diff --git a/LeanPool.lean b/LeanPool.lean index a2da06359d..67e116b9e9 100644 --- a/LeanPool.lean +++ b/LeanPool.lean @@ -7227,6 +7227,844 @@ public import LeanPool.Redhill.Odd.Pell public import LeanPool.Redhill.Odd.Subsum public import LeanPool.Redhill.ToMathlib.NatAbs public import LeanPool.Redhill.ToMathlib.NatSumProd +public import LeanPool.RegtsSevenster +public import LeanPool.RegtsSevenster.RS +public import LeanPool.RegtsSevenster.RS.Assembly.Blueprint +public import LeanPool.RegtsSevenster.RS.Assembly.BlueprintConverse +public import LeanPool.RegtsSevenster.RS.Assembly.BlueprintDeligne +public import LeanPool.RegtsSevenster.RS.Assembly.BlueprintFactorial +public import LeanPool.RegtsSevenster.RS.Assembly.BlueprintSchur +public import LeanPool.RegtsSevenster.RS.Assembly.BlueprintStatement +public import LeanPool.RegtsSevenster.RS.Classical +public import LeanPool.RegtsSevenster.RS.Classical.Algebra.FactorialTrace +public import LeanPool.RegtsSevenster.RS.Classical.Algebra.TraceCriterion +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Growth +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Intertwine +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.KaroubiLinear +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.KaroubiTrace +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Length +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LengthBound +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LinearCategory +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.PartialTrace +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.TensorPow +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Trace +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.UnitEnd +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive +public import LeanPool.RegtsSevenster.RS.Classical.Deligne +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPowAct +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeAdjoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeCoherence +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeFree +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeLinear +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTransport +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeZigzag +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensorUnit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodTransfer +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BlockUnits +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BraidCoherence +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainB +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGr +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGraded +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGradedLaws +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBInd +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBNonzero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBofA +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBridge +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainDelta +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.Base +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.FirstSlot +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.SecondSlot +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMul +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulHet +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulLaws +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainNonzero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainShift +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainStage2 +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainUnit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CharSplit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CommonAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoprodPreserve +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescent +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescentClose +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableNullstellensatz +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoverFactor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CycleSplit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DayCalculus +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DayType +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DeligneAssembly +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DescentClose +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DevissageBound +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledAbelian +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledGrowth +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledLine +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledScalar +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledSmall +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledSplit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Doubling +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DualityMate +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.EvenEmbedMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ExactFromShort +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FactorialBeats +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreAdditive +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreBridge +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreEps +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreExact +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreFaithful +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreFunctor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreLinear +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMix +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMu +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMuNat +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverComplex +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverSplitting +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreRestrict +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreStrong +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FiltNil +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FlatLimit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeCollapseAlg +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeMixRetract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModAdjoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModFunctor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffleCoh +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormalise +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormaliseBase +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormaliseStep +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowDesc +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowInsert +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeSlide +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeSummand +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeTwistPi +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaComplex +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaCountable +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModule +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModuleFunctor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPair +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairAdd +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairFreeFree +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairFreeMix +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairNat +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetractRight +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairUnit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaShift +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaTwistLeft +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GeneratorAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GrowthDichotomy +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.HomFinite +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.HookMult +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.HookZero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IdemCut +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IdempotentLength +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ImageSubalgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndAllColim +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndBigTensorUnit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCoeq +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCompact +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndDayClosure +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndImage +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndKill +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndLocallyMixed +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfLinear +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndPointTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchur +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchurKilled +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSimple +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplitSection +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndTensorExact +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndUnitNonzero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitState +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.InterchangeAct +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KernelPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaClose +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaData +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KillerNonempty +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KronKill +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.LambdaCoend +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixDegenerate +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffle +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffleLine +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixSumPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixWhisker +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixWhiskerAll +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedConc +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedDiag +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedTransport +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAbelian +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAssoc +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModContractL +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModCross +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModDual +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModIns +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMulti +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMultiTriple +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowCast +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowDescent +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowDescentClose +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowStage +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchur +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchurSummand +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModZero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MuInterchange +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MulBy +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.NatChain +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.NewtonConv +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.NullPoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLineMap +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLinePairing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddParity +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddPermSign +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddSquare +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddSquareIso +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairCarrier +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairMul +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairPerm +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermNat +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermRepChar +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PlainShuffle +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointBaseChange +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointFibre +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Calculus +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Coherence +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Comparison +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Functor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Residue +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowAct +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowActMul +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowChain +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowCopairing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowInduct +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowMerge +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairSucc +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSucc +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSuccMod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowTriangle +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZig +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZigzag +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PresentedQuotient +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21 +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21Core +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21General +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29Close +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29State +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210 +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Bridge +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Chain +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Close +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Ind +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Reduce +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.RegularSum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.RhoBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.RhoTwist +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.RowColIdem +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichMerge +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichRetract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichZig +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarBraiding +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitEquiv +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitInd +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurTransport +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SeedIns +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ShapeAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ShapeFintype +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SignConj +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleGenerator +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimplePoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleQuotient +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleScalars +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleSplit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SmallReduction +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAdjoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAssemble +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitClosure +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitComplement +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitEverything +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExact +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtractDual +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitMonHom +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitPairDef +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitReduce +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitTransport +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplittingAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.StateTransport +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepA +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepATransport +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepB +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Letters +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Signs +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Standard +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEvenRing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperGamma +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperGammaInst +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModAbelian +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprodMap +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModIso +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShift +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShiftUnit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperPointMod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperRealize +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSeries +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSmall +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperValues +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperVectSchur +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymAlg +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymMul +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorExact +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorPowZero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorTransfer +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorZigzag +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TrichotomyClose +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistCoherence +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistFreeTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistMixLine +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistShuffle +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistState +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistSymPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistUnitor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitBase +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitFreeMod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitMod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitSimple +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitStage +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UniversalAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.WhiskerFaithful +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.WordMap +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZagAction +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagCarrier +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagNonzero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagSandwich +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransfer +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransferIso +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneBridge +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackageRestrict +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneTheorem +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.EulerianIndependence +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.FibreTransport +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.KoszulAction +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaPerm +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaTensorPower +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SectorDischarge +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SectorIntertwine +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.TotalDimension +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BlockKill +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BranchTrace +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CentralElem +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharClass +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharDecomp +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharEquiv +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourCycleSum +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourWeight +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CommutantBound +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ContentCount +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleFactor +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleSum +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleSumPrep +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.EndSum +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FibreCard +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FixWeight +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.HVal +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.IdempotentBridge +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTChar +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTIntChar +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTIrreducible +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTOrtho +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTPad +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTSimple +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.KillSimples +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedCount +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedFixed +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeAction +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeFaithful +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeTable +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.OrbitBridge +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.Package +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PackageAssembly +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairChar +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairInner +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairOrbit +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairStab +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairTuple +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairingPos +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PermModule +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PowerSurj +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.RegularTrace +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SameCycleQuot +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ScalarTrace +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SchurAction +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SigmaCycleType +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignResolve +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignedTensor +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SimpleEmbed +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowth +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowthSharp +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareStair +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.StabCount +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorNonvanishing +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorTrace +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.WordCommutant +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourAction +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConj +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjStep +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjTop +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourEval +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourExtendSwap +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourFormMatch +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMerge +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMergeOdd +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairing +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairingSymm +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPower +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourTotal +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourWord +public import LeanPool.RegtsSevenster.RS.Classical.Super.OrthonormalBasis +public import LeanPool.RegtsSevenster.RS.Classical.Super.PowBraid +public import LeanPool.RegtsSevenster.RS.Classical.Super.SuperVect +public import LeanPool.RegtsSevenster.RS.Classical.Super.SymplecticBasis +public import LeanPool.RegtsSevenster.RS.Classical.Super.TotalSpace +public import LeanPool.RegtsSevenster.RS.Classical.Super.WordSignPerm +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantExpand +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantPieri +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantStrict +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.Bialternant +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialDet +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialH +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffExtract +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffSplit +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.DeltaSeq +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.DescVandermonde +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.DimFormula +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.EHConv +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.EHDischarge +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HInsert +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HProdCoeff +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HSubZ +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HookVanishing +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.JTDetExpand +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.JTGuard +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.LGVStrict +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PieriChain +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowCount +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.RationalityFromRecurrence +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.RecurrenceFromVanishing +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.SubsetEH +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.TCount +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.TIdentity +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaExp +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaRational +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaSeries +public import LeanPool.RegtsSevenster.RS.Common +public import LeanPool.RegtsSevenster.RS.Common.DiagramChain +public import LeanPool.RegtsSevenster.RS.Common.ExponentialGrowth +public import LeanPool.RegtsSevenster.RS.Common.FactorialBound +public import LeanPool.RegtsSevenster.RS.Common.FinSlots +public import LeanPool.RegtsSevenster.RS.Common.ListAttach +public import LeanPool.RegtsSevenster.RS.Common.ListPairs +public import LeanPool.RegtsSevenster.RS.Common.ListSign +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +public import LeanPool.RegtsSevenster.RS.Common.NilpotentMap +public import LeanPool.RegtsSevenster.RS.Common.NilpotentPowerTrace +public import LeanPool.RegtsSevenster.RS.Common.PairDisjoint +public import LeanPool.RegtsSevenster.RS.Common.PermCongr +public import LeanPool.RegtsSevenster.RS.Common.PermTopSplit +public import LeanPool.RegtsSevenster.RS.Common.ProdSum +public import LeanPool.RegtsSevenster.RS.Common.RowLenChain +public import LeanPool.RegtsSevenster.RS.Common.RowSpanRank +public import LeanPool.RegtsSevenster.RS.Common.TraceSeparation +public import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams +public import LeanPool.RegtsSevenster.RS.Definitions +public import LeanPool.RegtsSevenster.RS.DimensionDefinitions +public import LeanPool.RegtsSevenster.RS.Glossary +public import LeanPool.RegtsSevenster.RS.Novel +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjSwapBmc +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjacentWord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisCoord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisSplit +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaData +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiag +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiagForm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaFlip +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockAlign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockCanon +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockData +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockOddList +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockParity +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockRestrict +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSigma +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSort +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BraidWord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonColour +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapClosed +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapExpansion +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapFun +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapMatch +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeel +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeelSplit +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapSplit +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapVal +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ChainLists +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleModel +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleScalar +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircuitCount +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ClosedTransition +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ConcatSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordInterface +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordOf +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoreParity +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EdgeSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvForm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvFormOdd +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvLeaf +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FibreParam +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FlagEnum +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.GlobalSlotList +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.HRS +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.IndexPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ListSignPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MasterSum +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelCoord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelPermCoord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelStarVec +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MultiStar +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFDef +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFValue +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddFlip +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddListMultiset +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddPair +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddSignProd +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaCotensor +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaStarVec +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTensor +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTransport +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OneBasis +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OrbitCard +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OutSignEdges +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairEnum +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairList +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ParameterModel +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PatternInv +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PowMerge +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RegroupSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.Reindex +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexHeart +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexVanish +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RepFlag +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RiffleSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SignPair +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SkeinPowBraid +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SlotPairing +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortFactor +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarClassFactor +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPeel +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarRepeat +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarSymm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarTensorClass +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StdTransport +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StrandTransport +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauCount +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauKey +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TopBraidMerge +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TwoBasis +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexValue +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.AtomDichotomy +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.AtomicIdempotents +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockAssembly +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockBounds +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockCycle +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactor +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactorialTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockSplice +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockTower +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleNormal +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvAbelian +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDeligne +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDelignePackage +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGenerator +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGrowth +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvInstances +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvSemisimple +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.FactorialTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.Frobenius +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinement +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinementSharp +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiEmbBraided +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiMonoidal +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiRigid +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiSemisimple +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatBraided +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatEmbMonoidal +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatMonoidal +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatRigid +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatSemisimple +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentMatTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.ObjectTower +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.PermTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.RankDimension +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarPermTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleAll +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleEnd +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinDimBound +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SuperKill +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPerm +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPermCast +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowHom +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowSplit +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZeta +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZetaSharp +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.CircleValue +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.CoordIso +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.Coordinates +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.CopairUnique +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.Nondegenerate +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.SnakeTransport +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdDuality +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdRigid +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdSuper +public import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalAgreement +public import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalIndependence +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedNat +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleClose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleMapClasses +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleTensor +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonExistence +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonTransport +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonicalFrame +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChainAgreement +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordCount +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordLabels +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordParity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordSwapParity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotateLeft +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseUnion +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedAgreement +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedCutDispatch +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedIdentify +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedTopSum +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourEmbedding +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourGlue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourPadding +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourRecursion +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeNormal +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeRelabel +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Composition +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseAssembly +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseDischarge +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseFamily +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseGram +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseIdentity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseLift +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConversePair +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseTrip +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CrossingDelta +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CutMatching +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CutSubsetSum +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DirMatching +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjSubsetSplit +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.A +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.B +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.C +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionProduct +public import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeColouring +public import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeSum +public import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeTerm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Eulerian +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ExactPairingInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FibreValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FlagGraph +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignForm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignProduct +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FourLabelParity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FragmentEquiv +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GenBoundaryStates +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueAmbient +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChord +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChords +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCircuitDelta +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueComm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCrossDelta +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueFold +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueLedger +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GluePathMatch +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueRelTransport +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplit +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof.A +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof.C +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSubsetBij +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GramRank +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomCompose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomSpaces +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTensor +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceCyclic +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceNondegenerate +public import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLaw +public import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLawRight +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceAlternate +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceContract +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceCut +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceOrderIso +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceShift +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InvolutionCard +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LabelChords +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerCast +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerRecursion +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerSets +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerStage +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopExample +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopVerify +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalNat +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalStruct +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Multiplicativity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.NonSeparatedStep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.OpenCircuits +public import LeanPool.RegtsSevenster.RS.Novel.Skein.OrbitParities +public import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientExistence +public import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientationFlip +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairCloseComm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairedAssembly +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingConnectivity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSignature +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSwap +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialClose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseCompose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseTensor +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathCanon +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathMatch +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PermCompose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PermFragment +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PropThreeOpen +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RSTensor +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelTransition +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelChords +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelInvariance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RepairInvariance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidityClasses +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarClass +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarFunctional +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SeparatedParity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SimpleUnit +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCategory +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdealLeft +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinLinear +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SnakeClasses +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarCompClass +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarDecomposition +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarEnum +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarExplode +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarPrep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarTrace +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StateFlipSet +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StatusSet +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepFrame +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepLedger +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatus +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatusNonsep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StrandBundle +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SumLexOrder +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperGram +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperSpace +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorAssoc +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorComm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorCompClass +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorIdeal +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorInterchange +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorUnit +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughEdgeCut +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughIndCFalse +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Trace +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceNondegenerate +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionMove +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransposeLedger +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathNonSep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathStep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexOddSign +public import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexSum +public import LeanPool.RegtsSevenster.RS.QuantSector +public import LeanPool.RegtsSevenster.RS.StatementConverse +public import LeanPool.RegtsSevenster.RS.Summit +public import LeanPool.RegtsSevenster.RS.TheoremConverse +public import LeanPool.RegtsSevenster.RS.TheoremDimension +public import LeanPool.RegtsSevenster.RS.TheoremForward +public import LeanPool.RegtsSevenster.RS.TheoremPadding +public import LeanPool.RegtsSevenster.RS.TheoremQuant +public import LeanPool.RegtsSevenster.RS.TheoremTotal +public import LeanPool.RegtsSevenster.Solution public import LeanPool.RellichKondrachov public import LeanPool.RellichKondrachov.Analysis.Calculus.ContDiff.Support public import LeanPool.RellichKondrachov.Analysis.FunctionalSpaces.Sobolev.Euclidean.H1 diff --git a/LeanPool/RegtsSevenster.lean b/LeanPool/RegtsSevenster.lean new file mode 100644 index 0000000000..02ef97a6f4 --- /dev/null +++ b/LeanPool/RegtsSevenster.lean @@ -0,0 +1,856 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS +public import LeanPool.RegtsSevenster.RS.Assembly.Blueprint +public import LeanPool.RegtsSevenster.RS.Assembly.BlueprintConverse +public import LeanPool.RegtsSevenster.RS.Assembly.BlueprintDeligne +public import LeanPool.RegtsSevenster.RS.Assembly.BlueprintFactorial +public import LeanPool.RegtsSevenster.RS.Assembly.BlueprintSchur +public import LeanPool.RegtsSevenster.RS.Assembly.BlueprintStatement +public import LeanPool.RegtsSevenster.RS.Classical +public import LeanPool.RegtsSevenster.RS.Classical.Algebra.FactorialTrace +public import LeanPool.RegtsSevenster.RS.Classical.Algebra.TraceCriterion +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Growth +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Intertwine +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.KaroubiLinear +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.KaroubiTrace +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Length +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LengthBound +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LinearCategory +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.PartialTrace +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.TensorPow +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Trace +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.UnitEnd +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive +public import LeanPool.RegtsSevenster.RS.Classical.Deligne +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPowAct +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeAdjoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeCoherence +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeFree +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeLinear +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTransport +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeZigzag +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensorUnit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodTransfer +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BlockUnits +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BraidCoherence +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainB +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGr +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGraded +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGradedLaws +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBInd +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBNonzero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBofA +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBridge +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainDelta +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.Base +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.FirstSlot +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.SecondSlot +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMul +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulHet +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulLaws +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainNonzero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainShift +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainStage2 +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainUnit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CharSplit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CommonAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoprodPreserve +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescent +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescentClose +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableNullstellensatz +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoverFactor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CycleSplit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DayCalculus +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DayType +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DeligneAssembly +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DescentClose +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DevissageBound +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledAbelian +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledGrowth +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledLine +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledScalar +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledSmall +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledSplit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Doubling +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DualityMate +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.EvenEmbedMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ExactFromShort +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FactorialBeats +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreAdditive +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreBridge +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreEps +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreExact +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreFaithful +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreFunctor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreLinear +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMix +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMu +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMuNat +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverComplex +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverSplitting +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreRestrict +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreStrong +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FiltNil +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FlatLimit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeCollapseAlg +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeMixRetract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModAdjoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModFunctor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffleCoh +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormalise +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormaliseBase +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormaliseStep +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowDesc +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowInsert +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeSlide +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeSummand +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeTwistPi +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaComplex +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaCountable +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModule +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModuleFunctor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPair +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairAdd +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairFreeFree +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairFreeMix +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairNat +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetractRight +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairUnit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaShift +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaTwistLeft +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GeneratorAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GrowthDichotomy +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.HomFinite +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.HookMult +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.HookZero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IdemCut +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IdempotentLength +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ImageSubalgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndAllColim +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndBigTensorUnit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCoeq +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCompact +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndDayClosure +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndImage +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndKill +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndLocallyMixed +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfLinear +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndPointTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchur +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchurKilled +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSimple +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplitSection +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndTensorExact +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndUnitNonzero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitState +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.InterchangeAct +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KernelPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaClose +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaData +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KillerNonempty +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KronKill +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.LambdaCoend +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixDegenerate +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffle +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffleLine +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixSumPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixWhisker +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixWhiskerAll +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedConc +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedDiag +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedTransport +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAbelian +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAssoc +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModContractL +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModCross +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModDual +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModIns +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMulti +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMultiTriple +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowCast +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowDescent +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowDescentClose +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowStage +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchur +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchurSummand +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModZero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MuInterchange +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MulBy +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.NatChain +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.NewtonConv +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.NullPoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLineMap +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLinePairing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddParity +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddPermSign +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddSquare +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddSquareIso +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairCarrier +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairMul +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairPerm +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermNat +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermRepChar +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PlainShuffle +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointBaseChange +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointFibre +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Calculus +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Coherence +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Comparison +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Functor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Residue +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowAct +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowActMul +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowChain +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowCopairing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowInduct +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowMerge +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairSucc +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSucc +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSuccMod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowTriangle +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZig +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZigzag +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PresentedQuotient +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21 +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21Core +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21General +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29Close +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29State +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210 +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Bridge +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Chain +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Close +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Ind +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Reduce +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.RegularSum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.RhoBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.RhoTwist +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.RowColIdem +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichMerge +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichRetract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichZig +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarBraiding +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitEquiv +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitInd +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurTransport +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SeedIns +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ShapeAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ShapeFintype +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SignConj +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleGenerator +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimplePoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleQuotient +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleScalars +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleSplit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SmallReduction +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAdjoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAssemble +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitClosure +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitComplement +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitEverything +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExact +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtractDual +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitMonHom +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitPairDef +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitReduce +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitTransport +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplittingAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.StateTransport +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepA +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepATransport +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepB +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Letters +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Signs +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Standard +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEvenRing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperGamma +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperGammaInst +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModAbelian +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprodMap +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModIso +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShift +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShiftUnit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperPointMod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperRealize +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSeries +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSmall +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperValues +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperVectSchur +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymAlg +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymMul +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorExact +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorPowZero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorTransfer +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorZigzag +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TrichotomyClose +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistCoherence +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistFreeTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistMixLine +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistShuffle +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistState +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistSymPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistUnitor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitBase +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitFreeMod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitMod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitSimple +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitStage +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UniversalAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.WhiskerFaithful +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.WordMap +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZagAction +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagCarrier +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagNonzero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagSandwich +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransfer +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransferIso +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneBridge +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackageRestrict +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneTheorem +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.EulerianIndependence +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.FibreTransport +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.KoszulAction +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaPerm +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaTensorPower +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SectorDischarge +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SectorIntertwine +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.TotalDimension +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BlockKill +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BranchTrace +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CentralElem +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharClass +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharDecomp +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharEquiv +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourCycleSum +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourWeight +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CommutantBound +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ContentCount +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleFactor +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleSum +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleSumPrep +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.EndSum +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FibreCard +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FixWeight +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.HVal +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.IdempotentBridge +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTChar +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTIntChar +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTIrreducible +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTOrtho +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTPad +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTSimple +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.KillSimples +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedCount +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedFixed +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeAction +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeFaithful +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeTable +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.OrbitBridge +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.Package +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PackageAssembly +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairChar +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairInner +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairOrbit +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairStab +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairTuple +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairingPos +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PermModule +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PowerSurj +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.RegularTrace +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SameCycleQuot +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ScalarTrace +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SchurAction +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SigmaCycleType +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignResolve +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignedTensor +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SimpleEmbed +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowth +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowthSharp +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareStair +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.StabCount +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorNonvanishing +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorTrace +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.WordCommutant +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourAction +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConj +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjStep +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjTop +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourEval +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourExtendSwap +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourFormMatch +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMerge +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMergeOdd +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairing +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairingSymm +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPower +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourTotal +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourWord +public import LeanPool.RegtsSevenster.RS.Classical.Super.OrthonormalBasis +public import LeanPool.RegtsSevenster.RS.Classical.Super.PowBraid +public import LeanPool.RegtsSevenster.RS.Classical.Super.SuperVect +public import LeanPool.RegtsSevenster.RS.Classical.Super.SymplecticBasis +public import LeanPool.RegtsSevenster.RS.Classical.Super.TotalSpace +public import LeanPool.RegtsSevenster.RS.Classical.Super.WordSignPerm +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantExpand +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantPieri +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantStrict +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.Bialternant +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialDet +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialH +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffExtract +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffSplit +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.DeltaSeq +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.DescVandermonde +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.DimFormula +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.EHConv +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.EHDischarge +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HInsert +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HProdCoeff +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HSubZ +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HookVanishing +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.JTDetExpand +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.JTGuard +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.LGVStrict +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PieriChain +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowCount +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.RationalityFromRecurrence +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.RecurrenceFromVanishing +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.SubsetEH +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.TCount +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.TIdentity +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaExp +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaRational +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaSeries +public import LeanPool.RegtsSevenster.RS.Common +public import LeanPool.RegtsSevenster.RS.Common.DiagramChain +public import LeanPool.RegtsSevenster.RS.Common.ExponentialGrowth +public import LeanPool.RegtsSevenster.RS.Common.FactorialBound +public import LeanPool.RegtsSevenster.RS.Common.FinSlots +public import LeanPool.RegtsSevenster.RS.Common.ListAttach +public import LeanPool.RegtsSevenster.RS.Common.ListPairs +public import LeanPool.RegtsSevenster.RS.Common.ListSign +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +public import LeanPool.RegtsSevenster.RS.Common.NilpotentMap +public import LeanPool.RegtsSevenster.RS.Common.NilpotentPowerTrace +public import LeanPool.RegtsSevenster.RS.Common.PairDisjoint +public import LeanPool.RegtsSevenster.RS.Common.PermCongr +public import LeanPool.RegtsSevenster.RS.Common.PermTopSplit +public import LeanPool.RegtsSevenster.RS.Common.ProdSum +public import LeanPool.RegtsSevenster.RS.Common.RowLenChain +public import LeanPool.RegtsSevenster.RS.Common.RowSpanRank +public import LeanPool.RegtsSevenster.RS.Common.TraceSeparation +public import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams +public import LeanPool.RegtsSevenster.RS.Definitions +public import LeanPool.RegtsSevenster.RS.DimensionDefinitions +public import LeanPool.RegtsSevenster.RS.Glossary +public import LeanPool.RegtsSevenster.RS.Novel +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjSwapBmc +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjacentWord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisCoord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisSplit +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaData +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiag +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiagForm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaFlip +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockAlign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockCanon +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockData +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockOddList +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockParity +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockRestrict +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSigma +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSort +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BraidWord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonColour +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapClosed +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapExpansion +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapFun +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapMatch +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeel +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeelSplit +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapSplit +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapVal +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ChainLists +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleModel +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleScalar +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircuitCount +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ClosedTransition +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ConcatSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordInterface +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordOf +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoreParity +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EdgeSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvForm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvFormOdd +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvLeaf +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FibreParam +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FlagEnum +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.GlobalSlotList +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.HRS +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.IndexPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ListSignPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MasterSum +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelCoord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelPermCoord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelStarVec +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MultiStar +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFDef +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFValue +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddFlip +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddListMultiset +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddPair +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddSignProd +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaCotensor +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaStarVec +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTensor +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTransport +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OneBasis +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OrbitCard +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OutSignEdges +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairEnum +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairList +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ParameterModel +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PatternInv +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PowMerge +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RegroupSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.Reindex +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexHeart +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexVanish +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RepFlag +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RiffleSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SignPair +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SkeinPowBraid +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SlotPairing +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortFactor +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarClassFactor +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPeel +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarRepeat +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarSymm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarTensorClass +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StdTransport +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StrandTransport +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauCount +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauKey +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TopBraidMerge +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TwoBasis +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexValue +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.AtomDichotomy +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.AtomicIdempotents +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockAssembly +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockBounds +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockCycle +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactor +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactorialTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockSplice +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockTower +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleNormal +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvAbelian +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDeligne +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDelignePackage +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGenerator +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGrowth +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvInstances +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvSemisimple +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.FactorialTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.Frobenius +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinement +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinementSharp +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiEmbBraided +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiMonoidal +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiRigid +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiSemisimple +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatBraided +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatEmbMonoidal +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatMonoidal +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatRigid +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatSemisimple +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentMatTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.ObjectTower +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.PermTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.RankDimension +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarPermTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleAll +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleEnd +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinDimBound +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SuperKill +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPerm +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPermCast +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowHom +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowSplit +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZeta +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZetaSharp +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.CircleValue +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.CoordIso +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.Coordinates +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.CopairUnique +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.Nondegenerate +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.SnakeTransport +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdDuality +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdRigid +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdSuper +public import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalAgreement +public import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalIndependence +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedNat +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleClose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleMapClasses +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleTensor +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonExistence +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonTransport +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonicalFrame +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChainAgreement +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordCount +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordLabels +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordParity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordSwapParity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotateLeft +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseUnion +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedAgreement +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedCutDispatch +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedIdentify +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedTopSum +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourEmbedding +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourGlue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourPadding +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourRecursion +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeNormal +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeRelabel +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Composition +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseAssembly +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseDischarge +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseFamily +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseGram +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseIdentity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseLift +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConversePair +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseTrip +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CrossingDelta +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CutMatching +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CutSubsetSum +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DirMatching +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjSubsetSplit +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.A +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.B +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.C +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionProduct +public import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeColouring +public import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeSum +public import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeTerm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Eulerian +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ExactPairingInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FibreValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FlagGraph +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignForm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignProduct +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FourLabelParity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FragmentEquiv +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GenBoundaryStates +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueAmbient +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChord +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChords +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCircuitDelta +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueComm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCrossDelta +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueFold +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueLedger +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GluePathMatch +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueRelTransport +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplit +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof.A +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof.C +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSubsetBij +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GramRank +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomCompose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomSpaces +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTensor +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceCyclic +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceNondegenerate +public import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLaw +public import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLawRight +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceAlternate +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceContract +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceCut +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceOrderIso +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceShift +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InvolutionCard +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LabelChords +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerCast +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerRecursion +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerSets +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerStage +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopExample +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopVerify +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalNat +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalStruct +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Multiplicativity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.NonSeparatedStep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.OpenCircuits +public import LeanPool.RegtsSevenster.RS.Novel.Skein.OrbitParities +public import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientExistence +public import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientationFlip +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairCloseComm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairedAssembly +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingConnectivity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSignature +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSwap +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialClose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseCompose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseTensor +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathCanon +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathMatch +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PermCompose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PermFragment +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PropThreeOpen +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RSTensor +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelTransition +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelChords +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelInvariance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RepairInvariance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidityClasses +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarClass +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarFunctional +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SeparatedParity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SimpleUnit +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCategory +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdealLeft +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinLinear +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SnakeClasses +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarCompClass +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarDecomposition +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarEnum +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarExplode +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarPrep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarTrace +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StateFlipSet +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StatusSet +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepFrame +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepLedger +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatus +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatusNonsep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StrandBundle +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SumLexOrder +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperGram +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperSpace +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorAssoc +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorComm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorCompClass +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorIdeal +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorInterchange +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorUnit +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughEdgeCut +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughIndCFalse +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Trace +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceNondegenerate +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionMove +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransposeLedger +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathNonSep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathStep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexOddSign +public import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexSum +public import LeanPool.RegtsSevenster.RS.QuantSector +public import LeanPool.RegtsSevenster.RS.StatementConverse +public import LeanPool.RegtsSevenster.RS.Summit +public import LeanPool.RegtsSevenster.RS.TheoremConverse +public import LeanPool.RegtsSevenster.RS.TheoremDimension +public import LeanPool.RegtsSevenster.RS.TheoremForward +public import LeanPool.RegtsSevenster.RS.TheoremPadding +public import LeanPool.RegtsSevenster.RS.TheoremQuant +public import LeanPool.RegtsSevenster.RS.TheoremTotal +public import LeanPool.RegtsSevenster.Solution + +/-! +# A proof of the Regts–Sevenster conjecture, formalized + +Source: url:https://github.com/willwhistler/regts-sevenster +Authors: William Whistler +Status: verified +Main declarations: `RS.regts_sevenster_characterisation` +Tags: graph-parameters, tensor-categories, partition-functions +MSC: 05C50, 18M20 +-/ diff --git a/LeanPool/RegtsSevenster/RS.lean b/LeanPool/RegtsSevenster/RS.lean new file mode 100644 index 0000000000..ef26b01c71 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS.lean @@ -0,0 +1,30 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common +public import LeanPool.RegtsSevenster.RS.Classical +public import LeanPool.RegtsSevenster.RS.Novel +public import LeanPool.RegtsSevenster.RS.Definitions +public import LeanPool.RegtsSevenster.RS.StatementConverse +public import LeanPool.RegtsSevenster.RS.TheoremForward +public import LeanPool.RegtsSevenster.RS.TheoremQuant +public import LeanPool.RegtsSevenster.RS.TheoremTotal +public import LeanPool.RegtsSevenster.RS.TheoremConverse +public import LeanPool.RegtsSevenster.RS.QuantSector +public import LeanPool.RegtsSevenster.RS.Glossary +public import LeanPool.RegtsSevenster.RS.Assembly.BlueprintStatement +public import LeanPool.RegtsSevenster.RS.Assembly.Blueprint +public import LeanPool.RegtsSevenster.RS.Assembly.BlueprintConverse +public import LeanPool.RegtsSevenster.RS.Assembly.BlueprintSchur +public import LeanPool.RegtsSevenster.RS.Classical.Deligne +public import LeanPool.RegtsSevenster.RS.Summit +public import LeanPool.RegtsSevenster.RS.Assembly.BlueprintDeligne +public import LeanPool.RegtsSevenster.RS.Assembly.BlueprintFactorial +public import LeanPool.RegtsSevenster.RS.DimensionDefinitions +public import LeanPool.RegtsSevenster.RS.TheoremDimension +public import LeanPool.RegtsSevenster.RS.TheoremPadding diff --git a/LeanPool/RegtsSevenster/RS/Assembly/Blueprint.lean b/LeanPool/RegtsSevenster/RS/Assembly/Blueprint.lean new file mode 100644 index 0000000000..c4e3a4ea81 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Assembly/Blueprint.lean @@ -0,0 +1,1046 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +public import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourCycleSum +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTOrtho +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignResolve +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeFaithful +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowth +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BranchTrace +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTPad +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PackageAssembly +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.Package +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairingPos +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZeta +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaExp +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowthSharp +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinementSharp +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinDimBound +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathMatch +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SuperKill +public import LeanPool.RegtsSevenster.RS.StatementConverse +public import LeanPool.RegtsSevenster.RS.TheoremQuant +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.LGVStrict +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedAgreement +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionMove +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueRelTransport +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjSubsetSplit +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceOrderIso +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelInvariance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCircuitDelta +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChainAgreement +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonExistence +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RepairInvariance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordParity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingConnectivity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepLedger +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InvolutionCard +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordCount +public import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalIndependence +public import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalAgreement +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseAssembly +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceAlternate +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseDischarge +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseGram +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransposeLedger +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathNonSep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonicalFrame +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepFrame +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StateFlipSet +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StatusSet +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CrossingDelta +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignProduct +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignForm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerSets +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatus +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatusNonsep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairedAssembly +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PropThreeOpen +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FourLabelParity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSwap +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSignature +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopVerify +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughIndCFalse +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordLabels +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LabelChords +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FibreValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChords +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GluePathMatch +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCrossDelta +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedCutDispatch +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughEdgeCut +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelChords +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordSwapParity +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.RecurrenceFromVanishing +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.RationalityFromRecurrence +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HookVanishing +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockBounds +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinement +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiMonoidal +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatMonoidal +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatBraided +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleEnd +public import LeanPool.RegtsSevenster.RS.Classical.Super.OrthonormalBasis +public import LeanPool.RegtsSevenster.RS.Classical.Super.SuperVect +public import LeanPool.RegtsSevenster.RS.Classical.Super.SymplecticBasis +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FlagGraph +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Composition +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FragmentEquiv +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StrandBundle +public import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLaw +public import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLawRight +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomSpaces +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Multiplicativity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Eulerian +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueAmbient +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueComm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotateLeft +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceShift +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairCloseComm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SimpleUnit +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdealLeft +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomCompose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCategory +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceNondegenerate +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinLinear +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceCyclic +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarDecomposition +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeNormal +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueFold +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PermFragment +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PermCompose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Trace +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceNondegenerate +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorIdeal +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorComm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTensor +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorAssoc +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorUnit +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseTensor +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseUnion +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeRelabel +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseCompose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarClass +public import LeanPool.RegtsSevenster.RS.Definitions +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.CircleValue +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.CoordIso +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.Coordinates +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.CopairUnique +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.SnakeTransport +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.Nondegenerate +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdDuality +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdRigid +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdSuper +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneBridge +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneTheorem +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.FibreTransport +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.EulerianIndependence +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarTrace +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SnakeClasses +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourFormMatch +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairing +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairingSymm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorInterchange +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ExactPairingInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarCompClass +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTransport +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortFactor +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarClassFactor +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTensor +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaStarVec +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleModel +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BraidWord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarSymm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelStarVec +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ParameterModel +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjStep +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourWord +public import LeanPool.RegtsSevenster.RS.Classical.Super.WordSignPerm +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjTop +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourAction +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelPermCoord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapClosed +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MasterSum +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarRepeat +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.Reindex +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FibreParam +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockParity +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexVanish +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiagForm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockData +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RepFlag +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaData +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddFlip +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockAlign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PatternInv +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ListSignPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OutSignEdges +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EdgeSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddListMultiset +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddSignProd +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaFlip +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircuitCount +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairEnum +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FlagEnum +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.IndexPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauKey +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockCanon +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexValue +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockOddList +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauCount +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.GlobalSlotList +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ChainLists +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ConcatSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SignPair +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RiffleSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFDef +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RegroupSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoreParity +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFValue +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexHeart +public import LeanPool.RegtsSevenster.RS.TheoremForward +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapVal +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapSplit +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ClosedTransition +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelCoord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OneBasis +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvLeaf +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapExpansion +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeelSplit +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisCoord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiag +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SlotPairing +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TopBraidMerge +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TwoBasis +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDelignePackage + +/-! +# Blueprint: the axiom audit + +Every main theorem of the development carries a pinned +`#print axioms` line: an axiom set drifting from the whitelist +`[propext, Classical.choice, Quot.sound]` is a compile error, not a +reading exercise. + +**How to read it.** The sections group the categorical, Schur and +coordinate inputs to the forward theorem. The factorial mainline is +audited in `BlueprintFactorial.lean`. +Each pin names one theorem; the section it sits in says what that +theorem contributes. The converse is audited in +`BlueprintConverse.lean`, the symmetric-group input in +`BlueprintSchur.lean`, and the statement surface — every definition +the summits are phrased in — in `BlueprintStatement.lean`. +-/ + +/-! ### Hook vanishing and the power sums + +A tower whose hook-confined characters vanish has vanishing +super power sums, which is what makes the trace zeta rational. +-/ + +/- Upstream audit output: 'RS.superPowerSums_of_hook_vanishing' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.powerSums_zero_of_eventually_zero' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/-! ### Hook confinement and nilpotent traces + +Exponentially bounded growth confines the surviving Young diagrams +to a hook, nilpotents then have vanishing trace, and the trace +criterion makes every endomorphism algebra semisimple. +-/ + +/- Upstream audit output: 'RS.PermTower.hook_confinement' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.FrobeniusTower.traceA_eq_zero_of_isNilpotent' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.isSemisimpleRing_of_trace' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/-! ### The classical bases + +The symplectic and orthonormal standard bases the super model is +written in. +-/ + +/- Upstream audit output: 'RS.exists_symplectic_basis' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.exists_orthonormal_basis' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/-! ### Definition 5 and its transport + +The mixed partition value of an edge subset, and its invariance +under a fragment equivalence. +-/ + +/- Upstream audit output: 'RS.EdgeSubset.mixedSummand_transport' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.mixedPartition_transport' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/-! ### The hypothesis class + +The edge-rank hypothesis bounds the dimension of a row span; the +literature bounds the ranks of the finite submatrices of the +connection matrix. The two are the same condition. +-/ + +/- Upstream audit output: 'RS.edgeRankBounded_iff_submatrixRank' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/-! ### The gluing calculus + +Gluing a list of label pairs: permuting the list, appending, +normalising an interface, and the existence of transition data. +-/ + +/- Upstream audit output: 'RS.Fragment.glueListPerm' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.glueInterfaceNormal' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.Fragment.glueListAppend' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeRankParameter.val_union' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.exists_transition_orientation' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.RegtsSevensterStatement' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.composeStrandBundleLeft' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.Fragment.gluePairComm' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.composeStrandBundleRight' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/-! ### Coordinates and the standard model + +Contraction families, the standard form and copairing, and the +coordinates a nondegenerate pairing gives. +-/ + +/- Upstream audit output: 'RS.exists_coordinates' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.exists_contraction_families' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.exists_coordinates_of_snake' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.exists_std_iso' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.stdCopair_unique' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.exists_std_model' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.stdForm_comp_stdCopair' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/-! ### Gluing across a disjoint union + +The glue list distributes over a disjoint union and commutes with +swaps and folds — the associativity engine of the category. +-/ + +/- Upstream audit output: 'RS.Fragment.glueListDisjUnionLeft' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.Fragment.glueListDisjUnionRight' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.Fragment.glueListSwap' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.composeAssoc' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.pairCloseComposeRotate' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.pairCloseComposeRotateLeft' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.composeFinsupp_ker_left' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.composeFinsupp_ker_right' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.HomSpace.comp_ofFragment' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.HomSpace.comp_assoc' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.HomSpace.comp_id_left' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.HomSpace.comp_id_right' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.HomSpace.eq_zero_of_traces_vanish' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.skeinCategory' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.starDecomposition' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.homSpace_zero_spanned' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.interfaceShift' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.Fragment.pairCloseComm' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/-! ### The exact pairing + +The self-duality of the standard model, and that it is braided. +-/ + +/- Upstream audit output: 'RS.ExactPairing.map' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.braided_std_model' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/-! ### The trace calculus + +Closing a fragment against the strand bundle: relabels cross it, +tensors absorb, and permutation fragments compose. +-/ + +/- Upstream audit output: 'RS.pairCloseRelabel' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.fragTrace_comm' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.permFragmentCompose' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.mem_ker_of_traces_vanish' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.pairCloseTensorAbsorb' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.tensorFinsupp_ker_left' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.tensorFinsupp_ker_right' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.HomSpace.tensor_ofFragment' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.tensorFragmentAssoc' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.tensorFragmentUnitLeft' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.tensorFragmentUnitRight' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/-! ### The braided envelope + +The Karoubi and matrix envelopes inherit the braiding and its +symmetry. +-/ + +/- Upstream audit output: 'RS.karoubiBraided' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.karoubiSymmetric' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.matBraided' depends on axioms: [propext, Classical.choice, Quot.sound] + -/ + +/- Upstream audit output: 'RS.matSymmetric' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/-! ### The skein category + +Linear, monoidal and rigid structure on the skein category, and +the trace map it carries. +-/ + +/- Upstream audit output: 'RS.skeinPreadditive' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.skeinLinear' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.HomSpace.traceMap_comp_comm' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.partialCloseTensor' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.pairCloseUnionRight' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.fragTrace_tensor' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.composeRelabelOut' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.composePermFragment' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.partialCloseEqCompose' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.ofFragment_eq_smul_empty' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.pairCloseStrandBundle' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.starDecomposition' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.snake_left' depends on axioms: [propext, Classical.choice, Quot.sound] + -/ + +/- Upstream audit output: 'RS.snake_right' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.braid_comp_evClass' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.Fragment.tensorComposeInterchange' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.skeinMonoidal' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.skeinBraided' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.skeinSymmetric' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.strandExactPairing' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.strand_ev_symmetry' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.star_comp_class' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/-! ### The coordinate model + +The fibre functor's image of a star, the standard model it is +identified with, and the transport between them. +-/ + +/- Upstream audit output: 'RS.omega_star_scalar' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.skein_std_model' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.starUnionFactor' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.starClass_factor' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.omegaVec_tensor' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.parameter_star_factor' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.circleVal_model' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.stdFromOmega_stdToOmega' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.adjWord_spec' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.stdToOmega_powBraid' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.stdToOmega_bmc_perm' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.bundleCapClass_peel' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.point_cotensor' depends on axioms: [propext, Quot.sound] -/ + +/- Upstream audit output: 'RS.omegaFun_tensor' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.evForm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.vertexStarClass_perm' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.stdToOmega_merge' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.stdToOmega_modelStarVec' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.toColour_whisker' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.parameter_model' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.colourExtend_colourSwap' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.colourSwapWord_evenMap' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.parameter_capVal' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.ClosedFragment.eulerian_transition_nonempty' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.omegaFun_capTensor_merge' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.omegaFun_tensor_oddPair' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.colourMerge_coord' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.colourMerge_coord_oddPair' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.coordOf_modelStarVec' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.evenBasisVec_split' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.evFormOdd' depends on axioms: [propext, Classical.choice, Quot.sound] + -/ + +/- Upstream audit output: 'RS.stdToOmega_one' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.stdToOmega_one_even' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.stdToOmega_one_odd' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.evenBasisVec_one' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.oddBasisVec_one' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.stdForm_evenPair' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.stdForm_oddPair' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.omegaFun_ev_basis' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.capVal_expansion' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.splitCapVal_expansion' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.splitCapVal_merge' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.capVal_succ' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.coordOf_evenBasisVec' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.splitCapVal_oddMerge' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.peelColour_spec' depends on axioms: [propext, Quot.sound] -/ + +/- Upstream audit output: 'RS.eq_peelColour_of' depends on axioms: [propext, Quot.sound] -/ + +/- Upstream audit output: 'RS.peelColour_isEven' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.pairing_starFlagEnum_symm' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.powMerge_topBraid' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.wordSign_eq_oddInversions' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.toColour_topBraid' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.toColour_powBraid' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.toColour_powBraidWord' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/-! ### The master colour sum + +The parameter as a sum over colourings: the star coordinates, the +diagonal cap pairing, every sign family, and the reindexing that +turns the sum into Definition 5. +-/ + +/- Upstream audit output: 'RS.wordPerm_adjWord' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.coordOf_modelPermMap' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.coordOf_modelPermMap'' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.capVal_closed' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.parameter_colour_sum' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.starVec_perm' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.stdFromOmega_perm' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.starCoord_perm' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.oddInversions_adjacent' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.starCoord_repeat_zero' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.parameter_masterSummand' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.masterSum_partition' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.colourFlags_pairing_mem' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.colourFlags_colouringOf' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.card_even' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.colouringOf_isEven' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.colouringOf_diagonal' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.blockRestrict_parity' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.masterSummand_vanish_of_block_odd' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.masterSummand_vanish_of_not_eulerian' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.mem_colourFlags_iff' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.starFlagEnum_pairing_low' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.starFlagEnum_pairing_high' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.oddDataOf_constancy' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.evenDataOf_constancy' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.betaDiag_eq_betaColour' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.betaColour_perm'' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.masterSummand_vanish_of_impure' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.masterSummand_vanish_of_not_closed' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.colouringOf_reconstruct' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.oddColouringOf_colouringOf' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.evenColouringOf_colouringOf' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.masterSummand_vanish_of_not_diagonal' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.pairPure_of_pattern_closed' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.fibreSum_eq_dataSum' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.koszulCrossings_colouringOf' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.image_blockFlag' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.blockRestrict_colouringOf' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.blockRestrict_colouringOf_isRight' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.repFlag_pairing' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.outRepSet_pairing_mem' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.colourFormEntry_inr_partner' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.betaDiag_colouringOf' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.evenColoursAt_blockVertex' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.OddColouring.sum_flip' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.blockRestrict_colouringOfFlip_mem' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.map_flagsAt_blockVertex' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.oddInversions_colouringOf' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.sortSign_ofFn_comp_perm' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.prod_out_sign_eq_prod_edges' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.edge_sign_sector' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.oddListAt_coe_multiset' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.prod_oddSignAt' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.betaDiag_colouringOfFlip' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- +info: 'RS.EdgeSubset.TransitionSystem.circuitCount_eq_orbitCount_outPerm' depends on axioms: + [propext, + Classical.choice, + Quot.sound] +-/ + +/- Upstream audit output: 'RS.EdgeSubset.TransitionSystem.neg_one_pow_circuitCount' depends on + axioms: [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.oddListAt_eq_map' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.pairFlagList_nodup' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.mem_blockOddFlagList_iff_pairFlagList' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.prod_blockVertex' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.sortSign_map_listIndexPerm' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.sign_listIndexPerm_trans' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.sortSign_pairFlagList_key' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.exists_canonPerm' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.oddListOf_blockRestrict' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.evenMultisetOf_blockRestrict' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.starCoord_block_flip_nodup' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.starCoord_block_flip_not_nodup' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.oddListOf_blockRestrict_eq_map' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.vertex_sign_collapse' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.patternOddInv_eq_inversions' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.sortSign_globalPairList' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.sign_listIndexPerm_slot_edge' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.sign_listIndexPerm_edge_oriented' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.hMaster_vertex_nodup' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.defFiveNF_eq_flip' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.sign_listIndexPerm_oriented_matched' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.sign_listIndexPerm_matched_global' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.core_parity' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.grand_parity' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.masterSummand_colouringOfFlip' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.fibreSum_eq' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.parameter_eq_mixedPartition' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.hMaster_colouringOfFlip' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.mixedSummand_eq_nf' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.eulerian_independence_closed' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.mixedValue_eq_summand_closed' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/-! ### Deligne's hypotheses for the envelope + +Each hypothesis of the cited theorem, discharged for the concrete +envelope, and the package they assemble into. +-/ + +/- Upstream audit output: 'RS.env_deligneSemisimple' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.env_deligneGenerated' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.env_deligneModerateGrowth' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.env_delignePackage' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.skein_delignePackage' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/-! ### The forward theorem -/ diff --git a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintConverse.lean b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintConverse.lean new file mode 100644 index 0000000000..7d9082b627 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintConverse.lean @@ -0,0 +1,182 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Assembly.BlueprintSchur +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopExample +public import LeanPool.RegtsSevenster.RS.TheoremConverse + +/-! +# Blueprint: the converse audit + +The third part of the axiom audit: the chord diagram of a boundary +pairing, the super Gram identity, the interface lift, and the +converse itself. The prose between pins says what each step +contributes; read `Blueprint.lean` first for the forward direction. +-/ + +/-! ### Chords of the boundary pairing + +A subset's boundary flags pair up into chords; the involution +that records them, extended by the identity off the used labels, +is what the Koszul sign is read from. +-/ + +/- Upstream audit output: 'RS.EdgeSubset.pathMatch_eq_pairing_of_boundary' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +-- Boundary flags carry distinct labels, so a subset has at most as +-- many as the interface has labels. With the parity above, one label +-- leaves the boundary unused and forces a surviving state into the +-- even sector. + +-- A matching state's odd labels are in bijection with the subset's +-- boundary flags, so there is an even number of them -- which is +-- exactly what the Koszul sign's exponent is handed. + +-- The out-end test asks for an odd colour, so an everywhere-even state +-- is its own twist and carries no sign: there the conjugated kernel is +-- the plain Koszul kernel at the raw states. + +-- So the Koszul sign is read off the chord diagram: at a matching +-- state it is (-1) to the number of chords of the very diagram the cut +-- signs are computed from. + +-- Crossing asks for a strict interleaving, so a chord with equal ends +-- crosses nothing and nothing crosses it: an involution extended by +-- the identity off a subset has the crossing count of its genuine +-- chords alone. + +-- Chords pair up the labels a subset uses; extending by the identity +-- off those labels gives an involution of the whole interface, whose +-- genuine chords are the subset's and whose fixed points are the +-- unused labels. This is what the restriction transports apply to. + +/- Upstream audit output: 'RS.EdgeSubset.boundaryFlag_chordInv' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.chordInv_mem' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.chordInv_invol' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.chordInv_ne' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +-- At a used label the two chord descriptions coincide -- the +-- involution's chord is the sorted pair the diagram records -- and at +-- an unused one the involution's chord is degenerate, hence inert. + +/- Upstream audit output: 'RS.EdgeSubset.boundaryLabel_boundaryFlag' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +-- The cycle data is permutation-theoretic and reads no order, so +-- conjugating both involutions by a bijection carries the walk, its +-- return time and its label set across, and the cycle count is +-- unchanged. + +/-! ### The Gram identity + +The connection matrix of a parameter with a super Gram +factorization has bounded rank, which is the converse's engine. +-/ + +/- Upstream audit output: 'RS.converse_of_superGram' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.converse_of_superGramIdentity' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.exists_sum_sum_superForm_tFull' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.exists_sum_sum_superForm_tensorTermAt' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +/-! ### The interface lift + +Transition data carried up the gluing interface one cut at a time +and back down: the lift, the two glue branches, and the round +trip on directions and on the matching. +-/ + +/- Upstream audit output: 'RS.EdgeSubset.sign_composition_pair' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.chainDir_pushData_alternates' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.edgeSum_closeBase_eq_pairAgreeValue' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.liftData' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.glueDataOpen' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.glueDataClosed' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.match_unglue_glueDataOpen' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.isOut_unglue_glueDataOpen' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.match_unglue_glueDataClosed' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.isOut_unglue_glueDataClosed' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.edgeTermAt_pushData_colourSum' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/-! ### The base sum and the converse + +The subset sum over the composition's base, its independence of +the free bits, and the theorems of record. +-/ + +/- Upstream audit output: 'RS.EdgeSubset.summandSum_bits_indep' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.baseSumBitsOf_all' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.baseSumIsClosure_all' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.superGramIdentity' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.regts_sevenster_converse' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.regts_sevenster_iff' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.regts_sevenster_quant_roundtrip' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/-! ### Definition 5, evaluated + +The paper's worked example: the loop graph against the functional +whose mixed partition function is the characteristic polynomial. +Its value `θ − 2` fixes the loop's two incidences, the Eulerian +condition, the circuit sign and the `η`-convention all at once; +adjoining a free circle sends the same functional to `0`, which +fixes the loop/free-circle distinction. +-/ + +/- Upstream audit output: 'RS.mixedPartition_loopGraph' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.mixedPartition_loopGraphCircle' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ diff --git a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintDeligne.lean b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintDeligne.lean new file mode 100644 index 0000000000..6a489719da --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintDeligne.lean @@ -0,0 +1,91 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Summit + +/-! +# Audit: Deligne's theorem and the unconditional summit + +The pinned axiom checks for Deligne’s theorem and the unconditional +summit statements. Each `#guard_msgs` +fails the build if the axiom set changes, so the claim that these +depend on nothing beyond `propext`, `Classical.choice` and +`Quot.sound` is checked rather than asserted. +-/ + +@[expose] public section + +namespace RS + +/-! ### Deligne's theorem -/ + +/- Upstream audit output: 'RS.deligne_theorem' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.braidedFibreHypothesis' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.exists_splitting_simple_algebra_doubled' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.exists_simple_quotient' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/-! ### The summit, unconditionally -/ + +/- Upstream audit output: 'RS.regts_sevenster' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.regts_sevenster_quant' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.regts_sevenster_total' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.regts_sevenster_characterisation' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.regts_sevenster_quant_characterisation' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/-! ### Minimum dimensions, growth and padding -/ + +/- Upstream audit output: 'RS.minimumColourDimension_le_of_represents' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.TotalBoundedMixedModel.dimension_eq_minimum' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.stdModel_dimension_eq_minimum' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.stdModel_connectionRank_growth' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.MixedColourEmbedding.mixedPartition_extendColours' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.MixedFunctional.padColours_represents' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.TotalBoundedMixedModel.even_dimension_eq' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.TotalBoundedMixedModel.half_odd_dimension_eq' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.regts_sevenster_minimum' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.regts_sevenster_rank_growth' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.regts_sevenster_prescribed' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintFactorial.lean b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintFactorial.lean new file mode 100644 index 0000000000..bbc354dd46 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintFactorial.lean @@ -0,0 +1,281 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.FactorialTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiSemisimple +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.ObjectTower +public import LeanPool.RegtsSevenster.RS.Summit + +/-! +# Audit: the factorial route to nilpotent-trace vanishing + +The statements and axioms of the factorial obstruction are pinned +here. The final check traverses the types and proof bodies of the +factorial route, including opaque declarations, and rejects dependencies +on the Schur, hook-confinement, trace-zeta or Deligne engines. +Imported modules alone do not constitute a proof dependency. + +The appendix proof serves as a control: the same traversal must +find an excluded dependency in that proof. This audit checks +independence of the nilpotent-trace and semisimplicity lemmas. +The summit checks require the factorial theorem in their transitive +dependencies and exclude the appendix's nilpotent-trace and +trace-zeta mechanisms. Schur theory used by Deligne and by the +colour bounds is audited separately. +-/ + +@[expose] public section + +namespace RS + +/-! ### Statements -/ + +/- Upstream audit output: @SinglePowerTrace : {A : Type u_1} → [inst : Ring A] → [inst_1 : Algebra ℂ + A] → (A →ₗ[ℂ] ℂ) → A → Prop -/ + +/- Upstream audit output: @SinglePowerTrace.mk : ∀ {A : Type u_1} [inst : Ring A] [inst_1 : Algebra + ℂ A] {τ : A →ₗ[ℂ] ℂ} {y : A}, + τ y ≠ 0 → (∀ (m : ℕ), 2 ≤ m → τ (y ^ m) = 0) → SinglePowerTrace τ y -/ + +/- Upstream audit output: CycleTraceTower : (E : ℕ → Type u_1) → + [inst : (n : ℕ) → Ring (E n)] → + [(n : ℕ) → Algebra ℂ (E n)] → (A : Type u_2) → [inst : Ring A] → [Algebra ℂ A] → Type (max u_1 + u_2) -/ + +/- Upstream audit output: @CycleTraceTower.mk : {E : ℕ → Type u_1} → + [inst : (n : ℕ) → Ring (E n)] → + [inst_1 : (n : ℕ) → Algebra ℂ (E n)] → + {A : Type u_2} → + [inst_2 : Ring A] → + [inst_3 : Algebra ℂ A] → + (traceA : A →ₗ[ℂ] ℂ) → + (trace : (n : ℕ) → E n →ₗ[ℂ] ℂ) → + (rep : (n : ℕ) → Equiv.Perm (Fin n) →* E n) → + (pow : (n : ℕ) → A → E n) → + (∀ (n : ℕ) (π : Equiv.Perm (Fin n)) (g : A), + (trace n) ((rep n) π * pow n g) = + (Multiset.map (fun c => traceA (g ^ c)) π.cycleType).prod * + traceA g ^ (n - π.cycleType.sum)) → + CycleTraceTower E A -/ + +/- Upstream audit output: @CycleTraceTower.factorial_le_finrank : ∀ {E : ℕ → Type u_1} [inst : (n : + ℕ) → Ring (E n)] + [inst_1 : (n : ℕ) → Algebra ℂ (E n)] {A : Type u_2} [inst_2 : Ring A] [inst_3 : Algebra ℂ A] (T : + CycleTraceTower E A) + {g : A}, IsNilpotent g → T.traceA g ≠ 0 → ∀ (n : ℕ) [Module.Finite ℂ (E n)], n.factorial ≤ + Module.finrank ℂ (E n) -/ + +/- Upstream audit output: @CycleTraceTower.traceA_eq_zero_of_finrank_lt_factorial : ∀ {E : ℕ → Type + u_1} [inst : (n : ℕ) → Ring (E n)] + [inst_1 : (n : ℕ) → Algebra ℂ (E n)] {A : Type u_2} [inst_2 : Ring A] [inst_3 : Algebra ℂ A] (T : + CycleTraceTower E A) + {n : ℕ} [Module.Finite ℂ (E n)], Module.finrank ℂ (E n) < n.factorial → ∀ {g : A}, IsNilpotent g → + T.traceA g = 0 -/ + +/- Upstream audit output: @CycleTraceTower.traceA_eq_zero_of_exponential_bound : ∀ {E : ℕ → Type + u_1} [inst : (n : ℕ) → Ring (E n)] + [inst_1 : (n : ℕ) → Algebra ℂ (E n)] {A : Type u_2} [inst_2 : Ring A] [inst_3 : Algebra ℂ A] (T : + CycleTraceTower E A) + [∀ (n : ℕ), Module.Finite ℂ (E n)] (B : ℝ), + (∀ (n : ℕ), ↑(Module.finrank ℂ (E n)) ≤ B ^ n) → ∀ {g : A}, IsNilpotent g → T.traceA g = 0 -/ + +/- Upstream audit output: @scalarTrace_eq_zero_of_finrank_lt_factorial : ∀ {A : Type u_2} [inst : + CategoryTheory.Category.{u_1, u_2} A] + [inst_1 : CategoryTheory.MonoidalCategory A] [inst_2 : CategoryTheory.SymmetricCategory A] + [inst_3 : CategoryTheory.Preadditive A] [inst_4 : CategoryTheory.Linear ℂ A] + [inst_5 : CategoryTheory.MonoidalPreadditive A] [inst_6 : CategoryTheory.MonoidalLinear ℂ A] + [inst_7 : CategoryTheory.RigidCategory A] (hu : HasScalarUnit A) (X : A) {n : ℕ} + [Module.Finite ℂ (CategoryTheory.End (tensorPow A X n))], + Module.finrank ℂ (CategoryTheory.End (tensorPow A X n)) < n.factorial → + ∀ {g : CategoryTheory.End X}, IsNilpotent g → (scalarTrace hu X) g = 0 -/ + +/- Upstream audit output: @scalarTrace_eq_zero_of_isNilpotent_factorial : ∀ {A : Type u_2} [inst : + CategoryTheory.Category.{u_1, u_2} A] + [inst_1 : CategoryTheory.MonoidalCategory A] [inst_2 : CategoryTheory.SymmetricCategory A] + [inst_3 : CategoryTheory.Preadditive A] [inst_4 : CategoryTheory.Linear ℂ A] + [inst_5 : CategoryTheory.MonoidalPreadditive A] [inst_6 : CategoryTheory.MonoidalLinear ℂ A] + [inst_7 : CategoryTheory.RigidCategory A] (hu : HasScalarUnit A) (X : A) + [∀ (n : ℕ), Module.Finite ℂ (CategoryTheory.End (tensorPow A X n))] (B : ℝ), + (∀ (n : ℕ), ↑(Module.finrank ℂ (CategoryTheory.End (tensorPow A X n))) ≤ B ^ n) → + ∀ {g : CategoryTheory.End X}, IsNilpotent g → (scalarTrace hu X) g = 0 -/ + +/- Upstream audit output: @skeinTrace_eq_zero_of_isNilpotent_factorial : ∀ {R : ℕ} (f : + EdgeRankParameter R) (n : ℕ) {g : skeinEnd f n}, + IsNilpotent g → skeinTrace f n g = 0 -/ + +/- Upstream audit output: @skeinEnd_isSemisimpleRing_factorial : ∀ {R : ℕ} (f : EdgeRankParameter R) + (n : ℕ), IsSemisimpleRing (skeinEnd f n) -/ + +/- Upstream audit output: @karoubiEnd_isSemisimpleRing_factorial : ∀ {R : ℕ} (f : EdgeRankParameter + R) + (X : CategoryTheory.Idempotents.Karoubi (SkeinObj f)), IsSemisimpleRing (CategoryTheory.End X) -/ + +/- Upstream audit output: @karoubiEnd_isSemisimpleRing : ∀ {R : ℕ} (f : EdgeRankParameter R) + (X : CategoryTheory.Idempotents.Karoubi (SkeinObj f)), IsSemisimpleRing (CategoryTheory.End X) -/ + +/- Upstream audit output: @matTrace_eq_zero_of_isNilpotent' : ∀ {R : ℕ} {f : EdgeRankParameter R} + {M : CategoryTheory.Mat_ (CategoryTheory.Idempotents.Karoubi (SkeinObj f))} {φ : + CategoryTheory.End M}, + IsNilpotent φ → (matTrace f M) φ = 0 -/ + +/- Upstream audit output: @envEnd_isSemisimpleRing : ∀ {R : ℕ} (f : EdgeRankParameter R) (E : Env + f), IsSemisimpleRing (CategoryTheory.End E) -/ + +/- Upstream audit output: @envAbelian : {R : ℕ} → (f : EdgeRankParameter R) → CategoryTheory.Abelian + (Env f) -/ + +/- Upstream audit output: @env_deligneSemisimple : ∀ {R : ℕ} (f : EdgeRankParameter R), IsSemisimple + (Env f) -/ + +/- Upstream audit output: @env_delignePackage : ∀ {R : ℕ} (f : EdgeRankParameter R), + DeligneTheoremStatement → Nonempty (DelignePackage (Env f)) -/ + +/- Upstream audit output: @skein_delignePackage : ∀ {R : ℕ} (f : EdgeRankParameter R), + DeligneTheoremStatement → Nonempty (DelignePackage (SkeinObj f)) -/ + +/-! ### Axioms -/ + +/- Upstream audit output: 'RS.exists_singlePowerTrace_pow' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.linearIndependent_of_group_trace' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.CycleTraceTower.factorial_le_finrank' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.CycleTraceTower.traceA_eq_zero_of_finrank_lt_factorial' depends on + axioms: [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.CycleTraceTower.traceA_eq_zero_of_exponential_bound' depends on + axioms: [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.scalarTrace_eq_zero_of_finrank_lt_factorial' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.scalarTrace_eq_zero_of_isNilpotent_factorial' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.skeinTrace_eq_zero_of_isNilpotent_factorial' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.skeinEnd_isSemisimpleRing_factorial' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.karoubiEnd_isSemisimpleRing_factorial' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.envAbelian' depends on axioms: [propext, Classical.choice, Quot.sound] + -/ + +/-! ### Independence from the appendix and fibre-functor engines -/ + +/- +Upstream diagnostic traversal, preserved as documentation. The pool performs its +compiled declaration and axiom audits separately; this block declares no proof. + +open Lean in +private partial def factorialDependencies (env : Environment) (name : Name) : + StateT NameSet CoreM Unit := do + if (← get).contains name then return + modify (·.insert name) + let some info := env.checked.get.find? name + | throwError "Missing declaration in factorial audit: {name}" + for dependency in info.getUsedConstantsAsSet.toList do + factorialDependencies env dependency + +open Lean in +private def factorialDependencyModule (env : Environment) + (name : Name) : Option Name := do + -- Equation lemmas can be generated in the module that first + -- unfolds a definition. Attribute them to that definition; + -- their proof bodies are still traversed without exemption. + let origin := ((Meta.declFromEqLikeName env name).map Prod.fst).getD name + return (← env.getModuleIdxFor? origin |>.bind + (env.header.modules[·]?)).module + +open Lean in +private def appendixModule (name : Name) : Bool := + [ `RS.Novel.Envelope.BlockAssembly, + `RS.Novel.Envelope.NilpotentTrace, + `RS.Novel.Envelope.ObjectTower, + `RS.Novel.Envelope.TraceZeta, + `RS.Novel.Envelope.TraceZetaSharp, + `RS.Classical.SymFun.HookVanishing, + `RS.Classical.SymFun.RecurrenceFromVanishing, + `RS.Classical.SymFun.RationalityFromRecurrence, + `RS.Classical.SymFun.ZetaRational, + `RS.Classical.SymFun.ZetaSeries, + `RS.Classical.SymFun.ZetaExp ].any (·.isPrefixOf name) + +open Lean in +private def factorialExcludedDependency (env : Environment) + (name : Name) : Bool := + let excluded := [ + `RS.Classical.Interfaces.SchurPackage, + `RS.Classical.Interfaces.DeligneTheorem, + `RS.Classical.SchurTheory, + `RS.Classical.SymFun, + `RS.Novel.Envelope.BlockBounds, + `RS.Novel.Envelope.HookConfinement, + `RS.Novel.Envelope.HookConfinementSharp] + match factorialDependencyModule env name with + | none => false + | some source => + appendixModule source || excluded.any (·.isPrefixOf source) || + (`RS.Classical.Deligne).isPrefixOf source && + source != `RS.Classical.Deligne.FactorialBeats + +-- Traverse the proof terms themselves; the import graph also +-- contains the appendix route and cannot establish independence. +run_elab do + let env ← Lean.getEnv + let roots := [ + ``CycleTraceTower.factorial_le_finrank, + ``CycleTraceTower.traceA_eq_zero_of_finrank_lt_factorial, + ``CycleTraceTower.traceA_eq_zero_of_exponential_bound, + ``scalarTrace_eq_zero_of_finrank_lt_factorial, + ``scalarTrace_eq_zero_of_isNilpotent_factorial, + ``skeinTrace_eq_zero_of_isNilpotent_factorial, + ``skeinEnd_isSemisimpleRing_factorial, + ``karoubiEnd_isSemisimpleRing_factorial, + ``envEnd_isSemisimpleRing, ``envAbelian, ``env_deligneSemisimple] + let (_, dependencies) ← + (roots.forM (factorialDependencies env)).run {} + for name in dependencies.toList do + if factorialExcludedDependency env name then + throwError "Factorial route depends on excluded declaration: {name}" + let (_, control) ← + (factorialDependencies env + ``scalarTrace_eq_zero_of_isNilpotent).run {} + for name in [``schurPackage, + ``powerSums_zero_of_hook_and_eventually_zero] do + unless control.contains name && factorialExcludedDependency env name do + throwError "Factorial audit missed an appendix dependency: {name}" + +-- The summits use Deligne and colour-bound representation theory, +-- but their nilpotent-trace input must be the factorial argument. +run_elab do + let env ← Lean.getEnv + for root in [``regts_sevenster, ``regts_sevenster_quant, + ``regts_sevenster_total, ``regts_sevenster_minimum, + ``regts_sevenster_rank_growth, ``regts_sevenster_prescribed, + ``regts_sevenster_characterisation, + ``regts_sevenster_quant_characterisation] do + let (_, dependencies) ← (factorialDependencies env root).run {} + unless dependencies.contains + ``skeinTrace_eq_zero_of_isNilpotent_factorial do + throwError "Summit does not use the factorial trace theorem: {root}" + for name in dependencies.toList do + if let some source := factorialDependencyModule env name then + if appendixModule source then + throwError "Summit {root} depends on appendix declaration: {name}" + +-/ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintSchur.lean b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintSchur.lean new file mode 100644 index 0000000000..bccc8dacc4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintSchur.lean @@ -0,0 +1,462 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Assembly.Blueprint +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.ObjectTower +public import LeanPool.RegtsSevenster.RS.TheoremTotal + +/-! +# Blueprint: the Schur package, the dimension bound, the open sector + +The second part of the axiom audit. It pins the symmetric-group +input the forward direction rests on, the auxiliary `⌊2eR⌋` dimension +bound, the total bound `k + 2ℓ ≤ R`, and the open-sector Proposition 3. +Read `Blueprint.lean` +first: it audits the forward proof itself. +-/ + +/-! ### The Schur package + +Jacobi–Trudi characters: the Frobenius identity, orthonormality, +the branching containment, the block faithfulness and the square +growth bound — the fields of `SchurPackage`, and the package. +-/ + +/- Upstream audit output: 'RS.jtChar_frobenius'' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.jtChar_orthonormal' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.jtChar_eq_nChar' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.nProjector_block_faithful' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.square_growth' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.branching_of_pairing' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.jtChar_pad' depends on axioms: [propext, Classical.choice, Quot.sound] + -/ + +/- Upstream audit output: 'RS.schurPackageOf' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.restrPairing_ne_zero' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.schurPackage' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/-! ### The forward theorem on Deligne alone -/ + +/- Upstream audit output: 'RS.regts_sevenster_deligne_only' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/-! ### The trace zeta function + +The zeta function of a Frobenius tower is the Newton generating +series of its super power sums, and rational when the characters +are hook-confined. +-/ + +/- Upstream audit output: 'RS.FrobeniusTower.traceZeta_rational' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.FrobeniusTower.traceZeta_superSpectrum' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.traceZeta_eq_newtonH_series' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/-! ### Corollary A.2 with the sharp threshold + +The appendix's own statement: a real dimension bound `A`, every side +`s > 2e√A`, and degrees at most `s − 1`. +-/ + +/- Upstream audit output: 'RS.FrobeniusTower.traceZeta_rational_sharp' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.FrobeniusTower.traceZeta_superSpectrum_sharp' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.PermTower.hook_confinement_sharp' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.newtonH_series_rational_of_hook_vanishing' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +/-! ### Hook-confined sequences + +Lemma A.9 for arbitrary hook dimensions, with numerator degree at +most `b` and denominator degree at most `a`. +-/ + +/- +info: RS.newtonH_series_rational_of_hook_vanishing {t : ℕ → ℂ} {a b : ℕ} + (hvan : ∀ (μ : YoungDiagram), ¬RS.IsInHook a b μ → RS.diagramSchur μ t = 0) : + ∃ P Q, + P.coeff 0 = 1 ∧ Q.coeff 0 = 1 ∧ P.natDegree ≤ b ∧ Q.natDegree ≤ a ∧ IsCoprime P Q ∧ + RS.newtonHSeries t * ↑Q = ↑P +-/ + +/- +info: RS.superPowerSums_of_hook_vanishing {t : ℕ → ℂ} {a b : ℕ} + (hvan : ∀ (μ : YoungDiagram), ¬RS.IsInHook a b μ → RS.diagramSchur μ t = 0) : + ∃ α β, + α.card ≤ a ∧ + β.card ≤ b ∧ + (∀ x ∈ α, x ≠ 0) ∧ + (∀ x ∈ β, x ≠ 0) ∧ + (∀ x ∈ α, x ∉ β) ∧ + ∀ (m : ℕ), 1 ≤ m → t m = (Multiset.map (fun x => x ^ m) α).sum - (Multiset.map (fun x + => x ^ m) β).sum +-/ + +/-! ### The separate-sector dimension bound + +The `⌊2eR⌋` bound: a square diagram past it is dead, its +idempotent acts as zero, and the surviving sector is bounded. +-/ + +/- Upstream audit output: 'RS.square_growth_sharp' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.PermTower.not_alive_square_sharp' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.skeinRep_square_dead' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.functional_charIdempotent_signed' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.charIdempotent_image_ne_zero' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.RelTransitionSystem.pathMatch_invol' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.superPermAction_square_dead' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.mixedPartition_empty' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.squareSectorBound_of_detPos' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.diagramSchur_square_const_ne_zero' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.regts_sevenster_quant_of_detPos' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.squareBinomialDetPos' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.det_binomial_upper_ne_zero' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.regts_sevenster_quant_deligne_only' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/-! ### The total dimension bound + +Native blocks bound constituent dimensions; simultaneous word orbits +bound the commutant by a polynomial. The transported colour action +then forces `k + 2 * ℓ ≤ R` by comparison of exponential bases. +-/ + +/- Upstream audit output: 'RS.nDim_sq_le_finrank_of_projector_ne_zero' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.finrank_le_mul_commutant' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.finrank_commutant_le_word_counts' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.le_of_pow_le_pow_mul_polynomial' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.colourTotalEquiv_modelPermMap' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.stdModel_total_dimension_le' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.regts_sevenster_total_deligne_only' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/-! ### The open sector: Proposition 3 + +Repair connectivity of a pairing fibre, the canonical frame and +its re-canonicalization, the per-move ledgers and the paired step +— together, the signed value depends on the boundary pairing and +nothing else. Independence *across* pairings is false. +-/ + +/- Upstream audit output: 'RS.EdgeSubset.repair_connectivity' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.eulerian_iff_parts' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.openCircuitCount_glueOpen_participating' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.pathCanonical_agree_nonperiodic' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.exists_pathCanonical' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.third_chord_reparity' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.pairingConnectivity' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.stepLedger_single' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.throughSummand_independence_of_allInternal' depends on + axioms: [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.twoPath_transform' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.pathMatch_repair_swap' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.crossesCut_iff_chordPairCross' depends on axioms: [propext] -/ + +/- Upstream audit output: 'RS.EdgeSubset.pathSign_of_samePairing' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.signedValueAt_samePairing' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.pairedLedger_iff_value' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.signedValueAt_samePairing_of_value' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.TransposeVerify.not_throughIndependenceC' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.cutPartner_eq_some' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.eulerianIndependence' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.throughSummand_portFlip' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.twoPathNonSep_transform' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.throughValueC_eq_signedValueAt' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.chainDir_pathMatch' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.pathCanonical_iff_chainDir' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.exists_recanonicalize' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.swap_dirs_opposite' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.mem_antiLowSet_transport_untouched' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.chainDir_true_iff_high' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.mem_antiLowSet_transport_of_canonical' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.pairedLedger_iff_unsigned' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.stateOddFlipSet_flipSet' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.mem_highSet_repair_end' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.chordCrossingCount_repair_parity' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.fourLabel_parity_sep' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.fourLabel_parity_nonsep' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.flipSignProd_formula' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.flipSignProd_of_even' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.antiLowSet_transport_subset' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.symmU_trans' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.statusDiff_trans' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.statusDiff_of_samePairing' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.mem_pairFold_antiLow' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.antiLow_labels_eq_statusChange' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.antiLowSet_transport_eq' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.antiLowSet_transport_card' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.nonsep_labels_eq_statusChange' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.diagCrossCount_glue_cross' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.pairedLedgerUnsigned' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.pairedLedger' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.stepStatusLedger' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/- Upstream audit output: 'RS.EdgeSubset.chainStatusLedger' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ + +/-! ### The appendix, for an object + +Corollary A.2 as the appendix states it: for an arbitrary object of a +rigid symmetric ℂ-linear category whose tensor powers have +exponentially bounded endomorphism dimensions, the trace zeta +function of every endomorphism is rational of the stated degree. +-/ + +/- +info: 'RS.frobenius_powHom' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ + +/- +info: 'RS.objectFrobeniusTower' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ + +/- +info: 'RS.traceZeta_rational_of_object' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ + +/- +info: 'RS.scalarTrace_eq_zero_of_isNilpotent' depends on axioms: [propext, Classical.choice, + Quot.sound] +-/ + +/- +info: 'RS.traceZeta_superSpectrum_of_object' depends on axioms: [propext, Classical.choice, + Quot.sound] +-/ + +/-! ### The appendix's theorems, by type + +The axiom audits above fix what these rest on; the pins below fix +what they say — the hypothesis on the object, the threshold, and the +degree bound. +-/ + +/- +info: @RS.traceZeta_rational_of_object : ∀ {A : Type u_2} [inst : CategoryTheory.Category.{u_1, u_2} + A] + [inst_1 : CategoryTheory.MonoidalCategory A] [inst_2 : CategoryTheory.SymmetricCategory A] + [inst_3 : CategoryTheory.Preadditive A] [inst_4 : CategoryTheory.Linear ℂ A] + [inst_5 : CategoryTheory.MonoidalPreadditive A] [inst_6 : CategoryTheory.MonoidalLinear ℂ A] + [inst_7 : CategoryTheory.RigidCategory A] (hu : RS.HasScalarUnit A) (X : A) + [∀ (n : ℕ), Module.Finite ℂ (CategoryTheory.End (RS.tensorPow A X n))] (A₀ : ℝ), + (∀ (n : ℕ), ↑(Module.finrank ℂ (CategoryTheory.End (RS.tensorPow A X n))) ≤ A₀ ^ n) → + ∀ (g : CategoryTheory.End X) {s : ℕ}, + 2 * Real.exp 1 * √A₀ < ↑s → + ∃ (Pp : Polynomial ℂ) (Qp : Polynomial ℂ), + Pp.coeff 0 = 1 ∧ + Qp.coeff 0 = 1 ∧ + Pp.natDegree ≤ s - 1 ∧ + Qp.natDegree ≤ s - 1 ∧ + IsCoprime Pp Qp ∧ (RS.traceZeta fun (m : ℕ) => (RS.scalarTrace hu X) (g ^ m)) * + ↑Qp = ↑Pp +-/ + +/- +info: @RS.traceZeta_superSpectrum_of_object : ∀ {A : Type u_2} [inst : CategoryTheory.Category.{u_1, + u_2} A] + [inst_1 : CategoryTheory.MonoidalCategory A] [inst_2 : CategoryTheory.SymmetricCategory A] + [inst_3 : CategoryTheory.Preadditive A] [inst_4 : CategoryTheory.Linear ℂ A] + [inst_5 : CategoryTheory.MonoidalPreadditive A] [inst_6 : CategoryTheory.MonoidalLinear ℂ A] + [inst_7 : CategoryTheory.RigidCategory A] (hu : RS.HasScalarUnit A) (X : A) + [∀ (n : ℕ), Module.Finite ℂ (CategoryTheory.End (RS.tensorPow A X n))] (A₀ : ℝ), + (∀ (n : ℕ), ↑(Module.finrank ℂ (CategoryTheory.End (RS.tensorPow A X n))) ≤ A₀ ^ n) → + ∀ (g : CategoryTheory.End X) {s : ℕ}, + 2 * Real.exp 1 * √A₀ < ↑s → + ∃ (alpha : Multiset ℂ) (beta : Multiset ℂ), + alpha.card ≤ s - 1 ∧ + beta.card ≤ s - 1 ∧ + (∀ x ∈ alpha, x ≠ 0) ∧ + (∀ x ∈ beta, x ≠ 0) ∧ + (∀ x ∈ alpha, x ∉ beta) ∧ + ∀ (m : ℕ), + 1 ≤ m → + (RS.scalarTrace hu X) (g ^ m) = + (Multiset.map (fun (x : ℂ) => x ^ m) alpha).sum - + (Multiset.map (fun (x : ℂ) => x ^ m) beta).sum +-/ + +/- +info: @RS.objectFrobeniusTower : {A : Type u_2} → + [inst : CategoryTheory.Category.{u_1, u_2} A] → + [inst_1 : CategoryTheory.MonoidalCategory A] → + [CategoryTheory.SymmetricCategory A] → + [inst_3 : CategoryTheory.Preadditive A] → + [inst_4 : CategoryTheory.Linear ℂ A] → + [inst_5 : CategoryTheory.MonoidalPreadditive A] → + [CategoryTheory.MonoidalLinear ℂ A] → + [CategoryTheory.RigidCategory A] → + RS.HasScalarUnit A → + (X : A) → + (P : RS.SchurPackage) → + (A₀ : ℝ) → + (∀ (n : ℕ), ↑(Module.finrank ℂ (CategoryTheory.End (RS.tensorPow A X n))) + ≤ A₀ ^ n) → + RS.FrobeniusTower P (fun (n : ℕ) => CategoryTheory.End (RS.tensorPow A X + n)) A₀ + (CategoryTheory.End X) +-/ diff --git a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean new file mode 100644 index 0000000000..5b11467768 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean @@ -0,0 +1,793 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopExample +public import LeanPool.RegtsSevenster.RS.TheoremConverse +public import LeanPool.RegtsSevenster.RS.TheoremForward +public import LeanPool.RegtsSevenster.RS.TheoremQuant +public import LeanPool.RegtsSevenster.RS.Summit + +/-! +# The statement surface, pinned + +Reading a formalization means reading what its theorems *say*, and +that reduces to the handful of definitions their statements are +phrased in. This module lists exactly those definitions and pins +each one's type, and then pins the type of every theorem of record. + +For the development's own definitions this is a *signature* audit. +Each anonymous example turns a change to a pinned type into a compile +error, so nothing enters or leaves a summit statement unnoticed; but +a type is not a meaning, and a definition can be rewritten while +keeping it — `EdgeRankBounded` would still read +`(ClosedFragment → ℂ) → ℕ → Prop` whatever it bounded. Reading the +summits therefore means reading the linked definitions, which is +what the file lists them for. For the one definition where a +convention could silently be wrong — `mixedPartition`, which carries +the circuit sign, the Eulerian condition and the odd-colour +bookkeeping — the last section pins a value instead of a type. + +Deligne's theorem is pinned by content, as is every predicate its +hypothesis list is phrased in. The corollary definitions are likewise +pinned by content so the meaning of rank, minimum and prescribed +dimensions is visible. `Blueprint.lean` and its parts then pin what +the summits depend on. + +The main definitions live in `RS/Definitions.lean`, the +self-contained statement surface that the comparator certification +trusts. `RS/DimensionDefinitions.lean` adds the growth, minimum and +prescribed-dimension surface and imports only that main surface. +-/ + +@[expose] public section + +noncomputable section + +universe u v u_1 u_2 + +open CategoryTheory +open scoped BigOperators + +namespace RS + +/-! ## The model + +A fragment is a flag (half-edge) graph over a label type; a closed +fragment is one with no boundary labels, and `Fragment.Equiv` is +isomorphism of fragments. -/ + +/- Upstream contract: +Fragment : Type → Type 1 +-/ +example : Type → Type 1 := + @Fragment + + +/- Upstream contract: +ClosedFragment : Type 1 +-/ +example : Type 1 := + @ClosedFragment + + +/- Upstream contract: +emptyClosedFragment : ClosedFragment +-/ +example : ClosedFragment := + @emptyClosedFragment + + +/- Upstream contract: +@Fragment.Equiv : {α : Type} → Fragment α → Fragment α → Type +-/ +example : {α : Type} → Fragment α → Fragment α → Type := + @Fragment.Equiv + + +/-! ## Mixed partition functions + +`MixedFunctional k ℓ` is a vertex functional with `k` even and `2ℓ` +odd colours, `mixedPartition` is Definition 5 of Regts–Sevenster on +the flag model, and the two predicates say that a parameter is such +a partition function, with and without a bound on the dimensions. -/ + +/- Upstream contract: +MixedFunctional : ℕ → ℕ → Type +-/ +example : ℕ → ℕ → Type := + @MixedFunctional + + +/- Upstream contract: +@mixedPartition : {α : Type} → {k ℓ : ℕ} → MixedFunctional k ℓ → Fragment α → ℂ +-/ +example : {α : Type} → {k ℓ : ℕ} → MixedFunctional k ℓ → Fragment α → ℂ := + @mixedPartition + + +/- Upstream contract: +IsMixedPartitionFunction : (ClosedFragment → ℂ) → Prop +-/ +example : (ClosedFragment → ℂ) → Prop := + @IsMixedPartitionFunction + + +/- Upstream contract: +IsMixedPartitionFunctionBounded : (ClosedFragment → ℂ) → ℕ → Prop +-/ +example : (ClosedFragment → ℂ) → ℕ → Prop := + @IsMixedPartitionFunctionBounded + + +/- Upstream contract: +TotalBoundedMixedModel : (ClosedFragment → ℂ) → ℕ → Type +-/ +example : (ClosedFragment → ℂ) → ℕ → Type := + @TotalBoundedMixedModel + + +/- Upstream contract: +IsMixedPartitionFunctionTotalBounded : (ClosedFragment → ℂ) → ℕ → Prop +-/ +example : (ClosedFragment → ℂ) → ℕ → Prop := + @IsMixedPartitionFunctionTotalBounded + + +/-! The total bound is pinned by content: its witness bounds the +sum of both dimensions and evaluates to the original parameter. -/ + +/- Upstream contract: +structure RS.TotalBoundedMixedModel (f : ClosedFragment → ℂ) (B : ℕ) : Type +number of parameters: 2 +fields: + RS.TotalBoundedMixedModel.k : ℕ + RS.TotalBoundedMixedModel.ℓ : ℕ + RS.TotalBoundedMixedModel.functional : MixedFunctional self.k self.ℓ + RS.TotalBoundedMixedModel.dimension_le : self.k + 2 * self.ℓ ≤ B + RS.TotalBoundedMixedModel.partition_eq : ∀ (W : ClosedFragment), f W = mixedPartition + self.functional W +constructor: + RS.TotalBoundedMixedModel.mk {f : ClosedFragment → ℂ} {B : ℕ} (k ℓ : ℕ) (functional : + MixedFunctional k ℓ) + (dimension_le : k + 2 * ℓ ≤ B) (partition_eq : ∀ (W : ClosedFragment), f W = mixedPartition + functional W) : + TotalBoundedMixedModel f B +-/ +example {f : ClosedFragment → ℂ} {B : ℕ} (k ℓ : ℕ) (functional : MixedFunctional k ℓ) + (dimension_le : k + 2 * ℓ ≤ B) (partition_eq : ∀ (W : ClosedFragment), f W = mixedPartition + functional W) : + TotalBoundedMixedModel f B := + TotalBoundedMixedModel.mk k ℓ functional dimension_le partition_eq + + +/- Upstream contract: +def RS.IsMixedPartitionFunctionTotalBounded : (ClosedFragment → ℂ) → ℕ → Prop := +fun (f : ClosedFragment → ℂ) (B : ℕ) => Nonempty (TotalBoundedMixedModel f B) +-/ +example : @IsMixedPartitionFunctionTotalBounded = (fun (f : ClosedFragment → ℂ) (B : ℕ) => Nonempty + (TotalBoundedMixedModel f B) : (ClosedFragment → ℂ) → ℕ → Prop) := rfl + + +/-! ## Edge-connection rank + +`EdgeRankBounded f R` says the connection pairings of `f` have rank +at most `R ^ t` at every arity `t`; `EdgeRankParameter R` packages a +normalized, isomorphism-invariant parameter with that bound. -/ + +/- Upstream contract: +EdgeRankBounded : (ClosedFragment → ℂ) → ℕ → Prop +-/ +example : (ClosedFragment → ℂ) → ℕ → Prop := + @EdgeRankBounded + + +/- Upstream contract: +EdgeRankParameter : ℕ → Type 1 +-/ +example : ℕ → Type 1 := + @EdgeRankParameter + + +/-! ## The statements and Deligne's theorem -/ + +/- Upstream contract: +RegtsSevensterStatement : Prop +-/ +example : Prop := + @RegtsSevensterStatement + + +/- Upstream contract: +RegtsSevensterStatementQuant : Prop +-/ +example : Prop := + @RegtsSevensterStatementQuant + + +/- Upstream contract: +RegtsSevensterStatementTotal : Prop +-/ +example : Prop := + @RegtsSevensterStatementTotal + + +/- Upstream contract: +def RS.RegtsSevensterStatementTotal : Prop := +∀ (R : ℕ) (f : EdgeRankParameter R), IsMixedPartitionFunctionTotalBounded f.val R +-/ +example : @RegtsSevensterStatementTotal = (∀ (R : ℕ) (f : EdgeRankParameter R), + IsMixedPartitionFunctionTotalBounded f.val R : Prop) := rfl + + +/- Upstream contract: +RegtsSevensterConverseStatement : Prop +-/ +example : Prop := + @RegtsSevensterConverseStatement + + +/- Upstream contract: +DeligneTheoremStatement : Prop +-/ +example : Prop := + @DeligneTheoremStatement.{u, v} + + +/-! ### Deligne's theorem, unfolded + +A type is not a meaning, so `DeligneTheoremStatement` is pinned by +content as well as by name: its hypothesis list, and the definition +of every predicate that list is phrased in. An auditor compares +what follows with Deligne's Théorème 0.6 and §0.1; a change to any +of it is a compile error. The statement is proved in +`RS/Classical/Deligne/`, so the pin fixes the meaning of a theorem +of this tree rather than of an assumption. +-/ + +/- Upstream contract: +def RS.HasScalarUnit.{v, u} : (A : Type u) → + [inst : CategoryTheory.Category.{v, u} A] → + [inst_1 : CategoryTheory.Preadditive A] → + [CategoryTheory.Linear ℂ A] → [CategoryTheory.MonoidalCategory A] → Prop := +fun (A : Type u) [CategoryTheory.Category.{v, u} A] [CategoryTheory.Preadditive A] + [CategoryTheory.Linear ℂ A] + [CategoryTheory.MonoidalCategory A] => + Function.Bijective fun (c : ℂ) => + c • CategoryTheory.CategoryStruct.id (CategoryTheory.MonoidalCategoryStruct.tensorUnit A) +-/ +example : @HasScalarUnit = (fun (A : Type u) [CategoryTheory.Category.{v, u} A] + [CategoryTheory.Preadditive A] [CategoryTheory.Linear ℂ A] + [CategoryTheory.MonoidalCategory A] => + Function.Bijective fun (c : ℂ) => + c • CategoryTheory.CategoryStruct.id (CategoryTheory.MonoidalCategoryStruct.tensorUnit A) : (A : + Type u) → + [_inst : CategoryTheory.Category.{v, u} A] → + [_inst_1 : CategoryTheory.Preadditive A] → + [CategoryTheory.Linear ℂ A] → [CategoryTheory.MonoidalCategory A] → Prop) := rfl + + +/- Upstream contract: +tensorPow_zero : ∀ (A : Type u_2) [inst : CategoryTheory.Category.{u_1, u_2} A] + [inst_1 : CategoryTheory.MonoidalCategory A] (X : A), + tensorPow A X 0 = CategoryTheory.MonoidalCategoryStruct.tensorUnit A +-/ +example : ∀ (A : Type u_2) [_inst : CategoryTheory.Category.{u_1, u_2} A] + [_inst_1 : CategoryTheory.MonoidalCategory A] (X : A), + tensorPow A X 0 = CategoryTheory.MonoidalCategoryStruct.tensorUnit A := + @tensorPow_zero + + +/- Upstream contract: +tensorPow_succ : ∀ (A : Type u_2) [inst : CategoryTheory.Category.{u_1, u_2} A] + [inst_1 : CategoryTheory.MonoidalCategory A] (X : A) (n : ℕ), + tensorPow A X (n + 1) = CategoryTheory.MonoidalCategoryStruct.tensorObj (tensorPow A X n) X +-/ +example : ∀ (A : Type u_2) [_inst : CategoryTheory.Category.{u_1, u_2} A] + [_inst_1 : CategoryTheory.MonoidalCategory A] (X : A) (n : ℕ), + tensorPow A X (n + 1) = CategoryTheory.MonoidalCategoryStruct.tensorObj (tensorPow A X n) X := + @tensorPow_succ + + +/- Upstream contract: +def RS.mixedPow.{v, u} : (A : Type u) → + [inst : CategoryTheory.Category.{v, u} A] → + [inst_1 : CategoryTheory.MonoidalCategory A] → [CategoryTheory.RigidCategory A] → A → ℕ → ℕ → A + := +fun (A : Type u) [CategoryTheory.Category.{v, u} A] [CategoryTheory.MonoidalCategory A] + [CategoryTheory.RigidCategory A] + (X : A) (a b : ℕ) => + CategoryTheory.MonoidalCategoryStruct.tensorObj (tensorPow A X a) (tensorPow A Xᘁ b) +-/ +example : @mixedPow = (fun (A : Type u) [CategoryTheory.Category.{v, u} A] + [CategoryTheory.MonoidalCategory A] [CategoryTheory.RigidCategory A] + (X : A) (a b : ℕ) => + CategoryTheory.MonoidalCategoryStruct.tensorObj (tensorPow A X a) (tensorPow A Xᘁ b) : (A : Type + u) → + [_inst : CategoryTheory.Category.{v, u} A] → + [_inst_1 : CategoryTheory.MonoidalCategory A] → [CategoryTheory.RigidCategory A] → A → ℕ → ℕ → + A) := rfl + + +/- Upstream contract: +def RS.IsSubquotientOf.{v, u} : {C : Type u} → [CategoryTheory.Category.{v, u} C] → C → C → Prop := +fun {C : Type u} [CategoryTheory.Category.{v, u} C] (Y Z : C) => + ∃ (S : C) (i : S ⟶ Z) (p : S ⟶ Y), CategoryTheory.Mono i ∧ CategoryTheory.Epi p +-/ +example : @IsSubquotientOf = (fun {C : Type u} [CategoryTheory.Category.{v, u} C] (Y Z : C) => + ∃ (S : C) (i : S ⟶ Z) (p : S ⟶ Y), CategoryTheory.Mono i ∧ CategoryTheory.Epi p : {C : Type u} → + [CategoryTheory.Category.{v, u} C] → C → C → Prop) := rfl + + +/- Upstream contract: +def RS.TensorGeneratedBy.{v, u} : (A : Type u) → + [inst : CategoryTheory.Category.{v, u} A] → + [inst_1 : CategoryTheory.MonoidalCategory A] → + [inst_2 : CategoryTheory.Preadditive A] → + [CategoryTheory.Limits.HasFiniteBiproducts A] → [CategoryTheory.RigidCategory A] → A → Prop + := +fun (A : Type u) [CategoryTheory.Category.{v, u} A] [CategoryTheory.MonoidalCategory A] + [CategoryTheory.Preadditive A] + [CategoryTheory.Limits.HasFiniteBiproducts A] [CategoryTheory.RigidCategory A] (X : A) => + ∀ (Y : A), ∃ (k : ℕ) (ab : Fin k → ℕ × ℕ), IsSubquotientOf Y (⨁ fun (t : Fin k) => mixedPow A X + (ab t).1 (ab t).2) +-/ +example : @TensorGeneratedBy = (fun (A : Type u) [CategoryTheory.Category.{v, u} A] + [CategoryTheory.MonoidalCategory A] [CategoryTheory.Preadditive A] + [CategoryTheory.Limits.HasFiniteBiproducts A] [CategoryTheory.RigidCategory A] (X : A) => + ∀ (Y : A), ∃ (k : ℕ) (ab : Fin k → ℕ × ℕ), IsSubquotientOf Y (⨁ fun (t : Fin k) => mixedPow A X + (ab t).1 (ab t).2) : (A : Type u) → + [_inst : CategoryTheory.Category.{v, u} A] → + [_inst_1 : CategoryTheory.MonoidalCategory A] → + [_inst_2 : CategoryTheory.Preadditive A] → + [CategoryTheory.Limits.HasFiniteBiproducts A] → [CategoryTheory.RigidCategory A] → A → Prop) + := rfl + + +/- Upstream contract: +def RS.LengthLE.{v, u} : {C : Type u} → [CategoryTheory.Category.{v, u} C] → C → ℕ → Prop := +fun {C : Type u} [CategoryTheory.Category.{v, u} C] (Y : C) (k : ℕ) => + ∀ (f : Fin (k + 2) → CategoryTheory.Subobject Y), ¬StrictMono f +-/ +example : @LengthLE = (fun {C : Type u} [CategoryTheory.Category.{v, u} C] (Y : C) (k : ℕ) => + ∀ (f : Fin (k + 2) → CategoryTheory.Subobject Y), ¬StrictMono f : {C : Type u} → + [CategoryTheory.Category.{v, u} C] → C → ℕ → Prop) := rfl + + +/- Upstream contract: +def RS.ModerateLengthGrowth.{v, u} : (A : Type u) → + [inst : CategoryTheory.Category.{v, u} A] → [CategoryTheory.MonoidalCategory A] → Prop := +fun (A : Type u) [CategoryTheory.Category.{v, u} A] [CategoryTheory.MonoidalCategory A] => + ∀ (Y : A), ∃ (C : ℕ) (c : ℕ), ∀ (N : ℕ), LengthLE (tensorPow A Y N) (C * c ^ N) +-/ +example : @ModerateLengthGrowth = (fun (A : Type u) [CategoryTheory.Category.{v, u} A] + [CategoryTheory.MonoidalCategory A] => + ∀ (Y : A), ∃ (C : ℕ) (c : ℕ), ∀ (N : ℕ), LengthLE (tensorPow A Y N) (C * c ^ N) : (A : Type u) → + [_inst : CategoryTheory.Category.{v, u} A] → [CategoryTheory.MonoidalCategory A] → Prop) := rfl + + +/- Upstream contract: +structure RS.DeligneFibreFunctor.{u_1, u_2} (A : Type u_1) [CategoryTheory.Category.{u_2, u_1} A] + [CategoryTheory.MonoidalCategory A] [CategoryTheory.SymmetricCategory A] + [CategoryTheory.Preadditive A] + [CategoryTheory.Linear ℂ A] : Type (max (max 1 u_1) u_2) +number of parameters: 6 +fields: + RS.DeligneFibreFunctor.ω : CategoryTheory.Functor A SuperVect + RS.DeligneFibreFunctor.braided : self.ω.Braided + RS.DeligneFibreFunctor.additive : self.ω.Additive + RS.DeligneFibreFunctor.linear : CategoryTheory.Functor.Linear ℂ self.ω + RS.DeligneFibreFunctor.faithful : self.ω.Faithful + RS.DeligneFibreFunctor.preservesFiniteLimits : CategoryTheory.Limits.PreservesFiniteLimits self.ω + RS.DeligneFibreFunctor.preservesFiniteColimits : CategoryTheory.Limits.PreservesFiniteColimits + self.ω +constructor: + RS.DeligneFibreFunctor.mk.{u_1, u_2} {A : Type u_1} [CategoryTheory.Category.{u_2, u_1} A] + [CategoryTheory.MonoidalCategory A] [CategoryTheory.SymmetricCategory A] + [CategoryTheory.Preadditive A] + [CategoryTheory.Linear ℂ A] (ω : CategoryTheory.Functor A SuperVect) (braided : ω.Braided) + (additive : ω.Additive) + (linear : CategoryTheory.Functor.Linear ℂ ω) (faithful : ω.Faithful) + (preservesFiniteLimits : CategoryTheory.Limits.PreservesFiniteLimits ω) + (preservesFiniteColimits : CategoryTheory.Limits.PreservesFiniteColimits ω) : + DeligneFibreFunctor A +-/ +example {A : Type u_1} [CategoryTheory.Category.{u_2, u_1} A] + [CategoryTheory.MonoidalCategory A] [CategoryTheory.SymmetricCategory A] + [CategoryTheory.Preadditive A] + [CategoryTheory.Linear ℂ A] (ω : CategoryTheory.Functor A SuperVect) (braided : ω.Braided) + (additive : ω.Additive) + (linear : CategoryTheory.Functor.Linear ℂ ω) (faithful : ω.Faithful) + (preservesFiniteLimits : CategoryTheory.Limits.PreservesFiniteLimits ω) + (preservesFiniteColimits : CategoryTheory.Limits.PreservesFiniteColimits ω) : + DeligneFibreFunctor A := + DeligneFibreFunctor.mk ω braided additive linear faithful + preservesFiniteLimits preservesFiniteColimits + + +/- Upstream contract: +def RS.DeligneTheoremStatement.{u, v} : Prop := +∀ (A : Type u) [inst : CategoryTheory.Category.{v, u} A] [inst_1 : CategoryTheory.Abelian A] + [inst_2 : CategoryTheory.Linear ℂ A] [inst_3 : CategoryTheory.MonoidalCategory A] + [inst_4 : CategoryTheory.SymmetricCategory A] [inst_5 : CategoryTheory.MonoidalPreadditive A] + [CategoryTheory.MonoidalLinear ℂ A] [inst_7 : CategoryTheory.Limits.HasFiniteBiproducts A] + [inst_8 : CategoryTheory.RigidCategory A] [CategoryTheory.EssentiallySmall.{v, v, u} A], + HasScalarUnit A → (∃ (X : A), TensorGeneratedBy A X) → ModerateLengthGrowth A → Nonempty + (DeligneFibreFunctor A) +-/ +example : @DeligneTheoremStatement.{u, v} = (∀ (A : Type u) [_inst : CategoryTheory.Category.{v, u} + A] [_inst_1 : CategoryTheory.Abelian A] + [_inst_2 : CategoryTheory.Linear ℂ A] [_inst_3 : CategoryTheory.MonoidalCategory A] + [_inst_4 : CategoryTheory.SymmetricCategory A] [_inst_5 : CategoryTheory.MonoidalPreadditive A] + [CategoryTheory.MonoidalLinear ℂ A] [_inst_7 : CategoryTheory.Limits.HasFiniteBiproducts A] + [_inst_8 : CategoryTheory.RigidCategory A] [CategoryTheory.EssentiallySmall.{v, v, u} A], + HasScalarUnit A → (∃ (X : A), TensorGeneratedBy A X) → ModerateLengthGrowth A → Nonempty + (DeligneFibreFunctor A) : Prop) := rfl + + +/-! ## The theorems of record + +The converse carries no hypothesis; the forward direction and the +characterization carry Deligne's theorem and nothing else. -/ + +/- Upstream contract: +regts_sevenster_converse : RegtsSevensterConverseStatement +-/ +example : RegtsSevensterConverseStatement := + @regts_sevenster_converse + + +/- Upstream contract: +regts_sevenster_deligne_only : DeligneTheoremStatement → RegtsSevensterStatement +-/ +example : DeligneTheoremStatement.{1, 1} → RegtsSevensterStatement := + @regts_sevenster_deligne_only + + +/- Upstream contract: +regts_sevenster_quant_deligne_only : DeligneTheoremStatement → RegtsSevensterStatementQuant +-/ +example : DeligneTheoremStatement.{1, 1} → RegtsSevensterStatementQuant := + @regts_sevenster_quant_deligne_only + + +/- Upstream contract: +regts_sevenster_total_deligne_only : DeligneTheoremStatement → RegtsSevensterStatementTotal +-/ +example : DeligneTheoremStatement.{1, 1} → RegtsSevensterStatementTotal := + @regts_sevenster_total_deligne_only + + +/- Upstream contract: +regts_sevenster_total : RegtsSevensterStatementTotal +-/ +example : RegtsSevensterStatementTotal := + @regts_sevenster_total + + +/- Upstream contract: +@edgeRankBounded_of_mixedBounded : ∀ {f : ClosedFragment → ℂ} {B : ℕ}, + IsMixedPartitionFunctionBounded f B → EdgeRankBounded f (max 1 (2 * B)) +-/ +example : ∀ {f : ClosedFragment → ℂ} {B : ℕ}, + IsMixedPartitionFunctionBounded f B → EdgeRankBounded f (max 1 (2 * B)) := + @edgeRankBounded_of_mixedBounded + + +/- Upstream contract: +regts_sevenster_iff : DeligneTheoremStatement → + ∀ (f : ClosedFragment → ℂ), + f emptyClosedFragment = 1 → + (∀ (W₁ W₂ : ClosedFragment) (a : Fragment.Equiv W₁ W₂), f W₁ = f W₂) → + ((∃ R, EdgeRankBounded f R) ↔ IsMixedPartitionFunction f) +-/ +example : DeligneTheoremStatement.{1, 1} → + ∀ (f : ClosedFragment → ℂ), + f emptyClosedFragment = 1 → + (∀ (W₁ W₂ : ClosedFragment) (_a : Fragment.Equiv W₁ W₂), f W₁ = f W₂) → + ((∃ R, EdgeRankBounded f R) ↔ IsMixedPartitionFunction f) := + @regts_sevenster_iff + + +/- Upstream contract: +regts_sevenster_quant_roundtrip : DeligneTheoremStatement → + ∀ (f : ClosedFragment → ℂ), + f emptyClosedFragment = 1 → + (∀ (W₁ W₂ : ClosedFragment) (a : Fragment.Equiv W₁ W₂), f W₁ = f W₂) → + (∀ (R : ℕ), EdgeRankBounded f R → IsMixedPartitionFunctionBounded f ⌊2 * Real.exp 1 * ↑R⌋₊) + ∧ + ∀ (B : ℕ), IsMixedPartitionFunctionBounded f B → EdgeRankBounded f (max 1 (2 * B)) +-/ +example : DeligneTheoremStatement.{1, 1} → + ∀ (f : ClosedFragment → ℂ), + f emptyClosedFragment = 1 → + (∀ (W₁ W₂ : ClosedFragment) (_a : Fragment.Equiv W₁ W₂), f W₁ = f W₂) → + (∀ (R : ℕ), EdgeRankBounded f R → IsMixedPartitionFunctionBounded f ⌊2 * Real.exp 1 * ↑R⌋₊) + ∧ + ∀ (B : ℕ), IsMixedPartitionFunctionBounded f B → EdgeRankBounded f (max 1 (2 * B)) := + @regts_sevenster_quant_roundtrip + + +/-! ## The definition, evaluated + +A pinned type says nothing about a convention, and `mixedPartition` +is where the conventions are: the circuit sign, the Eulerian +condition, a loop's two incidences at its vertex, the difference +between a loop and a free circle, and the `η`-convention through +which distinct odd colourings reach a common basis vector. + +The accompanying paper's worked example fixes all five at once. +Against the functional `charPolyFunctional θ`, whose mixed partition +function is the characteristic polynomial `det(θ I − A_G)` on graphs +without free circles, the one-vertex one-loop graph has `A_L = (2)` +and so must evaluate to `θ − 2`. It does +(`RS/Novel/Skein/LoopExample.lean`); a sign error in any one of the +five would change the number. Adjoining a free circle sends the +same functional to `0`, since `k − 2ℓ = 0` here — the same graph, +worth `θ − 2` with a loop and `0` with a circle. -/ + +/- Upstream contract: +loopGraph : ClosedFragment +-/ +example : ClosedFragment := + @loopGraph + + +/- Upstream contract: +charPolyFunctional : ℂ → MixedFunctional 2 1 +-/ +example : ℂ → MixedFunctional 2 1 := + @charPolyFunctional + + +/- Upstream contract: +mixedPartition_loopGraph : ∀ (θ : ℂ), mixedPartition (charPolyFunctional θ) loopGraph = θ - 2 +-/ +example : ∀ (θ : ℂ), mixedPartition (charPolyFunctional θ) loopGraph = θ - 2 := + @mixedPartition_loopGraph + + +/- Upstream contract: +mixedPartition_loopGraphCircle : ∀ (θ : ℂ), mixedPartition (charPolyFunctional θ) loopGraphCircle = + 0 +-/ +example : ∀ (θ : ℂ), mixedPartition (charPolyFunctional θ) loopGraphCircle = 0 := + @mixedPartition_loopGraphCircle + + +/-! ## Minimum dimensions, rank growth and padding -/ + +/- Upstream contract: +circlesClosed : ℕ → ClosedFragment +-/ +example : ℕ → ClosedFragment := + @circlesClosed + + +/- Upstream contract: +connectionRank : (ClosedFragment → ℂ) → ℕ → ℕ +-/ +example : (ClosedFragment → ℂ) → ℕ → ℕ := + @connectionRank + + +/- Upstream contract: +@MixedFunctional.Represents : {k ℓ : ℕ} → MixedFunctional k ℓ → (ClosedFragment → ℂ) → Prop +-/ +example : {k ℓ : ℕ} → MixedFunctional k ℓ → (ClosedFragment → ℂ) → Prop := + @MixedFunctional.Represents + + +/- Upstream contract: +minimumColourDimension : (ClosedFragment → ℂ) → ℕ +-/ +example : (ClosedFragment → ℂ) → ℕ := + @minimumColourDimension + + +/- Upstream contract: +PrescribedColourBounds : (ClosedFragment → ℂ) → ℕ → ℕ → Prop +-/ +example : (ClosedFragment → ℂ) → ℕ → ℕ → Prop := + @PrescribedColourBounds + + +/- Upstream contract: +@regts_sevenster_minimum : ∀ {R : ℕ} (f : EdgeRankParameter R), + IsMixedPartitionFunctionTotalBounded f.val (minimumColourDimension f.val) +-/ +example : ∀ {R : ℕ} (f : EdgeRankParameter R), + IsMixedPartitionFunctionTotalBounded f.val (minimumColourDimension f.val) := + @regts_sevenster_minimum + + +/- Upstream contract: +@regts_sevenster_rank_growth : ∀ {R : ℕ} (f : EdgeRankParameter R), + Filter.Tendsto (fun n => (connectionRank f.val (2 * n) : ℝ) ^ ((2 * n : ℕ) : ℝ)⁻¹) Filter.atTop + (nhds ↑(minimumColourDimension f.val)) +-/ +example : ∀ {R : ℕ} (f : EdgeRankParameter R), + Filter.Tendsto (fun n => (connectionRank f.val (2 * n) : ℝ) ^ ((2 * n : ℕ) : ℝ)⁻¹) Filter.atTop + (nhds ↑(minimumColourDimension f.val)) := + @regts_sevenster_rank_growth + + +/- Upstream contract: +regts_sevenster_prescribed : ∀ (f : ClosedFragment → ℂ), + f emptyClosedFragment = 1 → + (∀ (W₁ W₂ : ClosedFragment) (a : Fragment.Equiv W₁ W₂), f W₁ = f W₂) → + ∀ (k ℓ : ℕ), (∃ h : MixedFunctional k ℓ, h.Represents f) ↔ PrescribedColourBounds f k ℓ +-/ +example : ∀ (f : ClosedFragment → ℂ), + f emptyClosedFragment = 1 → + (∀ (W₁ W₂ : ClosedFragment) (_a : Fragment.Equiv W₁ W₂), f W₁ = f W₂) → + ∀ (k ℓ : ℕ), (∃ h : MixedFunctional k ℓ, h.Represents f) ↔ PrescribedColourBounds f k ℓ := + @regts_sevenster_prescribed + + +/- Upstream contract: +regts_sevenster_minimum_deligne_only : DeligneTheoremStatement → + ∀ {R : ℕ} (f : EdgeRankParameter R), IsMixedPartitionFunctionTotalBounded f.val + (minimumColourDimension f.val) +-/ +example : DeligneTheoremStatement.{1, 1} → + ∀ {R : ℕ} (f : EdgeRankParameter R), IsMixedPartitionFunctionTotalBounded f.val + (minimumColourDimension f.val) := + @regts_sevenster_minimum_deligne_only + + +/- Upstream contract: +regts_sevenster_rank_growth_deligne_only : DeligneTheoremStatement → + ∀ {R : ℕ} (f : EdgeRankParameter R), + Filter.Tendsto (fun n => (connectionRank f.val (2 * n) : ℝ) ^ ((2 * n : ℕ) : ℝ)⁻¹) Filter.atTop + (nhds ↑(minimumColourDimension f.val)) +-/ +example : DeligneTheoremStatement.{1, 1} → + ∀ {R : ℕ} (f : EdgeRankParameter R), + Filter.Tendsto (fun n => (connectionRank f.val (2 * n) : ℝ) ^ ((2 * n : ℕ) : ℝ)⁻¹) Filter.atTop + (nhds ↑(minimumColourDimension f.val)) := + @regts_sevenster_rank_growth_deligne_only + + +/- Upstream contract: +regts_sevenster_prescribed_deligne_only : DeligneTheoremStatement → + ∀ (f : ClosedFragment → ℂ), + f emptyClosedFragment = 1 → + (∀ (W₁ W₂ : ClosedFragment) (a : Fragment.Equiv W₁ W₂), f W₁ = f W₂) → + ∀ (K L : ℕ), (∃ h : MixedFunctional K L, h.Represents f) ↔ PrescribedColourBounds f K L +-/ +example : DeligneTheoremStatement.{1, 1} → + ∀ (f : ClosedFragment → ℂ), + f emptyClosedFragment = 1 → + (∀ (W₁ W₂ : ClosedFragment) (_a : Fragment.Equiv W₁ W₂), f W₁ = f W₂) → + ∀ (K L : ℕ), (∃ h : MixedFunctional K L, h.Represents f) ↔ PrescribedColourBounds f K L := + @regts_sevenster_prescribed_deligne_only + + +/- Upstream contract: +@minimumColourDimension_le_of_represents : ∀ {f : ClosedFragment → ℂ} {k ℓ : ℕ} (h : MixedFunctional + k ℓ), + h.Represents f → minimumColourDimension f ≤ k + 2 * ℓ +-/ +example : ∀ {f : ClosedFragment → ℂ} {k ℓ : ℕ} (h : MixedFunctional k ℓ), + h.Represents f → minimumColourDimension f ≤ k + 2 * ℓ := + @minimumColourDimension_le_of_represents + + +/- Upstream contract: +@TotalBoundedMixedModel.dimension_eq_minimum : ∀ {f : ClosedFragment → ℂ} + (M : TotalBoundedMixedModel f (minimumColourDimension f)), M.k + 2 * M.ℓ = minimumColourDimension + f +-/ +example : ∀ {f : ClosedFragment → ℂ} + (M : TotalBoundedMixedModel f (minimumColourDimension f)), M.k + 2 * M.ℓ = minimumColourDimension + f := + @TotalBoundedMixedModel.dimension_eq_minimum + + +/- Upstream contract: +@TotalBoundedMixedModel.even_dimension_eq : ∀ {f : ClosedFragment → ℂ} + (M : TotalBoundedMixedModel f (minimumColourDimension f)), + ↑M.k = (↑(minimumColourDimension f) + f (circlesClosed 1)) / 2 +-/ +example : ∀ {f : ClosedFragment → ℂ} + (M : TotalBoundedMixedModel f (minimumColourDimension f)), + ↑M.k = (↑(minimumColourDimension f) + f (circlesClosed 1)) / 2 := + @TotalBoundedMixedModel.even_dimension_eq + + +/- Upstream contract: +@TotalBoundedMixedModel.half_odd_dimension_eq : ∀ {f : ClosedFragment → ℂ} + (M : TotalBoundedMixedModel f (minimumColourDimension f)), + ↑M.ℓ = (↑(minimumColourDimension f) - f (circlesClosed 1)) / 4 +-/ +example : ∀ {f : ClosedFragment → ℂ} + (M : TotalBoundedMixedModel f (minimumColourDimension f)), + ↑M.ℓ = (↑(minimumColourDimension f) - f (circlesClosed 1)) / 4 := + @TotalBoundedMixedModel.half_odd_dimension_eq + + +/- Upstream contract: +@MixedFunctional.padColours : {k ℓ K L : ℕ} → MixedFunctional k ℓ → k ≤ K → ℓ ≤ L → MixedFunctional + K L +-/ +example : {k ℓ K L : ℕ} → MixedFunctional k ℓ → k ≤ K → ℓ ≤ L → MixedFunctional K L := + @MixedFunctional.padColours + + +/- Upstream contract: +@MixedFunctional.padColours_represents : ∀ {k ℓ K L : ℕ} (h : MixedFunctional k ℓ) (hk : k ≤ K) (hℓ + : ℓ ≤ L), + (K : ℂ) - 2 * ↑L = ↑k - 2 * ↑ℓ → ∀ {f : ClosedFragment → ℂ}, h.Represents f → (h.padColours hk + hℓ).Represents f +-/ +example : ∀ {k ℓ K L : ℕ} (h : MixedFunctional k ℓ) (hk : k ≤ K) (hℓ : ℓ ≤ L), + (K : ℂ) - 2 * ↑L = ↑k - 2 * ↑ℓ → ∀ {f : ClosedFragment → ℂ}, h.Represents f → (h.padColours hk + hℓ).Represents f := + @MixedFunctional.padColours_represents + + +/- Upstream contract: +@connectionRank_cast_eq_rank : ∀ {R : ℕ} (f : EdgeRankParameter R) (t : ℕ), + ↑(connectionRank f.val t) = Module.rank ℂ ↥(connectionMap f.val t).range +-/ +example : ∀ {R : ℕ} (f : EdgeRankParameter R) (t : ℕ), + ↑(connectionRank f.val t) = Module.rank ℂ ↥(connectionMap f.val t).range := + @connectionRank_cast_eq_rank + + +/- Upstream contract: +def RS.circlesClosed : ℕ → ClosedFragment := +fun c => (Fragment.circlesOnly c).relabel (Equiv.equivOfIsEmpty Empty (Fin 0)) +-/ +example : @circlesClosed = (fun c => (Fragment.circlesOnly c).relabel (Equiv.equivOfIsEmpty Empty + (Fin 0)) : ℕ → ClosedFragment) := rfl + + +/- Upstream contract: +def RS.connectionRank : (ClosedFragment → ℂ) → ℕ → ℕ := +fun f t => Module.finrank ℂ ↥(connectionMap f t).range +-/ +example : @connectionRank = (fun f t => Module.finrank ℂ ↥(connectionMap f t).range : + (ClosedFragment → ℂ) → ℕ → ℕ) := rfl + + +/- Upstream contract: +def RS.MixedFunctional.Represents : {k ℓ : ℕ} → MixedFunctional k ℓ → (ClosedFragment → ℂ) → Prop := +fun {k ℓ} h f => ∀ (W : ClosedFragment), f W = mixedPartition h W +-/ +example : @MixedFunctional.Represents = (fun {_k _ℓ} h f => ∀ (W : ClosedFragment), f W = + mixedPartition h W : {k ℓ : ℕ} → MixedFunctional k ℓ → (ClosedFragment → ℂ) → Prop) := rfl + + +/- Upstream contract: +def RS.minimumColourDimension : (ClosedFragment → ℂ) → ℕ := +fun f => sInf {d | IsMixedPartitionFunctionTotalBounded f d} +-/ +example : @minimumColourDimension = (fun f => sInf {d | IsMixedPartitionFunctionTotalBounded f d} : + (ClosedFragment → ℂ) → ℕ) := rfl + + +/- Upstream contract: +structure RS.PrescribedColourBounds (f : ClosedFragment → ℂ) (k ℓ : ℕ) : Prop +number of parameters: 3 +fields: + RS.PrescribedColourBounds.circle_eq : f (circlesClosed 1) = ↑k - 2 * ↑ℓ + RS.PrescribedColourBounds.rank_bounded : EdgeRankBounded f (k + 2 * ℓ) +constructor: + RS.PrescribedColourBounds.mk {f : ClosedFragment → ℂ} {k ℓ : ℕ} (circle_eq : f (circlesClosed 1) = + ↑k - 2 * ↑ℓ) + (rank_bounded : EdgeRankBounded f (k + 2 * ℓ)) : PrescribedColourBounds f k ℓ +-/ +example {f : ClosedFragment → ℂ} {k ℓ : ℕ} (circle_eq : f (circlesClosed 1) = ↑k - 2 * ↑ℓ) + (rank_bounded : EdgeRankBounded f (k + 2 * ℓ)) : PrescribedColourBounds f k ℓ := + PrescribedColourBounds.mk circle_eq rank_bounded + + +end RS + +end diff --git a/LeanPool/RegtsSevenster/RS/Classical.lean b/LeanPool/RegtsSevenster/RS/Classical.lean new file mode 100644 index 0000000000..696dd9af51 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical.lean @@ -0,0 +1,145 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Algebra.TraceCriterion +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.KaroubiLinear +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.KaroubiTrace +public import LeanPool.RegtsSevenster.RS.Classical.Algebra.FactorialTrace +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Growth +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Intertwine +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Length +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LengthBound +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LinearCategory +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.PartialTrace +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.TensorPow +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Trace +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.UnitEnd +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneBridge +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackageRestrict +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneTheorem +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.EulerianIndependence +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.FibreTransport +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.KoszulAction +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaPerm +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaTensorPower +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SectorDischarge +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SectorIntertwine +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.TotalDimension +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BlockKill +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BranchTrace +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CentralElem +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharClass +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharDecomp +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharEquiv +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourCycleSum +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourWeight +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CommutantBound +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ContentCount +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleFactor +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleSum +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleSumPrep +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.EndSum +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FibreCard +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FixWeight +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.HVal +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.IdempotentBridge +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTChar +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTIntChar +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTIrreducible +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTOrtho +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTPad +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTSimple +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.KillSimples +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedCount +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedFixed +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeAction +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeFaithful +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeTable +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.OrbitBridge +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.Package +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PackageAssembly +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairChar +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairInner +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairOrbit +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairStab +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairTuple +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairingPos +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PermModule +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PowerSurj +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.RegularTrace +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SameCycleQuot +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ScalarTrace +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SchurAction +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SigmaCycleType +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignResolve +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignedTensor +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SimpleEmbed +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowth +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowthSharp +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareStair +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.StabCount +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorNonvanishing +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorTrace +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.WordCommutant +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourAction +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConj +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjStep +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjTop +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourEval +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourExtendSwap +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourFormMatch +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMerge +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMergeOdd +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairing +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairingSymm +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPower +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourTotal +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourWord +public import LeanPool.RegtsSevenster.RS.Classical.Super.OrthonormalBasis +public import LeanPool.RegtsSevenster.RS.Classical.Super.PowBraid +public import LeanPool.RegtsSevenster.RS.Classical.Super.SuperVect +public import LeanPool.RegtsSevenster.RS.Classical.Super.SymplecticBasis +public import LeanPool.RegtsSevenster.RS.Classical.Super.TotalSpace +public import LeanPool.RegtsSevenster.RS.Classical.Super.WordSignPerm +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantExpand +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantPieri +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantStrict +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.Bialternant +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialDet +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialH +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffExtract +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffSplit +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.DeltaSeq +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.DescVandermonde +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.DimFormula +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.EHConv +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.EHDischarge +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HInsert +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HProdCoeff +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HSubZ +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HookVanishing +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.JTDetExpand +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.JTGuard +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.LGVStrict +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PieriChain +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowCount +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.RationalityFromRecurrence +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.RecurrenceFromVanishing +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.SubsetEH +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.TCount +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.TIdentity +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaExp +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaRational +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaSeries +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdRigid +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdSuper diff --git a/LeanPool/RegtsSevenster/RS/Classical/Algebra/FactorialTrace.lean b/LeanPool/RegtsSevenster/RS/Classical/Algebra/FactorialTrace.lean new file mode 100644 index 0000000000..daafb8a102 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Algebra/FactorialTrace.lean @@ -0,0 +1,138 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.NilpotentPowerTrace +public import LeanPool.RegtsSevenster.RS.Common.TraceSeparation +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FactorialBeats + +/-! +# The factorial obstruction to a nonzero nilpotent trace + +Schrijver's argument (arXiv:1211.3561, Proposition 4) uses only +permutation representations and the cycle-trace identity. A last +nonzero power trace separates all permutations, forcing dimension +at least `n!` at every level. A single level of smaller dimension +therefore suffices for nilpotent-trace vanishing. + +`CycleTraceTower` records precisely these inputs, without Schur +idempotents, branching, hook confinement or rationality. The object +and strand instances are supplied in `Novel/Envelope/FactorialTrace` +and `Novel/Envelope/BlockFactorialTrace`. +-/ + +@[expose] public section + +namespace RS + +/-- Permutation representations and tensor-power traces satisfying +the cycle formula, with fixed points recorded separately. -/ +structure CycleTraceTower (E : ℕ → Type*) [∀ n, Ring (E n)] + [∀ n, Algebra ℂ (E n)] (A : Type*) [Ring A] [Algebra ℂ A] where + /-- The trace on the ambient algebra. -/ + traceA : A →ₗ[ℂ] ℂ + /-- The trace at each tensor level. -/ + trace : ∀ n, E n →ₗ[ℂ] ℂ + /-- The permutation representations. -/ + rep : ∀ n, Equiv.Perm (Fin n) →* E n + /-- The tensor-power maps; their cycle traces are all that is used. -/ + pow : ∀ n, A → E n + /-- The trace of a permutation against a tensor power is the + product of the traces along its cycles. -/ + cycleTrace : ∀ n (π : Equiv.Perm (Fin n)) (g : A), + trace n (rep n π * pow n g) = + (π.cycleType.map (fun c => traceA (g ^ c))).prod * + traceA g ^ (n - π.cycleType.sum) + +namespace CycleTraceTower + +variable {E : ℕ → Type*} + +/-- For an isolated nonzero power trace, every nonidentity +permutation has zero trace against the tensor power. -/ +theorem trace_perm_pow + [∀ n, Ring (E n)] [∀ n, Algebra ℂ (E n)] {A : Type*} [Ring A] + [Algebra ℂ A] + (T : CycleTraceTower E A) {y : A} + (hy : SinglePowerTrace T.traceA y) (n : ℕ) + (π : Equiv.Perm (Fin n)) : + T.trace n (T.rep n π * T.pow n y) = + if π = 1 then T.traceA y ^ n else 0 := by + classical + rw [T.cycleTrace] + by_cases hπ : π = 1 + · subst π + simp + · rw [ite_eq_right hπ] + have hcycles : π.cycleType ≠ 0 := + mt Equiv.Perm.cycleType_eq_zero.mp hπ + obtain ⟨c, hc⟩ := Multiset.exists_mem_of_ne_zero hcycles + have hzero : (π.cycleType.map (fun c => T.traceA (y ^ c))).prod = 0 := + Multiset.prod_eq_zero (Multiset.mem_map.mpr + ⟨c, hc, hy.higher_eq_zero c (Equiv.Perm.two_le_of_mem_cycleType hc)⟩) + rw [hzero, zero_mul] + +/-- An isolated nonzero power trace makes all permutation +operators linearly independent. -/ +theorem linearIndependent_rep + [∀ n, Ring (E n)] [∀ n, Algebra ℂ (E n)] {A : Type*} [Ring A] + [Algebra ℂ A] + (T : CycleTraceTower E A) {y : A} + (hy : SinglePowerTrace T.traceA y) (n : ℕ) : + LinearIndependent ℂ (fun π => T.rep n π) := by + let τ := (T.trace n).comp (LinearMap.mulRight ℂ (T.pow n y)) + exact linearIndependent_of_group_trace (T.rep n) τ + (pow_ne_zero n hy.trace_ne_zero) (T.trace_perm_pow hy n) + +/-- A nilpotent with nonzero trace forces factorial dimension at +every finite-dimensional level. -/ +theorem factorial_le_finrank + [∀ n, Ring (E n)] [∀ n, Algebra ℂ (E n)] {A : Type*} [Ring A] + [Algebra ℂ A] + (T : CycleTraceTower E A) {g : A} + (hg : IsNilpotent g) (hτ : T.traceA g ≠ 0) (n : ℕ) + [Module.Finite ℂ (E n)] : n.factorial ≤ Module.finrank ℂ (E n) := by + obtain ⟨r, _, hr⟩ := exists_singlePowerTrace_pow T.traceA hg hτ + simpa only [Fintype.card_perm, Fintype.card_fin] using + (T.linearIndependent_rep hr n).fintype_card_le_finrank + +/-- One finite-dimensional level below factorial growth forces +the trace of every nilpotent to vanish. -/ +theorem traceA_eq_zero_of_finrank_lt_factorial + [∀ n, Ring (E n)] [∀ n, Algebra ℂ (E n)] {A : Type*} [Ring A] + [Algebra ℂ A] + (T : CycleTraceTower E A) + {n : ℕ} [Module.Finite ℂ (E n)] + (hbound : Module.finrank ℂ (E n) < n.factorial) + {g : A} (hg : IsNilpotent g) : T.traceA g = 0 := by + by_contra hτ + exact (T.factorial_le_finrank hg hτ n).not_gt hbound + +/-- Exponential endomorphism growth is a sufficient instance of +the single-level factorial bound. -/ +theorem traceA_eq_zero_of_exponential_bound + [∀ n, Ring (E n)] [∀ n, Algebra ℂ (E n)] {A : Type*} [Ring A] + [Algebra ℂ A] + (T : CycleTraceTower E A) + [∀ n, Module.Finite ℂ (E n)] (B : ℝ) + (hbound : ∀ n, (Module.finrank ℂ (E n) : ℝ) ≤ B ^ n) + {g : A} (hg : IsNilpotent g) : T.traceA g = 0 := by + obtain ⟨n, hn⟩ := exists_lt_sqrt_factorial 1 B + have hfact : (1 : ℝ) ≤ n.factorial := by + exact_mod_cast (show 1 ≤ n.factorial from Nat.factorial_pos n) + have hsqrt : Real.sqrt (n.factorial : ℝ) ≤ n.factorial := by + apply (Real.sqrt_le_iff).mpr + exact ⟨by positivity, by nlinarith⟩ + have hexp : B ^ n < Real.sqrt (n.factorial : ℝ) := by + simpa only [one_mul] using hn + have hlt : (Module.finrank ℂ (E n) : ℝ) < n.factorial := + (hbound n).trans_lt (hexp.trans_le hsqrt) + exact T.traceA_eq_zero_of_finrank_lt_factorial (by exact_mod_cast hlt) hg + +end CycleTraceTower + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Algebra/TraceCriterion.lean b/LeanPool/RegtsSevenster/RS/Classical/Algebra/TraceCriterion.lean new file mode 100644 index 0000000000..7e6e6445aa --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Algebra/TraceCriterion.lean @@ -0,0 +1,67 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Semisimplicity from a trace form + +A finite-dimensional complex algebra carrying a linear functional +that vanishes on nilpotents and is nondegenerate in the form +`(∀ b, τ (b * a) = 0) → a = 0` is semisimple: every element of the +Jacobson radical is nilpotent (the radical of an Artinian ring is a +nilpotent ideal), so the functional kills `b * j` for every `b`, +forcing `j = 0`. + +-/ + +@[expose] public section + +namespace RS + +universe u + +/-- A finite-dimensional complex algebra with a linear functional +vanishing on nilpotents and nondegenerate in the form +`(∀ b, τ (b * a) = 0) → a = 0` is semisimple. -/ +theorem isSemisimpleRing_of_trace {A : Type u} [Ring A] [Algebra ℂ A] + [FiniteDimensional ℂ A] (τ : A →ₗ[ℂ] ℂ) + (hnil : ∀ x : A, IsNilpotent x → τ x = 0) + (hnondeg : ∀ a : A, (∀ b : A, τ (b * a) = 0) → a = 0) : + IsSemisimpleRing A := by + have : IsArtinianRing A := isArtinian_of_tower ℂ inferInstance + -- ═══════ The radical vanishes ═══════ + obtain ⟨n, hn⟩ := IsArtinianRing.isNilpotent_jacobson_bot (R := A) + have hJbot : Ring.jacobson A = ⊥ := by + rw [eq_bot_iff] + intro j hj + rw [Ideal.mem_bot] + apply hnondeg + intro b + apply hnil + have hbj : b * j ∈ (⊥ : Ideal A).jacobson := by + rw [Ideal.jacobson_bot] + exact Ideal.mul_mem_left _ b hj + refine ⟨n, ?_⟩ + have hpow := Ideal.pow_mem_pow hbj n + rw [hn] at hpow + exact Ideal.mem_bot.mp hpow + -- ═══════ Transport semisimplicity from the trivial quotient ═══════ + have hquot : IsSemisimpleRing (A ⧸ Ring.jacobson A) := + IsSemiprimaryRing.isSemisimpleRing + have hker : Ring.jacobson A = RingHom.ker (RingHom.id A) := by + rw [hJbot] + ext x + simp [RingHom.mem_ker] + have e : (A ⧸ Ring.jacobson A) ≃+* A := + (Ideal.quotEquivOfEq hker).trans + (RingHom.quotientKerEquivOfRightInverse + (f := RingHom.id A) (g := _root_.id) (fun _ => rfl)) + exact RingHom.isSemisimpleRing_of_surjective e.toRingHom e.surjective + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Growth.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Growth.lean new file mode 100644 index 0000000000..d69972d693 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Growth.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LengthBound + +/-! +# Moderate growth of tensor powers + +The two ways of asking that the tensor powers of every object grow +at most exponentially: by the dimension of their endomorphism +algebras (`ModerateEndGrowth`, here), and by their composition +length (`ModerateLengthGrowth`, defined in `RS/Definitions.lean`). +In a semisimple category with finite-dimensional Hom-spaces the +first implies the second, because length is bounded by the +endomorphism dimension. + +Length is the measure Deligne's theorem states its growth +hypothesis in; the endomorphism dimension is the measure the +envelope's rank bound supplies directly. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Limits MonoidalCategory + +universe v u + +variable (A : Type u) + +/-- Every object has moderate tensor-power growth, measured by +endomorphism dimensions. -/ +def ModerateEndGrowth [Category.{v} A] [MonoidalCategory A] + [Preadditive A] [Linear ℂ A] : Prop := + ∀ Y : A, ∃ C c : ℕ, ∀ N : ℕ, + Module.finrank ℂ (tensorPow A Y N ⟶ tensorPow A Y N) ≤ + C * c ^ N + +-- The preadditive and abelian structures are supplied +-- independently, as they are for the envelope; `lengthLE_finrank_end` +-- reconciles them. +/-- **Endomorphism growth bounds length growth** in a semisimple +category with finite-dimensional Hom-spaces: the length of an object +is at most the dimension of its endomorphism algebra, so an +exponential bound on the latter is one on the former. -/ +theorem moderateLengthGrowth_of_endGrowth [Category.{v} A] [MonoidalCategory A] + [Preadditive A] + [Linear ℂ A] [HasFiniteBiproducts A] (hab : Abelian A) + (hss : IsSemisimple A) + (hfd : HasFinDimHom A) (hgrow : ModerateEndGrowth A) : + ModerateLengthGrowth A := by + intro Y + obtain ⟨C, c, hC⟩ := hgrow Y + exact ⟨C, c, fun N => + (lengthLE_finrank_end hab hss hfd (tensorPow A Y N)).mono (hC N)⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Intertwine.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Intertwine.lean new file mode 100644 index 0000000000..2c499c5c4f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Intertwine.lean @@ -0,0 +1,38 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Linear combinations of intertwining endomorphisms + +An intertwining relation is preserved by addition and scalar +multiplication in a linear category. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +/-- Intertwining endomorphisms are closed under addition. -/ +theorem intertwine_add {A : Type*} [Category A] [Preadditive A] + {P Q : A} {a b : P ⟶ P} {a' b' : Q ⟶ Q} {T : P ⟶ Q} + (ha : a ≫ T = T ≫ a') (hb : b ≫ T = T ≫ b') : + (a + b) ≫ T = T ≫ (a' + b') := by + rw [Preadditive.add_comp, Preadditive.comp_add, ha, hb] + +/-- Intertwining endomorphisms are closed under scalar multiplication. -/ +theorem intertwine_smul {A : Type*} [Category A] [Preadditive A] + [Linear ℂ A] {P Q : A} {a : P ⟶ P} {a' : Q ⟶ Q} + {T : P ⟶ Q} (r : ℂ) (h : a ≫ T = T ≫ a') : + (r • a) ≫ T = T ≫ (r • a') := by + rw [Linear.smul_comp, Linear.comp_smul, h] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiLinear.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiLinear.lean new file mode 100644 index 0000000000..b50595b3c8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiLinear.lean @@ -0,0 +1,65 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Linear structure on a Karoubi completion + +The underlying-morphism map transports the linear structure of the +base category to its Karoubi completion. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Idempotents + +/-- The underlying-morphism map is additive. -/ +def karoubiHomAddHom {C : Type*} [Category C] [Preadditive C] + (P Q : Karoubi C) : (P ⟶ Q) →+ (P.X ⟶ Q.X) where + toFun g := g.f + map_zero' := rfl + map_add' _ _ := rfl + +/-- Scaling a Karoubi morphism through its underlying morphism. -/ +noncomputable instance karoubiHomSMul {C : Type*} [Category C] + [Preadditive C] [Linear ℂ C] (P Q : Karoubi C) : + SMul ℂ (P ⟶ Q) where + smul c g := ⟨c • g.f, by + rw [Linear.smul_comp, Linear.comp_smul, g.comm]⟩ + +/-- Karoubi hom-sets inherit the complex module structure. -/ +noncomputable instance karoubiHomModule {C : Type*} [Category C] + [Preadditive C] [Linear ℂ C] (P Q : Karoubi C) : + Module ℂ (P ⟶ Q) := + Function.Injective.module ℂ (karoubiHomAddHom P Q) + (fun _ _ h => Karoubi.Hom.ext h) (fun _ _ => rfl) + +/-- The Karoubi completion of a complex linear category is linear. -/ +noncomputable instance karoubiLinear {C : Type*} [Category C] + [Preadditive C] [Linear ℂ C] : Linear ℂ (Karoubi C) where + smul_comp P Q R c g h := by + apply Karoubi.hom_ext + change (c • g.f) ≫ h.f = c • (g.f ≫ h.f) + rw [Linear.smul_comp] + comp_smul P Q R g c h := by + apply Karoubi.hom_ext + change g.f ≫ (c • h.f) = c • (g.f ≫ h.f) + rw [Linear.comp_smul] + +/-- The underlying-morphism map is complex linear. -/ +noncomputable def karoubiHomLinearMap {C : Type*} [Category C] + [Preadditive C] [Linear ℂ C] (P Q : Karoubi C) : + (P ⟶ Q) →ₗ[ℂ] (P.X ⟶ Q.X) where + toFun g := g.f + map_add' _ _ := rfl + map_smul' _ _ := rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiTrace.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiTrace.lean new file mode 100644 index 0000000000..491190d52f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiTrace.lean @@ -0,0 +1,72 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.KaroubiLinear +public import LeanPool.RegtsSevenster.RS.Classical.Algebra.TraceCriterion +public import LeanPool.RegtsSevenster.RS.Common.NilpotentMap + +/-! +# The trace criterion on a Karoubi corner + +Nilpotence transports along the underlying-morphism map. Cyclicity +sandwiches arbitrary ambient tests into the corner, so a +nondegenerate trace that kills nilpotents proves semisimplicity +of every corner endomorphism algebra. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Idempotents + +/-- Nilpotent corner endomorphisms are nilpotent in the base category. -/ +theorem karoubiEnd_isNilpotent {C : Type*} [Category C] + [Preadditive C] {P : Karoubi C} {x : End P} + (hx : IsNilpotent x) : IsNilpotent (show End P.X from x.f) := + isNilpotent_map_of_mul_zero (fun y : End P => (show End P.X from y.f)) + rfl (fun _ _ => rfl) hx + +/-- A finite-dimensional ambient trace criterion restricts to a +Karoubi corner. -/ +theorem karoubiEnd_isSemisimpleRing_of_trace {C : Type*} [Category C] + [Preadditive C] [Linear ℂ C] (P : Karoubi C) + [FiniteDimensional ℂ (End P.X)] (τ : End P.X →ₗ[ℂ] ℂ) + (hnil : ∀ x : End P.X, IsNilpotent x → τ x = 0) + (hcyc : ∀ a b : End P.X, τ (a ≫ b) = τ (b ≫ a)) + (hnd : ∀ a : End P.X, (∀ b : End P.X, τ (a ≫ b) = 0) → a = 0) : + IsSemisimpleRing (End P) := by + have : FiniteDimensional ℂ (End P) := + FiniteDimensional.of_injective + (show End P →ₗ[ℂ] End P.X from karoubiHomLinearMap P P) + (fun _ _ h => Karoubi.Hom.ext h) + refine isSemisimpleRing_of_trace (τ.comp (karoubiHomLinearMap P P)) + (fun x hx => hnil x.f (karoubiEnd_isNilpotent hx)) (fun a ha => ?_) + apply Karoubi.hom_ext + apply hnd a.f + intro b + have hb : P.p ≫ (P.p ≫ b ≫ P.p) ≫ P.p = P.p ≫ b ≫ P.p := by + simp only [Category.assoc] + rw [show P.p ≫ P.p ≫ b ≫ P.p ≫ P.p = + (P.p ≫ P.p) ≫ b ≫ (P.p ≫ P.p) from by + simp only [Category.assoc]] + rw [P.idem] + have key := ha (⟨P.p ≫ b ≫ P.p, hb⟩ : End P) + have hred : a.f ≫ (P.p ≫ b ≫ P.p) = (a.f ≫ b) ≫ P.p := by + rw [show a.f ≫ (P.p ≫ b ≫ P.p) = + (a.f ≫ P.p) ≫ b ≫ P.p from by simp only [Category.assoc]] + rw [Karoubi.comp_p] + simp only [Category.assoc] + calc τ (a.f ≫ b) = τ (P.p ≫ (a.f ≫ b)) := by + rw [show P.p ≫ (a.f ≫ b) = (P.p ≫ a.f) ≫ b from by + simp only [Category.assoc], Karoubi.p_comp] + _ = τ ((a.f ≫ b) ≫ P.p) := hcyc _ _ + _ = τ (a.f ≫ (P.p ≫ b ≫ P.p)) := by rw [hred] + _ = 0 := key + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Length.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Length.lean new file mode 100644 index 0000000000..abdf787f6e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Length.lean @@ -0,0 +1,327 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Definitions + +/-! +# Bounded length for objects of an abelian category + +A lightweight, bound-shaped notion of composition length +(`LengthLE`, defined with the subquotient relation +`IsSubquotientOf` in `RS/Definitions.lean`): an object `Y` +satisfies `LengthLE Y k` when its subobject order admits no +strictly increasing chain of `k + 2` terms — exactly the predicate +needed to state growth hypotheses, without committing to a +composition-series formalism. + +The elementary API, proved here: the bound is monotone, the predicate transfers +along isomorphisms of the ambient object, zero objects have length +at most `0`, simple objects have length at most `1`, and the bound +is subadditive over binary biproducts. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Limits + +universe v u + +variable {C : Type u} + +/-- The length bound is monotone: a bound at `k` is a bound at any +`k' ≥ k`. -/ +theorem LengthLE.mono [Category.{v} C] + {Y : C} {k k' : ℕ} (h : LengthLE Y k) + (hk : k ≤ k') : LengthLE Y k' := by + intro f hf + exact h (f ∘ Fin.castLE (by omega)) + (hf.comp (Fin.strictMono_castLE (by omega))) + +/-- The length bound transfers along an isomorphism of the ambient +object, via the induced order isomorphism of subobject lattices. -/ +theorem LengthLE.of_iso [Category.{v} C] + {Y Z : C} (e : Y ≅ Z) {k : ℕ} + (h : LengthLE Y k) : LengthLE Z k := by + intro f hf + exact h (fun i => (Subobject.mapIsoToOrderIso e).symm (f i)) + ((Subobject.mapIsoToOrderIso e).symm.strictMono.comp hf) + +/-- A zero object has length at most `0`: its subobject order is a +singleton, so it carries no strictly increasing pair. -/ +theorem lengthLE_of_isZero [Category.{v} C] + {Y : C} (hY : IsZero Y) : LengthLE Y 0 := by + intro f hf + have := Subobject.subsingleton_of_isZero hY + exact (hf (show (0 : Fin 2) < 1 by decide)).ne + (Subsingleton.elim (f 0) (f 1)) + +/-- A simple object has length at most `1`: its subobjects are only +`⊥` and `⊤`, so no chain has three distinct terms. -/ +theorem lengthLE_of_simple [Category.{v} C] [Abelian C] + {Y : C} [Simple Y] : LengthLE Y 1 := by + intro f hf + have h01 : f 0 < f 1 := hf (show (0 : Fin 3) < 1 by decide) + have h12 : f 1 < f 2 := hf (show (1 : Fin 3) < 2 by decide) + rcases eq_bot_or_eq_top (f 1) with h | h + · exact not_lt_bot (h ▸ h01) + · exact not_top_lt (h ▸ h12) + +/-! ### Splitting strict chains in a product order -/ + +section Chains + +/-- Appending a strictly larger element to a strict chain. -/ +private lemma strictMono_snoc {A : Type*} [PartialOrder A] + {p : ℕ} {g : Fin (p + 1) → A} {y : A} + (hg : StrictMono g) (hy : g (Fin.last p) < y) : + StrictMono (Fin.snoc g y : Fin (p + 2) → A) := by + rw [Fin.strictMono_iff_lt_succ] + intro i + induction i using Fin.lastCases with + | last => simpa using hy + | cast j => + rw [Fin.succ_castSucc, Fin.snoc_castSucc, Fin.snoc_castSucc] + exact hg Fin.castSucc_lt_succ + +/-- A strict chain in a product of partial orders splits into strict +chains in the two factors whose numbers of steps sum to at least the +number of steps of the original chain. -/ +private lemma pair_chains + {A : Type*} {B : Type*} [PartialOrder A] [PartialOrder B] + {n : ℕ} : + ∀ w : Fin (n + 1) → A × B, StrictMono w → + ∃ p q, n ≤ p + q ∧ + (∃ g : Fin (p + 1) → A, StrictMono g ∧ + g (Fin.last p) = (w (Fin.last n)).1) ∧ + (∃ g : Fin (q + 1) → B, StrictMono g ∧ + g (Fin.last q) = (w (Fin.last n)).2) := by + induction n with + | zero => + intro w _ + have : Subsingleton (Fin (0 + 1)) := + ⟨fun a b => Fin.ext (by have := a.isLt; have := b.isLt; omega)⟩ + exact ⟨0, 0, Nat.zero_le _, + ⟨fun _ => (w (Fin.last 0)).1, Subsingleton.strictMono _, rfl⟩, + ⟨fun _ => (w (Fin.last 0)).2, Subsingleton.strictMono _, rfl⟩⟩ + | succ n ih => + intro w hw + obtain ⟨p, q, hpq, ⟨g1, hg1, he1⟩, ⟨g2, hg2, he2⟩⟩ := + ih (w ∘ Fin.castSucc) (hw.comp Fin.strictMono_castSucc) + simp only [Function.comp_apply] at he1 he2 + have hlt : w ((Fin.last n).castSucc) < w (Fin.last (n + 1)) := + hw (Fin.castSucc_lt_last _) + rcases Prod.lt_iff.mp hlt with ⟨h1, h2⟩ | ⟨h1, h2⟩ + · rcases h2.eq_or_lt with h2 | h2 + · exact ⟨p + 1, q, by omega, + ⟨Fin.snoc g1 (w (Fin.last (n + 1))).1, + strictMono_snoc hg1 (he1.trans_lt h1), by simp⟩, + ⟨g2, hg2, he2.trans h2⟩⟩ + · exact ⟨p + 1, q + 1, by omega, + ⟨Fin.snoc g1 (w (Fin.last (n + 1))).1, + strictMono_snoc hg1 (he1.trans_lt h1), by simp⟩, + ⟨Fin.snoc g2 (w (Fin.last (n + 1))).2, + strictMono_snoc hg2 (he2.trans_lt h2), by simp⟩⟩ + · rcases h1.eq_or_lt with h1 | h1 + · exact ⟨p, q + 1, by omega, + ⟨g1, hg1, he1.trans h1⟩, + ⟨Fin.snoc g2 (w (Fin.last (n + 1))).2, + strictMono_snoc hg2 (he2.trans_lt h2), by simp⟩⟩ + · exact ⟨p + 1, q + 1, by omega, + ⟨Fin.snoc g1 (w (Fin.last (n + 1))).1, + strictMono_snoc hg1 (he1.trans_lt h1), by simp⟩, + ⟨Fin.snoc g2 (w (Fin.last (n + 1))).2, + strictMono_snoc hg2 (he2.trans_lt h2), by simp⟩⟩ + +end Chains + +/-! ### Subadditivity over a binary biproduct -/ + +/-- A morphism into a binary biproduct that vanishes on the second +projection factors through the first inclusion. -/ +private lemma comp_fst_inl [Category.{v} C] [Abelian C] + {Y Z T : C} (g : T ⟶ Y ⊞ Z) + (hg : g ≫ biprod.snd = 0) : + (g ≫ biprod.fst) ≫ biprod.inl = g := by + conv_rhs => rw [← Category.comp_id g, ← biprod.total] + rw [Preadditive.comp_add, ← Category.assoc, ← Category.assoc, hg, + zero_comp, add_zero] + +/-- The part of a subobject of `Y ⊞ Z` lying over `Y`: the pullback +of the subobject along the first inclusion. -/ +private noncomputable def kerPart [Category.{v} C] [Abelian C] + {Y Z : C} (P : Subobject (Y ⊞ Z)) : + Subobject Y := + Subobject.mk (pullback.fst (biprod.inl : Y ⟶ Y ⊞ Z) P.arrow) + +/-- The image of a subobject of `Y ⊞ Z` under the second +projection. -/ +private noncomputable def imgPart [Category.{v} C] [Abelian C] + {Y Z : C} (P : Subobject (Y ⊞ Z)) : + Subobject Z := + Subobject.mk (image.ι (P.arrow ≫ biprod.snd)) + +/-- The `Y`-part is monotone in the subobject. -/ +private lemma kerPart_mono [Category.{v} C] [Abelian C] + {Y Z : C} {P Q : Subobject (Y ⊞ Z)} + (h : P ≤ Q) : kerPart P ≤ kerPart Q := by + unfold kerPart + refine Subobject.mk_le_mk_of_comm + (pullback.lift (pullback.fst biprod.inl P.arrow) + (pullback.snd biprod.inl P.arrow ≫ Subobject.ofLE P Q h) ?_) + (pullback.lift_fst _ _ _) + rw [Category.assoc, Subobject.ofLE_arrow, pullback.condition] + +/-- The `Z`-image is monotone in the subobject. -/ +private lemma imgPart_mono [Category.{v} C] [Abelian C] + {Y Z : C} {P Q : Subobject (Y ⊞ Z)} + (h : P ≤ Q) : imgPart P ≤ imgPart Q := by + unfold imgPart + refine Subobject.mk_le_mk_of_comm + (image.lift + { I := image (Q.arrow ≫ biprod.snd) + m := image.ι (Q.arrow ≫ biprod.snd) + e := Subobject.ofLE P Q h ≫ + factorThruImage (Q.arrow ≫ biprod.snd) + fac := ?_ }) (image.lift_fac _) + rw [Category.assoc, image.fac, ← Category.assoc, Subobject.ofLE_arrow] + +/-- Nested subobjects of a binary biproduct with the same part over +`Y` and the same image in `Z` coincide. -/ +private lemma eq_of_parts [Category.{v} C] [Abelian C] + {Y Z : C} {P Q : Subobject (Y ⊞ Z)} + (hPQ : P ≤ Q) (hker : kerPart P = kerPart Q) + (himg : imgPart P = imgPart Q) : P = Q := by + unfold kerPart at hker + unfold imgPart at himg + have ht : Subobject.ofLE P Q hPQ ≫ Q.arrow = P.arrow := + Subobject.ofLE_arrow hPQ + -- The kernel of `biprod.snd` restricted to `Q` factors through `P`. + have hy : (kernel.ι (Q.arrow ≫ biprod.snd) ≫ Q.arrow ≫ biprod.fst) + ≫ biprod.inl = kernel.ι (Q.arrow ≫ biprod.snd) ≫ Q.arrow := by + rw [← Category.assoc] + exact comp_fst_inl _ + (by rw [Category.assoc]; exact kernel.condition _) + have hfac : ∃ χ : (kernel (Q.arrow ≫ biprod.snd) : C) ⟶ (P : C), + χ ≫ P.arrow = kernel.ι (Q.arrow ≫ biprod.snd) ≫ Q.arrow := by + refine ⟨pullback.lift + (kernel.ι (Q.arrow ≫ biprod.snd) ≫ Q.arrow ≫ biprod.fst) + (kernel.ι (Q.arrow ≫ biprod.snd)) hy ≫ + Subobject.ofMkLEMk _ _ hker.ge ≫ pullback.snd biprod.inl P.arrow, + ?_⟩ + have hv : Subobject.ofMkLEMk _ _ hker.ge ≫ + pullback.fst biprod.inl P.arrow = + pullback.fst biprod.inl Q.arrow := + Subobject.ofMkLEMk_comp hker.ge + simp only [Category.assoc] + rw [← pullback.condition, + ← Category.assoc (Subobject.ofMkLEMk _ _ hker.ge), hv, + ← Category.assoc, pullback.lift_fst] + exact hy + obtain ⟨χ, hχ⟩ := hfac + have hχt : χ ≫ Subobject.ofLE P Q hPQ = + kernel.ι (Q.arrow ≫ biprod.snd) := by + rw [← cancel_mono Q.arrow, Category.assoc, ht, hχ] + -- The cokernel of the inclusion vanishes on the kernel of the + -- restriction of `biprod.snd` to `Q`. + have hkc : kernel.ι (Q.arrow ≫ biprod.snd) ≫ + cokernel.π (Subobject.ofLE P Q hPQ) = 0 := by + rw [← hχt, Category.assoc, cokernel.condition, comp_zero] + have h3 : kernel.ι (factorThruImage (Q.arrow ≫ biprod.snd)) ≫ + (Q.arrow ≫ biprod.snd) = 0 := by + calc kernel.ι (factorThruImage (Q.arrow ≫ biprod.snd)) ≫ + (Q.arrow ≫ biprod.snd) + = kernel.ι (factorThruImage (Q.arrow ≫ biprod.snd)) ≫ + (factorThruImage (Q.arrow ≫ biprod.snd) ≫ + image.ι (Q.arrow ≫ biprod.snd)) := by rw [image.fac] + _ = (kernel.ι (factorThruImage (Q.arrow ≫ biprod.snd)) ≫ + factorThruImage (Q.arrow ≫ biprod.snd)) ≫ + image.ι (Q.arrow ≫ biprod.snd) := by + rw [Category.assoc] + _ = 0 := by rw [kernel.condition, zero_comp] + have hk2 : kernel.ι (factorThruImage (Q.arrow ≫ biprod.snd)) ≫ + cokernel.π (Subobject.ofLE P Q hPQ) = 0 := by + rw [← kernel.lift_ι (Q.arrow ≫ biprod.snd) + (kernel.ι (factorThruImage (Q.arrow ≫ biprod.snd))) h3, + Category.assoc, hkc, comp_zero] + -- Compare the two images and kill the cokernel. + have hρ : Subobject.ofMkLEMk _ _ himg.le ≫ + image.ι (Q.arrow ≫ biprod.snd) = + image.ι (P.arrow ≫ biprod.snd) := + Subobject.ofMkLEMk_comp himg.le + have hρ' : Subobject.ofMkLEMk _ _ himg.ge ≫ + image.ι (P.arrow ≫ biprod.snd) = + image.ι (Q.arrow ≫ biprod.snd) := + Subobject.ofMkLEMk_comp himg.ge + have hsq : factorThruImage (P.arrow ≫ biprod.snd) ≫ + Subobject.ofMkLEMk _ _ himg.le = + Subobject.ofLE P Q hPQ ≫ + factorThruImage (Q.arrow ≫ biprod.snd) := by + rw [← cancel_mono (image.ι (Q.arrow ≫ biprod.snd)), + Category.assoc, hρ, image.fac, Category.assoc, image.fac, + ← Category.assoc, ht] + have hd : factorThruImage (Q.arrow ≫ biprod.snd) ≫ + Abelian.epiDesc (factorThruImage (Q.arrow ≫ biprod.snd)) + (cokernel.π (Subobject.ofLE P Q hPQ)) hk2 = + cokernel.π (Subobject.ofLE P Q hPQ) := + Abelian.comp_epiDesc _ _ _ + have h5 : Subobject.ofMkLEMk _ _ himg.le ≫ + Abelian.epiDesc (factorThruImage (Q.arrow ≫ biprod.snd)) + (cokernel.π (Subobject.ofLE P Q hPQ)) hk2 = 0 := by + rw [← cancel_epi (factorThruImage (P.arrow ≫ biprod.snd)), + ← Category.assoc, hsq, Category.assoc, hd, cokernel.condition, + comp_zero] + have h6 : Subobject.ofMkLEMk _ _ himg.ge ≫ + Subobject.ofMkLEMk _ _ himg.le = 𝟙 _ := by + rw [← cancel_mono (image.ι (Q.arrow ≫ biprod.snd)), + Category.assoc, hρ, hρ', Category.id_comp] + have h7 : Abelian.epiDesc (factorThruImage (Q.arrow ≫ biprod.snd)) + (cokernel.π (Subobject.ofLE P Q hPQ)) hk2 = 0 := by + rw [← Category.id_comp (Abelian.epiDesc + (factorThruImage (Q.arrow ≫ biprod.snd)) + (cokernel.π (Subobject.ofLE P Q hPQ)) hk2), + ← h6, Category.assoc, h5, comp_zero] + have hcz : cokernel.π (Subobject.ofLE P Q hPQ) = 0 := by + rw [← hd, h7, comp_zero] + have : Epi (Subobject.ofLE P Q hPQ) := + Preadditive.epi_of_cokernel_zero hcz + have : IsIso (Subobject.ofLE P Q hPQ) := + isIso_of_mono_of_epi _ + exact le_antisymm hPQ (Subobject.le_of_comm + (inv (Subobject.ofLE P Q hPQ)) (by rw [IsIso.inv_comp_eq, ht])) + +/-- Subadditivity of the length bound over a binary biproduct: a +strict chain of subobjects of `Y ⊞ Z` is traced by its parts over +`Y` and its images in `Z`, and each strict step moves at least one +of the two. -/ +theorem LengthLE.biprod [Category.{v} C] [Abelian C] + {Y Z : C} {j k : ℕ} (hY : LengthLE Y j) + (hZ : LengthLE Z k) : LengthLE (Y ⊞ Z) (j + k) := by + intro f hf + have hwmono : StrictMono (fun i : Fin (j + k + 1 + 1) => + (kerPart (f i), imgPart (f i))) := by + intro a b hab + refine lt_of_le_of_ne + ⟨kerPart_mono (hf hab).le, imgPart_mono (hf hab).le⟩ + (fun hEq => ?_) + exact (hf hab).ne (eq_of_parts (hf hab).le + (congrArg Prod.fst hEq) (congrArg Prod.snd hEq)) + obtain ⟨p, q, hpq, ⟨g1, hg1, -⟩, ⟨g2, hg2, -⟩⟩ := + pair_chains _ hwmono + have hp : p ≤ j := by + by_contra hp + exact hY (g1 ∘ Fin.castLE (by omega)) + (hg1.comp (Fin.strictMono_castLE (by omega))) + have hq : q ≤ k := by + by_contra hq + exact hZ (g2 ∘ Fin.castLE (by omega)) + (hg2.comp (Fin.strictMono_castLE (by omega))) + omega + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/LengthBound.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/LengthBound.lean new file mode 100644 index 0000000000..a0f9077ac4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/LengthBound.lean @@ -0,0 +1,200 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Length +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LinearCategory + +/-! +# Length bounded by the endomorphism dimension + +In a ℂ-linear semisimple category with finite-dimensional +Hom-spaces, the categorical length of an object is bounded by the +dimension of its endomorphism algebra. Writing `Y ≅ ⨁ S` with the +`S i` simple over `Fin n`, the biproduct of `n` simple objects has +length at most `n`; and the `n` composites of a projection with +the matching inclusion form pairwise-orthogonal nonzero idempotents +in `End Y`, hence a linearly independent family, so that +`n ≤ dim End Y`. Monotonicity of the length bound combines the +two halves. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Limits + +universe v u + +variable {C : Type u} + +/-! ### Length of a biproduct of simple objects -/ + +/-- The biproduct of a family over `Fin (n + 1)` splits off its +head summand as a binary biproduct with the biproduct of its +tail. -/ +private noncomputable def biproductSuccIso [Category.{v} C] + [Preadditive C] + [HasFiniteBiproducts C] [HasBinaryBiproducts C] {n : ℕ} + (S : Fin (n + 1) → C) : + (⨁ S) ≅ S 0 ⊞ ⨁ (fun j : Fin n => S j.succ) where + hom := biprod.lift (biproduct.π S 0) + (biproduct.lift fun j => biproduct.π S j.succ) + inv := biprod.desc (biproduct.ι S 0) + (biproduct.desc fun j => biproduct.ι S j.succ) + hom_inv_id := by + rw [biprod.lift_desc, biproduct.lift_desc, ← biproduct.total, + Fin.sum_univ_succ] + inv_hom_id := by + apply biprod.hom_ext' + · apply biprod.hom_ext + · simp + · apply biproduct.hom_ext + intro j + simp [biproduct.ι_π_ne S (Fin.succ_ne_zero j).symm] + · apply biprod.hom_ext + · apply biproduct.hom_ext' + intro j + simp [biproduct.ι_π_ne S (Fin.succ_ne_zero j)] + · apply biproduct.hom_ext' + intro j + apply biproduct.hom_ext + intro k + by_cases h : j = k + · subst h; simp + · simp [biproduct.ι_π_ne S + (fun hs => h (Fin.succ_injective n hs)), + biproduct.ι_π_ne _ h] + +/-- A biproduct of `n` simple objects has length at most `n`. -/ +theorem lengthLE_biproduct_of_simple [Category.{v} C] + [Abelian C] [HasFiniteBiproducts C] + {n : ℕ} (S : Fin n → C) (hS : ∀ i, Simple (S i)) : + LengthLE (⨁ S) n := by + induction n with + | zero => + refine lengthLE_of_isZero ?_ + rw [IsZero.iff_id_eq_zero] + exact biproduct.hom_ext _ _ fun j => j.elim0 + | succ n ih => + have := hS 0 + have htail := ih (fun j => S j.succ) fun j => hS j.succ + exact ((lengthLE_of_simple.biprod htail).of_iso + (biproductSuccIso S).symm).mono (by omega) + +/-! ### Counting orthogonal idempotents -/ + +/-- Pairwise-orthogonal nonzero idempotent endomorphisms are +linearly independent over ℂ. -/ +private lemma linearIndependent_of_orthogonal_idempotents [Category.{v} C] + [Preadditive C] [Linear ℂ C] {Y : C} {n : ℕ} + (p : Fin n → (Y ⟶ Y)) (hne : ∀ i, p i ≠ 0) + (hidem : ∀ i, p i ≫ p i = p i) + (horth : ∀ i j, i ≠ j → p i ≫ p j = 0) : + LinearIndependent ℂ p := by + rw [Fintype.linearIndependent_iff] + intro g hg j + have h0 : (∑ i, g i • p i) ≫ p j = 0 := by + rw [hg]; exact zero_comp + rw [Preadditive.sum_comp] at h0 + have hterm : ∀ i, (g i • p i) ≫ p j = + if i = j then g j • p j else 0 := by + intro i + by_cases h : i = j + · subst h + rw [ite_eq_left rfl, Linear.smul_comp, hidem] + · rw [ite_eq_right h, Linear.smul_comp, horth i j h, smul_zero] + rw [Finset.sum_congr rfl fun i _ => hterm i, Finset.sum_ite_eq' + Finset.univ j fun _ => g j • p j, ite_eq_left (Finset.mem_univ j)] at h0 + by_contra hgj + exact hne j (by + rw [← one_smul ℂ (p j), ← inv_mul_cancel₀ hgj, mul_smul, h0, + smul_zero]) + +/-- An object isomorphic to a biproduct of `n` simple objects has +`n` pairwise-orthogonal nonzero idempotent endomorphisms, so `n` +is at most the dimension of its endomorphism algebra. -/ +private lemma card_le_finrank_end [Category.{v} C] + [Preadditive C] [Linear ℂ C] + [HasFiniteBiproducts C] {Y : C} {n : ℕ} {S : Fin n → C} + (hS : ∀ i, Simple (S i)) (e : Y ≅ ⨁ S) + (hfd : FiniteDimensional ℂ (End Y)) : + n ≤ Module.finrank ℂ (End Y) := by + set p : Fin n → (Y ⟶ Y) := fun i => + e.hom ≫ biproduct.π S i ≫ biproduct.ι S i ≫ e.inv with hp + have hidem : ∀ i, p i ≫ p i = p i := by + intro i + simp [hp] + have horth : ∀ i j, i ≠ j → p i ≫ p j = 0 := by + intro i j hij + simp [hp, biproduct.ι_π_ne_assoc S hij] + have hne : ∀ i, p i ≠ 0 := by + intro i hzero + have := hS i + apply id_nonzero (S i) + have hcalc : (biproduct.ι S i ≫ e.inv) ≫ p i ≫ + (e.hom ≫ biproduct.π S i) = 𝟙 (S i) := by + simp [hp] + rw [hzero, zero_comp, comp_zero] at hcalc + exact hcalc.symm + have hli := + linearIndependent_of_orthogonal_idempotents p hne hidem horth + have : FiniteDimensional ℂ (Y ⟶ Y) := hfd + have hcard := hli.fintype_card_le_finrank + rw [Fintype.card_fin] at hcard + exact hcard + +/-! ### Reconciling independently supplied structures + +A category may carry its preadditive and its abelian structure as +independent instances — the envelope of the development does. The +two then disagree on which zero-morphism structure to use, and a +hypothesis stated over one does not typecheck against a lemma stated +over the other. Zero-morphism structures are unique, so the +abelian structure can be rebuilt over a prescribed preadditive one: +everything abelianness adds beyond preadditivity is `Prop`-valued +data that transports along that uniqueness. +-/ + +/-- The abelian structure rebuilt over a prescribed preadditive +structure. -/ +@[reducible] +private def abelianOver [Category.{v} C] + [hpre : Preadditive C] (hab : Abelian C) : + Abelian C := + have hzero : + @Preadditive.preadditiveHasZeroMorphisms C _ hab.toPreadditive = + @Preadditive.preadditiveHasZeroMorphisms C _ hpre := + Subsingleton.elim _ _ + { toPreadditive := hpre + toIsNormalMonoCategory := hzero ▸ hab.toIsNormalMonoCategory + toIsNormalEpiCategory := hzero ▸ hab.toIsNormalEpiCategory + has_finite_products := hab.has_finite_products + has_kernels := hzero ▸ hab.has_kernels + has_cokernels := hzero ▸ hab.has_cokernels } + +/-! ### The bound -/ + +/-- **Length is bounded by the endomorphism dimension**: in a +ℂ-linear semisimple category with finite-dimensional Hom-spaces, +every object `Y` satisfies the length bound at `dim End Y`. The +semisimplicity and finiteness hypotheses are read over the +preadditive structure, and the abelian structure is rebuilt over it +so that the two halves compose. -/ +theorem lengthLE_finrank_end [Category.{v} C] + [Preadditive C] [Linear ℂ C] + [HasFiniteBiproducts C] (hab : Abelian C) + (hss : IsSemisimple C) (hfd : HasFinDimHom C) (Y : C) : + LengthLE Y (Module.finrank ℂ (End Y)) := by + obtain ⟨n, S, hS, ⟨e⟩⟩ := hss Y + have hfin : FiniteDimensional ℂ (End Y) := hfd Y Y + let : Abelian C := abelianOver hab + exact ((lengthLE_biproduct_of_simple S hS).of_iso e.symm).mono + (card_le_finrank_end hS e hfin) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/LinearCategory.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/LinearCategory.lean new file mode 100644 index 0000000000..c346bef0aa --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/LinearCategory.lean @@ -0,0 +1,42 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Definitions + +/-! +# Conditions on a ℂ-linear category + +The ambient conditions a tensor category is asked to satisfy: +finite-dimensional Hom-spaces and semisimplicity in the form that +every object is a finite biproduct of simple objects. The third, +scalar endomorphisms of the tensor unit (`HasScalarUnit`), is +defined in `RS/Definitions.lean`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Limits MonoidalCategory + +universe v u + +variable (A : Type u) + +/-- Every Hom-space is finite dimensional over ℂ. -/ +def HasFinDimHom [Category.{v} A] + [Preadditive A] [Linear ℂ A] : Prop := + ∀ X Y : A, FiniteDimensional ℂ (X ⟶ Y) + +/-- Every object is a finite biproduct of simple objects. -/ +def IsSemisimple [Category.{v} A] + [Preadditive A] [HasFiniteBiproducts A] : Prop := + ∀ X : A, ∃ (n : ℕ) (S : Fin n → A), + (∀ i, Simple (S i)) ∧ Nonempty (X ≅ ⨁ S) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/PartialTrace.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/PartialTrace.lean new file mode 100644 index 0000000000..fd2c0b52dc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/PartialTrace.lean @@ -0,0 +1,300 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Trace + +/-! +# The partial categorical trace + +Tracing out the last tensor factor: for `f : P ⊗ X ⟶ P ⊗ X` the +partial trace `ptr f : P ⟶ P` closes the `X` strand into a loop and +leaves the `P` strand open. + +The calculus: the partial trace absorbs factors acting on `P` alone +from either side, it commutes with whiskering by a further factor on +the left, the partial trace of the braiding of the last two factors +is the identity, and the full trace of a partial trace is the full +trace. Those are what the cycle-trace factorisation of a +permutation action needs. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Category CategoryTheory.MonoidalCategory +open CategoryTheory.BraidedCategory + +universe v u + +variable {C : Type u} + +/-- **The partial trace** of an endomorphism of `P ⊗ X` over its +last factor: coevaluate an `X` strand beside `P`, let the +endomorphism act, cross the strand over its dual and evaluate. -/ +def ptr [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [RigidCategory C] + {P X : C} (f : P ⊗ X ⟶ P ⊗ X) : P ⟶ P := + (ρ_ P).inv ≫ (P ◁ η_ X Xᘁ) ≫ (α_ P X Xᘁ).inv ≫ (f ▷ Xᘁ) ≫ + (α_ P X Xᘁ).hom ≫ (P ◁ ((β_ X Xᘁ).hom ≫ ε_ X Xᘁ)) ≫ (ρ_ P).hom + +/-- Whiskering by `P` on the cup side is whiskering on the `P` +strand. -/ +@[reassoc] +private theorem coev_whiskerRight + [Category.{v} C] [MonoidalCategory C] [RigidCategory C] + (P X : C) (a : P ⟶ P) : + (P ◁ η_ X Xᘁ) ≫ (α_ P X Xᘁ).inv ≫ ((a ▷ X) ▷ Xᘁ) = + (a ▷ 𝟙_ C) ≫ (P ◁ η_ X Xᘁ) ≫ (α_ P X Xᘁ).inv := by + rw [← associator_inv_naturality_left, ← Category.assoc, + whisker_exchange, Category.assoc] + +/-- Whiskering by `P` on the cap side is whiskering on the `P` +strand. -/ +@[reassoc] +private theorem whiskerRight_ev + [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [RigidCategory C] + (P X : C) (a : P ⟶ P) : + ((a ▷ X) ▷ Xᘁ) ≫ (α_ P X Xᘁ).hom ≫ + (P ◁ ((β_ X Xᘁ).hom ≫ ε_ X Xᘁ)) = + ((α_ P X Xᘁ).hom ≫ (P ◁ ((β_ X Xᘁ).hom ≫ ε_ X Xᘁ))) ≫ + (a ▷ 𝟙_ C) := by + rw [← Category.assoc, associator_naturality_left, Category.assoc, + ← whisker_exchange, Category.assoc] + +/-- The partial trace absorbs a factor acting on `P` alone from the +left. -/ +theorem ptr_whiskerRight_comp + [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [RigidCategory C] + {P X : C} (a : P ⟶ P) + (f : P ⊗ X ⟶ P ⊗ X) : ptr ((a ▷ X) ≫ f) = a ≫ ptr f := by + change (ρ_ P).inv ≫ (P ◁ η_ X Xᘁ) ≫ (α_ P X Xᘁ).inv ≫ + (((a ▷ X) ≫ f) ▷ Xᘁ) ≫ (α_ P X Xᘁ).hom ≫ + (P ◁ ((β_ X Xᘁ).hom ≫ ε_ X Xᘁ)) ≫ (ρ_ P).hom = + a ≫ (ρ_ P).inv ≫ (P ◁ η_ X Xᘁ) ≫ (α_ P X Xᘁ).inv ≫ + (f ▷ Xᘁ) ≫ (α_ P X Xᘁ).hom ≫ + (P ◁ ((β_ X Xᘁ).hom ≫ ε_ X Xᘁ)) ≫ (ρ_ P).hom + rw [comp_whiskerRight] + simp only [Category.assoc] + rw [coev_whiskerRight_assoc, ← Category.assoc ((ρ_ P).inv), + ← rightUnitor_inv_naturality] + simp only [Category.assoc] + +/-- The partial trace absorbs a factor acting on `P` alone from the +right. -/ +theorem ptr_comp_whiskerRight + [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [RigidCategory C] + {P X : C} (a : P ⟶ P) + (f : P ⊗ X ⟶ P ⊗ X) : ptr (f ≫ (a ▷ X)) = ptr f ≫ a := by + change (ρ_ P).inv ≫ (P ◁ η_ X Xᘁ) ≫ (α_ P X Xᘁ).inv ≫ + ((f ≫ (a ▷ X)) ▷ Xᘁ) ≫ (α_ P X Xᘁ).hom ≫ + (P ◁ ((β_ X Xᘁ).hom ≫ ε_ X Xᘁ)) ≫ (ρ_ P).hom = + ((ρ_ P).inv ≫ (P ◁ η_ X Xᘁ) ≫ (α_ P X Xᘁ).inv ≫ + (f ▷ Xᘁ) ≫ (α_ P X Xᘁ).hom ≫ + (P ◁ ((β_ X Xᘁ).hom ≫ ε_ X Xᘁ)) ≫ (ρ_ P).hom) ≫ a + rw [comp_whiskerRight] + simp only [Category.assoc] + rw [whiskerRight_ev_assoc, rightUnitor_naturality] + +/-! ## Tracing inside a further factor + +Partial trace over the last factor is unaffected by a factor +whiskered on the far left, so it may be computed inside the smaller +tensorand. Combined with the calculus above this evaluates the +partial trace of the braiding of the last two factors. +-/ + +/-- **The partial trace passes a left factor.** A morphism acting +on `R ⊗ X` inside `Q ⊗ (R ⊗ X)` has partial trace `Q ◁ ptr u`. Both +sides carry the same coevaluation, morphism and evaluation in the +same order, so only the bracketing differs. -/ +theorem ptr_whiskerLeft + [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [RigidCategory C] + (Q : C) {R X : C} (u : R ⊗ X ⟶ R ⊗ X) : + ptr ((α_ Q R X).hom ≫ (Q ◁ u) ≫ (α_ Q R X).inv) = + Q ◁ ptr u := by + change (ρ_ (Q ⊗ R)).inv ≫ ((Q ⊗ R) ◁ η_ X Xᘁ) ≫ + (α_ (Q ⊗ R) X Xᘁ).inv ≫ + (((α_ Q R X).hom ≫ (Q ◁ u) ≫ (α_ Q R X).inv) ▷ Xᘁ) ≫ + (α_ (Q ⊗ R) X Xᘁ).hom ≫ + ((Q ⊗ R) ◁ ((β_ X Xᘁ).hom ≫ ε_ X Xᘁ)) ≫ (ρ_ (Q ⊗ R)).hom = + Q ◁ ((ρ_ R).inv ≫ (R ◁ η_ X Xᘁ) ≫ (α_ R X Xᘁ).inv ≫ + (u ▷ Xᘁ) ≫ (α_ R X Xᘁ).hom ≫ + (R ◁ ((β_ X Xᘁ).hom ≫ ε_ X Xᘁ)) ≫ (ρ_ R).hom) + simp only [whiskerLeft_comp, comp_whiskerRight, Category.assoc] + monoidal + +/-- **The partial trace of the braiding is the identity**: the +strand created by the coevaluation crosses the open strand and is +capped against it, and the resulting zig-zag is the snake identity +of the pairing. -/ +theorem ptr_braiding [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [RigidCategory C] + (X : C) : ptr (β_ X X).hom = 𝟙 X := by + change (ρ_ X).inv ≫ (X ◁ η_ X Xᘁ) ≫ (α_ X X Xᘁ).inv ≫ + ((β_ X X).hom ▷ Xᘁ) ≫ (α_ X X Xᘁ).hom ≫ + (X ◁ ((β_ X Xᘁ).hom ≫ ε_ X Xᘁ)) ≫ (ρ_ X).hom = 𝟙 X + -- Reassemble the two crossings into the braiding past `X ⊗ Xᘁ`. + have hbraid : (α_ X X Xᘁ).inv ≫ ((β_ X X).hom ▷ Xᘁ) ≫ + (α_ X X Xᘁ).hom ≫ (X ◁ (β_ X Xᘁ).hom) = + (β_ X (X ⊗ Xᘁ)).hom ≫ (α_ X Xᘁ X).hom := by + rw [braiding_tensor_right_hom] + simp only [Category.assoc, Iso.inv_hom_id, Category.comp_id] + rw [whiskerLeft_comp] + simp only [Category.assoc] + rw [reassoc_of% hbraid] + -- Slide the coevaluation through the braiding and close the snake. + rw [← Category.assoc (X ◁ η_ X Xᘁ), braiding_naturality_right] + simp only [Category.assoc] + rw [reassoc_of% (ExactPairing.evaluation_coevaluation X Xᘁ), + Iso.inv_hom_id, Category.comp_id, braiding_leftUnitor, + Iso.inv_hom_id] + +/-- **The partial trace of a braided last factor**: braiding the +last two factors and then acting by `g` on the last traces to `g` +acting on the factor that remains. -/ +theorem ptr_braiding_whiskerLeft + [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [RigidCategory C] + (Q X : C) (g : X ⟶ X) : + ptr (((α_ Q X X).hom ≫ (Q ◁ (β_ X X).hom) ≫ (α_ Q X X).inv) ≫ + ((Q ⊗ X) ◁ g)) = Q ◁ g := by + have hg : (Q ⊗ X) ◁ g = + (α_ Q X X).hom ≫ (Q ◁ (X ◁ g)) ≫ (α_ Q X X).inv := by + rw [← Category.assoc, ← associator_naturality_right, + Category.assoc, Iso.hom_inv_id, Category.comp_id] + have hsplit : ((α_ Q X X).hom ≫ (Q ◁ (β_ X X).hom) ≫ + (α_ Q X X).inv) ≫ ((Q ⊗ X) ◁ g) = + (α_ Q X X).hom ≫ (Q ◁ ((β_ X X).hom ≫ (X ◁ g))) ≫ + (α_ Q X X).inv := by + rw [hg, whiskerLeft_comp] + simp only [Category.assoc, Iso.inv_hom_id_assoc] + rw [hsplit, ptr_whiskerLeft, ← braiding_naturality_left, + ptr_whiskerRight_comp, ptr_braiding, Category.comp_id] + +/-! ## The full trace of a partial trace + +Closing the remaining `P` strand of `ptr f` into a loop closes both +strands of `f`. The comparison passes through the partial trace +over the *first* factor: against the tensor pairing the two loops of +the full trace disentangle with the `P` loop innermost, and an +exchange of disjoint cups and caps re-nests the loop closure of +`ptr f` into exactly that shape. +-/ + +/-- The partial trace over the first factor: coevaluate a `P` strand +kinked across its dual on the left, let the endomorphism act, and +evaluate. This is the shape in which the tensor pairing presents +the inner loop of the full trace on `P ⊗ X`. -/ +private def ptl [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [RigidCategory C] + {P X : C} (f : P ⊗ X ⟶ P ⊗ X) : X ⟶ X := + (λ_ X).inv ≫ ((η_ P Pᘁ ≫ (β_ P Pᘁ).hom) ▷ X) ≫ (α_ Pᘁ P X).hom ≫ + (Pᘁ ◁ f) ≫ (α_ Pᘁ P X).inv ≫ (ε_ P Pᘁ ▷ X) ≫ (λ_ X).hom + +/-- The full trace is the full trace of the first-factor partial +trace: computed against the tensor pairing, the two loops of the +trace of `f` disentangle into an outer `X` loop around an inner `P` +loop, and the inner loop closed around `f` is exactly `ptl f`. -/ +private theorem catTrace_eq_ptl_trace + [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [RigidCategory C] + {P X : C} + (f : P ⊗ X ⟶ P ⊗ X) : catTrace f = catTrace (ptl f) := by + rw [catTrace_eq_pairTrace f, + pairTrace_eq + (ExactPairing.tensor : ExactPairing (P ⊗ X) (Xᘁ ⊗ Pᘁ)) + HasRightDual.exact f] + change η_ (P ⊗ X) (Xᘁ ⊗ Pᘁ) ≫ f ▷ (Xᘁ ⊗ Pᘁ) ≫ + (β_ (P ⊗ X) (Xᘁ ⊗ Pᘁ)).hom ≫ ε_ (P ⊗ X) (Xᘁ ⊗ Pᘁ) = + catTrace (ptl f) + calc + η_ (P ⊗ X) (Xᘁ ⊗ Pᘁ) ≫ f ▷ (Xᘁ ⊗ Pᘁ) ≫ + (β_ (P ⊗ X) (Xᘁ ⊗ Pᘁ)).hom ≫ ε_ (P ⊗ X) (Xᘁ ⊗ Pᘁ) + -- Take the braiding first and let `f` act afterwards. + = η_ (P ⊗ X) (Xᘁ ⊗ Pᘁ) ≫ (β_ (P ⊗ X) (Xᘁ ⊗ Pᘁ)).hom ≫ + (Xᘁ ⊗ Pᘁ) ◁ f ≫ ε_ (P ⊗ X) (Xᘁ ⊗ Pᘁ) := by + rw [braiding_naturality_left_assoc] + -- Expose the components of the tensor pairing. + _ = ((η_ P Pᘁ ⊗≫ (P ◁ η_ X Xᘁ) ▷ Pᘁ ⊗≫ + 𝟙 ((P ⊗ X) ⊗ Xᘁ ⊗ Pᘁ)) ≫ (β_ (P ⊗ X) (Xᘁ ⊗ Pᘁ)).hom) ≫ + (Xᘁ ⊗ Pᘁ) ◁ f ≫ + (𝟙 ((Xᘁ ⊗ Pᘁ) ⊗ P ⊗ X) ⊗≫ Xᘁ ◁ (ε_ P Pᘁ ▷ X) ⊗≫ + ε_ X Xᘁ) := by + rw [ExactPairing.tensor_coevaluation, + ExactPairing.tensor_evaluation] + simp only [Category.assoc] + -- Disentangle the two loops. + _ = ((η_ X Xᘁ ≫ (β_ X Xᘁ).hom) ⊗≫ + Xᘁ ◁ ((η_ P Pᘁ ≫ (β_ P Pᘁ).hom) ▷ X) ⊗≫ + 𝟙 ((Xᘁ ⊗ Pᘁ) ⊗ P ⊗ X)) ≫ + (Xᘁ ⊗ Pᘁ) ◁ f ≫ + (𝟙 ((Xᘁ ⊗ Pᘁ) ⊗ P ⊗ X) ⊗≫ Xᘁ ◁ (ε_ P Pᘁ ▷ X) ⊗≫ + ε_ X Xᘁ) := by + rw [nested_cups] + -- The inner `P` loop closes around `f`: it is `ptl f`. + _ = η_ X Xᘁ ≫ (β_ X Xᘁ).hom ≫ Xᘁ ◁ ptl f ≫ ε_ X Xᘁ := by + simp only [ptl, whiskerLeft_comp, Category.assoc] + monoidal + _ = catTrace (ptl f) := (catTrace_eq_loop (ptl f)).symm + +/-- The full trace of the last-factor partial trace is the full +trace of the first-factor partial trace: the two cups are disjoint, +as are the two caps, so exchanging each pair re-nests the loop +closure of `ptr f` as the outer `X` loop around the `P` loop. -/ +private theorem ptr_trace_eq_ptl_trace + [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [RigidCategory C] + {P X : C} + (f : P ⊗ X ⟶ P ⊗ X) : + catTrace (ptr f) = catTrace (ptl f) := by + rw [catTrace_eq_loop (ptr f)] + calc + η_ P Pᘁ ≫ (β_ P Pᘁ).hom ≫ Pᘁ ◁ ptr f ≫ ε_ P Pᘁ + -- Unfold the partial trace; group cup with cup, cap with cap. + = 𝟙 (𝟙_ C) ⊗≫ + ((η_ P Pᘁ ≫ (β_ P Pᘁ).hom) ▷ 𝟙_ C ≫ + (Pᘁ ⊗ P) ◁ η_ X Xᘁ) ⊗≫ + Pᘁ ◁ (f ▷ Xᘁ) ⊗≫ + ((Pᘁ ⊗ P) ◁ ((β_ X Xᘁ).hom ≫ ε_ X Xᘁ) ≫ + ε_ P Pᘁ ▷ 𝟙_ C) ⊗≫ + 𝟙 (𝟙_ C) := by + simp only [ptr, whiskerLeft_comp, Category.assoc] + monoidal + -- The cups are disjoint, and so are the caps: exchange both. + _ = 𝟙 (𝟙_ C) ⊗≫ + (𝟙_ C ◁ η_ X Xᘁ ≫ + (η_ P Pᘁ ≫ (β_ P Pᘁ).hom) ▷ (X ⊗ Xᘁ)) ⊗≫ + Pᘁ ◁ (f ▷ Xᘁ) ⊗≫ + (ε_ P Pᘁ ▷ (X ⊗ Xᘁ) ≫ + 𝟙_ C ◁ ((β_ X Xᘁ).hom ≫ ε_ X Xᘁ)) ⊗≫ + 𝟙 (𝟙_ C) := by + rw [← whisker_exchange + (η_ P Pᘁ ≫ (β_ P Pᘁ).hom) (η_ X Xᘁ), + whisker_exchange (ε_ P Pᘁ) + ((β_ X Xᘁ).hom ≫ ε_ X Xᘁ)] + -- The `P` loop closes around `f`: `ptl f` inside an `X` loop. + _ = η_ X Xᘁ ≫ ptl f ▷ Xᘁ ≫ (β_ X Xᘁ).hom ≫ ε_ X Xᘁ := by + simp only [ptl, comp_whiskerRight, Category.assoc] + monoidal + _ = catTrace (ptl f) := rfl + +/-- **The full trace of a partial trace is the full trace**: closing +the remaining strand of `ptr f` into a loop closes both strands of +`f`. -/ +theorem catTrace_ptr [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [RigidCategory C] + {P X : C} (f : P ⊗ X ⟶ P ⊗ X) : + catTrace (ptr f) = catTrace f := + (ptr_trace_eq_ptl_trace f).trans (catTrace_eq_ptl_trace f).symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/TensorPow.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/TensorPow.lean new file mode 100644 index 0000000000..25ddd38095 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/TensorPow.lean @@ -0,0 +1,78 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Length + +/-! +# Tensor powers of an object + +The iterated tensor power `X ^ ⊗ n`, its mixed form and the +condition that a single object tensor-generates are defined in +`RS/Definitions.lean`. This module carries the defining recursion +equations, the stronger retract form of generation the envelope +satisfies, and the implication from it to Deligne's subquotient +form. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Limits MonoidalCategory + +universe v u + +variable (A : Type u) + +/-- The empty tensor power is the unit. -/ +theorem tensorPow_zero [Category.{v} A] [MonoidalCategory A] + (X : A) : tensorPow A X 0 = 𝟙_ A := rfl + +/-- `X ^ ⊗ (n + 1)` is `X ^ ⊗ n ⊗ X`. Together with +`tensorPow_zero` this is the defining recursion. -/ +theorem tensorPow_succ [Category.{v} A] [MonoidalCategory A] + (X : A) (n : ℕ) : + tensorPow A X (n + 1) = tensorPow A X n ⊗ X := rfl + +/-- **Generation by retracts of pure powers**: every object is a +retract of a finite biproduct of tensor powers of `X` alone. This +is how the envelope generates, and it is stronger than Deligne's +hypothesis in two ways at once — a retract rather than a +subquotient, and no duals among the powers. -/ +def RetractGeneratedBy [Category.{v} A] [MonoidalCategory A] + [Preadditive A] [HasFiniteBiproducts A] + (X : A) : Prop := + ∀ Y : A, ∃ (k : ℕ) (ns : Fin k → ℕ) + (ι : Y ⟶ ⨁ fun i => tensorPow A X (ns i)) + (π : (⨁ fun i => tensorPow A X (ns i)) ⟶ Y), + ι ≫ π = 𝟙 Y + +/-- A pure tensor power is the mixed power with no dual factors. -/ +def tensorPowIsoMixed [Category.{v} A] [MonoidalCategory A] + [RigidCategory A] (X : A) (n : ℕ) : + tensorPow A X n ≅ mixedPow A X n 0 := + (ρ_ (tensorPow A X n)).symm + +/-- **The retract formulation implies Deligne's.** A splitting +`ι ≫ π = 𝟙` makes `ι` a split mono, hence a mono, and `Y` is a +quotient of itself, so a retract of a biproduct of pure powers is a +subquotient of the corresponding biproduct of mixed powers. -/ +theorem tensorGeneratedBy_of_retract [Category.{v} A] [MonoidalCategory A] + [Preadditive A] + [HasFiniteBiproducts A] [RigidCategory A] {X : A} + (h : RetractGeneratedBy A X) : TensorGeneratedBy A X := by + intro Y + obtain ⟨k, ns, ι, π, hιπ⟩ := h Y + refine ⟨k, fun t => (ns t, 0), + isSubquotientOf_of_retract + (ι ≫ (biproduct.mapIso fun i => tensorPowIsoMixed A X (ns i)).hom) + ((biproduct.mapIso fun i => tensorPowIsoMixed A X (ns i)).inv ≫ π) + ?_⟩ + rw [Category.assoc, Iso.hom_inv_id_assoc, hιπ] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Trace.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Trace.lean new file mode 100644 index 0000000000..00c6572703 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Trace.lean @@ -0,0 +1,392 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.UnitEnd + +/-! +# The categorical trace + +The trace of an endomorphism `f : X ⟶ X` in a rigid symmetric +monoidal category: coevaluate at `X`, let `f` act, carry the strand +across its right dual with the braiding, and evaluate. The result +is a scalar, an endomorphism of the tensor unit. + +The basic calculus: the trace of the identity is the categorical +dimension; the trace is additive and ℂ-homogeneous; it is cyclic; +and it is multiplicative over the tensor product. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Category CategoryTheory.MonoidalCategory +open CategoryTheory.BraidedCategory + +universe v u + +variable {C : Type u} + +/-- The categorical trace of an endomorphism: coevaluate, act, cross +the strand over the right dual, and evaluate. -/ +def catTrace [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [RigidCategory C] + {X : C} (f : X ⟶ X) : End (𝟙_ C) := + η_ X Xᘁ ≫ f ▷ Xᘁ ≫ (β_ X Xᘁ).hom ≫ ε_ X Xᘁ + +/-- The categorical dimension of an object: the closed loop obtained +by crossing the coevaluation strand over the dual and evaluating. -/ +def catDim [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [RigidCategory C] + (X : C) : End (𝟙_ C) := + η_ X Xᘁ ≫ (β_ X Xᘁ).hom ≫ ε_ X Xᘁ + +/-- The trace of the identity is the categorical dimension. -/ +theorem catTrace_id [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [RigidCategory C] + (X : C) : catTrace (𝟙 X) = catDim X := by + simp [catTrace, catDim] + +/-- The trace is additive. -/ +theorem catTrace_add [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [Preadditive C] [MonoidalPreadditive C] [RigidCategory C] + {X : C} (f g : X ⟶ X) : + catTrace (f + g) = catTrace f + catTrace g := by + change η_ X Xᘁ ≫ (f + g) ▷ Xᘁ ≫ (β_ X Xᘁ).hom ≫ ε_ X Xᘁ = + (η_ X Xᘁ ≫ f ▷ Xᘁ ≫ (β_ X Xᘁ).hom ≫ ε_ X Xᘁ) + + (η_ X Xᘁ ≫ g ▷ Xᘁ ≫ (β_ X Xᘁ).hom ≫ ε_ X Xᘁ) + simp [MonoidalPreadditive.add_whiskerRight] + +/-- The trace is homogeneous for the ℂ-linear structure. -/ +theorem catTrace_smul + [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [Preadditive C] [Linear ℂ C] [MonoidalPreadditive C] + [MonoidalLinear ℂ C] [RigidCategory C] + {X : C} (a : ℂ) (f : X ⟶ X) : + catTrace (a • f) = a • catTrace f := by + change η_ X Xᘁ ≫ (a • f) ▷ Xᘁ ≫ (β_ X Xᘁ).hom ≫ ε_ X Xᘁ = + a • (η_ X Xᘁ ≫ f ▷ Xᘁ ≫ (β_ X Xᘁ).hom ≫ ε_ X Xᘁ) + simp [MonoidalLinear.smul_whiskerRight] + +/-- **Cyclicity of the categorical trace.** Both composites close to +the same loop: pass the strands across the pairing with the adjoint +mates and slide the braiding along. -/ +theorem catTrace_comp_comm + [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [RigidCategory C] + {X Y : C} (f : X ⟶ Y) (g : Y ⟶ X) : + catTrace (f ≫ g) = catTrace (g ≫ f) := by + change η_ X Xᘁ ≫ (f ≫ g) ▷ Xᘁ ≫ (β_ X Xᘁ).hom ≫ ε_ X Xᘁ = + η_ Y Yᘁ ≫ (g ≫ f) ▷ Yᘁ ≫ (β_ Y Yᘁ).hom ≫ ε_ Y Yᘁ + rw [comp_whiskerRight] + simp only [Category.assoc] + rw [braiding_naturality_left_assoc, + ← coevaluation_comp_rightAdjointMate_assoc f, + braiding_naturality_right_assoc, + ← rightAdjointMate_comp_evaluation g, + ← comp_whiskerRight_assoc, ← comp_rightAdjointMate, + rightAdjointMate_comp_evaluation (g ≫ f), + ← braiding_naturality_left_assoc] + +/-- The loop form of the trace: the braiding may be taken first and +the endomorphism absorbed into the evaluation. -/ +theorem catTrace_eq_loop + [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [RigidCategory C] + {X : C} (f : X ⟶ X) : + catTrace f = η_ X Xᘁ ≫ (β_ X Xᘁ).hom ≫ Xᘁ ◁ f ≫ ε_ X Xᘁ := by + change η_ X Xᘁ ≫ f ▷ Xᘁ ≫ (β_ X Xᘁ).hom ≫ ε_ X Xᘁ = _ + rw [braiding_naturality_left_assoc] + +/-- The trace computed against a chosen exact pairing. -/ +def pairTrace [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + {X D : C} (p : ExactPairing X D) (f : X ⟶ X) : + End (𝟙_ C) := + letI := p + η_ X D ≫ f ▷ D ≫ (β_ X D).hom ≫ ε_ X D + +/-- The trace does not depend on the choice of exact pairing: the +comparison morphism between two right duals carries one pairing's +coevaluation and evaluation to the other's. -/ +theorem pairTrace_eq [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + {X D₁ D₂ : C} (p₁ : ExactPairing X D₁) + (p₂ : ExactPairing X D₂) (f : X ⟶ X) : + pairTrace p₂ f = pairTrace p₁ f := by + let := p₁ + let := p₂ + obtain ⟨φ, hA, hB⟩ : + ∃ φ : D₁ ⟶ D₂, η_ X D₁ ≫ X ◁ φ = η_ X D₂ ∧ + φ ▷ X ≫ ε_ X D₂ = ε_ X D₁ := by + refine ⟨@rightAdjointMate C _ _ X X ⟨D₂⟩ ⟨D₁⟩ (𝟙 X), ?_, ?_⟩ + · simpa using + @coevaluation_comp_rightAdjointMate C _ _ X X ⟨D₂⟩ ⟨D₁⟩ (𝟙 X) + · simpa using + @rightAdjointMate_comp_evaluation C _ _ X X ⟨D₂⟩ ⟨D₁⟩ (𝟙 X) + change η_ X D₂ ≫ f ▷ D₂ ≫ (β_ X D₂).hom ≫ ε_ X D₂ = + η_ X D₁ ≫ f ▷ D₁ ≫ (β_ X D₁).hom ≫ ε_ X D₁ + rw [← hA, assoc, whisker_exchange_assoc, + braiding_naturality_right_assoc, hB] + +/-- The categorical trace is the pairing trace of the canonical +pairing supplied by rigidity. -/ +theorem catTrace_eq_pairTrace + [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [RigidCategory C] + {X : C} (f : X ⟶ X) : + catTrace f = pairTrace HasRightDual.exact f := + rfl + +/-- The block braiding carries the nested coevaluations of a tensor +pairing to nested kinked cups: the strands of each loop cross the +other loop twice with opposite senses, so the two crossings cancel +by symmetry and the loops disentangle. -/ +theorem nested_cups [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [RigidCategory C] + (X Y : C) : + (η_ X Xᘁ ⊗≫ (X ◁ η_ Y Yᘁ) ▷ Xᘁ ⊗≫ 𝟙 ((X ⊗ Y) ⊗ Yᘁ ⊗ Xᘁ)) ≫ + (β_ (X ⊗ Y) (Yᘁ ⊗ Xᘁ)).hom = + (η_ Y Yᘁ ≫ (β_ Y Yᘁ).hom) ⊗≫ + Yᘁ ◁ ((η_ X Xᘁ ≫ (β_ X Xᘁ).hom) ▷ Y) ⊗≫ + 𝟙 ((Yᘁ ⊗ Xᘁ) ⊗ X ⊗ Y) := by + calc + (η_ X Xᘁ ⊗≫ (X ◁ η_ Y Yᘁ) ▷ Xᘁ ⊗≫ 𝟙 ((X ⊗ Y) ⊗ Yᘁ ⊗ Xᘁ)) ≫ + (β_ (X ⊗ Y) (Yᘁ ⊗ Xᘁ)).hom + -- Expand the block braiding into the four strand crossings. + = η_ X Xᘁ ⊗≫ (X ◁ η_ Y Yᘁ) ▷ Xᘁ ⊗≫ + X ◁ (β_ Y Yᘁ).hom ▷ Xᘁ ⊗≫ + X ◁ Yᘁ ◁ (β_ Y Xᘁ).hom ⊗≫ + (β_ X Yᘁ).hom ▷ (Xᘁ ⊗ Y) ⊗≫ + Yᘁ ◁ (β_ X Xᘁ).hom ▷ Y ⊗≫ + 𝟙 ((Yᘁ ⊗ Xᘁ) ⊗ X ⊗ Y) := by + rw [braiding_tensor_left_hom, braiding_tensor_right_hom, + braiding_tensor_right_hom] + monoidal + -- Group the two inter-loop crossings for the exchange. + _ = η_ X Xᘁ ⊗≫ (X ◁ η_ Y Yᘁ) ▷ Xᘁ ⊗≫ + X ◁ (β_ Y Yᘁ).hom ▷ Xᘁ ⊗≫ + ((X ⊗ Yᘁ) ◁ (β_ Y Xᘁ).hom ≫ (β_ X Yᘁ).hom ▷ (Xᘁ ⊗ Y)) ⊗≫ + Yᘁ ◁ (β_ X Xᘁ).hom ▷ Y ⊗≫ + 𝟙 ((Yᘁ ⊗ Xᘁ) ⊗ X ⊗ Y) := by + monoidal + -- The two crossings act on disjoint strands, so they commute. + _ = η_ X Xᘁ ⊗≫ (X ◁ η_ Y Yᘁ) ▷ Xᘁ ⊗≫ + X ◁ (β_ Y Yᘁ).hom ▷ Xᘁ ⊗≫ + ((β_ X Yᘁ).hom ▷ (Y ⊗ Xᘁ) ≫ (Yᘁ ⊗ X) ◁ (β_ Y Xᘁ).hom) ⊗≫ + Yᘁ ◁ (β_ X Xᘁ).hom ▷ Y ⊗≫ + 𝟙 ((Yᘁ ⊗ Xᘁ) ⊗ X ⊗ Y) := by + rw [whisker_exchange (β_ X Yᘁ).hom (β_ Y Xᘁ).hom] + -- Insert a cancelling pair of crossings of `X` and `Y`. + _ = η_ X Xᘁ ⊗≫ (X ◁ η_ Y Yᘁ) ▷ Xᘁ ⊗≫ + X ◁ (β_ Y Yᘁ).hom ▷ Xᘁ ⊗≫ + (β_ X Yᘁ).hom ▷ (Y ⊗ Xᘁ) ⊗≫ + Yᘁ ◁ ((β_ X Y).hom ≫ (β_ Y X).hom) ▷ Xᘁ ⊗≫ + (Yᘁ ⊗ X) ◁ (β_ Y Xᘁ).hom ⊗≫ + Yᘁ ◁ (β_ X Xᘁ).hom ▷ Y ⊗≫ + 𝟙 ((Yᘁ ⊗ Xᘁ) ⊗ X ⊗ Y) := by + rw [SymmetricCategory.symmetry] + monoidal + -- The `X` strand now crosses the whole `g`-loop cup at once. + _ = η_ X Xᘁ ⊗≫ (X ◁ η_ Y Yᘁ) ▷ Xᘁ ⊗≫ + X ◁ (β_ Y Yᘁ).hom ▷ Xᘁ ⊗≫ + (β_ X (Yᘁ ⊗ Y)).hom ▷ Xᘁ ⊗≫ + Yᘁ ◁ (β_ Y X).hom ▷ Xᘁ ⊗≫ + (Yᘁ ⊗ X) ◁ (β_ Y Xᘁ).hom ⊗≫ + Yᘁ ◁ (β_ X Xᘁ).hom ▷ Y ⊗≫ + 𝟙 ((Yᘁ ⊗ Xᘁ) ⊗ X ⊗ Y) := by + rw [braiding_tensor_right_hom] + monoidal + -- Group the kinked cup of the `g`-loop with that crossing. + _ = η_ X Xᘁ ⊗≫ + ((X ◁ (η_ Y Yᘁ ≫ (β_ Y Yᘁ).hom) ≫ + (β_ X (Yᘁ ⊗ Y)).hom) ▷ Xᘁ) ⊗≫ + Yᘁ ◁ (β_ Y X).hom ▷ Xᘁ ⊗≫ + (Yᘁ ⊗ X) ◁ (β_ Y Xᘁ).hom ⊗≫ + Yᘁ ◁ (β_ X Xᘁ).hom ▷ Y ⊗≫ + 𝟙 ((Yᘁ ⊗ Xᘁ) ⊗ X ⊗ Y) := by + monoidal + -- Slide the crossing off the cup by naturality. + _ = η_ X Xᘁ ⊗≫ + (((β_ X (𝟙_ C)).hom ≫ + (η_ Y Yᘁ ≫ (β_ Y Yᘁ).hom) ▷ X) ▷ Xᘁ) ⊗≫ + Yᘁ ◁ (β_ Y X).hom ▷ Xᘁ ⊗≫ + (Yᘁ ⊗ X) ◁ (β_ Y Xᘁ).hom ⊗≫ + Yᘁ ◁ (β_ X Xᘁ).hom ▷ Y ⊗≫ + 𝟙 ((Yᘁ ⊗ Xᘁ) ⊗ X ⊗ Y) := by + rw [braiding_naturality_right X (η_ Y Yᘁ ≫ (β_ Y Yᘁ).hom)] + -- The unit braiding is coherence; regroup the two cups. + _ = 𝟙 (𝟙_ C) ⊗≫ + (𝟙_ C ◁ η_ X Xᘁ ≫ + (η_ Y Yᘁ ≫ (β_ Y Yᘁ).hom) ▷ (X ⊗ Xᘁ)) ⊗≫ + Yᘁ ◁ (β_ Y X).hom ▷ Xᘁ ⊗≫ + (Yᘁ ⊗ X) ◁ (β_ Y Xᘁ).hom ⊗≫ + Yᘁ ◁ (β_ X Xᘁ).hom ▷ Y ⊗≫ + 𝟙 ((Yᘁ ⊗ Xᘁ) ⊗ X ⊗ Y) := by + rw [braiding_tensorUnit_right] + monoidal + -- The two cups are disjoint, so they exchange. + _ = 𝟙 (𝟙_ C) ⊗≫ + ((η_ Y Yᘁ ≫ (β_ Y Yᘁ).hom) ▷ (𝟙_ C) ≫ + (Yᘁ ⊗ Y) ◁ η_ X Xᘁ) ⊗≫ + Yᘁ ◁ (β_ Y X).hom ▷ Xᘁ ⊗≫ + (Yᘁ ⊗ X) ◁ (β_ Y Xᘁ).hom ⊗≫ + Yᘁ ◁ (β_ X Xᘁ).hom ▷ Y ⊗≫ + 𝟙 ((Yᘁ ⊗ Xᘁ) ⊗ X ⊗ Y) := by + rw [whisker_exchange (η_ Y Yᘁ ≫ (β_ Y Yᘁ).hom) (η_ X Xᘁ)] + -- The `Y` strand now crosses the whole `f`-loop cup at once. + _ = (η_ Y Yᘁ ≫ (β_ Y Yᘁ).hom) ⊗≫ + Yᘁ ◁ (Y ◁ η_ X Xᘁ ≫ (β_ Y (X ⊗ Xᘁ)).hom) ⊗≫ + Yᘁ ◁ (β_ X Xᘁ).hom ▷ Y ⊗≫ + 𝟙 ((Yᘁ ⊗ Xᘁ) ⊗ X ⊗ Y) := by + rw [braiding_tensor_right_hom] + monoidal + -- Slide that crossing off the cup by naturality. + _ = (η_ Y Yᘁ ≫ (β_ Y Yᘁ).hom) ⊗≫ + Yᘁ ◁ ((β_ Y (𝟙_ C)).hom ≫ η_ X Xᘁ ▷ Y) ⊗≫ + Yᘁ ◁ (β_ X Xᘁ).hom ▷ Y ⊗≫ + 𝟙 ((Yᘁ ⊗ Xᘁ) ⊗ X ⊗ Y) := by + rw [braiding_naturality_right Y (η_ X Xᘁ)] + -- The unit braiding is coherence; absorb the residual kink. + _ = (η_ Y Yᘁ ≫ (β_ Y Yᘁ).hom) ⊗≫ + Yᘁ ◁ ((η_ X Xᘁ ≫ (β_ X Xᘁ).hom) ▷ Y) ⊗≫ + 𝟙 ((Yᘁ ⊗ Xᘁ) ⊗ X ⊗ Y) := by + rw [braiding_tensorUnit_right] + monoidal + +/-- A scalar whiskered on the right of an object may be moved to the +left: naturality of the braiding at the tensor unit, where the +braiding itself is coherence. -/ +private theorem scalar_shift + [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + (s : 𝟙_ C ⟶ 𝟙_ C) (Y : C) : + s ▷ Y = 𝟙 (𝟙_ C ⊗ Y) ⊗≫ Y ◁ s ⊗≫ 𝟙 (𝟙_ C ⊗ Y) := by + have h := braiding_naturality_left s Y + rw [braiding_tensorUnit_left] at h + calc s ▷ Y + = (s ▷ Y ≫ ((λ_ Y).hom ≫ (ρ_ Y).inv)) ⊗≫ 𝟙 (𝟙_ C ⊗ Y) := by + monoidal + _ = (((λ_ Y).hom ≫ (ρ_ Y).inv) ≫ Y ◁ s) ⊗≫ 𝟙 (𝟙_ C ⊗ Y) := by + rw [h] + _ = 𝟙 (𝟙_ C ⊗ Y) ⊗≫ Y ◁ s ⊗≫ 𝟙 (𝟙_ C ⊗ Y) := by + monoidal + +/-- **Multiplicativity of the categorical trace.** The trace of a +tensor product of endomorphisms is the product of the traces in the +scalar monoid `End (𝟙_ C)`. The trace of the tensor product may be +computed against the tensor pairing; there the two loops disentangle +by symmetry and the inner loop contracts to a scalar. -/ +theorem catTrace_tensorHom + [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [RigidCategory C] + {X Y : C} (f : X ⟶ X) (g : Y ⟶ Y) : + catTrace (f ⊗ₘ g) = catTrace f * catTrace g := by + rw [End.mul_def, catTrace_eq_pairTrace (f ⊗ₘ g), + pairTrace_eq (ExactPairing.tensor : ExactPairing (X ⊗ Y) (Yᘁ ⊗ Xᘁ)) + HasRightDual.exact (f ⊗ₘ g)] + change η_ (X ⊗ Y) (Yᘁ ⊗ Xᘁ) ≫ (f ⊗ₘ g) ▷ (Yᘁ ⊗ Xᘁ) ≫ + (β_ (X ⊗ Y) (Yᘁ ⊗ Xᘁ)).hom ≫ ε_ (X ⊗ Y) (Yᘁ ⊗ Xᘁ) = + catTrace g ≫ catTrace f + obtain ⟨s, hs⟩ : ∃ s : 𝟙_ C ⟶ 𝟙_ C, + η_ X Xᘁ ≫ (β_ X Xᘁ).hom ≫ Xᘁ ◁ f ≫ ε_ X Xᘁ = s := ⟨_, rfl⟩ + obtain ⟨t, ht⟩ : ∃ t : 𝟙_ C ⟶ 𝟙_ C, + η_ Y Yᘁ ≫ (β_ Y Yᘁ).hom ≫ Yᘁ ◁ g ≫ ε_ Y Yᘁ = t := ⟨_, rfl⟩ + calc + η_ (X ⊗ Y) (Yᘁ ⊗ Xᘁ) ≫ (f ⊗ₘ g) ▷ (Yᘁ ⊗ Xᘁ) ≫ + (β_ (X ⊗ Y) (Yᘁ ⊗ Xᘁ)).hom ≫ ε_ (X ⊗ Y) (Yᘁ ⊗ Xᘁ) + -- Take the braiding first and let `f ⊗ₘ g` act afterwards. + = η_ (X ⊗ Y) (Yᘁ ⊗ Xᘁ) ≫ (β_ (X ⊗ Y) (Yᘁ ⊗ Xᘁ)).hom ≫ + (Yᘁ ⊗ Xᘁ) ◁ (f ⊗ₘ g) ≫ ε_ (X ⊗ Y) (Yᘁ ⊗ Xᘁ) := by + rw [braiding_naturality_left_assoc] + -- Expose the components of the tensor pairing. + _ = ((η_ X Xᘁ ⊗≫ (X ◁ η_ Y Yᘁ) ▷ Xᘁ ⊗≫ + 𝟙 ((X ⊗ Y) ⊗ Yᘁ ⊗ Xᘁ)) ≫ (β_ (X ⊗ Y) (Yᘁ ⊗ Xᘁ)).hom) ≫ + (Yᘁ ⊗ Xᘁ) ◁ (f ⊗ₘ g) ≫ + (𝟙 ((Yᘁ ⊗ Xᘁ) ⊗ X ⊗ Y) ⊗≫ Yᘁ ◁ (ε_ X Xᘁ ▷ Y) ⊗≫ + ε_ Y Yᘁ) := by + rw [ExactPairing.tensor_coevaluation, + ExactPairing.tensor_evaluation] + simp only [Category.assoc] + -- Disentangle the two loops. + _ = ((η_ Y Yᘁ ≫ (β_ Y Yᘁ).hom) ⊗≫ + Yᘁ ◁ ((η_ X Xᘁ ≫ (β_ X Xᘁ).hom) ▷ Y) ⊗≫ + 𝟙 ((Yᘁ ⊗ Xᘁ) ⊗ X ⊗ Y)) ≫ + (Yᘁ ⊗ Xᘁ) ◁ (f ⊗ₘ g) ≫ + (𝟙 ((Yᘁ ⊗ Xᘁ) ⊗ X ⊗ Y) ⊗≫ Yᘁ ◁ (ε_ X Xᘁ ▷ Y) ⊗≫ + ε_ Y Yᘁ) := by + rw [nested_cups] + -- Split `f ⊗ₘ g` and push `g` past the inner evaluation. + _ = (η_ Y Yᘁ ≫ (β_ Y Yᘁ).hom) ⊗≫ + Yᘁ ◁ ((η_ X Xᘁ ≫ (β_ X Xᘁ).hom) ▷ Y) ⊗≫ + (Yᘁ ⊗ Xᘁ) ◁ (f ▷ Y) ⊗≫ + Yᘁ ◁ ((Xᘁ ⊗ X) ◁ g ≫ ε_ X Xᘁ ▷ Y) ⊗≫ + ε_ Y Yᘁ := by + rw [tensorHom_def] + monoidal + _ = (η_ Y Yᘁ ≫ (β_ Y Yᘁ).hom) ⊗≫ + Yᘁ ◁ ((η_ X Xᘁ ≫ (β_ X Xᘁ).hom) ▷ Y) ⊗≫ + (Yᘁ ⊗ Xᘁ) ◁ (f ▷ Y) ⊗≫ + Yᘁ ◁ (ε_ X Xᘁ ▷ Y ≫ 𝟙_ C ◁ g) ⊗≫ + ε_ Y Yᘁ := by + rw [whisker_exchange (ε_ X Xᘁ) g] + -- The inner loop closes on `f`. + _ = (η_ Y Yᘁ ≫ (β_ Y Yᘁ).hom) ⊗≫ + Yᘁ ◁ ((η_ X Xᘁ ≫ (β_ X Xᘁ).hom ≫ Xᘁ ◁ f ≫ ε_ X Xᘁ) ▷ Y) ⊗≫ + Yᘁ ◁ g ⊗≫ + ε_ Y Yᘁ := by + monoidal + _ = (η_ Y Yᘁ ≫ (β_ Y Yᘁ).hom) ⊗≫ + Yᘁ ◁ (s ▷ Y) ⊗≫ Yᘁ ◁ g ⊗≫ ε_ Y Yᘁ := by + rw [hs] + -- Shift the scalar out of the middle slot. + _ = (η_ Y Yᘁ ≫ (β_ Y Yᘁ).hom) ⊗≫ + ((Yᘁ ⊗ Y) ◁ s ≫ (Yᘁ ◁ g) ▷ 𝟙_ C) ⊗≫ + ε_ Y Yᘁ := by + rw [scalar_shift s Y] + monoidal + _ = (η_ Y Yᘁ ≫ (β_ Y Yᘁ).hom) ⊗≫ + ((Yᘁ ◁ g) ▷ 𝟙_ C ≫ (Yᘁ ⊗ Y) ◁ s) ⊗≫ + ε_ Y Yᘁ := by + rw [← whisker_exchange (Yᘁ ◁ g) s] + _ = (η_ Y Yᘁ ≫ (β_ Y Yᘁ).hom) ⊗≫ (Yᘁ ◁ g) ▷ 𝟙_ C ⊗≫ + ((Yᘁ ⊗ Y) ◁ s ≫ ε_ Y Yᘁ ▷ 𝟙_ C) ⊗≫ + 𝟙 (𝟙_ C) := by + monoidal + _ = (η_ Y Yᘁ ≫ (β_ Y Yᘁ).hom) ⊗≫ (Yᘁ ◁ g) ▷ 𝟙_ C ⊗≫ + (ε_ Y Yᘁ ▷ 𝟙_ C ≫ 𝟙_ C ◁ s) ⊗≫ + 𝟙 (𝟙_ C) := by + rw [whisker_exchange (ε_ Y Yᘁ) s] + -- The outer loop closes on `g`, and the scalars compose. + _ = (η_ Y Yᘁ ≫ (β_ Y Yᘁ).hom ≫ Yᘁ ◁ g ≫ ε_ Y Yᘁ) ≫ s := by + monoidal + _ = catTrace g ≫ catTrace f := by + rw [catTrace_eq_loop g, catTrace_eq_loop f, hs, ht] + +/-- **The dimension of the tensor unit is one.** Computed against +the unit's pairing with itself, the loop closes to the identity +scalar. -/ +@[simp] +theorem catDim_unit [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [RigidCategory C] : catDim (𝟙_ C) = 1 := by + have h : catDim (𝟙_ C) = pairTrace exactPairingUnit (𝟙 (𝟙_ C)) := by + rw [← catTrace_id, catTrace_eq_pairTrace] + exact pairTrace_eq _ _ _ + rw [h, End.one_def] + change (ρ_ (𝟙_ C)).inv ≫ (𝟙 (𝟙_ C) ▷ 𝟙_ C) ≫ + (β_ (𝟙_ C) (𝟙_ C)).hom ≫ (ρ_ (𝟙_ C)).hom = 𝟙 (𝟙_ C) + rw [braiding_tensorUnit_left, MonoidalCategory.unitors_equal] + monoidal + +/-- **The trace as a ℂ-linear map** into the scalar monoid. -/ +def catTraceLin [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] + [Preadditive C] [Linear ℂ C] [MonoidalPreadditive C] + [MonoidalLinear ℂ C] [RigidCategory C] + (X : C) : End X →ₗ[ℂ] End (𝟙_ C) where + toFun := catTrace + map_add' := catTrace_add + map_smul' := catTrace_smul + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/UnitEnd.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/UnitEnd.lean new file mode 100644 index 0000000000..3d7af0c0ce --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/UnitEnd.lean @@ -0,0 +1,82 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# The scalars of a monoidal category commute + +The endomorphisms of the tensor unit form a commutative monoid. The +tensor product is a second unital multiplication on `End (𝟙_ C)`, +and the interchange law makes it compatible with composition, so the +Eckmann–Hilton argument applies: conjugating by the unitor writes an +endomorphism of the unit either as a right whiskering or as a left +whiskering, and whiskerings on opposite sides commute. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +variable {C : Type u} + +/-- The two unitors of the tensor unit agree. -/ +private theorem unitor_iso_eq + [Category.{v} C] [MonoidalCategory C] : (λ_ (𝟙_ C)) = (ρ_ (𝟙_ C)) := + Iso.ext unitors_equal + +/-- Conjugating by the right unitor recovers an endomorphism of the +unit from its right whiskering. -/ +@[reassoc] +private theorem whiskerRight_unit [Category.{v} C] [MonoidalCategory C] + (f : 𝟙_ C ⟶ 𝟙_ C) : + (ρ_ (𝟙_ C)).inv ≫ (f ▷ 𝟙_ C) ≫ (ρ_ (𝟙_ C)).hom = f := by + rw [rightUnitor_naturality, ← Category.assoc, Iso.inv_hom_id, + Category.id_comp] + +/-- Conjugating by the right unitor recovers an endomorphism of the +unit from its left whiskering. -/ +@[reassoc] +private theorem whiskerLeft_unit [Category.{v} C] [MonoidalCategory C] + (g : 𝟙_ C ⟶ 𝟙_ C) : + (ρ_ (𝟙_ C)).inv ≫ (𝟙_ C ◁ g) ≫ (ρ_ (𝟙_ C)).hom = g := by + rw [← unitor_iso_eq, leftUnitor_naturality, ← Category.assoc, + Iso.inv_hom_id, Category.id_comp] + +/-- **Endomorphisms of the tensor unit commute.** -/ +theorem unit_comp_comm [Category.{v} C] [MonoidalCategory C] + (f g : 𝟙_ C ⟶ 𝟙_ C) : f ≫ g = g ≫ f := by + have h1 : (ρ_ (𝟙_ C)).inv ≫ (f ▷ 𝟙_ C) ≫ (𝟙_ C ◁ g) ≫ + (ρ_ (𝟙_ C)).hom = f ≫ g := by + rw [← unitor_iso_eq, leftUnitor_naturality, unitor_iso_eq, + whiskerRight_unit_assoc] + have h2 : (ρ_ (𝟙_ C)).inv ≫ (𝟙_ C ◁ g) ≫ (f ▷ 𝟙_ C) ≫ + (ρ_ (𝟙_ C)).hom = g ≫ f := by + rw [rightUnitor_naturality, whiskerLeft_unit_assoc] + rw [← h1, ← h2, ← whisker_exchange_assoc] + +/-- The scalars form a commutative monoid. -/ +instance endUnitCommMonoid + [Category.{v} C] [MonoidalCategory C] : CommMonoid (End (𝟙_ C)) := + { (inferInstance : Monoid (End (𝟙_ C))) with + mul_comm := fun f g => unit_comp_comm g f } + +/-- The unit braids trivially with itself. -/ +theorem braiding_unit_self [Category.{v} C] [MonoidalCategory C] + [BraidedCategory C] : + (β_ (𝟙_ C) (𝟙_ C)).hom = 𝟙 (𝟙_ C ⊗ 𝟙_ C) := by + have h := braiding_leftUnitor (C := C) (𝟙_ C) + rw [unitors_equal] at h + refine (cancel_mono (ρ_ (𝟙_ C)).hom).mp ?_ + rw [h, Category.id_comp] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/WhiskerAdditive.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/WhiskerAdditive.lean new file mode 100644 index 0000000000..814cc1706a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/WhiskerAdditive.lean @@ -0,0 +1,182 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Whiskering against negation, zero and binary biproducts + +Mathlib records that whiskering in a preadditive monoidal category +is additive (`MonoidalPreadditive.whiskerLeft_add`, +`MonoidalPreadditive.add_whiskerRight`) and that it kills the zero +morphism, but not the consequences the development uses everywhere: +whiskering commutes with negation, a tensor product with a zero +object is a zero object, and tensoring distributes over a binary +biproduct on either side. All hold in any preadditive monoidal +category, so they live here rather than in any of the files that +consume them. + +Mathlib's `Limits.Functor.mapBiprod` at `tensorLeft B` is the same +isomorphism, but its `PreservesBinaryBiproduct` hypothesis is not an +instance for `tensorLeft`, so the distributors are built here +directly. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {C : Type u} + +/-- Whiskering on the left commutes with negation. -/ +@[simp] +theorem whiskerLeft_neg [Category.{v} C] [MonoidalCategory C] [Preadditive C] + [MonoidalPreadditive C] + (X : C) {Y Z : C} (f : Y ⟶ Z) : + X ◁ (-f) = -(X ◁ f) := + (tensorLeft X).map_neg + +/-- Whiskering on the right commutes with negation. -/ +@[simp] +theorem neg_whiskerRight [Category.{v} C] [MonoidalCategory C] [Preadditive C] + [MonoidalPreadditive C] + {X Y : C} (f : X ⟶ Y) (Z : C) : + (-f) ▷ Z = -(f ▷ Z) := + (tensorRight Z).map_neg + +/-- Tensoring a zero object on the right with any object gives a +zero object. -/ +theorem isZero_whiskerRight + [Category.{v} C] [MonoidalCategory C] [Preadditive C] + [MonoidalPreadditive C] + {X : C} (h : IsZero X) (V : C) : + IsZero (X ⊗ V) := by + rw [IsZero.iff_id_eq_zero] at h ⊢ + rw [show 𝟙 (X ⊗ V) = 𝟙 X ▷ V from + (MonoidalCategory.id_whiskerRight X V).symm, h, + MonoidalPreadditive.zero_whiskerRight] + +/-- Tensoring any object with a zero object on the right gives a +zero object. -/ +theorem isZero_whiskerLeft [Category.{v} C] [MonoidalCategory C] [Preadditive C] + [MonoidalPreadditive C] + (V : C) {Y : C} (h : IsZero Y) : + IsZero (V ⊗ Y) := by + rw [IsZero.iff_id_eq_zero] at h ⊢ + rw [show 𝟙 (V ⊗ Y) = V ◁ 𝟙 Y from + (MonoidalCategory.whiskerLeft_id V Y).symm, h, + MonoidalPreadditive.whiskerLeft_zero] + +/-! ## Distributivity over a binary biproduct -/ + +section Distributors + +/-- **Tensoring on the left distributes over a binary +biproduct.** -/ +noncomputable def tensorBiprodIso + [Category.{v} C] [MonoidalCategory C] [Preadditive C] + [MonoidalPreadditive C] [Limits.HasBinaryBiproducts C] + (B X Y : C) : + B ⊗ (X ⊞ Y) ≅ (B ⊗ X) ⊞ (B ⊗ Y) where + hom := biprod.lift (B ◁ biprod.fst) (B ◁ biprod.snd) + inv := biprod.desc (B ◁ biprod.inl) (B ◁ biprod.inr) + hom_inv_id := by + rw [biprod.lift_desc, ← MonoidalCategory.whiskerLeft_comp, + ← MonoidalCategory.whiskerLeft_comp, + ← MonoidalPreadditive.whiskerLeft_add, biprod.total, + MonoidalCategory.whiskerLeft_id] + inv_hom_id := by + ext <;> simp [← MonoidalCategory.whiskerLeft_comp] + +/-- **Tensoring on the right distributes over a binary +biproduct.** -/ +noncomputable def biprodTensorIso + [Category.{v} C] [MonoidalCategory C] [Preadditive C] + [MonoidalPreadditive C] [Limits.HasBinaryBiproducts C] + (X Y B : C) : + (X ⊞ Y) ⊗ B ≅ (X ⊗ B) ⊞ (Y ⊗ B) where + hom := biprod.lift (biprod.fst ▷ B) (biprod.snd ▷ B) + inv := biprod.desc (biprod.inl ▷ B) (biprod.inr ▷ B) + hom_inv_id := by + rw [biprod.lift_desc, ← comp_whiskerRight, ← comp_whiskerRight, + ← MonoidalPreadditive.add_whiskerRight, biprod.total, + MonoidalCategory.id_whiskerRight] + inv_hom_id := by + ext <;> simp [← comp_whiskerRight] + +@[reassoc (attr := simp)] +theorem inl_tensorBiprodIso_hom + [Category.{v} C] [MonoidalCategory C] [Preadditive C] + [MonoidalPreadditive C] [Limits.HasBinaryBiproducts C] + (B X Y : C) : + (B ◁ biprod.inl) ≫ (tensorBiprodIso B X Y).hom = biprod.inl := by + ext <;> simp [tensorBiprodIso, ← MonoidalCategory.whiskerLeft_comp] + +@[reassoc (attr := simp)] +theorem inr_tensorBiprodIso_hom + [Category.{v} C] [MonoidalCategory C] [Preadditive C] + [MonoidalPreadditive C] [Limits.HasBinaryBiproducts C] + (B X Y : C) : + (B ◁ biprod.inr) ≫ (tensorBiprodIso B X Y).hom = biprod.inr := by + ext <;> simp [tensorBiprodIso, ← MonoidalCategory.whiskerLeft_comp] + +@[reassoc (attr := simp)] +theorem inl_tensorBiprodIso_inv + [Category.{v} C] [MonoidalCategory C] [Preadditive C] + [MonoidalPreadditive C] [Limits.HasBinaryBiproducts C] + (B X Y : C) : + biprod.inl ≫ (tensorBiprodIso B X Y).inv = B ◁ biprod.inl := by + simp [tensorBiprodIso] + +@[reassoc (attr := simp)] +theorem inr_tensorBiprodIso_inv + [Category.{v} C] [MonoidalCategory C] [Preadditive C] + [MonoidalPreadditive C] [Limits.HasBinaryBiproducts C] + (B X Y : C) : + biprod.inr ≫ (tensorBiprodIso B X Y).inv = B ◁ biprod.inr := by + simp [tensorBiprodIso] + +@[reassoc (attr := simp)] +theorem inl_biprodTensorIso_hom + [Category.{v} C] [MonoidalCategory C] [Preadditive C] + [MonoidalPreadditive C] [Limits.HasBinaryBiproducts C] + (X Y B : C) : + (biprod.inl ▷ B) ≫ (biprodTensorIso X Y B).hom = biprod.inl := by + ext <;> simp [biprodTensorIso, ← comp_whiskerRight] + +@[reassoc (attr := simp)] +theorem inr_biprodTensorIso_hom + [Category.{v} C] [MonoidalCategory C] [Preadditive C] + [MonoidalPreadditive C] [Limits.HasBinaryBiproducts C] + (X Y B : C) : + (biprod.inr ▷ B) ≫ (biprodTensorIso X Y B).hom = biprod.inr := by + ext <;> simp [biprodTensorIso, ← comp_whiskerRight] + +@[reassoc (attr := simp)] +theorem inl_biprodTensorIso_inv + [Category.{v} C] [MonoidalCategory C] [Preadditive C] + [MonoidalPreadditive C] [Limits.HasBinaryBiproducts C] + (X Y B : C) : + biprod.inl ≫ (biprodTensorIso X Y B).inv = biprod.inl ▷ B := by + simp [biprodTensorIso] + +@[reassoc (attr := simp)] +theorem inr_biprodTensorIso_inv + [Category.{v} C] [MonoidalCategory C] [Preadditive C] + [MonoidalPreadditive C] [Limits.HasBinaryBiproducts C] + (X Y B : C) : + biprod.inr ≫ (biprodTensorIso X Y B).inv = biprod.inr ▷ B := by + simp [biprodTensorIso] + +end Distributors + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne.lean new file mode 100644 index 0000000000..067a716be8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne.lean @@ -0,0 +1,343 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPowAct +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeAdjoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeCoherence +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeFree +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeLinear +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTransport +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeZigzag +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensorUnit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodTransfer +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BlockUnits +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BraidCoherence +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainB +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGr +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGraded +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGradedLaws +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBInd +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBNonzero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBofA +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBridge +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainDelta +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.Base +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.FirstSlot +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.SecondSlot +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMul +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulHet +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulLaws +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainNonzero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainShift +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainStage2 +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainUnit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CharSplit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CommonAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoprodPreserve +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescent +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescentClose +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableNullstellensatz +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoverFactor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CycleSplit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DayCalculus +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DayType +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DeligneAssembly +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DescentClose +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DevissageBound +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledAbelian +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledGrowth +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledLine +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledScalar +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledSmall +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledSplit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Doubling +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DualityMate +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.EvenEmbedMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ExactFromShort +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FactorialBeats +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreAdditive +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreBridge +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreEps +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreExact +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreFaithful +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreFunctor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMix +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMu +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreLinear +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMuNat +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverComplex +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverSplitting +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreRestrict +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreStrong +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FiltNil +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FlatLimit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeCollapseAlg +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeMixRetract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModAdjoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModFunctor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffleCoh +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeSummand +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormalise +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormaliseBase +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormaliseStep +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowDesc +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowInsert +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeSlide +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeTwistPi +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaCountable +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaComplex +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModule +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModuleFunctor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPair +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairAdd +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairFreeFree +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairFreeMix +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairNat +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetractRight +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairUnit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaShift +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaTwistLeft +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GeneratorAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GrowthDichotomy +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.HomFinite +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.HookMult +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.HookZero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IdemCut +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IdempotentLength +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ImageSubalgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndAllColim +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndBigTensorUnit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCoeq +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCompact +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndDayClosure +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndImage +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndKill +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndLocallyMixed +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfLinear +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndPointTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchur +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchurKilled +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSimple +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplitSection +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndTensorExact +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndUnitNonzero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitState +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.InterchangeAct +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KernelPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaClose +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaData +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KillerNonempty +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KronKill +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.LambdaCoend +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixDegenerate +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffle +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffleLine +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixSumPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixWhisker +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixWhiskerAll +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedConc +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedDiag +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedTransport +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAssoc +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAbelian +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModContractL +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModCross +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModDual +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModIns +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMulti +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMultiTriple +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowCast +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowDescent +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowDescentClose +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowStage +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchur +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchurSummand +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModZero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MulBy +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MuInterchange +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.NatChain +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.NewtonConv +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.NullPoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLineMap +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLinePairing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddParity +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddPermSign +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddSquare +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddSquareIso +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairCarrier +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairMul +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairPerm +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermNat +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermRepChar +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PlainShuffle +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointBaseChange +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointFibre +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Calculus +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Coherence +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Comparison +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Functor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Residue +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowAct +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowActMul +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowChain +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowCopairing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowInduct +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowMerge +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairSucc +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSucc +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSuccMod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowTriangle +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZig +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZigzag +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PresentedQuotient +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21 +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21Core +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21General +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29Close +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29State +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210 +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Bridge +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Chain +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Close +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Ind +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Reduce +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.RegularSum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.RhoBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.RhoTwist +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.RowColIdem +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichMerge +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichRetract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichZig +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarBraiding +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitEquiv +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitInd +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurTransport +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SeedIns +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ShapeAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ShapeFintype +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SignConj +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleGenerator +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SmallReduction +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleQuotient +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleSplit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimplePoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleScalars +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAdjoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitClosure +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitEverything +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAssemble +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitComplement +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExact +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtractDual +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitMonHom +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitPairDef +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitReduce +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitTransport +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplittingAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.StateTransport +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepA +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepATransport +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepB +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Letters +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Signs +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Standard +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEvenRing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperGamma +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperGammaInst +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModAbelian +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprodMap +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModIso +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShift +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShiftUnit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperPointMod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperRealize +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSeries +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSmall +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperValues +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperVectSchur +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymAlg +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymMul +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorExact +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorPowZero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorTransfer +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorZigzag +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TrichotomyClose +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistCoherence +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistFreeTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistMixLine +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistShuffle +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistState +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistSymPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistUnitor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitBase +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitFreeMod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitMod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitSimple +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitStage +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UniversalAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.WhiskerFaithful +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.WordMap +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZagAction +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagCarrier +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagNonzero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagSandwich +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransfer +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransferIso + +/-! +# The Deligne development: aggregator + +This module imports every file of the `RS.Classical.Deligne` +development, so that a single import brings the whole of the +Deligne-theorem work into scope. It declares nothing of its own. +-/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/AltPow.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/AltPow.lean new file mode 100644 index 0000000000..5cec8142f8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/AltPow.lean @@ -0,0 +1,262 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymAlg + +/-! +# Alternating powers over an internal monoid + +The antisymmetric counterpart of the symmetric-power interface of +`SymAlg.lean`: the sign-character central idempotent of the group +algebra `ℂ[Sₙ]` — the antisymmetriser — and the alternating power +of a module over an internal monoid, presented as the coequalizer +of the antisymmetriser's action on the module power against the +identity. + +* `antisymmetriser n`: the sign-character central idempotent + `(1/n!) • ∑ σ, sign σ • σ` of the group algebra, with signed + absorption and idempotency. +* `altPow A X n`: the alternating power, presented as the + coequalizer of `modPowAlg (antisymmetriser n)` against the + identity — which the idempotent splits into a direct summand: + `altPowσ ≫ altPowπ = 𝟙` and `altPowπ ≫ altPowσ` is the + antisymmetriser's action. Morphisms out of the alternating power + descend along `altPowπ`; morphisms in arrive through the section + `altPowσ`. + +The `A`-module structure on the alternating power is outside this +module's scope, exactly as its symmetric counterpart lives in +`PowAct.lean` rather than in `SymAlg.lean`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## The antisymmetriser + +The sign-character central idempotent of the group algebra +`ℂ[Sₙ]` — the `charIdempotent 1 sign` of the Schur interface, +written directly. +-/ + +section Antisymmetriser + +/-- **The antisymmetriser** `(1/n!) • ∑ σ, sign σ • σ` of the +symmetric-group algebra. -/ +noncomputable def antisymmetriser (n : ℕ) : SymGroupAlgebra n := + ((n.factorial : ℂ))⁻¹ • + ∑ σ : Equiv.Perm (Fin n), + MonoidAlgebra.single σ ((Equiv.Perm.sign σ : ℤ) : ℂ) + +/-- The square of a sign, cast to `ℂ`, is one. -/ +theorem sign_coe_mul_self {n : ℕ} (σ : Equiv.Perm (Fin n)) : + ((Equiv.Perm.sign σ : ℤ) : ℂ) * ((Equiv.Perm.sign σ : ℤ) : ℂ) = + 1 := by + rw [← Int.cast_mul, ← Units.val_mul, Int.units_mul_self, + Units.val_one, Int.cast_one] + +/-- The antisymmetriser absorbs every group element on the right, +up to its sign. -/ +@[simp] +theorem antisymmetriser_mul_single (n : ℕ) (τ : Equiv.Perm (Fin n)) : + antisymmetriser n * MonoidAlgebra.single τ (1 : ℂ) = + ((Equiv.Perm.sign τ : ℤ) : ℂ) • antisymmetriser n := by + unfold antisymmetriser + rw [smul_mul_assoc, Finset.sum_mul, + smul_comm ((Equiv.Perm.sign τ : ℤ) : ℂ)] + congr 1 + rw [Finset.smul_sum] + refine Fintype.sum_equiv (Equiv.mulRight τ) _ _ fun σ => ?_ + simp only [Equiv.coe_mulRight] + rw [MonoidAlgebra.single_mul_single, mul_one, + MonoidAlgebra.smul_single', Equiv.Perm.sign_mul, Units.val_mul, + Int.cast_mul, mul_comm ((Equiv.Perm.sign σ : ℤ) : ℂ), + ← mul_assoc, sign_coe_mul_self, one_mul] + +/-- The antisymmetriser absorbs every group element on the left, +up to its sign. -/ +@[simp] +theorem single_mul_antisymmetriser (n : ℕ) (τ : Equiv.Perm (Fin n)) : + MonoidAlgebra.single τ (1 : ℂ) * antisymmetriser n = + ((Equiv.Perm.sign τ : ℤ) : ℂ) • antisymmetriser n := by + unfold antisymmetriser + rw [mul_smul_comm, smul_comm ((Equiv.Perm.sign τ : ℤ) : ℂ)] + congr 1 + rw [Finset.mul_sum, Finset.smul_sum] + refine Fintype.sum_equiv (Equiv.mulLeft τ) _ _ fun σ => ?_ + simp only [Equiv.coe_mulLeft] + rw [MonoidAlgebra.single_mul_single, one_mul, + MonoidAlgebra.smul_single', Equiv.Perm.sign_mul, Units.val_mul, + Int.cast_mul, ← mul_assoc, sign_coe_mul_self, one_mul] + +/-- The antisymmetriser absorbs a sign-weighted group element on +the right, exactly. -/ +theorem antisymmetriser_mul_sign_single (n : ℕ) + (τ : Equiv.Perm (Fin n)) : + antisymmetriser n * + MonoidAlgebra.single τ ((Equiv.Perm.sign τ : ℤ) : ℂ) = + antisymmetriser n := by + have h : MonoidAlgebra.single τ ((Equiv.Perm.sign τ : ℤ) : ℂ) = + ((Equiv.Perm.sign τ : ℤ) : ℂ) • + MonoidAlgebra.single τ (1 : ℂ) := by + rw [MonoidAlgebra.smul_single', mul_one] + rw [h, mul_smul_comm, antisymmetriser_mul_single, smul_smul, + sign_coe_mul_self, one_smul] + +/-- **The antisymmetriser is idempotent.** -/ +theorem antisymmetriser_idem (n : ℕ) : + antisymmetriser n * antisymmetriser n = antisymmetriser n := by + nth_rewrite 2 [antisymmetriser] + rw [mul_smul_comm, Finset.mul_sum] + simp only [antisymmetriser_mul_sign_single, Finset.sum_const, + Finset.card_univ] + rw [Fintype.card_perm, Fintype.card_fin, + ← Nat.cast_smul_eq_nsmul ℂ, smul_smul, inv_mul_cancel₀ (by + exact_mod_cast n.factorial_ne_zero), one_smul] + +end Antisymmetriser + +/-! ## The alternating power -/ + +section AltPow + +/-- The antisymmetriser acting on the module power. -/ +noncomputable def altPowIdem + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) : modPow A X n ⟶ modPow A X n := + modPowAlg A X n (antisymmetriser n) + +/-- The antisymmetriser's action is idempotent. -/ +theorem altPowIdem_idem + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) : + altPowIdem A X n ≫ altPowIdem A X n = altPowIdem A X n := by + have h := congrArg (modPowAlg A X n) (antisymmetriser_idem n) + rw [map_mul] at h + exact h + +/-- **The alternating power**: the coinvariants of the +antisymmetriser's action — the coequalizer of the action against +the identity. The idempotency splits it off as a direct summand of +the module power, with section `altPowσ`; this presentation is +chosen because consumers build morphisms out of the alternating +power by descent along `altPowπ` and morphisms into it through the +section. -/ +noncomputable def altPow + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) : D := + coequalizer (altPowIdem A X n) (𝟙 (modPow A X n)) + +/-- The projection onto the alternating power. -/ +noncomputable def altPowπ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) : modPow A X n ⟶ altPow A X n := + coequalizer.π _ _ + +instance [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) : Epi (altPowπ A X n) := + inferInstanceAs (Epi (coequalizer.π _ _)) + +/-- The antisymmetriser is absorbed by the projection. -/ +@[reassoc (attr := simp)] +theorem altPowIdem_π + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) : + altPowIdem A X n ≫ altPowπ A X n = altPowπ A X n := by + have h := coequalizer.condition (altPowIdem A X n) + (𝟙 (modPow A X n)) + rwa [Category.id_comp] at h + +/-- The section of the alternating power, from idempotency. -/ +noncomputable def altPowσ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) : altPow A X n ⟶ modPow A X n := + coequalizer.desc (altPowIdem A X n) + (by rw [Category.id_comp, altPowIdem_idem]) + +/-- The section realises the antisymmetriser as projection followed +by inclusion. -/ +@[reassoc (attr := simp)] +theorem altPowπ_altPowσ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) : + altPowπ A X n ≫ altPowσ A X n = altPowIdem A X n := + coequalizer.π_desc _ _ + +/-- Morphisms out of the alternating power are determined by their +composite with the projection. -/ +theorem altPow_hom_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + {n : ℕ} {W : D} {k l : altPow A X n ⟶ W} + (h : altPowπ A X n ≫ k = altPowπ A X n ≫ l) : k = l := + coequalizer.hom_ext h + +/-- **The alternating power is a direct summand**: the section +followed by the projection is the identity. -/ +@[reassoc (attr := simp)] +theorem altPowσ_altPowπ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) : + altPowσ A X n ≫ altPowπ A X n = 𝟙 (altPow A X n) := by + apply altPow_hom_ext A X + rw [← Category.assoc, altPowπ_altPowσ, altPowIdem_π, + Category.comp_id] + +/-- Descend a morphism absorbed by the antisymmetriser to the +alternating power. -/ +noncomputable def altPowDesc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + {n : ℕ} {W : D} (k : modPow A X n ⟶ W) + (h : altPowIdem A X n ≫ k = k) : altPow A X n ⟶ W := + coequalizer.desc k (by rw [Category.id_comp, h]) + +/-- The descent factors the given morphism through the +projection. -/ +@[reassoc (attr := simp)] +theorem altPowπ_desc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + {n : ℕ} {W : D} (k : modPow A X n ⟶ W) + (h : altPowIdem A X n ≫ k = k) : + altPowπ A X n ≫ altPowDesc A X k h = k := + coequalizer.π_desc _ _ + +end AltPow + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/AltPowAct.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/AltPowAct.lean new file mode 100644 index 0000000000..c80aff19eb --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/AltPowAct.lean @@ -0,0 +1,185 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowAct + +/-! +# The monoid action on alternating powers + +The antisymmetric counterpart of the symmetric-power module +structure of `PowAct.lean`: over an internal commutative monoid `A` +and a left module `X` in a symmetric monoidal category, the +descended action on the module power commutes with the +antisymmetriser's action — the antisymmetriser is a `ℂ`-linear +combination of permutations, each of which the action passes — so +the action descends through the splitting of `AltPow.lean`, making +every positive alternating power a module. + +* `altPow_whiskerLeft_hom_ext`: morphisms out of a left-whiskered + alternating power are determined by the whiskered projection, + which is split epi. +* `modPowAct_altPowIdem`: the descended action commutes with the + antisymmetriser's action. +* `altPowAct`/`altPowModObj`: the action on the alternating power, + with `altPowσ` a module map. +* `altPowMod`: the bundled module. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## Whiskered extensionality for the alternating power -/ + +section AltWhisker + +/-- Morphisms out of a left-whiskered alternating power are +determined by the whiskered projection, which is split epi. -/ +theorem altPow_whiskerLeft_hom_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (P : D) (n : ℕ) {Z : D} + {k l : P ⊗ altPow A X n ⟶ Z} + (h : (P ◁ altPowπ A X n) ≫ k = (P ◁ altPowπ A X n) ≫ l) : + k = l := by + have hsec : (P ◁ altPowσ A X n) ≫ (P ◁ altPowπ A X n) = 𝟙 _ := by + rw [← MonoidalCategory.whiskerLeft_comp, altPowσ_altPowπ, + MonoidalCategory.whiskerLeft_id] + calc k = ((P ◁ altPowσ A X n) ≫ (P ◁ altPowπ A X n)) ≫ k := by + rw [hsec, Category.id_comp] + _ = ((P ◁ altPowσ A X n) ≫ (P ◁ altPowπ A X n)) ≫ l := by + rw [Category.assoc, Category.assoc, h] + _ = l := by rw [hsec, Category.id_comp] + +end AltWhisker + +/-! ## The alternating power as a module -/ + +section AltAct + +/-- **The descended action commutes with the antisymmetriser's +action**: the antisymmetriser is a `ℂ`-linear combination of +permutations, each of which the action passes. -/ +theorem modPowAct_altPowIdem + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + modPowAct A X n ≫ altPowIdem A X (n + 1) = + (A ◁ altPowIdem A X (n + 1)) ≫ modPowAct A X n := + modPowAct_alg A X n (antisymmetriser (n + 1)) + +/-- **The monoid action on the alternating power**, through the +section and the descended action. -/ +noncomputable def altPowAct + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + A ⊗ altPow A X (n + 1) ⟶ altPow A X (n + 1) := + (A ◁ altPowσ A X (n + 1)) ≫ modPowAct A X n ≫ + altPowπ A X (n + 1) + +/-- Defining equation of the alternating-power action. -/ +@[reassoc (attr := simp)] +theorem whiskerLeft_altPowπ_altPowAct + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + (A ◁ altPowπ A X (n + 1)) ≫ altPowAct A X n = + modPowAct A X n ≫ altPowπ A X (n + 1) := by + rw [altPowAct, ← whiskerLeft_comp_assoc, altPowπ_altPowσ, + reassoc_of% (modPowAct_altPowIdem A X n).symm, altPowIdem_π] + +/-- Unitality of the alternating-power action. -/ +theorem altPowAct_one + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + η[A] ▷ altPow A X (n + 1) ≫ altPowAct A X n = + (λ_ (altPow A X (n + 1))).hom := by + apply altPow_whiskerLeft_hom_ext A X (𝟙_ D) (n + 1) + rw [whisker_exchange_assoc, whiskerLeft_altPowπ_altPowAct, + reassoc_of% (modPowAct_one A X n), leftUnitor_naturality] + +/-- Associativity of the alternating-power action. -/ +theorem altPowAct_mul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + μ[A] ▷ altPow A X (n + 1) ≫ altPowAct A X n = + (α_ A A (altPow A X (n + 1))).hom ≫ + (A ◁ altPowAct A X n) ≫ altPowAct A X n := by + apply altPow_whiskerLeft_hom_ext A X (A ⊗ A) (n + 1) + conv_lhs => rw [whisker_exchange_assoc, + whiskerLeft_altPowπ_altPowAct, + reassoc_of% (modPowAct_mul A X n)] + conv_rhs => rw [associator_naturality_right_assoc, + ← whiskerLeft_comp_assoc, whiskerLeft_altPowπ_altPowAct, + whiskerLeft_comp_assoc, whiskerLeft_altPowπ_altPowAct] + +/-- **The alternating power of a module is a module**, in every +positive arity. -/ +@[implicit_reducible] +noncomputable def altPowModObj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + ModObj A (altPow A X (n + 1)) where + smul := altPowAct A X n + one_smul := altPowAct_one A X n + mul_smul := altPowAct_mul A X n + +/-- The alternating power of a module, bundled as a module. -/ +noncomputable def altPowMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : Mod D A := + letI := altPowModObj A X n + ⟨altPow A X (n + 1)⟩ + +@[simp] theorem altPowMod_X + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + (altPowMod A X n).X = altPow A X (n + 1) := rfl + +end AltAct + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeAdjoint.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeAdjoint.lean new file mode 100644 index 0000000000..3545261194 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeAdjoint.lean @@ -0,0 +1,820 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTransport +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtractDual + +/-! +# The base-changed pairing on its cover + +The pairing of a base-changed duality datum, evaluated on the +double cover of the relative tensor over the new base: it +multiplies the two base factors and applies the pairing through +the base morphism. This is the working form for the adjointness +of the split idempotents. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The base-changed pairing on the cover**: it multiplies the +two base factors and applies the pairing through the base +morphism. -/ +theorem baseChangePair_cover + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + (modTensorπ A (restrictRegular φ) M' ▷ (B ⊗ M.X)) ≫ + ((baseChangeMod φ M').X ◁ + modTensorπ A (restrictRegular φ) M) ≫ + modTensorπ B (baseChangeMod φ M') (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair = + tensorμ B M'.X B M.X ≫ (μ[B] ▷ (M'.X ⊗ M.X)) ≫ + (B ◁ (modTensorπ A M' M ≫ d.pair ≫ φ)) ≫ μ[B] := by + have hpair : (baseChangeDatum A B φ d).pair = + (projFormula A B φ M' M).hom ≫ + modTensorMap A (𝟙 (restrictRegular φ)) + (d.pairMod) ≫ + (modTensorUnitRight A (restrictRegular φ)).hom := rfl + have htail : modTensorπ A (restrictRegular φ) + (modTensorMod A M' M) ≫ + modTensorMap A (𝟙 (restrictRegular φ)) (d.pairMod) ≫ + (modTensorUnitRight A (restrictRegular φ)).hom = + (B ◁ (d.pair ≫ φ)) ≫ μ[B] := by + rw [modTensorπ_map_assoc, Mod.id_hom', + MonoidalCategory.id_tensorHom, + show (d.pairMod).hom = d.pair from rfl, + modTensorUnitRight_hom, modTensorπ_desc, + actRight_restrictRegular, + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rfl + rw [hpair] + have hcover := congrArg (fun t => t ≫ + modTensorMap A (𝟙 (restrictRegular φ)) d.pairMod ≫ + (modTensorUnitRight A (restrictRegular φ)).hom) + (projFormula_tensorμ_cover A B φ M' M) + conv at hcover => + lhs + erw [Category.assoc] + arg 2 + erw [Category.assoc] + arg 2 + erw [Category.assoc] + refine Eq.trans hcover ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (Category.assoc _ _ _))) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (whisker_eq _ htail))) ?_ + refine whisker_eq _ (whisker_eq _ ?_) + rw [← MonoidalCategory.whiskerLeft_comp_assoc] + +/-- The interchange followed by braiding the base factor to the +right is a reassociation of the braiding. -/ +theorem tensorμ_braid + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (X Y Z W : D) : + tensorμ X Y Z W ≫ (α_ X Z (Y ⊗ W)).hom ≫ + (X ◁ (β_ Z (Y ⊗ W)).hom) = + ((X ⊗ Y) ◁ (β_ Z W).hom) ≫ (α_ (X ⊗ Y) W Z).inv ≫ + ((α_ X Y W).hom ▷ Z) ≫ (α_ X (Y ⊗ W) Z).hom := by + have hin : (α_ Y Z W).inv ≫ ((β_ Y Z).hom ▷ W) ≫ + (α_ Z Y W).hom ≫ (β_ Z (Y ⊗ W)).hom = + (Y ◁ (β_ Z W).hom) ≫ (α_ Y W Z).inv := by + rw [BraidedCategory.braiding_tensor_right_hom Z Y W] + simp only [Iso.hom_inv_id_assoc] + rw [← MonoidalCategory.comp_whiskerRight_assoc, + SymmetricCategory.symmetry, + MonoidalCategory.id_whiskerRight, Category.id_comp, + Iso.inv_hom_id_assoc] + rw [tensorμ] + simp only [Category.assoc, Iso.inv_hom_id_assoc] + simp only [← MonoidalCategory.whiskerLeft_comp] + rw [hin] + simp only [MonoidalCategory.whiskerLeft_comp] + monoidal + +/-- Multiplying two scalars is symmetric. -/ +theorem mulSwap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (B : D) + [MonObj B] [IsCommMonObj B] + {U V : D} (f : U ⟶ B) (g : V ⟶ B) : + (f ⊗ₘ g) ≫ μ[B] = + (β_ U V).hom ≫ (g ⊗ₘ f) ≫ μ[B] := by + rw [← Category.assoc, + ← BraidedCategory.braiding_naturality, Category.assoc, + IsCommMonObj.mul_comm] + +/-- Reassociating a product with a base factor on the left. -/ +theorem mulLeftAssoc [Category.{v} D] [MonoidalCategory D] (B : D) [MonObj B] + {U V : D} (f : U ⟶ B) (g : V ⟶ B) : + ((((B ◁ f) ≫ μ[B]) ⊗ₘ g) ≫ μ[B]) = + (α_ B U V).hom ≫ (B ◁ ((f ⊗ₘ g) ≫ μ[B])) ≫ μ[B] := by + rw [show (((B ◁ f) ≫ μ[B]) ⊗ₘ g) = + ((B ◁ f) ⊗ₘ g) ≫ (μ[B] ⊗ₘ 𝟙 B) from by + rw [tensorHom_comp_tensorHom, Category.comp_id]] + rw [Category.assoc, MonoidalCategory.tensorHom_id μ[B] B, + MonObj.mul_assoc, ← Category.assoc, + ← MonoidalCategory.id_tensorHom B f, + associator_naturality, Category.assoc] + refine whisker_eq _ ?_ + rw [MonoidalCategory.id_tensorHom, + ← MonoidalCategory.whiskerLeft_comp_assoc] + +/-- The interchange, followed by reassociation, is the +braiding of the outer block. -/ +theorem tensorμ_shuffle + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (W X Y : D) : + ((W ⊗ Y) ◁ (β_ X Y).hom) ≫ tensorμ W Y Y X ≫ + (α_ W Y (Y ⊗ X)).hom = + (α_ W Y (X ⊗ Y)).hom ≫ + (W ◁ ((α_ Y X Y).inv ≫ (β_ (Y ⊗ X) Y).hom)) := by + have hin : (α_ Y X Y).inv ≫ (β_ (Y ⊗ X) Y).hom = + (Y ◁ (β_ X Y).hom) ≫ (α_ Y Y X).inv ≫ + ((β_ Y Y).hom ▷ X) ≫ (α_ Y Y X).hom := by + rw [BraidedCategory.braiding_tensor_left_hom Y X Y, + Iso.inv_hom_id_assoc] + rw [hin, tensorμ] + simp only [Category.assoc] + simp only [Iso.inv_hom_id, Category.comp_id] + rw [associator_naturality_right_assoc] + simp only [← MonoidalCategory.whiskerLeft_comp] + +/-- Sliding a base factor across a product of two scalars. -/ +theorem mulSlide + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (B : D) + [MonObj B] [IsCommMonObj B] + {U V : D} (f : U ⟶ B) (g : V ⟶ B) : + ((((f ▷ B) ≫ μ[B]) ⊗ₘ g) ≫ μ[B]) = + (α_ U B V).hom ≫ (U ◁ (β_ B V).hom) ≫ + (f ⊗ₘ ((g ▷ B) ≫ μ[B])) ≫ μ[B] := by + have hbg : (B ◁ g) ≫ μ[B] = + (β_ B V).hom ≫ (g ⊗ₘ 𝟙 B) ≫ μ[B] := by + rw [MonoidalCategory.tensorHom_id, + ← BraidedCategory.braiding_naturality_right_assoc, + IsCommMonObj.mul_comm] + rw [← MonoidalCategory.tensorHom_id f B, + ← MonoidalCategory.tensorHom_id g B] + rw [show (((f ⊗ₘ 𝟙 B) ≫ μ[B]) ⊗ₘ g) = + ((f ⊗ₘ 𝟙 B) ⊗ₘ g) ≫ (μ[B] ⊗ₘ 𝟙 B) from by + rw [tensorHom_comp_tensorHom, Category.comp_id]] + rw [Category.assoc, MonoidalCategory.tensorHom_id μ[B] B, + MonObj.mul_assoc, ← Category.assoc, + associator_naturality, Category.assoc] + refine whisker_eq _ ?_ + rw [← Category.assoc, + ← MonoidalCategory.id_tensorHom B μ[B], + tensorHom_comp_tensorHom, + Category.comp_id, MonoidalCategory.id_tensorHom, hbg] + rw [show (f ⊗ₘ ((β_ B V).hom ≫ (g ⊗ₘ 𝟙 B) ≫ μ[B])) = + (𝟙 U ⊗ₘ (β_ B V).hom) ≫ + (f ⊗ₘ ((g ⊗ₘ 𝟙 B) ≫ μ[B])) from by + rw [tensorHom_comp_tensorHom, Category.id_comp]] + rw [MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_id] + simp only [Category.assoc] + +section Adjoint + +/-- A base-linear insertion intertwines the braided right action +with multiplication through the base morphism. -/ +theorem actRight_ins + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) {M : Mod D A} + (v : M.X ⟶ B) + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) : + actRight A M.X ≫ v = (v ▷ A) ≫ (B ◁ φ) ≫ μ[B] := by + change ((β_ M.X A).hom ≫ actLeft A M.X) ≫ v = _ + rw [Category.assoc, hv, + ← BraidedCategory.braiding_naturality_left_assoc, + ← BraidedCategory.braiding_naturality_right_assoc, + IsCommMonObj.mul_comm] + +/-- **The dual coevaluation core against the base-changed +pairing**: the pairing sees the inserted primal factor through +the zig contraction. -/ +theorem splitCoevalCoreDual_cover + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} (v : M.X ⟶ B) + (d : ModDualityDatum A M M') + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) : + (splitCoevalCoreDual A B φ v hv ▷ (B ⊗ M.X)) ≫ + ((baseChangeMod φ M').X ◁ + modTensorπ A (restrictRegular φ) M) ≫ + modTensorπ B (baseChangeMod φ M') (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair = + (modTensor A M M' ◁ (β_ B M.X).hom) ≫ + (α_ (modTensor A M M') M.X B).inv ≫ + ((zigContract A d.pair d.pair_linear ≫ v) ▷ B) ≫ + μ[B] := by + apply modTensor_whiskerR_hom_ext A M M' (B ⊗ M.X) + have hL : (modTensorπ A M M' ▷ (B ⊗ M.X)) ≫ + (splitCoevalCoreDual A B φ v hv ▷ (B ⊗ M.X)) ≫ + ((baseChangeMod φ M').X ◁ + modTensorπ A (restrictRegular φ) M) ≫ + modTensorπ B (baseChangeMod φ M') (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair = + ((v ▷ M'.X) ▷ (B ⊗ M.X)) ≫ tensorμ B M'.X B M.X ≫ + (μ[B] ▷ (M'.X ⊗ M.X)) ≫ + (B ◁ (modTensorπ A M' M ≫ d.pair ≫ φ)) ≫ μ[B] := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.comp_whiskerRight _ _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg + (fun t => t ▷ (B ⊗ M.X)) + (modTensorπ_splitCoevalCoreDual A B φ v hv)) _) ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.comp_whiskerRight _ _ _) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (baseChangePair_cover A B φ d) + have hR : (modTensorπ A M M' ▷ (B ⊗ M.X)) ≫ + (modTensor A M M' ◁ (β_ B M.X).hom) ≫ + (α_ (modTensor A M M') M.X B).inv ≫ + ((zigContract A d.pair d.pair_linear ≫ v) ▷ B) ≫ + μ[B] = + ((M.X ⊗ M'.X) ◁ (β_ B M.X).hom) ≫ + (α_ (M.X ⊗ M'.X) M.X B).inv ≫ + (((α_ M.X M'.X M.X).hom ≫ (v ▷ (M'.X ⊗ M.X)) ≫ + (B ◁ (modTensorπ A M' M ≫ d.pair ≫ φ)) ≫ μ[B]) ▷ + B) ≫ μ[B] := by + rw [← whisker_exchange_assoc, + associator_inv_naturality_left_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, + ← Category.assoc (modTensorπ A M M' ▷ M.X), + whiskerRight_modTensorπ_zigContract] + refine congrArg (fun t => ((M.X ⊗ M'.X) ◁ + (β_ B M.X).hom) ≫ (α_ (M.X ⊗ M'.X) M.X B).inv ≫ + (t ▷ B) ≫ μ[B]) ?_ + rw [Category.assoc, Category.assoc, + actRight_ins A B φ v hv, ← whisker_exchange_assoc] + simp only [Category.assoc, + MonoidalCategory.whiskerLeft_comp] + refine whisker_eq _ ?_ + simp only [← MonoidalCategory.whiskerLeft_comp_assoc] + rw [whisker_exchange_assoc] + have hLform : ((v ▷ M'.X) ▷ (B ⊗ M.X)) ≫ + tensorμ B M'.X B M.X ≫ (μ[B] ▷ (M'.X ⊗ M.X)) ≫ + (B ◁ (modTensorπ A M' M ≫ d.pair ≫ φ)) ≫ μ[B] = + tensorμ M.X M'.X B M.X ≫ + (α_ M.X B (M'.X ⊗ M.X)).hom ≫ + (M.X ◁ (β_ B (M'.X ⊗ M.X)).hom) ≫ + (v ⊗ₘ (((modTensorπ A M' M ≫ d.pair ≫ φ) ▷ B) ≫ + μ[B])) ≫ μ[B] := by + rw [← MonoidalCategory.tensorHom_id v M'.X, + tensorμ_natural_left_assoc] + refine whisker_eq _ ?_ + rw [MonoidalCategory.id_whiskerRight, + MonoidalCategory.tensorHom_id (v ▷ B) (M'.X ⊗ M.X), + ← MonoidalCategory.comp_whiskerRight_assoc, + ← MonoidalCategory.tensorHom_def_assoc, + mulSlide B v (modTensorπ A M' M ≫ d.pair ≫ φ)] + have hRform : ((M.X ⊗ M'.X) ◁ (β_ B M.X).hom) ≫ + (α_ (M.X ⊗ M'.X) M.X B).inv ≫ + (((α_ M.X M'.X M.X).hom ≫ (v ▷ (M'.X ⊗ M.X)) ≫ + (B ◁ (modTensorπ A M' M ≫ d.pair ≫ φ)) ≫ μ[B]) ▷ + B) ≫ μ[B] = + (((M.X ⊗ M'.X) ◁ (β_ B M.X).hom) ≫ + (α_ (M.X ⊗ M'.X) M.X B).inv ≫ + ((α_ M.X M'.X M.X).hom ▷ B) ≫ + (α_ M.X (M'.X ⊗ M.X) B).hom) ≫ + (v ⊗ₘ (((modTensorπ A M' M ≫ d.pair ≫ φ) ▷ B) ≫ + μ[B])) ≫ μ[B] := by + rw [← MonoidalCategory.tensorHom_def_assoc] + rw [MonoidalCategory.comp_whiskerRight, + MonoidalCategory.comp_whiskerRight] + simp only [Category.assoc] + rw [MonObj.mul_assoc] + rw [← MonoidalCategory.tensorHom_id + (v ⊗ₘ (modTensorπ A M' M ≫ d.pair ≫ φ)) B, + ← MonoidalCategory.tensorHom_id + (modTensorπ A M' M ≫ d.pair ≫ φ) B, + ← Category.assoc + ((v ⊗ₘ (modTensorπ A M' M ≫ d.pair ≫ φ)) ⊗ₘ 𝟙 B), + associator_naturality] + simp only [Category.assoc] + rw [← MonoidalCategory.id_tensorHom B μ[B], + ← Category.assoc + (v ⊗ₘ (modTensorπ A M' M ≫ d.pair ≫ φ) ⊗ₘ 𝟙 B), + tensorHom_comp_tensorHom, Category.comp_id] + rw [hL, hR, hLform, hRform] + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + exact eq_whisker (tensorμ_braid M.X M'.X B M.X) _ + +/-- **The dual coevaluation point against the base-changed +pairing**: pairing the inserted point with a vector evaluates the +insertion on it. -/ +theorem splitCoevalDual_point_pair + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} (v : M.X ⟶ B) + (d : ModDualityDatum A M M') + (hz : ModZigzagDatum A d) + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) : + (λ_ (baseChangeMod φ M).X).inv ≫ + ((η[A] ≫ d.copair ≫ + splitCoevalCoreDual A B φ v hv) ▷ + (baseChangeMod φ M).X) ≫ + modTensorπ B (baseChangeMod φ M') (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair = + splitEval A B φ v hv := by + have hz1 : (η[A] ≫ d.copair ≫ + splitCoevalCoreDual A B φ v hv) ▷ + (baseChangeMod φ M).X = + ((η[A] ≫ d.copair) ▷ (baseChangeMod φ M).X) ≫ + (splitCoevalCoreDual A B φ v hv ▷ + (baseChangeMod φ M).X) := by + rw [← Category.assoc, MonoidalCategory.comp_whiskerRight] + have hpre : (λ_ (B ⊗ M.X)).inv ≫ + (𝟙_ D ◁ (β_ B M.X).hom) ≫ + (α_ (𝟙_ D) M.X B).inv = + (β_ B M.X).hom ≫ ((λ_ M.X).inv ▷ B) := by + rw [← leftUnitor_inv_naturality_assoc, + ← leftUnitor_inv_whiskerRight] + have hstep : modTensorπ A (restrictRegular φ) M ≫ + (λ_ (baseChangeMod φ M).X).inv ≫ + ((η[A] ≫ d.copair ≫ + splitCoevalCoreDual A B φ v hv) ▷ + (baseChangeMod φ M).X) ≫ + modTensorπ B (baseChangeMod φ M') (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair = + (β_ B M.X).hom ≫ (v ▷ B) ≫ μ[B] := by + have hclean : modTensorπ A (restrictRegular φ) M ≫ + (λ_ (modTensor A (restrictRegular φ) M)).inv ≫ + (((η[A] ≫ d.copair) ▷ + (modTensor A (restrictRegular φ) M)) ≫ + (splitCoevalCoreDual A B φ v hv ▷ + (modTensor A (restrictRegular φ) M))) ≫ + modTensorπ B (baseChangeMod φ M') + (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair = + (λ_ (B ⊗ M.X)).inv ≫ + ((η[A] ≫ d.copair) ▷ (B ⊗ M.X)) ≫ + (splitCoevalCoreDual A B φ v hv ▷ (B ⊗ M.X)) ≫ + ((baseChangeMod φ M').X ◁ + modTensorπ A (restrictRegular φ) M) ≫ + modTensorπ B (baseChangeMod φ M') + (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair := by + rw [leftUnitor_inv_naturality_assoc] + simp only [Category.assoc] + rw [whisker_exchange_assoc, whisker_exchange_assoc] + rfl + rw [hz1] + refine Eq.trans hclean ?_ + rw [splitCoevalCoreDual_cover A B φ v d hv] + rw [← whisker_exchange_assoc, + associator_inv_naturality_left_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc] + rw [reassoc_of% hpre] + rw [← MonoidalCategory.comp_whiskerRight_assoc, + zigzag_carrier_zig_assoc A hz] + apply modTensor_hom_ext + refine Eq.trans hstep ?_ + rw [modTensorπ_splitEval, + ← BraidedCategory.braiding_naturality_right_assoc, + IsCommMonObj.mul_comm] + +/-- The base-changed pairing is linear over the new base in its +outer variable. -/ +theorem baseChangePair_linear_outer + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + (baseChangeAct φ M' ▷ (baseChangeMod φ M).X) ≫ + modTensorπ B (baseChangeMod φ M') (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair = + (α_ B (baseChangeMod φ M').X + (baseChangeMod φ M).X).hom ≫ + (B ◁ (modTensorπ B (baseChangeMod φ M') + (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair)) ≫ μ[B] := by + let := modTensorModObj B (baseChangeMod φ M') + (baseChangeMod φ M) + have hact : (B ◁ modTensorπ B (baseChangeMod φ M') + (baseChangeMod φ M)) ≫ + actLeft B (modTensor B (baseChangeMod φ M') + (baseChangeMod φ M)) = + ((α_ B (baseChangeMod φ M').X + (baseChangeMod φ M).X).inv ≫ + (actLeft B (baseChangeMod φ M').X ▷ + (baseChangeMod φ M).X)) ≫ + modTensorπ B (baseChangeMod φ M') + (baseChangeMod φ M) := + whiskerLeft_modTensorπ_act B (baseChangeMod φ M') + (baseChangeMod φ M) + have hlin := (baseChangeDatum A B φ d).pair_linear + rw [MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rw [← hlin, ← Category.assoc + (B ◁ modTensorπ B (baseChangeMod φ M') + (baseChangeMod φ M)), + hact] + simp only [Category.assoc, Iso.hom_inv_id_assoc] + rfl + +/-- **The dual coevaluation against the base-changed pairing**: +pairing the dual coevaluation with a vector evaluates the +insertion on it. -/ +theorem splitCoevalDual_pair + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} (v : M.X ⟶ B) + (d : ModDualityDatum A M M') + (hz : ModZigzagDatum A d) + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) : + (splitCoevalDual A B φ v d hv ▷ + (baseChangeMod φ M).X) ≫ + modTensorπ B (baseChangeMod φ M') (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair = + (B ◁ splitEval A B φ v hv) ≫ μ[B] := by + have hcoh : ((ρ_ B).inv ▷ (baseChangeMod φ M).X) ≫ + (α_ B (𝟙_ D) (baseChangeMod φ M).X).hom = + B ◁ (λ_ (baseChangeMod φ M).X).inv := by monoidal + have hsplit : splitCoevalDual A B φ v d hv = + (ρ_ B).inv ≫ + (B ◁ (η[A] ≫ d.copair ≫ + splitCoevalCoreDual A B φ v hv)) ≫ + baseChangeAct φ M' := rfl + rw [hsplit] + rw [MonoidalCategory.comp_whiskerRight, + MonoidalCategory.comp_whiskerRight] + simp only [Category.assoc] + rw [baseChangePair_linear_outer A B φ d] + have hmid : ((B ◁ (η[A] ≫ d.copair ≫ + splitCoevalCoreDual A B φ v hv)) ▷ + (modTensor A (restrictRegular φ) M)) ≫ + (α_ B (modTensor A (restrictRegular φ) M') + (modTensor A (restrictRegular φ) M)).hom = + (α_ B (𝟙_ D) (modTensor A (restrictRegular φ) M)).hom ≫ + (B ◁ ((η[A] ≫ d.copair ≫ + splitCoevalCoreDual A B φ v hv) ▷ + (modTensor A (restrictRegular φ) M))) := + associator_naturality_middle _ _ _ + have hmid' := congrArg (fun t => t ≫ + (B ◁ (modTensorπ B (baseChangeMod φ M') (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair)) ≫ μ[B]) hmid + conv at hmid' => lhs; erw [Category.assoc] + refine Eq.trans (whisker_eq _ hmid') ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker hcoh _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (show + (B ◁ (λ_ (baseChangeMod φ M).X).inv) ≫ + (B ◁ ((η[A] ≫ d.copair ≫ + splitCoevalCoreDual A B φ v hv) ▷ + (baseChangeMod φ M).X)) ≫ + (B ◁ (modTensorπ B (baseChangeMod φ M') + (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair)) = + B ◁ ((λ_ (baseChangeMod φ M).X).inv ≫ + ((η[A] ≫ d.copair ≫ + splitCoevalCoreDual A B φ v hv) ▷ + (baseChangeMod φ M).X) ≫ + modTensorπ B (baseChangeMod φ M') + (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair) from by + simp only [← MonoidalCategory.whiskerLeft_comp]) _) ?_ + rw [splitCoevalDual_point_pair A B φ v d hz hv] + rfl + +/-- The shuffle identity behind the primal cover. -/ +theorem mulShuffle + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (B : D) + [MonObj B] [IsCommMonObj B] + (X Y : D) (w : Y ⟶ B) (p : Y ⊗ X ⟶ B) : + ((B ⊗ Y) ◁ ((β_ X Y).hom ≫ (w ▷ X))) ≫ + tensorμ B Y B X ≫ (μ[B] ▷ (Y ⊗ X)) ≫ + (B ◁ p) ≫ μ[B] = + (α_ B Y (X ⊗ Y)).hom ≫ + (B ◁ ((α_ Y X Y).inv ≫ (p ⊗ₘ w) ≫ μ[B])) ≫ + μ[B] := by + rw [mulSwap B p w] + rw [show (α_ Y X Y).inv ≫ (β_ (Y ⊗ X) Y).hom ≫ + (w ⊗ₘ p) ≫ μ[B] = + ((α_ Y X Y).inv ≫ (β_ (Y ⊗ X) Y).hom) ≫ + ((w ⊗ₘ p) ≫ μ[B]) from by + simp only [Category.assoc]] + rw [MonoidalCategory.whiskerLeft_comp] + rw [MonoidalCategory.whiskerLeft_comp, + ← MonoidalCategory.tensorHom_id w X] + simp only [Category.assoc] + rw [tensorμ_natural_right_assoc] + rw [MonoidalCategory.whiskerLeft_id, + MonoidalCategory.tensorHom_id] + rw [← MonoidalCategory.comp_whiskerRight_assoc, + ← MonoidalCategory.tensorHom_def_assoc, + mulLeftAssoc B w p] + rw [reassoc_of% (tensorμ_shuffle B X Y)] + +section Primal + +/-- **The coevaluation core against the base-changed pairing**: +the pairing sees the inserted dual factor through the zag +contraction. -/ +theorem splitCoevalCore_cover + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} (w : M'.X ⟶ B) + (d : ModDualityDatum A M M') + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + ((B ⊗ M'.X) ◁ splitCoevalCore A B φ w hw) ≫ + (modTensorπ A (restrictRegular φ) M' ▷ + (baseChangeMod φ M).X) ≫ + modTensorπ B (baseChangeMod φ M') (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair = + (α_ B M'.X (modTensor A M M')).hom ≫ + (B ◁ (zagContract A d.pair d.pair_linear ≫ w)) ≫ + μ[B] := by + apply modTensor_whisker_hom_ext A M M' (B ⊗ M'.X) + have hR : ((B ⊗ M'.X) ◁ modTensorπ A M M') ≫ + (α_ B M'.X (modTensor A M M')).hom ≫ + (B ◁ (zagContract A d.pair d.pair_linear ≫ w)) ≫ + μ[B] = + (α_ B M'.X (M.X ⊗ M'.X)).hom ≫ + (B ◁ ((α_ M'.X M.X M'.X).inv ≫ + ((modTensorπ A M' M ≫ d.pair) ▷ M'.X) ≫ + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B])) ≫ μ[B] := by + rw [associator_naturality_right_assoc] + refine whisker_eq _ ?_ + rw [← MonoidalCategory.whiskerLeft_comp_assoc] + refine eq_whisker (congrArg (fun t => B ◁ t) ?_) _ + rw [← Category.assoc, whiskerLeft_modTensorπ_zagContract] + simp only [Category.assoc, hw] + have hL : ((B ⊗ M'.X) ◁ modTensorπ A M M') ≫ + ((B ⊗ M'.X) ◁ splitCoevalCore A B φ w hw) ≫ + (modTensorπ A (restrictRegular φ) M' ▷ + (baseChangeMod φ M).X) ≫ + modTensorπ B (baseChangeMod φ M') (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair = + ((B ⊗ M'.X) ◁ ((β_ M.X M'.X).hom ≫ (w ▷ M.X))) ≫ + tensorμ B M'.X B M.X ≫ (μ[B] ▷ (M'.X ⊗ M.X)) ≫ + (B ◁ (modTensorπ A M' M ≫ d.pair ≫ φ)) ≫ μ[B] := by + rw [← MonoidalCategory.whiskerLeft_comp_assoc, + modTensorπ_splitCoevalCore] + refine Eq.trans (eq_whisker (show (B ⊗ M'.X) ◁ + ((β_ M.X M'.X).hom ≫ (w ▷ M.X) ≫ + modTensorπ A (restrictRegular φ) M) = + ((B ⊗ M'.X) ◁ ((β_ M.X M'.X).hom ≫ (w ▷ M.X))) ≫ + ((B ⊗ M'.X) ◁ + modTensorπ A (restrictRegular φ) M) from by + rw [← MonoidalCategory.whiskerLeft_comp, + Category.assoc]) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine whisker_eq _ ?_ + have hex : ((B ⊗ M'.X) ◁ + modTensorπ A (restrictRegular φ) M) ≫ + (modTensorπ A (restrictRegular φ) M' ▷ + (modTensor A (restrictRegular φ) M)) = + (modTensorπ A (restrictRegular φ) M' ▷ (B ⊗ M.X)) ≫ + ((modTensor A (restrictRegular φ) M') ◁ + modTensorπ A (restrictRegular φ) M) := + whisker_exchange _ _ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker hex _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact baseChangePair_cover A B φ d + rw [hL, hR] + rw [show ((modTensorπ A M' M ≫ d.pair) ▷ M'.X) ≫ + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B] = + ((modTensorπ A M' M ≫ d.pair ≫ φ) ⊗ₘ w) ≫ μ[B] from by + rw [← MonoidalCategory.tensorHom_def_assoc, + ← MonoidalCategory.tensorHom_id φ B, + ← Category.assoc, tensorHom_comp_tensorHom, + Category.comp_id, Category.assoc]] + exact mulShuffle B M.X M'.X w + (modTensorπ A M' M ≫ d.pair ≫ φ) + +/-- **The coevaluation point against the base-changed +pairing**. -/ +theorem splitCoeval_point_pair + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} (w : M'.X ⟶ B) + (d : ModDualityDatum A M M') + (hz : ModZigzagDatum A d) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + (ρ_ (baseChangeMod φ M').X).inv ≫ + ((baseChangeMod φ M').X ◁ (η[A] ≫ d.copair ≫ + splitCoevalCore A B φ w hw)) ≫ + modTensorπ B (baseChangeMod φ M') (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair = + splitEval A B φ w hw := by + have hz1 : ((baseChangeMod φ M').X ◁ (η[A] ≫ d.copair ≫ + splitCoevalCore A B φ w hw)) = + ((baseChangeMod φ M').X ◁ (η[A] ≫ d.copair)) ≫ + ((baseChangeMod φ M').X ◁ + splitCoevalCore A B φ w hw) := by + rw [← MonoidalCategory.whiskerLeft_comp, Category.assoc] + have hpre : (ρ_ (B ⊗ M'.X)).inv ≫ + (α_ B M'.X (𝟙_ D)).hom = + B ◁ (ρ_ M'.X).inv := by + rw [← whiskerLeft_rightUnitor_inv] + have hclean : modTensorπ A (restrictRegular φ) M' ≫ + (ρ_ (modTensor A (restrictRegular φ) M')).inv ≫ + (((modTensor A (restrictRegular φ) M') ◁ + (η[A] ≫ d.copair)) ≫ + ((modTensor A (restrictRegular φ) M') ◁ + splitCoevalCore A B φ w hw)) ≫ + modTensorπ B (baseChangeMod φ M') + (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair = + (ρ_ (B ⊗ M'.X)).inv ≫ + ((B ⊗ M'.X) ◁ (η[A] ≫ d.copair)) ≫ + ((B ⊗ M'.X) ◁ splitCoevalCore A B φ w hw) ≫ + (modTensorπ A (restrictRegular φ) M' ▷ + (baseChangeMod φ M).X) ≫ + modTensorπ B (baseChangeMod φ M') + (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair := by + rw [rightUnitor_inv_naturality_assoc] + simp only [Category.assoc] + rw [← whisker_exchange_assoc, ← whisker_exchange_assoc] + rfl + have hstep : modTensorπ A (restrictRegular φ) M' ≫ + (ρ_ (baseChangeMod φ M').X).inv ≫ + ((baseChangeMod φ M').X ◁ (η[A] ≫ d.copair ≫ + splitCoevalCore A B φ w hw)) ≫ + modTensorπ B (baseChangeMod φ M') + (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair = + (B ◁ w) ≫ μ[B] := by + rw [hz1] + refine Eq.trans hclean ?_ + rw [splitCoevalCore_cover A B φ w d hw] + rw [associator_naturality_right_assoc] + rw [← Category.assoc, hpre] + rw [← MonoidalCategory.whiskerLeft_comp_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc] + simp only [Category.assoc] + rw [zigzag_carrier_zag_assoc A hz] + apply modTensor_hom_ext + refine Eq.trans hstep ?_ + rw [modTensorπ_splitEval] + +/-- The base-changed pairing is linear over the new base in its +inner variable. -/ +theorem baseChangePair_linear_inner + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + ((baseChangeMod φ M').X ◁ baseChangeAct φ M) ≫ + modTensorπ B (baseChangeMod φ M') (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair = + (α_ (baseChangeMod φ M').X B + (baseChangeMod φ M).X).inv ≫ + ((β_ (baseChangeMod φ M').X B).hom ▷ + (baseChangeMod φ M).X) ≫ + (α_ B (baseChangeMod φ M').X + (baseChangeMod φ M).X).hom ≫ + (B ◁ (modTensorπ B (baseChangeMod φ M') + (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair)) ≫ μ[B] := by + have hcond : (actRight B (baseChangeMod φ M').X ▷ + (baseChangeMod φ M).X) ≫ + modTensorπ B (baseChangeMod φ M') (baseChangeMod φ M) = + (α_ (baseChangeMod φ M').X B (baseChangeMod φ M).X).hom ≫ + ((baseChangeMod φ M').X ◁ + actLeft B (baseChangeMod φ M).X) ≫ + modTensorπ B (baseChangeMod φ M') + (baseChangeMod φ M) := by + have h := modTensor_condition B (baseChangeMod φ M') + (baseChangeMod φ M) + rw [modTensorLegM, modTensorLegN, Category.assoc] at h + exact h + have hfold : ((β_ (baseChangeMod φ M').X B).hom ▷ + (baseChangeMod φ M).X) ≫ + (baseChangeAct φ M' ▷ (baseChangeMod φ M).X) = + (actRight B (baseChangeMod φ M').X ▷ + (baseChangeMod φ M).X) := + (MonoidalCategory.comp_whiskerRight _ _ _).symm + rw [← baseChangePair_linear_outer A B φ d] + refine Eq.symm ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker hfold _)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker hcond _)) ?_ + simp only [Category.assoc, Iso.inv_hom_id_assoc] + rfl + +/-- **The coevaluation against the base-changed pairing**. -/ +theorem splitCoeval_pair + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} (w : M'.X ⟶ B) + (d : ModDualityDatum A M M') + (hz : ModZigzagDatum A d) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + ((baseChangeMod φ M').X ◁ + splitCoeval A B φ w d hw) ≫ + modTensorπ B (baseChangeMod φ M') (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair = + (splitEval A B φ w hw ▷ B) ≫ μ[B] := by + have hstruct : ∀ (Y X : D) (z : 𝟙_ D ⟶ X), + (Y ◁ (ρ_ B).inv) ≫ (Y ◁ (B ◁ z)) ≫ + (α_ Y B X).inv ≫ ((β_ Y B).hom ▷ X) ≫ + (α_ B Y X).hom = + (β_ Y B).hom ≫ (B ◁ ((ρ_ Y).inv ≫ (Y ◁ z))) := by + intro Y X z + rw [associator_inv_naturality_right_assoc, + whisker_exchange_assoc, + associator_naturality_right] + rw [whiskerLeft_rightUnitor_inv] + simp only [Category.assoc, Iso.hom_inv_id_assoc] + rw [← rightUnitor_inv_naturality_assoc, + ← whiskerLeft_rightUnitor_inv_assoc, + ← MonoidalCategory.whiskerLeft_comp] + have hsplit : splitCoeval A B φ w d hw = + (ρ_ B).inv ≫ + (B ◁ (η[A] ≫ d.copair ≫ + splitCoevalCore A B φ w hw)) ≫ + baseChangeAct φ M := rfl + rw [hsplit] + rw [MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rw [baseChangePair_linear_inner A B φ d] + refine Eq.trans ((reassoc_of% (hstruct + (baseChangeMod φ M').X (baseChangeMod φ M).X + (η[A] ≫ d.copair ≫ + splitCoevalCore A B φ w hw))) _) ?_ + have hfold : ∀ {U V W : D} (p : U ⟶ V) (q : V ⟶ W) + (k : B ⊗ W ⟶ B), + (B ◁ p) ≫ (B ◁ q) ≫ k = (B ◁ (p ≫ q)) ≫ k := by + intro U V W p q k + rw [← Category.assoc, ← MonoidalCategory.whiskerLeft_comp] + refine Eq.trans (whisker_eq _ (hfold _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker (congrArg + (fun t => B ◁ t) (Category.assoc _ _ _)) _)) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker (congrArg + (fun t => B ◁ t) + (splitCoeval_point_pair A B φ w d hz hw)) _)) ?_ + erw [← BraidedCategory.braiding_naturality_left_assoc, + IsCommMonObj.mul_comm] + rfl + +end Primal + +end Adjoint + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeBiprod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeBiprod.lean new file mode 100644 index 0000000000..993624d297 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeBiprod.lean @@ -0,0 +1,395 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod + +/-! +# Base change distributes over biproducts + +Base change along a morphism of commutative monoid objects sends +the biproduct of two modules to the biproduct of their base +changes, as bundled modules over the new base. The forward map +projects componentwise; the inverse injects componentwise; both +are linear over the new base, and they are mutually inverse. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- Morphisms out of a tensored biproduct are determined by the +two whiskered injections. -/ +private theorem whisker_biprod_ext + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] + {P X Y Z : D} + {f g : P ⊗ (X ⊞ Y) ⟶ Z} + (h1 : (P ◁ biprod.inl) ≫ f = (P ◁ biprod.inl) ≫ g) + (h2 : (P ◁ biprod.inr) ≫ f = (P ◁ biprod.inr) ≫ g) : + f = g := by + have htot : 𝟙 (P ⊗ (X ⊞ Y)) = + (P ◁ biprod.fst) ≫ (P ◁ biprod.inl) + + (P ◁ biprod.snd) ≫ (P ◁ biprod.inr) := by + rw [← MonoidalCategory.whiskerLeft_comp, + ← MonoidalCategory.whiskerLeft_comp, + ← MonoidalPreadditive.whiskerLeft_add, biprod.total, + MonoidalCategory.whiskerLeft_id] + calc f = 𝟙 (P ⊗ (X ⊞ Y)) ≫ f := (Category.id_comp f).symm + _ = ((P ◁ biprod.fst) ≫ (P ◁ biprod.inl) + + (P ◁ biprod.snd) ≫ (P ◁ biprod.inr)) ≫ f := by + rw [← htot] + _ = (P ◁ biprod.fst) ≫ ((P ◁ biprod.inl) ≫ g) + + (P ◁ biprod.snd) ≫ ((P ◁ biprod.inr) ≫ g) := by + rw [Preadditive.add_comp] + simp only [Category.assoc] + rw [h1, h2] + _ = ((P ◁ biprod.fst) ≫ (P ◁ biprod.inl) + + (P ◁ biprod.snd) ≫ (P ◁ biprod.inr)) ≫ g := by + rw [Preadditive.add_comp] + simp only [Category.assoc] + _ = 𝟙 (P ⊗ (X ⊞ Y)) ≫ g := by rw [← htot] + _ = g := Category.id_comp g + +/-- The first injection followed by the first projection is the +identity, at the level of module morphisms. -/ +lemma modBiprodInl_fst [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] (A : D) [MonObj A] + (M : Mod D A) (N : Mod D A) : + modBiprodInl A M N ≫ modBiprodFst A M N = 𝟙 M := by + apply Mod.hom_ext + change (biprod.inl : M.X ⟶ M.X ⊞ N.X) ≫ biprod.fst = 𝟙 M.X + exact biprod.inl_fst + +/-- The second injection followed by the second projection is the +identity, at the level of module morphisms. -/ +lemma modBiprodInr_snd [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] (A : D) [MonObj A] + (M : Mod D A) (N : Mod D A) : + modBiprodInr A M N ≫ modBiprodSnd A M N = 𝟙 N := by + apply Mod.hom_ext + change (biprod.inr : N.X ⟶ M.X ⊞ N.X) ≫ biprod.snd = 𝟙 N.X + exact biprod.inr_snd + +/-- **The forward map**: the base change of a biproduct projects +componentwise onto the biproduct of the base changes. -/ +noncomputable def baseChangeBiprodFwd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasCoequalizers D] [HasBinaryBiproducts D] (A : D) + [MonObj A] (B : D) [MonObj B] (φ : A ⟶ B) [IsMonHom φ] (M : Mod D A) + (N : Mod D A) : + baseChange φ (modBiprod A M N) ⟶ + baseChange φ M ⊞ baseChange φ N := + biprod.lift + (modTensorMap A (𝟙 (restrictRegular φ)) (modBiprodFst A M N)) + (modTensorMap A (𝟙 (restrictRegular φ)) (modBiprodSnd A M N)) + +/-- **The backward map**: the biproduct of the base changes +injects componentwise into the base change of the biproduct. -/ +noncomputable def baseChangeBiprodBwd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (B : D) [MonObj B] + (φ : A ⟶ B) [IsMonHom φ] (M : Mod D A) (N : Mod D A) : + baseChange φ M ⊞ baseChange φ N ⟶ + baseChange φ (modBiprod A M N) := + biprod.desc + (modTensorMap A (𝟙 (restrictRegular φ)) (modBiprodInl A M N)) + (modTensorMap A (𝟙 (restrictRegular φ)) (modBiprodInr A M N)) + +/-- Injecting and then projecting the first component is the +identity on the base change. -/ +private lemma map_inl_fst + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (B : D) [MonObj B] + (φ : A ⟶ B) [IsMonHom φ] (M : Mod D A) (N : Mod D A) : + modTensorMap A (𝟙 (restrictRegular φ)) (modBiprodInl A M N) ≫ + modTensorMap A (𝟙 (restrictRegular φ)) + (modBiprodFst A M N) = + 𝟙 (baseChange φ M) := by + rw [← modTensorMap_comp, Category.comp_id, modBiprodInl_fst, + modTensorMap_id] + rfl + +/-- Injecting and then projecting the second component is the +identity on the base change. -/ +private lemma map_inr_snd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (B : D) [MonObj B] + (φ : A ⟶ B) [IsMonHom φ] (M : Mod D A) (N : Mod D A) : + modTensorMap A (𝟙 (restrictRegular φ)) (modBiprodInr A M N) ≫ + modTensorMap A (𝟙 (restrictRegular φ)) + (modBiprodSnd A M N) = + 𝟙 (baseChange φ N) := by + rw [← modTensorMap_comp, Category.comp_id, modBiprodInr_snd, + modTensorMap_id] + rfl + +/-- Injecting the first and projecting the second component +vanishes. -/ +private lemma map_inl_snd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (B : D) [MonObj B] + (φ : A ⟶ B) [IsMonHom φ] (M : Mod D A) (N : Mod D A) : + modTensorMap A (𝟙 (restrictRegular φ)) (modBiprodInl A M N) ≫ + modTensorMap A (𝟙 (restrictRegular φ)) + (modBiprodSnd A M N) = 0 := by + apply modTensor_hom_ext + rw [modTensorπ_map_assoc, modTensorπ_map] + simp only [Mod.id_hom', modBiprodInl_hom, modBiprodSnd_hom] + repeat' erw [MonoidalCategory.id_tensorHom] + erw [← MonoidalCategory.whiskerLeft_comp_assoc] + change B ◁ ((biprod.inl : M.X ⟶ M.X ⊞ N.X) ≫ biprod.snd) ≫ + modTensorπ A (restrictRegular φ) N = + modTensorπ A (restrictRegular φ) M ≫ 0 + rw [biprod.inl_snd, MonoidalPreadditive.whiskerLeft_zero, + Limits.zero_comp, Limits.comp_zero] + +/-- Injecting the second and projecting the first component +vanishes. -/ +private lemma map_inr_fst + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (B : D) [MonObj B] + (φ : A ⟶ B) [IsMonHom φ] (M : Mod D A) (N : Mod D A) : + modTensorMap A (𝟙 (restrictRegular φ)) (modBiprodInr A M N) ≫ + modTensorMap A (𝟙 (restrictRegular φ)) + (modBiprodFst A M N) = 0 := by + apply modTensor_hom_ext + rw [modTensorπ_map_assoc, modTensorπ_map] + simp only [Mod.id_hom', modBiprodInr_hom, modBiprodFst_hom] + repeat' erw [MonoidalCategory.id_tensorHom] + erw [← MonoidalCategory.whiskerLeft_comp_assoc] + change B ◁ ((biprod.inr : N.X ⟶ M.X ⊞ N.X) ≫ biprod.fst) ≫ + modTensorπ A (restrictRegular φ) M = + modTensorπ A (restrictRegular φ) N ≫ 0 + rw [biprod.inr_fst, MonoidalPreadditive.whiskerLeft_zero, + Limits.zero_comp, Limits.comp_zero] + +/-- The backward map followed by the forward map is the +identity. -/ +theorem baseChangeBiprodBwd_fwd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (B : D) [MonObj B] + (φ : A ⟶ B) [IsMonHom φ] (M : Mod D A) (N : Mod D A) : + baseChangeBiprodBwd A B φ M N ≫ baseChangeBiprodFwd A B φ M N = + 𝟙 (baseChange φ M ⊞ baseChange φ N) := by + unfold baseChangeBiprodBwd baseChangeBiprodFwd + apply biprod.hom_ext' + · erw [Category.comp_id, biprod.inl_desc_assoc] + apply biprod.hom_ext + · erw [Category.assoc, biprod.lift_fst, biprod.inl_fst] + exact map_inl_fst A B φ M N + · erw [Category.assoc, biprod.lift_snd, biprod.inl_snd] + exact map_inl_snd A B φ M N + · erw [Category.comp_id, biprod.inr_desc_assoc] + apply biprod.hom_ext + · erw [Category.assoc, biprod.lift_fst, biprod.inr_fst] + exact map_inr_fst A B φ M N + · erw [Category.assoc, biprod.lift_snd, biprod.inr_snd] + exact map_inr_snd A B φ M N + +/-- The forward map followed by the backward map is the +identity. -/ +theorem baseChangeBiprodFwd_bwd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (B : D) [MonObj B] + (φ : A ⟶ B) [IsMonHom φ] (M : Mod D A) (N : Mod D A) : + baseChangeBiprodFwd A B φ M N ≫ baseChangeBiprodBwd A B φ M N = + 𝟙 (baseChange φ (modBiprod A M N)) := by + unfold baseChangeBiprodFwd baseChangeBiprodBwd + erw [biprod.lift_desc] + apply modTensor_hom_ext + change modTensorπ A (restrictRegular φ) (modBiprod A M N) ≫ + (modTensorMap A (𝟙 (restrictRegular φ)) + (modBiprodFst A M N) ≫ + modTensorMap A (𝟙 (restrictRegular φ)) + (modBiprodInl A M N) + + modTensorMap A (𝟙 (restrictRegular φ)) + (modBiprodSnd A M N) ≫ + modTensorMap A (𝟙 (restrictRegular φ)) + (modBiprodInr A M N)) = + modTensorπ A (restrictRegular φ) (modBiprod A M N) ≫ + 𝟙 (modTensor A (restrictRegular φ) (modBiprod A M N)) + rw [Preadditive.comp_add, Category.comp_id] + rw [modTensorπ_map_assoc, modTensorπ_map_assoc, + modTensorπ_map, modTensorπ_map] + simp only [Mod.id_hom', modBiprodFst_hom, modBiprodInl_hom, + modBiprodSnd_hom, modBiprodInr_hom] + repeat' erw [MonoidalCategory.id_tensorHom] + erw [← MonoidalCategory.whiskerLeft_comp_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + ← Preadditive.add_comp, + ← MonoidalPreadditive.whiskerLeft_add] + have hs : B ◁ ((biprod.fst : M.X ⊞ N.X ⟶ M.X) ≫ biprod.inl + + (biprod.snd : M.X ⊞ N.X ⟶ N.X) ≫ biprod.inr) = + 𝟙 (B ⊗ (M.X ⊞ N.X)) := by + rw [biprod.total, MonoidalCategory.whiskerLeft_id] + exact (eq_whisker hs + (modTensorπ A (restrictRegular φ) (modBiprod A M N))).trans + (Category.id_comp _) + +/-- Base change of a module morphism is linear over the new +base. -/ +lemma baseChangeAct_modTensorMap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (B : D) [MonObj B] + [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + {P Q : Mod D A} (f : P ⟶ Q) : + baseChangeAct φ P ≫ modTensorMap A (𝟙 (restrictRegular φ)) f = + B ◁ modTensorMap A (𝟙 (restrictRegular φ)) f ≫ + baseChangeAct φ Q := by + apply modTensor_whisker_hom_ext A (restrictRegular φ) P B + have h2 : modTensorπ A (restrictRegular φ) P ≫ + modTensorMap A (𝟙 (restrictRegular φ)) f = + B ◁ f.hom ≫ modTensorπ A (restrictRegular φ) Q := by + rw [modTensorπ_map, Mod.id_hom', + MonoidalCategory.id_tensorHom] + have hcore : ((α_ B B P.X).inv ≫ μ[B] ▷ P.X) ≫ + B ◁ f.hom ≫ modTensorπ A (restrictRegular φ) Q = + B ◁ (B ◁ f.hom) ≫ + ((α_ B B Q.X).inv ≫ μ[B] ▷ Q.X) ≫ + modTensorπ A (restrictRegular φ) Q := by + simp only [Category.assoc] + rw [associator_inv_naturality_right_assoc, + whisker_exchange_assoc] + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (whiskerLeft_modTensorπ_baseChangeAct φ P) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ h2) ?_ + refine Eq.trans hcore ?_ + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => B ◁ t) h2) _) ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (whiskerLeft_modTensorπ_baseChangeAct φ Q) + +/-- The forward map intertwines the actions. -/ +theorem baseChangeAct_baseChangeBiprodFwd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasCoequalizers D] [HasBinaryBiproducts D] (A : D) + [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (M : Mod D A) (N : Mod D A) : + baseChangeAct φ (modBiprod A M N) ≫ + baseChangeBiprodFwd A B φ M N = + B ◁ baseChangeBiprodFwd A B φ M N ≫ + modBiprodAct B (baseChangeMod φ M) (baseChangeMod φ N) := by + apply biprod.hom_ext + · refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (biprod.lift_fst _ _)) ?_ + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (modBiprodAct_fst B (baseChangeMod φ M) + (baseChangeMod φ N))) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => B ◁ t) + (biprod.lift_fst _ _)) _) ?_ + exact + (baseChangeAct_modTensorMap A B φ (modBiprodFst A M N)).symm + · refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (biprod.lift_snd _ _)) ?_ + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (modBiprodAct_snd B (baseChangeMod φ M) + (baseChangeMod φ N))) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => B ◁ t) + (biprod.lift_snd _ _)) _) ?_ + exact + (baseChangeAct_modTensorMap A B φ (modBiprodSnd A M N)).symm + +/-- The backward map intertwines the actions. -/ +theorem modBiprodAct_baseChangeBiprodBwd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (B : D) [MonObj B] + [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (M : Mod D A) (N : Mod D A) : + modBiprodAct B (baseChangeMod φ M) (baseChangeMod φ N) ≫ + baseChangeBiprodBwd A B φ M N = + B ◁ baseChangeBiprodBwd A B φ M N ≫ + baseChangeAct φ (modBiprod A M N) := by + apply whisker_biprod_ext + · refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (actLeft_modBiprodInl B (baseChangeMod φ M) + (baseChangeMod φ N)).symm _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (biprod.inl_desc _ _)) ?_ + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => B ◁ t) + (biprod.inl_desc _ _)) _) ?_ + exact + (baseChangeAct_modTensorMap A B φ (modBiprodInl A M N)).symm + · refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (actLeft_modBiprodInr B (baseChangeMod φ M) + (baseChangeMod φ N)).symm _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (biprod.inr_desc _ _)) ?_ + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => B ◁ t) + (biprod.inr_desc _ _)) _) ?_ + exact + (baseChangeAct_modTensorMap A B φ (modBiprodInr A M N)).symm + +/-- **Base change distributes over the biproduct**: the base +change of a biproduct of modules is the biproduct of the base +changes, as bundled modules over the new base. -/ +noncomputable def baseChangeBiprodIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (B : D) [MonObj B] + [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (M : Mod D A) (N : Mod D A) : + baseChangeMod φ (modBiprod A M N) ≅ + modBiprod B (baseChangeMod φ M) (baseChangeMod φ N) where + hom := Mod.Hom.mk' (baseChangeBiprodFwd A B φ M N) + (by exact baseChangeAct_baseChangeBiprodFwd A B φ M N) + inv := Mod.Hom.mk' (baseChangeBiprodBwd A B φ M N) + (by exact modBiprodAct_baseChangeBiprodBwd A B φ M N) + hom_inv_id := by + apply Mod.hom_ext + exact baseChangeBiprodFwd_bwd A B φ M N + inv_hom_id := by + apply Mod.hom_ext + exact baseChangeBiprodBwd_fwd A B φ M N + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeCoherence.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeCoherence.lean new file mode 100644 index 0000000000..22cb374851 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeCoherence.lean @@ -0,0 +1,832 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichRetract + +/-! +# Coherence of the base-change structure map + +The projection formula is compatible with the right unit +collapse: contracting the regular factor before or after the +base change gives the same map. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The cast leg is invisible on projections**: the +restricted projection, transported along the identification of +the restricted base change, is the projection of the relative +tensor. -/ +theorem restrictπ_cast + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + (M N : Mod D A) : + restrictπ A B φ (baseChangeMod φ M) N ≫ + eqToHom (congrArg (fun R => modTensor A R N) + (restrictMod_baseChange_eq A B φ M)) = + modTensorπ A + (modTensorMod A (restrictRegular φ) M) N := by + have h := restrictMod_baseChange_eq A B φ M + have key : ∀ (P Q : Mod D A) (hPQ : P = Q), + modTensorπ A P N ≫ + eqToHom (congrArg (fun R => modTensor A R N) hPQ) = + eqToHom (congrArg (fun R => R.X ⊗ N.X) hPQ) ≫ + modTensorπ A Q N := by + intro P Q hPQ + subst hPQ + simp + refine Eq.trans (key _ _ h) ?_ + refine Eq.trans (eq_whisker (show + eqToHom (congrArg (fun R : Mod D A => R.X ⊗ N.X) h) = + 𝟙 ((baseChangeMod φ M).X ⊗ N.X) from rfl) _) ?_ + exact Category.id_comp _ + +/-- **The projection formula on the cover**: composing the +structure map with the inner projection unwinds to the right +action of the new base followed by the half-descended module +associator, with no transport left in the way. -/ +theorem projFormula_cover + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + (M N : Mod D A) : + ((baseChangeMod φ M).X ◁ + modTensorπ A (restrictRegular φ) N) ≫ + modTensorπ B (baseChangeMod φ M) (baseChangeMod φ N) ≫ + (projFormula A B φ M N).hom = + (α_ (baseChangeMod φ M).X B N.X).inv ≫ + (actRight B (baseChangeMod φ M).X ▷ N.X) ≫ + modTensorAssocMid A (restrictRegular φ) M N := by + have hpf : (projFormula A B φ M N).hom = + collapseHom A B φ (baseChangeMod φ M) N ≫ + eqToHom (congrArg (fun P => modTensor A P N) + (restrictMod_baseChange_eq A B φ M)) ≫ + modTensorAssocHom A (restrictRegular φ) M N := rfl + have hmid : ∀ {Z : D} + (h : modTensor A (restrictMod A B φ + (baseChangeMod φ M)) N ⟶ Z), + ((baseChangeMod φ M).X ◁ + modTensorπ A (restrictRegular φ) N) ≫ + modTensorπ B (baseChangeMod φ M) + (baseChangeMod φ N) ≫ + collapseHom A B φ (baseChangeMod φ M) N ≫ h = + (α_ (baseChangeMod φ M).X B N.X).inv ≫ + (actRight B (baseChangeMod φ M).X ▷ N.X) ≫ + restrictπ A B φ (baseChangeMod φ M) N ≫ h := by + intro Z h + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + (modTensorπ_collapseHom A B φ + (baseChangeMod φ M) N) h)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (whiskerLeft_collapseMid A B φ (baseChangeMod φ M) N) + h) ?_ + rw [collapseCover] + simp only [Category.assoc] + rw [hpf] + refine Eq.trans (hmid _) ?_ + refine whisker_eq _ (whisker_eq _ ?_) + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (restrictπ_cast A B φ M N) _) ?_ + exact modTensorπ_assocHom A (restrictRegular φ) M N + +/-- **The module triangle**: reassociating and collapsing the +regular factor on the right is the braided right action on the +relative tensor. -/ +theorem modTensorAssocMid_unitRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] + (P N : Mod D A) : + modTensorAssocMid A P N (regularMod A) ≫ + modTensorMap A (𝟙 P) (modTensorUnitRightMod A N).hom = + actRight A (modTensorMod A P N).X := by + have key : ∀ {Z : D} + (h : modTensor A P (modTensorMod A N (regularMod A)) ⟶ Z), + (modTensorπ A P N ▷ (regularMod A).X) ≫ + modTensorAssocMid A P N (regularMod A) ≫ h = + (α_ P.X N.X A).hom ≫ + (P.X ◁ modTensorπ A N (regularMod A)) ≫ + modTensorπ A P (modTensorMod A N (regularMod A)) ≫ + h := by + intro Z h + rw [← Category.assoc, whiskerRight_modTensorπ_assocMid, + modTensorAssocCover] + repeat' erw [Category.assoc] + have tail : modTensorπ A P (modTensorMod A N (regularMod A)) ≫ + modTensorMap A (𝟙 P) (modTensorUnitRightMod A N).hom = + (P.X ◁ (modTensorUnitRight A N).hom) ≫ modTensorπ A P N := by + rw [modTensorπ_map, Mod.id_hom', + MonoidalCategory.id_tensorHom] + rfl + have hfold : (P.X ◁ modTensorπ A N (regularMod A)) ≫ + (P.X ◁ (modTensorUnitRight A N).hom) = + P.X ◁ actRight A N.X := by + rw [← MonoidalCategory.whiskerLeft_comp, + modTensorUnitRight_hom, modTensorπ_desc] + apply modTensor_whiskerR_hom_ext A P N (regularMod A).X + refine Eq.trans (key _) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ tail)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker hfold _)) ?_ + exact (modTensorπ_actRight A P N).symm + +/-- The restricted action on a base change: the `A`-action on the +relative tensor is the `B`-action taken through the base +morphism. -/ +theorem actRight_modTensor_restrictRegular + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + (M : Mod D A) : + actRight A (modTensorMod A (restrictRegular φ) M).X = + ((baseChangeMod φ M).X ◁ φ) ≫ + actRight B (baseChangeMod φ M).X := by + have h := actLeft_restrict_baseChange A B φ M + change (β_ (baseChange φ M) A).hom ≫ + modTensorAct A (restrictRegular φ) M = _ + rw [← h] + change (β_ (baseChange φ M) A).hom ≫ (φ ▷ baseChange φ M) ≫ + baseChangeAct φ M = + ((baseChange φ M) ◁ φ) ≫ (β_ (baseChange φ M) B).hom ≫ + baseChangeAct φ M + rw [← BraidedCategory.braiding_naturality_right_assoc] + +/-- **The unit coherence of the projection formula**: collapsing +the regular factor after the base change agrees with collapsing +the base-changed regular module over the new base. -/ +theorem projFormula_unitRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + (M : Mod D A) : + (projFormula A B φ M (regularMod A)).hom ≫ + modTensorMap A (𝟙 (restrictRegular φ)) + (modTensorUnitRightMod A M).hom = + modTensorMap B (𝟙 (baseChangeMod φ M)) + (baseChangeUnitIso A B φ).hom ≫ + (modTensorUnitRight B (baseChangeMod φ M)).hom := by + have hslide : (α_ (baseChangeMod φ M).X B A).inv ≫ + (actRight B (baseChangeMod φ M).X ▷ A) ≫ + ((baseChangeMod φ M).X ◁ φ) ≫ + actRight B (baseChangeMod φ M).X = + ((baseChangeMod φ M).X ◁ ((B ◁ φ) ≫ μ[B])) ≫ + actRight B (baseChangeMod φ M).X := by + rw [← whisker_exchange_assoc] + rw [actRight_actRight, ← associator_inv_naturality_right_assoc, + Iso.inv_hom_id_assoc, MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + have hright : ((baseChangeMod φ M).X ◁ + modTensorπ A (restrictRegular φ) (regularMod A)) ≫ + modTensorπ B (baseChangeMod φ M) + (baseChangeMod φ (regularMod A)) ≫ + modTensorMap B (𝟙 (baseChangeMod φ M)) + (baseChangeUnitIso A B φ).hom ≫ + (modTensorUnitRight B (baseChangeMod φ M)).hom = + ((baseChangeMod φ M).X ◁ ((B ◁ φ) ≫ μ[B])) ≫ + actRight B (baseChangeMod φ M).X := by + have hmap : modTensorπ B (baseChangeMod φ M) + (baseChangeMod φ (regularMod A)) ≫ + modTensorMap B (𝟙 (baseChangeMod φ M)) + (baseChangeUnitIso A B φ).hom ≫ + (modTensorUnitRight B (baseChangeMod φ M)).hom = + ((baseChangeMod φ M).X ◁ + (modTensorUnitRight A (restrictRegular φ)).hom) ≫ + actRight B (baseChangeMod φ M).X := by + rw [modTensorπ_map_assoc, Mod.id_hom', + MonoidalCategory.id_tensorHom, modTensorUnitRight_hom, + modTensorπ_desc] + rfl + refine Eq.trans (whisker_eq _ hmap) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine eq_whisker ?_ _ + rw [← MonoidalCategory.whiskerLeft_comp, + modTensorUnitRight_hom, modTensorπ_desc, + actRight_restrictRegular] + apply modTensor_hom_ext + apply modTensor_whisker_hom_ext A (restrictRegular φ) + (regularMod A) (baseChangeMod φ M).X + refine Eq.trans ?_ hright.symm + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (projFormula_cover A B φ M (regularMod A)) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (modTensorAssocMid_unitRight A (restrictRegular φ) M))) ?_ + rw [actRight_modTensor_restrictRegular A B φ M] + exact hslide + +/-- A module map into the regular module intertwines the braided +right action with multiplication. -/ +theorem actRight_toRegular + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [IsCommMonObj A] + (Q : Mod D A) (g : Q ⟶ regularMod A) : + actRight A Q.X ≫ g.hom = (g.hom ▷ A) ≫ μ[A] := by + have hlin : actLeft A Q.X ≫ g.hom = (A ◁ g.hom) ≫ μ[A] := + g.isModHom.smul_hom + change ((β_ Q.X A).hom ≫ actLeft A Q.X) ≫ g.hom = _ + rw [Category.assoc, hlin, + ← BraidedCategory.braiding_naturality_left_assoc, + IsCommMonObj.mul_comm] + +/-- **The module triangle on the left**: reassociating and +collapsing the regular factor in the middle is the collapse of the +leading factor against the balance. -/ +theorem modTensorAssocMid_unitLeft + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] + (P N : Mod D A) : + modTensorAssocMid A P (regularMod A) N ≫ + modTensorMap A (𝟙 P) (modTensorUnitLeftMod A N).hom = + ((modTensorUnitRight A P).hom ▷ N.X) ≫ + modTensorπ A P N := by + have key : ∀ {Z : D} + (h : modTensor A P + (modTensorMod A (regularMod A) N) ⟶ Z), + (modTensorπ A P (regularMod A) ▷ N.X) ≫ + modTensorAssocMid A P (regularMod A) N ≫ h = + (α_ P.X A N.X).hom ≫ + (P.X ◁ modTensorπ A (regularMod A) N) ≫ + modTensorπ A P (modTensorMod A (regularMod A) N) ≫ + h := by + intro Z h + rw [← Category.assoc, whiskerRight_modTensorπ_assocMid, + modTensorAssocCover] + repeat' erw [Category.assoc] + have tail : modTensorπ A P + (modTensorMod A (regularMod A) N) ≫ + modTensorMap A (𝟙 P) (modTensorUnitLeftMod A N).hom = + (P.X ◁ (modTensorUnitLeft A N).hom) ≫ modTensorπ A P N := by + rw [modTensorπ_map, Mod.id_hom', + MonoidalCategory.id_tensorHom] + rfl + have hfold : (P.X ◁ modTensorπ A (regularMod A) N) ≫ + (P.X ◁ (modTensorUnitLeft A N).hom) = + P.X ◁ actLeft A N.X := by + rw [← MonoidalCategory.whiskerLeft_comp, + modTensorUnitLeft_hom, modTensorπ_desc] + have hR : (modTensorπ A P (regularMod A) ▷ N.X) ≫ + ((modTensorUnitRight A P).hom ▷ N.X) ≫ + modTensorπ A P N = + (α_ P.X A N.X).hom ≫ (P.X ◁ actLeft A N.X) ≫ + modTensorπ A P N := by + rw [← MonoidalCategory.comp_whiskerRight_assoc, + modTensorUnitRight_hom, modTensorπ_desc] + have h := modTensor_condition A P N + rw [modTensorLegM, modTensorLegN, Category.assoc] at h + exact h + apply modTensor_whiskerR_hom_ext A P (regularMod A) N.X + refine Eq.trans (key _) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ tail)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker hfold _)) ?_ + exact hR.symm + +/-- **The left unit coherence of the projection formula**: +collapsing the regular factor on the left commutes with the base +change. -/ +theorem projFormula_unitLeft + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + (N : Mod D A) : + (projFormula A B φ (regularMod A) N).hom ≫ + modTensorMap A (𝟙 (restrictRegular φ)) + (modTensorUnitLeftMod A N).hom = + modTensorMap B (baseChangeUnitIso A B φ).hom + (𝟙 (baseChangeMod φ N)) ≫ + (modTensorUnitLeft B (baseChangeMod φ N)).hom := by + have hu : actRight B (baseChangeMod φ (regularMod A)).X ≫ + (modTensorUnitRight A (restrictRegular φ)).hom = + ((modTensorUnitRight A (restrictRegular φ)).hom ▷ B) ≫ + μ[B] := + actRight_toRegular B (baseChangeMod φ (regularMod A)) + (baseChangeUnitIso A B φ).hom + have hend : ∀ (Y : D) (r : Y ⊗ B ⟶ Y) (uu : Y ⟶ B), + r ≫ uu = (uu ▷ B) ≫ μ[B] → + (α_ Y B N.X).inv ≫ (r ▷ N.X) ≫ (uu ▷ N.X) ≫ + modTensorπ A (restrictRegular φ) N = + (uu ▷ (B ⊗ N.X)) ≫ + ((α_ B B N.X).inv ≫ (μ[B] ▷ N.X)) ≫ + modTensorπ A (restrictRegular φ) N := by + intro Y r uu hh + rw [← MonoidalCategory.comp_whiskerRight_assoc, hh, + MonoidalCategory.comp_whiskerRight] + simp only [Category.assoc] + rw [← associator_inv_naturality_left_assoc] + have hright : ((baseChangeMod φ (regularMod A)).X ◁ + modTensorπ A (restrictRegular φ) N) ≫ + modTensorπ B (baseChangeMod φ (regularMod A)) + (baseChangeMod φ N) ≫ + modTensorMap B (baseChangeUnitIso A B φ).hom + (𝟙 (baseChangeMod φ N)) ≫ + (modTensorUnitLeft B (baseChangeMod φ N)).hom = + ((modTensorUnitRight A (restrictRegular φ)).hom ▷ + (B ⊗ N.X)) ≫ + ((α_ B B N.X).inv ≫ (μ[B] ▷ N.X)) ≫ + modTensorπ A (restrictRegular φ) N := by + have hmap : modTensorπ B (baseChangeMod φ (regularMod A)) + (baseChangeMod φ N) ≫ + modTensorMap B (baseChangeUnitIso A B φ).hom + (𝟙 (baseChangeMod φ N)) ≫ + (modTensorUnitLeft B (baseChangeMod φ N)).hom = + ((modTensorUnitRight A (restrictRegular φ)).hom ▷ + (baseChangeMod φ N).X) ≫ + actLeft B (baseChangeMod φ N).X := by + rw [modTensorπ_map_assoc, Mod.id_hom', + MonoidalCategory.tensorHom_id, modTensorUnitLeft_hom, + modTensorπ_desc] + rfl + refine Eq.trans (whisker_eq _ hmap) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (whisker_exchange _ _) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ + (whiskerLeft_modTensorπ_baseChangeAct φ N) + apply modTensor_hom_ext + apply modTensor_whisker_hom_ext A (restrictRegular φ) N + (baseChangeMod φ (regularMod A)).X + refine Eq.trans ?_ hright.symm + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (projFormula_cover A B φ (regularMod A) N) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (modTensorAssocMid_unitLeft A (restrictRegular φ) N))) ?_ + exact hend _ _ _ hu + +/-- The projection into a base change, whiskered against the new +base, multiplies the two base factors after braiding the trailing +one past the module. -/ +theorem whiskerRight_modTensorπ_actRight_baseChange + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] + (M : Mod D A) : + (modTensorπ A (restrictRegular φ) M ▷ B) ≫ + actRight B (baseChangeMod φ M).X = + ((β_ (B ⊗ M.X) B).hom ≫ (α_ B B M.X).inv ≫ + (μ[B] ▷ M.X)) ≫ + modTensorπ A (restrictRegular φ) M := by + change (modTensorπ A (restrictRegular φ) M ▷ B) ≫ + (β_ (baseChange φ M) B).hom ≫ baseChangeAct φ M = _ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (BraidedCategory.braiding_naturality_left + (modTensorπ A (restrictRegular φ) M) B) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (whiskerLeft_modTensorπ_baseChangeAct φ M)) ?_ + simp only [Category.assoc] + rfl + +/-- **The projection formula on the full cover**: on the two +covering projections the structure map multiplies the two base +factors and projects — an explicit formula with no descent left +in it. -/ +theorem projFormula_full_cover + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + (M N : Mod D A) : + (modTensorπ A (restrictRegular φ) M ▷ (B ⊗ N.X)) ≫ + ((baseChangeMod φ M).X ◁ + modTensorπ A (restrictRegular φ) N) ≫ + modTensorπ B (baseChangeMod φ M) (baseChangeMod φ N) ≫ + (projFormula A B φ M N).hom = + (α_ (B ⊗ M.X) B N.X).inv ≫ + (((β_ (B ⊗ M.X) B).hom ≫ (α_ B B M.X).inv ≫ + (μ[B] ▷ M.X)) ▷ N.X) ≫ + (α_ B M.X N.X).hom ≫ (B ◁ modTensorπ A M N) ≫ + modTensorπ A (restrictRegular φ) + (modTensorMod A M N) := by + have key : ∀ {Z : D} + (r : modTensor A (restrictRegular φ) M ⊗ B ⟶ + modTensor A (restrictRegular φ) M) + (h : modTensor A (restrictRegular φ) M ⊗ N.X ⟶ Z), + (modTensorπ A (restrictRegular φ) M ▷ (B ⊗ N.X)) ≫ + (α_ (modTensor A (restrictRegular φ) M) B N.X).inv ≫ + (r ▷ N.X) ≫ h = + (α_ (B ⊗ M.X) B N.X).inv ≫ + (((modTensorπ A (restrictRegular φ) M ▷ B) ≫ r) + ▷ N.X) ≫ h := by + intro Z r h + rw [associator_inv_naturality_left_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc] + refine Eq.trans (whisker_eq _ + (projFormula_cover A B φ M N)) ?_ + refine Eq.trans (key _ _) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + (congrArg (fun t => t ▷ N.X) + (whiskerRight_modTensorπ_actRight_baseChange A B φ M)) + _)) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + (MonoidalCategory.comp_whiskerRight _ _ _) _)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (whiskerRight_modTensorπ_assocMid A + (restrictRegular φ) M N))) ?_ + rw [modTensorAssocCover] + rfl + +section BaseShuffle + +/-- **The base shuffle**: bringing the second copy of the base to +the front and multiplying is the middle-four interchange followed +by the multiplication. Commutativity of the base is what makes +the two orders agree. -/ +theorem baseShuffle + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (B : D) + [MonObj B] [IsCommMonObj B] + (Q W : D) : + (α_ (B ⊗ Q) B W).inv ≫ + (((β_ (B ⊗ Q) B).hom ≫ (α_ B B Q).inv ≫ + (μ[B] ▷ Q)) ▷ W) ≫ (α_ B Q W).hom = + tensorμ B Q B W ≫ (μ[B] ▷ (Q ⊗ W)) := by + have hS₁ : (α_ (B ⊗ Q) B W).inv ≫ ((α_ B Q B).hom ▷ W) ≫ + (α_ B (Q ⊗ B) W).hom = + (α_ B Q (B ⊗ W)).hom ≫ (B ◁ (α_ Q B W).inv) := by + monoidal + have hS₂ : (α_ B (B ⊗ Q) W).inv ≫ ((α_ B B Q).inv ▷ W) ≫ + (α_ (B ⊗ B) Q W).hom = + (B ◁ (α_ B Q W).hom) ≫ (α_ B B (Q ⊗ W)).inv := by + monoidal + have hmid : ((B ◁ (β_ Q B).hom) ▷ W) = + (α_ B (Q ⊗ B) W).hom ≫ (B ◁ ((β_ Q B).hom ▷ W)) ≫ + (α_ B (B ⊗ Q) W).inv := by + rw [← associator_naturality_middle_assoc, + Iso.hom_inv_id, Category.comp_id] + have hcw : (((β_ B B).hom ▷ Q) ▷ W) ≫ ((μ[B] ▷ Q) ▷ W) = + (μ[B] ▷ Q) ▷ W := by + rw [← MonoidalCategory.comp_whiskerRight, + ← MonoidalCategory.comp_whiskerRight, + IsCommMonObj.mul_comm] + have hlast : ((μ[B] ▷ Q) ▷ W) ≫ (α_ B Q W).hom = + (α_ (B ⊗ B) Q W).hom ≫ (μ[B] ▷ (Q ⊗ W)) := + associator_naturality_left μ[B] Q W + rw [BraidedCategory.braiding_tensor_left_hom] + simp only [Category.assoc, Iso.hom_inv_id_assoc, + MonoidalCategory.comp_whiskerRight] + rw [reassoc_of% hcw] + rw [tensorμ] + simp only [Category.assoc] + rw [hmid] + simp only [Category.assoc] + rw [hlast, reassoc_of% hS₂, reassoc_of% hS₁] + +end BaseShuffle + +/-- **The base multiplication is associative on covers**: +interchange-and-multiply is the structure map of a lax monoidal +functor, so it satisfies the associativity square. -/ +theorem baseAssoc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (B : D) + [MonObj B] + (Q₁ Q₂ Q₃ : D) : + ((tensorμ B Q₁ B Q₂ ≫ (μ[B] ▷ (Q₁ ⊗ Q₂))) ▷ (B ⊗ Q₃)) ≫ + tensorμ B (Q₁ ⊗ Q₂) B Q₃ ≫ + (μ[B] ▷ ((Q₁ ⊗ Q₂) ⊗ Q₃)) ≫ + (B ◁ (α_ Q₁ Q₂ Q₃).hom) = + (α_ (B ⊗ Q₁) (B ⊗ Q₂) (B ⊗ Q₃)).hom ≫ + ((B ⊗ Q₁) ◁ (tensorμ B Q₂ B Q₃ ≫ + (μ[B] ▷ (Q₂ ⊗ Q₃)))) ≫ + tensorμ B Q₁ B (Q₂ ⊗ Q₃) ≫ + (μ[B] ▷ (Q₁ ⊗ (Q₂ ⊗ Q₃))) := by + have hass := tensor_associativity B Q₁ B Q₂ B Q₃ + simp only [MonoidalCategory.comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [← MonoidalCategory.tensorHom_id μ[B] (Q₁ ⊗ Q₂), + tensorμ_natural_left_assoc] + rw [← MonoidalCategory.tensorHom_id μ[B] (Q₂ ⊗ Q₃), + tensorμ_natural_right_assoc] + rw [← reassoc_of% hass] + have hL : ((μ[B] ▷ B) ⊗ₘ (𝟙 (Q₁ ⊗ Q₂) ▷ Q₃)) ≫ + (μ[B] ▷ ((Q₁ ⊗ Q₂) ⊗ Q₃)) ≫ + (B ◁ (α_ Q₁ Q₂ Q₃).hom) = + (((μ[B] ▷ B) ≫ μ[B]) ⊗ₘ (α_ Q₁ Q₂ Q₃).hom) := by + rw [MonoidalCategory.id_whiskerRight, + ← MonoidalCategory.tensorHom_id μ[B] ((Q₁ ⊗ Q₂) ⊗ Q₃), + ← MonoidalCategory.id_tensorHom B (α_ Q₁ Q₂ Q₃).hom, + tensorHom_comp_tensorHom, tensorHom_comp_tensorHom] + simp + have hR : ((α_ B B B).hom ⊗ₘ (α_ Q₁ Q₂ Q₃).hom) ≫ + ((B ◁ μ[B]) ⊗ₘ (Q₁ ◁ 𝟙 (Q₂ ⊗ Q₃))) ≫ + (μ[B] ▷ (Q₁ ⊗ (Q₂ ⊗ Q₃))) = + (((α_ B B B).hom ≫ (B ◁ μ[B]) ≫ μ[B]) ⊗ₘ + (α_ Q₁ Q₂ Q₃).hom) := by + rw [MonoidalCategory.whiskerLeft_id, + ← MonoidalCategory.tensorHom_id μ[B] (Q₁ ⊗ (Q₂ ⊗ Q₃)), + tensorHom_comp_tensorHom, tensorHom_comp_tensorHom] + simp + rw [hL, hR, MonObj.mul_assoc] + +/-- Interchange-and-multiply is natural in the first module +slot. -/ +theorem baseMul_natural_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (B : D) + [MonObj B] + {Q Q' : D} (f : Q ⟶ Q') (W : D) : + ((B ◁ f) ▷ (B ⊗ W)) ≫ tensorμ B Q' B W ≫ + (μ[B] ▷ (Q' ⊗ W)) = + tensorμ B Q B W ≫ (μ[B] ▷ (Q ⊗ W)) ≫ + (B ◁ (f ▷ W)) := by + rw [← MonoidalCategory.id_tensorHom B f, + tensorμ_natural_left_assoc, + MonoidalCategory.id_whiskerRight, + MonoidalCategory.id_tensorHom, whisker_exchange] + +/-- Interchange-and-multiply is natural in the second module +slot. -/ +theorem baseMul_natural_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (B : D) + [MonObj B] + (Q : D) {W W' : D} (g : W ⟶ W') : + ((B ⊗ Q) ◁ (B ◁ g)) ≫ tensorμ B Q B W' ≫ + (μ[B] ▷ (Q ⊗ W')) = + tensorμ B Q B W ≫ (μ[B] ▷ (Q ⊗ W)) ≫ + (B ◁ (Q ◁ g)) := by + rw [← MonoidalCategory.id_tensorHom B g, + tensorμ_natural_right_assoc, + MonoidalCategory.whiskerLeft_id, + MonoidalCategory.id_tensorHom, whisker_exchange] + +/-- **The projection formula on the full cover, in interchange +form**: the structure map multiplies the two base factors through +the middle-four interchange and projects. -/ +theorem projFormula_tensorμ_cover + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + (M N : Mod D A) : + (modTensorπ A (restrictRegular φ) M ▷ (B ⊗ N.X)) ≫ + ((baseChangeMod φ M).X ◁ + modTensorπ A (restrictRegular φ) N) ≫ + modTensorπ B (baseChangeMod φ M) (baseChangeMod φ N) ≫ + (projFormula A B φ M N).hom = + tensorμ B M.X B N.X ≫ (μ[B] ▷ (M.X ⊗ N.X)) ≫ + (B ◁ modTensorπ A M N) ≫ + modTensorπ A (restrictRegular φ) + (modTensorMod A M N) := by + rw [projFormula_full_cover, + reassoc_of% (baseShuffle B M.X N.X)] + +/-- **The core of the associator coherence**: on the triple cover +the two ways of multiplying three base factors and projecting +agree. Naturality of interchange-and-multiply moves the two +projections to the right, the defining equation of the +half-descended associator merges them, and what is left is the +associativity of interchange-and-multiply. -/ +theorem projFormula_assoc_core + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] + (M N P : Mod D A) : + (((tensorμ B M.X B N.X ≫ (μ[B] ▷ (M.X ⊗ N.X))) ≫ + (B ◁ modTensorπ A M N)) ▷ (B ⊗ P.X)) ≫ + (tensorμ B (modTensor A M N) B P.X ≫ + (μ[B] ▷ (modTensor A M N ⊗ P.X))) ≫ + (B ◁ modTensorAssocMid A M N P) = + (α_ (B ⊗ M.X) (B ⊗ N.X) (B ⊗ P.X)).hom ≫ + ((B ⊗ M.X) ◁ ((tensorμ B N.X B P.X ≫ + (μ[B] ▷ (N.X ⊗ P.X))) ≫ (B ◁ modTensorπ A N P))) ≫ + (tensorμ B M.X B (modTensor A N P) ≫ + (μ[B] ▷ (M.X ⊗ modTensor A N P))) ≫ + (B ◁ modTensorπ A M (modTensorMod A N P)) := by + have hcov : (modTensorπ A M N ▷ P.X) ≫ + modTensorAssocMid A M N P = + (α_ M.X N.X P.X).hom ≫ (M.X ◁ modTensorπ A N P) ≫ + modTensorπ A M (modTensorMod A N P) := by + rw [whiskerRight_modTensorπ_assocMid, modTensorAssocCover] + conv_lhs => + rw [MonoidalCategory.comp_whiskerRight] + simp only [Category.assoc] + rw [reassoc_of% + (baseMul_natural_left B (modTensorπ A M N) P.X)] + erw [← MonoidalCategory.whiskerLeft_comp, hcov, + MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp] + rw [reassoc_of% (baseAssoc B M.X N.X P.X)] + conv_rhs => + rw [MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rw [reassoc_of% + (baseMul_natural_right B M.X (modTensorπ A N P))] + +section ExtRR + +/-- Whiskering the module-tensor coequalizer twice on the right +yields a colimit cofork. -/ +noncomputable def modTensorWhiskerRRIsColimit + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) + (Y W : D) : + IsColimit (Cofork.ofπ ((modTensorπ A M N ▷ Y) ▷ W) + (by rw [← MonoidalCategory.comp_whiskerRight, + ← MonoidalCategory.comp_whiskerRight, + modTensor_condition, + MonoidalCategory.comp_whiskerRight, + MonoidalCategory.comp_whiskerRight]) : + Cofork ((modTensorLegM A M N ▷ Y) ▷ W) + ((modTensorLegN A M N ▷ Y) ▷ W)) := + isColimitOfHasCoequalizerOfPreservesColimit + (tensorRight Y ⋙ tensorRight W) _ _ + +/-- Morphisms out of a twice right-whiskered tensor product of +modules are determined by the doubly whiskered projection. -/ +lemma modTensor_whiskerRR_hom_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) + (Y W : D) {Z : D} + {k l : (modTensor A M N ⊗ Y) ⊗ W ⟶ Z} + (h : ((modTensorπ A M N ▷ Y) ▷ W) ≫ k = + ((modTensorπ A M N ▷ Y) ▷ W) ≫ l) : k = l := + Cofork.IsColimit.hom_ext + (modTensorWhiskerRRIsColimit A M N Y W) h + +end ExtRR + +section AssocMidNatural + +/-- The half-descended associator is natural in the third +slot. -/ +theorem modTensorAssocMid_natural_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (P : Mod D A) + (M : Mod D A) + {N N' : Mod D A} (g : N ⟶ N') : + modTensorAssocMid A P M N ≫ + modTensorMap A (𝟙 P) (modTensorMapMod A (𝟙 M) g) = + ((modTensorMod A P M).X ◁ g.hom) ≫ + modTensorAssocMid A P M N' := by + have hg : modTensorπ A M N ≫ modTensorMap A (𝟙 M) g = + (M.X ◁ g.hom) ≫ modTensorπ A M N' := by + rw [modTensorπ_map, Mod.id_hom', + MonoidalCategory.id_tensorHom] + have hP : modTensorπ A P (modTensorMod A M N) ≫ + modTensorMap A (𝟙 P) (modTensorMapMod A (𝟙 M) g) = + (P.X ◁ modTensorMap A (𝟙 M) g) ≫ + modTensorπ A P (modTensorMod A M N') := by + rw [modTensorπ_map, Mod.id_hom', + MonoidalCategory.id_tensorHom] + rfl + have key : ∀ {Z : D} + (h : modTensor A P (modTensorMod A M N) ⟶ Z), + (modTensorπ A P M ▷ N.X) ≫ + modTensorAssocMid A P M N ≫ h = + (α_ P.X M.X N.X).hom ≫ (P.X ◁ modTensorπ A M N) ≫ + modTensorπ A P (modTensorMod A M N) ≫ h := by + intro Z h + rw [← Category.assoc, whiskerRight_modTensorπ_assocMid, + modTensorAssocCover] + repeat' erw [Category.assoc] + have key' : (modTensorπ A P M ▷ N'.X) ≫ + modTensorAssocMid A P M N' = + (α_ P.X M.X N'.X).hom ≫ (P.X ◁ modTensorπ A M N') ≫ + modTensorπ A P (modTensorMod A M N') := by + rw [whiskerRight_modTensorπ_assocMid, modTensorAssocCover] + apply modTensor_whiskerR_hom_ext A P M N.X + refine Eq.trans (key _) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ hP)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + ((MonoidalCategory.whiskerLeft_comp P.X _ _).symm.trans + (congrArg (fun t => P.X ◁ t) hg)) _)) ?_ + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (whisker_exchange (modTensorπ A P M) g.hom).symm _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ key') ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (associator_naturality_right P.X M.X g.hom) _) ?_ + simp only [Category.assoc, + MonoidalCategory.whiskerLeft_comp] + repeat' erw [Category.assoc] + +/-- The half-descended associator is natural in the second +slot. -/ +theorem modTensorAssocMid_natural_mid + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (P : Mod D A) + {M M' : Mod D A} (f : M ⟶ M') (N : Mod D A) : + modTensorAssocMid A P M N ≫ + modTensorMap A (𝟙 P) (modTensorMapMod A f (𝟙 N)) = + (modTensorMap A (𝟙 P) f ▷ N.X) ≫ + modTensorAssocMid A P M' N := by + have hf : modTensorπ A M N ≫ modTensorMap A f (𝟙 N) = + (f.hom ▷ N.X) ≫ modTensorπ A M' N := by + rw [modTensorπ_map, Mod.id_hom', + MonoidalCategory.tensorHom_id] + have hP : modTensorπ A P (modTensorMod A M N) ≫ + modTensorMap A (𝟙 P) (modTensorMapMod A f (𝟙 N)) = + (P.X ◁ modTensorMap A f (𝟙 N)) ≫ + modTensorπ A P (modTensorMod A M' N) := by + rw [modTensorπ_map, Mod.id_hom', + MonoidalCategory.id_tensorHom] + rfl + have hQ : modTensorπ A P M ≫ modTensorMap A (𝟙 P) f = + (P.X ◁ f.hom) ≫ modTensorπ A P M' := by + rw [modTensorπ_map, Mod.id_hom', + MonoidalCategory.id_tensorHom] + have key : ∀ {Z : D} + (h : modTensor A P (modTensorMod A M N) ⟶ Z), + (modTensorπ A P M ▷ N.X) ≫ + modTensorAssocMid A P M N ≫ h = + (α_ P.X M.X N.X).hom ≫ (P.X ◁ modTensorπ A M N) ≫ + modTensorπ A P (modTensorMod A M N) ≫ h := by + intro Z h + rw [← Category.assoc, whiskerRight_modTensorπ_assocMid, + modTensorAssocCover] + repeat' erw [Category.assoc] + have key' : (modTensorπ A P M' ▷ N.X) ≫ + modTensorAssocMid A P M' N = + (α_ P.X M'.X N.X).hom ≫ (P.X ◁ modTensorπ A M' N) ≫ + modTensorπ A P (modTensorMod A M' N) := by + rw [whiskerRight_modTensorπ_assocMid, modTensorAssocCover] + apply modTensor_whiskerR_hom_ext A P M N.X + refine Eq.trans (key _) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ hP)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + ((MonoidalCategory.whiskerLeft_comp P.X _ _).symm.trans + (congrArg (fun t => P.X ◁ t) hf)) _)) ?_ + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + ((MonoidalCategory.comp_whiskerRight _ _ _).symm.trans + (congrArg (fun t => t ▷ N.X) hQ)) _) ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.comp_whiskerRight _ _ _) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ key') ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (associator_naturality_middle P.X f.hom N.X) _) ?_ + simp only [Category.assoc, + MonoidalCategory.whiskerLeft_comp] + repeat' erw [Category.assoc] + +end AssocMidNatural + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeDatum.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeDatum.lean new file mode 100644 index 0000000000..ea5e4cfea0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeDatum.lean @@ -0,0 +1,172 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeLinear +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle + +/-! +# The base change of a duality datum + +The pairing and copairing of a duality datum base-change to a +duality datum over the new base: the projection formula, the +functorial maps and the unit collapses are all linear, so the +composites defining the base-changed pairing and copairing are +linear too. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The base-changed pairing is linear.** -/ +theorem baseChangePair_linear + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + modTensorAct B (baseChangeMod φ M') + (baseChangeMod φ M) ≫ baseChangePair A B φ d = + (B ◁ baseChangePair A B φ d) ≫ μ[B] := by + change modTensorAct B (baseChangeMod φ M') + (baseChangeMod φ M) ≫ + ((projFormula A B φ M' M).hom ≫ + modTensorMap A (𝟙 (restrictRegular φ)) (d.pairMod) ≫ + (modTensorUnitRight A (restrictRegular φ)).hom) = + (B ◁ ((projFormula A B φ M' M).hom ≫ + modTensorMap A (𝟙 (restrictRegular φ)) (d.pairMod) ≫ + (modTensorUnitRight A (restrictRegular φ)).hom)) ≫ μ[B] + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (projFormula_linear A B φ M' M) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + (baseChangeAct_modTensorMap A B φ (d.pairMod)) _)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (baseChangeAct_unitRight A B φ))) ?_ + refine Eq.symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine whisker_eq _ ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _) _) ?_ + exact Category.assoc _ _ _ + +/-- **The base-changed copairing is linear.** -/ +theorem baseChangeCopair_linear + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + μ[B] ≫ baseChangeCopair A B φ d = + (B ◁ baseChangeCopair A B φ d) ≫ + modTensorAct B (baseChangeMod φ M) + (baseChangeMod φ M') := by + have hu : μ[B] ≫ + (modTensorUnitRight A (restrictRegular φ)).inv = + (B ◁ (modTensorUnitRight A (restrictRegular φ)).inv) ≫ + baseChangeAct φ (regularMod A) := by + refine act_inv_of_act_hom B + (modTensorUnitRight A (restrictRegular φ)) ?_ + exact baseChangeAct_unitRight A B φ + have hp : baseChangeAct φ (modTensorMod A M M') ≫ + (projFormula A B φ M M').inv = + (B ◁ (projFormula A B φ M M').inv) ≫ + modTensorAct B (baseChangeMod φ M) + (baseChangeMod φ M') := by + refine act_inv_of_act_hom B (projFormula A B φ M M') ?_ + exact projFormula_linear A B φ M M' + change μ[B] ≫ + ((modTensorUnitRight A (restrictRegular φ)).inv ≫ + modTensorMap A (𝟙 (restrictRegular φ)) + (d.copairMod) ≫ + (projFormula A B φ M M').inv) = + (B ◁ ((modTensorUnitRight A (restrictRegular φ)).inv ≫ + modTensorMap A (𝟙 (restrictRegular φ)) + (d.copairMod) ≫ + (projFormula A B φ M M').inv)) ≫ + modTensorAct B (baseChangeMod φ M) (baseChangeMod φ M') + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker hu _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + (baseChangeAct_modTensorMap A B φ (d.copairMod)) _)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ hp)) ?_ + refine Eq.symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine whisker_eq _ ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _) _) ?_ + exact Category.assoc _ _ _ + +/-- **The base change of a duality datum.** -/ +noncomputable def baseChangeDatum + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + ModDualityDatum B (baseChangeMod φ M) + (baseChangeMod φ M') where + pair := baseChangePair A B φ d + copair := baseChangeCopair A B φ d + pair_linear := baseChangePair_linear A B φ d + copair_linear := baseChangeCopair_linear A B φ d + +section Unit + +/-- **The unit of the base-change structure**: the base change of +the regular module is the regular module over the new base. -/ +noncomputable def baseChangeUnitIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] : + baseChangeMod φ (regularMod A) ≅ regularMod B where + hom := Mod.Hom.mk' + (modTensorUnitRight A (restrictRegular φ)).hom (by + exact baseChangeAct_unitRight A B φ) + inv := Mod.Hom.mk' + (modTensorUnitRight A (restrictRegular φ)).inv (by + exact act_inv_of_act_hom B + (modTensorUnitRight A (restrictRegular φ)) + (baseChangeAct_unitRight A B φ)) + hom_inv_id := by + apply Mod.Hom.ext + exact (modTensorUnitRight A (restrictRegular φ)).hom_inv_id + inv_hom_id := by + apply Mod.Hom.ext + exact (modTensorUnitRight A (restrictRegular φ)).inv_hom_id + +end Unit + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeFree.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeFree.lean new file mode 100644 index 0000000000..aa70d63a91 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeFree.lean @@ -0,0 +1,358 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor + +/-! +# Base change of a free module + +Base change along a morphism of commutative monoid objects sends +the free module on an object to the free module over the new base: +`B ⊗[A] (A ⊗ V) ≅ B ⊗ V` as `B`-modules. + +* `baseChangeFreeHom`/`baseChangeFreeInv`: the two carrier maps, + descending multiplication through `φ` and inserting the unit of + `A` respectively. +* `baseChangeFreeIso`: the isomorphism `baseChangeMod φ (freeMod + A V) ≅ freeMod B V` in the category of `B`-modules. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- Multiplying through `φ` twice is multiplying through `φ` once +after multiplying in `A`. -/ +lemma pushMul_pushMul + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (B : D) + [MonObj B] (φ : A ⟶ B) [IsMonHom φ] : + ((B ◁ φ ≫ μ[B]) ▷ A) ≫ (B ◁ φ ≫ μ[B]) = + (α_ B A A).hom ≫ B ◁ (μ[A] ≫ φ) ≫ μ[B] := by + rw [IsMonHom.mul_hom φ, tensorHom_def] + simp only [comp_whiskerRight, MonoidalCategory.whiskerLeft_comp, + Category.assoc] + rw [← whisker_exchange_assoc, MonObj.mul_assoc, + associator_naturality_right_assoc, + associator_naturality_middle_assoc] + +/-- Multiplying in `B` before pushing through `φ` is multiplying +in `B` after. -/ +lemma mul_pushMul + [Category.{v} D] [MonoidalCategory D] (A : D) (B : D) [MonObj B] + (φ : A ⟶ B) : + (μ[B] ▷ A) ≫ (B ◁ φ ≫ μ[B]) = + (α_ B B A).hom ≫ B ◁ (B ◁ φ ≫ μ[B]) ≫ μ[B] := by + rw [← whisker_exchange_assoc, MonObj.mul_assoc, + associator_naturality_right_assoc] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + +/-- The first module-tensor leg of the base change of a free +module, at carrier atoms. -/ +lemma legM_restrictRegular_freeMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + (V : D) : + modTensorLegM A (restrictRegular φ) (freeMod A V) = + (B ◁ φ ≫ μ[B]) ▷ (A ⊗ V) := + congrArg (fun t : B ⊗ A ⟶ B => t ▷ (A ⊗ V)) + (actRight_restrictRegular φ) + +/-- The comparison map coequalizes the two module-tensor legs, +stated at carrier atoms. -/ +lemma baseChangeFree_condition_atoms + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (B : D) + [MonObj B] (φ : A ⟶ B) [IsMonHom φ] + (V : D) : + ((B ◁ φ ≫ μ[B]) ▷ (A ⊗ V)) ≫ + ((α_ B A V).inv ≫ (B ◁ φ ≫ μ[B]) ▷ V) = + ((α_ B A (A ⊗ V)).hom ≫ + B ◁ ((α_ A A V).inv ≫ μ[A] ▷ V)) ≫ + ((α_ B A V).inv ≫ (B ◁ φ ≫ μ[B]) ▷ V) := by + have hstruct : + (α_ B A (A ⊗ V)).hom ≫ B ◁ (α_ A A V).inv ≫ + (α_ B (A ⊗ A) V).inv = + (α_ (B ⊗ A) A V).inv ≫ (α_ B A A).hom ▷ V := by + monoidal + rw [associator_inv_naturality_left_assoc, ← comp_whiskerRight, + pushMul_pushMul] + simp only [MonoidalCategory.whiskerLeft_comp, comp_whiskerRight, + Category.assoc] + rw [associator_inv_naturality_middle_assoc, reassoc_of% hstruct] + +/-- The comparison map coequalizes the two module-tensor legs. -/ +lemma baseChangeFree_condition + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + (V : D) : + modTensorLegM A (restrictRegular φ) (freeMod A V) ≫ + ((α_ B A V).inv ≫ (B ◁ φ ≫ μ[B]) ▷ V) = + modTensorLegN A (restrictRegular φ) (freeMod A V) ≫ + ((α_ B A V).inv ≫ (B ◁ φ ≫ μ[B]) ▷ V) := + (congrArg + (fun t => t ≫ ((α_ B A V).inv ≫ (B ◁ φ ≫ μ[B]) ▷ V)) + (legM_restrictRegular_freeMod A B φ V)).trans + (baseChangeFree_condition_atoms A B φ V) + +/-- The comparison map from the base change of a free module to +the free module over the new base. -/ +noncomputable def baseChangeFreeHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (B : D) [MonObj B] + [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + (V : D) : + baseChange φ (freeMod A V) ⟶ B ⊗ V := + modTensorDesc A (restrictRegular φ) (freeMod A V) + ((α_ B A V).inv ≫ (B ◁ φ ≫ μ[B]) ▷ V) + (baseChangeFree_condition A B φ V) + +/-- Defining equation of the comparison map. -/ +@[reassoc] +lemma modTensorπ_baseChangeFreeHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (B : D) [MonObj B] + [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + (V : D) : + modTensorπ A (restrictRegular φ) (freeMod A V) ≫ + baseChangeFreeHom A B φ V = + (α_ B A V).inv ≫ (B ◁ φ ≫ μ[B]) ▷ V := + modTensorπ_desc A (restrictRegular φ) (freeMod A V) _ _ + +/-- The inverse comparison map: insert the unit of `A`. -/ +noncomputable def baseChangeFreeInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (B : D) [MonObj B] (φ : A ⟶ B) + [IsMonHom φ] + (V : D) : + B ⊗ V ⟶ baseChange φ (freeMod A V) := + B ◁ ((λ_ V).inv ≫ η[A] ▷ V) ≫ + modTensorπ A (restrictRegular φ) (freeMod A V) + +/-- The balance relation of the base-change projection on a free +module, at carrier atoms. -/ +@[reassoc] +lemma baseChangeFree_balance + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (B : D) [MonObj B] + [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + (V : D) : + ((B ◁ φ ≫ μ[B]) ▷ (A ⊗ V)) ≫ + modTensorπ A (restrictRegular φ) (freeMod A V) = + ((α_ B A (A ⊗ V)).hom ≫ + B ◁ ((α_ A A V).inv ≫ μ[A] ▷ V)) ≫ + modTensorπ A (restrictRegular φ) (freeMod A V) := + (congrArg + (fun t => + t ≫ modTensorπ A (restrictRegular φ) (freeMod A V)) + (legM_restrictRegular_freeMod A B φ V)).symm.trans + (modTensor_condition A (restrictRegular φ) (freeMod A V)) + +/-- Multiplying out and reinserting the unit of `A` returns the +projection: the retract identity behind `hom ≫ inv = 𝟙`. -/ +lemma baseChangeFree_retract + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (B : D) [MonObj B] + [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + (V : D) : + ((α_ B A V).inv ≫ (B ◁ φ ≫ μ[B]) ▷ V) ≫ + (B ◁ ((λ_ V).inv ≫ η[A] ▷ V) ≫ + modTensorπ A (restrictRegular φ) (freeMod A V)) = + modTensorπ A (restrictRegular φ) (freeMod A V) := by + simp only [Category.assoc] + erw [← whisker_exchange_assoc, baseChangeFree_balance] + repeat' erw [Category.assoc] + erw [associator_naturality_right_assoc, Iso.inv_hom_id_assoc, + ← whiskerLeft_comp_assoc, whiskerLeft_one_mul, + MonoidalCategory.whiskerLeft_id, Category.id_comp] + +/-- The two comparison maps compose to the identity of the base +change. -/ +lemma baseChangeFree_hom_inv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (B : D) [MonObj B] + [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + (V : D) : + baseChangeFreeHom A B φ V ≫ baseChangeFreeInv A B φ V = + 𝟙 (baseChange φ (freeMod A V)) := by + apply modTensor_hom_ext A (restrictRegular φ) (freeMod A V) + exact (Category.assoc _ _ _).symm.trans + (((congrArg (fun t => t ≫ baseChangeFreeInv A B φ V) + (modTensorπ_baseChangeFreeHom A B φ V)).trans + (baseChangeFree_retract A B φ V)).trans + (Category.comp_id _).symm) + +/-- Inserting the unit of `A` and multiplying out through `φ` is +the identity of `B ⊗ V`. -/ +lemma baseChangeFree_section_atoms + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (B : D) + [MonObj B] (φ : A ⟶ B) [IsMonHom φ] + (V : D) : + B ◁ ((λ_ V).inv ≫ η[A] ▷ V) ≫ + ((α_ B A V).inv ≫ (B ◁ φ ≫ μ[B]) ▷ V) = + 𝟙 (B ⊗ V) := by + rw [MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rw [associator_inv_naturality_middle_assoc, + ← comp_whiskerRight, ← whiskerLeft_comp_assoc, + IsMonHom.one_hom φ, MonObj.mul_one] + monoidal + +/-- The two comparison maps compose to the identity of the free +module over the new base. -/ +lemma baseChangeFree_inv_hom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (B : D) [MonObj B] + [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + (V : D) : + baseChangeFreeInv A B φ V ≫ baseChangeFreeHom A B φ V = + 𝟙 (B ⊗ V) := + (Category.assoc _ _ _).trans + ((congrArg (fun t => B ◁ ((λ_ V).inv ≫ η[A] ▷ V) ≫ t) + (modTensorπ_baseChangeFreeHom A B φ V)).trans + (baseChangeFree_section_atoms A B φ V)) + +/-- The comparison map intertwines the two `B`-actions, at carrier +atoms. -/ +lemma baseChangeFree_linear_atoms + [Category.{v} D] [MonoidalCategory D] (A : D) (B : D) [MonObj B] + (φ : A ⟶ B) + (V : D) : + ((α_ B B (A ⊗ V)).inv ≫ μ[B] ▷ (A ⊗ V)) ≫ + ((α_ B A V).inv ≫ (B ◁ φ ≫ μ[B]) ▷ V) = + B ◁ ((α_ B A V).inv ≫ (B ◁ φ ≫ μ[B]) ▷ V) ≫ + ((α_ B B V).inv ≫ μ[B] ▷ V) := by + have hstruct : + (α_ B B (A ⊗ V)).inv ≫ (α_ (B ⊗ B) A V).inv ≫ + (α_ B B A).hom ▷ V = + B ◁ (α_ B A V).inv ≫ (α_ B (B ⊗ A) V).inv := by + monoidal + simp only [Category.assoc] + rw [associator_inv_naturality_left_assoc, ← comp_whiskerRight, + mul_pushMul] + simp only [MonoidalCategory.whiskerLeft_comp, comp_whiskerRight, + Category.assoc] + rw [associator_inv_naturality_middle_assoc, + associator_inv_naturality_middle_assoc, reassoc_of% hstruct] + +/-- Defining equation of the `B`-action on the base change of a +free module, at carrier atoms. -/ +lemma whiskerLeft_π_baseChangeAct_free + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (B : D) [MonObj B] + [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (V : D) : + B ◁ modTensorπ A (restrictRegular φ) (freeMod A V) ≫ + baseChangeAct φ (freeMod A V) = + ((α_ B B (A ⊗ V)).inv ≫ μ[B] ▷ (A ⊗ V)) ≫ + modTensorπ A (restrictRegular φ) (freeMod A V) := + whiskerLeft_modTensorπ_baseChangeAct φ (freeMod A V) + +/-- The comparison map is `B`-linear. -/ +@[reassoc] +lemma baseChangeAct_baseChangeFreeHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (B : D) [MonObj B] + [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (V : D) : + baseChangeAct φ (freeMod A V) ≫ baseChangeFreeHom A B φ V = + B ◁ baseChangeFreeHom A B φ V ≫ + ((α_ B B V).inv ≫ μ[B] ▷ V) := by + apply modTensor_whisker_hom_ext A (restrictRegular φ) + (freeMod A V) B + have h1 : + B ◁ modTensorπ A (restrictRegular φ) (freeMod A V) ≫ + (baseChangeAct φ (freeMod A V) ≫ + baseChangeFreeHom A B φ V) = + ((α_ B B (A ⊗ V)).inv ≫ μ[B] ▷ (A ⊗ V)) ≫ + (modTensorπ A (restrictRegular φ) (freeMod A V) ≫ + baseChangeFreeHom A B φ V) := + (Category.assoc _ _ _).symm.trans + ((congrArg (fun t => t ≫ baseChangeFreeHom A B φ V) + (whiskerLeft_π_baseChangeAct_free A B φ V)).trans + (Category.assoc _ _ _)) + have h2 : + ((α_ B B (A ⊗ V)).inv ≫ μ[B] ▷ (A ⊗ V)) ≫ + (modTensorπ A (restrictRegular φ) (freeMod A V) ≫ + baseChangeFreeHom A B φ V) = + ((α_ B B (A ⊗ V)).inv ≫ μ[B] ▷ (A ⊗ V)) ≫ + ((α_ B A V).inv ≫ (B ◁ φ ≫ μ[B]) ▷ V) := + congrArg + (fun t => ((α_ B B (A ⊗ V)).inv ≫ μ[B] ▷ (A ⊗ V)) ≫ t) + (modTensorπ_baseChangeFreeHom A B φ V) + have h4 : + B ◁ modTensorπ A (restrictRegular φ) (freeMod A V) ≫ + (B ◁ baseChangeFreeHom A B φ V ≫ + ((α_ B B V).inv ≫ μ[B] ▷ V)) = + B ◁ (modTensorπ A (restrictRegular φ) (freeMod A V) ≫ + baseChangeFreeHom A B φ V) ≫ + ((α_ B B V).inv ≫ μ[B] ▷ V) := + (Category.assoc _ _ _).symm.trans + (congrArg (fun t => t ≫ ((α_ B B V).inv ≫ μ[B] ▷ V)) + (MonoidalCategory.whiskerLeft_comp B + (modTensorπ A (restrictRegular φ) (freeMod A V)) + (baseChangeFreeHom A B φ V)).symm) + have h5 : + B ◁ (modTensorπ A (restrictRegular φ) (freeMod A V) ≫ + baseChangeFreeHom A B φ V) ≫ + ((α_ B B V).inv ≫ μ[B] ▷ V) = + B ◁ ((α_ B A V).inv ≫ (B ◁ φ ≫ μ[B]) ▷ V) ≫ + ((α_ B B V).inv ≫ μ[B] ▷ V) := + congrArg (fun t => B ◁ t ≫ ((α_ B B V).inv ≫ μ[B] ▷ V)) + (modTensorπ_baseChangeFreeHom A B φ V) + exact ((h1.trans h2).trans + (baseChangeFree_linear_atoms A B φ V)).trans + ((h4.trans h5).symm) + +/-- The inverse comparison map is `B`-linear. -/ +lemma freeAct_baseChangeFreeInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (B : D) [MonObj B] + [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (V : D) : + ((α_ B B V).inv ≫ μ[B] ▷ V) ≫ baseChangeFreeInv A B φ V = + B ◁ baseChangeFreeInv A B φ V ≫ + baseChangeAct φ (freeMod A V) := by + conv_rhs => + rw [← Category.comp_id (baseChangeAct φ (freeMod A V)), + ← baseChangeFree_hom_inv A B φ V, + baseChangeAct_baseChangeFreeHom_assoc A B φ V, + ← whiskerLeft_comp_assoc, baseChangeFree_inv_hom A B φ V, + MonoidalCategory.whiskerLeft_id, Category.id_comp] + simp only [Category.assoc] + +/-- **Base change of a free module**: the base change along `φ` of +the free `A`-module on `V` is the free `B`-module on `V`, as an +isomorphism of `B`-modules. -/ +noncomputable def baseChangeFreeIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (B : D) [MonObj B] + [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (V : D) : + baseChangeMod φ (freeMod A V) ≅ freeMod B V where + hom := Mod.Hom.mk' (baseChangeFreeHom A B φ V) + (by exact baseChangeAct_baseChangeFreeHom A B φ V) + inv := Mod.Hom.mk' (baseChangeFreeInv A B φ V) + (by exact freeAct_baseChangeFreeInv A B φ V) + hom_inv_id := by + apply Mod.hom_ext + exact baseChangeFree_hom_inv A B φ V + inv_hom_id := by + apply Mod.hom_ext + exact baseChangeFree_inv_hom A B φ V + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeLinear.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeLinear.lean new file mode 100644 index 0000000000..b5b8926d22 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeLinear.lean @@ -0,0 +1,602 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeBiprod + +/-! +# Linearity of the base-changed pairing and copairing + +The base-changed pairing and copairing of a duality datum are +linear over the new base: each factor of the defining composites +intertwines the descended actions, and the two linearity laws +follow by chaining the factors. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +section Glue + +/-- A composite of `B`-linear morphisms is `B`-linear. -/ +private theorem comp_linear [Category.{v} D] [MonoidalCategory D] (B : D) + {X Y Z : D} + {aX : B ⊗ X ⟶ X} {aY : B ⊗ Y ⟶ Y} {aZ : B ⊗ Z ⟶ Z} + {f : X ⟶ Y} {g : Y ⟶ Z} + (hf : aX ≫ f = (B ◁ f) ≫ aY) + (hg : aY ≫ g = (B ◁ g) ≫ aZ) : + aX ≫ (f ≫ g) = (B ◁ (f ≫ g)) ≫ aZ := + calc aX ≫ f ≫ g = (aX ≫ f) ≫ g := (Category.assoc _ _ _).symm + _ = ((B ◁ f) ≫ aY) ≫ g := eq_whisker hf g + _ = (B ◁ f) ≫ aY ≫ g := Category.assoc _ _ _ + _ = (B ◁ f) ≫ (B ◁ g) ≫ aZ := whisker_eq _ hg + _ = ((B ◁ f) ≫ (B ◁ g)) ≫ aZ := (Category.assoc _ _ _).symm + _ = (B ◁ (f ≫ g)) ≫ aZ := + eq_whisker (MonoidalCategory.whiskerLeft_comp B f g).symm _ + +/-- The inverse of a `B`-linear isomorphism is `B`-linear. -/ +private theorem inv_linear_of_hom_linear + [Category.{v} D] [MonoidalCategory D] (B : D) + {X Y : D} (e : X ≅ Y) + {aX : B ⊗ X ⟶ X} {aY : B ⊗ Y ⟶ Y} + (h : aX ≫ e.hom = (B ◁ e.hom) ≫ aY) : + aY ≫ e.inv = (B ◁ e.inv) ≫ aX := by + rw [← cancel_mono e.hom, Category.assoc, Category.assoc, + e.inv_hom_id, Category.comp_id, h, ← Category.assoc, + ← MonoidalCategory.whiskerLeft_comp, e.inv_hom_id, + MonoidalCategory.whiskerLeft_id, Category.id_comp] + +end Glue + +section Ext + +/-- Whiskering the module-tensor coequalizer by `tensorLeft P` +and then by `tensorRight W` yields a colimit cofork. -/ +noncomputable def modTensorWhiskerLRIsColimit + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) + (P W : D) : + IsColimit (Cofork.ofπ ((P ◁ modTensorπ A M N) ▷ W) + (by rw [← MonoidalCategory.comp_whiskerRight, + ← MonoidalCategory.whiskerLeft_comp, + modTensor_condition, + MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.comp_whiskerRight]) : + Cofork ((P ◁ modTensorLegM A M N) ▷ W) + ((P ◁ modTensorLegN A M N) ▷ W)) := + isColimitOfHasCoequalizerOfPreservesColimit + (tensorLeft P ⋙ tensorRight W) _ _ + +/-- Morphisms out of a left-then-right whiskered tensor product +of modules are determined by the doubly whiskered projection. -/ +lemma modTensor_whiskerLR_hom_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) + (P W : D) {Z : D} + {k l : (P ⊗ modTensor A M N) ⊗ W ⟶ Z} + (h : ((P ◁ modTensorπ A M N) ▷ W) ≫ k = + ((P ◁ modTensorπ A M N) ▷ W) ≫ l) : k = l := + Cofork.IsColimit.hom_ext + (modTensorWhiskerLRIsColimit A M N P W) h + +end Ext + +section Collapse + +/-- The `B`-action on a `B`-module commutes with the braided +right action through the base morphism. -/ +theorem restrictAct_compat + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) (P : Mod D B) : + B ◁ ((P.X ◁ φ) ≫ actRight B P.X) ≫ actLeft B P.X = + (α_ B P.X A).inv ≫ actLeft B P.X ▷ A ≫ + ((P.X ◁ φ) ≫ actRight B P.X) := by + rw [MonoidalCategory.whiskerLeft_comp, Category.assoc, + actLeft_actRight B P.X, + associator_inv_naturality_right_assoc, + whisker_exchange_assoc] + +/-- **The descended `B`-action on the collapsed tensor**: the +`B`-action of the module descends through the coequalizer of the +restricted-module tensor. -/ +noncomputable def collapseAct + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (P : Mod D B) (N : Mod D A) : + B ⊗ modTensor A (restrictMod A B φ P) N ⟶ + modTensor A (restrictMod A B φ P) N := + modTensorDescAct A (restrictMod A B φ P) N B (actLeft B P.X) + (by + rw [actRight_restrictMod] + exact restrictAct_compat A B φ P) + +/-- Defining equation of the descended `B`-action, in the retyped +spelling. -/ +theorem whiskerLeft_restrictπ_collapseAct + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (P : Mod D B) (N : Mod D A) : + B ◁ restrictπ A B φ P N ≫ collapseAct A B φ P N = + ((α_ B P.X N.X).inv ≫ actLeft B P.X ▷ N.X) ≫ + restrictπ A B φ P N := by + exact whiskerLeft_modTensorπ_descAct A (restrictMod A B φ P) N + B (actLeft B P.X) _ + +/-- The half-descended collapse intertwines the module action +with the descended action. -/ +theorem collapseMid_linear + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (P : Mod D B) (N : Mod D A) : + (actLeft B P.X ▷ baseChange φ N) ≫ collapseMid A B φ P N = + (α_ B P.X (baseChange φ N)).hom ≫ + (B ◁ collapseMid A B φ P N) ≫ collapseAct A B φ P N := by + apply modTensor_whisker_hom_ext A (restrictRegular φ) N + (B ⊗ P.X) + have hL : ((B ⊗ P.X) ◁ modTensorπ A (restrictRegular φ) N) ≫ + ((actLeft B P.X ▷ baseChange φ N) ≫ + collapseMid A B φ P N) = + (actLeft B P.X ▷ (B ⊗ N.X)) ≫ collapseCover A B φ P N := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (whisker_exchange + (actLeft B P.X) (modTensorπ A (restrictRegular φ) N)) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (whiskerLeft_collapseMid A B φ P N) + have hR : ((B ⊗ P.X) ◁ modTensorπ A (restrictRegular φ) N) ≫ + ((α_ B P.X (baseChange φ N)).hom ≫ + (B ◁ collapseMid A B φ P N) ≫ collapseAct A B φ P N) = + (α_ B P.X (B ⊗ N.X)).hom ≫ + (B ◁ collapseCover A B φ P N) ≫ + collapseAct A B φ P N := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (associator_naturality_right + B P.X (modTensorπ A (restrictRegular φ) N)) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine whisker_eq _ ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + exact eq_whisker (congrArg (fun t => B ◁ t) + (whiskerLeft_collapseMid A B φ P N)) _ + refine hL.trans (Eq.trans ?_ hR.symm) + rw [collapseCover] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [whiskerLeft_restrictπ_collapseAct] + simp only [Category.assoc] + rw [associator_inv_naturality_middle_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, + actLeft_actRight B P.X] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [associator_inv_naturality_left_assoc] + rw [reassoc_of% (show (α_ B P.X (B ⊗ N.X)).hom ≫ + (B ◁ (α_ P.X B N.X).inv) ≫ (α_ B (P.X ⊗ B) N.X).inv ≫ + ((α_ B P.X B).inv ▷ N.X) = (α_ (B ⊗ P.X) B N.X).inv + from by monoidal)] + +end Collapse + +section Hom + +/-- **The collapse is linear over the new base**: it intertwines +the module action with the descended action. -/ +theorem collapseHom_linear + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (P : Mod D B) (N : Mod D A) : + modTensorAct B P (baseChangeMod φ N) ≫ + collapseHom A B φ P N = + (B ◁ collapseHom A B φ P N) ≫ collapseAct A B φ P N := by + apply modTensor_whisker_hom_ext B P (baseChangeMod φ N) B + have hL : (B ◁ bcπ A B φ P N) ≫ + modTensorAct B P (baseChangeMod φ N) ≫ + collapseHom A B φ P N = + ((α_ B P.X (baseChange φ N)).inv ≫ + (actLeft B P.X ▷ baseChange φ N)) ≫ + collapseMid A B φ P N := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (whiskerLeft_modTensorπ_act B P + (baseChangeMod φ N)) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (modTensorπ_collapseHom A B φ P N) + have hR : (B ◁ bcπ A B φ P N) ≫ + (B ◁ collapseHom A B φ P N) ≫ collapseAct A B φ P N = + (B ◁ collapseMid A B φ P N) ≫ collapseAct A B φ P N := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + exact eq_whisker (congrArg (fun t => B ◁ t) + (modTensorπ_collapseHom A B φ P N)) _ + refine hL.trans (Eq.trans ?_ hR.symm) + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (collapseMid_linear A B φ P N)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (Iso.inv_hom_id _) _) ?_ + exact Category.id_comp _ + +end Hom + +section UnitLeg + +/-- The right unit collapse of the induced regular module is +linear over the new base. -/ +theorem baseChangeAct_unitRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] : + baseChangeAct φ (regularMod A) ≫ + (modTensorUnitRight A (restrictRegular φ)).hom = + (B ◁ (modTensorUnitRight A (restrictRegular φ)).hom) ≫ + μ[B] := by + apply modTensor_whisker_hom_ext A (restrictRegular φ) + (regularMod A) B + have hπ : modTensorπ A (restrictRegular φ) (regularMod A) ≫ + (modTensorUnitRight A (restrictRegular φ)).hom = + (B ◁ φ) ≫ μ[B] := by + refine Eq.trans (modTensorπ_desc A (restrictRegular φ) + (regularMod A) _ _) ?_ + exact actRight_restrictRegular φ + have hL : (B ◁ modTensorπ A (restrictRegular φ) + (regularMod A)) ≫ baseChangeAct φ (regularMod A) ≫ + (modTensorUnitRight A (restrictRegular φ)).hom = + ((α_ B B A).inv ≫ (μ[B] ▷ A)) ≫ ((B ◁ φ) ≫ μ[B]) := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (whiskerLeft_modTensorπ_baseChangeAct φ + (regularMod A)) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ hπ + have hR : (B ◁ modTensorπ A (restrictRegular φ) + (regularMod A)) ≫ + (B ◁ (modTensorUnitRight A (restrictRegular φ)).hom) ≫ + μ[B] = + (B ◁ ((B ◁ φ) ≫ μ[B])) ≫ μ[B] := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + exact eq_whisker (congrArg (fun t => B ◁ t) hπ) _ + refine hL.trans (Eq.trans ?_ hR.symm) + simp only [MonoidalCategory.whiskerLeft_comp, + Category.assoc] + rw [MonObj.mul_assoc_flip, + associator_inv_naturality_right_assoc, + whisker_exchange_assoc] + +end UnitLeg + +section Cast + +/-- **Transport of a descended action along an equality of +modules**: the descended actions of equal modules agree through +the induced transport. -/ +theorem modTensorDescAct_cast + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) + {P Q : Mod D A} (h : P = Q) + (N : Mod D A) (actP : B ⊗ P.X ⟶ P.X) + (actQ : B ⊗ Q.X ⟶ Q.X) + (hcP : B ◁ actRight A P.X ≫ actP = + (α_ B P.X A).inv ≫ actP ▷ A ≫ actRight A P.X) + (hcQ : B ◁ actRight A Q.X ≫ actQ = + (α_ B Q.X A).inv ≫ actQ ▷ A ≫ actRight A Q.X) + (hact : actP ≫ eqToHom (congrArg Mod.X h) = + (B ◁ eqToHom (congrArg Mod.X h)) ≫ actQ) : + modTensorDescAct A P N B actP hcP ≫ + eqToHom (congrArg (fun R => modTensor A R N) h) = + (B ◁ eqToHom (congrArg (fun R => modTensor A R N) h)) ≫ + modTensorDescAct A Q N B actQ hcQ := by + subst h + simp only [eqToHom_refl, Category.comp_id, Category.id_comp, + MonoidalCategory.whiskerLeft_id] at hact ⊢ + subst hact + rfl + +end Cast + +section AssocLeg + +/-- The base-change action, retyped at the relative-tensor +spelling so that goals stay type-correct. -/ +noncomputable def bcActR + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (M : Mod D A) : + B ⊗ modTensor A (restrictRegular φ) M ⟶ + modTensor A (restrictRegular φ) M := + baseChangeAct φ M + +/-- Defining equation of the retyped base-change action. -/ +theorem whiskerLeft_π_bcActR + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (M : Mod D A) : + (B ◁ modTensorπ A (restrictRegular φ) M) ≫ + bcActR A B φ M = + ((α_ B B M.X).inv ≫ (μ[B] ▷ M.X)) ≫ + modTensorπ A (restrictRegular φ) M := + whiskerLeft_modTensorπ_baseChangeAct φ M + +/-- The retyped base-change action commutes with the braided +right action. -/ +theorem bcActR_compat + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] (M : Mod D A) : + B ◁ actRight A (modTensorMod A (restrictRegular φ) M).X ≫ + bcActR A B φ M = + (α_ B (modTensorMod A (restrictRegular φ) M).X A).inv ≫ + (bcActR A B φ M ▷ A) ≫ + actRight A + (modTensorMod A (restrictRegular φ) M).X := by + have key : ∀ {Z : D} (g : B ⊗ M.X ⟶ Z), + (B ◁ (α_ B M.X A).hom) ≫ + (B ◁ (B ◁ actRight A M.X)) ≫ + ((α_ B B M.X).inv ≫ (μ[B] ▷ M.X)) ≫ g = + (α_ B (B ⊗ M.X) A).inv ≫ + (((α_ B B M.X).inv ≫ (μ[B] ▷ M.X)) ▷ A) ≫ + (α_ B M.X A).hom ≫ (B ◁ actRight A M.X) ≫ g := by + intro Z g + simp only [MonoidalCategory.comp_whiskerRight, + Category.assoc] + rw [associator_inv_naturality_right_assoc, + whisker_exchange_assoc] + rw [associator_naturality_left_assoc] + rw [reassoc_of% (show (B ◁ (α_ B M.X A).hom) ≫ + (α_ B B (M.X ⊗ A)).inv = (α_ B (B ⊗ M.X) A).inv ≫ + ((α_ B B M.X).inv ▷ A) ≫ (α_ (B ⊗ B) M.X A).hom + from by monoidal)] + have hπa : (modTensorπ A (restrictRegular φ) M ▷ A) ≫ + actRight A (modTensorMod A (restrictRegular φ) M).X = + (α_ B M.X A).hom ≫ (B ◁ actRight A M.X) ≫ + modTensorπ A (restrictRegular φ) M := + modTensorπ_actRight A (restrictRegular φ) M + have step : (B ◁ ((modTensorπ A (restrictRegular φ) M ▷ A) + ≫ actRight A + (modTensorMod A (restrictRegular φ) M).X)) = + (B ◁ (α_ B M.X A).hom) ≫ + (B ◁ (B ◁ actRight A M.X)) ≫ + (B ◁ modTensorπ A (restrictRegular φ) M) := + (congrArg (fun t => B ◁ t) hπa).trans + ((MonoidalCategory.whiskerLeft_comp B _ _).trans + (whisker_eq _ + (MonoidalCategory.whiskerLeft_comp B _ _))) + refine (cancel_epi (B ◁ (modTensorπ A (restrictRegular φ) M + ▷ A))).mp ?_ + have hL : (B ◁ (modTensorπ A (restrictRegular φ) M ▷ A)) ≫ + (B ◁ actRight A + (modTensorMod A (restrictRegular φ) M).X ≫ + bcActR A B φ M) = + (B ◁ (α_ B M.X A).hom) ≫ + (B ◁ (B ◁ actRight A M.X)) ≫ + ((α_ B B M.X).inv ≫ (μ[B] ▷ M.X)) ≫ + modTensorπ A (restrictRegular φ) M := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker step _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine whisker_eq _ ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (whiskerLeft_π_bcActR A B φ M) + have hR : (B ◁ (modTensorπ A (restrictRegular φ) M ▷ A)) ≫ + ((α_ B (modTensorMod A (restrictRegular φ) M).X A).inv ≫ + (bcActR A B φ M ▷ A) ≫ + actRight A + (modTensorMod A (restrictRegular φ) M).X) = + (α_ B (B ⊗ M.X) A).inv ≫ + (((α_ B B M.X).inv ≫ (μ[B] ▷ M.X)) ▷ A) ≫ + (α_ B M.X A).hom ≫ (B ◁ actRight A M.X) ≫ + modTensorπ A (restrictRegular φ) M := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (associator_inv_naturality_middle B + (modTensorπ A (restrictRegular φ) M) A) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine whisker_eq _ ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.comp_whiskerRight _ _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg + (fun t => t ▷ A) (whiskerLeft_π_bcActR A B φ M)) _) ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.comp_whiskerRight _ _ _) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ hπa + exact hL.trans ((key _).trans hR.symm) + +/-- **The associator is linear over the new base**: it +intertwines the action descended on the nested first slot with +the action of the base change. -/ +theorem assocHom_linear + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] (M : Mod D A) (N : Mod D A) + (hc : B ◁ actRight A + (modTensorMod A (restrictRegular φ) M).X ≫ + bcActR A B φ M = + (α_ B (modTensorMod A (restrictRegular φ) M).X A).inv ≫ + (bcActR A B φ M ▷ A) ≫ + actRight A + (modTensorMod A (restrictRegular φ) M).X) : + modTensorDescAct A (modTensorMod A (restrictRegular φ) M) N + B (bcActR A B φ M) hc ≫ + modTensorAssocHom A (restrictRegular φ) M N = + (B ◁ modTensorAssocHom A (restrictRegular φ) M N) ≫ + bcActR A B φ (modTensorMod A M N) := by + apply modTensor_whisker_hom_ext A + (modTensorMod A (restrictRegular φ) M) N B + have hL : (B ◁ modTensorπ A + (modTensorMod A (restrictRegular φ) M) N) ≫ + (modTensorDescAct A + (modTensorMod A (restrictRegular φ) M) N B + (bcActR A B φ M) hc ≫ + modTensorAssocHom A (restrictRegular φ) M N) = + ((α_ B (modTensor A (restrictRegular φ) M) N.X).inv ≫ + (bcActR A B φ M ▷ N.X)) ≫ + modTensorAssocMid A (restrictRegular φ) M N := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (whiskerLeft_modTensorπ_descAct A + (modTensorMod A (restrictRegular φ) M) N B + (bcActR A B φ M) hc) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ + (modTensorπ_assocHom A (restrictRegular φ) M N) + have hR : (B ◁ modTensorπ A + (modTensorMod A (restrictRegular φ) M) N) ≫ + ((B ◁ modTensorAssocHom A (restrictRegular φ) M N) ≫ + bcActR A B φ (modTensorMod A M N)) = + (B ◁ modTensorAssocMid A (restrictRegular φ) M N) ≫ + bcActR A B φ (modTensorMod A M N) := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + exact eq_whisker (congrArg (fun t => B ◁ t) + (modTensorπ_assocHom A (restrictRegular φ) M N)) _ + refine hL.trans (Eq.trans ?_ hR.symm) + refine (cancel_epi (B ◁ (modTensorπ A (restrictRegular φ) M + ▷ N.X))).mp ?_ + simp only [Category.assoc] + rw [associator_inv_naturality_middle_assoc] + rw [← MonoidalCategory.comp_whiskerRight_assoc] + rw [whiskerLeft_π_bcActR] + simp only [MonoidalCategory.comp_whiskerRight, + Category.assoc] + rw [whiskerRight_modTensorπ_assocMid] + rw [← MonoidalCategory.whiskerLeft_comp_assoc, + whiskerRight_modTensorπ_assocMid] + rw [modTensorAssocCover] + simp only [MonoidalCategory.whiskerLeft_comp, + Category.assoc] + erw [MonoidalCategory.whiskerLeft_comp] + repeat' erw [Category.assoc] + refine Eq.trans ?_ (whisker_eq _ (whisker_eq _ + (whiskerLeft_π_bcActR A B φ + (modTensorMod A M N)))).symm + have key : ∀ {Z : D} (g : B ⊗ modTensor A M N ⟶ Z), + (α_ B (B ⊗ M.X) N.X).inv ≫ + ((α_ B B M.X).inv ▷ N.X) ≫ + ((μ[B] ▷ M.X) ▷ N.X) ≫ + (α_ B M.X N.X).hom ≫ + (B ◁ modTensorπ A M N) ≫ g = + (B ◁ (α_ B M.X N.X).hom) ≫ + (B ◁ (B ◁ modTensorπ A M N)) ≫ + ((α_ B B (modTensor A M N)).inv ≫ + (μ[B] ▷ modTensor A M N)) ≫ g := by + intro Z g + simp only [Category.assoc] + rw [associator_inv_naturality_right_assoc, + whisker_exchange_assoc] + rw [associator_naturality_left_assoc] + rw [reassoc_of% (show (α_ B (B ⊗ M.X) N.X).inv ≫ + ((α_ B B M.X).inv ▷ N.X) ≫ (α_ (B ⊗ B) M.X N.X).hom = + (B ◁ (α_ B M.X N.X).hom) ≫ (α_ B B (M.X ⊗ N.X)).inv + from by monoidal)] + exact key _ + +end AssocLeg + +section ProjFormula + +/-- **The projection formula is linear over the new base.** -/ +theorem projFormula_linear + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] (M : Mod D A) (N : Mod D A) : + modTensorAct B (baseChangeMod φ M) (baseChangeMod φ N) ≫ + (projFormula A B φ M N).hom = + (B ◁ (projFormula A B φ M N).hom) ≫ + baseChangeAct φ (modTensorMod A M N) := by + have hcast : collapseAct A B φ (baseChangeMod φ M) N ≫ + eqToHom (congrArg (fun P => modTensor A P N) + (restrictMod_baseChange_eq A B φ M)) = + (B ◁ eqToHom (congrArg (fun P => modTensor A P N) + (restrictMod_baseChange_eq A B φ M))) ≫ + modTensorDescAct A + (modTensorMod A (restrictRegular φ) M) N B + (bcActR A B φ M) (bcActR_compat A B φ M) := by + have hact : bcActR A B φ M ≫ + 𝟙 (modTensor A (restrictRegular φ) M) = + (B ◁ 𝟙 (modTensor A (restrictRegular φ) M)) ≫ + bcActR A B φ M := by + rw [Category.comp_id, MonoidalCategory.whiskerLeft_id, + Category.id_comp] + exact modTensorDescAct_cast A B + (restrictMod_baseChange_eq A B φ M) N _ _ _ _ hact + change modTensorAct B (baseChangeMod φ M) + (baseChangeMod φ N) ≫ + (collapseHom A B φ (baseChangeMod φ M) N ≫ + eqToHom (congrArg (fun P => modTensor A P N) + (restrictMod_baseChange_eq A B φ M)) ≫ + modTensorAssocHom A (restrictRegular φ) M N) = + (B ◁ (collapseHom A B φ (baseChangeMod φ M) N ≫ + eqToHom (congrArg (fun P => modTensor A P N) + (restrictMod_baseChange_eq A B φ M)) ≫ + modTensorAssocHom A (restrictRegular φ) M N)) ≫ + baseChangeAct φ (modTensorMod A M N) + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (collapseHom_linear A B φ (baseChangeMod φ M) N) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker hcast _)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (assocHom_linear A B φ M N + (bcActR_compat A B φ M)))) ?_ + refine Eq.symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine whisker_eq _ ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _) _) ?_ + exact Category.assoc _ _ _ + +end ProjFormula + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeMonoidal.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeMonoidal.lean new file mode 100644 index 0000000000..614698d446 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeMonoidal.lean @@ -0,0 +1,650 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeCoherence +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepATransport + +/-! +# Base change as a monoidal functor + +Base change along a morphism of commutative algebras carries +modules to modules, morphisms to morphisms, and the relative +tensor to the relative tensor: the projection formula is the +structure map, the collapse of the regular module is the unit. +This file bundles the structure map as an isomorphism of modules +over the new base and proves it natural in both slots. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The structure map of base change, as an isomorphism of +modules over the new base.** -/ +noncomputable def projFormulaMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + (M N : Mod D A) : + modTensorMod B (baseChangeMod φ M) (baseChangeMod φ N) ≅ + baseChangeMod φ (modTensorMod A M N) where + hom := Mod.Hom.mk' (projFormula A B φ M N).hom (by + exact projFormula_linear A B φ M N) + inv := Mod.Hom.mk' (projFormula A B φ M N).inv (by + exact act_inv_of_act_hom B (projFormula A B φ M N) + (projFormula_linear A B φ M N)) + hom_inv_id := by + apply Mod.Hom.ext + exact (projFormula A B φ M N).hom_inv_id + inv_hom_id := by + apply Mod.Hom.ext + exact (projFormula A B φ M N).inv_hom_id + +/-- **The structure map is natural in the second slot.** -/ +theorem projFormula_natural_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + (M : Mod D A) + {N N' : Mod D A} (g : N ⟶ N') : + modTensorMap B (𝟙 (baseChangeMod φ M)) + (baseChangeMapMod A B φ g) ≫ + (projFormula A B φ M N').hom = + (projFormula A B φ M N).hom ≫ + modTensorMap A (𝟙 (restrictRegular φ)) + (modTensorMapMod A (𝟙 M) g) := by + have hmapB : modTensorπ B (baseChangeMod φ M) + (baseChangeMod φ N) ≫ + modTensorMap B (𝟙 (baseChangeMod φ M)) + (baseChangeMapMod A B φ g) = + ((baseChangeMod φ M).X ◁ + modTensorMap A (𝟙 (restrictRegular φ)) g) ≫ + modTensorπ B (baseChangeMod φ M) + (baseChangeMod φ N') := by + rw [modTensorπ_map, Mod.id_hom', + MonoidalCategory.id_tensorHom] + rfl + have hmapA : modTensorπ A (restrictRegular φ) N ≫ + modTensorMap A (𝟙 (restrictRegular φ)) g = + (B ◁ g.hom) ≫ modTensorπ A (restrictRegular φ) N' := by + rw [modTensorπ_map, Mod.id_hom', + MonoidalCategory.id_tensorHom] + have hL : ((baseChangeMod φ M).X ◁ + modTensorπ A (restrictRegular φ) N) ≫ + modTensorπ B (baseChangeMod φ M) + (baseChangeMod φ N) ≫ + modTensorMap B (𝟙 (baseChangeMod φ M)) + (baseChangeMapMod A B φ g) ≫ + (projFormula A B φ M N').hom = + ((baseChangeMod φ M).X ◁ (B ◁ g.hom)) ≫ + (α_ (baseChangeMod φ M).X B N'.X).inv ≫ + (actRight B (baseChangeMod φ M).X ▷ N'.X) ≫ + modTensorAssocMid A (restrictRegular φ) M N' := by + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker hmapB _)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + ((MonoidalCategory.whiskerLeft_comp _ _ _).symm.trans + (congrArg (fun t => + (baseChangeMod φ M).X ◁ t) hmapA)) _) ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp _ _ _) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (projFormula_cover A B φ M N') + have hR : ((baseChangeMod φ M).X ◁ + modTensorπ A (restrictRegular φ) N) ≫ + modTensorπ B (baseChangeMod φ M) + (baseChangeMod φ N) ≫ + (projFormula A B φ M N).hom ≫ + modTensorMap A (𝟙 (restrictRegular φ)) + (modTensorMapMod A (𝟙 M) g) = + (α_ (baseChangeMod φ M).X B N.X).inv ≫ + (actRight B (baseChangeMod φ M).X ▷ N.X) ≫ + ((modTensorMod A (restrictRegular φ) M).X ◁ g.hom) ≫ + modTensorAssocMid A (restrictRegular φ) M N' := by + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (projFormula_cover A B φ M N) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + exact whisker_eq _ (whisker_eq _ + (modTensorAssocMid_natural_right A + (restrictRegular φ) M g)) + have hend : ∀ (Y : D) (r : Y ⊗ B ⟶ Y), + (Y ◁ (B ◁ g.hom)) ≫ (α_ Y B N'.X).inv ≫ (r ▷ N'.X) = + (α_ Y B N.X).inv ≫ (r ▷ N.X) ≫ (Y ◁ g.hom) := by + intro Y r + rw [associator_inv_naturality_right_assoc, whisker_exchange] + apply modTensor_hom_ext + apply modTensor_whisker_hom_ext A (restrictRegular φ) N + (baseChangeMod φ M).X + refine Eq.trans hL (Eq.trans ?_ hR.symm) + refine Eq.trans (whisker_eq _ + (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (hend _ _) _) ?_ + simp only [] + conv_lhs => erw [Category.assoc]; arg 2; erw [Category.assoc] + rfl + +/-- **The structure map is natural in the first slot.** -/ +theorem projFormula_natural_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + {M M' : Mod D A} (f : M ⟶ M') + (N : Mod D A) : + modTensorMap B (baseChangeMapMod A B φ f) + (𝟙 (baseChangeMod φ N)) ≫ + (projFormula A B φ M' N).hom = + (projFormula A B φ M N).hom ≫ + modTensorMap A (𝟙 (restrictRegular φ)) + (modTensorMapMod A f (𝟙 N)) := by + have hmapB : modTensorπ B (baseChangeMod φ M) + (baseChangeMod φ N) ≫ + modTensorMap B (baseChangeMapMod A B φ f) + (𝟙 (baseChangeMod φ N)) = + (modTensorMap A (𝟙 (restrictRegular φ)) f ▷ + (baseChangeMod φ N).X) ≫ + modTensorπ B (baseChangeMod φ M') + (baseChangeMod φ N) := by + rw [modTensorπ_map, Mod.id_hom', + MonoidalCategory.tensorHom_id] + rfl + have hact : actRight B (baseChangeMod φ M).X ≫ + modTensorMap A (𝟙 (restrictRegular φ)) f = + (modTensorMap A (𝟙 (restrictRegular φ)) f ▷ B) ≫ + actRight B (baseChangeMod φ M').X := + actRight_natural_mod B (baseChangeMapMod A B φ f) + have hL : ((baseChangeMod φ M).X ◁ + modTensorπ A (restrictRegular φ) N) ≫ + modTensorπ B (baseChangeMod φ M) + (baseChangeMod φ N) ≫ + modTensorMap B (baseChangeMapMod A B φ f) + (𝟙 (baseChangeMod φ N)) ≫ + (projFormula A B φ M' N).hom = + (modTensorMap A (𝟙 (restrictRegular φ)) f ▷ + (B ⊗ N.X)) ≫ + (α_ (baseChangeMod φ M').X B N.X).inv ≫ + (actRight B (baseChangeMod φ M').X ▷ N.X) ≫ + modTensorAssocMid A (restrictRegular φ) M' N := by + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker hmapB _)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (whisker_exchange _ _) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (projFormula_cover A B φ M' N) + have hR : ((baseChangeMod φ M).X ◁ + modTensorπ A (restrictRegular φ) N) ≫ + modTensorπ B (baseChangeMod φ M) + (baseChangeMod φ N) ≫ + (projFormula A B φ M N).hom ≫ + modTensorMap A (𝟙 (restrictRegular φ)) + (modTensorMapMod A f (𝟙 N)) = + (α_ (baseChangeMod φ M).X B N.X).inv ≫ + (actRight B (baseChangeMod φ M).X ▷ N.X) ≫ + (modTensorMap A (𝟙 (restrictRegular φ)) f ▷ N.X) ≫ + modTensorAssocMid A (restrictRegular φ) M' N := by + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (projFormula_cover A B φ M N) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + exact whisker_eq _ (whisker_eq _ + (modTensorAssocMid_natural_mid A + (restrictRegular φ) f N)) + have hend : ∀ (Y Y' : D) (r : Y ⊗ B ⟶ Y) (r' : Y' ⊗ B ⟶ Y') + (k : Y ⟶ Y'), r ≫ k = (k ▷ B) ≫ r' → + (k ▷ (B ⊗ N.X)) ≫ (α_ Y' B N.X).inv ≫ (r' ▷ N.X) = + (α_ Y B N.X).inv ≫ (r ▷ N.X) ≫ (k ▷ N.X) := by + intro Y Y' r r' k hk + rw [associator_inv_naturality_left_assoc, + ← MonoidalCategory.comp_whiskerRight, ← hk, + MonoidalCategory.comp_whiskerRight] + apply modTensor_hom_ext + apply modTensor_whisker_hom_ext A (restrictRegular φ) N + (baseChangeMod φ M).X + refine Eq.trans hL (Eq.trans ?_ hR.symm) + refine Eq.trans (whisker_eq _ + (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (hend _ _ _ _ _ hact) _) ?_ + simp only [Category.assoc] + rfl + +section Assoc + +/-- The left-nested side of the associator square, evaluated on +the triple cover. -/ +theorem projFormula_assoc_leftCover + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] (M : Mod D A) (N : Mod D A) (P : Mod D A) : + ((modTensorπ A (restrictRegular φ) M ▷ (B ⊗ N.X)) ▷ + (B ⊗ P.X)) ≫ + (((baseChangeMod φ M).X ◁ + modTensorπ A (restrictRegular φ) N) ▷ (B ⊗ P.X)) ≫ + (modTensorπ B (baseChangeMod φ M) (baseChangeMod φ N) ▷ + (B ⊗ P.X)) ≫ + (modTensor B (baseChangeMod φ M) (baseChangeMod φ N) ◁ + modTensorπ A (restrictRegular φ) P) ≫ + modTensorπ B + (modTensorMod B (baseChangeMod φ M) (baseChangeMod φ N)) + (baseChangeMod φ P) ≫ + modTensorMap B (projFormulaMod A B φ M N).hom + (𝟙 (baseChangeMod φ P)) ≫ + (projFormula A B φ (modTensorMod A M N) P).hom ≫ + modTensorMap A (𝟙 (restrictRegular φ)) + (modTensorAssocModIso A M N P).hom = + (((tensorμ B M.X B N.X ≫ (μ[B] ▷ (M.X ⊗ N.X))) ≫ + (B ◁ modTensorπ A M N)) ▷ (B ⊗ P.X)) ≫ + (tensorμ B (modTensor A M N) B P.X ≫ + (μ[B] ▷ (modTensor A M N ⊗ P.X))) ≫ + (B ◁ modTensorAssocMid A M N P) ≫ + modTensorπ A (restrictRegular φ) + (modTensorMod A M (modTensorMod A N P)) := by + have h1 : modTensorπ B + (modTensorMod B (baseChangeMod φ M) (baseChangeMod φ N)) + (baseChangeMod φ P) ≫ + modTensorMap B (projFormulaMod A B φ M N).hom + (𝟙 (baseChangeMod φ P)) = + ((projFormula A B φ M N).hom ▷ + (baseChangeMod φ P).X) ≫ + modTensorπ B (baseChangeMod φ (modTensorMod A M N)) + (baseChangeMod φ P) := by + rw [modTensorπ_map, Mod.id_hom', + MonoidalCategory.tensorHom_id] + rfl + have h5 : modTensorπ A (restrictRegular φ) + (modTensorMod A (modTensorMod A M N) P) ≫ + modTensorMap A (𝟙 (restrictRegular φ)) + (modTensorAssocModIso A M N P).hom = + (B ◁ modTensorAssocHom A M N P) ≫ + modTensorπ A (restrictRegular φ) + (modTensorMod A M (modTensorMod A N P)) := by + rw [modTensorπ_map, Mod.id_hom', + MonoidalCategory.id_tensorHom] + rfl + have hcore1 : (modTensor B (baseChangeMod φ M) + (baseChangeMod φ N) ◁ + modTensorπ A (restrictRegular φ) P) ≫ + modTensorπ B + (modTensorMod B (baseChangeMod φ M) + (baseChangeMod φ N)) (baseChangeMod φ P) ≫ + modTensorMap B (projFormulaMod A B φ M N).hom + (𝟙 (baseChangeMod φ P)) ≫ + (projFormula A B φ (modTensorMod A M N) P).hom ≫ + modTensorMap A (𝟙 (restrictRegular φ)) + (modTensorAssocModIso A M N P).hom = + ((projFormula A B φ M N).hom ▷ (B ⊗ P.X)) ≫ + ((baseChangeMod φ (modTensorMod A M N)).X ◁ + modTensorπ A (restrictRegular φ) P) ≫ + modTensorπ B (baseChangeMod φ (modTensorMod A M N)) + (baseChangeMod φ P) ≫ + (projFormula A B φ (modTensorMod A M N) P).hom ≫ + modTensorMap A (𝟙 (restrictRegular φ)) + (modTensorAssocModIso A M N P).hom := by + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker h1 _)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (whisker_exchange + (projFormula A B φ M N).hom + (modTensorπ A (restrictRegular φ) P)) _) ?_ + simp only [] + erw [Category.assoc] + rfl + have hcore2 : ∀ {Z : D} + (h : (baseChangeMod φ (modTensorMod A M N)).X ⊗ + (B ⊗ P.X) ⟶ Z), + ((modTensorπ A (restrictRegular φ) M ▷ (B ⊗ N.X)) ▷ + (B ⊗ P.X)) ≫ + (((baseChangeMod φ M).X ◁ + modTensorπ A (restrictRegular φ) N) ▷ (B ⊗ P.X)) ≫ + (modTensorπ B (baseChangeMod φ M) (baseChangeMod φ N) ▷ + (B ⊗ P.X)) ≫ + ((projFormula A B φ M N).hom ▷ (B ⊗ P.X)) ≫ h = + (((tensorμ B M.X B N.X ≫ (μ[B] ▷ (M.X ⊗ N.X))) ≫ + (B ◁ modTensorπ A M N)) ▷ (B ⊗ P.X)) ≫ + (modTensorπ A (restrictRegular φ) + (modTensorMod A M N) ▷ (B ⊗ P.X)) ≫ h := by + intro Z h + have hfold : (((modTensorπ A (restrictRegular φ) M ▷ + (B ⊗ N.X)) ≫ + ((baseChangeMod φ M).X ◁ + modTensorπ A (restrictRegular φ) N)) ≫ + modTensorπ B (baseChangeMod φ M) (baseChangeMod φ N)) ≫ + (projFormula A B φ M N).hom = + ((tensorμ B M.X B N.X ≫ (μ[B] ▷ (M.X ⊗ N.X))) ≫ + (B ◁ modTensorπ A M N)) ≫ + modTensorπ A (restrictRegular φ) + (modTensorMod A M N) := by + simp only [Category.assoc] + conv_lhs => erw [Category.assoc, Category.assoc] + conv_rhs => erw [Category.assoc]; arg 2; erw [Category.assoc] + exact projFormula_tensorμ_cover A B φ M N + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.comp_whiskerRight _ _ _).symm _) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.comp_whiskerRight _ _ _).symm _) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.comp_whiskerRight _ _ _).symm _) ?_ + refine Eq.trans (eq_whisker + (congrArg (fun t => t ▷ (B ⊗ P.X)) hfold) _) ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.comp_whiskerRight _ _ _) _) ?_ + exact Category.assoc _ _ _ + have hcore3 : (modTensorπ A (restrictRegular φ) + (modTensorMod A M N) ▷ (B ⊗ P.X)) ≫ + ((baseChangeMod φ (modTensorMod A M N)).X ◁ + modTensorπ A (restrictRegular φ) P) ≫ + modTensorπ B (baseChangeMod φ (modTensorMod A M N)) + (baseChangeMod φ P) ≫ + (projFormula A B φ (modTensorMod A M N) P).hom ≫ + modTensorMap A (𝟙 (restrictRegular φ)) + (modTensorAssocModIso A M N P).hom = + (tensorμ B (modTensor A M N) B P.X ≫ + (μ[B] ▷ (modTensor A M N ⊗ P.X))) ≫ + (B ◁ modTensorAssocMid A M N P) ≫ + modTensorπ A (restrictRegular φ) + (modTensorMod A M (modTensorMod A N P)) := by + have hcover := congrArg (fun t => t ≫ + modTensorMap A (𝟙 (restrictRegular φ)) + (modTensorAssocModIso A M N P).hom) + (projFormula_tensorμ_cover A B φ (modTensorMod A M N) P) + conv at hcover => + lhs + erw [Category.assoc] + arg 2 + erw [Category.assoc] + arg 2 + erw [Category.assoc] + refine Eq.trans hcover ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (Category.assoc _ _ _))) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (whisker_eq _ h5))) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + ((Category.assoc _ _ _).symm.trans (eq_whisker + ((MonoidalCategory.whiskerLeft_comp _ _ _).symm.trans + (congrArg (fun t => B ◁ t) + (modTensorπ_assocHom A M N P))) _)))) ?_ + exact (Category.assoc _ _ _).symm + refine Eq.trans (whisker_eq _ (whisker_eq _ + (whisker_eq _ hcore1))) ?_ + refine Eq.trans (hcore2 _) ?_ + exact whisker_eq _ hcore3 + +/-- The right-nested side of the associator square, evaluated on +the triple cover. -/ +theorem projFormula_assoc_rightCover + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] (M : Mod D A) (N : Mod D A) (P : Mod D A) : + ((modTensorπ A (restrictRegular φ) M ▷ (B ⊗ N.X)) ▷ + (B ⊗ P.X)) ≫ + (((baseChangeMod φ M).X ◁ + modTensorπ A (restrictRegular φ) N) ▷ (B ⊗ P.X)) ≫ + (modTensorπ B (baseChangeMod φ M) (baseChangeMod φ N) ▷ + (B ⊗ P.X)) ≫ + (modTensor B (baseChangeMod φ M) (baseChangeMod φ N) ◁ + modTensorπ A (restrictRegular φ) P) ≫ + modTensorπ B + (modTensorMod B (baseChangeMod φ M) (baseChangeMod φ N)) + (baseChangeMod φ P) ≫ + modTensorAssocHom B (baseChangeMod φ M) + (baseChangeMod φ N) (baseChangeMod φ P) ≫ + modTensorMap B (𝟙 (baseChangeMod φ M)) + (projFormulaMod A B φ N P).hom ≫ + (projFormula A B φ M (modTensorMod A N P)).hom = + (α_ (B ⊗ M.X) (B ⊗ N.X) (B ⊗ P.X)).hom ≫ + ((B ⊗ M.X) ◁ (tensorμ B N.X B P.X ≫ + (μ[B] ▷ (N.X ⊗ P.X)) ≫ (B ◁ modTensorπ A N P))) ≫ + (tensorμ B M.X B (modTensor A N P) ≫ + (μ[B] ▷ (M.X ⊗ modTensor A N P))) ≫ + (B ◁ modTensorπ A M (modTensorMod A N P)) ≫ + modTensorπ A (restrictRegular φ) + (modTensorMod A M (modTensorMod A N P)) := by + have h2 : modTensorπ B (baseChangeMod φ M) + (modTensorMod B (baseChangeMod φ N) + (baseChangeMod φ P)) ≫ + modTensorMap B (𝟙 (baseChangeMod φ M)) + (projFormulaMod A B φ N P).hom = + ((baseChangeMod φ M).X ◁ + (projFormula A B φ N P).hom) ≫ + modTensorπ B (baseChangeMod φ M) + (baseChangeMod φ (modTensorMod A N P)) := by + rw [modTensorπ_map, Mod.id_hom', + MonoidalCategory.id_tensorHom] + rfl + have hcov : (modTensorπ B (baseChangeMod φ M) + (baseChangeMod φ N) ▷ (baseChangeMod φ P).X) ≫ + modTensorAssocMid B (baseChangeMod φ M) + (baseChangeMod φ N) (baseChangeMod φ P) = + (α_ (baseChangeMod φ M).X (baseChangeMod φ N).X + (baseChangeMod φ P).X).hom ≫ + ((baseChangeMod φ M).X ◁ + modTensorπ B (baseChangeMod φ N) + (baseChangeMod φ P)) ≫ + modTensorπ B (baseChangeMod φ M) + (modTensorMod B (baseChangeMod φ N) + (baseChangeMod φ P)) := by + rw [whiskerRight_modTensorπ_assocMid, modTensorAssocCover] + have hcore1 : (modTensorπ B (baseChangeMod φ M) + (baseChangeMod φ N) ▷ (B ⊗ P.X)) ≫ + (modTensor B (baseChangeMod φ M) (baseChangeMod φ N) ◁ + modTensorπ A (restrictRegular φ) P) ≫ + modTensorπ B + (modTensorMod B (baseChangeMod φ M) + (baseChangeMod φ N)) (baseChangeMod φ P) ≫ + modTensorAssocHom B (baseChangeMod φ M) + (baseChangeMod φ N) (baseChangeMod φ P) ≫ + modTensorMap B (𝟙 (baseChangeMod φ M)) + (projFormulaMod A B φ N P).hom ≫ + (projFormula A B φ M (modTensorMod A N P)).hom = + (((baseChangeMod φ M).X ⊗ (baseChangeMod φ N).X) ◁ + modTensorπ A (restrictRegular φ) P) ≫ + (α_ (baseChangeMod φ M).X (baseChangeMod φ N).X + (baseChangeMod φ P).X).hom ≫ + ((baseChangeMod φ M).X ◁ + modTensorπ B (baseChangeMod φ N) + (baseChangeMod φ P)) ≫ + ((baseChangeMod φ M).X ◁ + (projFormula A B φ N P).hom) ≫ + modTensorπ B (baseChangeMod φ M) + (baseChangeMod φ (modTensorMod A N P)) ≫ + (projFormula A B φ M (modTensorMod A N P)).hom := by + refine Eq.trans (whisker_eq _ (whisker_eq _ + (Category.assoc _ _ _).symm)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ (eq_whisker + (modTensorπ_assocHom B (baseChangeMod φ M) + (baseChangeMod φ N) (baseChangeMod φ P)) _))) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (whisker_exchange + (modTensorπ B (baseChangeMod φ M) (baseChangeMod φ N)) + (modTensorπ A (restrictRegular φ) P)).symm _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker hcov _)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (Category.assoc _ _ _))) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ (whisker_eq _ + (Category.assoc _ _ _).symm))) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ (whisker_eq _ + (eq_whisker h2 _)))) ?_ + exact whisker_eq _ (whisker_eq _ (whisker_eq _ + (Category.assoc _ _ _))) + have hfoldNP : (modTensorπ A (restrictRegular φ) N ▷ + (B ⊗ P.X)) ≫ + ((baseChangeMod φ N).X ◁ + modTensorπ A (restrictRegular φ) P) ≫ + modTensorπ B (baseChangeMod φ N) (baseChangeMod φ P) ≫ + (projFormula A B φ N P).hom = + ((tensorμ B N.X B P.X ≫ (μ[B] ▷ (N.X ⊗ P.X))) ≫ + (B ◁ modTensorπ A N P)) ≫ + modTensorπ A (restrictRegular φ) + (modTensorMod A N P) := by + simp only [Category.assoc] + conv_rhs => erw [Category.assoc]; arg 2; erw [Category.assoc] + exact projFormula_tensorμ_cover A B φ N P + have hfoldX : ((baseChangeMod φ M).X ◁ + (modTensorπ A (restrictRegular φ) N ▷ (B ⊗ P.X))) ≫ + ((baseChangeMod φ M).X ◁ ((baseChangeMod φ N).X ◁ + modTensorπ A (restrictRegular φ) P)) ≫ + ((baseChangeMod φ M).X ◁ + modTensorπ B (baseChangeMod φ N) + (baseChangeMod φ P)) ≫ + ((baseChangeMod φ M).X ◁ + (projFormula A B φ N P).hom) = + ((baseChangeMod φ M).X ◁ + ((tensorμ B N.X B P.X ≫ (μ[B] ▷ (N.X ⊗ P.X))) ≫ + (B ◁ modTensorπ A N P))) ≫ + ((baseChangeMod φ M).X ◁ + modTensorπ A (restrictRegular φ) + (modTensorMod A N P)) := by + repeat' erw [← MonoidalCategory.whiskerLeft_comp] + exact congrArg + (fun t => (baseChangeMod φ M).X ◁ t) hfoldNP + have hfoldM : (modTensorπ A (restrictRegular φ) M ▷ + (B ⊗ (modTensorMod A N P).X)) ≫ + ((baseChangeMod φ M).X ◁ + modTensorπ A (restrictRegular φ) + (modTensorMod A N P)) ≫ + modTensorπ B (baseChangeMod φ M) + (baseChangeMod φ (modTensorMod A N P)) ≫ + (projFormula A B φ M (modTensorMod A N P)).hom = + (tensorμ B M.X B (modTensor A N P) ≫ + (μ[B] ▷ (M.X ⊗ modTensor A N P))) ≫ + (B ◁ modTensorπ A M (modTensorMod A N P)) ≫ + modTensorπ A (restrictRegular φ) + (modTensorMod A M (modTensorMod A N P)) := by + simp only [Category.assoc] + exact projFormula_tensorμ_cover A B φ M + (modTensorMod A N P) + refine Eq.trans (whisker_eq _ (whisker_eq _ hcore1)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + ((Category.assoc _ _ _).symm.trans (eq_whisker + (associator_naturality_right (baseChangeMod φ M).X + (baseChangeMod φ N).X + (modTensorπ A (restrictRegular φ) P)) _)))) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (Category.assoc _ _ _))) ?_ + refine Eq.trans (whisker_eq _ + ((Category.assoc _ _ _).symm.trans (eq_whisker + (associator_naturality_middle (baseChangeMod φ M).X + (modTensorπ A (restrictRegular φ) N) + (B ⊗ P.X)) _))) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + ((reassoc_of% hfoldX) _))) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (Category.assoc _ _ _))) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (associator_naturality_left + (modTensorπ A (restrictRegular φ) M) (B ⊗ N.X) + (B ⊗ P.X)) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine whisker_eq _ ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (whisker_exchange + (modTensorπ A (restrictRegular φ) M) + (tensorμ B N.X B P.X ≫ (μ[B] ▷ (N.X ⊗ P.X)) ≫ + (B ◁ modTensorπ A N P))).symm _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ hfoldM + +/-- **The associator coherence of the projection formula**: base +change carries the module associator to the module associator +through the structure map. -/ +theorem projFormula_assoc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] (M : Mod D A) (N : Mod D A) (P : Mod D A) : + modTensorMap B (projFormulaMod A B φ M N).hom + (𝟙 (baseChangeMod φ P)) ≫ + (projFormula A B φ (modTensorMod A M N) P).hom ≫ + modTensorMap A (𝟙 (restrictRegular φ)) + (modTensorAssocModIso A M N P).hom = + modTensorAssocHom B (baseChangeMod φ M) (baseChangeMod φ N) + (baseChangeMod φ P) ≫ + modTensorMap B (𝟙 (baseChangeMod φ M)) + (projFormulaMod A B φ N P).hom ≫ + (projFormula A B φ M (modTensorMod A N P)).hom := by + apply modTensor_hom_ext + apply modTensor_whisker_hom_ext A (restrictRegular φ) P + (modTensor B (baseChangeMod φ M) (baseChangeMod φ N)) + apply modTensor_whiskerR_hom_ext B (baseChangeMod φ M) + (baseChangeMod φ N) (B ⊗ P.X) + apply modTensor_whiskerLR_hom_ext A (restrictRegular φ) N + (baseChangeMod φ M).X (B ⊗ P.X) + apply modTensor_whiskerRR_hom_ext A (restrictRegular φ) M + (B ⊗ N.X) (B ⊗ P.X) + refine Eq.trans (projFormula_assoc_leftCover A B φ M N P) + (Eq.trans ?_ + (projFormula_assoc_rightCover A B φ M N P).symm) + have hc := eq_whisker (projFormula_assoc_core A B M N P) + (modTensorπ A (restrictRegular φ) + (modTensorMod A M (modTensorMod A N P))) + conv at hc => + lhs + erw [Category.assoc] + arg 2 + erw [Category.assoc] + conv at hc => + rhs + erw [Category.assoc] + arg 2 + erw [Category.assoc] + arg 2 + erw [Category.assoc] + conv at hc => + rhs + arg 2 + arg 1 + arg 2 + erw [Category.assoc] + exact hc + +end Assoc + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTensor.lean new file mode 100644 index 0000000000..6fdd78b4f2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTensor.lean @@ -0,0 +1,717 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAssoc +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma + +/-! +# Base change and the tensor product of modules + +The change-of-rings collapse: over a base morphism, the relative +tensor of a module over the new base with an induced module +collapses to the relative tensor over the old base of the +restricted module. Together with the associativity of the +relative tensor this yields the projection formula: base change +commutes with the tensor product of modules. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- Scalar restriction of a module along the base morphism. -/ +noncomputable def restrictMod + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (B : D) + [MonObj B] (φ : A ⟶ B) [IsMonHom φ] (P : Mod D B) : + Mod D A := (Mod.comap φ).obj P + +@[simp] lemma restrictMod_X + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (B : D) + [MonObj B] (φ : A ⟶ B) [IsMonHom φ] (P : Mod D B) : + (restrictMod A B φ P).X = P.X := rfl + +/-- The restricted right action acts through the base +morphism. -/ +lemma actRight_restrictMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (B : D) [MonObj B] (φ : A ⟶ B) [IsMonHom φ] (P : Mod D B) : + actRight A (restrictMod A B φ P).X = + (P.X ◁ φ) ≫ actRight B P.X := by + change (β_ P.X A).hom ≫ (φ ▷ P.X) ≫ actLeft B P.X = + (P.X ◁ φ) ≫ (β_ P.X B).hom ≫ actLeft B P.X + rw [← BraidedCategory.braiding_naturality_right_assoc] + +/-- The projection of the restricted-module tensor, retyped at +the carrier of the unrestricted module. All statements of this +development use this spelling, so that goals remain type-correct +at the instances transparency level. -/ +noncomputable def restrictπ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (B : D) [MonObj B] (φ : A ⟶ B) + [IsMonHom φ] (P : Mod D B) (N : Mod D A) : P.X ⊗ N.X ⟶ + modTensor A (restrictMod A B φ P) N := + modTensorπ A (restrictMod A B φ P) N + +/-- The balance of the restricted-module tensor, in the retyped +spelling: sliding the base through the base morphism on the +module side is acting on the second factor. -/ +theorem restrictπ_cond + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (B : D) [MonObj B] (φ : A ⟶ B) + [IsMonHom φ] (P : Mod D B) (N : Mod D A) : + (((P.X ◁ φ) ≫ actRight B P.X) ▷ N.X) ≫ + restrictπ A B φ P N = + (α_ P.X A N.X).hom ≫ (P.X ◁ actLeft A N.X) ≫ + restrictπ A B φ P N := by + have h := modTensor_condition A (restrictMod A B φ P) N + rw [modTensorLegM, modTensorLegN, Category.assoc, + actRight_restrictMod] at h + exact h + +/-- The cover of the collapse: act the middle base into the +module and project. -/ +noncomputable def collapseCover + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (B : D) [MonObj B] (φ : A ⟶ B) + [IsMonHom φ] (P : Mod D B) (N : Mod D A) : P.X ⊗ (B ⊗ N.X) ⟶ + modTensor A (restrictMod A B φ P) N := + (α_ P.X B N.X).inv ≫ (actRight B P.X ▷ N.X) ≫ + restrictπ A B φ P N + +/-- The cover of the collapse coequalizes the whiskered balance +of the induced module: the base slides onto the module through +the associativity of the right action and the balance of the +target. -/ +theorem collapseCover_cond + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (B : D) [MonObj B] + [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] (P : Mod D B) (N : Mod D A) : + (P.X ◁ modTensorLegM A (restrictRegular φ) N) ≫ + collapseCover A B φ P N = + (P.X ◁ modTensorLegN A (restrictRegular φ) N) ≫ + collapseCover A B φ P N := by + have h1 : modTensorLegM A (restrictRegular φ) N = + ((B ◁ φ) ≫ μ[B]) ▷ N.X := + congrArg (· ▷ N.X) (actRight_restrictRegular φ) + have h2 : modTensorLegN A (restrictRegular φ) N = + (α_ B A N.X).hom ≫ (B ◁ actLeft A N.X) := rfl + have hAA : (P.X ◁ μ[B]) ≫ actRight B P.X = + (α_ P.X B B).inv ≫ (actRight B P.X ▷ B) ≫ + actRight B P.X := by + rw [actRight_actRight, Iso.inv_hom_id_assoc] + rw [h1, h2, collapseCover] + conv_lhs => rw [associator_inv_naturality_middle_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + hAA] + conv_rhs => rw [MonoidalCategory.whiskerLeft_comp, + Category.assoc, associator_inv_naturality_right_assoc] + simp only [MonoidalCategory.comp_whiskerRight, + Category.assoc] + have hslide : ((P.X ◁ (B ◁ φ)) ▷ N.X) ≫ + ((α_ P.X B B).inv ▷ N.X) = + ((α_ P.X B A).inv ▷ N.X) ≫ + (((P.X ⊗ B) ◁ φ) ▷ N.X) := by + rw [← MonoidalCategory.comp_whiskerRight, + ← MonoidalCategory.comp_whiskerRight, + associator_inv_naturality_right] + have hexch : (((P.X ⊗ B) ◁ φ) ▷ N.X) ≫ + ((actRight B P.X ▷ B) ▷ N.X) = + ((actRight B P.X ▷ A) ▷ N.X) ≫ + ((P.X ◁ φ) ▷ N.X) := by + rw [← MonoidalCategory.comp_whiskerRight, + ← MonoidalCategory.comp_whiskerRight, + whisker_exchange] + rw [← Category.assoc ((P.X ◁ (B ◁ φ)) ▷ N.X), hslide] + rw [Category.assoc, ← Category.assoc + (((P.X ⊗ B) ◁ φ) ▷ N.X), hexch] + rw [Category.assoc, ← Category.assoc ((P.X ◁ φ) ▷ N.X), + ← MonoidalCategory.comp_whiskerRight, restrictπ_cond] + rw [associator_naturality_left_assoc, + ← whisker_exchange_assoc] + rw [reassoc_of% (show (α_ P.X (B ⊗ A) N.X).inv ≫ + ((α_ P.X B A).inv ▷ N.X) ≫ (α_ (P.X ⊗ B) A N.X).hom = + (P.X ◁ (α_ B A N.X).hom) ≫ (α_ P.X B (A ⊗ N.X)).inv + from by monoidal)] + +/-- The half-descended collapse, on the induced module. -/ +noncomputable def collapseMid + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (P : Mod D B) (N : Mod D A) : + P.X ⊗ baseChange φ N ⟶ + modTensor A (restrictMod A B φ P) N := + modTensorWhiskerDesc A (restrictRegular φ) N P.X + (collapseCover A B φ P N) (collapseCover_cond A B φ P N) + +/-- Defining equation of the half-descended collapse. -/ +@[simp, reassoc] +theorem whiskerLeft_collapseMid + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (P : Mod D B) (N : Mod D A) : + (P.X ◁ modTensorπ A (restrictRegular φ) N) ≫ + collapseMid A B φ P N = collapseCover A B φ P N := + whiskerLeft_modTensorπ_whiskerDesc A _ N P.X _ _ + +/-- The half-descended collapse coequalizes the outer balance: +sliding the base between the module and the induced factor is +absorbed by the associativity of the right action. -/ +theorem collapseMid_cond + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (P : Mod D B) (N : Mod D A) : + modTensorLegM B P (baseChangeMod φ N) ≫ + collapseMid A B φ P N = + modTensorLegN B P (baseChangeMod φ N) ≫ + collapseMid A B φ P N := by + apply modTensor_whisker_hom_ext A (restrictRegular φ) N + (P.X ⊗ B) + have hL : ((P.X ⊗ B) ◁ + modTensorπ A (restrictRegular φ) N) ≫ + modTensorLegM B P (baseChangeMod φ N) ≫ + collapseMid A B φ P N = + (actRight B P.X ▷ (B ⊗ N.X)) ≫ + collapseCover A B φ P N := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (whisker_exchange (actRight B P.X) + (modTensorπ A (restrictRegular φ) N)) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (whiskerLeft_collapseMid A B φ P N) + have hR : ((P.X ⊗ B) ◁ + modTensorπ A (restrictRegular φ) N) ≫ + modTensorLegN B P (baseChangeMod φ N) ≫ + collapseMid A B φ P N = + (α_ P.X B (B ⊗ N.X)).hom ≫ + (P.X ◁ ((α_ B B N.X).inv ≫ (μ[B] ▷ N.X))) ≫ + collapseCover A B φ P N := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (Category.assoc _ _ _).symm + _) ?_ + refine Eq.trans (eq_whisker (eq_whisker + (associator_naturality_right P.X B + (modTensorπ A (restrictRegular φ) N)) _) _) ?_ + refine Eq.trans (eq_whisker (Category.assoc _ _ _) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine whisker_eq _ ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp P.X _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => P.X ◁ t) + (whiskerLeft_modTensorπ_baseChangeAct φ N)) _) ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp P.X _ _) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (whiskerLeft_collapseMid A B φ P N) + refine hL.trans (Eq.trans ?_ hR.symm) + rw [collapseCover] + have hAA : (P.X ◁ μ[B]) ≫ actRight B P.X = + (α_ P.X B B).inv ≫ (actRight B P.X ▷ B) ≫ + actRight B P.X := by + rw [actRight_actRight, Iso.inv_hom_id_assoc] + conv_lhs => rw [associator_inv_naturality_left_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, + actRight_actRight] + conv_rhs => rw [MonoidalCategory.whiskerLeft_comp, + Category.assoc, associator_inv_naturality_middle_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, hAA] + simp only [MonoidalCategory.comp_whiskerRight, + Category.assoc] + rw [reassoc_of% (show (α_ (P.X ⊗ B) B N.X).inv ≫ + ((α_ P.X B B).hom ▷ N.X) = + (α_ P.X B (B ⊗ N.X)).hom ≫ (P.X ◁ (α_ B B N.X).inv) ≫ + (α_ P.X (B ⊗ B) N.X).inv + from by monoidal)] + rw [← MonoidalCategory.comp_whiskerRight_assoc, hAA] + simp only [MonoidalCategory.comp_whiskerRight, + Category.assoc] + +/-- **The collapse**: the relative tensor over the new base with +an induced module collapses onto the relative tensor over the old +base of the restricted module. -/ +noncomputable def collapseHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (P : Mod D B) (N : Mod D A) : + modTensor B P (baseChangeMod φ N) ⟶ + modTensor A (restrictMod A B φ P) N := + modTensorDesc B P (baseChangeMod φ N) + (collapseMid A B φ P N) (collapseMid_cond A B φ P N) + +/-- Defining equation of the collapse. -/ +@[reassoc (attr := simp)] +theorem modTensorπ_collapseHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (P : Mod D B) (N : Mod D A) : + modTensorπ B P (baseChangeMod φ N) ≫ + collapseHom A B φ P N = collapseMid A B φ P N := + modTensorπ_desc B P (baseChangeMod φ N) _ _ + +/-- The unit insertion into the induced module. -/ +noncomputable def unitSlot + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (B : D) [MonObj B] (φ : A ⟶ B) + [IsMonHom φ] (N : Mod D A) : N.X ⟶ baseChange φ N := + (λ_ N.X).inv ≫ (η[B] ▷ N.X) ≫ + modTensorπ A (restrictRegular φ) N + +/-- Acting before the unit insertion is acting through the base +morphism after it: the balance of the induced module at the +unit. -/ +theorem actLeft_unitSlot + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (B : D) [MonObj B] + [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] (N : Mod D A) : + actLeft A N.X ≫ unitSlot A B φ N = + (φ ▷ N.X) ≫ modTensorπ A (restrictRegular φ) N := by + have h := modTensor_condition A (restrictRegular φ) N + have h1 : modTensorLegM A (restrictRegular φ) N = + ((B ◁ φ) ≫ μ[B]) ▷ N.X := + congrArg (· ▷ N.X) (actRight_restrictRegular φ) + have h2 : modTensorLegN A (restrictRegular φ) N = + (α_ B A N.X).hom ≫ (B ◁ actLeft A N.X) := rfl + rw [h1, h2] at h + have hi := congrArg (fun t => + (((λ_ A).inv ≫ (η[B] ▷ A)) ▷ N.X) ≫ t) h + simp only [Category.assoc] at hi + rw [← MonoidalCategory.comp_whiskerRight_assoc] at hi + rw [show ((λ_ A).inv ≫ (η[B] ▷ A)) ≫ (B ◁ φ) ≫ μ[B] = + φ ≫ (λ_ B).inv ≫ (η[B] ▷ B) ≫ μ[B] from by + simp only [Category.assoc] + rw [← whisker_exchange_assoc, + leftUnitor_inv_naturality_assoc]] at hi + rw [MonObj.one_mul, Iso.inv_hom_id, Category.comp_id] at hi + have hR2 : (((λ_ A).inv ≫ (η[B] ▷ A)) ▷ N.X) ≫ + (α_ B A N.X).hom ≫ (B ◁ actLeft A N.X) ≫ + modTensorπ A (restrictRegular φ) N = + actLeft A N.X ≫ unitSlot A B φ N := by + rw [MonoidalCategory.comp_whiskerRight, Category.assoc, + associator_naturality_left_assoc, + ← whisker_exchange_assoc] + rw [reassoc_of% (show ((λ_ A).inv ▷ N.X) ≫ + (α_ (𝟙_ D) A N.X).hom = (λ_ (A ⊗ N.X)).inv + from by monoidal)] + rw [← leftUnitor_inv_naturality_assoc, unitSlot] + rfl + exact (hi.trans hR2).symm + +/-- Acting on the unit insertion is the projection: the inserted +unit is absorbed by the action. -/ +theorem whiskerLeft_unitSlot_baseChangeAct + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (N : Mod D A) : + (B ◁ unitSlot A B φ N) ≫ baseChangeAct φ N = + modTensorπ A (restrictRegular φ) N := by + have hcoh : ((B ◁ (λ_ N.X).inv) ≫ (B ◁ (η[B] ▷ N.X))) ≫ + ((α_ B B N.X).inv ≫ (μ[B] ▷ N.X)) = 𝟙 (B ⊗ N.X) := by + simp only [Category.assoc] + rw [associator_inv_naturality_middle_assoc, + ← MonoidalCategory.comp_whiskerRight, + MonObj.mul_one] + monoidal + erw [unitSlot, MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + Category.assoc] + refine Eq.trans (whisker_eq _ (whisker_eq _ + (whiskerLeft_modTensorπ_baseChangeAct φ N))) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker hcoh _) ?_ + exact Category.id_comp _ + +/-- The projection of the new-base tensor, retyped at the +induced-module carrier. -/ +noncomputable def bcπ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (P : Mod D B) (N : Mod D A) : P.X ⊗ baseChange φ N ⟶ + modTensor B P (baseChangeMod φ N) := + modTensorπ B P (baseChangeMod φ N) + +/-- The balance of the new-base tensor, in the retyped +spelling. -/ +theorem bcπ_cond [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (P : Mod D B) (N : Mod D A) : + (actRight B P.X ▷ baseChange φ N) ≫ bcπ A B φ P N = + (α_ P.X B (baseChange φ N)).hom ≫ + (P.X ◁ baseChangeAct φ N) ≫ bcπ A B φ P N := by + have h := modTensor_condition B P (baseChangeMod φ N) + rw [modTensorLegM, modTensorLegN, Category.assoc] at h + exact h + +/-- The cover of the inverse collapse: insert the unit of the +new base and project. -/ +noncomputable def collapseInvCover + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (P : Mod D B) (N : Mod D A) : P.X ⊗ N.X ⟶ + modTensor B P (baseChangeMod φ N) := + (P.X ◁ unitSlot A B φ N) ≫ bcπ A B φ P N + +/-- The cover of the inverse collapse coequalizes the balance of +the restricted-module tensor: the old base enters the induced +factor through the unit insertion. -/ +theorem collapseInvCover_cond + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (P : Mod D B) (N : Mod D A) : + modTensorLegM A (restrictMod A B φ P) N ≫ + collapseInvCover A B φ P N = + modTensorLegN A (restrictMod A B φ P) N ≫ + collapseInvCover A B φ P N := by + have h1 : modTensorLegM A (restrictMod A B φ P) N = + ((P.X ◁ φ) ≫ actRight B P.X) ▷ N.X := + congrArg (· ▷ N.X) (actRight_restrictMod A B φ P) + have h2 : modTensorLegN A (restrictMod A B φ P) N = + (α_ P.X A N.X).hom ≫ (P.X ◁ actLeft A N.X) := rfl + have hin : (A ◁ unitSlot A B φ N) ≫ + ((φ ▷ baseChange φ N) ≫ baseChangeAct φ N) = + actLeft A N.X ≫ unitSlot A B φ N := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (whisker_exchange φ (unitSlot A B φ N)) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (whiskerLeft_unitSlot_baseChangeAct A B φ N)) ?_ + exact (actLeft_unitSlot A B φ N).symm + rw [h1, h2, collapseInvCover] + have hstep : (((P.X ◁ φ) ≫ actRight B P.X) ▷ + baseChange φ N) ≫ bcπ A B φ P N = + (α_ P.X A (baseChange φ N)).hom ≫ + (P.X ◁ ((φ ▷ baseChange φ N) ≫ + baseChangeAct φ N)) ≫ bcπ A B φ P N := by + refine Eq.trans (eq_whisker + (MonoidalCategory.comp_whiskerRight _ _ _) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (bcπ_cond A B φ P N)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (associator_naturality_middle P.X φ + (baseChange φ N)) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine whisker_eq _ ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + exact eq_whisker + (MonoidalCategory.whiskerLeft_comp P.X _ _).symm _ + have hstep2 : ((P.X ⊗ A) ◁ unitSlot A B φ N) ≫ + (α_ P.X A (baseChange φ N)).hom ≫ + (P.X ◁ ((φ ▷ baseChange φ N) ≫ + baseChangeAct φ N)) ≫ bcπ A B φ P N = + (α_ P.X A N.X).hom ≫ + (P.X ◁ (actLeft A N.X ≫ unitSlot A B φ N)) ≫ + bcπ A B φ P N := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (associator_naturality_right P.X A + (unitSlot A B φ N)) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine whisker_eq _ ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp P.X _ _).symm _) ?_ + exact eq_whisker (congrArg (fun t => P.X ◁ t) hin) _ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (whisker_exchange + ((P.X ◁ φ) ≫ actRight B P.X) + (unitSlot A B φ N)).symm _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ hstep) ?_ + refine Eq.trans hstep2 ?_ + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine whisker_eq _ ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp P.X _ _).symm _) ?_ + exact Eq.refl _ + +/-- **The inverse collapse**: descend the unit insertion. -/ +noncomputable def collapseInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (P : Mod D B) (N : Mod D A) : + modTensor A (restrictMod A B φ P) N ⟶ + modTensor B P (baseChangeMod φ N) := + modTensorDesc A (restrictMod A B φ P) N + (collapseInvCover A B φ P N) + (collapseInvCover_cond A B φ P N) + +/-- Defining equation of the inverse collapse. -/ +@[reassoc (attr := simp)] +theorem restrictπ_collapseInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (P : Mod D B) (N : Mod D A) : + restrictπ A B φ P N ≫ collapseInv A B φ P N = + collapseInvCover A B φ P N := + modTensorπ_desc A (restrictMod A B φ P) N _ _ + +/-- The inserted unit is absorbed by the half-descended +collapse. -/ +theorem whiskerLeft_unitSlot_collapseMid + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (P : Mod D B) (N : Mod D A) : + (P.X ◁ unitSlot A B φ N) ≫ collapseMid A B φ P N = + restrictπ A B φ P N := by + have hcoh : (P.X ◁ (λ_ N.X).inv) ≫ + ((P.X ◁ (η[B] ▷ N.X)) ≫ + ((α_ P.X B N.X).inv ≫ (actRight B P.X ▷ N.X))) = + 𝟙 (P.X ⊗ N.X) := by + rw [associator_inv_naturality_middle_assoc, + ← MonoidalCategory.comp_whiskerRight, actRight_one] + monoidal + erw [unitSlot, MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + Category.assoc] + refine Eq.trans (whisker_eq _ (whisker_eq _ + (whiskerLeft_collapseMid A B φ P N))) ?_ + rw [collapseCover] + refine Eq.trans (whisker_eq _ (whisker_eq _ + (Category.assoc _ _ _).symm)) ?_ + refine Eq.trans (whisker_eq _ + (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker hcoh _) ?_ + exact Category.id_comp _ + +/-- The collapse retracts the inverse collapse. -/ +@[reassoc (attr := simp)] +theorem collapseInv_collapseHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (P : Mod D B) (N : Mod D A) : + collapseInv A B φ P N ≫ collapseHom A B φ P N = + 𝟙 (modTensor A (restrictMod A B φ P) N) := by + apply modTensor_hom_ext A (restrictMod A B φ P) N + rw [Category.comp_id] + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (restrictπ_collapseInv A B φ P N) _) ?_ + rw [collapseInvCover] + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (modTensorπ_collapseHom A B φ P N)) ?_ + exact whiskerLeft_unitSlot_collapseMid A B φ P N + +/-- The inverse collapse retracts the collapse. -/ +@[reassoc (attr := simp)] +theorem collapseHom_collapseInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (P : Mod D B) (N : Mod D A) : + collapseHom A B φ P N ≫ collapseInv A B φ P N = + 𝟙 (modTensor B P (baseChangeMod φ N)) := by + apply modTensor_hom_ext B P (baseChangeMod φ N) + rw [Category.comp_id] + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (modTensorπ_collapseHom A B φ P N) _) ?_ + apply modTensor_whisker_hom_ext A (restrictRegular φ) N P.X + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (whiskerLeft_collapseMid A B φ P N) _) ?_ + rw [collapseCover] + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (restrictπ_collapseInv A B φ P N))) ?_ + rw [collapseInvCover] + refine Eq.trans (whisker_eq _ + (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + (whisker_exchange (actRight B P.X) + (unitSlot A B φ N)).symm _)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (bcπ_cond A B φ P N))) ?_ + refine Eq.trans (whisker_eq _ + (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + (associator_naturality_right P.X B + (unitSlot A B φ N)) _)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (Iso.inv_hom_id _) _) ?_ + refine Eq.trans (Category.id_comp _) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp P.X _ _).symm _) ?_ + exact eq_whisker (congrArg (fun t => P.X ◁ t) + (whiskerLeft_unitSlot_baseChangeAct A B φ N)) _ + +/-- **The change-of-rings collapse**, packaged. -/ +noncomputable def collapseIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (P : Mod D B) (N : Mod D A) : + modTensor B P (baseChangeMod φ N) ≅ + modTensor A (restrictMod A B φ P) N where + hom := collapseHom A B φ P N + inv := collapseInv A B φ P N + hom_inv_id := collapseHom_collapseInv A B φ P N + inv_hom_id := collapseInv_collapseHom A B φ P N + +/-- The restricted action of a base change is the descended +module action on the relative tensor. -/ +theorem actLeft_restrict_baseChange + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + (M : Mod D A) : + (φ ▷ baseChange φ M) ≫ baseChangeAct φ M = + modTensorAct A (restrictRegular φ) M := by + apply modTensor_whisker_hom_ext A (restrictRegular φ) M A + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (whisker_exchange φ + (modTensorπ A (restrictRegular φ) M)) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (whiskerLeft_modTensorπ_baseChangeAct φ M)) ?_ + refine Eq.symm ?_ + refine Eq.trans + (whiskerLeft_modTensorπ_act A (restrictRegular φ) M) ?_ + have hact : (letI := ModObj.regular B; + letI := Mod.scalarRestriction φ B; actLeft A B) = + (φ ▷ B) ≫ μ[B] := rfl + refine Eq.trans (eq_whisker (whisker_eq _ + (congrArg (· ▷ M.X) hact)) _) ?_ + rw [MonoidalCategory.comp_whiskerRight] + refine Eq.trans (eq_whisker + (Category.assoc _ _ _).symm _) ?_ + refine Eq.trans (eq_whisker (eq_whisker + (associator_inv_naturality_left φ B M.X).symm _) _) ?_ + exact Eq.trans (eq_whisker (Category.assoc + (φ ▷ (B ⊗ M.X)) (α_ B B M.X).inv (μ[B] ▷ M.X)) + (modTensorπ A (restrictRegular φ) M)) + (Category.assoc (φ ▷ (B ⊗ M.X)) + ((α_ B B M.X).inv ≫ (μ[B] ▷ M.X)) + (modTensorπ A (restrictRegular φ) M)) + +/-- Bundled modules with the same carrier and the same action +are equal. -/ +private theorem mod_ext [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + {X : D} (i₁ i₂ : ModObj A X) + (h : i₁.smul = i₂.smul) : + (letI := i₁; (⟨X⟩ : Mod D A)) = + (letI := i₂; (⟨X⟩ : Mod D A)) := by + cases i₁; cases i₂ + cases h + rfl + +/-- **The restricted base change is the module tensor with the +restricted regular module.** -/ +theorem restrictMod_baseChange_eq + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + (M : Mod D A) : + restrictMod A B φ (baseChangeMod φ M) = + modTensorMod A (restrictRegular φ) M := + mod_ext A _ _ (actLeft_restrict_baseChange A B φ M) + +/-- **The projection formula**: the relative tensor over the new +base of two base changes is the base change of the relative +tensor. -/ +noncomputable def projFormula + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + (M N : Mod D A) : + modTensor B (baseChangeMod φ M) (baseChangeMod φ N) ≅ + baseChange φ (modTensorMod A M N) := + (collapseIso A B φ (baseChangeMod φ M) N).trans + ((eqToIso (congrArg (fun P => modTensor A P N) + (restrictMod_baseChange_eq A B φ M))).trans + (modTensorAssocIso A (restrictRegular φ) M N)) + +section Datum + +/-- **The base change of the pairing**: collapse, apply the +pairing under the base, and collapse the regular module. -/ +noncomputable def baseChangePair + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + modTensor B (baseChangeMod φ M') + (baseChangeMod φ M) ⟶ B := + (projFormula A B φ M' M).hom ≫ + modTensorMap A (𝟙 (restrictRegular φ)) (d.pairMod) ≫ + (modTensorUnitRight A (restrictRegular φ)).hom + +/-- **The base change of the copairing.** -/ +noncomputable def baseChangeCopair + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + B ⟶ modTensor B (baseChangeMod φ M) + (baseChangeMod φ M') := + (modTensorUnitRight A (restrictRegular φ)).inv ≫ + modTensorMap A (𝟙 (restrictRegular φ)) (d.copairMod) ≫ + (projFormula A B φ M M').inv + +end Datum + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTransport.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTransport.lean new file mode 100644 index 0000000000..5261657092 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTransport.lean @@ -0,0 +1,638 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeZigzag +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagSandwich + +/-! +# Transport of the zigzag laws along base change + +Base change is a strong monoidal functor on modules, and the +zigzag laws of a duality datum are an identity between words in +the monoidal structure. This file transports the identity: the +base-changed insertion and contraction are the images of the +insertion and contraction, conjugated by the structure map, so +their composite is the image of an identity. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +section Bundled + +/-- Functoriality of the relative tensor of morphisms. -/ +theorem modTensorMapMod_comp + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] + {M M' M'' N N' N'' : Mod D A} + (f : M ⟶ M') (f' : M' ⟶ M'') (g : N ⟶ N') + (g' : N' ⟶ N'') : + modTensorMapMod A f g ≫ modTensorMapMod A f' g' = + modTensorMapMod A (f ≫ f') (g ≫ g') := + Mod.Hom.ext (modTensorMap_comp A f f' g g').symm + +/-- The right unit coherence, as an identity of module maps. -/ +theorem projFormulaMod_unitRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] (M : Mod D A) : + (projFormulaMod A B φ M (regularMod A)).hom ≫ + baseChangeMapMod A B φ + (modTensorUnitRightMod A M).hom = + modTensorMapMod B (𝟙 (baseChangeMod φ M)) + (baseChangeUnitIso A B φ).hom ≫ + (modTensorUnitRightMod B (baseChangeMod φ M)).hom := + Mod.Hom.ext (projFormula_unitRight A B φ M) + +/-- The left unit coherence, as an identity of module maps. -/ +theorem projFormulaMod_unitLeft + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] (N : Mod D A) : + (projFormulaMod A B φ (regularMod A) N).hom ≫ + baseChangeMapMod A B φ + (modTensorUnitLeftMod A N).hom = + modTensorMapMod B (baseChangeUnitIso A B φ).hom + (𝟙 (baseChangeMod φ N)) ≫ + (modTensorUnitLeftMod B (baseChangeMod φ N)).hom := + Mod.Hom.ext (projFormula_unitLeft A B φ N) + +/-- Naturality in the first slot, as an identity of module +maps. -/ +theorem projFormulaMod_natural_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + {M M' : Mod D A} + (f : M ⟶ M') (N : Mod D A) : + modTensorMapMod B (baseChangeMapMod A B φ f) + (𝟙 (baseChangeMod φ N)) ≫ + (projFormulaMod A B φ M' N).hom = + (projFormulaMod A B φ M N).hom ≫ + baseChangeMapMod A B φ (modTensorMapMod A f (𝟙 N)) := + Mod.Hom.ext (projFormula_natural_left A B φ f N) + +/-- Naturality in the second slot, as an identity of module +maps. -/ +theorem projFormulaMod_natural_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + (M : Mod D A) + {N N' : Mod D A} (g : N ⟶ N') : + modTensorMapMod B (𝟙 (baseChangeMod φ M)) + (baseChangeMapMod A B φ g) ≫ + (projFormulaMod A B φ M N').hom = + (projFormulaMod A B φ M N).hom ≫ + baseChangeMapMod A B φ (modTensorMapMod A (𝟙 M) g) := + Mod.Hom.ext (projFormula_natural_right A B φ M g) + +/-- The associator coherence, as an identity of module maps. -/ +theorem projFormulaMod_assoc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] (M : Mod D A) (N : Mod D A) (P : Mod D A) : + modTensorMapMod B (projFormulaMod A B φ M N).hom + (𝟙 (baseChangeMod φ P)) ≫ + (projFormulaMod A B φ (modTensorMod A M N) P).hom ≫ + baseChangeMapMod A B φ + (modTensorAssocModIso A M N P).hom = + (modTensorAssocModIso B (baseChangeMod φ M) + (baseChangeMod φ N) (baseChangeMod φ P)).hom ≫ + modTensorMapMod B (𝟙 (baseChangeMod φ M)) + (projFormulaMod A B φ N P).hom ≫ + (projFormulaMod A B φ M (modTensorMod A N P)).hom := + Mod.Hom.ext (projFormula_assoc A B φ M N P) + +end Bundled + +section Datum + +/-- The base-changed pairing, as the image of the pairing +conjugated by the structure map and the unit. -/ +theorem pairMod_baseChangeDatum + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + (baseChangeDatum A B φ d).pairMod = + (projFormulaMod A B φ M' M).hom ≫ + baseChangeMapMod A B φ (d.pairMod) ≫ + (baseChangeUnitIso A B φ).hom := + Mod.Hom.ext rfl + +/-- The base-changed copairing, as the image of the copairing +conjugated by the unit and the structure map. -/ +theorem copairMod_baseChangeDatum + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + (baseChangeDatum A B φ d).copairMod = + (baseChangeUnitIso A B φ).inv ≫ + baseChangeMapMod A B φ (d.copairMod) ≫ + (projFormulaMod A B φ M M').inv := + Mod.Hom.ext rfl + +/-- Base change on morphisms preserves composition. -/ +theorem baseChangeMapMod_comp + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] + {X Y Z : Mod D A} (f : X ⟶ Y) + (g : Y ⟶ Z) : + baseChangeMapMod A B φ (f ≫ g) = + baseChangeMapMod A B φ f ≫ baseChangeMapMod A B φ g := + Mod.Hom.ext (by + have h := modTensorMap_comp A (𝟙 (restrictRegular φ)) + (𝟙 (restrictRegular φ)) f g + rw [Category.comp_id] at h + exact h) + +/-- Base change on morphisms preserves identities. -/ +theorem baseChangeMapMod_id + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] + (X : Mod D A) : + baseChangeMapMod A B φ (𝟙 X) = 𝟙 (baseChangeMod φ X) := + Mod.Hom.ext (by + change modTensorMap A (𝟙 (restrictRegular φ)) (𝟙 X) = _ + rw [modTensorMap_id, Mod.id_hom'] + rfl) + +section Transport + +/-- Composing two relative tensors of morphisms with identity +second slots. -/ +theorem modTensorMapMod_compL + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (B : D) [MonObj B] [IsCommMonObj B] + {X Y Z W : Mod D B} (f : X ⟶ Y) + (g : Y ⟶ Z) : + modTensorMapMod B f (𝟙 W) ≫ modTensorMapMod B g (𝟙 W) = + modTensorMapMod B (f ≫ g) (𝟙 W) := by + rw [modTensorMapMod_comp, Category.comp_id] + +/-- Composing two relative tensors of morphisms with identity +first slots. -/ +theorem modTensorMapMod_compR + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (B : D) [MonObj B] [IsCommMonObj B] + {W X Y Z : Mod D B} (f : X ⟶ Y) + (g : Y ⟶ Z) : + modTensorMapMod B (𝟙 W) f ≫ modTensorMapMod B (𝟙 W) g = + modTensorMapMod B (𝟙 W) (f ≫ g) := by + rw [modTensorMapMod_comp, Category.comp_id] + +/-- The relative tensor with two identities is the identity. -/ +theorem modTensorMapMod_id + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (B : D) [MonObj B] [IsCommMonObj B] + (X W : Mod D B) : + modTensorMapMod B (𝟙 X) (𝟙 W) = 𝟙 (modTensorMod B X W) := + Mod.Hom.ext (by + change modTensorMap B (𝟙 X) (𝟙 W) = _ + rw [modTensorMap_id, Mod.id_hom'] + rfl) + +/-- **The insertion transports**: the base-changed sandwich +insertion, conjugated by the structure map, is the image of the +insertion. -/ +theorem baseChange_sandwichIns + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + sandwichIns B (baseChangeDatum A B φ d) ≫ + modTensorMapMod B (projFormulaMod A B φ M M').hom + (𝟙 (baseChangeMod φ M)) ≫ + (projFormulaMod A B φ (modTensorMod A M M') M).hom = + baseChangeMapMod A B φ (sandwichIns A d) := by + have hins : sandwichIns B (baseChangeDatum A B φ d) = + (modTensorUnitLeftMod B (baseChangeMod φ M)).inv ≫ + modTensorMapMod B + ((baseChangeDatum A B φ d).copairMod) + (𝟙 (baseChangeMod φ M)) := rfl + have hunit : (modTensorUnitLeftMod B + (baseChangeMod φ M)).inv ≫ + modTensorMapMod B (baseChangeUnitIso A B φ).inv + (𝟙 (baseChangeMod φ M)) = + baseChangeMapMod A B φ + (modTensorUnitLeftMod A M).inv ≫ + (projFormulaMod A B φ (regularMod A) M).inv := by + have hiso : (projFormulaMod A B φ (regularMod A) M).trans + (baseChangeMapIso A B φ + (modTensorUnitLeftMod A M)) = + Iso.trans + { hom := modTensorMapMod B + (baseChangeUnitIso A B φ).hom + (𝟙 (baseChangeMod φ M)) + inv := modTensorMapMod B + (baseChangeUnitIso A B φ).inv + (𝟙 (baseChangeMod φ M)) + hom_inv_id := by + rw [modTensorMapMod_compL, Iso.hom_inv_id, + modTensorMapMod_id] + inv_hom_id := by + rw [modTensorMapMod_compL, Iso.inv_hom_id, + modTensorMapMod_id] } + (modTensorUnitLeftMod B (baseChangeMod φ M)) := + Iso.ext (projFormulaMod_unitLeft A B φ M) + have hinv := congrArg Iso.inv hiso + simp only [Iso.trans_inv] at hinv + exact hinv.symm + have hnat := projFormulaMod_natural_left A B φ + (d.copairMod) M + have step1 : sandwichIns B (baseChangeDatum A B φ d) ≫ + modTensorMapMod B (projFormulaMod A B φ M M').hom + (𝟙 (baseChangeMod φ M)) = + (modTensorUnitLeftMod B (baseChangeMod φ M)).inv ≫ + modTensorMapMod B (baseChangeUnitIso A B φ).inv + (𝟙 (baseChangeMod φ M)) ≫ + modTensorMapMod B + (baseChangeMapMod A B φ (d.copairMod)) + (𝟙 (baseChangeMod φ M)) := by + rw [hins, copairMod_baseChangeDatum, Category.assoc] + refine whisker_eq _ ?_ + rw [modTensorMapMod_compL, modTensorMapMod_compL] + refine congrArg (fun t => modTensorMapMod B t + (𝟙 (baseChangeMod φ M))) ?_ + rw [Category.assoc, Category.assoc, Iso.inv_hom_id, + Category.comp_id] + rw [← Category.assoc, step1] + simp only [Category.assoc] + rw [← Category.assoc, hunit] + simp only [Category.assoc] + rw [hnat, Iso.inv_hom_id_assoc, ← baseChangeMapMod_comp] + rfl + +/-- **The contraction transports**: the conjugated image of the +sandwich contraction is the base-changed contraction. -/ +theorem baseChange_sandwichCon + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + (modTensorMapMod B (projFormulaMod A B φ M M').hom + (𝟙 (baseChangeMod φ M)) ≫ + (projFormulaMod A B φ (modTensorMod A M M') M).hom) ≫ + baseChangeMapMod A B φ (sandwichCon A d) = + sandwichCon B (baseChangeDatum A B φ d) := by + have hcon : baseChangeMapMod A B φ (sandwichCon A d) = + baseChangeMapMod A B φ + (modTensorAssocModIso A M M' M).hom ≫ + baseChangeMapMod A B φ + (modTensorMapMod A (𝟙 M) (d.pairMod)) ≫ + baseChangeMapMod A B φ + (modTensorUnitRightMod A M).hom := by + rw [← baseChangeMapMod_comp, ← baseChangeMapMod_comp] + rfl + have hRHS : sandwichCon B (baseChangeDatum A B φ d) = + (modTensorAssocModIso B (baseChangeMod φ M) + (baseChangeMod φ M') (baseChangeMod φ M)).hom ≫ + modTensorMapMod B (𝟙 (baseChangeMod φ M)) + (projFormulaMod A B φ M' M).hom ≫ + modTensorMapMod B (𝟙 (baseChangeMod φ M)) + (baseChangeMapMod A B φ (d.pairMod)) ≫ + modTensorMapMod B (𝟙 (baseChangeMod φ M)) + (baseChangeUnitIso A B φ).hom ≫ + (modTensorUnitRightMod B (baseChangeMod φ M)).hom := by + change (modTensorAssocModIso B (baseChangeMod φ M) + (baseChangeMod φ M') (baseChangeMod φ M)).hom ≫ + modTensorMapMod B (𝟙 (baseChangeMod φ M)) + ((baseChangeDatum A B φ d).pairMod) ≫ + (modTensorUnitRightMod B (baseChangeMod φ M)).hom = _ + rw [pairMod_baseChangeDatum, ← modTensorMapMod_compR, + ← modTensorMapMod_compR] + simp only [Category.assoc] + rw [hcon, hRHS] + simp only [Category.assoc] + rw [(reassoc_of% (projFormulaMod_assoc A B φ M M' M))] + rw [← Category.assoc + (projFormulaMod A B φ M (modTensorMod A M' M)).hom, + ← projFormulaMod_natural_right A B φ M (d.pairMod), + Category.assoc, projFormulaMod_unitRight A B φ M] + +/-- **The zig triangle transports**: the base-changed datum +satisfies the sandwich retract identity. -/ +theorem baseChange_sandwich_zig + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') + (hz : ModZigzagDatum A d) : + sandwichIns B (baseChangeDatum A B φ d) ≫ + sandwichCon B (baseChangeDatum A B φ d) = + 𝟙 (baseChangeMod φ M) := by + rw [← baseChange_sandwichCon A B φ d, ← Category.assoc, + baseChange_sandwichIns A B φ d, ← baseChangeMapMod_comp, + (sandwich_zig_iff A d).mpr (zigzag_carrier_zig A hz), + baseChangeMapMod_id] + +/-- **The carrier zig law of the base-changed datum.** -/ +theorem baseChange_carrier_zig + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') + (hz : ModZigzagDatum A d) : + (λ_ (baseChangeMod φ M).X).inv ≫ + ((η[B] ≫ (baseChangeDatum A B φ d).copair) ▷ + (baseChangeMod φ M).X) ≫ + zigContract B (baseChangeDatum A B φ d).pair + (baseChangeDatum A B φ d).pair_linear = + 𝟙 (baseChangeMod φ M).X := + (sandwich_zig_iff B (baseChangeDatum A B φ d)).mp + (baseChange_sandwich_zig A B φ d hz) + +/-- **The dual insertion transports**. -/ +theorem baseChange_sandwichInsR + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + sandwichInsR B (baseChangeDatum A B φ d) ≫ + modTensorMapMod B (𝟙 (baseChangeMod φ M')) + (projFormulaMod A B φ M M').hom ≫ + (projFormulaMod A B φ M' (modTensorMod A M M')).hom = + baseChangeMapMod A B φ (sandwichInsR A d) := by + have hins : sandwichInsR B (baseChangeDatum A B φ d) = + (modTensorUnitRightMod B (baseChangeMod φ M')).inv ≫ + modTensorMapMod B (𝟙 (baseChangeMod φ M')) + ((baseChangeDatum A B φ d).copairMod) := rfl + have hunit : (modTensorUnitRightMod B + (baseChangeMod φ M')).inv ≫ + modTensorMapMod B (𝟙 (baseChangeMod φ M')) + (baseChangeUnitIso A B φ).inv = + baseChangeMapMod A B φ + (modTensorUnitRightMod A M').inv ≫ + (projFormulaMod A B φ M' (regularMod A)).inv := by + have hiso : (projFormulaMod A B φ M' (regularMod A)).trans + (baseChangeMapIso A B φ + (modTensorUnitRightMod A M')) = + Iso.trans + { hom := modTensorMapMod B + (𝟙 (baseChangeMod φ M')) + (baseChangeUnitIso A B φ).hom + inv := modTensorMapMod B + (𝟙 (baseChangeMod φ M')) + (baseChangeUnitIso A B φ).inv + hom_inv_id := by + rw [modTensorMapMod_compR, Iso.hom_inv_id, + modTensorMapMod_id] + inv_hom_id := by + rw [modTensorMapMod_compR, Iso.inv_hom_id, + modTensorMapMod_id] } + (modTensorUnitRightMod B (baseChangeMod φ M')) := + Iso.ext (projFormulaMod_unitRight A B φ M') + have hinv := congrArg Iso.inv hiso + simp only [Iso.trans_inv] at hinv + exact hinv.symm + have hnat := projFormulaMod_natural_right A B φ M' + (d.copairMod) + have step1 : sandwichInsR B (baseChangeDatum A B φ d) ≫ + modTensorMapMod B (𝟙 (baseChangeMod φ M')) + (projFormulaMod A B φ M M').hom = + (modTensorUnitRightMod B (baseChangeMod φ M')).inv ≫ + modTensorMapMod B (𝟙 (baseChangeMod φ M')) + (baseChangeUnitIso A B φ).inv ≫ + modTensorMapMod B (𝟙 (baseChangeMod φ M')) + (baseChangeMapMod A B φ (d.copairMod)) := by + rw [hins, copairMod_baseChangeDatum, Category.assoc] + refine whisker_eq _ ?_ + rw [modTensorMapMod_compR, modTensorMapMod_compR] + refine congrArg (fun t => modTensorMapMod B + (𝟙 (baseChangeMod φ M')) t) ?_ + rw [Category.assoc, Category.assoc, Iso.inv_hom_id, + Category.comp_id] + rw [← Category.assoc, step1] + simp only [Category.assoc] + rw [← Category.assoc, hunit] + simp only [Category.assoc] + rw [hnat, Iso.inv_hom_id_assoc, ← baseChangeMapMod_comp] + rfl + +/-- **The dual contraction transports**. -/ +theorem baseChange_sandwichConR + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + (modTensorMapMod B (𝟙 (baseChangeMod φ M')) + (projFormulaMod A B φ M M').hom ≫ + (projFormulaMod A B φ M' (modTensorMod A M M')).hom) ≫ + baseChangeMapMod A B φ (sandwichConR A d) = + sandwichConR B (baseChangeDatum A B φ d) := by + have hassocInv : modTensorMapMod B + (𝟙 (baseChangeMod φ M')) + (projFormulaMod A B φ M M').hom ≫ + (projFormulaMod A B φ M' (modTensorMod A M M')).hom ≫ + baseChangeMapMod A B φ + (modTensorAssocModIso A M' M M').inv = + (modTensorAssocModIso B (baseChangeMod φ M') + (baseChangeMod φ M) (baseChangeMod φ M')).inv ≫ + modTensorMapMod B (projFormulaMod A B φ M' M).hom + (𝟙 (baseChangeMod φ M')) ≫ + (projFormulaMod A B φ (modTensorMod A M' M) M').hom := by + have h1 : (modTensorAssocModIso B (baseChangeMod φ M') + (baseChangeMod φ M) (baseChangeMod φ M')).hom ≫ + modTensorMapMod B (𝟙 (baseChangeMod φ M')) + (projFormulaMod A B φ M M').hom ≫ + (projFormulaMod A B φ M' (modTensorMod A M M')).hom ≫ + baseChangeMapMod A B φ + (modTensorAssocModIso A M' M M').inv = + modTensorMapMod B (projFormulaMod A B φ M' M).hom + (𝟙 (baseChangeMod φ M')) ≫ + (projFormulaMod A B φ + (modTensorMod A M' M) M').hom := by + have hc := congrArg (fun t => t ≫ baseChangeMapMod A B φ + (modTensorAssocModIso A M' M M').inv) + (projFormulaMod_assoc A B φ M' M M') + simp only [Category.assoc] at hc + rw [← baseChangeMapMod_comp, Iso.hom_inv_id, + baseChangeMapMod_id, Category.comp_id] at hc + exact hc.symm + rw [← h1, Iso.inv_hom_id_assoc] + have hcon : baseChangeMapMod A B φ (sandwichConR A d) = + baseChangeMapMod A B φ + (modTensorAssocModIso A M' M M').inv ≫ + baseChangeMapMod A B φ + (modTensorMapMod A (d.pairMod) (𝟙 M')) ≫ + baseChangeMapMod A B φ + (modTensorUnitLeftMod A M').hom := by + rw [← baseChangeMapMod_comp, ← baseChangeMapMod_comp] + rfl + have hRHS : sandwichConR B (baseChangeDatum A B φ d) = + (modTensorAssocModIso B (baseChangeMod φ M') + (baseChangeMod φ M) (baseChangeMod φ M')).inv ≫ + modTensorMapMod B (projFormulaMod A B φ M' M).hom + (𝟙 (baseChangeMod φ M')) ≫ + modTensorMapMod B + (baseChangeMapMod A B φ (d.pairMod)) + (𝟙 (baseChangeMod φ M')) ≫ + modTensorMapMod B (baseChangeUnitIso A B φ).hom + (𝟙 (baseChangeMod φ M')) ≫ + (modTensorUnitLeftMod B (baseChangeMod φ M')).hom := by + change (modTensorAssocModIso B (baseChangeMod φ M') + (baseChangeMod φ M) (baseChangeMod φ M')).inv ≫ + modTensorMapMod B + ((baseChangeDatum A B φ d).pairMod) + (𝟙 (baseChangeMod φ M')) ≫ + (modTensorUnitLeftMod B (baseChangeMod φ M')).hom = _ + rw [pairMod_baseChangeDatum, ← modTensorMapMod_compL, + ← modTensorMapMod_compL] + simp only [Category.assoc] + rw [hcon, hRHS] + simp only [Category.assoc] + rw [reassoc_of% hassocInv] + rw [← Category.assoc + (projFormulaMod A B φ (modTensorMod A M' M) M').hom, + ← projFormulaMod_natural_left A B φ (d.pairMod) M', + Category.assoc, projFormulaMod_unitLeft A B φ M'] + +/-- **The zag triangle transports**. -/ +theorem baseChange_sandwich_zag + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') + (hz : ModZigzagDatum A d) : + sandwichInsR B (baseChangeDatum A B φ d) ≫ + sandwichConR B (baseChangeDatum A B φ d) = + 𝟙 (baseChangeMod φ M') := by + rw [← baseChange_sandwichConR A B φ d, ← Category.assoc, + baseChange_sandwichInsR A B φ d, ← baseChangeMapMod_comp, + (sandwich_zag_iff A d).mpr (zigzag_carrier_zag A hz), + baseChangeMapMod_id] + +/-- **The carrier zag law of the base-changed datum.** -/ +theorem baseChange_carrier_zag + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') + (hz : ModZigzagDatum A d) : + (ρ_ (baseChangeMod φ M').X).inv ≫ + ((baseChangeMod φ M').X ◁ + (η[B] ≫ (baseChangeDatum A B φ d).copair)) ≫ + zagContract B (baseChangeDatum A B φ d).pair + (baseChangeDatum A B φ d).pair_linear = + 𝟙 (baseChangeMod φ M').X := + (sandwich_zag_iff B (baseChangeDatum A B φ d)).mp + (baseChange_sandwich_zag A B φ d hz) + +/-- **Base change preserves the zigzag laws.** -/ +theorem baseChange_modZigzagDatum + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') + (hz : ModZigzagDatum A d) : + ModZigzagDatum B (baseChangeDatum A B φ d) := + modZigzagDatum_of_carrier B + (baseChange_carrier_zig A B φ d hz) + (baseChange_carrier_zag A B φ d hz) + +end Transport + +end Datum + +section Statement + +variable (D) + +/-- **Base change preserves the zigzag laws**: the statement of +record, discharged. -/ +theorem baseChangeZigzag + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] : + BaseChangeZigzagStatement (D := D) := by + intro A _ _ M M' d hz B _ _ φ _ + exact baseChange_modZigzagDatum A B φ d hz + +end Statement + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeZigzag.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeZigzag.lean new file mode 100644 index 0000000000..89e223a222 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeZigzag.lean @@ -0,0 +1,45 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeDatum + +/-! +# The zigzag laws of a base-changed duality datum + +The statement that base change preserves the zigzag laws, named +so that the dévissage steps can refer to it directly. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **Base change preserves the zigzag laws**: the statement of +record for the dévissage steps. -/ +def BaseChangeZigzagStatement + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] : + Prop := + ∀ (A : D) (_ : MonObj A) (_ : IsCommMonObj A) + (M M' : Mod D A) (d : ModDualityDatum A M M') + (_ : ModZigzagDatum A d) + (B : D) (_ : MonObj B) (_ : IsCommMonObj B) + (φ : A ⟶ B) (_ : IsMonHom φ), + ModZigzagDatum B (baseChangeDatum A B φ d) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensor.lean new file mode 100644 index 0000000000..afb1fde45f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensor.lean @@ -0,0 +1,1186 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# The tensor product of an arbitrary family of monoid objects + +Infrastructure for Deligne's 2.11: in a braided monoidal category +`D` with filtered colimits, an arbitrary family `B : ι → D` of +(commutative) monoid objects has a tensor product, defined as the +filtered colimit of the tensor products of its finite +subfamilies. + +The index type carries a linear order, which fixes the ordering +of the tensor slots: the finite sub-tensor-product over +`s : Finset ι` is the fold of `B` over the sorted list of `s`. +For `s ⊆ t` there is an insertion morphism which places the unit +of the missing factors into the extra slots; these are the +transition maps of a `Finset ι`-shaped diagram, and the big +tensor product is its colimit. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +/- `open MonObj` would activate the scoped notation `ι` for +`GrpObj.inv`, clashing with our index type; we redeclare the unit +and multiplication notations locally instead. -/ +local notation "η[" M "]" => MonObj.one (X := M) +local notation "μ[" M "]" => MonObj.mul (X := M) + +universe v u + +variable {ι : Type v} +variable {D : Type u} + +/-! ## Finite tensor products -/ + +/-- The tensor product of the factors `B i` over a list of +indices, folded to the right with the unit object as seed. -/ +def listTensor [Category.{v} D] [MonoidalCategory D] + (B : ι → D) : List ι → D + | [] => 𝟙_ D + | i :: l => B i ⊗ listTensor B l + +@[simp] lemma listTensor_nil [Category.{v} D] [MonoidalCategory D] + (B : ι → D) : listTensor B [] = 𝟙_ D := rfl + +@[simp] lemma listTensor_cons [Category.{v} D] [MonoidalCategory D] + (B : ι → D) (i : ι) (l : List ι) : + listTensor B (i :: l) = B i ⊗ listTensor B l := rfl + +section LinearOrder + +/-- The tensor product of the factors `B i` over a finite set of +indices, in the slot order given by the linear order on `ι`. -/ +def finTensor [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + (B : ι → D) (s : Finset ι) : D := + listTensor B (s.sort (· ≤ ·)) + +@[simp] lemma finTensor_empty + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + (B : ι → D) : finTensor B ∅ = 𝟙_ D := by + simp [finTensor] + +@[simp] lemma finTensor_singleton + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + (B : ι → D) (i : ι) : + finTensor B {i} = B i ⊗ 𝟙_ D := by + simp [finTensor] + +end LinearOrder + +section Monoid + +/-- The finite tensor products of a family of monoid objects are +monoid objects, by folding the binary braided instance. -/ +instance listTensorMon [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (B : ι → D) [∀ i, MonObj (B i)] : + ∀ l : List ι, MonObj (listTensor B l) + | [] => inferInstanceAs (MonObj (𝟙_ D)) + | i :: l => + letI := listTensorMon B l + inferInstanceAs (MonObj (B i ⊗ listTensor B l)) + +instance finTensorMon [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [LinearOrder ι] (B : ι → D) [∀ i, MonObj (B i)] + (s : Finset ι) : + MonObj (finTensor B s) := + inferInstanceAs (MonObj (listTensor B (s.sort (· ≤ ·)))) + +end Monoid + +section CommMonoid + +/-- Finite tensor products of commutative monoid objects are +commutative, by folding the binary instance of the symmetric +category. -/ +instance listTensorCommMon + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (B : ι → D) [∀ i, MonObj (B i)] + [∀ i, IsCommMonObj (B i)] : + ∀ l : List ι, IsCommMonObj (listTensor B l) + | [] => inferInstanceAs (IsCommMonObj (𝟙_ D)) + | i :: l => + letI := listTensorCommMon B l + inferInstanceAs (IsCommMonObj (B i ⊗ listTensor B l)) + +instance finTensorCommMon + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [LinearOrder ι] (B : ι → D) + [∀ i, MonObj (B i)] [∀ i, IsCommMonObj (B i)] (s : Finset ι) : + IsCommMonObj (finTensor B s) := + inferInstanceAs (IsCommMonObj (listTensor B (s.sort (· ≤ ·)))) + +end CommMonoid + +/-! ## Insertion of units -/ + +/-- The unit `η[M] : 𝟙_ D ⟶ M` is a morphism of monoid objects +from the trivial monoid. -/ +instance isMonHom_one [Category.{v} D] [MonoidalCategory D] + (M : D) [MonObj M] : IsMonHom η[M] where + one_hom := by simp + mul_hom := by simp [unitors_equal] + +/-- Insertion of the unit of the monoid `M` in the front slot. -/ +def unitIncl [Category.{v} D] [MonoidalCategory D] + (M X : D) [MonObj M] : X ⟶ M ⊗ X := + (λ_ X).inv ≫ η[M] ▷ X + +lemma unitIncl_eq_tensorHom [Category.{v} D] [MonoidalCategory D] + (M X : D) [MonObj M] : + unitIncl M X = (λ_ X).inv ≫ (η[M] ⊗ₘ 𝟙 X) := by + simp [unitIncl] + +@[reassoc] +lemma unitIncl_naturality [Category.{v} D] [MonoidalCategory D] + (M : D) [MonObj M] {X Y : D} (f : X ⟶ Y) : + f ≫ unitIncl M Y = unitIncl M X ≫ (M ◁ f) := by + simp only [unitIncl, Category.assoc] + rw [leftUnitor_inv_naturality_assoc, whisker_exchange] + +instance isMonHom_unitIncl [Category.{v} D] [MonoidalCategory D] + [BraidedCategory D] (M X : D) [MonObj M] + [MonObj X] : IsMonHom (unitIncl M X) := by + rw [unitIncl_eq_tensorHom] + infer_instance + +/-! ## Inclusions of finite tensor products + +The inclusion of a sub-tensor-product is defined at the level of +lists: for a Boolean predicate `p`, the tensor product over +`l.filter p` maps into the tensor product over `l` by inserting +the unit of each factor whose index fails `p`. -/ + +section Insertion + +/-- Insertion morphism from the tensor product over the filtered +list into the tensor product over the full list, placing units in +the slots dropped by the filter. + +Convention: all stated morphisms have `listTensor`-form +endpoints; the tensor-shaped intermediate objects appear only +between explicit `eqToHom` guards, so that every composition in +the subsequent lemmas is well typed on the nose. -/ +def inclFilter + [Category.{v} D] [MonoidalCategory D] (B : ι → D) [∀ i, MonObj (B i)] + (p : ι → Bool) : + ∀ l : List ι, listTensor B (l.filter p) ⟶ listTensor B l + | [] => 𝟙 _ + | i :: l => + if h : p i then + eqToHom (show listTensor B ((i :: l).filter p) = + B i ⊗ listTensor B (l.filter p) by + rw [List.filter_cons_of_pos h, listTensor_cons]) ≫ + (B i ◁ inclFilter B p l) ≫ + eqToHom (listTensor_cons B i l).symm + else + eqToHom (show listTensor B ((i :: l).filter p) = + listTensor B (l.filter p) by + rw [List.filter_cons_of_neg (by simp [h])]) ≫ + inclFilter B p l ≫ unitIncl (B i) (listTensor B l) ≫ + eqToHom (listTensor_cons B i l).symm + +@[simp] lemma inclFilter_nil + [Category.{v} D] [MonoidalCategory D] (B : ι → D) [∀ i, MonObj (B i)] + (p : ι → Bool) : + inclFilter B p [] = 𝟙 (𝟙_ D) := rfl + +lemma inclFilter_cons_pos + [Category.{v} D] [MonoidalCategory D] (B : ι → D) [∀ i, MonObj (B i)] + (p : ι → Bool) {i : ι} (l : List ι) + (h : p i) : + inclFilter B p (i :: l) = + eqToHom (show listTensor B ((i :: l).filter p) = + B i ⊗ listTensor B (l.filter p) by + rw [List.filter_cons_of_pos h, listTensor_cons]) ≫ + (B i ◁ inclFilter B p l) ≫ + eqToHom (listTensor_cons B i l).symm := by + rw [inclFilter, dite_eq_left h] + +lemma inclFilter_cons_neg + [Category.{v} D] [MonoidalCategory D] (B : ι → D) [∀ i, MonObj (B i)] + (p : ι → Bool) {i : ι} (l : List ι) + (h : ¬ p i) : + inclFilter B p (i :: l) = + eqToHom (show listTensor B ((i :: l).filter p) = + listTensor B (l.filter p) by + rw [List.filter_cons_of_neg (by simp [h])]) ≫ + inclFilter B p l ≫ unitIncl (B i) (listTensor B l) ≫ + eqToHom (listTensor_cons B i l).symm := by + rw [inclFilter, dite_eq_right h] + +/-- Equal index lists give equal (conjugated) insertions. -/ +lemma inclFilter_congr + [Category.{v} D] [MonoidalCategory D] (B : ι → D) [∀ i, MonObj (B i)] + (p : ι → Bool) {l₁ l₂ : List ι} (h : l₁ = l₂) : + inclFilter B p l₁ = + eqToHom (by rw [h]) ≫ inclFilter B p l₂ ≫ eqToHom (by rw [h]) := by + subst h + simp + +/-- Equal predicates give equal (transported) insertions. -/ +lemma inclFilter_congr_pred + [Category.{v} D] [MonoidalCategory D] (B : ι → D) [∀ i, MonObj (B i)] + {p q : ι → Bool} (h : p = q) + (l : List ι) : + inclFilter B p l = eqToHom (by rw [h]) ≫ inclFilter B q l := by + subst h + simp + +/-- Transporting along an equality of index lists is a morphism +of monoid objects. -/ +lemma isMonHom_eqToHom + [Category.{v} D] [MonoidalCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [BraidedCategory D] {l₁ l₂ : List ι} + (h : l₁ = l₂) (q : listTensor B l₁ = listTensor B l₂) : + IsMonHom (eqToHom q) := by + subst h + simp only [eqToHom_refl] + infer_instance + +/-- The insertions are morphisms of monoid objects. -/ +instance isMonHom_inclFilter + [Category.{v} D] [MonoidalCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [BraidedCategory D] (p : ι → Bool) : + ∀ l : List ι, IsMonHom (inclFilter B p l) + | [] => inferInstanceAs (IsMonHom (𝟙 (𝟙_ D))) + | i :: l => by + have := isMonHom_inclFilter B p l + have : IsMonHom (eqToHom (listTensor_cons B i l).symm) := + isMonHom_eqToHom B (l₁ := i :: l) (l₂ := i :: l) rfl + (listTensor_cons B i l).symm + by_cases h : p i + · rw [inclFilter_cons_pos B p l h] + have : IsMonHom (eqToHom + (show listTensor B ((i :: l).filter p) = + B i ⊗ listTensor B (l.filter p) by + rw [List.filter_cons_of_pos h, listTensor_cons])) := + isMonHom_eqToHom B (List.filter_cons_of_pos (p := p) h) + (by rw [List.filter_cons_of_pos h] : + listTensor B ((i :: l).filter p) = + listTensor B (i :: l.filter p)) + infer_instance + · rw [inclFilter_cons_neg B p l h] + have : IsMonHom (eqToHom + (show listTensor B ((i :: l).filter p) = + listTensor B (l.filter p) by + rw [List.filter_cons_of_neg (by simp [h])])) := + isMonHom_eqToHom B (List.filter_cons_of_neg + (by simp [h] : ¬ p i = true) (p := p)) + (by rw [List.filter_cons_of_neg (by simp [h])] : + listTensor B ((i :: l).filter p) = listTensor B (l.filter p)) + infer_instance + +/-- Inserting nothing: if every index passes the filter, the +insertion is the transport of the identity. -/ +lemma inclFilter_of_forall + [Category.{v} D] [MonoidalCategory D] (B : ι → D) [∀ i, MonObj (B i)] + (p : ι → Bool) : + ∀ (l : List ι) (h : ∀ i ∈ l, p i), + inclFilter B p l = eqToHom (by rw [List.filter_eq_self.mpr h]) + | [], _ => by rfl + | i :: l, h => by + rw [inclFilter_cons_pos B p l (h i (by simp)), + inclFilter_of_forall B p l (fun j hj => h j (by simp [hj]))] + simp only [whiskerLeft_eqToHom] + repeat' erw [eqToHom_trans] + +/-- The composition law for insertions: inserting the units of +`l.filter q` past `p` and then those of `l` past `q` is the +insertion past the conjunction. This is the coherence heart of +the transition maps of the big tensor product. -/ +lemma inclFilter_inclFilter + [Category.{v} D] [MonoidalCategory D] (B : ι → D) [∀ i, MonObj (B i)] + (p q : ι → Bool) : + ∀ l : List ι, + inclFilter B p (l.filter q) ≫ inclFilter B q l = + eqToHom (by rw [List.filter_filter]) ≫ + inclFilter B (fun i => p i && q i) l + | [] => by rfl + | i :: l => by + have IH := inclFilter_inclFilter B p q l + by_cases hq : q i + · have hfq : (i :: l).filter q = i :: l.filter q := + List.filter_cons_of_pos hq + by_cases hp : p i + · rw [inclFilter_congr B p hfq, + inclFilter_cons_pos B p (l.filter q) hp, + inclFilter_cons_pos B q l hq, + inclFilter_cons_pos B (fun j => p j && q j) l + (by simp [hp, hq])] + simp only [Category.assoc, eqToHom_trans_assoc, eqToHom_refl, + Category.id_comp] + rw [← MonoidalCategory.whiskerLeft_comp_assoc, IH] + simp + · rw [inclFilter_congr B p hfq, + inclFilter_cons_neg B p (l.filter q) hp, + inclFilter_cons_pos B q l hq, + inclFilter_cons_neg B (fun j => p j && q j) l + (by simp [hp])] + simp only [Category.assoc, eqToHom_trans_assoc, eqToHom_refl, + Category.id_comp] + slice_lhs 3 4 => rw [← unitIncl_naturality] + slice_lhs 2 3 => rw [IH] + simp + · have hfq : (i :: l).filter q = l.filter q := + List.filter_cons_of_neg (by simp [hq]) + rw [inclFilter_congr B p hfq, + inclFilter_cons_neg B q l (by simp [hq]), + inclFilter_cons_neg B (fun j => p j && q j) l + (by simp [hq])] + simp only [Category.assoc, eqToHom_trans_assoc, eqToHom_refl, + Category.id_comp] + slice_lhs 2 3 => rw [IH] + simp + +/-! Bridging lemmas for the units of the fold monoids. -/ + +/-- On a vanishing index list, the unit of the fold monoid is the +canonical identification with the monoidal unit. -/ +lemma listTensor_one_eq + [Category.{v} D] [MonoidalCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [BraidedCategory D] {l : List ι} (h : l = []) : + η[listTensor B l] = + eqToHom (show 𝟙_ D = listTensor B l by rw [h, listTensor_nil]) := by + subst h + rfl + +end Insertion + +/-! ## Inclusions between finite sub-tensor-products -/ + +section FinsetIncl + +/-- Sorting commutes with restriction: the sorted list of a +subset of `t` is the filtering of the sorted list of `t`. -/ +lemma sort_filter_of_subset [LinearOrder ι] + {s t : Finset ι} (h : s ⊆ t) : + (t.sort (· ≤ ·)).filter (fun i => decide (i ∈ s)) = + s.sort (· ≤ ·) := by + apply List.Perm.eq_of_pairwise' (r := (· ≤ ·)) + · exact (Finset.pairwise_sort t _).sublist List.filter_sublist + · exact Finset.pairwise_sort s _ + · rw [← Multiset.coe_eq_coe, ← Multiset.filter_coe, Finset.sort_eq, + Finset.sort_eq, ← Finset.filter_val, Finset.filter_mem_eq_inter, + Finset.inter_eq_right.mpr h] + +/-- The inclusion of the finite sub-tensor-product over `s ⊆ t`, +inserting the units of the factors missing from `s`. -/ +def finTensorIncl + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] (B : ι → D) + [∀ i, MonObj (B i)] + {s t : Finset ι} (h : s ⊆ t) : + finTensor B s ⟶ finTensor B t := + eqToHom (show finTensor B s = + listTensor B ((t.sort (· ≤ ·)).filter fun i => decide (i ∈ s)) by + rw [sort_filter_of_subset h]; rfl) ≫ + inclFilter B (fun i => decide (i ∈ s)) (t.sort (· ≤ ·)) ≫ + eqToHom (show listTensor B (t.sort (· ≤ ·)) = finTensor B t from rfl) + +@[simp] lemma finTensorIncl_refl + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] (B : ι → D) + [∀ i, MonObj (B i)] + (s : Finset ι) : + finTensorIncl B (subset_refl s) = 𝟙 (finTensor B s) := by + rw [finTensorIncl, inclFilter_of_forall B _ _ + (fun i hi => by simpa using hi)] + simp + +/-- Functoriality of the inclusions of sub-tensor-products. -/ +@[reassoc] +lemma finTensorIncl_trans + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] (B : ι → D) + [∀ i, MonObj (B i)] + {s t u : Finset ι} (hst : s ⊆ t) + (htu : t ⊆ u) : + finTensorIncl B hst ≫ finTensorIncl B htu = + finTensorIncl B (hst.trans htu) := by + rw [finTensorIncl, finTensorIncl, finTensorIncl, + inclFilter_congr B (fun i => decide (i ∈ s)) + (sort_filter_of_subset htu).symm] + simp only [Category.assoc, eqToHom_trans_assoc, eqToHom_refl, + Category.id_comp] + slice_lhs 2 3 => rw [inclFilter_inclFilter] + have hpq : (fun i => decide (i ∈ s) && decide (i ∈ t)) = + (fun i => decide (i ∈ s)) := funext fun i => by + by_cases hi : i ∈ s + · simp [hi, hst hi] + · simp [hi] + rw [inclFilter_congr_pred B hpq (u.sort (· ≤ ·))] + simp + +/-- The inclusions of sub-tensor-products are morphisms of monoid +objects. -/ +instance isMonHom_finTensorIncl + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] (B : ι → D) + [∀ i, MonObj (B i)] + [BraidedCategory D] {s t : Finset ι} + (h : s ⊆ t) : IsMonHom (finTensorIncl B h) := by + rw [finTensorIncl] + have : IsMonHom (eqToHom (show finTensor B s = + listTensor B ((t.sort (· ≤ ·)).filter fun i => decide (i ∈ s)) by + rw [sort_filter_of_subset h]; rfl)) := + isMonHom_eqToHom B (l₁ := s.sort (· ≤ ·)) + (l₂ := (t.sort (· ≤ ·)).filter fun i => decide (i ∈ s)) + (sort_filter_of_subset h).symm + (by rw [sort_filter_of_subset h]) + have : IsMonHom (eqToHom + (show listTensor B (t.sort (· ≤ ·)) = finTensor B t from rfl)) := + isMonHom_eqToHom B (l₁ := t.sort (· ≤ ·)) (l₂ := t.sort (· ≤ ·)) + rfl rfl + infer_instance + +end FinsetIncl + +/-! ## The big tensor product as a filtered colimit -/ + +section BigTensor + +/-- The index category of finite stages is filtered: `Finset ι` +is a directed order with unions as upper bounds. -/ +example : IsFiltered (Finset ι) := inferInstance + +/-- The `Finset ι`-shaped diagram of finite sub-tensor-products, +with the unit insertions as transition maps. -/ +@[simps] +def finTensorDiagram + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] (B : ι → D) + [∀ i, MonObj (B i)] : Finset ι ⥤ D where + obj s := finTensor B s + map f := finTensorIncl B (leOfHom f) + map_id s := finTensorIncl_refl B s + map_comp f g := + (finTensorIncl_trans B (leOfHom f) (leOfHom g)).symm + +/-- The tensor product of the whole family `B`, as the filtered +colimit of its finite sub-tensor-products. -/ +noncomputable def bigTensor + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] (B : ι → D) + [∀ i, MonObj (B i)] [HasColimitsOfShape (Finset ι) D] : + D := colimit (finTensorDiagram B) + +/-- The stage inclusion of a finite sub-tensor-product into the +big tensor product. -/ +noncomputable def bigTensorStage + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] (B : ι → D) + [∀ i, MonObj (B i)] [HasColimitsOfShape (Finset ι) D] + (s : Finset ι) : + finTensor B s ⟶ bigTensor B := + colimit.ι (finTensorDiagram B) s + +/-- Stage inclusions are compatible with the insertions. -/ +@[reassoc (attr := simp)] +lemma finTensorIncl_bigTensorStage + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] (B : ι → D) + [∀ i, MonObj (B i)] [HasColimitsOfShape (Finset ι) D] + {s t : Finset ι} (h : s ⊆ t) : + finTensorIncl B h ≫ bigTensorStage B t = bigTensorStage B s := + colimit.w (finTensorDiagram B) (homOfLE h) + +/-- The unit of the big tensor product: the empty stage. -/ +noncomputable def bigTensorUnit + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] (B : ι → D) + [∀ i, MonObj (B i)] [HasColimitsOfShape (Finset ι) D] : + 𝟙_ D ⟶ bigTensor B := + eqToHom (finTensor_empty B).symm ≫ bigTensorStage B ∅ + +/-- The inclusion of a single factor, through the stage at the +singleton. -/ +noncomputable def bigTensorOf + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] (B : ι → D) + [∀ i, MonObj (B i)] [HasColimitsOfShape (Finset ι) D] + (i : ι) : B i ⟶ bigTensor B := + (ρ_ (B i)).inv ≫ eqToHom (finTensor_singleton B i).symm ≫ + bigTensorStage B {i} + +end BigTensor + +/-! ## The unit against the stages -/ + +section StageMonoid + +lemma finTensor_one_def [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + (s : Finset ι) : + η[finTensor B s] = η[listTensor B (s.sort (· ≤ ·))] := rfl + +/-- The unit of the empty stage is the canonical identification +with the monoidal unit. -/ +lemma finTensor_one_empty [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] : + η[finTensor B ∅] = eqToHom (finTensor_empty B).symm := by + rw [finTensor_one_def, + listTensor_one_eq B (Finset.sort_empty (fun a b => a ≤ b))] + rfl + +/-- The unit of the big tensor product is reached from the unit +of any finite stage. -/ +lemma bigTensorUnit_stage [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + (s : Finset ι) : + η[finTensor B s] ≫ bigTensorStage B s = bigTensorUnit B := by + rw [← (isMonHom_finTensorIncl B (Finset.empty_subset s)).one_hom, + Category.assoc, finTensorIncl_bigTensorStage, finTensor_one_empty, + bigTensorUnit] + +end StageMonoid + +/-! ## Merge maps + +The multiplication of the big tensor product is presented on the +finite stages by the merge maps: include both stages into their +union, then multiply there. This section provides the merge maps +together with their coherence squares. -/ + +section Merge + +/-- The inclusion of the empty stage is the unit. -/ +lemma finTensorIncl_empty [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + (u : Finset ι) : + finTensorIncl B (Finset.empty_subset u) = + eqToHom (finTensor_empty B) ≫ η[finTensor B u] := by + rw [← (isMonHom_finTensorIncl B (Finset.empty_subset u)).one_hom, + finTensor_one_empty] + simp + +/-- The merge map of two finite stages: include both into the +union stage and multiply there. -/ +def finTensorMul [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + (s t : Finset ι) : + finTensor B s ⊗ finTensor B t ⟶ finTensor B (s ∪ t) := + (finTensorIncl B Finset.subset_union_left ⊗ₘ + finTensorIncl B Finset.subset_union_right) ≫ μ[finTensor B (s ∪ t)] + +/-- Include-then-multiply is independent of the receiving stage: +merging and then including into any common superset is inclusion +into the superset followed by its multiplication. -/ +lemma finTensorMul_incl [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + {s t v : Finset ι} (hs : s ⊆ v) (ht : t ⊆ v) + (huv : s ∪ t ⊆ v) : + finTensorMul B s t ≫ finTensorIncl B huv = + (finTensorIncl B hs ⊗ₘ finTensorIncl B ht) ≫ + μ[finTensor B v] := by + rw [finTensorMul, Category.assoc, + (isMonHom_finTensorIncl B huv).mul_hom, ← Category.assoc, + tensorHom_comp_tensorHom, finTensorIncl_trans, finTensorIncl_trans] + +/-- Naturality of the merge maps in both stages. -/ +@[reassoc] +lemma finTensorMul_natural [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + {s s' t t' : Finset ι} (hs : s ⊆ s') + (ht : t ⊆ t') : + (finTensorIncl B hs ⊗ₘ finTensorIncl B ht) ≫ + finTensorMul B s' t' = + finTensorMul B s t ≫ + finTensorIncl B (Finset.union_subset_union hs ht) := by + rw [finTensorMul_incl B (hs.trans Finset.subset_union_left) + (ht.trans Finset.subset_union_right), finTensorMul, + ← Category.assoc, tensorHom_comp_tensorHom, finTensorIncl_trans, + finTensorIncl_trans] + +/-- The merge maps composed with the stage inclusions form a +cocone in each variable: the square defining the multiplication +of the big tensor product commutes. -/ +lemma finTensorMul_stage [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + {s s' t t' : Finset ι} (hs : s ⊆ s') + (ht : t ⊆ t') : + (finTensorIncl B hs ⊗ₘ finTensorIncl B ht) ≫ + finTensorMul B s' t' ≫ bigTensorStage B (s' ∪ t') = + finTensorMul B s t ≫ bigTensorStage B (s ∪ t) := by + rw [← Category.assoc, finTensorMul_natural, Category.assoc, + finTensorIncl_bigTensorStage] + +/-- The stage identification along an equality of finite sets is +an inclusion. -/ +lemma eqToHom_eq_finTensorIncl + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] (B : ι → D) + [∀ i, MonObj (B i)] + {s t : Finset ι} (e : s = t) + (h : s ⊆ t) : + eqToHom (show finTensor B s = finTensor B t by rw [e]) = + finTensorIncl B h := by + subst e + simp + +/-- Unit square: merging with the empty stage on the left is the +left unitor followed by the inclusion. -/ +lemma finTensorMul_empty_left + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + (t : Finset ι) : + (eqToHom (finTensor_empty B).symm ▷ finTensor B t) ≫ + finTensorMul B ∅ t = + (λ_ (finTensor B t)).hom ≫ + finTensorIncl B Finset.subset_union_right := by + rw [finTensorMul, finTensorIncl_empty, ← Category.assoc, + ← tensorHom_id, tensorHom_comp_tensorHom] + simp only [eqToHom_trans_assoc, eqToHom_refl, Category.id_comp] + rw [MonObj.one_mul_hom] + +/-- Unit square: merging with the empty stage on the right is the +right unitor followed by the inclusion. -/ +lemma finTensorMul_empty_right + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + (t : Finset ι) : + (finTensor B t ◁ eqToHom (finTensor_empty B).symm) ≫ + finTensorMul B t ∅ = + (ρ_ (finTensor B t)).hom ≫ + finTensorIncl B Finset.subset_union_left := by + rw [finTensorMul, finTensorIncl_empty, ← Category.assoc, + ← id_tensorHom, tensorHom_comp_tensorHom] + simp only [eqToHom_trans_assoc, eqToHom_refl, Category.id_comp] + rw [MonObj.mul_one_hom] + +/-- Three-fold multiplication of a monoid object is associative, +in the folded form used by the merge maps. -/ +lemma tensor_mul_assoc [Category.{v} D] [MonoidalCategory D] + {M X Y Z : D} [MonObj M] (a : X ⟶ M) + (b : Y ⟶ M) (c : Z ⟶ M) : + (((a ⊗ₘ b) ≫ μ[M]) ⊗ₘ c) ≫ μ[M] = + (α_ X Y Z).hom ≫ (a ⊗ₘ ((b ⊗ₘ c) ≫ μ[M])) ≫ μ[M] := by + rw [← Category.comp_id c, ← tensorHom_comp_tensorHom, + Category.assoc, Category.comp_id, tensorHom_id, + MonObj.mul_assoc, ← Category.assoc, associator_naturality, + Category.assoc, ← id_tensorHom, + tensorHom_comp_tensorHom_assoc, Category.comp_id] + +/-- Definitional unfolding of the merge map, for targeted +rewriting. -/ +lemma finTensorMul_def [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + (s t : Finset ι) : + finTensorMul B s t = + (finTensorIncl B Finset.subset_union_left ⊗ₘ + finTensorIncl B Finset.subset_union_right) ≫ + μ[finTensor B (s ∪ t)] := rfl + +/-- Associativity square of the merge maps. -/ +@[reassoc] +lemma finTensorMul_assoc [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + (s t u : Finset ι) : + (finTensorMul B s t ▷ finTensor B u) ≫ finTensorMul B (s ∪ t) u = + (α_ (finTensor B s) (finTensor B t) (finTensor B u)).hom ≫ + (finTensor B s ◁ finTensorMul B t u) ≫ + finTensorMul B s (t ∪ u) ≫ + eqToHom (show finTensor B (s ∪ (t ∪ u)) = + finTensor B (s ∪ t ∪ u) by + rw [Finset.union_assoc]) := by + conv_rhs => + rw [eqToHom_eq_finTensorIncl B (Finset.union_assoc s t u).symm + (le_of_eq (Finset.union_assoc s t u).symm), + finTensorMul_incl B + (Finset.subset_union_left.trans Finset.subset_union_left) + (Finset.union_subset + (Finset.subset_union_right.trans Finset.subset_union_left) + Finset.subset_union_right), + ← id_tensorHom, tensorHom_comp_tensorHom_assoc, + Category.id_comp, + finTensorMul_incl B + (Finset.subset_union_right.trans Finset.subset_union_left) + Finset.subset_union_right] + conv_lhs => + rw [finTensorMul_def B (s ∪ t) u, ← tensorHom_id, + tensorHom_comp_tensorHom_assoc, Category.id_comp, + finTensorMul_incl B + (Finset.subset_union_left.trans Finset.subset_union_left) + (Finset.subset_union_right.trans Finset.subset_union_left)] + rw [tensor_mul_assoc] + +end Merge + +/-! ## The multiplication of the big tensor product + +With tensoring preserving `Finset ι`-colimits, `bigTensor B ⊗ X` +and `X ⊗ bigTensor B` are colimits of the corresponding stage +diagrams; maps out of them are determined by the stages, and the +merge maps assemble into the multiplication. -/ + +section BigTensorMul + +/-- Maps out of `bigTensor B ⊗ X` are determined by their +restrictions to the stages. -/ +lemma bigTensor_tensorRight_hom_ext + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + [∀ X : D, PreservesColimitsOfShape (Finset ι) (tensorLeft X)] + {X Z : D} + {f g : bigTensor B ⊗ X ⟶ Z} + (w : ∀ s, (bigTensorStage B s ▷ X) ≫ f = + (bigTensorStage B s ▷ X) ≫ g) : f = g := by + apply (cancel_epi + (preservesColimitIso (tensorRight X) (finTensorDiagram B)).inv).mp + apply colimit.hom_ext + intro s + erw [ι_preservesColimitIso_inv_assoc, ι_preservesColimitIso_inv_assoc] + exact w s + +/-- Maps out of `X ⊗ bigTensor B` are determined by their +restrictions to the stages. -/ +lemma tensorLeft_bigTensor_hom_ext + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] (B : ι → D) + [∀ i, MonObj (B i)] [HasColimitsOfShape (Finset ι) D] + [∀ X : D, PreservesColimitsOfShape (Finset ι) (tensorLeft X)] + {X Z : D} + {f g : X ⊗ bigTensor B ⟶ Z} + (w : ∀ t, (X ◁ bigTensorStage B t) ≫ f = + (X ◁ bigTensorStage B t) ≫ g) : f = g := by + apply (cancel_epi + (preservesColimitIso (tensorLeft X) (finTensorDiagram B)).inv).mp + apply colimit.hom_ext + intro t + erw [ι_preservesColimitIso_inv_assoc, ι_preservesColimitIso_inv_assoc] + exact w t + +/-- Left compatibility of the merge-then-stage maps. -/ +@[reassoc] +lemma finTensorMul_stage_left + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + {s s' t : Finset ι} (hs : s ⊆ s') : + (finTensorIncl B hs ▷ finTensor B t) ≫ finTensorMul B s' t ≫ + bigTensorStage B (s' ∪ t) = + finTensorMul B s t ≫ bigTensorStage B (s ∪ t) := by + have h := finTensorMul_stage B hs (subset_refl t) + rwa [finTensorIncl_refl, tensorHom_id] at h + +/-- Right compatibility of the merge-then-stage maps. -/ +@[reassoc] +lemma finTensorMul_stage_right + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + {s t t' : Finset ι} (ht : t ⊆ t') : + (finTensor B s ◁ finTensorIncl B ht) ≫ finTensorMul B s t' ≫ + bigTensorStage B (s ∪ t') = + finTensorMul B s t ≫ bigTensorStage B (s ∪ t) := by + have h := finTensorMul_stage B (subset_refl s) ht + rwa [finTensorIncl_refl, id_tensorHom] at h + +/-- The merge maps into the big tensor product form a cocone on +the stage diagram tensored with a fixed finite stage. -/ +noncomputable def bigTensorMulCocone + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + (t : Finset ι) : + Cocone (finTensorDiagram B ⋙ tensorRight (finTensor B t)) where + pt := bigTensor B + ι := + { app := fun s => finTensorMul B s t ≫ bigTensorStage B (s ∪ t) + naturality := fun {s s'} f => by + change (finTensorIncl B (leOfHom f) ▷ finTensor B t) ≫ + (finTensorMul B s' t ≫ bigTensorStage B (s' ∪ t)) = + (finTensorMul B s t ≫ bigTensorStage B (s ∪ t)) ≫ + 𝟙 (bigTensor B) + rw [Category.comp_id] + exact finTensorMul_stage_left B (leOfHom f) } + +/-- Multiplication of the big tensor product against a fixed +finite stage. -/ +noncomputable def bigTensorMulStage + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + [∀ X : D, PreservesColimitsOfShape (Finset ι) (tensorLeft X)] + (t : Finset ι) : + bigTensor B ⊗ finTensor B t ⟶ bigTensor B := + ((preservesColimitIso (tensorRight (finTensor B t)) + (finTensorDiagram B)).hom ≫ + colimit.desc _ (bigTensorMulCocone B t) : + (tensorRight (finTensor B t)).obj (colimit (finTensorDiagram B)) ⟶ + bigTensor B) + +/-- On a stage, the partial multiplication is merge-then-stage. -/ +@[reassoc] +lemma stage_bigTensorMulStage + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + [∀ X : D, PreservesColimitsOfShape (Finset ι) (tensorLeft X)] + (s t : Finset ι) : + (bigTensorStage B s ▷ finTensor B t) ≫ bigTensorMulStage B t = + finTensorMul B s t ≫ bigTensorStage B (s ∪ t) := by + change (tensorRight (finTensor B t)).map + (colimit.ι (finTensorDiagram B) s) ≫ bigTensorMulStage B t = + finTensorMul B s t ≫ bigTensorStage B (s ∪ t) + erw [bigTensorMulStage, ι_preservesColimitIso_hom_assoc] + exact colimit.ι_desc (bigTensorMulCocone B t) s + +/-- The partial multiplications are natural in the stage. -/ +@[reassoc] +lemma bigTensorMulStage_natural + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + [∀ X : D, PreservesColimitsOfShape (Finset ι) (tensorLeft X)] + {t t' : Finset ι} (ht : t ⊆ t') : + (bigTensor B ◁ finTensorIncl B ht) ≫ bigTensorMulStage B t' = + bigTensorMulStage B t := by + apply bigTensor_tensorRight_hom_ext B + intro s + rw [← Category.assoc, ← whisker_exchange, Category.assoc, + stage_bigTensorMulStage, stage_bigTensorMulStage] + exact finTensorMul_stage_right B ht + +/-- The partial multiplications form a cocone on the stage +diagram tensored on the left with the big tensor product. -/ +noncomputable def bigTensorMulTotalCocone + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + [∀ X : D, PreservesColimitsOfShape (Finset ι) (tensorLeft X)] : + Cocone (finTensorDiagram B ⋙ tensorLeft (bigTensor B)) where + pt := bigTensor B + ι := + { app := fun t => bigTensorMulStage B t + naturality := fun {t t'} f => by + change (bigTensor B ◁ finTensorIncl B (leOfHom f)) ≫ + bigTensorMulStage B t' = + bigTensorMulStage B t ≫ 𝟙 (bigTensor B) + rw [Category.comp_id] + exact bigTensorMulStage_natural B (leOfHom f) } + +/-- The multiplication of the big tensor product. -/ +noncomputable def bigTensorMul + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + [∀ X : D, PreservesColimitsOfShape (Finset ι) (tensorLeft X)] : + bigTensor B ⊗ bigTensor B ⟶ bigTensor B := + ((preservesColimitIso (tensorLeft (bigTensor B)) + (finTensorDiagram B)).hom ≫ + colimit.desc _ (bigTensorMulTotalCocone B) : + (tensorLeft (bigTensor B)).obj (colimit (finTensorDiagram B)) ⟶ + bigTensor B) + +/-- On a stage in the second variable, the multiplication is the +partial multiplication. -/ +@[reassoc] +lemma stage_bigTensorMul_right + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + [∀ X : D, PreservesColimitsOfShape (Finset ι) (tensorLeft X)] + (t : Finset ι) : + (bigTensor B ◁ bigTensorStage B t) ≫ bigTensorMul B = + bigTensorMulStage B t := by + change (tensorLeft (bigTensor B)).map + (colimit.ι (finTensorDiagram B) t) ≫ bigTensorMul B = + bigTensorMulStage B t + erw [bigTensorMul, ι_preservesColimitIso_hom_assoc] + exact colimit.ι_desc (bigTensorMulTotalCocone B) t + +/-- The multiplication restricted to a pair of stages is the +merge map followed by the union stage: the presentation of the +multiplication over pairs of finite stages. -/ +@[reassoc] +lemma stage_bigTensorMul [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + [∀ X : D, PreservesColimitsOfShape (Finset ι) (tensorLeft X)] + (s t : Finset ι) : + (bigTensorStage B s ⊗ₘ bigTensorStage B t) ≫ bigTensorMul B = + finTensorMul B s t ≫ bigTensorStage B (s ∪ t) := by + rw [tensorHom_def, Category.assoc, stage_bigTensorMul_right, + stage_bigTensorMulStage] + +/-- Sandwich extension: maps out of `X ⊗ (bigTensor B ⊗ Y)` are +determined by the stages in the middle slot. -/ +lemma bigTensor_sandwich_hom_ext + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + [∀ X : D, PreservesColimitsOfShape (Finset ι) (tensorLeft X)] + (X Y : D) {Z : D} + {f g : X ⊗ (bigTensor B ⊗ Y) ⟶ Z} + (w : ∀ t, (X ◁ bigTensorStage B t ▷ Y) ≫ f = + (X ◁ bigTensorStage B t ▷ Y) ≫ g) : f = g := by + apply (cancel_epi (preservesColimitIso + (tensorRight Y ⋙ tensorLeft X) (finTensorDiagram B)).inv).mp + apply colimit.hom_ext + intro t + erw [ι_preservesColimitIso_inv_assoc, ι_preservesColimitIso_inv_assoc] + exact w t + +/-- Maps out of `bigTensor B ⊗ bigTensor B` are determined by +pairs of stages. -/ +lemma bigTensor_pair_hom_ext + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + [∀ X : D, PreservesColimitsOfShape (Finset ι) (tensorLeft X)] + {Z : D} + {f g : bigTensor B ⊗ bigTensor B ⟶ Z} + (w : ∀ s t, (bigTensorStage B s ⊗ₘ bigTensorStage B t) ≫ f = + (bigTensorStage B s ⊗ₘ bigTensorStage B t) ≫ g) : f = g := by + apply tensorLeft_bigTensor_hom_ext B + intro t + apply bigTensor_tensorRight_hom_ext B + intro s + rw [← Category.assoc, ← Category.assoc, + show bigTensorStage B s ▷ finTensor B t ≫ + bigTensor B ◁ bigTensorStage B t = + bigTensorStage B s ⊗ₘ bigTensorStage B t from + (tensorHom_def _ _).symm] + exact w s t + +/-- The merge maps against a fixed first stage form a cocone. -/ +noncomputable def bigTensorMulLCocone + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + (s : Finset ι) : + Cocone (finTensorDiagram B ⋙ tensorLeft (finTensor B s)) where + pt := bigTensor B + ι := + { app := fun t => finTensorMul B s t ≫ bigTensorStage B (s ∪ t) + naturality := fun {t t'} f => by + change (finTensor B s ◁ finTensorIncl B (leOfHom f)) ≫ + (finTensorMul B s t' ≫ bigTensorStage B (s ∪ t')) = + (finTensorMul B s t ≫ bigTensorStage B (s ∪ t)) ≫ + 𝟙 (bigTensor B) + rw [Category.comp_id] + exact finTensorMul_stage_right B (leOfHom f) } + +/-- Multiplication of a fixed finite stage against the big tensor +product. -/ +noncomputable def bigTensorMulStageL + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + [∀ X : D, PreservesColimitsOfShape (Finset ι) (tensorLeft X)] + (s : Finset ι) : + finTensor B s ⊗ bigTensor B ⟶ bigTensor B := + ((preservesColimitIso (tensorLeft (finTensor B s)) + (finTensorDiagram B)).hom ≫ + colimit.desc _ (bigTensorMulLCocone B s) : + (tensorLeft (finTensor B s)).obj (colimit (finTensorDiagram B)) ⟶ + bigTensor B) + +/-- On a stage, the left partial multiplication is +merge-then-stage. -/ +@[reassoc] +lemma stage_bigTensorMulStageL + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + [∀ X : D, PreservesColimitsOfShape (Finset ι) (tensorLeft X)] + (s t : Finset ι) : + (finTensor B s ◁ bigTensorStage B t) ≫ bigTensorMulStageL B s = + finTensorMul B s t ≫ bigTensorStage B (s ∪ t) := by + change (tensorLeft (finTensor B s)).map + (colimit.ι (finTensorDiagram B) t) ≫ bigTensorMulStageL B s = + finTensorMul B s t ≫ bigTensorStage B (s ∪ t) + erw [bigTensorMulStageL, ι_preservesColimitIso_hom_assoc] + exact colimit.ι_desc (bigTensorMulLCocone B s) t + +/-- On a stage in the first variable, the multiplication is the +left partial multiplication. -/ +@[reassoc] +lemma stage_bigTensorMul_left + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + [∀ X : D, PreservesColimitsOfShape (Finset ι) (tensorLeft X)] + (s : Finset ι) : + (bigTensorStage B s ▷ bigTensor B) ≫ bigTensorMul B = + bigTensorMulStageL B s := by + apply tensorLeft_bigTensor_hom_ext B + intro t + rw [← Category.assoc, whisker_exchange, Category.assoc, + stage_bigTensorMul_right, stage_bigTensorMulStage, + stage_bigTensorMulStageL] + +/-! ## The monoid structure on the big tensor product -/ + +/-- Left unit law of the big tensor product. -/ +lemma bigTensor_one_mul [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + [∀ X : D, PreservesColimitsOfShape (Finset ι) (tensorLeft X)] : + (bigTensorUnit B ▷ bigTensor B) ≫ bigTensorMul B = + (λ_ (bigTensor B)).hom := by + apply tensorLeft_bigTensor_hom_ext B + intro t + rw [← Category.assoc, whisker_exchange, Category.assoc, + stage_bigTensorMul_right, bigTensorUnit, comp_whiskerRight, + Category.assoc, stage_bigTensorMulStage, ← Category.assoc, + finTensorMul_empty_left, Category.assoc, + finTensorIncl_bigTensorStage, leftUnitor_naturality] + +/-- Right unit law of the big tensor product. -/ +lemma bigTensor_mul_one [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + [∀ X : D, PreservesColimitsOfShape (Finset ι) (tensorLeft X)] : + (bigTensor B ◁ bigTensorUnit B) ≫ bigTensorMul B = + (ρ_ (bigTensor B)).hom := by + apply bigTensor_tensorRight_hom_ext B + intro s + rw [← Category.assoc, ← whisker_exchange, Category.assoc, + stage_bigTensorMul_left, bigTensorUnit, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + stage_bigTensorMulStageL, ← Category.assoc, + finTensorMul_empty_right, Category.assoc, + finTensorIncl_bigTensorStage, rightUnitor_naturality] + +/-- Associativity of the big tensor product multiplication. -/ +lemma bigTensor_mul_assoc [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + [∀ X : D, PreservesColimitsOfShape (Finset ι) (tensorLeft X)] : + (bigTensorMul B ▷ bigTensor B) ≫ bigTensorMul B = + (α_ (bigTensor B) (bigTensor B) (bigTensor B)).hom ≫ + (bigTensor B ◁ bigTensorMul B) ≫ bigTensorMul B := by + apply tensorLeft_bigTensor_hom_ext B + intro u + conv_lhs => + rw [← Category.assoc, whisker_exchange, Category.assoc, + stage_bigTensorMul_right] + conv_rhs => + rw [associator_naturality_right_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + stage_bigTensorMul_right] + apply (cancel_epi + (α_ (bigTensor B) (bigTensor B) (finTensor B u)).inv).mp + rw [Iso.inv_hom_id_assoc] + apply bigTensor_tensorRight_hom_ext B + intro s + conv_lhs => + rw [associator_inv_naturality_left_assoc, + ← comp_whiskerRight_assoc, stage_bigTensorMul_left] + conv_rhs => + rw [← whisker_exchange_assoc, stage_bigTensorMul_left] + apply bigTensor_sandwich_hom_ext B + intro t + conv_lhs => + rw [associator_inv_naturality_middle_assoc, + ← comp_whiskerRight_assoc, stage_bigTensorMulStageL, + comp_whiskerRight, Category.assoc, stage_bigTensorMulStage, + finTensorMul_assoc_assoc, Iso.inv_hom_id_assoc, + eqToHom_eq_finTensorIncl B (Finset.union_assoc s t u).symm + (le_of_eq (Finset.union_assoc s t u).symm), + finTensorIncl_bigTensorStage] + conv_rhs => + rw [← MonoidalCategory.whiskerLeft_comp_assoc, + stage_bigTensorMulStage, MonoidalCategory.whiskerLeft_comp, + Category.assoc, stage_bigTensorMulStageL] + +/-- The big tensor product of a family of monoid objects is a +monoid object: the unit is the empty stage and the multiplication +is assembled from the merge maps. -/ +noncomputable instance bigTensorMon + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + [∀ X : D, PreservesColimitsOfShape (Finset ι) (tensorLeft X)] : + MonObj (bigTensor B) where + one := bigTensorUnit B + mul := bigTensorMul B + one_mul := bigTensor_one_mul B + mul_one := bigTensor_mul_one B + mul_assoc := bigTensor_mul_assoc B + +/-- The stage inclusions are morphisms of monoid objects. -/ +instance isMonHom_bigTensorStage + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + [∀ X : D, PreservesColimitsOfShape (Finset ι) (tensorLeft X)] + (s : Finset ι) : + IsMonHom (bigTensorStage B s) where + one_hom := bigTensorUnit_stage B s + mul_hom := by + rw [show μ[bigTensor B] = bigTensorMul B from rfl, + stage_bigTensorMul] + conv_rhs => rw [← finTensorIncl_bigTensorStage B + (le_of_eq (Finset.union_self s))] + rw [← Category.assoc, + finTensorMul_incl B (subset_refl s) (subset_refl s), + finTensorIncl_refl, id_tensorHom_id, Category.id_comp] + +/-- The single-factor inclusions are morphisms of monoid +objects. -/ +instance isMonHom_bigTensorOf + [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [BraidedCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [HasColimitsOfShape (Finset ι) D] + [∀ X : D, PreservesColimitsOfShape (Finset ι) (tensorLeft X)] + (i : ι) : + IsMonHom (bigTensorOf B i) := by + rw [bigTensorOf] + have : IsMonHom (eqToHom (finTensor_singleton B i).symm) := + isMonHom_eqToHom B (l₁ := [i]) + (l₂ := ({i} : Finset ι).sort (· ≤ ·)) + (Finset.sort_singleton (fun a b => a ≤ b) i).symm + (by rw [Finset.sort_singleton]) + infer_instance + +end BigTensorMul + +/-! ## Commutativity -/ + +section MergeComm + +/-- Commutativity square of the merge maps. -/ +@[reassoc] +lemma finTensorMul_comm [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [SymmetricCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [∀ i, IsCommMonObj (B i)] + (s t : Finset ι) : + (β_ (finTensor B s) (finTensor B t)).hom ≫ finTensorMul B t s = + finTensorMul B s t ≫ + eqToHom (show finTensor B (s ∪ t) = finTensor B (t ∪ s) by + rw [Finset.union_comm]) := by + rw [eqToHom_eq_finTensorIncl B (Finset.union_comm s t) + (le_of_eq (Finset.union_comm s t)), + finTensorMul_incl B Finset.subset_union_right + Finset.subset_union_left, + finTensorMul_def B t s, ← BraidedCategory.braiding_naturality_assoc, + IsCommMonObj.mul_comm] + +/-- The big tensor product of commutative monoid objects is +commutative. -/ +instance bigTensorCommMon [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] + [SymmetricCategory D] (B : ι → D) [∀ i, MonObj (B i)] + [∀ i, IsCommMonObj (B i)] [HasColimitsOfShape (Finset ι) D] + [∀ X : D, PreservesColimitsOfShape (Finset ι) (tensorLeft X)] : + IsCommMonObj (bigTensor B) where + mul_comm := by + change (β_ (bigTensor B) (bigTensor B)).hom ≫ bigTensorMul B = + bigTensorMul B + apply bigTensor_pair_hom_ext B + intro s t + rw [BraidedCategory.braiding_naturality_assoc, + stage_bigTensorMul, stage_bigTensorMul, + finTensorMul_comm_assoc B s t, + eqToHom_eq_finTensorIncl B (Finset.union_comm s t) + (le_of_eq (Finset.union_comm s t)), + finTensorIncl_bigTensorStage] + +end MergeComm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensorUnit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensorUnit.lean new file mode 100644 index 0000000000..21ca80ca04 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensorUnit.lean @@ -0,0 +1,94 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensor + +/-! +# The unit of a big tensor product survives + +If the tensor of two nonzero points is nonzero, then a finite +tensor product of algebras with nonvanishing units again has a +nonvanishing unit, by induction on the slots. The unit of the +whole family is the unit of any finite stage followed by the +stage inclusion, so it survives as soon as the unit of the +ambient category can be tested against the filtered colimit one +stage at a time. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +local notation "η[" M "]" => MonObj.one (X := M) +local notation "μ[" M "]" => MonObj.mul (X := M) + +universe v u + +variable {D : Type u} + +/-- **The unit of a finite fold survives**: the unit of a tensor +product of monoid objects is the tensor of their units, so it is +nonzero as soon as the binary statement holds. -/ +theorem listTensor_one_ne_zero + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] {ι : Type v} (B : ι → D) [∀ i, MonObj (B i)] + (h1 : 𝟙 (𝟙_ D) ≠ 0) + (hbin : ∀ {M N : D} (u : 𝟙_ D ⟶ M) (v : 𝟙_ D ⟶ N), + u ≠ 0 → v ≠ 0 → (u ⊗ₘ v) ≠ 0) + (hB : ∀ i, η[B i] ≠ 0) : + ∀ l : List ι, η[listTensor B l] ≠ 0 + | [] => h1 + | i :: l => by + have hstep : η[listTensor B (i :: l)] = + (λ_ (𝟙_ D)).inv ≫ (η[B i] ⊗ₘ η[listTensor B l]) := rfl + rw [hstep] + intro h0 + refine hbin η[B i] η[listTensor B l] (hB i) + (listTensor_one_ne_zero B h1 hbin hB l) ?_ + have hcomp := congrArg (fun t => (λ_ (𝟙_ D)).hom ≫ t) h0 + simp only [Iso.hom_inv_id_assoc] at hcomp + rw [hcomp] + exact Limits.comp_zero + +/-- **The unit of a finite sub-tensor-product survives.** -/ +theorem finTensor_one_ne_zero + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] {ι : Type v} (B : ι → D) [∀ i, MonObj (B i)] + [LinearOrder ι] + (h1 : 𝟙 (𝟙_ D) ≠ 0) + (hbin : ∀ {M N : D} (u : 𝟙_ D ⟶ M) (v : 𝟙_ D ⟶ N), + u ≠ 0 → v ≠ 0 → (u ⊗ₘ v) ≠ 0) + (hB : ∀ i, η[B i] ≠ 0) (s : Finset ι) : + η[finTensor B s] ≠ 0 := + listTensor_one_ne_zero B h1 hbin hB (s.sort (· ≤ ·)) + +/-- **The unit of the big tensor product survives**, given that +a point of the colimit vanishes only if it already vanishes at a +later stage. -/ +theorem bigTensorUnit_ne_zero + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] {ι : Type v} (B : ι → D) [∀ i, MonObj (B i)] + [LinearOrder ι] [HasColimitsOfShape (Finset ι) D] + (h1 : 𝟙 (𝟙_ D) ≠ 0) + (hbin : ∀ {M N : D} (u : 𝟙_ D ⟶ M) (v : 𝟙_ D ⟶ N), + u ≠ 0 → v ≠ 0 → (u ⊗ₘ v) ≠ 0) + (hB : ∀ i, η[B i] ≠ 0) + (hstage : ∀ (s : Finset ι) (f : 𝟙_ D ⟶ finTensor B s), + f ≫ bigTensorStage B s = 0 → + ∃ (t : Finset ι) (h : s ⊆ t), f ≫ finTensorIncl B h = 0) : + bigTensorUnit B ≠ 0 := by + intro h0 + obtain ⟨t, h, ht⟩ := hstage ∅ η[finTensor B ∅] + (by rw [bigTensorUnit_stage]; exact h0) + refine finTensor_one_ne_zero B h1 hbin hB t ?_ + rw [← (isMonHom_finTensorIncl B h).one_hom] + exact ht + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodPow.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodPow.lean new file mode 100644 index 0000000000..21a5a75a71 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodPow.lean @@ -0,0 +1,1422 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedConc +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermNat + +/-! +# Binomial expansion of a tensor power of a biproduct + +`(X ⊞ Y) ^ ⊗ n` decomposes into `2 ^ n` mixed words: for each +`w : Fin n → Bool` the word power `wordPow X Y n w` tensors an `X` +for each `true` letter and a `Y` for each `false` one, in slot +order. The letterwise biproduct inclusions and projections fold to +`mixedInto` and `mixedFrom`, which exhibit the word powers as a +biproduct decomposition of the full power: same-word round trips +are identities, different-word round trips vanish, and the sum of +all `mixedFrom ≫ mixedInto` is the identity of `(X ⊞ Y) ^ ⊗ n`. + +The sorted words are the `standardWord`s — all `X`s below all +`Y`s — whose word power is `X ^ ⊗ p ⊗ Y ^ ⊗ q` up to the +structural isomorphism `standardMixedIso`, and on which `mixedInto` +is the concatenation of the two pure-power inclusions. The sorting +lemma closes the file: every word is a sorted word up to the +symmetric-group action — `mixedInto` for `w`, followed by the +action of `sortPerm w`, is the base-point inclusion at +`(popCount w, n − popCount w)`, up to an isomorphism of the source +and an arity transport `eqToHom` at the target. + +`mixedPow` in `RS/Definitions.lean` already names the dual-mixed +power of a rigid object, so the word-indexed power here is called +`wordPow` instead. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Limits MonoidalCategory + +universe v u + +variable {A : Type u} + +/-! ## Word powers -/ + +/-- **The word power**: tensor an `X` for each `true` letter of `w` +and a `Y` for each `false` one, by the recursion of `tensorPow`. -/ +def wordPow [Category.{v} A] [MonoidalCategory A] + (X Y : A) : (n : ℕ) → (Fin n → Bool) → A + | 0, _ => 𝟙_ A + | n + 1, w => + wordPow X Y n (w ∘ Fin.castSucc) ⊗ + (bif w (Fin.last n) then X else Y) + +/-- The defining recursion of `wordPow`: one more letter tensors +the selected object on the right. -/ +theorem wordPow_succ [Category.{v} A] [MonoidalCategory A] + (X Y : A) (n : ℕ) (w : Fin (n + 1) → Bool) : + wordPow X Y (n + 1) w = + wordPow X Y n (w ∘ Fin.castSucc) ⊗ + (bif w (Fin.last n) then X else Y) := rfl + +/-! ## Letterwise inclusions and projections -/ + +section Biprod + +/-- The biproduct inclusion selected by one letter. -/ +noncomputable def letterInto + [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + (X Y : A) : + (b : Bool) → ((bif b then X else Y) ⟶ X ⊞ Y) + | true => biprod.inl + | false => biprod.inr + +/-- The biproduct projection selected by one letter. -/ +noncomputable def letterFrom + [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + (X Y : A) : + (b : Bool) → (X ⊞ Y ⟶ (bif b then X else Y)) + | true => biprod.fst + | false => biprod.snd + +/-- A letter's round trip through the biproduct is the identity. -/ +theorem letterInto_letterFrom + [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + (X Y : A) (b : Bool) : + letterInto X Y b ≫ letterFrom X Y b = 𝟙 _ := by + cases b + · exact biprod.inr_snd + · exact biprod.inl_fst + +/-- Different letters' round trips vanish. -/ +theorem letterInto_letterFrom_ne + [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + (X Y : A) {b b' : Bool} + (hbb' : b ≠ b') : + letterInto X Y b ≫ letterFrom X Y b' = 0 := by + cases b <;> cases b' + · exact absurd rfl hbb' + · exact biprod.inr_fst + · exact biprod.inl_snd + · exact absurd rfl hbb' + +/-- **The inclusion of a word power** into the tensor power of the +biproduct: the fold of the letterwise inclusions, by the recursion +of `wordPow`. -/ +noncomputable def mixedInto + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + (X Y : A) : (n : ℕ) → (w : Fin n → Bool) → + (wordPow X Y n w ⟶ tensorPow A (X ⊞ Y) n) + | 0, _ => 𝟙 (𝟙_ A) + | n + 1, w => + mixedInto X Y n (w ∘ Fin.castSucc) ⊗ₘ + letterInto X Y (w (Fin.last n)) + +/-- **The projection onto a word power** from the tensor power of +the biproduct: the fold of the letterwise projections. -/ +noncomputable def mixedFrom + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + (X Y : A) : (n : ℕ) → (w : Fin n → Bool) → + (tensorPow A (X ⊞ Y) n ⟶ wordPow X Y n w) + | 0, _ => 𝟙 (𝟙_ A) + | n + 1, w => + mixedFrom X Y n (w ∘ Fin.castSucc) ⊗ₘ + letterFrom X Y (w (Fin.last n)) + +/-! ## Round trips + +Each round-trip computation happens factorwise. The helpers are +stated at general objects and applied by `exact`, so that no +tensor-power arity enters the rewriting. +-/ + +/-- Sections tensor to a section. Stated at general objects. -/ +private theorem tensor_split_id [Category.{v} A] [MonoidalCategory A] + {P Q R S : A} (f : P ⟶ Q) (g : Q ⟶ P) + (h : R ⟶ S) (k : S ⟶ R) (hfg : f ≫ g = 𝟙 P) (hhk : h ≫ k = 𝟙 R) : + (f ⊗ₘ h) ≫ (g ⊗ₘ k) = 𝟙 (P ⊗ R) := by + rw [MonoidalCategory.tensorHom_comp_tensorHom, hfg, hhk, + MonoidalCategory.id_tensorHom_id] + +/-- Two words of positive length differ in the last letter or in +the rest. -/ +private theorem word_ne_cases {n : ℕ} {w w' : Fin (n + 1) → Bool} + (hww' : w ≠ w') : + w ∘ Fin.castSucc ≠ w' ∘ Fin.castSucc ∨ + w (Fin.last n) ≠ w' (Fin.last n) := by + by_contra hcon + rw [not_or, not_not, not_not] at hcon + obtain ⟨h1, h2⟩ := hcon + refine hww' (funext fun i => ?_) + induction i using Fin.lastCases with + | last => exact h2 + | cast j => exact congrFun h1 j + +section MonPre + +/-- A vanishing first factor kills the tensor. Stated at general +objects. -/ +private theorem tensor_split_zero_fst + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] + {P Q R S T U : A} + (f : P ⟶ Q) (g : Q ⟶ R) (h : S ⟶ T) (k : T ⟶ U) + (hfg : f ≫ g = 0) : (f ⊗ₘ h) ≫ (g ⊗ₘ k) = 0 := by + rw [MonoidalCategory.tensorHom_comp_tensorHom, hfg, + MonoidalPreadditive.zero_tensor] + +/-- A vanishing second factor kills the tensor. Stated at general +objects. -/ +private theorem tensor_split_zero_snd + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] + {P Q R S T U : A} + (f : P ⟶ Q) (g : Q ⟶ R) (h : S ⟶ T) (k : T ⟶ U) + (hhk : h ≫ k = 0) : (f ⊗ₘ h) ≫ (g ⊗ₘ k) = 0 := by + rw [MonoidalCategory.tensorHom_comp_tensorHom, hhk, + MonoidalPreadditive.tensor_zero] + +/-! ### Completeness + +Summed over all words, the round trips through the word powers +decompose the identity of `(X ⊞ Y) ^ ⊗ n`. The words of length +`n + 1` are reindexed by `Fin.snocEquiv` as pairs of a last letter +and a shorter word; the letter sum is `biprod.total` and the word +sum is the inductive hypothesis. +-/ + +/-- One word's round trip through the full power, split into the +shorter word's round trip and the last letter's. -/ +private theorem fromInto_snoc + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + (X Y : A) (n : ℕ) (w' : Fin n → Bool) + (b : Bool) : + mixedFrom X Y (n + 1) (Fin.snoc w' b) ≫ + mixedInto X Y (n + 1) (Fin.snoc w' b) = + (mixedFrom X Y n w' ≫ mixedInto X Y n w') ⊗ₘ + (letterFrom X Y b ≫ letterInto X Y b) := by + have hw : (Fin.snoc w' b : Fin (n + 1) → Bool) ∘ Fin.castSucc = w' := + Fin.snoc_comp_castSucc + have hb : (Fin.snoc w' b : Fin (n + 1) → Bool) (Fin.last n) = b := + Fin.snoc_last .. + have hww : mixedFrom X Y n (Fin.snoc w' b ∘ Fin.castSucc) ≫ + mixedInto X Y n (Fin.snoc w' b ∘ Fin.castSucc) = + mixedFrom X Y n w' ≫ mixedInto X Y n w' := by rw [hw] + have hbb : letterFrom X Y + ((Fin.snoc w' b : Fin (n + 1) → Bool) (Fin.last n)) ≫ + letterInto X Y + ((Fin.snoc w' b : Fin (n + 1) → Bool) (Fin.last n)) = + letterFrom X Y b ≫ letterInto X Y b := by rw [hb] + rw [← hww, ← hbb] + exact MonoidalCategory.tensorHom_comp_tensorHom (C := A) _ _ _ _ + +/-- **Completeness of the word decomposition**: the round trips +through the word powers sum to the identity of the full power. -/ +theorem sum_mixedFrom_mixedInto + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] [MonoidalPreadditive A] + (X Y : A) : + ∀ n : ℕ, + ∑ w : Fin n → Bool, mixedFrom X Y n w ≫ mixedInto X Y n w = + 𝟙 (tensorPow A (X ⊞ Y) n) := by + intro n + induction n with + | zero => + rw [Fintype.sum_unique] + exact Category.id_comp _ + | succ n ih => + have e1 : (∑ w : Fin (n + 1) → Bool, + mixedFrom X Y (n + 1) w ≫ mixedInto X Y (n + 1) w) = + ∑ p : Bool × (Fin n → Bool), + mixedFrom X Y (n + 1) (Fin.snoc p.2 p.1) ≫ + mixedInto X Y (n + 1) (Fin.snoc p.2 p.1) := + (Equiv.sum_comp (Fin.snocEquiv fun _ : Fin (n + 1) => Bool) + (fun w => mixedFrom X Y (n + 1) w ≫ + mixedInto X Y (n + 1) w)).symm + have e2 : (∑ p : Bool × (Fin n → Bool), + mixedFrom X Y (n + 1) (Fin.snoc p.2 p.1) ≫ + mixedInto X Y (n + 1) (Fin.snoc p.2 p.1)) = + ∑ p : Bool × (Fin n → Bool), + ((mixedFrom X Y n p.2 ≫ mixedInto X Y n p.2) ⊗ₘ + (letterFrom X Y p.1 ≫ letterInto X Y p.1) : + tensorPow A (X ⊞ Y) (n + 1) ⟶ + tensorPow A (X ⊞ Y) (n + 1)) := + Finset.sum_congr rfl fun p _ => fromInto_snoc X Y n p.2 p.1 + have e3 : (∑ p : Bool × (Fin n → Bool), + ((mixedFrom X Y n p.2 ≫ mixedInto X Y n p.2) ⊗ₘ + (letterFrom X Y p.1 ≫ letterInto X Y p.1) : + tensorPow A (X ⊞ Y) (n + 1) ⟶ + tensorPow A (X ⊞ Y) (n + 1))) = + ∑ b : Bool, ∑ w' : Fin n → Bool, + ((mixedFrom X Y n w' ≫ mixedInto X Y n w') ⊗ₘ + (letterFrom X Y b ≫ letterInto X Y b) : + tensorPow A (X ⊞ Y) (n + 1) ⟶ + tensorPow A (X ⊞ Y) (n + 1)) := + Fintype.sum_prod_type _ + have e4 : ∀ b : Bool, + (∑ w' : Fin n → Bool, + ((mixedFrom X Y n w' ≫ mixedInto X Y n w') ⊗ₘ + (letterFrom X Y b ≫ letterInto X Y b) : + tensorPow A (X ⊞ Y) (n + 1) ⟶ + tensorPow A (X ⊞ Y) (n + 1))) = + 𝟙 (tensorPow A (X ⊞ Y) n) ⊗ₘ + (letterFrom X Y b ≫ letterInto X Y b) := by + intro b + rw [← ih] + exact (sum_tensor _ _ _).symm + have e5 : (∑ b : Bool, ∑ w' : Fin n → Bool, + ((mixedFrom X Y n w' ≫ mixedInto X Y n w') ⊗ₘ + (letterFrom X Y b ≫ letterInto X Y b) : + tensorPow A (X ⊞ Y) (n + 1) ⟶ + tensorPow A (X ⊞ Y) (n + 1))) = + ∑ b : Bool, 𝟙 (tensorPow A (X ⊞ Y) n) ⊗ₘ + (letterFrom X Y b ≫ letterInto X Y b) := + Finset.sum_congr rfl fun b _ => e4 b + have e6 : (∑ b : Bool, 𝟙 (tensorPow A (X ⊞ Y) n) ⊗ₘ + (letterFrom X Y b ≫ letterInto X Y b)) = + 𝟙 (tensorPow A (X ⊞ Y) (n + 1)) := by + rw [← tensor_sum, Fintype.sum_bool] + change 𝟙 (tensorPow A (X ⊞ Y) n) ⊗ₘ + (biprod.fst ≫ biprod.inl + biprod.snd ≫ biprod.inr) = 𝟙 _ + rw [biprod.total, MonoidalCategory.id_tensorHom_id] + exact e1.trans (e2.trans (e3.trans (e5.trans e6))) + +end MonPre + +end Biprod + +/-! ## Counting letters and the sorted words -/ + +/-- The number of `true` letters of a word. -/ +def popCount {n : ℕ} (w : Fin n → Bool) : ℕ := + (Finset.univ.filter fun i => w i = true).card + +/-- At most every letter is `true`. -/ +theorem popCount_le {n : ℕ} (w : Fin n → Bool) : popCount w ≤ n := by + have h := Finset.card_filter_le Finset.univ fun i => w i = true + rwa [Finset.card_univ, Fintype.card_fin] at h + +/-- The empty word has no `true` letters. -/ +theorem popCount_nil (w : Fin 0 → Bool) : popCount w = 0 := by + simp [popCount] + +/-- The letter count splits off the last letter. -/ +theorem popCount_succ {n : ℕ} (w : Fin (n + 1) → Bool) : + popCount w = + popCount (w ∘ Fin.castSucc) + + (bif w (Fin.last n) then 1 else 0) := by + have key : ∀ (m : ℕ) (v : Fin m → Bool), + popCount v = ∑ i, if v i = true then 1 else 0 := by + intro m v + simp [popCount] + have hsum : (∑ i : Fin n, if w (Fin.castSucc i) = true + then 1 else 0) = + ∑ i : Fin n, if (w ∘ Fin.castSucc) i = true then 1 else 0 := + Finset.sum_congr rfl fun i _ => rfl + rw [key, key, Fin.sum_univ_castSucc, hsum] + cases hw : w (Fin.last n) <;> rfl + +/-- **The sorting permutation** of a word: the last slot is routed +below the tail — to the top of the `X` block when its letter is +`true`, and kept in place when it is `false` — and the rest is +sorted recursively. This is the `ofSplit` decomposition the +tensor-power action recurses on. -/ +noncomputable def sortPerm : + {n : ℕ} → (Fin n → Bool) → Equiv.Perm (Fin n) + | 0, _ => 1 + | n + 1, w => + ofSplit + (bif w (Fin.last n) + then ⟨popCount (w ∘ Fin.castSucc), + Nat.lt_succ_of_le (popCount_le _)⟩ + else Fin.last n) + (sortPerm (w ∘ Fin.castSucc)) + +/-- The defining recursion of `sortPerm`. -/ +theorem sortPerm_succ {n : ℕ} (w : Fin (n + 1) → Bool) : + sortPerm w = + ofSplit + (bif w (Fin.last n) + then ⟨popCount (w ∘ Fin.castSucc), + Nat.lt_succ_of_le (popCount_le _)⟩ + else Fin.last n) + (sortPerm (w ∘ Fin.castSucc)) := rfl + +/-- **The sorted word**: `true` on the first block of `p` slots and +`false` on the last `q`. -/ +def standardWord (p q : ℕ) : Fin (p + q) → Bool := + fun i => decide ((i : ℕ) < p) + +/-- With an empty second block the sorted word is all `true`. -/ +theorem standardWord_zero (p : ℕ) : + standardWord p 0 = fun _ => true := by + funext i + exact decide_eq_true i.isLt + +/-- Restricting a sorted word drops one `false` letter. -/ +theorem standardWord_castSucc (p q : ℕ) : + standardWord p (q + 1) ∘ Fin.castSucc = standardWord p q := rfl + +/-- The last letter of a sorted word with `false` letters is +`false`. -/ +theorem standardWord_last (p q : ℕ) : + standardWord p (q + 1) (Fin.last (p + q)) = false := by + have h : ¬ (p + q < p) := by omega + simp [standardWord, h] + +/-! ## The sorted word power -/ + +/-- An all-`true` word power is a pure power of `X`. -/ +theorem wordPow_const_true [Category.{v} A] [MonoidalCategory A] + (X Y : A) : + ∀ n : ℕ, wordPow X Y n (fun _ => true) = tensorPow A X n := by + intro n + induction n with + | zero => rfl + | succ n ih => + change wordPow X Y n (fun _ => true) ⊗ X = tensorPow A X n ⊗ X + rw [ih] + +/-- The sorted word power with empty second block is the pure +power of `X`. -/ +theorem wordPow_standard_zero [Category.{v} A] [MonoidalCategory A] + (X Y : A) (p : ℕ) : + wordPow X Y (p + 0) (standardWord p 0) = tensorPow A X p := by + rw [standardWord_zero] + exact wordPow_const_true X Y p + +/-- One more `false` letter of a sorted word tensors a `Y`. -/ +theorem wordPow_standard_succ [Category.{v} A] [MonoidalCategory A] + (X Y : A) (p q : ℕ) : + wordPow X Y (p + (q + 1)) (standardWord p (q + 1)) = + wordPow X Y (p + q) (standardWord p q) ⊗ Y := by + change wordPow X Y (p + q) + (standardWord p (q + 1) ∘ Fin.castSucc) ⊗ + (bif standardWord p (q + 1) (Fin.last (p + q)) then X else Y) = + wordPow X Y (p + q) (standardWord p q) ⊗ Y + rw [standardWord_castSucc, standardWord_last] + rfl + +/-- **The sorted word power is a concatenation of pure powers**: +with all `X`s below all `Y`s, the word power reassociates to +`X ^ ⊗ p ⊗ Y ^ ⊗ q`. Built by the recursion of the word, so that +consumers can compose with it stage by stage. -/ +noncomputable def standardMixedIso [Category.{v} A] [MonoidalCategory A] + (X Y : A) (p : ℕ) : (q : ℕ) → + (wordPow X Y (p + q) (standardWord p q) ≅ + tensorPow A X p ⊗ tensorPow A Y q) + | 0 => + eqToIso (wordPow_standard_zero X Y p) ≪≫ + (ρ_ (tensorPow A X p)).symm + | q + 1 => + eqToIso (wordPow_standard_succ X Y p q) ≪≫ + whiskerRightIso (standardMixedIso X Y p q) Y ≪≫ + α_ (tensorPow A X p) (tensorPow A Y q) Y + +/-! ## The base-point inclusion + +On a sorted word, `mixedInto` is the concatenation of the two +pure-power inclusions. The gluing helpers are stated at general +objects and applied by `exact`, so that no tensor-power arity +enters the rewriting. +-/ + +/-- Tensoring with the unit's identity is unitor conjugation. +Stated at general objects. -/ +private theorem unit_tensor_unitor [Category.{v} A] [MonoidalCategory A] + {P Q : A} (f : P ⟶ Q) : + (f ⊗ₘ 𝟙 (𝟙_ A)) ≫ (ρ_ Q).hom = (ρ_ P).hom ≫ f := by + rw [MonoidalCategory.tensorHom_id] + exact MonoidalCategory.rightUnitor_naturality f + +/-- One stage of the concatenation glued onto an intertwining of +the previous stage. Stated at general objects. -/ +private theorem concat_step_glue [Category.{v} A] [MonoidalCategory A] + {P Q W R P' Q' Y Z : A} + (u : P ⊗ Q ⟶ W) (M : W ⟶ R) (f : P ⟶ P') (g : Q ⟶ Q') + (c : P' ⊗ Q' ⟶ R) (e : Y ⟶ Z) + (hih : u ≫ M = (f ⊗ₘ g) ≫ c) : + (α_ P Q Y).inv ≫ ((u ▷ Y) ≫ (M ⊗ₘ e)) = + (f ⊗ₘ (g ⊗ₘ e)) ≫ (α_ P' Q' Z).inv ≫ (c ▷ Z) := by + have h1 : (u ▷ Y) ≫ (M ⊗ₘ e) = (u ≫ M) ⊗ₘ e := by + rw [← MonoidalCategory.tensorHom_id u Y, + MonoidalCategory.tensorHom_comp_tensorHom, Category.id_comp] + have h2 : ((f ⊗ₘ g) ⊗ₘ e) ≫ (c ▷ Z) = ((f ⊗ₘ g) ≫ c) ⊗ₘ e := by + rw [← MonoidalCategory.tensorHom_id c Z, + MonoidalCategory.tensorHom_comp_tensorHom, Category.comp_id] + have h3 : (α_ P Q Y).inv ≫ ((f ⊗ₘ g) ⊗ₘ e) = + (f ⊗ₘ (g ⊗ₘ e)) ≫ (α_ P' Q' Z).inv := + (MonoidalCategory.associator_inv_naturality f g e).symm + calc (α_ P Q Y).inv ≫ ((u ▷ Y) ≫ (M ⊗ₘ e)) + = (α_ P Q Y).inv ≫ (((f ⊗ₘ g) ≫ c) ⊗ₘ e) := by rw [h1, hih] + _ = (α_ P Q Y).inv ≫ ((f ⊗ₘ g) ⊗ₘ e) ≫ (c ▷ Z) := by rw [h2] + _ = ((f ⊗ₘ (g ⊗ₘ e)) ≫ (α_ P' Q' Z).inv) ≫ (c ▷ Z) := by + rw [← Category.assoc, h3] + _ = (f ⊗ₘ (g ⊗ₘ e)) ≫ (α_ P' Q' Z).inv ≫ (c ▷ Z) := + Category.assoc _ _ _ + +/-- An `eqToHom` pulls out of the first factor of a tensor. Stated +at general objects. -/ +private theorem eqToHom_tensor_pull [Category.{v} A] [MonoidalCategory A] + {P P' Q R S : A} (h : P = P') + (f : P' ⟶ Q) (g : R ⟶ S) : + (eqToHom h ≫ f) ⊗ₘ g = + eqToHom (congrArg (· ⊗ R) h) ≫ (f ⊗ₘ g) := by + subst h + rw [eqToHom_refl, eqToHom_refl, Category.id_comp, Category.id_comp] + +/-- Append a definitionally trivial transport to a two-step +factorisation. The transport's endpoints coincide, so `exact` +applies it wherever they agree definitionally. -/ +private theorem comp_cast_end₂ [Category.{v} A] + {P Q R : A} {f : P ⟶ R} {g₁ : P ⟶ Q} + {g₂ : Q ⟶ R} (H : R = R) (hfg : f = g₁ ≫ g₂) : + f = g₁ ≫ g₂ ≫ eqToHom H := by + erw [show H = rfl from rfl, eqToHom_refl, Category.comp_id, hfg] + +/-- A transport and its inverse cancel across a decomposition of +the middle morphism. Stated at general objects and applied by +`exact`, so the defeq-mismatched arities never enter a rewrite. -/ +private theorem cast_cancel_glue [Category.{v} A] + {U V W R : A} (h : V = W) + (h' : W = V) (a : U ⟶ V) (D : W ⟶ R) (T : V ⟶ R) + (hD : D = eqToHom h' ≫ T) : + (a ≫ eqToHom h) ≫ D = a ≫ T := by + subst h + rw [hD, show h' = rfl from rfl, eqToHom_refl, + Category.id_comp, Category.comp_id] + +section Base + +/-- Transport of `mixedInto` along an equality of words. -/ +theorem mixedInto_congr [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + (X Y : A) {n : ℕ} {w w' : Fin n → Bool} + (h : w = w') : + mixedInto X Y n w = + eqToHom (congrArg (wordPow X Y n) h) ≫ mixedInto X Y n w' := by + subst h + rw [eqToHom_refl, Category.id_comp] + +/-- Splitting `mixedInto` at the last letter, with the recursion's +word and letter replaced by given values. -/ +theorem mixedInto_split [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + (X Y : A) (n : ℕ) (w : Fin (n + 1) → Bool) + (w' : Fin n → Bool) (b : Bool) (hw : w ∘ Fin.castSucc = w') + (hb : w (Fin.last n) = b) + (h : wordPow X Y (n + 1) w = + wordPow X Y n w' ⊗ (bif b then X else Y)) : + mixedInto X Y (n + 1) w = + eqToHom h ≫ (mixedInto X Y n w' ⊗ₘ letterInto X Y b) := by + subst hw + subst hb + exact (Category.id_comp _).symm + +/-- On an all-`true` word the inclusion is the pure power of +`biprod.inl`. -/ +theorem mixedInto_const_true + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + (X Y : A) : + ∀ n : ℕ, + mixedInto X Y n (fun _ => true) = + eqToHom (wordPow_const_true X Y n) ≫ + tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) n := by + intro n + induction n with + | zero => + exact (Category.id_comp _).symm + | succ n ih => + change mixedInto X Y n (fun _ => true) ⊗ₘ + (biprod.inl : X ⟶ X ⊞ Y) = _ + rw [ih] + exact eqToHom_tensor_pull (wordPow_const_true X Y n) _ _ + +/-- The last-letter split of `mixedInto` at a `false` letter, with +the selected object and inclusion spelled as `Y` and `biprod.inr`. -/ +theorem mixedInto_split_false + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + (X Y : A) (n : ℕ) + (w : Fin (n + 1) → Bool) (w' : Fin n → Bool) + (hw : w ∘ Fin.castSucc = w') (hb : w (Fin.last n) = false) + (h : wordPow X Y (n + 1) w = wordPow X Y n w' ⊗ Y) : + mixedInto X Y (n + 1) w = + eqToHom h ≫ + (mixedInto X Y n w' ⊗ₘ (biprod.inr : Y ⟶ X ⊞ Y)) := + mixedInto_split X Y n w w' false hw hb h + +/-- The last-letter split of `mixedInto` at a `true` letter, with +the selected object and inclusion spelled as `X` and `biprod.inl`. -/ +theorem mixedInto_split_true + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + (X Y : A) (n : ℕ) + (w : Fin (n + 1) → Bool) (w' : Fin n → Bool) + (hw : w ∘ Fin.castSucc = w') (hb : w (Fin.last n) = true) + (h : wordPow X Y (n + 1) w = wordPow X Y n w' ⊗ X) : + mixedInto X Y (n + 1) w = + eqToHom h ≫ + (mixedInto X Y n w' ⊗ₘ (biprod.inl : X ⟶ X ⊞ Y)) := + mixedInto_split X Y n w w' true hw hb h + +/-- Transport along the `p + 0` arity cast composes away against +the pure power of the first inclusion. -/ +private theorem inl_pow_cast + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + (X Y : A) (m : ℕ) + (H : tensorPow A X m = tensorPow A X (m + 0)) : + eqToHom H ≫ tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) (m + 0) = + tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) m := by + erw [show H = rfl from rfl, eqToHom_refl, Category.id_comp] + rfl + +end Base + +/-! ## Sorting + +Every word's inclusion is the base-point inclusion of its sorted +form, up to the symmetric-group action. The categorical content is +a single full rotation: bubbling the top factor all the way down is +the braiding against the whole tail, followed by a merge of the new +bottom factor into the concatenation — `insertTop_full` and +`putBelow_concat` below. +-/ + +section Symmetric + +/-- The recursion of the action, at a split permutation. -/ +theorem permMor_ofSplit + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (Z : A) (n : ℕ) (q : Fin (n + 1)) + (τ : Equiv.Perm (Fin n)) : + permMor Z (n + 1) (ofSplit q τ) = + (permMor Z n τ ▷ Z) ≫ insertTop Z n (n - (q : ℕ)) := by + rw [permMor_succ, restPerm_ofSplit, topImage_ofSplit] + +/-- The hexagon, arranged for one bubbling step: braiding the top +two slots and then the lower pair against the top is braiding the +joint pair. Stated at a general object. -/ +private theorem swap_hexagon + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (P Z : A) : + ((α_ P Z Z).hom ≫ (P ◁ (β_ Z Z).hom) ≫ (α_ P Z Z).inv) ≫ + ((β_ P Z).hom ▷ Z) = + (β_ (P ⊗ Z) Z).hom ≫ (α_ Z P Z).inv := by + have h := BraidedCategory.hexagon_reverse P Z Z + calc ((α_ P Z Z).hom ≫ (P ◁ (β_ Z Z).hom) ≫ (α_ P Z Z).inv) ≫ + ((β_ P Z).hom ▷ Z) + = (α_ P Z Z).hom ≫ ((P ◁ (β_ Z Z).hom) ≫ (α_ P Z Z).inv ≫ + ((β_ P Z).hom ▷ Z)) := by simp only [Category.assoc] + _ = (α_ P Z Z).hom ≫ (α_ P Z Z).inv ≫ (β_ (P ⊗ Z) Z).hom ≫ + (α_ Z P Z).inv := by rw [← h] + _ = (β_ (P ⊗ Z) Z).hom ≫ (α_ Z P Z).inv := by + rw [Iso.hom_inv_id_assoc] + +/-- One rotation step, at a general base object: a braid-and-merge +of the lower slots, whiskered and preceded by the top braiding, is +the joint braid-and-merge one slot higher. -/ +private theorem rotate_step + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + {P V : A} (Z : A) (i : P ⊗ Z ⟶ V) + (u : Z ⊗ P ⟶ V) (hi : i = (β_ P Z).hom ≫ u) : + ((α_ P Z Z).hom ≫ (P ◁ (β_ Z Z).hom) ≫ (α_ P Z Z).inv) ≫ + (i ▷ Z) = + (β_ (P ⊗ Z) Z).hom ≫ (α_ Z P Z).inv ≫ (u ▷ Z) := by + rw [hi, MonoidalCategory.comp_whiskerRight, ← Category.assoc, + swap_hexagon, Category.assoc] + +/-- **Merging a factor at the bottom**: the structural morphism +`Z ⊗ Z ^ ⊗ m ⟶ Z ^ ⊗ (m + 1)`, by the recursion of the power. -/ +noncomputable def putBelow [Category.{v} A] [MonoidalCategory A] + (Z : A) : (m : ℕ) → + (Z ⊗ tensorPow A Z m ⟶ tensorPow A Z (m + 1)) + | 0 => (ρ_ Z).hom ≫ (λ_ Z).inv + | m + 1 => + (α_ Z (tensorPow A Z m) Z).inv ≫ (putBelow Z m ▷ Z) + +/-- **The full rotation is a braiding**: bubbling the top factor of +`Z ^ ⊗ (m + 1)` all the way to the bottom is the braiding of the +factor against the whole tail, followed by the bottom merge. -/ +theorem insertTop_full + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (Z : A) : + ∀ m : ℕ, insertTop Z m m = + (β_ (tensorPow A Z m) Z).hom ≫ putBelow Z m := by + intro m + induction m with + | zero => + rw [insertTop_zero] + have h : (β_ (𝟙_ A) Z).hom ≫ (ρ_ Z).hom ≫ (λ_ Z).inv = + 𝟙 (𝟙_ A ⊗ Z) := by + rw [← Category.assoc, braiding_rightUnitor, Iso.hom_inv_id] + exact h.symm + | succ m ih => + rw [insertTop_succ] + exact rotate_step Z (insertTop Z m m) (putBelow Z m) ih + +/-- A whiskered arity transport is the transport one arity up. +Stated with both transports explicit, so it applies by `exact` +wherever the endpoints agree definitionally. -/ +private theorem cast_whiskerRight_eq [Category.{v} A] [MonoidalCategory A] + (Z : A) {P Q : A} (h : P = Q) + (h' : P ⊗ Z = Q ⊗ Z) : + eqToHom h ▷ Z = eqToHom h' := by + subst h + rw [show h' = rfl from rfl, eqToHom_refl, eqToHom_refl, + MonoidalCategory.id_whiskerRight] + +/-- The bottom merge against one concatenation stage, at the empty +tail: pure unitor coherence, at general objects. -/ +private theorem putBelow_concat_zero_coh [Category.{v} A] [MonoidalCategory A] + (P Z : A) : + (P ◁ ((ρ_ Z).hom ≫ (λ_ Z).inv)) ≫ + ((α_ P (𝟙_ A) Z).inv ≫ ((ρ_ P).hom ▷ Z)) = + (α_ P Z (𝟙_ A)).inv ≫ (ρ_ (P ⊗ Z)).hom := by + monoidal + +/-- The inductive step of the bottom merge against the +concatenation, at general objects: the pentagon and naturality. -/ +private theorem merge_step_glue [Category.{v} A] [MonoidalCategory A] + {P U M W B' N N' : A} + (u : U ⊗ M ⟶ B') (c : P ⊗ B' ⟶ N) + (c' : (P ⊗ U) ⊗ M ⟶ N') (E : N' ⟶ N) + (hih : (P ◁ u) ≫ c = (α_ P U M).inv ≫ c' ≫ E) : + (P ◁ ((α_ U M W).inv ≫ (u ▷ W))) ≫ + ((α_ P B' W).inv ≫ (c ▷ W)) = + (α_ P U (M ⊗ W)).inv ≫ (α_ (P ⊗ U) M W).inv ≫ + (c' ▷ W) ≫ (E ▷ W) := by + have hpent : (P ◁ (α_ U M W).inv) ≫ (α_ P (U ⊗ M) W).inv ≫ + ((α_ P U M).inv ▷ W) = + (α_ P U (M ⊗ W)).inv ≫ (α_ (P ⊗ U) M W).inv := by + monoidal + calc (P ◁ ((α_ U M W).inv ≫ (u ▷ W))) ≫ + ((α_ P B' W).inv ≫ (c ▷ W)) + = (P ◁ (α_ U M W).inv) ≫ ((P ◁ (u ▷ W)) ≫ + (α_ P B' W).inv) ≫ (c ▷ W) := by + rw [MonoidalCategory.whiskerLeft_comp] + try simp only [Category.assoc] + _ = (P ◁ (α_ U M W).inv) ≫ ((α_ P (U ⊗ M) W).inv ≫ + ((P ◁ u) ▷ W)) ≫ (c ▷ W) := by + rw [MonoidalCategory.associator_inv_naturality_middle] + _ = (P ◁ (α_ U M W).inv) ≫ (α_ P (U ⊗ M) W).inv ≫ + ((P ◁ u) ≫ c) ▷ W := by + rw [MonoidalCategory.comp_whiskerRight] + try simp only [Category.assoc] + _ = (P ◁ (α_ U M W).inv) ≫ (α_ P (U ⊗ M) W).inv ≫ + ((α_ P U M).inv ▷ W) ≫ (c' ▷ W) ≫ (E ▷ W) := by + rw [hih, MonoidalCategory.comp_whiskerRight, + MonoidalCategory.comp_whiskerRight] + try simp only [Category.assoc] + _ = ((P ◁ (α_ U M W).inv) ≫ (α_ P (U ⊗ M) W).inv ≫ + ((α_ P U M).inv ▷ W)) ≫ (c' ▷ W) ≫ (E ▷ W) := by + simp only [Category.assoc] + _ = (α_ P U (M ⊗ W)).inv ≫ (α_ (P ⊗ U) M W).inv ≫ + (c' ▷ W) ≫ (E ▷ W) := by + rw [hpent] + try simp only [Category.assoc] + +/-- **The bottom merge concatenates**: merging a factor below the +second block and concatenating is reassociating it onto the first +block, up to the arity transport. -/ +theorem putBelow_concat [Category.{v} A] [MonoidalCategory A] + (Z : A) (p : ℕ) : + ∀ m : ℕ, + (tensorPow A Z p ◁ putBelow Z m) ≫ + (tensorPowConcat Z p (m + 1)).hom = + (α_ (tensorPow A Z p) Z (tensorPow A Z m)).inv ≫ + (tensorPowConcat Z (p + 1) m).hom ≫ + eqToHom (congrArg (tensorPow A Z) + (Nat.succ_add_eq_add_succ p m)) := by + intro m + induction m with + | zero => + exact comp_cast_end₂ _ + (putBelow_concat_zero_coh (tensorPow A Z p) Z) + | succ m ih => + have step := merge_step_glue (P := tensorPow A Z p) (W := Z) + (putBelow Z m) (tensorPowConcat Z p (m + 1)).hom + (tensorPowConcat Z (p + 1) m).hom + (eqToHom (congrArg (tensorPow A Z) + (Nat.succ_add_eq_add_succ p m))) ih + refine step.trans ?_ + rw [cast_whiskerRight_eq Z + (congrArg (tensorPow A Z) (Nat.succ_add_eq_add_succ p m)) + (congrArg (tensorPow A Z) + (Nat.succ_add_eq_add_succ p (m + 1)))] + exact congrArg + (fun t => (α_ (tensorPow A Z p) Z + (tensorPow A Z m ⊗ Z)).inv ≫ t) + (Category.assoc _ _ _).symm + +/-- Splitting the first factor off a composite tensored against a +morphism. Stated at general objects. -/ +private theorem tensor_split_first [Category.{v} A] [MonoidalCategory A] + {P Q R S T : A} (a : P ⟶ Q) + (v : Q ⟶ R) (g : S ⟶ T) : + (a ≫ v) ⊗ₘ g = (a ▷ S) ≫ (v ⊗ₘ g) := by + calc (a ≫ v) ⊗ₘ g = (a ≫ v) ⊗ₘ (𝟙 S ≫ g) := by + rw [Category.id_comp] + _ = (a ⊗ₘ 𝟙 S) ≫ (v ⊗ₘ g) := + (MonoidalCategory.tensorHom_comp_tensorHom _ _ _ _).symm + _ = (a ▷ S) ≫ (v ⊗ₘ g) := by + rw [MonoidalCategory.tensorHom_id] + +/-- Splitting the last factor off a composite tensored against a +morphism. Stated at general objects. -/ +private theorem tensor_split_last [Category.{v} A] [MonoidalCategory A] + {P Q R S T : A} (v : P ⟶ Q) + (E : Q ⟶ R) (g : S ⟶ T) : + (v ≫ E) ⊗ₘ g = (v ⊗ₘ g) ≫ (E ▷ T) := by + calc (v ≫ E) ⊗ₘ g = (v ≫ E) ⊗ₘ (g ≫ 𝟙 T) := by + rw [Category.comp_id] + _ = (v ⊗ₘ g) ≫ (E ⊗ₘ 𝟙 T) := + (MonoidalCategory.tensorHom_comp_tensorHom _ _ _ _).symm + _ = (v ⊗ₘ g) ≫ (E ▷ T) := by + rw [MonoidalCategory.tensorHom_id] + +/-- A tensor absorbed into the second factor through a left +whiskering. Stated at general objects. -/ +private theorem tensor_then_whiskerLeft [Category.{v} A] [MonoidalCategory A] + {P Q S T U : A} (g : P ⟶ Q) + (h : S ⟶ T) (k : T ⟶ U) : + (g ⊗ₘ h) ≫ (Q ◁ k) = g ⊗ₘ (h ≫ k) := by + rw [← MonoidalCategory.id_tensorHom Q k, + MonoidalCategory.tensorHom_comp_tensorHom, Category.comp_id] + +/-- A left whiskering absorbed into the second factor of a tensor. +Stated at general objects. -/ +private theorem whiskerLeft_then_tensor [Category.{v} A] [MonoidalCategory A] + {P Q S T U : A} (g : P ⟶ Q) + (h : S ⟶ T) (k : T ⟶ U) : + (P ◁ h) ≫ (g ⊗ₘ k) = g ⊗ₘ (h ≫ k) := by + rw [← MonoidalCategory.id_tensorHom P h, + MonoidalCategory.tensorHom_comp_tensorHom, Category.id_comp] + +/-- One concatenation stage, whiskered: reassociate and take the +next stage. -/ +private theorem concat_whisker_step [Category.{v} A] [MonoidalCategory A] + (Z : A) (p m : ℕ) : + ((tensorPowConcat Z p m).hom ▷ Z) = + (α_ (tensorPow A Z p) (tensorPow A Z m) Z).hom ≫ + (tensorPowConcat Z p (m + 1)).hom := + (Iso.hom_inv_id_assoc + (α_ (tensorPow A Z p) (tensorPow A Z m) Z) _).symm + +/-- Arity transport commutes with the insertion cycle. -/ +private theorem insertTop_cast + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (Z : A) (a b k : ℕ) (hab : a = b) + (H : tensorPow A Z a = tensorPow A Z b) : + (eqToHom H ▷ Z) ≫ insertTop Z b k = + insertTop Z a k ≫ (eqToHom H ▷ Z) := by + subst hab + erw [show H = rfl from rfl, eqToHom_refl, + MonoidalCategory.id_whiskerRight, Category.id_comp] + exact (Category.comp_id _).symm + +/-- An arity transport composed with a whiskered one is the joint +transport. -/ +private theorem cast_then_cast_whisker [Category.{v} A] [MonoidalCategory A] + (Z : A) {a b n : ℕ} + (hab : a = b + 1) (hbn : b = n) + (H₁ : tensorPow A Z a = tensorPow A Z (b + 1)) + (H₂ : tensorPow A Z b = tensorPow A Z n) + (H₃ : tensorPow A Z a = tensorPow A Z (n + 1)) : + eqToHom H₁ ≫ (eqToHom H₂ ▷ Z) = eqToHom H₃ := by + subst hbn + subst hab + erw [show H₁ = rfl from rfl, show H₂ = rfl from rfl, + show H₃ = rfl from rfl, eqToHom_refl, eqToHom_refl, + MonoidalCategory.id_whiskerRight, Category.id_comp] + rfl + +/-- `tensor_then_whiskerLeft` against a tail. -/ +private theorem tensor_then_whiskerLeft_assoc + [Category.{v} A] [MonoidalCategory A] + {P Q S T U V : A} + (g : P ⟶ Q) (h : S ⟶ T) (k : T ⟶ U) (rest : Q ⊗ U ⟶ V) : + (g ⊗ₘ h) ≫ (Q ◁ k) ≫ rest = (g ⊗ₘ (h ≫ k)) ≫ rest := by + rw [← Category.assoc, tensor_then_whiskerLeft] + +/-- `whiskerLeft_then_tensor` against a tail. -/ +private theorem whiskerLeft_then_tensor_assoc + [Category.{v} A] [MonoidalCategory A] + {P Q S T U V : A} + (g : P ⟶ Q) (h : S ⟶ T) (k : T ⟶ U) (rest : Q ⊗ U ⟶ V) : + (P ◁ h) ≫ (g ⊗ₘ k) ≫ rest = (g ⊗ₘ (h ≫ k)) ≫ rest := by + rw [← Category.assoc, whiskerLeft_then_tensor] + +/-- One whiskered concatenation stage against the insertion cycle: +reassociate, insert within the second block, and concatenate. -/ +private theorem concat_whisker_insert + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (Z : A) (p m : ℕ) : + ((tensorPowConcat Z p m).hom ▷ Z) ≫ insertTop Z (p + m) m = + (α_ (tensorPow A Z p) (tensorPow A Z m) Z).hom ≫ + ((tensorPow A Z p ◁ insertTop Z m m) ≫ + (tensorPowConcat Z p (m + 1)).hom) := by + have h1 := tensorPowConcat_insertTop Z p m m le_rfl + calc ((tensorPowConcat Z p m).hom ▷ Z) ≫ insertTop Z (p + m) m + = ((α_ (tensorPow A Z p) (tensorPow A Z m) Z).hom ≫ + (tensorPowConcat Z p (m + 1)).hom) ≫ + insertTop Z (p + m) m := by + rw [concat_whisker_step] + exact rfl + _ = (α_ (tensorPow A Z p) (tensorPow A Z m) Z).hom ≫ + ((tensorPowConcat Z p (m + 1)).hom ≫ + insertTop Z (p + m) m) := Category.assoc _ _ _ + _ = (α_ (tensorPow A Z p) (tensorPow A Z m) Z).hom ≫ + ((tensorPow A Z p ◁ insertTop Z m m) ≫ + (tensorPowConcat Z p (m + 1)).hom) := + congrArg + (fun t => (α_ (tensorPow A Z p) (tensorPow A Z m) Z).hom ≫ t) + h1 + +/-- A tensor absorbed through a right whiskering. Stated at +general objects. -/ +private theorem tensor_then_whiskerRight [Category.{v} A] [MonoidalCategory A] + {P Q R S T : A} + (f : P ⟶ Q) (u : Q ⟶ R) (g : S ⟶ T) : + (f ⊗ₘ g) ≫ (u ▷ T) = (f ≫ u) ⊗ₘ g := by + rw [← MonoidalCategory.tensorHom_id u T, + MonoidalCategory.tensorHom_comp_tensorHom, Category.comp_id] + +/-- The concatenation's successor stage, unfolded. -/ +private theorem tensorPowConcat_succ_hom [Category.{v} A] [MonoidalCategory A] + (Z : A) (a b : ℕ) : + (tensorPowConcat Z a (b + 1)).hom = + (α_ (tensorPow A Z a) (tensorPow A Z b) Z).inv ≫ + ((tensorPowConcat Z a b).hom ▷ Z) := rfl + +/-- Reassociating a parenthesised three-chain against a tail. -/ +private theorem assoc₃ [Category.{v} A] + {P Q R S T : A} (a : P ⟶ Q) (b : Q ⟶ R) + (c : R ⟶ S) (d : S ⟶ T) : + (a ≫ b ≫ c) ≫ d = a ≫ b ≫ c ≫ d := by + simp only [Category.assoc] + +/-- The false-branch gluing at general objects: tensoring a +four-chain with a letter splits it around the reassociation. -/ +private theorem sorted_false_glue [Category.{v} A] [MonoidalCategory A] + {W P Q P' Q' N N' Y Z : A} + (a : W ⟶ P ⊗ Q) (f₁ : P ⟶ P') (f₂ : Q ⟶ Q') + (c : P' ⊗ Q' ⟶ N) (E : N ⟶ N') (g : Y ⟶ Z) : + (a ≫ (f₁ ⊗ₘ f₂) ≫ c ≫ E) ⊗ₘ g = + (a ▷ Y) ≫ (α_ P Q Y).hom ≫ (f₁ ⊗ₘ (f₂ ⊗ₘ g)) ≫ + (α_ P' Q' Z).inv ≫ (c ▷ Z) ≫ (E ▷ Z) := by + rw [tensor_split_first, tensor_split_last, + MonoidalCategory.comp_whiskerRight, + MonoidalCategory.associator_conjugation] + simp only [Category.assoc] + +section SortedBiprod + +/-- **Sorting one appended `X`**: the base-point inclusion with one +more `X` in the last slot, bubbled down past the whole `Y` block, +is the base-point inclusion of the grown `X` block — up to braiding +the appended factor past the `Y` power on the mixed side and the +arity transport `(p + 1) + m = p + (m + 1)` at the target. -/ +theorem base_insert_true + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [HasBinaryBiproducts A] + (X Y : A) (p m : ℕ) : + (((tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) p ⊗ₘ + tensorPowMap (biprod.inr : Y ⟶ X ⊞ Y) m) ≫ + (tensorPowConcat (X ⊞ Y) p m).hom) ⊗ₘ + (biprod.inl : X ⟶ X ⊞ Y)) ≫ + insertTop (X ⊞ Y) (p + m) m = + (α_ (tensorPow A X p) (tensorPow A Y m) X).hom ≫ + (tensorPow A X p ◁ (β_ (tensorPow A Y m) X).hom) ≫ + (α_ (tensorPow A X p) X (tensorPow A Y m)).inv ≫ + (tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) (p + 1) ⊗ₘ + tensorPowMap (biprod.inr : Y ⟶ X ⊞ Y) m) ≫ + (tensorPowConcat (X ⊞ Y) (p + 1) m).hom ≫ + eqToHom (congrArg (tensorPow A (X ⊞ Y)) + (Nat.succ_add_eq_add_succ p m)) := by + rw [tensor_split_last] + repeat' erw [Category.assoc] + rw [concat_whisker_insert, insertTop_full, + MonoidalCategory.associator_naturality_assoc, + tensor_then_whiskerLeft_assoc, + BraidedCategory.braiding_naturality_assoc, + ← whiskerLeft_then_tensor_assoc, ← tensor_then_whiskerLeft_assoc, + putBelow_concat, MonoidalCategory.associator_inv_naturality_assoc] + exact rfl + +/-- Regrouping a flat seven-chain into the packaged form. Stated +at general objects. -/ +private theorem false_final_shape [Category.{v} A] + {W₀ W₁ P R₁ R₂ R₃ R₄ R₅ : A} + (a : W₀ ⟶ W₁) (b : W₁ ⟶ P) (c : P ⟶ R₁) (t : R₁ ⟶ R₂) + (ai : R₂ ⟶ R₃) (cw : R₃ ⟶ R₄) (e : R₄ ⟶ R₅) : + a ≫ b ≫ c ≫ t ≫ ai ≫ cw ≫ e = + (a ≫ b ≫ c) ≫ t ≫ (ai ≫ cw) ≫ e := by + simp only [Category.assoc] + +/-- **The sorting square grows by a `false` letter**: the appended +`Y` joins the top of the `Y` block and nothing is bubbled. -/ +private theorem sorted_step_false + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [HasBinaryBiproducts A] + (X Y : A) {n : ℕ} + (w : Fin (n + 1) → Bool) (p m : ℕ) + (hpm : p + m = n) (hq1 : p + (m + 1) = n + 1) + (e' : wordPow X Y n (w ∘ Fin.castSucc) ≅ + tensorPow A X p ⊗ tensorPow A Y m) + (hobj : wordPow X Y (n + 1) w = + wordPow X Y n (w ∘ Fin.castSucc) ⊗ Y) + (hb : w (Fin.last n) = false) + (hperm : permMor (X ⊞ Y) (n + 1) (sortPerm w) = + permMor (X ⊞ Y) n (sortPerm (w ∘ Fin.castSucc)) ▷ (X ⊞ Y)) + (hsq' : mixedInto X Y n (w ∘ Fin.castSucc) ≫ + permMor (X ⊞ Y) n (sortPerm (w ∘ Fin.castSucc)) = + e'.hom ≫ + (tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) p ⊗ₘ + tensorPowMap (biprod.inr : Y ⟶ X ⊞ Y) m) ≫ + (tensorPowConcat (X ⊞ Y) p m).hom ≫ + eqToHom (congrArg (tensorPow A (X ⊞ Y)) hpm)) : + mixedInto X Y (n + 1) w ≫ + permMor (X ⊞ Y) (n + 1) (sortPerm w) = + (eqToIso hobj ≪≫ whiskerRightIso e' Y ≪≫ + α_ (tensorPow A X p) (tensorPow A Y m) Y).hom ≫ + (tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) p ⊗ₘ + tensorPowMap (biprod.inr : Y ⟶ X ⊞ Y) (m + 1)) ≫ + (tensorPowConcat (X ⊞ Y) p (m + 1)).hom ≫ + eqToHom (congrArg (tensorPow A (X ⊞ Y)) hq1) := by + have hsplit := mixedInto_split_false X Y n w (w ∘ Fin.castSucc) + rfl hb hobj + have hcast := cast_whiskerRight_eq (X ⊞ Y) + (congrArg (tensorPow A (X ⊞ Y)) hpm) + (congrArg (tensorPow A (X ⊞ Y)) hq1) + have h1 : mixedInto X Y (n + 1) w ≫ + permMor (X ⊞ Y) (n + 1) (sortPerm w) + = (eqToHom hobj ≫ + (mixedInto X Y n (w ∘ Fin.castSucc) ⊗ₘ + (biprod.inr : Y ⟶ X ⊞ Y))) ≫ + (permMor (X ⊞ Y) n (sortPerm (w ∘ Fin.castSucc)) ▷ + (X ⊞ Y)) := by + rw [hsplit, hperm] + exact rfl + have h2 : (eqToHom hobj ≫ + (mixedInto X Y n (w ∘ Fin.castSucc) ⊗ₘ + (biprod.inr : Y ⟶ X ⊞ Y))) ≫ + (permMor (X ⊞ Y) n (sortPerm (w ∘ Fin.castSucc)) ▷ + (X ⊞ Y)) + = eqToHom hobj ≫ + ((mixedInto X Y n (w ∘ Fin.castSucc) ⊗ₘ + (biprod.inr : Y ⟶ X ⊞ Y)) ≫ + (permMor (X ⊞ Y) n (sortPerm (w ∘ Fin.castSucc)) ▷ + (X ⊞ Y))) := Category.assoc _ _ _ + have h3 : eqToHom hobj ≫ + ((mixedInto X Y n (w ∘ Fin.castSucc) ⊗ₘ + (biprod.inr : Y ⟶ X ⊞ Y)) ≫ + (permMor (X ⊞ Y) n (sortPerm (w ∘ Fin.castSucc)) ▷ + (X ⊞ Y))) + = eqToHom hobj ≫ + ((mixedInto X Y n (w ∘ Fin.castSucc) ≫ + permMor (X ⊞ Y) n (sortPerm (w ∘ Fin.castSucc))) ⊗ₘ + (biprod.inr : Y ⟶ X ⊞ Y)) := + congrArg (fun t => eqToHom hobj ≫ t) + (tensor_then_whiskerRight _ _ _) + have h4 : eqToHom hobj ≫ + ((mixedInto X Y n (w ∘ Fin.castSucc) ≫ + permMor (X ⊞ Y) n (sortPerm (w ∘ Fin.castSucc))) ⊗ₘ + (biprod.inr : Y ⟶ X ⊞ Y)) + = eqToHom hobj ≫ + ((e'.hom ≫ + (tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) p ⊗ₘ + tensorPowMap (biprod.inr : Y ⟶ X ⊞ Y) m) ≫ + (tensorPowConcat (X ⊞ Y) p m).hom ≫ + eqToHom (congrArg (tensorPow A (X ⊞ Y)) hpm)) ⊗ₘ + (biprod.inr : Y ⟶ X ⊞ Y)) := by rw [hsq'] + have h5 : eqToHom hobj ≫ + ((e'.hom ≫ + (tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) p ⊗ₘ + tensorPowMap (biprod.inr : Y ⟶ X ⊞ Y) m) ≫ + (tensorPowConcat (X ⊞ Y) p m).hom ≫ + eqToHom (congrArg (tensorPow A (X ⊞ Y)) hpm)) ⊗ₘ + (biprod.inr : Y ⟶ X ⊞ Y)) + = eqToHom hobj ≫ + ((e'.hom ▷ Y) ≫ + (α_ (tensorPow A X p) (tensorPow A Y m) Y).hom ≫ + (tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) p ⊗ₘ + (tensorPowMap (biprod.inr : Y ⟶ X ⊞ Y) m ⊗ₘ + (biprod.inr : Y ⟶ X ⊞ Y))) ≫ + (α_ (tensorPow A (X ⊞ Y) p) (tensorPow A (X ⊞ Y) m) + (X ⊞ Y)).inv ≫ + ((tensorPowConcat (X ⊞ Y) p m).hom ▷ (X ⊞ Y)) ≫ + (eqToHom (congrArg (tensorPow A (X ⊞ Y)) hpm) ▷ + (X ⊞ Y))) := + congrArg (fun t => eqToHom hobj ≫ t) + (sorted_false_glue e'.hom _ _ _ _ _) + have h6 : eqToHom hobj ≫ + ((e'.hom ▷ Y) ≫ + (α_ (tensorPow A X p) (tensorPow A Y m) Y).hom ≫ + (tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) p ⊗ₘ + (tensorPowMap (biprod.inr : Y ⟶ X ⊞ Y) m ⊗ₘ + (biprod.inr : Y ⟶ X ⊞ Y))) ≫ + (α_ (tensorPow A (X ⊞ Y) p) (tensorPow A (X ⊞ Y) m) + (X ⊞ Y)).inv ≫ + ((tensorPowConcat (X ⊞ Y) p m).hom ▷ (X ⊞ Y)) ≫ + (eqToHom (congrArg (tensorPow A (X ⊞ Y)) hpm) ▷ + (X ⊞ Y))) + = eqToHom hobj ≫ + ((e'.hom ▷ Y) ≫ + (α_ (tensorPow A X p) (tensorPow A Y m) Y).hom ≫ + (tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) p ⊗ₘ + (tensorPowMap (biprod.inr : Y ⟶ X ⊞ Y) m ⊗ₘ + (biprod.inr : Y ⟶ X ⊞ Y))) ≫ + (α_ (tensorPow A (X ⊞ Y) p) (tensorPow A (X ⊞ Y) m) + (X ⊞ Y)).inv ≫ + ((tensorPowConcat (X ⊞ Y) p m).hom ▷ (X ⊞ Y)) ≫ + eqToHom (congrArg (tensorPow A (X ⊞ Y)) hq1)) := by + rw [hcast] + exact rfl + have h7 : eqToHom hobj ≫ + ((e'.hom ▷ Y) ≫ + (α_ (tensorPow A X p) (tensorPow A Y m) Y).hom ≫ + (tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) p ⊗ₘ + (tensorPowMap (biprod.inr : Y ⟶ X ⊞ Y) m ⊗ₘ + (biprod.inr : Y ⟶ X ⊞ Y))) ≫ + (α_ (tensorPow A (X ⊞ Y) p) (tensorPow A (X ⊞ Y) m) + (X ⊞ Y)).inv ≫ + ((tensorPowConcat (X ⊞ Y) p m).hom ▷ (X ⊞ Y)) ≫ + eqToHom (congrArg (tensorPow A (X ⊞ Y)) hq1)) + = (eqToIso hobj ≪≫ whiskerRightIso e' Y ≪≫ + α_ (tensorPow A X p) (tensorPow A Y m) Y).hom ≫ + (tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) p ⊗ₘ + tensorPowMap (biprod.inr : Y ⟶ X ⊞ Y) (m + 1)) ≫ + (tensorPowConcat (X ⊞ Y) p (m + 1)).hom ≫ + eqToHom (congrArg (tensorPow A (X ⊞ Y)) hq1) := + false_final_shape _ _ _ _ _ _ _ + exact h1.trans (h2.trans (h3.trans (h4.trans (h5.trans + (h6.trans h7))))) + +/-- Regrouping the true-branch chain into the packaged form. +Stated at general objects. -/ +private theorem true_final_shape [Category.{v} A] + {W₀ W₁ P R₀ R₁ R₂ R₃ R₄ R₅ R₆ : A} + (a : W₀ ⟶ W₁) (b : W₁ ⟶ P) (c : P ⟶ R₀) (d : R₀ ⟶ R₁) + (e : R₁ ⟶ R₂) (t : R₂ ⟶ R₃) (cw : R₃ ⟶ R₄) (e₁ : R₄ ⟶ R₅) + (e₂ : R₅ ⟶ R₆) : + a ≫ ((b ≫ (c ≫ d ≫ e ≫ t ≫ cw ≫ e₁)) ≫ e₂) = + (a ≫ b ≫ c ≫ d ≫ e) ≫ t ≫ cw ≫ e₁ ≫ e₂ := by + simp only [Category.assoc] + +/-- **The sorting square grows by a `true` letter**: the appended +`X` is bubbled down past the whole `Y` block onto the top of the +`X` block. -/ +private theorem sorted_step_true + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [HasBinaryBiproducts A] + (X Y : A) {n : ℕ} + (w : Fin (n + 1) → Bool) (p m : ℕ) + (hpm : p + m = n) (hm : n - p = m) + (hq1 : p + 1 + m = n + 1) + (e' : wordPow X Y n (w ∘ Fin.castSucc) ≅ + tensorPow A X p ⊗ tensorPow A Y m) + (hobj : wordPow X Y (n + 1) w = + wordPow X Y n (w ∘ Fin.castSucc) ⊗ X) + (hb : w (Fin.last n) = true) + (hperm : permMor (X ⊞ Y) (n + 1) (sortPerm w) = + (permMor (X ⊞ Y) n (sortPerm (w ∘ Fin.castSucc)) ▷ + (X ⊞ Y)) ≫ insertTop (X ⊞ Y) n (n - p)) + (hsq' : mixedInto X Y n (w ∘ Fin.castSucc) ≫ + permMor (X ⊞ Y) n (sortPerm (w ∘ Fin.castSucc)) = + e'.hom ≫ + (tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) p ⊗ₘ + tensorPowMap (biprod.inr : Y ⟶ X ⊞ Y) m) ≫ + (tensorPowConcat (X ⊞ Y) p m).hom ≫ + eqToHom (congrArg (tensorPow A (X ⊞ Y)) hpm)) : + mixedInto X Y (n + 1) w ≫ + permMor (X ⊞ Y) (n + 1) (sortPerm w) = + (eqToIso hobj ≪≫ whiskerRightIso e' X ≪≫ + α_ (tensorPow A X p) (tensorPow A Y m) X ≪≫ + whiskerLeftIso (tensorPow A X p) + (β_ (tensorPow A Y m) X) ≪≫ + (α_ (tensorPow A X p) X (tensorPow A Y m)).symm).hom ≫ + (tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) (p + 1) ⊗ₘ + tensorPowMap (biprod.inr : Y ⟶ X ⊞ Y) m) ≫ + (tensorPowConcat (X ⊞ Y) (p + 1) m).hom ≫ + eqToHom (congrArg (tensorPow A (X ⊞ Y)) hq1) := by + have hsplit := mixedInto_split_true X Y n w (w ∘ Fin.castSucc) + rfl hb hobj + have hmerge := cast_then_cast_whisker (X ⊞ Y) + (a := p + 1 + m) (b := p + m) (n := n) + (by omega) hpm + (congrArg (tensorPow A (X ⊞ Y)) (Nat.succ_add_eq_add_succ p m)) + (congrArg (tensorPow A (X ⊞ Y)) hpm) + (congrArg (tensorPow A (X ⊞ Y)) hq1) + have h1 : mixedInto X Y (n + 1) w ≫ + permMor (X ⊞ Y) (n + 1) (sortPerm w) + = (eqToHom hobj ≫ + (mixedInto X Y n (w ∘ Fin.castSucc) ⊗ₘ + (biprod.inl : X ⟶ X ⊞ Y))) ≫ + ((permMor (X ⊞ Y) n (sortPerm (w ∘ Fin.castSucc)) ▷ + (X ⊞ Y)) ≫ insertTop (X ⊞ Y) n (n - p)) := by + rw [hsplit, hperm] + exact rfl + refine (h1.trans ?_) + refine (Category.assoc _ _ _).trans ?_ + refine (congrArg (fun t => eqToHom hobj ≫ t) + (Category.assoc _ _ _).symm).trans ?_ + refine (congrArg + (fun t => eqToHom hobj ≫ + (t ≫ insertTop (X ⊞ Y) n (n - p))) + (tensor_then_whiskerRight _ _ _)).trans ?_ + refine (?_ : + eqToHom hobj ≫ + (((mixedInto X Y n (w ∘ Fin.castSucc) ≫ + permMor (X ⊞ Y) n (sortPerm (w ∘ Fin.castSucc))) ⊗ₘ + (biprod.inl : X ⟶ X ⊞ Y)) ≫ + insertTop (X ⊞ Y) n (n - p)) = _) + rw [hsq'] + refine (congrArg + (fun v => eqToHom hobj ≫ + ((v ⊗ₘ (biprod.inl : X ⟶ X ⊞ Y)) ≫ + insertTop (X ⊞ Y) n (n - p))) + (assoc₃ e'.hom _ _ _).symm).trans ?_ + refine (congrArg + (fun t => eqToHom hobj ≫ + (t ≫ insertTop (X ⊞ Y) n (n - p))) + (tensor_split_last _ _ _)).trans ?_ + refine (congrArg (fun t => eqToHom hobj ≫ t) + (Category.assoc _ _ _)).trans ?_ + refine (congrArg + (fun t => eqToHom hobj ≫ + (((e'.hom ≫ + (tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) p ⊗ₘ + tensorPowMap (biprod.inr : Y ⟶ X ⊞ Y) m) ≫ + (tensorPowConcat (X ⊞ Y) p m).hom) ⊗ₘ + (biprod.inl : X ⟶ X ⊞ Y)) ≫ t)) + (insertTop_cast (X ⊞ Y) (p + m) n (n - p) hpm + (congrArg (tensorPow A (X ⊞ Y)) hpm))).trans ?_ + refine (congrArg + (fun k => eqToHom hobj ≫ + (((e'.hom ≫ + (tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) p ⊗ₘ + tensorPowMap (biprod.inr : Y ⟶ X ⊞ Y) m) ≫ + (tensorPowConcat (X ⊞ Y) p m).hom) ⊗ₘ + (biprod.inl : X ⟶ X ⊞ Y)) ≫ + (insertTop (X ⊞ Y) (p + m) k ≫ + (eqToHom (congrArg (tensorPow A (X ⊞ Y)) hpm) ▷ + (X ⊞ Y))))) + hm).trans ?_ + refine (congrArg (fun t => eqToHom hobj ≫ t) + (Category.assoc _ _ _).symm).trans ?_ + refine (congrArg + (fun t => eqToHom hobj ≫ + ((t ≫ insertTop (X ⊞ Y) (p + m) m) ≫ + (eqToHom (congrArg (tensorPow A (X ⊞ Y)) hpm) ▷ + (X ⊞ Y)))) + (tensor_split_first e'.hom _ _)).trans ?_ + refine (congrArg + (fun t => eqToHom hobj ≫ + (t ≫ (eqToHom (congrArg (tensorPow A (X ⊞ Y)) hpm) ▷ + (X ⊞ Y)))) + (Category.assoc _ _ _)).trans ?_ + refine (congrArg + (fun t => eqToHom hobj ≫ + (((e'.hom ▷ X) ≫ t) ≫ + (eqToHom (congrArg (tensorPow A (X ⊞ Y)) hpm) ▷ + (X ⊞ Y)))) + (base_insert_true X Y p m)).trans ?_ + refine (true_final_shape (eqToHom hobj) (e'.hom ▷ X) + (α_ (tensorPow A X p) (tensorPow A Y m) X).hom + (tensorPow A X p ◁ (β_ (tensorPow A Y m) X).hom) + (α_ (tensorPow A X p) X (tensorPow A Y m)).inv + (tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) (p + 1) ⊗ₘ + tensorPowMap (biprod.inr : Y ⟶ X ⊞ Y) m) + (tensorPowConcat (X ⊞ Y) (p + 1) m).hom + (eqToHom (congrArg (tensorPow A (X ⊞ Y)) + (Nat.succ_add_eq_add_succ p m))) + (eqToHom (congrArg (tensorPow A (X ⊞ Y)) hpm) ▷ + (X ⊞ Y))).trans ?_ + exact congrArg + (fun s => (eqToHom hobj ≫ (e'.hom ▷ X) ≫ + (α_ (tensorPow A X p) (tensorPow A Y m) X).hom ≫ + (tensorPow A X p ◁ (β_ (tensorPow A Y m) X).hom) ≫ + (α_ (tensorPow A X p) X (tensorPow A Y m)).inv) ≫ + (tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) (p + 1) ⊗ₘ + tensorPowMap (biprod.inr : Y ⟶ X ⊞ Y) m) ≫ + (tensorPowConcat (X ⊞ Y) (p + 1) m).hom ≫ s) + hmerge + +/-- Append a definitionally trivial transport to a three-step +factorisation. -/ +private theorem comp_cast_end₃ [Category.{v} A] + {P Q R S : A} {f : P ⟶ S} + {g₁ : P ⟶ Q} {g₂ : Q ⟶ R} {g₃ : R ⟶ S} (H : S = S) + (hfg : f = g₁ ≫ g₂ ≫ g₃) : + f = g₁ ≫ g₂ ≫ g₃ ≫ eqToHom H := by + erw [show H = rfl from rfl, eqToHom_refl, Category.comp_id, hfg] + +/-- Renaming the block sizes of a sorting square: the data and the +square transport along equalities of the two sizes. -/ +private theorem sorted_pack + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + (X Y : A) {n : ℕ} {W : A} + (mi : W ⟶ tensorPow A (X ⊞ Y) n) (p q pc qc : ℕ) + (hp : p = pc) (hq : q = qc) (hpq : p + q = n) + (hpcqc : pc + qc = n) + (e : W ≅ tensorPow A X p ⊗ tensorPow A Y q) + (hsq : mi = e.hom ≫ + (tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) p ⊗ₘ + tensorPowMap (biprod.inr : Y ⟶ X ⊞ Y) q) ≫ + (tensorPowConcat (X ⊞ Y) p q).hom ≫ + eqToHom (congrArg (tensorPow A (X ⊞ Y)) hpq)) : + ∃ e' : W ≅ tensorPow A X pc ⊗ tensorPow A Y qc, + mi = e'.hom ≫ + (tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) pc ⊗ₘ + tensorPowMap (biprod.inr : Y ⟶ X ⊞ Y) qc) ≫ + (tensorPowConcat (X ⊞ Y) pc qc).hom ≫ + eqToHom (congrArg (tensorPow A (X ⊞ Y)) hpcqc) := by + subst hp + subst hq + exact ⟨e, hsq⟩ + +/-- **The sorting lemma**: every mixed inclusion is a permuted +base-point inclusion. For each word `w` there is an isomorphism of +the word power with `X ^ ⊗ popCount w ⊗ Y ^ ⊗ (n − popCount w)` +under which `mixedInto`, followed by the action of `sortPerm w`, is +the concatenation of the two pure-power inclusions, transported +along `popCount w + (n − popCount w) = n` at the target. -/ +theorem mixedInto_sorted + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [HasBinaryBiproducts A] + (X Y : A) : + ∀ (n : ℕ) (w : Fin n → Bool), + ∃ e : wordPow X Y n w ≅ + tensorPow A X (popCount w) ⊗ + tensorPow A Y (n - popCount w), + mixedInto X Y n w ≫ permMor (X ⊞ Y) n (sortPerm w) = + e.hom ≫ + (tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) (popCount w) ⊗ₘ + tensorPowMap (biprod.inr : Y ⟶ X ⊞ Y) + (n - popCount w)) ≫ + (tensorPowConcat (X ⊞ Y) (popCount w) + (n - popCount w)).hom ≫ + eqToHom (congrArg (tensorPow A (X ⊞ Y)) + (Nat.add_sub_cancel' (popCount_le w))) := by + intro n + induction n with + | zero => + intro w + refine sorted_pack X Y + (mixedInto X Y 0 w ≫ permMor (X ⊞ Y) 0 (sortPerm w)) + 0 0 (popCount w) (0 - popCount w) (popCount_nil w).symm + (by rw [popCount_nil]) rfl + (Nat.add_sub_cancel' (popCount_le w)) + (ρ_ (𝟙_ A)).symm ?_ + have hz : (𝟙 (𝟙_ A) ≫ 𝟙 (𝟙_ A) : 𝟙_ A ⟶ 𝟙_ A) = + (ρ_ (𝟙_ A)).inv ≫ (𝟙 (𝟙_ A) ⊗ₘ 𝟙 (𝟙_ A)) ≫ + (ρ_ (𝟙_ A)).hom := by + rw [MonoidalCategory.id_tensorHom_id, Category.id_comp, + Category.id_comp, Iso.inv_hom_id] + refine comp_cast_end₃ _ ?_ + exact hz + | succ n ih => + intro w + obtain ⟨e', hsq'⟩ := ih (w ∘ Fin.castSucc) + have hple := popCount_le (w ∘ Fin.castSucc) + cases hb : w (Fin.last n) with + | false => + have hpw : popCount w = popCount (w ∘ Fin.castSucc) := by + rw [popCount_succ, hb] + rfl + have hobj : wordPow X Y (n + 1) w = + wordPow X Y n (w ∘ Fin.castSucc) ⊗ Y := by + rw [wordPow_succ, hb] + rfl + have hperm : permMor (X ⊞ Y) (n + 1) (sortPerm w) = + permMor (X ⊞ Y) n (sortPerm (w ∘ Fin.castSucc)) ▷ + (X ⊞ Y) := by + rw [sortPerm_succ, hb, Bool.cond_false, permMor_ofSplit, + show ((Fin.last n : Fin (n + 1)) : ℕ) = n from rfl, + Nat.sub_self, insertTop_zero] + exact Category.comp_id _ + have hq1 : popCount (w ∘ Fin.castSucc) + + (n - popCount (w ∘ Fin.castSucc) + 1) = n + 1 := by + omega + refine sorted_pack X Y + (mixedInto X Y (n + 1) w ≫ + permMor (X ⊞ Y) (n + 1) (sortPerm w)) + (popCount (w ∘ Fin.castSucc)) + (n - popCount (w ∘ Fin.castSucc) + 1) + (popCount w) (n + 1 - popCount w) hpw.symm (by omega) hq1 + (Nat.add_sub_cancel' (popCount_le w)) _ + (sorted_step_false X Y w (popCount (w ∘ Fin.castSucc)) + (n - popCount (w ∘ Fin.castSucc)) + (Nat.add_sub_cancel' hple) hq1 e' hobj hb hperm hsq') + | true => + have hpw : popCount w = popCount (w ∘ Fin.castSucc) + 1 := by + rw [popCount_succ, hb] + rfl + have hobj : wordPow X Y (n + 1) w = + wordPow X Y n (w ∘ Fin.castSucc) ⊗ X := by + rw [wordPow_succ, hb] + rfl + have hperm : permMor (X ⊞ Y) (n + 1) (sortPerm w) = + (permMor (X ⊞ Y) n (sortPerm (w ∘ Fin.castSucc)) ▷ + (X ⊞ Y)) ≫ + insertTop (X ⊞ Y) n + (n - popCount (w ∘ Fin.castSucc)) := by + rw [sortPerm_succ, hb, Bool.cond_true, permMor_ofSplit] + have hq1 : popCount (w ∘ Fin.castSucc) + 1 + + (n - popCount (w ∘ Fin.castSucc)) = n + 1 := by + omega + refine sorted_pack X Y + (mixedInto X Y (n + 1) w ≫ + permMor (X ⊞ Y) (n + 1) (sortPerm w)) + (popCount (w ∘ Fin.castSucc) + 1) + (n - popCount (w ∘ Fin.castSucc)) + (popCount w) (n + 1 - popCount w) hpw.symm (by omega) hq1 + (Nat.add_sub_cancel' (popCount_le w)) _ + (sorted_step_true X Y w (popCount (w ∘ Fin.castSucc)) + (n - popCount (w ∘ Fin.castSucc)) + (Nat.add_sub_cancel' hple) rfl hq1 e' hobj hb hperm hsq') + +/-- **The sorting isomorphism**, chosen once and for all from the +sorting lemma: `wordPow X Y n w` against the sorted concatenation +of pure powers. -/ +noncomputable def sortIso + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [HasBinaryBiproducts A] + (X Y : A) (n : ℕ) (w : Fin n → Bool) : + wordPow X Y n w ≅ + tensorPow A X (popCount w) ⊗ tensorPow A Y (n - popCount w) := + (mixedInto_sorted X Y n w).choose + +/-- The sorting square, for the chosen isomorphism `sortIso`. -/ +theorem sortIso_spec [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [HasBinaryBiproducts A] + (X Y : A) (n : ℕ) (w : Fin n → Bool) : + mixedInto X Y n w ≫ permMor (X ⊞ Y) n (sortPerm w) = + (sortIso X Y n w).hom ≫ + (tensorPowMap (biprod.inl : X ⟶ X ⊞ Y) (popCount w) ⊗ₘ + tensorPowMap (biprod.inr : Y ⟶ X ⊞ Y) + (n - popCount w)) ≫ + (tensorPowConcat (X ⊞ Y) (popCount w) + (n - popCount w)).hom ≫ + eqToHom (congrArg (tensorPow A (X ⊞ Y)) + (Nat.add_sub_cancel' (popCount_le w))) := + (mixedInto_sorted X Y n w).choose_spec + +end SortedBiprod + +end Symmetric + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodTransfer.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodTransfer.lean new file mode 100644 index 0000000000..b41f9827f4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodTransfer.lean @@ -0,0 +1,348 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndKill +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.HookMult + +/-! +# The direct-sum transfer of Schur vanishing + +Deligne 1.13, first half: if a Schur functor kills `X` and one +kills `Y`, a fat-hook Schur functor kills `X ⊞ Y`. The identity +of `(X ⊞ Y)^⊗n` expands over mixed words; each mixed inclusion +sorts to the standard block inclusion; the central idempotent of +`λ` then meets the complete family of embedded block idempotents, +where every term dies — by the induction kill when the multiplicity +vanishes, and through the killed factor and naturality when it does +not, since a nonzero multiplicity pushes a bounding-box cell into +`μ'` or `ν'` (Deligne 1.10). +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits Finset + +universe v u + +variable {A : Type u} + +/-- Transport of the group-algebra action along an arity +equality. -/ +theorem permAlg_eqToHom + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] + (Z : A) {m n : ℕ} (h : m = n) + (x : SymGroupAlgebra n) : + eqToHom (congrArg (tensorPow A Z) h) ≫ permAlg Z n x = + permAlg Z m (symCast (le_of_eq h.symm) x) ≫ + eqToHom (congrArg (tensorPow A Z) h) := by + subst h + rw [symCast_le_refl] + simp + +/-- The embedded block idempotents are a complete family. -/ +theorem sum_blockAlgEmbed_shape_e (P : SchurPackage.{v}) + (a b : ℕ) : + ∑ μ' : Shape a, ∑ ν' : Shape b, + blockAlgEmbed (Shape.e P μ') (Shape.e P ν') = + (1 : SymGroupAlgebra (a + b)) := by + classical + calc ∑ μ' : Shape a, ∑ ν' : Shape b, + blockAlgEmbed (Shape.e P μ') (Shape.e P ν') + = (MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedFstHom a b) + (∑ μ' : Shape a, Shape.e P μ')) * + (MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedSndHom a b) + (∑ ν' : Shape b, Shape.e P ν')) := by + rw [map_sum, map_sum, Finset.sum_mul_sum] + exact Finset.sum_congr rfl fun μ' _ => + Finset.sum_congr rfl fun ν' _ => rfl + _ = 1 := by + rw [P.sum_shape_e_eq_one, P.sum_shape_e_eq_one, + map_one, map_one, one_mul] + +/-- A diagram inside the `(p+1) × (q+1)` bounding box is contained +in any diagram holding the cell `(p, q)`. -/ +theorem le_of_box_of_cell {μ μ' : YoungDiagram} {p q : ℕ} + (hc : μ.colLen 0 ≤ p + 1) (hr : μ.rowLen 0 ≤ q + 1) + (hcell : (p, q) ∈ μ') : μ ≤ μ' := by + intro c hcmem + obtain ⟨i, j⟩ := c + have hi : i < μ.colLen 0 := by + rw [← YoungDiagram.mem_iff_lt_colLen] + exact μ.up_left_mem le_rfl (Nat.zero_le _) hcmem + have hj : j < μ.rowLen 0 := by + rw [← YoungDiagram.mem_iff_lt_rowLen] + exact μ.up_left_mem (Nat.zero_le _) le_rfl hcmem + exact μ'.up_left_mem (by omega) (by omega) hcell + +/-- A central element commutes with every permutation action. -/ +theorem permMor_comp_permAlg + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] + (Z : A) {n : ℕ} + (g : Equiv.Perm (Fin n)) {x : SymGroupAlgebra n} + (hcen : ∀ y, x * y = y * x) : + permMor Z n g ≫ permAlg Z n x = + permAlg Z n x ≫ permMor Z n g := by + have h1 : permMor Z n g ≫ permAlg Z n x = + permAlg Z n (x * MonoidAlgebra.single g 1) := by + rw [map_mul, permAlg_single] + rfl + have h2 : permAlg Z n x ≫ permMor Z n g = + permAlg Z n (MonoidAlgebra.single g 1 * x) := by + rw [map_mul, permAlg_single] + rfl + rw [h1, h2, hcen] + +/-- The permutation action followed by its inverse is the identity. -/ +theorem permMor_comp_inverse + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] + (Z : A) (n : ℕ) (g : Equiv.Perm (Fin n)) : + permMor Z n g ≫ permMor Z n g⁻¹ = 𝟙 _ := by + rw [show permMor Z n g ≫ + permMor Z n g⁻¹ = + permAlg Z n (MonoidAlgebra.single (g⁻¹ * + g) 1) from by + rw [show MonoidAlgebra.single (g⁻¹ * + g) (1 : ℂ) = + MonoidAlgebra.single g⁻¹ 1 * + MonoidAlgebra.single g 1 from by + rw [MonoidAlgebra.single_mul_single, one_mul], + map_mul, permAlg_single, permAlg_single] + rfl] + rw [inv_mul_cancel] + rw [show MonoidAlgebra.single (1 : Equiv.Perm (Fin n)) + (1 : ℂ) = 1 from rfl, map_one] + rfl + +/-- **The direct-sum transfer** (Deligne 1.13, ⊕ half): Schur +vanishing for `X` at `μ` and `Y` at `ν` forces Schur vanishing for +`X ⊞ Y` at every diagram containing the fat-hook cell of the two +bounding boxes. -/ +theorem SchurKilled.biprod + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] [HasBinaryBiproducts A] + (P : SchurPackage.{v}) {X Y : A} + {μ ν lam : YoungDiagram} {p q r s : ℕ} + (hμc : μ.colLen 0 ≤ p + 1) (hμr : μ.rowLen 0 ≤ q + 1) + (hνc : ν.colLen 0 ≤ r + 1) (hνr : ν.rowLen 0 ≤ s + 1) + (hX : SchurKilled P X μ) (hY : SchurKilled P Y ν) + (hcell : (p + r, q + s) ∈ lam) : + SchurKilled P (X ⊞ Y) lam := by + classical + rw [SchurKilled] + set n := lam.card with hn + -- Expand the identity over mixed words. + have hexp : permAlg (X ⊞ Y) n (P.e lam) = + ∑ w : Fin n → Bool, mixedFrom X Y n w ≫ + (mixedInto X Y n w ≫ permAlg (X ⊞ Y) n (P.e lam)) := by + conv_lhs => rw [show permAlg (X ⊞ Y) n (P.e lam) = + 𝟙 (tensorPow A (X ⊞ Y) n) ≫ permAlg (X ⊞ Y) n (P.e lam) from + (Category.id_comp _).symm] + rw [← sum_mixedFrom_mixedInto, Preadditive.sum_comp] + exact Finset.sum_congr rfl fun w _ => Category.assoc _ _ _ + rw [hexp] + refine Finset.sum_eq_zero fun w _ => ?_ + suffices hzero : mixedInto X Y n w ≫ + permAlg (X ⊞ Y) n (P.e lam) = 0 by + rw [hzero] + exact Limits.comp_zero + -- Sort the inclusion to the standard block. + set a := popCount w with ha + set b := n - popCount w with hb + have hab : a + b = n := Nat.add_sub_cancel' (popCount_le w) + have hsorted := sortIso_spec X Y n w + -- `mixedInto ≫ permMor (sortPerm w)` is the standard inclusion. + -- Post-compose the goal with the invertible sorting action. + have hperm := permMor_comp_inverse (X ⊞ Y) n (sortPerm w) + have hcen : ∀ y, P.e lam * y = y * P.e lam := fun y => by + have := shape_e_central P (⟨lam, rfl⟩ : Shape lam.card) y + rwa [show Shape.e P (⟨lam, rfl⟩ : Shape lam.card) = + P.e lam from by + unfold Shape.e + erw [symCast_le_refl]] at this + have hfactor : mixedInto X Y n w ≫ permAlg (X ⊞ Y) n (P.e lam) = + (sortIso X Y n w).hom ≫ + ((tensorPowMap biprod.inl a ⊗ₘ tensorPowMap biprod.inr b) ≫ + (tensorPowConcat (X ⊞ Y) a b).hom ≫ + eqToHom (congrArg (tensorPow A (X ⊞ Y)) hab) ≫ + permAlg (X ⊞ Y) n (P.e lam)) ≫ + permMor (X ⊞ Y) n (sortPerm w)⁻¹ := by + have h1 : mixedInto X Y n w = + ((sortIso X Y n w).hom ≫ + ((tensorPowMap biprod.inl a ⊗ₘ + tensorPowMap biprod.inr b) ≫ + (tensorPowConcat (X ⊞ Y) a b).hom ≫ + eqToHom (congrArg (tensorPow A (X ⊞ Y)) hab))) ≫ + permMor (X ⊞ Y) n (sortPerm w)⁻¹ := by + rw [← hsorted] + rw [Category.assoc, hperm, Category.comp_id] + rw [h1] + rw [Category.assoc] + rw [show permMor (X ⊞ Y) n (sortPerm w)⁻¹ ≫ + permAlg (X ⊞ Y) n (P.e lam) = + permAlg (X ⊞ Y) n (P.e lam) ≫ permMor (X ⊞ Y) n (sortPerm w)⁻¹ from + permMor_comp_permAlg (X ⊞ Y) _ hcen] + simp only [Category.assoc] + rw [hfactor] + suffices hcore : + (tensorPowMap biprod.inl a ⊗ₘ tensorPowMap biprod.inr b) ≫ + (tensorPowConcat (X ⊞ Y) a b).hom ≫ + eqToHom (congrArg (tensorPow A (X ⊞ Y)) hab) ≫ + permAlg (X ⊞ Y) n (P.e lam) = 0 by + rw [show (tensorPowMap biprod.inl a ⊗ₘ + tensorPowMap biprod.inr b) ≫ + (tensorPowConcat (X ⊞ Y) a b).hom ≫ + eqToHom (congrArg (tensorPow A (X ⊞ Y)) hab) ≫ + permAlg (X ⊞ Y) n (P.e lam) = 0 from hcore] + rw [Limits.zero_comp, Limits.comp_zero] + -- Transport the idempotent to the split arity. + rw [permAlg_eqToHom (X ⊞ Y) hab] + set eS : SymGroupAlgebra (a + b) := + symCast (le_of_eq hab.symm) (P.e lam) with heS + have heSshape : eS = Shape.e P (⟨lam, hab.symm⟩ : + Shape (a + b)) := rfl + -- Each embedded block term dies. + have hterm : ∀ (μ' : Shape a) (ν' : Shape b), + (tensorPowMap biprod.inl a ⊗ₘ tensorPowMap biprod.inr b) ≫ + (tensorPowConcat (X ⊞ Y) a b).hom ≫ + permAlg (X ⊞ Y) (a + b) + (eS * blockAlgEmbed (Shape.e P μ') (Shape.e P ν')) = + 0 := by + intro μ' ν' + by_cases hind : indMult (⟨lam, hab.symm⟩ : Shape (a + b)) + μ' ν' = 0 + · -- The induction kill. + have hz0 : permAlg (X ⊞ Y) (a + b) + (eS * blockAlgEmbed (Shape.e P μ') (Shape.e P ν')) = + (0 : tensorPow A (X ⊞ Y) (a + b) ⟶ + tensorPow A (X ⊞ Y) (a + b)) := by + rw [show eS * blockAlgEmbed (Shape.e P μ') (Shape.e P ν') = + 0 from by + rw [heSshape] + exact shape_e_mul_blockAlgEmbed_eq_zero P _ μ' ν' hind] + exact map_zero _ + rw [hz0, Limits.comp_zero, Limits.comp_zero] + · -- A bounding-box cell lands in `μ'` or `ν'`; that factor + -- is killed and naturality propagates the zero. + have hcell' := cell_of_indMult_ne_zero + (⟨lam, hab.symm⟩ : Shape (a + b)) μ' ν' + (p := p) (q := q) (r := r) (s := s) hind hcell + have hsplit : permAlg (X ⊞ Y) (a + b) + (eS * blockAlgEmbed (Shape.e P μ') (Shape.e P ν')) = + permAlg (X ⊞ Y) (a + b) + (blockAlgEmbed (Shape.e P μ') (Shape.e P ν')) ≫ + permAlg (X ⊞ Y) (a + b) eS := by + rw [map_mul] + rfl + rw [hsplit] + rw [show (tensorPowConcat (X ⊞ Y) a b).hom ≫ + permAlg (X ⊞ Y) (a + b) + (blockAlgEmbed (Shape.e P μ') (Shape.e P ν')) ≫ + permAlg (X ⊞ Y) (a + b) eS = + ((permAlg (X ⊞ Y) a (Shape.e P μ') ⊗ₘ + permAlg (X ⊞ Y) b (Shape.e P ν')) ≫ + (tensorPowConcat (X ⊞ Y) a b).hom) ≫ + permAlg (X ⊞ Y) (a + b) eS from by + rw [← Category.assoc, tensorPowConcat_permAlg]] + rw [show (tensorPowMap biprod.inl a ⊗ₘ + tensorPowMap biprod.inr b) ≫ + ((permAlg (X ⊞ Y) a (Shape.e P μ') ⊗ₘ + permAlg (X ⊞ Y) b (Shape.e P ν')) ≫ + (tensorPowConcat (X ⊞ Y) a b).hom) ≫ + permAlg (X ⊞ Y) (a + b) eS = + ((tensorPowMap biprod.inl a ≫ permAlg (X ⊞ Y) a (Shape.e P μ')) ⊗ₘ + (tensorPowMap biprod.inr b ≫ + permAlg (X ⊞ Y) b (Shape.e P ν'))) ≫ + (tensorPowConcat (X ⊞ Y) a b).hom ≫ + permAlg (X ⊞ Y) (a + b) eS from by + rw [← Category.assoc, ← Category.assoc, + tensorHom_comp_tensorHom] + simp only [Category.assoc]] + rcases hcell' with hcμ | hcν + · have hkilled : SchurKilled P X μ'.val := + hX.mono P (le_of_box_of_cell hμc hμr hcμ) + have hz : permAlg X a (Shape.e P μ') = + (0 : tensorPow A X a ⟶ tensorPow A X a) := by + rw [Shape.e] + exact permAlg_compat X _ _ hkilled + rw [show tensorPowMap biprod.inl a ≫ + permAlg (X ⊞ Y) a (Shape.e P μ') = + permAlg X a (Shape.e P μ') ≫ + tensorPowMap biprod.inl a from + (permAlg_natural biprod.inl a _).symm, hz, + Limits.zero_comp] + rw [show ((0 : tensorPow A X a ⟶ tensorPow A (X ⊞ Y) a) ⊗ₘ + (tensorPowMap biprod.inr b ≫ + permAlg (X ⊞ Y) b (Shape.e P ν'))) = + 0 from by + rw [tensorHom_def, MonoidalPreadditive.zero_whiskerRight, + Limits.zero_comp]] + rw [Limits.zero_comp] + · have hkilled : SchurKilled P Y ν'.val := + hY.mono P (le_of_box_of_cell hνc hνr hcν) + have hz : permAlg Y b (Shape.e P ν') = + (0 : tensorPow A Y b ⟶ tensorPow A Y b) := by + rw [Shape.e] + exact permAlg_compat Y _ _ hkilled + rw [show tensorPowMap biprod.inr b ≫ + permAlg (X ⊞ Y) b (Shape.e P ν') = + permAlg Y b (Shape.e P ν') ≫ + tensorPowMap biprod.inr b from + (permAlg_natural biprod.inr b _).symm, hz, + Limits.zero_comp] + rw [show ((tensorPowMap biprod.inl a ≫ + permAlg (X ⊞ Y) a (Shape.e P μ')) ⊗ₘ + (0 : tensorPow A Y b ⟶ tensorPow A (X ⊞ Y) b)) = + 0 from by + rw [tensorHom_def, MonoidalPreadditive.whiskerLeft_zero, + Limits.comp_zero]] + rw [Limits.zero_comp] + -- Assemble: the complete family expands the idempotent. + have hone : eS = ∑ μ' : Shape a, ∑ ν' : Shape b, + eS * blockAlgEmbed (Shape.e P μ') (Shape.e P ν') := by + conv_lhs => rw [show eS = eS * 1 from (mul_one eS).symm, + ← sum_blockAlgEmbed_shape_e P a b] + rw [Finset.mul_sum] + exact Finset.sum_congr rfl fun μ' _ => Finset.mul_sum _ _ _ + set F : Shape a → Shape b → + (tensorPow A (X ⊞ Y) (a + b) ⟶ + tensorPow A (X ⊞ Y) (a + b)) := + fun μ' ν' => permAlg (X ⊞ Y) (a + b) + (eS * blockAlgEmbed (Shape.e P μ') (Shape.e P ν')) with hF + have hdist : (permAlg (X ⊞ Y) (a + b) eS : + tensorPow A (X ⊞ Y) (a + b) ⟶ + tensorPow A (X ⊞ Y) (a + b)) = + ∑ μ' : Shape a, ∑ ν' : Shape b, F μ' ν' := by + conv_lhs => rw [hone] + rw [map_sum] + exact Finset.sum_congr rfl fun μ' _ => map_sum _ _ _ + rw [hdist] + simp only [Preadditive.sum_comp, Preadditive.comp_sum] + refine Finset.sum_eq_zero fun μ' _ => ?_ + refine Finset.sum_eq_zero fun ν' _ => ?_ + calc (tensorPowMap biprod.inl a ⊗ₘ tensorPowMap biprod.inr b) ≫ + (tensorPowConcat (X ⊞ Y) a b).hom ≫ F μ' ν' ≫ + eqToHom (congrArg (tensorPow A (X ⊞ Y)) hab) + = ((tensorPowMap biprod.inl a ⊗ₘ tensorPowMap biprod.inr b) ≫ + (tensorPowConcat (X ⊞ Y) a b).hom ≫ + permAlg (X ⊞ Y) (a + b) + (eS * blockAlgEmbed (Shape.e P μ') (Shape.e P ν'))) ≫ + eqToHom (congrArg (tensorPow A (X ⊞ Y)) hab) := by + simp only [Category.assoc] + rfl + _ = 0 ≫ eqToHom (congrArg (tensorPow A (X ⊞ Y)) hab) := by + rw [hterm μ' ν'] + _ = 0 := Limits.zero_comp + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BlockUnits.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BlockUnits.lean new file mode 100644 index 0000000000..f3558f5f6d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BlockUnits.lean @@ -0,0 +1,352 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeFaithful +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage + +/-! +# Matrix units inside a block + +Inside each block of the symmetric-group algebra the central +idempotent `P.e μ` of a `SchurPackage` splits as a sum of `P.dim μ` +orthogonal nonzero idempotents (`SchurPackage.exists_block_units`). + +The route is through a simple submodule of the regular module lying +inside the block, which exists because the group algebra is +semisimple and the idempotent is nonzero +(`exists_simple_of_central_idem`). The native action on such a +carrier sends the idempotent to the identity, is surjective onto +the endomorphisms of the carrier (`nPsi_surjective`, from +`mPsiLin_surjective`), and is injective on the block +(`block_faithful`); comparing dimensions against `block_rank` +identifies the dimension of the carrier with `P.dim μ`, and the +rank-one projections attached to a basis of the carrier +(`basisProj`) pull back to the required family of units. +-/ + +@[expose] public section + +namespace RS + +open Module + +universe u + +/-- The rank-one idempotent attached to a basis vector: the +projection onto the `i`-th coordinate line of the basis `b`. -/ +noncomputable def basisProj {V : Type*} [AddCommGroup V] + [Module ℂ V] {d : ℕ} (b : Basis (Fin d) ℂ V) (i : Fin d) : + Module.End ℂ V := + (b.coord i).smulRight (b i) + +variable {V : Type*} + +/-- The projection scales the `i`-th coordinate back onto the +`i`-th basis vector. -/ +theorem basisProj_apply [AddCommGroup V] [Module ℂ V] {d : ℕ} + (b : Basis (Fin d) ℂ V) (i : Fin d) + (m : V) : basisProj b i m = b.repr m i • b i := by + unfold basisProj + rw [LinearMap.smulRight_apply, Basis.coord_apply] + +/-- Each basis projection is idempotent. -/ +theorem basisProj_mul_self [AddCommGroup V] [Module ℂ V] {d : ℕ} + (b : Basis (Fin d) ℂ V) (i : Fin d) : + basisProj b i * basisProj b i = basisProj b i := by + apply LinearMap.ext + intro m + simp only [Module.End.mul_apply, basisProj_apply, map_smul, + Basis.repr_self, Finsupp.single_eq_same, one_smul] + +/-- Distinct basis projections are orthogonal. -/ +theorem basisProj_mul_ne [AddCommGroup V] [Module ℂ V] {d : ℕ} + (b : Basis (Fin d) ℂ V) {i j : Fin d} + (hij : i ≠ j) : basisProj b i * basisProj b j = 0 := by + apply LinearMap.ext + intro m + simp only [Module.End.mul_apply, basisProj_apply, map_smul, + Basis.repr_self, LinearMap.zero_apply] + rw [Finsupp.single_eq_of_ne hij, zero_smul, smul_zero] + +/-- The basis projections sum to the identity. -/ +theorem sum_basisProj [AddCommGroup V] [Module ℂ V] {d : ℕ} + (b : Basis (Fin d) ℂ V) : + ∑ i, basisProj b i = 1 := by + apply LinearMap.ext + intro m + simp only [LinearMap.sum_apply, basisProj_apply, + Module.End.one_apply] + exact b.sum_repr m + +/-- Each basis projection is nonzero. -/ +theorem basisProj_ne_zero [AddCommGroup V] [Module ℂ V] {d : ℕ} + (b : Basis (Fin d) ℂ V) (i : Fin d) : + basisProj b i ≠ 0 := by + intro h0 + have h1 := LinearMap.congr_fun h0 (b i) + rw [basisProj_apply, Basis.repr_self, Finsupp.single_eq_same, + one_smul, LinearMap.zero_apply] at h1 + exact b.ne_zero i h1 + +/-- Every nonzero central idempotent of a complex group algebra +has a simple submodule of the regular module inside its block: a +simple submodule on which it multiplies as the identity. -/ +theorem exists_simple_of_central_idem {G : Type*} [Group G] + [Finite G] (e : MonoidAlgebra ℂ G) (hidem : e * e = e) + (hcentral : ∀ x : MonoidAlgebra ℂ G, e * x = x * e) + (hne : e ≠ 0) : + ∃ S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G), + IsSimpleModule (MonoidAlgebra ℂ G) S ∧ + ∀ s ∈ S, e * s = s := by + classical + let := Fintype.ofFinite G + have hex : ∃ T : Submodule (MonoidAlgebra ℂ G) + (MonoidAlgebra ℂ G), + IsSimpleModule (MonoidAlgebra ℂ G) T ∧ + ∃ t ∈ T, e * t ≠ 0 := by + by_contra hno + push Not at hno + exact hne (eq_zero_of_kills_simples e fun T hT t ht => + hno T hT t ht) + obtain ⟨T, hT, t, ht, het⟩ := hex + have := hT + let g : T →ₗ[MonoidAlgebra ℂ G] MonoidAlgebra ℂ G := + { toFun := fun s => e * (s : MonoidAlgebra ℂ G) + map_add' := fun a b => by + rw [Submodule.coe_add, mul_add] + map_smul' := fun a s => by + change e * ((a • s : T) : MonoidAlgebra ℂ G) = + a • (e * (s : MonoidAlgebra ℂ G)) + rw [Submodule.coe_smul, smul_eq_mul, smul_eq_mul, + ← mul_assoc, hcentral a, mul_assoc] } + have hg : ∀ s : T, g s = e * (s : MonoidAlgebra ℂ G) := + fun s => rfl + have hker : LinearMap.ker g = ⊥ := by + rcases hT.eq_bot_or_eq_top (LinearMap.ker g) with hb | htop + · exact hb + · exfalso + apply het + have hmem : (⟨t, ht⟩ : T) ∈ LinearMap.ker g := by + rw [htop] + trivial + have h1 := LinearMap.mem_ker.mp hmem + rw [hg] at h1 + exact h1 + have hinj : Function.Injective g := LinearMap.ker_eq_bot.mp hker + refine ⟨LinearMap.range g, ?_, ?_⟩ + · exact IsSimpleModule.congr (LinearEquiv.ofInjective g hinj).symm + · intro s hs + obtain ⟨w, hw⟩ := LinearMap.mem_range.mp hs + rw [← hw, hg, ← mul_assoc, hidem] + +/-- An element multiplying a submodule of the regular module as +the identity acts as the identity endomorphism of its carrier. -/ +theorem nPsi_eq_one_of_forall_eq {G : Type*} [Group G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (e : MonoidAlgebra ℂ G) (he : ∀ s ∈ S, e * s = s) : + nPsi S e = 1 := by + apply LinearMap.ext + intro m + rw [show (nPsi S e) m = e • m from + rhoS_asAlgebraHom_apply S e m] + apply Subtype.ext + rw [show ((e • m : subCarrier S) : MonoidAlgebra ℂ G) = + e * (m : MonoidAlgebra ℂ G) from rfl] + rw [he _ m.2] + rfl + +/-- The native action of a simple submodule of the regular module +is surjective onto the endomorphisms of its carrier. -/ +theorem nPsi_surjective {G : Type*} [Group G] [Finite G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (hS : IsSimpleModule (MonoidAlgebra ℂ G) S) : + Function.Surjective (nPsi S) := by + classical + let := Fintype.ofFinite G + intro T + obtain ⟨y, hy⟩ := mPsiLin_surjective S hS + ((stdEquiv S).toLinearMap ∘ₗ T ∘ₗ + (stdEquiv S).symm.toLinearMap) + refine ⟨(y : MonoidAlgebra ℂ G), ?_⟩ + apply LinearMap.ext + intro m + have h2 : mPsi S (y : MonoidAlgebra ℂ G) (stdEquiv S m) = + ((stdEquiv S).toLinearMap ∘ₗ T ∘ₗ + (stdEquiv S).symm.toLinearMap) (stdEquiv S m) := + LinearMap.congr_fun hy (stdEquiv S m) + rw [mPsi_apply, (stdEquiv S).symm_apply_apply] at h2 + simp only [LinearMap.comp_apply, LinearEquiv.coe_coe, + LinearEquiv.symm_apply_apply] at h2 + exact (stdEquiv S).injective h2 + +/-- **Block units**: inside each block of the symmetric-group +algebra, the central idempotent `P.e μ` splits as a sum of +`P.dim μ` orthogonal nonzero idempotents of the block. -/ +theorem SchurPackage.exists_block_units (P : SchurPackage.{u}) + (μ : YoungDiagram) : + ∃ u : Fin (P.dim μ) → SymGroupAlgebra μ.card, + (∀ i, u i * u i = u i) ∧ + (∀ i j, i ≠ j → u i * u j = 0) ∧ + (∀ i, P.e μ * u i = u i) ∧ + (∀ i, u i * P.e μ = u i) ∧ + (∑ i, u i = P.e μ) ∧ + (∀ i, u i ≠ 0) := by + classical + have hidem : P.e μ * P.e μ = P.e μ := P.idem μ + have hcentral : ∀ y : SymGroupAlgebra μ.card, + P.e μ * y = y * P.e μ := P.central μ + have hrank : Module.finrank ℂ + (LinearMap.range (LinearMap.mulLeft ℂ (P.e μ))) = + P.dim μ ^ 2 := P.block_rank μ + -- The central idempotent is nonzero, its block having positive + -- dimension. + have hne : P.e μ ≠ 0 := by + intro h0 + rw [h0, LinearMap.mulLeft_zero_eq_zero, LinearMap.range_zero, + finrank_bot] at hrank + exact Nat.pos_iff_ne_zero.mp (pow_pos (P.dim_pos μ) 2) + hrank.symm + -- A simple submodule inside the block. + obtain ⟨S, hS, hSb⟩ := + exists_simple_of_central_idem (P.e μ) hidem hcentral hne + have := hS + have := IsSimpleModule.nontrivial + (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) S + have : Nontrivial (subCarrier S) := + inferInstanceAs (Nontrivial S) + have hone : nPsi S (P.e μ) = 1 := + nPsi_eq_one_of_forall_eq S (P.e μ) hSb + have hone_ne : (1 : Module.End ℂ (subCarrier S)) ≠ 0 := by + intro h1 + obtain ⟨m, hm⟩ := exists_ne (0 : subCarrier S) + apply hm + have h2 := LinearMap.congr_fun h1 m + rwa [Module.End.one_apply, LinearMap.zero_apply] at h2 + -- The kill criterion on the block, through `block_faithful`. + have hkill : ∀ x : SymGroupAlgebra μ.card, + nPsi S (P.e μ * x) = 0 → P.e μ * x = 0 := by + intro x hx0 + have hφ : ((ULift.algEquiv (R := ℂ)).symm.toAlgHom.comp + (nPsi S) : SymGroupAlgebra μ.card →ₐ[ℂ] + ULift.{u} (Module.End ℂ (subCarrier S))) + (P.e μ) ≠ 0 := by + intro hz + apply hone_ne + have h1 : (ULift.algEquiv (R := ℂ)).symm + (nPsi S (P.e μ)) = + (0 : ULift.{u} (Module.End ℂ (subCarrier S))) := hz + rw [hone] at h1 + have h2 := congrArg (ULift.algEquiv (R := ℂ)) h1 + rw [AlgEquiv.apply_symm_apply, map_zero] at h2 + exact h2 + have h0' : ((ULift.algEquiv (R := ℂ)).symm.toAlgHom.comp + (nPsi S) : SymGroupAlgebra μ.card →ₐ[ℂ] + ULift.{u} (Module.End ℂ (subCarrier S))) + (P.e μ * x) = 0 := by + change (ULift.algEquiv (R := ℂ)).symm + (nPsi S (P.e μ * x)) = 0 + rw [hx0, map_zero] + exact P.block_faithful μ + (ULift.{u} (Module.End ℂ (subCarrier S))) + ((ULift.algEquiv (R := ℂ)).symm.toAlgHom.comp (nPsi S)) + hφ x h0' + have hsurj := nPsi_surjective S hS + -- The block maps bijectively onto the endomorphism algebra of + -- the carrier, identifying the carrier dimension with `dim μ`. + let ψ : LinearMap.range (LinearMap.mulLeft ℂ (P.e μ)) →ₗ[ℂ] + Module.End ℂ (subCarrier S) := + (nPsi S).toLinearMap.comp + (LinearMap.range (LinearMap.mulLeft ℂ (P.e μ))).subtype + have hψinj : Function.Injective ψ := by + intro a b hab + have hd : ψ (a - b) = 0 := by + rw [map_sub, hab, sub_self] + obtain ⟨w, hw⟩ := (a - b).2 + have h1 : nPsi S (P.e μ * w) = 0 := by + rw [show P.e μ * w = ((a - b : + LinearMap.range (LinearMap.mulLeft ℂ (P.e μ))) : + SymGroupAlgebra μ.card) from hw] + exact hd + have h2 := hkill w h1 + have h3 : a - b = 0 := by + apply Subtype.ext + rw [← hw] + exact h2 + exact sub_eq_zero.mp h3 + have hψsurj : Function.Surjective ψ := by + intro T + obtain ⟨x, hx⟩ := hsurj T + have hmem : P.e μ * x ∈ + LinearMap.range (LinearMap.mulLeft ℂ (P.e μ)) := + LinearMap.mem_range.mpr ⟨x, rfl⟩ + refine ⟨⟨P.e μ * x, hmem⟩, ?_⟩ + change nPsi S (P.e μ * x) = T + rw [map_mul, hone, one_mul, hx] + have hdim : P.dim μ = nDim S := by + have hfr := LinearEquiv.finrank_eq + (LinearEquiv.ofBijective ψ ⟨hψinj, hψsurj⟩) + rw [hrank] at hfr + have hEnd : Module.finrank ℂ + (Module.End ℂ (subCarrier S)) = nDim S * nDim S := + Module.finrank_linearMap ℂ ℂ (subCarrier S) (subCarrier S) + rw [hEnd, ← pow_two] at hfr + exact Nat.pow_left_injective (by decide) hfr + -- The units: preimages of the basis projections of the carrier. + have hfrk : Module.finrank ℂ (subCarrier S) = P.dim μ := + hdim.symm + let b : Basis (Fin (P.dim μ)) ℂ (subCarrier S) := + Module.finBasisOfFinrankEq ℂ (subCarrier S) hfrk + choose x hx using fun i : Fin (P.dim μ) => + hsurj (basisProj b i) + have hval : ∀ i, nPsi S (P.e μ * x i) = basisProj b i := by + intro i + rw [map_mul, hone, one_mul, hx i] + have hmul_self : ∀ i, + P.e μ * x i * (P.e μ * x i) = P.e μ * x i := by + intro i + have hz : nPsi S + (P.e μ * (x i * (P.e μ * x i) - x i)) = 0 := by + rw [mul_sub, ← mul_assoc, map_sub, map_mul, hval i, + basisProj_mul_self, sub_self] + have h4 := hkill _ hz + rw [mul_sub, ← mul_assoc] at h4 + exact sub_eq_zero.mp h4 + have hmul_ne : ∀ i j, i ≠ j → + P.e μ * x i * (P.e μ * x j) = 0 := by + intro i j hij + have hz : nPsi S + (P.e μ * (x i * (P.e μ * x j))) = 0 := by + rw [← mul_assoc, map_mul, hval i, hval j, + basisProj_mul_ne b hij] + have h4 := hkill _ hz + rw [← mul_assoc] at h4 + exact h4 + have hleft : ∀ i, P.e μ * (P.e μ * x i) = P.e μ * x i := by + intro i + rw [← mul_assoc, hidem] + have hright : ∀ i, P.e μ * x i * P.e μ = P.e μ * x i := by + intro i + rw [← hcentral (P.e μ * x i)] + exact hleft i + have hsum : ∑ i, P.e μ * x i = P.e μ := by + have hz : nPsi S (P.e μ * ((∑ i, x i) - 1)) = 0 := by + rw [mul_sub, mul_one, map_sub, map_mul, hone, one_mul, + map_sum] + simp only [hx] + rw [sum_basisProj b, sub_self] + have h4 := hkill _ hz + rw [mul_sub, mul_one, Finset.mul_sum] at h4 + exact sub_eq_zero.mp h4 + have hnz : ∀ i, P.e μ * x i ≠ 0 := by + intro i h0 + apply basisProj_ne_zero b i + rw [← hval i, h0, map_zero] + exact ⟨fun i => P.e μ * x i, hmul_self, hmul_ne, hleft, + hright, hsum, hnz⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BraidCoherence.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BraidCoherence.lean new file mode 100644 index 0000000000..3d2fb59c4b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BraidCoherence.lean @@ -0,0 +1,69 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid + +/-! +# A braid-coherence identity for the interchange prefix + +Both sides of the identity proved here are words in associators and +braidings realising the same permutation of the four strands +`(P, q₁, R, q₂) ↦ (q₁, q₂, P, R)`: the left-hand side crosses `R` +past the second `Q`-strand and then `P` past both `Q`-strands, while +the right-hand side crosses the first `Q`-strand past `R` (inside +`tensorμ`) and then the block `P ⊗ R` past `Q ⊗ Q`. The surplus +adjacent pair of crossings `β_ Q R ≫ β_ R Q` cancels by the symmetry +axiom, and the residual pure-associator words close by coherence. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +variable {D : Type u} + +/-- Pure braid coherence for the interchange prefix: braiding the +third strand past the fourth, reassociating, and braiding `P` past +the two `Q`-strands as a block agrees with interchanging via +`tensorμ`, braiding the block `P ⊗ R` past `Q ⊗ Q`, and +reassociating. -/ +@[reassoc] +theorem braid_prefix_coherence + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (P Q R : D) : + ((P ⊗ Q) ◁ (β_ R Q).hom) ≫ + (α_ (P ⊗ Q) Q R).inv ≫ + ((α_ P Q Q).hom ▷ R) ≫ + ((β_ P (Q ⊗ Q)).hom ▷ R) = + tensorμ P Q R Q ≫ + (β_ (P ⊗ R) (Q ⊗ Q)).hom ≫ + (α_ (Q ⊗ Q) P R).inv := by + symm + calc + tensorμ P Q R Q ≫ (β_ (P ⊗ R) (Q ⊗ Q)).hom ≫ + (α_ (Q ⊗ Q) P R).inv + = 𝟙 _ ⊗≫ P ◁ (((β_ Q R).hom ≫ (β_ R Q).hom) ▷ Q) ⊗≫ + P ◁ Q ◁ (β_ R Q).hom ⊗≫ + (β_ P (Q ⊗ Q)).hom ▷ R ⊗≫ 𝟙 _ := by + dsimp only [tensorμ] + rw [BraidedCategory.braiding_tensor_left_hom P R (Q ⊗ Q), + BraidedCategory.braiding_tensor_right_hom R Q Q] + monoidal + _ = 𝟙 _ ⊗≫ (P ⊗ Q) ◁ (β_ R Q).hom ⊗≫ + (β_ P (Q ⊗ Q)).hom ▷ R ⊗≫ 𝟙 _ := by + rw [SymmetricCategory.symmetry Q R] + monoidal + _ = ((P ⊗ Q) ◁ (β_ R Q).hom) ≫ (α_ (P ⊗ Q) Q R).inv ≫ + ((α_ P Q Q).hom ▷ R) ≫ ((β_ P (Q ⊗ Q)).hom ▷ R) := by + monoidal + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainAlgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainAlgebra.lean new file mode 100644 index 0000000000..c97cc38830 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainAlgebra.lean @@ -0,0 +1,784 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainUnit + +/-! +# The colimit algebra of the splitting chain + +A chain of objects with one-step transitions has a filtered colimit +over the `v`-small copy of `ℕ`. Given stagewise multiplications +compatible with the transitions, the colimit carries a multiplication; +given a bottom-stage unit with stagewise unit laws, it becomes a +monoid object, commutative when the stagewise multiplication is +commutative up to the index transport. The development is generic +over any monoidal category in which tensoring preserves the chain +colimits — the ind-category of a small monoidal category qualifies by +`RS.tensorLeft_ind_preservesColimitsOfShape` and its right-hand +twin — so the splitting chain of `ChainDelta` can be instantiated +later with `B n := chainStage A M M' n` and `δ n := chainDelta`. + +The multiplication is assembled in two passes of `colimit.desc` +through the preservation isomorphisms, mirroring the merge pattern of +`BigTensor`: first against a fixed stage in the second slot, then over +the second slot. All colimit-level laws are cast-free because the +stage inclusions absorb the index transports. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +/- `open MonObj` would activate the scoped notation `ι` for +`GrpObj.inv`, clashing with the cocone fields; the packaged unit +and multiplication are therefore spelt with explicit projections. -/ + +universe v u + +variable {E : Type u} + +/-- Transport of a chain object along an equality of indices. -/ +def chainCast [Category.{v} E] (B : ℕ → E) + {a b : ℕ} (h : a = b) : B a ⟶ B b := + eqToHom (congrArg B h) + +/-- The trivial index transport is the identity. -/ +@[simp] +theorem chainCast_rfl [Category.{v} E] (B : ℕ → E) + (a : ℕ) : + chainCast B (rfl : a = a) = 𝟙 (B a) := rfl + +/-- Index transports compose. -/ +@[reassoc (attr := simp)] +theorem chainCast_trans [Category.{v} E] (B : ℕ → E) + {a b c : ℕ} (h : a = b) (h' : b = c) : + chainCast B h ≫ chainCast B h' = chainCast B (h.trans h') := by + subst h h' + simp + +/-- The chain diagram over the `v`-small copy of `ℕ`, the shape at +which the receiving category is assumed to have colimits. -/ +noncomputable def chainDiagram + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) : + SmallNat.{v} ⥤ E := + smallNatEquiv.inverse ⋙ chainFunctor B δ + +/-- The colimit object of the chain. -/ +noncomputable def chainColimit + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] : E := + colimit (chainDiagram B δ) + +/-- The stage inclusion into the chain colimit. -/ +noncomputable def chainColimitι + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] + (n : ℕ) : B n ⟶ chainColimit B δ := + colimit.ι (chainDiagram B δ) (smallNatEquiv.functor.obj n) + +/-- The chain morphisms are absorbed by the stage inclusions. -/ +@[reassoc (attr := simp)] +theorem chainMap_chainColimitι + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] + {a b : ℕ} (h : a ≤ b) : + chainMap B δ h ≫ chainColimitι B δ b = chainColimitι B δ a := by + exact colimit.w (chainDiagram B δ) + (smallNatEquiv.functor.map (homOfLE h)) + +/-- The transitions are absorbed by the stage inclusions. -/ +@[reassoc (attr := simp)] +theorem delta_chainColimitι + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] + (n : ℕ) : + δ n ≫ chainColimitι B δ (n + 1) = chainColimitι B δ n := by + have h := chainMap_chainColimitι B δ (Nat.le_succ n) + rwa [chainMap_le_succ] at h + +/-- The index transports are absorbed by the stage inclusions. -/ +@[reassoc (attr := simp)] +theorem chainCast_chainColimitι + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] + {a b : ℕ} (h : a = b) : + chainCast B h ≫ chainColimitι B δ b = chainColimitι B δ a := by + subst h + rw [chainCast_rfl, Category.id_comp] + +/-- Maps out of the chain colimit agree once they agree on all +stages. -/ +theorem chainColimit_hom_ext + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] + {Z : E} {f g : chainColimit B δ ⟶ Z} + (w : ∀ n : ℕ, chainColimitι B δ n ≫ f = + chainColimitι B δ n ≫ g) : f = g := by + apply colimit.hom_ext + intro k + exact w (smallNatEquiv.inverse.obj k) + +/-! ## The colimit multiplication + +Stagewise multiplications compatible with the transitions assemble +into a multiplication on the chain colimit. The two compatibility +squares are taken as hypotheses; only the left one needs an index +transport, since `(i + 1) + 1 + j` is not definitionally +`(i + 1 + j) + 1`. -/ + +/-- Multiplying after a chain morphism in the first slot agrees with +multiplying first, once both land in the colimit. -/ +theorem mul_chainMap_ι_left + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (mu : ∀ i j : ℕ, B i ⊗ B j ⟶ B (i + 1 + j)) + (hδl : ∀ i j, (δ i ▷ B j) ≫ mu (i + 1) j = mu i j ≫ δ (i + 1 + j) ≫ + chainCast B (Nat.add_right_comm (i + 1) j 1)) + {i i' : ℕ} (h : i ≤ i') (j : ℕ) : + (chainMap B δ h ▷ B j) ≫ mu i' j ≫ + chainColimitι B δ (i' + 1 + j) = + mu i j ≫ chainColimitι B δ (i + 1 + j) := by + induction i', h using Nat.le_induction with + | base => + rw [chainMap_self, MonoidalCategory.id_whiskerRight, + Category.id_comp] + | succ i' hii ih => + rw [chainMap_succ_of_le B δ hii, comp_whiskerRight, + Category.assoc, reassoc_of% (hδl i' j), + chainCast_chainColimitι, delta_chainColimitι] + exact ih + +/-- Multiplying after a chain morphism in the second slot agrees with +multiplying first, once both land in the colimit. -/ +theorem mul_chainMap_ι_right + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (mu : ∀ i j : ℕ, B i ⊗ B j ⟶ B (i + 1 + j)) + (hδr : ∀ i j, (B i ◁ δ j) ≫ mu i (j + 1) = mu i j ≫ δ (i + 1 + j)) + (i : ℕ) {j j' : ℕ} (h : j ≤ j') : + (B i ◁ chainMap B δ h) ≫ mu i j' ≫ + chainColimitι B δ (i + 1 + j') = + mu i j ≫ chainColimitι B δ (i + 1 + j) := by + induction j', h using Nat.le_induction with + | base => + rw [chainMap_self, MonoidalCategory.whiskerLeft_id, + Category.id_comp] + | succ j' hjj ih => + rw [chainMap_succ_of_le B δ hjj, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + reassoc_of% (hδr i j')] + have hι : δ (i + 1 + j') ≫ + chainColimitι B δ (i + 1 + (j' + 1)) = + chainColimitι B δ (i + 1 + j') := + delta_chainColimitι B δ (i + 1 + j') + rw [hι] + exact ih + +/-- The multiply-then-include maps against a fixed stage in the +second slot form a cocone on the chain diagram tensored on the right +with that stage. -/ +noncomputable def chainMulCocone + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (mu : ∀ i j : ℕ, B i ⊗ B j ⟶ B (i + 1 + j)) + (hδl : ∀ i j, (δ i ▷ B j) ≫ mu (i + 1) j = mu i j ≫ δ (i + 1 + j) ≫ + chainCast B (Nat.add_right_comm (i + 1) j 1)) + (j : ℕ) : + Cocone (chainDiagram B δ ⋙ tensorRight (B j)) where + pt := chainColimit B δ + ι := + { app := fun k => + mu (smallNatEquiv.inverse.obj k) j ≫ + chainColimitι B δ (smallNatEquiv.inverse.obj k + 1 + j) + naturality := fun {k k'} f => by + change (chainMap B δ + (leOfHom (smallNatEquiv.inverse.map f)) ▷ B j) ≫ + (mu (smallNatEquiv.inverse.obj k') j ≫ + chainColimitι B δ + (smallNatEquiv.inverse.obj k' + 1 + j)) = + (mu (smallNatEquiv.inverse.obj k) j ≫ + chainColimitι B δ + (smallNatEquiv.inverse.obj k + 1 + j)) ≫ + 𝟙 (chainColimit B δ) + rw [Category.comp_id] + exact mul_chainMap_ι_left B δ mu hδl + (leOfHom (smallNatEquiv.inverse.map f)) j } + +/-- Partial multiplication of the chain colimit against a fixed stage +in the second slot. -/ +noncomputable def chainMulStage + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (mu : ∀ i j : ℕ, B i ⊗ B j ⟶ B (i + 1 + j)) + (hδl : ∀ i j, (δ i ▷ B j) ≫ mu (i + 1) j = mu i j ≫ δ (i + 1 + j) ≫ + chainCast B (Nat.add_right_comm (i + 1) j 1)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + (j : ℕ) : + chainColimit B δ ⊗ B j ⟶ chainColimit B δ := + ((preservesColimitIso (tensorRight (B j)) + (chainDiagram B δ)).hom ≫ + colimit.desc _ (chainMulCocone B δ mu hδl j) : + (tensorRight (B j)).obj (colimit (chainDiagram B δ)) ⟶ + chainColimit B δ) + +/-- On a stage, the partial multiplication is multiply-then-include. -/ +@[reassoc] +theorem ι_chainMulStage [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (mu : ∀ i j : ℕ, B i ⊗ B j ⟶ B (i + 1 + j)) + (hδl : ∀ i j, (δ i ▷ B j) ≫ mu (i + 1) j = mu i j ≫ δ (i + 1 + j) ≫ + chainCast B (Nat.add_right_comm (i + 1) j 1)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + (i j : ℕ) : + (chainColimitι B δ i ▷ B j) ≫ chainMulStage B δ mu hδl j = + mu i j ≫ chainColimitι B δ (i + 1 + j) := by + change (tensorRight (B j)).map (colimit.ι (chainDiagram B δ) + (smallNatEquiv.functor.obj i)) ≫ + chainMulStage B δ mu hδl j = + mu i j ≫ chainColimitι B δ (i + 1 + j) + erw [chainMulStage, ι_preservesColimitIso_hom_assoc] + exact colimit.ι_desc (chainMulCocone B δ mu hδl j) + (smallNatEquiv.functor.obj i) + +/-- Maps out of the chain colimit tensored on the right are +determined by their restrictions to the stages. -/ +theorem chainColimit_tensorRight_hom_ext + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + {X Z : E} + {f g : chainColimit B δ ⊗ X ⟶ Z} + (w : ∀ i : ℕ, (chainColimitι B δ i ▷ X) ≫ f = + (chainColimitι B δ i ▷ X) ≫ g) : f = g := by + apply (cancel_epi (preservesColimitIso (tensorRight X) + (chainDiagram B δ)).inv).mp + apply colimit.hom_ext + intro k + erw [ι_preservesColimitIso_inv_assoc, + ι_preservesColimitIso_inv_assoc] + exact w (smallNatEquiv.inverse.obj k) + +/-- The partial multiplications are natural in the stage. -/ +@[reassoc] +theorem chainMulStage_natural + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (mu : ∀ i j : ℕ, B i ⊗ B j ⟶ B (i + 1 + j)) + (hδl : ∀ i j, (δ i ▷ B j) ≫ mu (i + 1) j = mu i j ≫ δ (i + 1 + j) ≫ + chainCast B (Nat.add_right_comm (i + 1) j 1)) + (hδr : ∀ i j, (B i ◁ δ j) ≫ mu i (j + 1) = mu i j ≫ δ (i + 1 + j)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + {j j' : ℕ} (h : j ≤ j') : + (chainColimit B δ ◁ chainMap B δ h) ≫ + chainMulStage B δ mu hδl j' = + chainMulStage B δ mu hδl j := by + apply chainColimit_tensorRight_hom_ext B δ + intro i + rw [← Category.assoc, ← whisker_exchange, Category.assoc, + ι_chainMulStage, ι_chainMulStage] + exact mul_chainMap_ι_right B δ mu hδr i h + +/-- Maps out of the chain colimit tensored on the left are +determined by their restrictions to the stages. -/ +theorem tensorLeft_chainColimit_hom_ext + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + {X Z : E} + {f g : X ⊗ chainColimit B δ ⟶ Z} + (w : ∀ j : ℕ, (X ◁ chainColimitι B δ j) ≫ f = + (X ◁ chainColimitι B δ j) ≫ g) : f = g := by + apply (cancel_epi (preservesColimitIso (tensorLeft X) + (chainDiagram B δ)).inv).mp + apply colimit.hom_ext + intro k + erw [ι_preservesColimitIso_inv_assoc, + ι_preservesColimitIso_inv_assoc] + exact w (smallNatEquiv.inverse.obj k) + +/-- The partial multiplications form a cocone on the chain diagram +tensored on the left with the chain colimit. -/ +noncomputable def chainMulTotalCocone + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (mu : ∀ i j : ℕ, B i ⊗ B j ⟶ B (i + 1 + j)) + (hδl : ∀ i j, (δ i ▷ B j) ≫ mu (i + 1) j = mu i j ≫ δ (i + 1 + j) ≫ + chainCast B (Nat.add_right_comm (i + 1) j 1)) + (hδr : ∀ i j, (B i ◁ δ j) ≫ mu i (j + 1) = mu i j ≫ δ (i + 1 + j)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] : + Cocone (chainDiagram B δ ⋙ tensorLeft (chainColimit B δ)) where + pt := chainColimit B δ + ι := + { app := fun k => + chainMulStage B δ mu hδl (smallNatEquiv.inverse.obj k) + naturality := fun {k k'} f => by + change (chainColimit B δ ◁ chainMap B δ + (leOfHom (smallNatEquiv.inverse.map f))) ≫ + chainMulStage B δ mu hδl + (smallNatEquiv.inverse.obj k') = + chainMulStage B δ mu hδl + (smallNatEquiv.inverse.obj k) ≫ + 𝟙 (chainColimit B δ) + rw [Category.comp_id] + exact chainMulStage_natural B δ mu hδl hδr + (leOfHom (smallNatEquiv.inverse.map f)) } + +/-- **The colimit multiplication**: the partial multiplications +assembled over the second slot. -/ +noncomputable def chainColimitMul + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (mu : ∀ i j : ℕ, B i ⊗ B j ⟶ B (i + 1 + j)) + (hδl : ∀ i j, (δ i ▷ B j) ≫ mu (i + 1) j = mu i j ≫ δ (i + 1 + j) ≫ + chainCast B (Nat.add_right_comm (i + 1) j 1)) + (hδr : ∀ i j, (B i ◁ δ j) ≫ mu i (j + 1) = mu i j ≫ δ (i + 1 + j)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] : + chainColimit B δ ⊗ chainColimit B δ ⟶ chainColimit B δ := + ((preservesColimitIso (tensorLeft (chainColimit B δ)) + (chainDiagram B δ)).hom ≫ + colimit.desc _ (chainMulTotalCocone B δ mu hδl hδr) : + (tensorLeft (chainColimit B δ)).obj + (colimit (chainDiagram B δ)) ⟶ + chainColimit B δ) + +/-- On a stage in the second slot, the colimit multiplication is the +partial multiplication. -/ +@[reassoc] +theorem whiskerLeft_ι_chainColimitMul + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (mu : ∀ i j : ℕ, B i ⊗ B j ⟶ B (i + 1 + j)) + (hδl : ∀ i j, (δ i ▷ B j) ≫ mu (i + 1) j = mu i j ≫ δ (i + 1 + j) ≫ + chainCast B (Nat.add_right_comm (i + 1) j 1)) + (hδr : ∀ i j, (B i ◁ δ j) ≫ mu i (j + 1) = mu i j ≫ δ (i + 1 + j)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (j : ℕ) : + (chainColimit B δ ◁ chainColimitι B δ j) ≫ + chainColimitMul B δ mu hδl hδr = + chainMulStage B δ mu hδl j := by + change (tensorLeft (chainColimit B δ)).map + (colimit.ι (chainDiagram B δ) + (smallNatEquiv.functor.obj j)) ≫ + chainColimitMul B δ mu hδl hδr = + chainMulStage B δ mu hδl j + erw [chainColimitMul, ι_preservesColimitIso_hom_assoc] + exact colimit.ι_desc (chainMulTotalCocone B δ mu hδl hδr) + (smallNatEquiv.functor.obj j) + +/-- **Defining equation of the colimit multiplication**: on a pair of +stages it is multiply-then-include. -/ +@[reassoc] +theorem ι_tensorHom_chainColimitMul + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (mu : ∀ i j : ℕ, B i ⊗ B j ⟶ B (i + 1 + j)) + (hδl : ∀ i j, (δ i ▷ B j) ≫ mu (i + 1) j = mu i j ≫ δ (i + 1 + j) ≫ + chainCast B (Nat.add_right_comm (i + 1) j 1)) + (hδr : ∀ i j, (B i ◁ δ j) ≫ mu i (j + 1) = mu i j ≫ δ (i + 1 + j)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (i j : ℕ) : + (chainColimitι B δ i ⊗ₘ chainColimitι B δ j) ≫ + chainColimitMul B δ mu hδl hδr = + mu i j ≫ chainColimitι B δ (i + 1 + j) := by + rw [tensorHom_def, Category.assoc, + whiskerLeft_ι_chainColimitMul, ι_chainMulStage] + +/-- The multiply-then-include maps against a fixed stage in the +first slot form a cocone on the chain diagram tensored on the left +with that stage. -/ +noncomputable def chainMulLCocone + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (mu : ∀ i j : ℕ, B i ⊗ B j ⟶ B (i + 1 + j)) + (hδr : ∀ i j, (B i ◁ δ j) ≫ mu i (j + 1) = mu i j ≫ δ (i + 1 + j)) + (i : ℕ) : + Cocone (chainDiagram B δ ⋙ tensorLeft (B i)) where + pt := chainColimit B δ + ι := + { app := fun k => + mu i (smallNatEquiv.inverse.obj k) ≫ + chainColimitι B δ (i + 1 + smallNatEquiv.inverse.obj k) + naturality := fun {k k'} f => by + change (B i ◁ chainMap B δ + (leOfHom (smallNatEquiv.inverse.map f))) ≫ + (mu i (smallNatEquiv.inverse.obj k') ≫ + chainColimitι B δ + (i + 1 + smallNatEquiv.inverse.obj k')) = + (mu i (smallNatEquiv.inverse.obj k) ≫ + chainColimitι B δ + (i + 1 + smallNatEquiv.inverse.obj k)) ≫ + 𝟙 (chainColimit B δ) + rw [Category.comp_id] + exact mul_chainMap_ι_right B δ mu hδr i + (leOfHom (smallNatEquiv.inverse.map f)) } + +/-- Partial multiplication of a fixed stage in the first slot +against the chain colimit. -/ +noncomputable def chainMulStageL + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (mu : ∀ i j : ℕ, B i ⊗ B j ⟶ B (i + 1 + j)) + (hδr : ∀ i j, (B i ◁ δ j) ≫ mu i (j + 1) = mu i j ≫ δ (i + 1 + j)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (i : ℕ) : + B i ⊗ chainColimit B δ ⟶ chainColimit B δ := + ((preservesColimitIso (tensorLeft (B i)) + (chainDiagram B δ)).hom ≫ + colimit.desc _ (chainMulLCocone B δ mu hδr i) : + (tensorLeft (B i)).obj (colimit (chainDiagram B δ)) ⟶ + chainColimit B δ) + +/-- On a stage, the left partial multiplication is +multiply-then-include. -/ +@[reassoc] +theorem ι_chainMulStageL [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (mu : ∀ i j : ℕ, B i ⊗ B j ⟶ B (i + 1 + j)) + (hδr : ∀ i j, (B i ◁ δ j) ≫ mu i (j + 1) = mu i j ≫ δ (i + 1 + j)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (i j : ℕ) : + (B i ◁ chainColimitι B δ j) ≫ chainMulStageL B δ mu hδr i = + mu i j ≫ chainColimitι B δ (i + 1 + j) := by + change (tensorLeft (B i)).map (colimit.ι (chainDiagram B δ) + (smallNatEquiv.functor.obj j)) ≫ + chainMulStageL B δ mu hδr i = + mu i j ≫ chainColimitι B δ (i + 1 + j) + erw [chainMulStageL, ι_preservesColimitIso_hom_assoc] + exact colimit.ι_desc (chainMulLCocone B δ mu hδr i) + (smallNatEquiv.functor.obj j) + +/-- On a stage in the first slot, the colimit multiplication is the +left partial multiplication. -/ +@[reassoc] +theorem ι_whiskerRight_chainColimitMul + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (mu : ∀ i j : ℕ, B i ⊗ B j ⟶ B (i + 1 + j)) + (hδl : ∀ i j, (δ i ▷ B j) ≫ mu (i + 1) j = mu i j ≫ δ (i + 1 + j) ≫ + chainCast B (Nat.add_right_comm (i + 1) j 1)) + (hδr : ∀ i j, (B i ◁ δ j) ≫ mu i (j + 1) = mu i j ≫ δ (i + 1 + j)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (i : ℕ) : + (chainColimitι B δ i ▷ chainColimit B δ) ≫ + chainColimitMul B δ mu hδl hδr = + chainMulStageL B δ mu hδr i := by + apply tensorLeft_chainColimit_hom_ext B δ + intro j + rw [← Category.assoc, whisker_exchange, Category.assoc, + whiskerLeft_ι_chainColimitMul, ι_chainMulStage, + ι_chainMulStageL] + +/-- Maps out of the tensor square of the chain colimit are +determined by pairs of stages. -/ +theorem chainColimit_pair_hom_ext + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + {Z : E} + {f g : chainColimit B δ ⊗ chainColimit B δ ⟶ Z} + (w : ∀ i j : ℕ, + (chainColimitι B δ i ⊗ₘ chainColimitι B δ j) ≫ f = + (chainColimitι B δ i ⊗ₘ chainColimitι B δ j) ≫ g) : + f = g := by + apply tensorLeft_chainColimit_hom_ext B δ + intro j + apply chainColimit_tensorRight_hom_ext B δ + intro i + rw [← Category.assoc, ← Category.assoc, + show chainColimitι B δ i ▷ B j ≫ + chainColimit B δ ◁ chainColimitι B δ j = + chainColimitι B δ i ⊗ₘ chainColimitι B δ j from + (tensorHom_def _ _).symm] + exact w i j + +/-- Sandwich extensionality: maps out of a tensor product with the +chain colimit in the middle slot are determined by the stages +there. -/ +theorem chainColimit_sandwich_hom_ext + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (X Y : E) {Z : E} + {f g : X ⊗ (chainColimit B δ ⊗ Y) ⟶ Z} + (w : ∀ j : ℕ, (X ◁ chainColimitι B δ j ▷ Y) ≫ f = + (X ◁ chainColimitι B δ j ▷ Y) ≫ g) : f = g := by + apply (cancel_epi (preservesColimitIso + (tensorRight Y ⋙ tensorLeft X) (chainDiagram B δ)).inv).mp + apply colimit.hom_ext + intro k + erw [ι_preservesColimitIso_inv_assoc, + ι_preservesColimitIso_inv_assoc] + exact w (smallNatEquiv.inverse.obj k) + +/-! ## The unit and the monoid laws + +The colimit unit is the bottom-stage unit followed by the stage +inclusion. The monoid laws hold on the colimit whenever their +stagewise forms hold; the index transports disappear into the stage +inclusions. -/ + +/-- The colimit unit: the bottom-stage unit followed by the stage +inclusion. -/ +noncomputable def chainColimitUnit + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (u : 𝟙_ E ⟶ B 0) : 𝟙_ E ⟶ chainColimit B δ := + u ≫ chainColimitι B δ 0 + +/-- **Left unit law** of the colimit multiplication, from the +stagewise left unit law. -/ +theorem chainColimit_one_mul + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (mu : ∀ i j : ℕ, B i ⊗ B j ⟶ B (i + 1 + j)) + (hδl : ∀ i j, (δ i ▷ B j) ≫ mu (i + 1) j = mu i j ≫ δ (i + 1 + j) ≫ + chainCast B (Nat.add_right_comm (i + 1) j 1)) + (hδr : ∀ i j, (B i ◁ δ j) ≫ mu i (j + 1) = mu i j ≫ δ (i + 1 + j)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (u : 𝟙_ E ⟶ B 0) + (hul : ∀ j, (u ▷ B j) ≫ mu 0 j = + (λ_ (B j)).hom ≫ chainMap B δ (Nat.le_add_left j (0 + 1))) : + (chainColimitUnit B δ u ▷ chainColimit B δ) ≫ + chainColimitMul B δ mu hδl hδr = + (λ_ (chainColimit B δ)).hom := by + apply tensorLeft_chainColimit_hom_ext B δ + intro j + rw [← Category.assoc, whisker_exchange, Category.assoc, + whiskerLeft_ι_chainColimitMul, chainColimitUnit, + comp_whiskerRight, Category.assoc, ι_chainMulStage, + reassoc_of% (hul j), chainMap_chainColimitι, + leftUnitor_naturality] + +/-- **Right unit law** of the colimit multiplication, from the +stagewise right unit law. -/ +theorem chainColimit_mul_one + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (mu : ∀ i j : ℕ, B i ⊗ B j ⟶ B (i + 1 + j)) + (hδl : ∀ i j, (δ i ▷ B j) ≫ mu (i + 1) j = mu i j ≫ δ (i + 1 + j) ≫ + chainCast B (Nat.add_right_comm (i + 1) j 1)) + (hδr : ∀ i j, (B i ◁ δ j) ≫ mu i (j + 1) = mu i j ≫ δ (i + 1 + j)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (u : 𝟙_ E ⟶ B 0) + (hur : ∀ i, (B i ◁ u) ≫ mu i 0 = (ρ_ (B i)).hom ≫ δ i) : + (chainColimit B δ ◁ chainColimitUnit B δ u) ≫ + chainColimitMul B δ mu hδl hδr = + (ρ_ (chainColimit B δ)).hom := by + apply chainColimit_tensorRight_hom_ext B δ + intro i + rw [← Category.assoc, ← whisker_exchange, Category.assoc, + ι_whiskerRight_chainColimitMul, chainColimitUnit, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + ι_chainMulStageL, reassoc_of% (hur i)] + have hι : δ i ≫ chainColimitι B δ (i + 1 + 0) = + chainColimitι B δ i := + delta_chainColimitι B δ i + rw [hι, rightUnitor_naturality] + +/-- Stagewise associativity, pushed into the colimit: the index +transport is absorbed by the stage inclusion. -/ +theorem mul_assoc_ι [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (mu : ∀ i j : ℕ, B i ⊗ B j ⟶ B (i + 1 + j)) + (hassoc : ∀ i j k, (mu i j ▷ B k) ≫ mu (i + 1 + j) k = + (α_ (B i) (B j) (B k)).hom ≫ (B i ◁ mu j k) ≫ + mu i (j + 1 + k) ≫ chainCast B + (by omega : i + 1 + (j + 1 + k) = i + 1 + j + 1 + k)) + (i j k : ℕ) : + (mu i j ▷ B k) ≫ mu (i + 1 + j) k ≫ + chainColimitι B δ (i + 1 + j + 1 + k) = + (α_ (B i) (B j) (B k)).hom ≫ (B i ◁ mu j k) ≫ + mu i (j + 1 + k) ≫ + chainColimitι B δ (i + 1 + (j + 1 + k)) := by + rw [reassoc_of% (hassoc i j k), chainCast_chainColimitι] + +/-- **Associativity** of the colimit multiplication, from stagewise +associativity. -/ +theorem chainColimit_mul_assoc + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (mu : ∀ i j : ℕ, B i ⊗ B j ⟶ B (i + 1 + j)) + (hδl : ∀ i j, (δ i ▷ B j) ≫ mu (i + 1) j = mu i j ≫ δ (i + 1 + j) ≫ + chainCast B (Nat.add_right_comm (i + 1) j 1)) + (hδr : ∀ i j, (B i ◁ δ j) ≫ mu i (j + 1) = mu i j ≫ δ (i + 1 + j)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (hassoc : ∀ i j k, (mu i j ▷ B k) ≫ mu (i + 1 + j) k = + (α_ (B i) (B j) (B k)).hom ≫ (B i ◁ mu j k) ≫ + mu i (j + 1 + k) ≫ chainCast B + (by omega : i + 1 + (j + 1 + k) = i + 1 + j + 1 + k)) : + (chainColimitMul B δ mu hδl hδr ▷ chainColimit B δ) ≫ + chainColimitMul B δ mu hδl hδr = + (α_ (chainColimit B δ) (chainColimit B δ) + (chainColimit B δ)).hom ≫ + (chainColimit B δ ◁ chainColimitMul B δ mu hδl hδr) ≫ + chainColimitMul B δ mu hδl hδr := by + apply tensorLeft_chainColimit_hom_ext B δ + intro k + conv_lhs => + rw [← Category.assoc, whisker_exchange, Category.assoc, + whiskerLeft_ι_chainColimitMul] + conv_rhs => + rw [associator_naturality_right_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + whiskerLeft_ι_chainColimitMul] + apply (cancel_epi (α_ (chainColimit B δ) (chainColimit B δ) + (B k)).inv).mp + rw [Iso.inv_hom_id_assoc] + apply chainColimit_tensorRight_hom_ext B δ + intro i + conv_lhs => + rw [associator_inv_naturality_left_assoc, + ← comp_whiskerRight_assoc, ι_whiskerRight_chainColimitMul] + conv_rhs => + rw [← whisker_exchange_assoc, ι_whiskerRight_chainColimitMul] + apply chainColimit_sandwich_hom_ext B δ (B i) (B k) + intro j + conv_lhs => + rw [associator_inv_naturality_middle_assoc, + ← comp_whiskerRight_assoc, ι_chainMulStageL, + comp_whiskerRight, Category.assoc, ι_chainMulStage, + mul_assoc_ι B δ mu hassoc i j k, + Iso.inv_hom_id_assoc] + conv_rhs => + rw [← MonoidalCategory.whiskerLeft_comp_assoc, + ι_chainMulStage, MonoidalCategory.whiskerLeft_comp, + Category.assoc, ι_chainMulStageL] + +/-- **The chain colimit as a monoid object**: the unit is the +included bottom-stage unit and the multiplication is assembled from +the stagewise multiplications. -/ +@[reducible] +noncomputable def chainColimitMonObj + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (mu : ∀ i j : ℕ, B i ⊗ B j ⟶ B (i + 1 + j)) + (hδl : ∀ i j, (δ i ▷ B j) ≫ mu (i + 1) j = mu i j ≫ δ (i + 1 + j) ≫ + chainCast B (Nat.add_right_comm (i + 1) j 1)) + (hδr : ∀ i j, (B i ◁ δ j) ≫ mu i (j + 1) = mu i j ≫ δ (i + 1 + j)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (u : 𝟙_ E ⟶ B 0) + (hul : ∀ j, (u ▷ B j) ≫ mu 0 j = + (λ_ (B j)).hom ≫ chainMap B δ (Nat.le_add_left j (0 + 1))) + (hur : ∀ i, (B i ◁ u) ≫ mu i 0 = (ρ_ (B i)).hom ≫ δ i) + (hassoc : ∀ i j k, (mu i j ▷ B k) ≫ mu (i + 1 + j) k = + (α_ (B i) (B j) (B k)).hom ≫ (B i ◁ mu j k) ≫ + mu i (j + 1 + k) ≫ chainCast B + (by omega : i + 1 + (j + 1 + k) = i + 1 + j + 1 + k)) : + MonObj (chainColimit B δ) where + one := chainColimitUnit B δ u + mul := chainColimitMul B δ mu hδl hδr + one_mul := chainColimit_one_mul B δ mu hδl hδr u hul + mul_one := chainColimit_mul_one B δ mu hδl hδr u hur + mul_assoc := chainColimit_mul_assoc B δ mu hδl hδr hassoc + +/-! ## Commutativity -/ + +section Braided + +/-- Stagewise commutativity, pushed into the colimit: the index +transport is absorbed by the stage inclusion. -/ +theorem mul_comm_ι [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (mu : ∀ i j : ℕ, B i ⊗ B j ⟶ B (i + 1 + j)) [BraidedCategory E] + (hcomm : ∀ i j, (β_ (B i) (B j)).hom ≫ mu j i ≫ + chainCast B (by omega : j + 1 + i = i + 1 + j) = mu i j) + (i j : ℕ) : + (β_ (B i) (B j)).hom ≫ mu j i ≫ + chainColimitι B δ (j + 1 + i) = + mu i j ≫ chainColimitι B δ (i + 1 + j) := by + rw [← hcomm i j, Category.assoc, Category.assoc, + chainCast_chainColimitι] + +/-- **Commutativity** of the colimit multiplication, from stagewise +commutativity up to the index transport. -/ +theorem chainColimitMul_comm + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (mu : ∀ i j : ℕ, B i ⊗ B j ⟶ B (i + 1 + j)) + (hδl : ∀ i j, (δ i ▷ B j) ≫ mu (i + 1) j = mu i j ≫ δ (i + 1 + j) ≫ + chainCast B (Nat.add_right_comm (i + 1) j 1)) + (hδr : ∀ i j, (B i ◁ δ j) ≫ mu i (j + 1) = mu i j ≫ δ (i + 1 + j)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + [BraidedCategory E] + (hcomm : ∀ i j, (β_ (B i) (B j)).hom ≫ mu j i ≫ + chainCast B (by omega : j + 1 + i = i + 1 + j) = mu i j) : + (β_ (chainColimit B δ) (chainColimit B δ)).hom ≫ + chainColimitMul B δ mu hδl hδr = + chainColimitMul B δ mu hδl hδr := by + apply chainColimit_pair_hom_ext B δ + intro i j + rw [BraidedCategory.braiding_naturality_assoc, + ι_tensorHom_chainColimitMul, ι_tensorHom_chainColimitMul] + exact mul_comm_ι B δ mu hcomm i j + +/-- **The chain colimit as a commutative monoid object**: stagewise +commutativity makes the packaged monoid structure commutative. -/ +theorem chainColimit_isCommMonObj + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] [MonoidalCategory E] + (mu : ∀ i j : ℕ, B i ⊗ B j ⟶ B (i + 1 + j)) + (hδl : ∀ i j, (δ i ▷ B j) ≫ mu (i + 1) j = mu i j ≫ δ (i + 1 + j) ≫ + chainCast B (Nat.add_right_comm (i + 1) j 1)) + (hδr : ∀ i j, (B i ◁ δ j) ≫ mu i (j + 1) = mu i j ≫ δ (i + 1 + j)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (u : 𝟙_ E ⟶ B 0) [BraidedCategory E] + (hul : ∀ j, (u ▷ B j) ≫ mu 0 j = + (λ_ (B j)).hom ≫ chainMap B δ (Nat.le_add_left j (0 + 1))) + (hur : ∀ i, (B i ◁ u) ≫ mu i 0 = (ρ_ (B i)).hom ≫ δ i) + (hassoc : ∀ i j k, (mu i j ▷ B k) ≫ mu (i + 1 + j) k = + (α_ (B i) (B j) (B k)).hom ≫ (B i ◁ mu j k) ≫ + mu i (j + 1 + k) ≫ chainCast B + (by omega : i + 1 + (j + 1 + k) = i + 1 + j + 1 + k)) + (hcomm : ∀ i j, (β_ (B i) (B j)).hom ≫ mu j i ≫ + chainCast B (by omega : j + 1 + i = i + 1 + j) = mu i j) : + @IsCommMonObj E _ _ _ (chainColimit B δ) + (chainColimitMonObj B δ mu hδl hδr u hul hur hassoc) := + letI := chainColimitMonObj B δ mu hδl hδr u hul hur hassoc + ⟨chainColimitMul_comm B δ mu hδl hδr hcomm⟩ + +end Braided + +/-! ## The ind-category instantiation + +Over the ind-category of a small monoidal category the generic +development applies verbatim: the shape has colimits, tensoring +preserves them (`IndTensorExact`), and the generic chain diagram is +the chain functor of `ChainUnit`, so the nonvanishing criterion for +the colimit unit transfers to the packaged unit. -/ + +section Ind + +/-- **Nonvanishing of the colimit unit**: over the ind-category, the +colimit unit built from a compatible family of stage units vanishes +exactly when the family dies at a finite stage. -/ +theorem chainColimitUnit_eq_zero_iff + {C : Type v} [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] + (B : ℕ → Ind C) + (δ : ∀ n, B n ⟶ B (n + 1)) (u : ∀ n, 𝟙_ (Ind C) ⟶ B n) + (hu : ∀ n, u n ≫ δ n = u (n + 1)) : + chainColimitUnit B δ (u 0) = 0 ↔ ∃ n, u n = 0 := + unit_chain_colimit_eq_zero_iff B δ u hu 0 + +end Ind + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainB.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainB.lean new file mode 100644 index 0000000000..bb40feada6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainB.lean @@ -0,0 +1,336 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulLaws +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainDelta + +/-! +# The transition squares of the splitting chain + +The chain transitions are multiplication by the seed, so they +commute with the chain multiplication: multiplying after an +insertion is inserting after multiplying. These are the +compatibility squares consumed by the colimit algebra. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {D : Type u} + +/-- **The right transition square**: inserting the seed in the +second factor and multiplying is multiplying and then inserting +the seed. -/ +theorem chainDelta_mul_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (i j : ℕ) : + (chainStage A M M' i ◁ chainDelta A M M' d j) ≫ + chainMul A M M' i (j + 1) = + chainMul A M M' i j ≫ chainDelta A M M' d (i + 1 + j) := by + rw [chainDelta, chainDelta] + rw [MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + Category.assoc] + have hass := chainMul_assoc A M M' i j 0 + rw [show chainStageCast A M M' + (by omega : i + 1 + (j + 1 + 0) = i + 1 + j + 1 + 0) = + 𝟙 _ from chainStageCast_rfl A M M' _, + Category.comp_id] at hass + rw [show chainMul A M M' (i + 1 + j) 0 ≫ + 𝟙 (chainStage A M M' (i + 1 + (j + 1 + 0))) = + chainMul A M M' (i + 1 + j) 0 from Category.comp_id _] + at hass + have hkey : (chainStage A M M' i ◁ chainMul A M M' j 0) ≫ + chainMul A M M' i (j + 1) = + (α_ (chainStage A M M' i) (chainStage A M M' j) + (chainStage A M M' 0)).inv ≫ + (chainMul A M M' i j ▷ chainStage A M M' 0) ≫ + chainMul A M M' (i + 1 + j) 0 := by + have h := congrArg (fun t => + (α_ (chainStage A M M' i) (chainStage A M M' j) + (chainStage A M M' 0)).inv ≫ t) hass + simp only [Iso.inv_hom_id_assoc] at h + exact h.symm + rw [hkey] + have h1 : (chainStage A M M' i ◁ + (chainStage A M M' j ◁ chainSeed A M M' d)) ≫ + (α_ (chainStage A M M' i) (chainStage A M M' j) + (chainStage A M M' 0)).inv = + (α_ (chainStage A M M' i) (chainStage A M M' j) + (𝟙_ D)).inv ≫ + ((chainStage A M M' i ⊗ chainStage A M M' j) ◁ + chainSeed A M M' d) := by + rw [← associator_inv_naturality_right] + rw [reassoc_of% h1] + have h2 : (chainStage A M M' i ◁ + (ρ_ (chainStage A M M' j)).inv) ≫ + (α_ (chainStage A M M' i) (chainStage A M M' j) + (𝟙_ D)).inv = + (ρ_ (chainStage A M M' i ⊗ chainStage A M M' j)).inv := by + monoidal + rw [reassoc_of% h2] + have h3 : ((chainStage A M M' i ⊗ chainStage A M M' j) ◁ + chainSeed A M M' d) ≫ + (chainMul A M M' i j ▷ chainStage A M M' 0) = + (chainMul A M M' i j ▷ 𝟙_ D) ≫ + (chainStage A M M' (i + 1 + j) ◁ chainSeed A M M' d) := + whisker_exchange _ _ + rw [reassoc_of% h3] + have h4 : (ρ_ (chainStage A M M' i ⊗ + chainStage A M M' j)).inv ≫ + (chainMul A M M' i j ▷ 𝟙_ D) = + chainMul A M M' i j ≫ + (ρ_ (chainStage A M M' (i + 1 + j))).inv := by + rw [rightUnitor_inv_naturality] + rw [reassoc_of% h4] + +/-- Transitions transport along index casts. -/ +theorem chainStageCast_delta + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + {a b : ℕ} (h : a = b) : + chainStageCast A M M' h ≫ chainDelta A M M' d b = + chainDelta A M M' d a ≫ + chainStageCast A M M' (by omega : a + 1 = b + 1) := by + subst h + rw [chainStageCast_rfl, chainStageCast_rfl, + Category.id_comp, Category.comp_id] + +/-- **The left transition square**: inserting the seed in the +first factor and multiplying is multiplying and then inserting +the seed, up to the index transport. -/ +theorem chainDelta_mul_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (i j : ℕ) : + (chainDelta A M M' d i ▷ chainStage A M M' j) ≫ + chainMul A M M' (i + 1) j = + chainMul A M M' i j ≫ chainDelta A M M' d (i + 1 + j) ≫ + chainStageCast A M M' + (Nat.add_right_comm (i + 1) j 1) := by + have hcm : chainMul A M M' (i + 1) j = + (β_ (chainStage A M M' (i + 1)) + (chainStage A M M' j)).hom ≫ + chainMul A M M' j (i + 1) ≫ + chainStageCast A M M' + (by omega : j + 1 + (i + 1) = i + 1 + 1 + j) := + (chainMul_comm A M M' (i + 1) j).symm + rw [hcm] + have hnat : (chainDelta A M M' d i ▷ chainStage A M M' j) ≫ + (β_ (chainStage A M M' (i + 1)) + (chainStage A M M' j)).hom = + (β_ (chainStage A M M' i) (chainStage A M M' j)).hom ≫ + (chainStage A M M' j ◁ chainDelta A M M' d i) := by + rw [BraidedCategory.braiding_naturality_left] + rw [reassoc_of% hnat] + rw [reassoc_of% (chainDelta_mul_right A M M' d j i)] + have hcm2 : (β_ (chainStage A M M' i) + (chainStage A M M' j)).hom ≫ + chainMul A M M' j i = + chainMul A M M' i j ≫ chainStageCast A M M' + (by omega : i + 1 + j = j + 1 + i) := by + have h := chainMul_comm A M M' i j + rw [← h, Category.assoc, Category.assoc, + chainStageCast_trans, chainStageCast_rfl, + Category.comp_id] + rw [reassoc_of% hcm2] + rw [reassoc_of% (chainStageCast_delta A M M' d + (by omega : i + 1 + j = j + 1 + i))] + rw [chainStageCast_trans] + +/-- **The right unit law of the seed**: multiplying by the seed +on the right is the transition. -/ +theorem chainSeed_mul_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (i : ℕ) : + (chainStage A M M' i ◁ chainSeed A M M' d) ≫ + chainMul A M M' i 0 = + (ρ_ (chainStage A M M' i)).hom ≫ + chainDelta A M M' d i := by + rw [chainDelta, Iso.hom_inv_id_assoc] + +/-- **The left unit law of the seed**: multiplying by the seed on +the left is the transition, through the unit braiding. -/ +theorem chainSeed_mul_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (j : ℕ) : + (chainSeed A M M' d ▷ chainStage A M M' j) ≫ + chainMul A M M' 0 j = + (λ_ (chainStage A M M' j)).hom ≫ + chainDelta A M M' d j ≫ + chainStageCast A M M' (by omega : j + 1 = 0 + 1 + j) := by + have hcm : chainMul A M M' 0 j = + (β_ (chainStage A M M' 0) (chainStage A M M' j)).hom ≫ + chainMul A M M' j 0 ≫ + chainStageCast A M M' (by omega : j + 1 + 0 = 0 + 1 + j) := + (chainMul_comm A M M' 0 j).symm + rw [hcm] + have hnat : (chainSeed A M M' d ▷ chainStage A M M' j) ≫ + (β_ (chainStage A M M' 0) (chainStage A M M' j)).hom = + (β_ (𝟙_ D) (chainStage A M M' j)).hom ≫ + (chainStage A M M' j ◁ chainSeed A M M' d) := by + rw [BraidedCategory.braiding_naturality_left] + rw [reassoc_of% hnat] + rw [reassoc_of% (chainSeed_mul_right A M M' d j)] + rw [braiding_tensorUnit_left] + simp only [Category.assoc, Iso.inv_hom_id_assoc] + +/-- A chain map to a transported index is the chain map followed +by the transport. -/ +theorem chainMap_eq_cast [Category.{v} D] + (B : ℕ → D) (δ : ∀ n, B n ⟶ B (n + 1)) + {m n n' : ℕ} (h : m ≤ n) (hn : n = n') (h' : m ≤ n') : + chainMap B δ h' = chainMap B δ h ≫ chainCast B hn := by + subst hn + rw [chainCast_rfl, Category.comp_id] + +/-- The left seed law in chain-map form. -/ +theorem chainSeed_mul_left_chainMap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (j : ℕ) : + (chainSeed A M M' d ▷ chainStage A M M' j) ≫ + chainMul A M M' 0 j = + (λ_ (chainStage A M M' j)).hom ≫ + chainMap (chainStage A M M') (chainDelta A M M' d) + (Nat.le_add_left j (0 + 1)) := by + rw [chainSeed_mul_left A M M' d j, + chainMap_eq_cast (chainStage A M M') + (chainDelta A M M' d) (Nat.le_succ j) + (by omega : j + 1 = 0 + 1 + j) (Nat.le_add_left j (0 + 1)), + chainMap_le_succ] + rfl + +section Colimit + +/-- **The algebra of the splitting chain**: the colimit of the +symmetric stages along the seed transitions. -/ +noncomputable def chainB + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') : D := + chainColimit (chainStage A M M') (chainDelta A M M' d) + +/-- **The splitting-chain algebra is a commutative monoid**: the +stage laws transport to the colimit. -/ +@[reducible] +noncomputable def chainBMonObj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (d : ModDualityDatum A M M') : + MonObj (chainB A M M' d) := + chainColimitMonObj (chainStage A M M') (chainDelta A M M' d) + (chainMul A M M') (chainDelta_mul_left A M M' d) + (chainDelta_mul_right A M M' d) (chainSeed A M M' d) + (chainSeed_mul_left_chainMap A M M' d) + (chainSeed_mul_right A M M' d) + (fun i j k => by + have h := chainMul_assoc A M M' i j k + rw [show chainStageCast A M M' + (by omega : i + 1 + j + 1 + k = i + 1 + j + 1 + k) = + 𝟙 _ from chainStageCast_rfl A M M' _, + Category.comp_id] at h + exact h) + +/-- **The splitting-chain algebra is commutative**. -/ +theorem chainB_isCommMonObj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (d : ModDualityDatum A M M') : + letI := chainBMonObj A M M' d + IsCommMonObj (chainB A M M' d) := + chainColimit_isCommMonObj (chainStage A M M') + (chainDelta A M M' d) (chainMul A M M') + (chainDelta_mul_left A M M' d) + (chainDelta_mul_right A M M' d) (chainSeed A M M' d) + (chainSeed_mul_left_chainMap A M M' d) + (chainSeed_mul_right A M M' d) + (fun i j k => by + have h := chainMul_assoc A M M' i j k + rw [show chainStageCast A M M' + (by omega : i + 1 + j + 1 + k = i + 1 + j + 1 + k) = + 𝟙 _ from chainStageCast_rfl A M M' _, + Category.comp_id] at h + exact h) + (fun i j => chainMul_comm A M M' i j) + +/-- **The unit of the splitting-chain algebra**: the seed at the +bottom stage. -/ +noncomputable def chainBUnit + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') : + 𝟙_ D ⟶ chainB A M M' d := + chainColimitUnit (chainStage A M M') (chainDelta A M M' d) + (chainSeed A M M' d) + +end Colimit + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGr.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGr.lean new file mode 100644 index 0000000000..3afe689d64 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGr.lean @@ -0,0 +1,1607 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGradedLaws + +/-! +# The graded splitting algebra carrier + +The full splitting algebra is the sum over the integer degrees of +the graded components: degree `a` is the line through the +starting bidegree `((−a)⁺, a⁺)`, so nonnegative degrees extend +the `M`-arity and negative degrees the `M'`-arity. The balanced +degree is the algebra of the splitting chain, carrying the unit. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The graded component at an integer degree**: the line +through `((−a)⁺, a⁺)` — nonnegative degrees raise the `M`-arity, +negative degrees the `M'`-arity. -/ +noncomputable def chainBGrComponent + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') + (a : ℤ) : D := + chainBdeg A M M' d (-a).toNat a.toNat + +/-- The degree-zero component is the splitting-chain algebra. -/ +noncomputable def chainBGrComponentZeroIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') : + chainBGrComponent A M M' d 0 ≅ chainB A M M' d := + chainBdegZeroIso A M M' d + +/-- The iterated line shift: raising both offsets `n` times is +the identity on the colimit. -/ +noncomputable def chainBdegShiftIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') + (p₀ q₀ : ℕ) : (n : ℕ) → + (chainBdeg A M M' d (p₀ + n) (q₀ + n) ≅ + chainBdeg A M M' d p₀ q₀) + | 0 => Iso.refl _ + | (n + 1) => + chainBdegSuccIso A M M' d (p₀ + n) (q₀ + n) ≪≫ + chainBdegShiftIso A M M' d p₀ q₀ n + +/-- **The pairwise offsets normalise to the sum degree**: the +line through the sum of two components' offsets is the raised +line of the sum-degree component. -/ +noncomputable def chainBGrCompNormIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') + (a b : ℤ) : + chainBdeg A M M' d ((-a).toNat + (-b).toNat) + (a.toNat + b.toNat) ≅ + chainBGrComponent A M M' d (a + b) := + eqToIso (congrArg₂ (chainBdeg A M M' d) + (by omega : (-a).toNat + (-b).toNat = + (-(a + b)).toNat + (a.toNat + b.toNat - (a + b).toNat)) + (by omega : a.toNat + b.toNat = + (a + b).toNat + + (a.toNat + b.toNat - (a + b).toNat))) ≪≫ + chainBdegShiftIso A M M' d (-(a + b)).toNat (a + b).toNat + (a.toNat + b.toNat - (a + b).toNat) + +section MulColimit + +/-- **The pairwise graded product**: two components multiply into +the sum-degree component through the offset normalisation. -/ +noncomputable def chainBGrCompMul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (d : ModDualityDatum A M M') + (a b : ℤ) : + chainBGrComponent A M M' d a ⊗ chainBGrComponent A M M' d b ⟶ + chainBGrComponent A M M' d (a + b) := + chainBdegMul A M M' d (-a).toNat a.toNat (-b).toNat b.toNat ≫ + (chainBGrCompNormIso A M M' d a b).hom + +end MulColimit + +section Carrier + +/-- **The graded splitting algebra carrier**: the sum of the +graded components over all integer degrees. -/ +noncomputable def chainBGr + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + (d : ModDualityDatum A M M') : D := + ∐ fun a : ℤ => chainBGrComponent A M M' d a + +/-- The inclusion of a graded component. -/ +noncomputable def chainBGrι + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + (d : ModDualityDatum A M M') + (a : ℤ) : chainBGrComponent A M M' d a ⟶ chainBGr A M M' d := + Sigma.ι (fun a : ℤ => chainBGrComponent A M M' d a) a + +/-- **The unit of the graded splitting algebra**: the unit of the +balanced algebra, in degree zero. -/ +noncomputable def chainBGrUnit + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + (d : ModDualityDatum A M M') : + 𝟙_ D ⟶ chainBGr A M M' d := + chainBUnit A M M' d ≫ + (chainBGrComponentZeroIso A M M' d).inv ≫ + chainBGrι A M M' d 0 + +/-- The projection onto the degree-zero component: the identity +in degree zero and zero elsewhere. -/ +noncomputable def chainBGrProjZero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + (d : ModDualityDatum A M M') : + chainBGr A M M' d ⟶ chainBGrComponent A M M' d 0 := + Sigma.desc fun b => + if h : b = 0 then + eqToHom (by rw [h]) + else 0 + +/-- The degree-zero inclusion is split by the projection. -/ +@[reassoc (attr := simp)] +theorem chainBGrι_projZero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + (d : ModDualityDatum A M M') : + chainBGrι A M M' d 0 ≫ chainBGrProjZero A M M' d = + 𝟙 (chainBGrComponent A M M' d 0) := by + rw [chainBGrι, chainBGrProjZero] + erw [Sigma.ι_comp_desc] + simp + +/-- **The graded unit does not vanish** when the balanced unit +does not: the degree-zero retraction detects it. -/ +theorem chainBGrUnit_ne_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + (d : ModDualityDatum A M M') + (h : chainBUnit A M M' d ≠ 0) : + chainBGrUnit A M M' d ≠ 0 := by + intro h0 + apply h + have := congrArg (fun t => t ≫ chainBGrProjZero A M M' d ≫ + (chainBGrComponentZeroIso A M M' d).hom) h0 + simpa [chainBGrUnit, Category.assoc] using this + +end Carrier + +section GradedMul + +/-- The multiply-then-include maps against a fixed left component +form a cocone over the right degree. -/ +noncomputable def chainBGrMulStageCocone + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + [HasColimitsOfShape (Discrete ℤ) D] + (d : ModDualityDatum A M M') (a : ℤ) : + Cocone (Discrete.functor + (fun b : ℤ => chainBGrComponent A M M' d b) ⋙ + tensorLeft (chainBGrComponent A M M' d a)) := + Cocone.mk (chainBGr A M M' d) + (Discrete.natTrans fun b => + chainBGrCompMul A M M' d a b.as ≫ + chainBGrι A M M' d (a + b.as)) + +/-- The left-component stage of the graded multiplication: a fixed +component multiplies the whole carrier degreewise. -/ +noncomputable def chainBGrMulStage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') + (a : ℤ) : + chainBGrComponent A M M' d a ⊗ chainBGr A M M' d ⟶ + chainBGr A M M' d := + ((preservesColimitIso + (tensorLeft (chainBGrComponent A M M' d a)) + (Discrete.functor + fun b : ℤ => chainBGrComponent A M M' d b)).hom ≫ + colimit.desc _ (chainBGrMulStageCocone A M M' d a) : + (tensorLeft (chainBGrComponent A M M' d a)).obj + (colimit (Discrete.functor + fun b : ℤ => chainBGrComponent A M M' d b)) ⟶ + chainBGr A M M' d) + +/-- On a right component, the stage multiplication is the pairwise +product followed by the sum-degree inclusion. -/ +@[reassoc] +theorem whiskerLeft_ι_chainBGrMulStage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') (a b : ℤ) : + (chainBGrComponent A M M' d a ◁ chainBGrι A M M' d b) ≫ + chainBGrMulStage A M M' d a = + chainBGrCompMul A M M' d a b ≫ + chainBGrι A M M' d (a + b) := by + change (tensorLeft (chainBGrComponent A M M' d a)).map + (colimit.ι (Discrete.functor + fun b : ℤ => chainBGrComponent A M M' d b) ⟨b⟩) ≫ + chainBGrMulStage A M M' d a = + chainBGrCompMul A M M' d a b ≫ chainBGrι A M M' d (a + b) + erw [chainBGrMulStage, ι_preservesColimitIso_hom_assoc] + exact colimit.ι_desc (chainBGrMulStageCocone A M M' d a) ⟨b⟩ + +/-- The stage multiplications form a cocone over the left +degree. -/ +noncomputable def chainBGrMulCocone + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') : + Cocone (Discrete.functor + (fun a : ℤ => chainBGrComponent A M M' d a) ⋙ + tensorRight (chainBGr A M M' d)) := + Cocone.mk (chainBGr A M M' d) + (Discrete.natTrans fun a => chainBGrMulStage A M M' d a.as) + +/-- **The multiplication of the graded splitting algebra**: the +pairwise graded products assembled over both degrees. -/ +noncomputable def chainBGrMul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') : + chainBGr A M M' d ⊗ chainBGr A M M' d ⟶ chainBGr A M M' d := + ((preservesColimitIso (tensorRight (chainBGr A M M' d)) + (Discrete.functor + fun a : ℤ => chainBGrComponent A M M' d a)).hom ≫ + colimit.desc _ (chainBGrMulCocone A M M' d) : + (tensorRight (chainBGr A M M' d)).obj + (colimit (Discrete.functor + fun a : ℤ => chainBGrComponent A M M' d a)) ⟶ + chainBGr A M M' d) + +/-- On a left component, the multiplication is the stage +multiplication. -/ +@[reassoc] +theorem ι_whiskerRight_chainBGrMul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') + (a : ℤ) : + (chainBGrι A M M' d a ▷ chainBGr A M M' d) ≫ + chainBGrMul A M M' d = + chainBGrMulStage A M M' d a := by + change (tensorRight (chainBGr A M M' d)).map + (colimit.ι (Discrete.functor + fun a : ℤ => chainBGrComponent A M M' d a) ⟨a⟩) ≫ + chainBGrMul A M M' d = + chainBGrMulStage A M M' d a + erw [chainBGrMul, ι_preservesColimitIso_hom_assoc] + exact colimit.ι_desc (chainBGrMulCocone A M M' d) ⟨a⟩ + +/-- **Defining equation of the graded multiplication**: on a pair +of components it is the pairwise product followed by the +sum-degree inclusion. -/ +@[reassoc] +theorem ι_tensorHom_chainBGrMul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') + (a b : ℤ) : + (chainBGrι A M M' d a ⊗ₘ chainBGrι A M M' d b) ≫ + chainBGrMul A M M' d = + chainBGrCompMul A M M' d a b ≫ + chainBGrι A M M' d (a + b) := by + rw [tensorHom_def', Category.assoc, + ι_whiskerRight_chainBGrMul, whiskerLeft_ι_chainBGrMulStage] + +end GradedMul + +section ZeroDegreeMul + +-- The graded chain's structure maps unfold +-- through the colimit cocone and the duality datum together. +/-- Under the degree-zero identification, the stage insertions of +the balanced line are the stage transports followed by the stage +inclusions of the splitting-chain algebra. -/ +@[reassoc] +theorem chainBdegι_chainBdegZeroIso_hom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') (k : ℕ) : + chainBdegι A M M' d 0 0 k ≫ + (chainBdegZeroIso A M M' d).hom = + chainStage2Cast A M M' (Nat.zero_add k) (Nat.zero_add k) ≫ + chainColimitι (chainStage A M M') + (chainDelta A M M' d) k := + ι_chainColimitMapIso_hom _ _ _ _ _ k + +-- The graded chain's structure maps unfold +-- through the colimit cocone and the duality datum together. + +end ZeroDegreeMul + +section GradedComm + +/-- The iterated shift commutes with the offset transports. -/ +theorem chainBdegShiftIso_hom_cast + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') + {p₀ q₀ p₀' q₀' n n' : ℕ} + (hp : p₀ = p₀') (hq : q₀ = q₀') (hn : n = n') : + chainBdegCast A M M' d + (by omega : p₀ + n = p₀' + n') + (by omega : q₀ + n = q₀' + n') ≫ + (chainBdegShiftIso A M M' d p₀' q₀' n').hom = + (chainBdegShiftIso A M M' d p₀ q₀ n).hom ≫ + chainBdegCast A M M' d hp hq := by + subst hp hq hn + rw [chainBdegCast_rfl, chainBdegCast_rfl, Category.id_comp, + Category.comp_id] + +/-- Degree transports on a component are offset transports. -/ +theorem chainBGrComponent_eqToHom_cast + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') {x y : ℤ} (h : x = y) : + eqToHom (congrArg (chainBGrComponent A M M' d) h) = + chainBdegCast A M M' d + (by rw [h] : (-x).toNat = (-y).toNat) + (by rw [h] : x.toNat = y.toNat) := by + subst h + rfl + +/-- Line transports along paired offset equalities are offset +transports. -/ +theorem chainBdeg_eqToHom_cast + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') + {p₀ q₀ p₀' q₀' : ℕ} (hp : p₀ = p₀') (hq : q₀ = q₀') : + eqToHom (congrArg₂ (chainBdeg A M M' d) hp hq) = + chainBdegCast A M M' d hp hq := by + subst hp hq + rfl + +/-- The normaliser decomposes as an offset transport followed by +the iterated shift. -/ +theorem chainBGrCompNormIso_hom_eq + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') + (a b : ℤ) : + (chainBGrCompNormIso A M M' d a b).hom = + chainBdegCast A M M' d + (by omega : (-a).toNat + (-b).toNat = + (-(a + b)).toNat + + (a.toNat + b.toNat - (a + b).toNat)) + (by omega : a.toNat + b.toNat = + (a + b).toNat + + (a.toNat + b.toNat - (a + b).toNat)) ≫ + (chainBdegShiftIso A M M' d (-(a + b)).toNat + (a + b).toNat + (a.toNat + b.toNat - (a + b).toNat)).hom := by + refine (Iso.trans_hom _ _).trans ?_ + refine eq_whisker ?_ _ + refine (eqToIso.hom _).trans ?_ + exact chainBdeg_eqToHom_cast A M M' d _ _ + +/-- **The offset normalisation is braiding-compatible**: the +normaliser of the swapped degrees followed by the sum-degree +transport is the offset transport followed by the normaliser. -/ +theorem chainBGrCompNormIso_comm + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') + (a b : ℤ) : + (chainBGrCompNormIso A M M' d b a).hom ≫ + eqToHom (congrArg (chainBGrComponent A M M' d) + (Int.add_comm b a)) = + chainBdegCast A M M' d + (by omega : (-b).toNat + (-a).toNat = + (-a).toNat + (-b).toNat) + (by omega : b.toNat + a.toNat = + a.toNat + b.toNat) ≫ + (chainBGrCompNormIso A M M' d a b).hom := by + refine (eq_whisker (chainBGrCompNormIso_hom_eq A M M' d b a) + _).trans ?_ + refine (whisker_eq _ (chainBGrComponent_eqToHom_cast A M M' d + (Int.add_comm b a))).trans ?_ + refine (Category.assoc _ _ _).trans ?_ + refine (whisker_eq _ (chainBdegShiftIso_hom_cast A M M' d + (by omega : (-(b + a)).toNat = (-(a + b)).toNat) + (by omega : (b + a).toNat = (a + b).toNat) + (by omega : b.toNat + a.toNat - (b + a).toNat = + a.toNat + b.toNat - (a + b).toNat)).symm).trans ?_ + refine (Category.assoc _ _ _).symm.trans ?_ + refine (eq_whisker + ((chainBdegCast_trans A M M' d _ _ _ _).trans + (chainBdegCast_trans A M M' d + (by omega : (-b).toNat + (-a).toNat = + (-a).toNat + (-b).toNat) + (by omega : b.toNat + a.toNat = a.toNat + b.toNat) + (by omega : (-a).toNat + (-b).toNat = + (-(a + b)).toNat + + (a.toNat + b.toNat - (a + b).toNat)) + (by omega : a.toNat + b.toNat = + (a + b).toNat + + (a.toNat + b.toNat - (a + b).toNat))).symm) + _).trans ?_ + refine (Category.assoc _ _ _).trans ?_ + exact whisker_eq _ + (chainBGrCompNormIso_hom_eq A M M' d a b).symm + +section MulColimit2 + +/-- **Commutativity of the pairwise graded product**: the +braiding followed by the swapped product is the product, up to +the sum-degree transport. -/ +theorem chainBGrCompMul_comm + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (d : ModDualityDatum A M M') + (a b : ℤ) : + (β_ (chainBGrComponent A M M' d a) + (chainBGrComponent A M M' d b)).hom ≫ + chainBGrCompMul A M M' d b a ≫ + eqToHom (congrArg (chainBGrComponent A M M' d) + (Int.add_comm b a)) = + chainBGrCompMul A M M' d a b := by + change (β_ (chainBGrComponent A M M' d a) + (chainBGrComponent A M M' d b)).hom ≫ + (chainBdegMul A M M' d (-b).toNat b.toNat (-a).toNat + a.toNat ≫ + (chainBGrCompNormIso A M M' d b a).hom) ≫ + eqToHom (congrArg (chainBGrComponent A M M' d) + (Int.add_comm b a)) = + chainBdegMul A M M' d (-a).toNat a.toNat (-b).toNat + b.toNat ≫ + (chainBGrCompNormIso A M M' d a b).hom + refine (whisker_eq _ (Category.assoc _ _ _)).trans ?_ + refine (whisker_eq _ (whisker_eq _ + (chainBGrCompNormIso_comm A M M' d a b))).trans ?_ + refine (whisker_eq _ (Category.assoc _ _ _).symm).trans ?_ + refine (Category.assoc _ _ _).symm.trans ?_ + exact eq_whisker (chainBdegMul_comm A M M' d (-a).toNat + a.toNat (-b).toNat b.toNat) _ + +end MulColimit2 + +section CarrierComm + +/-- Degree transports are absorbed by the inclusions. -/ +theorem eqToHom_chainBGrι + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + (d : ModDualityDatum A M M') + {x y : ℤ} (h : x = y) : + eqToHom (congrArg (chainBGrComponent A M M' d) h) ≫ + chainBGrι A M M' d y = chainBGrι A M M' d x := by + subst h + simp + +/-- Maps out of the carrier tensored on the right are determined +by their restrictions to the components. -/ +theorem chainBGr_tensorRight_hom_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') + {X Z : D} {f g : chainBGr A M M' d ⊗ X ⟶ Z} + (w : ∀ a : ℤ, (chainBGrι A M M' d a ▷ X) ≫ f = + (chainBGrι A M M' d a ▷ X) ≫ g) : f = g := by + apply (cancel_epi (preservesColimitIso (tensorRight X) + (Discrete.functor + fun a : ℤ => chainBGrComponent A M M' d a)).inv).mp + apply colimit.hom_ext + intro k + obtain ⟨a⟩ := k + erw [ι_preservesColimitIso_inv_assoc, + ι_preservesColimitIso_inv_assoc] + exact w a + +/-- Maps out of the carrier tensored on the left are determined +by their restrictions to the components. -/ +theorem tensorLeft_chainBGr_hom_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') + {X Z : D} {f g : X ⊗ chainBGr A M M' d ⟶ Z} + (w : ∀ b : ℤ, (X ◁ chainBGrι A M M' d b) ≫ f = + (X ◁ chainBGrι A M M' d b) ≫ g) : f = g := by + apply (cancel_epi (preservesColimitIso (tensorLeft X) + (Discrete.functor + fun b : ℤ => chainBGrComponent A M M' d b)).inv).mp + apply colimit.hom_ext + intro k + obtain ⟨b⟩ := k + erw [ι_preservesColimitIso_inv_assoc, + ι_preservesColimitIso_inv_assoc] + exact w b + +/-- Maps out of a tensor square of the carrier agree once they +agree on all pairs of components. -/ +theorem chainBGr_pair_hom_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') + {Z : D} + {f g : chainBGr A M M' d ⊗ chainBGr A M M' d ⟶ Z} + (w : ∀ a b : ℤ, + (chainBGrι A M M' d a ⊗ₘ chainBGrι A M M' d b) ≫ f = + (chainBGrι A M M' d a ⊗ₘ chainBGrι A M M' d b) ≫ g) : + f = g := by + apply tensorLeft_chainBGr_hom_ext A M M' d + intro b + apply chainBGr_tensorRight_hom_ext A M M' d + intro a + rw [← Category.assoc, ← Category.assoc, + show chainBGrι A M M' d a ▷ chainBGrComponent A M M' d b ≫ + chainBGr A M M' d ◁ chainBGrι A M M' d b = + chainBGrι A M M' d a ⊗ₘ chainBGrι A M M' d b from + (tensorHom_def _ _).symm] + exact w a b + +/-- **The graded multiplication is commutative**: the braiding +followed by the multiplication is the multiplication. -/ +theorem chainBGrMul_comm + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') : + (β_ (chainBGr A M M' d) (chainBGr A M M' d)).hom ≫ + chainBGrMul A M M' d = + chainBGrMul A M M' d := by + apply chainBGr_pair_hom_ext A M M' d + intro a b + rw [← Category.assoc, BraidedCategory.braiding_naturality, + Category.assoc, ι_tensorHom_chainBGrMul A M M' d b a, + ι_tensorHom_chainBGrMul A M M' d a b, + ← eqToHom_chainBGrι A M M' d (Int.add_comm b a)] + refine Eq.trans ?_ + (eq_whisker (chainBGrCompMul_comm A M M' d a b) _) + simp only [Category.assoc] + +end CarrierComm + +end GradedComm + +/-! ## The stage-level seed law on the left -/ + +/-- **The left unit law of the seed** at two indices: multiplying +by the seed on the left is the transition, through the unit +braiding. -/ +theorem chainSeed_mul2_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (p q : ℕ) : + (chainSeed A M M' d ▷ chainStage2 A M M' p q) ≫ + chainMul2 A M M' 0 0 p q = + (λ_ (chainStage2 A M M' p q)).hom ≫ + chainDelta2 A M M' d p q ≫ + chainStage2Cast A M M' (by omega : p + 1 = 0 + 1 + p) + (by omega : q + 1 = 0 + 1 + q) := by + have hcm : chainMul2 A M M' 0 0 p q = + (β_ (chainStage2 A M M' 0 0) + (chainStage2 A M M' p q)).hom ≫ + chainMul2 A M M' p q 0 0 ≫ + chainStage2Cast A M M' (by omega : p + 1 + 0 = 0 + 1 + p) + (by omega : q + 1 + 0 = 0 + 1 + q) := + (chainMul2_comm A M M' 0 0 p q).symm + have hnat : (chainSeed A M M' d ▷ chainStage2 A M M' p q) ≫ + (β_ (chainStage2 A M M' 0 0) + (chainStage2 A M M' p q)).hom = + (β_ (𝟙_ D) (chainStage2 A M M' p q)).hom ≫ + (chainStage2 A M M' p q ◁ chainSeed A M M' d) := + BraidedCategory.braiding_naturality_left + (chainSeed A M M' d) (chainStage2 A M M' p q) + refine Eq.trans (whisker_eq _ hcm) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker hnat _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + (chainSeed_mul2_right A M M' d p q) _)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (eq_whisker (braiding_tensorUnit_left + (chainStage2 A M M' p q)) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Iso.inv_hom_id_assoc _ _)) ?_ + rfl + +/-! ## Stage computation of the shift and the normalisation -/ + +/-- The iterated shift peels off one raise at a time. -/ +theorem chainBdegShiftIso_succ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') + (p₀ q₀ n : ℕ) : + chainBdegShiftIso A M M' d p₀ q₀ (n + 1) = + chainBdegSuccIso A M M' d (p₀ + n) (q₀ + n) ≪≫ + chainBdegShiftIso A M M' d p₀ q₀ n := rfl + +-- The graded chain's structure maps unfold +-- through the colimit cocone and the duality datum together. +/-- Under the tail identification, the stage insertions of the +raised line are the stage transports followed by the next stage +insertions of the line. -/ +@[reassoc] +theorem chainBdegι_chainBdegSuccIso_hom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') (p₀ q₀ k : ℕ) : + chainBdegι A M M' d (p₀ + 1) (q₀ + 1) k ≫ + (chainBdegSuccIso A M M' d p₀ q₀).hom = + chainStage2Cast A M M' + (by omega : p₀ + 1 + k = p₀ + (k + 1)) + (by omega : q₀ + 1 + k = q₀ + (k + 1)) ≫ + chainBdegι A M M' d p₀ q₀ (k + 1) := by + refine Eq.trans (whisker_eq _ (Iso.trans_hom _ _)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (ι_chainColimitMapIso_hom _ _ _ _ _ k) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (ι_chainColimitTail + (fun k => chainStage2 A M M' (p₀ + k) (q₀ + k)) + (fun k => chainDelta2 A M M' d (p₀ + k) (q₀ + k)) k)) ?_ + rfl + +-- The graded chain's structure maps unfold +-- through the colimit cocone and the duality datum together. +/-- Under the iterated shift, the stage insertions of the raised +line are the stage transports followed by the shifted stage +insertions of the line. -/ +theorem chainBdegι_chainBdegShiftIso_hom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') (p₀ q₀ : ℕ) : + ∀ n k : ℕ, + chainBdegι A M M' d (p₀ + n) (q₀ + n) k ≫ + (chainBdegShiftIso A M M' d p₀ q₀ n).hom = + chainStage2Cast A M M' + (by omega : p₀ + n + k = p₀ + (k + n)) + (by omega : q₀ + n + k = q₀ + (k + n)) ≫ + chainBdegι A M M' d p₀ q₀ (k + n) + | 0, k => by + refine Eq.trans (Category.comp_id _) ?_ + exact (chainStage2Cast_chainBdegι A M M' d p₀ q₀ + (rfl : k = k + 0)).symm + | (n + 1), k => by + refine Eq.trans (whisker_eq _ (congrArg Iso.hom + (chainBdegShiftIso_succ A M M' d p₀ q₀ n))) ?_ + refine Eq.trans (whisker_eq _ (Iso.trans_hom _ _)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (chainBdegι_chainBdegSuccIso_hom A M M' d + (p₀ + n) (q₀ + n) k) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (chainBdegι_chainBdegShiftIso_hom A M M' d p₀ q₀ n (k + 1))) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (chainStage2Cast_trans A M M' _ _ _ _) _) ?_ + refine Eq.trans (whisker_eq _ + (chainStage2Cast_chainBdegι A M M' d p₀ q₀ + (by omega : k + 1 + n = k + (n + 1))).symm) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + exact eq_whisker (chainStage2Cast_trans A M M' _ _ _ _) _ + +/-- Under the offset normalisation, the stage insertions of the +summed line are the stage transports followed by the shifted stage +insertions of the sum-degree component. -/ +@[reassoc] +theorem chainBdegι_chainBGrCompNormIso_hom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') (a b : ℤ) (k : ℕ) : + chainBdegι A M M' d ((-a).toNat + (-b).toNat) + (a.toNat + b.toNat) k ≫ + (chainBGrCompNormIso A M M' d a b).hom = + chainStage2Cast A M M' + (by omega : (-a).toNat + (-b).toNat + k = + (-(a + b)).toNat + + (k + (a.toNat + b.toNat - (a + b).toNat))) + (by omega : a.toNat + b.toNat + k = + (a + b).toNat + + (k + (a.toNat + b.toNat - (a + b).toNat))) ≫ + chainBdegι A M M' d (-(a + b)).toNat (a + b).toNat + (k + (a.toNat + b.toNat - (a + b).toNat)) := by + refine Eq.trans (whisker_eq _ + (chainBGrCompNormIso_hom_eq A M M' d a b)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (chainBdegι_cast A M M' d _ _ k) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (chainBdegι_chainBdegShiftIso_hom A M M' d + (-(a + b)).toNat (a + b).toNat + (a.toNat + b.toNat - (a + b).toNat) k)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + exact eq_whisker (chainStage2Cast_trans A M M' _ _ _ _) _ + +/-! ## Tensor surgery -/ + +/-- Absorb a whiskered morphism into the first tensor factor. -/ +private theorem tensorHom_whiskerRight_comp + [Category.{v} D] [MonoidalCategory D] + {X₁ X₂ Y₁ Y₂ Z₁ W : D} (a : X₁ ⟶ Y₁) (b : X₂ ⟶ Y₂) + (f : Y₁ ⟶ Z₁) (r : Z₁ ⊗ Y₂ ⟶ W) : + (a ⊗ₘ b) ≫ (f ▷ Y₂) ≫ r = ((a ≫ f) ⊗ₘ b) ≫ r := by + rw [← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom_assoc, + Category.comp_id] + +/-- Absorb a whiskered morphism into the second tensor factor. -/ +private theorem tensorHom_whiskerLeft_comp [Category.{v} D] [MonoidalCategory D] + {X₁ X₂ Y₁ Y₂ Z₂ W : D} (a : X₁ ⟶ Y₁) (b : X₂ ⟶ Y₂) + (g : Y₂ ⟶ Z₂) (r : Y₁ ⊗ Z₂ ⟶ W) : + (a ⊗ₘ b) ≫ (Y₁ ◁ g) ≫ r = (a ⊗ₘ (b ≫ g)) ≫ r := by + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom_assoc, + Category.comp_id] + +/-- Extract a prefix of the first tensor factor as a whisker. -/ +private theorem compTensorHom_whiskerRight_split + [Category.{v} D] [MonoidalCategory D] + {V₁ W₁ U₁ X₂ U₂ Z : D} (x : V₁ ⟶ W₁) (q₁ : W₁ ⟶ U₁) + (q₂ : X₂ ⟶ U₂) (r : U₁ ⊗ U₂ ⟶ Z) : + ((x ≫ q₁) ⊗ₘ q₂) ≫ r = (x ▷ X₂) ≫ (q₁ ⊗ₘ q₂) ≫ r := by + rw [MonoidalCategory.tensorHom_def, + MonoidalCategory.tensorHom_def, comp_whiskerRight] + simp only [Category.assoc] + +/-- Extract a prefix of the second tensor factor as a whisker. -/ +private theorem compTensorHom_whiskerLeft_split + [Category.{v} D] [MonoidalCategory D] + {X₁ U₁ V₂ W₂ U₂ Z : D} (q₁ : X₁ ⟶ U₁) (x : V₂ ⟶ W₂) + (q₂ : W₂ ⟶ U₂) (r : U₁ ⊗ U₂ ⟶ Z) : + (q₁ ⊗ₘ (x ≫ q₂)) ≫ r = (X₁ ◁ x) ≫ (q₁ ⊗ₘ q₂) ≫ r := by + rw [MonoidalCategory.tensorHom_def', + MonoidalCategory.tensorHom_def', + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + +/-! ## Component insertions -/ + +/-- The stage insertion of a graded component. -/ +noncomputable def chainBGrCompι + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') + (a : ℤ) (k : ℕ) : + chainStage2 A M M' ((-a).toNat + k) (a.toNat + k) ⟶ + chainBGrComponent A M M' d a := + chainBdegι A M M' d (-a).toNat a.toNat k + +/-- Stage transports along a stage equality are absorbed by the +component insertions. -/ +theorem chainStage2Cast_chainBGrCompι + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') (x : ℤ) {a b : ℕ} (h : a = b) : + chainStage2Cast A M M' + (by omega : (-x).toNat + a = (-x).toNat + b) + (by omega : x.toNat + a = x.toNat + b) ≫ + chainBGrCompι A M M' d x b = chainBGrCompι A M M' d x a := + chainStage2Cast_chainBdegι A M M' d (-x).toNat x.toNat h + +/-- The component insertions absorb the transitions. -/ +theorem chainDelta2_chainBGrCompι + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') + (x : ℤ) (k : ℕ) : + chainDelta2 A M M' d ((-x).toNat + k) (x.toNat + k) ≫ + chainBGrCompι A M M' d x (k + 1) = + chainBGrCompι A M M' d x k := + chainDelta2_chainBdegι A M M' d (-x).toNat x.toNat k + +/-- Degree transports intertwine the component insertions with +the stage transports. -/ +theorem chainBGrCompι_eqToHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') + {x y : ℤ} (h : x = y) (k : ℕ) : + chainBGrCompι A M M' d x k ≫ + eqToHom (congrArg (chainBGrComponent A M M' d) h) = + chainStage2Cast A M M' + (by omega : (-x).toNat + k = (-y).toNat + k) + (by omega : x.toNat + k = y.toNat + k) ≫ + chainBGrCompι A M M' d y k := by + subst h + simp only [eqToHom_refl, Category.comp_id] + exact (chainStage2Cast_chainBGrCompι A M M' d x + (rfl : k = k)).symm + +/-! ## Stage computation and associativity of the pairwise +product -/ + +section CompMulStages + +/-- Maps out of a component tensored on the left are determined +by the stages. -/ +theorem tensorLeft_chainBGrComp_hom_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (d : ModDualityDatum A M M') (b : ℤ) {X Z : D} + {f g : X ⊗ chainBGrComponent A M M' d b ⟶ Z} + (w : ∀ j : ℕ, (X ◁ chainBGrCompι A M M' d b j) ≫ f = + (X ◁ chainBGrCompι A M M' d b j) ≫ g) : f = g := + tensorLeft_chainColimit_hom_ext + (fun k => chainStage2 A M M' ((-b).toNat + k) (b.toNat + k)) + (fun k => chainDelta2 A M M' d ((-b).toNat + k) + (b.toNat + k)) + (fun j => w j) + +/-- Maps out of a triple tensor of components agree once they +agree on all triples of stages. -/ +theorem chainBGrComp_triple_hom_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (d : ModDualityDatum A M M') + (a b c : ℤ) {Z : D} + {f g : (chainBGrComponent A M M' d a ⊗ + chainBGrComponent A M M' d b) ⊗ + chainBGrComponent A M M' d c ⟶ Z} + (w : ∀ i j k : ℕ, + ((chainBGrCompι A M M' d a i ⊗ₘ + chainBGrCompι A M M' d b j) ⊗ₘ + chainBGrCompι A M M' d c k) ≫ f = + ((chainBGrCompι A M M' d a i ⊗ₘ + chainBGrCompι A M M' d b j) ⊗ₘ + chainBGrCompι A M M' d c k) ≫ g) : f = g := + chainBdeg_triple_hom_ext A M M' d (-a).toNat a.toNat + (-b).toNat b.toNat (-c).toNat c.toNat + (fun i j k => w i j k) + +/-- **Defining equation of the pairwise graded product on +stages**: the two-index stage multiplication, transported and +inserted at the shifted stage of the sum-degree component. -/ +@[reassoc] +theorem ι_tensorHom_chainBGrCompMul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (d : ModDualityDatum A M M') + (a b : ℤ) (i j : ℕ) : + (chainBGrCompι A M M' d a i ⊗ₘ + chainBGrCompι A M M' d b j) ≫ + chainBGrCompMul A M M' d a b = + (chainMul2 A M M' ((-a).toNat + i) (a.toNat + i) + ((-b).toNat + j) (b.toNat + j) ≫ + chainStage2Cast A M M' + (by omega : (-a).toNat + i + 1 + ((-b).toNat + j) = + (-(a + b)).toNat + + (i + 1 + j + + (a.toNat + b.toNat - (a + b).toNat))) + (by omega : a.toNat + i + 1 + (b.toNat + j) = + (a + b).toNat + + (i + 1 + j + + (a.toNat + b.toNat - (a + b).toNat)))) ≫ + chainBGrCompι A M M' d (a + b) + (i + 1 + j + (a.toNat + b.toNat - (a + b).toNat)) := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (ι_tensorHom_chainBdegMul A M M' d + (-a).toNat a.toNat (-b).toNat b.toNat i j) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (chainBdegι_chainBGrCompNormIso_hom A M M' d a b + (i + 1 + j))) ?_ + refine Eq.trans (eq_whisker (show + chainBdegMulStage A M M' (-a).toNat a.toNat (-b).toNat + b.toNat i j = + chainMul2 A M M' ((-a).toNat + i) (a.toNat + i) + ((-b).toNat + j) (b.toNat + j) ≫ + chainStage2Cast A M M' + (by omega : (-a).toNat + i + 1 + ((-b).toNat + j) = + (-a).toNat + (-b).toNat + (i + 1 + j)) + (by omega : a.toNat + i + 1 + (b.toNat + j) = + a.toNat + b.toNat + (i + 1 + j)) from rfl) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + (chainStage2Cast_trans A M M' _ _ _ _) _)) ?_ + exact (Category.assoc _ _ _).symm + +/-- **Associativity of the pairwise graded product**: the two +bracketings of a triple product agree up to the sum-degree +transport reassociating the degrees. -/ +theorem chainBGrCompMul_assoc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (d : ModDualityDatum A M M') + (a b c : ℤ) : + (chainBGrCompMul A M M' d a b ▷ + chainBGrComponent A M M' d c) ≫ + chainBGrCompMul A M M' d (a + b) c = + (α_ (chainBGrComponent A M M' d a) + (chainBGrComponent A M M' d b) + (chainBGrComponent A M M' d c)).hom ≫ + (chainBGrComponent A M M' d a ◁ + chainBGrCompMul A M M' d b c) ≫ + chainBGrCompMul A M M' d a (b + c) ≫ + eqToHom (congrArg (chainBGrComponent A M M' d) + (Int.add_assoc a b c).symm) := by + apply chainBGrComp_triple_hom_ext A M M' d a b c + intro i j k + have hass := chainMul2_assoc A M M' ((-a).toNat + i) + (a.toNat + i) ((-b).toNat + j) (b.toNat + j) + ((-c).toNat + k) (c.toNat + k) + rw [show chainStage2Cast A M M' + (by omega : (-a).toNat + i + 1 + ((-b).toNat + j) + 1 + + ((-c).toNat + k) = + (-a).toNat + i + 1 + ((-b).toNat + j) + 1 + + ((-c).toNat + k)) + (by omega : a.toNat + i + 1 + (b.toNat + j) + 1 + + (c.toNat + k) = + a.toNat + i + 1 + (b.toNat + j) + 1 + + (c.toNat + k)) = + 𝟙 _ from chainStage2Cast_rfl A M M' _ _, + Category.comp_id] at hass + rw [tensorHom_whiskerRight_comp, + ι_tensorHom_chainBGrCompMul A M M' d a b i j, + compTensorHom_whiskerRight_split, + ι_tensorHom_chainBGrCompMul A M M' d (a + b) c + (i + 1 + j + (a.toNat + b.toNat - (a + b).toNat)) k, + associator_naturality_assoc, + tensorHom_whiskerLeft_comp, + ι_tensorHom_chainBGrCompMul A M M' d b c j k, + compTensorHom_whiskerLeft_split, + ι_tensorHom_chainBGrCompMul_assoc A M M' d a (b + c) i + (j + 1 + k + (b.toNat + c.toNat - (b + c).toNat)), + chainBGrCompι_eqToHom A M M' d (Int.add_assoc a b c).symm + (i + 1 + (j + 1 + k + + (b.toNat + c.toNat - (b + c).toNat)) + + (a.toNat + (b + c).toNat - (a + (b + c)).toNat)), + MonoidalCategory.comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rw [reassoc_of% (chainStage2Cast_whiskerRight_chainMul2 A M M' + (by omega : (-a).toNat + i + 1 + ((-b).toNat + j) = + (-(a + b)).toNat + + (i + 1 + j + (a.toNat + b.toNat - (a + b).toNat))) + (by omega : a.toNat + i + 1 + (b.toNat + j) = + (a + b).toNat + + (i + 1 + j + (a.toNat + b.toNat - (a + b).toNat))) + ((-c).toNat + k) (c.toNat + k)), + reassoc_of% (whiskerLeft_chainStage2Cast_chainMul2 A M M' + ((-a).toNat + i) (a.toNat + i) + (by omega : (-b).toNat + j + 1 + ((-c).toNat + k) = + (-(b + c)).toNat + + (j + 1 + k + (b.toNat + c.toNat - (b + c).toNat))) + (by omega : b.toNat + j + 1 + (c.toNat + k) = + (b + c).toNat + + (j + 1 + k + (b.toNat + c.toNat - (b + c).toNat)))), + reassoc_of% hass] + rw [← chainStage2Cast_chainBGrCompι A M M' d (a + b + c) + (by omega : + i + 1 + j + (a.toNat + b.toNat - (a + b).toNat) + 1 + k + + ((a + b).toNat + c.toNat - (a + b + c).toNat) = + i + 1 + (j + 1 + k + + (b.toNat + c.toNat - (b + c).toNat)) + + (a.toNat + (b + c).toNat - (a + (b + c)).toNat))] + simp only [chainStage2Cast_trans_assoc] + +end CompMulStages + +/-! ## Associativity of the graded multiplication -/ + +section CarrierAssoc + +/-- Sandwich extensionality: maps out of a tensor product with +the carrier in the middle slot are determined by the components +there. -/ +theorem chainBGr_sandwich_hom_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') + (X Y : D) {Z : D} + {f g : X ⊗ (chainBGr A M M' d ⊗ Y) ⟶ Z} + (w : ∀ b : ℤ, (X ◁ chainBGrι A M M' d b ▷ Y) ≫ f = + (X ◁ chainBGrι A M M' d b ▷ Y) ≫ g) : f = g := by + apply (cancel_epi (preservesColimitIso + (tensorRight Y ⋙ tensorLeft X) + (Discrete.functor + fun b : ℤ => chainBGrComponent A M M' d b)).inv).mp + apply colimit.hom_ext + intro k + obtain ⟨b⟩ := k + erw [ι_preservesColimitIso_inv_assoc, + ι_preservesColimitIso_inv_assoc] + exact w b + +/-- Maps out of a tensor square of the carrier whiskered on the +right agree once they agree on all pairs of components. -/ +theorem chainBGr_pair_whiskerRight_hom_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') {X Z : D} + {f g : (chainBGr A M M' d ⊗ chainBGr A M M' d) ⊗ X ⟶ Z} + (w : ∀ a b : ℤ, + ((chainBGrι A M M' d a ⊗ₘ chainBGrι A M M' d b) ▷ X) ≫ + f = + ((chainBGrι A M M' d a ⊗ₘ chainBGrι A M M' d b) ▷ X) ≫ + g) : + f = g := by + apply (cancel_epi (α_ (chainBGr A M M' d) (chainBGr A M M' d) + X).inv).mp + apply chainBGr_tensorRight_hom_ext A M M' d + intro a + apply chainBGr_sandwich_hom_ext A M M' d + (chainBGrComponent A M M' d a) X + intro b + have hpre : (chainBGrComponent A M M' d a ◁ + chainBGrι A M M' d b ▷ X) ≫ + (chainBGrι A M M' d a ▷ (chainBGr A M M' d ⊗ X)) ≫ + (α_ (chainBGr A M M' d) (chainBGr A M M' d) X).inv = + (α_ (chainBGrComponent A M M' d a) + (chainBGrComponent A M M' d b) X).inv ≫ + ((chainBGrι A M M' d a ⊗ₘ chainBGrι A M M' d b) ▷ X) := by + rw [whisker_exchange_assoc, + associator_inv_naturality_middle, + associator_inv_naturality_left_assoc, + ← comp_whiskerRight, ← tensorHom_def] + rw [reassoc_of% hpre, reassoc_of% hpre] + exact congrArg (CategoryStruct.comp _) (w a b) + +/-- Maps out of a triple tensor of the carrier agree once they +agree on all triples of components. -/ +theorem chainBGr_triple_hom_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') + {Z : D} + {f g : (chainBGr A M M' d ⊗ chainBGr A M M' d) ⊗ + chainBGr A M M' d ⟶ Z} + (w : ∀ a b c : ℤ, + ((chainBGrι A M M' d a ⊗ₘ chainBGrι A M M' d b) ⊗ₘ + chainBGrι A M M' d c) ≫ f = + ((chainBGrι A M M' d a ⊗ₘ chainBGrι A M M' d b) ⊗ₘ + chainBGrι A M M' d c) ≫ g) : f = g := by + apply tensorLeft_chainBGr_hom_ext A M M' d + intro c + apply chainBGr_pair_whiskerRight_hom_ext A M M' d + intro a b + rw [← Category.assoc, ← Category.assoc, + show (chainBGrι A M M' d a ⊗ₘ chainBGrι A M M' d b) ▷ + chainBGrComponent A M M' d c ≫ + (chainBGr A M M' d ⊗ chainBGr A M M' d) ◁ + chainBGrι A M M' d c = + (chainBGrι A M M' d a ⊗ₘ chainBGrι A M M' d b) ⊗ₘ + chainBGrι A M M' d c from (tensorHom_def _ _).symm] + exact w a b c + +/-- **Associativity of the graded multiplication**: the two +bracketings of a triple product agree. -/ +theorem chainBGrMul_assoc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') : + (chainBGrMul A M M' d ▷ chainBGr A M M' d) ≫ + chainBGrMul A M M' d = + (α_ (chainBGr A M M' d) (chainBGr A M M' d) + (chainBGr A M M' d)).hom ≫ + (chainBGr A M M' d ◁ chainBGrMul A M M' d) ≫ + chainBGrMul A M M' d := by + apply chainBGr_triple_hom_ext A M M' d + intro a b c + rw [tensorHom_whiskerRight_comp, + ι_tensorHom_chainBGrMul A M M' d a b, + compTensorHom_whiskerRight_split, + ι_tensorHom_chainBGrMul A M M' d (a + b) c, + associator_naturality_assoc, + tensorHom_whiskerLeft_comp, + ι_tensorHom_chainBGrMul A M M' d b c, + compTensorHom_whiskerLeft_split, + ι_tensorHom_chainBGrMul A M M' d a (b + c), + ← eqToHom_chainBGrι A M M' d (Int.add_assoc a b c).symm] + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (chainBGrCompMul_assoc A M M' d a b c) _) ?_ + simp only [Category.assoc] + +end CarrierAssoc + +/-! ## The unit laws -/ + +section UnitLaws + +-- The graded chain's structure maps unfold +-- through the colimit cocone and the duality datum together. +/-- **The unit lands at the bottom stage**: through the +degree-zero identification, the unit of the balanced algebra is +the seed at the bottom stage of the degree-zero component. -/ +theorem chainBUnit_chainBGrComponentZeroIso_inv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') : + chainBUnit A M M' d ≫ + (chainBGrComponentZeroIso A M M' d).inv = + chainSeed A M M' d ≫ chainBGrCompι A M M' d 0 0 := by + refine Eq.trans (Category.assoc _ _ _) ?_ + refine whisker_eq _ ?_ + refine (Iso.comp_inv_eq _).mpr ?_ + refine Eq.trans ?_ + (chainBdegι_chainBdegZeroIso_hom A M M' d 0).symm + exact (Category.id_comp _).symm + +/-- The stage rule of the pairwise product at degree zero on the +left, with the balanced-line arities normalised. -/ +theorem ι_tensorHom_chainBGrCompMul_zero_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (d : ModDualityDatum A M M') (b : ℤ) (j : ℕ) : + (chainBGrCompι A M M' d 0 0 ⊗ₘ + chainBGrCompι A M M' d b j) ≫ + chainBGrCompMul A M M' d 0 b = + (chainMul2 A M M' 0 0 ((-b).toNat + j) (b.toNat + j) ≫ + chainStage2Cast A M M' + (by omega : 0 + 1 + ((-b).toNat + j) = + (-(0 + b)).toNat + + (0 + 1 + j + + ((0 : ℤ).toNat + b.toNat - (0 + b).toNat))) + (by omega : 0 + 1 + (b.toNat + j) = + (0 + b).toNat + + (0 + 1 + j + + ((0 : ℤ).toNat + b.toNat - (0 + b).toNat)))) ≫ + chainBGrCompι A M M' d (0 + b) + (0 + 1 + j + + ((0 : ℤ).toNat + b.toNat - (0 + b).toNat)) := + ι_tensorHom_chainBGrCompMul A M M' d 0 b 0 j + +-- The graded chain's structure maps unfold +-- through the colimit cocone and the duality datum together. +/-- **The left unit law of the pairwise graded product**: the +included unit against a component multiplies as the left unitor, +through the sum-degree transport. -/ +@[reassoc] +theorem chainBGrCompMul_unit_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (d : ModDualityDatum A M M') + (b : ℤ) : + ((chainBUnit A M M' d ≫ + (chainBGrComponentZeroIso A M M' d).inv) ▷ + chainBGrComponent A M M' d b) ≫ + chainBGrCompMul A M M' d 0 b ≫ + eqToHom (congrArg (chainBGrComponent A M M' d) + (Int.zero_add b)) = + (λ_ (chainBGrComponent A M M' d b)).hom := by + apply tensorLeft_chainBGrComp_hom_ext A M M' d b + intro j + rw [leftUnitor_naturality] + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (whisker_exchange + (chainBUnit A M M' d ≫ + (chainBGrComponentZeroIso A M M' d).inv) + (chainBGrCompι A M M' d b j)) _) ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.tensorHom_def _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg + (fun t => t ⊗ₘ chainBGrCompι A M M' d b j) + (chainBUnit_chainBGrComponentZeroIso_inv A M M' d)) _) ?_ + refine Eq.trans (compTensorHom_whiskerRight_split + (chainSeed A M M' d) (chainBGrCompι A M M' d 0 0) + (chainBGrCompι A M M' d b j) _) ?_ + refine Eq.trans (whisker_eq _ + ((Category.assoc _ _ _).symm.trans + ((eq_whisker (ι_tensorHom_chainBGrCompMul_zero_left + A M M' d b j) _).trans + ((Category.assoc _ _ _).trans + (whisker_eq _ (chainBGrCompι_eqToHom A M M' d + (Int.zero_add b) (0 + 1 + j + + ((0 : ℤ).toNat + b.toNat - + (0 + b).toNat)))))))) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + ((Category.assoc _ _ _).symm.trans + (eq_whisker (chainSeed_mul2_left A M M' d + ((-b).toNat + j) (b.toNat + j)) _)) _) ?_ + simp only [Category.assoc, chainStage2Cast_trans_assoc] + refine Eq.trans (whisker_eq _ (whisker_eq _ + (chainStage2Cast_chainBGrCompι A M M' d b + (by omega : j + 1 = 0 + 1 + j + + ((0 : ℤ).toNat + b.toNat - (0 + b).toNat))))) ?_ + exact whisker_eq _ (chainDelta2_chainBGrCompι A M M' d b j) + +end UnitLaws + +section CarrierUnit + +/-- **The left unit law of the graded splitting algebra**: the +unit against the carrier is the left unitor. -/ +theorem chainBGrUnit_mul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') : + (chainBGrUnit A M M' d ▷ chainBGr A M M' d) ≫ + chainBGrMul A M M' d = + (λ_ (chainBGr A M M' d)).hom := by + apply tensorLeft_chainBGr_hom_ext A M M' d + intro b + rw [chainBGrUnit, MonoidalCategory.comp_whiskerRight, + MonoidalCategory.comp_whiskerRight] + simp only [Category.assoc] + rw [ι_whiskerRight_chainBGrMul A M M' d 0, + whisker_exchange_assoc, whisker_exchange_assoc, + whiskerLeft_ι_chainBGrMulStage A M M' d 0 b, + ← eqToHom_chainBGrι A M M' d (Int.zero_add b), + ← MonoidalCategory.comp_whiskerRight_assoc, + chainBGrCompMul_unit_left_assoc A M M' d b, + leftUnitor_naturality] + +/-- **The right unit law of the graded splitting algebra**: the +carrier against the unit is the right unitor. -/ +theorem chainBGrMul_unit + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') : + (chainBGr A M M' d ◁ chainBGrUnit A M M' d) ≫ + chainBGrMul A M M' d = + (ρ_ (chainBGr A M M' d)).hom := by + rw [← chainBGrMul_comm A M M' d, ← Category.assoc, + BraidedCategory.braiding_naturality_right, + Category.assoc, chainBGrUnit_mul A M M' d, + braiding_tensorUnit_right, Category.assoc, + Iso.inv_hom_id, Category.comp_id] + +/-! ## The monoid object -/ + +/-- **The graded splitting algebra is a monoid object**: the +degree-zero unit and the graded multiplication satisfy the +monoid laws. -/ +@[reducible] +noncomputable def chainBGrMonObj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') : + MonObj (chainBGr A M M' d) where + one := chainBGrUnit A M M' d + mul := chainBGrMul A M M' d + one_mul := chainBGrUnit_mul A M M' d + mul_one := chainBGrMul_unit A M M' d + mul_assoc := chainBGrMul_assoc A M M' d + +/-- **The graded splitting algebra is commutative**. -/ +theorem chainBGr_isCommMonObj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') : + letI := chainBGrMonObj A M M' d + IsCommMonObj (chainBGr A M M' d) := + letI := chainBGrMonObj A M M' d + ⟨chainBGrMul_comm A M M' d⟩ + +end CarrierUnit + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGraded.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGraded.lean new file mode 100644 index 0000000000..21a15a6729 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGraded.lean @@ -0,0 +1,583 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainB +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulHet +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainShift + +/-! +# The shifted splitting chains + +The off-diagonal lines of the two-index stage lattice: for a +starting bidegree the chain climbs both arities in step, and its +colimit is the corresponding graded component of the splitting +algebra. The balanced line recovers the degree-zero algebra +carrier. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The shifted graded component**: the colimit of the +two-index stages along the line through the starting bidegree, +climbing both arities by the seed transition. -/ +noncomputable def chainBdeg + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') + (p₀ q₀ : ℕ) : D := + chainColimit (fun k => chainStage2 A M M' (p₀ + k) (q₀ + k)) + (fun k => chainDelta2 A M M' d (p₀ + k) (q₀ + k)) + +/-- The stage insertion of a shifted graded component. -/ +noncomputable def chainBdegι + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') + (p₀ q₀ k : ℕ) : + chainStage2 A M M' (p₀ + k) (q₀ + k) ⟶ + chainBdeg A M M' d p₀ q₀ := + chainColimitι + (fun k => chainStage2 A M M' (p₀ + k) (q₀ + k)) + (fun k => chainDelta2 A M M' d (p₀ + k) (q₀ + k)) k + +/-- The stage insertions commute with the transitions. -/ +theorem chainDelta2_chainBdegι + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') + (p₀ q₀ k : ℕ) : + chainDelta2 A M M' d (p₀ + k) (q₀ + k) ≫ + chainBdegι A M M' d p₀ q₀ (k + 1) = + chainBdegι A M M' d p₀ q₀ k := + delta_chainColimitι + (fun k => chainStage2 A M M' (p₀ + k) (q₀ + k)) + (fun k => chainDelta2 A M M' d (p₀ + k) (q₀ + k)) k + +/-- The family cast of a line agrees with the two-index stage +transport. -/ +theorem chainCast_line + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p₀ q₀ : ℕ) {a b : ℕ} (h : a = b) : + chainCast (fun k => chainStage2 A M M' (p₀ + k) (q₀ + k)) + h = + chainStage2Cast A M M' (by omega : p₀ + a = p₀ + b) + (by omega : q₀ + a = q₀ + b) := by + subst h + rw [chainCast_rfl, chainStage2Cast_rfl] + +/-- **The stagewise multiplication of two lines**: the two-index +stage multiplication, transported onto the sum line. -/ +noncomputable def chainBdegMulStage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p₀ q₀ r₀ s₀ i j : ℕ) : + chainStage2 A M M' (p₀ + i) (q₀ + i) ⊗ + chainStage2 A M M' (r₀ + j) (s₀ + j) ⟶ + chainStage2 A M M' (p₀ + r₀ + (i + 1 + j)) + (q₀ + s₀ + (i + 1 + j)) := + chainMul2 A M M' (p₀ + i) (q₀ + i) (r₀ + j) (s₀ + j) ≫ + chainStage2Cast A M M' + (by omega : p₀ + i + 1 + (r₀ + j) = p₀ + r₀ + (i + 1 + j)) + (by omega : q₀ + i + 1 + (s₀ + j) = q₀ + s₀ + (i + 1 + j)) + +/-- The right transition square of the line multiplication. -/ +theorem chainBdegMulStage_delta_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (p₀ q₀ r₀ s₀ i j : ℕ) : + (chainStage2 A M M' (p₀ + i) (q₀ + i) ◁ + chainDelta2 A M M' d (r₀ + j) (s₀ + j)) ≫ + chainBdegMulStage A M M' p₀ q₀ r₀ s₀ i (j + 1) = + chainBdegMulStage A M M' p₀ q₀ r₀ s₀ i j ≫ + chainDelta2 A M M' d (p₀ + r₀ + (i + 1 + j)) + (q₀ + s₀ + (i + 1 + j)) := by + rw [chainBdegMulStage, chainBdegMulStage, ← Category.assoc, + show chainMul2 A M M' (p₀ + i) (q₀ + i) (r₀ + (j + 1)) + (s₀ + (j + 1)) = + chainMul2 A M M' (p₀ + i) (q₀ + i) (r₀ + j + 1) + (s₀ + j + 1) from rfl, + chainDelta2_mul_right A M M' d (p₀ + i) (q₀ + i) + (r₀ + j) (s₀ + j), + Category.assoc] + conv_rhs => rw [Category.assoc, + chainStage2Cast_delta2 A M M' d + (by omega : p₀ + i + 1 + (r₀ + j) = + p₀ + r₀ + (i + 1 + j)) + (by omega : q₀ + i + 1 + (s₀ + j) = + q₀ + s₀ + (i + 1 + j))] + +/-- The left transition square of the line multiplication. -/ +theorem chainBdegMulStage_delta_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (p₀ q₀ r₀ s₀ i j : ℕ) : + (chainDelta2 A M M' d (p₀ + i) (q₀ + i) ▷ + chainStage2 A M M' (r₀ + j) (s₀ + j)) ≫ + chainBdegMulStage A M M' p₀ q₀ r₀ s₀ (i + 1) j = + chainBdegMulStage A M M' p₀ q₀ r₀ s₀ i j ≫ + chainDelta2 A M M' d (p₀ + r₀ + (i + 1 + j)) + (q₀ + s₀ + (i + 1 + j)) ≫ + chainStage2Cast A M M' + (by omega : p₀ + r₀ + (i + 1 + j) + 1 = + p₀ + r₀ + (i + 1 + 1 + j)) + (by omega : q₀ + s₀ + (i + 1 + j) + 1 = + q₀ + s₀ + (i + 1 + 1 + j)) := by + rw [chainBdegMulStage, chainBdegMulStage, + ← Category.assoc, + show chainMul2 A M M' (p₀ + (i + 1)) (q₀ + (i + 1)) + (r₀ + j) (s₀ + j) = + chainMul2 A M M' (p₀ + i + 1) (q₀ + i + 1) + (r₀ + j) (s₀ + j) from rfl, + chainDelta2_mul_left A M M' d (p₀ + i) (q₀ + i) + (r₀ + j) (s₀ + j), + Category.assoc] + conv_rhs => rw [Category.assoc, + reassoc_of% (chainStage2Cast_delta2 A M M' d + (by omega : p₀ + i + 1 + (r₀ + j) = + p₀ + r₀ + (i + 1 + j)) + (by omega : q₀ + i + 1 + (s₀ + j) = + q₀ + s₀ + (i + 1 + j)))] + simp only [Category.assoc, chainStage2Cast_trans] + +section ZeroLine + +/-- The stage identification of the balanced line. -/ +noncomputable def chainBdegZeroStageIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (k : ℕ) : + chainStage2 A M M' (0 + k) (0 + k) ≅ chainStage A M M' k + where + hom := chainStage2Cast A M M' (Nat.zero_add k) + (Nat.zero_add k) + inv := chainStage2Cast A M M' (Nat.zero_add k).symm + (Nat.zero_add k).symm + hom_inv_id := by + change chainStage2Cast A M M' (Nat.zero_add k) + (Nat.zero_add k) ≫ + chainStage2Cast A M M' (Nat.zero_add k).symm + (Nat.zero_add k).symm = + 𝟙 (chainStage2 A M M' (0 + k) (0 + k)) + rw [chainStage2Cast_trans] + exact chainStage2Cast_rfl A M M' _ _ + inv_hom_id := by + change chainStage2Cast A M M' (Nat.zero_add k).symm + (Nat.zero_add k).symm ≫ + chainStage2Cast A M M' (Nat.zero_add k) + (Nat.zero_add k) = + 𝟙 (chainStage2 A M M' k k) + rw [chainStage2Cast_trans] + exact chainStage2Cast_rfl A M M' _ _ + +private theorem chainBdegZeroStage_compatibility + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (k : ℕ) : + chainDelta2 A M M' d (0 + k) (0 + k) ≫ + (chainBdegZeroStageIso A M M' (k + 1)).hom = + (chainBdegZeroStageIso A M M' k).hom ≫ chainDelta2 A M M' d k k := by + dsimp only [chainBdegZeroStageIso] + exact (chainStage2Cast_delta2 A M M' d (Nat.zero_add k) (Nat.zero_add k)).symm + +/-- **The balanced line is the degree-zero algebra carrier**: the +zero-offset line's colimit is the splitting-chain algebra. -/ +noncomputable def chainBdegZeroIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') : + chainBdeg A M M' d 0 0 ≅ chainB A M M' d := + chainColimitMapIso + (fun k => chainStage2 A M M' (0 + k) (0 + k)) + (fun k => chainDelta2 A M M' d (0 + k) (0 + k)) + (chainDelta A M M' d) + (chainBdegZeroStageIso A M M') + (by exact chainBdegZeroStage_compatibility A M M' d) + +end ZeroLine + +/-- The stages of the raised line are the shifted stages of the +line. -/ +noncomputable def chainBdegSuccStageIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p₀ q₀ k : ℕ) : + chainStage2 A M M' (p₀ + 1 + k) (q₀ + 1 + k) ≅ + chainStage2 A M M' (p₀ + (k + 1)) (q₀ + (k + 1)) where + hom := chainStage2Cast A M M' (by omega) (by omega) + inv := chainStage2Cast A M M' (by omega) (by omega) + hom_inv_id := by + rw [chainStage2Cast_trans] + exact chainStage2Cast_rfl A M M' _ _ + inv_hom_id := by + rw [chainStage2Cast_trans] + exact chainStage2Cast_rfl A M M' _ _ + +private theorem chainBdegSuccStage_compatibility + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (p₀ q₀ : ℕ) + (k : ℕ) : + chainDelta2 A M M' d (p₀ + 1 + k) (q₀ + 1 + k) ≫ + (chainBdegSuccStageIso A M M' p₀ q₀ (k + 1)).hom = + (chainBdegSuccStageIso A M M' p₀ q₀ k).hom ≫ + chainDelta2 A M M' d (p₀ + (k + 1)) (q₀ + (k + 1)) := by + dsimp only [chainBdegSuccStageIso] + exact (chainStage2Cast_delta2 A M M' d + (by omega : p₀ + 1 + k = p₀ + (k + 1)) + (by omega : q₀ + 1 + k = q₀ + (k + 1))).symm + +/-- **The raised line is the line**: shifting both offsets by one +is passing to the tail of the chain, which has the same +colimit. -/ +noncomputable def chainBdegSuccIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') + (p₀ q₀ : ℕ) : + chainBdeg A M M' d (p₀ + 1) (q₀ + 1) ≅ + chainBdeg A M M' d p₀ q₀ := + (chainColimitMapIso + (fun k => chainStage2 A M M' (p₀ + 1 + k) (q₀ + 1 + k)) + (fun k => chainDelta2 A M M' d (p₀ + 1 + k) (q₀ + 1 + k)) + (fun k => chainDelta2 A M M' d (p₀ + (k + 1)) (q₀ + (k + 1))) + (chainBdegSuccStageIso A M M' p₀ q₀) + (by exact chainBdegSuccStage_compatibility A M M' d p₀ q₀)) ≪≫ + chainColimitTailIso + (fun k => chainStage2 A M M' (p₀ + k) (q₀ + k)) + (fun k => chainDelta2 A M M' d (p₀ + k) (q₀ + k)) + +section MulColimit + +/-- **The graded multiplication**: two lines multiply into the +sum line at the colimit level. -/ +noncomputable def chainBdegMul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (d : ModDualityDatum A M M') + (p₀ q₀ r₀ s₀ : ℕ) : + chainBdeg A M M' d p₀ q₀ ⊗ chainBdeg A M M' d r₀ s₀ ⟶ + chainBdeg A M M' d (p₀ + r₀) (q₀ + s₀) := + chainColimitMulHet + (fun k => chainStage2 A M M' (p₀ + k) (q₀ + k)) + (fun k => chainStage2 A M M' (r₀ + k) (s₀ + k)) + (fun k => chainStage2 A M M' (p₀ + r₀ + k) (q₀ + s₀ + k)) + (fun k => chainDelta2 A M M' d (p₀ + k) (q₀ + k)) + (fun k => chainDelta2 A M M' d (r₀ + k) (s₀ + k)) + (fun k => chainDelta2 A M M' d (p₀ + r₀ + k) + (q₀ + s₀ + k)) + (chainBdegMulStage A M M' p₀ q₀ r₀ s₀) + (chainBdegMulStage_delta_left A M M' d p₀ q₀ r₀ s₀) + (chainBdegMulStage_delta_right A M M' d p₀ q₀ r₀ s₀) + +/-- Transport of a graded component along offset equalities. -/ +noncomputable def chainBdegCast + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') + {p₀ q₀ p₀' q₀' : ℕ} (hp : p₀ = p₀') (hq : q₀ = q₀') : + chainBdeg A M M' d p₀ q₀ ⟶ chainBdeg A M M' d p₀' q₀' := + eqToHom (by rw [hp, hq]) + +/-- The trivial offset transport is the identity. -/ +@[simp] +theorem chainBdegCast_rfl + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') + (p₀ q₀ : ℕ) : + chainBdegCast A M M' d (rfl : p₀ = p₀) (rfl : q₀ = q₀) = + 𝟙 _ := rfl + +/-- Offset transports compose. -/ +@[reassoc (attr := simp)] +theorem chainBdegCast_trans + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') + {p₀ q₀ p₀' q₀' p₀'' q₀'' : ℕ} + (hp : p₀ = p₀') (hq : q₀ = q₀') + (hp' : p₀' = p₀'') (hq' : q₀' = q₀'') : + chainBdegCast A M M' d hp hq ≫ + chainBdegCast A M M' d hp' hq' = + chainBdegCast A M M' d (hp.trans hp') (hq.trans hq') := by + subst hp hq hp' hq' + simp + +/-- On stages, the graded multiplication is the stagewise line +multiplication. -/ +@[reassoc] +theorem ι_tensorHom_chainBdegMul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (d : ModDualityDatum A M M') + (p₀ q₀ r₀ s₀ i j : ℕ) : + (chainBdegι A M M' d p₀ q₀ i ⊗ₘ + chainBdegι A M M' d r₀ s₀ j) ≫ + chainBdegMul A M M' d p₀ q₀ r₀ s₀ = + chainBdegMulStage A M M' p₀ q₀ r₀ s₀ i j ≫ + chainBdegι A M M' d (p₀ + r₀) (q₀ + s₀) (i + 1 + j) := + ι_tensorHom_chainColimitMulHet _ _ _ _ _ _ _ _ _ i j + +end MulColimit + +section LineIns + +/-- The stage insertion transported onto the line. -/ +noncomputable def chainBdegInsPStage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p₀ q₀ k : ℕ) : + M'.X ⊗ chainStage2 A M M' (p₀ + k) (q₀ + k) ⟶ + chainStage2 A M M' (p₀ + 1 + k) (q₀ + k) := + chainInsP A M M' (p₀ + k) (q₀ + k) ≫ + chainStage2Cast A M M' + (by omega : p₀ + k + 1 = p₀ + 1 + k) + (by omega : q₀ + k = q₀ + k) + +/-- The line insertion commutes with the transitions. -/ +theorem chainBdegInsPStage_delta + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (p₀ q₀ k : ℕ) : + (M'.X ◁ chainDelta2 A M M' d (p₀ + k) (q₀ + k)) ≫ + chainBdegInsPStage A M M' p₀ q₀ (k + 1) = + chainBdegInsPStage A M M' p₀ q₀ k ≫ + chainDelta2 A M M' d (p₀ + 1 + k) (q₀ + k) := by + rw [chainBdegInsPStage, chainBdegInsPStage, + show chainInsP A M M' (p₀ + (k + 1)) (q₀ + (k + 1)) = + chainInsP A M M' (p₀ + k + 1) (q₀ + k + 1) from rfl, + ← Category.assoc, + chainInsP_delta2 A M M' d (p₀ + k) (q₀ + k), + Category.assoc] + conv_rhs => rw [Category.assoc, + chainStage2Cast_delta2 A M M' d + (by omega : p₀ + k + 1 = p₀ + 1 + k) + (by omega : q₀ + k = q₀ + k)] + +/-- The line insertion absorbs the chain maps under the +inclusions. -/ +theorem lineIns_chainMap_ι + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') + (p₀ q₀ : ℕ) {a b : ℕ} (h : a ≤ b) : + (M'.X ◁ chainMap + (fun k => chainStage2 A M M' (p₀ + k) (q₀ + k)) + (fun k => chainDelta2 A M M' d (p₀ + k) (q₀ + k)) h) ≫ + chainBdegInsPStage A M M' p₀ q₀ b ≫ + chainBdegι A M M' d (p₀ + 1) q₀ b = + chainBdegInsPStage A M M' p₀ q₀ a ≫ + chainBdegι A M M' d (p₀ + 1) q₀ a := by + induction b, h using Nat.le_induction with + | base => + rw [chainMap_self, MonoidalCategory.whiskerLeft_id, + Category.id_comp] + | succ b hab ih => + rw [chainMap_succ_of_le _ _ hab, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + ← Category.assoc (M'.X ◁ chainDelta2 A M M' d + (p₀ + b) (q₀ + b)), + chainBdegInsPStage_delta A M M' d p₀ q₀ b, + Category.assoc, chainDelta2_chainBdegι] + exact ih + +/-- The insertion cocone over the line diagram. -/ +noncomputable def chainBdegInsPCocone + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') + (p₀ q₀ : ℕ) : + Cocone (chainDiagram + (fun k => chainStage2 A M M' (p₀ + k) (q₀ + k)) + (fun k => chainDelta2 A M M' d (p₀ + k) (q₀ + k)) ⋙ + tensorLeft M'.X) := + Cocone.mk (chainBdeg A M M' d (p₀ + 1) q₀) + { app := fun k => + chainBdegInsPStage A M M' p₀ q₀ + (smallNatEquiv.inverse.obj k) ≫ + chainBdegι A M M' d (p₀ + 1) q₀ + (smallNatEquiv.inverse.obj k) + naturality := fun {k k'} f => by + change (M'.X ◁ chainMap + (fun k => chainStage2 A M M' (p₀ + k) (q₀ + k)) + (fun k => chainDelta2 A M M' d (p₀ + k) (q₀ + k)) + (leOfHom (smallNatEquiv.inverse.map f))) ≫ + (chainBdegInsPStage A M M' p₀ q₀ + (smallNatEquiv.inverse.obj k') ≫ + chainBdegι A M M' d (p₀ + 1) q₀ + (smallNatEquiv.inverse.obj k')) = + (chainBdegInsPStage A M M' p₀ q₀ + (smallNatEquiv.inverse.obj k) ≫ + chainBdegι A M M' d (p₀ + 1) q₀ + (smallNatEquiv.inverse.obj k)) ≫ + 𝟙 (chainBdeg A M M' d (p₀ + 1) q₀) + rw [Category.comp_id] + exact lineIns_chainMap_ι A M M' d p₀ q₀ + (leOfHom (smallNatEquiv.inverse.map f)) } + +/-- **The colimit-level line insertion.** -/ +noncomputable def chainBdegInsP + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (d : ModDualityDatum A M M') + (p₀ q₀ : ℕ) : + M'.X ⊗ chainBdeg A M M' d p₀ q₀ ⟶ + chainBdeg A M M' d (p₀ + 1) q₀ := + ((preservesColimitIso (tensorLeft M'.X) + (chainDiagram + (fun k => chainStage2 A M M' (p₀ + k) (q₀ + k)) + (fun k => chainDelta2 A M M' d (p₀ + k) (q₀ + k)))).hom ≫ + colimit.desc _ (chainBdegInsPCocone A M M' d p₀ q₀) : + (tensorLeft M'.X).obj _ ⟶ chainBdeg A M M' d (p₀ + 1) q₀) + +/-- On a stage, the line insertion is insert-then-include. -/ +@[reassoc] +theorem whiskerLeft_ι_chainBdegInsP + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (d : ModDualityDatum A M M') + (p₀ q₀ k : ℕ) : + (M'.X ◁ chainBdegι A M M' d p₀ q₀ k) ≫ + chainBdegInsP A M M' d p₀ q₀ = + chainBdegInsPStage A M M' p₀ q₀ k ≫ + chainBdegι A M M' d (p₀ + 1) q₀ k := by + change (tensorLeft M'.X).map (colimit.ι (chainDiagram _ _) + (smallNatEquiv.functor.obj k)) ≫ _ = _ + erw [chainBdegInsP, ι_preservesColimitIso_hom_assoc] + exact colimit.ι_desc (chainBdegInsPCocone A M M' d p₀ q₀) + (smallNatEquiv.functor.obj k) + +end LineIns + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGradedLaws.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGradedLaws.lean new file mode 100644 index 0000000000..cc2e8d31ce --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGradedLaws.lean @@ -0,0 +1,424 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGraded + +/-! +# Laws of the graded line multiplication + +Commutativity and associativity of the multiplication of shifted +graded components: the braiding followed by the swapped +multiplication is the multiplication, and the two bracketings of a +triple product agree, in both cases up to the offset transports. +Each law descends from the corresponding two-index stage law of +`ChainStage2` through pair and triple extensionality for tensored +chain colimits, mirroring the homogeneous laws of `ChainAlgebra`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +/-! ## Extensionality for tensors of distinct chain colimits -/ + +section HetExt + +variable {E : Type u} + +/-- Absorb a whiskered morphism into the first tensor factor. -/ +private theorem tensorHom_whiskerRight_comp + [Category.{v} E] [MonoidalCategory E] + {X₁ X₂ Y₁ Y₂ Z₁ W : E} (a : X₁ ⟶ Y₁) (b : X₂ ⟶ Y₂) + (f : Y₁ ⟶ Z₁) (r : Z₁ ⊗ Y₂ ⟶ W) : + (a ⊗ₘ b) ≫ (f ▷ Y₂) ≫ r = ((a ≫ f) ⊗ₘ b) ≫ r := by + rw [← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom_assoc, + Category.comp_id] + +/-- Absorb a whiskered morphism into the second tensor factor. -/ +private theorem tensorHom_whiskerLeft_comp [Category.{v} E] [MonoidalCategory E] + {X₁ X₂ Y₁ Y₂ Z₂ W : E} (a : X₁ ⟶ Y₁) (b : X₂ ⟶ Y₂) + (g : Y₂ ⟶ Z₂) (r : Y₁ ⊗ Z₂ ⟶ W) : + (a ⊗ₘ b) ≫ (Y₁ ◁ g) ≫ r = (a ⊗ₘ (b ≫ g)) ≫ r := by + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom_assoc, + Category.comp_id] + +/-- Extract a prefix of the first tensor factor as a whisker. -/ +private theorem compTensorHom_whiskerRight_split + [Category.{v} E] [MonoidalCategory E] + {V₁ W₁ U₁ X₂ U₂ Z : E} (x : V₁ ⟶ W₁) (q₁ : W₁ ⟶ U₁) + (q₂ : X₂ ⟶ U₂) (r : U₁ ⊗ U₂ ⟶ Z) : + ((x ≫ q₁) ⊗ₘ q₂) ≫ r = (x ▷ X₂) ≫ (q₁ ⊗ₘ q₂) ≫ r := by + rw [MonoidalCategory.tensorHom_def, + MonoidalCategory.tensorHom_def, comp_whiskerRight] + simp only [Category.assoc] + +/-- Extract a prefix of the second tensor factor as a whisker. -/ +private theorem compTensorHom_whiskerLeft_split + [Category.{v} E] [MonoidalCategory E] + {X₁ U₁ V₂ W₂ U₂ Z : E} (q₁ : X₁ ⟶ U₁) (x : V₂ ⟶ W₂) + (q₂ : W₂ ⟶ U₂) (r : U₁ ⊗ U₂ ⟶ Z) : + (q₁ ⊗ₘ (x ≫ q₂)) ≫ r = (X₁ ◁ x) ≫ (q₁ ⊗ₘ q₂) ≫ r := by + rw [MonoidalCategory.tensorHom_def', + MonoidalCategory.tensorHom_def', + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + +/-- Maps out of a tensor of two chain colimits agree once they +agree on all pairs of stages. -/ +theorem chainColimitHet_pair_hom_ext [Category.{v} E] [MonoidalCategory E] + [HasColimitsOfShape SmallNat.{v} E] (B : ℕ → E) (C : ℕ → E) + (δB : ∀ n, B n ⟶ B (n + 1)) (δC : ∀ n, C n ⟶ C (n + 1)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + {Z : E} + {f g : chainColimit B δB ⊗ chainColimit C δC ⟶ Z} + (w : ∀ i j : ℕ, + (chainColimitι B δB i ⊗ₘ chainColimitι C δC j) ≫ f = + (chainColimitι B δB i ⊗ₘ chainColimitι C δC j) ≫ g) : + f = g := by + apply tensorLeft_chainColimit_hom_ext C δC + intro j + apply chainColimit_tensorRight_hom_ext B δB + intro i + rw [← Category.assoc, ← Category.assoc, + show chainColimitι B δB i ▷ C j ≫ + chainColimit B δB ◁ chainColimitι C δC j = + chainColimitι B δB i ⊗ₘ chainColimitι C δC j from + (tensorHom_def _ _).symm] + exact w i j + +/-- Maps out of a tensor of two chain colimits whiskered on the +right agree once they agree on all pairs of stages. -/ +theorem chainColimitHet_pair_whiskerRight_hom_ext + [Category.{v} E] [MonoidalCategory E] + [HasColimitsOfShape SmallNat.{v} E] (B : ℕ → E) (C : ℕ → E) + (δB : ∀ n, B n ⟶ B (n + 1)) (δC : ∀ n, C n ⟶ C (n + 1)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + {X Z : E} + {f g : (chainColimit B δB ⊗ chainColimit C δC) ⊗ X ⟶ Z} + (w : ∀ i j : ℕ, + ((chainColimitι B δB i ⊗ₘ chainColimitι C δC j) ▷ X) ≫ f = + ((chainColimitι B δB i ⊗ₘ chainColimitι C δC j) ▷ X) ≫ + g) : + f = g := by + apply (cancel_epi (α_ (chainColimit B δB) (chainColimit C δC) + X).inv).mp + apply chainColimit_tensorRight_hom_ext B δB + intro i + apply chainColimit_sandwich_hom_ext C δC (B i) X + intro j + have hpre : (B i ◁ chainColimitι C δC j ▷ X) ≫ + (chainColimitι B δB i ▷ (chainColimit C δC ⊗ X)) ≫ + (α_ (chainColimit B δB) (chainColimit C δC) X).inv = + (α_ (B i) (C j) X).inv ≫ + ((chainColimitι B δB i ⊗ₘ chainColimitι C δC j) ▷ X) := by + rw [whisker_exchange_assoc, + associator_inv_naturality_middle, + associator_inv_naturality_left_assoc, + ← comp_whiskerRight, ← tensorHom_def] + rw [reassoc_of% hpre, reassoc_of% hpre] + exact congrArg (CategoryStruct.comp _) (w i j) + +/-- Maps out of a triple tensor of chain colimits agree once they +agree on all triples of stages. -/ +theorem chainColimitHet_triple_hom_ext [Category.{v} E] [MonoidalCategory E] + [HasColimitsOfShape SmallNat.{v} E] (B : ℕ → E) (C : ℕ → E) (F : ℕ → E) + (δB : ∀ n, B n ⟶ B (n + 1)) (δC : ∀ n, C n ⟶ C (n + 1)) + (δF : ∀ n, F n ⟶ F (n + 1)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + {Z : E} + {f g : (chainColimit B δB ⊗ chainColimit C δC) ⊗ + chainColimit F δF ⟶ Z} + (w : ∀ i j k : ℕ, + ((chainColimitι B δB i ⊗ₘ chainColimitι C δC j) ⊗ₘ + chainColimitι F δF k) ≫ f = + ((chainColimitι B δB i ⊗ₘ chainColimitι C δC j) ⊗ₘ + chainColimitι F δF k) ≫ g) : + f = g := by + apply tensorLeft_chainColimit_hom_ext F δF + intro k + apply chainColimitHet_pair_whiskerRight_hom_ext B C δB δC + intro i j + rw [← Category.assoc, ← Category.assoc, + show (chainColimitι B δB i ⊗ₘ chainColimitι C δC j) ▷ F k ≫ + (chainColimit B δB ⊗ chainColimit C δC) ◁ + chainColimitι F δF k = + (chainColimitι B δB i ⊗ₘ chainColimitι C δC j) ⊗ₘ + chainColimitι F δF k from (tensorHom_def _ _).symm] + exact w i j k + +end HetExt + +/-! ## The stage-level laws -/ + +variable {D : Type u} + +/-- Stage transports slide out of the first factor of the two-index +multiplication. -/ +theorem chainStage2Cast_whiskerRight_chainMul2 + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + {p q p' q' : ℕ} (hp : p = p') (hq : q = q') (e f : ℕ) : + (chainStage2Cast A M M' hp hq ▷ chainStage2 A M M' e f) ≫ + chainMul2 A M M' p' q' e f = + chainMul2 A M M' p q e f ≫ + chainStage2Cast A M M' (by omega : p + 1 + e = p' + 1 + e) + (by omega : q + 1 + f = q' + 1 + f) := by + subst hp hq + rw [chainStage2Cast_rfl, chainStage2Cast_rfl, + MonoidalCategory.id_whiskerRight, Category.id_comp, + Category.comp_id] + +/-- Stage transports slide out of the second factor of the +two-index multiplication. -/ +theorem whiskerLeft_chainStage2Cast_chainMul2 + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (a b : ℕ) {p q p' q' : ℕ} (hp : p = p') (hq : q = q') : + (chainStage2 A M M' a b ◁ chainStage2Cast A M M' hp hq) ≫ + chainMul2 A M M' a b p' q' = + chainMul2 A M M' a b p q ≫ + chainStage2Cast A M M' (by omega : a + 1 + p = a + 1 + p') + (by omega : b + 1 + q = b + 1 + q') := by + subst hp hq + rw [chainStage2Cast_rfl, chainStage2Cast_rfl, + MonoidalCategory.whiskerLeft_id, Category.id_comp, + Category.comp_id] + +/-- **Commutativity of the stagewise line multiplication**, up to +the stage transport onto the common arities. -/ +theorem chainBdegMulStage_comm + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p₀ q₀ r₀ s₀ i j : ℕ) : + (β_ (chainStage2 A M M' (p₀ + i) (q₀ + i)) + (chainStage2 A M M' (r₀ + j) (s₀ + j))).hom ≫ + chainBdegMulStage A M M' r₀ s₀ p₀ q₀ j i ≫ + chainStage2Cast A M M' + (by omega : r₀ + p₀ + (j + 1 + i) = + p₀ + r₀ + (i + 1 + j)) + (by omega : s₀ + q₀ + (j + 1 + i) = + q₀ + s₀ + (i + 1 + j)) = + chainBdegMulStage A M M' p₀ q₀ r₀ s₀ i j := by + rw [chainBdegMulStage, chainBdegMulStage, + ← chainMul2_comm A M M' (p₀ + i) (q₀ + i) (r₀ + j) (s₀ + j)] + simp only [Category.assoc, chainStage2Cast_trans] + +/-- **Associativity of the stagewise line multiplication**, up to +the stage transport reassociating the offsets. -/ +theorem chainBdegMulStage_assoc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p₀ q₀ r₀ s₀ t₀ u₀ i j k : ℕ) : + (chainBdegMulStage A M M' p₀ q₀ r₀ s₀ i j ▷ + chainStage2 A M M' (t₀ + k) (u₀ + k)) ≫ + chainBdegMulStage A M M' (p₀ + r₀) (q₀ + s₀) t₀ u₀ + (i + 1 + j) k = + (α_ (chainStage2 A M M' (p₀ + i) (q₀ + i)) + (chainStage2 A M M' (r₀ + j) (s₀ + j)) + (chainStage2 A M M' (t₀ + k) (u₀ + k))).hom ≫ + (chainStage2 A M M' (p₀ + i) (q₀ + i) ◁ + chainBdegMulStage A M M' r₀ s₀ t₀ u₀ j k) ≫ + chainBdegMulStage A M M' p₀ q₀ (r₀ + t₀) (s₀ + u₀) i + (j + 1 + k) ≫ + chainStage2Cast A M M' + (by omega : p₀ + (r₀ + t₀) + (i + 1 + (j + 1 + k)) = + p₀ + r₀ + t₀ + (i + 1 + j + 1 + k)) + (by omega : q₀ + (s₀ + u₀) + (i + 1 + (j + 1 + k)) = + q₀ + s₀ + u₀ + (i + 1 + j + 1 + k)) := by + have hass := chainMul2_assoc A M M' (p₀ + i) (q₀ + i) + (r₀ + j) (s₀ + j) (t₀ + k) (u₀ + k) + rw [show chainStage2Cast A M M' + (by omega : p₀ + i + 1 + (r₀ + j) + 1 + (t₀ + k) = + p₀ + i + 1 + (r₀ + j) + 1 + (t₀ + k)) + (by omega : q₀ + i + 1 + (s₀ + j) + 1 + (u₀ + k) = + q₀ + i + 1 + (s₀ + j) + 1 + (u₀ + k)) = 𝟙 _ from + chainStage2Cast_rfl A M M' _ _, Category.comp_id] at hass + rw [chainBdegMulStage, chainBdegMulStage, chainBdegMulStage, + chainBdegMulStage, comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rw [reassoc_of% (chainStage2Cast_whiskerRight_chainMul2 A M M' + (by omega : p₀ + i + 1 + (r₀ + j) = p₀ + r₀ + (i + 1 + j)) + (by omega : q₀ + i + 1 + (s₀ + j) = q₀ + s₀ + (i + 1 + j)) + (t₀ + k) (u₀ + k)), + reassoc_of% (whiskerLeft_chainStage2Cast_chainMul2 A M M' + (p₀ + i) (q₀ + i) + (by omega : r₀ + j + 1 + (t₀ + k) = r₀ + t₀ + (j + 1 + k)) + (by omega : s₀ + j + 1 + (u₀ + k) = s₀ + u₀ + (j + 1 + k))), + reassoc_of% hass] + simp only [chainStage2Cast_trans] + +/-! ## Transport of the stage insertions -/ + +/-- Stage transports along a stage-index equality are absorbed by +the stage insertions of a line. -/ +theorem chainStage2Cast_chainBdegι + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') + (p₀ q₀ : ℕ) {a b : ℕ} (h : a = b) : + chainStage2Cast A M M' (by omega : p₀ + a = p₀ + b) + (by omega : q₀ + a = q₀ + b) ≫ + chainBdegι A M M' d p₀ q₀ b = + chainBdegι A M M' d p₀ q₀ a := by + rw [← chainCast_line A M M' p₀ q₀ h] + exact chainCast_chainColimitι + (fun k => chainStage2 A M M' (p₀ + k) (q₀ + k)) + (fun k => chainDelta2 A M M' d (p₀ + k) (q₀ + k)) h + +/-- The stage insertions intertwine the offset transports of a line +with the stage transports. -/ +theorem chainBdegι_cast + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') + {p₀ q₀ p₀' q₀' : ℕ} (hp : p₀ = p₀') (hq : q₀ = q₀') (k : ℕ) : + chainBdegι A M M' d p₀ q₀ k ≫ chainBdegCast A M M' d hp hq = + chainStage2Cast A M M' (by omega : p₀ + k = p₀' + k) + (by omega : q₀ + k = q₀' + k) ≫ + chainBdegι A M M' d p₀' q₀' k := by + subst hp hq + rw [chainBdegCast_rfl, chainStage2Cast_rfl, Category.comp_id, + Category.id_comp] + +/-! ## The colimit-level laws -/ + +section MulColimit + +/-- Maps out of a tensor of two graded components agree once they +agree on all pairs of stages. -/ +theorem chainBdeg_pair_hom_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (d : ModDualityDatum A M M') + (p₀ q₀ r₀ s₀ : ℕ) {Z : D} + {f g : chainBdeg A M M' d p₀ q₀ ⊗ chainBdeg A M M' d r₀ s₀ ⟶ + Z} + (w : ∀ i j : ℕ, + (chainBdegι A M M' d p₀ q₀ i ⊗ₘ + chainBdegι A M M' d r₀ s₀ j) ≫ f = + (chainBdegι A M M' d p₀ q₀ i ⊗ₘ + chainBdegι A M M' d r₀ s₀ j) ≫ g) : + f = g := + chainColimitHet_pair_hom_ext + (fun k => chainStage2 A M M' (p₀ + k) (q₀ + k)) + (fun k => chainStage2 A M M' (r₀ + k) (s₀ + k)) + (fun k => chainDelta2 A M M' d (p₀ + k) (q₀ + k)) + (fun k => chainDelta2 A M M' d (r₀ + k) (s₀ + k)) w + +/-- Maps out of a triple tensor of graded components agree once +they agree on all triples of stages. -/ +theorem chainBdeg_triple_hom_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (d : ModDualityDatum A M M') + (p₀ q₀ r₀ s₀ t₀ u₀ : ℕ) {Z : D} + {f g : (chainBdeg A M M' d p₀ q₀ ⊗ + chainBdeg A M M' d r₀ s₀) ⊗ chainBdeg A M M' d t₀ u₀ ⟶ Z} + (w : ∀ i j k : ℕ, + ((chainBdegι A M M' d p₀ q₀ i ⊗ₘ + chainBdegι A M M' d r₀ s₀ j) ⊗ₘ + chainBdegι A M M' d t₀ u₀ k) ≫ f = + ((chainBdegι A M M' d p₀ q₀ i ⊗ₘ + chainBdegι A M M' d r₀ s₀ j) ⊗ₘ + chainBdegι A M M' d t₀ u₀ k) ≫ g) : + f = g := + chainColimitHet_triple_hom_ext + (fun k => chainStage2 A M M' (p₀ + k) (q₀ + k)) + (fun k => chainStage2 A M M' (r₀ + k) (s₀ + k)) + (fun k => chainStage2 A M M' (t₀ + k) (u₀ + k)) + (fun k => chainDelta2 A M M' d (p₀ + k) (q₀ + k)) + (fun k => chainDelta2 A M M' d (r₀ + k) (s₀ + k)) + (fun k => chainDelta2 A M M' d (t₀ + k) (u₀ + k)) w + +/-- **Commutativity of the graded line multiplication**: the +braiding followed by the swapped multiplication is the +multiplication, up to the offset transport. -/ +theorem chainBdegMul_comm + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (d : ModDualityDatum A M M') + (p₀ q₀ r₀ s₀ : ℕ) : + (β_ (chainBdeg A M M' d p₀ q₀) + (chainBdeg A M M' d r₀ s₀)).hom ≫ + chainBdegMul A M M' d r₀ s₀ p₀ q₀ ≫ + chainBdegCast A M M' d (Nat.add_comm r₀ p₀) + (Nat.add_comm s₀ q₀) = + chainBdegMul A M M' d p₀ q₀ r₀ s₀ := by + apply chainBdeg_pair_hom_ext A M M' d p₀ q₀ r₀ s₀ + intro i j + rw [BraidedCategory.braiding_naturality_assoc, + ι_tensorHom_chainBdegMul_assoc A M M' d r₀ s₀ p₀ q₀ j i, + ι_tensorHom_chainBdegMul A M M' d p₀ q₀ r₀ s₀ i j, + chainBdegι_cast A M M' d (Nat.add_comm r₀ p₀) + (Nat.add_comm s₀ q₀) (j + 1 + i), + ← chainStage2Cast_chainBdegι A M M' d (p₀ + r₀) (q₀ + s₀) + (by omega : j + 1 + i = i + 1 + j), + chainStage2Cast_trans_assoc, + reassoc_of% (chainBdegMulStage_comm A M M' p₀ q₀ r₀ s₀ i j)] + +end MulColimit + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBInd.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBInd.lean new file mode 100644 index 0000000000..e73ce37b8c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBInd.lean @@ -0,0 +1,118 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainB +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCoeq + +/-! +# The splitting chain in the ind-category + +`RS.Classical.Deligne.ChainB` assembles the splitting-chain +algebra `chainB` over any ambient category in which the chain +machinery runs. This file instantiates the ambient at the +ind-category of a small rigid abelian symmetric monoidal category +with preadditive tensor, where the colimit shape exists and the +stage-detection principle of `RS.Classical.Deligne.ChainAlgebra` +applies. The outcome is `RS.chainBUnit_eq_zero_iff`: the unit of +the splitting-chain algebra vanishes exactly when a stage unit +dies. + +Every hypothesis of the `Colimit` section of `ChainB` holds for +`D := Ind C` by an existing instance: + +* `MonoidalCategory (Ind C)` and `SymmetricCategory (Ind C)` — + the transport instances of `RS.Classical.Deligne.IndMonoidal`; +* `Preadditive (Ind C)` and `HasFiniteBiproducts (Ind C)` — + `Mathlib.CategoryTheory.Preadditive.Indization`, for `C` + preadditive with finite colimits (both supplied by `Abelian C`); +* `MonoidalPreadditive (Ind C)` — the preadditive half of + `RS.Classical.Deligne.IndTensorExact`; +* `HasCoequalizers (Ind C)` — the `WalkingParallelPair` colimit + instance of `Mathlib.CategoryTheory.Limits.Indization.Category`; +* `PreservesColimitsOfShape WalkingParallelPair` for every + `tensorLeft Z` and `tensorRight Z` — + `RS.tensorLeft_ind_preservesCoequalizers` and + `RS.tensorRight_ind_preservesCoequalizers` of + `RS.Classical.Deligne.IndCoeq`, for `C` rigid abelian; +* `HasColimitsOfShape SmallNat (Ind C)` — Mathlib's + `HasFilteredColimits (Ind C)`, since `SmallNat` is small + filtered; +* `PreservesColimitsOfShape SmallNat` for every `tensorLeft X` + and `tensorRight X` — + `RS.tensorLeft_ind_preservesColimitsOfShape` and its right-hand + twin in `RS.Classical.Deligne.IndTensorExact`, the filtered + half of Deligne 2.2. + +The ℂ-linear structure of `Ind C` is not canonical: it is induced +by a choice of scalar unit `ψ : ℂ ≃+* End (𝟙_ C)` through +`RS.linearOfScalarUnit (RS.indScalarUnit ψ)` and +`RS.monoidalLinearOfScalarUnitBraided (RS.indScalarUnit ψ)` +(`RS.Classical.Deligne.ScalarLinear`, acceptance section). It is +therefore carried as a hypothesis, as in +`RS.Classical.Deligne.SuperRealize`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v + +variable {C : Type v} + +/-- **Unit-vanishing detection for the splitting-chain algebra**: +over the ind-category, the unit of the algebra `chainB` vanishes +exactly when the unit dies at a finite stage of the chain. -/ +theorem chainBUnit_eq_zero_iff + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] [Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] (A : Ind C) [MonObj A] [IsCommMonObj A] + (M : Mod (Ind C) A) (M' : Mod (Ind C) A) + (d : ModDualityDatum A M M') : + chainBUnit A M M' d = 0 ↔ + ∃ n, chainUnitStage A M M' d n = 0 := + chainColimitUnit_eq_zero_iff (chainStage A M M') + (chainDelta A M M' d) (chainUnitStage A M M' d) + (chainUnitStage_succ A M M' d) + +/-! ## Acceptance + +The full assembly of `ChainB` synthesises over the ind-category: +the algebra, its monoid structure and its commutativity all +instantiate at `D := Ind C`. -/ + +noncomputable example + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] [Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] (A : Ind C) [MonObj A] [IsCommMonObj A] + (M : Mod (Ind C) A) (M' : Mod (Ind C) A) + (d : ModDualityDatum A M M') : Ind C := + chainB A M M' d + +noncomputable example + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] [Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] (A : Ind C) [MonObj A] [IsCommMonObj A] + (M : Mod (Ind C) A) (M' : Mod (Ind C) A) + (d : ModDualityDatum A M M') : + MonObj (chainB A M M' d) := + chainBMonObj A M M' d + +example + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] [Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] (A : Ind C) [MonObj A] [IsCommMonObj A] + (M : Mod (Ind C) A) (M' : Mod (Ind C) A) + (d : ModDualityDatum A M M') : + letI := chainBMonObj A M M' d + IsCommMonObj (chainB A M M' d) := + chainB_isCommMonObj A M M' d + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBNonzero.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBNonzero.lean new file mode 100644 index 0000000000..6119ae2c18 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBNonzero.lean @@ -0,0 +1,48 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBInd +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowInduct + +/-! +# Nonvanishing of the chain algebra unit + +The unit of the splitting-chain algebra over the ind-category is +nonzero: the finite-stage detection reduces vanishing to a chain +unit stage, and the power zigzag induction keeps every stage +alive. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v + +variable {C : Type v} + +/-- **The unit of the splitting-chain algebra is nonzero**: for a +zigzag datum over the ind-category whose symmetric powers all +survive, the unit of the algebra does not vanish. -/ +theorem chainBUnit_ne_zero + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + [CategoryTheory.Linear ℂ (Ind C)] [MonoidalLinear ℂ (Ind C)] (B : Ind C) + [MonObj B] [IsCommMonObj B] (N : Mod (Ind C) B) (N' : Mod (Ind C) B) + (d : ModDualityDatum B N N') + (hz : ModZigzagDatum B d) + (hS : ∀ n, ¬ IsZero (symPow B N.X (n + 1))) : + chainBUnit B N N' d ≠ 0 := by + intro h + obtain ⟨n, hn⟩ := (chainBUnit_eq_zero_iff B N N' d).mp h + exact chainUnitStage_ne_zero_all B N N' d hz n (hS n) hn + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBofA.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBofA.lean new file mode 100644 index 0000000000..ed37d8a536 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBofA.lean @@ -0,0 +1,356 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainB +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.InterchangeAct +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowDatum + +/-! +# The structure morphism of the splitting-chain algebra + +The base algebra maps to the splitting-chain algebra: act on the +seed at the bottom stage and include. The unit law is the +generic point-recovery of unital actions; the multiplication law +reduces along the colimit defining equations to the bilinearity +of the stage multiplication over the base. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- The base action on a chain stage, typed at the stage. A +single atom carrying the wrapper type uniformly, so that the +generic action lemmas instantiate without mixed typing. -/ +noncomputable def chainStageAct + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (k : ℕ) : + A ⊗ chainStage A M M' k ⟶ chainStage A M M' k := + modTensorAct A (symPowMod A M'.X k) (symPowMod A M.X k) + +/-- The stage action is unital. -/ +theorem chainStageAct_one + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (k : ℕ) : + (η[A] ▷ chainStage A M M' k) ≫ chainStageAct A M M' k = + (λ_ (chainStage A M M' k)).hom := + modTensorAct_one A (symPowMod A M'.X k) (symPowMod A M.X k) + +/-- The stage action is associative. -/ +theorem chainStageAct_mul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (k : ℕ) : + (μ[A] ▷ chainStage A M M' k) ≫ chainStageAct A M M' k = + (α_ A A (chainStage A M M' k)).hom ≫ + (A ◁ chainStageAct A M M' k) ≫ chainStageAct A M M' k := + modTensorAct_mul A (symPowMod A M'.X k) (symPowMod A M.X k) + +/-- **The structure morphism of the splitting-chain algebra**: +act on the seed at the bottom stage and include. -/ +noncomputable def chainBofA + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') : + A ⟶ chainB A M M' d := + (ρ_ A).inv ≫ (A ◁ chainSeed A M M' d) ≫ + chainStageAct A M M' 0 ≫ + chainColimitι (chainStage A M M') (chainDelta A M M' d) 0 + +/-- **The structure morphism preserves the unit**: the unit of +the base recovers the seed, which is the unit of the algebra. -/ +theorem chainBofA_unit + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] + (d : ModDualityDatum A M M') : + η[A] ≫ chainBofA A M M' d = chainBUnit A M M' d := by + have h := act_on_point_unit A (chainStageAct A M M' 0) + (chainStageAct_one A M M' 0) (chainSeed A M M' d) + erw [chainBofA, reassoc_of% h] + rfl + +/-- The chain multiplication is left linear over the base, at the +stage typing. -/ +theorem chainMul_actLeft_stage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (m n : ℕ) : + (chainStageAct A M M' m ▷ chainStage A M M' n) ≫ + chainMul A M M' m n = + (α_ A (chainStage A M M' m) (chainStage A M M' n)).hom ≫ + (A ◁ chainMul A M M' m n) ≫ + chainStageAct A M M' (m + 1 + n) := + chainMul_actLeft A M M' m n + +/-- The stage transport commutes with the action. -/ +theorem chainStageCast_actLeft + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + {j k : ℕ} (h : j = k) : + chainStageAct A M M' j ≫ chainStageCast A M M' h = + (A ◁ chainStageCast A M M' h) ≫ chainStageAct A M M' k := by + subst h + simp [chainStageCast_rfl] + +/-- **Insertion maps are linear**: precomposing an action with a +point insertion followed by a linear map is again linear. The +generic-carrier form; the orbit-map linearity is the case of the +action itself. -/ +theorem act_insert_linear [Category.{v} D] [MonoidalCategory D] (A : D) + {X S Z : D} (actX : A ⊗ X ⟶ X) + (actZ : A ⊗ Z ⟶ Z) (s : 𝟙_ D ⟶ S) (m : X ⊗ S ⟶ Z) + (hm : (actX ▷ S) ≫ m = + (α_ A X S).hom ≫ (A ◁ m) ≫ actZ) : + actX ≫ (ρ_ X).inv ≫ (X ◁ s) ≫ m = + (A ◁ ((ρ_ X).inv ≫ (X ◁ s) ≫ m)) ≫ actZ := by + have hnat : ((A ⊗ X) ◁ s) ≫ (α_ A X S).hom = + (α_ A X (𝟙_ D)).hom ≫ (A ◁ (X ◁ s)) := + associator_naturality_right A X s + rw [← Category.assoc, rightUnitor_inv_naturality, Category.assoc, + ← Category.assoc (actX ▷ 𝟙_ D), ← whisker_exchange, + Category.assoc, hm, reassoc_of% hnat, + ← Category.assoc ((ρ_ (A ⊗ X)).inv), + (by monoidal : (ρ_ (A ⊗ X)).inv ≫ (α_ A X (𝟙_ D)).hom = + A ◁ (ρ_ X).inv), + MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + Category.assoc] + +/-- **The chain transition is linear over the base**: it is the +insertion of the seed followed by the multiplication, which is +linear in its first slot. -/ +theorem chainDelta_actLeft + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (k : ℕ) : + chainStageAct A M M' k ≫ chainDelta A M M' d k = + (A ◁ chainDelta A M M' d k) ≫ + chainStageAct A M M' (k + 1) := by + have h := act_insert_linear A (chainStageAct A M M' k) + (chainStageAct A M M' (k + 1 + 0)) (chainSeed A M M' d) + (chainMul A M M' k 0) (chainMul_actLeft_stage A M M' k 0) + exact h + +/-- **The chain multiplication is right linear over the base**: +by commutativity, the second-slot action braids to the front and +the left linearity applies. -/ +theorem chainMul_actRight_stage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (m n : ℕ) : + (chainStage A M M' m ◁ chainStageAct A M M' n) ≫ + chainMul A M M' m n = + (α_ (chainStage A M M' m) A (chainStage A M M' n)).inv ≫ + ((β_ (chainStage A M M' m) A).hom ▷ chainStage A M M' n) ≫ + (α_ A (chainStage A M M' m) (chainStage A M M' n)).hom ≫ + (A ◁ chainMul A M M' m n) ≫ + chainStageAct A M M' (m + 1 + n) := by + have hinv : chainMul A M M' n m ≫ + chainStageCast A M M' (by omega : n + 1 + m = m + 1 + n) = + (β_ (chainStage A M M' n) (chainStage A M M' m)).hom ≫ + chainMul A M M' m n := by + conv_rhs => rw [← chainMul_comm A M M' m n, + SymmetricCategory.braiding_swap_eq_inv_braiding, + Iso.inv_hom_id_assoc] + have hcoh : (β_ (chainStage A M M' m) + (A ⊗ chainStage A M M' n)).hom ≫ + (α_ A (chainStage A M M' n) (chainStage A M M' m)).hom ≫ + (A ◁ (β_ (chainStage A M M' n) + (chainStage A M M' m)).hom) = + (α_ (chainStage A M M' m) A (chainStage A M M' n)).inv ≫ + ((β_ (chainStage A M M' m) A).hom ▷ + chainStage A M M' n) ≫ + (α_ A (chainStage A M M' m) (chainStage A M M' n)).hom := by + rw [BraidedCategory.braiding_tensor_right_hom] + simp only [Category.assoc, Iso.inv_hom_id_assoc, + ← MonoidalCategory.whiskerLeft_comp] + rw [SymmetricCategory.symmetry] + simp + conv_lhs => rw [← chainMul_comm A M M' m n] + rw [BraidedCategory.braiding_naturality_right_assoc, + reassoc_of% (chainMul_actLeft_stage A M M' n m), + chainStageCast_actLeft, + ← MonoidalCategory.whiskerLeft_comp_assoc, hinv, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + reassoc_of% hcoh] + +/-- Point insertion on the right is natural. -/ +theorem insert_point_natural [Category.{v} D] [MonoidalCategory D] + {X Y S : D} (f : X ⟶ Y) + (s : 𝟙_ D ⟶ S) : + f ≫ (ρ_ Y).inv ≫ (Y ◁ s) = + (ρ_ X).inv ≫ (X ◁ s) ≫ (f ▷ S) := by + rw [← Category.assoc, rightUnitor_inv_naturality, + Category.assoc, ← whisker_exchange] + +/-- **The stage multiplication law of the structure morphism**: +multiplying two acted seeds is acting by the product on the +doubled seed. The stage-level core of the algebra-map property. -/ +theorem chainBofA_mul_stage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + (((ρ_ A).inv ≫ (A ◁ chainSeed A M M' d) ≫ + chainStageAct A M M' 0) ⊗ₘ + ((ρ_ A).inv ≫ (A ◁ chainSeed A M M' d) ≫ + chainStageAct A M M' 0)) ≫ chainMul A M M' 0 0 = + μ[A] ≫ (ρ_ A).inv ≫ (A ◁ chainSeed A M M' d) ≫ + chainStageAct A M M' 0 ≫ chainDelta A M M' d 0 := by + conv_rhs => rw [chainDelta_actLeft A M M' d 0, + ← MonoidalCategory.whiskerLeft_comp_assoc, chainDelta, + reassoc_of% (insert_point_natural (chainSeed A M M' d) + (chainSeed A M M' d))] + conv_lhs => rw [MonoidalCategory.tensorHom_def, Category.assoc, + MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + Category.assoc, chainMul_actRight_stage A M M' 0 0] + have hdouble : (A ◁ chainStageAct A M M' (0 + 1 + 0)) ≫ + chainStageAct A M M' (0 + 1 + 0) = + (α_ A A (chainStage A M M' (0 + 1 + 0))).inv ≫ + (μ[A] ▷ chainStage A M M' (0 + 1 + 0)) ≫ + chainStageAct A M M' (0 + 1 + 0) := by + rw [chainStageAct_mul A M M' (0 + 1 + 0), + Iso.inv_hom_id_assoc] + conv_lhs => rw [comp_whiskerRight, comp_whiskerRight, + Category.assoc, Category.assoc, + ← whisker_exchange_assoc (chainStageAct A M M' 0) + ((ρ_ A).inv), + ← whisker_exchange_assoc (chainStageAct A M M' 0) + (A ◁ chainSeed A M M' d), + associator_inv_naturality_left_assoc, + ← comp_whiskerRight_assoc (chainStageAct A M M' 0 ▷ A) + (β_ (chainStage A M M' 0) A).hom, + BraidedCategory.braiding_naturality_left, + comp_whiskerRight, Category.assoc, + associator_naturality_middle_assoc] + conv_lhs => rw [ + ← MonoidalCategory.whiskerLeft_comp_assoc A + (chainStageAct A M M' 0 ▷ chainStage A M M' 0) + (chainMul A M M' 0 0), + chainMul_actLeft_stage A M M' 0 0, + MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + Category.assoc, hdouble] + conv_lhs => rw [ + associator_inv_naturality_right_assoc A A + (chainMul A M M' 0 0), + whisker_exchange_assoc μ[A] (chainMul A M M' 0 0)] + -- Slide the second seed insertion to the tail. + conv_lhs => rw [ + associator_inv_naturality_right_assoc + (A ⊗ chainStage A M M' 0) A (chainSeed A M M' d), + whisker_exchange_assoc + (β_ (A ⊗ chainStage A M M' 0) A).hom (chainSeed A M M' d), + associator_naturality_right_assoc A + (A ⊗ chainStage A M M' 0) (chainSeed A M M' d), + ← MonoidalCategory.whiskerLeft_comp_assoc A + ((A ⊗ chainStage A M M' 0) ◁ chainSeed A M M' d) + (α_ A (chainStage A M M' 0) (chainStage A M M' 0)).hom, + associator_naturality_right A (chainStage A M M' 0) + (chainSeed A M M' d), + MonoidalCategory.whiskerLeft_comp, Category.assoc, + associator_inv_naturality_right_assoc A A + (chainStage A M M' 0 ◁ chainSeed A M M' d), + whisker_exchange_assoc μ[A] + (chainStage A M M' 0 ◁ chainSeed A M M' d)] + -- Slide the first seed insertion to the tail. + conv_lhs => rw [ + ← whisker_exchange_assoc (A ◁ chainSeed A M M' d) + ((ρ_ A).inv), + associator_inv_naturality_left_assoc, + ← comp_whiskerRight_assoc ((A ◁ chainSeed A M M' d) ▷ A) + (β_ (A ⊗ chainStage A M M' 0) A).hom, + BraidedCategory.braiding_naturality_left, + comp_whiskerRight, Category.assoc, + associator_naturality_middle_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc A + ((A ◁ chainSeed A M M' d) ▷ 𝟙_ D) + (α_ A (chainStage A M M' 0) (𝟙_ D)).hom, + associator_naturality_middle, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + associator_inv_naturality_right_assoc A A + (chainSeed A M M' d ▷ 𝟙_ D), + whisker_exchange_assoc μ[A] (chainSeed A M M' d ▷ 𝟙_ D)] + -- Align the seed insertions with the unfolded transition and + -- the arities. + conv_lhs => rw [ + ← MonoidalCategory.whiskerLeft_comp_assoc A + (chainSeed A M M' d ▷ 𝟙_ D) + (chainStage A M M' 0 ◁ chainSeed A M M' d), + ← whisker_exchange (chainSeed A M M' d) (chainSeed A M M' d), + MonoidalCategory.whiskerLeft_comp, Category.assoc, + (show chainStageAct A M M' (0 + 1 + 0) = + chainStageAct A M M' (0 + 1) from rfl)] + -- Expand the right side. + conv_rhs => rw [MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + Category.assoc, Category.assoc] + -- The braiding at the unit-padded slot is the conjugated + -- braiding of the base. + have hβ : (β_ (A ⊗ 𝟙_ D) A).hom = + ((ρ_ A).hom ▷ A) ≫ (β_ A A).hom ≫ (A ◁ (ρ_ A).inv) := by + conv_rhs => rw [← Category.assoc, + BraidedCategory.braiding_naturality_left, Category.assoc, + ← MonoidalCategory.whiskerLeft_comp, Iso.hom_inv_id, + MonoidalCategory.whiskerLeft_id, Category.comp_id] + rw [hβ] + -- Commutativity supplies the crossing on the right. + conv_rhs => rw [(show (μ[A] : A ⊗ A ⟶ A) = + (β_ A A).hom ≫ μ[A] from + (IsCommMonObj.mul_comm A).symm)] + monoidal + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBridge.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBridge.lean new file mode 100644 index 0000000000..af2c61fb76 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBridge.lean @@ -0,0 +1,508 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymDatum + +/-! +# The bridge from the power chain to the splitting chain + +The symmetriser projection carries the power-chain units to the +splitting-chain units. Stagewise, a power stage maps to the +matching splitting-chain stage by swapping the pair into +copairing order and projecting both slots onto the symmetric +powers; this projection carries the seed to the seed and +intertwines the transitions, hence transports every power-chain +unit to the corresponding splitting-chain unit. This is the +wiring that connects the copairing powers of the duality datum +to the stage units that the colimit detection speaks about. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## Interchange coherence in a symmetric category -/ + +section Interchange + +/-- The interchange of the crossed middle pair undoes the +interchange, in a symmetric category. -/ +@[reassoc] +theorem tensorμ_tensorμ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (a b c d : D) : + tensorμ a b c d ≫ tensorμ a c b d = + 𝟙 ((a ⊗ b) ⊗ (c ⊗ d)) := by + calc tensorμ a b c d ≫ tensorμ a c b d + = 𝟙 _ ⊗≫ a ◁ ((β_ b c).hom ≫ (β_ c b).hom) ▷ d ⊗≫ 𝟙 _ := by + dsimp only [tensorμ] + monoidal + _ = 𝟙 ((a ⊗ b) ⊗ (c ⊗ d)) := by + rw [SymmetricCategory.symmetry] + monoidal + +/-- The mirror of `tensorμ_braiding`: interchanging and then +braiding the two blocks equals braiding slotwise and then +interchanging in the exchanged order. -/ +@[reassoc] +theorem tensorμ_braiding_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (a b c d : D) : + tensorμ a b c d ≫ (β_ (a ⊗ c) (b ⊗ d)).hom = + ((β_ a b).hom ⊗ₘ (β_ c d).hom) ≫ tensorμ b a d c := by + have hβ : (β_ (a ⊗ c) (b ⊗ d)).hom = + ((β_ (a ⊗ c) (b ⊗ d)).hom ≫ tensorμ b d a c) ≫ + tensorμ b a d c := by + rw [Category.assoc, tensorμ_tensorμ b d a c, + Category.comp_id] + rw [hβ, tensorμ_braiding a c b d] + simp only [Category.assoc] + rw [tensorμ_tensorμ_assoc a b c d] + +end Interchange + +/-! ## Commutativity of the projected power multiplication -/ + +section SlotComm + +/-- **The projected power multiplication is commutative**: after +the symmetriser projection, multiplying in the braided order and +transporting the arity agrees with multiplying directly. -/ +theorem braid_modPowMul_cast_symPowπ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (X : D) [ModObj A X] + (a b : ℕ) {c : ℕ} + (h : b + a = c) (h' : a + b = c) : + (β_ (modPow A X a) (modPow A X b)).hom ≫ + modPowMul A X b a ≫ modPowCast A X h ≫ symPowπ A X c = + modPowMul A X a b ≫ modPowCast A X h' ≫ symPowπ A X c := by + subst h' + rw [modPowCast_rfl, Category.id_comp, ← symPowπ_cast A X h, + ← symPowπ_tensor_symMul_assoc, + ← BraidedCategory.braiding_naturality_assoc, + reassoc_of% (symMul_comm A X a b)] + simp only [symPowCast, eqToHom_trans, eqToHom_refl, + Category.comp_id] + rw [symPowπ_tensor_symMul] + +end SlotComm + +/-! ## The stage projection -/ + +/-- **The stage projection**: a power stage maps to the matching +splitting-chain stage by swapping the pair into copairing order +and projecting both slots onto the symmetric powers. -/ +noncomputable def projStage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (k : ℕ) : + powStage A M M' k ⟶ chainStage A M M' k := + modTensorSwap A (modPowMod A M.X k) (modPowMod A M'.X k) ≫ + modTensorMap A (symPowπMod A k) (symPowπMod A k) + +/-- The stage projection under the stage projections of the +coequalizers: the braiding of the factors followed by the +symmetriser projections. -/ +theorem modTensorπ_projStage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (k : ℕ) : + modTensorπ A (modPowMod A M.X k) (modPowMod A M'.X k) ≫ + projStage A M M' k = + (β_ (modPow A M.X (k + 1)) (modPow A M'.X (k + 1))).hom ≫ + (symPowπ A M'.X (k + 1) ⊗ₘ symPowπ A M.X (k + 1)) ≫ + modTensorπ A (symPowMod A M'.X k) (symPowMod A M.X k) := by + have h1 : modTensorπ A (modPowMod A M.X k) + (modPowMod A M'.X k) ≫ + modTensorSwap A (modPowMod A M.X k) (modPowMod A M'.X k) ≫ + modTensorMap A (symPowπMod A k) (symPowπMod A k) = + (β_ (modPow A M.X (k + 1)) (modPow A M'.X (k + 1))).hom ≫ + (symPowπ A M'.X (k + 1) ⊗ₘ symPowπ A M.X (k + 1)) ≫ + modTensorπ A (symPowMod A M'.X k) (symPowMod A M.X k) := by + rw [modTensorπ_swap_assoc, modTensorπ_map] + rfl + exact h1 + +/-! ## The zero stages -/ + +/-- The symmetriser projection carries the singleton power stage +of a module to its singleton symmetric-power stage. -/ +theorem toModPowModZero_symPowπMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) : + toModPowModZero A M ≫ symPowπMod A 0 = + toSymPowModZero A M := + Mod.hom_ext _ _ rfl + +/-- **The seed bridge**: the stage projection carries the seed of +the power chain to the seed of the splitting chain. -/ +theorem powSeed_projStage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + powSeed A M M' d ≫ projStage A M M' 0 = + chainSeed A M M' d := by + have h1 : copairUnit A M M' d ≫ + modTensorMap A (toModPowModZero A M) + (toModPowModZero A M') ≫ + modTensorSwap A (modPowMod A M.X 0) (modPowMod A M'.X 0) ≫ + modTensorMap A (symPowπMod A 0) (symPowπMod A 0) = + copairUnit A M M' d ≫ modTensorSwap A M M' ≫ + modTensorMap A (toSymPowModZero A M') + (toSymPowModZero A M) := by + rw [reassoc_of% (modTensorMap_swap A (toModPowModZero A M) + (toModPowModZero A M')), + ← modTensorMap_comp, toModPowModZero_symPowπMod, + toModPowModZero_symPowπMod] + exact (Category.assoc _ _ _).trans h1 + +/-! ## The multiplication bridge -/ + +section MulBridge + +/-- **The multiplication bridge, at the carriers**: the descended +power multiplication followed by the symmetriser projection is +the slotwise projection followed by the descended symmetric +multiplication. -/ +theorem powMulDesc_symPowπ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (m n : ℕ) : + powMulDesc A X m n ≫ symPowπ A X (m + 1 + n + 1) = + modTensorMap A (symPowπMod A m) (symPowπMod A n) ≫ + symMulDesc A X m n := by + apply modTensor_hom_ext + conv_lhs => rw [modTensorπ_powMulDesc_assoc] + conv_rhs => rw [modTensorπ_map_assoc, modTensorπ_symMulDesc] + exact (symPowπ_tensor_symMul A X (m + 1) (n + 1)).symm + +end MulBridge + +/-! ## The transition bridge -/ + +private theorem projStage_mul_leftLift + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) + (k : ℕ) : modTensorπ A (modPowMod A M.X k) + (modPowMod A M.X 0) ≫ + (modTensorSwapMod A (modPowMod A M.X k) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 k ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + k + 1 = k + 2)).hom = + (β_ (modPow A M.X (k + 1)) (modPow A M.X (0 + 1))).hom ≫ + modPowMul A M.X (0 + 1) (k + 1) ≫ + modPowCast A M.X (by omega : 0 + 1 + k + 1 = k + 2) := by + change modTensorπ A (modPowMod A M.X k) (modPowMod A M.X 0) ≫ + modTensorSwap A (modPowMod A M.X k) (modPowMod A M.X 0) ≫ + powMulDesc A M.X 0 k ≫ + modPowCast A M.X (by omega : 0 + 1 + k + 1 = k + 2) = _ + rw [modTensorπ_swap_assoc, modTensorπ_powMulDesc_assoc] + rfl + +/-- **The transition core**: the interchange followed by the +power multiplications and the stage projection is the slotwise +stage projection followed by the chain multiplication. -/ +theorem projStage_mul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (k : ℕ) : + interchange A (modPowMod A M.X k) (modPowMod A M'.X k) + (modPowMod A M.X 0) (modPowMod A M'.X 0) ≫ + modTensorMap A + (modTensorSwapMod A (modPowMod A M.X k) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 k ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + k + 1 = k + 2)) + (powMulMod A M'.X k 0) ≫ + projStage A M M' (k + 1) = + (projStage A M M' k ⊗ₘ projStage A M M' 0) ≫ + chainMul A M M' k 0 := by + have hF := projStage_mul_leftLift A M k + have hG : modTensorπ A (modPowMod A M'.X k) + (modPowMod A M'.X 0) ≫ (powMulMod A M'.X k 0).hom = + modPowMul A M'.X (k + 1) (0 + 1) := by + change modTensorπ A (modPowMod A M'.X k) + (modPowMod A M'.X 0) ≫ powMulDesc A M'.X k 0 = _ + exact modTensorπ_powMulDesc A M'.X k 0 + have hslot : + (β_ (modPow A M.X (k + 1)) (modPow A M.X (0 + 1))).hom ≫ + modPowMul A M.X (0 + 1) (k + 1) ≫ + modPowCast A M.X + (by omega : 0 + 1 + k + 1 = k + 2) ≫ + symPowπ A M.X (k + 2) = + modPowMul A M.X (k + 1) (0 + 1) ≫ + symPowπ A M.X (k + 1 + (0 + 1)) := by + have h1 := braid_modPowMul_cast_symPowπ A M.X (k + 1) (0 + 1) + (by omega : 0 + 1 + (k + 1) = k + 1 + (0 + 1)) + (rfl : k + 1 + (0 + 1) = k + 1 + (0 + 1)) + conv at h1 => rhs; rw [modPowCast_rfl, Category.id_comp] + exact h1 + have h2 : (modTensorπ A (modPowMod A M.X k) + (modPowMod A M'.X k) ⊗ₘ + modTensorπ A (modPowMod A M.X 0) (modPowMod A M'.X 0)) ≫ + (interchange A (modPowMod A M.X k) (modPowMod A M'.X k) + (modPowMod A M.X 0) (modPowMod A M'.X 0) ≫ + modTensorMap A + (modTensorSwapMod A (modPowMod A M.X k) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 k ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + k + 1 = k + 2)) + (powMulMod A M'.X k 0) ≫ + projStage A M M' (k + 1)) = + tensorμ (modPow A M.X (k + 1)) (modPow A M'.X (k + 1)) + (modPow A M.X (0 + 1)) (modPow A M'.X (0 + 1)) ≫ + (((β_ (modPow A M.X (k + 1)) + (modPow A M.X (0 + 1))).hom ≫ + modPowMul A M.X (0 + 1) (k + 1) ≫ + modPowCast A M.X + (by omega : 0 + 1 + k + 1 = k + 2)) ⊗ₘ + modPowMul A M'.X (k + 1) (0 + 1)) ≫ + (β_ (modPow A M.X (k + 2)) (modPow A M'.X (k + 2))).hom ≫ + (symPowπ A M'.X (k + 2) ⊗ₘ symPowπ A M.X (k + 2)) ≫ + modTensorπ A (symPowMod A M'.X (k + 1)) + (symPowMod A M.X (k + 1)) := by + erw [tensorHom_π_interchange_map_assoc, hF, hG, + modTensorπ_projStage A M M' (k + 1)] + rfl + have h3 : tensorμ (modPow A M.X (k + 1)) (modPow A M'.X (k + 1)) + (modPow A M.X (0 + 1)) (modPow A M'.X (0 + 1)) ≫ + (((β_ (modPow A M.X (k + 1)) + (modPow A M.X (0 + 1))).hom ≫ + modPowMul A M.X (0 + 1) (k + 1) ≫ + modPowCast A M.X + (by omega : 0 + 1 + k + 1 = k + 2)) ⊗ₘ + modPowMul A M'.X (k + 1) (0 + 1)) ≫ + (β_ (modPow A M.X (k + 2)) (modPow A M'.X (k + 2))).hom ≫ + (symPowπ A M'.X (k + 2) ⊗ₘ symPowπ A M.X (k + 2)) ≫ + modTensorπ A (symPowMod A M'.X (k + 1)) + (symPowMod A M.X (k + 1)) = + ((β_ (modPow A M.X (k + 1)) (modPow A M'.X (k + 1))).hom ⊗ₘ + (β_ (modPow A M.X (0 + 1)) (modPow A M'.X (0 + 1))).hom) ≫ + tensorμ (modPow A M'.X (k + 1)) (modPow A M.X (k + 1)) + (modPow A M'.X (0 + 1)) (modPow A M.X (0 + 1)) ≫ + ((modPowMul A M'.X (k + 1) (0 + 1) ≫ + symPowπ A M'.X (k + 1 + (0 + 1))) ⊗ₘ + (modPowMul A M.X (k + 1) (0 + 1) ≫ + symPowπ A M.X (k + 1 + (0 + 1)))) ≫ + modTensorπ A (symPowMod A M'.X (k + 1)) + (symPowMod A M.X (k + 1)) := by + erw [BraidedCategory.braiding_naturality_assoc, + tensorμ_braiding_right_assoc, + MonoidalCategory.tensorHom_comp_tensorHom_assoc] + simp only [Category.assoc] + rw [hslot] + have h4a : (modTensorπ A (modPowMod A M.X k) + (modPowMod A M'.X k) ⊗ₘ + modTensorπ A (modPowMod A M.X 0) (modPowMod A M'.X 0)) ≫ + ((projStage A M M' k ⊗ₘ projStage A M M' 0) ≫ + chainMul A M M' k 0) = + (((β_ (modPow A M.X (k + 1)) (modPow A M'.X (k + 1))).hom ≫ + (symPowπ A M'.X (k + 1) ⊗ₘ symPowπ A M.X (k + 1)) ≫ + modTensorπ A (symPowMod A M'.X k) (symPowMod A M.X k)) ⊗ₘ + ((β_ (modPow A M.X (0 + 1)) (modPow A M'.X (0 + 1))).hom ≫ + (symPowπ A M'.X (0 + 1) ⊗ₘ symPowπ A M.X (0 + 1)) ≫ + modTensorπ A (symPowMod A M'.X 0) (symPowMod A M.X 0))) ≫ + chainMul A M M' k 0 := by + erw [MonoidalCategory.tensorHom_comp_tensorHom_assoc, + modTensorπ_projStage A M M' k, + modTensorπ_projStage A M M' 0] + rfl + have h4b : (((β_ (modPow A M.X (k + 1)) + (modPow A M'.X (k + 1))).hom ≫ + (symPowπ A M'.X (k + 1) ⊗ₘ symPowπ A M.X (k + 1)) ≫ + modTensorπ A (symPowMod A M'.X k) (symPowMod A M.X k)) ⊗ₘ + ((β_ (modPow A M.X (0 + 1)) (modPow A M'.X (0 + 1))).hom ≫ + (symPowπ A M'.X (0 + 1) ⊗ₘ symPowπ A M.X (0 + 1)) ≫ + modTensorπ A (symPowMod A M'.X 0) (symPowMod A M.X 0))) ≫ + chainMul A M M' k 0 = + ((β_ (modPow A M.X (k + 1)) (modPow A M'.X (k + 1))).hom ⊗ₘ + (β_ (modPow A M.X (0 + 1)) (modPow A M'.X (0 + 1))).hom) ≫ + tensorμ (modPow A M'.X (k + 1)) (modPow A M.X (k + 1)) + (modPow A M'.X (0 + 1)) (modPow A M.X (0 + 1)) ≫ + ((modPowMul A M'.X (k + 1) (0 + 1) ≫ + symPowπ A M'.X (k + 1 + (0 + 1))) ⊗ₘ + (modPowMul A M.X (k + 1) (0 + 1) ≫ + symPowπ A M.X (k + 1 + (0 + 1)))) ≫ + modTensorπ A (symPowMod A M'.X (k + 1)) + (symPowMod A M.X (k + 1)) := by + have hs : (((β_ (modPow A M.X (k + 1)) + (modPow A M'.X (k + 1))).hom ≫ + (symPowπ A M'.X (k + 1) ⊗ₘ symPowπ A M.X (k + 1)) ≫ + modTensorπ A (symPowMod A M'.X k) + (symPowMod A M.X k)) ⊗ₘ + ((β_ (modPow A M.X (0 + 1)) + (modPow A M'.X (0 + 1))).hom ≫ + (symPowπ A M'.X (0 + 1) ⊗ₘ symPowπ A M.X (0 + 1)) ≫ + modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 0))) ≫ + chainMul A M M' k 0 = + ((β_ (modPow A M.X (k + 1)) (modPow A M'.X (k + 1))).hom ⊗ₘ + (β_ (modPow A M.X (0 + 1)) + (modPow A M'.X (0 + 1))).hom) ≫ + ((symPowπ A M'.X (k + 1) ⊗ₘ symPowπ A M.X (k + 1)) ⊗ₘ + (symPowπ A M'.X (0 + 1) ⊗ₘ symPowπ A M.X (0 + 1))) ≫ + (modTensorπ A (symPowMod A M'.X k) (symPowMod A M.X k) ⊗ₘ + modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 0)) ≫ + chainMul A M M' k 0 := by + erw [← MonoidalCategory.tensorHom_comp_tensorHom_assoc, + ← MonoidalCategory.tensorHom_comp_tensorHom_assoc] + have hmid : ((β_ (modPow A M.X (k + 1)) + (modPow A M'.X (k + 1))).hom ⊗ₘ + (β_ (modPow A M.X (0 + 1)) + (modPow A M'.X (0 + 1))).hom) ≫ + ((symPowπ A M'.X (k + 1) ⊗ₘ symPowπ A M.X (k + 1)) ⊗ₘ + (symPowπ A M'.X (0 + 1) ⊗ₘ symPowπ A M.X (0 + 1))) ≫ + (modTensorπ A (symPowMod A M'.X k) (symPowMod A M.X k) ⊗ₘ + modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 0)) ≫ + chainMul A M M' k 0 = + ((β_ (modPow A M.X (k + 1)) (modPow A M'.X (k + 1))).hom ⊗ₘ + (β_ (modPow A M.X (0 + 1)) + (modPow A M'.X (0 + 1))).hom) ≫ + ((symPowπ A M'.X (k + 1) ⊗ₘ symPowπ A M.X (k + 1)) ⊗ₘ + (symPowπ A M'.X (0 + 1) ⊗ₘ symPowπ A M.X (0 + 1))) ≫ + tensorμ (symPow A M'.X (k + 1)) (symPow A M.X (k + 1)) + (symPow A M'.X (0 + 1)) (symPow A M.X (0 + 1)) ≫ + (symMul A M'.X (k + 1) (0 + 1) ⊗ₘ + symMul A M.X (k + 1) (0 + 1)) ≫ + modTensorπ A (symPowMod A M'.X (k + 1 + 0)) + (symPowMod A M.X (k + 1 + 0)) := + congrArg (CategoryStruct.comp _) + (congrArg (CategoryStruct.comp _) + (tensorHom_π_chainMul A M M' k 0)) + have hend : ((β_ (modPow A M.X (k + 1)) + (modPow A M'.X (k + 1))).hom ⊗ₘ + (β_ (modPow A M.X (0 + 1)) + (modPow A M'.X (0 + 1))).hom) ≫ + ((symPowπ A M'.X (k + 1) ⊗ₘ symPowπ A M.X (k + 1)) ⊗ₘ + (symPowπ A M'.X (0 + 1) ⊗ₘ symPowπ A M.X (0 + 1))) ≫ + tensorμ (symPow A M'.X (k + 1)) (symPow A M.X (k + 1)) + (symPow A M'.X (0 + 1)) (symPow A M.X (0 + 1)) ≫ + (symMul A M'.X (k + 1) (0 + 1) ⊗ₘ + symMul A M.X (k + 1) (0 + 1)) ≫ + modTensorπ A (symPowMod A M'.X (k + 1 + 0)) + (symPowMod A M.X (k + 1 + 0)) = + ((β_ (modPow A M.X (k + 1)) (modPow A M'.X (k + 1))).hom ⊗ₘ + (β_ (modPow A M.X (0 + 1)) + (modPow A M'.X (0 + 1))).hom) ≫ + tensorμ (modPow A M'.X (k + 1)) (modPow A M.X (k + 1)) + (modPow A M'.X (0 + 1)) (modPow A M.X (0 + 1)) ≫ + ((modPowMul A M'.X (k + 1) (0 + 1) ≫ + symPowπ A M'.X (k + 1 + (0 + 1))) ⊗ₘ + (modPowMul A M.X (k + 1) (0 + 1) ≫ + symPowπ A M.X (k + 1 + (0 + 1)))) ≫ + modTensorπ A (symPowMod A M'.X (k + 1)) + (symPowMod A M.X (k + 1)) := by + erw [tensorμ_natural_assoc, + MonoidalCategory.tensorHom_comp_tensorHom_assoc, + symPowπ_tensor_symMul A M'.X (k + 1) (0 + 1), + symPowπ_tensor_symMul A M.X (k + 1) (0 + 1)] + exact (hs.trans hmid).trans hend + refine (cancel_epi + (modTensorπ A (modPowMod A M.X k) (modPowMod A M'.X k) ⊗ₘ + modTensorπ A (modPowMod A M.X 0) + (modPowMod A M'.X 0))).mp ?_ + exact ((h2.trans h3).trans (h4a.trans h4b).symm) + +/-- **The transition bridge**: the stage projection intertwines +the power-chain transition with the splitting-chain +transition. -/ +theorem powDelta_projStage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (k : ℕ) : + powDelta A M M' d k ≫ projStage A M M' (k + 1) = + projStage A M M' k ≫ chainDelta A M M' d k := by + rw [powDelta, chainDelta, ← powSeed_projStage A M M' d, + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + conv_rhs => rw [rightUnitor_inv_naturality_assoc, + ← whisker_exchange_assoc, + ← MonoidalCategory.tensorHom_def_assoc] + exact congrArg (CategoryStruct.comp + (ρ_ (powStage A M M' k)).inv) + (congrArg (CategoryStruct.comp + (powStage A M M' k ◁ powSeed A M M' d)) + (by + erw [Category.assoc] + exact projStage_mul A M M' k)) + +/-! ## The unit bridge -/ + +/-- **The unit bridge**: the stage projection carries every +power-chain unit to the corresponding splitting-chain unit. +Together with the identification of the copairing powers as the +power-chain units, this transports the copair element of the +power datum to the stage units of the splitting chain. -/ +theorem powUnitStage_projStage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (k : ℕ) : + powUnitStage A M M' d k ≫ projStage A M M' k = + chainUnitStage A M M' d k := by + induction k with + | zero => exact powSeed_projStage A M M' d + | succ k ih => + calc powUnitStage A M M' d (k + 1) ≫ + projStage A M M' (k + 1) + = powUnitStage A M M' d k ≫ powDelta A M M' d k ≫ + projStage A M M' (k + 1) := by + rw [← powUnitStage_succ, Category.assoc] + _ = powUnitStage A M M' d k ≫ projStage A M M' k ≫ + chainDelta A M M' d k := by + rw [powDelta_projStage A M M' d k] + _ = chainUnitStage A M M' d (k + 1) := by + rw [← Category.assoc, ih, chainUnitStage_succ] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainDelta.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainDelta.lean new file mode 100644 index 0000000000..81dd9831fe --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainDelta.lean @@ -0,0 +1,177 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMul +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowCopairing + +/-! +# The transitions of the splitting chain + +The copairing of a duality datum seeds the bottom stage of the +splitting chain, and multiplication by the seed is the chain +transition. The stage units ride along the transitions by +construction; their nonvanishing is the pairing side's business. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- Acting across the unit context is acting after the unitor. -/ +theorem powTailAct_zero_lambda + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] : + powTailAct A X 0 ≫ (λ_ X).hom = + (A ◁ (λ_ X).hom) ≫ actLeft A X := by + change actAcross A (𝟙_ D) X ≫ (λ_ X).hom = _ + rw [actAcross] + simp only [Category.assoc] + rw [MonoidalCategory.leftUnitor_naturality] + suffices h : (α_ A (𝟙_ D) X).inv ≫ + ((β_ A (𝟙_ D)).hom ▷ X) ≫ (α_ (𝟙_ D) A X).hom ≫ + (λ_ (A ⊗ X)).hom = A ◁ (λ_ X).hom by + rw [reassoc_of% h] + rw [braiding_tensorUnit_right] + monoidal + +/-- The singleton projection of the module power carries the +descended action to the action of the module. -/ +theorem modPowAct_modPowOne + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] : + modPowAct A X 0 ≫ (modPowOne A X).hom = + (A ◁ (modPowOne A X).hom) ≫ actLeft A X := by + apply modPow_whiskerLeft_hom_ext A X A 1 + have hπ : modPowπ A X 1 ≫ (modPowOne A X).hom = + (λ_ X).hom := by + erw [modPowOne, Iso.trans_hom, ← Category.assoc] + rw [show modPowπ A X 1 ≫ (modPowTriv A X (by omega)).hom = + 𝟙 (tensorPow D X 1) from (modPowTriv A X (by omega)).inv_hom_id] + rw [Category.id_comp] + rw [whiskerLeft_modPowπ_modPowAct_assoc, hπ, + ← MonoidalCategory.whiskerLeft_comp_assoc, hπ, + powTailAct_zero_lambda] + rfl + +/-- The singleton symmetric power carries the descended action to +the action of the module. -/ +theorem symPowAct_symPowOne + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] : + symPowAct A X 0 ≫ (symPowOne A X).hom = + (A ◁ (symPowOne A X).hom) ≫ actLeft A X := by + rw [symPowAct, symPowOne] + change ((A ◁ symPowσ A X 1) ≫ modPowAct A X 0 ≫ + symPowπ A X 1) ≫ symPowσ A X 1 ≫ (modPowOne A X).hom = + (A ◁ (symPowσ A X 1 ≫ (modPowOne A X).hom)) ≫ actLeft A X + rw [MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rw [symPowπ_symPowσ_assoc, symPowIdem_one, Category.id_comp, + modPowAct_modPowOne] + +/-- The inverse of the singleton iso carries the module action to +the descended action. -/ +theorem actLeft_symPowOne_inv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] : + actLeft A X ≫ (symPowOne A X).inv = + (A ◁ (symPowOne A X).inv) ≫ symPowAct A X 0 := by + calc actLeft A X ≫ (symPowOne A X).inv + = (A ◁ (symPowOne A X).inv) ≫ + (A ◁ (symPowOne A X).hom) ≫ actLeft A X ≫ + (symPowOne A X).inv := by + rw [← MonoidalCategory.whiskerLeft_comp_assoc, + Iso.inv_hom_id, MonoidalCategory.whiskerLeft_id, + Category.id_comp] + _ = (A ◁ (symPowOne A X).inv) ≫ symPowAct A X 0 := by + rw [← reassoc_of% (symPowAct_symPowOne A X)] + simp only [Iso.hom_inv_id, Category.comp_id] + +/-- A module maps into the singleton stage of its symmetric-power +tower. -/ +noncomputable def toSymPowModZero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) : + M ⟶ symPowMod A M.X 0 := + Mod.Hom.mk' ((symPowOne A M.X).inv) + (actLeft_symPowOne_inv A M.X) + +/-- **The seed of the splitting chain**: the copairing lands in +the bottom stage. -/ +noncomputable def chainSeed + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + 𝟙_ D ⟶ chainStage A M M' 0 := + copairUnit A M M' d ≫ modTensorSwap A M M' ≫ + modTensorMap A (toSymPowModZero A M') (toSymPowModZero A M) + +/-- **The chain transition**: multiplication by the seed. -/ +noncomputable def chainDelta + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (k : ℕ) : chainStage A M M' k ⟶ chainStage A M M' (k + 1) := + (ρ_ (chainStage A M M' k)).inv ≫ + (chainStage A M M' k ◁ chainSeed A M M' d) ≫ + chainMul A M M' k 0 + +/-- The stage units of the splitting chain. -/ +noncomputable def chainUnitStage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + (k : ℕ) → (𝟙_ D ⟶ chainStage A M M' k) + | 0 => chainSeed A M M' d + | (k + 1) => chainUnitStage A M M' d k ≫ chainDelta A M M' d k + +/-- The stage units ride along the transitions. -/ +theorem chainUnitStage_succ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (k : ℕ) : + chainUnitStage A M M' d k ≫ chainDelta A M M' d k = + chainUnitStage A M M' d (k + 1) := + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns.lean new file mode 100644 index 0000000000..533f7141cc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns.lean @@ -0,0 +1,20 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.SecondSlot + +/-! +# Insertion maps into the splitting-chain stages + +The insertion of a single module letter into a two-index +splitting-chain stage, in the three parts below: the insertions +themselves ([Base.lean](ChainIns/Base.lean)) and the laws they +satisfy against the stage multiplication and the seed transition, +in the first slot ([FirstSlot.lean](ChainIns/FirstSlot.lean)) and +in the second ([SecondSlot.lean](ChainIns/SecondSlot.lean)). +-/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/Base.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/Base.lean new file mode 100644 index 0000000000..4e087d2366 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/Base.lean @@ -0,0 +1,647 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainStage2 + +/-! +# Insertion maps into the splitting-chain stages + +Single-module insertions for the two-index splitting chain: the +module inserts into a symmetric power from the left through the +singleton power and the symmetric multiplication, and this +insertion descends through the module-tensor coequalizer into +either slot of a two-index chain stage. How the descended +insertions meet the stage multiplication and the seed transition is +the subject of [FirstSlot.lean](FirstSlot.lean) and +[SecondSlot.lean](SecondSlot.lean). + +* `symInsL`: the insertion `X ⊗ symPow A X (n + 1) ⟶ + symPow A X (n + 2)`, the symmetric multiplication against the + singleton power. +* `symInsL_actAcross`/`symInsL_actRight`: the insertion is + compatible with the monoid action on the symmetric factor, in the + carried-past left form and in the braided right form. +* `chainInsP`/`chainInsQ`: the descended insertions of the dual + pair's modules into the first and second slots of a two-index + stage, with defining equations `whiskerLeft_π_chainInsP` and + `whiskerLeft_π_chainInsQ`. +* `symInsL_symMul`: the insertion is associative against the + symmetric multiplication, up to the arity transport. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## Insertion into a symmetric power -/ + +section SymIns + +/-- **Left insertion into a symmetric power**: the module enters +through the singleton power and multiplies. -/ +noncomputable def symInsL + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (X : D) [ModObj A X] + (n : ℕ) : + X ⊗ symPow A X (n + 1) ⟶ symPow A X (n + 2) := + ((symPowOne A X).inv ▷ symPow A X (n + 1)) ≫ + symMul A X 1 (n + 1) ≫ + symPowCast A X (by omega : 1 + (n + 1) = n + 2) + +/-- The symmetric-power action passes an arity transport. -/ +theorem symPowAct_symPowCast + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + {m n : ℕ} (h : m + 1 = n + 1) : + symPowAct A X m ≫ symPowCast A X h = + (A ◁ symPowCast A X h) ≫ symPowAct A X n := by + obtain rfl : m = n := by omega + have hc : symPowCast A X h = 𝟙 (symPow A X (m + 1)) := rfl + rw [hc, Category.comp_id, MonoidalCategory.whiskerLeft_id, + Category.id_comp] + +/-- **The insertion is compatible with the action on the symmetric +factor**, in carried-past form: the monoid crosses the inserted +module and acts on the enlarged power. -/ +theorem symInsL_actAcross + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (n : ℕ) : + (braidPast A X (symPow A X (n + 1))).hom ≫ + (X ◁ symPowAct A X n) ≫ symInsL A X n = + (A ◁ symInsL A X n) ≫ symPowAct A X (n + 1) := by + have hmul : (braidPast A (symPow A X 1) + (symPow A X (n + 1))).hom ≫ + (symPow A X 1 ◁ symPowAct A X n) ≫ symMul A X 1 (n + 1) = + (A ◁ symMul A X 1 (n + 1)) ≫ symPowAct A X (1 + n) := + symMul_actRight A X 0 n + have hcast : symPowAct A X (1 + n) ≫ + symPowCast A X (by omega : 1 + (n + 1) = n + 2) = + (A ◁ symPowCast A X (by omega : 1 + (n + 1) = n + 2)) ≫ + symPowAct A X (n + 1) := + symPowAct_symPowCast A X (by omega : 1 + n + 1 = n + 1 + 1) + rw [symInsL] + rw [whisker_exchange_assoc, ← braidPast_natural_context_assoc, + reassoc_of% hmul, hcast] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + +/-- The carried-past compatibility, solved for the action-first +composite. -/ +theorem symInsL_symPowAct + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (n : ℕ) : + (X ◁ symPowAct A X n) ≫ symInsL A X n = + (braidPast A X (symPow A X (n + 1))).inv ≫ + (A ◁ symInsL A X n) ≫ symPowAct A X (n + 1) := by + rw [← symInsL_actAcross A X n, Iso.inv_hom_id_assoc] + +/-- Braiding under a context gathers to the braiding of the tensor +pair. -/ +private theorem whiskerLeft_braiding_braidPast_inv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (P V B : D) : + (P ◁ (β_ V B).hom) ≫ (braidPast B P V).inv = + (α_ P V B).inv ≫ (β_ (P ⊗ V) B).hom := by + rw [← cancel_mono (braidPast B P V).hom] + simp only [Category.assoc, Iso.inv_hom_id, Category.comp_id] + rw [braidPast_hom, BraidedCategory.braiding_tensor_left_hom] + simp only [Category.assoc, Iso.inv_hom_id_assoc, + Iso.hom_inv_id_assoc] + rw [← comp_whiskerRight_assoc, SymmetricCategory.symmetry, + MonoidalCategory.id_whiskerRight, Category.id_comp, + Iso.inv_hom_id, Category.comp_id] + +/-- **The insertion is compatible with the braided right action on +the symmetric factor**: the monoid leaves through the inserted +module and acts on the right of the enlarged power. -/ +theorem symInsL_actRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (n : ℕ) : + (X ◁ actRight A (symPowMod A X n).X) ≫ symInsL A X n = + (α_ X (symPow A X (n + 1)) A).inv ≫ + (symInsL A X n ▷ A) ≫ + actRight A (symPowMod A X (n + 1)).X := by + rw [actRight, actRight, + show actLeft A (symPowMod A X n).X = symPowAct A X n from + rfl, + show actLeft A (symPowMod A X (n + 1)).X = + symPowAct A X (n + 1) from rfl] + change (X ◁ ((β_ (symPow A X (n + 1)) A).hom ≫ + symPowAct A X n)) ≫ symInsL A X n = + (α_ X (symPow A X (n + 1)) A).inv ≫ (symInsL A X n ▷ A) ≫ + (β_ (symPow A X (n + 2)) A).hom ≫ symPowAct A X (n + 1) + rw [BraidedCategory.braiding_naturality_left_assoc, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + symInsL_symPowAct, + reassoc_of% (whiskerLeft_braiding_braidPast_inv + X (symPow A X (n + 1)) A)] + +end SymIns + +/-! ## Structural crossings for the descent conditions -/ + +section Structural + +/-- A middle action slides under an untouched context and past an +insertion into the first factor. -/ +private theorem legN_cross_fst_aux [Category.{v} D] [MonoidalCategory D] + {P S₁ S₂ B T : D} + (f : P ⊗ S₁ ⟶ S₂) (a : B ⊗ T ⟶ T) : + P ◁ ((α_ S₁ B T).hom ≫ (S₁ ◁ a)) ≫ + ((α_ P S₁ T).inv ≫ (f ▷ T)) = + ((α_ P (S₁ ⊗ B) T).inv ≫ + (((α_ P S₁ B).inv ≫ (f ▷ B)) ▷ T)) ≫ + ((α_ S₂ B T).hom ≫ (S₂ ◁ a)) := by + have hcoh : (P ◁ (α_ S₁ B T).hom) ≫ (α_ P S₁ (B ⊗ T)).inv = + (α_ P (S₁ ⊗ B) T).inv ≫ ((α_ P S₁ B).inv ▷ T) ≫ + (α_ (P ⊗ S₁) B T).hom := by + monoidal + simp only [MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [associator_inv_naturality_right_assoc, + whisker_exchange, associator_naturality_left_assoc, + reassoc_of% hcoh] + +/-- A right action on the braided-past factor slides under the +carrying and past an insertion into the second factor. -/ +private theorem legM_cross_snd_aux + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + {P Q B T T' : D} + (g : Q ⊗ B ⟶ Q) (f : P ⊗ T ⟶ T') : + P ◁ (g ▷ T) ≫ + ((α_ P Q T).inv ≫ ((β_ P Q).hom ▷ T) ≫ + (α_ Q P T).hom ≫ (Q ◁ f)) = + ((α_ P (Q ⊗ B) T).inv ≫ ((β_ P (Q ⊗ B)).hom ▷ T) ≫ + (α_ (Q ⊗ B) P T).hom ≫ ((Q ⊗ B) ◁ f)) ≫ + (g ▷ T') := by + rw [associator_inv_naturality_middle_assoc, + ← comp_whiskerRight_assoc, + BraidedCategory.braiding_naturality_right] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [associator_naturality_left_assoc, ← whisker_exchange] + +/-- The carrying isomorphism, inverted and rewritten through the +symmetry. -/ +private theorem braidPast_inv_symm + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (B P T : D) : + (braidPast B P T).inv = + (α_ P B T).inv ≫ ((β_ P B).hom ▷ T) ≫ (α_ B P T).hom := by + rw [← cancel_epi (braidPast B P T).hom, Iso.hom_inv_id, + braidPast_hom] + simp only [Category.assoc, Iso.hom_inv_id_assoc] + rw [← comp_whiskerRight_assoc, SymmetricCategory.symmetry, + MonoidalCategory.id_whiskerRight, Category.id_comp, + Iso.inv_hom_id] + +/-- A middle action crosses an insertion into the second factor +under the carrying of the inserted module. -/ +private theorem legN_cross_snd_aux + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + {P Q B T T' : D} + (a : B ⊗ T ⟶ T) (a' : B ⊗ T' ⟶ T') (f : P ⊗ T ⟶ T') + (hcross : (P ◁ a) ≫ f = + (braidPast B P T).inv ≫ (B ◁ f) ≫ a') : + P ◁ ((α_ Q B T).hom ≫ (Q ◁ a)) ≫ + ((α_ P Q T).inv ≫ ((β_ P Q).hom ▷ T) ≫ + (α_ Q P T).hom ≫ (Q ◁ f)) = + ((α_ P (Q ⊗ B) T).inv ≫ ((β_ P (Q ⊗ B)).hom ▷ T) ≫ + (α_ (Q ⊗ B) P T).hom ≫ ((Q ⊗ B) ◁ f)) ≫ + ((α_ Q B T').hom ≫ (Q ◁ a')) := by + have hcoh : (P ◁ (α_ Q B T).hom) ≫ (α_ P Q (B ⊗ T)).inv ≫ + ((β_ P Q).hom ▷ (B ⊗ T)) ≫ (α_ Q P (B ⊗ T)).hom ≫ + (Q ◁ (braidPast B P T).inv) = + (α_ P (Q ⊗ B) T).inv ≫ ((β_ P (Q ⊗ B)).hom ▷ T) ≫ + (α_ (Q ⊗ B) P T).hom ≫ (α_ Q B (P ⊗ T)).hom := by + rw [braidPast_inv_symm, + BraidedCategory.braiding_tensor_right_hom] + simp only [MonoidalCategory.comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + monoidal + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [associator_inv_naturality_right_assoc, + whisker_exchange_assoc, associator_naturality_right_assoc, + ← MonoidalCategory.whiskerLeft_comp, hcross] + simp only [MonoidalCategory.whiskerLeft_comp] + rw [associator_naturality_right_assoc, reassoc_of% hcoh] + +end Structural + +/-! ## Insertion into the first slot -/ + +section InsP + +/-- The two module-tensor legs agree after the insertion of the +dual module into the first slot: the leg acting on the second +factor slides under the insertion, the leg acting on the first +factor crosses it, and the level-`(p + 1, q)` coequalizer absorbs +both. -/ +theorem chainInsP_cond + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q : ℕ) : + M'.X ◁ modTensorLegM A (symPowMod A M'.X p) + (symPowMod A M.X q) ≫ + ((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M.X (q + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1)) + (symPowMod A M.X q)) = + M'.X ◁ modTensorLegN A (symPowMod A M'.X p) + (symPowMod A M.X q) ≫ + ((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M.X (q + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1)) + (symPowMod A M.X q)) := by + rw [modTensorLegM, modTensorLegN, actRight, + show actLeft A (symPowMod A M'.X p).X = symPowAct A M'.X p + from rfl, + show actLeft A (symPowMod A M.X q).X = symPowAct A M.X q + from rfl] + change M'.X ◁ (((β_ (symPow A M'.X (p + 1)) A).hom ≫ + symPowAct A M'.X p) ▷ symPow A M.X (q + 1)) ≫ + ((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M.X (q + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1)) + (symPowMod A M.X q)) = + M'.X ◁ ((α_ (symPow A M'.X (p + 1)) A + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symPowAct A M.X q)) ≫ + ((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M.X (q + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1)) + (symPowMod A M.X q)) + have hcross : (M'.X ◁ ((β_ (symPow A M'.X (p + 1)) A).hom ≫ + symPowAct A M'.X p)) ≫ symInsL A M'.X p = + (α_ M'.X (symPow A M'.X (p + 1)) A).inv ≫ + (symInsL A M'.X p ▷ A) ≫ + ((β_ (symPow A M'.X (p + 2)) A).hom ≫ + symPowAct A M'.X (p + 1)) := + symInsL_actRight A M'.X p + have hM : M'.X ◁ (((β_ (symPow A M'.X (p + 1)) A).hom ≫ + symPowAct A M'.X p) ▷ symPow A M.X (q + 1)) ≫ + ((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M.X (q + 1))) = + ((α_ M'.X (symPow A M'.X (p + 1) ⊗ A) + (symPow A M.X (q + 1))).inv ≫ + (((α_ M'.X (symPow A M'.X (p + 1)) A).inv ≫ + (symInsL A M'.X p ▷ A)) ▷ symPow A M.X (q + 1))) ≫ + (((β_ (symPow A M'.X (p + 2)) A).hom ≫ + symPowAct A M'.X (p + 1)) ▷ + symPow A M.X (q + 1)) := by + rw [associator_inv_naturality_middle_assoc, + ← comp_whiskerRight, hcross] + simp only [MonoidalCategory.comp_whiskerRight, + Category.assoc] + have hN : M'.X ◁ ((α_ (symPow A M'.X (p + 1)) A + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symPowAct A M.X q)) ≫ + ((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M.X (q + 1))) = + ((α_ M'.X (symPow A M'.X (p + 1) ⊗ A) + (symPow A M.X (q + 1))).inv ≫ + (((α_ M'.X (symPow A M'.X (p + 1)) A).inv ≫ + (symInsL A M'.X p ▷ A)) ▷ symPow A M.X (q + 1))) ≫ + ((α_ (symPow A M'.X (p + 2)) A + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 2) ◁ symPowAct A M.X q)) := + legN_cross_fst_aux (symInsL A M'.X p) (symPowAct A M.X q) + have hcond : (((β_ (symPow A M'.X (p + 2)) A).hom ≫ + symPowAct A M'.X (p + 1)) ▷ symPow A M.X (q + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1)) + (symPowMod A M.X q) = + ((α_ (symPow A M'.X (p + 2)) A + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 2) ◁ symPowAct A M.X q)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1)) + (symPowMod A M.X q) := + modTensor_condition A (symPowMod A M'.X (p + 1)) + (symPowMod A M.X q) + erw [reassoc_of% hM, reassoc_of% hN, hcond] + repeat' erw [Category.assoc] + +/-- **Insertion into the first slot of a two-index stage**: the +dual module enters the first symmetric power, descended through +the module-tensor coequalizer. -/ +noncomputable def chainInsP + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q : ℕ) : + M'.X ⊗ chainStage2 A M M' p q ⟶ + chainStage2 A M M' (p + 1) q := + modTensorWhiskerDesc A (symPowMod A M'.X p) (symPowMod A M.X q) + M'.X + ((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M.X (q + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1)) + (symPowMod A M.X q)) + (chainInsP_cond A M M' p q) + +/-- Defining equation of the first-slot insertion. -/ +@[reassoc] +theorem whiskerLeft_π_chainInsP + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q : ℕ) : + M'.X ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q) ≫ chainInsP A M M' p q = + (α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M.X (q + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1)) + (symPowMod A M.X q) := + whiskerLeft_modTensorπ_whiskerDesc A _ _ M'.X _ _ + +end InsP + +/-! ## Insertion into the second slot -/ + +section InsQ + +/-- The two module-tensor legs agree after the insertion of the +module into the second slot: the module is carried past the first +symmetric power, the leg acting on the first factor slides under +the carrying, the leg acting on the second factor crosses the +insertion, and the level-`(p, q + 1)` coequalizer absorbs both. -/ +theorem chainInsQ_cond + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q : ℕ) : + M.X ◁ modTensorLegM A (symPowMod A M'.X p) + (symPowMod A M.X q) ≫ + ((α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q) ≫ + modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X (q + 1))) = + M.X ◁ modTensorLegN A (symPowMod A M'.X p) + (symPowMod A M.X q) ≫ + ((α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q) ≫ + modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X (q + 1))) := by + rw [modTensorLegM, modTensorLegN, actRight, + show actLeft A (symPowMod A M'.X p).X = symPowAct A M'.X p + from rfl, + show actLeft A (symPowMod A M.X q).X = symPowAct A M.X q + from rfl] + change M.X ◁ (((β_ (symPow A M'.X (p + 1)) A).hom ≫ + symPowAct A M'.X p) ▷ symPow A M.X (q + 1)) ≫ + ((α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q) ≫ + modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X (q + 1))) = + M.X ◁ ((α_ (symPow A M'.X (p + 1)) A + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symPowAct A M.X q)) ≫ + ((α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q) ≫ + modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X (q + 1))) + have hM : M.X ◁ (((β_ (symPow A M'.X (p + 1)) A).hom ≫ + symPowAct A M'.X p) ▷ symPow A M.X (q + 1)) ≫ + ((α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q)) = + ((α_ M.X (symPow A M'.X (p + 1) ⊗ A) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1) ⊗ A)).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1) ⊗ A) M.X + (symPow A M.X (q + 1))).hom ≫ + ((symPow A M'.X (p + 1) ⊗ A) ◁ symInsL A M.X q)) ≫ + (((β_ (symPow A M'.X (p + 1)) A).hom ≫ + symPowAct A M'.X p) ▷ symPow A M.X (q + 2)) := + legM_cross_snd_aux + ((β_ (symPow A M'.X (p + 1)) A).hom ≫ symPowAct A M'.X p) + (symInsL A M.X q) + have hN : M.X ◁ ((α_ (symPow A M'.X (p + 1)) A + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symPowAct A M.X q)) ≫ + ((α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q)) = + ((α_ M.X (symPow A M'.X (p + 1) ⊗ A) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1) ⊗ A)).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1) ⊗ A) M.X + (symPow A M.X (q + 1))).hom ≫ + ((symPow A M'.X (p + 1) ⊗ A) ◁ symInsL A M.X q)) ≫ + ((α_ (symPow A M'.X (p + 1)) A + (symPow A M.X (q + 2))).hom ≫ + (symPow A M'.X (p + 1) ◁ + symPowAct A M.X (q + 1))) := + legN_cross_snd_aux (symPowAct A M.X q) + (symPowAct A M.X (q + 1)) (symInsL A M.X q) + (symInsL_symPowAct A M.X q) + have hcond : (((β_ (symPow A M'.X (p + 1)) A).hom ≫ + symPowAct A M'.X p) ▷ symPow A M.X (q + 2)) ≫ + modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X (q + 1)) = + ((α_ (symPow A M'.X (p + 1)) A + (symPow A M.X (q + 2))).hom ≫ + (symPow A M'.X (p + 1) ◁ symPowAct A M.X (q + 1))) ≫ + modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X (q + 1)) := + modTensor_condition A (symPowMod A M'.X p) + (symPowMod A M.X (q + 1)) + erw [reassoc_of% hM, reassoc_of% hN, hcond] + repeat' erw [Category.assoc] + +/-- **Insertion into the second slot of a two-index stage**: the +module is carried past the first symmetric power and enters the +second, descended through the module-tensor coequalizer. -/ +noncomputable def chainInsQ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q : ℕ) : + M.X ⊗ chainStage2 A M M' p q ⟶ + chainStage2 A M M' p (q + 1) := + modTensorWhiskerDesc A (symPowMod A M'.X p) (symPowMod A M.X q) + M.X + ((α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q) ≫ + modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X (q + 1))) + (chainInsQ_cond A M M' p q) + +/-- Defining equation of the second-slot insertion. -/ +@[reassoc] +theorem whiskerLeft_π_chainInsQ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q : ℕ) : + M.X ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q) ≫ chainInsQ A M M' p q = + (α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q) ≫ + modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X (q + 1)) := + whiskerLeft_modTensorπ_whiskerDesc A _ _ M.X _ _ + +end InsQ + +/-! ## The insertion against the multiplication -/ + +section InsMul + +/-- Arity transports compose. -/ +theorem symPowCast_symPowCast + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] + (A : D) [MonObj A] (X : D) [ModObj A X] + {a b c : ℕ} (h : a = b) + (h' : b = c) : + symPowCast A X h ≫ symPowCast A X h' = + symPowCast A X (h.trans h') := by + subst h h' + have h1 : symPowCast A X (rfl : a = a) = 𝟙 (symPow A X a) := + rfl + rw [h1, Category.id_comp] + +/-- An arity transport of the first factor passes the symmetric +multiplication. -/ +private theorem symMul_cast_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (X : D) [ModObj A X] + {a b : ℕ} (h : a = b) (r : ℕ) : + (symPowCast A X h ▷ symPow A X r) ≫ symMul A X b r = + symMul A X a r ≫ + symPowCast A X (by omega : a + r = b + r) := by + subst h + have h1 : symPowCast A X (rfl : a = a) = 𝟙 (symPow A X a) := + rfl + have h2 : symPowCast A X (by omega : a + r = a + r) = + 𝟙 (symPow A X (a + r)) := rfl + rw [h1, h2, MonoidalCategory.id_whiskerRight, + Category.id_comp, Category.comp_id] + +/-- **The insertion is associative against the multiplication**: +inserting and multiplying is multiplying and inserting into the +product, up to the arity transport. -/ +theorem symInsL_symMul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (X : D) [ModObj A X] + (m n : ℕ) : + (symInsL A X m ▷ symPow A X (n + 1)) ≫ + symMul A X (m + 2) (n + 1) = + (α_ X (symPow A X (m + 1)) (symPow A X (n + 1))).hom ≫ + (X ◁ symMul A X (m + 1) (n + 1)) ≫ + symInsL A X (m + 1 + n) ≫ + symPowCast A X + (by omega : m + 1 + n + 2 = m + 2 + (n + 1)) := by + have hcl : (symPowCast A X + (by omega : 1 + (m + 1) = m + 2) ▷ + symPow A X (n + 1)) ≫ symMul A X (m + 2) (n + 1) = + symMul A X (1 + (m + 1)) (n + 1) ≫ + symPowCast A X + (by omega : 1 + (m + 1) + (n + 1) = m + 2 + (n + 1)) := + symMul_cast_left A X (by omega : 1 + (m + 1) = m + 2) (n + 1) + have hassoc := symMul_assoc A X 1 (m + 1) (n + 1) + rw [symInsL, symInsL] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [hcl, reassoc_of% hassoc, symPowCast_symPowCast, + symPowCast_symPowCast, + associator_naturality_left_assoc, ← whisker_exchange_assoc] + rfl + +end InsMul + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/FirstSlot.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/FirstSlot.lean new file mode 100644 index 0000000000..9c4f0465c0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/FirstSlot.lean @@ -0,0 +1,1271 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.Base + +/-! +# The first-slot insertion against the stage structure + +The insertion of a letter into the first slot of a two-index chain +stage, defined in [Base.lean](Base.lean), meets the two structure +maps of the chain: the stage multiplication and the seed +transition. + +* `chainInsP_mul`: inserting a letter into a merged stage is + inserting into the first factor and multiplying, up to the index + transport. +* `chainInsP_delta2`: the insertion passes the seed transition, + raising the merged arities by one on each side. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## An insertion past the interchange -/ + +section InsPastInterchange + +/-- An insertion into the first factor of the first pair passes +the interchange. -/ +private theorem insL_past_tensorμ [Category.{v} D] [MonoidalCategory D] + [BraidedCategory D] + {X P P₂ Q R S : D} (f : X ⊗ P ⟶ P₂) : + (α_ X (P ⊗ Q) (R ⊗ S)).inv ≫ + (((α_ X P Q).inv ≫ (f ▷ Q)) ⊗ₘ 𝟙 (R ⊗ S)) ≫ + tensorμ P₂ Q R S = + (X ◁ tensorμ P Q R S) ≫ + (α_ X (P ⊗ R) (Q ⊗ S)).inv ≫ + (((α_ X P R).inv ≫ (f ▷ R)) ⊗ₘ 𝟙 (Q ⊗ S)) := by + have hcoh : (α_ X (P ⊗ Q) (R ⊗ S)).inv ≫ + ((α_ X P Q).inv ▷ (R ⊗ S)) ≫ tensorμ (X ⊗ P) Q R S = + (X ◁ tensorμ P Q R S) ≫ + (α_ X (P ⊗ R) (Q ⊗ S)).inv ≫ + ((α_ X P R).inv ▷ (Q ⊗ S)) := by + dsimp only [tensorμ] + monoidal + have hnat := tensorμ_natural_left f (𝟙 Q) R S + simp only [MonoidalCategory.tensorHom_id, + MonoidalCategory.id_whiskerRight] at hnat + simp only [MonoidalCategory.tensorHom_id, + MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [hnat, reassoc_of% hcoh] + +end InsPastInterchange + +/-! ## The insertion against the stage multiplication -/ + +section InsSurgery + +/-- Absorb a whiskered morphism into the first tensor factor. -/ +theorem tensorHom_whiskerRight_absorb [Category.{v} D] [MonoidalCategory D] + {X₁ X₂ Y₁ Y₂ Z₁ W : D} (a : X₁ ⟶ Y₁) (b : X₂ ⟶ Y₂) + (f : Y₁ ⟶ Z₁) (h : Z₁ ⊗ Y₂ ⟶ W) : + (a ⊗ₘ b) ≫ (f ▷ Y₂) ≫ h = ((a ≫ f) ⊗ₘ b) ≫ h := by + rw [← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom_assoc, + Category.comp_id] + +end InsSurgery + +section Ins2Laws + +private theorem chainInsP_mul_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q r s : ℕ) : + (M'.X ◁ + (modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s))) ≫ + ((M'.X ◁ chainMul2 A M M' p q r s) ≫ + chainInsP A M M' (p + 1 + r) (q + 1 + s)) = + (M'.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((M'.X ◁ symMul A M'.X (p + 1) (r + 1)) ≫ + symInsL A M'.X (p + 1 + r)) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r + 1)) + (symPowMod A M.X (q + 1 + s)) := by + have l1 : (M'.X ◁ + (modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s))) ≫ + ((M'.X ◁ chainMul2 A M M' p q r s) ≫ + chainInsP A M M' (p + 1 + r) (q + 1 + s)) = + (M'.X ◁ + ((modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + chainMul2 A M M' p q r s)) ≫ + chainInsP A M M' (p + 1 + r) (q + 1 + s) := by + erw [← Category.assoc, ← MonoidalCategory.whiskerLeft_comp] + have l2 : (M'.X ◁ + ((modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + chainMul2 A M M' p q r s)) ≫ + chainInsP A M M' (p + 1 + r) (q + 1 + s) = + (M'.X ◁ + (tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s)))) ≫ + chainInsP A M M' (p + 1 + r) (q + 1 + s) := + congrArg (fun u : + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) ⊗ + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1)) ⟶ + chainStage2 A M M' (p + 1 + r) (q + 1 + s) => + (M'.X ◁ u) ≫ chainInsP A M M' (p + 1 + r) (q + 1 + s)) + (tensorHom_π_chainMul2 A M M' p q r s) + have l3w1 : M'.X ◁ + (tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s))) = + (M'.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (M'.X ◁ + ((symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s)))) := + MonoidalCategory.whiskerLeft_comp M'.X _ _ + have l3w2 : M'.X ◁ + ((symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s))) = + (M'.X ◁ (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1))) ≫ + (M'.X ◁ modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s))) := + MonoidalCategory.whiskerLeft_comp M'.X _ _ + have l3 : (M'.X ◁ + (tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s)))) ≫ + chainInsP A M M' (p + 1 + r) (q + 1 + s) = + (M'.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (M'.X ◁ (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1))) ≫ + ((M'.X ◁ modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s))) ≫ + chainInsP A M M' (p + 1 + r) (q + 1 + s)) := by + rw [l3w1, l3w2] + repeat' erw [Category.assoc] + have l4 : (M'.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (M'.X ◁ (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1))) ≫ + ((M'.X ◁ modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s))) ≫ + chainInsP A M M' (p + 1 + r) (q + 1 + s)) = + (M'.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (M'.X ◁ (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1))) ≫ + ((α_ M'.X (symPow A M'.X (p + 1 + r + 1)) + (symPow A M.X (q + 1 + s + 1))).inv ≫ + (symInsL A M'.X (p + 1 + r) ▷ + symPow A M.X (q + 1 + s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r + 1)) + (symPowMod A M.X (q + 1 + s))) := + congrArg (fun t : + M'.X ⊗ (symPow A M'.X (p + 1 + r + 1) ⊗ + symPow A M.X (q + 1 + s + 1)) ⟶ + chainStage2 A M M' (p + 1 + r + 1) (q + 1 + s) => + (M'.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (M'.X ◁ (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1))) ≫ t) + (whiskerLeft_π_chainInsP A M M' (p + 1 + r) (q + 1 + s)) + have hα6 : (M'.X ◁ (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1))) ≫ + (α_ M'.X (symPow A M'.X (p + 1 + r + 1)) + (symPow A M.X (q + 1 + s + 1))).inv = + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((M'.X ◁ symMul A M'.X (p + 1) (r + 1)) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) := by + have h := associator_inv_naturality (𝟙 M'.X) + (symMul A M'.X (p + 1) (r + 1)) + (symMul A M.X (q + 1) (s + 1)) + simp only [MonoidalCategory.id_tensorHom] at h + exact h + have l5 : (M'.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (M'.X ◁ (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1))) ≫ + ((α_ M'.X (symPow A M'.X (p + 1 + r + 1)) + (symPow A M.X (q + 1 + s + 1))).inv ≫ + (symInsL A M'.X (p + 1 + r) ▷ + symPow A M.X (q + 1 + s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r + 1)) + (symPowMod A M.X (q + 1 + s))) = + (M'.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((M'.X ◁ symMul A M'.X (p + 1) (r + 1)) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + (symInsL A M'.X (p + 1 + r) ▷ + symPow A M.X (q + 1 + s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r + 1)) + (symPowMod A M.X (q + 1 + s)) := by + rw [reassoc_of% hα6] + have l6 : (M'.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((M'.X ◁ symMul A M'.X (p + 1) (r + 1)) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + (symInsL A M'.X (p + 1 + r) ▷ + symPow A M.X (q + 1 + s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r + 1)) + (symPowMod A M.X (q + 1 + s)) = + (M'.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((M'.X ◁ symMul A M'.X (p + 1) (r + 1)) ≫ + symInsL A M'.X (p + 1 + r)) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r + 1)) + (symPowMod A M.X (q + 1 + s)) := by + erw [← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom_assoc] + exact congrArg (fun t : symPow A M.X (q + 1) ⊗ + symPow A M.X (s + 1) ⟶ symPow A M.X (q + 1 + s + 1) => + (M'.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((M'.X ◁ symMul A M'.X (p + 1) (r + 1)) ≫ + symInsL A M'.X (p + 1 + r)) ⊗ₘ t) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r + 1)) + (symPowMod A M.X (q + 1 + s))) + (Category.comp_id (symMul A M.X (q + 1) (s + 1))) + -- The right leg: cross the inserted module past the + -- interchange and reassemble the same meeting form. + exact l1.trans (l2.trans (l3.trans (l4.trans (l5.trans (l6))))) + +private theorem chainInsP_mul_rightCover + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q r s : ℕ) + (hp₀ : p + 1 + 1 + r = p + 1 + r + 1) + (hq₀ : q + 1 + s = q + 1 + s) : + (M'.X ◁ + (modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s))) ≫ + ((α_ M'.X (chainStage2 A M M' p q) + (chainStage2 A M M' r s)).inv ≫ + (chainInsP A M M' p q ▷ chainStage2 A M M' r s) ≫ + chainMul2 A M M' (p + 1) q r s ≫ + chainStage2Cast A M M' hp₀ hq₀) = + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M.X (q + 1))) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ + tensorμ (symPow A M'.X (p + 1 + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (symMul A M'.X (p + 1 + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + 1 + r)) + (symPowMod A M.X (q + 1 + s)) ≫ + chainStage2Cast A M M' hp₀ hq₀ := by + have hα1 : (M'.X ◁ + (modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s))) ≫ + (α_ M'.X (chainStage2 A M M' p q) + (chainStage2 A M M' r s)).inv = + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((M'.X ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q)) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) := by + have h := associator_inv_naturality (𝟙 M'.X) + (modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q)) + (modTensorπ A (symPowMod A M'.X r) (symPowMod A M.X s)) + simp only [MonoidalCategory.id_tensorHom] at h + exact h + have r1 : (M'.X ◁ + (modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s))) ≫ + ((α_ M'.X (chainStage2 A M M' p q) + (chainStage2 A M M' r s)).inv ≫ + (chainInsP A M M' p q ▷ chainStage2 A M M' r s) ≫ + chainMul2 A M M' (p + 1) q r s ≫ + chainStage2Cast A M M' hp₀ hq₀) = + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((M'.X ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q)) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + (chainInsP A M M' p q ▷ chainStage2 A M M' r s) ≫ + chainMul2 A M M' (p + 1) q r s ≫ + chainStage2Cast A M M' hp₀ hq₀ := + by + have h := congrArg (fun t => t ≫ + ((chainInsP A M M' p q ▷ chainStage2 A M M' r s) ≫ + chainMul2 A M M' (p + 1) q r s ≫ + chainStage2Cast A M M' hp₀ hq₀)) hα1 + conv at h => lhs; erw [Category.assoc] + conv at h => rhs; erw [Category.assoc] + exact h + have r2 : (α_ M'.X + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((M'.X ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q)) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + (chainInsP A M M' p q ▷ chainStage2 A M M' r s) ≫ + chainMul2 A M M' (p + 1) q r s ≫ + chainStage2Cast A M M' hp₀ hq₀ = + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((M'.X ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q)) ≫ chainInsP A M M' p q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + chainMul2 A M M' (p + 1) q r s ≫ + chainStage2Cast A M M' hp₀ hq₀ := + congrArg (fun t : + (M'.X ⊗ (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1))) ⊗ + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1)) ⟶ + chainStage2 A M M' (p + 1 + r + 1) (q + 1 + s) => + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + t) + (tensorHom_whiskerRight_absorb + (M'.X ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q)) + (modTensorπ A (symPowMod A M'.X r) (symPowMod A M.X s)) + (chainInsP A M M' p q) + (chainMul2 A M M' (p + 1) q r s ≫ + chainStage2Cast A M M' hp₀ hq₀)) + have r3 : (α_ M'.X + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((M'.X ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q)) ≫ chainInsP A M M' p q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + chainMul2 A M M' (p + 1) q r s ≫ + chainStage2Cast A M M' hp₀ hq₀ = + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M.X (q + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1)) + (symPowMod A M.X q)) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + chainMul2 A M M' (p + 1) q r s ≫ + chainStage2Cast A M M' hp₀ hq₀ := + congrArg (fun t : + M'.X ⊗ (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) ⟶ + chainStage2 A M M' (p + 1) q => + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (t ⊗ₘ modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + chainMul2 A M M' (p + 1) q r s ≫ + chainStage2Cast A M M' hp₀ hq₀) + (whiskerLeft_π_chainInsP A M M' p q) + have r4 : (α_ M'.X + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M.X (q + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1)) + (symPowMod A M.X q)) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + chainMul2 A M M' (p + 1) q r s ≫ + chainStage2Cast A M M' hp₀ hq₀ = + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M.X (q + 1))) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ + (modTensorπ A (symPowMod A M'.X (p + 1)) + (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + chainMul2 A M M' (p + 1) q r s ≫ + chainStage2Cast A M M' hp₀ hq₀ := by + erw [MonoidalCategory.tensorHom_comp_tensorHom_assoc, + Category.id_comp] + repeat' erw [Category.assoc] + have r5 : (α_ M'.X + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M.X (q + 1))) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ + (modTensorπ A (symPowMod A M'.X (p + 1)) + (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + chainMul2 A M M' (p + 1) q r s ≫ + chainStage2Cast A M M' hp₀ hq₀ = + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M.X (q + 1))) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ + tensorμ (symPow A M'.X (p + 1 + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (symMul A M'.X (p + 1 + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + 1 + r)) + (symPowMod A M.X (q + 1 + s)) ≫ + chainStage2Cast A M M' hp₀ hq₀ := + congrArg (fun t : + (symPow A M'.X (p + 1 + 1) ⊗ symPow A M.X (q + 1)) ⊗ + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1)) ⟶ + chainStage2 A M M' (p + 1 + r + 1) (q + 1 + s) => + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M.X (q + 1))) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ t) + (by + have h := congrArg (fun t => t ≫ chainStage2Cast A M M' hp₀ hq₀) + (tensorHom_π_chainMul2 A M M' (p + 1) q r s) + conv at h => lhs; erw [Category.assoc] + conv at h => rhs; erw [Category.assoc]; arg 2; erw [Category.assoc] + exact h) + exact r1.trans (r2.trans (r3.trans (r4.trans (r5)))) + +private theorem chainInsP_mul_rightInterchange + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q r s : ℕ) + (hp₀ : p + 1 + 1 + r = p + 1 + r + 1) + (hq₀ : q + 1 + s = q + 1 + s) : + (α_ M'.X + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M.X (q + 1))) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ + tensorμ (symPow A M'.X (p + 1 + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (symMul A M'.X (p + 1 + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + 1 + r)) + (symPowMod A M.X (q + 1 + s)) ≫ + chainStage2Cast A M M' hp₀ hq₀ = + (M'.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M'.X (r + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M'.X (r + 1))) ≫ + symMul A M'.X (p + 1 + 1) (r + 1)) ≫ + symPowCast A M'.X (congrArg Nat.succ hp₀)) ⊗ₘ + ((𝟙 (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1)) ≫ + symMul A M.X (q + 1) (s + 1)) ≫ + symPowCast A M.X (congrArg Nat.succ hq₀))) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r + 1)) + (symPowMod A M.X (q + 1 + s)) := by + have hcast : modTensorπ A (symPowMod A M'.X (p + 1 + 1 + r)) + (symPowMod A M.X (q + 1 + s)) ≫ + chainStage2Cast A M M' hp₀ hq₀ = + (symPowCast A M'.X (congrArg Nat.succ hp₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ hq₀)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r + 1)) + (symPowMod A M.X (q + 1 + s)) := + modTensorπ_chainStage2Cast A M M' hp₀ hq₀ + have r6 : (α_ M'.X + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M.X (q + 1))) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ + tensorμ (symPow A M'.X (p + 1 + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (symMul A M'.X (p + 1 + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + 1 + r)) + (symPowMod A M.X (q + 1 + s)) ≫ + chainStage2Cast A M M' hp₀ hq₀ = + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M.X (q + 1))) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ + tensorμ (symPow A M'.X (p + 1 + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (symMul A M'.X (p + 1 + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + (symPowCast A M'.X (congrArg Nat.succ hp₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ hq₀)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r + 1)) + (symPowMod A M.X (q + 1 + s)) := + congrArg (fun t : + symPow A M'.X (p + 1 + 1 + r + 1) ⊗ + symPow A M.X (q + 1 + s + 1) ⟶ + chainStage2 A M M' (p + 1 + r + 1) (q + 1 + s) => + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M.X (q + 1))) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ + tensorμ (symPow A M'.X (p + 1 + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (symMul A M'.X (p + 1 + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ t) + hcast + have hpast : (α_ M'.X + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M.X (q + 1))) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ + tensorμ (symPow A M'.X (p + 1 + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) = + (M'.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M'.X (r + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M'.X (r + 1))) ⊗ₘ + 𝟙 (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))) := + insL_past_tensorμ (symInsL A M'.X p) + have r7 : (α_ M'.X + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M.X (q + 1))) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ + tensorμ (symPow A M'.X (p + 1 + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (symMul A M'.X (p + 1 + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + (symPowCast A M'.X (congrArg Nat.succ hp₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ hq₀)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r + 1)) + (symPowMod A M.X (q + 1 + s)) = + (M'.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M'.X (r + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M'.X (r + 1))) ⊗ₘ + 𝟙 (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))) ≫ + (symMul A M'.X (p + 1 + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + (symPowCast A M'.X (congrArg Nat.succ hp₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ hq₀)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r + 1)) + (symPowMod A M.X (q + 1 + s)) := by + rw [reassoc_of% hpast] + have r8 : (M'.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M'.X (r + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M'.X (r + 1))) ⊗ₘ + 𝟙 (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))) ≫ + (symMul A M'.X (p + 1 + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + (symPowCast A M'.X (congrArg Nat.succ hp₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ hq₀)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r + 1)) + (symPowMod A M.X (q + 1 + s)) = + (M'.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M'.X (r + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M'.X (r + 1))) ≫ + symMul A M'.X (p + 1 + 1) (r + 1)) ≫ + symPowCast A M'.X (congrArg Nat.succ hp₀)) ⊗ₘ + ((𝟙 (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1)) ≫ + symMul A M.X (q + 1) (s + 1)) ≫ + symPowCast A M.X (congrArg Nat.succ hq₀))) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r + 1)) + (symPowMod A M.X (q + 1 + s)) := by + erw [MonoidalCategory.tensorHom_comp_tensorHom_assoc, + MonoidalCategory.tensorHom_comp_tensorHom_assoc] + exact r6.trans (r7.trans (r8)) + +private theorem chainInsP_mul_rightInsertion + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q r s : ℕ) + (hp₀ : p + 1 + 1 + r = p + 1 + r + 1) + (hq₀ : q + 1 + s = q + 1 + s) : + (M'.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M'.X (r + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M'.X (r + 1))) ≫ + symMul A M'.X (p + 1 + 1) (r + 1)) ≫ + symPowCast A M'.X (congrArg Nat.succ hp₀)) ⊗ₘ + ((𝟙 (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1)) ≫ + symMul A M.X (q + 1) (s + 1)) ≫ + symPowCast A M.X (congrArg Nat.succ hq₀))) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r + 1)) + (symPowMod A M.X (q + 1 + s)) = + (M'.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((M'.X ◁ symMul A M'.X (p + 1) (r + 1)) ≫ + symInsL A M'.X (p + 1 + r)) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r + 1)) + (symPowMod A M.X (q + 1 + s)) := by + have h₁ : p + 1 + r + 2 = p + 2 + (r + 1) := by omega + have hcc : symPowCast A M'.X h₁ ≫ + symPowCast A M'.X (congrArg Nat.succ hp₀) = + 𝟙 (symPow A M'.X (p + 1 + r + 2)) := + (symPowCast_symPowCast A M'.X h₁ + (congrArg Nat.succ hp₀)).trans rfl + have hfacL : (((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M'.X (r + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M'.X (r + 1))) ≫ + symMul A M'.X (p + 1 + 1) (r + 1)) ≫ + symPowCast A M'.X (congrArg Nat.succ hp₀) = + (M'.X ◁ symMul A M'.X (p + 1) (r + 1)) ≫ + symInsL A M'.X (p + 1 + r) := by + change (((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M'.X (r + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M'.X (r + 1))) ≫ + symMul A M'.X (p + 2) (r + 1)) ≫ + symPowCast A M'.X (congrArg Nat.succ hp₀) = + (M'.X ◁ symMul A M'.X (p + 1) (r + 1)) ≫ + symInsL A M'.X (p + 1 + r) + simp only [Category.assoc] + rw [reassoc_of% (symInsL_symMul A M'.X p r), + Iso.inv_hom_id_assoc] + exact congrArg (CategoryStruct.comp + (M'.X ◁ symMul A M'.X (p + 1) (r + 1))) + ((congrArg (CategoryStruct.comp + (symInsL A M'.X (p + 1 + r))) hcc).trans + (Category.comp_id _)) + have hfacR : (𝟙 (symPow A M.X (q + 1) ⊗ + symPow A M.X (s + 1)) ≫ + symMul A M.X (q + 1) (s + 1)) ≫ + symPowCast A M.X (congrArg Nat.succ hq₀) = + symMul A M.X (q + 1) (s + 1) := by + rw [Category.id_comp, + show symPowCast A M.X (congrArg Nat.succ hq₀) = + 𝟙 (symPow A M.X (q + 1 + s + 1)) from rfl] + exact Category.comp_id _ + have r9 : (M'.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((((α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M'.X (r + 1))).inv ≫ + (symInsL A M'.X p ▷ symPow A M'.X (r + 1))) ≫ + symMul A M'.X (p + 1 + 1) (r + 1)) ≫ + symPowCast A M'.X (congrArg Nat.succ hp₀)) ⊗ₘ + ((𝟙 (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1)) ≫ + symMul A M.X (q + 1) (s + 1)) ≫ + symPowCast A M.X (congrArg Nat.succ hq₀))) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r + 1)) + (symPowMod A M.X (q + 1 + s)) = + (M'.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M'.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((M'.X ◁ symMul A M'.X (p + 1) (r + 1)) ≫ + symInsL A M'.X (p + 1 + r)) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r + 1)) + (symPowMod A M.X (q + 1 + s)) := + congrArg (fun t : + (M'.X ⊗ (symPow A M'.X (p + 1) ⊗ + symPow A M'.X (r + 1))) ⊗ + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1)) ⟶ + symPow A M'.X (p + 1 + r + 1 + 1) ⊗ + symPow A M.X (q + 1 + s + 1) => + (M'.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M'.X (symPow A M'.X (p + 1) ⊗ + symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + t ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r + 1)) + (symPowMod A M.X (q + 1 + s))) + (congrArg₂ (· ⊗ₘ ·) hfacL hfacR) + exact r9 + +/-- **The insertion passes the stage multiplication**: inserting +a letter into the merged stage is inserting into the first factor +and multiplying, up to the index transport. -/ +theorem chainInsP_mul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q r s : ℕ) : + (M'.X ◁ chainMul2 A M M' p q r s) ≫ + chainInsP A M M' (p + 1 + r) (q + 1 + s) = + (α_ M'.X (chainStage2 A M M' p q) + (chainStage2 A M M' r s)).inv ≫ + (chainInsP A M M' p q ▷ chainStage2 A M M' r s) ≫ + chainMul2 A M M' (p + 1) q r s ≫ + chainStage2Cast A M M' + (by omega : p + 1 + 1 + r = p + 1 + r + 1) + (by omega : q + 1 + s = q + 1 + s) := by + have hp₀ : p + 1 + 1 + r = p + 1 + r + 1 := by omega + have hq₀ : q + 1 + s = q + 1 + s := rfl + refine (cancel_epi (M'.X ◁ + (modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)))).mp ?_ + change (M'.X ◁ + (modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s))) ≫ + ((M'.X ◁ chainMul2 A M M' p q r s) ≫ + chainInsP A M M' (p + 1 + r) (q + 1 + s)) = + (M'.X ◁ + (modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s))) ≫ + ((α_ M'.X (chainStage2 A M M' p q) + (chainStage2 A M M' r s)).inv ≫ + (chainInsP A M M' p q ▷ chainStage2 A M M' r s) ≫ + chainMul2 A M M' (p + 1) q r s ≫ + chainStage2Cast A M M' + (by omega : p + 1 + 1 + r = p + 1 + r + 1) + (by omega : q + 1 + s = q + 1 + s)) + -- The left leg: merge the pair cover into the multiplication, + -- fire its defining equation, and absorb the insertion's + -- defining equation at the merged arity. + have hLeft := + (chainInsP_mul_left A M M' p q r s) + have hRightCover := + (chainInsP_mul_rightCover A M M' p q r s hp₀ hq₀) + have hRightInterchange := + (chainInsP_mul_rightInterchange A M M' p q r s hp₀ hq₀) + have hRightInsertion := + (chainInsP_mul_rightInsertion A M M' p q r s hp₀ hq₀) + exact hLeft.trans (hRightCover.trans (hRightInterchange.trans (hRightInsertion))).symm + +private theorem chainInsP_delta2_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (p q : ℕ) + (hz : p + 1 + 1 + 0 = p + 1 + 0 + 1) + (hz' : q + 1 + 0 = q + 1 + 0) : + (M'.X ◁ chainDelta2 A M M' d p q) ≫ + chainInsP A M M' (p + 1) (q + 1) = + (M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (M'.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + ((α_ M'.X (chainStage2 A M M' p q) + (chainStage2 A M M' 0 0)).inv ≫ + ((chainInsP A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' (p + 1) q 0 0)) := by + have l1 : (M'.X ◁ chainDelta2 A M M' d p q) ≫ + chainInsP A M M' (p + 1) (q + 1) = + (M'.X ◁ ((ρ_ (chainStage2 A M M' p q)).inv ≫ + MonoidalCategory.whiskerLeft (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' p q 0 0)) ≫ + chainInsP A M M' (p + 1) (q + 1) := rfl + have w1 : M'.X ◁ ((ρ_ (chainStage2 A M M' p q)).inv ≫ + MonoidalCategory.whiskerLeft (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' p q 0 0) = + (M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (M'.X ◁ (MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' p q 0 0)) := + MonoidalCategory.whiskerLeft_comp M'.X _ _ + have w2 : M'.X ◁ (MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' p q 0 0) = + (M'.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + (M'.X ◁ chainMul2 A M M' p q 0 0) := + MonoidalCategory.whiskerLeft_comp M'.X _ _ + have l2 : (M'.X ◁ ((ρ_ (chainStage2 A M M' p q)).inv ≫ + MonoidalCategory.whiskerLeft (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' p q 0 0)) ≫ + chainInsP A M M' (p + 1) (q + 1) = + (M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (M'.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + ((M'.X ◁ chainMul2 A M M' p q 0 0) ≫ + chainInsP A M M' (p + 1) (q + 1)) := by + rw [w1, w2] + simp only [Category.assoc] + have l3 : (M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (M'.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + ((M'.X ◁ chainMul2 A M M' p q 0 0) ≫ + chainInsP A M M' (p + 1 + 0) (q + 1 + 0)) = + (M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (M'.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + ((α_ M'.X (chainStage2 A M M' p q) + (chainStage2 A M M' 0 0)).inv ≫ + (chainInsP A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' (p + 1) q 0 0 ≫ + chainStage2Cast A M M' hz hz') := + congrArg (fun t : M'.X ⊗ (chainStage2 A M M' p q ⊗ + chainStage2 A M M' 0 0) ⟶ + chainStage2 A M M' (p + 1 + 0 + 1) (q + 1 + 0) => + (M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (M'.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ≫ t) + (chainInsP_mul A M M' p q 0 0) + have hkill : chainMul2 A M M' (p + 1) q 0 0 ≫ + chainStage2Cast A M M' hz hz' = + chainMul2 A M M' (p + 1) q 0 0 := + (congrArg + (CategoryStruct.comp (chainMul2 A M M' (p + 1) q 0 0)) + (show chainStage2Cast A M M' hz hz' = + 𝟙 (chainStage2 A M M' (p + 1 + 1 + 0) (q + 1 + 0)) from + rfl)).trans (Category.comp_id _) + have l4 : (M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (M'.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + ((α_ M'.X (chainStage2 A M M' p q) + (chainStage2 A M M' 0 0)).inv ≫ + (chainInsP A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' (p + 1) q 0 0 ≫ + chainStage2Cast A M M' hz hz') = + (M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (M'.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + ((α_ M'.X (chainStage2 A M M' p q) + (chainStage2 A M M' 0 0)).inv ≫ + ((chainInsP A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' (p + 1) q 0 0)) := + congrArg (fun t : chainStage2 A M M' (p + 1) q ⊗ + chainStage2 A M M' 0 0 ⟶ + chainStage2 A M M' (p + 1 + 0 + 1) (q + 1 + 0) => + (M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (M'.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ≫ + ((α_ M'.X (chainStage2 A M M' p q) + (chainStage2 A M M' 0 0)).inv ≫ + ((chainInsP A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + t))) + hkill + -- Unitor and seed bookkeeping, as in `chainDelta2_mul_right`. + exact l1.trans (l2.trans (l3.trans (l4))) + +private theorem chainInsP_delta2_seed + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (p q : ℕ) : + (M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (M'.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + ((α_ M'.X (chainStage2 A M M' p q) + (chainStage2 A M M' 0 0)).inv ≫ + ((chainInsP A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' (p + 1) q 0 0)) = + (ρ_ (M'.X ⊗ chainStage2 A M M' p q)).inv ≫ + (MonoidalCategory.whiskerLeft + (M'.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + ((chainInsP A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' (p + 1) q 0 0)) := by + have hseed : (M'.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + (α_ M'.X (chainStage2 A M M' p q) + (chainStage2 A M M' 0 0)).inv = + (α_ M'.X (chainStage2 A M M' p q) (𝟙_ D)).inv ≫ + MonoidalCategory.whiskerLeft + (M'.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) := + associator_inv_naturality_right _ _ _ + have hρ : (M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (α_ M'.X (chainStage2 A M M' p q) (𝟙_ D)).inv = + (ρ_ (M'.X ⊗ chainStage2 A M M' p q)).inv := by + monoidal + have c1 : (M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (M'.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + ((α_ M'.X (chainStage2 A M M' p q) + (chainStage2 A M M' 0 0)).inv ≫ + ((chainInsP A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' (p + 1) q 0 0)) = + (M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (((M'.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + (α_ M'.X (chainStage2 A M M' p q) + (chainStage2 A M M' 0 0)).inv) ≫ + ((chainInsP A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' (p + 1) q 0 0)) := + congrArg + (CategoryStruct.comp + (M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv)) + (Category.assoc _ _ _).symm + have c2 : (M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (((M'.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + (α_ M'.X (chainStage2 A M M' p q) + (chainStage2 A M M' 0 0)).inv) ≫ + ((chainInsP A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' (p + 1) q 0 0)) = + (M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (((α_ M'.X (chainStage2 A M M' p q) (𝟙_ D)).inv ≫ + MonoidalCategory.whiskerLeft + (M'.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ≫ + ((chainInsP A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' (p + 1) q 0 0)) := + congrArg (fun t : M'.X ⊗ (chainStage2 A M M' p q ⊗ 𝟙_ D) ⟶ + (M'.X ⊗ chainStage2 A M M' p q) ⊗ + chainStage2 A M M' 0 0 => + (M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (t ≫ ((chainInsP A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' (p + 1) q 0 0))) + hseed + have c3 : (M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (((α_ M'.X (chainStage2 A M M' p q) (𝟙_ D)).inv ≫ + MonoidalCategory.whiskerLeft + (M'.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ≫ + ((chainInsP A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' (p + 1) q 0 0)) = + (M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + ((α_ M'.X (chainStage2 A M M' p q) (𝟙_ D)).inv ≫ + (MonoidalCategory.whiskerLeft + (M'.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d) ≫ + ((chainInsP A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' (p + 1) q 0 0))) := + congrArg + (CategoryStruct.comp + (M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv)) + (Category.assoc _ _ _) + have c4 : (M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + ((α_ M'.X (chainStage2 A M M' p q) (𝟙_ D)).inv ≫ + (MonoidalCategory.whiskerLeft + (M'.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d) ≫ + ((chainInsP A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' (p + 1) q 0 0))) = + ((M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (α_ M'.X (chainStage2 A M M' p q) (𝟙_ D)).inv) ≫ + (MonoidalCategory.whiskerLeft + (M'.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + ((chainInsP A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' (p + 1) q 0 0)) := + (Category.assoc _ _ _).symm + have c5 : ((M'.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (α_ M'.X (chainStage2 A M M' p q) (𝟙_ D)).inv) ≫ + (MonoidalCategory.whiskerLeft + (M'.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + ((chainInsP A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' (p + 1) q 0 0)) = + (ρ_ (M'.X ⊗ chainStage2 A M M' p q)).inv ≫ + (MonoidalCategory.whiskerLeft + (M'.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + ((chainInsP A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' (p + 1) q 0 0)) := + congrArg (fun t : M'.X ⊗ chainStage2 A M M' p q ⟶ + (M'.X ⊗ chainStage2 A M M' p q) ⊗ 𝟙_ D => + t ≫ (MonoidalCategory.whiskerLeft + (M'.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + ((chainInsP A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' (p + 1) q 0 0))) + hρ + -- The right leg: unfold the transition and slide the insertion + -- past the unitor and the seed. + exact c1.trans (c2.trans (c3.trans (c4.trans (c5)))) + +private theorem chainInsP_delta2_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (p q : ℕ) : + chainInsP A M M' p q ≫ + chainDelta2 A M M' d (p + 1) q = + (ρ_ (M'.X ⊗ chainStage2 A M M' p q)).inv ≫ + (MonoidalCategory.whiskerLeft + (M'.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + ((chainInsP A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' (p + 1) q 0 0)) := by + have hρnat : chainInsP A M M' p q ≫ + (ρ_ (chainStage2 A M M' (p + 1) q)).inv = + (ρ_ (M'.X ⊗ chainStage2 A M M' p q)).inv ≫ + (chainInsP A M M' p q ▷ 𝟙_ D) := + rightUnitor_inv_naturality _ + have hexch : (chainInsP A M M' p q ▷ 𝟙_ D) ≫ + MonoidalCategory.whiskerLeft + (chainStage2 A M M' (p + 1) q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) = + MonoidalCategory.whiskerLeft + (M'.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + (chainInsP A M M' p q ▷ chainStage2 A M M' 0 0) := + (whisker_exchange _ _).symm + have b1 : chainInsP A M M' p q ≫ + chainDelta2 A M M' d (p + 1) q = + chainInsP A M M' p q ≫ + ((ρ_ (chainStage2 A M M' (p + 1) q)).inv ≫ + (MonoidalCategory.whiskerLeft + (chainStage2 A M M' (p + 1) q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' (p + 1) q 0 0)) := rfl + have b2 : chainInsP A M M' p q ≫ + ((ρ_ (chainStage2 A M M' (p + 1) q)).inv ≫ + (MonoidalCategory.whiskerLeft + (chainStage2 A M M' (p + 1) q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' (p + 1) q 0 0)) = + (chainInsP A M M' p q ≫ + (ρ_ (chainStage2 A M M' (p + 1) q)).inv) ≫ + (MonoidalCategory.whiskerLeft + (chainStage2 A M M' (p + 1) q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' (p + 1) q 0 0) := + (Category.assoc _ _ _).symm + have b3 : (chainInsP A M M' p q ≫ + (ρ_ (chainStage2 A M M' (p + 1) q)).inv) ≫ + (MonoidalCategory.whiskerLeft + (chainStage2 A M M' (p + 1) q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' (p + 1) q 0 0) = + ((ρ_ (M'.X ⊗ chainStage2 A M M' p q)).inv ≫ + (chainInsP A M M' p q ▷ 𝟙_ D)) ≫ + (MonoidalCategory.whiskerLeft + (chainStage2 A M M' (p + 1) q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' (p + 1) q 0 0) := + congrArg (fun t : M'.X ⊗ chainStage2 A M M' p q ⟶ + chainStage2 A M M' (p + 1) q ⊗ 𝟙_ D => + t ≫ (MonoidalCategory.whiskerLeft + (chainStage2 A M M' (p + 1) q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' (p + 1) q 0 0)) + hρnat + have b4 : ((ρ_ (M'.X ⊗ chainStage2 A M M' p q)).inv ≫ + (chainInsP A M M' p q ▷ 𝟙_ D)) ≫ + (MonoidalCategory.whiskerLeft + (chainStage2 A M M' (p + 1) q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' (p + 1) q 0 0) = + (ρ_ (M'.X ⊗ chainStage2 A M M' p q)).inv ≫ + ((chainInsP A M M' p q ▷ 𝟙_ D) ≫ + (MonoidalCategory.whiskerLeft + (chainStage2 A M M' (p + 1) q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' (p + 1) q 0 0)) := + Category.assoc _ _ _ + have b5 : (ρ_ (M'.X ⊗ chainStage2 A M M' p q)).inv ≫ + ((chainInsP A M M' p q ▷ 𝟙_ D) ≫ + (MonoidalCategory.whiskerLeft + (chainStage2 A M M' (p + 1) q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' (p + 1) q 0 0)) = + (ρ_ (M'.X ⊗ chainStage2 A M M' p q)).inv ≫ + (((chainInsP A M M' p q ▷ 𝟙_ D) ≫ + MonoidalCategory.whiskerLeft + (chainStage2 A M M' (p + 1) q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + chainMul2 A M M' (p + 1) q 0 0) := + congrArg + (CategoryStruct.comp + (ρ_ (M'.X ⊗ chainStage2 A M M' p q)).inv) + (Category.assoc _ _ _).symm + have b6 : (ρ_ (M'.X ⊗ chainStage2 A M M' p q)).inv ≫ + (((chainInsP A M M' p q ▷ 𝟙_ D) ≫ + MonoidalCategory.whiskerLeft + (chainStage2 A M M' (p + 1) q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + chainMul2 A M M' (p + 1) q 0 0) = + (ρ_ (M'.X ⊗ chainStage2 A M M' p q)).inv ≫ + ((MonoidalCategory.whiskerLeft + (M'.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + (chainInsP A M M' p q ▷ chainStage2 A M M' 0 0)) ≫ + chainMul2 A M M' (p + 1) q 0 0) := + congrArg (fun t : (M'.X ⊗ chainStage2 A M M' p q) ⊗ 𝟙_ D ⟶ + chainStage2 A M M' (p + 1) q ⊗ + chainStage2 A M M' 0 0 => + (ρ_ (M'.X ⊗ chainStage2 A M M' p q)).inv ≫ + (t ≫ chainMul2 A M M' (p + 1) q 0 0)) + hexch + have b7 : (ρ_ (M'.X ⊗ chainStage2 A M M' p q)).inv ≫ + ((MonoidalCategory.whiskerLeft + (M'.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + (chainInsP A M M' p q ▷ chainStage2 A M M' 0 0)) ≫ + chainMul2 A M M' (p + 1) q 0 0) = + (ρ_ (M'.X ⊗ chainStage2 A M M' p q)).inv ≫ + (MonoidalCategory.whiskerLeft + (M'.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + ((chainInsP A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' (p + 1) q 0 0)) := + congrArg + (CategoryStruct.comp + (ρ_ (M'.X ⊗ chainStage2 A M M' p q)).inv) + (Category.assoc _ _ _) + exact b1.trans (b2.trans (b3.trans (b4.trans (b5.trans (b6.trans (b7)))))) + +/-- **The transition square for the first-slot insertion**: the +insertion passes the seed transition, raising the merged arities +by one on each side. -/ +theorem chainInsP_delta2 + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (p q : ℕ) : + (M'.X ◁ chainDelta2 A M M' d p q) ≫ + chainInsP A M M' (p + 1) (q + 1) = + chainInsP A M M' p q ≫ chainDelta2 A M M' d (p + 1) q := by + have hz : p + 1 + 1 + 0 = p + 1 + 0 + 1 := by omega + have hz' : q + 1 + 0 = q + 1 + 0 := rfl + -- The left leg: unfold the transition, distribute the whisker, + -- pass the insertion through the stage multiplication, and + -- absorb the trivial index transport. + have hLeft := + (chainInsP_delta2_left A M M' d p q hz hz') + have hSeed := + (chainInsP_delta2_seed A M M' d p q) + have hRight := + (chainInsP_delta2_right A M M' d p q) + exact (hLeft.trans (hSeed)).trans hRight.symm + +end Ins2Laws + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/SecondSlot.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/SecondSlot.lean new file mode 100644 index 0000000000..7252509beb --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/SecondSlot.lean @@ -0,0 +1,1592 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.FirstSlot + +/-! +# The second-slot insertion against the stage structure + +The mirror of [FirstSlot.lean](FirstSlot.lean) for the insertion +into the second slot of a two-index chain stage: the letter is +carried past the first slot by the braiding, so the crossings the +proofs need are established first. + +* `chainInsQ_mul`: inserting a letter into a merged stage is + inserting into the first factor's second slot and multiplying, up + to the index transport. +* `chainInsQ_delta2`: the insertion passes the seed transition, + raising the merged arities by one on each side. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## Braided crossings for the second-slot insertion -/ + +section InsQCross + +/-- A tensor pair passes the carried crossing of a letter: the +crossing is natural in the context and in the tail at once. -/ +private theorem whiskerLeft_tensorHom_cross + [Category.{v} D] [MonoidalCategory D] + [BraidedCategory D] + (X : D) {B B' T T' : D} (f : B ⟶ B') (g : T ⟶ T') : + (X ◁ (f ⊗ₘ g)) ≫ (α_ X B' T').inv ≫ + ((β_ X B').hom ▷ T') ≫ (α_ B' X T').hom = + (α_ X B T).inv ≫ ((β_ X B).hom ▷ T) ≫ (α_ B X T).hom ≫ + (f ⊗ₘ (X ◁ g)) := by + have h : (X ◁ (f ⊗ₘ g)) ≫ (braidPast X B' T').hom = + (braidPast X B T).hom ≫ (f ⊗ₘ (X ◁ g)) := by + rw [tensorHom_def f g, tensorHom_def f (X ◁ g)] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [braidPast_natural_tail, braidPast_natural_context_assoc] + simpa only [braidPast_hom, Category.assoc] using h + +/-- The carried crossing of a letter into the second slot of the +first pair passes the interchange: crossing then interchanging is +interchanging then crossing the merged context. -/ +private theorem cross_past_tensorμ [Category.{v} D] [MonoidalCategory D] + [BraidedCategory D] + (X P Q R S : D) : + (α_ X (P ⊗ Q) (R ⊗ S)).inv ≫ + ((α_ X P Q).inv ▷ (R ⊗ S)) ≫ + (((β_ X P).hom ▷ Q) ▷ (R ⊗ S)) ≫ + ((α_ P X Q).hom ▷ (R ⊗ S)) ≫ + tensorμ P (X ⊗ Q) R S = + (X ◁ tensorμ P Q R S) ≫ + (α_ X (P ⊗ R) (Q ⊗ S)).inv ≫ + ((β_ X (P ⊗ R)).hom ▷ (Q ⊗ S)) ≫ + (α_ (P ⊗ R) X (Q ⊗ S)).hom ≫ + ((P ⊗ R) ◁ (α_ X Q S).inv) := by + have hgather : ((α_ X P Q).inv ▷ (R ⊗ S)) ≫ + (((β_ X P).hom ▷ Q) ▷ (R ⊗ S)) ≫ + ((α_ P X Q).hom ▷ (R ⊗ S)) = + (braidPast X P Q).hom ▷ (R ⊗ S) := by + simp only [braidPast_hom, + MonoidalCategory.comp_whiskerRight] + have hμ₁ : tensorμ P (X ⊗ Q) R S = + (α_ P (X ⊗ Q) (R ⊗ S)).hom ≫ + (P ◁ (braidPast (X ⊗ Q) R S).hom) ≫ + (α_ P R ((X ⊗ Q) ⊗ S)).inv := by + dsimp only [tensorμ] + rw [braidPast_hom] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + have hμ₂ : tensorμ P Q R S = + (α_ P Q (R ⊗ S)).hom ≫ (P ◁ (braidPast Q R S).hom) ≫ + (α_ P R (Q ⊗ S)).inv := by + dsimp only [tensorμ] + rw [braidPast_hom] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + have hfirst : (braidPast (X ⊗ Q) R S).hom = + (α_ X Q (R ⊗ S)).hom ≫ (X ◁ (braidPast Q R S).hom) ≫ + (braidPast X R (Q ⊗ S)).hom ≫ (R ◁ (α_ X Q S).inv) := by + rw [braidPast_hom] + exact braidPast_tensor_first X Q R S + have hctx : (α_ X (P ⊗ R) (Q ⊗ S)).inv ≫ + ((β_ X (P ⊗ R)).hom ▷ (Q ⊗ S)) ≫ + (α_ (P ⊗ R) X (Q ⊗ S)).hom = + (X ◁ (α_ P R (Q ⊗ S)).hom) ≫ + (braidPast X P (R ⊗ Q ⊗ S)).hom ≫ + (P ◁ (braidPast X R (Q ⊗ S)).hom) ≫ + (α_ P R (X ⊗ Q ⊗ S)).inv := by + rw [← cancel_mono (α_ P R (X ⊗ Q ⊗ S)).hom] + simp only [Category.assoc, Iso.inv_hom_id, Category.comp_id] + exact braidPast_tensor_context X P R (Q ⊗ S) + have hhead : (α_ X (P ⊗ Q) (R ⊗ S)).inv ≫ + ((braidPast X P Q).hom ▷ (R ⊗ S)) ≫ + (α_ P (X ⊗ Q) (R ⊗ S)).hom ≫ + (P ◁ (α_ X Q (R ⊗ S)).hom) = + (X ◁ (α_ P Q (R ⊗ S)).hom) ≫ + (braidPast X P (Q ⊗ R ⊗ S)).hom := by + simp only [braidPast_hom, MonoidalCategory.comp_whiskerRight, + Category.assoc] + monoidal + have htail : (P ◁ (R ◁ (α_ X Q S).inv)) ≫ + (α_ P R ((X ⊗ Q) ⊗ S)).inv = + (α_ P R (X ⊗ Q ⊗ S)).inv ≫ ((P ⊗ R) ◁ (α_ X Q S).inv) := + associator_inv_naturality_right P R (α_ X Q S).inv + rw [reassoc_of% hgather, hμ₁, hfirst, hμ₂] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [reassoc_of% hhead, ← braidPast_natural_tail_assoc, htail, + reassoc_of% hctx, whiskerLeft_inv_hom_assoc] + +/-- An insertion into the first factor of the second pair, reached +by carrying the letter across the first factor, passes the +interchange. -/ +private theorem crossIns_past_tensorμ [Category.{v} D] [MonoidalCategory D] + [BraidedCategory D] + {X P Q Q₂ R S : D} (f : X ⊗ Q ⟶ Q₂) : + (α_ X (P ⊗ Q) (R ⊗ S)).inv ≫ + (((α_ X P Q).inv ≫ ((β_ X P).hom ▷ Q) ≫ + (α_ P X Q).hom ≫ (P ◁ f)) ⊗ₘ 𝟙 (R ⊗ S)) ≫ + tensorμ P Q₂ R S = + (X ◁ tensorμ P Q R S) ≫ + (α_ X (P ⊗ R) (Q ⊗ S)).inv ≫ + ((β_ X (P ⊗ R)).hom ▷ (Q ⊗ S)) ≫ + (α_ (P ⊗ R) X (Q ⊗ S)).hom ≫ + (𝟙 (P ⊗ R) ⊗ₘ ((α_ X Q S).inv ≫ (f ▷ S))) := by + have hnat := tensorμ_natural_left (𝟙 P) f R S + simp only [MonoidalCategory.id_tensorHom, + MonoidalCategory.id_whiskerRight] at hnat + simp only [MonoidalCategory.tensorHom_id, + MonoidalCategory.id_tensorHom, + MonoidalCategory.comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [hnat, reassoc_of% (cross_past_tensorμ X P Q R S)] + +end InsQCross + +section InsQSurgery + +/-- Absorb a whiskered morphism into the second tensor factor. -/ +private theorem tensorHom_whiskerLeft_absorb + [Category.{v} D] [MonoidalCategory D] + {X₁ X₂ Y₁ Y₂ Z₂ W : D} (a : X₁ ⟶ Y₁) (b : X₂ ⟶ Y₂) + (g : Y₂ ⟶ Z₂) (h : Y₁ ⊗ Z₂ ⟶ W) : + (a ⊗ₘ b) ≫ (Y₁ ◁ g) ≫ h = (a ⊗ₘ (b ≫ g)) ≫ h := by + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom_assoc, + Category.comp_id] + +end InsQSurgery + +section InsQ2Laws + +private theorem chainInsQ_mul_leftCover + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q r s : ℕ) : + (M.X ◁ + (modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s))) ≫ + ((M.X ◁ chainMul2 A M M' p q r s) ≫ + chainInsQ A M M' (p + 1 + r) (q + 1 + s)) = + (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (M.X ◁ (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1))) ≫ + ((α_ M.X (symPow A M'.X (p + 1 + r + 1)) + (symPow A M.X (q + 1 + s + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1 + r + 1))).hom ▷ + symPow A M.X (q + 1 + s + 1)) ≫ + (α_ (symPow A M'.X (p + 1 + r + 1)) M.X + (symPow A M.X (q + 1 + s + 1))).hom ≫ + (symPow A M'.X (p + 1 + r + 1) ◁ + symInsL A M.X (q + 1 + s)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1))) := by + have l1 : (M.X ◁ + (modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s))) ≫ + ((M.X ◁ chainMul2 A M M' p q r s) ≫ + chainInsQ A M M' (p + 1 + r) (q + 1 + s)) = + (M.X ◁ + ((modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + chainMul2 A M M' p q r s)) ≫ + chainInsQ A M M' (p + 1 + r) (q + 1 + s) := by + erw [← Category.assoc, ← MonoidalCategory.whiskerLeft_comp] + have l2 : (M.X ◁ + ((modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + chainMul2 A M M' p q r s)) ≫ + chainInsQ A M M' (p + 1 + r) (q + 1 + s) = + (M.X ◁ + (tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s)))) ≫ + chainInsQ A M M' (p + 1 + r) (q + 1 + s) := + congrArg (fun u : + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) ⊗ + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1)) ⟶ + chainStage2 A M M' (p + 1 + r) (q + 1 + s) => + (M.X ◁ u) ≫ chainInsQ A M M' (p + 1 + r) (q + 1 + s)) + (tensorHom_π_chainMul2 A M M' p q r s) + have l3w1 : M.X ◁ + (tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s))) = + (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (M.X ◁ + ((symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s)))) := + MonoidalCategory.whiskerLeft_comp M.X _ _ + have l3w2 : M.X ◁ + ((symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s))) = + (M.X ◁ (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1))) ≫ + (M.X ◁ modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s))) := + MonoidalCategory.whiskerLeft_comp M.X _ _ + have l3 : (M.X ◁ + (tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s)))) ≫ + chainInsQ A M M' (p + 1 + r) (q + 1 + s) = + (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (M.X ◁ (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1))) ≫ + ((M.X ◁ modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s))) ≫ + chainInsQ A M M' (p + 1 + r) (q + 1 + s)) := by + rw [l3w1, l3w2] + repeat' erw [Category.assoc] + have l4 : (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (M.X ◁ (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1))) ≫ + ((M.X ◁ modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s))) ≫ + chainInsQ A M M' (p + 1 + r) (q + 1 + s)) = + (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (M.X ◁ (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1))) ≫ + ((α_ M.X (symPow A M'.X (p + 1 + r + 1)) + (symPow A M.X (q + 1 + s + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1 + r + 1))).hom ▷ + symPow A M.X (q + 1 + s + 1)) ≫ + (α_ (symPow A M'.X (p + 1 + r + 1)) M.X + (symPow A M.X (q + 1 + s + 1))).hom ≫ + (symPow A M'.X (p + 1 + r + 1) ◁ + symInsL A M.X (q + 1 + s)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1))) := + congrArg (fun t : + M.X ⊗ (symPow A M'.X (p + 1 + r + 1) ⊗ + symPow A M.X (q + 1 + s + 1)) ⟶ + chainStage2 A M M' (p + 1 + r) (q + 1 + s + 1) => + (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (M.X ◁ (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1))) ≫ t) + (whiskerLeft_π_chainInsQ A M M' (p + 1 + r) (q + 1 + s)) + exact l1.trans (l2.trans (l3.trans (l4))) + +private theorem chainInsQ_mul_leftInsertion + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q r s : ℕ) : + (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (M.X ◁ (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1))) ≫ + ((α_ M.X (symPow A M'.X (p + 1 + r + 1)) + (symPow A M.X (q + 1 + s + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1 + r + 1))).hom ▷ + symPow A M.X (q + 1 + s + 1)) ≫ + (α_ (symPow A M'.X (p + 1 + r + 1)) M.X + (symPow A M.X (q + 1 + s + 1))).hom ≫ + (symPow A M'.X (p + 1 + r + 1) ◁ + symInsL A M.X (q + 1 + s)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1))) = + (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1) ⊗ + symPow A M'.X (r + 1))).hom ▷ + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))) ≫ + (α_ (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) M.X + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + ((M.X ◁ symMul A M.X (q + 1) (s + 1)) ≫ + symInsL A M.X (q + 1 + s))) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1)) := by + have hβ6 : (M.X ◁ (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1))) ≫ + (α_ M.X (symPow A M'.X (p + 1 + r + 1)) + (symPow A M.X (q + 1 + s + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1 + r + 1))).hom ▷ + symPow A M.X (q + 1 + s + 1)) ≫ + (α_ (symPow A M'.X (p + 1 + r + 1)) M.X + (symPow A M.X (q + 1 + s + 1))).hom = + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1) ⊗ + symPow A M'.X (r + 1))).hom ▷ + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))) ≫ + (α_ (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) M.X + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + (M.X ◁ symMul A M.X (q + 1) (s + 1))) := + whiskerLeft_tensorHom_cross M.X _ _ + have l5 : (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (M.X ◁ (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1))) ≫ + ((α_ M.X (symPow A M'.X (p + 1 + r + 1)) + (symPow A M.X (q + 1 + s + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1 + r + 1))).hom ▷ + symPow A M.X (q + 1 + s + 1)) ≫ + (α_ (symPow A M'.X (p + 1 + r + 1)) M.X + (symPow A M.X (q + 1 + s + 1))).hom ≫ + (symPow A M'.X (p + 1 + r + 1) ◁ + symInsL A M.X (q + 1 + s)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1))) = + (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1) ⊗ + symPow A M'.X (r + 1))).hom ▷ + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))) ≫ + (α_ (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) M.X + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + (M.X ◁ symMul A M.X (q + 1) (s + 1))) ≫ + (symPow A M'.X (p + 1 + r + 1) ◁ + symInsL A M.X (q + 1 + s)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1)) := by + rw [reassoc_of% hβ6] + have l6 : (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1) ⊗ + symPow A M'.X (r + 1))).hom ▷ + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))) ≫ + (α_ (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) M.X + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + (M.X ◁ symMul A M.X (q + 1) (s + 1))) ≫ + (symPow A M'.X (p + 1 + r + 1) ◁ + symInsL A M.X (q + 1 + s)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1)) = + (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1) ⊗ + symPow A M'.X (r + 1))).hom ▷ + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))) ≫ + (α_ (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) M.X + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + ((M.X ◁ symMul A M.X (q + 1) (s + 1)) ≫ + symInsL A M.X (q + 1 + s))) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1)) := + congrArg (fun t : + (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) ⊗ + (M.X ⊗ (symPow A M.X (q + 1) ⊗ + symPow A M.X (s + 1))) ⟶ + chainStage2 A M M' (p + 1 + r) (q + 1 + s + 1) => + (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1) ⊗ + symPow A M'.X (r + 1))).hom ▷ + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))) ≫ + (α_ (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) M.X + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + t) + (tensorHom_whiskerLeft_absorb + (symMul A M'.X (p + 1) (r + 1)) + (M.X ◁ symMul A M.X (q + 1) (s + 1)) + (symInsL A M.X (q + 1 + s)) + (modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1)))) + -- The right leg: cross the inserted module past the + -- interchange and reassemble the same meeting form. + exact l5.trans (l6) + +private theorem chainInsQ_mul_rightCover + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q r s : ℕ) + (hp₀ : p + 1 + r = p + 1 + r) + (hq₀ : q + 1 + 1 + s = q + 1 + s + 1) : + (M.X ◁ + (modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s))) ≫ + ((α_ M.X (chainStage2 A M M' p q) + (chainStage2 A M M' r s)).inv ≫ + (chainInsQ A M M' p q ▷ chainStage2 A M M' r s) ≫ + chainMul2 A M M' p (q + 1) r s ≫ + chainStage2Cast A M M' hp₀ hq₀) = + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q)) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ + (modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X (q + 1)) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + chainMul2 A M M' p (q + 1) r s ≫ + chainStage2Cast A M M' hp₀ hq₀ := by + have hα1 : (M.X ◁ + (modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s))) ≫ + (α_ M.X (chainStage2 A M M' p q) + (chainStage2 A M M' r s)).inv = + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((M.X ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q)) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) := by + have h := associator_inv_naturality (𝟙 M.X) + (modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q)) + (modTensorπ A (symPowMod A M'.X r) (symPowMod A M.X s)) + simp only [MonoidalCategory.id_tensorHom] at h + exact h + have r1 : (M.X ◁ + (modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s))) ≫ + ((α_ M.X (chainStage2 A M M' p q) + (chainStage2 A M M' r s)).inv ≫ + (chainInsQ A M M' p q ▷ chainStage2 A M M' r s) ≫ + chainMul2 A M M' p (q + 1) r s ≫ + chainStage2Cast A M M' hp₀ hq₀) = + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((M.X ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q)) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + (chainInsQ A M M' p q ▷ chainStage2 A M M' r s) ≫ + chainMul2 A M M' p (q + 1) r s ≫ + chainStage2Cast A M M' hp₀ hq₀ := + by + have h := congrArg (fun t => t ≫ + ((chainInsQ A M M' p q ▷ chainStage2 A M M' r s) ≫ + chainMul2 A M M' p (q + 1) r s ≫ + chainStage2Cast A M M' hp₀ hq₀)) hα1 + conv at h => lhs; erw [Category.assoc] + conv at h => rhs; erw [Category.assoc] + exact h + have r2 : (α_ M.X + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((M.X ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q)) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + (chainInsQ A M M' p q ▷ chainStage2 A M M' r s) ≫ + chainMul2 A M M' p (q + 1) r s ≫ + chainStage2Cast A M M' hp₀ hq₀ = + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((M.X ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q)) ≫ chainInsQ A M M' p q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + chainMul2 A M M' p (q + 1) r s ≫ + chainStage2Cast A M M' hp₀ hq₀ := + congrArg (fun t : + (M.X ⊗ (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1))) ⊗ + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1)) ⟶ + chainStage2 A M M' (p + 1 + r) (q + 1 + s + 1) => + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + t) + (tensorHom_whiskerRight_absorb + (M.X ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q)) + (modTensorπ A (symPowMod A M'.X r) (symPowMod A M.X s)) + (chainInsQ A M M' p q) + (chainMul2 A M M' p (q + 1) r s ≫ + chainStage2Cast A M M' hp₀ hq₀)) + have r3 : (α_ M.X + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((M.X ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q)) ≫ chainInsQ A M M' p q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + chainMul2 A M M' p (q + 1) r s ≫ + chainStage2Cast A M M' hp₀ hq₀ = + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q) ≫ + modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X (q + 1))) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + chainMul2 A M M' p (q + 1) r s ≫ + chainStage2Cast A M M' hp₀ hq₀ := + congrArg (fun t : + M.X ⊗ (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) ⟶ + chainStage2 A M M' p (q + 1) => + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (t ⊗ₘ modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + chainMul2 A M M' p (q + 1) r s ≫ + chainStage2Cast A M M' hp₀ hq₀) + (whiskerLeft_π_chainInsQ A M M' p q) + have r4 : (α_ M.X + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q) ≫ + modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X (q + 1))) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + chainMul2 A M M' p (q + 1) r s ≫ + chainStage2Cast A M M' hp₀ hq₀ = + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q)) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ + (modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X (q + 1)) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + chainMul2 A M M' p (q + 1) r s ≫ + chainStage2Cast A M M' hp₀ hq₀ := by + erw [MonoidalCategory.tensorHom_comp_tensorHom_assoc, + Category.id_comp] + repeat' erw [Category.assoc] + exact r1.trans (r2.trans (r3.trans (r4))) + +private theorem chainInsQ_mul_rightProjection + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q r s : ℕ) + (hp₀ : p + 1 + r = p + 1 + r) + (hq₀ : q + 1 + 1 + s = q + 1 + s + 1) : + (α_ M.X + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q)) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ + (modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X (q + 1)) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + chainMul2 A M M' p (q + 1) r s ≫ + chainStage2Cast A M M' hp₀ hq₀ = + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q)) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ + tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1 + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1 + 1) (s + 1)) ≫ + (symPowCast A M'.X (congrArg Nat.succ hp₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ hq₀)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1)) := by + have r5 : (α_ M.X + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q)) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ + (modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X (q + 1)) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + chainMul2 A M M' p (q + 1) r s ≫ + chainStage2Cast A M M' hp₀ hq₀ = + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q)) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ + tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1 + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1 + 1) (s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + 1 + s)) ≫ + chainStage2Cast A M M' hp₀ hq₀ := + congrArg (fun t : + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1 + 1)) ⊗ + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1)) ⟶ + chainStage2 A M M' (p + 1 + r) (q + 1 + s + 1) => + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q)) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ t) + (by + have h := congrArg (fun t => t ≫ chainStage2Cast A M M' hp₀ hq₀) + (tensorHom_π_chainMul2 A M M' p (q + 1) r s) + conv at h => lhs; erw [Category.assoc] + conv at h => rhs; erw [Category.assoc]; arg 2; erw [Category.assoc] + exact h) + have hcast : modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + 1 + s)) ≫ + chainStage2Cast A M M' hp₀ hq₀ = + (symPowCast A M'.X (congrArg Nat.succ hp₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ hq₀)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1)) := + modTensorπ_chainStage2Cast A M M' hp₀ hq₀ + have r6 : (α_ M.X + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q)) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ + tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1 + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1 + 1) (s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + 1 + s)) ≫ + chainStage2Cast A M M' hp₀ hq₀ = + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q)) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ + tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1 + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1 + 1) (s + 1)) ≫ + (symPowCast A M'.X (congrArg Nat.succ hp₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ hq₀)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1)) := + congrArg (fun t : + symPow A M'.X (p + 1 + r + 1) ⊗ + symPow A M.X (q + 1 + 1 + s + 1) ⟶ + chainStage2 A M M' (p + 1 + r) (q + 1 + s + 1) => + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q)) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ + tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1 + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1)) ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1 + 1) (s + 1)) ≫ t) + hcast + exact r5.trans (r6) + +private theorem chainInsQ_mul_rightInterchange + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q r s : ℕ) + (hp₀ : p + 1 + r = p + 1 + r) + (hq₀ : q + 1 + 1 + s = q + 1 + s + 1) : + (α_ M.X + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q)) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ + tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1 + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1 + 1) (s + 1)) ≫ + (symPowCast A M'.X (congrArg Nat.succ hp₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ hq₀)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1)) = + (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1) ⊗ + symPow A M'.X (r + 1))).hom ▷ + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))) ≫ + (α_ (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) M.X + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + (((𝟙 (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) ≫ + symMul A M'.X (p + 1) (r + 1)) ≫ + symPowCast A M'.X (congrArg Nat.succ hp₀)) ⊗ₘ + ((((α_ M.X (symPow A M.X (q + 1)) + (symPow A M.X (s + 1))).inv ≫ + (symInsL A M.X q ▷ symPow A M.X (s + 1))) ≫ + symMul A M.X (q + 1 + 1) (s + 1)) ≫ + symPowCast A M.X (congrArg Nat.succ hq₀))) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1)) := by + have hpast : (α_ M.X + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q)) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ + tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1 + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) = + (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1) ⊗ + symPow A M'.X (r + 1))).hom ▷ + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))) ≫ + (α_ (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) M.X + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + (𝟙 (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) ⊗ₘ + ((α_ M.X (symPow A M.X (q + 1)) + (symPow A M.X (s + 1))).inv ≫ + (symInsL A M.X q ▷ symPow A M.X (s + 1)))) := + crossIns_past_tensorμ (symInsL A M.X q) + have r7 : (α_ M.X + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + (((α_ M.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) ≫ + (α_ (symPow A M'.X (p + 1)) M.X + (symPow A M.X (q + 1))).hom ≫ + (symPow A M'.X (p + 1) ◁ symInsL A M.X q)) ⊗ₘ + 𝟙 (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))) ≫ + tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1 + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1 + 1) (s + 1)) ≫ + (symPowCast A M'.X (congrArg Nat.succ hp₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ hq₀)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1)) = + (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1) ⊗ + symPow A M'.X (r + 1))).hom ▷ + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))) ≫ + (α_ (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) M.X + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + (𝟙 (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) ⊗ₘ + ((α_ M.X (symPow A M.X (q + 1)) + (symPow A M.X (s + 1))).inv ≫ + (symInsL A M.X q ▷ symPow A M.X (s + 1)))) ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1 + 1) (s + 1)) ≫ + (symPowCast A M'.X (congrArg Nat.succ hp₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ hq₀)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1)) := by + rw [reassoc_of% hpast] + have r8 : (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1) ⊗ + symPow A M'.X (r + 1))).hom ▷ + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))) ≫ + (α_ (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) M.X + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + (𝟙 (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) ⊗ₘ + ((α_ M.X (symPow A M.X (q + 1)) + (symPow A M.X (s + 1))).inv ≫ + (symInsL A M.X q ▷ symPow A M.X (s + 1)))) ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1 + 1) (s + 1)) ≫ + (symPowCast A M'.X (congrArg Nat.succ hp₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ hq₀)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1)) = + (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1) ⊗ + symPow A M'.X (r + 1))).hom ▷ + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))) ≫ + (α_ (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) M.X + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + (((𝟙 (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) ≫ + symMul A M'.X (p + 1) (r + 1)) ≫ + symPowCast A M'.X (congrArg Nat.succ hp₀)) ⊗ₘ + ((((α_ M.X (symPow A M.X (q + 1)) + (symPow A M.X (s + 1))).inv ≫ + (symInsL A M.X q ▷ symPow A M.X (s + 1))) ≫ + symMul A M.X (q + 1 + 1) (s + 1)) ≫ + symPowCast A M.X (congrArg Nat.succ hq₀))) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1)) := by + erw [MonoidalCategory.tensorHom_comp_tensorHom_assoc, + MonoidalCategory.tensorHom_comp_tensorHom_assoc] + exact r7.trans (r8) + +private theorem chainInsQ_mul_rightInsertion + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q r s : ℕ) + (hp₀ : p + 1 + r = p + 1 + r) + (hq₀ : q + 1 + 1 + s = q + 1 + s + 1) : + (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1) ⊗ + symPow A M'.X (r + 1))).hom ▷ + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))) ≫ + (α_ (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) M.X + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + (((𝟙 (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) ≫ + symMul A M'.X (p + 1) (r + 1)) ≫ + symPowCast A M'.X (congrArg Nat.succ hp₀)) ⊗ₘ + ((((α_ M.X (symPow A M.X (q + 1)) + (symPow A M.X (s + 1))).inv ≫ + (symInsL A M.X q ▷ symPow A M.X (s + 1))) ≫ + symMul A M.X (q + 1 + 1) (s + 1)) ≫ + symPowCast A M.X (congrArg Nat.succ hq₀))) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1)) = + (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1) ⊗ + symPow A M'.X (r + 1))).hom ▷ + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))) ≫ + (α_ (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) M.X + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + ((M.X ◁ symMul A M.X (q + 1) (s + 1)) ≫ + symInsL A M.X (q + 1 + s))) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1)) := by + have h₁ : q + 1 + s + 2 = q + 2 + (s + 1) := by omega + have hcc : symPowCast A M.X h₁ ≫ + symPowCast A M.X (congrArg Nat.succ hq₀) = + 𝟙 (symPow A M.X (q + 1 + s + 2)) := + (symPowCast_symPowCast A M.X h₁ + (congrArg Nat.succ hq₀)).trans rfl + have hfacL : (𝟙 (symPow A M'.X (p + 1) ⊗ + symPow A M'.X (r + 1)) ≫ + symMul A M'.X (p + 1) (r + 1)) ≫ + symPowCast A M'.X (congrArg Nat.succ hp₀) = + symMul A M'.X (p + 1) (r + 1) := by + rw [Category.id_comp, + show symPowCast A M'.X (congrArg Nat.succ hp₀) = + 𝟙 (symPow A M'.X (p + 1 + r + 1)) from rfl] + exact Category.comp_id _ + have hfacR : ((((α_ M.X (symPow A M.X (q + 1)) + (symPow A M.X (s + 1))).inv ≫ + (symInsL A M.X q ▷ symPow A M.X (s + 1))) ≫ + symMul A M.X (q + 1 + 1) (s + 1)) ≫ + symPowCast A M.X (congrArg Nat.succ hq₀)) = + (M.X ◁ symMul A M.X (q + 1) (s + 1)) ≫ + symInsL A M.X (q + 1 + s) := by + change ((((α_ M.X (symPow A M.X (q + 1)) + (symPow A M.X (s + 1))).inv ≫ + (symInsL A M.X q ▷ symPow A M.X (s + 1))) ≫ + symMul A M.X (q + 2) (s + 1)) ≫ + symPowCast A M.X (congrArg Nat.succ hq₀)) = + (M.X ◁ symMul A M.X (q + 1) (s + 1)) ≫ + symInsL A M.X (q + 1 + s) + conv_lhs => erw [Category.assoc, Category.assoc] + erw [reassoc_of% (symInsL_symMul A M.X q s), + Iso.inv_hom_id_assoc] + exact congrArg (CategoryStruct.comp + (M.X ◁ symMul A M.X (q + 1) (s + 1))) + ((congrArg (CategoryStruct.comp + (symInsL A M.X (q + 1 + s))) hcc).trans + (Category.comp_id _)) + have r9 : (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1) ⊗ + symPow A M'.X (r + 1))).hom ▷ + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))) ≫ + (α_ (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) M.X + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + (((𝟙 (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) ≫ + symMul A M'.X (p + 1) (r + 1)) ≫ + symPowCast A M'.X (congrArg Nat.succ hp₀)) ⊗ₘ + ((((α_ M.X (symPow A M.X (q + 1)) + (symPow A M.X (s + 1))).inv ≫ + (symInsL A M.X q ▷ symPow A M.X (s + 1))) ≫ + symMul A M.X (q + 1 + 1) (s + 1)) ≫ + symPowCast A M.X (congrArg Nat.succ hq₀))) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1)) = + (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M.X (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1) ⊗ + symPow A M'.X (r + 1))).hom ▷ + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))) ≫ + (α_ (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) M.X + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + ((M.X ◁ symMul A M.X (q + 1) (s + 1)) ≫ + symInsL A M.X (q + 1 + s))) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1)) := + congrArg (fun t : + (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) ⊗ + (M.X ⊗ (symPow A M.X (q + 1) ⊗ + symPow A M.X (s + 1))) ⟶ + symPow A M'.X (p + 1 + r + 1) ⊗ + symPow A M.X (q + 1 + s + 1 + 1) => + (M.X ◁ tensorμ (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1)) (symPow A M'.X (r + 1)) + (symPow A M.X (s + 1))) ≫ + (α_ M.X (symPow A M'.X (p + 1) ⊗ + symPow A M'.X (r + 1)) + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).inv ≫ + ((β_ M.X (symPow A M'.X (p + 1) ⊗ + symPow A M'.X (r + 1))).hom ▷ + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))) ≫ + (α_ (symPow A M'.X (p + 1) ⊗ symPow A M'.X (r + 1)) + M.X + (symPow A M.X (q + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + t ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s + 1))) + (congrArg₂ (· ⊗ₘ ·) hfacL hfacR) + exact r9 + +/-- **The second-slot insertion passes the stage multiplication**: +inserting a letter into the merged stage is inserting into the +first factor's second slot and multiplying, up to the index +transport. -/ +theorem chainInsQ_mul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q r s : ℕ) : + (M.X ◁ chainMul2 A M M' p q r s) ≫ + chainInsQ A M M' (p + 1 + r) (q + 1 + s) = + (α_ M.X (chainStage2 A M M' p q) + (chainStage2 A M M' r s)).inv ≫ + (chainInsQ A M M' p q ▷ chainStage2 A M M' r s) ≫ + chainMul2 A M M' p (q + 1) r s ≫ + chainStage2Cast A M M' + (by omega : p + 1 + r = p + 1 + r) + (by omega : q + 1 + 1 + s = q + 1 + s + 1) := by + have hp₀ : p + 1 + r = p + 1 + r := rfl + have hq₀ : q + 1 + 1 + s = q + 1 + s + 1 := by omega + refine (cancel_epi (M.X ◁ + (modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s)))).mp ?_ + change (M.X ◁ + (modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s))) ≫ + ((M.X ◁ chainMul2 A M M' p q r s) ≫ + chainInsQ A M M' (p + 1 + r) (q + 1 + s)) = + (M.X ◁ + (modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) + (symPowMod A M.X s))) ≫ + ((α_ M.X (chainStage2 A M M' p q) + (chainStage2 A M M' r s)).inv ≫ + (chainInsQ A M M' p q ▷ chainStage2 A M M' r s) ≫ + chainMul2 A M M' p (q + 1) r s ≫ + chainStage2Cast A M M' + (by omega : p + 1 + r = p + 1 + r) + (by omega : q + 1 + 1 + s = q + 1 + s + 1)) + -- The left leg: merge the pair cover into the multiplication, + -- fire its defining equation, and absorb the insertion's + -- defining equation at the merged arity. + have hLeftCover := + (chainInsQ_mul_leftCover A M M' p q r s) + have hLeftInsertion := + (chainInsQ_mul_leftInsertion A M M' p q r s) + have hRightCover := + (chainInsQ_mul_rightCover A M M' p q r s hp₀ hq₀) + have hRightProjection := + (chainInsQ_mul_rightProjection A M M' p q r s hp₀ hq₀) + have hRightInterchange := + (chainInsQ_mul_rightInterchange A M M' p q r s hp₀ hq₀) + have hRightInsertion := + (chainInsQ_mul_rightInsertion A M M' p q r s hp₀ hq₀) + exact (hLeftCover.trans (hLeftInsertion)).trans + (hRightCover.trans (hRightProjection.trans (hRightInterchange.trans (hRightInsertion)))).symm + +private theorem chainInsQ_delta2_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (p q : ℕ) + (hz : p + 1 + 0 = p + 1 + 0) + (hz' : q + 1 + 1 + 0 = q + 1 + 0 + 1) : + (M.X ◁ chainDelta2 A M M' d p q) ≫ + chainInsQ A M M' (p + 1) (q + 1) = + (M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (M.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + ((α_ M.X (chainStage2 A M M' p q) + (chainStage2 A M M' 0 0)).inv ≫ + ((chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p (q + 1) 0 0)) := by + have l1 : (M.X ◁ chainDelta2 A M M' d p q) ≫ + chainInsQ A M M' (p + 1) (q + 1) = + (M.X ◁ ((ρ_ (chainStage2 A M M' p q)).inv ≫ + MonoidalCategory.whiskerLeft (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' p q 0 0)) ≫ + chainInsQ A M M' (p + 1) (q + 1) := rfl + have w1 : M.X ◁ ((ρ_ (chainStage2 A M M' p q)).inv ≫ + MonoidalCategory.whiskerLeft (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' p q 0 0) = + (M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (M.X ◁ (MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' p q 0 0)) := + MonoidalCategory.whiskerLeft_comp M.X _ _ + have w2 : M.X ◁ (MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' p q 0 0) = + (M.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + (M.X ◁ chainMul2 A M M' p q 0 0) := + MonoidalCategory.whiskerLeft_comp M.X _ _ + have l2 : (M.X ◁ ((ρ_ (chainStage2 A M M' p q)).inv ≫ + MonoidalCategory.whiskerLeft (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' p q 0 0)) ≫ + chainInsQ A M M' (p + 1) (q + 1) = + (M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (M.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + ((M.X ◁ chainMul2 A M M' p q 0 0) ≫ + chainInsQ A M M' (p + 1) (q + 1)) := by + rw [w1, w2] + repeat' erw [Category.assoc] + have l3 : (M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (M.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + ((M.X ◁ chainMul2 A M M' p q 0 0) ≫ + chainInsQ A M M' (p + 1 + 0) (q + 1 + 0)) = + (M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (M.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + ((α_ M.X (chainStage2 A M M' p q) + (chainStage2 A M M' 0 0)).inv ≫ + (chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p (q + 1) 0 0 ≫ + chainStage2Cast A M M' hz hz') := + congrArg (fun t : M.X ⊗ (chainStage2 A M M' p q ⊗ + chainStage2 A M M' 0 0) ⟶ + chainStage2 A M M' (p + 1 + 0) (q + 1 + 0 + 1) => + (M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (M.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ≫ t) + (chainInsQ_mul A M M' p q 0 0) + have hkill : chainMul2 A M M' p (q + 1) 0 0 ≫ + chainStage2Cast A M M' hz hz' = + chainMul2 A M M' p (q + 1) 0 0 := + (congrArg + (CategoryStruct.comp (chainMul2 A M M' p (q + 1) 0 0)) + (show chainStage2Cast A M M' hz hz' = + 𝟙 (chainStage2 A M M' (p + 1 + 0) (q + 1 + 1 + 0)) from + rfl)).trans (Category.comp_id _) + have l4 : (M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (M.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + ((α_ M.X (chainStage2 A M M' p q) + (chainStage2 A M M' 0 0)).inv ≫ + (chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p (q + 1) 0 0 ≫ + chainStage2Cast A M M' hz hz') = + (M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (M.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + ((α_ M.X (chainStage2 A M M' p q) + (chainStage2 A M M' 0 0)).inv ≫ + ((chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p (q + 1) 0 0)) := + congrArg (fun t : chainStage2 A M M' p (q + 1) ⊗ + chainStage2 A M M' 0 0 ⟶ + chainStage2 A M M' (p + 1 + 0) (q + 1 + 0 + 1) => + (M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (M.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ≫ + ((α_ M.X (chainStage2 A M M' p q) + (chainStage2 A M M' 0 0)).inv ≫ + ((chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + t))) + hkill + -- Unitor and seed bookkeeping, as in `chainInsP_delta2`. + exact l1.trans (l2.trans (l3.trans (l4))) + +private theorem chainInsQ_delta2_seed + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (p q : ℕ) : + (M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (M.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + ((α_ M.X (chainStage2 A M M' p q) + (chainStage2 A M M' 0 0)).inv ≫ + ((chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p (q + 1) 0 0)) = + (ρ_ (M.X ⊗ chainStage2 A M M' p q)).inv ≫ + (MonoidalCategory.whiskerLeft + (M.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + ((chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p (q + 1) 0 0)) := by + have hseed : (M.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + (α_ M.X (chainStage2 A M M' p q) + (chainStage2 A M M' 0 0)).inv = + (α_ M.X (chainStage2 A M M' p q) (𝟙_ D)).inv ≫ + MonoidalCategory.whiskerLeft + (M.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) := + associator_inv_naturality_right _ _ _ + have hρ : (M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (α_ M.X (chainStage2 A M M' p q) (𝟙_ D)).inv = + (ρ_ (M.X ⊗ chainStage2 A M M' p q)).inv := by + monoidal + have c1 : (M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (M.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + ((α_ M.X (chainStage2 A M M' p q) + (chainStage2 A M M' 0 0)).inv ≫ + ((chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p (q + 1) 0 0)) = + (M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (((M.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + (α_ M.X (chainStage2 A M M' p q) + (chainStage2 A M M' 0 0)).inv) ≫ + ((chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p (q + 1) 0 0)) := + congrArg + (CategoryStruct.comp + (M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv)) + (Category.assoc _ _ _).symm + have c2 : (M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (((M.X ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + (α_ M.X (chainStage2 A M M' p q) + (chainStage2 A M M' 0 0)).inv) ≫ + ((chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p (q + 1) 0 0)) = + (M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (((α_ M.X (chainStage2 A M M' p q) (𝟙_ D)).inv ≫ + MonoidalCategory.whiskerLeft + (M.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ≫ + ((chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p (q + 1) 0 0)) := + congrArg (fun t : M.X ⊗ (chainStage2 A M M' p q ⊗ 𝟙_ D) ⟶ + (M.X ⊗ chainStage2 A M M' p q) ⊗ + chainStage2 A M M' 0 0 => + (M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (t ≫ ((chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p (q + 1) 0 0))) + hseed + have c3 : (M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (((α_ M.X (chainStage2 A M M' p q) (𝟙_ D)).inv ≫ + MonoidalCategory.whiskerLeft + (M.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ≫ + ((chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p (q + 1) 0 0)) = + (M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + ((α_ M.X (chainStage2 A M M' p q) (𝟙_ D)).inv ≫ + (MonoidalCategory.whiskerLeft + (M.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d) ≫ + ((chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p (q + 1) 0 0))) := + congrArg + (CategoryStruct.comp + (M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv)) + (Category.assoc _ _ _) + have c4 : (M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + ((α_ M.X (chainStage2 A M M' p q) (𝟙_ D)).inv ≫ + (MonoidalCategory.whiskerLeft + (M.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d) ≫ + ((chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p (q + 1) 0 0))) = + ((M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (α_ M.X (chainStage2 A M M' p q) (𝟙_ D)).inv) ≫ + (MonoidalCategory.whiskerLeft + (M.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + ((chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p (q + 1) 0 0)) := + (Category.assoc _ _ _).symm + have c5 : ((M.X ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (α_ M.X (chainStage2 A M M' p q) (𝟙_ D)).inv) ≫ + (MonoidalCategory.whiskerLeft + (M.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + ((chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p (q + 1) 0 0)) = + (ρ_ (M.X ⊗ chainStage2 A M M' p q)).inv ≫ + (MonoidalCategory.whiskerLeft + (M.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + ((chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p (q + 1) 0 0)) := + congrArg (fun t : M.X ⊗ chainStage2 A M M' p q ⟶ + (M.X ⊗ chainStage2 A M M' p q) ⊗ 𝟙_ D => + t ≫ (MonoidalCategory.whiskerLeft + (M.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + ((chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p (q + 1) 0 0))) + hρ + -- The right leg: unfold the transition and slide the insertion + -- past the unitor and the seed. + exact c1.trans (c2.trans (c3.trans (c4.trans (c5)))) + +private theorem chainInsQ_delta2_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (p q : ℕ) : + chainInsQ A M M' p q ≫ + chainDelta2 A M M' d p (q + 1) = + (ρ_ (M.X ⊗ chainStage2 A M M' p q)).inv ≫ + (MonoidalCategory.whiskerLeft + (M.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + ((chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p (q + 1) 0 0)) := by + have hρnat : chainInsQ A M M' p q ≫ + (ρ_ (chainStage2 A M M' p (q + 1))).inv = + (ρ_ (M.X ⊗ chainStage2 A M M' p q)).inv ≫ + (chainInsQ A M M' p q ▷ 𝟙_ D) := + rightUnitor_inv_naturality _ + have hexch : (chainInsQ A M M' p q ▷ 𝟙_ D) ≫ + MonoidalCategory.whiskerLeft + (chainStage2 A M M' p (q + 1)) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) = + MonoidalCategory.whiskerLeft + (M.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + (chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0) := + (whisker_exchange _ _).symm + have b1 : chainInsQ A M M' p q ≫ + chainDelta2 A M M' d p (q + 1) = + chainInsQ A M M' p q ≫ + ((ρ_ (chainStage2 A M M' p (q + 1))).inv ≫ + (MonoidalCategory.whiskerLeft + (chainStage2 A M M' p (q + 1)) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' p (q + 1) 0 0)) := rfl + have b2 : chainInsQ A M M' p q ≫ + ((ρ_ (chainStage2 A M M' p (q + 1))).inv ≫ + (MonoidalCategory.whiskerLeft + (chainStage2 A M M' p (q + 1)) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' p (q + 1) 0 0)) = + (chainInsQ A M M' p q ≫ + (ρ_ (chainStage2 A M M' p (q + 1))).inv) ≫ + (MonoidalCategory.whiskerLeft + (chainStage2 A M M' p (q + 1)) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' p (q + 1) 0 0) := + (Category.assoc _ _ _).symm + have b3 : (chainInsQ A M M' p q ≫ + (ρ_ (chainStage2 A M M' p (q + 1))).inv) ≫ + (MonoidalCategory.whiskerLeft + (chainStage2 A M M' p (q + 1)) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' p (q + 1) 0 0) = + ((ρ_ (M.X ⊗ chainStage2 A M M' p q)).inv ≫ + (chainInsQ A M M' p q ▷ 𝟙_ D)) ≫ + (MonoidalCategory.whiskerLeft + (chainStage2 A M M' p (q + 1)) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' p (q + 1) 0 0) := + congrArg (fun t : M.X ⊗ chainStage2 A M M' p q ⟶ + chainStage2 A M M' p (q + 1) ⊗ 𝟙_ D => + t ≫ (MonoidalCategory.whiskerLeft + (chainStage2 A M M' p (q + 1)) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' p (q + 1) 0 0)) + hρnat + have b4 : ((ρ_ (M.X ⊗ chainStage2 A M M' p q)).inv ≫ + (chainInsQ A M M' p q ▷ 𝟙_ D)) ≫ + (MonoidalCategory.whiskerLeft + (chainStage2 A M M' p (q + 1)) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' p (q + 1) 0 0) = + (ρ_ (M.X ⊗ chainStage2 A M M' p q)).inv ≫ + ((chainInsQ A M M' p q ▷ 𝟙_ D) ≫ + (MonoidalCategory.whiskerLeft + (chainStage2 A M M' p (q + 1)) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' p (q + 1) 0 0)) := + Category.assoc _ _ _ + have b5 : (ρ_ (M.X ⊗ chainStage2 A M M' p q)).inv ≫ + ((chainInsQ A M M' p q ▷ 𝟙_ D) ≫ + (MonoidalCategory.whiskerLeft + (chainStage2 A M M' p (q + 1)) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' p (q + 1) 0 0)) = + (ρ_ (M.X ⊗ chainStage2 A M M' p q)).inv ≫ + (((chainInsQ A M M' p q ▷ 𝟙_ D) ≫ + MonoidalCategory.whiskerLeft + (chainStage2 A M M' p (q + 1)) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + chainMul2 A M M' p (q + 1) 0 0) := + congrArg + (CategoryStruct.comp + (ρ_ (M.X ⊗ chainStage2 A M M' p q)).inv) + (Category.assoc _ _ _).symm + have b6 : (ρ_ (M.X ⊗ chainStage2 A M M' p q)).inv ≫ + (((chainInsQ A M M' p q ▷ 𝟙_ D) ≫ + MonoidalCategory.whiskerLeft + (chainStage2 A M M' p (q + 1)) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + chainMul2 A M M' p (q + 1) 0 0) = + (ρ_ (M.X ⊗ chainStage2 A M M' p q)).inv ≫ + ((MonoidalCategory.whiskerLeft + (M.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + (chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0)) ≫ + chainMul2 A M M' p (q + 1) 0 0) := + congrArg (fun t : (M.X ⊗ chainStage2 A M M' p q) ⊗ 𝟙_ D ⟶ + chainStage2 A M M' p (q + 1) ⊗ + chainStage2 A M M' 0 0 => + (ρ_ (M.X ⊗ chainStage2 A M M' p q)).inv ≫ + (t ≫ chainMul2 A M M' p (q + 1) 0 0)) + hexch + have b7 : (ρ_ (M.X ⊗ chainStage2 A M M' p q)).inv ≫ + ((MonoidalCategory.whiskerLeft + (M.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + (chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0)) ≫ + chainMul2 A M M' p (q + 1) 0 0) = + (ρ_ (M.X ⊗ chainStage2 A M M' p q)).inv ≫ + (MonoidalCategory.whiskerLeft + (M.X ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + ((chainInsQ A M M' p q ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p (q + 1) 0 0)) := + congrArg + (CategoryStruct.comp + (ρ_ (M.X ⊗ chainStage2 A M M' p q)).inv) + (Category.assoc _ _ _) + exact b1.trans (b2.trans (b3.trans (b4.trans (b5.trans (b6.trans (b7)))))) + +/-- **The transition square for the second-slot insertion**: the +insertion passes the seed transition, raising the merged arities +by one on each side. -/ +theorem chainInsQ_delta2 + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (p q : ℕ) : + (M.X ◁ chainDelta2 A M M' d p q) ≫ + chainInsQ A M M' (p + 1) (q + 1) = + chainInsQ A M M' p q ≫ chainDelta2 A M M' d p (q + 1) := by + have hz : p + 1 + 0 = p + 1 + 0 := rfl + have hz' : q + 1 + 1 + 0 = q + 1 + 0 + 1 := by omega + -- The left leg: unfold the transition, distribute the whisker, + -- pass the insertion through the stage multiplication, and + -- absorb the trivial index transport. + have hLeft := + (chainInsQ_delta2_left A M M' d p q hz hz') + have hSeed := + (chainInsQ_delta2_seed A M M' d p q) + have hRight := + (chainInsQ_delta2_right A M M' d p q) + exact (hLeft.trans (hSeed)).trans hRight.symm + +end InsQ2Laws + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMul.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMul.lean new file mode 100644 index 0000000000..b69d62c0c0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMul.lean @@ -0,0 +1,227 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairMul + +/-! +# The multiplication of the chain algebra + +The symmetric multiplication descends through the module-tensor +coequalizer of two symmetric powers, giving a module map of +bundles; through the interchange, the tensor product of two chain +stages multiplies into the chain stage of summed arity. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- The two module-tensor legs of a pair of symmetric powers +agree after the symmetric multiplication. -/ +theorem symMul_modTensor_cond + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (m n : ℕ) : + modTensorLegM A (symPowMod A X m) (symPowMod A X n) ≫ + symMul A X (m + 1) (n + 1) = + modTensorLegN A (symPowMod A X m) (symPowMod A X n) ≫ + symMul A X (m + 1) (n + 1) := by + have h3 := (symMul_actRight A X m n).trans + (symMul_actLeft A X m n).symm + simp only [braidPast_hom, Category.assoc] at h3 + have h4 := (cancel_epi + (α_ A (symPow A X (m + 1)) (symPow A X (n + 1))).inv).mp h3 + rw [modTensorLegM, modTensorLegN, actRight, + show actLeft A (symPowMod A X m).X = symPowAct A X m from + rfl, + show actLeft A (symPowMod A X n).X = symPowAct A X n from + rfl] + change (((β_ (symPow A X (m + 1)) A).hom ≫ symPowAct A X m) ▷ + symPow A X (n + 1)) ≫ symMul A X (m + 1) (n + 1) = + ((α_ (symPow A X (m + 1)) A (symPow A X (n + 1))).hom ≫ + (symPow A X (m + 1) ◁ symPowAct A X n)) ≫ + symMul A X (m + 1) (n + 1) + rw [comp_whiskerRight, Category.assoc, ← h4, + ← comp_whiskerRight_assoc, SymmetricCategory.symmetry, + MonoidalCategory.id_whiskerRight, Category.id_comp] + simp only [Category.assoc] + +/-- **The descended symmetric multiplication** on the module +tensor product of two symmetric powers. -/ +noncomputable def symMulDesc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (m n : ℕ) : + modTensor A (symPowMod A X m) (symPowMod A X n) ⟶ + symPow A X (m + 1 + n + 1) := + modTensorDesc A (symPowMod A X m) (symPowMod A X n) + (symMul A X (m + 1) (n + 1)) (symMul_modTensor_cond A X m n) + +/-- Defining equation of the descended multiplication. -/ +@[reassoc (attr := simp)] +theorem modTensorπ_symMulDesc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (m n : ℕ) : + modTensorπ A (symPowMod A X m) (symPowMod A X n) ≫ + symMulDesc A X m n = symMul A X (m + 1) (n + 1) := + modTensorπ_desc A (symPowMod A X m) (symPowMod A X n) _ _ + +/-- The descended multiplication intertwines the module +actions. -/ +theorem symMulDesc_act + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (m n : ℕ) : + modTensorAct A (symPowMod A X m) (symPowMod A X n) ≫ + symMulDesc A X m n = + (A ◁ symMulDesc A X m n) ≫ symPowAct A X (m + 1 + n) := by + apply modTensor_whisker_hom_ext A (symPowMod A X m) + (symPowMod A X n) A + conv_lhs => rw [whiskerLeft_modTensorπ_act_assoc, + modTensorπ_symMulDesc] + conv_rhs => rw [← whiskerLeft_comp_assoc, + modTensorπ_symMulDesc] + have h := symMul_actLeft A X m n + change (α_ A (symPow A X (m + 1)) (symPow A X (n + 1))).inv ≫ + (symPowAct A X m ▷ symPow A X (n + 1)) ≫ + symMul A X (m + 1) (n + 1) = + (A ◁ symMul A X (m + 1) (n + 1)) ≫ symPowAct A X (m + 1 + n) + simpa only [Category.assoc] using h + +/-- The descended symmetric multiplication as a map of +modules. -/ +noncomputable def symMulMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (m n : ℕ) : + modTensorMod A (symPowMod A X m) (symPowMod A X n) ⟶ + symPowMod A X (m + 1 + n) := + Mod.Hom.mk' (symMulDesc A X m n) (symMulDesc_act A X m n) + +/-- One stage of the splitting chain: the module tensor product +of matching symmetric powers of the dual pair. -/ +noncomputable def chainStage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (k : ℕ) : D := + modTensor A (symPowMod A M'.X k) (symPowMod A M.X k) + +/-- **The chain multiplication**: two stages interchange and +multiply into the stage of summed arity. -/ +noncomputable def chainMul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (m n : ℕ) : + chainStage A M M' m ⊗ chainStage A M M' n ⟶ + chainStage A M M' (m + 1 + n) := + interchange A (symPowMod A M'.X m) (symPowMod A M.X m) + (symPowMod A M'.X n) (symPowMod A M.X n) ≫ + modTensorMap A (symMulMod A M'.X m n) (symMulMod A M.X m n) + +/-- Defining equation of the chain multiplication: under the +stage projections it is the raw crossing followed by the +symmetric multiplications. -/ +theorem tensorHom_π_chainMul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (m n : ℕ) : + (modTensorπ A (symPowMod A M'.X m) (symPowMod A M.X m) ⊗ₘ + modTensorπ A (symPowMod A M'.X n) (symPowMod A M.X n)) ≫ + chainMul A M M' m n = + tensorμ (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) + (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) ≫ + (symMul A M'.X (m + 1) (n + 1) ⊗ₘ + symMul A M.X (m + 1) (n + 1)) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n)) + (symPowMod A M.X (m + 1 + n)) := by + have h5 : (modTensorπ A (symPowMod A M'.X m) + (symPowMod A M.X m) ⊗ₘ + modTensorπ A (symPowMod A M'.X n) (symPowMod A M.X n)) ≫ + chainMul A M M' m n = + ((modTensorπ A (symPowMod A M'.X m) (symPowMod A M.X m) ⊗ₘ + modTensorπ A (symPowMod A M'.X n) (symPowMod A M.X n)) ≫ + interchange A (symPowMod A M'.X m) (symPowMod A M.X m) + (symPowMod A M'.X n) (symPowMod A M.X n)) ≫ + modTensorMap A (symMulMod A M'.X m n) + (symMulMod A M.X m n) := by + rw [chainMul] + exact (Category.assoc _ _ _).symm + rw [h5, tensorHom_π_interchange, rawInterchangeπ, + rawInterchange] + simp only [Category.assoc] + have h6 : modTensorπ A + (modTensorMod A (symPowMod A M'.X m) (symPowMod A M'.X n)) + (modTensorMod A (symPowMod A M.X m) (symPowMod A M.X n)) ≫ + modTensorMap A (symMulMod A M'.X m n) + (symMulMod A M.X m n) = + ((symMulMod A M'.X m n).hom ⊗ₘ (symMulMod A M.X m n).hom) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n)) + (symPowMod A M.X (m + 1 + n)) := + modTensorπ_map A (symMulMod A M'.X m n) + (symMulMod A M.X m n) + conv_lhs => arg 2; erw [Category.assoc] + change tensorμ (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) + (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) ≫ + (modTensorπ A (symPowMod A M'.X m) (symPowMod A M'.X n) ⊗ₘ + modTensorπ A (symPowMod A M.X m) (symPowMod A M.X n)) ≫ + modTensorπ A + (modTensorMod A (symPowMod A M'.X m) (symPowMod A M'.X n)) + (modTensorMod A (symPowMod A M.X m) (symPowMod A M.X n)) ≫ + modTensorMap A (symMulMod A M'.X m n) + (symMulMod A M.X m n) = _ + refine congrArg (CategoryStruct.comp _) ?_ + refine (congrArg (CategoryStruct.comp _) h6).trans ?_ + erw [show (symMulMod A M'.X m n).hom = symMulDesc A M'.X m n + from rfl, + show (symMulMod A M.X m n).hom = symMulDesc A M.X m n from + rfl, ← Category.assoc] + change ((modTensorπ A (symPowMod A M'.X m) + (symPowMod A M'.X n) ⊗ₘ + modTensorπ A (symPowMod A M.X m) (symPowMod A M.X n)) ≫ + (symMulDesc A M'.X m n ⊗ₘ symMulDesc A M.X m n)) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n)) + (symPowMod A M.X (m + 1 + n)) = _ + rw [MonoidalCategory.tensorHom_comp_tensorHom, + modTensorπ_symMulDesc, modTensorπ_symMulDesc] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulHet.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulHet.lean new file mode 100644 index 0000000000..accd4c9351 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulHet.lean @@ -0,0 +1,266 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainAlgebra + +/-! +# Heterogeneous multiplication of chain colimits + +The colimit multiplication of `ChainAlgebra` generalises to three +chains: stagewise multiplications `B i ⊗ C j ⟶ F (i + 1 + j)` +compatible with the three transition families assemble into a +morphism `chainColimit B δB ⊗ chainColimit C δC ⟶ chainColimit F δF`. +The construction is the two-pass `colimit.desc` of the homogeneous +case, verbatim up to the substitution of the three chains: partial +cocones against a fixed stage of `C` in the second slot, then the +total cocone over the second slot through the preservation +isomorphisms. The defining equation on a pair of stages is +cast-free because the stage inclusions absorb the index transports. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {E : Type u} + +/-- Multiplying after a chain morphism in the first slot agrees with +multiplying first, once both land in the colimit. -/ +theorem mulHet_chainMap_ι_left [Category.{v} E] [MonoidalCategory E] + [HasColimitsOfShape SmallNat.{v} E] (B : ℕ → E) (C : ℕ → E) (F : ℕ → E) + (δB : ∀ n, B n ⟶ B (n + 1)) (δF : ∀ n, F n ⟶ F (n + 1)) + (mu : ∀ i j : ℕ, B i ⊗ C j ⟶ F (i + 1 + j)) + (hδl : ∀ i j, (δB i ▷ C j) ≫ mu (i + 1) j = mu i j ≫ δF (i + 1 + j) ≫ + chainCast F (Nat.add_right_comm (i + 1) j 1)) + {i i' : ℕ} (h : i ≤ i') (j : ℕ) : + (chainMap B δB h ▷ C j) ≫ mu i' j ≫ + chainColimitι F δF (i' + 1 + j) = + mu i j ≫ chainColimitι F δF (i + 1 + j) := by + induction i', h using Nat.le_induction with + | base => + rw [chainMap_self, MonoidalCategory.id_whiskerRight, + Category.id_comp] + | succ i' hii ih => + rw [chainMap_succ_of_le B δB hii, comp_whiskerRight, + Category.assoc, reassoc_of% (hδl i' j), + chainCast_chainColimitι, delta_chainColimitι] + exact ih + +/-- Multiplying after a chain morphism in the second slot agrees with +multiplying first, once both land in the colimit. -/ +theorem mulHet_chainMap_ι_right [Category.{v} E] [MonoidalCategory E] + [HasColimitsOfShape SmallNat.{v} E] (B : ℕ → E) (C : ℕ → E) (F : ℕ → E) + (δC : ∀ n, C n ⟶ C (n + 1)) (δF : ∀ n, F n ⟶ F (n + 1)) + (mu : ∀ i j : ℕ, B i ⊗ C j ⟶ F (i + 1 + j)) + (hδr : ∀ i j, (B i ◁ δC j) ≫ mu i (j + 1) = mu i j ≫ δF (i + 1 + j)) + (i : ℕ) {j j' : ℕ} (h : j ≤ j') : + (B i ◁ chainMap C δC h) ≫ mu i j' ≫ + chainColimitι F δF (i + 1 + j') = + mu i j ≫ chainColimitι F δF (i + 1 + j) := by + induction j', h using Nat.le_induction with + | base => + rw [chainMap_self, MonoidalCategory.whiskerLeft_id, + Category.id_comp] + | succ j' hjj ih => + rw [chainMap_succ_of_le C δC hjj, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + reassoc_of% (hδr i j')] + have hι : δF (i + 1 + j') ≫ + chainColimitι F δF (i + 1 + (j' + 1)) = + chainColimitι F δF (i + 1 + j') := + delta_chainColimitι F δF (i + 1 + j') + rw [hι] + exact ih + +/-- The multiply-then-include maps against a fixed stage of `C` in +the second slot form a cocone on the first chain diagram tensored on +the right with that stage. -/ +noncomputable def chainMulHetCocone [Category.{v} E] [MonoidalCategory E] + [HasColimitsOfShape SmallNat.{v} E] (B : ℕ → E) (C : ℕ → E) (F : ℕ → E) + (δB : ∀ n, B n ⟶ B (n + 1)) (δF : ∀ n, F n ⟶ F (n + 1)) + (mu : ∀ i j : ℕ, B i ⊗ C j ⟶ F (i + 1 + j)) + (hδl : ∀ i j, (δB i ▷ C j) ≫ mu (i + 1) j = mu i j ≫ δF (i + 1 + j) ≫ + chainCast F (Nat.add_right_comm (i + 1) j 1)) + (j : ℕ) : + Cocone (chainDiagram B δB ⋙ tensorRight (C j)) where + pt := chainColimit F δF + ι := + { app := fun k => + mu (smallNatEquiv.inverse.obj k) j ≫ + chainColimitι F δF (smallNatEquiv.inverse.obj k + 1 + j) + naturality := fun {k k'} f => by + change (chainMap B δB + (leOfHom (smallNatEquiv.inverse.map f)) ▷ C j) ≫ + (mu (smallNatEquiv.inverse.obj k') j ≫ + chainColimitι F δF + (smallNatEquiv.inverse.obj k' + 1 + j)) = + (mu (smallNatEquiv.inverse.obj k) j ≫ + chainColimitι F δF + (smallNatEquiv.inverse.obj k + 1 + j)) ≫ + 𝟙 (chainColimit F δF) + rw [Category.comp_id] + exact mulHet_chainMap_ι_left B C F δB δF mu hδl + (leOfHom (smallNatEquiv.inverse.map f)) j } + +/-- Partial multiplication of the first chain colimit against a +fixed stage of `C` in the second slot. -/ +noncomputable def chainMulHetStage [Category.{v} E] [MonoidalCategory E] + [HasColimitsOfShape SmallNat.{v} E] (B : ℕ → E) (C : ℕ → E) (F : ℕ → E) + (δB : ∀ n, B n ⟶ B (n + 1)) (δF : ∀ n, F n ⟶ F (n + 1)) + (mu : ∀ i j : ℕ, B i ⊗ C j ⟶ F (i + 1 + j)) + (hδl : ∀ i j, (δB i ▷ C j) ≫ mu (i + 1) j = mu i j ≫ δF (i + 1 + j) ≫ + chainCast F (Nat.add_right_comm (i + 1) j 1)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + (j : ℕ) : + chainColimit B δB ⊗ C j ⟶ chainColimit F δF := + ((preservesColimitIso (tensorRight (C j)) + (chainDiagram B δB)).hom ≫ + colimit.desc _ (chainMulHetCocone B C F δB δF mu hδl j) : + (tensorRight (C j)).obj (colimit (chainDiagram B δB)) ⟶ + chainColimit F δF) + +/-- On a stage, the partial multiplication is multiply-then-include. -/ +@[reassoc] +theorem ι_chainMulHetStage [Category.{v} E] [MonoidalCategory E] + [HasColimitsOfShape SmallNat.{v} E] (B : ℕ → E) (C : ℕ → E) (F : ℕ → E) + (δB : ∀ n, B n ⟶ B (n + 1)) (δF : ∀ n, F n ⟶ F (n + 1)) + (mu : ∀ i j : ℕ, B i ⊗ C j ⟶ F (i + 1 + j)) + (hδl : ∀ i j, (δB i ▷ C j) ≫ mu (i + 1) j = mu i j ≫ δF (i + 1 + j) ≫ + chainCast F (Nat.add_right_comm (i + 1) j 1)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + (i j : ℕ) : + (chainColimitι B δB i ▷ C j) ≫ + chainMulHetStage B C F δB δF mu hδl j = + mu i j ≫ chainColimitι F δF (i + 1 + j) := by + change (tensorRight (C j)).map (colimit.ι (chainDiagram B δB) + (smallNatEquiv.functor.obj i)) ≫ + chainMulHetStage B C F δB δF mu hδl j = + mu i j ≫ chainColimitι F δF (i + 1 + j) + erw [chainMulHetStage, ι_preservesColimitIso_hom_assoc] + exact colimit.ι_desc (chainMulHetCocone B C F δB δF mu hδl j) + (smallNatEquiv.functor.obj i) + +/-- The partial multiplications are natural in the stage. -/ +@[reassoc] +theorem chainMulHetStage_natural [Category.{v} E] [MonoidalCategory E] + [HasColimitsOfShape SmallNat.{v} E] (B : ℕ → E) (C : ℕ → E) (F : ℕ → E) + (δB : ∀ n, B n ⟶ B (n + 1)) (δC : ∀ n, C n ⟶ C (n + 1)) + (δF : ∀ n, F n ⟶ F (n + 1)) (mu : ∀ i j : ℕ, B i ⊗ C j ⟶ F (i + 1 + j)) + (hδl : ∀ i j, (δB i ▷ C j) ≫ mu (i + 1) j = mu i j ≫ δF (i + 1 + j) ≫ + chainCast F (Nat.add_right_comm (i + 1) j 1)) + (hδr : ∀ i j, (B i ◁ δC j) ≫ mu i (j + 1) = mu i j ≫ δF (i + 1 + j)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + {j j' : ℕ} (h : j ≤ j') : + (chainColimit B δB ◁ chainMap C δC h) ≫ + chainMulHetStage B C F δB δF mu hδl j' = + chainMulHetStage B C F δB δF mu hδl j := by + apply chainColimit_tensorRight_hom_ext B δB + intro i + rw [← Category.assoc, ← whisker_exchange, Category.assoc, + ι_chainMulHetStage, ι_chainMulHetStage] + exact mulHet_chainMap_ι_right B C F δC δF mu hδr i h + +/-- The partial multiplications form a cocone on the second chain +diagram tensored on the left with the first chain colimit. -/ +noncomputable def chainMulHetTotalCocone [Category.{v} E] [MonoidalCategory E] + [HasColimitsOfShape SmallNat.{v} E] (B : ℕ → E) (C : ℕ → E) (F : ℕ → E) + (δB : ∀ n, B n ⟶ B (n + 1)) (δC : ∀ n, C n ⟶ C (n + 1)) + (δF : ∀ n, F n ⟶ F (n + 1)) (mu : ∀ i j : ℕ, B i ⊗ C j ⟶ F (i + 1 + j)) + (hδl : ∀ i j, (δB i ▷ C j) ≫ mu (i + 1) j = mu i j ≫ δF (i + 1 + j) ≫ + chainCast F (Nat.add_right_comm (i + 1) j 1)) + (hδr : ∀ i j, (B i ◁ δC j) ≫ mu i (j + 1) = mu i j ≫ δF (i + 1 + j)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] : + Cocone (chainDiagram C δC ⋙ tensorLeft (chainColimit B δB)) + where + pt := chainColimit F δF + ι := + { app := fun k => + chainMulHetStage B C F δB δF mu hδl + (smallNatEquiv.inverse.obj k) + naturality := fun {k k'} f => by + change (chainColimit B δB ◁ chainMap C δC + (leOfHom (smallNatEquiv.inverse.map f))) ≫ + chainMulHetStage B C F δB δF mu hδl + (smallNatEquiv.inverse.obj k') = + chainMulHetStage B C F δB δF mu hδl + (smallNatEquiv.inverse.obj k) ≫ + 𝟙 (chainColimit F δF) + rw [Category.comp_id] + exact chainMulHetStage_natural B C F δB δC δF mu hδl hδr + (leOfHom (smallNatEquiv.inverse.map f)) } + +/-- **The heterogeneous colimit multiplication**: the partial +multiplications assembled over the second slot. -/ +noncomputable def chainColimitMulHet [Category.{v} E] [MonoidalCategory E] + [HasColimitsOfShape SmallNat.{v} E] (B : ℕ → E) (C : ℕ → E) (F : ℕ → E) + (δB : ∀ n, B n ⟶ B (n + 1)) (δC : ∀ n, C n ⟶ C (n + 1)) + (δF : ∀ n, F n ⟶ F (n + 1)) (mu : ∀ i j : ℕ, B i ⊗ C j ⟶ F (i + 1 + j)) + (hδl : ∀ i j, (δB i ▷ C j) ≫ mu (i + 1) j = mu i j ≫ δF (i + 1 + j) ≫ + chainCast F (Nat.add_right_comm (i + 1) j 1)) + (hδr : ∀ i j, (B i ◁ δC j) ≫ mu i (j + 1) = mu i j ≫ δF (i + 1 + j)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] : + chainColimit B δB ⊗ chainColimit C δC ⟶ chainColimit F δF := + ((preservesColimitIso (tensorLeft (chainColimit B δB)) + (chainDiagram C δC)).hom ≫ + colimit.desc _ + (chainMulHetTotalCocone B C F δB δC δF mu hδl hδr) : + (tensorLeft (chainColimit B δB)).obj + (colimit (chainDiagram C δC)) ⟶ + chainColimit F δF) + +/-- On a stage in the second slot, the heterogeneous colimit +multiplication is the partial multiplication. -/ +@[reassoc] +theorem whiskerLeft_ι_chainColimitMulHet [Category.{v} E] [MonoidalCategory E] + [HasColimitsOfShape SmallNat.{v} E] (B : ℕ → E) (C : ℕ → E) (F : ℕ → E) + (δB : ∀ n, B n ⟶ B (n + 1)) (δC : ∀ n, C n ⟶ C (n + 1)) + (δF : ∀ n, F n ⟶ F (n + 1)) (mu : ∀ i j : ℕ, B i ⊗ C j ⟶ F (i + 1 + j)) + (hδl : ∀ i j, (δB i ▷ C j) ≫ mu (i + 1) j = mu i j ≫ δF (i + 1 + j) ≫ + chainCast F (Nat.add_right_comm (i + 1) j 1)) + (hδr : ∀ i j, (B i ◁ δC j) ≫ mu i (j + 1) = mu i j ≫ δF (i + 1 + j)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (j : ℕ) : + (chainColimit B δB ◁ chainColimitι C δC j) ≫ + chainColimitMulHet B C F δB δC δF mu hδl hδr = + chainMulHetStage B C F δB δF mu hδl j := by + change (tensorLeft (chainColimit B δB)).map + (colimit.ι (chainDiagram C δC) + (smallNatEquiv.functor.obj j)) ≫ + chainColimitMulHet B C F δB δC δF mu hδl hδr = + chainMulHetStage B C F δB δF mu hδl j + erw [chainColimitMulHet, ι_preservesColimitIso_hom_assoc] + exact colimit.ι_desc + (chainMulHetTotalCocone B C F δB δC δF mu hδl hδr) + (smallNatEquiv.functor.obj j) + +/-- **Defining equation of the heterogeneous colimit +multiplication**: on a pair of stages it is multiply-then-include. -/ +@[reassoc] +theorem ι_tensorHom_chainColimitMulHet [Category.{v} E] [MonoidalCategory E] + [HasColimitsOfShape SmallNat.{v} E] (B : ℕ → E) (C : ℕ → E) (F : ℕ → E) + (δB : ∀ n, B n ⟶ B (n + 1)) (δC : ∀ n, C n ⟶ C (n + 1)) + (δF : ∀ n, F n ⟶ F (n + 1)) (mu : ∀ i j : ℕ, B i ⊗ C j ⟶ F (i + 1 + j)) + (hδl : ∀ i j, (δB i ▷ C j) ≫ mu (i + 1) j = mu i j ≫ δF (i + 1 + j) ≫ + chainCast F (Nat.add_right_comm (i + 1) j 1)) + (hδr : ∀ i j, (B i ◁ δC j) ≫ mu i (j + 1) = mu i j ≫ δF (i + 1 + j)) + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : E, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + (i j : ℕ) : + (chainColimitι B δB i ⊗ₘ chainColimitι C δC j) ≫ + chainColimitMulHet B C F δB δC δF mu hδl hδr = + mu i j ≫ chainColimitι F δF (i + 1 + j) := by + rw [tensorHom_def, Category.assoc, + whiskerLeft_ι_chainColimitMulHet, ι_chainMulHetStage] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulLaws.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulLaws.lean new file mode 100644 index 0000000000..ba70fd6179 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulLaws.lean @@ -0,0 +1,1044 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMul +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid + +/-! +# Commutativity and associativity of the chain multiplication + +The chain multiplication braids and reassociates exactly as the +symmetric multiplication it descends from. Both laws are proved by +cancelling the jointly epimorphic stage projections and reducing to +the corresponding `symMul` laws together with the coherence of the +interchange `tensorμ`. Transports of chain stages along equalities +of arities are packaged as `chainStageCast`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## Stage transports -/ + +section StageCast + +/-- Transport of a chain stage along an equality of arities. -/ +noncomputable def chainStageCast + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + {j k : ℕ} (h : j = k) : + chainStage A M M' j ⟶ chainStage A M M' k := + eqToHom (congrArg (chainStage A M M') h) + +/-- The trivial transport is the identity. -/ +@[simp] +theorem chainStageCast_rfl + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (k : ℕ) : + chainStageCast A M M' (rfl : k = k) = 𝟙 _ := rfl + +/-- Stage transports compose. -/ +@[reassoc (attr := simp)] +theorem chainStageCast_trans + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + {i j k : ℕ} (h : i = j) (h' : j = k) : + chainStageCast A M M' h ≫ chainStageCast A M M' h' = + chainStageCast A M M' (h.trans h') := by + subst h h' + simp + +/-- The stage projection intertwines the symmetric-power and stage +transports. -/ +@[reassoc] +theorem modTensorπ_chainStageCast + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + {j k : ℕ} (h : j = k) : + modTensorπ A (symPowMod A M'.X j) (symPowMod A M.X j) ≫ + chainStageCast A M M' h = + (symPowCast A M'.X (congrArg Nat.succ h) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ h)) ≫ + modTensorπ A (symPowMod A M'.X k) (symPowMod A M.X k) := by + subst h + simp only [chainStageCast_rfl, symPowCast_rfl, + MonoidalCategory.id_tensorHom_id] + exact (Category.comp_id _).trans (Category.id_comp _).symm + +end StageCast + +/-! ## Epimorphy of whiskered stage projections -/ + +section EpiKit + +/-- The module-tensor projection is an epimorphism. -/ +instance epi_modTensorπ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (N : Mod D A) (P : Mod D A) : + Epi (modTensorπ A N P) := + ⟨fun _ _ w => modTensor_hom_ext A N P w⟩ + +/-- The right-whiskered module-tensor projection is an +epimorphism. -/ +instance epi_modTensorπ_whiskerRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] (N : Mod D A) (P : Mod D A) + (W : D) : + Epi (modTensorπ A N P ▷ W) := + ⟨fun _ _ w => modTensor_whiskerR_hom_ext A N P W w⟩ + +/-- The left-whiskered module-tensor projection is an +epimorphism. -/ +instance epi_whiskerLeft_modTensorπ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (N : Mod D A) (P : Mod D A) + (Q : D) : + Epi (Q ◁ modTensorπ A N P) := + ⟨fun _ _ w => modTensor_whisker_hom_ext A N P Q w⟩ + +/-- Whiskering the module-tensor coequalizer on the right and then +on the left still yields a colimit cofork. -/ +noncomputable def modTensorWhiskerRLIsColimit + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] (N : Mod D A) (P : Mod D A) + (W Q : D) : + IsColimit (Cofork.ofπ (Q ◁ (modTensorπ A N P ▷ W)) + (by rw [← MonoidalCategory.whiskerLeft_comp, + ← comp_whiskerRight, modTensor_condition, + comp_whiskerRight, MonoidalCategory.whiskerLeft_comp]) : + Cofork (Q ◁ (modTensorLegM A N P ▷ W)) + (Q ◁ (modTensorLegN A N P ▷ W))) := + isColimitCoforkMapOfIsColimit (tensorLeft Q) _ + (modTensorWhiskerRIsColimit A N P W) + +/-- The doubly whiskered module-tensor projection is an +epimorphism. -/ +instance epi_whiskerLeft_modTensorπ_whiskerRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] (N : Mod D A) (P : Mod D A) + (W Q : D) : + Epi (Q ◁ (modTensorπ A N P ▷ W)) := + epi_of_isColimit_cofork (modTensorWhiskerRLIsColimit A N P W Q) + +/-- A projection whiskered on the right by two objects is an +epimorphism. -/ +instance epi_modTensorπ_whiskerRight_whiskerRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] (N : Mod D A) (P : Mod D A) + (V W : D) : + Epi ((modTensorπ A N P ▷ V) ▷ W) := by + rw [show (modTensorπ A N P ▷ V) ▷ W = + (α_ (N.X ⊗ P.X) V W).hom ≫ + (modTensorπ A N P ▷ (V ⊗ W)) ≫ + (α_ (modTensor A N P) V W).inv by + simp [MonoidalCategory.whiskerRight_tensor]] + infer_instance + +/-- A projection whiskered on the left and then on the right is an +epimorphism. -/ +instance epi_whiskerLeft_modTensorπ_whiskerRight' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] (N : Mod D A) (P : Mod D A) + (Q W : D) : + Epi ((Q ◁ modTensorπ A N P) ▷ W) := by + rw [MonoidalCategory.whisker_assoc] + infer_instance + +/-- A projection whiskered on the left by two objects is an +epimorphism. -/ +instance epi_whiskerLeft_whiskerLeft_modTensorπ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (N : Mod D A) (P : Mod D A) + (Q R : D) : + Epi (Q ◁ (R ◁ modTensorπ A N P)) := by + rw [show Q ◁ (R ◁ modTensorπ A N P) = + (α_ Q R (N.X ⊗ P.X)).inv ≫ + ((Q ⊗ R) ◁ modTensorπ A N P) ≫ + (α_ Q R (modTensor A N P)).hom by monoidal] + infer_instance + +/-- The tensor product of two module-tensor projections is an +epimorphism. -/ +instance epi_modTensorπ_tensorHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] (N : Mod D A) (P : Mod D A) (Q : Mod D A) + (R : Mod D A) : + Epi (modTensorπ A N P ⊗ₘ modTensorπ A Q R) := by + rw [MonoidalCategory.tensorHom_def] + infer_instance + +/-- The right-whiskered tensor product of two projections is an +epimorphism. -/ +instance epi_modTensorπ_tensorHom_whiskerRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] (N : Mod D A) (P : Mod D A) (Q : Mod D A) + (R : Mod D A) + (W : D) : + Epi ((modTensorπ A N P ⊗ₘ modTensorπ A Q R) ▷ W) := by + rw [MonoidalCategory.tensorHom_def, comp_whiskerRight] + infer_instance + +/-- The left-whiskered tensor product of two projections is an +epimorphism. -/ +instance epi_modTensorπ_tensorHom_whiskerLeft + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] (N : Mod D A) (P : Mod D A) (Q : Mod D A) + (R : Mod D A) + (W : D) : + Epi (W ◁ (modTensorπ A N P ⊗ₘ modTensorπ A Q R)) := by + rw [MonoidalCategory.tensorHom_def, + MonoidalCategory.whiskerLeft_comp] + infer_instance + +/-- The tensored triple of module-tensor projections is an +epimorphism. -/ +instance epi_modTensorπ_tensorHom_tensorHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] (N : Mod D A) (P : Mod D A) (Q : Mod D A) + (R : Mod D A) (S : Mod D A) (T : Mod D A) : + Epi ((modTensorπ A N P ⊗ₘ modTensorπ A Q R) ⊗ₘ + modTensorπ A S T) := by + rw [MonoidalCategory.tensorHom_def] + infer_instance + +end EpiKit + +/-! ## Symmetric-power laws with transported arities -/ + +section SymCast + +/-- Commutativity of the symmetric multiplication, with both sides +transported to a common arity. -/ +private theorem symMul_comm_cast + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (X : D) [ModObj A X] + {a b c : ℕ} (h : b + a = c) + (h' : a + b = c) : + (β_ (symPow A X a) (symPow A X b)).hom ≫ symMul A X b a ≫ + symPowCast A X h = + symMul A X a b ≫ symPowCast A X h' := by + subst h + rw [symPowCast_rfl, Category.comp_id] + exact symMul_comm A X a b + +end SymCast + +/-! ## Commutativity of the chain multiplication -/ + +section ChainComm + +private theorem chainMul_comm_factors + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (m n : ℕ) + (h₀ : n + 1 + m = m + 1 + n) : + (((β_ (symPow A M'.X (m + 1)) + (symPow A M'.X (n + 1))).hom ≫ + symMul A M'.X (n + 1) (m + 1)) ≫ + symPowCast A M'.X (congrArg Nat.succ h₀) = + symMul A M'.X (m + 1) (n + 1)) ∧ + (((β_ (symPow A M.X (m + 1)) + (symPow A M.X (n + 1))).hom ≫ + symMul A M.X (n + 1) (m + 1)) ≫ + symPowCast A M.X (congrArg Nat.succ h₀) = + symMul A M.X (m + 1) (n + 1)) := by + have hfac₁ : + (β_ (symPow A M'.X (m + 1)) (symPow A M'.X (n + 1))).hom ≫ + symMul A M'.X (n + 1) (m + 1) ≫ + symPowCast A M'.X (congrArg Nat.succ h₀) = + symMul A M'.X (m + 1) (n + 1) ≫ + symPowCast A M'.X + (rfl : m + 1 + (n + 1) = m + 1 + (n + 1)) := + symMul_comm_cast A M'.X (congrArg Nat.succ h₀) rfl + have hfac₂ : + (β_ (symPow A M.X (m + 1)) (symPow A M.X (n + 1))).hom ≫ + symMul A M.X (n + 1) (m + 1) ≫ + symPowCast A M.X (congrArg Nat.succ h₀) = + symMul A M.X (m + 1) (n + 1) ≫ + symPowCast A M.X + (rfl : m + 1 + (n + 1) = m + 1 + (n + 1)) := + symMul_comm_cast A M.X (congrArg Nat.succ h₀) rfl + have hkill₁ : symMul A M'.X (m + 1) (n + 1) ≫ + symPowCast A M'.X + (rfl : m + 1 + (n + 1) = m + 1 + (n + 1)) = + symMul A M'.X (m + 1) (n + 1) := by + rw [symPowCast_rfl, Category.comp_id] + have hkill₂ : symMul A M.X (m + 1) (n + 1) ≫ + symPowCast A M.X + (rfl : m + 1 + (n + 1) = m + 1 + (n + 1)) = + symMul A M.X (m + 1) (n + 1) := by + rw [symPowCast_rfl, Category.comp_id] + have hfacL₁ : ((β_ (symPow A M'.X (m + 1)) + (symPow A M'.X (n + 1))).hom ≫ + symMul A M'.X (n + 1) (m + 1)) ≫ + symPowCast A M'.X (congrArg Nat.succ h₀) = + symMul A M'.X (m + 1) (n + 1) := + (Category.assoc _ _ _).trans (hfac₁.trans hkill₁) + have hfacL₂ : ((β_ (symPow A M.X (m + 1)) + (symPow A M.X (n + 1))).hom ≫ + symMul A M.X (n + 1) (m + 1)) ≫ + symPowCast A M.X (congrArg Nat.succ h₀) = + symMul A M.X (m + 1) (n + 1) := + (Category.assoc _ _ _).trans (hfac₂.trans hkill₂) + exact ⟨hfacL₁, hfacL₂⟩ + +/-- **Commutativity of the chain multiplication**, up to the stage +transport of `n + 1 + m = m + 1 + n`. -/ +theorem chainMul_comm + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (m n : ℕ) : + (β_ (chainStage A M M' m) (chainStage A M M' n)).hom ≫ + chainMul A M M' n m ≫ + chainStageCast A M M' (by omega : n + 1 + m = m + 1 + n) = + chainMul A M M' m n := by + have h₀ : n + 1 + m = m + 1 + n := by omega + obtain ⟨hfacL₁, hfacL₂⟩ := chainMul_comm_factors A M M' m n h₀ + have hβ : + (modTensorπ A (symPowMod A M'.X m) (symPowMod A M.X m) ⊗ₘ + modTensorπ A (symPowMod A M'.X n) (symPowMod A M.X n)) ≫ + (β_ (chainStage A M M' m) (chainStage A M M' n)).hom = + (β_ (symPow A M'.X (m + 1) ⊗ symPow A M.X (m + 1)) + (symPow A M'.X (n + 1) ⊗ symPow A M.X (n + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X n) (symPowMod A M.X n) ⊗ₘ + modTensorπ A (symPowMod A M'.X m) (symPowMod A M.X m)) := + BraidedCategory.braiding_naturality _ _ + refine (cancel_epi + (modTensorπ A (symPowMod A M'.X m) (symPowMod A M.X m) ⊗ₘ + modTensorπ A (symPowMod A M'.X n) (symPowMod A M.X n))).mp ?_ + have e1 : (modTensorπ A (symPowMod A M'.X m) + (symPowMod A M.X m) ⊗ₘ + modTensorπ A (symPowMod A M'.X n) (symPowMod A M.X n)) ≫ + ((β_ (chainStage A M M' m) (chainStage A M M' n)).hom ≫ + chainMul A M M' n m ≫ chainStageCast A M M' h₀) = + (β_ (symPow A M'.X (m + 1) ⊗ symPow A M.X (m + 1)) + (symPow A M'.X (n + 1) ⊗ symPow A M.X (n + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X n) (symPowMod A M.X n) ⊗ₘ + modTensorπ A (symPowMod A M'.X m) (symPowMod A M.X m)) ≫ + chainMul A M M' n m ≫ chainStageCast A M M' h₀ := + (Category.assoc _ _ _).symm.trans + ((congrArg (fun t => t ≫ (chainMul A M M' n m ≫ + chainStageCast A M M' h₀)) hβ).trans + (Category.assoc _ _ _)) + have e2 : (β_ (symPow A M'.X (m + 1) ⊗ symPow A M.X (m + 1)) + (symPow A M'.X (n + 1) ⊗ symPow A M.X (n + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X n) (symPowMod A M.X n) ⊗ₘ + modTensorπ A (symPowMod A M'.X m) (symPowMod A M.X m)) ≫ + chainMul A M M' n m ≫ chainStageCast A M M' h₀ = + (β_ (symPow A M'.X (m + 1) ⊗ symPow A M.X (m + 1)) + (symPow A M'.X (n + 1) ⊗ symPow A M.X (n + 1))).hom ≫ + tensorμ (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) + (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) ≫ + (symMul A M'.X (n + 1) (m + 1) ⊗ₘ + symMul A M.X (n + 1) (m + 1)) ≫ + (modTensorπ A (symPowMod A M'.X (n + 1 + m)) + (symPowMod A M.X (n + 1 + m)) ≫ + chainStageCast A M M' h₀) := + congrArg (CategoryStruct.comp _) + ((Category.assoc _ _ _).symm.trans + ((congrArg (fun t => t ≫ chainStageCast A M M' h₀) + (tensorHom_π_chainMul A M M' n m)).trans + ((Category.assoc _ _ _).trans + (congrArg (CategoryStruct.comp _) + (Category.assoc _ _ _))))) + have e3 : (β_ (symPow A M'.X (m + 1) ⊗ symPow A M.X (m + 1)) + (symPow A M'.X (n + 1) ⊗ symPow A M.X (n + 1))).hom ≫ + tensorμ (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) + (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) ≫ + (symMul A M'.X (n + 1) (m + 1) ⊗ₘ + symMul A M.X (n + 1) (m + 1)) ≫ + (modTensorπ A (symPowMod A M'.X (n + 1 + m)) + (symPowMod A M.X (n + 1 + m)) ≫ + chainStageCast A M M' h₀) = + (β_ (symPow A M'.X (m + 1) ⊗ symPow A M.X (m + 1)) + (symPow A M'.X (n + 1) ⊗ symPow A M.X (n + 1))).hom ≫ + tensorμ (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) + (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) ≫ + (symMul A M'.X (n + 1) (m + 1) ⊗ₘ + symMul A M.X (n + 1) (m + 1)) ≫ + ((symPowCast A M'.X (congrArg Nat.succ h₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ h₀)) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n)) + (symPowMod A M.X (m + 1 + n))) := + congrArg (CategoryStruct.comp _) + (congrArg (CategoryStruct.comp _) + (congrArg (CategoryStruct.comp _) + (modTensorπ_chainStageCast A M M' h₀))) + have e4 : (β_ (symPow A M'.X (m + 1) ⊗ symPow A M.X (m + 1)) + (symPow A M'.X (n + 1) ⊗ symPow A M.X (n + 1))).hom ≫ + tensorμ (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) + (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) ≫ + (symMul A M'.X (n + 1) (m + 1) ⊗ₘ + symMul A M.X (n + 1) (m + 1)) ≫ + ((symPowCast A M'.X (congrArg Nat.succ h₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ h₀)) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n)) + (symPowMod A M.X (m + 1 + n))) = + tensorμ (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) + (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) ≫ + ((β_ (symPow A M'.X (m + 1)) (symPow A M'.X (n + 1))).hom + ⊗ₘ (β_ (symPow A M.X (m + 1)) + (symPow A M.X (n + 1))).hom) ≫ + (symMul A M'.X (n + 1) (m + 1) ⊗ₘ + symMul A M.X (n + 1) (m + 1)) ≫ + ((symPowCast A M'.X (congrArg Nat.succ h₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ h₀)) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n)) + (symPowMod A M.X (m + 1 + n))) := + tensorμ_braiding_assoc _ _ _ _ _ + have e5 : tensorμ (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) + (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) ≫ + ((β_ (symPow A M'.X (m + 1)) (symPow A M'.X (n + 1))).hom + ⊗ₘ (β_ (symPow A M.X (m + 1)) + (symPow A M.X (n + 1))).hom) ≫ + (symMul A M'.X (n + 1) (m + 1) ⊗ₘ + symMul A M.X (n + 1) (m + 1)) ≫ + ((symPowCast A M'.X (congrArg Nat.succ h₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ h₀)) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n)) + (symPowMod A M.X (m + 1 + n))) = + tensorμ (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) + (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) ≫ + (((β_ (symPow A M'.X (m + 1)) + (symPow A M'.X (n + 1))).hom ≫ + symMul A M'.X (n + 1) (m + 1)) ⊗ₘ + ((β_ (symPow A M.X (m + 1)) + (symPow A M.X (n + 1))).hom ≫ + symMul A M.X (n + 1) (m + 1))) ≫ + ((symPowCast A M'.X (congrArg Nat.succ h₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ h₀)) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n)) + (symPowMod A M.X (m + 1 + n))) := + congrArg (CategoryStruct.comp _) + (MonoidalCategory.tensorHom_comp_tensorHom_assoc _ _ _ _ _) + have e6 : tensorμ (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) + (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) ≫ + (((β_ (symPow A M'.X (m + 1)) + (symPow A M'.X (n + 1))).hom ≫ + symMul A M'.X (n + 1) (m + 1)) ⊗ₘ + ((β_ (symPow A M.X (m + 1)) + (symPow A M.X (n + 1))).hom ≫ + symMul A M.X (n + 1) (m + 1))) ≫ + ((symPowCast A M'.X (congrArg Nat.succ h₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ h₀)) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n)) + (symPowMod A M.X (m + 1 + n))) = + tensorμ (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) + (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) ≫ + ((((β_ (symPow A M'.X (m + 1)) + (symPow A M'.X (n + 1))).hom ≫ + symMul A M'.X (n + 1) (m + 1)) ≫ + symPowCast A M'.X (congrArg Nat.succ h₀)) ⊗ₘ + (((β_ (symPow A M.X (m + 1)) + (symPow A M.X (n + 1))).hom ≫ + symMul A M.X (n + 1) (m + 1)) ≫ + symPowCast A M.X (congrArg Nat.succ h₀))) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n)) + (symPowMod A M.X (m + 1 + n)) := + congrArg (CategoryStruct.comp _) + (MonoidalCategory.tensorHom_comp_tensorHom_assoc _ _ _ _ _) + have e7 : tensorμ (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) + (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) ≫ + ((((β_ (symPow A M'.X (m + 1)) + (symPow A M'.X (n + 1))).hom ≫ + symMul A M'.X (n + 1) (m + 1)) ≫ + symPowCast A M'.X (congrArg Nat.succ h₀)) ⊗ₘ + (((β_ (symPow A M.X (m + 1)) + (symPow A M.X (n + 1))).hom ≫ + symMul A M.X (n + 1) (m + 1)) ≫ + symPowCast A M.X (congrArg Nat.succ h₀))) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n)) + (symPowMod A M.X (m + 1 + n)) = + tensorμ (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) + (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) ≫ + (symMul A M'.X (m + 1) (n + 1) ⊗ₘ + symMul A M.X (m + 1) (n + 1)) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n)) + (symPowMod A M.X (m + 1 + n)) := + congrArg (CategoryStruct.comp _) + (congrArg (fun t => t ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n)) + (symPowMod A M.X (m + 1 + n))) + (congrArg₂ (· ⊗ₘ ·) hfacL₁ hfacL₂)) + exact e1.trans (e2.trans (e3.trans (e4.trans (e5.trans + (e6.trans (e7.trans (tensorHom_π_chainMul A M M' m n).symm)))))) + +end ChainComm + +/-! ## Tensor surgery and the associativity core -/ + +section TensorSurgery + +/-- Absorb a whiskered morphism into the first tensor factor. -/ +private theorem tensorHom_whiskerRight_comp + [Category.{v} D] [MonoidalCategory D] + {X₁ X₂ Y₁ Y₂ Z₁ W : D} (a : X₁ ⟶ Y₁) (b : X₂ ⟶ Y₂) + (f : Y₁ ⟶ Z₁) (r : Z₁ ⊗ Y₂ ⟶ W) : + (a ⊗ₘ b) ≫ (f ▷ Y₂) ≫ r = ((a ≫ f) ⊗ₘ b) ≫ r := by + rw [← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom_assoc, + Category.comp_id] + +/-- Absorb a whiskered morphism into the second tensor factor. -/ +private theorem tensorHom_whiskerLeft_comp [Category.{v} D] [MonoidalCategory D] + {X₁ X₂ Y₁ Y₂ Z₂ W : D} (a : X₁ ⟶ Y₁) (b : X₂ ⟶ Y₂) + (g : Y₂ ⟶ Z₂) (r : Y₁ ⊗ Z₂ ⟶ W) : + (a ⊗ₘ b) ≫ (Y₁ ◁ g) ≫ r = (a ⊗ₘ (b ≫ g)) ≫ r := by + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom_assoc, + Category.comp_id] + +/-- Extract a prefix of the first tensor factor as a whisker. -/ +private theorem compTensorHom_whiskerRight_split + [Category.{v} D] [MonoidalCategory D] + {V₁ W₁ U₁ X₂ U₂ Z : D} (x : V₁ ⟶ W₁) (q₁ : W₁ ⟶ U₁) + (q₂ : X₂ ⟶ U₂) (r : U₁ ⊗ U₂ ⟶ Z) : + ((x ≫ q₁) ⊗ₘ q₂) ≫ r = (x ▷ X₂) ≫ (q₁ ⊗ₘ q₂) ≫ r := by + rw [MonoidalCategory.tensorHom_def, + MonoidalCategory.tensorHom_def, comp_whiskerRight] + simp only [Category.assoc] + +/-- Extract a prefix of the second tensor factor as a whisker. -/ +private theorem compTensorHom_whiskerLeft_split + [Category.{v} D] [MonoidalCategory D] + {X₁ U₁ V₂ W₂ U₂ Z : D} (q₁ : X₁ ⟶ U₁) (x : V₂ ⟶ W₂) + (q₂ : W₂ ⟶ U₂) (r : U₁ ⊗ U₂ ⟶ Z) : + (q₁ ⊗ₘ (x ≫ q₂)) ≫ r = (X₁ ◁ x) ≫ (q₁ ⊗ₘ q₂) ≫ r := by + rw [MonoidalCategory.tensorHom_def', + MonoidalCategory.tensorHom_def', + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + +/-- **The coherence core of associativity**: two interchanged pair +multiplications reassociate through `tensorμ` whenever each factor +satisfies the corresponding one-object associativity law. -/ +private theorem chainMulAssoc_core + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + {a₁ a₂ c₁ c₂ e₁ e₂ x₁ x₂ z₁ z₂ + t₁ t₂ Z : D} + {u₁ : a₁ ⊗ c₁ ⟶ x₁} {u₂ : a₂ ⊗ c₂ ⟶ x₂} + {w₁ : c₁ ⊗ e₁ ⟶ z₁} {w₂ : c₂ ⊗ e₂ ⟶ z₂} + {v₁ : x₁ ⊗ e₁ ⟶ t₁} {v₂ : x₂ ⊗ e₂ ⟶ t₂} + {v'₁ : a₁ ⊗ z₁ ⟶ t₁} {v'₂ : a₂ ⊗ z₂ ⟶ t₂} + (h₁ : (u₁ ▷ e₁) ≫ v₁ = + (α_ a₁ c₁ e₁).hom ≫ (a₁ ◁ w₁) ≫ v'₁) + (h₂ : (u₂ ▷ e₂) ≫ v₂ = + (α_ a₂ c₂ e₂).hom ≫ (a₂ ◁ w₂) ≫ v'₂) + (out : t₁ ⊗ t₂ ⟶ Z) : + ((tensorμ a₁ a₂ c₁ c₂ ≫ (u₁ ⊗ₘ u₂)) ▷ (e₁ ⊗ e₂)) ≫ + tensorμ x₁ x₂ e₁ e₂ ≫ (v₁ ⊗ₘ v₂) ≫ out = + (α_ (a₁ ⊗ a₂) (c₁ ⊗ c₂) (e₁ ⊗ e₂)).hom ≫ + ((a₁ ⊗ a₂) ◁ (tensorμ c₁ c₂ e₁ e₂ ≫ (w₁ ⊗ₘ w₂))) ≫ + tensorμ a₁ a₂ z₁ z₂ ≫ (v'₁ ⊗ₘ v'₂) ≫ out := by + conv_lhs => rw [comp_whiskerRight, Category.assoc, + tensorμ_natural_left_assoc, + MonoidalCategory.tensorHom_comp_tensorHom_assoc, h₁, h₂, + ← MonoidalCategory.tensorHom_comp_tensorHom_assoc, + tensor_associativity_assoc] + conv_rhs => rw [MonoidalCategory.whiskerLeft_comp, + Category.assoc, tensorμ_natural_right_assoc, + MonoidalCategory.tensorHom_comp_tensorHom_assoc] + +end TensorSurgery + +/-! ## Associativity of the chain multiplication -/ + +section ChainAssoc + +private theorem chainMul_assoc_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (m n p : ℕ) : + ((modTensorπ A (symPowMod A M'.X m) + (symPowMod A M.X m) ⊗ₘ + modTensorπ A (symPowMod A M'.X n) (symPowMod A M.X n)) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X p)) ≫ + ((chainMul A M M' m n ▷ chainStage A M M' p) ≫ + chainMul A M M' (m + 1 + n) p ≫ + chainStageCast A M M' + (rfl : m + 1 + n + 1 + p = m + 1 + n + 1 + p)) = + ((tensorμ (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) + (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) ≫ + (symMul A M'.X (m + 1) (n + 1) ⊗ₘ + symMul A M.X (m + 1) (n + 1))) ▷ + (symPow A M'.X (p + 1) ⊗ symPow A M.X (p + 1))) ≫ + tensorμ (symPow A M'.X (m + 1 + n + 1)) + (symPow A M.X (m + 1 + n + 1)) + (symPow A M'.X (p + 1)) (symPow A M.X (p + 1)) ≫ + (symMul A M'.X (m + 1 + n + 1) (p + 1) ⊗ₘ + symMul A M.X (m + 1 + n + 1) (p + 1)) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n + 1 + p)) + (symPowMod A M.X (m + 1 + n + 1 + p)) := by + have hK : chainMul A M M' (m + 1 + n) p ≫ + chainStageCast A M M' + (rfl : m + 1 + n + 1 + p = m + 1 + n + 1 + p) = + chainMul A M M' (m + 1 + n) p := by + rw [chainStageCast_rfl, Category.comp_id] + have l1 : ((modTensorπ A (symPowMod A M'.X m) + (symPowMod A M.X m) ⊗ₘ + modTensorπ A (symPowMod A M'.X n) (symPowMod A M.X n)) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X p)) ≫ + ((chainMul A M M' m n ▷ chainStage A M M' p) ≫ + chainMul A M M' (m + 1 + n) p ≫ + chainStageCast A M M' + (rfl : m + 1 + n + 1 + p = m + 1 + n + 1 + p)) = + ((modTensorπ A (symPowMod A M'.X m) (symPowMod A M.X m) ⊗ₘ + modTensorπ A (symPowMod A M'.X n) (symPowMod A M.X n)) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X p)) ≫ + ((chainMul A M M' m n ▷ chainStage A M M' p) ≫ + chainMul A M M' (m + 1 + n) p) := + congrArg (CategoryStruct.comp _) + (congrArg (CategoryStruct.comp _) hK) + have l2 : ((modTensorπ A (symPowMod A M'.X m) + (symPowMod A M.X m) ⊗ₘ + modTensorπ A (symPowMod A M'.X n) (symPowMod A M.X n)) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X p)) ≫ + ((chainMul A M M' m n ▷ chainStage A M M' p) ≫ + chainMul A M M' (m + 1 + n) p) = + (((modTensorπ A (symPowMod A M'.X m) (symPowMod A M.X m) ⊗ₘ + modTensorπ A (symPowMod A M'.X n) (symPowMod A M.X n)) ≫ + chainMul A M M' m n) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X p)) ≫ + chainMul A M M' (m + 1 + n) p := + tensorHom_whiskerRight_comp _ _ _ _ + have l3 : (((modTensorπ A (symPowMod A M'.X m) + (symPowMod A M.X m) ⊗ₘ + modTensorπ A (symPowMod A M'.X n) (symPowMod A M.X n)) ≫ + chainMul A M M' m n) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X p)) ≫ + chainMul A M M' (m + 1 + n) p = + ((tensorμ (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) + (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) ≫ + (symMul A M'.X (m + 1) (n + 1) ⊗ₘ + symMul A M.X (m + 1) (n + 1)) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n)) + (symPowMod A M.X (m + 1 + n))) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X p)) ≫ + chainMul A M M' (m + 1 + n) p := + congrArg (fun t => (t ⊗ₘ + modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X p)) ≫ + chainMul A M M' (m + 1 + n) p) + (tensorHom_π_chainMul A M M' m n) + have l4 : ((tensorμ (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) + (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) ≫ + (symMul A M'.X (m + 1) (n + 1) ⊗ₘ + symMul A M.X (m + 1) (n + 1)) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n)) + (symPowMod A M.X (m + 1 + n))) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X p)) ≫ + chainMul A M M' (m + 1 + n) p = + (((tensorμ (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) + (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) ≫ + (symMul A M'.X (m + 1) (n + 1) ⊗ₘ + symMul A M.X (m + 1) (n + 1))) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n)) + (symPowMod A M.X (m + 1 + n))) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X p)) ≫ + chainMul A M M' (m + 1 + n) p := + congrArg (fun t => (t ⊗ₘ + modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X p)) ≫ + chainMul A M M' (m + 1 + n) p) + (Category.assoc _ _ _).symm + have l5 : (((tensorμ (symPow A M'.X (m + 1)) + (symPow A M.X (m + 1)) + (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) ≫ + (symMul A M'.X (m + 1) (n + 1) ⊗ₘ + symMul A M.X (m + 1) (n + 1))) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n)) + (symPowMod A M.X (m + 1 + n))) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X p)) ≫ + chainMul A M M' (m + 1 + n) p = + ((tensorμ (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) + (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) ≫ + (symMul A M'.X (m + 1) (n + 1) ⊗ₘ + symMul A M.X (m + 1) (n + 1))) ▷ + (symPow A M'.X (p + 1) ⊗ symPow A M.X (p + 1))) ≫ + (modTensorπ A (symPowMod A M'.X (m + 1 + n)) + (symPowMod A M.X (m + 1 + n)) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X p)) ≫ + chainMul A M M' (m + 1 + n) p := + compTensorHom_whiskerRight_split _ _ _ _ + have l6 : ((tensorμ (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) + (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) ≫ + (symMul A M'.X (m + 1) (n + 1) ⊗ₘ + symMul A M.X (m + 1) (n + 1))) ▷ + (symPow A M'.X (p + 1) ⊗ symPow A M.X (p + 1))) ≫ + (modTensorπ A (symPowMod A M'.X (m + 1 + n)) + (symPowMod A M.X (m + 1 + n)) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X p)) ≫ + chainMul A M M' (m + 1 + n) p = + ((tensorμ (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) + (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) ≫ + (symMul A M'.X (m + 1) (n + 1) ⊗ₘ + symMul A M.X (m + 1) (n + 1))) ▷ + (symPow A M'.X (p + 1) ⊗ symPow A M.X (p + 1))) ≫ + tensorμ (symPow A M'.X (m + 1 + n + 1)) + (symPow A M.X (m + 1 + n + 1)) + (symPow A M'.X (p + 1)) (symPow A M.X (p + 1)) ≫ + (symMul A M'.X (m + 1 + n + 1) (p + 1) ⊗ₘ + symMul A M.X (m + 1 + n + 1) (p + 1)) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n + 1 + p)) + (symPowMod A M.X (m + 1 + n + 1 + p)) := + congrArg (CategoryStruct.comp _) + (tensorHom_π_chainMul A M M' (m + 1 + n) p) + -- Right bridge: from the reassociated side to the instantiated + -- core's right-hand side. + exact l1.trans (l2.trans (l3.trans (l4.trans (l5.trans (l6))))) + +private theorem chainMul_assoc_rightTail + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (m n p : ℕ) + (h₂ : m + 1 + (n + 1 + p) = m + 1 + n + 1 + p) : + (modTensorπ A (symPowMod A M'.X m) + (symPowMod A M.X m) ⊗ₘ + modTensorπ A (symPowMod A M'.X (n + 1 + p)) + (symPowMod A M.X (n + 1 + p))) ≫ + (chainMul A M M' m (n + 1 + p) ≫ + chainStageCast A M M' h₂) = + tensorμ (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) + (symPow A M'.X (n + 1 + p + 1)) + (symPow A M.X (n + 1 + p + 1)) ≫ + ((symMul A M'.X (m + 1) (n + 1 + p + 1) ≫ + symPowCast A M'.X (congrArg Nat.succ h₂)) ⊗ₘ + (symMul A M.X (m + 1) (n + 1 + p + 1) ≫ + symPowCast A M.X (congrArg Nat.succ h₂))) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n + 1 + p)) + (symPowMod A M.X (m + 1 + n + 1 + p)) := by + have r6 : (modTensorπ A (symPowMod A M'.X m) + (symPowMod A M.X m) ⊗ₘ + modTensorπ A (symPowMod A M'.X (n + 1 + p)) + (symPowMod A M.X (n + 1 + p))) ≫ + (chainMul A M M' m (n + 1 + p) ≫ + chainStageCast A M M' h₂) = + tensorμ (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) + (symPow A M'.X (n + 1 + p + 1)) + (symPow A M.X (n + 1 + p + 1)) ≫ + (symMul A M'.X (m + 1) (n + 1 + p + 1) ⊗ₘ + symMul A M.X (m + 1) (n + 1 + p + 1)) ≫ + (modTensorπ A (symPowMod A M'.X (m + 1 + (n + 1 + p))) + (symPowMod A M.X (m + 1 + (n + 1 + p))) ≫ + chainStageCast A M M' h₂) := + (Category.assoc _ _ _).symm.trans + ((congrArg (fun t => t ≫ chainStageCast A M M' h₂) + (tensorHom_π_chainMul A M M' m (n + 1 + p))).trans + ((Category.assoc _ _ _).trans + (congrArg (CategoryStruct.comp _) + (Category.assoc _ _ _)))) + have r7 : modTensorπ A (symPowMod A M'.X (m + 1 + (n + 1 + p))) + (symPowMod A M.X (m + 1 + (n + 1 + p))) ≫ + chainStageCast A M M' h₂ = + (symPowCast A M'.X (congrArg Nat.succ h₂) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ h₂)) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n + 1 + p)) + (symPowMod A M.X (m + 1 + n + 1 + p)) := + modTensorπ_chainStageCast A M M' h₂ + have r8 : (symMul A M'.X (m + 1) (n + 1 + p + 1) ⊗ₘ + symMul A M.X (m + 1) (n + 1 + p + 1)) ≫ + ((symPowCast A M'.X (congrArg Nat.succ h₂) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ h₂)) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n + 1 + p)) + (symPowMod A M.X (m + 1 + n + 1 + p))) = + ((symMul A M'.X (m + 1) (n + 1 + p + 1) ≫ + symPowCast A M'.X (congrArg Nat.succ h₂)) ⊗ₘ + (symMul A M.X (m + 1) (n + 1 + p + 1) ≫ + symPowCast A M.X (congrArg Nat.succ h₂))) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n + 1 + p)) + (symPowMod A M.X (m + 1 + n + 1 + p)) := + MonoidalCategory.tensorHom_comp_tensorHom_assoc _ _ _ _ _ + have rTail : (modTensorπ A (symPowMod A M'.X m) + (symPowMod A M.X m) ⊗ₘ + modTensorπ A (symPowMod A M'.X (n + 1 + p)) + (symPowMod A M.X (n + 1 + p))) ≫ + (chainMul A M M' m (n + 1 + p) ≫ + chainStageCast A M M' h₂) = + tensorμ (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) + (symPow A M'.X (n + 1 + p + 1)) + (symPow A M.X (n + 1 + p + 1)) ≫ + ((symMul A M'.X (m + 1) (n + 1 + p + 1) ≫ + symPowCast A M'.X (congrArg Nat.succ h₂)) ⊗ₘ + (symMul A M.X (m + 1) (n + 1 + p + 1) ≫ + symPowCast A M.X (congrArg Nat.succ h₂))) ≫ + modTensorπ A (symPowMod A M'.X (m + 1 + n + 1 + p)) + (symPowMod A M.X (m + 1 + n + 1 + p)) := + r6.trans ((congrArg (CategoryStruct.comp _) + (congrArg (CategoryStruct.comp _) r7)).trans + (congrArg (CategoryStruct.comp _) r8)) + exact rTail + +/-- **Associativity of the chain multiplication**, up to the stage +transports onto the common arity `m + 1 + n + 1 + p`. -/ +theorem chainMul_assoc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (m n p : ℕ) : + (chainMul A M M' m n ▷ chainStage A M M' p) ≫ + chainMul A M M' (m + 1 + n) p ≫ + chainStageCast A M M' + (by omega : m + 1 + n + 1 + p = m + 1 + n + 1 + p) = + (α_ (chainStage A M M' m) (chainStage A M M' n) + (chainStage A M M' p)).hom ≫ + (chainStage A M M' m ◁ chainMul A M M' n p) ≫ + chainMul A M M' m (n + 1 + p) ≫ + chainStageCast A M M' + (by omega : m + 1 + (n + 1 + p) = m + 1 + n + 1 + p) := by + have h₂ : m + 1 + (n + 1 + p) = m + 1 + n + 1 + p := by omega + have hcore := chainMulAssoc_core + (symMul_assoc A M'.X (m + 1) (n + 1) (p + 1)) + (symMul_assoc A M.X (m + 1) (n + 1) (p + 1)) + (modTensorπ A (symPowMod A M'.X (m + 1 + n + 1 + p)) + (symPowMod A M.X (m + 1 + n + 1 + p))) + refine (cancel_epi + ((modTensorπ A (symPowMod A M'.X m) (symPowMod A M.X m) ⊗ₘ + modTensorπ A (symPowMod A M'.X n) (symPowMod A M.X n)) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X p))).mp ?_ + -- Left bridge: from the whiskered chain multiplication to the + -- instantiated core's left-hand side. + have hleft := chainMul_assoc_left A M M' m n p + have hα : ((modTensorπ A (symPowMod A M'.X m) + (symPowMod A M.X m) ⊗ₘ + modTensorπ A (symPowMod A M'.X n) (symPowMod A M.X n)) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X p)) ≫ + (α_ (chainStage A M M' m) (chainStage A M M' n) + (chainStage A M M' p)).hom = + (α_ (symPow A M'.X (m + 1) ⊗ symPow A M.X (m + 1)) + (symPow A M'.X (n + 1) ⊗ symPow A M.X (n + 1)) + (symPow A M'.X (p + 1) ⊗ symPow A M.X (p + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X m) (symPowMod A M.X m) ⊗ₘ + (modTensorπ A (symPowMod A M'.X n) + (symPowMod A M.X n) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X p))) := + associator_naturality _ _ _ + have r1 : ((modTensorπ A (symPowMod A M'.X m) + (symPowMod A M.X m) ⊗ₘ + modTensorπ A (symPowMod A M'.X n) (symPowMod A M.X n)) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X p)) ≫ + ((α_ (chainStage A M M' m) (chainStage A M M' n) + (chainStage A M M' p)).hom ≫ + (chainStage A M M' m ◁ chainMul A M M' n p) ≫ + chainMul A M M' m (n + 1 + p) ≫ + chainStageCast A M M' h₂) = + (α_ (symPow A M'.X (m + 1) ⊗ symPow A M.X (m + 1)) + (symPow A M'.X (n + 1) ⊗ symPow A M.X (n + 1)) + (symPow A M'.X (p + 1) ⊗ symPow A M.X (p + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X m) (symPowMod A M.X m) ⊗ₘ + (modTensorπ A (symPowMod A M'.X n) + (symPowMod A M.X n) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X p))) ≫ + ((chainStage A M M' m ◁ chainMul A M M' n p) ≫ + chainMul A M M' m (n + 1 + p) ≫ + chainStageCast A M M' h₂) := + (Category.assoc _ _ _).symm.trans + ((congrArg (fun t => t ≫ + ((chainStage A M M' m ◁ chainMul A M M' n p) ≫ + chainMul A M M' m (n + 1 + p) ≫ + chainStageCast A M M' h₂)) hα).trans + (Category.assoc _ _ _)) + have r2 : (α_ (symPow A M'.X (m + 1) ⊗ symPow A M.X (m + 1)) + (symPow A M'.X (n + 1) ⊗ symPow A M.X (n + 1)) + (symPow A M'.X (p + 1) ⊗ symPow A M.X (p + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X m) (symPowMod A M.X m) ⊗ₘ + (modTensorπ A (symPowMod A M'.X n) + (symPowMod A M.X n) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X p))) ≫ + ((chainStage A M M' m ◁ chainMul A M M' n p) ≫ + chainMul A M M' m (n + 1 + p) ≫ + chainStageCast A M M' h₂) = + (α_ (symPow A M'.X (m + 1) ⊗ symPow A M.X (m + 1)) + (symPow A M'.X (n + 1) ⊗ symPow A M.X (n + 1)) + (symPow A M'.X (p + 1) ⊗ symPow A M.X (p + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X m) (symPowMod A M.X m) ⊗ₘ + ((modTensorπ A (symPowMod A M'.X n) + (symPowMod A M.X n) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X p)) ≫ + chainMul A M M' n p)) ≫ + (chainMul A M M' m (n + 1 + p) ≫ + chainStageCast A M M' h₂) := + congrArg (CategoryStruct.comp _) + (tensorHom_whiskerLeft_comp _ _ _ _) + have r3 : (α_ (symPow A M'.X (m + 1) ⊗ symPow A M.X (m + 1)) + (symPow A M'.X (n + 1) ⊗ symPow A M.X (n + 1)) + (symPow A M'.X (p + 1) ⊗ symPow A M.X (p + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X m) (symPowMod A M.X m) ⊗ₘ + ((modTensorπ A (symPowMod A M'.X n) + (symPowMod A M.X n) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X p)) ≫ + chainMul A M M' n p)) ≫ + (chainMul A M M' m (n + 1 + p) ≫ + chainStageCast A M M' h₂) = + (α_ (symPow A M'.X (m + 1) ⊗ symPow A M.X (m + 1)) + (symPow A M'.X (n + 1) ⊗ symPow A M.X (n + 1)) + (symPow A M'.X (p + 1) ⊗ symPow A M.X (p + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X m) (symPowMod A M.X m) ⊗ₘ + (tensorμ (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) + (symPow A M'.X (p + 1)) (symPow A M.X (p + 1)) ≫ + (symMul A M'.X (n + 1) (p + 1) ⊗ₘ + symMul A M.X (n + 1) (p + 1)) ≫ + modTensorπ A (symPowMod A M'.X (n + 1 + p)) + (symPowMod A M.X (n + 1 + p)))) ≫ + (chainMul A M M' m (n + 1 + p) ≫ + chainStageCast A M M' h₂) := + congrArg (fun t => + (α_ (symPow A M'.X (m + 1) ⊗ symPow A M.X (m + 1)) + (symPow A M'.X (n + 1) ⊗ symPow A M.X (n + 1)) + (symPow A M'.X (p + 1) ⊗ symPow A M.X (p + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X m) + (symPowMod A M.X m) ⊗ₘ t) ≫ + (chainMul A M M' m (n + 1 + p) ≫ + chainStageCast A M M' h₂)) + (tensorHom_π_chainMul A M M' n p) + have r4 : (α_ (symPow A M'.X (m + 1) ⊗ symPow A M.X (m + 1)) + (symPow A M'.X (n + 1) ⊗ symPow A M.X (n + 1)) + (symPow A M'.X (p + 1) ⊗ symPow A M.X (p + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X m) (symPowMod A M.X m) ⊗ₘ + (tensorμ (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) + (symPow A M'.X (p + 1)) (symPow A M.X (p + 1)) ≫ + (symMul A M'.X (n + 1) (p + 1) ⊗ₘ + symMul A M.X (n + 1) (p + 1)) ≫ + modTensorπ A (symPowMod A M'.X (n + 1 + p)) + (symPowMod A M.X (n + 1 + p)))) ≫ + (chainMul A M M' m (n + 1 + p) ≫ + chainStageCast A M M' h₂) = + (α_ (symPow A M'.X (m + 1) ⊗ symPow A M.X (m + 1)) + (symPow A M'.X (n + 1) ⊗ symPow A M.X (n + 1)) + (symPow A M'.X (p + 1) ⊗ symPow A M.X (p + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X m) (symPowMod A M.X m) ⊗ₘ + ((tensorμ (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) + (symPow A M'.X (p + 1)) (symPow A M.X (p + 1)) ≫ + (symMul A M'.X (n + 1) (p + 1) ⊗ₘ + symMul A M.X (n + 1) (p + 1))) ≫ + modTensorπ A (symPowMod A M'.X (n + 1 + p)) + (symPowMod A M.X (n + 1 + p)))) ≫ + (chainMul A M M' m (n + 1 + p) ≫ + chainStageCast A M M' h₂) := + congrArg (fun t => + (α_ (symPow A M'.X (m + 1) ⊗ symPow A M.X (m + 1)) + (symPow A M'.X (n + 1) ⊗ symPow A M.X (n + 1)) + (symPow A M'.X (p + 1) ⊗ symPow A M.X (p + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X m) + (symPowMod A M.X m) ⊗ₘ t) ≫ + (chainMul A M M' m (n + 1 + p) ≫ + chainStageCast A M M' h₂)) + (Category.assoc _ _ _).symm + have r5 : (α_ (symPow A M'.X (m + 1) ⊗ symPow A M.X (m + 1)) + (symPow A M'.X (n + 1) ⊗ symPow A M.X (n + 1)) + (symPow A M'.X (p + 1) ⊗ symPow A M.X (p + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X m) (symPowMod A M.X m) ⊗ₘ + ((tensorμ (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) + (symPow A M'.X (p + 1)) (symPow A M.X (p + 1)) ≫ + (symMul A M'.X (n + 1) (p + 1) ⊗ₘ + symMul A M.X (n + 1) (p + 1))) ≫ + modTensorπ A (symPowMod A M'.X (n + 1 + p)) + (symPowMod A M.X (n + 1 + p)))) ≫ + (chainMul A M M' m (n + 1 + p) ≫ + chainStageCast A M M' h₂) = + (α_ (symPow A M'.X (m + 1) ⊗ symPow A M.X (m + 1)) + (symPow A M'.X (n + 1) ⊗ symPow A M.X (n + 1)) + (symPow A M'.X (p + 1) ⊗ symPow A M.X (p + 1))).hom ≫ + ((symPow A M'.X (m + 1) ⊗ symPow A M.X (m + 1)) ◁ + (tensorμ (symPow A M'.X (n + 1)) (symPow A M.X (n + 1)) + (symPow A M'.X (p + 1)) (symPow A M.X (p + 1)) ≫ + (symMul A M'.X (n + 1) (p + 1) ⊗ₘ + symMul A M.X (n + 1) (p + 1)))) ≫ + (modTensorπ A (symPowMod A M'.X m) (symPowMod A M.X m) ⊗ₘ + modTensorπ A (symPowMod A M'.X (n + 1 + p)) + (symPowMod A M.X (n + 1 + p))) ≫ + (chainMul A M M' m (n + 1 + p) ≫ + chainStageCast A M M' h₂) := + congrArg (CategoryStruct.comp _) + (compTensorHom_whiskerLeft_split _ _ _ _) + have rTail := chainMul_assoc_rightTail A M M' m n p h₂ + exact hleft.trans + (hcore.trans (r1.trans (r2.trans (r3.trans (r4.trans + (r5.trans (congrArg (CategoryStruct.comp _) + (congrArg (CategoryStruct.comp _) rTail))))))).symm) + +end ChainAssoc + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainNonzero.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainNonzero.lean new file mode 100644 index 0000000000..52e64feb25 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainNonzero.lean @@ -0,0 +1,121 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBridge +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransfer + +/-! +# Nonvanishing of the splitting-chain units + +The assembly of the Key Lemma's nonvanishing half: the chain unit +stage is the copair element of the symmetric-power duality datum, +up to the braiding of the module tensor product; so once the +symmetric-power datum satisfies the zigzag laws, a vanishing +stage unit kills the symmetric power. This is Deligne's +argument: `δⁿ` is the `δ` of a duality between the symmetric +powers (1.15.1), and the `δ` of a duality vanishes only on the +zero module. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The chain unit stage is the symmetric copair element**, up +to the braiding of the module tensor product: Deligne's 1.15.1 +composite. -/ +theorem chainUnitStage_eq_symCopair + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [CategoryTheory.Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (n : ℕ) : + chainUnitStage A M M' d n = + η[A] ≫ (symDualityDatum A M M' d n).copair ≫ + modTensorSwap A (symPowMod A M.X n) (symPowMod A M'.X n) := by + have h1 : (symDualityDatum A M M' d n).copair = + powCopairA A M M' d n ≫ + modTensorMap A (symPowπMod A n) (symPowπMod A n) := rfl + have hproj : projStage A M M' n = + modTensorMap A (symPowπMod A n) (symPowπMod A n) ≫ + modTensorSwap A (symPowMod A M.X n) + (symPowMod A M'.X n) := by + rw [projStage] + exact (modTensorMap_swap A (symPowπMod A n) + (symPowπMod A n)).symm + erw [h1, Category.assoc, ← powUnitStage_projStage A M M' d n, + hproj, reassoc_of% (powCopairA_unit A M M' d n)] + rfl + +/-- **Nonvanishing of the chain unit stages**: once the +symmetric-power datum satisfies the zigzag laws, the stage unit +detects the symmetric power. -/ +theorem chainUnitStage_ne_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [CategoryTheory.Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (n : ℕ) + (hz : ModZigzagDatum A (symDualityDatum A M M' d n)) + (hS : ¬ IsZero (symPow A M.X (n + 1))) : + chainUnitStage A M M' d n ≠ 0 := by + intro h0 + have hcop : η[A] ≫ (symDualityDatum A M M' d n).copair = 0 := by + have h2 : (η[A] ≫ (symDualityDatum A M M' d n).copair ≫ + modTensorSwap A (symPowMod A M.X n) + (symPowMod A M'.X n)) ≫ + modTensorSwap A (symPowMod A M'.X n) + (symPowMod A M.X n) = 0 := by + rw [← chainUnitStage_eq_symCopair, h0] + exact zero_comp + have h3 : η[A] ≫ (symDualityDatum A M M' d n).copair = + (η[A] ≫ (symDualityDatum A M M' d n).copair ≫ + modTensorSwap A (symPowMod A M.X n) + (symPowMod A M'.X n)) ≫ + modTensorSwap A (symPowMod A M'.X n) + (symPowMod A M.X n) := by + conv_rhs => rw [Category.assoc, Category.assoc, + modTensorSwap_modTensorSwap, Category.comp_id] + rw [h3] + exact h2 + have hM : ¬ IsZero ((symPowMod A M.X n).X) := hS + exact absurd + (isZero_of_unit_copair_eq_zero A + (symDualityDatum A M M' d n) hz hcop) hM + +/-- **Nonvanishing from the power-level zigzags**: composing the +detection with the symmetric-power inheritance. -/ +theorem chainUnitStage_ne_zero' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [CategoryTheory.Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (n : ℕ) + (hz : ModZigzagDatum A (powDualityDatum A M M' d n)) + (hS : ¬ IsZero (symPow A M.X (n + 1))) : + chainUnitStage A M M' d n ≠ 0 := + chainUnitStage_ne_zero A M M' d n + (symDualityDatum_zigzag A M M' d n hz) hS + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainShift.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainShift.lean new file mode 100644 index 0000000000..81cd96f41f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainShift.lean @@ -0,0 +1,216 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainAlgebra + +/-! +# Shifting a chain colimit by one stage + +Dropping the bottom stage of a chain does not change its colimit. +The stage inclusions of the full chain restrict to a cocone on the +shifted chain, giving the tail comparison; the transitions followed +by the shifted stage inclusions form a cocone on the full chain, +giving the comparison back. Both composites are identified with the +identities by the stagewise extensionality lemma. The +descent-from-legs helper `chainDesc` is factored out for reuse: any +family of legs absorbed by the transitions descends to the chain +colimit, with the stage computation exposed as a simp lemma. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Limits + +universe v u + +variable {E : Type u} + +/-- Legs absorbed by the transitions absorb all chain morphisms. -/ +theorem chainMap_legs [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + {Z : E} (legs : ∀ n, B n ⟶ Z) + (h : ∀ n, δ n ≫ legs (n + 1) = legs n) {a b : ℕ} + (hab : a ≤ b) : chainMap B δ hab ≫ legs b = legs a := by + induction b, hab using Nat.le_induction with + | base => rw [chainMap_self, Category.id_comp] + | succ b hab ih => + rw [chainMap_succ_of_le B δ hab, Category.assoc, h] + exact ih + +/-- The cocone on the chain diagram assembled from legs absorbed by +the transitions. -/ +noncomputable def chainCocone + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + {Z : E} (legs : ∀ n, B n ⟶ Z) + (h : ∀ n, δ n ≫ legs (n + 1) = legs n) : + Cocone (chainDiagram B δ) where + pt := Z + ι := + { app := fun k => legs (smallNatEquiv.inverse.obj k) + naturality := fun {k k'} f => by + change chainMap B δ (leOfHom (smallNatEquiv.inverse.map f)) ≫ + legs (smallNatEquiv.inverse.obj k') = + legs (smallNatEquiv.inverse.obj k) ≫ 𝟙 Z + rw [Category.comp_id] + exact chainMap_legs B δ legs h + (leOfHom (smallNatEquiv.inverse.map f)) } + +/-- The descent out of the chain colimit determined by legs absorbed +by the transitions. -/ +noncomputable def chainDesc + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] + {Z : E} (legs : ∀ n, B n ⟶ Z) + (h : ∀ n, δ n ≫ legs (n + 1) = legs n) : + chainColimit B δ ⟶ Z := + colimit.desc _ (chainCocone B δ legs h) + +/-- On a stage, the descent is the corresponding leg. -/ +@[reassoc (attr := simp)] +theorem ι_chainDesc [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] + {Z : E} (legs : ∀ n, B n ⟶ Z) + (h : ∀ n, δ n ≫ legs (n + 1) = legs n) (n : ℕ) : + chainColimitι B δ n ≫ chainDesc B δ legs h = legs n := + colimit.ι_desc (chainCocone B δ legs h) + (smallNatEquiv.functor.obj n) + +/-- The comparison from the colimit of the shifted chain, whose leg +at a stage is the next stage inclusion of the full chain. -/ +noncomputable def chainColimitTail + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] : + chainColimit (fun k => B (k + 1)) (fun k => δ (k + 1)) ⟶ + chainColimit B δ := + chainDesc (fun k => B (k + 1)) (fun k => δ (k + 1)) + (fun k => chainColimitι B δ (k + 1)) + (fun k => delta_chainColimitι B δ (k + 1)) + +/-- On a stage, the tail comparison is the next stage inclusion. -/ +@[reassoc (attr := simp)] +theorem ι_chainColimitTail + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] + (k : ℕ) : + chainColimitι (fun k => B (k + 1)) (fun k => δ (k + 1)) k ≫ + chainColimitTail B δ = + chainColimitι B δ (k + 1) := + ι_chainDesc (fun k => B (k + 1)) (fun k => δ (k + 1)) + (fun k => chainColimitι B δ (k + 1)) + (fun k => delta_chainColimitι B δ (k + 1)) k + +/-- The comparison to the colimit of the shifted chain, whose leg at +a stage is the transition followed by the shifted inclusion. -/ +noncomputable def chainColimitUntail + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] : + chainColimit B δ ⟶ + chainColimit (fun k => B (k + 1)) (fun k => δ (k + 1)) := + chainDesc B δ + (fun k => δ k ≫ + chainColimitι (fun k => B (k + 1)) (fun k => δ (k + 1)) k) + (fun k => + congrArg (fun t => δ k ≫ t) + (delta_chainColimitι (fun k => B (k + 1)) + (fun k => δ (k + 1)) k)) + +/-- On a stage, the comparison to the shifted colimit is the +transition followed by the shifted inclusion. -/ +@[reassoc (attr := simp)] +theorem ι_chainColimitUntail + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] + (k : ℕ) : + chainColimitι B δ k ≫ chainColimitUntail B δ = + δ k ≫ + chainColimitι (fun k => B (k + 1)) (fun k => δ (k + 1)) k := + ι_chainDesc B δ + (fun k => δ k ≫ + chainColimitι (fun k => B (k + 1)) (fun k => δ (k + 1)) k) + (fun k => + congrArg (fun t => δ k ≫ t) + (delta_chainColimitι (fun k => B (k + 1)) + (fun k => δ (k + 1)) k)) k + +/-- Dropping the bottom stage of a chain does not change the +colimit. -/ +noncomputable def chainColimitTailIso + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] : + chainColimit (fun k => B (k + 1)) (fun k => δ (k + 1)) ≅ + chainColimit B δ where + hom := chainColimitTail B δ + inv := chainColimitUntail B δ + hom_inv_id := by + apply chainColimit_hom_ext (fun k => B (k + 1)) + (fun k => δ (k + 1)) + intro n + rw [Category.comp_id, ι_chainColimitTail_assoc, + ι_chainColimitUntail] + exact delta_chainColimitι (fun k => B (k + 1)) + (fun k => δ (k + 1)) n + inv_hom_id := by + apply chainColimit_hom_ext B δ + intro n + rw [Category.comp_id, ι_chainColimitUntail_assoc, + ι_chainColimitTail] + exact delta_chainColimitι B δ n + +section MapIso + +/-- **The chain colimit is invariant under stagewise +isomorphism**: compatible stage isomorphisms induce an +isomorphism of the chain colimits. -/ +noncomputable def chainColimitMapIso + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] {C : ℕ → E} + (δC : ∀ n, C n ⟶ C (n + 1)) + (φ : ∀ n, B n ≅ C n) + (hφ : ∀ n, δ n ≫ (φ (n + 1)).hom = (φ n).hom ≫ δC n) : + chainColimit B δ ≅ chainColimit C δC where + hom := chainDesc B δ + (fun n => (φ n).hom ≫ chainColimitι C δC n) + (fun n => by + rw [← Category.assoc, hφ n, Category.assoc, + delta_chainColimitι]) + inv := chainDesc C δC + (fun n => (φ n).inv ≫ chainColimitι B δ n) + (fun n => by + have h : δC n ≫ (φ (n + 1)).inv = (φ n).inv ≫ δ n := by + rw [Iso.comp_inv_eq, Category.assoc, hφ n, + Iso.inv_hom_id_assoc] + rw [← Category.assoc, h, Category.assoc, + delta_chainColimitι]) + hom_inv_id := by + apply chainColimit_hom_ext B δ + intro n + rw [Category.comp_id, ← Category.assoc, ι_chainDesc, + Category.assoc, ι_chainDesc, Iso.hom_inv_id_assoc] + inv_hom_id := by + apply chainColimit_hom_ext C δC + intro n + rw [Category.comp_id, ← Category.assoc, ι_chainDesc, + Category.assoc, ι_chainDesc, Iso.inv_hom_id_assoc] + +/-- The stage insertions under the stagewise isomorphism. -/ +@[reassoc (attr := simp)] +theorem ι_chainColimitMapIso_hom + [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (n + 1)) + [HasColimitsOfShape SmallNat.{v} E] {C : ℕ → E} + (δC : ∀ n, C n ⟶ C (n + 1)) + (φ : ∀ n, B n ≅ C n) + (hφ : ∀ n, δ n ≫ (φ (n + 1)).hom = (φ n).hom ≫ δC n) + (n : ℕ) : + chainColimitι B δ n ≫ (chainColimitMapIso B δ δC φ hφ).hom = + (φ n).hom ≫ chainColimitι C δC n := + ι_chainDesc B δ _ _ n + +end MapIso + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainStage2.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainStage2.lean new file mode 100644 index 0000000000..9aefb00b3a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainStage2.lean @@ -0,0 +1,1215 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulLaws +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainDelta + +/-! +# The two-index splitting-chain stages + +The unbalanced generalisation of the splitting chain: stages carry +two independent symmetric-power arities, one for each slot of the +dual pair. The balanced chain is the diagonal. The stage +multiplication, its commutativity and associativity laws, and the +seed transitions all restate the balanced machinery at two free +indices; the substrate for the graded splitting algebra. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## The two-index stages -/ + +/-- A two-index stage of the splitting chain: the module tensor +product of independently sized symmetric powers of the dual +pair. -/ +noncomputable def chainStage2 + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q : ℕ) : D := + modTensor A (symPowMod A M'.X p) (symPowMod A M.X q) + +/-- The diagonal of the two-index stages is the balanced stage. -/ +@[simp] +theorem chainStage2_diag + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (k : ℕ) : + chainStage2 A M M' k k = chainStage A M M' k := rfl + +/-! ## Stage transports -/ + +section Stage2Cast + +/-- Transport of a two-index stage along equalities of arities. -/ +noncomputable def chainStage2Cast + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + {p q p' q' : ℕ} + (hp : p = p') (hq : q = q') : + chainStage2 A M M' p q ⟶ chainStage2 A M M' p' q' := + eqToHom (congrArg₂ (chainStage2 A M M') hp hq) + +/-- The trivial transport is the identity. -/ +@[simp] +theorem chainStage2Cast_rfl + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q : ℕ) : + chainStage2Cast A M M' (rfl : p = p) (rfl : q = q) = + 𝟙 _ := rfl + +/-- Stage transports compose. -/ +@[reassoc (attr := simp)] +theorem chainStage2Cast_trans + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + {p q p' q' p'' q'' : ℕ} + (hp : p = p') (hq : q = q') (hp' : p' = p'') + (hq' : q' = q'') : + chainStage2Cast A M M' hp hq ≫ + chainStage2Cast A M M' hp' hq' = + chainStage2Cast A M M' (hp.trans hp') (hq.trans hq') := by + subst hp hq hp' hq' + simp + +/-- The stage projection intertwines the symmetric-power and +two-index stage transports. -/ +@[reassoc] +theorem modTensorπ_chainStage2Cast + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + {p q p' q' : ℕ} + (hp : p = p') (hq : q = q') : + modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ≫ + chainStage2Cast A M M' hp hq = + (symPowCast A M'.X (congrArg Nat.succ hp) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ hq)) ≫ + modTensorπ A (symPowMod A M'.X p') + (symPowMod A M.X q') := by + subst hp hq + simp only [chainStage2Cast_rfl, symPowCast_rfl, + MonoidalCategory.id_tensorHom_id] + exact (Category.comp_id _).trans (Category.id_comp _).symm + +end Stage2Cast + +/-! ## The two-index stage multiplication -/ + +/-- **The two-index chain multiplication**: two stages interchange +and multiply into the stage of the slotwise summed arities. -/ +noncomputable def chainMul2 + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q r s : ℕ) : + chainStage2 A M M' p q ⊗ chainStage2 A M M' r s ⟶ + chainStage2 A M M' (p + 1 + r) (q + 1 + s) := + interchange A (symPowMod A M'.X p) (symPowMod A M.X q) + (symPowMod A M'.X r) (symPowMod A M.X s) ≫ + modTensorMap A (symMulMod A M'.X p r) (symMulMod A M.X q s) + +/-- Defining equation of the two-index chain multiplication: under +the stage projections it is the raw crossing followed by the +slotwise symmetric multiplications. -/ +theorem tensorHom_π_chainMul2 + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q r s : ℕ) : + (modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) (symPowMod A M.X s)) ≫ + chainMul2 A M M' p q r s = + tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s)) := by + have h5 : (modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) (symPowMod A M.X s)) ≫ + chainMul2 A M M' p q r s = + ((modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) (symPowMod A M.X s)) ≫ + interchange A (symPowMod A M'.X p) (symPowMod A M.X q) + (symPowMod A M'.X r) (symPowMod A M.X s)) ≫ + modTensorMap A (symMulMod A M'.X p r) + (symMulMod A M.X q s) := by + rw [chainMul2] + exact (Category.assoc _ _ _).symm + rw [h5, tensorHom_π_interchange, rawInterchangeπ, + rawInterchange] + simp only [Category.assoc] + have h6 : modTensorπ A + (modTensorMod A (symPowMod A M'.X p) (symPowMod A M'.X r)) + (modTensorMod A (symPowMod A M.X q) (symPowMod A M.X s)) ≫ + modTensorMap A (symMulMod A M'.X p r) + (symMulMod A M.X q s) = + ((symMulMod A M'.X p r).hom ⊗ₘ (symMulMod A M.X q s).hom) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s)) := + modTensorπ_map A (symMulMod A M'.X p r) + (symMulMod A M.X q s) + conv_lhs => arg 2; erw [Category.assoc] + change tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (modTensorπ A (symPowMod A M'.X p) (symPowMod A M'.X r) ⊗ₘ + modTensorπ A (symPowMod A M.X q) (symPowMod A M.X s)) ≫ + modTensorπ A + (modTensorMod A (symPowMod A M'.X p) (symPowMod A M'.X r)) + (modTensorMod A (symPowMod A M.X q) (symPowMod A M.X s)) ≫ + modTensorMap A (symMulMod A M'.X p r) + (symMulMod A M.X q s) = _ + refine congrArg (CategoryStruct.comp _) ?_ + refine (congrArg (CategoryStruct.comp _) h6).trans ?_ + erw [show (symMulMod A M'.X p r).hom = symMulDesc A M'.X p r + from rfl, + show (symMulMod A M.X q s).hom = symMulDesc A M.X q s from + rfl, ← Category.assoc] + change ((modTensorπ A (symPowMod A M'.X p) + (symPowMod A M'.X r) ⊗ₘ + modTensorπ A (symPowMod A M.X q) (symPowMod A M.X s)) ≫ + (symMulDesc A M'.X p r ⊗ₘ symMulDesc A M.X q s)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s)) = _ + rw [MonoidalCategory.tensorHom_comp_tensorHom, + modTensorπ_symMulDesc, modTensorπ_symMulDesc] + rfl + +/-! ## Symmetric-power laws with transported arities -/ + +section SymCast + +/-- Commutativity of the symmetric multiplication, with both sides +transported to a common arity. -/ +private theorem symMul_comm_cast + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (X : D) [ModObj A X] + {a b c : ℕ} (h : b + a = c) + (h' : a + b = c) : + (β_ (symPow A X a) (symPow A X b)).hom ≫ symMul A X b a ≫ + symPowCast A X h = + symMul A X a b ≫ symPowCast A X h' := by + subst h + rw [symPowCast_rfl, Category.comp_id] + exact symMul_comm A X a b + +end SymCast + +/-! ## Commutativity of the two-index multiplication -/ + +section Chain2Comm + +private theorem chainMul2_comm_factors + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q r s : ℕ) + (hp₀ : r + 1 + p = p + 1 + r) + (hq₀ : s + 1 + q = q + 1 + s) : + (((β_ (symPow A M'.X (p + 1)) + (symPow A M'.X (r + 1))).hom ≫ + symMul A M'.X (r + 1) (p + 1)) ≫ + symPowCast A M'.X (congrArg Nat.succ hp₀) = + symMul A M'.X (p + 1) (r + 1)) ∧ + (((β_ (symPow A M.X (q + 1)) + (symPow A M.X (s + 1))).hom ≫ + symMul A M.X (s + 1) (q + 1)) ≫ + symPowCast A M.X (congrArg Nat.succ hq₀) = + symMul A M.X (q + 1) (s + 1)) := by + have hfac₁ : + (β_ (symPow A M'.X (p + 1)) (symPow A M'.X (r + 1))).hom ≫ + symMul A M'.X (r + 1) (p + 1) ≫ + symPowCast A M'.X (congrArg Nat.succ hp₀) = + symMul A M'.X (p + 1) (r + 1) ≫ + symPowCast A M'.X + (rfl : p + 1 + (r + 1) = p + 1 + (r + 1)) := + symMul_comm_cast A M'.X (congrArg Nat.succ hp₀) rfl + have hfac₂ : + (β_ (symPow A M.X (q + 1)) (symPow A M.X (s + 1))).hom ≫ + symMul A M.X (s + 1) (q + 1) ≫ + symPowCast A M.X (congrArg Nat.succ hq₀) = + symMul A M.X (q + 1) (s + 1) ≫ + symPowCast A M.X + (rfl : q + 1 + (s + 1) = q + 1 + (s + 1)) := + symMul_comm_cast A M.X (congrArg Nat.succ hq₀) rfl + have hkill₁ : symMul A M'.X (p + 1) (r + 1) ≫ + symPowCast A M'.X + (rfl : p + 1 + (r + 1) = p + 1 + (r + 1)) = + symMul A M'.X (p + 1) (r + 1) := by + rw [symPowCast_rfl, Category.comp_id] + have hkill₂ : symMul A M.X (q + 1) (s + 1) ≫ + symPowCast A M.X + (rfl : q + 1 + (s + 1) = q + 1 + (s + 1)) = + symMul A M.X (q + 1) (s + 1) := by + rw [symPowCast_rfl, Category.comp_id] + have hfacL₁ : ((β_ (symPow A M'.X (p + 1)) + (symPow A M'.X (r + 1))).hom ≫ + symMul A M'.X (r + 1) (p + 1)) ≫ + symPowCast A M'.X (congrArg Nat.succ hp₀) = + symMul A M'.X (p + 1) (r + 1) := + (Category.assoc _ _ _).trans (hfac₁.trans hkill₁) + have hfacL₂ : ((β_ (symPow A M.X (q + 1)) + (symPow A M.X (s + 1))).hom ≫ + symMul A M.X (s + 1) (q + 1)) ≫ + symPowCast A M.X (congrArg Nat.succ hq₀) = + symMul A M.X (q + 1) (s + 1) := + (Category.assoc _ _ _).trans (hfac₂.trans hkill₂) + exact ⟨hfacL₁, hfacL₂⟩ + +/-- **Commutativity of the two-index chain multiplication**, up to +the slotwise stage transports. -/ +theorem chainMul2_comm + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (p q r s : ℕ) : + (β_ (chainStage2 A M M' p q) (chainStage2 A M M' r s)).hom ≫ + chainMul2 A M M' r s p q ≫ + chainStage2Cast A M M' + (by omega : r + 1 + p = p + 1 + r) + (by omega : s + 1 + q = q + 1 + s) = + chainMul2 A M M' p q r s := by + have hp₀ : r + 1 + p = p + 1 + r := by omega + have hq₀ : s + 1 + q = q + 1 + s := by omega + obtain ⟨hfacL₁, hfacL₂⟩ := chainMul2_comm_factors A M M' p q r s hp₀ hq₀ + have hβ : + (modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) (symPowMod A M.X s)) ≫ + (β_ (chainStage2 A M M' p q) (chainStage2 A M M' r s)).hom = + (β_ (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X r) (symPowMod A M.X s) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q)) := + BraidedCategory.braiding_naturality _ _ + refine (cancel_epi + (modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) (symPowMod A M.X s))).mp ?_ + have e1 : (modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q) ⊗ₘ + modTensorπ A (symPowMod A M'.X r) (symPowMod A M.X s)) ≫ + ((β_ (chainStage2 A M M' p q) + (chainStage2 A M M' r s)).hom ≫ + chainMul2 A M M' r s p q ≫ + chainStage2Cast A M M' hp₀ hq₀) = + (β_ (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X r) (symPowMod A M.X s) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q)) ≫ + chainMul2 A M M' r s p q ≫ + chainStage2Cast A M M' hp₀ hq₀ := + (Category.assoc _ _ _).symm.trans + ((congrArg (fun t => t ≫ (chainMul2 A M M' r s p q ≫ + chainStage2Cast A M M' hp₀ hq₀)) hβ).trans + (Category.assoc _ _ _)) + have e2 : (β_ (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X r) (symPowMod A M.X s) ⊗ₘ + modTensorπ A (symPowMod A M'.X p) (symPowMod A M.X q)) ≫ + chainMul2 A M M' r s p q ≫ + chainStage2Cast A M M' hp₀ hq₀ = + (β_ (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + tensorμ (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) + (symPow A M'.X (p + 1)) (symPow A M.X (q + 1)) ≫ + (symMul A M'.X (r + 1) (p + 1) ⊗ₘ + symMul A M.X (s + 1) (q + 1)) ≫ + (modTensorπ A (symPowMod A M'.X (r + 1 + p)) + (symPowMod A M.X (s + 1 + q)) ≫ + chainStage2Cast A M M' hp₀ hq₀) := + congrArg (CategoryStruct.comp _) + ((Category.assoc _ _ _).symm.trans + ((congrArg (fun t => t ≫ chainStage2Cast A M M' hp₀ hq₀) + (tensorHom_π_chainMul2 A M M' r s p q)).trans + ((Category.assoc _ _ _).trans + (congrArg (CategoryStruct.comp _) + (Category.assoc _ _ _))))) + have e3 : (β_ (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + tensorμ (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) + (symPow A M'.X (p + 1)) (symPow A M.X (q + 1)) ≫ + (symMul A M'.X (r + 1) (p + 1) ⊗ₘ + symMul A M.X (s + 1) (q + 1)) ≫ + (modTensorπ A (symPowMod A M'.X (r + 1 + p)) + (symPowMod A M.X (s + 1 + q)) ≫ + chainStage2Cast A M M' hp₀ hq₀) = + (β_ (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + tensorμ (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) + (symPow A M'.X (p + 1)) (symPow A M.X (q + 1)) ≫ + (symMul A M'.X (r + 1) (p + 1) ⊗ₘ + symMul A M.X (s + 1) (q + 1)) ≫ + ((symPowCast A M'.X (congrArg Nat.succ hp₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ hq₀)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s))) := + congrArg (CategoryStruct.comp _) + (congrArg (CategoryStruct.comp _) + (congrArg (CategoryStruct.comp _) + (modTensorπ_chainStage2Cast A M M' hp₀ hq₀))) + have e4 : (β_ (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) + (symPow A M'.X (r + 1) ⊗ symPow A M.X (s + 1))).hom ≫ + tensorμ (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) + (symPow A M'.X (p + 1)) (symPow A M.X (q + 1)) ≫ + (symMul A M'.X (r + 1) (p + 1) ⊗ₘ + symMul A M.X (s + 1) (q + 1)) ≫ + ((symPowCast A M'.X (congrArg Nat.succ hp₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ hq₀)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s))) = + tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + ((β_ (symPow A M'.X (p + 1)) (symPow A M'.X (r + 1))).hom + ⊗ₘ (β_ (symPow A M.X (q + 1)) + (symPow A M.X (s + 1))).hom) ≫ + (symMul A M'.X (r + 1) (p + 1) ⊗ₘ + symMul A M.X (s + 1) (q + 1)) ≫ + ((symPowCast A M'.X (congrArg Nat.succ hp₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ hq₀)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s))) := + tensorμ_braiding_assoc _ _ _ _ _ + have e5 : tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + ((β_ (symPow A M'.X (p + 1)) (symPow A M'.X (r + 1))).hom + ⊗ₘ (β_ (symPow A M.X (q + 1)) + (symPow A M.X (s + 1))).hom) ≫ + (symMul A M'.X (r + 1) (p + 1) ⊗ₘ + symMul A M.X (s + 1) (q + 1)) ≫ + ((symPowCast A M'.X (congrArg Nat.succ hp₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ hq₀)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s))) = + tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (((β_ (symPow A M'.X (p + 1)) + (symPow A M'.X (r + 1))).hom ≫ + symMul A M'.X (r + 1) (p + 1)) ⊗ₘ + ((β_ (symPow A M.X (q + 1)) + (symPow A M.X (s + 1))).hom ≫ + symMul A M.X (s + 1) (q + 1))) ≫ + ((symPowCast A M'.X (congrArg Nat.succ hp₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ hq₀)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s))) := + congrArg (CategoryStruct.comp _) + (MonoidalCategory.tensorHom_comp_tensorHom_assoc _ _ _ _ _) + have e6 : tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (((β_ (symPow A M'.X (p + 1)) + (symPow A M'.X (r + 1))).hom ≫ + symMul A M'.X (r + 1) (p + 1)) ⊗ₘ + ((β_ (symPow A M.X (q + 1)) + (symPow A M.X (s + 1))).hom ≫ + symMul A M.X (s + 1) (q + 1))) ≫ + ((symPowCast A M'.X (congrArg Nat.succ hp₀) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ hq₀)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s))) = + tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + ((((β_ (symPow A M'.X (p + 1)) + (symPow A M'.X (r + 1))).hom ≫ + symMul A M'.X (r + 1) (p + 1)) ≫ + symPowCast A M'.X (congrArg Nat.succ hp₀)) ⊗ₘ + (((β_ (symPow A M.X (q + 1)) + (symPow A M.X (s + 1))).hom ≫ + symMul A M.X (s + 1) (q + 1)) ≫ + symPowCast A M.X (congrArg Nat.succ hq₀))) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s)) := + congrArg (CategoryStruct.comp _) + (MonoidalCategory.tensorHom_comp_tensorHom_assoc _ _ _ _ _) + have e7 : tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + ((((β_ (symPow A M'.X (p + 1)) + (symPow A M'.X (r + 1))).hom ≫ + symMul A M'.X (r + 1) (p + 1)) ≫ + symPowCast A M'.X (congrArg Nat.succ hp₀)) ⊗ₘ + (((β_ (symPow A M.X (q + 1)) + (symPow A M.X (s + 1))).hom ≫ + symMul A M.X (s + 1) (q + 1)) ≫ + symPowCast A M.X (congrArg Nat.succ hq₀))) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s)) = + tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1)) + (symPow A M'.X (r + 1)) (symPow A M.X (s + 1)) ≫ + (symMul A M'.X (p + 1) (r + 1) ⊗ₘ + symMul A M.X (q + 1) (s + 1)) ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s)) := + congrArg (CategoryStruct.comp _) + (congrArg (fun t => t ≫ + modTensorπ A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s))) + (congrArg₂ (· ⊗ₘ ·) hfacL₁ hfacL₂)) + exact e1.trans (e2.trans (e3.trans (e4.trans (e5.trans + (e6.trans (e7.trans + (tensorHom_π_chainMul2 A M M' p q r s).symm)))))) + +end Chain2Comm + +/-! ## Tensor surgery and the associativity core -/ + +section TensorSurgery + +/-- Absorb a whiskered morphism into the first tensor factor. -/ +private theorem tensorHom_whiskerRight_comp + [Category.{v} D] [MonoidalCategory D] + {X₁ X₂ Y₁ Y₂ Z₁ W : D} (a : X₁ ⟶ Y₁) (b : X₂ ⟶ Y₂) + (f : Y₁ ⟶ Z₁) (r : Z₁ ⊗ Y₂ ⟶ W) : + (a ⊗ₘ b) ≫ (f ▷ Y₂) ≫ r = ((a ≫ f) ⊗ₘ b) ≫ r := by + rw [← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom_assoc, + Category.comp_id] + +/-- Absorb a whiskered morphism into the second tensor factor. -/ +private theorem tensorHom_whiskerLeft_comp [Category.{v} D] [MonoidalCategory D] + {X₁ X₂ Y₁ Y₂ Z₂ W : D} (a : X₁ ⟶ Y₁) (b : X₂ ⟶ Y₂) + (g : Y₂ ⟶ Z₂) (r : Y₁ ⊗ Z₂ ⟶ W) : + (a ⊗ₘ b) ≫ (Y₁ ◁ g) ≫ r = (a ⊗ₘ (b ≫ g)) ≫ r := by + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom_assoc, + Category.comp_id] + +/-- Extract a prefix of the first tensor factor as a whisker. -/ +private theorem compTensorHom_whiskerRight_split + [Category.{v} D] [MonoidalCategory D] + {V₁ W₁ U₁ X₂ U₂ Z : D} (x : V₁ ⟶ W₁) (q₁ : W₁ ⟶ U₁) + (q₂ : X₂ ⟶ U₂) (r : U₁ ⊗ U₂ ⟶ Z) : + ((x ≫ q₁) ⊗ₘ q₂) ≫ r = (x ▷ X₂) ≫ (q₁ ⊗ₘ q₂) ≫ r := by + rw [MonoidalCategory.tensorHom_def, + MonoidalCategory.tensorHom_def, comp_whiskerRight] + simp only [Category.assoc] + +/-- Extract a prefix of the second tensor factor as a whisker. -/ +private theorem compTensorHom_whiskerLeft_split + [Category.{v} D] [MonoidalCategory D] + {X₁ U₁ V₂ W₂ U₂ Z : D} (q₁ : X₁ ⟶ U₁) (x : V₂ ⟶ W₂) + (q₂ : W₂ ⟶ U₂) (r : U₁ ⊗ U₂ ⟶ Z) : + (q₁ ⊗ₘ (x ≫ q₂)) ≫ r = (X₁ ◁ x) ≫ (q₁ ⊗ₘ q₂) ≫ r := by + rw [MonoidalCategory.tensorHom_def', + MonoidalCategory.tensorHom_def', + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + +/-- **The coherence core of associativity**: two interchanged pair +multiplications reassociate through `tensorμ` whenever each factor +satisfies the corresponding one-object associativity law. -/ +private theorem chainMulAssoc_core + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + {a₁ a₂ c₁ c₂ e₁ e₂ x₁ x₂ z₁ z₂ + t₁ t₂ Z : D} + {u₁ : a₁ ⊗ c₁ ⟶ x₁} {u₂ : a₂ ⊗ c₂ ⟶ x₂} + {w₁ : c₁ ⊗ e₁ ⟶ z₁} {w₂ : c₂ ⊗ e₂ ⟶ z₂} + {v₁ : x₁ ⊗ e₁ ⟶ t₁} {v₂ : x₂ ⊗ e₂ ⟶ t₂} + {v'₁ : a₁ ⊗ z₁ ⟶ t₁} {v'₂ : a₂ ⊗ z₂ ⟶ t₂} + (h₁ : (u₁ ▷ e₁) ≫ v₁ = + (α_ a₁ c₁ e₁).hom ≫ (a₁ ◁ w₁) ≫ v'₁) + (h₂ : (u₂ ▷ e₂) ≫ v₂ = + (α_ a₂ c₂ e₂).hom ≫ (a₂ ◁ w₂) ≫ v'₂) + (out : t₁ ⊗ t₂ ⟶ Z) : + ((tensorμ a₁ a₂ c₁ c₂ ≫ (u₁ ⊗ₘ u₂)) ▷ (e₁ ⊗ e₂)) ≫ + tensorμ x₁ x₂ e₁ e₂ ≫ (v₁ ⊗ₘ v₂) ≫ out = + (α_ (a₁ ⊗ a₂) (c₁ ⊗ c₂) (e₁ ⊗ e₂)).hom ≫ + ((a₁ ⊗ a₂) ◁ (tensorμ c₁ c₂ e₁ e₂ ≫ (w₁ ⊗ₘ w₂))) ≫ + tensorμ a₁ a₂ z₁ z₂ ≫ (v'₁ ⊗ₘ v'₂) ≫ out := by + conv_lhs => rw [comp_whiskerRight, Category.assoc, + tensorμ_natural_left_assoc, + MonoidalCategory.tensorHom_comp_tensorHom_assoc, h₁, h₂, + ← MonoidalCategory.tensorHom_comp_tensorHom_assoc, + tensor_associativity_assoc] + conv_rhs => rw [MonoidalCategory.whiskerLeft_comp, + Category.assoc, tensorμ_natural_right_assoc, + MonoidalCategory.tensorHom_comp_tensorHom_assoc] + +end TensorSurgery + +/-! ## Associativity of the two-index multiplication -/ + +section Chain2Assoc + +private theorem chainMul2_assoc_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (a b c d e f : ℕ) : + ((modTensorπ A (symPowMod A M'.X a) + (symPowMod A M.X b) ⊗ₘ + modTensorπ A (symPowMod A M'.X c) (symPowMod A M.X d)) ⊗ₘ + modTensorπ A (symPowMod A M'.X e) (symPowMod A M.X f)) ≫ + ((chainMul2 A M M' a b c d ▷ chainStage2 A M M' e f) ≫ + chainMul2 A M M' (a + 1 + c) (b + 1 + d) e f ≫ + chainStage2Cast A M M' + (rfl : a + 1 + c + 1 + e = a + 1 + c + 1 + e) + (rfl : b + 1 + d + 1 + f = b + 1 + d + 1 + f)) = + ((tensorμ (symPow A M'.X (a + 1)) (symPow A M.X (b + 1)) + (symPow A M'.X (c + 1)) (symPow A M.X (d + 1)) ≫ + (symMul A M'.X (a + 1) (c + 1) ⊗ₘ + symMul A M.X (b + 1) (d + 1))) ▷ + (symPow A M'.X (e + 1) ⊗ symPow A M.X (f + 1))) ≫ + tensorμ (symPow A M'.X (a + 1 + c + 1)) + (symPow A M.X (b + 1 + d + 1)) + (symPow A M'.X (e + 1)) (symPow A M.X (f + 1)) ≫ + (symMul A M'.X (a + 1 + c + 1) (e + 1) ⊗ₘ + symMul A M.X (b + 1 + d + 1) (f + 1)) ≫ + modTensorπ A (symPowMod A M'.X (a + 1 + c + 1 + e)) + (symPowMod A M.X (b + 1 + d + 1 + f)) := by + have hK : chainMul2 A M M' (a + 1 + c) (b + 1 + d) e f ≫ + chainStage2Cast A M M' + (rfl : a + 1 + c + 1 + e = a + 1 + c + 1 + e) + (rfl : b + 1 + d + 1 + f = b + 1 + d + 1 + f) = + chainMul2 A M M' (a + 1 + c) (b + 1 + d) e f := by + rw [chainStage2Cast_rfl, Category.comp_id] + have l1 : ((modTensorπ A (symPowMod A M'.X a) + (symPowMod A M.X b) ⊗ₘ + modTensorπ A (symPowMod A M'.X c) (symPowMod A M.X d)) ⊗ₘ + modTensorπ A (symPowMod A M'.X e) (symPowMod A M.X f)) ≫ + ((chainMul2 A M M' a b c d ▷ chainStage2 A M M' e f) ≫ + chainMul2 A M M' (a + 1 + c) (b + 1 + d) e f ≫ + chainStage2Cast A M M' + (rfl : a + 1 + c + 1 + e = a + 1 + c + 1 + e) + (rfl : b + 1 + d + 1 + f = b + 1 + d + 1 + f)) = + ((modTensorπ A (symPowMod A M'.X a) (symPowMod A M.X b) ⊗ₘ + modTensorπ A (symPowMod A M'.X c) (symPowMod A M.X d)) ⊗ₘ + modTensorπ A (symPowMod A M'.X e) (symPowMod A M.X f)) ≫ + ((chainMul2 A M M' a b c d ▷ chainStage2 A M M' e f) ≫ + chainMul2 A M M' (a + 1 + c) (b + 1 + d) e f) := + congrArg (CategoryStruct.comp _) + (congrArg (CategoryStruct.comp _) hK) + have l2 : ((modTensorπ A (symPowMod A M'.X a) + (symPowMod A M.X b) ⊗ₘ + modTensorπ A (symPowMod A M'.X c) (symPowMod A M.X d)) ⊗ₘ + modTensorπ A (symPowMod A M'.X e) (symPowMod A M.X f)) ≫ + ((chainMul2 A M M' a b c d ▷ chainStage2 A M M' e f) ≫ + chainMul2 A M M' (a + 1 + c) (b + 1 + d) e f) = + (((modTensorπ A (symPowMod A M'.X a) (symPowMod A M.X b) ⊗ₘ + modTensorπ A (symPowMod A M'.X c) (symPowMod A M.X d)) ≫ + chainMul2 A M M' a b c d) ⊗ₘ + modTensorπ A (symPowMod A M'.X e) (symPowMod A M.X f)) ≫ + chainMul2 A M M' (a + 1 + c) (b + 1 + d) e f := + tensorHom_whiskerRight_comp _ _ _ _ + have l3 : (((modTensorπ A (symPowMod A M'.X a) + (symPowMod A M.X b) ⊗ₘ + modTensorπ A (symPowMod A M'.X c) (symPowMod A M.X d)) ≫ + chainMul2 A M M' a b c d) ⊗ₘ + modTensorπ A (symPowMod A M'.X e) (symPowMod A M.X f)) ≫ + chainMul2 A M M' (a + 1 + c) (b + 1 + d) e f = + ((tensorμ (symPow A M'.X (a + 1)) (symPow A M.X (b + 1)) + (symPow A M'.X (c + 1)) (symPow A M.X (d + 1)) ≫ + (symMul A M'.X (a + 1) (c + 1) ⊗ₘ + symMul A M.X (b + 1) (d + 1)) ≫ + modTensorπ A (symPowMod A M'.X (a + 1 + c)) + (symPowMod A M.X (b + 1 + d))) ⊗ₘ + modTensorπ A (symPowMod A M'.X e) (symPowMod A M.X f)) ≫ + chainMul2 A M M' (a + 1 + c) (b + 1 + d) e f := + congrArg (fun t => (t ⊗ₘ + modTensorπ A (symPowMod A M'.X e) (symPowMod A M.X f)) ≫ + chainMul2 A M M' (a + 1 + c) (b + 1 + d) e f) + (tensorHom_π_chainMul2 A M M' a b c d) + have l4 : ((tensorμ (symPow A M'.X (a + 1)) + (symPow A M.X (b + 1)) + (symPow A M'.X (c + 1)) (symPow A M.X (d + 1)) ≫ + (symMul A M'.X (a + 1) (c + 1) ⊗ₘ + symMul A M.X (b + 1) (d + 1)) ≫ + modTensorπ A (symPowMod A M'.X (a + 1 + c)) + (symPowMod A M.X (b + 1 + d))) ⊗ₘ + modTensorπ A (symPowMod A M'.X e) (symPowMod A M.X f)) ≫ + chainMul2 A M M' (a + 1 + c) (b + 1 + d) e f = + (((tensorμ (symPow A M'.X (a + 1)) (symPow A M.X (b + 1)) + (symPow A M'.X (c + 1)) (symPow A M.X (d + 1)) ≫ + (symMul A M'.X (a + 1) (c + 1) ⊗ₘ + symMul A M.X (b + 1) (d + 1))) ≫ + modTensorπ A (symPowMod A M'.X (a + 1 + c)) + (symPowMod A M.X (b + 1 + d))) ⊗ₘ + modTensorπ A (symPowMod A M'.X e) (symPowMod A M.X f)) ≫ + chainMul2 A M M' (a + 1 + c) (b + 1 + d) e f := + congrArg (fun t => (t ⊗ₘ + modTensorπ A (symPowMod A M'.X e) (symPowMod A M.X f)) ≫ + chainMul2 A M M' (a + 1 + c) (b + 1 + d) e f) + (Category.assoc _ _ _).symm + have l5 : (((tensorμ (symPow A M'.X (a + 1)) + (symPow A M.X (b + 1)) + (symPow A M'.X (c + 1)) (symPow A M.X (d + 1)) ≫ + (symMul A M'.X (a + 1) (c + 1) ⊗ₘ + symMul A M.X (b + 1) (d + 1))) ≫ + modTensorπ A (symPowMod A M'.X (a + 1 + c)) + (symPowMod A M.X (b + 1 + d))) ⊗ₘ + modTensorπ A (symPowMod A M'.X e) (symPowMod A M.X f)) ≫ + chainMul2 A M M' (a + 1 + c) (b + 1 + d) e f = + ((tensorμ (symPow A M'.X (a + 1)) (symPow A M.X (b + 1)) + (symPow A M'.X (c + 1)) (symPow A M.X (d + 1)) ≫ + (symMul A M'.X (a + 1) (c + 1) ⊗ₘ + symMul A M.X (b + 1) (d + 1))) ▷ + (symPow A M'.X (e + 1) ⊗ symPow A M.X (f + 1))) ≫ + (modTensorπ A (symPowMod A M'.X (a + 1 + c)) + (symPowMod A M.X (b + 1 + d)) ⊗ₘ + modTensorπ A (symPowMod A M'.X e) + (symPowMod A M.X f)) ≫ + chainMul2 A M M' (a + 1 + c) (b + 1 + d) e f := + compTensorHom_whiskerRight_split _ _ _ _ + have l6 : ((tensorμ (symPow A M'.X (a + 1)) + (symPow A M.X (b + 1)) + (symPow A M'.X (c + 1)) (symPow A M.X (d + 1)) ≫ + (symMul A M'.X (a + 1) (c + 1) ⊗ₘ + symMul A M.X (b + 1) (d + 1))) ▷ + (symPow A M'.X (e + 1) ⊗ symPow A M.X (f + 1))) ≫ + (modTensorπ A (symPowMod A M'.X (a + 1 + c)) + (symPowMod A M.X (b + 1 + d)) ⊗ₘ + modTensorπ A (symPowMod A M'.X e) + (symPowMod A M.X f)) ≫ + chainMul2 A M M' (a + 1 + c) (b + 1 + d) e f = + ((tensorμ (symPow A M'.X (a + 1)) (symPow A M.X (b + 1)) + (symPow A M'.X (c + 1)) (symPow A M.X (d + 1)) ≫ + (symMul A M'.X (a + 1) (c + 1) ⊗ₘ + symMul A M.X (b + 1) (d + 1))) ▷ + (symPow A M'.X (e + 1) ⊗ symPow A M.X (f + 1))) ≫ + tensorμ (symPow A M'.X (a + 1 + c + 1)) + (symPow A M.X (b + 1 + d + 1)) + (symPow A M'.X (e + 1)) (symPow A M.X (f + 1)) ≫ + (symMul A M'.X (a + 1 + c + 1) (e + 1) ⊗ₘ + symMul A M.X (b + 1 + d + 1) (f + 1)) ≫ + modTensorπ A (symPowMod A M'.X (a + 1 + c + 1 + e)) + (symPowMod A M.X (b + 1 + d + 1 + f)) := + congrArg (CategoryStruct.comp _) + (tensorHom_π_chainMul2 A M M' (a + 1 + c) (b + 1 + d) e f) + -- Right bridge: from the reassociated side to the instantiated + -- core's right-hand side. + exact l1.trans (l2.trans (l3.trans (l4.trans (l5.trans (l6))))) + +private theorem chainMul2_assoc_rightTail + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (a b c d e f : ℕ) + (hp₂ : a + 1 + (c + 1 + e) = a + 1 + c + 1 + e) + (hq₂ : b + 1 + (d + 1 + f) = b + 1 + d + 1 + f) : + (modTensorπ A (symPowMod A M'.X a) + (symPowMod A M.X b) ⊗ₘ + modTensorπ A (symPowMod A M'.X (c + 1 + e)) + (symPowMod A M.X (d + 1 + f))) ≫ + (chainMul2 A M M' a b (c + 1 + e) (d + 1 + f) ≫ + chainStage2Cast A M M' hp₂ hq₂) = + tensorμ (symPow A M'.X (a + 1)) (symPow A M.X (b + 1)) + (symPow A M'.X (c + 1 + e + 1)) + (symPow A M.X (d + 1 + f + 1)) ≫ + ((symMul A M'.X (a + 1) (c + 1 + e + 1) ≫ + symPowCast A M'.X (congrArg Nat.succ hp₂)) ⊗ₘ + (symMul A M.X (b + 1) (d + 1 + f + 1) ≫ + symPowCast A M.X (congrArg Nat.succ hq₂))) ≫ + modTensorπ A (symPowMod A M'.X (a + 1 + c + 1 + e)) + (symPowMod A M.X (b + 1 + d + 1 + f)) := by + have r6 : (modTensorπ A (symPowMod A M'.X a) + (symPowMod A M.X b) ⊗ₘ + modTensorπ A (symPowMod A M'.X (c + 1 + e)) + (symPowMod A M.X (d + 1 + f))) ≫ + (chainMul2 A M M' a b (c + 1 + e) (d + 1 + f) ≫ + chainStage2Cast A M M' hp₂ hq₂) = + tensorμ (symPow A M'.X (a + 1)) (symPow A M.X (b + 1)) + (symPow A M'.X (c + 1 + e + 1)) + (symPow A M.X (d + 1 + f + 1)) ≫ + (symMul A M'.X (a + 1) (c + 1 + e + 1) ⊗ₘ + symMul A M.X (b + 1) (d + 1 + f + 1)) ≫ + (modTensorπ A (symPowMod A M'.X (a + 1 + (c + 1 + e))) + (symPowMod A M.X (b + 1 + (d + 1 + f))) ≫ + chainStage2Cast A M M' hp₂ hq₂) := + (Category.assoc _ _ _).symm.trans + ((congrArg (fun t => t ≫ chainStage2Cast A M M' hp₂ hq₂) + (tensorHom_π_chainMul2 A M M' a b + (c + 1 + e) (d + 1 + f))).trans + ((Category.assoc _ _ _).trans + (congrArg (CategoryStruct.comp _) + (Category.assoc _ _ _)))) + have r7 : modTensorπ A (symPowMod A M'.X (a + 1 + (c + 1 + e))) + (symPowMod A M.X (b + 1 + (d + 1 + f))) ≫ + chainStage2Cast A M M' hp₂ hq₂ = + (symPowCast A M'.X (congrArg Nat.succ hp₂) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ hq₂)) ≫ + modTensorπ A (symPowMod A M'.X (a + 1 + c + 1 + e)) + (symPowMod A M.X (b + 1 + d + 1 + f)) := + modTensorπ_chainStage2Cast A M M' hp₂ hq₂ + have r8 : (symMul A M'.X (a + 1) (c + 1 + e + 1) ⊗ₘ + symMul A M.X (b + 1) (d + 1 + f + 1)) ≫ + ((symPowCast A M'.X (congrArg Nat.succ hp₂) ⊗ₘ + symPowCast A M.X (congrArg Nat.succ hq₂)) ≫ + modTensorπ A (symPowMod A M'.X (a + 1 + c + 1 + e)) + (symPowMod A M.X (b + 1 + d + 1 + f))) = + ((symMul A M'.X (a + 1) (c + 1 + e + 1) ≫ + symPowCast A M'.X (congrArg Nat.succ hp₂)) ⊗ₘ + (symMul A M.X (b + 1) (d + 1 + f + 1) ≫ + symPowCast A M.X (congrArg Nat.succ hq₂))) ≫ + modTensorπ A (symPowMod A M'.X (a + 1 + c + 1 + e)) + (symPowMod A M.X (b + 1 + d + 1 + f)) := + MonoidalCategory.tensorHom_comp_tensorHom_assoc _ _ _ _ _ + have rTail : (modTensorπ A (symPowMod A M'.X a) + (symPowMod A M.X b) ⊗ₘ + modTensorπ A (symPowMod A M'.X (c + 1 + e)) + (symPowMod A M.X (d + 1 + f))) ≫ + (chainMul2 A M M' a b (c + 1 + e) (d + 1 + f) ≫ + chainStage2Cast A M M' hp₂ hq₂) = + tensorμ (symPow A M'.X (a + 1)) (symPow A M.X (b + 1)) + (symPow A M'.X (c + 1 + e + 1)) + (symPow A M.X (d + 1 + f + 1)) ≫ + ((symMul A M'.X (a + 1) (c + 1 + e + 1) ≫ + symPowCast A M'.X (congrArg Nat.succ hp₂)) ⊗ₘ + (symMul A M.X (b + 1) (d + 1 + f + 1) ≫ + symPowCast A M.X (congrArg Nat.succ hq₂))) ≫ + modTensorπ A (symPowMod A M'.X (a + 1 + c + 1 + e)) + (symPowMod A M.X (b + 1 + d + 1 + f)) := + r6.trans ((congrArg (CategoryStruct.comp _) + (congrArg (CategoryStruct.comp _) r7)).trans + (congrArg (CategoryStruct.comp _) r8)) + exact rTail + +/-- **Associativity of the two-index chain multiplication**, up to +the slotwise stage transports onto the common arities. -/ +theorem chainMul2_assoc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (a b c d e f : ℕ) : + (chainMul2 A M M' a b c d ▷ chainStage2 A M M' e f) ≫ + chainMul2 A M M' (a + 1 + c) (b + 1 + d) e f ≫ + chainStage2Cast A M M' + (by omega : a + 1 + c + 1 + e = a + 1 + c + 1 + e) + (by omega : b + 1 + d + 1 + f = b + 1 + d + 1 + f) = + (α_ (chainStage2 A M M' a b) (chainStage2 A M M' c d) + (chainStage2 A M M' e f)).hom ≫ + (chainStage2 A M M' a b ◁ chainMul2 A M M' c d e f) ≫ + chainMul2 A M M' a b (c + 1 + e) (d + 1 + f) ≫ + chainStage2Cast A M M' + (by omega : + a + 1 + (c + 1 + e) = a + 1 + c + 1 + e) + (by omega : + b + 1 + (d + 1 + f) = b + 1 + d + 1 + f) := by + have hp₂ : a + 1 + (c + 1 + e) = a + 1 + c + 1 + e := by omega + have hq₂ : b + 1 + (d + 1 + f) = b + 1 + d + 1 + f := by omega + have hcore := chainMulAssoc_core + (symMul_assoc A M'.X (a + 1) (c + 1) (e + 1)) + (symMul_assoc A M.X (b + 1) (d + 1) (f + 1)) + (modTensorπ A (symPowMod A M'.X (a + 1 + c + 1 + e)) + (symPowMod A M.X (b + 1 + d + 1 + f))) + refine (cancel_epi + ((modTensorπ A (symPowMod A M'.X a) (symPowMod A M.X b) ⊗ₘ + modTensorπ A (symPowMod A M'.X c) (symPowMod A M.X d)) ⊗ₘ + modTensorπ A (symPowMod A M'.X e) + (symPowMod A M.X f))).mp ?_ + -- Left bridge: from the whiskered chain multiplication to the + -- instantiated core's left-hand side. + have hleft := chainMul2_assoc_left A M M' a b c d e f + have hα : ((modTensorπ A (symPowMod A M'.X a) + (symPowMod A M.X b) ⊗ₘ + modTensorπ A (symPowMod A M'.X c) (symPowMod A M.X d)) ⊗ₘ + modTensorπ A (symPowMod A M'.X e) (symPowMod A M.X f)) ≫ + (α_ (chainStage2 A M M' a b) (chainStage2 A M M' c d) + (chainStage2 A M M' e f)).hom = + (α_ (symPow A M'.X (a + 1) ⊗ symPow A M.X (b + 1)) + (symPow A M'.X (c + 1) ⊗ symPow A M.X (d + 1)) + (symPow A M'.X (e + 1) ⊗ symPow A M.X (f + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X a) (symPowMod A M.X b) ⊗ₘ + (modTensorπ A (symPowMod A M'.X c) + (symPowMod A M.X d) ⊗ₘ + modTensorπ A (symPowMod A M'.X e) + (symPowMod A M.X f))) := + associator_naturality _ _ _ + have r1 : ((modTensorπ A (symPowMod A M'.X a) + (symPowMod A M.X b) ⊗ₘ + modTensorπ A (symPowMod A M'.X c) (symPowMod A M.X d)) ⊗ₘ + modTensorπ A (symPowMod A M'.X e) (symPowMod A M.X f)) ≫ + ((α_ (chainStage2 A M M' a b) (chainStage2 A M M' c d) + (chainStage2 A M M' e f)).hom ≫ + (chainStage2 A M M' a b ◁ chainMul2 A M M' c d e f) ≫ + chainMul2 A M M' a b (c + 1 + e) (d + 1 + f) ≫ + chainStage2Cast A M M' hp₂ hq₂) = + (α_ (symPow A M'.X (a + 1) ⊗ symPow A M.X (b + 1)) + (symPow A M'.X (c + 1) ⊗ symPow A M.X (d + 1)) + (symPow A M'.X (e + 1) ⊗ symPow A M.X (f + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X a) (symPowMod A M.X b) ⊗ₘ + (modTensorπ A (symPowMod A M'.X c) + (symPowMod A M.X d) ⊗ₘ + modTensorπ A (symPowMod A M'.X e) + (symPowMod A M.X f))) ≫ + ((chainStage2 A M M' a b ◁ chainMul2 A M M' c d e f) ≫ + chainMul2 A M M' a b (c + 1 + e) (d + 1 + f) ≫ + chainStage2Cast A M M' hp₂ hq₂) := + (Category.assoc _ _ _).symm.trans + ((congrArg (fun t => t ≫ + ((chainStage2 A M M' a b ◁ chainMul2 A M M' c d e f) ≫ + chainMul2 A M M' a b (c + 1 + e) (d + 1 + f) ≫ + chainStage2Cast A M M' hp₂ hq₂)) hα).trans + (Category.assoc _ _ _)) + have r2 : (α_ (symPow A M'.X (a + 1) ⊗ symPow A M.X (b + 1)) + (symPow A M'.X (c + 1) ⊗ symPow A M.X (d + 1)) + (symPow A M'.X (e + 1) ⊗ symPow A M.X (f + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X a) (symPowMod A M.X b) ⊗ₘ + (modTensorπ A (symPowMod A M'.X c) + (symPowMod A M.X d) ⊗ₘ + modTensorπ A (symPowMod A M'.X e) + (symPowMod A M.X f))) ≫ + ((chainStage2 A M M' a b ◁ chainMul2 A M M' c d e f) ≫ + chainMul2 A M M' a b (c + 1 + e) (d + 1 + f) ≫ + chainStage2Cast A M M' hp₂ hq₂) = + (α_ (symPow A M'.X (a + 1) ⊗ symPow A M.X (b + 1)) + (symPow A M'.X (c + 1) ⊗ symPow A M.X (d + 1)) + (symPow A M'.X (e + 1) ⊗ symPow A M.X (f + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X a) (symPowMod A M.X b) ⊗ₘ + ((modTensorπ A (symPowMod A M'.X c) + (symPowMod A M.X d) ⊗ₘ + modTensorπ A (symPowMod A M'.X e) + (symPowMod A M.X f)) ≫ + chainMul2 A M M' c d e f)) ≫ + (chainMul2 A M M' a b (c + 1 + e) (d + 1 + f) ≫ + chainStage2Cast A M M' hp₂ hq₂) := + congrArg (CategoryStruct.comp _) + (tensorHom_whiskerLeft_comp _ _ _ _) + have r3 : (α_ (symPow A M'.X (a + 1) ⊗ symPow A M.X (b + 1)) + (symPow A M'.X (c + 1) ⊗ symPow A M.X (d + 1)) + (symPow A M'.X (e + 1) ⊗ symPow A M.X (f + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X a) (symPowMod A M.X b) ⊗ₘ + ((modTensorπ A (symPowMod A M'.X c) + (symPowMod A M.X d) ⊗ₘ + modTensorπ A (symPowMod A M'.X e) + (symPowMod A M.X f)) ≫ + chainMul2 A M M' c d e f)) ≫ + (chainMul2 A M M' a b (c + 1 + e) (d + 1 + f) ≫ + chainStage2Cast A M M' hp₂ hq₂) = + (α_ (symPow A M'.X (a + 1) ⊗ symPow A M.X (b + 1)) + (symPow A M'.X (c + 1) ⊗ symPow A M.X (d + 1)) + (symPow A M'.X (e + 1) ⊗ symPow A M.X (f + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X a) (symPowMod A M.X b) ⊗ₘ + (tensorμ (symPow A M'.X (c + 1)) (symPow A M.X (d + 1)) + (symPow A M'.X (e + 1)) (symPow A M.X (f + 1)) ≫ + (symMul A M'.X (c + 1) (e + 1) ⊗ₘ + symMul A M.X (d + 1) (f + 1)) ≫ + modTensorπ A (symPowMod A M'.X (c + 1 + e)) + (symPowMod A M.X (d + 1 + f)))) ≫ + (chainMul2 A M M' a b (c + 1 + e) (d + 1 + f) ≫ + chainStage2Cast A M M' hp₂ hq₂) := + congrArg (fun t => + (α_ (symPow A M'.X (a + 1) ⊗ symPow A M.X (b + 1)) + (symPow A M'.X (c + 1) ⊗ symPow A M.X (d + 1)) + (symPow A M'.X (e + 1) ⊗ symPow A M.X (f + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X a) + (symPowMod A M.X b) ⊗ₘ t) ≫ + (chainMul2 A M M' a b (c + 1 + e) (d + 1 + f) ≫ + chainStage2Cast A M M' hp₂ hq₂)) + (tensorHom_π_chainMul2 A M M' c d e f) + have r4 : (α_ (symPow A M'.X (a + 1) ⊗ symPow A M.X (b + 1)) + (symPow A M'.X (c + 1) ⊗ symPow A M.X (d + 1)) + (symPow A M'.X (e + 1) ⊗ symPow A M.X (f + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X a) (symPowMod A M.X b) ⊗ₘ + (tensorμ (symPow A M'.X (c + 1)) (symPow A M.X (d + 1)) + (symPow A M'.X (e + 1)) (symPow A M.X (f + 1)) ≫ + (symMul A M'.X (c + 1) (e + 1) ⊗ₘ + symMul A M.X (d + 1) (f + 1)) ≫ + modTensorπ A (symPowMod A M'.X (c + 1 + e)) + (symPowMod A M.X (d + 1 + f)))) ≫ + (chainMul2 A M M' a b (c + 1 + e) (d + 1 + f) ≫ + chainStage2Cast A M M' hp₂ hq₂) = + (α_ (symPow A M'.X (a + 1) ⊗ symPow A M.X (b + 1)) + (symPow A M'.X (c + 1) ⊗ symPow A M.X (d + 1)) + (symPow A M'.X (e + 1) ⊗ symPow A M.X (f + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X a) (symPowMod A M.X b) ⊗ₘ + ((tensorμ (symPow A M'.X (c + 1)) (symPow A M.X (d + 1)) + (symPow A M'.X (e + 1)) (symPow A M.X (f + 1)) ≫ + (symMul A M'.X (c + 1) (e + 1) ⊗ₘ + symMul A M.X (d + 1) (f + 1))) ≫ + modTensorπ A (symPowMod A M'.X (c + 1 + e)) + (symPowMod A M.X (d + 1 + f)))) ≫ + (chainMul2 A M M' a b (c + 1 + e) (d + 1 + f) ≫ + chainStage2Cast A M M' hp₂ hq₂) := + congrArg (fun t => + (α_ (symPow A M'.X (a + 1) ⊗ symPow A M.X (b + 1)) + (symPow A M'.X (c + 1) ⊗ symPow A M.X (d + 1)) + (symPow A M'.X (e + 1) ⊗ symPow A M.X (f + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X a) + (symPowMod A M.X b) ⊗ₘ t) ≫ + (chainMul2 A M M' a b (c + 1 + e) (d + 1 + f) ≫ + chainStage2Cast A M M' hp₂ hq₂)) + (Category.assoc _ _ _).symm + have r5 : (α_ (symPow A M'.X (a + 1) ⊗ symPow A M.X (b + 1)) + (symPow A M'.X (c + 1) ⊗ symPow A M.X (d + 1)) + (symPow A M'.X (e + 1) ⊗ symPow A M.X (f + 1))).hom ≫ + (modTensorπ A (symPowMod A M'.X a) (symPowMod A M.X b) ⊗ₘ + ((tensorμ (symPow A M'.X (c + 1)) (symPow A M.X (d + 1)) + (symPow A M'.X (e + 1)) (symPow A M.X (f + 1)) ≫ + (symMul A M'.X (c + 1) (e + 1) ⊗ₘ + symMul A M.X (d + 1) (f + 1))) ≫ + modTensorπ A (symPowMod A M'.X (c + 1 + e)) + (symPowMod A M.X (d + 1 + f)))) ≫ + (chainMul2 A M M' a b (c + 1 + e) (d + 1 + f) ≫ + chainStage2Cast A M M' hp₂ hq₂) = + (α_ (symPow A M'.X (a + 1) ⊗ symPow A M.X (b + 1)) + (symPow A M'.X (c + 1) ⊗ symPow A M.X (d + 1)) + (symPow A M'.X (e + 1) ⊗ symPow A M.X (f + 1))).hom ≫ + ((symPow A M'.X (a + 1) ⊗ symPow A M.X (b + 1)) ◁ + (tensorμ (symPow A M'.X (c + 1)) (symPow A M.X (d + 1)) + (symPow A M'.X (e + 1)) (symPow A M.X (f + 1)) ≫ + (symMul A M'.X (c + 1) (e + 1) ⊗ₘ + symMul A M.X (d + 1) (f + 1)))) ≫ + (modTensorπ A (symPowMod A M'.X a) (symPowMod A M.X b) ⊗ₘ + modTensorπ A (symPowMod A M'.X (c + 1 + e)) + (symPowMod A M.X (d + 1 + f))) ≫ + (chainMul2 A M M' a b (c + 1 + e) (d + 1 + f) ≫ + chainStage2Cast A M M' hp₂ hq₂) := + congrArg (CategoryStruct.comp _) + (compTensorHom_whiskerLeft_split _ _ _ _) + have rTail := chainMul2_assoc_rightTail A M M' a b c d e f hp₂ hq₂ + exact hleft.trans + (hcore.trans (r1.trans (r2.trans (r3.trans (r4.trans + (r5.trans (congrArg (CategoryStruct.comp _) + (congrArg (CategoryStruct.comp _) rTail))))))).symm) + +end Chain2Assoc + +/-! ## The two-index transitions -/ + +section Chain2Delta + +/-- **The two-index chain transition**: multiplication by the +seed, which raises both arities by one. -/ +noncomputable def chainDelta2 + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (p q : ℕ) : + chainStage2 A M M' p q ⟶ chainStage2 A M M' (p + 1) (q + 1) := + (ρ_ (chainStage2 A M M' p q)).inv ≫ + MonoidalCategory.whiskerLeft (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainMul2 A M M' p q 0 0 + +/-- **The right unit law of the seed** at two indices: multiplying +by the seed on the right is the transition. -/ +theorem chainSeed_mul2_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (p q : ℕ) : + (chainStage2 A M M' p q ◁ chainSeed A M M' d) ≫ + chainMul2 A M M' p q 0 0 = + (ρ_ (chainStage2 A M M' p q)).hom ≫ + chainDelta2 A M M' d p q := by + rw [chainDelta2, Iso.hom_inv_id_assoc] + exact rfl + +/-- **The right transition square** at two indices: inserting the +seed in the second factor and multiplying is multiplying and then +inserting the seed. -/ +theorem chainDelta2_mul_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (i j k l : ℕ) : + (chainStage2 A M M' i j ◁ chainDelta2 A M M' d k l) ≫ + chainMul2 A M M' i j (k + 1) (l + 1) = + chainMul2 A M M' i j k l ≫ + chainDelta2 A M M' d (i + 1 + k) (j + 1 + l) := by + rw [chainDelta2, chainDelta2] + rw [MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + Category.assoc] + have hass := chainMul2_assoc A M M' i j k l 0 0 + rw [show chainStage2Cast A M M' + (by omega : i + 1 + (k + 1 + 0) = i + 1 + k + 1 + 0) + (by omega : j + 1 + (l + 1 + 0) = j + 1 + l + 1 + 0) = + 𝟙 _ from chainStage2Cast_rfl A M M' _ _, + Category.comp_id] at hass + rw [show chainMul2 A M M' (i + 1 + k) (j + 1 + l) 0 0 ≫ + 𝟙 (chainStage2 A M M' + (i + 1 + (k + 1 + 0)) (j + 1 + (l + 1 + 0))) = + chainMul2 A M M' (i + 1 + k) (j + 1 + l) 0 0 from + Category.comp_id _] at hass + have hkey : (chainStage2 A M M' i j ◁ + chainMul2 A M M' k l 0 0) ≫ + chainMul2 A M M' i j (k + 1) (l + 1) = + (α_ (chainStage2 A M M' i j) (chainStage2 A M M' k l) + (chainStage2 A M M' 0 0)).inv ≫ + (chainMul2 A M M' i j k l ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' (i + 1 + k) (j + 1 + l) 0 0 := by + have h := congrArg (fun t => + (α_ (chainStage2 A M M' i j) (chainStage2 A M M' k l) + (chainStage2 A M M' 0 0)).inv ≫ t) hass + simp only [Iso.inv_hom_id_assoc] at h + exact h.symm + rw [hkey] + have h1 : (chainStage2 A M M' i j ◁ + MonoidalCategory.whiskerLeft (chainStage2 A M M' k l) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + (α_ (chainStage2 A M M' i j) (chainStage2 A M M' k l) + (chainStage2 A M M' 0 0)).inv = + (α_ (chainStage2 A M M' i j) (chainStage2 A M M' k l) + (𝟙_ D)).inv ≫ + MonoidalCategory.whiskerLeft + (chainStage2 A M M' i j ⊗ chainStage2 A M M' k l) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) := + associator_inv_naturality_right _ _ _ + rw [reassoc_of% h1] + have h2 : (chainStage2 A M M' i j ◁ + (ρ_ (chainStage2 A M M' k l)).inv) ≫ + (α_ (chainStage2 A M M' i j) (chainStage2 A M M' k l) + (𝟙_ D)).inv = + (ρ_ (chainStage2 A M M' i j ⊗ + chainStage2 A M M' k l)).inv := by + monoidal + rw [reassoc_of% h2] + have h3 : (MonoidalCategory.whiskerLeft + (chainStage2 A M M' i j ⊗ chainStage2 A M M' k l) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + (chainMul2 A M M' i j k l ▷ chainStage2 A M M' 0 0) = + (chainMul2 A M M' i j k l ▷ 𝟙_ D) ≫ + MonoidalCategory.whiskerLeft + (chainStage2 A M M' (i + 1 + k) (j + 1 + l)) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) := + whisker_exchange _ _ + rw [reassoc_of% h3] + have h4 : (ρ_ (chainStage2 A M M' i j ⊗ + chainStage2 A M M' k l)).inv ≫ + (chainMul2 A M M' i j k l ▷ 𝟙_ D) = + chainMul2 A M M' i j k l ≫ + (ρ_ (chainStage2 A M M' (i + 1 + k) (j + 1 + l))).inv := by + rw [rightUnitor_inv_naturality] + rw [reassoc_of% h4] + +/-- Transitions transport along index casts. -/ +theorem chainStage2Cast_delta2 + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + {a b a' b' : ℕ} (ha : a = a') (hb : b = b') : + chainStage2Cast A M M' ha hb ≫ chainDelta2 A M M' d a' b' = + chainDelta2 A M M' d a b ≫ + chainStage2Cast A M M' (by omega : a + 1 = a' + 1) + (by omega : b + 1 = b' + 1) := by + subst ha hb + rw [chainStage2Cast_rfl, chainStage2Cast_rfl, + Category.id_comp, Category.comp_id] + +/-- **The left transition square** at two indices: inserting the +seed in the first factor and multiplying is multiplying and then +inserting the seed, up to the index transports. -/ +theorem chainDelta2_mul_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (i j k l : ℕ) : + (chainDelta2 A M M' d i j ▷ chainStage2 A M M' k l) ≫ + chainMul2 A M M' (i + 1) (j + 1) k l = + chainMul2 A M M' i j k l ≫ + chainDelta2 A M M' d (i + 1 + k) (j + 1 + l) ≫ + chainStage2Cast A M M' + (Nat.add_right_comm (i + 1) k 1) + (Nat.add_right_comm (j + 1) l 1) := by + have hcm : chainMul2 A M M' (i + 1) (j + 1) k l = + (β_ (chainStage2 A M M' (i + 1) (j + 1)) + (chainStage2 A M M' k l)).hom ≫ + chainMul2 A M M' k l (i + 1) (j + 1) ≫ + chainStage2Cast A M M' + (by omega : k + 1 + (i + 1) = i + 1 + 1 + k) + (by omega : l + 1 + (j + 1) = j + 1 + 1 + l) := + (chainMul2_comm A M M' (i + 1) (j + 1) k l).symm + rw [hcm] + have hnat : (chainDelta2 A M M' d i j ▷ + chainStage2 A M M' k l) ≫ + (β_ (chainStage2 A M M' (i + 1) (j + 1)) + (chainStage2 A M M' k l)).hom = + (β_ (chainStage2 A M M' i j) (chainStage2 A M M' k l)).hom ≫ + (chainStage2 A M M' k l ◁ chainDelta2 A M M' d i j) := by + rw [BraidedCategory.braiding_naturality_left] + rw [reassoc_of% hnat] + rw [reassoc_of% (chainDelta2_mul_right A M M' d k l i j)] + have hcm2 : (β_ (chainStage2 A M M' i j) + (chainStage2 A M M' k l)).hom ≫ + chainMul2 A M M' k l i j = + chainMul2 A M M' i j k l ≫ chainStage2Cast A M M' + (by omega : i + 1 + k = k + 1 + i) + (by omega : j + 1 + l = l + 1 + j) := by + have h := chainMul2_comm A M M' i j k l + rw [← h, Category.assoc, Category.assoc, + chainStage2Cast_trans, chainStage2Cast_rfl, + Category.comp_id] + rw [reassoc_of% hcm2] + rw [reassoc_of% (chainStage2Cast_delta2 A M M' d + (by omega : i + 1 + k = k + 1 + i) + (by omega : j + 1 + l = l + 1 + j))] + rw [chainStage2Cast_trans] + +end Chain2Delta + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainUnit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainUnit.lean new file mode 100644 index 0000000000..2e3716fc96 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainUnit.lean @@ -0,0 +1,95 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.NatChain +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitStage + +/-! +# Nonvanishing of the unit along a chain colimit + +For a chain of objects of the ind-category with compatible maps +from the monoidal unit, the image of the unit in the colimit +vanishes exactly when it dies at a finite stage. This is the form +in which the Key Lemma's colimit algebra is shown nonzero: the +δ-transitions carry the unit forward, and stage detection reduces +vanishing in the colimit to vanishing at a stage. The chain is +indexed by a universe-lifted copy of `ℕ`, the shape at which the +ind-category is known to have filtered colimits. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v + +/-- A `v`-small copy of the natural numbers. -/ +abbrev SmallNat : Type v := ULiftHom.{v} (ULift.{v} ℕ) + +/-- The equivalence between `ℕ` and its `v`-small copy. -/ +noncomputable def smallNatEquiv : ℕ ≌ SmallNat.{v} := + ULiftHomULiftCategory.equiv ℕ + +instance : IsFiltered SmallNat.{v} := + IsFiltered.of_equivalence smallNatEquiv + +variable {C : Type v} + +/-- Compatible unit maps ride along the chain morphisms. -/ +theorem unit_chainMap [SmallCategory C] [MonoidalCategory C] + (B : ℕ → Ind C) (δ : ∀ n, B n ⟶ B (n + 1)) + (u : ∀ n, 𝟙_ (Ind C) ⟶ B n) + (hu : ∀ n, u n ≫ δ n = u (n + 1)) {m n : ℕ} (h : m ≤ n) : + u m ≫ chainMap B δ h = u n := by + induction n, h using Nat.le_induction with + | base => rw [chainMap_self, Category.comp_id] + | succ n hmn ih => + rw [chainMap_succ_of_le B δ hmn, ← Category.assoc, ih, hu] + +/-- The chain functor over the `v`-small copy of `ℕ`. -/ +noncomputable def chainFunctorSmall [SmallCategory C] + (B : ℕ → Ind C) + (δ : ∀ n, B n ⟶ B (n + 1)) : SmallNat.{v} ⥤ Ind C := + smallNatEquiv.inverse ⋙ chainFunctor B δ + +/-- **Nonvanishing of the unit in a chain colimit**: with +compatible unit maps along the chain, the image of the unit in the +colimit is zero exactly when the unit dies at some stage. -/ +theorem unit_chain_colimit_eq_zero_iff + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] + (B : ℕ → Ind C) + (δ : ∀ n, B n ⟶ B (n + 1)) (u : ∀ n, 𝟙_ (Ind C) ⟶ B n) + (hu : ∀ n, u n ≫ δ n = u (n + 1)) (m : ℕ) : + u m ≫ colimit.ι (chainFunctorSmall B δ) + (smallNatEquiv.functor.obj m) = 0 ↔ ∃ n, u n = 0 := by + refine (unit_colimit_eq_zero_iff + (chainFunctorSmall B δ) (u m)).trans ?_ + constructor + · rintro ⟨k, α, hk⟩ + refine ⟨smallNatEquiv.inverse.obj k, ?_⟩ + rw [← unit_chainMap B δ u hu + (leOfHom (smallNatEquiv.inverse.map α))] + exact hk + · rintro ⟨n, hn⟩ + rcases le_total m n with h | h + · refine ⟨smallNatEquiv.functor.obj n, + smallNatEquiv.functor.map (homOfLE h), ?_⟩ + have : u m ≫ chainMap B δ h = 0 := by + rw [unit_chainMap B δ u hu h, hn] + exact this + · refine ⟨smallNatEquiv.functor.obj m, 𝟙 _, ?_⟩ + have hz : u m = 0 := by + rw [← unit_chainMap B δ u hu h, hn, Limits.zero_comp] + have : u m ≫ chainMap B δ (le_refl m) = 0 := by + rw [chainMap_self, Category.comp_id, hz] + exact this + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CharSplit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CharSplit.lean new file mode 100644 index 0000000000..c7d419693d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CharSplit.lean @@ -0,0 +1,409 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.RegularSum +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.Package + +/-! +# Character splitting of the completed cycle product + +The completed cycle product `cycleFun` is multiplicative in the +scalar sequence and expands over the Jacobi–Trudi characters with +Schur coefficients — the inverse Frobenius formula. Pairing the +expansion against a third character produces the Kronecker +multiplicities, which are nonnegative integers by the equivariant +Hom-space count, and yields the splitting of the Schur +specialisation at a pointwise product of scalar sequences over +pairs of shapes. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv + +universe u + +/-! ### The completed cycle product -/ + +/-- The completed cycle product of a prospective power-sum +sequence: the product of `t` over the cycle type, completed by +`t 1` over the fixed points. -/ +noncomputable def cycleFun {n : ℕ} (t : ℕ → ℂ) + (π : Equiv.Perm (Fin n)) : ℂ := + (π.cycleType.map t).prod * (t 1) ^ (n - π.cycleType.sum) + +/-- `cycleFun` is the completed cycle-type product of the +orbit-factorization development. -/ +theorem cycleFun_eq_cycleProd {n : ℕ} (t : ℕ → ℂ) + (π : Equiv.Perm (Fin n)) : + cycleFun t π = cycleProd t π := + rfl + +/-- **Multiplicativity of the completed cycle product** in the +scalar sequence. -/ +theorem cycleFun_mul {n : ℕ} (t t' : ℕ → ℂ) + (π : Equiv.Perm (Fin n)) : + cycleFun (fun c => t c * t' c) π = + cycleFun t π * cycleFun t' π := by + rw [cycleFun, cycleFun, cycleFun, Multiset.prod_map_mul, mul_pow] + ring + +/-- The completed cycle product is a class function. -/ +theorem cycleFun_conj {n : ℕ} (t : ℕ → ℂ) + (σ π : Equiv.Perm (Fin n)) : + cycleFun t (σ * π * σ⁻¹) = cycleFun t π := by + rw [cycleFun, cycleFun, Equiv.Perm.cycleType_conj] + +/-- The completed cycle product is invariant under relabelling +along an equality of sizes. -/ +theorem cycleFun_permCast {m n : ℕ} (h : m = n) (t : ℕ → ℂ) + (π : Equiv.Perm (Fin m)) : + cycleFun t (permCast h π) = cycleFun t π := by + subst h + rw [permCast_rfl, Equiv.refl_apply] + +/-! ### Shape-level Frobenius and orthonormality + +The Frobenius formula and the orthonormality of the Jacobi–Trudi +characters, reindexed along `permCast` to the group `S_n` shared by +all shapes of size `n`. -/ + +/-- **The Frobenius formula at a shape**: the normalized pairing of +the recast Jacobi–Trudi character with the completed cycle product +is the Schur specialisation. -/ +theorem jtChar_shape_frobenius {n : ℕ} (μ : Shape n) (t : ℕ → ℂ) : + ((n.factorial : ℂ))⁻¹ * ∑ π : Equiv.Perm (Fin n), + jtChar μ.val (permCast μ.prop.symm π) * cycleFun t π = + diagramSchur μ.val t := by + rw [show ((n.factorial : ℂ)) = (μ.val.card.factorial : ℂ) from by + rw [μ.prop]] + rw [← jtChar_frobenius' μ.val t, + ← Equiv.sum_comp (permCast μ.prop.symm) + (fun g => jtChar μ.val g * cycleProd t g)] + congr 1 + refine Finset.sum_congr rfl fun π _ => ?_ + rw [← cycleFun_eq_cycleProd, cycleFun_permCast] + +/-- **Orthonormality at a shape**: the recast Jacobi–Trudi +character has unit norm for the class pairing of `S_n`. -/ +theorem jtChar_shape_orthonormal {n : ℕ} (μ : Shape n) : + ((n.factorial : ℂ))⁻¹ * ∑ π : Equiv.Perm (Fin n), + jtChar μ.val (permCast μ.prop.symm π) * + jtChar μ.val (permCast μ.prop.symm π) = 1 := by + rw [show ((n.factorial : ℂ)) = (μ.val.card.factorial : ℂ) from by + rw [μ.prop]] + rw [Equiv.sum_comp (permCast μ.prop.symm) + (fun g => jtChar μ.val g * jtChar μ.val g)] + exact jtChar_orthonormal μ.val + +/-! ### Cross-shape orthogonality + +Distinct shapes of one size have orthogonal recast characters: a +common irreducible constituent would force the two Schur +specialisations to agree, contradicting the separation theorem. -/ + +/-- **Orthogonality of the recast characters**: the class pairing +of the Jacobi–Trudi characters of distinct shapes of size `n` +vanishes. -/ +theorem jtChar_orthogonal {n : ℕ} (μ ν : Shape n) (hne : μ ≠ ν) : + ((n.factorial : ℂ))⁻¹ * ∑ π : Equiv.Perm (Fin n), + jtChar μ.val (permCast μ.prop.symm π) * + jtChar ν.val (permCast ν.prop.symm π) = 0 := by + classical + set ρμ : Representation ℂ (Equiv.Perm (Fin n)) + (subCarrier (jtSimple μ.val)) := + (rhoS (jtSimple μ.val)).comp (permCastHom μ.prop.symm) with hρμ + set ρν : Representation ℂ (Equiv.Perm (Fin n)) + (subCarrier (jtSimple ν.val)) := + (rhoS (jtSimple ν.val)).comp (permCastHom ν.prop.symm) with hρν + have : ρμ.IsIrreducible := + isIrreducible_comp_permCastHom μ.prop.symm _ + (rhoS_isIrreducible _ (jtSimple_simple μ.val)) + have : ρν.IsIrreducible := + isIrreducible_comp_permCastHom ν.prop.symm _ + (rhoS_isIrreducible _ (jtSimple_simple ν.val)) + have hcard0 : ((Nat.card (Equiv.Perm (Fin n)) : ℂ)) ≠ 0 := by + rw [Nat.card_eq_fintype_card] + exact_mod_cast Fintype.card_ne_zero + have : Invertible ((Nat.card (Equiv.Perm (Fin n)) : ℂ)) := + invertibleOfNonzero hcard0 + -- the recast characters are the characters of the pullbacks + have hchμ : ∀ g : Equiv.Perm (Fin n), + ρμ.character g = jtChar μ.val (permCast μ.prop.symm g) := by + intro g + rw [jtSimple_char μ.val] + rfl + have hchν : ∀ g : Equiv.Perm (Fin n), + ρν.character g = jtChar ν.val (permCast ν.prop.symm g) := by + intro g + rw [jtSimple_char ν.val] + rfl + -- no equivalence: else the Schur specialisations agree + have hnoiso : ¬ Nonempty (ρν.Equiv ρμ) := by + rintro ⟨φ⟩ + have hchar := Representation.char_iso φ + have hds : ∀ s : ℕ → ℂ, + diagramSchur ν.val s = diagramSchur μ.val s := by + intro s + rw [← jtChar_shape_frobenius μ s, ← jtChar_shape_frobenius ν s] + congr 1 + refine Finset.sum_congr rfl fun g _ => ?_ + rw [← hchμ g, ← hchν g, hchar] + exact hne (Shape.ext (diagramSchur_injective hds)).symm + have horth := Representation.char_orthonormal ρμ ρν + rw [ite_eq_right hnoiso] at horth + rw [show ((n.factorial : ℂ))⁻¹ = + ((Nat.card (Equiv.Perm (Fin n)) : ℂ))⁻¹ from by + rw [Nat.card_eq_fintype_card, Fintype.card_perm, Fintype.card_fin]] + rw [show (∑ π : Equiv.Perm (Fin n), + jtChar μ.val (permCast μ.prop.symm π) * + jtChar ν.val (permCast ν.prop.symm π)) = + ∑ π : Equiv.Perm (Fin n), + ρμ.character π * ρν.character π⁻¹ from by + refine Finset.sum_congr rfl fun π _ => ?_ + rw [hchμ π, show ρν.character π⁻¹ = + nChar (jtSimple ν.val) (permCast ν.prop.symm π⁻¹) from rfl, + permCast_inv, ← jtSimple_char ν.val, jtChar_inv]] + rw [horth] + +/-! ### The character expansion of the completed cycle product + +The recast idempotents of a Schur package span the class elements +of `ℂ[S_n]`; expanding the class element of the completed cycle +product over them and pairing against each character determines the +coefficients as Schur specialisations — the inverse Frobenius +formula. -/ + +/-- The coefficients of a recast idempotent: the normalized recast +Jacobi–Trudi character. -/ +theorem shape_e_coeff (P : SchurPackage.{u}) {n : ℕ} (μ : Shape n) + (π : Equiv.Perm (Fin n)) : + (Shape.e P μ).coeff π = + ((P.dim μ.val : ℂ) / (n.factorial : ℂ)) * + jtChar μ.val (permCast μ.prop.symm π) := by + have h1 : (Shape.e P μ).coeff π = + (P.e μ.val).coeff ((permCast μ.prop).symm π) := by + change (symCast (le_of_eq μ.prop) (P.e μ.val)).coeff π = + (P.e μ.val).coeff ((permCast μ.prop).symm π) + rw [symCast_apply_of_eq μ.prop (P.e μ.val) π] + rw [h1, P.e_coeff, P.char_eq_jtChar, permCast_symm] + rw [show ((μ.val.card.factorial : ℂ)) = (n.factorial : ℂ) from by + rw [μ.prop]] + +/-- **The recast idempotents span the class elements**: every +conjugation-invariant coefficient function's class element is a +linear combination of the `Shape.e P μ`. -/ +theorem classElem_eq_sum_shape_e (P : SchurPackage.{u}) {n : ℕ} + (c : Equiv.Perm (Fin n) → ℂ) + (hc : ∀ g k : Equiv.Perm (Fin n), c (k * g * k⁻¹) = c g) : + ∃ a : Shape n → ℂ, + classElem c = ∑ μ : Shape n, a μ • Shape.e P μ := by + obtain ⟨a, ha⟩ := eq_sum_shape_e_of_mem_span P + (classElem_mem_span_classSum c hc) + exact ⟨a, ha.symm⟩ + +/-- **The character expansion of the completed cycle product** — +the inverse Frobenius formula: the completed cycle product expands +over the recast Jacobi–Trudi characters with the Schur +specialisations as coefficients. -/ +theorem cycleFun_expand {n : ℕ} (t : ℕ → ℂ) + (π : Equiv.Perm (Fin n)) : + cycleFun t π = ∑ μ : Shape n, + diagramSchur μ.val t * jtChar μ.val (permCast μ.prop.symm π) := by + classical + set P : SchurPackage.{0} := schurPackage.{0} with hP + obtain ⟨a, ha⟩ := classElem_eq_sum_shape_e P + (fun g => cycleFun t g) (fun g k => cycleFun_conj t k g) + set b : Shape n → ℂ := + fun μ => a μ * ((P.dim μ.val : ℂ) / (n.factorial : ℂ)) with hb + -- the coefficient identity at every permutation + have hcoeff : ∀ g : Equiv.Perm (Fin n), cycleFun t g = + ∑ μ : Shape n, b μ * jtChar μ.val (permCast μ.prop.symm g) := by + intro g + have h := congrArg (fun z : SymGroupAlgebra n => z.coeff g) ha + rw [show (classElem (fun g => cycleFun t g)).coeff g = + cycleFun t g from classElem_coeff _ g] at h + rw [show (∑ μ : Shape n, a μ • Shape.e P μ).coeff g = + ∑ μ : Shape n, (a μ • Shape.e P μ).coeff g from by + rw [MonoidAlgebra.coeff_sum] + exact Finsupp.finsetSum_apply _ _ _] at h + rw [Finset.sum_congr rfl (fun μ _ => show + (a μ • Shape.e P μ).coeff g = + a μ * (Shape.e P μ).coeff g from + MonoidAlgebra.coeff_smul_apply _ _ _)] at h + rw [Finset.sum_congr rfl (fun μ _ => by + rw [shape_e_coeff P μ g, ← mul_assoc])] at h + exact h + -- the coefficients are the Schur specialisations + have hbs : ∀ ν : Shape n, b ν = diagramSchur ν.val t := by + intro ν + rw [← jtChar_shape_frobenius ν t] + rw [Finset.sum_congr rfl fun g _ => by rw [hcoeff g]] + rw [Finset.sum_congr rfl fun g _ => Finset.mul_sum + (f := fun μ : Shape n => + b μ * jtChar μ.val (permCast μ.prop.symm g)) + (a := jtChar ν.val (permCast ν.prop.symm g)) Finset.univ] + rw [Finset.sum_comm] + rw [Finset.sum_congr rfl fun μ _ => show + (∑ g : Equiv.Perm (Fin n), + jtChar ν.val (permCast ν.prop.symm g) * + (b μ * jtChar μ.val (permCast μ.prop.symm g))) = + b μ * ∑ g : Equiv.Perm (Fin n), + jtChar ν.val (permCast ν.prop.symm g) * + jtChar μ.val (permCast μ.prop.symm g) from by + rw [Finset.mul_sum] + exact Finset.sum_congr rfl fun g _ => by ring] + rw [Finset.mul_sum] + rw [Finset.sum_congr rfl fun μ _ => + (mul_left_comm ((n.factorial : ℂ))⁻¹ (b μ) _)] + rw [Finset.sum_eq_single ν + (fun μ _ hμν => by + rw [jtChar_orthogonal ν μ (Ne.symm hμν), mul_zero]) + (fun h => absurd (Finset.mem_univ ν) h)] + rw [jtChar_shape_orthonormal ν, mul_one] + rw [hcoeff π] + exact Finset.sum_congr rfl fun μ _ => by rw [hbs μ] + +/-! ### Kronecker multiplicities + +The triple class pairing of three recast characters counts, by the +equivariant Hom-space dimension against a tensor product of +pullback representations, a nonnegative integer. -/ + +/-- The Kronecker multiplicity of three shapes of one size: the +normalized triple class pairing of their recast Jacobi–Trudi +characters. -/ +noncomputable def kronMult {n : ℕ} (lam μ ν : Shape n) : ℂ := + ((n.factorial : ℂ))⁻¹ * ∑ π : Equiv.Perm (Fin n), + jtChar lam.val (permCast lam.prop.symm π) * + jtChar μ.val (permCast μ.prop.symm π) * + jtChar ν.val (permCast ν.prop.symm π) + +/-- **Kronecker multiplicities are nonnegative integers**: the +triple pairing is the dimension of an equivariant Hom space. -/ +theorem kronMult_exists_nat {n : ℕ} (lam μ ν : Shape n) : + ∃ m : ℕ, kronMult lam μ ν = m := by + classical + set ρl : Representation ℂ (Equiv.Perm (Fin n)) + (subCarrier (jtSimple lam.val)) := + (rhoS (jtSimple lam.val)).comp (permCastHom lam.prop.symm) + with hρl + set ρμ : Representation ℂ (Equiv.Perm (Fin n)) + (subCarrier (jtSimple μ.val)) := + (rhoS (jtSimple μ.val)).comp (permCastHom μ.prop.symm) with hρμ + set ρν : Representation ℂ (Equiv.Perm (Fin n)) + (subCarrier (jtSimple ν.val)) := + (rhoS (jtSimple ν.val)).comp (permCastHom ν.prop.symm) with hρν + have hcard0 : ((Nat.card (Equiv.Perm (Fin n)) : ℂ)) ≠ 0 := by + rw [Nat.card_eq_fintype_card] + exact_mod_cast Fintype.card_ne_zero + have : Invertible ((Nat.card (Equiv.Perm (Fin n)) : ℂ)) := + invertibleOfNonzero hcard0 + have h := Representation.card_inv_mul_sum_char_mul_char_eq_finrank + (W := TensorProduct ℂ (subCarrier (jtSimple μ.val)) + (subCarrier (jtSimple ν.val))) + ρl (Representation.tprod ρμ ρν) + refine ⟨Module.finrank ℂ + (Representation.IntertwiningMap ρl + (Representation.tprod ρμ ρν)), ?_⟩ + rw [← h, kronMult] + rw [show ((n.factorial : ℂ))⁻¹ = + ((Nat.card (Equiv.Perm (Fin n)) : ℂ))⁻¹ from by + rw [Nat.card_eq_fintype_card, Fintype.card_perm, Fintype.card_fin]] + congr 1 + refine Finset.sum_congr rfl fun π _ => ?_ + rw [Representation.char_tensor, Pi.mul_apply] + rw [show ρμ.character π = + jtChar μ.val (permCast μ.prop.symm π) from by + rw [jtSimple_char μ.val]; rfl] + rw [show ρν.character π = + jtChar ν.val (permCast ν.prop.symm π) from by + rw [jtSimple_char ν.val]; rfl] + rw [show ρl.character π⁻¹ = + jtChar lam.val (permCast lam.prop.symm π) from by + rw [show ρl.character π⁻¹ = + nChar (jtSimple lam.val) (permCast lam.prop.symm π⁻¹) from + rfl, + permCast_inv, ← jtSimple_char lam.val, jtChar_inv]] + ring + +/-! ### The Kronecker splitting identity + +The Schur specialisation at a pointwise product of scalar +sequences splits over pairs of shapes with Kronecker +multiplicities: Frobenius at the product, multiplicativity of the +completed cycle product, and the character expansion of each +factor. -/ + +/-- **The Kronecker splitting identity**: the Schur specialisation +at a pointwise product of scalar sequences is the +Kronecker-weighted sum of products of Schur specialisations. -/ +theorem diagramSchur_pointwise_mul (lam : YoungDiagram) + (t t' : ℕ → ℂ) : + diagramSchur lam (fun c => t c * t' c) = + ∑ μ : Shape lam.card, ∑ ν : Shape lam.card, + kronMult ⟨lam, rfl⟩ μ ν * diagramSchur μ.val t * + diagramSchur ν.val t' := by + classical + set L : Shape lam.card := ⟨lam, rfl⟩ with hL + rw [show diagramSchur lam (fun c => t c * t' c) = + diagramSchur L.val (fun c => t c * t' c) from rfl] + rw [← jtChar_shape_frobenius L (fun c => t c * t' c)] + rw [Finset.sum_congr rfl fun π _ => by + rw [cycleFun_mul t t' π, cycleFun_expand t π, + cycleFun_expand t' π]] + -- expand the product of the two shape sums + rw [Finset.sum_congr rfl fun π _ => by + rw [Finset.sum_mul_sum Finset.univ Finset.univ + (fun μ : Shape lam.card => diagramSchur μ.val t * + jtChar μ.val (permCast μ.prop.symm π)) + (fun ν : Shape lam.card => diagramSchur ν.val t' * + jtChar ν.val (permCast ν.prop.symm π))]] + -- push the character of `L` inside and swap the summations + rw [Finset.sum_congr rfl fun π _ => Finset.mul_sum + (f := fun μ : Shape lam.card => ∑ ν : Shape lam.card, + (diagramSchur μ.val t * jtChar μ.val (permCast μ.prop.symm π)) * + (diagramSchur ν.val t' * + jtChar ν.val (permCast ν.prop.symm π))) + (a := jtChar L.val (permCast L.prop.symm π)) Finset.univ] + rw [Finset.sum_comm] + rw [Finset.sum_congr rfl fun μ _ => Finset.sum_congr rfl + fun π _ => Finset.mul_sum + (f := fun ν : Shape lam.card => + (diagramSchur μ.val t * + jtChar μ.val (permCast μ.prop.symm π)) * + (diagramSchur ν.val t' * + jtChar ν.val (permCast ν.prop.symm π))) + (a := jtChar L.val (permCast L.prop.symm π)) Finset.univ] + rw [Finset.sum_congr rfl fun μ _ => Finset.sum_comm + (s := (Finset.univ : Finset (Equiv.Perm (Fin lam.card)))) + (t := (Finset.univ : Finset (Shape lam.card)))] + -- identify each inner permutation sum as a Kronecker multiplicity + rw [Finset.mul_sum] + refine Finset.sum_congr rfl fun μ _ => ?_ + rw [Finset.mul_sum] + refine Finset.sum_congr rfl fun ν _ => ?_ + rw [kronMult] + rw [show (∑ π : Equiv.Perm (Fin lam.card), + jtChar L.val (permCast L.prop.symm π) * + ((diagramSchur μ.val t * + jtChar μ.val (permCast μ.prop.symm π)) * + (diagramSchur ν.val t' * + jtChar ν.val (permCast ν.prop.symm π)))) = + diagramSchur μ.val t * diagramSchur ν.val t' * + ∑ π : Equiv.Perm (Fin lam.card), + jtChar L.val (permCast L.prop.symm π) * + jtChar μ.val (permCast μ.prop.symm π) * + jtChar ν.val (permCast ν.prop.symm π) from by + rw [Finset.mul_sum] + exact Finset.sum_congr rfl fun π _ => by ring] + ring + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CommonAlgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CommonAlgebra.lean new file mode 100644 index 0000000000..b107823a26 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CommonAlgebra.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndBigTensorUnit + +/-! +# A common extension of a family of algebras + +Any small family of nonzero commutative algebras of the +ind-completion sits inside a single nonzero commutative algebra: +their tensor product. This is the device of Deligne 2.11, which +uses it to make every object mixed and every short exact sequence +split simultaneously. + +The index type is put in bijection with a well-ordered one so +that the slot order required by the tensor product is available. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v + +variable {C : Type v} + +/-- **A family of nonzero algebras has a common nonzero +extension**: their tensor product, into which each factor maps by +a morphism of monoid objects. -/ +theorem exists_common_algebra [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ C] [MonoidalPreadditive C] [MonoidalLinear ℂ C] + [RigidCategory C] [SymmetricCategory (Ind C)] + (hu : HasScalarUnit C) {ι : Type v} + (B : ι → Ind C) [∀ i, MonObj (B i)] [∀ i, IsCommMonObj (B i)] + (hB : ∀ i, MonObj.one (X := B i) ≠ 0) : + ∃ (𝔸 : Ind C) (_ : MonObj 𝔸) (_ : IsCommMonObj 𝔸), + MonObj.one (X := 𝔸) ≠ 0 ∧ + ∀ i, ∃ φ : B i ⟶ 𝔸, IsMonHom φ := by + let : DecidableRel (WellOrderingRel (α := ι)) := + Classical.decRel _ + let : LinearOrder ι := linearOrderOfSTO WellOrderingRel + refine ⟨bigTensor B, bigTensorMon B, bigTensorCommMon B, + bigTensorUnit_ne_zero_ind B hu hB, ?_⟩ + intro i + exact ⟨bigTensorOf B i, isMonHom_bigTensorOf B i⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoprodPreserve.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoprodPreserve.lean new file mode 100644 index 0000000000..a8ef0c8c86 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoprodPreserve.lean @@ -0,0 +1,166 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Preservation of coproducts from finite and filtered + +A functor preserving finite coproducts and `Finset`-shaped +colimits preserves arbitrary coproducts: the coproduct is the +filtered colimit of its finite subcoproducts, and the functor +preserves every stage and the colimit itself. Mathlib carries the +existence half of this construction; the preservation half is +supplied here. The consumer is the tensor product on the +ind-category, which is exact and preserves filtered colimits, and +must be seen to preserve the coend presentations of §3. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Limits CoproductsFromFiniteFiltered + +universe w v u v' u' + +variable {C : Type u} + +section + +/-- The stagewise comparison morphism at a finite stage is +invertible for a functor preserving finite coproducts. -/ +instance isIso_sigmaComparison_stage + [Category.{v} C] {D : Type u'} [Category.{v'} D] {α : Type w} + [HasFiniteCoproducts C] [HasFiniteCoproducts D] (G : C ⥤ D) + [PreservesFiniteCoproducts G] + (f : α → C) + (S : Finset (Discrete α)) : + IsIso (sigmaComparison G fun x : S => + (Discrete.functor f).obj x) := by + rw [← PreservesCoproduct.inv_hom] + infer_instance + +/-- The stage-level comparison computation, restated at the exact +syntactic form of the `Finset` diagram's coproduct families. -/ +@[reassoc] +theorem stage_ι_comp + [Category.{v} C] {D : Type u'} [Category.{v'} D] {α : Type w} + [HasFiniteCoproducts C] [HasFiniteCoproducts D] (G : C ⥤ D) + (f : α → C) (S : Finset (Discrete α)) + (x : S) : + Sigma.ι (fun y : S => + (Discrete.functor fun z => G.obj (f z)).obj y) x ≫ + sigmaComparison G (fun y : S => (Discrete.functor f).obj y) = + G.map (Sigma.ι + (fun y : S => (Discrete.functor f).obj y) x) := + ι_comp_sigmaComparison G _ x + +/-- The stagewise coproduct comparisons of a functor preserving +finite coproducts, assembled into an isomorphism of `Finset` +diagrams. -/ +noncomputable def liftToFinsetComparison + [Category.{v} C] {D : Type u'} [Category.{v'} D] {α : Type w} + [HasFiniteCoproducts C] [HasFiniteCoproducts D] (G : C ⥤ D) + [PreservesFiniteCoproducts G] + (f : α → C) : + liftToFinsetObj (Discrete.functor fun x => G.obj (f x)) ≅ + liftToFinsetObj (Discrete.functor f) ⋙ G := by + refine NatIso.ofComponents + (fun S => @asIso _ _ _ _ + (sigmaComparison G fun x : S => (Discrete.functor f).obj x) + (isIso_sigmaComparison_stage G f S)) ?_ + intro S T h + change ((Sigma.desc fun y : S => + Sigma.ι (fun x : T => + (Discrete.functor fun z => G.obj (f z)).obj x) + ⟨y.1, h.down.down y.2⟩ : + (∐ fun x : S => + (Discrete.functor fun z => G.obj (f z)).obj x) ⟶ + ∐ fun x : T => + (Discrete.functor fun z => G.obj (f z)).obj x)) ≫ + sigmaComparison G (fun x : T => (Discrete.functor f).obj x) = + sigmaComparison G (fun x : S => (Discrete.functor f).obj x) ≫ + G.map ((Sigma.desc fun y : S => + Sigma.ι (fun x : T => (Discrete.functor f).obj x) + ⟨y.1, h.down.down y.2⟩ : + (∐ fun x : S => (Discrete.functor f).obj x) ⟶ + ∐ fun x : T => (Discrete.functor f).obj x)) + apply Sigma.hom_ext + intro x + erw [stage_ι_comp_assoc, ← G.map_comp, Sigma.ι_comp_desc, + Sigma.ι_comp_desc_assoc, stage_ι_comp] + +/-- **Preservation of coproducts from finite and filtered**: a +functor preserving finite coproducts and `Finset`-shaped colimits +preserves every coproduct indexed by `α`. -/ +theorem preservesCoproduct_of_finite_and_filtered + [Category.{v} C] {D : Type u'} [Category.{v'} D] {α : Type w} + [HasFiniteCoproducts C] [HasFiniteCoproducts D] (G : C ⥤ D) + [PreservesFiniteCoproducts G] + [HasColimitsOfShape (Finset (Discrete α)) C] + [HasColimitsOfShape (Finset (Discrete α)) D] + [PreservesColimitsOfShape (Finset (Discrete α)) G] + (f : α → C) : + PreservesColimit (Discrete.functor f) G := by + have : HasCoproduct f := + HasColimit.mk (liftToFinsetColimitCocone (Discrete.functor f)) + have : HasCoproduct fun x => G.obj (f x) := + HasColimit.mk + (liftToFinsetColimitCocone (Discrete.functor fun x => G.obj (f x))) + have hD' : IsColimit ((Cocone.precompose + (liftToFinsetComparison G f).hom).obj + (G.mapCocone (finiteSubcoproductsCocone f))) := + (IsColimit.precomposeHomEquiv (liftToFinsetComparison G f) _).symm + (isColimitOfPreserves G (isColimitFiniteSubproductsCocone f)) + have hD2 := isColimitFiniteSubproductsCocone fun x => G.obj (f x) + let m : finiteSubcoproductsCocone (fun x => G.obj (f x)) ⟶ + (Cocone.precompose (liftToFinsetComparison G f).hom).obj + (G.mapCocone (finiteSubcoproductsCocone f)) := + { hom := sigmaComparison G f + w := by + intro S + change ((Sigma.desc fun s : S => + Sigma.ι (fun y => G.obj (f y)) s.1.as : + (∐ fun x : S => + (Discrete.functor fun z => G.obj (f z)).obj x) ⟶ + ∐ fun y => G.obj (f y))) ≫ sigmaComparison G f = + sigmaComparison G + (fun x : S => (Discrete.functor f).obj x) ≫ + G.map ((Sigma.desc fun s : S => Sigma.ι f s.1.as : + (∐ fun x : S => (Discrete.functor f).obj x) ⟶ + ∐ f)) + apply Sigma.hom_ext + intro x + erw [Sigma.ι_comp_desc_assoc, ι_comp_sigmaComparison, + stage_ι_comp_assoc, ← G.map_comp, Sigma.ι_comp_desc] } + have : IsIso m := hD2.hom_isIso hD' m + have : IsIso (sigmaComparison G f) := by + have : IsIso ((Cocone.forget _).map m) := inferInstance + exact this + exact PreservesCoproduct.of_iso_comparison G f + +/-- Shape form of the preservation of coproducts from finite and +filtered. -/ +theorem preservesColimitsOfShape_discrete_of_finite_and_filtered + [Category.{v} C] {D : Type u'} [Category.{v'} D] {α : Type w} + [HasFiniteCoproducts C] [HasFiniteCoproducts D] (G : C ⥤ D) + [PreservesFiniteCoproducts G] + [HasColimitsOfShape (Finset (Discrete α)) C] + [HasColimitsOfShape (Finset (Discrete α)) D] + [PreservesColimitsOfShape (Finset (Discrete α)) G] : + PreservesColimitsOfShape (Discrete α) G := by + constructor + intro F + have := preservesCoproduct_of_finite_and_filtered G + (F.obj ∘ Discrete.mk) + exact preservesColimit_of_iso_diagram G Discrete.natIsoFunctor.symm + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescent.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescent.lean new file mode 100644 index 0000000000..b743f80ddb --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescent.lean @@ -0,0 +1,889 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaCountable + +/-! +# Countable descent for the witnessing algebras + +The dimension count of `RS.Classical.Deligne.GammaCountable` asks +each constituent algebra of the universal algebra of Deligne 2.11 to +be countably presented (`RS.CountablyPresented`): a countable +filtered colimit of embedded objects. An algebra witnessing local +mixedness or a splitting is to be replaced by a countably presented +one, and this file assembles the two devices such a replacement +runs on: the countable tower generated inside an algebra by one +stage of its presentation, and the compactness of the objects that +carry the finite data to be pushed down that tower. + +The tower. Every ind-object is a filtered colimit of embedded +objects (`Ind.presentation`), the stage maps being `RS.presStage`, +and compactness of the embedded objects factors any map out of one +of them through a stage (`RS.exists_presStage_factor`). Starting +from a stage of the presentation of an algebra, rung `n + 1` of the +tower is chosen above rung `n` and above a stage absorbing the +square of rung `n`. The colimit `RS.stageSubalgebra` of the tower +is then countably presented +(`RS.countablyPresented_stageSubalgebra`), maps to the algebra +(`RS.stageSubalgebraHom`), contains the unit +(`RS.exists_unit_stageSubalgebra`) and is closed under +multiplication one rung at a time (`RS.stageRungMul_comp_hom`). + +The tower inside the algebra. The ind-completion of a small abelian +category is abelian, so each rung may be replaced by its image in the +algebra (`RS.stageImage`). The rung maps are then monomorphisms, and +so is the map `RS.imageSubalgebraHom` of the resulting colimit +`RS.imageSubalgebra` into the algebra +(`RS.mono_imageSubalgebraHom`): a map out of an embedded object into +the colimit factors through a rung, and monomorphisms of ind-objects +are detected on the embedded objects +(`RS.mono_of_hom_indOf_injective`). Countable presentation of the +image tower is `RS.countablyPresented_imageSubalgebra`, over the +hypothesis `RS.IndImageEmbedded` that images of embedded objects are +embedded. + +The compactness. The data to be pushed down is carried by mixed +sums of the unit and the odd line. The unit is compact because it +is embedded; the odd line is compact because its square is the unit, +which makes tensoring with it an equivalence and so turns a map out +of it into a point of a translate — this is `RS.oddUntwist`, and it +gives both halves of the compactness formula, +`RS.exists_factor_of_sq_unit_hom_colimit` and +`RS.factor_eq_of_sq_unit_hom_colimit`. Mixed sums are finite +biproducts of the two, and a finite family of stages of a filtered +diagram is dominated by a single stage, whence +`RS.exists_factor_of_mix_hom_colimit`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +/-! ## Towers of embedded objects + +An ℕ-shaped diagram is filtered and countable, so the colimit of a +tower of embedded objects is countably presented. The index +category has to live in the ambient universe, whence the `AsSmall` +wrapper. -/ + +section Tower + +/-- The index category of a tower: the natural numbers, transported +into the ambient universe. -/ +abbrev Tower : Type v := AsSmall.{v} ℕ + +instance countable_tower : Countable Tower.{v} := + inferInstanceAs (Countable (ULift ℕ)) + +variable {C : Type v} + +/-- The diagram of a tower of objects of `C`. -/ +noncomputable def towerDiagram [SmallCategory C] + {Y : ℕ → C} (u : ∀ n, Y n ⟶ Y (n + 1)) : + Tower.{v} ⥤ C := + AsSmall.down ⋙ Functor.ofSequence u + +/-- **The colimit of a tower of embedded objects is countably +presented.** This is the shape in which countable presentation is +produced below: no bookkeeping beyond the tower itself. -/ +theorem countablyPresented_colimit_tower [SmallCategory C] + {Y : ℕ → C} + (u : ∀ n, Y n ⟶ Y (n + 1)) : + CountablyPresented (colimit (towerDiagram u ⋙ indOf)) := + ⟨Tower.{v}, inferInstance, inferInstance, inferInstance, + towerDiagram u, ⟨Iso.refl _⟩⟩ + +end Tower + +/-! ## The stages of a presentation + +Mathlib's `Ind.presentation` exhibits every ind-object as a filtered +colimit of embedded objects. The maps of the stages into the +ind-object are `RS.presStage`, and compactness of the embedded +objects (`RS.exists_factor_of_hom_colimit`) factors any map out of an +embedded object through one of them. -/ + +section Presentation + +variable {C : Type v} + +/-- The diagram of embedded objects presenting an ind-object. -/ +noncomputable abbrev presDiagram [SmallCategory C] + (A : Ind C) : A.presentation.I ⥤ Ind C := + A.presentation.F ⋙ indOf + +/-- The structural map of a stage of the chosen presentation into the +ind-object it presents. -/ +noncomputable def presStage [SmallCategory C] + (A : Ind C) (i : A.presentation.I) : + indOf.obj (A.presentation.F.obj i) ⟶ A := + colimit.ι (presDiagram A) i ≫ (Ind.colimitPresentationCompYoneda A).hom + +/-- The structural maps are compatible with the transition maps of +the presentation. -/ +theorem presStage_naturality [SmallCategory C] + (A : Ind C) {i j : A.presentation.I} + (α : i ⟶ j) : + indOf.map (A.presentation.F.map α) ≫ presStage A j = presStage A i := by + rw [presStage, presStage, ← Category.assoc] + exact eq_whisker (colimit.w (presDiagram A) α) _ + +/-- **A map out of an embedded object factors through a stage of the +presentation**: this is compactness of the embedded objects. -/ +theorem exists_presStage_factor [SmallCategory C] + (A : Ind C) {Y : C} + (f : indOf.obj Y ⟶ A) : + ∃ (i : A.presentation.I) (g : Y ⟶ A.presentation.F.obj i), + indOf.map g ≫ presStage A i = f := by + obtain ⟨i, g, hg⟩ := exists_factor_of_hom_colimit (presDiagram A) Y + (f ≫ (Ind.colimitPresentationCompYoneda A).inv) + refine ⟨i, Ind.yoneda.fullyFaithful.preimage g, ?_⟩ + have hp : indOf.map (Ind.yoneda.fullyFaithful.preimage g) = g := + Ind.yoneda.fullyFaithful.map_preimage g + rw [hp, presStage, ← Category.assoc] + refine (eq_whisker hg _).trans ?_ + rw [Category.assoc, Iso.inv_hom_id, Category.comp_id] + +/-- **A point of an ind-object factors through a stage.** -/ +theorem exists_presStage_point [SmallCategory C] + [MonoidalCategory C] (A : Ind C) + (f : 𝟙_ (Ind C) ⟶ A) : + ∃ (i : A.presentation.I) (e : 𝟙_ (Ind C) ⟶ + indOf.obj (A.presentation.F.obj i)), e ≫ presStage A i = f := by + obtain ⟨i, g, hg⟩ := exists_factor_of_unit_hom_colimit (presDiagram A) + (f ≫ (Ind.colimitPresentationCompYoneda A).inv) + refine ⟨i, g, ?_⟩ + rw [presStage, ← Category.assoc] + refine (eq_whisker hg _).trans ?_ + rw [Category.assoc, Iso.inv_hom_id, Category.comp_id] + +end Presentation + +/-! ## The subalgebra generated by a stage + +Rung `n + 1` of the tower is chosen above rung `n` and above a stage +of the presentation absorbing the square of rung `n`. The colimit of +the tower is therefore countably presented, maps to the algebra, and +is closed under multiplication one rung at a time. -/ + +section Generate + +variable {C : Type v} + +/-- The square of a stage of the presentation, multiplied into the +algebra. -/ +noncomputable def stageMulToAlg + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] + (i : A.presentation.I) : + indOf.obj (A.presentation.F.obj i ⊗ A.presentation.F.obj i) ⟶ A := + (indOfTensorIso _ _).inv ≫ (presStage A i ⊗ₘ presStage A i) ≫ μ[A] + +/-- A stage of the presentation absorbing the square of the given +stage. -/ +noncomputable def mulStage + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] + (i : A.presentation.I) : A.presentation.I := + (exists_presStage_factor A (stageMulToAlg A i)).choose + +/-- The multiplication of a stage with itself, landing in the +absorbing stage. -/ +noncomputable def mulStageMap + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] + (i : A.presentation.I) : + A.presentation.F.obj i ⊗ A.presentation.F.obj i ⟶ + A.presentation.F.obj (mulStage A i) := + (exists_presStage_factor A (stageMulToAlg A i)).choose_spec.choose + +/-- The comparison of the embedding with the tensor product turns the +square of a stage into the product of its two structural maps. -/ +theorem indOfTensorIso_stageMulToAlg + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] + (i : A.presentation.I) : + (indOfTensorIso (A.presentation.F.obj i) + (A.presentation.F.obj i)).hom ≫ stageMulToAlg A i = + (presStage A i ⊗ₘ presStage A i) ≫ μ[A] := by + rw [stageMulToAlg, ← Category.assoc, Iso.hom_inv_id, Category.id_comp] + +theorem mulStageMap_spec + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] + (i : A.presentation.I) : + indOf.map (mulStageMap A i) ≫ presStage A (mulStage A i) = + stageMulToAlg A i := + (exists_presStage_factor A (stageMulToAlg A i)).choose_spec.choose_spec + +/-- The next rung: a stage above the given one and above the stage +absorbing its square. -/ +noncomputable def nextStage + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] + (i : A.presentation.I) : A.presentation.I := + IsFiltered.max i (mulStage A i) + +/-- The transition map of the tower, at the level of the index +category of the presentation. -/ +noncomputable def stageStep + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] + (i : A.presentation.I) : i ⟶ nextStage A i := + IsFiltered.leftToMax _ _ + +/-- The multiplication of a stage with itself, landing in the next +rung. -/ +noncomputable def stageMul + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] + (i : A.presentation.I) : + A.presentation.F.obj i ⊗ A.presentation.F.obj i ⟶ + A.presentation.F.obj (nextStage A i) := + mulStageMap A i ≫ + A.presentation.F.map (IsFiltered.rightToMax i (mulStage A i)) + +theorem stageMul_spec + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] + (i : A.presentation.I) : + indOf.map (stageMul A i) ≫ presStage A (nextStage A i) = + stageMulToAlg A i := by + erw [stageMul, CategoryTheory.Functor.map_comp, Category.assoc, + presStage_naturality, mulStageMap_spec] + +/-- The stages of the generated tower. -/ +noncomputable def towerIdx + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] + (i₀ : A.presentation.I) : ℕ → A.presentation.I + | 0 => i₀ + | n + 1 => nextStage A (towerIdx A i₀ n) + +/-- The rungs of the generated tower, as objects of `C`. -/ +@[reducible] noncomputable def towerObj + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] + (i₀ : A.presentation.I) + (n : ℕ) : C := + A.presentation.F.obj (towerIdx A i₀ n) + +/-- The transition maps of the generated tower. -/ +noncomputable def towerStep + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] + (i₀ : A.presentation.I) + (n : ℕ) : + towerObj A i₀ n ⟶ towerObj A i₀ (n + 1) := + A.presentation.F.map (stageStep A (towerIdx A i₀ n)) + +/-- The tower as a diagram of ind-objects. -/ +noncomputable def towerSeq + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] + (i₀ : A.presentation.I) : ℕ ⥤ Ind C := + Functor.ofSequence (towerStep A i₀) ⋙ indOf + +/-- The cocone of the tower under the algebra. -/ +noncomputable def towerNatTrans + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] + (i₀ : A.presentation.I) : + towerSeq A i₀ ⟶ (Functor.const ℕ).obj A := + NatTrans.ofSequence (fun n => presStage A (towerIdx A i₀ n)) (by + intro n + have h1 : (towerSeq A i₀).map (homOfLE (n.le_add_right 1)) = + indOf.map (towerStep A i₀ n) := + congrArg (fun m => indOf.map m) + (Functor.ofSequence_map_homOfLE_succ (towerStep A i₀) n) + have h2 : indOf.map (towerStep A i₀ n) ≫ + presStage A (towerIdx A i₀ (n + 1)) = + presStage A (towerIdx A i₀ n) := + presStage_naturality A (stageStep A (towerIdx A i₀ n)) + exact (eq_whisker h1 _).trans (h2.trans (Category.comp_id _).symm)) + +/-- **The subalgebra generated by a stage**: the colimit of the +tower. It is not known to be a subobject of the algebra — see +the module documentation — but it is countably presented, it maps to +the algebra, it contains the unit and it is closed under +multiplication rung by rung. -/ +noncomputable def stageSubalgebra + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] + (i₀ : A.presentation.I) : Ind C := + colimit (towerDiagram (towerStep A i₀) ⋙ indOf) + +/-- **The generated tower is countably presented.** -/ +theorem countablyPresented_stageSubalgebra + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] + (i₀ : A.presentation.I) : + CountablyPresented (stageSubalgebra A i₀) := + countablyPresented_colimit_tower _ + +/-- The map of the generated tower into the algebra. -/ +noncomputable def stageSubalgebraHom + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] + (i₀ : A.presentation.I) : stageSubalgebra A i₀ ⟶ A := + colimit.desc _ (Cocone.whisker AsSmall.down + (Cocone.mk A (towerNatTrans A i₀))) + +/-- The rungs of the generated tower map into it. -/ +noncomputable def stageRung + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] + (i₀ : A.presentation.I) + (n : ℕ) : + indOf.obj (towerObj A i₀ n) ⟶ stageSubalgebra A i₀ := + colimit.ι (towerDiagram (towerStep A i₀) ⋙ indOf) ⟨n⟩ + +@[simp] theorem stageRung_comp_hom + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] + (i₀ : A.presentation.I) + (n : ℕ) : + stageRung A i₀ n ≫ stageSubalgebraHom A i₀ = + presStage A (towerIdx A i₀ n) := + colimit.ι_desc _ _ + +/-- The multiplication of a rung of the generated tower with itself, +landing in the next rung. -/ +noncomputable def stageRungMul + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] + (i₀ : A.presentation.I) + (n : ℕ) : + indOf.obj (towerObj A i₀ n) ⊗ indOf.obj (towerObj A i₀ n) ⟶ + stageSubalgebra A i₀ := + (indOfTensorIso (towerObj A i₀ n) (towerObj A i₀ n)).hom ≫ + indOf.map (stageMul A (towerIdx A i₀ n)) ≫ stageRung A i₀ (n + 1) + +/-- **The generated tower is closed under multiplication, rung by +rung**: the product of a rung with itself, taken in the algebra, +factors through the tower. -/ +theorem stageRungMul_comp_hom + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] + (i₀ : A.presentation.I) + (n : ℕ) : + stageRungMul A i₀ n ≫ stageSubalgebraHom A i₀ = + (presStage A (towerIdx A i₀ n) ⊗ₘ + presStage A (towerIdx A i₀ n)) ≫ μ[A] := + have h4 : stageRung A i₀ (n + 1) ≫ stageSubalgebraHom A i₀ = + presStage A (nextStage A (towerIdx A i₀ n)) := + stageRung_comp_hom A i₀ (n + 1) + have h3 : indOf.map (stageMul A (towerIdx A i₀ n)) ≫ + presStage A (nextStage A (towerIdx A i₀ n)) = + stageMulToAlg A (towerIdx A i₀ n) := + stageMul_spec A (towerIdx A i₀ n) + (Category.assoc _ _ _).trans + ((whisker_eq _ ((Category.assoc _ _ _).trans + ((whisker_eq _ h4).trans h3))).trans + (indOfTensorIso_stageMulToAlg A (towerIdx A i₀ n))) + +/-! ### The unit rung + +Generating the tower at a stage through which the unit of the algebra +factors puts the unit into the tower. -/ + +/-- A stage of the presentation through which the unit factors. -/ +noncomputable def unitStage + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] : + A.presentation.I := + (exists_presStage_point A η[A]).choose + +/-- The unit, read at the stage that absorbs it. -/ +noncomputable def unitStagePoint + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] : + 𝟙_ (Ind C) ⟶ indOf.obj (A.presentation.F.obj (unitStage A)) := + (exists_presStage_point A η[A]).choose_spec.choose + +theorem unitStagePoint_spec + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] : + unitStagePoint A ≫ presStage A (unitStage A) = η[A] := + (exists_presStage_point A η[A]).choose_spec.choose_spec + +/-- **The tower generated at the unit stage contains the unit.** -/ +theorem exists_unit_stageSubalgebra + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] : + ∃ e : 𝟙_ (Ind C) ⟶ stageSubalgebra A (unitStage A), + e ≫ stageSubalgebraHom A (unitStage A) = η[A] := by + refine ⟨unitStagePoint A ≫ stageRung A (unitStage A) 0, ?_⟩ + have h0 : stageRung A (unitStage A) 0 ≫ + stageSubalgebraHom A (unitStage A) = presStage A (unitStage A) := + stageRung_comp_hom A (unitStage A) 0 + exact (Category.assoc _ _ _).trans + ((whisker_eq _ h0).trans (unitStagePoint_spec A)) + +end Generate + +/-! ## The image tower + +The ind-completion of a small abelian category is abelian, so a map +into an ind-object has an image, and the rungs of the generated tower +can be replaced by their images in the algebra. The rung maps then +become monomorphisms, and so does the map of the resulting colimit +into the algebra: a map out of an embedded object into the colimit +factors through a rung, and monomorphisms of ind-objects are detected +on the embedded objects. -/ + +section Detect + +variable {C : Type v} + +/-- **Monomorphisms are detected on the embedded objects**: a map of +ind-objects along which maps out of embedded objects cancel is a +monomorphism. Every ind-object is a filtered colimit of embedded +objects, so a pair of maps into the source is determined by its +restrictions to embedded objects. -/ +theorem mono_of_hom_indOf_injective [SmallCategory C] + {Y Z : Ind C} (f : Y ⟶ Z) + (h : ∀ (W : C) (u v : indOf.obj W ⟶ Y), u ≫ f = v ≫ f → u = v) : + Mono f := by + refine ⟨fun {T} u v huv => ?_⟩ + refine (cancel_epi (Ind.colimitPresentationCompYoneda T).hom).mp ?_ + refine colimit.hom_ext (fun a => ?_) + refine h (T.presentation.F.obj a) _ _ ?_ + calc (colimit.ι (T.presentation.F ⋙ indOf) a ≫ + (Ind.colimitPresentationCompYoneda T).hom ≫ u) ≫ f + = colimit.ι (T.presentation.F ⋙ indOf) a ≫ + (Ind.colimitPresentationCompYoneda T).hom ≫ u ≫ f := by + simp only [Category.assoc] + _ = colimit.ι (T.presentation.F ⋙ indOf) a ≫ + (Ind.colimitPresentationCompYoneda T).hom ≫ v ≫ f := by + rw [huv] + _ = (colimit.ι (T.presentation.F ⋙ indOf) a ≫ + (Ind.colimitPresentationCompYoneda T).hom ≫ v) ≫ f := by + simp only [Category.assoc] + +end Detect + +section StageImage + +variable {C : Type v} + +/-- The image in the ind-object of a stage of its presentation. -/ +noncomputable def stageImage [SmallCategory C] [Abelian C] (A : Ind C) + (i : A.presentation.I) : Ind C := + Limits.image (presStage A i) + +/-- The image of a stage, as a subobject of the ind-object. -/ +noncomputable def stageImageι [SmallCategory C] [Abelian C] (A : Ind C) + (i : A.presentation.I) : + stageImage A i ⟶ A := + Limits.image.ι (presStage A i) + +instance mono_stageImageι [SmallCategory C] [Abelian C] (A : Ind C) + (i : A.presentation.I) : + Mono (stageImageι A i) := + inferInstanceAs (Mono (Limits.image.ι (presStage A i))) + +/-- The stage maps through its image. -/ +noncomputable def stageToImage [SmallCategory C] [Abelian C] (A : Ind C) + (i : A.presentation.I) : + indOf.obj (A.presentation.F.obj i) ⟶ stageImage A i := + Limits.factorThruImage (presStage A i) + +instance epi_stageToImage [SmallCategory C] [Abelian C] (A : Ind C) + (i : A.presentation.I) : + Epi (stageToImage A i) := + inferInstanceAs (Epi (Limits.factorThruImage (presStage A i))) + +@[simp] theorem stageToImage_comp_ι [SmallCategory C] [Abelian C] (A : Ind C) + (i : A.presentation.I) : + stageToImage A i ≫ stageImageι A i = presStage A i := + Limits.image.fac (presStage A i) + +/-- A transition map of the presentation includes one image into the +next. -/ +noncomputable def stageImageMap [SmallCategory C] [Abelian C] (A : Ind C) + {i j : A.presentation.I} (α : i ⟶ j) : + stageImage A i ⟶ stageImage A j := + Limits.image.lift + { I := stageImage A j + m := stageImageι A j + e := indOf.map (A.presentation.F.map α) ≫ stageToImage A j + fac := by + rw [Category.assoc, stageToImage_comp_ι] + exact presStage_naturality A α } + +@[simp] theorem stageImageMap_comp_ι [SmallCategory C] [Abelian C] (A : Ind C) + {i j : A.presentation.I} + (α : i ⟶ j) : + stageImageMap A α ≫ stageImageι A j = stageImageι A i := + Limits.image.lift_fac _ + +end StageImage + +section ImageTower + +variable {C : Type v} + +/-- The rungs of the image tower. -/ +noncomputable def imageRung + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) + (n : ℕ) : Ind C := + stageImage A (towerIdx A i₀ n) + +/-- The transition maps of the image tower. -/ +noncomputable def imageRungStep + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) + (n : ℕ) : + imageRung A i₀ n ⟶ imageRung A i₀ (n + 1) := + stageImageMap A (stageStep A (towerIdx A i₀ n)) + +/-- The image tower as a diagram of ind-objects. -/ +noncomputable def imageSeq + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) : ℕ ⥤ Ind C := + Functor.ofSequence (imageRungStep A i₀) + +/-- **The subalgebra generated by a stage, realised inside the +algebra**: the colimit of the tower of images. -/ +noncomputable def imageSubalgebra + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) : Ind C := + colimit (AsSmall.down ⋙ imageSeq A i₀) + +/-- The cocone of the image tower under the algebra. -/ +noncomputable def imageNatTrans + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) : + imageSeq A i₀ ⟶ (Functor.const ℕ).obj A := + NatTrans.ofSequence (fun n => stageImageι A (towerIdx A i₀ n)) (by + intro n + have h1 : (imageSeq A i₀).map (homOfLE (n.le_add_right 1)) = + imageRungStep A i₀ n := + Functor.ofSequence_map_homOfLE_succ (imageRungStep A i₀) n + have h2 : imageRungStep A i₀ n ≫ + stageImageι A (towerIdx A i₀ (n + 1)) = + stageImageι A (towerIdx A i₀ n) := + stageImageMap_comp_ι A (stageStep A (towerIdx A i₀ n)) + exact (eq_whisker h1 _).trans (h2.trans (Category.comp_id _).symm)) + +/-- The map of the image tower into the algebra. -/ +noncomputable def imageSubalgebraHom + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) : imageSubalgebra A i₀ ⟶ A := + colimit.desc _ (Cocone.whisker AsSmall.down + (Cocone.mk A (imageNatTrans A i₀))) + +/-- The rungs of the image tower map into it. -/ +noncomputable def imageRungι + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) + (n : ℕ) : + imageRung A i₀ n ⟶ imageSubalgebra A i₀ := + colimit.ι (AsSmall.down ⋙ imageSeq A i₀) ⟨n⟩ + +@[simp] theorem imageRungι_comp_hom + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) + (n : ℕ) : + imageRungι A i₀ n ≫ imageSubalgebraHom A i₀ = + stageImageι A (towerIdx A i₀ n) := + colimit.ι_desc _ _ + +/-- **The image tower is a subobject of the algebra.** A map out of +an embedded object into the colimit factors through a rung, two such +factorisations are merged at a later rung, and the rung maps into the +algebra are monomorphisms. -/ +theorem mono_imageSubalgebraHom + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) : Mono (imageSubalgebraHom A i₀) := by + refine mono_of_hom_indOf_injective _ (fun W u v huv => ?_) + obtain ⟨s, u', hu'⟩ := exists_factor_of_hom_colimit + (AsSmall.down ⋙ imageSeq A i₀) W u + obtain ⟨t, v', hv'⟩ := exists_factor_of_hom_colimit + (AsSmall.down ⋙ imageSeq A i₀) W v + obtain ⟨k, ⟨hsk⟩, ⟨htk⟩⟩ : ∃ k : ℕ, + Nonempty (s ⟶ (⟨k⟩ : Tower.{v})) ∧ + Nonempty (t ⟶ (⟨k⟩ : Tower.{v})) := + ⟨max (ULift.down s) (ULift.down t), + ⟨⟨homOfLE (le_max_left _ _)⟩⟩, ⟨⟨homOfLE (le_max_right _ _)⟩⟩⟩ + have hu2 : (u' ≫ (AsSmall.down ⋙ imageSeq A i₀).map hsk) ≫ + colimit.ι (AsSmall.down ⋙ imageSeq A i₀) ⟨k⟩ = u := by + erw [Category.assoc, colimit.w, hu'] + have hv2 : (v' ≫ (AsSmall.down ⋙ imageSeq A i₀).map htk) ≫ + colimit.ι (AsSmall.down ⋙ imageSeq A i₀) ⟨k⟩ = v := by + erw [Category.assoc, colimit.w, hv'] + have hrung : colimit.ι (AsSmall.down ⋙ imageSeq A i₀) ⟨k⟩ ≫ + imageSubalgebraHom A i₀ = stageImageι A (towerIdx A i₀ k) := + imageRungι_comp_hom A i₀ k + have hcancel : (u' ≫ (AsSmall.down ⋙ imageSeq A i₀).map hsk) ≫ + stageImageι A (towerIdx A i₀ k) = + (v' ≫ (AsSmall.down ⋙ imageSeq A i₀).map htk) ≫ + stageImageι A (towerIdx A i₀ k) := + calc (u' ≫ (AsSmall.down ⋙ imageSeq A i₀).map hsk) ≫ + stageImageι A (towerIdx A i₀ k) + = ((u' ≫ (AsSmall.down ⋙ imageSeq A i₀).map hsk) ≫ + colimit.ι (AsSmall.down ⋙ imageSeq A i₀) ⟨k⟩) ≫ + imageSubalgebraHom A i₀ := + ((Category.assoc _ _ _).trans (whisker_eq _ hrung)).symm + _ = u ≫ imageSubalgebraHom A i₀ := eq_whisker hu2 _ + _ = v ≫ imageSubalgebraHom A i₀ := huv + _ = ((v' ≫ (AsSmall.down ⋙ imageSeq A i₀).map htk) ≫ + colimit.ι (AsSmall.down ⋙ imageSeq A i₀) ⟨k⟩) ≫ + imageSubalgebraHom A i₀ := eq_whisker hv2.symm _ + _ = (v' ≫ (AsSmall.down ⋙ imageSeq A i₀).map htk) ≫ + stageImageι A (towerIdx A i₀ k) := + (Category.assoc _ _ _).trans (whisker_eq _ hrung) + exact hu2.symm.trans ((eq_whisker + ((cancel_mono (stageImageι A (towerIdx A i₀ k))).mp hcancel) _).trans + hv2) + +end ImageTower + +/-! ## Countable presentation of the image tower + +The rungs of the image tower are images of embedded objects, and the +tower is countable, so the tower is countably presented as soon as +those images are again embedded. That is a condition on `C` alone — +`RS.IndImageEmbedded` — and it is not a consequence of abelianness: +for `C` the finitely presented modules over a coherent ring, the +image of `R ⟶ R ⧸ I` is `R ⧸ I`, which is embedded only when `I` is +finitely generated. It does hold as soon as the subobject orders of +`C` satisfy the ascending chain condition, which the finite length +hypothesis of `RS.Classical.Deligne.GammaCountable` supplies. -/ + +section PresentedTower + +variable {C : Type v} + +variable (C) in +/-- **Embedded images**: the image in the ind-completion of a map out +of an embedded object is again embedded. -/ +def IndImageEmbedded [SmallCategory C] [Abelian C] : Prop := + ∀ (Y : C) (Z : Ind C) (f : indOf.obj Y ⟶ Z), + ∃ W : C, Nonempty (Limits.image f ≅ indOf.obj W) + +/-- **The image tower is countably presented** when the images of +embedded objects are embedded: the tower is an ℕ-tower, and each rung +is by hypothesis an embedded object. -/ +theorem countablyPresented_imageSubalgebra + [SmallCategory C] [Abelian C] [MonoidalCategory C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) + (h : IndImageEmbedded C) : + CountablyPresented (imageSubalgebra A i₀) := by + classical + choose Z hZ using fun n : ℕ => + h (A.presentation.F.obj (towerIdx A i₀ n)) A + (presStage A (towerIdx A i₀ n)) + set e : ∀ n : ℕ, imageRung A i₀ n ≅ indOf.obj (Z n) := + fun n => (hZ n).some with he + set w : ∀ n : ℕ, Z n ⟶ Z (n + 1) := fun n => + Ind.yoneda.fullyFaithful.preimage + ((e n).inv ≫ imageRungStep A i₀ n ≫ (e (n + 1)).hom) with hw + have hwmap : ∀ n : ℕ, indOf.map (w n) = + (e n).inv ≫ imageRungStep A i₀ n ≫ (e (n + 1)).hom := fun n => + Ind.yoneda.fullyFaithful.map_preimage _ + set τ : Functor.ofSequence w ⋙ indOf ⟶ imageSeq A i₀ := + NatTrans.ofSequence (fun n => (e n).inv) (by + intro n + have h1 : (Functor.ofSequence w ⋙ indOf).map + (homOfLE (n.le_add_right 1)) = indOf.map (w n) := + congrArg (fun m => indOf.map m) + (Functor.ofSequence_map_homOfLE_succ w n) + have h2 : (imageSeq A i₀).map (homOfLE (n.le_add_right 1)) = + imageRungStep A i₀ n := + Functor.ofSequence_map_homOfLE_succ (imageRungStep A i₀) n + rw [h1, h2, hwmap n] + exact (Category.assoc _ _ _).trans (whisker_eq _ + (((Category.assoc _ _ _).trans + (whisker_eq _ (Iso.hom_inv_id _))).trans + (Category.comp_id _)))) with hτ + have hiso : ∀ n : ℕ, IsIso (τ.app n) := by + intro n + rw [hτ] + exact inferInstanceAs (IsIso (e n).inv) + have : IsIso τ := NatIso.isIso_of_isIso_app τ + refine CountablyPresented.of_iso + (HasColimit.isoOfNatIso + (CategoryTheory.Functor.isoWhiskerLeft (AsSmall.down (C := ℕ)) + (asIso τ))) (countablyPresented_colimit_tower w) + +end PresentedTower + +/-! ## Compactness of the odd line and of the mixed sums + +The isomorphism witnessing local mixedness is a map out of a mixed +sum of the unit and the odd line, so pushing it down to a stage needs +those objects to be compact. The unit is compact because it is +embedded (`RS.exists_factor_of_unit_hom_colimit`); the odd line is +compact because its square is the unit, which makes tensoring with it +an equivalence and so turns a map out of it into a point of a +translate. The mixed sums are finite biproducts of the two, and a +finite family of stages of a filtered diagram is dominated by a +single stage. -/ + +section Untwist + +variable {D : Type u} + +/-- **Untwisting**: along a trivialisation of the square of `L`, a +point of `L ⊗ W` becomes a map `L ⟶ W`. -/ +def oddUntwist [Category.{v} D] [MonoidalCategory D] {L : D} (e : L ⊗ L ≅ 𝟙_ D) + {W : D} (h : 𝟙_ D ⟶ L ⊗ W) : L ⟶ W := + (ρ_ L).inv ≫ L ◁ h ≫ (α_ L L W).inv ≫ e.hom ▷ W ≫ (λ_ W).hom + +/-- Untwisting is natural in the target. -/ +theorem oddUntwist_comp + [Category.{v} D] [MonoidalCategory D] {L : D} (e : L ⊗ L ≅ 𝟙_ D) + {W W' : D} (h : 𝟙_ D ⟶ L ⊗ W) (k : W ⟶ W') : + oddUntwist e (h ≫ L ◁ k) = oddUntwist e h ≫ k := by + simp only [oddUntwist, MonoidalCategory.whiskerLeft_comp, + Category.assoc, associator_inv_naturality_right_assoc, + whisker_exchange_assoc, leftUnitor_naturality] + +/-- The zigzag automorphism of `L` attached to a trivialisation of +its square: untwisting the twist of the identity. -/ +def oddZigzag + [Category.{v} D] [MonoidalCategory D] {L : D} (e : L ⊗ L ≅ 𝟙_ D) : L ≅ L := + (ρ_ L).symm ≪≫ whiskerLeftIso L e.symm ≪≫ (α_ L L L).symm ≪≫ + whiskerRightIso e L ≪≫ λ_ L + +/-- Untwisting undoes twisting, up to the zigzag automorphism. -/ +theorem oddUntwist_twist + [Category.{v} D] [MonoidalCategory D] {L : D} (e : L ⊗ L ≅ 𝟙_ D) + {W : D} (g : L ⟶ W) : + oddUntwist e (e.inv ≫ L ◁ g) = (oddZigzag e).hom ≫ g := + oddUntwist_comp e e.inv g + +end Untwist + +section OddCompact + +variable {C : Type v} + +/-- **An object whose square is the unit is compact**: a map from it +into a filtered colimit factors through a stage. Tensoring with the +object preserves the colimit, and the unit is compact, so the +translated point factors; untwisting brings the factorisation +back. -/ +theorem exists_factor_of_sq_unit_hom_colimit + [SmallCategory C] [MonoidalCategory C] + {L : Ind C} + (e : L ⊗ L ≅ 𝟙_ (Ind C)) {I : Type v} [SmallCategory I] + [IsFiltered I] (D : I ⥤ Ind C) (f : L ⟶ colimit D) : + ∃ (i : I) (g : L ⟶ D.obj i), g ≫ colimit.ι D i = f := by + obtain ⟨i, h, hh⟩ := exists_factor_of_unit_hom_colimit + (D ⋙ tensorLeft L) + ((e.inv ≫ L ◁ f) ≫ (preservesColimitIso (tensorLeft L) D).hom) + have hι : (tensorLeft L).map (colimit.ι D i) ≫ + (preservesColimitIso (tensorLeft L) D).hom = + colimit.ι (D ⋙ tensorLeft L) i := + ι_preservesColimitIso_hom (tensorLeft L) D i + have key : h ≫ L ◁ colimit.ι D i = e.inv ≫ L ◁ f := by + refine (cancel_mono (preservesColimitIso (tensorLeft L) D).hom).mp ?_ + exact (Category.assoc _ _ _).trans + ((whisker_eq h hι).trans hh) + refine ⟨i, (oddZigzag e).inv ≫ oddUntwist e h, ?_⟩ + have h1 : oddUntwist e h ≫ colimit.ι D i = + (oddZigzag e).hom ≫ f := + calc oddUntwist e h ≫ colimit.ι D i + = oddUntwist e (h ≫ L ◁ colimit.ι D i) := + (oddUntwist_comp e h (colimit.ι D i)).symm + _ = oddUntwist e (e.inv ≫ L ◁ f) := + congrArg + (fun t : 𝟙_ (Ind C) ⟶ L ⊗ colimit D => oddUntwist e t) key + _ = (oddZigzag e).hom ≫ f := oddUntwist_twist e f + rw [Category.assoc, h1, ← Category.assoc, Iso.inv_hom_id, + Category.id_comp] + +/-- Twisting a map out of an object with unit square into a point of +a translate turns composition into whiskering. -/ +theorem oddTwist_comp [SmallCategory C] [MonoidalCategory C] + {L : Ind C} (e : L ⊗ L ≅ 𝟙_ (Ind C)) + {Z Z' : Ind C} (x : L ⟶ Z) (y : Z ⟶ Z') : + e.inv ≫ L ◁ (x ≫ y) = (e.inv ≫ L ◁ x) ≫ L ◁ y := by + rw [MonoidalCategory.whiskerLeft_comp, Category.assoc] + +/-- **Merging of stage factorisations out of an object with unit +square**: two factorisations that agree after passing to a filtered +colimit are merged by transition maps of the diagram. With the +previous theorem this is the whole compactness formula for the odd +line. -/ +theorem factor_eq_of_sq_unit_hom_colimit [SmallCategory C] [MonoidalCategory C] + {L : Ind C} + (e : L ⊗ L ≅ 𝟙_ (Ind C)) {I : Type v} [SmallCategory I] + [IsFiltered I] (D : I ⥤ Ind C) {i j : I} (g₁ : L ⟶ D.obj i) + (g₂ : L ⟶ D.obj j) + (h : g₁ ≫ colimit.ι D i = g₂ ≫ colimit.ι D j) : + ∃ (k : I) (α : i ⟶ k) (β : j ⟶ k), + g₁ ≫ D.map α = g₂ ≫ D.map β := by + have hι : ∀ m : I, (L ◁ colimit.ι D m) ≫ + (preservesColimitIso (tensorLeft L) D).hom = + colimit.ι (D ⋙ tensorLeft L) m := fun m => + ι_preservesColimitIso_hom (tensorLeft L) D m + have key : (e.inv ≫ L ◁ g₁) ≫ colimit.ι (D ⋙ tensorLeft L) i = + (e.inv ≫ L ◁ g₂) ≫ colimit.ι (D ⋙ tensorLeft L) j := + calc (e.inv ≫ L ◁ g₁) ≫ colimit.ι (D ⋙ tensorLeft L) i + = (e.inv ≫ L ◁ g₁) ≫ (L ◁ colimit.ι D i) ≫ + (preservesColimitIso (tensorLeft L) D).hom := + whisker_eq _ (hι i).symm + _ = (e.inv ≫ L ◁ (g₁ ≫ colimit.ι D i)) ≫ + (preservesColimitIso (tensorLeft L) D).hom := + ((Category.assoc _ _ _).symm.trans + (eq_whisker (oddTwist_comp e g₁ (colimit.ι D i)).symm _)) + _ = (e.inv ≫ L ◁ (g₂ ≫ colimit.ι D j)) ≫ + (preservesColimitIso (tensorLeft L) D).hom := by rw [h] + _ = (e.inv ≫ L ◁ g₂) ≫ (L ◁ colimit.ι D j) ≫ + (preservesColimitIso (tensorLeft L) D).hom := + (eq_whisker (oddTwist_comp e g₂ (colimit.ι D j)) _).trans + (Category.assoc _ _ _) + _ = (e.inv ≫ L ◁ g₂) ≫ colimit.ι (D ⋙ tensorLeft L) j := + whisker_eq _ (hι j) + obtain ⟨k, α, β, hk⟩ := unit_factor_eq_of_hom_colimit + (D ⋙ tensorLeft L) (e.inv ≫ L ◁ g₁) (e.inv ≫ L ◁ g₂) key + refine ⟨k, α, β, ?_⟩ + have hk' : e.inv ≫ L ◁ (g₁ ≫ D.map α) = e.inv ≫ L ◁ (g₂ ≫ D.map β) := + (oddTwist_comp e g₁ (D.map α)).trans + (hk.trans (oddTwist_comp e g₂ (D.map β)).symm) + refine (cancel_epi (oddZigzag e).hom).mp ?_ + exact ((oddUntwist_twist e (g₁ ≫ D.map α)).symm.trans + (congrArg (fun t : 𝟙_ (Ind C) ⟶ L ⊗ D.obj k => oddUntwist e t) + hk')).trans (oddUntwist_twist e (g₂ ≫ D.map β)) + +/-- The summands of a mixed sum. -/ +noncomputable def mixFamily [SmallCategory C] [MonoidalCategory C] [Abelian C] + [SymmetricCategory (Ind C)] + (L : OddLine (Ind C)) (p q : ℕ) : + Fin p ⊕ Fin q → Ind C := + fun i => Sum.elim (fun _ => 𝟙_ (Ind C)) (fun _ => L.obj) i + +/-- **The mixed sums are compact**: a map from a mixed sum of the +unit and the odd line into a filtered colimit factors through a +stage. Each summand factors, and a finite family of stages of a +filtered diagram is dominated by a single one. -/ +theorem exists_factor_of_mix_hom_colimit + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [SymmetricCategory (Ind C)] [HasFiniteBiproducts (Ind C)] + (L : OddLine (Ind C)) + (p q : ℕ) {I : Type v} [SmallCategory I] [IsFiltered I] + (D : I ⥤ Ind C) (f : L.mix p q ⟶ colimit D) : + ∃ (i : I) (g : L.mix p q ⟶ D.obj i), g ≫ colimit.ι D i = f := by + classical + have hcomp : ∀ k : Fin p ⊕ Fin q, ∃ (i : I) + (g : mixFamily L p q k ⟶ D.obj i), + g ≫ colimit.ι D i = biproduct.ι (mixFamily L p q) k ≫ f := by + rintro (a | b) + · exact exists_factor_of_unit_hom_colimit D _ + · exact exists_factor_of_sq_unit_hom_colimit L.sq D _ + choose idx gg hgg using hcomp + obtain ⟨S, hS⟩ := IsFiltered.sup_objs_exists + (Finset.image idx Finset.univ) + have hmap : ∀ k, Nonempty (idx k ⟶ S) := fun k => + hS (Finset.mem_image_of_mem idx (Finset.mem_univ k)) + refine ⟨S, biproduct.desc (fun k => gg k ≫ D.map (hmap k).some), ?_⟩ + refine biproduct.hom_ext' _ _ (fun k => ?_) + have e1 : biproduct.ι (mixFamily L p q) k ≫ + biproduct.desc (fun k => gg k ≫ D.map (hmap k).some) = + gg k ≫ D.map (hmap k).some := biproduct.ι_desc _ _ + calc biproduct.ι (mixFamily L p q) k ≫ + (biproduct.desc (fun k => gg k ≫ D.map (hmap k).some) ≫ + colimit.ι D S) + = (biproduct.ι (mixFamily L p q) k ≫ + biproduct.desc (fun k => gg k ≫ D.map (hmap k).some)) ≫ + colimit.ι D S := (Category.assoc _ _ _).symm + _ = (gg k ≫ D.map (hmap k).some) ≫ colimit.ι D S := + eq_whisker e1 _ + _ = gg k ≫ D.map (hmap k).some ≫ colimit.ι D S := + Category.assoc _ _ _ + _ = gg k ≫ colimit.ι D (idx k) := whisker_eq _ (colimit.w D _) + _ = biproduct.ι (mixFamily L p q) k ≫ f := hgg k + +end OddCompact + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescentClose.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescentClose.lean new file mode 100644 index 0000000000..2db6d4e8e8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescentClose.lean @@ -0,0 +1,588 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ImageSubalgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndImage +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModAdjoint + +/-! +# Closing the countable descent + +`RS.Classical.Deligne.CountableDescent` builds, inside a commutative +algebra `A` of `Ind C` and above a stage of its presentation, the +countable tower `RS.imageSubalgebra` and the monomorphism +`RS.imageSubalgebraHom` of that tower into the algebra; +`RS.Classical.Deligne.ImageSubalgebra` makes the tower an algebra in +its own right. This file uses that replacement to push the two +witnessing statements of Deligne 2.9 and 2.10 down to countably +presented algebras: `RS.locallyMixed_countablyPresented` and +`RS.section_countablyPresented`. + +The data. An algebra witnessing local mixedness carries an +isomorphism of free modules, and one witnessing a splitting carries a +section. Neither is a datum of the ambient category, so the +free--forgetful adjunction (`RS.freeModHomEquiv`) is used first to +transpose them: an isomorphism `freeMod A X ≅ freeMod A (L.mix p q)` +becomes a pair of morphisms `X ⟶ A ⊗ L.mix p q` and +`L.mix p q ⟶ A ⊗ X` subject to two unit identities +(`RS.roundTrip_of_freeModIso`), and a section becomes a single +morphism `W ⟶ A ⊗ V` subject to one +(`RS.sectionDatum_of_section`). Both transpositions are reversible +(`RS.freeModIsoOfRoundTrip`, `RS.exists_section_of_datum`), so the +whole descent takes place in the ambient category. + +The descent. The algebra is the filtered colimit of the stages of +its presentation (`RS.presIsColimit`), tensoring preserves filtered +colimits, and the objects carrying the data are compact +(`RS.IndCompactObj`, satisfied by the embedded objects and by the +mixed sums). So each datum factors through a stage +(`RS.exists_presStage_whiskerRight_factor`), finitely many data are +brought to a common stage above the one carrying the unit, and there +they enter the tower generated at that stage +(`RS.exists_imageSubalgebra_pair`, `RS.exists_imageSubalgebra_single`). + +The identities. What is left is to know that the identities descend +with the data. The inclusion of the tower into the algebra is a +monomorphism and stays one after tensoring, the tensor product of +`Ind C` being exact in each variable +(`RS.mono_imageSubalgebraHom_whiskerRight`); the inclusion carries the +unit and the multiplication of the tower to those of the algebra; so +each identity may be verified after composing with the inclusion, +where it is the identity already known +(`RS.roundTrip_descend`, `RS.sectionDatum_descend`). Countable +presentation of the tower is +`RS.countablyPresented_imageSubalgebra`, over the embedded-image +hypothesis discharged from finite length by +`RS.indImageEmbedded_of_lengthLE`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe w v u + +/-! ## Compact objects of the ind-completion -/ + +section Compact + +variable {C : Type v} + +/-- **Compactness of an ind-object**, phrased as in +`RS.Classical.Deligne.IndCompact`: a morphism from the object into a +filtered colimit factors through a stage of the diagram. -/ +def IndCompactObj [SmallCategory C] + (Y : Ind C) : Prop := + ∀ {I : Type v} [SmallCategory I] [IsFiltered I] (D : I ⥤ Ind C) + (f : Y ⟶ colimit D), + ∃ (i : I) (g : Y ⟶ D.obj i), g ≫ colimit.ι D i = f + +/-- **The embedded objects are compact.** -/ +theorem indCompactObj_indOf [SmallCategory C] + (Z : C) : + IndCompactObj ((indOf : C ⥤ Ind C).obj Z) := + fun D f => exists_factor_of_hom_colimit D Z f + +/-- **Compactness against an arbitrary colimit cocone**: the +factorisation of the definition does not depend on the chosen +colimit. -/ +theorem IndCompactObj.factor_of_isColimit [SmallCategory C] + {Y : Ind C} + (hY : IndCompactObj Y) {I : Type v} [SmallCategory I] + [IsFiltered I] {K : I ⥤ Ind C} (c : Cocone K) (hc : IsColimit c) + (f : Y ⟶ c.pt) : + ∃ (i : I) (g : Y ⟶ K.obj i), g ≫ c.ι.app i = f := by + obtain ⟨i, g, hg⟩ := hY K (f ≫ (hc.coconePointUniqueUpToIso + (colimit.isColimit K)).hom) + refine ⟨i, g, ?_⟩ + refine (cancel_mono (hc.coconePointUniqueUpToIso + (colimit.isColimit K)).hom).mp ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact (whisker_eq _ (hc.comp_coconePointUniqueUpToIso_hom + (colimit.isColimit K) i)).trans hg + +end Compact + +/-! ## The presentation as a colimit cocone -/ + +section PresCocone + +variable {C : Type v} + +/-- The cocone of the chosen presentation of an ind-object, with the +ind-object itself as its point. -/ +@[simps! pt] +noncomputable def presCocone [SmallCategory C] + (A : Ind C) : Cocone (presDiagram A) := + Cocone.mk A + { app := fun i => presStage A i + naturality := fun _ _ α => + (presStage_naturality A α).trans (Category.comp_id _).symm } + +@[simp] theorem presCocone_ι_app [SmallCategory C] + (A : Ind C) (i : A.presentation.I) : + (presCocone A).ι.app i = presStage A i := rfl + +/-- **The presentation cocone is a colimit cocone.** -/ +noncomputable def presIsColimit [SmallCategory C] + (A : Ind C) : + IsColimit (presCocone A) := + IsColimit.ofIsoColimit (colimit.isColimit (presDiagram A)) + (Cocone.ext (Ind.colimitPresentationCompYoneda A) (fun _ => rfl)) + +end PresCocone + +/-! ## Descending the finite data to a stage -/ + +section TensorFactor + +variable {C : Type v} + +/-- **A map from a compact object into a base change factors through +a stage of the presentation**: tensoring preserves filtered colimits, +so the base change of the presentation cocone is again a colimit +cocone. -/ +theorem exists_presStage_whiskerRight_factor + [SmallCategory C] [MonoidalCategory C] + (A : Ind C) {Y M : Ind C} + (hY : IndCompactObj Y) (f : Y ⟶ A ⊗ M) : + ∃ (i : A.presentation.I) + (g : Y ⟶ indOf.obj (A.presentation.F.obj i) ⊗ M), + g ≫ presStage A i ▷ M = f := + hY.factor_of_isColimit ((tensorRight M).mapCocone (presCocone A)) + (isColimitOfPreserves (tensorRight M) (presIsColimit A)) f + +end TensorFactor + +/-! ## Descending the round-trip identities along a subalgebra -/ + +section MonoDescend + +variable {D : Type u} + +/-- **The product of the subalgebra, read in the algebra**: the +left-hand free action of the subalgebra, followed by the inclusion, +is the left-hand free action of the algebra applied to the +transported datum. -/ +theorem whiskerLeft_freeAct_comp_whiskerRight + [Category.{w} D] [MonoidalCategory D] {A : D} {B : D} [MonObj A] + [MonObj B] + (φ : B ⟶ A) + (hmul : μ[B] ≫ φ = (φ ⊗ₘ φ) ≫ μ[A]) {X M : D} (v : M ⟶ B ⊗ X) : + ((B ◁ v) ≫ (α_ B B X).inv ≫ μ[B] ▷ X) ≫ φ ▷ X = + (φ ▷ M) ≫ (A ◁ (v ≫ φ ▷ X)) ≫ (α_ A A X).inv ≫ μ[A] ▷ X := by + have hnat : (α_ B B X).inv ≫ (φ ⊗ₘ φ) ▷ X = + (φ ⊗ₘ φ ▷ X) ≫ (α_ A A X).inv := by + have h := associator_inv_naturality φ φ (𝟙 X) + simp only [tensorHom_id] at h + exact h.symm + calc ((B ◁ v) ≫ (α_ B B X).inv ≫ μ[B] ▷ X) ≫ φ ▷ X + = (B ◁ v) ≫ (α_ B B X).inv ≫ (μ[B] ≫ φ) ▷ X := by + simp only [Category.assoc, comp_whiskerRight] + _ = (B ◁ v) ≫ ((α_ B B X).inv ≫ (φ ⊗ₘ φ) ▷ X) ≫ μ[A] ▷ X := by + rw [hmul] + simp only [Category.assoc, comp_whiskerRight] + _ = ((B ◁ v) ≫ (φ ⊗ₘ φ ▷ X)) ≫ (α_ A A X).inv ≫ μ[A] ▷ X := by + rw [hnat] + simp only [Category.assoc] + _ = (φ ⊗ₘ (v ≫ φ ▷ X)) ≫ (α_ A A X).inv ≫ μ[A] ▷ X := by + rw [whiskerLeft_comp_tensorHom] + _ = (φ ▷ M) ≫ (A ◁ (v ≫ φ ▷ X)) ≫ + (α_ A A X).inv ≫ μ[A] ▷ X := by + rw [tensorHom_def, Category.assoc] + +/-- **Descent of a round trip to a subalgebra**: the identity that +holds in the algebra for the transported data already holds in the +subalgebra, because the inclusion is a monomorphism and stays one +after tensoring. -/ +theorem roundTrip_descend + [Category.{w} D] [MonoidalCategory D] {A : D} {B : D} [MonObj A] + [MonObj B] + (φ : B ⟶ A) (hone : η[B] ≫ φ = η[A]) + (hmul : μ[B] ≫ φ = (φ ⊗ₘ φ) ≫ μ[A]) {X M : D} + (u : X ⟶ B ⊗ M) (v : M ⟶ B ⊗ X) [Mono (φ ▷ X)] + (h : (u ≫ φ ▷ M) ≫ (A ◁ (v ≫ φ ▷ X)) ≫ + (α_ A A X).inv ≫ μ[A] ▷ X = (λ_ X).inv ≫ η[A] ▷ X) : + u ≫ (B ◁ v) ≫ (α_ B B X).inv ≫ μ[B] ▷ X = + (λ_ X).inv ≫ η[B] ▷ X := by + refine (cancel_mono (φ ▷ X)).mp ?_ + calc (u ≫ (B ◁ v) ≫ (α_ B B X).inv ≫ μ[B] ▷ X) ≫ φ ▷ X + = u ≫ ((B ◁ v) ≫ (α_ B B X).inv ≫ μ[B] ▷ X) ≫ φ ▷ X := by + simp only [Category.assoc] + _ = u ≫ (φ ▷ M) ≫ (A ◁ (v ≫ φ ▷ X)) ≫ + (α_ A A X).inv ≫ μ[A] ▷ X := by + rw [whiskerLeft_freeAct_comp_whiskerRight φ hmul] + _ = (λ_ X).inv ≫ η[A] ▷ X := by + rw [← h] + simp only [Category.assoc] + _ = ((λ_ X).inv ≫ η[B] ▷ X) ≫ φ ▷ X := by + rw [Category.assoc, ← comp_whiskerRight, hone] + +/-- **Descent of a splitting datum to a subalgebra.** Only the unit +is involved: the datum is a single map, not a round trip. -/ +theorem sectionDatum_descend + [Category.{w} D] [MonoidalCategory D] {A : D} {B : D} [MonObj A] + [MonObj B] + (φ : B ⟶ A) (hone : η[B] ≫ φ = η[A]) + {V W : D} (g : V ⟶ W) (t : W ⟶ B ⊗ V) [Mono (φ ▷ W)] + (h : (t ≫ φ ▷ V) ≫ (A ◁ g) = (λ_ W).inv ≫ η[A] ▷ W) : + t ≫ (B ◁ g) = (λ_ W).inv ≫ η[B] ▷ W := by + refine (cancel_mono (φ ▷ W)).mp ?_ + calc (t ≫ (B ◁ g)) ≫ φ ▷ W = t ≫ (B ◁ g) ≫ φ ▷ W := + Category.assoc _ _ _ + _ = t ≫ (φ ▷ V) ≫ (A ◁ g) := by rw [whisker_exchange] + _ = (λ_ W).inv ≫ η[A] ▷ W := by + rw [← h] + simp only [Category.assoc] + _ = ((λ_ W).inv ≫ η[B] ▷ W) ≫ φ ▷ W := by + rw [Category.assoc, ← comp_whiskerRight, hone] + +end MonoDescend + +/-! ## Rebuilding the module data from the descended maps -/ + +section FreeRebuild + +variable {D : Type u} + +/-- Restricting a composite out of a free module along the unit is +postcomposition of the restriction of the first factor. -/ +theorem freeModHomEquiv_symm_comp + [Category.{w} D] [MonoidalCategory D] (R : D) [MonObj R] + {X M : D} (N : Mod D R) + (u : X ⟶ (freeMod R M).X) (k : freeMod R M ⟶ N) : + freeModHomEquiv R X N + ((freeModHomEquiv R X (freeMod R M)).symm u ≫ k) = + u ≫ k.hom := + (unit_comp_assoc R X _ _ _ k.hom).trans + (congrArg (fun z => z ≫ k.hom) + ((freeModHomEquiv R X (freeMod R M)).apply_symm_apply u)) + +/-- Restricting the identity of a free module along the unit is the +unit itself. -/ +theorem freeModHomEquiv_id + [Category.{w} D] [MonoidalCategory D] (R : D) [MonObj R] + (X : D) : + freeModHomEquiv R X (freeMod R X) (𝟙 (freeMod R X)) = + (λ_ X).inv ≫ η[R] ▷ X := by + change (λ_ X).inv ≫ (η[R] ▷ X) ≫ 𝟙 _ = _ + rw [Category.comp_id] + +/-- **An isomorphism of free modules from a round trip**: a pair of +maps in the ambient category satisfying the two unit identities +extends to an isomorphism of free modules, by the free--forgetful +adjunction. -/ +noncomputable def freeModIsoOfRoundTrip + [Category.{w} D] [MonoidalCategory D] (R : D) [MonObj R] + {X M : D} (u : X ⟶ R ⊗ M) + (v : M ⟶ R ⊗ X) + (h₁ : u ≫ (R ◁ v) ≫ (α_ R R X).inv ≫ μ[R] ▷ X = + (λ_ X).inv ≫ η[R] ▷ X) + (h₂ : v ≫ (R ◁ u) ≫ (α_ R R M).inv ≫ μ[R] ▷ M = + (λ_ M).inv ≫ η[R] ▷ M) : + freeMod R X ≅ freeMod R M where + hom := (freeModHomEquiv R X (freeMod R M)).symm u + inv := (freeModHomEquiv R M (freeMod R X)).symm v + hom_inv_id := by + refine (freeModHomEquiv R X (freeMod R X)).injective ?_ + refine Eq.trans (freeModHomEquiv_symm_comp R _ u _) ?_ + exact h₁.trans (freeModHomEquiv_id R X).symm + inv_hom_id := by + refine (freeModHomEquiv R M (freeMod R M)).injective ?_ + refine Eq.trans (freeModHomEquiv_symm_comp R _ v _) ?_ + exact h₂.trans (freeModHomEquiv_id R M).symm + +/-- Restriction along the unit turns composition in the category of +modules into composition in the ambient category. -/ +theorem freeModHomEquiv_comp + [Category.{w} D] [MonoidalCategory D] (R : D) [MonObj R] + {X : D} {N P : Mod D R} + (f : freeMod R X ⟶ N) (k : N ⟶ P) : + freeModHomEquiv R X P (f ≫ k) = + freeModHomEquiv R X N f ≫ k.hom := + unit_comp_assoc R X _ _ f.hom k.hom + +/-- A module map out of a free module is the extension of its +restriction along the unit. -/ +theorem freeModHom_eq_whiskerLeft + [Category.{w} D] [MonoidalCategory D] (R : D) [MonObj R] + {M : D} (N : Mod D R) + (f : freeMod R M ⟶ N) : + f.hom = R ◁ (freeModHomEquiv R M N f) ≫ actLeft R N.X := + congrArg (fun z : freeMod R M ⟶ N => z.hom) + ((freeModHomEquiv R M N).symm_apply_apply f).symm + +/-- **The round trip attached to an isomorphism of free modules**: +the transposes of the two directions satisfy the unit identity. -/ +theorem roundTrip_of_freeModIso + [Category.{w} D] [MonoidalCategory D] (R : D) [MonObj R] + {X M : D} + (Φ : freeMod R X ≅ freeMod R M) : + freeModHomEquiv R X (freeMod R M) Φ.hom ≫ + (R ◁ freeModHomEquiv R M (freeMod R X) Φ.inv) ≫ + (α_ R R X).inv ≫ μ[R] ▷ X = + (λ_ X).inv ≫ η[R] ▷ X := by + have h := freeModHomEquiv_comp R Φ.hom Φ.inv + rw [Φ.hom_inv_id, freeModHomEquiv_id, + freeModHom_eq_whiskerLeft R (freeMod R X) Φ.inv] at h + exact h.symm + +/-- **The datum attached to a splitting**: the transpose of a section +of the free module on a morphism satisfies the unit identity. -/ +theorem sectionDatum_of_section + [Category.{w} D] [MonoidalCategory D] (R : D) [MonObj R] + {V W : D} (g : V ⟶ W) + (s : freeMod R W ⟶ freeMod R V) + (hs : s ≫ freeModMap R g = 𝟙 (freeMod R W)) : + freeModHomEquiv R W (freeMod R V) s ≫ (R ◁ g) = + (λ_ W).inv ≫ η[R] ▷ W := by + have h := freeModHomEquiv_comp R s (freeModMap R g) + rw [hs, freeModHomEquiv_id] at h + exact h.symm + +/-- **A splitting from its datum**: a map satisfying the unit +identity extends to a section of the free module on a morphism. -/ +theorem exists_section_of_datum + [Category.{w} D] [MonoidalCategory D] (R : D) [MonObj R] + {V W : D} (g : V ⟶ W) + (t : W ⟶ R ⊗ V) (h : t ≫ (R ◁ g) = (λ_ W).inv ≫ η[R] ▷ W) : + ∃ s : freeMod R W ⟶ freeMod R V, + s ≫ freeModMap R g = 𝟙 (freeMod R W) := by + refine ⟨(freeModHomEquiv R W (freeMod R V)).symm t, ?_⟩ + refine (freeModHomEquiv R W (freeMod R W)).injective ?_ + refine Eq.trans (freeModHomEquiv_symm_comp R _ t _) ?_ + exact h.trans (freeModHomEquiv_id R W).symm + +end FreeRebuild + +/-! ## Entering the image subalgebra -/ + +section IntoImage + +variable {C : Type v} + +/-- The generating stage, mapped into rung zero of the image tower and +on into the subalgebra it generates. -/ +noncomputable def stageIntoImageSubalgebra + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) : + indOf.obj (A.presentation.F.obj i₀) ⟶ imageSubalgebra A i₀ := + stageToImage A i₀ ≫ imageRungι A i₀ 0 + +theorem stageIntoImageSubalgebra_comp_hom + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) : + stageIntoImageSubalgebra A i₀ ≫ imageSubalgebraHom A i₀ = + presStage A i₀ := + (Category.assoc _ _ _).trans + ((whisker_eq _ (imageRungι_comp_hom A i₀ 0)).trans + (stageToImage_comp_ι A i₀)) + +/-- **A stage factorisation enters the image subalgebra**: a datum +factoring through a stage below the generating one factors through the +subalgebra generated there. -/ +theorem exists_imageSubalgebra_factor + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) + {Y M : Ind C} + {i : A.presentation.I} (α : i ⟶ i₀) + (g : Y ⟶ indOf.obj (A.presentation.F.obj i) ⊗ M) (f : Y ⟶ A ⊗ M) + (hg : g ≫ presStage A i ▷ M = f) : + ∃ g' : Y ⟶ imageSubalgebra A i₀ ⊗ M, + g' ≫ imageSubalgebraHom A i₀ ▷ M = f := by + refine ⟨g ≫ (indOf.map (A.presentation.F.map α) ≫ + stageIntoImageSubalgebra A i₀) ▷ M, ?_⟩ + rw [Category.assoc, ← comp_whiskerRight, Category.assoc, + stageIntoImageSubalgebra_comp_hom, presStage_naturality, hg] + +/-- **Two data descend to a common image subalgebra**, generated at a +stage that also carries the unit of the algebra. -/ +theorem exists_imageSubalgebra_pair + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] + {Y Y' M M' : Ind C} + (hY : IndCompactObj Y) (hY' : IndCompactObj Y') (f : Y ⟶ A ⊗ M) + (f' : Y' ⟶ A ⊗ M') : + ∃ (j : A.presentation.I) (_ : UnitAtStage A j) + (g : Y ⟶ imageSubalgebra A j ⊗ M) + (g' : Y' ⟶ imageSubalgebra A j ⊗ M'), + g ≫ imageSubalgebraHom A j ▷ M = f ∧ + g' ≫ imageSubalgebraHom A j ▷ M' = f' := by + obtain ⟨i₁, g₁, hg₁⟩ := exists_presStage_whiskerRight_factor A hY f + obtain ⟨i₂, g₂, hg₂⟩ := exists_presStage_whiskerRight_factor A hY' f' + obtain ⟨g, hg⟩ := exists_imageSubalgebra_factor A + (IsFiltered.max (IsFiltered.max i₁ i₂) (unitStage A)) + (IsFiltered.leftToMax i₁ i₂ ≫ IsFiltered.leftToMax _ _) g₁ f hg₁ + obtain ⟨g', hg'⟩ := exists_imageSubalgebra_factor A + (IsFiltered.max (IsFiltered.max i₁ i₂) (unitStage A)) + (IsFiltered.rightToMax i₁ i₂ ≫ IsFiltered.leftToMax _ _) g₂ f' hg₂ + exact ⟨_, UnitAtStage.map (IsFiltered.rightToMax _ _), g, g', hg, hg'⟩ + +/-- **A single datum descends to an image subalgebra**, generated at a +stage that also carries the unit of the algebra. -/ +theorem exists_imageSubalgebra_single + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] + {Y M : Ind C} + (hY : IndCompactObj Y) (f : Y ⟶ A ⊗ M) : + ∃ (j : A.presentation.I) (_ : UnitAtStage A j) + (g : Y ⟶ imageSubalgebra A j ⊗ M), + g ≫ imageSubalgebraHom A j ▷ M = f := by + obtain ⟨i, g₀, hg₀⟩ := exists_presStage_whiskerRight_factor A hY f + obtain ⟨g, hg⟩ := exists_imageSubalgebra_factor A + (IsFiltered.max i (unitStage A)) (IsFiltered.leftToMax _ _) g₀ f hg₀ + exact ⟨_, UnitAtStage.map (IsFiltered.rightToMax _ _), g, hg⟩ + +end IntoImage + +/-! ## The two theorems -/ + +section Close + +variable {C : Type v} + +/-- **The inclusion of the image subalgebra stays a monomorphism after +tensoring**: the tensor product of `Ind C` is exact in each +variable. -/ +theorem mono_imageSubalgebraHom_whiskerRight + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + (A : Ind C) [MonObj A] + (i₀ : A.presentation.I) (M : Ind C) : + Mono (imageSubalgebraHom A i₀ ▷ M) := + haveI := mono_imageSubalgebraHom A i₀ + inferInstanceAs + (Mono ((tensorRight M).map (imageSubalgebraHom A i₀))) + +/-- **The mixed sums are compact.** -/ +theorem indCompactObj_mix + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + (L : OddLine (Ind C)) (p q : ℕ) : + IndCompactObj (L.mix p q) := + fun D f => exists_factor_of_mix_hom_colimit L p q D f + +/-- **The countably presented form of local mixedness**: an object of +`Ind C` that becomes a mixed sum of the unit and the odd line over +some algebra with non-vanishing unit already becomes one over a +countably presented such algebra, provided the object is compact and +the objects of `C` have finite length. -/ +theorem locallyMixed_countablyPresented + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + (L : OddLine (Ind C)) + (X : Ind C) (hX : IndCompactObj X) + (hlen : ∀ Z : C, ∃ N, LengthLE Z N) (h : L.LocallyMixed X) : + ∃ (p q : ℕ) (A : Ind C) (_ : MonObj A) (_ : IsCommMonObj A), + η[A] ≠ 0 ∧ CountablyPresented A ∧ + Nonempty (freeMod A X ≅ freeMod A (L.mix p q)) := by + obtain ⟨p, q, A, hmon, hcomm, hA, ⟨Φ⟩⟩ := h + let := hmon + let := hcomm + obtain ⟨j, hjunit, u, v, hu, hv⟩ := + exists_imageSubalgebra_pair A hX (indCompactObj_mix L p q) + (freeModHomEquiv A X (freeMod A (L.mix p q)) Φ.hom) + (freeModHomEquiv A (L.mix p q) (freeMod A X) Φ.inv) + have := hjunit + have := mono_imageSubalgebraHom_whiskerRight A j X + have := mono_imageSubalgebraHom_whiskerRight A j (L.mix p q) + refine ⟨p, q, imageSubalgebra A j, inferInstance, inferInstance, + one_imageSubalgebra_ne_zero A j hA, + countablyPresented_imageSubalgebra A j + (indImageEmbedded_of_lengthLE hlen), + ⟨freeModIsoOfRoundTrip (imageSubalgebra A j) u v ?_ ?_⟩⟩ + · refine roundTrip_descend (imageSubalgebraHom A j) + (imageOne_comp_hom A j) (imageMul_comp_hom A j) u v ?_ + rw [hu, hv] + exact roundTrip_of_freeModIso A Φ + · refine roundTrip_descend (imageSubalgebraHom A j) + (imageOne_comp_hom A j) (imageMul_comp_hom A j) v u ?_ + rw [hu, hv] + exact roundTrip_of_freeModIso A Φ.symm + +/-- **The countably presented form of the local splitting**: a +morphism of `Ind C` whose free module acquires a section over some +algebra with non-vanishing unit already acquires one over a countably +presented such algebra, provided the two objects are compact and the +objects of `C` have finite length. -/ +theorem section_countablyPresented + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + {V W : Ind C} (g : V ⟶ W) + (_hV : IndCompactObj V) (hW : IndCompactObj W) + (hlen : ∀ Z : C, ∃ N, LengthLE Z N) + (h : ∃ (A : Ind C) (_ : MonObj A) (_ : IsCommMonObj A), + η[A] ≠ 0 ∧ + ∃ s : freeMod A W ⟶ freeMod A V, + s ≫ freeModMap A g = 𝟙 (freeMod A W)) : + ∃ (A : Ind C) (_ : MonObj A) (_ : IsCommMonObj A), + η[A] ≠ 0 ∧ CountablyPresented A ∧ + ∃ s : freeMod A W ⟶ freeMod A V, + s ≫ freeModMap A g = 𝟙 (freeMod A W) := by + obtain ⟨A, hmon, hcomm, hA, s, hs⟩ := h + let := hmon + let := hcomm + obtain ⟨j, hjunit, t, ht⟩ := exists_imageSubalgebra_single A hW + (freeModHomEquiv A W (freeMod A V) s) + have := hjunit + have := mono_imageSubalgebraHom_whiskerRight A j W + refine ⟨imageSubalgebra A j, inferInstance, inferInstance, + one_imageSubalgebra_ne_zero A j hA, + countablyPresented_imageSubalgebra A j + (indImageEmbedded_of_lengthLE hlen), + exists_section_of_datum (imageSubalgebra A j) g t ?_⟩ + refine sectionDatum_descend (imageSubalgebraHom A j) + (imageOne_comp_hom A j) g t ?_ + rw [ht] + exact sectionDatum_of_section A g s hs + +end Close + +/-! ## Acceptance tests + +The compactness hypothesis of the two theorems is satisfied by the +embedded objects, which is the shape in which the theorems are +consumed. -/ + +section AcceptanceTests + +variable {C : Type v} + +example + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + (L : OddLine (Ind C)) (Z : C) + (hlen : ∀ Y : C, ∃ N, LengthLE Y N) + (h : L.LocallyMixed ((indOf : C ⥤ Ind C).obj Z)) : + ∃ (p q : ℕ) (A : Ind C) (_ : MonObj A) (_ : IsCommMonObj A), + η[A] ≠ 0 ∧ CountablyPresented A ∧ + Nonempty (freeMod A ((indOf : C ⥤ Ind C).obj Z) ≅ + freeMod A (L.mix p q)) := + locallyMixed_countablyPresented L _ (indCompactObj_indOf Z) hlen h + +example + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + {Y Z : C} (g : (indOf : C ⥤ Ind C).obj Y ⟶ indOf.obj Z) + (hlen : ∀ W : C, ∃ N, LengthLE W N) + (h : ∃ (A : Ind C) (_ : MonObj A) (_ : IsCommMonObj A), + η[A] ≠ 0 ∧ + ∃ s : freeMod A (indOf.obj Z) ⟶ freeMod A (indOf.obj Y), + s ≫ freeModMap A g = 𝟙 (freeMod A (indOf.obj Z))) : + ∃ (A : Ind C) (_ : MonObj A) (_ : IsCommMonObj A), + η[A] ≠ 0 ∧ CountablyPresented A ∧ + ∃ s : freeMod A (indOf.obj Z) ⟶ freeMod A (indOf.obj Y), + s ≫ freeModMap A g = 𝟙 (freeMod A (indOf.obj Z)) := + section_countablyPresented g (indCompactObj_indOf Y) + (indCompactObj_indOf Z) hlen h + +end AcceptanceTests + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableNullstellensatz.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableNullstellensatz.lean new file mode 100644 index 0000000000..53219babf0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableNullstellensatz.lean @@ -0,0 +1,84 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# The countable Nullstellensatz over ℂ + +The classical Nullstellensatz produces a ℂ-point of a nonzero +commutative ℂ-algebra of finite type. Deligne's Proposition 4.5 +needs a ℂ-point of the algebra over which the fibre functor is +defined, and that algebra is not presented as a finite-type one; it +is instead built from countably much data, so its dimension as a +ℂ-vector space is at most countable. The countable-dimension +hypothesis is a perfectly good replacement for the finite-type +hypothesis, because the obstruction is uncountable: a field +extension of ℂ containing a transcendental element `x` already +contains the ℂ-linearly independent family `(x - a)⁻¹`, `a : ℂ`, of +cardinality the continuum. + +Three results are recorded. A field extension of ℂ of at most +countable dimension is algebraic; a nonzero commutative ℂ-algebra of +at most countable dimension maps onto ℂ; and an algebra generated by +a countable set has at most countable dimension. + +The finite-type predecessor is `RS.exists_algHom_complex` in +[NullPoint.lean](NullPoint.lean), which runs the same last two steps +— quotient by a maximal ideal, lift along `IsAlgClosed.lift` — over +Zariski's lemma instead of the dimension count. +-/ + +@[expose] public section + +namespace RS + +/-- A field extension of ℂ of at most countable dimension is +algebraic. A transcendental element `x` would give the ℂ-linearly +independent family `(x - a)⁻¹` indexed by `a : ℂ`, forcing the +dimension to be at least the continuum. -/ +theorem algebraic_of_countable_dimension (K : Type*) [Field K] [Algebra ℂ K] + (h : Module.rank ℂ K ≤ Cardinal.aleph0) : Algebra.IsAlgebraic ℂ K := by + by_contra hna + rw [← Algebra.transcendental_iff_not_isAlgebraic] at hna + obtain ⟨x, hx⟩ := Algebra.transcendental_def.mp hna + have hle := hx.linearIndependent_sub_inv.cardinal_lift_le_rank + rw [Cardinal.mk_complex, Cardinal.lift_continuum, Cardinal.lift_uzero] at hle + exact absurd (hle.trans h) (not_le.mpr Cardinal.aleph0_lt_continuum) + +/-- **The countable Nullstellensatz**: a nonzero commutative +ℂ-algebra of at most countable dimension admits a ℂ-point. Quotient +by a maximal ideal, observe that the residue field again has at most +countable dimension, hence is algebraic over ℂ, and lift along the +algebraically closed base. -/ +theorem exists_algHom_of_countable_dimension (R : Type*) [CommRing R] + [Algebra ℂ R] [Nontrivial R] (h : Module.rank ℂ R ≤ Cardinal.aleph0) : + Nonempty (R →ₐ[ℂ] ℂ) := by + obtain ⟨m, hm⟩ := Ideal.exists_maximal R + have := hm + let := Ideal.Quotient.field m + have : Algebra.IsAlgebraic ℂ (R ⧸ m) := + algebraic_of_countable_dimension (R ⧸ m) <| + le_trans (LinearMap.rank_le_of_surjective + (Ideal.Quotient.mkₐ ℂ m).toLinearMap + (Ideal.Quotient.mkₐ_surjective ℂ m)) h + exact ⟨(IsAlgClosed.lift (M := ℂ)).comp (Ideal.Quotient.mkₐ ℂ m)⟩ + +/-- **A field extension of the complex numbers of countable dimension +is the complex numbers**: every element is a complex multiple of the +unit. This is the shape the scalar computation for a simple algebra +consumes. -/ +theorem exists_smul_one_of_countable_dimension (K : Type*) [Field K] + [Algebra ℂ K] (h : Module.rank ℂ K ≤ Cardinal.aleph0) (x : K) : + ∃ c : ℂ, x = c • (1 : K) := by + have : Algebra.IsAlgebraic ℂ K := algebraic_of_countable_dimension K h + obtain ⟨c, hc⟩ := + (IsAlgClosed.algebraMap_bijective_of_isIntegral (k := ℂ) (K := K)).2 x + exact ⟨c, by rw [← hc, Algebra.algebraMap_eq_smul_one]⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoverFactor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoverFactor.lean new file mode 100644 index 0000000000..3cbb25d010 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoverFactor.lean @@ -0,0 +1,421 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PlainShuffle +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistPow + +/-! +# The cover factorisation of the twisted power identification + +Over the plain tensor-power covers, the twisted power +identification is the diagonal shuffle followed by the projection +of the module factor. This reduces the conjugation of the +permutation action through the identification to the committed +plain equivariance. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- The arity-one projection is the unitor through the singleton +identification. -/ +theorem modPowπ_one [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] + (X : D) [ModObj A X] : + modPowπ A X 1 ≫ (modPowOne A X).hom = (λ_ X).hom := by + erw [modPowOne, Iso.trans_hom, ← Category.assoc, + show modPowπ A X 1 ≫ (modPowTriv A X (by omega)).hom = + 𝟙 (tensorPow D X 1) from + (modPowTriv A X (by omega)).inv_hom_id, + Category.id_comp] + +/-- The singleton inverse is the unitor into the projection. -/ +theorem modPowOne_inv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] + (X : D) [ModObj A X] : + (modPowOne A X).inv = (λ_ X).inv ≫ modPowπ A X 1 := by + have h : ((λ_ X).inv ≫ modPowπ A X 1) ≫ + (modPowOne A X).hom = 𝟙 X := + (Category.assoc _ _ _).trans + ((congrArg (fun t : tensorPow D X 1 ⟶ X => + (λ_ X).inv ≫ t) (modPowπ_one A X)).trans + (Iso.inv_hom_id (λ_ X))) + exact ((Iso.comp_hom_eq_id (modPowOne A X)).mp h).symm + +/-- The generic core of the shuffle–concatenation step: against a +map into a tensor pair, the unit shuffle and the two unit +concatenation words dissolve into the source concatenation word. +Every concatenation word at block size one is a unitor windup, so +no braiding beyond the interchange blocks enters. -/ +private theorem shuffle_concat_core + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + {P B₁ B₂ : D} (C₁ C₂ : D) + (f : P ⟶ B₁ ⊗ B₂) : + (f ⊗ₘ (((λ_ (𝟙_ D)).inv ▷ (C₁ ⊗ C₂)) ≫ + tensorμ (𝟙_ D) (𝟙_ D) C₁ C₂)) ≫ + tensorμ B₁ B₂ (𝟙_ D ⊗ C₁) (𝟙_ D ⊗ C₂) ≫ + (((α_ B₁ (𝟙_ D) C₁).inv ≫ ((ρ_ B₁).hom ▷ C₁)) ▷ + (B₂ ⊗ (𝟙_ D ⊗ C₂))) ≫ + ((B₁ ⊗ C₁) ◁ + ((α_ B₂ (𝟙_ D) C₂).inv ≫ ((ρ_ B₂).hom ▷ C₂))) = + ((α_ P (𝟙_ D) (C₁ ⊗ C₂)).inv ≫ + ((ρ_ P).hom ▷ (C₁ ⊗ C₂))) ≫ + ((f ▷ (C₁ ⊗ C₂)) ≫ tensorμ B₁ B₂ C₁ C₂) := by + have hw : ∀ (B C : D), (α_ B (𝟙_ D) C).inv ≫ + ((ρ_ B).hom ▷ C) = B ◁ (λ_ C).hom := by + intro B C + monoidal + rw [hw B₁ C₁, hw B₂ C₂, hw P (C₁ ⊗ C₂)] + rw [← MonoidalCategory.tensorHom_def (B₁ ◁ (λ_ C₁).hom) + (B₂ ◁ (λ_ C₂).hom), + ← tensorμ_natural_right B₁ B₂ (λ_ C₁).hom (λ_ C₂).hom, + ← MonoidalCategory.id_tensorHom (B₁ ⊗ B₂) + ((λ_ C₁).hom ⊗ₘ (λ_ C₂).hom), + ← Category.assoc, MonoidalCategory.tensorHom_comp_tensorHom, + Category.comp_id, Category.assoc, + ← tensor_left_unitality C₁ C₂, + MonoidalCategory.tensorHom_def' f (λ_ (C₁ ⊗ C₂)).hom, + Category.assoc] + +/-- **The shuffle absorbs one concatenated block**: shuffling the +two halves and concatenating both target powers is concatenating +the source power and shuffling. At block size one every +concatenation word is definitionally a unitor windup, so this is +the generic core, read through the recursions. -/ +private theorem shuffle_concat_step + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (V X : D) (k : ℕ) : + (tensorPowConcat (V ⊗ X) (k + 1) (0 + 1)).inv ≫ + ((plainShuffle V X (k + 1)).hom ⊗ₘ + (plainShuffle V X (0 + 1)).hom) ≫ + tensorμ (tensorPow D V (k + 1)) (tensorPow D X (k + 1)) + (tensorPow D V (0 + 1)) (tensorPow D X (0 + 1)) ≫ + ((tensorPowConcat V (k + 1) (0 + 1)).hom ▷ + (tensorPow D X (k + 1) ⊗ tensorPow D X (0 + 1))) ≫ + (tensorPow D V (k + 1 + (0 + 1)) ◁ + (tensorPowConcat X (k + 1) (0 + 1)).hom) = + (plainShuffle V X (k + 1 + 1)).hom := by + rw [Iso.inv_comp_eq] + exact shuffle_concat_core V X (plainShuffle V X (k + 1)).hom + +/-- The base of the cover factorisation: at arity one the twisted +identification over the plain covers is the unit shuffle over the +module projection. -/ +private theorem twistPow_cover_factor_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] + (V : D) (R : Mod D A) : + modPowπ A ((tensorLeftMod A V R).X) (0 + 1) ≫ + ((twistPowModIso A V R 0).hom).hom = + (plainShuffle V R.X (0 + 1)).hom ≫ + ((tensorPow D V (0 + 1)) ◁ modPowπ A R.X (0 + 1)) := by + rw [twistPowModIso] + change modPowπ A ((tensorLeftMod A V R).X) 1 ≫ + ((modPowOne A ((tensorLeftMod A V R).X)).hom ≫ + (((λ_ V).inv ▷ R.X) ≫ + ((𝟙_ D ⊗ V) ◁ (modPowOne A R.X).inv))) = + (plainShuffle V R.X 1).hom ≫ + ((𝟙_ D ⊗ V) ◁ modPowπ A R.X 1) + erw [← Category.assoc, modPowπ_one, modPowOne_inv, + MonoidalCategory.whiskerLeft_comp] + have hL : (λ_ (V ⊗ R.X)).hom ≫ ((λ_ V).inv ▷ R.X) ≫ + ((𝟙_ D ⊗ V) ◁ (λ_ R.X).inv) = + (plainShuffle V R.X 1).hom := by + rw [← MonoidalCategory.tensorHom_def, + show (plainShuffle V R.X 1).hom = + ((λ_ (𝟙_ D)).inv ▷ (V ⊗ R.X)) ≫ + tensorμ (𝟙_ D) (𝟙_ D) V R.X from rfl, + tensor_left_unitality V R.X] + simp only [Category.assoc, + MonoidalCategory.tensorHom_comp_tensorHom, Iso.hom_inv_id, + MonoidalCategory.id_tensorHom_id, Category.comp_id] + exact (reassoc_of% hL) ((𝟙_ D ⊗ V) ◁ modPowπ A R.X 1) + +private theorem twistPow_cover_factor_moduleProjection + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] + (V : D) (R : Mod D A) (k : ℕ) : ((tensorPow D V (k + 1) ⊗ + tensorPow D V (0 + 1)) ◁ + (modPowπ A R.X (k + 1) ⊗ₘ modPowπ A R.X (0 + 1))) ≫ + (((tensorPow D V (k + 1) ⊗ tensorPow D V (0 + 1)) ◁ + modTensorπ A (modPowMod A R.X k) + (modPowMod A R.X 0)) ≫ + (((tensorPowConcat V (k + 1) (0 + 1)).hom ▷ + modTensor A (modPowMod A R.X k) + (modPowMod A R.X 0)) ≫ + (tensorPow D V (k + 1 + (0 + 1)) ◁ + powMulDesc A R.X k 0))) = + ((tensorPowConcat V (k + 1) (0 + 1)).hom ▷ + (tensorPow D R.X (k + 1) ⊗ tensorPow D R.X (0 + 1))) ≫ + ((tensorPow D V (k + 1 + (0 + 1)) ◁ + (tensorPowConcat R.X (k + 1) (0 + 1)).hom) ≫ + (tensorPow D V (k + 1 + (0 + 1)) ◁ + modPowπ A R.X (k + 1 + (0 + 1)))) := + ((MonoidalCategory.whiskerLeft_comp_assoc + (tensorPow D V (k + 1) ⊗ tensorPow D V (0 + 1)) + (modPowπ A R.X (k + 1) ⊗ₘ modPowπ A R.X (0 + 1)) + (modTensorπ A (modPowMod A R.X k) (modPowMod A R.X 0)) + _).symm).trans + ((MonoidalCategory.whisker_exchange_assoc + (tensorPowConcat V (k + 1) (0 + 1)).hom + ((modPowπ A R.X (k + 1) ⊗ₘ modPowπ A R.X (0 + 1)) ≫ + modTensorπ A (modPowMod A R.X k) + (modPowMod A R.X 0)) + (tensorPow D V (k + 1 + (0 + 1)) ◁ + powMulDesc A R.X k 0)).trans + (congrArg (fun z => + ((tensorPowConcat V (k + 1) (0 + 1)).hom ▷ + (tensorPow D R.X (k + 1) ⊗ + tensorPow D R.X (0 + 1))) ≫ z) + (((MonoidalCategory.whiskerLeft_comp + (tensorPow D V (k + 1 + (0 + 1))) + ((modPowπ A R.X (k + 1) ⊗ₘ + modPowπ A R.X (0 + 1)) ≫ + modTensorπ A (modPowMod A R.X k) + (modPowMod A R.X 0)) + (powMulDesc A R.X k 0)).symm).trans + ((congrArg (fun z => + tensorPow D V (k + 1 + (0 + 1)) ◁ z) + ((Category.assoc + (modPowπ A R.X (k + 1) ⊗ₘ + modPowπ A R.X (0 + 1)) + (modTensorπ A (modPowMod A R.X k) + (modPowMod A R.X 0)) + (powMulDesc A R.X k 0)).trans + ((congrArg (fun z => + (modPowπ A R.X (k + 1) ⊗ₘ + modPowπ A R.X (0 + 1)) ≫ z) + (modTensorπ_powMulDesc A R.X k 0)).trans + (modPowπ_tensor_modPowMul A R.X (k + 1) + (0 + 1))))).trans + (MonoidalCategory.whiskerLeft_comp + (tensorPow D V (k + 1 + (0 + 1))) + (tensorPowConcat R.X (k + 1) (0 + 1)).hom + (modPowπ A R.X (k + 1 + (0 + 1)))))))) + +/-- **The cover factorisation**: over the plain covers, the +twisted power identification is the diagonal shuffle followed by +the projection of the module factor. -/ +theorem twistPow_cover_factor + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] + (V : D) (R : Mod D A) : + ∀ k : ℕ, + modPowπ A ((tensorLeftMod A V R).X) (k + 1) ≫ + ((twistPowModIso A V R k).hom).hom = + (plainShuffle V R.X (k + 1)).hom ≫ + ((tensorPow D V (k + 1)) ◁ modPowπ A R.X (k + 1)) + | 0 => twistPow_cover_factor_zero A V R + | (k + 1) => by + rw [twistPowModIso] + change modPowπ A ((tensorLeftMod A V R).X) (k + 1 + 0 + 1) ≫ + (powSplit A ((tensorLeftMod A V R).X) k 0 ≫ + (modTensorMap A (twistPowModIso A V R k).hom + (twistPowModIso A V R 0).hom ≫ + (twistShuffleHom A (tensorPow D V (k + 1)) + (tensorPow D V (0 + 1)) (modPowMod A R.X k) + (modPowMod A R.X 0) ≫ + (((tensorPowConcat V (k + 1) (0 + 1)).hom ▷ + modTensor A (modPowMod A R.X k) + (modPowMod A R.X 0)) ≫ + (tensorPow D V (k + 1 + (0 + 1)) ◁ + powMulDesc A R.X k 0))))) + = (plainShuffle V R.X (k + 1 + 1)).hom ≫ + (tensorPow D V (k + 1 + 1) ◁ modPowπ A R.X (k + 1 + 1)) + have hIH : (modPowπ A ((tensorLeftMod A V R).X) (k + 1) ⊗ₘ + modPowπ A ((tensorLeftMod A V R).X) (0 + 1)) ≫ + (((twistPowModIso A V R k).hom).hom ⊗ₘ + ((twistPowModIso A V R 0).hom).hom) = + ((plainShuffle V R.X (k + 1)).hom ⊗ₘ + (plainShuffle V R.X (0 + 1)).hom) ≫ + ((tensorPow D V (k + 1) ◁ modPowπ A R.X (k + 1)) ⊗ₘ + (tensorPow D V (0 + 1) ◁ modPowπ A R.X (0 + 1))) := + (MonoidalCategory.tensorHom_comp_tensorHom _ _ _ _).trans + ((congrArg₂ (· ⊗ₘ ·) (twistPow_cover_factor A V R k) + (twistPow_cover_factor_zero A V R)).trans + (MonoidalCategory.tensorHom_comp_tensorHom + _ _ _ _).symm) + have hnat : ((tensorPow D V (k + 1) ◁ + modPowπ A R.X (k + 1)) ⊗ₘ + (tensorPow D V (0 + 1) ◁ modPowπ A R.X (0 + 1))) ≫ + tensorμ (tensorPow D V (k + 1)) (modPow A R.X (k + 1)) + (tensorPow D V (0 + 1)) (modPow A R.X (0 + 1)) = + tensorμ (tensorPow D V (k + 1)) (tensorPow D R.X (k + 1)) + (tensorPow D V (0 + 1)) (tensorPow D R.X (0 + 1)) ≫ + ((tensorPow D V (k + 1) ⊗ tensorPow D V (0 + 1)) ◁ + (modPowπ A R.X (k + 1) ⊗ₘ modPowπ A R.X (0 + 1))) := by + simpa using tensorμ_natural (𝟙 (tensorPow D V (k + 1))) + (modPowπ A R.X (k + 1)) (𝟙 (tensorPow D V (0 + 1))) + (modPowπ A R.X (0 + 1)) + have hRside := twistPow_cover_factor_moduleProjection A V R k + have hTail : modTensorπ A + (modPowMod A ((tensorLeftMod A V R).X) k) + (modPowMod A ((tensorLeftMod A V R).X) 0) ≫ + (modTensorMap A (twistPowModIso A V R k).hom + (twistPowModIso A V R 0).hom ≫ + (twistShuffleHom A (tensorPow D V (k + 1)) + (tensorPow D V (0 + 1)) (modPowMod A R.X k) + (modPowMod A R.X 0) ≫ + (((tensorPowConcat V (k + 1) (0 + 1)).hom ▷ + modTensor A (modPowMod A R.X k) + (modPowMod A R.X 0)) ≫ + (tensorPow D V (k + 1 + (0 + 1)) ◁ + powMulDesc A R.X k 0)))) = + (((twistPowModIso A V R k).hom).hom ⊗ₘ + ((twistPowModIso A V R 0).hom).hom) ≫ + (tensorμ (tensorPow D V (k + 1)) (modPow A R.X (k + 1)) + (tensorPow D V (0 + 1)) (modPow A R.X (0 + 1)) ≫ + (((tensorPow D V (k + 1) ⊗ tensorPow D V (0 + 1)) ◁ + modTensorπ A (modPowMod A R.X k) + (modPowMod A R.X 0)) ≫ + (((tensorPowConcat V (k + 1) (0 + 1)).hom ▷ + modTensor A (modPowMod A R.X k) + (modPowMod A R.X 0)) ≫ + (tensorPow D V (k + 1 + (0 + 1)) ◁ + powMulDesc A R.X k 0)))) := + (modTensorπ_map_assoc A (twistPowModIso A V R k).hom + (twistPowModIso A V R 0).hom _).trans + (congrArg (fun z => + (((twistPowModIso A V R k).hom).hom ⊗ₘ + ((twistPowModIso A V R 0).hom).hom) ≫ z) + ((modTensorπ_twistShuffleHom_assoc A + (tensorPow D V (k + 1)) (tensorPow D V (0 + 1)) + (modPowMod A R.X k) (modPowMod A R.X 0) _).trans + (Category.assoc + (tensorμ (tensorPow D V (k + 1)) + (modPow A R.X (k + 1)) (tensorPow D V (0 + 1)) + (modPow A R.X (0 + 1))) + ((tensorPow D V (k + 1) ⊗ + tensorPow D V (0 + 1)) ◁ + modTensorπ A (modPowMod A R.X k) + (modPowMod A R.X 0)) + _))) + have hMid : (modPowπ A ((tensorLeftMod A V R).X) (k + 1) ⊗ₘ + modPowπ A ((tensorLeftMod A V R).X) (0 + 1)) ≫ + ((((twistPowModIso A V R k).hom).hom ⊗ₘ + ((twistPowModIso A V R 0).hom).hom) ≫ + (tensorμ (tensorPow D V (k + 1)) + (modPow A R.X (k + 1)) (tensorPow D V (0 + 1)) + (modPow A R.X (0 + 1)) ≫ + (((tensorPow D V (k + 1) ⊗ tensorPow D V (0 + 1)) ◁ + modTensorπ A (modPowMod A R.X k) + (modPowMod A R.X 0)) ≫ + (((tensorPowConcat V (k + 1) (0 + 1)).hom ▷ + modTensor A (modPowMod A R.X k) + (modPowMod A R.X 0)) ≫ + (tensorPow D V (k + 1 + (0 + 1)) ◁ + powMulDesc A R.X k 0))))) = + ((plainShuffle V R.X (k + 1)).hom ⊗ₘ + (plainShuffle V R.X (0 + 1)).hom) ≫ + (((tensorPow D V (k + 1) ◁ modPowπ A R.X (k + 1)) ⊗ₘ + (tensorPow D V (0 + 1) ◁ modPowπ A R.X (0 + 1))) ≫ + (tensorμ (tensorPow D V (k + 1)) + (modPow A R.X (k + 1)) (tensorPow D V (0 + 1)) + (modPow A R.X (0 + 1)) ≫ + (((tensorPow D V (k + 1) ⊗ tensorPow D V (0 + 1)) ◁ + modTensorπ A (modPowMod A R.X k) + (modPowMod A R.X 0)) ≫ + (((tensorPowConcat V (k + 1) (0 + 1)).hom ▷ + modTensor A (modPowMod A R.X k) + (modPowMod A R.X 0)) ≫ + (tensorPow D V (k + 1 + (0 + 1)) ◁ + powMulDesc A R.X k 0))))) := + (Category.assoc _ _ _).symm.trans + ((congrArg (· ≫ tensorμ (tensorPow D V (k + 1)) + (modPow A R.X (k + 1)) (tensorPow D V (0 + 1)) + (modPow A R.X (0 + 1)) ≫ + (((tensorPow D V (k + 1) ⊗ tensorPow D V (0 + 1)) ◁ + modTensorπ A (modPowMod A R.X k) + (modPowMod A R.X 0)) ≫ + (((tensorPowConcat V (k + 1) (0 + 1)).hom ▷ + modTensor A (modPowMod A R.X k) + (modPowMod A R.X 0)) ≫ + (tensorPow D V (k + 1 + (0 + 1)) ◁ + powMulDesc A R.X k 0)))) hIH).trans + (Category.assoc _ _ _)) + have hW : ((tensorPow D V (k + 1) ◁ + modPowπ A R.X (k + 1)) ⊗ₘ + (tensorPow D V (0 + 1) ◁ modPowπ A R.X (0 + 1))) ≫ + (tensorμ (tensorPow D V (k + 1)) (modPow A R.X (k + 1)) + (tensorPow D V (0 + 1)) (modPow A R.X (0 + 1)) ≫ + (((tensorPow D V (k + 1) ⊗ tensorPow D V (0 + 1)) ◁ + modTensorπ A (modPowMod A R.X k) + (modPowMod A R.X 0)) ≫ + (((tensorPowConcat V (k + 1) (0 + 1)).hom ▷ + modTensor A (modPowMod A R.X k) + (modPowMod A R.X 0)) ≫ + (tensorPow D V (k + 1 + (0 + 1)) ◁ + powMulDesc A R.X k 0)))) = + tensorμ (tensorPow D V (k + 1)) (tensorPow D R.X (k + 1)) + (tensorPow D V (0 + 1)) (tensorPow D R.X (0 + 1)) ≫ + (((tensorPowConcat V (k + 1) (0 + 1)).hom ▷ + (tensorPow D R.X (k + 1) ⊗ + tensorPow D R.X (0 + 1))) ≫ + ((tensorPow D V (k + 1 + (0 + 1)) ◁ + (tensorPowConcat R.X (k + 1) (0 + 1)).hom) ≫ + (tensorPow D V (k + 1 + (0 + 1)) ◁ + modPowπ A R.X (k + 1 + (0 + 1))))) := + (Category.assoc _ _ _).symm.trans + ((congrArg (· ≫ ((tensorPow D V (k + 1) ⊗ + tensorPow D V (0 + 1)) ◁ + modTensorπ A (modPowMod A R.X k) + (modPowMod A R.X 0)) ≫ + (((tensorPowConcat V (k + 1) (0 + 1)).hom ▷ + modTensor A (modPowMod A R.X k) + (modPowMod A R.X 0)) ≫ + (tensorPow D V (k + 1 + (0 + 1)) ◁ + powMulDesc A R.X k 0))) hnat).trans + ((Category.assoc _ _ _).trans + (congrArg (fun z => + tensorμ (tensorPow D V (k + 1)) + (tensorPow D R.X (k + 1)) + (tensorPow D V (0 + 1)) + (tensorPow D R.X (0 + 1)) ≫ z) hRside))) + refine (modPowπ_powSplit_assoc A ((tensorLeftMod A V R).X) + k 0 _).trans ?_ + conv_lhs => arg 2; erw [Category.assoc] + refine (congrArg (fun z => + (tensorPowConcat ((tensorLeftMod A V R).X) (k + 1) + (0 + 1)).inv ≫ + ((modPowπ A ((tensorLeftMod A V R).X) (k + 1) ⊗ₘ + modPowπ A ((tensorLeftMod A V R).X) (0 + 1)) ≫ z)) + hTail).trans ?_ + refine (congrArg (fun z => + (tensorPowConcat ((tensorLeftMod A V R).X) (k + 1) + (0 + 1)).inv ≫ z) hMid).trans ?_ + refine (congrArg (fun z => + (tensorPowConcat ((tensorLeftMod A V R).X) (k + 1) + (0 + 1)).inv ≫ + (((plainShuffle V R.X (k + 1)).hom ⊗ₘ + (plainShuffle V R.X (0 + 1)).hom) ≫ z)) + hW).trans ?_ + exact (reassoc_of% (shuffle_concat_step V R.X k)) + (tensorPow D V (k + 1 + (0 + 1)) ◁ + modPowπ A R.X (k + 1 + (0 + 1))) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CycleSplit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CycleSplit.lean new file mode 100644 index 0000000000..b379ad961b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CycleSplit.lean @@ -0,0 +1,514 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CharSplit + +/-! +# Additive splitting of the completed cycle product + +The completed cycle product of a permutation, generalised from +`Fin n` to an arbitrary finite carrier, splits additively over the +invariant subsets of the carrier: at a pointwise sum of scalar +sequences it equals the sum, over all invariant subsets, of the +product of the completed cycle products of the two restrictions — +to the subset and to its complement. This is the combinatorial +heart of the induction-multiplicity identity. + +The route is through orbits: the completed cycle product is the +product of `t (O.card)` over the set of all orbits of the +permutation, singleton orbits included; the splitting is then the +expansion of a product of binomials, with subsets of the orbit set +enumerating exactly the invariant subsets of the carrier. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv + +variable {α : Type*} + +/-! ### The completed cycle product over an arbitrary carrier -/ + +/-- The completed cycle product of a prospective power-sum sequence +over an arbitrary finite carrier: the product of `t` over the cycle +type, completed by `t 1` over the fixed points. -/ +noncomputable def cycleFunG [Fintype α] [DecidableEq α] + (t : ℕ → ℂ) (π : Equiv.Perm α) : ℂ := + (π.cycleType.map t).prod * (t 1) ^ (Fintype.card α - π.cycleType.sum) + +/-- On `Fin n` the generalised completed cycle product is the +completed cycle product. -/ +theorem cycleFunG_fin {n : ℕ} (t : ℕ → ℂ) (π : Equiv.Perm (Fin n)) : + cycleFunG t π = cycleFun t π := by + simp only [cycleFunG, cycleFun, Fintype.card_fin] + +/-- The cycle type is invariant under conjugation by an equivalence +of carriers. Universe-polymorphic form of `cycleType_permCongr`. -/ +theorem cycleType_permCongr' + [Fintype α] [DecidableEq α] {β : Type*} [Fintype β] [DecidableEq β] + (e : α ≃ β) (π : Equiv.Perm α) : + (e.permCongr π).cycleType = π.cycleType := by + let : DecidablePred (fun _ : β => True) := fun _ => .isTrue trivial + have h : e.permCongr π = + π.extendDomain (e.trans (Equiv.subtypeUnivEquiv + (fun _ : β => trivial)).symm) := by + ext b + rw [Equiv.Perm.extendDomain_apply_subtype _ _ trivial] + simp + rw [h, Equiv.Perm.cycleType_extendDomain] + +/-- The completed cycle product is invariant under conjugation by +an equivalence of carriers. -/ +theorem cycleFunG_permCongr + [Fintype α] [DecidableEq α] {β : Type*} [Fintype β] [DecidableEq β] + (e : α ≃ β) (t : ℕ → ℂ) + (π : Equiv.Perm α) : + cycleFunG t (e.permCongr π) = cycleFunG t π := by + rw [cycleFunG, cycleFunG, cycleType_permCongr', + (Fintype.card_congr e.symm : Fintype.card β = Fintype.card α)] + +/-! ### Invariant subsets -/ + +/-- A finite set closed under a permutation is closed in both +directions: the permutation restricts to an injective self-map of +the set, which is onto by finiteness. -/ +theorem mem_iff_of_invariant + {π : Equiv.Perm α} {s : Finset α} + (hs : ∀ x ∈ s, π x ∈ s) : ∀ x, π x ∈ s ↔ x ∈ s := by + classical + have himg : s.image π = s := + Finset.eq_of_subset_of_card_le + (fun y hy => by + obtain ⟨x, hx, rfl⟩ := Finset.mem_image.mp hy + exact hs x hx) + (le_of_eq (Finset.card_image_of_injective s π.injective).symm) + intro x + refine ⟨fun hx => ?_, hs x⟩ + rw [← himg] at hx + obtain ⟨y, hy, hyx⟩ := Finset.mem_image.mp hx + rwa [← π.injective hyx] + +/-- The complement of an invariant set is invariant. -/ +theorem invariant_compl [Fintype α] [DecidableEq α] + {π : Equiv.Perm α} {s : Finset α} + (hs : ∀ x ∈ s, π x ∈ s) : ∀ x ∈ sᶜ, π x ∈ sᶜ := by + intro x hx + rw [Finset.mem_compl] at hx ⊢ + exact fun h => hx ((mem_iff_of_invariant hs x).mp h) + +/-- Integer powers of a permutation preserve a two-sided invariant +set. -/ +theorem zpow_apply_mem_of_invariant {π : Equiv.Perm α} + {s : Finset α} (hs : ∀ x, π x ∈ s ↔ x ∈ s) {x : α} + (hx : x ∈ s) (i : ℤ) : (π ^ i) x ∈ s := by + rw [← Equiv.Perm.subtypePerm_apply_zpow_of_mem hs hx] + exact Subtype.coe_prop _ + +/-- The restriction of a permutation to a finite subset, as a +permutation of the subtype: the two-sided restriction when the +subset is invariant, the identity otherwise. -/ +def permRestrict [Fintype α] [DecidableEq α] + (π : Equiv.Perm α) (s : Finset α) : + Equiv.Perm {x // x ∈ s} := + if h : ∀ x, π x ∈ s ↔ x ∈ s then π.subtypePerm h else 1 + +/-- On an invariant subset the restriction is `subtypePerm`. -/ +theorem permRestrict_of_invariant [Fintype α] [DecidableEq α] + {π : Equiv.Perm α} {s : Finset α} + (h : ∀ x, π x ∈ s ↔ x ∈ s) : + permRestrict π s = π.subtypePerm h := by + rw [permRestrict, dite_eq_left h] + +/-! ### Orbits as finite sets -/ + +/-- The orbit of a point under a permutation, as a finite set; +singleton orbits of fixed points included. -/ +def cycleOrbit [Fintype α] [DecidableEq α] + (π : Equiv.Perm α) (x : α) : Finset α := + Finset.univ.filter (π.SameCycle x) + +/-- Membership in an orbit is the same-cycle relation. -/ +theorem mem_cycleOrbit [Fintype α] [DecidableEq α] + {π : Equiv.Perm α} {x y : α} : + y ∈ cycleOrbit π x ↔ π.SameCycle x y := by + simp [cycleOrbit] + +/-- A point lies in its own orbit. -/ +theorem self_mem_cycleOrbit [Fintype α] [DecidableEq α] + (π : Equiv.Perm α) (x : α) : + x ∈ cycleOrbit π x := + mem_cycleOrbit.mpr (Equiv.Perm.SameCycle.refl π x) + +/-- The image of a point lies in the point's orbit. -/ +theorem apply_mem_cycleOrbit [Fintype α] [DecidableEq α] + (π : Equiv.Perm α) (x : α) : + π x ∈ cycleOrbit π x := + mem_cycleOrbit.mpr + (Equiv.Perm.sameCycle_apply_right.mpr Equiv.Perm.SameCycle.rfl) + +/-- Orbits through a common point coincide. -/ +theorem cycleOrbit_eq_of_mem [Fintype α] [DecidableEq α] + {π : Equiv.Perm α} {x y : α} + (h : y ∈ cycleOrbit π x) : cycleOrbit π y = cycleOrbit π x := by + have hxy := mem_cycleOrbit.mp h + ext z + rw [mem_cycleOrbit, mem_cycleOrbit] + exact ⟨fun hyz => hxy.trans hyz, fun hxz => hxy.symm.trans hxz⟩ + +/-- The orbit of a fixed point is a singleton. -/ +theorem cycleOrbit_eq_singleton [Fintype α] [DecidableEq α] + {π : Equiv.Perm α} {x : α} + (hx : π x = x) : cycleOrbit π x = {x} := by + ext y + rw [mem_cycleOrbit, Finset.mem_singleton] + exact ⟨fun h => (h.eq_of_left hx).symm, + fun h => by rw [h]⟩ + +/-- The orbit of a moved point is the support of its cycle. -/ +theorem cycleOrbit_eq_support_cycleOf [Fintype α] [DecidableEq α] + {π : Equiv.Perm α} {x : α} + (hx : π x ≠ x) : cycleOrbit π x = (π.cycleOf x).support := by + ext y + rw [mem_cycleOrbit, Equiv.Perm.mem_support_cycleOf_iff' hx] + +/-- The set of orbits of a permutation, singleton orbits +included. -/ +def cycleOrbits [Fintype α] [DecidableEq α] + (π : Equiv.Perm α) : Finset (Finset α) := + Finset.univ.image (cycleOrbit π) + +/-- Every orbit belongs to the set of orbits. -/ +theorem cycleOrbit_mem_cycleOrbits [Fintype α] [DecidableEq α] + (π : Equiv.Perm α) (x : α) : + cycleOrbit π x ∈ cycleOrbits π := + Finset.mem_image_of_mem _ (Finset.mem_univ x) + +/-- The members of the set of orbits are the orbits. -/ +theorem mem_cycleOrbits [Fintype α] [DecidableEq α] + {π : Equiv.Perm α} {O : Finset α} : + O ∈ cycleOrbits π ↔ ∃ x, cycleOrbit π x = O := by + simp [cycleOrbits] + +/-- An orbit is the orbit of each of its points. -/ +theorem eq_cycleOrbit_of_mem [Fintype α] [DecidableEq α] + {π : Equiv.Perm α} + {O : Finset α} (hO : O ∈ cycleOrbits π) {x : α} (hx : x ∈ O) : + O = cycleOrbit π x := by + obtain ⟨y, rfl⟩ := mem_cycleOrbits.mp hO + exact (cycleOrbit_eq_of_mem hx).symm + +/-- Orbits are nonempty. -/ +theorem nonempty_of_mem_cycleOrbits [Fintype α] [DecidableEq α] + {π : Equiv.Perm α} + {O : Finset α} (hO : O ∈ cycleOrbits π) : O.Nonempty := by + obtain ⟨x, rfl⟩ := mem_cycleOrbits.mp hO + exact ⟨x, self_mem_cycleOrbit π x⟩ + +/-! ### The completed cycle product as an orbit product -/ + +/-- The singleton orbits are the fixed points. -/ +theorem filter_card_one_cycleOrbits [Fintype α] [DecidableEq α] + (π : Equiv.Perm α) : + (cycleOrbits π).filter (fun O => O.card = 1) = + π.supportᶜ.image (fun x => {x}) := by + ext O + rw [Finset.mem_filter, Finset.mem_image] + constructor + · rintro ⟨hO, hcard⟩ + obtain ⟨x, rfl⟩ := mem_cycleOrbits.mp hO + obtain ⟨a, ha⟩ := Finset.card_eq_one.mp hcard + have hxa : x = a := Finset.mem_singleton.mp + (ha ▸ self_mem_cycleOrbit π x) + have hfix : π x = x := by + have h1 : π x ∈ ({a} : Finset α) := + ha ▸ apply_mem_cycleOrbit π x + rw [Finset.mem_singleton] at h1 + rw [h1, hxa] + exact ⟨x, Finset.mem_compl.mpr fun hs => + Equiv.Perm.mem_support.mp hs hfix, + (cycleOrbit_eq_singleton hfix).symm⟩ + · rintro ⟨x, hx, rfl⟩ + have hfix : π x = x := + Equiv.Perm.notMem_support.mp (Finset.mem_compl.mp hx) + exact ⟨cycleOrbit_eq_singleton hfix ▸ + cycleOrbit_mem_cycleOrbits π x, Finset.card_singleton x⟩ + +/-- The non-singleton orbits are the supports of the cycle +factors. -/ +theorem filter_card_ne_one_cycleOrbits [Fintype α] [DecidableEq α] + (π : Equiv.Perm α) : + (cycleOrbits π).filter (fun O => ¬O.card = 1) = + π.cycleFactorsFinset.image Equiv.Perm.support := by + ext O + rw [Finset.mem_filter, Finset.mem_image] + constructor + · rintro ⟨hO, hcard⟩ + obtain ⟨x, rfl⟩ := mem_cycleOrbits.mp hO + have hx : π x ≠ x := fun hfix => hcard + (by rw [cycleOrbit_eq_singleton hfix, Finset.card_singleton]) + exact ⟨π.cycleOf x, + Equiv.Perm.cycleOf_mem_cycleFactorsFinset_iff.mpr + (Equiv.Perm.mem_support.mpr hx), + (cycleOrbit_eq_support_cycleOf hx).symm⟩ + · rintro ⟨c, hc, rfl⟩ + have hcyc : c.IsCycle := + (Equiv.Perm.mem_cycleFactorsFinset_iff.mp hc).1 + obtain ⟨a, ha⟩ := hcyc.nonempty_support + have hπa : π a ≠ a := by + rw [← (Equiv.Perm.mem_cycleFactorsFinset_iff.mp hc).2 a ha] + exact Equiv.Perm.mem_support.mp ha + have hcc : c = π.cycleOf a := Equiv.Perm.cycle_is_cycleOf ha hc + refine ⟨?_, ?_⟩ + · rw [hcc, ← cycleOrbit_eq_support_cycleOf hπa] + exact cycleOrbit_mem_cycleOrbits π a + · have h2 := hcyc.two_le_card_support + omega + +/-- **The completed cycle product is the orbit product**: the +product of `t` at the orbit sizes, over all orbits, singleton +orbits included. -/ +theorem cycleFunG_eq_prod_cycleOrbits [Fintype α] [DecidableEq α] + (t : ℕ → ℂ) + (π : Equiv.Perm α) : + cycleFunG t π = ∏ O ∈ cycleOrbits π, t O.card := by + rw [← Finset.prod_filter_mul_prod_filter_not (cycleOrbits π) + (fun O => O.card = 1) (fun O => t O.card)] + rw [filter_card_one_cycleOrbits, filter_card_ne_one_cycleOrbits] + rw [Finset.prod_image + (fun x _ y _ h => Finset.singleton_injective h)] + rw [Finset.prod_image (fun c hc c' hc' h => by + have hcyc : Equiv.Perm.IsCycle c := + (Equiv.Perm.mem_cycleFactorsFinset_iff.mp hc).1 + obtain ⟨a, ha⟩ := hcyc.nonempty_support + have ha' : a ∈ c'.support := h ▸ ha + rw [Equiv.Perm.cycle_is_cycleOf ha hc, + Equiv.Perm.cycle_is_cycleOf ha' hc'])] + have hsing : ∏ x ∈ π.supportᶜ, t ({x} : Finset α).card = + (t 1) ^ (Fintype.card α - π.cycleType.sum) := by + rw [Finset.prod_congr rfl fun x _ => by + rw [Finset.card_singleton]] + rw [Finset.prod_const, Finset.card_compl, + Equiv.Perm.sum_cycleType] + have hbig : ∏ c ∈ π.cycleFactorsFinset, t c.support.card = + (π.cycleType.map t).prod := by + rw [Equiv.Perm.cycleType_def, Multiset.map_map] + rfl + rw [hsing, hbig, cycleFunG, mul_comm] + +/-! ### Restriction to an invariant subset -/ + +/-- Orbits of points of a two-sided invariant set stay inside the +set. -/ +theorem cycleOrbit_subset_of_invariant [Fintype α] [DecidableEq α] + {π : Equiv.Perm α} + {s : Finset α} (hs : ∀ x, π x ∈ s ↔ x ∈ s) {x : α} + (hx : x ∈ s) : cycleOrbit π x ⊆ s := by + intro y hy + obtain ⟨i, hi⟩ := mem_cycleOrbit.mp hy + exact hi ▸ zpow_apply_mem_of_invariant hs hx i + +/-- The orbit of the restriction to an invariant set is the orbit +of the ambient permutation, transported along the subtype map. -/ +theorem cycleOrbit_subtypePerm [Fintype α] [DecidableEq α] + {π : Equiv.Perm α} {s : Finset α} + (h : ∀ x, π x ∈ s ↔ x ∈ s) (x : {u // u ∈ s}) : + (cycleOrbit (π.subtypePerm h) x).map + (Function.Embedding.subtype _) = cycleOrbit π ↑x := by + ext y + rw [Finset.mem_map] + constructor + · rintro ⟨y', hy', rfl⟩ + exact mem_cycleOrbit.mpr + (Equiv.Perm.sameCycle_subtypePerm.mp (mem_cycleOrbit.mp hy')) + · intro hy + have hsc := mem_cycleOrbit.mp hy + have hys : y ∈ s := cycleOrbit_subset_of_invariant h x.2 hy + exact ⟨⟨y, hys⟩, mem_cycleOrbit.mpr + (Equiv.Perm.sameCycle_subtypePerm.mpr hsc), rfl⟩ + +/-- The completed cycle product of the restriction to an invariant +set is the product over the ambient orbits inside the set. -/ +theorem cycleFunG_subtypePerm [Fintype α] [DecidableEq α] + {π : Equiv.Perm α} {s : Finset α} + (h : ∀ x, π x ∈ s ↔ x ∈ s) (t : ℕ → ℂ) : + cycleFunG t (π.subtypePerm h) = + ∏ O ∈ (cycleOrbits π).filter (fun O => O ⊆ s), t O.card := by + rw [cycleFunG_eq_prod_cycleOrbits] + refine Finset.prod_nbij' + (fun O => O.map (Function.Embedding.subtype _)) + (fun O => O.subtype (fun u => u ∈ s)) ?_ ?_ ?_ ?_ ?_ + · intro O hO + obtain ⟨x, rfl⟩ := mem_cycleOrbits.mp hO + rw [cycleOrbit_subtypePerm h x, Finset.mem_filter] + exact ⟨cycleOrbit_mem_cycleOrbits π ↑x, + cycleOrbit_subset_of_invariant h x.2⟩ + · intro O hO + rw [Finset.mem_filter] at hO + obtain ⟨x, rfl⟩ := mem_cycleOrbits.mp hO.1 + have hxs : x ∈ s := hO.2 (self_mem_cycleOrbit π x) + have hmap : ((cycleOrbit π x).subtype (fun u => u ∈ s)).map + (Function.Embedding.subtype _) = + (cycleOrbit (π.subtypePerm h) ⟨x, hxs⟩).map + (Function.Embedding.subtype _) := by + rw [Finset.subtype_map_of_mem fun y hy => hO.2 hy, + cycleOrbit_subtypePerm h] + rw [Finset.map_injective _ hmap] + exact cycleOrbit_mem_cycleOrbits _ _ + · intro O _ + ext a + simp only [Finset.mem_subtype, Finset.mem_map, + Function.Embedding.coe_subtype] + exact ⟨fun ⟨b, hb, hba⟩ => (Subtype.ext hba : b = a) ▸ hb, + fun ha => ⟨a, ha, rfl⟩⟩ + · intro O hO + rw [Finset.mem_filter] at hO + exact Finset.subtype_map_of_mem fun y hy => hO.2 hy + · intro O _ + rw [Finset.card_map] + +/-! ### Invariant subsets are unions of orbits -/ + +/-- A union of orbits is an invariant set. -/ +theorem biUnion_invariant [Fintype α] [DecidableEq α] + {π : Equiv.Perm α} + {S : Finset (Finset α)} (hS : S ⊆ cycleOrbits π) : + ∀ x ∈ S.biUnion id, π x ∈ S.biUnion id := by + intro x hx + rw [Finset.mem_biUnion] at hx ⊢ + obtain ⟨O, hO, hxO⟩ := hx + refine ⟨O, hO, ?_⟩ + rw [eq_cycleOrbit_of_mem (hS hO) hxO] + exact apply_mem_cycleOrbit π x + +/-- An invariant set is the union of the orbits it contains. -/ +theorem biUnion_filter_subset_eq [Fintype α] [DecidableEq α] + {π : Equiv.Perm α} {s : Finset α} + (hs : ∀ x, π x ∈ s ↔ x ∈ s) : + ((cycleOrbits π).filter (fun O => O ⊆ s)).biUnion id = s := by + ext x + rw [Finset.mem_biUnion] + constructor + · rintro ⟨O, hO, hxO⟩ + exact (Finset.mem_filter.mp hO).2 hxO + · intro hx + exact ⟨cycleOrbit π x, Finset.mem_filter.mpr + ⟨cycleOrbit_mem_cycleOrbits π x, + cycleOrbit_subset_of_invariant hs hx⟩, + self_mem_cycleOrbit π x⟩ + +/-- The orbits inside a union of orbits are the orbits of the +union. -/ +theorem filter_subset_biUnion [Fintype α] [DecidableEq α] + {π : Equiv.Perm α} + {S : Finset (Finset α)} (hS : S ⊆ cycleOrbits π) : + (cycleOrbits π).filter (fun O => O ⊆ S.biUnion id) = S := by + ext O + rw [Finset.mem_filter] + constructor + · rintro ⟨hO, hOsub⟩ + obtain ⟨x, hxO⟩ := nonempty_of_mem_cycleOrbits hO + have hx := hOsub hxO + rw [Finset.mem_biUnion] at hx + obtain ⟨O', hO', hxO'⟩ := hx + have hOO' : O = O' := by + rw [eq_cycleOrbit_of_mem hO hxO, + eq_cycleOrbit_of_mem (hS hO') hxO'] + exact hOO' ▸ hO' + · intro hO + exact ⟨hS hO, Finset.subset_biUnion_of_mem id hO⟩ + +/-- The orbits inside the complement of an invariant set are the +orbits not inside the set. -/ +theorem filter_subset_compl_eq_sdiff [Fintype α] [DecidableEq α] + {π : Equiv.Perm α} + {s : Finset α} (hs : ∀ x, π x ∈ s ↔ x ∈ s) : + (cycleOrbits π).filter (fun O => O ⊆ sᶜ) = + cycleOrbits π \ (cycleOrbits π).filter (fun O => O ⊆ s) := by + ext O + rw [Finset.mem_sdiff, Finset.mem_filter, Finset.mem_filter] + constructor + · rintro ⟨hO, hOc⟩ + refine ⟨hO, fun hmem => ?_⟩ + obtain ⟨x, hx⟩ := nonempty_of_mem_cycleOrbits hO + exact absurd (hmem.2 hx) (Finset.mem_compl.mp (hOc hx)) + · rintro ⟨hO, hns⟩ + refine ⟨hO, fun x hx => ?_⟩ + rw [Finset.mem_compl] + intro hxs + apply hns + refine ⟨hO, ?_⟩ + rw [eq_cycleOrbit_of_mem hO hx] + exact cycleOrbit_subset_of_invariant hs hxs + +/-! ### The additive splitting -/ + +/-- **Additive splitting of the completed cycle product**: at a +pointwise sum of scalar sequences the completed cycle product is +the sum, over all invariant subsets of the carrier, of the product +of the completed cycle products of the restriction to the subset +in the first sequence and of the restriction to the complement in +the second. Each orbit contributes a binomial factor, and the +expansion enumerates the invariant subsets. -/ +theorem cycleFunG_add_split [Fintype α] [DecidableEq α] + (t t' : ℕ → ℂ) (π : Equiv.Perm α) : + cycleFunG (fun c => t c + t' c) π = + ∑ s ∈ Finset.univ.filter + (fun s : Finset α => ∀ x ∈ s, π x ∈ s), + cycleFunG t (permRestrict π s) * + cycleFunG t' (permRestrict π sᶜ) := by + rw [cycleFunG_eq_prod_cycleOrbits] + rw [show (∏ O ∈ cycleOrbits π, (fun c => t c + t' c) O.card) = + ∏ O ∈ cycleOrbits π, (t O.card + t' O.card) from rfl] + rw [Finset.prod_add] + refine Finset.sum_nbij' (fun S => S.biUnion id) + (fun s => (cycleOrbits π).filter (fun O => O ⊆ s)) + ?_ ?_ ?_ ?_ ?_ + · intro S hS + rw [Finset.mem_powerset] at hS + rw [Finset.mem_filter] + exact ⟨Finset.mem_univ _, biUnion_invariant hS⟩ + · intro s _ + rw [Finset.mem_powerset] + exact Finset.filter_subset _ _ + · intro S hS + rw [Finset.mem_powerset] at hS + exact filter_subset_biUnion hS + · intro s hs + rw [Finset.mem_filter] at hs + exact biUnion_filter_subset_eq (mem_iff_of_invariant hs.2) + · intro S hS + rw [Finset.mem_powerset] at hS + have hsinv : ∀ x, π x ∈ S.biUnion id ↔ x ∈ S.biUnion id := + mem_iff_of_invariant (biUnion_invariant hS) + have hcinv : ∀ x, π x ∈ (S.biUnion id)ᶜ ↔ + x ∈ (S.biUnion id)ᶜ := + mem_iff_of_invariant (invariant_compl (biUnion_invariant hS)) + rw [permRestrict_of_invariant hsinv, + permRestrict_of_invariant hcinv, + cycleFunG_subtypePerm hsinv t, cycleFunG_subtypePerm hcinv t', + filter_subset_biUnion hS, + filter_subset_compl_eq_sdiff hsinv, filter_subset_biUnion hS] + +/-- **Additive splitting of the completed cycle product on +`Fin n`**: the canonical form of the splitting for the shape-level +consumers. -/ +theorem cycleFun_add_split {n : ℕ} (t t' : ℕ → ℂ) + (π : Equiv.Perm (Fin n)) : + cycleFun (fun c => t c + t' c) π = + ∑ s ∈ Finset.univ.filter + (fun s : Finset (Fin n) => ∀ x ∈ s, π x ∈ s), + cycleFunG t (permRestrict π s) * + cycleFunG t' (permRestrict π sᶜ) := by + rw [← cycleFunG_fin, cycleFunG_add_split] + congr 1 + ext s + simp only [Finset.mem_filter] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayCalculus.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayCalculus.lean new file mode 100644 index 0000000000..3249bd905a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayCalculus.lean @@ -0,0 +1,340 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DayType + +/-! +# The corepresentable calculus of Day convolution on `Type` + +Over a small monoidal category `D`, the Day-convolution monoidal +structure on `D ⊛⥤ Type v` set up in `RS.Classical.Deligne.DayType` +interacts with corepresentables in the classical way. This file +records: + +* `RS.dayCoyonedaIso`: the Day tensor of the corepresentable functors + at `a` and `b` is the corepresentable functor at `a ⊗ b` (the + co-Yoneda computation for Day convolution); +* `RS.dayUnitIso`: the Day unit is the corepresentable functor at + `𝟙_ D`; +* preservation of all `v`-small colimits by `tensorLeft F` and + `tensorRight F` on `D ⊛⥤ Type v`, for every `F`. + +The two isomorphisms follow from uniqueness of corepresenting objects: +both sides corepresent evaluation of the underlying functor at the +relevant object of `D`. The preservation instances are obtained by +writing Day tensoring, on underlying functors, as an external-product +functor followed by the left Kan extension functor along `tensor D`; +the former preserves colimits pointwise because tensoring in `Type v` +does, and the latter is a left adjoint. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory MonoidalCategory.DayFunctor Limits +open scoped MonoidalCategory.ExternalProduct + +universe v + +noncomputable section + +variable {D : Type v} + +/-- Evaluation at `d` of the underlying functor, as a `Type`-valued +functor on `D ⊛⥤ Type v`. Every corepresentability statement in this +file corepresents a functor of this shape. -/ +def dayEvaluation [SmallCategory D] [MonoidalCategory D] + (d : D) : (D ⊛⥤ Type v) ⥤ Type v := + (equiv D (Type v)).functor ⋙ (evaluation D (Type v)).obj d + +/-- The corepresentable Day functor at `c` corepresents evaluation at +`c`: the Yoneda lemma, read through the `DayFunctor` synonym. -/ +def coyonedaDayCorepresentableBy [SmallCategory D] [MonoidalCategory D] + (c : D) : + (dayEvaluation c).CorepresentableBy + (DayFunctor.mk (coyoneda.obj (Opposite.op c))) where + homEquiv {F} := + { toFun f := coyonedaEquiv (X := c) (F := F.functor) f.natTrans + invFun x := .mk (coyonedaEquiv.symm x) + left_inv f := by + ext1 + exact coyonedaEquiv.symm_apply_apply f.natTrans + right_inv x := by + exact (coyonedaEquiv (X := c) (F := F.functor)).apply_symm_apply x } + homEquiv_comp g f := by + have h : coyonedaEquiv ((f ≫ g).natTrans) = + g.natTrans.app c (coyonedaEquiv f.natTrans) := by + rw [comp_natTrans, coyonedaEquiv_comp] + exact h + +/-- The Day tensor of the corepresentables at `a` and `b` corepresents +evaluation at `a ⊗ b`: maps out of it are transformations out of the +external product of the two corepresentables, which is definitionally +the corepresentable of the product category at `(a, b)`, so the Yoneda +lemma evaluates. This is the co-Yoneda computation for Day +convolution. -/ +def dayCoyonedaCorepresentableBy [SmallCategory D] [MonoidalCategory D] + (a b : D) : + (dayEvaluation (a ⊗ b)).CorepresentableBy + (DayFunctor.mk (coyoneda.obj (Opposite.op a)) ⊗ + DayFunctor.mk (coyoneda.obj (Opposite.op b))) where + homEquiv {F} := + ({ toFun := Hom.natTrans + invFun := .mk + left_inv := fun _ => rfl + right_inv := fun _ => rfl } : + (DayFunctor.mk (coyoneda.obj (Opposite.op a)) ⊗ + DayFunctor.mk (coyoneda.obj (Opposite.op b)) ⟶ F) ≃ + ((DayFunctor.mk (coyoneda.obj (Opposite.op a)) ⊗ + DayFunctor.mk (coyoneda.obj (Opposite.op b))).functor ⟶ + F.functor)).trans <| + (Functor.homEquivOfIsLeftKanExtension _ + (η (DayFunctor.mk (coyoneda.obj (Opposite.op a))) + (DayFunctor.mk (coyoneda.obj (Opposite.op b)))) + F.functor).trans + (coyonedaEquiv (C := D × D) (X := ((a, b) : D × D)) + (F := tensor D ⋙ F.functor)) + homEquiv_comp {F F'} g f := by + change coyonedaEquiv (C := D × D) (X := ((a, b) : D × D)) + (F := tensor D ⋙ F'.functor) + (η (DayFunctor.mk (coyoneda.obj (Opposite.op a))) + (DayFunctor.mk (coyoneda.obj (Opposite.op b))) ≫ + Functor.whiskerLeft (tensor D) (f ≫ g).natTrans) = _ + erw [comp_natTrans, Functor.whiskerLeft_comp, ← Category.assoc, + coyonedaEquiv_comp] + +/-- Day convolution of corepresentables: the Day tensor of the +corepresentable functors at `a` and `b` is the corepresentable functor +at `a ⊗ b`. -/ +def dayCoyonedaIso [SmallCategory D] [MonoidalCategory D] + (a b : D) : + DayFunctor.mk (coyoneda.obj (Opposite.op a)) ⊗ + DayFunctor.mk (coyoneda.obj (Opposite.op b)) ≅ + DayFunctor.mk (coyoneda.obj (Opposite.op (a ⊗ b))) := + (dayCoyonedaCorepresentableBy a b).uniqueUpToIso + (coyonedaDayCorepresentableBy (a ⊗ b)) + +/-- The Day unit corepresents evaluation at `𝟙_ D`: a map out of it is +determined by an element of `F.functor.obj (𝟙_ D)`, via the universal +property of the unit as a left Kan extension along +`fromPUnit (𝟙_ D)`. -/ +def dayUnitCorepresentableBy [SmallCategory D] [MonoidalCategory D] : + (dayEvaluation (𝟙_ D)).CorepresentableBy (𝟙_ (D ⊛⥤ Type v)) where + homEquiv {F} := + { toFun f := f.natTrans.app (𝟙_ D) (ν D (Type v) PUnit.unit) + invFun x := unitDesc (TypeCat.ofHom fun _ => x) + left_inv f := by + refine unit_hom_ext ?_ + rw [ν_comp_unitDesc] + refine ConcreteCategory.hom_ext _ _ fun u => ?_ + cases u + rfl + right_inv x := ConcreteCategory.congr_hom + (ν_comp_unitDesc (TypeCat.ofHom fun _ => x)) PUnit.unit } + homEquiv_comp g f := rfl + +variable (D) in +/-- The Day unit is the corepresentable functor at the monoidal unit of +`D`. -/ +def dayUnitIso [SmallCategory D] [MonoidalCategory D] : + 𝟙_ (MonoidalCategory.DayFunctor D (Type v)) ≅ + DayFunctor.mk (coyoneda.obj (Opposite.op (𝟙_ D))) := + dayUnitCorepresentableBy.uniqueUpToIso + (coyonedaDayCorepresentableBy (𝟙_ D)) + +section Preservation + +attribute [local instance] dayConv + +/-- Fixing the left factor of the external product gives a functor in +the right factor. -/ +def externalLeftFunctor [SmallCategory D] + (K : D ⥤ Type v) : + (D ⥤ Type v) ⥤ D × D ⥤ Type v := + Prod.sectR K (D ⥤ Type v) ⋙ externalProductBifunctor D D (Type v) + +/-- Fixing the right factor of the external product gives a functor in +the left factor. -/ +def externalRightFunctor [SmallCategory D] + (K : D ⥤ Type v) : + (D ⥤ Type v) ⥤ D × D ⥤ Type v := + Prod.sectL (D ⥤ Type v) K ⋙ externalProductBifunctor D D (Type v) + +/-- Pointwise, the external product with a fixed left factor is +tensoring on the left in `Type v`. -/ +def externalLeftFunctorEvaluationIso [SmallCategory D] + (K : D ⥤ Type v) (p : D × D) : + (evaluation D (Type v)).obj p.2 ⋙ tensorLeft (K.obj p.1) ≅ + externalLeftFunctor K ⋙ (evaluation (D × D) (Type v)).obj p := + NatIso.ofComponents (fun G => Iso.refl _) (by + intro G G' g + dsimp [externalLeftFunctor, Prod.sectR] + exact (Category.comp_id _).trans (Category.id_comp _).symm) + +/-- Pointwise, the external product with a fixed right factor is +tensoring on the right in `Type v`. -/ +def externalRightFunctorEvaluationIso [SmallCategory D] + (K : D ⥤ Type v) (p : D × D) : + (evaluation D (Type v)).obj p.1 ⋙ tensorRight (K.obj p.2) ≅ + externalRightFunctor K ⋙ (evaluation (D × D) (Type v)).obj p := + NatIso.ofComponents (fun G => Iso.refl _) (by + intro G G' g + dsimp [externalRightFunctor, Prod.sectL] + exact (Category.comp_id _).trans (Category.id_comp _).symm) + +/-- The external product with a fixed left factor preserves colimits in +the right factor. -/ +instance externalLeftFunctor_preservesColimits [SmallCategory D] + (K : D ⥤ Type v) : + PreservesColimitsOfSize.{v, v} (externalLeftFunctor K) where + preservesColimitsOfShape {J} _ := + preservesColimitsOfShape_of_evaluation _ J fun p => + preservesColimitsOfShape_of_natIso + (externalLeftFunctorEvaluationIso K p) + +/-- The external product with a fixed right factor preserves colimits +in the left factor. -/ +instance externalRightFunctor_preservesColimits [SmallCategory D] + (K : D ⥤ Type v) : + PreservesColimitsOfSize.{v, v} (externalRightFunctor K) where + preservesColimitsOfShape {J} _ := + preservesColimitsOfShape_of_evaluation _ J fun p => + preservesColimitsOfShape_of_natIso + (externalRightFunctorEvaluationIso K p) + +/-- The Day tensor, on underlying functors, is the left Kan extension +of the external product along `tensor D`. -/ +@[simps] +def tensorObjLanIso [SmallCategory D] [MonoidalCategory D] + (F G : D ⊛⥤ Type v) : + (F ⊗ G).functor ≅ (tensor D).lan.obj (F.functor ⊠ G.functor) where + hom := Functor.descOfIsLeftKanExtension _ (η F G) _ + ((tensor D).lanUnit.app (F.functor ⊠ G.functor)) + inv := Functor.descOfIsLeftKanExtension _ + ((tensor D).lanUnit.app (F.functor ⊠ G.functor)) _ (η F G) + hom_inv_id := Functor.hom_ext_of_isLeftKanExtension _ (η F G) _ _ + (by simp) + inv_hom_id := Functor.hom_ext_of_isLeftKanExtension _ + ((tensor D).lanUnit.app (F.functor ⊠ G.functor)) _ _ (by simp) + +open scoped CategoryTheory.Prod in +/-- Naturality in the right variable of `RS.tensorObjLanIso`. -/ +lemma whiskerLeft_natTrans_tensorObjLanIso_hom + [SmallCategory D] [MonoidalCategory D] + (F : D ⊛⥤ Type v) + {G G' : D ⊛⥤ Type v} (g : G ⟶ G') : + (F ◁ g).natTrans ≫ (tensorObjLanIso F G').hom = + (tensorObjLanIso F G).hom ≫ (tensor D).lan.map + ((externalProductBifunctor D D (Type v)).map + (𝟙 F.functor ×ₘ g.natTrans)) := by + refine Functor.hom_ext_of_isLeftKanExtension _ (η F G) _ _ ?_ + have h₁ : η F G ≫ Functor.whiskerLeft (tensor D) (F ◁ g).natTrans = + (externalProductBifunctor D D (Type v)).map + (𝟙 F.functor ×ₘ g.natTrans) ≫ η F G' := by + rw [natTrans_whiskerLeft] + exact Functor.descOfIsLeftKanExtension_fac _ _ _ _ + have h₂ := (tensor D).lanUnit.naturality + ((externalProductBifunctor D D (Type v)).map + (𝟙 F.functor ×ₘ g.natTrans)) + simp only [Functor.id_map, Functor.comp_map, + Functor.whiskeringLeft_obj_map] at h₂ + rw [Functor.whiskerLeft_comp, Functor.whiskerLeft_comp, + ← Category.assoc, h₁, Category.assoc, + tensorObjLanIso_hom, tensorObjLanIso_hom, + Functor.descOfIsLeftKanExtension_fac, + Functor.descOfIsLeftKanExtension_fac_assoc] + exact h₂ + +open scoped CategoryTheory.Prod in +/-- Naturality in the left variable of `RS.tensorObjLanIso`. -/ +lemma whiskerRight_natTrans_tensorObjLanIso_hom + [SmallCategory D] [MonoidalCategory D] + (F : D ⊛⥤ Type v) + {G G' : D ⊛⥤ Type v} (g : G ⟶ G') : + (g ▷ F).natTrans ≫ (tensorObjLanIso G' F).hom = + (tensorObjLanIso G F).hom ≫ (tensor D).lan.map + ((externalProductBifunctor D D (Type v)).map + (g.natTrans ×ₘ 𝟙 F.functor)) := by + refine Functor.hom_ext_of_isLeftKanExtension _ (η G F) _ _ ?_ + have h₁ : η G F ≫ Functor.whiskerLeft (tensor D) (g ▷ F).natTrans = + (externalProductBifunctor D D (Type v)).map + (g.natTrans ×ₘ 𝟙 F.functor) ≫ η G' F := by + rw [natTrans_whiskerRight] + exact Functor.descOfIsLeftKanExtension_fac _ _ _ _ + have h₂ := (tensor D).lanUnit.naturality + ((externalProductBifunctor D D (Type v)).map + (g.natTrans ×ₘ 𝟙 F.functor)) + simp only [Functor.id_map, Functor.comp_map, + Functor.whiskeringLeft_obj_map] at h₂ + rw [Functor.whiskerLeft_comp, Functor.whiskerLeft_comp, + ← Category.assoc, h₁, Category.assoc, + tensorObjLanIso_hom, tensorObjLanIso_hom, + Functor.descOfIsLeftKanExtension_fac, + Functor.descOfIsLeftKanExtension_fac_assoc] + exact h₂ + +/-- Day tensoring on the left, transported to the plain functor +category, is the external product followed by left Kan extension along +`tensor D`. -/ +def tensorLeftCompIso [SmallCategory D] [MonoidalCategory D] + (F : D ⊛⥤ Type v) : + tensorLeft F ⋙ (equiv D (Type v)).functor ≅ + (equiv D (Type v)).functor ⋙ + externalLeftFunctor F.functor ⋙ (tensor D).lan := + NatIso.ofComponents (fun G => tensorObjLanIso F G) + (fun g => whiskerLeft_natTrans_tensorObjLanIso_hom F g) + +/-- Day tensoring on the right, transported to the plain functor +category, is the external product followed by left Kan extension along +`tensor D`. -/ +def tensorRightCompIso [SmallCategory D] [MonoidalCategory D] + (F : D ⊛⥤ Type v) : + tensorRight F ⋙ (equiv D (Type v)).functor ≅ + (equiv D (Type v)).functor ⋙ + externalRightFunctor F.functor ⋙ (tensor D).lan := + NatIso.ofComponents (fun G => tensorObjLanIso G F) + (fun g => whiskerRight_natTrans_tensorObjLanIso_hom F g) + +/-- Day tensoring on the left preserves `v`-small colimits: through +`RS.tensorLeftCompIso` it is, up to the tautological equivalence, an +external product followed by a left Kan extension, and both preserve +colimits. -/ +noncomputable instance [SmallCategory D] [MonoidalCategory D] + (F : MonoidalCategory.DayFunctor D (Type v)) : + Limits.PreservesColimitsOfSize.{v, v} (tensorLeft F) := by + have : PreservesColimitsOfSize.{v, v} + ((tensor D).lan (H := Type v)) := + ((tensor D).lanAdjunction (Type v)).leftAdjoint_preservesColimits + have : PreservesColimitsOfSize.{v, v} + (tensorLeft F ⋙ (equiv D (Type v)).functor) := + preservesColimits_of_natIso (tensorLeftCompIso F).symm + exact preservesColimits_of_reflects_of_preserves _ + (equiv D (Type v)).functor + +/-- Day tensoring on the right preserves `v`-small colimits: through +`RS.tensorRightCompIso` it is, up to the tautological equivalence, an +external product followed by a left Kan extension, and both preserve +colimits. -/ +noncomputable instance [SmallCategory D] [MonoidalCategory D] + (F : MonoidalCategory.DayFunctor D (Type v)) : + Limits.PreservesColimitsOfSize.{v, v} (tensorRight F) := by + have : PreservesColimitsOfSize.{v, v} + ((tensor D).lan (H := Type v)) := + ((tensor D).lanAdjunction (Type v)).leftAdjoint_preservesColimits + have : PreservesColimitsOfSize.{v, v} + (tensorRight F ⋙ (equiv D (Type v)).functor) := + preservesColimits_of_natIso (tensorRightCompIso F).symm + exact preservesColimits_of_reflects_of_preserves _ + (equiv D (Type v)).functor + +end Preservation + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayType.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayType.lean new file mode 100644 index 0000000000..06c4a8ddd7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayType.lean @@ -0,0 +1,386 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Day convolution on `Type`-valued functor categories + +Mathlib equips the type synonym `C ⊛⥤ V` (`MonoidalCategory.DayFunctor`) +with the Day-convolution monoidal structure, subject to instance +hypotheses: existence of the relevant pointwise left Kan extensions and +preservation of colimits of the relevant costructured-arrow shapes by +`tensorLeft`/`tensorRight` in `V`. For `V := Type v` and `C` a small +monoidal category all of these hold via instances that Mathlib already +provides (`Type v` is monoidal closed and braided, so both tensoring +functors are left adjoints and preserve all colimits, and `Type v` has +all small colimits); the imports of `Closed.Types` and `Closed.Braided` +above are exactly what makes them synthesise. + +What Mathlib does not provide is a braided (or symmetric) structure +on `C ⊛⥤ V`: `Mathlib.CategoryTheory.Monoidal.DayConvolution.Braided` +constructs the braiding and proves the hexagons at the level of +individual `DayConvolution` structures on plain functors, but never +assembles them into a `BraidedCategory (C ⊛⥤ V)` instance. This file +performs that assembly, at the same generality as Mathlib's +`MonoidalCategory (C ⊛⥤ V)` instance, and records the acceptance tests +for `V := Type v` at the bottom. + +The Mathlib imports above are deliberate exceptions to the +`RS.Common.MathlibDeps` funnel: the Day-convolution modules are not +reachable from it. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory MonoidalCategory.DayFunctor Limits +open scoped MonoidalCategory.ExternalProduct +open scoped MonoidalCategory.DayConvolution + +universe v v₁ v₂ u₁ u₂ + +noncomputable section + +variable {C : Type u₁} + +/-- The underlying functor of a tensor product in `C ⊛⥤ V` is a Day +convolution of the underlying functors. Local instance: Mathlib advises +against registering `DayConvolution` instances globally. -/ +local instance dayConv + [Category.{v₁} C] {V : Type u₂} [Category.{v₂} V] [MonoidalCategory C] + [MonoidalCategory V] + [∀ (F G : C ⥤ V), (tensor C).HasPointwiseLeftKanExtension (F ⊠ G)] + [(Functor.fromPUnit.{0} <| 𝟙_ C).HasPointwiseLeftKanExtension + (Functor.fromPUnit.{0} <| 𝟙_ V)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow (tensor + C) d) (tensorLeft v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow (tensor + C) d) (tensorRight v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow + (Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorLeft v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow + (Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorRight v)] + [∀ (v : V) (d : C × C), PreservesColimitsOfShape (CostructuredArrow ((𝟭 + C).prod <| Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorRight v)] + [∀ (v : V) (d : C × C), PreservesColimitsOfShape (CostructuredArrow + ((tensor C).prod (𝟭 C)) d) (tensorRight v)] + (F G : C ⊛⥤ V) : + DayConvolution F.functor G.functor := + LawfulDayConvolutionMonoidalCategoryStruct.convolution C V (C ⊛⥤ V) F G + +/-- Right-nested triple Day convolutions, phrased so that instance search +finds them behind the `⊛` notation. -/ +local instance dayConv₂ + [Category.{v₁} C] {V : Type u₂} [Category.{v₂} V] [MonoidalCategory C] + [MonoidalCategory V] + [∀ (F G : C ⥤ V), (tensor C).HasPointwiseLeftKanExtension (F ⊠ G)] + [(Functor.fromPUnit.{0} <| 𝟙_ C).HasPointwiseLeftKanExtension + (Functor.fromPUnit.{0} <| 𝟙_ V)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow (tensor + C) d) (tensorLeft v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow (tensor + C) d) (tensorRight v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow + (Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorLeft v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow + (Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorRight v)] + [∀ (v : V) (d : C × C), PreservesColimitsOfShape (CostructuredArrow ((𝟭 + C).prod <| Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorRight v)] + [∀ (v : V) (d : C × C), PreservesColimitsOfShape (CostructuredArrow + ((tensor C).prod (𝟭 C)) d) (tensorRight v)] + (F G H : C ⊛⥤ V) : + DayConvolution F.functor (G.functor ⊛ H.functor) := + dayConv F (G ⊗ H) + +/-- Left-nested triple Day convolutions, phrased so that instance search +finds them behind the `⊛` notation. -/ +local instance dayConv₂' + [Category.{v₁} C] {V : Type u₂} [Category.{v₂} V] [MonoidalCategory C] + [MonoidalCategory V] + [∀ (F G : C ⥤ V), (tensor C).HasPointwiseLeftKanExtension (F ⊠ G)] + [(Functor.fromPUnit.{0} <| 𝟙_ C).HasPointwiseLeftKanExtension + (Functor.fromPUnit.{0} <| 𝟙_ V)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow (tensor + C) d) (tensorLeft v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow (tensor + C) d) (tensorRight v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow + (Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorLeft v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow + (Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorRight v)] + [∀ (v : V) (d : C × C), PreservesColimitsOfShape (CostructuredArrow ((𝟭 + C).prod <| Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorRight v)] + [∀ (v : V) (d : C × C), PreservesColimitsOfShape (CostructuredArrow + ((tensor C).prod (𝟭 C)) d) (tensorRight v)] + (F G H : C ⊛⥤ V) : + DayConvolution (F.functor ⊛ G.functor) H.functor := + dayConv (F ⊗ G) H + +/-- The underlying natural transformation of a tensor product of +morphisms of `C ⊛⥤ V` is the induced morphism of Day convolutions. -/ +lemma natTrans_tensorHom + [Category.{v₁} C] {V : Type u₂} [Category.{v₂} V] [MonoidalCategory C] + [MonoidalCategory V] + [∀ (F G : C ⥤ V), (tensor C).HasPointwiseLeftKanExtension (F ⊠ G)] + [(Functor.fromPUnit.{0} <| 𝟙_ C).HasPointwiseLeftKanExtension + (Functor.fromPUnit.{0} <| 𝟙_ V)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow (tensor + C) d) (tensorLeft v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow (tensor + C) d) (tensorRight v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow + (Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorLeft v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow + (Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorRight v)] + [∀ (v : V) (d : C × C), PreservesColimitsOfShape (CostructuredArrow ((𝟭 + C).prod <| Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorRight v)] + [∀ (v : V) (d : C × C), PreservesColimitsOfShape (CostructuredArrow + ((tensor C).prod (𝟭 C)) d) (tensorRight v)] + {F F' G G' : C ⊛⥤ V} (f : F ⟶ F') (g : G ⟶ G') : + (f ⊗ₘ g).natTrans = DayConvolution.map f.natTrans g.natTrans := + LawfulDayConvolutionMonoidalCategoryStruct.ι_map_tensorHom_hom_eq_tensorHom + (C := C) (V := V) (D := C ⊛⥤ V) f g + +/-- Left whiskering in `C ⊛⥤ V`, read off on underlying natural +transformations. -/ +lemma natTrans_whiskerLeft + [Category.{v₁} C] {V : Type u₂} [Category.{v₂} V] [MonoidalCategory C] + [MonoidalCategory V] + [∀ (F G : C ⥤ V), (tensor C).HasPointwiseLeftKanExtension (F ⊠ G)] + [(Functor.fromPUnit.{0} <| 𝟙_ C).HasPointwiseLeftKanExtension + (Functor.fromPUnit.{0} <| 𝟙_ V)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow (tensor + C) d) (tensorLeft v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow (tensor + C) d) (tensorRight v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow + (Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorLeft v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow + (Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorRight v)] + [∀ (v : V) (d : C × C), PreservesColimitsOfShape (CostructuredArrow ((𝟭 + C).prod <| Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorRight v)] + [∀ (v : V) (d : C × C), PreservesColimitsOfShape (CostructuredArrow + ((tensor C).prod (𝟭 C)) d) (tensorRight v)] + (F : C ⊛⥤ V) {G H : C ⊛⥤ V} (g : G ⟶ H) : + (F ◁ g).natTrans = DayConvolution.map (𝟙 F.functor) g.natTrans := by + rw [← MonoidalCategory.id_tensorHom, natTrans_tensorHom] + rfl + +/-- Right whiskering in `C ⊛⥤ V`, read off on underlying natural +transformations. -/ +lemma natTrans_whiskerRight + [Category.{v₁} C] {V : Type u₂} [Category.{v₂} V] [MonoidalCategory C] + [MonoidalCategory V] + [∀ (F G : C ⥤ V), (tensor C).HasPointwiseLeftKanExtension (F ⊠ G)] + [(Functor.fromPUnit.{0} <| 𝟙_ C).HasPointwiseLeftKanExtension + (Functor.fromPUnit.{0} <| 𝟙_ V)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow (tensor + C) d) (tensorLeft v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow (tensor + C) d) (tensorRight v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow + (Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorLeft v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow + (Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorRight v)] + [∀ (v : V) (d : C × C), PreservesColimitsOfShape (CostructuredArrow ((𝟭 + C).prod <| Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorRight v)] + [∀ (v : V) (d : C × C), PreservesColimitsOfShape (CostructuredArrow + ((tensor C).prod (𝟭 C)) d) (tensorRight v)] + {F G : C ⊛⥤ V} (f : F ⟶ G) (H : C ⊛⥤ V) : + (f ▷ H).natTrans = DayConvolution.map f.natTrans (𝟙 H.functor) := by + rw [← MonoidalCategory.tensorHom_id, natTrans_tensorHom] + rfl + +open LawfulDayConvolutionMonoidalCategoryStruct in +/-- The associator of `C ⊛⥤ V`, read off on underlying natural +transformations. -/ +lemma natTrans_associator + [Category.{v₁} C] {V : Type u₂} [Category.{v₂} V] [MonoidalCategory C] + [MonoidalCategory V] + [∀ (F G : C ⥤ V), (tensor C).HasPointwiseLeftKanExtension (F ⊠ G)] + [(Functor.fromPUnit.{0} <| 𝟙_ C).HasPointwiseLeftKanExtension + (Functor.fromPUnit.{0} <| 𝟙_ V)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow (tensor + C) d) (tensorLeft v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow (tensor + C) d) (tensorRight v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow + (Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorLeft v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow + (Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorRight v)] + [∀ (v : V) (d : C × C), PreservesColimitsOfShape (CostructuredArrow ((𝟭 + C).prod <| Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorRight v)] + [∀ (v : V) (d : C × C), PreservesColimitsOfShape (CostructuredArrow + ((tensor C).prod (𝟭 C)) d) (tensorRight v)] + (F G H : C ⊛⥤ V) : + (α_ F G H).hom.natTrans = + (DayConvolution.associator F.functor G.functor H.functor).hom := + ι_map_associator_hom_eq_associator_hom + (C := C) (V := V) (D := C ⊛⥤ V) F G H + +/-- Inverse form of `RS.natTrans_associator`. -/ +lemma natTrans_associator_inv + [Category.{v₁} C] {V : Type u₂} [Category.{v₂} V] [MonoidalCategory C] + [MonoidalCategory V] + [∀ (F G : C ⥤ V), (tensor C).HasPointwiseLeftKanExtension (F ⊠ G)] + [(Functor.fromPUnit.{0} <| 𝟙_ C).HasPointwiseLeftKanExtension + (Functor.fromPUnit.{0} <| 𝟙_ V)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow (tensor + C) d) (tensorLeft v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow (tensor + C) d) (tensorRight v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow + (Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorLeft v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow + (Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorRight v)] + [∀ (v : V) (d : C × C), PreservesColimitsOfShape (CostructuredArrow ((𝟭 + C).prod <| Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorRight v)] + [∀ (v : V) (d : C × C), PreservesColimitsOfShape (CostructuredArrow + ((tensor C).prod (𝟭 C)) d) (tensorRight v)] + (F G H : C ⊛⥤ V) : + (α_ F G H).inv.natTrans = + (DayConvolution.associator F.functor G.functor H.functor).inv := by + refine (Iso.inv_ext ?_).symm + rw [← natTrans_associator, ← comp_natTrans, Iso.hom_inv_id, id_natTrans] + +section Braided + +/-- The braiding on `C ⊛⥤ V`, inherited from the Day-convolution +braiding of the underlying functors. -/ +def dayFunctorBraiding + [Category.{v₁} C] {V : Type u₂} [Category.{v₂} V] [MonoidalCategory C] + [MonoidalCategory V] + [∀ (F G : C ⥤ V), (tensor C).HasPointwiseLeftKanExtension (F ⊠ G)] + [(Functor.fromPUnit.{0} <| 𝟙_ C).HasPointwiseLeftKanExtension + (Functor.fromPUnit.{0} <| 𝟙_ V)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow (tensor + C) d) (tensorLeft v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow (tensor + C) d) (tensorRight v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow + (Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorLeft v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow + (Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorRight v)] + [∀ (v : V) (d : C × C), PreservesColimitsOfShape (CostructuredArrow ((𝟭 + C).prod <| Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorRight v)] + [∀ (v : V) (d : C × C), PreservesColimitsOfShape (CostructuredArrow + ((tensor C).prod (𝟭 C)) d) (tensorRight v)] [BraidedCategory C] + [BraidedCategory V] + (F G : C ⊛⥤ V) : F ⊗ G ≅ G ⊗ F where + hom := .mk (DayConvolution.braiding F.functor G.functor).hom + inv := .mk (DayConvolution.braiding F.functor G.functor).inv + hom_inv_id := by + ext1 + exact (DayConvolution.braiding F.functor G.functor).hom_inv_id + inv_hom_id := by + ext1 + exact (DayConvolution.braiding F.functor G.functor).inv_hom_id + +/-- The Day-convolution monoidal structure on `C ⊛⥤ V` is braided when +`C` and `V` are. This discharges, for the type synonym, what +`Mathlib.CategoryTheory.Monoidal.DayConvolution.Braided` proves at the +level of individual convolutions. -/ +instance dayFunctorBraided + [Category.{v₁} C] {V : Type u₂} [Category.{v₂} V] [MonoidalCategory C] + [MonoidalCategory V] + [∀ (F G : C ⥤ V), (tensor C).HasPointwiseLeftKanExtension (F ⊠ G)] + [(Functor.fromPUnit.{0} <| 𝟙_ C).HasPointwiseLeftKanExtension + (Functor.fromPUnit.{0} <| 𝟙_ V)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow (tensor + C) d) (tensorLeft v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow (tensor + C) d) (tensorRight v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow + (Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorLeft v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow + (Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorRight v)] + [∀ (v : V) (d : C × C), PreservesColimitsOfShape (CostructuredArrow ((𝟭 + C).prod <| Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorRight v)] + [∀ (v : V) (d : C × C), PreservesColimitsOfShape (CostructuredArrow + ((tensor C).prod (𝟭 C)) d) (tensorRight v)] [BraidedCategory C] + [BraidedCategory V] : BraidedCategory (C ⊛⥤ V) where + braiding := dayFunctorBraiding + braiding_naturality_right F G H f := by + ext1 + simp only [comp_natTrans, natTrans_whiskerLeft, natTrans_whiskerRight] + exact DayConvolution.braiding_naturality_right F.functor f.natTrans + braiding_naturality_left f H := by + ext1 + simp only [comp_natTrans, natTrans_whiskerLeft, natTrans_whiskerRight] + exact DayConvolution.braiding_naturality_left f.natTrans H.functor + hexagon_forward F G H := by + ext1 + simp only [comp_natTrans, natTrans_associator, natTrans_whiskerLeft, + natTrans_whiskerRight] + exact DayConvolution.hexagon_forward F.functor G.functor H.functor + hexagon_reverse F G H := by + ext1 + simp only [comp_natTrans, natTrans_associator_inv, natTrans_whiskerLeft, + natTrans_whiskerRight] + exact DayConvolution.hexagon_reverse F.functor G.functor H.functor + +end Braided + +section Symmetric + +/-- The Day-convolution monoidal structure on `C ⊛⥤ V` is symmetric when +`C` and `V` are, via `DayConvolution.symmetry`. -/ +instance dayFunctorSymmetric + [Category.{v₁} C] {V : Type u₂} [Category.{v₂} V] [MonoidalCategory C] + [MonoidalCategory V] + [∀ (F G : C ⥤ V), (tensor C).HasPointwiseLeftKanExtension (F ⊠ G)] + [(Functor.fromPUnit.{0} <| 𝟙_ C).HasPointwiseLeftKanExtension + (Functor.fromPUnit.{0} <| 𝟙_ V)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow (tensor + C) d) (tensorLeft v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow (tensor + C) d) (tensorRight v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow + (Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorLeft v)] + [∀ (v : V) (d : C), PreservesColimitsOfShape (CostructuredArrow + (Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorRight v)] + [∀ (v : V) (d : C × C), PreservesColimitsOfShape (CostructuredArrow ((𝟭 + C).prod <| Functor.fromPUnit.{0} <| 𝟙_ C) d) (tensorRight v)] + [∀ (v : V) (d : C × C), PreservesColimitsOfShape (CostructuredArrow + ((tensor C).prod (𝟭 C)) d) (tensorRight v)] [SymmetricCategory C] + [SymmetricCategory V] : SymmetricCategory (C ⊛⥤ V) where + toBraidedCategory := inferInstance + symmetry F G := by + ext1 + simp only [comp_natTrans, id_natTrans] + exact DayConvolution.symmetry F.functor G.functor + +end Symmetric + +end + +section AcceptanceTests + +/- The three target instances for `V := Type v`, `C` small monoidal. +`noncomputable` because the underlying Day-convolution data is chosen +by colimit machinery; instance *synthesis* is what is being tested. -/ + +noncomputable example (C : Type v) [SmallCategory C] [MonoidalCategory C] : + MonoidalCategory (MonoidalCategory.DayFunctor C (Type v)) := + inferInstance + +noncomputable example (C : Type v) [SmallCategory C] [MonoidalCategory C] + [BraidedCategory C] : + BraidedCategory (MonoidalCategory.DayFunctor C (Type v)) := + inferInstance + +noncomputable example (C : Type v) [SmallCategory C] [MonoidalCategory C] + [SymmetricCategory C] : + SymmetricCategory (MonoidalCategory.DayFunctor C (Type v)) := + inferInstance + +end AcceptanceTests + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DeligneAssembly.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DeligneAssembly.lean new file mode 100644 index 0000000000..d18a4e5ef6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DeligneAssembly.lean @@ -0,0 +1,327 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledSplit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreLinear +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal + +/-! +# Deligne's theorem assembled + +`RS.deligne_theorem` proves `RS.DeligneTheoremStatement` +(*Catégories tensorielles*, Théorème 0.6). It is +`RS.deligne_theorem_of_braided`, which assembles the statement from +`RS.BraidedFibreHypothesis` — that the fibre functor +`RS.deligneFibre` of a splitting algebra at a complex point is +symmetric monoidal — applied to `RS.braidedFibreHypothesis`, which +discharges it from `RS.nonempty_braided_deligneFibre`. + +The route is not Deligne's. His §4 obtains the passage from an +arbitrary nonzero algebra of scalars to ℂ by descent along a +faithfully flat `Isom⊗` torsor. Here the tensor generator alone is +split and one passes to a quotient by a maximal ideal: over a simple +algebra the regular module and its twist by the odd line are simple +objects of the module category, so a free mixed module is semisimple +of finite length, the objects the algebra splits are closed under +subquotients, and the scalars are a field of countable dimension over +ℂ, hence ℂ. This is the pattern of Coulembier, *Tannakian categories +in positive characteristic*, Duke Math. J. **169** (2020), Lemma +3.3.2(ii), with Lemmas 1.2.10 and 1.5.2. + +* `RS.deligneTheoremStatement_of_small` + ([SmallReduction.lean](SmallReduction.lean)) reduces the statement, + which quantifies over essentially small categories, to the case of + a genuinely small one. +* A tensor category need not contain an odd line, so the small + category is replaced by its ℤ/2-graded doubling, whose + ind-completion carries the odd line `RS.doubledIndOddLine` + ([Prop21General.lean](Prop21General.lean)). +* `RS.exists_splitting_simple_algebra_doubled` + ([DoubledSplit.lean](DoubledSplit.lean)) produces the simple + commutative algebra of the ind-completion of the doubling that + splits every embedded object into a mixed sum of copies of the unit + and of the odd line, together with a complex point of its + Γ-algebra. +* Simplicity supplies the sections that exactness of the fibre + functor consumes. An embedded short exact sequence has an + epimorphic right-hand map, so the free-module functor sends it to + an epimorphism (`RS.epi_freeModMap`), and over a simple algebra + every epimorphism out of a free mixed module splits + (`RS.exists_section_of_simple`, + [SimpleSplit.lean](SimpleSplit.lean)). +* `RS.deligneFibreFunctorOfPoint` collects `RS.deligneFibre` and its + properties into a `RS.DeligneFibreFunctor`; the ℂ-linear clause is + `RS.superVectFunctor_linear` fed by `RS.fibreFun_linear` and + `RS.indOfFunctorLinear`. +* `RS.DeligneFibreFunctor.precompose` restricts the fibre functor of + the doubling along the even embedding, which is strong braided + monoidal, exact, faithful and ℂ-linear. + +One compatibility is needed for the last step. The even embedding is +ℂ-linear for the structure the doubling inherits componentwise from +its base, whereas the fibre construction runs at the structure induced +by the scalar unit, `RS.linearOfScalarUnit`. The two agree: +`RS.scalarSmul_scalarUnitEquiv` identifies the scalar action of a +scalar unit with the ambient action in a monoidally ℂ-linear category, +and `RS.evenEmbedLinear_scalarUnit` reads that off for the even +embedding. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +noncomputable section + +/-! ## The scalar action of a scalar unit is the ambient action -/ + +section ScalarBridge + +variable {D : Type u} + +/-- **The endomorphism attached to a scalar is the rescaled +identity**, when the scalar unit is the ambient action of ℂ on the +endomorphisms of the tensor unit: whiskering `c • 𝟙` onto `X` gives +`c • 𝟙` again because the tensor product is ℂ-bilinear, and the two +unitors then cancel. -/ +theorem scalarEnd_scalarUnitEquiv + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [CategoryTheory.Linear ℂ D] [MonoidalPreadditive D] [MonoidalLinear ℂ D] + (h : HasScalarUnit D) (c : ℂ) + (X : D) : scalarEnd (scalarUnitEquiv h) c X = c • 𝟙 X := by + have hs : scalarHom (scalarUnitEquiv h) c = c • 𝟙 (𝟙_ D) := rfl + change (λ_ X).inv ≫ (scalarHom (scalarUnitEquiv h) c ▷ X) ≫ + (λ_ X).hom = c • 𝟙 X + rw [hs, MonoidalLinear.smul_whiskerRight, id_whiskerRight, + CategoryTheory.Linear.smul_comp, CategoryTheory.Linear.comp_smul, + Category.id_comp, Iso.inv_hom_id] + +/-- **The ℂ-linear structure induced by the ambient scalar unit is the +ambient one.** In a monoidally ℂ-linear category the action of +`RS.linearOfScalarUnit (scalarUnitEquiv h)` on a hom-set is the given +action, so the two structures may be used interchangeably. -/ +theorem scalarSmul_scalarUnitEquiv + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [CategoryTheory.Linear ℂ D] [MonoidalPreadditive D] [MonoidalLinear ℂ D] + (h : HasScalarUnit D) {X Y : D} + (c : ℂ) (f : X ⟶ Y) : + scalarSmul (scalarUnitEquiv h) c f = c • f := by + rw [scalarSmul_eq, scalarEnd_scalarUnitEquiv, + CategoryTheory.Linear.smul_comp, Category.id_comp] + +end ScalarBridge + +/-! ## The even embedding at the scalar-unit structure -/ + +section EvenEmbedLinear + +variable {B : Type v} + +/-- The scalar action of `RS.doubledScalarUnit` on the doubling is the +action the doubling inherits componentwise from its base. -/ +theorem scalarSmul_doubledScalarUnit + [SmallCategory B] [Abelian B] [CategoryTheory.Linear ℂ B] + [MonoidalCategory B] [MonoidalPreadditive B] [MonoidalLinear ℂ B] + (hu : HasScalarUnit B) + {V W : Doubled B} (c : ℂ) (f : V ⟶ W) : + scalarSmul (doubledScalarUnit hu) c f = c • f := + scalarSmul_scalarUnitEquiv (hasScalarUnit_doubled hu) c f + +/-- The even embedding carries a rescaled morphism to the scalar-unit +rescaling of its image. -/ +theorem evenEmbed_map_smul_doubled + [SmallCategory B] [Abelian B] [CategoryTheory.Linear ℂ B] + [MonoidalCategory B] [MonoidalPreadditive B] [MonoidalLinear ℂ B] + (hu : HasScalarUnit B) (c : ℂ) + {V W : B} (f : V ⟶ W) : + (Doubled.evenEmbed : B ⥤ Doubled B).map (c • f) = + scalarSmul (doubledScalarUnit hu) c + ((Doubled.evenEmbed : B ⥤ Doubled B).map f) := by + rw [scalarSmul_doubledScalarUnit] + exact Functor.Linear.map_smul (R := ℂ) f c + +/-- **The even embedding is ℂ-linear for the scalar-unit structure** +of the doubling, the structure at which the fibre construction runs. +-/ +theorem evenEmbedLinear_scalarUnit + [SmallCategory B] [Abelian B] [CategoryTheory.Linear ℂ B] + [MonoidalCategory B] [MonoidalPreadditive B] [MonoidalLinear ℂ B] + (hu : HasScalarUnit B) : + letI := linearOfScalarUnit (doubledScalarUnit hu) + Functor.Linear ℂ (Doubled.evenEmbed : B ⥤ Doubled B) := + letI := linearOfScalarUnit (doubledScalarUnit hu) + ⟨fun f c => evenEmbed_map_smul_doubled hu c f⟩ + +end EvenEmbedLinear + +/-! ## The symmetry of the fibre functor -/ + +/-- **The fibre functor of a splitting algebra at a complex point is +symmetric monoidal.** The assembly below takes this clause of +Deligne's conclusion as a hypothesis, which +`RS.braidedFibreHypothesis` discharges from +`RS.nonempty_braided_deligneFibre`; the strong monoidal structure of +the composite is `RS.fibreRestrictMonoidal`, and the Koszul sign of +`RS.SuperVect` is the braiding it transports. -/ +def BraidedFibreHypothesis : Prop := + ∀ (C : Type v) [SmallCategory C] [MonoidalCategory C] + [SymmetricCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + [CategoryTheory.Linear ℂ (Ind C)] [MonoidalLinear ℂ (Ind C)] + (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] [IsCommMonObj 𝔸] + (hsp : SplitsOn L 𝔸 (indOf : C ⥤ Ind C)) + (pt : SuperPoint (gammaAlgebra (Ind C) L 𝔸)), + Nonempty (deligneFibre L 𝔸 hsp pt).Braided + +/-! ## The fibre functor of a splitting algebra, packaged -/ + +section GeneralFibre + +variable {C : Type v} + +/-- **The conclusion of Deligne's theorem for a category split by an +algebra with a complex point.** Every clause of +`RS.DeligneFibreFunctor` is available for `RS.deligneFibre`: it is +additive and ℂ-linear because the embedding, the fibre functor over +the algebra and base change all are; it is exact because the sections +make each embedded short exact sequence split after base change; and +it is faithful because the unit of the algebra is a monomorphism. +Symmetry is the hypothesis `hbraid`. -/ +def deligneFibreFunctorOfPoint + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] [CategoryTheory.Linear ℂ C] + [CategoryTheory.Linear ℂ (Ind C)] [MonoidalLinear ℂ (Ind C)] + [∀ Z : Ind C, (tensorRight Z).PreservesMonomorphisms] + [(indOf : C ⥤ Ind C).Additive] [Functor.Linear ℂ (indOf : C ⥤ Ind C)] + (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] [IsCommMonObj 𝔸] + (hmono : Mono η[𝔸]) + (hsp : SplitsOn L 𝔸 (indOf : C ⥤ Ind C)) + (hsec : ∀ T : CategoryTheory.ShortComplex C, T.ShortExact → + ∃ s : freeMod 𝔸 ((T.map (indOf : C ⥤ Ind C)).X₃) ⟶ + freeMod 𝔸 ((T.map (indOf : C ⥤ Ind C)).X₂), + s ≫ freeModMap 𝔸 ((T.map (indOf : C ⥤ Ind C)).g) = + 𝟙 (freeMod 𝔸 ((T.map (indOf : C ⥤ Ind C)).X₃))) + (pt : SuperPoint (gammaAlgebra (Ind C) L 𝔸)) + (hbraid : (deligneFibre L 𝔸 hsp pt).Braided) : + DeligneFibreFunctor C where + ω := deligneFibre L 𝔸 hsp pt + braided := hbraid + additive := deligneFibre_additive L 𝔸 hsp pt + linear := superVectFunctor_linear pt _ _ _ + faithful := deligneFibre_faithful L 𝔸 hmono hsp hsec pt + preservesFiniteLimits := + deligneFibre_preservesFiniteLimits L 𝔸 hsp hsec pt + preservesFiniteColimits := + deligneFibre_preservesFiniteColimits L 𝔸 hsp hsec pt + +end GeneralFibre + +/-! ## Deligne's theorem -/ + +section Assembly + +variable {B : Type v} + +attribute [local instance] Doubled.hasFiniteBiproducts + +/-- **Deligne's theorem for a small category.** The doubling of `B` +carries every hypothesis, and its ind-completion carries an odd line, +so the simple algebra `𝔹` that splits the embedding is available +together with a complex point of its Γ-algebra. Simplicity of `𝔹` +supplies the sections, the nonvanishing of its unit makes that unit a +monomorphism, and the resulting fibre functor of `Doubled B` restricts +along the even embedding to one of `B`. -/ +theorem exists_deligneFibreFunctor_small + [SmallCategory B] [Abelian B] [CategoryTheory.Linear ℂ B] + [MonoidalCategory B] [SymmetricCategory B] [MonoidalPreadditive B] + [MonoidalLinear ℂ B] [HasFiniteBiproducts B] [RigidCategory B] + (P : SchurPackage.{v}) + (P₀ : SchurPackage.{0}) (hbr : BraidedFibreHypothesis.{v}) + (hu : HasScalarUnit B) (X : B) (hgen : TensorGeneratedBy B X) + (hgrow : ModerateLengthGrowth B) : + Nonempty (DeligneFibreFunctor B) := by + let := linearOfScalarUnit (doubledScalarUnit hu) + let := monoidalLinearOfScalarUnitBraided (doubledScalarUnit hu) + let := linearOfScalarUnit (indScalarUnit (doubledScalarUnit hu)) + let := monoidalLinearOfScalarUnitBraided + (indScalarUnit (doubledScalarUnit hu)) + obtain ⟨𝔹, hmon, hcomm, hne, hsimple, hsp, ⟨pt⟩⟩ := + exists_splitting_simple_algebra_doubled P P₀ hu X hgen hgrow + let := hmon + let := hcomm + have hpm : ∀ Z : Ind (Doubled B), + (tensorRight Z).PreservesMonomorphisms := fun _ => inferInstance + have hmono : Mono η[𝔹] := + mono_unit_ind (simple_unit_of_hasScalarUnit + (hasScalarUnit_of_scalarUnit (doubledScalarUnit hu))) 𝔹 hne + have hsec : ∀ T : CategoryTheory.ShortComplex (Doubled B), + T.ShortExact → + ∃ s : freeMod 𝔹 ((T.map + (indOf : Doubled B ⥤ Ind (Doubled B))).X₃) ⟶ + freeMod 𝔹 ((T.map + (indOf : Doubled B ⥤ Ind (Doubled B))).X₂), + s ≫ freeModMap 𝔹 ((T.map + (indOf : Doubled B ⥤ Ind (Doubled B))).g) = + 𝟙 (freeMod 𝔹 ((T.map + (indOf : Doubled B ⥤ Ind (Doubled B))).X₃)) := by + intro T hT + have := (indOf_shortExact hT).epi_g + exact exists_section_of_simple 𝔹 doubledIndOddLine hsimple hne + ((T.map (indOf : Doubled B ⥤ Ind (Doubled B))).g) (hsp T.X₂) + (epi_freeModMap 𝔹 _ inferInstance) + let := indOf_additive (C := Doubled B) + let := indOfFunctorLinear (doubledScalarUnit hu) + let := evenEmbedLinear_scalarUnit hu + have hb := (hbr (Doubled B) doubledIndOddLine 𝔹 hsp pt).some + have hF : DeligneFibreFunctor (Doubled B) := + deligneFibreFunctorOfPoint doubledIndOddLine 𝔹 hmono hsp hsec pt hb + exact ⟨hF.precompose (Doubled.evenEmbed : B ⥤ Doubled B)⟩ + +/-- **Deligne's theorem** (*Catégories tensorielles*, Théorème 0.6), +conditional on the symmetry of the fibre functor: every essentially +small abelian ℂ-linear rigid symmetric monoidal category with +ℂ-bilinear tensor product, scalar unit endomorphisms, a finite tensor +generator and moderate growth of the lengths of its tensor powers +admits an exact faithful ℂ-linear symmetric monoidal fibre functor to +finite-dimensional super vector spaces. -/ +theorem deligne_theorem_of_braided (P : SchurPackage.{v}) + (P₀ : SchurPackage.{0}) (hbr : BraidedFibreHypothesis.{v}) : + DeligneTheoremStatement.{u, v} := by + refine deligneTheoremStatement_of_small ?_ + intro A _ _ _ _ _ _ _ _ _ hu hgen hgrow + obtain ⟨X, hX⟩ := hgen + exact exists_deligneFibreFunctor_small P P₀ hbr hu X hX hgrow + +end Assembly + +end + +/-- **The braided hypothesis is discharged**: the fibre functor of a +splitting algebra at a complex point is symmetric monoidal, because +the fibre functor over the algebra is and the base change at the +point is. -/ +theorem braidedFibreHypothesis : BraidedFibreHypothesis.{v} := + fun _ _ _ _ _ _ _ _ _ L 𝔸 _ _ hsp pt => + nonempty_braided_deligneFibre L 𝔸 hsp pt + +/-- **Deligne's theorem** (*Catégories tensorielles*, Théorème 0.6): +every essentially small abelian ℂ-linear rigid symmetric monoidal +category with ℂ-bilinear tensor product, scalar unit endomorphisms, a +finite tensor generator and moderate growth of the lengths of its +tensor powers admits an exact faithful ℂ-linear symmetric monoidal +fibre functor to finite-dimensional super vector spaces. -/ +theorem deligne_theorem : DeligneTheoremStatement.{u, v} := + deligne_theorem_of_braided schurPackage schurPackage + braidedFibreHypothesis + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DescentClose.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DescentClose.lean new file mode 100644 index 0000000000..8dac817357 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DescentClose.lean @@ -0,0 +1,72 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichZig +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowDescentClose +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TrichotomyClose + +/-! +# The power descent, unconditionally + +Over a zigzag datum the sandwich retract exists, so vanishing of +a relative tensor power descends to the module itself. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **Power vanishing descends to the module** (Deligne 2.9, +case (c), object half): over a duality datum with the zigzag +laws, a module whose `(k + 2)`-nd relative power vanishes is +zero. -/ +theorem isZero_of_isZero_modPow + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] + {M M' : Mod D A} + (d : ModDualityDatum A M M') (hz : ModZigzagDatum A d) + (k : ℕ) (h : IsZero (modPow A M.X (k + 2))) : + IsZero M.X := + isZero_of_sandwich_of_isZero_modPow A M M' + (sandwichIns A d) (sandwichCon A d) + (sandwichIns_sandwichCon A d hz) h + +section Trichotomy + +/-- **The dévissage trichotomy** (Deligne 2.9, the case +analysis): over any state, either every symmetric power of the +remainder survives, or every alternating power survives, or the +remainder is zero. -/ +theorem devissageTrichotomy + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + [Linear ℂ D] [MonoidalLinear ℂ D] + (P : SchurPackage.{v}) + (L : OddLine D) (X : D) : + DevissageTrichotomy D L X := + devissageTrichotomy_of_descent P L X + (fun B _ _ _ _ d hz k h => + isZero_of_isZero_modPow B d hz k h) + +end Trichotomy + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DevissageBound.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DevissageBound.lean new file mode 100644 index 0000000000..359792b310 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DevissageBound.lean @@ -0,0 +1,82 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormalise +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchurSummand +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixWhiskerAll +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29State + +/-! +# The dévissage counts are bounded + +A killing diagram bounds the two counts of a dévissage state. +The killing is whiskered by the base and read as module-level +vanishing for the free module on the object; the decomposition +carries it to the mixed free part; and there the nonvanishing of +the mixed sum forces the diagram to contain the cell recording +the two counts. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +attribute [local instance] + hasBinaryBiproducts_of_finite_biproducts + +/-- **The counts of a dévissage state are bounded by the killing +diagram.** -/ +theorem devissage_bound + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (P : SchurPackage.{v}) (P₀ : SchurPackage.{0}) + (L : OddLine D) (X : D) {lam : YoungDiagram} + (hcard : lam.card ≠ 0) (hkill : SchurKilled P X lam) + (st : DevissageState D L X) : + st.units + st.lines ≤ 2 * lam.card := by + let := st.monObj + let := st.comm + have h1 : (st.base ◁ (permAlg X lam.card (P.e lam) : + tensorPow D X lam.card ⟶ tensorPow D X lam.card)) = 0 := by + rw [show (permAlg X lam.card (P.e lam) : + tensorPow D X lam.card ⟶ tensorPow D X lam.card) = 0 + from hkill] + exact MonoidalPreadditive.whiskerLeft_zero + have h2 : ModSchurKilled st.base (freeMod st.base X).X P lam := + modPowAlg_eq_zero st.base X lam.card hcard (P.e lam) h1 + obtain ⟨e⟩ := st.decomp + have h3 : ModSchurKilled st.base + (freeMod st.base (L.mix st.units st.lines)).X P lam := + ModSchurKilled.of_biprod_left st.base _ _ P + (ModSchurKilled.of_modIso st.base e.symm P h2) + have h4 : (st.base ◁ (permAlg (L.mix st.units st.lines) lam.card + (P.e lam) : tensorPow D (L.mix st.units st.lines) lam.card ⟶ + tensorPow D (L.mix st.units st.lines) lam.card)) = 0 := + whisker_permAlg_eq_zero st.base (L.mix st.units st.lines) + lam.card hcard (P.e lam) h3 + have hW : ∀ k : ℕ, + 𝟙 (st.base ⊗ tensorPow D L.obj k) ≠ 0 := fun k => + L.whisker_tensorPow_id_ne_zero st.unit_ne_zero k + have hcell : ((st.units, st.lines) : ℕ × ℕ) ∈ lam := by + by_contra hc + exact L.whisker_permAlg_mix_ne_zero' P P₀ st.base st.units + st.lines hW hc h4 + obtain ⟨hr, hs⟩ := cell_lt_card hcell + omega + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledAbelian.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledAbelian.lean new file mode 100644 index 0000000000..592b7c5ede --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledAbelian.lean @@ -0,0 +1,204 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Doubling + +/-! +# Abelianness of the doubling + +`RS/Classical/Deligne/Doubling.lean` equips the ℤ/2-graded +doubling `Doubled A` with componentwise binary biproducts, kernels +and cokernels. This module upgrades that bookkeeping to +abelianness: if `A` is abelian, so is `Doubled A`. + +The route is Mathlib's coimage–image criterion +`CategoryTheory.Abelian.ofCoimageImageComparisonIsIso`. The two +component functors `evenFunctor`, `oddFunctor : Doubled A ⥤ A` +preserve kernels and cokernels, because the kernel and the cokernel +of a morphism of super-objects are the componentwise ones; hence +they preserve abelian images, abelian coimages, and the comparison +morphism between them. Downstairs that comparison is an +isomorphism, so both components of the comparison upstairs are +isomorphisms, and `Doubled.isIso_of_components` concludes. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Limits + +universe v u + +noncomputable section + +namespace Doubled + +section Components + +variable {A : Type u} + +/-- The even-component functor `X ↦ X.even`. -/ +def evenFunctor [Category.{v} A] : Doubled A ⥤ A where + obj X := X.even + map f := evenHom f + map_id _ := rfl + map_comp _ _ := rfl + +/-- The odd-component functor `X ↦ X.odd`. -/ +def oddFunctor [Category.{v} A] : Doubled A ⥤ A where + obj X := X.odd + map f := oddHom f + map_id _ := rfl + map_comp _ _ := rfl + +@[simp] +theorem evenFunctor_obj [Category.{v} A] + (X : Doubled A) : + (evenFunctor : Doubled A ⥤ A).obj X = X.even := + rfl + +@[simp] +theorem oddFunctor_obj [Category.{v} A] + (X : Doubled A) : + (oddFunctor : Doubled A ⥤ A).obj X = X.odd := + rfl + +@[simp] +theorem evenFunctor_map [Category.{v} A] + {X Y : Doubled A} (f : X ⟶ Y) : + (evenFunctor : Doubled A ⥤ A).map f = evenHom f := + rfl + +@[simp] +theorem oddFunctor_map [Category.{v} A] + {X Y : Doubled A} (f : X ⟶ Y) : + (oddFunctor : Doubled A ⥤ A).map f = oddHom f := + rfl + +/-- The even-component functor preserves zero morphisms. -/ +instance evenFunctorPreservesZeroMorphisms [Category.{v} A] + [Preadditive A] : + (evenFunctor : Doubled A ⥤ A).PreservesZeroMorphisms where + map_zero _ _ := rfl + +/-- The odd-component functor preserves zero morphisms. -/ +instance oddFunctorPreservesZeroMorphisms [Category.{v} A] + [Preadditive A] : + (oddFunctor : Doubled A ⥤ A).PreservesZeroMorphisms where + map_zero _ _ := rfl + +end Components + +section Exactness + +variable {A : Type u} + +/-- The even-component functor preserves kernels: the kernel of a +morphism of super-objects is the componentwise one. -/ +instance evenFunctorPreservesKernel [Category.{v} A] [Preadditive A] + [HasKernels A] {X Y : Doubled A} + (f : X ⟶ Y) : + PreservesLimit (parallelPair f 0) (evenFunctor : Doubled A ⥤ A) := + preservesLimit_of_preserves_limit_cone (kernelForkIsLimit f) + ((KernelFork.isLimitMapConeEquiv (kernelFork f) evenFunctor).symm + (kernelIsKernel (evenHom f))) + +/-- The odd-component functor preserves kernels. -/ +instance oddFunctorPreservesKernel [Category.{v} A] [Preadditive A] + [HasKernels A] {X Y : Doubled A} + (f : X ⟶ Y) : + PreservesLimit (parallelPair f 0) (oddFunctor : Doubled A ⥤ A) := + preservesLimit_of_preserves_limit_cone (kernelForkIsLimit f) + ((KernelFork.isLimitMapConeEquiv (kernelFork f) oddFunctor).symm + (kernelIsKernel (oddHom f))) + +/-- The even-component functor preserves cokernels: the cokernel of +a morphism of super-objects is the componentwise one. -/ +instance evenFunctorPreservesCokernel [Category.{v} A] [Preadditive A] + [HasCokernels A] + {X Y : Doubled A} (f : X ⟶ Y) : + PreservesColimit (parallelPair f 0) (evenFunctor : Doubled A ⥤ A) := + preservesColimit_of_preserves_colimit_cocone (cokernelCoforkIsColimit f) + ((CokernelCofork.isColimitMapCoconeEquiv (cokernelCofork f) + evenFunctor).symm (cokernelIsCokernel (evenHom f))) + +/-- The odd-component functor preserves cokernels. -/ +instance oddFunctorPreservesCokernel [Category.{v} A] [Preadditive A] + [HasCokernels A] + {X Y : Doubled A} (f : X ⟶ Y) : + PreservesColimit (parallelPair f 0) (oddFunctor : Doubled A ⥤ A) := + preservesColimit_of_preserves_colimit_cocone (cokernelCoforkIsColimit f) + ((CokernelCofork.isColimitMapCoconeEquiv (cokernelCofork f) + oddFunctor).symm (cokernelIsCokernel (oddHom f))) + +end Exactness + +section Abelian + +variable {A : Type u} + +/-- The even component of the coimage–image comparison is an +isomorphism: it is, up to the comparison isomorphisms of the +even-component functor, the coimage–image comparison of `evenHom f` +in the abelian category `A`. -/ +theorem isIso_evenHom_coimageImageComparison [Category.{v} A] [Abelian A] + {X Y : Doubled A} + (f : X ⟶ Y) : + IsIso (evenHom (Abelian.coimageImageComparison f)) := by + have h : IsIso ((evenFunctor : Doubled A ⥤ A).map + (Abelian.coimageImageComparison f)) := by + rw [Arrow.isIso_iff_isIso_of_isIso + (Abelian.PreservesCoimageImageComparison.iso + (evenFunctor : Doubled A ⥤ A) f).hom] + infer_instance + exact h + +/-- The odd component of the coimage–image comparison is an +isomorphism, for the same reason. -/ +theorem isIso_oddHom_coimageImageComparison [Category.{v} A] [Abelian A] + {X Y : Doubled A} + (f : X ⟶ Y) : + IsIso (oddHom (Abelian.coimageImageComparison f)) := by + have h : IsIso ((oddFunctor : Doubled A ⥤ A).map + (Abelian.coimageImageComparison f)) := by + rw [Arrow.isIso_iff_isIso_of_isIso + (Abelian.PreservesCoimageImageComparison.iso + (oddFunctor : Doubled A ⥤ A) f).hom] + infer_instance + exact h + +/-- The coimage–image comparison of a morphism of super-objects is +an isomorphism, since both of its components are. -/ +theorem isIso_coimageImageComparison [Category.{v} A] [Abelian A] + {X Y : Doubled A} (f : X ⟶ Y) : + IsIso (Abelian.coimageImageComparison f) := + haveI := isIso_evenHom_coimageImageComparison f + haveI := isIso_oddHom_coimageImageComparison f + isIso_of_components _ + +/-- The doubling of an abelian category is abelian, with +componentwise kernels, cokernels and biproducts. -/ +instance instAbelian [Category.{v} A] [Abelian A] : Abelian (Doubled A) := + haveI : ∀ {X Y : Doubled A} (f : X ⟶ Y), + IsIso (Abelian.coimageImageComparison f) := + fun f => isIso_coimageImageComparison f + Abelian.ofCoimageImageComparisonIsIso + +/-- The doubling has finite biproducts. -/ +theorem hasFiniteBiproducts + [Category.{v} A] [Abelian A] : HasFiniteBiproducts (Doubled A) := + Abelian.hasFiniteBiproducts + +end Abelian + +end Doubled + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledGrowth.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledGrowth.lean new file mode 100644 index 0000000000..5cd991d170 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledGrowth.lean @@ -0,0 +1,587 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.TensorPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledAbelian + +/-! +# Deligne's growth and generation hypotheses in the doubling + +`RS/Classical/Deligne/Doubling.lean` builds the ℤ/2-graded +doubling `Doubled A`, the faithful summing functor +`total : Doubled A ⥤ A`, `X ↦ X.even ⊞ X.odd` along which the +monoidal structure is induced, and the even embedding +`evenEmbed : A ⥤ Doubled A`. This module transports two of +Deligne's hypotheses across that construction: moderate growth of +the lengths of tensor powers, and finite ⊗-generation. + +Growth travels along the summing functor. It is monoidal, so its +comparison isomorphisms assemble by induction into +`total.obj (Y ^ ⊗ N) ≅ (total.obj Y) ^ ⊗ N`; and it reflects the +subobject order — the graded components of a monomorphism are +monomorphisms, a biproduct of monomorphisms is a monomorphism, and +a factorisation of the summed subobjects splits back into its +matrix entries. So a strictly increasing chain of subobjects +upstairs gives one of the same length downstairs, and the constants +that bound the growth of `total.obj Y` in `A` bound the growth of +`Y` in the doubling verbatim. + +Generation travels along the diagonal embedding `dbl`, +`M ↦ (M, M)`, which is additive and preserves monomorphisms and +epimorphisms. A super-object `Y` is a retract of +`dbl (Y.even ⊞ Y.odd)`, so a subquotient presentation of +`Y.even ⊞ Y.odd` downstairs presents both graded components at +once. The generator taken upstairs is +`gen X = (X ⊞ Xᘁ ⊞ 𝟙_ A, 𝟙_ A)`: the ambient generator, its dual +and the unit in even degree, the unit in odd degree. Its pure +tensor powers already contain the diagonal double of every mixed +power of `X` as a retract — read the word `X, …, X, (𝟙, 𝟙), +Xᘁ, …, Xᘁ` off the letters of `gen X`, the diagonal letter +spreading an even word over both degrees. No dual is ever formed +in the doubling: the presentations produced here use mixed powers +with no dual factors at all. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Limits MonoidalCategory + +universe v u + +noncomputable section + +namespace Doubled + +section Components + +variable {A : Type u} + +/-- The even component of a monomorphism of super-objects is a +monomorphism: a morphism killed by it is the even component of a +morphism killed by it. -/ +theorem mono_evenHom [Category.{v} A] [Preadditive A] + {S Z : Doubled A} (m : S ⟶ Z) [Mono m] : + Mono (evenHom m) := by + refine (Preadditive.mono_iff_cancel_zero _).2 fun T g hg => ?_ + have hzero : (homMk g 0 : (⟨T, S.odd⟩ : Doubled A) ⟶ S) ≫ m = 0 := by + apply hom_ext + · simpa using hg + · simp + have hg' := (Preadditive.mono_iff_cancel_zero m).1 ‹Mono m› _ _ hzero + simpa using congrArg evenHom hg' + +/-- The odd component of a monomorphism of super-objects is a +monomorphism. -/ +theorem mono_oddHom [Category.{v} A] [Preadditive A] + {S Z : Doubled A} (m : S ⟶ Z) [Mono m] : + Mono (oddHom m) := by + refine (Preadditive.mono_iff_cancel_zero _).2 fun T g hg => ?_ + have hzero : (homMk 0 g : (⟨S.even, T⟩ : Doubled A) ⟶ S) ≫ m = 0 := by + apply hom_ext + · simp + · simpa using hg + have hg' := (Preadditive.mono_iff_cancel_zero m).1 ‹Mono m› _ _ hzero + simpa using congrArg oddHom hg' + +/-- A morphism of super-objects with monomorphic components is a +monomorphism: morphisms are compared componentwise. -/ +theorem mono_of_components [Category.{v} A] [Preadditive A] + {S Z : Doubled A} (m : S ⟶ Z) + (he : Mono (evenHom m)) (ho : Mono (oddHom m)) : Mono m := by + refine (Preadditive.mono_of_cancel_zero _) fun g hg => ?_ + have he' : evenHom g = 0 := + (Preadditive.mono_iff_cancel_zero _).1 he _ _ + (by simpa using congrArg evenHom hg) + have ho' : oddHom g = 0 := + (Preadditive.mono_iff_cancel_zero _).1 ho _ _ + (by simpa using congrArg oddHom hg) + exact hom_ext (by simpa using he') (by simpa using ho') + +/-- A morphism of super-objects with epimorphic components is an +epimorphism. -/ +theorem epi_of_components [Category.{v} A] [Preadditive A] + {S Z : Doubled A} (m : S ⟶ Z) + (he : Epi (evenHom m)) (ho : Epi (oddHom m)) : Epi m := by + refine (Preadditive.epi_of_cancel_zero _) fun g hg => ?_ + have he' : evenHom g = 0 := + (Preadditive.epi_iff_cancel_zero _).1 he _ _ + (by simpa using congrArg evenHom hg) + have ho' : oddHom g = 0 := + (Preadditive.epi_iff_cancel_zero _).1 ho _ _ + (by simpa using congrArg oddHom hg) + exact hom_ext (by simpa using he') (by simpa using ho') + +end Components + +section TotalMono + +variable {A : Type u} + +/-- A biproduct of two monomorphisms is a monomorphism: a morphism +killed by it is killed in each matrix entry. -/ +theorem eq_zero_of_comp_biprod_map + [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + {P M N M' N' : A} + (g : P ⟶ M ⊞ N) {f₁ : M ⟶ M'} {f₂ : N ⟶ N'} (h₁ : Mono f₁) + (h₂ : Mono f₂) (hg : g ≫ biprod.map f₁ f₂ = 0) : g = 0 := by + have e₁ : g ≫ biprod.fst = 0 := by + refine (Preadditive.mono_iff_cancel_zero _).1 h₁ _ _ ?_ + have h : g ≫ biprod.map f₁ f₂ ≫ biprod.fst = 0 := by + rw [← Category.assoc, hg, Limits.zero_comp] + simpa using h + have e₂ : g ≫ biprod.snd = 0 := by + refine (Preadditive.mono_iff_cancel_zero _).1 h₂ _ _ ?_ + have h : g ≫ biprod.map f₁ f₂ ≫ biprod.snd = 0 := by + rw [← Category.assoc, hg, Limits.zero_comp] + simpa using h + exact biprod.hom_ext _ _ (by simpa using e₁) (by simpa using e₂) + +/-- The summing functor preserves monomorphisms: on components a +monomorphism of super-objects is a pair of monomorphisms, and the +biproduct of two monomorphisms is one. -/ +instance total_map_mono [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + {S Z : Doubled A} (m : S ⟶ Z) [Mono m] : + Mono (total.map m) := by + refine Preadditive.mono_of_cancel_zero _ ?_ + intro P g hg + have hg' : g ≫ biprod.map (evenHom m) (oddHom m) = 0 := hg + exact eq_zero_of_comp_biprod_map g (mono_evenHom m) (mono_oddHom m) + hg' + +/-- The diagonal matrix entries of a factorisation of one +biproduct of morphisms through another factor the two given +morphisms. -/ +theorem diag_of_comp_biprod_map + [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + {M N M' N' P Q : A} + (u : M ⊞ N ⟶ M' ⊞ N') {t₁ : M' ⟶ P} {t₂ : N' ⟶ Q} + {s₁ : M ⟶ P} {s₂ : N ⟶ Q} + (hu : u ≫ biprod.map t₁ t₂ = biprod.map s₁ s₂) : + (biprod.inl ≫ u ≫ biprod.fst) ≫ t₁ = s₁ ∧ + (biprod.inr ≫ u ≫ biprod.snd) ≫ t₂ = s₂ := by + constructor + · simpa using congrArg (fun w => biprod.inl ≫ w ≫ biprod.fst) hu + · simpa using congrArg (fun w => biprod.inr ≫ w ≫ biprod.snd) hu + +/-- A factorisation of the summed subobjects splits back into its +diagonal matrix entries, which assemble into a factorisation of the +subobjects themselves. -/ +theorem le_of_total_comm + [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + {Z : Doubled A} {S T : Subobject Z} + (u : total.obj (S : Doubled A) ⟶ total.obj (T : Doubled A)) + (hu : u ≫ total.map T.arrow = total.map S.arrow) : S ≤ T := by + have hu' : u ≫ biprod.map (evenHom T.arrow) (oddHom T.arrow) = + biprod.map (evenHom S.arrow) (oddHom S.arrow) := hu + obtain ⟨he, ho⟩ := diag_of_comp_biprod_map u hu' + refine Subobject.le_of_comm (homMk (biprod.inl ≫ u ≫ biprod.fst) + (biprod.inr ≫ u ≫ biprod.snd)) ?_ + exact hom_ext he ho + +/-- The summing functor reflects the subobject order. -/ +theorem le_of_total_le [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + {Z : Doubled A} {S T : Subobject Z} + (h : Subobject.mk (total.map S.arrow) ≤ + Subobject.mk (total.map T.arrow)) : S ≤ T := + le_of_total_comm + (Subobject.ofMkLEMk (total.map S.arrow) (total.map T.arrow) h) + (Subobject.ofMkLEMk_comp h) + +/-- Length in the doubling is length of the total object: a +strictly increasing chain of subobjects of `Z` maps to a strictly +increasing chain of subobjects of `total.obj Z`. -/ +theorem lengthLE_of_total + [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + {Z : Doubled A} {k : ℕ} + (h : LengthLE (total.obj Z) k) : LengthLE Z k := by + intro f hf + refine h (fun i => Subobject.mk (total.map (f i).arrow)) ?_ + intro i j hij + have hlt : f i < f j := hf hij + have hle : Subobject.mk (total.map (f i).arrow) ≤ + Subobject.mk (total.map (f j).arrow) := + Subobject.mk_le_mk_of_comm + (total.map (Subobject.ofLE _ _ hlt.le)) + (by rw [← CategoryTheory.Functor.map_comp, + Subobject.ofLE_arrow]) + refine lt_of_le_of_ne hle fun heq => ?_ + exact hlt.ne + (le_antisymm hlt.le (le_of_total_le (le_of_eq heq.symm))) + +end TotalMono + +section GrowthTransport + +variable {A : Type u} + +/-- The summing functor carries the graded tensor powers of `Y` to +the ambient tensor powers of `total.obj Y`: the comparison +isomorphisms of the monoidal functor `total`, assembled by +induction on the exponent. -/ +def totalTensorPowIso [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (Y : Doubled A) : ∀ N : ℕ, + total.obj (tensorPow (Doubled A) Y N) ≅ + tensorPow A (total.obj Y) N + | 0 => epsIso.symm + | N + 1 => (muIso (tensorPow (Doubled A) Y N) Y).symm ≪≫ + tensorIso (totalTensorPowIso Y N) (Iso.refl (total.obj Y)) + +end GrowthTransport + +end Doubled + +section Retracts + +variable {C : Type u} + +/-- **`Y` is a retract of `Z`**: a section split by a retraction. +A retract is in particular a subquotient, and — unlike the +subquotient relation — the property is visibly stable under tensor +products, tensor powers and biproducts. -/ +def IsRetractOf [Category.{v} C] + (Y Z : C) : Prop := + ∃ (s : Y ⟶ Z) (r : Z ⟶ Y), s ≫ r = 𝟙 Y + +/-- An isomorphism is a retraction. -/ +theorem isRetractOf_of_iso [Category.{v} C] + {Y Z : C} (e : Y ≅ Z) : IsRetractOf Y Z := + ⟨e.hom, e.inv, e.hom_inv_id⟩ + +/-- Every object is a retract of itself. -/ +theorem isRetractOf_rfl [Category.{v} C] + (Y : C) : IsRetractOf Y Y := + isRetractOf_of_iso (Iso.refl Y) + +/-- Retractions compose. -/ +theorem IsRetractOf.trans [Category.{v} C] + {Y Z W : C} (h : IsRetractOf Y Z) + (h' : IsRetractOf Z W) : IsRetractOf Y W := by + obtain ⟨s, r, hsr⟩ := h + obtain ⟨s', r', hsr'⟩ := h' + refine ⟨s ≫ s', r' ≫ r, ?_⟩ + rw [Category.assoc, ← Category.assoc s', hsr', Category.id_comp, + hsr] + +/-- A subquotient sandwiched between two retractions is a +subquotient: a split monomorphism extends the inclusion and a split +epimorphism extends the quotient map. -/ +theorem IsSubquotientOf.sandwich [Category.{v} C] + {Y Y' Z' Z : C} + (hY : IsRetractOf Y Y') (h : IsSubquotientOf Y' Z') + (hZ : IsRetractOf Z' Z) : IsSubquotientOf Y Z := by + obtain ⟨s, r, hsr⟩ := hY + obtain ⟨S, i, p, hi, hp⟩ := h + obtain ⟨s', r', hsr'⟩ := hZ + have := hi + have := hp + have : IsSplitMono s' := IsSplitMono.mk' ⟨r', hsr'⟩ + have : IsSplitEpi r := IsSplitEpi.mk' ⟨s, hsr⟩ + exact ⟨S, i ≫ s', p ≫ r, inferInstance, inferInstance⟩ + +end Retracts + +section RetractsMonoidal + +variable {C : Type u} + +/-- Retractions multiply. -/ +theorem IsRetractOf.tensor [Category.{v} C] [MonoidalCategory C] + {Y Z Y' Z' : C} (h : IsRetractOf Y Z) + (h' : IsRetractOf Y' Z') : IsRetractOf (Y ⊗ Y') (Z ⊗ Z') := by + obtain ⟨s, r, hsr⟩ := h + obtain ⟨s', r', hsr'⟩ := h' + exact ⟨s ⊗ₘ s', r ⊗ₘ r', by + rw [MonoidalCategory.tensorHom_comp_tensorHom, hsr, hsr', + MonoidalCategory.id_tensorHom_id]⟩ + +/-- Retractions raise to tensor powers. -/ +theorem IsRetractOf.tensorPow [Category.{v} C] [MonoidalCategory C] + {Y Z : C} (h : IsRetractOf Y Z) : + ∀ n : ℕ, IsRetractOf (tensorPow C Y n) (tensorPow C Z n) + | 0 => isRetractOf_rfl _ + | n + 1 => (h.tensorPow n).tensor h + +end RetractsMonoidal + +section RetractsBiproduct + +variable {C : Type u} + +/-- Retractions assemble over a finite biproduct. -/ +theorem IsRetractOf.biproduct [Category.{v} C] [Preadditive C] + {J : Type} {f g : J → C} + [HasBiproduct f] [HasBiproduct g] + (h : ∀ t, IsRetractOf (f t) (g t)) : + IsRetractOf (⨁ f) (⨁ g) := by + choose s r hsr using h + refine ⟨Limits.biproduct.map s, Limits.biproduct.map r, ?_⟩ + ext t + simp [hsr t] + +end RetractsBiproduct + +namespace Doubled + +section Diagonal + +variable {A : Type u} + +/-- The diagonal embedding `M ↦ (M, M)`: the ambient object placed +in both degrees at once. -/ +def dbl [Category.{v} A] : A ⥤ Doubled A where + obj M := ⟨M, M⟩ + map f := homMk f f + map_id _ := rfl + map_comp _ _ := rfl + +@[simp] +theorem dbl_obj_even [Category.{v} A] + (M : A) : (dbl.obj M).even = M := + rfl + +@[simp] +theorem dbl_obj_odd [Category.{v} A] + (M : A) : (dbl.obj M).odd = M := + rfl + +/-- The diagonal embedding is additive. -/ +instance [Category.{v} A] [Preadditive A] : (dbl (A := A)).Additive where + map_add := rfl + +/-- The diagonal embedding preserves subquotients: its components +are the given morphisms, so monomorphisms and epimorphisms are +preserved. -/ +theorem isSubquotientOf_dbl [Category.{v} A] [Preadditive A] + {P Q : A} (h : IsSubquotientOf P Q) : + IsSubquotientOf (dbl.obj P) (dbl.obj Q) := by + obtain ⟨S, i, p, hi, hp⟩ := h + exact ⟨dbl.obj S, dbl.map i, dbl.map p, + mono_of_components _ hi hi, epi_of_components _ hp hp⟩ + +/-- A retraction of super-objects from a pair of component +retractions. -/ +theorem isRetractOf_of_components [Category.{v} A] + {V W : Doubled A} + (se : V.even ⟶ W.even) (re : W.even ⟶ V.even) + (he : se ≫ re = 𝟙 V.even) (so : V.odd ⟶ W.odd) + (ro : W.odd ⟶ V.odd) (ho : so ≫ ro = 𝟙 V.odd) : + IsRetractOf V W := + ⟨homMk se so, homMk re ro, + hom_ext (by simpa using he) (by simpa using ho)⟩ + +end Diagonal + +section DiagonalBiprod + +variable {A : Type u} + +/-- Every super-object is a retract of the diagonal double of the +sum of its two components. -/ +theorem isRetractOf_dbl_self + [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + (Y : Doubled A) : + IsRetractOf Y (dbl.obj (Y.even ⊞ Y.odd)) := + isRetractOf_of_components biprod.inl biprod.fst (by simp) + biprod.inr biprod.snd (by simp) + +end DiagonalBiprod + +section EvenTensor + +variable {A : Type u} + +open ZeroObject + +/-- Tensoring an even object on the left multiplies both graded +components: the mixed blocks vanish. -/ +def evenTensorIso [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (Z : A) (V : Doubled A) : + evenEmbed.obj Z ⊗ V ≅ ⟨Z ⊗ V.even, Z ⊗ V.odd⟩ := + isoMk (isoBiprodZero (isZero_zeroTensor _)).symm + (isoBiprodZero (isZero_zeroTensor _)).symm + +/-- Tensoring an even object on the right multiplies both graded +components. -/ +def tensorEvenIso [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (V : Doubled A) (Z : A) : + V ⊗ evenEmbed.obj Z ≅ ⟨V.even ⊗ Z, V.odd ⊗ Z⟩ := + isoMk (isoBiprodZero (isZero_tensorZero _)).symm + (isoZeroBiprod (isZero_tensorZero _)).symm + +/-- Tensor powers of an even object are even. -/ +def evenTensorPowIso [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (Z : A) : ∀ n : ℕ, + tensorPow (Doubled A) (evenEmbed.obj Z) n ≅ + evenEmbed.obj (tensorPow A Z n) + | 0 => Iso.refl _ + | n + 1 => tensorIso (evenTensorPowIso Z n) (Iso.refl _) ≪≫ + evenEmbedTensorIso _ _ + +end EvenTensor + +section Generator + +variable {A : Type u} + +open ZeroObject + +/-- The generator of the doubling attached to a generator `X` of +`A`: the ambient generator, its dual and the unit in even degree, +the unit in odd degree. The odd component is what makes the odd +half of a super-object reachable; the dual and the unit in the even +component are what let the words of a mixed power be read off +without ever forming a dual in the doubling. It is reducible, so +that the component computations below see its two blocks. -/ +@[reducible] +def gen [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] [RigidCategory A] + (X : A) : Doubled A := + ⟨X ⊞ Xᘁ ⊞ 𝟙_ A, 𝟙_ A⟩ + +/-- The even copy of `X` is a retract of the generator. -/ +theorem isRetractOf_evenEmbed_gen + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] [HasZeroObject A] [RigidCategory A] + (X : A) : + IsRetractOf (evenEmbed.obj X) (gen X) := + isRetractOf_of_components biprod.inl biprod.fst (by simp) 0 0 + ((isZero_zero A).eq_of_src _ _) + +/-- The even copy of the dual of `X` is a retract of the +generator. -/ +theorem isRetractOf_evenEmbedDual_gen + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] [HasZeroObject A] [RigidCategory A] + (X : A) : + IsRetractOf (evenEmbed.obj (Xᘁ)) (gen X) := + isRetractOf_of_components (biprod.inl ≫ biprod.inr) + (biprod.snd ≫ biprod.fst) (by simp) 0 0 + ((isZero_zero A).eq_of_src _ _) + +/-- The diagonal double of the unit is a retract of the +generator. -/ +theorem isRetractOf_dblUnit_gen + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] [RigidCategory A] + (X : A) : + IsRetractOf (dbl.obj (𝟙_ A)) (gen X) := + isRetractOf_of_components (biprod.inr ≫ biprod.inr) + (biprod.snd ≫ biprod.snd) (by simp) (𝟙 _) (𝟙 _) (by simp) + +/-- The word in the generator that reads off a mixed power: `a` +even copies of `X`, then the diagonal double of the unit, then `b` +even copies of the dual of `X`. -/ +def genWord [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + [RigidCategory A] + (X : A) (a : ℕ) : ℕ → Doubled A + | 0 => tensorPow (Doubled A) (evenEmbed.obj X) a ⊗ dbl.obj (𝟙_ A) + | b + 1 => genWord X a b ⊗ evenEmbed.obj (Xᘁ) + +/-- The word is the diagonal double of the mixed power: the +diagonal factor spreads the even word over both degrees, and the +remaining brackets are reassociated. -/ +def genWordIso [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + [RigidCategory A] + (X : A) (a : ℕ) : ∀ b : ℕ, + genWord X a b ≅ dbl.obj (mixedPow A X a b) + | 0 => tensorIso (evenTensorPowIso X a) (Iso.refl _) ≪≫ + evenTensorIso _ _ + | b + 1 => tensorIso (genWordIso X a b) (Iso.refl _) ≪≫ + tensorEvenIso _ _ ≪≫ dbl.mapIso (α_ _ _ _) + +/-- The word is a retract of a tensor power of the generator: +letter by letter. -/ +theorem isRetractOf_genWord + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + [RigidCategory A] + (X : A) (a : ℕ) : ∀ b : ℕ, + IsRetractOf (genWord X a b) + (tensorPow (Doubled A) (gen X) (a + 1 + b)) + | 0 => ((isRetractOf_evenEmbed_gen X).tensorPow a).tensor + (isRetractOf_dblUnit_gen X) + | b + 1 => (isRetractOf_genWord X a b).tensor + (isRetractOf_evenEmbedDual_gen X) + +/-- The diagonal double of a mixed power of `X` is a retract of a +pure power of the generator — a mixed power of the generator with +no dual factors. -/ +theorem isRetractOf_dbl_mixedPow + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + [RigidCategory A] + (X : A) (a b : ℕ) : + IsRetractOf (dbl.obj (mixedPow A X a b)) + (mixedPow (Doubled A) (gen X) (a + 1 + b) 0) := + (isRetractOf_of_iso (genWordIso X a b).symm).trans + ((isRetractOf_genWord X a b).trans + (isRetractOf_of_iso (tensorPowIsoMixed (Doubled A) (gen X) _))) + +end Generator + +end Doubled + +section Hypotheses + +variable {A : Type u} + +/-- **Moderate length growth passes to the doubling.** The +constants bounding the growth of `total.obj Y` in `A` bound the +growth of `Y` in the doubling verbatim. -/ +theorem moderateLengthGrowth_doubled + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (h : ModerateLengthGrowth A) : + ModerateLengthGrowth (Doubled A) := by + intro Y + obtain ⟨C, c, hC⟩ := h (Doubled.total.obj Y) + refine ⟨C, c, fun N => Doubled.lengthLE_of_total ?_⟩ + exact (hC N).of_iso (Doubled.totalTensorPowIso Y N).symm + +end Hypotheses + +section Generation + +variable {A : Type u} + +attribute [local instance] Doubled.hasFiniteBiproducts + +/-- **Tensor generation passes to the doubling.** A super-object +is a retract of the diagonal double of the sum of its components, +that sum is a subquotient of a biproduct of mixed powers of `X`, +and the diagonal double of a mixed power of `X` is a retract of a +pure power of `Doubled.gen X`. -/ +theorem tensorGeneratedBy_doubled + [Category.{v} A] [Abelian A] [MonoidalCategory A] + [MonoidalPreadditive A] [HasFiniteBiproducts A] [RigidCategory A] + {X : A} + (h : TensorGeneratedBy A X) : + TensorGeneratedBy (Doubled A) (Doubled.gen X) := by + intro Y + obtain ⟨k, ab, hsub⟩ := h (Y.even ⊞ Y.odd) + refine ⟨k, fun t => ((ab t).1 + 1 + (ab t).2, 0), ?_⟩ + refine IsSubquotientOf.sandwich (Doubled.isRetractOf_dbl_self Y) + (Doubled.isSubquotientOf_dbl hsub) ?_ + refine IsRetractOf.trans + (isRetractOf_of_iso (Functor.mapBiproduct Doubled.dbl _)) ?_ + exact IsRetractOf.biproduct fun t => + Doubled.isRetractOf_dbl_mixedPow X (ab t).1 (ab t).2 + +end Generation + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledLine.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledLine.lean new file mode 100644 index 0000000000..a47682b8f3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledLine.lean @@ -0,0 +1,41 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Doubling +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 + +/-! +# The odd line of the doubling + +The ℤ/2-graded doubling of a tensor category always contains an +odd line: the monoidal unit placed in odd degree squares to the +unit and self-braids by `−1`. This is Deligne's device for the +general case of 2.11, where the category itself need not contain +such an object. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {A : Type u} + +/-- **The odd line of the doubling**: the unit in odd degree. -/ +noncomputable def doubledOddLine + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [MonoidalPreadditive A] [HasBinaryBiproducts A] + [HasZeroObject A] : OddLine (Doubled A) where + obj := Doubled.oddUnit + sq := Doubled.oddUnitSq + braid_neg := Doubled.braiding_oddUnit + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledScalar.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledScalar.lean new file mode 100644 index 0000000000..8836d8b918 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledScalar.lean @@ -0,0 +1,51 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Doubling +public import LeanPool.RegtsSevenster.RS.Definitions + +/-! +# Scalars on the unit of the doubling + +The unit of the doubling is the unit in even degree and the zero +object in odd degree, so its endomorphisms are those of the unit +downstairs: the scalar-unit hypothesis passes to the doubling. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {A : Type u} + +/-- **The scalar-unit hypothesis passes to the doubling.** -/ +theorem hasScalarUnit_doubled + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [CategoryTheory.Linear ℂ A] [MonoidalPreadditive A] + [HasBinaryBiproducts A] [HasZeroObject A] + (hu : HasScalarUnit A) : + HasScalarUnit (Doubled A) := by + constructor + · intro c c' h + have he := congrArg Doubled.evenHom h + rw [Doubled.evenHom_smul, Doubled.evenHom_smul, + Doubled.evenHom_id] at he + exact hu.1 he + · intro f + obtain ⟨c, hc⟩ := hu.2 (Doubled.evenHom f) + refine ⟨c, ?_⟩ + apply Doubled.hom_ext + · rw [Doubled.evenHom_smul, Doubled.evenHom_id] + exact hc + · exact (isZero_zero A).eq_of_src _ _ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledSmall.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledSmall.lean new file mode 100644 index 0000000000..eaea727fbd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledSmall.lean @@ -0,0 +1,50 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Doubling + +/-! +# The doubling is the square + +The doubling of a category is its product with itself: an object +is a pair and a morphism is a pair. Essential smallness follows. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +universe v u + +variable {A : Type u} + +/-- The doubling, as the product category. -/ +def doubledProdFunctor [Category.{v} A] : Doubled A ⥤ (A × A) where + obj X := (X.even, X.odd) + map f := (Doubled.evenHom f, Doubled.oddHom f) + map_id _ := rfl + map_comp _ _ := rfl + +/-- The product category, as the doubling. -/ +def prodDoubledFunctor [Category.{v} A] : (A × A) ⥤ Doubled A where + obj X := ⟨X.1, X.2⟩ + map f := ⟨f.1, f.2⟩ + map_id _ := rfl + map_comp _ _ := rfl + +/-- **The doubling is the square of the category.** -/ +def doubledProdEquiv [Category.{v} A] : Doubled A ≌ (A × A) where + functor := doubledProdFunctor + inverse := prodDoubledFunctor + unitIso := Iso.refl _ + counitIso := Iso.refl _ + functor_unitIso_comp _ := Category.comp_id _ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledSplit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledSplit.lean new file mode 100644 index 0000000000..2432e73812 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledSplit.lean @@ -0,0 +1,72 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitEverything +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21General + +/-! +# The splitting algebra of the doubling + +A tensor category need not contain an odd line; the ℤ/2-graded +doubling always does. Every hypothesis passes to the doubling — +scalar unit endomorphisms, moderate length growth, finite tensor +generation, and finite length of every object — so the single +simple algebra that splits the doubling is available, together with +the complex point of its Γ-algebra. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v + +variable {A : Type v} + +attribute [local instance] Doubled.hasFiniteBiproducts + +/-- **The splitting algebra of the doubling.** Everything the +argument needs passes to `Doubled A`, so one simple algebra splits +every embedded object of the doubling and its Γ-algebra has a +complex point. -/ +theorem exists_splitting_simple_algebra_doubled + [SmallCategory A] [MonoidalCategory A] [SymmetricCategory A] [Abelian A] + [RigidCategory A] [MonoidalPreadditive A] [CategoryTheory.Linear ℂ A] + [HasFiniteBiproducts A] + (P : SchurPackage.{v}) (P₀ : SchurPackage.{0}) + (hu : HasScalarUnit A) (X : A) (hgen : TensorGeneratedBy A X) + (hgrow : ModerateLengthGrowth A) + : + letI := linearOfScalarUnit (doubledScalarUnit hu) + letI := monoidalLinearOfScalarUnitBraided (doubledScalarUnit hu) + letI := linearOfScalarUnit (indScalarUnit (doubledScalarUnit hu)) + letI := monoidalLinearOfScalarUnitBraided + (indScalarUnit (doubledScalarUnit hu)) + ∃ (𝔹 : Ind (Doubled A)) (_ : MonObj 𝔹) (_ : IsCommMonObj 𝔹), + η[𝔹] ≠ 0 ∧ + (∀ I : Subobject 𝔹, IsIdeal 𝔹 I → I = ⊥ ∨ I = ⊤) ∧ + SplitsOn doubledIndOddLine 𝔹 + (indOf : Doubled A ⥤ Ind (Doubled A)) ∧ + Nonempty (SuperPoint + (gammaAlgebra (Ind (Doubled A)) doubledIndOddLine 𝔹)) := by + let := linearOfScalarUnit (doubledScalarUnit hu) + let := monoidalLinearOfScalarUnitBraided (doubledScalarUnit hu) + let := linearOfScalarUnit (indScalarUnit (doubledScalarUnit hu)) + let := monoidalLinearOfScalarUnitBraided + (indScalarUnit (doubledScalarUnit hu)) + exact exists_splitting_simple_algebra (doubledScalarUnit hu) P P₀ + doubledIndOddLine (Doubled.gen X) + (tensorGeneratedBy_doubled hgen) + (moderateLengthGrowth_doubled hgrow) + (fun Z => exists_lengthLE_of_moderateGrowth + (moderateLengthGrowth_doubled hgrow) Z) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Doubling.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Doubling.lean new file mode 100644 index 0000000000..f4d928aebc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Doubling.lean @@ -0,0 +1,1674 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive + +/-! +# The ℤ/2-graded doubling of a category + +Deligne 2.11's device: the category of super-objects over an +ambient category `A`. An object is a pair of objects of `A`, the +*even* and *odd* components; a morphism is a pair of component +morphisms. The graded tensor product mixes the components in the +usual super pattern, the braiding carries the Koszul sign `-1` on +the odd⊗odd block, and the odd copy of the unit provides an odd +invertible object — exactly the hypothesis pair of Deligne 2.9 — +to a category that may lack one. + +This module mirrors, at the abstract level, the concrete +`SuperVect` construction of `RS/Definitions.lean`: the same +component bookkeeping, with binary biproducts in place of products +of vector spaces. + +The monoidal coherences are not proved by hand: the summing +functor `Doubled A ⥤ A`, `X ↦ X.even ⊞ X.odd`, is faithful, and +`CategoryTheory.Monoidal.induced` transports the pentagon and +triangle from `A` along it. The braiding coherences, which the +Koszul sign prevents from transporting, are discharged by +componentwise matrix checks against the distributor calculus set +up in the `Distributors` section. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Limits MonoidalCategory + +universe v u + +noncomputable section + +/-- A super-object over `A`: a pair of objects of `A`, thought of +as the even and odd graded components. -/ +structure Doubled (A : Type u) : Type u where + /-- The even component. -/ + even : A + /-- The odd component. -/ + odd : A + +namespace Doubled + +variable {A : Type u} + +/-- A morphism of super-objects: a pair of component morphisms, +preserving the grading. -/ +@[ext] +structure Hom + [Category.{v} A] + (X Y : Doubled A) where + /-- The even component of the morphism. -/ + even : X.even ⟶ Y.even + /-- The odd component of the morphism. -/ + odd : X.odd ⟶ Y.odd + +/-- Super-objects form a category with componentwise identities +and composition. -/ +instance instCategory [Category.{v} A] : Category (Doubled A) where + Hom := Hom + id X := ⟨𝟙 X.even, 𝟙 X.odd⟩ + comp f g := ⟨f.even ≫ g.even, f.odd ≫ g.odd⟩ + +/-- The even component of a morphism of super-objects. -/ +def evenHom [Category.{v} A] + {X Y : Doubled A} (f : X ⟶ Y) : X.even ⟶ Y.even := + Hom.even f + +/-- The odd component of a morphism of super-objects. -/ +def oddHom [Category.{v} A] + {X Y : Doubled A} (f : X ⟶ Y) : X.odd ⟶ Y.odd := + Hom.odd f + +/-- Morphisms of super-objects agreeing in both components are +equal. -/ +@[ext] +theorem hom_ext [Category.{v} A] + {X Y : Doubled A} {f g : X ⟶ Y} + (he : evenHom f = evenHom g) (ho : oddHom f = oddHom g) : + f = g := + Hom.ext he ho + +/-- A morphism of super-objects from a pair of component +morphisms. -/ +def homMk [Category.{v} A] + {X Y : Doubled A} (fe : X.even ⟶ Y.even) + (fo : X.odd ⟶ Y.odd) : X ⟶ Y := + ⟨fe, fo⟩ + +@[simp] +theorem evenHom_homMk [Category.{v} A] + {X Y : Doubled A} (fe : X.even ⟶ Y.even) + (fo : X.odd ⟶ Y.odd) : evenHom (homMk fe fo) = fe := + rfl + +@[simp] +theorem oddHom_homMk [Category.{v} A] + {X Y : Doubled A} (fe : X.even ⟶ Y.even) + (fo : X.odd ⟶ Y.odd) : oddHom (homMk fe fo) = fo := + rfl + +@[simp] +theorem evenHom_id [Category.{v} A] + (X : Doubled A) : evenHom (𝟙 X) = 𝟙 X.even := + rfl + +@[simp] +theorem oddHom_id [Category.{v} A] + (X : Doubled A) : oddHom (𝟙 X) = 𝟙 X.odd := + rfl + +@[simp] +theorem evenHom_comp [Category.{v} A] + {X Y Z : Doubled A} (f : X ⟶ Y) (g : Y ⟶ Z) : + evenHom (f ≫ g) = evenHom f ≫ evenHom g := + rfl + +@[simp] +theorem oddHom_comp [Category.{v} A] + {X Y Z : Doubled A} (f : X ⟶ Y) (g : Y ⟶ Z) : + oddHom (f ≫ g) = oddHom f ≫ oddHom g := + rfl + +/-- An isomorphism of super-objects from a pair of component +isomorphisms. -/ +@[simps] +def isoMk [Category.{v} A] + {X Y : Doubled A} (e : X.even ≅ Y.even) + (o : X.odd ≅ Y.odd) : X ≅ Y where + hom := homMk e.hom o.hom + inv := homMk e.inv o.inv + hom_inv_id := by ext <;> simp + inv_hom_id := by ext <;> simp + +section Preadditive + +/-- The componentwise zero morphism. -/ +instance homZero [Category.{v} A] [Preadditive A] + (X Y : Doubled A) : Zero (X ⟶ Y) := + ⟨homMk 0 0⟩ + +/-- Componentwise addition of morphisms. -/ +instance homAdd [Category.{v} A] [Preadditive A] + (X Y : Doubled A) : Add (X ⟶ Y) := + ⟨fun f g => homMk (evenHom f + evenHom g) (oddHom f + oddHom g)⟩ + +/-- Componentwise negation of morphisms. -/ +instance homNeg [Category.{v} A] [Preadditive A] + (X Y : Doubled A) : Neg (X ⟶ Y) := + ⟨fun f => homMk (-evenHom f) (-oddHom f)⟩ + +/-- The componentwise additive group of morphisms. -/ +instance homAddCommGroup [Category.{v} A] [Preadditive A] + (X Y : Doubled A) : AddCommGroup (X ⟶ Y) where + nsmul := nsmulRec + zsmul := zsmulRec + add_assoc _ _ _ := Hom.ext (add_assoc _ _ _) (add_assoc _ _ _) + zero_add _ := Hom.ext (zero_add _) (zero_add _) + add_zero _ := Hom.ext (add_zero _) (add_zero _) + add_comm _ _ := Hom.ext (add_comm _ _) (add_comm _ _) + neg_add_cancel _ := + Hom.ext (neg_add_cancel _) (neg_add_cancel _) + +@[simp] +theorem evenHom_add [Category.{v} A] [Preadditive A] + {X Y : Doubled A} (f g : X ⟶ Y) : + evenHom (f + g) = evenHom f + evenHom g := + rfl + +@[simp] +theorem oddHom_add [Category.{v} A] [Preadditive A] + {X Y : Doubled A} (f g : X ⟶ Y) : + oddHom (f + g) = oddHom f + oddHom g := + rfl + +@[simp] +theorem evenHom_zero [Category.{v} A] [Preadditive A] + {X Y : Doubled A} : + evenHom (0 : X ⟶ Y) = 0 := + rfl + +@[simp] +theorem oddHom_zero [Category.{v} A] [Preadditive A] + {X Y : Doubled A} : + oddHom (0 : X ⟶ Y) = 0 := + rfl + +@[simp] +theorem evenHom_neg [Category.{v} A] [Preadditive A] + {X Y : Doubled A} (f : X ⟶ Y) : + evenHom (-f) = -evenHom f := + rfl + +@[simp] +theorem oddHom_neg [Category.{v} A] [Preadditive A] + {X Y : Doubled A} (f : X ⟶ Y) : + oddHom (-f) = -oddHom f := + rfl + +@[simp] +theorem evenHom_sub [Category.{v} A] [Preadditive A] + {X Y : Doubled A} (f g : X ⟶ Y) : + evenHom (f - g) = evenHom f - evenHom g := by + rw [sub_eq_add_neg, sub_eq_add_neg, evenHom_add, evenHom_neg] + +@[simp] +theorem oddHom_sub [Category.{v} A] [Preadditive A] + {X Y : Doubled A} (f g : X ⟶ Y) : + oddHom (f - g) = oddHom f - oddHom g := by + rw [sub_eq_add_neg, sub_eq_add_neg, oddHom_add, oddHom_neg] + +/-- The doubling of a preadditive category is preadditive, +componentwise. -/ +instance instPreadditive + [Category.{v} A] [Preadditive A] : Preadditive (Doubled A) where + add_comp _ _ _ _ _ _ := + Hom.ext (Preadditive.add_comp _ _ _ _ _ _) + (Preadditive.add_comp _ _ _ _ _ _) + comp_add _ _ _ _ _ _ := + Hom.ext (Preadditive.comp_add _ _ _ _ _ _) + (Preadditive.comp_add _ _ _ _ _ _) + +/-- A super-object with two zero components is a zero object. -/ +theorem isZero [Category.{v} A] + (X : Doubled A) (he : IsZero X.even) + (ho : IsZero X.odd) : IsZero X where + unique_to _ := + ⟨⟨⟨homMk (he.to_ _) (ho.to_ _)⟩, + fun _ => Hom.ext (he.eq_of_src _ _) (ho.eq_of_src _ _)⟩⟩ + unique_from _ := + ⟨⟨⟨homMk (he.from_ _) (ho.from_ _)⟩, + fun _ => Hom.ext (he.eq_of_tgt _ _) (ho.eq_of_tgt _ _)⟩⟩ + +open ZeroObject in +/-- The doubling of a category with a zero object has a zero +object, with both components zero. -/ +instance instHasZeroObject [Category.{v} A] + [HasZeroObject A] : + HasZeroObject (Doubled A) := + ⟨⟨0, 0⟩, isZero _ (isZero_zero A) (isZero_zero A)⟩ + +end Preadditive + +section Linear + +/-- The componentwise ℂ-module of morphisms. -/ +instance homModule [Category.{v} A] [Preadditive A] [CategoryTheory.Linear ℂ A] + (X Y : Doubled A) : Module ℂ (X ⟶ Y) where + smul c f := homMk (c • evenHom f) (c • oddHom f) + one_smul _ := Hom.ext (one_smul _ _) (one_smul _ _) + mul_smul _ _ _ := Hom.ext (mul_smul _ _ _) (mul_smul _ _ _) + smul_zero _ := Hom.ext (smul_zero _) (smul_zero _) + smul_add _ _ _ := Hom.ext (smul_add _ _ _) (smul_add _ _ _) + add_smul _ _ _ := Hom.ext (add_smul _ _ _) (add_smul _ _ _) + zero_smul _ := Hom.ext (zero_smul _ _) (zero_smul _ _) + +@[simp] +theorem evenHom_smul + [Category.{v} A] [Preadditive A] [CategoryTheory.Linear ℂ A] + {X Y : Doubled A} (c : ℂ) (f : X ⟶ Y) : + evenHom (c • f) = c • evenHom f := + rfl + +@[simp] +theorem oddHom_smul [Category.{v} A] [Preadditive A] [CategoryTheory.Linear ℂ A] + {X Y : Doubled A} (c : ℂ) (f : X ⟶ Y) : + oddHom (c • f) = c • oddHom f := + rfl + +/-- The doubling of a ℂ-linear category is ℂ-linear, +componentwise. -/ +instance instLinear + [Category.{v} A] [Preadditive A] [CategoryTheory.Linear ℂ A] : + CategoryTheory.Linear ℂ (Doubled A) where + smul_comp _ _ _ _ _ _ := + Hom.ext (Linear.smul_comp _ _ _ _ _ _) + (Linear.smul_comp _ _ _ _ _ _) + comp_smul _ _ _ _ _ _ := + Hom.ext (Linear.comp_smul _ _ _ _ _ _) + (Linear.comp_smul _ _ _ _ _ _) + +end Linear + +section Distributors + +/-- The matrix map out of a right-whiskered binary biproduct. -/ +def descRight [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] + {M N Z T : A} (f : M ⊗ Z ⟶ T) (g : N ⊗ Z ⟶ T) : + (M ⊞ N) ⊗ Z ⟶ T := + (biprodTensorIso M N Z).hom ≫ biprod.desc f g + +/-- The matrix map out of a left-whiskered binary biproduct. -/ +def descLeft [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] + {X M N T : A} (f : X ⊗ M ⟶ T) (g : X ⊗ N ⟶ T) : + X ⊗ (M ⊞ N) ⟶ T := + (tensorBiprodIso X M N).hom ≫ biprod.desc f g + +@[reassoc (attr := simp)] +theorem inl_descRight [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] + {M N Z T : A} (f : M ⊗ Z ⟶ T) + (g : N ⊗ Z ⟶ T) : (biprod.inl ▷ Z) ≫ descRight f g = f := by + simp [descRight] + +@[reassoc (attr := simp)] +theorem inr_descRight [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] + {M N Z T : A} (f : M ⊗ Z ⟶ T) + (g : N ⊗ Z ⟶ T) : (biprod.inr ▷ Z) ≫ descRight f g = g := by + simp [descRight] + +@[reassoc (attr := simp)] +theorem inl_descLeft [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] + {X M N T : A} (f : X ⊗ M ⟶ T) + (g : X ⊗ N ⟶ T) : (X ◁ biprod.inl) ≫ descLeft f g = f := by + simp [descLeft] + +@[reassoc (attr := simp)] +theorem inr_descLeft [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] + {X M N T : A} (f : X ⊗ M ⟶ T) + (g : X ⊗ N ⟶ T) : (X ◁ biprod.inr) ≫ descLeft f g = g := by + simp [descLeft] + +/-- `inl_descRight` in tensor-of-morphisms shape. Not a simp +lemma: `⊗ₘ 𝟙` normalises to the whiskering, where +`inl_descRight` already applies. -/ +@[reassoc] +theorem inl_id_descRight [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] + {M N Z T : A} (f : M ⊗ Z ⟶ T) + (g : N ⊗ Z ⟶ T) : + (biprod.inl ⊗ₘ 𝟙 Z) ≫ descRight f g = f := by + rw [tensorHom_id, inl_descRight] + +/-- `inr_descRight` in tensor-of-morphisms shape. Not a simp +lemma: `⊗ₘ 𝟙` normalises to the whiskering, where +`inr_descRight` already applies. -/ +@[reassoc] +theorem inr_id_descRight [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] + {M N Z T : A} (f : M ⊗ Z ⟶ T) + (g : N ⊗ Z ⟶ T) : + (biprod.inr ⊗ₘ 𝟙 Z) ≫ descRight f g = g := by + rw [tensorHom_id, inr_descRight] + +/-- `inl_descLeft` in tensor-of-morphisms shape. Not a simp +lemma: `𝟙 ⊗ₘ` normalises to the whiskering, where `inl_descLeft` +already applies. -/ +@[reassoc] +theorem id_inl_descLeft [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] + {X M N T : A} (f : X ⊗ M ⟶ T) + (g : X ⊗ N ⟶ T) : + (𝟙 X ⊗ₘ biprod.inl) ≫ descLeft f g = f := by + rw [id_tensorHom, inl_descLeft] + +/-- `inr_descLeft` in tensor-of-morphisms shape. Not a simp +lemma: `𝟙 ⊗ₘ` normalises to the whiskering, where `inr_descLeft` +already applies. -/ +@[reassoc] +theorem id_inr_descLeft [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] + {X M N T : A} (f : X ⊗ M ⟶ T) + (g : X ⊗ N ⟶ T) : + (𝟙 X ⊗ₘ biprod.inr) ≫ descLeft f g = g := by + rw [id_tensorHom, inr_descLeft] + +@[reassoc (attr := simp)] +theorem inl_map_whiskerRight + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + {M N M' N' Z : A} (f : M ⟶ M') + (g : N ⟶ N') : + (biprod.inl ▷ Z) ≫ (biprod.map f g ▷ Z) = + (f ▷ Z) ≫ (biprod.inl ▷ Z) := by + rw [← comp_whiskerRight, biprod.inl_map, comp_whiskerRight] + +@[reassoc (attr := simp)] +theorem inr_map_whiskerRight + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + {M N M' N' Z : A} (f : M ⟶ M') + (g : N ⟶ N') : + (biprod.inr ▷ Z) ≫ (biprod.map f g ▷ Z) = + (g ▷ Z) ≫ (biprod.inr ▷ Z) := by + rw [← comp_whiskerRight, biprod.inr_map, comp_whiskerRight] + +@[reassoc (attr := simp)] +theorem inl_desc_whiskerRight + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + {M N T Z : A} (f : M ⟶ T) + (g : N ⟶ T) : + (biprod.inl ▷ Z) ≫ (biprod.desc f g ▷ Z) = f ▷ Z := by + rw [← comp_whiskerRight, biprod.inl_desc] + +@[reassoc (attr := simp)] +theorem inr_desc_whiskerRight + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + {M N T Z : A} (f : M ⟶ T) + (g : N ⟶ T) : + (biprod.inr ▷ Z) ≫ (biprod.desc f g ▷ Z) = g ▷ Z := by + rw [← comp_whiskerRight, biprod.inr_desc] + +@[reassoc (attr := simp)] +theorem inl_map_whiskerLeft + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + {X M N M' N' : A} (f : M ⟶ M') + (g : N ⟶ N') : + (X ◁ biprod.inl) ≫ (X ◁ biprod.map f g) = + (X ◁ f) ≫ (X ◁ biprod.inl) := by + rw [← whiskerLeft_comp, biprod.inl_map, whiskerLeft_comp] + +@[reassoc (attr := simp)] +theorem inr_map_whiskerLeft + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + {X M N M' N' : A} (f : M ⟶ M') + (g : N ⟶ N') : + (X ◁ biprod.inr) ≫ (X ◁ biprod.map f g) = + (X ◁ g) ≫ (X ◁ biprod.inr) := by + rw [← whiskerLeft_comp, biprod.inr_map, whiskerLeft_comp] + +@[reassoc (attr := simp)] +theorem inl_desc_whiskerLeft + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + {X M N T : A} (f : M ⟶ T) + (g : N ⟶ T) : + (X ◁ biprod.inl) ≫ (X ◁ biprod.desc f g) = X ◁ f := by + rw [← whiskerLeft_comp, biprod.inl_desc] + +@[reassoc (attr := simp)] +theorem inr_desc_whiskerLeft + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + {X M N T : A} (f : M ⟶ T) + (g : N ⟶ T) : + (X ◁ biprod.inr) ≫ (X ◁ biprod.desc f g) = X ◁ g := by + rw [← whiskerLeft_comp, biprod.inr_desc] + +@[reassoc (attr := simp)] +theorem whiskerLeft_lift_descLeft + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] + {X M N T U : A} (f : U ⟶ M) + (g : U ⟶ N) (h : X ⊗ M ⟶ T) (k : X ⊗ N ⟶ T) : + (X ◁ biprod.lift f g) ≫ descLeft h k = + (X ◁ f) ≫ h + (X ◁ g) ≫ k := by + rw [descLeft, ← Category.assoc] + rw [show (X ◁ biprod.lift f g) ≫ (tensorBiprodIso X M N).hom = + biprod.lift (X ◁ f) (X ◁ g) by + apply biprod.hom_ext <;> simp [tensorBiprodIso, ← whiskerLeft_comp]] + rw [biprod.lift_desc] + +@[reassoc (attr := simp)] +theorem lift_whiskerRight_descRight + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] + {M N Z T U : A} (f : U ⟶ M) + (g : U ⟶ N) (h : M ⊗ Z ⟶ T) (k : N ⊗ Z ⟶ T) : + (biprod.lift f g ▷ Z) ≫ descRight h k = + (f ▷ Z) ≫ h + (g ▷ Z) ≫ k := by + rw [descRight, ← Category.assoc] + rw [show (biprod.lift f g ▷ Z) ≫ (biprodTensorIso M N Z).hom = + biprod.lift (f ▷ Z) (g ▷ Z) by + apply biprod.hom_ext <;> simp [biprodTensorIso, ← comp_whiskerRight]] + rw [biprod.lift_desc] + +/-- Maps out of a right-whiskered binary biproduct are determined +by their composites with the whiskered inclusions. -/ +theorem tensorRight_ext [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] + {M N Z T : A} {f g : (M ⊞ N) ⊗ Z ⟶ T} + (h₁ : (biprod.inl ▷ Z) ≫ f = (biprod.inl ▷ Z) ≫ g) + (h₂ : (biprod.inr ▷ Z) ≫ f = (biprod.inr ▷ Z) ≫ g) : f = g := by + rw [← cancel_epi (biprodTensorIso M N Z).inv] + apply biprod.hom_ext' + · simpa only [biprodTensorIso, biprod.inl_desc_assoc] using h₁ + · simpa only [biprodTensorIso, biprod.inr_desc_assoc] using h₂ + +/-- Maps out of a left-whiskered binary biproduct are determined +by their composites with the whiskered inclusions. -/ +theorem tensorLeft_ext [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] + {X M N T : A} {f g : X ⊗ (M ⊞ N) ⟶ T} + (h₁ : (X ◁ biprod.inl) ≫ f = (X ◁ biprod.inl) ≫ g) + (h₂ : (X ◁ biprod.inr) ≫ f = (X ◁ biprod.inr) ≫ g) : f = g := by + rw [← cancel_epi (tensorBiprodIso X M N).inv] + apply biprod.hom_ext' + · simpa only [tensorBiprodIso, biprod.inl_desc_assoc] using h₁ + · simpa only [tensorBiprodIso, biprod.inr_desc_assoc] using h₂ + +end Distributors + +section GradedTensor + +/-- The graded tensor product of super-objects: parities add, so +each component of the product is a biproduct of two mixed blocks. -/ +abbrev tensorObj [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + (X Y : Doubled A) : Doubled A where + even := X.even ⊗ Y.even ⊞ X.odd ⊗ Y.odd + odd := X.even ⊗ Y.odd ⊞ X.odd ⊗ Y.even + +@[simp] +theorem tensorObj_even [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + (X Y : Doubled A) : + (tensorObj X Y).even = (X.even ⊗ Y.even ⊞ X.odd ⊗ Y.odd) := + rfl + +@[simp] +theorem tensorObj_odd [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + (X Y : Doubled A) : + (tensorObj X Y).odd = (X.even ⊗ Y.odd ⊞ X.odd ⊗ Y.even) := + rfl + +/-- The graded tensor product of morphisms, blockwise. -/ +def tensorHom [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + {X₁ Y₁ X₂ Y₂ : Doubled A} (f : X₁ ⟶ Y₁) + (g : X₂ ⟶ Y₂) : tensorObj X₁ X₂ ⟶ tensorObj Y₁ Y₂ := + homMk + (biprod.map (evenHom f ⊗ₘ evenHom g) (oddHom f ⊗ₘ oddHom g)) + (biprod.map (evenHom f ⊗ₘ oddHom g) (oddHom f ⊗ₘ evenHom g)) + +/-- Left whiskering of super-objects, blockwise. -/ +def whiskerLeft [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + (X : Doubled A) {Y₁ Y₂ : Doubled A} (g : Y₁ ⟶ Y₂) : + tensorObj X Y₁ ⟶ tensorObj X Y₂ := + homMk + (biprod.map (X.even ◁ evenHom g) (X.odd ◁ oddHom g)) + (biprod.map (X.even ◁ oddHom g) (X.odd ◁ evenHom g)) + +/-- Right whiskering of super-objects, blockwise. -/ +def whiskerRight [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + {X₁ X₂ : Doubled A} (f : X₁ ⟶ X₂) (Y : Doubled A) : + tensorObj X₁ Y ⟶ tensorObj X₂ Y := + homMk + (biprod.map (evenHom f ▷ Y.even) (oddHom f ▷ Y.odd)) + (biprod.map (evenHom f ▷ Y.odd) (oddHom f ▷ Y.even)) + +/-- The even component of the associator: each of the four parity +blocks re-associates through `A`'s associator and is routed to the +matching block of the right-nested product. -/ +def assocEven [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] + (X Y Z : Doubled A) : + (tensorObj (tensorObj X Y) Z).even ≅ + (tensorObj X (tensorObj Y Z)).even where + hom := biprod.desc + (descRight + ((α_ X.even Y.even Z.even).hom ≫ + X.even ◁ biprod.inl ≫ biprod.inl) + ((α_ X.odd Y.odd Z.even).hom ≫ + X.odd ◁ biprod.inr ≫ biprod.inr)) + (descRight + ((α_ X.even Y.odd Z.odd).hom ≫ + X.even ◁ biprod.inr ≫ biprod.inl) + ((α_ X.odd Y.even Z.odd).hom ≫ + X.odd ◁ biprod.inl ≫ biprod.inr)) + inv := biprod.desc + (descLeft + ((α_ X.even Y.even Z.even).inv ≫ + biprod.inl ▷ Z.even ≫ biprod.inl) + ((α_ X.even Y.odd Z.odd).inv ≫ + biprod.inl ▷ Z.odd ≫ biprod.inr)) + (descLeft + ((α_ X.odd Y.even Z.odd).inv ≫ + biprod.inr ▷ Z.odd ≫ biprod.inr) + ((α_ X.odd Y.odd Z.even).inv ≫ + biprod.inr ▷ Z.even ≫ biprod.inl)) + hom_inv_id := by + apply biprod.hom_ext' <;> apply tensorRight_ext <;> simp + inv_hom_id := by + apply biprod.hom_ext' <;> apply tensorLeft_ext <;> simp + +/-- The odd component of the associator. -/ +def assocOdd [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] + (X Y Z : Doubled A) : + (tensorObj (tensorObj X Y) Z).odd ≅ + (tensorObj X (tensorObj Y Z)).odd where + hom := biprod.desc + (descRight + ((α_ X.even Y.even Z.odd).hom ≫ + X.even ◁ biprod.inl ≫ biprod.inl) + ((α_ X.odd Y.odd Z.odd).hom ≫ + X.odd ◁ biprod.inr ≫ biprod.inr)) + (descRight + ((α_ X.even Y.odd Z.even).hom ≫ + X.even ◁ biprod.inr ≫ biprod.inl) + ((α_ X.odd Y.even Z.even).hom ≫ + X.odd ◁ biprod.inl ≫ biprod.inr)) + inv := biprod.desc + (descLeft + ((α_ X.even Y.even Z.odd).inv ≫ + biprod.inl ▷ Z.odd ≫ biprod.inl) + ((α_ X.even Y.odd Z.even).inv ≫ + biprod.inl ▷ Z.even ≫ biprod.inr)) + (descLeft + ((α_ X.odd Y.even Z.even).inv ≫ + biprod.inr ▷ Z.even ≫ biprod.inr) + ((α_ X.odd Y.odd Z.odd).inv ≫ + biprod.inr ▷ Z.odd ≫ biprod.inl)) + hom_inv_id := by + apply biprod.hom_ext' <;> apply tensorRight_ext <;> simp + inv_hom_id := by + apply biprod.hom_ext' <;> apply tensorLeft_ext <;> simp + +end GradedTensor + +section Total + +/-- The summing functor `X ↦ X.even ⊞ X.odd`. It is faithful, and +the monoidal coherences of the doubling are induced along it. -/ +abbrev total [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] : + Doubled A ⥤ A where + obj X := X.even ⊞ X.odd + map f := biprod.map (evenHom f) (oddHom f) + map_id _ := by ext <;> simp + map_comp _ _ := by ext <;> simp + +@[simp] +theorem total_obj [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + (X : Doubled A) : + total.obj X = (X.even ⊞ X.odd) := + rfl + +@[simp] +theorem total_map [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + {X Y : Doubled A} (f : X ⟶ Y) : + total.map f = biprod.map (evenHom f) (oddHom f) := + rfl + +/-- The summing functor is faithful: both components are recovered +as matrix entries. -/ +instance [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] : + (total (A := A)).Faithful where + map_injective {X Y f g} h := by + ext + · calc evenHom f + = biprod.inl ≫ total.map f ≫ biprod.fst := by simp + _ = biprod.inl ≫ total.map g ≫ biprod.fst := by rw [h] + _ = evenHom g := by simp + · calc oddHom f + = biprod.inr ≫ total.map f ≫ biprod.snd := by simp + _ = biprod.inr ≫ total.map g ≫ biprod.snd := by rw [h] + _ = oddHom g := by simp + +end Total + +section UnitAndStruct + +open ZeroObject + +/-- The monoidal unit of the doubling: the unit of `A` in even +degree, the zero object in odd degree. -/ +abbrev unit [Category.{v} A] [MonoidalCategory A] [HasZeroObject A] : Doubled A := + ⟨𝟙_ A, 0⟩ + +/-- A left tensor factor which is the zero object kills the +product. -/ +theorem isZero_zeroTensor [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasZeroObject A] + (M : A) : IsZero ((0 : A) ⊗ M) := + (tensorRight M).map_isZero (isZero_zero A) + +/-- A right tensor factor which is the zero object kills the +product. -/ +theorem isZero_tensorZero [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasZeroObject A] + (M : A) : IsZero (M ⊗ (0 : A)) := + (tensorLeft M).map_isZero (isZero_zero A) + +/-- Collapse of a unit block against a zero block, in the shape of +the left unitor components. -/ +def leftUnitorComp [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (M M' : A) : + ((𝟙_ A) ⊗ M ⊞ (0 : A) ⊗ M') ≅ M where + hom := biprod.desc (λ_ M).hom 0 + inv := (λ_ M).inv ≫ biprod.inl + hom_inv_id := by + apply biprod.hom_ext' + · simp + · exact (isZero_zeroTensor M').eq_of_src _ _ + inv_hom_id := by simp + +/-- Collapse of a unit block against a zero block, in the shape of +the even right unitor component. -/ +def rightUnitorComp [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (M M' : A) : + (M ⊗ 𝟙_ A ⊞ M' ⊗ (0 : A)) ≅ M where + hom := biprod.desc (ρ_ M).hom 0 + inv := (ρ_ M).inv ≫ biprod.inl + hom_inv_id := by + apply biprod.hom_ext' + · simp + · exact (isZero_tensorZero M').eq_of_src _ _ + inv_hom_id := by simp + +/-- Collapse of a unit block against a zero block, in the shape of +the odd right unitor component. -/ +def rightUnitorCompOdd [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (M M' : A) : + (M' ⊗ (0 : A) ⊞ M ⊗ 𝟙_ A) ≅ M where + hom := biprod.desc 0 (ρ_ M).hom + inv := (ρ_ M).inv ≫ biprod.inr + hom_inv_id := by + apply biprod.hom_ext' + · exact (isZero_tensorZero M').eq_of_src _ _ + · simp + inv_hom_id := by simp + +/-- The monoidal skeleton of the doubling: graded tensor product, +unit `(𝟙_ A, 0)`, blockwise structural isomorphisms. -/ +instance instMonoidalCategoryStruct + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] : + MonoidalCategoryStruct (Doubled A) where + tensorObj := tensorObj + whiskerLeft := whiskerLeft + whiskerRight := whiskerRight + tensorHom := tensorHom + tensorUnit := unit + associator X Y Z := isoMk (assocEven X Y Z) (assocOdd X Y Z) + leftUnitor X := + isoMk (leftUnitorComp X.even X.odd) (leftUnitorComp X.odd X.even) + rightUnitor X := + isoMk (rightUnitorComp X.even X.odd) + (rightUnitorCompOdd X.odd X.even) + +/-! ### Components of the monoidal notation -/ + +@[simp] +theorem unit_even [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] : + (𝟙_ (Doubled A)).even = 𝟙_ A := + rfl + +@[simp] +theorem unit_odd [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] : + (𝟙_ (Doubled A)).odd = (0 : A) := + rfl + +@[simp] +theorem tensor_even [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X Y : Doubled A) : + (X ⊗ Y).even = (X.even ⊗ Y.even ⊞ X.odd ⊗ Y.odd) := + rfl + +@[simp] +theorem tensor_odd [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X Y : Doubled A) : + (X ⊗ Y).odd = (X.even ⊗ Y.odd ⊞ X.odd ⊗ Y.even) := + rfl + +@[simp] +theorem evenHom_tensor [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + {X₁ Y₁ X₂ Y₂ : Doubled A} (f : X₁ ⟶ Y₁) + (g : X₂ ⟶ Y₂) : + evenHom (f ⊗ₘ g) = + biprod.map (evenHom f ⊗ₘ evenHom g) (oddHom f ⊗ₘ oddHom g) := + rfl + +@[simp] +theorem oddHom_tensor [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + {X₁ Y₁ X₂ Y₂ : Doubled A} (f : X₁ ⟶ Y₁) + (g : X₂ ⟶ Y₂) : + oddHom (f ⊗ₘ g) = + biprod.map (evenHom f ⊗ₘ oddHom g) (oddHom f ⊗ₘ evenHom g) := + rfl + +@[simp] +theorem evenHom_whiskerLeft + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X : Doubled A) {Y₁ Y₂ : Doubled A} + (g : Y₁ ⟶ Y₂) : + evenHom (X ◁ g) = + biprod.map (X.even ◁ evenHom g) (X.odd ◁ oddHom g) := + rfl + +@[simp] +theorem oddHom_whiskerLeft [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X : Doubled A) {Y₁ Y₂ : Doubled A} + (g : Y₁ ⟶ Y₂) : + oddHom (X ◁ g) = + biprod.map (X.even ◁ oddHom g) (X.odd ◁ evenHom g) := + rfl + +@[simp] +theorem evenHom_whiskerRight + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + {X₁ X₂ : Doubled A} (f : X₁ ⟶ X₂) + (Y : Doubled A) : + evenHom (f ▷ Y) = + biprod.map (evenHom f ▷ Y.even) (oddHom f ▷ Y.odd) := + rfl + +@[simp] +theorem oddHom_whiskerRight + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + {X₁ X₂ : Doubled A} (f : X₁ ⟶ X₂) + (Y : Doubled A) : + oddHom (f ▷ Y) = + biprod.map (evenHom f ▷ Y.odd) (oddHom f ▷ Y.even) := + rfl + +@[simp] +theorem evenHom_associator_hom + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X Y Z : Doubled A) : + evenHom (α_ X Y Z).hom = (assocEven X Y Z).hom := + rfl + +@[simp] +theorem oddHom_associator_hom + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X Y Z : Doubled A) : + oddHom (α_ X Y Z).hom = (assocOdd X Y Z).hom := + rfl + +@[simp] +theorem evenHom_associator_inv + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X Y Z : Doubled A) : + evenHom (α_ X Y Z).inv = (assocEven X Y Z).inv := + rfl + +@[simp] +theorem oddHom_associator_inv + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X Y Z : Doubled A) : + oddHom (α_ X Y Z).inv = (assocOdd X Y Z).inv := + rfl + +@[simp] +theorem evenHom_leftUnitor_hom + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X : Doubled A) : + evenHom (λ_ X).hom = (leftUnitorComp X.even X.odd).hom := + rfl + +@[simp] +theorem oddHom_leftUnitor_hom + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X : Doubled A) : + oddHom (λ_ X).hom = (leftUnitorComp X.odd X.even).hom := + rfl + +@[simp] +theorem evenHom_leftUnitor_inv + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X : Doubled A) : + evenHom (λ_ X).inv = (leftUnitorComp X.even X.odd).inv := + rfl + +@[simp] +theorem oddHom_leftUnitor_inv + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X : Doubled A) : + oddHom (λ_ X).inv = (leftUnitorComp X.odd X.even).inv := + rfl + +@[simp] +theorem evenHom_rightUnitor_hom + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X : Doubled A) : + evenHom (ρ_ X).hom = (rightUnitorComp X.even X.odd).hom := + rfl + +@[simp] +theorem oddHom_rightUnitor_hom + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X : Doubled A) : + oddHom (ρ_ X).hom = (rightUnitorCompOdd X.odd X.even).hom := + rfl + +@[simp] +theorem evenHom_rightUnitor_inv + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X : Doubled A) : + evenHom (ρ_ X).inv = (rightUnitorComp X.even X.odd).inv := + rfl + +@[simp] +theorem oddHom_rightUnitor_inv + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X : Doubled A) : + oddHom (ρ_ X).inv = (rightUnitorCompOdd X.odd X.even).inv := + rfl + +/-- The multiplicative comparison of the summing functor: double +distribution followed by the parity shuffle. -/ +def muIso [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X Y : Doubled A) : + total.obj X ⊗ total.obj Y ≅ total.obj (X ⊗ Y) where + hom := descRight + (descLeft (biprod.inl ≫ biprod.inl) (biprod.inl ≫ biprod.inr)) + (descLeft (biprod.inr ≫ biprod.inr) (biprod.inr ≫ biprod.inl)) + inv := biprod.desc + (biprod.desc (biprod.inl ⊗ₘ biprod.inl) + (biprod.inr ⊗ₘ biprod.inr)) + (biprod.desc (biprod.inl ⊗ₘ biprod.inr) + (biprod.inr ⊗ₘ biprod.inl)) + hom_inv_id := by + apply tensorRight_ext <;> apply tensorLeft_ext <;> + simp [← tensorHom_def'] + inv_hom_id := by + apply biprod.hom_ext' <;> apply biprod.hom_ext' <;> + simp [tensorHom_def'] + +/-- The unit comparison of the summing functor. -/ +def epsIso [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] : + 𝟙_ A ≅ total.obj (𝟙_ (Doubled A)) where + hom := biprod.inl + inv := biprod.fst + hom_inv_id := by simp + inv_hom_id := by + apply biprod.hom_ext' + · simp + · exact (isZero_zero A).eq_of_src _ _ + +/-- The summing functor intertwines the graded tensor of morphisms +with the ambient tensor, through the comparison `muIso`. -/ +@[reassoc] +theorem total_tensorHom_muIso_inv + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + {X₁ Y₁ X₂ Y₂ : Doubled A} + (f : X₁ ⟶ Y₁) (g : X₂ ⟶ Y₂) : + total.map (f ⊗ₘ g) ≫ (muIso Y₁ Y₂).inv = + (muIso X₁ X₂).inv ≫ (total.map f ⊗ₘ total.map g) := by + apply biprod.hom_ext' <;> apply biprod.hom_ext' <;> + simp [muIso] + +/-- The summing functor intertwines graded left whiskering with +ambient left whiskering, through the comparison `muIso`. -/ +@[reassoc] +theorem total_whiskerLeft_muIso_inv + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X : Doubled A) + {Y₁ Y₂ : Doubled A} (g : Y₁ ⟶ Y₂) : + total.map (X ◁ g) ≫ (muIso X Y₂).inv = + (muIso X Y₁).inv ≫ (total.obj X ◁ total.map g) := by + apply biprod.hom_ext' <;> apply biprod.hom_ext' <;> + simp [muIso, ← id_tensorHom] + +/-- The summing functor intertwines graded right whiskering with +ambient right whiskering, through the comparison `muIso`. -/ +@[reassoc] +theorem total_whiskerRight_muIso_inv + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + {X₁ X₂ : Doubled A} + (f : X₁ ⟶ X₂) (Y : Doubled A) : + total.map (f ▷ Y) ≫ (muIso X₂ Y).inv = + (muIso X₁ Y).inv ≫ (total.map f ▷ total.obj Y) := by + apply biprod.hom_ext' <;> apply biprod.hom_ext' <;> + simp [muIso, ← tensorHom_id] + +/-- The summing functor intertwines the graded associator with the +ambient associator, through the comparison `muIso`. -/ +@[reassoc] +theorem total_associator_muIso_inv + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X Y Z : Doubled A) : + total.map (α_ X Y Z).hom ≫ (muIso X (Y ⊗ Z)).inv ≫ + (𝟙 (total.obj X) ⊗ₘ (muIso Y Z).inv) = + (muIso (X ⊗ Y) Z).inv ≫ + ((muIso X Y).inv ⊗ₘ 𝟙 (total.obj Z)) ≫ + (α_ (total.obj X) (total.obj Y) (total.obj Z)).hom := by + apply biprod.hom_ext' <;> apply biprod.hom_ext' <;> + apply tensorRight_ext <;> + simp [muIso, assocEven, assocOdd, ← id_tensorHom, + ← tensorHom_id, inl_id_descRight_assoc, + inr_id_descRight_assoc] + +/-- The inducing data exhibiting the graded structural morphisms +as the images of `A`'s structural morphisms under the parity +distributors. -/ +def totalInducingData [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] : + Monoidal.InducingFunctorData (total (A := A)) where + μIso := muIso + εIso := epsIso + whiskerLeft_eq X _ _ f := by + rw [← Category.assoc, ← total_whiskerLeft_muIso_inv, + Category.assoc, Iso.inv_hom_id, Category.comp_id] + whiskerRight_eq f Y := by + rw [← Category.assoc, ← total_whiskerRight_muIso_inv, + Category.assoc, Iso.inv_hom_id, Category.comp_id] + tensorHom_eq f g := by + rw [← Category.assoc, ← total_tensorHom_muIso_inv, + Category.assoc, Iso.inv_hom_id, Category.comp_id] + associator_eq X Y Z := by + simp only [Iso.trans_hom, Iso.symm_hom, tensorIso_hom, + Iso.refl_hom, Category.assoc] + rw [← total_associator_muIso_inv_assoc] + simp + leftUnitor_eq X := by + simp only [Iso.trans_hom, Iso.symm_hom, tensorIso_hom, + Iso.refl_hom, Category.assoc] + apply biprod.hom_ext' <;> apply biprod.hom_ext' <;> + simp [muIso, epsIso, leftUnitorComp, tensorHom_def, + whisker_exchange_assoc, -comp_whiskerRight, + ← comp_whiskerRight_assoc] + rightUnitor_eq X := by + simp only [Iso.trans_hom, Iso.symm_hom, tensorIso_hom, + Iso.refl_hom, Category.assoc] + apply biprod.hom_ext' <;> apply biprod.hom_ext' <;> + simp [muIso, epsIso, rightUnitorComp, rightUnitorCompOdd, + tensorHom_def, -whiskerLeft_comp, ← whiskerLeft_comp_assoc] + +/-- The doubling of a monoidal category is monoidal, with the +graded tensor product: the coherences are induced along the +faithful summing functor. -/ +instance instMonoidalCategory + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] : + MonoidalCategory (Doubled A) := + Monoidal.induced total totalInducingData + +/-- The summing functor is monoidal. -/ +instance [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] : + (total (A := A)).Monoidal := + Monoidal.fromInducedMonoidal total totalInducingData + +end UnitAndStruct + +section MonoidalPreadditive + +private theorem doubled_whiskerLeft_zero + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X Y Z : Doubled A) : X ◁ (0 : Y ⟶ Z) = 0 := by + ext + · change biprod.map (X.even ◁ (0 : Y.even ⟶ Z.even)) + (X.odd ◁ (0 : Y.odd ⟶ Z.odd)) = + (0 : X.even ⊗ Y.even ⊞ X.odd ⊗ Y.odd ⟶ + X.even ⊗ Z.even ⊞ X.odd ⊗ Z.odd) + apply biprod.hom_ext <;> simp + · change biprod.map (X.even ◁ (0 : Y.odd ⟶ Z.odd)) + (X.odd ◁ (0 : Y.even ⟶ Z.even)) = + (0 : X.even ⊗ Y.odd ⊞ X.odd ⊗ Y.even ⟶ + X.even ⊗ Z.odd ⊞ X.odd ⊗ Z.even) + apply biprod.hom_ext <;> simp + +/-- The doubling of a monoidal preadditive category is monoidal +preadditive, componentwise. Each component equation is restated +(`show`) with its objects in literal biproduct form, so that the +ambient simp lemmas apply. -/ +instance instMonoidalPreadditive + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] : + MonoidalPreadditive (Doubled A) where + whiskerLeft_zero := doubled_whiskerLeft_zero _ _ _ + zero_whiskerRight {X Y Z} := by + ext + · change biprod.map ((0 : Y.even ⟶ Z.even) ▷ X.even) + ((0 : Y.odd ⟶ Z.odd) ▷ X.odd) = + (0 : Y.even ⊗ X.even ⊞ Y.odd ⊗ X.odd ⟶ + Z.even ⊗ X.even ⊞ Z.odd ⊗ X.odd) + apply biprod.hom_ext <;> simp + · change biprod.map ((0 : Y.even ⟶ Z.even) ▷ X.odd) + ((0 : Y.odd ⟶ Z.odd) ▷ X.even) = + (0 : Y.even ⊗ X.odd ⊞ Y.odd ⊗ X.even ⟶ + Z.even ⊗ X.odd ⊞ Z.odd ⊗ X.even) + apply biprod.hom_ext <;> simp + whiskerLeft_add {X Y Z} f g := by + ext + · change biprod.map (X.even ◁ (evenHom f + evenHom g)) + (X.odd ◁ (oddHom f + oddHom g)) = + biprod.map (X.even ◁ evenHom f) (X.odd ◁ oddHom f) + + biprod.map (X.even ◁ evenHom g) (X.odd ◁ oddHom g) + apply biprod.hom_ext <;> simp + · change biprod.map (X.even ◁ (oddHom f + oddHom g)) + (X.odd ◁ (evenHom f + evenHom g)) = + biprod.map (X.even ◁ oddHom f) (X.odd ◁ evenHom f) + + biprod.map (X.even ◁ oddHom g) (X.odd ◁ evenHom g) + apply biprod.hom_ext <;> simp + add_whiskerRight {X Y Z} f g := by + ext + · change biprod.map ((evenHom f + evenHom g) ▷ X.even) + ((oddHom f + oddHom g) ▷ X.odd) = + biprod.map (evenHom f ▷ X.even) (oddHom f ▷ X.odd) + + biprod.map (evenHom g ▷ X.even) (oddHom g ▷ X.odd) + apply biprod.hom_ext <;> simp + · change biprod.map ((evenHom f + evenHom g) ▷ X.odd) + ((oddHom f + oddHom g) ▷ X.even) = + biprod.map (evenHom f ▷ X.odd) (oddHom f ▷ X.even) + + biprod.map (evenHom g ▷ X.odd) (oddHom g ▷ X.even) + apply biprod.hom_ext <;> simp + +/-- The doubling of a monoidal ℂ-linear category is monoidal +ℂ-linear, componentwise. -/ +instance instMonoidalLinear + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + [CategoryTheory.Linear ℂ A] + [MonoidalLinear ℂ A] : MonoidalLinear ℂ (Doubled A) where + whiskerLeft_smul X {Y Z} r f := by + ext + · change biprod.map (X.even ◁ (r • evenHom f)) + (X.odd ◁ (r • oddHom f)) = + r • biprod.map (X.even ◁ evenHom f) (X.odd ◁ oddHom f) + apply biprod.hom_ext <;> simp + · change biprod.map (X.even ◁ (r • oddHom f)) + (X.odd ◁ (r • evenHom f)) = + r • biprod.map (X.even ◁ oddHom f) (X.odd ◁ evenHom f) + apply biprod.hom_ext <;> simp + smul_whiskerRight r {Y Z} f X := by + ext + · change biprod.map ((r • evenHom f) ▷ X.even) + ((r • oddHom f) ▷ X.odd) = + r • biprod.map (evenHom f ▷ X.even) (oddHom f ▷ X.odd) + apply biprod.hom_ext <;> simp + · change biprod.map ((r • evenHom f) ▷ X.odd) + ((r • oddHom f) ▷ X.even) = + r • biprod.map (evenHom f ▷ X.odd) (oddHom f ▷ X.even) + apply biprod.hom_ext <;> simp + +end MonoidalPreadditive + +section Braided + +/-- The even component of the Koszul braiding: `A`'s braiding on +each parity block, with the sign `-1` on the odd⊗odd block. -/ +def braidingEven [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + [SymmetricCategory A] + (X Y : Doubled A) : (X ⊗ Y).even ≅ (Y ⊗ X).even where + hom := biprod.map (β_ X.even Y.even).hom (-(β_ X.odd Y.odd).hom) + inv := biprod.map (β_ Y.even X.even).hom (-(β_ Y.odd X.odd).hom) + hom_inv_id := by apply biprod.hom_ext <;> simp + inv_hom_id := by apply biprod.hom_ext <;> simp + +/-- The odd component of the Koszul braiding: the two mixed blocks +swap through `A`'s braiding, with no sign. -/ +def braidingOdd [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + [SymmetricCategory A] + (X Y : Doubled A) : (X ⊗ Y).odd ≅ (Y ⊗ X).odd where + hom := biprod.desc ((β_ X.even Y.odd).hom ≫ biprod.inr) + ((β_ X.odd Y.even).hom ≫ biprod.inl) + inv := biprod.desc ((β_ Y.even X.odd).hom ≫ biprod.inr) + ((β_ Y.odd X.even).hom ≫ biprod.inl) + hom_inv_id := by apply biprod.hom_ext' <;> simp + inv_hom_id := by apply biprod.hom_ext' <;> simp + +/-- The doubling of a symmetric category is braided, with the +Koszul-signed braiding. -/ +instance instBraidedCategory + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + [SymmetricCategory A] : BraidedCategory (Doubled A) where + braiding X Y := isoMk (braidingEven X Y) (braidingOdd X Y) + braiding_naturality_right X {_ _} f := by + ext <;> apply biprod.hom_ext' <;> + simp [braidingEven, braidingOdd] + braiding_naturality_left f Z := by + ext <;> apply biprod.hom_ext' <;> + simp [braidingEven, braidingOdd] + hexagon_forward X Y Z := by + ext + · apply biprod.hom_ext' + · apply tensorRight_ext + · simp [braidingEven, braidingOdd, assocEven] + · simp [braidingEven, braidingOdd, assocEven, + Preadditive.neg_comp, Preadditive.comp_neg] + · apply tensorRight_ext + · simp [braidingEven, braidingOdd, assocEven] + · simp [braidingEven, braidingOdd, assocEven, + Preadditive.neg_comp, Preadditive.comp_neg] + · apply biprod.hom_ext' <;> apply tensorRight_ext <;> + simp [braidingEven, braidingOdd, assocOdd, + Preadditive.neg_comp, Preadditive.comp_neg] + hexagon_reverse X Y Z := by + ext + · apply biprod.hom_ext' + · apply tensorLeft_ext + · simp [braidingEven, braidingOdd, assocEven] + · simp [braidingEven, braidingOdd, assocEven, + Preadditive.neg_comp, Preadditive.comp_neg] + · apply tensorLeft_ext + · simp [braidingEven, braidingOdd, assocEven, + Preadditive.neg_comp, Preadditive.comp_neg] + · simp [braidingEven, braidingOdd, assocEven] + · apply biprod.hom_ext' <;> apply tensorLeft_ext <;> + simp [braidingEven, braidingOdd, assocOdd, + Preadditive.neg_comp, Preadditive.comp_neg] + +/-- The doubling of a symmetric category is symmetric: the Koszul +sign squares away. -/ +instance instSymmetricCategory + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + [SymmetricCategory A] : SymmetricCategory (Doubled A) where + symmetry X Y := by + ext + · change biprod.map (β_ X.even Y.even).hom + (-(β_ X.odd Y.odd).hom) ≫ + biprod.map (β_ Y.even X.even).hom + (-(β_ Y.odd X.odd).hom) = + 𝟙 (X.even ⊗ Y.even ⊞ X.odd ⊗ Y.odd) + apply biprod.hom_ext <;> simp + · change biprod.desc ((β_ X.even Y.odd).hom ≫ biprod.inr) + ((β_ X.odd Y.even).hom ≫ biprod.inl) ≫ + biprod.desc ((β_ Y.even X.odd).hom ≫ biprod.inr) + ((β_ Y.odd X.even).hom ≫ biprod.inl) = + 𝟙 (X.even ⊗ Y.odd ⊞ X.odd ⊗ Y.even) + apply biprod.hom_ext' <;> simp + +end Braided + +section EvenEmbed + +open ZeroObject + +/-- A biproduct of two zero objects is a zero object. -/ +theorem isZero_biprod [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + {M N : A} (hM : IsZero M) (hN : IsZero N) : + IsZero (M ⊞ N) where + unique_to _ := + ⟨⟨⟨biprod.desc (hM.to_ _) (hN.to_ _)⟩, fun _ => + biprod.hom_ext' _ _ (hM.eq_of_src _ _) (hN.eq_of_src _ _)⟩⟩ + unique_from _ := + ⟨⟨⟨biprod.lift (hM.from_ _) (hN.from_ _)⟩, fun _ => + biprod.hom_ext _ _ (hM.eq_of_tgt _ _) (hN.eq_of_tgt _ _)⟩⟩ + +/-- The even embedding `X ↦ (X, 0)`. -/ +abbrev evenEmbed + [Category.{v} A] [Preadditive A] [HasZeroObject A] : A ⥤ Doubled A where + obj X := ⟨X, 0⟩ + map f := homMk f (𝟙 (0 : A)) + map_id _ := rfl + map_comp _ _ := by ext; simp + +@[simp] +theorem evenEmbed_obj_even [Category.{v} A] [Preadditive A] [HasZeroObject A] + (X : A) : (evenEmbed.obj X).even = X := + rfl + +@[simp] +theorem evenEmbed_obj_odd [Category.{v} A] [Preadditive A] [HasZeroObject A] + (X : A) : + (evenEmbed.obj X).odd = (0 : A) := + rfl + +@[simp] +theorem evenHom_evenEmbed_map [Category.{v} A] [Preadditive A] [HasZeroObject A] + {X Y : A} (f : X ⟶ Y) : + evenHom (evenEmbed.map f) = f := + rfl + +/-- The even embedding is faithful. -/ +instance [Category.{v} A] [Preadditive A] [HasZeroObject A] : + (evenEmbed (A := A)).Faithful where + map_injective h := congrArg evenHom h + +/-- The even embedding is full. -/ +instance [Category.{v} A] [Preadditive A] [HasZeroObject A] : + (evenEmbed (A := A)).Full where + map_surjective f := + ⟨evenHom f, hom_ext rfl ((isZero_zero A).eq_of_src _ _)⟩ + +/-- The even embedding is additive. -/ +instance [Category.{v} A] [Preadditive A] [HasZeroObject A] : + (evenEmbed (A := A)).Additive where + map_add := by + intros + ext + · rfl + +/-- The even embedding is ℂ-linear. -/ +instance [Category.{v} A] [Preadditive A] [HasZeroObject A] + [CategoryTheory.Linear ℂ A] : + (evenEmbed (A := A)).Linear ℂ where + map_smul := by + intros + ext + · rfl + +/-- The even embedding is monoidal up to isomorphism: the graded +tensor of two even objects collapses to the even tensor. -/ +def evenEmbedTensorIso [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X Y : A) : + evenEmbed.obj X ⊗ evenEmbed.obj Y ≅ evenEmbed.obj (X ⊗ Y) := + isoMk (isoBiprodZero (isZero_zeroTensor _)).symm + (((isZero_biprod (isZero_tensorZero _) (isZero_zeroTensor _)).iso + (isZero_zero A))) + +/-- The even embedding intertwines the braidings through +`evenEmbedTensorIso`. -/ +theorem evenEmbedTensorIso_braided + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + [SymmetricCategory A] (X Y : A) : + (β_ (evenEmbed.obj X) (evenEmbed.obj Y)).hom ≫ + (evenEmbedTensorIso Y X).hom = + (evenEmbedTensorIso X Y).hom ≫ evenEmbed.map (β_ X Y).hom := by + ext + · change biprod.map (β_ X Y).hom (-(β_ (0 : A) (0 : A)).hom) ≫ + biprod.fst = biprod.fst ≫ (β_ X Y).hom + simp + +/-- The unit comparison of the even embedding: definitional. -/ +def evenEmbedUnitIso [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] : + 𝟙_ (Doubled A) ≅ evenEmbed.obj (𝟙_ A) := + Iso.refl _ + +end EvenEmbed + +section OddUnit + +open ZeroObject + +/-- The odd unit: the unit of `A` placed in odd degree. Together +with `oddUnitSq` and `braiding_oddUnit` this is exactly the +invertible odd object required by Deligne 2.9. -/ +abbrev oddUnit + [Category.{v} A] [MonoidalCategory A] [HasZeroObject A] : Doubled A := + ⟨0, 𝟙_ A⟩ + +@[simp] +theorem oddUnit_even [Category.{v} A] [MonoidalCategory A] [HasZeroObject A] : + (oddUnit (A := A)).even = (0 : A) := + rfl + +@[simp] +theorem oddUnit_odd [Category.{v} A] [MonoidalCategory A] [HasZeroObject A] : + (oddUnit (A := A)).odd = 𝟙_ A := + rfl + +/-- The odd unit squares to the monoidal unit. -/ +def oddUnitSq [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] : + oddUnit ⊗ oddUnit ≅ 𝟙_ (Doubled A) := + isoMk + { hom := biprod.desc 0 (λ_ (𝟙_ A)).hom + inv := (λ_ (𝟙_ A)).inv ≫ biprod.inr + hom_inv_id := by + apply biprod.hom_ext' + · exact (isZero_zeroTensor _).eq_of_src _ _ + · simp + inv_hom_id := by simp } + ((isZero_biprod (isZero_zeroTensor _) (isZero_tensorZero _)).iso + (isZero_zero A)) + +/-- The braiding of the odd unit with itself is `-1`: the Koszul +sign made visible on a single object. -/ +theorem braiding_oddUnit [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + [SymmetricCategory A] : + (β_ (oddUnit (A := A)) oddUnit).hom = -𝟙 (oddUnit ⊗ oddUnit) := by + ext + · change biprod.map (β_ (0 : A) (0 : A)).hom + (-(β_ (𝟙_ A) (𝟙_ A)).hom) = + -𝟙 ((0 : A) ⊗ (0 : A) ⊞ 𝟙_ A ⊗ 𝟙_ A) + apply biprod.hom_ext + · exact (isZero_zeroTensor _).eq_of_tgt _ _ + · simp [braiding_tensorUnit_right, ← unitors_equal, + Preadditive.neg_comp, Preadditive.comp_neg] + · exact (isZero_biprod (isZero_zeroTensor _) + (isZero_tensorZero _)).eq_of_src _ _ + +end OddUnit + +section Biproducts + +/-- The componentwise binary bicone on a pair of super-objects. -/ +def binaryBicone [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + (X Y : Doubled A) : BinaryBicone X Y where + pt := ⟨X.even ⊞ Y.even, X.odd ⊞ Y.odd⟩ + fst := homMk biprod.fst biprod.fst + snd := homMk biprod.snd biprod.snd + inl := homMk biprod.inl biprod.inl + inr := homMk biprod.inr biprod.inr + inl_fst := by ext <;> simp + inl_snd := by ext <;> simp + inr_fst := by ext <;> simp + inr_snd := by ext <;> simp + +/-- The doubling has componentwise binary biproducts. -/ +instance instHasBinaryBiproducts + [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] : + HasBinaryBiproducts (Doubled A) where + has_binary_biproduct X Y := + hasBinaryBiproduct_of_total (binaryBicone X Y) (by + ext + · change biprod.fst ≫ biprod.inl + biprod.snd ≫ biprod.inr = + 𝟙 (X.even ⊞ Y.even) + exact biprod.total + · change biprod.fst ≫ biprod.inl + biprod.snd ≫ biprod.inr = + 𝟙 (X.odd ⊞ Y.odd) + exact biprod.total) + +/-- The doubling has finite products: it has a zero object and +componentwise binary biproducts. -/ +instance instHasFiniteProducts + [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + [HasZeroObject A] : + HasFiniteProducts (Doubled A) := + hasFiniteProducts_of_has_binary_and_terminal + +end Biproducts + +section Decomposition + +open ZeroObject + +/-- Every super-object is the biproduct of its even part and the +odd-unit twist of its odd part: the decomposition through which +Schur-vanishing transports from `A` to the doubling. -/ +def decomposition [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X : Doubled A) : + X ≅ evenEmbed.obj X.even ⊞ (oddUnit ⊗ evenEmbed.obj X.odd) where + hom := biprod.lift (homMk (𝟙 X.even) 0) + (homMk 0 ((λ_ X.odd).inv ≫ biprod.inr)) + inv := biprod.desc (homMk (𝟙 X.even) 0) + (homMk 0 (biprod.desc 0 (λ_ X.odd).hom)) + hom_inv_id := by + rw [biprod.lift_desc] + ext + · change 𝟙 X.even ≫ 𝟙 X.even + + (0 : X.even ⟶ ((0 : A) ⊗ X.odd ⊞ 𝟙_ A ⊗ (0 : A))) ≫ + (0 : ((0 : A) ⊗ X.odd ⊞ 𝟙_ A ⊗ (0 : A)) ⟶ X.even) = + 𝟙 X.even + simp + · change (0 : X.odd ⟶ (0 : A)) ≫ (0 : (0 : A) ⟶ X.odd) + + ((λ_ X.odd).inv ≫ biprod.inr) ≫ + biprod.desc 0 (λ_ X.odd).hom = + 𝟙 X.odd + simp + inv_hom_id := by + apply biprod.hom_ext' <;> apply biprod.hom_ext + · -- (inl, fst) + ext + · simp + · -- (inl, snd) + ext + · exact (isZero_biprod (isZero_zeroTensor _) + (isZero_tensorZero _)).eq_of_tgt _ _ + · -- (inr, fst) + ext + · exact (isZero_biprod (isZero_zeroTensor _) + (isZero_tensorZero _)).eq_of_src _ _ + · -- (inr, snd) + rw [biprod.inr_desc_assoc, Category.assoc, biprod.lift_snd, + Category.comp_id, biprod.inr_snd] + ext + · exact (isZero_biprod (isZero_zeroTensor _) + (isZero_tensorZero _)).eq_of_src _ _ + · change biprod.desc 0 (λ_ X.odd).hom ≫ + (λ_ X.odd).inv ≫ biprod.inr = + 𝟙 ((0 : A) ⊗ (0 : A) ⊞ 𝟙_ A ⊗ X.odd) + apply biprod.hom_ext' + · exact (isZero_zeroTensor _).eq_of_src _ _ + · simp + +end Decomposition + +section Kernels + +/-- The componentwise kernel fork of a morphism of +super-objects. -/ +def kernelFork [Category.{v} A] [Preadditive A] [HasKernels A] + {X Y : Doubled A} (f : X ⟶ Y) : KernelFork f := + KernelFork.ofι + (homMk (kernel.ι (evenHom f)) (kernel.ι (oddHom f)) : + (⟨kernel (evenHom f), kernel (oddHom f)⟩ : Doubled A) ⟶ X) + (by ext <;> simp) + +/-- The componentwise kernel fork is limiting. -/ +def kernelForkIsLimit [Category.{v} A] [Preadditive A] [HasKernels A] + {X Y : Doubled A} (f : X ⟶ Y) : + IsLimit (kernelFork f) := + KernelFork.IsLimit.ofι _ (by ext <;> simp) + (fun g' eq' => homMk + (kernel.lift _ (evenHom g') + (show _ from congrArg evenHom eq')) + (kernel.lift _ (oddHom g') + (show _ from congrArg oddHom eq'))) + (fun g' eq' => by ext <;> simp) + (fun g' eq' m hm => by + ext + · simp only [evenHom_homMk, kernel.lift_ι] + exact congrArg evenHom hm + · simp only [oddHom_homMk, kernel.lift_ι] + exact congrArg oddHom hm) + +/-- The doubling has componentwise kernels. -/ +instance instHasKernels [Category.{v} A] [Preadditive A] [HasKernels A] : + HasKernels (Doubled A) where + has_limit f := HasLimit.mk + { cone := kernelFork f + isLimit := kernelForkIsLimit f } + +end Kernels + +section Cokernels + +/-- The componentwise cokernel cofork of a morphism of +super-objects. -/ +def cokernelCofork [Category.{v} A] [Preadditive A] [HasCokernels A] + {X Y : Doubled A} (f : X ⟶ Y) : + CokernelCofork f := + CokernelCofork.ofπ + (homMk (cokernel.π (evenHom f)) (cokernel.π (oddHom f)) : + Y ⟶ (⟨cokernel (evenHom f), cokernel (oddHom f)⟩ : Doubled A)) + (by ext <;> simp) + +/-- The componentwise cokernel cofork is colimiting. -/ +def cokernelCoforkIsColimit [Category.{v} A] [Preadditive A] [HasCokernels A] + {X Y : Doubled A} (f : X ⟶ Y) : + IsColimit (cokernelCofork f) := + CokernelCofork.IsColimit.ofπ _ (by ext <;> simp) + (fun g' eq' => homMk + (cokernel.desc _ (evenHom g') + (show _ from congrArg evenHom eq')) + (cokernel.desc _ (oddHom g') + (show _ from congrArg oddHom eq'))) + (fun g' eq' => by ext <;> simp) + (fun g' eq' m hm => by + ext + · simp only [evenHom_homMk, cokernel.π_desc] + exact congrArg evenHom hm + · simp only [oddHom_homMk, cokernel.π_desc] + exact congrArg oddHom hm) + +/-- The doubling has componentwise cokernels. -/ +instance instHasCokernels [Category.{v} A] [Preadditive A] [HasCokernels A] : + HasCokernels (Doubled A) where + has_colimit f := HasColimit.mk + { cocone := cokernelCofork f + isColimit := cokernelCoforkIsColimit f } + +end Cokernels + +section IsoComponents + +/-- A morphism of super-objects whose two components are +isomorphisms is an isomorphism. -/ +theorem isIso_of_components [Category.{v} A] + {X Y : Doubled A} (f : X ⟶ Y) + [IsIso (evenHom f)] [IsIso (oddHom f)] : IsIso f := + ⟨homMk (inv (evenHom f)) (inv (oddHom f)), + hom_ext (by simp) (by simp), hom_ext (by simp) (by simp)⟩ + +end IsoComponents + +section Rigid + +open ZeroObject + +/-- Componentwise exact pairings pair the doubled objects: the +evaluations and coevaluations act blockwise on matching parities, +and the odd components vanish. -/ +@[reducible] +def exactPairing [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (P Q : Doubled A) [ExactPairing P.even Q.even] + [ExactPairing P.odd Q.odd] : ExactPairing P Q where + coevaluation' := homMk + (biprod.lift (η_ P.even Q.even) (η_ P.odd Q.odd)) 0 + evaluation' := homMk + (biprod.desc (ε_ P.even Q.even) (ε_ P.odd Q.odd)) 0 + coevaluation_evaluation' := by + ext + · apply biprod.hom_ext' + · simp [assocEven, rightUnitorComp, leftUnitorComp] + · exact (isZero_tensorZero _).eq_of_src _ _ + · apply biprod.hom_ext' + · exact (isZero_tensorZero _).eq_of_src _ _ + · simp [assocOdd, rightUnitorCompOdd, leftUnitorComp] + evaluation_coevaluation' := by + ext + · apply biprod.hom_ext' + · simp [assocEven, rightUnitorComp, leftUnitorComp] + · exact (isZero_zeroTensor _).eq_of_src _ _ + · apply biprod.hom_ext' + · simp [assocOdd, rightUnitorCompOdd, leftUnitorComp] + · exact (isZero_zeroTensor _).eq_of_src _ _ + +/-- The doubling of a right rigid category is right rigid, with +componentwise duals. -/ +instance instRightRigidCategory + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + [RightRigidCategory A] : + RightRigidCategory (Doubled A) where + rightDual X := + { rightDual := ⟨X.evenᘁ, X.oddᘁ⟩ + exact := exactPairing X ⟨X.evenᘁ, X.oddᘁ⟩ } + +/-- The doubling of a left rigid category is left rigid, with +componentwise duals. -/ +instance instLeftRigidCategory + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + [LeftRigidCategory A] : + LeftRigidCategory (Doubled A) where + leftDual X := + { leftDual := ⟨ᘁX.even, ᘁX.odd⟩ + exact := exactPairing ⟨ᘁX.even, ᘁX.odd⟩ X } + +/-- The doubling of a rigid category is rigid. -/ +instance instRigidCategory [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + [RigidCategory A] : + RigidCategory (Doubled A) where + +end Rigid + +end Doubled + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DualityMate.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DualityMate.lean new file mode 100644 index 0000000000..31c4bd18b9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DualityMate.lean @@ -0,0 +1,38 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Duality-intertwining morphisms are invertible + +The per-object kernel of Deligne 3.2: a morphism compatible with +exact pairings on both sides is an isomorphism, with inverse the +mate of its partner. A monoidal natural transformation between +fibre functors supplies exactly this data at every object. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +variable {D : Type u} + +/-- The mate of the partner: the candidate inverse. -/ +noncomputable def dualityMate [Category.{v} D] [MonoidalCategory D] + {X X' Y Y' : D} + [ExactPairing X X'] [ExactPairing Y Y'] (f' : X' ⟶ Y') : + Y ⟶ X := + (λ_ Y).inv ≫ (η_ X X' ▷ Y) ≫ (α_ X X' Y).hom ≫ + (X ◁ (f' ▷ Y)) ≫ (X ◁ ε_ Y Y') ≫ (ρ_ X).hom + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/EvenEmbedMonoidal.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/EvenEmbedMonoidal.lean new file mode 100644 index 0000000000..6943a539bf --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/EvenEmbedMonoidal.lean @@ -0,0 +1,245 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledAbelian + +/-! +# The even embedding is strong braided monoidal + +`RS/Classical/Deligne/Doubling.lean` builds the even embedding +`evenEmbed : A ⥤ Doubled A`, `X ↦ (X, 0)`, together with its +tensor comparison `evenEmbedTensorIso`, its unit comparison +`evenEmbedUnitIso` and the compatibility of the comparison with the +two braidings. This module packages that data as a lax monoidal +structure, upgrades it to a strong monoidal structure — both +comparisons are isomorphisms by construction — and records that the +result is braided. + +Every coherence reduces, by `Doubled.hom_ext`, to a pair of +component identities. The odd component of each target is the zero +object, so the odd half is automatic; the even half is a biproduct +calculation in which the mixed parity blocks are killed because one +of their two factors is the zero object. + +The module also records the exactness of the even embedding. The +even embedding is simultaneously left and right adjoint to the +even-component functor `evenFunctor` of +`RS/Classical/Deligne/DoubledAbelian.lean`, because a morphism into +or out of the zero object is unique; so it preserves all limits and +all colimits, in particular the finite ones. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Limits MonoidalCategory + +universe v u + +noncomputable section + +namespace Doubled + +section Monoidal + +open ZeroObject + +variable {A : Type u} + +/-- The even component of the unit comparison is the identity. -/ +@[simp] +theorem evenHom_evenEmbedUnitIso_hom + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] : + evenHom (evenEmbedUnitIso (A := A)).hom = 𝟙 (𝟙_ A) := + rfl + +/-- The even embedding is lax monoidal: the unit comparison is the +identity, because the unit of `Doubled A` *is* the even embedding +of the unit of `A`, and the tensor comparison is +`evenEmbedTensorIso`. -/ +instance evenEmbedLaxMonoidal + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] : + (evenEmbed (A := A)).LaxMonoidal where + ε := evenEmbedUnitIso.hom + μ X Y := (evenEmbedTensorIso X Y).hom + μ_natural_left := by + intro X Y f X' + ext + · simp [evenEmbedTensorIso, isoBiprodZero] + μ_natural_right := by + intro X Y X' f + ext + · simp [evenEmbedTensorIso, isoBiprodZero] + associativity := by + intro X Y Z + ext + · apply biprod.hom_ext' <;> apply tensorRight_ext <;> + simp [evenEmbedTensorIso, isoBiprodZero, assocEven, + -comp_whiskerRight, -MonoidalCategory.whiskerLeft_comp, + ← comp_whiskerRight_assoc, + ← MonoidalCategory.whiskerLeft_comp] + left_unitality := by + intro X + ext + · apply biprod.hom_ext' <;> + simp [evenEmbedTensorIso, isoBiprodZero, leftUnitorComp] + right_unitality := by + intro X + ext + · apply biprod.hom_ext' <;> + simp [evenEmbedTensorIso, isoBiprodZero, rightUnitorComp] + +/-- The even embedding is strong monoidal: both comparisons are +isomorphisms by construction. -/ +noncomputable instance evenEmbedMonoidal + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] : + (evenEmbed (A := A)).Monoidal := by + haveI hε : IsIso (Functor.LaxMonoidal.ε (evenEmbed (A := A))) := + inferInstanceAs (IsIso (evenEmbedUnitIso (A := A)).hom) + haveI hμ : ∀ X Y : A, + IsIso (Functor.LaxMonoidal.μ (evenEmbed (A := A)) X Y) := + fun X Y => inferInstanceAs (IsIso (evenEmbedTensorIso X Y).hom) + exact CategoryTheory.Functor.Monoidal.ofLaxMonoidal _ + +/-! ### The four structure morphisms + +These are stated after the strong monoidal structure has been +installed, so that their left-hand sides use the instance that a +downstream file resolves. -/ + +@[simp] +theorem evenEmbed_ε [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] : + Functor.LaxMonoidal.ε (evenEmbed (A := A)) = + (evenEmbedUnitIso (A := A)).hom := + rfl + +@[simp] +theorem evenEmbed_μ [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X Y : A) : + Functor.LaxMonoidal.μ (evenEmbed (A := A)) X Y = + (evenEmbedTensorIso X Y).hom := + rfl + +@[simp] +theorem evenEmbed_η [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] : + Functor.OplaxMonoidal.η (evenEmbed (A := A)) = + (evenEmbedUnitIso (A := A)).inv := by + have h : Functor.LaxMonoidal.ε (evenEmbed (A := A)) ≫ + Functor.OplaxMonoidal.η (evenEmbed (A := A)) = 𝟙 _ := + Functor.Monoidal.ε_η _ + calc Functor.OplaxMonoidal.η (evenEmbed (A := A)) + = ((evenEmbedUnitIso (A := A)).inv ≫ + Functor.LaxMonoidal.ε (evenEmbed (A := A))) ≫ + Functor.OplaxMonoidal.η (evenEmbed (A := A)) := by + rw [evenEmbed_ε, Iso.inv_hom_id, Category.id_comp] + _ = (evenEmbedUnitIso (A := A)).inv := by + rw [Category.assoc, h, Category.comp_id] + +@[simp] +theorem evenEmbed_δ [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + (X Y : A) : + Functor.OplaxMonoidal.δ (evenEmbed (A := A)) X Y = + (evenEmbedTensorIso X Y).inv := by + have h : Functor.LaxMonoidal.μ (evenEmbed (A := A)) X Y ≫ + Functor.OplaxMonoidal.δ (evenEmbed (A := A)) X Y = 𝟙 _ := + Functor.Monoidal.μ_δ _ X Y + calc Functor.OplaxMonoidal.δ (evenEmbed (A := A)) X Y + = ((evenEmbedTensorIso X Y).inv ≫ + Functor.LaxMonoidal.μ (evenEmbed (A := A)) X Y) ≫ + Functor.OplaxMonoidal.δ (evenEmbed (A := A)) X Y := by + rw [evenEmbed_μ, Iso.inv_hom_id, Category.id_comp] + _ = (evenEmbedTensorIso X Y).inv := by + rw [Category.assoc, h, Category.comp_id] + +end Monoidal + +section Braided + +open ZeroObject + +variable {A : Type u} + +/-- The even embedding is braided: the Koszul sign is invisible on +purely even objects, so the tensor comparison intertwines the two +braidings. -/ +noncomputable instance evenEmbedBraided + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] + [SymmetricCategory A] : + (evenEmbed (A := A)).Braided where + braided X Y := (evenEmbedTensorIso_braided X Y).symm + +end Braided + +section Exactness + +open ZeroObject + +variable {A : Type u} + +/-- The even embedding is left adjoint to the even-component +functor: a morphism out of the zero object is unique. -/ +def evenEmbedAdjEvenFunctor [Category.{v} A] [Preadditive A] [HasZeroObject A] : + evenEmbed (A := A) ⊣ evenFunctor := + Adjunction.mkOfHomEquiv + { homEquiv := fun _ Y => + { toFun := fun f => evenHom f + invFun := fun g => homMk g ((isZero_zero A).to_ Y.odd) + left_inv := fun _ => + hom_ext rfl ((isZero_zero A).eq_of_src _ _) + right_inv := fun _ => rfl } + homEquiv_naturality_left_symm := fun _ _ => + hom_ext rfl ((isZero_zero A).eq_of_src _ _) + homEquiv_naturality_right := fun _ _ => rfl } + +/-- The even embedding is right adjoint to the even-component +functor: a morphism into the zero object is unique. -/ +def evenFunctorAdjEvenEmbed [Category.{v} A] [Preadditive A] [HasZeroObject A] : + evenFunctor ⊣ evenEmbed (A := A) := + Adjunction.mkOfHomEquiv + { homEquiv := fun Y _ => + { toFun := fun g => homMk g ((isZero_zero A).from_ Y.odd) + invFun := fun f => evenHom f + left_inv := fun _ => rfl + right_inv := fun _ => + hom_ext rfl ((isZero_zero A).eq_of_tgt _ _) } + homEquiv_naturality_left_symm := fun _ _ => rfl + homEquiv_naturality_right := fun _ _ => + hom_ext rfl ((isZero_zero A).eq_of_tgt _ _) } + +/-- Being a right adjoint, the even embedding is left exact. -/ +instance evenEmbedPreservesFiniteLimits + [Category.{v} A] [Preadditive A] [HasZeroObject A] : + PreservesFiniteLimits (evenEmbed (A := A)) := by + have : PreservesLimitsOfSize.{0, 0} (evenEmbed (A := A)) := + (evenFunctorAdjEvenEmbed (A := A)).rightAdjoint_preservesLimits + infer_instance + +/-- Being a left adjoint, the even embedding is right exact. -/ +instance evenEmbedPreservesFiniteColimits + [Category.{v} A] [Preadditive A] [HasZeroObject A] : + PreservesFiniteColimits (evenEmbed (A := A)) := by + have : PreservesColimitsOfSize.{0, 0} (evenEmbed (A := A)) := + (evenEmbedAdjEvenFunctor (A := A)).leftAdjoint_preservesColimits + infer_instance + +end Exactness + +end Doubled + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ExactFromShort.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ExactFromShort.lean new file mode 100644 index 0000000000..08092e703e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ExactFromShort.lean @@ -0,0 +1,78 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExact + +/-! +# Exactness from short exact sequences + +An additive functor between abelian categories that carries short +exact sequences to short exact sequences preserves finite limits and +finite colimits. Mathlib supplies the equivalence as +`CategoryTheory.Functor.exact_tfae`, whose first and fourth entries +are exactly the hypothesis and the pair of conclusions; the general +results below are the named projections of that equivalence, and +the third of them records the intermediate entry, preservation of +homology. + +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Limits + +universe v u v' u' + +section General + +variable {C : Type u} + +/-- **A functor carrying short exact sequences to short exact +sequences preserves finite limits.** -/ +theorem preservesFiniteLimits_of_shortExact + [Category.{v} C] [Abelian C] {D : Type u'} [Category.{v'} D] [Abelian D] + (F : C ⥤ D) [F.Additive] + (h : ∀ (S : CategoryTheory.ShortComplex C), S.ShortExact → + (S.map F).ShortExact) : + Limits.PreservesFiniteLimits F := + have hboth : Limits.PreservesFiniteLimits F ∧ + Limits.PreservesFiniteColimits F := + ((CategoryTheory.Functor.exact_tfae F).out 1 4).mp h + hboth.1 + +/-- **A functor carrying short exact sequences to short exact +sequences preserves finite colimits.** -/ +theorem preservesFiniteColimits_of_shortExact + [Category.{v} C] [Abelian C] {D : Type u'} [Category.{v'} D] [Abelian D] + (F : C ⥤ D) + [F.Additive] + (h : ∀ (S : CategoryTheory.ShortComplex C), S.ShortExact → + (S.map F).ShortExact) : + Limits.PreservesFiniteColimits F := + have hboth : Limits.PreservesFiniteLimits F ∧ + Limits.PreservesFiniteColimits F := + ((CategoryTheory.Functor.exact_tfae F).out 1 4).mp h + hboth.2 + +/-- **A functor carrying short exact sequences to short exact +sequences preserves homology.** This is the intermediate entry of +the same equivalence, from which both preservation statements +above are read off. -/ +theorem preservesHomology_of_shortExact + [Category.{v} C] [Abelian C] {D : Type u'} [Category.{v'} D] [Abelian D] + (F : C ⥤ D) [F.Additive] + (h : ∀ (S : CategoryTheory.ShortComplex C), S.ShortExact → + (S.map F).ShortExact) : + F.PreservesHomology := + ((CategoryTheory.Functor.exact_tfae F).out 1 3).mp h + +end General + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FactorialBeats.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FactorialBeats.lean new file mode 100644 index 0000000000..261a6bc554 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FactorialBeats.lean @@ -0,0 +1,107 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.FactorialBound + +/-! +# The square root of the factorial beats every geometric progression + +The asymptotic input to Deligne §1.20: for any real +constants `C` and `c` there is an `n` with +`C * c ^ n < Real.sqrt n.factorial`. + +The route is elementary. The integral bound +`three_pow_mul_factorial_ge` (`n ^ n ≤ 3 ^ n * n !`, from +`RS/Common/FactorialBound.lean`) gives `(n / 3) ^ n ≤ n !` over ℝ, +so at an even index `n = 2 * m` the square root of the factorial is +at least `(2 * m / 3) ^ m`. Replacing `C` and `c` by +`max |C| 1` and `max |c| 1` reduces every sign case to constants at +least `1`, and it then suffices to pick `m` beyond both `3 * b ^ 2` +(so the base `2 * m / 3` dominates `2 * b ^ 2`) and a natural number +exceeding the constant (so the spare factor `2 ^ m` swallows it). +-/ + +@[expose] public section + +namespace RS + +/-- Real form of `three_pow_mul_factorial_ge`: +`(n / 3) ^ n ≤ n !` over ℝ. -/ +theorem div_three_pow_le_factorial (n : ℕ) : + ((n : ℝ) / 3) ^ n ≤ (n.factorial : ℝ) := by + have h : ((n : ℝ)) ^ n ≤ 3 ^ n * (n.factorial : ℝ) := by + exact_mod_cast three_pow_mul_factorial_ge n + rw [div_pow, div_le_iff₀ (by positivity : (0 : ℝ) < 3 ^ n)] + calc ((n : ℝ)) ^ n ≤ 3 ^ n * (n.factorial : ℝ) := h + _ = (n.factorial : ℝ) * 3 ^ n := mul_comm _ _ + +/-- At an even index the square root of the factorial dominates +`(2 * m / 3) ^ m`. -/ +theorem pow_le_sqrt_factorial_two_mul (m : ℕ) : + (((2 * m : ℕ) : ℝ) / 3) ^ m ≤ Real.sqrt ((2 * m).factorial) := by + set x : ℝ := ((2 * m : ℕ) : ℝ) / 3 with hx_def + have hx0 : 0 ≤ x := by positivity + have hsq : x ^ (2 * m) = (x ^ m) ^ 2 := pow_mul' x 2 m + have h1 : x ^ (2 * m) ≤ ((2 * m).factorial : ℝ) := + div_three_pow_le_factorial (2 * m) + calc x ^ m + = Real.sqrt ((x ^ m) ^ 2) := (Real.sqrt_sq (pow_nonneg hx0 m)).symm + _ = Real.sqrt (x ^ (2 * m)) := by rw [hsq] + _ ≤ Real.sqrt ((2 * m).factorial) := Real.sqrt_le_sqrt h1 + +/-- **The square root of the factorial beats every geometric +progression**: for any real constants `C` and `c` there is an `n` +with `C * c ^ n < Real.sqrt n.factorial`. This is the asymptotic +input to Deligne §1.20. -/ +theorem exists_lt_sqrt_factorial (C c : ℝ) : + ∃ n : ℕ, C * c ^ n < Real.sqrt (n.factorial) := by + set A : ℝ := max |C| 1 with hA_def + set b : ℝ := max |c| 1 with hb_def + have hA1 : (1 : ℝ) ≤ A := le_max_right _ _ + have hb1 : (1 : ℝ) ≤ b := le_max_right _ _ + have hb0 : (0 : ℝ) < b := lt_of_lt_of_le one_pos hb1 + obtain ⟨k₁, hk₁⟩ := exists_nat_gt A + obtain ⟨k₂, hk₂⟩ := exists_nat_ge (3 * b ^ 2) + set m : ℕ := max k₁ k₂ with hm_def + refine ⟨2 * m, ?_⟩ + -- The given progression is dominated by one with constants ≥ 1. + have habs : C * c ^ (2 * m) ≤ A * (b ^ 2) ^ m := by + have h1 : C * c ^ (2 * m) ≤ |C| * |c| ^ (2 * m) := by + calc C * c ^ (2 * m) ≤ |C * c ^ (2 * m)| := le_abs_self _ + _ = |C| * |c| ^ (2 * m) := by rw [abs_mul, abs_pow] + have h2 : |c| ^ (2 * m) ≤ b ^ (2 * m) := + pow_le_pow_left₀ (abs_nonneg c) (le_max_left _ _) _ + have h3 : |C| * |c| ^ (2 * m) ≤ A * b ^ (2 * m) := + mul_le_mul (le_max_left _ _) h2 (pow_nonneg (abs_nonneg c) _) + (le_trans zero_le_one hA1) + calc C * c ^ (2 * m) ≤ A * b ^ (2 * m) := h1.trans h3 + _ = A * (b ^ 2) ^ m := by rw [← pow_mul] + -- The spare factor `2 ^ m` swallows the constant `A`. + have hA_lt : A < (2 : ℝ) ^ m := by + have hk₁m : (k₁ : ℝ) ≤ (m : ℝ) := by + exact_mod_cast Nat.le_max_left k₁ k₂ + have hm2 : (m : ℝ) < (2 : ℝ) ^ m := by + exact_mod_cast @Nat.lt_two_pow_self m + linarith + have hbpos : (0 : ℝ) < (b ^ 2) ^ m := pow_pos (pow_pos hb0 2) m + -- Base comparison: `2 * b ^ 2 ≤ 2 * m / 3`. + have h6 : 2 * b ^ 2 ≤ ((2 * m : ℕ) : ℝ) / 3 := by + have hk₂m : (k₂ : ℝ) ≤ (m : ℝ) := by + exact_mod_cast Nat.le_max_right k₁ k₂ + have h3b : 3 * b ^ 2 ≤ (m : ℝ) := hk₂.trans hk₂m + push_cast + linarith + calc C * c ^ (2 * m) + ≤ A * (b ^ 2) ^ m := habs + _ < (2 : ℝ) ^ m * (b ^ 2) ^ m := mul_lt_mul_of_pos_right hA_lt hbpos + _ = ((2 : ℝ) * b ^ 2) ^ m := (mul_pow 2 (b ^ 2) m).symm + _ ≤ (((2 * m : ℕ) : ℝ) / 3) ^ m := + pow_le_pow_left₀ (by positivity) h6 m + _ ≤ Real.sqrt ((2 * m).factorial) := pow_le_sqrt_factorial_two_mul m + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreAdditive.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreAdditive.lean new file mode 100644 index 0000000000..150b191bbc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreAdditive.lean @@ -0,0 +1,100 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModFunctor + +/-! +# The fibre functor is additive + +Base change followed by realization is a functor from the ambient +category to the super modules over the Γ-algebra, and it is +additive: whiskering by the algebra is additive, and realization is +composition. Additivity is what makes the fibre functor preserve +finite biproducts, and hence what turns a mixed sum into a free +super module of the corresponding rank. + +The functor is built directly rather than as a composite through +the module objects, because the category of module objects carries +no additive structure in this development. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +section + +variable {D : Type u} + +/-- **The fibre functor over an algebra**: base change, then +realize. -/ +noncomputable def fibreFun + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] : + D ⥤ (gammaAlgebra D L R).Mod where + obj V := gammaModule D L R (freeMod R V).X + map f := (gammaModuleFunctor L R).map (freeModMap R f) + map_id V := by + rw [freeModMap_id] + exact CategoryTheory.Functor.map_id _ _ + map_comp f g := by + rw [freeModMap_comp] + exact CategoryTheory.Functor.map_comp _ _ _ + +@[simp] theorem fibreFun_obj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (V : D) : + (fibreFun L R).obj V = gammaModule D L R (freeMod R V).X := rfl + +@[simp] theorem fibreFun_map + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + {V W : D} (f : V ⟶ W) : + (fibreFun L R).map f = + (gammaModuleFunctor L R).map (freeModMap R f) := rfl + +/-- **The fibre functor is additive.** -/ +instance fibreFun_additive + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] : + (fibreFun L R).Additive where + map_add {V W f g} := by + rw [fibreFun_map, fibreFun_map, fibreFun_map] + refine SuperCommAlgebra.Mod.Hom.ext ?_ ?_ <;> + refine LinearMap.ext fun m => ?_ + · change m ≫ (R ◁ (f + g)) = m ≫ (R ◁ f) + m ≫ (R ◁ g) + rw [MonoidalPreadditive.whiskerLeft_add] + exact Preadditive.comp_add _ _ _ _ _ _ + · change m ≫ (R ◁ (f + g)) = m ≫ (R ◁ f) + m ≫ (R ◁ g) + rw [MonoidalPreadditive.whiskerLeft_add] + exact Preadditive.comp_add _ _ _ _ _ _ + +/-- **The fibre functor takes a finite biproduct to a finite +biproduct.** -/ +noncomputable def fibreFunBiproduct + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + [HasFiniteBiproducts D] + {ι : Type} [Fintype ι] + (f : ι → D) : + (fibreFun L R).obj (⨁ f) ≅ ⨁ fun i => (fibreFun L R).obj (f i) := + (fibreFun L R).mapBiproduct f + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreBridge.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreBridge.lean new file mode 100644 index 0000000000..0229ad1110 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreBridge.lean @@ -0,0 +1,51 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreAdditive +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMonoidal + +/-! +# The two presentations of the fibre functor agree + +Base change followed by realization was built twice: once directly, +so that additivity could be proved without an additive structure on +the module objects, and once as a composite, so that the monoidal +comparison could be read off. The two are the same functor. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +section + +variable {D : Type u} + +/-- **The direct and composite presentations of the fibre functor +agree.** -/ +theorem fibreFun_eq_fibreOver + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] : + fibreFun L R = fibreOver L R := rfl + +/-- The composite presentation is additive. -/ +instance fibreOver_additive + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] : + (fibreOver L R).Additive := + fibreFun_eq_fibreOver L R ▸ fibreFun_additive L R + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreEps.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreEps.lean new file mode 100644 index 0000000000..d7832caf04 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreEps.lean @@ -0,0 +1,80 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairNat +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle + +/-! +# The unit comparison of the fibre functor + +The free module of the tensor unit is the regular module, whose +realization is the Γ-algebra viewed over itself, that is, the unit +of the tensor product of super modules. The unit comparison of the +fibre functor is therefore an isomorphism outright, and on the two +components it is composition with the inverse right unitor of the +algebra. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +section + +variable {D : Type u} + +open SuperCommAlgebra.Mod + +/-- **The unit comparison of the fibre functor.** -/ +noncomputable def fibreEpsIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] : + (gammaAlgebra D L R).unitMod ≅ + gammaModule D L R (freeMod R (𝟙_ D)).X := + ((gammaModuleFunctor L R).mapIso (freeModUnitIso R)).symm + +/-- The unit comparison, as a morphism. -/ +noncomputable abbrev fibreEps + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] : + (gammaAlgebra D L R).unitMod ⟶ + gammaModule D L R (freeMod R (𝟙_ D)).X := + (fibreEpsIso L R).hom + +/-- The unit comparison on the even component: composition with the +inverse right unitor of the algebra. -/ +@[simp] theorem fibreEps_evenMap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (x : 𝟙_ D ⟶ R) : + (fibreEps L R).evenMap x = x ≫ (ρ_ R).inv := rfl + +/-- The unit comparison on the odd component: composition with the +inverse right unitor of the algebra. -/ +@[simp] theorem fibreEps_oddMap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (u : L.obj ⟶ R) : + (fibreEps L R).oddMap u = u ≫ (ρ_ R).inv := rfl + +instance [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] : + IsIso (fibreEps L R) := (fibreEpsIso L R).isIso_hom + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreExact.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreExact.lean new file mode 100644 index 0000000000..b2eca1c734 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreExact.lean @@ -0,0 +1,356 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ExactFromShort + +/-! +# Exactness of the fibre functor from a base-change section + +A short exact sequence of an abelian category does not split, so +the splitting hypothesis of `RS.fibreFun_shortExact` is never +available as stated. What Deligne's 2.10 supplies — in the form +recorded by `RS.Rappel210Statement` — is weaker and is exactly what +is needed: a section of the epimorphism *after base change*, that +is, a morphism of module objects +`s : freeMod R S.X₃ ⟶ freeMod R S.X₂` splitting `freeModMap R S.g`. + +This module derives short exactness of the realised sequence from +that hypothesis alone. The route is: + +* base change is exact, so `S.map (tensorLeft R)` is short exact + whenever `S` is (`RS.shortExact_map_tensorLeft`); +* a section of a short exact sequence produces a retraction + (Mathlib's `ShortComplex.Splitting.ofExactOfSection`), and that + retraction is again a morphism of module objects — the content of + `RS.baseChangeRetraction_lin`, proved by cancelling the + monomorphism `R ◁ S.f`, past which the intertwining law of the + retraction becomes the intertwining law of the complement of + `(R ◁ S.g) ≫ s`, a composite of module maps; +* realisation is a functor and turns sums of module morphisms into + sums, so the three splitting identities transport to the super + modules, where a split short complex is short exact. + +The category of module objects carries no additive structure, so +the transported splitting is assembled by hand rather than through +`ShortComplex.Splitting.map`; `RS.gammaModuleFunctor_map_add` is +the one additivity statement this needs, phrased on underlying +morphisms. + +Exactness of base change is assumed as an instance hypothesis on +the ambient category; for `Ind C` it is supplied by +`RS.tensorLeft_ind_preservesFiniteLimits` and its colimit +counterpart. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +/-! ## Intertwining laws in raw tensor form -/ + +section Raw + +variable {D : Type u} + +/-- **The underlying morphism of a map of free modules intertwines +the free actions**, in raw tensor form. -/ +theorem freeMod_hom_lin [Category.{v} D] [MonoidalCategory D] (R : D) [MonObj R] + {V W : D} (f : freeMod R V ⟶ freeMod R W) : + ((α_ R R V).inv ≫ (μ[R] ▷ V)) ≫ Mod.Hom.hom f = + (R ◁ Mod.Hom.hom f) ≫ ((α_ R R W).inv ≫ (μ[R] ▷ W)) := + (Mod.Hom.isModHom f).smul_hom + +section Complement + +/-- **The complement of a module endomorphism is a module map.** +Let `f` be a monomorphism intertwining the free actions, let `c` be +an endomorphism intertwining them, and let `u` satisfy +`u ≫ f + c = 𝟙`. Then `u` intertwines the free actions as well: +the law for `u` is checked after `f`, where it becomes the law for +`𝟙 - c`. This is the crux of the whole module. -/ +theorem lin_of_complement + [Category.{v} D] [MonoidalCategory D] (R : D) [MonObj R] [Preadditive D] + [MonoidalPreadditive D] + {V W : D} (f : R ⊗ V ⟶ R ⊗ W) [Mono f] + (hf : ((α_ R R V).inv ≫ (μ[R] ▷ V)) ≫ f = + (R ◁ f) ≫ ((α_ R R W).inv ≫ (μ[R] ▷ W))) + (u : R ⊗ W ⟶ R ⊗ V) (c : R ⊗ W ⟶ R ⊗ W) + (hc : ((α_ R R W).inv ≫ (μ[R] ▷ W)) ≫ c = + (R ◁ c) ≫ ((α_ R R W).inv ≫ (μ[R] ▷ W))) + (hid : u ≫ f + c = 𝟙 (R ⊗ W)) : + ((α_ R R W).inv ≫ (μ[R] ▷ W)) ≫ u = + (R ◁ u) ≫ ((α_ R R V).inv ≫ (μ[R] ▷ V)) := by + rw [← cancel_mono f] + have hR : ((R ◁ u) ≫ ((α_ R R V).inv ≫ (μ[R] ▷ V))) ≫ f = + (R ◁ (u ≫ f)) ≫ ((α_ R R W).inv ≫ (μ[R] ▷ W)) := by + rw [Category.assoc, hf, ← Category.assoc, + ← MonoidalCategory.whiskerLeft_comp] + rw [Category.assoc, hR] + have hsum : ((α_ R R W).inv ≫ (μ[R] ▷ W)) ≫ (u ≫ f) + + ((α_ R R W).inv ≫ (μ[R] ▷ W)) ≫ c = + (R ◁ (u ≫ f)) ≫ ((α_ R R W).inv ≫ (μ[R] ▷ W)) + + (R ◁ c) ≫ ((α_ R R W).inv ≫ (μ[R] ▷ W)) := by + rw [← Preadditive.comp_add, ← Preadditive.add_comp, + ← MonoidalPreadditive.whiskerLeft_add, hid, + MonoidalCategory.whiskerLeft_id, Category.comp_id, + Category.id_comp] + rw [hc] at hsum + exact add_right_cancel hsum + +end Complement + +end Raw + +/-! ## The retraction produced by a base-change section -/ + +section BaseChange + +variable {D : Type u} + +/-- **Base change of a short exact sequence is short exact.** +Tensoring is exact, so the whiskered sequence is again short +exact. -/ +theorem shortExact_map_tensorLeft + [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] [∀ Z : D, PreservesFiniteLimits (tensorLeft Z)] + [∀ Z : D, PreservesFiniteColimits (tensorLeft Z)] (R : D) + {S : CategoryTheory.ShortComplex D} (hS : S.ShortExact) : + (S.map (tensorLeft R)).ShortExact := + hS.map_of_exact (tensorLeft R) + +/-- The underlying morphism of a module-level section, in raw +tensor form. -/ +def baseChangeSectionHom + [Category.{v} D] [MonoidalCategory D] [Abelian D] (R : D) [MonObj R] + {S : CategoryTheory.ShortComplex D} + (s : freeMod R S.X₃ ⟶ freeMod R S.X₂) : + R ⊗ S.X₃ ⟶ R ⊗ S.X₂ := + Mod.Hom.hom s + +/-- A module-level section splits the base-changed epimorphism. -/ +theorem baseChangeSectionHom_g + [Category.{v} D] [MonoidalCategory D] [Abelian D] (R : D) [MonObj R] + {S : CategoryTheory.ShortComplex D} + (s : freeMod R S.X₃ ⟶ freeMod R S.X₂) + (hs : s ≫ freeModMap R S.g = 𝟙 (freeMod R S.X₃)) : + baseChangeSectionHom R s ≫ (R ◁ S.g) = 𝟙 (R ⊗ S.X₃) := + congrArg Mod.Hom.hom hs + +/-- The splitting of the base-changed sequence determined by a +module-level section of the epimorphism. -/ +noncomputable def baseChangeSplitting + [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] [∀ Z : D, PreservesFiniteLimits (tensorLeft Z)] + [∀ Z : D, PreservesFiniteColimits (tensorLeft Z)] (R : D) [MonObj R] + {S : CategoryTheory.ShortComplex D} + (hS : S.ShortExact) + (s : freeMod R S.X₃ ⟶ freeMod R S.X₂) + (hs : s ≫ freeModMap R S.g = 𝟙 (freeMod R S.X₃)) : + (S.map (tensorLeft R)).Splitting := + CategoryTheory.ShortComplex.Splitting.ofExactOfSection + (S.map (tensorLeft R)) (shortExact_map_tensorLeft R hS).exact + (baseChangeSectionHom R s) (baseChangeSectionHom_g R s hs) + (shortExact_map_tensorLeft R hS).mono_f + +/-- The retraction of the base-changed sequence, in raw tensor +form. -/ +noncomputable def baseChangeRetractionHom + [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] [∀ Z : D, PreservesFiniteLimits (tensorLeft Z)] + [∀ Z : D, PreservesFiniteColimits (tensorLeft Z)] (R : D) [MonObj R] + {S : CategoryTheory.ShortComplex D} + (hS : S.ShortExact) + (s : freeMod R S.X₃ ⟶ freeMod R S.X₂) + (hs : s ≫ freeModMap R S.g = 𝟙 (freeMod R S.X₃)) : + R ⊗ S.X₂ ⟶ R ⊗ S.X₁ := + (baseChangeSplitting R hS s hs).r + +/-- The retraction retracts the base-changed monomorphism. -/ +theorem baseChangeRetractionHom_f + [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] [∀ Z : D, PreservesFiniteLimits (tensorLeft Z)] + [∀ Z : D, PreservesFiniteColimits (tensorLeft Z)] (R : D) [MonObj R] + {S : CategoryTheory.ShortComplex D} + (hS : S.ShortExact) + (s : freeMod R S.X₃ ⟶ freeMod R S.X₂) + (hs : s ≫ freeModMap R S.g = 𝟙 (freeMod R S.X₃)) : + (R ◁ S.f) ≫ baseChangeRetractionHom R hS s hs = + 𝟙 (R ⊗ S.X₁) := + (baseChangeSplitting R hS s hs).f_r + +/-- The retraction and the section are complementary. -/ +theorem baseChangeRetractionHom_id + [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] [∀ Z : D, PreservesFiniteLimits (tensorLeft Z)] + [∀ Z : D, PreservesFiniteColimits (tensorLeft Z)] (R : D) [MonObj R] + {S : CategoryTheory.ShortComplex D} + (hS : S.ShortExact) + (s : freeMod R S.X₃ ⟶ freeMod R S.X₂) + (hs : s ≫ freeModMap R S.g = 𝟙 (freeMod R S.X₃)) : + baseChangeRetractionHom R hS s hs ≫ (R ◁ S.f) + + (R ◁ S.g) ≫ baseChangeSectionHom R s = + 𝟙 (R ⊗ S.X₂) := + (baseChangeSplitting R hS s hs).id + +/-- **The retraction is a morphism of module objects.** -/ +theorem baseChangeRetraction_lin + [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] [∀ Z : D, PreservesFiniteLimits (tensorLeft Z)] + [∀ Z : D, PreservesFiniteColimits (tensorLeft Z)] (R : D) [MonObj R] + {S : CategoryTheory.ShortComplex D} + (hS : S.ShortExact) + (s : freeMod R S.X₃ ⟶ freeMod R S.X₂) + (hs : s ≫ freeModMap R S.g = 𝟙 (freeMod R S.X₃)) : + ((α_ R R S.X₂).inv ≫ (μ[R] ▷ S.X₂)) ≫ + baseChangeRetractionHom R hS s hs = + (R ◁ baseChangeRetractionHom R hS s hs) ≫ + ((α_ R R S.X₁).inv ≫ (μ[R] ▷ S.X₁)) := by + have : Mono (R ◁ S.f) := (shortExact_map_tensorLeft R hS).mono_f + exact lin_of_complement R (R ◁ S.f) (freeModMap_lin R S.f) + (baseChangeRetractionHom R hS s hs) + ((R ◁ S.g) ≫ baseChangeSectionHom R s) + (freeMod_hom_lin R (freeModMap R S.g ≫ s)) + (baseChangeRetractionHom_id R hS s hs) + +/-- **The retraction, as a morphism of module objects.** -/ +noncomputable def baseChangeRetraction + [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] [∀ Z : D, PreservesFiniteLimits (tensorLeft Z)] + [∀ Z : D, PreservesFiniteColimits (tensorLeft Z)] (R : D) [MonObj R] + {S : CategoryTheory.ShortComplex D} + (hS : S.ShortExact) + (s : freeMod R S.X₃ ⟶ freeMod R S.X₂) + (hs : s ≫ freeModMap R S.g = 𝟙 (freeMod R S.X₃)) : + freeMod R S.X₂ ⟶ freeMod R S.X₁ := + Mod.Hom.mk' (baseChangeRetractionHom R hS s hs) + (baseChangeRetraction_lin R hS s hs) + +/-- The module retraction retracts the base change of the +monomorphism. -/ +theorem freeModMap_baseChangeRetraction + [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] [∀ Z : D, PreservesFiniteLimits (tensorLeft Z)] + [∀ Z : D, PreservesFiniteColimits (tensorLeft Z)] (R : D) [MonObj R] + {S : CategoryTheory.ShortComplex D} + (hS : S.ShortExact) + (s : freeMod R S.X₃ ⟶ freeMod R S.X₂) + (hs : s ≫ freeModMap R S.g = 𝟙 (freeMod R S.X₃)) : + freeModMap R S.f ≫ baseChangeRetraction R hS s hs = + 𝟙 (freeMod R S.X₁) := + Mod.hom_ext _ _ (baseChangeRetractionHom_f R hS s hs) + +/-- The module retraction and the module section are +complementary, read on underlying morphisms. -/ +theorem baseChangeRetraction_id + [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] [∀ Z : D, PreservesFiniteLimits (tensorLeft Z)] + [∀ Z : D, PreservesFiniteColimits (tensorLeft Z)] (R : D) [MonObj R] + {S : CategoryTheory.ShortComplex D} + (hS : S.ShortExact) + (s : freeMod R S.X₃ ⟶ freeMod R S.X₂) + (hs : s ≫ freeModMap R S.g = 𝟙 (freeMod R S.X₃)) : + Mod.Hom.hom (baseChangeRetraction R hS s hs ≫ freeModMap R S.f) + + Mod.Hom.hom (freeModMap R S.g ≫ s) = + Mod.Hom.hom (𝟙 (freeMod R S.X₂)) := + baseChangeRetractionHom_id R hS s hs + +end BaseChange + +/-! ## Transport to the super modules -/ + +section Fibre + +variable {D : Type u} + +/-- **Realisation turns a sum of module morphisms into a sum.** +The category of module objects has no additive structure, so the +hypothesis is stated on underlying morphisms. -/ +theorem gammaModuleFunctor_map_add + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + [MonoidalPreadditive D] [Linear ℂ D] [MonoidalLinear ℂ D] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + {M N : Mod D R} (f g h : M ⟶ N) + (hfg : Mod.Hom.hom f + Mod.Hom.hom g = Mod.Hom.hom h) : + (gammaModuleFunctor L R).map f + + (gammaModuleFunctor L R).map g = + (gammaModuleFunctor L R).map h := by + refine SuperCommAlgebra.Mod.Hom.ext ?_ ?_ <;> + refine LinearMap.ext fun m => ?_ <;> + · change m ≫ Mod.Hom.hom f + m ≫ Mod.Hom.hom g = + m ≫ Mod.Hom.hom h + erw [← Preadditive.comp_add, hfg] + +section Splitting + +/-- **The splitting of the realised sequence.** Its retraction and +section are the realisations of the module retraction and of the +given module section; the three identities are the images of the +corresponding identities in the category of module objects. -/ +noncomputable def fibreFunSplitting + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + [MonoidalPreadditive D] [Linear ℂ D] [MonoidalLinear ℂ D] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + [∀ Z : D, PreservesFiniteLimits (tensorLeft Z)] + [∀ Z : D, PreservesFiniteColimits (tensorLeft Z)] + {S : CategoryTheory.ShortComplex D} + (hS : S.ShortExact) + (s : freeMod R S.X₃ ⟶ freeMod R S.X₂) + (hs : s ≫ freeModMap R S.g = 𝟙 (freeMod R S.X₃)) : + (S.map (fibreFun L R)).Splitting where + r := (gammaModuleFunctor L R).map (baseChangeRetraction R hS s hs) + s := (gammaModuleFunctor L R).map s + f_r := by + change (gammaModuleFunctor L R).map (freeModMap R S.f) ≫ + (gammaModuleFunctor L R).map + (baseChangeRetraction R hS s hs) = _ + rw [← CategoryTheory.Functor.map_comp, + freeModMap_baseChangeRetraction R hS s hs] + exact CategoryTheory.Functor.map_id _ _ + s_g := by + change (gammaModuleFunctor L R).map s ≫ + (gammaModuleFunctor L R).map (freeModMap R S.g) = _ + rw [← CategoryTheory.Functor.map_comp, hs] + exact CategoryTheory.Functor.map_id _ _ + id := by + change (gammaModuleFunctor L R).map + (baseChangeRetraction R hS s hs) ≫ + (gammaModuleFunctor L R).map (freeModMap R S.f) + + (gammaModuleFunctor L R).map (freeModMap R S.g) ≫ + (gammaModuleFunctor L R).map s = _ + rw [← CategoryTheory.Functor.map_comp, + ← CategoryTheory.Functor.map_comp] + refine Eq.trans (gammaModuleFunctor_map_add L R _ _ + (𝟙 (freeMod R S.X₂)) (baseChangeRetraction_id R hS s hs)) ?_ + exact CategoryTheory.Functor.map_id _ _ + +/-- **The fibre functor carries a short exact sequence with a +base-change section to a short exact sequence of super modules.** +No section in the ambient category is required: a section of the +base-changed epimorphism as a map of module objects suffices. -/ +theorem fibreFun_shortExact_of_baseChangeSection + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + [MonoidalPreadditive D] [Linear ℂ D] [MonoidalLinear ℂ D] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + [∀ Z : D, PreservesFiniteLimits (tensorLeft Z)] + [∀ Z : D, PreservesFiniteColimits (tensorLeft Z)] + {S : CategoryTheory.ShortComplex D} (hS : S.ShortExact) + (s : freeMod R S.X₃ ⟶ freeMod R S.X₂) + (hs : s ≫ freeModMap R S.g = 𝟙 (freeMod R S.X₃)) : + (S.map (fibreFun L R)).ShortExact := + (fibreFunSplitting L R hS s hs).shortExact + +end Splitting + +end Fibre + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFaithful.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFaithful.lean new file mode 100644 index 0000000000..2947314e5c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFaithful.lean @@ -0,0 +1,169 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreAdditive +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModAdjoint + +/-! +# The fibre functor is faithful + +A free module on an object that becomes a mixed sum is generated, +as a module, by finitely many morphisms out of the unit and out of +the odd line. So a morphism killed by the fibre functor is killed +after base change; and if the unit of the algebra is a monomorphism +that is enough to kill the morphism itself. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +section + +variable {D : Type u} + +/-- The retract family of a free module on a mixed object, +transported along an isomorphism. -/ +private noncomputable def mixSec + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] (L : OddLine D) (R : D) + [MonObj R] + {V : D} {p q : ℕ} + (e : freeMod R V ≅ freeMod R (L.mix p q)) + (i : Fin p ⊕ Fin q) : + freeMod R (Sum.elim (fun _ => 𝟙_ D) (fun _ => L.obj) i) ⟶ + freeMod R V := + freeModMap R (biproduct.ι (fun k : Fin p ⊕ Fin q => + Sum.elim (fun _ => 𝟙_ D) (fun _ => L.obj) k) i) ≫ e.inv + +private noncomputable def mixRet + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] (L : OddLine D) (R : D) + [MonObj R] + {V : D} {p q : ℕ} + (e : freeMod R V ≅ freeMod R (L.mix p q)) + (i : Fin p ⊕ Fin q) : + freeMod R V ⟶ + freeMod R (Sum.elim (fun _ => 𝟙_ D) (fun _ => L.obj) i) := + e.hom ≫ freeModMap R (biproduct.π (fun k : Fin p ⊕ Fin q => + Sum.elim (fun _ => 𝟙_ D) (fun _ => L.obj) k) i) + +private theorem mixTotal + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (R : D) [MonObj R] + {V : D} {p q : ℕ} + (e : freeMod R V ≅ freeMod R (L.mix p q)) : + ∑ i : Fin p ⊕ Fin q, + (mixRet L R e i).hom ≫ (mixSec L R e i).hom = + 𝟙 (freeMod R V).X := by + classical + have h : ∀ i : Fin p ⊕ Fin q, + (mixRet L R e i).hom ≫ (mixSec L R e i).hom = + e.hom.hom ≫ + ((freeModMap R (biproduct.π (fun k : Fin p ⊕ Fin q => + Sum.elim (fun _ => 𝟙_ D) (fun _ => L.obj) k) i)).hom ≫ + (freeModMap R (biproduct.ι (fun k : Fin p ⊕ Fin q => + Sum.elim (fun _ => 𝟙_ D) (fun _ => L.obj) k) i)).hom) ≫ + e.inv.hom := by + intro i + change (e.hom.hom ≫ + (freeModMap R (biproduct.π (fun k : Fin p ⊕ Fin q => + Sum.elim (fun _ => 𝟙_ D) (fun _ => L.obj) k) i)).hom) ≫ + ((freeModMap R (biproduct.ι (fun k : Fin p ⊕ Fin q => + Sum.elim (fun _ => 𝟙_ D) (fun _ => L.obj) k) i)).hom ≫ + e.inv.hom) = _ + repeat' erw [Category.assoc] + refine Eq.trans (Finset.sum_congr rfl fun i _ => h i) ?_ + erw [← Preadditive.comp_sum, ← Preadditive.sum_comp] + refine Eq.trans (whisker_eq _ (eq_whisker + (freeModMap_biproduct_total R (fun k : Fin p ⊕ Fin q => + Sum.elim (fun _ => 𝟙_ D) (fun _ => L.obj) k)) _)) ?_ + refine Eq.trans (whisker_eq _ (Category.id_comp _)) ?_ + exact congrArg Mod.Hom.hom e.hom_inv_id + +/-- **A morphism killed by the fibre functor is killed by base +change.** -/ +theorem whiskerLeft_eq_zero_of_fibre + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasFiniteBiproducts D] (L : OddLine D) (R : D) + [MonObj R] [IsCommMonObj R] + {V W : D} (fm : V ⟶ W) + {p q : ℕ} (e : freeMod R V ≅ freeMod R (L.mix p q)) + (h : (fibreFun L R).map fm = 0) : R ◁ fm = 0 := by + classical + refine hom_eq_zero_of_generators R (mixSec L R e) (mixRet L R e) + (mixTotal L R e) (freeModMap R fm) ?_ + rintro (j | j) + · have hz : (((λ_ (𝟙_ D)).inv ≫ (η[R] ▷ (𝟙_ D)) ≫ + (mixSec L R e (Sum.inl j)).hom) ≫ + (freeModMap R fm).hom) = 0 := by + change ((fibreFun L R).map fm).evenMap + ((λ_ (𝟙_ D)).inv ≫ (η[R] ▷ (𝟙_ D)) ≫ + (mixSec L R e (Sum.inl j)).hom) = 0 + rw [h] + rfl + refine Eq.trans ?_ hz + exact (Eq.trans (Category.assoc _ _ _) + (whisker_eq _ (Category.assoc _ _ _))).symm + · have hz : (((λ_ L.obj).inv ≫ (η[R] ▷ L.obj) ≫ + (mixSec L R e (Sum.inr j)).hom) ≫ + (freeModMap R fm).hom) = 0 := by + change ((fibreFun L R).map fm).oddMap + ((λ_ L.obj).inv ≫ (η[R] ▷ L.obj) ≫ + (mixSec L R e (Sum.inr j)).hom) = 0 + rw [h] + rfl + refine Eq.trans ?_ hz + exact (Eq.trans (Category.assoc _ _ _) + (whisker_eq _ (Category.assoc _ _ _))).symm + +/-- **Base change is faithful when the unit is a +monomorphism.** -/ +theorem eq_zero_of_whiskerLeft + [Category.{v} D] [MonoidalCategory D] [Preadditive D] (R : D) [MonObj R] + [∀ Z : D, (tensorRight Z).PreservesMonomorphisms] + (hη : Mono η[R]) {V W : D} + (fm : V ⟶ W) (h : R ◁ fm = 0) : fm = 0 := by + have := hη + have : Mono (η[R] ▷ W) := + (tensorRight W).map_mono η[R] + have h1 : fm ≫ ((λ_ W).inv ≫ (η[R] ▷ W)) = 0 := by + have h2 : (λ_ V).inv ≫ (η[R] ▷ V) ≫ (R ◁ fm) = 0 := by + rw [h, Limits.comp_zero, Limits.comp_zero] + rw [← whisker_exchange, ← Category.assoc, + ← leftUnitor_inv_naturality, Category.assoc] at h2 + exact h2 + have : Mono ((λ_ W).inv ≫ (η[R] ▷ W)) := mono_comp _ _ + exact (cancel_mono ((λ_ W).inv ≫ (η[R] ▷ W))).mp + (h1.trans (Limits.zero_comp).symm) + +/-- **The fibre functor is faithful** on the objects that become +mixed sums. -/ +theorem fibreFun_map_eq_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasFiniteBiproducts D] (L : OddLine D) (R : D) + [MonObj R] [IsCommMonObj R] + [∀ Z : D, (tensorRight Z).PreservesMonomorphisms] + (hη : Mono η[R]) {V W : D} + (fm : V ⟶ W) {p q : ℕ} + (e : freeMod R V ≅ freeMod R (L.mix p q)) + (h : (fibreFun L R).map fm = 0) : fm = 0 := + eq_zero_of_whiskerLeft R hη fm + (whiskerLeft_eq_zero_of_fibre L R fm e h) + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFunctor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFunctor.lean new file mode 100644 index 0000000000..bfa1f89f39 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFunctor.lean @@ -0,0 +1,66 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210 +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom + +/-! +# The fibre functor over an algebra + +Deligne's `ω` of 2.11: base change to the algebra, then take the +morphisms out of the two generators. Both steps are functorial, +so `ω` is a functor from the category to the super modules over +the Γ-algebra of the base. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v + +variable {C : Type v} + +/-- The base change of an object, as a module object. -/ +noncomputable abbrev fibreObj + [SmallCategory C] [MonoidalCategory C] (A : Ind C) [MonObj A] + (X : Ind C) : Ind C := + (freeMod A X).X + +/-- **The fibre functor over an algebra** (Deligne 2.11): base +change and realize. -/ +noncomputable def fibreFunctor + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [MonoidalPreadditive C] [CategoryTheory.Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] (L : OddLine (Ind C)) (A : Ind C) [MonObj A] + [IsCommMonObj A] : + Ind C ⥤ (gammaAlgebra (Ind C) L A).Mod where + obj X := gammaModule (Ind C) L A (fibreObj A X) + map {_ _} f := + letI : IsModHom A (freeModMap A f).hom := + (freeModMap A f).isModHom + gammaModuleMap L A (freeModMap A f).hom + map_id X := by + refine SuperCommAlgebra.Mod.Hom.ext ?_ ?_ <;> + refine LinearMap.ext fun m => ?_ <;> + · change m ≫ (freeModMap A (𝟙 X)).hom = m + erw [show (freeModMap A (𝟙 X)).hom = 𝟙 (fibreObj A X) from + MonoidalCategory.whiskerLeft_id A X, Category.comp_id] + map_comp {X Y Z} f g := by + refine SuperCommAlgebra.Mod.Hom.ext ?_ ?_ <;> + refine LinearMap.ext fun m => ?_ <;> + · change m ≫ (freeModMap A (f ≫ g)).hom = + (m ≫ (freeModMap A f).hom) ≫ (freeModMap A g).hom + erw [show (freeModMap A (f ≫ g)).hom = + (freeModMap A f).hom ≫ (freeModMap A g).hom from + MonoidalCategory.whiskerLeft_comp A f g, + ← Category.assoc] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreLinear.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreLinear.lean new file mode 100644 index 0000000000..ac979be316 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreLinear.lean @@ -0,0 +1,52 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointFibre + +/-! +# The fibre functor is complex-linear + +The fibre functor is built by whiskering with the algebra and +composing, and both operations are complex-linear, so the functor +is. This is the last field of `RS.DeligneFibreFunctor` that the +fibre construction does not supply on its own. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +section + +variable {D : Type u} + +/-- **The fibre functor is complex-linear.** -/ +instance fibreFun_linear + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] : + (fibreFun L R).Linear ℂ where + map_smul {V W} f c := by + rw [fibreFun_map, fibreFun_map] + refine SuperCommAlgebra.Mod.Hom.ext ?_ ?_ <;> + refine LinearMap.ext fun m => ?_ + · change m ≫ (R ◁ (c • f)) = c • (m ≫ (R ◁ f)) + rw [MonoidalLinear.whiskerLeft_smul] + exact CategoryTheory.Linear.comp_smul _ _ _ m c (R ◁ f) + · change m ≫ (R ◁ (c • f)) = c • (m ≫ (R ◁ f)) + rw [MonoidalLinear.whiskerLeft_smul] + exact CategoryTheory.Linear.comp_smul _ _ _ m c (R ◁ f) + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMix.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMix.lean new file mode 100644 index 0000000000..2c8acac52c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMix.lean @@ -0,0 +1,66 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreAdditive +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreEps +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaShift + +/-! +# The fibre functor of a mixed sum + +A mixed sum of `p` copies of the unit and `q` copies of the odd line +has for its fibre the free super module of rank `(p | q)`: the unit +contributes the algebra and the line contributes its parity shift, +and the fibre functor is additive. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +section + +variable {D : Type u} + +attribute [local instance] CategoryTheory.ModObj.regular + +/-- **The free super module of rank `(p | q)`.** -/ +noncomputable def superFree + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (p q : ℕ) : (gammaAlgebra D L R).Mod := + ⨁ fun i : Fin p ⊕ Fin q => + Sum.elim (fun _ => (gammaAlgebra D L R).unitMod) + (fun _ => SuperCommAlgebra.Mod.shift + (gammaAlgebra D L R).unitMod) i + +/-- **The fibre of a mixed sum is free of the corresponding +rank.** -/ +noncomputable def fibreMixIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasFiniteBiproducts D] (L : OddLine D) (R : D) + [MonObj R] [IsCommMonObj R] + (p q : ℕ) : + (fibreFun L R).obj (L.mix p q) ≅ superFree L R p q := + fibreFunBiproduct L R + (fun i : Fin p ⊕ Fin q => + Sum.elim (fun _ => 𝟙_ D) (fun _ => L.obj) i) ≪≫ + biproduct.mapIso fun i => + match i with + | Sum.inl _ => (fibreEpsIso L R).symm + | Sum.inr _ => gammaShiftIso L R + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMonoidal.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMonoidal.lean new file mode 100644 index 0000000000..db86d2e8c4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMonoidal.lean @@ -0,0 +1,1166 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMuNat +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreEps +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffleCoh +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModFunctor + +/-! +# The fibre functor is symmetric monoidal + +Deligne's `ω` is base change to the algebra followed by +realization, and its monoidal comparison `RS.fibreMu` is, on the +generators of the tensor product of super modules, nothing but the +free-module shuffle evaluated at a pair of morphisms. The three +coherence laws of a lax monoidal functor therefore reduce, family +by family, to the three coherence laws of the shuffle recorded in +`RS.FreeModShuffleCoh`. + +The reduction is uniform. Each generator family names a morphism +`s` out of the intended source into a tensor product of the two +sources involved, and the comparison sends a pair `(m, n)` to +`s ≫ (m ⊗ₘ n) ≫ freeModShuffle`. Associativity at a family is +then the associativity of the shuffle conjugated by the coherence +identity relating the four `s`'s of that family — exactly the +identity that already appears in the corresponding associativity +axiom of `RS.gammaModule`. Unitality and the braiding law are the +same computation one factor shorter. + +Two signs appear, and both are forced by the target rather than by +the fibre functor: + +* the Koszul sign of `rightUnitorHom_evenMap_tmulOO` in the + odd-odd family of the right unitor; +* the Koszul sign of `braidingHom_evenMap_tmulOO` in the odd-odd + family of the braiding. + +In both places the sign is supplied by `RS.OddLine.braid_neg`: the +self-braiding of the odd line is `−1`, so the source identification +`L.sq.inv` picks up exactly that sign when the two odd generators +are exchanged. No sign is left over. + +The functor is packaged as `CategoryTheory.Functor.LaxMonoidal` and +`CategoryTheory.Functor.LaxBraided`. Invertibility of `fibreMu` is +a separate matter and is not assumed here, so the strong notions +`Functor.Monoidal` and `Functor.Braided` are not instantiated. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +/-! ## Splitting a tensor of composites -/ + +section Split + +variable {D : Type u} + +/-- A composite in the first factor, split off on the left. -/ +theorem tensorHom_comp_fst [Category.{v} D] [MonoidalCategory D] + {A B C X Y : D} (f : A ⟶ B) (g : B ⟶ X) + (p : C ⟶ Y) : (f ≫ g) ⊗ₘ p = f ▷ C ≫ (g ⊗ₘ p) := by + rw [← tensorHom_id, tensorHom_comp_tensorHom, Category.id_comp] + +/-- A composite in the second factor, split off on the left. -/ +theorem tensorHom_comp_snd [Category.{v} D] [MonoidalCategory D] + {A B C X Y : D} (m : A ⟶ X) (f : B ⟶ C) + (g : C ⟶ Y) : m ⊗ₘ (f ≫ g) = A ◁ f ≫ (m ⊗ₘ g) := by + rw [← id_tensorHom, tensorHom_comp_tensorHom, Category.id_comp] + +/-- A composite in the first factor, split off on the right. -/ +theorem tensorHom_comp_fst' [Category.{v} D] [MonoidalCategory D] + {A B C X Y : D} (f : A ⟶ B) + (g : B ⟶ X) (p : C ⟶ Y) : (f ≫ g) ⊗ₘ p = (f ⊗ₘ p) ≫ g ▷ Y := by + rw [← tensorHom_id, tensorHom_comp_tensorHom, Category.comp_id] + +/-- A composite in the second factor, split off on the right. -/ +theorem tensorHom_comp_snd' [Category.{v} D] [MonoidalCategory D] + {A B C X Y : D} (m : A ⟶ X) + (f : B ⟶ C) (g : C ⟶ Y) : m ⊗ₘ (f ≫ g) = (m ⊗ₘ f) ≫ X ◁ g := by + rw [← id_tensorHom, tensorHom_comp_tensorHom, Category.comp_id] + +end Split + +/-! ## The coherence of the shuffle at arbitrary sources -/ + +section AtSources + +variable {D : Type u} + +/-- **Associativity of the shuffle at arbitrary sources.** Given +a coherence identity between the two ways of reassociating the +chosen sources, the two ways of shuffling three morphisms agree. -/ +theorem freeModShuffle_assoc_at + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] + {A B C T T' T'' : D} + (s₁ : T ⟶ T' ⊗ C) (s₂ : T' ⟶ A ⊗ B) (s₃ : T ⟶ A ⊗ T'') + (s₄ : T'' ⟶ B ⊗ C) + (h : s₁ ≫ s₂ ▷ C ≫ (α_ A B C).hom = s₃ ≫ A ◁ s₄) + {V W Z : D} (m : A ⟶ R ⊗ V) (n : B ⟶ R ⊗ W) + (p : C ⟶ R ⊗ Z) : + s₁ ≫ ((s₂ ≫ (m ⊗ₘ n) ≫ freeModShuffle R V W) ⊗ₘ p) ≫ + freeModShuffle R (V ⊗ W) Z ≫ R ◁ (α_ V W Z).hom = + s₃ ≫ (m ⊗ₘ (s₄ ≫ (n ⊗ₘ p) ≫ freeModShuffle R W Z)) ≫ + freeModShuffle R V (W ⊗ Z) := by + rw [tensorHom_comp_fst, tensorHom_comp_fst', tensorHom_comp_snd, + tensorHom_comp_snd'] + simp only [Category.assoc] + rw [freeModShuffle_assoc R V W Z, + associator_naturality_assoc m n p, reassoc_of% h] + +/-- `RS.freeModShuffle_assoc_at`, bracketed as realization of the +reassociation of the generators produces it. -/ +theorem freeModShuffle_assoc_at' + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] + {A B C T T' T'' : D} + (s₁ : T ⟶ T' ⊗ C) (s₂ : T' ⟶ A ⊗ B) (s₃ : T ⟶ A ⊗ T'') + (s₄ : T'' ⟶ B ⊗ C) + (h : s₁ ≫ s₂ ▷ C ≫ (α_ A B C).hom = s₃ ≫ A ◁ s₄) + {V W Z : D} (m : A ⟶ R ⊗ V) (n : B ⟶ R ⊗ W) + (p : C ⟶ R ⊗ Z) : + (s₁ ≫ ((s₂ ≫ (m ⊗ₘ n) ≫ freeModShuffle R V W) ⊗ₘ p) ≫ + freeModShuffle R (V ⊗ W) Z) ≫ R ◁ (α_ V W Z).hom = + s₃ ≫ (m ⊗ₘ (s₄ ≫ (n ⊗ₘ p) ≫ freeModShuffle R W Z)) ≫ + freeModShuffle R V (W ⊗ Z) := + Eq.trans (Category.assoc _ _ _) + (Eq.trans (whisker_eq _ (Category.assoc _ _ _)) + (freeModShuffle_assoc_at R s₁ s₂ s₃ s₄ h m n p)) + +/-- **Left unitality of the shuffle**, with the trailing +reassociation of the generators cancelled. -/ +theorem freeModShuffle_unit_left' + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] + (V : D) : + ((ρ_ R).inv ▷ (R ⊗ V)) ≫ freeModShuffle R (𝟙_ D) V ≫ + R ◁ (λ_ V).hom = (α_ R R V).inv ≫ μ[R] ▷ V := by + rw [← Category.assoc, freeModShuffle_unit_left, Category.assoc, + ← MonoidalCategory.whiskerLeft_comp, Iso.inv_hom_id, + MonoidalCategory.whiskerLeft_id, Category.comp_id] + +/-- **Left unitality of the shuffle at arbitrary sources**: +filling the first slot with the unit comparison leaves the action +of the free module. -/ +theorem freeModShuffle_unit_left_at + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] + {X Y T : D} (s : T ⟶ X ⊗ Y) + {V : D} (x : X ⟶ R) (m : Y ⟶ R ⊗ V) : + s ≫ ((x ≫ (ρ_ R).inv) ⊗ₘ m) ≫ freeModShuffle R (𝟙_ D) V ≫ + R ◁ (λ_ V).hom + = s ≫ (x ⊗ₘ m) ≫ (α_ R R V).inv ≫ μ[R] ▷ V := by + rw [tensorHom_comp_fst'] + simp only [Category.assoc] + rw [freeModShuffle_unit_left' R V] + +/-- `RS.freeModShuffle_unit_left_at`, bracketed as realization of +the left unitor of the generators produces it. -/ +theorem freeModShuffle_unit_left_at' + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] + {X Y T : D} (s : T ⟶ X ⊗ Y) + {V : D} (x : X ⟶ R) (m : Y ⟶ R ⊗ V) : + (s ≫ ((x ≫ (ρ_ R).inv) ⊗ₘ m) ≫ + freeModShuffle R (𝟙_ D) V) ≫ R ◁ (λ_ V).hom + = s ≫ (x ⊗ₘ m) ≫ (α_ R R V).inv ≫ μ[R] ▷ V := + Eq.trans (Category.assoc _ _ _) + (Eq.trans (whisker_eq _ (Category.assoc _ _ _)) + (freeModShuffle_unit_left_at R s x m)) + +end AtSources + +section AtSourcesComm + +variable {D : Type u} + +/-- **Right unitality of the shuffle**, with the trailing +reassociation of the generators cancelled. -/ +theorem freeModShuffle_unit_right' + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] [IsCommMonObj R] + (V : D) : + ((R ⊗ V) ◁ (ρ_ R).inv) ≫ freeModShuffle R V (𝟙_ D) ≫ + R ◁ (ρ_ V).hom + = (β_ (R ⊗ V) R).hom ≫ (α_ R R V).inv ≫ μ[R] ▷ V := by + rw [← Category.assoc, freeModShuffle_unit_right, Category.assoc, + ← MonoidalCategory.whiskerLeft_comp, Iso.inv_hom_id, + MonoidalCategory.whiskerLeft_id, Category.comp_id] + +/-- **Right unitality of the shuffle at arbitrary sources**: +filling the second slot with the unit comparison leaves the action +of the free module, the two sources having been exchanged. -/ +theorem freeModShuffle_unit_right_at + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] [IsCommMonObj R] + {X Y T : D} (s : T ⟶ X ⊗ Y) + {V : D} (m : X ⟶ R ⊗ V) (x : Y ⟶ R) : + s ≫ (m ⊗ₘ (x ≫ (ρ_ R).inv)) ≫ freeModShuffle R V (𝟙_ D) ≫ + R ◁ (ρ_ V).hom + = s ≫ (β_ X Y).hom ≫ (x ⊗ₘ m) ≫ (α_ R R V).inv ≫ + μ[R] ▷ V := by + rw [tensorHom_comp_snd'] + simp only [Category.assoc] + rw [freeModShuffle_unit_right' R V, + BraidedCategory.braiding_naturality_assoc m x] + +/-- `RS.freeModShuffle_unit_right_at`, bracketed as realization of +the right unitor of the generators produces it. -/ +theorem freeModShuffle_unit_right_at' + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] [IsCommMonObj R] + {X Y T : D} (s : T ⟶ X ⊗ Y) + {V : D} (m : X ⟶ R ⊗ V) (x : Y ⟶ R) : + (s ≫ (m ⊗ₘ (x ≫ (ρ_ R).inv)) ≫ + freeModShuffle R V (𝟙_ D)) ≫ R ◁ (ρ_ V).hom + = s ≫ (β_ X Y).hom ≫ (x ⊗ₘ m) ≫ (α_ R R V).inv ≫ + μ[R] ▷ V := + Eq.trans (Category.assoc _ _ _) + (Eq.trans (whisker_eq _ (Category.assoc _ _ _)) + (freeModShuffle_unit_right_at R s m x)) + +end AtSourcesComm + +section AtSourcesSym + +variable {D : Type u} + +/-- **The shuffle commutes with the braiding, at arbitrary +sources.** -/ +theorem freeModShuffle_braiding_at + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (R : D) + [MonObj R] [IsCommMonObj R] + {X Y T : D} (s : T ⟶ X ⊗ Y) + {V W : D} (m : X ⟶ R ⊗ V) (n : Y ⟶ R ⊗ W) : + s ≫ (m ⊗ₘ n) ≫ freeModShuffle R V W ≫ R ◁ (β_ V W).hom + = s ≫ (β_ X Y).hom ≫ (n ⊗ₘ m) ≫ freeModShuffle R W V := by + rw [← freeModShuffle_braiding R V W, + BraidedCategory.braiding_naturality_assoc m n] + +/-- `RS.freeModShuffle_braiding_at`, bracketed as realization of +the braiding of the generators produces it. -/ +theorem freeModShuffle_braiding_at' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (R : D) + [MonObj R] [IsCommMonObj R] + {X Y T : D} (s : T ⟶ X ⊗ Y) + {V W : D} (m : X ⟶ R ⊗ V) (n : Y ⟶ R ⊗ W) : + (s ≫ (m ⊗ₘ n) ≫ freeModShuffle R V W) ≫ R ◁ (β_ V W).hom + = s ≫ (β_ X Y).hom ≫ (n ⊗ₘ m) ≫ freeModShuffle R W V := + Eq.trans (Category.assoc _ _ _) + (Eq.trans (whisker_eq _ (Category.assoc _ _ _)) + (freeModShuffle_braiding_at R s m n)) + +end AtSourcesSym + +/-! ## The braiding on the four sources -/ + +section OddSources + +variable {D : Type u} + +/-- The even-even source is fixed by the braiding. -/ +theorem leftUnitorInv_braiding_ee + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] : + (λ_ (𝟙_ D)).inv ≫ (β_ (𝟙_ D) (𝟙_ D)).hom + = (λ_ (𝟙_ D)).inv := by + rw [← cancel_mono (ρ_ (𝟙_ D)).hom, Category.assoc, + braiding_rightUnitor, ← unitors_equal] + +/-- The braiding exchanges the even-odd and odd-even sources. -/ +theorem leftUnitorInv_braiding_eo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) : + (λ_ L.obj).inv ≫ (β_ (𝟙_ D) L.obj).hom = (ρ_ L.obj).inv := by + rw [← cancel_mono (ρ_ L.obj).hom, Category.assoc, + braiding_rightUnitor, Iso.inv_hom_id, Iso.inv_hom_id] + +/-- The braiding exchanges the odd-even and even-odd sources. -/ +theorem rightUnitorInv_braiding_oe + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) : + (ρ_ L.obj).inv ≫ (β_ L.obj (𝟙_ D)).hom = (λ_ L.obj).inv := by + rw [braiding_tensorUnit_right, Iso.inv_hom_id_assoc] + +end OddSources + +/-! ## The four families of the unitor and the braiding -/ + +section Families + +variable {D : Type u} + +/-- Right unitality at the even-even family. -/ +theorem freeModShuffle_unit_right_ee + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (R : D) + [MonObj R] [IsCommMonObj R] + (V : D) (m : 𝟙_ D ⟶ R ⊗ V) + (x : 𝟙_ D ⟶ R) : + ((λ_ (𝟙_ D)).inv ≫ (m ⊗ₘ (x ≫ (ρ_ R).inv)) ≫ + freeModShuffle R V (𝟙_ D)) ≫ R ◁ (ρ_ V).hom + = (λ_ (𝟙_ D)).inv ≫ (x ⊗ₘ m) ≫ (α_ R R V).inv ≫ + μ[R] ▷ V := by + rw [freeModShuffle_unit_right_at', + reassoc_of% (leftUnitorInv_braiding_ee (D := D))] + +/-- Right unitality at the odd-odd family; the Koszul sign of the +right unitor appears here, and nowhere else. -/ +theorem freeModShuffle_unit_right_oo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (V : D) (m : L.obj ⟶ R ⊗ V) + (u : L.obj ⟶ R) : + (L.sq.inv ≫ (m ⊗ₘ (u ≫ (ρ_ R).inv)) ≫ + freeModShuffle R V (𝟙_ D)) ≫ R ◁ (ρ_ V).hom + = -(L.sq.inv ≫ (u ⊗ₘ m) ≫ (α_ R R V).inv ≫ + μ[R] ▷ V) := by + rw [freeModShuffle_unit_right_at', + reassoc_of% (oddLine_sq_inv_braiding L), Preadditive.neg_comp] + +/-- Right unitality at the even-odd family. -/ +theorem freeModShuffle_unit_right_eo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (V : D) (m : 𝟙_ D ⟶ R ⊗ V) + (u : L.obj ⟶ R) : + ((λ_ L.obj).inv ≫ (m ⊗ₘ (u ≫ (ρ_ R).inv)) ≫ + freeModShuffle R V (𝟙_ D)) ≫ R ◁ (ρ_ V).hom + = (ρ_ L.obj).inv ≫ (u ⊗ₘ m) ≫ (α_ R R V).inv ≫ + μ[R] ▷ V := by + rw [freeModShuffle_unit_right_at', + reassoc_of% (leftUnitorInv_braiding_eo L)] + +/-- Right unitality at the odd-even family. -/ +theorem freeModShuffle_unit_right_oe + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (V : D) (m : L.obj ⟶ R ⊗ V) + (x : 𝟙_ D ⟶ R) : + ((ρ_ L.obj).inv ≫ (m ⊗ₘ (x ≫ (ρ_ R).inv)) ≫ + freeModShuffle R V (𝟙_ D)) ≫ R ◁ (ρ_ V).hom + = (λ_ L.obj).inv ≫ (x ⊗ₘ m) ≫ (α_ R R V).inv ≫ + μ[R] ▷ V := by + rw [freeModShuffle_unit_right_at', + reassoc_of% (rightUnitorInv_braiding_oe L)] + +/-- The braiding at the even-even family. -/ +theorem freeModShuffle_braiding_ee + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (R : D) + [MonObj R] [IsCommMonObj R] + (V W : D) (m : 𝟙_ D ⟶ R ⊗ V) + (n : 𝟙_ D ⟶ R ⊗ W) : + ((λ_ (𝟙_ D)).inv ≫ (m ⊗ₘ n) ≫ freeModShuffle R V W) ≫ + R ◁ (β_ V W).hom + = (λ_ (𝟙_ D)).inv ≫ (n ⊗ₘ m) ≫ freeModShuffle R W V := by + rw [freeModShuffle_braiding_at', + reassoc_of% (leftUnitorInv_braiding_ee (D := D))] + +/-- The braiding at the odd-odd family; the Koszul sign of the +Koszul swap appears here, and nowhere else. -/ +theorem freeModShuffle_braiding_oo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (V W : D) (m : L.obj ⟶ R ⊗ V) + (n : L.obj ⟶ R ⊗ W) : + (L.sq.inv ≫ (m ⊗ₘ n) ≫ freeModShuffle R V W) ≫ + R ◁ (β_ V W).hom + = -(L.sq.inv ≫ (n ⊗ₘ m) ≫ freeModShuffle R W V) := by + rw [freeModShuffle_braiding_at', + reassoc_of% (oddLine_sq_inv_braiding L), Preadditive.neg_comp] + +/-- The braiding at the even-odd family. -/ +theorem freeModShuffle_braiding_eo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (V W : D) (m : 𝟙_ D ⟶ R ⊗ V) + (n : L.obj ⟶ R ⊗ W) : + ((λ_ L.obj).inv ≫ (m ⊗ₘ n) ≫ freeModShuffle R V W) ≫ + R ◁ (β_ V W).hom + = (ρ_ L.obj).inv ≫ (n ⊗ₘ m) ≫ freeModShuffle R W V := by + rw [freeModShuffle_braiding_at', + reassoc_of% (leftUnitorInv_braiding_eo L)] + +/-- The braiding at the odd-even family. -/ +theorem freeModShuffle_braiding_oe + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (V W : D) (m : L.obj ⟶ R ⊗ V) + (n : 𝟙_ D ⟶ R ⊗ W) : + ((ρ_ L.obj).inv ≫ (m ⊗ₘ n) ≫ freeModShuffle R V W) ≫ + R ◁ (β_ V W).hom + = (λ_ L.obj).inv ≫ (n ⊗ₘ m) ≫ freeModShuffle R W V := by + rw [freeModShuffle_braiding_at', + reassoc_of% (rightUnitorInv_braiding_oe L)] + +end Families + +/-! ## The fibre functor and its comparison data -/ + +section Fibre + +variable {D : Type u} + +open SuperCommAlgebra.Mod + +/-- **The fibre functor over an algebra**: base change to the +algebra followed by realization. -/ +noncomputable def fibreOver + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] : + D ⥤ (gammaAlgebra D L R).Mod := + freeModFunctor R ⋙ gammaModuleFunctor L R + +/-- Realization of a base-changed morphism, in even degree. -/ +theorem gammaFunMap_freeModMap_evenMap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + {V W : D} (f : V ⟶ W) + (m : 𝟙_ D ⟶ (freeMod R V).X) : + (gammaFunMap L R (freeModMap R f)).evenMap m = m ≫ R ◁ f := + rfl + +/-- Realization of a base-changed morphism, in odd degree. -/ +theorem gammaFunMap_freeModMap_oddMap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + {V W : D} (f : V ⟶ W) + (m : L.obj ⟶ (freeMod R V).X) : + (gammaFunMap L R (freeModMap R f)).oddMap m = m ≫ R ◁ f := + rfl + +/-! ## Associativity -/ + +private theorem fibreTensorComp_EE + {S : SuperCommAlgebra.{v, v}} {M M' N P Q : S.Mod.{v, v, v, v}} + (f : M ⟶ M') (g : M'.tensor N ⟶ P) (h : P ⟶ Q) + (m : M.even) (n : N.even) : + (SuperCommAlgebra.Mod.tensorHom f (𝟙 N) ≫ g ≫ h).evenMap (tmulEE M N m n) = + h.evenMap (g.evenMap (tmulEE M' N (f.evenMap m) n)) := by + simp only [comp_evenMap, LinearMap.comp_apply, tensorHom_evenMap_tmulEE, id_evenMap, + LinearMap.id_coe, id_eq] + +private theorem fibreTensorComp_EO + {S : SuperCommAlgebra.{v, v}} {M M' N P Q : S.Mod.{v, v, v, v}} + (f : M ⟶ M') (g : M'.tensor N ⟶ P) (h : P ⟶ Q) + (m : M.even) (n : N.odd) : + (SuperCommAlgebra.Mod.tensorHom f (𝟙 N) ≫ g ≫ h).oddMap (tmulEO M N m n) = + h.oddMap (g.oddMap (tmulEO M' N (f.evenMap m) n)) := by + simp only [comp_oddMap, LinearMap.comp_apply, tensorHom_oddMap_tmulEO, id_oddMap, + LinearMap.id_coe, id_eq] + +private theorem fibreTensorComp_OE + {S : SuperCommAlgebra.{v, v}} {M M' N P Q : S.Mod.{v, v, v, v}} + (f : M ⟶ M') (g : M'.tensor N ⟶ P) (h : P ⟶ Q) + (m : M.odd) (n : N.even) : + (SuperCommAlgebra.Mod.tensorHom f (𝟙 N) ≫ g ≫ h).oddMap (tmulOE M N m n) = + h.oddMap (g.oddMap (tmulOE M' N (f.oddMap m) n)) := by + simp only [comp_oddMap, LinearMap.comp_apply, tensorHom_oddMap_tmulOE, id_evenMap, + LinearMap.id_coe, id_eq] + +private theorem fibreTensorComp_OO + {S : SuperCommAlgebra.{v, v}} {M M' N P Q : S.Mod.{v, v, v, v}} + (f : M ⟶ M') (g : M'.tensor N ⟶ P) (h : P ⟶ Q) + (m : M.odd) (n : N.odd) : + (SuperCommAlgebra.Mod.tensorHom f (𝟙 N) ≫ g ≫ h).evenMap (tmulOO M N m n) = + h.evenMap (g.evenMap (tmulOO M' N (f.oddMap m) n)) := by + simp only [comp_evenMap, LinearMap.comp_apply, tensorHom_evenMap_tmulOO, id_oddMap, + LinearMap.id_coe, id_eq] + +private theorem fibreAssocTensorComp_EEE + {S : SuperCommAlgebra.{v, v}} {M N P Q T : S.Mod.{v, v, v, v}} + (f : N.tensor P ⟶ Q) (g : M.tensor Q ⟶ T) + (m : M.even) (n : N.even) + (p : P.even) : + (assocHom M N P ≫ SuperCommAlgebra.Mod.tensorHom (𝟙 M) f ≫ g).evenMap + (tmulEE (M.tensor N) P (tmulEE M N m n) p) = + g.evenMap (tmulEE M Q m (f.evenMap (tmulEE N P n p))) := by + simp only [comp_evenMap, LinearMap.comp_apply, tensorHom_evenMap_tmulEE, + assocHom_evenMap_tmulEE, assocFee_tmulEE, id_evenMap, LinearMap.id_coe, id_eq] + +private theorem fibreAssocTensorComp_EEO + {S : SuperCommAlgebra.{v, v}} {M N P Q T : S.Mod.{v, v, v, v}} + (f : N.tensor P ⟶ Q) (g : M.tensor Q ⟶ T) + (m : M.even) (n : N.even) + (p : P.odd) : + (assocHom M N P ≫ SuperCommAlgebra.Mod.tensorHom (𝟙 M) f ≫ g).oddMap + (tmulEO (M.tensor N) P (tmulEE M N m n) p) = + g.oddMap (tmulEO M Q m (f.oddMap (tmulEO N P n p))) := by + simp only [comp_oddMap, LinearMap.comp_apply, tensorHom_oddMap_tmulEO, assocHom_oddMap_tmulEO, + assocFeo_tmulEE, id_evenMap, LinearMap.id_coe, id_eq] + +private theorem fibreAssocTensorComp_EOE + {S : SuperCommAlgebra.{v, v}} {M N P Q T : S.Mod.{v, v, v, v}} + (f : N.tensor P ⟶ Q) (g : M.tensor Q ⟶ T) + (m : M.even) (n : N.odd) + (p : P.even) : + (assocHom M N P ≫ SuperCommAlgebra.Mod.tensorHom (𝟙 M) f ≫ g).oddMap + (tmulOE (M.tensor N) P (tmulEO M N m n) p) = + g.oddMap (tmulEO M Q m (f.oddMap (tmulOE N P n p))) := by + simp only [comp_oddMap, LinearMap.comp_apply, tensorHom_oddMap_tmulEO, assocHom_oddMap_tmulOE, + assocFoe_tmulEO, id_evenMap, LinearMap.id_coe, id_eq] + +private theorem fibreAssocTensorComp_EOO + {S : SuperCommAlgebra.{v, v}} {M N P Q T : S.Mod.{v, v, v, v}} + (f : N.tensor P ⟶ Q) (g : M.tensor Q ⟶ T) + (m : M.even) (n : N.odd) + (p : P.odd) : + (assocHom M N P ≫ SuperCommAlgebra.Mod.tensorHom (𝟙 M) f ≫ g).evenMap + (tmulOO (M.tensor N) P (tmulEO M N m n) p) = + g.evenMap (tmulEE M Q m (f.evenMap (tmulOO N P n p))) := by + simp only [comp_evenMap, LinearMap.comp_apply, tensorHom_evenMap_tmulEE, + assocHom_evenMap_tmulOO, assocFoo_tmulEO, id_evenMap, LinearMap.id_coe, id_eq] + +private theorem fibreAssocTensorComp_OEE + {S : SuperCommAlgebra.{v, v}} {M N P Q T : S.Mod.{v, v, v, v}} + (f : N.tensor P ⟶ Q) (g : M.tensor Q ⟶ T) + (m : M.odd) (n : N.even) + (p : P.even) : + (assocHom M N P ≫ SuperCommAlgebra.Mod.tensorHom (𝟙 M) f ≫ g).oddMap + (tmulOE (M.tensor N) P (tmulOE M N m n) p) = + g.oddMap (tmulOE M Q m (f.evenMap (tmulEE N P n p))) := by + simp only [comp_oddMap, LinearMap.comp_apply, tensorHom_oddMap_tmulOE, assocHom_oddMap_tmulOE, + assocFoe_tmulOE, id_oddMap, LinearMap.id_coe, id_eq] + +private theorem fibreAssocTensorComp_OEO + {S : SuperCommAlgebra.{v, v}} {M N P Q T : S.Mod.{v, v, v, v}} + (f : N.tensor P ⟶ Q) (g : M.tensor Q ⟶ T) + (m : M.odd) (n : N.even) + (p : P.odd) : + (assocHom M N P ≫ SuperCommAlgebra.Mod.tensorHom (𝟙 M) f ≫ g).evenMap + (tmulOO (M.tensor N) P (tmulOE M N m n) p) = + g.evenMap (tmulOO M Q m (f.oddMap (tmulEO N P n p))) := by + simp only [comp_evenMap, LinearMap.comp_apply, tensorHom_evenMap_tmulOO, + assocHom_evenMap_tmulOO, assocFoo_tmulOE, id_oddMap, LinearMap.id_coe, id_eq] + +private theorem fibreAssocTensorComp_OOE + {S : SuperCommAlgebra.{v, v}} {M N P Q T : S.Mod.{v, v, v, v}} + (f : N.tensor P ⟶ Q) (g : M.tensor Q ⟶ T) + (m : M.odd) (n : N.odd) + (p : P.even) : + (assocHom M N P ≫ SuperCommAlgebra.Mod.tensorHom (𝟙 M) f ≫ g).evenMap + (tmulEE (M.tensor N) P (tmulOO M N m n) p) = + g.evenMap (tmulOO M Q m (f.oddMap (tmulOE N P n p))) := by + simp only [comp_evenMap, LinearMap.comp_apply, tensorHom_evenMap_tmulOO, + assocHom_evenMap_tmulEE, assocFee_tmulOO, id_oddMap, LinearMap.id_coe, id_eq] + +private theorem fibreAssocTensorComp_OOO + {S : SuperCommAlgebra.{v, v}} {M N P Q T : S.Mod.{v, v, v, v}} + (f : N.tensor P ⟶ Q) (g : M.tensor Q ⟶ T) + (m : M.odd) (n : N.odd) + (p : P.odd) : + (assocHom M N P ≫ SuperCommAlgebra.Mod.tensorHom (𝟙 M) f ≫ g).oddMap + (tmulEO (M.tensor N) P (tmulOO M N m n) p) = + g.oddMap (tmulOE M Q m (f.evenMap (tmulOO N P n p))) := by + simp only [comp_oddMap, LinearMap.comp_apply, tensorHom_oddMap_tmulOE, assocHom_oddMap_tmulEO, + assocFeo_tmulOO, id_oddMap, LinearMap.id_coe, id_eq] + +/- Keep intermediate computations in bundled module types, so rewriting does not repeatedly +unfold the module instance dictionaries. The final coherence step unfolds the products once. -/ +private noncomputable def fibreProductEE + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (V W : D) + (m : (gammaModule D L R (freeMod R V).X).even) + (n : (gammaModule D L R (freeMod R W).X).even) : + (gammaModule D L R (freeMod R (V ⊗ W)).X).even := + (λ_ (𝟙_ D)).inv ≫ (m ⊗ₘ n) ≫ freeModShuffle R V W + +private noncomputable def fibreProductOO + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (V W : D) + (m : (gammaModule D L R (freeMod R V).X).odd) + (n : (gammaModule D L R (freeMod R W).X).odd) : + (gammaModule D L R (freeMod R (V ⊗ W)).X).even := + L.sq.inv ≫ (m ⊗ₘ n) ≫ freeModShuffle R V W + +private noncomputable def fibreProductEO + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (V W : D) + (m : (gammaModule D L R (freeMod R V).X).even) + (n : (gammaModule D L R (freeMod R W).X).odd) : + (gammaModule D L R (freeMod R (V ⊗ W)).X).odd := + (λ_ L.obj).inv ≫ (m ⊗ₘ n) ≫ freeModShuffle R V W + +private noncomputable def fibreProductOE + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (V W : D) + (m : (gammaModule D L R (freeMod R V).X).odd) + (n : (gammaModule D L R (freeMod R W).X).even) : + (gammaModule D L R (freeMod R (V ⊗ W)).X).odd := + (ρ_ L.obj).inv ≫ (m ⊗ₘ n) ≫ freeModShuffle R V W + +private noncomputable def fibreMapEven + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] {V W : D} + (f : V ⟶ W) (m : (gammaModule D L R (freeMod R V).X).even) : + (gammaModule D L R (freeMod R W).X).even := m ≫ R ◁ f + +private noncomputable def fibreMapOdd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] {V W : D} + (f : V ⟶ W) (m : (gammaModule D L R (freeMod R V).X).odd) : + (gammaModule D L R (freeMod R W).X).odd := m ≫ R ◁ f + +private theorem typedFibreMuEE + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (V W : D) + (m : (gammaModule D L R (freeMod R V).X).even) + (n : (gammaModule D L R (freeMod R W).X).even) : + (fibreMu L R V W).evenMap + (tmulEE (gammaModule D L R (freeMod R V).X) + (gammaModule D L R (freeMod R W).X) m n) = fibreProductEE L R V W m n := + fibreMu_evenMap_tmulEE L R V W m n + +private theorem typedFibreMuOO + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (V W : D) + (m : (gammaModule D L R (freeMod R V).X).odd) + (n : (gammaModule D L R (freeMod R W).X).odd) : + (fibreMu L R V W).evenMap + (tmulOO (gammaModule D L R (freeMod R V).X) + (gammaModule D L R (freeMod R W).X) m n) = fibreProductOO L R V W m n := + fibreMu_evenMap_tmulOO L R V W m n + +private theorem typedFibreMuEO + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (V W : D) + (m : (gammaModule D L R (freeMod R V).X).even) + (n : (gammaModule D L R (freeMod R W).X).odd) : + (fibreMu L R V W).oddMap + (tmulEO (gammaModule D L R (freeMod R V).X) + (gammaModule D L R (freeMod R W).X) m n) = fibreProductEO L R V W m n := + fibreMu_oddMap_tmulEO L R V W m n + +private theorem typedFibreMuOE + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (V W : D) + (m : (gammaModule D L R (freeMod R V).X).odd) + (n : (gammaModule D L R (freeMod R W).X).even) : + (fibreMu L R V W).oddMap + (tmulOE (gammaModule D L R (freeMod R V).X) + (gammaModule D L R (freeMod R W).X) m n) = fibreProductOE L R V W m n := + fibreMu_oddMap_tmulOE L R V W m n + +private theorem typedFibreMapEven + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] {V W : D} + (f : V ⟶ W) (m : (gammaModule D L R (freeMod R V).X).even) : + (gammaFunMap L R (freeModMap R f)).evenMap m = fibreMapEven L R f m := rfl + +private theorem typedFibreMapOdd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] {V W : D} + (f : V ⟶ W) (m : (gammaModule D L R (freeMod R V).X).odd) : + (gammaFunMap L R (freeModMap R f)).oddMap m = fibreMapOdd L R f m := rfl + +private theorem fibreMu_associativity_eee + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (V W Z : D) : + ∀ m n p, + (SuperCommAlgebra.Mod.tensorHom (fibreMu L R V W) + (𝟙 (gammaModule D L R (freeMod R Z).X)) ≫ + fibreMu L R (V ⊗ W) Z ≫ + gammaFunMap L R (freeModMap R (α_ V W Z).hom)).evenMap (tmulEE ((gammaModule D L R + (freeMod R V).X).tensor (gammaModule D L R (freeMod R W).X)) (gammaModule D L R + (freeMod R Z).X) + (tmulEE (gammaModule D L R (freeMod R V).X) (gammaModule D L R (freeMod R W).X) m n) p) = + (assocHom (gammaModule D L R (freeMod R V).X) + (gammaModule D L R (freeMod R W).X) + (gammaModule D L R (freeMod R Z).X) ≫ + SuperCommAlgebra.Mod.tensorHom + (𝟙 (gammaModule D L R (freeMod R V).X)) + (fibreMu L R W Z) ≫ + fibreMu L R V (W ⊗ Z)).evenMap (tmulEE ((gammaModule D L R (freeMod R V).X).tensor + (gammaModule D L R (freeMod R W).X)) (gammaModule D L R (freeMod R Z).X) + (tmulEE (gammaModule D L R (freeMod R V).X) (gammaModule D L R (freeMod R W).X) m n) + p) := by + intro m n p + rw [fibreTensorComp_EE, fibreAssocTensorComp_EEE] + rw [typedFibreMuEE, typedFibreMuEE, typedFibreMuEE, typedFibreMuEE, + typedFibreMapEven] + refine freeModShuffle_assoc_at' R _ _ _ _ ?_ m n p + monoidal + +private theorem fibreMu_associativity_ooe + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (V W Z : D) : + ∀ m n p, + (SuperCommAlgebra.Mod.tensorHom (fibreMu L R V W) + (𝟙 (gammaModule D L R (freeMod R Z).X)) ≫ + fibreMu L R (V ⊗ W) Z ≫ + gammaFunMap L R (freeModMap R (α_ V W Z).hom)).evenMap (tmulEE ((gammaModule D L R + (freeMod R V).X).tensor (gammaModule D L R (freeMod R W).X)) (gammaModule D L R + (freeMod R Z).X) + (tmulOO (gammaModule D L R (freeMod R V).X) (gammaModule D L R (freeMod R W).X) m n) p) = + (assocHom (gammaModule D L R (freeMod R V).X) + (gammaModule D L R (freeMod R W).X) + (gammaModule D L R (freeMod R Z).X) ≫ + SuperCommAlgebra.Mod.tensorHom + (𝟙 (gammaModule D L R (freeMod R V).X)) + (fibreMu L R W Z) ≫ + fibreMu L R V (W ⊗ Z)).evenMap (tmulEE ((gammaModule D L R (freeMod R V).X).tensor + (gammaModule D L R (freeMod R W).X)) (gammaModule D L R (freeMod R Z).X) + (tmulOO (gammaModule D L R (freeMod R V).X) (gammaModule D L R (freeMod R W).X) m n) + p) := by + intro m n p + rw [fibreTensorComp_EE, fibreAssocTensorComp_OOE] + rw [typedFibreMuOO, typedFibreMuEE, typedFibreMuOE, typedFibreMuOO, + typedFibreMapEven] + refine freeModShuffle_assoc_at' R _ _ _ _ ?_ m n p + have hc : (ρ_ (L.obj ⊗ L.obj)).inv ≫ + (α_ L.obj L.obj (𝟙_ D)).hom = + L.obj ◁ (ρ_ L.obj).inv := by monoidal + rw [unitors_inv_equal, ← Category.assoc, + ← rightUnitor_inv_naturality, Category.assoc, hc] + +private theorem fibreMu_associativity_eoo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (V W Z : D) : + ∀ m n p, + (SuperCommAlgebra.Mod.tensorHom (fibreMu L R V W) + (𝟙 (gammaModule D L R (freeMod R Z).X)) ≫ + fibreMu L R (V ⊗ W) Z ≫ + gammaFunMap L R (freeModMap R (α_ V W Z).hom)).evenMap (tmulOO ((gammaModule D L R + (freeMod R V).X).tensor (gammaModule D L R (freeMod R W).X)) (gammaModule D L R + (freeMod R Z).X) + (tmulEO (gammaModule D L R (freeMod R V).X) (gammaModule D L R (freeMod R W).X) m n) p) = + (assocHom (gammaModule D L R (freeMod R V).X) + (gammaModule D L R (freeMod R W).X) + (gammaModule D L R (freeMod R Z).X) ≫ + SuperCommAlgebra.Mod.tensorHom + (𝟙 (gammaModule D L R (freeMod R V).X)) + (fibreMu L R W Z) ≫ + fibreMu L R V (W ⊗ Z)).evenMap (tmulOO ((gammaModule D L R (freeMod R V).X).tensor + (gammaModule D L R (freeMod R W).X)) (gammaModule D L R (freeMod R Z).X) + (tmulEO (gammaModule D L R (freeMod R V).X) (gammaModule D L R (freeMod R W).X) m n) + p) := by + intro m n p + rw [fibreTensorComp_OO, fibreAssocTensorComp_EOO] + rw [typedFibreMuEO, typedFibreMuOO, typedFibreMuOO, typedFibreMuEE, + typedFibreMapEven] + refine freeModShuffle_assoc_at' R _ _ _ _ ?_ m n p + have hc : (λ_ L.obj).inv ▷ L.obj ≫ + (α_ (𝟙_ D) L.obj L.obj).hom = + (λ_ (L.obj ⊗ L.obj)).inv := by monoidal + rw [hc] + exact leftUnitor_inv_naturality L.sq.inv + +private theorem fibreMu_associativity_oeo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (V W Z : D) : + ∀ m n p, + (SuperCommAlgebra.Mod.tensorHom (fibreMu L R V W) + (𝟙 (gammaModule D L R (freeMod R Z).X)) ≫ + fibreMu L R (V ⊗ W) Z ≫ + gammaFunMap L R (freeModMap R (α_ V W Z).hom)).evenMap (tmulOO ((gammaModule D L R + (freeMod R V).X).tensor (gammaModule D L R (freeMod R W).X)) (gammaModule D L R + (freeMod R Z).X) + (tmulOE (gammaModule D L R (freeMod R V).X) (gammaModule D L R (freeMod R W).X) m n) p) = + (assocHom (gammaModule D L R (freeMod R V).X) + (gammaModule D L R (freeMod R W).X) + (gammaModule D L R (freeMod R Z).X) ≫ + SuperCommAlgebra.Mod.tensorHom + (𝟙 (gammaModule D L R (freeMod R V).X)) + (fibreMu L R W Z) ≫ + fibreMu L R V (W ⊗ Z)).evenMap (tmulOO ((gammaModule D L R (freeMod R V).X).tensor + (gammaModule D L R (freeMod R W).X)) (gammaModule D L R (freeMod R Z).X) + (tmulOE (gammaModule D L R (freeMod R V).X) (gammaModule D L R (freeMod R W).X) m n) + p) := by + intro m n p + rw [fibreTensorComp_OO, fibreAssocTensorComp_OEO] + rw [typedFibreMuOE, typedFibreMuOO, typedFibreMuEO, typedFibreMuOO, + typedFibreMapEven] + refine freeModShuffle_assoc_at' R _ _ _ _ ?_ m n p + have hc : (ρ_ L.obj).inv ▷ L.obj ≫ + (α_ L.obj (𝟙_ D) L.obj).hom = + L.obj ◁ (λ_ L.obj).inv := by monoidal + rw [hc] + +private theorem fibreMu_associativity_eeo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (V W Z : D) : + ∀ m n p, + (SuperCommAlgebra.Mod.tensorHom (fibreMu L R V W) + (𝟙 (gammaModule D L R (freeMod R Z).X)) ≫ + fibreMu L R (V ⊗ W) Z ≫ + gammaFunMap L R (freeModMap R (α_ V W Z).hom)).oddMap (tmulEO ((gammaModule D L R + (freeMod R V).X).tensor (gammaModule D L R (freeMod R W).X)) (gammaModule D L R + (freeMod R Z).X) + (tmulEE (gammaModule D L R (freeMod R V).X) (gammaModule D L R (freeMod R W).X) m n) p) = + (assocHom (gammaModule D L R (freeMod R V).X) + (gammaModule D L R (freeMod R W).X) + (gammaModule D L R (freeMod R Z).X) ≫ + SuperCommAlgebra.Mod.tensorHom + (𝟙 (gammaModule D L R (freeMod R V).X)) + (fibreMu L R W Z) ≫ + fibreMu L R V (W ⊗ Z)).oddMap (tmulEO ((gammaModule D L R (freeMod R V).X).tensor + (gammaModule D L R (freeMod R W).X)) (gammaModule D L R (freeMod R Z).X) + (tmulEE (gammaModule D L R (freeMod R V).X) (gammaModule D L R (freeMod R W).X) m n) + p) := by + intro m n p + rw [fibreTensorComp_EO, fibreAssocTensorComp_EEO] + rw [typedFibreMuEE, typedFibreMuEO, typedFibreMuEO, typedFibreMuEO, + typedFibreMapOdd] + refine freeModShuffle_assoc_at' R _ _ _ _ ?_ m n p + monoidal + +private theorem fibreMu_associativity_ooo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (V W Z : D) : + ∀ m n p, + (SuperCommAlgebra.Mod.tensorHom (fibreMu L R V W) + (𝟙 (gammaModule D L R (freeMod R Z).X)) ≫ + fibreMu L R (V ⊗ W) Z ≫ + gammaFunMap L R (freeModMap R (α_ V W Z).hom)).oddMap (tmulEO ((gammaModule D L R + (freeMod R V).X).tensor (gammaModule D L R (freeMod R W).X)) (gammaModule D L R + (freeMod R Z).X) + (tmulOO (gammaModule D L R (freeMod R V).X) (gammaModule D L R (freeMod R W).X) m n) p) = + (assocHom (gammaModule D L R (freeMod R V).X) + (gammaModule D L R (freeMod R W).X) + (gammaModule D L R (freeMod R Z).X) ≫ + SuperCommAlgebra.Mod.tensorHom + (𝟙 (gammaModule D L R (freeMod R V).X)) + (fibreMu L R W Z) ≫ + fibreMu L R V (W ⊗ Z)).oddMap (tmulEO ((gammaModule D L R (freeMod R V).X).tensor + (gammaModule D L R (freeMod R W).X)) (gammaModule D L R (freeMod R Z).X) + (tmulOO (gammaModule D L R (freeMod R V).X) (gammaModule D L R (freeMod R W).X) m n) + p) := by + intro m n p + rw [fibreTensorComp_EO, fibreAssocTensorComp_OOO] + rw [typedFibreMuOO, typedFibreMuEO, typedFibreMuOO, typedFibreMuOE, + typedFibreMapOdd] + refine freeModShuffle_assoc_at' R _ _ _ _ ?_ m n p + have h2 : L.sq.inv ▷ L.obj ≫ (α_ L.obj L.obj L.obj).hom = + (λ_ L.obj).hom ≫ (ρ_ L.obj).inv ≫ + L.obj ◁ L.sq.inv := by + rw [← reassoc_of% L.evaluation_coevaluation, + ← MonoidalCategory.whiskerLeft_comp, Iso.hom_inv_id, + MonoidalCategory.whiskerLeft_id, Category.comp_id] + rw [h2, ← Category.assoc, Iso.inv_hom_id, Category.id_comp] + +private theorem fibreMu_associativity_eoe + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (V W Z : D) : + ∀ m n p, + (SuperCommAlgebra.Mod.tensorHom (fibreMu L R V W) + (𝟙 (gammaModule D L R (freeMod R Z).X)) ≫ + fibreMu L R (V ⊗ W) Z ≫ + gammaFunMap L R (freeModMap R (α_ V W Z).hom)).oddMap (tmulOE ((gammaModule D L R + (freeMod R V).X).tensor (gammaModule D L R (freeMod R W).X)) (gammaModule D L R + (freeMod R Z).X) + (tmulEO (gammaModule D L R (freeMod R V).X) (gammaModule D L R (freeMod R W).X) m n) p) = + (assocHom (gammaModule D L R (freeMod R V).X) + (gammaModule D L R (freeMod R W).X) + (gammaModule D L R (freeMod R Z).X) ≫ + SuperCommAlgebra.Mod.tensorHom + (𝟙 (gammaModule D L R (freeMod R V).X)) + (fibreMu L R W Z) ≫ + fibreMu L R V (W ⊗ Z)).oddMap (tmulOE ((gammaModule D L R (freeMod R V).X).tensor + (gammaModule D L R (freeMod R W).X)) (gammaModule D L R (freeMod R Z).X) + (tmulEO (gammaModule D L R (freeMod R V).X) (gammaModule D L R (freeMod R W).X) m n) + p) := by + intro m n p + rw [fibreTensorComp_OE, fibreAssocTensorComp_EOE] + rw [typedFibreMuEO, typedFibreMuOE, typedFibreMuOE, typedFibreMuEO, + typedFibreMapOdd] + refine freeModShuffle_assoc_at' R _ _ _ _ ?_ m n p + monoidal + +private theorem fibreMu_associativity_oee + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (V W Z : D) : + ∀ m n p, + (SuperCommAlgebra.Mod.tensorHom (fibreMu L R V W) + (𝟙 (gammaModule D L R (freeMod R Z).X)) ≫ + fibreMu L R (V ⊗ W) Z ≫ + gammaFunMap L R (freeModMap R (α_ V W Z).hom)).oddMap (tmulOE ((gammaModule D L R + (freeMod R V).X).tensor (gammaModule D L R (freeMod R W).X)) (gammaModule D L R + (freeMod R Z).X) + (tmulOE (gammaModule D L R (freeMod R V).X) (gammaModule D L R (freeMod R W).X) m n) p) = + (assocHom (gammaModule D L R (freeMod R V).X) + (gammaModule D L R (freeMod R W).X) + (gammaModule D L R (freeMod R Z).X) ≫ + SuperCommAlgebra.Mod.tensorHom + (𝟙 (gammaModule D L R (freeMod R V).X)) + (fibreMu L R W Z) ≫ + fibreMu L R V (W ⊗ Z)).oddMap (tmulOE ((gammaModule D L R (freeMod R V).X).tensor + (gammaModule D L R (freeMod R W).X)) (gammaModule D L R (freeMod R Z).X) + (tmulOE (gammaModule D L R (freeMod R V).X) (gammaModule D L R (freeMod R W).X) m n) + p) := by + intro m n p + rw [fibreTensorComp_OE, fibreAssocTensorComp_OEE] + rw [typedFibreMuOE, typedFibreMuOE, typedFibreMuEE, typedFibreMuOE, + typedFibreMapOdd] + refine freeModShuffle_assoc_at' R _ _ _ _ ?_ m n p + monoidal + +/-- **Associativity of the monoidal comparison of the fibre +functor**: the two ways of comparing a threefold tensor product +agree, up to the associator of the super modules and the +reassociation of the three objects. -/ +theorem fibreMu_associativity + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (V W Z : D) : + SuperCommAlgebra.Mod.tensorHom (fibreMu L R V W) + (𝟙 (gammaModule D L R (freeMod R Z).X)) ≫ + fibreMu L R (V ⊗ W) Z ≫ + gammaFunMap L R (freeModMap R (α_ V W Z).hom) + = assocHom (gammaModule D L R (freeMod R V).X) + (gammaModule D L R (freeMod R W).X) + (gammaModule D L R (freeMod R Z).X) ≫ + SuperCommAlgebra.Mod.tensorHom + (𝟙 (gammaModule D L R (freeMod R V).X)) + (fibreMu L R W Z) ≫ + fibreMu L R V (W ⊗ Z) := by + exact hom_ext₃ + (fibreMu_associativity_eee L R V W Z) + (fibreMu_associativity_ooe L R V W Z) + (fibreMu_associativity_eoo L R V W Z) + (fibreMu_associativity_oeo L R V W Z) + (fibreMu_associativity_eeo L R V W Z) + (fibreMu_associativity_ooo L R V W Z) + (fibreMu_associativity_eoe L R V W Z) + (fibreMu_associativity_oee L R V W Z) + +/-! ## Unitality -/ + +/-- **Left unitality of the monoidal comparison of the fibre +functor**: the unit comparison in the first slot is the left +unitor of the super modules. No sign appears. -/ +theorem fibreMu_left_unitality + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (V : D) : + leftUnitorHom (gammaModule D L R (freeMod R V).X) + = SuperCommAlgebra.Mod.tensorHom (fibreEps L R) + (𝟙 (gammaModule D L R (freeMod R V).X)) ≫ + fibreMu L R (𝟙_ D) V ≫ + gammaFunMap L R (freeModMap R (λ_ V).hom) := by + refine hom_ext (fun x m => ?_) (fun u m => ?_) (fun x m => ?_) + (fun u m => ?_) + · erw [leftUnitorHom_evenMap_tmulEE, comp_evenMap_apply, + comp_evenMap_apply, tensorHom_evenMap_tmulEE, + typedFibreMuEE, typedFibreMapEven] + exact (freeModShuffle_unit_left_at' R (λ_ (𝟙_ D)).inv x m).symm + · erw [leftUnitorHom_evenMap_tmulOO, comp_evenMap_apply, + comp_evenMap_apply, tensorHom_evenMap_tmulOO, + typedFibreMuOO, typedFibreMapEven] + exact (freeModShuffle_unit_left_at' R L.sq.inv u m).symm + · erw [leftUnitorHom_oddMap_tmulEO, comp_oddMap_apply, + comp_oddMap_apply, tensorHom_oddMap_tmulEO, + typedFibreMuEO, typedFibreMapOdd] + exact (freeModShuffle_unit_left_at' R (λ_ L.obj).inv x m).symm + · erw [leftUnitorHom_oddMap_tmulOE, comp_oddMap_apply, + comp_oddMap_apply, tensorHom_oddMap_tmulOE, + typedFibreMuOE, typedFibreMapOdd] + exact (freeModShuffle_unit_left_at' R (ρ_ L.obj).inv u m).symm + +/-- **Right unitality of the monoidal comparison of the fibre +functor**: the unit comparison in the second slot is the right +unitor of the super modules. The Koszul sign of the odd-odd block +of the right unitor is `RS.freeModShuffle_unit_right_oo`, and it is +supplied by `RS.oddLine_sq_inv_braiding`. -/ +theorem fibreMu_right_unitality + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (V : D) : + rightUnitorHom (gammaModule D L R (freeMod R V).X) + = SuperCommAlgebra.Mod.tensorHom + (𝟙 (gammaModule D L R (freeMod R V).X)) + (fibreEps L R) ≫ + fibreMu L R V (𝟙_ D) ≫ + gammaFunMap L R (freeModMap R (ρ_ V).hom) := by + refine hom_ext (fun m x => ?_) (fun m u => ?_) (fun m u => ?_) + (fun m x => ?_) + · erw [rightUnitorHom_evenMap_tmulEE, comp_evenMap_apply, + comp_evenMap_apply, tensorHom_evenMap_tmulEE, + typedFibreMuEE, typedFibreMapEven] + exact (freeModShuffle_unit_right_ee R V m x).symm + · erw [rightUnitorHom_evenMap_tmulOO, comp_evenMap_apply, + comp_evenMap_apply, tensorHom_evenMap_tmulOO, + typedFibreMuOO, typedFibreMapEven] + exact (freeModShuffle_unit_right_oo L R V m u).symm + · erw [rightUnitorHom_oddMap_tmulEO, comp_oddMap_apply, + comp_oddMap_apply, tensorHom_oddMap_tmulEO, + typedFibreMuEO, typedFibreMapOdd] + exact (freeModShuffle_unit_right_eo L R V m u).symm + · erw [rightUnitorHom_oddMap_tmulOE, comp_oddMap_apply, + comp_oddMap_apply, tensorHom_oddMap_tmulOE, + typedFibreMuOE, typedFibreMapOdd] + exact (freeModShuffle_unit_right_oe L R V m x).symm + +/-! ## Compatibility with the braiding -/ + +/-- **The monoidal comparison of the fibre functor commutes with +the braiding**: swapping the two factors of the super-module +tensor product and comparing agrees with comparing and swapping +the two objects. The Koszul sign of the odd-odd block of the +Koszul swap is `RS.freeModShuffle_braiding_oo`, and it is again +supplied by `RS.oddLine_sq_inv_braiding`. -/ +theorem fibreMu_braided + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (V W : D) : + braidingHom (gammaModule D L R (freeMod R V).X) + (gammaModule D L R (freeMod R W).X) ≫ fibreMu L R W V + = fibreMu L R V W ≫ + gammaFunMap L R (freeModMap R (β_ V W).hom) := by + refine hom_ext (fun m n => ?_) (fun m n => ?_) (fun m n => ?_) + (fun m n => ?_) + · erw [comp_evenMap_apply, braidingHom_evenMap_tmulEE, + typedFibreMuEE, comp_evenMap_apply, + typedFibreMuEE, typedFibreMapEven] + exact (freeModShuffle_braiding_ee R V W m n).symm + · erw [comp_evenMap_apply, braidingHom_evenMap_tmulOO, map_neg, + typedFibreMuOO, comp_evenMap_apply, + typedFibreMuOO, typedFibreMapEven] + exact (freeModShuffle_braiding_oo L R V W m n).symm + · erw [comp_oddMap_apply, braidingHom_oddMap_tmulEO, + typedFibreMuOE, comp_oddMap_apply, + typedFibreMuEO, typedFibreMapOdd] + exact (freeModShuffle_braiding_eo L R V W m n).symm + · erw [comp_oddMap_apply, braidingHom_oddMap_tmulOE, + typedFibreMuEO, comp_oddMap_apply, + typedFibreMuOE, typedFibreMapOdd] + exact (freeModShuffle_braiding_oe L R V W m n).symm + +/-! ## The lax monoidal and lax braided structures -/ + +/-- **The fibre functor is lax monoidal**, with unit `RS.fibreEps` +and tensorator `RS.fibreMu`. -/ +noncomputable instance fibreOverLaxMonoidal + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] : + (fibreOver L R).LaxMonoidal := + CategoryTheory.Functor.LaxMonoidal.ofTensorHom + (F := fibreOver L R) (fibreEps L R) (fibreMu L R) + (fun f g => fibreMu_naturality L R f g) + (fun V W Z => fibreMu_associativity L R V W Z) + (fun V => fibreMu_left_unitality L R V) + (fun V => fibreMu_right_unitality L R V) + +/-- The unit of the lax monoidal structure. -/ +theorem fibreOver_ε [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] : + CategoryTheory.Functor.LaxMonoidal.ε (fibreOver L R) + = fibreEps L R := + rfl + +/-- The tensorator of the lax monoidal structure. -/ +theorem fibreOver_μ [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (V W : D) : + CategoryTheory.Functor.LaxMonoidal.μ (fibreOver L R) V W + = fibreMu L R V W := + rfl + +/-- **The fibre functor is lax braided**: its tensorator commutes +with the two symmetries. -/ +noncomputable instance fibreOverLaxBraided + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] : + (fibreOver L R).LaxBraided where + toLaxMonoidal := fibreOverLaxMonoidal L R + braided V W := (fibreMu_braided L R V W).symm + +end Fibre + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMu.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMu.lean new file mode 100644 index 0000000000..551627b498 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMu.lean @@ -0,0 +1,163 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairNat +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModTensor + +/-! +# The monoidal comparison of the fibre functor + +Deligne's `ω` sends an object to the realization of its free +module, so its monoidal comparison is the comparison map of +(2.11.1) at two free modules, followed by the identification of the +relative tensor of two free modules with the free module of the +tensor product. On the generators of the tensor product of super +modules the composite has a completely explicit form: tensor the +two morphisms and shuffle. No coequalizer survives in that +formula, which is what makes the coherence of `ω` a computation in +the ambient category alone. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +section + +variable {D : Type u} + +open SuperCommAlgebra.Mod + +/-- **The monoidal comparison of the fibre functor.** -/ +noncomputable def fibreMu + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (V : D) (W : D) : + (gammaModule D L R (freeMod R V).X).tensor + (gammaModule D L R (freeMod R W).X) ⟶ + gammaModule D L R (freeMod R (V ⊗ W)).X := + gammaPairComparison L R (freeMod R V) (freeMod R W) ≫ + gammaFunMap L R (freeModTensorIso R V W).hom + +/-- The monoidal comparison on even-even generators. -/ +@[simp] theorem fibreMu_evenMap_tmulEE + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (V : D) (W : D) + (m : 𝟙_ D ⟶ R ⊗ V) + (n : 𝟙_ D ⟶ R ⊗ W) : + (fibreMu L R V W).evenMap + (tmulEE (gammaModule D L R (freeMod R V).X) + (gammaModule D L R (freeMod R W).X) m n) = + (λ_ (𝟙_ D)).inv ≫ (m ⊗ₘ n) ≫ freeModShuffle R V W := by + have h : (fibreMu L R V W).evenMap + (tmulEE (gammaModule D L R (freeMod R V).X) + (gammaModule D L R (freeMod R W).X) m n) = + gammaPairEven L R (freeMod R V) (freeMod R W) + (tmulEE _ _ m n) ≫ + (freeModTensorIso R V W).hom.hom := rfl + erw [h, gammaPairEven_tmulEE, gpairLin_apply] + exact Eq.trans (Category.assoc _ _ _) + (whisker_eq _ (freeModTensorIso_gpair R V W m n)) + +/-- The monoidal comparison on odd-odd generators. -/ +@[simp] theorem fibreMu_evenMap_tmulOO + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (V : D) (W : D) + (m : L.obj ⟶ R ⊗ V) + (n : L.obj ⟶ R ⊗ W) : + (fibreMu L R V W).evenMap + (tmulOO (gammaModule D L R (freeMod R V).X) + (gammaModule D L R (freeMod R W).X) m n) = + L.sq.inv ≫ (m ⊗ₘ n) ≫ freeModShuffle R V W := by + have h : (fibreMu L R V W).evenMap + (tmulOO (gammaModule D L R (freeMod R V).X) + (gammaModule D L R (freeMod R W).X) m n) = + gammaPairEven L R (freeMod R V) (freeMod R W) + (tmulOO _ _ m n) ≫ + (freeModTensorIso R V W).hom.hom := rfl + erw [h, gammaPairEven_tmulOO, gpairLin_apply] + exact Eq.trans (Category.assoc _ _ _) + (whisker_eq _ (freeModTensorIso_gpair R V W m n)) + +/-- The monoidal comparison on even-odd generators. -/ +@[simp] theorem fibreMu_oddMap_tmulEO + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (V : D) (W : D) + (m : 𝟙_ D ⟶ R ⊗ V) + (n : L.obj ⟶ R ⊗ W) : + (fibreMu L R V W).oddMap + (tmulEO (gammaModule D L R (freeMod R V).X) + (gammaModule D L R (freeMod R W).X) m n) = + (λ_ L.obj).inv ≫ (m ⊗ₘ n) ≫ freeModShuffle R V W := by + have h : (fibreMu L R V W).oddMap + (tmulEO (gammaModule D L R (freeMod R V).X) + (gammaModule D L R (freeMod R W).X) m n) = + gammaPairOdd L R (freeMod R V) (freeMod R W) + (tmulEO _ _ m n) ≫ + (freeModTensorIso R V W).hom.hom := rfl + erw [h, gammaPairOdd_tmulEO, gpairLin_apply] + exact Eq.trans (Category.assoc _ _ _) + (whisker_eq _ (freeModTensorIso_gpair R V W m n)) + +/-- The monoidal comparison on odd-even generators. -/ +@[simp] theorem fibreMu_oddMap_tmulOE + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (V : D) (W : D) + (m : L.obj ⟶ R ⊗ V) + (n : 𝟙_ D ⟶ R ⊗ W) : + (fibreMu L R V W).oddMap + (tmulOE (gammaModule D L R (freeMod R V).X) + (gammaModule D L R (freeMod R W).X) m n) = + (ρ_ L.obj).inv ≫ (m ⊗ₘ n) ≫ freeModShuffle R V W := by + have h : (fibreMu L R V W).oddMap + (tmulOE (gammaModule D L R (freeMod R V).X) + (gammaModule D L R (freeMod R W).X) m n) = + gammaPairOdd L R (freeMod R V) (freeMod R W) + (tmulOE _ _ m n) ≫ + (freeModTensorIso R V W).hom.hom := rfl + erw [h, gammaPairOdd_tmulOE, gpairLin_apply] + exact Eq.trans (Category.assoc _ _ _) + (whisker_eq _ (freeModTensorIso_gpair R V W m n)) + +/-- **The monoidal comparison is invertible as soon as the +comparison map of (2.11.1) is.** -/ +theorem isIso_fibreMu + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (V : D) (W : D) + (h : IsIso (gammaPairComparison L R (freeMod R V) + (freeMod R W))) : IsIso (fibreMu L R V W) := by + have := h + have : IsIso (gammaFunMap L R (freeModTensorIso R V W).hom) := + ((gammaModuleFunctor L R).mapIso + (freeModTensorIso R V W)).isIso_hom + exact IsIso.comp_isIso + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMuNat.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMuNat.lean new file mode 100644 index 0000000000..4f1241f079 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMuNat.lean @@ -0,0 +1,131 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMu + +/-! +# Naturality of the monoidal comparison of the fibre functor + +The free-module shuffle is natural in its two variables, and the +monoidal comparison of the fibre functor inherits that naturality +directly on the generators of the tensor product of super modules. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +section Shuffle + +variable {D : Type u} + +/-- **The free-module shuffle is natural.** -/ +theorem freeModShuffle_naturality + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] + {V V' W W' : D} (f : V ⟶ V') + (g : W ⟶ W') : + ((R ◁ f) ⊗ₘ (R ◁ g)) ≫ freeModShuffle R V' W' = + freeModShuffle R V W ≫ (R ◁ (f ⊗ₘ g)) := by + have h := tensorμ_natural (C := D) (𝟙 R) f (𝟙 R) g + simp only [id_tensorHom, MonoidalCategory.whiskerLeft_id] at h + change ((R ◁ f) ⊗ₘ (R ◁ g)) ≫ + tensorμ R V' R W' ≫ μ[R] ▷ (V' ⊗ W') = + (tensorμ R V R W ≫ μ[R] ▷ (V ⊗ W)) ≫ (R ◁ (f ⊗ₘ g)) + rw [← Category.assoc, h, Category.assoc, Category.assoc] + exact whisker_eq _ (whisker_exchange μ[R] (f ⊗ₘ g)) + +end Shuffle + +section Fibre + +variable {D : Type u} + +open SuperCommAlgebra.Mod + +/-- **The monoidal comparison of the fibre functor is natural.** -/ +theorem fibreMu_naturality + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + {V V' W W' : D} (f : V ⟶ V') + (g : W ⟶ W') : + SuperCommAlgebra.Mod.tensorHom + (gammaFunMap L R (freeModMap R f)) + (gammaFunMap L R (freeModMap R g)) ≫ + fibreMu L R V' W' = + fibreMu L R V W ≫ + gammaFunMap L R (freeModMap R (f ⊗ₘ g)) := by + have hint : ∀ {X Y : D} (m : X ⟶ R ⊗ V) (n : Y ⟶ R ⊗ W), + ((m ≫ R ◁ f) ⊗ₘ (n ≫ R ◁ g)) ≫ freeModShuffle R V' W' = + ((m ⊗ₘ n) ≫ freeModShuffle R V W) ≫ + R ◁ (f ⊗ₘ g) := by + intro X Y m n + rw [Category.assoc, ← freeModShuffle_naturality R f g, + ← Category.assoc, tensorHom_comp_tensorHom] + refine hom_ext (fun m n => ?_) (fun m n => ?_) (fun m n => ?_) + (fun m n => ?_) + · have hl : (SuperCommAlgebra.Mod.tensorHom + (gammaFunMap L R (freeModMap R f)) + (gammaFunMap L R (freeModMap R g)) ≫ + fibreMu L R V' W').evenMap (tmulEE _ _ m n) = + (fibreMu L R V' W').evenMap + (tmulEE _ _ (m ≫ R ◁ f) (n ≫ R ◁ g)) := by + rw [comp_evenMap_apply, tensorHom_evenMap_tmulEE] + rfl + erw [hl, fibreMu_evenMap_tmulEE, comp_evenMap_apply, + fibreMu_evenMap_tmulEE] + exact Eq.trans (whisker_eq _ (hint m n)) + (Category.assoc _ _ _).symm + · have hl : (SuperCommAlgebra.Mod.tensorHom + (gammaFunMap L R (freeModMap R f)) + (gammaFunMap L R (freeModMap R g)) ≫ + fibreMu L R V' W').evenMap (tmulOO _ _ m n) = + (fibreMu L R V' W').evenMap + (tmulOO _ _ (m ≫ R ◁ f) (n ≫ R ◁ g)) := by + rw [comp_evenMap_apply, tensorHom_evenMap_tmulOO] + rfl + erw [hl, fibreMu_evenMap_tmulOO, comp_evenMap_apply, + fibreMu_evenMap_tmulOO] + exact Eq.trans (whisker_eq _ (hint m n)) + (Category.assoc _ _ _).symm + · have hl : (SuperCommAlgebra.Mod.tensorHom + (gammaFunMap L R (freeModMap R f)) + (gammaFunMap L R (freeModMap R g)) ≫ + fibreMu L R V' W').oddMap (tmulEO _ _ m n) = + (fibreMu L R V' W').oddMap + (tmulEO _ _ (m ≫ R ◁ f) (n ≫ R ◁ g)) := by + rw [comp_oddMap_apply, tensorHom_oddMap_tmulEO] + rfl + erw [hl, fibreMu_oddMap_tmulEO, comp_oddMap_apply, + fibreMu_oddMap_tmulEO] + exact Eq.trans (whisker_eq _ (hint m n)) + (Category.assoc _ _ _).symm + · have hl : (SuperCommAlgebra.Mod.tensorHom + (gammaFunMap L R (freeModMap R f)) + (gammaFunMap L R (freeModMap R g)) ≫ + fibreMu L R V' W').oddMap (tmulOE _ _ m n) = + (fibreMu L R V' W').oddMap + (tmulOE _ _ (m ≫ R ◁ f) (n ≫ R ◁ g)) := by + rw [comp_oddMap_apply, tensorHom_oddMap_tmulOE] + rfl + erw [hl, fibreMu_oddMap_tmulOE, comp_oddMap_apply, + fibreMu_oddMap_tmulOE] + exact Eq.trans (whisker_eq _ (hint m n)) + (Category.assoc _ _ _).symm + +end Fibre + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverComplex.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverComplex.lean new file mode 100644 index 0000000000..6fc1dcfdec --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverComplex.lean @@ -0,0 +1,342 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescentClose +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMix +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfLinear +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointBaseChange +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitInd + +/-! +# From a countable family to a complex point of the splitting algebra + +The descent of the argument of Deligne §2.11 to the complex numbers +is a chain of five steps, and this file runs it end to end for a countable +family of objects and of morphisms of the small category. + +This is a route to the complex numbers, not the route +`RS.deligne_theorem` takes: that one splits a single object and +passes to a simple quotient +(`RS/Classical/Deligne/SplitEverything.lean`), which reaches ℂ +without a countability restriction on the family. What the +assembly consumes from this module is `RS.fibreFreeIso`, the fibre +of a mixed object as a free super module. + +1. *The splitting algebra.* The tensor-product device of Deligne 2.11 + produces, out of local mixedness for each object of the family and a + splitting for each morphism, one nonzero commutative algebra of the + ind-completion realising all of them at once. +2. *Countable presentation.* The witnessing algebras of the input are + arbitrary; `RS.locallyMixed_countablyPresented` and + `RS.section_countablyPresented` replace each of them by a countably + presented one. The compactness they ask for is available because + the family is indexed by objects of the *small* category + (`RS.indCompactObj_indOf`). +3. *The dimension count.* Over countable index families the algebra + assembled from countably presented constituents has even component + of at most countable dimension: + `RS.exists_universal_algebra_rank_le_aleph0`. This is the same + assembly as step 1, carrying the count, so the two steps are run + together rather than one after the other; the ℂ-linearity of the + embedding that the count consumes is discharged for the structures + installed from a scalar unit by `RS.indOfLinear_of_scalarUnit`. +4. *The point.* The countable Nullstellensatz turns that count into a + ℂ-point of the Γ-algebra: `RS.nonempty_superPoint_gammaAlgebra`. +5. *The fibre.* At such a point the fibre of an object of the family + is a finite-dimensional super vector space, of dimension exactly the + pair `(p | q)` of the mixed sum it becomes over the algebra; this is + `RS.Classical.Deligne.PointBaseChange` applied through + `RS.fibreMixIso`. + +## Contents + +* `RS.exists_superPoint_of_countable_family` — the chain, steps 1 to 4: + the splitting algebra together with a complex point of its + Γ-algebra. +* `RS.fibreFreeIso` — the fibre of a mixed object, as a free super + module. +* `RS.finrank_fibre_tensor_point_even` and + `RS.finrank_fibre_tensor_point_odd` — the two dimensions of the fibre + at a point, with their finite-dimensionality. +* `RS.exists_superVect_fibre` — the fibre, packaged as an + `RS.SuperVect` of dimension `(p | q)`. +* `RS.exists_superPoint_fibre_of_countable_family` — the whole chain, + steps 1 to 5. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open SuperCommAlgebra (pointMod) +open scoped MonObj + +universe v + +variable {C : Type v} + +/-! ## The chain to a complex point -/ + +/-- **From a countable family of objects to split to a complex point.** +Given a countable family of objects of the small category, each locally +mixed after the embedding, and a countable family of morphisms of +embedded objects, each split after base change to some nonzero +commutative algebra, there is a single nonzero commutative algebra of +the ind-completion over which every object of the family becomes a +mixed sum and every morphism of the family acquires a section, and +whose Γ-algebra has a ℂ-point. + +The finite-length hypothesis is what makes the constituents of the +assembled algebra countably presented; the countability of the two +index families is what keeps the assembled algebra of countable +dimension; and the linear structures are the ones installed from the +scalar unit `ψ`, for which the ℂ-linearity of the embedding is +automatic. -/ +theorem exists_superPoint_of_countable_family + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + (ψ : ℂ ≃+* End (𝟙_ C)) + (L : OddLine (Ind C)) {J K : Type v} [Countable J] [Countable K] + (Xf : J → C) (V W : K → C) + (g : ∀ k, (indOf : C ⥤ Ind C).obj (V k) ⟶ + (indOf : C ⥤ Ind C).obj (W k)) + (hlen : ∀ Z : C, ∃ N : ℕ, LengthLE Z N) + (hmix : ∀ j, L.LocallyMixed ((indOf : C ⥤ Ind C).obj (Xf j))) + (hsplit : ∀ k, ∃ (A : Ind C) (_ : MonObj A) (_ : IsCommMonObj A), + η[A] ≠ 0 ∧ + ∃ s : freeMod A ((indOf : C ⥤ Ind C).obj (W k)) ⟶ + freeMod A ((indOf : C ⥤ Ind C).obj (V k)), + s ≫ freeModMap A (g k) = + 𝟙 (freeMod A ((indOf : C ⥤ Ind C).obj (W k)))) : + letI := linearOfScalarUnit ψ + letI := monoidalLinearOfScalarUnitBraided ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + letI := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + ∃ (𝔸 : Ind C) (_ : MonObj 𝔸) (_ : IsCommMonObj 𝔸), + η[𝔸] ≠ 0 ∧ + (∀ j, ∃ p q : ℕ, + Nonempty (freeMod 𝔸 ((indOf : C ⥤ Ind C).obj (Xf j)) ≅ + freeMod 𝔸 (L.mix p q))) ∧ + (∀ k, ∃ s : freeMod 𝔸 ((indOf : C ⥤ Ind C).obj (W k)) ⟶ + freeMod 𝔸 ((indOf : C ⥤ Ind C).obj (V k)), + s ≫ freeModMap 𝔸 (g k) = + 𝟙 (freeMod 𝔸 ((indOf : C ⥤ Ind C).obj (W k)))) ∧ + Nonempty (SuperPoint (gammaAlgebra (Ind C) L 𝔸)) := by + let := linearOfScalarUnit ψ + let := monoidalLinearOfScalarUnitBraided ψ + let := linearOfScalarUnit (indScalarUnit ψ) + let := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + have hu : HasScalarUnit C := hasScalarUnit_of_scalarUnit ψ + obtain ⟨𝔸, hmon, hcomm, hne, hmixed, hsec, hrk⟩ := + exists_universal_algebra_rank_le_aleph0 (C := C) hu + (indOfLinear_of_scalarUnit ψ) hlen L + (fun j => (indOf : C ⥤ Ind C).obj (Xf j)) + (fun k => (indOf : C ⥤ Ind C).obj (V k)) + (fun k => (indOf : C ⥤ Ind C).obj (W k)) g + (fun j => locallyMixed_countablyPresented L _ + (indCompactObj_indOf (Xf j)) hlen (hmix j)) + (fun k => section_countablyPresented (g k) + (indCompactObj_indOf (V k)) (indCompactObj_indOf (W k)) hlen + (hsplit k)) + let := hmon + let := hcomm + exact ⟨𝔸, hmon, hcomm, hne, hmixed, hsec, + nonempty_superPoint_gammaAlgebra L 𝔸 hne hrk⟩ + +/-! ## The fibre at a complex point -/ + +section Fibre + +/-- **The fibre of a mixed object is a free super module.** An object +that becomes the mixed sum `L.mix p q` after base change to the algebra +has for its fibre the free super module of rank `(p | q)`: apply the +realization functor to the isomorphism of free modules, then +`RS.fibreMixIso`. -/ +noncomputable def fibreFreeIso + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [MonoidalPreadditive C] [CategoryTheory.Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] + [IsCommMonObj 𝔸] + {X : Ind C} {p q : ℕ} + (e : freeMod 𝔸 X ≅ freeMod 𝔸 (L.mix p q)) : + (fibreFun L 𝔸).obj X ≅ + ⨁ fun i : Fin p ⊕ Fin q => + Sum.elim (fun _ => (gammaAlgebra (Ind C) L 𝔸).unitMod) + (fun _ => SuperCommAlgebra.Mod.shift + (gammaAlgebra (Ind C) L 𝔸).unitMod) i := + (gammaModuleFunctor L 𝔸).mapIso e ≪≫ fibreMixIso L 𝔸 p q + +/-- **The even part of the fibre at a point is finite +dimensional.** -/ +theorem finiteDimensional_fibre_tensor_point_even + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [MonoidalPreadditive C] [CategoryTheory.Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] + [IsCommMonObj 𝔸] + (P : SuperPoint (gammaAlgebra (Ind C) L 𝔸)) {X : Ind C} + {p q : ℕ} (e : freeMod 𝔸 X ≅ freeMod 𝔸 (L.mix p q)) : + FiniteDimensional ℂ + (((fibreFun L 𝔸).obj X).tensor (pointMod P)).even := + finiteDimensional_even_of_free P p q _ (fibreFreeIso L 𝔸 e) + +/-- **The odd part of the fibre at a point is finite +dimensional.** -/ +theorem finiteDimensional_fibre_tensor_point_odd + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [MonoidalPreadditive C] [CategoryTheory.Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] + [IsCommMonObj 𝔸] + (P : SuperPoint (gammaAlgebra (Ind C) L 𝔸)) {X : Ind C} + {p q : ℕ} (e : freeMod 𝔸 X ≅ freeMod 𝔸 (L.mix p q)) : + FiniteDimensional ℂ + (((fibreFun L 𝔸).obj X).tensor (pointMod P)).odd := + finiteDimensional_odd_of_free P p q _ (fibreFreeIso L 𝔸 e) + +/-- **The even dimension of the fibre at a point is `p`.** -/ +theorem finrank_fibre_tensor_point_even + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [MonoidalPreadditive C] [CategoryTheory.Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] + [IsCommMonObj 𝔸] + (P : SuperPoint (gammaAlgebra (Ind C) L 𝔸)) {X : Ind C} + {p q : ℕ} (e : freeMod 𝔸 X ≅ freeMod 𝔸 (L.mix p q)) : + Module.finrank ℂ + (((fibreFun L 𝔸).obj X).tensor (pointMod P)).even = p := + finrank_even_of_free P p q _ (fibreFreeIso L 𝔸 e) + +/-- **The odd dimension of the fibre at a point is `q`.** -/ +theorem finrank_fibre_tensor_point_odd + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [MonoidalPreadditive C] [CategoryTheory.Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] + [IsCommMonObj 𝔸] + (P : SuperPoint (gammaAlgebra (Ind C) L 𝔸)) {X : Ind C} + {p q : ℕ} (e : freeMod 𝔸 X ≅ freeMod 𝔸 (L.mix p q)) : + Module.finrank ℂ + (((fibreFun L 𝔸).obj X).tensor (pointMod P)).odd = q := + finrank_odd_of_free P p q _ (fibreFreeIso L 𝔸 e) + +/-- **The fibre at a point, as a super vector space of dimension +`(p | q)`.** The packaging is `RS.toSuperVect`, whose components are +coordinate spaces of the two dimensions just computed. -/ +theorem exists_superVect_fibre + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [MonoidalPreadditive C] [CategoryTheory.Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] + [IsCommMonObj 𝔸] + (P : SuperPoint (gammaAlgebra (Ind C) L 𝔸)) {X : Ind C} + {p q : ℕ} (e : freeMod 𝔸 X ≅ freeMod 𝔸 (L.mix p q)) : + ∃ E : SuperVect, Module.finrank ℂ E.even = p ∧ + Module.finrank ℂ E.odd = q := by + have := finiteDimensional_fibre_tensor_point_even L 𝔸 P e + have := finiteDimensional_fibre_tensor_point_odd L 𝔸 P e + refine ⟨toSuperVect P ((fibreFun L 𝔸).obj X), ?_, ?_⟩ + · exact finrank_toSuperVect_even_of_free P p q _ (fibreFreeIso L 𝔸 e) + · exact finrank_toSuperVect_odd_of_free P p q _ (fibreFreeIso L 𝔸 e) + +end Fibre + +/-! ## The whole chain -/ + +/-- **From a countable family of objects to split to a fibre functor +valued in finite-dimensional super vector spaces.** The algebra and +the point of `RS.exists_superPoint_of_countable_family`, with the fibre +of each object of the family recorded as a super vector space of the +dimension pair its mixed sum prescribes. -/ +theorem exists_superPoint_fibre_of_countable_family + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + (ψ : ℂ ≃+* End (𝟙_ C)) (L : OddLine (Ind C)) {J K : Type v} + [Countable J] [Countable K] (Xf : J → C) (V W : K → C) + (g : ∀ k, (indOf : C ⥤ Ind C).obj (V k) ⟶ + (indOf : C ⥤ Ind C).obj (W k)) + (hlen : ∀ Z : C, ∃ N : ℕ, LengthLE Z N) + (hmix : ∀ j, L.LocallyMixed ((indOf : C ⥤ Ind C).obj (Xf j))) + (hsplit : ∀ k, ∃ (A : Ind C) (_ : MonObj A) (_ : IsCommMonObj A), + η[A] ≠ 0 ∧ + ∃ s : freeMod A ((indOf : C ⥤ Ind C).obj (W k)) ⟶ + freeMod A ((indOf : C ⥤ Ind C).obj (V k)), + s ≫ freeModMap A (g k) = + 𝟙 (freeMod A ((indOf : C ⥤ Ind C).obj (W k)))) : + letI := linearOfScalarUnit ψ + letI := monoidalLinearOfScalarUnitBraided ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + letI := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + ∃ (𝔸 : Ind C) (_ : MonObj 𝔸) (_ : IsCommMonObj 𝔸), + η[𝔸] ≠ 0 ∧ + (∀ k, ∃ s : freeMod 𝔸 ((indOf : C ⥤ Ind C).obj (W k)) ⟶ + freeMod 𝔸 ((indOf : C ⥤ Ind C).obj (V k)), + s ≫ freeModMap 𝔸 (g k) = + 𝟙 (freeMod 𝔸 ((indOf : C ⥤ Ind C).obj (W k)))) ∧ + ∃ P : SuperPoint (gammaAlgebra (Ind C) L 𝔸), + ∀ j, ∃ p q : ℕ, + Nonempty (freeMod 𝔸 ((indOf : C ⥤ Ind C).obj (Xf j)) ≅ + freeMod 𝔸 (L.mix p q)) ∧ + Module.finrank ℂ + (((fibreFun L 𝔸).obj ((indOf : C ⥤ Ind C).obj (Xf j))).tensor + (pointMod P)).even = p ∧ + Module.finrank ℂ + (((fibreFun L 𝔸).obj ((indOf : C ⥤ Ind C).obj (Xf j))).tensor + (pointMod P)).odd = q ∧ + ∃ E : SuperVect, Module.finrank ℂ E.even = p ∧ + Module.finrank ℂ E.odd = q := by + let := linearOfScalarUnit ψ + let := monoidalLinearOfScalarUnitBraided ψ + let := linearOfScalarUnit (indScalarUnit ψ) + let := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + obtain ⟨𝔸, hmon, hcomm, hne, hmixed, hsec, ⟨P⟩⟩ := + exists_superPoint_of_countable_family ψ L Xf V W g hlen hmix hsplit + let := hmon + let := hcomm + refine ⟨𝔸, hmon, hcomm, hne, hsec, P, fun j => ?_⟩ + obtain ⟨p, q, ⟨e⟩⟩ := hmixed j + exact ⟨p, q, ⟨e⟩, finrank_fibre_tensor_point_even L 𝔸 P e, + finrank_fibre_tensor_point_odd L 𝔸 P e, + exists_superVect_fibre L 𝔸 P e⟩ + +/-! ## Acceptance + +The intended instantiation takes for `J` the pairs of natural numbers, +indexing the mixed powers of a ⊗-generator. The index families are +asked to live in the same universe as the objects of the small +category, so the concrete family is `ULift.{v} (ℕ × ℕ)`, which is +countable; there are no morphisms to split. -/ + +section Acceptance + +example + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + (ψ : ℂ ≃+* End (𝟙_ C)) (L : OddLine (Ind C)) + (Xf : ULift.{v} (ℕ × ℕ) → C) + (hlen : ∀ Z : C, ∃ N : ℕ, LengthLE Z N) + (hmix : ∀ j, L.LocallyMixed ((indOf : C ⥤ Ind C).obj (Xf j))) : + letI := linearOfScalarUnit ψ + letI := monoidalLinearOfScalarUnitBraided ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + letI := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + ∃ (𝔸 : Ind C) (_ : MonObj 𝔸) (_ : IsCommMonObj 𝔸), + η[𝔸] ≠ 0 ∧ + (∀ j, ∃ p q : ℕ, + Nonempty (freeMod 𝔸 ((indOf : C ⥤ Ind C).obj (Xf j)) ≅ + freeMod 𝔸 (L.mix p q))) ∧ + Nonempty (SuperPoint (gammaAlgebra (Ind C) L 𝔸)) := by + let := linearOfScalarUnit ψ + let := monoidalLinearOfScalarUnitBraided ψ + let := linearOfScalarUnit (indScalarUnit ψ) + let := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + obtain ⟨𝔸, hmon, hcomm, hne, hmixed, _, hP⟩ := + exists_superPoint_of_countable_family ψ L Xf + (K := PEmpty.{v + 1}) PEmpty.elim PEmpty.elim + (fun k => PEmpty.elim k) hlen hmix (fun k => PEmpty.elim k) + exact ⟨𝔸, hmon, hcomm, hne, hmixed, hP⟩ + +end Acceptance + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverSplitting.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverSplitting.lean new file mode 100644 index 0000000000..5dd5e1b432 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverSplitting.lean @@ -0,0 +1,165 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplittingAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreExact +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreFaithful +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreBridge +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfMonoidal + +/-! +# The fibre functor over the splitting algebra + +Assembling the three properties over the algebra of +`RS.exists_splitting_algebra`: the restriction of the fibre functor +along the Ind-embedding is strong monoidal, it is exact, and it is +faithful once the unit of the algebra is a monomorphism. + +The braiding of `Ind C` is hypothesised here, through +`SymmetricCategory (Ind C)`, and is deliberately *not* also +available by transport from a braiding of `C`. Assuming +`BraidedCategory C` as well would put two unrelated +`BraidedCategory (Ind C)` instances in scope — the transported one +of `RS.Classical.Deligne.IndMonoidal` and the one underlying the +hypothesised symmetry — and `IsCommMonObj 𝔸`, whose commutativity +law is stated against a braiding, would then be a different class +in the variable block from the one the fibre-functor lemmas below +consume. The variable block therefore names the symmetry of +`Ind C` only, matching `RS.Classical.Deligne.UniversalAlgebra`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v + +variable {C : Type v} + +/-- **The restricted fibre functor is strong monoidal** over an +algebra that splits the embedded objects. -/ +@[implicit_reducible] +noncomputable def indFibreMonoidal + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ (Ind C)] [MonoidalPreadditive (Ind C)] + [MonoidalLinear ℂ (Ind C)] [SymmetricCategory (Ind C)] + [HasCoequalizers (Ind C)] + [∀ Z : Ind C, PreservesColimitsOfShape WalkingParallelPair (tensorLeft + Z)] [HasFiniteBiproducts (Ind C)] (L : OddLine (Ind C)) (𝔸 : Ind C) + [MonObj 𝔸] [IsCommMonObj 𝔸] + (hsp : SplitsOn L 𝔸 (indOf : C ⥤ Ind C)) : + ((indOf : C ⥤ Ind C) ⋙ fibreOver L 𝔸).Monoidal := + fibreRestrictMonoidal L 𝔸 _ hsp + +/-- **The restricted fibre functor is faithful** over an algebra +that splits the embedded objects, provided its unit is a +monomorphism. -/ +theorem indFibre_faithful [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ (Ind C)] [MonoidalPreadditive (Ind C)] + [MonoidalLinear ℂ (Ind C)] [SymmetricCategory (Ind C)] + [HasFiniteBiproducts (Ind C)] (L : OddLine (Ind C)) (𝔸 : Ind C) + [MonObj 𝔸] [IsCommMonObj 𝔸] + (hmono : Mono η[𝔸]) + (hsp : SplitsOn L 𝔸 (indOf : C ⥤ Ind C)) + [∀ Z : Ind C, (tensorRight Z).PreservesMonomorphisms] : + ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸).Faithful := by + have : (indOf (C := C)).Additive := indOf_additive + have : ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸).Additive := + inferInstance + refine ⟨fun {X Y} f g hfg => ?_⟩ + obtain ⟨p, q, ⟨e⟩⟩ := hsp X + have h0 : ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸).map (f - g) = 0 := by + rw [Functor.map_sub, hfg, sub_self] + have h1 : (indOf : C ⥤ Ind C).map (f - g) = 0 := + fibreFun_map_eq_zero L 𝔸 hmono _ e h0 + have h2 : (indOf : C ⥤ Ind C).map f = (indOf : C ⥤ Ind C).map g := by + rw [Functor.map_sub] at h1 + exact sub_eq_zero.mp h1 + exact (indOf (C := C)).map_injective h2 + +/-! ## Exactness of the restricted fibre functor -/ + +section Exact + +/-- The embedding carries a short exact sequence of `C` to a short +exact sequence of `Ind C`: it is additive, it preserves limits, and +it preserves finite colimits. -/ +theorem indOf_shortExact [SmallCategory C] [Abelian C] + {S : CategoryTheory.ShortComplex C} + (hS : S.ShortExact) : + (S.map (indOf : C ⥤ Ind C)).ShortExact := by + have : (indOf (C := C)).Additive := indOf_additive + exact hS.map_of_exact (indOf : C ⥤ Ind C) + +/-- The restricted fibre functor carries short exact sequences to +short exact sequences, given a base-change section over `𝔸` for +each embedded sequence. -/ +theorem indFibre_shortExact [SmallCategory C] [MonoidalCategory C] [Abelian C] + [MonoidalPreadditive C] [RigidCategory C] + [CategoryTheory.Linear ℂ (Ind C)] [MonoidalPreadditive (Ind C)] + [MonoidalLinear ℂ (Ind C)] [SymmetricCategory (Ind C)] + (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] [IsCommMonObj 𝔸] + (hsec : ∀ (S : CategoryTheory.ShortComplex C), S.ShortExact → + ∃ s : freeMod 𝔸 ((S.map (indOf : C ⥤ Ind C)).X₃) ⟶ + freeMod 𝔸 ((S.map (indOf : C ⥤ Ind C)).X₂), + s ≫ freeModMap 𝔸 ((S.map (indOf : C ⥤ Ind C)).g) = 𝟙 _) + (S : CategoryTheory.ShortComplex C) (hS : S.ShortExact) : + (S.map ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸)).ShortExact := by + obtain ⟨s, hs⟩ := hsec S hS + have h := fibreFun_shortExact_of_baseChangeSection L 𝔸 + (indOf_shortExact hS) s hs + rw [CategoryTheory.ShortComplex.map_comp] + exact h + +/-- **The restricted fibre functor preserves finite limits** over an +algebra that supplies a base-change section for every embedded short +exact sequence. -/ +theorem indFibre_preservesFiniteLimits + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [MonoidalPreadditive C] [RigidCategory C] + [CategoryTheory.Linear ℂ (Ind C)] [MonoidalPreadditive (Ind C)] + [MonoidalLinear ℂ (Ind C)] [SymmetricCategory (Ind C)] + (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] [IsCommMonObj 𝔸] + (hsec : ∀ (S : CategoryTheory.ShortComplex C), S.ShortExact → + ∃ s : freeMod 𝔸 ((S.map (indOf : C ⥤ Ind C)).X₃) ⟶ + freeMod 𝔸 ((S.map (indOf : C ⥤ Ind C)).X₂), + s ≫ freeModMap 𝔸 ((S.map (indOf : C ⥤ Ind C)).g) = 𝟙 _) : + Limits.PreservesFiniteLimits + ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸) := by + have : (indOf (C := C)).Additive := indOf_additive + have : ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸).Additive := + inferInstance + exact preservesFiniteLimits_of_shortExact _ + (indFibre_shortExact L 𝔸 hsec) + +/-- **The restricted fibre functor preserves finite colimits** under +the same hypothesis; with the previous statement it is exact. -/ +theorem indFibre_preservesFiniteColimits + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [MonoidalPreadditive C] [RigidCategory C] + [CategoryTheory.Linear ℂ (Ind C)] [MonoidalPreadditive (Ind C)] + [MonoidalLinear ℂ (Ind C)] [SymmetricCategory (Ind C)] + (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] [IsCommMonObj 𝔸] + (hsec : ∀ (S : CategoryTheory.ShortComplex C), S.ShortExact → + ∃ s : freeMod 𝔸 ((S.map (indOf : C ⥤ Ind C)).X₃) ⟶ + freeMod 𝔸 ((S.map (indOf : C ⥤ Ind C)).X₂), + s ≫ freeModMap 𝔸 ((S.map (indOf : C ⥤ Ind C)).g) = 𝟙 _) : + Limits.PreservesFiniteColimits + ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸) := by + have : (indOf (C := C)).Additive := indOf_additive + have : ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸).Additive := + inferInstance + exact preservesFiniteColimits_of_shortExact _ + (indFibre_shortExact L 𝔸 hsec) + +end Exact + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreRestrict.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreRestrict.lean new file mode 100644 index 0000000000..3f6e3ab74c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreRestrict.lean @@ -0,0 +1,91 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreStrong + +/-! +# Restricting the fibre functor along a monoidal functor + +A splitting algebra need not split every object of the ambient +category — after all, the ambient category here is an Ind-completion +and a filtered colimit is not a finite mixed sum. What is needed is +only that it split the objects in the image of a chosen monoidal +functor; the composite of that functor with the fibre functor is +then strong monoidal. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v₂ u₂ v u + +section + +variable {D : Type u} + +/-- **The algebra splits the image of a functor**: every object in +the image becomes a mixed sum of copies of the unit and of the odd +line after base change. -/ +def SplitsOn [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] (L : OddLine D) (R : D) + [MonObj R] {C : Type u₂} [Category.{v₂} C] (F : C ⥤ D) : Prop := + ∀ X : C, ∃ p q : ℕ, + Nonempty (freeMod R (F.obj X) ≅ freeMod R (L.mix p q)) + +/-- **The restricted fibre functor is strong monoidal.** -/ +@[implicit_reducible] +noncomputable def fibreRestrictMonoidal + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] [HasFiniteBiproducts D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] {C : Type u₂} + [Category.{v₂} C] [MonoidalCategory C] (F : C ⥤ D) [F.Monoidal] + (hsp : SplitsOn L R F) : + (F ⋙ fibreOver L R).Monoidal := by + have hεF : IsIso (CategoryTheory.Functor.LaxMonoidal.ε F) := + ⟨CategoryTheory.Functor.OplaxMonoidal.η F, + CategoryTheory.Functor.Monoidal.ε_η F, + CategoryTheory.Functor.Monoidal.η_ε F⟩ + haveI : IsIso (CategoryTheory.Functor.LaxMonoidal.ε + (F ⋙ fibreOver L R)) := by + rw [CategoryTheory.Functor.LaxMonoidal.comp_ε] + have h1 : IsIso (CategoryTheory.Functor.LaxMonoidal.ε + (fibreOver L R)) := by + rw [fibreOver_ε] + exact (fibreEpsIso L R).isIso_hom + exact IsIso.comp_isIso' h1 + (@CategoryTheory.Functor.map_isIso _ _ _ _ _ _ + (fibreOver L R) (CategoryTheory.Functor.LaxMonoidal.ε F) + hεF) + haveI : ∀ X Y : C, IsIso (CategoryTheory.Functor.LaxMonoidal.μ + (F ⋙ fibreOver L R) X Y) := by + intro X Y + have hμF : IsIso (CategoryTheory.Functor.LaxMonoidal.μ F X Y) := + ⟨CategoryTheory.Functor.OplaxMonoidal.δ F X Y, + CategoryTheory.Functor.Monoidal.μ_δ F X Y, + CategoryTheory.Functor.Monoidal.δ_μ F X Y⟩ + rw [CategoryTheory.Functor.LaxMonoidal.comp_μ] + obtain ⟨p, q, ⟨eX⟩⟩ := hsp X + obtain ⟨p', q', ⟨eY⟩⟩ := hsp Y + have h1 : IsIso (CategoryTheory.Functor.LaxMonoidal.μ + (fibreOver L R) (F.obj X) (F.obj Y)) := by + rw [fibreOver_μ] + exact isIso_fibreMu_of_mix L R eX eY + exact IsIso.comp_isIso' h1 + (@CategoryTheory.Functor.map_isIso _ _ _ _ _ _ + (fibreOver L R) + (CategoryTheory.Functor.LaxMonoidal.μ F X Y) hμF) + exact CategoryTheory.Functor.Monoidal.ofLaxMonoidal _ + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreStrong.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreStrong.lean new file mode 100644 index 0000000000..a38dfe6f5f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreStrong.lean @@ -0,0 +1,79 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairFreeFree + +/-! +# The fibre functor is strong monoidal over a splitting algebra + +Over an algebra for which every object becomes a mixed sum of +copies of the unit and of the odd line, the monoidal comparison of +Deligne's (2.11.1) is invertible at every pair of objects, and the +unit comparison is invertible outright. The lax symmetric monoidal +structure of the fibre functor is therefore strong. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +section + +variable {D : Type u} + +/-- **A splitting algebra**: every object becomes a mixed sum of +copies of the unit and of the odd line after base change. -/ +def Splits [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] (L : OddLine D) (R : D) + [MonObj R] : Prop := + ∀ X : D, ∃ p q : ℕ, + Nonempty (freeMod R X ≅ freeMod R (L.mix p q)) + +/-- Over a splitting algebra the monoidal comparison is invertible +at every pair of objects. -/ +theorem isIso_fibreMu_of_splits + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] [HasFiniteBiproducts D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (hsp : Splits L R) (V W : D) : + IsIso (fibreMu L R V W) := by + obtain ⟨p, q, ⟨eV⟩⟩ := hsp V + obtain ⟨p', q', ⟨eW⟩⟩ := hsp W + exact isIso_fibreMu_of_mix L R eV eW + +/-- **Over a splitting algebra the fibre functor is strong +monoidal.** -/ +@[implicit_reducible] +noncomputable def fibreOverMonoidal + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] [HasFiniteBiproducts D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (hsp : Splits L R) : + (fibreOver L R).Monoidal := by + haveI : IsIso (CategoryTheory.Functor.LaxMonoidal.ε + (fibreOver L R)) := by + rw [fibreOver_ε] + exact (fibreEpsIso L R).isIso_hom + haveI : ∀ V W : D, IsIso (CategoryTheory.Functor.LaxMonoidal.μ + (fibreOver L R) V W) := fun V W => by + rw [fibreOver_μ] + exact isIso_fibreMu_of_splits L R hsp V W + exact CategoryTheory.Functor.Monoidal.ofLaxMonoidal _ + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FiltNil.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FiltNil.lean new file mode 100644 index 0000000000..c795dc2b82 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FiltNil.lean @@ -0,0 +1,193 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Nilpotency from a shifted finite filtration + +The abstract engine of a filtration argument, in a preadditive +category with a zero object. Given a finite chain of subobjects +`F : ℕ → Subobject X` with `F 0 = ⊤` and `F N = ⊥`, an +endomorphism `f` that moves each stage into the next — in the +sense that `(F k).arrow ≫ f` factors through `F (k + 1)` for every +`k < N` — satisfies `f ^ N = 0` (`RS.comp_eq_zero_of_chain`); if +`f` is moreover idempotent it vanishes outright +(`RS.eq_zero_of_idem_of_chain`). Convenience forms taking the +chain as a `Fin (N + 1)`-indexed family are also provided +(`RS.comp_eq_zero_of_finChain`, `RS.eq_zero_of_idem_of_finChain`). + +No monotonicity of the chain is assumed: only the endpoints and +the shift hypothesis enter the argument. + +## Composition-order convention + +Multiplication in `End X` is reversed composition: +`g * h = h ≫ g` (`CategoryTheory.End.mul_def`). Read as a +morphism via `CategoryTheory.End.asHom`, the power `f ^ (n + 1)` +is therefore `End.asHom (f ^ n) ≫ End.asHom f`; the lemma +`RS.pow_end_eq` records exactly this unfolding. (For powers of a +single endomorphism all bracketings agree, but consumers matching +syntactically against `f ^ N` should unfold via `pow_end_eq`.) +The shift hypothesis is phrased with `End.asHom f`, so consumers +supply factorisations of the morphism `(F k).arrow ≫ End.asHom f`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Limits + +universe v u + +variable {C : Type u} + +/-- Powers in `End X` unfold through the reversed multiplication +of `End`: read as a morphism, `f ^ (n + 1)` is `f ^ n ≫ f`. -/ +lemma pow_end_eq [Category.{v} C] + {X : C} (f : End X) (n : ℕ) : + End.asHom (f ^ (n + 1)) = End.asHom (f ^ n) ≫ End.asHom f := by + rw [pow_succ'] + rfl + +section Chain + +/-- An idempotent has all its positive powers equal to itself. -/ +private lemma pow_succ_of_idem [Category.{v} C] {X : C} + {f : End X} (h : f * f = f) : + ∀ n : ℕ, f ^ (n + 1) = f + | 0 => pow_one f + | n + 1 => by rw [pow_succ, pow_succ_of_idem h n, h] + +/-- An idempotent endomorphism with a vanishing power is zero. At +exponent zero the hypothesis reads `1 = 0`, which kills `f` as +well. -/ +private lemma eq_zero_of_idem_of_pow [Category.{v} C] [Preadditive C] {X : C} + {f : End X} {N : ℕ} + (hidem : f * f = f) (hpow : f ^ N = 0) : f = 0 := by + rcases N with _ | M + · rw [pow_zero] at hpow + calc f = f * 1 := (mul_one f).symm + _ = f * 0 := by rw [hpow] + _ = 0 := mul_zero f + · rw [pow_succ_of_idem hidem M] at hpow + exact hpow + +/-- **Shifting a finite chain forces nilpotency.** If the chain +`F` runs from `F 0 = ⊤` to `F N = ⊥` and the endomorphism `f` +moves each stage into the next — `(F k).arrow ≫ f` factors +through `F (k + 1)` for every `k < N` — then `f ^ N = 0`. + +The proof shows by induction that `(⊤ : Subobject X).arrow` +composed with `f ^ k` factors through `F k`; at `k = N` the +factorisation runs through `⊥`, whose arrow is zero, and the top +arrow is an isomorphism, hence an epimorphism. -/ +theorem comp_eq_zero_of_chain + [Category.{v} C] [Preadditive C] [HasZeroObject C] {X : C} + {N : ℕ} (F : ℕ → Subobject X) + (htop : F 0 = ⊤) (hbot : F N = ⊥) (f : End X) + (hshift : ∀ k, k < N → + (F (k + 1)).Factors ((F k).arrow ≫ End.asHom f)) : + f ^ N = 0 := by + have key : ∀ k, k ≤ N → + (F k).Factors + ((⊤ : Subobject X).arrow ≫ End.asHom (f ^ k)) := by + intro k + induction k with + | zero => + intro _ + rw [htop] + exact Subobject.top_factors _ + | succ k ih => + intro hk + have h := ih (Nat.le_of_succ_le hk) + have h' := hshift k hk + have heq : (⊤ : Subobject X).arrow ≫ End.asHom (f ^ (k + 1)) + = ((F k).factorThru _ h ≫ (F (k + 1)).factorThru _ h') ≫ + (F (k + 1)).arrow := by + rw [pow_end_eq] + calc (⊤ : Subobject X).arrow ≫ + End.asHom (f ^ k) ≫ End.asHom f + = ((⊤ : Subobject X).arrow ≫ End.asHom (f ^ k)) ≫ + End.asHom f := (Category.assoc _ _ _).symm + _ = ((F k).factorThru _ h ≫ (F k).arrow) ≫ + End.asHom f := by rw [Subobject.factorThru_arrow] + _ = (F k).factorThru _ h ≫ (F k).arrow ≫ End.asHom f := + Category.assoc _ _ _ + _ = (F k).factorThru _ h ≫ (F (k + 1)).factorThru _ h' ≫ + (F (k + 1)).arrow := by + rw [Subobject.factorThru_arrow] + _ = ((F k).factorThru _ h ≫ + (F (k + 1)).factorThru _ h') ≫ (F (k + 1)).arrow := + (Category.assoc _ _ _).symm + rw [heq] + exact Subobject.factors_comp_arrow _ + have hN := key N le_rfl + rw [hbot, Subobject.bot_factors_iff_zero] at hN + have hz : End.asHom (f ^ N) = 0 := + (cancel_epi ((⊤ : Subobject X).arrow)).mp + (by rw [hN, comp_zero]) + exact hz + +/-- **A shifted idempotent is zero.** Under the hypotheses of +`comp_eq_zero_of_chain`, an idempotent `f` (with respect to the +`End` multiplication `f * f = f`) vanishes outright: `f ^ N = 0` +and `f = f ^ N` for `N ≥ 1`, while `N = 0` makes `X` a zero +object. -/ +theorem eq_zero_of_idem_of_chain + [Category.{v} C] [Preadditive C] [HasZeroObject C] {X : C} + {N : ℕ} (F : ℕ → Subobject X) + (htop : F 0 = ⊤) (hbot : F N = ⊥) (f : End X) + (hshift : ∀ k, k < N → + (F (k + 1)).Factors ((F k).arrow ≫ End.asHom f)) + (hidem : f * f = f) : f = 0 := + eq_zero_of_idem_of_pow hidem + (comp_eq_zero_of_chain F htop hbot f hshift) + +/-- Convenience form of `comp_eq_zero_of_chain` with the chain +indexed by `Fin (N + 1)`: it runs from `F 0 = ⊤` to +`F (Fin.last N) = ⊥`, and the shift hypothesis is stated over +`k : Fin N` via `Fin.castSucc` and `Fin.succ`. -/ +theorem comp_eq_zero_of_finChain + [Category.{v} C] [Preadditive C] [HasZeroObject C] {X : C} + {N : ℕ} + (F : Fin (N + 1) → Subobject X) (htop : F 0 = ⊤) + (hbot : F (Fin.last N) = ⊥) (f : End X) + (hshift : ∀ k : Fin N, + (F k.succ).Factors ((F k.castSucc).arrow ≫ End.asHom f)) : + f ^ N = 0 := by + refine comp_eq_zero_of_chain + (fun k => if h : k ≤ N then F ⟨k, Nat.lt_succ_of_le h⟩ else ⊥) + ?_ ?_ f ?_ + · rw [dite_eq_left (Nat.zero_le N)] + exact htop + · rw [dite_eq_left (le_refl N)] + exact hbot + · intro k hk + have h1 : k ≤ N := Nat.le_of_lt hk + have h2 : k + 1 ≤ N := hk + rw [dite_eq_left h2, dite_eq_left h1] + exact hshift ⟨k, hk⟩ + +/-- Convenience form of `eq_zero_of_idem_of_chain` with the chain +indexed by `Fin (N + 1)`. -/ +theorem eq_zero_of_idem_of_finChain + [Category.{v} C] [Preadditive C] [HasZeroObject C] {X : C} + {N : ℕ} + (F : Fin (N + 1) → Subobject X) (htop : F 0 = ⊤) + (hbot : F (Fin.last N) = ⊥) (f : End X) + (hshift : ∀ k : Fin N, + (F k.succ).Factors ((F k.castSucc).arrow ≫ End.asHom f)) + (hidem : f * f = f) : f = 0 := + eq_zero_of_idem_of_pow hidem + (comp_eq_zero_of_finChain F htop hbot f hshift) + +end Chain + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FlatLimit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FlatLimit.lean new file mode 100644 index 0000000000..6d51d204d3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FlatLimit.lean @@ -0,0 +1,412 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# The limit theorem for flatness at a finite stage + +The ordinary-ring case of the limit theorem for flatness +(EGA IV, 11.2.6.1): when `R` is a directed colimit of commutative +rings `Rᵢ` and a finitely presented flat `R`-module arises by base +change from a stage `i₀`, the base change to some finite stage +`j ≥ i₀` is already flat. + +We work with the matrix form of Lazard's equational criterion. A +finitely presented module is the cokernel of a presentation matrix +`K : Matrix (Fin n) (Fin m) A`; such a cokernel is projective — +equivalently flat, see the bridge below — precisely when `K` +admits a *certificate*: a matrix `T` with `K * T * K = K` +(`projective_of_matrix_certificate` and +`matrix_certificate_of_projective`). A certificate is a finite +system of ring equations, so it descends along a directed colimit +of rings (`exists_stage_matrix_certificate`); the headline +statement is `exists_stage_projective`. + +The colimit is presented abstractly by +`DirectedColimitPresentation`: a compatible cocone `gᵢ : Rᵢ →+* R` +which is jointly surjective and detects equalities at a finite +stage. `Ring.DirectLimit` provides these data via +`Ring.DirectLimit.exists_of` and `Ring.DirectLimit.of.zero_exact` +(module `Mathlib.Algebra.Colimit.Ring`, outside our import +funnel), so the statements here apply to it directly. + +## The flatness bridge + +`Module.Flat` lives in `Mathlib.RingTheory.Flat.Basic`, which is +not reachable through `RS.Common.MathlibDeps`, so the statements +here are phrased with `Module.Projective`. The translation to +flatness is a pair of Mathlib lemmas for the consumer: + +* `Module.Flat.of_projective` + (`Mathlib.RingTheory.Flat.Basic`): projective modules are flat; +* `Module.Flat.projective_of_finitePresentation` + (`Mathlib.RingTheory.Flat.EquationalCriterion`): a finitely + presented flat module is projective. + +With these, `exists_stage_projective` is the flatness statement: +a finitely presented flat `R`-module presented by the base change +of a stage-`i₀` matrix is projective, its certificate descends to +a stage `j`, and every module presented over `Rⱼ` by the pushed +matrix — in particular the base change `Rⱼ ⊗_{R_{i₀}} M_{i₀}` — +is projective, hence flat. +-/ + +@[expose] public section + +namespace RS +namespace FlatLimit + +/-! ## Lazard certificates + +A module presented by the matrix `K` — the cokernel of +`K.mulVecLin : A^m →ₗ A^n` — is projective exactly when `K` admits +a matrix `T` with `K * T * K = K`. The two directions are +`projective_of_matrix_certificate` and +`matrix_certificate_of_projective`. +-/ + +section Certificate + +variable {A : Type*} + +/-- Matrices inducing the same linear map are equal. -/ +theorem matrix_eq_of_mulVecLin_eq [CommRing A] + {p q : ℕ} + {K L : Matrix (Fin p) (Fin q) A} + (h : K.mulVecLin = L.mulVecLin) : K = L := by + ext a b + have h1 : K.mulVec (Pi.single b 1) = L.mulVec (Pi.single b 1) := by + have h2 := DFunLike.congr_fun h (Pi.single b 1) + simpa [Matrix.mulVecLin_apply] using h2 + rw [Matrix.mulVec_single_one, Matrix.mulVec_single_one] at h1 + simpa [Matrix.col_apply] using congrFun h1 a + +/-- The matrix assembled from the prescribed columns +`t 0, …, t (q-1)` sends the `j`-th basis vector to `t j`. -/ +theorem mulVecLin_ofCols_single [CommRing A] + {p q : ℕ} (t : Fin q → Fin p → A) + (j : Fin q) : + (Matrix.of fun a b => t b a).mulVecLin (Pi.single j (1 : A)) + = t j := by + rw [Matrix.mulVecLin_apply, Matrix.mulVec_single_one] + funext a + simp [Matrix.col_apply] + +/-- One half of the matrix form of Lazard's criterion: a +certificate `K * T * K = K` splits the presentation, so any module +presented by `K` is a direct summand of `A ^ n` and therefore +projective. Combined with `Module.Flat.of_projective` (outside +the funnel) this shows certified modules are flat. -/ +theorem projective_of_matrix_certificate [CommRing A] + {m n : ℕ} + {M : Type*} [AddCommGroup M] [Module A M] + {K : Matrix (Fin n) (Fin m) A} {π : (Fin n → A) →ₗ[A] M} + (hsurj : Function.Surjective π) + (hker : LinearMap.ker π = LinearMap.range K.mulVecLin) + {T : Matrix (Fin m) (Fin n) A} (hT : K * T * K = K) : + Module.Projective A M := by + have hSK : (1 - K * T) * K = 0 := by + rw [Matrix.sub_mul, Matrix.one_mul, hT, sub_self] + have hπK : ∀ y, π (K.mulVec y) = 0 := by + intro y + have hy : K.mulVec y ∈ LinearMap.ker π := by + rw [hker] + exact ⟨y, Matrix.mulVecLin_apply K y⟩ + exact LinearMap.mem_ker.mp hy + have hkerle : + LinearMap.ker π ≤ LinearMap.ker (1 - K * T).mulVecLin := by + rw [hker] + rintro x ⟨y, rfl⟩ + rw [LinearMap.mem_ker, Matrix.mulVecLin_apply, + Matrix.mulVecLin_apply, Matrix.mulVec_mulVec, hSK, + Matrix.zero_mulVec] + refine Module.Projective.of_split + ((LinearMap.ker π).liftQ (1 - K * T).mulVecLin hkerle ∘ₗ + (π.quotKerEquivOfSurjective hsurj).symm.toLinearMap) π ?_ + apply LinearMap.ext + intro x + obtain ⟨v, rfl⟩ := hsurj x + simp only [LinearMap.comp_apply, LinearMap.id_apply, + LinearEquiv.coe_toLinearMap, + LinearMap.quotKerEquivOfSurjective_symm_apply, + Submodule.liftQ_apply] + rw [Matrix.mulVecLin_apply, + Matrix.sub_mulVec, Matrix.one_mulVec, map_sub, + ← Matrix.mulVec_mulVec, hπK, sub_zero] + +/-- The other half of the matrix form of Lazard's criterion: a +projective module presented by `K` yields a certificate +`K * T * K = K`. Via +`Module.Flat.projective_of_finitePresentation` (outside the +funnel) the hypothesis holds for any finitely presented flat +module. -/ +theorem matrix_certificate_of_projective [CommRing A] + {m n : ℕ} + {M : Type*} [AddCommGroup M] [Module A M] + [Module.Projective A M] + {K : Matrix (Fin n) (Fin m) A} {π : (Fin n → A) →ₗ[A] M} + (hsurj : Function.Surjective π) + (hker : LinearMap.ker π = LinearMap.range K.mulVecLin) : + ∃ T : Matrix (Fin m) (Fin n) A, K * T * K = K := by + obtain ⟨s, hs⟩ := + Module.projective_lifting_property π LinearMap.id hsurj + have hsec : ∀ z, π (s z) = z := by + intro z + simpa using DFunLike.congr_fun hs z + have hπK : ∀ y, π (K.mulVecLin y) = 0 := by + intro y + have hy : K.mulVecLin y ∈ LinearMap.ker π := by + rw [hker] + exact ⟨y, rfl⟩ + exact LinearMap.mem_ker.mp hy + -- each basis column of `1 - s ∘ π` is a relation, so it lifts + -- through `K` + have hcol : ∀ j : Fin n, ∃ t : Fin m → A, + K.mulVecLin t = Pi.single j 1 - s (π (Pi.single j 1)) := by + intro j + have hmem : (Pi.single j 1 - s (π (Pi.single j 1)) : Fin n → A) + ∈ LinearMap.ker π := by + rw [LinearMap.mem_ker, map_sub, hsec, sub_self] + rw [hker] at hmem + exact hmem + choose t ht using hcol + refine ⟨Matrix.of fun a b => t b a, ?_⟩ + apply matrix_eq_of_mulVecLin_eq + -- `K * T` induces `1 - s ∘ π`, checked on basis vectors + have hKT : K.mulVecLin ∘ₗ + (Matrix.of fun a b => t b a).mulVecLin + = LinearMap.id - s ∘ₗ π := by + apply LinearMap.pi_ext' + intro j + apply LinearMap.ext + intro a + have hsingle : (Pi.single j a : Fin n → A) + = a • Pi.single j 1 := by + rw [← Pi.single_smul, smul_eq_mul, mul_one] + simp only [LinearMap.comp_apply, LinearMap.coe_single, + LinearMap.sub_apply, LinearMap.id_apply] + rw [hsingle, map_smul, map_smul, mulVecLin_ofCols_single, + ht j, map_smul, map_smul, smul_sub] + rw [Matrix.mulVecLin_mul, Matrix.mulVecLin_mul, hKT] + apply LinearMap.ext + intro y + simp only [LinearMap.comp_apply, LinearMap.sub_apply, + LinearMap.id_apply] + rw [hπK, map_zero, sub_zero] + +end Certificate + +/-! ## Directed colimit presentations of a ring + +The colimit `R = colim Rᵢ` enters only through three properties of +the cocone `gᵢ : Rᵢ →+* R`: compatibility with the transition +maps, joint surjectivity, and detection of equalities at a finite +stage. `Ring.DirectLimit` satisfies all three. +-/ + +section Colimit + +variable {ι : Type*} + +/-- A presentation of the commutative ring `R` as the directed +colimit of the system `F` with transition maps `f`: a compatible +cocone which is jointly surjective and detects equalities at a +finite stage. These are the only properties of a filtered colimit +of rings used by the limit theorem. -/ +structure DirectedColimitPresentation + [Preorder ι] {F : ι → Type*} [∀ i, CommRing (F i)] + (f : ∀ ⦃i j : ι⦄, i ≤ j → F i →+* F j) + (R : Type*) [CommRing R] where + /-- The cocone maps from the stages to the colimit. -/ + toColim : ∀ i, F i →+* R + /-- The cocone commutes with the transition maps. -/ + compat : ∀ ⦃i j : ι⦄ (h : i ≤ j) (x : F i), + toColim j (f h x) = toColim i x + /-- Every element of the colimit comes from some stage. -/ + exhaustive : ∀ x : R, ∃ i, ∃ y : F i, toColim i y = x + /-- An equality in the colimit holds at some later stage. -/ + eventuallyEq : ∀ i (x y : F i), toColim i x = toColim i y → + ∃ j, ∃ h : i ≤ j, f h x = f h y + +/-- Every finite family of elements of the colimit lifts jointly +to a single stage. -/ +theorem DirectedColimitPresentation.exists_stage_family + [Preorder ι] {F : ι → Type*} [∀ i, CommRing (F i)] [Nonempty ι] + [IsDirectedOrder ι] {f : ∀ ⦃i j : ι⦄, i ≤ j → F i →+* F j} {R : Type*} + [CommRing R] + (P : DirectedColimitPresentation f R) + {κ : Type*} [Finite κ] (x : κ → R) : + ∃ i, ∃ y : κ → F i, ∀ k, P.toColim i (y k) = x k := by + classical + let := Fintype.ofFinite κ + choose idx y hy using fun k => P.exhaustive (x k) + obtain ⟨i, hi⟩ := (Finset.univ.image idx).exists_le + refine ⟨i, fun k => f (hi (idx k) + (Finset.mem_image_of_mem idx (Finset.mem_univ k))) (y k), + fun k => ?_⟩ + exact (P.compat _ _).trans (hy k) + +/-- Finitely many equalities holding in the colimit hold +simultaneously at some common later stage. -/ +theorem DirectedColimitPresentation.exists_stage_eq + [Preorder ι] {F : ι → Type*} [∀ i, CommRing (F i)] [Nonempty ι] + [IsDirectedOrder ι] {f : ∀ ⦃i j : ι⦄, i ≤ j → F i →+* F j} {R : Type*} + [CommRing R] + (P : DirectedColimitPresentation f R) + (hDS : DirectedSystem F fun _ _ h => f h) + {κ : Type*} [Finite κ] {i : ι} {a b : κ → F i} + (hab : ∀ k, P.toColim i (a k) = P.toColim i (b k)) : + ∃ j, ∃ h : i ≤ j, ∀ k, f h (a k) = f h (b k) := by + classical + let := Fintype.ofFinite κ + choose jdx hjdx hj using fun k => + P.eventuallyEq i (a k) (b k) (hab k) + obtain ⟨j, hjle⟩ := (insert i (Finset.univ.image jdx)).exists_le + have hij : i ≤ j := hjle i (Finset.mem_insert_self _ _) + refine ⟨j, hij, fun k => ?_⟩ + have hk : jdx k ≤ j := hjle _ (Finset.mem_insert_of_mem + (Finset.mem_image_of_mem jdx (Finset.mem_univ k))) + calc f hij (a k) + = f hk (f (hjdx k) (a k)) := (hDS.map_map _ _ _).symm + _ = f hk (f (hjdx k) (b k)) := by rw [hj k] + _ = f hij (b k) := hDS.map_map _ _ _ + +/-- Every matrix over the colimit lifts to a matrix at some +stage. -/ +theorem DirectedColimitPresentation.exists_stage_matrix + [Preorder ι] {F : ι → Type*} [∀ i, CommRing (F i)] [Nonempty ι] + [IsDirectedOrder ι] {f : ∀ ⦃i j : ι⦄, i ≤ j → F i →+* F j} {R : Type*} + [CommRing R] + (P : DirectedColimitPresentation f R) + {p q : ℕ} (X : Matrix (Fin p) (Fin q) R) : + ∃ i, ∃ Y : Matrix (Fin p) (Fin q) (F i), + Y.map (P.toColim i) = X := by + obtain ⟨i, y, hy⟩ := P.exists_stage_family + (fun k : Fin p × Fin q => X k.1 k.2) + refine ⟨i, Matrix.of fun a b => y (a, b), ?_⟩ + ext a b + simpa [Matrix.map_apply] using hy (a, b) + +/-- An equality of matrices in the colimit holds at some later +stage. -/ +theorem DirectedColimitPresentation.exists_stage_matrix_eq + [Preorder ι] {F : ι → Type*} [∀ i, CommRing (F i)] [Nonempty ι] + [IsDirectedOrder ι] {f : ∀ ⦃i j : ι⦄, i ≤ j → F i →+* F j} {R : Type*} + [CommRing R] + (P : DirectedColimitPresentation f R) + (hDS : DirectedSystem F fun _ _ h => f h) + {p q : ℕ} {i : ι} {Xa Xb : Matrix (Fin p) (Fin q) (F i)} + (h : Xa.map (P.toColim i) = Xb.map (P.toColim i)) : + ∃ j, ∃ hij : i ≤ j, Xa.map (f hij) = Xb.map (f hij) := by + have h' : ∀ k : Fin p × Fin q, + P.toColim i (Xa k.1 k.2) = P.toColim i (Xb k.1 k.2) := by + intro k + have h1 := (Matrix.ext_iff.mpr h) k.1 k.2 + simpa [Matrix.map_apply] using h1 + obtain ⟨j, hij, he⟩ := P.exists_stage_eq hDS h' + refine ⟨j, hij, ?_⟩ + ext a b + simpa [Matrix.map_apply] using he (a, b) + +end Colimit + +/-! ## The limit theorem -/ + +section Limit + +variable {ι : Type*} + +/-- Certificates descend to a finite stage: when the base change +to the colimit of a stage-`i₀` presentation matrix admits a +certificate over `R`, its base change to some finite stage +`j ≥ i₀` admits a certificate over `F j`. This is the equational +heart of the limit theorem for flatness: the certificate is a +finite system of ring equations, its entries live at a finite +stage, and the equations hold at a further stage. -/ +theorem DirectedColimitPresentation.exists_stage_matrix_certificate + [Preorder ι] [Nonempty ι] [IsDirectedOrder ι] {F : ι → Type*} + [∀ i, CommRing (F i)] {f : ∀ ⦃i j : ι⦄, i ≤ j → F i →+* F j} {R : Type*} + [CommRing R] + (P : DirectedColimitPresentation f R) + (hDS : DirectedSystem F fun _ _ h => f h) + {m n : ℕ} {i₀ : ι} (K₀ : Matrix (Fin n) (Fin m) (F i₀)) + (T : Matrix (Fin m) (Fin n) R) + (hT : K₀.map (P.toColim i₀) * T * K₀.map (P.toColim i₀) + = K₀.map (P.toColim i₀)) : + ∃ j, ∃ hij : i₀ ≤ j, ∃ Tj : Matrix (Fin m) (Fin n) (F j), + K₀.map (f hij) * Tj * K₀.map (f hij) = K₀.map (f hij) := by + -- lift the certificate entries to a stage `i₁` + obtain ⟨i₁, T₁, hT₁⟩ := P.exists_stage_matrix T + -- move everything to a common stage `i₂` + obtain ⟨i₂, h₀₂, h₁₂⟩ := exists_ge_ge i₀ i₁ + -- the certificate equation holds in the colimit at stage `i₂` + have hK₂ : (K₀.map (f h₀₂)).map (P.toColim i₂) + = K₀.map (P.toColim i₀) := by + ext a b + simp [Matrix.map_apply, P.compat] + have hT₂ : (T₁.map (f h₁₂)).map (P.toColim i₂) = T := by + rw [← hT₁] + ext a b + simp [Matrix.map_apply, P.compat] + have hg : (K₀.map (f h₀₂) * T₁.map (f h₁₂) * K₀.map (f h₀₂)).map + (P.toColim i₂) + = (K₀.map (f h₀₂)).map (P.toColim i₂) := by + rw [Matrix.map_mul, Matrix.map_mul, hK₂, hT₂, hT] + -- the equation therefore holds at a later stage `j` + obtain ⟨j, h₂ⱼ, he⟩ := P.exists_stage_matrix_eq hDS hg + refine ⟨j, h₀₂.trans h₂ⱼ, (T₁.map (f h₁₂)).map (f h₂ⱼ), ?_⟩ + have hKj : (K₀.map (f h₀₂)).map (f h₂ⱼ) + = K₀.map (f (h₀₂.trans h₂ⱼ)) := by + ext a b + simp only [Matrix.map_apply] + exact hDS.map_map _ _ _ + rw [← hKj] + rw [Matrix.map_mul, Matrix.map_mul] at he + exact he + +/-- The limit theorem for flatness, projective form (the +ordinary-ring case of EGA IV, 11.2.6.1). Let `R` be a directed +colimit of the commutative rings `F i` and let `M` be a projective +`R`-module presented by the base change of a stage-`i₀` matrix +`K₀` — for instance a finitely presented flat module arising by +base change from a finitely presented module at stage `i₀`, via +`Module.Flat.projective_of_finitePresentation`. Then there is a +stage `j ≥ i₀` at which every module presented by the pushed +matrix `K₀.map (f hij)` — in particular the base change +`F j ⊗_{F i₀} M_{i₀}`, whose presentation matrix it is by right +exactness of the tensor product — is projective, hence flat via +`Module.Flat.of_projective`. -/ +theorem DirectedColimitPresentation.exists_stage_projective + [Preorder ι] [Nonempty ι] [IsDirectedOrder ι] {F : ι → Type*} + [∀ i, CommRing (F i)] {f : ∀ ⦃i j : ι⦄, i ≤ j → F i →+* F j} {R : Type*} + [CommRing R] + (P : DirectedColimitPresentation f R) + (hDS : DirectedSystem F fun _ _ h => f h) + {m n : ℕ} {i₀ : ι} (K₀ : Matrix (Fin n) (Fin m) (F i₀)) + {M : Type*} [AddCommGroup M] [Module R M] + [Module.Projective R M] + {π : (Fin n → R) →ₗ[R] M} (hsurj : Function.Surjective π) + (hker : LinearMap.ker π + = LinearMap.range (K₀.map (P.toColim i₀)).mulVecLin) : + ∃ j, ∃ hij : i₀ ≤ j, + ∀ (N : Type*) [AddCommGroup N] [Module (F j) N] + (ρ : (Fin n → F j) →ₗ[F j] N), Function.Surjective ρ → + LinearMap.ker ρ + = LinearMap.range (K₀.map (f hij)).mulVecLin → + Module.Projective (F j) N := by + obtain ⟨T, hT⟩ := matrix_certificate_of_projective hsurj hker + obtain ⟨j, hij, Tj, hTj⟩ := + P.exists_stage_matrix_certificate hDS K₀ T hT + exact ⟨j, hij, fun N _ _ ρ hρsurj hρker => + projective_of_matrix_certificate hρsurj hρker hTj⟩ + +end Limit + +end FlatLimit +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeCollapseAlg.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeCollapseAlg.lean new file mode 100644 index 0000000000..df3588ddc6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeCollapseAlg.lean @@ -0,0 +1,78 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePow + +/-! +# The collapse against the group-algebra action + +Permutation equivariance of the free collapse extends linearly to +the whole symmetric-group algebra: the action on a word of free +letters becomes, after collapsing the heads, the action on the +ambient word under the head. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- Passing a sum across a collapse-type intertwiner. -/ +private theorem add_pass_free + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] + {P W Y : D} {T : P ⟶ W ⊗ Y} + {u v : P ⟶ P} {u' v' : Y ⟶ Y} + (hu : u ≫ T = T ≫ (W ◁ u')) + (hv : v ≫ T = T ≫ (W ◁ v')) : + (u + v) ≫ T = T ≫ (W ◁ (u' + v')) := by + rw [Preadditive.add_comp, hu, hv, + MonoidalPreadditive.whiskerLeft_add, Preadditive.comp_add] + +/-- Passing a scalar across a collapse-type intertwiner. -/ +private theorem smul_pass_free + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [Linear ℂ D] [MonoidalLinear ℂ D] + {P W Y : D} {T : P ⟶ W ⊗ Y} + {u : P ⟶ P} {u' : Y ⟶ Y} (r : ℂ) + (h : u ≫ T = T ≫ (W ◁ u')) : + (r • u) ≫ T = T ≫ (W ◁ (r • u')) := by + rw [Linear.smul_comp, h, MonoidalLinear.whiskerLeft_smul, + Linear.comp_smul] + +/-- **Equivariance of the collapse for the group algebra.** -/ +theorem freeCollapse_permAlg + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (A : D) [MonObj A] [IsCommMonObj A] (V : D) + (n : ℕ) (z : SymGroupAlgebra n) : + (permAlg (A ⊗ V) n z : tensorPow D (A ⊗ V) n ⟶ + tensorPow D (A ⊗ V) n) ≫ freeCollapse A V n = + freeCollapse A V n ≫ + (A ◁ (permAlg V n z : tensorPow D V n ⟶ + tensorPow D V n)) := by + induction z using MonoidAlgebra.induction_on with + | of σ => + rw [show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin n))) σ = + MonoidAlgebra.single σ (1 : ℂ) from rfl, permAlg_single, + permAlg_single] + exact freeCollapse_permMor A V n σ + | add z₁ z₂ h₁ h₂ => + rw [map_add, map_add] + exact add_pass_free h₁ h₂ + | smul r z h => + rw [map_smul, map_smul] + exact smul_pass_free r h + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeMixRetract.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeMixRetract.lean new file mode 100644 index 0000000000..e9f161d5dc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeMixRetract.lean @@ -0,0 +1,51 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210 + +/-! +# The free modules of a finite biproduct as retracts + +A finite biproduct in the ambient category presents each of its +summands as a retract, and taking free modules preserves both the +retraction identities and the totality of the projectors. This is +how a mixed sum of copies of the unit and the odd line is fed to an +additivity argument without ever forming a biproduct in the +category of module objects. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {D : Type u} + +/-- **The free-module retracts of a finite biproduct are total.** -/ +theorem freeModMap_biproduct_total + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] (A : D) [MonObj A] [HasFiniteBiproducts D] + {ι : Type} [Fintype ι] + (f : ι → D) : + ∑ i : ι, (freeModMap A (biproduct.π f i)).hom ≫ + (freeModMap A (biproduct.ι f i)).hom = + 𝟙 (freeMod A (⨁ f)).X := by + have h : ∀ i : ι, (freeModMap A (biproduct.π f i)).hom ≫ + (freeModMap A (biproduct.ι f i)).hom = + A ◁ (biproduct.π f i ≫ biproduct.ι f i) := fun i => + (MonoidalCategory.whiskerLeft_comp A _ _).symm + refine Eq.trans (Finset.sum_congr rfl fun i _ => h i) ?_ + refine Eq.trans (whiskerLeft_sum A Finset.univ + (fun i => biproduct.π f i ≫ biproduct.ι f i)).symm ?_ + rw [biproduct.total] + exact MonoidalCategory.whiskerLeft_id A (⨁ f) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModAdjoint.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModAdjoint.lean new file mode 100644 index 0000000000..bc817e9e73 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModAdjoint.lean @@ -0,0 +1,230 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeMixRetract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModFunctor + +/-! +# The free–forgetful adjunction for module objects + +The free module `freeMod A X` on an object `X` of a monoidal +category `D` carries `A ⊗ X` with the action obtained by +multiplying on the left factor. Maps of `A`-modules out of it are +the same thing as maps out of `X` in `D`: the bijection sends a +module map to its restriction along the unit +`(λ_ X).inv ≫ η[A] ▷ X` and a bare map `g` to its extension +`A ◁ g ≫ actLeft A M.X`. + +* `freeModHomEquiv`: the bijection, with both round trips. +* `freeModHom_eq_zero_iff`: a map out of a free module vanishes + exactly when its restriction along the unit does. This is the + additive shadow of the adjunction, available even though the + hom-sets of `Mod D A` carry no additive structure here. +* `hom_eq_zero_of_generators`: a module map out of `N` vanishes as + soon as it is killed by a family of free modules whose retracts + sum to the identity of `N`. +* `freeModAdjunction`: the bijection bundled as an adjunction + between `freeModFunctor A` and `Mod.forget A`. + +All the intermediate statements are phrased in the ambient +language of `A ⊗ X` and a bare action morphism, and are transported +into the category of module objects by definitional unfolding. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +section Bijection + +/-- The unit of the free module is cancelled by the free action. -/ +theorem freeMod_unit_mul + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X : D) : + A ◁ (λ_ X).inv ≫ A ◁ (η[A] ▷ X) ≫ + (α_ A A X).inv ≫ μ[A] ▷ X = 𝟙 (A ⊗ X) := by + have h₁ : A ◁ (η[A] ▷ X) ≫ (α_ A A X).inv = + (α_ A (𝟙_ D) X).inv ≫ (A ◁ η[A]) ▷ X := + associator_inv_naturality_middle A η[A] X + have h₂ : A ◁ (λ_ X).inv ≫ (α_ A (𝟙_ D) X).inv = + (ρ_ A).inv ▷ X := by + monoidal + rw [reassoc_of% h₁, reassoc_of% h₂, ← comp_whiskerRight, + MonObj.mul_one, ← comp_whiskerRight, Iso.inv_hom_id, + MonoidalCategory.id_whiskerRight] + +/-- Restricting an extended map along the unit recovers the map. -/ +theorem unit_whiskerLeft_act + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X Y : D) (act : A ⊗ Y ⟶ Y) + (hone : η[A] ▷ Y ≫ act = (λ_ Y).hom) (g : X ⟶ Y) : + (λ_ X).inv ≫ (η[A] ▷ X) ≫ (A ◁ g ≫ act) = g := by + rw [← whisker_exchange_assoc, hone] + simp + +/-- Extending the restriction of a module map along the unit +recovers the module map. -/ +theorem whiskerLeft_unit_cancel + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X Y : D) (act : A ⊗ Y ⟶ Y) + (h : A ⊗ X ⟶ Y) + (hlin : ((α_ A A X).inv ≫ μ[A] ▷ X) ≫ h = A ◁ h ≫ act) : + A ◁ ((λ_ X).inv ≫ (η[A] ▷ X) ≫ h) ≫ act = h := by + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [← hlin] + simp only [Category.assoc] + rw [reassoc_of% (freeMod_unit_mul A X)] + +/-- The extension of a map along the free module intertwines the +free action with the given action. -/ +theorem whiskerLeft_act_lin + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X Y : D) (act : A ⊗ Y ⟶ Y) + (hassoc : A ◁ act ≫ act = (α_ A A Y).inv ≫ μ[A] ▷ Y ≫ act) + (g : X ⟶ Y) : + ((α_ A A X).inv ≫ μ[A] ▷ X) ≫ (A ◁ g ≫ act) = + A ◁ (A ◁ g ≫ act) ≫ act := by + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [← whisker_exchange_assoc, hassoc, + associator_inv_naturality_right_assoc] + +/-- The module law of a map out of a free module, in tensor +form. -/ +theorem freeModHom_lin [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X : D) (M : Mod D A) + (f : freeMod A X ⟶ M) : + ((α_ A A X).inv ≫ μ[A] ▷ X) ≫ f.hom = + A ◁ f.hom ≫ actLeft A M.X := + f.isModHom.smul_hom + +/-- **The free–forgetful adjunction bijection for module +objects**: module maps out of the free module on `X` are maps out +of `X`, by restriction along the unit. -/ +noncomputable def freeModHomEquiv + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X : D) (M : Mod D A) : + (freeMod A X ⟶ M) ≃ (X ⟶ M.X) where + toFun f := (λ_ X).inv ≫ (η[A] ▷ X) ≫ f.hom + invFun g := Mod.Hom.mk' (A ◁ g ≫ actLeft A M.X) + (whiskerLeft_act_lin A X M.X (actLeft A M.X) + (actLeft_actLeft A M.X) g) + left_inv f := Mod.Hom.ext + (whiskerLeft_unit_cancel A X M.X (actLeft A M.X) f.hom + (freeModHom_lin A X M f)) + right_inv g := + unit_whiskerLeft_act A X M.X (actLeft A M.X) + (one_actLeft A M.X) g + +@[simp] theorem freeModHomEquiv_apply + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X : D) (M : Mod D A) + (f : freeMod A X ⟶ M) : + freeModHomEquiv A X M f = (λ_ X).inv ≫ (η[A] ▷ X) ≫ f.hom := + rfl + +@[simp] theorem freeModHomEquiv_symm_apply_hom + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X : D) + (M : Mod D A) (g : X ⟶ M.X) : + ((freeModHomEquiv A X M).symm g).hom = A ◁ g ≫ actLeft A M.X := + rfl + +end Bijection + +section Vanishing + +/-- An equivariant map out of a free module vanishes exactly when +its restriction along the unit does. -/ +theorem unit_eq_zero_iff [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] (A : D) [MonObj A] + (X Y : D) (act : A ⊗ Y ⟶ Y) + (h : A ⊗ X ⟶ Y) + (hlin : ((α_ A A X).inv ≫ μ[A] ▷ X) ≫ h = A ◁ h ≫ act) : + h = 0 ↔ (λ_ X).inv ≫ (η[A] ▷ X) ≫ h = 0 := by + constructor + · intro hh + rw [hh, Limits.comp_zero, Limits.comp_zero] + · intro hh + refine Eq.trans + (whiskerLeft_unit_cancel A X Y act h hlin).symm ?_ + rw [hh, MonoidalPreadditive.whiskerLeft_zero, Limits.zero_comp] + +/-- **A map out of a free module vanishes exactly when its +restriction along the unit does.** This replaces the linearity of +the adjunction bijection, which is unavailable because the +hom-sets of `Mod D A` carry no additive structure. -/ +theorem freeModHom_eq_zero_iff + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] (A : D) [MonObj A] + (X : D) (M : Mod D A) + (f : freeMod A X ⟶ M) : + f.hom = 0 ↔ (λ_ X).inv ≫ (η[A] ▷ X) ≫ f.hom = 0 := + unit_eq_zero_iff A X M.X (actLeft A M.X) f.hom + (freeModHom_lin A X M f) + +/-- **Generation by a finite family of free modules**: a module map +out of `N` vanishes as soon as its restrictions along the units of +a family of free modules whose retracts sum to the identity of `N` +all vanish. -/ +theorem hom_eq_zero_of_generators + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] (A : D) [MonObj A] + {N M : Mod D A} {J : Type} + [Fintype J] {f : J → D} (s : ∀ i, freeMod A (f i) ⟶ N) + (r : ∀ i, N ⟶ freeMod A (f i)) + (htot : ∑ i, (r i).hom ≫ (s i).hom = 𝟙 N.X) (g : N ⟶ M) + (hg : ∀ i, (λ_ (f i)).inv ≫ (η[A] ▷ (f i)) ≫ + (s i).hom ≫ g.hom = 0) : + g.hom = 0 := by + have hz : ∀ i, (s i).hom ≫ g.hom = 0 := fun i => + (freeModHom_eq_zero_iff A (f i) M (s i ≫ g)).2 (hg i) + calc g.hom = (∑ i, (r i).hom ≫ (s i).hom) ≫ g.hom := by + rw [htot, Category.id_comp] + _ = ∑ i, (r i).hom ≫ (s i).hom ≫ g.hom := by + simp only [Preadditive.sum_comp, Category.assoc] + _ = 0 := Finset.sum_eq_zero fun i _ => by + rw [hz i, Limits.comp_zero] + +end Vanishing + +section Adjoint + +/-- Restriction along the unit is compatible with postcomposition +in the target. -/ +theorem unit_comp_assoc [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X Y Z : D) (h : A ⊗ X ⟶ Y) (k : Y ⟶ Z) : + (λ_ X).inv ≫ (η[A] ▷ X) ≫ h ≫ k = + ((λ_ X).inv ≫ (η[A] ▷ X) ≫ h) ≫ k := by + simp only [Category.assoc] + +/-- **The free–forgetful adjunction for module objects.** -/ +noncomputable def freeModAdjunction + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] : + freeModFunctor A ⊣ Mod.forget A := + Adjunction.mkOfHomEquiv + { homEquiv := fun X M => freeModHomEquiv A X M + homEquiv_naturality_left_symm := by + intro X' X M u g + apply Mod.Hom.ext + change A ◁ (u ≫ g) ≫ actLeft A M.X = + A ◁ u ≫ A ◁ g ≫ actLeft A M.X + erw [MonoidalCategory.whiskerLeft_comp, Category.assoc] + homEquiv_naturality_right := by + intro X M M' u v + exact unit_comp_assoc A X M.X M'.X u.hom v.hom } + +end Adjoint + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModBiprod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModBiprod.lean new file mode 100644 index 0000000000..852193f9a0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModBiprod.lean @@ -0,0 +1,49 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle + +/-! +# Components of the free module on a biproduct + +The free module on a binary biproduct is the biproduct of the two +free modules; that isomorphism is `freeModBiprodIso`, assembled +from the carrier-level distributor `tensorBiprodIso`. +Recorded here are its four components: the distributor followed by +a projection of the module biproduct is the free module on the +corresponding projection of the underlying biproduct, and an +injection of the module biproduct followed by the inverse +distributor is the free module on the corresponding injection. +Since each side is a module map, the identifications are those of +the carriers, and the carrier-level identifications are the +defining equations of `biprod.lift` and `biprod.desc`. + +The vanishing of the free module on a zero object completes the +bookkeeping of the empty mixed sum. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The free module on a zero object is zero**: the vanishing of +a tensor product, retyped at the carrier of the free module. -/ +theorem freeModZeroIso [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] (R : D) [MonObj R] + {V : D} (h : IsZero V) : + IsZero (freeMod R V).X := + isZero_whiskerLeft R h + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModFunctor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModFunctor.lean new file mode 100644 index 0000000000..a8c3410b3f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModFunctor.lean @@ -0,0 +1,69 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreFunctor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModuleFunctor + +/-! +# The free-module functor, and the factorisation of `ω` + +Base change to an algebra is a functor to the module objects over +that algebra, and Deligne's `ω` of 2.11 is that functor followed by +realization. Recording the factorisation lets the two halves be +treated separately: the free-module functor carries the monoidal +comparison of the ambient category, and realization carries the +comparison of (2.11.1). +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +section Free + +variable {D : Type u} + +/-- Base change of a morphism is the identity on the identity. -/ +theorem freeModMap_id [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (V : D) : + freeModMap A (𝟙 V) = 𝟙 (freeMod A V) := by + apply Mod.Hom.ext + exact MonoidalCategory.whiskerLeft_id A V + +/-- Base change of a morphism respects composition. -/ +theorem freeModMap_comp [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + {V W X : D} (f : V ⟶ W) (g : W ⟶ X) : + freeModMap A (f ≫ g) = freeModMap A f ≫ freeModMap A g := by + apply Mod.Hom.ext + exact MonoidalCategory.whiskerLeft_comp A f g + +/-- **Base change to an algebra, as a functor.** -/ +noncomputable def freeModFunctor + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] : D ⥤ Mod D A where + obj V := freeMod A V + map f := freeModMap A f + map_id := freeModMap_id A + map_comp := freeModMap_comp A + +@[simp] theorem freeModFunctor_obj + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (V : D) : + (freeModFunctor A).obj V = freeMod A V := rfl + +@[simp] theorem freeModFunctor_map + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + {V W : D} (f : V ⟶ W) : + (freeModFunctor A).map f = freeModMap A f := rfl + +end Free + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModShuffle.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModShuffle.lean new file mode 100644 index 0000000000..d90b2a74e2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModShuffle.lean @@ -0,0 +1,191 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210 + +/-! +# Free modules on units and biproducts + +The free module on the tensor unit is the regular module, and +the free module on a biproduct is the biproduct of the free +modules: the bookkeeping of the mixed free part of the dévissage +decomposition. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- The right unitor intertwines the free action on the unit +with the regular action. -/ +theorem freeModUnit_linear + [Category.{v} D] [MonoidalCategory D] (B : D) [MonObj B] : + ((α_ B B (𝟙_ D)).inv ≫ μ[B] ▷ (𝟙_ D)) ≫ + (ρ_ B).hom = + (B ◁ (ρ_ B).hom) ≫ μ[B] := by + rw [Category.assoc, rightUnitor_naturality, + ← Category.assoc] + rw [show (α_ B B (𝟙_ D)).inv ≫ (ρ_ (B ⊗ B)).hom = + B ◁ (ρ_ B).hom from by monoidal] + +/-- **The free module on the unit is the regular module.** -/ +noncomputable def freeModUnitIso + [Category.{v} D] [MonoidalCategory D] (B : D) [MonObj B] : + freeMod B (𝟙_ D) ≅ regularMod B where + hom := Mod.Hom.mk' (ρ_ B).hom (by + change ((α_ B B (𝟙_ D)).inv ≫ μ[B] ▷ (𝟙_ D)) ≫ + (ρ_ B).hom = (B ◁ (ρ_ B).hom) ≫ μ[B] + exact freeModUnit_linear B) + inv := Mod.Hom.mk' (ρ_ B).inv (by + change μ[B] ≫ (ρ_ B).inv = (B ◁ (ρ_ B).inv) ≫ + ((α_ B B (𝟙_ D)).inv ≫ μ[B] ▷ (𝟙_ D)) + refine (cancel_mono (ρ_ B).hom).mp ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (ρ_ B).inv_hom_id) ?_ + refine Eq.trans (Category.comp_id _) ?_ + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (freeModUnit_linear B)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => B ◁ t) + (ρ_ B).inv_hom_id) _) ?_ + rw [MonoidalCategory.whiskerLeft_id, Category.id_comp]) + hom_inv_id := by + apply Mod.Hom.ext + exact (ρ_ B).hom_inv_id + inv_hom_id := by + apply Mod.Hom.ext + exact (ρ_ B).inv_hom_id + +section Biprod + +/-- The distributor intertwines the free actions. -/ +theorem freeModBiprod_linear + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (B : D) [MonObj B] (X : D) (Y : D) : + ((α_ B B (X ⊞ Y)).inv ≫ μ[B] ▷ (X ⊞ Y)) ≫ + biprod.lift (B ◁ biprod.fst) (B ◁ biprod.snd) = + (B ◁ biprod.lift (B ◁ biprod.fst) (B ◁ biprod.snd)) ≫ + modBiprodAct B (freeMod B X) (freeMod B Y) := by + apply biprod.hom_ext + · rw [Category.assoc, Category.assoc, biprod.lift_fst] + refine Eq.trans (whisker_eq _ + (whisker_exchange μ[B] (biprod.fst : + X ⊞ Y ⟶ X)).symm) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (associator_inv_naturality_right B B + (biprod.fst : X ⊞ Y ⟶ X)).symm _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (modBiprodAct_fst B (freeMod B X) (freeMod B Y))) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => B ◁ t) + (biprod.lift_fst (B ◁ (biprod.fst : X ⊞ Y ⟶ X)) + (B ◁ (biprod.snd : X ⊞ Y ⟶ Y)))) _) ?_ + rfl + · rw [Category.assoc, Category.assoc, biprod.lift_snd] + refine Eq.trans (whisker_eq _ + (whisker_exchange μ[B] (biprod.snd : + X ⊞ Y ⟶ Y)).symm) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (associator_inv_naturality_right B B + (biprod.snd : X ⊞ Y ⟶ Y)).symm _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (modBiprodAct_snd B (freeMod B X) (freeMod B Y))) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => B ◁ t) + (biprod.lift_snd (B ◁ (biprod.fst : X ⊞ Y ⟶ X)) + (B ◁ (biprod.snd : X ⊞ Y ⟶ Y)))) _) ?_ + rfl + +/-- The inverse of a linear isomorphism is linear. -/ +theorem act_inv_of_act_hom [Category.{v} D] [MonoidalCategory D] (B : D) + {P Q : D} {actP : B ⊗ P ⟶ P} + {actQ : B ⊗ Q ⟶ Q} (e : P ≅ Q) + (h : actP ≫ e.hom = (B ◁ e.hom) ≫ actQ) : + actQ ≫ e.inv = (B ◁ e.inv) ≫ actP := by + have h1 : actQ ≫ e.inv = + (B ◁ e.inv) ≫ ((B ◁ e.hom) ≫ actQ) ≫ e.inv := by + rw [← Category.assoc, ← Category.assoc, + ← MonoidalCategory.whiskerLeft_comp, e.inv_hom_id, + MonoidalCategory.whiskerLeft_id, Category.id_comp] + rw [h1, ← h, Category.assoc, e.hom_inv_id, + Category.comp_id] + +/-- **The free module on a biproduct is the biproduct of the +free modules.** -/ +noncomputable def freeModBiprodIso + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] (B : D) [MonObj B] + (X : D) (Y : D) : + freeMod B (X ⊞ Y) ≅ + modBiprod B (freeMod B X) (freeMod B Y) where + hom := Mod.Hom.mk' (tensorBiprodIso B X Y).hom (by + change ((α_ B B (X ⊞ Y)).inv ≫ μ[B] ▷ (X ⊞ Y)) ≫ + (tensorBiprodIso B X Y).hom = + (B ◁ (tensorBiprodIso B X Y).hom) ≫ + modBiprodAct B (freeMod B X) (freeMod B Y) + exact freeModBiprod_linear B X Y) + inv := Mod.Hom.mk' (tensorBiprodIso B X Y).inv (by + change modBiprodAct B (freeMod B X) (freeMod B Y) ≫ + (tensorBiprodIso B X Y).inv = + (B ◁ (tensorBiprodIso B X Y).inv) ≫ + ((α_ B B (X ⊞ Y)).inv ≫ μ[B] ▷ (X ⊞ Y)) + exact act_inv_of_act_hom B (tensorBiprodIso B X Y) + (freeModBiprod_linear B X Y)) + hom_inv_id := by + apply Mod.Hom.ext + exact (tensorBiprodIso B X Y).hom_inv_id + inv_hom_id := by + apply Mod.Hom.ext + exact (tensorBiprodIso B X Y).inv_hom_id + +end Biprod + +/-- The free module on an isomorphism. -/ +noncomputable def freeModMapIso + [Category.{v} D] [MonoidalCategory D] (B : D) [MonObj B] + {V W : D} (e : V ≅ W) : + freeMod B V ≅ freeMod B W where + hom := freeModMap B e.hom + inv := freeModMap B e.inv + hom_inv_id := by + apply Mod.Hom.ext + change (B ◁ e.hom) ≫ (B ◁ e.inv) = 𝟙 (B ⊗ V) + rw [← MonoidalCategory.whiskerLeft_comp, e.hom_inv_id, + MonoidalCategory.whiskerLeft_id] + inv_hom_id := by + apply Mod.Hom.ext + change (B ◁ e.inv) ≫ (B ◁ e.hom) = 𝟙 (B ⊗ W) + rw [← MonoidalCategory.whiskerLeft_comp, e.inv_hom_id, + MonoidalCategory.whiskerLeft_id] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModShuffleCoh.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModShuffleCoh.lean new file mode 100644 index 0000000000..95dc392ae5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModShuffleCoh.lean @@ -0,0 +1,187 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid + +/-! +# Coherence of the free-module shuffle + +The shuffle `freeModShuffle R V W : (R ⊗ V) ⊗ (R ⊗ W) ⟶ R ⊗ (V ⊗ W)` +of `RS.freeModTensor` obeys the coherence of a monoidal structure. +The four identities recorded here are pure identities of the ambient +braided monoidal category: no coequalizer and no module theory +appears in any of them, and everything is stated in raw +`R ⊗ V` language. + +* `freeModShuffle_assoc`: associativity, against the reassociation + of the generators. +* `freeModShuffle_unit_left`: filling the first algebra slot with + the unit leaves the left action of the free module. +* `freeModShuffle_unit_right`: filling the second algebra slot with + the unit leaves the braided right action of the free module. +* `freeModShuffle_braiding`: the shuffle commutes with the + braiding. + +The first two need only a monoid `R`; the third needs `R` +commutative. The fourth needs the ambient braiding to be a +symmetry: the two legs differ, in a merely braided category, by the +double twist of the leading algebra factor past the second +generator, and that double twist is not the identity. Accordingly +`freeModShuffle_braiding` is stated over a `SymmetricCategory`, as +is the interchange identity `RS.tensorμ_braiding` behind it. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +/-! ## Associativity -/ + +section Assoc + +variable {D : Type u} + +/-- Two multiplications, with a reassociation of the generators +carried past them. -/ +@[reassoc] +theorem mul_mul_whiskerRight + [Category.{v} D] [MonoidalCategory D] (R : D) [MonObj R] + {P Q : D} (g : P ⟶ Q) : + (μ[R] ▷ R) ▷ P ≫ μ[R] ▷ P ≫ R ◁ g = + ((α_ R R R).hom ⊗ₘ g) ≫ (R ◁ μ[R]) ▷ Q ≫ μ[R] ▷ Q := by + rw [tensorHom_def] + simp only [Category.assoc] + rw [whisker_exchange_assoc (R ◁ μ[R]) g] + rw [whisker_exchange μ[R] g, ← comp_whiskerRight_assoc, + ← comp_whiskerRight_assoc, ← comp_whiskerRight_assoc, + MonObj.mul_assoc] + simp only [Category.assoc] + +/-- **Associativity of the shuffle**: shuffling the first two free +modules and then the third agrees, up to the reassociation of the +generators, with shuffling the last two and then the first. -/ +@[reassoc] +theorem freeModShuffle_assoc + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] + (V W Z : D) : + (freeModShuffle R V W ▷ (R ⊗ Z)) ≫ freeModShuffle R (V ⊗ W) Z + ≫ (R ◁ (α_ V W Z).hom) + = (α_ (R ⊗ V) (R ⊗ W) (R ⊗ Z)).hom ≫ + ((R ⊗ V) ◁ freeModShuffle R W Z) ≫ + freeModShuffle R V (W ⊗ Z) := by + simp only [freeModShuffle, comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [reassoc_of% whiskerRight_mul_tensorμ R (V ⊗ W) Z, + reassoc_of% whiskerLeft_mul_tensorμ R V (W ⊗ Z), + ← tensor_associativity_assoc R V R W R Z, + mul_mul_whiskerRight R (α_ V W Z).hom] + +end Assoc + +/-! ## Unitality -/ + +section Unit + +variable {D : Type u} + +/-- Interchanging against a leading unit is a reassociation. -/ +@[reassoc] +theorem rightUnitor_inv_whiskerRight_tensorμ + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + (W : D) : + (ρ_ R).inv ▷ (R ⊗ W) ≫ tensorμ R (𝟙_ D) R W = + (α_ R R W).inv ≫ (R ⊗ R) ◁ (λ_ W).inv := by + simp only [tensorμ, braiding_tensorUnit_left] + monoidal + +/-- **Left unitality of the shuffle**: filling the first generator +slot with the unit turns the shuffle into the left action of the +free module, written out. -/ +@[reassoc] +theorem freeModShuffle_unit_left + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] + (W : D) : + ((ρ_ R).inv ▷ (R ⊗ W)) ≫ freeModShuffle R (𝟙_ D) W + = ((α_ R R W).inv ≫ μ[R] ▷ W) ≫ (R ◁ (λ_ W).inv) := by + rw [freeModShuffle, ← Category.assoc, + rightUnitor_inv_whiskerRight_tensorμ, Category.assoc, + whisker_exchange μ[R] (λ_ W).inv, Category.assoc] + +/-- Interchanging against a trailing unit is the slide. -/ +@[reassoc] +theorem whiskerLeft_rightUnitor_inv_tensorμ + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + (V : D) : + (R ⊗ V) ◁ (ρ_ R).inv ≫ tensorμ R V R (𝟙_ D) = + freeModSlide R V ≫ (R ⊗ R) ◁ (ρ_ V).inv := by + simp only [tensorμ, freeModSlide, Category.assoc] + monoidal + +end Unit + +section Comm + +variable {D : Type u} + +/-- **Right unitality of the shuffle**: filling the second +generator slot with the unit turns the shuffle into the braided +right action of the free module, written out. -/ +@[reassoc] +theorem freeModShuffle_unit_right + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] [IsCommMonObj R] + (V : D) : + ((R ⊗ V) ◁ (ρ_ R).inv) ≫ freeModShuffle R V (𝟙_ D) + = ((β_ (R ⊗ V) R).hom ≫ (α_ R R V).inv ≫ μ[R] ▷ V) ≫ + (R ◁ (ρ_ V).inv) := by + rw [braiding_free_mul, freeModShuffle, ← Category.assoc, + whiskerLeft_rightUnitor_inv_tensorμ, Category.assoc, + whisker_exchange μ[R] (ρ_ V).inv, Category.assoc] + +end Comm + +/-! ## Compatibility with the braiding -/ + +section Symmetric + +variable {D : Type u} + +end Symmetric + +section Braiding + +variable {D : Type u} + +/-- **The shuffle commutes with the braiding**: swapping the two +free modules and shuffling agrees with shuffling and swapping the +two generators. Commutativity of `R` swaps the algebra factors; +the symmetry of the ambient braiding untwists the generators. -/ +@[reassoc] +theorem freeModShuffle_braiding + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (R : D) + [MonObj R] [IsCommMonObj R] + (V W : D) : + (β_ (R ⊗ V) (R ⊗ W)).hom ≫ freeModShuffle R W V + = freeModShuffle R V W ≫ (R ◁ (β_ V W).hom) := by + simp only [freeModShuffle, Category.assoc] + rw [← Category.assoc, tensorμ_braiding, Category.assoc, + tensorHom_def, Category.assoc, + whisker_exchange μ[R] (β_ V W).hom, ← comp_whiskerRight_assoc, + IsCommMonObj.mul_comm] + +end Braiding + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModTensor.lean new file mode 100644 index 0000000000..cf7338a3ce --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModTensor.lean @@ -0,0 +1,387 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPair + +/-! +# The relative tensor of two free modules + +The relative tensor product of the free modules on two objects is +the free module on their tensor product. The comparison is the +*shuffle*: multiply the two algebra factors, having carried the +first generator past the second algebra factor. + +* the shuffle `RS.freeModShuffle` of + `RS/Classical/Deligne/ModTensor.lean`, Mathlib's middle-four + interchange `tensorμ` followed by multiplication; +* `freeModTensorIso`: the resulting isomorphism of `R`-modules + `modTensorMod R (freeMod R V) (freeMod R W) ≅ freeMod R (V ⊗ W)`. +* `modTensorπ_freeModTensorIso` and `freeModTensorIso_gpair`: the + isomorphism computes the projection, hence the pairing + `RS.gpair`, as the shuffle. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +/-! ## Coherence for the shuffle -/ + +section Coherence + +variable {D : Type u} + +/-- The braided coherence morphism carrying a generator past a +scalar: `(R ⊗ V) ⊗ R ⟶ (R ⊗ R) ⊗ V`. -/ +def freeModSlide + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + (V : D) : (R ⊗ V) ⊗ R ⟶ (R ⊗ R) ⊗ V := + (α_ R V R).hom ≫ R ◁ (β_ V R).hom ≫ (α_ R R V).inv + +/-- The middle-four interchange at a free pair, cut open along the +last factor: it is the slide of the generator past the scalar, +whiskered by that factor. -/ +theorem freeModSlide_whiskerRight + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + (V : D) (W : D) : + (α_ (R ⊗ V) R W).inv ≫ freeModSlide R V ▷ W = + tensorμ R V R W ≫ (α_ (R ⊗ R) V W).inv := by + simp only [freeModSlide, tensorμ, comp_whiskerRight, + Category.assoc] + monoidal + +/-- **Associativity of the shuffle**: sliding and then +interchanging against a third scalar agrees with interchanging +against the product of the last two scalars. This is the coherence +behind the balance relation of the relative tensor product. -/ +theorem freeModSlide_tensorμ + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + (V : D) (W : D) : + freeModSlide R V ▷ (R ⊗ W) ≫ tensorμ (R ⊗ R) V R W = + (α_ (R ⊗ V) R (R ⊗ W)).hom ≫ (R ⊗ V) ◁ (α_ R R W).inv ≫ + tensorμ R V (R ⊗ R) W ≫ (α_ R R R).inv ▷ (V ⊗ W) := by + simp only [freeModSlide, tensorμ, + BraidedCategory.braiding_tensor_right_hom, Category.assoc] + monoidal + +/-- **Equivariance of the shuffle**: acting on the leading scalar +and then interchanging agrees with interchanging and then acting. +This is the coherence behind the linearity of the comparison. -/ +theorem tensorμ_whiskerLeft_shuffle + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + (V : D) (W : D) : + (α_ R (R ⊗ V) (R ⊗ W)).inv ≫ (α_ R R V).inv ▷ (R ⊗ W) ≫ + tensorμ (R ⊗ R) V R W = + R ◁ tensorμ R V R W ≫ (α_ R (R ⊗ R) (V ⊗ W)).inv ≫ + (α_ R R R).inv ▷ (V ⊗ W) := by + simp only [tensorμ, MonoidalCategory.whiskerLeft_comp, + Category.assoc] + monoidal + +/-- Interchanging against a unit scalar is a reassociation. -/ +theorem whiskerLeft_leftUnitor_inv_tensorμ + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + (V : D) (W : D) : + (R ⊗ V) ◁ (λ_ W).inv ≫ tensorμ R V (𝟙_ D) W ≫ + (ρ_ R).hom ▷ (V ⊗ W) = (α_ R V W).hom := by + simp only [tensorμ, braiding_tensorUnit_right, Category.assoc] + monoidal + +end Coherence + +/-! ## The shuffle -/ + +section Shuffle + +variable {D : Type u} + +/-- Multiplying the leading scalars moves through the +interchange. -/ +theorem whiskerRight_mul_tensorμ + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] (V : D) (W : D) : + (μ[R] ▷ V) ▷ (R ⊗ W) ≫ tensorμ R V R W = + tensorμ (R ⊗ R) V R W ≫ (μ[R] ▷ R) ▷ (V ⊗ W) := by + simpa using tensorμ_natural_left (μ[R]) (𝟙 V) R W + +/-- Multiplying the trailing scalars moves through the +interchange. -/ +theorem whiskerLeft_mul_tensorμ + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] (V : D) (W : D) : + (R ⊗ V) ◁ (μ[R] ▷ W) ≫ tensorμ R V R W = + tensorμ R V (R ⊗ R) W ≫ (R ◁ μ[R]) ▷ (V ⊗ W) := by + simpa using tensorμ_natural_right R V (μ[R]) (𝟙 W) + +/-- The trailing unit moves through the interchange. -/ +theorem whiskerLeft_one_tensorμ + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] (V : D) (W : D) : + (R ⊗ V) ◁ (η[R] ▷ W) ≫ tensorμ R V R W = + tensorμ R V (𝟙_ D) W ≫ (R ◁ η[R]) ▷ (V ⊗ W) := by + simpa using tensorμ_natural_right R V (η[R]) (𝟙 W) + +/-- Associativity of the algebra, whiskered by an object. -/ +theorem whiskerRight_mul_assoc + [Category.{v} D] [MonoidalCategory D] (R : D) [MonObj R] + (X : D) : + (R ◁ μ[R]) ▷ X ≫ μ[R] ▷ X = + (α_ R R R).inv ▷ X ≫ (μ[R] ▷ R) ▷ X ≫ μ[R] ▷ X := by + rw [← comp_whiskerRight, MonObj.mul_assoc_flip, comp_whiskerRight, + comp_whiskerRight] + +/-- **The unit inverts the shuffle**: filling the second algebra +slot with the unit turns the shuffle into a reassociation. -/ +theorem whiskerLeft_one_freeModShuffle + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] (V : D) (W : D) : + (R ⊗ V) ◁ ((λ_ W).inv ≫ η[R] ▷ W) ≫ freeModShuffle R V W = + (α_ R V W).hom := by + rw [freeModShuffle, MonoidalCategory.whiskerLeft_comp, + Category.assoc, reassoc_of% whiskerLeft_one_tensorμ, + ← comp_whiskerRight, MonObj.mul_one] + exact whiskerLeft_leftUnitor_inv_tensorμ R V W + +end Shuffle + +/-! ## The balance and equivariance of the shuffle -/ + +section Balance + +variable {D : Type u} + +/-- **The braided right action on a free module is the slide +followed by multiplication**: the generator is carried out of the +way and the two algebra factors multiply. -/ +theorem braiding_free_mul + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] [IsCommMonObj R] (V : D) : + (β_ (R ⊗ V) R).hom ≫ (α_ R R V).inv ≫ μ[R] ▷ V = + freeModSlide R V ≫ μ[R] ▷ V := by + rw [BraidedCategory.braiding_tensor_left_hom, freeModSlide] + simp only [Category.assoc, Iso.hom_inv_id_assoc] + rw [← comp_whiskerRight, IsCommMonObj.mul_comm] + +/-- **The shuffle is balanced**, in raw form: the two legs of the +relative tensor product of the free modules agree after it. -/ +theorem freeModShuffle_condition_raw + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] [IsCommMonObj R] (V : D) (W : D) : + (((β_ (R ⊗ V) R).hom ≫ (α_ R R V).inv ≫ μ[R] ▷ V) ▷ + (R ⊗ W)) ≫ freeModShuffle R V W = + ((α_ (R ⊗ V) R (R ⊗ W)).hom ≫ + (R ⊗ V) ◁ ((α_ R R W).inv ≫ μ[R] ▷ W)) ≫ + freeModShuffle R V W := by + rw [braiding_free_mul, freeModShuffle] + simp only [comp_whiskerRight, MonoidalCategory.whiskerLeft_comp, + Category.assoc] + rw [reassoc_of% whiskerRight_mul_tensorμ, + reassoc_of% whiskerLeft_mul_tensorμ, whiskerRight_mul_assoc, + reassoc_of% freeModSlide_tensorμ] + +/-- **The shuffle is equivariant**, in raw form: acting on the +leading scalar and shuffling agrees with shuffling and acting. -/ +theorem freeModShuffle_act_raw + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] (V : D) (W : D) : + (α_ R (R ⊗ V) (R ⊗ W)).inv ≫ + ((α_ R R V).inv ≫ μ[R] ▷ V) ▷ (R ⊗ W) ≫ + freeModShuffle R V W = + R ◁ freeModShuffle R V W ≫ + ((α_ R R (V ⊗ W)).inv ≫ μ[R] ▷ (V ⊗ W)) := by + rw [freeModShuffle] + simp only [comp_whiskerRight, MonoidalCategory.whiskerLeft_comp, + Category.assoc] + rw [reassoc_of% whiskerRight_mul_tensorμ, + associator_inv_naturality_middle_assoc R (μ[R]) (V ⊗ W), + whiskerRight_mul_assoc, reassoc_of% tensorμ_whiskerLeft_shuffle] + +/-- The shuffle absorbs the reassociation of the first leg. -/ +theorem freeModShuffle_associator_inv + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] [IsCommMonObj R] (V : D) (W : D) : + (α_ (R ⊗ V) R W).inv ≫ + ((β_ (R ⊗ V) R).hom ≫ (α_ R R V).inv ≫ μ[R] ▷ V) ▷ W = + freeModShuffle R V W ≫ (α_ R V W).inv := by + rw [braiding_free_mul, freeModShuffle, comp_whiskerRight, + ← Category.assoc, freeModSlide_whiskerRight] + simp only [Category.assoc] + rw [associator_inv_naturality_left] + +/-- **Inserting the unit is a section of the first leg**: the +shuffle followed by the insertion is the insertion followed by the +first leg. -/ +theorem freeModShuffle_unit_legM + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] [IsCommMonObj R] (V : D) (W : D) : + freeModShuffle R V W ≫ (α_ R V W).inv ≫ + (R ⊗ V) ◁ ((λ_ W).inv ≫ η[R] ▷ W) = + ((α_ (R ⊗ V) R W).inv ≫ + ((R ⊗ V) ⊗ R) ◁ ((λ_ W).inv ≫ η[R] ▷ W)) ≫ + (((β_ (R ⊗ V) R).hom ≫ (α_ R R V).inv ≫ μ[R] ▷ V) ▷ + (R ⊗ W)) := by + rw [Category.assoc, + whisker_exchange ((β_ (R ⊗ V) R).hom ≫ (α_ R R V).inv ≫ + μ[R] ▷ V) ((λ_ W).inv ≫ η[R] ▷ W), + reassoc_of% freeModShuffle_associator_inv] + +/-- **Inserting the unit is a retraction of the second leg**. -/ +theorem freeModUnit_legN + [Category.{v} D] [MonoidalCategory D] (R : D) [MonObj R] (V : D) (W : D) : + ((α_ (R ⊗ V) R W).inv ≫ + ((R ⊗ V) ⊗ R) ◁ ((λ_ W).inv ≫ η[R] ▷ W)) ≫ + ((α_ (R ⊗ V) R (R ⊗ W)).hom ≫ + (R ⊗ V) ◁ ((α_ R R W).inv ≫ μ[R] ▷ W)) = + 𝟙 ((R ⊗ V) ⊗ (R ⊗ W)) := by + rw [Category.assoc, + ← Category.assoc (((R ⊗ V) ⊗ R) ◁ ((λ_ W).inv ≫ η[R] ▷ W)), + associator_naturality_right, Category.assoc, + ← MonoidalCategory.whiskerLeft_comp, whiskerLeft_one_mul R W, + MonoidalCategory.whiskerLeft_id, Category.comp_id, + Iso.inv_hom_id] + +end Balance + +/-! ## The isomorphism -/ + +section Iso + +variable {D : Type u} + +/-- **The shuffle is balanced**: it coequalizes the two legs of the +relative tensor product of the two free modules. -/ +theorem freeModShuffle_condition + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] [IsCommMonObj R] (V : D) (W : D) : + modTensorLegM R (freeMod R V) (freeMod R W) ≫ + freeModShuffle R V W = + modTensorLegN R (freeMod R V) (freeMod R W) ≫ + freeModShuffle R V W := + freeModShuffle_condition_raw R V W + +/-- **The relative tensor of two free modules is free**, at the +level of underlying objects: the shuffle descends to an +isomorphism, inverted by filling the second algebra slot with the +unit. -/ +noncomputable def freeModTensorCarrier + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] (R : D) [MonObj R] [IsCommMonObj R] (V : D) (W : D) : + modTensor R (freeMod R V) (freeMod R W) ≅ R ⊗ (V ⊗ W) where + hom := modTensorDesc R (freeMod R V) (freeMod R W) + (freeModShuffle R V W) (freeModShuffle_condition R V W) + inv := ((α_ R V W).inv ≫ + (R ⊗ V) ◁ ((λ_ W).inv ≫ η[R] ▷ W)) ≫ + modTensorπ R (freeMod R V) (freeMod R W) + hom_inv_id := by + apply modTensor_hom_ext + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (modTensorπ_desc R (freeMod R V) + (freeMod R W) (freeModShuffle R V W) + (freeModShuffle_condition R V W)) _) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (freeModShuffle_unit_legM R V W) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (modTensor_condition R + (freeMod R V) (freeMod R W))) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (freeModUnit_legN R V W) _) ?_ + exact Eq.trans (Category.id_comp _) (Category.comp_id _).symm + inv_hom_id := by + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (modTensorπ_desc R (freeMod R V) + (freeMod R W) (freeModShuffle R V W) + (freeModShuffle_condition R V W))) ?_ + show ((α_ R V W).inv ≫ + (R ⊗ V) ◁ ((λ_ W).inv ≫ η[R] ▷ W)) ≫ + freeModShuffle R V W = 𝟙 (R ⊗ (V ⊗ W)) + rw [Category.assoc, whiskerLeft_one_freeModShuffle, + Iso.inv_hom_id] + +/-- The descended shuffle is `R`-linear. -/ +theorem freeModTensorCarrier_linear + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (R : D) [MonObj R] [IsCommMonObj R] (V : D) (W : D) : + modTensorAct R (freeMod R V) (freeMod R W) ≫ + (freeModTensorCarrier R V W).hom = + R ◁ (freeModTensorCarrier R V W).hom ≫ + ((α_ R R (V ⊗ W)).inv ≫ μ[R] ▷ (V ⊗ W)) := + modTensorDescAct_desc R (freeMod R V) (freeMod R W) R + (actLeft R (freeMod R V).X) + (actLeft_actRight R (freeMod R V).X) + (freeModShuffle R V W) (freeModShuffle_condition R V W) + ((α_ R R (V ⊗ W)).inv ≫ μ[R] ▷ (V ⊗ W)) + (freeModShuffle_act_raw R V W) + +/-- **The relative tensor of two free modules is the free module on +the tensor product.** -/ +noncomputable def freeModTensorIso + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (R : D) [MonObj R] [IsCommMonObj R] (V : D) (W : D) : + modTensorMod R (freeMod R V) (freeMod R W) ≅ + freeMod R (V ⊗ W) where + hom := Mod.Hom.mk' (freeModTensorCarrier R V W).hom (by + change modTensorAct R (freeMod R V) (freeMod R W) ≫ + (freeModTensorCarrier R V W).hom = + (R ◁ (freeModTensorCarrier R V W).hom) ≫ + ((α_ R R (V ⊗ W)).inv ≫ μ[R] ▷ (V ⊗ W)) + exact freeModTensorCarrier_linear R V W) + inv := Mod.Hom.mk' (freeModTensorCarrier R V W).inv (by + change ((α_ R R (V ⊗ W)).inv ≫ μ[R] ▷ (V ⊗ W)) ≫ + (freeModTensorCarrier R V W).inv = + (R ◁ (freeModTensorCarrier R V W).inv) ≫ + modTensorAct R (freeMod R V) (freeMod R W) + exact act_inv_of_act_hom R (freeModTensorCarrier R V W) + (freeModTensorCarrier_linear R V W)) + hom_inv_id := by + apply Mod.Hom.ext + exact (freeModTensorCarrier R V W).hom_inv_id + inv_hom_id := by + apply Mod.Hom.ext + exact (freeModTensorCarrier R V W).inv_hom_id + +/-- **The isomorphism computes the projection as the shuffle.** -/ +theorem modTensorπ_freeModTensorIso + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (R : D) [MonObj R] [IsCommMonObj R] (V : D) (W : D) : + modTensorπ R (freeMod R V) (freeMod R W) ≫ + (freeModTensorIso R V W).hom.hom = freeModShuffle R V W := + modTensorπ_desc R (freeMod R V) (freeMod R W) + (freeModShuffle R V W) (freeModShuffle_condition R V W) + +/-- **The isomorphism computes the pairing as the shuffle**: the +pairing `RS.gpair` of two morphisms into free modules is, after the +identification with the free module on the tensor product, the +tensor of the two morphisms followed by the shuffle. -/ +theorem freeModTensorIso_gpair + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (R : D) [MonObj R] [IsCommMonObj R] (V : D) (W : D) + {X Y : D} (m : X ⟶ R ⊗ V) + (n : Y ⟶ R ⊗ W) : + gpair (M := freeMod R V) (N := freeMod R W) m n ≫ + (freeModTensorIso R V W).hom.hom = + (m ⊗ₘ n) ≫ freeModShuffle R V W := by + erw [gpair_def, Category.assoc] + exact whisker_eq _ (modTensorπ_freeModTensorIso R V W) + +end Iso + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormalise.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormalise.lean new file mode 100644 index 0000000000..62d5700ac4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormalise.lean @@ -0,0 +1,182 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormaliseStep +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormaliseBase +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowStage +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowDesc +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeCollapseAlg + +/-! +# The relative power of a free module + +Gathering every head of a word of free letters onto the last +letter is invisible in the module power: one letter at a time, it +is a slide, and a slide is a slot relation. So the descended +collapse is an isomorphism +`modPow A (A ⊗ V) (n + 1) ≅ A ⊗ tensorPow D V (n + 1)`, +and under it the descended group-algebra action becomes the +ambient action under the head. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **Normalisation**: gathering every head onto the last letter +is invisible in the module power. -/ +theorem freeNormalise + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (V : D) + (n : ℕ) : + (freeCollapse A V (n + 1) ≫ freeInsert A V n) ≫ + modPowπ A (freeMod A V).X (n + 1) = + modPowπ A (freeMod A V).X (n + 1) := by + induction n with + | zero => + erw [freeCollapse_freeInsert_one, Category.id_comp] + | succ k ih => + rw [freeCollapse_freeInsert_succ] + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (freeSlideTop_modPowπ A V k)) ?_ + exact modPow_invisible_succ A (freeMod A V).X (k + 1) ih + +/-- **The section of the descended collapse**: insert the head on +the last letter and project. -/ +noncomputable def freeCollapseSection + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] (V : D) + (n : ℕ) : + A ⊗ tensorPow D V (n + 1) ⟶ modPow A (freeMod A V).X (n + 1) := + freeInsert A V n ≫ modPowπ A (freeMod A V).X (n + 1) + +/-- The section retracts the descended collapse. -/ +theorem freeCollapseSection_desc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] (V : D) + (n : ℕ) : + freeCollapseSection A V n ≫ freeCollapseDesc A V (n + 1) = + 𝟙 (A ⊗ tensorPow D V (n + 1)) := by + rw [freeCollapseSection] + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans + (whisker_eq _ (modPowπ_freeCollapseDesc A V (n + 1))) ?_ + exact freeInsert_freeCollapse A V n + +/-- The descended collapse retracts the section. -/ +theorem freeCollapseDesc_section + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (V : D) + (n : ℕ) : + freeCollapseDesc A V (n + 1) ≫ freeCollapseSection A V n = + 𝟙 (modPow A (freeMod A V).X (n + 1)) := by + apply modPow_hom_ext A (freeMod A V).X + erw [← Category.assoc, modPowπ_freeCollapseDesc, + freeCollapseSection, ← Category.assoc] + refine Eq.trans (freeNormalise A V n) ?_ + exact (Category.comp_id _).symm + +/-- **The identification intertwines the two group-algebra +actions.** -/ +theorem freeModPow_alg + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] (A : D) [MonObj A] + [IsCommMonObj A] (V : D) + (n : ℕ) (z : SymGroupAlgebra (n + 1)) : + freeCollapseSection A V n ≫ + (modPowAlg A (freeMod A V).X (n + 1) z : + modPow A (freeMod A V).X (n + 1) ⟶ + modPow A (freeMod A V).X (n + 1)) ≫ + freeCollapseDesc A V (n + 1) = + A ◁ (permAlg V (n + 1) z : tensorPow D V (n + 1) ⟶ + tensorPow D V (n + 1)) := by + have hmid : modPowπ A (freeMod A V).X (n + 1) ≫ + ((modPowAlg A (freeMod A V).X (n + 1) z : + modPow A (freeMod A V).X (n + 1) ⟶ + modPow A (freeMod A V).X (n + 1)) ≫ + freeCollapseDesc A V (n + 1)) = + (permAlg (A ⊗ V) (n + 1) z : + tensorPow D (A ⊗ V) (n + 1) ⟶ + tensorPow D (A ⊗ V) (n + 1)) ≫ + freeCollapse A V (n + 1) := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (modPowπ_permAlg A (freeMod A V).X (n + 1) z) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (modPowπ_freeCollapseDesc A V (n + 1)) + rw [freeCollapseSection] + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ hmid) ?_ + refine Eq.trans + (whisker_eq _ (freeCollapse_permAlg A V (n + 1) z)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (freeInsert_freeCollapse A V n) _) ?_ + exact Category.id_comp _ + +/-- **Module-level vanishing gives whiskered ambient +vanishing.** -/ +theorem whisker_permAlg_eq_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] (A : D) [MonObj A] + [IsCommMonObj A] (V : D) + (n : ℕ) (hn : n ≠ 0) + (z : SymGroupAlgebra n) + (h : (modPowAlg A (freeMod A V).X n z : + modPow A (freeMod A V).X n ⟶ + modPow A (freeMod A V).X n) = 0) : + (A ◁ (permAlg V n z : tensorPow D V n ⟶ + tensorPow D V n)) = 0 := by + obtain ⟨k, rfl⟩ := Nat.exists_eq_succ_of_ne_zero hn + rw [← freeModPow_alg A V k z, h] + exact Eq.trans (whisker_eq _ Limits.zero_comp) Limits.comp_zero + +/-- **Whiskered ambient vanishing gives module-level +vanishing.** -/ +theorem modPowAlg_eq_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (V : D) + (n : ℕ) (hn : n ≠ 0) + (z : SymGroupAlgebra n) + (h : (A ◁ (permAlg V n z : tensorPow D V n ⟶ + tensorPow D V n)) = 0) : + (modPowAlg A (freeMod A V).X n z : + modPow A (freeMod A V).X n ⟶ + modPow A (freeMod A V).X n) = 0 := by + obtain ⟨k, rfl⟩ := Nat.exists_eq_succ_of_ne_zero hn + have hcon := freeModPow_alg A V k z + rw [h] at hcon + refine Eq.trans ?_ (Eq.trans (whisker_eq + (freeCollapseDesc A V (k + 1)) + (Eq.trans (eq_whisker hcon (freeCollapseSection A V k)) + Limits.zero_comp)) Limits.comp_zero) + simp only [← Category.assoc] + rw [freeCollapseDesc_section, Category.id_comp] + simp only [Category.assoc] + rw [freeCollapseDesc_section, Category.comp_id] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormaliseBase.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormaliseBase.lean new file mode 100644 index 0000000000..81e3f49827 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormaliseBase.lean @@ -0,0 +1,62 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowInsert + +/-! +# The one-letter normalisation + +At arity one the collapse and the insertion are mutually inverse: +the single head is already at the front, and re-inserting it puts +it back where it was. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The one-letter normalisation is trivial.** -/ +theorem freeCollapse_freeInsert_one + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (V : D) : + freeCollapse A V 1 ≫ freeInsert A V 0 = + 𝟙 (tensorPow D (A ⊗ V) 1) := by + have key : ((((λ_ (𝟙_ D)).inv ≫ (η[A] ▷ 𝟙_ D)) ▷ (A ⊗ V)) ≫ + (tensorμ A (𝟙_ D) A V ≫ (μ[A] ▷ (𝟙_ D ⊗ V)))) ≫ + ((α_ A (𝟙_ D) V).inv ≫ ((β_ A (𝟙_ D)).hom ▷ V) ≫ + (α_ (𝟙_ D) A V).hom ≫ (𝟙 (𝟙_ D) ▷ (A ⊗ V))) = + 𝟙 (𝟙_ D ⊗ (A ⊗ V)) := by + rw [MonoidalCategory.id_whiskerRight, Category.comp_id, + MonoidalCategory.comp_whiskerRight] + simp only [Category.assoc] + rw [← MonoidalCategory.tensorHom_id η[A] (𝟙_ D), + tensorμ_natural_left_assoc, + ← MonoidalCategory.tensorHom_id (μ[A]) (𝟙_ D ⊗ V), + MonoidalCategory.tensorHom_comp_tensorHom_assoc, + MonObj.one_mul, MonoidalCategory.id_whiskerRight, + Category.comp_id] + rw [show ((λ_ A).hom ⊗ₘ 𝟙 (𝟙_ D ⊗ V)) = + ((λ_ A).hom ⊗ₘ (λ_ V).hom) ≫ (𝟙 A ⊗ₘ (λ_ V).inv) by + rw [MonoidalCategory.tensorHom_comp_tensorHom, + Category.comp_id, Iso.hom_inv_id]] + simp only [Category.assoc] + have hbr : (β_ A (𝟙_ D)).hom = (ρ_ A).hom ≫ (λ_ A).inv := by + rw [← braiding_leftUnitor A, Category.assoc, Iso.hom_inv_id, + Category.comp_id] + rw [← tensor_left_unitality_assoc, hbr] + monoidal + exact key + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormaliseStep.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormaliseStep.lean new file mode 100644 index 0000000000..29c4c59917 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormaliseStep.lean @@ -0,0 +1,212 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowInsert +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeSlide + +/-! +# The normalisation step for a word of free letters + +Gathering every head of a word of free letters `A ⊗ V` onto its last +letter can be done one letter at a time: normalise all but the last +letter, and then slide the head so gathered one place along. That +is `freeCollapse_freeInsert_succ`. + +Both sides of the identity begin by collapsing the first `k + 1` +letters, so the whole statement reduces to the last two letters: +absorbing a fresh head and inserting on the top letter is inserting +on the penultimate letter and sliding. What is left is braiding +bookkeeping around a single multiplication, organised here by the +*head swap* — carrying a head factor past a block and landing it on +the tail of that block. The interchange is a head swap under a head +(`tensorμ_headSwap`), a head swap past a two-block splits into two +head swaps (`headSwap_tensor_block`), and the slide window is itself +a head swap followed by the action (`freeSlideWin_eq`). The two +products are formed in the same order on both sides, so no +commutativity is needed for the step. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## Carrying a head past a block -/ + +section HeadSwap + +/-- **The head swap**: carry the head factor past a block and land +it on the tail of that block. -/ +private noncomputable def headSwap + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (B P V : D) : + B ⊗ (P ⊗ V) ⟶ P ⊗ (B ⊗ V) := + (α_ B P V).inv ≫ ((β_ B P).hom ▷ V) ≫ (α_ P B V).hom + +/-- The head swap is natural in the head. -/ +@[reassoc] +private theorem headSwap_naturality + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + {B B' : D} (f : B ⟶ B') + (P V : D) : + (f ▷ (P ⊗ V)) ≫ headSwap B' P V = + headSwap B P V ≫ (P ◁ (f ▷ V)) := by + rw [headSwap, headSwap, associator_inv_naturality_left_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, + BraidedCategory.braiding_naturality_left, + MonoidalCategory.comp_whiskerRight_assoc, + associator_naturality_middle, Category.assoc, Category.assoc] + +/-- **Splitting the block**: carrying a head past a two-block is +carrying it past each block in turn. -/ +@[reassoc] +private theorem headSwap_tensor_block + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (B P V W : D) : + (α_ B (P ⊗ V) W).hom ≫ headSwap B (P ⊗ V) W = + (headSwap B P V ▷ W) ≫ (α_ P (B ⊗ V) W).hom ≫ + (P ◁ ((α_ B V W).hom ≫ headSwap B V W)) ≫ + (α_ P V (B ⊗ W)).inv := by + simp only [headSwap, BraidedCategory.braiding_tensor_right_hom] + monoidal + +end HeadSwap + +section HeadSwapSymm + +/-- **The interchange is a head swap under a head**: gathering two +heads and then carrying the pair past a block is carrying the first +head past the block and gathering afterwards. The two braidings the +interchange introduces below the block cancel by symmetry. -/ +@[reassoc] +private theorem tensorμ_headSwap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (B P C V : D) : + tensorμ B P C V ≫ headSwap (B ⊗ C) P V = + (α_ B P (C ⊗ V)).hom ≫ headSwap B P (C ⊗ V) ≫ + (P ◁ (α_ B C V).inv) := by + calc tensorμ B P C V ≫ headSwap (B ⊗ C) P V + = 𝟙 _ ⊗≫ (B ◁ ((β_ P C).hom ≫ (β_ C P).hom) ▷ V) ⊗≫ + ((β_ B P).hom ▷ C ▷ V) ⊗≫ 𝟙 _ := by + simp only [tensorμ, headSwap, + BraidedCategory.braiding_tensor_left_hom] + monoidal + _ = _ := by + rw [SymmetricCategory.symmetry] + simp only [headSwap, MonoidalCategory.whiskerLeft_id, + MonoidalCategory.id_whiskerRight] + monoidal + +end HeadSwapSymm + +/-! ## The two-letter step -/ + +section Step + +/-- **The slide window as a head swap**: the window carries the head +of the first letter past the ambient factor and acts with it on the +second letter, leaving the unit behind. -/ +private theorem freeSlideWin_eq + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (V : D) : + freeSlideWin A V = + (α_ A V (A ⊗ V)).hom ≫ headSwap A V (A ⊗ V) ≫ + (V ◁ ((α_ A A V).inv ≫ (μ[A] ▷ V))) ≫ + (((λ_ V).inv ≫ (η[A] ▷ V)) ▷ (A ⊗ V)) := by + simp only [headSwap, Category.assoc, Iso.hom_inv_id_assoc] + change (((β_ A V).hom ≫ (((λ_ V).inv ≫ (η[A] ▷ V)) ▷ A)) ▷ + (A ⊗ V)) ≫ ((α_ (A ⊗ V) A (A ⊗ V)).hom ≫ + ((A ⊗ V) ◁ ((α_ A A V).inv ≫ (μ[A] ▷ V)))) = _ + rw [MonoidalCategory.comp_whiskerRight, Category.assoc, + associator_naturality_left_assoc, ← whisker_exchange] + +/-- **Absorbing a head, then inserting on the top letter**: the same +as inserting on the penultimate letter and sliding. This is the +whole content of the normalisation step, with the lower block left +generic. -/ +@[reassoc] +private theorem freeModShuffle_headSwap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (V : D) + (P : D) : + freeModShuffle A (P ⊗ V) V ≫ headSwap A (P ⊗ V) V ≫ + ((P ◁ ((λ_ V).inv ≫ (η[A] ▷ V))) ▷ (A ⊗ V)) = + (headSwap A P V ▷ (A ⊗ V)) ≫ (α_ P (A ⊗ V) (A ⊗ V)).hom ≫ + (P ◁ freeSlideWin A V) ≫ (α_ P (A ⊗ V) (A ⊗ V)).inv := by + rw [freeModShuffle, Category.assoc, headSwap_naturality_assoc, + tensorμ_headSwap_assoc, ← MonoidalCategory.whiskerLeft_comp_assoc, + headSwap_tensor_block_assoc, + ← associator_inv_naturality_right_assoc, + ← associator_inv_naturality_middle, + ← MonoidalCategory.whiskerLeft_comp_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc] + simp only [Category.assoc] + rw [← freeSlideWin_eq] + +/-- The step with the insertion of the lower block carried along, +spelt out as the free insertion spells it. -/ +private theorem freeModShuffle_insert + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (V : D) + {P Q : D} (u : P ⟶ Q) : + freeModShuffle A (P ⊗ V) V ≫ + ((α_ A (P ⊗ V) V).inv ≫ ((β_ A (P ⊗ V)).hom ▷ V) ≫ + (α_ (P ⊗ V) A V).hom ≫ + ((u ⊗ₘ ((λ_ V).inv ≫ (η[A] ▷ V))) ▷ (A ⊗ V))) = + (((α_ A P V).inv ≫ ((β_ A P).hom ▷ V) ≫ (α_ P A V).hom ≫ + (u ▷ (A ⊗ V))) ▷ (A ⊗ V)) ≫ + (α_ Q (A ⊗ V) (A ⊗ V)).hom ≫ (Q ◁ freeSlideWin A V) ≫ + (α_ Q (A ⊗ V) (A ⊗ V)).inv := by + have h : freeModShuffle A (P ⊗ V) V ≫ headSwap A (P ⊗ V) V ≫ + ((u ⊗ₘ ((λ_ V).inv ≫ (η[A] ▷ V))) ▷ (A ⊗ V)) = + ((headSwap A P V ≫ (u ▷ (A ⊗ V))) ▷ (A ⊗ V)) ≫ + (α_ Q (A ⊗ V) (A ⊗ V)).hom ≫ (Q ◁ freeSlideWin A V) ≫ + (α_ Q (A ⊗ V) (A ⊗ V)).inv := by + rw [MonoidalCategory.tensorHom_def', + MonoidalCategory.comp_whiskerRight, freeModShuffle_headSwap_assoc, + MonoidalCategory.comp_whiskerRight, Category.assoc, + associator_naturality_left_assoc, ← whisker_exchange_assoc, + associator_inv_naturality_left] + simpa only [headSwap, Category.assoc] using h + +end Step + +/-! ## The normalisation step -/ + +section Normalise + +/-- **The normalisation step**: gathering every head of a word of +free letters onto the last letter is gathering the heads of all but +the last onto the penultimate letter and then sliding that head one +place along. -/ +theorem freeCollapse_freeInsert_succ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (A : D) [MonObj A] + (V : D) (k : ℕ) : + freeCollapse A V (k + 2) ≫ freeInsert A V (k + 1) = + ((freeCollapse A V (k + 1) ≫ freeInsert A V k) ▷ (A ⊗ V)) ≫ + freeSlideTop A V k := by + have hstep : freeModShuffle A (tensorPow D V (k + 1)) V ≫ + freeInsert A V (k + 1) = + (freeInsert A V k ▷ (A ⊗ V)) ≫ freeSlideTop A V k := + freeModShuffle_insert A V (freeUnitPow A V k) + refine Eq.trans (eq_whisker (freeCollapse_succ A V (k + 1)) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ hstep) ?_ + exact Eq.trans (Category.assoc _ _ _).symm + (eq_whisker (MonoidalCategory.comp_whiskerRight _ _ _).symm _) + +end Normalise + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePow.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePow.lean new file mode 100644 index 0000000000..cc432a746a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePow.lean @@ -0,0 +1,240 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowCast +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PlainShuffle +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MuInterchange + +/-! +# The relative power of a free module + +Over an internal commutative monoid `A` in a symmetric monoidal +category, the module power of the free module `A ⊗ V` collapses to +the free module on the ambient tensor power: +`modPow A (A ⊗ V) (n + 1) ≅ A ⊗ tensorPow D V (n + 1)`. At arity +zero the module power is the unit object while `A ⊗ 𝟙_ D ≅ A`, so +the collapse starts at arity one. + +Throughout, the module structure on `A ⊗ V` is `freeModObj A V` — +multiplication into the head factor — installed as a local instance +for the whole file; the statements of record are spelt at the +carrier `A ⊗ V` with that instance. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## The multiplication fold of a monoid power -/ + +section Fold + +/-- **The multiplication fold**: the left-to-right product +`tensorPow D A n ⟶ A`, one factor at a time; the empty product is +the unit. -/ +noncomputable def muFold + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] : + (n : ℕ) → tensorPow D A n ⟶ A + | 0 => η[A] + | n + 1 => (muFold A n ▷ A) ≫ μ[A] + +@[simp] theorem muFold_zero + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] : + muFold A 0 = η[A] := rfl + +end Fold + +/-! ## Permutation invariance of the fold -/ + +section FoldPerm + +/-- The braiding sandwich on the top two factors is natural in the +lower block. -/ +private theorem braidTop_natural + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + {P Q : D} (f : P ⟶ Q) : + ((f ▷ A) ▷ A) ≫ (α_ Q A A).hom ≫ (Q ◁ (β_ A A).hom) ≫ + (α_ Q A A).inv = + (α_ P A A).hom ≫ (P ◁ (β_ A A).hom) ≫ (α_ P A A).inv ≫ + ((f ▷ A) ▷ A) := by + rw [associator_naturality_left_assoc, ← whisker_exchange_assoc, + associator_inv_naturality_left] + +/-- **Commutativity under a head**: braiding the two top factors is +absorbed by two folds of the multiplication. -/ +private theorem braidTop_mul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [IsCommMonObj A] : + (α_ A A A).hom ≫ (A ◁ (β_ A A).hom) ≫ (α_ A A A).inv ≫ + (μ[A] ▷ A) ≫ μ[A] = (μ[A] ▷ A) ≫ μ[A] := by + have h : (α_ A A A).inv ≫ (μ[A] ▷ A) ≫ μ[A] = + (A ◁ μ[A]) ≫ μ[A] := by + rw [MonObj.mul_assoc, Iso.inv_hom_id_assoc] + rw [h, ← whiskerLeft_comp_assoc, IsCommMonObj.mul_comm, + ← MonObj.mul_assoc] + +/-- The absorption at a generic lower block. -/ +private theorem braidTop_mul' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [IsCommMonObj A] + {P : D} (f : P ⟶ A) : + (α_ P A A).hom ≫ (P ◁ (β_ A A).hom) ≫ (α_ P A A).inv ≫ + (((f ▷ A) ≫ μ[A]) ▷ A) ≫ μ[A] = + (((f ▷ A) ≫ μ[A]) ▷ A) ≫ μ[A] := by + rw [comp_whiskerRight, Category.assoc, + ← reassoc_of% (braidTop_natural A f), braidTop_mul] + +/-- **The top transposition is absorbed by the fold.** -/ +theorem swapTop_muFold + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [IsCommMonObj A] + (n : ℕ) : + swapTop A n ≫ muFold A (n + 2) = muFold A (n + 2) := by + have hM : muFold A (n + 2) = + (((muFold A n ▷ A) ≫ μ[A]) ▷ A) ≫ μ[A] := rfl + rw [hM] + unfold swapTop + repeat' erw [Category.assoc] + exact braidTop_mul' A (muFold A n) + +/-- **Bubbling is absorbed by the fold.** -/ +theorem insertTop_muFold + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [IsCommMonObj A] : ∀ n k : ℕ, + insertTop A n k ≫ muFold A (n + 1) = muFold A (n + 1) + | _, 0 => by rw [insertTop_zero, Category.id_comp] + | 0, _ + 1 => by rw [insertTop_of_zero, Category.id_comp] + | n + 1, k + 1 => by + have h : (insertTop A n k ▷ A) ≫ muFold A (n + 2) = + muFold A (n + 2) := by + change (insertTop A n k ▷ A) ≫ ((muFold A (n + 1) ▷ A) ≫ μ[A]) + = (muFold A (n + 1) ▷ A) ≫ μ[A] + rw [← Category.assoc, ← comp_whiskerRight, + insertTop_muFold A n k] + rw [insertTop_succ] + exact (Category.assoc _ _ _).trans + ((congrArg (fun z => swapTop A n ≫ z) h).trans + (swapTop_muFold A n)) + +/-- **Permutation invariance of the fold**: the fold of a +commutative monoid absorbs the symmetric-group action. -/ +theorem muFold_permMor + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [IsCommMonObj A] + (n : ℕ) (σ : Equiv.Perm (Fin n)) : + permMor A n σ ≫ muFold A n = muFold A n := by + induction n with + | zero => + change 𝟙 _ ≫ _ = _ + exact Category.id_comp _ + | succ n ih => + rw [permMor_succ] + refine (Category.assoc _ _ _).trans ?_ + refine (congrArg + (fun z => (permMor A n (restPerm σ) ▷ A) ≫ z) + (insertTop_muFold A n _)).trans ?_ + change (permMor A n (restPerm σ) ▷ A) ≫ + ((muFold A n ▷ A) ≫ μ[A]) = (muFold A n ▷ A) ≫ μ[A] + rw [← Category.assoc, ← comp_whiskerRight, ih] + +end FoldPerm + +/-! ## The free collapse -/ + +section Collect + +/-- **The free collapse**: multiply all the heads of a power of +free letters to the front of the word. -/ +noncomputable def freeCollapse + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (V : D) : (n : ℕ) → + tensorPow D (A ⊗ V) n ⟶ A ⊗ tensorPow D V n + | 0 => (λ_ (𝟙_ D)).inv ≫ (η[A] ▷ 𝟙_ D) + | n + 1 => (freeCollapse A V n ▷ (A ⊗ V)) ≫ + freeModShuffle A (tensorPow D V n) V + +@[simp] theorem freeCollapse_zero + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (V : D) : + freeCollapse A V 0 = (λ_ (𝟙_ D)).inv ≫ (η[A] ▷ 𝟙_ D) := rfl + +/-- The defining recursion of the collapse. -/ +theorem freeCollapse_succ + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (V : D) + (n : ℕ) : + freeCollapse A V (n + 1) = + (freeCollapse A V n ▷ (A ⊗ V)) ≫ + freeModShuffle A (tensorPow D V n) V := rfl + +end Collect + +section CollapseShuffle + +/-- **The collapse through the diagonal shuffle**: sorting the word +and folding the heads is the collapse. -/ +theorem freeCollapse_shuffle + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (V : D) + (n : ℕ) : + freeCollapse A V n = + (plainShuffle A V n).hom ≫ + (muFold A n ▷ tensorPow D V n) := by + induction n with + | zero => rfl + | succ n ih => + have hstep : ∀ P : D, + ((muFold A n ▷ P) ▷ (A ⊗ V)) ≫ freeModShuffle A P V = + tensorμ (tensorPow D A n) P A V ≫ + (((muFold A n ▷ A) ≫ μ[A]) ▷ (P ⊗ V)) := by + intro P + rw [freeModShuffle, ← tensorHom_id (muFold A n) P, + tensorμ_natural_left_assoc] + congr 1 + rw [MonoidalCategory.id_whiskerRight, + ← tensorHom_id μ[A] (P ⊗ V), tensorHom_comp_tensorHom, + Category.comp_id, tensorHom_id] + refine Eq.trans (freeCollapse_succ A V n) ?_ + refine Eq.trans (eq_whisker + (congrArg (fun t => t ▷ (A ⊗ V)) ih) _) ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.comp_whiskerRight _ _ _) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (hstep (tensorPow D V n))) ?_ + refine Eq.trans ?_ (eq_whisker + (plainShuffle_succ_hom A V n) _).symm + exact (Category.assoc _ _ _).symm + +/-- **Permutation equivariance of the collapse**: sorting the +free letters and then collapsing is collapsing and then sorting +the ambient letters — the heads are folded by a commutative +multiplication, which absorbs the permutation. -/ +theorem freeCollapse_permMor + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (V : D) [IsCommMonObj A] + (n : ℕ) (σ : Equiv.Perm (Fin n)) : + permMor (A ⊗ V) n σ ≫ freeCollapse A V n = + freeCollapse A V n ≫ (A ◁ permMor V n σ) := by + rw [freeCollapse_shuffle, ← Category.assoc, + plainShuffle_permMor] + simp only [Category.assoc] + refine whisker_eq ((plainShuffle A V n).hom) ?_ + rw [MonoidalCategory.tensorHom_def, Category.assoc, + whisker_exchange, ← Category.assoc, + ← MonoidalCategory.comp_whiskerRight, muFold_permMor] + +end CollapseShuffle + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowDesc.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowDesc.lean new file mode 100644 index 0000000000..888370971f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowDesc.lean @@ -0,0 +1,404 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffleCoh +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePow + +/-! +# The free collapse descends to the module power + +The collapse `freeCollapse A V n : (A ⊗ V) ^ ⊗ n ⟶ A ⊗ V ^ ⊗ n` of +`FreePow.lean` multiplies all the heads of a word of free letters +into a single head at the front. Here it is shown to coequalise +the slot relations that present the module power of the free module +`A ⊗ V`, so that it descends to `freeCollapseDesc`. + +The engine is head absorption `freeModShuffle A P V` viewed as the +laxity of the functor `V ↦ A ⊗ V`: it is natural, associative and +unital (`freeModShuffle_natural_left`, +`freeModShuffle_assoc_inv`, `freeModShuffle_unit`), and the collapse +is its iterate. Generalised associativity of a laxity is +`freeCollapse_concat`, the compatibility of the collapse with +concatenation of words. + +Given that, a slot relation is local: whiskering the ambient letters +away, both legs reduce to the two-letter window +`((A ⊗ V) ⊗ A) ⊗ (A ⊗ V) ⟶ A ⊗ (V ⊗ V)`, on which the left leg +multiplies the extra scalar into the first head and the right leg +into the second. The two differ by a single crossing of the two +heads that are multiplied first — a braid identity of the ambient +symmetric structure, `freeWindow_braid` — which commutativity of `A` +absorbs. + +Throughout, the module structure on `A ⊗ V` is `freeModObj A V`; the +carrier is spelt `(freeMod A V).X` so that instance synthesis finds +it. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## The laws of head absorption -/ + +section CollectLaws + +/-- Naturality of head absorption in the accumulated block. -/ +@[reassoc] +theorem freeModShuffle_natural_left + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] + {P P' : D} (f : P ⟶ P') (V : D) : + ((A ◁ f) ▷ (A ⊗ V)) ≫ freeModShuffle A P' V = + freeModShuffle A P V ≫ (A ◁ (f ▷ V)) := by + rw [freeModShuffle, freeModShuffle, + ← MonoidalCategory.id_tensorHom A f, + tensorμ_natural_left_assoc, MonoidalCategory.id_whiskerRight, + MonoidalCategory.id_tensorHom, whisker_exchange, + Category.assoc] + +/-- **Associativity of head absorption**, in inverse-associator +form: the mirror of `RS.freeModShuffle_assoc`. -/ +@[reassoc] +theorem freeModShuffle_assoc_inv + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] + (P Q R : D) : + (α_ (A ⊗ P) (A ⊗ Q) (A ⊗ R)).inv ≫ + (freeModShuffle A P Q ▷ (A ⊗ R)) ≫ + freeModShuffle A (P ⊗ Q) R = + ((A ⊗ P) ◁ freeModShuffle A Q R) ≫ freeModShuffle A P (Q ⊗ R) ≫ + (A ◁ (α_ P Q R).inv) := by + rw [← cancel_epi (α_ (A ⊗ P) (A ⊗ Q) (A ⊗ R)).hom, + Iso.hom_inv_id_assoc, + ← cancel_mono (A ◁ (α_ P Q R).hom)] + simp only [Category.assoc] + rw [← MonoidalCategory.whiskerLeft_comp, Iso.inv_hom_id, + MonoidalCategory.whiskerLeft_id, Category.comp_id] + exact freeModShuffle_assoc A P Q R + +/-- **Unitality of head absorption.** -/ +theorem freeModShuffle_unit + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] + (P : D) : + ((A ⊗ P) ◁ ((λ_ (𝟙_ D)).inv ≫ (η[A] ▷ 𝟙_ D))) ≫ + freeModShuffle A P (𝟙_ D) ≫ (A ◁ (ρ_ P).hom) = + (ρ_ (A ⊗ P)).hom := by + have hunit : ((A ⊗ P) ◁ (η[A] ▷ 𝟙_ D)) ≫ freeModShuffle A P (𝟙_ D) ≫ + (A ◁ (ρ_ P).hom) = + tensorμ A P (𝟙_ D) (𝟙_ D) ≫ ((ρ_ A).hom ⊗ₘ (ρ_ P).hom) := by + have hmul : ((A ◁ η[A]) ▷ (P ⊗ 𝟙_ D)) ≫ (μ[A] ▷ (P ⊗ 𝟙_ D)) = + (ρ_ A).hom ▷ (P ⊗ 𝟙_ D) := by + rw [← MonoidalCategory.comp_whiskerRight, MonObj.mul_one] + rw [freeModShuffle, ← MonoidalCategory.tensorHom_id η[A] (𝟙_ D)] + simp only [Category.assoc] + rw [tensorμ_natural_right_assoc, MonoidalCategory.whiskerLeft_id, + MonoidalCategory.tensorHom_id, reassoc_of% hmul, + ← MonoidalCategory.tensorHom_def] + rw [MonoidalCategory.whiskerLeft_comp, Category.assoc, hunit] + exact (tensor_right_unitality A P).symm + +end CollectLaws + +/-! ## The collapse of a concatenation -/ + +section Concat + +/-- The collapse of a concatenation, stated through head +absorption. -/ +private theorem freeCollapse_concat_collect + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (V : D) + (a : ℕ) : ∀ b : ℕ, + (tensorPowConcat (A ⊗ V) a b).hom ≫ freeCollapse A V (a + b) = + (freeCollapse A V a ⊗ₘ freeCollapse A V b) ≫ + freeModShuffle A (tensorPow D V a) (tensorPow D V b) ≫ + (A ◁ (tensorPowConcat V a b).hom) + | 0 => by + change (ρ_ (tensorPow D (A ⊗ V) a)).hom ≫ freeCollapse A V a = + (freeCollapse A V a ⊗ₘ + ((λ_ (𝟙_ D)).inv ≫ (η[A] ▷ 𝟙_ D))) ≫ + freeModShuffle A (tensorPow D V a) (𝟙_ D) ≫ + (A ◁ (ρ_ (tensorPow D V a)).hom) + rw [MonoidalCategory.tensorHom_def, Category.assoc, + freeModShuffle_unit, MonoidalCategory.rightUnitor_naturality] + | b + 1 => by + have ih := freeCollapse_concat_collect A V a b + have hnat : (α_ (tensorPow D (A ⊗ V) a) + (tensorPow D (A ⊗ V) b) (A ⊗ V)).inv ≫ + ((freeCollapse A V a ⊗ₘ freeCollapse A V b) ▷ (A ⊗ V)) = + (freeCollapse A V a ⊗ₘ + (freeCollapse A V b ▷ (A ⊗ V))) ≫ + (α_ (A ⊗ tensorPow D V a) (A ⊗ tensorPow D V b) + (A ⊗ V)).inv := by + rw [← MonoidalCategory.tensorHom_id + (freeCollapse A V b) (A ⊗ V), + ← MonoidalCategory.tensorHom_id + (freeCollapse A V a ⊗ₘ freeCollapse A V b) (A ⊗ V), + associator_inv_naturality] + have hsplit : (freeCollapse A V a ⊗ₘ + ((freeCollapse A V b ▷ (A ⊗ V)) ≫ + freeModShuffle A (tensorPow D V b) V)) = + (freeCollapse A V a ⊗ₘ + (freeCollapse A V b ▷ (A ⊗ V))) ≫ + ((A ⊗ tensorPow D V a) ◁ + freeModShuffle A (tensorPow D V b) V) := by + rw [← MonoidalCategory.id_tensorHom, tensorHom_comp_tensorHom, + Category.comp_id] + change ((α_ (tensorPow D (A ⊗ V) a) + (tensorPow D (A ⊗ V) b) (A ⊗ V)).inv ≫ + ((tensorPowConcat (A ⊗ V) a b).hom ▷ (A ⊗ V))) ≫ + ((freeCollapse A V (a + b) ▷ (A ⊗ V)) ≫ + freeModShuffle A (tensorPow D V (a + b)) V) = + (freeCollapse A V a ⊗ₘ + ((freeCollapse A V b ▷ (A ⊗ V)) ≫ + freeModShuffle A (tensorPow D V b) V)) ≫ + freeModShuffle A (tensorPow D V a) (tensorPow D V b ⊗ V) ≫ + (A ◁ ((α_ (tensorPow D V a) (tensorPow D V b) V).inv ≫ + ((tensorPowConcat V a b).hom ▷ V))) + rw [hsplit, MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rw [← MonoidalCategory.comp_whiskerRight_assoc, ih] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [freeModShuffle_natural_left, ← Category.assoc, + ← Category.assoc, hnat] + simp only [Category.assoc] + rw [freeModShuffle_assoc_inv_assoc] + +/-- **The collapse of a concatenation**: collapsing a +concatenated word is collapsing each part and multiplying the two +heads. -/ +theorem freeCollapse_concat + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (A : D) [MonObj A] + (V : D) (a b : ℕ) : + (tensorPowConcat (A ⊗ V) a b).hom ≫ freeCollapse A V (a + b) = + (freeCollapse A V a ⊗ₘ freeCollapse A V b) ≫ + tensorμ A (tensorPow D V a) A (tensorPow D V b) ≫ + (μ[A] ▷ (tensorPow D V a ⊗ tensorPow D V b)) ≫ + (A ◁ (tensorPowConcat V a b).hom) := by + refine Eq.trans (freeCollapse_concat_collect A V a b) ?_ + rw [freeModShuffle] + simp only [Category.assoc] + +end Concat + +/-! ## The window of a relation slot -/ + +section Window + +/-- The braid identity behind the window: the two legs differ by a +single crossing of the two heads that are multiplied first. -/ +private theorem freeWindow_braid + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (A V : D) : + ((β_ (A ⊗ V) A).hom ▷ (A ⊗ V)) ≫ + ((α_ A A V).inv ▷ (A ⊗ V)) ≫ tensorμ (A ⊗ A) V A V = + ((α_ (A ⊗ V) A (A ⊗ V)).hom ≫ + ((A ⊗ V) ◁ (α_ A A V).inv) ≫ tensorμ A V (A ⊗ A) V ≫ + ((α_ A A A).inv ▷ (V ⊗ V))) ≫ + (((β_ A A).hom ▷ A) ▷ (V ⊗ V)) := by + calc ((β_ (A ⊗ V) A).hom ▷ (A ⊗ V)) ≫ + ((α_ A A V).inv ▷ (A ⊗ V)) ≫ tensorμ (A ⊗ A) V A V + = 𝟙 _ ⊗≫ (A ◁ ((β_ V A).hom ▷ (A ⊗ V))) ⊗≫ + (((β_ A A).hom ▷ ((V ⊗ A) ⊗ V)) ≫ + ((A ⊗ A) ◁ ((β_ V A).hom ▷ V))) ⊗≫ 𝟙 _ := by + dsimp only [tensorμ] + rw [BraidedCategory.braiding_tensor_left_hom] + monoidal + _ = 𝟙 _ ⊗≫ (A ◁ ((β_ V A).hom ▷ (A ⊗ V))) ⊗≫ + (((A ⊗ A) ◁ ((β_ V A).hom ▷ V)) ≫ + ((β_ A A).hom ▷ ((A ⊗ V) ⊗ V))) ⊗≫ 𝟙 _ := by + rw [whisker_exchange] + _ = _ := by + dsimp only [tensorμ] + rw [BraidedCategory.braiding_tensor_right_hom] + monoidal + +/-- The first slot leg on a window of free letters, resolved into a +braid and the product of the three heads. -/ +private theorem freeWindow_legM + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (A : D) [MonObj A] (V : D) : + winLegM A (freeMod A V).X ≫ freeModShuffle A V V = + (((β_ (A ⊗ V) A).hom ▷ (A ⊗ V)) ≫ + ((α_ A A V).inv ▷ (A ⊗ V)) ≫ tensorμ (A ⊗ A) V A V) ≫ + (((μ[A] ▷ A) ≫ μ[A]) ▷ (V ⊗ V)) := by + have hleft : ((μ[A] ▷ V) ▷ (A ⊗ V)) ≫ tensorμ A V A V = + tensorμ (A ⊗ A) V A V ≫ ((μ[A] ▷ A) ▷ (V ⊗ V)) := by + rw [← MonoidalCategory.tensorHom_id μ[A] V, tensorμ_natural_left, + MonoidalCategory.id_whiskerRight, MonoidalCategory.tensorHom_id] + change (((β_ (A ⊗ V) A).hom ≫ (α_ A A V).inv ≫ (μ[A] ▷ V)) ▷ + (A ⊗ V)) ≫ (tensorμ A V A V ≫ (μ[A] ▷ (V ⊗ V))) = _ + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [reassoc_of% hleft] + +/-- The second slot leg on a window of free letters, resolved into a +reassociation and the product of the three heads. -/ +private theorem freeWindow_legN + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (A : D) [MonObj A] (V : D) : + winLegN A (freeMod A V).X ≫ freeModShuffle A V V = + ((α_ (A ⊗ V) A (A ⊗ V)).hom ≫ + ((A ⊗ V) ◁ (α_ A A V).inv) ≫ tensorμ A V (A ⊗ A) V) ≫ + (((A ◁ μ[A]) ≫ μ[A]) ▷ (V ⊗ V)) := by + have hright : ((A ⊗ V) ◁ (μ[A] ▷ V)) ≫ tensorμ A V A V = + tensorμ A V (A ⊗ A) V ≫ ((A ◁ μ[A]) ▷ (V ⊗ V)) := by + rw [← MonoidalCategory.tensorHom_id μ[A] V, tensorμ_natural_right, + MonoidalCategory.whiskerLeft_id, MonoidalCategory.tensorHom_id] + change ((α_ (A ⊗ V) A (A ⊗ V)).hom ≫ + ((A ⊗ V) ◁ ((α_ A A V).inv ≫ (μ[A] ▷ V)))) ≫ + (tensorμ A V A V ≫ (μ[A] ▷ (V ⊗ V))) = _ + simp only [MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [reassoc_of% hright] + +/-- **The window identity**: a scalar absorbed on either side of an +adjacent pair of free letters ends in the same head. -/ +private theorem freeWindow + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (A : D) [MonObj A] [IsCommMonObj A] + (V : D) : + winLegM A (freeMod A V).X ≫ freeModShuffle A V V = + winLegN A (freeMod A V).X ≫ freeModShuffle A V V := by + have hw : (α_ A A A).inv ≫ (μ[A] ▷ A) ≫ μ[A] = + (A ◁ μ[A]) ≫ μ[A] := by + rw [MonObj.mul_assoc, Iso.inv_hom_id_assoc] + have hc : (((β_ A A).hom ▷ A) ▷ (V ⊗ V)) ≫ + ((μ[A] ▷ A) ▷ (V ⊗ V)) ≫ (μ[A] ▷ (V ⊗ V)) = + ((μ[A] ▷ A) ▷ (V ⊗ V)) ≫ (μ[A] ▷ (V ⊗ V)) := by + simp only [← MonoidalCategory.comp_whiskerRight] + rw [← Category.assoc, ← MonoidalCategory.comp_whiskerRight, + IsCommMonObj.mul_comm] + rw [freeWindow_legM, freeWindow_legN, freeWindow_braid, ← hw] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [hc] + +end Window + +/-! ## The descended collapse -/ + +section Descent + +/-- A slot window inside a word, collapsed: only the composite of +the window with one head absorption survives. -/ +private theorem freeLeg_window + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (A : D) [MonObj A] (V : D) (a b : ℕ) + (L : ((A ⊗ V) ⊗ A) ⊗ (A ⊗ V) ⟶ (A ⊗ V) ⊗ (A ⊗ V)) : + ((tensorPow D (A ⊗ V) a ◁ L) ▷ tensorPow D (A ⊗ V) b) ≫ + modPowGlue (A ⊗ V) a b ≫ freeCollapse A V (a + 2 + b) = + (((freeCollapse A V a ▷ (((A ⊗ V) ⊗ A) ⊗ (A ⊗ V))) ≫ + ((A ⊗ tensorPow D V a) ◁ (L ≫ freeModShuffle A V V)) ≫ + freeModShuffle A (tensorPow D V a) (V ⊗ V) ≫ + (A ◁ (α_ (tensorPow D V a) V V).inv)) ▷ + tensorPow D (A ⊗ V) b) ≫ + ((A ⊗ tensorPow D V (a + 2)) ◁ freeCollapse A V b) ≫ + freeModShuffle A (tensorPow D V (a + 2)) (tensorPow D V b) ≫ + (A ◁ (tensorPowConcat V (a + 2) b).hom) := by + have hA : (tensorPow D (A ⊗ V) a ◁ L) ≫ + (α_ (tensorPow D (A ⊗ V) a) (A ⊗ V) (A ⊗ V)).inv ≫ + freeCollapse A V (a + 2) = + (freeCollapse A V a ▷ (((A ⊗ V) ⊗ A) ⊗ (A ⊗ V))) ≫ + ((A ⊗ tensorPow D V a) ◁ (L ≫ freeModShuffle A V V)) ≫ + freeModShuffle A (tensorPow D V a) (V ⊗ V) ≫ + (A ◁ (α_ (tensorPow D V a) V V).inv) := by + change (tensorPow D (A ⊗ V) a ◁ L) ≫ + (α_ (tensorPow D (A ⊗ V) a) (A ⊗ V) (A ⊗ V)).inv ≫ + ((((freeCollapse A V a ▷ (A ⊗ V)) ≫ + freeModShuffle A (tensorPow D V a) V) ▷ (A ⊗ V)) ≫ + freeModShuffle A (tensorPow D V a ⊗ V) V) = _ + rw [MonoidalCategory.comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rw [← MonoidalCategory.associator_inv_naturality_left_assoc, + ← whisker_exchange_assoc, freeModShuffle_assoc_inv] + have hglue : modPowGlue (A ⊗ V) a b ≫ + freeCollapse A V (a + 2 + b) = + ((α_ (tensorPow D (A ⊗ V) a) (A ⊗ V) (A ⊗ V)).inv ▷ + tensorPow D (A ⊗ V) b) ≫ + ((freeCollapse A V (a + 2) ⊗ₘ freeCollapse A V b) ≫ + freeModShuffle A (tensorPow D V (a + 2)) + (tensorPow D V b) ≫ + (A ◁ (tensorPowConcat V (a + 2) b).hom)) := + (Category.assoc _ _ _).trans + (whisker_eq _ (freeCollapse_concat_collect A V (a + 2) b)) + erw [hglue, MonoidalCategory.tensorHom_def] + simp only [Category.assoc] + erw [← MonoidalCategory.comp_whiskerRight_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc] + erw [Category.assoc] + erw [hA] + rfl + +/-- **The collapse coequalises the slot relations**: a scalar +absorbed on either side of a slot ends up in the same head. -/ +theorem freeCollapse_leg + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (A : D) [MonObj A] [IsCommMonObj A] + (V : D) {n : ℕ} (a b : ℕ) (hab : a + 2 + b = n) : + modPowLegM A (freeMod A V).X a b ≫ + powCast (freeMod A V).X hab ≫ freeCollapse A V n = + modPowLegN A (freeMod A V).X a b ≫ + powCast (freeMod A V).X hab ≫ freeCollapse A V n := by + subst hab + simp only [powCast_rfl, modPowLegM, modPowLegN, + Category.assoc] + erw [Category.id_comp] + change ((tensorPow D (A ⊗ V) a ◁ winLegM A (freeMod A V).X) ▷ + tensorPow D (A ⊗ V) b) ≫ + modPowGlue (A ⊗ V) a b ≫ freeCollapse A V (a + 2 + b) = + ((tensorPow D (A ⊗ V) a ◁ winLegN A (freeMod A V).X) ▷ + tensorPow D (A ⊗ V) b) ≫ + modPowGlue (A ⊗ V) a b ≫ freeCollapse A V (a + 2 + b) + refine ((freeLeg_window A V a b + (winLegM A (freeMod A V).X)).trans ?_).trans + (freeLeg_window A V a b (winLegN A (freeMod A V).X)).symm + exact congrArg + (fun z : ((A ⊗ V) ⊗ A) ⊗ (A ⊗ V) ⟶ A ⊗ (V ⊗ V) => + (((freeCollapse A V a ▷ (((A ⊗ V) ⊗ A) ⊗ (A ⊗ V))) ≫ + ((A ⊗ tensorPow D V a) ◁ z) ≫ + freeModShuffle A (tensorPow D V a) (V ⊗ V) ≫ + (A ◁ (α_ (tensorPow D V a) V V).inv)) ▷ + tensorPow D (A ⊗ V) b) ≫ + ((A ⊗ tensorPow D V (a + 2)) ◁ freeCollapse A V b) ≫ + freeModShuffle A (tensorPow D V (a + 2)) (tensorPow D V b) ≫ + (A ◁ (tensorPowConcat V (a + 2) b).hom)) + (freeWindow A V) + +/-- **The descended collapse.** -/ +noncomputable def freeCollapseDesc + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + (A : D) [MonObj A] + [IsCommMonObj A] (V : D) (n : ℕ) : + modPow A (freeMod A V).X n ⟶ A ⊗ tensorPow D V n := + modPowDesc A (freeMod A V).X (freeCollapse A V n) + (fun a b hab => freeCollapse_leg A V a b hab) + +@[reassoc (attr := simp)] +theorem modPowπ_freeCollapseDesc + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + (A : D) [MonObj A] + [IsCommMonObj A] (V : D) (n : ℕ) : + modPowπ A (freeMod A V).X n ≫ freeCollapseDesc A V n = + freeCollapse A V n := + modPowπ_desc A (freeMod A V).X _ _ + +end Descent + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowInsert.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowInsert.lean new file mode 100644 index 0000000000..055bf82bf4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowInsert.lean @@ -0,0 +1,234 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePow + +/-! +# A section of the free collapse + +The free collapse `freeCollapse A V n` of `Deligne/FreePow.lean` +multiplies the heads of a word of free letters `A ⊗ V` to the front +of the word. From arity one upwards it is a split epimorphism: the +section carries the head of `A ⊗ V ^ ⊗ n` into the topmost letter +and fills every other letter with the unit of `A`. + +The bookkeeping is carried by two auxiliary constructions. The +*unit word* is the empty product of units in a monoid power; folding +it returns the unit, by the left unit law alone. The *unit power* +inserts the unit into every letter of an ambient power; shuffling it +separates the unit word from the ambient word. With those two in +hand the composite of the insertion and the collapse is a +symmetric-monoidal identity: the braiding introduced by the +insertion cancels the braiding hidden inside the middle-four +interchange, and the folded unit word contributes only a left +unitor. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## Unit words and unit-filled powers -/ + +/-- The unit word: the empty product of units in an ambient +power. -/ +noncomputable def unitWord [Category.{v} D] [MonoidalCategory D] + (A : D) [MonObj A] : + (n : ℕ) → (𝟙_ D ⟶ tensorPow D A n) + | 0 => 𝟙 (𝟙_ D) + | n + 1 => (ρ_ (𝟙_ D)).inv ≫ (unitWord A n ⊗ₘ η[A]) + +@[simp] theorem unitWord_zero [Category.{v} D] [MonoidalCategory D] + (A : D) [MonObj A] : + unitWord A 0 = 𝟙 (𝟙_ D) := rfl + +/-- Insert the monoid unit into every letter of an ambient +power. -/ +noncomputable def freeUnitPow [Category.{v} D] [MonoidalCategory D] + (A : D) [MonObj A] (V : D) : + (n : ℕ) → (tensorPow D V n ⟶ tensorPow D (A ⊗ V) n) + | 0 => 𝟙 (𝟙_ D) + | n + 1 => freeUnitPow A V n ⊗ₘ ((λ_ V).inv ≫ (η[A] ▷ V)) + +@[simp] theorem unitPow_zero [Category.{v} D] [MonoidalCategory D] + (A : D) [MonObj A] (V : D) : + freeUnitPow A V 0 = 𝟙 (𝟙_ D) := rfl + +section Fold + +/-- Folding a word of units gives the unit. -/ +theorem unitWord_muFold + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (A : D) [MonObj A] (n : ℕ) : + unitWord A n ≫ muFold A n = η[A] := by + induction n with + | zero => exact Category.id_comp _ + | succ n ih => + change ((ρ_ (𝟙_ D)).inv ≫ (unitWord A n ⊗ₘ η[A])) ≫ + ((muFold A n ▷ A) ≫ μ[A]) = η[A] + rw [Category.assoc, ← Category.assoc (unitWord A n ⊗ₘ η[A]), + ← MonoidalCategory.tensorHom_id (muFold A n) A, + tensorHom_comp_tensorHom, ih, Category.comp_id, + MonoidalCategory.tensorHom_def', Category.assoc, + MonObj.one_mul, ← unitors_inv_equal, + ← leftUnitor_inv_naturality_assoc, Iso.inv_hom_id, + Category.comp_id] + +end Fold + +/-! ## The unit power through the shuffle -/ + +section Shuffle + +/-- Two unit-inserted legs are merged by the interchange into a +single unit pair in front of the ambient pair. -/ +private theorem unitPair_tensorμ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + {X₁ Y₁ : D} (g : 𝟙_ D ⟶ X₁) + (h : 𝟙_ D ⟶ Y₁) (X₂ Y₂ : D) : + (((λ_ X₂).inv ≫ (g ▷ X₂)) ⊗ₘ ((λ_ Y₂).inv ≫ (h ▷ Y₂))) ≫ + tensorμ X₁ X₂ Y₁ Y₂ = + (λ_ (X₂ ⊗ Y₂)).inv ≫ + (((ρ_ (𝟙_ D)).inv ≫ (g ⊗ₘ h)) ▷ (X₂ ⊗ Y₂)) := by + have hkey : ((λ_ X₂).inv ⊗ₘ (λ_ Y₂).inv) ≫ + tensorμ (𝟙_ D) X₂ (𝟙_ D) Y₂ = + (λ_ (X₂ ⊗ Y₂)).inv ≫ ((λ_ (𝟙_ D)).inv ▷ (X₂ ⊗ Y₂)) := by + rw [tensorμ, braiding_tensorUnit_right] + monoidal + rw [← tensorHom_comp_tensorHom, Category.assoc, + ← MonoidalCategory.tensorHom_id g X₂, + ← MonoidalCategory.tensorHom_id h Y₂, + tensorμ_natural g (𝟙 X₂) h (𝟙 Y₂), ← Category.assoc, hkey, + id_tensorHom_id, MonoidalCategory.tensorHom_id, + MonoidalCategory.comp_whiskerRight, unitors_inv_equal, + Category.assoc] + +/-- Shuffling a word of unit-filled letters separates the unit +word from the ambient word. -/ +theorem unitPow_plainShuffle + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (A : D) [MonObj A] (V : D) (n : ℕ) : + freeUnitPow A V n ≫ (plainShuffle A V n).hom = + (λ_ (tensorPow D V n)).inv ≫ + (unitWord A n ▷ tensorPow D V n) := by + induction n with + | zero => + change 𝟙 (𝟙_ D) ≫ (λ_ (𝟙_ D)).inv = + (λ_ (𝟙_ D)).inv ≫ (𝟙 (𝟙_ D) ▷ 𝟙_ D) + rw [Category.id_comp, MonoidalCategory.id_whiskerRight, + Category.comp_id] + | succ n ih => + change (freeUnitPow A V n ⊗ₘ ((λ_ V).inv ≫ (η[A] ▷ V))) ≫ + (((plainShuffle A V n).hom ▷ (A ⊗ V)) ≫ + tensorμ (tensorPow D A n) (tensorPow D V n) A V) = + (λ_ (tensorPow D V n ⊗ V)).inv ≫ + (((ρ_ (𝟙_ D)).inv ≫ (unitWord A n ⊗ₘ η[A])) ▷ + (tensorPow D V n ⊗ V)) + rw [← Category.assoc, + ← MonoidalCategory.tensorHom_id (plainShuffle A V n).hom + (A ⊗ V), tensorHom_comp_tensorHom, ih, Category.comp_id] + exact unitPair_tensorμ (unitWord A n) η[A] + (tensorPow D V n) V + +end Shuffle + +/-! ## The free insertion -/ + +section Insert + +/-- With the unit in the first slot, the interchange is a single +braiding, conjugated by associators. -/ +private theorem unitTensorμ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (P A V : D) : + ((λ_ P).inv ▷ (A ⊗ V)) ≫ tensorμ (𝟙_ D) P A V ≫ + ((λ_ A).hom ▷ (P ⊗ V)) = + (α_ P A V).inv ≫ ((β_ P A).hom ▷ V) ≫ (α_ A P V).hom := by + have h₁ : tensorμ (𝟙_ D) P A V = + (α_ (𝟙_ D) P (A ⊗ V)).hom ≫ + (𝟙_ D ◁ ((α_ P A V).inv ≫ ((β_ P A).hom ▷ V) ≫ + (α_ A P V).hom)) ≫ (α_ (𝟙_ D) A (P ⊗ V)).inv := by + rw [tensorμ] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + have h₂ : ((λ_ P).inv ▷ (A ⊗ V)) ≫ (α_ (𝟙_ D) P (A ⊗ V)).hom = + (λ_ (P ⊗ (A ⊗ V))).inv := by monoidal + have h₃ : (α_ (𝟙_ D) A (P ⊗ V)).inv ≫ ((λ_ A).hom ▷ (P ⊗ V)) = + (λ_ (A ⊗ (P ⊗ V))).hom := by monoidal + rw [h₁] + simp only [Category.assoc] + rw [← Category.assoc, h₂, h₃, ← Category.assoc, + ← leftUnitor_inv_naturality, Category.assoc, Iso.inv_hom_id, + Category.comp_id] + +/-- **The free insertion**: carry the head into the top letter of +the word and fill every other letter with the unit. -/ +noncomputable def freeInsert + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (A : D) [MonObj A] (V : D) (n : ℕ) : + A ⊗ tensorPow D V (n + 1) ⟶ tensorPow D (A ⊗ V) (n + 1) := + (α_ A (tensorPow D V n) V).inv ≫ + ((β_ A (tensorPow D V n)).hom ▷ V) ≫ + (α_ (tensorPow D V n) A V).hom ≫ + (freeUnitPow A V n ▷ (A ⊗ V)) + +/-- **The free insertion is a section of the free collapse.** -/ +theorem freeInsert_freeCollapse + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (A : D) [MonObj A] [IsCommMonObj A] + (V : D) (n : ℕ) : + freeInsert A V n ≫ freeCollapse A V (n + 1) = + 𝟙 (A ⊗ tensorPow D V (n + 1)) := by + have hA : (unitWord A n ▷ A) ≫ ((muFold A n ▷ A) ≫ μ[A]) = + (λ_ A).hom := by + rw [← Category.assoc, ← MonoidalCategory.comp_whiskerRight, + unitWord_muFold, MonObj.one_mul] + have hcol : freeCollapse A V (n + 1) = + ((plainShuffle A V n).hom ▷ (A ⊗ V)) ≫ + tensorμ (tensorPow D A n) (tensorPow D V n) A V ≫ + (((muFold A n ▷ A) ≫ μ[A]) ▷ (tensorPow D V n ⊗ V)) := + (freeCollapse_shuffle A V (n + 1)).trans + ((eq_whisker (plainShuffle_succ_hom A V n) _).trans + (Category.assoc _ _ _)) + have hhead : ((unitWord A n ▷ tensorPow D V n) ▷ (A ⊗ V)) ≫ + tensorμ (tensorPow D A n) (tensorPow D V n) A V ≫ + (((muFold A n ▷ A) ≫ μ[A]) ▷ (tensorPow D V n ⊗ V)) = + tensorμ (𝟙_ D) (tensorPow D V n) A V ≫ + ((λ_ A).hom ▷ (tensorPow D V n ⊗ V)) := by + rw [← MonoidalCategory.tensorHom_id (unitWord A n) + (tensorPow D V n), tensorμ_natural_left_assoc, + MonoidalCategory.id_whiskerRight, + MonoidalCategory.tensorHom_id, + ← MonoidalCategory.comp_whiskerRight, hA] + rw [hcol] + change ((α_ A (tensorPow D V n) V).inv ≫ + ((β_ A (tensorPow D V n)).hom ▷ V) ≫ + (α_ (tensorPow D V n) A V).hom ≫ + (freeUnitPow A V n ▷ (A ⊗ V))) ≫ + (((plainShuffle A V n).hom ▷ (A ⊗ V)) ≫ + tensorμ (tensorPow D A n) (tensorPow D V n) A V ≫ + (((muFold A n ▷ A) ≫ μ[A]) ▷ (tensorPow D V n ⊗ V))) = + 𝟙 (A ⊗ (tensorPow D V n ⊗ V)) + simp only [Category.assoc] + rw [← Category.assoc (freeUnitPow A V n ▷ (A ⊗ V)), + ← MonoidalCategory.comp_whiskerRight, unitPow_plainShuffle, + MonoidalCategory.comp_whiskerRight, Category.assoc, hhead, + unitTensorμ, Iso.hom_inv_id_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, + SymmetricCategory.symmetry, MonoidalCategory.id_whiskerRight, + Category.id_comp, Iso.inv_hom_id] + +end Insert + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSlide.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSlide.lean new file mode 100644 index 0000000000..89ad9c9923 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSlide.lean @@ -0,0 +1,160 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePow + +/-! +# Sliding a head along a word of free letters + +The head of a free letter splits off as a trailing scalar and +slides into the next letter. Splitting and acting back on the +same letter is the identity, so the slot relation of the module +power says exactly that the slide is invisible after the +projection. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **Splitting the head off a free letter**: the head becomes a +trailing scalar and the letter keeps the unit. -/ +noncomputable def freeSplit + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (V : D) : (A ⊗ V) ⟶ (A ⊗ V) ⊗ A := + (β_ A V).hom ≫ (((λ_ V).inv ≫ (η[A] ▷ V)) ▷ A) + +/-- **Splitting and acting back is the identity**: the scalar +returns to the head it came from. -/ +theorem freeSplit_actRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (V : D) : + letI := freeModObj A V + freeSplit A V ≫ actRight A (A ⊗ V) = 𝟙 (A ⊗ V) := by + let := freeModObj A V + change freeSplit A V ≫ (β_ (A ⊗ V) A).hom ≫ + ((α_ A A V).inv ≫ (μ[A] ▷ V)) = 𝟙 (A ⊗ V) + rw [freeSplit, Category.assoc, + BraidedCategory.braiding_naturality_left_assoc, + ← Category.assoc ((β_ A V).hom), SymmetricCategory.symmetry, + Category.id_comp, MonoidalCategory.whiskerLeft_comp, + Category.assoc, + associator_inv_naturality_middle_assoc, + ← MonoidalCategory.comp_whiskerRight, MonObj.mul_one] + monoidal + +/-- **The slide window**: split the head off the first letter and +act with it on the second. -/ +noncomputable def freeSlideWin + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (V : D) : + (A ⊗ V) ⊗ (A ⊗ V) ⟶ (A ⊗ V) ⊗ (A ⊗ V) := + letI := freeModObj A V + (freeSplit A V ▷ (A ⊗ V)) ≫ winLegN A (A ⊗ V) + +/-- Splitting and acting back through the first slot leg is the +identity of the window. -/ +theorem freeSplit_winLegM + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (V : D) : + letI := freeModObj A V + (freeSplit A V ▷ (A ⊗ V)) ≫ winLegM A (A ⊗ V) = + 𝟙 ((A ⊗ V) ⊗ (A ⊗ V)) := by + let := freeModObj A V + rw [winLegM, ← MonoidalCategory.comp_whiskerRight, + freeSplit_actRight, MonoidalCategory.id_whiskerRight] + +/-- **The slide is invisible in the module power**: it is the +difference of the two slot legs at a window whose first leg is the +identity. -/ +theorem freeSlideWin_modPowπ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (V : D) [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + {n : ℕ} (a b : ℕ) + (hab : a + 2 + b = n) : + letI := freeModObj A V + ((tensorPow D (A ⊗ V) a ◁ freeSlideWin A V) ▷ + tensorPow D (A ⊗ V) b) ≫ + modPowGlue (A ⊗ V) a b ≫ powCast (A ⊗ V) hab ≫ + modPowπ A (A ⊗ V) n = + modPowGlue (A ⊗ V) a b ≫ powCast (A ⊗ V) hab ≫ + modPowπ A (A ⊗ V) n := by + let := freeModObj A V + have hsplitN : ((tensorPow D (A ⊗ V) a ◁ freeSlideWin A V) ▷ + tensorPow D (A ⊗ V) b) ≫ modPowGlue (A ⊗ V) a b = + ((tensorPow D (A ⊗ V) a ◁ (freeSplit A V ▷ (A ⊗ V))) ▷ + tensorPow D (A ⊗ V) b) ≫ modPowLegN A (A ⊗ V) a b := by + rw [modPowLegN, freeSlideWin, + MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.comp_whiskerRight, Category.assoc] + have hsplitM : ((tensorPow D (A ⊗ V) a ◁ + (freeSplit A V ▷ (A ⊗ V))) ▷ tensorPow D (A ⊗ V) b) ≫ + modPowLegM A (A ⊗ V) a b = modPowGlue (A ⊗ V) a b := by + rw [modPowLegM, ← Category.assoc, + ← MonoidalCategory.comp_whiskerRight, + ← MonoidalCategory.whiskerLeft_comp, freeSplit_winLegM, + MonoidalCategory.whiskerLeft_id, + MonoidalCategory.id_whiskerRight, Category.id_comp] + rw [← Category.assoc, hsplitN, Category.assoc, + ← modPow_rel A (A ⊗ V) a b hab, ← Category.assoc, hsplitM] + +/-- **The top slide**: slide the head of the penultimate letter +into the last one. -/ +noncomputable def freeSlideTop + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (V : D) + (k : ℕ) : + tensorPow D (A ⊗ V) (k + 2) ⟶ tensorPow D (A ⊗ V) (k + 2) := + letI := freeModObj A V + (α_ (tensorPow D (A ⊗ V) k) (A ⊗ V) (A ⊗ V)).hom ≫ + (tensorPow D (A ⊗ V) k ◁ freeSlideWin A V) ≫ + (α_ (tensorPow D (A ⊗ V) k) (A ⊗ V) (A ⊗ V)).inv + +/-- **The top slide is invisible in the module power.** -/ +theorem freeSlideTop_modPowπ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (V : D) [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (k : ℕ) : + letI := freeModObj A V + freeSlideTop A V k ≫ modPowπ A (A ⊗ V) (k + 2) = + modPowπ A (A ⊗ V) (k + 2) := by + let := freeModObj A V + have hnat : ∀ {P Q Z : D} (f : P ⟶ Q) (m : Q ⟶ Z), + (f ▷ tensorPow D (A ⊗ V) 0) ≫ (ρ_ Q).hom ≫ m = + (ρ_ P).hom ≫ f ≫ m := by + intro P Q Z f m + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (rightUnitor_naturality f) m) ?_ + exact Category.assoc _ _ _ + have hrel := + freeSlideWin_modPowπ A V k 0 (rfl : k + 2 + 0 = k + 2) + rw [modPowGlue, tensorPowConcat_zero, powCast_rfl, + Category.id_comp] at hrel + repeat' erw [Category.assoc] at hrel + rw [← MonoidalCategory.comp_whiskerRight_assoc] at hrel + have hA : ((tensorPow D (A ⊗ V) k ◁ freeSlideWin A V) ≫ + (α_ (tensorPow D (A ⊗ V) k) (A ⊗ V) (A ⊗ V)).inv) ≫ + modPowπ A (A ⊗ V) (k + 2) = + (α_ (tensorPow D (A ⊗ V) k) (A ⊗ V) (A ⊗ V)).inv ≫ + modPowπ A (A ⊗ V) (k + 2) := by + refine (cancel_epi (ρ_ (tensorPow D (A ⊗ V) k ⊗ + (A ⊗ V) ⊗ (A ⊗ V))).hom).mp ?_ + exact Eq.trans (hnat _ _).symm (Eq.trans hrel (hnat _ _)) + erw [freeSlideTop, Category.assoc] + exact (whisker_eq _ hA).trans (Iso.hom_inv_id_assoc _ _) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSummand.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSummand.lean new file mode 100644 index 0000000000..5e7eef08e7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSummand.lean @@ -0,0 +1,896 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModAdjoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffle + +/-! +# Free summands of free mixed modules + +Over an algebra whose unit is a scalar, the free-module functor is +full and faithful on the mixed sums of copies of the tensor unit +and of an odd line, idempotent endomorphisms of those mixed sums +split off further mixed sums, and consequently a direct summand of +a free mixed module is again a free mixed module. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +/-! ## Idempotent complex matrices split -/ + +section Matrices + +/-- An idempotent endomorphism of a finite-dimensional coordinate +space factors through a smaller coordinate space. -/ +theorem exists_split_of_linear_idem {n : ℕ} + (f : (Fin n → ℂ) →ₗ[ℂ] (Fin n → ℂ)) (hf : f ∘ₗ f = f) : + ∃ (r : ℕ) (s : (Fin r → ℂ) →ₗ[ℂ] (Fin n → ℂ)) + (t : (Fin n → ℂ) →ₗ[ℂ] (Fin r → ℂ)), + s ∘ₗ t = f ∧ t ∘ₗ s = LinearMap.id := by + classical + have hff : ∀ y, f (f y) = f y := fun y => + congrFun + (congrArg (fun g : (Fin n → ℂ) →ₗ[ℂ] (Fin n → ℂ) => ⇑g) hf) y + have hU : ∀ u : LinearMap.range f, f ↑u = ↑u := by + intro u + obtain ⟨y, hy⟩ := LinearMap.mem_range.1 u.2 + rw [← hy, hff] + obtain ⟨r, ⟨b⟩⟩ : + ∃ r : ℕ, + Nonempty (Module.Basis (Fin r) ℂ (LinearMap.range f)) := + ⟨_, ⟨Module.finBasis ℂ _⟩⟩ + refine ⟨r, (LinearMap.range f).subtype ∘ₗ + b.equivFun.symm.toLinearMap, + b.equivFun.toLinearMap ∘ₗ f.rangeRestrict, ?_, ?_⟩ + · refine LinearMap.ext fun x => ?_ + change ((b.equivFun.symm (b.equivFun (f.rangeRestrict x)) : + LinearMap.range f) : Fin n → ℂ) = f x + rw [LinearEquiv.symm_apply_apply] + rfl + · refine LinearMap.ext fun w => ?_ + have h1 : f.rangeRestrict + ((b.equivFun.symm w : LinearMap.range f) : Fin n → ℂ) + = b.equivFun.symm w := Subtype.ext (hU _) + change b.equivFun (f.rangeRestrict + ((b.equivFun.symm w : LinearMap.range f) : Fin n → ℂ)) = w + rw [h1, LinearEquiv.apply_symm_apply] + +/-- **An idempotent complex square matrix splits** through a +rectangular pair of matrices. -/ +theorem exists_split_of_matrix_idem {n : ℕ} + (M : Matrix (Fin n) (Fin n) ℂ) (hM : M * M = M) : + ∃ (r : ℕ) (S : Matrix (Fin n) (Fin r) ℂ) + (T : Matrix (Fin r) (Fin n) ℂ), S * T = M ∧ T * S = 1 := by + obtain ⟨r, s, t, hst, hts⟩ := + exists_split_of_linear_idem (Matrix.toLin' M) + (by rw [← Matrix.toLin'_mul, hM]) + refine ⟨r, LinearMap.toMatrix' s, LinearMap.toMatrix' t, ?_, ?_⟩ + · rw [← LinearMap.toMatrix'_comp, hst, LinearMap.toMatrix'_toLin'] + · rw [← LinearMap.toMatrix'_comp, hts, LinearMap.toMatrix'_id] + +end Matrices + +/-! ## Matrix calculus for biproducts -/ + +section Biprod + +variable {D : Type u} + +/-- **The matrix of a composite is the product of the matrices.** -/ +theorem components_comp [Category.{v} D] [Preadditive D] [HasFiniteBiproducts D] + {J K M : Type} [Finite J] [Fintype K] + [Finite M] {f : J → D} {g : K → D} {h : M → D} + (x : ⨁ f ⟶ ⨁ g) (y : ⨁ g ⟶ ⨁ h) (j : J) (m : M) : + biproduct.components (x ≫ y) j m = + ∑ k : K, biproduct.components x j k ≫ + biproduct.components y k m := by + classical + let := Fintype.ofFinite J + let := Fintype.ofFinite M + have key : x ≫ y = ∑ k : K, (x ≫ biproduct.π g k) ≫ + (biproduct.ι g k ≫ y) := by + calc x ≫ y + = x ≫ (∑ k : K, biproduct.π g k ≫ biproduct.ι g k) ≫ y := by + rw [biproduct.total, Category.id_comp] + _ = ∑ k : K, (x ≫ biproduct.π g k) ≫ (biproduct.ι g k ≫ y) := by + rw [Preadditive.sum_comp, Preadditive.comp_sum] + exact Finset.sum_congr rfl fun k _ => by + simp only [Category.assoc] + simp only [biproduct.components, key, Preadditive.comp_sum, + Preadditive.sum_comp, Category.assoc] + +/-- Two maps of biproducts with the same matrix agree. -/ +theorem hom_ext_components + [Category.{v} D] [Preadditive D] [HasFiniteBiproducts D] + {J K : Type} [Finite J] [Finite K] + {f : J → D} {g : K → D} (x y : ⨁ f ⟶ ⨁ g) + (h : ∀ j k, biproduct.components x j k = + biproduct.components y j k) : x = y := by + classical + let := Fintype.ofFinite J + let := Fintype.ofFinite K + rw [← biproduct.components_matrix x, ← biproduct.components_matrix y] + exact congrArg biproduct.matrix (funext fun j => funext fun k => h j k) + +/-- The diagonal entries of the identity matrix. -/ +theorem components_id_self + [Category.{v} D] [Preadditive D] [HasFiniteBiproducts D] + {J : Type} [Finite J] + {f : J → D} (j : J) : + biproduct.components (𝟙 (⨁ f)) j j = 𝟙 (f j) := by + classical + let := Fintype.ofFinite J + simp [biproduct.components] + +/-- The off-diagonal entries of the identity matrix vanish. -/ +theorem components_id_ne + [Category.{v} D] [Preadditive D] [HasFiniteBiproducts D] + {J : Type} [Finite J] + {f : J → D} {j k : J} (h : j ≠ k) : + biproduct.components (𝟙 (⨁ f)) j k = 0 := by + classical + let := Fintype.ofFinite J + simp [biproduct.components, biproduct.ι_π_ne _ h] + +end Biprod + +/-! ## Whiskering by the odd line is injective on morphisms -/ + +section Line + +variable {D : Type u} + +/-- Whiskering an object twice by the line returns the object. -/ +noncomputable def OddLine.rot + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) + (X : D) : (X ⊗ L.obj) ⊗ L.obj ≅ X := + α_ X L.obj L.obj ≪≫ whiskerLeftIso X L.sq ≪≫ ρ_ X + +theorem OddLine.rot_hom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) + (X : D) : + (L.rot X).hom = + (α_ X L.obj L.obj).hom ≫ X ◁ L.sq.hom ≫ (ρ_ X).hom := + rfl + +/-- Whiskering a morphism twice by the line conjugates it. -/ +@[reassoc] +theorem OddLine.whiskerRight_rot + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) + {X Y : D} (f : X ⟶ Y) : + ((f ▷ L.obj) ▷ L.obj) ≫ (L.rot Y).hom = (L.rot X).hom ≫ f := by + simp only [rot_hom, Category.assoc] + rw [associator_naturality_left_assoc, ← whisker_exchange_assoc, + rightUnitor_naturality] + +theorem OddLine.whiskerRight_whiskerRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) + {X Y : D} (f : X ⟶ Y) : + (f ▷ L.obj) ▷ L.obj = (L.rot X).hom ≫ f ≫ (L.rot Y).inv := by + rw [← Category.assoc, ← L.whiskerRight_rot f, Category.assoc, + Iso.hom_inv_id, Category.comp_id] + +/-- Double whiskering by the line is undone by the rotation. -/ +theorem OddLine.rot_whiskerRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) + {X Y : D} (f : X ⟶ Y) : + (L.rot X).inv ≫ ((f ▷ L.obj) ▷ L.obj) ≫ (L.rot Y).hom = f := by + rw [L.whiskerRight_whiskerRight, Category.assoc, + Iso.inv_hom_id_assoc, Category.assoc, Iso.inv_hom_id, + Category.comp_id] + +/-- **Whiskering by the odd line is injective on morphisms.** -/ +theorem OddLine.whiskerRight_injective + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) + {X Y : D} : + Function.Injective (fun f : X ⟶ Y => f ▷ L.obj) := by + intro f g h + have h' : f ▷ L.obj = g ▷ L.obj := h + rw [← L.rot_whiskerRight f, ← L.rot_whiskerRight g, h'] + +/-- A morphism killed by whiskering with the line vanishes. -/ +theorem OddLine.eq_zero_of_whiskerRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] (L : OddLine D) + {X Y : D} (f : X ⟶ Y) + (h : f ▷ L.obj = 0) : f = 0 := by + refine L.whiskerRight_injective ?_ + change f ▷ L.obj = (0 : X ⟶ Y) ▷ L.obj + rw [h, MonoidalPreadditive.zero_whiskerRight] + +end Line + +/-! ## Elementary cancellation helpers -/ + +section Cancel + +variable {D : Type u} + +/-- A morphism sandwiched between isomorphisms vanishes only if it +vanishes. -/ +theorem eq_zero_of_iso_comp [Category.{v} D] [Preadditive D] + {W X Y Z : D} (a : W ≅ X) (f : X ⟶ Y) + (b : Y ≅ Z) (h : a.hom ≫ f ≫ b.hom = 0) : f = 0 := by + have h2 := congrArg (fun k : W ⟶ Z => a.inv ≫ k ≫ b.inv) h + simpa using h2 + +/-- Scalars are determined by their action on a nonzero +morphism. -/ +theorem smul_left_cancel_of_ne_zero + [Category.{v} D] [Preadditive D] [Linear ℂ D] + {X Y : D} {a b : ℂ} {f : X ⟶ Y} + (hf : f ≠ 0) (h : a • f = b • f) : a = b := by + by_contra hne + refine hf ?_ + have h0 : (a - b) • f = 0 := by rw [sub_smul, h, sub_self] + have h1 := congrArg (fun z : X ⟶ Y => (a - b)⁻¹ • z) h0 + simpa [smul_smul, inv_mul_cancel₀ (sub_ne_zero.2 hne)] using h1 + +end Cancel + +/-! ## The unit of the free module -/ + +section Unit + +variable {D : Type u} + +/-- The unit of the free module on an object, read in the ambient +category. -/ +noncomputable def algUnitHom + [Category.{v} D] [MonoidalCategory D] (R : D) [MonObj R] + (W : D) : W ⟶ R ⊗ W := + (λ_ W).inv ≫ η[R] ▷ W + +/-- The unit of the free module is natural. -/ +@[reassoc] +theorem algUnitHom_naturality + [Category.{v} D] [MonoidalCategory D] (R : D) [MonObj R] + {W W' : D} (k : W ⟶ W') : + algUnitHom R W ≫ (R ◁ k) = k ≫ algUnitHom R W' := by + rw [algUnitHom, algUnitHom, Category.assoc, ← whisker_exchange, + ← leftUnitor_inv_naturality_assoc] + +/-- At the tensor unit the free-module unit is the algebra unit. -/ +theorem algUnitHom_unit + [Category.{v} D] [MonoidalCategory D] (R : D) [MonObj R] : + algUnitHom R (𝟙_ D) ≫ (ρ_ R).hom = η[R] := by + rw [algUnitHom, Category.assoc, rightUnitor_naturality, + ← unitors_equal, Iso.inv_hom_id_assoc] + +/-- **Postcomposition with the free-module unit is bijective.** -/ +def UnitBij [Category.{v} D] [MonoidalCategory D] (R : D) [MonObj R] + (V W : D) : Prop := + Function.Bijective (fun f : V ⟶ W => f ≫ algUnitHom R W) + +/-- The bijectivity statement passes to biproducts in the +target. -/ +theorem unitBij_biproduct_right + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] (R : D) [MonObj R] + {J : Type} [Finite J] + (V : D) (g : J → D) + (h : ∀ k, UnitBij R V (g k)) : UnitBij R V (⨁ g) := by + classical + let := Fintype.ofFinite J + constructor + · intro x y hxy + have hxy' : x ≫ algUnitHom R (⨁ g) = y ≫ algUnitHom R (⨁ g) := hxy + refine biproduct.hom_ext _ _ fun k => ?_ + refine (h k).1 ?_ + change (x ≫ biproduct.π g k) ≫ algUnitHom R (g k) = + (y ≫ biproduct.π g k) ≫ algUnitHom R (g k) + rw [Category.assoc, Category.assoc, ← algUnitHom_naturality, + ← Category.assoc, ← Category.assoc, hxy'] + · intro y + choose f hf using fun k => (h k).2 (y ≫ (R ◁ biproduct.π g k)) + have hf' : ∀ k : J, f k ≫ algUnitHom R (g k) = + y ≫ (R ◁ biproduct.π g k) := hf + refine ⟨∑ k : J, f k ≫ biproduct.ι g k, ?_⟩ + change (∑ k : J, f k ≫ biproduct.ι g k) ≫ algUnitHom R (⨁ g) = y + rw [Preadditive.sum_comp] + have step : ∀ k : J, (f k ≫ biproduct.ι g k) ≫ algUnitHom R (⨁ g) + = y ≫ (R ◁ (biproduct.π g k ≫ biproduct.ι g k)) := by + intro k + rw [Category.assoc, ← algUnitHom_naturality, ← Category.assoc, + hf' k, Category.assoc, + ← MonoidalCategory.whiskerLeft_comp] + rw [Finset.sum_congr rfl fun k _ => step k, + ← Preadditive.comp_sum, ← whiskerLeft_sum R Finset.univ + (fun k : J => biproduct.π g k ≫ biproduct.ι g k), + biproduct.total, MonoidalCategory.whiskerLeft_id, + Category.comp_id] + +/-- The bijectivity statement passes to biproducts in the +source. -/ +theorem unitBij_biproduct_left + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasFiniteBiproducts D] (R : D) [MonObj R] + {J : Type} [Finite J] + (f : J → D) (W : D) + (h : ∀ j, UnitBij R (f j) W) : UnitBij R (⨁ f) W := by + classical + let := Fintype.ofFinite J + constructor + · intro x y hxy + have hxy' : x ≫ algUnitHom R W = y ≫ algUnitHom R W := hxy + refine biproduct.hom_ext' _ _ fun j => ?_ + refine (h j).1 ?_ + change (biproduct.ι f j ≫ x) ≫ algUnitHom R W = + (biproduct.ι f j ≫ y) ≫ algUnitHom R W + rw [Category.assoc, Category.assoc, hxy'] + · intro y + choose g hg using fun j => (h j).2 (biproduct.ι f j ≫ y) + have hg' : ∀ j : J, g j ≫ algUnitHom R W = biproduct.ι f j ≫ y := + hg + refine ⟨∑ j : J, biproduct.π f j ≫ g j, ?_⟩ + change (∑ j : J, biproduct.π f j ≫ g j) ≫ algUnitHom R W = y + rw [Preadditive.sum_comp] + have step : ∀ j : J, + (biproduct.π f j ≫ g j) ≫ algUnitHom R W = + (biproduct.π f j ≫ biproduct.ι f j) ≫ y := by + intro j + rw [Category.assoc, hg' j, ← Category.assoc] + rw [Finset.sum_congr rfl fun j _ => step j, + ← Preadditive.sum_comp, biproduct.total, Category.id_comp] + +end Unit + +/-! ## The atomic hom-sets -/ + +section Atoms + +variable {D : Type u} + +/-- **Endomorphisms of the odd line are scalars** when the +endomorphisms of the tensor unit are. -/ +theorem OddLine.hom_line_scalar + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) + (hsc : ∀ g : 𝟙_ D ⟶ 𝟙_ D, ∃ c : ℂ, g = c • 𝟙 (𝟙_ D)) + (f : L.obj ⟶ L.obj) : ∃ c : ℂ, f = c • 𝟙 L.obj := by + obtain ⟨c, hc⟩ := hsc (L.sq.inv ≫ (f ▷ L.obj) ≫ L.sq.hom) + refine ⟨c, L.whiskerRight_injective ?_⟩ + change f ▷ L.obj = (c • 𝟙 L.obj) ▷ L.obj + rw [MonoidalLinear.smul_whiskerRight, + MonoidalCategory.id_whiskerRight] + refine (Iso.cancel_iso_hom_right _ _ L.sq).mp ?_ + have h1 : (f ▷ L.obj) ≫ L.sq.hom = L.sq.hom ≫ (c • 𝟙 (𝟙_ D)) := by + rw [← hc, Iso.hom_inv_id_assoc] + rw [h1, Linear.comp_smul, Category.comp_id, Linear.smul_comp, + Category.id_comp] + +/-- **Maps from the tensor unit to the odd line vanish** when maps +the other way do. -/ +theorem OddLine.hom_unit_line_eq_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] (L : OddLine D) + (hLU : ∀ g : L.obj ⟶ 𝟙_ D, g = 0) (f : 𝟙_ D ⟶ L.obj) : f = 0 := by + refine L.eq_zero_of_whiskerRight f ?_ + exact eq_zero_of_iso_comp (λ_ L.obj).symm _ L.sq (hLU _) + +/-- Maps from the tensor unit into the free module on the line +vanish. -/ +theorem hom_unit_freeLine_eq_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] (L : OddLine D) (R : D) + (hLR : ∀ f : L.obj ⟶ R, f = 0) (g : 𝟙_ D ⟶ R ⊗ L.obj) : + g = 0 := by + refine L.eq_zero_of_whiskerRight g ?_ + exact eq_zero_of_iso_comp (λ_ L.obj).symm _ (L.rot R) (hLR _) + +/-- Maps from the line into the free module on the tensor unit +vanish. -/ +theorem hom_line_freeUnit_eq_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) (R : D) + (hLR : ∀ f : L.obj ⟶ R, f = 0) (g : L.obj ⟶ R ⊗ 𝟙_ D) : + g = 0 := by + refine (Iso.cancel_iso_hom_right _ _ (ρ_ R)).mp ?_ + rw [Limits.zero_comp] + exact hLR _ + +/-- The free-module unit at the line, transported through the +rotation, is the algebra unit. -/ +theorem algUnitHom_line + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) (R : D) [MonObj R] : + ((algUnitHom R L.obj) ▷ L.obj) ≫ (L.rot R).hom + = L.sq.hom ≫ η[R] := by + have hcoh : ((λ_ L.obj).inv ▷ L.obj) + ≫ (α_ (𝟙_ D) L.obj L.obj).hom + = (λ_ (L.obj ⊗ L.obj)).inv := by monoidal + calc ((algUnitHom R L.obj) ▷ L.obj) ≫ (L.rot R).hom + = ((λ_ L.obj).inv ▷ L.obj) ≫ (((η[R] ▷ L.obj) ▷ L.obj) + ≫ (α_ R L.obj L.obj).hom) + ≫ (R ◁ L.sq.hom) ≫ (ρ_ R).hom := by + rw [algUnitHom, comp_whiskerRight, L.rot_hom] + simp only [Category.assoc] + _ = ((λ_ L.obj).inv ▷ L.obj) ≫ ((α_ (𝟙_ D) L.obj L.obj).hom + ≫ (η[R] ▷ (L.obj ⊗ L.obj))) + ≫ (R ◁ L.sq.hom) ≫ (ρ_ R).hom := by + rw [associator_naturality_left] + _ = algUnitHom R (L.obj ⊗ L.obj) + ≫ (R ◁ L.sq.hom) ≫ (ρ_ R).hom := by + rw [algUnitHom, ← hcoh] + simp only [Category.assoc] + _ = L.sq.hom ≫ algUnitHom R (𝟙_ D) ≫ (ρ_ R).hom := by + rw [← Category.assoc, algUnitHom_naturality, Category.assoc] + _ = L.sq.hom ≫ η[R] := by rw [algUnitHom_unit] + +/-- The free-module unit at the tensor unit is nonzero. -/ +theorem algUnitHom_unit_ne_zero + [Category.{v} D] [MonoidalCategory D] [Preadditive D] (R : D) [MonObj R] + (hη : η[R] ≠ 0) : + algUnitHom R (𝟙_ D) ≠ 0 := fun h => + hη (by rw [← algUnitHom_unit, h, Limits.zero_comp]) + +/-- The free-module unit at the line is nonzero. -/ +theorem algUnitHom_line_ne_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] (L : OddLine D) (R : D) + [MonObj R] + (hη : η[R] ≠ 0) : + algUnitHom R L.obj ≠ 0 := by + intro h + refine hη ?_ + have h2 : L.sq.hom ≫ η[R] = 0 := by + rw [← algUnitHom_line L R, h, + MonoidalPreadditive.zero_whiskerRight, Limits.zero_comp] + have h3 := congrArg (fun k : L.obj ⊗ L.obj ⟶ R => L.sq.inv ≫ k) h2 + simpa using h3 + +/-- **Maps from the line into the free module on the line are +scalar multiples of the unit.** -/ +theorem hom_line_freeLine_scalar + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] + (halg : ∀ f : 𝟙_ D ⟶ R, ∃ c : ℂ, f = c • η[R]) + (g : L.obj ⟶ R ⊗ L.obj) : + ∃ c : ℂ, g = c • algUnitHom R L.obj := by + obtain ⟨c, hc⟩ := halg (L.sq.inv ≫ (g ▷ L.obj) ≫ (L.rot R).hom) + refine ⟨c, L.whiskerRight_injective ?_⟩ + change g ▷ L.obj = (c • algUnitHom R L.obj) ▷ L.obj + rw [MonoidalLinear.smul_whiskerRight] + refine (Iso.cancel_iso_hom_right _ _ (L.rot R)).mp ?_ + have h1 : (g ▷ L.obj) ≫ (L.rot R).hom + = L.sq.hom ≫ (c • η[R]) := by + rw [← hc, Iso.hom_inv_id_assoc] + rw [h1, Linear.smul_comp, algUnitHom_line, Linear.comp_smul] + +/-! ## Bijectivity at the atoms -/ + +/-- The unit-to-unit case. -/ +theorem unitBij_unit_unit + [Category.{v} D] [MonoidalCategory D] [Preadditive D] [Linear ℂ D] + (R : D) [MonObj R] + (hsc : ∀ f : 𝟙_ D ⟶ 𝟙_ D, ∃ c : ℂ, f = c • 𝟙 (𝟙_ D)) + (halg : ∀ f : 𝟙_ D ⟶ R, ∃ c : ℂ, f = c • η[R]) + (hη : η[R] ≠ 0) : UnitBij R (𝟙_ D) (𝟙_ D) := by + constructor + · intro x y hxy + have hxy' : x ≫ algUnitHom R (𝟙_ D) = y ≫ algUnitHom R (𝟙_ D) := + hxy + obtain ⟨a, ha⟩ := hsc x + obtain ⟨b, hb⟩ := hsc y + have hab : a = b := by + refine smul_left_cancel_of_ne_zero + (algUnitHom_unit_ne_zero R hη) ?_ + calc a • algUnitHom R (𝟙_ D) + = x ≫ algUnitHom R (𝟙_ D) := by + rw [ha, Linear.smul_comp, Category.id_comp] + _ = y ≫ algUnitHom R (𝟙_ D) := hxy' + _ = b • algUnitHom R (𝟙_ D) := by + rw [hb, Linear.smul_comp, Category.id_comp] + rw [ha, hb, hab] + · intro y + obtain ⟨c, hc⟩ := halg (y ≫ (ρ_ R).hom) + refine ⟨c • 𝟙 (𝟙_ D), ?_⟩ + change (c • 𝟙 (𝟙_ D)) ≫ algUnitHom R (𝟙_ D) = y + refine (Iso.cancel_iso_hom_right _ _ (ρ_ R)).mp ?_ + rw [Linear.smul_comp, Category.id_comp, Linear.smul_comp, + algUnitHom_unit, hc] + +/-- The unit-to-line case. -/ +theorem unitBij_unit_line + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] (L : OddLine D) (R : D) + [MonObj R] + (hLU : ∀ f : L.obj ⟶ 𝟙_ D, f = 0) + (hLR : ∀ f : L.obj ⟶ R, f = 0) : UnitBij R (𝟙_ D) L.obj := by + constructor + · intro x y _ + rw [L.hom_unit_line_eq_zero hLU x, L.hom_unit_line_eq_zero hLU y] + · intro y + refine ⟨0, ?_⟩ + change (0 : 𝟙_ D ⟶ L.obj) ≫ algUnitHom R L.obj = y + rw [Limits.zero_comp] + exact (hom_unit_freeLine_eq_zero L R hLR y).symm + +/-- The line-to-unit case. -/ +theorem unitBij_line_unit + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) (R : D) [MonObj R] + (hLU : ∀ f : L.obj ⟶ 𝟙_ D, f = 0) + (hLR : ∀ f : L.obj ⟶ R, f = 0) : UnitBij R L.obj (𝟙_ D) := by + constructor + · intro x y _ + rw [hLU x, hLU y] + · intro y + refine ⟨0, ?_⟩ + change (0 : L.obj ⟶ 𝟙_ D) ≫ algUnitHom R (𝟙_ D) = y + rw [Limits.zero_comp] + exact (hom_line_freeUnit_eq_zero L R hLR y).symm + +/-- The line-to-line case. -/ +theorem unitBij_line_line + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] + (hsc : ∀ f : 𝟙_ D ⟶ 𝟙_ D, ∃ c : ℂ, f = c • 𝟙 (𝟙_ D)) + (halg : ∀ f : 𝟙_ D ⟶ R, ∃ c : ℂ, f = c • η[R]) + (hη : η[R] ≠ 0) : UnitBij R L.obj L.obj := by + constructor + · intro x y hxy + have hxy' : x ≫ algUnitHom R L.obj = y ≫ algUnitHom R L.obj := hxy + obtain ⟨a, ha⟩ := L.hom_line_scalar hsc x + obtain ⟨b, hb⟩ := L.hom_line_scalar hsc y + have hab : a = b := by + refine smul_left_cancel_of_ne_zero + (algUnitHom_line_ne_zero L R hη) ?_ + calc a • algUnitHom R L.obj = x ≫ algUnitHom R L.obj := by + rw [ha, Linear.smul_comp, Category.id_comp] + _ = y ≫ algUnitHom R L.obj := hxy' + _ = b • algUnitHom R L.obj := by + rw [hb, Linear.smul_comp, Category.id_comp] + rw [ha, hb, hab] + · intro y + obtain ⟨c, hc⟩ := hom_line_freeLine_scalar L R halg y + refine ⟨c • 𝟙 L.obj, ?_⟩ + change (c • 𝟙 L.obj) ≫ algUnitHom R L.obj = y + rw [Linear.smul_comp, Category.id_comp, hc] + +/-! ## Bijectivity at the mixed sums -/ + +/-- Bijectivity at a mixed target follows from the two atoms. -/ +theorem unitBij_mix_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (R : D) [MonObj R] + (V : D) + (h1 : UnitBij R V (𝟙_ D)) (h2 : UnitBij R V L.obj) (p q : ℕ) : + UnitBij R V (L.mix p q) := by + change UnitBij R V (⨁ L.mixFun p q) + refine unitBij_biproduct_right R V (L.mixFun p q) ?_ + rintro (i | j) + · exact h1 + · exact h2 + +/-- **Postcomposition with the free-module unit is bijective on +mixed sums.** -/ +theorem unitBij_mix [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasFiniteBiproducts D] (L : OddLine D) (R : D) + [MonObj R] + (hsc : ∀ f : 𝟙_ D ⟶ 𝟙_ D, ∃ c : ℂ, f = c • 𝟙 (𝟙_ D)) + (hLU : ∀ f : L.obj ⟶ 𝟙_ D, f = 0) + (halg : ∀ f : 𝟙_ D ⟶ R, ∃ c : ℂ, f = c • η[R]) + (hLR : ∀ f : L.obj ⟶ R, f = 0) + (hη : η[R] ≠ 0) (p q p' q' : ℕ) : + UnitBij R (L.mix p q) (L.mix p' q') := by + change UnitBij R (⨁ L.mixFun p q) (L.mix p' q') + refine unitBij_biproduct_left R (L.mixFun p q) (L.mix p' q') ?_ + rintro (i | j) + · exact unitBij_mix_right L R (𝟙_ D) + (unitBij_unit_unit R hsc halg hη) + (unitBij_unit_line L R hLU hLR) p' q' + · exact unitBij_mix_right L R L.obj + (unitBij_line_unit L R hLU hLR) + (unitBij_line_line L R hsc halg hη) p' q' + +end Atoms + +/-! ## The free-module functor on mixed sums -/ + +section Fullness + +variable {D : Type u} + +/-- Base change of a morphism corresponds, under the free–forgetful +adjunction, to postcomposition with the free-module unit. -/ +theorem freeModHomEquiv_freeModMap + [Category.{v} D] [MonoidalCategory D] (R : D) [MonObj R] + {V W : D} (f : V ⟶ W) : + freeModHomEquiv R V (freeMod R W) (freeModMap R f) + = f ≫ algUnitHom R W := by + change (λ_ V).inv ≫ (η[R] ▷ V) ≫ (R ◁ f) = f ≫ algUnitHom R W + rw [← Category.assoc] + exact algUnitHom_naturality R f + +/-- **The free-module functor is full on mixed sums.** -/ +theorem exists_preimage_freeModMap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasFiniteBiproducts D] (L : OddLine D) (R : D) + [MonObj R] + (hsc : ∀ f : 𝟙_ D ⟶ 𝟙_ D, ∃ c : ℂ, f = c • 𝟙 (𝟙_ D)) + (hLU : ∀ f : L.obj ⟶ 𝟙_ D, f = 0) + (halg : ∀ f : 𝟙_ D ⟶ R, ∃ c : ℂ, f = c • η[R]) + (hLR : ∀ f : L.obj ⟶ R, f = 0) + (hη : η[R] ≠ 0) (p q p' q' : ℕ) + (g : freeMod R (L.mix p q) ⟶ freeMod R (L.mix p' q')) : + ∃ f : L.mix p q ⟶ L.mix p' q', freeModMap R f = g := by + obtain ⟨f, hf⟩ := (unitBij_mix L R hsc hLU halg hLR hη p q p' q').2 + (freeModHomEquiv R (L.mix p q) (freeMod R (L.mix p' q')) g) + refine ⟨f, ?_⟩ + refine (freeModHomEquiv R (L.mix p q) + (freeMod R (L.mix p' q'))).injective ?_ + rw [freeModHomEquiv_freeModMap] + exact hf + +/-- **The free-module functor is faithful on mixed sums.** -/ +theorem freeModMap_injective_mix + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasFiniteBiproducts D] (L : OddLine D) (R : D) + [MonObj R] + (hsc : ∀ f : 𝟙_ D ⟶ 𝟙_ D, ∃ c : ℂ, f = c • 𝟙 (𝟙_ D)) + (hLU : ∀ f : L.obj ⟶ 𝟙_ D, f = 0) + (halg : ∀ f : 𝟙_ D ⟶ R, ∃ c : ℂ, f = c • η[R]) + (hLR : ∀ f : L.obj ⟶ R, f = 0) + (hη : η[R] ≠ 0) (p q p' q' : ℕ) : + Function.Injective + (fun f : L.mix p q ⟶ L.mix p' q' => freeModMap R f) := by + intro f f' h + have h' : freeModMap R f = freeModMap R f' := h + refine (unitBij_mix L R hsc hLU halg hLR hη p q p' q').1 ?_ + change f ≫ algUnitHom R (L.mix p' q') + = f' ≫ algUnitHom R (L.mix p' q') + rw [← freeModHomEquiv_freeModMap, ← freeModHomEquiv_freeModMap, h'] + +/-- A nonzero algebra unit forces a nonzero identity on the tensor +unit. -/ +theorem id_unit_ne_zero_of_unit + [Category.{v} D] [MonoidalCategory D] [Preadditive D] (R : D) [MonObj R] + (hη : η[R] ≠ 0) : + 𝟙 (𝟙_ D) ≠ 0 := fun h => + hη (by rw [← Category.id_comp η[R], h, Limits.zero_comp]) + +end Fullness + +/-! ## Idempotents of mixed sums split -/ + +section Split + +variable {D : Type u} + +/-- The identity of the line is nonzero as soon as the identity of +the tensor unit is. -/ +theorem OddLine.id_line_ne_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] (L : OddLine D) + (hid : 𝟙 (𝟙_ D) ≠ 0) : + 𝟙 L.obj ≠ 0 := by + intro h + refine hid ?_ + have h2 : 𝟙 (L.obj ⊗ L.obj) = 0 := by + rw [← MonoidalCategory.id_whiskerRight, h, + MonoidalPreadditive.zero_whiskerRight] + have h3 : 𝟙 (𝟙_ D) = L.sq.inv ≫ 𝟙 (L.obj ⊗ L.obj) ≫ L.sq.hom := by + rw [Category.id_comp, Iso.inv_hom_id] + rw [h3, h2, Limits.zero_comp, Limits.comp_zero] + +/-- The entries of a block-diagonal matrix on a mixed sum. -/ +noncomputable def OddLine.mixEntry + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [Linear ℂ D] (L : OddLine D) + {p q p' q' : ℕ} + (A : Matrix (Fin p) (Fin p') ℂ) (B : Matrix (Fin q) (Fin q') ℂ) : + ∀ (j : Fin p ⊕ Fin q) (k : Fin p' ⊕ Fin q'), + L.mixFun p q j ⟶ L.mixFun p' q' k + | Sum.inl i, Sum.inl i' => A i i' • 𝟙 (𝟙_ D) + | Sum.inl _, Sum.inr _ => 0 + | Sum.inr _, Sum.inl _ => 0 + | Sum.inr j, Sum.inr j' => B j j' • 𝟙 L.obj + +/-- A pair of complex matrices as a morphism of mixed sums. -/ +noncomputable def OddLine.mixMat + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [Linear ℂ D] [HasFiniteBiproducts D] (L : OddLine D) + {p q p' q' : ℕ} + (A : Matrix (Fin p) (Fin p') ℂ) (B : Matrix (Fin q) (Fin q') ℂ) : + (⨁ L.mixFun p q) ⟶ (⨁ L.mixFun p' q') := + biproduct.matrix (L.mixEntry A B) + +theorem OddLine.components_mixMat + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [Linear ℂ D] [HasFiniteBiproducts D] (L : OddLine D) + {p q p' q' : ℕ} + (A : Matrix (Fin p) (Fin p') ℂ) (B : Matrix (Fin q) (Fin q') ℂ) + (j : Fin p ⊕ Fin q) (k : Fin p' ⊕ Fin q') : + biproduct.components (L.mixMat A B) j k = L.mixEntry A B j k := + biproduct.matrix_components _ j k + +/-- Scalar multiples of an identity compose by multiplication. -/ +theorem sum_smul_id [Category.{v} D] [Preadditive D] [Linear ℂ D] + {X : D} {J : Type} [Fintype J] (u v : J → ℂ) : + ∑ x : J, (u x • 𝟙 X) ≫ (v x • 𝟙 X) + = (∑ x : J, u x * v x) • 𝟙 X := by + rw [Finset.sum_smul] + refine Finset.sum_congr rfl fun x _ => ?_ + rw [Linear.smul_comp, Linear.comp_smul, Category.id_comp, smul_smul] + +/-- Block-diagonal matrices multiply blockwise. -/ +theorem OddLine.mixEntry_comp + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [Linear ℂ D] (L : OddLine D) + {p q p' q' p'' q'' : ℕ} + (A : Matrix (Fin p) (Fin p') ℂ) (B : Matrix (Fin q) (Fin q') ℂ) + (A' : Matrix (Fin p') (Fin p'') ℂ) + (B' : Matrix (Fin q') (Fin q'') ℂ) + (j : Fin p ⊕ Fin q) (k : Fin p'' ⊕ Fin q'') : + ∑ m : Fin p' ⊕ Fin q', + L.mixEntry A B j m ≫ L.mixEntry A' B' m k + = L.mixEntry (A * A') (B * B') j k := by + rcases j with i | jj <;> rcases k with i2 | j2 <;> + rw [Fintype.sum_sum_type] <;> + simp only [mixEntry, Limits.comp_zero, + Finset.sum_const_zero, add_zero, zero_add, Matrix.mul_apply] + · exact sum_smul_id _ _ + · refine (congrArg₂ (· + ·) ?_ ?_).trans (zero_add 0) + · apply Finset.sum_eq_zero + intro a _ + exact Limits.comp_zero + · apply Finset.sum_eq_zero + intro a _ + exact Limits.zero_comp + · refine (congrArg₂ (· + ·) ?_ ?_).trans (zero_add 0) + · apply Finset.sum_eq_zero + intro a _ + exact Limits.zero_comp + · apply Finset.sum_eq_zero + intro a _ + exact Limits.comp_zero + · exact sum_smul_id _ _ + +/-- Composition of block matrices is matrix multiplication. -/ +theorem OddLine.mixMat_comp + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [Linear ℂ D] [HasFiniteBiproducts D] (L : OddLine D) + {p q p' q' p'' q'' : ℕ} + (A : Matrix (Fin p) (Fin p') ℂ) (B : Matrix (Fin q) (Fin q') ℂ) + (A' : Matrix (Fin p') (Fin p'') ℂ) + (B' : Matrix (Fin q') (Fin q'') ℂ) : + L.mixMat A B ≫ L.mixMat A' B' = L.mixMat (A * A') (B * B') := by + refine hom_ext_components _ _ fun j k => ?_ + rw [components_comp] + simp only [components_mixMat] + exact L.mixEntry_comp A B A' B' j k + +/-- The identity matrices give the identity morphism. -/ +theorem OddLine.mixMat_one + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [Linear ℂ D] [HasFiniteBiproducts D] (L : OddLine D) + (p q : ℕ) : + L.mixMat (1 : Matrix (Fin p) (Fin p) ℂ) + (1 : Matrix (Fin q) (Fin q) ℂ) = 𝟙 (⨁ L.mixFun p q) := by + refine hom_ext_components _ _ fun j k => ?_ + rw [components_mixMat] + by_cases h : j = k + · subst h + rw [components_id_self] + rcases j with i | jj + · change (1 : Matrix (Fin p) (Fin p) ℂ) i i • 𝟙 (𝟙_ D) = 𝟙 (𝟙_ D) + rw [Matrix.one_apply_eq, one_smul] + · change (1 : Matrix (Fin q) (Fin q) ℂ) jj jj • 𝟙 L.obj = 𝟙 L.obj + rw [Matrix.one_apply_eq, one_smul] + · rw [components_id_ne h] + rcases j with i | jj + · rcases k with i2 | j2 + · have hne : i ≠ i2 := fun hh => h (by rw [hh]) + change (1 : Matrix (Fin p) (Fin p) ℂ) i i2 • 𝟙 (𝟙_ D) = 0 + rw [Matrix.one_apply_ne hne, zero_smul] + · rfl + · rcases k with i2 | j2 + · rfl + · have hne : jj ≠ j2 := fun hh => h (by rw [hh]) + change (1 : Matrix (Fin q) (Fin q) ℂ) jj j2 • 𝟙 L.obj = 0 + rw [Matrix.one_apply_ne hne, zero_smul] + +/-- **Every endomorphism of a mixed sum is a pair of complex +matrices.** -/ +theorem OddLine.exists_mixMat + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasFiniteBiproducts D] (L : OddLine D) + (hsc : ∀ f : 𝟙_ D ⟶ 𝟙_ D, ∃ c : ℂ, f = c • 𝟙 (𝟙_ D)) + (hLU : ∀ f : L.obj ⟶ 𝟙_ D, f = 0) + {p q : ℕ} (e : (⨁ L.mixFun p q) ⟶ (⨁ L.mixFun p q)) : + ∃ (A : Matrix (Fin p) (Fin p) ℂ) (B : Matrix (Fin q) (Fin q) ℂ), + e = L.mixMat A B := by + choose A hA using fun i i' : Fin p => + hsc (biproduct.components e (Sum.inl i) (Sum.inl i')) + choose B hB using fun j j' : Fin q => + L.hom_line_scalar hsc + (biproduct.components e (Sum.inr j) (Sum.inr j')) + refine ⟨A, B, hom_ext_components _ _ fun j k => ?_⟩ + erw [components_mixMat] + rcases j with i | jj + · rcases k with i2 | j2 + · exact hA i i2 + · exact L.hom_unit_line_eq_zero hLU _ + · rcases k with i2 | j2 + · exact hLU _ + · exact hB jj j2 + +/-- The pair of matrices is determined by the morphism. -/ +theorem OddLine.mixMat_injective + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [HasFiniteBiproducts D] (L : OddLine D) + (hid : 𝟙 (𝟙_ D) ≠ 0) + {p q p' q' : ℕ} {A A' : Matrix (Fin p) (Fin p') ℂ} + {B B' : Matrix (Fin q) (Fin q') ℂ} + (h : L.mixMat A B = L.mixMat A' B') : A = A' ∧ B = B' := by + constructor + · ext i i' + have h2 : L.mixEntry A B (Sum.inl i) (Sum.inl i') + = L.mixEntry A' B' (Sum.inl i) (Sum.inl i') := by + rw [← L.components_mixMat, ← L.components_mixMat, h] + exact smul_left_cancel_of_ne_zero hid h2 + · ext j j' + have h2 : L.mixEntry A B (Sum.inr j) (Sum.inr j') + = L.mixEntry A' B' (Sum.inr j) (Sum.inr j') := by + rw [← L.components_mixMat, ← L.components_mixMat, h] + exact smul_left_cancel_of_ne_zero (L.id_line_ne_zero hid) h2 + +/-- **An idempotent endomorphism of a mixed sum splits off a mixed +sum.** -/ +theorem exists_split_of_idem_mix + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasFiniteBiproducts D] (L : OddLine D) + (hsc : ∀ f : 𝟙_ D ⟶ 𝟙_ D, ∃ c : ℂ, f = c • 𝟙 (𝟙_ D)) + (hLU : ∀ f : L.obj ⟶ 𝟙_ D, f = 0) (hid : 𝟙 (𝟙_ D) ≠ 0) + {p q : ℕ} (e : L.mix p q ⟶ L.mix p q) (he : e ≫ e = e) : + ∃ (p' q' : ℕ) (a : L.mix p' q' ⟶ L.mix p q) + (b : L.mix p q ⟶ L.mix p' q'), + a ≫ b = 𝟙 (L.mix p' q') ∧ b ≫ a = e := by + obtain ⟨A, B, hAB⟩ := L.exists_mixMat hsc hLU e + have hidem : L.mixMat (A * A) (B * B) = L.mixMat A B := by + rw [← L.mixMat_comp, ← hAB] + exact he + obtain ⟨hAA, hBB⟩ := L.mixMat_injective hid hidem + obtain ⟨p', S, T, hST, hTS⟩ := exists_split_of_matrix_idem A hAA + obtain ⟨q', S', T', hST', hTS'⟩ := exists_split_of_matrix_idem B hBB + have h1 : L.mixMat T T' ≫ L.mixMat S S' + = 𝟙 (⨁ L.mixFun p' q') := by + rw [L.mixMat_comp, hTS, hTS'] + exact L.mixMat_one p' q' + have h2 : L.mixMat S S' ≫ L.mixMat T T' = e := by + rw [L.mixMat_comp, hST, hST'] + exact hAB.symm + exact ⟨p', q', L.mixMat T T', L.mixMat S S', h1, h2⟩ + +end Split + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeTwistPi.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeTwistPi.lean new file mode 100644 index 0000000000..4195f4a8ab --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeTwistPi.lean @@ -0,0 +1,107 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPair +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistFreeTensor + +/-! +# The free factor on the projection + +The relative tensor of a free module with a module is the twist of +that module by the generating object, `RS.freeTensorTwistIso`. +This file computes that comparison on the canonical projection: it +carries the algebra past the generator, reassociates, and acts. + +* `modTensorπ_freeTensorTwistIso`: the projection formula. +* `freeTensorTwistIso_gpair`: the same statement for the pairing + `RS.gpair`, which is the form the comparison map of the Γ-modules + consumes. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- The coherence behind the projection formula: crossing the +generator, interchanging against the unit factor and collapsing +the resulting right unitor is the crossing followed by the +reassociation. The interchange meets the tensor unit, so its +braiding is a pair of unitors. -/ +theorem freeTwistInterchange + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + (V X : D) : + ((β_ A V).hom ⊗ₘ (λ_ X).inv) ≫ tensorμ V A (𝟙_ D) X ≫ + ((ρ_ V).hom ▷ (A ⊗ X)) = + ((β_ A V).hom ▷ X) ≫ (α_ V A X).hom := by + rw [tensorμ, braiding_tensorUnit_right] + simp only [tensorHom_def, Category.assoc] + monoidal + +/-- **The free factor on the projection**: the isomorphism +identifying the relative tensor of a free module with the twist of +the module carries the projection to the crossing of the algebra +past the generator, followed by the action. -/ +theorem modTensorπ_freeTensorTwistIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (V : D) (M : Mod D A) : + modTensorπ A (freeMod A V) M ≫ + (freeTensorTwistIso A V M).hom.hom = + ((β_ A V).hom ▷ M.X) ≫ (α_ V A M.X).hom ≫ + (V ◁ actLeft A M.X) := by + have hπ : modTensorπ A (regularMod A) M ≫ + (modTensorUnitLeft A M).hom = actLeft A M.X := + modTensorπ_desc A (regularMod A) M _ _ + change modTensorπ A (freeMod A V) M ≫ + modTensorMap A (freeRegTwistIso A V).hom + (tensorLeftUnitMod A M).symm.hom ≫ + twistShuffleHom A V (𝟙_ D) (regularMod A) M ≫ + ((ρ_ V).hom ▷ modTensor A (regularMod A) M) ≫ + (V ◁ (modTensorUnitLeft A M).hom) = + ((β_ A V).hom ▷ M.X) ≫ (α_ V A M.X).hom ≫ + (V ◁ actLeft A M.X) + rw [modTensorπ_map_assoc, modTensorπ_twistShuffleHom_assoc] + change ((β_ A V).hom ⊗ₘ (λ_ M.X).inv) ≫ + (tensorμ V A (𝟙_ D) M.X ≫ + ((V ⊗ 𝟙_ D) ◁ modTensorπ A (regularMod A) M)) ≫ + ((ρ_ V).hom ▷ modTensor A (regularMod A) M) ≫ + (V ◁ (modTensorUnitLeft A M).hom) = + ((β_ A V).hom ▷ M.X) ≫ (α_ V A M.X).hom ≫ + (V ◁ actLeft A M.X) + simp only [Category.assoc] + rw [whisker_exchange_assoc, ← MonoidalCategory.whiskerLeft_comp, + hπ, reassoc_of% freeTwistInterchange A V M.X] + +/-- **The free factor on the pairing**: the pairing `RS.gpair` of a +morphism into a free module with a morphism into a module is, after +the identification of the relative tensor with the twist, the +tensor of the two morphisms followed by the crossing and the +action. -/ +theorem freeTensorTwistIso_gpair + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (V : D) (M : Mod D A) + {X Y : D} (m : X ⟶ A ⊗ V) + (n : Y ⟶ M.X) : + gpair (M := freeMod A V) (N := M) m n ≫ + (freeTensorTwistIso A V M).hom.hom = + (m ⊗ₘ n) ≫ ((β_ A V).hom ▷ M.X) ≫ (α_ V A M.X).hom ≫ + (V ◁ actLeft A M.X) := by + erw [gpair_def, Category.assoc] + exact whisker_eq _ (modTensorπ_freeTensorTwistIso A V M) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaAlgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaAlgebra.lean new file mode 100644 index 0000000000..0b9996b12a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaAlgebra.lean @@ -0,0 +1,310 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLinePairing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperRealize + +/-! +# The Γ-algebra of a commutative monoid object + +A commutative monoid object `R` of a symmetric ℂ-linear monoidal +category `D` equipped with an odd line `L` realizes as a +super-commutative ℂ-algebra (`RS.SuperCommAlgebra`): the even part +is `𝟙_ D ⟶ R`, the odd part is `L.obj ⟶ R`, and the four graded +multiplication blocks are the convolution product of the monoid +sandwiched between the coherence isomorphisms that identify the +sources. + +Everything rests on one ungraded operation, `RS.gmul`: the +convolution `(a ⊗ₘ b) ≫ μ` of two morphisms into `R` at +*arbitrary* sources. Its three structural laws — associativity up +to the associator (`RS.gmul_assoc`), the two unit laws +(`RS.gmul_one_left`, `RS.gmul_one_right`) and commutativity up to +the braiding (`RS.gmul_comm`) — hold once and for all, and each of +the thirteen axioms of `RS.SuperCommAlgebra` is one of them +conjugated by coherence isomorphisms. The Koszul sign is the sole +place where the odd line enters: `RS.gmul_comm` produces the +self-braiding of `L.obj`, which `RS.OddLine.braid_neg` identifies +with `-𝟙`. + +The odd-odd-odd associativity is the one axiom not implied by +coherence alone: it is the first triangle identity of the +self-duality of the odd line, `RS.OddLine.evaluation_coevaluation`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open scoped MonObj + +universe v u + +/-! ## Ungraded convolution -/ + +section Convolution + +variable {D : Type u} + +/-- The *convolution product* of two morphisms into a monoid +object, taken at arbitrary sources: tensor the two morphisms and +multiply. -/ +noncomputable def gmul [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] + {X Y : D} (a : X ⟶ R) (b : Y ⟶ R) : + X ⊗ Y ⟶ R := + (a ⊗ₘ b) ≫ μ + +/-- Convolution unfolded. -/ +theorem gmul_def [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] + {X Y : D} (a : X ⟶ R) (b : Y ⟶ R) : + gmul a b = (a ⊗ₘ b) ≫ μ[R] := rfl + +/-- Reindexing the left source of a convolution. -/ +theorem comp_gmul [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] + {W X Y : D} (f : W ⟶ X) (a : X ⟶ R) + (b : Y ⟶ R) : gmul (f ≫ a) b = f ▷ Y ≫ gmul a b := by + have h : f ▷ Y ≫ (a ⊗ₘ b) = (f ≫ a) ⊗ₘ b := by + rw [← tensorHom_id, tensorHom_comp_tensorHom, Category.id_comp] + rw [gmul_def, gmul_def, ← h, Category.assoc] + +/-- Reindexing the right source of a convolution. -/ +theorem gmul_comp [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] + {X Y Z : D} (a : X ⟶ R) (g : Z ⟶ Y) + (b : Y ⟶ R) : gmul a (g ≫ b) = X ◁ g ≫ gmul a b := by + have h : X ◁ g ≫ (a ⊗ₘ b) = a ⊗ₘ (g ≫ b) := by + rw [← id_tensorHom, tensorHom_comp_tensorHom, Category.id_comp] + rw [gmul_def, gmul_def, ← h, Category.assoc] + +/-- **Convolution is associative**, up to the associator of the +three sources. -/ +theorem gmul_assoc [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] + {X Y Z : D} (a : X ⟶ R) (b : Y ⟶ R) + (c : Z ⟶ R) : + gmul (gmul a b) c = (α_ X Y Z).hom ≫ gmul a (gmul b c) := by + have hl : ((a ⊗ₘ b) ⊗ₘ c) ≫ (μ[R] ▷ R) ≫ μ[R] = + gmul (gmul a b) c := by + rw [← Category.assoc, ← tensorHom_id, tensorHom_comp_tensorHom, + Category.comp_id] + rfl + have hr : (a ⊗ₘ (b ⊗ₘ c)) ≫ (R ◁ μ[R]) ≫ μ[R] = + gmul a (gmul b c) := by + rw [← Category.assoc, ← id_tensorHom, tensorHom_comp_tensorHom, + Category.comp_id] + rfl + rw [← hl, ← hr, MonObj.mul_assoc R, ← Category.assoc, + associator_naturality, Category.assoc] + +/-- The monoid unit is a left unit for convolution. -/ +theorem gmul_one_left [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] + {Y : D} (b : Y ⟶ R) : + gmul (η[R]) b = (λ_ Y).hom ≫ b := by + rw [gmul_def, tensorHom_def', Category.assoc, MonObj.one_mul, + leftUnitor_naturality] + +/-- The monoid unit is a right unit for convolution. -/ +theorem gmul_one_right [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] + {X : D} (a : X ⟶ R) : + gmul a (η[R]) = (ρ_ X).hom ≫ a := by + rw [gmul_def, tensorHom_def, Category.assoc, MonObj.mul_one, + rightUnitor_naturality] + +/-- **Convolution against a commutative monoid object is +commutative**, up to the braiding of the two sources. -/ +theorem gmul_comm [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] + [BraidedCategory D] [IsCommMonObj R] {X Y : D} + (a : X ⟶ R) (b : Y ⟶ R) : + gmul a b = (β_ X Y).hom ≫ gmul b a := by + rw [gmul_def, gmul_def] + conv_lhs => rw [← IsCommMonObj.mul_comm R] + rw [BraidedCategory.braiding_naturality_assoc] + +section Additive + +/-- Convolution is additive in its left argument. -/ +theorem add_gmul + [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] [Preadditive D] + [MonoidalPreadditive D] + {X Y : D} (a a' : X ⟶ R) (b : Y ⟶ R) : + gmul (a + a') b = gmul a b + gmul a' b := by + rw [gmul_def, gmul_def, gmul_def, MonoidalPreadditive.add_tensor, + Preadditive.add_comp] + +/-- Convolution is additive in its right argument. -/ +theorem gmul_add + [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] [Preadditive D] + [MonoidalPreadditive D] + {X Y : D} (a : X ⟶ R) (b b' : Y ⟶ R) : + gmul a (b + b') = gmul a b + gmul a b' := by + rw [gmul_def, gmul_def, gmul_def, MonoidalPreadditive.tensor_add, + Preadditive.add_comp] + +end Additive + +section Homogeneous + +/-- Convolution is ℂ-homogeneous in its left argument. -/ +theorem smul_gmul + [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] [Preadditive D] + [MonoidalPreadditive D] [Linear ℂ D] [MonoidalLinear ℂ D] + (r : ℂ) {X Y : D} (a : X ⟶ R) (b : Y ⟶ R) : + gmul (r • a) b = r • gmul a b := by + have h : (r • a) ⊗ₘ b = r • (a ⊗ₘ b) := by + rw [tensorHom_def, tensorHom_def, + MonoidalLinear.smul_whiskerRight, Linear.smul_comp] + rw [gmul_def, gmul_def, h, Linear.smul_comp] + +/-- Convolution is ℂ-homogeneous in its right argument. -/ +theorem gmul_smul + [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] [Preadditive D] + [MonoidalPreadditive D] [Linear ℂ D] [MonoidalLinear ℂ D] + (r : ℂ) {X Y : D} (a : X ⟶ R) (b : Y ⟶ R) : + gmul a (r • b) = r • gmul a b := by + have h : a ⊗ₘ (r • b) = r • (a ⊗ₘ b) := by + rw [tensorHom_def', tensorHom_def', + MonoidalLinear.whiskerLeft_smul, Linear.smul_comp] + rw [gmul_def, gmul_def, h, Linear.smul_comp] + +end Homogeneous + +/-! ### The bundled bilinear convolution -/ + +section Bundled + +/-- The convolution product as a ℂ-bilinear map of hom-modules, +transported along a chosen morphism `s` from the intended source +into the tensor product of the two given sources. The four graded +multiplication blocks of `RS.gammaAlgebra` are the four instances +of this construction. -/ +noncomputable def gmulLin + [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] [Preadditive D] + [MonoidalPreadditive D] [Linear ℂ D] [MonoidalLinear ℂ D] + {W X Y : D} (s : W ⟶ X ⊗ Y) : + (X ⟶ R) →ₗ[ℂ] (Y ⟶ R) →ₗ[ℂ] (W ⟶ R) := + LinearMap.mk₂ ℂ (fun a b => s ≫ gmul a b) + (fun a a' b => by rw [add_gmul, Preadditive.comp_add]) + (fun r a b => by rw [smul_gmul, Linear.comp_smul]) + (fun a b b' => by rw [gmul_add, Preadditive.comp_add]) + (fun r a b => by rw [gmul_smul, Linear.comp_smul]) + +@[simp] +theorem gmulLin_apply + [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] [Preadditive D] + [MonoidalPreadditive D] [Linear ℂ D] [MonoidalLinear ℂ D] + {W X Y : D} (s : W ⟶ X ⊗ Y) (a : X ⟶ R) + (b : Y ⟶ R) : gmulLin s a b = s ≫ gmul a b := rfl + +/-- **The transported associativity law**: given a coherence +identity between the two ways of reassociating the chosen sources, +the two bracketings of a triple convolution agree. -/ +theorem gmulLin_assoc + [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] [Preadditive D] + [MonoidalPreadditive D] [Linear ℂ D] [MonoidalLinear ℂ D] + {W W' V X Y Z : D} (s₁ : W' ⟶ W ⊗ Z) + (s₂ : W ⟶ X ⊗ Y) (s₃ : W' ⟶ X ⊗ V) (s₄ : V ⟶ Y ⊗ Z) + (h : s₁ ≫ s₂ ▷ Z ≫ (α_ X Y Z).hom = s₃ ≫ X ◁ s₄) + (a : X ⟶ R) (b : Y ⟶ R) (c : Z ⟶ R) : + gmulLin s₁ (gmulLin s₂ a b) c + = gmulLin s₃ a (gmulLin s₄ b c) := by + simp only [gmulLin_apply] + rw [comp_gmul, gmul_assoc, gmul_comp, reassoc_of% h] + +end Bundled + +end Convolution + +/-! ## The super-commutative algebra of a commutative monoid -/ + +/-- **The Γ-algebra of a commutative monoid object**: for a +commutative monoid object `R` of a symmetric ℂ-linear monoidal +category carrying an odd line `L`, the morphisms `𝟙_ D ⟶ R` and +`L.obj ⟶ R` form a super-commutative ℂ-algebra under convolution. + +The four blocks are the convolution product conjugated by the +coherence isomorphisms that identify each source with a tensor +product of the two sources involved: the left unitor for +even-even and even-odd, the right unitor for odd-even, and the +square trivialisation `L.sq` of the odd line for odd-odd. The +Koszul sign of `comm_oo` is exactly `RS.OddLine.braid_neg`. -/ +noncomputable def gammaAlgebra (D : Type u) [Category.{v} D] + [MonoidalCategory D] [SymmetricCategory D] [Preadditive D] + [MonoidalPreadditive D] [Linear ℂ D] [MonoidalLinear ℂ D] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] : + SuperCommAlgebra where + even := 𝟙_ D ⟶ R + odd := L.obj ⟶ R + one := η[R] + mulEE := gmulLin (R := R) (λ_ (𝟙_ D)).inv + mulEO := gmulLin (R := R) (λ_ L.obj).inv + mulOE := gmulLin (R := R) (ρ_ L.obj).inv + mulOO := gmulLin (R := R) L.sq.inv + one_mul_e x := by + rw [gmulLin_apply, gmul_one_left, Iso.inv_hom_id_assoc] + one_mul_o u := by + rw [gmulLin_apply, gmul_one_left, Iso.inv_hom_id_assoc] + assoc_eee x y z := by + refine gmulLin_assoc _ _ _ _ ?_ x y z + monoidal + assoc_eeo x y u := by + refine gmulLin_assoc _ _ _ _ ?_ x y u + monoidal + assoc_eoe x u y := by + refine gmulLin_assoc _ _ _ _ ?_ x u y + monoidal + assoc_eoo x u v := by + refine gmulLin_assoc _ _ _ _ ?_ x u v + have hc : (λ_ L.obj).inv ▷ L.obj ≫ + (α_ (𝟙_ D) L.obj L.obj).hom = + (λ_ (L.obj ⊗ L.obj)).inv := by monoidal + rw [hc] + exact leftUnitor_inv_naturality L.sq.inv + assoc_oee u x y := by + refine gmulLin_assoc _ _ _ _ ?_ u x y + monoidal + assoc_oeo u x v := by + refine gmulLin_assoc _ _ _ _ ?_ u x v + have hc : (ρ_ L.obj).inv ▷ L.obj ≫ + (α_ L.obj (𝟙_ D) L.obj).hom = + L.obj ◁ (λ_ L.obj).inv := by monoidal + rw [hc] + assoc_ooe u v y := by + refine gmulLin_assoc _ _ _ _ ?_ u v y + have hc : (ρ_ (L.obj ⊗ L.obj)).inv ≫ + (α_ L.obj L.obj (𝟙_ D)).hom = + L.obj ◁ (ρ_ L.obj).inv := by monoidal + rw [unitors_inv_equal, ← Category.assoc, + ← rightUnitor_inv_naturality, Category.assoc, hc] + assoc_ooo u v w := by + refine gmulLin_assoc _ _ _ _ ?_ u v w + have h2 : L.sq.inv ▷ L.obj ≫ (α_ L.obj L.obj L.obj).hom = + (λ_ L.obj).hom ≫ (ρ_ L.obj).inv ≫ + L.obj ◁ L.sq.inv := by + rw [← reassoc_of% L.evaluation_coevaluation, + ← MonoidalCategory.whiskerLeft_comp, Iso.hom_inv_id, + MonoidalCategory.whiskerLeft_id, Category.comp_id] + rw [h2, ← Category.assoc, Iso.inv_hom_id, Category.id_comp] + comm_ee x y := by + have hb : (λ_ (𝟙_ D)).inv ≫ (β_ (𝟙_ D) (𝟙_ D)).hom = + (λ_ (𝟙_ D)).inv := by + rw [← cancel_mono (ρ_ (𝟙_ D)).hom, Category.assoc, + braiding_rightUnitor, ← unitors_equal] + rw [gmulLin_apply, gmulLin_apply, gmul_comm x y, ← Category.assoc, + hb] + comm_eo x u := by + have hb : (λ_ L.obj).inv ≫ (β_ (𝟙_ D) L.obj).hom = + (ρ_ L.obj).inv := by + rw [← cancel_mono (ρ_ L.obj).hom, Category.assoc, + braiding_rightUnitor, Iso.inv_hom_id, Iso.inv_hom_id] + rw [gmulLin_apply, gmulLin_apply, gmul_comm x u, ← Category.assoc, + hb] + comm_oo u v := by + rw [gmulLin_apply, gmulLin_apply, gmul_comm u v, L.braid_neg, + Preadditive.neg_comp, Category.id_comp, + Preadditive.comp_neg] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaBiprod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaBiprod.lean new file mode 100644 index 0000000000..7337ddb72a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaBiprod.lean @@ -0,0 +1,105 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModIso +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod + +/-! +# Realization of a biproduct of module objects + +Morphisms out of the two generators into a biproduct are pairs of +morphisms, and the action on a biproduct is componentwise, so the +realization of a biproduct is the biproduct of the realizations. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {D : Type u} + +/-- The comparison of the realization of a biproduct with the +biproduct of the realizations. -/ +noncomputable def gammaBiprodMap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] [HasBinaryBiproducts D] (L : OddLine D) (R : D) + [MonObj R] [IsCommMonObj R] (M : Mod D R) (N : Mod D R) : + gammaModule D L R (modBiprod R M N).X ⟶ + (gammaModule D L R M.X).biprod + (gammaModule D L R N.X) := by + haveI : IsModHom R (show (modBiprod R M N).X ⟶ M.X from + biprod.fst) := (modBiprodFst R M N).isModHom + haveI : IsModHom R (show (modBiprod R M N).X ⟶ N.X from + biprod.snd) := (modBiprodSnd R M N).isModHom + exact + { evenMap := LinearMap.prod + (Linear.rightComp ℂ _ + (show (modBiprod R M N).X ⟶ M.X from biprod.fst)) + (Linear.rightComp ℂ _ + (show (modBiprod R M N).X ⟶ N.X from biprod.snd)) + oddMap := LinearMap.prod + (Linear.rightComp ℂ _ + (show (modBiprod R M N).X ⟶ M.X from biprod.fst)) + (Linear.rightComp ℂ _ + (show (modBiprod R M N).X ⟶ N.X from biprod.snd)) + map_actEE := fun x m => by + refine Prod.ext ?_ ?_ <;> + exact (Category.assoc _ _ _).trans + (congrArg _ (gact_naturality R _ x m)) + map_actEO := fun x m => by + refine Prod.ext ?_ ?_ <;> + exact (Category.assoc _ _ _).trans + (congrArg _ (gact_naturality R _ x m)) + map_actOE := fun u m => by + refine Prod.ext ?_ ?_ <;> + exact (Category.assoc _ _ _).trans + (congrArg _ (gact_naturality R _ u m)) + map_actOO := fun u m => by + refine Prod.ext ?_ ?_ <;> + exact (Category.assoc _ _ _).trans + (congrArg _ (gact_naturality R _ u m)) } + +/-- Morphisms into a binary biproduct are pairs, ℂ-linearly. -/ +theorem bijective_pair [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (R : D) [MonObj R] (M : Mod D R) (N : Mod D R) + (P : D) : + Function.Bijective + (fun f : P ⟶ M.X ⊞ N.X => + ((f ≫ biprod.fst, f ≫ biprod.snd) : + (P ⟶ M.X) × (P ⟶ N.X))) := by + constructor + · intro f g h + refine biprod.hom_ext _ _ ?_ ?_ + · exact congrArg Prod.fst h + · exact congrArg Prod.snd h + · intro p + refine ⟨biprod.lift p.1 p.2, ?_⟩ + refine Prod.ext ?_ ?_ + · exact biprod.lift_fst _ _ + · exact biprod.lift_snd _ _ + +/-- **The realization of a biproduct is the biproduct of the +realizations.** -/ +noncomputable def gammaBiprodIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] [HasBinaryBiproducts D] (L : OddLine D) (R : D) + [MonObj R] [IsCommMonObj R] (M : Mod D R) (N : Mod D R) : + gammaModule D L R (modBiprod R M N).X ≅ + (gammaModule D L R M.X).biprod + (gammaModule D L R N.X) := + SuperCommAlgebra.Mod.isoOfComponents (gammaBiprodMap L R M N) + (bijective_pair R M N (𝟙_ D)) (bijective_pair R M N L.obj) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaComplex.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaComplex.lean new file mode 100644 index 0000000000..1231cc8c82 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaComplex.lean @@ -0,0 +1,64 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleScalars +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PresentedQuotient + +/-! +# The scalars of a simple countably presented algebra are complex + +The even part of the Γ-algebra of a simple algebra is a field, and a +quotient of a countably presented ind-object is countably presented, +so that field has countable dimension over the complex numbers. A +field extension of the complex numbers of countable dimension is the +complex numbers, so every scalar is a complex multiple of the unit. + +Together with the vanishing of the odd part this is exactly the pair +of hypotheses that `RS/Classical/Deligne/FreeSummand.lean` consumes: +the free-module functor is then full and faithful on the mixed +objects, and idempotents split with free image. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v + +variable {C : Type v} + +/-- **The scalars of a simple countably presented algebra are the +complex numbers.** The algebra is presented as a quotient of a +countably presented one, which is how the countable descent delivers +it. -/ +theorem exists_smul_one_of_simple_of_epi + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] [CategoryTheory.Linear ℂ C] + [MonoidalLinear ℂ C] [CategoryTheory.Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] + (hu : HasScalarUnit C) + (hsmul : IndOfLinear C) (hlen : ∀ Z : C, ∃ N : ℕ, LengthLE Z N) + (L : OddLine (Ind C)) {𝔸 𝔹 : Ind C} [MonObj 𝔹] + [IsCommMonObj 𝔹] (π : 𝔸 ⟶ 𝔹) [Epi π] + (hcp : CountablyPresented 𝔸) (hne : η[𝔹] ≠ 0) + (hsimple : ∀ I : Subobject 𝔹, IsIdeal 𝔹 I → I = ⊥ ∨ I = ⊤) + (g : 𝟙_ (Ind C) ⟶ 𝔹) : ∃ c : ℂ, g = c • η[𝔹] := by + let : Field ((gammaAlgebra (Ind C) L 𝔹).even) := + gammaEvenField 𝔹 L hsimple hne + have hrank : + Module.rank ℂ ((gammaAlgebra (Ind C) L 𝔹).even) ≤ Cardinal.aleph0 := + rank_hom_unit_le_aleph0_of_epi hu hsmul hlen π hcp + obtain ⟨c, hc⟩ := + exists_smul_one_of_countable_dimension + ((gammaAlgebra (Ind C) L 𝔹).even) hrank g + exact ⟨c, hc⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaCountable.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaCountable.lean new file mode 100644 index 0000000000..ae582b4694 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaCountable.lean @@ -0,0 +1,630 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableNullstellensatz +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.HomFinite +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEvenRing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UniversalAlgebra + +/-! +# Countable dimension of the Γ-algebra + +The descent to the complex numbers of Deligne's Proposition 4.5 +consumes a ℂ-point of the Γ-algebra of the universal algebra, and the +countable Nullstellensatz +(`RS.exists_algHom_of_countable_dimension`) supplies one as soon as +the even component has at most countable dimension. This file +establishes that dimension count for the algebras built by the +tensor-product device of Deligne 2.11 over a countable index family. + +The route is the compactness of the unit in the ind-completion. The +big tensor product of a family of algebras is, by construction, the +filtered colimit of the finite sub-tensor-products +(`RS.bigTensor`), and a morphism out of the unit into a filtered +colimit factors through a stage +(`RS.exists_factor_of_unit_hom_colimit`). So the even component +`𝟙 ⟶ bigTensor B` is the union of the images of the even components +of the stages; over a countable index family there are only countably +many stages, and a countable union of subspaces of at most countable +dimension has at most countable dimension. + +The finite stages are the tensor words of the family, and they are +handled by the same one-variable colimit lemma. Call an object of +the ind-completion *countably presented* (`RS.CountablyPresented`) +when it is a countable filtered colimit of embedded objects — the +precise sense of "built from countably much data". Tensoring +preserves the colimits of the ind-completion, and the embedding is +monoidal, so a countably presented factor of a tensor word can be +absorbed one stage at a time +(`RS.rank_hom_unit_tensor_presented`), leaving tensor words against +an embedded object; those are finite dimensional by finite length +(`RS.finiteDimensional_hom_unit`). Induction along the word +(`RS.rank_hom_unit_listTensor_le_aleph0`) needs no product of index +categories. + +Two hypotheses are carried explicitly, because the ambient linear +structure on the ind-completion is itself a hypothesis of this +development and neither follows from it: ℂ-linearity of the +embedding `C ⥤ Ind C` (`RS.IndOfLinear`), and finite length of every +object of `C`. + +The conclusion is packaged three ways: as a dimension count for the +common extension of a countable family +(`RS.exists_common_algebra_rank_le_aleph0_of_presented`), as the same +count for the universal algebra of Deligne 2.11 over countable index +families (`RS.exists_universal_algebra_rank_le_aleph0`), and, through +the countable Nullstellensatz, as a ℂ-point of the Γ-algebra +(`RS.nonempty_superPoint_gammaAlgebra`). +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +/-! ## A countable union of small subspaces is small + +Pure linear algebra: a module covered by countably many subspaces of +at most countable dimension has at most countable dimension. Choose +a basis of each piece; the union of the bases is a countable spanning +set. -/ + +section CountableRank + +variable {K : Type*} + +/-- **A countable union of subspaces of countable dimension has +countable dimension**: the union of chosen bases of the pieces is a +countable spanning set. -/ +theorem rank_le_aleph0_of_countable_cover + [DivisionRing K] {M : Type*} [AddCommGroup M] [Module K M] + {I : Type*} [Countable I] + (p : I → Submodule K M) + (hp : ∀ i, Module.rank K (p i) ≤ Cardinal.aleph0) + (hcover : ∀ x : M, ∃ i, x ∈ p i) : + Module.rank K M ≤ Cardinal.aleph0 := by + classical + set b : ∀ i, Module.Basis (Module.Free.ChooseBasisIndex K (p i)) + K (p i) := fun i => Module.Free.chooseBasis K (p i) + have hcnt : ∀ i, Countable (Module.Free.ChooseBasisIndex K (p i)) := + fun i => Cardinal.mk_le_aleph0_iff.mp (by + rw [← Module.Free.rank_eq_card_chooseBasisIndex] + exact hp i) + set s : I → Set M := + fun i => Set.range (fun t => ((b i t : p i) : M)) with hs + have hspan : ∀ i, p i = Submodule.span K (s i) := by + intro i + have h1 : Submodule.map (p i).subtype + (Submodule.span K (Set.range (b i))) = + Submodule.span K (s i) := by + rw [Submodule.map_span, hs] + exact congrArg (Submodule.span K) (Set.range_comp _ _).symm + rwa [(b i).span_eq, Submodule.map_top, Submodule.range_subtype] + at h1 + have hcS : (⋃ i, s i).Countable := by + have := hcnt + exact Set.countable_iUnion fun i => Set.countable_range _ + have htopS : Submodule.span K (⋃ i, s i) = ⊤ := by + rw [Submodule.span_iUnion] + refine eq_top_iff.mpr fun x _ => ?_ + obtain ⟨i, hi⟩ := hcover x + exact Submodule.mem_iSup_of_mem i (by rw [← hspan i]; exact hi) + have hrk := rank_span_le (R := K) (⋃ i, s i) + rw [htopS, rank_top] at hrk + exact hrk.trans (Cardinal.le_aleph0_iff_set_countable.mpr hcS) + +end CountableRank + +/-! ## Countable filtered colimits in the ind-completion + +The unit of the ind-completion is compact: a morphism out of it into +a filtered colimit factors through a stage. So the even component of +a filtered colimit is the union of the images of the even components +of the stages, and over a countable diagram the previous section +applies. -/ + +section IndColimit + +variable {C : Type v} + +/-- **A countable filtered colimit of objects with countable even +component again has countable even component.** Compactness of the +unit (`RS.exists_factor_of_unit_hom_colimit`) covers `𝟙 ⟶ colimit D` +by the countably many images of the `𝟙 ⟶ D.obj i`. -/ +theorem rank_hom_unit_colimit_le_aleph0 + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ (Ind C)] + {I : Type v} [SmallCategory I] + [IsFiltered I] [Countable I] (D : I ⥤ Ind C) + (h : ∀ i : I, + Module.rank ℂ (𝟙_ (Ind C) ⟶ D.obj i) ≤ Cardinal.aleph0) : + Module.rank ℂ (𝟙_ (Ind C) ⟶ colimit D) ≤ Cardinal.aleph0 := by + refine rank_le_aleph0_of_countable_cover + (fun i => LinearMap.range + (Linear.rightComp ℂ (𝟙_ (Ind C)) (colimit.ι D i))) + (fun i => ?_) (fun f => ?_) + · exact le_trans (LinearMap.rank_le_of_surjective _ + (Linear.rightComp ℂ (𝟙_ (Ind C)) + (colimit.ι D i)).surjective_rangeRestrict) (h i) + · obtain ⟨i, g, hg⟩ := exists_factor_of_unit_hom_colimit D f + exact ⟨i, LinearMap.mem_range.mpr ⟨g, hg⟩⟩ + +end IndColimit + +/-! ## The big tensor product over a countable index family + +The big tensor product is the filtered colimit of its finite +sub-tensor-products, indexed by the finite subsets of the index +family. Over a countable family there are only countably many of +those, so the even component is of at most countable dimension as +soon as each finite stage is. -/ + +section BigTensorRank + +variable {C : Type v} + +/-- **The big tensor product of a countable family has countable +even component**, provided each finite sub-tensor-product does: the +stages are indexed by `Finset J`, which is countable. -/ +theorem rank_hom_unit_bigTensor_le_aleph0 + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ (Ind C)] {J : Type v} [LinearOrder J] + (B : J → Ind C) [∀ j, MonObj (B j)] + [Countable J] + (h : ∀ s : Finset J, + Module.rank ℂ (𝟙_ (Ind C) ⟶ finTensor B s) ≤ Cardinal.aleph0) : + Module.rank ℂ (𝟙_ (Ind C) ⟶ bigTensor B) ≤ Cardinal.aleph0 := + rank_hom_unit_colimit_le_aleph0 (finTensorDiagram B) h + +/-- The finite stages are the tensor words of the family: a bound on +every word bounds every stage. -/ +theorem rank_hom_unit_finTensor_le_aleph0 + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ (Ind C)] {J : Type v} [LinearOrder J] + (B : J → Ind C) + (h : ∀ l : List J, + Module.rank ℂ (𝟙_ (Ind C) ⟶ listTensor B l) ≤ Cardinal.aleph0) + (s : Finset J) : + Module.rank ℂ (𝟙_ (Ind C) ⟶ finTensor B s) ≤ Cardinal.aleph0 := + h (s.sort (· ≤ ·)) + +end BigTensorRank + +/-! ## Transport along isomorphisms -/ + +section Transport + +variable {C : Type v} + +/-- Isomorphic objects have isomorphic even components. -/ +theorem rank_hom_unit_congr [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ (Ind C)] + {Y Z : Ind C} (e : Y ≅ Z) : + Module.rank ℂ (𝟙_ (Ind C) ⟶ Y) = + Module.rank ℂ (𝟙_ (Ind C) ⟶ Z) := + (Linear.homCongr ℂ (Iso.refl (𝟙_ (Ind C))) e).rank_eq + +/-- Countability of the even component is an isomorphism +invariant. -/ +theorem rank_hom_unit_le_aleph0_of_iso + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ (Ind C)] + {Y Z : Ind C} (e : Y ≅ Z) + (h : Module.rank ℂ (𝟙_ (Ind C) ⟶ Z) ≤ Cardinal.aleph0) : + Module.rank ℂ (𝟙_ (Ind C) ⟶ Y) ≤ Cardinal.aleph0 := + (rank_hom_unit_congr e).trans_le h + +end Transport + +/-! ## The embedded objects + +For an embedded object the even component is the even component +downstairs, which finite length makes finite dimensional +(`RS.finiteDimensional_hom_unit`). The identification is ℂ-linear +only if the embedding is, which the hypothesised linear structure on +the ind-completion does not by itself provide; ℂ-linearity of the +embedding is therefore carried as an explicit hypothesis, in the +shape in which the induced structure of `RS.linearOfScalarUnit` +supplies it. -/ + +section Embedded + +variable {C : Type v} + +variable (C) in +/-- ℂ-linearity of the embedding `C ⥤ Ind C`, as a hypothesis on the +ambient linear structure of the ind-completion. -/ +def IndOfLinear [SmallCategory C] [Abelian C] [CategoryTheory.Linear ℂ C] + [CategoryTheory.Linear ℂ (Ind C)] : Prop := + ∀ (X Y : C) (c : ℂ) (f : X ⟶ Y), + (indOf (C := C)).map (c • f) = c • (indOf (C := C)).map f + +/-- **Full faithfulness of the embedding, ℂ-linearly**: for a +ℂ-linear embedding the hom-modules downstairs and upstairs are the +same ℂ-module. -/ +noncomputable def indOfHomEquiv + [SmallCategory C] [Abelian C] [CategoryTheory.Linear ℂ C] + [CategoryTheory.Linear ℂ (Ind C)] + (hsmul : IndOfLinear C) (X Y : C) : + (X ⟶ Y) ≃ₗ[ℂ] (indOf.obj X ⟶ indOf.obj Y) := + letI := indOf_additive (C := C) + { toFun := fun f => indOf.map f + map_add' := fun _ _ => (indOf (C := C)).map_add + map_smul' := fun c f => hsmul X Y c f + invFun := fun g => Ind.yoneda.fullyFaithful.preimage g + left_inv := fun f => Ind.yoneda.fullyFaithful.preimage_map f + right_inv := fun g => Ind.yoneda.fullyFaithful.map_preimage g } + +/-- **An embedded object of finite length has finite dimensional even +component**, hence countable dimension: the even component is +`𝟙_ C ⟶ W`, which `RS.finiteDimensional_hom_unit` makes finite +dimensional. -/ +theorem rank_hom_unit_indOf_le_aleph0 + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ C] [MonoidalPreadditive C] [MonoidalLinear ℂ C] + [RigidCategory C] [CategoryTheory.Linear ℂ (Ind C)] + (hu : HasScalarUnit C) + (hsmul : IndOfLinear C) {W : C} (hW : ∃ N : ℕ, LengthLE W N) : + Module.rank ℂ (𝟙_ (Ind C) ⟶ indOf.obj W) ≤ Cardinal.aleph0 := by + have : FiniteDimensional ℂ (𝟙_ C ⟶ W) := + finiteDimensional_hom_unit hu hW + have h1 : Module.rank ℂ (𝟙_ (Ind C) ⟶ indOf.obj W) = + Module.rank ℂ (indOf.obj (𝟙_ C) ⟶ indOf.obj W) := + (Linear.homCongr ℂ (indOfUnitIso (C := C)) + (Iso.refl (indOf.obj W))).rank_eq + have h2 : Module.rank ℂ (𝟙_ C ⟶ W) = + Module.rank ℂ (indOf.obj (𝟙_ C) ⟶ indOf.obj W) := + (indOfHomEquiv hsmul (𝟙_ C) W).rank_eq + rw [h1, ← h2] + exact le_of_lt (Module.rank_lt_aleph0 ℂ (𝟙_ C ⟶ W)) + +end Embedded + +/-! ## Countably presented ind-objects + +An object of the ind-completion built from countably much data is a +countable filtered colimit of embedded objects. Such objects are +absorbed one at a time into a tensor word: tensoring preserves +filtered colimits of the ind-completion +(`RS.tensorLeft_ind_preservesColimitsOfShape` and its right-hand +version), so a tensor word against a countably +presented factor is again a countable filtered colimit, whose stages +are tensor words against an *embedded* factor — and the embedding is +monoidal (`RS.indOfTensorIso`), so those stages absorb the factor +into the base category. Iterating along the word never leaves the +one-variable colimit lemma, and no product of index categories is +needed. -/ + +section Presented + +variable {C : Type v} + +/-- An object of the ind-completion is *countably presented* when it +is the colimit of a countable filtered diagram of embedded objects. +This is the shape in which "built from countably much data" enters +the dimension count of the Γ-algebra. -/ +def CountablyPresented [SmallCategory C] + (Z : Ind C) : Prop := + ∃ (I : Type v) (_ : SmallCategory I) (_ : IsFiltered I) + (_ : Countable I) (G : I ⥤ C), + Nonempty (Z ≅ colimit (G ⋙ indOf)) + +/-- Being countably presented is an isomorphism invariant. -/ +theorem CountablyPresented.of_iso [SmallCategory C] + {Y Z : Ind C} (e : Y ≅ Z) + (h : CountablyPresented Y) : CountablyPresented Z := by + obtain ⟨I, hcat, hfil, hcnt, G, ⟨eY⟩⟩ := h + exact ⟨I, hcat, hfil, hcnt, G, ⟨e.symm ≪≫ eY⟩⟩ + +/-- The single object of the one-morphism index category is +terminal. -/ +private def punitIsTerminal : + IsTerminal (Discrete.mk PUnit.unit : Discrete PUnit.{v + 1}) := + IsTerminal.ofUniqueHom (fun X => Discrete.eqToHom (by cases X; rfl)) + (fun _ _ => Subsingleton.elim _ _) + +/-- **Absorbing a countably presented factor.** A tensor word `Y` +whose even component stays countable against every embedded factor +keeps that property after `Y` is enlarged by a countably presented +factor: the enlarged word against an embedded factor is a countable +filtered colimit of copies of the original word against an embedded +factor. -/ +theorem rank_hom_unit_tensor_presented + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ (Ind C)] + {Y Z : Ind C} + (hZ : CountablyPresented Z) + (hY : ∀ W : C, Module.rank ℂ (𝟙_ (Ind C) ⟶ Y ⊗ indOf.obj W) ≤ + Cardinal.aleph0) (W : C) : + Module.rank ℂ (𝟙_ (Ind C) ⟶ (Y ⊗ Z) ⊗ indOf.obj W) ≤ + Cardinal.aleph0 := by + obtain ⟨I, hcat, hfil, hcnt, G, ⟨eZ⟩⟩ := hZ + let := hcat + let := hfil + let := hcnt + refine rank_hom_unit_le_aleph0_of_iso + (Z := colimit (((G ⋙ indOf) ⋙ tensorRight (indOf.obj W)) ⋙ + tensorLeft Y)) ?_ ?_ + · exact (α_ Y Z (indOf.obj W)) ≪≫ + whiskerLeftIso Y ((tensorRight (indOf.obj W)).mapIso eZ ≪≫ + preservesColimitIso (tensorRight (indOf.obj W)) + (G ⋙ indOf)) ≪≫ + preservesColimitIso (tensorLeft Y) _ + · refine rank_hom_unit_colimit_le_aleph0 _ (fun i => ?_) + exact rank_hom_unit_le_aleph0_of_iso + (whiskerLeftIso Y (indOfTensorIso (G.obj i) W)) + (hY (G.obj i ⊗ W)) + +/-- The induction along a tensor word: each factor is absorbed by +`RS.rank_hom_unit_tensor_presented`, the accumulated word being +carried as the parameter `Y`. -/ +private theorem rank_tensor_listTensor_aux + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ (Ind C)] + {J : Type v} + (B : J → Ind C) (hB : ∀ j, CountablyPresented (B j)) : + ∀ (l : List J) (Y : Ind C), + (∀ W : C, Module.rank ℂ (𝟙_ (Ind C) ⟶ Y ⊗ indOf.obj W) ≤ + Cardinal.aleph0) → + ∀ W : C, Module.rank ℂ + (𝟙_ (Ind C) ⟶ (Y ⊗ listTensor B l) ⊗ indOf.obj W) ≤ + Cardinal.aleph0 + | [], Y, hY, W => + rank_hom_unit_le_aleph0_of_iso + (whiskerRightIso (ρ_ Y) (indOf.obj W)) (hY W) + | j :: l, Y, hY, W => + rank_hom_unit_le_aleph0_of_iso + (whiskerRightIso (α_ Y (B j) (listTensor B l)).symm + (indOf.obj W)) + (rank_tensor_listTensor_aux B hB l (Y ⊗ B j) + (rank_hom_unit_tensor_presented (hB j) hY) W) + +/-- **The tensor words of countably presented algebras have countable +even component.** This is the finite-stage input of +`RS.rank_hom_unit_bigTensor_le_aleph0`, discharged. -/ +theorem rank_hom_unit_listTensor_le_aleph0 + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] [CategoryTheory.Linear ℂ (Ind C)] + [CategoryTheory.Linear ℂ C] [MonoidalLinear ℂ C] + (hu : HasScalarUnit C) + (hsmul : IndOfLinear C) (hlen : ∀ X : C, ∃ N : ℕ, LengthLE X N) + {J : Type v} (B : J → Ind C) + (hB : ∀ j, CountablyPresented (B j)) (l : List J) : + Module.rank ℂ (𝟙_ (Ind C) ⟶ listTensor B l) ≤ Cardinal.aleph0 := by + have hbase : ∀ W : C, + Module.rank ℂ (𝟙_ (Ind C) ⟶ 𝟙_ (Ind C) ⊗ indOf.obj W) ≤ + Cardinal.aleph0 := fun W => + rank_hom_unit_le_aleph0_of_iso (λ_ (indOf.obj W)) + (rank_hom_unit_indOf_le_aleph0 hu hsmul (hlen W)) + refine rank_hom_unit_le_aleph0_of_iso ?_ + (rank_tensor_listTensor_aux B hB l (𝟙_ (Ind C)) hbase (𝟙_ C)) + exact (ρ_ (listTensor B l)).symm ≪≫ + whiskerLeftIso (listTensor B l) (indOfUnitIso (C := C)) ≪≫ + whiskerRightIso (λ_ (listTensor B l)).symm (indOf.obj (𝟙_ C)) + +end Presented + +/-! ## The common extension of a countable family + +The tensor-product device of Deligne 2.11, with the dimension count +carried along: a countable family of algebras whose tensor words have +countable even component has a common extension with countable even +component. -/ + +section CommonAlgebraRank + +variable {C : Type v} + +/-- **A countable family of nonzero algebras has a common nonzero +extension of countable even dimension**: the tensor product of the +family, as in `RS.exists_common_algebra`, with the dimension count of +`RS.rank_hom_unit_bigTensor_le_aleph0` added. The hypothesis is the +countability of the even component of every tensor word of the +family, which is the finite-stage input the colimit argument +consumes. -/ +theorem exists_common_algebra_rank_le_aleph0 + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ C] [MonoidalPreadditive C] [MonoidalLinear ℂ C] + [RigidCategory C] [CategoryTheory.Linear ℂ (Ind C)] + [SymmetricCategory (Ind C)] + (hu : HasScalarUnit C) + {J : Type v} [Countable J] (B : J → Ind C) [∀ j, MonObj (B j)] + [∀ j, IsCommMonObj (B j)] (hB : ∀ j, MonObj.one (X := B j) ≠ 0) + (hrk : ∀ l : List J, + Module.rank ℂ (𝟙_ (Ind C) ⟶ listTensor B l) ≤ Cardinal.aleph0) : + ∃ (𝔸 : Ind C) (_ : MonObj 𝔸) (_ : IsCommMonObj 𝔸), + MonObj.one (X := 𝔸) ≠ 0 ∧ + (∀ j, ∃ φ : B j ⟶ 𝔸, IsMonHom φ) ∧ + Module.rank ℂ (𝟙_ (Ind C) ⟶ 𝔸) ≤ Cardinal.aleph0 := by + let : DecidableRel (WellOrderingRel (α := J)) := + Classical.decRel _ + let : LinearOrder J := linearOrderOfSTO WellOrderingRel + exact ⟨bigTensor B, bigTensorMon B, bigTensorCommMon B, + bigTensorUnit_ne_zero_ind B hu hB, + fun j => ⟨bigTensorOf B j, isMonHom_bigTensorOf B j⟩, + rank_hom_unit_bigTensor_le_aleph0 B + (rank_hom_unit_finTensor_le_aleph0 B hrk)⟩ + +/-- **The common extension of a countable family of countably +presented algebras has countable even component.** The hypothesis is +structural: each member of the family is a countable filtered +colimit of embedded objects, which is what "built from countably much +data" means for the algebras of Deligne 2.11. -/ +theorem exists_common_algebra_rank_le_aleph0_of_presented + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ C] [MonoidalPreadditive C] [MonoidalLinear ℂ C] + [RigidCategory C] [CategoryTheory.Linear ℂ (Ind C)] + [SymmetricCategory (Ind C)] + (hu : HasScalarUnit C) (hsmul : IndOfLinear C) + (hlen : ∀ X : C, ∃ N : ℕ, LengthLE X N) {J : Type v} [Countable J] + (B : J → Ind C) [∀ j, MonObj (B j)] [∀ j, IsCommMonObj (B j)] + (hB : ∀ j, MonObj.one (X := B j) ≠ 0) + (hpres : ∀ j, CountablyPresented (B j)) : + ∃ (𝔸 : Ind C) (_ : MonObj 𝔸) (_ : IsCommMonObj 𝔸), + MonObj.one (X := 𝔸) ≠ 0 ∧ + (∀ j, ∃ φ : B j ⟶ 𝔸, IsMonHom φ) ∧ + Module.rank ℂ (𝟙_ (Ind C) ⟶ 𝔸) ≤ Cardinal.aleph0 := + exists_common_algebra_rank_le_aleph0 hu B hB + (rank_hom_unit_listTensor_le_aleph0 hu hsmul hlen B hpres) + +end CommonAlgebraRank + +/-! ## The universal algebra over a countable family + +Deligne 2.11 with the dimension count carried along. The two +hypotheses are those of `RS.exists_universal_algebra` strengthened by +the requirement that the algebra chosen at each index be countably +presented; the index families are countable, so the universal algebra +— the tensor product of all the chosen algebras — has countable even +component. -/ + +section UniversalAlgebraRank + +variable {C : Type v} + +/-- **The universal algebra over countable families has countable +even component**: one nonzero algebra over which every object of the +family becomes a mixed sum and every chosen morphism acquires a +section, whose Γ-algebra is of at most countable dimension over ℂ. +The hypotheses are those of `RS.exists_universal_algebra` with the +chosen algebras required to be countably presented. -/ +theorem exists_universal_algebra_rank_le_aleph0 + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ C] [MonoidalPreadditive C] [MonoidalLinear ℂ C] + [RigidCategory C] [CategoryTheory.Linear ℂ (Ind C)] + [SymmetricCategory (Ind C)] [HasCoequalizers (Ind C)] + [∀ Z : Ind C, PreservesColimitsOfShape WalkingParallelPair (tensorLeft + Z)] [HasFiniteBiproducts (Ind C)] + (hu : HasScalarUnit C) + (hsmul : IndOfLinear C) (hlen : ∀ Z : C, ∃ N : ℕ, LengthLE Z N) + (L : OddLine (Ind C)) {J K : Type v} [Countable J] [Countable K] + (X : J → Ind C) (V W : K → Ind C) (g : ∀ k, V k ⟶ W k) + (hmix : ∀ j, ∃ (p q : ℕ) (A : Ind C) (_ : MonObj A) + (_ : IsCommMonObj A), MonObj.one (X := A) ≠ 0 ∧ + CountablyPresented A ∧ + Nonempty (freeMod A (X j) ≅ freeMod A (L.mix p q))) + (hsplit : ∀ k, ∃ (A : Ind C) (_ : MonObj A) (_ : IsCommMonObj A), + MonObj.one (X := A) ≠ 0 ∧ CountablyPresented A ∧ + ∃ s : freeMod A (W k) ⟶ freeMod A (V k), + s ≫ freeModMap A (g k) = 𝟙 (freeMod A (W k))) : + ∃ (𝔸 : Ind C) (_ : MonObj 𝔸) (_ : IsCommMonObj 𝔸), + MonObj.one (X := 𝔸) ≠ 0 ∧ + (∀ j, ∃ p q : ℕ, + Nonempty (freeMod 𝔸 (X j) ≅ freeMod 𝔸 (L.mix p q))) ∧ + (∀ k, ∃ s : freeMod 𝔸 (W k) ⟶ freeMod 𝔸 (V k), + s ≫ freeModMap 𝔸 (g k) = 𝟙 (freeMod 𝔸 (W k))) ∧ + Module.rank ℂ (𝟙_ (Ind C) ⟶ 𝔸) ≤ Cardinal.aleph0 := by + classical + choose pm qm Am Amon Acomm Ane Apres Aiso using hmix + choose Bs Bmon Bcomm Bne Bpres Bsec using hsplit + let : ∀ i : J ⊕ K, MonObj (Sum.elim Am Bs i) := fun i => + match i with + | Sum.inl j => Amon j + | Sum.inr k => Bmon k + let : ∀ i : J ⊕ K, IsCommMonObj (Sum.elim Am Bs i) := fun i => + match i with + | Sum.inl j => Acomm j + | Sum.inr k => Bcomm k + obtain ⟨𝔸, hmon, hcomm, hne, hmap, hrk⟩ := + exists_common_algebra_rank_le_aleph0_of_presented hu hsmul hlen + (Sum.elim Am Bs) + (fun i => match i with + | Sum.inl j => Ane j + | Sum.inr k => Bne k) + (fun i => match i with + | Sum.inl j => Apres j + | Sum.inr k => Bpres k) + refine ⟨𝔸, hmon, hcomm, hne, ?_, ?_, hrk⟩ + · intro j + obtain ⟨φ, hφ⟩ := hmap (Sum.inl j) + have : IsMonHom (show Am j ⟶ 𝔸 from φ) := hφ + exact ⟨pm j, qm j, + ⟨freeModIsoBaseChange (Am j) 𝔸 (show Am j ⟶ 𝔸 from φ) + (Aiso j).some⟩⟩ + · intro k + obtain ⟨φ, hφ⟩ := hmap (Sum.inr k) + have : IsMonHom (show Bs k ⟶ 𝔸 from φ) := hφ + obtain ⟨s, hs⟩ := Bsec k + exact exists_section_baseChange (Bs k) 𝔸 + (show Bs k ⟶ 𝔸 from φ) (g k) s hs + +end UniversalAlgebraRank + +/-! ## The Γ-algebra and its ℂ-point + +The even component of the Γ-algebra of a commutative monoid object is +its even component as computed above, so the dimension count is a +count of `𝟙 ⟶ R`; and the countable Nullstellensatz turns it into a +ℂ-point of the Γ-algebra. -/ + +section SuperPointCountable + +universe u' + +/-- **A super-commutative ℂ-algebra of at most countable dimension +has a ℂ-point.** The odd-nil quotient is a nonzero commutative +ℂ-algebra of at most countable dimension, so +`RS.exists_algHom_of_countable_dimension` gives it a ℂ-algebra map to +ℂ, which pulls back to a point. This is the countable-dimension +replacement for the finite-type hypothesis of +`RS.nonempty_superPoint`. -/ +theorem nonempty_superPoint_of_rank_le_aleph0 + (S : SuperCommAlgebra.{u, u'}) [Nontrivial S.even] + (h : Module.rank ℂ S.even ≤ Cardinal.aleph0) : + Nonempty (SuperPoint S) := by + have := S.nontrivial_quotient_oddIdeal + refine (exists_algHom_of_countable_dimension (S.even ⧸ S.oddIdeal) + ?_).map (SuperPoint.ofQuotient S) + exact le_trans (LinearMap.rank_le_of_surjective + (Ideal.Quotient.mkₐ ℂ S.oddIdeal).toLinearMap + (Ideal.Quotient.mkₐ_surjective ℂ _)) h + +end SuperPointCountable + +section GammaRank + +variable {C : Type v} + +/-- **The even component of the Γ-algebra has countable dimension** +whenever the even hom-module of the algebra does: the two are the +same ℂ-module. -/ +theorem rank_gammaEven_le_aleph0 + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ (Ind C)] [MonoidalPreadditive (Ind C)] + [MonoidalLinear ℂ (Ind C)] [SymmetricCategory (Ind C)] + (L : OddLine (Ind C)) (R : Ind C) + [MonObj R] [IsCommMonObj R] + (h : Module.rank ℂ (𝟙_ (Ind C) ⟶ R) ≤ Cardinal.aleph0) : + Module.rank ℂ (gammaAlgebra (Ind C) L R).even ≤ + Cardinal.aleph0 := h + +/-- **A ℂ-point of the Γ-algebra of an algebra with countable even +component**: the last step of the descent to the complex numbers, run +over the countable-dimension Nullstellensatz. Nontriviality of the +even ring is exactly the nonvanishing of the unit of the algebra. -/ +theorem nonempty_superPoint_gammaAlgebra + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ (Ind C)] [MonoidalPreadditive (Ind C)] + [MonoidalLinear ℂ (Ind C)] [SymmetricCategory (Ind C)] + (L : OddLine (Ind C)) + (R : Ind C) [MonObj R] [IsCommMonObj R] + (hR : MonObj.one (X := R) ≠ 0) + (h : Module.rank ℂ (𝟙_ (Ind C) ⟶ R) ≤ Cardinal.aleph0) : + Nonempty (SuperPoint (gammaAlgebra (Ind C) L R)) := by + have : Nontrivial (gammaAlgebra (Ind C) L R).even := + nontrivial_of_ne 1 0 hR + exact nonempty_superPoint_of_rank_le_aleph0 _ + (rank_gammaEven_le_aleph0 L R h) + +end GammaRank + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModule.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModule.lean new file mode 100644 index 0000000000..2c1b2b74ab --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModule.lean @@ -0,0 +1,358 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaAlgebra + +/-! +# The Γ-module of a module object + +A module object `M` over a commutative monoid object `R` of a +symmetric ℂ-linear monoidal category with an odd line `L` realizes +as a module over the super-commutative ℂ-algebra +`RS.gammaAlgebra D L R`: the even part is `𝟙_ D ⟶ M`, the odd part +is `L.obj ⟶ M`, and the four graded action blocks are the +convolution of the internal action sandwiched between the same +coherence isomorphisms that identify the sources in +`RS.gammaAlgebra`. + +The pattern of `RS.GammaAlgebra` repeats one level down. +Everything rests on a single ungraded operation, `RS.gact`: the +convolution `(a ⊗ₘ m) ≫ γ` of a morphism into `R` against a +morphism into `M`, at *arbitrary* sources. Its two structural +laws — associativity against `RS.gmul` up to the associator +(`RS.gact_assoc`) and the unit law (`RS.gact_one`) — hold once and +for all, and each of the ten axioms of `RS.SuperCommAlgebra.Mod` +is one of them conjugated by coherence isomorphisms. + +There is no commutativity axiom for a module, so the odd line +enters only through the source identification `L.sq` of the +odd-odd block; as in the algebra, the odd-odd-odd associativity is +the one axiom not implied by coherence alone, and it is again the +first triangle identity of the self-duality of the odd line, +`RS.OddLine.evaluation_coevaluation`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open scoped MonObj + +universe v u u' w w' + +/-! ## Modules over a super-commutative ℂ-algebra -/ + +/-- A *module* over a super-commutative ℂ-algebra, presented as a +pair of ℂ-modules — the even and odd components — with the four +graded action blocks, the two unit laws and associativity at every +parity pattern of a scalar pair acting on a module element. + +The blocks are indexed by the parities of the two algebra +arguments and of the module argument, and the parity of the value +is their sum: `assoc_xyz` says that acting by the product of an +`x`-parity and a `y`-parity scalar is acting by the second and +then by the first. -/ +-- `w` and `w'` are the universes of the even and odd components: +-- independent by design, and the structure is a pair, so they can +-- only ever occur together in its type. +structure SuperCommAlgebra.Mod (S : SuperCommAlgebra.{u, u'}) where + /-- The even component. -/ + even : Type w + /-- The odd component. -/ + odd : Type w' + [evenAddCommGroup : AddCommGroup even] + [evenModule : Module ℂ even] + [oddAddCommGroup : AddCommGroup odd] + [oddModule : Module ℂ odd] + /-- The action of an even scalar on an even element. -/ + actEE : S.even →ₗ[ℂ] even →ₗ[ℂ] even + /-- The action of an even scalar on an odd element. -/ + actEO : S.even →ₗ[ℂ] odd →ₗ[ℂ] odd + /-- The action of an odd scalar on an even element. -/ + actOE : S.odd →ₗ[ℂ] even →ₗ[ℂ] odd + /-- The action of an odd scalar on an odd element. -/ + actOO : S.odd →ₗ[ℂ] odd →ₗ[ℂ] even + /-- The unit acts as the identity on the even component. -/ + one_act_e : ∀ m, actEE S.one m = m + /-- The unit acts as the identity on the odd component. -/ + one_act_o : ∀ m, actEO S.one m = m + /-- Associativity at parity pattern even-even-even. -/ + assoc_eee : ∀ x y m, actEE (S.mulEE x y) m = actEE x (actEE y m) + /-- Associativity at parity pattern even-even-odd. -/ + assoc_eeo : ∀ x y m, actEO (S.mulEE x y) m = actEO x (actEO y m) + /-- Associativity at parity pattern even-odd-even. -/ + assoc_eoe : ∀ x u m, actOE (S.mulEO x u) m = actEO x (actOE u m) + /-- Associativity at parity pattern even-odd-odd. -/ + assoc_eoo : ∀ x u m, actOO (S.mulEO x u) m = actEE x (actOO u m) + /-- Associativity at parity pattern odd-even-even. -/ + assoc_oee : ∀ u x m, actOE (S.mulOE u x) m = actOE u (actEE x m) + /-- Associativity at parity pattern odd-even-odd. -/ + assoc_oeo : ∀ u x m, actOO (S.mulOE u x) m = actOO u (actEO x m) + /-- Associativity at parity pattern odd-odd-even. -/ + assoc_ooe : ∀ u v m, actEE (S.mulOO u v) m = actOO u (actOE v m) + /-- Associativity at parity pattern odd-odd-odd. -/ + assoc_ooo : ∀ u v m, actEO (S.mulOO u v) m = actOE u (actOO v m) + +attribute [instance] SuperCommAlgebra.Mod.evenAddCommGroup + SuperCommAlgebra.Mod.evenModule + SuperCommAlgebra.Mod.oddAddCommGroup + SuperCommAlgebra.Mod.oddModule + +/-! ## Ungraded convolution against a module object -/ + +section Action + +variable {D : Type u} + +/-- The *convolution action* of a morphism into a monoid object on +a morphism into a module object, taken at arbitrary sources: +tensor the two morphisms and act. -/ +noncomputable def gact + [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] {M : D} + [ModObj R M] + {X Y : D} (a : X ⟶ R) (m : Y ⟶ M) : + X ⊗ Y ⟶ M := + (a ⊗ₘ m) ≫ actLeft R M + +/-- The convolution action unfolded. -/ +theorem gact_def + [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] {M : D} + [ModObj R M] + {X Y : D} (a : X ⟶ R) (m : Y ⟶ M) : + gact a m = (a ⊗ₘ m) ≫ actLeft R M := rfl + +/-- Reindexing the scalar source of a convolution action. -/ +theorem comp_gact + [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] {M : D} + [ModObj R M] + {W X Y : D} (f : W ⟶ X) (a : X ⟶ R) + (m : Y ⟶ M) : gact (f ≫ a) m = f ▷ Y ≫ gact a m := by + have h : f ▷ Y ≫ (a ⊗ₘ m) = (f ≫ a) ⊗ₘ m := by + rw [← tensorHom_id, tensorHom_comp_tensorHom, Category.id_comp] + rw [gact_def, gact_def, ← h, Category.assoc] + +/-- Reindexing the module source of a convolution action. -/ +theorem gact_comp + [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] {M : D} + [ModObj R M] + {X Y Z : D} (a : X ⟶ R) (g : Z ⟶ Y) + (m : Y ⟶ M) : gact a (g ≫ m) = X ◁ g ≫ gact a m := by + have h : X ◁ g ≫ (a ⊗ₘ m) = a ⊗ₘ (g ≫ m) := by + rw [← id_tensorHom, tensorHom_comp_tensorHom, Category.id_comp] + rw [gact_def, gact_def, ← h, Category.assoc] + +/-- **The convolution action is associative** against the +convolution product, up to the associator of the three sources. -/ +theorem gact_assoc + [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] {M : D} + [ModObj R M] + {X Y Z : D} (a : X ⟶ R) (b : Y ⟶ R) + (m : Z ⟶ M) : + gact (gmul a b) m = (α_ X Y Z).hom ≫ gact a (gact b m) := by + have hl : ((a ⊗ₘ b) ⊗ₘ m) ≫ (μ[R] ▷ M) ≫ actLeft R M = + gact (gmul a b) m := by + rw [← Category.assoc, ← tensorHom_id, tensorHom_comp_tensorHom, + Category.comp_id] + rfl + have hr : (a ⊗ₘ (b ⊗ₘ m)) ≫ (R ◁ actLeft R M) ≫ actLeft R M = + gact a (gact b m) := by + rw [← Category.assoc, ← id_tensorHom, tensorHom_comp_tensorHom, + Category.comp_id] + rfl + rw [← hl, ← hr, mul_actLeft R M, ← Category.assoc, + associator_naturality, Category.assoc] + +/-- The monoid unit acts as the identity. -/ +theorem gact_one + [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] {M : D} + [ModObj R M] + {Y : D} (m : Y ⟶ M) : + gact (η[R]) m = (λ_ Y).hom ≫ m := by + rw [gact_def, tensorHom_def', Category.assoc, one_actLeft, + leftUnitor_naturality] + +section Additive + +/-- The convolution action is additive in its scalar argument. -/ +theorem add_gact + [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] {M : D} + [ModObj R M] [Preadditive D] [MonoidalPreadditive D] + {X Y : D} (a a' : X ⟶ R) (m : Y ⟶ M) : + gact (a + a') m = gact a m + gact a' m := by + rw [gact_def, gact_def, gact_def, MonoidalPreadditive.add_tensor, + Preadditive.add_comp] + +/-- The convolution action is additive in its module argument. -/ +theorem gact_add + [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] {M : D} + [ModObj R M] [Preadditive D] [MonoidalPreadditive D] + {X Y : D} (a : X ⟶ R) (m m' : Y ⟶ M) : + gact a (m + m') = gact a m + gact a m' := by + rw [gact_def, gact_def, gact_def, MonoidalPreadditive.tensor_add, + Preadditive.add_comp] + +end Additive + +section Homogeneous + +/-- The convolution action is ℂ-homogeneous in its scalar +argument. -/ +theorem smul_gact + [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] {M : D} + [ModObj R M] [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + (r : ℂ) {X Y : D} (a : X ⟶ R) (m : Y ⟶ M) : + gact (r • a) m = r • gact a m := by + have h : (r • a) ⊗ₘ m = r • (a ⊗ₘ m) := by + rw [tensorHom_def, tensorHom_def, + MonoidalLinear.smul_whiskerRight, Linear.smul_comp] + rw [gact_def, gact_def, h, Linear.smul_comp] + +/-- The convolution action is ℂ-homogeneous in its module +argument. -/ +theorem gact_smul + [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] {M : D} + [ModObj R M] [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + (r : ℂ) {X Y : D} (a : X ⟶ R) (m : Y ⟶ M) : + gact a (r • m) = r • gact a m := by + have h : a ⊗ₘ (r • m) = r • (a ⊗ₘ m) := by + rw [tensorHom_def', tensorHom_def', + MonoidalLinear.whiskerLeft_smul, Linear.smul_comp] + rw [gact_def, gact_def, h, Linear.smul_comp] + +end Homogeneous + +/-! ### The bundled bilinear convolution action -/ + +section Bundled + +/-- The convolution action as a ℂ-bilinear map of hom-modules, +transported along a chosen morphism `s` from the intended source +into the tensor product of the two given sources. The four graded +action blocks of `RS.gammaModule` are the four instances of this +construction. -/ +noncomputable def gactLin + [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] {M : D} + [ModObj R M] [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + {W X Y : D} (s : W ⟶ X ⊗ Y) : + (X ⟶ R) →ₗ[ℂ] (Y ⟶ M) →ₗ[ℂ] (W ⟶ M) := + LinearMap.mk₂ ℂ (fun a m => s ≫ gact a m) + (fun a a' m => by rw [add_gact, Preadditive.comp_add]) + (fun r a m => by rw [smul_gact, Linear.comp_smul]) + (fun a m m' => by rw [gact_add, Preadditive.comp_add]) + (fun r a m => by rw [gact_smul, Linear.comp_smul]) + +@[simp] +theorem gactLin_apply + [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] {M : D} + [ModObj R M] [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + {W X Y : D} (s : W ⟶ X ⊗ Y) (a : X ⟶ R) + (m : Y ⟶ M) : gactLin s a m = s ≫ gact a m := rfl + +/-- **The transported associativity law**: given a coherence +identity between the two ways of reassociating the chosen sources, +acting by a convolution product agrees with acting twice. -/ +theorem gactLin_assoc + [Category.{v} D] [MonoidalCategory D] {R : D} [MonObj R] {M : D} + [ModObj R M] [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + {W W' V X Y Z : D} (s₁ : W' ⟶ W ⊗ Z) + (s₂ : W ⟶ X ⊗ Y) (s₃ : W' ⟶ X ⊗ V) (s₄ : V ⟶ Y ⊗ Z) + (h : s₁ ≫ s₂ ▷ Z ≫ (α_ X Y Z).hom = s₃ ≫ X ◁ s₄) + (a : X ⟶ R) (b : Y ⟶ R) (m : Z ⟶ M) : + gactLin s₁ (gmulLin s₂ a b) m + = gactLin s₃ a (gactLin s₄ b m) := by + simp only [gactLin_apply, gmulLin_apply] + rw [comp_gact, gact_assoc, gact_comp, reassoc_of% h] + +end Bundled + +end Action + +/-! ## The Γ-module of a module object -/ + +/-- **The Γ-module of a module object**: for a module object `M` +over a commutative monoid object `R` of a symmetric ℂ-linear +monoidal category carrying an odd line `L`, the morphisms +`𝟙_ D ⟶ M` and `L.obj ⟶ M` form a module over the +super-commutative ℂ-algebra `RS.gammaAlgebra D L R` under the +convolution action. + +The four blocks are the convolution action conjugated by the same +coherence isomorphisms that identify the sources in +`RS.gammaAlgebra`: the left unitor for even-even and even-odd, the +right unitor for odd-even, and the square trivialisation `L.sq` of +the odd line for odd-odd. -/ +noncomputable def gammaModule (D : Type u) [Category.{v} D] + [MonoidalCategory D] [SymmetricCategory D] [Preadditive D] + [MonoidalPreadditive D] [Linear ℂ D] [MonoidalLinear ℂ D] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (M : D) [ModObj R M] : (gammaAlgebra D L R).Mod where + even := 𝟙_ D ⟶ M + odd := L.obj ⟶ M + actEE := gactLin (R := R) (M := M) (λ_ (𝟙_ D)).inv + actEO := gactLin (R := R) (M := M) (λ_ L.obj).inv + actOE := gactLin (R := R) (M := M) (ρ_ L.obj).inv + actOO := gactLin (R := R) (M := M) L.sq.inv + one_act_e m := by + have h : gactLin (R := R) (M := M) (λ_ (𝟙_ D)).inv η[R] m + = m := by + rw [gactLin_apply, gact_one, Iso.inv_hom_id_assoc] + exact h + one_act_o m := by + have h : gactLin (R := R) (M := M) (λ_ L.obj).inv η[R] m + = m := by + rw [gactLin_apply, gact_one, Iso.inv_hom_id_assoc] + exact h + assoc_eee x y m := by + refine gactLin_assoc _ _ _ _ ?_ x y m + monoidal + assoc_eeo x y m := by + refine gactLin_assoc _ _ _ _ ?_ x y m + monoidal + assoc_eoe x u m := by + refine gactLin_assoc _ _ _ _ ?_ x u m + monoidal + assoc_eoo x u m := by + refine gactLin_assoc _ _ _ _ ?_ x u m + have hc : (λ_ L.obj).inv ▷ L.obj ≫ + (α_ (𝟙_ D) L.obj L.obj).hom = + (λ_ (L.obj ⊗ L.obj)).inv := by monoidal + rw [hc] + exact leftUnitor_inv_naturality L.sq.inv + assoc_oee u x m := by + refine gactLin_assoc _ _ _ _ ?_ u x m + monoidal + assoc_oeo u x m := by + refine gactLin_assoc _ _ _ _ ?_ u x m + have hc : (ρ_ L.obj).inv ▷ L.obj ≫ + (α_ L.obj (𝟙_ D) L.obj).hom = + L.obj ◁ (λ_ L.obj).inv := by monoidal + rw [hc] + assoc_ooe u v m := by + refine gactLin_assoc _ _ _ _ ?_ u v m + have hc : (ρ_ (L.obj ⊗ L.obj)).inv ≫ + (α_ L.obj L.obj (𝟙_ D)).hom = + L.obj ◁ (ρ_ L.obj).inv := by monoidal + rw [unitors_inv_equal, ← Category.assoc, + ← rightUnitor_inv_naturality, Category.assoc, hc] + assoc_ooo u v m := by + refine gactLin_assoc _ _ _ _ ?_ u v m + have h2 : L.sq.inv ▷ L.obj ≫ (α_ L.obj L.obj L.obj).hom = + (λ_ L.obj).hom ≫ (ρ_ L.obj).inv ≫ + L.obj ◁ L.sq.inv := by + rw [← reassoc_of% L.evaluation_coevaluation, + ← MonoidalCategory.whiskerLeft_comp, Iso.hom_inv_id, + MonoidalCategory.whiskerLeft_id, Category.comp_id] + rw [h2, ← Category.assoc, Iso.inv_hom_id, Category.id_comp] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModuleFunctor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModuleFunctor.lean new file mode 100644 index 0000000000..b68a40553c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModuleFunctor.lean @@ -0,0 +1,52 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom + +/-! +# Realization as a functor on module objects + +Taking the morphisms out of the two generators is functorial on +module objects over a fixed commutative monoid object: the +realization of a module map is postcomposition. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {D : Type u} + +/-- **Realization, as a functor on module objects.** -/ +noncomputable def gammaModuleFunctor + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (R : D) + [MonObj R] [IsCommMonObj R] : + Mod D R ⥤ (gammaAlgebra D L R).Mod where + obj M := gammaModule D L R M.X + map {_ _} f := + letI : IsModHom R f.hom := f.isModHom + gammaModuleMap L R f.hom + map_id M := by + refine SuperCommAlgebra.Mod.Hom.ext ?_ ?_ <;> + refine LinearMap.ext fun m => ?_ <;> + · change m ≫ Mod.Hom.hom (𝟙 M) = m + erw [Mod.id_hom', Category.comp_id] + map_comp {M N P} f g := by + refine SuperCommAlgebra.Mod.Hom.ext ?_ ?_ <;> + refine LinearMap.ext fun m => ?_ <;> + · change m ≫ Mod.Hom.hom (f ≫ g) = (m ≫ f.hom) ≫ g.hom + erw [Mod.comp_hom', Category.assoc] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPair.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPair.lean new file mode 100644 index 0000000000..27f0b1ac74 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPair.lean @@ -0,0 +1,1049 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModTensor + +/-! +# The comparison map of Deligne's (2.11.1) + +For two module objects `M`, `N` over a commutative monoid object +`R` of a symmetric ℂ-linear monoidal category carrying an odd line +`L`, the Γ-modules of `M` and of `N` may be tensored over the +Γ-algebra of `R` (`RS.SuperCommAlgebra.Mod.tensor`), and the +relative tensor product `RS.modTensor` of the module objects has a +Γ-module of its own. This file builds the comparison map between +them, `RS.gammaPairComparison`, as a morphism of super modules. + +Everything rests on one ungraded operation, `RS.gpair`: the +pairing `(m ⊗ₘ n) ≫ π` of a morphism into `M` against a morphism +into `N`, at *arbitrary* sources, followed by the projection onto +the relative tensor product. It obeys two structural laws, which +between them carry the whole construction. + +* **The balance law** `RS.gpair_balance`: + `gpair (gact a m) n = (β_ X Y).hom ▷ Z ≫ (α_ Y X Z).hom ≫ + gpair m (gact a n)`. + A scalar may be moved from the left argument to the right one at + the cost of braiding it past the source of the left argument. + This is the defining relation `RS.modTensor_condition` of the + coequalizer, written in the language of the pairing: the leg + acting on `M` does so through `RS.actRight`, which is the left + action conjugated by the braiding. +* **The action law** `RS.gact_gpair`: + `gact a (gpair m n) = (α_ X Y Z).inv ≫ gpair (gact a m) n`. + The descended action of `R` on the relative tensor product is + the action on the left factor. + +Instantiating the balance law at the four source identifications +`(λ_ (𝟙_ D)).inv`, `(λ_ L.obj).inv`, `(ρ_ L.obj).inv` and +`L.sq.inv` gives the eight balancing laws `RS.gpair_balanced_xyz` +that the universal property of `RS.SuperCommAlgebra.Mod.tensor` +requires; the Koszul sign appears in exactly the two patterns +`ooe` and `ooo`, where the scalar and the left argument are both +odd, and it is `RS.OddLine.braid_neg`. Instantiating the action +law at the same four identifications gives the eight action laws +`RS.gpair_act_xyz`, which say that the resulting map is a morphism +of super modules. + +The only identity not implied by coherence is the odd-odd-odd one, +`RS.oddLine_sq_assoc`: it is the first triangle identity of the +self-duality of the odd line, +`RS.OddLine.evaluation_coevaluation`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +/-! ## The ungraded pairing -/ + +section Pairing + +variable {D : Type u} + +/-- The *pairing* of a morphism into one module object with a +morphism into another, taken at arbitrary sources: tensor the two +morphisms and project to the relative tensor product. -/ +noncomputable def gpair + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] {R : D} [MonObj R] {M : Mod D R} {N : Mod D R} + {X Y : D} (m : X ⟶ M.X) (n : Y ⟶ N.X) : + X ⊗ Y ⟶ modTensor R M N := + (m ⊗ₘ n) ≫ modTensorπ R M N + +/-- The pairing unfolded. -/ +theorem gpair_def [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] {R : D} [MonObj R] {M : Mod D R} {N : Mod D R} + {X Y : D} (m : X ⟶ M.X) (n : Y ⟶ N.X) : + gpair m n = (m ⊗ₘ n) ≫ modTensorπ R M N := rfl + +/-- Reindexing the left source of a pairing. -/ +theorem comp_gpair [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] {R : D} [MonObj R] {M : Mod D R} {N : Mod D R} + {W X Y : D} (f : W ⟶ X) (m : X ⟶ M.X) + (n : Y ⟶ N.X) : + gpair (f ≫ m) n = f ▷ Y ≫ gpair (M := M) (N := N) m n := by + have h : f ▷ Y ≫ (m ⊗ₘ n) = (f ≫ m) ⊗ₘ n := by + rw [← tensorHom_id, tensorHom_comp_tensorHom, Category.id_comp] + rw [gpair_def, gpair_def, ← h, Category.assoc] + +/-- Reindexing the right source of a pairing. -/ +theorem gpair_comp [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] {R : D} [MonObj R] {M : Mod D R} {N : Mod D R} + {X Y Z : D} (m : X ⟶ M.X) (g : Z ⟶ Y) + (n : Y ⟶ N.X) : + gpair m (g ≫ n) = X ◁ g ≫ gpair (M := M) (N := N) m n := by + have h : X ◁ g ≫ (m ⊗ₘ n) = m ⊗ₘ (g ≫ n) := by + rw [← id_tensorHom, tensorHom_comp_tensorHom, Category.id_comp] + rw [gpair_def, gpair_def, ← h, Category.assoc] + +section Additive + +/-- The pairing is additive in its left argument. -/ +theorem add_gpair [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] {R : D} [MonObj R] {M : Mod D R} {N : Mod D R} + [Preadditive D] [MonoidalPreadditive D] + {X Y : D} (m m' : X ⟶ M.X) (n : Y ⟶ N.X) : + gpair (m + m') n = gpair (N := N) m n + gpair (N := N) m' n := by + rw [gpair_def, gpair_def, gpair_def, MonoidalPreadditive.add_tensor, + Preadditive.add_comp] + +/-- The pairing is additive in its right argument. -/ +theorem gpair_add [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] {R : D} [MonObj R] {M : Mod D R} {N : Mod D R} + [Preadditive D] [MonoidalPreadditive D] + {X Y : D} (m : X ⟶ M.X) (n n' : Y ⟶ N.X) : + gpair m (n + n') = gpair (M := M) m n + gpair (M := M) m n' := by + rw [gpair_def, gpair_def, gpair_def, MonoidalPreadditive.tensor_add, + Preadditive.add_comp] + +end Additive + +section Homogeneous + +/-- The pairing is ℂ-homogeneous in its left argument. -/ +theorem smul_gpair [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] {R : D} [MonObj R] {M : Mod D R} {N : Mod D R} + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + (r : ℂ) {X Y : D} (m : X ⟶ M.X) (n : Y ⟶ N.X) : + gpair (r • m) n = r • gpair (M := M) (N := N) m n := by + have h : (r • m) ⊗ₘ n = r • (m ⊗ₘ n) := by + rw [tensorHom_def, tensorHom_def, + MonoidalLinear.smul_whiskerRight, Linear.smul_comp] + rw [gpair_def, gpair_def, h, Linear.smul_comp] + +/-- The pairing is ℂ-homogeneous in its right argument. -/ +theorem gpair_smul [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] {R : D} [MonObj R] {M : Mod D R} {N : Mod D R} + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + (r : ℂ) {X Y : D} (m : X ⟶ M.X) (n : Y ⟶ N.X) : + gpair m (r • n) = r • gpair (M := M) (N := N) m n := by + have h : m ⊗ₘ (r • n) = r • (m ⊗ₘ n) := by + rw [tensorHom_def', tensorHom_def', + MonoidalLinear.whiskerLeft_smul, Linear.smul_comp] + rw [gpair_def, gpair_def, h, Linear.smul_comp] + +end Homogeneous + +/-! ### The bundled bilinear pairing -/ + +section Bundled + +/-- The pairing as a ℂ-bilinear map of hom-modules, transported +along a chosen morphism `s` from the intended source into the +tensor product of the two given sources. The four graded blocks of +the comparison map of `RS.gammaPairComparison` are the four +instances of this construction. -/ +noncomputable def gpairLin + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] {R : D} [MonObj R] [Preadditive D] + [MonoidalPreadditive D] [Linear ℂ D] [MonoidalLinear ℂ D] + (M N : Mod D R) {W X Y : D} + (s : W ⟶ X ⊗ Y) : + (X ⟶ M.X) →ₗ[ℂ] (Y ⟶ N.X) →ₗ[ℂ] (W ⟶ modTensor R M N) := + LinearMap.mk₂ ℂ (fun m n => s ≫ gpair m n) + (fun m m' n => by rw [add_gpair, Preadditive.comp_add]) + (fun r m n => by rw [smul_gpair, Linear.comp_smul]) + (fun m n n' => by rw [gpair_add, Preadditive.comp_add]) + (fun r m n => by rw [gpair_smul, Linear.comp_smul]) + +@[simp] +theorem gpairLin_apply [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] {R : D} [MonObj R] [Preadditive D] + [MonoidalPreadditive D] [Linear ℂ D] [MonoidalLinear ℂ D] + (M N : Mod D R) {W X Y : D} (s : W ⟶ X ⊗ Y) + (m : X ⟶ M.X) (n : Y ⟶ N.X) : + gpairLin M N s m n = s ≫ gpair m n := rfl + +end Bundled + +end Pairing + +/-! ## The balance law -/ + +section Balance + +variable {D : Type u} + +/-- **The balance law**: a scalar may be moved from the left +argument of the pairing to the right one, at the cost of braiding +the scalar past the left source. This is the defining relation of +the relative tensor product, `RS.modTensor_condition`, written in +the language of the pairing. -/ +theorem gpair_balance + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] {R : D} [MonObj R] {M : Mod D R} {N : Mod D R} + {X Y Z : D} (a : X ⟶ R) (m : Y ⟶ M.X) + (n : Z ⟶ N.X) : + gpair (gact a m) n = + (β_ X Y).hom ▷ Z ≫ (α_ Y X Z).hom ≫ + gpair (M := M) m (gact a n) := by + have hl : ((a ⊗ₘ m) ⊗ₘ n) ≫ actLeft R M.X ▷ N.X ≫ + modTensorπ R M N = gpair (gact a m) n := by + rw [← Category.assoc, ← tensorHom_id, tensorHom_comp_tensorHom, + Category.comp_id] + rfl + have hr : (m ⊗ₘ (a ⊗ₘ n)) ≫ M.X ◁ actLeft R N.X ≫ + modTensorπ R M N = gpair (M := M) m (gact a n) := by + rw [← Category.assoc, ← id_tensorHom, tensorHom_comp_tensorHom, + Category.comp_id] + rfl + have hleg : M.X ◁ actLeft R N.X ≫ modTensorπ R M N = + (α_ M.X R N.X).inv ≫ actRight R M.X ▷ N.X ≫ + modTensorπ R M N := by + have h := modTensor_condition R M N + rw [modTensorLegM, modTensorLegN] at h + rw [h] + simp only [Category.assoc] + rw [Iso.inv_hom_id_assoc] + have hbr : (β_ X Y).hom ▷ Z ≫ ((m ⊗ₘ a) ⊗ₘ n) = + ((a ⊗ₘ m) ⊗ₘ n) ≫ (β_ R M.X).hom ▷ N.X := by + rw [← tensorHom_id ((β_ X Y).hom) Z, + ← tensorHom_id ((β_ R M.X).hom) N.X, + tensorHom_comp_tensorHom, tensorHom_comp_tensorHom, + Category.id_comp, Category.comp_id, + ← BraidedCategory.braiding_naturality] + have hsym : (β_ R M.X).hom ▷ N.X ≫ actRight R M.X ▷ N.X = + actLeft R M.X ▷ N.X := by + rw [← comp_whiskerRight, actRight, + SymmetricCategory.symmetry_assoc] + rw [← hl, ← hr, hleg, ← associator_naturality_assoc, + Iso.hom_inv_id_assoc, reassoc_of% hbr, reassoc_of% hsym] + +/-! ### The transported balance law -/ + +section Bundled + +/-- The balance law with both sources reindexed, in the form used +to discharge the eight balancing hypotheses: the two source +identifications may be replaced by a single comparison morphism. -/ +theorem gpairLin_balance_comp + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] {R : D} [MonObj R] {M : Mod D R} {N : Mod D R} + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + {W V X Y Z : D} (s₁ : W ⟶ V ⊗ Z) + (s₂ : V ⟶ X ⊗ Y) (a : X ⟶ R) (m : Y ⟶ M.X) (n : Z ⟶ N.X) : + gpairLin M N s₁ (gactLin s₂ a m) n = + (s₁ ≫ (s₂ ≫ (β_ X Y).hom) ▷ Z ≫ (α_ Y X Z).hom) ≫ + gpair (M := M) m (gact a n) := by + rw [gpairLin_apply, gactLin_apply, comp_gpair, gpair_balance, + comp_whiskerRight] + simp only [Category.assoc] + +/-- **The transported balance law**: given a coherence identity +between the two ways of reindexing the sources, a scalar may be +moved from the left argument of the pairing to the right one. -/ +theorem gpairLin_balance + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] {R : D} [MonObj R] {M : Mod D R} {N : Mod D R} + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + {W V U X Y Z : D} (s₁ : W ⟶ V ⊗ Z) + (s₂ : V ⟶ X ⊗ Y) (s₃ : W ⟶ Y ⊗ U) (s₄ : U ⟶ X ⊗ Z) + (h : s₁ ≫ (s₂ ≫ (β_ X Y).hom) ▷ Z ≫ (α_ Y X Z).hom = + s₃ ≫ Y ◁ s₄) + (a : X ⟶ R) (m : Y ⟶ M.X) (n : Z ⟶ N.X) : + gpairLin M N s₁ (gactLin s₂ a m) n = + gpairLin M N s₃ m (gactLin s₄ a n) := by + rw [gpairLin_balance_comp, h, gpairLin_apply, gactLin_apply, + gpair_comp] + simp only [Category.assoc] + +/-- **The transported balance law with a Koszul sign**: the +coherence identity may hold only up to sign, and then so does the +balance law. The sign arises from `RS.OddLine.braid_neg`, in +exactly the two cases where the scalar and the left argument are +both odd. -/ +theorem gpairLin_balance_neg + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] {R : D} [MonObj R] {M : Mod D R} {N : Mod D R} + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + {W V U X Y Z : D} (s₁ : W ⟶ V ⊗ Z) + (s₂ : V ⟶ X ⊗ Y) (s₃ : W ⟶ Y ⊗ U) (s₄ : U ⟶ X ⊗ Z) + (h : s₁ ≫ (s₂ ≫ (β_ X Y).hom) ▷ Z ≫ (α_ Y X Z).hom = + -(s₃ ≫ Y ◁ s₄)) + (a : X ⟶ R) (m : Y ⟶ M.X) (n : Z ⟶ N.X) : + gpairLin M N s₁ (gactLin s₂ a m) n = + -gpairLin M N s₃ m (gactLin s₄ a n) := by + rw [gpairLin_balance_comp, h, Preadditive.neg_comp, gpairLin_apply, + gactLin_apply, gpair_comp] + simp only [Category.assoc] + +end Bundled + +end Balance + +/-! ## The action law -/ + +section ActLaw + +variable {D : Type u} + +/-- **The action law**: the descended action of `R` on the +relative tensor product is the action on the left factor of a +pairing, up to the associator of the three sources. -/ +theorem gact_gpair [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + {R : D} [MonObj R] [IsCommMonObj R] {M : Mod D R} {N : Mod D R} + {X Y Z : D} (a : X ⟶ R) (m : Y ⟶ M.X) + (n : Z ⟶ N.X) : + gact (M := (modTensorMod R M N).X) a (gpair m n) = + (α_ X Y Z).inv ≫ gpair (gact a m) n := by + have hl : ((a ⊗ₘ m) ⊗ₘ n) ≫ actLeft R M.X ▷ N.X ≫ + modTensorπ R M N = gpair (gact a m) n := by + rw [← Category.assoc, ← tensorHom_id, tensorHom_comp_tensorHom, + Category.comp_id] + rfl + have hr : (a ⊗ₘ (m ⊗ₘ n)) ≫ R ◁ modTensorπ R M N ≫ + modTensorAct R M N = + gact (M := (modTensorMod R M N).X) a (gpair m n) := by + rw [← Category.assoc, ← id_tensorHom, tensorHom_comp_tensorHom, + Category.comp_id] + rfl + rw [← hl, ← hr, whiskerLeft_modTensorπ_act] + simp only [Category.assoc] + rw [← associator_inv_naturality_assoc] + +/-- The action law with the descended action named explicitly. +This is `RS.gact_gpair` retyped along `RS.modTensorMod_X`, and is +the form in which the law is transported. -/ +theorem gpair_modTensorAct + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + {R : D} [MonObj R] [IsCommMonObj R] {M : Mod D R} {N : Mod D R} + {X Y Z : D} (a : X ⟶ R) (m : Y ⟶ M.X) + (n : Z ⟶ N.X) : + (a ⊗ₘ gpair (M := M) (N := N) m n) ≫ modTensorAct R M N = + (α_ X Y Z).inv ≫ gpair (gact a m) n := + gact_gpair a m n + +section Bundled + +/-- **The transported action law**: given a coherence identity +between the two ways of reindexing the sources, acting on the +relative tensor product is acting on the left factor. -/ +theorem gpairLin_act [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + {R : D} [MonObj R] [IsCommMonObj R] {M : Mod D R} {N : Mod D R} + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + {W V U X Y Z : D} (s₁ : W ⟶ X ⊗ V) + (s₂ : V ⟶ Y ⊗ Z) (s₃ : W ⟶ U ⊗ Z) (s₄ : U ⟶ X ⊗ Y) + (h : s₁ ≫ X ◁ s₂ ≫ (α_ X Y Z).inv = s₃ ≫ s₄ ▷ Z) + (a : X ⟶ R) (m : Y ⟶ M.X) (n : Z ⟶ N.X) : + s₁ ≫ (a ⊗ₘ gpairLin M N s₂ m n) ≫ modTensorAct R M N = + gpairLin M N s₃ (gactLin s₄ a m) n := by + have e : (a ⊗ₘ (s₂ ≫ gpair (M := M) (N := N) m n)) ≫ + modTensorAct R M N = + X ◁ s₂ ≫ (a ⊗ₘ gpair (M := M) (N := N) m n) ≫ + modTensorAct R M N := by + rw [← Category.assoc, ← id_tensorHom, tensorHom_comp_tensorHom, + Category.id_comp] + rw [gpairLin_apply, e, gpair_modTensorAct, gpairLin_apply, + gactLin_apply, comp_gpair, reassoc_of% h] + +end Bundled + +end ActLaw + +/-! ## Coherence for the four source identifications -/ + +section Coherence + +variable {D : Type u} + +/-- Braiding past the unit on the left turns the left unitor into +the right one. -/ +theorem leftUnitor_inv_braiding + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (Y : D) : + (λ_ Y).inv ≫ (β_ (𝟙_ D) Y).hom = (ρ_ Y).inv := by + rw [← cancel_mono (ρ_ Y).hom, Category.assoc, braiding_rightUnitor, + Iso.inv_hom_id, Iso.inv_hom_id] + +/-- Braiding past the unit on the right turns the right unitor into +the left one. -/ +theorem rightUnitor_inv_braiding + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (Y : D) : + (ρ_ Y).inv ≫ (β_ Y (𝟙_ D)).hom = (λ_ Y).inv := by + rw [← cancel_mono (λ_ Y).hom, Category.assoc, braiding_leftUnitor, + Iso.inv_hom_id, Iso.inv_hom_id] + +/-- **The Koszul sign**: braiding the square trivialisation of the +odd line past itself is `RS.OddLine.braid_neg`. -/ +theorem oddLine_sq_inv_braiding + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] + (L : OddLine D) : + L.sq.inv ≫ (β_ L.obj L.obj).hom = -L.sq.inv := by + rw [L.braid_neg, Preadditive.comp_neg, Category.comp_id] + +/-- Reassociating the square trivialisation against a left unitor: +the odd-even-odd source identifications agree. -/ +theorem oddLine_sq_leftUnitor + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] + (L : OddLine D) : + L.sq.inv ≫ (λ_ L.obj).inv ▷ L.obj ≫ + (α_ (𝟙_ D) L.obj L.obj).hom = + (λ_ (𝟙_ D)).inv ≫ (𝟙_ D) ◁ L.sq.inv := by + have hc : (λ_ L.obj).inv ▷ L.obj ≫ + (α_ (𝟙_ D) L.obj L.obj).hom = (λ_ (L.obj ⊗ L.obj)).inv := by + monoidal + rw [hc] + exact leftUnitor_inv_naturality L.sq.inv + +/-- The same identity read from the other end. -/ +theorem oddLine_sq_leftUnitor' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] + (L : OddLine D) : + (λ_ (𝟙_ D)).inv ≫ (𝟙_ D) ◁ L.sq.inv ≫ + (α_ (𝟙_ D) L.obj L.obj).inv = + L.sq.inv ≫ (λ_ L.obj).inv ▷ L.obj := by + rw [← reassoc_of% oddLine_sq_leftUnitor L, Iso.hom_inv_id, + Category.comp_id] + +/-- Reassociating the square trivialisation against a right +unitor: the odd-odd-even source identifications agree. -/ +theorem oddLine_sq_rightUnitor + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] + (L : OddLine D) : + (λ_ (𝟙_ D)).inv ≫ L.sq.inv ▷ (𝟙_ D) ≫ + (α_ L.obj L.obj (𝟙_ D)).hom = + L.sq.inv ≫ L.obj ◁ (ρ_ L.obj).inv := by + have hc : (ρ_ (L.obj ⊗ L.obj)).inv ≫ + (α_ L.obj L.obj (𝟙_ D)).hom = L.obj ◁ (ρ_ L.obj).inv := by + monoidal + rw [unitors_inv_equal, ← Category.assoc, + ← rightUnitor_inv_naturality, Category.assoc, hc] + +/-- The same identity read from the other end. -/ +theorem oddLine_sq_rightUnitor' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] + (L : OddLine D) : + L.sq.inv ≫ L.obj ◁ (ρ_ L.obj).inv ≫ + (α_ L.obj L.obj (𝟙_ D)).inv = + (λ_ (𝟙_ D)).inv ≫ L.sq.inv ▷ (𝟙_ D) := by + rw [← reassoc_of% oddLine_sq_rightUnitor L, Iso.hom_inv_id, + Category.comp_id] + +/-- **The odd-odd-odd coherence identity**, the one identity not +implied by coherence alone: it is the first triangle identity of +the self-duality of the odd line. -/ +theorem oddLine_sq_assoc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] + (L : OddLine D) : + (λ_ L.obj).inv ≫ L.sq.inv ▷ L.obj ≫ + (α_ L.obj L.obj L.obj).hom = + (ρ_ L.obj).inv ≫ L.obj ◁ L.sq.inv := by + have h2 : L.sq.inv ▷ L.obj ≫ (α_ L.obj L.obj L.obj).hom = + (λ_ L.obj).hom ≫ (ρ_ L.obj).inv ≫ L.obj ◁ L.sq.inv := by + rw [← reassoc_of% L.evaluation_coevaluation, + ← MonoidalCategory.whiskerLeft_comp, Iso.hom_inv_id, + MonoidalCategory.whiskerLeft_id, Category.comp_id] + rw [h2, ← Category.assoc, Iso.inv_hom_id, Category.id_comp] + +/-- The same identity read from the other end. -/ +theorem oddLine_sq_assoc' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] + (L : OddLine D) : + (ρ_ L.obj).inv ≫ L.obj ◁ L.sq.inv ≫ + (α_ L.obj L.obj L.obj).inv = + (λ_ L.obj).inv ≫ L.sq.inv ▷ L.obj := by + rw [← reassoc_of% oddLine_sq_assoc L, Iso.hom_inv_id, + Category.comp_id] + +end Coherence + +/-! ## The eight balancing laws -/ + +section Eight + +variable {D : Type u} + +/-- Balancing at parity pattern even-even-even. -/ +theorem gpair_balanced_eee + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] {R : D} [MonObj R] + (M : Mod D R) (N : Mod D R) + (b : 𝟙_ D ⟶ R) (m : 𝟙_ D ⟶ M.X) + (n : 𝟙_ D ⟶ N.X) : + gpairLin M N (λ_ (𝟙_ D)).inv (gactLin (λ_ (𝟙_ D)).inv b m) n = + gpairLin M N (λ_ (𝟙_ D)).inv m + (gactLin (λ_ (𝟙_ D)).inv b n) := by + refine gpairLin_balance _ _ _ _ ?_ b m n + rw [leftUnitor_inv_braiding] + monoidal + +/-- Balancing at parity pattern even-odd-odd. -/ +theorem gpair_balanced_eoo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] (L : OddLine D) {R : D} + [MonObj R] (M : Mod D R) (N : Mod D R) + (b : 𝟙_ D ⟶ R) (m : L.obj ⟶ M.X) + (n : L.obj ⟶ N.X) : + gpairLin M N L.sq.inv (gactLin (λ_ L.obj).inv b m) n = + gpairLin M N L.sq.inv m (gactLin (λ_ L.obj).inv b n) := by + refine gpairLin_balance _ _ _ _ ?_ b m n + rw [leftUnitor_inv_braiding] + monoidal + +/-- Balancing at parity pattern odd-even-odd: the scalar is odd and +the left argument even, so there is no sign. -/ +theorem gpair_balanced_oeo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] (L : OddLine D) {R : D} + [MonObj R] (M : Mod D R) (N : Mod D R) + (c : L.obj ⟶ R) (m : 𝟙_ D ⟶ M.X) + (n : L.obj ⟶ N.X) : + gpairLin M N L.sq.inv (gactLin (ρ_ L.obj).inv c m) n = + gpairLin M N (λ_ (𝟙_ D)).inv m (gactLin L.sq.inv c n) := by + refine gpairLin_balance _ _ _ _ ?_ c m n + rw [rightUnitor_inv_braiding] + exact oddLine_sq_leftUnitor L + +/-- Balancing at parity pattern odd-odd-even: the scalar and the +left argument are both odd, so the Koszul sign appears. -/ +theorem gpair_balanced_ooe + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] (L : OddLine D) {R : D} + [MonObj R] (M : Mod D R) (N : Mod D R) + (c : L.obj ⟶ R) (m : L.obj ⟶ M.X) + (n : 𝟙_ D ⟶ N.X) : + gpairLin M N (λ_ (𝟙_ D)).inv (gactLin L.sq.inv c m) n = + -gpairLin M N L.sq.inv m (gactLin (ρ_ L.obj).inv c n) := by + refine gpairLin_balance_neg _ _ _ _ ?_ c m n + rw [oddLine_sq_inv_braiding, neg_whiskerRight, + Preadditive.neg_comp, Preadditive.comp_neg, neg_inj] + exact oddLine_sq_rightUnitor L + +/-- Balancing at parity pattern even-even-odd. -/ +theorem gpair_balanced_eeo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] (L : OddLine D) {R : D} + [MonObj R] (M : Mod D R) (N : Mod D R) + (b : 𝟙_ D ⟶ R) (m : 𝟙_ D ⟶ M.X) + (n : L.obj ⟶ N.X) : + gpairLin M N (λ_ L.obj).inv (gactLin (λ_ (𝟙_ D)).inv b m) n = + gpairLin M N (λ_ L.obj).inv m (gactLin (λ_ L.obj).inv b n) := by + refine gpairLin_balance _ _ _ _ ?_ b m n + rw [leftUnitor_inv_braiding] + monoidal + +/-- Balancing at parity pattern even-odd-even. -/ +theorem gpair_balanced_eoe + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] (L : OddLine D) {R : D} + [MonObj R] (M : Mod D R) (N : Mod D R) + (b : 𝟙_ D ⟶ R) (m : L.obj ⟶ M.X) + (n : 𝟙_ D ⟶ N.X) : + gpairLin M N (ρ_ L.obj).inv (gactLin (λ_ L.obj).inv b m) n = + gpairLin M N (ρ_ L.obj).inv m + (gactLin (λ_ (𝟙_ D)).inv b n) := by + refine gpairLin_balance _ _ _ _ ?_ b m n + rw [leftUnitor_inv_braiding] + monoidal + +/-- Balancing at parity pattern odd-even-even: the left argument is +even, so there is no sign. -/ +theorem gpair_balanced_oee + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] (L : OddLine D) {R : D} + [MonObj R] (M : Mod D R) (N : Mod D R) + (c : L.obj ⟶ R) (m : 𝟙_ D ⟶ M.X) + (n : 𝟙_ D ⟶ N.X) : + gpairLin M N (ρ_ L.obj).inv (gactLin (ρ_ L.obj).inv c m) n = + gpairLin M N (λ_ L.obj).inv m (gactLin (ρ_ L.obj).inv c n) := by + refine gpairLin_balance _ _ _ _ ?_ c m n + rw [rightUnitor_inv_braiding] + monoidal + +/-- Balancing at parity pattern odd-odd-odd: the scalar and the +left argument are both odd, so the Koszul sign appears. -/ +theorem gpair_balanced_ooo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] (L : OddLine D) {R : D} + [MonObj R] (M : Mod D R) (N : Mod D R) + (c : L.obj ⟶ R) (m : L.obj ⟶ M.X) + (n : L.obj ⟶ N.X) : + gpairLin M N (λ_ L.obj).inv (gactLin L.sq.inv c m) n = + -gpairLin M N (ρ_ L.obj).inv m (gactLin L.sq.inv c n) := by + refine gpairLin_balance_neg _ _ _ _ ?_ c m n + rw [oddLine_sq_inv_braiding, neg_whiskerRight, + Preadditive.neg_comp, Preadditive.comp_neg, neg_inj] + exact oddLine_sq_assoc L + +end Eight + +/-! ## The eight action laws -/ + +section EightAct + +variable {D : Type u} + +/-- The action law at parity pattern even-even-even. -/ +theorem gpair_act_eee + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + {R : D} [MonObj R] [IsCommMonObj R] (M : Mod D R) (N : Mod D R) + (x : 𝟙_ D ⟶ R) (m : 𝟙_ D ⟶ M.X) + (n : 𝟙_ D ⟶ N.X) : + gactLin (M := (modTensorMod R M N).X) (λ_ (𝟙_ D)).inv x + (gpairLin M N (λ_ (𝟙_ D)).inv m n) = + gpairLin M N (λ_ (𝟙_ D)).inv + (gactLin (λ_ (𝟙_ D)).inv x m) n := + gpairLin_act _ _ _ _ (by monoidal) x m n + +/-- The action law at parity pattern even-odd-odd. -/ +theorem gpair_act_eoo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) {R : D} [MonObj R] [IsCommMonObj R] (M : Mod D R) + (N : Mod D R) + (x : 𝟙_ D ⟶ R) (m : L.obj ⟶ M.X) + (n : L.obj ⟶ N.X) : + gactLin (M := (modTensorMod R M N).X) (λ_ (𝟙_ D)).inv x + (gpairLin M N L.sq.inv m n) = + gpairLin M N L.sq.inv (gactLin (λ_ L.obj).inv x m) n := + gpairLin_act _ _ _ _ (oddLine_sq_leftUnitor' L) x m n + +/-- The action law at parity pattern even-even-odd. -/ +theorem gpair_act_eeo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) {R : D} [MonObj R] [IsCommMonObj R] (M : Mod D R) + (N : Mod D R) + (x : 𝟙_ D ⟶ R) (m : 𝟙_ D ⟶ M.X) + (n : L.obj ⟶ N.X) : + gactLin (M := (modTensorMod R M N).X) (λ_ L.obj).inv x + (gpairLin M N (λ_ L.obj).inv m n) = + gpairLin M N (λ_ L.obj).inv (gactLin (λ_ (𝟙_ D)).inv x m) n := + gpairLin_act _ _ _ _ (by monoidal) x m n + +/-- The action law at parity pattern even-odd-even. -/ +theorem gpair_act_eoe + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) {R : D} [MonObj R] [IsCommMonObj R] (M : Mod D R) + (N : Mod D R) + (x : 𝟙_ D ⟶ R) (m : L.obj ⟶ M.X) + (n : 𝟙_ D ⟶ N.X) : + gactLin (M := (modTensorMod R M N).X) (λ_ L.obj).inv x + (gpairLin M N (ρ_ L.obj).inv m n) = + gpairLin M N (ρ_ L.obj).inv (gactLin (λ_ L.obj).inv x m) n := + gpairLin_act _ _ _ _ (by monoidal) x m n + +/-- The action law at parity pattern odd-even-even. -/ +theorem gpair_act_oee + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) {R : D} [MonObj R] [IsCommMonObj R] (M : Mod D R) + (N : Mod D R) + (u : L.obj ⟶ R) (m : 𝟙_ D ⟶ M.X) + (n : 𝟙_ D ⟶ N.X) : + gactLin (M := (modTensorMod R M N).X) (ρ_ L.obj).inv u + (gpairLin M N (λ_ (𝟙_ D)).inv m n) = + gpairLin M N (ρ_ L.obj).inv (gactLin (ρ_ L.obj).inv u m) n := + gpairLin_act _ _ _ _ (by monoidal) u m n + +/-- The action law at parity pattern odd-odd-odd. -/ +theorem gpair_act_ooo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) {R : D} [MonObj R] [IsCommMonObj R] (M : Mod D R) + (N : Mod D R) + (u : L.obj ⟶ R) (m : L.obj ⟶ M.X) + (n : L.obj ⟶ N.X) : + gactLin (M := (modTensorMod R M N).X) (ρ_ L.obj).inv u + (gpairLin M N L.sq.inv m n) = + gpairLin M N (λ_ L.obj).inv (gactLin L.sq.inv u m) n := + gpairLin_act _ _ _ _ (oddLine_sq_assoc' L) u m n + +/-- The action law at parity pattern odd-even-odd. -/ +theorem gpair_act_oeo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) {R : D} [MonObj R] [IsCommMonObj R] (M : Mod D R) + (N : Mod D R) + (u : L.obj ⟶ R) (m : 𝟙_ D ⟶ M.X) + (n : L.obj ⟶ N.X) : + gactLin (M := (modTensorMod R M N).X) L.sq.inv u + (gpairLin M N (λ_ L.obj).inv m n) = + gpairLin M N L.sq.inv (gactLin (ρ_ L.obj).inv u m) n := + gpairLin_act _ _ _ _ (by monoidal) u m n + +/-- The action law at parity pattern odd-odd-even. -/ +theorem gpair_act_ooe + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) {R : D} [MonObj R] [IsCommMonObj R] (M : Mod D R) + (N : Mod D R) + (u : L.obj ⟶ R) (m : L.obj ⟶ M.X) + (n : 𝟙_ D ⟶ N.X) : + gactLin (M := (modTensorMod R M N).X) L.sq.inv u + (gpairLin M N (ρ_ L.obj).inv m n) = + gpairLin M N (λ_ (𝟙_ D)).inv (gactLin L.sq.inv u m) n := + gpairLin_act _ _ _ _ (oddLine_sq_rightUnitor' L) u m n + +end EightAct + +/-! ## The comparison map -/ + +section Comparison + +variable {D : Type u} + +open SuperCommAlgebra.Mod + +/-- The even block of the comparison map: the pairing on the +even-even and odd-odd blocks, factored through the even part of +the tensor product of super modules by its universal property. -/ +noncomputable def gammaPairEven + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (M : Mod D R) + (N : Mod D R) : + ((gammaModule D L R M.X).tensor (gammaModule D L R N.X)).even + →ₗ[ℂ] (gammaModule D L R (modTensorMod R M N).X).even := + liftEven (gammaModule D L R M.X) (gammaModule D L R N.X) + (gpairLin M N (λ_ (𝟙_ D)).inv) (gpairLin M N L.sq.inv) + (gpair_balanced_eee M N) (gpair_balanced_eoo L M N) + (gpair_balanced_oeo L M N) (gpair_balanced_ooe L M N) + +/-- The odd block of the comparison map: the pairing on the +even-odd and odd-even blocks, factored through the odd part of the +tensor product of super modules by its universal property. -/ +noncomputable def gammaPairOdd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (M : Mod D R) + (N : Mod D R) : + ((gammaModule D L R M.X).tensor (gammaModule D L R N.X)).odd + →ₗ[ℂ] (gammaModule D L R (modTensorMod R M N).X).odd := + liftOdd (gammaModule D L R M.X) (gammaModule D L R N.X) + (gpairLin M N (λ_ L.obj).inv) (gpairLin M N (ρ_ L.obj).inv) + (gpair_balanced_eeo L M N) (gpair_balanced_eoe L M N) + (gpair_balanced_oee L M N) (gpair_balanced_ooo L M N) + +/-- The even block on even-even generators. -/ +@[simp] theorem gammaPairEven_tmulEE + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (M : Mod D R) + (N : Mod D R) + (m : 𝟙_ D ⟶ M.X) (n : 𝟙_ D ⟶ N.X) : + gammaPairEven L R M N + (tmulEE (gammaModule D L R M.X) (gammaModule D L R N.X) + m n) = gpairLin M N (λ_ (𝟙_ D)).inv m n := + liftEven_tmulEE (gammaModule D L R M.X) (gammaModule D L R N.X) + (gpairLin M N (λ_ (𝟙_ D)).inv) (gpairLin M N L.sq.inv) + (gpair_balanced_eee M N) (gpair_balanced_eoo L M N) + (gpair_balanced_oeo L M N) (gpair_balanced_ooe L M N) m n + +/-- The even block on odd-odd generators. -/ +@[simp] theorem gammaPairEven_tmulOO + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (M : Mod D R) + (N : Mod D R) + (m : L.obj ⟶ M.X) (n : L.obj ⟶ N.X) : + gammaPairEven L R M N + (tmulOO (gammaModule D L R M.X) (gammaModule D L R N.X) + m n) = gpairLin M N L.sq.inv m n := + liftEven_tmulOO (gammaModule D L R M.X) (gammaModule D L R N.X) + (gpairLin M N (λ_ (𝟙_ D)).inv) (gpairLin M N L.sq.inv) + (gpair_balanced_eee M N) (gpair_balanced_eoo L M N) + (gpair_balanced_oeo L M N) (gpair_balanced_ooe L M N) m n + +/-- The odd block on even-odd generators. -/ +@[simp] theorem gammaPairOdd_tmulEO + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (M : Mod D R) + (N : Mod D R) + (m : 𝟙_ D ⟶ M.X) (n : L.obj ⟶ N.X) : + gammaPairOdd L R M N + (tmulEO (gammaModule D L R M.X) (gammaModule D L R N.X) + m n) = gpairLin M N (λ_ L.obj).inv m n := + liftOdd_tmulEO (gammaModule D L R M.X) (gammaModule D L R N.X) + (gpairLin M N (λ_ L.obj).inv) (gpairLin M N (ρ_ L.obj).inv) + (gpair_balanced_eeo L M N) (gpair_balanced_eoe L M N) + (gpair_balanced_oee L M N) (gpair_balanced_ooo L M N) m n + +/-- The odd block on odd-even generators. -/ +@[simp] theorem gammaPairOdd_tmulOE + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (M : Mod D R) + (N : Mod D R) + (m : L.obj ⟶ M.X) (n : 𝟙_ D ⟶ N.X) : + gammaPairOdd L R M N + (tmulOE (gammaModule D L R M.X) (gammaModule D L R N.X) + m n) = gpairLin M N (ρ_ L.obj).inv m n := + liftOdd_tmulOE (gammaModule D L R M.X) (gammaModule D L R N.X) + (gpairLin M N (λ_ L.obj).inv) (gpairLin M N (ρ_ L.obj).inv) + (gpair_balanced_eeo L M N) (gpair_balanced_eoe L M N) + (gpair_balanced_oee L M N) (gpair_balanced_ooo L M N) m n + +/-- The even block intertwines the action of an even scalar. -/ +theorem gammaPairEven_actEE + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (M : Mod D R) + (N : Mod D R) + (x : 𝟙_ D ⟶ R) + (t : ((gammaModule D L R M.X).tensor + (gammaModule D L R N.X)).even) : + gammaPairEven L R M N + (((gammaModule D L R M.X).tensor + (gammaModule D L R N.X)).actEE x t) = + (gammaModule D L R (modTensorMod R M N).X).actEE x + (gammaPairEven L R M N t) := by + have key : (gammaPairEven L R M N).comp + (((gammaModule D L R M.X).tensor + (gammaModule D L R N.X)).actEE x) = + ((gammaModule D L R (modTensorMod R M N).X).actEE x).comp + (gammaPairEven L R M N) := by + refine liftEven_unique _ _ _ _ ?_ ?_ + · intro m n + change gammaPairEven L R M N (tmulEE _ _ + ((gammaModule D L R M.X).actEE x m) n) = + (gammaModule D L R (modTensorMod R M N).X).actEE x + (gammaPairEven L R M N (tmulEE _ _ m n)) + erw [gammaPairEven_tmulEE, gammaPairEven_tmulEE] + exact (gpair_act_eee M N x m n).symm + · intro m n + change gammaPairEven L R M N (tmulOO _ _ + ((gammaModule D L R M.X).actEO x m) n) = + (gammaModule D L R (modTensorMod R M N).X).actEE x + (gammaPairEven L R M N (tmulOO _ _ m n)) + erw [gammaPairEven_tmulOO, gammaPairEven_tmulOO] + exact (gpair_act_eoo L M N x m n).symm + exact LinearMap.congr_fun key t + +/-- The odd block intertwines the action of an even scalar. -/ +theorem gammaPairOdd_actEO + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (M : Mod D R) + (N : Mod D R) + (x : 𝟙_ D ⟶ R) + (t : ((gammaModule D L R M.X).tensor + (gammaModule D L R N.X)).odd) : + gammaPairOdd L R M N + (((gammaModule D L R M.X).tensor + (gammaModule D L R N.X)).actEO x t) = + (gammaModule D L R (modTensorMod R M N).X).actEO x + (gammaPairOdd L R M N t) := by + have key : (gammaPairOdd L R M N).comp + (((gammaModule D L R M.X).tensor + (gammaModule D L R N.X)).actEO x) = + ((gammaModule D L R (modTensorMod R M N).X).actEO x).comp + (gammaPairOdd L R M N) := by + refine liftOdd_unique _ _ _ _ ?_ ?_ + · intro m n + change gammaPairOdd L R M N (tmulEO _ _ + ((gammaModule D L R M.X).actEE x m) n) = + (gammaModule D L R (modTensorMod R M N).X).actEO x + (gammaPairOdd L R M N (tmulEO _ _ m n)) + erw [gammaPairOdd_tmulEO, gammaPairOdd_tmulEO] + exact (gpair_act_eeo L M N x m n).symm + · intro m n + change gammaPairOdd L R M N (tmulOE _ _ + ((gammaModule D L R M.X).actEO x m) n) = + (gammaModule D L R (modTensorMod R M N).X).actEO x + (gammaPairOdd L R M N (tmulOE _ _ m n)) + erw [gammaPairOdd_tmulOE, gammaPairOdd_tmulOE] + exact (gpair_act_eoe L M N x m n).symm + exact LinearMap.congr_fun key t + +/-- The two blocks intertwine the action of an odd scalar on the +even part. -/ +theorem gammaPairOdd_actOE + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (M : Mod D R) + (N : Mod D R) + (u : L.obj ⟶ R) + (t : ((gammaModule D L R M.X).tensor + (gammaModule D L R N.X)).even) : + gammaPairOdd L R M N + (((gammaModule D L R M.X).tensor + (gammaModule D L R N.X)).actOE u t) = + (gammaModule D L R (modTensorMod R M N).X).actOE u + (gammaPairEven L R M N t) := by + have key : (gammaPairOdd L R M N).comp + (((gammaModule D L R M.X).tensor + (gammaModule D L R N.X)).actOE u) = + ((gammaModule D L R (modTensorMod R M N).X).actOE u).comp + (gammaPairEven L R M N) := by + refine liftEven_unique _ _ _ _ ?_ ?_ + · intro m n + change gammaPairOdd L R M N (tmulOE _ _ + ((gammaModule D L R M.X).actOE u m) n) = + (gammaModule D L R (modTensorMod R M N).X).actOE u + (gammaPairEven L R M N (tmulEE _ _ m n)) + erw [gammaPairOdd_tmulOE, gammaPairEven_tmulEE] + exact (gpair_act_oee L M N u m n).symm + · intro m n + change gammaPairOdd L R M N (tmulEO _ _ + ((gammaModule D L R M.X).actOO u m) n) = + (gammaModule D L R (modTensorMod R M N).X).actOE u + (gammaPairEven L R M N (tmulOO _ _ m n)) + erw [gammaPairOdd_tmulEO, gammaPairEven_tmulOO] + exact (gpair_act_ooo L M N u m n).symm + exact LinearMap.congr_fun key t + +/-- The two blocks intertwine the action of an odd scalar on the +odd part. -/ +theorem gammaPairEven_actOO + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (M : Mod D R) + (N : Mod D R) + (u : L.obj ⟶ R) + (t : ((gammaModule D L R M.X).tensor + (gammaModule D L R N.X)).odd) : + gammaPairEven L R M N + (((gammaModule D L R M.X).tensor + (gammaModule D L R N.X)).actOO u t) = + (gammaModule D L R (modTensorMod R M N).X).actOO u + (gammaPairOdd L R M N t) := by + have key : (gammaPairEven L R M N).comp + (((gammaModule D L R M.X).tensor + (gammaModule D L R N.X)).actOO u) = + ((gammaModule D L R (modTensorMod R M N).X).actOO u).comp + (gammaPairOdd L R M N) := by + refine liftOdd_unique _ _ _ _ ?_ ?_ + · intro m n + change gammaPairEven L R M N (tmulOO _ _ + ((gammaModule D L R M.X).actOE u m) n) = + (gammaModule D L R (modTensorMod R M N).X).actOO u + (gammaPairOdd L R M N (tmulEO _ _ m n)) + erw [gammaPairEven_tmulOO, gammaPairOdd_tmulEO] + exact (gpair_act_oeo L M N u m n).symm + · intro m n + change gammaPairEven L R M N (tmulEE _ _ + ((gammaModule D L R M.X).actOO u m) n) = + (gammaModule D L R (modTensorMod R M N).X).actOO u + (gammaPairOdd L R M N (tmulOE _ _ m n)) + erw [gammaPairEven_tmulEE, gammaPairOdd_tmulOE] + exact (gpair_act_ooe L M N u m n).symm + exact LinearMap.congr_fun key t + +/-- **The comparison map of Deligne's (2.11.1)**: the tensor +product over the Γ-algebra of the two Γ-modules maps to the +Γ-module of the relative tensor product of the two module objects. + +The two blocks are the pairing `RS.gpair` conjugated by the four +source identifications, and they descend by the universal property +of `RS.SuperCommAlgebra.Mod.tensor` because the eight balancing +laws hold; that they are morphisms of super modules is the eight +action laws. -/ +noncomputable def gammaPairComparison + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] (M : Mod D R) + (N : Mod D R) : + (gammaModule D L R M.X).tensor (gammaModule D L R N.X) ⟶ + gammaModule D L R (modTensorMod R M N).X where + evenMap := gammaPairEven L R M N + oddMap := gammaPairOdd L R M N + map_actEE := gammaPairEven_actEE L R M N + map_actEO := gammaPairOdd_actEO L R M N + map_actOE := gammaPairOdd_actOE L R M N + map_actOO := gammaPairEven_actOO L R M N + +end Comparison + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairAdd.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairAdd.lean new file mode 100644 index 0000000000..f3fa3d2592 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairAdd.lean @@ -0,0 +1,145 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModuleFunctor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModMonoidal + +/-! +# Additivity for the comparison map + +The two constructions flanking the comparison map of Deligne's +(2.11.1) are additive: the tensor product of super modules is +additive in each variable, and realization turns a finite sum of +endomorphisms of a module object summing to the identity into a +finite sum of endomorphisms of its realization summing to the +identity. These are what let a decomposition of a module object +into a finite family of retracts be pushed through the comparison. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +namespace SuperCommAlgebra.Mod + +variable {S : SuperCommAlgebra.{u, u}} +variable {M N P Q : S.Mod.{u, u, u, u}} + +/-- The even component of a finite sum of morphisms, pointwise. -/ +theorem sum_evenMap_apply {ι : Type*} (s : Finset ι) + (f : ι → (M ⟶ N)) (m : M.even) : + (∑ i ∈ s, f i).evenMap m = ∑ i ∈ s, (f i).evenMap m := by + classical + induction s using Finset.induction with + | empty => rw [Finset.sum_empty, Finset.sum_empty]; rfl + | @insert a s ha ih => + rw [Finset.sum_insert ha, Finset.sum_insert ha, add_evenMap, + LinearMap.add_apply, ih] + +/-- The odd component of a finite sum of morphisms, pointwise. -/ +theorem sum_oddMap_apply {ι : Type*} (s : Finset ι) + (f : ι → (M ⟶ N)) (m : M.odd) : + (∑ i ∈ s, f i).oddMap m = ∑ i ∈ s, (f i).oddMap m := by + classical + induction s using Finset.induction with + | empty => rw [Finset.sum_empty, Finset.sum_empty]; rfl + | @insert a s ha ih => + rw [Finset.sum_insert ha, Finset.sum_insert ha, add_oddMap, + LinearMap.add_apply, ih] + +/-- **The tensor product of super modules is additive in the left +variable.** -/ +theorem tensorHom_add_left (f f' : M ⟶ P) (g : N ⟶ Q) : + tensorHom (f + f') g = tensorHom f g + tensorHom f' g := by + refine hom_ext (fun m n => ?_) (fun m n => ?_) (fun m n => ?_) + (fun m n => ?_) + · rw [tensorHom_evenMap_tmulEE, add_evenMap, LinearMap.add_apply, + map_add, LinearMap.add_apply, add_evenMap, + LinearMap.add_apply, tensorHom_evenMap_tmulEE, + tensorHom_evenMap_tmulEE] + · rw [tensorHom_evenMap_tmulOO, add_oddMap, LinearMap.add_apply, + map_add, LinearMap.add_apply, add_evenMap, + LinearMap.add_apply, tensorHom_evenMap_tmulOO, + tensorHom_evenMap_tmulOO] + · rw [tensorHom_oddMap_tmulEO, add_evenMap, LinearMap.add_apply, + map_add, LinearMap.add_apply, add_oddMap, + LinearMap.add_apply, tensorHom_oddMap_tmulEO, + tensorHom_oddMap_tmulEO] + · rw [tensorHom_oddMap_tmulOE, add_oddMap, LinearMap.add_apply, + map_add, LinearMap.add_apply, add_oddMap, + LinearMap.add_apply, tensorHom_oddMap_tmulOE, + tensorHom_oddMap_tmulOE] + +/-- The tensor product of super modules kills the zero morphism in +the left variable. -/ +theorem tensorHom_zero_left (g : N ⟶ Q) : + tensorHom (0 : M ⟶ P) g = 0 := by + refine hom_ext (fun m n => ?_) (fun m n => ?_) (fun m n => ?_) + (fun m n => ?_) + · rw [tensorHom_evenMap_tmulEE, zero_evenMap, LinearMap.zero_apply, + map_zero, LinearMap.zero_apply, zero_evenMap, + LinearMap.zero_apply] + · rw [tensorHom_evenMap_tmulOO, zero_oddMap, LinearMap.zero_apply, + map_zero, LinearMap.zero_apply, zero_evenMap, + LinearMap.zero_apply] + · rw [tensorHom_oddMap_tmulEO, zero_evenMap, LinearMap.zero_apply, + map_zero, LinearMap.zero_apply, zero_oddMap, + LinearMap.zero_apply] + · rw [tensorHom_oddMap_tmulOE, zero_oddMap, LinearMap.zero_apply, + map_zero, LinearMap.zero_apply, zero_oddMap, + LinearMap.zero_apply] + +/-- **The tensor product of super modules takes a finite sum in the +left variable to a finite sum.** -/ +theorem tensorHom_sum_left {ι : Type*} (s : Finset ι) + (f : ι → (M ⟶ P)) (g : N ⟶ Q) : + tensorHom (∑ i ∈ s, f i) g = ∑ i ∈ s, tensorHom (f i) g := by + classical + induction s using Finset.induction with + | empty => + rw [Finset.sum_empty, Finset.sum_empty, tensorHom_zero_left] + | @insert a s ha ih => + rw [Finset.sum_insert ha, Finset.sum_insert ha, + tensorHom_add_left, ih] + +end SuperCommAlgebra.Mod + +/-! ## Additivity of realization -/ + +section Realize + +variable {D : Type u} + +/-- **Realization is additive on endomorphisms**: a finite family +of endomorphisms of a module object whose underlying morphisms sum +to the identity realizes to a family summing to the identity. -/ +theorem sum_gammaModuleFunctor_map + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + {P : Mod D R} {ι : Type*} + (s : Finset ι) (g : ι → (P ⟶ P)) + (h : ∑ i ∈ s, (g i).hom = 𝟙 P.X) : + ∑ i ∈ s, (gammaModuleFunctor L R).map (g i) = + 𝟙 ((gammaModuleFunctor L R).obj P) := by + refine SuperCommAlgebra.Mod.Hom.ext ?_ ?_ <;> + refine LinearMap.ext fun m => ?_ + · rw [SuperCommAlgebra.Mod.sum_evenMap_apply] + change ∑ i ∈ s, m ≫ (g i).hom = m + erw [← Preadditive.comp_sum, h, Category.comp_id] + · rw [SuperCommAlgebra.Mod.sum_oddMap_apply] + change ∑ i ∈ s, m ≫ (g i).hom = m + erw [← Preadditive.comp_sum, h, Category.comp_id] + +end Realize + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairFreeFree.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairFreeFree.lean new file mode 100644 index 0000000000..cc44bda574 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairFreeFree.lean @@ -0,0 +1,116 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairFreeMix +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetractRight +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddSquareIso + +/-! +# The comparison map on a pair of free modules + +Putting the two retract reductions together with the odd-line +square: the comparison map of Deligne's (2.11.1) is invertible at +any pair of free modules whose objects become mixed sums after base +change. Every case but the odd line against itself is a unitor. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +section + +variable {D : Type u} + +/-- **The comparison map at the odd line against the unit** is the +right unitor. -/ +instance isIso_gammaPairComparison_freeL_freeUnit + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] : + IsIso (gammaPairComparison L R (freeMod R L.obj) + (freeMod R (𝟙_ D))) := + gammaPairComparison_isIso_of_iso L R (Iso.refl _) + (freeModUnitIso R) + (isIso_gammaPairComparison_unitRight L R (freeMod R L.obj)) + +/-- **The comparison map at the odd line against the free module of +a mixed sum.** -/ +theorem isIso_gammaPairComparison_freeL_mix + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] [HasFiniteBiproducts D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (p q : ℕ) : + IsIso (gammaPairComparison L R (freeMod R L.obj) + (freeMod R (L.mix p q))) := by + classical + refine isIso_gammaPairComparison_of_retracts_right L R + (freeMod R L.obj) + (fun i => freeModMap R (biproduct.ι _ i)) + (fun i => freeModMap R (biproduct.π _ i)) + (freeModMap_biproduct_total R _) ?_ + rintro (j | j) + · exact isIso_gammaPairComparison_freeL_freeUnit L R + · exact isIso_gammaPairComparison_oddSquare L R + +/-- **The comparison map at the odd line against any free module +that becomes a mixed sum.** -/ +theorem isIso_gammaPairComparison_freeL_free + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] [HasFiniteBiproducts D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + {Y : D} {p q : ℕ} + (eY : freeMod R Y ≅ freeMod R (L.mix p q)) : + IsIso (gammaPairComparison L R (freeMod R L.obj) + (freeMod R Y)) := + gammaPairComparison_isIso_of_iso L R (Iso.refl _) eY + (isIso_gammaPairComparison_freeL_mix L R p q) + +/-- **The comparison map of (2.11.1) at a pair of free modules.** -/ +theorem isIso_gammaPairComparison_freeFree + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] [HasFiniteBiproducts D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + {X Y : D} + {p q p' q' : ℕ} + (eX : freeMod R X ≅ freeMod R (L.mix p q)) + (eY : freeMod R Y ≅ freeMod R (L.mix p' q')) : + IsIso (gammaPairComparison L R (freeMod R X) (freeMod R Y)) := + isIso_gammaPairComparison_free L R + (isIso_gammaPairComparison_freeL_free L R eY) eX + +/-- **The monoidal comparison of the fibre functor is an +isomorphism** at any pair of objects that become mixed sums. -/ +theorem isIso_fibreMu_of_mix + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] [HasFiniteBiproducts D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + {X Y : D} {p q p' q' : ℕ} + (eX : freeMod R X ≅ freeMod R (L.mix p q)) + (eY : freeMod R Y ≅ freeMod R (L.mix p' q')) : + IsIso (fibreMu L R X Y) := + isIso_fibreMu L R X Y + (isIso_gammaPairComparison_freeFree L R eX eY) + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairFreeMix.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairFreeMix.lean new file mode 100644 index 0000000000..18c94ddd98 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairFreeMix.lean @@ -0,0 +1,88 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairUnit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeMixRetract + +/-! +# The comparison map on the free module of a mixed sum + +A mixed sum of copies of the unit and of the odd line presents its +free module as a finite family of retracts of free modules on the +two generators, so the comparison map of Deligne's (2.11.1) on it is +invertible as soon as it is invertible on those two. The unit case +is the left unitor of `RS.gammaPairComparison_unitLeft`; the odd +line is passed in as a hypothesis and discharged separately. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +section + +variable {D : Type u} + +/-- **The comparison map is an isomorphism on the free module of +the unit**, since that free module is the regular module. -/ +instance isIso_gammaPairComparison_freeUnit + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (N : Mod D R) : + IsIso (gammaPairComparison L R (freeMod R (𝟙_ D)) N) := + gammaPairComparison_isIso_of_iso L R (freeModUnitIso R) + (Iso.refl N) (isIso_gammaPairComparison_unitLeft L R N) + +/-- **The comparison map is an isomorphism on the free module of a +mixed sum**, given that it is on the free module of the odd +line. -/ +theorem isIso_gammaPairComparison_freeMix + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] [HasFiniteBiproducts D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + {N : Mod D R} + (hL : IsIso (gammaPairComparison L R (freeMod R L.obj) N)) + (p q : ℕ) : + IsIso (gammaPairComparison L R (freeMod R (L.mix p q)) N) := by + classical + refine isIso_gammaPairComparison_of_retracts L R N + (fun i => freeModMap R (biproduct.ι _ i)) + (fun i => freeModMap R (biproduct.π _ i)) + (freeModMap_biproduct_total R _) ?_ + rintro (j | j) + · exact isIso_gammaPairComparison_freeUnit L R N + · exact hL + +/-- **The comparison map is an isomorphism on any free module that +becomes a mixed sum.** -/ +theorem isIso_gammaPairComparison_free + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] [HasFiniteBiproducts D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + {N : Mod D R} + (hL : IsIso (gammaPairComparison L R (freeMod R L.obj) N)) + {X : D} {p q : ℕ} (e : freeMod R X ≅ freeMod R (L.mix p q)) : + IsIso (gammaPairComparison L R (freeMod R X) N) := + gammaPairComparison_isIso_of_iso L R e (Iso.refl N) + (isIso_gammaPairComparison_freeMix L R hL p q) + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairNat.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairNat.lean new file mode 100644 index 0000000000..a8db21ecb5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairNat.lean @@ -0,0 +1,365 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModuleFunctor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPair +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModMonoidal + +/-! +# Naturality of the comparison map + +The comparison map `RS.gammaPairComparison` of Deligne's (2.11.1) +is natural in each of its two module variables: realization +`RS.gammaModuleFunctor` carries a morphism of module objects to a +morphism of Γ-modules, both sides of the comparison map are +functorial in that morphism, and the resulting square commutes. + +Everything rests on one identity, `RS.gpair_naturality`: the +ungraded pairing `RS.gpair` of a morphism into `M` against a +morphism into `N` is natural, that is, +`gpair (m ≫ f.hom) (n ≫ g.hom) = gpair m n ≫ modTensorMap R f g`. +This is the defining equation of `RS.modTensorMap` against +`RS.modTensorπ`, read through the interchange law. Transported +along a source identification it becomes +`RS.gpairLin_naturality`, and the four graded blocks of the +comparison map are four instances of that one statement, one for +each family of generators of the tensor product of super modules. +The extensionality principle `RS.SuperCommAlgebra.Mod.hom_ext` +reduces the naturality square to exactly those four instances. + +## Contents + +* `RS.gpair_naturality`, `RS.gpairLin_naturality`: naturality of + the ungraded pairing, plain and transported. +* `RS.modTensorMapMod_id'`, `RS.modTensorMapMod_comp'`, + `RS.modTensorMapModIso`: functoriality of the bundled relative + tensor product, and the isomorphism it yields from a pair of + isomorphisms. +* `RS.SuperCommAlgebra.Mod.tensorIso`: the tensor product of two + isomorphisms of super modules. +* `RS.gammaPairComparison_naturality_left`, + `RS.gammaPairComparison_naturality_right`, + `RS.gammaPairComparison_naturality`: the naturality squares. +* `RS.gammaPairComparison_isIso_of_iso`: whether the comparison + map is an isomorphism depends only on the isomorphism classes of + the two module objects. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +/-! ## Naturality of the ungraded pairing -/ + +section Pairing + +variable {D : Type u} + +/-- **Naturality of the pairing**: pairing after postcomposition +with a pair of module morphisms is pairing followed by the +functorial map of the relative tensor product. -/ +theorem gpair_naturality + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] (R : D) [MonObj R] {M : Mod D R} {M' : Mod D R} + {N : Mod D R} {N' : Mod D R} + {X Y : D} (f : M ⟶ M') (g : N ⟶ N') + (m : X ⟶ M.X) (n : Y ⟶ N.X) : + gpair (M := M') (N := N') (m ≫ f.hom) (n ≫ g.hom) = + gpair (M := M) (N := N) m n ≫ modTensorMap R f g := by + change ((m ≫ f.hom) ⊗ₘ (n ≫ g.hom)) ≫ modTensorπ R M' N' = + ((m ⊗ₘ n) ≫ modTensorπ R M N) ≫ modTensorMap R f g + rw [← tensorHom_comp_tensorHom] + simp only [Category.assoc] + rw [modTensorπ_map] + +/-- **The transported naturality of the pairing**: the form taken +by `RS.gpair_naturality` at a source identification, that is, at +one graded block of the comparison map. -/ +theorem gpairLin_naturality + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] (R : D) [MonObj R] {M : Mod D R} {M' : Mod D R} + {N : Mod D R} {N' : Mod D R} + {W X Y : D} (s : W ⟶ X ⊗ Y) + (f : M ⟶ M') (g : N ⟶ N') (m : X ⟶ M.X) (n : Y ⟶ N.X) : + s ≫ gpair (M := M') (N := N') (m ≫ f.hom) (n ≫ g.hom) = + (s ≫ gpair (M := M) (N := N) m n) ≫ modTensorMap R f g := by + rw [gpair_naturality, Category.assoc] + +end Pairing + +/-! ## Functoriality of the bundled relative tensor product -/ + +section BundledFunctoriality + +variable {D : Type u} + +/-- The bundled functorial map preserves identities. -/ +theorem modTensorMapMod_id' + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (R : D) [MonObj R] [IsCommMonObj R] + (M N : Mod D R) : + modTensorMapMod R (𝟙 M) (𝟙 N) = 𝟙 (modTensorMod R M N) := + Mod.hom_ext _ _ (modTensorMap_id R (M := M) (N := N)) + +/-- The bundled functorial map preserves composition. -/ +theorem modTensorMapMod_comp' + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (R : D) [MonObj R] [IsCommMonObj R] {M : Mod D R} {M' : Mod D R} + {M'' : Mod D R} {N : Mod D R} {N' : Mod D R} {N'' : Mod D R} + (f : M ⟶ M') (f' : M' ⟶ M'') + (g : N ⟶ N') (g' : N' ⟶ N'') : + modTensorMapMod R (f ≫ f') (g ≫ g') = + modTensorMapMod R f g ≫ modTensorMapMod R f' g' := + Mod.hom_ext _ _ (modTensorMap_comp R f f' g g') + +/-- The relative tensor product of two isomorphisms of module +objects. -/ +noncomputable def modTensorMapModIso + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (R : D) [MonObj R] [IsCommMonObj R] {M : Mod D R} {M' : Mod D R} + {N : Mod D R} {N' : Mod D R} + (e : M ≅ M') (e' : N ≅ N') : + modTensorMod R M N ≅ modTensorMod R M' N' where + hom := modTensorMapMod R e.hom e'.hom + inv := modTensorMapMod R e.inv e'.inv + hom_inv_id := by + rw [← modTensorMapMod_comp', e.hom_inv_id, e'.hom_inv_id, + modTensorMapMod_id'] + inv_hom_id := by + rw [← modTensorMapMod_comp', e.inv_hom_id, e'.inv_hom_id, + modTensorMapMod_id'] + +end BundledFunctoriality + +/-! ## Two conveniences for super modules -/ + +section SuperConveniences + +variable {S : SuperCommAlgebra.{v, v}} +variable {P P' Q Q' T : S.Mod.{v, v, v, v}} + +/-- The even component of a composite, applied to an element. -/ +theorem SuperCommAlgebra.Mod.comp_evenMap_apply (a : P ⟶ Q) + (b : Q ⟶ T) (t : P.even) : + (a ≫ b).evenMap t = b.evenMap (a.evenMap t) := rfl + +/-- The odd component of a composite, applied to an element. -/ +theorem SuperCommAlgebra.Mod.comp_oddMap_apply (a : P ⟶ Q) + (b : Q ⟶ T) (t : P.odd) : + (a ≫ b).oddMap t = b.oddMap (a.oddMap t) := rfl + +/-- The tensor product of two isomorphisms of super modules. -/ +noncomputable def SuperCommAlgebra.Mod.tensorIso (a : P ≅ P') + (b : Q ≅ Q') : P.tensor Q ≅ P'.tensor Q' where + hom := SuperCommAlgebra.Mod.tensorHom a.hom b.hom + inv := SuperCommAlgebra.Mod.tensorHom a.inv b.inv + hom_inv_id := by + rw [← SuperCommAlgebra.Mod.tensorHom_comp, a.hom_inv_id, + b.hom_inv_id, SuperCommAlgebra.Mod.tensorHom_id] + inv_hom_id := by + rw [← SuperCommAlgebra.Mod.tensorHom_comp, a.inv_hom_id, + b.inv_hom_id, SuperCommAlgebra.Mod.tensorHom_id] + +end SuperConveniences + +/-! ## Naturality of the comparison map -/ + +section Naturality + +variable {D : Type u} + +open SuperCommAlgebra.Mod + +/-- Realization of a morphism of module objects, with its type +written at the Γ-modules themselves. This is +`RS.gammaModuleFunctor` on morphisms, and is reducibly equal to +it; naming it keeps the two ends of a naturality square typed by +the same expressions. -/ +noncomputable abbrev gammaFunMap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + {M : Mod D R} {M' : Mod D R} + (f : M ⟶ M') : + gammaModule D L R M.X ⟶ gammaModule D L R M'.X := + (gammaModuleFunctor L R).map f + +/-- Realization takes an identity to an identity. -/ +theorem gammaFunMap_id + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (M : Mod D R) : + gammaFunMap L R (𝟙 M) = 𝟙 (gammaModule D L R M.X) := + CategoryTheory.Functor.map_id _ _ + +@[simp] +theorem gammaPairComparison_evenMap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (M N : Mod D R) : + (gammaPairComparison L R M N).evenMap = gammaPairEven L R M N := + rfl + +@[simp] +theorem gammaPairComparison_oddMap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (M N : Mod D R) : + (gammaPairComparison L R M N).oddMap = gammaPairOdd L R M N := + rfl + +/-- The naturality square, with the realized morphisms typed at +the Γ-modules. This is `RS.gammaPairComparison_naturality` in the +form in which it is proved. -/ +theorem gammaPairComparison_naturality_aux + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] {M : Mod D R} + {M' : Mod D R} {N : Mod D R} {N' : Mod D R} + (f : M ⟶ M') + (g : N ⟶ N') : + SuperCommAlgebra.Mod.tensorHom (gammaFunMap L R f) + (gammaFunMap L R g) ≫ gammaPairComparison L R M' N' = + gammaPairComparison L R M N ≫ + gammaFunMap L R (modTensorMapMod R f g) := by + refine hom_ext (fun m n => ?_) (fun m n => ?_) (fun m n => ?_) + (fun m n => ?_) + · simp only [comp_evenMap_apply, gammaPairComparison_evenMap, + tensorHom_evenMap_tmulEE] + erw [gammaPairEven_tmulEE, gammaPairEven_tmulEE] + exact gpairLin_naturality R _ f g m n + · simp only [comp_evenMap_apply, gammaPairComparison_evenMap, + tensorHom_evenMap_tmulOO] + erw [gammaPairEven_tmulOO, gammaPairEven_tmulOO] + exact gpairLin_naturality R _ f g m n + · simp only [comp_oddMap_apply, gammaPairComparison_oddMap, + tensorHom_oddMap_tmulEO] + erw [gammaPairOdd_tmulEO, gammaPairOdd_tmulEO] + exact gpairLin_naturality R _ f g m n + · simp only [comp_oddMap_apply, gammaPairComparison_oddMap, + tensorHom_oddMap_tmulOE] + erw [gammaPairOdd_tmulOE, gammaPairOdd_tmulOE] + exact gpairLin_naturality R _ f g m n + +/-- **The naturality square of the comparison map**, in both +module variables at once. -/ +theorem gammaPairComparison_naturality + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] {M : Mod D R} + {M' : Mod D R} {N : Mod D R} {N' : Mod D R} + (f : M ⟶ M') (g : N ⟶ N') : + SuperCommAlgebra.Mod.tensorHom + ((gammaModuleFunctor L R).map f) + ((gammaModuleFunctor L R).map g) ≫ + gammaPairComparison L R M' N' = + gammaPairComparison L R M N ≫ + (gammaModuleFunctor L R).map (modTensorMapMod R f g) := + gammaPairComparison_naturality_aux L R f g + +/-- **The naturality square of the comparison map in the first +module variable**. -/ +theorem gammaPairComparison_naturality_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] {M : Mod D R} + {M' : Mod D R} + (f : M ⟶ M') + (N : Mod D R) : + SuperCommAlgebra.Mod.tensorHom + ((gammaModuleFunctor L R).map f) + (𝟙 (gammaModule D L R N.X)) ≫ + gammaPairComparison L R M' N = + gammaPairComparison L R M N ≫ + (gammaModuleFunctor L R).map + (modTensorMapMod R f (𝟙 N)) := by + have h := gammaPairComparison_naturality_aux L R f (𝟙 N) + rw [gammaFunMap_id] at h + exact h + +/-- **The naturality square of the comparison map in the second +module variable**. -/ +theorem gammaPairComparison_naturality_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] {N : Mod D R} + {N' : Mod D R} + (M : Mod D R) + (g : N ⟶ N') : + SuperCommAlgebra.Mod.tensorHom + (𝟙 (gammaModule D L R M.X)) + ((gammaModuleFunctor L R).map g) ≫ + gammaPairComparison L R M N' = + gammaPairComparison L R M N ≫ + (gammaModuleFunctor L R).map + (modTensorMapMod R (𝟙 M) g) := by + have h := gammaPairComparison_naturality_aux L R (𝟙 M) g + rw [gammaFunMap_id] at h + exact h + +/-- **Invariance of the comparison map under isomorphism**: +whether the comparison map is an isomorphism depends only on the +isomorphism classes of the two module objects. -/ +theorem gammaPairComparison_isIso_of_iso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] {M : Mod D R} + {M' : Mod D R} {N : Mod D R} {N' : Mod D R} + (e : M ≅ M') (e' : N ≅ N') + (h : IsIso (gammaPairComparison L R M' N')) : + IsIso (gammaPairComparison L R M N) := by + have := h + have : IsIso (gammaFunMap L R (modTensorMapMod R e.hom e'.hom)) := + ((gammaModuleFunctor L R).mapIso + (modTensorMapModIso R e e')).isIso_hom + have : IsIso (SuperCommAlgebra.Mod.tensorHom + (gammaFunMap L R e.hom) (gammaFunMap L R e'.hom)) := + (SuperCommAlgebra.Mod.tensorIso + ((gammaModuleFunctor L R).mapIso e) + ((gammaModuleFunctor L R).mapIso e')).isIso_hom + have key : SuperCommAlgebra.Mod.tensorHom (gammaFunMap L R e.hom) + (gammaFunMap L R e'.hom) ≫ + gammaPairComparison L R M' N' ≫ + inv (gammaFunMap L R (modTensorMapMod R e.hom e'.hom)) = + gammaPairComparison L R M N := by + rw [← Category.assoc, + gammaPairComparison_naturality_aux L R e.hom e'.hom, + Category.assoc, IsIso.hom_inv_id, Category.comp_id] + rw [← key] + infer_instance + +end Naturality + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetract.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetract.lean new file mode 100644 index 0000000000..07a7a281c0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetract.lean @@ -0,0 +1,164 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairNat +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairAdd + +/-! +# The comparison map on a family of retracts + +If a module object is presented as a finite family of retracts +whose projectors sum to the identity, and the comparison map of +Deligne's (2.11.1) is invertible on each retract, then it is +invertible on the module object itself. This is the additivity +step that reduces (2.11.1) on free modules to the two rank-one +cases; it needs no biproducts in the category of module objects, +only the retraction identities and the totality of the projectors. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +section + +variable {D : Type u} + +open SuperCommAlgebra.Mod + +/-- A finite family of endomorphisms of a module object whose +underlying morphisms sum to the identity stays total after +tensoring with a second module object. -/ +theorem sum_modTensorMapMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (R : D) [MonObj R] [IsCommMonObj R] + {ι : Type*} (s : Finset ι) + {M N : Mod D R} (g : ι → (M ⟶ M)) + (h : ∑ i ∈ s, (g i).hom = 𝟙 M.X) : + ∑ i ∈ s, (modTensorMapMod R (g i) (𝟙 N)).hom = + 𝟙 (modTensorMod R M N).X := by + apply modTensor_hom_ext + have hl : modTensorπ R M N ≫ + ∑ i ∈ s, (modTensorMapMod R (g i) (𝟙 N)).hom = + ∑ i ∈ s, ((g i).hom ▷ N.X) ≫ modTensorπ R M N := by + erw [Preadditive.comp_sum] + refine Finset.sum_congr rfl fun i _ => ?_ + refine Eq.trans (modTensorπ_map R (g i) (𝟙 N)) + (eq_whisker ?_ _) + rw [Mod.id_hom'] + exact MonoidalCategory.tensorHom_id _ _ + refine hl.trans ?_ + refine Eq.trans (Preadditive.sum_comp _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (sum_whiskerRight s (fun i => (g i).hom) N.X).symm _) ?_ + rw [h, MonoidalCategory.id_whiskerRight, Category.id_comp] + exact (Category.comp_id _).symm + +/-- **The comparison map on a family of retracts.** -/ +theorem isIso_gammaPairComparison_of_retracts + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + {ι : Type*} + [Fintype ι] {M : Mod D R} {M' : ι → Mod D R} (N : Mod D R) + (s : ∀ i, M' i ⟶ M) (r : ∀ i, M ⟶ M' i) + (htot : ∑ i : ι, (r i).hom ≫ (s i).hom = 𝟙 M.X) + (h : ∀ i, IsIso (gammaPairComparison L R (M' i) N)) : + IsIso (gammaPairComparison L R M N) := by + classical + have := h + have hnat : ∀ (P P' : Mod D R) (f : P ⟶ P'), + SuperCommAlgebra.Mod.tensorHom (gammaFunMap L R f) + (𝟙 (gammaModule D L R N.X)) ≫ + gammaPairComparison L R P' N = + gammaPairComparison L R P N ≫ + gammaFunMap L R (modTensorMapMod R f (𝟙 N)) := by + intro P P' f + have hx := gammaPairComparison_naturality_aux L R f (𝟙 N) + rw [gammaFunMap_id] at hx + exact hx + have hcomp : ∑ i : ι, (r i ≫ s i).hom = 𝟙 M.X := + Eq.trans (Finset.sum_congr rfl fun i _ => Mod.comp_hom' (r i) + (s i)) htot + have hone : ∑ i : ι, gammaFunMap L R (r i ≫ s i) = + 𝟙 (gammaModule D L R M.X) := + sum_gammaModuleFunctor_map L R Finset.univ _ hcomp + have hsrc : ∑ i : ι, + (SuperCommAlgebra.Mod.tensorHom (gammaFunMap L R (r i)) + (𝟙 (gammaModule D L R N.X)) ≫ + SuperCommAlgebra.Mod.tensorHom (gammaFunMap L R (s i)) + (𝟙 (gammaModule D L R N.X))) = + 𝟙 ((gammaModule D L R M.X).tensor + (gammaModule D L R N.X)) := by + have hi : ∀ i : ι, + SuperCommAlgebra.Mod.tensorHom (gammaFunMap L R (r i)) + (𝟙 (gammaModule D L R N.X)) ≫ + SuperCommAlgebra.Mod.tensorHom (gammaFunMap L R (s i)) + (𝟙 (gammaModule D L R N.X)) = + SuperCommAlgebra.Mod.tensorHom + (gammaFunMap L R (r i ≫ s i)) + (𝟙 (gammaModule D L R N.X)) := by + intro i + refine Eq.trans (SuperCommAlgebra.Mod.tensorHom_comp + (gammaFunMap L R (r i)) (gammaFunMap L R (s i)) + (𝟙 (gammaModule D L R N.X)) + (𝟙 (gammaModule D L R N.X))).symm ?_ + rw [Category.comp_id] + exact congrArg (fun t => SuperCommAlgebra.Mod.tensorHom t + (𝟙 (gammaModule D L R N.X))) + (CategoryTheory.Functor.map_comp (gammaModuleFunctor L R) + (r i) (s i)).symm + refine Eq.trans (Finset.sum_congr rfl fun i _ => hi i) ?_ + refine Eq.trans (SuperCommAlgebra.Mod.tensorHom_sum_left + Finset.univ (fun i : ι => gammaFunMap L R (r i ≫ s i)) _).symm + ?_ + rw [hone] + exact SuperCommAlgebra.Mod.tensorHom_id _ _ + have htgt : ∑ i : ι, + (gammaFunMap L R (modTensorMapMod R (r i) (𝟙 N)) ≫ + gammaFunMap L R (modTensorMapMod R (s i) (𝟙 N))) = + 𝟙 (gammaModule D L R (modTensorMod R M N).X) := by + have hi : ∀ i : ι, + gammaFunMap L R (modTensorMapMod R (r i) (𝟙 N)) ≫ + gammaFunMap L R (modTensorMapMod R (s i) (𝟙 N)) = + gammaFunMap L R + (modTensorMapMod R (r i ≫ s i) (𝟙 N)) := by + intro i + refine Eq.trans (CategoryTheory.Functor.map_comp + (gammaModuleFunctor L R) _ _).symm ?_ + refine congrArg ((gammaModuleFunctor L R).map) ?_ + rw [← modTensorMapMod_comp', Category.comp_id] + refine Eq.trans (Finset.sum_congr rfl fun i _ => hi i) ?_ + refine sum_gammaModuleFunctor_map L R Finset.univ _ ?_ + exact sum_modTensorMapMod R Finset.univ (fun i => r i ≫ s i) + hcomp + refine ⟨∑ i : ι, + gammaFunMap L R (modTensorMapMod R (r i) (𝟙 N)) ≫ + inv (gammaPairComparison L R (M' i) N) ≫ + SuperCommAlgebra.Mod.tensorHom (gammaFunMap L R (s i)) + (𝟙 (gammaModule D L R N.X)), ?_, ?_⟩ + · rw [Preadditive.comp_sum] + refine Eq.trans (Finset.sum_congr rfl fun i _ => ?_) hsrc + rw [← Category.assoc, ← hnat M (M' i) (r i), Category.assoc, + IsIso.hom_inv_id_assoc] + · rw [Preadditive.sum_comp] + refine Eq.trans (Finset.sum_congr rfl fun i _ => ?_) htgt + rw [Category.assoc, Category.assoc, hnat (M' i) M (s i), + IsIso.inv_hom_id_assoc] + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetractRight.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetractRight.lean new file mode 100644 index 0000000000..ba59c72f8c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetractRight.lean @@ -0,0 +1,218 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeMixRetract + +/-! +# The comparison map on a family of retracts, second variable + +The mirror of `RS.isIso_gammaPairComparison_of_retracts`: a finite +family of retracts in the second module variable, total in the same +sense, transports invertibility of the comparison map of Deligne's +(2.11.1) in exactly the same way. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +namespace SuperCommAlgebra.Mod + +variable {S : SuperCommAlgebra.{u, u}} +variable {M N P Q : S.Mod.{u, u, u, u}} + +/-- **The tensor product of super modules is additive in the right +variable.** -/ +theorem tensorHom_add_right (f : M ⟶ P) (g g' : N ⟶ Q) : + tensorHom f (g + g') = tensorHom f g + tensorHom f g' := by + refine hom_ext (fun m n => ?_) (fun m n => ?_) (fun m n => ?_) + (fun m n => ?_) + · rw [tensorHom_evenMap_tmulEE, add_evenMap, LinearMap.add_apply, + map_add, add_evenMap, LinearMap.add_apply, + tensorHom_evenMap_tmulEE, tensorHom_evenMap_tmulEE] + · rw [tensorHom_evenMap_tmulOO, add_oddMap, LinearMap.add_apply, + map_add, add_evenMap, LinearMap.add_apply, + tensorHom_evenMap_tmulOO, tensorHom_evenMap_tmulOO] + · rw [tensorHom_oddMap_tmulEO, add_oddMap, LinearMap.add_apply, + map_add, add_oddMap, LinearMap.add_apply, + tensorHom_oddMap_tmulEO, tensorHom_oddMap_tmulEO] + · rw [tensorHom_oddMap_tmulOE, add_evenMap, LinearMap.add_apply, + map_add, add_oddMap, LinearMap.add_apply, + tensorHom_oddMap_tmulOE, tensorHom_oddMap_tmulOE] + +/-- The tensor product of super modules kills the zero morphism in +the right variable. -/ +theorem tensorHom_zero_right (f : M ⟶ P) : + tensorHom f (0 : N ⟶ Q) = 0 := by + refine hom_ext (fun m n => ?_) (fun m n => ?_) (fun m n => ?_) + (fun m n => ?_) + · rw [tensorHom_evenMap_tmulEE, zero_evenMap, + LinearMap.zero_apply, map_zero, zero_evenMap, + LinearMap.zero_apply] + · rw [tensorHom_evenMap_tmulOO, zero_oddMap, + LinearMap.zero_apply, map_zero, zero_evenMap, + LinearMap.zero_apply] + · rw [tensorHom_oddMap_tmulEO, zero_oddMap, LinearMap.zero_apply, + map_zero, zero_oddMap, LinearMap.zero_apply] + · rw [tensorHom_oddMap_tmulOE, zero_evenMap, + LinearMap.zero_apply, map_zero, zero_oddMap, + LinearMap.zero_apply] + +/-- **The tensor product of super modules takes a finite sum in the +right variable to a finite sum.** -/ +theorem tensorHom_sum_right {ι : Type*} (s : Finset ι) + (f : M ⟶ P) (g : ι → (N ⟶ Q)) : + tensorHom f (∑ i ∈ s, g i) = ∑ i ∈ s, tensorHom f (g i) := by + classical + induction s using Finset.induction with + | empty => + rw [Finset.sum_empty, Finset.sum_empty, tensorHom_zero_right] + | @insert a s ha ih => + rw [Finset.sum_insert ha, Finset.sum_insert ha, + tensorHom_add_right, ih] + +end SuperCommAlgebra.Mod + +section + +variable {D : Type u} + +open SuperCommAlgebra.Mod + +/-- The mirror of `RS.sum_modTensorMapMod`, in the second +variable. -/ +theorem sum_modTensorMapMod_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (R : D) [MonObj R] [IsCommMonObj R] + {ι : Type*} (s : Finset ι) + {M N : Mod D R} (g : ι → (N ⟶ N)) + (h : ∑ i ∈ s, (g i).hom = 𝟙 N.X) : + ∑ i ∈ s, (modTensorMapMod R (𝟙 M) (g i)).hom = + 𝟙 (modTensorMod R M N).X := by + apply modTensor_hom_ext + have hl : modTensorπ R M N ≫ + ∑ i ∈ s, (modTensorMapMod R (𝟙 M) (g i)).hom = + ∑ i ∈ s, (M.X ◁ (g i).hom) ≫ modTensorπ R M N := by + erw [Preadditive.comp_sum] + refine Finset.sum_congr rfl fun i _ => ?_ + refine Eq.trans (modTensorπ_map R (𝟙 M) (g i)) + (eq_whisker ?_ _) + rw [Mod.id_hom'] + exact MonoidalCategory.id_tensorHom _ _ + refine hl.trans ?_ + refine Eq.trans (Preadditive.sum_comp _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (whiskerLeft_sum M.X s (fun i => (g i).hom)).symm _) ?_ + rw [h, MonoidalCategory.whiskerLeft_id, Category.id_comp] + exact (Category.comp_id _).symm + +/-- **The comparison map on a family of retracts in the second +variable.** -/ +theorem isIso_gammaPairComparison_of_retracts_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + {ι : Type*} + [Fintype ι] (M : Mod D R) {N : Mod D R} {N' : ι → Mod D R} + (s : ∀ i, N' i ⟶ N) (r : ∀ i, N ⟶ N' i) + (htot : ∑ i : ι, (r i).hom ≫ (s i).hom = 𝟙 N.X) + (h : ∀ i, IsIso (gammaPairComparison L R M (N' i))) : + IsIso (gammaPairComparison L R M N) := by + classical + have := h + have hnat : ∀ (P P' : Mod D R) (f : P ⟶ P'), + SuperCommAlgebra.Mod.tensorHom + (𝟙 (gammaModule D L R M.X)) (gammaFunMap L R f) ≫ + gammaPairComparison L R M P' = + gammaPairComparison L R M P ≫ + gammaFunMap L R (modTensorMapMod R (𝟙 M) f) := by + intro P P' f + have hx := gammaPairComparison_naturality_aux L R (𝟙 M) f + rw [gammaFunMap_id] at hx + exact hx + have hcomp : ∑ i : ι, (r i ≫ s i).hom = 𝟙 N.X := + Eq.trans (Finset.sum_congr rfl fun i _ => Mod.comp_hom' (r i) + (s i)) htot + have hone : ∑ i : ι, gammaFunMap L R (r i ≫ s i) = + 𝟙 (gammaModule D L R N.X) := + sum_gammaModuleFunctor_map L R Finset.univ _ hcomp + have hsrc : ∑ i : ι, + (SuperCommAlgebra.Mod.tensorHom + (𝟙 (gammaModule D L R M.X)) (gammaFunMap L R (r i)) ≫ + SuperCommAlgebra.Mod.tensorHom + (𝟙 (gammaModule D L R M.X)) (gammaFunMap L R (s i))) = + 𝟙 ((gammaModule D L R M.X).tensor + (gammaModule D L R N.X)) := by + have hi : ∀ i : ι, + SuperCommAlgebra.Mod.tensorHom + (𝟙 (gammaModule D L R M.X)) (gammaFunMap L R (r i)) ≫ + SuperCommAlgebra.Mod.tensorHom + (𝟙 (gammaModule D L R M.X)) (gammaFunMap L R (s i)) = + SuperCommAlgebra.Mod.tensorHom + (𝟙 (gammaModule D L R M.X)) + (gammaFunMap L R (r i ≫ s i)) := by + intro i + refine Eq.trans (SuperCommAlgebra.Mod.tensorHom_comp + (𝟙 (gammaModule D L R M.X)) (𝟙 (gammaModule D L R M.X)) + (gammaFunMap L R (r i)) (gammaFunMap L R (s i))).symm ?_ + rw [Category.comp_id] + exact congrArg (fun t => SuperCommAlgebra.Mod.tensorHom + (𝟙 (gammaModule D L R M.X)) t) + (CategoryTheory.Functor.map_comp (gammaModuleFunctor L R) + (r i) (s i)).symm + refine Eq.trans (Finset.sum_congr rfl fun i _ => hi i) ?_ + refine Eq.trans (SuperCommAlgebra.Mod.tensorHom_sum_right + Finset.univ _ + (fun i : ι => gammaFunMap L R (r i ≫ s i))).symm ?_ + rw [hone] + exact SuperCommAlgebra.Mod.tensorHom_id _ _ + have htgt : ∑ i : ι, + (gammaFunMap L R (modTensorMapMod R (𝟙 M) (r i)) ≫ + gammaFunMap L R (modTensorMapMod R (𝟙 M) (s i))) = + 𝟙 (gammaModule D L R (modTensorMod R M N).X) := by + have hi : ∀ i : ι, + gammaFunMap L R (modTensorMapMod R (𝟙 M) (r i)) ≫ + gammaFunMap L R (modTensorMapMod R (𝟙 M) (s i)) = + gammaFunMap L R + (modTensorMapMod R (𝟙 M) (r i ≫ s i)) := by + intro i + refine Eq.trans (CategoryTheory.Functor.map_comp + (gammaModuleFunctor L R) _ _).symm ?_ + refine congrArg ((gammaModuleFunctor L R).map) ?_ + rw [← modTensorMapMod_comp', Category.comp_id] + refine Eq.trans (Finset.sum_congr rfl fun i _ => hi i) ?_ + refine sum_gammaModuleFunctor_map L R Finset.univ _ ?_ + exact sum_modTensorMapMod_right R Finset.univ + (fun i => r i ≫ s i) hcomp + refine ⟨∑ i : ι, + gammaFunMap L R (modTensorMapMod R (𝟙 M) (r i)) ≫ + inv (gammaPairComparison L R M (N' i)) ≫ + SuperCommAlgebra.Mod.tensorHom + (𝟙 (gammaModule D L R M.X)) + (gammaFunMap L R (s i)), ?_, ?_⟩ + · rw [Preadditive.comp_sum] + refine Eq.trans (Finset.sum_congr rfl fun i _ => ?_) hsrc + rw [← Category.assoc, ← hnat N (N' i) (r i), Category.assoc, + IsIso.hom_inv_id_assoc] + · rw [Preadditive.sum_comp] + refine Eq.trans (Finset.sum_congr rfl fun i _ => ?_) htgt + rw [Category.assoc, Category.assoc, hnat (N' i) N (s i), + IsIso.inv_hom_id_assoc] + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairUnit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairUnit.lean new file mode 100644 index 0000000000..bd6dd347b6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairUnit.lean @@ -0,0 +1,334 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.UnitEnd +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModuleFunctor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPair +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichRetract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModMonoidal + +/-! +# The comparison map at the regular module + +The regular module is the unit of the relative tensor product, and +its realization is the Γ-algebra viewed over itself, that is, the +unit of the tensor product of super modules. Under those two +identifications the comparison map of Deligne's (2.11.1) is +literally a unitor, so it is an isomorphism whenever one of the two +arguments is the regular module. + +The Koszul sign carried by the right unitor of super modules is +exactly the self-braiding of the odd line: pushing a scalar past a +module element on the odd-odd block braids `L` past `L`, which is +`−1`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +section + +variable {D : Type u} + +open SuperCommAlgebra.Mod + +/-! ## The regular module on the left -/ + +/-- Pairing against the regular module and collapsing is the +convolution action. -/ +theorem gpair_unitLeft + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (R : D) [MonObj R] [IsCommMonObj R] + (N : Mod D R) {X Y : D} (a : X ⟶ R) + (m : Y ⟶ N.X) : + gpair (M := regularMod R) (N := N) a m ≫ + (modTensorUnitLeftMod R N).hom.hom = gact a m := by + erw [gpair_def, Category.assoc] + exact whisker_eq _ (modTensorπ_desc R (regularMod R) N _ _) + +/-- The reindexed form of `RS.gpair_unitLeft`. -/ +theorem gpair_unitLeft' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (R : D) [MonObj R] [IsCommMonObj R] + (N : Mod D R) {W X Y : D} (s : W ⟶ X ⊗ Y) + (a : X ⟶ R) (m : Y ⟶ N.X) : + (s ≫ gpair (M := regularMod R) (N := N) a m) ≫ + (modTensorUnitLeftMod R N).hom.hom = s ≫ gact a m := + Eq.trans (Category.assoc _ _ _) + (whisker_eq _ (gpair_unitLeft R N a m)) + +/-- **The comparison map at the regular module on the left is the +left unitor.** -/ +theorem gammaPairComparison_unitLeft + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (N : Mod D R) : + gammaPairComparison L R (regularMod R) N ≫ + (gammaModuleFunctor L R).map + (modTensorUnitLeftMod R N).hom = + leftUnitorHom (gammaModule D L R N.X) := by + refine hom_ext (fun a m => ?_) (fun a m => ?_) (fun a m => ?_) + (fun a m => ?_) + · have h : (gammaPairComparison L R (regularMod R) N ≫ + (gammaModuleFunctor L R).map + (modTensorUnitLeftMod R N).hom).evenMap + (tmulEE _ _ a m) = + gammaPairEven L R (regularMod R) N (tmulEE _ _ a m) ≫ + (modTensorUnitLeftMod R N).hom.hom := rfl + erw [h, gammaPairEven_tmulEE, gpairLin_apply] + refine Eq.trans ?_ (leftUnitorHom_evenMap_tmulEE + (M := gammaModule D L R N.X) a m).symm + exact gpair_unitLeft' R N _ a m + · have h : (gammaPairComparison L R (regularMod R) N ≫ + (gammaModuleFunctor L R).map + (modTensorUnitLeftMod R N).hom).evenMap + (tmulOO _ _ a m) = + gammaPairEven L R (regularMod R) N (tmulOO _ _ a m) ≫ + (modTensorUnitLeftMod R N).hom.hom := rfl + erw [h, gammaPairEven_tmulOO, gpairLin_apply] + refine Eq.trans ?_ (leftUnitorHom_evenMap_tmulOO + (M := gammaModule D L R N.X) a m).symm + exact gpair_unitLeft' R N _ a m + · have h : (gammaPairComparison L R (regularMod R) N ≫ + (gammaModuleFunctor L R).map + (modTensorUnitLeftMod R N).hom).oddMap + (tmulEO _ _ a m) = + gammaPairOdd L R (regularMod R) N (tmulEO _ _ a m) ≫ + (modTensorUnitLeftMod R N).hom.hom := rfl + erw [h, gammaPairOdd_tmulEO, gpairLin_apply] + refine Eq.trans ?_ (leftUnitorHom_oddMap_tmulEO + (M := gammaModule D L R N.X) a m).symm + exact gpair_unitLeft' R N _ a m + · have h : (gammaPairComparison L R (regularMod R) N ≫ + (gammaModuleFunctor L R).map + (modTensorUnitLeftMod R N).hom).oddMap + (tmulOE _ _ a m) = + gammaPairOdd L R (regularMod R) N (tmulOE _ _ a m) ≫ + (modTensorUnitLeftMod R N).hom.hom := rfl + erw [h, gammaPairOdd_tmulOE, gpairLin_apply] + refine Eq.trans ?_ (leftUnitorHom_oddMap_tmulOE + (M := gammaModule D L R N.X) a m).symm + exact gpair_unitLeft' R N _ a m + +/-! ## The regular module on the right -/ + +/-- Pairing with the regular module on the right and collapsing is +the convolution action after a braiding. -/ +theorem gpair_unitRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (R : D) [MonObj R] [IsCommMonObj R] + (M : Mod D R) {X Y : D} (m : X ⟶ M.X) + (a : Y ⟶ R) : + gpair (M := M) (N := regularMod R) m a ≫ + (modTensorUnitRightMod R M).hom.hom = + (β_ X Y).hom ≫ gact a m := by + have h : gpair (M := M) (N := regularMod R) m a ≫ + (modTensorUnitRightMod R M).hom.hom = + (m ⊗ₘ a) ≫ actRight R M.X := by + erw [gpair_def, Category.assoc] + exact whisker_eq _ (modTensorπ_desc R M (regularMod R) _ _) + refine h.trans ?_ + rw [actRight, ← Category.assoc, + BraidedCategory.braiding_naturality] + exact Category.assoc _ _ _ + +/-- The reindexed form of `RS.gpair_unitRight`. -/ +theorem gpair_unitRight' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (R : D) [MonObj R] [IsCommMonObj R] + (M : Mod D R) {W X Y : D} (s : W ⟶ X ⊗ Y) + (t : W ⟶ Y ⊗ X) (hst : s ≫ (β_ X Y).hom = t) (m : X ⟶ M.X) + (a : Y ⟶ R) : + (s ≫ gpair (M := M) (N := regularMod R) m a) ≫ + (modTensorUnitRightMod R M).hom.hom = t ≫ gact a m := by + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (gpair_unitRight R M m a)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + exact eq_whisker hst _ + +/-- **The comparison map at the regular module on the right is the +right unitor**, Koszul sign and all: the sign is the self-braiding +of the odd line. -/ +theorem gammaPairComparison_unitRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (M : Mod D R) : + gammaPairComparison L R M (regularMod R) ≫ + (gammaModuleFunctor L R).map + (modTensorUnitRightMod R M).hom = + rightUnitorHom (gammaModule D L R M.X) := by + refine hom_ext (fun m a => ?_) (fun m a => ?_) (fun m a => ?_) + (fun m a => ?_) + · have h : (gammaPairComparison L R M (regularMod R) ≫ + (gammaModuleFunctor L R).map + (modTensorUnitRightMod R M).hom).evenMap + (tmulEE _ _ m a) = + gammaPairEven L R M (regularMod R) (tmulEE _ _ m a) ≫ + (modTensorUnitRightMod R M).hom.hom := rfl + erw [h, gammaPairEven_tmulEE, gpairLin_apply] + refine Eq.trans ?_ (rightUnitorHom_evenMap_tmulEE + (M := gammaModule D L R M.X) m a).symm + refine gpair_unitRight' R M _ _ ?_ m a + rw [braiding_unit_self, Category.comp_id] + · have h : (gammaPairComparison L R M (regularMod R) ≫ + (gammaModuleFunctor L R).map + (modTensorUnitRightMod R M).hom).evenMap + (tmulOO _ _ m a) = + gammaPairEven L R M (regularMod R) (tmulOO _ _ m a) ≫ + (modTensorUnitRightMod R M).hom.hom := rfl + erw [h, gammaPairEven_tmulOO, gpairLin_apply] + refine Eq.trans ?_ (rightUnitorHom_evenMap_tmulOO + (M := gammaModule D L R M.X) m a).symm + refine Eq.trans (gpair_unitRight' R M _ (-L.sq.inv) ?_ m a) ?_ + · rw [L.braid_neg, Preadditive.comp_neg, Category.comp_id] + · exact Preadditive.neg_comp _ _ + · have h : (gammaPairComparison L R M (regularMod R) ≫ + (gammaModuleFunctor L R).map + (modTensorUnitRightMod R M).hom).oddMap + (tmulEO _ _ m a) = + gammaPairOdd L R M (regularMod R) (tmulEO _ _ m a) ≫ + (modTensorUnitRightMod R M).hom.hom := rfl + erw [h, gammaPairOdd_tmulEO, gpairLin_apply] + refine Eq.trans ?_ (rightUnitorHom_oddMap_tmulEO + (M := gammaModule D L R M.X) m a).symm + refine gpair_unitRight' R M _ _ ?_ m a + rw [(Iso.eq_comp_inv (ρ_ L.obj)).mpr + (braiding_rightUnitor L.obj), Iso.inv_hom_id_assoc] + · have h : (gammaPairComparison L R M (regularMod R) ≫ + (gammaModuleFunctor L R).map + (modTensorUnitRightMod R M).hom).oddMap + (tmulOE _ _ m a) = + gammaPairOdd L R M (regularMod R) (tmulOE _ _ m a) ≫ + (modTensorUnitRightMod R M).hom.hom := rfl + erw [h, gammaPairOdd_tmulOE, gpairLin_apply] + refine Eq.trans ?_ (rightUnitorHom_oddMap_tmulOE + (M := gammaModule D L R M.X) m a).symm + refine gpair_unitRight' R M _ _ ?_ m a + rw [(Iso.eq_comp_inv (λ_ L.obj)).mpr + (braiding_leftUnitor L.obj), Iso.inv_hom_id_assoc] + +/-! ## Invertibility -/ + +/-- The comparison isomorphism at the regular module on the +left. -/ +noncomputable def gammaPairIsoUnitLeft + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (N : Mod D R) : + ((gammaModuleFunctor L R).obj (regularMod R)).tensor + ((gammaModuleFunctor L R).obj N) ≅ + (gammaModuleFunctor L R).obj + (modTensorMod R (regularMod R) N) := + (gammaModule D L R N.X).leftUnitor ≪≫ + ((gammaModuleFunctor L R).mapIso + (modTensorUnitLeftMod R N)).symm + +theorem gammaPairIsoUnitLeft_hom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (N : Mod D R) : + (gammaPairIsoUnitLeft L R N).hom = + gammaPairComparison L R (regularMod R) N := by + have key : (gammaModuleFunctor L R).map (modTensorUnitLeftMod R N).hom ≫ + (gammaModuleFunctor L R).map (modTensorUnitLeftMod R N).inv = 𝟙 _ := by + rw [← CategoryTheory.Functor.map_comp, Iso.hom_inv_id, + CategoryTheory.Functor.map_id] + refine Eq.trans (eq_whisker + (gammaPairComparison_unitLeft L R N).symm _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact Eq.trans (whisker_eq _ key) (Category.comp_id _) + +/-- **The comparison map is an isomorphism when the left argument +is the regular module.** -/ +instance isIso_gammaPairComparison_unitLeft + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (N : Mod D R) : + IsIso (gammaPairComparison L R (regularMod R) N) := by + rw [← gammaPairIsoUnitLeft_hom] + exact (gammaPairIsoUnitLeft L R N).isIso_hom + +/-- The comparison isomorphism at the regular module on the +right. -/ +noncomputable def gammaPairIsoUnitRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (M : Mod D R) : + ((gammaModuleFunctor L R).obj M).tensor + ((gammaModuleFunctor L R).obj (regularMod R)) ≅ + (gammaModuleFunctor L R).obj + (modTensorMod R M (regularMod R)) := + (gammaModule D L R M.X).rightUnitor ≪≫ + ((gammaModuleFunctor L R).mapIso + (modTensorUnitRightMod R M)).symm + +theorem gammaPairIsoUnitRight_hom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (M : Mod D R) : + (gammaPairIsoUnitRight L R M).hom = + gammaPairComparison L R M (regularMod R) := by + have key : (gammaModuleFunctor L R).map (modTensorUnitRightMod R M).hom ≫ + (gammaModuleFunctor L R).map (modTensorUnitRightMod R M).inv = 𝟙 _ := by + rw [← CategoryTheory.Functor.map_comp, Iso.hom_inv_id, + CategoryTheory.Functor.map_id] + refine Eq.trans (eq_whisker + (gammaPairComparison_unitRight L R M).symm _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact Eq.trans (whisker_eq _ key) (Category.comp_id _) + +/-- **The comparison map is an isomorphism when the right argument +is the regular module.** -/ +instance isIso_gammaPairComparison_unitRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (M : Mod D R) : + IsIso (gammaPairComparison L R M (regularMod R)) := by + rw [← gammaPairIsoUnitRight_hom] + exact (gammaPairIsoUnitRight L R M).isIso_hom + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaShift.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaShift.lean new file mode 100644 index 0000000000..b47a9fc033 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaShift.lean @@ -0,0 +1,257 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.RhoTwist +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModIso +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShift + +/-! +# The realization of an odd twist is a parity shift + +The Γ-module of the free module `R ⊗ 1̄` on the odd line is the +parity shift of the Γ-module of `R` itself: twisting by the odd +line exchanges the two components of `ρ`, and the exchange is +compatible with all four graded action blocks. + +The two components of the identification are the parity swaps +`RS.rhoEvenOdd` and `RS.rhoOddOdd` of `RS.RhoTwist`, and no sign +enters. Both swaps have the same shape, `s ≫ (· ▷ 1̄) ≫ cap` for +a source identification `s`, where `RS.OddLine.cap` contracts the +two twisting legs of `(Z ⊗ 1̄) ⊗ 1̄` against the square +trivialisation. The cap is natural in the capped object +(`RS.OddLine.cap_naturality`) and compatible with the associator +(`RS.OddLine.cap_tensor`), and those two facts alone give the one +sliding lemma of the file, `RS.free_cap_slide`: capping the free +action of a scalar is convolution by that scalar, up to the +associator of the three sources. Each of the four action +compatibilities is that lemma conjugated by the very coherence +isomorphisms that identify the sources in `RS.gammaAlgebra`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open scoped MonObj + +universe v u + +attribute [local instance] CategoryTheory.ModObj.regular + +/-! ## Capping the two twisting legs -/ + +section Cap + +variable {D : Type u} + +/-- **The odd cap**: contract the two twisting legs of a doubly +twisted object against the square trivialisation of the odd +line. -/ +def OddLine.cap [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] + (L : OddLine D) (Z : D) : + (Z ⊗ L.obj) ⊗ L.obj ⟶ Z := + (α_ Z L.obj L.obj).hom ≫ (Z ◁ L.sq.hom) ≫ (ρ_ Z).hom + +/-- The odd cap unfolded. -/ +theorem OddLine.cap_def + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] + (L : OddLine D) (Z : D) : + L.cap Z = + (α_ Z L.obj L.obj).hom ≫ (Z ◁ L.sq.hom) ≫ (ρ_ Z).hom := + rfl + +/-- **The odd cap is natural** in the capped object: a morphism +whiskered by the two legs passes through the contraction. -/ +theorem OddLine.cap_naturality + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] + (L : OddLine D) {Z Z' : D} + (f : Z ⟶ Z') : + ((f ▷ L.obj) ▷ L.obj) ≫ L.cap Z' = L.cap Z ≫ f := by + simp only [OddLine.cap_def, Category.assoc] + rw [associator_naturality_left_assoc, ← whisker_exchange_assoc, + rightUnitor_naturality] + +/-- **The odd cap is compatible with the associator**: capping a +tensor product is capping the right-hand factor inside the +left-hand one. -/ +theorem OddLine.cap_tensor + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] + (L : OddLine D) (A B : D) : + ((α_ A B L.obj).inv ▷ L.obj) ≫ L.cap (A ⊗ B) = + (α_ A (B ⊗ L.obj) L.obj).hom ≫ (A ◁ L.cap B) := by + have hpre : ((α_ A B L.obj).inv ▷ L.obj) ≫ + (α_ (A ⊗ B) L.obj L.obj).hom ≫ + (α_ A B (L.obj ⊗ L.obj)).hom = + (α_ A (B ⊗ L.obj) L.obj).hom ≫ + (A ◁ (α_ B L.obj L.obj).hom) := by + monoidal + have hpost : (α_ A B (𝟙_ D)).inv ≫ (ρ_ (A ⊗ B)).hom = + A ◁ (ρ_ B).hom := by + monoidal + simp only [OddLine.cap_def, tensor_whiskerLeft, whiskerLeft_comp, + Category.assoc] + rw [reassoc_of% hpre, hpost] + +/-! ## The two parity swaps, capped -/ + +/-- The even parity swap is a whiskering followed by the cap. -/ +theorem rhoEvenOdd_eq_cap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [CategoryTheory.Linear ℂ D] [MonoidalPreadditive D] + [MonoidalLinear ℂ D] + (L : OddLine D) (Z : D) + (f : 𝟙_ D ⟶ Z ⊗ L.obj) : + rhoEvenOdd L Z f = (λ_ L.obj).inv ≫ (f ▷ L.obj) ≫ L.cap Z := + rfl + +/-- The odd parity swap is a whiskering followed by the cap. -/ +theorem rhoOddOdd_eq_cap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [CategoryTheory.Linear ℂ D] [MonoidalPreadditive D] + [MonoidalLinear ℂ D] + (L : OddLine D) (Z : D) + (g : L.obj ⟶ Z ⊗ L.obj) : + rhoOddOdd L Z g = L.sq.inv ≫ (g ▷ L.obj) ≫ L.cap Z := by + rw [rhoOddOdd, LinearEquiv.trans_apply, Linear.homCongr_apply] + simp only [Iso.refl_inv, Category.id_comp, Iso.trans_hom, + whiskerLeftIso_hom, oddParitySwap_symm_apply, OddLine.cap_def, + Category.assoc] + +end Cap + +/-! ## The sliding lemma -/ + +section Slide + +variable {D : Type u} + +/-- **The sliding lemma**: the free action of a scalar on the free +module of the odd line, capped, is the convolution product by that +scalar, up to the associator of the three sources. This is `μ` +sliding past an associator and the square trivialisation, and it +is the whole content of the parity shift. -/ +theorem free_cap_slide + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) (R : D) [MonObj R] + {W X : D} (a : W ⟶ R) + (m : X ⟶ R ⊗ L.obj) : + (((a ⊗ₘ m) ≫ (α_ R R L.obj).inv ≫ μ[R] ▷ L.obj) ▷ L.obj) ≫ + L.cap R = + (α_ W X L.obj).hom ≫ gmul a ((m ▷ L.obj) ≫ L.cap R) := by + have h1 : ((a ⊗ₘ m) ▷ L.obj) ≫ (α_ R (R ⊗ L.obj) L.obj).hom = + (α_ W X L.obj).hom ≫ (a ⊗ₘ (m ▷ L.obj)) := by + rw [← tensorHom_id, ← tensorHom_id, associator_naturality] + have h2 : (a ⊗ₘ (m ▷ L.obj)) ≫ (R ◁ L.cap R) = + a ⊗ₘ ((m ▷ L.obj) ≫ L.cap R) := by + rw [← id_tensorHom, tensorHom_comp_tensorHom, Category.comp_id] + simp only [comp_whiskerRight, Category.assoc] + rw [L.cap_naturality μ[R], reassoc_of% (L.cap_tensor R R), + reassoc_of% h1, reassoc_of% h2, gmul_def] + +/-- **The transported sliding lemma**: for any two parity swaps +`Φ` and `Ψ` presented as a source identification followed by the +cap, and any coherence identity between the two ways of +reassociating the chosen sources, the swap of a free action is the +transported convolution product against the swap. The four action +compatibilities of `RS.gammaShiftHom` are the four instances of +this. -/ +theorem free_cap_slide' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) (R : D) [MonObj R] + {W X U V V' : D} (a : W ⟶ R) + (m : X ⟶ R ⊗ L.obj) (s₁ : U ⟶ W ⊗ X) (p : V ⟶ U ⊗ L.obj) + (q : V' ⟶ X ⊗ L.obj) (s₂ : V ⟶ W ⊗ V') + {Φ : (U ⟶ R ⊗ L.obj) → (V ⟶ R)} + {Ψ : (X ⟶ R ⊗ L.obj) → (V' ⟶ R)} + (hΦ : ∀ f, Φ f = p ≫ (f ▷ L.obj) ≫ L.cap R) + (hΨ : ∀ f, Ψ f = q ≫ (f ▷ L.obj) ≫ L.cap R) + (h : p ≫ (s₁ ▷ L.obj) ≫ (α_ W X L.obj).hom = + s₂ ≫ (W ◁ q)) : + Φ (s₁ ≫ (a ⊗ₘ m) ≫ (α_ R R L.obj).inv ≫ μ[R] ▷ L.obj) = + s₂ ≫ gmul a (Ψ m) := by + rw [hΦ, hΨ, comp_whiskerRight, Category.assoc, free_cap_slide, + reassoc_of% h, ← gmul_comp] + +end Slide + +/-! ## The parity shift of the Γ-module -/ + +section Shift + +variable {D : Type u} + +/-- **The parity swap is a morphism of Γ-modules**: the two +parity swaps of `RS.RhoTwist` intertwine the four action blocks of +the Γ-module of the free module on the odd line with the four +relabelled blocks of the parity shift of the Γ-module of `R`. -/ +noncomputable def gammaShiftHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (R : D) [MonObj R] + [IsCommMonObj R] : + gammaModule D L R ((freeMod R L.obj).X) ⟶ + SuperCommAlgebra.Mod.shift (gammaModule D L R R) where + evenMap := (rhoEvenOdd L R).toLinearMap + oddMap := (rhoOddOdd L R).toLinearMap + map_actEE x m := by + refine free_cap_slide' L R x m (λ_ (𝟙_ D)).inv (λ_ L.obj).inv + (λ_ L.obj).inv (λ_ L.obj).inv (rhoEvenOdd_eq_cap L R) + (rhoEvenOdd_eq_cap L R) ?_ + monoidal + map_actEO x m := by + refine free_cap_slide' L R x m (λ_ L.obj).inv L.sq.inv + L.sq.inv (λ_ (𝟙_ D)).inv (rhoOddOdd_eq_cap L R) + (rhoOddOdd_eq_cap L R) ?_ + have hc : (λ_ L.obj).inv ▷ L.obj ≫ + (α_ (𝟙_ D) L.obj L.obj).hom = + (λ_ (L.obj ⊗ L.obj)).inv := by monoidal + rw [hc] + exact leftUnitor_inv_naturality L.sq.inv + map_actOE u m := by + refine free_cap_slide' L R u m (ρ_ L.obj).inv L.sq.inv + (λ_ L.obj).inv L.sq.inv (rhoOddOdd_eq_cap L R) + (rhoEvenOdd_eq_cap L R) ?_ + have hc : (ρ_ L.obj).inv ▷ L.obj ≫ + (α_ L.obj (𝟙_ D) L.obj).hom = + L.obj ◁ (λ_ L.obj).inv := by monoidal + rw [hc] + map_actOO u m := by + refine free_cap_slide' L R u m L.sq.inv (λ_ L.obj).inv + L.sq.inv (ρ_ L.obj).inv (rhoEvenOdd_eq_cap L R) + (rhoOddOdd_eq_cap L R) ?_ + have h2 : L.sq.inv ▷ L.obj ≫ (α_ L.obj L.obj L.obj).hom = + (λ_ L.obj).hom ≫ (ρ_ L.obj).inv ≫ + L.obj ◁ L.sq.inv := by + rw [← reassoc_of% L.evaluation_coevaluation, + ← MonoidalCategory.whiskerLeft_comp, Iso.hom_inv_id, + MonoidalCategory.whiskerLeft_id, Category.comp_id] + rw [h2, ← Category.assoc, Iso.inv_hom_id, Category.id_comp] + +/-- **The realization of an odd twist is the parity shift of the +realization**: the Γ-module of the free `R`-module on the odd line +is the parity shift of the Γ-module of `R`. -/ +noncomputable def gammaShiftIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (R : D) [MonObj R] + [IsCommMonObj R] : + gammaModule D L R ((freeMod R L.obj).X) ≅ + SuperCommAlgebra.Mod.shift (gammaModule D L R R) := + SuperCommAlgebra.Mod.isoOfComponents (gammaShiftHom L R) + (rhoEvenOdd L R).bijective (rhoOddOdd L R).bijective + +end Shift + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaTwistLeft.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaTwistLeft.lean new file mode 100644 index 0000000000..095b849988 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaTwistLeft.lean @@ -0,0 +1,388 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaShift +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistShuffle + +/-! +# The realization of a left odd twist is a parity shift + +Twisting a module `N` over a commutative monoid object `R` by the +odd line *on the left* produces `1̄ ⊗ N`, and its Γ-module is the +parity shift of the Γ-module of `N`. This is the mirror of +`RS.gammaShiftIso`, which twists the regular module on the right. + +The two identifications are again a source identification followed +by a contraction, but the contraction is now the *left* cap +`RS.OddLine.capL`, which folds the two leading odd legs of +`1̄ ⊗ (1̄ ⊗ Z)` against the square trivialisation. The left cap is +natural in the capped object (`RS.OddLine.capL_naturality`), it +commutes with carrying a further object past the two odd legs +(`RS.OddLine.capL_braidPast`), and the tensor–hom bijection of the +self-duality of the odd line makes it invertible +(`RS.OddLine.capLEquiv`). Those three facts give the single +sliding lemma `RS.left_cap_slide`, of which the four action +compatibilities are instances. + +Unlike the right-handed twist, a sign is unavoidable here: the +scalar has to be carried past the free odd leg, and in the two +odd-scalar blocks that carrying is the self-braiding of the odd +line, which is `−1`. The sign is absorbed once and for all into +the odd component `RS.gammaTwistLeftOdd`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +/-! ## Carrying an object past a context -/ + +section Braid + +variable {D : Type u} + +/-- Carrying an object past a context is inverse to carrying it +back: over a symmetric base the two directions are inverse +isomorphisms. -/ +theorem braidPast_symm + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (A V T : D) : + (braidPast A V T).inv = (braidPast V A T).hom := by + simp only [braidPast, Iso.trans_inv, Iso.trans_hom, Iso.symm_inv, + Iso.symm_hom, whiskerRightIso_inv, whiskerRightIso_hom, + Category.assoc, + SymmetricCategory.braiding_swap_eq_inv_braiding] + +/-- Carrying an object past the unit is the unit coherence. -/ +theorem braidPast_tensorUnit + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (A Z : D) : + (braidPast A (𝟙_ D) Z).hom ≫ (λ_ (A ⊗ Z)).hom = + A ◁ (λ_ Z).hom := by + rw [braidPast_hom, braiding_tensorUnit_right] + monoidal + +end Braid + +/-! ## Capping the two leading odd legs -/ + +section Cap + +variable {D : Type u} + +/-- **The left odd cap**: contract the two leading legs of a doubly +twisted object against the square trivialisation of the odd +line. -/ +def OddLine.capL [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] + (L : OddLine D) (Z : D) : + L.obj ⊗ (L.obj ⊗ Z) ⟶ Z := + (α_ L.obj L.obj Z).inv ≫ (L.sq.hom ▷ Z) ≫ (λ_ Z).hom + +/-- The left odd cap unfolded. -/ +theorem OddLine.capL_def + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] + (L : OddLine D) (Z : D) : + L.capL Z = + (α_ L.obj L.obj Z).inv ≫ (L.sq.hom ▷ Z) ≫ (λ_ Z).hom := + rfl + +/-- **The left odd cap is natural** in the capped object: a +morphism whiskered by the two legs passes through the +contraction. -/ +theorem OddLine.capL_naturality + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] + (L : OddLine D) {Z Z' : D} + (f : Z ⟶ Z') : + (L.obj ◁ (L.obj ◁ f)) ≫ L.capL Z' = L.capL Z ≫ f := by + simp only [OddLine.capL_def, Category.assoc] + rw [associator_inv_naturality_right_assoc, whisker_exchange_assoc, + leftUnitor_naturality] + +/-- **The left odd cap commutes with carrying an object past the +two odd legs**: capping after the carry is carrying after the +cap. -/ +theorem OddLine.capL_braidPast + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] + (L : OddLine D) (A Z : D) : + (L.obj ◁ (braidPast A L.obj Z).hom) ≫ L.capL (A ⊗ Z) = + (braidPast L.obj A (L.obj ⊗ Z)).hom ≫ (A ◁ L.capL Z) := by + have hP : (braidPast A (L.obj ⊗ L.obj) Z).hom ≫ + (α_ L.obj L.obj (A ⊗ Z)).hom = + (A ◁ (α_ L.obj L.obj Z).hom) ≫ + (braidPast A L.obj (L.obj ⊗ Z)).hom ≫ + (L.obj ◁ (braidPast A L.obj Z).hom) := by + rw [braidPast_hom] + simp only [Category.assoc] + exact braidPast_tensor_context A L.obj L.obj Z + have hQ : (braidPast A L.obj (L.obj ⊗ Z)).hom ≫ + (L.obj ◁ (braidPast A L.obj Z).hom) = + (A ◁ (α_ L.obj L.obj Z).inv) ≫ + (braidPast A (L.obj ⊗ L.obj) Z).hom ≫ + (α_ L.obj L.obj (A ⊗ Z)).hom := by + rw [hP, ← Category.assoc, ← MonoidalCategory.whiskerLeft_comp, + Iso.inv_hom_id, MonoidalCategory.whiskerLeft_id, + Category.id_comp] + have hE : (braidPast A (L.obj ⊗ L.obj) Z).hom ≫ + (L.sq.hom ▷ (A ⊗ Z)) ≫ (λ_ (A ⊗ Z)).hom = + (A ◁ (L.sq.hom ▷ Z)) ≫ (A ◁ (λ_ Z).hom) := by + rw [← braidPast_natural_context_assoc A L.sq.hom Z, + braidPast_tensorUnit] + have hG : (braidPast A L.obj (L.obj ⊗ Z)).hom ≫ + ((L.obj ◁ (braidPast A L.obj Z).hom) ≫ L.capL (A ⊗ Z)) = + A ◁ L.capL Z := by + rw [← Category.assoc, hQ, OddLine.capL_def] + simp only [Category.assoc, Iso.hom_inv_id_assoc] + rw [hE, OddLine.capL_def] + simp only [MonoidalCategory.whiskerLeft_comp] + have h0 : (braidPast L.obj A (L.obj ⊗ Z)).hom ≫ + (braidPast A L.obj (L.obj ⊗ Z)).hom = 𝟙 _ := by + rw [← braidPast_symm A L.obj (L.obj ⊗ Z)] + exact Iso.inv_hom_id _ + rw [← hG, ← Category.assoc, h0, Category.id_comp] + +end Cap + +/-! ## The sliding lemma -/ + +section Slide + +variable {D : Type u} + +/-- **The sliding lemma**: the action on a left twist by the odd +line, capped, is the convolution action of the scalar on the +capped module element, up to carrying the odd leg past the scalar. +This is the whole content of the left parity shift. -/ +theorem left_cap_slide + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) (R : D) [MonObj R] (N : D) [ModObj R N] + {W X : D} (a : W ⟶ R) (m : X ⟶ L.obj ⊗ N) : + (L.obj ◁ ((a ⊗ₘ m) ≫ actAcross R L.obj N)) ≫ L.capL N = + (braidPast L.obj W X).hom ≫ + gact a ((L.obj ◁ m) ≫ L.capL N) := by + have h1 : (L.obj ◁ (a ⊗ₘ m)) ≫ + (braidPast L.obj R (L.obj ⊗ N)).hom = + (braidPast L.obj W X).hom ≫ (a ⊗ₘ (L.obj ◁ m)) := by + rw [tensorHom_def, tensorHom_def] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [braidPast_natural_tail L.obj R m, + ← Category.assoc, braidPast_natural_context L.obj a X, + Category.assoc] + have h2 : (a ⊗ₘ (L.obj ◁ m)) ≫ (R ◁ L.capL N) = + a ⊗ₘ ((L.obj ◁ m) ≫ L.capL N) := by + rw [tensorHom_def, tensorHom_def, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [actAcross_eq_braidPast] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [L.capL_naturality (actLeft R N), + reassoc_of% (L.capL_braidPast R N), reassoc_of% h1, + reassoc_of% h2, gact_def] + +/-- **The transported sliding lemma**: for any two contractions `Φ` +and `Ψ` presented as a source identification followed by the left +cap, and any coherence identity between the two ways of +reassociating the chosen sources, the contraction of a twisted +action is the transported convolution action against the +contraction. The four action compatibilities of +`RS.gammaTwistLeftHom` are the four instances of this. -/ +theorem left_cap_slide' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) (R : D) [MonObj R] (N : D) [ModObj R N] + {W X U V V' : D} (a : W ⟶ R) + (m : X ⟶ L.obj ⊗ N) (s₁ : U ⟶ W ⊗ X) (p : V ⟶ L.obj ⊗ U) + (q : V' ⟶ L.obj ⊗ X) (s₂ : V ⟶ W ⊗ V') + {Φ : (U ⟶ L.obj ⊗ N) → (V ⟶ N)} + {Ψ : (X ⟶ L.obj ⊗ N) → (V' ⟶ N)} + (hΦ : ∀ f, Φ f = p ≫ (L.obj ◁ f) ≫ L.capL N) + (hΨ : ∀ f, Ψ f = q ≫ (L.obj ◁ f) ≫ L.capL N) + (act : R ⊗ (L.obj ⊗ N) ⟶ L.obj ⊗ N) + (hact : act = actAcross R L.obj N) + (h : p ≫ (L.obj ◁ s₁) ≫ (braidPast L.obj W X).hom = + s₂ ≫ (W ◁ q)) : + Φ (s₁ ≫ (a ⊗ₘ m) ≫ act) = s₂ ≫ gact a (Ψ m) := by + rw [hΦ, hΨ, hact, MonoidalCategory.whiskerLeft_comp, + Category.assoc, left_cap_slide, reassoc_of% h, + gact_comp a q ((L.obj ◁ m) ≫ L.capL N)] + +end Slide + +/-! ## The two contractions are isomorphisms -/ + +section Equivalence + +variable {D : Type u} + +/-- **Lowering along the left cap is a ℂ-linear isomorphism**: it +is the tensor–hom bijection of the self-duality of the odd line. -/ +noncomputable def OddLine.capLEquiv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (Y Z : D) : + (Y ⟶ L.obj ⊗ Z) ≃ₗ[ℂ] (L.obj ⊗ Y ⟶ Z) where + toFun f := (L.obj ◁ f) ≫ L.capL Z + map_add' f g := by + simp [MonoidalPreadditive.whiskerLeft_add, Preadditive.add_comp] + map_smul' c f := by + simp [MonoidalLinear.whiskerLeft_smul, Linear.smul_comp] + invFun h := (λ_ Y).inv ≫ (L.sq.inv ▷ Y) ≫ + (α_ L.obj L.obj Y).hom ≫ (L.obj ◁ h) + left_inv f := by + let := L.exactPairing + have hs : ∀ F : Y ⟶ L.obj ⊗ Z, + (tensorLeftHomEquiv Y L.obj L.obj Z).symm F = + (L.obj ◁ F) ≫ L.capL Z := fun _ => rfl + have ht : ∀ g : L.obj ⊗ Y ⟶ Z, + (tensorLeftHomEquiv Y L.obj L.obj Z) g = + (λ_ Y).inv ≫ (L.sq.inv ▷ Y) ≫ + (α_ L.obj L.obj Y).hom ≫ (L.obj ◁ g) := fun _ => rfl + change (λ_ Y).inv ≫ (L.sq.inv ▷ Y) ≫ (α_ L.obj L.obj Y).hom ≫ + (L.obj ◁ ((L.obj ◁ f) ≫ L.capL Z)) = f + rw [← ht, ← hs, Equiv.apply_symm_apply] + right_inv g := by + let := L.exactPairing + have hs : ∀ F : Y ⟶ L.obj ⊗ Z, + (tensorLeftHomEquiv Y L.obj L.obj Z).symm F = + (L.obj ◁ F) ≫ L.capL Z := fun _ => rfl + have ht : ∀ g : L.obj ⊗ Y ⟶ Z, + (tensorLeftHomEquiv Y L.obj L.obj Z) g = + (λ_ Y).inv ≫ (L.sq.inv ▷ Y) ≫ + (α_ L.obj L.obj Y).hom ≫ (L.obj ◁ g) := fun _ => rfl + change (L.obj ◁ ((λ_ Y).inv ≫ (L.sq.inv ▷ Y) ≫ + (α_ L.obj L.obj Y).hom ≫ (L.obj ◁ g))) ≫ L.capL Z = g + rw [← hs, ← ht, Equiv.symm_apply_apply] + +/-- **The even component**: points of a left twist by the odd line +are odd elements of the module. -/ +noncomputable def gammaTwistLeftEven + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (Z : D) : + (𝟙_ D ⟶ L.obj ⊗ Z) ≃ₗ[ℂ] (L.obj ⟶ Z) := + (L.capLEquiv (𝟙_ D) Z).trans + (Linear.homCongr ℂ (ρ_ L.obj) (Iso.refl Z)) + +theorem gammaTwistLeftEven_apply + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (Z : D) + (f : 𝟙_ D ⟶ L.obj ⊗ Z) : + (gammaTwistLeftEven L Z).toLinearMap f = + (ρ_ L.obj).inv ≫ (L.obj ◁ f) ≫ L.capL Z := by + change gammaTwistLeftEven L Z f = _ + rw [gammaTwistLeftEven, LinearEquiv.trans_apply, + Linear.homCongr_apply, Iso.refl_hom, Category.comp_id] + rfl + +/-- **The odd component**: odd elements of a left twist by the odd +line are points of the module. The sign is the self-braiding of +the odd line, and it is what makes the odd blocks of the twist +match the shifted blocks of the module. -/ +noncomputable def gammaTwistLeftOdd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (Z : D) : + (L.obj ⟶ L.obj ⊗ Z) ≃ₗ[ℂ] (𝟙_ D ⟶ Z) := + ((L.capLEquiv L.obj Z).trans + (Linear.homCongr ℂ L.sq (Iso.refl Z))).trans (LinearEquiv.neg ℂ) + +theorem gammaTwistLeftOdd_apply + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (Z : D) + (g : L.obj ⟶ L.obj ⊗ Z) : + (gammaTwistLeftOdd L Z).toLinearMap g = + (-L.sq.inv) ≫ (L.obj ◁ g) ≫ L.capL Z := by + change gammaTwistLeftOdd L Z g = _ + rw [gammaTwistLeftOdd, LinearEquiv.trans_apply, + LinearEquiv.trans_apply, LinearEquiv.neg_apply, + Linear.homCongr_apply, Iso.refl_hom, Category.comp_id, + Preadditive.neg_comp] + rfl + +end Equivalence + +/-! ## The parity shift of the Γ-module -/ + +section Twist + +variable {D : Type u} + +/-- **The two contractions form a morphism of Γ-modules**: they +intertwine the four action blocks of the Γ-module of the left twist +with the four relabelled blocks of the parity shift of the +Γ-module of the module. -/ +noncomputable def gammaTwistLeftHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (R : D) + [MonObj R] [IsCommMonObj R] (N : Mod D R) : + gammaModule D L R (tensorLeftMod R L.obj N).X ⟶ + SuperCommAlgebra.Mod.shift (gammaModule D L R N.X) where + evenMap := (gammaTwistLeftEven L N.X).toLinearMap + oddMap := (gammaTwistLeftOdd L N.X).toLinearMap + map_actEE x m := by + refine left_cap_slide' L R N.X x m (λ_ (𝟙_ D)).inv + (ρ_ L.obj).inv (ρ_ L.obj).inv (λ_ L.obj).inv + (gammaTwistLeftEven_apply L N.X) + (gammaTwistLeftEven_apply L N.X) _ rfl ?_ + rw [braidPast_hom, braiding_tensorUnit_right] + monoidal + map_actEO x m := by + refine left_cap_slide' L R N.X x m (λ_ L.obj).inv + (-L.sq.inv) (-L.sq.inv) (λ_ (𝟙_ D)).inv + (gammaTwistLeftOdd_apply L N.X) + (gammaTwistLeftOdd_apply L N.X) _ rfl ?_ + have hc : (L.obj ◁ (λ_ L.obj).inv) ≫ + (braidPast L.obj (𝟙_ D) L.obj).hom = + (λ_ (L.obj ⊗ L.obj)).inv := by + rw [braidPast_hom, braiding_tensorUnit_right] + monoidal + rw [hc, whiskerLeft_neg, Preadditive.neg_comp, + Preadditive.comp_neg, leftUnitor_inv_naturality] + map_actOE u m := by + refine left_cap_slide' L R N.X u m (ρ_ L.obj).inv + (-L.sq.inv) (ρ_ L.obj).inv L.sq.inv + (gammaTwistLeftOdd_apply L N.X) + (gammaTwistLeftEven_apply L N.X) _ rfl ?_ + have hb : (braidPast L.obj L.obj (𝟙_ D)).hom = + -𝟙 (L.obj ⊗ (L.obj ⊗ 𝟙_ D)) := by + rw [braidPast_hom, L.braid_neg, neg_id_whiskerRight] + simp + rw [hb] + simp only [Preadditive.comp_neg, Preadditive.neg_comp, + Category.comp_id, neg_neg] + map_actOO u m := by + refine left_cap_slide' L R N.X u m L.sq.inv + (ρ_ L.obj).inv (-L.sq.inv) (ρ_ L.obj).inv + (gammaTwistLeftEven_apply L N.X) + (gammaTwistLeftOdd_apply L N.X) _ rfl ?_ + have hb : (braidPast L.obj L.obj L.obj).hom = + -𝟙 (L.obj ⊗ (L.obj ⊗ L.obj)) := by + rw [braidPast_hom, L.braid_neg, neg_id_whiskerRight] + simp + rw [hb] + simp only [whiskerLeft_neg, Preadditive.comp_neg, + Category.comp_id] + +end Twist + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GeneratorAlgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GeneratorAlgebra.lean new file mode 100644 index 0000000000..c5aeed5449 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GeneratorAlgebra.lean @@ -0,0 +1,76 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescentClose +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndLocallyMixed +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndUnitNonzero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitInd + +/-! +# The splitting algebra of a single object + +The argument of Deligne §2.11 tensors together a splitting algebra +for every object of the category and a section for every short exact +sequence. The index family is then as large as the category itself, +and the ring of scalars of the result has no dimension bound. + +Only one object need be split. Over a *simple* algebra the free +modules on the unit and on the odd line are simple, so a free mixed +module is semisimple of finite length and every subquotient of it is +again free mixed; the class of split objects is therefore closed +under subobjects and quotients as well as sums, tensor products and +duals, and a tensor generator drags the whole category into it. + +This module supplies the entry point: for a single object, a +splitting algebra that is *countably presented*, which is what makes +its scalars a field of countable dimension over the complex numbers, +hence the complex numbers themselves. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v + +variable {C : Type v} + +/-- **The splitting algebra of a single object, countably +presented.** Proposition 2.9 makes the object locally mixed, and +the countable descent replaces the witnessing algebra by a countably +presented one. -/ +theorem exists_generator_algebra + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + (ψ : ℂ ≃+* End (𝟙_ C)) + (P : SchurPackage.{v}) (P₀ : SchurPackage.{0}) + (L : OddLine (Ind C)) (X₀ : C) (lam : YoungDiagram) + (hkill : letI := linearOfScalarUnit ψ; SchurKilled P X₀ lam) + (hlen : ∀ Z : C, ∃ N : ℕ, LengthLE Z N) : + letI := linearOfScalarUnit ψ + letI := monoidalLinearOfScalarUnitBraided ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + letI := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + ∃ (p q : ℕ) (𝔸 : Ind C) (_ : MonObj 𝔸) (_ : IsCommMonObj 𝔸), + η[𝔸] ≠ 0 ∧ CountablyPresented 𝔸 ∧ + Nonempty (freeMod 𝔸 ((indOf : C ⥤ Ind C).obj X₀) ≅ + freeMod 𝔸 (L.mix p q)) := by + let := linearOfScalarUnit ψ + let := monoidalLinearOfScalarUnitBraided ψ + let := linearOfScalarUnit (indScalarUnit ψ) + let := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + have hu : HasScalarUnit C := hasScalarUnit_of_scalarUnit ψ + have h1 : ¬ IsZero (𝟙_ (Ind C)) := not_isZero_unit_ind hu + exact locallyMixed_countablyPresented L + ((indOf : C ⥤ Ind C).obj X₀) (indCompactObj_indOf X₀) hlen + (locallyMixed_indOf ψ P P₀ X₀ lam hkill L h1) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GrowthDichotomy.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GrowthDichotomy.lean new file mode 100644 index 0000000000..6f5ce7c223 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GrowthDichotomy.lean @@ -0,0 +1,360 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IdempotentLength +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FactorialBeats +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BlockUnits +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.WhiskerFaithful +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitSimple +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorPowZero + +/-! +# Moderate growth forces Schur vanishing + +Deligne's 1.20 (Catégories tensorielles): if no Schur functor kills +`X`, then for every `n` the tensor power `X ^ ⊗ n` carries, through +`permAlg`, one nonzero idempotent for each unit of each block — +`∑_{μ ⊢ n} dim μ` many, pairwise orthogonal — so its length is at +least `√(n!) − 1`, which outgrows every geometric progression. +Contrapositive: moderate length growth yields a shape whose Schur +functor vanishes. + +The two block-theoretic inputs — completeness and orthogonality of +the central idempotents at each size — are named `Prop`s here and +discharged for the tree's package where the block theory lives. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +/-- **Completeness of the blocks**: at every size the central +idempotents sum to the identity of the group algebra. -/ +def SchurPackage.Complete (P : SchurPackage.{u}) : Prop := + ∀ n : ℕ, ∑ μ : Shape n, Shape.e P μ = 1 + +/-- **Orthogonality of the blocks**: distinct shapes of one size +have orthogonal central idempotents. -/ +def SchurPackage.Orthogonal (P : SchurPackage.{u}) : Prop := + ∀ (n : ℕ) (μ ν : Shape n), μ ≠ ν → + Shape.e P μ * Shape.e P ν = 0 + +variable {A : Type u} + +/-- **Moderate growth forces Schur vanishing** (Catégories +tensorielles, 1.20), assembly form: the block-theoretic inputs — +completeness, orthogonality, the block units — and the +nonvanishing transport up the standard embedding are hypotheses, +discharged elsewhere. -/ +theorem exists_schurKilled_of_lengthLE + [Category.{v} A] [Abelian A] [MonoidalCategory A] [SymmetricCategory A] + [Linear ℂ A] + (P : SchurPackage.{v}) (hO : P.Orthogonal) + (hunits : ∀ μ : YoungDiagram, + ∃ u : Fin (P.dim μ) → SymGroupAlgebra μ.card, + (∀ i, u i * u i = u i) ∧ + (∀ i j, i ≠ j → u i * u j = 0) ∧ + (∀ i, P.e μ * u i = u i) ∧ + (∀ i, u i * P.e μ = u i) ∧ + (∀ i, u i ≠ 0)) + (hsum : ∀ n : ℕ, + Real.sqrt n.factorial ≤ ((∑ μ : Shape n, P.dim μ.val : ℕ) : ℝ)) + (X : A) + (hup : ∀ {m n : ℕ} (h : m ≤ n) (x : SymGroupAlgebra m), + permAlg X m x ≠ 0 → permAlg X n (symCast h x) ≠ 0) + {C c : ℕ} + (hlen : ∀ N : ℕ, LengthLE (tensorPow A X N) (C * c ^ N)) : + ∃ μ : YoungDiagram, SchurKilled P X μ := by + by_contra hall + push Not at hall + -- ═══════ STAGE 1: CHOOSE THE SIZE ═══════ + -- A size at which `√(n!)` clears the growth bound with room for + -- the `+ 1` of the idempotent count. + obtain ⟨n, hn⟩ := + exists_lt_sqrt_factorial ((C : ℝ) + 1) ((c : ℝ) + 1) + have hclear : ((C * c ^ n : ℕ) : ℝ) + 1 < Real.sqrt n.factorial := by + refine lt_of_le_of_lt ?_ hn + push_cast + have hc0 : (0 : ℝ) ≤ (c : ℝ) := Nat.cast_nonneg c + have h1 : (1 : ℝ) ≤ ((c : ℝ) + 1) ^ n := + one_le_pow₀ (by linarith) + have h2 : (c : ℝ) ^ n ≤ ((c : ℝ) + 1) ^ n := + pow_le_pow_left₀ hc0 (by linarith) n + nlinarith [h1, h2, (Nat.cast_nonneg C : (0 : ℝ) ≤ (C : ℝ))] + -- ═══════ STAGE 2: THE ORTHOGONAL FAMILY ═══════ + -- One idempotent per block unit, all recast into `S_n` and pushed + -- through the action. + choose u hui huo hue hue' hun using hunits + set F := fun p : (μ : Shape n) × Fin (P.dim μ.val) => + permAlg X n (symCast (le_of_eq p.1.prop) (u p.1.val p.2)) + with hF + have hcastu : ∀ (μ : Shape n) (i : Fin (P.dim μ.val)), + symCast (le_of_eq μ.prop) (u μ.val i) * Shape.e P μ = + symCast (le_of_eq μ.prop) (u μ.val i) := by + intro μ i + rw [Shape.e, ← map_mul, hue'] + have hcastu' : ∀ (μ : Shape n) (i : Fin (P.dim μ.val)), + Shape.e P μ * symCast (le_of_eq μ.prop) (u μ.val i) = + symCast (le_of_eq μ.prop) (u μ.val i) := by + intro μ i + rw [Shape.e, ← map_mul, hue] + have hFidem : ∀ p, F p * F p = F p := by + intro ⟨μ, i⟩ + rw [hF, ← map_mul, ← map_mul, hui] + have hForth : ∀ p q, p ≠ q → F p * F q = 0 := by + rintro ⟨μ, i⟩ ⟨ν, j⟩ hpq + rw [hF, ← map_mul] + by_cases hμν : μ = ν + · subst hμν + have hij : i ≠ j := fun h => hpq (by rw [h]) + rw [← map_mul, huo _ _ _ hij, map_zero, map_zero] + · rw [show symCast (le_of_eq μ.prop) (u μ.val i) * + symCast (le_of_eq ν.prop) (u ν.val j) = + (symCast (le_of_eq μ.prop) (u μ.val i) * Shape.e P μ) * + (Shape.e P ν * symCast (le_of_eq ν.prop) (u ν.val j)) + from by rw [hcastu, hcastu'], + mul_assoc, ← mul_assoc (Shape.e P μ), hO n μ ν hμν, + zero_mul, mul_zero, map_zero] + have hFne : ∀ p, F p ≠ 0 := by + intro ⟨μ, i⟩ + refine hup (le_of_eq μ.prop) _ ?_ + intro hz + have hlowe : permAlg X μ.val.card (P.e μ.val) ≠ 0 := hall μ.val + have : permAlg X μ.val.card (P.e μ.val * u μ.val i) = 0 := by + rw [hue, hz] + have hzero := P.block_faithful μ.val _ _ hlowe _ this + rw [← SchurPackage.e_def, hue] at hzero + exact hun μ.val i hzero + -- ═══════ STAGE 3: COUNT AGAINST THE LENGTH ═══════ + have hcard : + Fintype.card ((μ : Shape n) × Fin (P.dim μ.val)) = + ∑ μ : Shape n, P.dim μ.val := by + simp [Fintype.card_sigma] + set k := ∑ μ : Shape n, P.dim μ.val with hk + have hbound : k ≤ C * c ^ n + 1 := by + have := le_of_orthogonal_idempotents (hlen n) + (F ∘ (Fintype.equivFin _).symm) + (fun i => hFidem _) + (fun i j hij => hForth _ _ + (fun h => hij ((Fintype.equivFin _).symm.injective h))) + (fun i => hFne _) + rwa [hcard] at this + -- ═══════ STAGE 4: THE CONTRADICTION ═══════ + -- `√(n!) ≤ k ≤ C·cⁿ + 1 < √(n!)`. + have hkr : ((k : ℕ) : ℝ) ≤ ((C * c ^ n : ℕ) : ℝ) + 1 := by + exact_mod_cast hbound + exact absurd (lt_of_le_of_lt (le_trans (hsum n) hkr) hclear) + (lt_irrefl _) + +/-- **Moderate growth forces Schur vanishing** (Catégories +tensorielles, 1.20), final form: every hypothesis slot discharged — +orthogonality and the dimension bound from the package's block +theory, the block units from its matrix structure, and the +transport from whisker faithfulness. Only simplicity of the unit +and nonvanishing of `X` remain, both facts of the ambient +category. -/ +theorem exists_schurKilled_of_moderateGrowth + [Category.{v} A] [Abelian A] [MonoidalCategory A] [SymmetricCategory A] + [Linear ℂ A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] [RigidCategory A] + (P : SchurPackage.{v}) (hs : Simple (𝟙_ A)) {X : A} + (hX : ¬ Limits.IsZero X) {C c : ℕ} + (hlen : ∀ N : ℕ, LengthLE (tensorPow A X N) (C * c ^ N)) : + ∃ μ : YoungDiagram, SchurKilled P X μ := by + refine exists_schurKilled_of_lengthLE P + (fun n μ ν h => P.shape_e_orthogonal μ ν h) ?_ + P.sqrt_factorial_le_sum_dim X + (fun {m n} h x hx => permAlg_symCast_ne_zero hs hX h x hx) + hlen + intro μ + obtain ⟨u, h1, h2, h3, h4, _, h6⟩ := P.exists_block_units μ + exact ⟨u, h1, h2, h3, h4, h6⟩ + +/-- **The completeness collapse**: if every shape of size `k` kills +`X`, the `k`-th tensor power is zero — the central idempotents sum +to the identity, and each acts as zero. -/ +theorem isZero_tensorPow_of_schurKilled + [Category.{v} A] [Abelian A] [MonoidalCategory A] [SymmetricCategory A] + [Linear ℂ A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] + (P : SchurPackage.{v}) {X : A} {k : ℕ} + (h : ∀ μ : Shape k, SchurKilled P X μ.val) : + Limits.IsZero (tensorPow A X k) := by + rw [Limits.IsZero.iff_id_eq_zero, ← End.one_def] + calc (1 : End (tensorPow A X k)) + = permAlg X k 1 := (map_one _).symm + _ = permAlg X k (∑ μ : Shape k, Shape.e P μ) := by + rw [P.sum_shape_e_eq_one] + _ = ∑ μ : Shape k, permAlg X k (Shape.e P μ) := map_sum _ _ _ + _ = 0 := Finset.sum_eq_zero fun μ _ => + permAlg_compat X (le_of_eq μ.prop) _ (h μ) + +/-- The moderate-growth dichotomy over a scalar unit: with +`End (𝟙) = ℂ` the simplicity hypothesis discharges as well, leaving +only nonvanishing of the generator. -/ +theorem exists_schurKilled_of_moderateGrowth' + [Category.{v} A] [Abelian A] [MonoidalCategory A] [SymmetricCategory A] + [Linear ℂ A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] [RigidCategory A] + (P : SchurPackage.{v}) (hu : HasScalarUnit A) {X : A} + (hX : ¬ Limits.IsZero X) {C c : ℕ} + (hlen : ∀ N : ℕ, LengthLE (tensorPow A X N) (C * c ^ N)) : + ∃ μ : YoungDiagram, SchurKilled P X μ := + exists_schurKilled_of_moderateGrowth P + (simple_unit_of_hasScalarUnit hu) hX hlen + +/-- Under moderate growth every object has finite length: evaluate +the growth bound at the first tensor power. -/ +theorem exists_lengthLE_of_moderateGrowth {C : Type*} [Category C] + [MonoidalCategory C] (h : ModerateLengthGrowth C) (X : C) : + ∃ N : ℕ, LengthLE X N := by + obtain ⟨c₀, c, hN⟩ := h X + exact ⟨c₀ * c ^ 1, (hN 1).of_iso (λ_ X)⟩ + +/-- A zero object is killed by every Schur functor of positive +size: its positive tensor powers are zero. -/ +theorem SchurKilled.of_isZero + [Category.{v} A] [Abelian A] [MonoidalCategory A] [SymmetricCategory A] + [Linear ℂ A] + [MonoidalPreadditive A] + (P : SchurPackage.{v}) {X : A} (hX : Limits.IsZero X) + {lam : YoungDiagram} (hcard : 0 < lam.card) : + SchurKilled P X lam := by + rw [SchurKilled] + obtain ⟨n, hn⟩ : ∃ n, lam.card = n + 1 := + ⟨lam.card - 1, by omega⟩ + have hzero : Limits.IsZero (tensorPow A X lam.card) := by + rw [hn] + rw [Limits.IsZero.iff_id_eq_zero] + rw [show 𝟙 (tensorPow A X (n + 1)) = + tensorPow A X n ◁ 𝟙 X from + (MonoidalCategory.whiskerLeft_id _ _).symm] + rw [Limits.IsZero.iff_id_eq_zero] at hX + rw [hX, MonoidalPreadditive.whiskerLeft_zero] + rfl + exact hzero.eq_of_src _ _ + +/-- **Every object is Schur-killed under moderate growth** — the +hypothesis of Deligne 2.1 in the form the pinned statement +supplies it. -/ +theorem forall_exists_schurKilled + [Category.{v} A] [Abelian A] [MonoidalCategory A] [SymmetricCategory A] + [Linear ℂ A] + [MonoidalPreadditive A] + [MonoidalLinear ℂ A] [RigidCategory A] (P : SchurPackage.{v}) + (hu : HasScalarUnit A) (hg : ModerateLengthGrowth A) : + ∀ X : A, ∃ μ : YoungDiagram, SchurKilled P X μ := by + intro X + by_cases hX : Limits.IsZero X + · refine ⟨(colShape 2).val, SchurKilled.of_isZero P hX ?_⟩ + rw [(colShape 2).prop] + omega + · obtain ⟨c₀, c, hN⟩ := hg X + exact exists_schurKilled_of_moderateGrowth' P hu hX hN + +/-- Containment of the single row. -/ +theorem rowShape_le_iff {m : ℕ} {lam : YoungDiagram} : + (rowShape m).val ≤ lam ↔ m ≤ lam.rowLen 0 := by + constructor + · intro h + rcases Nat.eq_zero_or_pos m with h0 | hpos + · omega + · have := h (show ((0, m - 1) : ℕ × ℕ) ∈ (rowShape m).val by + rw [YoungDiagram.mem_iff_lt_rowLen, rowShape_rowLen_zero] + omega) + rw [YoungDiagram.mem_iff_lt_rowLen] at this + omega + · intro h c hc + obtain ⟨i, j⟩ := c + rw [YoungDiagram.mem_iff_lt_rowLen] at hc ⊢ + rcases Nat.eq_zero_or_pos i with rfl | hpos + · rw [rowShape_rowLen_zero] at hc + omega + · obtain ⟨i', rfl⟩ : ∃ i', i = i' + 1 := ⟨i - 1, by omega⟩ + rw [rowShape_rowLen_succ] at hc + omega + +/-- Containment of the single column. -/ +theorem colShape_le_iff {m : ℕ} {lam : YoungDiagram} : + (colShape m).val ≤ lam ↔ m ≤ lam.colLen 0 := by + constructor + · intro h + rcases Nat.eq_zero_or_pos m with h0 | hpos + · omega + · have := h (show ((m - 1, 0) : ℕ × ℕ) ∈ (colShape m).val by + rw [YoungDiagram.mem_iff_lt_rowLen, + colShape_rowLen_lt m (by omega)] + omega) + rw [YoungDiagram.mem_iff_lt_colLen] at this + omega + · intro h c hc + obtain ⟨i, j⟩ := c + rw [YoungDiagram.mem_iff_lt_rowLen] at hc + by_cases him : i < m + · rw [colShape_rowLen_lt m him] at hc + have hj : j = 0 := by omega + subst hj + rw [YoungDiagram.mem_iff_lt_colLen] + omega + · rw [colShape_rowLen_le m (by omega)] at hc + omega + +/-- A cell's coordinates are bounded by the cell count. -/ +theorem cell_lt_card {lam : YoungDiagram} {p q : ℕ} + (h : (p, q) ∈ lam) : p < lam.card ∧ q < lam.card := by + constructor + · have h0 : (p, 0) ∈ lam := + lam.up_left_mem le_rfl (Nat.zero_le _) h + have hlt : p < lam.colLen 0 := by + rw [← YoungDiagram.mem_iff_lt_colLen] + exact h0 + have hle : lam.colLen 0 ≤ lam.card := by + rw [YoungDiagram.colLen_eq_card] + exact Finset.card_le_card (Finset.filter_subset _ _) + omega + · have h0 : (p, 0) ∈ lam := + lam.up_left_mem le_rfl (Nat.zero_le _) h + have h1 : (0, q) ∈ lam := + lam.up_left_mem (Nat.zero_le _) le_rfl h + have hlt : q < lam.rowLen 0 := by + rw [← YoungDiagram.mem_iff_lt_rowLen] + exact h1 + have hle : lam.rowLen 0 ≤ lam.card := by + rw [YoungDiagram.rowLen_eq_card] + exact Finset.card_le_card (Finset.filter_subset _ _) + omega + +/-- The bounding-box count: a diagram fits in the rectangle of its +first row and column. -/ +theorem card_le_colLen_mul_rowLen (lam : YoungDiagram) : + lam.card ≤ lam.colLen 0 * lam.rowLen 0 := by + classical + have hsub : lam.cells ⊆ + Finset.range (lam.colLen 0) ×ˢ Finset.range (lam.rowLen 0) := by + intro c hc + obtain ⟨i, j⟩ := c + rw [Finset.mem_product, Finset.mem_range, Finset.mem_range] + have hmem : (i, j) ∈ lam := hc + constructor + · rw [← YoungDiagram.mem_iff_lt_colLen] + exact lam.up_left_mem le_rfl (Nat.zero_le _) hmem + · rw [← YoungDiagram.mem_iff_lt_rowLen] + exact lam.up_left_mem (Nat.zero_le _) le_rfl hmem + calc lam.card ≤ (Finset.range (lam.colLen 0) ×ˢ + Finset.range (lam.rowLen 0)).card := Finset.card_le_card hsub + _ = lam.colLen 0 * lam.rowLen 0 := by + rw [Finset.card_product, Finset.card_range, + Finset.card_range] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/HomFinite.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HomFinite.lean new file mode 100644 index 0000000000..7434ecbdd1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HomFinite.lean @@ -0,0 +1,437 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitSimple + +/-! +# Finite length bounds Hom-dimension from the unit + +In the setting of Deligne's theorem — an abelian ℂ-linear rigid +monoidal category whose unit endomorphisms are exactly the scalars — +the Hom-space out of the tensor unit is finite dimensional whenever +the target has bounded length, with dimension at most the length +bound. This is the Hom-finiteness input of Deligne's Proposition +2.1. + +The route: a nonzero map `φ : 𝟙 ⟶ Z` is a monomorphism because the +unit is simple (`simple_unit_of_hasScalarUnit`), and pulling +subobjects of `cokernel φ` back along the projection embeds its +subobject chains strictly above the nonzero subobject `φ`, so the +length bound drops by one on the cokernel. Left-exactness of +`Hom (𝟙, −)`, in the concrete form that a map annihilated by the +projection factors through `φ` with a scalar coefficient, bounds the +kernel of the induced linear map by one dimension, and induction +along the length bound does the rest. + +At the bottom of the induction sits the simple case, recorded +separately: `Hom (𝟙, S)` vanishes for a simple `S` not isomorphic +to the unit, and is the line `End (𝟙_ A) = ℂ` when it is — the +scalar-unit hypothesis read as a ℂ-linear equivalence. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Limits MonoidalCategory + +universe v u + +/-! ## The unit endomorphisms are a line + +The scalar-unit hypothesis says that scaling the identity of the +tensor unit is a bijection `ℂ → End (𝟙)`. Scaling is ℂ-linear, so +the bijection is a ℂ-linear equivalence and `End (𝟙)` is a line. +Transporting along an isomorphism `𝟙 ≅ S` gives the same for +`𝟙 ⟶ S`. -/ + +section ScalarEnd + +variable {A : Type u} + +/-- Scaling the identity of the tensor unit, as a ℂ-linear map. -/ +def unitScalarMap + [Category.{v} A] [Preadditive A] [Linear ℂ A] [MonoidalCategory A] : + ℂ →ₗ[ℂ] (𝟙_ A ⟶ 𝟙_ A) where + toFun c := c • 𝟙 (𝟙_ A) + map_add' a b := add_smul a b _ + map_smul' a b := mul_smul a b _ + +/-- **The scalars exhaust the unit endomorphisms**, as a ℂ-linear +equivalence `ℂ ≃ₗ End (𝟙_ A)`: this is exactly the content of +`HasScalarUnit`, packaged linearly. -/ +noncomputable def unitEndEquiv + [Category.{v} A] [Preadditive A] [Linear ℂ A] [MonoidalCategory A] + (hu : HasScalarUnit A) : + ℂ ≃ₗ[ℂ] (𝟙_ A ⟶ 𝟙_ A) := + LinearEquiv.ofBijective unitScalarMap hu + +@[simp] theorem unitEndEquiv_apply + [Category.{v} A] [Preadditive A] [Linear ℂ A] [MonoidalCategory A] + (hu : HasScalarUnit A) (c : ℂ) : + unitEndEquiv hu c = c • 𝟙 (𝟙_ A) := rfl + +/-- **The unit endomorphisms are one dimensional.** -/ +theorem finrank_end_unit + [Category.{v} A] [Preadditive A] [Linear ℂ A] [MonoidalCategory A] + (hu : HasScalarUnit A) : + Module.finrank ℂ (𝟙_ A ⟶ 𝟙_ A) = 1 := by + rw [← (unitEndEquiv hu).finrank_eq, Module.finrank_self] + +/-- An isomorphism `𝟙 ≅ S` identifies `𝟙 ⟶ S` with the unit +endomorphisms, ℂ-linearly. -/ +noncomputable def homUnitEquivOfIso + [Category.{v} A] [Preadditive A] [Linear ℂ A] [MonoidalCategory A] + {S : A} (e : 𝟙_ A ≅ S) : + (𝟙_ A ⟶ S) ≃ₗ[ℂ] (𝟙_ A ⟶ 𝟙_ A) := + Linear.homCongr ℂ (Iso.refl (𝟙_ A)) e.symm + +/-- **`Hom (𝟙, S)` is a line when `S` is isomorphic to the unit**: +it is then `End (𝟙_ A) = ℂ`. -/ +theorem finrank_hom_unit_of_iso + [Category.{v} A] [Preadditive A] [Linear ℂ A] [MonoidalCategory A] + (hu : HasScalarUnit A) {S : A} + (e : 𝟙_ A ≅ S) : Module.finrank ℂ (𝟙_ A ⟶ S) = 1 := + ((homUnitEquivOfIso e).finrank_eq).trans (finrank_end_unit hu) + +end ScalarEnd + +/-! ## Maps from the unit to a simple object are proportional + +Schur's lemma between the simple unit and a simple target: any +nonzero `φ : 𝟙 ⟶ S` is an isomorphism, so every `ψ : 𝟙 ⟶ S` is a +scalar multiple of it, the scalar produced by `HasScalarUnit`. -/ + +section Proportional + +variable {A : Type u} + +/-- A nonzero map from the unit to a simple object is an +isomorphism, the unit being simple; so a simple object receiving a +nonzero map from the unit *is* the unit up to isomorphism. -/ +theorem nonempty_unitIso_of_hom_ne_zero + [Category.{v} A] [Abelian A] [Linear ℂ A] [MonoidalCategory A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] [RigidCategory A] + (hu : HasScalarUnit A) + {S : A} [Simple S] {φ : 𝟙_ A ⟶ S} (hφ : φ ≠ 0) : + Nonempty (𝟙_ A ≅ S) := by + have : Simple (𝟙_ A) := simple_unit_of_hasScalarUnit hu + have : IsIso φ := isIso_of_hom_simple hφ + exact ⟨asIso φ⟩ + +/-- **Maps from the unit to a simple object not isomorphic to it +vanish.** -/ +theorem hom_unit_simple_eq_zero + [Category.{v} A] [Abelian A] [Linear ℂ A] [MonoidalCategory A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] [RigidCategory A] + (hu : HasScalarUnit A) {S : A} + [Simple S] (h : IsEmpty (𝟙_ A ≅ S)) (φ : 𝟙_ A ⟶ S) : φ = 0 := by + by_contra hφ + exact h.elim (nonempty_unitIso_of_hom_ne_zero hu hφ).some + +/-- `Hom (𝟙, S)` is trivial for a simple `S` not isomorphic to the +unit. -/ +theorem subsingleton_hom_unit_simple + [Category.{v} A] [Abelian A] [Linear ℂ A] [MonoidalCategory A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] [RigidCategory A] + (hu : HasScalarUnit A) {S : A} + [Simple S] (h : IsEmpty (𝟙_ A ≅ S)) : + Subsingleton (𝟙_ A ⟶ S) := + ⟨fun f g => by + rw [hom_unit_simple_eq_zero hu h f, hom_unit_simple_eq_zero hu h g]⟩ + +/-- **`Hom (𝟙, S)` vanishes for a simple `S` not isomorphic to the +unit.** -/ +theorem finrank_hom_unit_simple_eq_zero + [Category.{v} A] [Abelian A] [Linear ℂ A] [MonoidalCategory A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] [RigidCategory A] + (hu : HasScalarUnit A) + {S : A} [Simple S] (h : IsEmpty (𝟙_ A ≅ S)) : + Module.finrank ℂ (𝟙_ A ⟶ S) = 0 := by + have := subsingleton_hom_unit_simple hu h + exact Module.finrank_zero_of_subsingleton + +end Proportional + +/-! ## Quotients drop the length bound + +Pulling a subobject of a quotient back along the projection gives a +subobject of the ambient object. The operation is monotone, and +along an epimorphism it reflects inequalities, so it embeds strict +chains; every pullback contains the kernel of the projection, so for +the quotient by a nonzero subobject the embedded chain sits strictly +above `⊥` and the length bound drops by one. -/ + +section QuotientLength + +variable {C : Type u} + +/-- The pullback of a subobject along a morphism into its ambient +object. -/ +private noncomputable def pbSub [Category.{v} C] [Abelian C] + {Z W : C} (π : Z ⟶ W) + (P : Subobject W) : Subobject Z := + Subobject.mk (pullback.snd P.arrow π) + +/-- Pulling subobjects back is monotone. -/ +private lemma pbSub_mono [Category.{v} C] [Abelian C] + {Z W : C} (π : Z ⟶ W) {P Q : Subobject W} + (h : P ≤ Q) : pbSub π P ≤ pbSub π Q := by + refine Subobject.mk_le_mk_of_comm + (pullback.lift (pullback.fst P.arrow π ≫ Subobject.ofLE P Q h) + (pullback.snd P.arrow π) ?_) (pullback.lift_snd _ _ _) + rw [Category.assoc, Subobject.ofLE_arrow] + exact pullback.condition + +/-- Along an epimorphism, pulling subobjects back reflects +inequalities: the pullback of `P` maps onto `P`, and a factorisation +of pullbacks descends along that epimorphism. -/ +private lemma le_of_pbSub_le [Category.{v} C] [Abelian C] + {Z W : C} (π : Z ⟶ W) [Epi π] + {P Q : Subobject W} (h : pbSub π P ≤ pbSub π Q) : P ≤ Q := by + have hu : Subobject.ofMkLEMk _ _ h ≫ pullback.snd Q.arrow π + = pullback.snd P.arrow π := + Subobject.ofMkLEMk_comp h + have hker : kernel.ι (pullback.fst P.arrow π) + ≫ (Subobject.ofMkLEMk _ _ h ≫ pullback.fst Q.arrow π) = 0 := by + rw [← cancel_mono Q.arrow] + simp only [Category.assoc, zero_comp] + rw [pullback.condition, ← Category.assoc (Subobject.ofMkLEMk _ _ h), + hu, ← pullback.condition, ← Category.assoc, kernel.condition, + zero_comp] + have hv := Abelian.comp_epiDesc (pullback.fst P.arrow π) + (Subobject.ofMkLEMk _ _ h ≫ pullback.fst Q.arrow π) hker + refine Subobject.le_of_comm + (Abelian.epiDesc (pullback.fst P.arrow π) + (Subobject.ofMkLEMk _ _ h ≫ pullback.fst Q.arrow π) hker) ?_ + rw [← cancel_epi (pullback.fst P.arrow π), ← Category.assoc, hv, + Category.assoc, pullback.condition, + ← Category.assoc (Subobject.ofMkLEMk _ _ h), hu, + ← pullback.condition] + +/-- Along an epimorphism, pulling subobjects back is strictly +monotone. -/ +private lemma pbSub_strictMono [Category.{v} C] [Abelian C] + {Z W : C} (π : Z ⟶ W) [Epi π] + {P Q : Subobject W} (h : P < Q) : pbSub π P < pbSub π Q := + lt_of_le_of_ne (pbSub_mono π h.le) fun he => + h.ne (le_antisymm h.le (le_of_pbSub_le π he.ge)) + +/-- Every subobject pulled back from the cokernel of `φ` contains +the subobject `φ`. -/ +private lemma mk_le_pbSub_cokernel [Category.{v} C] [Abelian C] + {U Z : C} (φ : U ⟶ Z) [Mono φ] + (P : Subobject (cokernel φ)) : + Subobject.mk φ ≤ pbSub (cokernel.π φ) P := by + refine Subobject.mk_le_mk_of_comm (pullback.lift 0 φ ?_) + (pullback.lift_snd _ _ _) + rw [zero_comp, cokernel.condition] + +/-- **Quotients by a nonzero subobject drop the length bound**: if +`LengthLE Z (N + 1)` and `φ : U ⟶ Z` is a nonzero monomorphism, then +`LengthLE (cokernel φ) N`. A strict chain in the cokernel pulls +back to a strict chain in `Z` sitting above the nonzero subobject +`φ`, so prepending `⊥` lengthens it by one. -/ +private theorem lengthLE_cokernel [Category.{v} C] [Abelian C] + {U Z : C} (φ : U ⟶ Z) [Mono φ] + (hφ : φ ≠ 0) {N : ℕ} (h : LengthLE Z (N + 1)) : + LengthLE (cokernel φ) N := by + intro f hf + refine h (Fin.cons ⊥ fun i => pbSub (cokernel.π φ) (f i)) ?_ + rw [Fin.strictMono_iff_lt_succ] + intro i + induction i using Fin.cases with + | zero => + rw [Fin.castSucc_zero, Fin.cons_zero, Fin.cons_succ] + refine Ne.bot_lt fun he => hφ ?_ + exact Subobject.mk_eq_bot_iff_zero.mp + (le_bot_iff.mp (he ▸ mk_le_pbSub_cokernel φ (f 0))) + | succ j => + rw [← Fin.succ_castSucc, Fin.cons_succ, Fin.cons_succ] + exact pbSub_strictMono _ (hf (Fin.castSucc_lt_succ (i := j))) + +end QuotientLength + +/-! ## The induction along the length bound + +`Hom (𝟙, −)` is left exact; concretely, a map `𝟙 ⟶ Z` annihilated +by the projection to `cokernel φ` factors through the kernel `φ` of +that projection, with coefficient a unit endomorphism — a scalar. +So the kernel of postcomposition by the projection is at most one +dimensional, the quotient lemma above drops the length bound on the +cokernel, and rank-nullity closes the induction. -/ + +section Induction + +variable {A : Type u} + +/-- A map from the unit annihilated by the projection to the +cokernel of a monomorphism `φ` from the unit is a scalar multiple +of `φ`: it factors through the kernel of the projection, which is +`φ` itself, with coefficient in `End (𝟙) = ℂ`. -/ +private theorem eq_smul_of_comp_cokernel_π_zero + [Category.{v} A] [Abelian A] [Linear ℂ A] [MonoidalCategory A] + (hu : HasScalarUnit A) {Z : A} {φ ψ : 𝟙_ A ⟶ Z} [Mono φ] + (hψ : ψ ≫ cokernel.π φ = 0) : ∃ c : ℂ, ψ = c • φ := by + have hlim : IsLimit (KernelFork.ofι φ (cokernel.condition φ)) := + Abelian.monoIsKernelOfCokernel + (CokernelCofork.ofπ (cokernel.π φ) (cokernel.condition φ)) + (cokernelIsCokernel φ) + obtain ⟨χ, hχ⟩ := KernelFork.IsLimit.lift' hlim ψ hψ + simp only [Fork.ι_ofι] at hχ + obtain ⟨χ₀, hχ₀⟩ : ∃ χ₀ : 𝟙_ A ⟶ 𝟙_ A, χ₀ ≫ φ = ψ := ⟨χ, hχ⟩ + obtain ⟨c, hc⟩ := hu.surjective χ₀ + replace hc : c • 𝟙 (𝟙_ A) = χ₀ := hc + exact ⟨c, by rw [← hχ₀, ← hc, Linear.smul_comp, Category.id_comp]⟩ + +/-- The induction workhorse, with simplicity of the unit supplied as +a hypothesis: a length bound of `N` on `Z` makes `𝟙 ⟶ Z` a finite +dimensional ℂ-module of dimension at most `N`. -/ +private theorem homFinite_core + [Category.{v} A] [Abelian A] [Linear ℂ A] [MonoidalCategory A] + (hu : HasScalarUnit A) + (hs : Simple (𝟙_ A)) : + ∀ (N : ℕ) (Z : A), LengthLE Z N → + Module.Finite ℂ (𝟙_ A ⟶ Z) + ∧ Module.finrank ℂ (𝟙_ A ⟶ Z) ≤ N := by + have := hs + intro N + induction N with + | zero => + intro Z h + rcases subsingleton_or_nontrivial (𝟙_ A ⟶ Z) with hss | hnt + · have := hss + exact ⟨inferInstance, by + rw [Module.finrank_zero_of_subsingleton]⟩ + · have := hnt + obtain ⟨φ, hφ⟩ := exists_ne (0 : 𝟙_ A ⟶ Z) + have : Mono φ := mono_of_nonzero_from_simple hφ + refine absurd ?_ (h (Fin.cons ⊥ fun _ : Fin 1 => Subobject.mk φ)) + rw [Fin.strictMono_iff_lt_succ] + intro i + induction i using Fin.cases with + | zero => + rw [Fin.castSucc_zero, Fin.cons_zero, Fin.cons_succ] + exact Ne.bot_lt fun he => + hφ (Subobject.mk_eq_bot_iff_zero.mp he) + | succ j => exact j.elim0 + | succ M ih => + intro Z h + rcases subsingleton_or_nontrivial (𝟙_ A ⟶ Z) with hss | hnt + · have := hss + exact ⟨inferInstance, by + rw [Module.finrank_zero_of_subsingleton]; exact Nat.zero_le _⟩ + · have := hnt + obtain ⟨φ, hφ⟩ := exists_ne (0 : 𝟙_ A ⟶ Z) + have : Mono φ := mono_of_nonzero_from_simple hφ + obtain ⟨hfinQ, hrkQ⟩ := ih (cokernel φ) (lengthLE_cokernel φ hφ h) + have := hfinQ + set L : (𝟙_ A ⟶ Z) →ₗ[ℂ] (𝟙_ A ⟶ cokernel φ) := + Linear.rightComp ℂ (𝟙_ A) (cokernel.π φ) with hLdef + have hker : LinearMap.ker L ≤ Submodule.span ℂ {φ} := by + intro ψ hψ + have hψ0 : ψ ≫ cokernel.π φ = 0 := by + have hmem := LinearMap.mem_ker.mp hψ + rwa [hLdef, Linear.rightComp_apply] at hmem + obtain ⟨c, hc⟩ := eq_smul_of_comp_cokernel_π_zero hu hψ0 + exact Submodule.mem_span_singleton.mpr ⟨c, hc.symm⟩ + have hkfin : FiniteDimensional ℂ (LinearMap.ker L) := + Submodule.finiteDimensional_of_le hker + have hrfin : FiniteDimensional ℂ (LinearMap.range L) := + inferInstance + have hfin : Module.Finite ℂ (𝟙_ A ⟶ Z) := + Module.finite_def.mpr + (Submodule.fg_of_fg_map_of_fg_inf_ker L + (by rw [Submodule.map_top] + exact Module.Finite.iff_fg.mp hrfin) + (by rw [top_inf_eq] + exact Module.Finite.iff_fg.mp hkfin)) + refine ⟨hfin, ?_⟩ + have hsum := LinearMap.finrank_range_add_finrank_ker L + have h1 : Module.finrank ℂ (LinearMap.range L) ≤ M := + le_trans (Submodule.finrank_le _) hrkQ + have h2 : Module.finrank ℂ (LinearMap.ker L) ≤ 1 := by + have h3 := Submodule.finrank_mono hker + rwa [finrank_span_singleton hφ] at h3 + omega + +end Induction + +/-! ## The theorems -/ + +section Main + +variable {A : Type u} + +/-- **Finite length bounds Hom-dimension from the unit**: in the +setting of Deligne's theorem, a length bound of `N` on `Z` makes +`𝟙 ⟶ Z` a finite dimensional ℂ-module of dimension at most `N`. -/ +theorem finrank_hom_unit_le + [Category.{v} A] [Abelian A] [Linear ℂ A] [MonoidalCategory A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] [RigidCategory A] + (hu : HasScalarUnit A) {Z : A} {N : ℕ} + (h : LengthLE Z N) : + Module.Finite ℂ (𝟙_ A ⟶ Z) + ∧ Module.finrank ℂ (𝟙_ A ⟶ Z) ≤ N := + homFinite_core hu (simple_unit_of_hasScalarUnit hu) N Z h + +/-- The duality correspondence `(X ⟶ Y) ≃ₗ (𝟙 ⟶ Y ⊗ Xᘁ)` as a +ℂ-linear equivalence: precomposition by the left unitor followed by +the right-dual adjunction `tensorRightHomEquiv`. Linearity follows +from bilinearity of composition and of the tensor product. -/ +noncomputable def homUnitDualEquiv + [Category.{v} A] [Abelian A] [Linear ℂ A] [MonoidalCategory A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] [RigidCategory A] + (X Y : A) : + (X ⟶ Y) ≃ₗ[ℂ] (𝟙_ A ⟶ Y ⊗ Xᘁ) where + toFun f := tensorRightHomEquiv (𝟙_ A) X (Xᘁ) Y ((λ_ X).hom ≫ f) + map_add' f g := by simp [tensorRightHomEquiv, Preadditive.comp_add] + map_smul' c f := by simp [tensorRightHomEquiv, Linear.comp_smul] + invFun g := + (λ_ X).inv ≫ (tensorRightHomEquiv (𝟙_ A) X (Xᘁ) Y).symm g + left_inv f := by simp + right_inv g := by simp + +/-- **Finite length bounds every Hom-dimension**: in the setting of +Deligne's theorem, a length bound of `N` on `Y ⊗ Xᘁ` makes `X ⟶ Y` +a finite dimensional ℂ-module of dimension at most `N`, via the +duality correspondence `(X ⟶ Y) ≃ₗ (𝟙 ⟶ Y ⊗ Xᘁ)`. -/ +theorem finrank_hom_le + [Category.{v} A] [Abelian A] [Linear ℂ A] [MonoidalCategory A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] [RigidCategory A] + (hu : HasScalarUnit A) {X Y : A} {N : ℕ} + (h : LengthLE (Y ⊗ Xᘁ) N) : + Module.Finite ℂ (X ⟶ Y) ∧ Module.finrank ℂ (X ⟶ Y) ≤ N := by + obtain ⟨hfin, hrk⟩ := finrank_hom_unit_le hu h + have := hfin + refine ⟨Module.Finite.equiv (homUnitDualEquiv X Y).symm, ?_⟩ + rw [(homUnitDualEquiv X Y).finrank_eq] + exact hrk + +/-! ### Finite length, unquantified + +`LengthLE Z N` is the bound-shaped finite-length predicate of this +development; "`Z` has finite length" is `∃ N, LengthLE Z N`, and +"every object has finite length" is that statement quantified over +all objects. There is no finite-length typeclass here, so the +hypothesis is carried explicitly. -/ + +/-- **Hom out of the unit is finite dimensional** whenever the +target has finite length. -/ +theorem finiteDimensional_hom_unit + [Category.{v} A] [Abelian A] [Linear ℂ A] [MonoidalCategory A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] [RigidCategory A] + (hu : HasScalarUnit A) {Z : A} + (h : ∃ N : ℕ, LengthLE Z N) : + FiniteDimensional ℂ (𝟙_ A ⟶ Z) := by + obtain ⟨N, hN⟩ := h + exact (finrank_hom_unit_le hu hN).1 + +end Main + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookMult.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookMult.lean new file mode 100644 index 0000000000..6cfe2ef27f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookMult.lean @@ -0,0 +1,224 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos + +/-! +# Hook bounds on induction and Kronecker multiplicities + +Deligne 1.10 and 1.12, character side: if the induction +multiplicity `[λ : μ, ν]` is nonzero and `λ` contains the cell +`(p + r, q + s)`, then `μ` contains `(p, q)` or `ν` contains +`(r, s)`; and the Kronecker analogue at +`(pr + qs, ps + qr)`. Both by evaluation: the Schur +specialisation of `λ` at the corresponding super power sum +vanishes, every term of the bilinear splitting is a natural +number, so every term vanishes; hook positivity makes the two +specialisation factors nonzero, killing the multiplicity. +-/ + +@[expose] public section + +namespace RS + +/-- A finite sum of natural values vanishing termwise: if every +summand is a natural number and the sum is zero, each summand is +zero. -/ +theorem eq_zero_of_sum_nat_eq_zero {ι : Type*} {s : Finset ι} + {f : ι → ℂ} (h : ∀ i ∈ s, ∃ m : ℕ, f i = m) + (h0 : ∑ i ∈ s, f i = 0) : ∀ i ∈ s, f i = 0 := by + classical + -- Replace each value by its chosen natural witness. + have hg : ∀ i ∈ s, f i = + ((if h' : i ∈ s then Classical.choose (h i h') else 0 : ℕ) : + ℂ) := by + intro i hi + rw [dite_eq_left hi] + exact Classical.choose_spec (h i hi) + have hsum : ((∑ i ∈ s, + (if h' : i ∈ s then Classical.choose (h i h') else 0) : ℕ) : + ℂ) = 0 := by + rw [Nat.cast_sum, ← h0] + exact (Finset.sum_congr rfl hg).symm + rw [Nat.cast_eq_zero] at hsum + intro i hi + rw [hg i hi] + have := (Finset.sum_eq_zero_iff.mp hsum) i hi + rw [this, Nat.cast_zero] + +/-- **Deligne 1.10, character side**: an induction multiplicity +dies against the fat hook — if `λ` contains `(p + r, q + s)` while +`μ` avoids `(p, q)` and `ν` avoids `(r, s)`, then `[λ : μ, ν] = 0`. +-/ +theorem indMult_eq_zero_of_cells {a b : ℕ} (lam : Shape (a + b)) + (μ : Shape a) (ν : Shape b) {p q r s : ℕ} + (hμ : (p, q) ∉ μ.val) (hν : (r, s) ∉ ν.val) + (hlam : (p + r, q + s) ∈ lam.val) : indMult lam μ ν = 0 := by + classical + -- The specialisation of `λ` at the summed point vanishes. + have hzero : diagramSchur lam.val + (fun c => superPS p q c + superPS r s c) = 0 := by + rw [show (fun c => superPS p q c + superPS r s c) = + superPS (p + r) (q + s) from superPS_add p q r s] + exact diagramSchur_superPS_eq_zero lam.val hlam + rw [diagramSchur_add] at hzero + -- Every outer summand is a natural number. + have houter : ∀ ab ∈ (Finset.antidiagonal lam.val.card).attach, + ∃ m : ℕ, + (∑ μ' : Shape ab.1.1, ∑ ν' : Shape ab.1.2, + indMult ⟨lam.val, + (Finset.mem_antidiagonal.mp ab.2).symm⟩ μ' ν' * + diagramSchur μ'.val (superPS p q) * + diagramSchur ν'.val (superPS r s)) = m := by + intro ab _ + refine exists_nat_sum _ _ fun μ' _ => ?_ + refine exists_nat_sum _ _ fun ν' _ => ?_ + obtain ⟨m₁, h₁⟩ := indMult_exists_nat + (⟨lam.val, (Finset.mem_antidiagonal.mp ab.2).symm⟩ : + Shape (ab.1.1 + ab.1.2)) μ' ν' + obtain ⟨m₂, h₂⟩ := diagramSchur_superPS_exists_nat p q μ'.val + obtain ⟨m₃, h₃⟩ := diagramSchur_superPS_exists_nat r s ν'.val + exact ⟨m₁ * m₂ * m₃, by + rw [h₁, h₂, h₃, Nat.cast_mul, Nat.cast_mul]⟩ + -- Extract the `(a, b)` term, then the `(μ, ν)` term. + have hab : ((a, b) : ℕ × ℕ) ∈ + Finset.antidiagonal lam.val.card := + Finset.mem_antidiagonal.mpr lam.prop.symm + have hterm := eq_zero_of_sum_nat_eq_zero houter hzero + ⟨(a, b), hab⟩ (Finset.mem_attach _ _) + have hinner : ∀ μ' ∈ (Finset.univ : Finset (Shape a)), + ∃ m : ℕ, + (∑ ν' : Shape b, + indMult ⟨lam.val, lam.prop⟩ μ' ν' * + diagramSchur μ'.val (superPS p q) * + diagramSchur ν'.val (superPS r s)) = m := by + intro μ' _ + refine exists_nat_sum _ _ fun ν' _ => ?_ + obtain ⟨m₁, h₁⟩ := indMult_exists_nat + (⟨lam.val, lam.prop⟩ : Shape (a + b)) μ' ν' + obtain ⟨m₂, h₂⟩ := diagramSchur_superPS_exists_nat p q μ'.val + obtain ⟨m₃, h₃⟩ := diagramSchur_superPS_exists_nat r s ν'.val + exact ⟨m₁ * m₂ * m₃, by + rw [h₁, h₂, h₃, Nat.cast_mul, Nat.cast_mul]⟩ + have hμterm := eq_zero_of_sum_nat_eq_zero hinner + (by exact hterm) μ (Finset.mem_univ μ) + have hνnat : ∀ ν' ∈ (Finset.univ : Finset (Shape b)), + ∃ m : ℕ, + indMult ⟨lam.val, lam.prop⟩ μ ν' * + diagramSchur μ.val (superPS p q) * + diagramSchur ν'.val (superPS r s) = m := by + intro ν' _ + obtain ⟨m₁, h₁⟩ := indMult_exists_nat + (⟨lam.val, lam.prop⟩ : Shape (a + b)) μ ν' + obtain ⟨m₂, h₂⟩ := diagramSchur_superPS_exists_nat p q μ.val + obtain ⟨m₃, h₃⟩ := diagramSchur_superPS_exists_nat r s ν'.val + exact ⟨m₁ * m₂ * m₃, by + rw [h₁, h₂, h₃, Nat.cast_mul, Nat.cast_mul]⟩ + have hfinal := eq_zero_of_sum_nat_eq_zero hνnat hμterm ν + (Finset.mem_univ ν) + -- Both specialisation factors are nonzero; the multiplicity dies. + obtain ⟨m₂, hm₂, h₂⟩ := diagramSchur_superPS_pos μ.val hμ + obtain ⟨m₃, hm₃, h₃⟩ := diagramSchur_superPS_pos ν.val hν + have h₂' : diagramSchur μ.val (superPS p q) ≠ 0 := by + rw [h₂] + exact_mod_cast hm₂.ne' + have h₃' : diagramSchur ν.val (superPS r s) ≠ 0 := by + rw [h₃] + exact_mod_cast hm₃.ne' + have := mul_eq_zero.mp hfinal + rcases this with h | h + · rcases mul_eq_zero.mp h with h' | h' + · rwa [show (⟨lam.val, lam.prop⟩ : Shape (a + b)) = lam from + Subtype.ext rfl] at h' + · exact absurd h' h₂' + · exact absurd h h₃' + +/-- Deligne 1.10 in its positive form: a nonzero induction +multiplicity pushes a fat-hook cell of `λ` into `μ` or `ν`. -/ +theorem cell_of_indMult_ne_zero {a b : ℕ} (lam : Shape (a + b)) + (μ : Shape a) (ν : Shape b) {p q r s : ℕ} + (h : indMult lam μ ν ≠ 0) + (hlam : (p + r, q + s) ∈ lam.val) : + (p, q) ∈ μ.val ∨ (r, s) ∈ ν.val := by + by_contra hcon + push Not at hcon + exact h (indMult_eq_zero_of_cells lam μ ν hcon.1 hcon.2 hlam) + +/-- **Deligne 1.12, character side**: a Kronecker multiplicity +dies against the product hook. -/ +theorem kronMult_eq_zero_of_cells {n : ℕ} (lam μ ν : Shape n) + {p q r s : ℕ} (hμ : (p, q) ∉ μ.val) (hν : (r, s) ∉ ν.val) + (hlam : (p * r + q * s, p * s + q * r) ∈ lam.val) : + kronMult lam μ ν = 0 := by + classical + obtain ⟨L, hL⟩ := lam + obtain ⟨M, hM⟩ := μ + obtain ⟨N, hN⟩ := ν + subst hL + simp only at hμ hν hlam ⊢ + have hzero : diagramSchur L + (fun c => superPS p q c * superPS r s c) = 0 := by + rw [show (fun c => superPS p q c * superPS r s c) = + superPS (p * r + q * s) (p * s + q * r) from + superPS_mul p q r s] + exact diagramSchur_superPS_eq_zero L hlam + rw [diagramSchur_pointwise_mul] at hzero + have houter : ∀ μ' ∈ (Finset.univ : Finset (Shape L.card)), + ∃ m : ℕ, + (∑ ν' : Shape L.card, + kronMult ⟨L, rfl⟩ μ' ν' * + diagramSchur μ'.val (superPS p q) * + diagramSchur ν'.val (superPS r s)) = m := by + intro μ' _ + refine exists_nat_sum _ _ fun ν' _ => ?_ + obtain ⟨m₁, h₁⟩ := kronMult_exists_nat + (⟨L, rfl⟩ : Shape L.card) μ' ν' + obtain ⟨m₂, h₂⟩ := diagramSchur_superPS_exists_nat p q μ'.val + obtain ⟨m₃, h₃⟩ := diagramSchur_superPS_exists_nat r s ν'.val + exact ⟨m₁ * m₂ * m₃, by + rw [h₁, h₂, h₃, Nat.cast_mul, Nat.cast_mul]⟩ + have hμterm := eq_zero_of_sum_nat_eq_zero houter hzero + ⟨M, hM⟩ (Finset.mem_univ _) + have hνnat : ∀ ν' ∈ (Finset.univ : Finset (Shape L.card)), + ∃ m : ℕ, + kronMult ⟨L, rfl⟩ ⟨M, hM⟩ ν' * + diagramSchur M (superPS p q) * + diagramSchur ν'.val (superPS r s) = m := by + intro ν' _ + obtain ⟨m₁, h₁⟩ := kronMult_exists_nat + (⟨L, rfl⟩ : Shape L.card) ⟨M, hM⟩ ν' + obtain ⟨m₂, h₂⟩ := diagramSchur_superPS_exists_nat p q M + obtain ⟨m₃, h₃⟩ := diagramSchur_superPS_exists_nat r s ν'.val + exact ⟨m₁ * m₂ * m₃, by + rw [h₁, h₂, h₃, Nat.cast_mul, Nat.cast_mul]⟩ + have hfinal := eq_zero_of_sum_nat_eq_zero hνnat hμterm + ⟨N, hN⟩ (Finset.mem_univ _) + obtain ⟨m₂, hm₂, h₂⟩ := diagramSchur_superPS_pos M hμ + obtain ⟨m₃, hm₃, h₃⟩ := diagramSchur_superPS_pos N hν + have h₂' : diagramSchur M (superPS p q) ≠ 0 := by + rw [h₂] + exact_mod_cast hm₂.ne' + have h₃' : diagramSchur N (superPS r s) ≠ 0 := by + rw [h₃] + exact_mod_cast hm₃.ne' + rcases mul_eq_zero.mp hfinal with h | h + · rcases mul_eq_zero.mp h with h' | h' + · exact h' + · exact absurd h' h₂' + · exact absurd h h₃' + +/-- Deligne 1.12 in its positive form. -/ +theorem cell_of_kronMult_ne_zero {n : ℕ} (lam μ ν : Shape n) + {p q r s : ℕ} (h : kronMult lam μ ν ≠ 0) + (hlam : (p * r + q * s, p * s + q * r) ∈ lam.val) : + (p, q) ∈ μ.val ∨ (r, s) ∈ ν.val := by + by_contra hcon + push Not at hcon + exact h (kronMult_eq_zero_of_cells lam μ ν hcon.1 hcon.2 hlam) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookZero.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookZero.lean new file mode 100644 index 0000000000..388787ac5b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookZero.lean @@ -0,0 +1,411 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSeries + +/-! +# Hook vanishing for Jacobi–Trudi determinants + +If the complete homogeneous sequence attached to a scalar sequence +`t` satisfies the alternating binomial recurrence of order `p` +beyond degree `q` — the coefficient statement of +`(1 − X)^p · Σ h_n Xⁿ = polynomial of degree ≤ q` — then the Schur +specialisation `diagramSchur λ t` vanishes for every diagram `λ` +containing the cell `(p, q)`. + +Route: a unipotent column operation turns each column `≥ p` of the +Jacobi–Trudi matrix into the recurrence sums; in the first `p + 1` +rows the recurrence applies and the transformed entries vanish, so +those rows live in a `p`-dimensional coordinate subspace, are +linearly dependent, and the determinant is zero. +-/ + +@[expose] public section + +namespace RS + +open Matrix Finset + +/-- The unipotent column-operation matrix: columns `< p` are left +alone, and column `j ≥ p` becomes the alternating binomial +combination of columns `j, j − 1, …, j − p`. -/ +noncomputable def hookColOp (p ℓ : ℕ) : Matrix (Fin ℓ) (Fin ℓ) ℂ := + Matrix.of fun k j => + if (j : ℕ) < p then (if k = j then 1 else 0) + else if (k : ℕ) ≤ (j : ℕ) then + (-1 : ℂ) ^ ((j : ℕ) - (k : ℕ)) * + ((p.choose ((j : ℕ) - (k : ℕ))) : ℂ) + else 0 + +/-- The column operation is upper triangular. -/ +theorem hookColOp_blockTriangular (p ℓ : ℕ) : + (hookColOp p ℓ).BlockTriangular id := by + intro k j hjk + have h : (j : ℕ) < (k : ℕ) := hjk + simp only [hookColOp, Matrix.of_apply] + split_ifs with h1 h2 h3 + · exact absurd (congrArg Fin.val h2) (by omega) + · rfl + · omega + · rfl + +/-- The column operation has determinant one. -/ +theorem det_hookColOp (p ℓ : ℕ) : (hookColOp p ℓ).det = 1 := by + rw [Matrix.det_of_isUpperTriangular (hookColOp_blockTriangular p ℓ)] + apply Finset.prod_eq_one + intro j _ + simp only [hookColOp, Matrix.of_apply] + split_ifs with h1 h2 + · rfl + · simp + · omega + +/-- The Jacobi–Trudi matrix of a row-length list. -/ +noncomputable def jtMatrix (t : ℕ → ℂ) (rows : List ℕ) : + Matrix (Fin rows.length) (Fin rows.length) ℂ := + Matrix.of fun i j : Fin rows.length => + newtonHZ t ((rows.get i : ℤ) + (j : ℤ) - (i : ℤ)) + +/-- `schurDet` is the determinant of the Jacobi–Trudi matrix. -/ +theorem schurDet_eq_det_jtMatrix (t : ℕ → ℂ) (rows : List ℕ) : + schurDet t rows = (jtMatrix t rows).det := + rfl + +/-- Columns `≥ p` of the transformed Jacobi–Trudi matrix carry the +alternating binomial recurrence sums. -/ +theorem jtMatrix_mul_hookColOp (t : ℕ → ℂ) (rows : List ℕ) (p : ℕ) + (i j : Fin rows.length) (hj : p ≤ (j : ℕ)) : + (jtMatrix t rows * hookColOp p rows.length) i j = + ∑ d ∈ Finset.range (p + 1), (-1 : ℂ) ^ d * (p.choose d : ℂ) * + newtonHZ t ((rows.get i : ℤ) + (j : ℤ) - (i : ℤ) - (d : ℤ)) := by + rw [Matrix.mul_apply] + have hnotlt : ¬ (j : ℕ) < p := not_lt.mpr hj + -- Extend the recurrence sum to `range (j + 1)`: the extra terms + -- carry a vanishing binomial coefficient. + have hext : + (∑ d ∈ Finset.range (p + 1), (-1 : ℂ) ^ d * (p.choose d : ℂ) * + newtonHZ t ((rows.get i : ℤ) + (j : ℤ) - (i : ℤ) - (d : ℤ))) = + ∑ d ∈ Finset.range ((j : ℕ) + 1), + (-1 : ℂ) ^ d * (p.choose d : ℂ) * + newtonHZ t ((rows.get i : ℤ) + (j : ℤ) - (i : ℤ) - (d : ℤ)) := by + refine Finset.sum_subset (fun x hx => ?_) ?_ + · rw [Finset.mem_range] at hx ⊢ + omega + intro d hd hnd + rw [Finset.mem_range] at hd + rw [Finset.mem_range, not_lt] at hnd + rw [Nat.choose_eq_zero_of_lt (by omega)] + ring + rw [hext] + -- Indices `k > j` do not contribute on the left. + rw [show (∑ k, jtMatrix t rows i k * hookColOp p rows.length k j) = + ∑ k ∈ Finset.univ.filter + (fun k : Fin rows.length => (k : ℕ) ≤ (j : ℕ)), + jtMatrix t rows i k * hookColOp p rows.length k j from + (Finset.sum_subset (Finset.filter_subset _ _) (by + intro k _ hk + rw [Finset.mem_filter, not_and] at hk + have hkj : ¬ (k : ℕ) ≤ (j : ℕ) := hk (Finset.mem_univ k) + simp only [hookColOp, Matrix.of_apply, ite_eq_right hnotlt, + ite_eq_right hkj, mul_zero])).symm] + -- Reindex by `d = j − k`. + refine Finset.sum_bij' + (i := fun k _ => (j : ℕ) - (k : ℕ)) + (j := fun d hd => (⟨(j : ℕ) - d, + lt_of_le_of_lt (Nat.sub_le _ _) j.isLt⟩ : Fin rows.length)) + ?_ ?_ ?_ ?_ ?_ + · intro k hk + rw [Finset.mem_range] + omega + · intro d _ + rw [Finset.mem_filter] + exact ⟨Finset.mem_univ _, Nat.sub_le _ _⟩ + · intro k hk + rw [Finset.mem_filter] at hk + refine Fin.ext ?_ + change (j : ℕ) - ((j : ℕ) - (k : ℕ)) = (k : ℕ) + omega + · intro d hd + rw [Finset.mem_range] at hd + change (j : ℕ) - ((j : ℕ) - d) = d + omega + · intro k hk + rw [Finset.mem_filter] at hk + have hkj : (k : ℕ) ≤ (j : ℕ) := hk.2 + simp only [jtMatrix, hookColOp, Matrix.of_apply, ite_eq_right hnotlt, + ite_eq_left hkj] + have hcast : (((j : ℕ) - (k : ℕ) : ℕ) : ℤ) = + (j : ℤ) - (k : ℤ) := by omega + rw [hcast] + have harg : (rows.get i : ℤ) + (k : ℤ) - (i : ℤ) = + (rows.get i : ℤ) + (j : ℤ) - (i : ℤ) - + ((j : ℤ) - (k : ℤ)) := by ring + rw [harg] + ring + +/-- In the first `p + 1` rows, the transformed entries in columns +`≥ p` vanish by the recurrence: the diagram contains the cell +`(p, q)`, so those rows are long enough to push the argument past +degree `q`. -/ +theorem jtMatrix_mul_hookColOp_eq_zero (t : ℕ → ℂ) {p q : ℕ} + (hrec : ∀ m : ℤ, (q : ℤ) < m → + ∑ d ∈ Finset.range (p + 1), (-1 : ℂ) ^ d * (p.choose d : ℂ) * + newtonHZ t (m - (d : ℤ)) = 0) + (lam : YoungDiagram) (hcell : (p, q) ∈ lam) + (i j : Fin lam.rowLens.length) + (hi : (i : ℕ) ≤ p) (hj : p ≤ (j : ℕ)) : + (jtMatrix t lam.rowLens * hookColOp p lam.rowLens.length) i j + = 0 := by + rw [jtMatrix_mul_hookColOp t lam.rowLens p i j hj] + have hget : lam.rowLens.get i = lam.rowLen (i : ℕ) := by + rw [List.get_eq_getElem, YoungDiagram.get_rowLens] + have hq : q < lam.rowLen (i : ℕ) := + lt_of_lt_of_le (YoungDiagram.mem_iff_lt_rowLen.mp hcell) + (lam.rowLen_anti _ _ hi) + have hij : (i : ℕ) ≤ (j : ℕ) := le_trans hi hj + have hm : (q : ℤ) < + (lam.rowLens.get i : ℤ) + (j : ℤ) - (i : ℤ) := by + rw [hget] + omega + exact hrec _ hm + +/-- **Hook vanishing** (the combinatorial engine behind Deligne +1.9): if the complete homogeneous sequence of `t` satisfies the +alternating binomial recurrence of order `p` beyond degree `q`, +the Schur specialisation vanishes on every diagram containing the +cell `(p, q)`. -/ +theorem diagramSchur_eq_zero_of_hook (t : ℕ → ℂ) {p q : ℕ} + (hrec : ∀ m : ℤ, (q : ℤ) < m → + ∑ d ∈ Finset.range (p + 1), (-1 : ℂ) ^ d * (p.choose d : ℂ) * + newtonHZ t (m - (d : ℤ)) = 0) + (lam : YoungDiagram) (hcell : (p, q) ∈ lam) : + diagramSchur lam t = 0 := by + -- Notation and the size bound `p < ℓ`. + set ℓ := lam.rowLens.length with hℓ + have hpl : p < ℓ := by + rw [hℓ, YoungDiagram.length_rowLens] + rw [← YoungDiagram.mem_iff_lt_colLen] + exact lam.up_left_mem le_rfl (Nat.zero_le q) hcell + set M := jtMatrix t lam.rowLens * hookColOp p ℓ with hM + -- The first `p + 1` rows, restricted to the first `p` columns. + set v : Fin (p + 1) → (Fin p → ℂ) := fun a b => + M ⟨(a : ℕ), lt_of_lt_of_le a.isLt hpl⟩ + ⟨(b : ℕ), lt_of_le_of_lt (Nat.le_of_lt b.isLt) hpl⟩ with hv + -- Too many vectors for the ambient dimension: dependence. + have hdep : ¬ LinearIndependent ℂ v := by + intro hLI + have hcard := hLI.fintype_card_le_finrank + rw [Module.finrank_pi] at hcard + simp only [Fintype.card_fin] at hcard + omega + obtain ⟨f, g, hfg, i₀, hne⟩ := + Fintype.not_linearIndependent_iffₛ.mp hdep + set c : Fin (p + 1) → ℂ := fun a => f a - g a with hc + have hcsum : ∑ a, c a • v a = 0 := by + simp only [hc, sub_smul] + rw [Finset.sum_sub_distrib, hfg, sub_self] + have hc₀ : c i₀ ≠ 0 := sub_ne_zero.mpr hne + -- The dependence vector, extended by zero. + set w : Fin ℓ → ℂ := fun k => + if h : (k : ℕ) < p + 1 then c ⟨(k : ℕ), h⟩ else 0 with hw + have hwne : w ≠ 0 := by + intro h0 + apply hc₀ + calc c i₀ = w ⟨(i₀ : ℕ), lt_of_lt_of_le i₀.isLt hpl⟩ := by + rw [hw] + change c i₀ = + if h : (i₀ : ℕ) < p + 1 then c ⟨(i₀ : ℕ), h⟩ else 0 + rw [dite_eq_left i₀.isLt] + _ = 0 := by rw [h0]; rfl + -- The extended vector annihilates the transformed matrix. + have hvm : Matrix.vecMul w M = 0 := by + funext j + change ∑ k, w k * M k j = 0 + -- Only the first `p + 1` rows contribute. + rw [show (∑ k, w k * M k j) = + ∑ a : Fin (p + 1), c a * + M ⟨(a : ℕ), lt_of_lt_of_le a.isLt hpl⟩ j from ?_] + · rcases lt_or_ge (j : ℕ) p with hjp | hjp + · -- Columns `< p`: the chosen dependence relation. + have := congrFun hcsum ⟨(j : ℕ), hjp⟩ + rw [Finset.sum_apply] at this + simp only [Pi.smul_apply, smul_eq_mul, Pi.zero_apply] at this + rw [← this] + · -- Columns `≥ p`: the recurrence zeroes. + refine Finset.sum_eq_zero fun a _ => ?_ + have hz := jtMatrix_mul_hookColOp_eq_zero t hrec lam hcell + ⟨(a : ℕ), lt_of_lt_of_le a.isLt hpl⟩ j + (Nat.lt_succ_iff.mp a.isLt) hjp + change c a * (jtMatrix t lam.rowLens * + hookColOp p lam.rowLens.length) + ⟨(a : ℕ), lt_of_lt_of_le a.isLt hpl⟩ j = 0 + rw [hz, mul_zero] + · -- Collapse the zero-extended sum onto `Fin (p + 1)`. + rw [show (∑ k, w k * M k j) = + ∑ k ∈ Finset.univ.filter + (fun k : Fin ℓ => (k : ℕ) < p + 1), w k * M k j from + (Finset.sum_subset (Finset.filter_subset _ _) (by + intro k _ hk + rw [Finset.mem_filter, not_and] at hk + have : ¬ (k : ℕ) < p + 1 := hk (Finset.mem_univ k) + rw [hw] + simp only [dite_eq_right this, zero_mul])).symm] + refine Finset.sum_bij' + (i := fun k hk => (⟨(k : ℕ), + (Finset.mem_filter.mp hk).2⟩ : Fin (p + 1))) + (j := fun a _ => (⟨(a : ℕ), + lt_of_lt_of_le a.isLt hpl⟩ : Fin ℓ)) + ?_ ?_ ?_ ?_ ?_ + · intro k _ + exact Finset.mem_univ _ + · intro a _ + rw [Finset.mem_filter] + exact ⟨Finset.mem_univ _, a.isLt⟩ + · intro k _ + exact Fin.ext rfl + · intro a _ + exact Fin.ext rfl + · intro k hk + have hklt : (k : ℕ) < p + 1 := (Finset.mem_filter.mp hk).2 + rw [hw] + simp only [dite_eq_left hklt] + rfl + -- Conclude through the determinant. + have hdet0 : M.det = 0 := + Matrix.exists_vecMul_eq_zero_iff.mp ⟨w, hwne, hvm⟩ + have hdetM : (jtMatrix t lam.rowLens).det = 0 := by + have := Matrix.det_mul (jtMatrix t lam.rowLens) (hookColOp p ℓ) + rw [← hM, hdet0, det_hookColOp, mul_one] at this + exact this.symm + rw [diagramSchur, schurDet_eq_det_jtMatrix, hdetM] + +/-- The super-power-sum sequences satisfy the recurrence slot of +`diagramSchur_eq_zero_of_hook`, in its integer-indexed form. -/ +theorem superPS_rec_int (p q : ℕ) {m : ℤ} (hm : (q : ℤ) < m) : + ∑ d ∈ Finset.range (p + 1), (-1 : ℂ) ^ d * (p.choose d : ℂ) * + newtonHZ (superPS p q) (m - (d : ℤ)) = 0 := by + have hm0 : 0 ≤ m := le_trans (Int.natCast_nonneg q) (le_of_lt hm) + set n := m.toNat with hn + have hmn : m = (n : ℤ) := (Int.toNat_of_nonneg hm0).symm + have hqn : q < n := by omega + have hanti := newtonH_superPS_rec_antidiagonal p q hqn + rw [Finset.Nat.sum_antidiagonal_eq_sum_range_succ_mk] at hanti + -- Both sums agree with the common extension to `range (M + 1)`. + set M := max p n with hM + have hleft : + (∑ d ∈ Finset.range (p + 1), (-1 : ℂ) ^ d * (p.choose d : ℂ) * + newtonHZ (superPS p q) (m - (d : ℤ))) = + ∑ d ∈ Finset.range (M + 1), (-1 : ℂ) ^ d * (p.choose d : ℂ) * + newtonHZ (superPS p q) (m - (d : ℤ)) := by + refine Finset.sum_subset (fun x hx => ?_) (fun d _ hd => ?_) + · rw [Finset.mem_range] at hx ⊢ + omega + · rw [Finset.mem_range, not_lt] at hd + rw [Nat.choose_eq_zero_of_lt (by omega)] + ring + have hswap : + (∑ d ∈ Finset.range (M + 1), (-1 : ℂ) ^ d * (p.choose d : ℂ) * + newtonHZ (superPS p q) (m - (d : ℤ))) = + ∑ d ∈ Finset.range (n + 1), (-1 : ℂ) ^ d * (p.choose d : ℂ) * + newtonHZ (superPS p q) (m - (d : ℤ)) := by + refine (Finset.sum_subset (fun x hx => ?_) (fun d _ hd => ?_)).symm + · rw [Finset.mem_range] at hx ⊢ + omega + · rw [Finset.mem_range, not_lt] at hd + have hneg : m - (d : ℤ) < 0 := by omega + rw [newtonHZ, ite_eq_right (not_le.mpr hneg), mul_zero] + have hconv : + (∑ d ∈ Finset.range (n + 1), (-1 : ℂ) ^ d * (p.choose d : ℂ) * + newtonHZ (superPS p q) (m - (d : ℤ))) = + ∑ d ∈ Finset.range (n + 1), (-1 : ℂ) ^ d * (p.choose d : ℂ) * + newtonH (superPS p q) (n - d) := by + refine Finset.sum_congr rfl fun d hd => ?_ + rw [Finset.mem_range] at hd + congr 1 + rw [show m - (d : ℤ) = ((n - d : ℕ) : ℤ) by omega, + newtonHZ_natCast] + rw [hleft, hswap, hconv] + exact hanti + +/-- **Deligne 1.9, vanishing direction, character side**: the Schur +specialisation at the super power sums of dimension `(p, q)` +vanishes on every diagram containing the cell `(p, q)`. -/ +theorem diagramSchur_superPS_eq_zero {p q : ℕ} (lam : YoungDiagram) + (hcell : (p, q) ∈ lam) : + diagramSchur lam (superPS p q) = 0 := + diagramSchur_eq_zero_of_hook (superPS p q) + (fun _ hm => superPS_rec_int p q hm) lam hcell + +/-- One `h`-variable: the Schur specialisation at `superPS 1 0` is +the indicator of single-row diagrams. -/ +theorem diagramSchur_superPS_row (ν : YoungDiagram) : + diagramSchur ν (superPS 1 0) = + if ν.colLen 0 ≤ 1 then 1 else 0 := by + by_cases h : ν.colLen 0 ≤ 1 + · rw [ite_eq_left h] + have hlen : ν.rowLens.length ≤ 1 := by + rw [YoungDiagram.length_rowLens]; exact h + rw [diagramSchur, schurDet_eq_det_jtMatrix, + Matrix.det_of_isUpperTriangular + (by + intro i j hji + have hji' : (j : ℕ) < (i : ℕ) := hji + have hi := i.isLt + omega)] + refine Finset.prod_eq_one fun i _ => ?_ + change newtonHZ (superPS 1 0) + ((ν.rowLens.get i : ℤ) + (i : ℤ) - (i : ℤ)) = 1 + rw [show ((ν.rowLens.get i : ℤ) + (i : ℤ) - (i : ℤ)) = + ((ν.rowLens.get i : ℕ) : ℤ) by ring, newtonHZ_natCast, + newtonH_superPS_zero_q 1 _ Nat.one_pos] + simp + · rw [ite_eq_right h] + exact diagramSchur_superPS_eq_zero ν + (YoungDiagram.mem_iff_lt_colLen.mpr (by omega)) + +/-- One `e`-variable: the Schur specialisation at `superPS 0 1` is +the indicator of single-column diagrams. -/ +theorem diagramSchur_superPS_col (ν : YoungDiagram) : + diagramSchur ν (superPS 0 1) = + if ν.rowLen 0 ≤ 1 then 1 else 0 := by + by_cases h : ν.rowLen 0 ≤ 1 + · rw [ite_eq_left h] + have hone : ∀ i : Fin ν.rowLens.length, + ν.rowLens.get i = 1 := by + intro i + have hpos : 0 < ν.rowLens.get i := + ν.pos_of_mem_rowLens _ (ν.rowLens.get_mem i) + have hle : ν.rowLens.get i ≤ ν.rowLen 0 := by + rw [List.get_eq_getElem, YoungDiagram.get_rowLens] + exact ν.rowLen_anti 0 (i : ℕ) (Nat.zero_le _) + omega + have hval : ∀ n : ℕ, + newtonH (superPS 0 1) n = ((1 : ℕ).choose n : ℂ) := + newtonH_superPS_zero_p 1 + rw [diagramSchur, schurDet_eq_det_jtMatrix, + Matrix.det_of_isLowerTriangular _ (by + intro i j hij + have hij' : (i : ℕ) < (j : ℕ) := hij + change newtonHZ (superPS 0 1) + ((ν.rowLens.get i : ℤ) + (j : ℤ) - (i : ℤ)) = 0 + rw [hone i, show ((1 : ℕ) : ℤ) + (j : ℤ) - (i : ℤ) = + ((1 + (j : ℕ) - (i : ℕ) : ℕ) : ℤ) by omega, + newtonHZ_natCast, hval] + rw [Nat.choose_eq_zero_of_lt (by omega)] + simp)] + refine Finset.prod_eq_one fun i _ => ?_ + change newtonHZ (superPS 0 1) + ((ν.rowLens.get i : ℤ) + (i : ℤ) - (i : ℤ)) = 1 + rw [hone i, show ((1 : ℕ) : ℤ) + (i : ℤ) - (i : ℤ) = + ((1 : ℕ) : ℤ) by ring, newtonHZ_natCast, hval] + simp + · rw [ite_eq_right h] + exact diagramSchur_superPS_eq_zero ν + (YoungDiagram.mem_iff_lt_rowLen.mpr (by omega)) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdemCut.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdemCut.lean new file mode 100644 index 0000000000..a9cec51a0f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdemCut.lean @@ -0,0 +1,715 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermNat +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowAct + +/-! +# The idempotent cut of module powers + +The generic splitting that `SymAlg.lean` performs for the +symmetriser and `AltPow.lean` for the antisymmetriser, done once +for an arbitrary idempotent `e` of the symmetric-group algebra: +the cut of the module power by `e`, presented as the coequalizer +of the action `modPowAlg e` against the identity, which the +idempotency splits off as a direct summand of the module power — +together with the `A`-module structure descended through the +splitting. This is the substrate for Schur functors of modules +over an internal monoid; the Young idempotents of the Schur +interface are plugged in elsewhere. + +* `modPowCut A X n e`: the cut, with projection `modPowCutπ`, + section `modPowCutσ`, the splitting identities, extensionality + and descent. Idempotency `e * e = e` enters as an explicit + hypothesis on exactly the declarations that need it. +* `modPowAct_modPowCutIdem`: the descended action commutes with + the group-algebra action, by the linear extension of the + permutation case. +* `modPowCutAct`/`modPowCutModObj`/`modPowCutMod`: the action on + the cut, with `modPowCutσ` a module map. +* `modPowCut_symmetriser`/`modPowCut_antisymmetriser`: at the + symmetriser and the antisymmetriser the cut is the symmetric and + the alternating power, definitionally. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## The cut of the module power by an idempotent -/ + +section IdemCut + +/-- A group-algebra element acting on the module power. -/ +noncomputable def modPowCutIdem + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) (e : SymGroupAlgebra n) : + modPow A X n ⟶ modPow A X n := + modPowAlg A X n e + +/-- An idempotent's action is idempotent. -/ +theorem modPowCutIdem_idem + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) (e : SymGroupAlgebra n) + (he : e * e = e) : + modPowCutIdem A X n e ≫ modPowCutIdem A X n e = + modPowCutIdem A X n e := by + have h := congrArg (modPowAlg A X n) he + rw [map_mul] at h + exact h + +/-- **The cut of the module power by an idempotent**: the +coequalizer of the idempotent's action against the identity. The +idempotency splits it off as a direct summand of the module power, +with section `modPowCutσ`; this presentation is chosen because +consumers build morphisms out of the cut by descent along +`modPowCutπ` and morphisms into it through the section. -/ +noncomputable def modPowCut + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) (e : SymGroupAlgebra n) : D := + coequalizer (modPowCutIdem A X n e) (𝟙 (modPow A X n)) + +/-- The projection onto the cut. -/ +noncomputable def modPowCutπ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) (e : SymGroupAlgebra n) : + modPow A X n ⟶ modPowCut A X n e := + coequalizer.π _ _ + +instance [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) (e : SymGroupAlgebra n) : + Epi (modPowCutπ A X n e) := + inferInstanceAs (Epi (coequalizer.π _ _)) + +/-- The idempotent is absorbed by the projection. -/ +@[reassoc (attr := simp)] +theorem modPowCutIdem_π + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) (e : SymGroupAlgebra n) : + modPowCutIdem A X n e ≫ modPowCutπ A X n e = + modPowCutπ A X n e := by + have h := coequalizer.condition (modPowCutIdem A X n e) + (𝟙 (modPow A X n)) + rwa [Category.id_comp] at h + +/-- The section of the cut, from idempotency. -/ +noncomputable def modPowCutσ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) (e : SymGroupAlgebra n) + (he : e * e = e) : modPowCut A X n e ⟶ modPow A X n := + coequalizer.desc (modPowCutIdem A X n e) + (by rw [Category.id_comp, modPowCutIdem_idem A X n e he]) + +/-- The section realises the idempotent as projection followed by +inclusion. -/ +@[reassoc (attr := simp)] +theorem modPowCutπ_σ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) (e : SymGroupAlgebra n) + (he : e * e = e) : + modPowCutπ A X n e ≫ modPowCutσ A X n e he = + modPowCutIdem A X n e := + coequalizer.π_desc _ _ + +/-- Morphisms out of the cut are determined by their composite with +the projection. -/ +theorem modPowCut_hom_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + {n : ℕ} {e : SymGroupAlgebra n} {W : D} + {k l : modPowCut A X n e ⟶ W} + (h : modPowCutπ A X n e ≫ k = modPowCutπ A X n e ≫ l) : + k = l := + coequalizer.hom_ext h + +/-- **The cut is a direct summand**: the section followed by the +projection is the identity. -/ +@[reassoc (attr := simp)] +theorem modPowCutσ_π + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) (e : SymGroupAlgebra n) + (he : e * e = e) : + modPowCutσ A X n e he ≫ modPowCutπ A X n e = + 𝟙 (modPowCut A X n e) := by + apply modPowCut_hom_ext A X + rw [← Category.assoc, modPowCutπ_σ, modPowCutIdem_π, + Category.comp_id] + +/-- Descend a morphism absorbed by the idempotent to the cut. -/ +noncomputable def modPowCutDesc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + {n : ℕ} {e : SymGroupAlgebra n} + {W : D} (k : modPow A X n ⟶ W) + (h : modPowCutIdem A X n e ≫ k = k) : modPowCut A X n e ⟶ W := + coequalizer.desc k (by rw [Category.id_comp, h]) + +/-- The descent factors the given morphism through the +projection. -/ +@[reassoc (attr := simp)] +theorem modPowCutπ_desc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + {n : ℕ} {e : SymGroupAlgebra n} {W : D} + (k : modPow A X n ⟶ W) (h : modPowCutIdem A X n e ≫ k = k) : + modPowCutπ A X n e ≫ modPowCutDesc A X k h = k := + coequalizer.π_desc _ _ + +/-! ### Compatibility with the symmetric and alternating powers -/ + +/-- At the symmetriser the cut is the symmetric power, +definitionally. -/ +theorem modPowCut_symmetriser + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) : + modPowCut A X n (symmetriser n) = symPow A X n := rfl + +/-- At the antisymmetriser the cut is the alternating power, +definitionally. -/ +theorem modPowCut_antisymmetriser + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) : + modPowCut A X n (antisymmetriser n) = altPow A X n := rfl + +end IdemCut + +/-! ## Whiskered extensionality for the cut -/ + +section CutWhisker + +/-- Morphisms out of a left-whiskered cut are determined by the +whiskered projection, which is split epi. -/ +theorem modPowCut_whiskerLeft_hom_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (P : D) (n : ℕ) + (e : SymGroupAlgebra n) (he : e * e = e) {Z : D} + {k l : P ⊗ modPowCut A X n e ⟶ Z} + (h : (P ◁ modPowCutπ A X n e) ≫ k = + (P ◁ modPowCutπ A X n e) ≫ l) : + k = l := by + have hsec : (P ◁ modPowCutσ A X n e he) ≫ + (P ◁ modPowCutπ A X n e) = 𝟙 _ := by + rw [← MonoidalCategory.whiskerLeft_comp, modPowCutσ_π, + MonoidalCategory.whiskerLeft_id] + calc k = ((P ◁ modPowCutσ A X n e he) ≫ + (P ◁ modPowCutπ A X n e)) ≫ k := by + rw [hsec, Category.id_comp] + _ = ((P ◁ modPowCutσ A X n e he) ≫ + (P ◁ modPowCutπ A X n e)) ≫ l := by + rw [Category.assoc, Category.assoc, h] + _ = l := by rw [hsec, Category.id_comp] + +end CutWhisker + +/-! ## The cut as a module -/ + +section CutAct + +/-- **The descended action commutes with the idempotent's action**: +the idempotent is a `ℂ`-linear combination of permutations, each of +which the action passes. -/ +theorem modPowAct_modPowCutIdem + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) + (e : SymGroupAlgebra (n + 1)) : + modPowAct A X n ≫ modPowCutIdem A X (n + 1) e = + (A ◁ modPowCutIdem A X (n + 1) e) ≫ modPowAct A X n := + modPowAct_alg A X n e + +/-- **The monoid action on the cut**, through the section and the +descended action. -/ +noncomputable def modPowCutAct + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) (e : SymGroupAlgebra (n + 1)) + (he : e * e = e) : + A ⊗ modPowCut A X (n + 1) e ⟶ modPowCut A X (n + 1) e := + (A ◁ modPowCutσ A X (n + 1) e he) ≫ modPowAct A X n ≫ + modPowCutπ A X (n + 1) e + +/-- Defining equation of the cut action. -/ +@[reassoc (attr := simp)] +theorem whiskerLeft_modPowCutπ_modPowCutAct + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) + (e : SymGroupAlgebra (n + 1)) (he : e * e = e) : + (A ◁ modPowCutπ A X (n + 1) e) ≫ modPowCutAct A X n e he = + modPowAct A X n ≫ modPowCutπ A X (n + 1) e := by + rw [modPowCutAct, ← whiskerLeft_comp_assoc, modPowCutπ_σ, + reassoc_of% (modPowAct_modPowCutIdem A X n e).symm, + modPowCutIdem_π] + +/-- Unitality of the cut action. -/ +theorem modPowCutAct_one + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) (e : SymGroupAlgebra (n + 1)) + (he : e * e = e) : + η[A] ▷ modPowCut A X (n + 1) e ≫ modPowCutAct A X n e he = + (λ_ (modPowCut A X (n + 1) e)).hom := by + apply modPowCut_whiskerLeft_hom_ext A X (𝟙_ D) (n + 1) e he + rw [whisker_exchange_assoc, whiskerLeft_modPowCutπ_modPowCutAct, + reassoc_of% (modPowAct_one A X n), leftUnitor_naturality] + +/-- Associativity of the cut action. -/ +theorem modPowCutAct_mul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) (e : SymGroupAlgebra (n + 1)) + (he : e * e = e) : + μ[A] ▷ modPowCut A X (n + 1) e ≫ modPowCutAct A X n e he = + (α_ A A (modPowCut A X (n + 1) e)).hom ≫ + (A ◁ modPowCutAct A X n e he) ≫ + modPowCutAct A X n e he := by + apply modPowCut_whiskerLeft_hom_ext A X (A ⊗ A) (n + 1) e he + conv_lhs => rw [whisker_exchange_assoc, + whiskerLeft_modPowCutπ_modPowCutAct, + reassoc_of% (modPowAct_mul A X n)] + conv_rhs => rw [associator_naturality_right_assoc, + ← whiskerLeft_comp_assoc, whiskerLeft_modPowCutπ_modPowCutAct, + whiskerLeft_comp_assoc, whiskerLeft_modPowCutπ_modPowCutAct] + +/-- **The cut of a module is a module**, in every positive +arity. -/ +@[implicit_reducible] +noncomputable def modPowCutModObj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) + (e : SymGroupAlgebra (n + 1)) (he : e * e = e) : + ModObj A (modPowCut A X (n + 1) e) where + smul := modPowCutAct A X n e he + one_smul := modPowCutAct_one A X n e he + mul_smul := modPowCutAct_mul A X n e he + +/-- The cut of a module, bundled as a module. -/ +noncomputable def modPowCutMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) (e : SymGroupAlgebra (n + 1)) + (he : e * e = e) : Mod D A := + letI := modPowCutModObj A X n e he + ⟨modPowCut A X (n + 1) e⟩ + +@[simp] theorem modPowCutMod_X + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) (e : SymGroupAlgebra (n + 1)) + (he : e * e = e) : + (modPowCutMod A X n e he).X = modPowCut A X (n + 1) e := rfl + +end CutAct + +/-! ## Naturality substrate: module maps on powers + +The transport kit for the cut: a module map `f : X ⟶ Y` induces a +map of module powers and of their cuts, functorially, and killing +the cut transports along retracts and isomorphisms. +-/ + +section MapNat + +/-- Arity transports pass tensor powers of a morphism. -/ +theorem powCast_tensorPowMap + [Category.{v} D] [MonoidalCategory D] {X : D} {Y : D} + (f : X ⟶ Y) {m n : ℕ} (h : m = n) : + powCast X h ≫ tensorPowMap f n = + tensorPowMap f m ≫ powCast Y h := by + subst h + rw [powCast_rfl, powCast_rfl, Category.id_comp, Category.comp_id] + +/-- The concatenation isomorphism is natural in tensor powers of a +morphism. -/ +theorem tensorPowMap_concat + [Category.{v} D] [MonoidalCategory D] {X : D} {Y : D} + (f : X ⟶ Y) (a : ℕ) : ∀ b : ℕ, + (tensorPowMap f a ⊗ₘ tensorPowMap f b) ≫ + (tensorPowConcat Y a b).hom = + (tensorPowConcat X a b).hom ≫ tensorPowMap f (a + b) + | 0 => by + rw [tensorPowConcat_zero, tensorPowConcat_zero] + change (tensorPowMap f a ⊗ₘ 𝟙 (𝟙_ D)) ≫ + (ρ_ (tensorPow D Y a)).hom = + (ρ_ (tensorPow D X a)).hom ≫ tensorPowMap f a + rw [MonoidalCategory.tensorHom_id, + MonoidalCategory.rightUnitor_naturality] + | b + 1 => by + change (tensorPowMap f a ⊗ₘ (tensorPowMap f b ⊗ₘ f)) ≫ + ((α_ (tensorPow D Y a) (tensorPow D Y b) Y).inv ≫ + (tensorPowConcat Y a b).hom ▷ Y) = + ((α_ (tensorPow D X a) (tensorPow D X b) X).inv ≫ + (tensorPowConcat X a b).hom ▷ X) ≫ + (tensorPowMap f (a + b) ⊗ₘ f) + rw [MonoidalCategory.associator_inv_naturality_assoc, + ← MonoidalCategory.tensorHom_id (tensorPowConcat Y a b).hom Y, + MonoidalCategory.tensorHom_comp_tensorHom, + tensorPowMap_concat f a b, Category.comp_id, Category.assoc, + ← MonoidalCategory.tensorHom_id (tensorPowConcat X a b).hom X, + MonoidalCategory.tensorHom_comp_tensorHom, Category.id_comp] + +/-- The first window leg is natural in module maps. -/ +theorem winLegM_natural + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] {X : D} {Y : D} [ModObj A X] [ModObj A Y] + (f : X ⟶ Y) [IsModHom A f] : + ((f ⊗ₘ 𝟙 A) ⊗ₘ f) ≫ winLegM A Y = winLegM A X ≫ (f ⊗ₘ f) := by + rw [winLegM, winLegM, + ← MonoidalCategory.tensorHom_id (actRight A Y) Y, + MonoidalCategory.tensorHom_comp_tensorHom, Category.comp_id, + MonoidalCategory.tensorHom_id (f := f), + ← actRight_natural A X Y f, + ← MonoidalCategory.tensorHom_id (actRight A X) X, + MonoidalCategory.tensorHom_comp_tensorHom, Category.id_comp] + +/-- The second window leg is natural in module maps. -/ +theorem winLegN_natural + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] {X : D} {Y : D} + [ModObj A X] [ModObj A Y] + (f : X ⟶ Y) [IsModHom A f] : + ((f ⊗ₘ 𝟙 A) ⊗ₘ f) ≫ winLegN A Y = winLegN A X ≫ (f ⊗ₘ f) := by + rw [winLegN, winLegN, MonoidalCategory.associator_naturality_assoc, + ← MonoidalCategory.id_tensorHom Y (actLeft A Y), + MonoidalCategory.tensorHom_comp_tensorHom, Category.comp_id, + MonoidalCategory.id_tensorHom (f := f), + ← actLeft_natural A X Y f, Category.assoc, + ← MonoidalCategory.id_tensorHom X (actLeft A X), + MonoidalCategory.tensorHom_comp_tensorHom, Category.id_comp] + +/-- A tensor of maps followed by a right whiskering, as one +tensor. -/ +private theorem tensor_comp_whisker [Category.{v} D] [MonoidalCategory D] + {P P' P'' Q Q' : D} + (p : P ⟶ P') (r : P' ⟶ P'') (q : Q ⟶ Q') : + (p ⊗ₘ q) ≫ (r ▷ Q') = (p ≫ r) ⊗ₘ q := by + rw [← MonoidalCategory.tensorHom_id r Q', + MonoidalCategory.tensorHom_comp_tensorHom, Category.comp_id] + +/-- A right whiskering followed by a tensor of maps, as one +tensor. -/ +private theorem whisker_comp_tensor [Category.{v} D] [MonoidalCategory D] + {P P' P'' Q Q' : D} + (r : P ⟶ P') (p : P' ⟶ P'') (q : Q ⟶ Q') : + (r ▷ Q) ≫ (p ⊗ₘ q) = (r ≫ p) ⊗ₘ q := by + rw [← MonoidalCategory.tensorHom_id r Q, + MonoidalCategory.tensorHom_comp_tensorHom, Category.id_comp] + +/-- The slot gluing is natural in tensor powers of a morphism. -/ +theorem modPowGlue_natural [Category.{v} D] [MonoidalCategory D] {X : D} {Y : D} + (f : X ⟶ Y) (a b : ℕ) : + ((tensorPowMap f a ⊗ₘ (f ⊗ₘ f)) ⊗ₘ tensorPowMap f b) ≫ + modPowGlue Y a b = + modPowGlue X a b ≫ tensorPowMap f (a + 2 + b) := by + erw [modPowGlue, modPowGlue, ← Category.assoc, tensor_comp_whisker, + MonoidalCategory.associator_inv_naturality, + ← whisker_comp_tensor, Category.assoc, Category.assoc] + exact congrArg (CategoryStruct.comp _) + (tensorPowMap_concat f (a + 2) b) + +/-- A tensor of maps followed by a left whiskering, as one +tensor. -/ +private theorem tensor_comp_lwhisker [Category.{v} D] [MonoidalCategory D] + {P P' Q Q' Q'' : D} + (p : P ⟶ P') (q : Q ⟶ Q') (s : Q' ⟶ Q'') : + (p ⊗ₘ q) ≫ (P' ◁ s) = p ⊗ₘ (q ≫ s) := by + rw [← MonoidalCategory.id_tensorHom P' s, + MonoidalCategory.tensorHom_comp_tensorHom, Category.comp_id] + +/-- A left whiskering followed by a tensor of maps, as one +tensor. -/ +private theorem lwhisker_comp_tensor [Category.{v} D] [MonoidalCategory D] + {P P' Q Q' Q'' : D} + (s : Q ⟶ Q') (p : P ⟶ P') (q : Q' ⟶ Q'') : + (P ◁ s) ≫ (p ⊗ₘ q) = p ⊗ₘ (s ≫ q) := by + rw [← MonoidalCategory.id_tensorHom P s, + MonoidalCategory.tensorHom_comp_tensorHom, Category.id_comp] + +/-- Both slot legs are natural in module maps, generically over the +window leg. -/ +private theorem modPowLeg_natural_aux + [Category.{v} D] [MonoidalCategory D] (A : D) {X : D} {Y : D} + (f : X ⟶ Y) (a b : ℕ) + {wX : (X ⊗ A) ⊗ X ⟶ X ⊗ X} {wY : (Y ⊗ A) ⊗ Y ⟶ Y ⊗ Y} + (hw : ((f ⊗ₘ 𝟙 A) ⊗ₘ f) ≫ wY = wX ≫ (f ⊗ₘ f)) : + ((tensorPowMap f a ⊗ₘ ((f ⊗ₘ 𝟙 A) ⊗ₘ f)) ⊗ₘ tensorPowMap f b) ≫ + ((tensorPow D Y a ◁ wY) ▷ tensorPow D Y b) ≫ + modPowGlue Y a b = + (((tensorPow D X a ◁ wX) ▷ tensorPow D X b) ≫ + modPowGlue X a b) ≫ + tensorPowMap f (a + 2 + b) := by + rw [← Category.assoc, tensor_comp_whisker, tensor_comp_lwhisker, + hw, ← lwhisker_comp_tensor, ← whisker_comp_tensor, + Category.assoc, Category.assoc] + exact congrArg (CategoryStruct.comp _) (modPowGlue_natural f a b) + +/-- The first slot leg is natural in module maps. -/ +theorem modPowLegM_natural + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] {X : D} {Y : D} [ModObj A X] [ModObj A Y] + (f : X ⟶ Y) [IsModHom A f] (a b : ℕ) : + ((tensorPowMap f a ⊗ₘ ((f ⊗ₘ 𝟙 A) ⊗ₘ f)) ⊗ₘ tensorPowMap f b) ≫ + modPowLegM A Y a b = + modPowLegM A X a b ≫ tensorPowMap f (a + 2 + b) := + modPowLeg_natural_aux (A := A) f a b (winLegM_natural A f) + +/-- The second slot leg is natural in module maps. -/ +theorem modPowLegN_natural + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] {X : D} {Y : D} + [ModObj A X] [ModObj A Y] + (f : X ⟶ Y) [IsModHom A f] (a b : ℕ) : + ((tensorPowMap f a ⊗ₘ ((f ⊗ₘ 𝟙 A) ⊗ₘ f)) ⊗ₘ tensorPowMap f b) ≫ + modPowLegN A Y a b = + modPowLegN A X a b ≫ tensorPowMap f (a + 2 + b) := + modPowLeg_natural_aux (A := A) f a b (winLegN_natural A f) + +/-- **The module power of a module map**: the tensor power of the +map descends to the module powers, since it carries every slot +relation of the source into a slot relation of the target. -/ +noncomputable def modPowMap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + {X : D} {Y : D} [ModObj A X] [ModObj A Y] + (f : X ⟶ Y) [IsModHom A f] (n : ℕ) : + modPow A X n ⟶ modPow A Y n := + modPowDesc A X (tensorPowMap f n ≫ modPowπ A Y n) + (fun a b hab => by + rw [reassoc_of% (powCast_tensorPowMap f hab), + ← reassoc_of% (modPowLegM_natural A f a b), + ← reassoc_of% (modPowLegN_natural A f a b)] + exact congrArg (CategoryStruct.comp _) + (modPow_rel A Y a b hab)) + +/-- Defining square of the module-power map. -/ +@[reassoc (attr := simp)] +theorem modPowπ_map + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + {X : D} {Y : D} [ModObj A X] [ModObj A Y] + (f : X ⟶ Y) [IsModHom A f] (n : ℕ) : + modPowπ A X n ≫ modPowMap A f n = + tensorPowMap f n ≫ modPowπ A Y n := + modPowπ_desc A X _ _ + +/-- The module power of the identity is the identity. -/ +@[simp] +theorem modPowMap_id + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + {X : D} [ModObj A X] + (n : ℕ) : + modPowMap A (𝟙 X) n = 𝟙 (modPow A X n) := by + apply modPow_hom_ext A X + rw [modPowπ_map, tensorPowMap_id, Category.id_comp, + Category.comp_id] + +/-- The module power is functorial in module maps. -/ +theorem modPowMap_comp + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + {X : D} {Y : D} [ModObj A X] [ModObj A Y] + {Z : D} [ModObj A Z] (f : X ⟶ Y) (g : Y ⟶ Z) + [IsModHom A f] [IsModHom A g] (n : ℕ) : + modPowMap A (f ≫ g) n = modPowMap A f n ≫ modPowMap A g n := by + apply modPow_hom_ext A X + rw [modPowπ_map, modPowπ_map_assoc, modPowπ_map, + tensorPowMap_comp, Category.assoc] + +/-- The module-power map passes the descended permutation +action. -/ +theorem modPowMap_perm + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + {X : D} {Y : D} [ModObj A X] [ModObj A Y] + (f : X ⟶ Y) [IsModHom A f] (n : ℕ) + (σ : Equiv.Perm (Fin n)) : + modPowMap A f n ≫ modPowPerm (A := A) (X := Y) n σ = + modPowPerm (A := A) (X := X) n σ ≫ modPowMap A f n := by + apply modPow_hom_ext A X + rw [modPowπ_map_assoc, modPowπ_perm, modPowπ_perm_assoc, + modPowπ_map, reassoc_of% (permMor_natural f n σ)] + +/-- **The module-power map passes the group-algebra action**, by +linear extension of the permutation case. -/ +theorem modPowMap_alg + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [Linear ℂ D] {X : D} {Y : D} [ModObj A X] [ModObj A Y] + (f : X ⟶ Y) [IsModHom A f] (n : ℕ) + (z : SymGroupAlgebra n) : + modPowMap A f n ≫ (modPowAlg A Y n z : End (modPow A Y n)) = + (modPowAlg A X n z : End (modPow A X n)) ≫ + modPowMap A f n := by + induction z using MonoidAlgebra.induction_on with + | of σ => + rw [show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin n))) σ = + MonoidAlgebra.single σ (1 : ℂ) from rfl, modPowAlg_single, + modPowAlg_single] + exact modPowMap_perm A f n σ + | add z₁ z₂ h₁ h₂ => + rw [map_add, map_add] + exact (intertwine_add h₁.symm h₂.symm).symm + | smul r z h => + rw [map_smul, map_smul] + exact (intertwine_smul r h.symm).symm + +/-- The module-power map passes the idempotent's action. -/ +theorem modPowMap_cutIdem + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [Linear ℂ D] {X : D} {Y : D} [ModObj A X] [ModObj A Y] + (f : X ⟶ Y) [IsModHom A f] (n : ℕ) + (e : SymGroupAlgebra n) : + modPowCutIdem A X n e ≫ modPowMap A f n = + modPowMap A f n ≫ modPowCutIdem A Y n e := + (modPowMap_alg A f n e).symm + +/-- **The cut of a module map**: the module-power map descends to +the cuts by an idempotent. -/ +noncomputable def modPowCutMap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [Linear ℂ D] {X : D} {Y : D} [ModObj A X] [ModObj A Y] + (f : X ⟶ Y) [IsModHom A f] (n : ℕ) + (e : SymGroupAlgebra n) : + modPowCut A X n e ⟶ modPowCut A Y n e := + modPowCutDesc A X (modPowMap A f n ≫ modPowCutπ A Y n e) + (by rw [← Category.assoc, modPowMap_cutIdem A f n e, + Category.assoc, modPowCutIdem_π]) + +/-- Defining square of the cut map. -/ +@[reassoc (attr := simp)] +theorem modPowCutπ_map + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [Linear ℂ D] {X : D} {Y : D} [ModObj A X] [ModObj A Y] + (f : X ⟶ Y) [IsModHom A f] (n : ℕ) + (e : SymGroupAlgebra n) : + modPowCutπ A X n e ≫ modPowCutMap A f n e = + modPowMap A f n ≫ modPowCutπ A Y n e := + modPowCutπ_desc A X _ _ + +/-- The cut of the identity is the identity. -/ +@[simp] +theorem modPowCutMap_id + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [Linear ℂ D] {X : D} [ModObj A X] + (n : ℕ) (e : SymGroupAlgebra n) : + modPowCutMap A (𝟙 X) n e = 𝟙 (modPowCut A X n e) := by + apply modPowCut_hom_ext A X + rw [modPowCutπ_map, modPowMap_id, Category.id_comp, + Category.comp_id] + +/-- The cut map is functorial in module maps. -/ +theorem modPowCutMap_comp + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [Linear ℂ D] {X : D} {Y : D} [ModObj A X] [ModObj A Y] + {Z : D} [ModObj A Z] (f : X ⟶ Y) + (g : Y ⟶ Z) [IsModHom A f] [IsModHom A g] (n : ℕ) + (e : SymGroupAlgebra n) : + modPowCutMap A (f ≫ g) n e = + modPowCutMap A f n e ≫ modPowCutMap A g n e := by + apply modPowCut_hom_ext A X + rw [modPowCutπ_map, modPowCutπ_map_assoc, modPowCutπ_map, + modPowMap_comp, Category.assoc] + +/-! ### Killing the cut transports along retracts -/ + +/-- The cut map depends only on the underlying morphism, not on +the module-map witness. -/ +theorem modPowCutMap_congr + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [Linear ℂ D] {X : D} {Y : D} [ModObj A X] [ModObj A Y] + {f g : X ⟶ Y} [IsModHom A f] + [IsModHom A g] (h : f = g) (n : ℕ) (e : SymGroupAlgebra n) : + modPowCutMap A f n e = modPowCutMap A g n e := by + subst h + rfl + +/-- **The cut of a retract is a retract of the cut**: if the cut of +`X` vanishes, so does the cut of a module retract of `X`. -/ +theorem modPowCut_isZero_of_retract + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [Linear ℂ D] {X : D} {Y : D} [ModObj A X] [ModObj A Y] + (r : X ⟶ Y) (s : Y ⟶ X) + [IsModHom A r] [IsModHom A s] (hs : s ≫ r = 𝟙 Y) (n : ℕ) + (e : SymGroupAlgebra n) (hX : IsZero (modPowCut A X n e)) : + IsZero (modPowCut A Y n e) := by + rw [IsZero.iff_id_eq_zero] + have hsplit : modPowCutMap A s n e ≫ modPowCutMap A r n e = + 𝟙 (modPowCut A Y n e) := by + rw [← modPowCutMap_comp A s r n e, + modPowCutMap_congr A hs n e, modPowCutMap_id] + rw [← hsplit, hX.eq_of_tgt (modPowCutMap A s n e) 0, zero_comp] + +end MapNat + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdempotentLength.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdempotentLength.lean new file mode 100644 index 0000000000..001187f9ca --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdempotentLength.lean @@ -0,0 +1,237 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Length + +/-! +# Length lower bounds from orthogonal idempotents + +A family of pairwise-orthogonal nonzero idempotent endomorphisms +of an object `Y` of an abelian category splits `Y` into as many +nonzero pieces, so it bounds the composition length of `Y` from +below. In the bound-shaped formulation of `LengthLE` +(`RS/Definitions.lean`) this reads: `k` such endomorphisms +together with `LengthLE Y N` force `k ≤ N + 1`. + +The proof forms the partial sums `E n = f 0 + ⋯ + f n`, which are +again idempotent by orthogonality, realises each as the subobject +`ker (𝟙 Y - E n)`, and shows the resulting chain is strictly +increasing: a collapse of consecutive kernels would factor +`f (n + 1)` through `ker (𝟙 Y - E n)`, where it is annihilated by +orthogonality, contradicting `f (n + 1) ≠ 0`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Limits + +universe v u + +section Helpers + +variable {C : Type u} + +/-- An endomorphism, retyped as a morphism, so that morphism-level +notation (`≫`, subtraction of parallel morphisms) elaborates +without fuss. -/ +private def endHom [Category.{v} C] + {Y : C} (e : End Y) : Y ⟶ Y := e + +/-- A finite family of endomorphisms, extended by zero to a family +indexed by `ℕ`. -/ +private def extendZero [Category.{v} C] [Abelian C] + {Y : C} {k : ℕ} (f : Fin k → End Y) (n : ℕ) : + End Y := + if h : n < k then f ⟨n, h⟩ else 0 + +/-- Below `k`, the extension agrees with the original family. -/ +private lemma extendZero_of_lt [Category.{v} C] [Abelian C] + {Y : C} {k : ℕ} (f : Fin k → End Y) + {n : ℕ} (h : n < k) : extendZero f n = f ⟨n, h⟩ := + dite_eq_left h + +/-- The extension by zero inherits idempotence. -/ +private lemma extendZero_idem [Category.{v} C] [Abelian C] + {Y : C} {k : ℕ} {f : Fin k → End Y} + (hidem : ∀ i, f i * f i = f i) (n : ℕ) : + extendZero f n * extendZero f n = extendZero f n := by + unfold extendZero + split + · exact hidem _ + · exact zero_mul 0 + +/-- The extension by zero inherits pairwise orthogonality. -/ +private lemma extendZero_orth [Category.{v} C] [Abelian C] + {Y : C} {k : ℕ} {f : Fin k → End Y} + (horth : ∀ i j, i ≠ j → f i * f j = 0) {m n : ℕ} (h : m ≠ n) : + extendZero f m * extendZero f n = 0 := by + unfold extendZero + split + · split + · exact horth _ _ fun he => h (congrArg Fin.val he) + · exact mul_zero _ + · exact zero_mul _ + +/-- The partial sum `g 0 + ⋯ + g n` of a family of +endomorphisms. -/ +private def partialSum [Category.{v} C] [Abelian C] + {Y : C} (g : ℕ → End Y) (n : ℕ) : End Y := + ∑ i ∈ Finset.range (n + 1), g i + +/-- Multiplying a partial sum of an orthogonal idempotent family +by a member already collected picks out that member. -/ +private lemma partialSum_mul [Category.{v} C] [Abelian C] + {Y : C} {g : ℕ → End Y} + (hidem : ∀ i, g i * g i = g i) + (horth : ∀ i j, i ≠ j → g i * g j = 0) + {j n : ℕ} (h : j ≤ n) : partialSum g n * g j = g j := by + unfold partialSum + rw [Finset.sum_mul, Finset.sum_eq_single j + (fun b _ hb => horth b j hb) + (fun hj => absurd (Finset.mem_range.mpr (by omega)) hj)] + exact hidem j + +/-- A partial sum of an orthogonal family annihilates the members +not yet collected. -/ +private lemma partialSum_mul_of_lt [Category.{v} C] [Abelian C] + {Y : C} {g : ℕ → End Y} + (horth : ∀ i j, i ≠ j → g i * g j = 0) + {j n : ℕ} (h : n < j) : partialSum g n * g j = 0 := by + unfold partialSum + rw [Finset.sum_mul] + exact Finset.sum_eq_zero fun i hi => + horth i j (by have := Finset.mem_range.mp hi; omega) + +/-- Consecutive partial sums of an orthogonal idempotent family +multiply to the shorter one. -/ +private lemma partialSum_succ_mul [Category.{v} C] [Abelian C] + {Y : C} {g : ℕ → End Y} + (hidem : ∀ i, g i * g i = g i) + (horth : ∀ i j, i ≠ j → g i * g j = 0) (n : ℕ) : + partialSum g (n + 1) * partialSum g n = partialSum g n := by + have h1 : partialSum g n = ∑ i ∈ Finset.range (n + 1), g i := rfl + rw [h1, Finset.mul_sum] + exact Finset.sum_congr rfl fun i hi => + partialSum_mul hidem horth + (by have := Finset.mem_range.mp hi; omega) + +/-- The subobject of `Y` carried by an idempotent `e`, realised as +the kernel of `𝟙 Y - e`. -/ +private noncomputable def idemKer [Category.{v} C] [Abelian C] + {Y : C} (e : End Y) : + Subobject Y := + Subobject.mk (kernel.ι (𝟙 Y - endHom e)) + +/-- The kernel inclusion of `𝟙 Y - e` is fixed by `e`. -/ +private lemma kernel_comp_self [Category.{v} C] [Abelian C] + {Y : C} (e : End Y) : + kernel.ι (𝟙 Y - endHom e) ≫ endHom e = + kernel.ι (𝟙 Y - endHom e) := by + have h := kernel.condition (𝟙 Y - endHom e) + rw [Preadditive.comp_sub, Category.comp_id, sub_eq_zero] at h + exact h.symm + +/-- Anything that factors through the kernel of `𝟙 Y - e` is fixed +by `e`. -/ +private lemma comp_self_of_factors [Category.{v} C] [Abelian C] + {Y T : C} {e : End Y} + {x : T ⟶ Y} {w : T ⟶ kernel (𝟙 Y - endHom e)} + (hw : w ≫ kernel.ι (𝟙 Y - endHom e) = x) : x ≫ endHom e = x := by + rw [← hw, Category.assoc, kernel_comp_self] + +/-- If `e' * e = e` then the subobject carried by `e` is contained +in the one carried by `e'`. -/ +private lemma idemKer_le [Category.{v} C] [Abelian C] + {Y : C} {e e' : End Y} (h : e' * e = e) : + idemKer e ≤ idemKer e' := by + have hc : endHom e ≫ endHom e' = endHom e := by + rw [← End.mul_def]; exact h + have hk : kernel.ι (𝟙 Y - endHom e) ≫ (𝟙 Y - endHom e') = 0 := by + have h2 : kernel.ι (𝟙 Y - endHom e) ≫ endHom e' = + kernel.ι (𝟙 Y - endHom e) := by + calc kernel.ι (𝟙 Y - endHom e) ≫ endHom e' + = (kernel.ι (𝟙 Y - endHom e) ≫ endHom e) ≫ endHom e' := by + rw [kernel_comp_self] + _ = kernel.ι (𝟙 Y - endHom e) ≫ (endHom e ≫ endHom e') := + Category.assoc _ _ _ + _ = kernel.ι (𝟙 Y - endHom e) := by + rw [hc, kernel_comp_self] + rw [Preadditive.comp_sub, Category.comp_id, h2, sub_self] + exact Subobject.mk_le_mk_of_comm + (kernel.lift _ (kernel.ι _) hk) (kernel.lift_ι _ _ _) + +/-- If the subobjects carried by two idempotents coincide, an +endomorphism fixed by the second and annihilated by the first must +vanish. -/ +private lemma eq_zero_of_idemKer_eq [Category.{v} C] [Abelian C] + {Y : C} {e e' a : End Y} + (hfix : e' * a = a) (hkill : e * a = 0) + (hU : idemKer e = idemKer e') : a = 0 := by + have hfix' : endHom a ≫ endHom e' = endHom a := by + rw [← End.mul_def]; exact hfix + have hkill' : endHom a ≫ endHom e = 0 := by + rw [← End.mul_def]; exact hkill + have hz : endHom a ≫ (𝟙 Y - endHom e') = 0 := by + rw [Preadditive.comp_sub, Category.comp_id, hfix', sub_self] + have hle : idemKer e' ≤ idemKer e := hU.ge + unfold idemKer at hle + have ha : (kernel.lift (𝟙 Y - endHom e') (endHom a) hz ≫ + Subobject.ofMkLEMk _ _ hle) ≫ kernel.ι (𝟙 Y - endHom e) = + endHom a := by + rw [Category.assoc, Subobject.ofMkLEMk_comp, kernel.lift_ι] + have hae : endHom a ≫ endHom e = endHom a := comp_self_of_factors ha + rw [hkill'] at hae + exact hae.symm + +end Helpers + +/-- **Orthogonal idempotents bound length from below.** In an +abelian category, a family of `k` pairwise-orthogonal nonzero +idempotent endomorphisms of `Y` forces the composition length of +`Y` to be at least `k`; with the bound `LengthLE Y N` this reads +`k ≤ N + 1`. -/ +theorem le_of_orthogonal_idempotents {C : Type u} [Category.{v} C] + [Abelian C] {Y : C} {N k : ℕ} (hlen : LengthLE Y N) + (f : Fin k → End Y) + (hidem : ∀ i, f i * f i = f i) + (horth : ∀ i j, i ≠ j → f i * f j = 0) + (hne : ∀ i, f i ≠ 0) : + k ≤ N + 1 := by + by_contra hk + have hgidem := extendZero_idem hidem + have hgorth : ∀ m n, m ≠ n → + extendZero f m * extendZero f n = 0 := + fun m n h => extendZero_orth horth h + have hstep : ∀ n, idemKer (partialSum (extendZero f) n) ≤ + idemKer (partialSum (extendZero f) (n + 1)) := + fun n => idemKer_le (partialSum_succ_mul hgidem hgorth n) + have hmono : + Monotone fun n => idemKer (partialSum (extendZero f) n) := + monotone_nat_of_le_succ hstep + have hstrict : ∀ n, n + 1 < k → + idemKer (partialSum (extendZero f) n) ≠ + idemKer (partialSum (extendZero f) (n + 1)) := by + intro n hn hEq + have hz : extendZero f (n + 1) = 0 := + eq_zero_of_idemKer_eq + (partialSum_mul hgidem hgorth (le_refl (n + 1))) + (partialSum_mul_of_lt hgorth (Nat.lt_succ_self n)) hEq + exact hne ⟨n + 1, hn⟩ ((extendZero_of_lt f hn).symm.trans hz) + refine hlen + (fun i : Fin (N + 2) => + idemKer (partialSum (extendZero f) i)) ?_ + intro a b hab + have hab' : (a : ℕ) < (b : ℕ) := hab + have hb := b.isLt + refine lt_of_lt_of_le + (lt_of_le_of_ne (hstep a) (hstrict a (by omega))) (hmono ?_) + omega + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ImageSubalgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ImageSubalgebra.lean new file mode 100644 index 0000000000..6814003aa1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ImageSubalgebra.lean @@ -0,0 +1,692 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescent + +/-! +# The algebra structure on the image tower + +`RS.Classical.Deligne.CountableDescent` builds, inside a commutative +algebra `A` of `Ind C` and above a stage `i₀` of its presentation, the +tower of images `RS.imageRung`, its colimit `RS.imageSubalgebra`, and +the monomorphism `RS.imageSubalgebraHom` of that colimit into the +algebra. This file makes the colimit an algebra in its own right, so +that the countably presented replacement produced there is a +replacement of algebras. + +The multiplication. Tensoring in `Ind C` preserves filtered colimits +(`RS.Classical.Deligne.IndTensorExact`), so the square of the colimit +is the colimit of the squares, and the multiplication is a descent in +each variable: `RS.imageMul` is `RS.imageLeftMul` descended along the +right-hand variable, and `RS.imageLeftMul` is `RS.imagePairMul` +descended along the left-hand one. The naturality conditions of the +two descents cost nothing, because `RS.imageSubalgebraHom` is a +monomorphism and both sides of each condition have the same composite +with it. + +The product of a pair of rungs. Rungs `n` and `m` are pushed up to +their common upper bound, where the tower is closed under +multiplication one rung at a time. Closure is an +epimorphism--monomorphism lifting: the square of the stage of the +presentation surjects onto the square of its image, because the +tensor of `Ind C` is right exact in each variable +(`RS.Classical.Deligne.IndCoeq`) and hence carries epimorphisms to +epimorphisms; the next rung is a subobject of the algebra; and +`RS.stageMul_spec` says the square commutes. Every epimorphism of an +abelian category is strong, so the lifting exists. + +The unit and the laws. A stage carrying the unit of the algebra +(`RS.UnitAtStage`, satisfied by `RS.unitStage` and by every stage +above it) puts the unit into rung zero. The laws are then free: each +is an equation between maps into the colimit, and a monomorphism +cancels, so each reduces to the corresponding law in `A`. This is +`RS.monObjOfMono`, and it gives `MonObj (RS.imageSubalgebra A i₀)` +and, over a symmetric `C`, `IsCommMonObj` of the same. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe w u v + +/-! ## Subobjects closed under the operations + +A monomorphism into an algebra whose source carries a multiplication +and a unit lying over those of the algebra is itself an algebra: each +law is an equation between maps into the source, and a monomorphism +cancels. -/ + +section SubObject + +variable {D : Type u} + +/-- **The unit law of a subobject closed under the operations**, +left-hand version. -/ +theorem one_mul_of_mono + [Category.{w} D] [MonoidalCategory D] {S : D} {A : D} [MonObj A] + (k : S ⟶ A) [Mono k] (m : S ⊗ S ⟶ S) (e : 𝟙_ D ⟶ S) + (hm : m ≫ k = (k ⊗ₘ k) ≫ μ[A]) + (he : e ≫ k = η[A]) : e ▷ S ≫ m = (λ_ S).hom := by + rw [← cancel_mono k, Category.assoc, hm, ← Category.assoc, + ← tensorHom_id, tensorHom_comp_tensorHom, Category.id_comp, he, + tensorHom_def', Category.assoc, MonObj.one_mul, + leftUnitor_naturality] + +/-- **The unit law of a subobject closed under the operations**, +right-hand version. -/ +theorem mul_one_of_mono + [Category.{w} D] [MonoidalCategory D] {S : D} {A : D} [MonObj A] + (k : S ⟶ A) [Mono k] (m : S ⊗ S ⟶ S) (e : 𝟙_ D ⟶ S) + (hm : m ≫ k = (k ⊗ₘ k) ≫ μ[A]) + (he : e ≫ k = η[A]) : S ◁ e ≫ m = (ρ_ S).hom := by + rw [← cancel_mono k, Category.assoc, hm, ← Category.assoc, + ← id_tensorHom, tensorHom_comp_tensorHom, Category.id_comp, he, + tensorHom_def, Category.assoc, MonObj.mul_one, + rightUnitor_naturality] + +/-- **The associativity law of a subobject closed under the +operations.** -/ +theorem mul_assoc_of_mono + [Category.{w} D] [MonoidalCategory D] {S : D} {A : D} [MonObj A] + (k : S ⟶ A) [Mono k] (m : S ⊗ S ⟶ S) + (hm : m ≫ k = (k ⊗ₘ k) ≫ μ[A]) : + m ▷ S ≫ m = (α_ S S S).hom ≫ S ◁ m ≫ m := by + have h1 : m ▷ S ≫ (k ⊗ₘ k) = ((k ⊗ₘ k) ≫ μ[A]) ⊗ₘ k := by + rw [← tensorHom_id, tensorHom_comp_tensorHom, Category.id_comp, hm] + have h2 : S ◁ m ≫ (k ⊗ₘ k) = k ⊗ₘ ((k ⊗ₘ k) ≫ μ[A]) := by + rw [← id_tensorHom, tensorHom_comp_tensorHom, Category.id_comp, hm] + have h3 : ((k ⊗ₘ k) ≫ μ[A]) ⊗ₘ k + = ((k ⊗ₘ k) ⊗ₘ k) ≫ μ[A] ▷ A := by + rw [← tensorHom_id, tensorHom_comp_tensorHom, Category.comp_id] + have h4 : k ⊗ₘ ((k ⊗ₘ k) ≫ μ[A]) + = (k ⊗ₘ (k ⊗ₘ k)) ≫ A ◁ μ[A] := by + rw [← id_tensorHom, tensorHom_comp_tensorHom, Category.comp_id] + rw [← cancel_mono k] + simp only [Category.assoc, hm] + rw [← Category.assoc, h1, h3, ← Category.assoc (S ◁ m), h2, h4, + Category.assoc, Category.assoc, MonObj.mul_assoc, + ← Category.assoc ((k ⊗ₘ k) ⊗ₘ k), associator_naturality, + Category.assoc] + +/-- **The commutativity law of a subobject closed under the +operations.** -/ +theorem mul_comm_of_mono + [Category.{w} D] [MonoidalCategory D] {S : D} {A : D} [MonObj A] + (k : S ⟶ A) [Mono k] (m : S ⊗ S ⟶ S) + [BraidedCategory D] [IsCommMonObj A] + (hm : m ≫ k = (k ⊗ₘ k) ≫ μ[A]) : (β_ S S).hom ≫ m = m := by + rw [← cancel_mono k, Category.assoc, hm, ← Category.assoc, + ← BraidedCategory.braiding_naturality, Category.assoc, + IsCommMonObj.mul_comm] + +/-- **A subobject closed under the operations is an algebra.** -/ +@[reducible] def monObjOfMono + [Category.{w} D] [MonoidalCategory D] {S : D} {A : D} [MonObj A] + (k : S ⟶ A) [Mono k] (m : S ⊗ S ⟶ S) (e : 𝟙_ D ⟶ S) + (hm : m ≫ k = (k ⊗ₘ k) ≫ μ[A]) + (he : e ≫ k = η[A]) : MonObj S where + one := e + mul := m + one_mul := one_mul_of_mono k m e hm he + mul_one := mul_one_of_mono k m e hm he + mul_assoc := mul_assoc_of_mono k m hm + +end SubObject + +/-! ## Epimorphisms and the tensor of ind-objects + +The tensor product of `Ind C` is right exact in each variable, so it +carries epimorphisms to epimorphisms; and every epimorphism of an +abelian category is strong. -/ + +section IndEpi + +variable {C : Type v} + +/-- **The tensor of two epimorphisms of ind-objects is an +epimorphism**: both whiskerings are right exact. -/ +instance epi_tensorHom_ind + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + {X Y X' Y' : Ind C} (f : X ⟶ Y) + (g : X' ⟶ Y') [Epi f] [Epi g] : Epi (f ⊗ₘ g) := by + have : Epi (f ▷ X') := inferInstanceAs (Epi ((tensorRight X').map f)) + have : Epi (Y ◁ g) := inferInstanceAs (Epi ((tensorLeft Y).map g)) + rw [tensorHom_def] + exact epi_comp _ _ + +/-- The tensor of two epimorphisms of ind-objects is a strong +epimorphism: `Ind C` is abelian. -/ +instance strongEpi_tensorHom_ind + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + {X Y X' Y' : Ind C} (f : X ⟶ Y) + (g : X' ⟶ Y') [Epi f] [Epi g] : StrongEpi (f ⊗ₘ g) := + strongEpi_of_epi _ + +end IndEpi + +/-! ## The stage carrying the unit + +The tower generated at a stage contains the unit of the algebra as +soon as the unit factors through that stage. The chosen stage +`RS.unitStage` does, and so does every stage above it. -/ + +section UnitStage + +variable {C : Type v} + +/-- **The unit is carried by a stage**: the unit of the algebra +factors through the given stage of the chosen presentation. -/ +class UnitAtStage + [SmallCategory C] [MonoidalCategory C] + (A : Ind C) [MonObj A] (i : A.presentation.I) : + Prop where + /-- The unit of the algebra factors through the stage. -/ + exists_point : ∃ e : 𝟙_ (Ind C) ⟶ + indOf.obj (A.presentation.F.obj i), e ≫ presStage A i = η[A] + +/-- The factorisation of the unit through a stage that carries it. -/ +theorem exists_unitAtStage_point [SmallCategory C] [MonoidalCategory C] + (A : Ind C) [MonObj A] + (i : A.presentation.I) [UnitAtStage A i] : + ∃ e : 𝟙_ (Ind C) ⟶ indOf.obj (A.presentation.F.obj i), + e ≫ presStage A i = η[A] := + UnitAtStage.exists_point + +/-- **The chosen unit stage carries the unit.** -/ +instance unitAtStage_unitStage [SmallCategory C] [MonoidalCategory C] + (A : Ind C) [MonObj A] : + UnitAtStage A (unitStage A) := + ⟨⟨unitStagePoint A, unitStagePoint_spec A⟩⟩ + +/-- **Every stage above a stage carrying the unit carries it too.** -/ +theorem UnitAtStage.map [SmallCategory C] [MonoidalCategory C] + {A : Ind C} [MonObj A] + {i j : A.presentation.I} (α : i ⟶ j) [UnitAtStage A i] : + UnitAtStage A j := by + obtain ⟨e, he⟩ := exists_unitAtStage_point A i + refine ⟨⟨e ≫ indOf.map (A.presentation.F.map α), ?_⟩⟩ + exact (Category.assoc _ _ _).trans + ((whisker_eq _ (presStage_naturality A α)).trans he) + +end UnitStage + +/-! ## The tower, its rungs, and its unit + +Everything in this section is available over an abelian `C`: the +comparison maps of the rungs, the lifting square for the rung-wise +multiplication, and the unit. -/ + +section ImageTowerBasic + +variable {C : Type v} + +/-- The image tower, read as a diagram over the ambient-universe copy +of the natural numbers. -/ +@[reducible] noncomputable def imageDiagram + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) : Tower.{v} ⥤ Ind C := + AsSmall.down ⋙ imageSeq A i₀ + +/-- **Maps into the image tower are determined by their composites +with the inclusion into the algebra**, that inclusion being a +monomorphism. -/ +theorem imageSubalgebra_hom_ext + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) + {X : Ind C} + {f g : X ⟶ imageSubalgebra A i₀} + (h : f ≫ imageSubalgebraHom A i₀ = g ≫ imageSubalgebraHom A i₀) : + f = g := + haveI := mono_imageSubalgebraHom A i₀ + (cancel_mono (imageSubalgebraHom A i₀)).mp h + +/-- The structural maps of the colimit of the image tower, composed +with the inclusion into the algebra. -/ +theorem imageColimitι_comp_hom + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) + (m : Tower.{v}) : + colimit.ι (imageDiagram A i₀) m ≫ imageSubalgebraHom A i₀ = + stageImageι A (towerIdx A i₀ (ULift.down m)) := + imageRungι_comp_hom A i₀ (ULift.down m) + +/-- The transition maps of the image tower are compatible with the +inclusions of the rungs into the algebra. -/ +theorem imageDiagram_map_comp_ι + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) + {m m' : Tower.{v}} (u : m ⟶ m') : + (imageDiagram A i₀).map u ≫ + stageImageι A (towerIdx A i₀ (ULift.down m')) = + stageImageι A (towerIdx A i₀ (ULift.down m)) := + (whisker_eq _ (imageColimitι_comp_hom A i₀ m').symm).trans + ((Category.assoc _ _ _).symm.trans + ((eq_whisker (colimit.w (imageDiagram A i₀) u) _).trans + (imageColimitι_comp_hom A i₀ m))) + +/-- The comparison map of two rungs of the image tower. -/ +noncomputable def imageRungLe + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) + {n k : ℕ} (h : n ≤ k) : + stageImage A (towerIdx A i₀ n) ⟶ stageImage A (towerIdx A i₀ k) := + (imageDiagram A i₀).map (X := (⟨n⟩ : Tower.{v})) (Y := ⟨k⟩) + ⟨homOfLE h⟩ + +theorem imageRungLe_comp_ι + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) + {n k : ℕ} (h : n ≤ k) : + imageRungLe A i₀ h ≫ stageImageι A (towerIdx A i₀ k) = + stageImageι A (towerIdx A i₀ n) := + imageDiagram_map_comp_ι A i₀ _ + +/-- The square of a rung of the generated tower, multiplied into the +next rung of the image tower. -/ +noncomputable def imageRungTop + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) + (n : ℕ) : + indOf.obj (towerObj A i₀ n) ⊗ indOf.obj (towerObj A i₀ n) ⟶ + stageImage A (towerIdx A i₀ (n + 1)) := + (indOfTensorIso (towerObj A i₀ n) (towerObj A i₀ n)).hom ≫ + indOf.map (stageMul A (towerIdx A i₀ n)) ≫ + stageToImage A (towerIdx A i₀ (n + 1)) + +theorem imageRungTop_comp_ι + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) + (n : ℕ) : + imageRungTop A i₀ n ≫ stageImageι A (towerIdx A i₀ (n + 1)) = + (presStage A (towerIdx A i₀ n) ⊗ₘ + presStage A (towerIdx A i₀ n)) ≫ μ[A] := + have h4 : stageToImage A (towerIdx A i₀ (n + 1)) ≫ + stageImageι A (towerIdx A i₀ (n + 1)) = + presStage A (nextStage A (towerIdx A i₀ n)) := + stageToImage_comp_ι A (towerIdx A i₀ (n + 1)) + have h3 : indOf.map (stageMul A (towerIdx A i₀ n)) ≫ + presStage A (nextStage A (towerIdx A i₀ n)) = + stageMulToAlg A (towerIdx A i₀ n) := + stageMul_spec A (towerIdx A i₀ n) + (Category.assoc _ _ _).trans + ((whisker_eq _ ((Category.assoc _ _ _).trans + ((whisker_eq _ h4).trans h3))).trans + (indOfTensorIso_stageMulToAlg A (towerIdx A i₀ n))) + +theorem imageRungBot_comp + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) + (n : ℕ) : + (stageToImage A (towerIdx A i₀ n) ⊗ₘ + stageToImage A (towerIdx A i₀ n)) ≫ + ((stageImageι A (towerIdx A i₀ n) ⊗ₘ + stageImageι A (towerIdx A i₀ n)) ≫ μ[A]) = + (presStage A (towerIdx A i₀ n) ⊗ₘ + presStage A (towerIdx A i₀ n)) ≫ μ[A] := + have h : (stageToImage A (towerIdx A i₀ n) ⊗ₘ + stageToImage A (towerIdx A i₀ n)) ≫ + (stageImageι A (towerIdx A i₀ n) ⊗ₘ + stageImageι A (towerIdx A i₀ n)) = + presStage A (towerIdx A i₀ n) ⊗ₘ + presStage A (towerIdx A i₀ n) := by + rw [tensorHom_comp_tensorHom, stageToImage_comp_ι] + (Category.assoc _ _ _).symm.trans (eq_whisker h μ[A]) + +/-- The lifting square for the multiplication of a rung of the image +tower with itself: the square of the stage surjects onto the square of +its image, the next rung is a subobject of the algebra, and the +generated tower is closed under multiplication. -/ +theorem imageRungMul_sq + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) + (n : ℕ) : + CommSq (imageRungTop A i₀ n) + (stageToImage A (towerIdx A i₀ n) ⊗ₘ + stageToImage A (towerIdx A i₀ n)) + (stageImageι A (towerIdx A i₀ (n + 1))) + ((stageImageι A (towerIdx A i₀ n) ⊗ₘ + stageImageι A (towerIdx A i₀ n)) ≫ μ[A]) := + ⟨(imageRungTop_comp_ι A i₀ n).trans (imageRungBot_comp A i₀ n).symm⟩ + +/-- **The unit of the image tower**, present as soon as the generating +stage carries the unit of the algebra. -/ +noncomputable def imageOne + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) + [UnitAtStage A i₀] : + 𝟙_ (Ind C) ⟶ imageSubalgebra A i₀ := + (exists_unitAtStage_point A i₀).choose ≫ + stageToImage A i₀ ≫ imageRungι A i₀ 0 + +/-- **The unit of the image tower lies over the unit of the +algebra.** -/ +theorem imageOne_comp_hom + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) + [UnitAtStage A i₀] : + imageOne A i₀ ≫ imageSubalgebraHom A i₀ = η[A] := + have h0 : imageRungι A i₀ 0 ≫ imageSubalgebraHom A i₀ = + stageImageι A i₀ := imageRungι_comp_hom A i₀ 0 + have h1 : stageToImage A i₀ ≫ (imageRungι A i₀ 0 ≫ + imageSubalgebraHom A i₀) = presStage A i₀ := + (whisker_eq _ h0).trans (stageToImage_comp_ι A i₀) + (Category.assoc _ _ _).trans + ((whisker_eq _ ((Category.assoc _ _ _).trans h1)).trans + (exists_unitAtStage_point A i₀).choose_spec) + +/-- **The unit of the image tower does not vanish** when the unit of +the algebra does not: it composes to the unit of the algebra. -/ +theorem imageOne_ne_zero + [SmallCategory C] [MonoidalCategory C] [Abelian C] (A : Ind C) + [MonObj A] (i₀ : A.presentation.I) + [UnitAtStage A i₀] (h : η[A] ≠ 0) : + imageOne A i₀ ≠ 0 := fun hz => + h ((imageOne_comp_hom A i₀).symm.trans + ((eq_whisker hz _).trans (Limits.zero_comp))) + +end ImageTowerBasic + +/-! ## The multiplication of the image tower + +The rungs are closed under multiplication one rung at a time, by an +epimorphism--monomorphism lifting; the products of pairs of rungs +assemble into the multiplication of the colimit by two filtered +descents. -/ + +section ImageMul + +variable {C : Type v} + +/-- **The image tower is closed under multiplication, rung by +rung.** -/ +noncomputable def imageRungMul + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] (A : Ind C) [MonObj A] (i₀ : A.presentation.I) + (n : ℕ) : + stageImage A (towerIdx A i₀ n) ⊗ stageImage A (towerIdx A i₀ n) ⟶ + stageImage A (towerIdx A i₀ (n + 1)) := + (imageRungMul_sq A i₀ n).lift + +theorem imageRungMul_comp_ι + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] (A : Ind C) [MonObj A] (i₀ : A.presentation.I) + (n : ℕ) : + imageRungMul A i₀ n ≫ stageImageι A (towerIdx A i₀ (n + 1)) = + (stageImageι A (towerIdx A i₀ n) ⊗ₘ + stageImageι A (towerIdx A i₀ n)) ≫ μ[A] := + (imageRungMul_sq A i₀ n).fac_right + +/-- **The product of two rungs of the image tower**: both are pushed +up to their common upper bound, where the tower multiplies. -/ +noncomputable def imagePairMul + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] (A : Ind C) [MonObj A] (i₀ : A.presentation.I) + (n m : ℕ) : + stageImage A (towerIdx A i₀ n) ⊗ stageImage A (towerIdx A i₀ m) ⟶ + imageSubalgebra A i₀ := + (imageRungLe A i₀ (le_max_left n m) ⊗ₘ + imageRungLe A i₀ (le_max_right n m)) ≫ + imageRungMul A i₀ (max n m) ≫ imageRungι A i₀ (max n m + 1) + +theorem imagePairMul_comp_hom + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] (A : Ind C) [MonObj A] (i₀ : A.presentation.I) + (n m : ℕ) : + imagePairMul A i₀ n m ≫ imageSubalgebraHom A i₀ = + (stageImageι A (towerIdx A i₀ n) ⊗ₘ + stageImageι A (towerIdx A i₀ m)) ≫ μ[A] := + have h1 : imageRungMul A i₀ (max n m) ≫ + (imageRungι A i₀ (max n m + 1) ≫ imageSubalgebraHom A i₀) = + (stageImageι A (towerIdx A i₀ (max n m)) ⊗ₘ + stageImageι A (towerIdx A i₀ (max n m))) ≫ μ[A] := + (whisker_eq _ (imageRungι_comp_hom A i₀ (max n m + 1))).trans + (imageRungMul_comp_ι A i₀ (max n m)) + have h2 : (imageRungLe A i₀ (le_max_left n m) ⊗ₘ + imageRungLe A i₀ (le_max_right n m)) ≫ + (stageImageι A (towerIdx A i₀ (max n m)) ⊗ₘ + stageImageι A (towerIdx A i₀ (max n m))) = + stageImageι A (towerIdx A i₀ n) ⊗ₘ + stageImageι A (towerIdx A i₀ m) := by + rw [tensorHom_comp_tensorHom, + imageRungLe_comp_ι A i₀ (le_max_left n m), + imageRungLe_comp_ι A i₀ (le_max_right n m)] + (Category.assoc _ _ _).trans + ((whisker_eq _ ((Category.assoc _ _ _).trans h1)).trans + ((Category.assoc _ _ _).symm.trans (eq_whisker h2 μ[A]))) + +/-- The cocone over the image tower whose leg at a rung is the product +with a fixed rung. -/ +noncomputable def imageLeftMulCocone + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] (A : Ind C) [MonObj A] (i₀ : A.presentation.I) + (n : ℕ) : + Cocone (imageDiagram A i₀ ⋙ + tensorLeft (stageImage A (towerIdx A i₀ n))) := + Cocone.mk (imageSubalgebra A i₀) + { app := fun m => imagePairMul A i₀ n (ULift.down m) + naturality := fun m m' u => by + have hh : (stageImage A (towerIdx A i₀ n) ◁ + (imageDiagram A i₀).map u) ≫ + (stageImageι A (towerIdx A i₀ n) ⊗ₘ + stageImageι A (towerIdx A i₀ (ULift.down m'))) = + stageImageι A (towerIdx A i₀ n) ⊗ₘ + stageImageι A (towerIdx A i₀ (ULift.down m)) := by + erw [whiskerLeft_comp_tensorHom, imageDiagram_map_comp_ι] + rfl + refine Eq.trans ?_ (Category.comp_id _).symm + refine imageSubalgebra_hom_ext A i₀ ?_ + exact ((Category.assoc _ _ _).trans + ((whisker_eq _ (imagePairMul_comp_hom A i₀ n + (ULift.down m'))).trans + ((Category.assoc _ _ _).symm.trans + (eq_whisker hh μ[A])))).trans + (imagePairMul_comp_hom A i₀ n (ULift.down m)).symm } + +/-- The product of a rung of the image tower with the whole tower. -/ +noncomputable def imageLeftMul + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] (A : Ind C) [MonObj A] (i₀ : A.presentation.I) + (n : ℕ) : + stageImage A (towerIdx A i₀ n) ⊗ imageSubalgebra A i₀ ⟶ + imageSubalgebra A i₀ := + (isColimitOfPreserves (tensorLeft (stageImage A (towerIdx A i₀ n))) + (colimit.isColimit (imageDiagram A i₀))).desc + (imageLeftMulCocone A i₀ n) + +theorem imageLeftMul_fac + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] (A : Ind C) [MonObj A] (i₀ : A.presentation.I) + (n : ℕ) (m : Tower.{v}) : + (stageImage A (towerIdx A i₀ n) ◁ + colimit.ι (imageDiagram A i₀) m) ≫ imageLeftMul A i₀ n = + imagePairMul A i₀ n (ULift.down m) := + (isColimitOfPreserves (tensorLeft (stageImage A (towerIdx A i₀ n))) + (colimit.isColimit (imageDiagram A i₀))).fac + (imageLeftMulCocone A i₀ n) m + +theorem imageLeftMul_comp_hom + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] (A : Ind C) [MonObj A] (i₀ : A.presentation.I) + (n : ℕ) : + imageLeftMul A i₀ n ≫ imageSubalgebraHom A i₀ = + (stageImageι A (towerIdx A i₀ n) ⊗ₘ + imageSubalgebraHom A i₀) ≫ μ[A] := + (isColimitOfPreserves (tensorLeft (stageImage A (towerIdx A i₀ n))) + (colimit.isColimit (imageDiagram A i₀))).hom_ext (fun m => + have hh : (stageImage A (towerIdx A i₀ n) ◁ + colimit.ι (imageDiagram A i₀) m) ≫ + (stageImageι A (towerIdx A i₀ n) ⊗ₘ + imageSubalgebraHom A i₀) = + stageImageι A (towerIdx A i₀ n) ⊗ₘ + stageImageι A (towerIdx A i₀ (ULift.down m)) := by + erw [whiskerLeft_comp_tensorHom, imageColimitι_comp_hom] + rfl + ((Category.assoc _ _ _).symm.trans + ((eq_whisker (imageLeftMul_fac A i₀ n m) _).trans + (imagePairMul_comp_hom A i₀ n (ULift.down m)))).trans + ((Category.assoc _ _ _).symm.trans + (eq_whisker hh μ[A])).symm) + +/-- The cocone over the image tower whose leg at a rung is the product +of that rung with the whole tower. -/ +noncomputable def imageMulCocone + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] (A : Ind C) [MonObj A] (i₀ : A.presentation.I) : + Cocone (imageDiagram A i₀ ⋙ + tensorRight (imageSubalgebra A i₀)) := + Cocone.mk (imageSubalgebra A i₀) + { app := fun n => imageLeftMul A i₀ (ULift.down n) + naturality := fun n n' u => by + have hh : ((imageDiagram A i₀).map u ▷ + imageSubalgebra A i₀) ≫ + (stageImageι A (towerIdx A i₀ (ULift.down n')) ⊗ₘ + imageSubalgebraHom A i₀) = + stageImageι A (towerIdx A i₀ (ULift.down n)) ⊗ₘ + imageSubalgebraHom A i₀ := by + erw [whiskerRight_comp_tensorHom, imageDiagram_map_comp_ι] + rfl + refine Eq.trans ?_ (Category.comp_id _).symm + refine imageSubalgebra_hom_ext A i₀ ?_ + exact ((Category.assoc _ _ _).trans + ((whisker_eq _ (imageLeftMul_comp_hom A i₀ + (ULift.down n'))).trans + ((Category.assoc _ _ _).symm.trans + (eq_whisker hh μ[A])))).trans + (imageLeftMul_comp_hom A i₀ (ULift.down n)).symm } + +/-- **The multiplication of the image tower.** -/ +noncomputable def imageMul + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] (A : Ind C) [MonObj A] (i₀ : A.presentation.I) : + imageSubalgebra A i₀ ⊗ imageSubalgebra A i₀ ⟶ + imageSubalgebra A i₀ := + (isColimitOfPreserves (tensorRight (imageSubalgebra A i₀)) + (colimit.isColimit (imageDiagram A i₀))).desc (imageMulCocone A i₀) + +theorem imageMul_fac + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] (A : Ind C) [MonObj A] (i₀ : A.presentation.I) + (n : Tower.{v}) : + (colimit.ι (imageDiagram A i₀) n ▷ imageSubalgebra A i₀) ≫ + imageMul A i₀ = + imageLeftMul A i₀ (ULift.down n) := + (isColimitOfPreserves (tensorRight (imageSubalgebra A i₀)) + (colimit.isColimit (imageDiagram A i₀))).fac + (imageMulCocone A i₀) n + +/-- **The multiplication of the image tower lies over the +multiplication of the algebra.** -/ +theorem imageMul_comp_hom + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] (A : Ind C) [MonObj A] (i₀ : A.presentation.I) : + imageMul A i₀ ≫ imageSubalgebraHom A i₀ = + (imageSubalgebraHom A i₀ ⊗ₘ imageSubalgebraHom A i₀) ≫ μ[A] := + (isColimitOfPreserves (tensorRight (imageSubalgebra A i₀)) + (colimit.isColimit (imageDiagram A i₀))).hom_ext (fun n => + have hh : (colimit.ι (imageDiagram A i₀) n ▷ + imageSubalgebra A i₀) ≫ + (imageSubalgebraHom A i₀ ⊗ₘ imageSubalgebraHom A i₀) = + stageImageι A (towerIdx A i₀ (ULift.down n)) ⊗ₘ + imageSubalgebraHom A i₀ := by + erw [whiskerRight_comp_tensorHom, imageColimitι_comp_hom] + rfl + ((Category.assoc _ _ _).symm.trans + ((eq_whisker (imageMul_fac A i₀ n) _).trans + (imageLeftMul_comp_hom A i₀ (ULift.down n)))).trans + ((Category.assoc _ _ _).symm.trans + (eq_whisker hh μ[A])).symm) + +/-- **The image tower is an algebra.** The laws are inherited from +the algebra: each is an equation between maps into the tower, and the +inclusion into the algebra is a monomorphism. -/ +noncomputable instance monObjImageSubalgebra + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] (A : Ind C) [MonObj A] (i₀ : A.presentation.I) + [UnitAtStage A i₀] : + MonObj (imageSubalgebra A i₀) := + haveI := mono_imageSubalgebraHom A i₀ + monObjOfMono (imageSubalgebraHom A i₀) (imageMul A i₀) + (imageOne A i₀) (imageMul_comp_hom A i₀) (imageOne_comp_hom A i₀) + +/-- The unit of the image tower, read through its algebra structure, +does not vanish when the unit of the algebra does not. -/ +theorem one_imageSubalgebra_ne_zero + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] (A : Ind C) [MonObj A] (i₀ : A.presentation.I) + [UnitAtStage A i₀] (h : η[A] ≠ 0) : + η[imageSubalgebra A i₀] ≠ 0 := + imageOne_ne_zero A i₀ h + +end ImageMul + +/-! ## Commutativity + +Over a symmetric `C` the image tower is a commutative algebra, again +because the inclusion into the algebra is a monomorphism. -/ + +section ImageComm + +variable {C : Type v} + +/-- **The image tower is a commutative algebra.** -/ +noncomputable instance isCommMonObj_imageSubalgebra + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] (A : Ind C) [MonObj A] + [IsCommMonObj A] (i₀ : A.presentation.I) [UnitAtStage A i₀] : + IsCommMonObj (imageSubalgebra A i₀) where + mul_comm := + haveI := mono_imageSubalgebraHom A i₀ + mul_comm_of_mono (imageSubalgebraHom A i₀) (imageMul A i₀) + (imageMul_comp_hom A i₀) + +end ImageComm + +/-! ## Acceptance tests + +The algebra structure synthesises at the chosen unit stage, and the +replacement it produces is a monomorphism of commutative algebras +with countably presented source and non-vanishing unit. -/ + +section AcceptanceTests + +variable {C : Type v} + +noncomputable example + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] (A : Ind C) [MonObj A] : + MonObj (imageSubalgebra A (unitStage A)) := + inferInstance + +noncomputable example + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] (A : Ind C) [MonObj A] + [IsCommMonObj A] : + IsCommMonObj (imageSubalgebra A (unitStage A)) := + inferInstance + +example + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] (A : Ind C) [MonObj A] + [IsCommMonObj A] + (hemb : IndImageEmbedded C) (h : η[A] ≠ 0) : + ∃ (B : Ind C) (_ : MonObj B) (_ : IsCommMonObj B) (f : B ⟶ A), + Mono f ∧ CountablyPresented B ∧ η[B] ≠ 0 := + ⟨imageSubalgebra A (unitStage A), inferInstance, inferInstance, + imageSubalgebraHom A (unitStage A), mono_imageSubalgebraHom _ _, + countablyPresented_imageSubalgebra _ _ hemb, + one_imageSubalgebra_ne_zero A (unitStage A) h⟩ + +end AcceptanceTests + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndAllColim.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndAllColim.lean new file mode 100644 index 0000000000..b0111ffa91 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndAllColim.lean @@ -0,0 +1,71 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCoeq +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoprodPreserve + +/-! +# The ind tensor preserves all small colimits + +Combining the finite-colimit half (`IndCoeq`), the filtered half +(`IndTensorExact`) and the preservation of coproducts from finite +and filtered (`CoprodPreserve`): tensoring on either side in the +ind-category preserves every small colimit. This is the form in +which the coend presentations of §3 pass through the tensor +product. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Limits MonoidalCategory + +universe v + +variable {C : Type v} + +instance tensorLeft_ind_preservesShapeDiscrete + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + (A : Ind C) + (α : Type v) : + PreservesColimitsOfShape (Discrete α) (tensorLeft A) := + preservesColimitsOfShape_discrete_of_finite_and_filtered + (tensorLeft A) + +instance tensorRight_ind_preservesShapeDiscrete + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + (A : Ind C) + (α : Type v) : + PreservesColimitsOfShape (Discrete α) (tensorRight A) := + preservesColimitsOfShape_discrete_of_finite_and_filtered + (tensorRight A) + +/-- **Tensoring preserves all small colimits in the +ind-category**, left-hand version. -/ +instance tensorLeft_ind_preservesColimits + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + (A : Ind C) : + PreservesColimitsOfSize.{v, v} (tensorLeft A) := + preservesColimits_of_preservesCoequalizers_and_coproducts + (tensorLeft A) + +/-- **Tensoring preserves all small colimits in the +ind-category**, right-hand version. -/ +instance tensorRight_ind_preservesColimits + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + (A : Ind C) : + PreservesColimitsOfSize.{v, v} (tensorRight A) := + preservesColimits_of_preservesCoequalizers_and_coproducts + (tensorRight A) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndBigTensorUnit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndBigTensorUnit.lean new file mode 100644 index 0000000000..9d779b16c5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndBigTensorUnit.lean @@ -0,0 +1,66 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensorUnit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndPointTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndAllColim + +/-! +# The unit of a big tensor product of ind-algebras survives + +In the ind-completion the two inputs of the general criterion are +available: the tensor of two nonzero points is nonzero, and a +point of a filtered colimit vanishes only if it already vanishes +at a later stage. So a tensor product of an arbitrary family of +algebras with nonvanishing units again has a nonvanishing unit — +the step Deligne asserts without proof in 2.11. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v + +variable {C : Type v} + +/-- The identity of the unit of the ind-completion is nonzero. -/ +theorem id_indUnit_ne_zero [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ C] + (hu : HasScalarUnit C) : + 𝟙 (𝟙_ (Ind C)) ≠ 0 := by + intro h + refine id_unit_ne_zero hu ?_ + refine (indOf_map_eq_zero_iff (𝟙 (𝟙_ C))).mp ?_ + rw [CategoryTheory.Functor.map_id] + have hconj := congrArg + (fun t => (indOfUnitIso (C := C)).inv ≫ t ≫ + (indOfUnitIso (C := C)).hom) h + simpa using hconj + +/-- **The unit of a big tensor product of ind-algebras +survives.** -/ +theorem bigTensorUnit_ne_zero_ind + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ C] [MonoidalPreadditive C] [MonoidalLinear ℂ C] + [RigidCategory C] [BraidedCategory (Ind C)] {ι : Type v} [LinearOrder ι] + (B : ι → Ind C) [∀ i, MonObj (B i)] + (hu : HasScalarUnit C) + (hB : ∀ i, MonObj.one (X := B i) ≠ 0) : + bigTensorUnit B ≠ 0 := by + refine bigTensorUnit_ne_zero B (id_indUnit_ne_zero hu) + (fun u v hu0 hv0 => indTensorHom_point_ne_zero hu hu0 hv0) + hB ?_ + intro s f hf + obtain ⟨t, α, ht⟩ := + (unit_colimit_eq_zero_iff (finTensorDiagram B) f).mp hf + exact ⟨t, leOfHom α, ht⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCoeq.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCoeq.lean new file mode 100644 index 0000000000..b869dbae1a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCoeq.lean @@ -0,0 +1,917 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndTensorExact +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorExact + +/-! +# Exactness of the tensor product on ind-objects, (co)equalizer half + +Deligne's 2.2, finite-(co)limit half: for a small rigid abelian +monoidal `C` with preadditive tensor, the transported tensor product +of `Ind C` preserves finite colimits *and* finite limits in each +variable. This closes the gap documented in +`RS.Classical.Deligne.IndTensorExact`, whose additivity results +cover the finite-(co)product halves; what remains, and is proved +here, is preservation of coequalizers and of equalizers. + +The route is a two-stage descent from the exactness of the tensor of +`C` itself (`RS.Classical.Deligne.TensorExact`): + +* *Embedded stage* (`RS.preservesColimit_parallelPair_tensorLeft_indOf` + and its limit and right-hand twins): a parallel pair of `Ind C` is + presented as a filtered colimit of parallel pairs of `C` + (Mathlib's `IndParallelPairPresentation`), i.e. the pair is + isomorphic to `parallelPair φ ψ ⋙ Ind.lim I`. Tensoring by an + embedded object commutes with `Ind.lim` up to the natural + isomorphism `RS.indLimCompTensorLeftIso`, built from + `RS.indOfTensorIso` and its naturality; on the functor category + side the whiskered `tensorLeft a` preserves (co)equalizers + pointwise because `tensorLeft a` preserves all (co)limits in the + rigid `C`, and `Ind.lim` preserves finite limits and colimits. + Preservation transports along the presentation. +* *Descent stage* (`RS.isIso_post_parallelPair_tensorLeft`, + `RS.isIso_limitPost_parallelPair_tensorLeft` and twins): for a + fixed parallel pair, the (co)limit comparison of `tensorLeft A` is + natural in the tensoring object `A` + (`RS.whiskerLeftCoeqComparison`/`RS.whiskerLeftEqComparison`), + between endofunctor-composites that preserve filtered colimits. + The filtered-descent lemma `RS.isIso_app_of_isIso_indOf` of + `IndTensorExact` then propagates invertibility from the embedded + stage to every `A : Ind C`. For coequalizers the required + filtered preservation of `colim`-composites is formal; for + equalizers it is the exactness of filtered colimits in `Ind C`, + derived here as `RS.preservesColimitsOfShape_parallelPairLim_ind` + from the type-level commutation of filtered colimits with finite + limits through the interchange transpose + `RS.preservesColimitsOfShape_lim` and the inclusion into + presheaves. + +Deliverables, for every `A : Ind C`: + +* `RS.tensorLeft_ind_preservesCoequalizers` / + `RS.tensorRight_ind_preservesCoequalizers` and + `RS.tensorLeft_ind_preservesEqualizers` / + `RS.tensorRight_ind_preservesEqualizers` — preservation of + `WalkingParallelPair` colimits and limits for both tensoring + functors; +* `RS.tensorLeft_ind_preservesFiniteColimits` / + `RS.tensorRight_ind_preservesFiniteColimits` — **the tensor of + `Ind C` is right exact in each variable**; +* `RS.tensorLeft_ind_preservesFiniteLimits` / + `RS.tensorRight_ind_preservesFiniteLimits` — **and left exact**, + combining with the additivity of `IndTensorExact`. + +The acceptance tests confirm that the cokernel and kernel comparison +isomorphisms of both tensoring functors synthesize. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v + +noncomputable section + +section CompositeDiagram + +universe w₁ w₂ w₃ w₄ w₅ w₆ w₇ w₈ w₉ w₁₀ + +variable {J : Type w₁} + +/-- Preservation of the colimit of a composed diagram `K ⋙ F` by +`T`, given that `F` preserves the colimit of `K` and the composite +functor `F ⋙ T` does: the colimit cocone of `K ⋙ F` may be taken to +be the image under `F` of the colimit cocone of `K`. -/ +lemma preservesColimit_comp_diagram + [Category.{w₂} J] {𝒜 : Type w₃} [Category.{w₄} 𝒜] {ℬ : Type w₅} + [Category.{w₆} ℬ] {𝒞 : Type w₇} [Category.{w₈} 𝒞] + (K : J ⥤ 𝒜) (F : 𝒜 ⥤ ℬ) + (T : ℬ ⥤ 𝒞) [HasColimit K] [PreservesColimit K F] + [PreservesColimit K (F ⋙ T)] : PreservesColimit (K ⋙ F) T := + preservesColimit_of_preserves_colimit_cocone + (isColimitOfPreserves F (colimit.isColimit K)) + (isColimitOfPreserves (F ⋙ T) (colimit.isColimit K)) + +/-- Dual of `RS.preservesColimit_comp_diagram`. -/ +lemma preservesLimit_comp_diagram + [Category.{w₂} J] {𝒜 : Type w₃} [Category.{w₄} 𝒜] {ℬ : Type w₅} + [Category.{w₆} ℬ] {𝒞 : Type w₇} [Category.{w₈} 𝒞] + (K : J ⥤ 𝒜) (F : 𝒜 ⥤ ℬ) + (T : ℬ ⥤ 𝒞) [HasLimit K] [PreservesLimit K F] + [PreservesLimit K (F ⋙ T)] : PreservesLimit (K ⋙ F) T := + preservesLimit_of_preserves_limit_cone + (isLimitOfPreserves F (limit.isLimit K)) + (isLimitOfPreserves (F ⋙ T) (limit.isLimit K)) + +end CompositeDiagram + +section InterchangeBridge + +universe x₁ x₂ x₃ x₄ x₅ x₆ + +variable {J : Type x₁} + +/-- Transpose of the interchange property, flipped-diagram form: if +`K`-indexed colimits preserve `J`-limits, the `J`-limit functor +preserves the colimit of `G.flip` for any bifunctor `G`. The +colimit comparison is identified with the canonical interchange +isomorphism `Limits.colimitLimitIso`. -/ +lemma preservesColimit_flip_lim + [Category.{x₂} J] {K : Type x₃} [Category.{x₄} K] {𝒟 : Type x₅} + [Category.{x₆} 𝒟] [HasLimitsOfShape J 𝒟] [HasColimitsOfShape K 𝒟] + [PreservesLimitsOfShape J (colim : (K ⥤ 𝒟) ⥤ 𝒟)] + (G : J ⥤ K ⥤ 𝒟) : + PreservesColimit G.flip (lim : (J ⥤ 𝒟) ⥤ 𝒟) := by + have key : colimit.post G.flip lim = + (HasColimit.isoOfNatIso (limitIsoFlipCompLim G).symm).hom ≫ + (colimitLimitIso G).hom := by + apply colimit.hom_ext + intro a + apply limit.hom_ext + intro b + have hL : + (colimit.ι (G.flip ⋙ lim) a ≫ colimit.post G.flip lim) ≫ + limit.π (colimit G.flip) b = + limit.π (G.flip.obj a) b ≫ (colimit.ι G.flip a).app b := + (congrArg (fun t => t ≫ limit.π (colimit G.flip) b) + (colimit.ι_post G.flip lim a)).trans + (limMap_π (colimit.ι G.flip a) b) + have hR : + (colimit.ι (G.flip ⋙ lim) a ≫ + (HasColimit.isoOfNatIso (limitIsoFlipCompLim G).symm).hom ≫ + (colimitLimitIso G).hom) ≫ limit.π (colimit G.flip) b = + limit.π (G.flip.obj a) b ≫ + (colimit.ι G.flip a).app b := by + refine (Category.assoc _ _ _).trans ?_ + refine (congrArg (fun t => colimit.ι (G.flip ⋙ lim) a ≫ t) + (Category.assoc _ _ _)).trans ?_ + refine (HasColimit.ι_isoOfNatIso_hom_assoc + (limitIsoFlipCompLim G).symm a _).trans ?_ + refine (congrArg + (fun t => (limitIsoFlipCompLim G).symm.hom.app a ≫ t) + (ι_colimitLimitIso_limit_π G a b)).trans ?_ + refine (Category.assoc _ _ _).symm.trans ?_ + apply congrArg (fun t => t ≫ (colimit.ι G.flip a).app b) + simp [limitIsoFlipCompLim, Category.assoc] + exact hL.trans hR.symm + have : IsIso (colimit.post G.flip lim) := by + rw [key] + exact IsIso.comp_isIso + exact preservesColimit_of_isIso_post _ _ + +/-- Transpose of the interchange property: if `K`-indexed colimits +preserve `J`-limits, then the `J`-limit functor preserves +`K`-colimits. -/ +lemma preservesColimitsOfShape_lim + [Category.{x₂} J] {K : Type x₃} [Category.{x₄} K] {𝒟 : Type x₅} + [Category.{x₆} 𝒟] [HasLimitsOfShape J 𝒟] [HasColimitsOfShape K 𝒟] + [PreservesLimitsOfShape J (colim : (K ⥤ 𝒟) ⥤ 𝒟)] : + PreservesColimitsOfShape K (lim : (J ⥤ 𝒟) ⥤ 𝒟) where + preservesColimit {D} := preservesColimit_flip_lim D.flip + +end InterchangeBridge + +variable {C : Type v} + +section IndLimTensor + +/-- The embedding-tensor comparison as a natural isomorphism, left +version: composing the embedding with left tensoring by an embedded +object is left tensoring in `C` followed by the embedding. -/ +def indOfCompTensorLeftIso [SmallCategory C] [MonoidalCategory C] + (a : C) : + indOf ⋙ tensorLeft (indOf.obj a) ≅ + tensorLeft a ⋙ (indOf : C ⥤ Ind C) := + NatIso.ofComponents (fun x => indOfTensorIso a x) + (fun {_ _} g => indOfTensorIso_hom_natural_right a g) + +/-- The embedding-tensor comparison as a natural isomorphism, right +version. -/ +def indOfCompTensorRightIso [SmallCategory C] [MonoidalCategory C] + (a : C) : + indOf ⋙ tensorRight (indOf.obj a) ≅ + tensorRight a ⋙ (indOf : C ⥤ Ind C) := + NatIso.ofComponents (fun x => indOfTensorIso x a) + (fun {_ _} g => indOfTensorIso_hom_natural_left g a) + +/-- Left tensoring by an embedded object commutes with `Ind.lim`: +the composite `Ind.lim I ⋙ tensorLeft (indOf.obj a)` is the +whiskering of `tensorLeft a` followed by `Ind.lim I`. The chain +mirrors Mathlib's `Ind.limCompInclusion`, with the embedded-tensor +isomorphism in place of `Ind.yonedaCompInclusion`. -/ +def indLimCompTensorLeftIso [SmallCategory C] [MonoidalCategory C] + (a : C) (I : Type v) [SmallCategory I] + [IsFiltered I] : + Ind.lim I ⋙ tensorLeft (indOf.obj a) ≅ + (Functor.whiskeringRight I C C).obj (tensorLeft a) ⋙ + Ind.lim I := calc + Ind.lim I ⋙ tensorLeft (indOf.obj a) + ≅ (Functor.whiskeringRight I C (Ind C)).obj indOf ⋙ + (colim ⋙ tensorLeft (indOf.obj a)) := + Functor.associator _ _ _ + _ ≅ (Functor.whiskeringRight I C (Ind C)).obj indOf ⋙ + ((Functor.whiskeringRight I (Ind C) (Ind C)).obj + (tensorLeft (indOf.obj a)) ⋙ colim) := + Functor.isoWhiskerLeft _ (preservesColimitNatIso _) + _ ≅ ((Functor.whiskeringRight I C (Ind C)).obj indOf ⋙ + (Functor.whiskeringRight I (Ind C) (Ind C)).obj + (tensorLeft (indOf.obj a))) ⋙ colim := + (Functor.associator _ _ _).symm + _ ≅ (Functor.whiskeringRight I C (Ind C)).obj + (indOf ⋙ tensorLeft (indOf.obj a)) ⋙ colim := + Functor.isoWhiskerRight + (Functor.whiskeringRightObjCompIso _ _) colim + _ ≅ (Functor.whiskeringRight I C (Ind C)).obj + (tensorLeft a ⋙ indOf) ⋙ colim := + Functor.isoWhiskerRight + ((Functor.whiskeringRight I C (Ind C)).mapIso + (indOfCompTensorLeftIso a)) colim + _ ≅ ((Functor.whiskeringRight I C C).obj (tensorLeft a) ⋙ + (Functor.whiskeringRight I C (Ind C)).obj indOf) ⋙ colim := + Functor.isoWhiskerRight + (Functor.whiskeringRightObjCompIso _ _).symm colim + _ ≅ (Functor.whiskeringRight I C C).obj (tensorLeft a) ⋙ + Ind.lim I := + Functor.associator _ _ _ + +/-- Right tensoring by an embedded object commutes with +`Ind.lim`. -/ +def indLimCompTensorRightIso [SmallCategory C] [MonoidalCategory C] + (a : C) (I : Type v) [SmallCategory I] + [IsFiltered I] : + Ind.lim I ⋙ tensorRight (indOf.obj a) ≅ + (Functor.whiskeringRight I C C).obj (tensorRight a) ⋙ + Ind.lim I := calc + Ind.lim I ⋙ tensorRight (indOf.obj a) + ≅ (Functor.whiskeringRight I C (Ind C)).obj indOf ⋙ + (colim ⋙ tensorRight (indOf.obj a)) := + Functor.associator _ _ _ + _ ≅ (Functor.whiskeringRight I C (Ind C)).obj indOf ⋙ + ((Functor.whiskeringRight I (Ind C) (Ind C)).obj + (tensorRight (indOf.obj a)) ⋙ colim) := + Functor.isoWhiskerLeft _ (preservesColimitNatIso _) + _ ≅ ((Functor.whiskeringRight I C (Ind C)).obj indOf ⋙ + (Functor.whiskeringRight I (Ind C) (Ind C)).obj + (tensorRight (indOf.obj a))) ⋙ colim := + (Functor.associator _ _ _).symm + _ ≅ (Functor.whiskeringRight I C (Ind C)).obj + (indOf ⋙ tensorRight (indOf.obj a)) ⋙ colim := + Functor.isoWhiskerRight + (Functor.whiskeringRightObjCompIso _ _) colim + _ ≅ (Functor.whiskeringRight I C (Ind C)).obj + (tensorRight a ⋙ indOf) ⋙ colim := + Functor.isoWhiskerRight + ((Functor.whiskeringRight I C (Ind C)).mapIso + (indOfCompTensorRightIso a)) colim + _ ≅ ((Functor.whiskeringRight I C C).obj (tensorRight a) ⋙ + (Functor.whiskeringRight I C (Ind C)).obj indOf) ⋙ colim := + Functor.isoWhiskerRight + (Functor.whiskeringRightObjCompIso _ _).symm colim + _ ≅ (Functor.whiskeringRight I C C).obj (tensorRight a) ⋙ + Ind.lim I := + Functor.associator _ _ _ + +end IndLimTensor + +section EmbeddedBase + +/-- Embedded stage, left version: left tensoring by an embedded +object preserves the colimit of every parallel pair of `Ind C`. The +pair is presented as a filtered colimit of parallel pairs of `C`; +tensoring commutes with the presentation by +`RS.indLimCompTensorLeftIso`, and on the functor-category side the +whiskered `tensorLeft a` preserves coequalizers pointwise since the +tensor of the rigid `C` is exact. -/ +lemma preservesColimit_parallelPair_tensorLeft_indOf + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + (a : C) + {X Y : Ind C} (f g : X ⟶ Y) : + PreservesColimit (parallelPair f g) (tensorLeft (indOf.obj a)) := by + obtain ⟨P⟩ := nonempty_indParallelPairPresentation + (Ind.isIndObject_inclusion_obj X) (Ind.isIndObject_inclusion_obj Y) + ((Ind.inclusion C).map f) ((Ind.inclusion C).map g) + have : PreservesColimitsOfSize.{0, 0} (tensorLeft a) := + preservesSmallestColimits_of_preservesColimits _ + have : PreservesColimit (parallelPair P.φ P.ψ) + (Ind.lim P.I ⋙ tensorLeft (indOf.obj a)) := + preservesColimit_of_natIso _ (indLimCompTensorLeftIso a P.I).symm + have : PreservesColimit (parallelPair P.φ P.ψ ⋙ Ind.lim P.I) + (tensorLeft (indOf.obj a)) := + preservesColimit_comp_diagram _ _ _ + exact preservesColimit_of_iso_diagram _ + P.parallelPairIsoParallelPairCompIndYoneda.symm + +/-- Embedded stage for limits, left version: left tensoring by an +embedded object preserves the limit of every parallel pair of +`Ind C` — the dual of the coequalizer argument, using that +`Ind.lim` preserves finite limits and that the tensor of the rigid +`C` is left exact. -/ +lemma preservesLimit_parallelPair_tensorLeft_indOf + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + (a : C) + {X Y : Ind C} (f g : X ⟶ Y) : + PreservesLimit (parallelPair f g) (tensorLeft (indOf.obj a)) := by + obtain ⟨P⟩ := nonempty_indParallelPairPresentation + (Ind.isIndObject_inclusion_obj X) (Ind.isIndObject_inclusion_obj Y) + ((Ind.inclusion C).map f) ((Ind.inclusion C).map g) + have : PreservesLimitsOfSize.{0, 0} (tensorLeft a) := + preservesSmallestLimits_of_preservesLimits _ + have : PreservesLimit (parallelPair P.φ P.ψ) + (Ind.lim P.I ⋙ tensorLeft (indOf.obj a)) := + preservesLimit_of_natIso _ (indLimCompTensorLeftIso a P.I).symm + have : PreservesLimit (parallelPair P.φ P.ψ ⋙ Ind.lim P.I) + (tensorLeft (indOf.obj a)) := + preservesLimit_comp_diagram _ _ _ + exact preservesLimit_of_iso_diagram _ + P.parallelPairIsoParallelPairCompIndYoneda.symm + +/-- Embedded stage for limits, right version. -/ +lemma preservesLimit_parallelPair_tensorRight_indOf + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + (a : C) + {X Y : Ind C} (f g : X ⟶ Y) : + PreservesLimit (parallelPair f g) (tensorRight (indOf.obj a)) := by + obtain ⟨P⟩ := nonempty_indParallelPairPresentation + (Ind.isIndObject_inclusion_obj X) (Ind.isIndObject_inclusion_obj Y) + ((Ind.inclusion C).map f) ((Ind.inclusion C).map g) + have : PreservesLimitsOfSize.{0, 0} (tensorRight a) := + preservesSmallestLimits_of_preservesLimits _ + have : PreservesLimit (parallelPair P.φ P.ψ) + (Ind.lim P.I ⋙ tensorRight (indOf.obj a)) := + preservesLimit_of_natIso _ (indLimCompTensorRightIso a P.I).symm + have : PreservesLimit (parallelPair P.φ P.ψ ⋙ Ind.lim P.I) + (tensorRight (indOf.obj a)) := + preservesLimit_comp_diagram _ _ _ + exact preservesLimit_of_iso_diagram _ + P.parallelPairIsoParallelPairCompIndYoneda.symm + +/-- Embedded stage, right version. -/ +lemma preservesColimit_parallelPair_tensorRight_indOf + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + (a : C) + {X Y : Ind C} (f g : X ⟶ Y) : + PreservesColimit (parallelPair f g) (tensorRight (indOf.obj a)) := by + obtain ⟨P⟩ := nonempty_indParallelPairPresentation + (Ind.isIndObject_inclusion_obj X) (Ind.isIndObject_inclusion_obj Y) + ((Ind.inclusion C).map f) ((Ind.inclusion C).map g) + have : PreservesColimitsOfSize.{0, 0} (tensorRight a) := + preservesSmallestColimits_of_preservesColimits _ + have : PreservesColimit (parallelPair P.φ P.ψ) + (Ind.lim P.I ⋙ tensorRight (indOf.obj a)) := + preservesColimit_of_natIso _ (indLimCompTensorRightIso a P.I).symm + have : PreservesColimit (parallelPair P.φ P.ψ ⋙ Ind.lim P.I) + (tensorRight (indOf.obj a)) := + preservesColimit_comp_diagram _ _ _ + exact preservesColimit_of_iso_diagram _ + P.parallelPairIsoParallelPairCompIndYoneda.symm + +end EmbeddedBase + +section CoequalizerDescent + +/-- The parallel pair `(A ◁ f, A ◁ g)` as a functor of the tensoring +object `A`. The `@[reducible]` marking is deliberate: the object +field must reduce at instance transparency for the `show`-retyped +colimit proofs below to be stateable. -/ +@[reducible] +def whiskerLeftPairFunctor + [SmallCategory C] [MonoidalCategory C] {X : Ind C} {Y : Ind C} + (f g : X ⟶ Y) : + Ind C ⥤ WalkingParallelPair ⥤ Ind C where + obj A := parallelPair f g ⋙ tensorLeft A + map {A B} u := + { app := fun k => u ▷ (parallelPair f g).obj k + naturality := fun _ _ h => + whisker_exchange u ((parallelPair f g).map h) } + map_id A := by + ext k + exact MonoidalCategory.id_whiskerRight A ((parallelPair f g).obj k) + map_comp {A B D} u v := by + ext k + exact MonoidalCategory.comp_whiskerRight u v + ((parallelPair f g).obj k) + +/-- The parallel pair `(f ▷ A, g ▷ A)` as a functor of the tensoring +object `A`. -/ +@[reducible] +def whiskerRightPairFunctor + [SmallCategory C] [MonoidalCategory C] {X : Ind C} {Y : Ind C} + (f g : X ⟶ Y) : + Ind C ⥤ WalkingParallelPair ⥤ Ind C where + obj A := parallelPair f g ⋙ tensorRight A + map {A B} u := + { app := fun k => (parallelPair f g).obj k ◁ u + naturality := fun _ _ h => + (whisker_exchange ((parallelPair f g).map h) u).symm } + map_id A := by + ext k + exact MonoidalCategory.whiskerLeft_id ((parallelPair f g).obj k) A + map_comp {A B D} u v := by + ext k + exact MonoidalCategory.whiskerLeft_comp + ((parallelPair f g).obj k) u v + +/-- Evaluating `RS.whiskerLeftPairFunctor` at a stage of the walking +parallel pair gives right tensoring by the corresponding object. -/ +def whiskerLeftPairFunctorEvalIso + [SmallCategory C] [MonoidalCategory C] {X : Ind C} {Y : Ind C} + (f g : X ⟶ Y) + (k : WalkingParallelPair) : + whiskerLeftPairFunctor f g ⋙ (evaluation _ _).obj k ≅ + tensorRight ((parallelPair f g).obj k) := + NatIso.ofComponents (fun _ => Iso.refl _) + (fun u => by + change u ▷ (parallelPair f g).obj k ≫ 𝟙 _ = + 𝟙 _ ≫ u ▷ (parallelPair f g).obj k + rw [Category.comp_id, Category.id_comp]) + +/-- Evaluating `RS.whiskerRightPairFunctor` at a stage gives left +tensoring by the corresponding object. -/ +def whiskerRightPairFunctorEvalIso + [SmallCategory C] [MonoidalCategory C] {X : Ind C} {Y : Ind C} + (f g : X ⟶ Y) + (k : WalkingParallelPair) : + whiskerRightPairFunctor f g ⋙ (evaluation _ _).obj k ≅ + tensorLeft ((parallelPair f g).obj k) := + NatIso.ofComponents (fun _ => Iso.refl _) + (fun u => by + change (parallelPair f g).obj k ◁ u ≫ 𝟙 _ = + 𝟙 _ ≫ (parallelPair f g).obj k ◁ u + rw [Category.comp_id, Category.id_comp]) + +/-- The pair functor preserves filtered colimits, pointwise. -/ +lemma preservesFilteredColimits_whiskerLeftPairFunctor + [SmallCategory C] [MonoidalCategory C] {X : Ind C} {Y : Ind C} + (f g : X ⟶ Y) : + PreservesFilteredColimits (whiskerLeftPairFunctor f g) where + preserves_filtered_colimits _ _ _ := + preservesColimitsOfShape_of_evaluation _ _ fun k => + preservesColimitsOfShape_of_natIso + (whiskerLeftPairFunctorEvalIso f g k).symm + +/-- The right-hand pair functor preserves filtered colimits. -/ +lemma preservesFilteredColimits_whiskerRightPairFunctor + [SmallCategory C] [MonoidalCategory C] {X : Ind C} {Y : Ind C} + (f g : X ⟶ Y) : + PreservesFilteredColimits (whiskerRightPairFunctor f g) where + preserves_filtered_colimits _ _ _ := + preservesColimitsOfShape_of_evaluation _ _ fun k => + preservesColimitsOfShape_of_natIso + (whiskerRightPairFunctorEvalIso f g k).symm + +/-- The coequalizer comparison for left tensoring, naturally in the +tensoring object: at `A` it is the canonical morphism from the +colimit of the pair `(A ◁ f, A ◁ g)` to `A ⊗ coeq (f, g)`. -/ +def whiskerLeftCoeqComparison + [SmallCategory C] [MonoidalCategory C] [Abelian C] {X : Ind C} + {Y : Ind C} + (f g : X ⟶ Y) : + whiskerLeftPairFunctor f g ⋙ colim ⟶ + tensorRight (colimit (parallelPair f g)) where + app A := colimit.post (parallelPair f g) (tensorLeft A) + naturality {A B} u := by + change colimMap ((whiskerLeftPairFunctor f g).map u) ≫ + colimit.post (parallelPair f g) (tensorLeft B) = + colimit.post (parallelPair f g) (tensorLeft A) ≫ + u ▷ colimit (parallelPair f g) + apply colimit.hom_ext + intro k + rw [ι_colimMap_assoc] + change ((whiskerLeftPairFunctor f g).map u).app k ≫ + colimit.ι (parallelPair f g ⋙ tensorLeft B) k ≫ + colimit.post (parallelPair f g) (tensorLeft B) = + colimit.ι (parallelPair f g ⋙ tensorLeft A) k ≫ + colimit.post (parallelPair f g) (tensorLeft A) ≫ + u ▷ colimit (parallelPair f g) + rw [colimit.ι_post, colimit.ι_post_assoc] + change u ▷ (parallelPair f g).obj k ≫ + (B ◁ colimit.ι (parallelPair f g) k) = + (A ◁ colimit.ι (parallelPair f g) k) ≫ + u ▷ colimit (parallelPair f g) + exact (whisker_exchange u (colimit.ι (parallelPair f g) k)).symm + +/-- The coequalizer comparison for right tensoring, naturally in the +tensoring object. -/ +def whiskerRightCoeqComparison + [SmallCategory C] [MonoidalCategory C] [Abelian C] {X : Ind C} + {Y : Ind C} + (f g : X ⟶ Y) : + whiskerRightPairFunctor f g ⋙ colim ⟶ + tensorLeft (colimit (parallelPair f g)) where + app A := colimit.post (parallelPair f g) (tensorRight A) + naturality {A B} u := by + change colimMap ((whiskerRightPairFunctor f g).map u) ≫ + colimit.post (parallelPair f g) (tensorRight B) = + colimit.post (parallelPair f g) (tensorRight A) ≫ + colimit (parallelPair f g) ◁ u + apply colimit.hom_ext + intro k + rw [ι_colimMap_assoc] + change ((whiskerRightPairFunctor f g).map u).app k ≫ + colimit.ι (parallelPair f g ⋙ tensorRight B) k ≫ + colimit.post (parallelPair f g) (tensorRight B) = + colimit.ι (parallelPair f g ⋙ tensorRight A) k ≫ + colimit.post (parallelPair f g) (tensorRight A) ≫ + colimit (parallelPair f g) ◁ u + rw [colimit.ι_post, colimit.ι_post_assoc] + change (parallelPair f g).obj k ◁ u ≫ + (colimit.ι (parallelPair f g) k ▷ B) = + (colimit.ι (parallelPair f g) k ▷ A) ≫ + colimit (parallelPair f g) ◁ u + exact whisker_exchange (colimit.ι (parallelPair f g) k) u + +/-- Descent stage, left version: the colimit comparison of any +parallel pair under left tensoring is invertible, for every +tensoring ind-object. Filtered descent from the embedded stage. -/ +lemma isIso_post_parallelPair_tensorLeft + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + {X : Ind C} {Y : Ind C} + (A : Ind C) (f g : X ⟶ Y) : + IsIso (colimit.post (parallelPair f g) (tensorLeft A)) := by + have : PreservesFilteredColimits (whiskerLeftPairFunctor f g) := + preservesFilteredColimits_whiskerLeftPairFunctor f g + have : PreservesColimitsOfSize.{v, v} + (colim : (WalkingParallelPair ⥤ Ind C) ⥤ Ind C) := + colimConstAdj.leftAdjoint_preservesColimits + have : PreservesFilteredColimits + (whiskerLeftPairFunctor f g ⋙ colim) := + ⟨fun _ _ _ => inferInstance⟩ + have h := isIso_app_of_isIso_indOf (whiskerLeftCoeqComparison f g) + (fun c => by + have := preservesColimit_parallelPair_tensorLeft_indOf c f g + exact inferInstanceAs (IsIso (colimit.post (parallelPair f g) + (tensorLeft (indOf.obj c))))) A + exact h + +/-- Descent stage, right version. -/ +lemma isIso_post_parallelPair_tensorRight + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + {X : Ind C} {Y : Ind C} + (A : Ind C) (f g : X ⟶ Y) : + IsIso (colimit.post (parallelPair f g) (tensorRight A)) := by + have : PreservesFilteredColimits (whiskerRightPairFunctor f g) := + preservesFilteredColimits_whiskerRightPairFunctor f g + have : PreservesColimitsOfSize.{v, v} + (colim : (WalkingParallelPair ⥤ Ind C) ⥤ Ind C) := + colimConstAdj.leftAdjoint_preservesColimits + have : PreservesFilteredColimits + (whiskerRightPairFunctor f g ⋙ colim) := + ⟨fun _ _ _ => inferInstance⟩ + have h := isIso_app_of_isIso_indOf (whiskerRightCoeqComparison f g) + (fun c => by + have := preservesColimit_parallelPair_tensorRight_indOf c f g + exact inferInstanceAs (IsIso (colimit.post (parallelPair f g) + (tensorRight (indOf.obj c))))) A + exact h + +end CoequalizerDescent + +section Coequalizers + +/-- **Left tensoring on `Ind C` preserves coequalizers.** -/ +instance tensorLeft_ind_preservesCoequalizers + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + (A : Ind C) : + PreservesColimitsOfShape WalkingParallelPair (tensorLeft A) where + preservesColimit {K} := by + have := isIso_post_parallelPair_tensorLeft A + (K.map WalkingParallelPairHom.left) + (K.map WalkingParallelPairHom.right) + have : PreservesColimit + (parallelPair (K.map WalkingParallelPairHom.left) + (K.map WalkingParallelPairHom.right)) (tensorLeft A) := + preservesColimit_of_isIso_post _ _ + exact preservesColimit_of_iso_diagram _ + (diagramIsoParallelPair K).symm + +/-- **Right tensoring on `Ind C` preserves coequalizers.** -/ +instance tensorRight_ind_preservesCoequalizers + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + (A : Ind C) : + PreservesColimitsOfShape WalkingParallelPair (tensorRight A) where + preservesColimit {K} := by + have := isIso_post_parallelPair_tensorRight A + (K.map WalkingParallelPairHom.left) + (K.map WalkingParallelPairHom.right) + have : PreservesColimit + (parallelPair (K.map WalkingParallelPairHom.left) + (K.map WalkingParallelPairHom.right)) (tensorRight A) := + preservesColimit_of_isIso_post _ _ + exact preservesColimit_of_iso_diagram _ + (diagramIsoParallelPair K).symm + +end Coequalizers + +section EqualizerDescent + +/-- Filtered colimits commute with `WalkingParallelPair`-limits in +`Ind C`: the parallel-pair limit functor preserves filtered +colimits. The property holds for types, lifts to presheaves +pointwise, transposes through `RS.preservesColimitsOfShape_lim`, +and transports to `Ind C` along the inclusion, which creates the +limits and preserves the filtered colimits involved. -/ +lemma preservesColimitsOfShape_parallelPairLim_ind [SmallCategory C] [Abelian C] + (I : Type v) [SmallCategory I] [IsFiltered I] : + PreservesColimitsOfShape I + (lim : (WalkingParallelPair ⥤ Ind C) ⥤ Ind C) := by + have hlim : PreservesColimitsOfShape I + (lim : (WalkingParallelPair ⥤ (Cᵒᵖ ⥤ Type v)) ⥤ _) := + preservesColimitsOfShape_lim + have h₁ : PreservesColimitsOfShape I + ((lim : (WalkingParallelPair ⥤ Ind C) ⥤ Ind C) ⋙ + Ind.inclusion C) := by + exact preservesColimitsOfShape_of_natIso + (preservesLimitNatIso (Ind.inclusion C)).symm + exact preservesColimitsOfShape_of_reflects_of_preserves _ + (Ind.inclusion C) + +/-- The equalizer comparison for left tensoring, naturally in the +tensoring object: at `A` it is the canonical morphism from +`A ⊗ lim (f, g)` to the limit of the pair `(A ◁ f, A ◁ g)`. -/ +def whiskerLeftEqComparison + [SmallCategory C] [MonoidalCategory C] [Abelian C] {X : Ind C} + {Y : Ind C} + (f g : X ⟶ Y) : + tensorRight (limit (parallelPair f g)) ⟶ + whiskerLeftPairFunctor f g ⋙ lim where + app A := limit.post (parallelPair f g) (tensorLeft A) + naturality {A B} u := by + apply limit.hom_ext + intro k + have hL : + ((u ▷ limit (parallelPair f g)) ≫ + limit.post (parallelPair f g) (tensorLeft B)) ≫ + limit.π (parallelPair f g ⋙ tensorLeft B) k = + (A ◁ limit.π (parallelPair f g) k) ≫ + u ▷ (parallelPair f g).obj k := by + refine (Category.assoc _ _ _).trans ?_ + refine (congrArg (fun t => (u ▷ limit (parallelPair f g)) ≫ t) + (limit.post_π (parallelPair f g) (tensorLeft B) k)).trans ?_ + exact (whisker_exchange u (limit.π (parallelPair f g) k)).symm + have hR : + (limit.post (parallelPair f g) (tensorLeft A) ≫ + limMap ((whiskerLeftPairFunctor f g).map u)) ≫ + limit.π (parallelPair f g ⋙ tensorLeft B) k = + (A ◁ limit.π (parallelPair f g) k) ≫ + u ▷ (parallelPair f g).obj k := by + refine (Category.assoc _ _ _).trans ?_ + refine (congrArg + (fun t => limit.post (parallelPair f g) (tensorLeft A) ≫ t) + (limMap_π ((whiskerLeftPairFunctor f g).map u) k)).trans ?_ + refine (Category.assoc _ _ _).symm.trans ?_ + exact congrArg + (fun t => t ≫ ((whiskerLeftPairFunctor f g).map u).app k) + (limit.post_π (parallelPair f g) (tensorLeft A) k) + exact hL.trans hR.symm + +/-- The equalizer comparison for right tensoring, naturally in the +tensoring object. -/ +def whiskerRightEqComparison + [SmallCategory C] [MonoidalCategory C] [Abelian C] {X : Ind C} + {Y : Ind C} + (f g : X ⟶ Y) : + tensorLeft (limit (parallelPair f g)) ⟶ + whiskerRightPairFunctor f g ⋙ lim where + app A := limit.post (parallelPair f g) (tensorRight A) + naturality {A B} u := by + apply limit.hom_ext + intro k + have hL : + ((limit (parallelPair f g) ◁ u) ≫ + limit.post (parallelPair f g) (tensorRight B)) ≫ + limit.π (parallelPair f g ⋙ tensorRight B) k = + (limit.π (parallelPair f g) k ▷ A) ≫ + (parallelPair f g).obj k ◁ u := by + refine (Category.assoc _ _ _).trans ?_ + refine (congrArg (fun t => (limit (parallelPair f g) ◁ u) ≫ t) + (limit.post_π (parallelPair f g) (tensorRight B) k)).trans ?_ + exact whisker_exchange (limit.π (parallelPair f g) k) u + have hR : + (limit.post (parallelPair f g) (tensorRight A) ≫ + limMap ((whiskerRightPairFunctor f g).map u)) ≫ + limit.π (parallelPair f g ⋙ tensorRight B) k = + (limit.π (parallelPair f g) k ▷ A) ≫ + (parallelPair f g).obj k ◁ u := by + refine (Category.assoc _ _ _).trans ?_ + refine (congrArg + (fun t => limit.post (parallelPair f g) (tensorRight A) ≫ t) + (limMap_π ((whiskerRightPairFunctor f g).map u) k)).trans ?_ + refine (Category.assoc _ _ _).symm.trans ?_ + exact congrArg + (fun t => t ≫ ((whiskerRightPairFunctor f g).map u).app k) + (limit.post_π (parallelPair f g) (tensorRight A) k) + exact hL.trans hR.symm + +/-- Descent stage for limits, left version: the limit comparison of +any parallel pair under left tensoring is invertible, for every +tensoring ind-object. -/ +lemma isIso_limitPost_parallelPair_tensorLeft + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + {X : Ind C} {Y : Ind C} + (A : Ind C) + (f g : X ⟶ Y) : + IsIso (limit.post (parallelPair f g) (tensorLeft A)) := by + have : PreservesFilteredColimits (whiskerLeftPairFunctor f g) := + preservesFilteredColimits_whiskerLeftPairFunctor f g + have : PreservesFilteredColimits + (whiskerLeftPairFunctor f g ⋙ lim) := + ⟨fun I _ _ => by + have := preservesColimitsOfShape_parallelPairLim_ind (C := C) I + infer_instance⟩ + have h := isIso_app_of_isIso_indOf (whiskerLeftEqComparison f g) + (fun c => by + have := preservesLimit_parallelPair_tensorLeft_indOf c f g + exact inferInstanceAs (IsIso (limit.post (parallelPair f g) + (tensorLeft (indOf.obj c))))) A + exact h + +/-- Descent stage for limits, right version. -/ +lemma isIso_limitPost_parallelPair_tensorRight + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + {X : Ind C} {Y : Ind C} + (A : Ind C) + (f g : X ⟶ Y) : + IsIso (limit.post (parallelPair f g) (tensorRight A)) := by + have : PreservesFilteredColimits (whiskerRightPairFunctor f g) := + preservesFilteredColimits_whiskerRightPairFunctor f g + have : PreservesFilteredColimits + (whiskerRightPairFunctor f g ⋙ lim) := + ⟨fun I _ _ => by + have := preservesColimitsOfShape_parallelPairLim_ind (C := C) I + infer_instance⟩ + have h := isIso_app_of_isIso_indOf (whiskerRightEqComparison f g) + (fun c => by + have := preservesLimit_parallelPair_tensorRight_indOf c f g + exact inferInstanceAs (IsIso (limit.post (parallelPair f g) + (tensorRight (indOf.obj c))))) A + exact h + +end EqualizerDescent + +section Equalizers + +/-- **Left tensoring on `Ind C` preserves equalizers.** -/ +instance tensorLeft_ind_preservesEqualizers + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + (A : Ind C) : + PreservesLimitsOfShape WalkingParallelPair (tensorLeft A) where + preservesLimit {K} := by + have := isIso_limitPost_parallelPair_tensorLeft A + (K.map WalkingParallelPairHom.left) + (K.map WalkingParallelPairHom.right) + have : PreservesLimit + (parallelPair (K.map WalkingParallelPairHom.left) + (K.map WalkingParallelPairHom.right)) (tensorLeft A) := + preservesLimit_of_isIso_post _ _ + exact preservesLimit_of_iso_diagram _ + (diagramIsoParallelPair K).symm + +/-- **Right tensoring on `Ind C` preserves equalizers.** -/ +instance tensorRight_ind_preservesEqualizers + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + (A : Ind C) : + PreservesLimitsOfShape WalkingParallelPair (tensorRight A) where + preservesLimit {K} := by + have := isIso_limitPost_parallelPair_tensorRight A + (K.map WalkingParallelPairHom.left) + (K.map WalkingParallelPairHom.right) + have : PreservesLimit + (parallelPair (K.map WalkingParallelPairHom.left) + (K.map WalkingParallelPairHom.right)) (tensorRight A) := + preservesLimit_of_isIso_post _ _ + exact preservesLimit_of_iso_diagram _ + (diagramIsoParallelPair K).symm + +end Equalizers + +section RightExact + +/-- **Deligne 2.2, right-exactness, left version**: left tensoring +on `Ind C` preserves finite colimits — coequalizers by the descent +above, finite coproducts by the additivity of +`RS.Classical.Deligne.IndTensorExact`. -/ +instance tensorLeft_ind_preservesFiniteColimits + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + (A : Ind C) : + PreservesFiniteColimits (tensorLeft A) := + preservesFiniteColimits_of_preservesCoequalizers_and_finiteCoproducts + _ + +/-- **Deligne 2.2, right-exactness, right version**. -/ +instance tensorRight_ind_preservesFiniteColimits + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + (A : Ind C) : + PreservesFiniteColimits (tensorRight A) := + preservesFiniteColimits_of_preservesCoequalizers_and_finiteCoproducts + _ + +/-- **Left-exactness, left version**: left tensoring on `Ind C` +preserves finite limits — equalizers by the dual descent, finite +products by additivity. With the right-exactness above, the tensor +of `Ind C` is exact in each variable. -/ +instance tensorLeft_ind_preservesFiniteLimits + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + (A : Ind C) : + PreservesFiniteLimits (tensorLeft A) := + preservesFiniteLimits_of_preservesEqualizers_and_finiteProducts _ + +/-- **Left-exactness, right version**. -/ +instance tensorRight_ind_preservesFiniteLimits + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + (A : Ind C) : + PreservesFiniteLimits (tensorRight A) := + preservesFiniteLimits_of_preservesEqualizers_and_finiteProducts _ + +end RightExact + +section AcceptanceTests + +/- Instance synthesis is what is being tested; the data is chosen by +colimit machinery, hence `noncomputable`. -/ + +noncomputable example + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + (A : Ind C) : + PreservesColimitsOfShape WalkingParallelPair (tensorLeft A) := + inferInstance + +noncomputable example + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + (A : Ind C) : + PreservesColimitsOfShape WalkingParallelPair (tensorRight A) := + inferInstance + +noncomputable example + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + (A : Ind C) : + PreservesFiniteColimits (tensorLeft A) := + inferInstance + +noncomputable example + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + (A : Ind C) : + PreservesFiniteColimits (tensorRight A) := + inferInstance + +noncomputable example + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + {X Y : Ind C} (h : X ⟶ Y) (A : Ind C) : + IsIso (cokernelComparison h (tensorLeft A)) := + inferInstance + +noncomputable example + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + {X Y : Ind C} (h : X ⟶ Y) (A : Ind C) : + IsIso (cokernelComparison h (tensorRight A)) := + inferInstance + +noncomputable example + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + (A : Ind C) : + PreservesFiniteLimits (tensorLeft A) := + inferInstance + +noncomputable example + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + (A : Ind C) : + PreservesFiniteLimits (tensorRight A) := + inferInstance + +noncomputable example + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + {X Y : Ind C} (h : X ⟶ Y) (A : Ind C) : + IsIso (kernelComparison h (tensorLeft A)) := + inferInstance + +noncomputable example + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + {X Y : Ind C} (h : X ⟶ Y) (A : Ind C) : + IsIso (kernelComparison h (tensorRight A)) := + inferInstance + +end AcceptanceTests + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCompact.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCompact.lean new file mode 100644 index 0000000000..3fe5f68179 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCompact.lean @@ -0,0 +1,168 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndMonoidal + +/-! +# Compactness of the embedded objects of the ind-completion + +Objects of a small category `C` are compact in `Ind C`: the hom +functor out of an embedded object preserves filtered colimits. This +is the finite-stage engine of Deligne 2.8 — a morphism from an +embedded object into a filtered colimit factors through a stage, and +two stage factorisations that agree in the colimit are merged by +transition maps of the diagram. + +* `RS.indOf` — the canonical embedding `C ⥤ Ind C` (Mathlib's + `Ind.yoneda`, re-exported); +* `RS.indOfCoyonedaIso` — mapping out of `indOf.obj X` in `Ind C` is + mapping out of the representable `yoneda.obj X` after applying the + inclusion `Ind C ⥤ Cᵒᵖ ⥤ Type v`; +* `RS.preservesColimitsOfShape_coyoneda_indOf` and the derived + `PreservesFilteredColimits` instance — compactness itself; +* `RS.exists_factor_of_hom_colimit` — factorisation through a stage; +* `RS.factor_eq_of_hom_colimit` — merging of stage factorisations; +* `RS.comp_ι_eq_comp_ι_iff` — equality after passing to the colimit + is equality at some later stage. + +The route: the inclusion `Ind C ⥤ Cᵒᵖ ⥤ Type v` is fully faithful +and creates (hence preserves) filtered colimits, and mapping out of a +representable presheaf preserves all colimits that exist (Mathlib's +`Limits.Preserves.Yoneda`); the stage lemmas then read off elements +of a filtered colimit of types (`Types.jointly_surjective'`, +`Types.FilteredColimit.colimit_eq_iff`). +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Limits Opposite + +universe v + +variable {C : Type v} + +/-- The canonical embedding of a small category into its +ind-completion: Mathlib's `Ind.yoneda`, re-exported under the name +used throughout the Deligne development. -/ +noncomputable abbrev indOf [SmallCategory C] : C ⥤ Ind C := Ind.yoneda + +/-- Mapping out of an embedded object of `Ind C` is mapping out of +its representable presheaf: the inclusion `Ind C ⥤ Cᵒᵖ ⥤ Type v` is +fully faithful and carries `indOf.obj X` to an object isomorphic to +`yoneda.obj X`. -/ +noncomputable def indOfCoyonedaIso [SmallCategory C] + (X : C) : + coyoneda.obj (op (indOf.obj X)) ≅ + Ind.inclusion C ⋙ coyoneda.obj (op (yoneda.obj X)) := + NatIso.ofComponents + (fun A => Equiv.toIso + (Ind.inclusion.fullyFaithful.homEquiv.trans + ((Ind.yonedaCompInclusion.app X).homCongr (Iso.refl _)))) + (fun h => by + ext f + change (Ind.yonedaCompInclusion.app X).inv ≫ + (Ind.inclusion C).map (f ≫ h) ≫ 𝟙 _ = + ((Ind.yonedaCompInclusion.app X).inv ≫ + (Ind.inclusion C).map f ≫ 𝟙 _) ≫ (Ind.inclusion C).map h + simp) + +/-- **Objects of `C` are compact in `Ind C`**: the hom functor out +of an embedded object preserves filtered colimits of any given small +shape. -/ +instance preservesColimitsOfShape_coyoneda_indOf [SmallCategory C] + (X : C) + (I : Type v) [SmallCategory I] [IsFiltered I] : + PreservesColimitsOfShape I (coyoneda.obj (op (indOf.obj X))) := + haveI : PreservesColimitsOfShape I + (coyoneda.obj (op (yoneda.obj X)) : (Cᵒᵖ ⥤ Type v) ⥤ Type v) := + ⟨inferInstance⟩ + preservesColimitsOfShape_of_natIso (indOfCoyonedaIso X).symm + +/-- Compactness, packaged: the hom functor out of an embedded object +preserves all (small) filtered colimits. -/ +instance preservesFilteredColimits_coyoneda_indOf [SmallCategory C] + (X : C) : + PreservesFilteredColimits (coyoneda.obj (op (indOf.obj X))) where + preserves_filtered_colimits _ _ _ := inferInstance + +/-- Stage description of an element of the hom-out-of-`indOf` functor +applied to a filtered colimit: the colimit injection of the diagram +of hom sets is postcomposition with the colimit injection of the +diagram, read through the preservation isomorphism. -/ +theorem ι_comp_coyoneda_indOf [SmallCategory C] + {I : Type v} [SmallCategory I] + [IsFiltered I] (D : I ⥤ Ind C) (X : C) (i : I) + (g : indOf.obj X ⟶ D.obj i) : + colimit.ι (D ⋙ coyoneda.obj (op (indOf.obj X))) i g = + (preservesColimitIso (coyoneda.obj (op (indOf.obj X))) D).hom + (g ≫ colimit.ι D i) := by + simpa using + (ConcreteCategory.congr_hom + (ι_preservesColimitIso_hom + (coyoneda.obj (op (indOf.obj X))) D i) g).symm + +/-- **Factorisation through a stage** (half of Kashiwara–Schapira +6.1.19, the surjectivity half of the compactness formula): a +morphism from an embedded object into a filtered colimit in `Ind C` +factors through one of the stages of the diagram. -/ +theorem exists_factor_of_hom_colimit [SmallCategory C] + {I : Type v} [SmallCategory I] + [IsFiltered I] (D : I ⥤ Ind C) (X : C) + (f : indOf.obj X ⟶ colimit D) : + ∃ (i : I) (g : indOf.obj X ⟶ D.obj i), + g ≫ colimit.ι D i = f := by + obtain ⟨i, g, hg⟩ := Types.jointly_surjective' + ((preservesColimitIso (coyoneda.obj (op (indOf.obj X))) D).hom f) + refine ⟨i, g, + (preservesColimitIso + (coyoneda.obj (op (indOf.obj X))) D).toEquiv.injective ?_⟩ + exact (ι_comp_coyoneda_indOf D X i g).symm.trans hg + +/-- **Merging of stage factorisations** (the injectivity half of the +compactness formula): two stage factorisations that agree after +passing to the filtered colimit are merged by transition maps of the +diagram. -/ +theorem factor_eq_of_hom_colimit [SmallCategory C] + {I : Type v} [SmallCategory I] + [IsFiltered I] (D : I ⥤ Ind C) (X : C) {i j : I} + (g₁ : indOf.obj X ⟶ D.obj i) (g₂ : indOf.obj X ⟶ D.obj j) + (h : g₁ ≫ colimit.ι D i = g₂ ≫ colimit.ι D j) : + ∃ (k : I) (α : i ⟶ k) (β : j ⟶ k), + g₁ ≫ D.map α = g₂ ≫ D.map β := by + have h' : colimit.ι (D ⋙ coyoneda.obj (op (indOf.obj X))) i g₁ = + colimit.ι (D ⋙ coyoneda.obj (op (indOf.obj X))) j g₂ := by + rw [ι_comp_coyoneda_indOf, ι_comp_coyoneda_indOf, h] + obtain ⟨k, α, β, hk⟩ := + (Types.FilteredColimit.colimit_eq_iff _).mp h' + exact ⟨k, α, β, hk⟩ + +/-- **Equality in the colimit is equality at a stage**: two parallel +morphisms from an embedded object to a stage of a filtered diagram +agree after passing to the colimit iff they agree after some +transition map. (In an additive setting, applied with `g₂ = 0`: +a stage morphism vanishes in the colimit iff it vanishes at some +later stage.) -/ +theorem comp_ι_eq_comp_ι_iff [SmallCategory C] + {I : Type v} [SmallCategory I] + [IsFiltered I] (D : I ⥤ Ind C) (X : C) {i : I} + (g₁ g₂ : indOf.obj X ⟶ D.obj i) : + g₁ ≫ colimit.ι D i = g₂ ≫ colimit.ι D i ↔ + ∃ (k : I) (α : i ⟶ k), g₁ ≫ D.map α = g₂ ≫ D.map α := by + constructor + · intro h + obtain ⟨k, α, β, hk⟩ := factor_eq_of_hom_colimit D X g₁ g₂ h + refine ⟨IsFiltered.coeq α β, α ≫ IsFiltered.coeqHom α β, ?_⟩ + rw [Functor.map_comp, ← Category.assoc, hk, Category.assoc, + ← Functor.map_comp, ← IsFiltered.coeq_condition, + Functor.map_comp] + · rintro ⟨k, α, hk⟩ + rw [← colimit.w D α, ← Category.assoc, hk, Category.assoc] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndDayClosure.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndDayClosure.lean new file mode 100644 index 0000000000..894cc4a8c5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndDayClosure.lean @@ -0,0 +1,151 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DayCalculus + +/-! +# Ind-objects are closed under Day convolution + +Over a small monoidal category `C`, the presheaf category +`Cᵒᵖ ⥤ Type v` carries the Day-convolution monoidal structure through +the synonym `Cᵒᵖ ⊛⥤ Type v` set up in `RS.Classical.Deligne.DayType`. +This file proves that the ind-objects among presheaves are closed +under the Day tensor and contain the Day unit: + +* `RS.dayYonedaIso`: the Day tensor of the representables at `x` and + `y` is the representable at `x ⊗ y` (this is `RS.dayCoyonedaIso` at + the base `Cᵒᵖ`, read through `Coyoneda.objOpOp` and the definitional + identification `op x ⊗ op y = op (x ⊗ y)` in `Cᵒᵖ`); +* `RS.isIndObject_day_tensor`: if `F.functor` and `G.functor` are + ind-objects, so is `(F ⊗ G).functor`; +* `RS.isIndObject_day_unit`: the Day unit is an ind-object. + +The argument is the classical one. Each tensor factor is a small +filtered colimit of representables (`IsIndObject.presentation`); Day +tensoring on either side preserves `v`-small colimits (the instances +of `RS.Classical.Deligne.DayCalculus`), so the tensor is a small +filtered colimit of tensors of representables, and those are +representable by the co-Yoneda computation; closure of ind-objects +under small filtered colimits (`isIndObject_colimit`) concludes. The +two colimit steps are the same manoeuvre, factored out as +`RS.isIndObject_obj_of_preservesColimits`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory MonoidalCategory.DayFunctor Limits +open Opposite + +universe v + +noncomputable section + +variable {C : Type v} + +/-- Transport an isomorphism of plain presheaves to the Day synonym +category. -/ +def dayMkIso [SmallCategory C] [MonoidalCategory C] + {A B : Cᵒᵖ ⥤ Type v} (e : A ≅ B) : + (DayFunctor.mk A : Cᵒᵖ ⊛⥤ Type v) ≅ DayFunctor.mk B := + (equiv Cᵒᵖ (Type v)).inverse.mapIso e + +/-- Transport an isomorphism of the Day synonym category to the plain +presheaf category. -/ +def dayFunctorIso [SmallCategory C] [MonoidalCategory C] + {F G : Cᵒᵖ ⊛⥤ Type v} (e : F ≅ G) : + F.functor ≅ G.functor := + (equiv Cᵒᵖ (Type v)).functor.mapIso e + +/-- Day convolution of representables: the Day tensor of the yoneda +presheaves at `x` and `y` is the yoneda presheaf at `x ⊗ y`. This is +`RS.dayCoyonedaIso` at the base `Cᵒᵖ`, transported along +`Coyoneda.objOpOp`, using that `op x ⊗ op y = op (x ⊗ y)` holds +definitionally in `Cᵒᵖ`. -/ +def dayYonedaIso [SmallCategory C] [MonoidalCategory C] + (x y : C) : + (DayFunctor.mk (yoneda.obj x) : Cᵒᵖ ⊛⥤ Type v) ⊗ + DayFunctor.mk (yoneda.obj y) ≅ + DayFunctor.mk (yoneda.obj (x ⊗ y)) := + tensorIso (dayMkIso (Coyoneda.objOpOp x).symm) + (dayMkIso (Coyoneda.objOpOp y).symm) ≪≫ + dayCoyonedaIso (op x) (op y) ≪≫ + dayMkIso (Coyoneda.objOpOp (x ⊗ y)) + +/-- The Day tensor of two representable presheaves is an +ind-object. -/ +theorem isIndObject_day_tensor_yoneda [SmallCategory C] [MonoidalCategory C] + (x y : C) : + IsIndObject ((DayFunctor.mk (yoneda.obj x) ⊗ + DayFunctor.mk (yoneda.obj y) : Cᵒᵖ ⊛⥤ Type v)).functor := + (isIndObject_yoneda (x ⊗ y)).map (dayFunctorIso (dayYonedaIso x y).symm).hom + +/-- A colimit-preserving endofunctor of the Day synonym category that +sends representables to ind-objects sends every ind-object to an +ind-object: apply the functor to a presentation of the argument as a +small filtered colimit of representables and use closure of +ind-objects under small filtered colimits. This is the induction step +used twice below, for Day tensoring on either side. -/ +theorem isIndObject_obj_of_preservesColimits + [SmallCategory C] [MonoidalCategory C] + (T : (Cᵒᵖ ⊛⥤ Type v) ⥤ Cᵒᵖ ⊛⥤ Type v) + [PreservesColimitsOfSize.{v, v} T] + (hT : ∀ y : C, + IsIndObject (T.obj (DayFunctor.mk (yoneda.obj y))).functor) + {G : Cᵒᵖ ⊛⥤ Type v} (hG : IsIndObject G.functor) : + IsIndObject (T.obj G).functor := by + obtain ⟨⟨Q⟩⟩ := hG + let E : Q.I ⥤ Cᵒᵖ ⥤ Type v := + (((Q.F ⋙ yoneda) ⋙ (equiv Cᵒᵖ (Type v)).inverse) ⋙ T) ⋙ + (equiv Cᵒᵖ (Type v)).functor + have hc₁ : IsColimit ((equiv Cᵒᵖ (Type v)).inverse.mapCocone Q.cocone) := + isColimitOfPreserves _ Q.coconeIsColimit + have hc₂ : IsColimit (T.mapCocone + ((equiv Cᵒᵖ (Type v)).inverse.mapCocone Q.cocone)) := + isColimitOfPreserves T hc₁ + have hc₃ : IsColimit ((equiv Cᵒᵖ (Type v)).functor.mapCocone + (T.mapCocone ((equiv Cᵒᵖ (Type v)).inverse.mapCocone Q.cocone))) := + isColimitOfPreserves _ hc₂ + have hE : ∀ i, IsIndObject (E.obj i) := fun i => hT (Q.F.obj i) + let e := IsColimit.coconePointUniqueUpToIso (colimit.isColimit E) hc₃ + have : IsIso e.hom := e.isIso_hom + have hInd := (isIndObject_colimit Q.I E hE).map e.hom + exact hInd + +/-- The Day tensor of a representable presheaf with an ind-object is +an ind-object. -/ +theorem isIndObject_day_tensor_yoneda_left + [SmallCategory C] [MonoidalCategory C] + (x : C) {G : Cᵒᵖ ⊛⥤ Type v} + (hG : IsIndObject G.functor) : + IsIndObject ((DayFunctor.mk (yoneda.obj x) ⊗ G).functor) := + isIndObject_obj_of_preservesColimits + (tensorLeft (DayFunctor.mk (yoneda.obj x))) + (fun y => isIndObject_day_tensor_yoneda x y) hG + +/-- Ind-objects are closed under Day convolution. -/ +theorem isIndObject_day_tensor [SmallCategory C] [MonoidalCategory C] + {F G : Cᵒᵖ ⊛⥤ Type v} + (hF : IsIndObject F.functor) (hG : IsIndObject G.functor) : + IsIndObject ((F ⊗ G).functor) := + isIndObject_obj_of_preservesColimits (tensorRight G) + (fun y => isIndObject_day_tensor_yoneda_left y hG) hF + +variable (C) in +/-- The Day unit is an ind-object: by `RS.dayUnitIso` it is the +representable at the monoidal unit of `C`. -/ +theorem isIndObject_day_unit [SmallCategory C] [MonoidalCategory C] : + IsIndObject (𝟙_ (Cᵒᵖ ⊛⥤ Type v)).functor := + (isIndObject_yoneda (𝟙_ C)).map + (dayFunctorIso (dayMkIso (Coyoneda.objOpOp (𝟙_ C)).symm ≪≫ + (dayUnitIso Cᵒᵖ).symm)).hom + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndImage.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndImage.lean new file mode 100644 index 0000000000..226ccb5b8e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndImage.lean @@ -0,0 +1,273 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescent + +/-! +# Embedded images from finite length + +`RS.IndImageEmbedded` — the image in `Ind C` of a map out of an +embedded object is again embedded — is carried as a hypothesis by +`RS.Classical.Deligne.CountableDescent` and discharged here from +finite length: if every object of `C` carries a bound on the +length of the chains in its subobject order, then every such image is +embedded. + +The argument. A map `f : indOf.obj Y ⟶ Z` factors through a stage of +the chosen presentation of `Z` (`RS.exists_presStage_factor`), say as +`indOf.map g ≫ presStage Z i`. The stage may be advanced along any +`α : i ⟶ j`, and advancing it only enlarges the kernel of the +composite `g ≫ F.map α` in the subobject order of `Y`. Finite length +makes that order satisfy the ascending chain condition +(`RS.exists_maximal_of_lengthLE`), so the kernel may be taken maximal, +at a stage `j₀`; write `g₀` for the map to that stage. + +Maximality says that no further advance of the stage enlarges the +kernel, and that is exactly what makes the image of `g₀` embed into +`Z`: the map `indOf.map (image.ι g₀) ≫ presStage Z j₀` is a +monomorphism. Monomorphisms of ind-objects are detected on the +embedded objects (`RS.mono_of_hom_indOf_injective`), the detection +brings the question back to a single stage of the presentation, and +there `RS.mono_of_kernelSubobject_comp_le` settles it inside `C`. The +embedding preserves finite colimits, so the other half of the +factorisation of `g₀` stays an epimorphism, and `f` acquires a strong +epi–mono factorisation through `indOf.obj (image g₀)`; uniqueness of +such factorisations identifies the image of `f` with it. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Limits + +universe w v u + +/-! ## Finite length is the ascending chain condition + +`RS.LengthLE Y N` forbids strictly increasing chains of `N + 2` +subobjects of `Y`. A family of subobjects without a maximal member +would generate an infinite strictly increasing chain, so it forbids +that too. -/ + +section Order + +variable {C : Type u} + +/-- **Finite length gives maximal members**: if the subobject order +of `Y` carries no strictly increasing chain of `N + 2` terms, then +every nonempty family of subobjects of `Y` has a maximal member. -/ +theorem exists_maximal_of_lengthLE [Category.{w} C] + {Y : C} {N : ℕ} (hY : LengthLE Y N) + {S : Set (Subobject Y)} (hS : S.Nonempty) : + ∃ P ∈ S, ∀ Q ∈ S, P ≤ Q → Q ≤ P := by + classical + by_contra hcon + push Not at hcon + obtain ⟨P₀, hP₀⟩ := hS + have hstep : ∀ x : S, ∃ y : S, (x : Subobject Y) < (y : Subobject Y) := by + rintro ⟨x, hx⟩ + obtain ⟨Q, hQ, hxQ, hQx⟩ := hcon x hx + exact ⟨⟨Q, hQ⟩, lt_of_le_of_ne hxQ (fun he => hQx (le_of_eq he.symm))⟩ + choose next hnext using hstep + have hchain : StrictMono + (fun n : ℕ => ((next^[n] (⟨P₀, hP₀⟩ : S) : S) : Subobject Y)) := by + refine strictMono_nat_of_lt_succ (fun n => ?_) + have hsucc : next^[n + 1] (⟨P₀, hP₀⟩ : S) = + next (next^[n] (⟨P₀, hP₀⟩ : S)) := + Function.iterate_succ_apply' next n _ + rw [hsucc] + exact hnext _ + exact hY (fun k => ((next^[k.val] (⟨P₀, hP₀⟩ : S) : S) : Subobject Y)) + (fun a b hab => hchain hab) + +end Order + +/-! ## The stable-kernel criterion for a monomorphism + +A map `f` followed by `g` has a kernel at least that of `f`. When +the two kernels agree, the mono half of the image factorisation of +`f` survives postcomposition with `g`: the kernel of `image.ι f ≫ g` +is pulled back along the epi half to the common kernel, and an +epimorphism cancels. -/ + +section Ambient + +variable {C : Type u} + +/-- Postcomposition only enlarges the kernel. -/ +theorem kernelSubobject_le_comp [Category.{w} C] [Abelian C] + {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) : + kernelSubobject f ≤ kernelSubobject (f ≫ g) := + Subobject.le_of_factors + ((kernelSubobject_factors_iff (f ≫ g) + (kernelSubobject f).arrow).mpr (by + rw [← Category.assoc, kernelSubobject_arrow_comp, zero_comp])) + +/-- **The stable-kernel criterion**: if postcomposing `f` with `g` +does not enlarge the kernel of `f`, then the mono half of the image +factorisation of `f` remains a monomorphism after postcomposition +with `g`. -/ +theorem mono_of_kernelSubobject_comp_le [Category.{w} C] [Abelian C] + {X Y Z : C} (f : X ⟶ Y) + (g : Y ⟶ Z) (h : kernelSubobject (f ≫ g) ≤ kernelSubobject f) : + Mono (image.ι f ≫ g) := by + rw [Preadditive.mono_iff_cancel_zero] + intro T x hx + have hcond : pullback.fst x (factorThruImage f) ≫ x = + pullback.snd x (factorThruImage f) ≫ factorThruImage f := + pullback.condition + have hker : pullback.snd x (factorThruImage f) ≫ (f ≫ g) = 0 := by + calc pullback.snd x (factorThruImage f) ≫ (f ≫ g) + = (pullback.snd x (factorThruImage f) ≫ factorThruImage f) ≫ + (image.ι f ≫ g) := by + rw [Category.assoc, ← Category.assoc (factorThruImage f), + image.fac] + _ = (pullback.fst x (factorThruImage f) ≫ x) ≫ + (image.ι f ≫ g) := by rw [hcond] + _ = pullback.fst x (factorThruImage f) ≫ + (x ≫ (image.ι f ≫ g)) := Category.assoc _ _ _ + _ = 0 := by rw [hx, comp_zero] + have hfib : pullback.snd x (factorThruImage f) ≫ f = 0 := + (kernelSubobject_factors_iff f _).mp + (Subobject.factors_of_le _ h + ((kernelSubobject_factors_iff (f ≫ g) _).mpr hker)) + have hzero : pullback.fst x (factorThruImage f) ≫ + (x ≫ image.ι f) = 0 := by + rw [← Category.assoc, hcond, Category.assoc, image.fac, hfib] + have hxι : x ≫ image.ι f = 0 := + (cancel_epi (pullback.fst x (factorThruImage f))).mp + (hzero.trans (comp_zero).symm) + exact (cancel_mono (image.ι f)).mp (hxι.trans (zero_comp).symm) + +end Ambient + +/-! ## Embedded images + +The main theorem: finite length discharges `RS.IndImageEmbedded`. -/ + +section Embedded + +variable {C : Type v} + +/-- Two maps out of an embedded object into a stage of the +presentation of an ind-object which agree in the ind-object already +agree at a later stage — the merging half of compactness, read at the +structural maps of the presentation. -/ +theorem exists_stage_comp_eq_of_presStage [SmallCategory C] + {Z : Ind C} {W : C} + {j : Z.presentation.I} (a b : indOf.obj W ⟶ indOf.obj + (Z.presentation.F.obj j)) + (hab : a ≫ presStage Z j = b ≫ presStage Z j) : + ∃ (k : Z.presentation.I) (β : j ⟶ k), + a ≫ indOf.map (Z.presentation.F.map β) = + b ≫ indOf.map (Z.presentation.F.map β) := by + have hcancel : a ≫ colimit.ι (presDiagram Z) j = + b ≫ colimit.ι (presDiagram Z) j := by + refine (cancel_mono (Ind.colimitPresentationCompYoneda Z).hom).mp ?_ + calc (a ≫ colimit.ι (presDiagram Z) j) ≫ + (Ind.colimitPresentationCompYoneda Z).hom + = a ≫ presStage Z j := Category.assoc _ _ _ + _ = b ≫ presStage Z j := hab + _ = (b ≫ colimit.ι (presDiagram Z) j) ≫ + (Ind.colimitPresentationCompYoneda Z).hom := + (Category.assoc _ _ _).symm + obtain ⟨k, β, hβ⟩ := + (comp_ι_eq_comp_ι_iff (presDiagram Z) W a b).mp hcancel + exact ⟨k, β, hβ⟩ + +/-- **Embedded images from finite length.** If every object of `C` +has a bound on the length of the chains in its subobject order, then +the image in `Ind C` of a map out of an embedded object is again +embedded. -/ +theorem indImageEmbedded_of_lengthLE [SmallCategory C] [Abelian C] + (hlen : ∀ Z : C, ∃ N, LengthLE Z N) : IndImageEmbedded C := by + classical + intro Y Z f + obtain ⟨N, hN⟩ := hlen Y + obtain ⟨i, g, hg⟩ := exists_presStage_factor Z f + obtain ⟨P₀, hP₀mem, hmax⟩ := exists_maximal_of_lengthLE hN + (S := {P : Subobject Y | ∃ (j : Z.presentation.I) (α : i ⟶ j), + P = kernelSubobject (g ≫ Z.presentation.F.map α)}) + ⟨kernelSubobject (g ≫ Z.presentation.F.map (𝟙 i)), i, 𝟙 i, rfl⟩ + obtain ⟨j₀, α₀, hP₀⟩ := hP₀mem + subst hP₀ + -- The map to the maximal stage, and the factorisation of `f`. + have hf : indOf.map (g ≫ Z.presentation.F.map α₀) ≫ + presStage Z j₀ = f := by + rw [CategoryTheory.Functor.map_comp, Category.assoc, + presStage_naturality, hg] + -- Maximality: advancing the stage no longer enlarges the kernel. + have hstable : ∀ (k : Z.presentation.I) (β : j₀ ⟶ k), + kernelSubobject ((g ≫ Z.presentation.F.map α₀) ≫ + Z.presentation.F.map β) ≤ + kernelSubobject (g ≫ Z.presentation.F.map α₀) := by + intro k β + have hcomp : g ≫ Z.presentation.F.map (α₀ ≫ β) = + (g ≫ Z.presentation.F.map α₀) ≫ Z.presentation.F.map β := by + rw [CategoryTheory.Functor.map_comp, Category.assoc] + have hmem : kernelSubobject (g ≫ Z.presentation.F.map (α₀ ≫ β)) ∈ + {P : Subobject Y | ∃ (j : Z.presentation.I) (α : i ⟶ j), + P = kernelSubobject (g ≫ Z.presentation.F.map α)} := + ⟨k, α₀ ≫ β, rfl⟩ + have hle : kernelSubobject (g ≫ Z.presentation.F.map α₀) ≤ + kernelSubobject (g ≫ Z.presentation.F.map (α₀ ≫ β)) := + (congrArg (fun t : Y ⟶ Z.presentation.F.obj k => + kernelSubobject t) hcomp.symm) ▸ + kernelSubobject_le_comp (g ≫ Z.presentation.F.map α₀) + (Z.presentation.F.map β) + exact (congrArg (fun t : Y ⟶ Z.presentation.F.obj k => + kernelSubobject t) hcomp) ▸ hmax _ hmem hle + -- The mono half of the factorisation, after the embedding. + have hmono : Mono (indOf.map + (image.ι (g ≫ Z.presentation.F.map α₀)) ≫ presStage Z j₀) := by + refine mono_of_hom_indOf_injective _ (fun W u v huv => ?_) + have hu : indOf.map (Ind.yoneda.fullyFaithful.preimage u) = u := + Ind.yoneda.fullyFaithful.map_preimage u + have hv : indOf.map (Ind.yoneda.fullyFaithful.preimage v) = v := + Ind.yoneda.fullyFaithful.map_preimage v + obtain ⟨k, β, hβ⟩ := exists_stage_comp_eq_of_presStage + (u ≫ indOf.map (image.ι (g ≫ Z.presentation.F.map α₀))) + (v ≫ indOf.map (image.ι (g ≫ Z.presentation.F.map α₀))) + ((Category.assoc _ _ _).trans (huv.trans + (Category.assoc _ _ _).symm)) + have hpre : (Ind.yoneda.fullyFaithful.preimage u ≫ + image.ι (g ≫ Z.presentation.F.map α₀) ≫ + Z.presentation.F.map β) = + (Ind.yoneda.fullyFaithful.preimage v ≫ + image.ι (g ≫ Z.presentation.F.map α₀) ≫ + Z.presentation.F.map β) := by + refine indOf.map_injective ?_ + rw [CategoryTheory.Functor.map_comp, + CategoryTheory.Functor.map_comp, + CategoryTheory.Functor.map_comp, + CategoryTheory.Functor.map_comp, hu, hv] + exact ((Category.assoc _ _ _).symm.trans hβ).trans + (Category.assoc _ _ _) + have : Mono (image.ι (g ≫ Z.presentation.F.map α₀) ≫ + Z.presentation.F.map β) := + mono_of_kernelSubobject_comp_le _ _ (hstable k β) + have : Ind.yoneda.fullyFaithful.preimage u = + Ind.yoneda.fullyFaithful.preimage v := + (cancel_mono (image.ι (g ≫ Z.presentation.F.map α₀) ≫ + Z.presentation.F.map β)).mp hpre + rw [← hu, ← hv, this] + have := hmono + have : StrongEpi (indOf.map + (factorThruImage (g ≫ Z.presentation.F.map α₀))) := + strongEpi_of_epi _ + refine ⟨image (g ≫ Z.presentation.F.map α₀), ⟨(image.isoStrongEpiMono + (indOf.map (factorThruImage (g ≫ Z.presentation.F.map α₀))) + (indOf.map (image.ι (g ≫ Z.presentation.F.map α₀)) ≫ + presStage Z j₀) ?_).symm⟩⟩ + rw [← Category.assoc, ← CategoryTheory.Functor.map_comp, image.fac] + exact hf + +end Embedded + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndKill.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndKill.lean new file mode 100644 index 0000000000..e7d0c0ef34 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndKill.lean @@ -0,0 +1,447 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplit +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.RegularTrace + +/-! +# The induction kill: block products die with their multiplicity + +The product of the central idempotent of `λ` with the embedded +block idempotent of `(μ, ν)` is an idempotent of the group algebra +whose coefficient at the identity is a positive multiple of the +induction multiplicity `[λ : μ, ν]`. An idempotent of a group +algebra over ℂ vanishes exactly when its identity coefficient +does — the trace of its left-regular action — so the product is +zero as soon as the multiplicity is. This is the bridge from the +character combinatorics to the categorical direct-sum transfer of +Schur vanishing. +-/ + +@[expose] public section + +namespace RS + +open Finset + +private theorem ma_add_apply {G : Type*} (f g : MonoidAlgebra ℂ G) + (x : G) : (f + g).coeff x = f.coeff x + g.coeff x := rfl + +private theorem ma_smul_apply {G : Type*} (r : ℂ) + (f : MonoidAlgebra ℂ G) (x : G) : (r • f).coeff x = r * f.coeff x := rfl + +/-- The trace of left multiplication on a group algebra is the +group order times the identity coefficient. -/ +theorem trace_mulLeft_monoidAlgebra {G : Type*} [Group G] + [Fintype G] (x : MonoidAlgebra ℂ G) : + LinearMap.trace ℂ (MonoidAlgebra ℂ G) + (LinearMap.mulLeft ℂ x) = + (Fintype.card G : ℂ) * x.coeff 1 := by + classical + exact + trace_mulLeft x + +/-- An idempotent of a finite group algebra over ℂ with vanishing +identity coefficient is zero. -/ +theorem eq_zero_of_idem_of_coeff_one {G : Type*} [Group G] + [Finite G] {x : MonoidAlgebra ℂ G} + (hidem : x * x = x) (h1 : x.coeff 1 = 0) : x = 0 := by + classical + let := Fintype.ofFinite G + set L := LinearMap.mulLeft ℂ x with hLdef + have hLL : L ∘ₗ L = L := by + rw [hLdef, ← LinearMap.mulLeft_mul, hidem] + have hproj : LinearMap.IsProj (LinearMap.range L) L := by + refine ⟨fun y => LinearMap.mem_range_self L y, ?_⟩ + rintro y ⟨z, rfl⟩ + exact congrArg (fun f => f z) hLL + have htr := hproj.trace + rw [show LinearMap.trace ℂ (MonoidAlgebra ℂ G) L = + (Fintype.card G : ℂ) * x.coeff 1 from + trace_mulLeft_monoidAlgebra x, h1, mul_zero] at htr + have hrank : Module.finrank ℂ (LinearMap.range L) = 0 := by + exact_mod_cast htr.symm + have hbot : LinearMap.range L = ⊥ := + Submodule.finrank_eq_zero.mp hrank + have hL0 : L = 0 := LinearMap.range_eq_bot.mp hbot + have hx := congrArg (fun f : _ →ₗ[ℂ] _ => + f (1 : MonoidAlgebra ℂ G)) hL0 + simpa [hLdef, LinearMap.mulLeft_apply] using hx + +universe u + +/-- The Shape idempotent's coefficients are conjugation +invariant. -/ +theorem shape_e_coeff_conj (P : SchurPackage.{u}) {n : ℕ} + (lam : Shape n) (g k : Equiv.Perm (Fin n)) : + (Shape.e P lam).coeff (g⁻¹ * k * g) = (Shape.e P lam).coeff k := by + have h1 := shape_e_coeff P lam (g⁻¹ * k * g) + have h2 := shape_e_coeff P lam k + have hcast : permCast lam.prop.symm (g⁻¹ * k * g) = + (permCast lam.prop.symm g)⁻¹ * + permCast lam.prop.symm k * permCast lam.prop.symm g := by + rw [permCast_mul, permCast_mul, permCast_inv] + have hchar : jtChar lam.val (permCast lam.prop.symm + (g⁻¹ * k * g)) = + jtChar lam.val (permCast lam.prop.symm k) := by + rw [hcast] + have := jtChar_conj lam.val + ((permCast lam.prop.symm g)⁻¹ : _) + (permCast lam.prop.symm k) + simpa [inv_inv] using this + change (Shape.e P lam).coeff (g⁻¹ * k * g) = + (Shape.e P lam).coeff k + rw [h1, h2, hchar] + +/-- The Shape idempotents are central. -/ +theorem shape_e_central (P : SchurPackage.{u}) {n : ℕ} + (lam : Shape n) (y : SymGroupAlgebra n) : + Shape.e P lam * y = y * Shape.e P lam := by + classical + -- Reduce to singles by linearity. + suffices hsingle : ∀ (g : Equiv.Perm (Fin n)) (c : ℂ), + Shape.e P lam * MonoidAlgebra.single g c = + MonoidAlgebra.single g c * Shape.e P lam by + induction y using MonoidAlgebra.induction_on with + | of g => exact hsingle g 1 + | add y z hy hz => rw [mul_add, add_mul, hy, hz] + | smul r y hy => rw [mul_smul_comm, smul_mul_assoc, hy] + intro g c + ext k + rw [MonoidAlgebra.coeff_mul_single_apply, + MonoidAlgebra.coeff_single_mul_apply] + have hconj := shape_e_coeff_conj P lam g (k * g⁻¹) + have harg : g⁻¹ * (k * g⁻¹) * g = g⁻¹ * k := by + group + rw [harg] at hconj + rw [← hconj] + ring + +/-- The two block images commute elementwise. -/ +theorem blockImages_comm {a b : ℕ} (x : SymGroupAlgebra a) + (y : SymGroupAlgebra b) : + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedFstHom a b) x * + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedSndHom a b) y = + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedSndHom a b) y * + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedFstHom a b) + x := by + classical + induction x using MonoidAlgebra.induction_on with + | of σ => + induction y using MonoidAlgebra.induction_on with + | of τ => + have hL : MonoidAlgebra.mapDomainAlgHom ℂ ℂ + (blockEmbedFstHom a b) (MonoidAlgebra.single σ 1) = + MonoidAlgebra.single (blockEmbed σ 1) (1 : ℂ) := by + change MonoidAlgebra.mapDomain _ + (MonoidAlgebra.single σ 1) = _ + exact MonoidAlgebra.mapDomain_single + have hR : MonoidAlgebra.mapDomainAlgHom ℂ ℂ + (blockEmbedSndHom a b) (MonoidAlgebra.single τ 1) = + MonoidAlgebra.single (blockEmbed 1 τ) (1 : ℂ) := by + change MonoidAlgebra.mapDomain _ + (MonoidAlgebra.single τ 1) = _ + exact MonoidAlgebra.mapDomain_single + simp only [MonoidAlgebra.of_apply] + rw [hL, hR, MonoidAlgebra.single_mul_single, + MonoidAlgebra.single_mul_single] + congr 1 + rw [← blockEmbed_mul, ← blockEmbed_mul] + simp + | add y y' hy hy' => + rw [map_add, mul_add, add_mul, hy, hy'] + | smul r y hy => + rw [map_smul, mul_smul_comm, smul_mul_assoc, hy] + | add x x' hx hx' => + rw [map_add, add_mul, mul_add, hx, hx'] + | smul r x hx => + rw [map_smul, smul_mul_assoc, mul_smul_comm, hx] + +/-- The block embedding is multiplicative in the two slots +jointly. -/ +theorem blockAlgEmbed_mul_blockAlgEmbed {a b : ℕ} + (x x' : SymGroupAlgebra a) (y y' : SymGroupAlgebra b) : + blockAlgEmbed x y * blockAlgEmbed x' y' = + blockAlgEmbed (x * x') (y * y') := by + unfold blockAlgEmbed + rw [map_mul, map_mul] + calc MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedFstHom a b) x * + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedSndHom a b) y * + (MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedFstHom a b) x' * + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedSndHom a b) y') + = MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedFstHom a b) x * + (MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedSndHom a b) y * + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedFstHom a b) + x') * + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedSndHom a b) + y' := by + rw [mul_assoc, mul_assoc, mul_assoc] + _ = MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedFstHom a b) x * + (MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedFstHom a b) + x' * + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedSndHom a b) + y) * + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedSndHom a b) + y' := by + rw [blockImages_comm] + _ = _ := by + rw [mul_assoc, mul_assoc, mul_assoc] + +/-- The embedded block idempotent is idempotent. -/ +theorem blockAlgEmbed_shape_e_idem (P : SchurPackage.{u}) + {a b : ℕ} (μ : Shape a) (ν : Shape b) : + blockAlgEmbed (Shape.e P μ) (Shape.e P ν) * + blockAlgEmbed (Shape.e P μ) (Shape.e P ν) = + blockAlgEmbed (Shape.e P μ) (Shape.e P ν) := by + rw [blockAlgEmbed_mul_blockAlgEmbed, Shape.e_mul_self, + Shape.e_mul_self] + +/-- Joint injectivity of the block embedding. -/ +theorem blockEmbed_inj {a b : ℕ} {σ σ' : Equiv.Perm (Fin a)} + {τ τ' : Equiv.Perm (Fin b)} + (h : blockEmbed σ τ = blockEmbed σ' τ') : σ = σ' ∧ τ = τ' := by + constructor + · ext i + have h1 := DFunLike.congr_fun h (Fin.castAdd b i) + rw [blockEmbed_castAdd, blockEmbed_castAdd] at h1 + have := congrArg Fin.val h1 + simp only [Fin.val_castAdd] at this + omega + · ext j + have h1 := DFunLike.congr_fun h (Fin.natAdd a j) + rw [blockEmbed_natAdd, blockEmbed_natAdd] at h1 + have := congrArg Fin.val h1 + simp only [Fin.val_natAdd] at this + omega + +/-- The block image's coefficient on the block. -/ +theorem blockAlgEmbed_apply_blockEmbed {a b : ℕ} + (x : SymGroupAlgebra a) (y : SymGroupAlgebra b) + (σ : Equiv.Perm (Fin a)) (τ : Equiv.Perm (Fin b)) : + (blockAlgEmbed x y).coeff (blockEmbed σ τ) = x.coeff σ * y.coeff τ := by + classical + induction x using MonoidAlgebra.induction_on with + | of σ₀ => + induction y using MonoidAlgebra.induction_on with + | of τ₀ => + simp only [MonoidAlgebra.of_apply] + rw [blockAlgEmbed_single] + by_cases hcase : σ₀ = σ ∧ τ₀ = τ + · obtain ⟨rfl, rfl⟩ := hcase + simp + · have hne : blockEmbed σ₀ τ₀ ≠ blockEmbed σ τ := by + intro he + exact hcase (blockEmbed_inj he) + rcases not_and_or.mp hcase with hσ | hτ + · simp [Finsupp.single_apply, hne, hσ] + · simp [Finsupp.single_apply, hne, hτ] + | add y y' hy hy' => + rw [blockAlgEmbed_add_snd, ma_add_apply, hy, hy', + ma_add_apply, mul_add] + | smul r y hy => + rw [blockAlgEmbed_smul_snd, ma_smul_apply, hy, + ma_smul_apply] + ring + | add x x' hx hx' => + rw [blockAlgEmbed_add_fst, ma_add_apply, hx, hx', + ma_add_apply, add_mul] + | smul r x hx => + rw [blockAlgEmbed_smul_fst, ma_smul_apply, hx, + ma_smul_apply] + ring + +/-- The block image vanishes off the block. -/ +theorem blockAlgEmbed_apply_eq_zero {a b : ℕ} + (x : SymGroupAlgebra a) (y : SymGroupAlgebra b) + {g : Equiv.Perm (Fin (a + b))} + (h : ∀ (σ : Equiv.Perm (Fin a)) (τ : Equiv.Perm (Fin b)), + g ≠ blockEmbed σ τ) : + (blockAlgEmbed x y).coeff g = 0 := by + classical + induction x using MonoidAlgebra.induction_on with + | of σ₀ => + induction y using MonoidAlgebra.induction_on with + | of τ₀ => + simp only [MonoidAlgebra.of_apply] + rw [blockAlgEmbed_single] + have hne : blockEmbed σ₀ τ₀ ≠ g := fun he => h σ₀ τ₀ he.symm + simp [hne] + | add y y' hy hy' => + rw [blockAlgEmbed_add_snd, ma_add_apply, hy, hy', add_zero] + | smul r y hy => + rw [blockAlgEmbed_smul_snd, ma_smul_apply, hy, mul_zero] + | add x x' hx hx' => + rw [blockAlgEmbed_add_fst, ma_add_apply, hx, hx', add_zero] + | smul r x hx => + rw [blockAlgEmbed_smul_fst, ma_smul_apply, hx, mul_zero] + +/-- Convolution at the identity. -/ +theorem mul_apply_one {G : Type*} [Group G] [Fintype G] + (x y : MonoidAlgebra ℂ G) : + (x * y).coeff 1 = ∑ g : G, x.coeff g * y.coeff g⁻¹ := by + classical + rw [MonoidAlgebra.coeff_mul_apply_left] + simp only [mul_one, Finsupp.sum] + exact Finset.sum_subset (Finset.subset_univ _) fun g _ hg => by + rw [Finsupp.notMem_support_iff.mp hg, zero_mul] + +/-- The identity coefficient of the block product is a positive +multiple of the induction multiplicity. -/ +theorem shape_e_mul_block_apply_one (P : SchurPackage.{u}) + {a b : ℕ} (lam : Shape (a + b)) (μ : Shape a) (ν : Shape b) : + (Shape.e P lam * + blockAlgEmbed (Shape.e P μ) (Shape.e P ν)).coeff 1 = + (P.dim lam.val : ℂ) * (P.dim μ.val : ℂ) * + (P.dim ν.val : ℂ) / (((a + b).factorial : ℂ)) * + indMult lam μ ν := by + classical + rw [mul_apply_one] + have hswap : (∑ g : Equiv.Perm (Fin (a + b)), + (Shape.e P lam).coeff g * + (blockAlgEmbed (Shape.e P μ) (Shape.e P ν)).coeff g⁻¹) = + ∑ g : Equiv.Perm (Fin (a + b)), + (Shape.e P lam).coeff g⁻¹ * + (blockAlgEmbed (Shape.e P μ) (Shape.e P ν)).coeff g := + Fintype.sum_equiv (Equiv.inv _) _ _ fun g => by + change (Shape.e P lam).coeff g * + (blockAlgEmbed (Shape.e P μ) (Shape.e P ν)).coeff g⁻¹ = + (Shape.e P lam).coeff g⁻¹⁻¹ * + (blockAlgEmbed (Shape.e P μ) (Shape.e P ν)).coeff g⁻¹ + rw [inv_inv] + rw [hswap] + have hoff : ∀ g ∈ (Finset.univ : + Finset (Equiv.Perm (Fin (a + b)))), + g ∉ (Finset.univ ×ˢ Finset.univ).image + (fun p : Equiv.Perm (Fin a) × Equiv.Perm (Fin b) => + blockEmbed p.1 p.2) → + (Shape.e P lam).coeff g⁻¹ * + (blockAlgEmbed (Shape.e P μ) (Shape.e P ν)).coeff g = 0 := by + intro g _ hg + rw [blockAlgEmbed_apply_eq_zero _ _ fun σ τ he => + hg (Finset.mem_image.mpr ⟨(σ, τ), + Finset.mem_product.mpr + ⟨Finset.mem_univ _, Finset.mem_univ _⟩, he.symm⟩), + mul_zero] + rw [← Finset.sum_subset (Finset.subset_univ _) hoff] + rw [Finset.sum_image (by + intro p _ q _ hpq + obtain ⟨h1, h2⟩ := blockEmbed_inj hpq + exact Prod.ext h1 h2)] + rw [Finset.sum_product] + have hterm : ∀ (σ : Equiv.Perm (Fin a)) + (τ : Equiv.Perm (Fin b)), + (Shape.e P lam).coeff (blockEmbed σ τ)⁻¹ * + (blockAlgEmbed (Shape.e P μ) (Shape.e P ν)).coeff + (blockEmbed σ τ) = + ((P.dim lam.val : ℂ) / (((a + b).factorial : ℂ))) * + ((P.dim μ.val : ℂ) / ((a.factorial : ℂ))) * + ((P.dim ν.val : ℂ) / ((b.factorial : ℂ))) * + (jtChar lam.val + (permCast lam.prop.symm (blockEmbed σ τ)) * + jtChar μ.val (permCast μ.prop.symm σ) * + jtChar ν.val (permCast ν.prop.symm τ)) := by + intro σ τ + rw [blockAlgEmbed_apply_blockEmbed] + have h1 : (Shape.e P lam).coeff ((blockEmbed σ τ)⁻¹) = + ((P.dim lam.val : ℂ) / (((a + b).factorial : ℂ))) * + jtChar lam.val + (permCast lam.prop.symm (blockEmbed σ τ)) := by + have hc := shape_e_coeff P lam ((blockEmbed σ τ)⁻¹) + rw [permCast_inv, jtChar_inv] at hc + exact hc + have h2 := shape_e_coeff P μ σ + have h3 := shape_e_coeff P ν τ + rw [h1, show (Shape.e P μ).coeff σ = + ((P.dim μ.val : ℂ) / ((a.factorial : ℂ))) * + jtChar μ.val (permCast μ.prop.symm σ) from h2, + show (Shape.e P ν).coeff τ = + ((P.dim ν.val : ℂ) / ((b.factorial : ℂ))) * + jtChar ν.val (permCast ν.prop.symm τ) from h3] + ring + rw [Finset.sum_congr rfl fun σ _ => + Finset.sum_congr rfl fun τ _ => hterm σ τ] + rw [show (∑ σ : Equiv.Perm (Fin a), ∑ τ : Equiv.Perm (Fin b), + ((P.dim lam.val : ℂ) / (((a + b).factorial : ℂ))) * + ((P.dim μ.val : ℂ) / ((a.factorial : ℂ))) * + ((P.dim ν.val : ℂ) / ((b.factorial : ℂ))) * + (jtChar lam.val + (permCast lam.prop.symm (blockEmbed σ τ)) * + jtChar μ.val (permCast μ.prop.symm σ) * + jtChar ν.val (permCast ν.prop.symm τ))) = + ((P.dim lam.val : ℂ) / (((a + b).factorial : ℂ))) * + ((P.dim μ.val : ℂ) / ((a.factorial : ℂ))) * + ((P.dim ν.val : ℂ) / ((b.factorial : ℂ))) * + ∑ σ : Equiv.Perm (Fin a), ∑ τ : Equiv.Perm (Fin b), + jtChar lam.val + (permCast lam.prop.symm (blockEmbed σ τ)) * + jtChar μ.val (permCast μ.prop.symm σ) * + jtChar ν.val (permCast ν.prop.symm τ) from by + simp only [Finset.mul_sum]] + rw [indMult] + have ha : ((a.factorial : ℂ)) ≠ 0 := + Nat.cast_ne_zero.mpr a.factorial_ne_zero + have hb : ((b.factorial : ℂ)) ≠ 0 := + Nat.cast_ne_zero.mpr b.factorial_ne_zero + field_simp + +/-- **The induction kill**: a vanishing induction multiplicity +kills the block product in the group algebra. -/ +theorem shape_e_mul_blockAlgEmbed_eq_zero (P : SchurPackage.{u}) + {a b : ℕ} (lam : Shape (a + b)) (μ : Shape a) (ν : Shape b) + (h : indMult lam μ ν = 0) : + Shape.e P lam * blockAlgEmbed (Shape.e P μ) (Shape.e P ν) = + 0 := by + classical + apply eq_zero_of_idem_of_coeff_one + · have hc : blockAlgEmbed (Shape.e P μ) (Shape.e P ν) * + Shape.e P lam = + Shape.e P lam * + blockAlgEmbed (Shape.e P μ) (Shape.e P ν) := + (shape_e_central P lam _).symm + calc Shape.e P lam * + blockAlgEmbed (Shape.e P μ) (Shape.e P ν) * + (Shape.e P lam * + blockAlgEmbed (Shape.e P μ) (Shape.e P ν)) + = Shape.e P lam * + (blockAlgEmbed (Shape.e P μ) (Shape.e P ν) * + (Shape.e P lam * + blockAlgEmbed (Shape.e P μ) (Shape.e P ν))) := + mul_assoc _ _ _ + _ = Shape.e P lam * + (blockAlgEmbed (Shape.e P μ) (Shape.e P ν) * + Shape.e P lam * + blockAlgEmbed (Shape.e P μ) (Shape.e P ν)) := + congrArg (fun z => Shape.e P lam * z) + (mul_assoc _ _ _).symm + _ = Shape.e P lam * + (Shape.e P lam * + blockAlgEmbed (Shape.e P μ) (Shape.e P ν) * + blockAlgEmbed (Shape.e P μ) (Shape.e P ν)) := + congrArg (fun z => Shape.e P lam * + (z * blockAlgEmbed (Shape.e P μ) (Shape.e P ν))) hc + _ = Shape.e P lam * + (Shape.e P lam * + (blockAlgEmbed (Shape.e P μ) (Shape.e P ν) * + blockAlgEmbed (Shape.e P μ) (Shape.e P ν))) := + congrArg (fun z => Shape.e P lam * z) (mul_assoc _ _ _) + _ = Shape.e P lam * + (Shape.e P lam * + blockAlgEmbed (Shape.e P μ) (Shape.e P ν)) := + congrArg (fun z => Shape.e P lam * (Shape.e P lam * z)) + (blockAlgEmbed_shape_e_idem P μ ν) + _ = Shape.e P lam * Shape.e P lam * + blockAlgEmbed (Shape.e P μ) (Shape.e P ν) := + (mul_assoc _ _ _).symm + _ = Shape.e P lam * + blockAlgEmbed (Shape.e P μ) (Shape.e P ν) := + congrArg (fun z => z * + blockAlgEmbed (Shape.e P μ) (Shape.e P ν)) + (Shape.e_mul_self P lam) + · rw [shape_e_mul_block_apply_one, h, mul_zero] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndLocallyMixed.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndLocallyMixed.lean new file mode 100644 index 0000000000..ba81c0a65e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndLocallyMixed.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29Close +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchurKilled + +/-! +# Embedded objects are locally mixed + +Proposition 2.9 applies to the embedded objects: an object of the +small category killed by some Schur functor stays killed after the +Ind-embedding, its dual embeds to a dual, and the trichotomy then +makes it a mixed sum of the unit and the odd line after base change +to some nonzero commutative algebra. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v + +variable {C : Type v} + +/-- **Embedded Schur-killed objects are locally mixed.** -/ +theorem locallyMixed_indOf + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + (ψ : ℂ ≃+* End (𝟙_ C)) + (P : SchurPackage.{v}) (P₀ : SchurPackage.{0}) (Z : C) + (lam : YoungDiagram) + (hkill : letI := linearOfScalarUnit ψ; SchurKilled P Z lam) : + letI := linearOfScalarUnit ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + letI := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + ∀ (L : OddLine (Ind C)), ¬ IsZero (𝟙_ (Ind C)) → + L.LocallyMixed ((indOf : C ⥤ Ind C).obj Z) := by + let := linearOfScalarUnit ψ + let := linearOfScalarUnit (indScalarUnit ψ) + let := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + intro L h1 + refine prop29 P P₀ L ((indOf : C ⥤ Ind C).obj Z) + ((indOf : C ⥤ Ind C).obj (Zᘁ)) h1 ⟨lam, ?_⟩ + exact (schurKilled_indOf ψ P Z lam).mpr hkill + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndMonoidal.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndMonoidal.lean new file mode 100644 index 0000000000..f50cabb833 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndMonoidal.lean @@ -0,0 +1,134 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndDayClosure + +/-! +# The monoidal structure on ind-objects + +Deligne's 2.2: the tensor product of a small ℂ-tensorielle +category extends to its ind-completion by +`(colim Xᵢ) ⊗ (colim Yⱼ) = colim (Xᵢ ⊗ Yⱼ)`. Here the extension +is packaged through Day convolution: presheaves on `C` carry the +Day monoidal structure (`Cᵒᵖ ⊛⥤ Type v`, with the instances of +`DayType.lean`), the ind-objects are closed under it — the Day +tensor preserves colimits in each variable and sends a pair of +representables to the representable of the tensor — and `Ind C` +inherits the structure through `Ind.equivalence` and the full +monoidal subcategory of the ind-property. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v + +variable (C : Type v) + +/-- The ind-property, read on the Day synonym of the presheaf +category. -/ +def IsIndDay [SmallCategory C] [MonoidalCategory C] + (F : MonoidalCategory.DayFunctor Cᵒᵖ (Type v)) : Prop := + IsIndObject F.functor + +/-- The ind-property is monoidal: it holds for the unit and is +stable under the Day tensor. -/ +instance isIndDay_isMonoidal [SmallCategory C] [MonoidalCategory C] : + ObjectProperty.IsMonoidal (IsIndDay C) where + prop_unit := isIndObject_day_unit C + prop_tensor _ _ h₁ h₂ := isIndObject_day_tensor h₁ h₂ + +/-- The full subcategory of ind-objects of the Day presheaf +category is monoidal. -/ +noncomputable example + [SmallCategory C] [MonoidalCategory C] : MonoidalCategory + (ObjectProperty.FullSubcategory + (C := MonoidalCategory.DayFunctor Cᵒᵖ (Type v)) + (IsIndDay C)) := + inferInstance + +/-- The ind-property respects isomorphisms. -/ +instance isIndDay_closedUnderIso [SmallCategory C] [MonoidalCategory C] : + ObjectProperty.IsClosedUnderIsomorphisms (IsIndDay C) where + of_iso e h := IsIndObject.map (dayFunctorIso e).hom h + +/-- The wrapper equivalence between the ind-subcategory of the +presheaf category and the ind-subcategory of its Day synonym. -/ +noncomputable def indDayCongr [SmallCategory C] [MonoidalCategory C] : + ObjectProperty.FullSubcategory + (IsIndObject (C := C)) ≌ + ObjectProperty.FullSubcategory + (C := MonoidalCategory.DayFunctor Cᵒᵖ (Type v)) + (IsIndDay C) where + functor := ObjectProperty.lift _ + (ObjectProperty.ι _ ⋙ + (MonoidalCategory.DayFunctor.equiv Cᵒᵖ (Type v)).inverse) + (fun X => X.2) + inverse := ObjectProperty.lift _ + (ObjectProperty.ι _ ⋙ + (MonoidalCategory.DayFunctor.equiv Cᵒᵖ (Type v)).functor) + (fun X => X.2) + unitIso := (ObjectProperty.fullyFaithfulι _).whiskeringRight _ + |>.preimageIso ((ObjectProperty.ι _).isoWhiskerLeft + (MonoidalCategory.DayFunctor.equiv Cᵒᵖ (Type v)).symm.unitIso) + counitIso := (ObjectProperty.fullyFaithfulι _).whiskeringRight _ + |>.preimageIso ((ObjectProperty.ι _).isoWhiskerLeft + (MonoidalCategory.DayFunctor.equiv Cᵒᵖ (Type v)).symm.counitIso) + functor_unitIso_comp X := ObjectProperty.hom_ext _ + ((MonoidalCategory.DayFunctor.equiv Cᵒᵖ + (Type v)).symm.functor_unit_comp X.obj) + +/-- `Ind C` is equivalent to the monoidal full subcategory of +ind-objects of the Day presheaf category. -/ +noncomputable def indDayEquivalence [SmallCategory C] [MonoidalCategory C] : + Ind C ≌ ObjectProperty.FullSubcategory + (C := MonoidalCategory.DayFunctor Cᵒᵖ (Type v)) + (IsIndDay C) := + (Ind.equivalence C).trans (indDayCongr C) + +/-- **Deligne 2.2, structure half**: the tensor product of a small +monoidal category extends to its ind-completion — the Day tensor +structure transported across the indization equivalence. -/ +noncomputable instance indMonoidalCategory + [SmallCategory C] [MonoidalCategory C] : + MonoidalCategory (Ind C) := + Monoidal.transport ((indDayEquivalence C).symm) + +/-- The opposite of a symmetric category is symmetric (the braided +instance exists in Mathlib at this pin; the symmetric one does +not). -/ +instance symmetricCategoryOp {D : Type*} [Category D] + [MonoidalCategory D] [SymmetricCategory D] : + SymmetricCategory Dᵒᵖ where + symmetry X Y := by + change (β_ (Opposite.unop Y) (Opposite.unop X)).hom.op ≫ + (β_ (Opposite.unop X) (Opposite.unop Y)).hom.op = 𝟙 _ + rw [← op_comp, SymmetricCategory.symmetry] + rfl + +/-- The braiding transports as well: `Ind C` of a braided small +category is braided. -/ +noncomputable instance indBraidedCategory [SmallCategory C] [MonoidalCategory C] + [BraidedCategory C] : + BraidedCategory (Ind C) := + inferInstanceAs + (BraidedCategory (Monoidal.Transported ((indDayEquivalence C).symm))) + +/-- And the symmetry: `Ind C` of a symmetric small category is +symmetric. -/ +noncomputable instance indSymmetricCategory + [SmallCategory C] [MonoidalCategory C] + [SymmetricCategory C] : + SymmetricCategory (Ind C) := + inferInstanceAs + (SymmetricCategory (Monoidal.Transported ((indDayEquivalence C).symm))) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfLinear.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfLinear.lean new file mode 100644 index 0000000000..53a695d122 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfLinear.lean @@ -0,0 +1,148 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaCountable +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchurKilled + +/-! +# ℂ-linearity of the embedding `C ⥤ Ind C` + +For an *arbitrary* pair of ℂ-linear structures on `C` and on `Ind C` +the embedding `RS.indOf` need not be ℂ-linear: two ring maps +`ℂ → End (𝟙_ (Ind C))` can differ by a field automorphism of ℂ, and +nothing ties the structure upstairs to the one downstairs. That is +why `RS.IndOfLinear` is carried as a hypothesis in +`RS.Classical.Deligne.GammaCountable`. + +The structures this development actually installs are not arbitrary. +Both come from a single scalar unit `ψ : ℂ ≃+* End (𝟙_ C)`, by +`RS.linearOfScalarUnit ψ` downstairs and +`RS.linearOfScalarUnit (indScalarUnit ψ)` upstairs, and +`RS.indScalarUnit ψ` is by construction the transport of `ψ` along +the embedding and the unit comparison `RS.indOfUnitIso` +(`RS.indScalarUnit_apply`, which is a `rfl`). For that pair the +scalar action on either side is conjugation of a unit endomorphism +through the left unitor, and the embedding is strong monoidal +(`RS.indOfMonoidal`), so it carries the one conjugate to the other: +this is `RS.indOf_map_scalarSmul`. + +This file reads that transport in the language of the installed +module structures: + +* `RS.indOf_linear` — `indOf.map (c • f) = c • indOf.map f` under the + two `letI`-installed structures; +* `RS.indOfFunctorLinear` — the same, packaged as Mathlib's + `CategoryTheory.Functor.Linear ℂ indOf`; +* `RS.indOfLinear_of_scalarUnit` — the same, in the shape + `RS.IndOfLinear C` in which `RS.Classical.Deligne.GammaCountable` + consumes it, so that the hypothesis is discharged for the scalar-unit + structures. + +The additive law is `RS.indOf_additive`; this module proves scalar +compatibility. No compatibility between `ψ` +and an ambient linear structure is asked, and no braiding is needed: +both actions are defined from the same `ψ`, and the proof uses only +the unitality of the strong monoidal structure of the embedding. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v + +noncomputable section + +/-! ## The scalar half, for the installed structures -/ + +section Installed + +variable {C : Type v} + +/-- **The embedding `C ⥤ Ind C` is ℂ-linear** for the two ℂ-linear +structures induced by a single scalar unit `ψ`: `RS.scalarSmul` is +what `•` means on both sides, and `RS.indOf_map_scalarSmul` transports +the one to the other. -/ +theorem indOf_linear [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [MonoidalPreadditive C] + (ψ : ℂ ≃+* End (𝟙_ C)) : + letI := linearOfScalarUnit ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + ∀ {X Y : C} (c : ℂ) (f : X ⟶ Y), + (indOf : C ⥤ Ind C).map (c • f) = + c • (indOf : C ⥤ Ind C).map f := by + let := linearOfScalarUnit ψ + let := linearOfScalarUnit (indScalarUnit ψ) + intro X Y c f + exact indOf_map_scalarSmul ψ c f + +/-- `RS.indOf_linear`, packaged as Mathlib's linearity class for a +functor. -/ +theorem indOfFunctorLinear + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [MonoidalPreadditive C] + (ψ : ℂ ≃+* End (𝟙_ C)) : + letI := linearOfScalarUnit ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + Functor.Linear ℂ (indOf : C ⥤ Ind C) := by + let := linearOfScalarUnit ψ + let := linearOfScalarUnit (indScalarUnit ψ) + exact ⟨fun f c => indOf_map_scalarSmul ψ c f⟩ + +end Installed + +/-! ## Discharging the hypothesis of the countability lane -/ + +section Hypothesis + +variable {C : Type v} + +/-- **The ℂ-linearity hypothesis of +`RS.Classical.Deligne.GammaCountable` holds for the scalar-unit +structures**: `RS.IndOfLinear C` is exactly `RS.indOf_linear`, read at +the two structures induced by `ψ`. -/ +theorem indOfLinear_of_scalarUnit + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [MonoidalPreadditive C] + (ψ : ℂ ≃+* End (𝟙_ C)) : + letI := linearOfScalarUnit ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + IndOfLinear C := by + let := linearOfScalarUnit ψ + let := linearOfScalarUnit (indScalarUnit ψ) + exact fun _ _ c f => indOf_map_scalarSmul ψ c f + +end Hypothesis + +/-! ## Acceptance -/ + +section Acceptance + +variable {C : Type v} + +/- The ℂ-linear full faithfulness of the embedding, which +`RS.Classical.Deligne.GammaCountable` builds from the hypothesis, is +therefore available outright for the scalar-unit structures. -/ +example + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [MonoidalPreadditive C] + (ψ : ℂ ≃+* End (𝟙_ C)) (X Y : C) : + letI := linearOfScalarUnit ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + (X ⟶ Y) ≃ₗ[ℂ] ((indOf : C ⥤ Ind C).obj X ⟶ indOf.obj Y) := + letI := linearOfScalarUnit ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + indOfHomEquiv (indOfLinear_of_scalarUnit ψ) X Y + +end Acceptance + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfMonoidal.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfMonoidal.lean new file mode 100644 index 0000000000..eada19ccb4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfMonoidal.lean @@ -0,0 +1,400 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurTransport + +/-! +# The embedding `C ⥤ Ind C` as a strong braided monoidal functor + +`RS.Classical.Deligne.IndSchur` assembles the comparison data of the +embedding `RS.indOf : C ⥤ Ind C` — the unit comparison +`RS.indOfUnitIso`, the tensor comparison `RS.indOfTensorIso`, and their +compatibility with the associator and the braiding. This file supplies +the two remaining coherences, the unitalities, and packages the whole as +the Mathlib classes: + +* `RS.indOfLaxMonoidal` — `indOf` is lax monoidal, with `ε` the forward + direction of `RS.indOfUnitIso` and `μ` that of `RS.indOfTensorIso`; +* `RS.indOfMonoidal` — the comparisons are isomorphisms, so `indOf` is + strong monoidal, with `RS.indOfMonoidal_εIso`/`RS.indOfMonoidal_μIso` + and `RS.indOf_oplax_η`/`RS.indOf_oplax_δ` reading off the packaged + data; +* `RS.indOfBraided` — and braided, for `C` braided. + +The two coherences that `RS.Classical.Deligne.IndSchur` does not +already supply are the unitalities +`RS.indOfUnitIso_hom_leftUnitor` and +`RS.indOfUnitIso_hom_rightUnitor`. The left one is +`RS.indOf_leftUnitor_hom` of `RS.Classical.Deligne.SchurTransport`, +which also carries the Day-level `RS.dayCoyonedaIso_hom_leftUnitor` +and its Yoneda form `RS.dayYonedaIso_hom_leftUnitor`; this file +supplies the mirror-image right-handed calculus, +`RS.dayCoyonedaIso_hom_rightUnitor` and +`RS.dayYonedaIso_hom_rightUnitor`. + +The unitalities are proved the same way as the associativity: the +embedding `RS.indToDay` into the Day presheaf category is fully faithful +and monoidal, so it suffices to prove the corresponding identities for +the Day comparison `RS.dayYonedaIso` and the Day unit `RS.dayUnitIso`. +Those are decided, as everywhere in this lane, by evaluating both sides +on the canonical element `RS.dayCoyonedaUnitElt`: the Day unitors are +characterised on the Kan-extension unit by the `leftUnitor_hom_unit_app` +and `rightUnitor_hom_unit_app` fields of Mathlib's +`CategoryTheory.MonoidalCategory.LawfulDayConvolutionMonoidalCategoryStruct`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory MonoidalCategory.DayFunctor Limits +open Opposite + +universe v + +noncomputable section + +section DayRightUnitCalculus + +attribute [local instance] dayConv dayConvPlain + +variable {D : Type v} + +/-- Left-whiskering the inverse of `RS.dayUnitIso` carries the canonical +element at `(a, 𝟙_ D)` to the Kan-extension unit element assembled from +the Day-unit element. -/ +lemma whiskerLeft_dayUnitIso_inv_app_unitElt + [SmallCategory D] [MonoidalCategory D] + (a : D) : + (DayFunctor.mk (coyoneda.obj (op a)) ◁ + (dayUnitIso D).inv).natTrans.app (a ⊗ 𝟙_ D) + (dayCoyonedaUnitElt a (𝟙_ D)) = + (η (DayFunctor.mk (coyoneda.obj (op a))) + (𝟙_ (D ⊛⥤ Type v))).app (a, 𝟙_ D) + ((𝟙 a, ν D (Type v) PUnit.unit)) := by + have h₀ := congrArg (fun t => t.app (a ⊗ 𝟙_ D)) + (natTrans_whiskerLeft (DayFunctor.mk (coyoneda.obj (op a))) + (dayUnitIso D).inv) + have h₁ := ConcreteCategory.congr_hom h₀ (dayCoyonedaUnitElt a (𝟙_ D)) + have h₂' := DayConvolution.unit_app_map_app + (f := 𝟙 ((DayFunctor.mk (coyoneda.obj (op a))).functor)) + (g := (dayUnitIso D).inv.natTrans) + (x := a) (y := 𝟙_ D) + have h₂ : (DayConvolution.map + (𝟙 ((DayFunctor.mk (coyoneda.obj (op a))).functor)) + (dayUnitIso D).inv.natTrans).app + (a ⊗ 𝟙_ D) (dayCoyonedaUnitElt a (𝟙_ D)) = + (η (DayFunctor.mk (coyoneda.obj (op a))) + (𝟙_ (D ⊛⥤ Type v))).app (a, 𝟙_ D) + ((𝟙 a, (dayUnitIso D).inv.natTrans.app (𝟙_ D) (𝟙 (𝟙_ D)))) := + ConcreteCategory.congr_hom h₂' + ((𝟙 a, 𝟙 (𝟙_ D)) : (a ⟶ a) × (𝟙_ D ⟶ 𝟙_ D)) + rw [h₁] + refine h₂.trans ?_ + exact congrArg + (fun z => (η (DayFunctor.mk (coyoneda.obj (op a))) + (𝟙_ (D ⊛⥤ Type v))).app (a, 𝟙_ D) + ((𝟙 a, z) : + (a ⟶ a) × ((𝟙_ (D ⊛⥤ Type v)).functor.obj (𝟙_ D)))) + dayUnitIso_inv_app_id + +/-- The Day right unitor, characterised on the Kan-extension unit. -/ +lemma dayRightUnitor_hom_unit [SmallCategory D] [MonoidalCategory D] + (K : D ⊛⥤ Type v) (y : D) : + (K.functor.obj y ◁ ν D (Type v)) ≫ + (η K (𝟙_ (D ⊛⥤ Type v))).app (y, 𝟙_ D) ≫ + (ρ_ K).hom.natTrans.app (y ⊗ 𝟙_ D) = + (ρ_ (K.functor.obj y)).hom ≫ K.functor.map (ρ_ y).inv := + LawfulDayConvolutionMonoidalCategoryStruct.rightUnitor_hom_unit_app + (Type v) K y + +/-- Evaluation of the Day right unitor on the canonical element built +from the Day-unit element. -/ +lemma dayRightUnitor_hom_app_unitElt [SmallCategory D] [MonoidalCategory D] + (a : D) : + (ρ_ (DayFunctor.mk (coyoneda.obj (op a)) : + D ⊛⥤ Type v)).hom.natTrans.app (a ⊗ 𝟙_ D) + ((η (DayFunctor.mk (coyoneda.obj (op a))) + (𝟙_ (D ⊛⥤ Type v))).app (a, 𝟙_ D) + ((𝟙 a, ν D (Type v) PUnit.unit))) = (ρ_ a).inv := by + have h := ConcreteCategory.congr_hom + (dayRightUnitor_hom_unit (DayFunctor.mk (coyoneda.obj (op a))) a) + ((𝟙 a, PUnit.unit) : (a ⟶ a) × PUnit.{v + 1}) + exact h.trans (Category.id_comp _) + +/-- **Day convolution of corepresentables intertwines the right +unitor**. -/ +lemma dayCoyonedaIso_hom_rightUnitor [SmallCategory D] [MonoidalCategory D] + (a : D) : + (dayCoyonedaIso a (𝟙_ D)).hom ≫ + (⟨coyoneda.map ((ρ_ a).inv.op)⟩ : + DayFunctor.mk (coyoneda.obj (op (a ⊗ 𝟙_ D))) ⟶ + DayFunctor.mk (coyoneda.obj (op a))) = + (DayFunctor.mk (coyoneda.obj (op a)) ◁ (dayUnitIso D).inv) ≫ + (ρ_ (DayFunctor.mk (coyoneda.obj (op a)) : + D ⊛⥤ Type v)).hom := by + apply (dayCoyonedaCorepresentableBy a (𝟙_ D)).homEquiv.injective + change (coyoneda.map ((ρ_ a).inv.op)).app (a ⊗ 𝟙_ D) + ((dayCoyonedaIso a (𝟙_ D)).hom.natTrans.app (a ⊗ 𝟙_ D) + (dayCoyonedaUnitElt a (𝟙_ D))) = + (ρ_ (DayFunctor.mk (coyoneda.obj (op a)) : D ⊛⥤ Type v)).hom.natTrans.app + (a ⊗ 𝟙_ D) + ((DayFunctor.mk (coyoneda.obj (op a)) ◁ (dayUnitIso D).inv).natTrans.app + (a ⊗ 𝟙_ D) (dayCoyonedaUnitElt a (𝟙_ D))) + rw [dayCoyonedaIso_hom_app_unitElt, + whiskerLeft_dayUnitIso_inv_app_unitElt, dayRightUnitor_hom_app_unitElt] + exact Category.comp_id _ + +end DayRightUnitCalculus + +section YonedaUnitTransport + +variable {C : Type v} + +/-- The Day unit is the representable presheaf at the unit of `C`: the +Yoneda form of `RS.dayUnitIso`. -/ +def dayYonedaUnitIso [SmallCategory C] [MonoidalCategory C] : + 𝟙_ (Cᵒᵖ ⊛⥤ Type v) ≅ DayFunctor.mk (yoneda.obj (𝟙_ C)) := + dayUnitIso Cᵒᵖ ≪≫ dayMkIso (Coyoneda.objOpOp (𝟙_ C)) + +/-- **The Day tensor of representables intertwines the right unitor**: +the Yoneda form of `RS.dayCoyonedaIso_hom_rightUnitor`. -/ +lemma dayYonedaIso_hom_rightUnitor [SmallCategory C] [MonoidalCategory C] + (x : C) : + (DayFunctor.mk (yoneda.obj x) ◁ (dayYonedaUnitIso (C := C)).hom) ≫ + (dayYonedaIso x (𝟙_ C)).hom ≫ ⟨yoneda.map (ρ_ x).hom⟩ = + (ρ_ (DayFunctor.mk (yoneda.obj x) : Cᵒᵖ ⊛⥤ Type v)).hom := by + have s₂ : (⟨coyoneda.map ((ρ_ x).hom.op.op)⟩ : + DayFunctor.mk (coyoneda.obj (op (op (x ⊗ 𝟙_ C)))) ⟶ + DayFunctor.mk (coyoneda.obj (op (op x)))) ≫ + (dayMkIso (Coyoneda.objOpOp x)).hom = + (dayMkIso (Coyoneda.objOpOp (x ⊗ 𝟙_ C))).hom ≫ + ⟨yoneda.map (ρ_ x).hom⟩ := by + ext1 + exact coyoneda_map_op_op_comp_objOpOp_hom (ρ_ x).hom + have hR : (dayCoyonedaIso (op x) (op (𝟙_ C))).hom ≫ + (⟨coyoneda.map ((ρ_ x).hom.op.op)⟩ : + DayFunctor.mk (coyoneda.obj (op (op (x ⊗ 𝟙_ C)))) ⟶ + DayFunctor.mk (coyoneda.obj (op (op x)))) = + (DayFunctor.mk (coyoneda.obj (op (op x))) ◁ + (dayUnitIso Cᵒᵖ).inv) ≫ + (ρ_ (DayFunctor.mk (coyoneda.obj (op (op x))) : + Cᵒᵖ ⊛⥤ Type v)).hom := + dayCoyonedaIso_hom_rightUnitor (D := Cᵒᵖ) (op x) + have hcomp : ((dayUnitIso Cᵒᵖ).hom ≫ + (dayMkIso (Coyoneda.objOpOp (𝟙_ C))).hom) ≫ + (dayMkIso (Coyoneda.objOpOp (𝟙_ C)).symm).hom = + (dayUnitIso Cᵒᵖ).hom := by + rw [Category.assoc, dayMkIso_hom_symm_hom] + exact Category.comp_id _ + have e₁ : (DayFunctor.mk (yoneda.obj x) ◁ + ((dayUnitIso Cᵒᵖ).hom ≫ + (dayMkIso (Coyoneda.objOpOp (𝟙_ C))).hom)) ≫ + ((dayMkIso (Coyoneda.objOpOp x).symm).hom ⊗ₘ + (dayMkIso (Coyoneda.objOpOp (𝟙_ C)).symm).hom) = + (dayMkIso (Coyoneda.objOpOp x).symm).hom ⊗ₘ + (dayUnitIso Cᵒᵖ).hom := by + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, Category.id_comp, + hcomp] + have e₂ : ((dayMkIso (Coyoneda.objOpOp x).symm).hom ⊗ₘ + (dayUnitIso Cᵒᵖ).hom) ≫ + (DayFunctor.mk (coyoneda.obj (op (op x))) ◁ + (dayUnitIso Cᵒᵖ).inv) = + (dayMkIso (Coyoneda.objOpOp x).symm).hom ▷ + (𝟙_ (Cᵒᵖ ⊛⥤ Type v)) := by + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, Iso.hom_inv_id, + Category.comp_id, MonoidalCategory.tensorHom_id] + have e₃ : (dayMkIso (Coyoneda.objOpOp x).symm).hom ≫ + (dayMkIso (Coyoneda.objOpOp x)).hom = + 𝟙 (DayFunctor.mk (yoneda.obj x) : Cᵒᵖ ⊛⥤ Type v) := + dayMkIso_hom_symm_hom (Coyoneda.objOpOp x).symm + simp only [dayYonedaUnitIso, dayYonedaIso, Iso.trans_hom, tensorIso_hom, + Category.assoc] + rw [← s₂, ← Category.assoc, e₁, reassoc_of% hR, ← Category.assoc, e₂, + MonoidalCategory.rightUnitor_naturality_assoc, e₃, Category.comp_id] + +end YonedaUnitTransport + +section IndUnitality + +variable {C : Type v} + +/-- The embedding into the Day presheaf category carries the unit +comparison to the Day unit: the `RS.dayYonedaUnitIso` reading of +`RS.indToDay_map_indOfUnitIso_hom`. -/ +lemma indToDay_map_indOfUnitIso_hom_dayYonedaUnitIso + [SmallCategory C] [MonoidalCategory C] : + (indToDay (C := C)).map indOfUnitIso.hom = + Functor.OplaxMonoidal.η (indToDay (C := C)) ≫ + (dayYonedaUnitIso (C := C)).hom ≫ + (indToDayIndOfIso (𝟙_ C)).inv := by + rw [indToDay_map_indOfUnitIso_hom, Functor.Monoidal.εIso_inv] + simp only [dayYonedaUnitIso, Iso.trans_hom, Category.assoc] + +/-- **The unit and tensor comparisons satisfy left unitality**: the +left-unitality axiom of the monoidal structure of `indOf`. This is +`RS.indOf_leftUnitor_hom` read in the direction the `LaxMonoidal` +field wants. -/ +lemma indOfUnitIso_hom_leftUnitor [SmallCategory C] [MonoidalCategory C] + (x : C) : + (indOfUnitIso.hom ▷ indOf.obj x) ≫ + (indOfTensorIso (𝟙_ C) x).hom ≫ indOf.map (λ_ x).hom = + (λ_ (indOf.obj x)).hom := + (indOf_leftUnitor_hom x).symm + +/-- **The unit and tensor comparisons satisfy right unitality**: the +right-unitality axiom of the monoidal structure of `indOf`. -/ +lemma indOfUnitIso_hom_rightUnitor [SmallCategory C] [MonoidalCategory C] + (x : C) : + (indOf.obj x ◁ indOfUnitIso.hom) ≫ + (indOfTensorIso x (𝟙_ C)).hom ≫ indOf.map (ρ_ x).hom = + (ρ_ (indOf.obj x)).hom := by + apply (indToDay (C := C)).map_injective + rw [Functor.map_comp, Functor.map_comp, + Functor.Monoidal.map_whiskerLeft (F := indToDay (C := C)), + Functor.Monoidal.map_rightUnitor (F := indToDay (C := C)), + indToDay_map_indOfTensorIso_hom, + indToDay_map_indOfUnitIso_hom_dayYonedaUnitIso] + simp only [indToDayTensorIso, Iso.trans_hom, Iso.symm_hom, + tensorIso_hom, Functor.Monoidal.μIso_inv, Category.assoc, + Functor.Monoidal.μ_δ_assoc] + have hq : (ρ_ ((indToDay (C := C)).obj (indOf.obj x))).hom = + ((indToDayIndOfIso x).hom ▷ (𝟙_ (Cᵒᵖ ⊛⥤ Type v))) ≫ + (ρ_ (DayFunctor.mk (yoneda.obj x) : Cᵒᵖ ⊛⥤ Type v)).hom ≫ + (indToDayIndOfIso x).inv := by + rw [MonoidalCategory.rightUnitor_naturality_assoc, Iso.hom_inv_id, + Category.comp_id] + have hright : ((indToDay (C := C)).obj (indOf.obj x) ◁ + (Functor.OplaxMonoidal.η (indToDay (C := C)) ≫ + (dayYonedaUnitIso (C := C)).hom ≫ + (indToDayIndOfIso (𝟙_ C)).inv)) ≫ + ((indToDayIndOfIso x).hom ⊗ₘ (indToDayIndOfIso (𝟙_ C)).hom) = + ((indToDayIndOfIso x).hom ⊗ₘ + Functor.OplaxMonoidal.η (indToDay (C := C))) ≫ + (DayFunctor.mk (yoneda.obj x) ◁ + (dayYonedaUnitIso (C := C)).hom) := by + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, Category.id_comp, + Category.assoc, Category.assoc, Iso.inv_hom_id, Category.comp_id, + ← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, Category.comp_id] + have htd : ((indToDay (C := C)).obj (indOf.obj x) ◁ + Functor.OplaxMonoidal.η (indToDay (C := C))) ≫ + ((indToDayIndOfIso x).hom ▷ (𝟙_ (Cᵒᵖ ⊛⥤ Type v))) = + (indToDayIndOfIso x).hom ⊗ₘ + Functor.OplaxMonoidal.η (indToDay (C := C)) := + (MonoidalCategory.tensorHom_def' _ _).symm + rw [← comp_indToDayIndOfIso_inv, hq] + rw [reassoc_of% hright, reassoc_of% htd, + reassoc_of% dayYonedaIso_hom_rightUnitor x] + +end IndUnitality + +section Instances + +variable {C : Type v} + +/-- **The embedding `C ⥤ Ind C` is lax monoidal**: the unit comparison +`RS.indOfUnitIso` and the tensor comparison `RS.indOfTensorIso` satisfy +the five coherences. -/ +noncomputable instance indOfLaxMonoidal [SmallCategory C] [MonoidalCategory C] : + (indOf (C := C)).LaxMonoidal where + ε := indOfUnitIso.hom + μ x y := (indOfTensorIso x y).hom + μ_natural_left f x' := indOfTensorIso_hom_natural_left f x' + μ_natural_right x' f := indOfTensorIso_hom_natural_right x' f + associativity x y z := indOfTensorIso_hom_associator x y z + left_unitality x := (indOfUnitIso_hom_leftUnitor x).symm + right_unitality x := (indOfUnitIso_hom_rightUnitor x).symm + +/-- **The embedding `C ⥤ Ind C` is strong monoidal**: both comparisons +are isomorphisms by construction. -/ +noncomputable instance indOfMonoidal + [SmallCategory C] [MonoidalCategory C] : (indOf (C := C)).Monoidal := + haveI : IsIso (Functor.LaxMonoidal.ε (indOf (C := C))) := + (indOfUnitIso (C := C)).isIso_hom + haveI : ∀ x y : C, + IsIso (Functor.LaxMonoidal.μ (indOf (C := C)) x y) := + fun x y => (indOfTensorIso x y).isIso_hom + Functor.Monoidal.ofLaxMonoidal _ + +/-- **The embedding `C ⥤ Ind C` is braided**. -/ +noncomputable instance indOfBraided [SmallCategory C] [MonoidalCategory C] + [BraidedCategory C] : + (indOf (C := C)).Braided where + toMonoidal := indOfMonoidal + braided x y := (indOfTensorIso_hom_braiding x y).symm + +/-- The unit comparison of the strong monoidal structure is +`RS.indOfUnitIso`. -/ +lemma indOfMonoidal_εIso [SmallCategory C] [MonoidalCategory C] : + Functor.Monoidal.εIso (indOf (C := C)) = indOfUnitIso := + Iso.ext rfl + +/-- The tensor comparison of the strong monoidal structure is +`RS.indOfTensorIso`. -/ +lemma indOfMonoidal_μIso [SmallCategory C] [MonoidalCategory C] + (x y : C) : + Functor.Monoidal.μIso (indOf (C := C)) x y = indOfTensorIso x y := + Iso.ext rfl + +/-- The counit of the strong monoidal structure is the inverse of +`RS.indOfUnitIso`. -/ +lemma indOf_oplax_η [SmallCategory C] [MonoidalCategory C] : + Functor.OplaxMonoidal.η (indOf (C := C)) = indOfUnitIso.inv := by + rw [← Functor.Monoidal.εIso_inv, indOfMonoidal_εIso] + +/-- The cotensorator of the strong monoidal structure is the inverse of +`RS.indOfTensorIso`. -/ +lemma indOf_oplax_δ [SmallCategory C] [MonoidalCategory C] + (x y : C) : + Functor.OplaxMonoidal.δ (indOf (C := C)) x y = + (indOfTensorIso x y).inv := by + rw [← Functor.Monoidal.μIso_inv, indOfMonoidal_μIso] + +end Instances + +section AcceptanceTests + +/- Synthesis tests for the three instances of this file. -/ + +noncomputable example (C : Type v) [SmallCategory C] + [MonoidalCategory C] : (indOf (C := C)).LaxMonoidal := + inferInstance + +noncomputable example (C : Type v) [SmallCategory C] + [MonoidalCategory C] : (indOf (C := C)).Monoidal := + inferInstance + +noncomputable example (C : Type v) [SmallCategory C] + [MonoidalCategory C] [BraidedCategory C] : + (indOf (C := C)).Braided := + inferInstance + +noncomputable example (C : Type v) [SmallCategory C] + [MonoidalCategory C] [BraidedCategory C] : + (indOf (C := C)).LaxBraided := + inferInstance + +/- The packaged comparisons are the ones of record. -/ + +example (C : Type v) [SmallCategory C] [MonoidalCategory C] : + Functor.LaxMonoidal.ε (indOf (C := C)) = indOfUnitIso.hom := rfl + +example (C : Type v) [SmallCategory C] [MonoidalCategory C] + (x y : C) : + Functor.LaxMonoidal.μ (indOf (C := C)) x y = + (indOfTensorIso x y).hom := rfl + +end AcceptanceTests + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndPointTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndPointTensor.lean new file mode 100644 index 0000000000..cd07d89be1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndPointTensor.lean @@ -0,0 +1,317 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchur +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitStage + +/-! +# Points tensor without vanishing in the ind-completion + +`RS.Classical.Deligne.PointTensor` proves, in an abelian ℂ-linear +rigid monoidal category with scalar unit, that the tensor of two +nonzero points of the unit is nonzero. This file carries that +statement across the embedding `C ⥤ Ind C` to the whole +ind-completion — the fact Deligne asserts in 2.11 when he says the +algebra `𝔸` is not zero, since the unit of a tensor product of +algebras is `(λ_ _).inv ≫ (η ⊗ₘ η)`. + +The route is compactness, applied twice. + +* `RS.indOfTensorIso_hom_natural` — the embedding-tensor comparison + is natural in both variables at once, assembled from the two + one-variable naturalities of `RS.Classical.Deligne.IndTensorExact`; +* `RS.exists_indOf_point` — a point of an embedded object is the + embedding of a point downstairs, and vanishes only if that one + does (`RS.indOfUnitIso` and `RS.indOf_map_eq_zero_iff`); +* `RS.indTensorHom_point_ne_zero_indOf` — the statement for two + embedded objects, obtained by conjugating with the unit comparison + `RS.indOfUnitIso` and the embedding-tensor comparison and appealing + to `RS.tensorHom_point_ne_zero` downstairs; +* `RS.tensor_unit_point_stage_left`/`_right` — the finite-stage + engine: if the tensor of a point with a point of a filtered + colimit vanishes, it already vanishes at some stage of the + diagram. Tensoring preserves filtered colimits + (`RS.tensorLeft_ind_preservesFilteredColimits`) and the unit of + `Ind C` is compact (`RS.unit_colimit_eq_zero_iff`); +* `RS.indTensorHom_point_ne_zero_indOf_left` — one embedded factor + and one arbitrary, by presenting the second factor as a filtered + colimit of embedded objects; +* **`RS.indTensorHom_point_ne_zero`** — both factors arbitrary, by + the same descent in the first factor. + +The filtered-colimit presentations are Mathlib's: `Ind.presentation` +and `Ind.colimitPresentationCompYoneda` exhibit every ind-object as +the colimit of `X.presentation.F ⋙ Ind.yoneda` over the filtered +index category `X.presentation.I`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Limits MonoidalCategory + +universe v u + +noncomputable section + +/-! ## Transport of a vanishing composite along a preserved colimit -/ + +section Preserve + +variable {𝒜 : Type u} + +/-- If a morphism into the image of a stage dies against the image +of a colimit injection, it dies against the colimit injection of the +transported diagram. Stated with the domain written as +`F.obj (D.obj i)` so that every composite below is type-correct +without unfolding `Functor.comp`. -/ +theorem comp_ι_comp_eq_zero [Category.{v} 𝒜] [HasZeroMorphisms 𝒜] + {I : Type v} [SmallCategory I] + (D : I ⥤ 𝒜) [HasColimit D] (F : 𝒜 ⥤ 𝒜) [PreservesColimit D F] + {i : I} {W : 𝒜} (w : W ⟶ F.obj (D.obj i)) + (h : w ≫ F.map (colimit.ι D i) = 0) : + w ≫ colimit.ι (D ⋙ F) i = 0 := + calc w ≫ colimit.ι (D ⋙ F) i + = w ≫ (F.map (colimit.ι D i) ≫ + (preservesColimitIso F D).hom) := + whisker_eq w (ι_preservesColimitIso_hom F D i).symm + _ = (w ≫ F.map (colimit.ι D i)) ≫ + (preservesColimitIso F D).hom := + (Category.assoc _ _ _).symm + _ = 0 ≫ (preservesColimitIso F D).hom := by rw [h] + _ = 0 := Limits.zero_comp + +end Preserve + +/-! ## The embedding-tensor comparison in both variables -/ + +section Naturality + +variable {C : Type v} + +/-- **Naturality of the embedding-tensor comparison in both +variables at once**: `RS.indOfTensorIso` intertwines the tensor of +two embedded morphisms with the embedding of their tensor. The +two one-variable naturalities compose along +`MonoidalCategory.tensorHom_def`. -/ +theorem indOfTensorIso_hom_natural [SmallCategory C] [MonoidalCategory C] + {x x' y y' : C} (f : x ⟶ x') + (g : y ⟶ y') : + (indOf.map f ⊗ₘ indOf.map g) ≫ (indOfTensorIso x' y').hom = + (indOfTensorIso x y).hom ≫ indOf.map (f ⊗ₘ g) := by + rw [tensorHom_def, Category.assoc, indOfTensorIso_hom_natural_right, + ← Category.assoc, indOfTensorIso_hom_natural_left, Category.assoc, + ← Functor.map_comp, ← tensorHom_def] + +end Naturality + +/-! ## Both factors embedded -/ + +section Embedded + +variable {C : Type v} + +/-- **A point of an embedded object comes from downstairs**: read +through the unit comparison `RS.indOfUnitIso`, it is the embedding of +a point of the object in `C`, and that point is nonzero whenever the +original is. -/ +theorem exists_indOf_point [SmallCategory C] [MonoidalCategory C] [Abelian C] + {X : C} (u : 𝟙_ (Ind C) ⟶ indOf.obj X) : + ∃ u₀ : 𝟙_ C ⟶ X, + indOf.map u₀ = (indOfUnitIso (C := C)).inv ≫ u ∧ + (u ≠ 0 → u₀ ≠ 0) := + ⟨Ind.yoneda.fullyFaithful.preimage _, + Ind.yoneda.fullyFaithful.map_preimage _, fun hne h0 => hne (by + have hz : (indOfUnitIso (C := C)).inv ≫ u = 0 := by + rw [← Ind.yoneda.fullyFaithful.map_preimage + ((indOfUnitIso (C := C)).inv ≫ u), h0] + exact ((indOf_map_eq_zero_iff (0 : 𝟙_ C ⟶ X)).mpr rfl) + exact (Preadditive.IsIso.comp_left_eq_zero _ _).mp hz)⟩ + +/-- **The tensor of two nonzero points of embedded objects is +nonzero**: the unit comparison and the embedding-tensor comparison +identify it with the embedding of the corresponding tensor +downstairs, which is nonzero by `RS.tensorHom_point_ne_zero`. -/ +theorem indTensorHom_point_ne_zero_indOf + [SmallCategory C] [MonoidalCategory C] [Abelian C] [Linear ℂ C] + [MonoidalPreadditive C] [MonoidalLinear ℂ C] [RigidCategory C] + (hu : HasScalarUnit C) + {X Y : C} {u : 𝟙_ (Ind C) ⟶ indOf.obj X} + {v : 𝟙_ (Ind C) ⟶ indOf.obj Y} (hu0 : u ≠ 0) (hv0 : v ≠ 0) : + (u ⊗ₘ v) ≠ 0 := by + intro h0 + obtain ⟨u₀, hu₀, hu₀0⟩ := exists_indOf_point u + obtain ⟨v₀, hv₀, hv₀0⟩ := exists_indOf_point v + have hzero : indOf.map u₀ ⊗ₘ indOf.map v₀ = 0 := by + rw [hu₀, hv₀, ← tensorHom_comp_tensorHom, h0] + exact Limits.comp_zero + have hmap : indOf.map (u₀ ⊗ₘ v₀) = 0 := by + have h1 := indOfTensorIso_hom_natural u₀ v₀ + rw [hzero, Limits.zero_comp] at h1 + exact (Preadditive.IsIso.comp_left_eq_zero _ _).mp h1.symm + exact tensorHom_point_ne_zero hu (hu₀0 hu0) (hv₀0 hv0) + ((indOf_map_eq_zero_iff (u₀ ⊗ₘ v₀)).mp hmap) + +end Embedded + +/-! ## The finite-stage engine -/ + +section Stage + +variable {C : Type v} + +/-- **Vanishing at a stage, second factor**: if the tensor of a +point of `M` with a point of a filtered colimit that factors through +the stage `i` vanishes, then it already vanishes after some +transition map out of `i`. Tensoring on the left preserves the +filtered colimit, and the unit of `Ind C` is compact. -/ +theorem tensor_unit_point_stage_left + [SmallCategory C] [MonoidalCategory C] [Abelian C] + {I : Type v} [SmallCategory I] + [IsFiltered I] (D : I ⥤ Ind C) (M : Ind C) {i : I} + (u : 𝟙_ (Ind C) ⟶ M) (g : 𝟙_ (Ind C) ⟶ D.obj i) + (h : u ⊗ₘ (g ≫ colimit.ι D i) = 0) : + ∃ (k : I) (α : i ⟶ k), u ⊗ₘ (g ≫ D.map α) = 0 := by + have hz : ((λ_ (𝟙_ (Ind C))).inv ≫ (u ⊗ₘ g)) ≫ + (tensorLeft M).map (colimit.ι D i) = 0 := by + have h1 : (u ⊗ₘ g) ≫ (M ◁ colimit.ι D i) = 0 := by + rw [tensorHom_comp_whiskerLeft] + exact h + have h2 : ((λ_ (𝟙_ (Ind C))).inv ≫ (u ⊗ₘ g)) ≫ + (M ◁ colimit.ι D i) = 0 := by + rw [Category.assoc, h1] + exact Limits.comp_zero + exact h2 + have hcol := comp_ι_comp_eq_zero D (tensorLeft M) + ((λ_ (𝟙_ (Ind C))).inv ≫ (u ⊗ₘ g)) hz + obtain ⟨k, α, hk⟩ := + (unit_colimit_eq_zero_iff (D ⋙ tensorLeft M) (i := i) + ((λ_ (𝟙_ (Ind C))).inv ≫ (u ⊗ₘ g))).mp hcol + refine ⟨k, α, ?_⟩ + have hk1 : ((λ_ (𝟙_ (Ind C))).inv ≫ (u ⊗ₘ g)) ≫ + (M ◁ D.map α) = 0 := hk + rw [Category.assoc] at hk1 + have hk2 : (u ⊗ₘ g) ≫ (M ◁ D.map α) = 0 := + (Preadditive.IsIso.comp_left_eq_zero _ _).mp hk1 + rw [tensorHom_comp_whiskerLeft] at hk2 + exact hk2 + +/-- **Vanishing at a stage, first factor**: the mirror image of +`RS.tensor_unit_point_stage_left`, using that tensoring on the right +preserves filtered colimits. -/ +theorem tensor_unit_point_stage_right + [SmallCategory C] [MonoidalCategory C] [Abelian C] + {I : Type v} [SmallCategory I] + [IsFiltered I] (D : I ⥤ Ind C) (N : Ind C) {i : I} + (f : 𝟙_ (Ind C) ⟶ D.obj i) (v : 𝟙_ (Ind C) ⟶ N) + (h : (f ≫ colimit.ι D i) ⊗ₘ v = 0) : + ∃ (k : I) (α : i ⟶ k), (f ≫ D.map α) ⊗ₘ v = 0 := by + have hz : ((λ_ (𝟙_ (Ind C))).inv ≫ (f ⊗ₘ v)) ≫ + (tensorRight N).map (colimit.ι D i) = 0 := by + have h1 : (f ⊗ₘ v) ≫ (colimit.ι D i ▷ N) = 0 := by + rw [tensorHom_comp_whiskerRight] + exact h + have h2 : ((λ_ (𝟙_ (Ind C))).inv ≫ (f ⊗ₘ v)) ≫ + (colimit.ι D i ▷ N) = 0 := by + rw [Category.assoc, h1] + exact Limits.comp_zero + exact h2 + have hcol := comp_ι_comp_eq_zero D (tensorRight N) + ((λ_ (𝟙_ (Ind C))).inv ≫ (f ⊗ₘ v)) hz + obtain ⟨k, α, hk⟩ := + (unit_colimit_eq_zero_iff (D ⋙ tensorRight N) (i := i) + ((λ_ (𝟙_ (Ind C))).inv ≫ (f ⊗ₘ v))).mp hcol + refine ⟨k, α, ?_⟩ + have hk1 : ((λ_ (𝟙_ (Ind C))).inv ≫ (f ⊗ₘ v)) ≫ + (D.map α ▷ N) = 0 := hk + rw [Category.assoc] at hk1 + have hk2 : (f ⊗ₘ v) ≫ (D.map α ▷ N) = 0 := + (Preadditive.IsIso.comp_left_eq_zero _ _).mp hk1 + rw [tensorHom_comp_whiskerRight] at hk2 + exact hk2 + +end Stage + +/-! ## The general statement -/ + +section Main + +variable {C : Type v} + +/-- **One embedded factor**: the tensor of a nonzero point of an +embedded object with a nonzero point of an arbitrary ind-object is +nonzero. Present the second factor as a filtered colimit of +embedded objects, factor the point through a stage, and use that a +vanishing tensor vanishes at a stage. -/ +theorem indTensorHom_point_ne_zero_indOf_left + [SmallCategory C] [MonoidalCategory C] [Abelian C] [Linear ℂ C] + [MonoidalPreadditive C] [MonoidalLinear ℂ C] [RigidCategory C] + (hu : HasScalarUnit C) + {X : C} {N : Ind C} {u : 𝟙_ (Ind C) ⟶ indOf.obj X} + {v : 𝟙_ (Ind C) ⟶ N} (hu0 : u ≠ 0) (hv0 : v ≠ 0) : + (u ⊗ₘ v) ≠ 0 := by + intro h0 + set D : N.presentation.I ⥤ Ind C := N.presentation.F ⋙ indOf + with hD + have e : colimit D ≅ N := Ind.colimitPresentationCompYoneda N + have hv' : v ≫ e.inv ≠ 0 := fun hz => + hv0 ((Preadditive.IsIso.comp_right_eq_zero _ _).mp hz) + obtain ⟨i, g, hg⟩ := exists_factor_of_unit_hom_colimit D (v ≫ e.inv) + have h0' : u ⊗ₘ (g ≫ colimit.ι D i) = 0 := by + rw [hg, ← tensorHom_comp_whiskerLeft, h0] + exact Limits.zero_comp + obtain ⟨k, α, hk⟩ := tensor_unit_point_stage_left D _ u g h0' + have hgα : g ≫ D.map α ≠ 0 := by + intro hz + refine hv' ?_ + rw [← hg, ← colimit.w D α, ← Category.assoc, hz] + exact Limits.zero_comp + have hgα' : (g ≫ D.map α : + 𝟙_ (Ind C) ⟶ indOf.obj (N.presentation.F.obj k)) ≠ 0 := hgα + exact indTensorHom_point_ne_zero_indOf (X := X) + (Y := N.presentation.F.obj k) hu hu0 hgα' hk + +/-- **The tensor of two nonzero points of the ind-completion is +nonzero** (Deligne 2.11, the nonvanishing of the algebra `𝔸`). +Present the first factor as a filtered colimit of embedded objects, +factor the point through a stage, and appeal to +`RS.indTensorHom_point_ne_zero_indOf_left`. -/ +theorem indTensorHom_point_ne_zero + [SmallCategory C] [MonoidalCategory C] [Abelian C] [Linear ℂ C] + [MonoidalPreadditive C] [MonoidalLinear ℂ C] [RigidCategory C] + (hu : HasScalarUnit C) + {M N : Ind C} {u : 𝟙_ (Ind C) ⟶ M} {v : 𝟙_ (Ind C) ⟶ N} + (hu0 : u ≠ 0) (hv0 : v ≠ 0) : (u ⊗ₘ v) ≠ 0 := by + intro h0 + set D : M.presentation.I ⥤ Ind C := M.presentation.F ⋙ indOf + with hD + have e : colimit D ≅ M := Ind.colimitPresentationCompYoneda M + have hu' : u ≫ e.inv ≠ 0 := fun hz => + hu0 ((Preadditive.IsIso.comp_right_eq_zero _ _).mp hz) + obtain ⟨i, f, hf⟩ := exists_factor_of_unit_hom_colimit D (u ≫ e.inv) + have h0' : (f ≫ colimit.ι D i) ⊗ₘ v = 0 := by + rw [hf, ← tensorHom_comp_whiskerRight, h0] + exact Limits.zero_comp + obtain ⟨k, α, hk⟩ := tensor_unit_point_stage_right D _ f v h0' + have hfα : f ≫ D.map α ≠ 0 := by + intro hz + refine hu' ?_ + rw [← hf, ← colimit.w D α, ← Category.assoc, hz] + exact Limits.zero_comp + have hfα' : (f ≫ D.map α : + 𝟙_ (Ind C) ⟶ indOf.obj (M.presentation.F.obj k)) ≠ 0 := hfα + exact indTensorHom_point_ne_zero_indOf_left (X := M.presentation.F.obj k) + (N := N) hu hfα' hv0 hk + +end Main + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchur.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchur.lean new file mode 100644 index 0000000000..ac686c68c5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchur.lean @@ -0,0 +1,999 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndTensorExact +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing + +/-! +# Transport of tensor powers and the permutation action along +`C ⥤ Ind C` + +The embedding `RS.indOf : C ⥤ Ind C` is monoidal up to isomorphism +(`RS.indOfTensorIso`, `RS.Classical.Deligne.IndTensorExact`). This +file upgrades that comparison to the full coherent package needed to +transport the symmetric-group action on tensor powers +(`RS.Novel.Envelope.SymPerm`) across the embedding: + +* `RS.dayCoyonedaIso_hom_braiding` and + `RS.dayCoyonedaIso_hom_associator` — the co-Yoneda identifications + of `RS.dayCoyonedaIso` intertwine the Day braiding and the Day + associator with the braiding and associator of the base, with + Yoneda forms `RS.dayYonedaIso_hom_braiding` and + `RS.dayYonedaIso_hom_associator`; +* `RS.indOfUnitIso` — the unit of `Ind C` is the embedded unit; +* `RS.indOfTensorIso_hom_braiding` and + `RS.indOfTensorIso_hom_associator` — the embedding-tensor + comparison is compatible with braiding and associator: `indOf` + with `indOfTensorIso` is a braided monoidal functor up to + isomorphism; +* `RS.indOfPowIso` — the tensor powers of an embedded object are the + embedded tensor powers, with recursion lemmas + `RS.indOfPowIso_zero`/`RS.indOfPowIso_succ`; +* `RS.indOfPowIso_swapTop`/`RS.indOfPowIso_insertTop`/ + **`RS.indOfPowIso_permMor`** — the permutation action on the + tensor powers of `indOf.obj X` is conjugate, under `indOfPowIso`, + to the embedded permutation action; +* `RS.permMor_indOf_eq_zero_iff` and + `RS.schurKilled_iff_indOf_map_permAlg_eq_zero` — vanishing of the + action transports faithfully across the embedding. + +The Mathlib pin has `Preadditive (Ind C)` (for `C` preadditive with +finite colimits) but no `Linear ℂ (Ind C)` instance, so `Ind C` +carries no `permAlg`, so Schur vanishing cannot be *stated* on +`Ind C`; the lemmas above are the `permMor`-level substrate, which is +what the group-algebra layer would rest on were `Linear ℂ (Ind C)` +available. + +The single-element method used throughout the Day-level proofs: a +morphism out of a (possibly iterated) Day tensor of corepresentables +is classified, through the Kan-extension universal property and the +Yoneda lemma, by one element — its value on the canonical element +`RS.dayCoyonedaUnitElt` assembled from identities. All coherence +comparisons are decided by evaluating both sides there. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory MonoidalCategory.DayFunctor Limits +open Opposite + +universe v + +noncomputable section + +section DayCalculusMore + +attribute [local instance] dayConv + +variable {D : Type v} + +/-- The Day-convolution structure of a plain presheaf pair, read +through the synonym: makes the `DayConvolution` API available on +underlying functors of the Day category. -/ +@[reducible] def dayConvPlain [SmallCategory D] [MonoidalCategory D] + (F G : D ⥤ Type v) : DayConvolution F G := + dayConv (DayFunctor.mk F) (DayFunctor.mk G) + +attribute [local instance] dayConvPlain + +/-- The canonical element of the Day tensor of two +corepresentables: the Kan-extension unit evaluated on the pair of +identities. -/ +def dayCoyonedaUnitElt [SmallCategory D] [MonoidalCategory D] + (a b : D) : + ((DayFunctor.mk (coyoneda.obj (op a)) ⊗ + DayFunctor.mk (coyoneda.obj (op b)) : D ⊛⥤ Type v)).functor.obj + (a ⊗ b) := + (η (DayFunctor.mk (coyoneda.obj (op a))) + (DayFunctor.mk (coyoneda.obj (op b)))).app (a, b) + ((𝟙 a, 𝟙 b) : (a ⟶ a) × (b ⟶ b)) + +/-- The canonical element of a left-nested triple Day tensor of +corepresentables. -/ +def dayCoyonedaUnitElt₂ [SmallCategory D] [MonoidalCategory D] + (a b c : D) : + (((DayFunctor.mk (coyoneda.obj (op a)) ⊗ + DayFunctor.mk (coyoneda.obj (op b))) ⊗ + DayFunctor.mk (coyoneda.obj (op c)) : D ⊛⥤ Type v)).functor.obj + ((a ⊗ b) ⊗ c) := + (η (DayFunctor.mk (coyoneda.obj (op a)) ⊗ + DayFunctor.mk (coyoneda.obj (op b))) + (DayFunctor.mk (coyoneda.obj (op c)))).app (a ⊗ b, c) + ((dayCoyonedaUnitElt a b, 𝟙 c)) + +/-- The canonical element of a right-nested triple Day tensor of +corepresentables. -/ +def dayCoyonedaUnitElt₂' [SmallCategory D] [MonoidalCategory D] + (a b c : D) : + ((DayFunctor.mk (coyoneda.obj (op a)) ⊗ + (DayFunctor.mk (coyoneda.obj (op b)) ⊗ + DayFunctor.mk (coyoneda.obj (op c))) : D ⊛⥤ Type v)).functor.obj + (a ⊗ (b ⊗ c)) := + (η (DayFunctor.mk (coyoneda.obj (op a))) + (DayFunctor.mk (coyoneda.obj (op b)) ⊗ + DayFunctor.mk (coyoneda.obj (op c)))).app (a, b ⊗ c) + ((𝟙 a, dayCoyonedaUnitElt b c)) + +open scoped MonoidalCategory.ExternalProduct in +/-- The left-nested triple Day tensor of corepresentables +corepresents evaluation at `(a ⊗ b) ⊗ c`: iterate the Kan-extension +universal property twice and read off the Yoneda lemma on the +external product of three corepresentables, which is definitionally +the corepresentable of the triple product category. -/ +def dayCoyonedaCorepresentableBy₂ [SmallCategory D] [MonoidalCategory D] + (a b c : D) : + (dayEvaluation ((a ⊗ b) ⊗ c)).CorepresentableBy + ((DayFunctor.mk (coyoneda.obj (op a)) ⊗ + DayFunctor.mk (coyoneda.obj (op b))) ⊗ + DayFunctor.mk (coyoneda.obj (op c))) where + homEquiv {F} := + ({ toFun := Hom.natTrans + invFun := .mk + left_inv := fun _ => rfl + right_inv := fun _ => rfl } : + ((DayFunctor.mk (coyoneda.obj (op a)) ⊗ + DayFunctor.mk (coyoneda.obj (op b))) ⊗ + DayFunctor.mk (coyoneda.obj (op c)) ⟶ F) ≃ + (((DayFunctor.mk (coyoneda.obj (op a)) ⊗ + DayFunctor.mk (coyoneda.obj (op b))) ⊗ + DayFunctor.mk (coyoneda.obj (op c))).functor ⟶ + F.functor)).trans <| + (Functor.homEquivOfIsLeftKanExtension _ + (DayConvolution.unit + ((DayFunctor.mk (coyoneda.obj (op a)) ⊗ + DayFunctor.mk (coyoneda.obj (op b))).functor) + (coyoneda.obj (op c))) + F.functor).trans <| + (Functor.homEquivOfIsLeftKanExtension _ + (ExternalProduct.extensionUnitLeft _ + (DayConvolution.unit (coyoneda.obj (op a)) + (coyoneda.obj (op b))) + (coyoneda.obj (op c))) + (tensor D ⋙ F.functor)).trans + (coyonedaEquiv (C := (D × D) × D) + (X := (((a, b), c) : (D × D) × D)) + (F := (tensor D).prod (𝟭 D) ⋙ tensor D ⋙ F.functor)) + homEquiv_comp _ _ := rfl + +/-- Evaluation of `RS.dayEvaluation` on a morphism of the Day +category. -/ +lemma dayEvaluation_map_apply [SmallCategory D] [MonoidalCategory D] + (d : D) {F K : D ⊛⥤ Type v} (g : F ⟶ K) + (x : (dayEvaluation d).obj F) : + (dayEvaluation d).map g x = g.natTrans.app d x := rfl + +/-- The corepresentability of a Day tensor of two corepresentables +classifies a morphism by its value on the canonical element. -/ +lemma dayCoyonedaCorepresentableBy_homEquiv_apply + [SmallCategory D] [MonoidalCategory D] + (a b : D) + {K : D ⊛⥤ Type v} + (f : DayFunctor.mk (coyoneda.obj (op a)) ⊗ + DayFunctor.mk (coyoneda.obj (op b)) ⟶ K) : + (dayCoyonedaCorepresentableBy a b).homEquiv f = + f.natTrans.app (a ⊗ b) (dayCoyonedaUnitElt a b) := rfl + +/-- The corepresentability of a left-nested triple Day tensor of +corepresentables classifies a morphism by its value on the canonical +element. -/ +lemma dayCoyonedaCorepresentableBy₂_homEquiv_apply + [SmallCategory D] [MonoidalCategory D] + (a b c : D) + {K : D ⊛⥤ Type v} + (f : (DayFunctor.mk (coyoneda.obj (op a)) ⊗ + DayFunctor.mk (coyoneda.obj (op b))) ⊗ + DayFunctor.mk (coyoneda.obj (op c)) ⟶ K) : + (dayCoyonedaCorepresentableBy₂ a b c).homEquiv f = + f.natTrans.app ((a ⊗ b) ⊗ c) (dayCoyonedaUnitElt₂ a b c) := rfl + +/-- The classification of `RS.dayCoyonedaIso` under the +corepresentability of the Day tensor of two corepresentables: its +value is the identity of `p ⊗ q`. -/ +lemma dayCoyonedaCorepresentableBy_homEquiv_iso + [SmallCategory D] [MonoidalCategory D] + (p q : D) : + (dayCoyonedaCorepresentableBy p q).homEquiv + (dayCoyonedaIso p q).hom = 𝟙 (p ⊗ q) := by + have h := corepresentableBy_homEquiv_uniqueUpToIso_hom + (dayCoyonedaCorepresentableBy p q) + (coyonedaDayCorepresentableBy (p ⊗ q)) + rw [show (dayCoyonedaCorepresentableBy p q).uniqueUpToIso + (coyonedaDayCorepresentableBy (p ⊗ q)) = dayCoyonedaIso p q + from rfl] at h + rw [h] + change coyonedaEquiv (𝟙 (coyoneda.obj (op (p ⊗ q)))) = 𝟙 (p ⊗ q) + rfl + +/-- `RS.dayCoyonedaIso` sends the canonical element to the +identity. -/ +lemma dayCoyonedaIso_hom_app_unitElt [SmallCategory D] [MonoidalCategory D] + (p q : D) : + (dayCoyonedaIso p q).hom.natTrans.app (p ⊗ q) + (dayCoyonedaUnitElt p q) = 𝟙 (p ⊗ q) := by + have h := dayCoyonedaCorepresentableBy_homEquiv_iso p q + rwa [dayCoyonedaCorepresentableBy_homEquiv_apply] at h + +/-- Right-whiskering `RS.dayCoyonedaIso` sends the left-nested +canonical element to the canonical element at `(a ⊗ b, c)`. -/ +lemma whiskerRight_dayCoyonedaIso_app_unitElt + [SmallCategory D] [MonoidalCategory D] + (a b c : D) : + ((dayCoyonedaIso a b).hom ▷ + DayFunctor.mk (coyoneda.obj (op c))).natTrans.app ((a ⊗ b) ⊗ c) + (dayCoyonedaUnitElt₂ a b c) = dayCoyonedaUnitElt (a ⊗ b) c := by + have h₀ := congrArg (fun t => t.app ((a ⊗ b) ⊗ c)) + (natTrans_whiskerRight (dayCoyonedaIso a b).hom + (DayFunctor.mk (coyoneda.obj (op c)))) + have h₁ := ConcreteCategory.congr_hom h₀ (dayCoyonedaUnitElt₂ a b c) + have h₂' := DayConvolution.unit_app_map_app + (f := (dayCoyonedaIso a b).hom.natTrans) + (g := 𝟙 ((DayFunctor.mk (coyoneda.obj (op c))).functor)) + (x := a ⊗ b) (y := c) + have h₂ : (DayConvolution.map (dayCoyonedaIso a b).hom.natTrans + (𝟙 ((DayFunctor.mk (coyoneda.obj (op c))).functor))).app + ((a ⊗ b) ⊗ c) (dayCoyonedaUnitElt₂ a b c) = + (η (DayFunctor.mk (coyoneda.obj (op (a ⊗ b)))) + (DayFunctor.mk (coyoneda.obj (op c)))).app (a ⊗ b, c) + (((dayCoyonedaIso a b).hom.natTrans.app (a ⊗ b) + (dayCoyonedaUnitElt a b), 𝟙 c)) := + ConcreteCategory.congr_hom h₂' + ((dayCoyonedaUnitElt a b, 𝟙 c) : + ((DayFunctor.mk (coyoneda.obj (op a)) ⊗ + DayFunctor.mk (coyoneda.obj (op b))).functor.obj (a ⊗ b)) × + (c ⟶ c)) + rw [h₁] + refine h₂.trans ?_ + exact congrArg + (fun z => (η (DayFunctor.mk (coyoneda.obj (op (a ⊗ b)))) + (DayFunctor.mk (coyoneda.obj (op c)))).app (a ⊗ b, c) + ((z, 𝟙 c) : + ((a ⊗ b) ⟶ (a ⊗ b)) × (c ⟶ c))) + (dayCoyonedaIso_hom_app_unitElt a b) + +/-- Left-whiskering `RS.dayCoyonedaIso` sends the right-nested +canonical element to the canonical element at `(a, b ⊗ c)`. -/ +lemma whiskerLeft_dayCoyonedaIso_app_unitElt + [SmallCategory D] [MonoidalCategory D] + (a b c : D) : + (DayFunctor.mk (coyoneda.obj (op a)) ◁ + (dayCoyonedaIso b c).hom).natTrans.app (a ⊗ (b ⊗ c)) + (dayCoyonedaUnitElt₂' a b c) = dayCoyonedaUnitElt a (b ⊗ c) := by + have h₀ := congrArg (fun t => t.app (a ⊗ (b ⊗ c))) + (natTrans_whiskerLeft (DayFunctor.mk (coyoneda.obj (op a))) + (dayCoyonedaIso b c).hom) + have h₁ := ConcreteCategory.congr_hom h₀ (dayCoyonedaUnitElt₂' a b c) + have h₂' := DayConvolution.unit_app_map_app + (f := 𝟙 ((DayFunctor.mk (coyoneda.obj (op a))).functor)) + (g := (dayCoyonedaIso b c).hom.natTrans) (x := a) (y := b ⊗ c) + have h₂ : (DayConvolution.map + (𝟙 ((DayFunctor.mk (coyoneda.obj (op a))).functor)) + (dayCoyonedaIso b c).hom.natTrans).app (a ⊗ (b ⊗ c)) + (dayCoyonedaUnitElt₂' a b c) = + (η (DayFunctor.mk (coyoneda.obj (op a))) + (DayFunctor.mk (coyoneda.obj (op (b ⊗ c))))).app (a, b ⊗ c) + ((𝟙 a, (dayCoyonedaIso b c).hom.natTrans.app (b ⊗ c) + (dayCoyonedaUnitElt b c))) := + ConcreteCategory.congr_hom h₂' + ((𝟙 a, dayCoyonedaUnitElt b c) : + (a ⟶ a) × + ((DayFunctor.mk (coyoneda.obj (op b)) ⊗ + DayFunctor.mk (coyoneda.obj (op c))).functor.obj (b ⊗ c))) + rw [h₁] + refine h₂.trans ?_ + exact congrArg + (fun z => (η (DayFunctor.mk (coyoneda.obj (op a))) + (DayFunctor.mk (coyoneda.obj (op (b ⊗ c))))).app (a, b ⊗ c) + ((𝟙 a, z) : + (a ⟶ a) × ((b ⊗ c) ⟶ (b ⊗ c)))) + (dayCoyonedaIso_hom_app_unitElt b c) + +/-- The Day associator carries the left-nested canonical element to +the image of the right-nested one under the base associator. -/ +lemma dayAssociator_hom_app_unitElt [SmallCategory D] [MonoidalCategory D] + (a b c : D) : + (α_ (DayFunctor.mk (coyoneda.obj (op a))) + (DayFunctor.mk (coyoneda.obj (op b))) + (DayFunctor.mk (coyoneda.obj (op c)))).hom.natTrans.app + ((a ⊗ b) ⊗ c) (dayCoyonedaUnitElt₂ a b c) = + (DayFunctor.mk (coyoneda.obj (op a)) ⊗ + (DayFunctor.mk (coyoneda.obj (op b)) ⊗ + DayFunctor.mk (coyoneda.obj (op c)))).functor.map (α_ a b c).inv + (dayCoyonedaUnitElt₂' a b c) := by + have h₀ := congrArg (fun t => t.app ((a ⊗ b) ⊗ c)) + (natTrans_associator (DayFunctor.mk (coyoneda.obj (op a))) + (DayFunctor.mk (coyoneda.obj (op b))) + (DayFunctor.mk (coyoneda.obj (op c)))) + have h₁ := ConcreteCategory.congr_hom h₀ (dayCoyonedaUnitElt₂ a b c) + rw [h₁] + exact ConcreteCategory.congr_hom + (DayConvolution.associator_hom_unit_unit (coyoneda.obj (op a)) + (coyoneda.obj (op b)) (coyoneda.obj (op c)) a b c) + (((𝟙 a, 𝟙 b), 𝟙 c) : ((a ⟶ a) × (b ⟶ b)) × (c ⟶ c)) + +/-- **Day convolution of corepresentables intertwines the +associator**: under the co-Yoneda identifications, the two +reassociation routes of a triple Day tensor of corepresentables +differ by precomposition with the associator of the base. -/ +lemma dayCoyonedaIso_hom_associator [SmallCategory D] [MonoidalCategory D] + (a b c : D) : + ((dayCoyonedaIso a b).hom ▷ DayFunctor.mk (coyoneda.obj (op c))) ≫ + (dayCoyonedaIso (a ⊗ b) c).hom ≫ + ⟨coyoneda.map ((α_ a b c).inv.op)⟩ = + (α_ (DayFunctor.mk (coyoneda.obj (op a))) + (DayFunctor.mk (coyoneda.obj (op b))) + (DayFunctor.mk (coyoneda.obj (op c)))).hom ≫ + (DayFunctor.mk (coyoneda.obj (op a)) ◁ + (dayCoyonedaIso b c).hom) ≫ + (dayCoyonedaIso a (b ⊗ c)).hom := by + apply (dayCoyonedaCorepresentableBy₂ a b c).homEquiv.injective + change (coyoneda.map ((α_ a b c).inv.op)).app ((a ⊗ b) ⊗ c) + ((dayCoyonedaIso (a ⊗ b) c).hom.natTrans.app ((a ⊗ b) ⊗ c) + (((dayCoyonedaIso a b).hom ▷ DayFunctor.mk (coyoneda.obj (op c))).natTrans.app + ((a ⊗ b) ⊗ c) (dayCoyonedaUnitElt₂ a b c))) = + (dayCoyonedaIso a (b ⊗ c)).hom.natTrans.app ((a ⊗ b) ⊗ c) + ((DayFunctor.mk (coyoneda.obj (op a)) ◁ (dayCoyonedaIso b c).hom).natTrans.app + ((a ⊗ b) ⊗ c) + ((α_ (DayFunctor.mk (coyoneda.obj (op a))) + (DayFunctor.mk (coyoneda.obj (op b))) + (DayFunctor.mk (coyoneda.obj (op c)))).hom.natTrans.app + ((a ⊗ b) ⊗ c) (dayCoyonedaUnitElt₂ a b c))) + rw [whiskerRight_dayCoyonedaIso_app_unitElt, + dayCoyonedaIso_hom_app_unitElt, dayAssociator_hom_app_unitElt] + have hnatl : (DayFunctor.mk (coyoneda.obj (op a)) ◁ + (dayCoyonedaIso b c).hom).natTrans.app ((a ⊗ b) ⊗ c) + ((DayFunctor.mk (coyoneda.obj (op a)) ⊗ + (DayFunctor.mk (coyoneda.obj (op b)) ⊗ + DayFunctor.mk (coyoneda.obj (op c)))).functor.map + (α_ a b c).inv (dayCoyonedaUnitElt₂' a b c)) = + (DayFunctor.mk (coyoneda.obj (op a)) ⊗ + DayFunctor.mk (coyoneda.obj (op (b ⊗ c)))).functor.map + (α_ a b c).inv + ((DayFunctor.mk (coyoneda.obj (op a)) ◁ + (dayCoyonedaIso b c).hom).natTrans.app (a ⊗ (b ⊗ c)) + (dayCoyonedaUnitElt₂' a b c)) := + ConcreteCategory.congr_hom + ((DayFunctor.mk (coyoneda.obj (op a)) ◁ + (dayCoyonedaIso b c).hom).natTrans.naturality (α_ a b c).inv) + (dayCoyonedaUnitElt₂' a b c) + have hnati : (dayCoyonedaIso a (b ⊗ c)).hom.natTrans.app + ((a ⊗ b) ⊗ c) + ((DayFunctor.mk (coyoneda.obj (op a)) ⊗ + DayFunctor.mk (coyoneda.obj (op (b ⊗ c)))).functor.map + (α_ a b c).inv (dayCoyonedaUnitElt a (b ⊗ c))) = + (coyoneda.obj (op (a ⊗ (b ⊗ c)))).map (α_ a b c).inv + ((dayCoyonedaIso a (b ⊗ c)).hom.natTrans.app (a ⊗ (b ⊗ c)) + (dayCoyonedaUnitElt a (b ⊗ c))) := + ConcreteCategory.congr_hom + ((dayCoyonedaIso a (b ⊗ c)).hom.natTrans.naturality + (α_ a b c).inv) + (dayCoyonedaUnitElt a (b ⊗ c)) + rw [hnatl, whiskerLeft_dayCoyonedaIso_app_unitElt, hnati, + dayCoyonedaIso_hom_app_unitElt] + change (α_ a b c).inv ≫ 𝟙 ((a ⊗ b) ⊗ c) = + 𝟙 (a ⊗ (b ⊗ c)) ≫ (α_ a b c).inv + rw [Category.id_comp, Category.comp_id] + +section Braided + +/-- **Day convolution of corepresentables intertwines the +braiding**: under the co-Yoneda identifications, the braiding of the +Day tensor of two corepresentables is precomposition with the +braiding of the base. -/ +lemma dayCoyonedaIso_hom_braiding + [SmallCategory D] [MonoidalCategory D] [BraidedCategory D] + (a b : D) : + (β_ (DayFunctor.mk (coyoneda.obj (op a))) + (DayFunctor.mk (coyoneda.obj (op b)))).hom ≫ + (dayCoyonedaIso b a).hom = + (dayCoyonedaIso a b).hom ≫ ⟨coyoneda.map ((β_ b a).hom.op)⟩ := by + apply (dayCoyonedaCorepresentableBy a b).homEquiv.injective + change (dayCoyonedaIso b a).hom.natTrans.app (a ⊗ b) + ((β_ (DayFunctor.mk (coyoneda.obj (op a))) + (DayFunctor.mk (coyoneda.obj (op b)))).hom.natTrans.app (a ⊗ b) + (dayCoyonedaUnitElt a b)) = + (coyoneda.map ((β_ b a).hom.op)).app (a ⊗ b) + ((dayCoyonedaIso a b).hom.natTrans.app (a ⊗ b) (dayCoyonedaUnitElt a b)) + rw [dayCoyonedaIso_hom_app_unitElt] + have hβ : (β_ (DayFunctor.mk (coyoneda.obj (op a))) + (DayFunctor.mk (coyoneda.obj (op b)))).hom.natTrans.app (a ⊗ b) + (dayCoyonedaUnitElt a b) = + (DayFunctor.mk (coyoneda.obj (op b)) ⊗ + DayFunctor.mk (coyoneda.obj (op a))).functor.map (β_ b a).hom + ((η (DayFunctor.mk (coyoneda.obj (op b))) + (DayFunctor.mk (coyoneda.obj (op a)))).app (b, a) + ((𝟙 b, 𝟙 a) : (b ⟶ b) × (a ⟶ a))) := + ConcreteCategory.congr_hom + (DayConvolution.unit_app_braiding_hom_app + (coyoneda.obj (op a)) (coyoneda.obj (op b)) a b) + ((𝟙 a, 𝟙 b) : (a ⟶ a) × (b ⟶ b)) + have hnat : (dayCoyonedaIso b a).hom.natTrans.app (a ⊗ b) + ((DayFunctor.mk (coyoneda.obj (op b)) ⊗ + DayFunctor.mk (coyoneda.obj (op a))).functor.map (β_ b a).hom + ((η (DayFunctor.mk (coyoneda.obj (op b))) + (DayFunctor.mk (coyoneda.obj (op a)))).app (b, a) + ((𝟙 b, 𝟙 a) : (b ⟶ b) × (a ⟶ a)))) = + (coyoneda.obj (op (b ⊗ a))).map (β_ b a).hom + ((dayCoyonedaIso b a).hom.natTrans.app (b ⊗ a) + ((η (DayFunctor.mk (coyoneda.obj (op b))) + (DayFunctor.mk (coyoneda.obj (op a)))).app (b, a) + ((𝟙 b, 𝟙 a) : (b ⟶ b) × (a ⟶ a)))) := + ConcreteCategory.congr_hom + ((dayCoyonedaIso b a).hom.natTrans.naturality (β_ b a).hom) + ((η (DayFunctor.mk (coyoneda.obj (op b))) + (DayFunctor.mk (coyoneda.obj (op a)))).app (b, a) + ((𝟙 b, 𝟙 a) : (b ⟶ b) × (a ⟶ a))) + have hid : (dayCoyonedaIso b a).hom.natTrans.app (b ⊗ a) + ((η (DayFunctor.mk (coyoneda.obj (op b))) + (DayFunctor.mk (coyoneda.obj (op a)))).app (b, a) + ((𝟙 b, 𝟙 a) : (b ⟶ b) × (a ⟶ a))) = 𝟙 b ⊗ₘ 𝟙 a := by + have h := congrArg (fun t => t.app (b, a)) + (eta_comp_dayCoyonedaIso_hom b a) + exact ConcreteCategory.congr_hom h ((𝟙 b, 𝟙 a) : (b ⟶ b) × (a ⟶ a)) + rw [hβ, hnat, hid] + change (𝟙 b ⊗ₘ 𝟙 a) ≫ (β_ b a).hom = (β_ b a).hom ≫ 𝟙 (a ⊗ b) + rw [MonoidalCategory.id_tensorHom_id, Category.id_comp, + Category.comp_id] + +end Braided + +/-- The forward and reversed transports along `RS.dayMkIso` +compose to the identity. -/ +lemma dayMkIso_hom_symm_hom [SmallCategory D] [MonoidalCategory D] + {A B : Dᵒᵖ ⥤ Type v} + (e : A ≅ B) : + (dayMkIso e).hom ≫ (dayMkIso e.symm).hom = + 𝟙 (DayFunctor.mk A : Dᵒᵖ ⊛⥤ Type v) := + (dayMkIso e).hom_inv_id + +/-- Cancellation form of `RS.dayMkIso_hom_symm_hom`, stated against +a leading morphism so that no identity is left behind. -/ +lemma comp_dayMkIso_hom_symm_hom [SmallCategory D] [MonoidalCategory D] + {A B : Dᵒᵖ ⥤ Type v} (e : A ≅ B) + {X : Dᵒᵖ ⊛⥤ Type v} (f : X ⟶ DayFunctor.mk A) : + f ≫ (dayMkIso e).hom ≫ (dayMkIso e.symm).hom = f := by + rw [dayMkIso_hom_symm_hom, Category.comp_id] + +end DayCalculusMore + +section YonedaTransport + +variable {C : Type v} + +/-- Naturality of `Coyoneda.objOpOp`, forward form, at a general +double-opposite morphism. -/ +lemma coyoneda_map_op_op_comp_objOpOp_hom [SmallCategory C] + {z z' : C} (u : z ⟶ z') : + coyoneda.map (u.op.op) ≫ (Coyoneda.objOpOp z').hom = + (Coyoneda.objOpOp z).hom ≫ yoneda.map u := by + ext w t + simp [Coyoneda.objOpOp, opEquiv] + +/-- **The Day tensor of representables intertwines the braiding**: +the Yoneda form of `RS.dayCoyonedaIso_hom_braiding`. -/ +lemma dayYonedaIso_hom_braiding [SmallCategory C] [MonoidalCategory C] + [BraidedCategory C] (x y : C) : + (β_ (DayFunctor.mk (yoneda.obj x)) + (DayFunctor.mk (yoneda.obj y))).hom ≫ (dayYonedaIso y x).hom = + (dayYonedaIso x y).hom ≫ ⟨yoneda.map (β_ x y).hom⟩ := by + have s₂ : (⟨coyoneda.map ((β_ (op y) (op x)).hom.op)⟩ : + DayFunctor.mk (coyoneda.obj (op (op x ⊗ op y))) ⟶ + DayFunctor.mk (coyoneda.obj (op (op y ⊗ op x)))) ≫ + (dayMkIso (Coyoneda.objOpOp (y ⊗ x))).hom = + (dayMkIso (Coyoneda.objOpOp (x ⊗ y))).hom ≫ + ⟨yoneda.map (β_ x y).hom⟩ := by + ext1 + exact coyoneda_map_op_op_comp_objOpOp_hom (β_ x y).hom + have e₁ : (β_ (DayFunctor.mk (yoneda.obj x)) + (DayFunctor.mk (yoneda.obj y))).hom ≫ + ((dayMkIso (Coyoneda.objOpOp y).symm).hom ⊗ₘ + (dayMkIso (Coyoneda.objOpOp x).symm).hom) = + ((dayMkIso (Coyoneda.objOpOp x).symm).hom ⊗ₘ + (dayMkIso (Coyoneda.objOpOp y).symm).hom) ≫ + (β_ (DayFunctor.mk (coyoneda.obj (op (op x)))) + (DayFunctor.mk (coyoneda.obj (op (op y))))).hom := + (BraidedCategory.braiding_naturality _ _).symm + simp only [dayYonedaIso, Iso.trans_hom, tensorIso_hom] + rw [← Category.assoc, e₁, Category.assoc, + reassoc_of% dayCoyonedaIso_hom_braiding (D := Cᵒᵖ) (op x) (op y), + s₂] + simp only [Category.assoc] + +/-- **The Day tensor of representables intertwines the associator**: +the Yoneda form of `RS.dayCoyonedaIso_hom_associator`. -/ +lemma dayYonedaIso_hom_associator [SmallCategory C] [MonoidalCategory C] + (x y z : C) : + ((dayYonedaIso x y).hom ▷ DayFunctor.mk (yoneda.obj z)) ≫ + (dayYonedaIso (x ⊗ y) z).hom ≫ ⟨yoneda.map (α_ x y z).hom⟩ = + (α_ (DayFunctor.mk (yoneda.obj x)) (DayFunctor.mk (yoneda.obj y)) + (DayFunctor.mk (yoneda.obj z))).hom ≫ + (DayFunctor.mk (yoneda.obj x) ◁ (dayYonedaIso y z).hom) ≫ + (dayYonedaIso x (y ⊗ z)).hom := by + have s₂ : (⟨coyoneda.map ((α_ (op x) (op y) (op z)).inv.op)⟩ : + DayFunctor.mk (coyoneda.obj (op (op ((x ⊗ y) ⊗ z)))) ⟶ + DayFunctor.mk (coyoneda.obj (op (op (x ⊗ (y ⊗ z)))))) ≫ + (dayMkIso (Coyoneda.objOpOp (x ⊗ (y ⊗ z)))).hom = + (dayMkIso (Coyoneda.objOpOp ((x ⊗ y) ⊗ z))).hom ≫ + ⟨yoneda.map (α_ x y z).hom⟩ := by + ext1 + exact coyoneda_map_op_op_comp_objOpOp_hom (α_ x y z).hom + have hassoc : ((dayCoyonedaIso (op x) (op y)).hom ▷ + DayFunctor.mk (coyoneda.obj (op (op z)))) ≫ + (dayCoyonedaIso (op (x ⊗ y)) (op z)).hom ≫ + (⟨coyoneda.map ((α_ (op x) (op y) (op z)).inv.op)⟩ : + DayFunctor.mk (coyoneda.obj (op (op ((x ⊗ y) ⊗ z)))) ⟶ + DayFunctor.mk (coyoneda.obj (op (op (x ⊗ (y ⊗ z)))))) = + (α_ (DayFunctor.mk (coyoneda.obj (op (op x)))) + (DayFunctor.mk (coyoneda.obj (op (op y)))) + (DayFunctor.mk (coyoneda.obj (op (op z))))).hom ≫ + (DayFunctor.mk (coyoneda.obj (op (op x))) ◁ + (dayCoyonedaIso (op y) (op z)).hom) ≫ + (dayCoyonedaIso (op x) (op (y ⊗ z))).hom := + dayCoyonedaIso_hom_associator (D := Cᵒᵖ) (op x) (op y) (op z) + have e_left : ((((dayMkIso (Coyoneda.objOpOp x).symm).hom ⊗ₘ + (dayMkIso (Coyoneda.objOpOp y).symm).hom) ≫ + (dayCoyonedaIso (op x) (op y)).hom ≫ + (dayMkIso (Coyoneda.objOpOp (x ⊗ y))).hom) ▷ + DayFunctor.mk (yoneda.obj z)) ≫ + ((dayMkIso (Coyoneda.objOpOp (x ⊗ y)).symm).hom ⊗ₘ + (dayMkIso (Coyoneda.objOpOp z).symm).hom) = + (((dayMkIso (Coyoneda.objOpOp x).symm).hom ⊗ₘ + (dayMkIso (Coyoneda.objOpOp y).symm).hom) ⊗ₘ + (dayMkIso (Coyoneda.objOpOp z).symm).hom) ≫ + ((dayCoyonedaIso (op x) (op y)).hom ▷ + DayFunctor.mk (coyoneda.obj (op (op z)))) := by + rw [← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom, Category.id_comp, + ← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom, Category.comp_id] + simp only [Category.assoc, comp_dayMkIso_hom_symm_hom] + have e_right : ((dayMkIso (Coyoneda.objOpOp x).symm).hom ⊗ₘ + ((dayMkIso (Coyoneda.objOpOp y).symm).hom ⊗ₘ + (dayMkIso (Coyoneda.objOpOp z).symm).hom)) ≫ + (DayFunctor.mk (coyoneda.obj (op (op x))) ◁ + (dayCoyonedaIso (op y) (op z)).hom) = + (DayFunctor.mk (yoneda.obj x) ◁ + (((dayMkIso (Coyoneda.objOpOp y).symm).hom ⊗ₘ + (dayMkIso (Coyoneda.objOpOp z).symm).hom) ≫ + (dayCoyonedaIso (op y) (op z)).hom ≫ + (dayMkIso (Coyoneda.objOpOp (y ⊗ z))).hom)) ≫ + ((dayMkIso (Coyoneda.objOpOp x).symm).hom ⊗ₘ + (dayMkIso (Coyoneda.objOpOp (y ⊗ z)).symm).hom) := by + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, Category.comp_id, + ← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, Category.id_comp] + simp only [Category.assoc, comp_dayMkIso_hom_symm_hom] + simp only [dayYonedaIso, Iso.trans_hom, tensorIso_hom] + calc _ = ((((dayMkIso (Coyoneda.objOpOp x).symm).hom ⊗ₘ + (dayMkIso (Coyoneda.objOpOp y).symm).hom) ≫ + (dayCoyonedaIso (op x) (op y)).hom ≫ + (dayMkIso (Coyoneda.objOpOp (x ⊗ y))).hom) ▷ + DayFunctor.mk (yoneda.obj z)) ≫ + ((dayMkIso (Coyoneda.objOpOp (x ⊗ y)).symm).hom ⊗ₘ + (dayMkIso (Coyoneda.objOpOp z).symm).hom) ≫ + ((dayCoyonedaIso (op (x ⊗ y)) (op z)).hom ≫ + (dayMkIso (Coyoneda.objOpOp ((x ⊗ y) ⊗ z))).hom ≫ + ⟨yoneda.map (α_ x y z).hom⟩) := by + simp only [Category.assoc] + _ = (((dayMkIso (Coyoneda.objOpOp x).symm).hom ⊗ₘ + (dayMkIso (Coyoneda.objOpOp y).symm).hom) ⊗ₘ + (dayMkIso (Coyoneda.objOpOp z).symm).hom) ≫ + ((dayCoyonedaIso (op x) (op y)).hom ▷ + DayFunctor.mk (coyoneda.obj (op (op z)))) ≫ + (dayCoyonedaIso (op (x ⊗ y)) (op z)).hom ≫ + (⟨coyoneda.map ((α_ (op x) (op y) (op z)).inv.op)⟩ : + DayFunctor.mk (coyoneda.obj (op (op ((x ⊗ y) ⊗ z)))) ⟶ + DayFunctor.mk (coyoneda.obj (op (op (x ⊗ (y ⊗ z)))))) ≫ + (dayMkIso (Coyoneda.objOpOp (x ⊗ (y ⊗ z)))).hom := by + rw [← Category.assoc, e_left, ← s₂] + simp only [Category.assoc] + _ = (((dayMkIso (Coyoneda.objOpOp x).symm).hom ⊗ₘ + (dayMkIso (Coyoneda.objOpOp y).symm).hom) ⊗ₘ + (dayMkIso (Coyoneda.objOpOp z).symm).hom) ≫ + (α_ (DayFunctor.mk (coyoneda.obj (op (op x)))) + (DayFunctor.mk (coyoneda.obj (op (op y)))) + (DayFunctor.mk (coyoneda.obj (op (op z))))).hom ≫ + (DayFunctor.mk (coyoneda.obj (op (op x))) ◁ + (dayCoyonedaIso (op y) (op z)).hom) ≫ + (dayCoyonedaIso (op x) (op (y ⊗ z))).hom ≫ + (dayMkIso (Coyoneda.objOpOp (x ⊗ (y ⊗ z)))).hom := by + rw [reassoc_of% hassoc] + _ = _ := by + rw [MonoidalCategory.associator_naturality_assoc, + reassoc_of% e_right] + +end YonedaTransport + +section IndTransport + +variable {C : Type v} + +/-- The embedding into the Day presheaf category carries the +embedding-tensor comparison to the Day-level comparison. -/ +lemma indToDay_map_indOfTensorIso_hom [SmallCategory C] [MonoidalCategory C] + (x y : C) : + (indToDay (C := C)).map (indOfTensorIso x y).hom = + (indToDayTensorIso x y).hom := by + rw [indOfTensorIso, Functor.FullyFaithful.preimageIso_hom, + Functor.FullyFaithful.map_preimage] + +section Braided + +/-- The indization equivalence's forward functor is braided: the +braiding of `Ind C` is transported across it. -/ +instance [SmallCategory C] [MonoidalCategory C] [BraidedCategory C] : + (indDayEquivalence C).functor.Braided := + inferInstanceAs + (Monoidal.equivalenceTransported + ((indDayEquivalence C).symm)).inverse.Braided + +/-- The embedding into the Day presheaf category is braided. -/ +instance [SmallCategory C] [MonoidalCategory C] [BraidedCategory C] : + (indToDay (C := C)).Braided := + inferInstanceAs + ((indDayEquivalence C).functor ⋙ ObjectProperty.ι _).Braided + +/-- **The embedding-tensor comparison intertwines the braiding**: +`indOf` with `indOfTensorIso` is a braided functor up to +isomorphism. -/ +lemma indOfTensorIso_hom_braiding + [SmallCategory C] [MonoidalCategory C] [BraidedCategory C] + (x y : C) : + (β_ (indOf.obj x) (indOf.obj y)).hom ≫ (indOfTensorIso y x).hom = + (indOfTensorIso x y).hom ≫ indOf.map (β_ x y).hom := by + apply (indToDay (C := C)).map_injective + rw [Functor.map_comp, Functor.map_comp, + indToDay_map_indOfTensorIso_hom, indToDay_map_indOfTensorIso_hom, + Functor.map_braiding] + simp only [indToDayTensorIso, Iso.trans_hom, Iso.symm_hom, + tensorIso_hom, Functor.Monoidal.μIso_inv, Category.assoc, + Functor.Monoidal.μ_δ_assoc] + rw [← BraidedCategory.braiding_naturality_assoc, + reassoc_of% dayYonedaIso_hom_braiding x y, + comp_indToDayIndOfIso_inv] + +end Braided + +/-- **The embedding-tensor comparison intertwines the associator**: +the associativity axiom of the monoidal-functor-up-to-isomorphism +structure of `indOf`. -/ +lemma indOfTensorIso_hom_associator [SmallCategory C] [MonoidalCategory C] + (x y z : C) : + ((indOfTensorIso x y).hom ▷ indOf.obj z) ≫ + (indOfTensorIso (x ⊗ y) z).hom ≫ indOf.map (α_ x y z).hom = + (α_ (indOf.obj x) (indOf.obj y) (indOf.obj z)).hom ≫ + (indOf.obj x ◁ (indOfTensorIso y z).hom) ≫ + (indOfTensorIso x (y ⊗ z)).hom := by + apply (indToDay (C := C)).map_injective + rw [Functor.map_comp, Functor.map_comp, Functor.map_comp, + Functor.map_comp, + Functor.Monoidal.map_whiskerRight (F := indToDay (C := C)), + Functor.Monoidal.map_whiskerLeft (F := indToDay (C := C)), + Functor.Monoidal.map_associator (F := indToDay (C := C)), + indToDay_map_indOfTensorIso_hom, indToDay_map_indOfTensorIso_hom, + indToDay_map_indOfTensorIso_hom, indToDay_map_indOfTensorIso_hom] + simp only [indToDayTensorIso, Iso.trans_hom, Iso.symm_hom, + tensorIso_hom, Functor.Monoidal.μIso_inv, Category.assoc, + Functor.Monoidal.μ_δ_assoc, MonoidalCategory.comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp] + have hA : ((indToDayIndOfIso (x ⊗ y)).inv ▷ + (indToDay (C := C)).obj (indOf.obj z)) ≫ + ((indToDayIndOfIso (x ⊗ y)).hom ⊗ₘ (indToDayIndOfIso z).hom) = + DayFunctor.mk (yoneda.obj (x ⊗ y)) ◁ (indToDayIndOfIso z).hom := by + rw [← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom, Iso.inv_hom_id, + Category.id_comp, MonoidalCategory.id_tensorHom] + have hB : ((dayYonedaIso x y).hom ▷ + (indToDay (C := C)).obj (indOf.obj z)) ≫ + (DayFunctor.mk (yoneda.obj (x ⊗ y)) ◁ (indToDayIndOfIso z).hom) = + ((DayFunctor.mk (yoneda.obj x) ⊗ DayFunctor.mk (yoneda.obj y)) ◁ + (indToDayIndOfIso z).hom) ≫ + ((dayYonedaIso x y).hom ▷ DayFunctor.mk (yoneda.obj z)) := + (MonoidalCategory.whisker_exchange _ _).symm + have hC : (((indToDayIndOfIso x).hom ⊗ₘ (indToDayIndOfIso y).hom) ▷ + (indToDay (C := C)).obj (indOf.obj z)) ≫ + ((DayFunctor.mk (yoneda.obj x) ⊗ DayFunctor.mk (yoneda.obj y)) ◁ + (indToDayIndOfIso z).hom) = + ((indToDayIndOfIso x).hom ⊗ₘ (indToDayIndOfIso y).hom) ⊗ₘ + (indToDayIndOfIso z).hom := + (MonoidalCategory.tensorHom_def _ _).symm + have hD : ((indToDay (C := C)).obj (indOf.obj x) ◁ + (indToDayIndOfIso (y ⊗ z)).inv) ≫ + ((indToDayIndOfIso x).hom ⊗ₘ (indToDayIndOfIso (y ⊗ z)).hom) = + (indToDayIndOfIso x).hom ▷ DayFunctor.mk (yoneda.obj (y ⊗ z)) := by + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, Iso.inv_hom_id, + Category.id_comp, MonoidalCategory.tensorHom_id] + have hE : ((indToDay (C := C)).obj (indOf.obj x) ◁ + (dayYonedaIso y z).hom) ≫ + ((indToDayIndOfIso x).hom ▷ DayFunctor.mk (yoneda.obj (y ⊗ z))) = + ((indToDayIndOfIso x).hom ▷ + (DayFunctor.mk (yoneda.obj y) ⊗ DayFunctor.mk (yoneda.obj z))) ≫ + (DayFunctor.mk (yoneda.obj x) ◁ (dayYonedaIso y z).hom) := + MonoidalCategory.whisker_exchange _ _ + have hF : ((indToDay (C := C)).obj (indOf.obj x) ◁ + ((indToDayIndOfIso y).hom ⊗ₘ (indToDayIndOfIso z).hom)) ≫ + ((indToDayIndOfIso x).hom ▷ + (DayFunctor.mk (yoneda.obj y) ⊗ DayFunctor.mk (yoneda.obj z))) = + (indToDayIndOfIso x).hom ⊗ₘ + ((indToDayIndOfIso y).hom ⊗ₘ (indToDayIndOfIso z).hom) := + (MonoidalCategory.tensorHom_def' _ _).symm + rw [reassoc_of% hA, reassoc_of% hB, reassoc_of% hC, + ← comp_indToDayIndOfIso_inv, + reassoc_of% dayYonedaIso_hom_associator x y z, + reassoc_of% hD, reassoc_of% hE, reassoc_of% hF, + MonoidalCategory.associator_naturality_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, Functor.Monoidal.μ_δ, + MonoidalCategory.whiskerLeft_id, Category.id_comp] + +section Powers + +/-- **The tensor powers of an embedded object are the embedded +tensor powers**: `n = 0` is `RS.indOfUnitIso`, and each successor +stage tensors the previous one with `indOf.obj X` and applies the +embedding-tensor comparison. -/ +def indOfPowIso [SmallCategory C] [MonoidalCategory C] + (X : C) : (n : ℕ) → + (tensorPow (Ind C) (indOf.obj X) n ≅ indOf.obj (tensorPow C X n)) + | 0 => indOfUnitIso + | n + 1 => + whiskerRightIso (indOfPowIso X n) (indOf.obj X) ≪≫ + indOfTensorIso (tensorPow C X n) X + +/-- The base case of the power comparison. -/ +@[simp] +theorem indOfPowIso_zero [SmallCategory C] [MonoidalCategory C] + (X : C) : + indOfPowIso X 0 = indOfUnitIso := rfl + +/-- The defining recursion of the power comparison. -/ +theorem indOfPowIso_succ [SmallCategory C] [MonoidalCategory C] + (X : C) (n : ℕ) : + indOfPowIso X (n + 1) = + whiskerRightIso (indOfPowIso X n) (indOf.obj X) ≪≫ + indOfTensorIso (tensorPow C X n) X := rfl + +end Powers + +section Perm + +/-- The braiding conjugate defining `swapTop` passes doubly +whiskered morphisms, with an arbitrary tail. -/ +private lemma swap_conj_pass + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] + {P Q Z : Ind C} (g : P ⟶ Q) {R : Ind C} + (h : (Q ⊗ Z) ⊗ Z ⟶ R) : + (α_ P Z Z).hom ≫ (P ◁ (β_ Z Z).hom) ≫ (α_ P Z Z).inv ≫ + ((g ▷ Z) ▷ Z) ≫ h = + ((g ▷ Z) ▷ Z) ≫ (α_ Q Z Z).hom ≫ (Q ◁ (β_ Z Z).hom) ≫ + (α_ Q Z Z).inv ≫ h := by + rw [MonoidalCategory.associator_naturality_left_assoc, + ← MonoidalCategory.whisker_exchange_assoc, + MonoidalCategory.associator_inv_naturality_left_assoc] + +/-- The embedding-tensor comparison conjugates the braiding block of +`swapTop` to its embedded form. -/ +lemma indOfTensorIso_swap_conj + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] + (a z : C) : + (α_ (indOf.obj a) (indOf.obj z) (indOf.obj z)).hom ≫ + (indOf.obj a ◁ (β_ (indOf.obj z) (indOf.obj z)).hom) ≫ + (α_ (indOf.obj a) (indOf.obj z) (indOf.obj z)).inv ≫ + ((indOfTensorIso a z).hom ▷ indOf.obj z) ≫ + (indOfTensorIso (a ⊗ z) z).hom = + ((indOfTensorIso a z).hom ▷ indOf.obj z) ≫ + (indOfTensorIso (a ⊗ z) z).hom ≫ + indOf.map + ((α_ a z z).hom ≫ (a ◁ (β_ z z).hom) ≫ (α_ a z z).inv) := by + have hArev : (indOf.obj a ◁ (indOfTensorIso z z).hom) ≫ + (indOfTensorIso a (z ⊗ z)).hom = + (α_ (indOf.obj a) (indOf.obj z) (indOf.obj z)).inv ≫ + ((indOfTensorIso a z).hom ▷ indOf.obj z) ≫ + (indOfTensorIso (a ⊗ z) z).hom ≫ + indOf.map (α_ a z z).hom := by + rw [indOfTensorIso_hom_associator, Iso.inv_hom_id_assoc] + rw [Functor.map_comp, Functor.map_comp, + reassoc_of% indOfTensorIso_hom_associator a z z, + ← reassoc_of% indOfTensorIso_hom_natural_right a (β_ z z).hom, + ← MonoidalCategory.whiskerLeft_comp_assoc, + ← indOfTensorIso_hom_braiding z z, + MonoidalCategory.whiskerLeft_comp_assoc, + reassoc_of% hArev, Iso.map_hom_inv_id, Category.comp_id] + +/-- **Transport of the top braiding**: `swapTop` on the powers of an +embedded object is conjugate to the embedded `swapTop`. -/ +lemma indOfPowIso_swapTop + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] + (X : C) (n : ℕ) : + swapTop (indOf.obj X) n ≫ (indOfPowIso X (n + 2)).hom = + (indOfPowIso X (n + 2)).hom ≫ indOf.map (swapTop X n) := by + change ((α_ (tensorPow (Ind C) (indOf.obj X) n) (indOf.obj X) + (indOf.obj X)).hom ≫ + (tensorPow (Ind C) (indOf.obj X) n ◁ + (β_ (indOf.obj X) (indOf.obj X)).hom) ≫ + (α_ (tensorPow (Ind C) (indOf.obj X) n) (indOf.obj X) + (indOf.obj X)).inv) ≫ + ((((indOfPowIso X n).hom ▷ indOf.obj X) ≫ + (indOfTensorIso (tensorPow C X n) X).hom) ▷ indOf.obj X) ≫ + (indOfTensorIso (tensorPow C X n ⊗ X) X).hom = + (((((indOfPowIso X n).hom ▷ indOf.obj X) ≫ + (indOfTensorIso (tensorPow C X n) X).hom) ▷ indOf.obj X) ≫ + (indOfTensorIso (tensorPow C X n ⊗ X) X).hom) ≫ + indOf.map ((α_ (tensorPow C X n) X X).hom ≫ + (tensorPow C X n ◁ (β_ X X).hom) ≫ + (α_ (tensorPow C X n) X X).inv) + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [swap_conj_pass (indOfPowIso X n).hom, indOfTensorIso_swap_conj] + +/-- Whiskering by one more embedded factor preserves the transport +relation. -/ +lemma indOfPowIso_whiskerRight [SmallCategory C] [MonoidalCategory C] + (X : C) {m : ℕ} + {f : tensorPow (Ind C) (indOf.obj X) m ⟶ + tensorPow (Ind C) (indOf.obj X) m} + {u : tensorPow C X m ⟶ tensorPow C X m} + (h : f ≫ (indOfPowIso X m).hom = + (indOfPowIso X m).hom ≫ indOf.map u) : + (f ▷ indOf.obj X) ≫ (indOfPowIso X (m + 1)).hom = + (indOfPowIso X (m + 1)).hom ≫ indOf.map (u ▷ X) := by + change (f ▷ indOf.obj X) ≫ + (((indOfPowIso X m).hom ▷ indOf.obj X) ≫ + (indOfTensorIso (tensorPow C X m) X).hom) = + (((indOfPowIso X m).hom ▷ indOf.obj X) ≫ + (indOfTensorIso (tensorPow C X m) X).hom) ≫ indOf.map (u ▷ X) + rw [← Category.assoc, ← MonoidalCategory.comp_whiskerRight, h, + MonoidalCategory.comp_whiskerRight, Category.assoc, + indOfTensorIso_hom_natural_left, ← Category.assoc] + +/-- Two morphisms transported across the power comparison compose to +the transported composite. Stated at general objects, so that no +tensor-power arity enters the rewriting. -/ +private lemma step_pass_map [SmallCategory C] + {P : Ind C} {p : C} {s u : P ⟶ P} + {T : P ⟶ indOf.obj p} {s₀ u₀ : p ⟶ p} + (hs : s ≫ T = T ≫ indOf.map s₀) + (hu : u ≫ T = T ≫ indOf.map u₀) : + (s ≫ u) ≫ T = T ≫ indOf.map (s₀ ≫ u₀) := by + rw [Functor.map_comp, Category.assoc, hu, ← Category.assoc, hs, + Category.assoc] + +/-- **Transport of the insertion cycle**: `insertTop` on the powers +of an embedded object is conjugate to the embedded `insertTop`. -/ +lemma indOfPowIso_insertTop + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] + (X : C) : ∀ n k : ℕ, + insertTop (indOf.obj X) n k ≫ (indOfPowIso X (n + 1)).hom = + (indOfPowIso X (n + 1)).hom ≫ indOf.map (insertTop X n k) := by + intro n + induction n with + | zero => + intro k + rw [insertTop_of_zero, insertTop_of_zero, Category.id_comp, + CategoryTheory.Functor.map_id, Category.comp_id] + | succ n ih => + intro k + cases k with + | zero => + rw [insertTop_zero, insertTop_zero, Category.id_comp, + CategoryTheory.Functor.map_id, Category.comp_id] + | succ k => + exact step_pass_map (indOfPowIso_swapTop X n) + (indOfPowIso_whiskerRight X (ih k)) + +/-- **Transport of the permutation action** along the embedding +`C ⥤ Ind C`: the action of a permutation on the tensor powers of an +embedded object is conjugate, under `RS.indOfPowIso`, to the +embedded action. -/ +theorem indOfPowIso_permMor + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] + (X : C) : ∀ (n : ℕ) + (σ : Equiv.Perm (Fin n)), + permMor (indOf.obj X) n σ ≫ (indOfPowIso X n).hom = + (indOfPowIso X n).hom ≫ indOf.map (permMor X n σ) := by + intro n + induction n with + | zero => + intro σ + change 𝟙 _ ≫ _ = _ ≫ indOf.map (𝟙 _) + rw [Category.id_comp, CategoryTheory.Functor.map_id, + Category.comp_id] + | succ m ih => + intro σ + exact step_pass_map + (indOfPowIso_whiskerRight X (ih (restPerm σ))) + (indOfPowIso_insertTop X m (m - (topImage σ : ℕ))) + +/-- Conjugation form of `RS.indOfPowIso_permMor`. -/ +theorem permMor_indOf_conj + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] + (X : C) (n : ℕ) (σ : Equiv.Perm (Fin n)) : + permMor (indOf.obj X) n σ = + (indOfPowIso X n).hom ≫ indOf.map (permMor X n σ) ≫ + (indOfPowIso X n).inv := by + rw [← reassoc_of% indOfPowIso_permMor X n σ, Iso.hom_inv_id, + Category.comp_id] + +end Perm + +section Schur + +/-- **The faithfulness bridge**: the embedding `C ⥤ Ind C` reflects +and preserves vanishing of morphisms. -/ +lemma indOf_map_eq_zero_iff + [SmallCategory C] [Preadditive C] [HasFiniteColimits C] + {P Q : C} (f : P ⟶ Q) : + indOf.map f = 0 ↔ f = 0 := by + have : HasFiniteBiproducts C := + HasFiniteBiproducts.of_hasFiniteCoproducts + have : indOf.PreservesZeroMorphisms (C := C) := + Functor.preservesZeroMorphisms_of_map_zero_object + ((isZero_indOf (isZero_zero C)).isoZero) + constructor + · intro h + apply indOf.map_injective + rw [h, Functor.map_zero] + · intro h + rw [h, Functor.map_zero] + +/-- Vanishing of the permutation action on an embedded object is +vanishing of the embedded action. -/ +theorem permMor_indOf_eq_zero_iff_map + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [SymmetricCategory C] + (X : C) (n : ℕ) + (σ : Equiv.Perm (Fin n)) : + permMor (indOf.obj X) n σ = 0 ↔ + indOf.map (permMor X n σ) = 0 := by + rw [permMor_indOf_conj X n σ] + constructor + · intro h + have := (indOfPowIso X n).inv ≫= h =≫ (indOfPowIso X n).hom + simpa using this + · intro h + rw [h, zero_comp, comp_zero] + +/-- **Vanishing of the permutation action transports faithfully +along the embedding `C ⥤ Ind C`.** This is the `permMor`-level form +of Schur-vanishing transport: the group-algebra form waits on a +`Linear ℂ (Ind C)` instance, which the Mathlib pin does not +provide. -/ +theorem permMor_indOf_eq_zero_iff + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [SymmetricCategory C] + (X : C) (n : ℕ) + (σ : Equiv.Perm (Fin n)) : + permMor (indOf.obj X) n σ = 0 ↔ permMor X n σ = 0 := by + rw [permMor_indOf_eq_zero_iff_map, indOf_map_eq_zero_iff] + +end Schur + +section SchurBridge + +/-- **Schur vanishing, read through the embedding**: the shape `μ` +kills `X` precisely when the embedded action of its block idempotent +vanishes. Together with `RS.permMor_indOf_eq_zero_iff` this is the +substrate for transporting `RS.SchurKilled` to `Ind C`; phrasing the +`Ind C` side through `permAlg` needs `Linear ℂ (Ind C)`, which is a +mainline decision. -/ +theorem schurKilled_iff_indOf_map_permAlg_eq_zero + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] + [Preadditive C] [Linear ℂ C] [HasFiniteColimits C] + (P : SchurPackage.{v}) (X : C) (μ : YoungDiagram) : + SchurKilled P X μ ↔ + indOf.map (permAlg X μ.card (P.e μ)) = 0 := + (indOf_map_eq_zero_iff (permAlg X μ.card (P.e μ))).symm + +end SchurBridge + +end IndTransport + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchurKilled.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchurKilled.lean new file mode 100644 index 0000000000..bb432a9a76 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchurKilled.lean @@ -0,0 +1,334 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfMonoidal + +/-! +# Schur vanishing and exact pairings across `C ⥤ Ind C` + +`RS.Classical.Deligne.IndSchur` transports the symmetric-group action +on tensor powers along the embedding `RS.indOf : C ⥤ Ind C` at the +level of single permutations, and `RS.Classical.Deligne.IndOfMonoidal` +packages the comparison data as a strong (braided) monoidal structure +on `indOf`. `RS.Classical.Deligne.ScalarLinear` turns a scalar unit +`ψ : ℂ ≃+* End (𝟙_ C)` into ℂ-linear structures on `C` and on +`Ind C`. This file joins the three. + +* `RS.monoidalMap_unitConj` — a strong monoidal functor carries the + left-unitor conjugate of a unit endomorphism to the left-unitor + conjugate of its comparison transport; +* `RS.exactPairingMap` — a strong monoidal functor carries an exact + pairing to an exact pairing, with the coevaluation `ε ≫ F h ≫ δ` + and the evaluation `μ ≫ F ε_ ≫ η`; Mathlib has only the converse + (`CategoryTheory.ExactPairing.ofFaithful`, which *reflects* a + pairing along a faithful monoidal functor), so the two triangle + identities are proved here from the oplax coherences; +* `RS.exactPairingIndOf` — **duals transport**: the embedding + `C ⥤ Ind C` carries an exact pairing to an exact pairing; +* `RS.indOf_map_scalarSmul` and + `RS.permAlg_indOf_conj_scalarUnit` — the embedding intertwines the + scalar actions induced by `ψ` and by `RS.indScalarUnit ψ`, hence + the whole group-algebra action; +* `RS.schurKilled_indOf` — **Schur vanishing transports**: for the + ℂ-linear structures induced by a single scalar unit `ψ` on `C` and + on `Ind C`, a shape kills an embedded object exactly when it kills + the object downstairs. + +Both linear structures are installed by `letI` inside the statements, +as in the acceptance section of `RS.Classical.Deligne.ScalarLinear`: +`RS.linearOfScalarUnit` is deliberately not an instance, and taking +*both* structures from the same `ψ` is what makes the two sides of +`RS.schurKilled_indOf` comparable — no compatibility hypothesis +between `ψ` and an ambient linear structure is needed. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u v' u' + +noncomputable section + +/-! ## Strong monoidal functors: unit conjugates and duals -/ + +section MonoidalFunctor + +variable {A : Type u} + +/-- **Transport of unit-endomorphism conjugates**: a strong monoidal +functor carries the left-unitor conjugate of a unit endomorphism `u` +to the left-unitor conjugate of the comparison transport of `u`. -/ +theorem monoidalMap_unitConj + [Category.{v} A] [MonoidalCategory A] {B : Type u'} [Category.{v'} B] + [MonoidalCategory B] (F : A ⥤ B) [F.Monoidal] + (X : A) (u : 𝟙_ A ⟶ 𝟙_ A) : + F.map ((λ_ X).inv ≫ (u ▷ X) ≫ (λ_ X).hom) = + (λ_ (F.obj X)).inv ≫ + ((Functor.LaxMonoidal.ε F ≫ F.map u ≫ + Functor.OplaxMonoidal.η F) ▷ F.obj X) ≫ + (λ_ (F.obj X)).hom := by + rw [Functor.map_comp, Functor.map_comp, + Functor.Monoidal.map_leftUnitor_inv, + Functor.Monoidal.map_whiskerRight, + Functor.Monoidal.map_leftUnitor] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc, + Functor.Monoidal.μ_δ_assoc] + +/-- **A strong monoidal functor carries an exact pairing to an exact +pairing**: the coevaluation is the unit comparison followed by the +image of the coevaluation and the cotensorator, the evaluation is the +tensorator followed by the image of the evaluation and the counit +comparison. Both triangle identities descend from the corresponding +identities downstairs, whose image is expanded by the oplax +coherences of `CategoryTheory.Functor.Monoidal`. -/ +@[implicit_reducible] +def exactPairingMap + [Category.{v} A] [MonoidalCategory A] {B : Type u'} [Category.{v'} B] + [MonoidalCategory B] (F : A ⥤ B) [F.Monoidal] + {X Y : A} [ExactPairing X Y] : + ExactPairing (F.obj X) (F.obj Y) where + coevaluation' := + Functor.LaxMonoidal.ε F ≫ F.map (η_ X Y) ≫ + Functor.OplaxMonoidal.δ F X Y + evaluation' := + Functor.LaxMonoidal.μ F Y X ≫ F.map (ε_ X Y) ≫ + Functor.OplaxMonoidal.η F + evaluation_coevaluation' := by + have h := congrArg F.map (ExactPairing.evaluation_coevaluation X Y) + simp only [Functor.map_comp, Functor.Monoidal.map_whiskerRight, + Functor.Monoidal.map_associator, + Functor.Monoidal.map_whiskerLeft, Category.assoc, + Functor.Monoidal.μ_δ_assoc, Functor.Monoidal.map_leftUnitor, + Functor.Monoidal.map_rightUnitor_inv] at h + have h' := Functor.LaxMonoidal.μ F (𝟙_ A) X ≫= h =≫ + Functor.OplaxMonoidal.δ F X (𝟙_ A) + simp only [Category.assoc, Functor.Monoidal.μ_δ_assoc, + Functor.Monoidal.μ_δ, Category.comp_id] at h' + simp only [MonoidalCategory.comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + reassoc_of% h', Functor.Monoidal.whiskerRight_ε_η_assoc, + Functor.Monoidal.whiskerLeft_ε_η, Category.comp_id] + coevaluation_evaluation' := by + have h := congrArg F.map (ExactPairing.coevaluation_evaluation X Y) + simp only [Functor.map_comp, Functor.Monoidal.map_whiskerRight, + Functor.Monoidal.map_associator_inv, + Functor.Monoidal.map_whiskerLeft, Category.assoc, + Functor.Monoidal.μ_δ_assoc, Functor.Monoidal.map_rightUnitor, + Functor.Monoidal.map_leftUnitor_inv] at h + have h' := Functor.LaxMonoidal.μ F Y (𝟙_ A) ≫= h =≫ + Functor.OplaxMonoidal.δ F (𝟙_ A) Y + simp only [Category.assoc, Functor.Monoidal.μ_δ_assoc, + Functor.Monoidal.μ_δ, Category.comp_id] at h' + simp only [MonoidalCategory.comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + reassoc_of% h', Functor.Monoidal.whiskerLeft_ε_η_assoc, + Functor.Monoidal.whiskerRight_ε_η, Category.comp_id] + +end MonoidalFunctor + +/-! ## Duals along the embedding -/ + +section Duals + +variable {C : Type v} + +/-- **Duals transport along the embedding `C ⥤ Ind C`**: the +embedding is strong monoidal (`RS.indOfMonoidal`), and a strong +monoidal functor preserves exact pairings. -/ +instance exactPairingIndOf [SmallCategory C] [MonoidalCategory C] + (X Y : C) [ExactPairing X Y] : + ExactPairing ((indOf : C ⥤ Ind C).obj X) + ((indOf : C ⥤ Ind C).obj Y) := + exactPairingMap indOf + +end Duals + +/-! ## The scalar action along the embedding -/ + +section Scalars + +variable {C : Type v} + +/-- The scalar unit of `Ind C` is the comparison transport of the +scalar unit of `C` along the strong monoidal embedding. -/ +theorem scalarHom_indScalarUnit + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] + (ψ : ℂ ≃+* End (𝟙_ C)) (c : ℂ) : + scalarHom (indScalarUnit ψ) c = + Functor.LaxMonoidal.ε (indOf (C := C)) ≫ indOf.map (ψ c) ≫ + Functor.OplaxMonoidal.η (indOf (C := C)) := by + rw [indOf_oplax_η] + rfl + +/-- **The embedding intertwines the scalar actions**: `indOf` carries +the action of `c` induced by `ψ` to the action of `c` induced by +`RS.indScalarUnit ψ`. No compatibility with an ambient linear +structure is asked: both actions come from the same `ψ`. -/ +theorem indOf_map_scalarSmul + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] + (ψ : ℂ ≃+* End (𝟙_ C)) (c : ℂ) {X Y : C} + (f : X ⟶ Y) : + indOf.map (scalarSmul ψ c f) = + scalarSmul (indScalarUnit ψ) c (indOf.map f) := by + have h : indOf.map ((λ_ X).inv ≫ (scalarHom ψ c ▷ X) ≫ (λ_ X).hom) = + (λ_ (indOf.obj X)).inv ≫ + (scalarHom (indScalarUnit ψ) c ▷ indOf.obj X) ≫ + (λ_ (indOf.obj X)).hom := by + rw [scalarHom_indScalarUnit] + exact monoidalMap_unitConj indOf X (scalarHom ψ c) + calc indOf.map (scalarSmul ψ c f) + = indOf.map ((λ_ X).inv ≫ (scalarHom ψ c ▷ X) ≫ (λ_ X).hom) ≫ + indOf.map f := by + rw [← Functor.map_comp] + simp only [scalarSmul, Category.assoc] + _ = scalarSmul (indScalarUnit ψ) c (indOf.map f) := by + rw [h] + simp only [scalarSmul, Category.assoc] + +end Scalars + +/-! ## The group-algebra action and Schur vanishing -/ + +section AlgebraTransport + +variable {E : Type u} + +/-- Intertwining a fixed morphism is closed under sums. Stated at +general objects and applied by `exact`, so that the endomorphism-ring +structure never enters the rewriting. -/ +private theorem sum_pass [Category.{v} E] + [Preadditive E] {P Q : E} {a b : P ⟶ P} + {a' b' : Q ⟶ Q} {T : P ⟶ Q} (ha : a ≫ T = T ≫ a') + (hb : b ≫ T = T ≫ b') : + (a + b) ≫ T = T ≫ (a' + b') := by + rw [Preadditive.add_comp, Preadditive.comp_add, ha, hb] + +/-- Intertwining a fixed morphism is closed under scalars. -/ +private theorem scale_pass [Category.{v} E] + [Preadditive E] [Linear ℂ E] {P Q : E} + {a : P ⟶ P} {a' : Q ⟶ Q} {T : P ⟶ Q} (r : ℂ) + (h : a ≫ T = T ≫ a') : + (r • a) ≫ T = T ≫ (r • a') := by + rw [Linear.smul_comp, Linear.comp_smul, h] + +/-- **Transport of the group-algebra action**: for the ℂ-linear +structures induced on `C` and on `Ind C` by one scalar unit `ψ`, the +action of the symmetric-group algebra on the tensor powers of an +embedded object is conjugate, under `RS.indOfPowIso`, to the embedded +action. -/ +theorem permAlg_indOf_conj_scalarUnit + {C : Type v} [SmallCategory C] [MonoidalCategory C] + [SymmetricCategory C] [Preadditive C] [HasFiniteColimits C] + [MonoidalPreadditive C] + (ψ : ℂ ≃+* End (𝟙_ C)) (X : C) + {n : ℕ} (x : SymGroupAlgebra n) : + letI := linearOfScalarUnit ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + permAlg (indOf.obj X) n x ≫ (indOfPowIso X n).hom = + (indOfPowIso X n).hom ≫ indOf.map (permAlg X n x) := by + let := linearOfScalarUnit ψ + let := linearOfScalarUnit (indScalarUnit ψ) + have := indOf_additive (C := C) + induction x using MonoidAlgebra.induction_on with + | of σ => + rw [MonoidAlgebra.of_apply, permAlg_single, permAlg_single] + exact indOfPowIso_permMor X n σ + | add p q hp hq => + rw [map_add, map_add] + exact (sum_pass hp hq).trans + (congrArg (fun m => (indOfPowIso X n).hom ≫ m) + (Functor.map_add (F := indOf (C := C))).symm) + | smul c p hp => + rw [map_smul, map_smul] + exact (scale_pass c hp).trans + (congrArg (fun m => (indOfPowIso X n).hom ≫ m) + (indOf_map_scalarSmul ψ c (permAlg X n p)).symm) + +/-- **Schur vanishing transports along the embedding `C ⥤ Ind C`**: +with the ℂ-linear structures induced on `C` and on `Ind C` by one +scalar unit `ψ`, a shape kills an embedded object exactly when it +kills the object downstairs. -/ +theorem schurKilled_indOf {C : Type v} [SmallCategory C] [MonoidalCategory C] + [SymmetricCategory C] [Preadditive C] [HasFiniteColimits C] + [MonoidalPreadditive C] + (ψ : ℂ ≃+* End (𝟙_ C)) (P : SchurPackage.{v}) + (X : C) (μ : YoungDiagram) : + letI := linearOfScalarUnit ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + (SchurKilled P ((indOf : C ⥤ Ind C).obj X) μ ↔ + SchurKilled P X μ) := by + let := linearOfScalarUnit ψ + let := linearOfScalarUnit (indScalarUnit ψ) + have hconj : permAlg (indOf.obj X) μ.card (P.e μ) = + (indOfPowIso X μ.card).hom ≫ + indOf.map (permAlg X μ.card (P.e μ)) ≫ + (indOfPowIso X μ.card).inv := by + rw [← reassoc_of% permAlg_indOf_conj_scalarUnit ψ X (P.e μ), + Iso.hom_inv_id, Category.comp_id] + have hdown : SchurKilled P X μ ↔ + permAlg X μ.card (P.e μ) = + (0 : tensorPow C X μ.card ⟶ tensorPow C X μ.card) := + Iff.rfl + constructor + · intro h0 + have h0' : permAlg (indOf.obj X) μ.card (P.e μ) = + (0 : tensorPow (Ind C) (indOf.obj X) μ.card ⟶ + tensorPow (Ind C) (indOf.obj X) μ.card) := h0 + rw [hconj] at h0' + have h1 := (indOfPowIso X μ.card).inv ≫= h0' =≫ + (indOfPowIso X μ.card).hom + have h2 : indOf.map (permAlg X μ.card (P.e μ)) = 0 := by + simpa using h1 + exact hdown.mpr ((indOf_map_eq_zero_iff _).mp h2) + · intro h0 + change permAlg (indOf.obj X) μ.card (P.e μ) = 0 + rw [hconj, + (indOf_map_eq_zero_iff (permAlg X μ.card (P.e μ))).mpr + (hdown.mp h0), + Limits.zero_comp, Limits.comp_zero] + +end AlgebraTransport + +/-! ## Acceptance -/ + +section Acceptance + +variable {C : Type v} + +example + [SmallCategory C] [MonoidalCategory C] + (X Y : C) [ExactPairing X Y] : + ExactPairing ((indOf : C ⥤ Ind C).obj X) + ((indOf : C ⥤ Ind C).obj Y) := + inferInstance + +example + [SmallCategory C] [MonoidalCategory C] + [RightRigidCategory C] (X : C) : + ExactPairing ((indOf : C ⥤ Ind C).obj X) + ((indOf : C ⥤ Ind C).obj (Xᘁ)) := + inferInstance + +/- The embedded object of a right rigid category has a right dual in +`Ind C`, namely the embedded dual. -/ +example + [SmallCategory C] [MonoidalCategory C] + [RightRigidCategory C] (X : C) : + HasRightDual ((indOf : C ⥤ Ind C).obj X) where + rightDual := (indOf : C ⥤ Ind C).obj (Xᘁ) + +end Acceptance + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSimple.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSimple.lean new file mode 100644 index 0000000000..23c2168afa --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSimple.lean @@ -0,0 +1,136 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchur +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear + +/-! +# The ind-embedding preserves simplicity + +For a small abelian category `C` the embedding `RS.indOf : C ⥤ Ind C` +carries simple objects to simple objects, and hence the unit of +`Ind C` is simple as soon as the unit of `C` is. + +The proof is short because the pin already supplies every input. + +* the embedded objects form a separating family in `Ind C` + (`CategoryTheory.Ind.isSeparating_range_yoneda`), the consequence + of "every ind-object is a filtered colimit of embedded objects" + that the argument actually needs; +* `RS.indOf` is fully faithful, and it preserves and reflects + vanishing of morphisms (`RS.indOf_map_eq_zero_iff`); +* `RS.indOf` preserves finite colimits, hence epimorphisms; +* `Ind C` is abelian (`CategoryTheory.Ind` is abelian for `C` + abelian and small), hence balanced. + +Given a nonzero monomorphism `m : U ⟶ indOf.obj X`, separation +produces an object `W` of `C` and a map `g : indOf.obj W ⟶ U` with +`g ≫ m ≠ 0`. Full faithfulness writes `g ≫ m = indOf.map f` for a +unique nonzero `f : W ⟶ X`, simplicity of `X` makes `f` an +epimorphism, and preservation of epimorphisms makes `g ≫ m` — and +therefore `m` — an epimorphism. A monomorphism that is also an +epimorphism in an abelian category is an isomorphism. + +## Main results + +* `RS.simple_indOf` — the embedding preserves simplicity; +* `RS.simple_unit_ind` — the unit of `Ind C` is simple when the unit + of `C` is; +* `RS.mono_unit_ind` — a nonzero algebra unit in `Ind C` is a + monomorphism. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Limits MonoidalCategory +open scoped MonObj + +universe v + +section Embedding + +variable {C : Type v} + +/-- **The ind-embedding preserves simplicity.** If `X` is a simple +object of a small abelian category `C`, then `indOf.obj X` is a +simple object of `Ind C`. -/ +theorem simple_indOf [SmallCategory C] [Abelian C] + (X : C) [Simple X] : Simple (indOf.obj X) := by + have := indOf_additive (C := C) + constructor + intro U m hm + have := hm + constructor + · -- An isomorphism onto an embedded simple object is nonzero: + -- otherwise the identity of `X` would be killed by a faithful + -- functor. + intro hiso hzero + have := hiso + have hid : 𝟙 (indOf.obj X) = 0 := + calc 𝟙 (indOf.obj X) = inv m ≫ m := (IsIso.inv_hom_id m).symm + _ = inv m ≫ 0 := congrArg (fun t => inv m ≫ t) hzero + _ = 0 := comp_zero + refine id_nonzero X ?_ + refine (indOf (C := C)).map_injective ?_ + rw [CategoryTheory.Functor.map_id, + CategoryTheory.Functor.map_zero, hid] + · -- A nonzero monomorphism onto an embedded simple object is an + -- isomorphism. + intro hne + have hex : ∃ (W : C) (g : indOf.obj W ⟶ U), g ≫ m ≠ 0 := by + by_contra hcon + refine hne (Ind.isSeparating_range_yoneda m 0 ?_) + rintro _ ⟨W⟩ g + have hg : g ≫ m = 0 := not_not.mp fun h => hcon ⟨W, g, h⟩ + simp [hg] + obtain ⟨W, g, hgm⟩ := hex + have hmap : indOf.map + (Ind.yoneda.fullyFaithful.preimage (g ≫ m)) = g ≫ m := + Ind.yoneda.fullyFaithful.map_preimage (g ≫ m) + have hfne : Ind.yoneda.fullyFaithful.preimage (g ≫ m) ≠ 0 := by + intro h0 + exact hgm (((indOf_map_eq_zero_iff _).mpr h0).symm.trans hmap).symm + have : Epi (Ind.yoneda.fullyFaithful.preimage (g ≫ m)) := + epi_of_nonzero_to_simple hfne + have : Epi (g ≫ m) := by + rw [← hmap] + infer_instance + have : Epi m := epi_of_epi g m + exact isIso_of_mono_of_epi m + +end Embedding + +section Unit + +variable {C : Type v} + +/-- **The unit of `Ind C` is simple** whenever the unit of `C` is: +the unit of `Ind C` is the embedded unit (`RS.indOfUnitIso`), and +the embedding preserves simplicity. -/ +theorem simple_unit_ind [SmallCategory C] [MonoidalCategory C] [Abelian C] + (hsimple : Simple (𝟙_ C)) : + Simple (𝟙_ (Ind C)) := + haveI := hsimple + haveI := simple_indOf (𝟙_ C) + Simple.of_iso (indOfUnitIso (C := C)) + +/-- **A nonzero algebra unit in `Ind C` is a monomorphism.** This +is the faithful-flatness input to faithfulness of Deligne's fibre +functor: the unit of `Ind C` is simple, so any nonzero morphism out +of it is a monomorphism. -/ +theorem mono_unit_ind [SmallCategory C] [MonoidalCategory C] [Abelian C] + (hsimple : Simple (𝟙_ C)) (A : Ind C) + [MonObj A] (hne : η[A] ≠ 0) : Mono η[A] := + haveI := simple_unit_ind hsimple + mono_of_nonzero_from_simple hne + +end Unit + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplit.lean new file mode 100644 index 0000000000..93cc677f9e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplit.lean @@ -0,0 +1,570 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CycleSplit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedConc + +/-! +# Additive splitting of Schur specialisations + +The Schur specialisation of a diagram at a pointwise sum of scalar +sequences splits over pairs of shapes whose sizes add to the size of +the diagram, with induction multiplicities: the normalized pairings +of the recast Jacobi–Trudi character of the diagram, restricted to a +block product of symmetric groups, against the characters of the two +shapes. The multiplicities are nonnegative integers, being +dimensions of equivariant Hom spaces over the product group. + +The route: the Frobenius formula at a sum of sequences, the additive +splitting of the completed cycle product over invariant subsets, a +reindexing of the invariant permutations of a subset of fixed size +by pairs of block permutations, the collapse of the subset sum by +the binomial count, and the character expansion of each block +factor. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv + +/-! ### Conjugation invariance of the Jacobi–Trudi character -/ + +open scoped Classical in +/-- The Jacobi–Trudi character is a class function. -/ +theorem jtChar_conj (μ : YoungDiagram) (τ π : Equiv.Perm (Fin μ.card)) : + jtChar μ (τ * π * τ⁻¹) = jtChar μ π := by + rw [jtChar, jtChar] + refine Finset.sum_congr rfl fun σ _ => ?_ + congr 1 + by_cases hp : ∀ i, 0 ≤ jtSigned μ σ i + · rw [ite_eq_left hp, ite_eq_left hp, colourChar_conj] + · rw [ite_eq_right hp, ite_eq_right hp] + +/-- **Transport independence of the recast Jacobi–Trudi character**: +relabelling a permutation of an abstract carrier into the symmetric +group of the diagram gives the same character value whichever +equivalence performs the relabelling — two choices differ by an +inner automorphism. -/ +theorem jtChar_permCongr_congr (lam : YoungDiagram) {α : Type*} + (g₁ g₂ : α ≃ Fin lam.card) (π : Equiv.Perm α) : + jtChar lam (g₁.permCongr π) = jtChar lam (g₂.permCongr π) := by + have key : g₁.permCongr π = + (g₁.symm.trans g₂)⁻¹ * g₂.permCongr π * (g₁.symm.trans g₂) := by + refine Equiv.ext fun x => ?_ + simp [Equiv.Perm.mul_apply, Equiv.Perm.inv_def] + have h := jtChar_conj lam (g₁.symm.trans g₂)⁻¹ (g₂.permCongr π) + rw [inv_inv] at h + rw [key, h] + +/-! ### The block embedding as a homomorphism from the product -/ + +/-- **The block embedding of the product group**: the monoid +homomorphism `S_a × S_b →* S_{a + b}` carrying a pair to its block +embedding, the first factor on the first `a` slots and the second on +the last `b`. -/ +noncomputable def blockEmbedHom (a b : ℕ) : + Equiv.Perm (Fin a) × Equiv.Perm (Fin b) →* + Equiv.Perm (Fin (a + b)) where + toFun p := blockEmbed p.1 p.2 + map_one' := blockEmbed_one + map_mul' p q := blockEmbed_mul p.1 q.1 p.2 q.2 + +/-- The block embedding carries inverses to inverses. -/ +theorem blockEmbed_inv {a b : ℕ} (σ : Equiv.Perm (Fin a)) + (τ : Equiv.Perm (Fin b)) : + blockEmbed σ⁻¹ τ⁻¹ = (blockEmbed σ τ)⁻¹ := by + refine eq_inv_of_mul_eq_one_left ?_ + rw [← blockEmbed_mul, inv_mul_cancel, inv_mul_cancel, blockEmbed_one] + +private theorem blockEmbed_injective {a b : ℕ} + {σ σ' : Equiv.Perm (Fin a)} {τ τ' : Equiv.Perm (Fin b)} + (h : blockEmbed σ τ = blockEmbed σ' τ') : σ = σ' ∧ τ = τ' := by + constructor + · refine Equiv.ext fun i => ?_ + have h1 : Fin.castAdd b (σ i) = Fin.castAdd b (σ' i) := by + rw [← blockEmbed_castAdd σ τ i, h, blockEmbed_castAdd] + have h2 := congrArg Fin.val h1 + exact Fin.ext h2 + · refine Equiv.ext fun j => ?_ + have h1 : Fin.natAdd a (τ j) = Fin.natAdd a (τ' j) := by + rw [← blockEmbed_natAdd σ τ j, h, blockEmbed_natAdd] + have h2 : a + (τ j).val = a + (τ' j).val := congrArg Fin.val h1 + exact Fin.ext (Nat.add_left_cancel h2) + +/-! ### Induction multiplicities -/ + +/-- **The induction multiplicity** of a pair of shapes in a shape of +the joint size: the normalized pairing, over the block product +`S_a × S_b`, of the recast Jacobi–Trudi character of the joint shape +with the recast characters of the two shapes. -/ +noncomputable def indMult {a b : ℕ} (lam : Shape (a + b)) (μ : Shape a) + (ν : Shape b) : ℂ := + ((a.factorial : ℂ) * (b.factorial : ℂ))⁻¹ * + ∑ σ : Equiv.Perm (Fin a), ∑ τ : Equiv.Perm (Fin b), + jtChar lam.val (permCast lam.prop.symm (blockEmbed σ τ)) * + jtChar μ.val (permCast μ.prop.symm σ) * + jtChar ν.val (permCast ν.prop.symm τ) + +/-- **Induction multiplicities are nonnegative integers**: the +pairing is the dimension of the space of `S_a × S_b`-equivariant +maps from the restricted joint irreducible to the external tensor +product of the two block irreducibles. -/ +theorem indMult_exists_nat {a b : ℕ} (lam : Shape (a + b)) + (μ : Shape a) (ν : Shape b) : + ∃ m : ℕ, indMult lam μ ν = m := by + classical + set ρl : Representation ℂ (Equiv.Perm (Fin a) × Equiv.Perm (Fin b)) + (subCarrier (jtSimple lam.val)) := + (rhoS (jtSimple lam.val)).comp + ((permCastHom lam.prop.symm).comp (blockEmbedHom a b)) with hρl + set ρμ : Representation ℂ (Equiv.Perm (Fin a) × Equiv.Perm (Fin b)) + (subCarrier (jtSimple μ.val)) := + (rhoS (jtSimple μ.val)).comp + ((permCastHom μ.prop.symm).comp (MonoidHom.fst _ _)) with hρμ + set ρν : Representation ℂ (Equiv.Perm (Fin a) × Equiv.Perm (Fin b)) + (subCarrier (jtSimple ν.val)) := + (rhoS (jtSimple ν.val)).comp + ((permCastHom ν.prop.symm).comp (MonoidHom.snd _ _)) with hρν + have hcard0 : ((Nat.card + (Equiv.Perm (Fin a) × Equiv.Perm (Fin b)) : ℂ)) ≠ 0 := by + rw [Nat.card_eq_fintype_card] + exact_mod_cast Fintype.card_ne_zero + have : Invertible ((Nat.card + (Equiv.Perm (Fin a) × Equiv.Perm (Fin b)) : ℂ)) := + invertibleOfNonzero hcard0 + have h := Representation.card_inv_mul_sum_char_mul_char_eq_finrank + (W := TensorProduct ℂ (subCarrier (jtSimple μ.val)) + (subCarrier (jtSimple ν.val))) + ρl (Representation.tprod ρμ ρν) + refine ⟨Module.finrank ℂ + (Representation.IntertwiningMap ρl + (Representation.tprod ρμ ρν)), ?_⟩ + rw [← h, indMult] + rw [show ((a.factorial : ℂ) * (b.factorial : ℂ))⁻¹ = + ((Nat.card (Equiv.Perm (Fin a) × Equiv.Perm (Fin b)) : ℂ))⁻¹ + from by + rw [Nat.card_eq_fintype_card, Fintype.card_prod, + Fintype.card_perm, Fintype.card_perm, Fintype.card_fin, + Fintype.card_fin, Nat.cast_mul]] + congr 1 + rw [Fintype.sum_prod_type] + refine Finset.sum_congr rfl fun σ _ => ?_ + refine Finset.sum_congr rfl fun τ _ => ?_ + rw [Representation.char_tensor, Pi.mul_apply] + rw [show ρμ.character (σ, τ) = + jtChar μ.val (permCast μ.prop.symm σ) from by + rw [jtSimple_char μ.val]; rfl] + rw [show ρν.character (σ, τ) = + jtChar ν.val (permCast ν.prop.symm τ) from by + rw [jtSimple_char ν.val]; rfl] + rw [show ρl.character (σ, τ)⁻¹ = + jtChar lam.val (permCast lam.prop.symm (blockEmbed σ τ)) from by + rw [show ρl.character (σ, τ)⁻¹ = nChar (jtSimple lam.val) + (permCast lam.prop.symm (blockEmbed σ⁻¹ τ⁻¹)) from rfl, + blockEmbed_inv, permCast_inv, ← jtSimple_char lam.val, + jtChar_inv]] + ring + +/-! ### Assembling a subset and its complement into a block carrier + +A subset of `Fin n` of size `a` with complement of size `b`, once +equivalences of the subset with `Fin a` and of the complement with +`Fin b` are chosen, assembles into an equivalence +`Fin n ≃ Fin (a + b)` carrying the subset onto the first block. +Conjugation along it carries a permutation preserving the subset to +the block embedding of its two restrictions. -/ + +section Assemble + +variable {n a b : ℕ} {s : Finset (Fin n)} + +/-- The assembled block equivalence of a subset and its +complement. -/ +private noncomputable def assembleE (es : {x // x ∈ s} ≃ Fin a) + (ec : {x // x ∈ sᶜ} ≃ Fin b) : Fin n ≃ Fin (a + b) := + (Equiv.sumCompl (fun x => x ∈ s)).symm.trans + ((es.sumCongr + ((Equiv.subtypeEquivRight + (fun x => Iff.symm (Finset.mem_compl (a := x)))).trans ec)).trans + finSumFinEquiv) + +private theorem assembleE_coe_mem (es : {x // x ∈ s} ≃ Fin a) + (ec : {x // x ∈ sᶜ} ≃ Fin b) (u : {x // x ∈ s}) : + assembleE es ec ↑u = Fin.castAdd b (es u) := by + simp [assembleE] + +private theorem assembleE_coe_compl (es : {x // x ∈ s} ≃ Fin a) + (ec : {x // x ∈ sᶜ} ≃ Fin b) (u : {x // x ∈ sᶜ}) : + assembleE es ec ↑u = Fin.natAdd a (ec u) := by + have hu : ¬ (↑u : Fin n) ∈ s := Finset.mem_compl.mp u.2 + have hval : ((Equiv.subtypeEquivRight + (fun x => Iff.symm (Finset.mem_compl (a := x)))) + ⟨↑u, hu⟩ : {x // x ∈ sᶜ}) = u := + Subtype.ext rfl + simp [assembleE, Equiv.sumCompl_symm_apply_of_neg hu, hval] + +private theorem assembleE_symm_castAdd (es : {x // x ∈ s} ≃ Fin a) + (ec : {x // x ∈ sᶜ} ≃ Fin b) (i : Fin a) : + (assembleE es ec).symm (Fin.castAdd b i) = ↑(es.symm i) := by + rw [Equiv.symm_apply_eq, assembleE_coe_mem, Equiv.apply_symm_apply] + +private theorem assembleE_symm_natAdd (es : {x // x ∈ s} ≃ Fin a) + (ec : {x // x ∈ sᶜ} ≃ Fin b) (j : Fin b) : + (assembleE es ec).symm (Fin.natAdd a j) = ↑(ec.symm j) := by + rw [Equiv.symm_apply_eq, assembleE_coe_compl, Equiv.apply_symm_apply] + +/-- Conjugating an invariant permutation along the assembled block +equivalence gives the block embedding of its two restrictions. -/ +private theorem assembleE_permCongr (es : {x // x ∈ s} ≃ Fin a) + (ec : {x // x ∈ sᶜ} ≃ Fin b) {π : Equiv.Perm (Fin n)} + (h : ∀ x, π x ∈ s ↔ x ∈ s) (hc : ∀ x, π x ∈ sᶜ ↔ x ∈ sᶜ) : + (assembleE es ec).permCongr π = + blockEmbed (es.permCongr (π.subtypePerm h)) + (ec.permCongr (π.subtypePerm hc)) := by + refine Equiv.ext fun x => ?_ + induction x using Fin.addCases with + | left i => + rw [blockEmbed_castAdd, Equiv.permCongr_apply, assembleE_symm_castAdd, + show π ↑(es.symm i) = ↑((π.subtypePerm h) (es.symm i)) from rfl, + assembleE_coe_mem, Equiv.permCongr_apply] + | right j => + rw [blockEmbed_natAdd, Equiv.permCongr_apply, assembleE_symm_natAdd, + show π ↑(ec.symm j) = ↑((π.subtypePerm hc) (ec.symm j)) from rfl, + assembleE_coe_compl, Equiv.permCongr_apply] + +/-- The assembled conjugate of a block embedding preserves the +subset. -/ +private theorem assembled_invariant (es : {x // x ∈ s} ≃ Fin a) + (ec : {x // x ∈ sᶜ} ≃ Fin b) (σ : Equiv.Perm (Fin a)) + (τ : Equiv.Perm (Fin b)) : + ∀ x ∈ s, (assembleE es ec).symm.permCongr (blockEmbed σ τ) x ∈ s := by + intro x hx + rw [Equiv.permCongr_apply, Equiv.symm_symm, + show (assembleE es ec) x = Fin.castAdd b (es ⟨x, hx⟩) from + assembleE_coe_mem es ec ⟨x, hx⟩, + blockEmbed_castAdd, assembleE_symm_castAdd] + exact (es.symm _).2 + +end Assemble + +private theorem permCongr_comp {α β γ : Type*} (e : α ≃ β) (f : β ≃ γ) + (π : Equiv.Perm α) : + f.permCongr (e.permCongr π) = (e.trans f).permCongr π := by + refine Equiv.ext fun x => ?_ + simp + +/-! ### The invariant-permutation sum at a fixed subset -/ + +/-- The sum over permutations preserving a subset of size `a`, of +the recast character of `lam` against the two restricted completed +cycle products, reindexed by pairs of block permutations. -/ +private theorem sum_invariant_eq {n a b : ℕ} (lam : YoungDiagram) + (hL : lam.card = n) (hab : lam.card = a + b) (t t' : ℕ → ℂ) + (s : Finset (Fin n)) (hs : s.card = a) (hsc : sᶜ.card = b) : + ∑ π ∈ Finset.univ.filter + (fun π : Equiv.Perm (Fin n) => ∀ x ∈ s, π x ∈ s), + jtChar lam (permCast hL.symm π) * + (cycleFunG t (permRestrict π s) * + cycleFunG t' (permRestrict π sᶜ)) = + ∑ σ : Equiv.Perm (Fin a), ∑ τ : Equiv.Perm (Fin b), + jtChar lam (permCast hab.symm (blockEmbed σ τ)) * + (cycleFun t σ * cycleFun t' τ) := by + classical + have hes : Fintype.card {x // x ∈ s} = a := by + rw [Fintype.card_coe]; exact hs + have hec : Fintype.card {x // x ∈ sᶜ} = b := by + rw [Fintype.card_coe]; exact hsc + set es : {x // x ∈ s} ≃ Fin a := Fintype.equivFinOfCardEq hes + with hesdef + set ec : {x // x ∈ sᶜ} ≃ Fin b := Fintype.equivFinOfCardEq hec + with hecdef + refine Eq.trans ?_ (Fintype.sum_prod_type + (f := fun p : Equiv.Perm (Fin a) × Equiv.Perm (Fin b) => + jtChar lam (permCast hab.symm (blockEmbed p.1 p.2)) * + (cycleFun t p.1 * cycleFun t' p.2))) + refine Finset.sum_nbij' + (fun π => (es.permCongr (permRestrict π s), + ec.permCongr (permRestrict π sᶜ))) + (fun p => (assembleE es ec).symm.permCongr (blockEmbed p.1 p.2)) + ?_ ?_ ?_ ?_ ?_ + · exact fun π _ => Finset.mem_univ _ + · intro p _ + rw [Finset.mem_filter] + exact ⟨Finset.mem_univ _, assembled_invariant es ec p.1 p.2⟩ + · intro π hπ + rw [Finset.mem_filter] at hπ + have hinv := mem_iff_of_invariant hπ.2 + have hinvc := mem_iff_of_invariant (invariant_compl hπ.2) + rw [permRestrict_of_invariant hinv, permRestrict_of_invariant hinvc, + ← assembleE_permCongr es ec hinv hinvc] + exact Equiv.symm_apply_apply + (Equiv.permCongr (assembleE es ec)) π + · intro p _ + have hone : ∀ x ∈ s, + (assembleE es ec).symm.permCongr (blockEmbed p.1 p.2) x ∈ s := + assembled_invariant es ec p.1 p.2 + have hinv := mem_iff_of_invariant hone + have hinvc := mem_iff_of_invariant (invariant_compl hone) + have hkey : (assembleE es ec).permCongr + ((assembleE es ec).symm.permCongr (blockEmbed p.1 p.2)) = + blockEmbed p.1 p.2 := + Equiv.apply_symm_apply + (Equiv.permCongr (assembleE es ec)) (blockEmbed p.1 p.2) + have heq := (assembleE_permCongr es ec hinv hinvc).symm.trans hkey + obtain ⟨h1, h2⟩ := blockEmbed_injective heq + rw [permRestrict_of_invariant hinv, permRestrict_of_invariant hinvc] + exact Prod.ext h1 h2 + · intro π hπ + rw [Finset.mem_filter] at hπ + have hinv := mem_iff_of_invariant hπ.2 + have hinvc := mem_iff_of_invariant (invariant_compl hπ.2) + dsimp only + rw [← cycleFunG_fin t, ← cycleFunG_fin t', + cycleFunG_permCongr es, cycleFunG_permCongr ec, + permRestrict_of_invariant hinv, permRestrict_of_invariant hinvc, + ← assembleE_permCongr es ec hinv hinvc] + congr 1 + rw [show permCast hab.symm ((assembleE es ec).permCongr π) = + ((assembleE es ec).trans (finCongr hab.symm)).permCongr π from + permCongr_comp _ _ _] + rw [show permCast hL.symm π = (finCongr hL.symm).permCongr π from + rfl] + exact jtChar_permCongr_congr lam _ _ π + +/-! ### Character expansion of the block sums -/ + +/-- A weighted sum of completed cycle products expands over the +shapes with Schur coefficients. -/ +private theorem sum_mul_cycleFun_expand {m : ℕ} (t : ℕ → ℂ) + (F : Equiv.Perm (Fin m) → ℂ) : + ∑ σ : Equiv.Perm (Fin m), F σ * cycleFun t σ = + ∑ μ : Shape m, diagramSchur μ.val t * + ∑ σ : Equiv.Perm (Fin m), + F σ * jtChar μ.val (permCast μ.prop.symm σ) := by + rw [Finset.sum_congr rfl fun σ _ => by + rw [cycleFun_expand t σ, Finset.mul_sum]] + rw [Finset.sum_comm] + refine Finset.sum_congr rfl fun μ _ => ?_ + rw [Finset.mul_sum] + refine Finset.sum_congr rfl fun σ _ => by ring + +/-- The normalization exchange: dividing the binomial count by the +joint factorial is dividing by the product of the block +factorials. -/ +private theorem inv_factorial_choose {n a : ℕ} (h : a ≤ n) : + ((n.factorial : ℂ))⁻¹ * (n.choose a : ℂ) = + ((a.factorial : ℂ) * ((n - a).factorial : ℂ))⁻¹ := by + have hnat : n.choose a * (a.factorial * (n - a).factorial) = + n.factorial := by + rw [← mul_assoc] + exact Nat.choose_mul_factorial_mul_factorial h + have hcast : (n.choose a : ℂ) * + ((a.factorial : ℂ) * ((n - a).factorial : ℂ)) = + (n.factorial : ℂ) := by + exact_mod_cast congrArg (fun k : ℕ => (k : ℂ)) hnat + have ha0 : (a.factorial : ℂ) ≠ 0 := + Nat.cast_ne_zero.mpr (Nat.factorial_ne_zero a) + have hb0 : ((n - a).factorial : ℂ) ≠ 0 := + Nat.cast_ne_zero.mpr (Nat.factorial_ne_zero (n - a)) + have hn0 : (n.factorial : ℂ) ≠ 0 := + Nat.cast_ne_zero.mpr (Nat.factorial_ne_zero n) + field_simp + linear_combination hcast + +/-- **The block pair sum is the induction-multiplicity expansion**: +normalizing the sum of the recast joint character against the two +completed cycle products and expanding each factor over its shapes +produces the induction multiplicities. -/ +private theorem pairSum_expand {a b : ℕ} (lam : YoungDiagram) + (hab : lam.card = a + b) (t t' : ℕ → ℂ) : + ((a.factorial : ℂ) * (b.factorial : ℂ))⁻¹ * + ∑ σ : Equiv.Perm (Fin a), ∑ τ : Equiv.Perm (Fin b), + jtChar lam (permCast hab.symm (blockEmbed σ τ)) * + (cycleFun t σ * cycleFun t' τ) = + ∑ μ : Shape a, ∑ ν : Shape b, + indMult ⟨lam, hab⟩ μ ν * + diagramSchur μ.val t * diagramSchur ν.val t' := by + classical + -- expand the τ-factor over the shapes of `b` + rw [Finset.sum_congr rfl fun σ _ => by + rw [Finset.sum_congr rfl fun τ _ => + (mul_assoc (jtChar lam (permCast hab.symm (blockEmbed σ τ))) + (cycleFun t σ) (cycleFun t' τ)).symm, + sum_mul_cycleFun_expand t' + (fun τ => jtChar lam (permCast hab.symm (blockEmbed σ τ)) * + cycleFun t σ)]] + -- swap the σ-sum inside the ν-sum + rw [Finset.sum_comm] + -- expand the σ-factor over the shapes of `a` + rw [Finset.sum_congr rfl fun ν _ => by + rw [Finset.sum_congr rfl fun σ _ => by + rw [Finset.sum_congr rfl fun τ _ => show + (jtChar lam (permCast hab.symm (blockEmbed σ τ)) * + cycleFun t σ) * + jtChar ν.val (permCast ν.prop.symm τ) = + (jtChar lam (permCast hab.symm (blockEmbed σ τ)) * + jtChar ν.val (permCast ν.prop.symm τ)) * + cycleFun t σ from by ring, + ← Finset.sum_mul, ← mul_assoc], + sum_mul_cycleFun_expand t + (fun σ => diagramSchur ν.val t' * + ∑ τ : Equiv.Perm (Fin b), + jtChar lam (permCast hab.symm (blockEmbed σ τ)) * + jtChar ν.val (permCast ν.prop.symm τ))]] + -- swap the shape sums of the target to align the binders + rw [Finset.sum_comm (s := (Finset.univ : Finset (Shape a))) + (t := (Finset.univ : Finset (Shape b))) + (f := fun μ ν => indMult ⟨lam, hab⟩ μ ν * + diagramSchur μ.val t * diagramSchur ν.val t')] + -- distribute the normalization and identify the multiplicities + rw [Finset.mul_sum] + refine Finset.sum_congr rfl fun ν _ => ?_ + rw [Finset.mul_sum] + refine Finset.sum_congr rfl fun μ _ => ?_ + rw [Finset.sum_congr rfl fun σ _ => show + (diagramSchur ν.val t' * + ∑ τ : Equiv.Perm (Fin b), + jtChar lam (permCast hab.symm (blockEmbed σ τ)) * + jtChar ν.val (permCast ν.prop.symm τ)) * + jtChar μ.val (permCast μ.prop.symm σ) = + diagramSchur ν.val t' * + ∑ τ : Equiv.Perm (Fin b), + jtChar lam (permCast hab.symm (blockEmbed σ τ)) * + jtChar μ.val (permCast μ.prop.symm σ) * + jtChar ν.val (permCast ν.prop.symm τ) from by + rw [mul_assoc, Finset.sum_mul] + congr 1 + exact Finset.sum_congr rfl fun τ _ => by ring] + rw [← Finset.mul_sum] + dsimp only [indMult] + ring + +/-! ### The splitting identity -/ + +/-- Swapping a sum over a filtered inner range: the filter moves to +the other variable through the indicator form. -/ +private theorem sum_sum_filter_comm {α β : Type*} [Fintype α] + [Fintype β] (p : α → β → Prop) [∀ a b, Decidable (p a b)] + (F : α → β → ℂ) : + ∑ a : α, ∑ b ∈ Finset.univ.filter (p a), F a b = + ∑ b : β, ∑ a ∈ Finset.univ.filter (fun a => p a b), F a b := by + rw [Finset.sum_congr rfl fun a _ => Finset.sum_filter (p a) (F a)] + rw [Finset.sum_comm] + exact Finset.sum_congr rfl fun b _ => + (Finset.sum_filter (fun a => p a b) (fun a => F a b)).symm + +/-- The splitting identity in fixed-size form: the diagram sum over +the sizes of the first block, with the block pair sums still +unexpanded. -/ +private theorem diagramSchur_add_aux (lam : YoungDiagram) + (t t' : ℕ → ℂ) : + diagramSchur lam (fun c => t c + t' c) = + ∑ a ∈ (Finset.range (lam.card + 1)).attach, + ((a.1.factorial : ℂ) * ((lam.card - a.1).factorial : ℂ))⁻¹ * + ∑ σ : Equiv.Perm (Fin a.1), + ∑ τ : Equiv.Perm (Fin (lam.card - a.1)), + jtChar lam (permCast (Nat.add_sub_cancel' + (Nat.lt_succ_iff.mp (Finset.mem_range.mp a.2))) + (blockEmbed σ τ)) * + (cycleFun t σ * cycleFun t' τ) := by + classical + rw [show diagramSchur lam (fun c => t c + t' c) = + diagramSchur (⟨lam, rfl⟩ : Shape lam.card).val + (fun c => t c + t' c) from rfl, + ← jtChar_shape_frobenius (⟨lam, rfl⟩ : Shape lam.card) + (fun c => t c + t' c)] + rw [Finset.sum_congr rfl fun π _ => by + rw [cycleFun_add_split t t' π, Finset.mul_sum]] + rw [sum_sum_filter_comm + (fun (π : Equiv.Perm (Fin lam.card)) (s : Finset (Fin lam.card)) => + ∀ x ∈ s, π x ∈ s) + (fun π s => jtChar (⟨lam, rfl⟩ : Shape lam.card).val + (permCast (⟨lam, rfl⟩ : Shape lam.card).prop.symm π) * + (cycleFunG t (permRestrict π s) * + cycleFunG t' (permRestrict π sᶜ)))] + rw [← Finset.sum_fiberwise_of_maps_to + (g := Finset.card) (t := Finset.range (lam.card + 1)) + (fun s _ => Finset.mem_range.mpr (Nat.lt_succ_of_le + (le_trans (Finset.card_le_univ s) + (le_of_eq (Fintype.card_fin lam.card))))) + (fun s => ∑ π ∈ Finset.univ.filter + (fun π : Equiv.Perm (Fin lam.card) => ∀ x ∈ s, π x ∈ s), + jtChar (⟨lam, rfl⟩ : Shape lam.card).val + (permCast (⟨lam, rfl⟩ : Shape lam.card).prop.symm π) * + (cycleFunG t (permRestrict π s) * + cycleFunG t' (permRestrict π sᶜ)))] + rw [← Finset.sum_attach (Finset.range (lam.card + 1)) + (fun j => ∑ s ∈ Finset.univ.filter + (fun s : Finset (Fin lam.card) => s.card = j), + ∑ π ∈ Finset.univ.filter + (fun π : Equiv.Perm (Fin lam.card) => ∀ x ∈ s, π x ∈ s), + jtChar (⟨lam, rfl⟩ : Shape lam.card).val + (permCast (⟨lam, rfl⟩ : Shape lam.card).prop.symm π) * + (cycleFunG t (permRestrict π s) * + cycleFunG t' (permRestrict π sᶜ)))] + rw [Finset.mul_sum] + refine Finset.sum_congr rfl fun a _ => ?_ + have hle : a.1 ≤ lam.card := + Nat.lt_succ_iff.mp (Finset.mem_range.mp a.2) + have hab : lam.card = a.1 + (lam.card - a.1) := + (Nat.add_sub_cancel' hle).symm + rw [Finset.sum_congr rfl fun s hs => + sum_invariant_eq lam rfl hab t t' s + (Finset.mem_filter.mp hs).2 + (by rw [Finset.card_compl, Fintype.card_fin, + (Finset.mem_filter.mp hs).2])] + rw [Finset.sum_const] + rw [show (Finset.univ.filter + (fun s : Finset (Fin lam.card) => s.card = a.1)) = + Finset.powersetCard a.1 (Finset.univ : Finset (Fin lam.card)) + from by + rw [Finset.powersetCard_eq_filter, Finset.powerset_univ]] + rw [Finset.card_powersetCard, Finset.card_univ, Fintype.card_fin, + nsmul_eq_mul, ← mul_assoc, inv_factorial_choose hle] + +/-- **The additive splitting of Schur specialisations** — the +character shadow of the `⊕`-splitting: the Schur specialisation of +a diagram at a pointwise sum of scalar sequences is the sum, over +splittings of its size recorded on the antidiagonal and over pairs +of shapes of the two parts, of the induction-multiplicity-weighted +products of the Schur specialisations of the parts. The +antidiagonal is attached so that each index carries the proof that +its parts sum to the size of the diagram. -/ +theorem diagramSchur_add (lam : YoungDiagram) (t t' : ℕ → ℂ) : + diagramSchur lam (fun c => t c + t' c) = + ∑ ab ∈ (Finset.antidiagonal lam.card).attach, + ∑ μ : Shape ab.1.1, ∑ ν : Shape ab.1.2, + indMult ⟨lam, (Finset.mem_antidiagonal.mp ab.2).symm⟩ μ ν * + diagramSchur μ.val t * diagramSchur ν.val t' := by + classical + rw [diagramSchur_add_aux lam t t'] + rw [Finset.sum_congr rfl fun a _ => + pairSum_expand lam + ((Nat.add_sub_cancel' + (Nat.lt_succ_iff.mp (Finset.mem_range.mp a.2))).symm) t t'] + refine Finset.sum_nbij' + (fun a => ⟨(a.1, lam.card - a.1), Finset.mem_antidiagonal.mpr + (Nat.add_sub_cancel' + (Nat.lt_succ_iff.mp (Finset.mem_range.mp a.2)))⟩) + (fun ab => ⟨ab.1.1, Finset.mem_range.mpr (Nat.lt_succ_of_le + (le_of_add_le_left + (le_of_eq (Finset.mem_antidiagonal.mp ab.2))))⟩) + ?_ ?_ ?_ ?_ ?_ + · exact fun a _ => Finset.mem_attach _ _ + · exact fun ab _ => Finset.mem_attach _ _ + · exact fun a _ => Subtype.ext rfl + · intro ab _ + refine Subtype.ext ?_ + have h := Finset.mem_antidiagonal.mp ab.2 + have h2 : lam.card - ab.1.1 = ab.1.2 := by omega + exact Prod.ext rfl h2 + · exact fun a _ => rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplitSection.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplitSection.lean new file mode 100644 index 0000000000..0569dc48ea --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplitSection.lean @@ -0,0 +1,207 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchurKilled +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Ind + +/-! +# The base-change section for embedded short exact sequences + +`RS.Classical.Deligne.Rappel210Ind` proves the local splitting +statement (Deligne 2.10) over `Ind C` for every short exact sequence +`S` whose quotient `S.X₃`, whose dual `S.X₃ᘁ` and whose unit-form +middle `RS.unitFormMid S` carry the duals used in the reduction. +This file discharges all four of those side conditions for the +sequences that the fibre-functor assembly actually consumes: the +images `T.map RS.indOf` of short exact sequences of `C`. + +* `RS.exactPairingOfIso` — an exact pairing transports along an + isomorphism of its left leg (Mathlib has the analogous + `CategoryTheory.rightDualIso`/`leftDualIso` comparisons, but no + transport of the pairing itself); +* `RS.hasRightDualIndOf` — embedded objects carry right duals, + from `RS.exactPairingIndOf`; the dual of `RS.indOf.obj X` is + `RS.indOf.obj (Xᘁ)` by construction, so the duals of `S.X₃ᘁ` are + instances of the same lemma and `HasLeftDual (S.X₃ᘁ)` is + Mathlib's `CategoryTheory.hasLeftDualRightDual`; +* `RS.unitName_indOf` — the name of the identity transports along + the embedding, from the strong braided monoidal structure + `RS.indOfBraided`; +* `RS.unitFormMidIndOfIso` — **the unit-form middle of an embedded + sequence is embedded**: `RS.unitFormMid` is a pullback of maps + between embedded objects, and `RS.indOf` preserves limits, so the + comparison isomorphisms of the tensor and unit comparisons turn + the cospan upstairs into the image of the cospan downstairs; +* `RS.rappel210_indOf` — **Deligne 2.10 for embedded sequences**. + +The fourth side condition is the only one with content: `C` is +rigid, so the pullback taken in `C` has a right dual there, and +`RS.exactPairingOfIso` carries the embedded pairing across the +comparison isomorphism. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +section Transport + +variable {D : Type u} + +/-- Exact pairings transport along an isomorphism of the left leg. -/ +@[implicit_reducible] +def exactPairingOfIso [Category.{v} D] [MonoidalCategory D] + {X X' Y : D} [ExactPairing X Y] (e : X ≅ X') : + ExactPairing X' Y where + coevaluation' := η_ X Y ≫ (e.hom ▷ Y) + evaluation' := (Y ◁ e.inv) ≫ ε_ X Y + coevaluation_evaluation' := by + simp only [MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [associator_inv_naturality_middle_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, + ← MonoidalCategory.whiskerLeft_comp, e.hom_inv_id, + MonoidalCategory.whiskerLeft_id, + MonoidalCategory.id_whiskerRight, Category.id_comp, + ExactPairing.coevaluation_evaluation] + evaluation_coevaluation' := by + simp only [MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [associator_naturality_left_assoc, ← whisker_exchange_assoc, + ← whisker_exchange, ← associator_naturality_right_assoc, + ← whisker_exchange_assoc, + ExactPairing.evaluation_coevaluation_assoc] + simp + +end Transport + +section Embedded + +variable {C : Type v} + +/-- Embedded objects inherit right duals. -/ +noncomputable instance hasRightDualIndOf + [SmallCategory C] [MonoidalCategory C] [RigidCategory C] + (X : C) : + HasRightDual ((indOf : C ⥤ Ind C).obj X) where + rightDual := (indOf : C ⥤ Ind C).obj (Xᘁ) + +/-- The coevaluation of an embedded pairing: the unit comparison, +the image of the coevaluation, and the cotensorator. -/ +theorem coevaluation_indOf + [SmallCategory C] [MonoidalCategory C] [RigidCategory C] + (X : C) : + η_ ((indOf : C ⥤ Ind C).obj X) + ((indOf : C ⥤ Ind C).obj (Xᘁ)) = + Functor.LaxMonoidal.ε (indOf (C := C)) ≫ + indOf.map (η_ X (Xᘁ)) ≫ + Functor.OplaxMonoidal.δ (indOf (C := C)) X (Xᘁ) := rfl + +/-- The cotensorator intertwines the braidings: the embedding is +braided, so the braiding upstairs is the image of the braiding +downstairs, conjugated by the tensor comparisons. -/ +theorem delta_braiding_indOf + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] + (X Y : C) : + Functor.OplaxMonoidal.δ (indOf (C := C)) X Y ≫ + (β_ ((indOf : C ⥤ Ind C).obj X) + ((indOf : C ⥤ Ind C).obj Y)).hom = + indOf.map (β_ X Y).hom ≫ + Functor.OplaxMonoidal.δ (indOf (C := C)) Y X := by + rw [Functor.map_braiding, Category.assoc, Category.assoc, + Functor.Monoidal.μ_δ, Category.comp_id] + +/-- **The name of the identity transports along the embedding**. -/ +theorem unitName_indOf + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] + [RigidCategory C] + (X : C) : + unitName ((indOf : C ⥤ Ind C).obj X) = + Functor.LaxMonoidal.ε (indOf (C := C)) ≫ + indOf.map (unitName X) ≫ + Functor.OplaxMonoidal.δ (indOf (C := C)) (Xᘁ) X := by + have h : unitName ((indOf : C ⥤ Ind C).obj X) = + η_ ((indOf : C ⥤ Ind C).obj X) + ((indOf : C ⥤ Ind C).obj (Xᘁ)) ≫ + (β_ ((indOf : C ⥤ Ind C).obj X) + ((indOf : C ⥤ Ind C).obj (Xᘁ))).hom := rfl + rw [h, coevaluation_indOf, Category.assoc, Category.assoc, + delta_braiding_indOf, unitName, Functor.map_comp] + simp only [Category.assoc] + +/-- **The unit-form middle of an embedded sequence is embedded**: +the pullback displayed here is `RS.unitFormMid (T.map RS.indOf)` +with the dual instance of `RS.hasRightDualIndOf`, written out so +that the statement needs no local instance. The embedding +preserves the pullback, and the tensor and unit comparisons carry +the cospan downstairs to the cospan upstairs. -/ +noncomputable def unitFormMidIndOfIso + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] + (T : ShortComplex C) : + (indOf : C ⥤ Ind C).obj (unitFormMid T) ≅ + pullback ((indOf : C ⥤ Ind C).obj ((T.X₃)ᘁ) ◁ indOf.map T.g) + (unitName ((indOf : C ⥤ Ind C).obj T.X₃)) := + (PreservesPullback.iso (indOf : C ⥤ Ind C) + (((T.X₃)ᘁ) ◁ T.g) (unitName T.X₃)).trans + (HasLimit.isoOfNatIso (cospanExt + (Functor.Monoidal.μIso (indOf : C ⥤ Ind C) + ((T.X₃)ᘁ) T.X₂).symm + (Functor.Monoidal.εIso (indOf : C ⥤ Ind C)).symm + (Functor.Monoidal.μIso (indOf : C ⥤ Ind C) + ((T.X₃)ᘁ) T.X₃).symm + (by + simp only [Iso.symm_hom, Functor.Monoidal.μIso_inv] + exact Functor.OplaxMonoidal.δ_natural_right + (indOf : C ⥤ Ind C) _ _) + (by + simp only [Iso.symm_hom, Functor.Monoidal.μIso_inv, + Functor.Monoidal.εIso_inv] + have hηε : Functor.OplaxMonoidal.η (indOf (C := C)) ≫ + Functor.LaxMonoidal.ε (indOf (C := C)) = 𝟙 _ := + Functor.Monoidal.η_ε _ + rw [unitName_indOf, ← Category.assoc, hηε, + Category.id_comp]))) + +/-- **The local splitting statement for embedded short exact +sequences** (Deligne 2.10): the image in `Ind C` of a short exact +sequence of `C` splits after base change to a nonzero commutative +algebra. The four duality side conditions of `RS.rappel210_ind` are +supplied here: the quotient and its dual are embedded, and so — +up to isomorphism — is the unit-form middle. -/ +theorem rappel210_indOf + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] [Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] + (T : CategoryTheory.ShortComplex C) + (hT : T.ShortExact) (h1 : ¬ IsZero (𝟙_ (Ind C))) : + ∃ (A : Ind C) (_ : MonObj A) (_ : IsCommMonObj A), η[A] ≠ 0 ∧ + ∃ s : freeMod A ((T.map (indOf : C ⥤ Ind C)).X₃) ⟶ + freeMod A ((T.map (indOf : C ⥤ Ind C)).X₂), + s ≫ freeModMap A ((T.map (indOf : C ⥤ Ind C)).g) = + 𝟙 (freeMod A ((T.map (indOf : C ⥤ Ind C)).X₃)) := by + have := indOf_additive (C := C) + let i3 : HasRightDual ((T.map (indOf : C ⥤ Ind C)).X₃) := + hasRightDualIndOf T.X₃ + let i3d : HasRightDual (((T.map (indOf : C ⥤ Ind C)).X₃)ᘁ) := + hasRightDualIndOf ((T.X₃)ᘁ) + let i4 : HasRightDual + (unitFormMid (T.map (indOf : C ⥤ Ind C))) := + { rightDual := (indOf : C ⥤ Ind C).obj ((unitFormMid T)ᘁ) + exact := exactPairingOfIso (unitFormMidIndOfIso T) } + exact rappel210_ind (T.map (indOf : C ⥤ Ind C)) + (hT.map_of_exact (indOf : C ⥤ Ind C)) h1 + +end Embedded + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndTensorExact.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndTensorExact.lean new file mode 100644 index 0000000000..6ced52053a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndTensorExact.lean @@ -0,0 +1,1410 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCompact + +/-! +# Right-exactness of the tensor product on ind-objects + +Deligne's 2.2, exactness half: the transported tensor product of +`Ind C` preserves colimits in each variable, and the monoidal +structure is preadditive. + +For a small monoidal `C` the file proves, unconditionally: + +* `RS.indToDay` — the monoidal embedding of `Ind C` into the Day + presheaf category `Cᵒᵖ ⊛⥤ Type v`, with its `Functor.Monoidal` + instance transported from `RS.indDayEquivalence`; +* `RS.tensorLeft_ind_preservesColimitsOfShape` and the right-hand + and packaged (`PreservesFilteredColimits`) versions — `tensorLeft + X` and `tensorRight X` on `Ind C` preserve all small filtered + colimits, for every `X : Ind C`; +* `RS.indOfTensorIso`/`RS.indOfTensorIsoSymm` — the embedding + `indOf : C ⥤ Ind C` is monoidal up to isomorphism, with + naturality in each variable + (`RS.indOfTensorIso_hom_natural_right`/`_left`); this rests on the + corepresentability calculus for `RS.dayCoyonedaIso` + (`RS.eta_comp_dayCoyonedaIso_hom` and the naturality lemmas for + `RS.dayYonedaIso`). + +For `C` additionally preadditive with finite colimits and a +preadditive tensor (`[Preadditive C] [HasFiniteColimits C] +[MonoidalPreadditive C]` — Deligne's setting, where `C` is abelian +ℂ-linear with exact tensor): + +* `RS.isIso_coprodComparison_tensorLeft`/`_tensorRight` — the binary + coproduct comparisons of both tensoring functors on `Ind C` are + invertible, by a three-stage filtered descent + (`RS.isIso_app_of_isIso_indOf`) from the embedded case, which is + conjugate under `indOf` to additivity of the tensor of `C`; +* `RS.isZero_tensor_left_ind`/`_right_ind` — tensoring kills zero + objects; +* `RS.tensorLeft_ind_additive`/`RS.tensorRight_ind_additive` and + **`MonoidalPreadditive (Ind C)`** — whiskering in `Ind C` is + additive in each variable. + +Filtered colimits are the only colimits `Ind C` possesses for +general `C`; under `[HasFiniteColimits C]` it is cocomplete, and the +finite-coproduct half of general right-exactness follows from the +additivity above (see the acceptance tests at the bottom). +Preservation of coequalizers demands genuine right-exactness of the +tensor of `C` and is left to a follow-up lane. + +The `@[reducible]` marking on the small `coprodDiagram`/ +`coprodCocone`/`coprodPairFunctor` helpers is deliberate: their +object fields must reduce at instance transparency for the +`show`-retyped colimit proofs below to be stateable. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory MonoidalCategory.DayFunctor Limits +open Opposite + +universe v + +noncomputable section + +variable {C : Type v} + +section Embedding + +/-- The embedding of `Ind C` into the Day presheaf category: the +indization equivalence onto the full monoidal subcategory of +ind-objects, followed by the subcategory inclusion. -/ +def indToDay [SmallCategory C] [MonoidalCategory C] : Ind C ⥤ (Cᵒᵖ ⊛⥤ Type v) := + (indDayEquivalence C).functor ⋙ ObjectProperty.ι _ + +/-- The forward functor of the indization equivalence is monoidal: +the monoidal structure of `Ind C` is transported across it. -/ +instance [SmallCategory C] [MonoidalCategory C] : + (indDayEquivalence C).functor.Monoidal := + inferInstanceAs + (Monoidal.equivalenceTransported + ((indDayEquivalence C).symm)).inverse.Monoidal + +/-- The embedding into the Day presheaf category is monoidal. -/ +instance + [SmallCategory C] [MonoidalCategory C] : (indToDay (C := C)).Monoidal := + inferInstanceAs + ((indDayEquivalence C).functor ⋙ ObjectProperty.ι _).Monoidal + +instance [SmallCategory C] [MonoidalCategory C] : (indToDay (C := C)).Full := + inferInstanceAs + ((indDayEquivalence C).functor ⋙ ObjectProperty.ι _).Full + +instance + [SmallCategory C] [MonoidalCategory C] : (indToDay (C := C)).Faithful := + inferInstanceAs + ((indDayEquivalence C).functor ⋙ ObjectProperty.ι _).Faithful + +/-- The embedding of `Ind C` into the Day presheaf category is the +inclusion into plain presheaves followed by the tautological +equivalence with the Day synonym. -/ +def indToDayCompIso [SmallCategory C] [MonoidalCategory C] : + indToDay (C := C) ≅ + Ind.inclusion C ⋙ (DayFunctor.equiv Cᵒᵖ (Type v)).inverse := + Iso.refl _ + +/-- The embedding into the Day presheaf category preserves small +filtered colimits: the inclusion into plain presheaves creates them +and the tautological Day equivalence preserves everything. -/ +instance indToDay_preservesFilteredColimits + [SmallCategory C] [MonoidalCategory C] + (I : Type v) + [SmallCategory I] [IsFiltered I] : + PreservesColimitsOfShape I (indToDay (C := C)) := + preservesColimitsOfShape_of_natIso (indToDayCompIso (C := C)).symm + +end Embedding + +section Filtered + +/-- **Deligne 2.2, filtered half, left version**: tensoring on the +left in `Ind C` preserves small filtered colimits. The embedding +into the Day presheaf category is monoidal, so it intertwines +`tensorLeft X` with the Day-convolution `tensorLeft` of the image, +which preserves all small colimits; the embedding preserves and +reflects filtered colimits, so `tensorLeft X` preserves them. -/ +instance tensorLeft_ind_preservesColimitsOfShape + [SmallCategory C] [MonoidalCategory C] + (X : Ind C) + (I : Type v) [SmallCategory I] [IsFiltered I] : + PreservesColimitsOfShape I (tensorLeft X) := + haveI : PreservesColimitsOfShape I (tensorLeft X ⋙ indToDay) := + preservesColimitsOfShape_of_natIso + (Functor.Monoidal.commTensorLeft indToDay X) + preservesColimitsOfShape_of_reflects_of_preserves _ indToDay + +/-- **Deligne 2.2, filtered half, right version**: tensoring on the +right in `Ind C` preserves small filtered colimits. -/ +instance tensorRight_ind_preservesColimitsOfShape + [SmallCategory C] [MonoidalCategory C] + (X : Ind C) + (I : Type v) [SmallCategory I] [IsFiltered I] : + PreservesColimitsOfShape I (tensorRight X) := + haveI : PreservesColimitsOfShape I (tensorRight X ⋙ indToDay) := + preservesColimitsOfShape_of_natIso + (Functor.Monoidal.commTensorRight indToDay X) + preservesColimitsOfShape_of_reflects_of_preserves _ indToDay + +/-- Filtered-colimit preservation by left tensoring, packaged. -/ +instance tensorLeft_ind_preservesFilteredColimits + [SmallCategory C] [MonoidalCategory C] + (X : Ind C) : + PreservesFilteredColimits (tensorLeft X) where + preserves_filtered_colimits _ _ _ := inferInstance + +/-- Filtered-colimit preservation by right tensoring, packaged. -/ +instance tensorRight_ind_preservesFilteredColimits + [SmallCategory C] [MonoidalCategory C] + (X : Ind C) : + PreservesFilteredColimits (tensorRight X) where + preserves_filtered_colimits _ _ _ := inferInstance + +end Filtered + +section EmbeddingTensor + +/-- The embedding into the Day presheaf category, restricted along +`indOf`, is the Day synonym of the Yoneda embedding. -/ +def indOfDayIso [SmallCategory C] [MonoidalCategory C] : + indOf ⋙ indToDay (C := C) ≅ + yoneda ⋙ (DayFunctor.equiv Cᵒᵖ (Type v)).inverse := + Functor.isoWhiskerLeft indOf (indToDayCompIso (C := C)) ≪≫ + (Functor.associator _ _ _).symm ≪≫ + Functor.isoWhiskerRight Ind.yonedaCompInclusion + (DayFunctor.equiv Cᵒᵖ (Type v)).inverse + +/-- The embedding sends `indOf.obj z` to the Day representable at +`z`. -/ +def indToDayIndOfIso [SmallCategory C] [MonoidalCategory C] + (z : C) : + (indToDay (C := C)).obj (indOf.obj z) ≅ + DayFunctor.mk (yoneda.obj z) := + (indOfDayIso (C := C)).app z + +/-- The embedding calculus for the tensor of two embedded objects: +under `indToDay`, the tensor `indOf.obj x ⊗ indOf.obj y` is the Day +tensor of the representables at `x` and `y`, which is the +representable at `x ⊗ y` — that is, the image of +`indOf.obj (x ⊗ y)`. -/ +def indToDayTensorIso [SmallCategory C] [MonoidalCategory C] + (x y : C) : + (indToDay (C := C)).obj (indOf.obj x ⊗ indOf.obj y) ≅ + (indToDay (C := C)).obj (indOf.obj (x ⊗ y)) := + (Functor.Monoidal.μIso indToDay (indOf.obj x) (indOf.obj y)).symm ≪≫ + tensorIso (indToDayIndOfIso x) (indToDayIndOfIso y) ≪≫ + dayYonedaIso x y ≪≫ (indToDayIndOfIso (x ⊗ y)).symm + +/-- The fully faithful structure of the embedding into the Day +presheaf category. -/ +def indToDayFullyFaithful [SmallCategory C] [MonoidalCategory C] : + (indToDay (C := C)).FullyFaithful := + Functor.FullyFaithful.ofFullyFaithful _ + +/-- The tensor of two embedded objects of `Ind C` is the embedding +of the tensor: `indOf` is monoidal up to isomorphism. -/ +def indOfTensorIso [SmallCategory C] [MonoidalCategory C] + (x y : C) : + indOf.obj x ⊗ indOf.obj y ≅ indOf.obj (x ⊗ y) := + indToDayFullyFaithful.preimageIso (indToDayTensorIso x y) + +/-- **The embedding `C ⥤ Ind C` is monoidal up to isomorphism**, in +the orientation used downstream. -/ +def indOfTensorIsoSymm [SmallCategory C] [MonoidalCategory C] + (x y : C) : + indOf.obj (x ⊗ y) ≅ indOf.obj x ⊗ indOf.obj y := + (indOfTensorIso x y).symm + +end EmbeddingTensor + +section CorepresentableCalculus + +/-- Characterisation of the canonical isomorphism between two +corepresenting objects: its classification under the first +corepresentability structure is the universal element of the +second. -/ +lemma corepresentableBy_homEquiv_uniqueUpToIso_hom {A : Type*} + [Category A] {F : A ⥤ Type*} {X X' : A} + (e : F.CorepresentableBy X) (e' : F.CorepresentableBy X') : + e.homEquiv (e.uniqueUpToIso e').hom = e'.homEquiv (𝟙 X') := by + simp [Functor.CorepresentableBy.uniqueUpToIso, Coyoneda.ext, + Functor.FullyFaithful.preimageIso, Coyoneda.fullyFaithful_preimage] + +end CorepresentableCalculus + +section DayNaturality + +attribute [local instance] dayConv + +open scoped MonoidalCategory.ExternalProduct +open scoped CategoryTheory.Prod + +/-- The universal transformation classified by the Day tensor of two +corepresentables: on a pair of morphisms it takes the tensor, +`(f, g) ↦ f ⊗ₘ g`. -/ +def coyonedaTensorHom {D : Type v} [SmallCategory D] [MonoidalCategory D] + (a b : D) : + coyoneda.obj (op ((a, b) : D × D)) ⟶ + tensor D ⋙ coyoneda.obj (op (a ⊗ b)) where + app X := TypeCat.ofHom fun (fg : (a, b) ⟶ X) => fg.1 ⊗ₘ fg.2 + naturality _ _ _ := + ConcreteCategory.hom_ext _ _ fun _ => + (tensorHom_comp_tensorHom _ _ _ _).symm + +/-- `RS.dayCoyonedaIso` classifies as the universal transformation +`(f, g) ↦ f ⊗ₘ g`: composing the Day unit with its underlying +natural transformation is `RS.coyonedaTensorHom`. -/ +lemma eta_comp_dayCoyonedaIso_hom + {D : Type v} [SmallCategory D] [MonoidalCategory D] + (a b : D) : + η (DayFunctor.mk (coyoneda.obj (op a))) + (DayFunctor.mk (coyoneda.obj (op b))) ≫ + Functor.whiskerLeft (tensor D) (dayCoyonedaIso a b).hom.natTrans = + coyonedaTensorHom a b := by + have h := corepresentableBy_homEquiv_uniqueUpToIso_hom + (dayCoyonedaCorepresentableBy a b) + (coyonedaDayCorepresentableBy (a ⊗ b)) + rw [show (dayCoyonedaCorepresentableBy a b).uniqueUpToIso + (coyonedaDayCorepresentableBy (a ⊗ b)) = dayCoyonedaIso a b + from rfl] at h + dsimp [dayCoyonedaCorepresentableBy, coyonedaDayCorepresentableBy, + Functor.homEquivOfIsLeftKanExtension] at h + apply (coyonedaEquiv (C := D × D) (X := ((a, b) : D × D)) + (F := tensor D ⋙ coyoneda.obj (op (a ⊗ b)))).injective + refine h.trans ?_ + change 𝟙 (a ⊗ b) = 𝟙 a ⊗ₘ 𝟙 b + simp + +/-- Naturality of `RS.dayCoyonedaIso` in the right variable. -/ +lemma dayCoyonedaIso_hom_natural_right + {D : Type v} [SmallCategory D] [MonoidalCategory D] + (a : D) {b b' : D} + (h : b ⟶ b') : + (DayFunctor.mk (coyoneda.obj (op a)) ◁ + (⟨coyoneda.map h.op⟩ : + DayFunctor.mk (coyoneda.obj (op b')) ⟶ + DayFunctor.mk (coyoneda.obj (op b)))) ≫ + (dayCoyonedaIso a b).hom = + (dayCoyonedaIso a b').hom ≫ ⟨coyoneda.map ((a ◁ h).op)⟩ := by + have h₁ : η (DayFunctor.mk (coyoneda.obj (op a))) + (DayFunctor.mk (coyoneda.obj (op b'))) ≫ + Functor.whiskerLeft (tensor D) + (DayFunctor.mk (coyoneda.obj (op a)) ◁ + (⟨coyoneda.map h.op⟩ : + DayFunctor.mk (coyoneda.obj (op b')) ⟶ + DayFunctor.mk (coyoneda.obj (op b)))).natTrans = + (externalProductBifunctor D D (Type v)).map + (𝟙 (coyoneda.obj (op a)) ×ₘ coyoneda.map h.op) ≫ + η (DayFunctor.mk (coyoneda.obj (op a))) + (DayFunctor.mk (coyoneda.obj (op b))) := by + rw [natTrans_whiskerLeft] + exact Functor.descOfIsLeftKanExtension_fac _ _ _ _ + ext1 + apply Functor.hom_ext_of_isLeftKanExtension _ + (η (DayFunctor.mk (coyoneda.obj (op a))) + (DayFunctor.mk (coyoneda.obj (op b')))) _ _ + rw [comp_natTrans, comp_natTrans, Functor.whiskerLeft_comp, + Functor.whiskerLeft_comp, ← Category.assoc, h₁, Category.assoc, + eta_comp_dayCoyonedaIso_hom, ← Category.assoc, + eta_comp_dayCoyonedaIso_hom] + ext X : 2 + refine ConcreteCategory.hom_ext _ _ fun fg => ?_ + change fg.1 ⊗ₘ (h ≫ fg.2) = (a ◁ h) ≫ (fg.1 ⊗ₘ fg.2) + rw [← id_tensorHom, tensorHom_comp_tensorHom, Category.id_comp] + +/-- Naturality of `RS.dayCoyonedaIso` in the left variable. -/ +lemma dayCoyonedaIso_hom_natural_left + {D : Type v} [SmallCategory D] [MonoidalCategory D] + {a a' : D} (f : a ⟶ a') + (b : D) : + ((⟨coyoneda.map f.op⟩ : + DayFunctor.mk (coyoneda.obj (op a')) ⟶ + DayFunctor.mk (coyoneda.obj (op a))) ▷ + DayFunctor.mk (coyoneda.obj (op b))) ≫ + (dayCoyonedaIso a b).hom = + (dayCoyonedaIso a' b).hom ≫ ⟨coyoneda.map ((f ▷ b).op)⟩ := by + have h₁ : η (DayFunctor.mk (coyoneda.obj (op a'))) + (DayFunctor.mk (coyoneda.obj (op b))) ≫ + Functor.whiskerLeft (tensor D) + ((⟨coyoneda.map f.op⟩ : + DayFunctor.mk (coyoneda.obj (op a')) ⟶ + DayFunctor.mk (coyoneda.obj (op a))) ▷ + DayFunctor.mk (coyoneda.obj (op b))).natTrans = + (externalProductBifunctor D D (Type v)).map + (coyoneda.map f.op ×ₘ 𝟙 (coyoneda.obj (op b))) ≫ + η (DayFunctor.mk (coyoneda.obj (op a))) + (DayFunctor.mk (coyoneda.obj (op b))) := by + rw [natTrans_whiskerRight] + exact Functor.descOfIsLeftKanExtension_fac _ _ _ _ + ext1 + apply Functor.hom_ext_of_isLeftKanExtension _ + (η (DayFunctor.mk (coyoneda.obj (op a'))) + (DayFunctor.mk (coyoneda.obj (op b)))) _ _ + rw [comp_natTrans, comp_natTrans, Functor.whiskerLeft_comp, + Functor.whiskerLeft_comp, ← Category.assoc, h₁, Category.assoc, + eta_comp_dayCoyonedaIso_hom, ← Category.assoc, + eta_comp_dayCoyonedaIso_hom] + ext X : 2 + refine ConcreteCategory.hom_ext _ _ fun fg => ?_ + change (f ≫ fg.1) ⊗ₘ fg.2 = (f ▷ b) ≫ (fg.1 ⊗ₘ fg.2) + rw [← tensorHom_id, tensorHom_comp_tensorHom, Category.id_comp] + +end DayNaturality + +section YonedaNaturality + +/-- Naturality of `Coyoneda.objOpOp`, inverse form. -/ +lemma yoneda_map_comp_objOpOp_inv [SmallCategory C] + {y y' : C} (g : y ⟶ y') : + yoneda.map g ≫ (Coyoneda.objOpOp y').inv = + (Coyoneda.objOpOp y).inv ≫ coyoneda.map (g.op.op) := by + ext z u + simp [Coyoneda.objOpOp, opEquiv] + +/-- Naturality of `Coyoneda.objOpOp`, forward form, at a left +whiskering of `Cᵒᵖ`. -/ +lemma coyoneda_map_whiskerLeft_comp_objOpOp_hom + [SmallCategory C] [MonoidalCategory C] + (x : C) {y y' : C} + (g : y ⟶ y') : + coyoneda.map ((op x ◁ g.op).op) ≫ + (Coyoneda.objOpOp (x ⊗ y')).hom = + (Coyoneda.objOpOp (x ⊗ y)).hom ≫ yoneda.map (x ◁ g) := by + ext z u + simp [Coyoneda.objOpOp, opEquiv] + +/-- Naturality of `Coyoneda.objOpOp`, forward form, at a right +whiskering of `Cᵒᵖ`. -/ +lemma coyoneda_map_whiskerRight_comp_objOpOp_hom + [SmallCategory C] [MonoidalCategory C] + {x x' : C} + (f : x ⟶ x') (y : C) : + coyoneda.map ((f.op ▷ op y).op) ≫ + (Coyoneda.objOpOp (x' ⊗ y)).hom = + (Coyoneda.objOpOp (x ⊗ y)).hom ≫ yoneda.map (f ▷ y) := by + ext z u + simp [Coyoneda.objOpOp, opEquiv] + +/-- Naturality of `RS.dayYonedaIso` in the right variable. -/ +lemma dayYonedaIso_hom_natural_right [SmallCategory C] [MonoidalCategory C] + (x : C) {y y' : C} + (g : y ⟶ y') : + (DayFunctor.mk (yoneda.obj x) ◁ + (⟨yoneda.map g⟩ : DayFunctor.mk (yoneda.obj y) ⟶ + DayFunctor.mk (yoneda.obj y'))) ≫ (dayYonedaIso x y').hom = + (dayYonedaIso x y).hom ≫ ⟨yoneda.map (x ◁ g)⟩ := by + have s₁ : (⟨yoneda.map g⟩ : DayFunctor.mk (yoneda.obj y) ⟶ + DayFunctor.mk (yoneda.obj y')) ≫ + (dayMkIso (Coyoneda.objOpOp y').symm).hom = + (dayMkIso (Coyoneda.objOpOp y).symm).hom ≫ + ⟨coyoneda.map (g.op.op)⟩ := by + ext1 + exact yoneda_map_comp_objOpOp_inv g + have s₂ : (⟨coyoneda.map ((op x ◁ g.op).op)⟩ : + DayFunctor.mk (coyoneda.obj (op (op x ⊗ op y))) ⟶ + DayFunctor.mk (coyoneda.obj (op (op x ⊗ op y')))) ≫ + (dayMkIso (Coyoneda.objOpOp (x ⊗ y'))).hom = + (dayMkIso (Coyoneda.objOpOp (x ⊗ y))).hom ≫ + ⟨yoneda.map (x ◁ g)⟩ := by + ext1 + exact coyoneda_map_whiskerLeft_comp_objOpOp_hom x g + have e₁ : (DayFunctor.mk (yoneda.obj x) ◁ + (⟨yoneda.map g⟩ : DayFunctor.mk (yoneda.obj y) ⟶ + DayFunctor.mk (yoneda.obj y'))) ≫ + ((dayMkIso (Coyoneda.objOpOp x).symm).hom ⊗ₘ + (dayMkIso (Coyoneda.objOpOp y').symm).hom) = + ((dayMkIso (Coyoneda.objOpOp x).symm).hom ⊗ₘ + (dayMkIso (Coyoneda.objOpOp y).symm).hom) ≫ + (DayFunctor.mk (coyoneda.obj (op (op x))) ◁ + (⟨coyoneda.map (g.op.op)⟩ : + DayFunctor.mk (coyoneda.obj (op (op y))) ⟶ + DayFunctor.mk (coyoneda.obj (op (op y'))))) := by + rw [← id_tensorHom, tensorHom_comp_tensorHom, Category.id_comp, + s₁, ← id_tensorHom, tensorHom_comp_tensorHom, Category.comp_id] + simp only [dayYonedaIso, Iso.trans_hom, tensorIso_hom] + rw [← Category.assoc, e₁, Category.assoc, + reassoc_of% dayCoyonedaIso_hom_natural_right (D := Cᵒᵖ) + (op x) (g.op), s₂] + simp only [Category.assoc] + +/-- Naturality of `RS.dayYonedaIso` in the left variable. -/ +lemma dayYonedaIso_hom_natural_left [SmallCategory C] [MonoidalCategory C] + {x x' : C} (f : x ⟶ x') + (y : C) : + ((⟨yoneda.map f⟩ : DayFunctor.mk (yoneda.obj x) ⟶ + DayFunctor.mk (yoneda.obj x')) ▷ + DayFunctor.mk (yoneda.obj y)) ≫ (dayYonedaIso x' y).hom = + (dayYonedaIso x y).hom ≫ ⟨yoneda.map (f ▷ y)⟩ := by + have s₁ : (⟨yoneda.map f⟩ : DayFunctor.mk (yoneda.obj x) ⟶ + DayFunctor.mk (yoneda.obj x')) ≫ + (dayMkIso (Coyoneda.objOpOp x').symm).hom = + (dayMkIso (Coyoneda.objOpOp x).symm).hom ≫ + ⟨coyoneda.map (f.op.op)⟩ := by + ext1 + exact yoneda_map_comp_objOpOp_inv f + have s₂ : (⟨coyoneda.map ((f.op ▷ op y).op)⟩ : + DayFunctor.mk (coyoneda.obj (op (op x ⊗ op y))) ⟶ + DayFunctor.mk (coyoneda.obj (op (op x' ⊗ op y)))) ≫ + (dayMkIso (Coyoneda.objOpOp (x' ⊗ y))).hom = + (dayMkIso (Coyoneda.objOpOp (x ⊗ y))).hom ≫ + ⟨yoneda.map (f ▷ y)⟩ := by + ext1 + exact coyoneda_map_whiskerRight_comp_objOpOp_hom f y + have e₁ : ((⟨yoneda.map f⟩ : DayFunctor.mk (yoneda.obj x) ⟶ + DayFunctor.mk (yoneda.obj x')) ▷ + DayFunctor.mk (yoneda.obj y)) ≫ + ((dayMkIso (Coyoneda.objOpOp x').symm).hom ⊗ₘ + (dayMkIso (Coyoneda.objOpOp y).symm).hom) = + ((dayMkIso (Coyoneda.objOpOp x).symm).hom ⊗ₘ + (dayMkIso (Coyoneda.objOpOp y).symm).hom) ≫ + ((⟨coyoneda.map (f.op.op)⟩ : + DayFunctor.mk (coyoneda.obj (op (op x))) ⟶ + DayFunctor.mk (coyoneda.obj (op (op x')))) ▷ + DayFunctor.mk (coyoneda.obj (op (op y)))) := by + rw [← tensorHom_id, tensorHom_comp_tensorHom, Category.id_comp, + s₁, ← tensorHom_id, tensorHom_comp_tensorHom, Category.comp_id] + simp only [dayYonedaIso, Iso.trans_hom, tensorIso_hom] + rw [← Category.assoc, e₁, Category.assoc, + reassoc_of% dayCoyonedaIso_hom_natural_left (D := Cᵒᵖ) + (f.op) (op y), s₂] + simp only [Category.assoc] + +end YonedaNaturality + +section EmbeddingTensorNatural + +/-- Naturality of `RS.indToDayIndOfIso` in its object. -/ +lemma indToDay_map_comp_indToDayIndOfIso_hom + [SmallCategory C] [MonoidalCategory C] + {z z' : C} (u : z ⟶ z') : + (indToDay (C := C)).map (indOf.map u) ≫ + (indToDayIndOfIso z').hom = + (indToDayIndOfIso z).hom ≫ ⟨yoneda.map u⟩ := + (indOfDayIso (C := C)).hom.naturality u + +/-- Inverse form of `RS.indToDay_map_comp_indToDayIndOfIso_hom`. -/ +lemma comp_indToDayIndOfIso_inv [SmallCategory C] [MonoidalCategory C] + {z z' : C} (u : z ⟶ z') : + (⟨yoneda.map u⟩ : DayFunctor.mk (yoneda.obj z) ⟶ + DayFunctor.mk (yoneda.obj z')) ≫ (indToDayIndOfIso z').inv = + (indToDayIndOfIso z).inv ≫ (indToDay (C := C)).map (indOf.map u) := by + rw [Iso.comp_inv_eq, Category.assoc, + indToDay_map_comp_indToDayIndOfIso_hom, Iso.inv_hom_id_assoc] + +/-- Naturality of `RS.indOfTensorIso` in the right variable: the +embedding-tensor comparison intertwines whiskering by an embedded +object with the embedded whiskering. -/ +lemma indOfTensorIso_hom_natural_right [SmallCategory C] [MonoidalCategory C] + (x : C) {y y' : C} + (g : y ⟶ y') : + (indOf.obj x ◁ indOf.map g) ≫ (indOfTensorIso x y').hom = + (indOfTensorIso x y).hom ≫ indOf.map (x ◁ g) := by + apply (indToDay (C := C)).map_injective + have hmap : ∀ (a b : C), + (indToDay (C := C)).map (indOfTensorIso a b).hom = + (indToDayTensorIso a b).hom := fun a b => by + rw [indOfTensorIso, Functor.FullyFaithful.preimageIso_hom, + Functor.FullyFaithful.map_preimage] + have e₁ : ((indToDay (C := C)).obj (indOf.obj x) ◁ + (indToDay (C := C)).map (indOf.map g)) ≫ + ((indToDayIndOfIso x).hom ⊗ₘ (indToDayIndOfIso y').hom) = + ((indToDayIndOfIso x).hom ⊗ₘ (indToDayIndOfIso y).hom) ≫ + (DayFunctor.mk (yoneda.obj x) ◁ + (⟨yoneda.map g⟩ : DayFunctor.mk (yoneda.obj y) ⟶ + DayFunctor.mk (yoneda.obj y'))) := by + rw [← id_tensorHom, tensorHom_comp_tensorHom, Category.id_comp, + indToDay_map_comp_indToDayIndOfIso_hom, ← id_tensorHom, + tensorHom_comp_tensorHom, Category.comp_id] + rw [Functor.map_comp, Functor.map_comp, hmap, hmap, + Functor.Monoidal.map_whiskerLeft] + simp only [indToDayTensorIso, Iso.trans_hom, Iso.symm_hom, + tensorIso_hom, Functor.Monoidal.μIso_inv, Category.assoc, + Functor.Monoidal.μ_δ_assoc] + rw [← Category.assoc ((indToDay (C := C)).obj (indOf.obj x) ◁ _), + e₁, Category.assoc, + reassoc_of% dayYonedaIso_hom_natural_right x g, + comp_indToDayIndOfIso_inv] + +/-- Naturality of `RS.indOfTensorIso` in the left variable. -/ +lemma indOfTensorIso_hom_natural_left [SmallCategory C] [MonoidalCategory C] + {x x' : C} (f : x ⟶ x') + (y : C) : + (indOf.map f ▷ indOf.obj y) ≫ (indOfTensorIso x' y).hom = + (indOfTensorIso x y).hom ≫ indOf.map (f ▷ y) := by + apply (indToDay (C := C)).map_injective + have hmap : ∀ (a b : C), + (indToDay (C := C)).map (indOfTensorIso a b).hom = + (indToDayTensorIso a b).hom := fun a b => by + rw [indOfTensorIso, Functor.FullyFaithful.preimageIso_hom, + Functor.FullyFaithful.map_preimage] + have e₁ : ((indToDay (C := C)).map (indOf.map f) ▷ + (indToDay (C := C)).obj (indOf.obj y)) ≫ + ((indToDayIndOfIso x').hom ⊗ₘ (indToDayIndOfIso y).hom) = + ((indToDayIndOfIso x).hom ⊗ₘ (indToDayIndOfIso y).hom) ≫ + ((⟨yoneda.map f⟩ : DayFunctor.mk (yoneda.obj x) ⟶ + DayFunctor.mk (yoneda.obj x')) ▷ + DayFunctor.mk (yoneda.obj y)) := by + rw [← tensorHom_id, tensorHom_comp_tensorHom, Category.id_comp, + indToDay_map_comp_indToDayIndOfIso_hom, ← tensorHom_id, + tensorHom_comp_tensorHom, Category.comp_id] + rw [Functor.map_comp, Functor.map_comp, hmap, hmap, + Functor.Monoidal.map_whiskerRight] + simp only [indToDayTensorIso, Iso.trans_hom, Iso.symm_hom, + tensorIso_hom, Functor.Monoidal.μIso_inv, Category.assoc, + Functor.Monoidal.μ_δ_assoc] + rw [← Category.assoc ((indToDay (C := C)).map (indOf.map f) ▷ _), + e₁, Category.assoc, + reassoc_of% dayYonedaIso_hom_natural_left f y, + comp_indToDayIndOfIso_inv] + +/-- **The unit of `Ind C` is the embedded unit**: the transported +Day unit, identified through `RS.dayUnitIso` with the representable +at `𝟙_ C` and pulled back through the fully faithful monoidal +embedding `RS.indToDay`. -/ +def indOfUnitIso + [SmallCategory C] [MonoidalCategory C] : (𝟙_ (Ind C)) ≅ indOf.obj (𝟙_ C) := + indToDayFullyFaithful.preimageIso + ((Functor.Monoidal.εIso (indToDay (C := C))).symm ≪≫ + dayUnitIso Cᵒᵖ ≪≫ dayMkIso (Coyoneda.objOpOp (𝟙_ C)) ≪≫ + (indToDayIndOfIso (𝟙_ C)).symm) + +end EmbeddingTensorNatural + +section CoconeTools + +universe v₁ v₂ v₃ u₂ u₃ + +/-- A cocone leg, with its type stated at the cocone point. -/ +def coconeLeg {J : Type v₁} [Category.{v₁} J] {ℬ : Type u₃} [Category.{v₃} ℬ] + {D : J ⥤ ℬ} (c : Cocone D) (j : J) : D.obj j ⟶ c.pt := + c.ι.app j + +lemma coconeLeg_w + {J : Type v₁} [Category.{v₁} J] {ℬ : Type u₃} [Category.{v₃} ℬ] + {D : J ⥤ ℬ} (c : Cocone D) {j k : J} (u : j ⟶ k) : + D.map u ≫ coconeLeg c k = coconeLeg c j := + c.w u + +/-- The pointwise binary coproduct of two diagrams of the same +shape. -/ +@[reducible, simps] +def coprodDiagram + {J : Type v₁} [Category.{v₁} J] {ℬ : Type u₃} [Category.{v₃} ℬ] + [HasBinaryCoproducts ℬ] + (D₁ D₂ : J ⥤ ℬ) : J ⥤ ℬ where + obj j := D₁.obj j ⨿ D₂.obj j + map u := coprod.map (D₁.map u) (D₂.map u) + +/-- A leg of a cocone over a pointwise coproduct, with its type +stated at the coproduct. -/ +def coprodLeg {J : Type v₁} [Category.{v₁} J] {ℬ : Type u₃} [Category.{v₃} ℬ] + [HasBinaryCoproducts ℬ] + {D₁ D₂ : J ⥤ ℬ} (s : Cocone (coprodDiagram D₁ D₂)) + (j : J) : D₁.obj j ⨿ D₂.obj j ⟶ s.pt := + s.ι.app j + +lemma coprodLeg_w + {J : Type v₁} [Category.{v₁} J] {ℬ : Type u₃} [Category.{v₃} ℬ] + [HasBinaryCoproducts ℬ] + {D₁ D₂ : J ⥤ ℬ} (s : Cocone (coprodDiagram D₁ D₂)) + {j k : J} (u : j ⟶ k) : + coprod.map (D₁.map u) (D₂.map u) ≫ coprodLeg s k = coprodLeg s j := + s.w u + +/-- The coproduct of two cocones: a cocone over the pointwise +coproduct diagram, with the coproduct of the two points as its +point. -/ +@[reducible, simps] +def coprodCocone {J : Type v₁} [Category.{v₁} J] {ℬ : Type u₃} [Category.{v₃} ℬ] + [HasBinaryCoproducts ℬ] + {D₁ D₂ : J ⥤ ℬ} (c₁ : Cocone D₁) (c₂ : Cocone D₂) : + Cocone (coprodDiagram D₁ D₂) where + pt := c₁.pt ⨿ c₂.pt + ι := + { app := fun j => coprod.map (coconeLeg c₁ j) (coconeLeg c₂ j) + naturality := fun j k u => by + change coprod.map (D₁.map u) (D₂.map u) ≫ + coprod.map (coconeLeg c₁ k) (coconeLeg c₂ k) = + coprod.map (coconeLeg c₁ j) (coconeLeg c₂ j) ≫ + 𝟙 (c₁.pt ⨿ c₂.pt) + rw [Category.comp_id, coprod.map_map, coconeLeg_w, coconeLeg_w] } + +/-- A cocone over the pointwise coproduct, restricted along the +first inclusion to a cocone over the first diagram. -/ +@[reducible, simps] +def coprodCoconeFst + {J : Type v₁} [Category.{v₁} J] {ℬ : Type u₃} [Category.{v₃} ℬ] + [HasBinaryCoproducts ℬ] + {D₁ D₂ : J ⥤ ℬ} + (s : Cocone (coprodDiagram D₁ D₂)) : Cocone D₁ where + pt := s.pt + ι := + { app := fun j => coprod.inl ≫ coprodLeg s j + naturality := fun j k u => by + change D₁.map u ≫ coprod.inl ≫ coprodLeg s k = + (coprod.inl ≫ coprodLeg s j) ≫ 𝟙 s.pt + rw [Category.comp_id, ← coprodLeg_w s u, coprod.inl_map_assoc] } + +/-- A cocone over the pointwise coproduct, restricted along the +second inclusion to a cocone over the second diagram. -/ +@[reducible, simps] +def coprodCoconeSnd + {J : Type v₁} [Category.{v₁} J] {ℬ : Type u₃} [Category.{v₃} ℬ] + [HasBinaryCoproducts ℬ] + {D₁ D₂ : J ⥤ ℬ} + (s : Cocone (coprodDiagram D₁ D₂)) : Cocone D₂ where + pt := s.pt + ι := + { app := fun j => coprod.inr ≫ coprodLeg s j + naturality := fun j k u => by + change D₂.map u ≫ coprod.inr ≫ coprodLeg s k = + (coprod.inr ≫ coprodLeg s j) ≫ 𝟙 s.pt + rw [Category.comp_id, ← coprodLeg_w s u, coprod.inr_map_assoc] } + +/-- The coproduct of two colimit cocones is a colimit cocone over +the pointwise coproduct diagram: colimits commute with binary +coproducts. -/ +def isColimitCoprodCocone + {J : Type v₁} [Category.{v₁} J] {ℬ : Type u₃} [Category.{v₃} ℬ] + [HasBinaryCoproducts ℬ] + {D₁ D₂ : J ⥤ ℬ} {c₁ : Cocone D₁} + {c₂ : Cocone D₂} (h₁ : IsColimit c₁) (h₂ : IsColimit c₂) : + IsColimit (coprodCocone c₁ c₂) where + desc s := coprod.desc (h₁.desc (coprodCoconeFst s)) + (h₂.desc (coprodCoconeSnd s)) + fac s j := by + have f₁ : coconeLeg c₁ j ≫ h₁.desc (coprodCoconeFst s) = + coprod.inl ≫ coprodLeg s j := h₁.fac (coprodCoconeFst s) j + have f₂ : coconeLeg c₂ j ≫ h₂.desc (coprodCoconeSnd s) = + coprod.inr ≫ coprodLeg s j := h₂.fac (coprodCoconeSnd s) j + change coprod.map (coconeLeg c₁ j) (coconeLeg c₂ j) ≫ + coprod.desc (h₁.desc (coprodCoconeFst s)) + (h₂.desc (coprodCoconeSnd s)) = coprodLeg s j + apply coprod.hom_ext + · rw [coprod.inl_map_assoc, coprod.inl_desc] + exact f₁ + · rw [coprod.inr_map_assoc, coprod.inr_desc] + exact f₂ + uniq s m hm := by + have hm' : ∀ j, coprod.map (coconeLeg c₁ j) (coconeLeg c₂ j) ≫ m = + coprodLeg s j := hm + change m = coprod.desc (h₁.desc (coprodCoconeFst s)) + (h₂.desc (coprodCoconeSnd s)) + apply coprod.hom_ext + · rw [coprod.inl_desc] + refine h₁.hom_ext fun j => ?_ + have hf : coconeLeg c₁ j ≫ h₁.desc (coprodCoconeFst s) = + coprod.inl ≫ coprodLeg s j := h₁.fac (coprodCoconeFst s) j + change coconeLeg c₁ j ≫ coprod.inl ≫ m = + coconeLeg c₁ j ≫ h₁.desc (coprodCoconeFst s) + rw [hf, ← hm' j, coprod.inl_map_assoc] + · rw [coprod.inr_desc] + refine h₂.hom_ext fun j => ?_ + have hf : coconeLeg c₂ j ≫ h₂.desc (coprodCoconeSnd s) = + coprod.inr ≫ coprodLeg s j := h₂.fac (coprodCoconeSnd s) j + change coconeLeg c₂ j ≫ coprod.inr ≫ m = + coconeLeg c₂ j ≫ h₂.desc (coprodCoconeSnd s) + rw [hf, ← hm' j, coprod.inr_map_assoc] + +/-- The pointwise binary coproduct of two functors. -/ +@[reducible, simps] +def coprodPairFunctor + {𝒜 : Type u₂} [Category.{v₂} 𝒜] {ℬ : Type u₃} [Category.{v₃} ℬ] + [HasBinaryCoproducts ℬ] + (F G : 𝒜 ⥤ ℬ) : 𝒜 ⥤ ℬ where + obj A := F.obj A ⨿ G.obj A + map u := coprod.map (F.map u) (G.map u) + +lemma preservesColimitsOfShape_coprodPairFunctor + {J : Type v₁} [Category.{v₁} J] {𝒜 : Type u₂} [Category.{v₂} 𝒜] + {ℬ : Type u₃} [Category.{v₃} ℬ] [HasBinaryCoproducts ℬ] + (F G : 𝒜 ⥤ ℬ) + [PreservesColimitsOfShape J F] [PreservesColimitsOfShape J G] : + PreservesColimitsOfShape J (coprodPairFunctor F G) where + preservesColimit {D} := + { preserves := fun {c} hc => by + refine ⟨IsColimit.ofIsoColimit + (isColimitCoprodCocone (isColimitOfPreserves F hc) + (isColimitOfPreserves G hc)) + (Cocone.ext (Iso.refl _) fun j => ?_)⟩ + change coprod.map (coconeLeg (F.mapCocone c) j) + (coconeLeg (G.mapCocone c) j) ≫ + 𝟙 ((F.mapCocone c).pt ⨿ (G.mapCocone c).pt) = + coprod.map (F.map (c.ι.app j)) (G.map (c.ι.app j)) + rw [Category.comp_id] + rfl } + +lemma preservesColimitsOfShape_const_of_isConnected + {J : Type v₁} [Category.{v₁} J] {𝒜 : Type u₂} [Category.{v₂} 𝒜] + {ℬ : Type u₃} [Category.{v₃} ℬ] + [IsConnected J] + (W : ℬ) : + PreservesColimitsOfShape J ((Functor.const 𝒜).obj W) where + preservesColimit {D} := + { preserves := fun {c} _ => by + refine ⟨IsColimit.ofIsoColimit (isColimitConstCocone J W) + (Cocone.ext (Iso.refl _) fun j => ?_)⟩ + change 𝟙 W ≫ 𝟙 W = 𝟙 W + rw [Category.comp_id] } + +end CoconeTools + +section FilteredDescent + +/-- **Filtered descent for pointwise-invertible transformations**: a +natural transformation between endofunctors of `Ind C` that both +preserve filtered colimits is invertible everywhere as soon as it is +invertible on the embedded objects, since every ind-object is a +filtered colimit of embedded objects. -/ +lemma isIso_app_of_isIso_indOf [SmallCategory C] + {L R : Ind C ⥤ Ind C} + [PreservesFilteredColimits L] [PreservesFilteredColimits R] + (γ : L ⟶ R) (hbase : ∀ c : C, IsIso (γ.app (indOf.obj c))) + (A : Ind C) : IsIso (γ.app A) := by + set D : A.presentation.I ⥤ Ind C := A.presentation.F ⋙ indOf with hD + suffices h : IsIso (γ.app (colimit D)) by + have e : colimit D ≅ A := Ind.colimitPresentationCompYoneda A + have : γ.app A = L.map e.inv ≫ γ.app (colimit D) ≫ R.map e.hom := by + rw [← γ.naturality e.hom, ← Functor.map_comp_assoc, + e.inv_hom_id, CategoryTheory.Functor.map_id, Category.id_comp] + rw [this] + infer_instance + have hw : ∀ k, IsIso ((Functor.whiskerLeft D γ).app k) := fun k => + hbase (A.presentation.F.obj k) + have : IsIso (Functor.whiskerLeft D γ) := + NatIso.isIso_of_isIso_app _ + have hL : IsColimit (L.mapCocone (colimit.cocone D)) := + isColimitOfPreserves L (colimit.isColimit D) + have hR : IsColimit (R.mapCocone (colimit.cocone D)) := + isColimitOfPreserves R (colimit.isColimit D) + have : γ.app (colimit D) = (IsColimit.coconePointsIsoOfNatIso hL hR + (asIso (Functor.whiskerLeft D γ))).hom := by + refine hL.hom_ext fun k => ?_ + refine Eq.trans ?_ (IsColimit.comp_coconePointsIsoOfNatIso_hom hL hR + (asIso (Functor.whiskerLeft D γ)) k).symm + exact γ.naturality (colimit.ι D k) + rw [this] + infer_instance + +end FilteredDescent + +section CoproductPreservation + +open ZeroObject + +/-- Abstract form of the embedded base case, left version: a +morphism satisfying the two defining equations of the binary +coproduct comparison for `tensorLeft (indOf.obj a)` at a pair of +embedded objects is invertible, provided the corresponding +comparison in `C` is. -/ +lemma isIso_of_coprod_eq_whiskerLeft_indOf + [SmallCategory C] [MonoidalCategory C] [HasFiniteColimits C] + (a x y : C) + (w : a ⊗ x ⨿ a ⊗ y ⟶ a ⊗ (x ⨿ y)) [IsIso w] + (hw₁ : coprod.inl ≫ w = a ◁ coprod.inl) + (hw₂ : coprod.inr ≫ w = a ◁ coprod.inr) + (v : (indOf.obj a ⊗ indOf.obj x) ⨿ (indOf.obj a ⊗ indOf.obj y) ⟶ + indOf.obj a ⊗ (indOf.obj x ⨿ indOf.obj y)) + (hv₁ : coprod.inl ≫ v = indOf.obj a ◁ coprod.inl) + (hv₂ : coprod.inr ≫ v = indOf.obj a ◁ coprod.inr) : + IsIso v := by + have nat₁ := indOfTensorIso_hom_natural_right a + (coprod.inl : x ⟶ x ⨿ y) + have nat₂ := indOfTensorIso_hom_natural_right a + (coprod.inr : y ⟶ x ⨿ y) + have key : v = + coprod.map (indOfTensorIso a x).hom (indOfTensorIso a y).hom ≫ + coprodComparison indOf (a ⊗ x) (a ⊗ y) ≫ + indOf.map w ≫ + (indOfTensorIso a (x ⨿ y)).inv ≫ + (indOf.obj a ◁ inv (coprodComparison indOf x y)) := by + apply coprod.hom_ext + · rw [hv₁, coprod.inl_map_assoc, coprodComparison_inl_assoc, + ← Functor.map_comp_assoc, hw₁, ← reassoc_of% nat₁, + Iso.hom_inv_id_assoc, ← MonoidalCategory.whiskerLeft_comp, + map_inl_inv_coprodComparison] + · rw [hv₂, coprod.inr_map_assoc, coprodComparison_inr_assoc, + ← Functor.map_comp_assoc, hw₂, ← reassoc_of% nat₂, + Iso.hom_inv_id_assoc, ← MonoidalCategory.whiskerLeft_comp, + map_inr_inv_coprodComparison] + rw [key] + infer_instance + +/-- Abstract form of the embedded base case, right version. -/ +lemma isIso_of_coprod_eq_whiskerRight_indOf + [SmallCategory C] [MonoidalCategory C] [HasFiniteColimits C] + (a x y : C) + (w : x ⊗ a ⨿ y ⊗ a ⟶ (x ⨿ y) ⊗ a) [IsIso w] + (hw₁ : coprod.inl ≫ w = coprod.inl ▷ a) + (hw₂ : coprod.inr ≫ w = coprod.inr ▷ a) + (v : (indOf.obj x ⊗ indOf.obj a) ⨿ (indOf.obj y ⊗ indOf.obj a) ⟶ + (indOf.obj x ⨿ indOf.obj y) ⊗ indOf.obj a) + (hv₁ : coprod.inl ≫ v = coprod.inl ▷ indOf.obj a) + (hv₂ : coprod.inr ≫ v = coprod.inr ▷ indOf.obj a) : + IsIso v := by + have nat₁ := indOfTensorIso_hom_natural_left + (coprod.inl : x ⟶ x ⨿ y) a + have nat₂ := indOfTensorIso_hom_natural_left + (coprod.inr : y ⟶ x ⨿ y) a + have key : v = + coprod.map (indOfTensorIso x a).hom (indOfTensorIso y a).hom ≫ + coprodComparison indOf (x ⊗ a) (y ⊗ a) ≫ + indOf.map w ≫ + (indOfTensorIso (x ⨿ y) a).inv ≫ + (inv (coprodComparison indOf x y) ▷ indOf.obj a) := by + apply coprod.hom_ext + · rw [hv₁, coprod.inl_map_assoc, coprodComparison_inl_assoc, + ← Functor.map_comp_assoc, hw₁, ← reassoc_of% nat₁, + Iso.hom_inv_id_assoc, ← MonoidalCategory.comp_whiskerRight, + map_inl_inv_coprodComparison] + · rw [hv₂, coprod.inr_map_assoc, coprodComparison_inr_assoc, + ← Functor.map_comp_assoc, hw₂, ← reassoc_of% nat₂, + Iso.hom_inv_id_assoc, ← MonoidalCategory.comp_whiskerRight, + map_inr_inv_coprodComparison] + rw [key] + infer_instance + +-- The biproduct-preservation instances for +-- `tensorLeft a` are assembled by instance search through the +-- finite-biproduct hierarchy of `C`, and the two comparison maps +-- are then unified across the transported tensor of `Ind C`. +/-- The embedded base case, left version: the binary coproduct +comparison for tensoring on the left by an embedded object is +invertible at a pair of embedded objects. -/ +lemma isIso_coprodComparison_tensorLeft_indOf₀ + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [MonoidalPreadditive C] + (a x y : C) : + IsIso (coprodComparison (tensorLeft (indOf.obj a)) + (indOf.obj x) (indOf.obj y)) := by + have : HasFiniteBiproducts C := + HasFiniteBiproducts.of_hasFiniteCoproducts + have : HasBinaryBiproducts C := + hasBinaryBiproducts_of_finite_biproducts C + have : PreservesBiproductsOfShape WalkingPair (tensorLeft a) := + PreservesFiniteBiproducts.preserves + have := preservesBinaryBiproducts_of_preservesBiproducts + (tensorLeft a) + have := preservesBinaryCoproducts_of_preservesBinaryBiproducts + (tensorLeft a) + exact isIso_of_coprod_eq_whiskerLeft_indOf a x y + (PreservesColimitPair.iso (tensorLeft a) x y).hom + (coprodComparison_inl (tensorLeft a)) + (coprodComparison_inr (tensorLeft a)) + (coprodComparison (tensorLeft (indOf.obj a)) (indOf.obj x) + (indOf.obj y)) + (coprodComparison_inl (tensorLeft (indOf.obj a))) + (coprodComparison_inr (tensorLeft (indOf.obj a))) + +-- The mirror of the left version, with the same +-- biproduct-preservation search for `tensorRight a`. +/-- The embedded base case, right version. -/ +lemma isIso_coprodComparison_tensorRight_indOf₀ + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [MonoidalPreadditive C] + (a x y : C) : + IsIso (coprodComparison (tensorRight (indOf.obj a)) + (indOf.obj x) (indOf.obj y)) := by + have : HasFiniteBiproducts C := + HasFiniteBiproducts.of_hasFiniteCoproducts + have : HasBinaryBiproducts C := + hasBinaryBiproducts_of_finite_biproducts C + have : PreservesBiproductsOfShape WalkingPair (tensorRight a) := + PreservesFiniteBiproducts.preserves + have := preservesBinaryBiproducts_of_preservesBiproducts + (tensorRight a) + have := preservesBinaryCoproducts_of_preservesBinaryBiproducts + (tensorRight a) + exact isIso_of_coprod_eq_whiskerRight_indOf a x y + (PreservesColimitPair.iso (tensorRight a) x y).hom + (coprodComparison_inl (tensorRight a)) + (coprodComparison_inr (tensorRight a)) + (coprodComparison (tensorRight (indOf.obj a)) (indOf.obj x) + (indOf.obj y)) + (coprodComparison_inl (tensorRight (indOf.obj a))) + (coprodComparison_inr (tensorRight (indOf.obj a))) + +/-- Stage two, left version: the comparison for tensoring on the +left by an embedded object, at one embedded and one arbitrary +argument. Filtered descent in the second coproduct argument. -/ +lemma isIso_coprodComparison_tensorLeft_indOf₁ + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [MonoidalPreadditive C] + (a x : C) + (Y : Ind C) : + IsIso (coprodComparison (tensorLeft (indOf.obj a)) + (indOf.obj x) Y) := by + have hL : PreservesFilteredColimits + (coprodPairFunctor ((Functor.const (Ind C)).obj + (indOf.obj a ⊗ indOf.obj x)) (tensorLeft (indOf.obj a))) := + ⟨fun I _ _ => + haveI := IsFiltered.isConnected (C := I) + haveI := preservesColimitsOfShape_const_of_isConnected + (𝒜 := Ind C) (J := I) (indOf.obj a ⊗ indOf.obj x) + preservesColimitsOfShape_coprodPairFunctor _ _⟩ + have hR : PreservesFilteredColimits + (coprodPairFunctor ((Functor.const (Ind C)).obj (indOf.obj x)) + (𝟭 (Ind C)) ⋙ tensorLeft (indOf.obj a)) := + ⟨fun I _ _ => by + have := IsFiltered.isConnected (C := I) + have := preservesColimitsOfShape_const_of_isConnected + (𝒜 := Ind C) (J := I) (indOf.obj x) + have := preservesColimitsOfShape_coprodPairFunctor + ((Functor.const (Ind C)).obj (indOf.obj x)) (𝟭 (Ind C)) + (J := I) + infer_instance⟩ + let γ : coprodPairFunctor ((Functor.const (Ind C)).obj + (indOf.obj a ⊗ indOf.obj x)) (tensorLeft (indOf.obj a)) ⟶ + coprodPairFunctor ((Functor.const (Ind C)).obj (indOf.obj x)) + (𝟭 (Ind C)) ⋙ tensorLeft (indOf.obj a) := + { app := fun B => coprod.desc + (indOf.obj a ◁ (coprod.inl : indOf.obj x ⟶ indOf.obj x ⨿ B)) + (indOf.obj a ◁ (coprod.inr : B ⟶ indOf.obj x ⨿ B)) + naturality := fun B B' u => by + change coprod.map (𝟙 (indOf.obj a ⊗ indOf.obj x)) + (indOf.obj a ◁ u) ≫ + coprod.desc (indOf.obj a ◁ coprod.inl) + (indOf.obj a ◁ coprod.inr) = + coprod.desc (indOf.obj a ◁ coprod.inl) + (indOf.obj a ◁ coprod.inr) ≫ + (indOf.obj a ◁ coprod.map (𝟙 (indOf.obj x)) u) + simp only [coprod.map_desc, coprod.desc_comp, Category.id_comp, + ← MonoidalCategory.whiskerLeft_comp, coprod.inl_map, + coprod.inr_map] } + have h := isIso_app_of_isIso_indOf γ + (fun c => isIso_coprodComparison_tensorLeft_indOf₀ a x c) Y + exact h + +/-- Stage two, right version. -/ +lemma isIso_coprodComparison_tensorRight_indOf₁ + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [MonoidalPreadditive C] + (a x : C) + (Y : Ind C) : + IsIso (coprodComparison (tensorRight (indOf.obj a)) + (indOf.obj x) Y) := by + have hL : PreservesFilteredColimits + (coprodPairFunctor ((Functor.const (Ind C)).obj + (indOf.obj x ⊗ indOf.obj a)) (tensorRight (indOf.obj a))) := + ⟨fun I _ _ => + haveI := IsFiltered.isConnected (C := I) + haveI := preservesColimitsOfShape_const_of_isConnected + (𝒜 := Ind C) (J := I) (indOf.obj x ⊗ indOf.obj a) + preservesColimitsOfShape_coprodPairFunctor _ _⟩ + have hR : PreservesFilteredColimits + (coprodPairFunctor ((Functor.const (Ind C)).obj (indOf.obj x)) + (𝟭 (Ind C)) ⋙ tensorRight (indOf.obj a)) := + ⟨fun I _ _ => by + have := IsFiltered.isConnected (C := I) + have := preservesColimitsOfShape_const_of_isConnected + (𝒜 := Ind C) (J := I) (indOf.obj x) + have := preservesColimitsOfShape_coprodPairFunctor + ((Functor.const (Ind C)).obj (indOf.obj x)) (𝟭 (Ind C)) + (J := I) + infer_instance⟩ + let γ : coprodPairFunctor ((Functor.const (Ind C)).obj + (indOf.obj x ⊗ indOf.obj a)) (tensorRight (indOf.obj a)) ⟶ + coprodPairFunctor ((Functor.const (Ind C)).obj (indOf.obj x)) + (𝟭 (Ind C)) ⋙ tensorRight (indOf.obj a) := + { app := fun B => coprod.desc + ((coprod.inl : indOf.obj x ⟶ indOf.obj x ⨿ B) ▷ indOf.obj a) + ((coprod.inr : B ⟶ indOf.obj x ⨿ B) ▷ indOf.obj a) + naturality := fun B B' u => by + change coprod.map (𝟙 (indOf.obj x ⊗ indOf.obj a)) + (u ▷ indOf.obj a) ≫ + coprod.desc (coprod.inl ▷ indOf.obj a) + (coprod.inr ▷ indOf.obj a) = + coprod.desc (coprod.inl ▷ indOf.obj a) + (coprod.inr ▷ indOf.obj a) ≫ + (coprod.map (𝟙 (indOf.obj x)) u ▷ indOf.obj a) + simp only [coprod.map_desc, coprod.desc_comp, Category.id_comp, + ← MonoidalCategory.comp_whiskerRight, coprod.inl_map, + coprod.inr_map] } + have h := isIso_app_of_isIso_indOf γ + (fun c => isIso_coprodComparison_tensorRight_indOf₀ a x c) Y + exact h + +/-- Stage three, left version: descent in the first coproduct +argument. -/ +lemma isIso_coprodComparison_tensorLeft_indOf₂ + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [MonoidalPreadditive C] + (a : C) + (X Y : Ind C) : + IsIso (coprodComparison (tensorLeft (indOf.obj a)) X Y) := by + have hL : PreservesFilteredColimits + (coprodPairFunctor (tensorLeft (indOf.obj a)) + ((Functor.const (Ind C)).obj (indOf.obj a ⊗ Y))) := + ⟨fun I _ _ => + haveI := IsFiltered.isConnected (C := I) + haveI := preservesColimitsOfShape_const_of_isConnected + (𝒜 := Ind C) (J := I) (indOf.obj a ⊗ Y) + preservesColimitsOfShape_coprodPairFunctor _ _⟩ + have hR : PreservesFilteredColimits + (coprodPairFunctor (𝟭 (Ind C)) + ((Functor.const (Ind C)).obj Y) ⋙ + tensorLeft (indOf.obj a)) := + ⟨fun I _ _ => by + have := IsFiltered.isConnected (C := I) + have := preservesColimitsOfShape_const_of_isConnected + (𝒜 := Ind C) (J := I) Y + have := preservesColimitsOfShape_coprodPairFunctor + (𝟭 (Ind C)) ((Functor.const (Ind C)).obj Y) (J := I) + infer_instance⟩ + let γ : coprodPairFunctor (tensorLeft (indOf.obj a)) + ((Functor.const (Ind C)).obj (indOf.obj a ⊗ Y)) ⟶ + coprodPairFunctor (𝟭 (Ind C)) + ((Functor.const (Ind C)).obj Y) ⋙ + tensorLeft (indOf.obj a) := + { app := fun B => coprod.desc + (indOf.obj a ◁ (coprod.inl : B ⟶ B ⨿ Y)) + (indOf.obj a ◁ (coprod.inr : Y ⟶ B ⨿ Y)) + naturality := fun B B' u => by + change coprod.map (indOf.obj a ◁ u) + (𝟙 (indOf.obj a ⊗ Y)) ≫ + coprod.desc (indOf.obj a ◁ coprod.inl) + (indOf.obj a ◁ coprod.inr) = + coprod.desc (indOf.obj a ◁ coprod.inl) + (indOf.obj a ◁ coprod.inr) ≫ + (indOf.obj a ◁ coprod.map u (𝟙 Y)) + simp only [coprod.map_desc, coprod.desc_comp, Category.id_comp, + ← MonoidalCategory.whiskerLeft_comp, coprod.inl_map, + coprod.inr_map] } + have h := isIso_app_of_isIso_indOf γ + (fun c => isIso_coprodComparison_tensorLeft_indOf₁ a c Y) X + exact h + +/-- Stage three, right version. -/ +lemma isIso_coprodComparison_tensorRight_indOf₂ + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [MonoidalPreadditive C] + (a : C) + (X Y : Ind C) : + IsIso (coprodComparison (tensorRight (indOf.obj a)) X Y) := by + have hL : PreservesFilteredColimits + (coprodPairFunctor (tensorRight (indOf.obj a)) + ((Functor.const (Ind C)).obj (Y ⊗ indOf.obj a))) := + ⟨fun I _ _ => + haveI := IsFiltered.isConnected (C := I) + haveI := preservesColimitsOfShape_const_of_isConnected + (𝒜 := Ind C) (J := I) (Y ⊗ indOf.obj a) + preservesColimitsOfShape_coprodPairFunctor _ _⟩ + have hR : PreservesFilteredColimits + (coprodPairFunctor (𝟭 (Ind C)) + ((Functor.const (Ind C)).obj Y) ⋙ + tensorRight (indOf.obj a)) := + ⟨fun I _ _ => by + have := IsFiltered.isConnected (C := I) + have := preservesColimitsOfShape_const_of_isConnected + (𝒜 := Ind C) (J := I) Y + have := preservesColimitsOfShape_coprodPairFunctor + (𝟭 (Ind C)) ((Functor.const (Ind C)).obj Y) (J := I) + infer_instance⟩ + let γ : coprodPairFunctor (tensorRight (indOf.obj a)) + ((Functor.const (Ind C)).obj (Y ⊗ indOf.obj a)) ⟶ + coprodPairFunctor (𝟭 (Ind C)) + ((Functor.const (Ind C)).obj Y) ⋙ + tensorRight (indOf.obj a) := + { app := fun B => coprod.desc + ((coprod.inl : B ⟶ B ⨿ Y) ▷ indOf.obj a) + ((coprod.inr : Y ⟶ B ⨿ Y) ▷ indOf.obj a) + naturality := fun B B' u => by + change coprod.map (u ▷ indOf.obj a) + (𝟙 (Y ⊗ indOf.obj a)) ≫ + coprod.desc (coprod.inl ▷ indOf.obj a) + (coprod.inr ▷ indOf.obj a) = + coprod.desc (coprod.inl ▷ indOf.obj a) + (coprod.inr ▷ indOf.obj a) ≫ + (coprod.map u (𝟙 Y) ▷ indOf.obj a) + simp only [coprod.map_desc, coprod.desc_comp, Category.id_comp, + ← MonoidalCategory.comp_whiskerRight, coprod.inl_map, + coprod.inr_map] } + have h := isIso_app_of_isIso_indOf γ + (fun c => isIso_coprodComparison_tensorRight_indOf₁ a c Y) X + exact h + +/-- **The binary coproduct comparison for left tensoring in `Ind C` +is invertible**: final descent in the tensoring object. -/ +lemma isIso_coprodComparison_tensorLeft + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [MonoidalPreadditive C] + (A X Y : Ind C) : + IsIso (coprodComparison (tensorLeft A) X Y) := by + have hL : PreservesFilteredColimits + (coprodPairFunctor (tensorRight X) (tensorRight Y)) := + ⟨fun I _ _ => preservesColimitsOfShape_coprodPairFunctor _ _⟩ + let γ : coprodPairFunctor (tensorRight X) (tensorRight Y) ⟶ + tensorRight (X ⨿ Y) := + { app := fun B => coprod.desc + (B ◁ (coprod.inl : X ⟶ X ⨿ Y)) + (B ◁ (coprod.inr : Y ⟶ X ⨿ Y)) + naturality := fun B B' u => by + change coprod.map (u ▷ X) (u ▷ Y) ≫ + coprod.desc (B' ◁ coprod.inl) (B' ◁ coprod.inr) = + coprod.desc (B ◁ coprod.inl) (B ◁ coprod.inr) ≫ + (u ▷ (X ⨿ Y)) + simp only [coprod.map_desc, coprod.desc_comp, + whisker_exchange] } + have h := isIso_app_of_isIso_indOf γ + (fun c => isIso_coprodComparison_tensorLeft_indOf₂ c X Y) A + exact h + +/-- **The binary coproduct comparison for right tensoring in +`Ind C` is invertible**. -/ +lemma isIso_coprodComparison_tensorRight + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [MonoidalPreadditive C] + (A X Y : Ind C) : + IsIso (coprodComparison (tensorRight A) X Y) := by + have hL : PreservesFilteredColimits + (coprodPairFunctor (tensorLeft X) (tensorLeft Y)) := + ⟨fun I _ _ => preservesColimitsOfShape_coprodPairFunctor _ _⟩ + let γ : coprodPairFunctor (tensorLeft X) (tensorLeft Y) ⟶ + tensorLeft (X ⨿ Y) := + { app := fun B => coprod.desc + ((coprod.inl : X ⟶ X ⨿ Y) ▷ B) + ((coprod.inr : Y ⟶ X ⨿ Y) ▷ B) + naturality := fun B B' u => by + change coprod.map (X ◁ u) (Y ◁ u) ≫ + coprod.desc (coprod.inl ▷ B') (coprod.inr ▷ B') = + coprod.desc (coprod.inl ▷ B) (coprod.inr ▷ B) ≫ + ((X ⨿ Y) ◁ u) + simp only [coprod.map_desc, coprod.desc_comp, + whisker_exchange] } + have h := isIso_app_of_isIso_indOf γ + (fun c => isIso_coprodComparison_tensorRight_indOf₂ c X Y) A + exact h + +/-- An object that is both initial and terminal is a zero object. -/ +lemma isZero_of_isInitial_isTerminal {𝒜 : Type*} [Category 𝒜] + {X : 𝒜} (hI : IsInitial X) (hT : IsTerminal X) : IsZero X := + ⟨fun Y => ⟨⟨⟨hI.to Y⟩, fun f => hI.hom_ext f _⟩⟩, + fun Y => ⟨⟨⟨hT.from Y⟩, fun f => hT.hom_ext f _⟩⟩⟩ + +/-- The embedding `C ⥤ Ind C` carries zero objects to zero objects: +it preserves the initial and the terminal object. -/ +lemma isZero_indOf [SmallCategory C] + {W : C} (hW : IsZero W) : + IsZero (indOf.obj W) := + isZero_of_isInitial_isTerminal + (IsInitial.isInitialObj indOf W hW.isInitial) + (IsTerminal.isTerminalObj indOf W hW.isTerminal) + +/-- A colimit all of whose stages vanish vanishes. -/ +lemma isZero_colimit_of_isZero + [SmallCategory C] [Preadditive C] [HasFiniteColimits C] + {I : Type v} [SmallCategory I] + (K : I ⥤ Ind C) [HasColimit K] (h : ∀ i, IsZero (K.obj i)) : + IsZero (colimit K) := by + rw [IsZero.iff_id_eq_zero] + apply colimit.hom_ext + intro j + rw [Category.comp_id, comp_zero] + exact (h j).eq_of_src _ _ + +-- Three isomorphisms of ind-objects are chained +-- through the presentation colimit, each elaborated against the +-- transported tensor of `Ind C` and the colimit-preservation +-- instance for `tensorRight`. +/-- Tensoring a vanishing ind-object on the left kills it: descend +along a presentation of the other factor and use that tensoring in +`C` is additive. -/ +lemma isZero_tensor_left_ind + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [MonoidalPreadditive C] + (A : Ind C) {Z : Ind C} + (hZ : IsZero Z) : IsZero (A ⊗ Z) := by + have : HasFiniteBiproducts C := + HasFiniteBiproducts.of_hasFiniteCoproducts + have h0 : IsZero (indOf.obj (0 : C)) := isZero_indOf (isZero_zero C) + set D : A.presentation.I ⥤ Ind C := A.presentation.F ⋙ indOf + with hD + have hpt : ∀ k, IsZero ((D ⋙ tensorRight (indOf.obj 0)).obj k) := + fun k => by + have hz : IsZero (A.presentation.F.obj k ⊗ (0 : C)) := + (tensorLeft (A.presentation.F.obj k)).map_isZero + (isZero_zero C) + exact IsZero.of_iso (isZero_indOf hz) + (indOfTensorIso (A.presentation.F.obj k) 0) + have e₁ : A ⊗ Z ≅ A ⊗ indOf.obj 0 := + (tensorLeft A).mapIso (hZ.iso h0) + have e₂ : A ⊗ indOf.obj (0 : C) ≅ colimit D ⊗ indOf.obj (0 : C) := + (tensorRight (indOf.obj (0 : C))).mapIso + (Ind.colimitPresentationCompYoneda A).symm + have e₃ : colimit D ⊗ indOf.obj (0 : C) ≅ + colimit (D ⋙ tensorRight (indOf.obj 0)) := + preservesColimitIso (tensorRight (indOf.obj (0 : C))) D + exact IsZero.of_iso (isZero_colimit_of_isZero + (D ⋙ tensorRight (indOf.obj 0)) hpt) (e₁ ≪≫ e₂ ≪≫ e₃) + +-- The mirror of the left version, with the same +-- chain of three isomorphisms through the presentation colimit. +/-- Tensoring a vanishing ind-object on the right kills it. -/ +lemma isZero_tensor_right_ind + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [MonoidalPreadditive C] + (A : Ind C) {Z : Ind C} + (hZ : IsZero Z) : IsZero (Z ⊗ A) := by + have : HasFiniteBiproducts C := + HasFiniteBiproducts.of_hasFiniteCoproducts + have h0 : IsZero (indOf.obj (0 : C)) := isZero_indOf (isZero_zero C) + set D : A.presentation.I ⥤ Ind C := A.presentation.F ⋙ indOf + with hD + have hpt : ∀ k, IsZero ((D ⋙ tensorLeft (indOf.obj 0)).obj k) := + fun k => by + have hz : IsZero ((0 : C) ⊗ A.presentation.F.obj k) := + (tensorRight (A.presentation.F.obj k)).map_isZero + (isZero_zero C) + exact IsZero.of_iso (isZero_indOf hz) + (indOfTensorIso 0 (A.presentation.F.obj k)) + have e₁ : Z ⊗ A ≅ indOf.obj 0 ⊗ A := + (tensorRight A).mapIso (hZ.iso h0) + have e₂ : indOf.obj (0 : C) ⊗ A ≅ indOf.obj (0 : C) ⊗ colimit D := + (tensorLeft (indOf.obj (0 : C))).mapIso + (Ind.colimitPresentationCompYoneda A).symm + have e₃ : indOf.obj (0 : C) ⊗ colimit D ≅ + colimit (D ⋙ tensorLeft (indOf.obj 0)) := + preservesColimitIso (tensorLeft (indOf.obj (0 : C))) D + exact IsZero.of_iso (isZero_colimit_of_isZero + (D ⋙ tensorLeft (indOf.obj 0)) hpt) (e₁ ≪≫ e₂ ≪≫ e₃) + +/-- Left tensoring on `Ind C` preserves zero morphisms. -/ +lemma preservesZeroMorphisms_tensorLeft_ind + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [MonoidalPreadditive C] + (A : Ind C) : + (tensorLeft A).PreservesZeroMorphisms := + Functor.preservesZeroMorphisms_of_map_zero_object + ((isZero_tensor_left_ind A (isZero_zero (Ind C))).isoZero) + +/-- Right tensoring on `Ind C` preserves zero morphisms. -/ +lemma preservesZeroMorphisms_tensorRight_ind + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [MonoidalPreadditive C] + (A : Ind C) : + (tensorRight A).PreservesZeroMorphisms := + Functor.preservesZeroMorphisms_of_map_zero_object + ((isZero_tensor_right_ind A (isZero_zero (Ind C))).isoZero) + +/-- Left tensoring on `Ind C` preserves binary coproducts. -/ +lemma preservesBinaryCoproducts_tensorLeft_ind + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [MonoidalPreadditive C] + (A : Ind C) : + PreservesColimitsOfShape (Discrete WalkingPair) + (tensorLeft A) where + preservesColimit {K} := by + have := isIso_coprodComparison_tensorLeft A + (K.obj ⟨WalkingPair.left⟩) (K.obj ⟨WalkingPair.right⟩) + have := PreservesColimitPair.of_iso_coprod_comparison + (tensorLeft A) (K.obj ⟨WalkingPair.left⟩) + (K.obj ⟨WalkingPair.right⟩) + exact preservesColimit_of_iso_diagram _ (diagramIsoPair K).symm + +/-- Right tensoring on `Ind C` preserves binary coproducts. -/ +lemma preservesBinaryCoproducts_tensorRight_ind + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [MonoidalPreadditive C] + (A : Ind C) : + PreservesColimitsOfShape (Discrete WalkingPair) + (tensorRight A) where + preservesColimit {K} := by + have := isIso_coprodComparison_tensorRight A + (K.obj ⟨WalkingPair.left⟩) (K.obj ⟨WalkingPair.right⟩) + have := PreservesColimitPair.of_iso_coprod_comparison + (tensorRight A) (K.obj ⟨WalkingPair.left⟩) + (K.obj ⟨WalkingPair.right⟩) + exact preservesColimit_of_iso_diagram _ (diagramIsoPair K).symm + +/-- Left tensoring on `Ind C` is additive. -/ +instance tensorLeft_ind_additive + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [MonoidalPreadditive C] + (A : Ind C) : + (tensorLeft A).Additive := by + have : HasBinaryBiproducts (Ind C) := + hasBinaryBiproducts_of_finite_biproducts (Ind C) + have := preservesZeroMorphisms_tensorLeft_ind A + have := preservesBinaryCoproducts_tensorLeft_ind A + have := preservesBinaryBiproducts_of_preservesBinaryCoproducts + (tensorLeft A) + exact Functor.additive_of_preservesBinaryBiproducts _ + +/-- Right tensoring on `Ind C` is additive. -/ +instance tensorRight_ind_additive + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [MonoidalPreadditive C] + (A : Ind C) : + (tensorRight A).Additive := by + have : HasBinaryBiproducts (Ind C) := + hasBinaryBiproducts_of_finite_biproducts (Ind C) + have := preservesZeroMorphisms_tensorRight_ind A + have := preservesBinaryCoproducts_tensorRight_ind A + have := preservesBinaryBiproducts_of_preservesBinaryCoproducts + (tensorRight A) + exact Functor.additive_of_preservesBinaryBiproducts _ + +/-- **Deligne 2.2, preadditive half**: the transported monoidal +structure on `Ind C` is preadditive — whiskering is additive in each +variable. -/ +instance [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [MonoidalPreadditive C] : + MonoidalPreadditive (Ind C) where + whiskerLeft_zero {X Y Z} := (tensorLeft X).map_zero Y Z + zero_whiskerRight {X Y Z} := (tensorRight X).map_zero Y Z + whiskerLeft_add {X _ _} _ _ := (tensorLeft X).map_add + add_whiskerRight {X _ _} _ _ := (tensorRight X).map_add + +end CoproductPreservation + +section AcceptanceTests + +/- Instance synthesis is what is being tested; the data is chosen by +colimit machinery, hence `noncomputable`. -/ + +noncomputable example + [SmallCategory C] [MonoidalCategory C] + (X : Ind C) : + PreservesFilteredColimits (tensorLeft X) := + inferInstance + +noncomputable example + [SmallCategory C] [MonoidalCategory C] + (X : Ind C) : + PreservesFilteredColimits (tensorRight X) := + inferInstance + +noncomputable example + [SmallCategory C] [MonoidalCategory C] + [Preadditive C] [HasFiniteColimits C] + [MonoidalPreadditive C] : MonoidalPreadditive (Ind C) := + inferInstance + +noncomputable example + [SmallCategory C] [MonoidalCategory C] + [Preadditive C] [HasFiniteColimits C] + [MonoidalPreadditive C] (X : Ind C) : + PreservesFiniteCoproducts (tensorLeft X) := + inferInstance + +noncomputable example + [SmallCategory C] [MonoidalCategory C] + [Preadditive C] [HasFiniteColimits C] + [MonoidalPreadditive C] (X : Ind C) : + PreservesFiniteCoproducts (tensorRight X) := + inferInstance + +end AcceptanceTests + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndUnitNonzero.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndUnitNonzero.lean new file mode 100644 index 0000000000..ccb6800373 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndUnitNonzero.lean @@ -0,0 +1,45 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchur +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitSimple + +/-! +# The unit of the Ind-completion is nonzero + +A scalar unit downstairs makes the identity of the tensor unit +nonzero, and the embedding is faithful, so the tensor unit of the +Ind-completion is not a zero object. This is the side condition of +both Proposition 2.9 and Rappel 2.10 over the Ind-completion. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v + +variable {C : Type v} + +/-- **The tensor unit of the Ind-completion is not a zero +object.** -/ +theorem not_isZero_unit_ind [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ C] + (hu : HasScalarUnit C) : + ¬ IsZero (𝟙_ (Ind C)) := by + intro h + have h0 : IsZero ((indOf : C ⥤ Ind C).obj (𝟙_ C)) := + h.of_iso (indOfUnitIso (C := C)).symm + have h1 : (indOf : C ⥤ Ind C).map (𝟙 (𝟙_ C)) = 0 := by + rw [CategoryTheory.Functor.map_id] + exact h0.eq_zero_of_src _ + exact id_unit_ne_zero hu ((indOf_map_eq_zero_iff _).mp h1) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitDatum.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitDatum.lean new file mode 100644 index 0000000000..a3ab0f9628 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitDatum.lean @@ -0,0 +1,193 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitBase +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagCarrier + +/-! +# The duality datum over the trivial base + +An exact pairing of the ambient category induces a duality datum +between the corresponding modules over the tensor unit: the +relative tensor collapses to the plain tensor, and the pairing +and copairing pass through the collapse. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- The pairing over the trivial base: collapse and evaluate. -/ +noncomputable def unitBasePair + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (X : D) (Y : D) [ExactPairing X Y] : + modTensor (𝟙_ D) (unitMod Y) (unitMod X) ⟶ 𝟙_ D := + (modTensorUnitBase (unitMod Y) (unitMod X)).hom ≫ ε_ X Y + +/-- The copairing over the trivial base: coevaluate and embed. -/ +noncomputable def unitBaseCopair + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (X : D) (Y : D) [ExactPairing X Y] : + 𝟙_ D ⟶ modTensor (𝟙_ D) (unitMod X) (unitMod Y) := + η_ X Y ≫ (modTensorUnitBase (unitMod X) (unitMod Y)).inv + +/-- The pairing is linear over the trivial base. -/ +theorem unitBasePair_linear + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (X : D) (Y : D) [ExactPairing X Y] : + (letI := modTensorModObj (𝟙_ D) (unitMod Y) (unitMod X); + actLeft (𝟙_ D) + (modTensor (𝟙_ D) (unitMod Y) (unitMod X))) ≫ + unitBasePair X Y = + ((𝟙_ D) ◁ unitBasePair X Y) ≫ μ[𝟙_ D] := by + rw [actLeft_unitBase _ + (inst := modTensorModObj (𝟙_ D) (unitMod Y) (unitMod X))] + rw [show μ[𝟙_ D] = (λ_ (𝟙_ D)).hom from rfl] + exact (leftUnitor_naturality (unitBasePair X Y)).symm + +/-- The copairing is linear over the trivial base. -/ +theorem unitBaseCopair_linear + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (X : D) (Y : D) [ExactPairing X Y] : + μ[𝟙_ D] ≫ unitBaseCopair X Y = + ((𝟙_ D) ◁ unitBaseCopair X Y) ≫ + (letI := modTensorModObj (𝟙_ D) (unitMod X) (unitMod Y); + actLeft (𝟙_ D) + (modTensor (𝟙_ D) (unitMod X) (unitMod Y))) := by + rw [actLeft_unitBase _ + (inst := modTensorModObj (𝟙_ D) (unitMod X) (unitMod Y))] + rw [show μ[𝟙_ D] = (λ_ (𝟙_ D)).hom from rfl] + exact (leftUnitor_naturality (unitBaseCopair X Y)).symm + +/-- **The duality datum over the trivial base** attached to an +exact pairing of the ambient category. -/ +noncomputable def unitBaseDatum + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (X : D) (Y : D) [ExactPairing X Y] : + ModDualityDatum (𝟙_ D) (unitMod X) (unitMod Y) where + pair := unitBasePair X Y + copair := unitBaseCopair X Y + pair_linear := unitBasePair_linear X Y + copair_linear := unitBaseCopair_linear X Y + +/-- **The trivial-base datum satisfies the zigzag laws**: through +the collapse they are the zigzag identities of the exact +pairing. -/ +theorem unitBaseDatum_zigzag + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (X : D) (Y : D) [ExactPairing X Y] : + ModZigzagDatum (𝟙_ D) (unitBaseDatum X Y) := by + have h2 : modTensorπ (𝟙_ D) (unitMod Y) (unitMod X) ≫ + (unitBaseDatum X Y).pair = ε_ X Y := by + have hπ : modTensorπ (𝟙_ D) (unitMod Y) (unitMod X) ≫ + (modTensorUnitBase (unitMod Y) (unitMod X)).hom = + 𝟙 ((unitMod Y).X ⊗ (unitMod X).X) := + (modTensorUnitBase (unitMod Y) (unitMod X)).inv_hom_id + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker hπ _) ?_ + exact Category.id_comp _ + apply modZigzagDatum_of_carrier + · have h1 : ((modTensorUnitBase (unitMod X) + (unitMod Y)).inv ▷ X) ≫ + zigContract (𝟙_ D) (unitBaseDatum X Y).pair + (unitBaseDatum X Y).pair_linear = + (α_ X Y X).hom ≫ + (X ◁ (modTensorπ (𝟙_ D) (unitMod Y) (unitMod X) ≫ + (unitBaseDatum X Y).pair)) ≫ + actRight (𝟙_ D) X := + whiskerRight_modTensorπ_zigContract (𝟙_ D) _ _ + have h4 : (α_ X Y X).hom ≫ + (X ◁ (modTensorπ (𝟙_ D) (unitMod Y) (unitMod X) ≫ + (unitBaseDatum X Y).pair)) ≫ + actRight (𝟙_ D) X = + (α_ X Y X).hom ≫ (X ◁ ε_ X Y) ≫ (ρ_ X).hom := by + refine whisker_eq _ ?_ + refine Eq.trans (eq_whisker (congrArg + (fun t => X ◁ t) h2) _) ?_ + exact whisker_eq _ (actRight_unitBase X) + change (λ_ X).inv ≫ + ((η[𝟙_ D] ≫ (unitBaseDatum X Y).copair) ▷ X) ≫ + zigContract (𝟙_ D) (unitBaseDatum X Y).pair + (unitBaseDatum X Y).pair_linear = 𝟙 X + rw [show η[𝟙_ D] ≫ (unitBaseDatum X Y).copair = + η_ X Y ≫ (modTensorUnitBase (unitMod X) + (unitMod Y)).inv from Category.id_comp _] + erw [MonoidalCategory.comp_whiskerRight, Category.assoc] + refine Eq.trans (whisker_eq _ (whisker_eq _ + (h1.trans h4))) ?_ + have hzz : η_ X Y ▷ X ≫ (α_ X Y X).hom ≫ + (X ◁ ε_ X Y) ≫ (ρ_ X).hom = + (λ_ X).hom ≫ (ρ_ X).inv ≫ (ρ_ X).hom := + (reassoc_of% + (ExactPairing.evaluation_coevaluation X Y)) + ((ρ_ X).hom) + refine Eq.trans (whisker_eq _ hzz) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (ρ_ X).inv_hom_id)) ?_ + refine Eq.trans (whisker_eq _ (Category.comp_id _)) ?_ + exact (λ_ X).inv_hom_id + · have h1 : (Y ◁ (modTensorUnitBase (unitMod X) + (unitMod Y)).inv) ≫ + zagContract (𝟙_ D) (unitBaseDatum X Y).pair + (unitBaseDatum X Y).pair_linear = + (α_ Y X Y).inv ≫ + ((modTensorπ (𝟙_ D) (unitMod Y) (unitMod X) ≫ + (unitBaseDatum X Y).pair) ▷ Y) ≫ + actLeft (𝟙_ D) Y := + whiskerLeft_modTensorπ_zagContract (𝟙_ D) + (unitBaseDatum X Y).pair + (unitBaseDatum X Y).pair_linear + have h4 : (α_ Y X Y).inv ≫ + ((modTensorπ (𝟙_ D) (unitMod Y) (unitMod X) ≫ + (unitBaseDatum X Y).pair) ▷ Y) ≫ + actLeft (𝟙_ D) Y = + (α_ Y X Y).inv ≫ (ε_ X Y ▷ Y) ≫ (λ_ Y).hom := by + refine whisker_eq _ ?_ + refine Eq.trans (eq_whisker (congrArg + (fun t => t ▷ Y) h2) _) ?_ + exact whisker_eq _ (actLeft_unitBase Y) + change (ρ_ Y).inv ≫ + (Y ◁ (η[𝟙_ D] ≫ (unitBaseDatum X Y).copair)) ≫ + zagContract (𝟙_ D) (unitBaseDatum X Y).pair + (unitBaseDatum X Y).pair_linear = 𝟙 Y + rw [show η[𝟙_ D] ≫ (unitBaseDatum X Y).copair = + η_ X Y ≫ (modTensorUnitBase (unitMod X) + (unitMod Y)).inv from Category.id_comp _] + erw [MonoidalCategory.whiskerLeft_comp, Category.assoc] + refine Eq.trans (whisker_eq _ (whisker_eq _ + (h1.trans h4))) ?_ + have hzz : Y ◁ η_ X Y ≫ (α_ Y X Y).inv ≫ + (ε_ X Y ▷ Y) ≫ (λ_ Y).hom = + (ρ_ Y).hom ≫ (λ_ Y).inv ≫ (λ_ Y).hom := + (reassoc_of% + (ExactPairing.coevaluation_evaluation X Y)) + ((λ_ Y).hom) + refine Eq.trans (whisker_eq _ hzz) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (λ_ Y).inv_hom_id)) ?_ + refine Eq.trans (whisker_eq _ (Category.comp_id _)) ?_ + exact (ρ_ Y).inv_hom_id + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitState.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitState.lean new file mode 100644 index 0000000000..55ffa6f88d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitState.lean @@ -0,0 +1,67 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29State + +/-! +# The initial state of the dévissage + +Every object with an exact pairing seeds the dévissage: the base +is the tensor unit, no factors are split off, and the remainder +is the object itself with its ambient duality. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +attribute [local instance] + hasBinaryBiproducts_of_finite_biproducts + +/-- **The initial dévissage state**: the trivial base, no split +factors, and the object itself as the remainder. -/ +noncomputable def devissageInit + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (L : OddLine D) (X Y : D) + [ExactPairing X Y] (h1 : ¬ IsZero (𝟙_ D)) : + DevissageState D L X where + base := 𝟙_ D + monObj := inferInstance + comm := inferInstance + unit_ne_zero := by + rw [MonObj.one_def] + intro h0 + exact h1 (by + rw [IsZero.iff_id_eq_zero] + exact h0) + units := 0 + lines := 0 + rest := unitMod X + restDual := unitMod Y + datum := unitBaseDatum X Y + zigzag := unitBaseDatum_zigzag X Y + decomp := by + have hZ : IsZero (freeMod (𝟙_ D) (L.mix 0 0)).X := + isZero_whiskerLeft (𝟙_ D) L.isZero_mix_zero + exact ⟨(freeModUnitBase X).trans + (modBiprodZeroLeft (𝟙_ D) + (freeMod (𝟙_ D) (L.mix 0 0)) (unitMod X) hZ).symm⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/InterchangeAct.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InterchangeAct.lean new file mode 100644 index 0000000000..ed2d1b9f2a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InterchangeAct.lean @@ -0,0 +1,421 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainStage2 +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowChain + +/-! +# The interchange is linear over the base + +The action compatibility of the interchange: acting on the first +tensor factor and interchanging is reassociating, interchanging, +and acting on the nested module tensor product. Together with +the functoriality of the module tensor product this makes the +chain multiplication bilinear over the base, which is what the +structure morphism of the splitting-chain algebra multiplies +through. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The interchange is linear over the base**: the action on +the first factor interchanges to the action on the nested module +tensor product. -/ +theorem interchange_actLeft + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (N₁ : Mod D A) (N₂ : Mod D A) + (P₁ : Mod D A) (P₂ : Mod D A) : + (modTensorAct A N₁ N₂ ▷ modTensor A P₁ P₂) ≫ + interchange A N₁ N₂ P₁ P₂ = + (α_ A (modTensor A N₁ N₂) (modTensor A P₁ P₂)).hom ≫ + (A ◁ interchange A N₁ N₂ P₁ P₂) ≫ + modTensorAct A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) := by + refine (cancel_epi + ((A ◁ modTensorπ A N₁ N₂) ▷ modTensor A P₁ P₂)).mp ?_ + refine (cancel_epi + ((A ⊗ (N₁.X ⊗ N₂.X)) ◁ modTensorπ A P₁ P₂)).mp ?_ + -- The left side: unfold the source action and the interchange + -- to the raw crossing. + conv_lhs => rw [← comp_whiskerRight_assoc, + whiskerLeft_modTensorπ_act, comp_whiskerRight, + Category.assoc, whisker_exchange_assoc, + ← tensorHom_def'_assoc, tensorHom_π_interchange, + rawInterchangeπ, rawInterchange] + -- The right side: pass the projections through the associator, + -- unfold the interchange, and descend the nested action. + have hT : (A ◁ modTensorπ A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂)) ≫ + modTensorAct A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) = + ((α_ A (modTensor A N₁ P₁) (modTensor A N₂ P₂)).inv ≫ + modTensorAct A N₁ P₁ ▷ modTensor A N₂ P₂) ≫ + modTensorπ A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) := + whiskerLeft_modTensorπ_act A + (modTensorMod A N₁ P₁) (modTensorMod A N₂ P₂) + have hT' : (A ◁ ((modTensorπ A N₁ P₁ ⊗ₘ modTensorπ A N₂ P₂) ≫ + modTensorπ A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂))) ≫ + modTensorAct A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) = + (A ◁ (modTensorπ A N₁ P₁ ⊗ₘ modTensorπ A N₂ P₂)) ≫ + (α_ A (modTensor A N₁ P₁) (modTensor A N₂ P₂)).inv ≫ + (modTensorAct A N₁ P₁ ▷ modTensor A N₂ P₂) ≫ + modTensorπ A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) := by + erw [MonoidalCategory.whiskerLeft_comp, Category.assoc, hT] + repeat' erw [Category.assoc] + conv_rhs => rw [associator_naturality_middle_assoc, + associator_naturality_right_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + ← tensorHom_def', tensorHom_π_interchange, + rawInterchangeπ, rawInterchange, + MonoidalCategory.whiskerLeft_comp, Category.assoc, hT'] + -- Pass the pair projection through the inverse associator. + have hnat : (A ◁ (modTensorπ A N₁ P₁ ⊗ₘ modTensorπ A N₂ P₂)) ≫ + (α_ A (modTensor A N₁ P₁) (modTensor A N₂ P₂)).inv = + (α_ A (N₁.X ⊗ P₁.X) (N₂.X ⊗ P₂.X)).inv ≫ + ((A ◁ modTensorπ A N₁ P₁) ⊗ₘ modTensorπ A N₂ P₂) := by + simpa using associator_inv_naturality (𝟙 A) + (modTensorπ A N₁ P₁) (modTensorπ A N₂ P₂) + rw [reassoc_of% hnat] + -- Merge the nested action into the first pair slot and descend. + have hmerge : ((A ◁ modTensorπ A N₁ P₁) ⊗ₘ modTensorπ A N₂ P₂) ≫ + (modTensorAct A N₁ P₁ ▷ modTensor A N₂ P₂) = + ((α_ A N₁.X P₁.X).inv ⊗ₘ 𝟙 (N₂.X ⊗ P₂.X)) ≫ + ((actLeft A N₁.X ▷ P₁.X) ⊗ₘ 𝟙 (N₂.X ⊗ P₂.X)) ≫ + (modTensorπ A N₁ P₁ ⊗ₘ modTensorπ A N₂ P₂) := by + rw [← tensorHom_id, tensorHom_comp_tensorHom, + whiskerLeft_modTensorπ_act, Category.comp_id, + tensorHom_comp_tensorHom, tensorHom_comp_tensorHom] + simp + erw [reassoc_of% hmerge] + -- Extract the action from the crossing. + have htm : ((actLeft A N₁.X ▷ N₂.X) ▷ (P₁.X ⊗ P₂.X)) ≫ + tensorμ N₁.X N₂.X P₁.X P₂.X = + tensorμ (A ⊗ N₁.X) N₂.X P₁.X P₂.X ≫ + ((actLeft A N₁.X ▷ P₁.X) ⊗ₘ 𝟙 (N₂.X ⊗ P₂.X)) := by + simpa using tensorμ_natural (actLeft A N₁.X) (𝟙 N₂.X) + (𝟙 P₁.X) (𝟙 P₂.X) + conv_lhs => rw [comp_whiskerRight, Category.assoc, + reassoc_of% htm] + -- The remaining prefixes agree by coherence. + have hcoh : ((α_ A N₁.X N₂.X).inv ▷ (P₁.X ⊗ P₂.X)) ≫ + tensorμ (A ⊗ N₁.X) N₂.X P₁.X P₂.X = + (α_ A (N₁.X ⊗ N₂.X) (P₁.X ⊗ P₂.X)).hom ≫ + (A ◁ tensorμ N₁.X N₂.X P₁.X P₂.X) ≫ + (α_ A (N₁.X ⊗ P₁.X) (N₂.X ⊗ P₂.X)).inv ≫ + ((α_ A N₁.X P₁.X).inv ⊗ₘ 𝟙 (N₂.X ⊗ P₂.X)) := by + simp only [tensorμ] + monoidal + rw [reassoc_of% hcoh] + +/-- **Commutativity of the interchange**: the block braiding +interchanges to the nested braidings, by the braiding law of the +crossing. -/ +theorem interchange_comm + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (N₁ : Mod D A) (N₂ : Mod D A) + (P₁ : Mod D A) (P₂ : Mod D A) : + (β_ (modTensor A N₁ N₂) (modTensor A P₁ P₂)).hom ≫ + interchange A P₁ P₂ N₁ N₂ = + interchange A N₁ N₂ P₁ P₂ ≫ + modTensorMap A (modTensorSwapMod A N₁ P₁) + (modTensorSwapMod A N₂ P₂) := by + refine (cancel_epi + (modTensorπ A N₁ N₂ ⊗ₘ modTensorπ A P₁ P₂)).mp ?_ + conv_lhs => rw [BraidedCategory.braiding_naturality_assoc, + tensorHom_π_interchange, rawInterchangeπ, rawInterchange] + conv_rhs => erw [tensorHom_π_interchange_assoc, + rawInterchangeπ, rawInterchange, Category.assoc, + Category.assoc] + have hswap : modTensorπ A + (modTensorMod A N₁ P₁) (modTensorMod A N₂ P₂) ≫ + modTensorMap A (modTensorSwapMod A N₁ P₁) + (modTensorSwapMod A N₂ P₂) = + (modTensorSwap A N₁ P₁ ⊗ₘ modTensorSwap A N₂ P₂) ≫ + modTensorπ A (modTensorMod A P₁ N₁) + (modTensorMod A P₂ N₂) := + modTensorπ_map A (modTensorSwapMod A N₁ P₁) + (modTensorSwapMod A N₂ P₂) + have hπswap : (modTensorπ A N₁ P₁ ⊗ₘ modTensorπ A N₂ P₂) ≫ + (modTensorSwap A N₁ P₁ ⊗ₘ modTensorSwap A N₂ P₂) = + ((β_ N₁.X P₁.X).hom ⊗ₘ (β_ N₂.X P₂.X).hom) ≫ + (modTensorπ A P₁ N₁ ⊗ₘ modTensorπ A P₂ N₂) := by + rw [MonoidalCategory.tensorHom_comp_tensorHom, + modTensorπ_swap, modTensorπ_swap, + ← MonoidalCategory.tensorHom_comp_tensorHom] + have hR : (modTensorπ A N₁ P₁ ⊗ₘ modTensorπ A N₂ P₂) ≫ + modTensorπ A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) ≫ + modTensorMap A (modTensorSwapMod A N₁ P₁) + (modTensorSwapMod A N₂ P₂) = + ((β_ N₁.X P₁.X).hom ⊗ₘ (β_ N₂.X P₂.X).hom) ≫ + (modTensorπ A P₁ N₁ ⊗ₘ modTensorπ A P₂ N₂) ≫ + modTensorπ A (modTensorMod A P₁ N₁) + (modTensorMod A P₂ N₂) := by + refine (congrArg (fun t : (modTensorMod A N₁ P₁).X ⊗ + (modTensorMod A N₂ P₂).X ⟶ + modTensor A (modTensorMod A P₁ N₁) + (modTensorMod A P₂ N₂) => + (modTensorπ A N₁ P₁ ⊗ₘ modTensorπ A N₂ P₂) ≫ t) + hswap).trans ?_ + refine (Category.assoc _ _ _).symm.trans ?_ + refine (congrArg (fun t : (N₁.X ⊗ P₁.X) ⊗ (N₂.X ⊗ P₂.X) ⟶ + modTensor A P₁ N₁ ⊗ modTensor A P₂ N₂ => + t ≫ modTensorπ A (modTensorMod A P₁ N₁) + (modTensorMod A P₂ N₂)) hπswap).trans ?_ + exact Category.assoc _ _ _ + conv_lhs => rw [← Category.assoc, + tensorμ_braiding N₁.X N₂.X P₁.X P₂.X, Category.assoc] + conv_rhs => erw [← Category.assoc] + change _ = tensorμ N₁.X N₂.X P₁.X P₂.X ≫ + (((modTensorπ A N₁ P₁ ⊗ₘ modTensorπ A N₂ P₂) ≫ + modTensorπ A (modTensorMod A N₁ P₁) (modTensorMod A N₂ P₂)) ≫ + modTensorMap A (modTensorSwapMod A N₁ P₁) (modTensorSwapMod A N₂ P₂)) + refine congrArg (fun t : (N₁.X ⊗ P₁.X) ⊗ (N₂.X ⊗ P₂.X) ⟶ + modTensor A (modTensorMod A P₁ N₁) + (modTensorMod A P₂ N₂) => + tensorμ N₁.X N₂.X P₁.X P₂.X ≫ t) ?_ + erw [Category.assoc] + exact hR.symm + +/-- **The interchange is linear in the second factor**: the +middle action braids to the front and the first-factor linearity +applies through commutativity. -/ +theorem interchange_actMid + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (N₁ : Mod D A) (N₂ : Mod D A) + (P₁ : Mod D A) (P₂ : Mod D A) : + (modTensor A N₁ N₂ ◁ modTensorAct A P₁ P₂) ≫ + interchange A N₁ N₂ P₁ P₂ = + (α_ (modTensor A N₁ N₂) A (modTensor A P₁ P₂)).inv ≫ + ((β_ (modTensor A N₁ N₂) A).hom ▷ modTensor A P₁ P₂) ≫ + (α_ A (modTensor A N₁ N₂) (modTensor A P₁ P₂)).hom ≫ + (A ◁ interchange A N₁ N₂ P₁ P₂) ≫ + modTensorAct A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) := by + have hcomm : interchange A N₁ N₂ P₁ P₂ = + (β_ (modTensor A N₁ N₂) (modTensor A P₁ P₂)).hom ≫ + interchange A P₁ P₂ N₁ N₂ ≫ + modTensorMap A (modTensorSwapMod A P₁ N₁) + (modTensorSwapMod A P₂ N₂) := by + conv_rhs => rw [← interchange_comm A P₁ P₂ N₁ N₂, + ← Category.assoc, SymmetricCategory.symmetry, + Category.id_comp] + have hcoh : (β_ (modTensor A N₁ N₂) + (A ⊗ modTensor A P₁ P₂)).hom ≫ + (α_ A (modTensor A P₁ P₂) (modTensor A N₁ N₂)).hom ≫ + (A ◁ (β_ (modTensor A P₁ P₂) + (modTensor A N₁ N₂)).hom) = + (α_ (modTensor A N₁ N₂) A (modTensor A P₁ P₂)).inv ≫ + ((β_ (modTensor A N₁ N₂) A).hom ▷ modTensor A P₁ P₂) ≫ + (α_ A (modTensor A N₁ N₂) (modTensor A P₁ P₂)).hom := by + rw [BraidedCategory.braiding_tensor_right_hom] + simp only [Category.assoc, Iso.inv_hom_id_assoc, + ← MonoidalCategory.whiskerLeft_comp] + rw [SymmetricCategory.symmetry] + simp + conv_lhs => rw [hcomm, + BraidedCategory.braiding_naturality_right_assoc, + reassoc_of% (interchange_actLeft A P₁ P₂ N₁ N₂), + modTensorAct_map, + ← MonoidalCategory.whiskerLeft_comp_assoc, + (show interchange A P₁ P₂ N₁ N₂ ≫ + modTensorMap A (modTensorSwapMod A P₁ N₁) + (modTensorSwapMod A P₂ N₂) = + (β_ (modTensor A P₁ P₂) (modTensor A N₁ N₂)).hom ≫ + interchange A N₁ N₂ P₁ P₂ + from (interchange_comm A P₁ P₂ N₁ N₂).symm), + MonoidalCategory.whiskerLeft_comp, Category.assoc, + reassoc_of% hcoh] + +section ChainMulAct + +/-- **The chain multiplication is linear over the base in the +first stage**: the interchange linearity composed with the +functoriality of the module tensor product. Stated at the +unwrapped module tensor products; the stage forms follow by +definitional unfolding. -/ +theorem chainMul_actLeft + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] + [CategoryTheory.Linear ℂ D] [MonoidalLinear ℂ D] (M : Mod D A) + (M' : Mod D A) + (m n : ℕ) : + (modTensorAct A (symPowMod A M'.X m) (symPowMod A M.X m) ▷ + modTensor A (symPowMod A M'.X n) (symPowMod A M.X n)) ≫ + chainMul A M M' m n = + (α_ A (modTensor A (symPowMod A M'.X m) (symPowMod A M.X m)) + (modTensor A (symPowMod A M'.X n) + (symPowMod A M.X n))).hom ≫ + (A ◁ chainMul A M M' m n) ≫ + modTensorAct A (symPowMod A M'.X (m + 1 + n)) + (symPowMod A M.X (m + 1 + n)) := by + change (modTensorAct A (symPowMod A M'.X m) (symPowMod A M.X m) ▷ + modTensor A (symPowMod A M'.X n) (symPowMod A M.X n)) ≫ + (interchange A (symPowMod A M'.X m) (symPowMod A M.X m) + (symPowMod A M'.X n) (symPowMod A M.X n) ≫ + modTensorMap A (symMulMod A M'.X m n) + (symMulMod A M.X m n)) = + (α_ A (modTensor A (symPowMod A M'.X m) (symPowMod A M.X m)) + (modTensor A (symPowMod A M'.X n) + (symPowMod A M.X n))).hom ≫ + (A ◁ (interchange A (symPowMod A M'.X m) + (symPowMod A M.X m) (symPowMod A M'.X n) + (symPowMod A M.X n) ≫ + modTensorMap A (symMulMod A M'.X m n) + (symMulMod A M.X m n))) ≫ + modTensorAct A (symPowMod A M'.X (m + 1 + n)) + (symPowMod A M.X (m + 1 + n)) + rw [reassoc_of% (interchange_actLeft A + (symPowMod A M'.X m) (symPowMod A M.X m) + (symPowMod A M'.X n) (symPowMod A M.X n)), + modTensorAct_map, + ← MonoidalCategory.whiskerLeft_comp_assoc] + +/-- **The two-index chain multiplication is linear over the base +in the first stage**: the interchange linearity composed with the +functoriality of the module tensor product, at four independent +symmetric-power arities. Stated at the unwrapped module tensor +products; the two-index stage forms follow by definitional +unfolding. The diagonal `p = q`, `r = s` is `chainMul_actLeft`. -/ +theorem chainMul2_actLeft + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] + [CategoryTheory.Linear ℂ D] [MonoidalLinear ℂ D] (M : Mod D A) + (M' : Mod D A) + (p q r s : ℕ) : + (modTensorAct A (symPowMod A M'.X p) (symPowMod A M.X q) ▷ + modTensor A (symPowMod A M'.X r) (symPowMod A M.X s)) ≫ + chainMul2 A M M' p q r s = + (α_ A (modTensor A (symPowMod A M'.X p) + (symPowMod A M.X q)) + (modTensor A (symPowMod A M'.X r) + (symPowMod A M.X s))).hom ≫ + (A ◁ chainMul2 A M M' p q r s) ≫ + modTensorAct A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s)) := by + change (modTensorAct A (symPowMod A M'.X p) (symPowMod A M.X q) ▷ + modTensor A (symPowMod A M'.X r) (symPowMod A M.X s)) ≫ + (interchange A (symPowMod A M'.X p) (symPowMod A M.X q) + (symPowMod A M'.X r) (symPowMod A M.X s) ≫ + modTensorMap A (symMulMod A M'.X p r) + (symMulMod A M.X q s)) = + (α_ A (modTensor A (symPowMod A M'.X p) (symPowMod A M.X q)) + (modTensor A (symPowMod A M'.X r) + (symPowMod A M.X s))).hom ≫ + (A ◁ (interchange A (symPowMod A M'.X p) + (symPowMod A M.X q) (symPowMod A M'.X r) + (symPowMod A M.X s) ≫ + modTensorMap A (symMulMod A M'.X p r) + (symMulMod A M.X q s))) ≫ + modTensorAct A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s)) + rw [reassoc_of% (interchange_actLeft A + (symPowMod A M'.X p) (symPowMod A M.X q) + (symPowMod A M'.X r) (symPowMod A M.X s)), + modTensorAct_map, + ← MonoidalCategory.whiskerLeft_comp_assoc] + +/-- **The two-index chain multiplication is linear over the base +in the second factor**: the middle action braids to the front and +the interchange linearity applies. Stated at the unwrapped module +tensor products; the stage forms follow by definitional +unfolding. -/ +theorem chainMul2_actMid + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] + [CategoryTheory.Linear ℂ D] [MonoidalLinear ℂ D] (M : Mod D A) + (M' : Mod D A) + (p q r s : ℕ) : + (modTensor A (symPowMod A M'.X p) (symPowMod A M.X q) ◁ + modTensorAct A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + chainMul2 A M M' p q r s = + (α_ (modTensor A (symPowMod A M'.X p) + (symPowMod A M.X q)) A + (modTensor A (symPowMod A M'.X r) + (symPowMod A M.X s))).inv ≫ + ((β_ (modTensor A (symPowMod A M'.X p) + (symPowMod A M.X q)) A).hom ▷ + modTensor A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + (α_ A (modTensor A (symPowMod A M'.X p) + (symPowMod A M.X q)) + (modTensor A (symPowMod A M'.X r) + (symPowMod A M.X s))).hom ≫ + (A ◁ chainMul2 A M M' p q r s) ≫ + modTensorAct A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s)) := by + change (modTensor A (symPowMod A M'.X p) (symPowMod A M.X q) ◁ + modTensorAct A (symPowMod A M'.X r) (symPowMod A M.X s)) ≫ + (interchange A (symPowMod A M'.X p) (symPowMod A M.X q) + (symPowMod A M'.X r) (symPowMod A M.X s) ≫ + modTensorMap A (symMulMod A M'.X p r) + (symMulMod A M.X q s)) = + (α_ (modTensor A (symPowMod A M'.X p) + (symPowMod A M.X q)) A + (modTensor A (symPowMod A M'.X r) + (symPowMod A M.X s))).inv ≫ + ((β_ (modTensor A (symPowMod A M'.X p) + (symPowMod A M.X q)) A).hom ▷ + modTensor A (symPowMod A M'.X r) + (symPowMod A M.X s)) ≫ + (α_ A (modTensor A (symPowMod A M'.X p) + (symPowMod A M.X q)) + (modTensor A (symPowMod A M'.X r) + (symPowMod A M.X s))).hom ≫ + (A ◁ (interchange A (symPowMod A M'.X p) + (symPowMod A M.X q) (symPowMod A M'.X r) + (symPowMod A M.X s) ≫ + modTensorMap A (symMulMod A M'.X p r) + (symMulMod A M.X q s))) ≫ + modTensorAct A (symPowMod A M'.X (p + 1 + r)) + (symPowMod A M.X (q + 1 + s)) + rw [reassoc_of% (interchange_actMid A + (symPowMod A M'.X p) (symPowMod A M.X q) + (symPowMod A M'.X r) (symPowMod A M.X s)), + modTensorAct_map, + ← MonoidalCategory.whiskerLeft_comp_assoc] + +end ChainMulAct + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KernelPow.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KernelPow.lean new file mode 100644 index 0000000000..0cfeea2c23 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KernelPow.lean @@ -0,0 +1,1011 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.WordMap + +/-! +# The kernel of a tensor power of an epimorphism + +The exactness half of the mixed filtration for Deligne 1.19's +extension argument (Catégories tensorielles): if `ι : U ⟶ Z` covers +the kernel of an epimorphism `π : Z ⟶ W`, then the kernel of +`π ^ ⊗ m` is covered by the images of the word maps of `ι` and +`𝟙 Z` with exactly one `ι`-slot (`kernelSubobject_tensorPowMap_le`). + +**The exactness hypothesis.** The kernel condition is stated as +`hker : kernelSubobject π ≤ imageSubobject ι` — only the covering +half of exactness is consumed, so neither `Mono ι` nor `ι ≫ π = 0` +is assumed. For a genuinely exact pair, with `Mono ι` and +`hexact : imageSubobject ι = kernelSubobject π`, apply the theorems +at `hker := hexact.ge`. + +Three layers: + +* **Word concatenation** (pure monoidal coherence): appended words + `wordAppend` concatenate word powers (`wordPowConcatIso`) and word + maps (`wordMap_append`), mirroring `wordMap_standard`; letter + counts add (`popCount_wordAppend`). At the level of images this + is `imageSubobject_wordMap_concat`. +* **The two-factor kernel** (the abelian heart): in a rigid abelian + monoidal category the kernel of `p₁ ⊗ₘ p₂`, for `p₁` epi, is the + join of the images of the two one-slot kernel insertions + (`kernelSubobject_tensorHom_le`, an equality by + `kernelSubobject_tensorHom`). The chase runs through the + factorisation `p₁ ⊗ₘ p₂ = (p₁ ▷ Z₂) ≫ (W₁ ◁ p₂)`, the + identification of whiskered kernels + (`kernelSubobject_whiskerRight_le`), and a pullback of the + covering epimorphism (`kernelSubobject_comp_le_of_cover`). +* **The iterated kernel**: induction along + `tensorPowMap π (m + 1) = tensorPowMap π m ⊗ₘ π`, transporting + the inductive cover through the tensor structure. The cover is + a single morphism from a biproduct of one-slot word powers + (`oneSlotCover`), and the final statement is phrased as a + `Finset.sup` of image subobjects: the ambient category is not + assumed well-powered, so the subobject lattice carries finite + joins but no indexed supremum. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Limits MonoidalCategory + +universe v u + +variable {A : Type u} + +/-! ## Appended words + +`wordAppend` is `Fin.append`: the first word occupies the low +block. This matches the orientation of `tensorPowConcat` and +`standardWord`, whose first factor is also the low block +(`wordAppend_const_true_false`). +-/ + +/-- **The appended word**: `wa` on the low block, `wb` on the high +block. -/ +def wordAppend {a b : ℕ} (wa : Fin a → Bool) (wb : Fin b → Bool) : + Fin (a + b) → Bool := + Fin.append wa wb + +/-- Appending the empty word is the identity. -/ +theorem wordAppend_zero {a : ℕ} (wa : Fin a → Bool) + (wb : Fin 0 → Bool) : wordAppend wa wb = wa := by + funext i + induction i using Fin.addCases with + | left j => exact Fin.append_left wa wb j + | right j => exact j.elim0 + +/-- Restricting an appended word restricts the second word. -/ +theorem wordAppend_castSucc {a b : ℕ} (wa : Fin a → Bool) + (wb : Fin (b + 1) → Bool) : + wordAppend wa wb ∘ Fin.castSucc = + wordAppend wa (wb ∘ Fin.castSucc) := by + funext i + induction i using Fin.addCases with + | left j => + exact (Fin.append_left wa wb j).trans + (Fin.append_left wa (wb ∘ Fin.castSucc) j).symm + | right j => + exact (Fin.append_right wa wb (Fin.castSucc j)).trans + (Fin.append_right wa (wb ∘ Fin.castSucc) j).symm + +/-- The last letter of an appended word is the second word's last +letter. -/ +theorem wordAppend_last {a b : ℕ} (wa : Fin a → Bool) + (wb : Fin (b + 1) → Bool) : + wordAppend wa wb (Fin.last (a + b)) = wb (Fin.last b) := + Fin.append_right wa wb (Fin.last b) + +/-- Letter counts add across an appended word. -/ +theorem popCount_wordAppend {a b : ℕ} (wa : Fin a → Bool) + (wb : Fin b → Bool) : + popCount (wordAppend wa wb) = popCount wa + popCount wb := by + have key : ∀ (m : ℕ) (v : Fin m → Bool), + popCount v = ∑ i, if v i = true then 1 else 0 := by + intro m v + simp [popCount] + rw [key, key, key, Fin.sum_univ_add] + congr 1 + · exact Finset.sum_congr rfl fun i _ => by + rw [wordAppend, Fin.append_left] + · exact Finset.sum_congr rfl fun i _ => by + rw [wordAppend, Fin.append_right] + +/-- The sorted word is the all-`true` word appended to the +all-`false` word: `wordAppend`'s low block matches +`standardWord`'s. -/ +theorem wordAppend_const_true_false (p q : ℕ) : + wordAppend (fun _ : Fin p => true) (fun _ : Fin q => false) = + standardWord p q := by + funext i + induction i using Fin.addCases with + | left j => + rw [wordAppend, Fin.append_left] + exact (decide_eq_true j.isLt).symm + | right j => + rw [wordAppend, Fin.append_right] + simp [standardWord] + +/-! ## Word powers of appended words -/ + +/-- Appending the empty word does not change the word power. -/ +theorem wordPow_append_zero [Category.{v} A] [MonoidalCategory A] + (U V : A) {a : ℕ} (wa : Fin a → Bool) + (wb : Fin 0 → Bool) : + wordPow U V (a + 0) (wordAppend wa wb) = wordPow U V a wa := + congrArg (wordPow U V a) (wordAppend_zero wa wb) + +/-- One more letter of the second word tensors the selected +object. -/ +theorem wordPow_append_succ [Category.{v} A] [MonoidalCategory A] + (U V : A) {a b : ℕ} (wa : Fin a → Bool) + (wb : Fin (b + 1) → Bool) : + wordPow U V (a + (b + 1)) (wordAppend wa wb) = + wordPow U V (a + b) (wordAppend wa (wb ∘ Fin.castSucc)) ⊗ + (bif wb (Fin.last b) then U else V) := by + change wordPow U V (a + b) (wordAppend wa wb ∘ Fin.castSucc) ⊗ + (bif wordAppend wa wb (Fin.last (a + b)) then U else V) = _ + rw [wordAppend_castSucc, wordAppend_last] + +/-- **The word powers of an appended word concatenate**: the word +power of `wordAppend wa wb` is the tensor of the two word powers, +by the recursion of the second word. Built stage by stage, mirror +to `standardMixedIso`, so that consumers can compose with it. -/ +noncomputable def wordPowConcatIso [Category.{v} A] [MonoidalCategory A] + (U V : A) {a : ℕ} + (wa : Fin a → Bool) : (b : ℕ) → (wb : Fin b → Bool) → + (wordPow U V (a + b) (wordAppend wa wb) ≅ + wordPow U V a wa ⊗ wordPow U V b wb) + | 0, wb => + eqToIso (wordPow_append_zero U V wa wb) ≪≫ + (ρ_ (wordPow U V a wa)).symm + | b + 1, wb => + eqToIso (wordPow_append_succ U V wa wb) ≪≫ + whiskerRightIso + (wordPowConcatIso U V wa b (wb ∘ Fin.castSucc)) _ ≪≫ + α_ (wordPow U V a wa) + (wordPow U V b (wb ∘ Fin.castSucc)) + (bif wb (Fin.last b) then U else V) + +/-! ## The concatenation square + +The word map of an appended word is the tensor of the two word +maps, followed by the concatenation of the target powers, under +`wordPowConcatIso`. The gluing helpers replicate the private +steps of `wordMap_standard` at general objects, applied by +`exact`, so that no tensor-power arity enters the rewriting. +-/ + +/-- Tensoring with the unit's identity is unitor conjugation. +Stated at general objects. -/ +private theorem unit_tensor_unitor [Category.{v} A] [MonoidalCategory A] + {P Q : A} (k : P ⟶ Q) : + (k ⊗ₘ 𝟙 (𝟙_ A)) ≫ (ρ_ Q).hom = (ρ_ P).hom ≫ k := by + rw [MonoidalCategory.tensorHom_id] + exact MonoidalCategory.rightUnitor_naturality k + +/-- One stage of the concatenation glued onto an intertwining of +the previous stage. Stated at general objects. -/ +private theorem concat_step_glue [Category.{v} A] [MonoidalCategory A] + {P Q W R P' Q' S T : A} + (u : P ⊗ Q ⟶ W) (M : W ⟶ R) (v₁ : P ⟶ P') (v₂ : Q ⟶ Q') + (c : P' ⊗ Q' ⟶ R) (e : S ⟶ T) + (hih : u ≫ M = (v₁ ⊗ₘ v₂) ≫ c) : + (α_ P Q S).inv ≫ ((u ▷ S) ≫ (M ⊗ₘ e)) = + (v₁ ⊗ₘ (v₂ ⊗ₘ e)) ≫ (α_ P' Q' T).inv ≫ (c ▷ T) := by + have h1 : (u ▷ S) ≫ (M ⊗ₘ e) = (u ≫ M) ⊗ₘ e := by + rw [← MonoidalCategory.tensorHom_id u S, + MonoidalCategory.tensorHom_comp_tensorHom, Category.id_comp] + have h2 : ((v₁ ⊗ₘ v₂) ⊗ₘ e) ≫ (c ▷ T) = ((v₁ ⊗ₘ v₂) ≫ c) ⊗ₘ e := by + rw [← MonoidalCategory.tensorHom_id c T, + MonoidalCategory.tensorHom_comp_tensorHom, Category.comp_id] + have h3 : (α_ P Q S).inv ≫ ((v₁ ⊗ₘ v₂) ⊗ₘ e) = + (v₁ ⊗ₘ (v₂ ⊗ₘ e)) ≫ (α_ P' Q' T).inv := + (MonoidalCategory.associator_inv_naturality v₁ v₂ e).symm + calc (α_ P Q S).inv ≫ ((u ▷ S) ≫ (M ⊗ₘ e)) + = (α_ P Q S).inv ≫ (((v₁ ⊗ₘ v₂) ≫ c) ⊗ₘ e) := by rw [h1, hih] + _ = (α_ P Q S).inv ≫ ((v₁ ⊗ₘ v₂) ⊗ₘ e) ≫ (c ▷ T) := by rw [h2] + _ = ((v₁ ⊗ₘ (v₂ ⊗ₘ e)) ≫ (α_ P' Q' T).inv) ≫ (c ▷ T) := by + rw [← Category.assoc, h3] + _ = (v₁ ⊗ₘ (v₂ ⊗ₘ e)) ≫ (α_ P' Q' T).inv ≫ (c ▷ T) := + Category.assoc _ _ _ + +/-- A transport and its inverse cancel across a decomposition of +the middle morphism. Stated at general objects and applied by +`exact`, so the defeq-mismatched arities never enter a rewrite. -/ +private theorem cast_cancel_glue [Category.{v} A] + {M N W R : A} (h : N = W) + (h' : W = N) (a : M ⟶ N) (D : W ⟶ R) (T : N ⟶ R) + (hD : D = eqToHom h' ≫ T) : + (a ≫ eqToHom h) ≫ D = a ≫ T := by + subst h + rw [hD, show h' = rfl from rfl, eqToHom_refl, + Category.id_comp, Category.comp_id] + +/-- Transport along the `a + 0` arity cast composes away against +the word map of the first word. -/ +private theorem word_map_cast + [Category.{v} A] [MonoidalCategory A] {U : A} {V : A} {Z : A} + (f : U ⟶ Z) (g : V ⟶ Z) {a : ℕ} + (wa : Fin a → Bool) + (H : wordPow U V a wa = wordPow U V (a + 0) wa) : + eqToHom H ≫ wordMap f g (a + 0) wa = wordMap f g a wa := by + rw [show H = rfl from rfl, eqToHom_refl, Category.id_comp] + rfl + +/-- **The concatenation square**: the word map of an appended word +is the tensor of the two word maps followed by the concatenation +of the pure target powers, under `wordPowConcatIso` at the +source. -/ +theorem wordMap_append + [Category.{v} A] [MonoidalCategory A] {U : A} {V : A} {Z : A} + (f : U ⟶ Z) (g : V ⟶ Z) {a : ℕ} + (wa : Fin a → Bool) : + ∀ (b : ℕ) (wb : Fin b → Bool), + (wordPowConcatIso U V wa b wb).inv ≫ + wordMap f g (a + b) (wordAppend wa wb) = + (wordMap f g a wa ⊗ₘ wordMap f g b wb) ≫ + (tensorPowConcat Z a b).hom := by + intro b + induction b with + | zero => + intro wb + have hkey : eqToHom (wordPow_append_zero U V wa wb).symm ≫ + wordMap f g (a + 0) (wordAppend wa wb) = + wordMap f g a wa := by + rw [wordMap_congr f g (wordAppend_zero wa wb), + eqToHom_trans_assoc] + exact word_map_cast f g wa _ + change ((ρ_ (wordPow U V a wa)).hom ≫ + eqToHom (wordPow_append_zero U V wa wb).symm) ≫ + wordMap f g (a + 0) (wordAppend wa wb) = + (wordMap f g a wa ⊗ₘ 𝟙 (𝟙_ A)) ≫ + (ρ_ (tensorPow A Z a)).hom + rw [Category.assoc, hkey] + exact (unit_tensor_unitor (wordMap f g a wa)).symm + | succ b ih => + intro wb + have hstep : wordPow U V (a + (b + 1)) (wordAppend wa wb) = + wordPow U V (a + b) (wordAppend wa (wb ∘ Fin.castSucc)) ⊗ + (bif wb (Fin.last b) then U else V) := + wordPow_append_succ U V wa wb + have hsplit := wordMap_split f g (a + b) + (wordAppend (a := a) (b := b + 1) wa wb) + (wordAppend wa (wb ∘ Fin.castSucc)) (wb (Fin.last b)) + (wordAppend_castSucc wa wb) (wordAppend_last wa wb) hstep + refine (cast_cancel_glue hstep.symm hstep + ((α_ (wordPow U V a wa) + (wordPow U V b (wb ∘ Fin.castSucc)) + (bif wb (Fin.last b) then U else V)).inv ≫ + ((wordPowConcatIso U V wa b (wb ∘ Fin.castSucc)).inv ▷ _)) + (wordMap f g (a + (b + 1)) (wordAppend wa wb)) + (wordMap f g (a + b) (wordAppend wa (wb ∘ Fin.castSucc)) ⊗ₘ + letterMap f g (wb (Fin.last b))) + hsplit).trans ?_ + erw [Category.assoc] + exact concat_step_glue + (wordPowConcatIso U V wa b (wb ∘ Fin.castSucc)).inv + (wordMap f g (a + b) (wordAppend wa (wb ∘ Fin.castSucc))) + (wordMap f g a wa) (wordMap f g b (wb ∘ Fin.castSucc)) + (tensorPowConcat Z a b).hom + (letterMap f g (wb (Fin.last b))) + (ih (wb ∘ Fin.castSucc)) + +/-! ## Extended and all-`false` words + +The one-slot insertions of the filtration are words extended by +`Fin.snoc`, and the base insertion is an all-`false` word with one +`true` slot on top. The lemmas mirror the all-`true` cases of +`WordMap.lean`. +-/ + +/-- The letter count of an extended word. -/ +theorem popCount_snoc {n : ℕ} (w : Fin n → Bool) (y : Bool) : + popCount (Fin.snoc w y) = popCount w + (bif y then 1 else 0) := by + rw [popCount_succ, + show (Fin.snoc w y : Fin (n + 1) → Bool) ∘ Fin.castSucc = w from + Fin.snoc_comp_castSucc, + Fin.snoc_last] + +/-- The all-`false` word has no `true` letters. -/ +theorem popCount_const_false (n : ℕ) : + popCount (fun _ : Fin n => false) = 0 := by + simp [popCount] + +/-- The word power of a `false`-extended word tensors a `Y`. -/ +theorem wordPow_snoc_false [Category.{v} A] [MonoidalCategory A] + (X Y : A) (n : ℕ) (w : Fin n → Bool) : + wordPow X Y (n + 1) (Fin.snoc w false) = wordPow X Y n w ⊗ Y := by + rw [wordPow_succ, + show (Fin.snoc w false : Fin (n + 1) → Bool) ∘ Fin.castSucc = w + from Fin.snoc_comp_castSucc, + Fin.snoc_last] + rfl + +/-- The word power of a `true`-extended word tensors an `X`. -/ +theorem wordPow_snoc_true [Category.{v} A] [MonoidalCategory A] + (X Y : A) (n : ℕ) (w : Fin n → Bool) : + wordPow X Y (n + 1) (Fin.snoc w true) = wordPow X Y n w ⊗ X := by + rw [wordPow_succ, + show (Fin.snoc w true : Fin (n + 1) → Bool) ∘ Fin.castSucc = w + from Fin.snoc_comp_castSucc, + Fin.snoc_last] + rfl + +/-- The word map of a `false`-extended word tensors a `g`. -/ +theorem wordMap_snoc_false + [Category.{v} A] [MonoidalCategory A] {U : A} {V : A} {Z : A} + (f : U ⟶ Z) (g : V ⟶ Z) (n : ℕ) + (w : Fin n → Bool) : + wordMap f g (n + 1) (Fin.snoc w false) = + eqToHom (wordPow_snoc_false U V n w) ≫ + (wordMap f g n w ⊗ₘ g) := + wordMap_split_false f g n (Fin.snoc w false) w + Fin.snoc_comp_castSucc (Fin.snoc_last ..) + (wordPow_snoc_false U V n w) + +/-- The word map of a `true`-extended word tensors an `f`. -/ +theorem wordMap_snoc_true + [Category.{v} A] [MonoidalCategory A] {U : A} {V : A} {Z : A} + (f : U ⟶ Z) (g : V ⟶ Z) (n : ℕ) + (w : Fin n → Bool) : + wordMap f g (n + 1) (Fin.snoc w true) = + eqToHom (wordPow_snoc_true U V n w) ≫ + (wordMap f g n w ⊗ₘ f) := + wordMap_split_true f g n (Fin.snoc w true) w + Fin.snoc_comp_castSucc (Fin.snoc_last ..) + (wordPow_snoc_true U V n w) + +/-- An all-`false` word power is a pure power of `Y`. -/ +theorem wordPow_const_false [Category.{v} A] [MonoidalCategory A] + (X Y : A) : + ∀ n : ℕ, wordPow X Y n (fun _ => false) = tensorPow A Y n := by + intro n + induction n with + | zero => rfl + | succ n ih => + change wordPow X Y n (fun _ => false) ⊗ Y = tensorPow A Y n ⊗ Y + rw [ih] + +/-- An `eqToHom` pulls out of the first factor of a tensor. Stated +at general objects. -/ +private theorem eqToHom_tensor_pull [Category.{v} A] [MonoidalCategory A] + {P P' Q R S : A} (h : P = P') + (k : P' ⟶ Q) (l : R ⟶ S) : + (eqToHom h ≫ k) ⊗ₘ l = + eqToHom (congrArg (· ⊗ R) h) ≫ (k ⊗ₘ l) := by + subst h + rw [eqToHom_refl, eqToHom_refl, Category.id_comp, Category.id_comp] + +/-- On an all-`false` word the word map is the pure power of `g`. -/ +theorem wordMap_const_false + [Category.{v} A] [MonoidalCategory A] {U : A} {V : A} {Z : A} + (f : U ⟶ Z) (g : V ⟶ Z) : + ∀ n : ℕ, + wordMap f g n (fun _ => false) = + eqToHom (wordPow_const_false U V n) ≫ tensorPowMap g n := by + intro n + induction n with + | zero => + exact (Category.id_comp _).symm + | succ n ih => + change wordMap f g n (fun _ => false) ⊗ₘ g = _ + rw [ih] + exact eqToHom_tensor_pull (wordPow_const_false U V n) _ _ + +/-- A tensor with a cast first factor is a left whiskering. Stated +at general objects and applied by `exact`, so the defeq-mismatched +arities never enter a rewrite. -/ +private theorem cast_tensor_to_whiskerLeft [Category.{v} A] [MonoidalCategory A] + {P Q R S : A} (h : P = Q) + (H : Q ⊗ R = P ⊗ R) (l : R ⟶ S) : + eqToHom H ≫ (eqToHom h ⊗ₘ l) = Q ◁ l := by + subst h + rw [show H = rfl from rfl, eqToHom_refl, eqToHom_refl, + Category.id_comp, MonoidalCategory.id_tensorHom] + +/-! ## Concatenation at the level of images -/ + +section Image + +/-- Rewriting the morphism inside an image subobject. Stated as a +congruence, so the image's instance argument transports with the +equality. -/ +private theorem imageSubobject_congr [Category.{v} A] [HasImages A] + {X B : A} {f g : X ⟶ B} + (h : f = g) : imageSubobject f = imageSubobject g := by + subst h + rfl + +/-- **Concatenation of word-map images**: the tensor of two word +maps followed by the target concatenation has the same image as +the word map of the appended word — the concatenation square +`wordMap_append` up to the isomorphism `wordPowConcatIso` of the +sources. -/ +theorem imageSubobject_wordMap_concat + [Category.{v} A] [MonoidalCategory A] {U : A} {V : A} {Z : A} + [HasEqualizers A] [HasImages A] + (f : U ⟶ Z) (g : V ⟶ Z) + {a b : ℕ} (wa : Fin a → Bool) (wb : Fin b → Bool) : + imageSubobject ((wordMap f g a wa ⊗ₘ wordMap f g b wb) ≫ + (tensorPowConcat Z a b).hom) = + imageSubobject (wordMap f g (a + b) (wordAppend wa wb)) := + ((imageSubobject_congr (wordMap_append f g wa b wb)).symm).trans + (imageSubobject_iso_comp _ _) + +end Image + +/-! ## The subobject toolkit + +Factoring through subobjects in an abelian category: epi descent +(`factors_of_epi_comp`, the monomorphism half of the +kernel–cokernel duality), the kernel and image conversions, and +the composite-kernel chase `kernelSubobject_comp_le_of_cover` — the +kernel of `u ≫ v` is covered by the kernel of `u` together with +any `b` whose image under `u` covers the kernel of `v`. This is +the extension `0 ⟶ ker u ⟶ ker (u ≫ v) ⟶ ker v` of the mixed +filtration, phrased through a pullback of the covering +epimorphism. +-/ + +section Toolkit + +/-- **Epi descent for factorisations**: a morphism factors through +a subobject as soon as its composite with an epimorphism does. +The subobject's arrow is the kernel of its cokernel, so the +factorisation is `Abelian.monoLift`. -/ +theorem factors_of_epi_comp [Category.{v} A] [Abelian A] + {P K B : A} (S : Subobject B) + (e : P ⟶ K) [Epi e] (k : K ⟶ B) (h : S.Factors (e ≫ k)) : + S.Factors k := by + have hz : k ≫ cokernel.π S.arrow = 0 := by + rw [← cancel_epi e, comp_zero, ← Category.assoc, + ← Subobject.factorThru_arrow S (e ≫ k) h, Category.assoc, + cokernel.condition, comp_zero] + exact (Subobject.factors_iff S k).mpr + ⟨Abelian.monoLift S.arrow k hz, Abelian.monoLift_comp S.arrow k hz⟩ + +/-- A subobject containing a kernel factors the kernel's arrow. -/ +theorem factors_kernel_ι_of_le [Category.{v} A] [Abelian A] + {X Y : A} {p : X ⟶ Y} + {S : Subobject X} (h : kernelSubobject p ≤ S) : + S.Factors (kernel.ι p) := + Subobject.factors_of_le _ h + (kernelSubobject_factors p _ (kernel.condition p)) + +/-- A subobject factoring a kernel's arrow contains the kernel. -/ +theorem kernelSubobject_le_of_factors [Category.{v} A] [Abelian A] + {X Y : A} {p : X ⟶ Y} + {S : Subobject X} (h : S.Factors (kernel.ι p)) : + kernelSubobject p ≤ S := by + refine Subobject.le_of_comm + ((kernelSubobjectIso p).hom ≫ S.factorThru (kernel.ι p) h) ?_ + rw [Category.assoc, Subobject.factorThru_arrow, + kernelSubobject_arrow] + +/-- A subobject factoring a morphism contains its image. -/ +theorem imageSubobject_le_of_factors [Category.{v} A] [Abelian A] + {X B : A} {f : X ⟶ B} + {S : Subobject B} (h : S.Factors f) : + imageSubobject f ≤ S := + imageSubobject_le f (S.factorThru f h) + (Subobject.factorThru_arrow S f h) + +/-- The image of a morphism factors it. -/ +theorem factors_self_imageSubobject [Category.{v} A] [Abelian A] + {X B : A} (f : X ⟶ B) : + (imageSubobject f).Factors f := + (Subobject.factors_iff _ _).mpr + ⟨factorThruImageSubobject f, imageSubobject_arrow_comp f⟩ + +/-- Rewriting the morphism inside a kernel subobject. Stated as a +congruence, so the kernel's instance argument transports with the +equality. -/ +private theorem kernelSubobject_congr [Category.{v} A] [Abelian A] + {X Y : A} {f g : X ⟶ Y} + (h : f = g) : kernelSubobject f = kernelSubobject g := by + subst h + rfl + +/-- **The composite-kernel chase**: if the image of `b ≫ u` covers +the kernel of `v`, then the kernel of `u ≫ v` is covered by the +kernel of `u` together with the image of `b`. The kernel arrow of +`u ≫ v`, pushed into `Y`, factors through the cover; pulling the +covering epimorphism back splits the kernel arrow, up to an +epimorphism, into a summand through `ker u` and a summand through +`b`. -/ +theorem kernelSubobject_comp_le_of_cover [Category.{v} A] [Abelian A] + {X Y T B : A} + (u : X ⟶ Y) (v : Y ⟶ T) (b : B ⟶ X) + (hv : kernelSubobject v ≤ imageSubobject (b ≫ u)) : + kernelSubobject (u ≫ v) ≤ + kernelSubobject u ⊔ imageSubobject b := by + have hku : (kernel.ι (u ≫ v) ≫ u) ≫ v = 0 := by + rw [Category.assoc, kernel.condition] + have hfac : (imageSubobject (b ≫ u)).Factors + (kernel.ι (u ≫ v) ≫ u) := + Subobject.factors_of_le _ hv (kernelSubobject_factors v _ hku) + obtain ⟨t, htw⟩ : ∃ t' : kernel (u ≫ v) ⟶ + (imageSubobject (b ≫ u) : A), + t' ≫ (imageSubobject (b ≫ u)).arrow = kernel.ι (u ≫ v) ≫ u := + ⟨_, Subobject.factorThru_arrow _ _ hfac⟩ + obtain ⟨q, hq_epi, hqw⟩ : ∃ q' : B ⟶ (imageSubobject (b ≫ u) : A), + Epi q' ∧ q' ≫ (imageSubobject (b ≫ u)).arrow = b ≫ u := + ⟨factorThruImageSubobject (b ≫ u), inferInstance, + imageSubobject_arrow_comp (b ≫ u)⟩ + have := hq_epi + refine kernelSubobject_le_of_factors + (factors_of_epi_comp _ (pullback.fst t q) + (kernel.ι (u ≫ v)) ?_) + have hd : (pullback.fst t q ≫ kernel.ι (u ≫ v) - + pullback.snd t q ≫ b) ≫ u = 0 := by + calc (pullback.fst t q ≫ kernel.ι (u ≫ v) - + pullback.snd t q ≫ b) ≫ u + = pullback.fst t q ≫ (kernel.ι (u ≫ v) ≫ u) - + pullback.snd t q ≫ (b ≫ u) := by + rw [Preadditive.sub_comp, Category.assoc, Category.assoc] + _ = pullback.fst t q ≫ + (t ≫ (imageSubobject (b ≫ u)).arrow) - + pullback.snd t q ≫ + (q ≫ (imageSubobject (b ≫ u)).arrow) := by + rw [htw, hqw] + _ = (pullback.fst t q ≫ t - pullback.snd t q ≫ q) ≫ + (imageSubobject (b ≫ u)).arrow := by + rw [Preadditive.sub_comp, Category.assoc, Category.assoc] + _ = 0 := by rw [pullback.condition, sub_self, zero_comp] + have hsum : pullback.fst t q ≫ kernel.ι (u ≫ v) = + (pullback.fst t q ≫ kernel.ι (u ≫ v) - + pullback.snd t q ≫ b) + pullback.snd t q ≫ b := + (sub_add_cancel _ _).symm + rw [hsum] + exact Subobject.factors_add _ _ + (Subobject.sup_factors_of_factors_left + (kernelSubobject_factors u _ hd)) + (Subobject.sup_factors_of_factors_right + (Subobject.factors_of_factors_right _ + (factors_self_imageSubobject b))) + +end Toolkit + +/-! ## Whiskered epimorphisms and kernels + +Whiskering preserves epimorphisms and kernels because tensoring is +exact in a rigid category (`TensorExact.lean`). +-/ + +section Rigid + +/-- Right whiskering preserves epimorphisms. -/ +theorem epi_whiskerRight_of_epi + [Category.{v} A] [MonoidalCategory A] [RigidCategory A] + {X Y : A} (p : X ⟶ Y) [Epi p] + (W : A) : Epi (p ▷ W) := by + have : PreservesColimitsOfSize.{0, 0} (tensorRight W) := + preservesSmallestColimits_of_preservesColimits _ + exact (tensorRight W).map_epi p + +/-- Left whiskering preserves epimorphisms. -/ +theorem epi_whiskerLeft_of_epi + [Category.{v} A] [MonoidalCategory A] [RigidCategory A] + (W : A) {X Y : A} (p : X ⟶ Y) + [Epi p] : Epi (W ◁ p) := by + have : PreservesColimitsOfSize.{0, 0} (tensorLeft W) := + preservesSmallestColimits_of_preservesColimits _ + exact (tensorLeft W).map_epi p + +end Rigid + +section WhiskerKernel + +/-- The kernel arrow of a right-whiskered morphism factors through +the whiskered kernel arrow, because right tensoring preserves +kernels. -/ +private theorem exists_kernel_ι_whiskerRight + [Category.{v} A] [MonoidalCategory A] [Abelian A] + [MonoidalPreadditive A] [RigidCategory A] + {X Y : A} (p : X ⟶ Y) + (W : A) : + ∃ e : kernel (p ▷ W) ⟶ kernel p ⊗ W, + kernel.ι (p ▷ W) = e ≫ (kernel.ι p ▷ W) := by + have : PreservesLimitsOfSize.{0, 0} (tensorRight W) := + preservesSmallestLimits_of_preservesLimits _ + exact ⟨(PreservesKernel.iso (tensorRight W) p).inv, + (PreservesKernel.iso_inv_ι (tensorRight W) p).symm⟩ + +/-- The kernel arrow of a left-whiskered morphism factors through +the whiskered kernel arrow, because left tensoring preserves +kernels. -/ +private theorem exists_kernel_ι_whiskerLeft + [Category.{v} A] [MonoidalCategory A] [Abelian A] + [MonoidalPreadditive A] [RigidCategory A] + (W : A) {X Y : A} + (p : X ⟶ Y) : + ∃ e : kernel (W ◁ p) ⟶ W ⊗ kernel p, + kernel.ι (W ◁ p) = e ≫ (W ◁ kernel.ι p) := by + have : PreservesLimitsOfSize.{0, 0} (tensorLeft W) := + preservesSmallestLimits_of_preservesLimits _ + exact ⟨(PreservesKernel.iso (tensorLeft W) p).inv, + (PreservesKernel.iso_inv_ι (tensorLeft W) p).symm⟩ + +/-- A subobject factoring the whiskered kernel arrow factors the +kernel arrow of the right-whiskered morphism. -/ +theorem factors_kernel_ι_whiskerRight + [Category.{v} A] [MonoidalCategory A] [Abelian A] + [MonoidalPreadditive A] [RigidCategory A] + {X Y : A} (p : X ⟶ Y) {W : A} + {S : Subobject (X ⊗ W)} (h : S.Factors (kernel.ι p ▷ W)) : + S.Factors (kernel.ι (p ▷ W)) := by + obtain ⟨e, he⟩ := exists_kernel_ι_whiskerRight p W + rw [he] + exact Subobject.factors_of_factors_right e h + +/-- A subobject factoring the whiskered kernel arrow factors the +kernel arrow of the left-whiskered morphism. -/ +theorem factors_kernel_ι_whiskerLeft + [Category.{v} A] [MonoidalCategory A] [Abelian A] + [MonoidalPreadditive A] [RigidCategory A] + {W X Y : A} (p : X ⟶ Y) + {S : Subobject (W ⊗ X)} (h : S.Factors (W ◁ kernel.ι p)) : + S.Factors (kernel.ι (W ◁ p)) := by + obtain ⟨e, he⟩ := exists_kernel_ι_whiskerLeft W p + rw [he] + exact Subobject.factors_of_factors_right e h + +/-- **The kernel of a right-whiskered morphism** is covered by the +image of the whiskered kernel arrow. -/ +theorem kernelSubobject_whiskerRight_le + [Category.{v} A] [MonoidalCategory A] [Abelian A] + [MonoidalPreadditive A] [RigidCategory A] + {X Y : A} (p : X ⟶ Y) + (W : A) : + kernelSubobject (p ▷ W) ≤ imageSubobject (kernel.ι p ▷ W) := + kernelSubobject_le_of_factors + (factors_kernel_ι_whiskerRight p + (factors_self_imageSubobject _)) + +/-- Factoring through an image is stable under right whiskering. -/ +theorem factors_imageSubobject_whiskerRight + [Category.{v} A] [MonoidalCategory A] [Abelian A] [RigidCategory A] + {X B C' : A} + {f : X ⟶ B} {c : C' ⟶ B} + (h : (imageSubobject c).Factors f) (W : A) : + (imageSubobject (c ▷ W)).Factors (f ▷ W) := by + have : Epi (factorThruImageSubobject c ▷ W) := + epi_whiskerRight_of_epi (factorThruImageSubobject c) W + have harrow : (imageSubobject (c ▷ W)).Factors + ((imageSubobject c).arrow ▷ W) := by + refine factors_of_epi_comp _ + (factorThruImageSubobject c ▷ W) _ ?_ + have hc : (factorThruImageSubobject c ▷ W) ≫ + ((imageSubobject c).arrow ▷ W) = c ▷ W := by + rw [← MonoidalCategory.comp_whiskerRight, + imageSubobject_arrow_comp] + rw [hc] + exact factors_self_imageSubobject _ + have hf : f ▷ W = + ((imageSubobject c).factorThru f h ▷ W) ≫ + ((imageSubobject c).arrow ▷ W) := by + rw [← MonoidalCategory.comp_whiskerRight, + Subobject.factorThru_arrow] + rw [hf] + exact Subobject.factors_of_factors_right _ harrow + +/-- Factoring through an image is stable under left whiskering. -/ +theorem factors_imageSubobject_whiskerLeft + [Category.{v} A] [MonoidalCategory A] [Abelian A] [RigidCategory A] + {X B C' : A} + {f : X ⟶ B} {c : C' ⟶ B} + (h : (imageSubobject c).Factors f) (W : A) : + (imageSubobject (W ◁ c)).Factors (W ◁ f) := by + have : Epi (W ◁ factorThruImageSubobject c) := + epi_whiskerLeft_of_epi W (factorThruImageSubobject c) + have harrow : (imageSubobject (W ◁ c)).Factors + (W ◁ (imageSubobject c).arrow) := by + refine factors_of_epi_comp _ + (W ◁ factorThruImageSubobject c) _ ?_ + have hc : (W ◁ factorThruImageSubobject c) ≫ + (W ◁ (imageSubobject c).arrow) = W ◁ c := by + rw [← MonoidalCategory.whiskerLeft_comp, + imageSubobject_arrow_comp] + rw [hc] + exact factors_self_imageSubobject _ + have hf : W ◁ f = + (W ◁ (imageSubobject c).factorThru f h) ≫ + (W ◁ (imageSubobject c).arrow) := by + rw [← MonoidalCategory.whiskerLeft_comp, + Subobject.factorThru_arrow] + rw [hf] + exact Subobject.factors_of_factors_right _ harrow + +/-! ## The two-factor kernel -/ + +/-- **The kernel of a tensor product of an epimorphism and a +morphism** is covered by the two one-slot kernel insertions: the +whiskered kernels of the factors. The route is the factorisation +`p₁ ⊗ₘ p₂ = (p₁ ▷ Z₂) ≫ (W₁ ◁ p₂)`: the kernel of the second +factor is covered by the image of `Z₁ ◁ kernel.ι p₂` under the +first — the whisker exchange against the epimorphism +`p₁ ▷ kernel p₂` — and the composite-kernel chase concludes. -/ +theorem kernelSubobject_tensorHom_le + [Category.{v} A] [MonoidalCategory A] [Abelian A] + [MonoidalPreadditive A] [RigidCategory A] + {Z₁ W₁ Z₂ W₂ : A} + (p₁ : Z₁ ⟶ W₁) (p₂ : Z₂ ⟶ W₂) [Epi p₁] : + kernelSubobject (p₁ ⊗ₘ p₂) ≤ + imageSubobject (kernel.ι p₁ ▷ Z₂) ⊔ + imageSubobject (Z₁ ◁ kernel.ι p₂) := by + have hv : kernelSubobject (W₁ ◁ p₂) ≤ + imageSubobject ((Z₁ ◁ kernel.ι p₂) ≫ (p₁ ▷ Z₂)) := by + have : Epi (p₁ ▷ kernel p₂) := epi_whiskerRight_of_epi p₁ _ + refine kernelSubobject_le_of_factors + (factors_kernel_ι_whiskerLeft p₂ + (factors_of_epi_comp _ (p₁ ▷ kernel p₂) _ ?_)) + rw [← whisker_exchange p₁ (kernel.ι p₂)] + exact factors_self_imageSubobject _ + calc kernelSubobject (p₁ ⊗ₘ p₂) + = kernelSubobject ((p₁ ▷ Z₂) ≫ (W₁ ◁ p₂)) := + kernelSubobject_congr (MonoidalCategory.tensorHom_def p₁ p₂) + _ ≤ kernelSubobject (p₁ ▷ Z₂) ⊔ + imageSubobject (Z₁ ◁ kernel.ι p₂) := + kernelSubobject_comp_le_of_cover (p₁ ▷ Z₂) (W₁ ◁ p₂) + (Z₁ ◁ kernel.ι p₂) hv + _ ≤ imageSubobject (kernel.ι p₁ ▷ Z₂) ⊔ + imageSubobject (Z₁ ◁ kernel.ι p₂) := + sup_le_sup_right (kernelSubobject_whiskerRight_le p₁ Z₂) _ + +/-- The two one-slot kernel insertions land in the kernel of the +tensor product; no epimorphism hypothesis is needed. -/ +theorem sup_le_kernelSubobject_tensorHom + [Category.{v} A] [MonoidalCategory A] [Abelian A] + [MonoidalPreadditive A] + {Z₁ W₁ Z₂ W₂ : A} + (p₁ : Z₁ ⟶ W₁) (p₂ : Z₂ ⟶ W₂) : + imageSubobject (kernel.ι p₁ ▷ Z₂) ⊔ + imageSubobject (Z₁ ◁ kernel.ι p₂) ≤ + kernelSubobject (p₁ ⊗ₘ p₂) := by + refine sup_le + (imageSubobject_le_of_factors + (kernelSubobject_factors _ _ ?_)) + (imageSubobject_le_of_factors + (kernelSubobject_factors _ _ ?_)) + · rw [MonoidalCategory.tensorHom_def, ← Category.assoc, + ← MonoidalCategory.comp_whiskerRight, kernel.condition, + MonoidalPreadditive.zero_whiskerRight, zero_comp] + · rw [MonoidalCategory.tensorHom_def', ← Category.assoc, + ← MonoidalCategory.whiskerLeft_comp, kernel.condition, + MonoidalPreadditive.whiskerLeft_zero, zero_comp] + +/-- **The kernel of a tensor product of an epimorphism and a +morphism**, exactly: it is the join of the images of the two +one-slot kernel insertions. -/ +theorem kernelSubobject_tensorHom + [Category.{v} A] [MonoidalCategory A] [Abelian A] + [MonoidalPreadditive A] [RigidCategory A] + {Z₁ W₁ Z₂ W₂ : A} + (p₁ : Z₁ ⟶ W₁) (p₂ : Z₂ ⟶ W₂) [Epi p₁] : + kernelSubobject (p₁ ⊗ₘ p₂) = + imageSubobject (kernel.ι p₁ ▷ Z₂) ⊔ + imageSubobject (Z₁ ◁ kernel.ι p₂) := + le_antisymm (kernelSubobject_tensorHom_le p₁ p₂) + (sup_le_kernelSubobject_tensorHom p₁ p₂) + +/-! ## The iterated kernel + +The kernel of `π ^ ⊗ m` is covered by the one-slot insertions: the +word maps of `ι` and `𝟙 Z` at words with exactly one `true` +letter. The induction along +`tensorPowMap π (m + 1) = tensorPowMap π m ⊗ₘ π` transports the +inductive cover through the tensor structure, so the cover is kept +as a single morphism out of the biproduct of the one-slot word +powers (`oneSlotCover`); the `Finset.sup` phrasing is recovered at +the end. +-/ + +attribute [local instance] Abelian.hasFiniteBiproducts + +/-- **The one-slot cover**: the fold of all word maps of `ι` and +`𝟙 Z` with exactly one `ι`-slot, out of the biproduct of their +word powers. -/ +noncomputable def oneSlotCover [Category.{v} A] [MonoidalCategory A] [Abelian A] + {U Z : A} (ι : U ⟶ Z) (m : ℕ) : + (⨁ fun w : {w : Fin m → Bool // popCount w = 1} => + wordPow U Z m w.1) ⟶ tensorPow A Z m := + biproduct.desc fun w => wordMap ι (𝟙 Z) m w.1 + +/-- Each one-slot word map factors through the cover's image. -/ +private theorem factors_oneSlotCover + [Category.{v} A] [MonoidalCategory A] [Abelian A] + {U Z : A} (ι : U ⟶ Z) (m : ℕ) + (w : Fin m → Bool) (hw : popCount w = 1) : + (imageSubobject (oneSlotCover ι m)).Factors + (wordMap ι (𝟙 Z) m w) := by + have h : wordMap ι (𝟙 Z) m w = + biproduct.ι + (fun w' : {w' : Fin m → Bool // popCount w' = 1} => + wordPow U Z m w'.1) ⟨w, hw⟩ ≫ oneSlotCover ι m := by + unfold oneSlotCover + rw [biproduct.ι_desc] + rw [h] + exact Subobject.factors_of_factors_right _ + (factors_self_imageSubobject _) + +/-- The cover, decomposed as the sum of its word-map summands. -/ +private theorem oneSlotCover_eq_sum + [Category.{v} A] [MonoidalCategory A] [Abelian A] + {U Z : A} (ι : U ⟶ Z) (m : ℕ) : + oneSlotCover ι m = + ∑ w : {w : Fin m → Bool // popCount w = 1}, + biproduct.π + (fun w' : {w' : Fin m → Bool // popCount w' = 1} => + wordPow U Z m w'.1) w ≫ wordMap ι (𝟙 Z) m w.1 := by + calc oneSlotCover ι m + = 𝟙 _ ≫ oneSlotCover ι m := (Category.id_comp _).symm + _ = (∑ w : {w : Fin m → Bool // popCount w = 1}, + biproduct.π _ w ≫ biproduct.ι _ w) ≫ oneSlotCover ι m := by + rw [biproduct.total] + _ = ∑ w : {w : Fin m → Bool // popCount w = 1}, + (biproduct.π _ w ≫ biproduct.ι _ w) ≫ oneSlotCover ι m := + Preadditive.sum_comp _ _ _ + _ = ∑ w : {w : Fin m → Bool // popCount w = 1}, + biproduct.π _ w ≫ wordMap ι (𝟙 Z) m w.1 := + Finset.sum_congr rfl fun w _ => by + rw [Category.assoc] + exact congrArg (biproduct.π _ w ≫ ·) (biproduct.ι_desc _ _) + +/-- Factoring through a subobject is closed under finite sums. -/ +private theorem factors_sum [Category.{v} A] [Abelian A] + {X B : A} {S : Subobject B} + {J : Type*} [Fintype J] (g : J → (X ⟶ B)) + (h : ∀ j, S.Factors (g j)) : S.Factors (∑ j, g j) := + Finset.sum_induction g S.Factors + (fun a b ha hb => Subobject.factors_add a b ha hb) + Subobject.factors_zero (fun j _ => h j) + +/-- A morphism equal to a cast composed with a decomposition of a +given morphism. Stated at general objects and applied by `exact`, +so the defeq-mismatched arities never enter a rewrite. -/ +private theorem eq_cast_comp_of [Category.{v} A] + {N W R : A} (h : N = W) + (h' : W = N) (D : N ⟶ R) (E : W ⟶ R) + (hD : D = eqToHom h ≫ E) : E = eqToHom h' ≫ D := by + subst h + rw [hD, show h' = rfl from rfl, eqToHom_refl, Category.id_comp, + Category.id_comp] + +/-- The right-whiskered cover factors through the next cover: a +`false` letter joins each word on top, preserving its letter +count. -/ +private theorem factors_oneSlotCover_whiskerRight + [Category.{v} A] [MonoidalCategory A] [Abelian A] + [MonoidalPreadditive A] + {U Z : A} + (ι : U ⟶ Z) (m : ℕ) : + (imageSubobject (oneSlotCover ι (m + 1))).Factors + (oneSlotCover ι m ▷ Z) := by + rw [oneSlotCover_eq_sum ι m, sum_whiskerRight] + refine factors_sum _ fun w => ?_ + rw [MonoidalCategory.comp_whiskerRight] + refine Subobject.factors_of_factors_right _ ?_ + have hbase : (imageSubobject (oneSlotCover ι (m + 1))).Factors + (wordMap ι (𝟙 Z) (m + 1) (Fin.snoc w.1 false)) := by + refine factors_oneSlotCover ι (m + 1) _ ?_ + rw [popCount_snoc, w.2] + rfl + have hE : (wordMap ι (𝟙 Z) m w.1 ⊗ₘ 𝟙 Z) = + eqToHom (wordPow_snoc_false U Z m w.1).symm ≫ + wordMap ι (𝟙 Z) (m + 1) (Fin.snoc w.1 false) := + eq_cast_comp_of (wordPow_snoc_false U Z m w.1) + (wordPow_snoc_false U Z m w.1).symm _ _ + (wordMap_snoc_false ι (𝟙 Z) m w.1) + rw [← MonoidalCategory.tensorHom_id, hE] + exact Subobject.factors_of_factors_right _ hbase + +/-- The base insertion `Z ^ ⊗ m ◁ ι` factors through the next +cover: it is the word map of the all-`false` word with one `true` +letter on top. -/ +private theorem factors_whiskerLeft_iota + [Category.{v} A] [MonoidalCategory A] [Abelian A] + {U Z : A} (ι : U ⟶ Z) + (m : ℕ) : + (imageSubobject (oneSlotCover ι (m + 1))).Factors + (tensorPow A Z m ◁ ι) := by + have hbase : (imageSubobject (oneSlotCover ι (m + 1))).Factors + (wordMap ι (𝟙 Z) (m + 1) + (Fin.snoc (fun _ : Fin m => false) true)) := by + refine factors_oneSlotCover ι (m + 1) _ ?_ + rw [popCount_snoc, popCount_const_false] + rfl + have hM : wordMap ι (𝟙 Z) m (fun _ => false) = + eqToHom (wordPow_const_false U Z m) := by + rw [wordMap_const_false, tensorPowMap_id, Category.comp_id] + have hE : (wordMap ι (𝟙 Z) m (fun _ => false) ⊗ₘ ι) = + eqToHom (wordPow_snoc_true U Z m (fun _ => false)).symm ≫ + wordMap ι (𝟙 Z) (m + 1) + (Fin.snoc (fun _ : Fin m => false) true) := + eq_cast_comp_of (wordPow_snoc_true U Z m (fun _ => false)) + (wordPow_snoc_true U Z m (fun _ => false)).symm _ _ + (wordMap_snoc_true ι (𝟙 Z) m (fun _ => false)) + have hwhisk : tensorPow A Z m ◁ ι = + eqToHom (congrArg (· ⊗ U) (wordPow_const_false U Z m).symm) ≫ + (wordMap ι (𝟙 Z) m (fun _ => false) ⊗ₘ ι) := by + rw [hM] + exact + (cast_tensor_to_whiskerLeft (wordPow_const_false U Z m) _ ι).symm + rw [hwhisk, hE] + exact Subobject.factors_of_factors_right _ + (Subobject.factors_of_factors_right _ hbase) + +/-- **The kernel of a tensor power of an epimorphism, cover +form**: if `ι` covers the kernel of the epimorphism `π`, then the +kernel of `π ^ ⊗ m` is covered by the image of the one-slot +cover. -/ +theorem kernelSubobject_tensorPowMap_le_cover + [Category.{v} A] [MonoidalCategory A] [Abelian A] + [MonoidalPreadditive A] [RigidCategory A] + {U Z W : A} + (ι : U ⟶ Z) (π : Z ⟶ W) [Epi π] + (hker : kernelSubobject π ≤ imageSubobject ι) : + ∀ m : ℕ, kernelSubobject (tensorPowMap π m) ≤ + imageSubobject (oneSlotCover ι m) := by + intro m + induction m with + | zero => + refine kernelSubobject_le_of_factors ?_ + have h : kernel.ι (tensorPowMap π 0) = 0 := by + rw [← Category.comp_id (kernel.ι (tensorPowMap π 0))] + exact kernel.condition (tensorPowMap π 0) + rw [h] + exact Subobject.factors_zero + | succ m ih => + have : Epi (tensorPowMap π m) := tensorPowMap_epi π m + refine le_trans + (kernelSubobject_tensorHom_le (tensorPowMap π m) π) + (sup_le ?_ ?_) + · exact imageSubobject_le_of_factors + (Subobject.factors_of_le _ + (imageSubobject_le_of_factors + (factors_oneSlotCover_whiskerRight ι m)) + (factors_imageSubobject_whiskerRight + (factors_kernel_ι_of_le ih) Z)) + · exact imageSubobject_le_of_factors + (Subobject.factors_of_le _ + (imageSubobject_le_of_factors (factors_whiskerLeft_iota ι m)) + (factors_imageSubobject_whiskerLeft + (factors_kernel_ι_of_le hker) (tensorPow A Z m))) + +/-- **The kernel of a tensor power of an epimorphism**: if `ι` +covers the kernel of the epimorphism `π : Z ⟶ W`, the kernel of +`π ^ ⊗ m` is covered by the join of the images of the word maps of +`ι` and `𝟙 Z` over the words with exactly one `ι`-slot. The join +is a `Finset.sup`: without well-poweredness the subobject lattice +carries finite joins, and the index is the finite set of one-slot +words. -/ +theorem kernelSubobject_tensorPowMap_le + [Category.{v} A] [MonoidalCategory A] [Abelian A] + [MonoidalPreadditive A] [RigidCategory A] + {U Z W : A} + (ι : U ⟶ Z) (π : Z ⟶ W) [Epi π] + (hker : kernelSubobject π ≤ imageSubobject ι) (m : ℕ) : + kernelSubobject (tensorPowMap π m) ≤ + ((Finset.univ.filter + fun w : Fin m → Bool => popCount w = 1).sup + fun w => imageSubobject (wordMap ι (𝟙 Z) m w)) := by + refine le_trans (kernelSubobject_tensorPowMap_le_cover ι π hker m) + (imageSubobject_le_of_factors ?_) + rw [oneSlotCover_eq_sum] + refine factors_sum _ fun w => ?_ + refine Subobject.factors_of_factors_right _ ?_ + refine Subobject.finset_sup_factors ⟨w.1, ?_, ?_⟩ + · exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, w.2⟩ + · exact factors_self_imageSubobject _ + +end WhiskerKernel + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemma.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemma.lean new file mode 100644 index 0000000000..9517bc5762 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemma.lean @@ -0,0 +1,190 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymMul +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModContractL +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainUnit + +/-! +# The Key Lemma: the universal splitting algebra + +Deligne 2.8, the consumed direction: for a dualizable module over +a commutative algebra whose symmetric powers do not vanish, there +is a nonzero algebra over which the module acquires the unit as a +direct factor. The construction is the colimit of the chain of +paired symmetric powers, with copair-insertion transitions; its +nonvanishing is stage detection for the unit, and the splitting +pair is built from the tautological pairing against the +multiplication. + +The duality of the module is Mod-internal: the pairing and +copairing are given as data with zigzag identities stated at the +multi-tensor level, where the wide-coequalizer presentation makes +them associativity-free. + +## The form of the conclusion + +The conclusion is in element form: a nonzero commutative +algebra `B` under `A` together with a global point of +`modTensor A M' M ⊗ B` on which the pairing evaluates to the unit +of `B`. This is the section-of-the-evaluation reading of the +splitting: the point is exactly the datum needed to produce a +`B`-linear section of the base-changed evaluation by +multiplication. A direct splitting of the unit off `M_B` itself +is not the right reading: counting `M`-letters minus `M'`-letters +grades every morphism constructible from a duality datum, and +`M_B` sits in degree one while `B` sits in degree zero, so no +constructible morphism connects them. The degree-zero object +`modTensor A M' M ⊗ B` is where the splitting genuinely lives. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +section Datum + +/-- A Mod-internal duality datum for a pair of modules over a +monoid object: a descended `A`-valued pairing and a copairing +into the relative tensor, each a module map. The zigzag +identities live one level up, through the multi-tensor insertion +and contraction constructors, and are packaged separately as +`ModZigzagDatum`. -/ +structure ModDualityDatum + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Limits.HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] (M M' : Mod D A) + [∀ Z : D, Limits.PreservesColimitsOfShape + Limits.WalkingParallelPair (tensorLeft Z)] where + /-- The descended `A`-valued pairing on the relative tensor. -/ + pair : modTensor A M' M ⟶ A + /-- The copairing into the relative tensor. -/ + copair : A ⟶ modTensor A M M' + /-- The pairing is a module map for the descended action and + the regular action. -/ + pair_linear : + haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ pair = + (A ◁ pair) ≫ μ[A] + /-- The copairing is a module map for the regular action and + the descended action. -/ + copair_linear : + haveI := modTensorModObj A M M' + μ[A] ≫ copair = + (A ◁ copair) ≫ actLeft A (modTensor A M M') + +end Datum + +section Bundles + +/-- The pairing of a duality datum, as a module map into the +regular module. -/ +noncomputable def ModDualityDatum.pairMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Limits.HasCoequalizers D] + [∀ Z : D, Limits.PreservesColimitsOfShape Limits.WalkingParallelPair + (tensorLeft Z)] (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} + {M' : Mod D A} + (d : ModDualityDatum A M M') : + modTensorMod A M' M ⟶ regularMod A := + Mod.Hom.mk' d.pair d.pair_linear + +/-- The copairing of a duality datum, as a module map from the +regular module. -/ +noncomputable def ModDualityDatum.copairMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Limits.HasCoequalizers D] + [∀ Z : D, Limits.PreservesColimitsOfShape Limits.WalkingParallelPair + (tensorLeft Z)] (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} + {M' : Mod D A} + (d : ModDualityDatum A M M') : + regularMod A ⟶ modTensorMod A M M' := + Mod.Hom.mk' d.copair d.copair_linear + +end Bundles + +section Zigzag + +/-- **The zigzag laws of a duality datum.** Both triangle +identities, stated through the multi-tensor insertion and +contraction constructors: inserting the copairing and contracting +the pairing across the original factor is the identity, on each +side. These are the dimension-free dualizability +conditions: the inserted `M'` is contracted against the original +`M` (and mirrored), never against its own partner — the latter +composite is the categorical dimension and carries no +information about dualizability. -/ +structure ModZigzagDatum + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] + {M M' : Mod D A} + (d : ModDualityDatum A M M') : Prop where + /-- The zig triangle: insert on the left, contract the + trailing cross pair, on the single-factor multi-tensor + at `M`. -/ + zig : zigComposite A d.copair d.pair d.pair_linear = + 𝟙 (modMulti A [M]) + /-- The zag triangle: insert on the right, contract the + leading cross pair, on the single-factor multi-tensor + at `M'`. -/ + zag : zagComposite A d.copair d.pair d.pair_linear = + 𝟙 (modMulti A [M']) + +/-- **The conclusion of the Key Lemma** (Deligne 2.8), packaged +for the 2.9 consumer: a commutative algebra `B` under `A`, +nonzero in the unit-detection sense, together with a global +point of `modTensor A M' M ⊗ B` on which the base-changed +evaluation returns the unit of `B`. Multiplication by the point +produces a `B`-linear section of the evaluation, so the unit of +`B` splits off the base change of `modTensor A M' M`. -/ +structure SplittingAlgebra + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] + {M M' : Mod D A} + (d : ModDualityDatum A M M') where + /-- The underlying object of the splitting algebra. -/ + carrier : D + /-- The monoid structure. -/ + monObj : MonObj carrier + /-- Commutativity. -/ + comm : letI := monObj; IsCommMonObj carrier + /-- The structure morphism from the base algebra. -/ + ofBase : A ⟶ carrier + /-- The structure morphism is a monoid map. -/ + ofBase_monHom : letI := monObj; IsMonHom ofBase + /-- The algebra is nonzero: its unit does not vanish. -/ + unit_ne_zero : letI := monObj; η[carrier] ≠ 0 + /-- The splitting point: a global element of the pairing's + source, base-changed to the algebra. -/ + point : 𝟙_ D ⟶ modTensor A M' M ⊗ carrier + /-- The pairing evaluates the point to the unit of the + algebra: the section identity. -/ + point_eval : letI := monObj; + point ≫ (d.pair ▷ carrier) ≫ (ofBase ▷ carrier) ≫ + μ[carrier] = η[carrier] + +end Zigzag + +section Statement + +end Statement + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemmaClose.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemmaClose.lean new file mode 100644 index 0000000000..1513a90d66 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemmaClose.lean @@ -0,0 +1,91 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaData +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitMonHom +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitPairDef +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBNonzero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndAllColim + +/-! +# The Key Lemma, closed over the ind-completion + +The splitting data of Deligne's Key Lemma (2.8), assembled from +the graded splitting algebra: the carrier is the ℤ-graded +chain algebra, the base enters in degree zero, the module and its +dual in degrees `±1`, the pair product two stages up the +degree-zero line, and the section identity is the advancement of +the seed. Nonvanishing is the stage-detection argument of the +balanced line. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v + +variable {C : Type v} + +/-- Tensoring preserves integer-indexed coproducts in the +ind-category, by transport from the universe-sized discrete +shape. -/ +instance tensorLeft_ind_preservesShapeInt + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + (X : Ind C) : + PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X) := + preservesColimitsOfShape_of_equiv + (Discrete.equivalence Equiv.ulift.{v}) _ + +/-- Tensoring preserves integer-indexed coproducts in the +ind-category, right-hand version. -/ +instance tensorRight_ind_preservesShapeInt + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + (X : Ind C) : + PreservesColimitsOfShape (Discrete ℤ) (tensorRight X) := + preservesColimitsOfShape_of_equiv + (Discrete.equivalence Equiv.ulift.{v}) _ + +/-- **The Key Lemma** (Deligne 2.8) over the ind-completion: a +duality datum with the zigzag laws, over a base whose symmetric +powers of the module never vanish, admits splitting data — the +graded splitting algebra with its degree-`±1` insertions. -/ +theorem keyLemmaData_ind + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + [CategoryTheory.Linear ℂ (Ind C)] [MonoidalLinear ℂ (Ind C)] (B : Ind C) + [MonObj B] [IsCommMonObj B] (N : Mod (Ind C) B) (N' : Mod (Ind C) B) + (d : ModDualityDatum B N N') : + KeyLemmaDataStatement B d := by + intro hz _ hS + let := chainBGrMonObj B N N' d + exact ⟨{ carrier := chainBGr B N N' d + monObj := chainBGrMonObj B N N' d + comm := chainBGr_isCommMonObj B N N' d + ofBase := splitOfBase B N N' d + ofBase_monHom := + ⟨splitOfBase_unit B N N' d, + splitOfBase_mul B N N' d⟩ + unit_ne_zero := chainBGrUnit_ne_zero B N N' d + (chainBUnit_ne_zero B N N' d hz + fun n => hS (n + 1)) + ins := splitIns B N N' d + ins' := splitIns' B N N' d + ins_linear := splitIns_linear B N N' d + ins'_linear := splitIns'_linear B N N' d + pairMul := splitPairMul B N N' d + pairMul_def := modTensorπ_splitPairMul B N N' d + delta_eq := Eq.trans (Category.assoc _ _ _).symm + (copairUnit_splitPairMul B N N' d) }⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemmaData.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemmaData.lean new file mode 100644 index 0000000000..fdba36126e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemmaData.lean @@ -0,0 +1,121 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma + +/-! +# The Key Lemma conclusion, in Deligne's insertion form + +The conclusion of record for Deligne 2.8, per the source: a +nonzero commutative algebra under the base together with module +insertions of the module and its dual, multiplying the copair +element to the unit. This is the data from which the direct +factor `1_B ∣ M_B` is rebuilt by the algebra structure (the +consumer's reconstruction), stated without any base-changed +module category. + +The earlier element form (`SplittingAlgebra` in `KeyLemma.lean`) +is superseded: it does not retain the individual insertions that +the 2.9 dévissage consumes. The witness algebra is the full +ℤ-graded splitting algebra, of which the balanced chain `chainB` +is the degree-zero part — the unit lives in degree zero, so the +nonvanishing argument is unaffected; the insertions live in +degrees `±1`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +section Data + +/-- **The conclusion of the Key Lemma** (Deligne 2.8), in the +insertion form of the source: a commutative algebra `B` under +`A`, nonzero in the unit-detection sense, with module insertions +`v` of `M` and `u` of `M'` whose product carries the copair +element to the unit of `B`. The insertions are linear over the +base through the structure morphism, and their product on the +relative tensor is packaged as the descended map `pairMul` with +its defining equation. -/ +structure SplittingData + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] + {M M' : Mod D A} + (d : ModDualityDatum A M M') where + /-- The underlying object of the splitting algebra. -/ + carrier : D + /-- The monoid structure. -/ + monObj : MonObj carrier + /-- Commutativity. -/ + comm : letI := monObj; IsCommMonObj carrier + /-- The structure morphism from the base algebra. -/ + ofBase : A ⟶ carrier + /-- The structure morphism is a monoid map. -/ + ofBase_monHom : letI := monObj; IsMonHom ofBase + /-- The algebra is nonzero: its unit does not vanish. -/ + unit_ne_zero : letI := monObj; η[carrier] ≠ 0 + /-- The insertion of the module. -/ + ins : M.X ⟶ carrier + /-- The insertion of the dual module. -/ + ins' : M'.X ⟶ carrier + /-- The insertion of the module is linear over the base, + through the structure morphism. -/ + ins_linear : letI := monObj; + actLeft A M.X ≫ ins = + (A ◁ ins) ≫ (ofBase ▷ carrier) ≫ μ[carrier] + /-- The insertion of the dual module is linear over the base, + through the structure morphism. -/ + ins'_linear : letI := monObj; + actLeft A M'.X ≫ ins' = + (A ◁ ins') ≫ (ofBase ▷ carrier) ≫ μ[carrier] + /-- The product of the insertions, descended to the relative + tensor. -/ + pairMul : modTensor A M M' ⟶ carrier + /-- Defining equation of the descended product of the + insertions. -/ + pairMul_def : letI := monObj; + modTensorπ A M M' ≫ pairMul = + (ins ⊗ₘ ins') ≫ μ[carrier] + /-- **The section identity**: the product of the insertions + carries the copair element to the unit. -/ + delta_eq : letI := monObj; + η[A] ≫ d.copair ≫ pairMul = η[carrier] + +end Data + +section Statement + +/-- **The Key Lemma statement of record** (Deligne 2.8, the +consumed direction): a duality datum with the zigzag laws, over +a nonzero base whose symmetric powers of the module never +vanish, admits splitting data. -/ +def KeyLemmaDataStatement + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [CategoryTheory.Linear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] + {M M' : Mod D A} + (d : ModDualityDatum A M M') : Prop := + ModZigzagDatum A d → η[A] ≠ 0 → + (∀ n : ℕ, ¬ Limits.IsZero (symPow A M.X n)) → + Nonempty (SplittingData A d) + +end Statement + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KillerNonempty.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KillerNonempty.lean new file mode 100644 index 0000000000..d8261defb8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KillerNonempty.lean @@ -0,0 +1,58 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing + +/-! +# Upgrading a killing diagram to a nonempty one + +Schur vanishing is upward closed, and the empty diagram is below +every diagram, so a killed object is killed at some diagram with +at least one cell. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +variable {A : Type u} + +/-- A diagram with no cells is the empty diagram. -/ +theorem YoungDiagram.eq_bot_of_card_eq_zero {lam : YoungDiagram} + (h : lam.card = 0) : lam = ⊥ := by + ext c + constructor + · intro hc + exact absurd (Finset.card_eq_zero.mp h ▸ hc) + (Finset.notMem_empty c) + · intro hc + exact absurd hc (Finset.notMem_empty c) + +/-- **A killed object is killed at a nonempty diagram.** -/ +theorem exists_killer_card_ne_zero + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] + (P : SchurPackage.{v}) {X : A} + {lam : YoungDiagram} (h : SchurKilled P X lam) : + ∃ mu : YoungDiagram, mu.card ≠ 0 ∧ SchurKilled P X mu := by + by_cases hc : lam.card = 0 + · refine ⟨(rowShape 1).val, ?_, ?_⟩ + · rw [(rowShape 1).prop] + exact one_ne_zero + · refine SchurKilled.mono P ?_ h + rw [YoungDiagram.eq_bot_of_card_eq_zero hc] + exact bot_le + · exact ⟨lam, hc, h⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KronKill.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KronKill.lean new file mode 100644 index 0000000000..5d69585d31 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KronKill.lean @@ -0,0 +1,409 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndKill + +/-! +# The Kronecker kill: diagonal products die with their multiplicity + +In the group algebra of the product group `S_n × S_n`, the external +product of two recast Shape idempotents times the diagonal image of +a third is an idempotent whose coefficient at the identity is a +positive multiple of the Kronecker multiplicity `[λ : μ ⊗ ν]`. An +idempotent of a finite group algebra over ℂ vanishes exactly when +its identity coefficient does, so the product is zero as soon as +the multiplicity is. This mirrors the induction kill of +`RS.Classical.Deligne.IndKill`, with the block embedding replaced +by the two external embeddings and the diagonal. +-/ + +@[expose] public section + +namespace RS + +open Finset + +private theorem ma_add_apply {G : Type*} (f g : MonoidAlgebra ℂ G) + (x : G) : (f + g).coeff x = f.coeff x + g.coeff x := rfl + +private theorem ma_smul_apply {G : Type*} (r : ℂ) + (f : MonoidAlgebra ℂ G) (x : G) : (r • f).coeff x = r * f.coeff x := rfl + +universe u + +/-- The first-factor embedding of `S_n` into `S_n × S_n`. -/ +noncomputable def extFstHom (n : ℕ) : + Equiv.Perm (Fin n) →* + Equiv.Perm (Fin n) × Equiv.Perm (Fin n) where + toFun σ := (σ, 1) + map_one' := rfl + map_mul' σ σ' := by rw [Prod.mk_mul_mk, one_mul] + +/-- The second-factor embedding of `S_n` into `S_n × S_n`. -/ +noncomputable def extSndHom (n : ℕ) : + Equiv.Perm (Fin n) →* + Equiv.Perm (Fin n) × Equiv.Perm (Fin n) where + toFun τ := (1, τ) + map_one' := rfl + map_mul' τ τ' := by rw [Prod.mk_mul_mk, one_mul] + +/-- The diagonal embedding of `S_n` into `S_n × S_n`. -/ +noncomputable def diagHom (n : ℕ) : + Equiv.Perm (Fin n) →* + Equiv.Perm (Fin n) × Equiv.Perm (Fin n) where + toFun σ := (σ, σ) + map_one' := rfl + map_mul' σ σ' := by rw [Prod.mk_mul_mk] + +/-- **The external product**: the product of the two one-sided +images of a pair of group-algebra elements in the group algebra of +`S_n × S_n`. -/ +noncomputable def extProd {n : ℕ} (x y : SymGroupAlgebra n) : + MonoidAlgebra ℂ (Equiv.Perm (Fin n) × Equiv.Perm (Fin n)) := + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extFstHom n) x * + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extSndHom n) y + +/-- **The diagonal embedding of group algebras**: extension of the +diagonal along `mapDomain`, an algebra homomorphism. -/ +noncomputable def diagEmbed {n : ℕ} : + SymGroupAlgebra n →ₐ[ℂ] + MonoidAlgebra ℂ (Equiv.Perm (Fin n) × Equiv.Perm (Fin n)) := + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (diagHom n) + +/-- On basis permutations the external product is the single at the +pair. -/ +theorem extProd_single {n : ℕ} (σ τ : Equiv.Perm (Fin n)) + (c d : ℂ) : + extProd (MonoidAlgebra.single σ c) (MonoidAlgebra.single τ d) = + MonoidAlgebra.single (σ, τ) (c * d) := by + have hL : MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extFstHom n) + (MonoidAlgebra.single σ c) = + MonoidAlgebra.single + ((σ, 1) : Equiv.Perm (Fin n) × Equiv.Perm (Fin n)) c := by + change MonoidAlgebra.mapDomain _ (MonoidAlgebra.single σ c) = _ + exact MonoidAlgebra.mapDomain_single + have hR : MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extSndHom n) + (MonoidAlgebra.single τ d) = + MonoidAlgebra.single + ((1, τ) : Equiv.Perm (Fin n) × Equiv.Perm (Fin n)) d := by + change MonoidAlgebra.mapDomain _ (MonoidAlgebra.single τ d) = _ + exact MonoidAlgebra.mapDomain_single + unfold extProd + rw [hL, hR, MonoidAlgebra.single_mul_single] + congr 1 + +/-- The two external images commute elementwise. -/ +theorem extImages_comm {n : ℕ} (x y : SymGroupAlgebra n) : + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extFstHom n) x * + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extSndHom n) y = + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extSndHom n) y * + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extFstHom n) x := by + classical + induction x using MonoidAlgebra.induction_on with + | of σ => + induction y using MonoidAlgebra.induction_on with + | of τ => + have hL : MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extFstHom n) + (MonoidAlgebra.single σ 1) = + MonoidAlgebra.single + ((σ, 1) : Equiv.Perm (Fin n) × Equiv.Perm (Fin n)) + (1 : ℂ) := by + change MonoidAlgebra.mapDomain _ + (MonoidAlgebra.single σ 1) = _ + exact MonoidAlgebra.mapDomain_single + have hR : MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extSndHom n) + (MonoidAlgebra.single τ 1) = + MonoidAlgebra.single + ((1, τ) : Equiv.Perm (Fin n) × Equiv.Perm (Fin n)) + (1 : ℂ) := by + change MonoidAlgebra.mapDomain _ + (MonoidAlgebra.single τ 1) = _ + exact MonoidAlgebra.mapDomain_single + simp only [MonoidAlgebra.of_apply] + rw [hL, hR, MonoidAlgebra.single_mul_single, + MonoidAlgebra.single_mul_single] + congr 1 + | add y y' hy hy' => + rw [map_add, mul_add, add_mul, hy, hy'] + | smul r y hy => + rw [map_smul, mul_smul_comm, smul_mul_assoc, hy] + | add x x' hx hx' => + rw [map_add, add_mul, mul_add, hx, hx'] + | smul r x hx => + rw [map_smul, smul_mul_assoc, mul_smul_comm, hx] + +/-- The external product is multiplicative in the two slots +jointly. -/ +theorem extProd_mul_extProd {n : ℕ} + (x x' y y' : SymGroupAlgebra n) : + extProd x y * extProd x' y' = extProd (x * x') (y * y') := by + unfold extProd + rw [map_mul, map_mul] + calc MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extFstHom n) x * + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extSndHom n) y * + (MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extFstHom n) x' * + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extSndHom n) y') + = MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extFstHom n) x * + (MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extSndHom n) y * + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extFstHom n) x') * + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extSndHom n) y' := by + rw [mul_assoc, mul_assoc, mul_assoc] + _ = MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extFstHom n) x * + (MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extFstHom n) x' * + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extSndHom n) y) * + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extSndHom n) y' := by + rw [extImages_comm] + _ = _ := by + rw [mul_assoc, mul_assoc, mul_assoc] + +/-- The external product of Shape idempotents is idempotent. -/ +theorem extProd_shape_e_idem (P : SchurPackage.{u}) {n : ℕ} + (μ ν : Shape n) : + extProd (Shape.e P μ) (Shape.e P ν) * + extProd (Shape.e P μ) (Shape.e P ν) = + extProd (Shape.e P μ) (Shape.e P ν) := by + rw [extProd_mul_extProd, Shape.e_mul_self, Shape.e_mul_self] + +/-- The external product is additive in the first argument. -/ +theorem extProd_add_fst {n : ℕ} (x x' y : SymGroupAlgebra n) : + extProd (x + x') y = extProd x y + extProd x' y := by + unfold extProd + rw [map_add, add_mul] + +/-- The external product is homogeneous in the first argument. -/ +theorem extProd_smul_fst {n : ℕ} (r : ℂ) + (x y : SymGroupAlgebra n) : + extProd (r • x) y = r • extProd x y := by + unfold extProd + rw [map_smul, smul_mul_assoc] + +/-- The external product is additive in the second argument. -/ +theorem extProd_add_snd {n : ℕ} (x y y' : SymGroupAlgebra n) : + extProd x (y + y') = extProd x y + extProd x y' := by + unfold extProd + rw [map_add, mul_add] + +/-- The external product is homogeneous in the second argument. -/ +theorem extProd_smul_snd {n : ℕ} (r : ℂ) + (x y : SymGroupAlgebra n) : + extProd x (r • y) = r • extProd x y := by + unfold extProd + rw [map_smul, mul_smul_comm] + +/-- The external product's coefficient at a pair is the product of +the coefficients. -/ +theorem extProd_apply_pair {n : ℕ} (x y : SymGroupAlgebra n) + (σ τ : Equiv.Perm (Fin n)) : + (extProd x y).coeff (σ, τ) = x.coeff σ * y.coeff τ := by + classical + induction x using MonoidAlgebra.induction_on with + | of σ₀ => + induction y using MonoidAlgebra.induction_on with + | of τ₀ => + simp only [MonoidAlgebra.of_apply] + rw [extProd_single] + by_cases hcase : σ₀ = σ ∧ τ₀ = τ + · obtain ⟨rfl, rfl⟩ := hcase + simp + · have hne : ((σ₀, τ₀) : + Equiv.Perm (Fin n) × Equiv.Perm (Fin n)) ≠ (σ, τ) := by + intro he + exact hcase ⟨congrArg Prod.fst he, congrArg Prod.snd he⟩ + rcases not_and_or.mp hcase with hσ | hτ + · simp [Finsupp.single_apply, hne, hσ] + · simp [Finsupp.single_apply, hne, hτ] + | add y y' hy hy' => + rw [extProd_add_snd, ma_add_apply, hy, hy', ma_add_apply, + mul_add] + | smul r y hy => + rw [extProd_smul_snd, ma_smul_apply, hy, ma_smul_apply] + ring + | add x x' hx hx' => + rw [extProd_add_fst, ma_add_apply, hx, hx', ma_add_apply, + add_mul] + | smul r x hx => + rw [extProd_smul_fst, ma_smul_apply, hx, ma_smul_apply] + ring + +/-- The external product of Shape idempotents has conjugation +invariant coefficients. -/ +theorem extProd_shape_e_coeff_conj (P : SchurPackage.{u}) {n : ℕ} + (μ ν : Shape n) + (g k : Equiv.Perm (Fin n) × Equiv.Perm (Fin n)) : + (extProd (Shape.e P μ) (Shape.e P ν)).coeff (g⁻¹ * k * g) = + (extProd (Shape.e P μ) (Shape.e P ν)).coeff k := by + change (extProd (Shape.e P μ) (Shape.e P ν)).coeff + (g.1⁻¹ * k.1 * g.1, g.2⁻¹ * k.2 * g.2) = + (extProd (Shape.e P μ) (Shape.e P ν)).coeff (k.1, k.2) + rw [extProd_apply_pair, extProd_apply_pair, shape_e_coeff_conj, + shape_e_coeff_conj] + +/-- The external products of Shape idempotents are central. -/ +theorem extProd_shape_e_central (P : SchurPackage.{u}) {n : ℕ} + (μ ν : Shape n) + (z : MonoidAlgebra ℂ + (Equiv.Perm (Fin n) × Equiv.Perm (Fin n))) : + extProd (Shape.e P μ) (Shape.e P ν) * z = + z * extProd (Shape.e P μ) (Shape.e P ν) := by + classical + -- Reduce to singles by linearity. + suffices hsingle : ∀ + (g : Equiv.Perm (Fin n) × Equiv.Perm (Fin n)) (c : ℂ), + extProd (Shape.e P μ) (Shape.e P ν) * + MonoidAlgebra.single g c = + MonoidAlgebra.single g c * + extProd (Shape.e P μ) (Shape.e P ν) by + induction z using MonoidAlgebra.induction_on with + | of g => exact hsingle g 1 + | add y z hy hz => rw [mul_add, add_mul, hy, hz] + | smul r y hy => rw [mul_smul_comm, smul_mul_assoc, hy] + intro g c + ext k + rw [MonoidAlgebra.coeff_mul_single_apply, + MonoidAlgebra.coeff_single_mul_apply] + have hconj := extProd_shape_e_coeff_conj P μ ν g (k * g⁻¹) + have harg : g⁻¹ * (k * g⁻¹) * g = g⁻¹ * k := by + group + rw [harg] at hconj + rw [← hconj] + ring + +/-- The diagonal embedding is injective on group elements. -/ +theorem diagHom_injective (n : ℕ) : + Function.Injective (diagHom n) := fun _ _ h => + congrArg Prod.fst h + +/-- The diagonal image's coefficient on the diagonal. -/ +theorem diagEmbed_apply_diag {n : ℕ} (x : SymGroupAlgebra n) + (σ : Equiv.Perm (Fin n)) : (diagEmbed x).coeff (σ, σ) = x.coeff σ := by + change Finsupp.mapDomain (diagHom n) x.coeff (σ, σ) = x.coeff σ + exact Finsupp.mapDomain_apply_of_injective (diagHom_injective n) x.coeff σ + +/-- The diagonal image vanishes off the diagonal. -/ +theorem diagEmbed_apply_off_diag {n : ℕ} (x : SymGroupAlgebra n) + {p : Equiv.Perm (Fin n) × Equiv.Perm (Fin n)} + (h : p.1 ≠ p.2) : (diagEmbed x).coeff p = 0 := by + change Finsupp.mapDomain (diagHom n) x.coeff p = 0 + refine Finsupp.mapDomain_of_notMem_range x.coeff p ?_ + rintro ⟨σ, hσ⟩ + rw [← hσ] at h + exact h rfl + +/-- The identity coefficient of the diagonal product is a positive +multiple of the Kronecker multiplicity. -/ +theorem extProd_mul_diagEmbed_apply_one (P : SchurPackage.{u}) + {n : ℕ} (lam μ ν : Shape n) : + (extProd (Shape.e P μ) (Shape.e P ν) * + diagEmbed (Shape.e P lam)).coeff (1, 1) = + (P.dim μ.val : ℂ) * (P.dim ν.val : ℂ) * + (P.dim lam.val : ℂ) / + ((n.factorial : ℂ) * (n.factorial : ℂ)) * + kronMult lam μ ν := by + classical + change (extProd (Shape.e P μ) (Shape.e P ν) * + diagEmbed (Shape.e P lam)).coeff 1 = _ + rw [mul_apply_one] + have hoff : ∀ p ∈ (Finset.univ : + Finset (Equiv.Perm (Fin n) × Equiv.Perm (Fin n))), + p ∉ (Finset.univ : Finset (Equiv.Perm (Fin n))).image + (fun σ => + ((σ, σ) : Equiv.Perm (Fin n) × Equiv.Perm (Fin n))) → + (extProd (Shape.e P μ) (Shape.e P ν)).coeff p * + (diagEmbed (Shape.e P lam)).coeff p⁻¹ = 0 := by + intro p _ hp + have hne : p.1 ≠ p.2 := by + intro he + exact hp (Finset.mem_image.mpr + ⟨p.1, Finset.mem_univ _, Prod.ext rfl he⟩) + have hne' : (p⁻¹).1 ≠ (p⁻¹).2 := by + rw [Prod.fst_inv, Prod.snd_inv] + exact fun he => hne (inv_injective he) + rw [diagEmbed_apply_off_diag _ hne', mul_zero] + rw [← Finset.sum_subset (Finset.subset_univ _) hoff] + rw [Finset.sum_image (fun _ _ _ _ h => congrArg Prod.fst h)] + have hterm : ∀ σ : Equiv.Perm (Fin n), + (extProd (Shape.e P μ) (Shape.e P ν)).coeff (σ, σ) * + (diagEmbed (Shape.e P lam)).coeff ((σ, σ)⁻¹) = + ((P.dim μ.val : ℂ) / (n.factorial : ℂ)) * + ((P.dim ν.val : ℂ) / (n.factorial : ℂ)) * + ((P.dim lam.val : ℂ) / (n.factorial : ℂ)) * + (jtChar lam.val (permCast lam.prop.symm σ) * + jtChar μ.val (permCast μ.prop.symm σ) * + jtChar ν.val (permCast ν.prop.symm σ)) := by + intro σ + have h2 : (diagEmbed (Shape.e P lam)).coeff ((σ, σ)⁻¹) = + (Shape.e P lam).coeff σ⁻¹ := + diagEmbed_apply_diag (Shape.e P lam) σ⁻¹ + have hc := shape_e_coeff P lam σ⁻¹ + rw [permCast_inv, jtChar_inv] at hc + rw [extProd_apply_pair, h2, + show (Shape.e P lam).coeff σ⁻¹ = + ((P.dim lam.val : ℂ) / (n.factorial : ℂ)) * + jtChar lam.val (permCast lam.prop.symm σ) from hc, + show (Shape.e P μ).coeff σ = + ((P.dim μ.val : ℂ) / (n.factorial : ℂ)) * + jtChar μ.val (permCast μ.prop.symm σ) from + shape_e_coeff P μ σ, + show (Shape.e P ν).coeff σ = + ((P.dim ν.val : ℂ) / (n.factorial : ℂ)) * + jtChar ν.val (permCast ν.prop.symm σ) from + shape_e_coeff P ν σ] + ring + rw [Finset.sum_congr rfl fun σ _ => hterm σ] + rw [show (∑ σ : Equiv.Perm (Fin n), + ((P.dim μ.val : ℂ) / (n.factorial : ℂ)) * + ((P.dim ν.val : ℂ) / (n.factorial : ℂ)) * + ((P.dim lam.val : ℂ) / (n.factorial : ℂ)) * + (jtChar lam.val (permCast lam.prop.symm σ) * + jtChar μ.val (permCast μ.prop.symm σ) * + jtChar ν.val (permCast ν.prop.symm σ))) = + ((P.dim μ.val : ℂ) / (n.factorial : ℂ)) * + ((P.dim ν.val : ℂ) / (n.factorial : ℂ)) * + ((P.dim lam.val : ℂ) / (n.factorial : ℂ)) * + ∑ σ : Equiv.Perm (Fin n), + jtChar lam.val (permCast lam.prop.symm σ) * + jtChar μ.val (permCast μ.prop.symm σ) * + jtChar ν.val (permCast ν.prop.symm σ) from by + simp only [Finset.mul_sum]] + rw [kronMult] + have hn : ((n.factorial : ℂ)) ≠ 0 := + Nat.cast_ne_zero.mpr n.factorial_ne_zero + field_simp + +/-- **The Kronecker kill**: a vanishing Kronecker multiplicity +kills the diagonal product in the product group algebra. -/ +theorem extProd_mul_diagEmbed_eq_zero (P : SchurPackage.{u}) + {n : ℕ} (lam μ ν : Shape n) (h : kronMult lam μ ν = 0) : + extProd (Shape.e P μ) (Shape.e P ν) * + diagEmbed (Shape.e P lam) = 0 := by + classical + apply eq_zero_of_idem_of_coeff_one + · set A := extProd (Shape.e P μ) (Shape.e P ν) with hA + set B := diagEmbed (Shape.e P lam) with hB + have hc : B * A = A * B := + (extProd_shape_e_central P μ ν B).symm + have hd : B * B = B := by + rw [hB, ← map_mul, Shape.e_mul_self] + have ha : A * A = A := extProd_shape_e_idem P μ ν + calc A * B * (A * B) + = A * (B * (A * B)) := mul_assoc _ _ _ + _ = A * (B * A * B) := + congrArg (fun z => A * z) (mul_assoc _ _ _).symm + _ = A * (A * B * B) := + congrArg (fun z => A * (z * B)) hc + _ = A * (A * (B * B)) := + congrArg (fun z => A * z) (mul_assoc _ _ _) + _ = A * (A * B) := + congrArg (fun z => A * (A * z)) hd + _ = A * A * B := (mul_assoc _ _ _).symm + _ = A * B := congrArg (fun z => z * B) ha + · have h4 := extProd_mul_diagEmbed_apply_one P lam μ ν + rw [h, mul_zero] at h4 + exact h4 + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/LambdaCoend.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/LambdaCoend.lean new file mode 100644 index 0000000000..eb90bb4ee4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/LambdaCoend.lean @@ -0,0 +1,1820 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid + +/-! +# The Λ coend of a pair of functors + +Deligne 3.4's object `Λ(α, β)`: the coend over `X` of +`α(X)∨ ⊗ β(X)`, built here as the coend of the diagram +`(X, Y) ↦ α(Xᘁ) ⊗ β(Y)` using the *source* category's rigidity — +for tensor functors the two agree, and this form needs no duals in +the target. This file provides the diagram, the coend with its +stage maps and dinaturality, the mapping property, and +functoriality in both arguments. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits Opposite + +universe v u v' u' + +variable {A : Type u} + +/-- The Λ diagram of a pair of functors: `(X, Y) ↦ α(Xᘁ) ⊗ β(Y)`, +contravariant in `X` through the adjoint mate. -/ +@[simps!] +def lambdaDiagram [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] + (α β : A ⥤ D) : Aᵒᵖ ⥤ A ⥤ D where + obj X := + { obj := fun Y => α.obj ((unop X)ᘁ) ⊗ β.obj Y + map := fun g => α.obj ((unop X)ᘁ) ◁ β.map g + map_id := fun Y => by + rw [β.map_id, MonoidalCategory.whiskerLeft_id] + map_comp := fun g g' => by + rw [β.map_comp, MonoidalCategory.whiskerLeft_comp] } + map f := + { app := fun Y => α.map ((f.unop)ᘁ) ▷ β.obj Y + naturality := fun Y Y' g => by + dsimp + exact whisker_exchange _ _ } + map_id X := by + ext Y + simp + map_comp f f' := by + ext Y + dsimp + rw [comp_rightAdjointMate, α.map_comp, comp_whiskerRight] + +section + +/-- Existence of the Λ coend of the pair `(α, β)`. -/ +abbrev HasLambda [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] (α : A ⥤ D) + (β : A ⥤ D) : Prop := HasCoend (lambdaDiagram α β) + +/-- The Λ object of a pair of functors: the coend of +`(X, Y) ↦ α(Xᘁ) ⊗ β(Y)`. -/ +noncomputable def lambdaObj + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] (α : A ⥤ D) + (β : A ⥤ D) [HasLambda α β] : D := coend (lambdaDiagram α β) + +/-- The stage map of the Λ coend at an object of the source. -/ +noncomputable def lambdaStage + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] (α : A ⥤ D) + (β : A ⥤ D) [HasLambda α β] + (X : A) : + α.obj (Xᘁ) ⊗ β.obj X ⟶ lambdaObj α β := + coend.ι (lambdaDiagram α β) X + +/-- Dinaturality of the stage maps. -/ +@[reassoc] +theorem lambdaStage_condition + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] (α : A ⥤ D) + (β : A ⥤ D) [HasLambda α β] + {X Y : A} (f : X ⟶ Y) : + (α.map (fᘁ) ▷ β.obj X) ≫ lambdaStage α β X = + (α.obj (Yᘁ) ◁ β.map f) ≫ lambdaStage α β Y := + coend.condition (lambdaDiagram α β) f + +/-- Maps out of the Λ object agree once they agree on stages. -/ +theorem lambdaObj_hom_ext + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] (α : A ⥤ D) + (β : A ⥤ D) [HasLambda α β] + {W : D} {f g : lambdaObj α β ⟶ W} + (h : ∀ X, lambdaStage α β X ≫ f = lambdaStage α β X ≫ g) : + f = g := + coend.hom_ext h + +/-- Descend a dinatural family of maps to the Λ object. -/ +noncomputable def lambdaDesc + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] (α : A ⥤ D) + (β : A ⥤ D) [HasLambda α β] + {W : D} + (f : ∀ X : A, α.obj (Xᘁ) ⊗ β.obj X ⟶ W) + (hf : ∀ ⦃X Y : A⦄ (g : X ⟶ Y), + (α.map (gᘁ) ▷ β.obj X) ≫ f X = + (α.obj (Yᘁ) ◁ β.map g) ≫ f Y) : + lambdaObj α β ⟶ W := + coend.desc f hf + +@[reassoc (attr := simp)] +theorem lambdaStage_desc + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] (α : A ⥤ D) + (β : A ⥤ D) [HasLambda α β] + {W : D} + (f : ∀ X : A, α.obj (Xᘁ) ⊗ β.obj X ⟶ W) + (hf : ∀ ⦃X Y : A⦄ (g : X ⟶ Y), + (α.map (gᘁ) ▷ β.obj X) ≫ f X = + (α.obj (Yᘁ) ◁ β.map g) ≫ f Y) (X : A) : + lambdaStage α β X ≫ lambdaDesc α β f hf = f X := + coend.ι_desc (F := lambdaDiagram α β) f hf X + +end + +section + +/-- Natural transformations in both arguments induce a map of Λ +diagrams. -/ +@[simps] +def lambdaDiagramMap + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] {α : A ⥤ D} + {α' : A ⥤ D} {β : A ⥤ D} {β' : A ⥤ D} + (η : α ⟶ α') (τ : β ⟶ β') : + lambdaDiagram α β ⟶ lambdaDiagram α' β' where + app X := + { app := fun Y => η.app ((unop X)ᘁ) ⊗ₘ τ.app Y + naturality := fun Y Y' g => by + change α.obj ((unop X)ᘁ) ◁ β.map g ≫ + (η.app ((unop X)ᘁ) ⊗ₘ τ.app Y') = + (η.app ((unop X)ᘁ) ⊗ₘ τ.app Y) ≫ + α'.obj ((unop X)ᘁ) ◁ β'.map g + simp only [tensorHom_def] + rw [whisker_exchange_assoc, + ← MonoidalCategory.whiskerLeft_comp, Category.assoc, + ← MonoidalCategory.whiskerLeft_comp, τ.naturality] } + naturality f f' g := by + ext Y + change α.map ((g.unop)ᘁ) ▷ β.obj Y ≫ + (η.app ((unop f')ᘁ) ⊗ₘ τ.app Y) = + (η.app ((unop f)ᘁ) ⊗ₘ τ.app Y) ≫ + α'.map ((g.unop)ᘁ) ▷ β'.obj Y + simp only [tensorHom_def] + rw [Category.assoc, whisker_exchange, + ← comp_whiskerRight_assoc, ← comp_whiskerRight_assoc, + η.naturality] + +/-- Functoriality of the Λ object in both arguments. -/ +noncomputable def lambdaMap + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] {α : A ⥤ D} + {α' : A ⥤ D} {β : A ⥤ D} {β' : A ⥤ D} + [HasLambda α β] [HasLambda α' β'] + (η : α ⟶ α') (τ : β ⟶ β') : + lambdaObj α β ⟶ lambdaObj α' β' := + coend.map (lambdaDiagramMap η τ) + +@[reassoc (attr := simp)] +theorem lambdaStage_map + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] {α : A ⥤ D} + {α' : A ⥤ D} {β : A ⥤ D} {β' : A ⥤ D} + [HasLambda α β] [HasLambda α' β'] + (η : α ⟶ α') (τ : β ⟶ β') (X : A) : + lambdaStage α β X ≫ lambdaMap η τ = + (η.app (Xᘁ) ⊗ₘ τ.app X) ≫ lambdaStage α' β' X := + coend.ι_map (lambdaDiagramMap η τ) X + +@[simp] +theorem lambdaMap_id + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] {α : A ⥤ D} + {β : A ⥤ D} + [HasLambda α β] : + lambdaMap (𝟙 α) (𝟙 β) = 𝟙 (lambdaObj α β) := by + refine lambdaObj_hom_ext α β fun X => ?_ + simp + +@[reassoc] +theorem lambdaMap_comp + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] {α : A ⥤ D} + {α' : A ⥤ D} {α'' : A ⥤ D} {β : A ⥤ D} {β' : A ⥤ D} {β'' : A ⥤ D} + [HasLambda α β] [HasLambda α' β'] + [HasLambda α'' β''] (η : α ⟶ α') (η' : α' ⟶ α'') + (τ : β ⟶ β') (τ' : β' ⟶ β'') : + lambdaMap η τ ≫ lambdaMap η' τ' = + lambdaMap (η ≫ η') (τ ≫ τ') := by + refine lambdaObj_hom_ext α β fun X => ?_ + simp + +end + +section Unit + +open Functor.LaxMonoidal + +/-- The right dual of the monoidal unit supplied by the rigid +structure — the instance the Λ stages use, which need not be the +unit-specific instance. -/ +noncomputable def unitRigidDual + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] : A := + @HasRightDual.rightDual A _ _ (𝟙_ A) + (RightRigidCategory.rightDual (𝟙_ A)) + +/-- The rigid right dual of the monoidal unit is the unit, through +the canonical comparison of exact pairings. -/ +noncomputable def unitRightDualIso + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] : + (unitRigidDual : A) ≅ 𝟙_ A := + rightDualIso + (@HasRightDual.exact A _ _ (𝟙_ A) + (RightRigidCategory.rightDual (𝟙_ A))) + exactPairingUnit + +/-- The unit of the Λ object of a pair of lax monoidal functors: +the units of the functors into the stage at the monoidal unit, +through the comparison of the unit with its rigid dual. -/ +noncomputable def lambdaUnit + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] (α : A ⥤ D) + (β : A ⥤ D) [α.LaxMonoidal] [β.LaxMonoidal] + [HasLambda α β] : + 𝟙_ D ⟶ lambdaObj α β := + (λ_ (𝟙_ D)).inv ≫ + ((ε α ≫ α.map unitRightDualIso.inv) ⊗ₘ ε β) ≫ + lambdaStage α β (𝟙_ A) + +end Unit + +section TensorCoend + +/-- Maps out of the image of a coend under a +colimit-preserving functor agree once they agree on the images +of the stages. -/ +theorem coend_hom_ext_of_preserves + {D : Type u'} [Category.{v'} D] {J : Type u} [Category.{v} J] + {E : Type u'} [Category.{v'} E] + (F : Jᵒᵖ ⥤ J ⥤ D) [HasCoend F] (G : D ⥤ E) + [PreservesColimit (multispanIndexCoend F).multispan G] + {Z : E} {f g : G.obj (coend F) ⟶ Z} + (h : ∀ j, G.map (coend.ι F j) ≫ f = + G.map (coend.ι F j) ≫ g) : f = g := by + have hc := isColimitOfPreserves G + (colimit.isColimit (multispanIndexCoend F).multispan) + refine hc.hom_ext fun x => ?_ + match x with + | .right j => exact h j + | .left a => + have hw : (multispanIndexCoend F).multispan.map + (Limits.WalkingMultispan.Hom.fst a) ≫ + colimit.ι (multispanIndexCoend F).multispan + (.right ((multispanShapeCoend J).fst a)) = + colimit.ι (multispanIndexCoend F).multispan (.left a) := + colimit.w _ _ + have hf := h ((multispanShapeCoend J).fst a) + change G.map + (colimit.ι (multispanIndexCoend F).multispan (.left a)) ≫ + f = + G.map + (colimit.ι (multispanIndexCoend F).multispan (.left a)) ≫ + g + erw [← hw, Functor.map_comp, Category.assoc, Category.assoc] + exact congrArg (fun t => G.map + ((multispanIndexCoend F).multispan.map + (Limits.WalkingMultispan.Hom.fst a)) ≫ t) hf + +/-- Maps out of a tensor by a coend agree once they agree on +whiskered stages, provided tensoring preserves the coend's +colimit presentation. The workhorse for descending +multiplications through `Λ ⊗ Λ`. -/ +theorem tensorLeft_coend_hom_ext + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] {J : Type u} + [Category.{v} J] + (F : Jᵒᵖ ⥤ J ⥤ D) [HasCoend F] + (W : D) [PreservesColimit (multispanIndexCoend F).multispan + (tensorLeft W)] {Z : D} {f g : W ⊗ coend F ⟶ Z} + (h : ∀ j, (W ◁ coend.ι F j) ≫ f = (W ◁ coend.ι F j) ≫ g) : + f = g := by + have hc := isColimitOfPreserves (tensorLeft W) + (colimit.isColimit (multispanIndexCoend F).multispan) + refine hc.hom_ext fun x => ?_ + match x with + | .right j => exact h j + | .left a => + have hw : (multispanIndexCoend F).multispan.map + (Limits.WalkingMultispan.Hom.fst a) ≫ + colimit.ι (multispanIndexCoend F).multispan + (.right ((multispanShapeCoend J).fst a)) = + colimit.ι (multispanIndexCoend F).multispan (.left a) := + colimit.w _ _ + have hf := h ((multispanShapeCoend J).fst a) + change (tensorLeft W).map + (colimit.ι (multispanIndexCoend F).multispan (.left a)) ≫ + f = + (tensorLeft W).map + (colimit.ι (multispanIndexCoend F).multispan (.left a)) ≫ g + erw [← hw, Functor.map_comp, Category.assoc, Category.assoc] + exact congrArg (fun t => (tensorLeft W).map + ((multispanIndexCoend F).multispan.map + (Limits.WalkingMultispan.Hom.fst a)) ≫ t) hf + +/-- Right-hand mirror of `RS.tensorLeft_coend_hom_ext`. -/ +theorem tensorRight_coend_hom_ext + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] {J : Type u} + [Category.{v} J] + (F : Jᵒᵖ ⥤ J ⥤ D) [HasCoend F] + (W : D) [PreservesColimit (multispanIndexCoend F).multispan + (tensorRight W)] {Z : D} {f g : coend F ⊗ W ⟶ Z} + (h : ∀ j, (coend.ι F j ▷ W) ≫ f = (coend.ι F j ▷ W) ≫ g) : + f = g := by + have hc := isColimitOfPreserves (tensorRight W) + (colimit.isColimit (multispanIndexCoend F).multispan) + refine hc.hom_ext fun x => ?_ + match x with + | .right j => exact h j + | .left a => + have hw : (multispanIndexCoend F).multispan.map + (Limits.WalkingMultispan.Hom.fst a) ≫ + colimit.ι (multispanIndexCoend F).multispan + (.right ((multispanShapeCoend J).fst a)) = + colimit.ι (multispanIndexCoend F).multispan (.left a) := + colimit.w _ _ + have hf := h ((multispanShapeCoend J).fst a) + change (tensorRight W).map + (colimit.ι (multispanIndexCoend F).multispan (.left a)) ≫ + f = + (tensorRight W).map + (colimit.ι (multispanIndexCoend F).multispan (.left a)) ≫ g + erw [← hw, Functor.map_comp, Category.assoc, Category.assoc] + exact congrArg (fun t => (tensorRight W).map + ((multispanIndexCoend F).multispan.map + (Limits.WalkingMultispan.Hom.fst a)) ≫ t) hf + +section + +/-- The cocone under the whiskered multispan carried by a +dinatural family. -/ +@[simps] +def tensorLeftCoendCocone + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] {J : Type u} + [Category.{v} J] (F : Jᵒᵖ ⥤ J ⥤ D) (W : D) {Z : D} + (k : ∀ j : J, W ⊗ (F.obj (op j)).obj j ⟶ Z) + (hk : ∀ ⦃i j : J⦄ (g : i ⟶ j), (W ◁ (F.map g.op).app i) ≫ k i = (W ◁ + (F.obj (op j)).map g) ≫ k j) : + Cocone ((multispanIndexCoend F).multispan ⋙ tensorLeft W) where + pt := Z + ι := + { app := fun x => + match x with + | .left a => + ((multispanIndexCoend F).multispan ⋙ + tensorLeft W).map + (Limits.WalkingMultispan.Hom.fst a) ≫ + k ((multispanShapeCoend J).fst a) + | .right j => k j + naturality := fun x y φ => by + match φ with + | .id z => + obtain a | j := z + · exact ((congrArg (fun t => t ≫ + (((multispanIndexCoend F).multispan ⋙ + tensorLeft W).map + (Limits.WalkingMultispan.Hom.fst a) ≫ + k ((multispanShapeCoend J).fst a))) + (CategoryTheory.Functor.map_id _ _)).trans + (Category.id_comp _)).trans + (Category.comp_id _).symm + · exact ((congrArg (fun t => t ≫ k j) + (CategoryTheory.Functor.map_id _ _)).trans + (Category.id_comp _)).trans + (Category.comp_id _).symm + | .fst a => + exact (Category.comp_id _).symm + | .snd a => + exact ((hk (Arrow.hom a)).symm).trans + (Category.comp_id _).symm } + +/-- Descend a whiskered dinatural family through a tensor by a +coend. -/ +noncomputable def tensorLeftCoendDesc + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] {J : Type u} + [Category.{v} J] (F : Jᵒᵖ ⥤ J ⥤ D) [HasCoend F] (W : D) + [PreservesColimit (multispanIndexCoend F).multispan (tensorLeft W)] + {Z : D} (k : ∀ j : J, W ⊗ (F.obj (op j)).obj j ⟶ Z) + (hk : ∀ ⦃i j : J⦄ (g : i ⟶ j), (W ◁ (F.map g.op).app i) ≫ k i = (W ◁ + (F.obj (op j)).map g) ≫ k j) : W ⊗ coend F ⟶ Z := + (isColimitOfPreserves (tensorLeft W) + (colimit.isColimit (multispanIndexCoend F).multispan)).desc + (tensorLeftCoendCocone F W k hk) + +@[reassoc (attr := simp)] +theorem whiskerLeft_ι_tensorLeftCoendDesc + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] {J : Type u} + [Category.{v} J] (F : Jᵒᵖ ⥤ J ⥤ D) [HasCoend F] (W : D) + [PreservesColimit (multispanIndexCoend F).multispan (tensorLeft W)] + {Z : D} (k : ∀ j : J, W ⊗ (F.obj (op j)).obj j ⟶ Z) + (hk : ∀ ⦃i j : J⦄ (g : i ⟶ j), (W ◁ (F.map g.op).app i) ≫ k i = (W ◁ + (F.obj (op j)).map g) ≫ k j) + (j : J) : + (W ◁ coend.ι F j) ≫ tensorLeftCoendDesc F W k hk = k j := + (isColimitOfPreserves (tensorLeft W) + (colimit.isColimit (multispanIndexCoend F).multispan)).fac + (tensorLeftCoendCocone F W k hk) (.right j) + +end + +section + +/-- The cocone under the right-whiskered multispan carried by a +dinatural family. -/ +@[simps] +def tensorRightCoendCocone + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] {J : Type u} + [Category.{v} J] (F : Jᵒᵖ ⥤ J ⥤ D) (W : D) {Z : D} + (k : ∀ j : J, (F.obj (op j)).obj j ⊗ W ⟶ Z) + (hk : ∀ ⦃i j : J⦄ (g : i ⟶ j), ((F.map g.op).app i ▷ W) ≫ k i = ((F.obj + (op j)).map g ▷ W) ≫ k j) : + Cocone ((multispanIndexCoend F).multispan ⋙ tensorRight W) + where + pt := Z + ι := + { app := fun x => + match x with + | .left a => + ((multispanIndexCoend F).multispan ⋙ + tensorRight W).map + (Limits.WalkingMultispan.Hom.fst a) ≫ + k ((multispanShapeCoend J).fst a) + | .right j => k j + naturality := fun x y φ => by + match φ with + | .id z => + obtain a | j := z + · exact ((congrArg (fun t => t ≫ + (((multispanIndexCoend F).multispan ⋙ + tensorRight W).map + (Limits.WalkingMultispan.Hom.fst a) ≫ + k ((multispanShapeCoend J).fst a))) + (CategoryTheory.Functor.map_id _ _)).trans + (Category.id_comp _)).trans + (Category.comp_id _).symm + · exact ((congrArg (fun t => t ≫ k j) + (CategoryTheory.Functor.map_id _ _)).trans + (Category.id_comp _)).trans + (Category.comp_id _).symm + | .fst a => + exact (Category.comp_id _).symm + | .snd a => + exact ((hk (Arrow.hom a)).symm).trans + (Category.comp_id _).symm } + +/-- Descend a right-whiskered dinatural family through a tensor by +a coend. -/ +noncomputable def tensorRightCoendDesc + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] {J : Type u} + [Category.{v} J] (F : Jᵒᵖ ⥤ J ⥤ D) [HasCoend F] (W : D) + [PreservesColimit (multispanIndexCoend F).multispan (tensorRight W)] + {Z : D} (k : ∀ j : J, (F.obj (op j)).obj j ⊗ W ⟶ Z) + (hk : ∀ ⦃i j : J⦄ (g : i ⟶ j), ((F.map g.op).app i ▷ W) ≫ k i = ((F.obj + (op j)).map g ▷ W) ≫ k j) : coend F ⊗ W ⟶ Z := + (isColimitOfPreserves (tensorRight W) + (colimit.isColimit (multispanIndexCoend F).multispan)).desc + (tensorRightCoendCocone F W k hk) + +@[reassoc (attr := simp)] +theorem ι_whiskerRight_tensorRightCoendDesc + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] {J : Type u} + [Category.{v} J] (F : Jᵒᵖ ⥤ J ⥤ D) [HasCoend F] (W : D) + [PreservesColimit (multispanIndexCoend F).multispan (tensorRight W)] + {Z : D} (k : ∀ j : J, (F.obj (op j)).obj j ⊗ W ⟶ Z) + (hk : ∀ ⦃i j : J⦄ (g : i ⟶ j), ((F.map g.op).app i ▷ W) ≫ k i = ((F.obj + (op j)).map g ▷ W) ≫ k j) + (j : J) : + (coend.ι F j ▷ W) ≫ tensorRightCoendDesc F W k hk = k j := + (isColimitOfPreserves (tensorRight W) + (colimit.isColimit (multispanIndexCoend F).multispan)).fac + (tensorRightCoendCocone F W k hk) (.right j) + +end + +end TensorCoend + +section Multiplication + +open Functor.LaxMonoidal + +/-- The braid shuffle: the two ways of carrying the reversed pair +across a third object agree — the Yang–Baxter consequence behind +the associativity of the Λ multiplication. -/ +theorem braid_shuffle [Category.{v} A] [MonoidalCategory A] + {P Q R : A} [BraidedCategory A] : + ((β_ P Q).hom ▷ R) ≫ (β_ (Q ⊗ P) R).hom ≫ + (α_ R Q P).inv = + (α_ P Q R).hom ≫ (P ◁ (β_ Q R).hom) ≫ + (β_ P (R ⊗ Q)).hom := by + rw [BraidedCategory.braiding_tensor_left_hom, + BraidedCategory.braiding_tensor_right_hom] + calc ((β_ P Q).hom ▷ R) ≫ + ((α_ Q P R).hom ≫ Q ◁ (β_ P R).hom ≫ (α_ Q R P).inv ≫ + (β_ Q R).hom ▷ P ≫ (α_ R Q P).hom) ≫ (α_ R Q P).inv + = (α_ P Q R).hom ≫ ((α_ P Q R).inv ≫ + (β_ P Q).hom ▷ R ≫ (α_ Q P R).hom ≫ + Q ◁ (β_ P R).hom ≫ (α_ Q R P).inv ≫ + (β_ Q R).hom ▷ P ≫ (α_ R Q P).hom) ≫ + (α_ R Q P).inv := by + monoidal + _ = (α_ P Q R).hom ≫ (P ◁ (β_ Q R).hom ≫ + (α_ P R Q).inv ≫ (β_ P R).hom ▷ Q ≫ + (α_ R P Q).hom ≫ R ◁ (β_ P Q).hom) ≫ + (α_ R Q P).inv := by + rw [BraidedCategory.yang_baxter] + _ = (α_ P Q R).hom ≫ (P ◁ (β_ Q R).hom) ≫ + ((α_ P R Q).inv ≫ (β_ P R).hom ▷ Q ≫ + (α_ R P Q).hom ≫ R ◁ (β_ P Q).hom ≫ + (α_ R Q P).inv) := by + monoidal + +/-- Maps into a right dual agree once their evaluation composites +agree. -/ +theorem eq_of_whiskerRight_comp_evaluation [Category.{v} A] [MonoidalCategory A] + {P Q Z : A} + [ExactPairing P Q] {h₁ h₂ : Z ⟶ Q} + (H : (h₁ ▷ P) ≫ ε_ P Q = (h₂ ▷ P) ≫ ε_ P Q) : h₁ = h₂ := by + apply_fun tensorRightHomEquiv Z P Q (𝟙_ A) at H + have e₁ := + @tensorRightHomEquiv_whiskerRight_comp_evaluation A _ _ P Z + ⟨Q⟩ h₁ + have e₂ := + @tensorRightHomEquiv_whiskerRight_comp_evaluation A _ _ P Z + ⟨Q⟩ h₂ + have H' : h₁ ≫ (λ_ Q).inv = h₂ ≫ (λ_ Q).inv := + e₁.symm.trans (H.trans e₂) + exact (cancel_mono _).1 H' + +/-- The comparison of the dual of a product with the product of +the duals reduces the rigid evaluation to the tensor-pairing +evaluation. -/ +theorem rightDualTensorIso_inv_comp_evaluation + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + (X Y : A) : + ((rightDualTensorIso X Y).inv ▷ (X ⊗ Y)) ≫ + ε_ (X ⊗ Y) ((X ⊗ Y)ᘁ) = + ε_ (X ⊗ Y) ((Yᘁ : A) ⊗ (Xᘁ : A)) := by + have h := @rightAdjointMate_comp_evaluation A _ _ (X ⊗ Y) + (X ⊗ Y) inferInstance ⟨(Yᘁ : A) ⊗ (Xᘁ : A)⟩ (𝟙 (X ⊗ Y)) + refine h.trans ?_ + rw [MonoidalCategory.whiskerLeft_id, Category.id_comp] + rfl + +/-- The mate of a left whiskering, through the comparison of the +dual of a tensor product with the tensor of the duals: the +dinaturality input of the Λ multiplication. -/ +theorem whiskerLeft_mate_square + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + (X : A) {Y Y' : A} (g : Y ⟶ Y') : + ((gᘁ) ▷ (Xᘁ : A)) ≫ (rightDualTensorIso X Y).inv = + (rightDualTensorIso X Y').inv ≫ ((X ◁ g)ᘁ) := by + refine eq_of_whiskerRight_comp_evaluation (P := X ⊗ Y) ?_ + rw [comp_whiskerRight, comp_whiskerRight, Category.assoc, + Category.assoc, rightDualTensorIso_inv_comp_evaluation, + rightAdjointMate_comp_evaluation, + ← whisker_exchange_assoc, + rightDualTensorIso_inv_comp_evaluation] + calc ((gᘁ) ▷ (Xᘁ : A)) ▷ (X ⊗ Y) ≫ + ε_ (X ⊗ Y) ((Yᘁ : A) ⊗ (Xᘁ : A)) + = 𝟙 _ ⊗≫ ((gᘁ) ▷ ((Xᘁ : A) ⊗ X) ≫ + (Yᘁ : A) ◁ ε_ X (Xᘁ)) ▷ Y ⊗≫ ε_ Y (Yᘁ) := by + rw [ExactPairing.tensor_evaluation] + monoidal + _ = 𝟙 _ ⊗≫ (((Y'ᘁ : A) ◁ ε_ X (Xᘁ)) ≫ + ((gᘁ) ▷ 𝟙_ A)) ▷ Y ⊗≫ ε_ Y (Yᘁ) := by + rw [whisker_exchange] + _ = 𝟙 _ ⊗≫ (Y'ᘁ : A) ◁ (ε_ X (Xᘁ) ▷ Y) ⊗≫ + ((gᘁ) ▷ Y ≫ ε_ Y (Yᘁ)) := by + monoidal + _ = 𝟙 _ ⊗≫ (Y'ᘁ : A) ◁ (ε_ X (Xᘁ) ▷ Y) ⊗≫ + ((Y'ᘁ : A) ◁ g ≫ ε_ Y' (Y'ᘁ)) := by + rw [rightAdjointMate_comp_evaluation] + _ = 𝟙 _ ⊗≫ (((Y'ᘁ : A) ◁ ε_ X (Xᘁ)) ▷ Y ≫ + ((Y'ᘁ : A) ⊗ 𝟙_ A) ◁ g) ⊗≫ ε_ Y' (Y'ᘁ) := by + monoidal + _ = 𝟙 _ ⊗≫ (((Y'ᘁ : A) ⊗ ((Xᘁ : A) ⊗ X)) ◁ g ≫ + ((Y'ᘁ : A) ◁ ε_ X (Xᘁ)) ▷ Y') ⊗≫ ε_ Y' (Y'ᘁ) := by + rw [← whisker_exchange] + _ = ((Y'ᘁ : A) ⊗ (Xᘁ : A)) ◁ (X ◁ g) ≫ + (𝟙 _ ⊗≫ (Y'ᘁ : A) ◁ (ε_ X (Xᘁ) ▷ Y') ⊗≫ + ε_ Y' (Y'ᘁ)) := by + monoidal + _ = ((Y'ᘁ : A) ⊗ (Xᘁ : A)) ◁ (X ◁ g) ≫ + ε_ (X ⊗ Y') ((Y'ᘁ : A) ⊗ (Xᘁ : A)) := by + rw [ExactPairing.tensor_evaluation] + +/-- The mate of a right whiskering: the left-slot mirror of +`RS.whiskerLeft_mate_square`. -/ +theorem whiskerRight_mate_square + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {X X' : A} (f : X ⟶ X') + (Y : A) : + ((Yᘁ : A) ◁ (fᘁ)) ≫ (rightDualTensorIso X Y).inv = + (rightDualTensorIso X' Y).inv ≫ ((f ▷ Y)ᘁ) := by + refine eq_of_whiskerRight_comp_evaluation (P := X ⊗ Y) ?_ + rw [comp_whiskerRight, comp_whiskerRight, Category.assoc, + Category.assoc, rightDualTensorIso_inv_comp_evaluation, + rightAdjointMate_comp_evaluation, + ← whisker_exchange_assoc, + rightDualTensorIso_inv_comp_evaluation] + calc ((Yᘁ : A) ◁ (fᘁ)) ▷ (X ⊗ Y) ≫ + ε_ (X ⊗ Y) ((Yᘁ : A) ⊗ (Xᘁ : A)) + = 𝟙 _ ⊗≫ (Yᘁ : A) ◁ (((fᘁ) ▷ X ≫ ε_ X (Xᘁ)) ▷ Y) ⊗≫ + ε_ Y (Yᘁ) := by + rw [ExactPairing.tensor_evaluation] + monoidal + _ = 𝟙 _ ⊗≫ (Yᘁ : A) ◁ ((((X'ᘁ : A) ◁ f) ≫ + ε_ X' (X'ᘁ)) ▷ Y) ⊗≫ ε_ Y (Yᘁ) := by + rw [rightAdjointMate_comp_evaluation] + _ = ((Yᘁ : A) ⊗ (X'ᘁ : A)) ◁ (f ▷ Y) ≫ + ε_ (X' ⊗ Y) ((Yᘁ : A) ⊗ (X'ᘁ : A)) := by + rw [ExactPairing.tensor_evaluation] + monoidal + +/-- The mate of the associator, through the comparisons of duals +of tensor products: the source-side kernel of the Λ +associativity. -/ +theorem associator_mate_square + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + (X Y Z : A) : + (α_ (Zᘁ : A) (Yᘁ : A) (Xᘁ : A)).hom ≫ + ((Zᘁ : A) ◁ (rightDualTensorIso X Y).inv) ≫ + (rightDualTensorIso (X ⊗ Y) Z).inv = + ((rightDualTensorIso Y Z).inv ▷ (Xᘁ : A)) ≫ + (rightDualTensorIso X (Y ⊗ Z)).inv ≫ + (((α_ X Y Z).hom)ᘁ) := by + refine eq_of_whiskerRight_comp_evaluation + (P := (X ⊗ Y) ⊗ Z) ?_ + rw [comp_whiskerRight, comp_whiskerRight, comp_whiskerRight, + comp_whiskerRight, Category.assoc, Category.assoc, + Category.assoc, Category.assoc, + rightDualTensorIso_inv_comp_evaluation, + rightAdjointMate_comp_evaluation, + ← whisker_exchange_assoc, + rightDualTensorIso_inv_comp_evaluation] + calc ((α_ (Zᘁ : A) (Yᘁ : A) (Xᘁ : A)).hom ▷ + ((X ⊗ Y) ⊗ Z)) ≫ + (((Zᘁ : A) ◁ (rightDualTensorIso X Y).inv) ▷ + ((X ⊗ Y) ⊗ Z)) ≫ + ε_ ((X ⊗ Y) ⊗ Z) ((Zᘁ : A) ⊗ ((X ⊗ Y)ᘁ : A)) + = ((α_ (Zᘁ : A) (Yᘁ : A) (Xᘁ : A)).hom ▷ + ((X ⊗ Y) ⊗ Z)) ≫ + (𝟙 _ ⊗≫ (Zᘁ : A) ◁ + ((((rightDualTensorIso X Y).inv ▷ (X ⊗ Y)) ≫ + ε_ (X ⊗ Y) ((X ⊗ Y)ᘁ)) ▷ Z) ⊗≫ + ε_ Z (Zᘁ)) := by + rw [ExactPairing.tensor_evaluation] + congr 1 + monoidal + _ = ((α_ (Zᘁ : A) (Yᘁ : A) (Xᘁ : A)).hom ▷ + ((X ⊗ Y) ⊗ Z)) ≫ + (𝟙 _ ⊗≫ (Zᘁ : A) ◁ + ((𝟙 _ ⊗≫ (Yᘁ : A) ◁ (ε_ X (Xᘁ) ▷ Y) ⊗≫ + ε_ Y (Yᘁ)) ▷ Z) ⊗≫ + ε_ Z (Zᘁ)) := by + rw [rightDualTensorIso_inv_comp_evaluation, + ExactPairing.tensor_evaluation] + _ = (((rightDualTensorIso Y Z).inv ▷ (Xᘁ : A)) ▷ + ((X ⊗ Y) ⊗ Z)) ≫ + ((((Y ⊗ Z)ᘁ : A) ⊗ (Xᘁ : A)) ◁ (α_ X Y Z).hom) ≫ + ε_ (X ⊗ (Y ⊗ Z)) (((Y ⊗ Z)ᘁ : A) ⊗ (Xᘁ : A)) := by + symm + calc (((rightDualTensorIso Y Z).inv ▷ (Xᘁ : A)) ▷ + ((X ⊗ Y) ⊗ Z)) ≫ + ((((Y ⊗ Z)ᘁ : A) ⊗ (Xᘁ : A)) ◁ (α_ X Y Z).hom) ≫ + ε_ (X ⊗ (Y ⊗ Z)) (((Y ⊗ Z)ᘁ : A) ⊗ (Xᘁ : A)) + = ((((Zᘁ : A) ⊗ (Yᘁ : A)) ⊗ (Xᘁ : A)) ◁ + (α_ X Y Z).hom) ≫ + (((rightDualTensorIso Y Z).inv ▷ (Xᘁ : A)) ▷ + (X ⊗ (Y ⊗ Z))) ≫ + ε_ (X ⊗ (Y ⊗ Z)) + (((Y ⊗ Z)ᘁ : A) ⊗ (Xᘁ : A)) := by + rw [← whisker_exchange_assoc] + _ = ((((Zᘁ : A) ⊗ (Yᘁ : A)) ⊗ (Xᘁ : A)) ◁ + (α_ X Y Z).hom) ≫ + (𝟙 _ ⊗≫ + (((rightDualTensorIso Y Z).inv ▷ + (((Xᘁ : A) ⊗ X) ⊗ (Y ⊗ Z))) ≫ + (((Y ⊗ Z)ᘁ : A) ◁ + (ε_ X (Xᘁ) ▷ (Y ⊗ Z)))) ⊗≫ + ε_ (Y ⊗ Z) ((Y ⊗ Z)ᘁ)) := by + rw [ExactPairing.tensor_evaluation] + congr 1 + monoidal + _ = ((((Zᘁ : A) ⊗ (Yᘁ : A)) ⊗ (Xᘁ : A)) ◁ + (α_ X Y Z).hom) ≫ + (𝟙 _ ⊗≫ + ((((Zᘁ : A) ⊗ (Yᘁ : A)) ◁ + (ε_ X (Xᘁ) ▷ (Y ⊗ Z))) ≫ + ((rightDualTensorIso Y Z).inv ▷ + (𝟙_ A ⊗ (Y ⊗ Z)))) ⊗≫ + ε_ (Y ⊗ Z) ((Y ⊗ Z)ᘁ)) := by + rw [← whisker_exchange] + _ = ((((Zᘁ : A) ⊗ (Yᘁ : A)) ⊗ (Xᘁ : A)) ◁ + (α_ X Y Z).hom) ≫ + (𝟙 _ ⊗≫ ((Zᘁ : A) ⊗ (Yᘁ : A)) ◁ + (ε_ X (Xᘁ) ▷ (Y ⊗ Z)) ⊗≫ + (((rightDualTensorIso Y Z).inv ▷ (Y ⊗ Z)) ≫ + ε_ (Y ⊗ Z) ((Y ⊗ Z)ᘁ))) := by + congr 1 + monoidal + _ = ((((Zᘁ : A) ⊗ (Yᘁ : A)) ⊗ (Xᘁ : A)) ◁ + (α_ X Y Z).hom) ≫ + (𝟙 _ ⊗≫ ((Zᘁ : A) ⊗ (Yᘁ : A)) ◁ + (ε_ X (Xᘁ) ▷ (Y ⊗ Z)) ⊗≫ + (𝟙 _ ⊗≫ (Zᘁ : A) ◁ (ε_ Y (Yᘁ) ▷ Z) ⊗≫ + ε_ Z (Zᘁ))) := by + rw [rightDualTensorIso_inv_comp_evaluation, + ExactPairing.tensor_evaluation] + _ = ((α_ (Zᘁ : A) (Yᘁ : A) (Xᘁ : A)).hom ▷ + ((X ⊗ Y) ⊗ Z)) ≫ + (𝟙 _ ⊗≫ (Zᘁ : A) ◁ + ((𝟙 _ ⊗≫ (Yᘁ : A) ◁ (ε_ X (Xᘁ) ▷ Y) ⊗≫ + ε_ Y (Yᘁ)) ▷ Z) ⊗≫ + ε_ Z (Zᘁ)) := by + monoidal + +/-- Associativity of the composite dual comparisons: the full +source-side input of the Λ associativity, assembled from the +braid shuffle and the mate of the associator. -/ +theorem cAssoc [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + [BraidedCategory A] (X Y Z : A) : + (((β_ (Xᘁ : A) (Yᘁ : A)).hom ≫ + (rightDualTensorIso X Y).inv) ▷ (Zᘁ : A)) ≫ + (β_ ((X ⊗ Y)ᘁ : A) (Zᘁ : A)).hom ≫ + (rightDualTensorIso (X ⊗ Y) Z).inv = + (α_ (Xᘁ : A) (Yᘁ : A) (Zᘁ : A)).hom ≫ + ((Xᘁ : A) ◁ ((β_ (Yᘁ : A) (Zᘁ : A)).hom ≫ + (rightDualTensorIso Y Z).inv)) ≫ + (β_ (Xᘁ : A) ((Y ⊗ Z)ᘁ : A)).hom ≫ + (rightDualTensorIso X (Y ⊗ Z)).inv ≫ + (((α_ X Y Z).hom)ᘁ) := by + have hsq : ((Zᘁ : A) ◁ (rightDualTensorIso X Y).inv) ≫ + (rightDualTensorIso (X ⊗ Y) Z).inv = + (α_ (Zᘁ : A) (Yᘁ : A) (Xᘁ : A)).inv ≫ + ((rightDualTensorIso Y Z).inv ▷ (Xᘁ : A)) ≫ + (rightDualTensorIso X (Y ⊗ Z)).inv ≫ + (((α_ X Y Z).hom)ᘁ) := by + rw [← associator_mate_square, Iso.inv_hom_id_assoc] + rw [comp_whiskerRight, Category.assoc, + BraidedCategory.braiding_naturality_left_assoc, hsq, + reassoc_of% braid_shuffle, + ← BraidedCategory.braiding_naturality_right_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc] + +/-- The mate of the braiding through the dual-tensor +comparisons: the source-side kernel of the Λ commutativity. -/ +theorem braiding_mate_square + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + [SymmetricCategory A] (X Y : A) : + (rightDualTensorIso Y X).inv ≫ (((β_ X Y).hom)ᘁ) = + (β_ (Xᘁ : A) (Yᘁ : A)).hom ≫ + (rightDualTensorIso X Y).inv := by + refine eq_of_whiskerRight_comp_evaluation (P := X ⊗ Y) ?_ + rw [comp_whiskerRight, comp_whiskerRight, Category.assoc, + Category.assoc, rightAdjointMate_comp_evaluation, + ← whisker_exchange_assoc, + rightDualTensorIso_inv_comp_evaluation, + rightDualTensorIso_inv_comp_evaluation, + tensor_evaluation_braiding X Y (Xᘁ : A) (Yᘁ : A), + whisker_exchange_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + SymmetricCategory.symmetry, MonoidalCategory.whiskerLeft_id, + Category.id_comp] + +/-- The tensor dual comparison at the monoidal unit, pinned to +the rigid blanket instances that the Λ stages use. -/ +noncomputable def unitTensorDualIso + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + (Y : A) : + ((𝟙_ A ⊗ Y)ᘁ : A) ≅ (Yᘁ : A) ⊗ unitRigidDual := + @rightDualTensorIso A _ _ (𝟙_ A) Y + (RightRigidCategory.rightDual (𝟙_ A)) + (RightRigidCategory.rightDual Y) + (RightRigidCategory.rightDual (𝟙_ A ⊗ Y)) + +/-- The rigid evaluation of the monoidal unit, at the blanket +instance. -/ +noncomputable def unitRigidEvaluation + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] : + (unitRigidDual (A := A)) ⊗ 𝟙_ A ⟶ 𝟙_ A := + @ExactPairing.evaluation A _ _ (𝟙_ A) (unitRigidDual (A := A)) + (@HasRightDual.exact A _ _ (𝟙_ A) + (RightRigidCategory.rightDual (𝟙_ A))) + +/-- The unit comparison reduces the blanket evaluation of the +unit to the unit pairing. -/ +theorem unitRightDualIso_inv_comp_evaluation + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] : + ((unitRightDualIso (A := A)).inv ▷ (𝟙_ A)) ≫ + unitRigidEvaluation (A := A) = ε_ (𝟙_ A) (𝟙_ A) := by + have h := @rightAdjointMate_comp_evaluation A _ _ (𝟙_ A) + (𝟙_ A) (RightRigidCategory.rightDual (𝟙_ A)) ⟨𝟙_ A⟩ + (𝟙 (𝟙_ A)) + refine h.trans ?_ + rw [MonoidalCategory.whiskerLeft_id, Category.id_comp] + rfl + +/-- The pinned tensor dual comparison at the unit reduces the +rigid evaluation to the expanded tensor evaluation. -/ +theorem unitTensorDualIso_inv_comp_evaluation + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + (Y : A) : + ((unitTensorDualIso Y).inv ▷ (𝟙_ A ⊗ Y)) ≫ + ε_ (𝟙_ A ⊗ Y) ((𝟙_ A ⊗ Y)ᘁ) = + 𝟙 _ ⊗≫ (Yᘁ : A) ◁ + (unitRigidEvaluation (A := A) ▷ Y) ⊗≫ + ε_ Y (Yᘁ) := by + let pt : ExactPairing (𝟙_ A ⊗ Y) + ((Yᘁ : A) ⊗ unitRigidDual) := + @ExactPairing.tensor A _ _ (𝟙_ A) Y (unitRigidDual (A := A)) + (Yᘁ) (@HasRightDual.exact A _ _ (𝟙_ A) + (RightRigidCategory.rightDual (𝟙_ A))) inferInstance + have h := @rightAdjointMate_comp_evaluation A _ _ (𝟙_ A ⊗ Y) + (𝟙_ A ⊗ Y) inferInstance + ⟨(Yᘁ : A) ⊗ unitRigidDual⟩ (𝟙 (𝟙_ A ⊗ Y)) + refine h.trans ?_ + rw [MonoidalCategory.whiskerLeft_id, Category.id_comp] + rfl + +/-- The tensor dual comparison with the unit on the right, pinned +to the rigid blanket instances. -/ +noncomputable def tensorUnitDualIso + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + (Y : A) : + ((Y ⊗ 𝟙_ A)ᘁ : A) ≅ unitRigidDual ⊗ (Yᘁ : A) := + @rightDualTensorIso A _ _ Y (𝟙_ A) + (RightRigidCategory.rightDual Y) + (RightRigidCategory.rightDual (𝟙_ A)) + (RightRigidCategory.rightDual (Y ⊗ 𝟙_ A)) + +/-- The pinned tensor dual comparison with the unit on the right +reduces the rigid evaluation to the expanded tensor +evaluation. -/ +theorem tensorUnitDualIso_inv_comp_evaluation + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + (Y : A) : + ((tensorUnitDualIso Y).inv ▷ (Y ⊗ 𝟙_ A)) ≫ + ε_ (Y ⊗ 𝟙_ A) ((Y ⊗ 𝟙_ A)ᘁ) = + 𝟙 _ ⊗≫ (unitRigidDual (A := A)) ◁ + (ε_ Y (Yᘁ) ▷ (𝟙_ A)) ⊗≫ + unitRigidEvaluation (A := A) := by + let pt : ExactPairing (Y ⊗ 𝟙_ A) + ((unitRigidDual (A := A)) ⊗ (Yᘁ : A)) := + @ExactPairing.tensor A _ _ Y (𝟙_ A) (Yᘁ) + (unitRigidDual (A := A)) inferInstance + (@HasRightDual.exact A _ _ (𝟙_ A) + (RightRigidCategory.rightDual (𝟙_ A))) + have h := @rightAdjointMate_comp_evaluation A _ _ (Y ⊗ 𝟙_ A) + (Y ⊗ 𝟙_ A) inferInstance + ⟨(unitRigidDual (A := A)) ⊗ (Yᘁ : A)⟩ (𝟙 (Y ⊗ 𝟙_ A)) + refine h.trans ?_ + rw [MonoidalCategory.whiskerLeft_id, Category.id_comp] + rfl + +/-- The mate of the right unitor: the mirror of +`RS.leftUnitor_mate`. -/ +theorem rightUnitor_mate + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + [BraidedCategory A] + (Y : A) : + (ρ_ (Yᘁ : A)).inv ≫ + ((Yᘁ : A) ◁ (unitRightDualIso (A := A)).inv) ≫ + (β_ (Yᘁ : A) (unitRigidDual (A := A))).hom ≫ + (tensorUnitDualIso Y).inv = + (((ρ_ Y).hom)ᘁ) := by + have hβ2 : (β_ (Yᘁ : A) (𝟙_ A)).hom = + (ρ_ (Yᘁ : A)).hom ≫ (λ_ (Yᘁ : A)).inv := + (Iso.eq_comp_inv _).mpr (braiding_leftUnitor _) + have hε : ε_ (𝟙_ A) (𝟙_ A) = (ρ_ (𝟙_ A)).hom := rfl + refine eq_of_whiskerRight_comp_evaluation + (P := Y ⊗ 𝟙_ A) ?_ + rw [rightAdjointMate_comp_evaluation, comp_whiskerRight, + comp_whiskerRight, comp_whiskerRight, Category.assoc, + Category.assoc, Category.assoc, + tensorUnitDualIso_inv_comp_evaluation] + calc ((ρ_ (Yᘁ : A)).inv ▷ (Y ⊗ 𝟙_ A)) ≫ + (((Yᘁ : A) ◁ (unitRightDualIso (A := A)).inv) ▷ + (Y ⊗ 𝟙_ A)) ≫ + ((β_ (Yᘁ : A) (unitRigidDual (A := A))).hom ▷ + (Y ⊗ 𝟙_ A)) ≫ + (𝟙 _ ⊗≫ (unitRigidDual (A := A)) ◁ + (ε_ Y (Yᘁ) ▷ (𝟙_ A)) ⊗≫ + unitRigidEvaluation (A := A)) + = ((ρ_ (Yᘁ : A)).inv ▷ (Y ⊗ 𝟙_ A)) ≫ + (((β_ (Yᘁ : A) (𝟙_ A)).hom ≫ + ((unitRightDualIso (A := A)).inv ▷ (Yᘁ : A))) ▷ + (Y ⊗ 𝟙_ A)) ≫ + (𝟙 _ ⊗≫ (unitRigidDual (A := A)) ◁ + (ε_ Y (Yᘁ) ▷ (𝟙_ A)) ⊗≫ + unitRigidEvaluation (A := A)) := by + rw [← comp_whiskerRight_assoc + ((Yᘁ : A) ◁ (unitRightDualIso (A := A)).inv) + (β_ (Yᘁ : A) (unitRigidDual (A := A))).hom, + BraidedCategory.braiding_naturality_right, + comp_whiskerRight_assoc] + _ = ((ρ_ (Yᘁ : A)).inv ▷ (Y ⊗ 𝟙_ A)) ≫ + ((β_ (Yᘁ : A) (𝟙_ A)).hom ▷ (Y ⊗ 𝟙_ A)) ≫ + (𝟙 _ ⊗≫ + (((unitRightDualIso (A := A)).inv ▷ + (((Yᘁ : A) ⊗ Y) ⊗ 𝟙_ A)) ≫ + ((unitRigidDual (A := A)) ◁ + (ε_ Y (Yᘁ) ▷ (𝟙_ A)))) ⊗≫ + unitRigidEvaluation (A := A)) := by + rw [comp_whiskerRight_assoc] + congr 2 + monoidal + _ = ((ρ_ (Yᘁ : A)).inv ▷ (Y ⊗ 𝟙_ A)) ≫ + ((β_ (Yᘁ : A) (𝟙_ A)).hom ▷ (Y ⊗ 𝟙_ A)) ≫ + (𝟙 _ ⊗≫ + (((𝟙_ A) ◁ (ε_ Y (Yᘁ) ▷ (𝟙_ A))) ≫ + ((unitRightDualIso (A := A)).inv ▷ + ((𝟙_ A) ⊗ (𝟙_ A)))) ⊗≫ + unitRigidEvaluation (A := A)) := by + rw [← whisker_exchange] + _ = ((ρ_ (Yᘁ : A)).inv ▷ (Y ⊗ 𝟙_ A)) ≫ + ((β_ (Yᘁ : A) (𝟙_ A)).hom ▷ (Y ⊗ 𝟙_ A)) ≫ + (𝟙 _ ⊗≫ (𝟙_ A) ◁ (ε_ Y (Yᘁ) ▷ (𝟙_ A)) ⊗≫ + (((unitRightDualIso (A := A)).inv ▷ (𝟙_ A)) ≫ + unitRigidEvaluation (A := A))) := by + congr 2 + monoidal + _ = ((ρ_ (Yᘁ : A)).inv ▷ (Y ⊗ 𝟙_ A)) ≫ + (((ρ_ (Yᘁ : A)).hom ≫ (λ_ (Yᘁ : A)).inv) ▷ + (Y ⊗ 𝟙_ A)) ≫ + (𝟙 _ ⊗≫ (𝟙_ A) ◁ (ε_ Y (Yᘁ) ▷ (𝟙_ A)) ⊗≫ + (ρ_ (𝟙_ A)).hom) := by + rw [unitRightDualIso_inv_comp_evaluation, hε, hβ2] + _ = ((Yᘁ : A) ◁ (ρ_ Y).hom) ≫ ε_ Y (Yᘁ) := by + monoidal + +/-- The mate of the left unitor, expressed through the unit and +tensor dual comparisons: the source-side input of the Λ unit +law. -/ +theorem leftUnitor_mate + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + [BraidedCategory A] + (Y : A) : + (λ_ (Yᘁ : A)).inv ≫ + ((unitRightDualIso (A := A)).inv ▷ (Yᘁ : A)) ≫ + (β_ (unitRigidDual (A := A)) (Yᘁ : A)).hom ≫ + (unitTensorDualIso Y).inv = + (((λ_ Y).hom)ᘁ) := by + have hβ1 : (β_ (𝟙_ A) (Yᘁ : A)).hom = + (λ_ (Yᘁ : A)).hom ≫ (ρ_ (Yᘁ : A)).inv := + (Iso.eq_comp_inv _).mpr (braiding_rightUnitor _) + have hε : ε_ (𝟙_ A) (𝟙_ A) = (ρ_ (𝟙_ A)).hom := rfl + refine eq_of_whiskerRight_comp_evaluation + (P := 𝟙_ A ⊗ Y) ?_ + rw [rightAdjointMate_comp_evaluation, comp_whiskerRight, + comp_whiskerRight, comp_whiskerRight, Category.assoc, + Category.assoc, Category.assoc, + unitTensorDualIso_inv_comp_evaluation] + calc ((λ_ (Yᘁ : A)).inv ▷ (𝟙_ A ⊗ Y)) ≫ + (((unitRightDualIso (A := A)).inv ▷ (Yᘁ : A)) ▷ + (𝟙_ A ⊗ Y)) ≫ + ((β_ (unitRigidDual (A := A)) (Yᘁ : A)).hom ▷ + (𝟙_ A ⊗ Y)) ≫ + (𝟙 _ ⊗≫ (Yᘁ : A) ◁ + (unitRigidEvaluation (A := A) ▷ Y) ⊗≫ + ε_ Y (Yᘁ)) + = ((λ_ (Yᘁ : A)).inv ▷ (𝟙_ A ⊗ Y)) ≫ + (((β_ (𝟙_ A) (Yᘁ : A)).hom ≫ + ((Yᘁ : A) ◁ (unitRightDualIso (A := A)).inv)) ▷ + (𝟙_ A ⊗ Y)) ≫ + (𝟙 _ ⊗≫ (Yᘁ : A) ◁ + (unitRigidEvaluation (A := A) ▷ Y) ⊗≫ + ε_ Y (Yᘁ)) := by + rw [← comp_whiskerRight_assoc + ((unitRightDualIso (A := A)).inv ▷ (Yᘁ : A)) + (β_ (unitRigidDual (A := A)) (Yᘁ : A)).hom, + BraidedCategory.braiding_naturality_left, + comp_whiskerRight_assoc] + _ = ((λ_ (Yᘁ : A)).inv ▷ (𝟙_ A ⊗ Y)) ≫ + ((β_ (𝟙_ A) (Yᘁ : A)).hom ▷ (𝟙_ A ⊗ Y)) ≫ + (𝟙 _ ⊗≫ (Yᘁ : A) ◁ + ((((unitRightDualIso (A := A)).inv ▷ (𝟙_ A)) ≫ + unitRigidEvaluation (A := A)) ▷ Y) ⊗≫ + ε_ Y (Yᘁ)) := by + rw [comp_whiskerRight_assoc] + congr 2 + monoidal + _ = ((λ_ (Yᘁ : A)).inv ▷ (𝟙_ A ⊗ Y)) ≫ + (((λ_ (Yᘁ : A)).hom ≫ (ρ_ (Yᘁ : A)).inv) ▷ + (𝟙_ A ⊗ Y)) ≫ + (𝟙 _ ⊗≫ (Yᘁ : A) ◁ ((ρ_ (𝟙_ A)).hom ▷ Y) ⊗≫ + ε_ Y (Yᘁ)) := by + rw [unitRightDualIso_inv_comp_evaluation, hε, hβ1] + _ = ((Yᘁ : A) ◁ (λ_ Y).hom) ≫ ε_ Y (Yᘁ) := by + monoidal + +/-- The stage-level multiplication of the Λ object: middle-four +exchange, the tensorators of the two functors, and the comparison +of the dual of a product with the product of the duals. -/ +noncomputable def lambdaMulStage + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] [BraidedCategory A] + [BraidedCategory D] (α : A ⥤ D) (β : A ⥤ D) [α.LaxMonoidal] + [β.LaxMonoidal] + (X Y : A) : + (α.obj (Xᘁ) ⊗ β.obj X) ⊗ (α.obj (Yᘁ) ⊗ β.obj Y) ⟶ + α.obj ((X ⊗ Y)ᘁ) ⊗ β.obj (X ⊗ Y) := + tensorμ (α.obj (Xᘁ)) (β.obj X) (α.obj (Yᘁ)) (β.obj Y) ≫ + (μ α (Xᘁ) (Yᘁ) ⊗ₘ μ β X Y) ≫ + (α.map ((β_ (Xᘁ : A) (Yᘁ : A)).hom ≫ + (rightDualTensorIso X Y).inv) ▷ β.obj (X ⊗ Y)) + +/-- The stage-level associativity of the Λ multiplication. -/ +theorem lambdaMulStage_assoc + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] [BraidedCategory A] + [BraidedCategory D] (α : A ⥤ D) (β : A ⥤ D) [α.LaxMonoidal] + [β.LaxMonoidal] + [HasLambda α β] (X Y Z : A) : + (lambdaMulStage α β X Y ▷ (α.obj (Zᘁ) ⊗ β.obj Z)) ≫ + lambdaMulStage α β (X ⊗ Y) Z ≫ + lambdaStage α β ((X ⊗ Y) ⊗ Z) = + (α_ (α.obj (Xᘁ) ⊗ β.obj X) (α.obj (Yᘁ) ⊗ β.obj Y) + (α.obj (Zᘁ) ⊗ β.obj Z)).hom ≫ + ((α.obj (Xᘁ) ⊗ β.obj X) ◁ lambdaMulStage α β Y Z) ≫ + lambdaMulStage α β X (Y ⊗ Z) ≫ + lambdaStage α β (X ⊗ (Y ⊗ Z)) := by + rw [lambdaMulStage, lambdaMulStage, lambdaMulStage, + lambdaMulStage] + simp only [Category.assoc] + conv_lhs => + rw [comp_whiskerRight, comp_whiskerRight, + ← MonoidalCategory.tensorHom_id + (α.map ((β_ (Xᘁ : A) (Yᘁ : A)).hom ≫ + (rightDualTensorIso X Y).inv)) (β.obj (X ⊗ Y))] + rw [Category.assoc, Category.assoc, + tensorμ_natural_left_assoc, tensorμ_natural_left_assoc, + tensorHom_comp_tensorHom_assoc, + tensorHom_comp_tensorHom_assoc] + simp only [Category.assoc] + rw [Functor.LaxMonoidal.μ_natural_left, + MonoidalCategory.id_whiskerRight, Category.id_comp, + reassoc_of% Functor.LaxMonoidal.μ_whiskerRight_comp_μ α + (Xᘁ) (Yᘁ) (Zᘁ), + Functor.LaxMonoidal.μ_whiskerRight_comp_μ β X Y Z, + ← MonoidalCategory.tensorHom_id + (α.map ((β_ ((X ⊗ Y)ᘁ : A) (Zᘁ : A)).hom ≫ + (rightDualTensorIso (X ⊗ Y) Z).inv)) + (β.obj ((X ⊗ Y) ⊗ Z)), + tensorHom_comp_tensorHom_assoc, Category.comp_id] + simp only [← Functor.map_comp, Category.assoc] + have hA : (α_ (Xᘁ : A) (Yᘁ : A) (Zᘁ : A)).inv ≫ + (((β_ (Xᘁ : A) (Yᘁ : A)).hom ≫ + (rightDualTensorIso X Y).inv) ▷ (Zᘁ : A)) ≫ + (β_ ((X ⊗ Y)ᘁ : A) (Zᘁ : A)).hom ≫ + (rightDualTensorIso (X ⊗ Y) Z).inv = + (((Xᘁ : A) ◁ ((β_ (Yᘁ : A) (Zᘁ : A)).hom ≫ + (rightDualTensorIso Y Z).inv)) ≫ + ((β_ (Xᘁ : A) ((Y ⊗ Z)ᘁ : A)).hom ≫ + (rightDualTensorIso X (Y ⊗ Z)).inv)) ≫ + (((α_ X Y Z).hom)ᘁ) := by + rw [cAssoc, Iso.inv_hom_id_assoc] + simp only [Category.assoc] + have hstage : (α.map (((α_ X Y Z).hom)ᘁ) ⊗ₘ + β.map ((α_ X Y Z).inv)) ≫ + lambdaStage α β ((X ⊗ Y) ⊗ Z) = + lambdaStage α β (X ⊗ (Y ⊗ Z)) := by + rw [tensorHom_def'_assoc, lambdaStage_condition, + ← MonoidalCategory.whiskerLeft_comp_assoc, + ← Functor.map_comp, Iso.inv_hom_id, + CategoryTheory.Functor.map_id, + MonoidalCategory.whiskerLeft_id, Category.id_comp] + rw [hA, Functor.map_comp (g := (((α_ X Y Z).hom)ᘁ)), + ← tensorHom_comp_tensorHom_assoc, + ← Category.id_comp (β.map ((α_ X Y Z).inv)), + ← tensorHom_comp_tensorHom_assoc, + ← tensorHom_comp_tensorHom_assoc, + ← tensorHom_comp_tensorHom_assoc] + rw [hstage, MonoidalCategory.tensorHom_id, + reassoc_of% tensor_associativity (α.obj (Xᘁ)) (β.obj X) + (α.obj (Yᘁ)) (β.obj Y) (α.obj (Zᘁ)) (β.obj Z)] + rw [MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rw [← MonoidalCategory.tensorHom_id + (α.map ((β_ (Yᘁ : A) (Zᘁ : A)).hom ≫ + (rightDualTensorIso Y Z).inv)) (β.obj (Y ⊗ Z)), + MonoidalCategory.whiskerLeft_comp, + Category.assoc, tensorμ_natural_right_assoc, + tensorμ_natural_right_assoc, + tensorHom_comp_tensorHom_assoc, + tensorHom_comp_tensorHom_assoc, + tensorHom_comp_tensorHom_assoc] + simp only [Category.assoc] + rw [Functor.LaxMonoidal.μ_natural_right, + MonoidalCategory.whiskerLeft_id, Category.id_comp, + ← Category.comp_id (Functor.LaxMonoidal.μ β X (Y ⊗ Z)), + ← tensorHom_comp_tensorHom_assoc, + ← tensorHom_comp_tensorHom_assoc, + ← tensorHom_comp_tensorHom_assoc, + MonoidalCategory.tensorHom_id, Category.comp_id, + ← comp_whiskerRight_assoc, ← Functor.map_comp] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + +/-- Dinaturality of the stage-level multiplication in the right +variable: the input of the inner coend descent of the Λ +multiplication. -/ +theorem lambdaMulStage_dinat_right + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] [BraidedCategory A] + [BraidedCategory D] (α : A ⥤ D) (β : A ⥤ D) [α.LaxMonoidal] + [β.LaxMonoidal] + [HasLambda α β] (X : A) + {Y Y' : A} (g : Y ⟶ Y') : + ((α.obj (Xᘁ) ⊗ β.obj X) ◁ (α.map (gᘁ) ▷ β.obj Y)) ≫ + lambdaMulStage α β X Y ≫ lambdaStage α β (X ⊗ Y) = + ((α.obj (Xᘁ) ⊗ β.obj X) ◁ (α.obj (Y'ᘁ) ◁ β.map g)) ≫ + lambdaMulStage α β X Y' ≫ lambdaStage α β (X ⊗ Y') := by + have hc : (Xᘁ : A) ◁ (gᘁ) ≫ (β_ (Xᘁ : A) (Yᘁ : A)).hom ≫ + (rightDualTensorIso X Y).inv = + ((β_ (Xᘁ : A) (Y'ᘁ : A)).hom ≫ + (rightDualTensorIso X Y').inv) ≫ ((X ◁ g)ᘁ) := by + rw [BraidedCategory.braiding_naturality_right_assoc, + whiskerLeft_mate_square, Category.assoc] + rw [lambdaMulStage, lambdaMulStage] + simp only [Category.assoc] + conv_lhs => + rw [← MonoidalCategory.tensorHom_id (α.map (gᘁ)) (β.obj Y), + tensorμ_natural_right_assoc, + tensorHom_comp_tensorHom_assoc, + Functor.LaxMonoidal.μ_natural_right, + MonoidalCategory.whiskerLeft_id, Category.id_comp, + ← Category.comp_id (Functor.LaxMonoidal.μ β X Y), + ← tensorHom_comp_tensorHom_assoc, + MonoidalCategory.tensorHom_id, + ← comp_whiskerRight_assoc, + ← Functor.map_comp, hc, + Functor.map_comp, comp_whiskerRight_assoc, + lambdaStage_condition, + ← whisker_exchange_assoc, + ← MonoidalCategory.id_tensorHom, + tensorHom_comp_tensorHom_assoc, Category.comp_id, + ← Functor.LaxMonoidal.μ_natural_right, + ← Category.id_comp (Functor.LaxMonoidal.μ α (Xᘁ) (Y'ᘁ)), + ← tensorHom_comp_tensorHom_assoc] + conv_rhs => + rw [← MonoidalCategory.id_tensorHom (α.obj (Y'ᘁ)) (β.map g), + tensorμ_natural_right_assoc, + MonoidalCategory.whiskerLeft_id] + +/-- The stage-level left unit computation: the Λ unit composed +into the multiplication at a stage collapses to the left +unitor. -/ +theorem lambdaMulStage_unit_left + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] [BraidedCategory A] + [BraidedCategory D] (α : A ⥤ D) (β : A ⥤ D) [α.LaxMonoidal] + [β.LaxMonoidal] + [HasLambda α β] (Y : A) : + ((λ_ (𝟙_ D)).inv ▷ (α.obj (Yᘁ) ⊗ β.obj Y)) ≫ + ((((ε α ≫ α.map unitRightDualIso.inv) ⊗ₘ ε β)) ▷ + (α.obj (Yᘁ) ⊗ β.obj Y)) ≫ + lambdaMulStage α β (𝟙_ A) Y ≫ + lambdaStage α β (𝟙_ A ⊗ Y) = + (λ_ (α.obj (Yᘁ) ⊗ β.obj Y)).hom ≫ lambdaStage α β Y := by + have hTL : ((λ_ (𝟙_ D)).inv ▷ (α.obj (Yᘁ) ⊗ β.obj Y)) ≫ + tensorμ (𝟙_ D) (𝟙_ D) (α.obj (Yᘁ)) (β.obj Y) = + (λ_ (α.obj (Yᘁ) ⊗ β.obj Y)).hom ≫ + ((λ_ (α.obj (Yᘁ))).inv ⊗ₘ (λ_ (β.obj Y)).inv) := by + rw [tensor_left_unitality] + simp only [Category.assoc, tensorHom_comp_tensorHom, + Iso.hom_inv_id, id_tensorHom_id, Category.comp_id] + change ((λ_ (𝟙_ D)).inv ▷ (α.obj (Yᘁ) ⊗ β.obj Y)) ≫ + ((((ε α ≫ α.map unitRightDualIso.inv) ⊗ₘ ε β)) ▷ + (α.obj (Yᘁ) ⊗ β.obj Y)) ≫ + (tensorμ (α.obj (unitRigidDual (A := A))) (β.obj (𝟙_ A)) + (α.obj (Yᘁ)) (β.obj Y) ≫ + (μ α (unitRigidDual (A := A)) (Yᘁ) ⊗ₘ μ β (𝟙_ A) Y) ≫ + (α.map ((β_ (unitRigidDual (A := A)) (Yᘁ : A)).hom ≫ + (unitTensorDualIso Y).inv) ▷ β.obj (𝟙_ A ⊗ Y))) ≫ + lambdaStage α β (𝟙_ A ⊗ Y) = + (λ_ (α.obj (Yᘁ) ⊗ β.obj Y)).hom ≫ lambdaStage α β Y + simp only [Category.assoc] + rw [tensorμ_natural_left_assoc, ← Category.assoc, hTL, + Category.assoc, tensorHom_comp_tensorHom_assoc, + tensorHom_comp_tensorHom_assoc] + simp only [Category.assoc] + rw [Functor.LaxMonoidal.left_unitality_inv, + comp_whiskerRight] + simp only [Category.assoc] + rw [Functor.LaxMonoidal.μ_natural_left, + reassoc_of% Functor.LaxMonoidal.left_unitality_inv, + ← MonoidalCategory.tensorHom_id + (α.map ((β_ (unitRigidDual (A := A)) (Yᘁ : A)).hom ≫ + (unitTensorDualIso Y).inv)) (β.obj (𝟙_ A ⊗ Y)), + tensorHom_comp_tensorHom_assoc, Category.comp_id, + ← Functor.map_comp, ← Functor.map_comp] + simp only [Category.assoc] + rw [leftUnitor_mate, + tensorHom_def'_assoc, lambdaStage_condition, + ← MonoidalCategory.whiskerLeft_comp_assoc, + ← Functor.map_comp, Iso.inv_hom_id, + CategoryTheory.Functor.map_id, + MonoidalCategory.whiskerLeft_id, Category.id_comp] + +/-- Dinaturality of the stage-level multiplication in the left +variable: the input of the outer coend descent of the Λ +multiplication. -/ +theorem lambdaMulStage_dinat_left + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] [BraidedCategory A] + [BraidedCategory D] (α : A ⥤ D) (β : A ⥤ D) [α.LaxMonoidal] + [β.LaxMonoidal] + [HasLambda α β] {X X' : A} + (f : X ⟶ X') (Y : A) : + ((α.map (fᘁ) ▷ β.obj X) ▷ (α.obj (Yᘁ) ⊗ β.obj Y)) ≫ + lambdaMulStage α β X Y ≫ lambdaStage α β (X ⊗ Y) = + ((α.obj (X'ᘁ) ◁ β.map f) ▷ (α.obj (Yᘁ) ⊗ β.obj Y)) ≫ + lambdaMulStage α β X' Y ≫ lambdaStage α β (X' ⊗ Y) := by + have hc : (fᘁ) ▷ (Yᘁ : A) ≫ (β_ (Xᘁ : A) (Yᘁ : A)).hom ≫ + (rightDualTensorIso X Y).inv = + ((β_ (X'ᘁ : A) (Yᘁ : A)).hom ≫ + (rightDualTensorIso X' Y).inv) ≫ ((f ▷ Y)ᘁ) := by + rw [BraidedCategory.braiding_naturality_left_assoc, + whiskerRight_mate_square, Category.assoc] + rw [lambdaMulStage, lambdaMulStage] + simp only [Category.assoc] + conv_lhs => + rw [← MonoidalCategory.tensorHom_id (α.map (fᘁ)) (β.obj X), + tensorμ_natural_left_assoc, + tensorHom_comp_tensorHom_assoc, + Functor.LaxMonoidal.μ_natural_left, + MonoidalCategory.id_whiskerRight, Category.id_comp, + ← Category.comp_id (Functor.LaxMonoidal.μ β X Y), + ← tensorHom_comp_tensorHom_assoc, + MonoidalCategory.tensorHom_id, + ← comp_whiskerRight_assoc, + ← Functor.map_comp, hc, + Functor.map_comp, comp_whiskerRight_assoc, + lambdaStage_condition, + ← whisker_exchange_assoc, + ← MonoidalCategory.id_tensorHom, + tensorHom_comp_tensorHom_assoc, Category.comp_id, + ← Functor.LaxMonoidal.μ_natural_left, + ← Category.id_comp + (Functor.LaxMonoidal.μ α (X'ᘁ) (Yᘁ)), + ← tensorHom_comp_tensorHom_assoc] + conv_rhs => + rw [← MonoidalCategory.id_tensorHom (α.obj (X'ᘁ)) + (β.map f), + tensorμ_natural_left_assoc, + MonoidalCategory.id_whiskerRight] + +/-- The inner descent of the Λ multiplication: for a fixed left +stage, the stage-level multiplication descends through the right +coend. -/ +noncomputable def lambdaMulLeft + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] [BraidedCategory A] + [BraidedCategory D] (α : A ⥤ D) (β : A ⥤ D) [α.LaxMonoidal] + [β.LaxMonoidal] + [HasLambda α β] (X : A) + [PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorLeft (α.obj (Xᘁ) ⊗ β.obj X))] : + (α.obj (Xᘁ) ⊗ β.obj X) ⊗ lambdaObj α β ⟶ lambdaObj α β := + tensorLeftCoendDesc (lambdaDiagram α β) _ + (fun Y => lambdaMulStage α β X Y ≫ lambdaStage α β (X ⊗ Y)) + (fun _ _ g => lambdaMulStage_dinat_right α β X g) + +@[reassoc] +theorem whiskerLeft_stage_lambdaMulLeft + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] [BraidedCategory A] + [BraidedCategory D] (α : A ⥤ D) (β : A ⥤ D) [α.LaxMonoidal] + [β.LaxMonoidal] + [HasLambda α β] (X : A) + [PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorLeft (α.obj (Xᘁ) ⊗ β.obj X))] (Y : A) : + ((α.obj (Xᘁ) ⊗ β.obj X) ◁ lambdaStage α β Y) ≫ + lambdaMulLeft α β X = + lambdaMulStage α β X Y ≫ lambdaStage α β (X ⊗ Y) := + whiskerLeft_ι_tensorLeftCoendDesc (lambdaDiagram α β) _ _ _ Y + +/-- Dinaturality of the inner descent in the left variable. -/ +theorem lambdaMulLeft_dinat + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] [BraidedCategory A] + [BraidedCategory D] (α : A ⥤ D) (β : A ⥤ D) [α.LaxMonoidal] + [β.LaxMonoidal] + [HasLambda α β] + [∀ W : D, PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorLeft W)] {X X' : A} (f : X ⟶ X') : + ((α.map (fᘁ) ▷ β.obj X) ▷ lambdaObj α β) ≫ + lambdaMulLeft α β X = + ((α.obj (X'ᘁ) ◁ β.map f) ▷ lambdaObj α β) ≫ + lambdaMulLeft α β X' := by + refine tensorLeft_coend_hom_ext (lambdaDiagram α β) + (α.obj (X'ᘁ) ⊗ β.obj X) (fun Y => ?_) + change ((α.obj (X'ᘁ) ⊗ β.obj X) ◁ lambdaStage α β Y) ≫ + ((α.map (fᘁ) ▷ β.obj X) ▷ lambdaObj α β) ≫ + lambdaMulLeft α β X = + ((α.obj (X'ᘁ) ⊗ β.obj X) ◁ lambdaStage α β Y) ≫ + ((α.obj (X'ᘁ) ◁ β.map f) ▷ lambdaObj α β) ≫ + lambdaMulLeft α β X' + rw [whisker_exchange_assoc, whisker_exchange_assoc, + whiskerLeft_stage_lambdaMulLeft, + whiskerLeft_stage_lambdaMulLeft, + lambdaMulStage_dinat_left] + +/-- **The Λ multiplication** (Deligne 3.7's product): the +stage-level multiplication descended through both coend +variables. -/ +noncomputable def lambdaMul + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] [BraidedCategory A] + [BraidedCategory D] (α : A ⥤ D) (β : A ⥤ D) [α.LaxMonoidal] + [β.LaxMonoidal] + [HasLambda α β] + [∀ W : D, PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorLeft W)] + [PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorRight (lambdaObj α β))] : + lambdaObj α β ⊗ lambdaObj α β ⟶ lambdaObj α β := + tensorRightCoendDesc (lambdaDiagram α β) (lambdaObj α β) + (fun X => lambdaMulLeft α β X) + (fun _ _ f => lambdaMulLeft_dinat α β f) + +@[reassoc (attr := simp)] +theorem stage_whiskerRight_lambdaMul + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] [BraidedCategory A] + [BraidedCategory D] (α : A ⥤ D) (β : A ⥤ D) [α.LaxMonoidal] + [β.LaxMonoidal] + [HasLambda α β] + [∀ W : D, PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorLeft W)] + [PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorRight (lambdaObj α β))] (X : A) : + (lambdaStage α β X ▷ lambdaObj α β) ≫ lambdaMul α β = + lambdaMulLeft α β X := + ι_whiskerRight_tensorRightCoendDesc (lambdaDiagram α β) _ _ _ X + +/-- The two-stage computation of the Λ multiplication. -/ +theorem stage_tensorHom_lambdaMul + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] [BraidedCategory A] + [BraidedCategory D] (α : A ⥤ D) (β : A ⥤ D) [α.LaxMonoidal] + [β.LaxMonoidal] + [HasLambda α β] + [∀ W : D, PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorLeft W)] + [PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorRight (lambdaObj α β))] (X Y : A) : + (lambdaStage α β X ⊗ₘ lambdaStage α β Y) ≫ lambdaMul α β = + lambdaMulStage α β X Y ≫ lambdaStage α β (X ⊗ Y) := by + rw [tensorHom_def, Category.assoc, ← whisker_exchange_assoc, + stage_whiskerRight_lambdaMul, + whiskerLeft_stage_lambdaMulLeft] + +/-- **The left unit law of the Λ algebra**: the Λ unit composed +into the Λ multiplication is the left unitor. -/ +theorem lambdaMul_unit_left + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] [BraidedCategory A] + [BraidedCategory D] (α : A ⥤ D) (β : A ⥤ D) [α.LaxMonoidal] + [β.LaxMonoidal] + [HasLambda α β] + [∀ W : D, PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorLeft W)] + [PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorRight (lambdaObj α β))] : + (lambdaUnit α β ▷ lambdaObj α β) ≫ lambdaMul α β = + (λ_ (lambdaObj α β)).hom := by + refine tensorLeft_coend_hom_ext (lambdaDiagram α β) (𝟙_ D) + (fun Y => ?_) + change (𝟙_ D ◁ lambdaStage α β Y) ≫ + (lambdaUnit α β ▷ lambdaObj α β) ≫ lambdaMul α β = + (𝟙_ D ◁ lambdaStage α β Y) ≫ (λ_ (lambdaObj α β)).hom + erw [lambdaUnit, comp_whiskerRight, comp_whiskerRight] + simp only [Category.assoc] + change (𝟙_ D ◁ lambdaStage α β Y) ≫ + ((λ_ (𝟙_ D)).inv ▷ lambdaObj α β) ≫ + (((ε α ≫ α.map unitRightDualIso.inv) ⊗ₘ ε β) ▷ + lambdaObj α β) ≫ + (lambdaStage α β (𝟙_ A) ▷ lambdaObj α β) ≫ + lambdaMul α β = + (𝟙_ D ◁ lambdaStage α β Y) ≫ (λ_ (lambdaObj α β)).hom + erw [stage_whiskerRight_lambdaMul] + erw [whisker_exchange_assoc, whisker_exchange_assoc] + erw [whiskerLeft_stage_lambdaMulLeft] + erw [lambdaMulStage_unit_left] + rw [leftUnitor_naturality] + +/-- The stage-level right unit computation: the mirror of +`RS.lambdaMulStage_unit_left`. -/ +theorem lambdaMulStage_unit_right + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] [BraidedCategory A] + [BraidedCategory D] (α : A ⥤ D) (β : A ⥤ D) [α.LaxMonoidal] + [β.LaxMonoidal] + [HasLambda α β] (Y : A) : + ((α.obj (Yᘁ) ⊗ β.obj Y) ◁ (λ_ (𝟙_ D)).inv) ≫ + ((α.obj (Yᘁ) ⊗ β.obj Y) ◁ + ((ε α ≫ α.map unitRightDualIso.inv) ⊗ₘ ε β)) ≫ + lambdaMulStage α β Y (𝟙_ A) ≫ + lambdaStage α β (Y ⊗ 𝟙_ A) = + (ρ_ (α.obj (Yᘁ) ⊗ β.obj Y)).hom ≫ lambdaStage α β Y := by + have hTR : ((α.obj (Yᘁ) ⊗ β.obj Y) ◁ (λ_ (𝟙_ D)).inv) ≫ + tensorμ (α.obj (Yᘁ)) (β.obj Y) (𝟙_ D) (𝟙_ D) = + (ρ_ (α.obj (Yᘁ) ⊗ β.obj Y)).hom ≫ + ((ρ_ (α.obj (Yᘁ))).inv ⊗ₘ (ρ_ (β.obj Y)).inv) := by + rw [tensor_right_unitality] + simp only [Category.assoc, tensorHom_comp_tensorHom, + Iso.hom_inv_id, id_tensorHom_id, Category.comp_id] + change ((α.obj (Yᘁ) ⊗ β.obj Y) ◁ (λ_ (𝟙_ D)).inv) ≫ + ((α.obj (Yᘁ) ⊗ β.obj Y) ◁ + ((ε α ≫ α.map unitRightDualIso.inv) ⊗ₘ ε β)) ≫ + (tensorμ (α.obj (Yᘁ)) (β.obj Y) + (α.obj (unitRigidDual (A := A))) (β.obj (𝟙_ A)) ≫ + (μ α (Yᘁ) (unitRigidDual (A := A)) ⊗ₘ μ β Y (𝟙_ A)) ≫ + (α.map ((β_ (Yᘁ : A) (unitRigidDual (A := A))).hom ≫ + (tensorUnitDualIso Y).inv) ▷ β.obj (Y ⊗ 𝟙_ A))) ≫ + lambdaStage α β (Y ⊗ 𝟙_ A) = + (ρ_ (α.obj (Yᘁ) ⊗ β.obj Y)).hom ≫ lambdaStage α β Y + simp only [Category.assoc] + rw [tensorμ_natural_right_assoc, ← Category.assoc, hTR, + Category.assoc, tensorHom_comp_tensorHom_assoc, + tensorHom_comp_tensorHom_assoc] + simp only [Category.assoc] + rw [Functor.LaxMonoidal.right_unitality_inv, + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rw [Functor.LaxMonoidal.μ_natural_right, + reassoc_of% Functor.LaxMonoidal.right_unitality_inv, + ← MonoidalCategory.tensorHom_id + (α.map ((β_ (Yᘁ : A) (unitRigidDual (A := A))).hom ≫ + (tensorUnitDualIso Y).inv)) (β.obj (Y ⊗ 𝟙_ A)), + tensorHom_comp_tensorHom_assoc, Category.comp_id, + ← Functor.map_comp, ← Functor.map_comp] + simp only [Category.assoc] + rw [rightUnitor_mate, + tensorHom_def'_assoc, lambdaStage_condition, + ← MonoidalCategory.whiskerLeft_comp_assoc, + ← Functor.map_comp, Iso.inv_hom_id, + CategoryTheory.Functor.map_id, + MonoidalCategory.whiskerLeft_id, Category.id_comp] + +/-- **The right unit law of the Λ algebra**. -/ +theorem lambdaMul_unit_right + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] [BraidedCategory A] + [BraidedCategory D] (α : A ⥤ D) (β : A ⥤ D) [α.LaxMonoidal] + [β.LaxMonoidal] + [HasLambda α β] + [∀ W : D, PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorLeft W)] + [PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorRight (lambdaObj α β))] + [PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorRight (𝟙_ D))] : + (lambdaObj α β ◁ lambdaUnit α β) ≫ lambdaMul α β = + (ρ_ (lambdaObj α β)).hom := by + refine tensorRight_coend_hom_ext (lambdaDiagram α β) (𝟙_ D) + (fun X => ?_) + change (lambdaStage α β X ▷ 𝟙_ D) ≫ + (lambdaObj α β ◁ lambdaUnit α β) ≫ lambdaMul α β = + (lambdaStage α β X ▷ 𝟙_ D) ≫ (ρ_ (lambdaObj α β)).hom + rw [← whisker_exchange_assoc] + erw [stage_whiskerRight_lambdaMul] + erw [lambdaUnit, MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + erw [whiskerLeft_stage_lambdaMulLeft] + erw [lambdaMulStage_unit_right] + rw [rightUnitor_naturality] + +/-- Maps out of the triple tensor of the Λ object agree once +they agree on triples of stages. -/ +theorem lambda_triple_hom_ext + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] [BraidedCategory D] + (α : A ⥤ D) (β : A ⥤ D) + [HasLambda α β] + [∀ W : D, PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorLeft W)] + [∀ W : D, PreservesColimit + ((multispanIndexCoend (lambdaDiagram α β)).multispan ⋙ + tensorRight (lambdaObj α β)) (tensorRight W)] + [∀ W W' : D, PreservesColimit + ((multispanIndexCoend (lambdaDiagram α β)).multispan ⋙ + tensorLeft W) (tensorRight W')] + {Z : D} + {f g : (lambdaObj α β ⊗ lambdaObj α β) ⊗ lambdaObj α β ⟶ Z} + (h : ∀ X Y W', + ((lambdaStage α β X ⊗ₘ lambdaStage α β Y) ⊗ₘ + lambdaStage α β W') ≫ f = + ((lambdaStage α β X ⊗ₘ lambdaStage α β Y) ⊗ₘ + lambdaStage α β W') ≫ g) : f = g := by + refine tensorLeft_coend_hom_ext (lambdaDiagram α β) + (lambdaObj α β ⊗ lambdaObj α β) (fun W' => ?_) + refine coend_hom_ext_of_preserves (lambdaDiagram α β) + (tensorRight (lambdaObj α β) ⋙ + tensorRight (α.obj (W'ᘁ) ⊗ β.obj W')) (fun X => ?_) + refine coend_hom_ext_of_preserves (lambdaDiagram α β) + (tensorLeft (α.obj (Xᘁ) ⊗ β.obj X) ⋙ + tensorRight (α.obj (W'ᘁ) ⊗ β.obj W')) (fun Y => ?_) + change (((α.obj (Xᘁ) ⊗ β.obj X) ◁ lambdaStage α β Y) ▷ + (α.obj (W'ᘁ) ⊗ β.obj W')) ≫ + ((lambdaStage α β X ▷ lambdaObj α β) ▷ + (α.obj (W'ᘁ) ⊗ β.obj W')) ≫ + (((lambdaObj α β ⊗ lambdaObj α β) ◁ + lambdaStage α β W') ≫ f) = + (((α.obj (Xᘁ) ⊗ β.obj X) ◁ lambdaStage α β Y) ▷ + (α.obj (W'ᘁ) ⊗ β.obj W')) ≫ + ((lambdaStage α β X ▷ lambdaObj α β) ▷ + (α.obj (W'ᘁ) ⊗ β.obj W')) ≫ + (((lambdaObj α β ⊗ lambdaObj α β) ◁ + lambdaStage α β W') ≫ g) + have hpack : ∀ {Z' : D} + (k : (lambdaObj α β ⊗ lambdaObj α β) ⊗ lambdaObj α β ⟶ Z'), + (((α.obj (Xᘁ) ⊗ β.obj X) ◁ lambdaStage α β Y) ▷ + (α.obj (W'ᘁ) ⊗ β.obj W')) ≫ + ((lambdaStage α β X ▷ lambdaObj α β) ▷ + (α.obj (W'ᘁ) ⊗ β.obj W')) ≫ + (((lambdaObj α β ⊗ lambdaObj α β) ◁ + lambdaStage α β W') ≫ k) = + ((lambdaStage α β X ⊗ₘ lambdaStage α β Y) ⊗ₘ + lambdaStage α β W') ≫ k := by + intro Z' k + rw [tensorHom_def, tensorHom_def', comp_whiskerRight] + simp only [Category.assoc] + rw [hpack f, hpack g] + exact h X Y W' + +/-- **Associativity of the Λ multiplication** (Deligne 3.8). -/ +theorem lambdaMul_assoc + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] [BraidedCategory A] + [BraidedCategory D] (α : A ⥤ D) (β : A ⥤ D) [α.LaxMonoidal] + [β.LaxMonoidal] + [HasLambda α β] + [∀ W : D, PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorLeft W)] + [PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorRight (lambdaObj α β))] + [∀ W : D, PreservesColimit + ((multispanIndexCoend (lambdaDiagram α β)).multispan ⋙ + tensorRight (lambdaObj α β)) (tensorRight W)] + [∀ W W' : D, PreservesColimit + ((multispanIndexCoend (lambdaDiagram α β)).multispan ⋙ + tensorLeft W) (tensorRight W')] : + (lambdaMul α β ▷ lambdaObj α β) ≫ lambdaMul α β = + (α_ (lambdaObj α β) (lambdaObj α β) + (lambdaObj α β)).hom ≫ + (lambdaObj α β ◁ lambdaMul α β) ≫ lambdaMul α β := by + refine lambda_triple_hom_ext α β (fun X Y Z => ?_) + calc ((lambdaStage α β X ⊗ₘ lambdaStage α β Y) ⊗ₘ + lambdaStage α β Z) ≫ + (lambdaMul α β ▷ lambdaObj α β) ≫ lambdaMul α β + = (lambdaMulStage α β X Y ▷ + (α.obj (Zᘁ) ⊗ β.obj Z)) ≫ + lambdaMulStage α β (X ⊗ Y) Z ≫ + lambdaStage α β ((X ⊗ Y) ⊗ Z) := by + rw [← MonoidalCategory.tensorHom_id (lambdaMul α β), + tensorHom_comp_tensorHom_assoc, + stage_tensorHom_lambdaMul, Category.comp_id, + ← Category.id_comp (lambdaStage α β Z), + ← tensorHom_comp_tensorHom_assoc, + stage_tensorHom_lambdaMul, + MonoidalCategory.tensorHom_id] + _ = (α_ (α.obj (Xᘁ) ⊗ β.obj X) (α.obj (Yᘁ) ⊗ β.obj Y) + (α.obj (Zᘁ) ⊗ β.obj Z)).hom ≫ + ((α.obj (Xᘁ) ⊗ β.obj X) ◁ lambdaMulStage α β Y Z) ≫ + lambdaMulStage α β X (Y ⊗ Z) ≫ + lambdaStage α β (X ⊗ (Y ⊗ Z)) := + lambdaMulStage_assoc α β X Y Z + _ = ((lambdaStage α β X ⊗ₘ lambdaStage α β Y) ⊗ₘ + lambdaStage α β Z) ≫ + (α_ (lambdaObj α β) (lambdaObj α β) + (lambdaObj α β)).hom ≫ + (lambdaObj α β ◁ lambdaMul α β) ≫ lambdaMul α β := by + rw [associator_naturality_assoc, + ← MonoidalCategory.id_tensorHom (lambdaObj α β) + (lambdaMul α β), + tensorHom_comp_tensorHom_assoc, + stage_tensorHom_lambdaMul, Category.comp_id, + ← Category.id_comp (lambdaStage α β X), + ← tensorHom_comp_tensorHom_assoc, + stage_tensorHom_lambdaMul, + MonoidalCategory.id_tensorHom] + +/-- Maps out of the square of the Λ object agree once they agree +on pairs of stages. -/ +theorem lambda_pair_hom_ext + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] (α : A ⥤ D) + (β : A ⥤ D) + [HasLambda α β] + [∀ W : D, PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorLeft W)] + [PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorRight (lambdaObj α β))] + {Z : D} {f g : lambdaObj α β ⊗ lambdaObj α β ⟶ Z} + (h : ∀ X Y, + (lambdaStage α β X ⊗ₘ lambdaStage α β Y) ≫ f = + (lambdaStage α β X ⊗ₘ lambdaStage α β Y) ≫ g) : + f = g := by + refine tensorRight_coend_hom_ext (lambdaDiagram α β) + (lambdaObj α β) (fun X => ?_) + refine tensorLeft_coend_hom_ext (lambdaDiagram α β) + (α.obj (Xᘁ) ⊗ β.obj X) (fun Y => ?_) + change ((α.obj (Xᘁ) ⊗ β.obj X) ◁ lambdaStage α β Y) ≫ + ((lambdaStage α β X ▷ lambdaObj α β) ≫ f) = + ((α.obj (Xᘁ) ⊗ β.obj X) ◁ lambdaStage α β Y) ≫ + ((lambdaStage α β X ▷ lambdaObj α β) ≫ g) + have hpack : ∀ {Z' : D} + (k : lambdaObj α β ⊗ lambdaObj α β ⟶ Z'), + ((α.obj (Xᘁ) ⊗ β.obj X) ◁ lambdaStage α β Y) ≫ + ((lambdaStage α β X ▷ lambdaObj α β) ≫ k) = + (lambdaStage α β X ⊗ₘ lambdaStage α β Y) ≫ k := by + intro Z' k + rw [tensorHom_def'] + simp only [Category.assoc] + rw [hpack f, hpack g] + exact h X Y + +/-- **The Λ algebra** (Deligne 3.7): the coend of a pair of lax +monoidal functors from a braided rigid source is a monoid +object, with the stage at the unit as unit and the descended +stage-level multiplication as product. -/ +@[implicit_reducible] +noncomputable def lambdaMonObj + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] [BraidedCategory A] + [BraidedCategory D] (α : A ⥤ D) (β : A ⥤ D) [α.LaxMonoidal] + [β.LaxMonoidal] + [HasLambda α β] + [∀ W : D, PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorLeft W)] + [PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorRight (lambdaObj α β))] + [PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorRight (𝟙_ D))] + [∀ W : D, PreservesColimit + ((multispanIndexCoend (lambdaDiagram α β)).multispan ⋙ + tensorRight (lambdaObj α β)) (tensorRight W)] + [∀ W W' : D, PreservesColimit + ((multispanIndexCoend (lambdaDiagram α β)).multispan ⋙ + tensorLeft W) (tensorRight W')] : + MonObj (lambdaObj α β) where + one := lambdaUnit α β + mul := lambdaMul α β + one_mul := lambdaMul_unit_left α β + mul_one := lambdaMul_unit_right α β + mul_assoc := lambdaMul_assoc α β + +/-- The stage-level multiplication is natural in the pair of +monoidal transformations. -/ +theorem lambdaMulStage_map + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] [BraidedCategory A] + [BraidedCategory D] (α : A ⥤ D) (β : A ⥤ D) [α.LaxMonoidal] + [β.LaxMonoidal] + {α' β' : A ⥤ D} [α'.LaxMonoidal] + [β'.LaxMonoidal] (η : α ⟶ α') (τ : β ⟶ β') + [NatTrans.IsMonoidal η] [NatTrans.IsMonoidal τ] (X Y : A) : + lambdaMulStage α β X Y ≫ + (η.app ((X ⊗ Y)ᘁ) ⊗ₘ τ.app (X ⊗ Y)) = + ((η.app (Xᘁ) ⊗ₘ τ.app X) ⊗ₘ (η.app (Yᘁ) ⊗ₘ τ.app Y)) ≫ + lambdaMulStage α' β' X Y := by + rw [lambdaMulStage, lambdaMulStage] + simp only [Category.assoc] + rw [tensorμ_natural_assoc, tensorHom_comp_tensorHom_assoc, + ← NatTrans.IsMonoidal.tensor (τ := η), + ← NatTrans.IsMonoidal.tensor (τ := τ), + ← tensorHom_comp_tensorHom_assoc] + congr 1 + congr 1 + rw [tensorHom_def, ← comp_whiskerRight_assoc, η.naturality, + comp_whiskerRight_assoc, ← whisker_exchange, + ← tensorHom_def_assoc] + +end Multiplication + +section Commutativity + +open Functor.LaxMonoidal + +/-- The stage-level commutativity of the Λ multiplication over a +symmetric source and target with braided functors. -/ +theorem lambdaMulStage_comm + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] + [SymmetricCategory A] [SymmetricCategory D] (α : A ⥤ D) (β : A ⥤ D) + [α.LaxBraided] [β.LaxBraided] + [HasLambda α β] (X Y : A) : + lambdaMulStage α β X Y ≫ lambdaStage α β (X ⊗ Y) = + (β_ (α.obj (Xᘁ) ⊗ β.obj X) + (α.obj (Yᘁ) ⊗ β.obj Y)).hom ≫ + lambdaMulStage α β Y X ≫ lambdaStage α β (Y ⊗ X) := by + have hc : (β_ (Xᘁ : A) (Yᘁ : A)).hom ≫ + (rightDualTensorIso X Y).inv = + (rightDualTensorIso Y X).inv ≫ (((β_ X Y).hom)ᘁ) := + (braiding_mate_square X Y).symm + have hins : (rightDualTensorIso Y X).inv = + (β_ (Xᘁ : A) (Yᘁ : A)).hom ≫ + ((β_ (Yᘁ : A) (Xᘁ : A)).hom ≫ + (rightDualTensorIso Y X).inv) := by + rw [← Category.assoc, SymmetricCategory.symmetry, + Category.id_comp] + rw [lambdaMulStage, lambdaMulStage] + simp only [Category.assoc] + conv_lhs => + rw [hc, Functor.map_comp, comp_whiskerRight_assoc, + lambdaStage_condition, ← whisker_exchange_assoc, + hins, Functor.map_comp] + rw [← MonoidalCategory.id_tensorHom + (α.obj ((Xᘁ : A) ⊗ (Yᘁ : A))) (β.map (β_ X Y).hom), + tensorHom_comp_tensorHom_assoc, Category.comp_id, + Functor.LaxBraided.braided, + comp_whiskerRight, Category.assoc, + ← MonoidalCategory.tensorHom_id + (α.map (β_ (Xᘁ : A) (Yᘁ : A)).hom) (β.obj (Y ⊗ X)), + tensorHom_comp_tensorHom_assoc, Category.comp_id, + Functor.LaxBraided.braided, + ← tensorHom_comp_tensorHom_assoc, + ← tensorμ_braiding_assoc] + +/-- **Commutativity of the Λ multiplication** (Deligne 3.8). -/ +theorem lambdaMul_comm + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] + [SymmetricCategory A] [SymmetricCategory D] (α : A ⥤ D) (β : A ⥤ D) + [α.LaxBraided] [β.LaxBraided] + [HasLambda α β] + [∀ W : D, PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorLeft W)] + [PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorRight (lambdaObj α β))] : + (β_ (lambdaObj α β) (lambdaObj α β)).hom ≫ lambdaMul α β = + lambdaMul α β := by + refine lambda_pair_hom_ext α β (fun X Y => ?_) + rw [reassoc_of% BraidedCategory.braiding_naturality + (lambdaStage α β X) (lambdaStage α β Y), + stage_tensorHom_lambdaMul α β Y X, + ← lambdaMulStage_comm, stage_tensorHom_lambdaMul] + +/-- **The Λ algebra is commutative** over symmetric data with +braided functors (Deligne 3.7–3.8 in full). -/ +theorem lambdaIsCommMonObj + [Category.{v} A] [MonoidalCategory A] [RightRigidCategory A] + {D : Type u'} [Category.{v'} D] [MonoidalCategory D] + [SymmetricCategory A] [SymmetricCategory D] (α : A ⥤ D) (β : A ⥤ D) + [α.LaxBraided] [β.LaxBraided] + [HasLambda α β] + [∀ W : D, PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorLeft W)] + [PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorRight (lambdaObj α β))] + [PreservesColimit + (multispanIndexCoend (lambdaDiagram α β)).multispan + (tensorRight (𝟙_ D))] + [∀ W : D, PreservesColimit + ((multispanIndexCoend (lambdaDiagram α β)).multispan ⋙ + tensorRight (lambdaObj α β)) (tensorRight W)] + [∀ W W' : D, PreservesColimit + ((multispanIndexCoend (lambdaDiagram α β)).multispan ⋙ + tensorLeft W) (tensorRight W')] : + letI : MonObj (lambdaObj α β) := lambdaMonObj α β + IsCommMonObj (lambdaObj α β) := by + let : MonObj (lambdaObj α β) := lambdaMonObj α β + exact ⟨lambdaMul_comm α β⟩ + +end Commutativity + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixDegenerate.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixDegenerate.lean new file mode 100644 index 0000000000..d922d853f6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixDegenerate.lean @@ -0,0 +1,292 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixSumPow + +/-! +# Mixed sums with degenerate counts + +The nonvanishing half of Deligne 1.9 was established for mixed +sums `L.mix (p + 1) (q + 1)` with both counts strictly positive. +Nothing in the argument needs that. The letter framework of +`MixedLetters` is stated at an arbitrary finite label type, the +super-trace computation behind `not_schurKilled_stdSuper` holds at +every pair of dimensions, and the only trace of positivity in the +existing chain is the shape of the objects carrying the letter +systems: an iterated binary sum `sumPow X k` has `k + 1` summands, +and the standard super object was equipped with letters only in +the form `stdSuper (p + 1) (q + 1)`. + +Both are avoidable. Here the ambient letter system is read off +directly from the indexed biproduct defining `L.mix r s`, whose +label type `Fin r ⊕ Fin s` is allowed to be empty, and the +`SuperVect` letter system is rebuilt on `stdSuper r s` at +arbitrary dimensions. The two sides are joined exactly as before, +giving the nonvanishing statement for all counts `r s : ℕ`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +/-- The parity of a mixed letter label at arbitrary counts: even +on the unit summands, odd on the line summands. -/ +abbrev mixParity (r s : ℕ) : Fin r ⊕ Fin s → Bool := + fun k => Sum.rec (fun _ => false) (fun _ => true) k + +/-! ## The letter system of a mixed sum -/ + +section AmbientLetters + +variable {D : Type u} + +/-- **The letter system of a mixed sum**, read off from the +indexed biproduct: the inclusions and projections of the summands, +with the unit summands even and the line summands odd. No +positivity of the counts is involved. -/ +noncomputable def OddLine.mixLetters + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasFiniteBiproducts D] [SymmetricCategory D] + (L : OddLine D) (r s : ℕ) : + MixedLetters (Fin r ⊕ Fin s) (mixParity r s) L.obj + (L.mix r s) where + ins k := + Sum.rec (fun i => biproduct.ι (L.mixFun r s) (Sum.inl i)) + (fun j => biproduct.ι (L.mixFun r s) (Sum.inr j)) k + prj k := + Sum.rec (fun i => biproduct.π (L.mixFun r s) (Sum.inl i)) + (fun j => biproduct.π (L.mixFun r s) (Sum.inr j)) k + ins_prj k := by + cases k with + | inl i => exact biproduct.ι_π_self (L.mixFun r s) (Sum.inl i) + | inr j => exact biproduct.ι_π_self (L.mixFun r s) (Sum.inr j) + ins_prj_ne {k k'} hkk' := by + cases k with + | inl i => + cases k' with + | inl i' => + exact biproduct.ι_π_ne (L.mixFun r s) + (fun h => hkk' (congrArg Sum.inl (Sum.inl.inj h))) + | inr j' => + exact biproduct.ι_π_ne (L.mixFun r s) (by simp) + | inr j => + cases k' with + | inl i' => + exact biproduct.ι_π_ne (L.mixFun r s) (by simp) + | inr j' => + exact biproduct.ι_π_ne (L.mixFun r s) + (fun h => hkk' (congrArg Sum.inr (Sum.inr.inj h))) + total := by + refine Eq.trans ?_ (biproduct.total (f := L.mixFun r s)) + refine Finset.sum_congr rfl fun k _ => ?_ + cases k with + | inl i => rfl + | inr j => rfl + +end AmbientLetters + +/-! ## The letter system of the standard super object + +The same letters on `stdSuper r s`, at arbitrary dimensions: unit +letters along the even coordinates, odd-line letters along the odd +coordinates. -/ + +section SuperLetters + +open scoped TensorProduct + +/-- The even component, as an additive map of homs. -/ +private def evenAdd (V W : SuperVect) : + (V ⟶ W) →+ (V.even →ₗ[ℂ] W.even) where + toFun f := SuperVect.Hom.evenMap f + map_zero' := rfl + map_add' _ _ := rfl + +/-- The odd component, as an additive map of homs. -/ +private def oddAdd (V W : SuperVect) : + (V ⟶ W) →+ (V.odd →ₗ[ℂ] W.odd) where + toFun f := SuperVect.Hom.oddMap f + map_zero' := rfl + map_add' _ _ := rfl + +/-- The inclusion of an even coordinate line. -/ +noncomputable def evenIn (r s : ℕ) (i : Fin r) : + 𝟙_ SuperVect ⟶ stdSuper r s where + evenMap := LinearMap.single ℂ (fun _ => ℂ) i + oddMap := 0 + +/-- The projection onto an even coordinate line. -/ +noncomputable def evenOut (r s : ℕ) (i : Fin r) : + stdSuper r s ⟶ 𝟙_ SuperVect where + evenMap := LinearMap.proj i + oddMap := 0 + +/-- The inclusion of an odd coordinate line. -/ +noncomputable def oddInto (r s : ℕ) (j : Fin s) : + stdSuper 0 1 ⟶ stdSuper r s where + evenMap := 0 + oddMap := + (LinearMap.single ℂ (fun _ => ℂ) j).comp + (LinearMap.proj (0 : Fin 1)) + +/-- The projection onto an odd coordinate line. -/ +noncomputable def oddOut (r s : ℕ) (j : Fin s) : + stdSuper r s ⟶ stdSuper 0 1 where + evenMap := 0 + oddMap := LinearMap.pi fun _ : Fin 1 => LinearMap.proj j + +/-- The letter inclusions of the standard super object. -/ +noncomputable def superIns (r s : ℕ) (k : Fin r ⊕ Fin s) : + letterObj (stdSuper 0 1) (mixParity r s) k ⟶ stdSuper r s := + Sum.rec (fun i => evenIn r s i) (fun j => oddInto r s j) k + +/-- The letter projections of the standard super object. -/ +noncomputable def superPrj (r s : ℕ) (k : Fin r ⊕ Fin s) : + stdSuper r s ⟶ letterObj (stdSuper 0 1) (mixParity r s) k := + Sum.rec (fun i => evenOut r s i) (fun j => oddOut r s j) k + +/-- The letter decomposition of the identity of the standard super +object, at arbitrary dimensions. -/ +private theorem superSum_total (r s : ℕ) : + (∑ k : Fin r ⊕ Fin s, + (superPrj r s k ≫ superIns r s k : + stdSuper r s ⟶ stdSuper r s)) = 𝟙 (stdSuper r s) := by + apply SuperVect.hom_ext + · have h1 : SuperVect.Hom.evenMap + ((∑ k : Fin r ⊕ Fin s, superPrj r s k ≫ superIns r s k : + stdSuper r s ⟶ stdSuper r s)) = + ∑ k : Fin r ⊕ Fin s, + SuperVect.Hom.evenMap (superPrj r s k ≫ superIns r s k) + := map_sum (evenAdd _ _) _ _ + rw [h1, Fintype.sum_sum_type] + refine LinearMap.ext fun v => ?_ + rw [LinearMap.add_apply, LinearMap.sum_apply, + LinearMap.sum_apply] + have hA : ∀ i : Fin r, SuperVect.Hom.evenMap + (superPrj r s (Sum.inl i) ≫ superIns r s (Sum.inl i)) v = + Pi.single i (v i) := fun i => rfl + have hB : ∀ j : Fin s, SuperVect.Hom.evenMap + (superPrj r s (Sum.inr j) ≫ superIns r s (Sum.inr j)) v = 0 + := fun j => rfl + rw [Finset.sum_congr rfl fun i (_ : i ∈ Finset.univ) => hA i, + Finset.sum_congr rfl fun j (_ : j ∈ Finset.univ) => hB j, + Finset.sum_const, smul_zero, add_zero] + exact Finset.univ_sum_single v + · have h1 : SuperVect.Hom.oddMap + ((∑ k : Fin r ⊕ Fin s, superPrj r s k ≫ superIns r s k : + stdSuper r s ⟶ stdSuper r s)) = + ∑ k : Fin r ⊕ Fin s, + SuperVect.Hom.oddMap (superPrj r s k ≫ superIns r s k) + := map_sum (oddAdd _ _) _ _ + rw [h1, Fintype.sum_sum_type] + refine LinearMap.ext fun v => ?_ + rw [LinearMap.add_apply, LinearMap.sum_apply, + LinearMap.sum_apply] + have hA : ∀ i : Fin r, SuperVect.Hom.oddMap + (superPrj r s (Sum.inl i) ≫ superIns r s (Sum.inl i)) v = 0 + := fun i => rfl + have hB : ∀ j : Fin s, SuperVect.Hom.oddMap + (superPrj r s (Sum.inr j) ≫ superIns r s (Sum.inr j)) v = + Pi.single j (v j) := fun j => rfl + rw [Finset.sum_congr rfl fun i (_ : i ∈ Finset.univ) => hA i, + Finset.sum_congr rfl fun j (_ : j ∈ Finset.univ) => hB j, + Finset.sum_const, smul_zero, zero_add] + exact Finset.univ_sum_single v + +/-- **The letter system of the standard super object** at +arbitrary dimensions. -/ +noncomputable def superLetters (r s : ℕ) : + MixedLetters (Fin r ⊕ Fin s) (mixParity r s) + (stdSuper 0 1) (stdSuper r s) where + ins := superIns r s + prj := superPrj r s + ins_prj k := by + cases k with + | inl i => + apply SuperVect.hom_ext + · change (LinearMap.proj (R := ℂ) (φ := fun _ : Fin r => ℂ) + i).comp (LinearMap.single ℂ (fun _ => ℂ) i) = + LinearMap.id + refine LinearMap.ext fun z => ?_ + change Pi.single (M := fun _ : Fin r => ℂ) i z i = z + rw [Pi.single_eq_same] + · refine LinearMap.ext fun z => ?_ + exact Subsingleton.elim (α := PUnit) _ _ + | inr j => + apply SuperVect.hom_ext + · refine LinearMap.ext fun z => ?_ + exact Subsingleton.elim (α := Fin 0 → ℂ) _ _ + · change (LinearMap.pi fun _ : Fin 1 => + LinearMap.proj (R := ℂ) + (φ := fun _ : Fin s => ℂ) j).comp + ((LinearMap.single ℂ (fun _ => ℂ) j).comp + (LinearMap.proj (R := ℂ) (φ := fun _ : Fin 1 => ℂ) 0)) + = LinearMap.id + refine LinearMap.ext fun v => ?_ + funext i + change Pi.single (M := fun _ : Fin s => ℂ) j (v 0) j = v i + rw [Pi.single_eq_same, Subsingleton.elim i 0] + ins_prj_ne {k k'} hkk' := by + cases k with + | inl i => + cases k' with + | inl i' => + apply SuperVect.hom_ext + · change (LinearMap.proj (R := ℂ) (φ := fun _ : Fin r => ℂ) + i').comp (LinearMap.single ℂ (fun _ => ℂ) i) = 0 + refine LinearMap.ext fun z => ?_ + change Pi.single (M := fun _ : Fin r => ℂ) i z i' = 0 + exact Pi.single_eq_of_ne (M := fun _ : Fin r => ℂ) + (fun h => hkk' (congrArg Sum.inl h.symm)) z + · refine LinearMap.ext fun z => ?_ + exact Subsingleton.elim (α := PUnit) _ _ + | inr j' => + apply SuperVect.hom_ext + · refine LinearMap.ext fun z => ?_ + exact Subsingleton.elim (α := Fin 0 → ℂ) _ _ + · refine LinearMap.ext fun z => ?_ + change (LinearMap.pi fun _ : Fin 1 => + LinearMap.proj (R := ℂ) + (φ := fun _ : Fin s => ℂ) j') + ((0 : PUnit →ₗ[ℂ] (Fin s → ℂ)) z) = 0 + rw [LinearMap.zero_apply, map_zero] + | inr j => + cases k' with + | inl i' => + apply SuperVect.hom_ext + · refine LinearMap.ext fun z => ?_ + change (LinearMap.proj (R := ℂ) + (φ := fun _ : Fin r => ℂ) i') + ((0 : (Fin 0 → ℂ) →ₗ[ℂ] (Fin r → ℂ)) z) = 0 + rfl + · refine LinearMap.ext fun z => ?_ + exact Subsingleton.elim (α := PUnit) _ _ + | inr j' => + apply SuperVect.hom_ext + · refine LinearMap.ext fun z => ?_ + exact Subsingleton.elim (α := Fin 0 → ℂ) _ _ + · change (LinearMap.pi fun _ : Fin 1 => + LinearMap.proj (R := ℂ) (φ := fun _ : Fin s => ℂ) + j').comp + ((LinearMap.single ℂ (fun _ => ℂ) j).comp + (LinearMap.proj (R := ℂ) + (φ := fun _ : Fin 1 => ℂ) 0)) = 0 + refine LinearMap.ext fun v => ?_ + funext i + change Pi.single (M := fun _ : Fin s => ℂ) j (v 0) j' = 0 + exact Pi.single_eq_of_ne (M := fun _ : Fin s => ℂ) + (fun h => hkk' (congrArg Sum.inr h.symm)) (v 0) + total := by exact superSum_total r s + +end SuperLetters + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixShuffle.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixShuffle.lean new file mode 100644 index 0000000000..039512a326 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixShuffle.lean @@ -0,0 +1,226 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 + +/-! +# Peeling a unit summand off a mixed sum + +The mixed sum `L.mix (p + 1) q` of `p + 1` copies of the unit and +`q` copies of an odd line decomposes as a binary biproduct of one +unit summand and the smaller mixed sum `L.mix p q`. The +isomorphism is pure index bookkeeping: the first unit index is +peeled off and the remaining indices are shifted down by one. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {D : Type u} + +attribute [local instance] hasBinaryBiproducts_of_finite_biproducts + +/-- Shift the unit indices of a mixed sum up by one, leaving the +line indices unchanged. -/ +def mixShift (p q : ℕ) : Fin p ⊕ Fin q → Fin (p + 1) ⊕ Fin q := + Sum.elim (fun i => Sum.inl i.succ) Sum.inr + +/-- The summand family of the mixed sum: the unit at each `Fin p` +index, the line at each `Fin q` index. -/ +abbrev OddLine.mixFun + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] + (L : OddLine D) (p q : ℕ) + (i : Fin p ⊕ Fin q) : D := + Sum.elim (fun _ => 𝟙_ D) (fun _ => L.obj) i + +/-- Shifting an index does not change the associated summand. -/ +theorem OddLine.mixShift_summand + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] + (L : OddLine D) (p q : ℕ) + (j : Fin p ⊕ Fin q) : + L.mixFun (p + 1) q (mixShift p q j) = L.mixFun p q j := by + rcases j with i | k <;> rfl + +/-- The shift never produces the first unit index. -/ +theorem mixShift_ne_inl_zero (p q : ℕ) (j : Fin p ⊕ Fin q) : + mixShift p q j ≠ Sum.inl 0 := by + rcases j with i | k + · simp [mixShift, Fin.succ_ne_zero] + · simp [mixShift] + +/-- The index shift is injective. -/ +theorem mixShift_injective (p q : ℕ) : + Function.Injective (mixShift p q) := by + rintro (i | k) (i' | k') h <;> + simp only [mixShift, Sum.elim_inl, Sum.elim_inr, Sum.inl.injEq, + Sum.inr.injEq, reduceCtorEq, Fin.succ_inj] at h <;> + simp [h] + +/-- Every unit summand of a mixed sum is the unit. -/ +theorem OddLine.mixFun_inl + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] + (L : OddLine D) (p q : ℕ) (i : Fin p) : + L.mixFun p q (Sum.inl i) = 𝟙_ D := rfl + +/-- Every line summand of a mixed sum is the line. -/ +theorem OddLine.mixFun_inr + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] + (L : OddLine D) (p q : ℕ) (j : Fin q) : + L.mixFun p q (Sum.inr j) = L.obj := rfl + +/-- Project a mixed sum onto its first unit summand together with +the remaining, downshifted, mixed sum. -/ +noncomputable def OddLine.mixSuccHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (p q : ℕ) : + (⨁ L.mixFun (p + 1) q) ⟶ (𝟙_ D) ⊞ (⨁ L.mixFun p q) := + biprod.lift + (biproduct.π (L.mixFun (p + 1) q) (Sum.inl 0) ≫ + eqToHom (L.mixFun_inl (p + 1) q 0)) + (biproduct.lift fun j => + biproduct.π (L.mixFun (p + 1) q) (mixShift p q j) ≫ + eqToHom (L.mixShift_summand p q j)) + +/-- Rebuild a mixed sum from its first unit summand and the +remaining, downshifted, mixed sum. -/ +noncomputable def OddLine.mixSuccInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (p q : ℕ) : + (𝟙_ D) ⊞ (⨁ L.mixFun p q) ⟶ ⨁ L.mixFun (p + 1) q := + biprod.desc + (eqToHom (L.mixFun_inl (p + 1) q 0).symm ≫ + biproduct.ι (L.mixFun (p + 1) q) (Sum.inl 0)) + (biproduct.desc fun j => + eqToHom (L.mixShift_summand p q j).symm ≫ + biproduct.ι (L.mixFun (p + 1) q) (mixShift p q j)) + +/-- The peeling map restricted to the first unit summand is the +left biproduct inclusion. -/ +@[reassoc] +theorem OddLine.ι_zero_mixSuccHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (p q : ℕ) : + biproduct.ι (L.mixFun (p + 1) q) (Sum.inl 0) ≫ + L.mixSuccHom p q = + eqToHom (L.mixFun_inl (p + 1) q 0) ≫ biprod.inl := by + apply biprod.hom_ext + · simp only [mixSuccHom, Category.assoc, biprod.lift_fst] + rw [← Category.assoc, biproduct.ι_π_self, Category.id_comp, + biprod.inl_fst, Category.comp_id] + · apply biproduct.hom_ext + intro j + simp only [mixSuccHom, Category.assoc, biprod.lift_snd_assoc, + biproduct.lift_π, biprod.inl_snd_assoc, zero_comp, comp_zero] + rw [← Category.assoc, + biproduct.ι_π_ne _ (Ne.symm (mixShift_ne_inl_zero p q j)), + zero_comp] + +/-- The peeling map restricted to a shifted summand is the right +inclusion of the corresponding summand of the smaller sum. -/ +@[reassoc] +theorem OddLine.ι_mixShift_mixSuccHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (p q : ℕ) + (j : Fin p ⊕ Fin q) : + biproduct.ι (L.mixFun (p + 1) q) (mixShift p q j) ≫ + L.mixSuccHom p q = + eqToHom (L.mixShift_summand p q j) ≫ + biproduct.ι (L.mixFun p q) j ≫ biprod.inr := by + apply biprod.hom_ext + · simp only [mixSuccHom, Category.assoc, biprod.lift_fst, + biprod.inr_fst, comp_zero] + rw [← Category.assoc, + biproduct.ι_π_ne _ (mixShift_ne_inl_zero p q j), zero_comp] + · apply biproduct.hom_ext + intro j' + simp only [mixSuccHom, Category.assoc, biprod.lift_snd_assoc, + biproduct.lift_π, biprod.inr_snd_assoc] + by_cases h : j = j' + · subst h + rw [← Category.assoc, biproduct.ι_π_self, Category.id_comp, + biproduct.ι_π_self, Category.comp_id] + · rw [← Category.assoc, + biproduct.ι_π_ne _ fun hh => h (mixShift_injective p q hh), + zero_comp, biproduct.ι_π_ne _ h, comp_zero] + +/-- Every index of the longer mixed sum is either the first unit +index or a shifted index. -/ +theorem mixShift_cases (p q : ℕ) (i : Fin (p + 1) ⊕ Fin q) : + i = Sum.inl 0 ∨ ∃ j, i = mixShift p q j := by + rcases i with i | k + · rcases Fin.eq_zero_or_eq_succ i with h | ⟨i', h⟩ + · exact Or.inl (by rw [h]) + · exact Or.inr ⟨Sum.inl i', by rw [h]; rfl⟩ + · exact Or.inr ⟨Sum.inr k, rfl⟩ + +/-- The peeling map followed by the rebuilding map is the +identity on the longer mixed sum. -/ +theorem OddLine.mixSucc_hom_inv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (p q : ℕ) : + L.mixSuccHom p q ≫ L.mixSuccInv p q = + 𝟙 (⨁ L.mixFun (p + 1) q) := by + apply biproduct.hom_ext' + intro i + rcases mixShift_cases p q i with rfl | ⟨j, rfl⟩ + · rw [← Category.assoc, L.ι_zero_mixSuccHom p q] + simp only [mixSuccInv, Category.assoc, biprod.inl_desc, + eqToHom_trans_assoc, eqToHom_refl, Category.id_comp, + Category.comp_id] + · rw [← Category.assoc, L.ι_mixShift_mixSuccHom p q j] + simp only [mixSuccInv, Category.assoc, biprod.inr_desc, + biproduct.ι_desc, eqToHom_trans_assoc, eqToHom_refl, + Category.id_comp, Category.comp_id] + +/-- The rebuilding map followed by the peeling map is the +identity on the peeled form. -/ +theorem OddLine.mixSucc_inv_hom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (p q : ℕ) : + L.mixSuccInv p q ≫ L.mixSuccHom p q = + 𝟙 ((𝟙_ D) ⊞ (⨁ L.mixFun p q)) := by + apply biprod.hom_ext' + · simp only [mixSuccInv, biprod.inl_desc_assoc, Category.assoc, + L.ι_zero_mixSuccHom p q, eqToHom_trans_assoc, eqToHom_refl, + Category.id_comp, Category.comp_id] + · apply biproduct.hom_ext' + intro j + simp only [mixSuccInv, Category.assoc, biprod.inr_desc_assoc, + biproduct.ι_desc_assoc, L.ι_mixShift_mixSuccHom p q, + eqToHom_trans_assoc, eqToHom_refl, Category.id_comp, + Category.comp_id] + +/-- Peeling one unit summand off a mixed sum: the mixed sum of +`p + 1` units and `q` lines is a unit plus the mixed sum of `p` +units and `q` lines. -/ +noncomputable def OddLine.mixSuccIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (p q : ℕ) : + L.mix (p + 1) q ≅ (𝟙_ D) ⊞ L.mix p q where + hom := L.mixSuccHom p q + inv := L.mixSuccInv p q + hom_inv_id := L.mixSucc_hom_inv p q + inv_hom_id := L.mixSucc_inv_hom p q + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixShuffleLine.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixShuffleLine.lean new file mode 100644 index 0000000000..862ecca175 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixShuffleLine.lean @@ -0,0 +1,212 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffle + +/-! +# Peeling a line summand off a mixed sum + +The mixed sum `L.mix p (q + 1)` of `p` copies of the unit and +`q + 1` copies of an odd line decomposes as a binary biproduct +of one line summand and the smaller mixed sum `L.mix p q`. The +isomorphism is pure index bookkeeping: the first line index is +peeled off and the remaining indices are shifted down by one. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {D : Type u} + +attribute [local instance] hasBinaryBiproducts_of_finite_biproducts + +/-- Shift the line indices of a mixed sum up by one, leaving the +unit indices unchanged. -/ +def mixShiftL (p q : ℕ) : Fin p ⊕ Fin q → Fin p ⊕ Fin (q + 1) := + Sum.elim Sum.inl (fun j => Sum.inr j.succ) + +/-- Shifting an index does not change the associated summand. -/ +theorem OddLine.mixShiftL_summand + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] + (L : OddLine D) (p q : ℕ) + (j : Fin p ⊕ Fin q) : + L.mixFun p (q + 1) (mixShiftL p q j) = L.mixFun p q j := by + rcases j with i | k <;> rfl + +/-- The shift never produces the first line index. -/ +theorem mixShiftL_ne_inr_zero (p q : ℕ) (j : Fin p ⊕ Fin q) : + mixShiftL p q j ≠ Sum.inr 0 := by + rcases j with i | k + · simp [mixShiftL] + · simp [mixShiftL, Fin.succ_ne_zero] + +/-- The index shift is injective. -/ +theorem mixShiftL_injective (p q : ℕ) : + Function.Injective (mixShiftL p q) := by + rintro (i | k) (i' | k') h <;> + simp only [mixShiftL, Sum.elim_inl, Sum.elim_inr, + Sum.inl.injEq, Sum.inr.injEq, reduceCtorEq, + Fin.succ_inj] at h <;> + simp [h] + +/-- Project a mixed sum onto its first line summand together +with the remaining, downshifted, mixed sum. -/ +noncomputable def OddLine.mixLineSuccHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) + (p q : ℕ) : + (⨁ L.mixFun p (q + 1)) ⟶ L.obj ⊞ (⨁ L.mixFun p q) := + biprod.lift + (biproduct.π (L.mixFun p (q + 1)) (Sum.inr 0) ≫ + eqToHom (L.mixFun_inr p (q + 1) 0)) + (biproduct.lift fun j => + biproduct.π (L.mixFun p (q + 1)) (mixShiftL p q j) ≫ + eqToHom (L.mixShiftL_summand p q j)) + +/-- Rebuild a mixed sum from its first line summand and the +remaining, downshifted, mixed sum. -/ +noncomputable def OddLine.mixLineSuccInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) + (p q : ℕ) : + L.obj ⊞ (⨁ L.mixFun p q) ⟶ ⨁ L.mixFun p (q + 1) := + biprod.desc + (eqToHom (L.mixFun_inr p (q + 1) 0).symm ≫ + biproduct.ι (L.mixFun p (q + 1)) (Sum.inr 0)) + (biproduct.desc fun j => + eqToHom (L.mixShiftL_summand p q j).symm ≫ + biproduct.ι (L.mixFun p (q + 1)) (mixShiftL p q j)) + +/-- The peeling map restricted to the first line summand is the +left biproduct inclusion. -/ +@[reassoc] +theorem OddLine.ι_inr_zero_mixLineSuccHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) + (p q : ℕ) : + biproduct.ι (L.mixFun p (q + 1)) (Sum.inr 0) ≫ + L.mixLineSuccHom p q = + eqToHom (L.mixFun_inr p (q + 1) 0) ≫ biprod.inl := by + apply biprod.hom_ext + · simp only [mixLineSuccHom, Category.assoc, biprod.lift_fst] + rw [← Category.assoc, biproduct.ι_π_self, Category.id_comp, + biprod.inl_fst, Category.comp_id] + · apply biproduct.hom_ext + intro j + simp only [mixLineSuccHom, Category.assoc, + biprod.lift_snd_assoc, biproduct.lift_π, + biprod.inl_snd_assoc, zero_comp, comp_zero] + rw [← Category.assoc, + biproduct.ι_π_ne _ (Ne.symm (mixShiftL_ne_inr_zero p q j)), + zero_comp] + +/-- The peeling map restricted to a shifted summand is the right +inclusion of the corresponding summand of the smaller sum. -/ +@[reassoc] +theorem OddLine.ι_mixShiftL_mixLineSuccHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) + (p q : ℕ) (j : Fin p ⊕ Fin q) : + biproduct.ι (L.mixFun p (q + 1)) (mixShiftL p q j) ≫ + L.mixLineSuccHom p q = + eqToHom (L.mixShiftL_summand p q j) ≫ + biproduct.ι (L.mixFun p q) j ≫ biprod.inr := by + apply biprod.hom_ext + · simp only [mixLineSuccHom, Category.assoc, biprod.lift_fst, + biprod.inr_fst, comp_zero] + rw [← Category.assoc, + biproduct.ι_π_ne _ (mixShiftL_ne_inr_zero p q j), zero_comp] + · apply biproduct.hom_ext + intro j' + simp only [mixLineSuccHom, Category.assoc, + biprod.lift_snd_assoc, biproduct.lift_π, + biprod.inr_snd_assoc] + by_cases h : j = j' + · subst h + rw [← Category.assoc, biproduct.ι_π_self, Category.id_comp, + biproduct.ι_π_self, Category.comp_id] + · rw [← Category.assoc, + biproduct.ι_π_ne _ + fun hh => h (mixShiftL_injective p q hh), + zero_comp, biproduct.ι_π_ne _ h, comp_zero] + +/-- Every index of the longer mixed sum is either the first line +index or a shifted index. -/ +theorem mixShiftL_cases (p q : ℕ) (i : Fin p ⊕ Fin (q + 1)) : + i = Sum.inr 0 ∨ ∃ j, i = mixShiftL p q j := by + rcases i with i | k + · exact Or.inr ⟨Sum.inl i, rfl⟩ + · rcases Fin.eq_zero_or_eq_succ k with h | ⟨k', h⟩ + · exact Or.inl (by rw [h]) + · exact Or.inr ⟨Sum.inr k', by rw [h]; rfl⟩ + +/-- The peeling map followed by the rebuilding map is the +identity on the longer mixed sum. -/ +theorem OddLine.mixLineSucc_hom_inv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (p q : ℕ) : + L.mixLineSuccHom p q ≫ L.mixLineSuccInv p q = + 𝟙 (⨁ L.mixFun p (q + 1)) := by + apply biproduct.hom_ext' + intro i + rcases mixShiftL_cases p q i with rfl | ⟨j, rfl⟩ + · rw [← Category.assoc, L.ι_inr_zero_mixLineSuccHom p q] + simp only [mixLineSuccInv, Category.assoc, biprod.inl_desc, + eqToHom_trans_assoc, eqToHom_refl, Category.id_comp, + Category.comp_id] + · rw [← Category.assoc, L.ι_mixShiftL_mixLineSuccHom p q j] + simp only [mixLineSuccInv, Category.assoc, biprod.inr_desc, + biproduct.ι_desc, eqToHom_trans_assoc, eqToHom_refl, + Category.id_comp, Category.comp_id] + +/-- The rebuilding map followed by the peeling map is the +identity on the peeled form. -/ +theorem OddLine.mixLineSucc_inv_hom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (p q : ℕ) : + L.mixLineSuccInv p q ≫ L.mixLineSuccHom p q = + 𝟙 (L.obj ⊞ (⨁ L.mixFun p q)) := by + apply biprod.hom_ext' + · simp only [mixLineSuccInv, biprod.inl_desc_assoc, + Category.assoc, L.ι_inr_zero_mixLineSuccHom p q, + eqToHom_trans_assoc, eqToHom_refl, Category.id_comp, + Category.comp_id] + · apply biproduct.hom_ext' + intro j + simp only [mixLineSuccInv, Category.assoc, + biprod.inr_desc_assoc, biproduct.ι_desc_assoc, + L.ι_mixShiftL_mixLineSuccHom p q, eqToHom_trans_assoc, + eqToHom_refl, Category.id_comp, Category.comp_id] + +/-- Peeling one line summand off a mixed sum: the mixed sum of +`p` units and `q + 1` lines is a line plus the mixed sum of `p` +units and `q` lines. -/ +noncomputable def OddLine.mixLineSuccIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) + (p q : ℕ) : + L.mix p (q + 1) ≅ L.obj ⊞ L.mix p q where + hom := L.mixLineSuccHom p q + inv := L.mixLineSuccInv p q + hom_inv_id := L.mixLineSucc_hom_inv p q + inv_hom_id := L.mixLineSucc_inv_hom p q + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixSumPow.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixSumPow.lean new file mode 100644 index 0000000000..394db277a1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixSumPow.lean @@ -0,0 +1,241 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffle +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed + +/-! +# Mixed sums as folded biproduct powers + +The mixed sum `L.mix (p + 1) (q + 1)` of the dévissage is indexed +by a `Sum` of two `Fin` types. Splitting the biproduct along the +two injections and folding each constant family into the iterated +binary sum `sumPow` identifies the mixed sum with the object +`sumPow (𝟙_ D) p ⊞ sumPow L.obj q` of the 1.9 layer. The +nonvanishing of the mixed sum at every diagram avoiding the cell +`(p + 1, q + 1)` then transports across the isomorphism. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {D : Type u} + +attribute [local instance] hasBinaryBiproducts_of_finite_biproducts + +/-- Split a mixed sum into its unit part and its line part. -/ +noncomputable def OddLine.mixSplitHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (p q : ℕ) : + (⨁ L.mixFun (p + 1) (q + 1)) ⟶ + (⨁ fun _ : Fin (p + 1) => 𝟙_ D) ⊞ + (⨁ fun _ : Fin (q + 1) => L.obj) := + biprod.lift + (biproduct.lift fun i => + biproduct.π (L.mixFun (p + 1) (q + 1)) (Sum.inl i) ≫ + eqToHom (L.mixFun_inl (p + 1) (q + 1) i)) + (biproduct.lift fun j => + biproduct.π (L.mixFun (p + 1) (q + 1)) (Sum.inr j) ≫ + eqToHom (L.mixFun_inr (p + 1) (q + 1) j)) + +/-- Rebuild a mixed sum from its unit part and its line part. -/ +noncomputable def OddLine.mixSplitInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (p q : ℕ) : + (⨁ fun _ : Fin (p + 1) => 𝟙_ D) ⊞ + (⨁ fun _ : Fin (q + 1) => L.obj) ⟶ + ⨁ L.mixFun (p + 1) (q + 1) := + biprod.desc + (biproduct.desc fun i => + eqToHom (L.mixFun_inl (p + 1) (q + 1) i).symm ≫ + biproduct.ι (L.mixFun (p + 1) (q + 1)) (Sum.inl i)) + (biproduct.desc fun j => + eqToHom (L.mixFun_inr (p + 1) (q + 1) j).symm ≫ + biproduct.ι (L.mixFun (p + 1) (q + 1)) (Sum.inr j)) + +/-- The splitting map restricted to a unit summand is the matching +inclusion into the unit part. -/ +@[reassoc] +theorem OddLine.ι_inl_mixSplitHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (p q : ℕ) + (i : Fin (p + 1)) : + biproduct.ι (L.mixFun (p + 1) (q + 1)) (Sum.inl i) ≫ + L.mixSplitHom p q = + eqToHom (L.mixFun_inl (p + 1) (q + 1) i) ≫ + biproduct.ι (fun _ : Fin (p + 1) => 𝟙_ D) i ≫ + biprod.inl := by + apply biprod.hom_ext + · apply biproduct.hom_ext + intro i' + simp only [mixSplitHom, Category.assoc, biprod.lift_fst, + biproduct.lift_π, biprod.inl_fst, Category.comp_id] + by_cases h : i = i' + · subst h + rw [← Category.assoc, biproduct.ι_π_self, Category.id_comp, + biproduct.ι_π_self, Category.comp_id] + · rw [← Category.assoc, + biproduct.ι_π_ne _ fun hh => h (Sum.inl_injective hh), + zero_comp, biproduct.ι_π_ne _ h, comp_zero] + · apply biproduct.hom_ext + intro j + simp only [mixSplitHom, Category.assoc, biprod.lift_snd, + biproduct.lift_π, biprod.inl_snd, comp_zero, zero_comp] + rw [← Category.assoc, biproduct.ι_π_ne _ Sum.inl_ne_inr, + zero_comp] + +/-- The splitting map restricted to a line summand is the matching +inclusion into the line part. -/ +@[reassoc] +theorem OddLine.ι_inr_mixSplitHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (p q : ℕ) + (j : Fin (q + 1)) : + biproduct.ι (L.mixFun (p + 1) (q + 1)) (Sum.inr j) ≫ + L.mixSplitHom p q = + eqToHom (L.mixFun_inr (p + 1) (q + 1) j) ≫ + biproduct.ι (fun _ : Fin (q + 1) => L.obj) j ≫ + biprod.inr := by + apply biprod.hom_ext + · apply biproduct.hom_ext + intro i + simp only [mixSplitHom, Category.assoc, biprod.lift_fst, + biproduct.lift_π, biprod.inr_fst, comp_zero, zero_comp] + rw [← Category.assoc, biproduct.ι_π_ne _ Sum.inr_ne_inl, + zero_comp] + · apply biproduct.hom_ext + intro j' + simp only [mixSplitHom, Category.assoc, biprod.lift_snd, + biproduct.lift_π, biprod.inr_snd, Category.comp_id] + by_cases h : j = j' + · subst h + rw [← Category.assoc, biproduct.ι_π_self, Category.id_comp, + biproduct.ι_π_self, Category.comp_id] + · rw [← Category.assoc, + biproduct.ι_π_ne _ fun hh => h (Sum.inr_injective hh), + zero_comp, biproduct.ι_π_ne _ h, comp_zero] + +/-- Splitting then rebuilding is the identity on the mixed sum. -/ +theorem OddLine.mixSplit_hom_inv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (p q : ℕ) : + L.mixSplitHom p q ≫ L.mixSplitInv p q = + 𝟙 (⨁ L.mixFun (p + 1) (q + 1)) := by + apply biproduct.hom_ext' + rintro (i | j) + · rw [← Category.assoc, L.ι_inl_mixSplitHom p q i] + simp only [mixSplitInv, Category.assoc, biprod.inl_desc, + biproduct.ι_desc, eqToHom_trans_assoc, eqToHom_refl, + Category.id_comp, Category.comp_id] + · rw [← Category.assoc, L.ι_inr_mixSplitHom p q j] + simp only [mixSplitInv, Category.assoc, biprod.inr_desc, + biproduct.ι_desc, eqToHom_trans_assoc, eqToHom_refl, + Category.id_comp, Category.comp_id] + +/-- Rebuilding then splitting is the identity on the split +form. -/ +theorem OddLine.mixSplit_inv_hom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (p q : ℕ) : + L.mixSplitInv p q ≫ L.mixSplitHom p q = + 𝟙 ((⨁ fun _ : Fin (p + 1) => 𝟙_ D) ⊞ + (⨁ fun _ : Fin (q + 1) => L.obj)) := by + apply biprod.hom_ext' + · apply biproduct.hom_ext' + intro i + simp only [mixSplitInv, Category.assoc, biprod.inl_desc_assoc, + biproduct.ι_desc_assoc, L.ι_inl_mixSplitHom p q, + eqToHom_trans_assoc, eqToHom_refl, Category.id_comp, + Category.comp_id] + · apply biproduct.hom_ext' + intro j + simp only [mixSplitInv, Category.assoc, biprod.inr_desc_assoc, + biproduct.ι_desc_assoc, L.ι_inr_mixSplitHom p q, + eqToHom_trans_assoc, eqToHom_refl, Category.id_comp, + Category.comp_id] + +/-- A mixed sum is the biproduct of its unit part and its line +part. -/ +noncomputable def OddLine.mixSplitIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (p q : ℕ) : + L.mix (p + 1) (q + 1) ≅ + (⨁ fun _ : Fin (p + 1) => 𝟙_ D) ⊞ + (⨁ fun _ : Fin (q + 1) => L.obj) where + hom := L.mixSplitHom p q + inv := L.mixSplitInv p q + hom_inv_id := L.mixSplit_hom_inv p q + inv_hom_id := L.mixSplit_inv_hom p q + +/-- Folding a constant biproduct into the iterated binary sum. -/ +noncomputable def constSumIso + [Category.{v} D] [Preadditive D] [HasFiniteBiproducts D] + (X : D) (k : ℕ) : + (⨁ fun _ : Fin (k + 1) => X) ≅ sumPow X k where + hom := biproduct.desc (sumPowIns X k) + inv := biproduct.lift (sumPowPrj X k) + hom_inv_id := by + apply biproduct.hom_ext' + intro i + apply biproduct.hom_ext + intro i' + simp only [Category.assoc, biproduct.ι_desc_assoc, + biproduct.lift_π, Category.id_comp] + by_cases h : i = i' + · subst h + rw [sumPowIns_prj_same X k i, biproduct.ι_π_self] + · rw [sumPowIns_prj_ne X k h, biproduct.ι_π_ne _ h] + inv_hom_id := by + rw [biproduct.lift_desc] + exact sumPow_total X k + +/-- **The mixed sum in fold form**: the mixed sum of `p + 1` units +and `q + 1` lines is the biproduct of the folded unit power and +the folded line power. -/ +noncomputable def OddLine.mixSumPowIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (p q : ℕ) : + L.mix (p + 1) (q + 1) ≅ + sumPow (𝟙_ D) p ⊞ sumPow L.obj q := + L.mixSplitIso p q ≪≫ + biprod.mapIso (constSumIso (𝟙_ D) p) (constSumIso L.obj q) + +section Killed + +/-- **Nonvanishing of the mixed sum**: in a nontrivial ambient +category, the mixed sum of `p + 1` units and `q + 1` odd lines is +not Schur-killed at any diagram avoiding the cell +`(p + 1, q + 1)`. -/ +theorem OddLine.not_schurKilled_mix + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [Linear ℂ D] + [MonoidalPreadditive D] [MonoidalLinear ℂ D] + (P : SchurPackage.{v}) + (P₀ : SchurPackage.{0}) (hone : ¬ Limits.IsZero (𝟙_ D)) + (L : OddLine D) (p q : ℕ) {lam : YoungDiagram} + (hcell : ((p + 1, q + 1) : ℕ × ℕ) ∉ lam) : + ¬ SchurKilled P (L.mix (p + 1) (q + 1)) lam := fun h => + not_schurKilled_sum P P₀ hone L.sq L.braid_neg p q hcell + (SchurKilled.of_iso P (L.mixSumPowIso p q) h) + +end Killed + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixWhisker.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixWhisker.lean new file mode 100644 index 0000000000..55d075933d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixWhisker.lean @@ -0,0 +1,242 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixSumPow + +/-! +# Whiskered nonvanishing of the mixed sum + +The nonvanishing of `MixSumPow.lean` says that the block +idempotent of a diagram avoiding the cell `(p + 1, q + 1)` acts +nonzero on the tensor power of the mixed sum. For the dévissage +one needs the same statement after whiskering by an auxiliary +object `W`: the action stays nonzero inside `W ⊗ −`. + +Whiskering is a `ℂ`-linear functor, so the whole extraction of +`SuperEmbed.lean` survives it verbatim. The colour sums are the +model-independent middle of that argument: the entry formula +`nIn_permAlg_nOut` pins the normalised matrix entry of a +group-algebra element to a scalar times a transport, and applying +`W ◁ −` to it leaves the scalar alone. Once every colour sum +vanishes the ambient endgame — reconstruction in `SuperVect` and +the super trace computation — is reused unchanged. + +The hypothesis feeding the whiskered form is that no power of the +odd line is killed by `W ⊗ −`; for `W` a monoid object with +nonzero unit this is automatic, since the odd line is invertible. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +/-! ## Whiskered extraction of the colour sums -/ + +section WhiskerLetters + +variable {A : Type u} + +namespace MixedLetters + +/-- **Whiskered extraction**: if a group-algebra element acts as +zero on the tensor power of the mixed object *after whiskering by +`W`*, all its colour sums vanish — provided no power of the odd +line is annihilated by `W ⊗ −`. The proof is the unwhiskered one +run through the `ℂ`-linear functor `W ◁ −`. -/ +theorem colourSum_eq_zero_whisker + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] {K : Type} [Fintype K] [DecidableEq K] + {par : K → Bool} {U : A} {M : A} + (S : MixedLetters K par U M) + (hβ : (β_ U U).hom = -(𝟙 (U ⊗ U))) (W : A) + (hW : ∀ k : ℕ, 𝟙 (W ⊗ tensorPow A U k) ≠ + (0 : W ⊗ tensorPow A U k ⟶ W ⊗ tensorPow A U k)) + {n : ℕ} {x : SymGroupAlgebra n} + (hx : W ◁ permAlg M n x = 0) (c d : Fin n → K) : + colourSum par x c d = 0 := by + by_cases hpop : popCount (par ∘ c) = popCount (par ∘ d) + · have h1 : W ◁ (S.nIn n c ≫ permAlg M n x ≫ S.nOut n d) = 0 := by + rw [MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp, hx, Limits.zero_comp, + Limits.comp_zero] + rw [S.nIn_permAlg_nOut hβ x c d, dite_eq_left hpop, + MonoidalLinear.whiskerLeft_smul] at h1 + by_contra hne + have h2 : W ◁ eqToHom (congrArg (tensorPow A U) hpop) = 0 := by + have h3 := congrArg + (fun t => (colourSum par x c d)⁻¹ • t) h1 + simpa only [smul_smul, inv_mul_cancel₀ hne, one_smul, + smul_zero] using h3 + refine hW (popCount (par ∘ c)) ?_ + have h4 := congrArg (fun t => t ≫ + W ◁ eqToHom (congrArg (tensorPow A U) hpop).symm) h2 + simpa only [← MonoidalCategory.whiskerLeft_comp, eqToHom_trans, + eqToHom_refl, MonoidalCategory.whiskerLeft_id, + Limits.zero_comp] using h4 + · exact colourSum_eq_zero_of_ne par x hpop + +end MixedLetters + +end WhiskerLetters + +/-! ## The whiskered ambient extraction and endgame -/ + +section AmbientWhisker + +variable {A : Type u} + +/-- **Whiskered extraction in the ambient category**: if the block +idempotent acts as zero on the whiskered tensor power of the mixed +sum, every colour sum of the idempotent vanishes. -/ +theorem colourSum_eq_zero_of_whisker_sum + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] [HasBinaryBiproducts A] + (P : SchurPackage.{v}) + (W : A) {U : A} + (hW : ∀ k : ℕ, 𝟙 (W ⊗ tensorPow A U k) ≠ + (0 : W ⊗ tensorPow A U k ⟶ W ⊗ tensorPow A U k)) + (hβ : (β_ U U).hom = -(𝟙 (U ⊗ U))) (p q : ℕ) + {lam : YoungDiagram} + (hkill : W ◁ permAlg (sumPow (𝟙_ A) p ⊞ sumPow U q) lam.card + (P.e lam) = 0) : + ∀ c d : Fin lam.card → Fin (p + 1) ⊕ Fin (q + 1), + colourSum mixedPar (P.e lam) c d = 0 := + fun c d => (mixedSumLetters p q U).colourSum_eq_zero_whisker hβ W + hW hkill c d + +/-- **The whiskered nonvanishing half of Deligne 1.9**: whiskering +by `W` does not destroy the action of the block idempotent on a +direct sum of `p + 1` unit copies and `q + 1` odd-line copies, at +any diagram avoiding the cell `(p + 1, q + 1)`. The nontriviality +of the ambient category is replaced by the sharper hypothesis that +`W ⊗ −` kills no power of the line. -/ +theorem whisker_permAlg_sum_ne_zero + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] [HasBinaryBiproducts A] + (P : SchurPackage.{v}) + (P₀ : SchurPackage.{0}) (W : A) {U : A} + (hW : ∀ k : ℕ, 𝟙 (W ⊗ tensorPow A U k) ≠ + (0 : W ⊗ tensorPow A U k ⟶ W ⊗ tensorPow A U k)) + (hβ : (β_ U U).hom = -(𝟙 (U ⊗ U))) (p q : ℕ) + {lam : YoungDiagram} + (hcell : ((p + 1, q + 1) : ℕ × ℕ) ∉ lam) : + W ◁ permAlg (sumPow (𝟙_ A) p ⊞ sumPow U q) lam.card (P.e lam) + ≠ 0 := by + intro hkill + have he : P.e lam = P₀.e lam := by + rw [P.e_eq_nProjector lam, P₀.e_eq_nProjector lam] + have hcs := colourSum_eq_zero_of_whisker_sum P W hW hβ p q hkill + rw [he] at hcs + exact not_schurKilled_stdSuper P₀ hcell + (schurKilled_stdSuper_of_colourSum P₀ p q hcs) + +end AmbientWhisker + +/-! ## Transport of the whiskered action along an isomorphism -/ + +section Transport + +variable {A : Type u} + +/-- **The whiskered action is an isomorphism invariant**: the +tensor power of the inverse splits the tensor power of the +isomorphism, and `W ◁ −` is a functor, so the naturality square of +`permAlg` transports the vanishing. -/ +theorem whisker_permAlg_eq_zero_of_iso + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] + (W : A) {X Y : A} (e : X ≅ Y) + {n : ℕ} (x : SymGroupAlgebra n) (h : W ◁ permAlg X n x = 0) : + W ◁ permAlg Y n x = 0 := by + have hST : (W ◁ tensorPowMap e.inv n) ≫ + (W ◁ tensorPowMap e.hom n) = 𝟙 (W ⊗ tensorPow A Y n) := by + rw [← MonoidalCategory.whiskerLeft_comp, ← tensorPowMap_comp, + e.inv_hom_id, tensorPowMap_id, + MonoidalCategory.whiskerLeft_id] + have hnat : (W ◁ permAlg X n x) ≫ (W ◁ tensorPowMap e.hom n) = + (W ◁ tensorPowMap e.hom n) ≫ (W ◁ permAlg Y n x) := by + rw [← MonoidalCategory.whiskerLeft_comp, + ← MonoidalCategory.whiskerLeft_comp, permAlg_natural] + calc W ◁ permAlg Y n x + = ((W ◁ tensorPowMap e.inv n) ≫ + (W ◁ tensorPowMap e.hom n)) ≫ (W ◁ permAlg Y n x) := by + rw [hST, Category.id_comp] + _ = (W ◁ tensorPowMap e.inv n) ≫ (W ◁ permAlg X n x) ≫ + (W ◁ tensorPowMap e.hom n) := by + rw [Category.assoc, ← hnat] + _ = 0 := by rw [h, Limits.zero_comp, Limits.comp_zero] + +end Transport + +/-! ## Whiskered powers of an odd line -/ + +section LinePowers + +variable {A : Type u} + +/-- A zero identity transfers along an isomorphism. Stated at +general objects. -/ +private theorem id_zero_of_iso [Category.{v} A] [Preadditive A] + {X Y : A} (e : X ≅ Y) (h : 𝟙 X = 0) : + 𝟙 Y = 0 := by + calc 𝟙 Y = e.inv ≫ 𝟙 X ≫ e.hom := by + rw [Category.id_comp, e.inv_hom_id] + _ = 0 := by rw [h, Limits.zero_comp, Limits.comp_zero] + +/-- **Whiskered powers of an odd line are nonzero** when the unit +of the whiskering monoid is: one more copy of the line is undone +through the line's self-pairing, and the empty power leaves `W` +itself, whose identity carries the unit. -/ +theorem OddLine.whisker_tensorPow_id_ne_zero + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [MonoidalPreadditive A] + (L : OddLine A) + {W : A} [MonObj W] (hW : η[W] ≠ 0) (k : ℕ) : + 𝟙 (W ⊗ tensorPow A L.obj k) ≠ + (0 : W ⊗ tensorPow A L.obj k ⟶ W ⊗ tensorPow A L.obj k) := by + induction k with + | zero => + intro h + refine hW ?_ + have h1 : 𝟙 W = 0 := + id_zero_of_iso (ρ_ W) (show 𝟙 (W ⊗ 𝟙_ A) = 0 from h) + calc η[W] = η[W] ≫ 𝟙 W := (Category.comp_id _).symm + _ = 0 := by rw [h1, Limits.comp_zero] + | succ k ih => + intro h + have h1 : 𝟙 ((W ⊗ tensorPow A L.obj (k + 1)) ⊗ L.obj) = 0 := by + rw [← MonoidalCategory.id_whiskerRight, h, + MonoidalPreadditive.zero_whiskerRight] + exact ih (id_zero_of_iso + (α_ W (tensorPow A L.obj k ⊗ L.obj) L.obj ≪≫ + whiskerLeftIso W + (α_ (tensorPow A L.obj k) L.obj L.obj ≪≫ + whiskerLeftIso (tensorPow A L.obj k) L.sq ≪≫ + ρ_ (tensorPow A L.obj k))) h1) + +end LinePowers + +/-! ## The whiskered mixed sum -/ + +section MixWhisker + +variable {A : Type u} + +attribute [local instance] hasBinaryBiproducts_of_finite_biproducts + +end MixWhisker + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixWhiskerAll.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixWhiskerAll.lean new file mode 100644 index 0000000000..aaa8a0335d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixWhiskerAll.lean @@ -0,0 +1,60 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixDegenerate +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixWhisker + +/-! +# The whiskered mixed sum at arbitrary counts + +The two generalisations of the nonvanishing of the mixed sum +combine: the letter systems built on the indexed biproduct work at +every pair of counts, and the extraction of the colour sums +survives whiskering by an auxiliary object, so the block +idempotent acts nontrivially on the whiskered tensor power at +every pair of counts and every diagram avoiding the corresponding +cell. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **Nonvanishing of the whiskered mixed sum at arbitrary +counts**: no positivity of either count is needed, and the +nontriviality hypothesis is carried by the whiskering object. -/ +theorem OddLine.whisker_permAlg_mix_ne_zero' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [Linear ℂ D] [MonoidalPreadditive D] + [MonoidalLinear ℂ D] [HasFiniteBiproducts D] + (P : SchurPackage.{v}) + (P₀ : SchurPackage.{0}) (W : D) (L : OddLine D) (r s : ℕ) + {lam : YoungDiagram} + (hW : ∀ k : ℕ, 𝟙 (W ⊗ tensorPow D L.obj k) ≠ 0) + (hcell : ((r, s) : ℕ × ℕ) ∉ lam) : + W ◁ permAlg (L.mix r s) lam.card (P.e lam) ≠ 0 := by + intro hkill + have he : P.e lam = P₀.e lam := by + rw [P.e_eq_nProjector lam, P₀.e_eq_nProjector lam] + have hcs : ∀ c d : Fin lam.card → Fin r ⊕ Fin s, + colourSum (mixParity r s) (P₀.e lam) c d = 0 := by + intro c d + have h := (L.mixLetters r s).colourSum_eq_zero_whisker + L.braid_neg W hW hkill c d + rwa [he] at h + exact not_schurKilled_stdSuper P₀ hcell + ((superLetters r s).permAlg_eq_zero stdSuper_braiding_neg hcs) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedConc.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedConc.lean new file mode 100644 index 0000000000..97decef8ff --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedConc.lean @@ -0,0 +1,654 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPerm + +/-! +# Concatenation of tensor powers and the block embedding + +`X ^ ⊗ a ⊗ X ^ ⊗ b` reassociates to `X ^ ⊗ (a + b)`, and the +reassociation intertwines the permutation actions: a pair of +permutations acting on the two factors separately corresponds to +their block embedding into `S_{a + b}`. + +The block embedding is conjugation by `finSumFinEquiv`, which sends +the `Fin a` summand to the first block `{0, …, a − 1}` by +`Fin.castAdd` and the `Fin b` summand to the last block by +`Fin.natAdd`; so `σ` permutes the first `a` slots and `τ` the last +`b`, matching the order of the tensor factors. + +Both the embedding and the intertwiners are multiplicative, so the +intertwining reduces to the generator families `(σ, 1)` and `(1, τ)`. +The first extends by `extPerm` one slot at a time, following the +recursion of the concatenation isomorphism; the second follows the +recursion of `permMor` itself, shifted into the last block — its top +cycle bubbles inside the last block only, which is the content of +the insertion lemma. The `ℂ`-bilinear extension to the group +algebras then holds on basis permutations and extends linearly. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +/-! ## The block embedding of symmetric groups -/ + +section BlockEmbed + +variable {a b : ℕ} + +/-- **The block embedding** of `S_a × S_b` into `S_{a + b}`: +`σ` permutes the first `a` slots and `τ` the last `b`. The +convention is that of `finSumFinEquiv`, which carries the `Fin a` +summand onto `{0, …, a − 1}` by `Fin.castAdd` and the `Fin b` +summand onto `{a, …, a + b − 1}` by `Fin.natAdd`. -/ +noncomputable def blockEmbed (σ : Equiv.Perm (Fin a)) + (τ : Equiv.Perm (Fin b)) : Equiv.Perm (Fin (a + b)) := + finSumFinEquiv.permCongr (σ.sumCongr τ) + +/-- On the first block the embedding acts by `σ`. -/ +@[simp] +theorem blockEmbed_castAdd (σ : Equiv.Perm (Fin a)) + (τ : Equiv.Perm (Fin b)) (i : Fin a) : + blockEmbed σ τ (Fin.castAdd b i) = Fin.castAdd b (σ i) := by + simp [blockEmbed] + +/-- On the last block the embedding acts by `τ`. -/ +@[simp] +theorem blockEmbed_natAdd (σ : Equiv.Perm (Fin a)) + (τ : Equiv.Perm (Fin b)) (j : Fin b) : + blockEmbed σ τ (Fin.natAdd a j) = Fin.natAdd a (τ j) := by + simp [blockEmbed] + +/-- The block embedding of the identities is the identity. -/ +@[simp] +theorem blockEmbed_one : + blockEmbed (1 : Equiv.Perm (Fin a)) (1 : Equiv.Perm (Fin b)) = 1 := by + refine Equiv.ext fun x => ?_ + induction x using Fin.addCases with + | left i => simp + | right j => simp + +/-- **The block embedding is multiplicative**: it is a homomorphism +from the product group. -/ +theorem blockEmbed_mul (σ σ' : Equiv.Perm (Fin a)) + (τ τ' : Equiv.Perm (Fin b)) : + blockEmbed (σ * σ') (τ * τ') = blockEmbed σ τ * blockEmbed σ' τ' := by + refine Equiv.ext fun x => ?_ + induction x using Fin.addCases with + | left i => simp [Equiv.Perm.mul_apply] + | right j => simp [Equiv.Perm.mul_apply] + +/-- A block embedding splits into its two one-sided factors. -/ +theorem blockEmbed_decompose (σ : Equiv.Perm (Fin a)) + (τ : Equiv.Perm (Fin b)) : + blockEmbed σ τ = blockEmbed σ 1 * blockEmbed 1 τ := by + rw [← blockEmbed_mul, mul_one, one_mul] + +/-- With an empty second block the embedding is the identity +re-indexing. -/ +theorem blockEmbed_one_zero (σ : Equiv.Perm (Fin a)) : + blockEmbed σ (1 : Equiv.Perm (Fin 0)) = σ := by + refine Equiv.ext fun x => ?_ + induction x using Fin.addCases with + | left i => + rw [blockEmbed_castAdd] + rfl + | right j => exact j.elim0 + +/-- Growing the second block by an unused slot extends the embedding +by fixing the new top slot. -/ +theorem blockEmbed_one_succ (σ : Equiv.Perm (Fin a)) : + blockEmbed σ (1 : Equiv.Perm (Fin (b + 1))) = + extPerm (blockEmbed σ (1 : Equiv.Perm (Fin b))) := by + refine Equiv.ext fun x => ?_ + induction x using Fin.addCases with + | left i => + change blockEmbed σ 1 (Fin.castAdd (b + 1) i) = + extPerm (blockEmbed σ 1) (Fin.castSucc (Fin.castAdd b i)) + rw [blockEmbed_castAdd, extPerm_castSucc, blockEmbed_castAdd] + rfl + | right j => + induction j using Fin.lastCases with + | last => + change blockEmbed σ 1 (Fin.natAdd a (Fin.last b)) = + extPerm (blockEmbed σ 1) (Fin.last (a + b)) + rw [blockEmbed_natAdd, extPerm_last] + rfl + | cast j => + change blockEmbed σ 1 (Fin.natAdd a (Fin.castSucc j)) = + extPerm (blockEmbed σ 1) (Fin.castSucc (Fin.natAdd a j)) + rw [blockEmbed_natAdd, extPerm_castSucc, blockEmbed_natAdd] + rfl + +/-- The block embedding of `(1, τ)` sends the top slot where `τ` +does, shifted into the last block. -/ +theorem topImage_blockEmbed (τ : Equiv.Perm (Fin (b + 1))) : + topImage (n := a + b) (blockEmbed (a := a) (b := b + 1) 1 τ) = + Fin.natAdd a (topImage τ) := by + change blockEmbed (a := a) (b := b + 1) 1 τ + (Fin.natAdd a (Fin.last b)) = + Fin.natAdd a (topImage τ) + rw [blockEmbed_natAdd] + rfl + +/-- Reinsertion above a point of the last block stays inside the +last block. -/ +private theorem natAdd_succAbove (q : Fin (b + 1)) (j : Fin b) : + (Fin.natAdd a q).succAbove (Fin.natAdd a j) = + Fin.natAdd a (q.succAbove j) := by + rcases Fin.lt_or_le (Fin.castSucc j) q with h | h + · have hv : (j : ℕ) < (q : ℕ) := Fin.lt_def.mp h + have h' : Fin.castSucc (Fin.natAdd a j) < Fin.natAdd a q := + Fin.lt_def.mpr (show a + (j : ℕ) < a + (q : ℕ) by omega) + rw [Fin.succAbove_of_castSucc_lt _ _ h, + Fin.succAbove_of_castSucc_lt _ _ h'] + rfl + · have hv : (q : ℕ) ≤ (j : ℕ) := Fin.le_def.mp h + have h' : Fin.natAdd a q ≤ Fin.castSucc (Fin.natAdd a j) := + Fin.le_def.mpr (show a + (q : ℕ) ≤ a + (j : ℕ) by omega) + rw [Fin.succAbove_of_le_castSucc _ _ h, + Fin.succAbove_of_le_castSucc _ _ h'] + rfl + +/-- The block embedding of `(1, τ)` induces the block embedding of +`(1, restPerm τ)` on the lower slots: the top split of the ambient +permutation happens entirely inside the last block. -/ +theorem restPerm_blockEmbed (τ : Equiv.Perm (Fin (b + 1))) : + restPerm (n := a + b) (blockEmbed (a := a) (b := b + 1) 1 τ) = + blockEmbed 1 (restPerm τ) := by + refine Equiv.ext fun j => ?_ + have key : (topImage (n := a + b) + (blockEmbed (a := a) (b := b + 1) 1 τ)).succAbove + (blockEmbed (1 : Equiv.Perm (Fin a)) (restPerm τ) j) = + blockEmbed (1 : Equiv.Perm (Fin a)) τ (Fin.castSucc j) := by + rw [topImage_blockEmbed] + induction j using Fin.addCases with + | left i => + have hlt : Fin.castSucc (Fin.castAdd b i) < + Fin.natAdd a (topImage τ) := + Fin.lt_def.mpr (show (i : ℕ) < a + ((topImage τ) : ℕ) by + have := i.isLt + omega) + change (Fin.natAdd a (topImage τ)).succAbove + (blockEmbed (1 : Equiv.Perm (Fin a)) (restPerm τ) + (Fin.castAdd b i)) = + blockEmbed (1 : Equiv.Perm (Fin a)) τ (Fin.castAdd (b + 1) i) + rw [blockEmbed_castAdd, blockEmbed_castAdd, Equiv.Perm.one_apply, + Fin.succAbove_of_castSucc_lt _ _ hlt] + rfl + | right i => + change (Fin.natAdd a (topImage τ)).succAbove + (blockEmbed (1 : Equiv.Perm (Fin a)) (restPerm τ) + (Fin.natAdd a i)) = + blockEmbed (1 : Equiv.Perm (Fin a)) τ + (Fin.natAdd a (Fin.castSucc i)) + rw [blockEmbed_natAdd, blockEmbed_natAdd, natAdd_succAbove, + succAbove_restPerm] + exact Fin.succAbove_right_injective + ((succAbove_restPerm (blockEmbed (a := a) (b := b + 1) 1 τ) + j).trans key.symm) + +end BlockEmbed + +/-! ## The concatenation isomorphism -/ + +variable {A : Type u} + +/-- **The concatenation isomorphism** +`X ^ ⊗ a ⊗ X ^ ⊗ b ≅ X ^ ⊗ (a + b)`, by the recursion of +`tensorPow` itself: the empty second power is absorbed by the right +unitor, and one further factor reassociates off the second power and +whiskers the previous stage. -/ +noncomputable def tensorPowConcat [Category.{v} A] [MonoidalCategory A] + (X : A) (a : ℕ) : + (b : ℕ) → (tensorPow A X a ⊗ tensorPow A X b ≅ tensorPow A X (a + b)) + | 0 => ρ_ (tensorPow A X a) + | b + 1 => + (α_ (tensorPow A X a) (tensorPow A X b) X).symm ≪≫ + whiskerRightIso (tensorPowConcat X a b) X + +/-- Concatenating with the empty power is the right unitor. -/ +theorem tensorPowConcat_zero [Category.{v} A] [MonoidalCategory A] + (X : A) (a : ℕ) : + tensorPowConcat X a 0 = ρ_ (tensorPow A X a) := rfl + +/-- The defining recursion of `tensorPowConcat`. -/ +theorem tensorPowConcat_succ [Category.{v} A] [MonoidalCategory A] + (X : A) (a b : ℕ) : + tensorPowConcat X a (b + 1) = + (α_ (tensorPow A X a) (tensorPow A X b) X).symm ≪≫ + whiskerRightIso (tensorPowConcat X a b) X := rfl + +/-! ## Passing endomorphisms across one stage + +The successor stage of the concatenation is an associator followed +by a whiskering of the previous stage. Each helper is stated at +general objects and applied by `exact`, so that no tensor-power +arity enters the rewriting. +-/ + +/-- Two morphisms passed one at a time across `T`. -/ +private theorem pull_pair [Category.{v} A] + {P Q : A} {T : P ⟶ Q} {u v : Q ⟶ Q} + {u' v' : P ⟶ P} (hu : T ≫ u = u' ≫ T) (hv : T ≫ v = v' ≫ T) : + T ≫ (u ≫ v) = (u' ≫ v') ≫ T := by + rw [← Category.assoc, hu, Category.assoc, hv, ← Category.assoc] + +/-- Identities pass across `T`. -/ +private theorem id_pass [Category.{v} A] + {P Q : A} (T : P ⟶ Q) : + T ≫ 𝟙 Q = 𝟙 P ≫ T := by + rw [Category.comp_id, Category.id_comp] + +/-- A morphism of the second tensorand passed across one stage of +the concatenation. -/ +private theorem concat_left_glue [Category.{v} A] [MonoidalCategory A] + {P Q R Y : A} (c : P ⊗ Q ⟶ R) + (u : R ⟶ R) (g : Q ⟶ Q) (h : c ≫ u = (P ◁ g) ≫ c) : + ((α_ P Q Y).inv ≫ (c ▷ Y)) ≫ (u ▷ Y) = + (P ◁ (g ▷ Y)) ≫ (α_ P Q Y).inv ≫ (c ▷ Y) := by + rw [Category.assoc, ← MonoidalCategory.comp_whiskerRight, h, + MonoidalCategory.comp_whiskerRight, + ← MonoidalCategory.associator_inv_naturality_middle_assoc] + +/-- A morphism of the first tensorand passed across one stage of +the concatenation. -/ +private theorem concat_right_glue [Category.{v} A] [MonoidalCategory A] + {P Q R Y : A} (c : P ⊗ Q ⟶ R) + (u : R ⟶ R) (f : P ⟶ P) (h : c ≫ u = (f ▷ Q) ≫ c) : + ((α_ P Q Y).inv ≫ (c ▷ Y)) ≫ (u ▷ Y) = + (f ▷ (Q ⊗ Y)) ≫ (α_ P Q Y).inv ≫ (c ▷ Y) := by + rw [Category.assoc, ← MonoidalCategory.comp_whiskerRight, h, + MonoidalCategory.comp_whiskerRight, + ← MonoidalCategory.associator_inv_naturality_left_assoc] + +section Symmetric + +/-- The braiding conjugate defining `swapTop` commutes with a doubly +whiskered morphism of the base, at general objects. -/ +private theorem swap_conj_whisker + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + {P R : A} (Y : A) (g : P ⟶ R) : + ((g ▷ Y) ▷ Y) ≫ + ((α_ R Y Y).hom ≫ (R ◁ (β_ Y Y).hom) ≫ (α_ R Y Y).inv) = + ((α_ P Y Y).hom ≫ (P ◁ (β_ Y Y).hom) ≫ (α_ P Y Y).inv) ≫ + ((g ▷ Y) ▷ Y) := by + rw [MonoidalCategory.associator_naturality_left_assoc, + ← MonoidalCategory.whisker_exchange_assoc, + MonoidalCategory.associator_inv_naturality_left] + simp only [Category.assoc] + +/-- The structural half of the swap intertwining: conjugating the +braiding at the joint base against conjugating it inside the second +tensorand. Pure coherence and naturality, discharged by +`monoidal`. -/ +private theorem concat_swap_structural + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (P Q Y : A) : + (α_ P (Q ⊗ Y) Y).inv ≫ ((α_ P Q Y).inv ▷ Y) ≫ + (α_ (P ⊗ Q) Y Y).hom ≫ ((P ⊗ Q) ◁ (β_ Y Y).hom) ≫ + (α_ (P ⊗ Q) Y Y).inv = + (P ◁ ((α_ Q Y Y).hom ≫ (Q ◁ (β_ Y Y).hom) ≫ (α_ Q Y Y).inv)) ≫ + (α_ P (Q ⊗ Y) Y).inv ≫ ((α_ P Q Y).inv ▷ Y) := by + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + monoidal + +/-- The swap intertwining at general objects: the top braiding after +two stages of concatenation is the whiskered top braiding of the +second tensorand. -/ +private theorem concat_swap_aux + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + {P Q R : A} (Y : A) (c : P ⊗ Q ⟶ R) : + ((α_ P (Q ⊗ Y) Y).inv ≫ (((α_ P Q Y).inv ≫ (c ▷ Y)) ▷ Y)) ≫ + ((α_ R Y Y).hom ≫ (R ◁ (β_ Y Y).hom) ≫ (α_ R Y Y).inv) = + (P ◁ ((α_ Q Y Y).hom ≫ (Q ◁ (β_ Y Y).hom) ≫ (α_ Q Y Y).inv)) ≫ + (α_ P (Q ⊗ Y) Y).inv ≫ (((α_ P Q Y).inv ≫ (c ▷ Y)) ▷ Y) := by + rw [MonoidalCategory.comp_whiskerRight] + simp only [Category.assoc] + rw [swap_conj_whisker Y c] + simp only [Category.assoc] + rw [reassoc_of% (concat_swap_structural P Q Y)] + +/-- **The concatenation isomorphism intertwines the top braiding** +of the last block: braiding the top two slots of `X ^ ⊗ (a + b + 2)` +corresponds to braiding the top two slots of the second factor. -/ +theorem tensorPowConcat_swapTop + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (a b : ℕ) : + (tensorPowConcat X a (b + 2)).hom ≫ swapTop X (a + b) = + (tensorPow A X a ◁ swapTop X b) ≫ (tensorPowConcat X a (b + 2)).hom := + concat_swap_aux X ((tensorPowConcat X a b).hom) + +/-- **The concatenation isomorphism intertwines bubbling** inside +the last block: as long as the insertion distance stays within the +second factor, inserting the top slot commutes with concatenation. -/ +theorem tensorPowConcat_insertTop + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (a : ℕ) : + ∀ b k : ℕ, k ≤ b → + (tensorPowConcat X a (b + 1)).hom ≫ insertTop X (a + b) k = + (tensorPow A X a ◁ insertTop X b k) ≫ + (tensorPowConcat X a (b + 1)).hom := by + intro b + induction b with + | zero => + intro k hk + obtain rfl : k = 0 := Nat.le_zero.mp hk + rw [insertTop_zero, insertTop_zero, MonoidalCategory.whiskerLeft_id] + exact id_pass _ + | succ b ihb => + intro k hk + cases k with + | zero => + rw [insertTop_zero, insertTop_zero, + MonoidalCategory.whiskerLeft_id] + exact id_pass _ + | succ k => + have hin : insertTop (A := A) X (a + (b + 1)) (k + 1) = + swapTop X (a + b) ≫ (insertTop X (a + b) k ▷ X) := + insertTop_succ X (a + b) k + have hwl : tensorPow A X a ◁ insertTop (A := A) X (b + 1) (k + 1) = + (tensorPow A X a ◁ swapTop X b) ≫ + (tensorPow A X a ◁ (insertTop X b k ▷ X)) := by + rw [insertTop_succ X b k] + exact MonoidalCategory.whiskerLeft_comp _ _ _ + have hswap := tensorPowConcat_swapTop X a b + have hstep : (tensorPowConcat X a (b + 1 + 1)).hom ≫ + (insertTop X (a + b) k ▷ X) = + (tensorPow A X a ◁ (insertTop X b k ▷ X)) ≫ + (tensorPowConcat X a (b + 1 + 1)).hom := + concat_left_glue ((tensorPowConcat X a (b + 1)).hom) + (insertTop X (a + b) k) (insertTop X b k) + (ihb k (Nat.le_of_succ_le_succ hk)) + rw [hin, hwl] + exact pull_pair hswap hstep + +/-- **The intertwining on the first generator family**: a +permutation of the first block acts on the first tensor factor +alone. -/ +theorem tensorPowConcat_permMor_fst + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (a : ℕ) + (σ : Equiv.Perm (Fin a)) : + ∀ b : ℕ, + (tensorPowConcat X a b).hom ≫ permMor X (a + b) (blockEmbed σ 1) = + (permMor X a σ ▷ tensorPow A X b) ≫ (tensorPowConcat X a b).hom := by + intro b + induction b with + | zero => + rw [blockEmbed_one_zero] + exact (MonoidalCategory.rightUnitor_naturality (permMor X a σ)).symm + | succ b ih => + rw [blockEmbed_one_succ] + have hpm : permMor X (a + (b + 1)) + (extPerm (blockEmbed σ (1 : Equiv.Perm (Fin b)))) = + permMor X (a + b) (blockEmbed σ 1) ▷ X := + permMor_extPerm X (a + b) (blockEmbed σ 1) + rw [hpm] + exact concat_right_glue ((tensorPowConcat X a b).hom) + (permMor X (a + b) (blockEmbed σ 1)) (permMor X a σ) ih + +/-- **The intertwining on the second generator family**: a +permutation of the last block acts on the second tensor factor +alone. The proof mirrors the recursion of `permMor`, shifted into +the last block by `restPerm_blockEmbed` and `topImage_blockEmbed`. -/ +theorem tensorPowConcat_permMor_snd + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (a : ℕ) : + ∀ (b : ℕ) (τ : Equiv.Perm (Fin b)), + (tensorPowConcat X a b).hom ≫ permMor X (a + b) (blockEmbed 1 τ) = + (tensorPow A X a ◁ permMor X b τ) ≫ (tensorPowConcat X a b).hom := by + intro b + induction b with + | zero => + intro τ + have hτ : τ = 1 := Equiv.ext fun x => x.elim0 + rw [hτ, blockEmbed_one, permMor_one, permMor_one, + MonoidalCategory.whiskerLeft_id, Category.comp_id, Category.id_comp] + | succ b ih => + intro τ + have hs := permMor_succ X (a + b) + (blockEmbed (a := a) (b := b + 1) 1 τ) + rw [restPerm_blockEmbed, topImage_blockEmbed] at hs + have harith : a + b - ((Fin.natAdd a (topImage τ) : + Fin (a + b + 1)) : ℕ) = + b - ((topImage τ : Fin (b + 1)) : ℕ) := by + change a + b - (a + ((topImage τ : Fin (b + 1)) : ℕ)) = _ + omega + rw [harith] at hs + have hs' : permMor X (a + (b + 1)) + (blockEmbed (a := a) (b := b + 1) 1 τ) = + (permMor X (a + b) (blockEmbed 1 (restPerm τ)) ▷ X) ≫ + insertTop X (a + b) (b - ((topImage τ : Fin (b + 1)) : ℕ)) := hs + have h2 : (tensorPowConcat X a (b + 1)).hom ≫ + (permMor X (a + b) (blockEmbed 1 (restPerm τ)) ▷ X) = + (tensorPow A X a ◁ (permMor X b (restPerm τ) ▷ X)) ≫ + (tensorPowConcat X a (b + 1)).hom := + concat_left_glue ((tensorPowConcat X a b).hom) + (permMor X (a + b) (blockEmbed 1 (restPerm τ))) + (permMor X b (restPerm τ)) (ih (restPerm τ)) + have h3 : (tensorPowConcat X a (b + 1)).hom ≫ + insertTop X (a + b) (b - ((topImage τ : Fin (b + 1)) : ℕ)) = + (tensorPow A X a ◁ + insertTop X b (b - ((topImage τ : Fin (b + 1)) : ℕ))) ≫ + (tensorPowConcat X a (b + 1)).hom := + tensorPowConcat_insertTop X a b _ (Nat.sub_le _ _) + have hwl : tensorPow A X a ◁ permMor X (b + 1) τ = + (tensorPow A X a ◁ (permMor X b (restPerm τ) ▷ X)) ≫ + (tensorPow A X a ◁ + insertTop X b (b - ((topImage τ : Fin (b + 1)) : ℕ))) := by + rw [permMor_succ X b τ] + exact MonoidalCategory.whiskerLeft_comp _ _ _ + rw [hs', hwl] + exact pull_pair h2 h3 + +/-- **The concatenation isomorphism intertwines the block +embedding**: under `tensorPowConcat`, the action of +`blockEmbed σ τ` on `X ^ ⊗ (a + b)` is the tensor product of the +actions of `σ` and `τ` on the two factors. -/ +theorem tensorPowConcat_permMor + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) {a b : ℕ} + (σ : Equiv.Perm (Fin a)) (τ : Equiv.Perm (Fin b)) : + (tensorPowConcat X a b).hom ≫ permMor X (a + b) (blockEmbed σ τ) = + (permMor X a σ ⊗ₘ permMor X b τ) ≫ (tensorPowConcat X a b).hom := by + rw [blockEmbed_decompose, permMor_mul, MonoidalCategory.tensorHom_def'] + exact pull_pair (tensorPowConcat_permMor_snd X a b τ) + (tensorPowConcat_permMor_fst X a σ b) + +end Symmetric + +/-! ## The linear extension -/ + +section Linear + +/-- The first-block embedding as a monoid homomorphism. -/ +noncomputable def blockEmbedFstHom (a b : ℕ) : + Equiv.Perm (Fin a) →* Equiv.Perm (Fin (a + b)) where + toFun σ := blockEmbed σ 1 + map_one' := blockEmbed_one + map_mul' σ σ' := by rw [← blockEmbed_mul, one_mul] + +/-- The second-block embedding as a monoid homomorphism. -/ +noncomputable def blockEmbedSndHom (a b : ℕ) : + Equiv.Perm (Fin b) →* Equiv.Perm (Fin (a + b)) where + toFun τ := blockEmbed 1 τ + map_one' := blockEmbed_one + map_mul' τ τ' := by rw [← blockEmbed_mul, one_mul] + +/-- **The block embedding of group algebras**: the `ℂ`-bilinear +extension of `blockEmbed`, carrying a pair of group-algebra elements +to the product of their one-sided embeddings. -/ +noncomputable def blockAlgEmbed {a b : ℕ} (x : SymGroupAlgebra a) + (y : SymGroupAlgebra b) : SymGroupAlgebra (a + b) := + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedFstHom a b) x * + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedSndHom a b) y + +/-- On basis permutations the algebra embedding is the block +embedding. -/ +theorem blockAlgEmbed_single {a b : ℕ} (σ : Equiv.Perm (Fin a)) + (τ : Equiv.Perm (Fin b)) (c d : ℂ) : + blockAlgEmbed (MonoidAlgebra.single σ c) + (MonoidAlgebra.single τ d) = + MonoidAlgebra.single (blockEmbed σ τ) (c * d) := by + have hL : MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedFstHom a b) + (MonoidAlgebra.single σ c) = + MonoidAlgebra.single (blockEmbed σ 1) c := by + change MonoidAlgebra.mapDomain _ (MonoidAlgebra.single σ c) = _ + exact MonoidAlgebra.mapDomain_single + have hR : MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedSndHom a b) + (MonoidAlgebra.single τ d) = + MonoidAlgebra.single (blockEmbed 1 τ) d := by + change MonoidAlgebra.mapDomain _ (MonoidAlgebra.single τ d) = _ + exact MonoidAlgebra.mapDomain_single + unfold blockAlgEmbed + rw [hL, hR, MonoidAlgebra.single_mul_single, ← blockEmbed_decompose] + +/-- The algebra embedding is additive in the first argument. -/ +theorem blockAlgEmbed_add_fst {a b : ℕ} (x x' : SymGroupAlgebra a) + (y : SymGroupAlgebra b) : + blockAlgEmbed (x + x') y = blockAlgEmbed x y + blockAlgEmbed x' y := by + unfold blockAlgEmbed + rw [map_add, add_mul] + +/-- The algebra embedding is homogeneous in the first argument. -/ +theorem blockAlgEmbed_smul_fst {a b : ℕ} (r : ℂ) (x : SymGroupAlgebra a) + (y : SymGroupAlgebra b) : + blockAlgEmbed (r • x) y = r • blockAlgEmbed x y := by + unfold blockAlgEmbed + rw [map_smul, smul_mul_assoc] + +/-- The algebra embedding is additive in the second argument. -/ +theorem blockAlgEmbed_add_snd {a b : ℕ} (x : SymGroupAlgebra a) + (y y' : SymGroupAlgebra b) : + blockAlgEmbed x (y + y') = blockAlgEmbed x y + blockAlgEmbed x y' := by + unfold blockAlgEmbed + rw [map_add, mul_add] + +/-- The algebra embedding is homogeneous in the second argument. -/ +theorem blockAlgEmbed_smul_snd {a b : ℕ} (r : ℂ) (x : SymGroupAlgebra a) + (y : SymGroupAlgebra b) : + blockAlgEmbed x (r • y) = r • blockAlgEmbed x y := by + unfold blockAlgEmbed + rw [map_smul, mul_smul_comm] + +/-- The tensor product of morphisms is homogeneous in the second +factor. -/ +private theorem tensorHom_smul + [Category.{v} A] [MonoidalCategory A] [Preadditive A] [Linear ℂ A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] + {P Q R S : A} (f : P ⟶ Q) (r : ℂ) + (g : R ⟶ S) : f ⊗ₘ (r • g) = r • (f ⊗ₘ g) := by + rw [MonoidalCategory.tensorHom_def, MonoidalCategory.tensorHom_def, + MonoidalLinear.whiskerLeft_smul, Linear.comp_smul] + +/-- The tensor product of morphisms is homogeneous in the first +factor. -/ +private theorem smul_tensorHom + [Category.{v} A] [MonoidalCategory A] [Preadditive A] [Linear ℂ A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] + {P Q R S : A} (r : ℂ) (f : P ⟶ Q) + (g : R ⟶ S) : (r • f) ⊗ₘ g = r • (f ⊗ₘ g) := by + rw [MonoidalCategory.tensorHom_def, MonoidalCategory.tensorHom_def, + MonoidalLinear.smul_whiskerRight, Linear.smul_comp] + +/-- Intertwining a tensor product across `T` is closed under sums in +the second factor. Stated at general objects and applied by +`exact`, so that the endomorphism-ring structure never enters the +rewriting. -/ +private theorem tensor_add_glue + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] + {P Q R : A} {T : P ⊗ Q ⟶ R} + {u v : R ⟶ R} {f : P ⟶ P} {g h : Q ⟶ Q} + (hu : T ≫ u = (f ⊗ₘ g) ≫ T) (hv : T ≫ v = (f ⊗ₘ h) ≫ T) : + T ≫ (u + v) = (f ⊗ₘ (g + h)) ≫ T := by + rw [MonoidalPreadditive.tensor_add, Preadditive.comp_add, + Preadditive.add_comp, hu, hv] + +/-- Intertwining a tensor product across `T` is closed under sums in +the first factor. Stated at general objects and applied by +`exact`. -/ +private theorem add_tensor_glue + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] + {P Q R : A} {T : P ⊗ Q ⟶ R} + {u v : R ⟶ R} {f g : P ⟶ P} {h : Q ⟶ Q} + (hu : T ≫ u = (f ⊗ₘ h) ≫ T) (hv : T ≫ v = (g ⊗ₘ h) ≫ T) : + T ≫ (u + v) = ((f + g) ⊗ₘ h) ≫ T := by + rw [MonoidalPreadditive.add_tensor, Preadditive.comp_add, + Preadditive.add_comp, hu, hv] + +/-- Intertwining a tensor product across `T` is closed under scalars +in the second factor. Stated at general objects and applied by +`exact`. -/ +private theorem tensor_smul_glue + [Category.{v} A] [MonoidalCategory A] [Preadditive A] [Linear ℂ A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] + {P Q R : A} {T : P ⊗ Q ⟶ R} + {u : R ⟶ R} {f : P ⟶ P} {g : Q ⟶ Q} (r : ℂ) + (h : T ≫ u = (f ⊗ₘ g) ≫ T) : + T ≫ (r • u) = (f ⊗ₘ (r • g)) ≫ T := by + rw [tensorHom_smul, Linear.comp_smul, Linear.smul_comp, h] + +/-- Intertwining a tensor product across `T` is closed under scalars +in the first factor. Stated at general objects and applied by +`exact`. -/ +private theorem smul_tensor_glue + [Category.{v} A] [MonoidalCategory A] [Preadditive A] [Linear ℂ A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] + {P Q R : A} {T : P ⊗ Q ⟶ R} + {u : R ⟶ R} {f : P ⟶ P} {g : Q ⟶ Q} (r : ℂ) + (h : T ≫ u = (f ⊗ₘ g) ≫ T) : + T ≫ (r • u) = ((r • f) ⊗ₘ g) ≫ T := by + rw [smul_tensorHom, Linear.comp_smul, Linear.smul_comp, h] + +/-- **The concatenation isomorphism intertwines the block embedding +of group algebras**: the `ℂ`-bilinear extension of the intertwining +on basis permutations. Both sides are bilinear in `(x, y)`, so the +statement reduces to `tensorPowConcat_permMor`. -/ +theorem tensorPowConcat_permAlg + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] + (X : A) {a b : ℕ} + (x : SymGroupAlgebra a) (y : SymGroupAlgebra b) : + (tensorPowConcat X a b).hom ≫ permAlg X (a + b) (blockAlgEmbed x y) = + (permAlg X a x ⊗ₘ permAlg X b y) ≫ (tensorPowConcat X a b).hom := by + induction x using MonoidAlgebra.induction_on with + | of σ => + induction y using MonoidAlgebra.induction_on with + | of τ => + rw [show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin a))) σ = + MonoidAlgebra.single σ (1 : ℂ) from rfl, + show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin b))) τ = + MonoidAlgebra.single τ (1 : ℂ) from rfl, + blockAlgEmbed_single, one_mul, permAlg_single, permAlg_single, + permAlg_single] + exact tensorPowConcat_permMor X σ τ + | add y₁ y₂ hy₁ hy₂ => + rw [blockAlgEmbed_add_snd, map_add, map_add] + exact tensor_add_glue hy₁ hy₂ + | smul r y' hy => + rw [blockAlgEmbed_smul_snd, map_smul, map_smul] + exact tensor_smul_glue r hy + | add x₁ x₂ hx₁ hx₂ => + rw [blockAlgEmbed_add_fst, map_add, map_add] + exact add_tensor_glue hx₁ hx₂ + | smul r x' hx => + rw [blockAlgEmbed_smul_fst, map_smul, map_smul] + exact smul_tensor_glue r hx + +end Linear + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedDiag.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedDiag.lean new file mode 100644 index 0000000000..753e809460 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedDiag.lean @@ -0,0 +1,417 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Intertwine +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPerm + +/-! +# Distribution of the permutation action over a tensor product + +The distribution isomorphism `(X ⊗ Y) ^ ⊗ n ≅ X ^ ⊗ n ⊗ Y ^ ⊗ n` +re-sorts the factors of a tensor power of a tensor product: stage by +stage, the middle-four interchange (`tensorμ`) moves the newest pair +of factors past the ones already sorted. The diagonal permutation +action on the left matches the simultaneous action of the same +permutation on the two sides. + +The intertwining is proved for the top braiding first: braiding two +compound factors distributes into the two plain braidings, which is +the symmetric-category compatibility `tensorμ_braid_swap` conjugated +through Mathlib's `tensor_associativity`. It then propagates along +the recursions of `insertTop` and `permMor` exactly as the naturality +lemmas of `Deligne/PermNat.lean` do, and linearises to the group +algebra, whose diagonal double action is packaged as `diagAlg`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +variable {A : Type u} + +/-! ## The distribution isomorphism -/ + +/-- **The middle-four interchange as an isomorphism**: `tensorμ` and +`tensorδ` are mutually inverse. -/ +noncomputable def tensorμIso + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (P Q X Y : A) : + (P ⊗ Q) ⊗ (X ⊗ Y) ≅ (P ⊗ X) ⊗ (Q ⊗ Y) where + hom := tensorμ P Q X Y + inv := tensorδ P Q X Y + hom_inv_id := tensorμ_tensorδ P Q X Y + inv_hom_id := tensorδ_tensorμ P Q X Y + +/-- **The distribution isomorphism** +`(X ⊗ Y) ^ ⊗ n ≅ X ^ ⊗ n ⊗ Y ^ ⊗ n`: at each stage the previous +stage sorts all but the newest pair of factors, and the middle-four +interchange routes that pair to its two destinations. -/ +noncomputable def tensorPowDistrib + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X Y : A) : (n : ℕ) → + (tensorPow A (X ⊗ Y) n ≅ tensorPow A X n ⊗ tensorPow A Y n) + | 0 => (λ_ (𝟙_ A)).symm + | n + 1 => + whiskerRightIso (tensorPowDistrib X Y n) (X ⊗ Y) ≪≫ + tensorμIso (tensorPow A X n) (tensorPow A Y n) X Y + +/-- The distribution at arity zero is the inverse unitor. -/ +@[simp] +theorem tensorPowDistrib_zero + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X Y : A) : + tensorPowDistrib X Y 0 = (λ_ (𝟙_ A)).symm := rfl + +/-! ## The top braiding distributes + +Braiding the top two compound factors of `((P ⊗ Q) ⊗ (X ⊗ Y)) ⊗ +(X ⊗ Y)` corresponds, through the two-stage interchange, to braiding +the two top factors on each side at once. The computation is done at +general objects, so that no tensor-power arity enters the rewriting: +the two-stage interchange is re-associated into a single interchange +against the paired factors (`tensor_associativity`), where the +braiding of a tensor square distributes by the symmetric-category +compatibility `tensorμ_braid_swap`. +-/ + +/-- In a symmetric category the interchange with the two middle +factors swapped is the inverse interchange: the single braiding they +contain differs by `braiding_swap_eq_inv_braiding`. -/ +private theorem tensorμ_swap_eq_tensorδ + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X₁ X₂ Y₁ Y₂ : A) : + tensorμ X₁ Y₁ X₂ Y₂ = tensorδ X₁ X₂ Y₁ Y₂ := by + simp only [tensorμ, tensorδ, + SymmetricCategory.braiding_swap_eq_inv_braiding] + +/-- **The braiding of a tensor square distributes**: braiding the two +compound factors corresponds, through the interchange, to braiding +the two plain pairs. This reads `tensorμ_braid_swap` through the +inverse interchange. -/ +private theorem braiding_tensorμ + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X Y : A) : + (β_ (X ⊗ Y) (X ⊗ Y)).hom ≫ tensorμ X Y X Y = + tensorμ X Y X Y ≫ ((β_ X X).hom ⊗ₘ (β_ Y Y).hom) := by + have h := SymmetricCategory.tensorμ_braid_swap (C := A) X Y + rw [tensorμ_swap_eq_tensorδ X X Y Y] + calc (β_ (X ⊗ Y) (X ⊗ Y)).hom ≫ tensorδ X X Y Y + = tensorδ X X Y Y ≫ tensorμ X X Y Y ≫ + (β_ (X ⊗ Y) (X ⊗ Y)).hom ≫ tensorδ X X Y Y := by + rw [tensorδ_tensorμ_assoc] + _ = tensorδ X X Y Y ≫ ((β_ X X).hom ⊗ₘ (β_ Y Y).hom) ≫ + tensorμ X X Y Y ≫ tensorδ X X Y Y := by + rw [← reassoc_of% h] + _ = tensorδ X X Y Y ≫ ((β_ X X).hom ⊗ₘ (β_ Y Y).hom) := by + rw [tensorμ_tensorδ, Category.comp_id] + +/-- The two-stage interchange, re-associated: distributing twice is a +single interchange against the paired factors, conjugated by +associators. This is `tensor_associativity` with the final +associators moved across. -/ +private theorem interchange_assoc + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (P Q X Y : A) : + (tensorμ P Q X Y ▷ (X ⊗ Y)) ≫ tensorμ (P ⊗ X) (Q ⊗ Y) X Y = + (α_ (P ⊗ Q) (X ⊗ Y) (X ⊗ Y)).hom ≫ + ((P ⊗ Q) ◁ tensorμ X Y X Y) ≫ + tensorμ P Q (X ⊗ X) (Y ⊗ Y) ≫ + ((α_ P X X).inv ⊗ₘ (α_ Q Y Y).inv) := by + rw [← tensor_associativity_assoc, tensorHom_comp_tensorHom, + Iso.hom_inv_id, Iso.hom_inv_id, id_tensorHom_id, Category.comp_id] + +/-- **The top braiding distributes through the interchange**, at +general objects standing for the two sorted lower parts. -/ +private theorem swap_distrib_core + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (P Q X Y : A) : + ((α_ (P ⊗ Q) (X ⊗ Y) (X ⊗ Y)).hom ≫ + ((P ⊗ Q) ◁ (β_ (X ⊗ Y) (X ⊗ Y)).hom) ≫ + (α_ (P ⊗ Q) (X ⊗ Y) (X ⊗ Y)).inv) ≫ + (tensorμ P Q X Y ▷ (X ⊗ Y)) ≫ tensorμ (P ⊗ X) (Q ⊗ Y) X Y = + ((tensorμ P Q X Y ▷ (X ⊗ Y)) ≫ tensorμ (P ⊗ X) (Q ⊗ Y) X Y) ≫ + (((α_ P X X).hom ≫ (P ◁ (β_ X X).hom) ≫ (α_ P X X).inv) ⊗ₘ + ((α_ Q Y Y).hom ≫ (Q ◁ (β_ Y Y).hom) ≫ (α_ Q Y Y).inv)) := by + rw [interchange_assoc P Q X Y] + simp only [Category.assoc, Iso.inv_hom_id_assoc] + rw [← MonoidalCategory.whiskerLeft_comp_assoc, braiding_tensorμ, + MonoidalCategory.whiskerLeft_comp_assoc, + tensorμ_natural_right_assoc, tensorHom_comp_tensorHom, + tensorHom_comp_tensorHom, Iso.inv_hom_id_assoc, + Iso.inv_hom_id_assoc] + +/-- The braiding conjugate that defines `swapTop` is natural in the +base object. Stated at general objects. -/ +private theorem swap_conj_base + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + {B B' : A} (Z : A) (g : B ⟶ B') : + ((g ▷ Z) ▷ Z) ≫ + ((α_ B' Z Z).hom ≫ (B' ◁ (β_ Z Z).hom) ≫ (α_ B' Z Z).inv) = + ((α_ B Z Z).hom ≫ (B ◁ (β_ Z Z).hom) ≫ (α_ B Z Z).inv) ≫ + ((g ▷ Z) ▷ Z) := by + rw [MonoidalCategory.associator_naturality_left_assoc, + ← MonoidalCategory.whisker_exchange_assoc, + MonoidalCategory.associator_inv_naturality_left] + simp only [Category.assoc] + +/-- A conjugation step at general objects: what commutes with `s` +across `W` and intertwines across `T` intertwines across the +composite. -/ +private theorem conj_step [Category.{v} A] + {P₁ P₂ P₃ : A} {W : P₁ ⟶ P₂} {s : P₁ ⟶ P₁} + {s' : P₂ ⟶ P₂} {T : P₂ ⟶ P₃} {u : P₃ ⟶ P₃} + (h1 : W ≫ s' = s ≫ W) (h2 : s' ≫ T = T ≫ u) : + s ≫ W ≫ T = (W ≫ T) ≫ u := by + calc s ≫ W ≫ T + = (W ≫ s') ≫ T := by rw [h1, Category.assoc] + _ = (W ≫ T) ≫ u := by rw [Category.assoc, Category.assoc, h2] + +/-- **The distribution intertwines the top braiding**: braiding the +top two factors of `(X ⊗ Y) ^ ⊗ (n + 2)` corresponds to braiding the +top two factors on each side simultaneously. -/ +theorem tensorPowDistrib_swapTop + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X Y : A) (n : ℕ) : + swapTop (X ⊗ Y) n ≫ (tensorPowDistrib X Y (n + 2)).hom = + (tensorPowDistrib X Y (n + 2)).hom ≫ + (swapTop X n ⊗ₘ swapTop Y n) := by + have hD : (tensorPowDistrib X Y (n + 2)).hom = + (((tensorPowDistrib X Y n).hom ▷ (X ⊗ Y)) ▷ (X ⊗ Y)) ≫ + ((tensorμ (tensorPow A X n) (tensorPow A Y n) X Y ▷ + (X ⊗ Y)) ≫ + tensorμ (tensorPow A X n ⊗ X) (tensorPow A Y n ⊗ Y) + X Y) := by + have h := MonoidalCategory.comp_whiskerRight + ((tensorPowDistrib X Y n).hom ▷ (X ⊗ Y)) + (tensorμ (tensorPow A X n) (tensorPow A Y n) X Y) (X ⊗ Y) + change ((((tensorPowDistrib X Y n).hom ▷ (X ⊗ Y)) ≫ + tensorμ (tensorPow A X n) (tensorPow A Y n) X Y) ▷ (X ⊗ Y)) ≫ + tensorμ (tensorPow A X n ⊗ X) (tensorPow A Y n ⊗ Y) X Y = _ + erw [h, Category.assoc] + rw [hD] + exact conj_step + (swap_conj_base (X ⊗ Y) (tensorPowDistrib X Y n).hom) + (swap_distrib_core (tensorPow A X n) (tensorPow A Y n) X Y) + +/-! ## The insertion cycle and the full action + +The intertwining propagates along the recursions of `insertTop` and +`permMor` exactly as the naturality lemmas of `PermNat.lean`: each +whiskered step passes through the distribution by naturality of the +interchange, and each top braiding by the coherence above. +-/ + +/-- A morphism intertwining the distribution one arity down still +intertwines after whiskering by the newest pair, by naturality of the +interchange. Stated at general objects. -/ +private theorem whisker_pass_distrib + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + {P Q R : A} (X Y : A) + {u : P ⟶ P} {v : Q ⟶ Q} {w : R ⟶ R} {T : P ⟶ Q ⊗ R} + (h : u ≫ T = T ≫ (v ⊗ₘ w)) : + (u ▷ (X ⊗ Y)) ≫ ((T ▷ (X ⊗ Y)) ≫ tensorμ Q R X Y) = + ((T ▷ (X ⊗ Y)) ≫ tensorμ Q R X Y) ≫ + ((v ▷ X) ⊗ₘ (w ▷ Y)) := by + calc (u ▷ (X ⊗ Y)) ≫ ((T ▷ (X ⊗ Y)) ≫ tensorμ Q R X Y) + = ((u ≫ T) ▷ (X ⊗ Y)) ≫ tensorμ Q R X Y := by + rw [← Category.assoc, ← MonoidalCategory.comp_whiskerRight] + _ = ((T ≫ (v ⊗ₘ w)) ▷ (X ⊗ Y)) ≫ tensorμ Q R X Y := by + rw [h] + _ = (T ▷ (X ⊗ Y)) ≫ ((v ⊗ₘ w) ▷ (X ⊗ Y)) ≫ tensorμ Q R X Y := by + rw [MonoidalCategory.comp_whiskerRight, Category.assoc] + _ = (T ▷ (X ⊗ Y)) ≫ tensorμ Q R X Y ≫ + ((v ▷ X) ⊗ₘ (w ▷ Y)) := by + rw [tensorμ_natural_left] + _ = ((T ▷ (X ⊗ Y)) ≫ tensorμ Q R X Y) ≫ + ((v ▷ X) ⊗ₘ (w ▷ Y)) := by + rw [Category.assoc] + +/-- Two morphisms that each intertwine `T` compose to a morphism +intertwining `T`. Stated at general objects, so that no tensor-power +arity enters the rewriting. -/ +private theorem step_shuffle [Category.{v} A] + {P Q : A} {s u : P ⟶ P} {T : P ⟶ Q} + {s' u' : Q ⟶ Q} (hs : s ≫ T = T ≫ s') (hu : u ≫ T = T ≫ u') : + (s ≫ u) ≫ T = T ≫ (s' ≫ u') := by + rw [Category.assoc, hu, ← Category.assoc, hs, Category.assoc] + +/-- The identity intertwines any morphism into a tensor product with +the tensor product of identities. Stated at general objects. -/ +private theorem id_pass [Category.{v} A] [MonoidalCategory A] + {P Q R : A} (T : P ⟶ Q ⊗ R) : + 𝟙 P ≫ T = T ≫ (𝟙 Q ⊗ₘ 𝟙 R) := by + rw [MonoidalCategory.id_tensorHom_id, Category.id_comp, + Category.comp_id] + +/-- **The distribution intertwines the insertion cycle**: bubbling +the top compound factor down corresponds to bubbling the top factor +on each side simultaneously. The proof follows the recursion of +`insertTop`. -/ +theorem tensorPowDistrib_insertTop + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X Y : A) : + ∀ n k : ℕ, + insertTop (X ⊗ Y) n k ≫ (tensorPowDistrib X Y (n + 1)).hom = + (tensorPowDistrib X Y (n + 1)).hom ≫ + (insertTop X n k ⊗ₘ insertTop Y n k) := by + intro n + induction n with + | zero => + intro k + simp only [insertTop_of_zero, MonoidalCategory.id_tensorHom_id, + Category.id_comp, Category.comp_id] + | succ n ih => + intro k + cases k with + | zero => + simp only [insertTop_zero, MonoidalCategory.id_tensorHom_id, + Category.id_comp, Category.comp_id] + | succ k => + have hs := tensorPowDistrib_swapTop X Y n + have hw : (insertTop (X ⊗ Y) n k ▷ (X ⊗ Y)) ≫ + (tensorPowDistrib X Y (n + 2)).hom = + (tensorPowDistrib X Y (n + 2)).hom ≫ + ((insertTop X n k ▷ X) ⊗ₘ (insertTop Y n k ▷ Y)) := + whisker_pass_distrib X Y (ih k) + have hcomp := MonoidalCategory.tensorHom_comp_tensorHom + (swapTop X n) (swapTop Y n) + (insertTop X n k ▷ X) (insertTop Y n k ▷ Y) + rw [insertTop_succ, insertTop_succ, insertTop_succ] + exact (step_shuffle hs hw).trans + (congrArg (fun m => (tensorPowDistrib X Y (n + 2)).hom ≫ m) + hcomp) + +/-- **The distribution intertwines the permutation action**: the +diagonal action of `σ` on `(X ⊗ Y) ^ ⊗ n` corresponds to the +simultaneous action of `σ` on the two sides. The proof is the +recursion of `permMor` itself. -/ +theorem tensorPowDistrib_permMor + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X Y : A) : + ∀ (n : ℕ) (σ : Equiv.Perm (Fin n)), + permMor (X ⊗ Y) n σ ≫ (tensorPowDistrib X Y n).hom = + (tensorPowDistrib X Y n).hom ≫ + (permMor X n σ ⊗ₘ permMor Y n σ) := by + intro n + induction n with + | zero => + intro σ + exact id_pass (tensorPowDistrib X Y 0).hom + | succ n ih => + intro σ + have hw : (permMor (X ⊗ Y) n (restPerm σ) ▷ (X ⊗ Y)) ≫ + (tensorPowDistrib X Y (n + 1)).hom = + (tensorPowDistrib X Y (n + 1)).hom ≫ + ((permMor X n (restPerm σ) ▷ X) ⊗ₘ + (permMor Y n (restPerm σ) ▷ Y)) := + whisker_pass_distrib X Y (ih (restPerm σ)) + have hi := tensorPowDistrib_insertTop X Y n + (n - (topImage σ : ℕ)) + have hcomp := MonoidalCategory.tensorHom_comp_tensorHom + (permMor X n (restPerm σ) ▷ X) (permMor Y n (restPerm σ) ▷ Y) + (insertTop X n (n - (topImage σ : ℕ))) + (insertTop Y n (n - (topImage σ : ℕ))) + rw [permMor_succ, permMor_succ, permMor_succ] + exact (step_shuffle hw hi).trans + (congrArg (fun m => (tensorPowDistrib X Y (n + 1)).hom ≫ m) + hcomp) + +/-! ## The diagonal double action -/ + +/-- **The diagonal double action of a permutation** on +`X ^ ⊗ n ⊗ Y ^ ⊗ n`, as a monoid homomorphism: `σ` acts by its two +actions tensored together. -/ +@[simps] +noncomputable def diagPermHom + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X Y : A) (n : ℕ) : + Equiv.Perm (Fin n) →* End (tensorPow A X n ⊗ tensorPow A Y n) + where + toFun σ := permMor X n σ ⊗ₘ permMor Y n σ + map_one' := by + change permMor X n 1 ⊗ₘ permMor Y n 1 = + 𝟙 (tensorPow A X n ⊗ tensorPow A Y n) + rw [permMor_one, permMor_one, MonoidalCategory.id_tensorHom_id] + map_mul' σ τ := by + change permMor X n (σ * τ) ⊗ₘ permMor Y n (σ * τ) = + (permMor X n τ ⊗ₘ permMor Y n τ) ≫ + (permMor X n σ ⊗ₘ permMor Y n σ) + rw [permMor_mul, permMor_mul, + MonoidalCategory.tensorHom_comp_tensorHom] + +section Linear + +/-- **The diagonal double action of the symmetric-group algebra** on +`X ^ ⊗ n ⊗ Y ^ ⊗ n`: the linear extension of +`σ ↦ permMor X n σ ⊗ₘ permMor Y n σ`. -/ +noncomputable def diagAlg + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] + (X Y : A) (n : ℕ) : + SymGroupAlgebra n →ₐ[ℂ] End (tensorPow A X n ⊗ tensorPow A Y n) := + MonoidAlgebra.lift ℂ (End (tensorPow A X n ⊗ tensorPow A Y n)) + (Equiv.Perm (Fin n)) (diagPermHom X Y n) + +/-- The diagonal algebra map sends a group element to the tensor +product of its two actions. -/ +@[simp] +theorem diagAlg_single + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] + (X Y : A) (n : ℕ) (σ : Equiv.Perm (Fin n)) : + diagAlg X Y n (MonoidAlgebra.single σ (1 : ℂ)) = + permMor X n σ ⊗ₘ permMor Y n σ := by + rw [diagAlg, MonoidAlgebra.lift_single, one_smul] + rfl + +/-- The diagonal algebra map written out as a sum over the support: +`x` acts by `Σ_σ x_σ • (permMor X n σ ⊗ₘ permMor Y n σ)`. -/ +theorem diagAlg_apply + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] + (X Y : A) (n : ℕ) (x : SymGroupAlgebra n) : + diagAlg X Y n x = + Finsupp.sum x.coeff fun σ c => + c • (permMor X n σ ⊗ₘ permMor Y n σ) := by + rw [diagAlg, MonoidAlgebra.lift_apply] + rfl + +/-- **The distribution intertwines the group-algebra action**: the +diagonal action of any group-algebra element on `(X ⊗ Y) ^ ⊗ n` +corresponds, through the distribution isomorphism, to its diagonal +double action on +`X ^ ⊗ n ⊗ Y ^ ⊗ n`. Both sides are `ℂ`-linear in the element, so +the statement reduces to basis permutations, where it is +`tensorPowDistrib_permMor`. -/ +theorem tensorPowDistrib_permAlg + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] + (X Y : A) {n : ℕ} + (x : SymGroupAlgebra n) : + permAlg (X ⊗ Y) n x ≫ (tensorPowDistrib X Y n).hom = + (tensorPowDistrib X Y n).hom ≫ diagAlg X Y n x := by + induction x using MonoidAlgebra.induction_on with + | of σ => + rw [show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin n))) σ = + MonoidAlgebra.single σ (1 : ℂ) from rfl, + permAlg_single, diagAlg_single] + exact tensorPowDistrib_permMor X Y n σ + | add x y hx hy => + rw [map_add, map_add] + exact intertwine_add hx hy + | smul r x hx => + rw [map_smul, map_smul] + exact intertwine_smul r hx + +end Linear + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedTransport.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedTransport.lean new file mode 100644 index 0000000000..7085456de7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedTransport.lean @@ -0,0 +1,43 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepATransport + +/-! +# Transport of local mixedness along a base change + +Being a mixed sum after base change is inherited by any further +base change: the free module on an object is carried to the free +module on the same object, so a decomposition over one algebra +becomes a decomposition over any algebra under it. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **An isomorphism of free modules base-changes.** -/ +noncomputable def freeModIsoBaseChange + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + {V W : D} (e : freeMod A V ≅ freeMod A W) : + freeMod B V ≅ freeMod B W := + (baseChangeFreeIso A B φ V).symm.trans + ((baseChangeMapIso A B φ e).trans (baseChangeFreeIso A B φ W)) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAbelian.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAbelian.lean new file mode 100644 index 0000000000..e23841ea63 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAbelian.lean @@ -0,0 +1,1649 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeBiprod + +/-! +# Modules over a monoid object form an abelian category + +Mathlib's `CategoryTheory.Mod D A` carries no additive structure. +This file supplies it, for `A` a monoid object in a monoidally +preadditive category `D`, and upgrades it to an abelian structure +when `D` is abelian and tensoring on the left is right exact. + +Everything is computed in `D` and transported along the forgetful +functor: + +* hom-groups are the subgroups of `D`'s hom-groups cut out by the + intertwining condition — closed under addition because `A ◁ −` is + additive; +* the zero module is the zero object of `D` with the zero action, + and the biproduct of `RS.modBiprod` exhibits binary biproducts; +* the kernel of a module map is the kernel of its underlying + morphism, with the action restricted by the universal property of + the kernel: no exactness hypothesis is needed, since the + restricted action is produced by `kernel.lift`; +* the cokernel is the cokernel of the underlying morphism, with the + action descended along `A ◁ cokernel.π`; here right exactness of + `Z ◁ −` is what makes the descent possible, and the module laws + are checked after cancelling the epimorphisms `𝟙_ D ◁ cokernel.π` + and `(A ⊗ A) ◁ cokernel.π`; +* a module map is a monomorphism exactly when its underlying + morphism is, and likewise for epimorphisms, so normality in `D` + transports: the route to `CategoryTheory.Abelian` is the + normality route, as for super modules in + `RS/Classical/Deligne/SuperModAbelian.lean`. + +The second half of the file is independent of module theory: in any +abelian category, a subobject of a finite direct sum of simple +objects is the direct sum of a sublist of them, and dually for +quotients. The engine is `RS.idxSum`, the direct sum of a list of +indices into a family of objects, and the two theorems +`RS.exists_sublist_iso_of_mono`/`RS.exists_sublist_iso_of_epi` are +proved by induction on the list from the two splitting lemmas +`RS.isoBiprodOfRetraction`/`RS.isoBiprodOfSection`: at each step +the intersection with the leading summand is a subobject of a +simple object, hence zero or the whole of it, and in either case +the inclusion of the kernel is split. The specialisations to a +`Fin n`-indexed biproduct +(`RS.exists_sublist_iso_biproduct_of_mono` and its epimorphism +companion) and to a sum of copies of two simple objects +(`RS.exists_mixSum_iso_of_mono` and its companion) follow. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits ZeroObject +open scoped MonObj + +universe v u w + +/-! ## The additive structure on module maps -/ + +section Preadd + +variable {D : Type u} + +/-- The zero morphism of carriers intertwines the actions. -/ +theorem zero_lin [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] {A : D} [MonObj A] {M : Mod D A} {N : Mod D A} : + actLeft A M.X ≫ (0 : M.X ⟶ N.X) + = A ◁ (0 : M.X ⟶ N.X) ≫ actLeft A N.X := by + rw [Limits.comp_zero, MonoidalPreadditive.whiskerLeft_zero, + Limits.zero_comp] + +/-- A sum of module maps intertwines the actions. -/ +theorem add_lin [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] {A : D} [MonObj A] {M : Mod D A} {N : Mod D A} + (f g : M ⟶ N) : + actLeft A M.X ≫ (f.hom + g.hom) + = A ◁ (f.hom + g.hom) ≫ actLeft A N.X := by + rw [Preadditive.comp_add, actLeft_natural A M.X N.X f.hom, + actLeft_natural A M.X N.X g.hom, + MonoidalPreadditive.whiskerLeft_add, Preadditive.add_comp] + +/-- The negative of a module map intertwines the actions. -/ +theorem neg_lin [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] {A : D} [MonObj A] {M : Mod D A} {N : Mod D A} + (f : M ⟶ N) : + actLeft A M.X ≫ (-f.hom) + = A ◁ (-f.hom) ≫ actLeft A N.X := by + rw [Preadditive.comp_neg, actLeft_natural A M.X N.X f.hom, + whiskerLeft_neg, Preadditive.neg_comp] + +/-- The sum of two module maps. -/ +def homAdd [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] {A : D} [MonObj A] {M : Mod D A} {N : Mod D A} + (f g : M ⟶ N) : M ⟶ N := + Mod.Hom.mk' (f.hom + g.hom) (by exact add_lin f g) + +/-- The zero module map. -/ +def homZero [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] {A : D} [MonObj A] {M : Mod D A} {N : Mod D A} : + M ⟶ N := + Mod.Hom.mk' 0 (by exact zero_lin) + +/-- The negative of a module map. -/ +def homNeg [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] {A : D} [MonObj A] {M : Mod D A} {N : Mod D A} + (f : M ⟶ N) : M ⟶ N := + Mod.Hom.mk' (-f.hom) (by exact neg_lin f) + +instance instAddHomMod [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] {A : D} [MonObj A] {M : Mod D A} {N : Mod D A} : + Add (M ⟶ N) := ⟨homAdd⟩ + +instance instZeroHomMod [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] {A : D} [MonObj A] {M : Mod D A} {N : Mod D A} : + Zero (M ⟶ N) := ⟨homZero⟩ + +instance instNegHomMod [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] {A : D} [MonObj A] {M : Mod D A} {N : Mod D A} : + Neg (M ⟶ N) := ⟨homNeg⟩ + +/-- The hom-groups of the category of modules. -/ +instance instAddCommGroupHomMod + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] {A : D} [MonObj A] {M : Mod D A} {N : Mod D A} : + AddCommGroup (M ⟶ N) where + add_assoc _ _ _ := Mod.hom_ext _ _ (add_assoc _ _ _) + zero_add _ := Mod.hom_ext _ _ (zero_add _) + add_zero _ := Mod.hom_ext _ _ (add_zero _) + neg_add_cancel _ := Mod.hom_ext _ _ (neg_add_cancel _) + add_comm _ _ := Mod.hom_ext _ _ (add_comm _ _) + nsmul := nsmulRec + zsmul := zsmulRec + +/-- **Modules over a monoid object are preadditive**, with +hom-groups the intertwining subgroups of the ambient hom-groups. -/ +instance instPreadditiveMod + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] {A : D} [MonObj A] : Preadditive (Mod D A) where + homGroup _ _ := instAddCommGroupHomMod + add_comp _ _ _ _ _ _ := + Mod.hom_ext _ _ (Preadditive.add_comp _ _ _ _ _ _) + comp_add _ _ _ _ _ _ := + Mod.hom_ext _ _ (Preadditive.comp_add _ _ _ _ _ _) + +@[simp] theorem mod_add_hom + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] {A : D} [MonObj A] {M : Mod D A} {N : Mod D A} + (f g : M ⟶ N) : + (f + g).hom = f.hom + g.hom := rfl + +@[simp] theorem mod_zero_hom + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] {A : D} [MonObj A] {M : Mod D A} {N : Mod D A} : + (0 : M ⟶ N).hom = 0 := rfl + +@[simp] theorem mod_neg_hom + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] {A : D} [MonObj A] {M : Mod D A} {N : Mod D A} + (f : M ⟶ N) : (-f).hom = -f.hom := rfl + +/-- **The forgetful functor is additive.** -/ +instance instForgetAdditive + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] {A : D} [MonObj A] : + (Mod.forget (D := D) A).Additive where + map_add := rfl + +/-- **The forgetful functor is faithful.** -/ +instance instForgetFaithful + [Category.{v} D] [MonoidalCategory D] {A : D} [MonObj A] : + (Mod.forget (D := D) A).Faithful where + map_injective h := Mod.hom_ext _ _ h + +/-- A module map whose underlying morphism is a monomorphism is a +monomorphism. -/ +theorem mono_of_mono_hom + [Category.{v} D] [MonoidalCategory D] {A : D} [MonObj A] {M : Mod D A} + {N : Mod D A} + (f : M ⟶ N) (h : Mono f.hom) : Mono f := + ⟨fun _ _ huv => Mod.hom_ext _ _ + ((cancel_mono f.hom).1 (congrArg Mod.Hom.hom huv))⟩ + +/-- A module map whose underlying morphism is an epimorphism is an +epimorphism. -/ +theorem epi_of_epi_hom + [Category.{v} D] [MonoidalCategory D] {A : D} [MonObj A] {M : Mod D A} + {N : Mod D A} + (f : M ⟶ N) (h : Epi f.hom) : Epi f := + ⟨fun _ _ huv => Mod.hom_ext _ _ + ((cancel_epi f.hom).1 (congrArg Mod.Hom.hom huv))⟩ + +end Preadd + +/-! ## The zero module -/ + +section Zero + +variable {D : Type u} + +/-- The zero object of `D` is a module, with the zero action. -/ +@[implicit_reducible] +noncomputable def zeroModObj + [Category.{v} D] [MonoidalCategory D] [Preadditive D] [HasZeroObject D] + (A : D) [MonObj A] : ModObj A (0 : D) where + smul := 0 + one_smul := (isZero_zero D).eq_of_tgt _ _ + mul_smul := (isZero_zero D).eq_of_tgt _ _ + +/-- **The zero module.** -/ +noncomputable def zeroMod + [Category.{v} D] [MonoidalCategory D] [Preadditive D] [HasZeroObject D] + (A : D) [MonObj A] : Mod D A := + letI := zeroModObj A + ⟨0⟩ + +/-- The zero module is a zero object. -/ +theorem isZero_zeroMod [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasZeroObject D] (A : D) [MonObj A] : + IsZero (zeroMod A) := by + rw [IsZero.iff_id_eq_zero] + refine Mod.hom_ext _ _ ?_ + exact (isZero_zero D).eq_of_tgt _ _ + +/-- **Modules over a monoid object have a zero object.** -/ +instance instHasZeroObjectMod + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasZeroObject D] (A : D) [MonObj A] : + HasZeroObject (Mod D A) := + ⟨⟨zeroMod A, isZero_zeroMod A⟩⟩ + +end Zero + +/-! ## Binary biproducts -/ + +section Biprod + +variable {D : Type u} + +/-- The binary bicone carried by the biproduct of two modules. -/ +noncomputable def modBinaryBicone + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] (A : D) [MonObj A] + (M : Mod D A) (N : Mod D A) : BinaryBicone M N where + pt := modBiprod A M N + fst := modBiprodFst A M N + snd := modBiprodSnd A M N + inl := modBiprodInl A M N + inr := modBiprodInr A M N + inl_fst := Mod.hom_ext _ _ (by simp) + inl_snd := Mod.hom_ext _ _ (by simp) + inr_fst := Mod.hom_ext _ _ (by simp) + inr_snd := Mod.hom_ext _ _ (by simp) + +/-- The bicone of the module biproduct is total. -/ +theorem modBinaryBicone_total + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] (A : D) [MonObj A] + (M : Mod D A) (N : Mod D A) : + (modBinaryBicone A M N).fst ≫ (modBinaryBicone A M N).inl + + (modBinaryBicone A M N).snd ≫ (modBinaryBicone A M N).inr + = 𝟙 (modBinaryBicone A M N).pt := by + refine Mod.hom_ext _ _ ?_ + change biprod.fst ≫ biprod.inl + biprod.snd ≫ biprod.inr + = 𝟙 (M.X ⊞ N.X) + exact biprod.total + +/-- **The bicone of the module biproduct is a bilimit.** -/ +noncomputable def modBinaryBiconeIsBilimit + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] (A : D) [MonObj A] + (M : Mod D A) (N : Mod D A) : + (modBinaryBicone A M N).IsBilimit := + isBinaryBilimitOfTotal _ (modBinaryBicone_total A M N) + +end Biprod + +section BiprodInst + +variable {D : Type u} + +/-- **Modules over a monoid object have binary biproducts.** -/ +instance instHasBinaryBiproductsMod + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] (A : D) [MonObj A] : + HasBinaryBiproducts (Mod D A) := + ⟨fun M N => HasBinaryBiproduct.mk + ⟨modBinaryBicone A M N, modBinaryBiconeIsBilimit A M N⟩⟩ + +end BiprodInst + +/-! ## Finite biproducts -/ + +section FinBiprod + +variable {D : Type u} + +/-- The componentwise action on a finite biproduct of carriers. -/ +noncomputable def modBiproductAct + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasFiniteBiproducts D] (A : D) [MonObj A] {K : Type} [Fintype K] + (M : K → Mod D A) : + A ⊗ (⨁ fun j => (M j).X) ⟶ ⨁ fun j => (M j).X := + biproduct.lift fun j => + A ◁ biproduct.π (fun j => (M j).X) j ≫ actLeft A (M j).X + +@[reassoc (attr := simp)] +theorem modBiproductAct_π [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasFiniteBiproducts D] (A : D) [MonObj A] {K : Type} [Fintype K] + (M : K → Mod D A) + (j : K) : + modBiproductAct A M ≫ biproduct.π (fun j => (M j).X) j + = A ◁ biproduct.π (fun j => (M j).X) j ≫ actLeft A (M j).X := + biproduct.lift_π _ _ + +/-- Unitality of the componentwise action. -/ +theorem modBiproductAct_one + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasFiniteBiproducts D] (A : D) [MonObj A] {K : Type} [Fintype K] + (M : K → Mod D A) : + η[A] ▷ (⨁ fun j => (M j).X) ≫ modBiproductAct A M + = (λ_ (⨁ fun j => (M j).X)).hom := by + refine biproduct.hom_ext _ _ fun j => ?_ + rw [Category.assoc, modBiproductAct_π, ← Category.assoc, + ← whisker_exchange, Category.assoc, one_actLeft, + leftUnitor_naturality] + +/-- Associativity of the componentwise action. -/ +theorem modBiproductAct_mul + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasFiniteBiproducts D] (A : D) [MonObj A] {K : Type} [Fintype K] + (M : K → Mod D A) : + μ[A] ▷ (⨁ fun j => (M j).X) ≫ modBiproductAct A M + = (α_ A A (⨁ fun j => (M j).X)).hom + ≫ A ◁ modBiproductAct A M ≫ modBiproductAct A M := by + refine biproduct.hom_ext _ _ fun j => ?_ + rw [Category.assoc, modBiproductAct_π, ← Category.assoc, + ← whisker_exchange, Category.assoc, mul_actLeft, Category.assoc, + Category.assoc, modBiproductAct_π, + ← MonoidalCategory.whiskerLeft_comp_assoc, modBiproductAct_π, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + associator_naturality_right_assoc] + +/-- The module structure on a finite biproduct of carriers. -/ +@[implicit_reducible] +noncomputable def modBiproductModObj + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasFiniteBiproducts D] (A : D) [MonObj A] {K : Type} [Fintype K] + (M : K → Mod D A) : + ModObj A (⨁ fun j => (M j).X) where + smul := modBiproductAct A M + one_smul := modBiproductAct_one A M + mul_smul := modBiproductAct_mul A M + +/-- **The finite biproduct of modules**, bundled. -/ +noncomputable def modBiproduct + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasFiniteBiproducts D] (A : D) [MonObj A] {K : Type} [Fintype K] + (M : K → Mod D A) : Mod D A := + letI := modBiproductModObj A M + ⟨⨁ fun j => (M j).X⟩ + +/-- The projections of the biproduct are module maps. -/ +noncomputable def modBiproductπ + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasFiniteBiproducts D] (A : D) [MonObj A] {K : Type} [Fintype K] + (M : K → Mod D A) + (j : K) : modBiproduct A M ⟶ M j := + Mod.Hom.mk' (biproduct.π (fun j => (M j).X) j) + (by exact modBiproductAct_π A M j) + +/-- The injections intertwine the actions. -/ +theorem modBiproductAct_ι [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] (A : D) [MonObj A] + {K : Type} [Fintype K] (M : K → Mod D A) + (j : K) : + actLeft A (M j).X ≫ biproduct.ι (fun j => (M j).X) j + = A ◁ biproduct.ι (fun j => (M j).X) j + ≫ modBiproductAct A M := by + refine biproduct.hom_ext _ _ fun j' => ?_ + by_cases h : j = j' + · subst h + rw [Category.assoc, biproduct.ι_π_self, Category.comp_id, + Category.assoc, modBiproductAct_π, + ← MonoidalCategory.whiskerLeft_comp_assoc, + biproduct.ι_π_self, MonoidalCategory.whiskerLeft_id, + Category.id_comp] + · rw [Category.assoc, biproduct.ι_π_ne _ h, Limits.comp_zero, + Category.assoc, modBiproductAct_π, + ← MonoidalCategory.whiskerLeft_comp_assoc, + biproduct.ι_π_ne _ h, MonoidalPreadditive.whiskerLeft_zero, + Limits.zero_comp] + +/-- The injections of the biproduct are module maps. -/ +noncomputable def modBiproductInj + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] (A : D) [MonObj A] + {K : Type} [Fintype K] (M : K → Mod D A) + (j : K) : M j ⟶ modBiproduct A M := + Mod.Hom.mk' (biproduct.ι (fun j => (M j).X) j) + (by exact modBiproductAct_ι A M j) + +/-- The bicone carried by the finite biproduct of modules. -/ +noncomputable def modBicone + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] (A : D) [MonObj A] + {K : Type} [Fintype K] (M : K → Mod D A) : Bicone M := + Bicone.mk (modBiproduct A M) (modBiproductπ A M) + (modBiproductInj A M) + (fun j j' => by + by_cases h : j = j' + · subst h + rw [dite_eq_left rfl] + refine Mod.hom_ext _ _ ?_ + change biproduct.ι (fun j => (M j).X) j + ≫ biproduct.π (fun j => (M j).X) j = _ + rw [biproduct.ι_π_self] + exact (Mod.id_hom' (M j)).symm + · rw [dite_eq_right h] + refine Mod.hom_ext _ _ ?_ + change biproduct.ι (fun j => (M j).X) j + ≫ biproduct.π (fun j => (M j).X) j' = _ + rw [biproduct.ι_π_ne _ h] + rfl) + +/-- Taking the underlying morphism of a module map is additive. -/ +def modHomAddHom [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] (A : D) [MonObj A] + (P Q : Mod D A) : (P ⟶ Q) →+ (P.X ⟶ Q.X) where + toFun f := f.hom + map_zero' := rfl + map_add' _ _ := rfl + +/-- The bicone of the finite biproduct of modules is total. -/ +theorem modBicone_total [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] (A : D) [MonObj A] + {K : Type} [Fintype K] (M : K → Mod D A) : + ∑ j, Bicone.π (modBicone A M) j ≫ Bicone.ι (modBicone A M) j + = 𝟙 (Bicone.pt (modBicone A M)) := by + refine Mod.hom_ext _ _ ?_ + refine Eq.trans (map_sum (modHomAddHom A (modBiproduct A M) + (modBiproduct A M)) _ Finset.univ) ?_ + exact biproduct.total + +/-- **Modules over a monoid object have finite biproducts**, +computed in the ambient category. -/ +instance instHasFiniteBiproductsMod + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] (A : D) [MonObj A] : + HasFiniteBiproducts (Mod D A) where + out _ := + { has_biproduct := fun M => HasBiproduct.mk + { bicone := modBicone A M + isBilimit := isBilimitOfTotal _ (modBicone_total A M) } } + +end FinBiprod + +/-! ## Finite products -/ + +section FinProd + +variable {D : Type u} + +/-- **Modules over a monoid object have finite products.** -/ +instance instHasFiniteProductsMod + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteProducts D] (A : D) [MonObj A] : + HasFiniteProducts (Mod D A) := + haveI : HasFiniteBiproducts D := + HasFiniteBiproducts.of_hasFiniteProducts + haveI : HasFiniteBiproducts (Mod D A) := instHasFiniteBiproductsMod A + inferInstance + +end FinProd + +/-! ## Kernels -/ + +section Kernels + +variable {D : Type u} + +/-- The action carried by the kernel lands in the kernel. -/ +theorem kerAct_aux [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasKernels D] (A : D) [MonObj A] {M : Mod D A} + {N : Mod D A} (f : M ⟶ N) : + (A ◁ kernel.ι f.hom ≫ actLeft A M.X) ≫ f.hom = 0 := by + rw [Category.assoc, actLeft_natural A M.X N.X f.hom, + ← MonoidalCategory.whiskerLeft_comp_assoc, kernel.condition, + MonoidalPreadditive.whiskerLeft_zero, Limits.zero_comp] + +/-- **The action on the kernel** of the underlying morphism. -/ +noncomputable def kerAct [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasKernels D] (A : D) [MonObj A] {M : Mod D A} + {N : Mod D A} (f : M ⟶ N) : A ⊗ kernel f.hom ⟶ kernel f.hom := + kernel.lift f.hom (A ◁ kernel.ι f.hom ≫ actLeft A M.X) + (kerAct_aux A f) + +@[reassoc (attr := simp)] +theorem kerAct_ι [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasKernels D] (A : D) [MonObj A] {M : Mod D A} + {N : Mod D A} (f : M ⟶ N) : + kerAct A f ≫ kernel.ι f.hom + = A ◁ kernel.ι f.hom ≫ actLeft A M.X := + kernel.lift_ι _ _ _ + +/-- Unitality of the action on the kernel. -/ +theorem kerAct_one [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasKernels D] (A : D) [MonObj A] {M : Mod D A} + {N : Mod D A} (f : M ⟶ N) : + η[A] ▷ kernel f.hom ≫ kerAct A f + = (λ_ (kernel f.hom)).hom := by + refine (cancel_mono (kernel.ι f.hom)).1 ?_ + rw [Category.assoc, kerAct_ι, ← Category.assoc, ← whisker_exchange, + Category.assoc, one_actLeft, leftUnitor_naturality] + +/-- Associativity of the action on the kernel. -/ +theorem kerAct_mul [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasKernels D] (A : D) [MonObj A] {M : Mod D A} + {N : Mod D A} (f : M ⟶ N) : + μ[A] ▷ kernel f.hom ≫ kerAct A f + = (α_ A A (kernel f.hom)).hom ≫ A ◁ kerAct A f ≫ kerAct A f := by + refine (cancel_mono (kernel.ι f.hom)).1 ?_ + rw [Category.assoc, kerAct_ι, ← Category.assoc, ← whisker_exchange, + Category.assoc, mul_actLeft, Category.assoc, Category.assoc, + kerAct_ι, ← MonoidalCategory.whiskerLeft_comp_assoc, kerAct_ι, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + associator_naturality_right_assoc] + +/-- The module structure on the kernel of the underlying +morphism. -/ +@[implicit_reducible] +noncomputable def kerModObj + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasKernels D] (A : D) [MonObj A] {M : Mod D A} + {N : Mod D A} (f : M ⟶ N) : ModObj A (kernel f.hom) where + smul := kerAct A f + one_smul := kerAct_one A f + mul_smul := kerAct_mul A f + +/-- **The kernel of a module map**, bundled. -/ +noncomputable def kerMod [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasKernels D] (A : D) [MonObj A] {M : Mod D A} + {N : Mod D A} (f : M ⟶ N) : Mod D A := + letI := kerModObj A f + ⟨kernel f.hom⟩ + +/-- The inclusion of the kernel of a module map. -/ +noncomputable def kerIncl [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasKernels D] (A : D) [MonObj A] {M : Mod D A} + {N : Mod D A} (f : M ⟶ N) : kerMod A f ⟶ M := + Mod.Hom.mk' (kernel.ι f.hom) (by exact kerAct_ι A f) + +@[simp] theorem kerIncl_hom + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasKernels D] (A : D) [MonObj A] {M : Mod D A} + {N : Mod D A} (f : M ⟶ N) : (kerIncl A f).hom = kernel.ι f.hom := + rfl + +/-- The inclusion of the kernel is annihilated by the map. -/ +theorem kerIncl_comp [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasKernels D] (A : D) [MonObj A] {M : Mod D A} + {N : Mod D A} (f : M ⟶ N) : kerIncl A f ≫ f = 0 := + Mod.hom_ext _ _ (kernel.condition f.hom) + +/-- The inclusion of the kernel is a monomorphism. -/ +theorem mono_kerIncl [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasKernels D] (A : D) [MonObj A] {M : Mod D A} + {N : Mod D A} (f : M ⟶ N) : Mono (kerIncl A f) := + mono_of_mono_hom _ (by + change Mono (kernel.ι f.hom) + infer_instance) + +/-- The lift of a module map annihilated by `f` through the +inclusion of the kernel. -/ +noncomputable def kerLift [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasKernels D] (A : D) [MonObj A] {M : Mod D A} + {N : Mod D A} (f : M ⟶ N) + {W : Mod D A} (k : W ⟶ M) + (hk : k ≫ f = 0) : W ⟶ kerMod A f := + Mod.Hom.mk' + (kernel.lift f.hom k.hom (by simpa using congrArg Mod.Hom.hom hk)) + (by + change actLeft A W.X ≫ kernel.lift f.hom k.hom (by simpa using congrArg Mod.Hom.hom hk) + = A ◁ kernel.lift f.hom k.hom (by simpa using congrArg Mod.Hom.hom hk) ≫ kerAct A f + refine (cancel_mono (kernel.ι f.hom)).1 ?_ + rw [Category.assoc, kernel.lift_ι, Category.assoc, kerAct_ι, + ← MonoidalCategory.whiskerLeft_comp_assoc, kernel.lift_ι, + actLeft_natural A W.X M.X k.hom] + all_goals simpa using congrArg Mod.Hom.hom hk) + +/-- The lift through the kernel recovers the given map. -/ +theorem kerLift_comp [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasKernels D] (A : D) [MonObj A] {M : Mod D A} + {N : Mod D A} (f : M ⟶ N) + {W : Mod D A} (k : W ⟶ M) (hk : k ≫ f = 0) : + kerLift A f k hk ≫ kerIncl A f = k := + Mod.hom_ext _ _ (kernel.lift_ι _ _ _) + +/-- The kernel fork of a module map. -/ +noncomputable def kernelForkMod + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasKernels D] (A : D) [MonObj A] {M : Mod D A} + {N : Mod D A} (f : M ⟶ N) : KernelFork f := + KernelFork.ofι (kerIncl A f) (kerIncl_comp A f) + +/-- **The kernel fork of a module map is limiting.** -/ +noncomputable def kernelForkModIsLimit + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasKernels D] (A : D) [MonObj A] {M : Mod D A} + {N : Mod D A} (f : M ⟶ N) : IsLimit (kernelForkMod A f) := + haveI := mono_kerIncl A f + KernelFork.IsLimit.ofι' (kerIncl A f) (kerIncl_comp A f) + fun k hk => ⟨kerLift A f k hk, kerLift_comp A f k hk⟩ + +end Kernels + +section KernelsInst + +variable {D : Type u} + +/-- **Modules over a monoid object have kernels**, computed in the +ambient category. -/ +instance instHasKernelsMod [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasKernels D] (A : D) [MonObj A] : + HasKernels (Mod D A) where + has_limit g := HasLimit.mk + { cone := kernelForkMod A g + isLimit := kernelForkModIsLimit A g } + +end KernelsInst + +/-! ## Cokernels -/ + +section Cokernels + +variable {D : Type u} + +/-- Whiskering a cokernel projection leaves an epimorphism. -/ +theorem epi_whiskerLeft_cokernelπ + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasCokernels D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Z : D) {X Y : D} (g : X ⟶ Y) : + Epi (Z ◁ cokernel.π g) := + epi_of_isColimit_cofork + (isColimitOfHasCokernelOfPreservesColimit (tensorLeft Z) g) + +/-- **Descent along a whiskered cokernel projection.** -/ +noncomputable def whiskerCokernelDesc + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasCokernels D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Z : D) {X Y W : D} (g : X ⟶ Y) + (k : Z ⊗ Y ⟶ W) (hk : Z ◁ g ≫ k = 0) : Z ⊗ cokernel g ⟶ W := + (isColimitOfHasCokernelOfPreservesColimit (tensorLeft Z) g).desc + (CokernelCofork.ofπ k (by exact hk)) + +@[reassoc (attr := simp)] +theorem whiskerCokernel_π_desc + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasCokernels D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Z : D) {X Y W : D} (g : X ⟶ Y) + (k : Z ⊗ Y ⟶ W) (hk : Z ◁ g ≫ k = 0) : + Z ◁ cokernel.π g ≫ whiskerCokernelDesc Z g k hk = k := by + exact Cofork.IsColimit.π_desc + (isColimitOfHasCokernelOfPreservesColimit (tensorLeft Z) g) + +/-- The descended action is well defined. -/ +theorem cokerAct_aux + [Category.{v} D] [MonoidalCategory D] [Preadditive D] [HasCokernels D] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (f : M ⟶ N) : + A ◁ f.hom ≫ actLeft A N.X ≫ cokernel.π f.hom = 0 := by + rw [← Category.assoc, ← actLeft_natural A M.X N.X f.hom, + Category.assoc, cokernel.condition, Limits.comp_zero] + +/-- **The action on the cokernel** of the underlying morphism. -/ +noncomputable def cokerAct [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasCokernels D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (f : M ⟶ N) : + A ⊗ cokernel f.hom ⟶ cokernel f.hom := + whiskerCokernelDesc A f.hom (actLeft A N.X ≫ cokernel.π f.hom) + (cokerAct_aux A f) + +@[reassoc (attr := simp)] +theorem π_cokerAct [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasCokernels D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (f : M ⟶ N) : + A ◁ cokernel.π f.hom ≫ cokerAct A f + = actLeft A N.X ≫ cokernel.π f.hom := + whiskerCokernel_π_desc _ _ _ _ + +/-- Unitality of the action on the cokernel. -/ +theorem cokerAct_one [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasCokernels D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (f : M ⟶ N) : + η[A] ▷ cokernel f.hom ≫ cokerAct A f + = (λ_ (cokernel f.hom)).hom := by + have := epi_whiskerLeft_cokernelπ (𝟙_ D) f.hom + refine (cancel_epi ((𝟙_ D) ◁ cokernel.π f.hom)).1 ?_ + rw [← Category.assoc, whisker_exchange, Category.assoc, + π_cokerAct, ← Category.assoc, one_actLeft, leftUnitor_naturality] + +/-- Associativity of the action on the cokernel. -/ +theorem cokerAct_mul [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasCokernels D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (f : M ⟶ N) : + μ[A] ▷ cokernel f.hom ≫ cokerAct A f + = (α_ A A (cokernel f.hom)).hom + ≫ A ◁ cokerAct A f ≫ cokerAct A f := by + have := epi_whiskerLeft_cokernelπ (A ⊗ A) f.hom + refine (cancel_epi ((A ⊗ A) ◁ cokernel.π f.hom)).1 ?_ + rw [← Category.assoc, whisker_exchange, Category.assoc, + π_cokerAct, ← Category.assoc, mul_actLeft, Category.assoc, + Category.assoc, associator_naturality_right_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, π_cokerAct, + MonoidalCategory.whiskerLeft_comp, Category.assoc, π_cokerAct] + +/-- The module structure on the cokernel of the underlying +morphism. -/ +@[implicit_reducible] +noncomputable def cokerModObj + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasCokernels D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (f : M ⟶ N) : + ModObj A (cokernel f.hom) where + smul := cokerAct A f + one_smul := cokerAct_one A f + mul_smul := cokerAct_mul A f + +/-- **The cokernel of a module map**, bundled. -/ +noncomputable def cokerMod [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasCokernels D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (f : M ⟶ N) : Mod D A := + letI := cokerModObj A f + ⟨cokernel f.hom⟩ + +/-- The projection onto the cokernel of a module map. -/ +noncomputable def cokerProj + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasCokernels D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (f : M ⟶ N) : + N ⟶ cokerMod A f := + Mod.Hom.mk' (cokernel.π f.hom) (by exact (π_cokerAct A f).symm) + +@[simp] theorem cokerProj_hom + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasCokernels D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (f : M ⟶ N) : + (cokerProj A f).hom = cokernel.π f.hom := rfl + +/-- The projection onto the cokernel annihilates the map. -/ +theorem comp_cokerProj [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasCokernels D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (f : M ⟶ N) : + f ≫ cokerProj A f = 0 := + Mod.hom_ext _ _ (cokernel.condition f.hom) + +/-- The projection onto the cokernel is an epimorphism. -/ +theorem epi_cokerProj [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasCokernels D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (f : M ⟶ N) : + Epi (cokerProj A f) := + epi_of_epi_hom _ (by + change Epi (cokernel.π f.hom) + infer_instance) + +/-- The descent of a module map annihilating `f` through the +projection onto the cokernel. -/ +noncomputable def cokerDesc + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasCokernels D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (f : M ⟶ N) + {W : Mod D A} (k : N ⟶ W) + (hk : f ≫ k = 0) : cokerMod A f ⟶ W := + Mod.Hom.mk' + (cokernel.desc f.hom k.hom (by simpa using congrArg Mod.Hom.hom hk)) + (by + change cokerAct A f ≫ cokernel.desc f.hom k.hom (by simpa using congrArg Mod.Hom.hom hk) + = A ◁ cokernel.desc f.hom k.hom (by simpa using congrArg Mod.Hom.hom hk) ≫ actLeft A W.X + have := epi_whiskerLeft_cokernelπ A f.hom + refine (cancel_epi (A ◁ cokernel.π f.hom)).1 ?_ + rw [← Category.assoc, π_cokerAct, Category.assoc, + cokernel.π_desc, ← MonoidalCategory.whiskerLeft_comp_assoc, + cokernel.π_desc, actLeft_natural A N.X W.X k.hom] + all_goals simpa using congrArg Mod.Hom.hom hk) + +/-- The descent through the cokernel recovers the given map. -/ +theorem cokerProj_desc [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasCokernels D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (f : M ⟶ N) + {W : Mod D A} (k : N ⟶ W) (hk : f ≫ k = 0) : + cokerProj A f ≫ cokerDesc A f k hk = k := + Mod.hom_ext _ _ (cokernel.π_desc _ _ _) + +/-- The cokernel cofork of a module map. -/ +noncomputable def cokernelCoforkMod + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasCokernels D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (f : M ⟶ N) : + CokernelCofork f := + CokernelCofork.ofπ (cokerProj A f) (comp_cokerProj A f) + +/-- **The cokernel cofork of a module map is colimiting.** -/ +noncomputable def cokernelCoforkModIsColimit + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasCokernels D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (f : M ⟶ N) : + IsColimit (cokernelCoforkMod A f) := + haveI := epi_cokerProj A f + CokernelCofork.IsColimit.ofπ' (cokerProj A f) (comp_cokerProj A f) + fun k hk => ⟨cokerDesc A f k hk, cokerProj_desc A f k hk⟩ + +end Cokernels + +section CokernelsInst + +variable {D : Type u} + +/-- **Modules over a monoid object have cokernels**, computed in +the ambient category. -/ +instance instHasCokernelsMod + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasCokernels D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] : HasCokernels (Mod D A) where + has_colimit g := HasColimit.mk + { cocone := cokernelCoforkMod A g + isColimit := cokernelCoforkModIsColimit A g } + +end CokernelsInst + +/-! ## The monomorphism and epimorphism bridges -/ + +section MonoBridge + +variable {D : Type u} + +/-- **A module map is a monomorphism exactly when its underlying +morphism is.** -/ +theorem mono_iff_hom [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} + (f : M ⟶ N) : Mono f ↔ Mono f.hom := by + refine ⟨fun hf => ?_, mono_of_mono_hom f⟩ + have h0 : kerIncl A f = 0 := by + refine (cancel_mono f).1 ?_ + rw [kerIncl_comp, Limits.zero_comp] + have hi : kernel.ι f.hom = 0 := congrArg Mod.Hom.hom h0 + rw [Preadditive.mono_iff_cancel_zero] + intro R w hw + rw [← kernel.lift_ι f.hom w hw, hi, Limits.comp_zero] + +/-- **Whiskering preserves epimorphisms**: an epimorphism of an +abelian category is the cokernel of its kernel, and tensoring on +the left preserves that cokernel. -/ +theorem epi_whiskerLeft [Category.{v} D] [MonoidalCategory D] [Abelian D] + [∀ Z : D, + PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Z : D) {X Y : D} (e : X ⟶ Y) [Epi e] : Epi (Z ◁ e) := by + have h := Abelian.epiIsCokernelOfKernel _ (kernelIsKernel e) + exact epi_of_isColimit_cofork + (isColimitMapCoconeCoforkEquiv (tensorLeft Z) _ + (isColimitOfPreserves (tensorLeft Z) h)) + +end MonoBridge + +section EpiBridge + +variable {D : Type u} + +/-- **A module map is an epimorphism exactly when its underlying +morphism is.** -/ +theorem epi_iff_hom [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} + (f : M ⟶ N) : Epi f ↔ Epi f.hom := by + refine ⟨fun hf => ?_, epi_of_epi_hom f⟩ + have h0 : cokerProj A f = 0 := by + refine (cancel_epi f).1 ?_ + rw [comp_cokerProj, Limits.comp_zero] + have hp : cokernel.π f.hom = 0 := congrArg Mod.Hom.hom h0 + rw [Preadditive.epi_iff_cancel_zero] + intro R w hw + rw [← cokernel.π_desc f.hom w hw, hp, Limits.zero_comp] + +end EpiBridge + +/-! ## Normality and abelianness -/ + +section Normal + +variable {D : Type u} + +/-- A module map annihilated by the projection onto the cokernel is +annihilated by the underlying cokernel projection. -/ +theorem monoLift_aux [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (φ : M ⟶ N) + {W : Mod D A} (k : W ⟶ N) + (hk : k ≫ cokerProj A φ = 0) : k.hom ≫ cokernel.π φ.hom = 0 := + congrArg Mod.Hom.hom hk + +/-- The underlying factorisation through a monomorphic module +map. -/ +noncomputable def monoLiftHom [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (φ : M ⟶ N) + [Mono φ.hom] {W : Mod D A} (k : W ⟶ N) + (hk : k ≫ cokerProj A φ = 0) : W.X ⟶ M.X := + (Abelian.monoIsKernelOfCokernel _ (cokernelIsCokernel φ.hom)).lift + (KernelFork.ofι k.hom (monoLift_aux A φ k hk)) + +@[reassoc] +theorem monoLiftHom_comp [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (φ : M ⟶ N) + [Mono φ.hom] {W : Mod D A} (k : W ⟶ N) + (hk : k ≫ cokerProj A φ = 0) : + monoLiftHom A φ k hk ≫ φ.hom = k.hom := by + exact Fork.IsLimit.lift_ι _ + +/-- The underlying factorisation intertwines the actions. -/ +theorem monoLiftHom_lin [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (φ : M ⟶ N) + [Mono φ.hom] {W : Mod D A} (k : W ⟶ N) + (hk : k ≫ cokerProj A φ = 0) : + actLeft A W.X ≫ monoLiftHom A φ k hk + = A ◁ monoLiftHom A φ k hk ≫ actLeft A M.X := by + refine (cancel_mono φ.hom).1 ?_ + rw [Category.assoc, monoLiftHom_comp, Category.assoc, + actLeft_natural A M.X N.X φ.hom, + ← MonoidalCategory.whiskerLeft_comp_assoc, monoLiftHom_comp, + actLeft_natural A W.X N.X k.hom] + +/-- The factorisation through a monomorphism of a module map +annihilated by the projection onto its cokernel. -/ +noncomputable def monoLift [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (φ : M ⟶ N) + [Mono φ.hom] {W : Mod D A} (k : W ⟶ N) + (hk : k ≫ cokerProj A φ = 0) : W ⟶ M := + Mod.Hom.mk' (monoLiftHom A φ k hk) + (by exact monoLiftHom_lin A φ k hk) + +/-- The factorisation through a monomorphism recovers the given +map. -/ +theorem monoLift_comp [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (φ : M ⟶ N) + [Mono φ.hom] {W : Mod D A} (k : W ⟶ N) + (hk : k ≫ cokerProj A φ = 0) : monoLift A φ k hk ≫ φ = k := + Mod.hom_ext _ _ (monoLiftHom_comp A φ k hk) + +/-- **A module map with monomorphic underlying morphism is the +kernel of its cokernel.** -/ +@[implicit_reducible] +noncomputable def normalMonoOfMonoHom + [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (φ : M ⟶ N) + [Mono φ.hom] : NormalMono φ where + Z := cokerMod A φ + g := cokerProj A φ + w := comp_cokerProj A φ + isLimit := + haveI : Mono φ := mono_of_mono_hom φ inferInstance + KernelFork.IsLimit.ofι' φ (comp_cokerProj A φ) + fun k hk => ⟨monoLift A φ k hk, monoLift_comp A φ k hk⟩ + +/-- A module map annihilating the inclusion of the kernel is +annihilated by the underlying kernel inclusion. -/ +theorem epiDesc_aux [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} + (φ : M ⟶ N) + {W : Mod D A} (k : M ⟶ W) + (hk : kerIncl A φ ≫ k = 0) : kernel.ι φ.hom ≫ k.hom = 0 := + congrArg Mod.Hom.hom hk + +/-- The underlying factorisation through an epimorphic module +map. -/ +noncomputable def epiDescHom [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} + (φ : M ⟶ N) + [Epi φ.hom] {W : Mod D A} (k : M ⟶ W) + (hk : kerIncl A φ ≫ k = 0) : N.X ⟶ W.X := + (Abelian.epiIsCokernelOfKernel _ (kernelIsKernel φ.hom)).desc + (CokernelCofork.ofπ k.hom (epiDesc_aux A φ k hk)) + +/-- The underlying factorisation recovers the given map. -/ +@[reassoc] +theorem comp_epiDescHom [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} + (φ : M ⟶ N) + [Epi φ.hom] {W : Mod D A} (k : M ⟶ W) + (hk : kerIncl A φ ≫ k = 0) : + φ.hom ≫ epiDescHom A φ k hk = k.hom := by + exact Cofork.IsColimit.π_desc + (Abelian.epiIsCokernelOfKernel _ (kernelIsKernel φ.hom)) + +/-- The underlying factorisation intertwines the actions. -/ +theorem epiDescHom_lin [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (φ : M ⟶ N) + [Epi φ.hom] {W : Mod D A} (k : M ⟶ W) + (hk : kerIncl A φ ≫ k = 0) : + actLeft A N.X ≫ epiDescHom A φ k hk + = A ◁ epiDescHom A φ k hk ≫ actLeft A W.X := by + have := epi_whiskerLeft A (e := φ.hom) + refine (cancel_epi (A ◁ φ.hom)).1 ?_ + rw [← Category.assoc, ← actLeft_natural A M.X N.X φ.hom, + Category.assoc, comp_epiDescHom, + ← MonoidalCategory.whiskerLeft_comp_assoc, comp_epiDescHom, + actLeft_natural A M.X W.X k.hom] + +/-- The factorisation through an epimorphism of a module map +annihilating the inclusion of its kernel. -/ +noncomputable def epiDesc [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (φ : M ⟶ N) + [Epi φ.hom] {W : Mod D A} (k : M ⟶ W) + (hk : kerIncl A φ ≫ k = 0) : N ⟶ W := + Mod.Hom.mk' (epiDescHom A φ k hk) + (by exact epiDescHom_lin A φ k hk) + +/-- The factorisation through an epimorphism recovers the given +map. -/ +theorem comp_epiDesc [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (φ : M ⟶ N) + [Epi φ.hom] {W : Mod D A} (k : M ⟶ W) + (hk : kerIncl A φ ≫ k = 0) : φ ≫ epiDesc A φ k hk = k := + Mod.hom_ext _ _ (comp_epiDescHom A φ k hk) + +/-- **A module map with epimorphic underlying morphism is the +cokernel of its kernel.** -/ +@[implicit_reducible] +noncomputable def normalEpiOfEpiHom + [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (φ : M ⟶ N) + [Epi φ.hom] : NormalEpi φ where + W := kerMod A φ + g := kerIncl A φ + w := kerIncl_comp A φ + isColimit := + haveI : Epi φ := epi_of_epi_hom φ inferInstance + CokernelCofork.IsColimit.ofπ' φ (kerIncl_comp A φ) + fun k hk => ⟨epiDesc A φ k hk, comp_epiDesc A φ k hk⟩ + +end Normal + +section AbelianMod + +variable {D : Type u} + +/-- **Every monomorphism of modules is a kernel.** -/ +instance instIsNormalMonoCategoryMod + [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] : + IsNormalMonoCategory (Mod D A) where + normalMonoOfMono φ hφ := + haveI : Mono φ.hom := (mono_iff_hom A φ).1 hφ + ⟨normalMonoOfMonoHom A φ⟩ + +/-- **Every epimorphism of modules is a cokernel.** -/ +instance instIsNormalEpiCategoryMod + [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] : + IsNormalEpiCategory (Mod D A) where + normalEpiOfEpi φ hφ := + haveI : Epi φ.hom := (epi_iff_hom A φ).1 hφ + ⟨normalEpiOfEpiHom A φ⟩ + +/-- **Modules over a monoid object in an abelian monoidally +preadditive category with right-exact tensor form an abelian +category.** -/ +noncomputable instance instAbelianMod + [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] : Abelian (Mod D A) where + normalMonoOfMono φ hφ := + haveI : Mono φ.hom := (mono_iff_hom A φ).1 hφ + ⟨normalMonoOfMonoHom A φ⟩ + normalEpiOfEpi φ hφ := + haveI : Epi φ.hom := (epi_iff_hom A φ).1 hφ + ⟨normalEpiOfEpiHom A φ⟩ + +/-- **The forgetful functor preserves monomorphisms.** -/ +instance instForgetPreservesMono + [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] (A : D) [MonObj A] : + (Mod.forget (D := D) A).PreservesMonomorphisms where + preserves φ hφ := (mono_iff_hom A φ).1 hφ + +/-- **The forgetful functor reflects monomorphisms.** -/ +instance instForgetReflectsMono + [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] (A : D) [MonObj A] : + (Mod.forget (D := D) A).ReflectsMonomorphisms where + reflects φ hφ := (mono_iff_hom A φ).2 hφ + +/-- **The forgetful functor preserves epimorphisms.** -/ +instance instForgetPreservesEpi + [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] : + (Mod.forget (D := D) A).PreservesEpimorphisms where + preserves φ hφ := (epi_iff_hom A φ).1 hφ + +/-- **The forgetful functor reflects epimorphisms.** -/ +instance instForgetReflectsEpi [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] : + (Mod.forget (D := D) A).ReflectsEpimorphisms where + reflects φ hφ := (epi_iff_hom A φ).2 hφ + +end AbelianMod + +/-! ## Splitting off a retraction or a section -/ + +section Split + +variable {E : Type u} + +/-- The section of the cokernel projection determined by a +retraction. -/ +noncomputable def retractionSection + [Category.{v} E] [Abelian E] {K : E} {N : E} (k : K ⟶ N) (r : N ⟶ K) + (hr : k ≫ r = 𝟙 K) : cokernel k ⟶ N := + cokernel.desc k (𝟙 N - r ≫ k) (by + rw [Preadditive.comp_sub, Category.comp_id, ← Category.assoc, hr, + Category.id_comp, sub_self]) + +@[reassoc] +theorem π_retractionSection + [Category.{v} E] [Abelian E] {K : E} {N : E} (k : K ⟶ N) (r : N ⟶ K) + (hr : k ≫ r = 𝟙 K) : + cokernel.π k ≫ retractionSection k r hr = 𝟙 N - r ≫ k := + cokernel.π_desc _ _ _ + +/-- The section is a section of the cokernel projection. -/ +theorem retractionSection_π + [Category.{v} E] [Abelian E] {K : E} {N : E} (k : K ⟶ N) (r : N ⟶ K) + (hr : k ≫ r = 𝟙 K) : + retractionSection k r hr ≫ cokernel.π k = 𝟙 (cokernel k) := by + refine (cancel_epi (cokernel.π k)).1 ?_ + rw [← Category.assoc, π_retractionSection, Preadditive.sub_comp, + Category.id_comp, Category.assoc, cokernel.condition, + Limits.comp_zero, sub_zero, Category.comp_id] + +/-- The section is annihilated by the retraction. -/ +theorem retractionSection_comp + [Category.{v} E] [Abelian E] {K : E} {N : E} (k : K ⟶ N) (r : N ⟶ K) + (hr : k ≫ r = 𝟙 K) : + retractionSection k r hr ≫ r = 0 := by + refine (cancel_epi (cokernel.π k)).1 ?_ + rw [← Category.assoc, π_retractionSection, Preadditive.sub_comp, + Category.id_comp, Category.assoc, hr, Category.comp_id, sub_self, + Limits.comp_zero] + +/-- The bicone exhibiting the ambient object as the biproduct of a +split monomorphism and its cokernel. -/ +noncomputable def retractionBicone + [Category.{v} E] [Abelian E] {K : E} {N : E} (k : K ⟶ N) (r : N ⟶ K) + (hr : k ≫ r = 𝟙 K) : BinaryBicone K (cokernel k) where + pt := N + fst := r + snd := cokernel.π k + inl := k + inr := retractionSection k r hr + inl_fst := hr + inl_snd := cokernel.condition k + inr_fst := retractionSection_comp k r hr + inr_snd := retractionSection_π k r hr + +/-- The bicone determined by a retraction is total. -/ +theorem retractionBicone_total + [Category.{v} E] [Abelian E] {K : E} {N : E} (k : K ⟶ N) (r : N ⟶ K) + (hr : k ≫ r = 𝟙 K) : + (retractionBicone k r hr).fst ≫ (retractionBicone k r hr).inl + + (retractionBicone k r hr).snd + ≫ (retractionBicone k r hr).inr + = 𝟙 (retractionBicone k r hr).pt := by + change r ≫ k + cokernel.π k ≫ retractionSection k r hr = 𝟙 N + rw [π_retractionSection] + abel + +/-- **A retraction splits off the cokernel**: if `k : K ⟶ N` has a +retraction then `N` is the biproduct of `K` and the cokernel of +`k`. -/ +noncomputable def isoBiprodOfRetraction + [Category.{v} E] [Abelian E] {K : E} {N : E} (k : K ⟶ N) (r : N ⟶ K) + (hr : k ≫ r = 𝟙 K) : N ≅ K ⊞ cokernel k := + biprod.uniqueUpToIso K (cokernel k) + (isBinaryBilimitOfTotal (retractionBicone k r hr) + (retractionBicone_total k r hr)) + +end Split + +section CoSplit + +variable {E : Type u} + +/-- The retraction of the kernel inclusion determined by a +section. -/ +noncomputable def sectionRetraction + [Category.{v} E] [Abelian E] {C : E} {N : E} (c : N ⟶ C) (s : C ⟶ N) + (hs : s ≫ c = 𝟙 C) : N ⟶ kernel c := + kernel.lift c (𝟙 N - c ≫ s) (by + rw [Preadditive.sub_comp, Category.id_comp, Category.assoc, hs, + Category.comp_id, sub_self]) + +@[reassoc] +theorem sectionRetraction_ι + [Category.{v} E] [Abelian E] {C : E} {N : E} (c : N ⟶ C) (s : C ⟶ N) + (hs : s ≫ c = 𝟙 C) : + sectionRetraction c s hs ≫ kernel.ι c = 𝟙 N - c ≫ s := + kernel.lift_ι _ _ _ + +/-- The retraction is a retraction of the kernel inclusion. -/ +theorem ι_sectionRetraction + [Category.{v} E] [Abelian E] {C : E} {N : E} (c : N ⟶ C) (s : C ⟶ N) + (hs : s ≫ c = 𝟙 C) : + kernel.ι c ≫ sectionRetraction c s hs = 𝟙 (kernel c) := by + refine (cancel_mono (kernel.ι c)).1 ?_ + rw [Category.assoc, sectionRetraction_ι, Preadditive.comp_sub, + Category.comp_id, ← Category.assoc, kernel.condition, + Limits.zero_comp, sub_zero, Category.id_comp] + +/-- The section is annihilated by the retraction. -/ +theorem comp_sectionRetraction + [Category.{v} E] [Abelian E] {C : E} {N : E} (c : N ⟶ C) (s : C ⟶ N) + (hs : s ≫ c = 𝟙 C) : + s ≫ sectionRetraction c s hs = 0 := by + refine (cancel_mono (kernel.ι c)).1 ?_ + rw [Category.assoc, sectionRetraction_ι, Preadditive.comp_sub, + Category.comp_id, ← Category.assoc, hs, Category.id_comp, + sub_self, Limits.zero_comp] + +/-- The bicone exhibiting the ambient object as the biproduct of the +kernel of a split epimorphism and its target. -/ +noncomputable def sectionBicone + [Category.{v} E] [Abelian E] {C : E} {N : E} (c : N ⟶ C) (s : C ⟶ N) + (hs : s ≫ c = 𝟙 C) : BinaryBicone (kernel c) C where + pt := N + fst := sectionRetraction c s hs + snd := c + inl := kernel.ι c + inr := s + inl_fst := ι_sectionRetraction c s hs + inl_snd := kernel.condition c + inr_fst := comp_sectionRetraction c s hs + inr_snd := hs + +/-- The bicone determined by a section is total. -/ +theorem sectionBicone_total + [Category.{v} E] [Abelian E] {C : E} {N : E} (c : N ⟶ C) (s : C ⟶ N) + (hs : s ≫ c = 𝟙 C) : + (sectionBicone c s hs).fst ≫ (sectionBicone c s hs).inl + + (sectionBicone c s hs).snd ≫ (sectionBicone c s hs).inr + = 𝟙 (sectionBicone c s hs).pt := by + change sectionRetraction c s hs ≫ kernel.ι c + c ≫ s = 𝟙 N + rw [sectionRetraction_ι] + abel + +/-- **A section splits off the kernel**: if `c : N ⟶ C` has a +section then `N` is the biproduct of the kernel of `c` and `C`. -/ +noncomputable def isoBiprodOfSection + [Category.{v} E] [Abelian E] {C : E} {N : E} (c : N ⟶ C) (s : C ⟶ N) + (hs : s ≫ c = 𝟙 C) : N ≅ kernel c ⊞ C := + biprod.uniqueUpToIso (kernel c) C + (isBinaryBilimitOfTotal (sectionBicone c s hs) + (sectionBicone_total c s hs)) + +end CoSplit + +/-! ## Subobjects and quotients of a finite sum of simples -/ + +section SimpleSum + +variable {E : Type u} + +/-- **The inductive step for subobjects**: a subobject of `X ⊞ T` +with `X` simple is either a subobject of `T`, or the sum of `X` +with one. -/ +theorem exists_subobject_of_mono_biprod [Category.{v} E] [Abelian E] + {X T N : E} [Simple X] + (f : N ⟶ (X ⊞ T)) [Mono f] : + ∃ (C : E) (m : C ⟶ T), Mono m ∧ + (Nonempty (N ≅ C) ∨ Nonempty (N ≅ (X ⊞ C))) := by + have hfac : kernel.ι (f ≫ biprod.snd) ≫ f + = (kernel.ι (f ≫ biprod.snd) ≫ f ≫ biprod.fst) + ≫ biprod.inl := by + refine biprod.hom_ext _ _ ?_ ?_ <;> simp [Category.assoc] + have : Mono (kernel.ι (f ≫ biprod.snd) ≫ f) := mono_comp _ _ + have : Mono (kernel.ι (f ≫ biprod.snd) ≫ f ≫ biprod.fst) := + mono_of_mono_fac hfac.symm + refine ⟨Abelian.coimage (f ≫ biprod.snd), + Abelian.factorThruCoimage (f ≫ biprod.snd), inferInstance, ?_⟩ + by_cases hu : kernel.ι (f ≫ biprod.snd) ≫ f ≫ biprod.fst = 0 + · have hk0 : kernel.ι (f ≫ biprod.snd) = 0 := by + refine zero_of_comp_mono f ?_ + rw [hfac, hu, Limits.zero_comp] + have hKz : IsZero (kernel (f ≫ biprod.snd)) := by + rw [IsZero.iff_id_eq_zero] + refine (cancel_mono (kernel.ι (f ≫ biprod.snd))).1 ?_ + rw [Category.id_comp, hk0, Limits.zero_comp] + have hr : kernel.ι (f ≫ biprod.snd) + ≫ (0 : N ⟶ kernel (f ≫ biprod.snd)) + = 𝟙 (kernel (f ≫ biprod.snd)) := hKz.eq_of_tgt _ _ + exact Or.inl ⟨isoBiprodOfRetraction _ 0 hr + ≪≫ (isoZeroBiprod hKz).symm⟩ + · have : IsIso (kernel.ι (f ≫ biprod.snd) ≫ f ≫ biprod.fst) := + isIso_of_mono_of_nonzero hu + have hr : kernel.ι (f ≫ biprod.snd) + ≫ ((f ≫ biprod.fst) + ≫ inv (kernel.ι (f ≫ biprod.snd) ≫ f ≫ biprod.fst)) + = 𝟙 (kernel (f ≫ biprod.snd)) := by + rw [← Category.assoc] + exact IsIso.hom_inv_id _ + exact Or.inr ⟨isoBiprodOfRetraction _ _ hr + ≪≫ biprod.mapIso + (asIso (kernel.ι (f ≫ biprod.snd) ≫ f ≫ biprod.fst)) + (Iso.refl _)⟩ + +/-- **The inductive step for quotients**: a quotient of `X ⊞ T` +with `X` simple is either a quotient of `T`, or the sum of `X` +with one. -/ +theorem exists_quotient_of_epi_biprod [Category.{v} E] [Abelian E] + {X T N : E} [Simple X] + (f : (X ⊞ T) ⟶ N) [Epi f] : + ∃ (C : E) (m : T ⟶ C), Epi m ∧ + (Nonempty (N ≅ C) ∨ Nonempty (N ≅ (X ⊞ C))) := by + have hg : biprod.inr ≫ f ≫ cokernel.π (biprod.inr ≫ f) = 0 := by + rw [← Category.assoc] + exact cokernel.condition _ + have hfac : f ≫ cokernel.π (biprod.inr ≫ f) + = biprod.fst + ≫ (biprod.inl ≫ f ≫ cokernel.π (biprod.inr ≫ f)) := by + refine biprod.hom_ext' _ _ ?_ ?_ <;> simp [hg] + have : Epi (biprod.inl ≫ f ≫ cokernel.π (biprod.inr ≫ f)) := by + have h1 : Epi (f ≫ cokernel.π (biprod.inr ≫ f)) := epi_comp _ _ + rw [hfac] at h1 + exact epi_of_epi (biprod.fst : (X ⊞ T) ⟶ X) + (biprod.inl ≫ f ≫ cokernel.π (biprod.inr ≫ f)) + refine ⟨Abelian.image (biprod.inr ≫ f), + Abelian.factorThruImage (biprod.inr ≫ f), inferInstance, ?_⟩ + by_cases hu : biprod.inl ≫ f ≫ cokernel.π (biprod.inr ≫ f) = 0 + · have hc0 : cokernel.π (biprod.inr ≫ f) = 0 := by + refine zero_of_epi_comp f ?_ + rw [hfac, hu, Limits.comp_zero] + have hCz : IsZero (cokernel (biprod.inr ≫ f)) := by + rw [IsZero.iff_id_eq_zero] + refine (cancel_epi (cokernel.π (biprod.inr ≫ f))).1 ?_ + rw [Category.comp_id, hc0, Limits.comp_zero] + have hs : (0 : cokernel (biprod.inr ≫ f) ⟶ N) + ≫ cokernel.π (biprod.inr ≫ f) + = 𝟙 (cokernel (biprod.inr ≫ f)) := hCz.eq_of_src _ _ + exact Or.inl ⟨isoBiprodOfSection _ 0 hs + ≪≫ (isoBiprodZero hCz).symm⟩ + · have : IsIso (biprod.inl ≫ f ≫ cokernel.π (biprod.inr ≫ f)) := + isIso_of_epi_of_nonzero hu + have hs : (inv (biprod.inl ≫ f ≫ cokernel.π (biprod.inr ≫ f)) + ≫ (biprod.inl ≫ f)) + ≫ cokernel.π (biprod.inr ≫ f) + = 𝟙 (cokernel (biprod.inr ≫ f)) := by + rw [Category.assoc, Category.assoc] + exact IsIso.inv_hom_id _ + exact Or.inr ⟨isoBiprodOfSection _ _ hs + ≪≫ biprod.mapIso (Iso.refl _) + (asIso (biprod.inl ≫ f + ≫ cokernel.π (biprod.inr ≫ f))).symm + ≪≫ biprod.braiding _ _⟩ + +/-- **The direct sum of a list of indices**, formed by iterated +binary biproducts from a family of objects. -/ +noncomputable def idxSum [Category.{v} E] [Abelian E] + {J : Type w} (S : J → E) : List J → E + | [] => 0 + | i :: L => S i ⊞ idxSum S L + +@[simp] theorem idxSum_nil [Category.{v} E] [Abelian E] + {J : Type w} (S : J → E) : + idxSum S [] = 0 := rfl + +@[simp] theorem idxSum_cons [Category.{v} E] [Abelian E] + {J : Type w} (S : J → E) (i : J) + (L : List J) : idxSum S (i :: L) = (S i ⊞ idxSum S L) := rfl + +/-- **A subobject of a finite direct sum of simple objects is the +direct sum of a sublist of them.** -/ +theorem exists_sublist_iso_of_mono [Category.{v} E] [Abelian E] + {J : Type w} (S : J → E) : + ∀ (L : List J), (∀ j ∈ L, Simple (S j)) → + ∀ {N : E} (f : N ⟶ idxSum S L), Mono f → + ∃ L' : List J, L'.Sublist L ∧ Nonempty (N ≅ idxSum S L') := by + intro L + induction L with + | nil => + intro _ N f hf + have := hf + refine ⟨[], List.Sublist.refl _, ⟨?_⟩⟩ + have h0 : IsZero N := by + rw [IsZero.iff_id_eq_zero] + refine (cancel_mono f).1 ?_ + exact (isZero_zero E).eq_of_tgt _ _ + exact h0.iso (isZero_zero E) + | cons i L₀ ih => + intro hS N f hf + have : Simple (S i) := hS i (List.mem_cons_self ..) + have : Mono (show N ⟶ (S i ⊞ idxSum S L₀) from f) := hf + obtain ⟨C, m, hm, hcase⟩ := + exists_subobject_of_mono_biprod (X := S i) + (T := idxSum S L₀) (N := N) f + obtain ⟨L', hL', ⟨e⟩⟩ := + ih (fun j hj => hS j (List.mem_cons_of_mem i hj)) m hm + rcases hcase with h | h + · obtain ⟨eN⟩ := h + exact ⟨L', hL'.cons i, ⟨eN ≪≫ e⟩⟩ + · obtain ⟨eN⟩ := h + exact ⟨i :: L', hL'.cons_cons i, + ⟨eN ≪≫ biprod.mapIso (Iso.refl (S i)) e⟩⟩ + +/-- **A quotient of a finite direct sum of simple objects is the +direct sum of a sublist of them.** -/ +theorem exists_sublist_iso_of_epi [Category.{v} E] [Abelian E] + {J : Type w} (S : J → E) : + ∀ (L : List J), (∀ j ∈ L, Simple (S j)) → + ∀ {N : E} (f : idxSum S L ⟶ N), Epi f → + ∃ L' : List J, L'.Sublist L ∧ Nonempty (N ≅ idxSum S L') := by + intro L + induction L with + | nil => + intro _ N f hf + have := hf + refine ⟨[], List.Sublist.refl _, ⟨?_⟩⟩ + have h0 : IsZero N := by + rw [IsZero.iff_id_eq_zero] + refine (cancel_epi f).1 ?_ + exact (isZero_zero E).eq_of_src _ _ + exact h0.iso (isZero_zero E) + | cons i L₀ ih => + intro hS N f hf + have : Simple (S i) := hS i (List.mem_cons_self ..) + have : Epi (show (S i ⊞ idxSum S L₀) ⟶ N from f) := hf + obtain ⟨C, m, hm, hcase⟩ := + exists_quotient_of_epi_biprod (X := S i) + (T := idxSum S L₀) (N := N) f + obtain ⟨L', hL', ⟨e⟩⟩ := + ih (fun j hj => hS j (List.mem_cons_of_mem i hj)) m hm + rcases hcase with h | h + · obtain ⟨eN⟩ := h + exact ⟨L', hL'.cons i, ⟨eN ≪≫ e⟩⟩ + · obtain ⟨eN⟩ := h + exact ⟨i :: L', hL'.cons_cons i, + ⟨eN ≪≫ biprod.mapIso (Iso.refl (S i)) e⟩⟩ + +/-! ## Sums of copies of two simple objects -/ + +/-- The direct sum of `p` copies of `X` and `q` copies of `Y`. -/ +noncomputable def mixSum [Category.{v} E] [Abelian E] + (X Y : E) (p q : ℕ) : E := + idxSum (id : E → E) (List.replicate p X ++ List.replicate q Y) + +/-- Every entry of a mixed replicate list is one of the two given +objects. -/ +theorem simple_of_mem_mix [Category.{v} E] [Abelian E] + (X Y : E) [Simple X] [Simple Y] (p q : ℕ) : + ∀ Z ∈ List.replicate p X ++ List.replicate q Y, Simple (id Z) := by + intro Z hZ + rcases List.mem_append.1 hZ with h | h + · rw [List.eq_of_mem_replicate h] + exact inferInstanceAs (Simple X) + · rw [List.eq_of_mem_replicate h] + exact inferInstanceAs (Simple Y) + +/-- **A subobject of a sum of `p` copies of a simple object and `q` +copies of another is a sum of `p' ≤ p` copies of the first and +`q' ≤ q` copies of the second.** -/ +theorem exists_mixSum_iso_of_mono [Category.{v} E] [Abelian E] + (X Y : E) [Simple X] [Simple Y] + (p q : ℕ) {N : E} (f : N ⟶ mixSum X Y p q) (hf : Mono f) : + ∃ p' q' : ℕ, p' ≤ p ∧ q' ≤ q ∧ + Nonempty (N ≅ mixSum X Y p' q') := by + obtain ⟨L, hL, e⟩ := exists_sublist_iso_of_mono (id : E → E) + (List.replicate p X ++ List.replicate q Y) + (simple_of_mem_mix X Y p q) f hf + obtain ⟨L₁, L₂, rfl, h₁, h₂⟩ := List.sublist_append_iff.1 hL + obtain ⟨p', hp', rfl⟩ := List.sublist_replicate_iff.1 h₁ + obtain ⟨q', hq', rfl⟩ := List.sublist_replicate_iff.1 h₂ + exact ⟨p', q', hp', hq', e⟩ + +/-- **A quotient of a sum of `p` copies of a simple object and `q` +copies of another is a sum of `p' ≤ p` copies of the first and +`q' ≤ q` copies of the second.** -/ +theorem exists_mixSum_iso_of_epi [Category.{v} E] [Abelian E] + (X Y : E) [Simple X] [Simple Y] + (p q : ℕ) {N : E} (f : mixSum X Y p q ⟶ N) (hf : Epi f) : + ∃ p' q' : ℕ, p' ≤ p ∧ q' ≤ q ∧ + Nonempty (N ≅ mixSum X Y p' q') := by + obtain ⟨L, hL, e⟩ := exists_sublist_iso_of_epi (id : E → E) + (List.replicate p X ++ List.replicate q Y) + (simple_of_mem_mix X Y p q) f hf + obtain ⟨L₁, L₂, rfl, h₁, h₂⟩ := List.sublist_append_iff.1 hL + obtain ⟨p', hp', rfl⟩ := List.sublist_replicate_iff.1 h₁ + obtain ⟨q', hq', rfl⟩ := List.sublist_replicate_iff.1 h₂ + exact ⟨p', q', hp', hq', e⟩ + +end SimpleSum + +/-! ## Biproducts indexed by `Fin n` -/ + +section FinIndexed + +attribute [local instance] HasFiniteBiproducts.of_hasFiniteProducts + +variable {E : Type u} + +/-- The bicone splitting off the zeroth summand of a biproduct +indexed by `Fin (n + 1)`. -/ +noncomputable def finSuccBicone [Category.{v} E] [Abelian E] + {n : ℕ} (S : Fin (n + 1) → E) : + BinaryBicone (S 0) (⨁ fun i : Fin n => S i.succ) where + pt := ⨁ S + fst := biproduct.π S 0 + snd := biproduct.lift fun i : Fin n => biproduct.π S i.succ + inl := biproduct.ι S 0 + inr := biproduct.desc fun i : Fin n => biproduct.ι S i.succ + inl_fst := biproduct.ι_π_self S 0 + inl_snd := by + refine biproduct.hom_ext _ _ fun j => ?_ + rw [Category.assoc, biproduct.lift_π, Limits.zero_comp, + biproduct.ι_π_ne S (Fin.succ_ne_zero j).symm] + inr_fst := by + refine biproduct.hom_ext' _ _ fun i => ?_ + rw [← Category.assoc, biproduct.ι_desc, Limits.comp_zero, + biproduct.ι_π_ne S (Fin.succ_ne_zero i)] + inr_snd := by + refine biproduct.hom_ext' _ _ fun i => ?_ + refine biproduct.hom_ext _ _ fun j => ?_ + rw [Category.assoc, Category.assoc, biproduct.lift_π, + ← Category.assoc, biproduct.ι_desc, Category.comp_id] + by_cases h : i = j + · subst h + rw [biproduct.ι_π_self, biproduct.ι_π_self] + · rw [biproduct.ι_π_ne _ h, biproduct.ι_π_ne S + (fun hc => h (Fin.succ_injective n hc))] + +/-- **A biproduct indexed by `Fin (n + 1)` splits off its zeroth +summand.** -/ +noncomputable def biproductFinSuccIso [Category.{v} E] [Abelian E] + {n : ℕ} (S : Fin (n + 1) → E) : + (⨁ S) ≅ (S 0 ⊞ ⨁ fun i : Fin n => S i.succ) := + biprod.uniqueUpToIso _ _ + (isBinaryBilimitOfTotal (finSuccBicone S) (by + change biproduct.π S 0 ≫ biproduct.ι S 0 + + biproduct.lift (fun i : Fin n => biproduct.π S i.succ) + ≫ (biproduct.desc fun i : Fin n => + biproduct.ι S i.succ) + = 𝟙 (⨁ S) + rw [biproduct.lift_desc] + exact (Fin.sum_univ_succ + (fun j => biproduct.π S j ≫ biproduct.ι S j)).symm.trans + biproduct.total)) + +/-- Reindexing a list sum along a map of indices. -/ +theorem idxSum_map [Category.{v} E] [Abelian E] + {J K : Type w} (S : K → E) (g : J → K) + (L : List J) : idxSum S (L.map g) = idxSum (S ∘ g) L := by + induction L with + | nil => rfl + | cons i L ih => rw [List.map_cons, idxSum_cons, ih]; rfl + +/-- **A biproduct indexed by `Fin n` is the sum over the list of +its indices.** -/ +theorem nonempty_biproduct_iso_idxSum + [Category.{v} E] [Abelian E] : ∀ (n : ℕ) (S : Fin n → E), + Nonempty ((⨁ S) ≅ idxSum S (List.finRange n)) + | 0, S => by + rw [List.finRange_zero] + have h : IsZero (⨁ S) := by + rw [IsZero.iff_id_eq_zero, ← biproduct.total] + simp + exact ⟨h.iso (isZero_zero E)⟩ + | n + 1, S => by + obtain ⟨e⟩ := + nonempty_biproduct_iso_idxSum n fun i : Fin n => S i.succ + rw [List.finRange_succ, idxSum_cons, idxSum_map] + exact ⟨biproductFinSuccIso S ≪≫ biprod.mapIso (Iso.refl _) e⟩ + +/-- **A subobject of a finite biproduct of simple objects is the +sum over a sublist of the indices.** -/ +theorem exists_sublist_iso_biproduct_of_mono [Category.{v} E] [Abelian E] + {n : ℕ} (S : Fin n → E) + (hS : ∀ i, Simple (S i)) {N : E} (f : N ⟶ ⨁ S) (hf : Mono f) : + ∃ L : List (Fin n), L.Sublist (List.finRange n) ∧ + Nonempty (N ≅ idxSum S L) := by + obtain ⟨e⟩ := nonempty_biproduct_iso_idxSum n S + have := hf + exact exists_sublist_iso_of_mono S (List.finRange n) + (fun j _ => hS j) (f ≫ e.hom) inferInstance + +end FinIndexed + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAssoc.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAssoc.lean new file mode 100644 index 0000000000..7dcfeb0497 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAssoc.lean @@ -0,0 +1,578 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulLaws + +/-! +# Associativity of the tensor product of modules + +The associator of the relative tensor of internal modules over a +commutative monoid. Both directions are double descents: the outer +coequalizer is covered through the whiskered inner projection, the +associator of the ambient category reassociates the cover, and the +two balance conditions are pure slides through associator +naturality together with the coequalizer conditions of source and +target. + +* `modTensorπ_actRight`: on the tensor product of modules the + braided right action, precomposed with the projection, is the + right action on the second factor. +* `modTensorAssocHom`/`modTensorAssocInv`: the two descents, with + defining equations against the covers. +* `modTensorAssocIso`: the packaged isomorphism, inverted on the + covers by cancelling the ambient associators. +* `modTensorAssocModIso`: the associator as an isomorphism of + bundled modules; inverse linearity follows by cancelling the + forward map. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- The braided right action on the tensor product of modules, +precomposed with the projection, is the right action on the second +factor. -/ +@[reassoc] +theorem modTensorπ_actRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) : + (modTensorπ A M N ▷ A) ≫ (β_ (modTensor A M N) A).hom ≫ + modTensorAct A M N = + (α_ M.X N.X A).hom ≫ (M.X ◁ actRight A N.X) ≫ + modTensorπ A M N := by + rw [BraidedCategory.braiding_naturality_left_assoc, + whiskerLeft_modTensorπ_act, + BraidedCategory.braiding_tensor_left_hom] + simp only [Category.assoc, Iso.hom_inv_id_assoc] + rw [← MonoidalCategory.comp_whiskerRight_assoc, + show ((β_ M.X A).hom ≫ actLeft A M.X) ▷ N.X ≫ + modTensorπ A M N = + modTensorLegM A M N ≫ modTensorπ A M N from rfl, + modTensor_condition, modTensorLegN] + simp only [Category.assoc, Iso.inv_hom_id_assoc] + rw [← MonoidalCategory.whiskerLeft_comp_assoc] + rfl + +/-- Companion form of `modTensorπ_actRight`: the right action on +the second factor descends to the braided right action on the +tensor product of modules. -/ +@[reassoc] +theorem whiskerLeft_actRight_modTensorπ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) : + (M.X ◁ actRight A N.X) ≫ modTensorπ A M N = + (α_ M.X N.X A).inv ≫ (modTensorπ A M N ▷ A) ≫ + (β_ (modTensor A M N) A).hom ≫ modTensorAct A M N := by + rw [modTensorπ_actRight, Iso.inv_hom_id_assoc] + +/-- The coequalizer condition of the right-nested tensor product, +stated over the underlying objects. -/ +theorem modTensor_condition_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + (actRight A M.X ▷ modTensor A N P) ≫ + modTensorπ A M (modTensorMod A N P) = + (α_ M.X A (modTensor A N P)).hom ≫ + (M.X ◁ modTensorAct A N P) ≫ + modTensorπ A M (modTensorMod A N P) := by + have h := modTensor_condition A M (modTensorMod A N P) + rw [modTensorLegM, modTensorLegN, Category.assoc] at h + exact h + +/-- The coequalizer condition of the left-nested tensor product, +stated over the underlying objects. -/ +theorem modTensor_condition_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + (((β_ (modTensor A M N) A).hom ≫ modTensorAct A M N) ▷ P.X) ≫ + modTensorπ A (modTensorMod A M N) P = + (α_ (modTensor A M N) A P.X).hom ≫ + (modTensor A M N ◁ actLeft A P.X) ≫ + modTensorπ A (modTensorMod A M N) P := by + have h := modTensor_condition A (modTensorMod A M N) P + rw [modTensorLegM, modTensorLegN, Category.assoc] at h + exact h + +/-- The cover of the associator: reassociate and project through +both tensor products of the right-nested side. -/ +noncomputable def modTensorAssocCover + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + (M.X ⊗ N.X) ⊗ P.X ⟶ modTensor A M (modTensorMod A N P) := + (α_ M.X N.X P.X).hom ≫ (M.X ◁ modTensorπ A N P) ≫ + modTensorπ A M (modTensorMod A N P) + +/-- The cover of the associator coequalizes the whiskered inner +balance relation: the monoid sliding between `M` and `N` slides +onto `N` through the conditions of the target. -/ +theorem modTensorAssocCover_cond + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + (modTensorLegM A M N ▷ P.X) ≫ modTensorAssocCover A M N P = + (modTensorLegN A M N ▷ P.X) ≫ modTensorAssocCover A M N P := by + rw [modTensorLegM, modTensorLegN, modTensorAssocCover] + conv_lhs => erw [associator_naturality_left_assoc, + ← whisker_exchange_assoc, modTensor_condition_right, + associator_naturality_right_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + whiskerLeft_modTensorπ_act] + conv_rhs => rw [MonoidalCategory.comp_whiskerRight, + Category.assoc, associator_naturality_middle_assoc] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + repeat' erw [Category.assoc] + erw [pentagon_hom_hom_inv_hom_hom_assoc] + +/-- The half-descended associator, on the cover of the outer +coequalizer of the left-nested side. -/ +noncomputable def modTensorAssocMid + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + modTensor A M N ⊗ P.X ⟶ modTensor A M (modTensorMod A N P) := + modTensorWhiskerRDesc A M N P.X (modTensorAssocCover A M N P) + (modTensorAssocCover_cond A M N P) + +/-- Defining equation of the half-descended associator. -/ +@[reassoc (attr := simp)] +theorem whiskerRight_modTensorπ_assocMid + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + (modTensorπ A M N ▷ P.X) ≫ modTensorAssocMid A M N P = + modTensorAssocCover A M N P := + whiskerRight_modTensorπ_whiskerRDesc A M N P.X _ _ + +/-- The half-descended associator coequalizes the outer balance +relation: the monoid sliding between the `(M, N)`-block and `P` +slides between `N` and `P` through the inner condition of the +target. -/ +theorem modTensorAssocMid_cond + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + modTensorLegM A (modTensorMod A M N) P ≫ + modTensorAssocMid A M N P = + modTensorLegN A (modTensorMod A M N) P ≫ + modTensorAssocMid A M N P := by + have hNP : (actRight A N.X ▷ P.X) ≫ modTensorπ A N P = + (α_ N.X A P.X).hom ≫ (N.X ◁ actLeft A P.X) ≫ + modTensorπ A N P := by + have h := modTensor_condition A N P + rw [modTensorLegM, modTensorLegN, Category.assoc] at h + exact h + refine (cancel_epi ((modTensorπ A M N ▷ A) ▷ P.X)).mp ?_ + change ((modTensorπ A M N ▷ A) ▷ P.X) ≫ + (((β_ (modTensor A M N) A).hom ≫ modTensorAct A M N) + ▷ P.X) ≫ + modTensorAssocMid A M N P = + ((modTensorπ A M N ▷ A) ▷ P.X) ≫ + ((α_ (modTensor A M N) A P.X).hom ≫ + (modTensor A M N ◁ actLeft A P.X)) ≫ + modTensorAssocMid A M N P + conv_lhs => rw [← MonoidalCategory.comp_whiskerRight_assoc, + modTensorπ_actRight] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + conv_lhs => erw [whiskerRight_modTensorπ_assocMid, + modTensorAssocCover, associator_naturality_middle_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, hNP] + conv_rhs => rw [associator_naturality_left_assoc, + ← whisker_exchange_assoc, whiskerRight_modTensorπ_assocMid, + modTensorAssocCover, associator_naturality_right_assoc] + simp only [MonoidalCategory.whiskerLeft_comp] + repeat' erw [Category.assoc] + erw [pentagon_assoc] + +/-- **The associator of the tensor product of modules**: the +descent of the ambient associator to the relative tensors. -/ +noncomputable def modTensorAssocHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + modTensor A (modTensorMod A M N) P ⟶ + modTensor A M (modTensorMod A N P) := + modTensorDesc A (modTensorMod A M N) P + (modTensorAssocMid A M N P) (modTensorAssocMid_cond A M N P) + +/-- Defining equation of the associator. -/ +@[reassoc (attr := simp)] +theorem modTensorπ_assocHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + modTensorπ A (modTensorMod A M N) P ≫ + modTensorAssocHom A M N P = + modTensorAssocMid A M N P := + modTensorπ_desc A _ _ _ _ + +/-- The cover of the inverse associator: reassociate backwards and +project through both tensor products of the left-nested side. -/ +noncomputable def modTensorAssocInvCover + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + M.X ⊗ (N.X ⊗ P.X) ⟶ modTensor A (modTensorMod A M N) P := + (α_ M.X N.X P.X).inv ≫ (modTensorπ A M N ▷ P.X) ≫ + modTensorπ A (modTensorMod A M N) P + +/-- The inverse cover coequalizes the whiskered inner balance +relation: the monoid sliding between `N` and `P` slides onto the +`(M, N)`-block through the conditions of the target. -/ +theorem modTensorAssocInvCover_cond + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + (M.X ◁ modTensorLegM A N P) ≫ + modTensorAssocInvCover A M N P = + (M.X ◁ modTensorLegN A N P) ≫ + modTensorAssocInvCover A M N P := by + rw [modTensorLegM, modTensorLegN, modTensorAssocInvCover] + conv_lhs => erw [associator_inv_naturality_middle_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, + whiskerLeft_actRight_modTensorπ, + MonoidalCategory.comp_whiskerRight, + MonoidalCategory.comp_whiskerRight] + repeat' erw [Category.assoc] + conv_lhs => erw [modTensor_condition_left, + associator_naturality_left_assoc, ← whisker_exchange_assoc] + conv_rhs => rw [MonoidalCategory.whiskerLeft_comp, + Category.assoc, associator_inv_naturality_right_assoc] + rw [pentagon_inv_inv_hom_hom_inv_assoc] + +/-- The half-descended inverse associator, on the cover of the +outer coequalizer of the right-nested side. -/ +noncomputable def modTensorAssocInvMid + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + M.X ⊗ modTensor A N P ⟶ modTensor A (modTensorMod A M N) P := + modTensorWhiskerDesc A N P M.X (modTensorAssocInvCover A M N P) + (modTensorAssocInvCover_cond A M N P) + +/-- Defining equation of the half-descended inverse associator. -/ +@[reassoc (attr := simp)] +theorem whiskerLeft_modTensorπ_assocInvMid + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + (M.X ◁ modTensorπ A N P) ≫ modTensorAssocInvMid A M N P = + modTensorAssocInvCover A M N P := + whiskerLeft_modTensorπ_whiskerDesc A N P M.X _ _ + +/-- The half-descended inverse associator coequalizes the outer +balance relation: the monoid sliding between `M` and the +`(N, P)`-block slides between `M` and `N` through the inner +condition of the target. -/ +theorem modTensorAssocInvMid_cond + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + modTensorLegM A M (modTensorMod A N P) ≫ + modTensorAssocInvMid A M N P = + modTensorLegN A M (modTensorMod A N P) ≫ + modTensorAssocInvMid A M N P := by + have hMN : (actRight A M.X ▷ N.X) ≫ modTensorπ A M N = + (α_ M.X A N.X).hom ≫ (M.X ◁ actLeft A N.X) ≫ + modTensorπ A M N := by + have h := modTensor_condition A M N + rw [modTensorLegM, modTensorLegN, Category.assoc] at h + exact h + apply modTensor_whisker_hom_ext A N P (M.X ⊗ A) + change ((M.X ⊗ A) ◁ modTensorπ A N P) ≫ + (actRight A M.X ▷ modTensor A N P) ≫ + modTensorAssocInvMid A M N P = + ((M.X ⊗ A) ◁ modTensorπ A N P) ≫ + ((α_ M.X A (modTensor A N P)).hom ≫ + (M.X ◁ modTensorAct A N P)) ≫ + modTensorAssocInvMid A M N P + conv_lhs => erw [whisker_exchange_assoc, + whiskerLeft_modTensorπ_assocInvMid, modTensorAssocInvCover, + associator_inv_naturality_left_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, hMN] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + conv_rhs => rw [associator_naturality_right_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + whiskerLeft_modTensorπ_act] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + conv_rhs => rw [whiskerLeft_modTensorπ_assocInvMid, + modTensorAssocInvCover, + associator_inv_naturality_middle_assoc] + repeat' erw [Category.assoc] + erw [← pentagon_hom_inv_inv_inv_hom_assoc] + +/-- **The inverse associator of the tensor product of modules.** -/ +noncomputable def modTensorAssocInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + modTensor A M (modTensorMod A N P) ⟶ + modTensor A (modTensorMod A M N) P := + modTensorDesc A M (modTensorMod A N P) + (modTensorAssocInvMid A M N P) + (modTensorAssocInvMid_cond A M N P) + +/-- Defining equation of the inverse associator. -/ +@[reassoc (attr := simp)] +theorem modTensorπ_assocInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + modTensorπ A M (modTensorMod A N P) ≫ + modTensorAssocInv A M N P = + modTensorAssocInvMid A M N P := + modTensorπ_desc A _ _ _ _ + +/-- The associator retracts the inverse associator. -/ +@[reassoc (attr := simp)] +theorem modTensorAssocHom_assocInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + modTensorAssocHom A M N P ≫ modTensorAssocInv A M N P = + 𝟙 (modTensor A (modTensorMod A M N) P) := by + apply modTensor_hom_ext A (modTensorMod A M N) P + rw [modTensorπ_assocHom_assoc, Category.comp_id] + apply modTensor_whiskerR_hom_ext A M N P.X + change (modTensorπ A M N ▷ P.X) ≫ modTensorAssocMid A M N P ≫ + modTensorAssocInv A M N P = + (modTensorπ A M N ▷ P.X) ≫ + modTensorπ A (modTensorMod A M N) P + erw [whiskerRight_modTensorπ_assocMid_assoc, modTensorAssocCover] + simp only [Category.assoc] + conv_lhs => erw [Category.assoc] + erw [modTensorπ_assocInv] + erw [whiskerLeft_modTensorπ_assocInvMid, + modTensorAssocInvCover, Iso.hom_inv_id_assoc] + +/-- The inverse associator retracts the associator. -/ +@[reassoc (attr := simp)] +theorem modTensorAssocInv_assocHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + modTensorAssocInv A M N P ≫ modTensorAssocHom A M N P = + 𝟙 (modTensor A M (modTensorMod A N P)) := by + apply modTensor_hom_ext A M (modTensorMod A N P) + rw [modTensorπ_assocInv_assoc, Category.comp_id] + apply modTensor_whisker_hom_ext A N P M.X + change (M.X ◁ modTensorπ A N P) ≫ modTensorAssocInvMid A M N P ≫ + modTensorAssocHom A M N P = + (M.X ◁ modTensorπ A N P) ≫ + modTensorπ A M (modTensorMod A N P) + erw [whiskerLeft_modTensorπ_assocInvMid_assoc, + modTensorAssocInvCover] + simp only [Category.assoc] + conv_lhs => erw [Category.assoc] + erw [modTensorπ_assocHom] + erw [whiskerRight_modTensorπ_assocMid, + modTensorAssocCover, Iso.inv_hom_id_assoc] + +/-- **The associator isomorphism of the tensor product of +modules** (Deligne 2002, §2.3): the relative tensor is associative +up to the descended ambient associator. -/ +noncomputable def modTensorAssocIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + modTensor A (modTensorMod A M N) P ≅ + modTensor A M (modTensorMod A N P) where + hom := modTensorAssocHom A M N P + inv := modTensorAssocInv A M N P + hom_inv_id := modTensorAssocHom_assocInv A M N P + inv_hom_id := modTensorAssocInv_assocHom A M N P + +/-- **The associator is a morphism of modules**: it intertwines +the descended actions of the two nestings. -/ +@[reassoc] +theorem modTensorAssocHom_act + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + modTensorAct A (modTensorMod A M N) P ≫ + modTensorAssocHom A M N P = + (A ◁ modTensorAssocHom A M N P) ≫ + modTensorAct A M (modTensorMod A N P) := by + have hactL : (A ◁ modTensorπ A (modTensorMod A M N) P) ≫ + modTensorAct A (modTensorMod A M N) P ≫ + modTensorAssocHom A M N P = + (α_ A (modTensor A M N) P.X).inv ≫ + (modTensorAct A M N ▷ P.X) ≫ + modTensorAssocMid A M N P := by + rw [← Category.assoc, whiskerLeft_modTensorπ_act, + Category.assoc, modTensorπ_assocHom] + exact Category.assoc _ _ _ + have hwhk : (A ◁ modTensorπ A (modTensorMod A M N) P) ≫ + (A ◁ modTensorAssocHom A M N P) ≫ + modTensorAct A M (modTensorMod A N P) = + (A ◁ modTensorAssocMid A M N P) ≫ + modTensorAct A M (modTensorMod A N P) := by + rw [← MonoidalCategory.whiskerLeft_comp_assoc, + modTensorπ_assocHom] + rfl + have hcov : (A ◁ modTensorAssocCover A M N P) ≫ + modTensorAct A M (modTensorMod A N P) = + (A ◁ (α_ M.X N.X P.X).hom) ≫ + (A ◁ (M.X ◁ modTensorπ A N P)) ≫ + (α_ A M.X (modTensor A N P)).inv ≫ + ((actLeft A M.X ▷ modTensor A N P) ≫ + modTensorπ A M (modTensorMod A N P)) := by + erw [modTensorAssocCover] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + conv_lhs => arg 2; erw [MonoidalCategory.whiskerLeft_comp, Category.assoc] + erw [whiskerLeft_modTensorπ_act] + exact congrArg (CategoryStruct.comp _) + (congrArg (CategoryStruct.comp _) (Category.assoc _ _ _)) + apply modTensor_whisker_hom_ext A (modTensorMod A M N) P A + conv_lhs => rw [hactL] + conv_rhs => rw [hwhk] + refine (cancel_epi (A ◁ (modTensorπ A M N ▷ P.X))).mp ?_ + conv_lhs => rw [associator_inv_naturality_middle_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, + whiskerLeft_modTensorπ_act] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + conv_lhs => erw [whiskerRight_modTensorπ_assocMid, + modTensorAssocCover, associator_naturality_left_assoc, + ← whisker_exchange_assoc] + conv_rhs => rw [← MonoidalCategory.whiskerLeft_comp_assoc, + whiskerRight_modTensorπ_assocMid, hcov, + associator_inv_naturality_right_assoc] + rw [pentagon_inv_inv_hom_hom_inv_assoc] + +/-- The inverse associator intertwines the actions. -/ +@[reassoc] +theorem modTensorAssocInv_act + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + modTensorAct A M (modTensorMod A N P) ≫ + modTensorAssocInv A M N P = + (A ◁ modTensorAssocInv A M N P) ≫ + modTensorAct A (modTensorMod A M N) P := by + have : IsIso (modTensorAssocHom A M N P) := + ⟨modTensorAssocInv A M N P, + modTensorAssocHom_assocInv A M N P, + modTensorAssocInv_assocHom A M N P⟩ + rw [← cancel_mono (modTensorAssocHom A M N P), Category.assoc, + Category.assoc, modTensorAssocInv_assocHom, Category.comp_id, + modTensorAssocHom_act, ← Category.assoc, + ← MonoidalCategory.whiskerLeft_comp, + modTensorAssocInv_assocHom, MonoidalCategory.whiskerLeft_id, + Category.id_comp] + +/-- The associator as a morphism of bundled modules. -/ +noncomputable def modTensorAssocModHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + modTensorMod A (modTensorMod A M N) P ⟶ + modTensorMod A M (modTensorMod A N P) := + Mod.Hom.mk' (modTensorAssocHom A M N P) + (modTensorAssocHom_act A M N P) + +/-- The inverse associator as a morphism of bundled modules. -/ +noncomputable def modTensorAssocModInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + modTensorMod A M (modTensorMod A N P) ⟶ + modTensorMod A (modTensorMod A M N) P := + Mod.Hom.mk' (modTensorAssocInv A M N P) + (modTensorAssocInv_act A M N P) + +/-- **The associator of the tensor product of modules, as an +isomorphism of bundled modules.** -/ +noncomputable def modTensorAssocModIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + modTensorMod A (modTensorMod A M N) P ≅ + modTensorMod A M (modTensorMod A N P) where + hom := modTensorAssocModHom A M N P + inv := modTensorAssocModInv A M N P + hom_inv_id := Mod.hom_ext _ _ + (modTensorAssocHom_assocInv A M N P) + inv_hom_id := Mod.hom_ext _ _ + (modTensorAssocInv_assocHom A M N P) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModBiprod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModBiprod.lean new file mode 100644 index 0000000000..557047508d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModBiprod.lean @@ -0,0 +1,452 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor + +/-! +# Biproducts of internal modules + +The biproduct of two modules over a monoid object carries the +componentwise action: the tensor distributes over the biproduct +in a monoidally preadditive category, and the two actions act in +each summand. The injections and projections are module maps, +and morphisms out of the biproduct module are determined by the +two components. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- The componentwise action on the biproduct of the carriers. -/ +noncomputable def modBiprodAct + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) : + A ⊗ (M.X ⊞ N.X) ⟶ M.X ⊞ N.X := + biprod.lift ((A ◁ biprod.fst) ≫ actLeft A M.X) + ((A ◁ biprod.snd) ≫ actLeft A N.X) + +/-- The unit law of the componentwise action. -/ +theorem modBiprodAct_one [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) : + (η[A] ▷ (M.X ⊞ N.X)) ≫ modBiprodAct A M N = + (λ_ (M.X ⊞ N.X)).hom := by + apply biprod.hom_ext + · rw [Category.assoc, modBiprodAct, biprod.lift_fst, + ← Category.assoc, ← whisker_exchange, Category.assoc, + one_actLeft, leftUnitor_naturality] + · rw [Category.assoc, modBiprodAct, biprod.lift_snd, + ← Category.assoc, ← whisker_exchange, Category.assoc, + one_actLeft, leftUnitor_naturality] + +/-- The multiplication law of the componentwise action. -/ +theorem modBiprodAct_mul [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) : + (μ[A] ▷ (M.X ⊞ N.X)) ≫ modBiprodAct A M N = + (α_ A A (M.X ⊞ N.X)).hom ≫ + (A ◁ modBiprodAct A M N) ≫ modBiprodAct A M N := by + apply biprod.hom_ext + · rw [Category.assoc, modBiprodAct, biprod.lift_fst, + Category.assoc, Category.assoc, biprod.lift_fst, + ← MonoidalCategory.whiskerLeft_comp_assoc, + biprod.lift_fst] + rw [← Category.assoc, ← whisker_exchange, + Category.assoc, mul_actLeft] + rw [MonoidalCategory.whiskerLeft_comp, Category.assoc, + associator_naturality_right_assoc] + · rw [Category.assoc, modBiprodAct, biprod.lift_snd, + Category.assoc, Category.assoc, biprod.lift_snd, + ← MonoidalCategory.whiskerLeft_comp_assoc, + biprod.lift_snd] + rw [← Category.assoc, ← whisker_exchange, + Category.assoc, mul_actLeft] + rw [MonoidalCategory.whiskerLeft_comp, Category.assoc, + associator_naturality_right_assoc] + +/-- The module structure on the biproduct of the carriers. -/ +@[implicit_reducible] +noncomputable def modBiprodModObj + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) : + ModObj A (M.X ⊞ N.X) where + smul := modBiprodAct A M N + one_smul := modBiprodAct_one A M N + mul_smul := modBiprodAct_mul A M N + +/-- **The biproduct of modules**, bundled. -/ +noncomputable def modBiprod + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) : + Mod D A := + letI := modBiprodModObj A M N + ⟨M.X ⊞ N.X⟩ + +@[simp] lemma modBiprod_X [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) : + (modBiprod A M N).X = (M.X ⊞ N.X) := rfl + +/-- The first injection intertwines the actions. -/ +theorem actLeft_modBiprodInl + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] (A : D) [MonObj A] + (M : Mod D A) (N : Mod D A) : + actLeft A M.X ≫ (biprod.inl : M.X ⟶ M.X ⊞ N.X) = + (A ◁ biprod.inl) ≫ modBiprodAct A M N := by + apply biprod.hom_ext + · rw [Category.assoc, Category.assoc, modBiprodAct, + biprod.lift_fst, biprod.inl_fst, Category.comp_id, + ← MonoidalCategory.whiskerLeft_comp_assoc, + biprod.inl_fst, MonoidalCategory.whiskerLeft_id, + Category.id_comp] + · rw [Category.assoc, Category.assoc, modBiprodAct, + biprod.lift_snd, biprod.inl_snd, Limits.comp_zero, + ← MonoidalCategory.whiskerLeft_comp_assoc, + biprod.inl_snd, MonoidalPreadditive.whiskerLeft_zero, + Limits.zero_comp] + +/-- The second injection intertwines the actions. -/ +theorem actLeft_modBiprodInr + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] (A : D) [MonObj A] + (M : Mod D A) (N : Mod D A) : + actLeft A N.X ≫ (biprod.inr : N.X ⟶ M.X ⊞ N.X) = + (A ◁ biprod.inr) ≫ modBiprodAct A M N := by + apply biprod.hom_ext + · rw [Category.assoc, Category.assoc, modBiprodAct, + biprod.lift_fst, biprod.inr_fst, Limits.comp_zero, + ← MonoidalCategory.whiskerLeft_comp_assoc, + biprod.inr_fst, MonoidalPreadditive.whiskerLeft_zero, + Limits.zero_comp] + · rw [Category.assoc, Category.assoc, modBiprodAct, + biprod.lift_snd, biprod.inr_snd, Category.comp_id, + ← MonoidalCategory.whiskerLeft_comp_assoc, + biprod.inr_snd, MonoidalCategory.whiskerLeft_id, + Category.id_comp] + +/-- The first projection intertwines the actions. -/ +theorem modBiprodAct_fst [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) : + modBiprodAct A M N ≫ biprod.fst = + (A ◁ (biprod.fst : M.X ⊞ N.X ⟶ M.X)) ≫ + actLeft A M.X := by + rw [modBiprodAct, biprod.lift_fst] + +/-- The second projection intertwines the actions. -/ +theorem modBiprodAct_snd [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) : + modBiprodAct A M N ≫ biprod.snd = + (A ◁ (biprod.snd : M.X ⊞ N.X ⟶ N.X)) ≫ + actLeft A N.X := by + rw [modBiprodAct, biprod.lift_snd] + +/-- The first injection is a module map. -/ +noncomputable def modBiprodInl + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] (A : D) [MonObj A] + (M : Mod D A) (N : Mod D A) : M ⟶ modBiprod A M N := + Mod.Hom.mk' (biprod.inl : M.X ⟶ M.X ⊞ N.X) + (by exact actLeft_modBiprodInl A M N) + +/-- The second injection is a module map. -/ +noncomputable def modBiprodInr + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] (A : D) [MonObj A] + (M : Mod D A) (N : Mod D A) : N ⟶ modBiprod A M N := + Mod.Hom.mk' (biprod.inr : N.X ⟶ M.X ⊞ N.X) + (by exact actLeft_modBiprodInr A M N) + +/-- The first projection is a module map. -/ +noncomputable def modBiprodFst + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) : + modBiprod A M N ⟶ M := + Mod.Hom.mk' (biprod.fst : M.X ⊞ N.X ⟶ M.X) + (by exact modBiprodAct_fst A M N) + +/-- The second projection is a module map. -/ +noncomputable def modBiprodSnd + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) : + modBiprod A M N ⟶ N := + Mod.Hom.mk' (biprod.snd : M.X ⊞ N.X ⟶ N.X) + (by exact modBiprodAct_snd A M N) + +@[simp] lemma modBiprodInl_hom + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] (A : D) [MonObj A] + (M : Mod D A) (N : Mod D A) : + (modBiprodInl A M N).hom = biprod.inl := rfl + +@[simp] lemma modBiprodInr_hom + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] (A : D) [MonObj A] + (M : Mod D A) (N : Mod D A) : + (modBiprodInr A M N).hom = biprod.inr := rfl + +section Map + +/-- Componentwise maps intertwine the biproduct actions. -/ +theorem modBiprodAct_map [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) + {M' : Mod D A} {N' : Mod D A} + (f : M ⟶ M') (g : N ⟶ N') : + modBiprodAct A M N ≫ biprod.map f.hom g.hom = + (A ◁ biprod.map f.hom g.hom) ≫ + modBiprodAct A M' N' := by + apply biprod.hom_ext + · rw [Category.assoc, biprod.map_fst, ← Category.assoc, + modBiprodAct_fst, Category.assoc, actLeft_natural, + Category.assoc, modBiprodAct, biprod.lift_fst, + ← MonoidalCategory.whiskerLeft_comp_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + biprod.map_fst] + · rw [Category.assoc, biprod.map_snd, ← Category.assoc, + modBiprodAct_snd, Category.assoc, actLeft_natural, + Category.assoc, modBiprodAct, biprod.lift_snd, + ← MonoidalCategory.whiskerLeft_comp_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + biprod.map_snd] + +/-- **Functoriality of the module biproduct.** -/ +noncomputable def modBiprodMap + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) + {M' : Mod D A} {N' : Mod D A} + (f : M ⟶ M') (g : N ⟶ N') : + modBiprod A M N ⟶ modBiprod A M' N' := + Mod.Hom.mk' (biprod.map f.hom g.hom) + (by exact modBiprodAct_map A M N f g) + +@[simp] lemma modBiprodMap_hom + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) + {M' : Mod D A} {N' : Mod D A} + (f : M ⟶ M') (g : N ⟶ N') : + (modBiprodMap A M N f g).hom = + biprod.map f.hom g.hom := rfl + +/-- The module biproduct of two isomorphisms. -/ +noncomputable def modBiprodMapIso + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) + {M' : Mod D A} {N' : Mod D A} + (e₁ : M ≅ M') + (e₂ : N ≅ N') : + modBiprod A M N ≅ modBiprod A M' N' where + hom := modBiprodMap A M N e₁.hom e₂.hom + inv := modBiprodMap A M' N' e₁.inv e₂.inv + hom_inv_id := by + apply Mod.Hom.ext + change biprod.map e₁.hom.hom e₂.hom.hom ≫ + biprod.map e₁.inv.hom e₂.inv.hom = + 𝟙 (M.X ⊞ N.X) + have h₁ : e₁.hom.hom ≫ e₁.inv.hom = 𝟙 M.X := + congrArg Mod.Hom.hom e₁.hom_inv_id + have h₂ : e₂.hom.hom ≫ e₂.inv.hom = 𝟙 N.X := + congrArg Mod.Hom.hom e₂.hom_inv_id + apply biprod.hom_ext + · rw [Category.assoc, biprod.map_fst, ← Category.assoc, + biprod.map_fst, Category.assoc, h₁, + Category.comp_id, Category.id_comp] + · rw [Category.assoc, biprod.map_snd, ← Category.assoc, + biprod.map_snd, Category.assoc, h₂, + Category.comp_id, Category.id_comp] + inv_hom_id := by + apply Mod.Hom.ext + change biprod.map e₁.inv.hom e₂.inv.hom ≫ + biprod.map e₁.hom.hom e₂.hom.hom = + 𝟙 (M'.X ⊞ N'.X) + have h₁ : e₁.inv.hom ≫ e₁.hom.hom = 𝟙 M'.X := + congrArg Mod.Hom.hom e₁.inv_hom_id + have h₂ : e₂.inv.hom ≫ e₂.hom.hom = 𝟙 N'.X := + congrArg Mod.Hom.hom e₂.inv_hom_id + apply biprod.hom_ext + · rw [Category.assoc, biprod.map_fst, ← Category.assoc, + biprod.map_fst, Category.assoc, h₁, + Category.comp_id, Category.id_comp] + · rw [Category.assoc, biprod.map_snd, ← Category.assoc, + biprod.map_snd, Category.assoc, h₂, + Category.comp_id, Category.id_comp] + +end Map + +@[simp] lemma modBiprodFst_hom + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) : + (modBiprodFst A M N).hom = biprod.fst := rfl + +@[simp] lemma modBiprodSnd_hom + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) : + (modBiprodSnd A M N).hom = biprod.snd := rfl + +section Rearrange + +/-- The braiding of a module biproduct is linear. -/ +theorem modBiprodAct_braiding + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) : + modBiprodAct A M N ≫ (biprod.braiding M.X N.X).hom = + (A ◁ (biprod.braiding M.X N.X).hom) ≫ + modBiprodAct A N M := by + apply biprod.hom_ext + · rw [Category.assoc, biprod.braiding_hom, biprod.lift_fst, + modBiprodAct_snd, Category.assoc, modBiprodAct, + biprod.lift_fst, + ← MonoidalCategory.whiskerLeft_comp_assoc, + biprod.lift_fst] + · rw [Category.assoc, biprod.braiding_hom, biprod.lift_snd, + modBiprodAct_fst, Category.assoc, modBiprodAct, + biprod.lift_snd, + ← MonoidalCategory.whiskerLeft_comp_assoc, + biprod.lift_snd] + +/-- **The biproduct of modules is symmetric.** -/ +noncomputable def modBiprodSymmIso + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) : + modBiprod A M N ≅ modBiprod A N M where + hom := Mod.Hom.mk' (biprod.braiding M.X N.X).hom (by + exact modBiprodAct_braiding A M N) + inv := Mod.Hom.mk' (biprod.braiding N.X M.X).hom (by + exact modBiprodAct_braiding A N M) + hom_inv_id := by + apply Mod.Hom.ext + change (biprod.braiding M.X N.X).hom ≫ + (biprod.braiding N.X M.X).hom = 𝟙 (M.X ⊞ N.X) + exact (biprod.braiding M.X N.X).hom_inv_id + inv_hom_id := by + apply Mod.Hom.ext + change (biprod.braiding N.X M.X).hom ≫ + (biprod.braiding M.X N.X).hom = 𝟙 (N.X ⊞ M.X) + exact (biprod.braiding N.X M.X).hom_inv_id + +/-- The action on the left-nested triple biproduct, retyped. -/ +noncomputable def actLeftNest + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + A ⊗ ((M.X ⊞ N.X) ⊞ P.X) ⟶ (M.X ⊞ N.X) ⊞ P.X := + modBiprodAct A (modBiprod A M N) P + +/-- The action on the right-nested triple biproduct, retyped. -/ +noncomputable def actRightNest + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + A ⊗ (M.X ⊞ (N.X ⊞ P.X)) ⟶ M.X ⊞ (N.X ⊞ P.X) := + modBiprodAct A M (modBiprod A N P) + +/-- The associator of a module biproduct is linear. -/ +theorem modBiprodAct_associator + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + actLeftNest A M N P ≫ + (biprod.associator M.X N.X P.X).hom = + (A ◁ (biprod.associator M.X N.X P.X).hom) ≫ + actRightNest A M N P := by + have h1 : actLeftNest A M N P ≫ biprod.fst = + (A ◁ biprod.fst) ≫ modBiprodAct A M N := + modBiprodAct_fst A (modBiprod A M N) P + have h2 : actLeftNest A M N P ≫ biprod.snd = + (A ◁ biprod.snd) ≫ actLeft A P.X := + modBiprodAct_snd A (modBiprod A M N) P + have h3 : actRightNest A M N P ≫ biprod.fst = + (A ◁ biprod.fst) ≫ actLeft A M.X := + modBiprodAct_fst A M (modBiprod A N P) + have h4 : actRightNest A M N P ≫ biprod.snd = + (A ◁ biprod.snd) ≫ modBiprodAct A N P := + modBiprodAct_snd A M (modBiprod A N P) + have h4' : ∀ {Z : D} (g : (N.X ⊞ P.X) ⟶ Z), + actRightNest A M N P ≫ biprod.snd ≫ g = + (A ◁ biprod.snd) ≫ modBiprodAct A N P ≫ g := by + intro Z g + rw [← Category.assoc, h4, Category.assoc] + have h1' : ∀ {Z : D} (g : (M.X ⊞ N.X) ⟶ Z), + actLeftNest A M N P ≫ biprod.fst ≫ g = + (A ◁ biprod.fst) ≫ modBiprodAct A M N ≫ g := by + intro Z g + rw [← Category.assoc, h1, Category.assoc] + change actLeftNest A M N P ≫ + biprod.lift (biprod.fst ≫ biprod.fst) + (biprod.lift (biprod.fst ≫ biprod.snd) + biprod.snd) = + (A ◁ biprod.lift (biprod.fst ≫ biprod.fst) + (biprod.lift (biprod.fst ≫ biprod.snd) biprod.snd)) ≫ + actRightNest A M N P + apply biprod.hom_ext + · simp only [Category.assoc, biprod.lift_fst] + rw [h3, ← MonoidalCategory.whiskerLeft_comp_assoc, + biprod.lift_fst, + MonoidalCategory.whiskerLeft_comp_assoc] + rw [← Category.assoc, h1, Category.assoc, + modBiprodAct_fst] + · apply biprod.hom_ext + · simp only [Category.assoc, biprod.lift_fst, + biprod.lift_snd] + rw [h4' biprod.fst] + rw [← MonoidalCategory.whiskerLeft_comp_assoc, + biprod.lift_snd] + rw [modBiprodAct_fst] + rw [← MonoidalCategory.whiskerLeft_comp_assoc, + biprod.lift_fst, + MonoidalCategory.whiskerLeft_comp_assoc] + rw [h1' biprod.snd, modBiprodAct_snd] + · simp only [Category.assoc, biprod.lift_snd] + rw [h4' biprod.snd] + rw [← MonoidalCategory.whiskerLeft_comp_assoc, + biprod.lift_snd] + rw [modBiprodAct_snd] + rw [← MonoidalCategory.whiskerLeft_comp_assoc, + biprod.lift_snd] + exact h2 + +/-- **The biproduct of modules is associative.** -/ +noncomputable def modBiprodAssocIso + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) + (P : Mod D A) : + modBiprod A (modBiprod A M N) P ≅ + modBiprod A M (modBiprod A N P) where + hom := Mod.Hom.mk' (biprod.associator M.X N.X P.X).hom (by + exact modBiprodAct_associator A M N P) + inv := Mod.Hom.mk' (biprod.associator M.X N.X P.X).inv (by + change actRightNest A M N P ≫ + (biprod.associator M.X N.X P.X).inv = + (A ◁ (biprod.associator M.X N.X P.X).inv) ≫ + actLeftNest A M N P + refine (cancel_mono + (biprod.associator M.X N.X P.X).hom).mp ?_ + rw [Category.assoc, + (biprod.associator M.X N.X P.X).inv_hom_id, + Category.comp_id, Category.assoc] + refine Eq.symm ?_ + refine Eq.trans (whisker_eq _ + (modBiprodAct_associator A M N P)) ?_ + rw [← Category.assoc, + ← MonoidalCategory.whiskerLeft_comp, + (biprod.associator M.X N.X P.X).inv_hom_id, + MonoidalCategory.whiskerLeft_id, Category.id_comp]) + hom_inv_id := by + apply Mod.Hom.ext + exact (biprod.associator M.X N.X P.X).hom_inv_id + inv_hom_id := by + apply Mod.Hom.ext + exact (biprod.associator M.X N.X P.X).inv_hom_id + +end Rearrange + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModContractL.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModContractL.lean new file mode 100644 index 0000000000..2c59d03aa8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModContractL.lean @@ -0,0 +1,288 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModIns + +/-! +# Contraction of a leading dual pair on the multi-tensor + +The mirror image of the three-window contraction of `ModIns.lean`: +a linear pairing contracts the leading pair of the multi-tensor, +its scalar acting on the head of the remainder from the left, so no +braid is needed at the fold level. The zag composite inserts a +copairing's image on the right and contracts the leading pair. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- Case analysis for decompositions of the three-element list +`[M', M, N]`: a slot is the leading pair or the boundary. -/ +theorem prepend_pair_slot_cases + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + {pre post : List (Mod D A)} + {M M' N P Q : Mod D A} + (hd : [M', M, N] = pre ++ P :: Q :: post) : + (pre = [] ∧ P = M' ∧ Q = M ∧ post = [N]) ∨ + (pre = [M'] ∧ P = M ∧ Q = N ∧ post = []) := by + rcases pre with _ | ⟨R, pre⟩ + · injection hd with h1 h + injection h with h2 h3 + exact Or.inl ⟨rfl, h1.symm, h2.symm, h3.symm⟩ + · rcases pre with _ | ⟨S, pre⟩ + · injection hd with h1 h + injection h with h2 h + injection h with h3 h4 + exact Or.inr ⟨by rw [h1], h2.symm, h3.symm, h4.symm⟩ + · exact absurd (congrArg List.length hd) (by simp; omega) + +section Contract3L + +/-- The fold-level three-window contraction of a leading pair: pair +off the leading window, act on the head of the remainder with the +resulting scalar from the left. -/ +noncomputable def contract3LFold + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (N : Mod D A) : modList A [M', M, N] ⟶ modMulti A [N] := + (α_ M'.X M.X (N.X ⊗ 𝟙_ D)).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ (N.X ⊗ 𝟙_ D)) ≫ + modListHeadAct A N [] ≫ modMultiπ A [N] + +/-- The window morphism of the leading pair passes to the pairing +through the projection. -/ +theorem window_contract3LFold + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (N : Mod D A) (w : (M'.X ⊗ A) ⊗ M.X ⟶ M'.X ⊗ M.X) : + ((w ▷ modList A [N]) ≫ + (α_ M'.X M.X (modList A [N])).hom) ≫ + contract3LFold A p N = + ((w ≫ modTensorπ A M' M ≫ p) ▷ (N.X ⊗ 𝟙_ D)) ≫ + modListHeadAct A N [] ≫ modMultiπ A [N] := by + change ((w ▷ (N.X ⊗ 𝟙_ D)) ≫ (α_ M'.X M.X (N.X ⊗ 𝟙_ D)).hom) ≫ + (α_ M'.X M.X (N.X ⊗ 𝟙_ D)).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ (N.X ⊗ 𝟙_ D)) ≫ + modListHeadAct A N [] ≫ modMultiπ A [N] = _ + rw [Category.assoc, Iso.hom_inv_id_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc] + +/-- The pair-slot condition of the leading three-window +contraction: the two window legs of the leading pair agree after +the contraction. -/ +theorem contract3LFold_pair_cond + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (N : Mod D A) : + modMultiLegM A [] M' M [N] ≫ contract3LFold A p N = + modMultiLegN A [] M' M [N] ≫ contract3LFold A p N := by + change ((modTensorLegM A M' M ▷ modList A [N]) ≫ + (α_ M'.X M.X (modList A [N])).hom) ≫ + contract3LFold A p N = + ((modTensorLegN A M' M ▷ modList A [N]) ≫ + (α_ M'.X M.X (modList A [N])).hom) ≫ + contract3LFold A p N + rw [window_contract3LFold, window_contract3LFold] + have hcond2 : modTensorLegM A M' M ≫ + modTensorπ A M' M ≫ p = + modTensorLegN A M' M ≫ modTensorπ A M' M ≫ p := by + rw [← Category.assoc, modTensor_condition, Category.assoc] + exact congrArg (fun t => (t ▷ (N.X ⊗ 𝟙_ D)) ≫ + modListHeadAct A N [] ≫ modMultiπ A [N]) hcond2 + +/-- The boundary-slot condition of the leading three-window +contraction: the two window legs of the dual--head boundary agree +after the contraction, through the linearity of the pairing. -/ +theorem contract3LFold_boundary_cond + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) + (N : Mod D A) : + modMultiLegM A [M'] M N [] ≫ contract3LFold A p N = + modMultiLegN A [M'] M N [] ≫ contract3LFold A p N := by + change (M'.X ◁ (((actRight A M.X ▷ N.X) ▷ (𝟙_ D)) ≫ + (α_ M.X N.X (𝟙_ D)).hom)) ≫ + (α_ M'.X M.X (N.X ⊗ 𝟙_ D)).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ (N.X ⊗ 𝟙_ D)) ≫ + ((α_ A N.X (𝟙_ D)).inv ≫ (actLeft A N.X ▷ (𝟙_ D))) ≫ + modMultiπ A [N] = + (M'.X ◁ ((((α_ M.X A N.X).hom ≫ (M.X ◁ actLeft A N.X)) ▷ + (𝟙_ D)) ≫ (α_ M.X N.X (𝟙_ D)).hom)) ≫ + (α_ M'.X M.X (N.X ⊗ 𝟙_ D)).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ (N.X ⊗ 𝟙_ D)) ≫ + ((α_ A N.X (𝟙_ D)).inv ≫ (actLeft A N.X ▷ (𝟙_ D))) ≫ + modMultiπ A [N] + repeat' erw [Category.assoc] + have hrel : (M'.X ◁ actLeft A M.X) ≫ modTensorπ A M' M = + (α_ M'.X A M.X).inv ≫ (actRight A M'.X ▷ M.X) ≫ + modTensorπ A M' M := by + have h := (modTensor_condition A M' M).symm + rw [modTensorLegM, modTensorLegN, Category.assoc] at h + rw [← h, Iso.inv_hom_id_assoc] + have hact : (actLeft A M'.X ▷ M.X) ≫ modTensorπ A M' M = + (α_ A M'.X M.X).hom ≫ (A ◁ modTensorπ A M' M) ≫ + modTensorAct A M' M := by + rw [whiskerLeft_modTensorπ_act] + simp only [Category.assoc, Iso.hom_inv_id_assoc] + have hp' : modTensorAct A M' M ≫ p = (A ◁ p) ≫ μ[A] := hp + have hbraid : (M'.X ◁ (β_ M.X A).hom) ≫ + (α_ M'.X A M.X).inv ≫ ((β_ M'.X A).hom ▷ M.X) ≫ + (α_ A M'.X M.X).hom = + (α_ M'.X M.X A).inv ≫ (β_ (M'.X ⊗ M.X) A).hom := by + rw [BraidedCategory.braiding_tensor_left_hom, + Iso.inv_hom_id_assoc] + have hML : (M'.X ◁ actRight A M.X) ≫ modTensorπ A M' M ≫ p = + (α_ M'.X M.X A).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ A) ≫ μ[A] := by + change (M'.X ◁ ((β_ M.X A).hom ≫ actLeft A M.X)) ≫ + modTensorπ A M' M ≫ p = _ + rw [MonoidalCategory.whiskerLeft_comp, Category.assoc, + reassoc_of% hrel] + change (M'.X ◁ (β_ M.X A).hom) ≫ (α_ M'.X A M.X).inv ≫ + (((β_ M'.X A).hom ≫ actLeft A M'.X) ▷ M.X) ≫ + modTensorπ A M' M ≫ p = _ + rw [MonoidalCategory.comp_whiskerRight, Category.assoc, + reassoc_of% hact, + show modTensorAct A M' M ≫ p = (A ◁ p) ≫ μ[A] from hp', + ← MonoidalCategory.whiskerLeft_comp_assoc, + reassoc_of% hbraid, + ← BraidedCategory.braiding_naturality_left_assoc, + IsCommMonObj.mul_comm] + conv_lhs => rw [associator_naturality_left, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + associator_inv_naturality_middle_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, hML, + MonoidalCategory.comp_whiskerRight, + MonoidalCategory.comp_whiskerRight, Category.assoc, + Category.assoc, associator_inv_naturality_left_assoc, + associator_inv_naturality_left_assoc] + conv_rhs => erw [MonoidalCategory.comp_whiskerRight, + Category.assoc, associator_naturality_middle, + MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + Category.assoc, associator_inv_naturality_right_assoc, + whisker_exchange_assoc, + associator_inv_naturality_middle_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, + actLeft_actLeft, + MonoidalCategory.comp_whiskerRight, + MonoidalCategory.comp_whiskerRight, Category.assoc, + Category.assoc, associator_inv_naturality_left_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, + associator_inv_naturality_left, + MonoidalCategory.comp_whiskerRight, Category.assoc] + monoidal + +/-- **The multi-level contraction at a leading three-element +window**: a linear pairing contracts the leading pair of the +multi-tensor, the scalar acting on the remaining module. -/ +noncomputable def modMultiContract3L + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) + (N : Mod D A) : + modMulti A [M', M, N] ⟶ modMulti A [N] := + modMultiDesc A (contract3LFold A p N) + (by + intro pre P Q post hd + rcases prepend_pair_slot_cases A hd with + ⟨h1, h2, h3, h4⟩ | ⟨h1, h2, h3, h4⟩ + · subst h1 + replace h2 := h2.symm; subst h2 + replace h3 := h3.symm; subst h3 + subst h4 + have hid : (modListCast A hd.symm ≫ + contract3LFold A p N : + modList A ([] ++ M' :: M :: [N]) ⟶ + modMulti A [N]) = contract3LFold A p N := + Category.id_comp _ + exact ((congrArg (fun t => + modMultiLegM A [] M' M [N] ≫ t) hid).trans + (contract3LFold_pair_cond A p N)).trans + (congrArg (fun t => + modMultiLegN A [] M' M [N] ≫ t) hid.symm) + · subst h1 + replace h2 := h2.symm; subst h2 + replace h3 := h3.symm; subst h3 + subst h4 + have hid : (modListCast A hd.symm ≫ + contract3LFold A p N : + modList A ([M'] ++ M :: N :: []) ⟶ + modMulti A [N]) = contract3LFold A p N := + Category.id_comp _ + exact ((congrArg (fun t => + modMultiLegM A [M'] M N [] ≫ t) hid).trans + (contract3LFold_boundary_cond A p hp N)).trans + (congrArg (fun t => + modMultiLegN A [M'] M N [] ≫ t) hid.symm)) + +/-- Defining equation of the leading three-window contraction. -/ +@[reassoc (attr := simp)] +theorem modMultiπ_contract3L + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) + (N : Mod D A) : + modMultiπ A [M', M, N] ≫ modMultiContract3L A p hp N = + contract3LFold A p N := + modMultiπ_desc A _ _ + +end Contract3L + +section ZagCore + +/-- **The zag composite** of a copairing and a linear pairing: +insert the copairing on the right, concatenate, and contract the +leading pair. The zagzig law of a duality datum states that this +composite is the identity. -/ +noncomputable def zagComposite + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (c : A ⟶ modTensor A M M') + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) : + modMulti A [M'] ⟶ modMulti A [M'] := + (ρ_ (modMulti A [M'])).inv ≫ + (modMulti A [M'] ◁ copairImage A c) ≫ + modMultiConcat A [M'] [M, M'] ≫ + modMultiContract3L A p hp M' + +end ZagCore + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModCross.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModCross.lean new file mode 100644 index 0000000000..2223745665 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModCross.lean @@ -0,0 +1,922 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMulti + +/-! +# Crossing the monoid over a block of the multi-tensor + +The endgame of `ModMulti.lean`: the braided crossing of the monoid +`A` over a whole first block of modules factors through the slot +relations of the multi-tensor. From it, the concatenation map +descends through the binary `modTensor` of two bundled multi-tensor +modules, and the braiding of two adjacent factors descends to the +two-element multi-tensor. + +* `modCrossMid`, `modCrossLegOf`: the boundary-insertion carrier — + the monoid seated between two blocks, under a prefix — and its + assembly of a boundary window into a prefix-whiskered leg. +* `modCrossHeadWin`/`modCrossYWin`: the two boundary windows — the + monoid crosses the whole first block and acts on its head, or + acts on the head of the second block. +* `modCross_rel`: **the fold-level crossing relation** — the two + boundary legs agree after the projection, at every prefix; the + crossing is consumed one factor at a time, one slot relation per + factor. +* `modListCross`: the prefix-free crossing relation, in the typed + form consumed by the `modTensor` descent. +* `modTensorMulti`: the concatenation map descended through the + binary module tensor product of two bundled multi-tensors, with + its defining equation `modTensorπ_multi`. +* `modWinSwap`, `modMultiSwapPair`: the braiding of the two factors + of a two-element multi-tensor, by descent through the single slot + relation, with its defining equation `modMultiπ_swapPair`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## The boundary-insertion carrier + +The monoid seated at the boundary between two blocks, under a +prefix. The prefix enters by recursion, exactly as in +`modMultiMid`, so that slot-relation consumption below can match +prefixes on the nose. -/ + +section CrossDefs + +/-- The boundary-insertion object: the monoid between the folds of +two blocks, whiskered under a prefix. -/ +def modCrossMid [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (Xs Ys : List (Mod D A)) : + List (Mod D A) → D + | [] => (modList A Xs ⊗ A) ⊗ modList A Ys + | P :: rest => P.X ⊗ modCrossMid A Xs Ys rest + +@[simp] lemma modCrossMid_nil + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (Xs Ys : List (Mod D A)) : + modCrossMid A Xs Ys [] = (modList A Xs ⊗ A) ⊗ modList A Ys := + rfl + +@[simp] lemma modCrossMid_cons + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (Xs Ys : List (Mod D A)) + (P : Mod D A) (pre : List (Mod D A)) : + modCrossMid A Xs Ys (P :: pre) = + P.X ⊗ modCrossMid A Xs Ys pre := + rfl + +/-- Assemble a boundary window into a prefix-whiskered leg. -/ +def modCrossLegOf [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (Xs Ys : List (Mod D A)) + (w : (modList A Xs ⊗ A) ⊗ modList A Ys ⟶ modList A (Xs ++ Ys)) : + (pre : List (Mod D A)) → + modCrossMid A Xs Ys pre ⟶ modList A (pre ++ (Xs ++ Ys)) + | [] => w + | P :: rest => P.X ◁ modCrossLegOf A Xs Ys w rest + +@[simp] lemma modCrossLegOf_nil + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (Xs Ys : List (Mod D A)) + (w : (modList A Xs ⊗ A) ⊗ modList A Ys ⟶ modList A (Xs ++ Ys)) : + modCrossLegOf A Xs Ys w [] = w := + rfl + +@[simp] lemma modCrossLegOf_cons + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (Xs Ys : List (Mod D A)) + (w : (modList A Xs ⊗ A) ⊗ modList A Ys ⟶ modList A (Xs ++ Ys)) + (P : Mod D A) (pre : List (Mod D A)) : + modCrossLegOf A Xs Ys w (P :: pre) = + P.X ◁ modCrossLegOf A Xs Ys w pre := + rfl + +end CrossDefs + +/-! ## The two boundary windows -/ + +section CrossWindows + +/-- The crossing window: the monoid braids over the whole first +block and acts on its head. -/ +def modCrossHeadWin [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] + (X : Mod D A) (l Ys : List (Mod D A)) : + (modList A (X :: l) ⊗ A) ⊗ modList A Ys ⟶ + modList A ((X :: l) ++ Ys) := + (((β_ (modList A (X :: l)) A).hom ≫ modListHeadAct A X l) ▷ + modList A Ys) ≫ + (modListConcat A (X :: l) Ys).hom + +/-- The stationary window: the monoid acts on the head of the +second block. -/ +def modCrossYWin [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (Xs : List (Mod D A)) (Y : Mod D A) + (m : List (Mod D A)) : + (modList A Xs ⊗ A) ⊗ modList A (Y :: m) ⟶ + modList A (Xs ++ (Y :: m)) := + (α_ (modList A Xs) A (modList A (Y :: m))).hom ≫ + (modList A Xs ◁ modListHeadAct A Y m) ≫ + (modListConcat A Xs (Y :: m)).hom + +end CrossWindows + +/-! ## The singleton first block + +For a one-module first block the two boundary windows are the two +relation legs of the head slot, up to the unit seed of the fold. +The bridge below absorbs the seed and retypes the boundary carrier +at the relation object of the slot. -/ + +section CrossBase + +/-- The base bridge: absorb the unit seed of a singleton first +block and reassociate onto the relation window of the head slot. -/ +def modCrossBridge [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X Y : Mod D A) (m : List (Mod D A)) : + (pre : List (Mod D A)) → + modCrossMid A [X] (Y :: m) pre ⟶ modMultiMid A pre X Y m + | [] => (((ρ_ X.X).hom ▷ A) ▷ modList A (Y :: m)) ≫ + (α_ (X.X ⊗ A) Y.X (modList A m)).inv + | P :: rest => P.X ◁ modCrossBridge A X Y m rest + +/-- **The crossing window of a singleton block is the first +relation leg** of the head slot, through the bridge. -/ +lemma modCrossBridge_legM + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] + (X Y : Mod D A) (m : List (Mod D A)) : + ∀ pre : List (Mod D A), + modCrossLegOf A [X] (Y :: m) + (modCrossHeadWin A X [] (Y :: m)) pre = + modCrossBridge A X Y m pre ≫ modMultiLegM A pre X Y m + | [] => by + change (((β_ (X.X ⊗ 𝟙_ D) A).hom ≫ + ((α_ A X.X (𝟙_ D)).inv ≫ + (actLeft A X.X ▷ 𝟙_ D))) ▷ (Y.X ⊗ modList A m)) ≫ + ((α_ X.X (𝟙_ D) (Y.X ⊗ modList A m)).hom ≫ + (X.X ◁ (λ_ (Y.X ⊗ modList A m)).hom)) = + ((((ρ_ X.X).hom ▷ A) ▷ (Y.X ⊗ modList A m)) ≫ + (α_ (X.X ⊗ A) Y.X (modList A m)).inv) ≫ + ((((β_ X.X A).hom ≫ actLeft A X.X) ▷ Y.X) ▷ modList A m ≫ + (α_ X.X Y.X (modList A m)).hom) + have hcoh : ((α_ A X.X (𝟙_ D)).inv ▷ (Y.X ⊗ modList A m)) ≫ + (α_ (A ⊗ X.X) (𝟙_ D) (Y.X ⊗ modList A m)).hom ≫ + ((A ⊗ X.X) ◁ (λ_ (Y.X ⊗ modList A m)).hom) = + (A ◁ (ρ_ X.X).hom) ▷ (Y.X ⊗ modList A m) := by monoidal + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + conv_lhs => rw [associator_naturality_left_assoc, + ← whisker_exchange] + conv_rhs => rw [associator_inv_naturality_left_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, + ← MonoidalCategory.comp_whiskerRight, + BraidedCategory.braiding_naturality_left] + conv_rhs => simp only [MonoidalCategory.comp_whiskerRight, + Category.assoc] + conv_rhs => rw [← associator_inv_naturality_left_assoc, + associator_naturality_left, + associator_naturality_left_assoc, Iso.inv_hom_id_assoc] + rw [reassoc_of% hcoh] + | P :: rest => by + change P.X ◁ modCrossLegOf A [X] (Y :: m) + (modCrossHeadWin A X [] (Y :: m)) rest = + (P.X ◁ modCrossBridge A X Y m rest) ≫ + (P.X ◁ modMultiLegM A rest X Y m) + rw [← MonoidalCategory.whiskerLeft_comp, + modCrossBridge_legM A X Y m rest] + +/-- **The stationary window of a singleton block is the second +relation leg** of the head slot, through the bridge. -/ +lemma modCrossBridge_legN + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X Y : Mod D A) (m : List (Mod D A)) : + ∀ pre : List (Mod D A), + modCrossLegOf A [X] (Y :: m) + (modCrossYWin A [X] Y m) pre = + modCrossBridge A X Y m pre ≫ modMultiLegN A pre X Y m + | [] => by + change (α_ (X.X ⊗ 𝟙_ D) A (Y.X ⊗ modList A m)).hom ≫ + ((X.X ⊗ 𝟙_ D) ◁ + ((α_ A Y.X (modList A m)).inv ≫ + (actLeft A Y.X ▷ modList A m))) ≫ + ((α_ X.X (𝟙_ D) (Y.X ⊗ modList A m)).hom ≫ + (X.X ◁ (λ_ (Y.X ⊗ modList A m)).hom)) = + ((((ρ_ X.X).hom ▷ A) ▷ (Y.X ⊗ modList A m)) ≫ + (α_ (X.X ⊗ A) Y.X (modList A m)).inv) ≫ + (((α_ X.X A Y.X).hom ≫ (X.X ◁ actLeft A Y.X)) ▷ + modList A m ≫ + (α_ X.X Y.X (modList A m)).hom) + have hcoh : (α_ (X.X ⊗ 𝟙_ D) A (Y.X ⊗ modList A m)).hom ≫ + (α_ X.X (𝟙_ D) (A ⊗ (Y.X ⊗ modList A m))).hom ≫ + (X.X ◁ (λ_ (A ⊗ (Y.X ⊗ modList A m))).hom) ≫ + (X.X ◁ (α_ A Y.X (modList A m)).inv) = + (((ρ_ X.X).hom ▷ A) ▷ (Y.X ⊗ modList A m)) ≫ + (α_ (X.X ⊗ A) Y.X (modList A m)).inv ≫ + ((α_ X.X A Y.X).hom ▷ modList A m) ≫ + (α_ X.X (A ⊗ Y.X) (modList A m)).hom := by monoidal + simp only [MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.comp_whiskerRight, Category.assoc] + conv_lhs => rw [associator_naturality_right_assoc, + associator_naturality_right_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + ← MonoidalCategory.whiskerLeft_comp, + ← MonoidalCategory.whiskerLeft_comp, + leftUnitor_naturality] + conv_rhs => rw [associator_naturality_middle] + simp only [MonoidalCategory.whiskerLeft_comp] + rw [reassoc_of% hcoh] + | P :: rest => by + change P.X ◁ modCrossLegOf A [X] (Y :: m) + (modCrossYWin A [X] Y m) rest = + (P.X ◁ modCrossBridge A X Y m rest) ≫ + (P.X ◁ modMultiLegN A rest X Y m) + rw [← MonoidalCategory.whiskerLeft_comp, + modCrossBridge_legN A X Y m rest] + +end CrossBase + +/-! ## The step of the crossing + +For a first block of two or more modules, the crossing decomposes +by the hexagon: the monoid braids over the tail of the block first, +reaching the relation window of the head slot; the slot relation +walks it past the head, and what remains is the crossing of the +tail block under a prefix extended by the head. -/ + +section CrossStep + +/-- Peel the head of the first block into the prefix. -/ +def modCrossPeel [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X : Mod D A) (Xs' Ys : List (Mod D A)) : + (pre : List (Mod D A)) → + modCrossMid A (X :: Xs') Ys pre ⟶ + modCrossMid A Xs' Ys (pre ++ [X]) + | [] => ((α_ X.X (modList A Xs') A).hom ▷ modList A Ys) ≫ + (α_ X.X (modList A Xs' ⊗ A) (modList A Ys)).hom + | P :: rest => P.X ◁ modCrossPeel A X Xs' Ys rest + +/-- **Peeling passes the stationary window**: the stationary window +of the extended block is the peel followed by the whiskered +stationary window of the tail block. -/ +lemma modCrossPeel_yWin [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X : Mod D A) (Xs' : List (Mod D A)) + (Y : Mod D A) (m : List (Mod D A)) : + ∀ (pre : List (Mod D A)) + (h : (pre ++ [X]) ++ (Xs' ++ (Y :: m)) = + pre ++ ((X :: Xs') ++ (Y :: m))), + modCrossPeel A X Xs' (Y :: m) pre ≫ + modCrossLegOf A Xs' (Y :: m) + (modCrossYWin A Xs' Y m) (pre ++ [X]) ≫ + modListCast A h = + modCrossLegOf A (X :: Xs') (Y :: m) + (modCrossYWin A (X :: Xs') Y m) pre + | [], h => by + simp only [List.nil_append, List.cons_append, modListCast_rfl, + Category.comp_id] + change (((α_ X.X (modList A Xs') A).hom ▷ modList A (Y :: m)) ≫ + (α_ X.X (modList A Xs' ⊗ A) (modList A (Y :: m))).hom) ≫ + (X.X ◁ ((α_ (modList A Xs') A (modList A (Y :: m))).hom ≫ + (modList A Xs' ◁ modListHeadAct A Y m) ≫ + (modListConcat A Xs' (Y :: m)).hom)) = + (α_ (X.X ⊗ modList A Xs') A (modList A (Y :: m))).hom ≫ + ((X.X ⊗ modList A Xs') ◁ modListHeadAct A Y m) ≫ + ((α_ X.X (modList A Xs') (modList A (Y :: m))).hom ≫ + (X.X ◁ (modListConcat A Xs' (Y :: m)).hom)) + have hcoh : ((α_ X.X (modList A Xs') A).hom ▷ + modList A (Y :: m)) ≫ + (α_ X.X (modList A Xs' ⊗ A) (modList A (Y :: m))).hom ≫ + (X.X ◁ (α_ (modList A Xs') A (modList A (Y :: m))).hom) = + (α_ (X.X ⊗ modList A Xs') A (modList A (Y :: m))).hom ≫ + (α_ X.X (modList A Xs') + (A ⊗ modList A (Y :: m))).hom := by monoidal + rw [Category.assoc] + simp only [MonoidalCategory.whiskerLeft_comp] + conv_rhs => rw [associator_naturality_right_assoc] + rw [reassoc_of% hcoh] + | P :: rest, h => by + change (P.X ◁ modCrossPeel A X Xs' (Y :: m) rest) ≫ + (P.X ◁ modCrossLegOf A Xs' (Y :: m) + (modCrossYWin A Xs' Y m) (rest ++ [X])) ≫ + modListCast A h = + P.X ◁ modCrossLegOf A (X :: Xs') (Y :: m) + (modCrossYWin A (X :: Xs') Y m) rest + rw [← modCrossPeel_yWin A X Xs' Y m rest (by simp)] + simp only [MonoidalCategory.whiskerLeft_comp] + rw [modListCast_whiskerLeft] + rfl + +/-- The step bridge: braid the monoid over the tail of the first +block and retype at the relation window of the head slot. -/ +def modCrossStepBridge [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] + (X P : Mod D A) (l' Ys : List (Mod D A)) : + (pre : List (Mod D A)) → + modCrossMid A (X :: P :: l') Ys pre ⟶ + modMultiMid A pre X P (l' ++ Ys) + | [] => + (((α_ X.X (P.X ⊗ modList A l') A).hom ≫ + (X.X ◁ (β_ (P.X ⊗ modList A l') A).hom) ≫ + (α_ X.X A (P.X ⊗ modList A l')).inv) ▷ modList A Ys) ≫ + (α_ (X.X ⊗ A) (P.X ⊗ modList A l') (modList A Ys)).hom ≫ + ((X.X ⊗ A) ◁ + (α_ P.X (modList A l') (modList A Ys)).hom) ≫ + ((X.X ⊗ A) ◁ (P.X ◁ (modListConcat A l' Ys).hom)) ≫ + (α_ (X.X ⊗ A) P.X (modList A (l' ++ Ys))).inv + | Q :: rest => Q.X ◁ modCrossStepBridge A X P l' Ys rest + +/-- **The crossing window decomposes over the head slot**: by the +hexagon, the full crossing is the step bridge followed by the first +relation leg of the head slot. -/ +lemma modCrossStepBridge_legM + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] + (X P : Mod D A) + (l' Ys : List (Mod D A)) : + ∀ pre : List (Mod D A), + modCrossLegOf A (X :: P :: l') Ys + (modCrossHeadWin A X (P :: l') Ys) pre = + modCrossStepBridge A X P l' Ys pre ≫ + modMultiLegM A pre X P (l' ++ Ys) + | [] => by + change (((β_ (X.X ⊗ (P.X ⊗ modList A l')) A).hom ≫ + ((α_ A X.X (P.X ⊗ modList A l')).inv ≫ + (actLeft A X.X ▷ (P.X ⊗ modList A l')))) ▷ + modList A Ys) ≫ + ((α_ X.X (P.X ⊗ modList A l') (modList A Ys)).hom ≫ + (X.X ◁ ((α_ P.X (modList A l') (modList A Ys)).hom ≫ + (P.X ◁ (modListConcat A l' Ys).hom)))) = + ((((α_ X.X (P.X ⊗ modList A l') A).hom ≫ + (X.X ◁ (β_ (P.X ⊗ modList A l') A).hom) ≫ + (α_ X.X A (P.X ⊗ modList A l')).inv) ▷ modList A Ys) ≫ + (α_ (X.X ⊗ A) (P.X ⊗ modList A l') (modList A Ys)).hom ≫ + ((X.X ⊗ A) ◁ + (α_ P.X (modList A l') (modList A Ys)).hom) ≫ + ((X.X ⊗ A) ◁ (P.X ◁ (modListConcat A l' Ys).hom)) ≫ + (α_ (X.X ⊗ A) P.X (modList A (l' ++ Ys))).inv) ≫ + ((((β_ X.X A).hom ≫ actLeft A X.X) ▷ P.X) ▷ + modList A (l' ++ Ys) ≫ + (α_ X.X P.X (modList A (l' ++ Ys))).hom) + rw [BraidedCategory.braiding_tensor_left_hom] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc, + MonoidalCategory.hom_inv_whiskerRight_assoc, + MonoidalCategory.whiskerLeft_comp] + conv_lhs => rw [associator_naturality_left_assoc, + associator_naturality_left_assoc] + conv_rhs => rw [associator_naturality_left, + associator_naturality_left_assoc, Iso.inv_hom_id_assoc, + whisker_exchange_assoc, whisker_exchange_assoc, + whisker_exchange, whisker_exchange_assoc] + | Q :: rest => by + change Q.X ◁ modCrossLegOf A (X :: P :: l') Ys + (modCrossHeadWin A X (P :: l') Ys) rest = + (Q.X ◁ modCrossStepBridge A X P l' Ys rest) ≫ + (Q.X ◁ modMultiLegM A rest X P (l' ++ Ys)) + rw [← MonoidalCategory.whiskerLeft_comp, + modCrossStepBridge_legM A X P l' Ys rest] + +/-- **The step bridge against the second relation leg**: past the +head slot, what remains is the crossing of the tail block, under +the prefix extended by the head. -/ +lemma modCrossStepBridge_legN + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] + (X P : Mod D A) + (l' Ys : List (Mod D A)) : + ∀ (pre : List (Mod D A)) + (h : (pre ++ [X]) ++ ((P :: l') ++ Ys) = + pre ++ ((X :: P :: l') ++ Ys)), + modCrossStepBridge A X P l' Ys pre ≫ + modMultiLegN A pre X P (l' ++ Ys) = + modCrossPeel A X (P :: l') Ys pre ≫ + modCrossLegOf A (P :: l') Ys + (modCrossHeadWin A P l' Ys) (pre ++ [X]) ≫ + modListCast A h + | [], h => by + simp only [List.nil_append, List.cons_append, modListCast_rfl, + Category.comp_id] + change ((((α_ X.X (P.X ⊗ modList A l') A).hom ≫ + (X.X ◁ (β_ (P.X ⊗ modList A l') A).hom) ≫ + (α_ X.X A (P.X ⊗ modList A l')).inv) ▷ modList A Ys) ≫ + (α_ (X.X ⊗ A) (P.X ⊗ modList A l') (modList A Ys)).hom ≫ + ((X.X ⊗ A) ◁ + (α_ P.X (modList A l') (modList A Ys)).hom) ≫ + ((X.X ⊗ A) ◁ (P.X ◁ (modListConcat A l' Ys).hom)) ≫ + (α_ (X.X ⊗ A) P.X (modList A (l' ++ Ys))).inv) ≫ + (((α_ X.X A P.X).hom ≫ (X.X ◁ actLeft A P.X)) ▷ + modList A (l' ++ Ys) ≫ + (α_ X.X P.X (modList A (l' ++ Ys))).hom) = + (((α_ X.X (P.X ⊗ modList A l') A).hom ▷ modList A Ys) ≫ + (α_ X.X ((P.X ⊗ modList A l') ⊗ A) + (modList A Ys)).hom) ≫ + (X.X ◁ ((((β_ (P.X ⊗ modList A l') A).hom ≫ + ((α_ A P.X (modList A l')).inv ≫ + (actLeft A P.X ▷ modList A l'))) ▷ modList A Ys) ≫ + ((α_ P.X (modList A l') (modList A Ys)).hom ≫ + (P.X ◁ (modListConcat A l' Ys).hom)))) + have hW : (((β_ (P.X ⊗ modList A l') A).hom ≫ + ((α_ A P.X (modList A l')).inv ≫ + (actLeft A P.X ▷ modList A l'))) ▷ modList A Ys) ≫ + ((α_ P.X (modList A l') (modList A Ys)).hom ≫ + (P.X ◁ (modListConcat A l' Ys).hom)) = + ((β_ (P.X ⊗ modList A l') A).hom ▷ modList A Ys) ≫ + ((α_ A P.X (modList A l')).inv ▷ modList A Ys) ≫ + (α_ (A ⊗ P.X) (modList A l') (modList A Ys)).hom ≫ + ((A ⊗ P.X) ◁ (modListConcat A l' Ys).hom) ≫ + (actLeft A P.X ▷ modList A (l' ++ Ys)) := by + simp only [MonoidalCategory.comp_whiskerRight, + Category.assoc] + rw [associator_naturality_left_assoc, ← whisker_exchange] + have hcoh : ((α_ X.X A (P.X ⊗ modList A l')).inv ▷ + modList A Ys) ≫ + (α_ (X.X ⊗ A) (P.X ⊗ modList A l') (modList A Ys)).hom ≫ + ((X.X ⊗ A) ◁ + (α_ P.X (modList A l') (modList A Ys)).hom) ≫ + (α_ (X.X ⊗ A) P.X + (modList A l' ⊗ modList A Ys)).inv ≫ + ((α_ X.X A P.X).hom ▷ + (modList A l' ⊗ modList A Ys)) ≫ + (α_ X.X (A ⊗ P.X) + (modList A l' ⊗ modList A Ys)).hom = + (α_ X.X (A ⊗ (P.X ⊗ modList A l')) (modList A Ys)).hom ≫ + (X.X ◁ ((α_ A P.X (modList A l')).inv ▷ modList A Ys)) ≫ + (X.X ◁ (α_ (A ⊗ P.X) (modList A l') + (modList A Ys)).hom) := by + monoidal + rw [hW] + simp only [MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.comp_whiskerRight, Category.assoc] + conv_lhs => rw [associator_naturality_middle, + associator_inv_naturality_right_assoc, + whisker_exchange_assoc, associator_naturality_right_assoc] + conv_rhs => rw [← associator_naturality_middle_assoc] + rw [reassoc_of% hcoh] + | Q :: rest, h => by + have h' : (rest ++ [X]) ++ ((P :: l') ++ Ys) = + rest ++ ((X :: P :: l') ++ Ys) := by simp + have hQC : Q.X ◁ modListCast A h' = modListCast A h := + modListCast_whiskerLeft A Q h' + change (Q.X ◁ modCrossStepBridge A X P l' Ys rest) ≫ + (Q.X ◁ modMultiLegN A rest X P (l' ++ Ys)) = + (Q.X ◁ modCrossPeel A X (P :: l') Ys rest) ≫ + (Q.X ◁ modCrossLegOf A (P :: l') Ys + (modCrossHeadWin A P l' Ys) (rest ++ [X])) ≫ + modListCast A h + have e1 := (MonoidalCategory.whiskerLeft_comp Q.X + (modCrossStepBridge A X P l' Ys rest) + (modMultiLegN A rest X P (l' ++ Ys))).symm + have e2 := congrArg (fun t => Q.X ◁ t) + (modCrossStepBridge_legN A X P l' Ys rest h') + have e3 := MonoidalCategory.whiskerLeft_comp Q.X + (modCrossPeel A X (P :: l') Ys rest) + (modCrossLegOf A (P :: l') Ys + (modCrossHeadWin A P l' Ys) (rest ++ [X]) ≫ + modListCast A h') + have e4 := congrArg + (fun t => (Q.X ◁ modCrossPeel A X (P :: l') Ys rest) ≫ t) + (MonoidalCategory.whiskerLeft_comp Q.X + (modCrossLegOf A (P :: l') Ys + (modCrossHeadWin A P l' Ys) (rest ++ [X])) + (modListCast A h')) + have e5 := congrArg (fun t => + (Q.X ◁ modCrossPeel A X (P :: l') Ys rest) ≫ + (Q.X ◁ modCrossLegOf A (P :: l') Ys + (modCrossHeadWin A P l' Ys) (rest ++ [X])) ≫ t) + hQC + exact (((e1.trans e2).trans e3).trans e4).trans e5 + +end CrossStep + +/-! ## The crossing relation -/ + +section CrossRel + +/-- **The fold-level crossing relation**: after the projection of +the multi-tensor, braiding the monoid over the whole first block +and acting on its head agrees with acting on the head of the second +block, at every ambient prefix. The crossing is consumed one +factor at a time, one slot relation per factor. -/ +theorem modCross_rel [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (Y : Mod D A) (m : List (Mod D A)) : + ∀ (l : List (Mod D A)) (X : Mod D A) + (pr Zs : List (Mod D A)) + (h : Zs = pr ++ ((X :: l) ++ (Y :: m))), + modCrossLegOf A (X :: l) (Y :: m) + (modCrossHeadWin A X l (Y :: m)) pr ≫ + modListCast A h.symm ≫ modMultiπ A Zs = + modCrossLegOf A (X :: l) (Y :: m) + (modCrossYWin A (X :: l) Y m) pr ≫ + modListCast A h.symm ≫ modMultiπ A Zs + | [], X, pr, Zs, h => by + have g1 := congrArg + (fun t => t ≫ (modListCast A h.symm ≫ modMultiπ A Zs)) + (modCrossBridge_legM A X Y m pr) + have g2 := Category.assoc (modCrossBridge A X Y m pr) + (modMultiLegM A pr X Y m) + (modListCast A h.symm ≫ modMultiπ A Zs) + have g3 := congrArg (fun t => modCrossBridge A X Y m pr ≫ t) + (modMulti_rel A pr X Y m h) + have g4 := (Category.assoc (modCrossBridge A X Y m pr) + (modMultiLegN A pr X Y m) + (modListCast A h.symm ≫ modMultiπ A Zs)).symm + have g5 := (congrArg + (fun t => t ≫ (modListCast A h.symm ≫ modMultiπ A Zs)) + (modCrossBridge_legN A X Y m pr)).symm + exact g1.trans (g2.trans (g3.trans (g4.trans g5))) + | P :: l', X, pr, Zs, h => by + have h2 : (pr ++ [X]) ++ ((P :: l') ++ (Y :: m)) = + pr ++ ((X :: P :: l') ++ (Y :: m)) := by simp + have h'' : Zs = (pr ++ [X]) ++ ((P :: l') ++ (Y :: m)) := + h.trans h2.symm + have b1 := congrArg + (fun t => t ≫ (modListCast A h.symm ≫ modMultiπ A Zs)) + (modCrossStepBridge_legM A X P l' (Y :: m) pr) + have b2 := Category.assoc + (modCrossStepBridge A X P l' (Y :: m) pr) + (modMultiLegM A pr X P (l' ++ (Y :: m))) + (modListCast A h.symm ≫ modMultiπ A Zs) + have b3 := congrArg + (fun t => modCrossStepBridge A X P l' (Y :: m) pr ≫ t) + (modMulti_rel A pr X P (l' ++ (Y :: m)) h) + have b4 := (Category.assoc + (modCrossStepBridge A X P l' (Y :: m) pr) + (modMultiLegN A pr X P (l' ++ (Y :: m))) + (modListCast A h.symm ≫ modMultiπ A Zs)).symm + have b5 := congrArg + (fun t => t ≫ (modListCast A h.symm ≫ modMultiπ A Zs)) + (modCrossStepBridge_legN A X P l' (Y :: m) pr h2) + have b6 := Category.assoc + (modCrossPeel A X (P :: l') (Y :: m) pr) + (modCrossLegOf A (P :: l') (Y :: m) + (modCrossHeadWin A P l' (Y :: m)) (pr ++ [X]) ≫ + modListCast A h2) + (modListCast A h.symm ≫ modMultiπ A Zs) + have b7 := congrArg + (fun t => modCrossPeel A X (P :: l') (Y :: m) pr ≫ t) + (Category.assoc + (modCrossLegOf A (P :: l') (Y :: m) + (modCrossHeadWin A P l' (Y :: m)) (pr ++ [X])) + (modListCast A h2) + (modListCast A h.symm ≫ modMultiπ A Zs)) + have b8 := congrArg + (fun t => modCrossPeel A X (P :: l') (Y :: m) pr ≫ + (modCrossLegOf A (P :: l') (Y :: m) + (modCrossHeadWin A P l' (Y :: m)) (pr ++ [X]) ≫ t)) + (modListCast_comp_assoc A h2 h.symm (modMultiπ A Zs)) + have b9 := congrArg + (fun t => modCrossPeel A X (P :: l') (Y :: m) pr ≫ t) + (modCross_rel A Y m l' P (pr ++ [X]) Zs h'') + have c1 := congrArg + (fun t => modCrossPeel A X (P :: l') (Y :: m) pr ≫ + (modCrossLegOf A (P :: l') (Y :: m) + (modCrossYWin A (P :: l') Y m) (pr ++ [X]) ≫ t)) + (modListCast_comp_assoc A h2 h.symm (modMultiπ A Zs)).symm + have c2 := (congrArg + (fun t => modCrossPeel A X (P :: l') (Y :: m) pr ≫ t) + (Category.assoc + (modCrossLegOf A (P :: l') (Y :: m) + (modCrossYWin A (P :: l') Y m) (pr ++ [X])) + (modListCast A h2) + (modListCast A h.symm ≫ modMultiπ A Zs))).symm + have c3 := (Category.assoc + (modCrossPeel A X (P :: l') (Y :: m) pr) + (modCrossLegOf A (P :: l') (Y :: m) + (modCrossYWin A (P :: l') Y m) (pr ++ [X]) ≫ + modListCast A h2) + (modListCast A h.symm ≫ modMultiπ A Zs)).symm + have c4 := congrArg + (fun t => t ≫ (modListCast A h.symm ≫ modMultiπ A Zs)) + (modCrossPeel_yWin A X (P :: l') Y m pr h2) + exact b1.trans (b2.trans (b3.trans (b4.trans (b5.trans + (b6.trans (b7.trans (b8.trans (b9.trans (c1.trans + (c2.trans (c3.trans c4))))))))))) + +/-- **The crossing relation, prefix-free**: braiding the monoid +over the first block and acting on its head agrees, after the +projection, with acting on the head of the second block. This is +the typed form consumed by the `modTensor` descent below. -/ +theorem modListCross [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (X Y : Mod D A) (l m : List (Mod D A)) : + (((β_ (modList A (X :: l)) A).hom ≫ modListHeadAct A X l) ▷ + modList A (Y :: m)) ≫ + (modListConcat A (X :: l) (Y :: m)).hom ≫ + modMultiπ A ((X :: l) ++ (Y :: m)) = + (α_ (modList A (X :: l)) A (modList A (Y :: m))).hom ≫ + (modList A (X :: l) ◁ modListHeadAct A Y m) ≫ + (modListConcat A (X :: l) (Y :: m)).hom ≫ + modMultiπ A ((X :: l) ++ (Y :: m)) := by + have h := modCross_rel A Y m l X [] ((X :: l) ++ (Y :: m)) rfl + simp only [modCrossLegOf_nil, List.nil_append, modListCast_rfl, + Category.id_comp] at h + have e0 := Category.assoc + (((β_ (modList A (X :: l)) A).hom ≫ modListHeadAct A X l) ▷ + modList A (Y :: m)) + (modListConcat A (X :: l) (Y :: m)).hom + (modMultiπ A ((X :: l) ++ (Y :: m))) + have e1 := Category.assoc + (α_ (modList A (X :: l)) A (modList A (Y :: m))).hom + ((modList A (X :: l) ◁ modListHeadAct A Y m) ≫ + (modListConcat A (X :: l) (Y :: m)).hom) + (modMultiπ A ((X :: l) ++ (Y :: m))) + have e2 := congrArg + (fun t => + (α_ (modList A (X :: l)) A (modList A (Y :: m))).hom ≫ t) + (Category.assoc + (modList A (X :: l) ◁ modListHeadAct A Y m) + (modListConcat A (X :: l) (Y :: m)).hom + (modMultiπ A ((X :: l) ++ (Y :: m)))) + exact e0.symm.trans (h.trans (e1.trans e2)) + +end CrossRel + +/-! ## Descent of the concatenation through the module tensor + +For a commutative monoid the two bundled multi-tensor modules have +a binary `modTensor`; the concatenation map coequalizes its two +legs — by the crossing relation — and so descends. -/ + +section TensorMulti + +/-- The concatenation coequalizes the binary module-tensor legs of +two bundled multi-tensors: the crossing relation, lifted through +the projections. -/ +lemma modTensorLeg_multi + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorRight Y)] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorLeft Y)] + (X Y : Mod D A) (l m : List (Mod D A)) : + modTensorLegM A (modMultiMod A X l) (modMultiMod A Y m) ≫ + modMultiConcat A (X :: l) (Y :: m) = + modTensorLegN A (modMultiMod A X l) (modMultiMod A Y m) ≫ + modMultiConcat A (X :: l) (Y :: m) := by + have hM : (modMultiπ A (X :: l) ▷ (A ⊗ modList A (Y :: m))) ≫ + (α_ (modMulti A (X :: l)) A (modList A (Y :: m))).inv ≫ + ((modMulti A (X :: l) ⊗ A) ◁ modMultiπ A (Y :: m)) ≫ + modTensorLegM A (modMultiMod A X l) (modMultiMod A Y m) ≫ + modMultiConcat A (X :: l) (Y :: m) = + (α_ (modList A (X :: l)) A (modList A (Y :: m))).inv ≫ + ((β_ (modList A (X :: l)) A).hom ▷ modList A (Y :: m)) ≫ + (modListHeadAct A X l ▷ modList A (Y :: m)) ≫ + (modListConcat A (X :: l) (Y :: m)).hom ≫ + modMultiπ A ((X :: l) ++ (Y :: m)) := by + change (modMultiπ A (X :: l) ▷ (A ⊗ modList A (Y :: m))) ≫ + (α_ (modMulti A (X :: l)) A (modList A (Y :: m))).inv ≫ + ((modMulti A (X :: l) ⊗ A) ◁ modMultiπ A (Y :: m)) ≫ + (((β_ (modMulti A (X :: l)) A).hom ≫ + modMultiHeadAct A X l) ▷ modMulti A (Y :: m)) ≫ + modMultiConcat A (X :: l) (Y :: m) = _ + rw [associator_inv_naturality_left_assoc, + ← whisker_exchange_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, + BraidedCategory.braiding_naturality_left_assoc, + whiskerLeft_modMultiπ_headAct, whisker_exchange_assoc, + whiskerLeft_modMultiπ_concat, + MonoidalCategory.comp_whiskerRight_assoc, + MonoidalCategory.comp_whiskerRight_assoc, + whiskerRight_modMultiπ_concatFst] + have hN : (modMultiπ A (X :: l) ▷ (A ⊗ modList A (Y :: m))) ≫ + (α_ (modMulti A (X :: l)) A (modList A (Y :: m))).inv ≫ + ((modMulti A (X :: l) ⊗ A) ◁ modMultiπ A (Y :: m)) ≫ + modTensorLegN A (modMultiMod A X l) (modMultiMod A Y m) ≫ + modMultiConcat A (X :: l) (Y :: m) = + (modList A (X :: l) ◁ modListHeadAct A Y m) ≫ + (modListConcat A (X :: l) (Y :: m)).hom ≫ + modMultiπ A ((X :: l) ++ (Y :: m)) := by + change (modMultiπ A (X :: l) ▷ (A ⊗ modList A (Y :: m))) ≫ + (α_ (modMulti A (X :: l)) A (modList A (Y :: m))).inv ≫ + ((modMulti A (X :: l) ⊗ A) ◁ modMultiπ A (Y :: m)) ≫ + ((α_ (modMulti A (X :: l)) A (modMulti A (Y :: m))).hom ≫ + (modMulti A (X :: l) ◁ modMultiHeadAct A Y m)) ≫ + modMultiConcat A (X :: l) (Y :: m) = _ + simp only [Category.assoc] + rw [associator_naturality_right_assoc, Iso.inv_hom_id_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + whiskerLeft_modMultiπ_headAct, + MonoidalCategory.whiskerLeft_comp_assoc, + whiskerLeft_modMultiπ_concat, ← whisker_exchange_assoc, + whiskerRight_modMultiπ_concatFst] + apply modMulti_whiskerL_hom_ext A (Y :: m) + (modMulti A (X :: l) ⊗ A) + apply (cancel_epi + (α_ (modMulti A (X :: l)) A (modList A (Y :: m))).inv).mp + apply modMulti_whiskerR_hom_ext A (X :: l) + (A ⊗ modList A (Y :: m)) + have mc := modListCross A X Y l m + rw [MonoidalCategory.comp_whiskerRight] at mc + simp only [Category.assoc] at mc + change (modMultiπ A (X :: l) ▷ (A ⊗ modList A (Y :: m))) ≫ + (α_ (modMulti A (X :: l)) A (modList A (Y :: m))).inv ≫ + ((modMulti A (X :: l) ⊗ A) ◁ modMultiπ A (Y :: m)) ≫ + modTensorLegM A (modMultiMod A X l) (modMultiMod A Y m) ≫ + modMultiConcat A (X :: l) (Y :: m) = + (modMultiπ A (X :: l) ▷ (A ⊗ modList A (Y :: m))) ≫ + (α_ (modMulti A (X :: l)) A (modList A (Y :: m))).inv ≫ + ((modMulti A (X :: l) ⊗ A) ◁ modMultiπ A (Y :: m)) ≫ + modTensorLegN A (modMultiMod A X l) (modMultiMod A Y m) ≫ + modMultiConcat A (X :: l) (Y :: m) + rw [hM, hN, mc, Iso.inv_hom_id_assoc] + +/-- **The concatenation descends to the binary module tensor +product of two multi-tensors.** -/ +noncomputable def modTensorMulti + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorRight Y)] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorLeft Y)] + (X Y : Mod D A) + (l m : List (Mod D A)) : + modTensor A (modMultiMod A X l) (modMultiMod A Y m) ⟶ + modMulti A ((X :: l) ++ (Y :: m)) := + modTensorDesc A (modMultiMod A X l) (modMultiMod A Y m) + (modMultiConcat A (X :: l) (Y :: m)) + (modTensorLeg_multi A X Y l m) + +/-- Defining equation of the descended concatenation against the +module-tensor projection. -/ +@[reassoc (attr := simp)] +lemma modTensorπ_multi [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorRight Y)] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorLeft Y)] + (X Y : Mod D A) (l m : List (Mod D A)) : + modTensorπ A (modMultiMod A X l) (modMultiMod A Y m) ≫ + modTensorMulti A X Y l m = + modMultiConcat A (X :: l) (Y :: m) := + modTensorπ_desc A _ _ _ _ + +/-- Defining equation of the descended concatenation against the +multi-tensor projections: on the folds it is the fold +concatenation. -/ +@[reassoc] +lemma tensorHom_modTensorπ_multi + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorRight Y)] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorLeft Y)] + (X Y : Mod D A) + (l m : List (Mod D A)) : + (modMultiπ A (X :: l) ⊗ₘ modMultiπ A (Y :: m)) ≫ + modTensorπ A (modMultiMod A X l) (modMultiMod A Y m) ≫ + modTensorMulti A X Y l m = + (modListConcat A (X :: l) (Y :: m)).hom ≫ + modMultiπ A ((X :: l) ++ (Y :: m)) := by + have e := congrArg (fun t => + (modMultiπ A (X :: l) ⊗ₘ modMultiπ A (Y :: m)) ≫ t) + (modTensorπ_multi A X Y l m) + exact e.trans (tensorHom_modMultiπ_concat A (X :: l) (Y :: m)) + +end TensorMulti + +/-! ## The braiding at a relation window + +In a symmetric category the braiding of the two module factors of +a relation window carries the monoid along; the window legs +intertwine it with the plain braiding of the factors, exchanging +the two legs. This mirrors the treatment of the symmetric-power +slot exchange, at two distinct modules. -/ + +section WinSwapMod + +/-- Exchange of the two module factors of a relation window, +carrying the monoid along: `(x ⊗ c) ⊗ y ↦ (y ⊗ c) ⊗ x`. -/ +def modWinSwap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] + (M N : Mod D A) : + (M.X ⊗ A) ⊗ N.X ⟶ (N.X ⊗ A) ⊗ M.X := + (β_ (M.X ⊗ A) N.X).hom ≫ (N.X ◁ (β_ M.X A).hom) ≫ + (α_ N.X A M.X).inv + +/-- The window exchange is an involution. -/ +@[reassoc (attr := simp)] +lemma modWinSwap_modWinSwap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] + (M N : Mod D A) : + modWinSwap A M N ≫ modWinSwap A N M = 𝟙 _ := by + simp only [modWinSwap, BraidedCategory.braiding_tensor_left_hom, + Category.assoc, Iso.inv_hom_id_assoc] + rw [← MonoidalCategory.whiskerLeft_comp_assoc N.X (β_ M.X A).hom + (β_ A M.X).hom, SymmetricCategory.symmetry, + MonoidalCategory.whiskerLeft_id, Category.id_comp, + Iso.hom_inv_id_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, + SymmetricCategory.symmetry, MonoidalCategory.id_whiskerRight, + Category.id_comp, Iso.inv_hom_id_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + SymmetricCategory.symmetry, MonoidalCategory.whiskerLeft_id, + Category.id_comp, Iso.hom_inv_id] + +/-- **The first leg intertwines the window exchange with the +braiding**: acting on the first factor and braiding is exchanging +and acting on the second factor. -/ +@[reassoc] +lemma modWinSwap_legM + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] + (M N : Mod D A) : + modTensorLegM A M N ≫ (β_ M.X N.X).hom = + modWinSwap A M N ≫ modTensorLegN A N M := by + rw [modTensorLegM, BraidedCategory.braiding_naturality_left, + actRight, MonoidalCategory.whiskerLeft_comp, modWinSwap, + modTensorLegN] + simp only [Category.assoc, Iso.inv_hom_id_assoc] + +/-- **The second leg intertwines the window exchange with the +braiding**, by the involutivity of both. -/ +@[reassoc] +lemma modWinSwap_legN + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] + (M N : Mod D A) : + modTensorLegN A M N ≫ (β_ M.X N.X).hom = + modWinSwap A M N ≫ modTensorLegM A N M := by + have h1 : modTensorLegN A M N = + modWinSwap A M N ≫ modTensorLegM A N M ≫ + (β_ N.X M.X).hom := by + rw [modWinSwap_legM A N M, ← Category.assoc, + modWinSwap_modWinSwap, Category.id_comp] + rw [h1, Category.assoc, Category.assoc, + SymmetricCategory.symmetry, Category.comp_id] + +end WinSwapMod + +/-! ## The two-element swap -/ + +section SwapPair + +/-- **The braiding of a two-element multi-tensor**: the exchange of +the two factors descends, the single slot relation consumed through +the window exchange. -/ +noncomputable def modMultiSwapPair + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + (M N : Mod D A) : + modMulti A [M, N] ⟶ modMulti A [N, M] := + modMultiDesc A (pairResolve A M N ≫ (β_ M.X N.X).hom ≫ + pairResolveInv A N M ≫ modMultiπ A [N, M]) + (by + intro pre M' N' post hd + obtain ⟨rfl, h2, h3, rfl⟩ := pair_decomp A hd + subst h2 + subst h3 + rw [modMultiLegM, modMultiLegN, + modMultiLeg_pair_resolve_assoc A M N _ hd.symm, + modMultiLeg_pair_resolve_assoc A M N _ hd.symm, + modWinSwap_legM_assoc, modWinSwap_legN_assoc, + modMultiLeg_pair_resolveInv_assoc A N M _ + (Eq.symm (rfl : [N, M] = [] ++ N :: M :: [])), + modMultiLeg_pair_resolveInv_assoc A N M _ + (Eq.symm (rfl : [N, M] = [] ++ N :: M :: []))] + have hrel := modMulti_rel A [] N M [] + (rfl : [N, M] = [] ++ N :: M :: []) + rw [modMultiLegM, modMultiLegN] at hrel + exact congrArg + (fun t => pairSeed A M N ≫ modWinSwap A M N ≫ + pairSeedInv A N M ≫ t) hrel.symm) + +/-- Defining equation of the two-element swap: on the fold it is +the braiding of the factors, conjugated by the unit seeds. -/ +@[reassoc (attr := simp)] +lemma modMultiπ_swapPair + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + (M N : Mod D A) : + modMultiπ A [M, N] ≫ modMultiSwapPair A M N = + pairResolve A M N ≫ (β_ M.X N.X).hom ≫ + pairResolveInv A N M ≫ modMultiπ A [N, M] := + modMultiπ_desc A _ _ + +end SwapPair + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModDual.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModDual.lean new file mode 100644 index 0000000000..665a6c2c65 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModDual.lean @@ -0,0 +1,446 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor + +/-! +# The dual of a module object + +Substrate for Deligne (2002), §2.8: over a monoidal category `D`, an +exact pairing `(X, Y)` transports a module structure on `X` (for a +monoid object `A`) to its dual `Y`. + +* `actCoev`: the coevaluation twisted by the action, `A ⟶ X ⊗ Y`, + with unit and multiplication laws `one_actCoev`/`mul_actCoev`. +* `dualActRight`: the contragredient right action `Y ⊗ A ⟶ Y`, the + mate of the action under the pairing; right-module laws are + `dualActRight_one` and `dualActRight_dualActRight`. No braiding + is needed at this stage. +* `dualActRight_evaluation`/`coevaluation_dualActRight`: the mate + calculus carrying the dual action across the evaluation and the + coevaluation of the pairing. +* `dualActLeft`: in a braided category, `(β_ Y A).inv ≫ + dualActRight`; for a commutative monoid this is a left module + structure, bundled as `dualModObj`/`dualMod`. The inverse + braiding is chosen so that the braided right action `actRight` + derived on the dual is exactly `dualActRight` + (`actRight_dualMod`), which makes the pairing descend through the + module-tensor coequalizer on the nose. +* `modPairing : modTensor A (dualMod A X Y) (asMod A X) ⟶ A`, the + descent of `ε_ X Y ≫ η[A]`. It is balanced but is not a + morphism of `A`-modules for a general module; the equivariance + that does hold is `whiskerLeft_modTensorπ_act_modPairing`. +* `modCopairing : A ⟶ modTensor A (asMod A X) (dualMod A X Y)`, + the twisted coevaluation followed by the projection. It is a + morphism of modules (`mul_modCopairing`), bundled as + `modCopairingHom`. + +Zigzag identities at the `modTensor` level, and nonvanishing of the +copairing, need the multi-tensor coherence layer and are outside +this module's scope. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +section ActCoev + +/-- The coevaluation twisted by the action: informally +`a ↦ (a • xᵢ) ⊗ yᵢ` in dual-basis notation. -/ +def actCoev + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : D) (Y : D) + [ExactPairing X Y] [ModObj A X] : A ⟶ X ⊗ Y := + (ρ_ A).inv ≫ A ◁ η_ X Y ≫ (α_ A X Y).inv ≫ actLeft A X ▷ Y + +/-- The twisted coevaluation, unfolded. -/ +lemma actCoev_def + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : D) (Y : D) + [ExactPairing X Y] [ModObj A X] : + actCoev A X Y = + (ρ_ A).inv ≫ A ◁ η_ X Y ≫ (α_ A X Y).inv ≫ + actLeft A X ▷ Y := + rfl + +/-- Uncurrying the twisted coevaluation recovers the action. -/ +@[reassoc] +lemma actCoev_uncurry + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : D) (Y : D) + [ExactPairing X Y] [ModObj A X] : + actCoev A X Y ▷ X ≫ (α_ X Y X).hom ≫ X ◁ ε_ X Y ≫ + (ρ_ X).hom = actLeft A X := + (tensorRightHomEquiv A X Y X).symm_apply_apply (actLeft A X) + +/-- Unit law of the twisted coevaluation. -/ +@[reassoc] +lemma one_actCoev + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : D) (Y : D) + [ExactPairing X Y] [ModObj A X] : η[A] ≫ actCoev A X Y = η_ X Y := by + rw [actCoev_def, rightUnitor_inv_naturality_assoc, + ← whisker_exchange_assoc, associator_inv_naturality_left_assoc, + ← comp_whiskerRight, one_actLeft] + monoidal + +/-- Multiplication law of the twisted coevaluation. -/ +@[reassoc] +lemma mul_actCoev + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : D) (Y : D) + [ExactPairing X Y] [ModObj A X] : + μ[A] ≫ actCoev A X Y = + A ◁ actCoev A X Y ≫ (α_ A X Y).inv ≫ actLeft A X ▷ Y := by + rw [actCoev_def, rightUnitor_inv_naturality_assoc, + ← whisker_exchange_assoc, associator_inv_naturality_left_assoc, + ← comp_whiskerRight, mul_actLeft] + monoidal + +/-- The contragredient right action on the dual: informally +`f ⊗ a ↦ f (a • ·)`, that is, `f ⊗ a ↦ f (a • xᵢ) yᵢ` in dual-basis +notation. -/ +def dualActRight + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : D) (Y : D) + [ExactPairing X Y] [ModObj A X] : Y ⊗ A ⟶ Y := + Y ◁ actCoev A X Y ≫ (α_ Y X Y).inv ≫ ε_ X Y ▷ Y ≫ (λ_ Y).hom + +/-- The contragredient right action, unfolded. -/ +lemma dualActRight_def + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : D) (Y : D) + [ExactPairing X Y] [ModObj A X] : + dualActRight A X Y = + Y ◁ actCoev A X Y ≫ (α_ Y X Y).inv ≫ ε_ X Y ▷ Y ≫ + (λ_ Y).hom := + rfl + +/-- Evaluation compatibility: the contragredient action against the +evaluation is the original action across the pairing. This is the +workhorse identity of the mate calculus. -/ +@[reassoc] +lemma dualActRight_evaluation + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : D) (Y : D) + [ExactPairing X Y] [ModObj A X] : + dualActRight A X Y ▷ X ≫ ε_ X Y = + (α_ Y A X).hom ≫ Y ◁ actLeft A X ≫ ε_ X Y := by + calc dualActRight A X Y ▷ X ≫ ε_ X Y + _ = 𝟙 _ ⊗≫ (Y ◁ actCoev A X Y) ▷ X ⊗≫ + (ε_ X Y ▷ (Y ⊗ X) ≫ 𝟙_ D ◁ ε_ X Y) ⊗≫ 𝟙 _ := by + rw [dualActRight_def]; monoidal + _ = 𝟙 _ ⊗≫ (Y ◁ actCoev A X Y) ▷ X ⊗≫ + ((Y ⊗ X) ◁ ε_ X Y ≫ ε_ X Y ▷ 𝟙_ D) ⊗≫ 𝟙 _ := by + rw [← whisker_exchange] + _ = (α_ Y A X).hom ≫ Y ◁ (actCoev A X Y ▷ X ≫ + (α_ X Y X).hom ≫ X ◁ ε_ X Y ≫ (ρ_ X).hom) ≫ + ε_ X Y := by + monoidal + _ = (α_ Y A X).hom ≫ Y ◁ actLeft A X ≫ ε_ X Y := by + rw [actCoev_uncurry] + +/-- Coevaluation compatibility, the mirror of +`dualActRight_evaluation`: inserting the coevaluation and applying +the contragredient action is the twisted coevaluation. -/ +@[reassoc] +lemma coevaluation_dualActRight + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : D) (Y : D) + [ExactPairing X Y] [ModObj A X] : + η_ X Y ▷ A ≫ (α_ X Y A).hom ≫ X ◁ dualActRight A X Y = + (λ_ A).hom ≫ actCoev A X Y := by + have h : (λ_ A).inv ≫ η_ X Y ▷ A ≫ (α_ X Y A).hom ≫ + X ◁ dualActRight A X Y = actCoev A X Y := + (tensorLeftHomEquiv A X Y Y).apply_symm_apply (actCoev A X Y) + rw [← h, Iso.hom_inv_id_assoc] + +/-- Unitality of the contragredient right action. -/ +@[reassoc] +lemma dualActRight_one + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : D) (Y : D) + [ExactPairing X Y] [ModObj A X] : + Y ◁ η[A] ≫ dualActRight A X Y = (ρ_ Y).hom := by + rw [dualActRight_def, ← MonoidalCategory.whiskerLeft_comp_assoc, + one_actCoev] + simp + +/-- Associativity of the contragredient right action. -/ +@[reassoc] +lemma dualActRight_dualActRight + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : D) (Y : D) + [ExactPairing X Y] [ModObj A X] : + dualActRight A X Y ▷ A ≫ dualActRight A X Y = + (α_ Y A A).hom ≫ Y ◁ μ[A] ≫ dualActRight A X Y := by + calc dualActRight A X Y ▷ A ≫ dualActRight A X Y + _ = dualActRight A X Y ▷ A ≫ Y ◁ actCoev A X Y ≫ + (α_ Y X Y).inv ≫ ε_ X Y ▷ Y ≫ (λ_ Y).hom := by + rw [← dualActRight_def] + _ = (Y ⊗ A) ◁ actCoev A X Y ≫ + dualActRight A X Y ▷ (X ⊗ Y) ≫ + (α_ Y X Y).inv ≫ ε_ X Y ▷ Y ≫ (λ_ Y).hom := by + rw [← whisker_exchange_assoc] + _ = (Y ⊗ A) ◁ actCoev A X Y ≫ (α_ (Y ⊗ A) X Y).inv ≫ + (dualActRight A X Y ▷ X ≫ ε_ X Y) ▷ Y ≫ + (λ_ Y).hom := by + rw [associator_inv_naturality_left_assoc, + ← comp_whiskerRight_assoc] + _ = (Y ⊗ A) ◁ actCoev A X Y ≫ (α_ (Y ⊗ A) X Y).inv ≫ + ((α_ Y A X).hom ≫ Y ◁ actLeft A X ≫ ε_ X Y) ▷ Y ≫ + (λ_ Y).hom := by + rw [dualActRight_evaluation] + _ = (α_ Y A A).hom ≫ Y ◁ (μ[A] ≫ actCoev A X Y) ≫ + (α_ Y X Y).inv ≫ ε_ X Y ▷ Y ≫ (λ_ Y).hom := by + rw [mul_actCoev]; monoidal + _ = (α_ Y A A).hom ≫ Y ◁ μ[A] ≫ dualActRight A X Y := by + rw [MonoidalCategory.whiskerLeft_comp_assoc, + ← dualActRight_def] + +end ActCoev + +section DualModule + +/-- The dual left action: the contragredient right action pulled +back along the inverse braiding. The inverse braiding (rather than +the braiding `β_ A Y`) is chosen so that the braided right action +`actRight` derived from it is exactly `dualActRight`; see +`actRight_dualMod`. -/ +def dualActLeft [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (X : D) (Y : D) [ExactPairing X Y] [ModObj A X] : + A ⊗ Y ⟶ Y := + (β_ Y A).inv ≫ dualActRight A X Y + +/-- The dual left action, unfolded. -/ +lemma dualActLeft_def [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (X : D) (Y : D) [ExactPairing X Y] [ModObj A X] : + dualActLeft A X Y = (β_ Y A).inv ≫ dualActRight A X Y := + rfl + +/-- Unitality of the dual left action. -/ +@[reassoc] +lemma one_dualActLeft [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (X : D) (Y : D) [ExactPairing X Y] [ModObj A X] : + η[A] ▷ Y ≫ dualActLeft A X Y = (λ_ Y).hom := by + rw [dualActLeft_def, BraidedCategory.braiding_inv_naturality_left_assoc, + dualActRight_one, braiding_inv_tensorUnit_right] + simp + +/-- Evaluation compatibility for the dual left action. -/ +@[reassoc] +lemma dualActLeft_evaluation + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (X : D) (Y : D) [ExactPairing X Y] [ModObj A X] : + dualActLeft A X Y ▷ X ≫ ε_ X Y = + (β_ Y A).inv ▷ X ≫ (α_ Y A X).hom ≫ Y ◁ actLeft A X ≫ + ε_ X Y := by + rw [dualActLeft_def, comp_whiskerRight, Category.assoc, + dualActRight_evaluation] + +/-- Associativity of the dual left action, for a commutative +monoid. -/ +@[reassoc] +lemma mul_dualActLeft [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (X : D) (Y : D) [ExactPairing X Y] [ModObj A X] + [IsCommMonObj A] : + μ[A] ▷ Y ≫ dualActLeft A X Y = + (α_ A A Y).hom ≫ A ◁ dualActLeft A X Y ≫ + dualActLeft A X Y := by + rw [dualActLeft_def, BraidedCategory.braiding_inv_naturality_left_assoc, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + BraidedCategory.braiding_inv_naturality_right_assoc, + dualActRight_dualActRight, BraidedCategory.braiding_tensor_right_inv, + BraidedCategory.braiding_tensor_left_inv] + simp only [Category.assoc, Iso.inv_hom_id_assoc] + rw [← MonoidalCategory.whiskerLeft_comp_assoc, + IsCommMonObj.mul_comm' A] + +/-- The dual module structure on `Y`, for a commutative monoid. -/ +@[implicit_reducible] +def dualModObj [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (X : D) (Y : D) [ExactPairing X Y] [ModObj A X] + [IsCommMonObj A] : ModObj A Y where + smul := dualActLeft A X Y + one_smul := one_dualActLeft A X Y + mul_smul := mul_dualActLeft A X Y + +/-- The dual of a module, bundled: `Y` with the transported +action. -/ +@[reducible] +def dualMod [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (X : D) (Y : D) [ExactPairing X Y] [ModObj A X] + [IsCommMonObj A] : Mod D A := + letI := dualModObj A X Y + ⟨Y⟩ + +/-- On the dual module the action is the dual left action. -/ +lemma actLeft_dualMod [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (X : D) (Y : D) [ExactPairing X Y] [ModObj A X] + [IsCommMonObj A] : + haveI := dualModObj A X Y + actLeft A Y = dualActLeft A X Y := rfl + +/-- On the dual module the braided right action is exactly the +contragredient right action. -/ +lemma actRight_dualMod [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (X : D) (Y : D) [ExactPairing X Y] [ModObj A X] + [IsCommMonObj A] : + haveI := dualModObj A X Y + actRight A Y = dualActRight A X Y := by + change (β_ Y A).hom ≫ dualActLeft A X Y = dualActRight A X Y + rw [dualActLeft_def, Iso.hom_inv_id_assoc] + +end DualModule + +section AsMod + +/-- A module object, bundled as a module. -/ +@[reducible] +def asMod [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : D) + [ModObj A X] : Mod D A := ⟨X⟩ + +end AsMod + +section ModDualPairing + +/-- The two coequalizer legs agree against the paired evaluation: +this is exactly `dualActRight_evaluation`, thanks to the inverse +braiding convention of `dualActLeft`. -/ +lemma modTensorLeg_pair [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] (X : D) (Y : D) [ExactPairing X Y] + [ModObj A X] : + modTensorLegM A (dualMod A X Y) (asMod A X) ≫ + (ε_ X Y ≫ η[A]) = + modTensorLegN A (dualMod A X Y) (asMod A X) ≫ + (ε_ X Y ≫ η[A]) := by + let := dualModObj A X Y + change actRight A Y ▷ X ≫ (ε_ X Y ≫ η[A]) = + ((α_ Y A X).hom ≫ Y ◁ actLeft A X) ≫ (ε_ X Y ≫ η[A]) + rw [actRight_dualMod, dualActRight_evaluation_assoc, + Category.assoc] + +/-- The `A`-valued pairing on the module tensor of the dual with +the module: the descent of `ε_ X Y ≫ η[A]` through the coequalizer. +It is balanced but, for a general module, not a morphism of +`A`-modules; see `whiskerLeft_modTensorπ_act_modPairing` for the +equivariance it does satisfy. -/ +noncomputable def modPairing + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] (X : D) (Y : D) [ExactPairing X Y] + [ModObj A X] [HasCoequalizers D] : + modTensor A (dualMod A X Y) (asMod A X) ⟶ A := + modTensorDesc A (dualMod A X Y) (asMod A X) (ε_ X Y ≫ η[A]) + (modTensorLeg_pair A X Y) + +/-- Defining equation of the pairing. -/ +@[reassoc (attr := simp)] +lemma modTensorπ_modPairing + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] (X : D) (Y : D) [ExactPairing X Y] + [ModObj A X] [HasCoequalizers D] : + modTensorπ A (dualMod A X Y) (asMod A X) ≫ modPairing A X Y = + ε_ X Y ≫ η[A] := + modTensorπ_desc A _ _ _ _ + +/-- The copairing into the module tensor of the module with its +dual: the twisted coevaluation followed by the projection. -/ +noncomputable def modCopairing + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] (X : D) (Y : D) [ExactPairing X Y] + [ModObj A X] [HasCoequalizers D] : + A ⟶ modTensor A (asMod A X) (dualMod A X Y) := + actCoev A X Y ≫ modTensorπ A (asMod A X) (dualMod A X Y) + +/-- The copairing carries the unit to the projected coevaluation. -/ +@[reassoc] +lemma one_modCopairing [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] (X : D) (Y : D) [ExactPairing X Y] + [ModObj A X] [HasCoequalizers D] : + η[A] ≫ modCopairing A X Y = + η_ X Y ≫ modTensorπ A (asMod A X) (dualMod A X Y) := by + rw [modCopairing, one_actCoev_assoc] + +/-- Equivariance of the pairing: acting on the tensor product and +pairing equals braiding the scalar through and pairing against the +acted-on module. For a general module this is the strongest +compatibility available; the pairing is not `A`-linear. -/ +@[reassoc] +lemma whiskerLeft_modTensorπ_act_modPairing + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] (X : D) (Y : D) [ExactPairing X Y] + [ModObj A X] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] : + A ◁ modTensorπ A (dualMod A X Y) (asMod A X) ≫ + modTensorAct A (dualMod A X Y) (asMod A X) ≫ + modPairing A X Y = + (α_ A Y X).inv ≫ (β_ Y A).inv ▷ X ≫ (α_ Y A X).hom ≫ + Y ◁ actLeft A X ≫ ε_ X Y ≫ η[A] := by + rw [whiskerLeft_modTensorπ_act_assoc, modTensorπ_modPairing] + let := dualModObj A X Y + change (α_ A Y X).inv ≫ actLeft A Y ▷ X ≫ ε_ X Y ≫ η[A] = _ + rw [actLeft_dualMod, dualActLeft_evaluation_assoc] + +/-- The copairing is a morphism of modules. -/ +@[reassoc] +lemma mul_modCopairing [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] (X : D) (Y : D) [ExactPairing X Y] + [ModObj A X] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] : + μ[A] ≫ modCopairing A X Y = + A ◁ modCopairing A X Y ≫ + modTensorAct A (asMod A X) (dualMod A X Y) := by + rw [modCopairing, MonoidalCategory.whiskerLeft_comp, + Category.assoc, whiskerLeft_modTensorπ_act, + mul_actCoev_assoc] + simp only [Category.assoc] + +/-- The copairing, bundled as a morphism of modules out of the +regular module. -/ +noncomputable def modCopairingHom + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] (X : D) (Y : D) [ExactPairing X Y] + [ModObj A X] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] : + regularMod A ⟶ modTensorMod A (asMod A X) (dualMod A X Y) := + Mod.Hom.mk' (modCopairing A X Y) (mul_modCopairing A X Y) + +end ModDualPairing + +section RightDual + +/-- The dual left action, specialised to the right dual `Xᘁ`. -/ +def rightDualActLeft [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (X : D) [HasRightDual X] [ModObj A X] : + A ⊗ Xᘁ ⟶ Xᘁ := dualActLeft A X (Xᘁ) + +/-- Unitality of the dual left action at the right dual. -/ +@[reassoc] +lemma one_rightDualActLeft + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (X : D) [HasRightDual X] [ModObj A X] : + η[A] ▷ (Xᘁ) ≫ rightDualActLeft A X = (λ_ (Xᘁ)).hom := + one_dualActLeft A X (Xᘁ) + +/-- Associativity of the dual left action at the right dual. -/ +@[reassoc] +lemma mul_rightDualActLeft + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (X : D) [HasRightDual X] [ModObj A X] + [IsCommMonObj A] : + μ[A] ▷ (Xᘁ) ≫ rightDualActLeft A X = + (α_ A A (Xᘁ)).hom ≫ A ◁ rightDualActLeft A X ≫ + rightDualActLeft A X := + mul_dualActLeft A X (Xᘁ) + +/-- The dual module, specialised to the right dual `Xᘁ`. -/ +@[reducible] +def rightDualMod [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (X : D) [HasRightDual X] [ModObj A X] + [IsCommMonObj A] : Mod D A := dualMod A X (Xᘁ) + +end RightDual + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModIns.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModIns.lean new file mode 100644 index 0000000000..a05dcb7fe2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModIns.lean @@ -0,0 +1,324 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModCross + +/-! +# Insertion and contraction on the multi-tensor + +The two workhorses of the Key Lemma's pairing calculus: inserting +a copairing's image at a boundary of the multi-tensor, and +contracting a pairing across one. Insertion needs no descent — +it lands in the larger multi-tensor through the concatenation; +contraction descends through the coequalizer using the pairing's +linearity. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- The pairing evaluated on the two-element fold. -/ +noncomputable def modListPairFold + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] (A : D) [MonObj A] + {M M' : Mod D A} + (p : modTensor A M' M ⟶ A) : + modList A [M', M] ⟶ A := + (M'.X ◁ (ρ_ M.X).hom) ≫ modTensorπ A M' M ≫ p + +/-- Case analysis for decompositions of `Xs ++ [M', M]`: a slot +lies inside `Xs`, at the boundary, or inside the pair. -/ +theorem append_pair_slot_cases + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + {Xs pre post : List (Mod D A)} + {M M' P Q : Mod D A} + (hd : Xs ++ [M', M] = pre ++ P :: Q :: post) : + (∃ post', post = post' ++ [M', M] ∧ + Xs = pre ++ P :: Q :: post') ∨ + (post = [M] ∧ Q = M' ∧ Xs = pre ++ [P]) ∨ + (post = [] ∧ P = M' ∧ Q = M ∧ Xs = pre) := by + rcases post.eq_nil_or_concat with h | ⟨post', q, rfl⟩ + · subst h + have := congrArg List.reverse hd + simp only [List.reverse_append, List.reverse_cons, List.reverse_nil, List.nil_append, + List.cons_append, List.cons.injEq, List.reverse_inj] at this + obtain ⟨h1, h2, h3⟩ := this + exact Or.inr (Or.inr ⟨rfl, h2.symm, h1.symm, by + simpa using congrArg List.reverse h3⟩) + · rcases post'.eq_nil_or_concat with h | ⟨post'', q', rfl⟩ + · subst h + have := congrArg List.reverse hd + simp only [List.reverse_append, List.reverse_cons, List.reverse_nil, List.nil_append, + List.cons_append, List.concat_eq_append, List.cons.injEq, List.reverse_eq_cons_iff, + List.reverse_reverse] at this + obtain ⟨h1, h2, h3⟩ := this + refine Or.inr (Or.inl ⟨by simp [List.concat, h1], + h2.symm, ?_⟩) + have h4 := congrArg List.reverse h3 + simp only [List.reverse_append, List.reverse_cons, List.reverse_nil, List.nil_append, + List.cons_append, List.reverse_eq_cons_iff, List.reverse_reverse] at h4 + rw [h4] + · have := congrArg List.reverse hd + simp only [List.reverse_append, List.reverse_cons, List.reverse_nil, List.nil_append, + List.cons_append, List.concat_eq_append, List.append_assoc, List.cons.injEq, + List.reverse_eq_append_iff, List.reverse_reverse] at this + obtain ⟨h1, h2, h3⟩ := this + refine Or.inl ⟨post'', ⟨by + rw [show (post''.concat q').concat q = + post'' ++ [q', q] by simp, h1, h2], ?_⟩⟩ + have h4 := congrArg List.reverse h3 + simp at h4 + simpa using h4 + +section Contract3 + +/-- The fold-level three-window contraction: pair off the +trailing window, act on the head with the resulting scalar. -/ +noncomputable def contract3Fold + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (N : Mod D A) : modList A [N, M', M] ⟶ modMulti A [N] := + (N.X ◁ ((M'.X ◁ (ρ_ M.X).hom) ≫ modTensorπ A M' M ≫ p)) ≫ + actRight A N.X ≫ (ρ_ N.X).inv ≫ modMultiπ A [N] + +/-- The window morphism of the trailing pair passes to the +pairing through the projection. -/ +theorem window_contract3Fold + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (N : Mod D A) (w : (M'.X ⊗ A) ⊗ M.X ⟶ M'.X ⊗ M.X) : + (N.X ◁ ((w ▷ modList A []) ≫ + (α_ M'.X M.X (modList A [])).hom)) ≫ + contract3Fold A p N = + (N.X ◁ ((ρ_ ((M'.X ⊗ A) ⊗ M.X)).hom ≫ w ≫ + modTensorπ A M' M ≫ p)) ≫ + actRight A N.X ≫ (ρ_ N.X).inv ≫ modMultiπ A [N] := by + change (N.X ◁ ((w ▷ (𝟙_ D)) ≫ (α_ M'.X M.X (𝟙_ D)).hom)) ≫ + (N.X ◁ ((M'.X ◁ (ρ_ M.X).hom) ≫ + modTensorπ A M' M ≫ p)) ≫ + actRight A N.X ≫ (ρ_ N.X).inv ≫ modMultiπ A [N] = _ + rw [← MonoidalCategory.whiskerLeft_comp_assoc] + have hw : ((w ▷ (𝟙_ D)) ≫ (α_ M'.X M.X (𝟙_ D)).hom) ≫ + (M'.X ◁ (ρ_ M.X).hom) ≫ modTensorπ A M' M ≫ p = + (ρ_ ((M'.X ⊗ A) ⊗ M.X)).hom ≫ w ≫ + modTensorπ A M' M ≫ p := by + have hcoh : (α_ M'.X M.X (𝟙_ D)).hom ≫ + (M'.X ◁ (ρ_ M.X).hom) = (ρ_ (M'.X ⊗ M.X)).hom := by + monoidal + rw [Category.assoc, reassoc_of% hcoh, + rightUnitor_naturality_assoc] + rw [hw] + +/-- The boundary-slot condition of the three-window contraction: +the two window legs of the head--dual boundary agree after the +contraction, through the linearity of the pairing. -/ +theorem contract3Fold_boundary_cond + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) + (N : Mod D A) : + modMultiLegM A [] N M' [M] ≫ contract3Fold A p N = + modMultiLegN A [] N M' [M] ≫ contract3Fold A p N := by + change (((actRight A N.X ▷ M'.X) ▷ (M.X ⊗ 𝟙_ D)) ≫ + (α_ N.X M'.X (M.X ⊗ 𝟙_ D)).hom) ≫ + (N.X ◁ ((M'.X ◁ (ρ_ M.X).hom) ≫ + modTensorπ A M' M ≫ p)) ≫ + actRight A N.X ≫ + ((ρ_ N.X).inv : N.X ⟶ modList A [N]) ≫ + modMultiπ A [N] = + ((((α_ N.X A M'.X).hom ≫ (N.X ◁ actLeft A M'.X)) ▷ + (M.X ⊗ 𝟙_ D)) ≫ + (α_ N.X M'.X (M.X ⊗ 𝟙_ D)).hom) ≫ + (N.X ◁ ((M'.X ◁ (ρ_ M.X).hom) ≫ + modTensorπ A M' M ≫ p)) ≫ + actRight A N.X ≫ + ((ρ_ N.X).inv : N.X ⟶ modList A [N]) ≫ + modMultiπ A [N] + simp only [Category.assoc] + have hL : (((actRight A N.X ▷ M'.X) ▷ (M.X ⊗ 𝟙_ D)) ≫ + (α_ N.X M'.X (M.X ⊗ 𝟙_ D)).hom) ≫ + (N.X ◁ ((M'.X ◁ (ρ_ M.X).hom) ≫ + modTensorπ A M' M ≫ p)) = + (α_ (N.X ⊗ A) M'.X (M.X ⊗ 𝟙_ D)).hom ≫ + ((N.X ⊗ A) ◁ ((M'.X ◁ (ρ_ M.X).hom) ≫ + modTensorπ A M' M ≫ p)) ≫ + (actRight A N.X ▷ A) := by + simp only [Category.assoc] + rw [associator_naturality_left_assoc, ← whisker_exchange] + conv_lhs => rw [reassoc_of% hL] + rw [reassoc_of% (actRight_actRight A N.X)] + have hp' : modTensorAct A M' M ≫ p = (A ◁ p) ≫ μ[A] := hp + have hActπ : (actLeft A M'.X ▷ M.X) ≫ modTensorπ A M' M = + (α_ A M'.X M.X).hom ≫ (A ◁ modTensorπ A M' M) ≫ + modTensorAct A M' M := by + rw [whiskerLeft_modTensorπ_act] + simp only [Category.assoc, Iso.hom_inv_id_assoc] + have hInner : (actLeft A M'.X ▷ (M.X ⊗ 𝟙_ D)) ≫ + (M'.X ◁ (ρ_ M.X).hom) ≫ modTensorπ A M' M ≫ p = + ((A ⊗ M'.X) ◁ (ρ_ M.X).hom) ≫ (α_ A M'.X M.X).hom ≫ + (A ◁ modTensorπ A M' M) ≫ (A ◁ p) ≫ μ[A] := by + rw [← whisker_exchange_assoc, reassoc_of% hActπ] + rw [show modTensorAct A M' M ≫ p = (A ◁ p) ≫ μ[A] from hp'] + conv_rhs => rw [comp_whiskerRight, Category.assoc, + associator_naturality_middle_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, hInner] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + suffices h : (α_ (N.X ⊗ A) M'.X (M.X ⊗ 𝟙_ D)).hom ≫ + ((N.X ⊗ A) ◁ (M'.X ◁ (ρ_ M.X).hom)) ≫ + ((N.X ⊗ A) ◁ modTensorπ A M' M) ≫ + ((N.X ⊗ A) ◁ p) ≫ (α_ N.X A A).hom = + ((α_ N.X A M'.X).hom ▷ (M.X ⊗ 𝟙_ D)) ≫ + (α_ N.X (A ⊗ M'.X) (M.X ⊗ 𝟙_ D)).hom ≫ + (N.X ◁ ((A ⊗ M'.X) ◁ (ρ_ M.X).hom)) ≫ + (N.X ◁ (α_ A M'.X M.X).hom) ≫ + (N.X ◁ (A ◁ modTensorπ A M' M)) ≫ + (N.X ◁ (A ◁ p)) by + rw [reassoc_of% h] + monoidal + +/-- **The multi-level contraction at a three-element window**: a +linear pairing contracts the trailing pair of the multi-tensor, +the scalar acting on the head. -/ +noncomputable def modMultiContract3 + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) + (N : Mod D A) : + modMulti A [N, M', M] ⟶ modMulti A [N] := + modMultiDesc A (contract3Fold A p N) + (by + intro pre P Q post hd + rcases append_pair_slot_cases A (Xs := [N]) + (show [N] ++ [M', M] = pre ++ P :: Q :: post from hd) + with ⟨post', _, h2⟩ | ⟨h1, h2, h3⟩ | ⟨h1, h2, h3, h4⟩ + · exact absurd (congrArg List.length h2) + (by simp; omega) + · subst h1 + replace h2 := h2.symm; subst h2 + obtain ⟨rfl, hP⟩ : pre = [] ∧ P = N := by + rcases pre with _ | ⟨R, rest⟩ + · exact ⟨rfl, by simpa using h3.symm⟩ + · exact absurd (congrArg List.length h3) (by simp) + replace hP := hP.symm; subst hP + have hid : (modListCast A hd.symm ≫ + contract3Fold A p N : + modList A ([] ++ N :: M' :: [M]) ⟶ + modMulti A [N]) = contract3Fold A p N := + Category.id_comp _ + exact ((congrArg (fun t => + modMultiLegM A [] N M' [M] ≫ t) hid).trans + (contract3Fold_boundary_cond A p hp N)).trans + (congrArg (fun t => + modMultiLegN A [] N M' [M] ≫ t) hid.symm) + · subst h1 + replace h2 := h2.symm; subst h2 + replace h3 := h3.symm; subst h3 + obtain rfl : pre = [N] := h4.symm + have hid : (modListCast A hd.symm ≫ + contract3Fold A p N : + modList A ([N] ++ M' :: M :: []) ⟶ + modMulti A [N]) = contract3Fold A p N := + Category.id_comp _ + have hfree : modMultiLegM A [N] M' M [] ≫ + contract3Fold A p N = + modMultiLegN A [N] M' M [] ≫ + contract3Fold A p N := by + change (N.X ◁ ((modTensorLegM A M' M ▷ modList A []) ≫ + (α_ M'.X M.X (modList A [])).hom)) ≫ + contract3Fold A p N = + (N.X ◁ ((modTensorLegN A M' M ▷ modList A []) ≫ + (α_ M'.X M.X (modList A [])).hom)) ≫ + contract3Fold A p N + rw [window_contract3Fold, window_contract3Fold] + have hcond2 : modTensorLegM A M' M ≫ + modTensorπ A M' M ≫ p = + modTensorLegN A M' M ≫ modTensorπ A M' M ≫ p := by + rw [← Category.assoc, modTensor_condition, + Category.assoc] + exact congrArg (fun t => (N.X ◁ + ((ρ_ ((M'.X ⊗ A) ⊗ M.X)).hom ≫ t)) ≫ + actRight A N.X ≫ (ρ_ N.X).inv ≫ modMultiπ A [N]) + hcond2 + exact ((congrArg (fun t => + modMultiLegM A [N] M' M [] ≫ t) hid).trans + hfree).trans + (congrArg (fun t => + modMultiLegN A [N] M' M [] ≫ t) hid.symm)) + +/-- Defining equation of the three-window contraction. -/ +@[reassoc (attr := simp)] +theorem modMultiπ_contract3 + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) + (N : Mod D A) : + modMultiπ A [N, M', M] ≫ modMultiContract3 A p hp N = + contract3Fold A p N := + modMultiπ_desc A _ _ + +end Contract3 + +section ZigCore + +/-- The image of a copairing at the two-element multi-tensor. -/ +noncomputable def copairImage + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] {M : Mod D A} {M' : Mod D A} + (c : A ⟶ modTensor A M M') : + 𝟙_ D ⟶ modMulti A [M, M'] := + η[A] ≫ c ≫ (modMultiPair A M M').inv + +/-- **The zig composite** of a copairing and a linear pairing: +insert the copairing on the left, concatenate, and contract the +trailing pair. The zigzag law of a duality datum states that +this composite is the identity. -/ +noncomputable def zigComposite + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (c : A ⟶ modTensor A M M') + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) : + modMulti A [M] ⟶ modMulti A [M] := + (λ_ (modMulti A [M])).inv ≫ + (copairImage A c ▷ modMulti A [M]) ≫ + modMultiConcat A [M, M'] [M] ≫ + modMultiContract3 A p hp M + +end ZigCore + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMulti.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMulti.lean new file mode 100644 index 0000000000..9e64f0d90b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMulti.lean @@ -0,0 +1,1490 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor + +/-! +# The multi-tensor of internal modules over a monoid object + +The replacement for associativity of the binary module tensor +product of `ModTensor.lean`: for a list `Xs` of left modules over a +monoid object `A` in a braided monoidal category, the multi-tensor +`X₁ ⊗_A ⋯ ⊗_A Xₙ` is presented in one step, as the coequalizer of a +single wide relation pair + + `⊕ₛ mid s ⇉ X₁ ⊗ (X₂ ⊗ (⋯ ⊗ Xₙ))` + +whose source is the finite biproduct, over the adjacent slots `s` of +the list, of the relation objects obtained by inserting `A` between +the two factors of the slot, and whose legs act on the slot through +the braided right action and the left action respectively — the two +legs of `ModTensor.lean` at the slot's window, in every adjacent +slot at once. + +* `modList A Xs`: the plain tensor fold of the underlying objects, + with the monoidal unit as seed; `modListCast` transports it along + equalities of lists. +* `ModSlot Xs`: an adjacent slot, recorded as a decomposition + `Xs = pre ++ M :: N :: post`; `modSlots Xs` enumerates the slots + and `mem_modSlots` shows the enumeration is complete. +* `modMulti A Xs`, `modMultiπ`, `modMulti_rel`, `modMultiDesc`, + `modMultiπ_desc`, `modMulti_hom_ext`: the multi-tensor and its + universal property, with the slot relations quantified over + decompositions. +* `modMultiNil`/`modMultiSingle`: with this presentation the empty + multi-tensor is the monoidal unit of the ambient category (not + the regular module `A`, which is the unit of `Mod A` — consumers + wanting that convention should treat the empty list separately), + and the singleton multi-tensor is the module itself. +* `modMultiPair`: the two-element multi-tensor agrees with the + binary `modTensor`, compatibly with the projections. +* `modMultiWhiskerRDesc`/`modMultiWhiskerLDesc`: descent along the + whiskered projections, with the whiskered relation condition + reduced to the slots through the biproduct distributors. +* `modMultiConcatFst`, `modMultiConcat`: the concatenation map + `modMulti A Xs ⊗ modMulti A Ys ⟶ modMulti A (Xs ++ Ys)`, by a + two-stage descent through the whiskered coequalizers, with the + defining equation `tensorHom_modMultiπ_concat` against the + projections and the fold concatenation `modListConcat`. +* `modMultiHeadAct`, `modMultiMod`: for a commutative monoid the + action on the head factor descends, making the multi-tensor of a + non-empty list a module; the empty multi-tensor is the monoidal + unit and carries no canonical `A`-action. + +The further descent of `modMultiConcat` through the middle +`A`-action — the comparison with `modTensor` of two multi-tensors — +is outside this module's scope; its substrate (the head modules, +the concatenation map, and the slot relations) is complete. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## The underlying tensor fold -/ + +section ModList + +/-- The tensor fold of the underlying objects of a list of modules, +folded to the right with the monoidal unit as seed. -/ +def modList [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] : + List (Mod D A) → D + | [] => 𝟙_ D + | M :: l => M.X ⊗ modList A l + +@[simp] lemma modList_nil + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] : + modList A ([] : List (Mod D A)) = 𝟙_ D := + rfl + +@[simp] lemma modList_cons + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (M : Mod D A) (l : List (Mod D A)) : + modList A (M :: l) = M.X ⊗ modList A l := + rfl + +/-- Transport of the tensor fold along an equality of lists. It is +an `eqToHom`, so it composes and cancels by `eqToHom` simp lemmas. -/ +def modListCast [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + {l₁ l₂ : List (Mod D A)} (h : l₁ = l₂) : + modList A l₁ ⟶ modList A l₂ := + eqToHom (congrArg (modList A) h) + +@[simp] lemma modListCast_rfl + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (l : List (Mod D A)) : + modListCast A (rfl : l = l) = 𝟙 _ := + rfl + +@[reassoc (attr := simp)] +lemma modListCast_comp [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + {l₁ l₂ l₃ : List (Mod D A)} (h : l₁ = l₂) + (h' : l₂ = l₃) : + modListCast A h ≫ modListCast A h' = modListCast A (h.trans h') := by + simp [modListCast] + +/-- Whiskering a list transport is a list transport. -/ +lemma modListCast_whiskerLeft + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (M : Mod D A) {l₁ l₂ : List (Mod D A)} + (h : l₁ = l₂) : + M.X ◁ modListCast A h = + modListCast A (congrArg (M :: ·) h) := by + subst h + simp only [modListCast_rfl, MonoidalCategory.whiskerLeft_id] + rfl + +end ModList + +/-! ## The slot relations + +A slot of the list is a decomposition `Xs = pre ++ M :: N :: post`. +Its relation object inserts `A` between the two factors of the +slot, nested exactly as the ambient fold, so that the legs below +are typed at the fold on the nose, with no transport. -/ + +section Slots + +/-- The relation object of a slot: the ambient fold with the monoid +inserted between the two factors of the slot. -/ +def modMultiMid [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] : + List (Mod D A) → Mod D A → Mod D A → + List (Mod D A) → D + | [], M, N, post => ((M.X ⊗ A) ⊗ N.X) ⊗ modList A post + | P :: rest, M, N, post => P.X ⊗ modMultiMid A rest M N post + +@[simp] lemma modMultiMid_nil + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (M N : Mod D A) (post : List (Mod D A)) : + modMultiMid A [] M N post = ((M.X ⊗ A) ⊗ N.X) ⊗ modList A post := + rfl + +@[simp] lemma modMultiMid_cons + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (P : Mod D A) (pre : List (Mod D A)) + (M N : Mod D A) (post : List (Mod D A)) : + modMultiMid A (P :: pre) M N post = + P.X ⊗ modMultiMid A pre M N post := + rfl + +/-- Assemble a window morphism on `(M.X ⊗ A) ⊗ N.X` into a relation +leg over a prefix: resolve the window, reassociate the second factor +onto the suffix, and whisker through the prefix. -/ +def modMultiLegOf [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (M N : Mod D A) (post : List (Mod D A)) + (w : (M.X ⊗ A) ⊗ N.X ⟶ M.X ⊗ N.X) : + (pre : List (Mod D A)) → + modMultiMid A pre M N post ⟶ modList A (pre ++ M :: N :: post) + | [] => (w ▷ modList A post) ≫ (α_ M.X N.X (modList A post)).hom + | P :: rest => P.X ◁ modMultiLegOf A M N post w rest + +@[simp] lemma modMultiLegOf_nil + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (M N : Mod D A) (post : List (Mod D A)) + (w : (M.X ⊗ A) ⊗ N.X ⟶ M.X ⊗ N.X) : + modMultiLegOf A M N post w [] = + (w ▷ modList A post) ≫ (α_ M.X N.X (modList A post)).hom := + rfl + +@[simp] lemma modMultiLegOf_cons + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (M N : Mod D A) + (post : List (Mod D A)) (w : (M.X ⊗ A) ⊗ N.X ⟶ M.X ⊗ N.X) + (P : Mod D A) (pre : List (Mod D A)) : + modMultiLegOf A M N post w (P :: pre) = + P.X ◁ modMultiLegOf A M N post w pre := + rfl + +/-- The first relation leg at a slot: act on the left factor of the +window through the braided right action. -/ +def modMultiLegM [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] + (pre : List (Mod D A)) (M N : Mod D A) + (post : List (Mod D A)) : + modMultiMid A pre M N post ⟶ modList A (pre ++ M :: N :: post) := + modMultiLegOf A M N post (modTensorLegM A M N) pre + +/-- The second relation leg at a slot: associate and act on the +right factor of the window. -/ +def modMultiLegN [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (pre : List (Mod D A)) (M N : Mod D A) + (post : List (Mod D A)) : + modMultiMid A pre M N post ⟶ modList A (pre ++ M :: N :: post) := + modMultiLegOf A M N post (modTensorLegN A M N) pre + +end Slots + +/-! ## Enumeration of the slots -/ + +section SlotList + +/-- An adjacent slot of a list of modules: a decomposition into a +prefix, two adjacent factors, and a suffix. -/ +structure ModSlot + [Category.{v} D] [MonoidalCategory D] + {A : D} [MonObj A] (Xs : List (Mod D A)) where + /-- The factors below the slot. -/ + pre : List (Mod D A) + /-- The first factor of the slot. -/ + fst : Mod D A + /-- The second factor of the slot. -/ + snd : Mod D A + /-- The factors above the slot. -/ + post : List (Mod D A) + /-- The decomposition of the ambient list. -/ + eq : Xs = pre ++ fst :: snd :: post + +variable {A} in +/-- Extend a slot by one factor below. -/ +def ModSlot.consSlot [Category.{v} D] [MonoidalCategory D] {A : D} [MonObj A] + (P : Mod D A) {Xs : List (Mod D A)} + (s : ModSlot Xs) : ModSlot (P :: Xs) := + ⟨P :: s.pre, s.fst, s.snd, s.post, congrArg (List.cons P) s.eq⟩ + +/-- The list of all adjacent slots of a list of modules. -/ +def modSlots [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] : + (Xs : List (Mod D A)) → List (ModSlot Xs) + | [] => [] + | [_] => [] + | M :: N :: post => + ⟨[], M, N, post, rfl⟩ :: + (modSlots A (N :: post)).map (ModSlot.consSlot M) + +@[simp] lemma modSlots_nil + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] : + modSlots A ([] : List (Mod D A)) = [] := + rfl + +@[simp] lemma modSlots_singleton + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (M : Mod D A) : + modSlots A [M] = [] := + rfl + +variable {A} in +/-- Extension by a factor preserves membership in the slot list. -/ +lemma ModSlot.consSlot_mem + [Category.{v} D] [MonoidalCategory D] {A : D} [MonObj A] + (P : Mod D A) : + ∀ {Ys : List (Mod D A)} (s : ModSlot Ys), + s ∈ modSlots A Ys → s.consSlot P ∈ modSlots A (P :: Ys) + | [], s, _ => absurd s.eq (by simp) + | _ :: _, _, hs => + List.mem_cons_of_mem _ (List.mem_map_of_mem hs) + +variable {A} in +/-- **The slot enumeration is complete**: every decomposition of the +list occurs among its slots. -/ +lemma mem_modSlots [Category.{v} D] [MonoidalCategory D] {A : D} [MonObj A] + {Xs : List (Mod D A)} (s : ModSlot Xs) : + s ∈ modSlots A Xs := by + obtain ⟨pre, M, N, post, rfl⟩ := s + induction pre with + | nil => exact List.mem_cons_self + | cons P pre ih => exact ModSlot.consSlot_mem P _ ih + +end SlotList + +/-! ## The relation pair of the multi-tensor -/ + +section ModMultiDefs + +variable {A} in +/-- The relation object of a slot, in slot form. -/ +abbrev ModSlot.mid [Category.{v} D] [MonoidalCategory D] {A : D} [MonObj A] + {Xs : List (Mod D A)} (s : ModSlot Xs) : D := + modMultiMid A s.pre s.fst s.snd s.post + +variable {A} in +/-- The first relation leg of a slot, transported to the ambient +list. -/ +def ModSlot.legM [Category.{v} D] [MonoidalCategory D] {A : D} [MonObj A] + [BraidedCategory D] + {Xs : List (Mod D A)} (s : ModSlot Xs) : + s.mid ⟶ modList A Xs := + modMultiLegM A s.pre s.fst s.snd s.post ≫ modListCast A s.eq.symm + +variable {A} in +/-- The second relation leg of a slot, transported to the ambient +list. -/ +def ModSlot.legN [Category.{v} D] [MonoidalCategory D] {A : D} [MonObj A] + {Xs : List (Mod D A)} (s : ModSlot Xs) : + s.mid ⟶ modList A Xs := + modMultiLegN A s.pre s.fst s.snd s.post ≫ modListCast A s.eq.symm + +/-- The source of the relation pair: the biproduct of the relation +objects over all adjacent slots. An abbreviation, so that the +biproduct API applies to the legs without unfolding. -/ +noncomputable abbrev modMultiSrc + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] [Preadditive D] + [HasFiniteBiproducts D] + (Xs : List (Mod D A)) : D := + ⨁ fun i : Fin (modSlots A Xs).length => (modSlots A Xs)[i.1].mid + +/-- The first leg of the relation pair, assembled over all slots. -/ +noncomputable def modMultiLegFst + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + (Xs : List (Mod D A)) : + modMultiSrc A Xs ⟶ modList A Xs := + biproduct.desc fun i => (modSlots A Xs)[i.1].legM + +/-- The second leg of the relation pair, assembled over all slots. -/ +noncomputable def modMultiLegSnd + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] [Preadditive D] + [HasFiniteBiproducts D] + (Xs : List (Mod D A)) : + modMultiSrc A Xs ⟶ modList A Xs := + biproduct.desc fun i => (modSlots A Xs)[i.1].legN + +end ModMultiDefs + +/-! ## The multi-tensor and its universal property -/ + +section ModMulti + +/-- **The multi-tensor of a list of modules** over `A`: the +coequalizer of the wide relation pair, identifying +`(x·c) ⊗ y ~ x ⊗ (c·y)` in every adjacent slot simultaneously. No +binary module tensor product and no associativity enter. -/ +noncomputable def modMulti + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (Xs : List (Mod D A)) : D := + coequalizer (modMultiLegFst A Xs) (modMultiLegSnd A Xs) + +/-- The projection of the ambient fold onto the multi-tensor. -/ +noncomputable def modMultiπ + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (Xs : List (Mod D A)) : + modList A Xs ⟶ modMulti A Xs := + coequalizer.π _ _ + +instance [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (Xs : List (Mod D A)) : Epi (modMultiπ A Xs) := + inferInstanceAs (Epi (coequalizer.π _ _)) + +/-- The two assembled legs agree after the projection. -/ +@[reassoc] +lemma modMulti_condition + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (Xs : List (Mod D A)) : + modMultiLegFst A Xs ≫ modMultiπ A Xs = + modMultiLegSnd A Xs ≫ modMultiπ A Xs := + coequalizer.condition _ _ + +/-- **The slot relation in the multi-tensor**: at every +decomposition `Xs = pre ++ M :: N :: post` the two slot legs agree +after the projection. -/ +@[reassoc] +lemma modMulti_rel [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + {Xs : List (Mod D A)} (pre : List (Mod D A)) + (M N : Mod D A) (post : List (Mod D A)) + (h : Xs = pre ++ M :: N :: post) : + modMultiLegM A pre M N post ≫ modListCast A h.symm ≫ + modMultiπ A Xs = + modMultiLegN A pre M N post ≫ modListCast A h.symm ≫ + modMultiπ A Xs := by + have hmem : (⟨pre, M, N, post, h⟩ : ModSlot Xs) ∈ modSlots A Xs := + mem_modSlots _ + obtain ⟨i, hi, hget⟩ := List.getElem_of_mem hmem + have h2 : biproduct.ι + (fun j : Fin (modSlots A Xs).length => (modSlots A Xs)[j.1].mid) + ⟨i, hi⟩ ≫ modMultiLegFst A Xs ≫ modMultiπ A Xs = + biproduct.ι + (fun j : Fin (modSlots A Xs).length => (modSlots A Xs)[j.1].mid) + ⟨i, hi⟩ ≫ modMultiLegSnd A Xs ≫ modMultiπ A Xs := by + rw [modMulti_condition] + simp only [modMultiLegFst, modMultiLegSnd, biproduct.ι_desc_assoc] + at h2 + rw [hget] at h2 + simpa [ModSlot.legM, ModSlot.legN] using h2 + +/-- Morphisms out of the multi-tensor are determined by their +composite with the projection. -/ +lemma modMulti_hom_ext [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + {Xs : List (Mod D A)} {W : D} + {k l : modMulti A Xs ⟶ W} + (h : modMultiπ A Xs ≫ k = modMultiπ A Xs ≫ l) : k = l := + coequalizer.hom_ext h + +/-- Descend a morphism that coequalizes every slot relation to the +multi-tensor. -/ +noncomputable def modMultiDesc + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + {Xs : List (Mod D A)} {W : D} + (k : modList A Xs ⟶ W) + (h : ∀ (pre : List (Mod D A)) (M N : Mod D A) + (post : List (Mod D A)) (hd : Xs = pre ++ M :: N :: post), + modMultiLegM A pre M N post ≫ modListCast A hd.symm ≫ k = + modMultiLegN A pre M N post ≫ modListCast A hd.symm ≫ k) : + modMulti A Xs ⟶ W := + coequalizer.desc k (by + apply biproduct.hom_ext' + intro i + simp only [modMultiLegFst, modMultiLegSnd, biproduct.ι_desc_assoc] + have hs := h (modSlots A Xs)[i.1].pre (modSlots A Xs)[i.1].fst + (modSlots A Xs)[i.1].snd (modSlots A Xs)[i.1].post + (modSlots A Xs)[i.1].eq + simpa [ModSlot.legM, ModSlot.legN] using hs) + +/-- The descent factors the given morphism through the +projection. -/ +@[reassoc (attr := simp)] +lemma modMultiπ_desc [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + {Xs : List (Mod D A)} {W : D} + (k : modList A Xs ⟶ W) + (h : ∀ (pre : List (Mod D A)) (M N : Mod D A) + (post : List (Mod D A)) (hd : Xs = pre ++ M :: N :: post), + modMultiLegM A pre M N post ≫ modListCast A hd.symm ≫ k = + modMultiLegN A pre M N post ≫ modListCast A hd.symm ≫ k) : + modMultiπ A Xs ≫ modMultiDesc A k h = k := + coequalizer.π_desc _ _ + +/-! ### The empty and singleton multi-tensors + +Below two factors there are no adjacent slots: the relation source +is the empty biproduct, the legs agree, and the projection is an +isomorphism. -/ + +/-- On a slot-free list the projection is an isomorphism. -/ +noncomputable def modMultiTriv + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + {Xs : List (Mod D A)} + (h : modSlots A Xs = []) : modMulti A Xs ≅ modList A Xs where + hom := modMultiDesc A (𝟙 _) (fun pre M N post hd => + absurd (mem_modSlots ⟨pre, M, N, post, hd⟩) (by simp [h])) + inv := modMultiπ A Xs + hom_inv_id := modMulti_hom_ext A (by + rw [modMultiπ_desc_assoc, Category.id_comp, Category.comp_id]) + inv_hom_id := modMultiπ_desc A _ _ + +/-- **The empty multi-tensor is the monoidal unit** of the ambient +category. With this presentation the empty fold is `𝟙_ D`, not the +regular module: consumers wanting `A` as the empty product — the +unit of the module category — should treat the empty list as a +separate case. -/ +noncomputable def modMultiNil + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] : modMulti A ([] : List (Mod D A)) ≅ 𝟙_ D := + modMultiTriv A (modSlots_nil A) + +/-- **The singleton multi-tensor is the module.** -/ +noncomputable def modMultiSingle + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (X : Mod D A) : + modMulti A [X] ≅ X.X := + modMultiTriv A (modSlots_singleton A X) ≪≫ ρ_ X.X + +end ModMulti + +/-! ## Comparison with the binary module tensor product + +For a two-element list the wide relation pair has a single slot, +whose window legs are exactly the parallel pair of `ModTensor.lean`; +the two coequalizer presentations agree, up to the right unitor +absorbing the unit seed of the fold. -/ + +section Pair + +/-- The only slot of a two-element list is the full decomposition. -/ +lemma pair_decomp [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + {X Y M N : Mod D A} {pre post : List (Mod D A)} + (h : [X, Y] = pre ++ M :: N :: post) : + pre = [] ∧ X = M ∧ Y = N ∧ post = [] := by + rcases pre with _ | ⟨P, pre⟩ + · injection h with h1 h + injection h with h2 h3 + exact ⟨rfl, h1, h2, h3.symm⟩ + · rcases pre with _ | ⟨Q, pre⟩ <;> simp at h + +/-- The resolution of the two-element fold onto the plain tensor +product: absorb the unit seed. A bridge morphism with a +`modList`-typed source, so that statements through it stay +type-correct at low transparency. -/ +def pairResolve + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : Mod D A) + (Y : Mod D A) : modList A [X, Y] ⟶ X.X ⊗ Y.X := + X.X ◁ (ρ_ Y.X).hom + +/-- The inverse resolution: reinstate the unit seed. -/ +def pairResolveInv + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : Mod D A) + (Y : Mod D A) : X.X ⊗ Y.X ⟶ modList A [X, Y] := + X.X ◁ (ρ_ Y.X).inv + +@[reassoc (attr := simp)] +lemma pairResolve_inv + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : Mod D A) + (Y : Mod D A) : + pairResolve A X Y ≫ pairResolveInv A X Y = 𝟙 _ := by + change (X.X ◁ (ρ_ Y.X).hom) ≫ (X.X ◁ (ρ_ Y.X).inv) = + 𝟙 (X.X ⊗ (Y.X ⊗ 𝟙_ D)) + rw [← MonoidalCategory.whiskerLeft_comp, Iso.hom_inv_id, + MonoidalCategory.whiskerLeft_id] + +@[reassoc (attr := simp)] +lemma pairResolveInv_resolve + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : Mod D A) + (Y : Mod D A) : + pairResolveInv A X Y ≫ pairResolve A X Y = 𝟙 _ := by + change (X.X ◁ (ρ_ Y.X).inv) ≫ (X.X ◁ (ρ_ Y.X).hom) = + 𝟙 (X.X ⊗ Y.X) + rw [← MonoidalCategory.whiskerLeft_comp, Iso.inv_hom_id, + MonoidalCategory.whiskerLeft_id] + +/-- The window seed of the pair: the right unitor of the single +relation object, retyped at `modMultiMid`. -/ +def pairSeed + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : Mod D A) + (Y : Mod D A) : modMultiMid A [] X Y [] ⟶ (X.X ⊗ A) ⊗ Y.X := + (ρ_ ((X.X ⊗ A) ⊗ Y.X)).hom + +/-- The inverse window seed of the pair. -/ +def pairSeedInv + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : Mod D A) + (Y : Mod D A) : (X.X ⊗ A) ⊗ Y.X ⟶ modMultiMid A [] X Y [] := + (ρ_ ((X.X ⊗ A) ⊗ Y.X)).inv + +/-- The single relation leg of the pair against the resolution: the +unit seed is absorbed and the window morphism remains. -/ +@[reassoc] +lemma modMultiLeg_pair_resolve + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : Mod D A) + (Y : Mod D A) + (w : (X.X ⊗ A) ⊗ Y.X ⟶ X.X ⊗ Y.X) + (h : ([] ++ X :: Y :: [] : List (Mod D A)) = [X, Y]) : + modMultiLegOf A X Y [] w [] ≫ modListCast A h ≫ + pairResolve A X Y = + pairSeed A X Y ≫ w := by + have hcoh : (α_ X.X Y.X (𝟙_ D)).hom ≫ (X.X ◁ (ρ_ Y.X).hom) = + (ρ_ (X.X ⊗ Y.X)).hom := by monoidal + change ((w ▷ 𝟙_ D) ≫ (α_ X.X Y.X (𝟙_ D)).hom) ≫ + 𝟙 (X.X ⊗ (Y.X ⊗ 𝟙_ D)) ≫ (X.X ◁ (ρ_ Y.X).hom) = + (ρ_ ((X.X ⊗ A) ⊗ Y.X)).hom ≫ w + rw [Category.id_comp, Category.assoc, hcoh, rightUnitor_naturality] + +/-- A window morphism against the inverse resolution, in leg +form. -/ +@[reassoc] +lemma modMultiLeg_pair_resolveInv + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : Mod D A) + (Y : Mod D A) + (w : (X.X ⊗ A) ⊗ Y.X ⟶ X.X ⊗ Y.X) + (h : ([] ++ X :: Y :: [] : List (Mod D A)) = [X, Y]) : + w ≫ pairResolveInv A X Y = + pairSeedInv A X Y ≫ modMultiLegOf A X Y [] w [] ≫ + modListCast A h := by + have hcoh : (ρ_ (X.X ⊗ Y.X)).inv ≫ (α_ X.X Y.X (𝟙_ D)).hom = + X.X ◁ (ρ_ Y.X).inv := by monoidal + change w ≫ (X.X ◁ (ρ_ Y.X).inv) = + (ρ_ ((X.X ⊗ A) ⊗ Y.X)).inv ≫ + ((w ▷ 𝟙_ D) ≫ (α_ X.X Y.X (𝟙_ D)).hom) ≫ + 𝟙 (X.X ⊗ (Y.X ⊗ 𝟙_ D)) + rw [Category.comp_id, ← rightUnitor_inv_naturality_assoc, hcoh] + +end Pair + +section PairIso + +/-- Comparison with the binary tensor product: the forward +direction, descending the binary projection. -/ +noncomputable def modMultiPairHom + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] (X : Mod D A) (Y : Mod D A) : + modMulti A [X, Y] ⟶ modTensor A X Y := + modMultiDesc A (pairResolve A X Y ≫ modTensorπ A X Y) + (by + intro pre M N post hd + obtain ⟨rfl, h2, h3, rfl⟩ := pair_decomp A hd + subst h2 + subst h3 + rw [modMultiLegM, modMultiLegN, + modMultiLeg_pair_resolve_assoc A X Y _ hd.symm, + modMultiLeg_pair_resolve_assoc A X Y _ hd.symm, + modTensor_condition]) + +/-- Defining equation of the forward comparison. -/ +@[reassoc (attr := simp)] +lemma modMultiπ_pairMod [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] (X : Mod D A) (Y : Mod D A) : + modMultiπ A [X, Y] ≫ modMultiPairHom A X Y = + pairResolve A X Y ≫ modTensorπ A X Y := + modMultiπ_desc A _ _ + +/-- Comparison with the binary tensor product: the backward +direction, descending the wide projection. -/ +noncomputable def modMultiPairInv + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] (X : Mod D A) (Y : Mod D A) : + modTensor A X Y ⟶ modMulti A [X, Y] := + modTensorDesc A X Y (pairResolveInv A X Y ≫ modMultiπ A [X, Y]) + (by + have hrel := modMulti_rel A [] X Y [] + (rfl : [X, Y] = [] ++ X :: Y :: []) + rw [modMultiLegM, modMultiLegN] at hrel + rw [modMultiLeg_pair_resolveInv_assoc A X Y _ + (Eq.symm (rfl : [X, Y] = [] ++ X :: Y :: [])), + modMultiLeg_pair_resolveInv_assoc A X Y _ + (Eq.symm (rfl : [X, Y] = [] ++ X :: Y :: [])), + hrel]) + +/-- Defining equation of the backward comparison. -/ +@[reassoc (attr := simp)] +lemma modTensorπ_pairInv + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] (X : Mod D A) (Y : Mod D A) : + modTensorπ A X Y ≫ modMultiPairInv A X Y = + pairResolveInv A X Y ≫ modMultiπ A [X, Y] := + modTensorπ_desc A X Y _ _ + +/-- **The two-element multi-tensor is the binary module tensor +product**: the one-slot wide presentation and the parallel-pair +presentation coequalize the same relations. -/ +noncomputable def modMultiPair + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] (X : Mod D A) (Y : Mod D A) : + modMulti A [X, Y] ≅ modTensor A X Y where + hom := modMultiPairHom A X Y + inv := modMultiPairInv A X Y + hom_inv_id := by + apply modMulti_hom_ext + rw [modMultiπ_pairMod_assoc, modTensorπ_pairInv, + pairResolve_inv_assoc, Category.comp_id] + inv_hom_id := by + apply modTensor_hom_ext + rw [modTensorπ_pairInv_assoc, modMultiπ_pairMod, + pairResolveInv_resolve_assoc, Category.comp_id] + +end PairIso + +/-! ## Concatenation of folds + +The fold of a concatenated list against the tensor product of the +two folds, with the bridges that carry a relation slot of one block +into the concatenated list. Casts are quantified, as in the slot +relations, so consumers never meet a transported proof they cannot +name. -/ + +section Concat + +/-- Concatenation of tensor folds: the two-block fold reassociates +onto the fold of the concatenated list. -/ +def modListConcat [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] : + (Xs Ys : List (Mod D A)) → + (modList A Xs ⊗ modList A Ys ≅ modList A (Xs ++ Ys)) + | [], Ys => λ_ (modList A Ys) + | P :: Xs, Ys => + α_ P.X (modList A Xs) (modList A Ys) ≪≫ + whiskerLeftIso P.X (modListConcat A Xs Ys) + +/-- A morphism whiskered under a cons prefix passes the +concatenation: the step case of every prefix induction below. -/ +lemma modListConcat_cons_whisker + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (P : Mod D A) {S : D} + {T Ys : List (Mod D A)} (u : S ⟶ modList A T) : + ((P.X ◁ u) ▷ modList A Ys) ≫ (modListConcat A (P :: T) Ys).hom = + (α_ P.X S (modList A Ys)).hom ≫ + (P.X ◁ ((u ▷ modList A Ys) ≫ (modListConcat A T Ys).hom)) := by + change ((P.X ◁ u) ▷ modList A Ys) ≫ + ((α_ P.X (modList A T) (modList A Ys)).hom ≫ + (P.X ◁ (modListConcat A T Ys).hom)) = + (α_ P.X S (modList A Ys)).hom ≫ + (P.X ◁ ((u ▷ modList A Ys) ≫ (modListConcat A T Ys).hom)) + rw [MonoidalCategory.whiskerLeft_comp, + associator_naturality_middle_assoc] + +/-- A morphism whiskered on the right of a cons prefix passes the +concatenation. -/ +lemma modListConcat_whiskerLeft_cons + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (P : Mod D A) + (Xs : List (Mod D A)) {S : D} {T : List (Mod D A)} + (u : S ⟶ modList A T) : + (modList A (P :: Xs) ◁ u) ≫ (modListConcat A (P :: Xs) T).hom = + (α_ P.X (modList A Xs) S).hom ≫ + (P.X ◁ ((modList A Xs ◁ u) ≫ + (modListConcat A Xs T).hom)) := by + change ((P.X ⊗ modList A Xs) ◁ u) ≫ + ((α_ P.X (modList A Xs) (modList A T)).hom ≫ + (P.X ◁ (modListConcat A Xs T).hom)) = + (α_ P.X (modList A Xs) S).hom ≫ + (P.X ◁ ((modList A Xs ◁ u) ≫ (modListConcat A Xs T).hom)) + rw [MonoidalCategory.whiskerLeft_comp, + associator_naturality_right_assoc] + +/-- A transport in the second block passes the concatenation. -/ +@[reassoc] +lemma modListConcat_cast_right + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (Xs : List (Mod D A)) + {l₁ l₂ : List (Mod D A)} (h : l₁ = l₂) : + (modList A Xs ◁ modListCast A h) ≫ + (modListConcat A Xs l₂).hom = + (modListConcat A Xs l₁).hom ≫ + modListCast A (congrArg (Xs ++ ·) h) := by + subst h + simp + +/-- The relation object of a slot, concatenated on the right: the +suffix grows by the second block. -/ +def modMultiMidConcat [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (M N : Mod D A) (post Ys : List (Mod D A)) : + (pre : List (Mod D A)) → + (modMultiMid A pre M N post ⊗ modList A Ys ⟶ + modMultiMid A pre M N (post ++ Ys)) + | [] => + (α_ ((M.X ⊗ A) ⊗ N.X) (modList A post) (modList A Ys)).hom ≫ + (((M.X ⊗ A) ⊗ N.X) ◁ (modListConcat A post Ys).hom) + | P :: rest => + (α_ P.X (modMultiMid A rest M N post) (modList A Ys)).hom ≫ + (P.X ◁ modMultiMidConcat A M N post Ys rest) + +/-- The base of the right leg-concatenation: the window against the +concatenation, by the pentagon. -/ +lemma modMultiLegOf_concat_nil + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (M N : Mod D A) + (post Ys : List (Mod D A)) + (w : (M.X ⊗ A) ⊗ N.X ⟶ M.X ⊗ N.X) : + (modMultiLegOf A M N post w [] ▷ modList A Ys) ≫ + (modListConcat A (M :: N :: post) Ys).hom = + modMultiMidConcat A M N post Ys [] ≫ + modMultiLegOf A M N (post ++ Ys) w [] := by + change (((w ▷ modList A post) ≫ + (α_ M.X N.X (modList A post)).hom) ▷ modList A Ys) ≫ + ((α_ M.X (N.X ⊗ modList A post) (modList A Ys)).hom ≫ + (M.X ◁ ((α_ N.X (modList A post) (modList A Ys)).hom ≫ + (N.X ◁ (modListConcat A post Ys).hom)))) = + ((α_ ((M.X ⊗ A) ⊗ N.X) (modList A post) (modList A Ys)).hom ≫ + (((M.X ⊗ A) ⊗ N.X) ◁ (modListConcat A post Ys).hom)) ≫ + ((w ▷ modList A (post ++ Ys)) ≫ + (α_ M.X N.X (modList A (post ++ Ys))).hom) + simp only [MonoidalCategory.comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + conv_rhs => rw [whisker_exchange_assoc, + ← associator_naturality_left_assoc, associator_naturality_right] + rw [pentagon_assoc] + +/-- **The right leg-concatenation**: a slot leg of the first block, +whiskered by the second block, is the slot leg of the concatenated +list at the widened suffix. -/ +@[reassoc] +lemma modMultiLegOf_concat + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (M N : Mod D A) (post Ys : List (Mod D A)) + (w : (M.X ⊗ A) ⊗ N.X ⟶ M.X ⊗ N.X) : + ∀ (pre : List (Mod D A)) + (h : pre ++ M :: N :: (post ++ Ys) = + (pre ++ M :: N :: post) ++ Ys), + (modMultiLegOf A M N post w pre ▷ modList A Ys) ≫ + (modListConcat A (pre ++ M :: N :: post) Ys).hom = + modMultiMidConcat A M N post Ys pre ≫ + modMultiLegOf A M N (post ++ Ys) w pre ≫ modListCast A h + | [], h => by + simp only [List.nil_append, List.cons_append, modListCast_rfl, + Category.comp_id] + exact modMultiLegOf_concat_nil A M N post Ys w + | P :: rest, h => by + change ((P.X ◁ modMultiLegOf A M N post w rest) ▷ modList A Ys) ≫ + (modListConcat A (P :: (rest ++ M :: N :: post)) Ys).hom = + ((α_ P.X (modMultiMid A rest M N post) (modList A Ys)).hom ≫ + (P.X ◁ modMultiMidConcat A M N post Ys rest)) ≫ + (P.X ◁ modMultiLegOf A M N (post ++ Ys) w rest) ≫ + modListCast A h + rw [modListConcat_cons_whisker A P, + modMultiLegOf_concat A M N post Ys w rest (by simp)] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [modListCast_whiskerLeft] + rfl + +/-- The relation object of a slot, concatenated on the left: the +prefix grows by the first block. -/ +def modMultiMidConcatL [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (pre : List (Mod D A)) (M N : Mod D A) + (post : List (Mod D A)) : + (Xs : List (Mod D A)) → + (modList A Xs ⊗ modMultiMid A pre M N post ⟶ + modMultiMid A (Xs ++ pre) M N post) + | [] => (λ_ (modMultiMid A pre M N post)).hom + | P :: rest => + (α_ P.X (modList A rest) (modMultiMid A pre M N post)).hom ≫ + (P.X ◁ modMultiMidConcatL A pre M N post rest) + +/-- **The left leg-concatenation**: a slot leg of the second block, +whiskered by the first block, is the slot leg of the concatenated +list at the widened prefix. -/ +@[reassoc] +lemma modMultiLegOf_concatL + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (pre : List (Mod D A)) (M N : Mod D A) + (post : List (Mod D A)) (w : (M.X ⊗ A) ⊗ N.X ⟶ M.X ⊗ N.X) : + ∀ (Xs : List (Mod D A)) + (h : (Xs ++ pre) ++ M :: N :: post = + Xs ++ (pre ++ M :: N :: post)), + (modList A Xs ◁ modMultiLegOf A M N post w pre) ≫ + (modListConcat A Xs (pre ++ M :: N :: post)).hom = + modMultiMidConcatL A pre M N post Xs ≫ + modMultiLegOf A M N post w (Xs ++ pre) ≫ modListCast A h + | [], h => by + change ((𝟙_ D) ◁ modMultiLegOf A M N post w pre) ≫ + (λ_ (modList A (pre ++ M :: N :: post))).hom = + (λ_ (modMultiMid A pre M N post)).hom ≫ + modMultiLegOf A M N post w pre ≫ + 𝟙 (modList A (pre ++ M :: N :: post)) + rw [Category.comp_id, leftUnitor_naturality] + | P :: rest, h => by + rw [modListConcat_whiskerLeft_cons A P rest, + modMultiLegOf_concatL A pre M N post w rest (by simp)] + change (α_ P.X (modList A rest) (modMultiMid A pre M N post)).hom ≫ + (P.X ◁ (modMultiMidConcatL A pre M N post rest ≫ + modMultiLegOf A M N post w (rest ++ pre) ≫ + modListCast A (show (rest ++ pre) ++ M :: N :: post = + rest ++ (pre ++ M :: N :: post) by simp))) = + ((α_ P.X (modList A rest) (modMultiMid A pre M N post)).hom ≫ + (P.X ◁ modMultiMidConcatL A pre M N post rest)) ≫ + ((P.X ◁ modMultiLegOf A M N post w (rest ++ pre)) ≫ + modListCast A h) + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc, + modListCast_whiskerLeft] + rfl + +end Concat + +/-! ## Whiskered descent + +Morphisms out of a whiskered multi-tensor, by descent along the +whiskered projection. The relation source is a biproduct, so the +whiskered relation condition reduces to the slots through the +distributors of the monoidal preadditive structure. -/ + +section Whisker + +/-- Maps out of a right-whiskered biproduct are determined by the +whiskered injections. -/ +lemma biproduct_whiskerRight_hom_ext + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] + {J : Type} [Finite J] + (f : J → D) (P : D) {W : D} {u v : (⨁ f) ⊗ P ⟶ W} + (h : ∀ j, (biproduct.ι f j ▷ P) ≫ u = + (biproduct.ι f j ▷ P) ≫ v) : + u = v := by + classical + let := Fintype.ofFinite J + apply (cancel_epi (rightDistributor f P).inv).mp + apply biproduct.hom_ext' + intro j + rw [← Category.assoc, ← Category.assoc, + biproduct_ι_comp_rightDistributor_inv] + exact h j + +/-- Maps out of a left-whiskered biproduct are determined by the +whiskered injections. -/ +lemma biproduct_whiskerLeft_hom_ext + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] + {J : Type} [Finite J] + (f : J → D) (P : D) {W : D} {u v : P ⊗ (⨁ f) ⟶ W} + (h : ∀ j, (P ◁ biproduct.ι f j) ≫ u = + (P ◁ biproduct.ι f j) ≫ v) : + u = v := by + classical + let := Fintype.ofFinite J + apply (cancel_epi (leftDistributor P f).inv).mp + apply biproduct.hom_ext' + intro j + rw [← Category.assoc, ← Category.assoc, + biproduct_ι_comp_leftDistributor_inv] + exact h j + +section WhiskerRight + +/-- Whiskering the multi-tensor coequalizer by `tensorRight P` +yields a colimit cofork. -/ +noncomputable def modMultiWhiskerRIsColimit + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorRight Y)] + (Xs : List (Mod D A)) + (P : D) : + IsColimit (Cofork.ofπ (modMultiπ A Xs ▷ P) + (by rw [← MonoidalCategory.comp_whiskerRight, + modMulti_condition, MonoidalCategory.comp_whiskerRight]) : + Cofork (modMultiLegFst A Xs ▷ P) (modMultiLegSnd A Xs ▷ P)) := + isColimitOfHasCoequalizerOfPreservesColimit + (MonoidalCategory.tensorRight P) _ _ + +/-- Morphisms out of a right-whiskered multi-tensor are determined +by their composite with the whiskered projection. -/ +lemma modMulti_whiskerR_hom_ext + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorRight Y)] + (Xs : List (Mod D A)) (P : D) + {W : D} {k l : modMulti A Xs ⊗ P ⟶ W} + (h : (modMultiπ A Xs ▷ P) ≫ k = (modMultiπ A Xs ▷ P) ≫ l) : + k = l := + Cofork.IsColimit.hom_ext (modMultiWhiskerRIsColimit A Xs P) h + +/-- Descend a morphism coequalizing every right-whiskered slot +relation along the right-whiskered projection. -/ +noncomputable def modMultiWhiskerRDesc + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [MonoidalPreadditive D] + [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorRight Y)] + (Xs : List (Mod D A)) (P : D) + {W : D} (k : modList A Xs ⊗ P ⟶ W) + (h : ∀ (pre : List (Mod D A)) (M N : Mod D A) + (post : List (Mod D A)) (hd : Xs = pre ++ M :: N :: post), + ((modMultiLegM A pre M N post ≫ modListCast A hd.symm) ▷ P) ≫ + k = + ((modMultiLegN A pre M N post ≫ modListCast A hd.symm) ▷ P) ≫ + k) : + modMulti A Xs ⊗ P ⟶ W := + Cofork.IsColimit.desc (modMultiWhiskerRIsColimit A Xs P) k + (by + apply biproduct_whiskerRight_hom_ext + intro j + rw [← Category.assoc, ← MonoidalCategory.comp_whiskerRight, + ← Category.assoc, ← MonoidalCategory.comp_whiskerRight] + simp only [modMultiLegFst, modMultiLegSnd, biproduct.ι_desc] + have hs := h (modSlots A Xs)[j.1].pre (modSlots A Xs)[j.1].fst + (modSlots A Xs)[j.1].snd (modSlots A Xs)[j.1].post + (modSlots A Xs)[j.1].eq + simpa [ModSlot.legM, ModSlot.legN] using hs) + +/-- The right-whiskered descent factors the given morphism through +the whiskered projection. -/ +@[reassoc (attr := simp)] +lemma whiskerRight_modMultiπ_whiskerRDesc + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [MonoidalPreadditive D] + [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorRight Y)] + (Xs : List (Mod D A)) + (P : D) {W : D} (k : modList A Xs ⊗ P ⟶ W) + (h : ∀ (pre : List (Mod D A)) (M N : Mod D A) + (post : List (Mod D A)) (hd : Xs = pre ++ M :: N :: post), + ((modMultiLegM A pre M N post ≫ modListCast A hd.symm) ▷ P) ≫ + k = + ((modMultiLegN A pre M N post ≫ modListCast A hd.symm) ▷ P) ≫ + k) : + (modMultiπ A Xs ▷ P) ≫ modMultiWhiskerRDesc A Xs P k h = k := + Cofork.IsColimit.π_desc' (modMultiWhiskerRIsColimit A Xs P) k _ + +end WhiskerRight + +section WhiskerLeft + +/-- Whiskering the multi-tensor coequalizer by `tensorLeft P` +yields a colimit cofork. -/ +noncomputable def modMultiWhiskerLIsColimit + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorLeft Y)] + (Xs : List (Mod D A)) + (P : D) : + IsColimit (Cofork.ofπ (P ◁ modMultiπ A Xs) + (by rw [← MonoidalCategory.whiskerLeft_comp, + modMulti_condition, MonoidalCategory.whiskerLeft_comp]) : + Cofork (P ◁ modMultiLegFst A Xs) (P ◁ modMultiLegSnd A Xs)) := + isColimitOfHasCoequalizerOfPreservesColimit + (MonoidalCategory.tensorLeft P) _ _ + +/-- Morphisms out of a left-whiskered multi-tensor are determined +by their composite with the whiskered projection. -/ +lemma modMulti_whiskerL_hom_ext + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorLeft Y)] + (Xs : List (Mod D A)) (P : D) + {W : D} {k l : P ⊗ modMulti A Xs ⟶ W} + (h : (P ◁ modMultiπ A Xs) ≫ k = (P ◁ modMultiπ A Xs) ≫ l) : + k = l := + Cofork.IsColimit.hom_ext (modMultiWhiskerLIsColimit A Xs P) h + +/-- Descend a morphism coequalizing every left-whiskered slot +relation along the left-whiskered projection. -/ +noncomputable def modMultiWhiskerLDesc + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [MonoidalPreadditive D] + [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorLeft Y)] + (Xs : List (Mod D A)) (P : D) + {W : D} (k : P ⊗ modList A Xs ⟶ W) + (h : ∀ (pre : List (Mod D A)) (M N : Mod D A) + (post : List (Mod D A)) (hd : Xs = pre ++ M :: N :: post), + (P ◁ (modMultiLegM A pre M N post ≫ modListCast A hd.symm)) ≫ + k = + (P ◁ (modMultiLegN A pre M N post ≫ modListCast A hd.symm)) ≫ + k) : + P ⊗ modMulti A Xs ⟶ W := + Cofork.IsColimit.desc (modMultiWhiskerLIsColimit A Xs P) k + (by + apply biproduct_whiskerLeft_hom_ext + intro j + rw [← Category.assoc, ← MonoidalCategory.whiskerLeft_comp, + ← Category.assoc, ← MonoidalCategory.whiskerLeft_comp] + simp only [modMultiLegFst, modMultiLegSnd, biproduct.ι_desc] + have hs := h (modSlots A Xs)[j.1].pre (modSlots A Xs)[j.1].fst + (modSlots A Xs)[j.1].snd (modSlots A Xs)[j.1].post + (modSlots A Xs)[j.1].eq + simpa [ModSlot.legM, ModSlot.legN] using hs) + +/-- The left-whiskered descent factors the given morphism through +the whiskered projection. -/ +@[reassoc (attr := simp)] +lemma whiskerLeft_modMultiπ_whiskerLDesc + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [MonoidalPreadditive D] + [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorLeft Y)] + (Xs : List (Mod D A)) + (P : D) {W : D} (k : P ⊗ modList A Xs ⟶ W) + (h : ∀ (pre : List (Mod D A)) (M N : Mod D A) + (post : List (Mod D A)) (hd : Xs = pre ++ M :: N :: post), + (P ◁ (modMultiLegM A pre M N post ≫ modListCast A hd.symm)) ≫ + k = + (P ◁ (modMultiLegN A pre M N post ≫ modListCast A hd.symm)) ≫ + k) : + (P ◁ modMultiπ A Xs) ≫ modMultiWhiskerLDesc A Xs P k h = k := + Cofork.IsColimit.π_desc' (modMultiWhiskerLIsColimit A Xs P) k _ + +end WhiskerLeft + +end Whisker + +/-! ## The concatenation map + +The projection of the concatenated list descends through the tensor +product of the two multi-tensors, one block at a time: first the +relations of the first block through the right-whiskered +coequalizer, then those of the second block through the +left-whiskered coequalizer. -/ + +section ConcatMap + +/-- First stage of the concatenation: the relations of the first +block descend, the second block still at the fold. -/ +noncomputable def modMultiConcatFst + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [MonoidalPreadditive D] + [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorRight Y)] + (Xs Ys : List (Mod D A)) : + modMulti A Xs ⊗ modList A Ys ⟶ modMulti A (Xs ++ Ys) := + modMultiWhiskerRDesc A Xs (modList A Ys) + ((modListConcat A Xs Ys).hom ≫ modMultiπ A (Xs ++ Ys)) + (by + intro pre M N post hd + subst hd + simp only [modListCast_rfl, Category.comp_id] + rw [modMultiLegM, modMultiLegN, + modMultiLegOf_concat_assoc A M N post Ys _ pre (by simp), + modMultiLegOf_concat_assoc A M N post Ys _ pre (by simp)] + have hrel := modMulti_rel A pre M N (post ++ Ys) + (show (pre ++ M :: N :: post) ++ Ys = + pre ++ M :: N :: (post ++ Ys) by simp) + rw [modMultiLegM, modMultiLegN] at hrel + exact congrArg (modMultiMidConcat A M N post Ys pre ≫ ·) hrel) + +/-- Defining equation of the first stage. -/ +@[reassoc (attr := simp)] +lemma whiskerRight_modMultiπ_concatFst + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [MonoidalPreadditive D] + [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorRight Y)] + (Xs Ys : List (Mod D A)) : + (modMultiπ A Xs ▷ modList A Ys) ≫ modMultiConcatFst A Xs Ys = + (modListConcat A Xs Ys).hom ≫ modMultiπ A (Xs ++ Ys) := + whiskerRight_modMultiπ_whiskerRDesc A Xs _ _ _ + +/-- **The concatenation map**: the multi-tensor of a concatenated +list receives the tensor product of the two multi-tensors. -/ +noncomputable def modMultiConcat + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [MonoidalPreadditive D] + [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorRight Y)] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorLeft Y)] + (Xs Ys : List (Mod D A)) : + modMulti A Xs ⊗ modMulti A Ys ⟶ modMulti A (Xs ++ Ys) := + modMultiWhiskerLDesc A Ys (modMulti A Xs) + (modMultiConcatFst A Xs Ys) + (by + intro pre M N post hd + subst hd + simp only [modListCast_rfl, Category.comp_id] + apply modMulti_whiskerR_hom_ext A Xs + rw [← whisker_exchange_assoc, ← whisker_exchange_assoc, + whiskerRight_modMultiπ_concatFst] + rw [modMultiLegM, modMultiLegN, + modMultiLegOf_concatL_assoc A pre M N post _ Xs (by simp), + modMultiLegOf_concatL_assoc A pre M N post _ Xs (by simp)] + have hrel := modMulti_rel A (Xs ++ pre) M N post + (show Xs ++ (pre ++ M :: N :: post) = + (Xs ++ pre) ++ M :: N :: post by simp) + rw [modMultiLegM, modMultiLegN] at hrel + exact congrArg + (modMultiMidConcatL A pre M N post Xs ≫ ·) hrel) + +/-- Defining equation of the concatenation against the projection +of the second block. -/ +@[reassoc (attr := simp)] +lemma whiskerLeft_modMultiπ_concat + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [MonoidalPreadditive D] + [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorRight Y)] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorLeft Y)] + (Xs Ys : List (Mod D A)) : + (modMulti A Xs ◁ modMultiπ A Ys) ≫ modMultiConcat A Xs Ys = + modMultiConcatFst A Xs Ys := + whiskerLeft_modMultiπ_whiskerLDesc A Ys _ _ _ + +/-- **Defining equation of the concatenation**: on the two +projections it is the fold concatenation followed by the projection +of the concatenated list. -/ +@[reassoc] +lemma tensorHom_modMultiπ_concat + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [Preadditive D] [MonoidalPreadditive D] + [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorRight Y)] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorLeft Y)] + (Xs Ys : List (Mod D A)) : + (modMultiπ A Xs ⊗ₘ modMultiπ A Ys) ≫ modMultiConcat A Xs Ys = + (modListConcat A Xs Ys).hom ≫ modMultiπ A (Xs ++ Ys) := by + rw [tensorHom_def, Category.assoc, whiskerLeft_modMultiπ_concat, + whiskerRight_modMultiπ_concatFst] + +end ConcatMap + +/-! ## The head action + +On a non-empty list the monoid acts through the head factor; the +action descends to the multi-tensor, making it a module. The slot +compatibilities are the two cases: the slot at the head, through +the binary window compatibilities of `ModTensor.lean`, and a slot +in the tail, disjoint from the action. -/ + +section HeadAction + +/-- The head action on the fold of a non-empty list: act on the +head factor. -/ +def modListHeadAct [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X : Mod D A) (l : List (Mod D A)) : + A ⊗ modList A (X :: l) ⟶ modList A (X :: l) := + (α_ A X.X (modList A l)).inv ≫ (actLeft A X.X ▷ modList A l) + +/-- Unitality of the head action. -/ +lemma modListHeadAct_one + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X : Mod D A) (l : List (Mod D A)) : + η[A] ▷ modList A (X :: l) ≫ modListHeadAct A X l = + (λ_ (modList A (X :: l))).hom := + one_act_tensorRight A X.X (actLeft A X.X) (one_actLeft A X.X) + (modList A l) + +/-- Associativity of the head action. -/ +lemma modListHeadAct_mul + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X : Mod D A) (l : List (Mod D A)) : + μ[A] ▷ modList A (X :: l) ≫ modListHeadAct A X l = + (α_ A A (modList A (X :: l))).hom ≫ + (A ◁ modListHeadAct A X l) ≫ modListHeadAct A X l := + mul_act_tensorRight A X.X (actLeft A X.X) (mul_actLeft A X.X) + (modList A l) + +/-- The shuffle of the head slot: the monoid moves inside the +window and acts on the left module factor there. -/ +def modMultiHeadShuffle [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (M N : Mod D A) (post : List (Mod D A)) : + A ⊗ modMultiMid A [] M N post ⟶ modMultiMid A [] M N post := + (α_ A ((M.X ⊗ A) ⊗ N.X) (modList A post)).inv ≫ + (((α_ A (M.X ⊗ A) N.X).inv ≫ + ((α_ A M.X A).inv ≫ actLeft A M.X ▷ A) ▷ N.X) ▷ + modList A post) + +/-- **The head-slot compatibility**: a window morphism compatible +with the binary action commutes the head action past the head +slot's leg. -/ +@[reassoc] +lemma modListHeadAct_window + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (M N : Mod D A) (post : List (Mod D A)) + (w : (M.X ⊗ A) ⊗ N.X ⟶ M.X ⊗ N.X) + (hw : A ◁ w ≫ ((α_ A M.X N.X).inv ≫ actLeft A M.X ▷ N.X) = + ((α_ A (M.X ⊗ A) N.X).inv ≫ + ((α_ A M.X A).inv ≫ actLeft A M.X ▷ A) ▷ N.X) ≫ w) : + (A ◁ modMultiLegOf A M N post w []) ≫ + modListHeadAct A M (N :: post) = + modMultiHeadShuffle A M N post ≫ + modMultiLegOf A M N post w [] := by + have hcoh : (A ◁ (α_ M.X N.X (modList A post)).hom) ≫ + (α_ A M.X (N.X ⊗ modList A post)).inv = + (α_ A (M.X ⊗ N.X) (modList A post)).inv ≫ + ((α_ A M.X N.X).inv ▷ modList A post) ≫ + (α_ (A ⊗ M.X) N.X (modList A post)).hom := by + monoidal + change (A ◁ ((w ▷ modList A post) ≫ + (α_ M.X N.X (modList A post)).hom)) ≫ + ((α_ A M.X (N.X ⊗ modList A post)).inv ≫ + (actLeft A M.X ▷ (N.X ⊗ modList A post))) = + ((α_ A ((M.X ⊗ A) ⊗ N.X) (modList A post)).inv ≫ + (((α_ A (M.X ⊗ A) N.X).inv ≫ + ((α_ A M.X A).inv ≫ actLeft A M.X ▷ A) ▷ N.X) ▷ + modList A post)) ≫ + ((w ▷ modList A post) ≫ (α_ M.X N.X (modList A post)).hom) + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + conv_rhs => rw [← MonoidalCategory.comp_whiskerRight_assoc, ← hw] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [← associator_inv_naturality_middle_assoc, + associator_naturality_left, reassoc_of% hcoh] + +/-- **The tail-slot compatibility**: the head action is disjoint +from any morphism whiskered under the head factor. -/ +@[reassoc] +lemma modListHeadAct_tail + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X : Mod D A) {S : D} + {T : List (Mod D A)} (u : S ⟶ modList A T) : + (A ◁ (X.X ◁ u)) ≫ modListHeadAct A X T = + ((α_ A X.X S).inv ≫ (actLeft A X.X ▷ S)) ≫ (X.X ◁ u) := by + change (A ◁ (X.X ◁ u)) ≫ + ((α_ A X.X (modList A T)).inv ≫ + (actLeft A X.X ▷ modList A T)) = + ((α_ A X.X S).inv ≫ (actLeft A X.X ▷ S)) ≫ (X.X ◁ u) + rw [associator_inv_naturality_right_assoc, Category.assoc, + whisker_exchange] + +end HeadAction + +/-! ## Descent of the head action -/ + +section HeadDescent + +/-- The head action carries every slot relation into the kernel of +the projection. -/ +lemma modListHeadAct_slotwise + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] [Preadditive D] + [HasFiniteBiproducts D] [HasCoequalizers D] + (X : Mod D A) (l : List (Mod D A)) + (pre : List (Mod D A)) (M N : Mod D A) (post : List (Mod D A)) + (hd : X :: l = pre ++ M :: N :: post) : + (A ◁ (modMultiLegM A pre M N post ≫ modListCast A hd.symm)) ≫ + (modListHeadAct A X l ≫ modMultiπ A (X :: l)) = + (A ◁ (modMultiLegN A pre M N post ≫ modListCast A hd.symm)) ≫ + (modListHeadAct A X l ≫ modMultiπ A (X :: l)) := by + rcases pre with _ | ⟨P, pre'⟩ + · rw [List.nil_append] at hd + injection hd with h1 h2 + subst h1 + subst h2 + rw [modMultiLegM, modMultiLegN] + change (A ◁ (modMultiLegOf A X N post (modTensorLegM A X N) [] ≫ + 𝟙 (modList A ([] ++ X :: N :: post)))) ≫ + (modListHeadAct A X (N :: post) ≫ + modMultiπ A (X :: N :: post)) = + (A ◁ (modMultiLegOf A X N post (modTensorLegN A X N) [] ≫ + 𝟙 (modList A ([] ++ X :: N :: post)))) ≫ + (modListHeadAct A X (N :: post) ≫ + modMultiπ A (X :: N :: post)) + rw [Category.comp_id, Category.comp_id, + modListHeadAct_window_assoc A X N post _ + (whiskerLeft_modTensorLegM_act A X N A (actLeft A X.X) + (actLeft_actRight A X.X)), + modListHeadAct_window_assoc A X N post _ + (whiskerLeft_modTensorLegN_act A X N A (actLeft A X.X))] + have hrel := modMulti_rel A [] X N post + (rfl : X :: N :: post = [] ++ X :: N :: post) + simp only [List.nil_append, modListCast_rfl, Category.id_comp] + at hrel + rw [modMultiLegM, modMultiLegN] at hrel + simpa only [modMultiHeadShuffle, Category.assoc] using + congrArg (modMultiHeadShuffle A X N post ≫ ·) hrel + · rw [List.cons_append] at hd + injection hd with h1 h2 + subst h1 + subst h2 + rw [modMultiLegM, modMultiLegN] + change (A ◁ ((X.X ◁ modMultiLegOf A M N post + (modTensorLegM A M N) pre') ≫ + 𝟙 (X.X ⊗ modList A (pre' ++ M :: N :: post)))) ≫ + (modListHeadAct A X (pre' ++ M :: N :: post) ≫ + modMultiπ A (X :: (pre' ++ M :: N :: post))) = + (A ◁ ((X.X ◁ modMultiLegOf A M N post + (modTensorLegN A M N) pre') ≫ + 𝟙 (X.X ⊗ modList A (pre' ++ M :: N :: post)))) ≫ + (modListHeadAct A X (pre' ++ M :: N :: post) ≫ + modMultiπ A (X :: (pre' ++ M :: N :: post))) + rw [Category.comp_id, Category.comp_id] + erw [← Category.assoc, modListHeadAct_tail_assoc A X _] + conv_rhs => erw [← Category.assoc, modListHeadAct_tail_assoc A X _] + have hrel := modMulti_rel A (X :: pre') M N post + (show X :: (pre' ++ M :: N :: post) = + (X :: pre') ++ M :: N :: post by simp) + simp only [List.cons_append, modListCast_rfl, Category.id_comp] + at hrel + rw [modMultiLegM, modMultiLegN, modMultiLegOf_cons, + modMultiLegOf_cons] at hrel + have h4 : (actLeft A X.X ▷ modMultiMid A pre' M N post ≫ + X.X ◁ modMultiLegOf A M N post (modTensorLegM A M N) pre') ≫ + modMultiπ A (X :: (pre' ++ M :: N :: post)) = + (actLeft A X.X ▷ modMultiMid A pre' M N post ≫ + X.X ◁ modMultiLegOf A M N post (modTensorLegN A M N) pre') ≫ + modMultiπ A (X :: (pre' ++ M :: N :: post)) := + (Category.assoc _ _ _).trans + ((congrArg + (actLeft A X.X ▷ modMultiMid A pre' M N post ≫ ·) + hrel).trans (Category.assoc _ _ _).symm) + exact (Category.assoc _ _ _).trans + ((congrArg + ((α_ A X.X (modMultiMid A pre' M N post)).inv ≫ ·) + h4).trans (Category.assoc _ _ _).symm) + +/-- **The head action on the multi-tensor**, by descent. -/ +noncomputable def modMultiHeadAct + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorLeft Y)] + (X : Mod D A) (l : List (Mod D A)) : + A ⊗ modMulti A (X :: l) ⟶ modMulti A (X :: l) := + modMultiWhiskerLDesc A (X :: l) A + (modListHeadAct A X l ≫ modMultiπ A (X :: l)) + (fun pre M N post hd => + modListHeadAct_slotwise A X l pre M N post hd) + +/-- Defining equation of the descended head action. -/ +@[reassoc (attr := simp)] +lemma whiskerLeft_modMultiπ_headAct + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorLeft Y)] + (X : Mod D A) + (l : List (Mod D A)) : + (A ◁ modMultiπ A (X :: l)) ≫ modMultiHeadAct A X l = + modListHeadAct A X l ≫ modMultiπ A (X :: l) := + whiskerLeft_modMultiπ_whiskerLDesc A (X :: l) A _ _ + +/-- Unitality of the descended head action. -/ +lemma modMultiHeadAct_one + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorLeft Y)] + (X : Mod D A) (l : List (Mod D A)) : + η[A] ▷ modMulti A (X :: l) ≫ modMultiHeadAct A X l = + (λ_ (modMulti A (X :: l))).hom := by + apply modMulti_whiskerL_hom_ext A (X :: l) (𝟙_ D) + rw [whisker_exchange_assoc, whiskerLeft_modMultiπ_headAct, + reassoc_of% (modListHeadAct_one A X l)] + conv_rhs => rw [leftUnitor_naturality] + +/-- Associativity of the descended head action. -/ +lemma modMultiHeadAct_mul + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorLeft Y)] + (X : Mod D A) (l : List (Mod D A)) : + μ[A] ▷ modMulti A (X :: l) ≫ modMultiHeadAct A X l = + (α_ A A (modMulti A (X :: l))).hom ≫ + (A ◁ modMultiHeadAct A X l) ≫ modMultiHeadAct A X l := by + apply modMulti_whiskerL_hom_ext A (X :: l) (A ⊗ A) + conv_lhs => rw [whisker_exchange_assoc, + whiskerLeft_modMultiπ_headAct] + conv_rhs => rw [associator_naturality_right_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + whiskerLeft_modMultiπ_headAct, + MonoidalCategory.whiskerLeft_comp_assoc, + whiskerLeft_modMultiπ_headAct] + rw [reassoc_of% (modListHeadAct_mul A X l)] + +/-- The multi-tensor of a non-empty list is a module over `A`. -/ +@[implicit_reducible] +noncomputable def modMultiModObj + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorLeft Y)] + (X : Mod D A) (l : List (Mod D A)) : + ModObj A (modMulti A (X :: l)) where + smul := modMultiHeadAct A X l + one_smul := modMultiHeadAct_one A X l + mul_smul := modMultiHeadAct_mul A X l + +/-- The multi-tensor of a non-empty list, bundled as a module. -/ +noncomputable def modMultiMod + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorLeft Y)] + (X : Mod D A) (l : List (Mod D A)) : + Mod D A := + letI := modMultiModObj A X l + ⟨modMulti A (X :: l)⟩ + +@[simp] lemma modMultiMod_X + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair + (MonoidalCategory.tensorLeft Y)] + (X : Mod D A) (l : List (Mod D A)) : + (modMultiMod A X l).X = modMulti A (X :: l) := + rfl + +end HeadDescent + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMultiTriple.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMultiTriple.lean new file mode 100644 index 0000000000..e4c03a2e1c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMultiTriple.lean @@ -0,0 +1,524 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMulti +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAssoc + +/-! +# The three-letter multi-tensor against the nested binary tensor + +The comparison of the wide presentation of the multi-tensor of a +three-element list with the left-nested binary module tensor +product of `ModTensor.lean`. + +* `triple_decomp`: a three-element list has exactly two adjacent + slots. +* `tripleResolve`/`tripleResolveInv`: the resolution of the + three-element fold onto the plain triple tensor, absorbing the + unit seed of the fold. +* `tripleLegFst_resolve`, `tripleLegSnd_resolve`, and the inverse + forms: the slot legs of the wide relation pair against the + resolutions, with the window morphism quantified. +* `modMultiTripleHom`: the forward descent through the wide + coequalizer, landing on the cover of the inverse associator of + `ModAssoc.lean`; its slot conditions are the whiskered binary + balance and the cover condition of the inverse associator. +* `tripleInvCover`, `tripleInvMid`, `modMultiTripleInv`: the + backward double descent through the outer and inner binary + coequalizers, mapping onto the wide projection. +* `modMultiTriple`: the packaged isomorphism + `modMulti A [X, Y, Z] ≅ modTensor A (modTensorMod A X Y) Z`, + with defining equations against the projections in both + directions. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## The resolution of the three-element fold -/ + +section TripleResolve + +/-- The two decompositions of a three-element list: the slot at the +head and the slot at the tail. -/ +lemma triple_decomp [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + {X Y Z M N : Mod D A} {pre post : List (Mod D A)} + (h : [X, Y, Z] = pre ++ M :: N :: post) : + (pre = [] ∧ X = M ∧ Y = N ∧ post = [Z]) ∨ + (pre = [X] ∧ Y = M ∧ Z = N ∧ post = []) := by + rcases pre with _ | ⟨P, pre⟩ + · injection h with h1 h + injection h with h2 h3 + exact Or.inl ⟨rfl, h1, h2, h3.symm⟩ + · injection h with h1 h + obtain ⟨rfl, h2, h3, rfl⟩ := pair_decomp A h + exact Or.inr ⟨by rw [h1], h2, h3, rfl⟩ + +/-- The resolution of the three-element fold onto the plain triple +tensor: absorb the unit seed. A bridge morphism with a +`modList`-typed source, so that statements through it stay +type-correct at low transparency. -/ +def tripleResolve + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : Mod D A) + (Y : Mod D A) (Z : Mod D A) : modList A [X, Y, Z] ⟶ X.X ⊗ (Y.X ⊗ Z.X) := + X.X ◁ (Y.X ◁ (ρ_ Z.X).hom) + +/-- The inverse resolution: reinstate the unit seed. -/ +def tripleResolveInv + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : Mod D A) + (Y : Mod D A) (Z : Mod D A) : X.X ⊗ (Y.X ⊗ Z.X) ⟶ modList A [X, Y, Z] := + X.X ◁ (Y.X ◁ (ρ_ Z.X).inv) + +@[reassoc (attr := simp)] +lemma tripleResolve_inv + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : Mod D A) + (Y : Mod D A) (Z : Mod D A) : + tripleResolve A X Y Z ≫ tripleResolveInv A X Y Z = 𝟙 _ := by + change (X.X ◁ (Y.X ◁ (ρ_ Z.X).hom)) ≫ + (X.X ◁ (Y.X ◁ (ρ_ Z.X).inv)) = + 𝟙 (X.X ⊗ (Y.X ⊗ (Z.X ⊗ 𝟙_ D))) + rw [← MonoidalCategory.whiskerLeft_comp, + ← MonoidalCategory.whiskerLeft_comp, Iso.hom_inv_id] + simp only [MonoidalCategory.whiskerLeft_id] + +@[reassoc (attr := simp)] +lemma tripleResolveInv_resolve + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : Mod D A) + (Y : Mod D A) (Z : Mod D A) : + tripleResolveInv A X Y Z ≫ tripleResolve A X Y Z = 𝟙 _ := by + change (X.X ◁ (Y.X ◁ (ρ_ Z.X).inv)) ≫ + (X.X ◁ (Y.X ◁ (ρ_ Z.X).hom)) = + 𝟙 (X.X ⊗ (Y.X ⊗ Z.X)) + rw [← MonoidalCategory.whiskerLeft_comp, + ← MonoidalCategory.whiskerLeft_comp, Iso.inv_hom_id] + simp only [MonoidalCategory.whiskerLeft_id] + +/-- The window seed of the head slot: absorb the unit seed of the +suffix fold, retyped at `modMultiMid`. -/ +def tripleSeedFst + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : Mod D A) + (Y : Mod D A) (Z : Mod D A) : + modMultiMid A [] X Y [Z] ⟶ ((X.X ⊗ A) ⊗ Y.X) ⊗ Z.X := + ((X.X ⊗ A) ⊗ Y.X) ◁ (ρ_ Z.X).hom + +/-- The inverse window seed of the head slot. -/ +def tripleSeedFstInv + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : Mod D A) + (Y : Mod D A) (Z : Mod D A) : + ((X.X ⊗ A) ⊗ Y.X) ⊗ Z.X ⟶ modMultiMid A [] X Y [Z] := + ((X.X ⊗ A) ⊗ Y.X) ◁ (ρ_ Z.X).inv + +/-- The head-slot leg against the resolution: the unit seed is +absorbed, the window morphism and the reassociation remain. -/ +@[reassoc] +lemma tripleLegFst_resolve + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : Mod D A) + (Y : Mod D A) (Z : Mod D A) + (w : (X.X ⊗ A) ⊗ Y.X ⟶ X.X ⊗ Y.X) + (h : ([] ++ X :: Y :: [Z] : List (Mod D A)) = [X, Y, Z]) : + modMultiLegOf A X Y [Z] w [] ≫ modListCast A h ≫ + tripleResolve A X Y Z = + tripleSeedFst A X Y Z ≫ (w ▷ Z.X) ≫ + (α_ X.X Y.X Z.X).hom := by + change ((w ▷ (Z.X ⊗ 𝟙_ D)) ≫ + (α_ X.X Y.X (Z.X ⊗ 𝟙_ D)).hom) ≫ + 𝟙 (X.X ⊗ (Y.X ⊗ (Z.X ⊗ 𝟙_ D))) ≫ + (X.X ◁ (Y.X ◁ (ρ_ Z.X).hom)) = + (((X.X ⊗ A) ⊗ Y.X) ◁ (ρ_ Z.X).hom) ≫ (w ▷ Z.X) ≫ + (α_ X.X Y.X Z.X).hom + rw [Category.id_comp, Category.assoc, + ← associator_naturality_right, ← whisker_exchange_assoc] + +/-- A window morphism against the inverse resolution, in head-slot +leg form. -/ +@[reassoc] +lemma tripleLegFst_resolveInv + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : Mod D A) + (Y : Mod D A) (Z : Mod D A) + (w : (X.X ⊗ A) ⊗ Y.X ⟶ X.X ⊗ Y.X) + (h : ([] ++ X :: Y :: [Z] : List (Mod D A)) = [X, Y, Z]) : + (w ▷ Z.X) ≫ (α_ X.X Y.X Z.X).hom ≫ + tripleResolveInv A X Y Z = + tripleSeedFstInv A X Y Z ≫ modMultiLegOf A X Y [Z] w [] ≫ + modListCast A h := by + change (w ▷ Z.X) ≫ (α_ X.X Y.X Z.X).hom ≫ + (X.X ◁ (Y.X ◁ (ρ_ Z.X).inv)) = + (((X.X ⊗ A) ⊗ Y.X) ◁ (ρ_ Z.X).inv) ≫ + ((w ▷ (Z.X ⊗ 𝟙_ D)) ≫ + (α_ X.X Y.X (Z.X ⊗ 𝟙_ D)).hom) ≫ + 𝟙 (X.X ⊗ (Y.X ⊗ (Z.X ⊗ 𝟙_ D))) + rw [Category.comp_id, whisker_exchange_assoc, + associator_naturality_right] + +/-- The window seed of the tail slot: the whiskered pair seed, +retyped at `modMultiMid` over the head prefix. -/ +def tripleSeedSnd + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : Mod D A) + (Y : Mod D A) (Z : Mod D A) : + modMultiMid A [X] Y Z [] ⟶ X.X ⊗ ((Y.X ⊗ A) ⊗ Z.X) := + X.X ◁ pairSeed A Y Z + +/-- The inverse window seed of the tail slot. -/ +def tripleSeedSndInv + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : Mod D A) + (Y : Mod D A) (Z : Mod D A) : + X.X ⊗ ((Y.X ⊗ A) ⊗ Z.X) ⟶ modMultiMid A [X] Y Z [] := + X.X ◁ pairSeedInv A Y Z + +/-- The tail-slot leg against the resolution: under the head factor +the leg is the pair leg, and the pair resolution applies. -/ +@[reassoc] +lemma tripleLegSnd_resolve + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : Mod D A) + (Y : Mod D A) (Z : Mod D A) + (w : (Y.X ⊗ A) ⊗ Z.X ⟶ Y.X ⊗ Z.X) + (h : ([X] ++ Y :: Z :: [] : List (Mod D A)) = [X, Y, Z]) : + modMultiLegOf A Y Z [] w [X] ≫ modListCast A h ≫ + tripleResolve A X Y Z = + tripleSeedSnd A X Y Z ≫ (X.X ◁ w) := by + change (X.X ◁ ((w ▷ 𝟙_ D) ≫ (α_ Y.X Z.X (𝟙_ D)).hom)) ≫ + 𝟙 (X.X ⊗ (Y.X ⊗ (Z.X ⊗ 𝟙_ D))) ≫ + (X.X ◁ (Y.X ◁ (ρ_ Z.X).hom)) = + (X.X ◁ (ρ_ ((Y.X ⊗ A) ⊗ Z.X)).hom) ≫ (X.X ◁ w) + rw [Category.id_comp, ← MonoidalCategory.whiskerLeft_comp, + ← MonoidalCategory.whiskerLeft_comp] + refine congrArg (fun t => X.X ◁ t) ?_ + have hcoh : (α_ Y.X Z.X (𝟙_ D)).hom ≫ (Y.X ◁ (ρ_ Z.X).hom) = + (ρ_ (Y.X ⊗ Z.X)).hom := by monoidal + rw [Category.assoc, hcoh, rightUnitor_naturality] + +/-- A window morphism against the inverse resolution, in tail-slot +leg form. -/ +@[reassoc] +lemma tripleLegSnd_resolveInv + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : Mod D A) + (Y : Mod D A) (Z : Mod D A) + (w : (Y.X ⊗ A) ⊗ Z.X ⟶ Y.X ⊗ Z.X) + (h : ([X] ++ Y :: Z :: [] : List (Mod D A)) = [X, Y, Z]) : + (X.X ◁ w) ≫ tripleResolveInv A X Y Z = + tripleSeedSndInv A X Y Z ≫ + modMultiLegOf A Y Z [] w [X] ≫ modListCast A h := by + change (X.X ◁ w) ≫ (X.X ◁ (Y.X ◁ (ρ_ Z.X).inv)) = + (X.X ◁ (ρ_ ((Y.X ⊗ A) ⊗ Z.X)).inv) ≫ + ((X.X ◁ ((w ▷ 𝟙_ D) ≫ (α_ Y.X Z.X (𝟙_ D)).hom)) ≫ + 𝟙 (X.X ⊗ (Y.X ⊗ (Z.X ⊗ 𝟙_ D)))) + rw [Category.comp_id, ← MonoidalCategory.whiskerLeft_comp, + ← MonoidalCategory.whiskerLeft_comp] + refine congrArg (fun t => X.X ◁ t) ?_ + have hcoh : (ρ_ (Y.X ⊗ Z.X)).inv ≫ (α_ Y.X Z.X (𝟙_ D)).hom = + Y.X ◁ (ρ_ Z.X).inv := by monoidal + rw [← rightUnitor_inv_naturality_assoc, hcoh] + +end TripleResolve + +/-! ## The comparison isomorphism -/ + +section TripleIso + +/-- The head window against the inverse-associator cover: the two +binary legs agree after the cover, by the inner balance whiskered +by `Z`. -/ +lemma tripleWindowFst_cond + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ V : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft V)] + (A : D) [MonObj A] [IsCommMonObj A] (X : Mod D A) (Y : Mod D A) + (Z : Mod D A) : + (modTensorLegM A X Y ▷ Z.X) ≫ (α_ X.X Y.X Z.X).hom ≫ + modTensorAssocInvCover A X Y Z = + (modTensorLegN A X Y ▷ Z.X) ≫ (α_ X.X Y.X Z.X).hom ≫ + modTensorAssocInvCover A X Y Z := by + rw [modTensorAssocInvCover] + simp only [Iso.hom_inv_id_assoc] + erw [← MonoidalCategory.comp_whiskerRight_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, + modTensor_condition] + +/-- **The forward comparison**: the wide projection descends onto +the cover of the inverse associator. The head slot condition is +the whiskered binary balance, the tail slot condition is the cover +condition of the inverse associator. -/ +noncomputable def modMultiTripleHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ V : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft V)] + (A : D) [MonObj A] [IsCommMonObj A] (X : Mod D A) (Y : Mod D A) + (Z : Mod D A) : + modMulti A [X, Y, Z] ⟶ modTensor A (modTensorMod A X Y) Z := + modMultiDesc A + (tripleResolve A X Y Z ≫ modTensorAssocInvCover A X Y Z) + (by + intro pre M N post hd + rcases triple_decomp A hd with ⟨rfl, h2, h3, rfl⟩ | + ⟨rfl, h2, h3, rfl⟩ + · subst h2 + subst h3 + rw [modMultiLegM, modMultiLegN, + tripleLegFst_resolve_assoc A X Y Z _ hd.symm, + tripleLegFst_resolve_assoc A X Y Z _ hd.symm, + tripleWindowFst_cond] + · subst h2 + subst h3 + rw [modMultiLegM, modMultiLegN, + tripleLegSnd_resolve_assoc A X Y Z _ hd.symm, + tripleLegSnd_resolve_assoc A X Y Z _ hd.symm, + modTensorAssocInvCover_cond]) + +/-- Defining equation of the forward comparison. -/ +@[reassoc (attr := simp)] +lemma modMultiπ_tripleHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ V : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft V)] + (A : D) [MonObj A] [IsCommMonObj A] (X : Mod D A) (Y : Mod D A) + (Z : Mod D A) : + modMultiπ A [X, Y, Z] ≫ modMultiTripleHom A X Y Z = + tripleResolve A X Y Z ≫ modTensorAssocInvCover A X Y Z := + modMultiπ_desc A _ _ + +/-- Defining equation of the forward comparison, with the cover +spelled out on the projections of the nested binary tensor. -/ +@[reassoc] +lemma modMultiπ_tripleHom_π + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ V : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft V)] + (A : D) [MonObj A] [IsCommMonObj A] (X : Mod D A) (Y : Mod D A) + (Z : Mod D A) : + modMultiπ A [X, Y, Z] ≫ modMultiTripleHom A X Y Z = + tripleResolve A X Y Z ≫ (α_ X.X Y.X Z.X).inv ≫ + (modTensorπ A X Y ▷ Z.X) ≫ + modTensorπ A (modTensorMod A X Y) Z := by + rw [modMultiπ_tripleHom, modTensorAssocInvCover] + +/-- The cover of the backward comparison: reassociate, reinstate +the unit seed, and project onto the multi-tensor. -/ +noncomputable def tripleInvCover + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] (X : Mod D A) (Y : Mod D A) (Z : Mod D A) : + (X.X ⊗ Y.X) ⊗ Z.X ⟶ modMulti A [X, Y, Z] := + (α_ X.X Y.X Z.X).hom ≫ tripleResolveInv A X Y Z ≫ + modMultiπ A [X, Y, Z] + +/-- The cover of the backward comparison coequalizes the whiskered +inner balance: the head slot relation of the wide pair. -/ +lemma tripleInvCover_cond + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] (X : Mod D A) (Y : Mod D A) (Z : Mod D A) : + (modTensorLegM A X Y ▷ Z.X) ≫ tripleInvCover A X Y Z = + (modTensorLegN A X Y ▷ Z.X) ≫ tripleInvCover A X Y Z := by + have hrel := modMulti_rel A [] X Y [Z] + (rfl : [X, Y, Z] = [] ++ X :: Y :: [Z]) + rw [modMultiLegM, modMultiLegN] at hrel + rw [tripleInvCover, + tripleLegFst_resolveInv_assoc A X Y Z _ + (Eq.symm (rfl : [X, Y, Z] = [] ++ X :: Y :: [Z])), + tripleLegFst_resolveInv_assoc A X Y Z _ + (Eq.symm (rfl : [X, Y, Z] = [] ++ X :: Y :: [Z])), + hrel] + +/-- The tail slot relation after the inverse resolution, spelled at +the braided right action: the bridge between the outer balance of +the nested binary tensor and the wide relation pair. -/ +@[reassoc] +lemma tripleResolveInv_snd_rel + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] (X : Mod D A) (Y : Mod D A) (Z : Mod D A) : + (X.X ◁ (actRight A Y.X ▷ Z.X)) ≫ tripleResolveInv A X Y Z ≫ + modMultiπ A [X, Y, Z] = + (X.X ◁ ((α_ Y.X A Z.X).hom ≫ (Y.X ◁ actLeft A Z.X))) ≫ + tripleResolveInv A X Y Z ≫ modMultiπ A [X, Y, Z] := by + have hrel := modMulti_rel A [X] Y Z [] + (rfl : [X, Y, Z] = [X] ++ Y :: Z :: []) + rw [modMultiLegM, modMultiLegN] at hrel + change (X.X ◁ modTensorLegM A Y Z) ≫ tripleResolveInv A X Y Z ≫ + modMultiπ A [X, Y, Z] = + (X.X ◁ modTensorLegN A Y Z) ≫ tripleResolveInv A X Y Z ≫ + modMultiπ A [X, Y, Z] + rw [tripleLegSnd_resolveInv_assoc A X Y Z _ + (Eq.symm (rfl : [X, Y, Z] = [X] ++ Y :: Z :: [])), + tripleLegSnd_resolveInv_assoc A X Y Z _ + (Eq.symm (rfl : [X, Y, Z] = [X] ++ Y :: Z :: [])), + hrel] + +/-- The half-descended backward comparison, on the cover of the +outer coequalizer of the nested binary tensor. -/ +noncomputable def tripleInvMid + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ V : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight V)] + (A : D) [MonObj A] (X : Mod D A) (Y : Mod D A) (Z : Mod D A) : + modTensor A X Y ⊗ Z.X ⟶ modMulti A [X, Y, Z] := + modTensorWhiskerRDesc A X Y Z.X (tripleInvCover A X Y Z) + (tripleInvCover_cond A X Y Z) + +/-- Defining equation of the half-descended backward comparison. -/ +@[reassoc (attr := simp)] +lemma whiskerRight_modTensorπ_tripleInvMid + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ V : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight V)] + (A : D) [MonObj A] (X : Mod D A) (Y : Mod D A) (Z : Mod D A) : + (modTensorπ A X Y ▷ Z.X) ≫ tripleInvMid A X Y Z = + tripleInvCover A X Y Z := + whiskerRight_modTensorπ_whiskerRDesc A X Y Z.X _ _ + +/-- The half-descended backward comparison coequalizes the outer +balance: the monoid sliding between the `(X, Y)`-block and `Z` +slides into the tail slot of the wide relation pair. -/ +lemma tripleInvMid_cond + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ V : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft V)] + [∀ V : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight V)] + (A : D) [MonObj A] [IsCommMonObj A] (X : Mod D A) (Y : Mod D A) + (Z : Mod D A) : + modTensorLegM A (modTensorMod A X Y) Z ≫ tripleInvMid A X Y Z = + modTensorLegN A (modTensorMod A X Y) Z ≫ + tripleInvMid A X Y Z := by + refine (cancel_epi ((modTensorπ A X Y ▷ A) ▷ Z.X)).mp ?_ + change ((modTensorπ A X Y ▷ A) ▷ Z.X) ≫ + (((β_ (modTensor A X Y) A).hom ≫ modTensorAct A X Y) ▷ + Z.X) ≫ + tripleInvMid A X Y Z = + ((modTensorπ A X Y ▷ A) ▷ Z.X) ≫ + ((α_ (modTensor A X Y) A Z.X).hom ≫ + (modTensor A X Y ◁ actLeft A Z.X)) ≫ + tripleInvMid A X Y Z + conv_lhs => rw [← MonoidalCategory.comp_whiskerRight_assoc, + modTensorπ_actRight] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + conv_lhs => rw [whiskerRight_modTensorπ_tripleInvMid, + tripleInvCover, associator_naturality_middle_assoc, + tripleResolveInv_snd_rel] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + conv_rhs => rw [associator_naturality_left_assoc, + ← whisker_exchange_assoc, whiskerRight_modTensorπ_tripleInvMid, + tripleInvCover, associator_naturality_right_assoc] + rw [pentagon_assoc] + +/-- **The backward comparison**: the nested binary tensor descends +onto the multi-tensor, by double descent through the outer and +inner coequalizers. -/ +noncomputable def modMultiTripleInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ V : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft V)] + [∀ V : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight V)] + (A : D) [MonObj A] [IsCommMonObj A] (X : Mod D A) (Y : Mod D A) + (Z : Mod D A) : + modTensor A (modTensorMod A X Y) Z ⟶ modMulti A [X, Y, Z] := + modTensorDesc A (modTensorMod A X Y) Z (tripleInvMid A X Y Z) + (tripleInvMid_cond A X Y Z) + +/-- Defining equation of the backward comparison against the outer +projection. -/ +@[reassoc (attr := simp)] +lemma modTensorπ_tripleInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ V : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft V)] + [∀ V : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight V)] + (A : D) [MonObj A] [IsCommMonObj A] (X : Mod D A) (Y : Mod D A) + (Z : Mod D A) : + modTensorπ A (modTensorMod A X Y) Z ≫ + modMultiTripleInv A X Y Z = + tripleInvMid A X Y Z := + modTensorπ_desc A _ _ _ _ + +/-- Defining equation of the backward comparison against both +projections: reassociate, reinstate the unit seed, and project. -/ +@[reassoc] +lemma whiskerRight_modTensorπ_tripleInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ V : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft V)] + [∀ V : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight V)] + (A : D) [MonObj A] [IsCommMonObj A] (X : Mod D A) (Y : Mod D A) + (Z : Mod D A) : + (modTensorπ A X Y ▷ Z.X) ≫ + modTensorπ A (modTensorMod A X Y) Z ≫ + modMultiTripleInv A X Y Z = + (α_ X.X Y.X Z.X).hom ≫ tripleResolveInv A X Y Z ≫ + modMultiπ A [X, Y, Z] := by + erw [modTensorπ_tripleInv] + erw [whiskerRight_modTensorπ_tripleInvMid, tripleInvCover] + +/-- The forward comparison retracts the backward comparison. -/ +@[reassoc (attr := simp)] +lemma modMultiTripleHom_tripleInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ V : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft V)] + [∀ V : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight V)] + (A : D) [MonObj A] [IsCommMonObj A] (X : Mod D A) (Y : Mod D A) + (Z : Mod D A) : + modMultiTripleHom A X Y Z ≫ modMultiTripleInv A X Y Z = + 𝟙 (modMulti A [X, Y, Z]) := by + apply modMulti_hom_ext + rw [modMultiπ_tripleHom_assoc, Category.comp_id, + modTensorAssocInvCover] + simp only [Category.assoc] + repeat' erw [Category.assoc] + erw [modTensorπ_tripleInv] + rw [whiskerRight_modTensorπ_tripleInvMid, tripleInvCover, + Iso.inv_hom_id_assoc, tripleResolve_inv_assoc] + +/-- The backward comparison retracts the forward comparison. -/ +@[reassoc (attr := simp)] +lemma modMultiTripleInv_tripleHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ V : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft V)] + [∀ V : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight V)] + (A : D) [MonObj A] [IsCommMonObj A] (X : Mod D A) (Y : Mod D A) + (Z : Mod D A) : + modMultiTripleInv A X Y Z ≫ modMultiTripleHom A X Y Z = + 𝟙 (modTensor A (modTensorMod A X Y) Z) := by + apply modTensor_hom_ext + rw [modTensorπ_tripleInv_assoc, Category.comp_id] + apply modTensor_whiskerR_hom_ext A X Y Z.X + change (modTensorπ A X Y ▷ Z.X) ≫ tripleInvMid A X Y Z ≫ + modMultiTripleHom A X Y Z = + (modTensorπ A X Y ▷ Z.X) ≫ modTensorπ A (modTensorMod A X Y) Z + rw [whiskerRight_modTensorπ_tripleInvMid_assoc, tripleInvCover] + simp only [Category.assoc] + rw [modMultiπ_tripleHom, tripleResolveInv_resolve_assoc, + modTensorAssocInvCover, Iso.hom_inv_id_assoc] + +/-- **The three-letter multi-tensor is the nested binary tensor**: +the one-step wide presentation of `modMulti A [X, Y, Z]` and the +left-nested binary module tensor product coequalize the same +relations. -/ +noncomputable def modMultiTriple + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ V : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft V)] + [∀ V : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight V)] + (A : D) [MonObj A] [IsCommMonObj A] (X : Mod D A) (Y : Mod D A) + (Z : Mod D A) : + modMulti A [X, Y, Z] ≅ modTensor A (modTensorMod A X Y) Z where + hom := modMultiTripleHom A X Y Z + inv := modMultiTripleInv A X Y Z + hom_inv_id := modMultiTripleHom_tripleInv A X Y Z + inv_hom_id := modMultiTripleInv_tripleHom A X Y Z + +end TripleIso + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowCast.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowCast.lean new file mode 100644 index 0000000000..1d2888aaf0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowCast.lean @@ -0,0 +1,204 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymMul +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPermCast + +/-! +# Vanishing along the standard embeddings on module powers + +The module-power mirror of `Envelope/SymPermCast.lean`: an element +of the symmetric-group algebra whose descended action on the `m`-th +module power vanishes keeps a vanishing action at every higher +arity, along the standard embeddings `S_m ↪ S_n`. + +The route is a descent reduction rather than a fresh induction. +The projection `modPowπ` intertwines the ambient action `permAlg` +with the descended action `modPowAlg` (`modPowπ_permAlg`), because +the descended action is defined slot by slot through that very +square; so vanishing of the descended action is exactly vanishing +of the ambient action followed by the projection. The ambient +compatibility `permAlg_symCast` rewrites the restricted action as a +repeated whiskering, and one letter is attached to a module power +by `modPowAttach` — the first concatenation stage of `SymMul.lean` +taken at a single letter — whose defining square +`(modPowπ ▷ X) ≫ modPowAttach = modPowπ` lets whiskered morphisms +that die after the projection keep dying +(`whiskerRight_modPowπ_zero`). The compatibility +`modPowAlg_compat` follows. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## Structural helpers -/ + +section Aux + +/-- Collapse of the single-letter concatenation stage: the unitor +triangle, in the shape produced by `tensorPowConcat` at one +letter. -/ +private theorem attach_aux [Category.{v} D] [MonoidalCategory D] (X : D) + (P : D) : + (P ◁ (λ_ X).inv) ≫ (α_ P (𝟙_ D) X).inv ≫ + ((ρ_ P).hom ▷ X) = 𝟙 (P ⊗ X) := by + monoidal + +end Aux + +section Pass + +/-- Passing a sum across an intertwiner. -/ +private theorem add_pass [Category.{v} D] [Preadditive D] + {P Q : D} {T : P ⟶ Q} {u v : Q ⟶ Q} + {u' v' : P ⟶ P} (hu : T ≫ u = u' ≫ T) (hv : T ≫ v = v' ≫ T) : + T ≫ (u + v) = (u' + v') ≫ T := by + rw [Preadditive.comp_add, Preadditive.add_comp, hu, hv] + +/-- Passing a scalar multiple across an intertwiner. -/ +private theorem smul_pass [Category.{v} D] [Preadditive D] [Linear ℂ D] + {P Q : D} {T : P ⟶ Q} {u : Q ⟶ Q} + {u' : P ⟶ P} (r : ℂ) (h : T ≫ u = u' ≫ T) : + T ≫ (r • u) = (r • u') ≫ T := by + rw [Linear.comp_smul, Linear.smul_comp, h] + +end Pass + +/-! ## Attaching one letter to a module power -/ + +section Attach + +/-- **Attach one ambient letter** on the right of a module power: +the first concatenation stage of the multiplication of +`SymMul.lean`, taken at a single letter. -/ +noncomputable def modPowAttach + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (p : ℕ) : + modPow A X p ⊗ X ⟶ modPow A X (p + 1) := + (modPow A X p ◁ (show X ⟶ tensorPow D X 1 from (λ_ X).inv)) ≫ + modPowMulStage A X p 1 + +/-- **Defining square of the attachment**: the projection at `p + 1` +factors through the right-whiskered projection at `p`. -/ +theorem modPowπ_attach + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (p : ℕ) : + (modPowπ A X p ▷ X) ≫ modPowAttach A X p = + modPowπ A X (p + 1) := by + have h2 : (tensorPow D X p ◁ + (show X ⟶ tensorPow D X 1 from (λ_ X).inv)) ≫ + (tensorPowConcat X p 1).hom = 𝟙 (tensorPow D X (p + 1)) := + attach_aux X (tensorPow D X p) + rw [modPowAttach, ← MonoidalCategory.whisker_exchange_assoc, + modPowπ_whiskerRight_mulStage, ← Category.assoc, h2] + exact Category.id_comp (modPowπ A X (p + 1)) + +/-- **Whiskered vanishing**: a morphism of the ambient power that +dies after the projection keeps dying, one letter later, after +whiskering on the right. -/ +theorem whiskerRight_modPowπ_zero + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + {p : ℕ} + {f : tensorPow D X p ⟶ tensorPow D X p} + (hf : f ≫ modPowπ A X p = 0) : + (f ▷ X) ≫ modPowπ A X (p + 1) = 0 := by + rw [← modPowπ_attach A X p, + ← MonoidalCategory.comp_whiskerRight_assoc, hf, + MonoidalPreadditive.zero_whiskerRight, Limits.zero_comp] + +end Attach + +/-! ## The compatibility -/ + +section Compat + +/-- **The projection intertwines the two algebra actions**: the +`ℂ`-linear extension of the defining square of the descended +permutation action. -/ +theorem modPowπ_permAlg + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) (x : SymGroupAlgebra n) : + modPowπ A X n ≫ modPowAlg A X n x = + permAlg X n x ≫ modPowπ A X n := by + induction x using MonoidAlgebra.induction_on with + | of σ => + rw [show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin n))) σ = + MonoidAlgebra.single σ (1 : ℂ) from rfl, + modPowAlg_single, permAlg_single] + exact modPowπ_perm n σ + | add x₁ x₂ h₁ h₂ => + rw [map_add, map_add] + exact add_pass h₁ h₂ + | smul r y hy => + rw [map_smul, map_smul] + exact smul_pass r hy + +/-- **Iterated whiskered vanishing**: an endomorphism of the ambient +power that dies after the projection keeps dying after any number of +letters is attached. -/ +theorem whiskerPowAlg_modPowπ_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalPreadditive D] + [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (m k : ℕ) + (f : tensorPow D X m ⟶ tensorPow D X m) + (hf : f ≫ modPowπ A X m = 0) : + whiskerPowAlg X m k f ≫ modPowπ A X (m + k) = 0 := by + induction k with + | zero => exact hf + | succ k ih => exact whiskerRight_modPowπ_zero A X ih + +/-- **Vanishing propagates along the standard embeddings** on +module powers: an element of the group algebra killed by the +descended action at arity `m` stays killed at every arity `n ≥ m`. +This is the `compat` field of a tower, for the action on a module +power. -/ +theorem modPowAlg_compat + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalPreadditive D] + [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + {m n : ℕ} (h : m ≤ n) + (x : SymGroupAlgebra m) (hx : modPowAlg A X m x = 0) : + modPowAlg A X n (symCast h x) = 0 := by + obtain ⟨k, rfl⟩ := Nat.exists_eq_add_of_le h + have hπ : permAlg X m x ≫ modPowπ A X m = 0 := by + rw [← modPowπ_permAlg A X m x, hx] + exact Limits.comp_zero + have h0 : whiskerPowAlg X m k (permAlg X m x) ≫ + modPowπ A X (m + k) = 0 := + whiskerPowAlg_modPowπ_zero A X m k (permAlg X m x) hπ + apply modPow_hom_ext A X + rw [modPowπ_permAlg, permAlg_symCast, h0] + exact Limits.comp_zero.symm + +end Compat + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescent.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescent.lean new file mode 100644 index 0000000000..c0a2599d8c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescent.lean @@ -0,0 +1,97 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowCopairing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModZero + +/-! +# The retract tower of a dualizable module + +Iterating the zig retract: a module that is a retract of its +double-dual sandwich is a retract of every stage of the sandwich +tower. Together with the merge isomorphisms this descends the +vanishing of a relative power to the module itself. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The sandwich tower**: iterate tensoring with the pair +`M ⊗ M'` on the left. -/ +noncomputable def sandwichTower + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) : + ℕ → Mod D A + | 0 => M + | (k + 1) => modTensorMod A (modTensorMod A M M') + (sandwichTower A M M' k) + +@[simp] lemma sandwichTower_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) : + sandwichTower A M M' 0 = M := rfl + +@[simp] lemma sandwichTower_succ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (k : ℕ) : + sandwichTower A M M' (k + 1) = + modTensorMod A (modTensorMod A M M') + (sandwichTower A M M' k) := rfl + +/-- **The retract iterates up the tower**: a module that is a +retract of its sandwich is a retract of every tower stage. -/ +theorem sandwichTower_retract + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (i₀ : M ⟶ modTensorMod A (modTensorMod A M M') M) + (r₀ : modTensorMod A (modTensorMod A M M') M ⟶ M) + (h₀ : i₀ ≫ r₀ = 𝟙 M) : + ∀ k : ℕ, ∃ (i : M ⟶ sandwichTower A M M' k) + (r : sandwichTower A M M' k ⟶ M), i ≫ r = 𝟙 M + | 0 => ⟨𝟙 M, 𝟙 M, Category.id_comp _⟩ + | (k + 1) => by + obtain ⟨ik, rk, hk⟩ := + sandwichTower_retract A M M' i₀ r₀ h₀ k + refine ⟨i₀ ≫ modTensorMapMod A (𝟙 _) ik, + modTensorMapMod A (𝟙 _) rk ≫ r₀, ?_⟩ + have hmid : modTensorMapMod A + (𝟙 (modTensorMod A M M')) ik ≫ + modTensorMapMod A (𝟙 (modTensorMod A M M')) rk = + 𝟙 (modTensorMod A (modTensorMod A M M') M) := by + apply Mod.Hom.ext + change modTensorMap A (𝟙 (modTensorMod A M M')) ik ≫ + modTensorMap A (𝟙 (modTensorMod A M M')) rk = + 𝟙 (modTensor A (modTensorMod A M M') M) + rw [← modTensorMap_comp, Category.comp_id] + have hcarrier : ik ≫ rk = 𝟙 M := hk + rw [hcarrier, modTensorMap_id] + erw [Category.assoc] + refine Eq.trans (whisker_eq _ + (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker hmid _)) ?_ + refine Eq.trans (whisker_eq _ (Category.id_comp _)) ?_ + exact h₀ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescentClose.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescentClose.lean new file mode 100644 index 0000000000..badaf0aa1a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescentClose.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichMerge + +/-! +# Descent of power vanishing to the module + +Given the sandwich retract of a dualizable module, vanishing of a +relative tensor power descends to the module itself: the retract +iterates up the tower, and the tower reassembles into a power +pair whose first factor is the vanishing power. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **Power vanishing descends along the sandwich retract**: a +module with a sandwich retract whose `(n + 2)`-nd relative power +vanishes is itself zero. -/ +theorem isZero_of_sandwich_of_isZero_modPow + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (i₀ : M ⟶ modTensorMod A (modTensorMod A M M') M) + (r₀ : modTensorMod A (modTensorMod A M M') M ⟶ M) + (h₀ : i₀ ≫ r₀ = 𝟙 M) {n : ℕ} + (h : IsZero (modPow A M.X (n + 2))) : IsZero M.X := by + obtain ⟨i, r, hir⟩ := + sandwichTower_retract A M M' i₀ r₀ h₀ (n + 1) + have hz : IsZero ((sandwichTower A M M' (n + 1)).X) := + isZero_sandwichTower_of_isZero_modPow A M M' n h + rw [IsZero.iff_id_eq_zero] + have hcar : i.hom ≫ r.hom = 𝟙 M.X := + congrArg Mod.Hom.hom hir + rw [← hcar, hz.eq_of_tgt i.hom 0, Limits.zero_comp] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowStage.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowStage.lean new file mode 100644 index 0000000000..0896c2b3df --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowStage.lean @@ -0,0 +1,226 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymAlg + +/-! +# The module power, one letter at a time + +The relative tensor power `modPow A X n` of `SymAlg.lean` is +presented in a single step, over all adjacent slots at once. The +arities are nevertheless joined by one letter at a time, and this +file supplies that stage map: the projection at arity `n + 1` +factors through the projection at arity `n` whiskered by one +further letter. + +* `modPowGlue_succ`, `modPowLegM_succ`, `modPowLegN_succ`: a + relation slot with one further letter of tail is that slot with + the shorter tail, whiskered by the letter, after the associator + that exposes it. +* `modPowStage A X n : modPow A X n ⊗ X ⟶ modPow A X (n + 1)`, + descended along the whiskered presentation of `SymAlg.lean`, with + `modPowπ_whiskerRight_stage` the factorisation itself. +* `modPow_invisible_succ`: an ambient endomorphism invisible to the + projection at one arity is invisible at the next. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## One further letter of tail + +Every relation leg is a local morphism whiskered by the tail and +then glued. Lengthening the tail by one letter therefore only +reassociates: at general objects this is a single application of +`whiskerRight_tensor`, and each arity-bearing instance is obtained +from it by `exact`, so that no tensor-power arity enters the +rewriting. +-/ + +section LegSucc + +/-- Lengthening the tail by one letter, at general objects. -/ +private theorem glue_succ_aux [Category.{v} D] [MonoidalCategory D] + {S T Q : D} (v : S ⟶ T) (P : D) + (c : T ⊗ P ⟶ Q) (W : D) : + (v ▷ (P ⊗ W)) ≫ ((α_ T P W).inv ≫ (c ▷ W)) = + (α_ S P W).inv ≫ (((v ▷ P) ≫ c) ▷ W) := by + rw [MonoidalCategory.whiskerRight_tensor, + MonoidalCategory.comp_whiskerRight] + simp only [Category.assoc, Iso.hom_inv_id_assoc] + +/-- **Gluing a longer tail**: the glue at tail length `b + 1` is the +glue at tail length `b`, whiskered by the extra letter. -/ +theorem modPowGlue_succ [Category.{v} D] [MonoidalCategory D] (X : D) + (a b : ℕ) : + modPowGlue X a (b + 1) = + (α_ (tensorPow D X a ⊗ (X ⊗ X)) (tensorPow D X b) X).inv ≫ + (modPowGlue X a b ▷ X) := + glue_succ_aux (α_ (tensorPow D X a) X X).inv (tensorPow D X b) + (tensorPowConcat X (a + 2) b).hom X + +end LegSucc + +section LegSuccMod + +/-- **The first leg with a longer tail**: acting on the left module +factor over a tail of length `b + 1` is doing so over a tail of +length `b`, whiskered by the extra letter. -/ +theorem modPowLegM_succ + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] + (a b : ℕ) : + modPowLegM A X a (b + 1) = + (α_ (tensorPow D X a ⊗ ((X ⊗ A) ⊗ X)) (tensorPow D X b) X).inv ≫ + (modPowLegM A X a b ▷ X) := by + change ((tensorPow D X a ◁ winLegM A X) ▷ tensorPow D X (b + 1)) ≫ + modPowGlue X a (b + 1) = _ + rw [modPowGlue_succ] + exact glue_succ_aux (tensorPow D X a ◁ winLegM A X) + (tensorPow D X b) (modPowGlue X a b) X + +/-- **The second leg with a longer tail**: acting on the right +module factor over a tail of length `b + 1` is doing so over a tail +of length `b`, whiskered by the extra letter. -/ +theorem modPowLegN_succ + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : D) + [ModObj A X] + (a b : ℕ) : + modPowLegN A X a (b + 1) = + (α_ (tensorPow D X a ⊗ ((X ⊗ A) ⊗ X)) (tensorPow D X b) X).inv ≫ + (modPowLegN A X a b ▷ X) := by + change ((tensorPow D X a ◁ winLegN A X) ▷ tensorPow D X (b + 1)) ≫ + modPowGlue X a (b + 1) = _ + rw [modPowGlue_succ] + exact glue_succ_aux (tensorPow D X a ◁ winLegN A X) + (tensorPow D X b) (modPowGlue X a b) X + +end LegSuccMod + +/-! ## The stage map + +The whiskered relation pair still coequalizes the projection one +arity up: tensoring on the right is additive, so the assembled legs +split into their slots, and each slot is the slot relation of the +longer arity with one more letter of tail. +-/ + +section BiproductWhisker + +/-- Whiskering a biproduct descent: tensoring on the right is an +additive functor, so it distributes over the slot decomposition. -/ +private theorem desc_whiskerRight + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] + {J : Type} [Fintype J] + {f : J → D} {T : D} (g : ∀ i, f i ⟶ T) (W : D) : + biproduct.desc g ▷ W = + ∑ i : J, (biproduct.π f i ▷ W) ≫ (g i ▷ W) := by + rw [biproduct.desc_eq, + show (∑ i : J, biproduct.π f i ≫ g i) ▷ W = + (tensorRight W).map (∑ i : J, biproduct.π f i ≫ g i) from rfl, + (tensorRight W).map_sum (fun i => biproduct.π f i ≫ g i) + Finset.univ] + exact Finset.sum_congr rfl fun i _ => + MonoidalCategory.comp_whiskerRight _ _ _ + +end BiproductWhisker + +section Stage + +/-- One slot of the whiskered relation pair is the slot relation of +the longer arity, with one more letter of tail. -/ +private theorem slot_whiskerRight + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + {n : ℕ} (a b : ℕ) + (h : a + 2 + b = n) : + ((modPowLegM A X a b ≫ powCast X h) ▷ X) ≫ + modPowπ A X (n + 1) = + ((modPowLegN A X a b ≫ powCast X h) ▷ X) ≫ + modPowπ A X (n + 1) := by + have key := modPow_rel A X a (b + 1) + (by omega : a + 2 + (b + 1) = n + 1) + rw [modPowLegM_succ, modPowLegN_succ] at key + refine (cancel_epi (α_ (tensorPow D X a ⊗ ((X ⊗ A) ⊗ X)) + (tensorPow D X b) X).inv).1 ?_ + rw [MonoidalCategory.comp_whiskerRight, + MonoidalCategory.comp_whiskerRight, powCast_whiskerRight] + repeat' erw [Category.assoc] + exact ((Category.assoc _ _ _).symm.trans key).trans + (Category.assoc _ _ _) + +/-- **The whiskered relation pair coequalizes one arity up**: the +assembled legs at arity `n`, whiskered by one letter, agree after +the projection at arity `n + 1`. -/ +theorem modPow_condition_succ + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [MonoidalPreadditive D] + [HasFiniteBiproducts D] [HasCoequalizers D] + (n : ℕ) : + (modPowLegFst A X n ▷ X) ≫ modPowπ A X (n + 1) = + (modPowLegSnd A X n ▷ X) ≫ modPowπ A X (n + 1) := by + erw [modPowLegFst, modPowLegSnd, desc_whiskerRight, + desc_whiskerRight, Preadditive.sum_comp, Preadditive.sum_comp] + refine Finset.sum_congr rfl fun i _ => ?_ + repeat' erw [Category.assoc] + have hslot := slot_whiskerRight A X i.val (n - 2 - i.val) (slot_decomp i) + simp only [modPowLegM, modPowLegN, modPowGlue, Category.assoc] at hslot + repeat' erw [Category.assoc] at hslot + exact whisker_eq _ hslot + +/-- **The stage map**: the projection at arity `n + 1` factors +through the projection at arity `n` whiskered by one letter. -/ +noncomputable def modPowStage + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [MonoidalPreadditive D] + [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (n : ℕ) : + modPow A X n ⊗ X ⟶ modPow A X (n + 1) := + modPowWhiskerRightDesc A X n X (modPowπ A X (n + 1)) + (modPow_condition_succ A X n) + +/-- The stage map is the factorisation of the projection at arity +`n + 1` through the whiskered projection at arity `n`. -/ +@[reassoc (attr := simp)] +theorem modPowπ_whiskerRight_stage + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [MonoidalPreadditive D] + [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (n : ℕ) : + (modPowπ A X n ▷ X) ≫ modPowStage A X n = modPowπ A X (n + 1) := + modPowπ_whiskerRight_desc A X n X _ _ + +/-- **An identity invisible at one arity is invisible at the +next**: whiskering by a further letter keeps it invisible. -/ +theorem modPow_invisible_succ + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [MonoidalPreadditive D] + [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (n : ℕ) + {g : tensorPow D X n ⟶ tensorPow D X n} + (hg : g ≫ modPowπ A X n = modPowπ A X n) : + (g ▷ X) ≫ modPowπ A X (n + 1) = modPowπ A X (n + 1) := by + rw [← modPowπ_whiskerRight_stage A X n, ← Category.assoc, + ← MonoidalCategory.comp_whiskerRight, hg] + +end Stage + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModSchur.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModSchur.lean new file mode 100644 index 0000000000..32897dd622 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModSchur.lean @@ -0,0 +1,240 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GrowthDichotomy +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IdemCut +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowCast +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.RowColIdem + +/-! +# Schur vanishing at the module level + +The block decomposition of the symmetric-group algebra acts on +the relative tensor powers of a module through `modPowAlg`; when +every block of one size acts as zero, the completeness of the +blocks collapses the whole power. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {D : Type u} + +/-- **Module-level Schur vanishing**: the block of the shape acts +as zero on the relative tensor power of the module. -/ +def ModSchurKilled [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] + (A : D) [MonObj A] (X : D) [ModObj A X] + (P : SchurPackage.{v}) (μ : YoungDiagram) : + Prop := + modPowAlg A X μ.card (P.e μ) = 0 + +/-- **Module-level upward closure** (Deligne 1.7 over the base): +vanishing of a block's action ascends along containment of +shapes. -/ +theorem ModSchurKilled.mono + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (A : D) [MonObj A] (X : D) [ModObj A X] + (P : SchurPackage.{v}) + {lam mu : YoungDiagram} (hle : lam ≤ mu) + (h : ModSchurKilled A X P lam) : + ModSchurKilled A X P mu := by + by_contra hne + have hcard : lam.card ≤ mu.card := YoungDiagram.card_le_card hle + have hlow : modPowAlg A X mu.card (symCast hcard (P.e lam)) = + 0 := modPowAlg_compat A X hcard _ h + have hz : modPowAlg A X mu.card + (P.e mu * (symCast hcard (P.e lam) * P.e mu)) = 0 := by + rw [map_mul, map_mul, hlow, zero_mul, mul_zero] + have hker := P.block_faithful mu _ (modPowAlg A X mu.card) + hne _ hz + rw [← mul_assoc] at hker + exact P.branching lam mu hle hcard hker + +/-- **Completeness collapses the power**: if every block of one +size acts as zero on the relative power, the power itself +vanishes. -/ +theorem isZero_modPow_of_cuts + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] + (A : D) [MonObj A] (X : D) [ModObj A X] + (P : SchurPackage.{v}) {k : ℕ} + (h : ∀ μ : Shape k, modPowAlg A X k (Shape.e P μ) = 0) : + IsZero (modPow A X k) := by + rw [Limits.IsZero.iff_id_eq_zero, ← End.one_def] + calc (1 : End (modPow A X k)) + = modPowAlg A X k 1 := (map_one _).symm + _ = modPowAlg A X k (∑ μ : Shape k, Shape.e P μ) := by + rw [P.sum_shape_e_eq_one] + _ = ∑ μ : Shape k, modPowAlg A X k (Shape.e P μ) := + map_sum _ _ _ + _ = 0 := Finset.sum_eq_zero fun μ _ => h μ + +/-- **The symmetric power vanishes exactly when the symmetriser +acts as zero.** -/ +theorem symPowIdem_eq_zero_iff + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] + (A : D) [MonObj A] (X : D) [ModObj A X] + (n : ℕ) : + symPowIdem A X n = 0 ↔ IsZero (symPow A X n) := by + constructor + · intro h0 + rw [Limits.IsZero.iff_id_eq_zero, + ← symPowσ_symPowπ A X n] + have hπ : symPowπ A X n = 0 := by + rw [← symPowIdem_π A X n, h0, Limits.zero_comp] + rw [hπ, Limits.comp_zero] + · intro hz + have hσ : symPowσ A X n = 0 := hz.eq_of_src _ _ + rw [← symPowπ_symPowσ A X n, hσ, Limits.comp_zero] + +/-- **A dead symmetric power kills the row block.** -/ +theorem modSchurKilled_row_of_isZero_symPow + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] + (A : D) [MonObj A] (X : D) [ModObj A X] + (P : SchurPackage.{v}) (n : ℕ) + (h : IsZero (symPow A X (n + 1))) : + ModSchurKilled A X P (rowShape (n + 1)).val := by + have h0 : modPowAlg A X (n + 1) (symmetriser (n + 1)) = 0 := + (symPowIdem_eq_zero_iff A X (n + 1)).mpr h + have hgen : ∀ {k : ℕ}, k = n + 1 → + modPowAlg A X k (symmetriser k) = 0 := by + rintro k rfl + exact h0 + rw [ModSchurKilled, P.e_rowShape (n + 1)] + exact hgen (rowShape (n + 1)).prop + +/-- **Row and column kills collapse the whole power** (Deligne +2.9 case (c), module level, Schur half): a module whose row and +column blocks act as zero has vanishing relative power at the +product size. -/ +theorem isZero_modPow_of_row_col + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (A : D) [MonObj A] (X : D) [ModObj A X] + (P : SchurPackage.{v}) + {n m : ℕ} + (hrow : ModSchurKilled A X P (rowShape (n + 1)).val) + (hcol : ModSchurKilled A X P (colShape (m + 1)).val) : + IsZero (modPow A X (n * m + 1)) := by + have hall : ∀ μ : Shape (n * m + 1), + modPowAlg A X (n * m + 1) (Shape.e P μ) = 0 := by + intro μ + have hk : ModSchurKilled A X P μ.val := by + by_cases hr : n + 1 ≤ μ.val.rowLen 0 + · exact ModSchurKilled.mono A X P + (rowShape_le_iff.mpr hr) hrow + · by_cases hc : m + 1 ≤ μ.val.colLen 0 + · exact ModSchurKilled.mono A X P + (colShape_le_iff.mpr hc) hcol + · exfalso + have hcard := card_le_colLen_mul_rowLen μ.val + have := μ.prop + have hbound : μ.val.colLen 0 * μ.val.rowLen 0 ≤ + m * n := + Nat.mul_le_mul (by omega) (by omega) + rw [Nat.mul_comm m n] at hbound + omega + exact modPowAlg_compat A X (le_of_eq μ.prop) _ hk + exact isZero_modPow_of_cuts A X P hall + +/-- **The alternating power vanishes exactly when the +antisymmetriser acts as zero.** -/ +theorem altPowIdem_eq_zero_iff + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] + (A : D) [MonObj A] (X : D) [ModObj A X] + (n : ℕ) : + altPowIdem A X n = 0 ↔ IsZero (altPow A X n) := by + constructor + · intro h0 + rw [Limits.IsZero.iff_id_eq_zero, + ← altPowσ_altPowπ A X n] + have hπ : altPowπ A X n = 0 := by + rw [← altPowIdem_π A X n, h0, Limits.zero_comp] + rw [hπ, Limits.comp_zero] + · intro hz + have hσ : altPowσ A X n = 0 := hz.eq_of_src _ _ + rw [← altPowπ_altPowσ A X n, hσ, Limits.comp_zero] + +/-- **A dead alternating power kills the column block.** -/ +theorem modSchurKilled_col_of_isZero_altPow + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] + (A : D) [MonObj A] (X : D) [ModObj A X] + (P : SchurPackage.{v}) (m : ℕ) + (h : IsZero (altPow A X (m + 1))) : + ModSchurKilled A X P (colShape (m + 1)).val := by + have h0 : modPowAlg A X (m + 1) + (antisymmetriser (m + 1)) = 0 := + (altPowIdem_eq_zero_iff A X (m + 1)).mpr h + have hgen : ∀ {k : ℕ}, k = m + 1 → + modPowAlg A X k (antisymmetriser k) = 0 := by + rintro k rfl + exact h0 + rw [ModSchurKilled, P.e_colShape (m + 1)] + exact hgen (colShape (m + 1)).prop + +/-- **Dead symmetric and alternating powers collapse the relative +power** (Deligne 2.9 case (c), Schur half): the row and column +bridges feed the block collapse. -/ +theorem isZero_modPow_of_isZero_sym_alt + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (A : D) [MonObj A] (X : D) [ModObj A X] + (P : SchurPackage.{v}) {n m : ℕ} + (hs : IsZero (symPow A X (n + 1))) + (ha : IsZero (altPow A X (m + 1))) : + IsZero (modPow A X (n * m + 1)) := + isZero_modPow_of_row_col A X P + (modSchurKilled_row_of_isZero_symPow A X P n hs) + (modSchurKilled_col_of_isZero_altPow A X P m ha) + +/-- **An idempotent's cut vanishes exactly when it acts as +zero.** -/ +theorem modPowCutIdem_eq_zero_iff + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] + (A : D) [MonObj A] (X : D) [ModObj A X] + (n : ℕ) + (e : SymGroupAlgebra n) (he : e * e = e) : + modPowAlg A X n e = 0 ↔ IsZero (modPowCut A X n e) := by + constructor + · intro h0 + rw [Limits.IsZero.iff_id_eq_zero, + ← modPowCutσ_π A X n e he] + have hπ : modPowCutπ A X n e = 0 := by + have h1 : modPowCutIdem A X n e ≫ + modPowCutπ A X n e = modPowCutπ A X n e := + modPowCutIdem_π A X n e + rw [show modPowCutIdem A X n e = + (0 : modPow A X n ⟶ modPow A X n) from h0] at h1 + rw [Limits.zero_comp] at h1 + exact h1.symm + rw [hπ, Limits.comp_zero] + · intro hz + have hσ : modPowCutσ A X n e he = 0 := hz.eq_of_src _ _ + have h := modPowCutπ_σ A X n e he + rw [hσ, Limits.comp_zero] at h + exact h.symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModSchurSummand.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModSchurSummand.lean new file mode 100644 index 0000000000..c21775421e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModSchurSummand.lean @@ -0,0 +1,95 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchur +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod + +/-! +# Module-level Schur vanishing passes to retracts + +A retract of a module inherits the vanishing of a block's action +on the relative tensor powers: the module-power map of the section +is a split monomorphism and intertwines the two actions. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **Module-level Schur vanishing passes to retracts.** -/ +theorem ModSchurKilled.of_split + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] + (A : D) [MonObj A] + {X Y : D} [ModObj A X] [ModObj A Y] + (s : X ⟶ Y) [IsModHom A s] (r : Y ⟶ X) [IsModHom A r] + (hsr : s ≫ r = 𝟙 X) (P : SchurPackage.{v}) + {lam : YoungDiagram} (h : ModSchurKilled A Y P lam) : + ModSchurKilled A X P lam := by + have hmap : modPowMap A s lam.card ≫ modPowMap A r lam.card = + 𝟙 (modPow A X lam.card) := by + apply modPow_hom_ext A X + rw [modPowπ_map_assoc, modPowπ_map, Category.comp_id, + ← Category.assoc, ← tensorPowMap_comp, hsr, tensorPowMap_id, + Category.id_comp] + have key : (modPowAlg A X lam.card (P.e lam) : + modPow A X lam.card ⟶ modPow A X lam.card) ≫ + modPowMap A s lam.card = 0 := by + rw [← modPowMap_alg A s lam.card (P.e lam), h] + exact Limits.comp_zero + have hpost := congrArg + (fun t => t ≫ modPowMap A r lam.card) key + simp only [Category.assoc, hmap, Category.comp_id, + Limits.zero_comp] at hpost + exact hpost + +attribute [local instance] + hasBinaryBiproducts_of_finite_biproducts + +/-- **Module-level Schur vanishing passes to the first biproduct +summand.** -/ +theorem ModSchurKilled.of_biprod_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] (A : D) [MonObj A] + (M N : Mod D A) + (P : SchurPackage.{v}) {lam : YoungDiagram} + (h : ModSchurKilled A (modBiprod A M N).X P lam) : + ModSchurKilled A M.X P lam := by + have := (modBiprodInl A M N).isModHom + have := (modBiprodFst A M N).isModHom + refine ModSchurKilled.of_split A (modBiprodInl A M N).hom + (modBiprodFst A M N).hom ?_ P h + change (biprod.inl : M.X ⟶ M.X ⊞ N.X) ≫ biprod.fst = 𝟙 M.X + exact biprod.inl_fst + +/-- **Module-level Schur vanishing is invariant under +isomorphism.** -/ +theorem ModSchurKilled.of_modIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] + (A : D) [MonObj A] + {M N : Mod D A} (e : M ≅ N) + (P : SchurPackage.{v}) {lam : YoungDiagram} + (h : ModSchurKilled A N.X P lam) : + ModSchurKilled A M.X P lam := by + have := e.hom.isModHom + have := e.inv.isModHom + refine ModSchurKilled.of_split A e.hom.hom e.inv.hom ?_ P h + have h1 := congrArg Mod.Hom.hom e.hom_inv_id + rw [Mod.comp_hom', Mod.id_hom'] at h1 + exact h1 + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModTensor.lean new file mode 100644 index 0000000000..ce6d5be2a0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModTensor.lean @@ -0,0 +1,1106 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Tensor product of internal modules over a commutative monoid + +Module theory over a monoid object, after Deligne (2002), §§2.2–2.3. +Throughout, `D` is a monoidal category and `A : D` a monoid object +in Mathlib's internal sense: `MonObj A`, with internal left modules +given by `ModObj A X` over the self-action of `D` and bundled as +`Mod D A`. + +* `actLeft`: the action morphism of a module object, typed at the + tensor product `A ⊗ X` rather than at the action synonym `⊙ₗ`, + with the module laws restated in this form. +* `tensorRightModObj`: a left module tensored with an object on the + right is again a left module; `freeModObj`/`freeMod` specialize to + the free module `A ⊗ V`. The regular module is Mathlib's + `Mod.regular A`. +* `actRight`: on a left module over a commutative monoid in a + braided category, the braiding induces a right action; the + compatibility lemmas `actLeft_actRight` and `actRight_actRight` + express that left and right actions commute and that `actRight` + is associative. +* `modTensor A M N`: the tensor product of modules, the coequalizer + of the pair `(M.X ⊗ A) ⊗ N.X ⇉ M.X ⊗ N.X` whose first leg + `modTensorLegM` acts on `M` through `actRight` and whose second + leg `modTensorLegN` associates and acts on `N`. +* `modTensorModObj`: the `A`-action descends to the coequalizer + when every `tensorLeft X` preserves coequalizers; more generally + `modTensorDescModObj` descends any monoid action on `M.X` that + commutes with `actRight`. +* `modTensorUnitLeft`/`modTensorUnitRight`: the regular module is a + two-sided unit, compatibly with the actions. +* `modTensorMap`: functoriality in both slots. +* `restrictRegular`/`baseChange`: base change along a morphism of + commutative monoid objects. + +The development is scoped to the structures above; associativity of +`modTensor` is outside this module's scope. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +section ActLeft + +/-- The action morphism of a module object, typed at the tensor +product. -/ +def actLeft [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X : D) [ModObj A X] : A ⊗ X ⟶ X := + γ[A, X] + +/-- Unitality of the action, in tensor form. -/ +@[reassoc (attr := simp)] +lemma one_actLeft [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X : D) [ModObj A X] : + η[A] ▷ X ≫ actLeft A X = (λ_ X).hom := + ModObj.one_smul_self A X + +/-- Associativity of the action, in tensor form. -/ +@[reassoc] +lemma mul_actLeft [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X : D) [ModObj A X] : + μ[A] ▷ X ≫ actLeft A X = + (α_ A A X).hom ≫ A ◁ actLeft A X ≫ actLeft A X := + ModObj.mul_smul_self A X + +/-- Associativity of the action, associator on the right. -/ +@[reassoc] +lemma actLeft_actLeft [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X : D) [ModObj A X] : + A ◁ actLeft A X ≫ actLeft A X = + (α_ A A X).inv ≫ μ[A] ▷ X ≫ actLeft A X := + ModObj.mul_smul_self_flip (M := A) (X := X) + +/-- `actLeft` is natural in module morphisms. -/ +@[reassoc (attr := simp)] +lemma actLeft_natural [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X Y : D) [ModObj A X] [ModObj A Y] + (f : X ⟶ Y) [IsModHom A f] : + actLeft A X ≫ f = A ◁ f ≫ actLeft A Y := + IsModHom.smul_hom + +/-- The regular module, with underlying object reducibly `A`; it is +definitionally Mathlib's `Mod.regular A`. -/ +@[reducible] +def regularMod + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] : Mod D A := + letI := ModObj.regular A + ⟨A⟩ + +end ActLeft + +section TensorRight + +/-- Unitality of an action transported to a right tensor factor. -/ +lemma one_act_tensorRight + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X : D) (act : A ⊗ X ⟶ X) + (hone : η[A] ▷ X ≫ act = (λ_ X).hom) (V : D) : + η[A] ▷ (X ⊗ V) ≫ ((α_ A X V).inv ≫ act ▷ V) = + (λ_ (X ⊗ V)).hom := by + rw [associator_inv_naturality_left_assoc, ← comp_whiskerRight, + hone, ← leftUnitor_tensor_hom] + +/-- Associativity of an action transported to a right tensor +factor. -/ +lemma mul_act_tensorRight + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X : D) (act : A ⊗ X ⟶ X) + (hmul : μ[A] ▷ X ≫ act = + (α_ A A X).hom ≫ A ◁ act ≫ act) (V : D) : + μ[A] ▷ (X ⊗ V) ≫ ((α_ A X V).inv ≫ act ▷ V) = + (α_ A A (X ⊗ V)).hom ≫ + A ◁ ((α_ A X V).inv ≫ act ▷ V) ≫ + (α_ A X V).inv ≫ act ▷ V := by + rw [associator_inv_naturality_left_assoc, ← comp_whiskerRight, + hmul] + simp only [comp_whiskerRight, whiskerLeft_comp, Category.assoc, + associator_inv_naturality_middle_assoc] + monoidal + +/-- A left module tensored with an object on the right: the action +of `A` on `X ⊗ V` through the left factor. -/ +@[implicit_reducible] +def tensorRightModObj [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X : D) [ModObj A X] (V : D) : + ModObj A (X ⊗ V) where + smul := (α_ A X V).inv ≫ actLeft A X ▷ V + one_smul := one_act_tensorRight A X (actLeft A X) + (one_actLeft A X) V + mul_smul := mul_act_tensorRight A X (actLeft A X) + (mul_actLeft A X) V + +@[simp] lemma tensorRightModObj_smul + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (X : D) [ModObj A X] (V : D) : + (tensorRightModObj A X V).smul = + (α_ A X V).inv ≫ actLeft A X ▷ V := + rfl + +/-- The free module on an object: `A ⊗ V` with the action given by +multiplication on the left factor. -/ +@[implicit_reducible] +def freeModObj [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (V : D) : ModObj A (A ⊗ V) := + letI := ModObj.regular A + tensorRightModObj A A V + +/-- Inserting the unit of `A` and then acting on the free module +is the identity. -/ +theorem whiskerLeft_one_mul + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (W : D) : + A ◁ ((λ_ W).inv ≫ η[A] ▷ W) ≫ ((α_ A A W).inv ≫ μ[A] ▷ W) = + 𝟙 (A ⊗ W) := by + rw [MonoidalCategory.whiskerLeft_comp, Category.assoc, + associator_inv_naturality_middle_assoc A (η[A]) W, + ← comp_whiskerRight, MonObj.mul_one] + monoidal + +/-- The free module on an object, bundled. -/ +def freeMod [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (V : D) : Mod D A := + letI := freeModObj A V + ⟨A ⊗ V⟩ + +/-- The carrier of the free module. This is definitional, and is +stated for use by name: as a `simp` rule it would rewrite the type +arguments of every application of the module interface at a free +module and so stop that interface firing. -/ +lemma freeMod_X [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + (V : D) : (freeMod A V).X = A ⊗ V := rfl + +end TensorRight + +section RightAction + +/-- The right action of `A` on a left module, induced by the +braiding. -/ +def actRight [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] + (X : D) [ModObj A X] : X ⊗ A ⟶ X := + (β_ X A).hom ≫ actLeft A X + +/-- Unitality of the braided right action. -/ +@[reassoc] +lemma actRight_one [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] + (X : D) [ModObj A X] : + X ◁ η[A] ≫ actRight A X = (ρ_ X).hom := by + simp [actRight, braiding_tensorUnit_right] + +/-- `actRight` is natural in module morphisms. -/ +@[reassoc] +lemma actRight_natural [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] + (X Y : D) [ModObj A X] [ModObj A Y] + (f : X ⟶ Y) [IsModHom A f] : + actRight A X ≫ f = f ▷ A ≫ actRight A Y := by + simp [actRight] + +/-- `actRight` is natural in maps of module objects. -/ +@[reassoc] +lemma actRight_natural_mod + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] + {M N : Mod D A} (f : M ⟶ N) : + actRight A M.X ≫ f.hom = f.hom ▷ A ≫ actRight A N.X := by + have := f.isModHom + exact actRight_natural A M.X N.X f.hom + +/-- **The shuffle of two free modules**: multiply the two algebra +factors, having carried the first generator past the second +algebra factor. This is at once the head absorption that folds an +incoming free letter into an accumulated head. -/ +def freeModShuffle [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] + (V W : D) : (A ⊗ V) ⊗ (A ⊗ W) ⟶ A ⊗ (V ⊗ W) := + tensorμ A V A W ≫ μ[A] ▷ (V ⊗ W) + +/-- Two-sided compatibility for a commutative monoid: the left +action and the braided right action on a module commute. -/ +@[reassoc] +lemma actLeft_actRight [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] + (X : D) [ModObj A X] [IsCommMonObj A] : + A ◁ actRight A X ≫ actLeft A X = + (α_ A X A).inv ≫ actLeft A X ▷ A ≫ actRight A X := by + simp only [actRight, whiskerLeft_comp, Category.assoc, actLeft_actLeft, + BraidedCategory.braiding_naturality_left_assoc, BraidedCategory.braiding_tensor_left_hom, + Iso.hom_inv_id_assoc, Iso.inv_hom_id_assoc] + rw [← comp_whiskerRight_assoc, IsCommMonObj.mul_comm] + +/-- For a commutative monoid, the braided right action is +associative. -/ +@[reassoc] +lemma actRight_actRight [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] + (X : D) [ModObj A X] [IsCommMonObj A] : + actRight A X ▷ A ≫ actRight A X = + (α_ X A A).hom ≫ X ◁ μ[A] ≫ actRight A X := by + simp only [actRight, comp_whiskerRight, Category.assoc, + BraidedCategory.braiding_naturality_left_assoc, BraidedCategory.braiding_tensor_left_hom, + actLeft_actLeft, Iso.hom_inv_id_assoc, BraidedCategory.braiding_naturality_right_assoc, + BraidedCategory.braiding_tensor_right_hom] + rw [← comp_whiskerRight_assoc, IsCommMonObj.mul_comm] + +end RightAction + +section ModTensor + +/-- First leg of the module-tensor parallel pair on +`(M.X ⊗ A) ⊗ N.X`: act on `M` through the braided right action. -/ +def modTensorLegM [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (M : Mod D A) (N : Mod D A) : + (M.X ⊗ A) ⊗ N.X ⟶ M.X ⊗ N.X := + actRight A M.X ▷ N.X + +/-- Second leg of the module-tensor parallel pair on +`(M.X ⊗ A) ⊗ N.X`: associate and act on `N`. -/ +def modTensorLegN + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (M : Mod D A) + (N : Mod D A) : (M.X ⊗ A) ⊗ N.X ⟶ M.X ⊗ N.X := + (α_ M.X A N.X).hom ≫ M.X ◁ actLeft A N.X + +/-- A `P`-action on `M.X` commuting with the braided right +`A`-action intertwines the first leg with the induced actions on +`(M.X ⊗ A) ⊗ N.X` and `M.X ⊗ N.X`. -/ +lemma whiskerLeft_modTensorLegM_act + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (M : Mod D A) (N : Mod D A) + (P : D) + (act : P ⊗ M.X ⟶ M.X) + (compat : P ◁ actRight A M.X ≫ act = + (α_ P M.X A).inv ≫ act ▷ A ≫ actRight A M.X) : + P ◁ modTensorLegM A M N ≫ + ((α_ P M.X N.X).inv ≫ act ▷ N.X) = + ((α_ P (M.X ⊗ A) N.X).inv ≫ + ((α_ P M.X A).inv ≫ act ▷ A) ▷ N.X) ≫ + modTensorLegM A M N := by + rw [modTensorLegM, associator_inv_naturality_middle_assoc, + ← comp_whiskerRight, compat] + simp + +/-- Any morphism `P ⊗ M.X ⟶ M.X` intertwines the second leg with +the induced maps on `(M.X ⊗ A) ⊗ N.X` and `M.X ⊗ N.X`. -/ +lemma whiskerLeft_modTensorLegN_act + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (M : Mod D A) + (N : Mod D A) + (P : D) + (act : P ⊗ M.X ⟶ M.X) : + P ◁ modTensorLegN A M N ≫ + ((α_ P M.X N.X).inv ≫ act ▷ N.X) = + ((α_ P (M.X ⊗ A) N.X).inv ≫ + ((α_ P M.X A).inv ≫ act ▷ A) ▷ N.X) ≫ + modTensorLegN A M N := by + have hstruct : + P ◁ (α_ M.X A N.X).hom ≫ (α_ P M.X (A ⊗ N.X)).inv = + (α_ P (M.X ⊗ A) N.X).inv ≫ (α_ P M.X A).inv ▷ N.X ≫ + (α_ (P ⊗ M.X) A N.X).hom := by + monoidal + rw [modTensorLegN] + simp only [whiskerLeft_comp, comp_whiskerRight, Category.assoc] + conv_lhs => rw [associator_inv_naturality_right_assoc, + whisker_exchange] + conv_rhs => rw [associator_naturality_left_assoc] + rw [reassoc_of% hstruct] + +section + +/-- The tensor product of two modules over `A`: the coequalizer of +`modTensorLegM` and `modTensorLegN`. -/ +noncomputable def modTensor + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (M : Mod D A) (N : Mod D A) [HasCoequalizers D] : D := + coequalizer (modTensorLegM A M N) (modTensorLegN A M N) + +/-- The projection onto the tensor product of modules. -/ +noncomputable def modTensorπ + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (M : Mod D A) (N : Mod D A) [HasCoequalizers D] : + M.X ⊗ N.X ⟶ modTensor A M N := + coequalizer.π _ _ + +/-- The two legs agree after the projection. -/ +@[reassoc] +lemma modTensor_condition + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (M : Mod D A) (N : Mod D A) [HasCoequalizers D] : + modTensorLegM A M N ≫ modTensorπ A M N = + modTensorLegN A M N ≫ modTensorπ A M N := + coequalizer.condition _ _ + +/-- Descend a morphism coequalizing the two legs to the tensor +product of modules. -/ +noncomputable def modTensorDesc + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (M : Mod D A) (N : Mod D A) [HasCoequalizers D] + {W : D} (k : M.X ⊗ N.X ⟶ W) + (h : modTensorLegM A M N ≫ k = modTensorLegN A M N ≫ k) : + modTensor A M N ⟶ W := + coequalizer.desc k h + +/-- The descent factors the given morphism through the +projection. -/ +@[reassoc (attr := simp)] +lemma modTensorπ_desc [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (M : Mod D A) (N : Mod D A) [HasCoequalizers D] + {W : D} (k : M.X ⊗ N.X ⟶ W) + (h : modTensorLegM A M N ≫ k = modTensorLegN A M N ≫ k) : + modTensorπ A M N ≫ modTensorDesc A M N k h = k := + coequalizer.π_desc _ _ + +/-- Morphisms out of the tensor product of modules are determined +by their composite with the projection. -/ +lemma modTensor_hom_ext [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (M : Mod D A) (N : Mod D A) [HasCoequalizers D] + {W : D} {k l : modTensor A M N ⟶ W} + (h : modTensorπ A M N ≫ k = modTensorπ A M N ≫ l) : k = l := + coequalizer.hom_ext h + +end + +section + +/-- Whiskering the module-tensor coequalizer by `tensorLeft P` +yields a colimit cofork. -/ +noncomputable def modTensorWhiskerIsColimit + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (M : Mod D A) (N : Mod D A) [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (P : D) : + IsColimit (Cofork.ofπ (P ◁ modTensorπ A M N) + (by rw [← whiskerLeft_comp, modTensor_condition, + whiskerLeft_comp]) : + Cofork (P ◁ modTensorLegM A M N) (P ◁ modTensorLegN A M N)) := + isColimitOfHasCoequalizerOfPreservesColimit (tensorLeft P) _ _ + +/-- Morphisms out of a whiskered tensor product of modules are +determined by their composite with the whiskered projection. -/ +lemma modTensor_whisker_hom_ext + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (M : Mod D A) (N : Mod D A) [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (P : D) {W : D} + {k l : P ⊗ modTensor A M N ⟶ W} + (h : P ◁ modTensorπ A M N ≫ k = P ◁ modTensorπ A M N ≫ l) : + k = l := + Cofork.IsColimit.hom_ext (modTensorWhiskerIsColimit A M N P) h + +/-- Descend a morphism along the whiskered coequalizer. -/ +noncomputable def modTensorWhiskerDesc + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (M : Mod D A) (N : Mod D A) [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (P : D) {W : D} + (k : P ⊗ (M.X ⊗ N.X) ⟶ W) + (h : P ◁ modTensorLegM A M N ≫ k = + P ◁ modTensorLegN A M N ≫ k) : + P ⊗ modTensor A M N ⟶ W := + Cofork.IsColimit.desc (modTensorWhiskerIsColimit A M N P) k h + +/-- The whiskered descent factors the given morphism through the +whiskered projection. -/ +@[reassoc (attr := simp)] +lemma whiskerLeft_modTensorπ_whiskerDesc + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (M : Mod D A) (N : Mod D A) [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (P : D) {W : D} + (k : P ⊗ (M.X ⊗ N.X) ⟶ W) + (h : P ◁ modTensorLegM A M N ≫ k = + P ◁ modTensorLegN A M N ≫ k) : + P ◁ modTensorπ A M N ≫ modTensorWhiskerDesc A M N P k h = k := + Cofork.IsColimit.π_desc' (modTensorWhiskerIsColimit A M N P) k h + +end + +section WhiskerRKit + +/-- Whiskering the module-tensor coequalizer by `tensorRight W` +yields a colimit cofork. -/ +noncomputable def modTensorWhiskerRIsColimit + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (M : Mod D A) (N : Mod D A) + [Limits.HasCoequalizers D] + [∀ Z : D, Limits.PreservesColimitsOfShape Limits.WalkingParallelPair + (tensorRight Z)] + (W : D) : + IsColimit (Cofork.ofπ (modTensorπ A M N ▷ W) + (by rw [← comp_whiskerRight, modTensor_condition, + comp_whiskerRight]) : + Cofork (modTensorLegM A M N ▷ W) + (modTensorLegN A M N ▷ W)) := + isColimitOfHasCoequalizerOfPreservesColimit (tensorRight W) _ _ + +/-- Morphisms out of a right-whiskered tensor product of modules +are determined by their composite with the whiskered +projection. -/ +lemma modTensor_whiskerR_hom_ext + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (M : Mod D A) (N : Mod D A) + [Limits.HasCoequalizers D] + [∀ Z : D, Limits.PreservesColimitsOfShape Limits.WalkingParallelPair + (tensorRight Z)] + (W : D) {Z : D} + {k l : modTensor A M N ⊗ W ⟶ Z} + (h : (modTensorπ A M N ▷ W) ≫ k = + (modTensorπ A M N ▷ W) ≫ l) : + k = l := + Cofork.IsColimit.hom_ext + (modTensorWhiskerRIsColimit A M N W) h + +/-- Descend a morphism along the right-whiskered coequalizer. -/ +noncomputable def modTensorWhiskerRDesc + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (M : Mod D A) (N : Mod D A) + [Limits.HasCoequalizers D] + [∀ Z : D, Limits.PreservesColimitsOfShape Limits.WalkingParallelPair + (tensorRight Z)] + (W : D) {Z : D} + (k : (M.X ⊗ N.X) ⊗ W ⟶ Z) + (h : (modTensorLegM A M N ▷ W) ≫ k = + (modTensorLegN A M N ▷ W) ≫ k) : + modTensor A M N ⊗ W ⟶ Z := + Cofork.IsColimit.desc + (modTensorWhiskerRIsColimit A M N W) k h + +/-- The right-whiskered descent factors the given morphism +through the whiskered projection. -/ +@[reassoc (attr := simp)] +lemma whiskerRight_modTensorπ_whiskerRDesc + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (M : Mod D A) (N : Mod D A) + [Limits.HasCoequalizers D] + [∀ Z : D, Limits.PreservesColimitsOfShape Limits.WalkingParallelPair + (tensorRight Z)] + (W : D) {Z : D} + (k : (M.X ⊗ N.X) ⊗ W ⟶ Z) + (h : (modTensorLegM A M N ▷ W) ≫ k = + (modTensorLegN A M N ▷ W) ≫ k) : + (modTensorπ A M N ▷ W) ≫ + modTensorWhiskerRDesc A M N W k h = k := + Cofork.IsColimit.π_desc' + (modTensorWhiskerRIsColimit A M N W) k h + +end WhiskerRKit + +end ModTensor + +section DescAct + +/-- Descend a compatible action along the module-tensor +projection. -/ +noncomputable def modTensorDescAct + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (M : Mod D A) (N : Mod D A) [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (P : D) + (act : P ⊗ M.X ⟶ M.X) + (compat : P ◁ actRight A M.X ≫ act = + (α_ P M.X A).inv ≫ act ▷ A ≫ actRight A M.X) : + P ⊗ modTensor A M N ⟶ modTensor A M N := + modTensorWhiskerDesc A M N P + (((α_ P M.X N.X).inv ≫ act ▷ N.X) ≫ modTensorπ A M N) + (by + conv_lhs => rw [← Category.assoc, + whiskerLeft_modTensorLegM_act A M N P act compat, + Category.assoc, modTensor_condition] + conv_rhs => rw [← Category.assoc, + whiskerLeft_modTensorLegN_act A M N P act, + Category.assoc]) + +/-- Defining equation of the descended action. -/ +@[reassoc (attr := simp)] +lemma whiskerLeft_modTensorπ_descAct + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (M : Mod D A) (N : Mod D A) [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (P : D) + (act : P ⊗ M.X ⟶ M.X) + (compat : P ◁ actRight A M.X ≫ act = + (α_ P M.X A).inv ≫ act ▷ A ≫ actRight A M.X) : + P ◁ modTensorπ A M N ≫ modTensorDescAct A M N P act compat = + ((α_ P M.X N.X).inv ≫ act ▷ N.X) ≫ modTensorπ A M N := + whiskerLeft_modTensorπ_whiskerDesc A M N P _ _ + +/-- Unitality descends to the tensor product of modules. -/ +lemma modTensorDescAct_one + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (M : Mod D A) (N : Mod D A) [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (P : D) [MonObj P] + (act : P ⊗ M.X ⟶ M.X) + (compat : P ◁ actRight A M.X ≫ act = + (α_ P M.X A).inv ≫ act ▷ A ≫ actRight A M.X) + (hone : η[P] ▷ M.X ≫ act = (λ_ M.X).hom) : + η[P] ▷ modTensor A M N ≫ modTensorDescAct A M N P act compat = + (λ_ (modTensor A M N)).hom := by + apply modTensor_whisker_hom_ext A M N (𝟙_ D) + have h1 := one_act_tensorRight P M.X act hone N.X + rw [whisker_exchange_assoc, whiskerLeft_modTensorπ_descAct] + simp only [Category.assoc] + rw [reassoc_of% h1] + simp + +/-- Associativity descends to the tensor product of modules. -/ +lemma modTensorDescAct_mul + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (M : Mod D A) (N : Mod D A) [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (P : D) [MonObj P] + (act : P ⊗ M.X ⟶ M.X) + (compat : P ◁ actRight A M.X ≫ act = + (α_ P M.X A).inv ≫ act ▷ A ≫ actRight A M.X) + (hmul : μ[P] ▷ M.X ≫ act = + (α_ P P M.X).hom ≫ P ◁ act ≫ act) : + μ[P] ▷ modTensor A M N ≫ modTensorDescAct A M N P act compat = + (α_ P P (modTensor A M N)).hom ≫ + P ◁ modTensorDescAct A M N P act compat ≫ + modTensorDescAct A M N P act compat := by + apply modTensor_whisker_hom_ext A M N (P ⊗ P) + have h2 := mul_act_tensorRight P M.X act hmul N.X + conv_lhs => rw [whisker_exchange_assoc, + whiskerLeft_modTensorπ_descAct] + conv_rhs => rw [associator_naturality_right_assoc, + ← whiskerLeft_comp_assoc, + whiskerLeft_modTensorπ_descAct A M N P act compat, + whiskerLeft_comp_assoc, + whiskerLeft_modTensorπ_descAct A M N P act compat] + simp only [Category.assoc] + rw [reassoc_of% h2] + +/-- The descended action intertwines descended morphisms with +actions on the target: if `k` coequalizes the legs and carries the +induced action on `M.X ⊗ N.X` to `w`, then the descent of `k` is +equivariant. -/ +lemma modTensorDescAct_desc + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (M : Mod D A) (N : Mod D A) [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (P : D) + (act : P ⊗ M.X ⟶ M.X) + (compat : P ◁ actRight A M.X ≫ act = + (α_ P M.X A).inv ≫ act ▷ A ≫ actRight A M.X) + {W : D} (k : M.X ⊗ N.X ⟶ W) + (hk : modTensorLegM A M N ≫ k = modTensorLegN A M N ≫ k) + (w : P ⊗ W ⟶ W) + (hw : (α_ P M.X N.X).inv ≫ act ▷ N.X ≫ k = P ◁ k ≫ w) : + modTensorDescAct A M N P act compat ≫ + modTensorDesc A M N k hk = + P ◁ modTensorDesc A M N k hk ≫ w := by + apply modTensor_whisker_hom_ext A M N P + conv_lhs => rw [whiskerLeft_modTensorπ_descAct_assoc, + modTensorπ_desc, hw] + conv_rhs => rw [← whiskerLeft_comp_assoc, modTensorπ_desc] + +/-- Descend a compatible monoid action on `M.X` to a module +structure on the tensor product. -/ +@[implicit_reducible] +noncomputable def modTensorDescModObj + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] (M : Mod D A) (N : Mod D A) [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (P : D) [MonObj P] + (act : P ⊗ M.X ⟶ M.X) + (compat : P ◁ actRight A M.X ≫ act = + (α_ P M.X A).inv ≫ act ▷ A ≫ actRight A M.X) + (hone : η[P] ▷ M.X ≫ act = (λ_ M.X).hom) + (hmul : μ[P] ▷ M.X ≫ act = + (α_ P P M.X).hom ≫ P ◁ act ≫ act) : + ModObj P (modTensor A M N) where + smul := modTensorDescAct A M N P act compat + one_smul := modTensorDescAct_one A M N P act compat hone + mul_smul := modTensorDescAct_mul A M N P act compat hmul + +end DescAct + +section TensorModule + +/-- The `A`-module structure on the tensor product of modules over +a commutative monoid: the action on the `M`-factor descends. -/ +@[implicit_reducible] +noncomputable def modTensorModObj + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] : + ModObj A (modTensor A M N) := + modTensorDescModObj A M N A (actLeft A M.X) + (actLeft_actRight A M.X) (one_actLeft A M.X) (mul_actLeft A M.X) + +/-- The action of `A` on the tensor product of modules. -/ +noncomputable def modTensorAct + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] : + A ⊗ modTensor A M N ⟶ modTensor A M N := + (modTensorModObj A M N).smul + +/-- Defining equation of the `A`-action on the tensor product of +modules. -/ +@[reassoc (attr := simp)] +lemma whiskerLeft_modTensorπ_act + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] : + A ◁ modTensorπ A M N ≫ modTensorAct A M N = + ((α_ A M.X N.X).inv ≫ actLeft A M.X ▷ N.X) ≫ + modTensorπ A M N := + whiskerLeft_modTensorπ_descAct A M N A (actLeft A M.X) + (actLeft_actRight A M.X) + +/-- Unitality of the descended action. -/ +lemma modTensorAct_one [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] : + η[A] ▷ modTensor A M N ≫ modTensorAct A M N = + (λ_ (modTensor A M N)).hom := + modTensorDescAct_one A M N A (actLeft A M.X) + (actLeft_actRight A M.X) (one_actLeft A M.X) + +/-- Associativity of the descended action. -/ +lemma modTensorAct_mul [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] : + μ[A] ▷ modTensor A M N ≫ modTensorAct A M N = + (α_ A A (modTensor A M N)).hom ≫ + A ◁ modTensorAct A M N ≫ modTensorAct A M N := + modTensorDescAct_mul A M N A (actLeft A M.X) + (actLeft_actRight A M.X) (mul_actLeft A M.X) + +/-- The tensor product of modules, bundled as a module. -/ +noncomputable def modTensorMod + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] : + Mod D A := + letI := modTensorModObj A M N + ⟨modTensor A M N⟩ + +/-- The carrier of the bundled tensor product. Definitional, and +stated for use by name, for the reason given for `freeMod_X`. -/ +lemma modTensorMod_X [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] : + (modTensorMod A M N).X = modTensor A M N := rfl + +end TensorModule + +section ActSnd + +/-- **The descended action through the second factor**: over a +symmetric base, the monoid braids past the first module and acts +on the second. The balance relation of the coequalizer carries +the first-factor action across. -/ +@[reassoc] +lemma whiskerLeft_modTensorπ_act_snd + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [SymmetricCategory D] [IsCommMonObj A] (M : Mod D A) (N : Mod D A) + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] : + A ◁ modTensorπ A M N ≫ modTensorAct A M N = + (α_ A M.X N.X).inv ≫ ((β_ A M.X).hom ▷ N.X) ≫ + (α_ M.X A N.X).hom ≫ (M.X ◁ actLeft A N.X) ≫ + modTensorπ A M N := by + rw [whiskerLeft_modTensorπ_act] + simp only [Category.assoc] + rw [cancel_epi] + have hact : actLeft A M.X ▷ N.X = + ((β_ A M.X).hom ▷ N.X) ≫ modTensorLegM A M N := by + rw [modTensorLegM, actRight, + ← MonoidalCategory.comp_whiskerRight, + SymmetricCategory.symmetry_assoc] + rw [hact, Category.assoc, modTensor_condition, modTensorLegN] + simp only [Category.assoc] + +end ActSnd + +section Units + +/-- The action of `N` coequalizes the legs at `M = A`. -/ +lemma modTensorLegM_regular_actLeft + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] (N : Mod D A) : + modTensorLegM A (regularMod A) N ≫ actLeft A N.X = + modTensorLegN A (regularMod A) N ≫ actLeft A N.X := by + change ((β_ A A).hom ≫ μ[A]) ▷ N.X ≫ actLeft A N.X = + ((α_ A A N.X).hom ≫ A ◁ actLeft A N.X) ≫ actLeft A N.X + rw [IsCommMonObj.mul_comm, mul_actLeft, Category.assoc] + +/-- The right action of `M` coequalizes the legs at `N = A`. -/ +lemma modTensorLegM_regular_actRight + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] (M : Mod D A) : + modTensorLegM A M (regularMod A) ≫ actRight A M.X = + modTensorLegN A M (regularMod A) ≫ actRight A M.X := by + change actRight A M.X ▷ A ≫ actRight A M.X = + ((α_ M.X A A).hom ≫ M.X ◁ μ[A]) ≫ actRight A M.X + rw [actRight_actRight, Category.assoc] + +/-- The regular module is a left unit for the module tensor +product. -/ +@[simps] +noncomputable def modTensorUnitLeft + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] (N : Mod D A) [HasCoequalizers D] : + modTensor A (regularMod A) N ≅ N.X where + hom := modTensorDesc A (regularMod A) N (actLeft A N.X) + (modTensorLegM_regular_actLeft A N) + inv := (λ_ N.X).inv ≫ η[A] ▷ N.X ≫ modTensorπ A (regularMod A) N + hom_inv_id := by + have hM : (((λ_ A).inv ≫ η[A] ▷ A) ▷ N.X) ≫ + modTensorLegM A (regularMod A) N = 𝟙 (A ⊗ N.X) := by + change (((λ_ A).inv ≫ η[A] ▷ A) ▷ N.X) ≫ + ((β_ A A).hom ≫ μ[A]) ▷ N.X = 𝟙 (A ⊗ N.X) + rw [← comp_whiskerRight, IsCommMonObj.mul_comm] + simp + have hN : (((λ_ A).inv ≫ η[A] ▷ A) ▷ N.X) ≫ + modTensorLegN A (regularMod A) N = + actLeft A N.X ≫ (λ_ N.X).inv ≫ η[A] ▷ N.X := by + change (((λ_ A).inv ≫ η[A] ▷ A) ▷ N.X) ≫ + ((α_ A A N.X).hom ≫ A ◁ actLeft A N.X) = + actLeft A N.X ≫ (λ_ N.X).inv ≫ η[A] ▷ N.X + simp only [comp_whiskerRight, Category.assoc] + rw [associator_naturality_left_assoc, ← whisker_exchange, + ← leftUnitor_tensor_inv_assoc, + ← leftUnitor_inv_naturality_assoc] + apply modTensor_hom_ext + rw [modTensorπ_desc_assoc, ← reassoc_of% hN, + ← modTensor_condition, reassoc_of% hM] + simp + inv_hom_id := by simp + +/-- The regular module is a right unit for the module tensor +product of a commutative monoid. -/ +@[simps] +noncomputable def modTensorUnitRight + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] (M : Mod D A) [HasCoequalizers D] : + modTensor A M (regularMod A) ≅ M.X where + hom := modTensorDesc A M (regularMod A) (actRight A M.X) + (modTensorLegM_regular_actRight A M) + inv := (ρ_ M.X).inv ≫ M.X ◁ η[A] ≫ modTensorπ A M (regularMod A) + hom_inv_id := by + have hM : ((ρ_ (M.X ⊗ A)).inv ≫ (M.X ⊗ A) ◁ η[A]) ≫ + modTensorLegM A M (regularMod A) = + actRight A M.X ≫ (ρ_ M.X).inv ≫ M.X ◁ η[A] := by + change ((ρ_ (M.X ⊗ A)).inv ≫ (M.X ⊗ A) ◁ η[A]) ≫ + actRight A M.X ▷ A = + actRight A M.X ≫ (ρ_ M.X).inv ≫ M.X ◁ η[A] + rw [Category.assoc, whisker_exchange, + ← rightUnitor_inv_naturality_assoc] + have hN : ((ρ_ (M.X ⊗ A)).inv ≫ (M.X ⊗ A) ◁ η[A]) ≫ + modTensorLegN A M (regularMod A) = 𝟙 (M.X ⊗ A) := by + change ((ρ_ (M.X ⊗ A)).inv ≫ (M.X ⊗ A) ◁ η[A]) ≫ + ((α_ M.X A A).hom ≫ M.X ◁ μ[A]) = 𝟙 (M.X ⊗ A) + simp only [Category.assoc] + rw [associator_naturality_right_assoc, ← whiskerLeft_comp, + MonObj.mul_one, ← rightUnitor_tensor_hom] + simp + apply modTensor_hom_ext + rw [modTensorπ_desc_assoc, ← reassoc_of% hM, + modTensor_condition, reassoc_of% hN] + simp + inv_hom_id := by simp [actRight_one] + +/-- The left unit isomorphism is a morphism of modules. -/ +@[reassoc] +lemma modTensorUnitLeft_hom_actLeft + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] (N : Mod D A) [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] : + modTensorAct A (regularMod A) N ≫ + (modTensorUnitLeft A N).hom = + A ◁ (modTensorUnitLeft A N).hom ≫ actLeft A N.X := by + apply modTensor_whisker_hom_ext A (regularMod A) N A + conv_lhs => rw [whiskerLeft_modTensorπ_act_assoc, + modTensorUnitLeft_hom, modTensorπ_desc] + conv_rhs => rw [modTensorUnitLeft_hom, ← whiskerLeft_comp_assoc, + modTensorπ_desc, actLeft_actLeft] + rfl + +/-- The right unit isomorphism is a morphism of modules. -/ +@[reassoc] +lemma modTensorUnitRight_hom_actLeft + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] [IsCommMonObj A] (M : Mod D A) [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] : + modTensorAct A M (regularMod A) ≫ + (modTensorUnitRight A M).hom = + A ◁ (modTensorUnitRight A M).hom ≫ actLeft A M.X := by + apply modTensor_whisker_hom_ext A M (regularMod A) A + conv_lhs => rw [whiskerLeft_modTensorπ_act_assoc, + modTensorUnitRight_hom, modTensorπ_desc] + conv_rhs => rw [modTensorUnitRight_hom, ← whiskerLeft_comp_assoc, + modTensorπ_desc, actLeft_actRight] + +end Units + +section Functoriality + +/-- Module morphisms intertwine the first legs. -/ +lemma modTensorLegM_tensorHom + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] {M : Mod D A} {M' : Mod D A} {N : Mod D A} + {N' : Mod D A} + (f : M ⟶ M') (g : N ⟶ N') : + modTensorLegM A M N ≫ (f.hom ⊗ₘ g.hom) = + (f.hom ▷ A ⊗ₘ g.hom) ≫ modTensorLegM A M' N' := by + rw [modTensorLegM, modTensorLegM, tensorHom_def, tensorHom_def] + conv_lhs => rw [← comp_whiskerRight_assoc, + actRight_natural A M.X M'.X f.hom, comp_whiskerRight_assoc] + conv_rhs => rw [Category.assoc, whisker_exchange] + +/-- Module morphisms intertwine the second legs. -/ +lemma modTensorLegN_tensorHom + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] {M : Mod D A} + {M' : Mod D A} {N : Mod D A} {N' : Mod D A} + (f : M ⟶ M') (g : N ⟶ N') : + modTensorLegN A M N ≫ (f.hom ⊗ₘ g.hom) = + (f.hom ▷ A ⊗ₘ g.hom) ≫ modTensorLegN A M' N' := by + rw [modTensorLegN, modTensorLegN, tensorHom_def, tensorHom_def] + conv_lhs => rw [Category.assoc, whisker_exchange_assoc, + ← whiskerLeft_comp, actLeft_natural A N.X N'.X g.hom, + whiskerLeft_comp] + conv_rhs => rw [Category.assoc, + associator_naturality_right_assoc, + associator_naturality_left_assoc] + +/-- Functoriality of the module tensor product in both slots. -/ +noncomputable def modTensorMap + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] {M : Mod D A} {M' : Mod D A} {N : Mod D A} + {N' : Mod D A} [HasCoequalizers D] + (f : M ⟶ M') (g : N ⟶ N') : + modTensor A M N ⟶ modTensor A M' N' := + modTensorDesc A M N ((f.hom ⊗ₘ g.hom) ≫ modTensorπ A M' N') + (by + conv_lhs => rw [← Category.assoc, + modTensorLegM_tensorHom A f g, Category.assoc, + modTensor_condition] + conv_rhs => rw [← Category.assoc, + modTensorLegN_tensorHom A f g, Category.assoc]) + +/-- Defining equation of the functorial map. -/ +@[reassoc (attr := simp)] +lemma modTensorπ_map [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] {M : Mod D A} {M' : Mod D A} {N : Mod D A} + {N' : Mod D A} [HasCoequalizers D] + (f : M ⟶ M') (g : N ⟶ N') : + modTensorπ A M N ≫ modTensorMap A f g = + (f.hom ⊗ₘ g.hom) ≫ modTensorπ A M' N' := + modTensorπ_desc A M N _ _ + +/-- The functorial map preserves identities. -/ +lemma modTensorMap_id [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] {M : Mod D A} {N : Mod D A} [HasCoequalizers D] : + modTensorMap A (𝟙 M) (𝟙 N) = 𝟙 (modTensor A M N) := by + apply modTensor_hom_ext + simp + +/-- The functorial map preserves composition. -/ +lemma modTensorMap_comp [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] {M : Mod D A} {M' : Mod D A} {M'' : Mod D A} + {N : Mod D A} {N' : Mod D A} {N'' : Mod D A} [HasCoequalizers D] + (f : M ⟶ M') (f' : M' ⟶ M'') + (g : N ⟶ N') (g' : N' ⟶ N'') : + modTensorMap A (f ≫ f') (g ≫ g') = + modTensorMap A f g ≫ modTensorMap A f' g' := by + apply modTensor_hom_ext + simp + +/-- `modTensorMap` is a morphism of modules. -/ +@[reassoc] +lemma modTensorAct_map [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] {M : Mod D A} {M' : Mod D A} {N : Mod D A} + {N' : Mod D A} [HasCoequalizers D] [IsCommMonObj A] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (f : M ⟶ M') (g : N ⟶ N') : + modTensorAct A M N ≫ modTensorMap A f g = + A ◁ modTensorMap A f g ≫ modTensorAct A M' N' := by + have hpre : (α_ A M.X N.X).inv ≫ actLeft A M.X ▷ N.X ≫ + (f.hom ⊗ₘ g.hom) = + A ◁ (f.hom ⊗ₘ g.hom) ≫ (α_ A M'.X N'.X).inv ≫ + actLeft A M'.X ▷ N'.X := by + conv_rhs => rw [← id_tensorHom, associator_inv_naturality_assoc] + simp only [id_tensorHom, Iso.cancel_iso_inv_left] + rw [← tensorHom_id (actLeft A M.X) N.X, + ← tensorHom_id (actLeft A M'.X) N'.X, + tensorHom_comp_tensorHom, tensorHom_comp_tensorHom] + simp + apply modTensor_whisker_hom_ext A M N A + conv_lhs => rw [whiskerLeft_modTensorπ_act_assoc, + modTensorπ_map] + conv_rhs => rw [← whiskerLeft_comp_assoc, modTensorπ_map, + whiskerLeft_comp_assoc, whiskerLeft_modTensorπ_act] + simp only [Category.assoc] + rw [reassoc_of% hpre] + +/-- Functoriality, as a morphism of bundled modules. -/ +noncomputable def modTensorMapMod + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] {M : Mod D A} {M' : Mod D A} {N : Mod D A} + {N' : Mod D A} [HasCoequalizers D] [IsCommMonObj A] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (f : M ⟶ M') (g : N ⟶ N') : + modTensorMod A M N ⟶ modTensorMod A M' N' := + Mod.Hom.mk' (modTensorMap A f g) (modTensorAct_map A f g) + +/-- The relative tensor product of two module isomorphisms. -/ +noncomputable def modTensorMapIso + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] {M : Mod D A} {M' : Mod D A} {N : Mod D A} + {N' : Mod D A} [HasCoequalizers D] [IsCommMonObj A] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (e : M ≅ M') (f : N ≅ N') : + modTensorMod A M N ≅ modTensorMod A M' N' where + hom := modTensorMapMod A e.hom f.hom + inv := modTensorMapMod A e.inv f.inv + hom_inv_id := Mod.hom_ext _ _ (by + change modTensorMap A e.hom f.hom ≫ + modTensorMap A e.inv f.inv = 𝟙 _ + rw [← modTensorMap_comp, Iso.hom_inv_id, Iso.hom_inv_id, + modTensorMap_id]) + inv_hom_id := Mod.hom_ext _ _ (by + change modTensorMap A e.inv f.inv ≫ + modTensorMap A e.hom f.hom = 𝟙 _ + rw [← modTensorMap_comp, Iso.inv_hom_id, Iso.inv_hom_id, + modTensorMap_id]) + +end Functoriality + +section BaseChange + +/-- `B` as an `A`-module by restriction along `φ`, with underlying +object reducibly `B`. -/ +@[reducible] +def restrictRegular + [Category.{v} D] [MonoidalCategory D] {A : D} {B : D} [MonObj A] + [MonObj B] (φ : A ⟶ B) [IsMonHom φ] : Mod D A := + letI := ModObj.regular B + letI := Mod.scalarRestriction φ B + ⟨B⟩ + +/-- For commutative `B`, the braided right `A`-action on the +restricted module is right multiplication through `φ`. -/ +lemma actRight_restrictRegular + [Category.{v} D] [MonoidalCategory D] {A : D} {B : D} [MonObj A] + [MonObj B] (φ : A ⟶ B) [IsMonHom φ] [BraidedCategory D] + [IsCommMonObj B] : + haveI := ModObj.regular B + haveI := Mod.scalarRestriction φ B + actRight A B = B ◁ φ ≫ μ[B] := by + change (β_ B A).hom ≫ φ ▷ B ≫ μ[B] = B ◁ φ ≫ μ[B] + rw [← BraidedCategory.braiding_naturality_right_assoc, + IsCommMonObj.mul_comm] + +/-- Multiplication of `B` commutes with the right `A`-action on the +restricted module. -/ +lemma mul_actRight_restrictRegular + [Category.{v} D] [MonoidalCategory D] {A : D} {B : D} [MonObj A] + [MonObj B] (φ : A ⟶ B) [IsMonHom φ] [BraidedCategory D] + [IsCommMonObj B] : + haveI := ModObj.regular B + haveI := Mod.scalarRestriction φ B + B ◁ actRight A B ≫ μ[B] = + (α_ B B A).inv ≫ μ[B] ▷ A ≫ actRight A B := by + rw [actRight_restrictRegular φ] + simp only [whiskerLeft_comp, Category.assoc] + rw [MonObj.mul_assoc_flip, associator_inv_naturality_right_assoc, + whisker_exchange_assoc] + +/-- Base change along `φ`: the extension `B ⊗[A] M` of an +`A`-module `M`. -/ +noncomputable def baseChange + [Category.{v} D] [MonoidalCategory D] {A : D} {B : D} [MonObj A] + [MonObj B] (φ : A ⟶ B) [IsMonHom φ] [BraidedCategory D] + [HasCoequalizers D] + (M : Mod D A) : D := + modTensor A (restrictRegular φ) M + +/-- The `B`-module structure on the base change: multiplication on +the left factor descends. -/ +@[implicit_reducible] +noncomputable def baseChangeModObj + [Category.{v} D] [MonoidalCategory D] {A : D} {B : D} [MonObj A] + [MonObj B] (φ : A ⟶ B) [IsMonHom φ] [BraidedCategory D] + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (M : Mod D A) [IsCommMonObj B] : + ModObj B (baseChange φ M) := + modTensorDescModObj A (restrictRegular φ) M B μ[B] + (mul_actRight_restrictRegular φ) (MonObj.one_mul B) + (MonObj.mul_assoc B) + +/-- The action of `B` on the base change. -/ +noncomputable def baseChangeAct + [Category.{v} D] [MonoidalCategory D] {A : D} {B : D} [MonObj A] + [MonObj B] (φ : A ⟶ B) [IsMonHom φ] [BraidedCategory D] + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (M : Mod D A) [IsCommMonObj B] : + B ⊗ baseChange φ M ⟶ baseChange φ M := + (baseChangeModObj φ M).smul + +/-- Defining equation of the `B`-action on the base change. -/ +@[simp, reassoc] +lemma whiskerLeft_modTensorπ_baseChangeAct + [Category.{v} D] [MonoidalCategory D] {A : D} {B : D} [MonObj A] + [MonObj B] (φ : A ⟶ B) [IsMonHom φ] [BraidedCategory D] + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (M : Mod D A) + [IsCommMonObj B] : + B ◁ modTensorπ A (restrictRegular φ) M ≫ baseChangeAct φ M = + ((α_ B B M.X).inv ≫ μ[B] ▷ M.X) ≫ + modTensorπ A (restrictRegular φ) M := + whiskerLeft_modTensorπ_descAct A (restrictRegular φ) M B μ[B] + (mul_actRight_restrictRegular φ) + +/-- Base change, bundled as a `B`-module. -/ +noncomputable def baseChangeMod + [Category.{v} D] [MonoidalCategory D] {A : D} {B : D} [MonObj A] + [MonObj B] (φ : A ⟶ B) [IsMonHom φ] [BraidedCategory D] + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (M : Mod D A) [IsCommMonObj B] : + Mod D B := + letI := baseChangeModObj φ M + ⟨baseChange φ M⟩ + +@[simp] lemma baseChangeMod_X + [Category.{v} D] [MonoidalCategory D] {A : D} {B : D} [MonObj A] + [MonObj B] (φ : A ⟶ B) [IsMonHom φ] [BraidedCategory D] + [HasCoequalizers D] + [∀ X : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft X)] + (M : Mod D A) [IsCommMonObj B] : + (baseChangeMod φ M).X = baseChange φ M := rfl + +end BaseChange + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModZero.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModZero.lean new file mode 100644 index 0000000000..bfce9d89d7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModZero.lean @@ -0,0 +1,48 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor + +/-! +# Vanishing transport through the module tensor product + +The relative tensor product of modules vanishes when either +factor does: the projection from the ordinary tensor product is +epic, and the ordinary tensor product with a zero object is +zero. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The module tensor product of a zero module vanishes**, +left-factor version. -/ +theorem isZero_modTensor_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] (M : Mod D A) (N : Mod D A) + (h : IsZero M.X) : + IsZero (modTensor A M N) := by + rw [IsZero.iff_id_eq_zero] + have hπ : modTensorπ A M N = 0 := + (isZero_whiskerRight h N.X).eq_of_src _ _ + have := modTensor_hom_ext A M N + (k := 𝟙 (modTensor A M N)) (l := 0) + apply this + rw [hπ, Limits.zero_comp, Limits.zero_comp] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MuInterchange.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MuInterchange.lean new file mode 100644 index 0000000000..760549cc98 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MuInterchange.lean @@ -0,0 +1,110 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid + +/-! +# The tensorμ interchange associativity + +The mixed associativity of the middle-four interchange: shuffling +first and regrouping equals regrouping blockwise and shuffling +twice. This is the symmetric-category companion of Mathlib's +`tensor_associativity`, with the shuffle on the other side; one +adjacent symmetry cancellation dissolves the doubled crossing. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +variable {D : Type u} + +/-- Mixed associativity of the interchange: shuffling the first two +pairs and regrouping against `Z₁ ⊗ Z₂` agrees with regrouping +blockwise and shuffling twice. The two block braidings on the right +decompose into four elementary crossings, of which the adjacent pair +`β_ X₂ Z₁ ≫ β_ Z₁ X₂` cancels by the symmetry axiom; one exchange of +the disjoint surviving crossings then matches the left-hand side. -/ +@[reassoc] +theorem tensorMu_assoc_swap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (X₁ Y₁ X₂ Y₂ Z₁ Z₂ : D) : + (tensorμ X₁ Y₁ X₂ Y₂ ▷ (Z₁ ⊗ Z₂)) ≫ + (α_ (X₁ ⊗ X₂) (Y₁ ⊗ Y₂) (Z₁ ⊗ Z₂)).hom ≫ + ((X₁ ⊗ X₂) ◁ tensorμ Y₁ Y₂ Z₁ Z₂) = + tensorμ (X₁ ⊗ Y₁) (X₂ ⊗ Y₂) Z₁ Z₂ ≫ + ((α_ X₁ Y₁ Z₁).hom ⊗ₘ (α_ X₂ Y₂ Z₂).hom) ≫ + tensorμ X₁ (Y₁ ⊗ Z₁) X₂ (Y₂ ⊗ Z₂) := by + symm + calc + tensorμ (X₁ ⊗ Y₁) (X₂ ⊗ Y₂) Z₁ Z₂ ≫ + ((α_ X₁ Y₁ Z₁).hom ⊗ₘ (α_ X₂ Y₂ Z₂).hom) ≫ + tensorμ X₁ (Y₁ ⊗ Z₁) X₂ (Y₂ ⊗ Z₂) + = 𝟙 _ ⊗≫ X₁ ◁ Y₁ ◁ X₂ ◁ (β_ Y₂ Z₁).hom ▷ Z₂ ⊗≫ + X₁ ◁ Y₁ ◁ ((β_ X₂ Z₁).hom ≫ (β_ Z₁ X₂).hom) ▷ (Y₂ ⊗ Z₂) ⊗≫ + X₁ ◁ (β_ Y₁ X₂).hom ▷ ((Z₁ ⊗ Y₂) ⊗ Z₂) ⊗≫ 𝟙 _ := by + dsimp only [tensorμ] + rw [BraidedCategory.braiding_tensor_left_hom X₂ Y₂ Z₁, + BraidedCategory.braiding_tensor_left_hom Y₁ Z₁ X₂] + monoidal + _ = 𝟙 _ ⊗≫ X₁ ◁ ((Y₁ ⊗ X₂) ◁ ((β_ Y₂ Z₁).hom ▷ Z₂) ≫ + (β_ Y₁ X₂).hom ▷ ((Z₁ ⊗ Y₂) ⊗ Z₂)) ⊗≫ 𝟙 _ := by + rw [SymmetricCategory.symmetry X₂ Z₁] + monoidal + _ = (tensorμ X₁ Y₁ X₂ Y₂ ▷ (Z₁ ⊗ Z₂)) ≫ + (α_ (X₁ ⊗ X₂) (Y₁ ⊗ Y₂) (Z₁ ⊗ Z₂)).hom ≫ + ((X₁ ⊗ X₂) ◁ tensorμ Y₁ Y₂ Z₁ Z₂) := by + rw [whisker_exchange (β_ Y₁ X₂).hom ((β_ Y₂ Z₁).hom ▷ Z₂)] + dsimp only [tensorμ] + monoidal + +/-- The inverse-associator companion of `tensorMu_assoc_swap`: +shuffling the last two pairs and regrouping against `Z₁ ⊗ Z₂` agrees +with regrouping blockwise and shuffling twice. The two block +braidings on the right decompose into four elementary crossings, of +which the adjacent pair `β_ Z₂ Y₁ ≫ β_ Y₁ Z₂` cancels by the symmetry +axiom; one exchange of the disjoint surviving crossings then matches +the left-hand side. -/ +@[reassoc] +theorem tensorMu_assoc_swap_inv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (Z₁ Z₂ X₁ Y₁ X₂ Y₂ : D) : + ((Z₁ ⊗ Z₂) ◁ tensorμ X₁ Y₁ X₂ Y₂) ≫ + (α_ (Z₁ ⊗ Z₂) (X₁ ⊗ X₂) (Y₁ ⊗ Y₂)).inv ≫ + (tensorμ Z₁ Z₂ X₁ X₂ ▷ (Y₁ ⊗ Y₂)) = + tensorμ Z₁ Z₂ (X₁ ⊗ Y₁) (X₂ ⊗ Y₂) ≫ + ((α_ Z₁ X₁ Y₁).inv ⊗ₘ (α_ Z₂ X₂ Y₂).inv) ≫ + tensorμ (Z₁ ⊗ X₁) Y₁ (Z₂ ⊗ X₂) Y₂ := by + symm + calc + tensorμ Z₁ Z₂ (X₁ ⊗ Y₁) (X₂ ⊗ Y₂) ≫ + ((α_ Z₁ X₁ Y₁).inv ⊗ₘ (α_ Z₂ X₂ Y₂).inv) ≫ + tensorμ (Z₁ ⊗ X₁) Y₁ (Z₂ ⊗ X₂) Y₂ + = 𝟙 _ ⊗≫ Z₁ ◁ (β_ Z₂ X₁).hom ▷ ((Y₁ ⊗ X₂) ⊗ Y₂) ⊗≫ + Z₁ ◁ X₁ ◁ ((β_ Z₂ Y₁).hom ≫ (β_ Y₁ Z₂).hom) ▷ (X₂ ⊗ Y₂) ⊗≫ + Z₁ ◁ X₁ ◁ Z₂ ◁ (β_ Y₁ X₂).hom ▷ Y₂ ⊗≫ 𝟙 _ := by + dsimp only [tensorμ] + rw [BraidedCategory.braiding_tensor_right_hom Z₂ X₁ Y₁, + BraidedCategory.braiding_tensor_right_hom Y₁ Z₂ X₂] + monoidal + _ = 𝟙 _ ⊗≫ Z₁ ◁ ((β_ Z₂ X₁).hom ▷ ((Y₁ ⊗ X₂) ⊗ Y₂) ≫ + (X₁ ⊗ Z₂) ◁ ((β_ Y₁ X₂).hom ▷ Y₂)) ⊗≫ 𝟙 _ := by + rw [SymmetricCategory.symmetry Z₂ Y₁] + monoidal + _ = ((Z₁ ⊗ Z₂) ◁ tensorμ X₁ Y₁ X₂ Y₂) ≫ + (α_ (Z₁ ⊗ Z₂) (X₁ ⊗ X₂) (Y₁ ⊗ Y₂)).inv ≫ + (tensorμ Z₁ Z₂ X₁ X₂ ▷ (Y₁ ⊗ Y₂)) := by + rw [← whisker_exchange (β_ Z₂ X₁).hom ((β_ Y₁ X₂).hom ▷ Y₂)] + dsimp only [tensorμ] + monoidal + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MulBy.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MulBy.lean new file mode 100644 index 0000000000..61f7bc9395 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MulBy.lean @@ -0,0 +1,124 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaAlgebra + +/-! +# Multiplication by a scalar + +For an algebra `R` in a monoidal category, an element `g : 𝟙 ⟶ R` +of the even part of its Γ-algebra acts on `R` by multiplication. +The resulting endomorphism `RS.mulBy g` sends the unit to `g`, and +composing any element of the Γ-algebra into it is the convolution +product with `g`. + +This is the calculus behind the scalar computation for a simple +algebra: multiplication by a nonzero even element has an ideal for +its kernel and an ideal for its image, so simplicity makes it +invertible, and the preimage of the unit is then an inverse for `g`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +section Basic + +variable {D : Type u} + +/-- **Multiplication by an even scalar.** -/ +noncomputable def mulBy [Category.{v} D] [MonoidalCategory D] (R : D) [MonObj R] + (g : 𝟙_ D ⟶ R) : R ⟶ R := + (λ_ R).inv ≫ gmul g (𝟙 R) + +/-- Multiplication by a scalar, applied to any element of the +Γ-algebra, is the convolution product. -/ +theorem comp_mulBy [Category.{v} D] [MonoidalCategory D] (R : D) [MonObj R] + {X : D} (g : 𝟙_ D ⟶ R) (h : X ⟶ R) : + h ≫ mulBy R g = (λ_ X).inv ≫ gmul g h := by + rw [mulBy, ← Category.assoc, MonoidalCategory.leftUnitor_inv_naturality, + Category.assoc, ← gmul_comp, Category.comp_id] + +/-- Multiplication by a scalar sends the unit to that scalar. -/ +@[simp] +theorem unit_comp_mulBy [Category.{v} D] [MonoidalCategory D] (R : D) [MonObj R] + (g : 𝟙_ D ⟶ R) : η[R] ≫ mulBy R g = g := by + rw [comp_mulBy, gmul_one_right, ← MonoidalCategory.unitors_equal, + Iso.inv_hom_id_assoc] + +/-- Multiplication by the unit is the identity. -/ +@[simp] +theorem mulBy_one [Category.{v} D] [MonoidalCategory D] (R : D) [MonObj R] : + mulBy R η[R] = 𝟙 R := by + rw [mulBy, gmul_one_left, Iso.inv_hom_id_assoc] + +end Basic + +section Additive + +variable {D : Type u} + +/-- Multiplication by a scalar is additive in the scalar. -/ +theorem mulBy_add [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] (R : D) [MonObj R] + (g g' : 𝟙_ D ⟶ R) : + mulBy R (g + g') = mulBy R g + mulBy R g' := by + rw [mulBy, mulBy, mulBy, add_gmul, Preadditive.comp_add] + +/-- Multiplication by the zero scalar is zero. -/ +@[simp] +theorem mulBy_zero [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] (R : D) [MonObj R] : + mulBy R (0 : 𝟙_ D ⟶ R) = 0 := by + have h : mulBy R 0 + mulBy R 0 = mulBy R 0 + 0 := by + rw [← mulBy_add, add_zero, add_zero] + exact add_left_cancel h + +/-- A scalar whose multiplication vanishes is itself zero. -/ +theorem eq_zero_of_mulBy_eq_zero + [Category.{v} D] [MonoidalCategory D] [Preadditive D] (R : D) [MonObj R] + {g : 𝟙_ D ⟶ R} + (h : mulBy R g = 0) : g = 0 := by + have hg := unit_comp_mulBy R g + rw [h, Limits.comp_zero] at hg + exact hg.symm + +end Additive + +section Odd + +variable {D : Type u} + +/-- **An odd scalar squares to zero.** The self-braiding of the odd +line is `−1`, and convolution against a commutative algebra is +commutative up to that braiding, so the square of an odd element is +its own negative. -/ +theorem gmul_self_eq_zero_of_oddLine + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [Linear ℂ D] (R : D) [MonObj R] [IsCommMonObj R] + (L : OddLine D) (f : L.obj ⟶ R) : + gmul f f = 0 := by + have hc : gmul f f = (β_ L.obj L.obj).hom ≫ gmul f f := gmul_comm f f + rw [L.braid_neg, Preadditive.neg_comp, Category.id_comp] at hc + have h2 : gmul f f + gmul f f = 0 := by + rw [← neg_eq_iff_add_eq_zero] + exact hc.symm + have h3 : (2 : ℂ) • gmul f f = 0 := by + rw [two_smul] + exact h2 + have h4 := congrArg (fun t => ((2 : ℂ)⁻¹) • t) h3 + simpa [smul_smul] using h4 + +end Odd + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/NatChain.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/NatChain.lean new file mode 100644 index 0000000000..cd90a024cb --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/NatChain.lean @@ -0,0 +1,96 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Functors out of the natural numbers from step data + +A sequence of objects and one-step transition morphisms assembles +into a functor from `ℕ` — the shape of the Key Lemma's +δ-multiplication colimit. The map on an arbitrary inequality is +defined by recursion on its length, with the composition law +proved once and the one-step computation exposed as a simp lemma. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +universe v u + +variable {D : Type u} + +/-- The morphism of a chain along an inequality, by recursion on +its length. -/ +noncomputable def chainMap [Category.{v} D] + (B : ℕ → D) (δ : ∀ n, B n ⟶ B (n + 1)) : + ∀ {m n : ℕ}, m ≤ n → (B m ⟶ B n) := fun {m} {_} h => + Nat.leRecOn h (fun {k} f => f ≫ δ k) (𝟙 (B m)) + +@[simp] +theorem chainMap_self [Category.{v} D] + (B : ℕ → D) (δ : ∀ n, B n ⟶ B (n + 1)) + (n : ℕ) : chainMap B δ (le_refl n) = 𝟙 (B n) := + Nat.leRecOn_self _ + +theorem chainMap_succ_of_le [Category.{v} D] + (B : ℕ → D) + (δ : ∀ n, B n ⟶ B (n + 1)) {m n : ℕ} (h : m ≤ n) + (h' : m ≤ n + 1) : + chainMap B δ h' = chainMap B δ h ≫ δ n := + Nat.leRecOn_succ h _ + +@[simp] +theorem chainMap_le_succ [Category.{v} D] + (B : ℕ → D) + (δ : ∀ n, B n ⟶ B (n + 1)) (n : ℕ) : + chainMap B δ (Nat.le_succ n) = δ n := by + rw [chainMap_succ_of_le B δ (le_refl n), chainMap_self, + Category.id_comp] + +theorem chainMap_trans [Category.{v} D] + (B : ℕ → D) (δ : ∀ n, B n ⟶ B (n + 1)) + {l m n : ℕ} (h₁ : l ≤ m) (h₂ : m ≤ n) : + chainMap B δ (h₁.trans h₂) = + chainMap B δ h₁ ≫ chainMap B δ h₂ := by + induction n, h₂ using Nat.le_induction with + | base => + rw [chainMap_self, Category.comp_id] + | succ n hmn ih => + rw [chainMap_succ_of_le B δ hmn, + chainMap_succ_of_le B δ (h₁.trans hmn), ih, + Category.assoc] + +/-- The functor out of `ℕ` assembled from objects and one-step +transitions. -/ +noncomputable def chainFunctor [Category.{v} D] + (B : ℕ → D) + (δ : ∀ n, B n ⟶ B (n + 1)) : ℕ ⥤ D where + obj := B + map f := chainMap B δ (leOfHom f) + map_id n := chainMap_self B δ n + map_comp f g := + chainMap_trans B δ (leOfHom f) (leOfHom g) + +@[simp] +theorem chainFunctor_obj [Category.{v} D] + (B : ℕ → D) (δ : ∀ n, B n ⟶ B (n + 1)) + (n : ℕ) : (chainFunctor B δ).obj n = B n := + rfl + +@[simp] +theorem chainFunctor_map_le_succ [Category.{v} D] + (B : ℕ → D) + (δ : ∀ n, B n ⟶ B (n + 1)) (n : ℕ) : + (chainFunctor B δ).map (homOfLE (Nat.le_succ n)) = δ n := + chainMap_le_succ B δ n + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/NewtonConv.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/NewtonConv.lean new file mode 100644 index 0000000000..4369d96cd6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/NewtonConv.lean @@ -0,0 +1,118 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums + +/-! +# Convolution of complete homogeneous sequences + +The complete homogeneous sequence of a sum of scalar sequences is the +convolution of the individual sequences: at the level of generating +series, `newtonHSeries (t + t') = newtonHSeries t * newtonHSeries t'`. + +The proof follows the house technique: both sides satisfy the +first-order differential equation `F′ = (T + T′) · F` — the left by +the Newton derivative identity applied to the sum, the right by the +Leibniz rule and the identity applied twice — and both have constant +coefficient `1`, so they agree by the coefficient recursion that the +equation pins down. A reusable uniqueness lemma +`odeUnique_of_constEq` packages the recursion argument. + +Coefficient extraction yields the consumer-facing convolution formula +`newtonH_add`, together with its integer-indexed form `newtonHZ_add` +for Jacobi–Trudi consumers. +-/ + +@[expose] public section + +namespace RS + +open Finset PowerSeries + +/-! ### Additivity of the power-sum series -/ + +/-- The shifted power-sum series is additive in the scalar sequence. -/ +theorem powerSumSeries_add (t t' : ℕ → ℂ) : + powerSumSeries (fun c => t c + t' c) = + powerSumSeries t + powerSumSeries t' := by + ext n + simp only [powerSumSeries, coeff_mk, map_add] + +/-! ### Uniqueness for the first-order linear ODE -/ + +/-- **Uniqueness for `F′ = P · F`.** Two power series satisfying the +same first-order linear differential equation with equal constant +coefficients are equal: the equation determines each coefficient from +the earlier ones by the recursion +`(n + 1) · F_{n+1} = ∑_{i+j=n} P_i · F_j`, and division by the +nonzero scalar `n + 1` closes the strong induction. -/ +theorem odeUnique_of_constEq (P F G : ℂ⟦X⟧) + (hF : (PowerSeries.derivative (R := ℂ)) F = P * F) (hG : (PowerSeries.derivative (R := + ℂ)) G = P * G) + (h0 : constantCoeff F = constantCoeff G) : F = G := by + ext n + induction n using Nat.strong_induction_on with + | _ n ih => + cases n with + | zero => + rw [coeff_zero_eq_constantCoeff_apply, + coeff_zero_eq_constantCoeff_apply, h0] + | succ m => + have hFm := congrArg (coeff m) hF + have hGm := congrArg (coeff m) hG + rw [coeff_derivative, coeff_mul] at hFm hGm + have hsum : + ∑ ij ∈ Finset.antidiagonal m, coeff ij.1 P * coeff ij.2 F = + ∑ ij ∈ Finset.antidiagonal m, coeff ij.1 P * coeff ij.2 G := by + refine Finset.sum_congr rfl fun ij hij => ?_ + have h2 : ij.1 + ij.2 = m := Finset.mem_antidiagonal.mp hij + rw [ih ij.2 (by omega)] + exact mul_right_cancel₀ (Nat.cast_add_one_ne_zero m) + (hFm.trans (hsum.trans hGm.symm)) + +/-! ### The convolution identity -/ + +/-- **Convolution of Newton generating series.** The generating +series of the complete homogeneous sequence of a sum of scalar +sequences is the product of the individual generating series. -/ +theorem newtonHSeries_add (t t' : ℕ → ℂ) : + newtonHSeries (fun c => t c + t' c) = + newtonHSeries t * newtonHSeries t' := by + apply odeUnique_of_constEq (powerSumSeries t + powerSumSeries t') + · rw [newtonH_derivative, powerSumSeries_add] + · rw [Derivation.leibniz, smul_eq_mul, smul_eq_mul, + newtonH_derivative, newtonH_derivative] + ring + · rw [map_mul, newtonH_series_constantCoeff, + newtonH_series_constantCoeff, newtonH_series_constantCoeff, + mul_one] + +/-- **The convolution formula for complete homogeneous values.** +`h_n (t + t') = ∑_{i+j=n} h_i (t) · h_j (t')`. -/ +theorem newtonH_add (t t' : ℕ → ℂ) (n : ℕ) : + newtonH (fun c => t c + t' c) n = + ∑ ij ∈ Finset.antidiagonal n, newtonH t ij.1 * newtonH t' ij.2 := by + have h := congrArg (coeff n) (newtonHSeries_add t t') + rw [coeff_mul] at h + simpa only [newtonHSeries, coeff_mk] using h + +/-- The convolution formula in the integer-indexed form used by +Jacobi–Trudi consumers: for `0 ≤ m` the value `newtonHZ (t + t') m` +is the antidiagonal convolution over `m.toNat` (in negative degrees +both sides vanish by `newtonHZ_neg`, so the nonnegative case carries +all content). -/ +theorem newtonHZ_add (t t' : ℕ → ℂ) (m : ℤ) (hm : 0 ≤ m) : + newtonHZ (fun c => t c + t' c) m = + ∑ ij ∈ Finset.antidiagonal m.toNat, + newtonHZ t ij.1 * newtonHZ t' ij.2 := by + obtain ⟨n, rfl⟩ := Int.eq_ofNat_of_zero_le hm + rw [newtonHZ_natCast, Int.toNat_natCast, newtonH_add] + refine Finset.sum_congr rfl fun ij _ => ?_ + rw [newtonHZ_natCast, newtonHZ_natCast] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/NullPoint.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/NullPoint.lean new file mode 100644 index 0000000000..0dfd8d8c33 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/NullPoint.lean @@ -0,0 +1,38 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Complex points of finite-type algebras + +Every nonzero commutative ℂ-algebra of finite type admits a +ℂ-point: quotient by a maximal ideal, apply Zariski's lemma over +the Jacobson ring ℂ, and lift to the algebraically closed base. +This is the Nullstellensatz input of the descent's final step. +-/ + +@[expose] public section + +namespace RS + +/-- **The ℂ-point**: a nonzero finite-type commutative ℂ-algebra +maps onto ℂ. -/ +theorem exists_algHom_complex (R : Type*) [CommRing R] + [Algebra ℂ R] [Nontrivial R] [Algebra.FiniteType ℂ R] : + Nonempty (R →ₐ[ℂ] ℂ) := by + obtain ⟨m, hm⟩ := Ideal.exists_maximal R + have := hm + let := Ideal.Quotient.field m + have : Module.Finite ℂ (R ⧸ m) := + finite_of_finite_type_of_isJacobsonRing ℂ (R ⧸ m) + have : Algebra.IsAlgebraic ℂ (R ⧸ m) := + Algebra.IsAlgebraic.of_finite ℂ (R ⧸ m) + exact ⟨(IsAlgClosed.lift (M := ℂ)).comp (Ideal.Quotient.mkₐ ℂ m)⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLineMap.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLineMap.lean new file mode 100644 index 0000000000..69e1a32bb0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLineMap.lean @@ -0,0 +1,59 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 + +/-! +# Transporting an odd line along a monoidal functor + +A strong braided monoidal additive functor carries an odd line to an +odd line: the square of the image is the image of the square, and +the self-braiding of the image is the image of the self-braiding, +which is minus an identity. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v₁ u₁ v₂ u₂ + +variable {A : Type u₁} + +/-- **The image of an odd line under a strong braided monoidal +additive functor is an odd line.** -/ +noncomputable def OddLine.map + [Category.{v₁} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] {B : Type u₂} [Category.{v₂} B] [MonoidalCategory B] + [SymmetricCategory B] [Preadditive B] + (F : A ⥤ B) [F.Braided] + [F.Additive] (L : OddLine A) : OddLine B where + obj := F.obj L.obj + sq := CategoryTheory.Functor.Monoidal.μIso F L.obj L.obj ≪≫ + F.mapIso L.sq ≪≫ (CategoryTheory.Functor.Monoidal.εIso F).symm + braid_neg := by + have hb := CategoryTheory.Functor.LaxBraided.braided + (F := F) L.obj L.obj + have hn : F.map (β_ L.obj L.obj).hom = + -𝟙 (F.obj (L.obj ⊗ L.obj)) := by + rw [L.braid_neg, F.map_neg, CategoryTheory.Functor.map_id] + rw [hn, Preadditive.comp_neg, Category.comp_id] at hb + have h := congrArg + (fun t => t ≫ CategoryTheory.Functor.OplaxMonoidal.δ F + L.obj L.obj) hb + simp only [Preadditive.neg_comp, Category.assoc] at h + have hmd : CategoryTheory.Functor.LaxMonoidal.μ F L.obj L.obj ≫ + CategoryTheory.Functor.OplaxMonoidal.δ F L.obj L.obj = + 𝟙 (F.obj L.obj ⊗ F.obj L.obj) := + CategoryTheory.Functor.Monoidal.μ_δ F L.obj L.obj + rw [hmd, Category.comp_id] at h + exact h.symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLinePairing.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLinePairing.lean new file mode 100644 index 0000000000..01d4e0faa8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLinePairing.lean @@ -0,0 +1,162 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 + +/-! +# The odd line is self-dual + +The square trivialisation of an odd line is an exact pairing of +the line with itself. The two triangle identities are forced by +the sign of the self-braiding: rearranging a triple of lines +cyclically costs two transpositions, hence no sign at all, and +the hexagon turns that cyclic rearrangement into a braiding past +the trivialisation, which the unit coherences absorb. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {D : Type u} + +/-- Whiskering a negated identity on the right negates it. -/ +theorem neg_id_whiskerRight + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] + (X Y : D) : + (-𝟙 X) ▷ Y = -𝟙 (X ⊗ Y) := by + change (tensorRight Y).map (-𝟙 X) = _ + rw [Functor.map_neg] + simp + +/-- Whiskering a negated identity on the left negates it. -/ +theorem whiskerLeft_neg_id [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] + (X Y : D) : + X ◁ (-𝟙 Y) = -𝟙 (X ⊗ Y) := by + change (tensorLeft X).map (-𝟙 Y) = _ + rw [Functor.map_neg] + simp + +/-- **Cyclic rearrangement of a triple of lines is free**: the +two transpositions each contribute a sign, and the signs +cancel. -/ +theorem OddLine.cycle_triple + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] (L : OddLine D) : + ((β_ L.obj L.obj).hom ▷ L.obj) ≫ + (α_ L.obj L.obj L.obj).hom ≫ + (L.obj ◁ (β_ L.obj L.obj).hom) = + (α_ L.obj L.obj L.obj).hom := by + rw [L.braid_neg, neg_id_whiskerRight, whiskerLeft_neg_id] + simp + +/-- **Cyclic rearrangement of a triple of lines is free**, in the +mirror grouping. -/ +theorem OddLine.cycle_triple' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] (L : OddLine D) : + (L.obj ◁ (β_ L.obj L.obj).hom) ≫ + (α_ L.obj L.obj L.obj).inv ≫ + ((β_ L.obj L.obj).hom ▷ L.obj) = + (α_ L.obj L.obj L.obj).inv := by + rw [L.braid_neg, neg_id_whiskerRight, whiskerLeft_neg_id] + simp + +/-- **The first triangle identity of the odd line.** -/ +theorem OddLine.evaluation_coevaluation + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] (L : OddLine D) : + (L.sq.inv ▷ L.obj) ≫ (α_ L.obj L.obj L.obj).hom ≫ + (L.obj ◁ L.sq.hom) = + (λ_ L.obj).hom ≫ (ρ_ L.obj).inv := by + have hcyc : (α_ L.obj L.obj L.obj).inv ≫ + ((β_ L.obj L.obj).hom ▷ L.obj) ≫ + (α_ L.obj L.obj L.obj).hom ≫ + (L.obj ◁ (β_ L.obj L.obj).hom) = + (β_ L.obj (L.obj ⊗ L.obj)).hom ≫ + (α_ L.obj L.obj L.obj).hom := by + rw [BraidedCategory.braiding_tensor_right_hom L.obj L.obj + L.obj] + simp only [Category.assoc, Iso.inv_hom_id, Category.comp_id] + have hkey : (L.obj ◁ L.sq.inv) ≫ + (α_ L.obj L.obj L.obj).inv ≫ + ((β_ L.obj L.obj).hom ▷ L.obj) ≫ + (α_ L.obj L.obj L.obj).hom ≫ + (L.obj ◁ (β_ L.obj L.obj).hom) ≫ + (L.obj ◁ L.sq.hom) = 𝟙 (L.obj ⊗ 𝟙_ D) := by + rw [reassoc_of% L.cycle_triple, Iso.inv_hom_id_assoc, + ← MonoidalCategory.whiskerLeft_comp, Iso.inv_hom_id, + MonoidalCategory.whiskerLeft_id] + rw [reassoc_of% hcyc, ← Category.assoc, + BraidedCategory.braiding_naturality_right L.obj L.sq.inv, + Category.assoc] at hkey + have hbr : (β_ L.obj (𝟙_ D)).inv = + (λ_ L.obj).hom ≫ (ρ_ L.obj).inv := by + refine (cancel_epi (β_ L.obj (𝟙_ D)).hom).mp ?_ + rw [Iso.hom_inv_id, ← Category.assoc, braiding_leftUnitor, + Iso.hom_inv_id] + rw [← hbr] + refine Eq.trans ?_ (Category.comp_id _) + exact (Iso.eq_inv_comp _).mpr hkey + +/-- **The second triangle identity of the odd line.** -/ +theorem OddLine.coevaluation_evaluation + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] (L : OddLine D) : + (L.obj ◁ L.sq.inv) ≫ (α_ L.obj L.obj L.obj).inv ≫ + (L.sq.hom ▷ L.obj) = + (ρ_ L.obj).hom ≫ (λ_ L.obj).inv := by + have hcyc : (α_ L.obj L.obj L.obj).hom ≫ + (L.obj ◁ (β_ L.obj L.obj).hom) ≫ + (α_ L.obj L.obj L.obj).inv ≫ + ((β_ L.obj L.obj).hom ▷ L.obj) = + (β_ (L.obj ⊗ L.obj) L.obj).hom ≫ + (α_ L.obj L.obj L.obj).inv := by + rw [BraidedCategory.braiding_tensor_left_hom L.obj L.obj + L.obj] + simp only [Category.assoc, Iso.hom_inv_id, Category.comp_id] + have hkey : (L.sq.inv ▷ L.obj) ≫ + (α_ L.obj L.obj L.obj).hom ≫ + (L.obj ◁ (β_ L.obj L.obj).hom) ≫ + (α_ L.obj L.obj L.obj).inv ≫ + ((β_ L.obj L.obj).hom ▷ L.obj) ≫ + (L.sq.hom ▷ L.obj) = 𝟙 (𝟙_ D ⊗ L.obj) := by + rw [reassoc_of% L.cycle_triple', Iso.hom_inv_id_assoc, + ← MonoidalCategory.comp_whiskerRight, Iso.inv_hom_id, + MonoidalCategory.id_whiskerRight] + rw [reassoc_of% hcyc, ← Category.assoc, + BraidedCategory.braiding_naturality_left L.sq.inv L.obj, + Category.assoc] at hkey + have hbr : (β_ (𝟙_ D) L.obj).inv = + (ρ_ L.obj).hom ≫ (λ_ L.obj).inv := by + refine (cancel_epi (β_ (𝟙_ D) L.obj).hom).mp ?_ + rw [Iso.hom_inv_id, ← Category.assoc, braiding_rightUnitor, + Iso.hom_inv_id] + rw [← hbr] + refine Eq.trans ?_ (Category.comp_id _) + exact (Iso.eq_inv_comp _).mpr hkey + +/-- **The odd line is self-dual**: the square trivialisation is +an exact pairing of the line with itself. -/ +@[implicit_reducible] +noncomputable def OddLine.exactPairing + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] (L : OddLine D) : + ExactPairing L.obj L.obj where + coevaluation' := L.sq.inv + evaluation' := L.sq.hom + coevaluation_evaluation' := L.coevaluation_evaluation + evaluation_coevaluation' := L.evaluation_coevaluation + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddParity.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddParity.lean new file mode 100644 index 0000000000..7a3c91472b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddParity.lean @@ -0,0 +1,169 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLinePairing + +/-! +# Tensoring by the odd line swaps parity + +The odd line is self-dual, so tensoring by it is an equivalence on +Hom-spaces: points of a twisted object are odd elements of the +object. Concretely, `𝟙 ⟶ M ⊗ L` and `L ⟶ M` are the same +ℂ-module, the passage between them being capping the twisting leg +against the square trivialisation. Both directions are visibly +ℂ-linear, composition and whiskering being bilinear, and the two +round trips are the two triangle identities of the self-duality. + +The mirror form, with the twist on the left, is obtained from this +one by transporting along the braiding. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +variable {D : Type u} + +/-- Feeding the coevaluation into a map out of `𝟙 ⊗ L` is the same +as feeding it in on the other side: the unitors and the associator +absorb the difference. -/ +theorem OddLine.coevaluation_whiskerRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] + (L : OddLine D) {M : D} + (g : 𝟙_ D ⊗ L.obj ⟶ M) : + L.sq.inv ≫ (((λ_ L.obj).inv ≫ g) ▷ L.obj) = + (ρ_ (𝟙_ D)).inv ≫ (𝟙_ D ◁ L.sq.inv) ≫ + (α_ (𝟙_ D) L.obj L.obj).inv ≫ (g ▷ L.obj) := by + have hc : ((λ_ L.obj).inv ▷ L.obj) = + (λ_ (L.obj ⊗ L.obj)).inv ≫ (α_ (𝟙_ D) L.obj L.obj).inv := by + monoidal + have h1 : L.sq.inv ≫ ((λ_ L.obj).inv ▷ L.obj) = + (ρ_ (𝟙_ D)).inv ≫ (𝟙_ D ◁ L.sq.inv) ≫ + (α_ (𝟙_ D) L.obj L.obj).inv := by + rw [hc, ← Category.assoc, leftUnitor_inv_naturality, + unitors_inv_equal, Category.assoc] + rw [MonoidalCategory.comp_whiskerRight, ← Category.assoc, h1] + simp only [Category.assoc] + +/-- **Tensoring by the odd line swaps parity**: points of a +twisted object are odd elements of the object. -/ +noncomputable def oddParitySwap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (M : D) : + (𝟙_ D ⟶ M ⊗ L.obj) ≃ₗ[ℂ] (L.obj ⟶ M) where + toFun f := (λ_ L.obj).inv ≫ (f ▷ L.obj) ≫ + (α_ M L.obj L.obj).hom ≫ (M ◁ L.sq.hom) ≫ (ρ_ M).hom + map_add' f g := by + simp [MonoidalPreadditive.add_whiskerRight, Preadditive.comp_add, + Preadditive.add_comp] + map_smul' c f := by + simp [MonoidalLinear.smul_whiskerRight, Linear.comp_smul, + Linear.smul_comp] + invFun g := L.sq.inv ≫ (g ▷ L.obj) + left_inv f := by + change L.sq.inv ≫ (((λ_ L.obj).inv ≫ (f ▷ L.obj) ≫ + (α_ M L.obj L.obj).hom ≫ (M ◁ L.sq.hom) ≫ (ρ_ M).hom) + ▷ L.obj) = f + let := L.exactPairing + have hs : ∀ F : 𝟙_ D ⟶ M ⊗ L.obj, + (tensorRightHomEquiv (𝟙_ D) L.obj L.obj M).symm F = + (F ▷ L.obj) ≫ (α_ M L.obj L.obj).hom ≫ + (M ◁ L.sq.hom) ≫ (ρ_ M).hom := fun _ => rfl + have ht : ∀ g : 𝟙_ D ⊗ L.obj ⟶ M, + (tensorRightHomEquiv (𝟙_ D) L.obj L.obj M) g = + (ρ_ (𝟙_ D)).inv ≫ (𝟙_ D ◁ L.sq.inv) ≫ + (α_ (𝟙_ D) L.obj L.obj).inv ≫ (g ▷ L.obj) := + fun _ => rfl + rw [← hs, L.coevaluation_whiskerRight, ← ht, + Equiv.apply_symm_apply] + right_inv g := by + change (λ_ L.obj).inv ≫ ((L.sq.inv ≫ (g ▷ L.obj)) ▷ L.obj) ≫ + (α_ M L.obj L.obj).hom ≫ (M ◁ L.sq.hom) ≫ (ρ_ M).hom = g + let := L.exactPairing + have hs : ∀ F : 𝟙_ D ⟶ M ⊗ L.obj, + (tensorRightHomEquiv (𝟙_ D) L.obj L.obj M).symm F = + (F ▷ L.obj) ≫ (α_ M L.obj L.obj).hom ≫ + (M ◁ L.sq.hom) ≫ (ρ_ M).hom := fun _ => rfl + have ht : ∀ g : 𝟙_ D ⊗ L.obj ⟶ M, + (tensorRightHomEquiv (𝟙_ D) L.obj L.obj M) g = + (ρ_ (𝟙_ D)).inv ≫ (𝟙_ D ◁ L.sq.inv) ≫ + (α_ (𝟙_ D) L.obj L.obj).inv ≫ (g ▷ L.obj) := + fun _ => rfl + have hkey : (tensorRightHomEquiv (𝟙_ D) L.obj L.obj M) + ((λ_ L.obj).hom ≫ g) = L.sq.inv ≫ (g ▷ L.obj) := by + rw [ht, ← L.coevaluation_whiskerRight, Iso.inv_hom_id_assoc] + rw [← hs, ← hkey, Equiv.symm_apply_apply, Iso.inv_hom_id_assoc] + +@[simp] +theorem oddParitySwap_apply + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (M : D) + (f : 𝟙_ D ⟶ M ⊗ L.obj) : + oddParitySwap L M f = (λ_ L.obj).inv ≫ (f ▷ L.obj) ≫ + (α_ M L.obj L.obj).hom ≫ (M ◁ L.sq.hom) ≫ (ρ_ M).hom := + rfl + +@[simp] +theorem oddParitySwap_symm_apply + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (M : D) + (g : L.obj ⟶ M) : + (oddParitySwap L M).symm g = L.sq.inv ≫ (g ▷ L.obj) := + rfl + +/-- **Tensoring by the odd line swaps parity**, with the twist on +the left. Transporting along the braiding reduces this to the +right-handed form. -/ +noncomputable def oddParitySwapLeft + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (M : D) : + (𝟙_ D ⟶ L.obj ⊗ M) ≃ₗ[ℂ] (L.obj ⟶ M) := + (Linear.homCongr ℂ (Iso.refl (𝟙_ D)) (β_ L.obj M)).trans + (oddParitySwap L M) + +@[simp] +theorem oddParitySwapLeft_apply + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (M : D) + (f : 𝟙_ D ⟶ L.obj ⊗ M) : + oddParitySwapLeft L M f = (λ_ L.obj).inv ≫ + ((f ≫ (β_ L.obj M).hom) ▷ L.obj) ≫ + (α_ M L.obj L.obj).hom ≫ (M ◁ L.sq.hom) ≫ (ρ_ M).hom := by + rw [oddParitySwapLeft, LinearEquiv.trans_apply, + Linear.homCongr_apply, oddParitySwap_apply, Iso.refl_inv, + Category.id_comp] + +@[simp] +theorem oddParitySwapLeft_symm_apply + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (M : D) + (g : L.obj ⟶ M) : + (oddParitySwapLeft L M).symm g = + L.sq.inv ≫ (g ▷ L.obj) ≫ (β_ L.obj M).inv := by + rw [oddParitySwapLeft, LinearEquiv.symm_trans_apply, + oddParitySwap_symm_apply, Linear.homCongr_symm_apply, + Iso.refl_hom, Category.id_comp, Category.assoc] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddPermSign.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddPermSign.lean new file mode 100644 index 0000000000..26e9937344 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddPermSign.lean @@ -0,0 +1,123 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 + +/-! +# The sign action on tensor powers of an odd line + +The permutation action on a tensor power of an odd line is the sign +character. The line's self-braiding is `−1`, so the top braiding of +any tensor power is the negated identity; every adjacent +transposition therefore acts by `−1`, and functoriality of the +action, together with generation of the symmetric group by the +adjacent transpositions, forces a general permutation to act by its +sign. The linear extension evaluates the group algebra's action on +a single group element accordingly. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +variable {D : Type u} + +/-- **The top braiding of an odd line's tensor power is `−1`**: the +braiding of the top two factors is the line's self-braiding, +whiskered by the factors below, and negation passes through the +whiskering. -/ +theorem oddLine_swapTop + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] + (L : OddLine D) (n : ℕ) : + swapTop L.obj n = -𝟙 (tensorPow D L.obj (n + 2)) := by + unfold swapTop + erw [L.braid_neg, whiskerLeft_neg, MonoidalCategory.whiskerLeft_id, + Preadditive.neg_comp, Category.id_comp, Preadditive.comp_neg, + Iso.hom_inv_id] + +/-- **Every adjacent transposition acts by `−1`** on a tensor power +of an odd line: the top one is the top braiding, and the lower ones +are whiskered copies of the same evaluation one arity down. -/ +theorem oddLine_permMor_adjSwap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] + (L : OddLine D) : + ∀ (n : ℕ) (i : Fin (n + 1)), + permMor L.obj (n + 2) (Equiv.swap i.castSucc i.succ) = + -𝟙 (tensorPow D L.obj (n + 2)) := by + intro n + induction n with + | zero => + intro i + refine Fin.lastCases ?_ (fun j => j.elim0) i + rw [show Equiv.swap (Fin.castSucc (Fin.last 0)) (Fin.last 0).succ + = (topSwap : Equiv.Perm (Fin 2)) from by + rw [topSwap, Fin.succ_last], + permMor_topSwap_eq] + exact oddLine_swapTop L 0 + | succ n ih => + intro i + refine Fin.lastCases ?_ (fun j => ?_) i + · rw [show Equiv.swap (Fin.castSucc (Fin.last (n + 1))) + (Fin.last (n + 1)).succ + = (topSwap : Equiv.Perm (Fin (n + 3))) from by + rw [topSwap, Fin.succ_last], + permMor_topSwap_eq] + exact oddLine_swapTop L (n + 1) + · rw [swap_castSucc_succ_castSucc j, permMor_extPerm, ih j, + neg_whiskerRight, MonoidalCategory.id_whiskerRight] + rfl + +/-- **The permutation action on a tensor power of an odd line is the +sign character.** Both the action and the sign are multiplicative, +and every adjacent transposition acts by `−1`, so generation of the +symmetric group by the adjacent transpositions gives the general +permutation. -/ +theorem oddLine_permMor + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + (L : OddLine D) (n : ℕ) + (σ : Equiv.Perm (Fin n)) : + permMor L.obj n σ = + ((Equiv.Perm.sign σ : ℤ) : ℂ) • 𝟙 (tensorPow D L.obj n) := by + match n, σ with + | 0, σ => + have hσ : σ = 1 := Equiv.ext fun x => x.elim0 + rw [hσ, permMor_one, Equiv.Perm.sign_one] + simp + | 1, σ => + have hσ : σ = 1 := Equiv.ext fun x => Fin.ext (by omega) + rw [hσ, permMor_one, Equiv.Perm.sign_one] + simp + | n + 2, σ => + have key : ∀ τ : Equiv.Perm (Fin (n + 2)), + τ ∈ Submonoid.closure (Set.range fun i : Fin (n + 1) => + Equiv.swap i.castSucc i.succ) → + permMor L.obj (n + 2) τ = + ((Equiv.Perm.sign τ : ℤ) : ℂ) • + 𝟙 (tensorPow D L.obj (n + 2)) := by + intro τ hτ + induction hτ using Submonoid.closure_induction_left with + | one => + rw [permMor_one, Equiv.Perm.sign_one] + simp + | mul_left g hg τ' hτ' ihτ' => + obtain ⟨i, rfl⟩ := hg + rw [permMor_mul, ihτ', oddLine_permMor_adjSwap L n i, + Equiv.Perm.sign_mul, + Equiv.Perm.sign_swap (Fin.castSucc_lt_succ (i := i)).ne] + simp [neg_smul] + exact key σ (by + rw [Equiv.Perm.mclosure_swap_castSucc_succ]; trivial) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquare.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquare.lean new file mode 100644 index 0000000000..cdc6284757 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquare.lean @@ -0,0 +1,203 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModTensor + +/-! +# Contracting the shuffle of two odd twists + +The comparison map of Deligne's (2.11.1) at the free module of the +odd line against itself is a shuffle of two morphisms into `R ⊗ 1̄` +followed by the contraction of the two odd legs. Every such +morphism is a morphism into `R` with an odd leg attached, and the +whole composite then splits: the algebra factors multiply, and what +is left is a pure coherence identity between the two ways of +contracting the two odd legs. + +The four instances of that coherence identity — one for each pair +of parities — are the content of this file. Two of them carry a +sign, and the sign is the self-braiding of the odd line. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +section + +variable {D : Type u} + +/-- **Splitting off the algebra factors.** If two morphisms into +`R ⊗ 1̄` are a morphism into `R` with an odd leg attached, then +shuffling them and contracting the two odd legs multiplies the two +morphisms into `R`, after a pure contraction of the odd legs. -/ +theorem shuffle_contract + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) (R : D) [MonObj R] + {A B A' B' : D} (y : A' ⟶ R) (z : B' ⟶ R) + (pA : A ⟶ A' ⊗ L.obj) (pB : B ⟶ B' ⊗ L.obj) : + ((pA ≫ (y ▷ L.obj)) ⊗ₘ (pB ≫ (z ▷ L.obj))) ≫ + freeModShuffle R L.obj L.obj ≫ (R ◁ L.sq.hom) ≫ + (ρ_ R).hom = + ((pA ⊗ₘ pB) ≫ tensorμ A' L.obj B' L.obj ≫ + ((A' ⊗ B') ◁ L.sq.hom) ≫ (ρ_ (A' ⊗ B')).hom) ≫ + ((y ⊗ₘ z) ≫ μ[R]) := by + have hnat := tensorμ_natural (C := D) y (𝟙 L.obj) z (𝟙 L.obj) + rw [tensorHom_id, tensorHom_id, tensorHom_id, + MonoidalCategory.id_whiskerRight] at hnat + have hfs : ∀ {Z : D} (k : R ⊗ (L.obj ⊗ L.obj) ⟶ Z), + freeModShuffle R L.obj L.obj ≫ k = + tensorμ R L.obj R L.obj ≫ + (μ[R] ▷ (L.obj ⊗ L.obj)) ≫ k := + fun k => Category.assoc _ _ k + have hstep : ∀ {W : D} (g : W ⟶ R), + (g ▷ (L.obj ⊗ L.obj)) ≫ (R ◁ L.sq.hom) ≫ (ρ_ R).hom = + (W ◁ L.sq.hom) ≫ (ρ_ W).hom ≫ g := by + intro W g + rw [← Category.assoc, ← whisker_exchange, Category.assoc, + rightUnitor_naturality] + calc ((pA ≫ (y ▷ L.obj)) ⊗ₘ (pB ≫ (z ▷ L.obj))) ≫ + freeModShuffle R L.obj L.obj ≫ (R ◁ L.sq.hom) ≫ + (ρ_ R).hom + = (pA ⊗ₘ pB) ≫ ((y ▷ L.obj) ⊗ₘ (z ▷ L.obj)) ≫ + tensorμ R L.obj R L.obj ≫ (μ[R] ▷ (L.obj ⊗ L.obj)) ≫ + (R ◁ L.sq.hom) ≫ (ρ_ R).hom := by + rw [← tensorHom_comp_tensorHom, hfs] + simp only [Category.assoc] + _ = (pA ⊗ₘ pB) ≫ tensorμ A' L.obj B' L.obj ≫ + ((y ⊗ₘ z) ▷ (L.obj ⊗ L.obj)) ≫ + (μ[R] ▷ (L.obj ⊗ L.obj)) ≫ (R ◁ L.sq.hom) ≫ + (ρ_ R).hom := by + rw [← Category.assoc ((y ▷ L.obj) ⊗ₘ (z ▷ L.obj)), hnat] + simp only [Category.assoc, tensorHom_id] + _ = (pA ⊗ₘ pB) ≫ tensorμ A' L.obj B' L.obj ≫ + ((A' ⊗ B') ◁ L.sq.hom) ≫ (ρ_ (A' ⊗ B')).hom ≫ + (y ⊗ₘ z) ≫ μ[R] := by + rw [← comp_whiskerRight_assoc, hstep] + _ = ((pA ⊗ₘ pB) ≫ tensorμ A' L.obj B' L.obj ≫ + ((A' ⊗ B') ◁ L.sq.hom) ≫ (ρ_ (A' ⊗ B')).hom) ≫ + ((y ⊗ₘ z) ≫ μ[R]) := by + simp only [Category.assoc] + +/-! ## The four contraction identities -/ + +/-- **The middle-four interchange across two odd lines is minus the +identity**: its only braiding is the self-braiding of the line. -/ +theorem tensorμ_oddLine + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] (L : OddLine D) + (A : D) : + tensorμ A L.obj L.obj L.obj = + -𝟙 ((A ⊗ L.obj) ⊗ (L.obj ⊗ L.obj)) := by + change (α_ A L.obj (L.obj ⊗ L.obj)).hom ≫ + (A ◁ (α_ L.obj L.obj L.obj).inv) ≫ + (A ◁ (β_ L.obj L.obj).hom ▷ L.obj) ≫ + (A ◁ (α_ L.obj L.obj L.obj).hom) ≫ + (α_ A L.obj (L.obj ⊗ L.obj)).inv = _ + rw [L.braid_neg, neg_id_whiskerRight, whiskerLeft_neg_id, + Preadditive.neg_comp, Preadditive.comp_neg, + Preadditive.comp_neg] + refine congrArg Neg.neg ?_ + rw [Category.id_comp] + monoidal + +/-- **Contraction against a coevaluation carries a sign**: the two +odd legs cross. -/ +theorem oddContract_neg + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] (L : OddLine D) + {A A' : D} (pA : A ⟶ A' ⊗ L.obj) : + (ρ_ A).inv ≫ (pA ⊗ₘ L.sq.inv) ≫ + tensorμ A' L.obj L.obj L.obj ≫ + ((A' ⊗ L.obj) ◁ L.sq.hom) ≫ + (ρ_ (A' ⊗ L.obj)).hom = -pA := by + rw [tensorμ_oddLine L A'] + simp only [Preadditive.neg_comp, Preadditive.comp_neg, + Category.id_comp] + refine congrArg Neg.neg ?_ + rw [tensorHom_def, Category.assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + L.sq.inv_hom_id, MonoidalCategory.whiskerLeft_id, + Category.id_comp, rightUnitor_naturality, ← Category.assoc, + Iso.inv_hom_id, Category.id_comp] + +/-- **Contraction against a unitor carries no sign**: the free odd +leg passes only the unit. -/ +theorem oddContract_pos + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) + {A A' : D} (pA : A ⟶ A' ⊗ L.obj) : + (pA ⊗ₘ (λ_ L.obj).inv) ≫ tensorμ A' L.obj (𝟙_ D) L.obj ≫ + ((A' ⊗ 𝟙_ D) ◁ L.sq.hom) ≫ (ρ_ (A' ⊗ 𝟙_ D)).hom = + (pA ▷ L.obj) ≫ (α_ A' L.obj L.obj).hom ≫ + (A' ◁ L.sq.hom) := by + have hk : ((A' ⊗ L.obj) ◁ (λ_ L.obj).inv) ≫ + tensorμ A' L.obj (𝟙_ D) L.obj ≫ + ((A' ⊗ 𝟙_ D) ◁ L.sq.hom) ≫ (ρ_ (A' ⊗ 𝟙_ D)).hom = + (α_ A' L.obj L.obj).hom ≫ (A' ◁ L.sq.hom) := by + simp only [tensorμ, braiding_tensorUnit_right] + monoidal + rw [tensorHom_def, Category.assoc, hk] + +/-- The even–even contraction: a sign. -/ +theorem oddContract_ee + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] (L : OddLine D) : + (λ_ (𝟙_ D)).inv ≫ (L.sq.inv ⊗ₘ L.sq.inv) ≫ + tensorμ L.obj L.obj L.obj L.obj ≫ + ((L.obj ⊗ L.obj) ◁ L.sq.hom) ≫ + (ρ_ (L.obj ⊗ L.obj)).hom = -L.sq.inv := by + rw [unitors_inv_equal] + exact oddContract_neg L L.sq.inv + +/-- The odd–even contraction: a sign. -/ +theorem oddContract_oe + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] (L : OddLine D) : + (ρ_ L.obj).inv ≫ ((λ_ L.obj).inv ⊗ₘ L.sq.inv) ≫ + tensorμ (𝟙_ D) L.obj L.obj L.obj ≫ + ((𝟙_ D ⊗ L.obj) ◁ L.sq.hom) ≫ + (ρ_ (𝟙_ D ⊗ L.obj)).hom = -(λ_ L.obj).inv := + oddContract_neg L (λ_ L.obj).inv + +/-- The odd–odd contraction: no sign. -/ +theorem oddContract_oo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) : + L.sq.inv ≫ ((λ_ L.obj).inv ⊗ₘ (λ_ L.obj).inv) ≫ + tensorμ (𝟙_ D) L.obj (𝟙_ D) L.obj ≫ + ((𝟙_ D ⊗ 𝟙_ D) ◁ L.sq.hom) ≫ + (ρ_ (𝟙_ D ⊗ 𝟙_ D)).hom = (λ_ (𝟙_ D)).inv := by + rw [oddContract_pos L (λ_ L.obj).inv] + have hc : ((λ_ L.obj).inv ▷ L.obj) ≫ + (α_ (𝟙_ D) L.obj L.obj).hom = (λ_ (L.obj ⊗ L.obj)).inv := by + monoidal + rw [← Category.assoc ((λ_ L.obj).inv ▷ L.obj), hc, + ← leftUnitor_inv_naturality, ← Category.assoc, + L.sq.inv_hom_id, Category.id_comp] + +/-- The even–odd contraction: no sign; it is the triangle identity +of the odd line. -/ +theorem oddContract_eo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] (L : OddLine D) : + (λ_ L.obj).inv ≫ (L.sq.inv ⊗ₘ (λ_ L.obj).inv) ≫ + tensorμ L.obj L.obj (𝟙_ D) L.obj ≫ + ((L.obj ⊗ 𝟙_ D) ◁ L.sq.hom) ≫ + (ρ_ (L.obj ⊗ 𝟙_ D)).hom = (ρ_ L.obj).inv := by + rw [oddContract_pos L L.sq.inv, L.evaluation_coevaluation, + ← Category.assoc, Iso.inv_hom_id, Category.id_comp] + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquareIso.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquareIso.lean new file mode 100644 index 0000000000..1893a0854b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquareIso.lean @@ -0,0 +1,380 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddSquare +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMu +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaShift +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShiftUnit + +/-! +# The comparison map at the odd line against itself + +The realization of the free module on the odd line is the parity +shift of the Γ-algebra, and the parity shift of the algebra is +invertible for the tensor product of super modules. Under those +two identifications the comparison map of Deligne's (2.11.1) at the +odd line against itself is minus the canonical isomorphism, so it +is an isomorphism. The sign is the self-braiding of the line and +is the same on all four blocks. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +section + +variable {D : Type u} + +/-! ## The two parity swaps, inverted -/ + +/-- The odd parity swap, unfolded. -/ +theorem rhoOddOdd_apply + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) + (M : D) (g : L.obj ⟶ M ⊗ L.obj) : + rhoOddOdd L M g = (L.sq.inv ≫ (g ▷ L.obj)) ≫ + ((α_ M L.obj L.obj).hom ≫ (M ◁ L.sq.hom) ≫ + (ρ_ M).hom) := by + rw [rhoOddOdd, LinearEquiv.trans_apply, Linear.homCongr_apply, + Iso.refl_inv, Category.id_comp] + rfl + +/-- The odd parity swap, inverted. -/ +theorem rhoOddOdd_symm_apply + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) + (y : 𝟙_ D ⟶ R) : + (rhoOddOdd L R).symm y = (λ_ L.obj).inv ≫ (y ▷ L.obj) := by + refine (LinearEquiv.symm_apply_eq _).mpr ?_ + have hc : ((λ_ L.obj).inv ▷ L.obj) ≫ + (α_ (𝟙_ D) L.obj L.obj).hom = (λ_ (L.obj ⊗ L.obj)).inv := by + monoidal + rw [rhoOddOdd_apply, MonoidalCategory.comp_whiskerRight] + simp only [Category.assoc] + rw [← Category.assoc ((y ▷ L.obj) ▷ L.obj), + associator_naturality_left] + simp only [Category.assoc] + rw [← Category.assoc (y ▷ (L.obj ⊗ L.obj)), ← whisker_exchange] + simp only [Category.assoc] + rw [rightUnitor_naturality, + ← Category.assoc ((λ_ L.obj).inv ▷ L.obj), hc, + ← Category.assoc (λ_ (L.obj ⊗ L.obj)).inv, + ← leftUnitor_inv_naturality] + simp only [Category.assoc] + rw [← Category.assoc L.sq.inv, L.sq.inv_hom_id, Category.id_comp, + ← Category.assoc, unitors_inv_equal, Iso.inv_hom_id, + Category.id_comp] + +/-! ## The comparison at the odd line against itself -/ + +attribute [local instance] CategoryTheory.ModObj.regular + +open SuperCommAlgebra.Mod + +/-- The comparison map at the odd line against itself, followed by +the two identifications of the target with the algebra. -/ +noncomputable abbrev oddSqMap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] : + (gammaModule D L R (freeMod R L.obj).X).tensor + (gammaModule D L R (freeMod R L.obj).X) ⟶ + (gammaAlgebra D L R).unitMod := + fibreMu L R L.obj L.obj ≫ + gammaFunMap L R (freeModMap R L.sq.hom) ≫ + gammaFunMap L R (freeModUnitIso R).hom + +/-- The identification of the source with the parity shift of the +algebra, on both factors. -/ +noncomputable abbrev oddSqShift + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] : + (gammaModule D L R (freeMod R L.obj).X).tensor + (gammaModule D L R (freeMod R L.obj).X) ⟶ + (gammaAlgebra D L R).unitMod := + SuperCommAlgebra.Mod.tensorHom (gammaShiftIso L R).hom + (gammaShiftIso L R).hom ≫ + (shiftUnitTensor (shift (gammaAlgebra D L R).unitMod)).hom + +/-! ### Evaluation on the four generator families -/ + +private theorem oddSqMap_ee + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (u v : 𝟙_ D ⟶ R ⊗ L.obj) : + (oddSqMap L R).evenMap (tmulEE _ _ u v) = + (λ_ (𝟙_ D)).inv ≫ (u ⊗ₘ v) ≫ + freeModShuffle R L.obj L.obj ≫ (R ◁ L.sq.hom) ≫ + (ρ_ R).hom := by + change ((fibreMu L R L.obj L.obj).evenMap (tmulEE _ _ u v) ≫ + (R ◁ L.sq.hom)) ≫ (ρ_ R).hom = _ + rw [fibreMu_evenMap_tmulEE] + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (Category.assoc _ _ _) + +private theorem oddSqMap_oo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (u v : L.obj ⟶ R ⊗ L.obj) : + (oddSqMap L R).evenMap (tmulOO _ _ u v) = + L.sq.inv ≫ (u ⊗ₘ v) ≫ + freeModShuffle R L.obj L.obj ≫ (R ◁ L.sq.hom) ≫ + (ρ_ R).hom := by + change ((fibreMu L R L.obj L.obj).evenMap (tmulOO _ _ u v) ≫ + (R ◁ L.sq.hom)) ≫ (ρ_ R).hom = _ + rw [fibreMu_evenMap_tmulOO] + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (Category.assoc _ _ _) + +private theorem oddSqMap_eo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (u : 𝟙_ D ⟶ R ⊗ L.obj) + (v : L.obj ⟶ R ⊗ L.obj) : + (oddSqMap L R).oddMap (tmulEO _ _ u v) = + (λ_ L.obj).inv ≫ (u ⊗ₘ v) ≫ + freeModShuffle R L.obj L.obj ≫ (R ◁ L.sq.hom) ≫ + (ρ_ R).hom := by + change ((fibreMu L R L.obj L.obj).oddMap (tmulEO _ _ u v) ≫ + (R ◁ L.sq.hom)) ≫ (ρ_ R).hom = _ + rw [fibreMu_oddMap_tmulEO] + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (Category.assoc _ _ _) + +private theorem oddSqMap_oe + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (u : L.obj ⟶ R ⊗ L.obj) + (v : 𝟙_ D ⟶ R ⊗ L.obj) : + (oddSqMap L R).oddMap (tmulOE _ _ u v) = + (ρ_ L.obj).inv ≫ (u ⊗ₘ v) ≫ + freeModShuffle R L.obj L.obj ≫ (R ◁ L.sq.hom) ≫ + (ρ_ R).hom := by + change ((fibreMu L R L.obj L.obj).oddMap (tmulOE _ _ u v) ≫ + (R ◁ L.sq.hom)) ≫ (ρ_ R).hom = _ + rw [fibreMu_oddMap_tmulOE] + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (Category.assoc _ _ _) + +private theorem rhoEvenOdd_expand + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) + (a : L.obj ⟶ R) : + rhoEvenOdd L R (L.sq.inv ≫ (a ▷ L.obj)) = a := + (rhoEvenOdd L R).apply_symm_apply a + +private theorem rhoOddOdd_expand + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) + (x : 𝟙_ D ⟶ R) : + rhoOddOdd L R ((λ_ L.obj).inv ≫ (x ▷ L.obj)) = x := by + rw [← rhoOddOdd_symm_apply] + exact (rhoOddOdd L R).apply_symm_apply x + +private theorem oddSqShift_ee + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (a b : L.obj ⟶ R) : + (oddSqShift L R).evenMap (tmulEE _ _ + (L.sq.inv ≫ (a ▷ L.obj)) (L.sq.inv ≫ (b ▷ L.obj))) = + L.sq.inv ≫ (a ⊗ₘ b) ≫ μ[R] := by + change (shiftUnitHom (shift (gammaAlgebra D L R).unitMod)).evenMap + (tmulEE (shift (gammaAlgebra D L R).unitMod) + (shift (gammaAlgebra D L R).unitMod) + (rhoEvenOdd L R (L.sq.inv ≫ (a ▷ L.obj))) + (rhoEvenOdd L R (L.sq.inv ≫ (b ▷ L.obj)))) = _ + erw [rhoEvenOdd_expand, rhoEvenOdd_expand, + shiftUnitHom_evenMap_tmulEE] + rfl + +private theorem oddSqShift_oo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (x y : 𝟙_ D ⟶ R) : + (oddSqShift L R).evenMap (tmulOO _ _ + ((λ_ L.obj).inv ≫ (x ▷ L.obj)) + ((λ_ L.obj).inv ≫ (y ▷ L.obj))) = + -((λ_ (𝟙_ D)).inv ≫ (x ⊗ₘ y) ≫ μ[R]) := by + change (shiftUnitHom (shift (gammaAlgebra D L R).unitMod)).evenMap + (tmulOO (shift (gammaAlgebra D L R).unitMod) + (shift (gammaAlgebra D L R).unitMod) + (rhoOddOdd L R ((λ_ L.obj).inv ≫ (x ▷ L.obj))) + (rhoOddOdd L R ((λ_ L.obj).inv ≫ (y ▷ L.obj)))) = _ + erw [rhoOddOdd_expand, rhoOddOdd_expand, + shiftUnitHom_evenMap_tmulOO] + rfl + +private theorem oddSqShift_eo + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (a : L.obj ⟶ R) (x : 𝟙_ D ⟶ R) : + (oddSqShift L R).oddMap (tmulEO _ _ + (L.sq.inv ≫ (a ▷ L.obj)) + ((λ_ L.obj).inv ≫ (x ▷ L.obj))) = + -((ρ_ L.obj).inv ≫ (a ⊗ₘ x) ≫ μ[R]) := by + change (shiftUnitHom (shift (gammaAlgebra D L R).unitMod)).oddMap + (tmulEO (shift (gammaAlgebra D L R).unitMod) + (shift (gammaAlgebra D L R).unitMod) + (rhoEvenOdd L R (L.sq.inv ≫ (a ▷ L.obj))) + (rhoOddOdd L R ((λ_ L.obj).inv ≫ (x ▷ L.obj)))) = _ + erw [rhoEvenOdd_expand, rhoOddOdd_expand, + shiftUnitHom_oddMap_tmulEO] + rfl + +private theorem oddSqShift_oe + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + (x : 𝟙_ D ⟶ R) (a : L.obj ⟶ R) : + (oddSqShift L R).oddMap (tmulOE _ _ + ((λ_ L.obj).inv ≫ (x ▷ L.obj)) + (L.sq.inv ≫ (a ▷ L.obj))) = + (λ_ L.obj).inv ≫ (x ⊗ₘ a) ≫ μ[R] := by + change (shiftUnitHom (shift (gammaAlgebra D L R).unitMod)).oddMap + (tmulOE (shift (gammaAlgebra D L R).unitMod) + (shift (gammaAlgebra D L R).unitMod) + (rhoOddOdd L R ((λ_ L.obj).inv ≫ (x ▷ L.obj))) + (rhoEvenOdd L R (L.sq.inv ≫ (a ▷ L.obj)))) = _ + erw [rhoOddOdd_expand, rhoEvenOdd_expand, + shiftUnitHom_oddMap_tmulOE] + rfl + +/-! ### The identification -/ + +private theorem exists_even + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) + (u : 𝟙_ D ⟶ R ⊗ L.obj) : + ∃ a : L.obj ⟶ R, L.sq.inv ≫ (a ▷ L.obj) = u := + ⟨rhoEvenOdd L R u, (rhoEvenOdd L R).symm_apply_apply u⟩ + +private theorem exists_odd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) + (u : L.obj ⟶ R ⊗ L.obj) : + ∃ x : 𝟙_ D ⟶ R, (λ_ L.obj).inv ≫ (x ▷ L.obj) = u := by + refine ⟨rhoOddOdd L R u, ?_⟩ + rw [← rhoOddOdd_symm_apply] + exact (rhoOddOdd L R).symm_apply_apply u + +/-- **The comparison map at the odd line against itself is minus +the canonical isomorphism.** The sign is the self-braiding of the +line, and it is the same on all four blocks. -/ +theorem oddSqMap_eq [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] : + oddSqMap L R = -oddSqShift L R := by + refine hom_ext (fun u v => ?_) (fun u v => ?_) (fun u v => ?_) + (fun u v => ?_) + · obtain ⟨a, rfl⟩ := exists_even L R u + obtain ⟨b, rfl⟩ := exists_even L R v + rw [oddSqMap_ee, shuffle_contract, ← Category.assoc, + oddContract_ee, Preadditive.neg_comp, neg_evenMap, + LinearMap.neg_apply] + exact congrArg Neg.neg (oddSqShift_ee L R a b).symm + · obtain ⟨x, rfl⟩ := exists_odd L R u + obtain ⟨y, rfl⟩ := exists_odd L R v + rw [oddSqMap_oo, shuffle_contract, ← Category.assoc, + oddContract_oo, neg_evenMap, LinearMap.neg_apply] + exact Eq.trans (neg_neg _).symm + (congrArg Neg.neg (oddSqShift_oo L R x y).symm) + · obtain ⟨a, rfl⟩ := exists_even L R u + obtain ⟨x, rfl⟩ := exists_odd L R v + rw [oddSqMap_eo, shuffle_contract, ← Category.assoc, + oddContract_eo, neg_oddMap, LinearMap.neg_apply] + exact Eq.trans (neg_neg _).symm + (congrArg Neg.neg (oddSqShift_eo L R a x).symm) + · obtain ⟨x, rfl⟩ := exists_odd L R u + obtain ⟨a, rfl⟩ := exists_even L R v + rw [oddSqMap_oe, shuffle_contract, ← Category.assoc, + oddContract_oe, Preadditive.neg_comp, neg_oddMap, + LinearMap.neg_apply] + exact congrArg Neg.neg (oddSqShift_oe L R x a).symm + +/-! ### Invertibility -/ + +/-- **The comparison map of (2.11.1) at the odd line against +itself is an isomorphism.** -/ +theorem isIso_gammaPairComparison_oddSquare + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] : + IsIso (gammaPairComparison L R (freeMod R L.obj) + (freeMod R L.obj)) := by + have hsh : IsIso (oddSqShift L R) := + ((SuperCommAlgebra.Mod.tensorIso (gammaShiftIso L R) (gammaShiftIso L R)).trans + (shiftUnitTensor (shift (gammaAlgebra D L R).unitMod))).isIso_hom + have hmap : IsIso (oddSqMap L R) := by + rw [oddSqMap_eq] + refine ⟨-inv (oddSqShift L R), ?_, ?_⟩ + · rw [Preadditive.neg_comp, Preadditive.comp_neg, neg_neg, + IsIso.hom_inv_id] + · rw [Preadditive.neg_comp, Preadditive.comp_neg, neg_neg, + IsIso.inv_hom_id] + have h1 : IsIso (gammaFunMap L R (freeModMap R L.sq.hom)) := + ((gammaModuleFunctor L R).mapIso + (freeModMapIso R L.sq)).isIso_hom + have h2 : IsIso (gammaFunMap L R (freeModUnitIso R).hom) := + ((gammaModuleFunctor L R).mapIso (freeModUnitIso R)).isIso_hom + have h3 : IsIso (gammaFunMap L R (freeModMap R L.sq.hom) ≫ + gammaFunMap L R (freeModUnitIso R).hom) := IsIso.comp_isIso + have h4 : IsIso (gammaFunMap L R + (freeModTensorIso R L.obj L.obj).hom) := + ((gammaModuleFunctor L R).mapIso + (freeModTensorIso R L.obj L.obj)).isIso_hom + have hmu : IsIso (gammaPairComparison L R (freeMod R L.obj) + (freeMod R L.obj) ≫ + gammaFunMap L R (freeModTensorIso R L.obj L.obj).hom) := + @IsIso.of_isIso_comp_right _ _ _ _ _ + (fibreMu L R L.obj L.obj) + (gammaFunMap L R (freeModMap R L.sq.hom) ≫ + gammaFunMap L R (freeModUnitIso R).hom) h3 hmap + exact IsIso.of_isIso_comp_right _ + (gammaFunMap L R (freeModTensorIso R L.obj L.obj).hom) + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairCarrier.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairCarrier.lean new file mode 100644 index 0000000000..0be5dd03be --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairCarrier.lean @@ -0,0 +1,116 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SeedIns + +/-! +# The pair product on the graded carrier + +The descended pair product of the module entries lands two stages +up the degree-zero line of the graded splitting algebra carrier. +Through the component insertions, the transitions are absorbed +and the copair element multiplies to the unit of the carrier — +the section identity of the splitting data of the Key Lemma. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The pair product on the carrier**: the descended pair +product of the entries, entering the degree-zero component two +stages up. -/ +noncomputable def splitPairMul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + (d : ModDualityDatum A M M') : + modTensor A M M' ⟶ chainBGr A M M' d := + chainPairMul A M M' d ≫ + chainStage2Cast A M M' + (by omega : 2 = (-(0 : ℤ)).toNat + 2) + (by omega : 2 = (0 : ℤ).toNat + 2) ≫ + chainBGrCompι A M M' d 0 2 ≫ + chainBGrι A M M' d 0 + +/-- **The copair element multiplies to the unit on the carrier**: +the section identity of the splitting data. -/ +theorem copairUnit_splitPairMul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + (d : ModDualityDatum A M M') : + copairUnit A M M' d ≫ splitPairMul A M M' d = + chainBGrUnit A M M' d := by + have hA : chainStage2Cast A M M' + (by omega : 2 = (-(0 : ℤ)).toNat + 2) + (by omega : 2 = (0 : ℤ).toNat + 2) ≫ + chainBGrCompι A M M' d 0 2 = + chainBGrCompι A M M' d 0 2 := + chainStage2Cast_chainBGrCompι A M M' d 0 + (rfl : (2 : ℕ) = 2) + have hB : chainDelta2 A M M' d 1 1 ≫ + chainBGrCompι A M M' d 0 2 = + chainBGrCompι A M M' d 0 1 := + chainDelta2_chainBGrCompι A M M' d 0 1 + have hC : chainDelta2 A M M' d 0 0 ≫ + chainBGrCompι A M M' d 0 1 = + chainBGrCompι A M M' d 0 0 := + chainDelta2_chainBGrCompι A M M' d 0 0 + have k1 : chainStage2Cast A M M' + (by omega : 2 = (-(0 : ℤ)).toNat + 2) + (by omega : 2 = (0 : ℤ).toNat + 2) ≫ + chainBGrCompι A M M' d 0 2 ≫ chainBGrι A M M' d 0 = + chainBGrCompι A M M' d 0 2 ≫ chainBGrι A M M' d 0 := + (Category.assoc _ _ _).symm.trans (eq_whisker hA _) + have k2 : chainDelta2 A M M' d 1 1 ≫ + chainBGrCompι A M M' d 0 2 ≫ chainBGrι A M M' d 0 = + chainBGrCompι A M M' d 0 1 ≫ chainBGrι A M M' d 0 := + (Category.assoc _ _ _).symm.trans (eq_whisker hB _) + have k3 : chainDelta2 A M M' d 0 0 ≫ + chainBGrCompι A M M' d 0 1 ≫ chainBGrι A M M' d 0 = + chainBGrCompι A M M' d 0 0 ≫ chainBGrι A M M' d 0 := + (Category.assoc _ _ _).symm.trans (eq_whisker hC _) + have h2 : chainBGrUnit A M M' d = + chainSeed A M M' d ≫ chainBGrCompι A M M' d 0 0 ≫ + chainBGrι A M M' d 0 := by + erw [chainBGrUnit, ← Category.assoc, + chainBUnit_chainBGrComponentZeroIso_inv, Category.assoc] + change copairUnit A M M' d ≫ chainPairMul A M M' d ≫ + chainStage2Cast A M M' + (by omega : 2 = (-(0 : ℤ)).toNat + 2) + (by omega : 2 = (0 : ℤ).toNat + 2) ≫ + chainBGrCompι A M M' d 0 2 ≫ chainBGrι A M M' d 0 = + chainBGrUnit A M M' d + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans + (eq_whisker (copairUnit_chainPairMul A M M' d) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans + (whisker_eq _ (whisker_eq _ (whisker_eq _ k1))) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ k2)) ?_ + refine Eq.trans (whisker_eq _ k3) ?_ + exact h2.symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairMul.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairMul.lean new file mode 100644 index 0000000000..4b5fa3a52a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairMul.lean @@ -0,0 +1,676 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowActMul + +/-! +# The interchange of module tensor products + +The pair-multiplication device of the Key Lemma's chain algebra: +over a symmetric base, the tensor product of two module tensor +products interchanges into the module tensor product of the +crossed pairs. The chain transitions and the stage products of +the splitting algebra factor through it. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- The raw interchange: cross the middle factors. -/ +def rawInterchange + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (N₁ : Mod D A) (N₂ : Mod D A) (P₁ : Mod D A) (P₂ : Mod D A) : + (N₁.X ⊗ N₂.X) ⊗ (P₁.X ⊗ P₂.X) ⟶ + (N₁.X ⊗ P₁.X) ⊗ (N₂.X ⊗ P₂.X) := + tensorμ N₁.X N₂.X P₁.X P₂.X + +/-- The raw interchange followed by the projections. -/ +noncomputable def rawInterchangeπ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (N₁ : Mod D A) (N₂ : Mod D A) + (P₁ : Mod D A) (P₂ : Mod D A) : + (N₁.X ⊗ N₂.X) ⊗ (P₁.X ⊗ P₂.X) ⟶ + modTensor A (modTensorMod A N₁ P₁) (modTensorMod A N₂ P₂) := + rawInterchange A N₁ N₂ P₁ P₂ ≫ + (modTensorπ A N₁ P₁ ⊗ₘ modTensorπ A N₂ P₂) ≫ + modTensorπ A (modTensorMod A N₁ P₁) (modTensorMod A N₂ P₂) + +/-- The scalar-carrying rearrangement: the interchange at the +scalar-extended first block, the scalar crossing to the block +boundary. -/ +noncomputable def midArrange + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (N₁ : Mod D A) (N₂ : Mod D A) (P₁ : Mod D A) (P₂ : Mod D A) : + ((N₁.X ⊗ A) ⊗ N₂.X) ⊗ (P₁.X ⊗ P₂.X) ⟶ + ((N₁.X ⊗ P₁.X) ⊗ A) ⊗ (N₂.X ⊗ P₂.X) := + tensorμ (N₁.X ⊗ A) N₂.X P₁.X P₂.X ≫ + (((α_ N₁.X A P₁.X).hom ≫ (N₁.X ◁ (β_ A P₁.X).hom) ≫ + (α_ N₁.X P₁.X A).inv) ▷ (N₂.X ⊗ P₂.X)) + +/-- The coherence core of the left leg identification. -/ +private theorem legM_core + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + {V₁ W₁ U Q₁ Q₂ Z : D} + (act : A ⊗ V₁ ⟶ V₁) (q₁ : V₁ ⊗ W₁ ⟶ Q₁) (q₂ : U ⟶ Q₂) + (out : Q₁ ⊗ Q₂ ⟶ Z) : + ((((β_ V₁ A).hom ≫ act) ▷ W₁) ▷ U) ≫ + (q₁ ⊗ₘ q₂) ≫ out = + (((α_ V₁ A W₁).hom ≫ (V₁ ◁ (β_ A W₁).hom) ≫ + (α_ V₁ W₁ A).inv) ▷ U) ≫ + ((((β_ (V₁ ⊗ W₁) A).hom ≫ (α_ A V₁ W₁).inv ≫ + (act ▷ W₁)) ≫ q₁) ⊗ₘ q₂) ≫ out := by + have hq : ∀ {Y : D} (x : Y ⟶ V₁ ⊗ W₁), + ((x ≫ q₁) ⊗ₘ q₂) = (x ▷ U) ≫ (q₁ ⊗ₘ q₂) := by + intro Y x + rw [MonoidalCategory.tensorHom_def, + MonoidalCategory.tensorHom_def, comp_whiskerRight, + Category.assoc] + rw [hq] + simp only [Category.assoc] + rw [← comp_whiskerRight_assoc] + suffices h : ((β_ V₁ A).hom ≫ act) ▷ W₁ = + ((α_ V₁ A W₁).hom ≫ (V₁ ◁ (β_ A W₁).hom) ≫ + (α_ V₁ W₁ A).inv) ≫ + ((β_ (V₁ ⊗ W₁) A).hom ≫ (α_ A V₁ W₁).inv ≫ + (act ▷ W₁)) by rw [h] + rw [BraidedCategory.braiding_tensor_left_hom] + simp only [Category.assoc, Iso.inv_hom_id_assoc] + rw [← MonoidalCategory.whiskerLeft_comp_assoc, + SymmetricCategory.symmetry, MonoidalCategory.whiskerLeft_id, + Category.id_comp, Iso.hom_inv_id_assoc, + comp_whiskerRight] + simp only [Iso.hom_inv_id_assoc] + +/-- The coherence core of the right leg identification. -/ +private theorem legN_core + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + {V₁ V₂ W₁ W₂ Q₁ Q₂ Z : D} + (act : A ⊗ V₂ ⟶ V₂) (q₁ : V₁ ⊗ W₁ ⟶ Q₁) + (q₂ : V₂ ⊗ W₂ ⟶ Q₂) (out : Q₁ ⊗ Q₂ ⟶ Z) : + ((α_ V₁ A V₂).hom ▷ (W₁ ⊗ W₂)) ≫ + tensorμ V₁ (A ⊗ V₂) W₁ W₂ ≫ + (q₁ ⊗ₘ ((act ▷ W₂) ≫ q₂)) ≫ out = + tensorμ (V₁ ⊗ A) V₂ W₁ W₂ ≫ + (((α_ V₁ A W₁).hom ≫ (V₁ ◁ (β_ A W₁).hom) ≫ + (α_ V₁ W₁ A).inv) ▷ (V₂ ⊗ W₂)) ≫ + (α_ (V₁ ⊗ W₁) A (V₂ ⊗ W₂)).hom ≫ + ((V₁ ⊗ W₁) ◁ (α_ A V₂ W₂).inv) ≫ + (q₁ ⊗ₘ ((act ▷ W₂) ≫ q₂)) ≫ out := by + suffices h : ((α_ V₁ A V₂).hom ▷ (W₁ ⊗ W₂)) ≫ + tensorμ V₁ (A ⊗ V₂) W₁ W₂ = + tensorμ (V₁ ⊗ A) V₂ W₁ W₂ ≫ + (((α_ V₁ A W₁).hom ≫ (V₁ ◁ (β_ A W₁).hom) ≫ + (α_ V₁ W₁ A).inv) ▷ (V₂ ⊗ W₂)) ≫ + (α_ (V₁ ⊗ W₁) A (V₂ ⊗ W₂)).hom ≫ + ((V₁ ⊗ W₁) ◁ (α_ A V₂ W₂).inv) by + rw [reassoc_of% h] + simp only [tensorμ] + rw [BraidedCategory.braiding_tensor_left_hom A V₂ W₁] + monoidal + +/-- The left slide of the first factors becomes the outer left +slide of the target. -/ +theorem interchange_legM + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (N₁ : Mod D A) (N₂ : Mod D A) + (P₁ : Mod D A) (P₂ : Mod D A) : + (modTensorLegM A N₁ N₂ ▷ (P₁.X ⊗ P₂.X)) ≫ + rawInterchangeπ A N₁ N₂ P₁ P₂ = + midArrange A N₁ N₂ P₁ P₂ ≫ + ((modTensorπ A N₁ P₁ ▷ A) ⊗ₘ modTensorπ A N₂ P₂) ≫ + modTensorLegM A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) ≫ + modTensorπ A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) := by + have h1 := tensorμ_natural (actRight A N₁.X) (𝟙 N₂.X) + (𝟙 P₁.X) (𝟙 P₂.X) + simp only [MonoidalCategory.id_whiskerRight, + MonoidalCategory.tensorHom_id] at h1 + conv_lhs => rw [modTensorLegM, rawInterchangeπ, + rawInterchange, reassoc_of% h1] + have hslot : (modTensorπ A N₁ P₁ ▷ A) ≫ + (β_ (modTensor A N₁ P₁) A).hom ≫ modTensorAct A N₁ P₁ = + (β_ (N₁.X ⊗ P₁.X) A).hom ≫ (α_ A N₁.X P₁.X).inv ≫ + (actLeft A N₁.X ▷ P₁.X) ≫ modTensorπ A N₁ P₁ := by + rw [BraidedCategory.braiding_naturality_left_assoc, + whiskerLeft_modTensorπ_act] + simp only [Category.assoc] + have hcov : ((modTensorπ A N₁ P₁ ▷ A) ⊗ₘ + modTensorπ A N₂ P₂) ≫ + modTensorLegM A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) = + ((((β_ (N₁.X ⊗ P₁.X) A).hom ≫ (α_ A N₁.X P₁.X).inv ≫ + (actLeft A N₁.X ▷ P₁.X)) ≫ modTensorπ A N₁ P₁) ⊗ₘ + modTensorπ A N₂ P₂) := by + have hmw : ∀ {X₁ X₂ Y₁ Y₂ Z₁ : D} (a : X₁ ⟶ Y₁) + (b : X₂ ⟶ Y₂) (f : Y₁ ⟶ Z₁), + (a ⊗ₘ b) ≫ (f ▷ Y₂) = (a ≫ f) ⊗ₘ b := by + intros + rw [← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.comp_id] + rw [modTensorLegM, + show actRight A (modTensorMod A N₁ P₁).X = + (β_ (modTensor A N₁ P₁) A).hom ≫ + modTensorAct A N₁ P₁ from rfl] + change ((modTensorπ A N₁ P₁ ▷ A) ⊗ₘ modTensorπ A N₂ P₂) ≫ + (((β_ (modTensor A N₁ P₁) A).hom ≫ + modTensorAct A N₁ P₁) ▷ modTensor A N₂ P₂) = _ + rw [hmw, hslot] + simp only [Category.assoc] + have hcov' := congrArg (fun t => t ≫ + modTensorπ A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂)) hcov + repeat' erw [Category.assoc] at hcov' + conv_rhs => erw [hcov', midArrange] + conv_rhs => simp only [Category.assoc] + refine congrArg (CategoryStruct.comp + (tensorμ (N₁.X ⊗ A) N₂.X P₁.X P₂.X)) ?_ + rw [actRight] + have hc := legM_core A (actLeft A N₁.X) + (modTensorπ A N₁ P₁) (modTensorπ A N₂ P₂) + (modTensorπ A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂)) + simp only [Category.assoc] at hc + exact hc + +/-- The right slide of the second factors becomes the outer right +slide of the target. -/ +theorem interchange_legN + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (N₁ : Mod D A) (N₂ : Mod D A) + (P₁ : Mod D A) (P₂ : Mod D A) : + (modTensorLegN A N₁ N₂ ▷ (P₁.X ⊗ P₂.X)) ≫ + rawInterchangeπ A N₁ N₂ P₁ P₂ = + midArrange A N₁ N₂ P₁ P₂ ≫ + ((modTensorπ A N₁ P₁ ▷ A) ⊗ₘ modTensorπ A N₂ P₂) ≫ + modTensorLegN A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) ≫ + modTensorπ A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) := by + have hml : ∀ {X₁ X₂ Y₂ Z₁ Z₂ : D} (b : X₂ ⟶ Y₂) + (a : X₁ ⟶ Z₁) (c : Y₂ ⟶ Z₂), + (X₁ ◁ b) ≫ (a ⊗ₘ c) = a ⊗ₘ (b ≫ c) := by + intros + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.id_comp] + have hmr : ∀ {X₁ X₂ Z₁ Y₂ Z₂ : D} (a : X₁ ⟶ Z₁) + (b : X₂ ⟶ Y₂) (f : Y₂ ⟶ Z₂), + (a ⊗ₘ b) ≫ (Z₁ ◁ f) = a ⊗ₘ (b ≫ f) := by + intros + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.comp_id] + have h1 := tensorμ_natural (𝟙 N₁.X) (actLeft A N₂.X) + (𝟙 P₁.X) (𝟙 P₂.X) + simp only [MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_id, + MonoidalCategory.id_whiskerRight] at h1 + conv_lhs => rw [modTensorLegN, rawInterchangeπ, + rawInterchange, comp_whiskerRight, Category.assoc, + reassoc_of% h1] + conv_lhs => erw [reassoc_of% hml (actLeft A N₂.X ▷ P₂.X) + (modTensorπ A N₁ P₁) (modTensorπ A N₂ P₂)] + have hassoc := associator_naturality (modTensorπ A N₁ P₁) + (𝟙 A) (modTensorπ A N₂ P₂) + have hcov : ((modTensorπ A N₁ P₁ ▷ A) ⊗ₘ + modTensorπ A N₂ P₂) ≫ + modTensorLegN A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) = + (α_ (N₁.X ⊗ P₁.X) A (N₂.X ⊗ P₂.X)).hom ≫ + ((N₁.X ⊗ P₁.X) ◁ (α_ A N₂.X P₂.X).inv) ≫ + (modTensorπ A N₁ P₁ ⊗ₘ + ((actLeft A N₂.X ▷ P₂.X) ≫ modTensorπ A N₂ P₂)) := by + rw [modTensorLegN, + show actLeft A (modTensorMod A N₂ P₂).X = + modTensorAct A N₂ P₂ from rfl] + change ((modTensorπ A N₁ P₁ ▷ A) ⊗ₘ modTensorπ A N₂ P₂) ≫ + ((α_ (modTensor A N₁ P₁) A (modTensor A N₂ P₂)).hom ≫ + (modTensor A N₁ P₁ ◁ modTensorAct A N₂ P₂)) = _ + rw [← MonoidalCategory.tensorHom_id] + rw [reassoc_of% hassoc, hmr, + MonoidalCategory.id_tensorHom, + whiskerLeft_modTensorπ_act] + rw [show ((α_ A N₂.X P₂.X).inv ≫ + (actLeft A N₂.X ▷ P₂.X)) ≫ modTensorπ A N₂ P₂ = + (α_ A N₂.X P₂.X).inv ≫ + ((actLeft A N₂.X ▷ P₂.X) ≫ modTensorπ A N₂ P₂) from + Category.assoc _ _ _] + rw [← hml (α_ A N₂.X P₂.X).inv (modTensorπ A N₁ P₁) + ((actLeft A N₂.X ▷ P₂.X) ≫ modTensorπ A N₂ P₂)] + have hcov' : ((modTensorπ A N₁ P₁ ▷ A) ⊗ₘ + modTensorπ A N₂ P₂) ≫ + modTensorLegN A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) ≫ + modTensorπ A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) = + (α_ (N₁.X ⊗ P₁.X) A (N₂.X ⊗ P₂.X)).hom ≫ + ((N₁.X ⊗ P₁.X) ◁ (α_ A N₂.X P₂.X).inv) ≫ + (modTensorπ A N₁ P₁ ⊗ₘ + ((actLeft A N₂.X ▷ P₂.X) ≫ modTensorπ A N₂ P₂)) ≫ + modTensorπ A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) := by + erw [← Category.assoc, hcov] + exact (Category.assoc _ _ _).trans + (congrArg (CategoryStruct.comp _) (Category.assoc _ _ _)) + conv_rhs => erw [hcov', midArrange] + conv_rhs => rw [Category.assoc] + have hc := legN_core A (actLeft A N₂.X) + (modTensorπ A N₁ P₁) (modTensorπ A N₂ P₂) + (modTensorπ A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂)) + exact hc + +/-- The scalar-carrying rearrangement from the second block: the +interchange at the scalar-extended second block, the scalar +reassociating to the block boundary. -/ +noncomputable def midArrangeP + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (N₁ : Mod D A) (N₂ : Mod D A) (P₁ : Mod D A) (P₂ : Mod D A) : + (N₁.X ⊗ N₂.X) ⊗ ((P₁.X ⊗ A) ⊗ P₂.X) ⟶ + ((N₁.X ⊗ P₁.X) ⊗ A) ⊗ (N₂.X ⊗ P₂.X) := + tensorμ N₁.X N₂.X (P₁.X ⊗ A) P₂.X ≫ + ((α_ N₁.X P₁.X A).inv ▷ (N₂.X ⊗ P₂.X)) + +/-- The coherence core of the second-block left leg +identification: the module condition on the first pair transports +the scalar action across the pair. -/ +private theorem legMP_core + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + {V₁ W₁ U Q₁ Q₂ Z : D} + (actN : A ⊗ V₁ ⟶ V₁) (actW : A ⊗ W₁ ⟶ W₁) + (q₁ : V₁ ⊗ W₁ ⟶ Q₁) (q₂ : U ⟶ Q₂) (out : Q₁ ⊗ Q₂ ⟶ Z) + (hcond : (((β_ V₁ A).hom ≫ actN) ▷ W₁) ≫ q₁ = + (α_ V₁ A W₁).hom ≫ (V₁ ◁ actW) ≫ q₁) : + ((V₁ ◁ ((β_ W₁ A).hom ≫ actW)) ▷ U) ≫ + (q₁ ⊗ₘ q₂) ≫ out = + ((α_ V₁ W₁ A).inv ▷ U) ≫ + ((((β_ (V₁ ⊗ W₁) A).hom ≫ (α_ A V₁ W₁).inv ≫ + (actN ▷ W₁)) ≫ q₁) ⊗ₘ q₂) ≫ out := by + have hq : ∀ {Y : D} (x : Y ⟶ V₁ ⊗ W₁), + (((x ≫ q₁) ⊗ₘ q₂) ≫ out) = + (x ▷ U) ≫ (q₁ ⊗ₘ q₂) ≫ out := by + intro Y x + rw [MonoidalCategory.tensorHom_def, + MonoidalCategory.tensorHom_def, comp_whiskerRight] + simp only [Category.assoc] + rw [BraidedCategory.braiding_tensor_left_hom V₁ W₁ A] + simp only [Category.assoc, Iso.hom_inv_id_assoc] + rw [← comp_whiskerRight_assoc (β_ V₁ A).hom actN, hcond, + Iso.inv_hom_id_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc V₁ + (β_ W₁ A).hom actW] + rw [show (α_ V₁ W₁ A).hom ≫ + (V₁ ◁ ((β_ W₁ A).hom ≫ actW)) ≫ q₁ = + ((α_ V₁ W₁ A).hom ≫ + (V₁ ◁ ((β_ W₁ A).hom ≫ actW))) ≫ q₁ from + (Category.assoc _ _ _).symm] + rw [hq, comp_whiskerRight] + simp only [Category.assoc] + rw [← comp_whiskerRight_assoc (α_ V₁ W₁ A).inv + (α_ V₁ W₁ A).hom, Iso.inv_hom_id, + MonoidalCategory.id_whiskerRight, Category.id_comp] + +/-- The second-block left slide becomes the outer left slide of +the target. -/ +theorem interchange_legMP + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (N₁ : Mod D A) (N₂ : Mod D A) + (P₁ : Mod D A) (P₂ : Mod D A) : + ((N₁.X ⊗ N₂.X) ◁ modTensorLegM A P₁ P₂) ≫ + rawInterchangeπ A N₁ N₂ P₁ P₂ = + midArrangeP A N₁ N₂ P₁ P₂ ≫ + ((modTensorπ A N₁ P₁ ▷ A) ⊗ₘ modTensorπ A N₂ P₂) ≫ + modTensorLegM A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) ≫ + modTensorπ A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) := by + have h1 := tensorμ_natural (𝟙 N₁.X) (𝟙 N₂.X) + (actRight A P₁.X) (𝟙 P₂.X) + simp only [MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_id, + MonoidalCategory.id_whiskerRight] at h1 + conv_lhs => rw [modTensorLegM, rawInterchangeπ, + rawInterchange, reassoc_of% h1] + have hslot : (modTensorπ A N₁ P₁ ▷ A) ≫ + (β_ (modTensor A N₁ P₁) A).hom ≫ modTensorAct A N₁ P₁ = + (β_ (N₁.X ⊗ P₁.X) A).hom ≫ (α_ A N₁.X P₁.X).inv ≫ + (actLeft A N₁.X ▷ P₁.X) ≫ modTensorπ A N₁ P₁ := by + rw [BraidedCategory.braiding_naturality_left_assoc, + whiskerLeft_modTensorπ_act] + simp only [Category.assoc] + have hcov : ((modTensorπ A N₁ P₁ ▷ A) ⊗ₘ + modTensorπ A N₂ P₂) ≫ + modTensorLegM A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) = + ((((β_ (N₁.X ⊗ P₁.X) A).hom ≫ (α_ A N₁.X P₁.X).inv ≫ + (actLeft A N₁.X ▷ P₁.X)) ≫ modTensorπ A N₁ P₁) ⊗ₘ + modTensorπ A N₂ P₂) := by + have hmw : ∀ {X₁ X₂ Y₁ Y₂ Z₁ : D} (a : X₁ ⟶ Y₁) + (b : X₂ ⟶ Y₂) (f : Y₁ ⟶ Z₁), + (a ⊗ₘ b) ≫ (f ▷ Y₂) = (a ≫ f) ⊗ₘ b := by + intros + rw [← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.comp_id] + rw [modTensorLegM, + show actRight A (modTensorMod A N₁ P₁).X = + (β_ (modTensor A N₁ P₁) A).hom ≫ + modTensorAct A N₁ P₁ from rfl] + change ((modTensorπ A N₁ P₁ ▷ A) ⊗ₘ modTensorπ A N₂ P₂) ≫ + (((β_ (modTensor A N₁ P₁) A).hom ≫ + modTensorAct A N₁ P₁) ▷ modTensor A N₂ P₂) = _ + rw [hmw, hslot] + simp only [Category.assoc] + have hcov' := congrArg (fun t => t ≫ + modTensorπ A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂)) hcov + repeat' erw [Category.assoc] at hcov' + conv_rhs => erw [hcov', midArrangeP] + conv_rhs => simp only [Category.assoc] + refine congrArg (CategoryStruct.comp + (tensorμ N₁.X N₂.X (P₁.X ⊗ A) P₂.X)) ?_ + rw [actRight] + have hcond : (((β_ N₁.X A).hom ≫ actLeft A N₁.X) ▷ P₁.X) ≫ + modTensorπ A N₁ P₁ = + (α_ N₁.X A P₁.X).hom ≫ (N₁.X ◁ actLeft A P₁.X) ≫ + modTensorπ A N₁ P₁ := by + have hc := modTensor_condition A N₁ P₁ + rw [modTensorLegM, modTensorLegN, actRight] at hc + simpa only [Category.assoc] using hc + have hb := legMP_core A (actLeft A N₁.X) (actLeft A P₁.X) + (modTensorπ A N₁ P₁) (modTensorπ A N₂ P₂) + (modTensorπ A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂)) hcond + simp only [Category.assoc] at hb + exact hb + +/-- The coherence core of the second-block right leg +identification: the module condition on the second pair +transports the scalar action across the pair. -/ +private theorem legNP_core + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + {V₁ V₂ W₁ W₂ Q₁ Q₂ Z : D} + (actN : A ⊗ V₂ ⟶ V₂) (actW : A ⊗ W₂ ⟶ W₂) + (q₁ : V₁ ⊗ W₁ ⟶ Q₁) (q₂ : V₂ ⊗ W₂ ⟶ Q₂) + (out : Q₁ ⊗ Q₂ ⟶ Z) + (hcond : (((β_ V₂ A).hom ≫ actN) ▷ W₂) ≫ q₂ = + (α_ V₂ A W₂).hom ≫ (V₂ ◁ actW) ≫ q₂) : + ((V₁ ⊗ V₂) ◁ (α_ W₁ A W₂).hom) ≫ + tensorμ V₁ V₂ W₁ (A ⊗ W₂) ≫ + (q₁ ⊗ₘ ((V₂ ◁ actW) ≫ q₂)) ≫ out = + tensorμ V₁ V₂ (W₁ ⊗ A) W₂ ≫ + ((α_ V₁ W₁ A).inv ▷ (V₂ ⊗ W₂)) ≫ + (α_ (V₁ ⊗ W₁) A (V₂ ⊗ W₂)).hom ≫ + ((V₁ ⊗ W₁) ◁ (α_ A V₂ W₂).inv) ≫ + (q₁ ⊗ₘ ((actN ▷ W₂) ≫ q₂)) ≫ out := by + have hml : ∀ {X₁ X₂ Y₂ Z₁ Z₂ : D} (b : X₂ ⟶ Y₂) + (a : X₁ ⟶ Z₁) (c : Y₂ ⟶ Z₂), + (X₁ ◁ b) ≫ (a ⊗ₘ c) = a ⊗ₘ (b ≫ c) := by + intros + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.id_comp] + have hbridge : (V₂ ◁ actW) ≫ q₂ = + ((α_ V₂ A W₂).inv ≫ ((β_ V₂ A).hom ▷ W₂)) ≫ + ((actN ▷ W₂) ≫ q₂) := by + calc (V₂ ◁ actW) ≫ q₂ + = (α_ V₂ A W₂).inv ≫ (α_ V₂ A W₂).hom ≫ + (V₂ ◁ actW) ≫ q₂ := by + rw [Iso.inv_hom_id_assoc] + _ = (α_ V₂ A W₂).inv ≫ + (((β_ V₂ A).hom ≫ actN) ▷ W₂) ≫ q₂ := by + rw [hcond] + _ = ((α_ V₂ A W₂).inv ≫ ((β_ V₂ A).hom ▷ W₂)) ≫ + ((actN ▷ W₂) ≫ q₂) := by + rw [comp_whiskerRight] + simp only [Category.assoc] + rw [hbridge, ← hml ((α_ V₂ A W₂).inv ≫ + ((β_ V₂ A).hom ▷ W₂)) q₁ ((actN ▷ W₂) ≫ q₂)] + suffices h : ((V₁ ⊗ V₂) ◁ (α_ W₁ A W₂).hom) ≫ + tensorμ V₁ V₂ W₁ (A ⊗ W₂) ≫ + ((V₁ ⊗ W₁) ◁ ((α_ V₂ A W₂).inv ≫ + ((β_ V₂ A).hom ▷ W₂))) = + tensorμ V₁ V₂ (W₁ ⊗ A) W₂ ≫ + ((α_ V₁ W₁ A).inv ▷ (V₂ ⊗ W₂)) ≫ + (α_ (V₁ ⊗ W₁) A (V₂ ⊗ W₂)).hom ≫ + ((V₁ ⊗ W₁) ◁ (α_ A V₂ W₂).inv) by + simp only [Category.assoc] + conv_lhs => rw [reassoc_of% h] + simp only [tensorμ] + rw [BraidedCategory.braiding_tensor_right_hom V₂ W₁ A] + monoidal + +/-- The second-block right slide becomes the outer right slide of +the target. -/ +theorem interchange_legNP + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (N₁ : Mod D A) (N₂ : Mod D A) + (P₁ : Mod D A) (P₂ : Mod D A) : + ((N₁.X ⊗ N₂.X) ◁ modTensorLegN A P₁ P₂) ≫ + rawInterchangeπ A N₁ N₂ P₁ P₂ = + midArrangeP A N₁ N₂ P₁ P₂ ≫ + ((modTensorπ A N₁ P₁ ▷ A) ⊗ₘ modTensorπ A N₂ P₂) ≫ + modTensorLegN A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) ≫ + modTensorπ A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) := by + have hml : ∀ {X₁ X₂ Y₂ Z₁ Z₂ : D} (b : X₂ ⟶ Y₂) + (a : X₁ ⟶ Z₁) (c : Y₂ ⟶ Z₂), + (X₁ ◁ b) ≫ (a ⊗ₘ c) = a ⊗ₘ (b ≫ c) := by + intros + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.id_comp] + have hmr : ∀ {X₁ X₂ Z₁ Y₂ Z₂ : D} (a : X₁ ⟶ Z₁) + (b : X₂ ⟶ Y₂) (f : Y₂ ⟶ Z₂), + (a ⊗ₘ b) ≫ (Z₁ ◁ f) = a ⊗ₘ (b ≫ f) := by + intros + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.comp_id] + have h1 := tensorμ_natural (𝟙 N₁.X) (𝟙 N₂.X) (𝟙 P₁.X) + (actLeft A P₂.X) + simp only [MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_id, + MonoidalCategory.id_whiskerRight] at h1 + conv_lhs => rw [modTensorLegN, rawInterchangeπ, + rawInterchange, MonoidalCategory.whiskerLeft_comp, + Category.assoc, reassoc_of% h1] + conv_lhs => erw [reassoc_of% hml (N₂.X ◁ actLeft A P₂.X) + (modTensorπ A N₁ P₁) (modTensorπ A N₂ P₂)] + have hassoc := associator_naturality (modTensorπ A N₁ P₁) + (𝟙 A) (modTensorπ A N₂ P₂) + have hcov : ((modTensorπ A N₁ P₁ ▷ A) ⊗ₘ + modTensorπ A N₂ P₂) ≫ + modTensorLegN A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) = + (α_ (N₁.X ⊗ P₁.X) A (N₂.X ⊗ P₂.X)).hom ≫ + ((N₁.X ⊗ P₁.X) ◁ (α_ A N₂.X P₂.X).inv) ≫ + (modTensorπ A N₁ P₁ ⊗ₘ + ((actLeft A N₂.X ▷ P₂.X) ≫ modTensorπ A N₂ P₂)) := by + rw [modTensorLegN, + show actLeft A (modTensorMod A N₂ P₂).X = + modTensorAct A N₂ P₂ from rfl] + change ((modTensorπ A N₁ P₁ ▷ A) ⊗ₘ modTensorπ A N₂ P₂) ≫ + ((α_ (modTensor A N₁ P₁) A (modTensor A N₂ P₂)).hom ≫ + (modTensor A N₁ P₁ ◁ modTensorAct A N₂ P₂)) = _ + rw [← MonoidalCategory.tensorHom_id] + rw [reassoc_of% hassoc, hmr, + MonoidalCategory.id_tensorHom, + whiskerLeft_modTensorπ_act] + rw [show ((α_ A N₂.X P₂.X).inv ≫ + (actLeft A N₂.X ▷ P₂.X)) ≫ modTensorπ A N₂ P₂ = + (α_ A N₂.X P₂.X).inv ≫ + ((actLeft A N₂.X ▷ P₂.X) ≫ modTensorπ A N₂ P₂) from + Category.assoc _ _ _] + rw [← hml (α_ A N₂.X P₂.X).inv (modTensorπ A N₁ P₁) + ((actLeft A N₂.X ▷ P₂.X) ≫ modTensorπ A N₂ P₂)] + have hcov' : ((modTensorπ A N₁ P₁ ▷ A) ⊗ₘ + modTensorπ A N₂ P₂) ≫ + modTensorLegN A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) ≫ + modTensorπ A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) = + (α_ (N₁.X ⊗ P₁.X) A (N₂.X ⊗ P₂.X)).hom ≫ + ((N₁.X ⊗ P₁.X) ◁ (α_ A N₂.X P₂.X).inv) ≫ + (modTensorπ A N₁ P₁ ⊗ₘ + ((actLeft A N₂.X ▷ P₂.X) ≫ modTensorπ A N₂ P₂)) ≫ + modTensorπ A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) := by + erw [← Category.assoc, hcov] + exact (Category.assoc _ _ _).trans + (congrArg (CategoryStruct.comp _) (Category.assoc _ _ _)) + conv_rhs => rw [hcov', midArrangeP] + conv_rhs => rw [Category.assoc] + have hcond : (((β_ N₂.X A).hom ≫ actLeft A N₂.X) ▷ P₂.X) ≫ + modTensorπ A N₂ P₂ = + (α_ N₂.X A P₂.X).hom ≫ (N₂.X ◁ actLeft A P₂.X) ≫ + modTensorπ A N₂ P₂ := by + have hc := modTensor_condition A N₂ P₂ + rw [modTensorLegM, modTensorLegN, actRight] at hc + simpa only [Category.assoc] using hc + have hb := legNP_core A (actLeft A N₂.X) (actLeft A P₂.X) + (modTensorπ A N₁ P₁) (modTensorπ A N₂ P₂) + (modTensorπ A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂)) hcond + exact hb + +/-- The two first-block legs agree after the raw interchange +projection. -/ +theorem rawInterchangeπ_condN + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (N₁ : Mod D A) (N₂ : Mod D A) + (P₁ : Mod D A) (P₂ : Mod D A) : + (modTensorLegM A N₁ N₂ ▷ (P₁.X ⊗ P₂.X)) ≫ + rawInterchangeπ A N₁ N₂ P₁ P₂ = + (modTensorLegN A N₁ N₂ ▷ (P₁.X ⊗ P₂.X)) ≫ + rawInterchangeπ A N₁ N₂ P₁ P₂ := by + rw [interchange_legM, interchange_legN] + exact congrArg (CategoryStruct.comp _) + (congrArg (CategoryStruct.comp _) (modTensor_condition A + (modTensorMod A N₁ P₁) (modTensorMod A N₂ P₂))) + +/-- The two second-block legs agree after the raw interchange +projection. -/ +theorem rawInterchangeπ_condP + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (N₁ : Mod D A) (N₂ : Mod D A) + (P₁ : Mod D A) (P₂ : Mod D A) : + ((N₁.X ⊗ N₂.X) ◁ modTensorLegM A P₁ P₂) ≫ + rawInterchangeπ A N₁ N₂ P₁ P₂ = + ((N₁.X ⊗ N₂.X) ◁ modTensorLegN A P₁ P₂) ≫ + rawInterchangeπ A N₁ N₂ P₁ P₂ := by + rw [interchange_legMP, interchange_legNP] + exact congrArg (CategoryStruct.comp _) + (congrArg (CategoryStruct.comp _) (modTensor_condition A + (modTensorMod A N₁ P₁) (modTensorMod A N₂ P₂))) + +/-- First-stage descent of the interchange, through the +coequalizer of the first block. -/ +noncomputable def interchangeStage1 + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (N₁ : Mod D A) (N₂ : Mod D A) + (P₁ : Mod D A) (P₂ : Mod D A) : + modTensor A N₁ N₂ ⊗ (P₁.X ⊗ P₂.X) ⟶ + modTensor A (modTensorMod A N₁ P₁) (modTensorMod A N₂ P₂) := + modTensorWhiskerRDesc A N₁ N₂ (P₁.X ⊗ P₂.X) + (rawInterchangeπ A N₁ N₂ P₁ P₂) + (rawInterchangeπ_condN A N₁ N₂ P₁ P₂) + +/-- Defining equation of the first-stage descent. -/ +@[reassoc] +theorem whiskerRight_π_interchangeStage1 + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (N₁ : Mod D A) (N₂ : Mod D A) + (P₁ : Mod D A) (P₂ : Mod D A) : + (modTensorπ A N₁ N₂ ▷ (P₁.X ⊗ P₂.X)) ≫ + interchangeStage1 A N₁ N₂ P₁ P₂ = + rawInterchangeπ A N₁ N₂ P₁ P₂ := + whiskerRight_modTensorπ_whiskerRDesc A N₁ N₂ _ _ _ + +/-- The second-block legs agree after the first-stage descent. -/ +theorem interchangeStage1_condP + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (N₁ : Mod D A) (N₂ : Mod D A) + (P₁ : Mod D A) (P₂ : Mod D A) : + (modTensor A N₁ N₂ ◁ modTensorLegM A P₁ P₂) ≫ + interchangeStage1 A N₁ N₂ P₁ P₂ = + (modTensor A N₁ N₂ ◁ modTensorLegN A P₁ P₂) ≫ + interchangeStage1 A N₁ N₂ P₁ P₂ := by + apply modTensor_whiskerR_hom_ext A N₁ N₂ + ((P₁.X ⊗ A) ⊗ P₂.X) + rw [← whisker_exchange_assoc, ← whisker_exchange_assoc, + whiskerRight_π_interchangeStage1] + exact rawInterchangeπ_condP A N₁ N₂ P₁ P₂ + +/-- The interchange of module tensor products: the tensor product +of two module tensor products maps to the module tensor product +of the crossed pairs. -/ +noncomputable def interchange + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (N₁ : Mod D A) (N₂ : Mod D A) + (P₁ : Mod D A) (P₂ : Mod D A) : + modTensor A N₁ N₂ ⊗ modTensor A P₁ P₂ ⟶ + modTensor A (modTensorMod A N₁ P₁) (modTensorMod A N₂ P₂) := + modTensorWhiskerDesc A P₁ P₂ (modTensor A N₁ N₂) + (interchangeStage1 A N₁ N₂ P₁ P₂) + (interchangeStage1_condP A N₁ N₂ P₁ P₂) + +/-- Defining equation of the interchange. -/ +@[reassoc (attr := simp)] +theorem tensorHom_π_interchange + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (N₁ : Mod D A) (N₂ : Mod D A) + (P₁ : Mod D A) (P₂ : Mod D A) : + (modTensorπ A N₁ N₂ ⊗ₘ modTensorπ A P₁ P₂) ≫ + interchange A N₁ N₂ P₁ P₂ = + rawInterchangeπ A N₁ N₂ P₁ P₂ := by + rw [interchange, MonoidalCategory.tensorHom_def, + Category.assoc, whiskerLeft_modTensorπ_whiskerDesc, + whiskerRight_π_interchangeStage1] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairPerm.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairPerm.lean new file mode 100644 index 0000000000..a10002d4ef --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairPerm.lean @@ -0,0 +1,1074 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairing + +/-! +# Permutations across the power pairing + +The nested power pairing consumes the `M'`-power from the top and +the `M`-power from the bottom, so it pairs slot `j` of the +`M'`-power against slot `n - 1 - j` of the `M`-power. Moving a +permutation of the `M`-slots across the pairing therefore turns it +into the *order-reversing adjoint* permutation of the `M'`-slots. + +* `adjPerm`: the adjoint `σ ↦ rev ∘ σ⁻¹ ∘ rev`. The convention is + chosen so that the exchange law holds verbatim; it is an + anti-homomorphism (`adjPerm_mul`) and an involution + (`adjPerm_adjPerm`), and on transpositions it reverses the two + slots (`adjPerm_swap`). +* `swapTop_powPeel`, `powPeel_permMor_swap`, `powPeel_permMor_low`: + the head peel intertwines an adjacent braiding away from the + bottom slot with the braiding one slot down, and resolves the + bottom braiding into the braiding of the two exposed factors. +* `pairStep_dbl_braid`: the doubled generic step absorbs the + braiding of its two consumed `M'`-factors as the braiding of its + two consumed `M`-factors — the boundary of the exchange law. +* `rawPair_perm`: **the exchange law** — a permutation of the + `M`-power slots crosses the raw pairing as the adjoint + permutation of the `M'`-power slots. +* `pairPow_perm`, `symPowIdem_pairPow`: the exchange law descended + to the module powers, and its average over the group — the + symmetriser on either side of the descended pairing agree, the + self-adjointness that transfers the power-level duality to the + symmetric powers. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +/-! ## The order-reversing adjoint of a permutation -/ + +section AdjPerm + +variable {n : ℕ} + +/-- **The order-reversing adjoint** of a permutation: conjugate +the inverse by the order reversal of the slots. The inverse makes +it an anti-homomorphism, which is the direction in which +permutations cross the power pairing. -/ +def adjPerm (σ : Equiv.Perm (Fin n)) : Equiv.Perm (Fin n) := + Fin.revPerm * σ⁻¹ * Fin.revPerm + +@[simp] +theorem adjPerm_apply (σ : Equiv.Perm (Fin n)) (i : Fin n) : + adjPerm σ i = (σ⁻¹ i.rev).rev := by + simp [adjPerm] + +/-- The adjoint of the identity is the identity. -/ +@[simp] +theorem adjPerm_one : adjPerm (1 : Equiv.Perm (Fin n)) = 1 := by + ext i + simp + +/-- **The adjoint is an anti-homomorphism.** -/ +theorem adjPerm_mul (σ τ : Equiv.Perm (Fin n)) : + adjPerm (σ * τ) = adjPerm τ * adjPerm σ := by + ext i + simp + +/-- **The adjoint is an involution.** -/ +@[simp] +theorem adjPerm_adjPerm (σ : Equiv.Perm (Fin n)) : + adjPerm (adjPerm σ) = σ := by + ext i + simp [adjPerm] + +/-- The adjoint of a transposition reverses its two slots. -/ +theorem adjPerm_swap (u v : Fin n) : + adjPerm (Equiv.swap u v) = Equiv.swap u.rev v.rev := by + ext i + simp only [adjPerm_apply, Equiv.swap_inv] + rcases eq_or_ne i u.rev with rfl | hu + · rw [Fin.rev_rev, Equiv.swap_apply_left, Equiv.swap_apply_left] + rcases eq_or_ne i v.rev with rfl | hv + · rw [Fin.rev_rev, Equiv.swap_apply_right, Equiv.swap_apply_right] + have hu' : i.rev ≠ u := fun h => hu (by rw [← h, Fin.rev_rev]) + have hv' : i.rev ≠ v := fun h => hv (by rw [← h, Fin.rev_rev]) + rw [Equiv.swap_apply_of_ne_of_ne hu' hv', Fin.rev_rev, + Equiv.swap_apply_of_ne_of_ne hu hv] + +/-- The adjoint of an adjacent transposition is the adjacent +transposition at the reversed position. -/ +theorem adjPerm_swap_castSucc_succ {m : ℕ} (i : Fin (m + 1)) : + adjPerm (Equiv.swap i.castSucc i.succ) = + Equiv.swap i.rev.castSucc i.rev.succ := by + rw [adjPerm_swap, Fin.rev_castSucc, Fin.rev_succ, + Equiv.swap_comm] + +end AdjPerm + +variable {D : Type u} + +/-! ## Adjacent braidings across the head peel + +The permutation action of `Envelope/SymPerm.lean` is built from the +top of the power, while the pairing peels the bottom. The bridge +is the head peel: an adjacent braiding that avoids the bottom slot +passes the peel, dropping one slot; the braiding of the bottom two +slots resolves, under the double peel, into the braiding of the two +exposed factors. +-/ + +section PermPeel + +/-- The top braiding word over an arbitrary base. -/ +private noncomputable def braidTopM + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) + (P : D) : + (P ⊗ X) ⊗ X ⟶ (P ⊗ X) ⊗ X := + (α_ P X X).hom ≫ (P ◁ (β_ X X).hom) ≫ (α_ P X X).inv + +/-- Naturality of the top braiding word in its base. -/ +private theorem braidTopM_natural + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) + {P Q : D} (f : P ⟶ Q) : + braidTopM X P ≫ ((f ▷ X) ▷ X) = + ((f ▷ X) ▷ X) ≫ braidTopM X Q := by + rw [braidTopM, braidTopM, associator_naturality_left_assoc, + ← whisker_exchange_assoc, associator_inv_naturality_left] + simp only [Category.assoc] + +/-- The top braiding word migrates below an exposed head factor. -/ +private theorem braidTop_shift + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) + (P : D) : + braidTopM X (X ⊗ P) ≫ + ((α_ X P X).hom ▷ X) ≫ (α_ X (P ⊗ X) X).hom = + ((α_ X P X).hom ▷ X) ≫ (α_ X (P ⊗ X) X).hom ≫ + (X ◁ braidTopM X P) := by + rw [braidTopM, braidTopM] + monoidal + +/-- The top braiding passes a peeled step, at general objects. -/ +private theorem braidTop_peel_gen + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) + {W P : D} (p : W ⟶ X ⊗ P) : + braidTopM X W ≫ + (((p ▷ X) ≫ (α_ X P X).hom) ▷ X) ≫ + (α_ X (P ⊗ X) X).hom = + ((((p ▷ X) ≫ (α_ X P X).hom) ▷ X) ≫ + (α_ X (P ⊗ X) X).hom) ≫ + (X ◁ braidTopM X P) := by + rw [MonoidalCategory.comp_whiskerRight] + simp only [Category.assoc] + rw [reassoc_of% (braidTopM_natural X p)] + exact congrArg (CategoryStruct.comp _) (braidTop_shift X P) + +/-- **The top braiding passes the head peel**, dropping to the top +braiding one arity down. -/ +theorem swapTop_powPeel + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) + (k : ℕ) : + swapTop X (k + 1) ≫ (powPeel X (k + 2)).hom = + (powPeel X (k + 2)).hom ≫ (X ◁ swapTop X k) := + braidTop_peel_gen X (P := tensorPow D X k) (powPeel X k).hom + +/-- An endomorphism intertwined with a lower one by a peel is +intertwined with its whisker by the peeled step; at general +objects. -/ +private theorem peel_step_gen [Category.{v} D] [MonoidalCategory D] (X : D) + {W P : D} (p : W ⟶ X ⊗ P) + (s : W ⟶ W) (t : P ⟶ P) (hst : s ≫ p = p ≫ (X ◁ t)) : + (s ▷ X) ≫ ((p ▷ X) ≫ (α_ X P X).hom) = + ((p ▷ X) ≫ (α_ X P X).hom) ≫ (X ◁ (t ▷ X)) := by + rw [← MonoidalCategory.comp_whiskerRight_assoc, hst, + MonoidalCategory.comp_whiskerRight, Category.assoc, + associator_naturality_middle] + simp only [Category.assoc] + +/-- **An adjacent braiding above the bottom slot passes the head +peel**, dropping one slot. -/ +theorem powPeel_permMor_swap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) : + ∀ (q a b : ℕ) (_ : a + 2 + b = q), + permMor X (q + 1) + (Equiv.swap ⟨a + 1, by omega⟩ ⟨a + 2, by omega⟩) ≫ + (powPeel X q).hom = + (powPeel X q).hom ≫ + (X ◁ permMor X q + (Equiv.swap ⟨a, by omega⟩ ⟨a + 1, by omega⟩)) + | q, a, 0, h => by + subst h + change permMor X (a + 1 + 2) topSwap ≫ + (powPeel X (a + 2)).hom = + (powPeel X (a + 2)).hom ≫ + (X ◁ permMor X (a + 2) topSwap) + rw [permMor_topSwap_eq, permMor_topSwap_eq] + exact swapTop_powPeel X a + | q, a, b + 1, h => by + subst h + change permMor X (a + 2 + b + 1 + 1) + (Equiv.swap ⟨a + 1, by omega⟩ ⟨a + 2, by omega⟩) ≫ + (powPeel X (a + 2 + b + 1)).hom = + (powPeel X (a + 2 + b + 1)).hom ≫ + (X ◁ permMor X (a + 2 + b + 1) + (Equiv.swap ⟨a, by omega⟩ ⟨a + 1, by omega⟩)) + have hswL : (Equiv.swap + (⟨a + 1, by omega⟩ : Fin (a + 2 + b + 1 + 1)) + ⟨a + 2, by omega⟩) = + extPerm (Equiv.swap + (⟨a + 1, by omega⟩ : Fin (a + 2 + b + 1)) + ⟨a + 2, by omega⟩) := by + rw [extPerm_swap] + rfl + have hswR : (Equiv.swap + (⟨a, by omega⟩ : Fin (a + 2 + b + 1)) + ⟨a + 1, by omega⟩) = + extPerm (Equiv.swap + (⟨a, by omega⟩ : Fin (a + 2 + b)) + ⟨a + 1, by omega⟩) := by + rw [extPerm_swap] + rfl + rw [hswL, hswR, permMor_extPerm, permMor_extPerm] + exact peel_step_gen X (powPeel X (a + 2 + b)).hom _ _ + (powPeel_permMor_swap X (a + 2 + b) a b rfl) + +/-- The bottom braiding word migrates below one more exposed head +factor, as the bottom braiding of the extended tail. -/ +private theorem braidLow_shift + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) + (P : D) : + ((α_ X X P).inv ▷ X) ≫ (((β_ X X).hom ▷ P) ▷ X) ≫ + ((α_ X X P).hom ▷ X) ≫ (α_ X (X ⊗ P) X).hom ≫ + (X ◁ (α_ X P X).hom) = + (α_ X (X ⊗ P) X).hom ≫ (X ◁ (α_ X P X).hom) ≫ + (α_ X X (P ⊗ X)).inv ≫ ((β_ X X).hom ▷ (P ⊗ X)) ≫ + (α_ X X (P ⊗ X)).hom := by + monoidal + +/-- An endomorphism intertwined with the bottom braiding by a +double peel is intertwined with the extended bottom braiding by +the doubled peel; at general objects. -/ +private theorem peel_low_gen + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) + {W W₀ P : D} (f : W ⟶ X ⊗ W₀) + (g : W₀ ⟶ X ⊗ P) (s : W ⟶ W) + (hs : s ≫ f ≫ (X ◁ g) = + f ≫ (X ◁ g) ≫ (α_ X X P).inv ≫ + ((β_ X X).hom ▷ P) ≫ (α_ X X P).hom) : + (s ▷ X) ≫ ((f ▷ X) ≫ (α_ X W₀ X).hom) ≫ + (X ◁ ((g ▷ X) ≫ (α_ X P X).hom)) = + ((f ▷ X) ≫ (α_ X W₀ X).hom) ≫ + (X ◁ ((g ▷ X) ≫ (α_ X P X).hom)) ≫ + (α_ X X (P ⊗ X)).inv ≫ + ((β_ X X).hom ▷ (P ⊗ X)) ≫ (α_ X X (P ⊗ X)).hom := by + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + conv_lhs => rw [← associator_naturality_middle_assoc] + conv_rhs => rw [← associator_naturality_middle_assoc] + conv_lhs => rw [← MonoidalCategory.comp_whiskerRight_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, Category.assoc] + rw [hs] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + refine congrArg (CategoryStruct.comp _) ?_ + refine congrArg (CategoryStruct.comp _) ?_ + exact braidLow_shift X P + +/-- **The bottom braiding resolves under the double peel** into +the braiding of the two exposed head factors. -/ +theorem powPeel_permMor_low + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) : + ∀ n : ℕ, + permMor X (n + 2) + (Equiv.swap ⟨0, by omega⟩ ⟨1, by omega⟩) ≫ + (powPeel X (n + 1)).hom ≫ (X ◁ (powPeel X n).hom) = + (powPeel X (n + 1)).hom ≫ (X ◁ (powPeel X n).hom) ≫ + (α_ X X (tensorPow D X n)).inv ≫ + ((β_ X X).hom ▷ tensorPow D X n) ≫ + (α_ X X (tensorPow D X n)).hom + | 0 => by + change permMor X (0 + 2) topSwap ≫ + (powPeel X 1).hom ≫ (X ◁ (powPeel X 0).hom) = + (powPeel X 1).hom ≫ (X ◁ (powPeel X 0).hom) ≫ + (α_ X X (𝟙_ D)).inv ≫ ((β_ X X).hom ▷ 𝟙_ D) ≫ + (α_ X X (𝟙_ D)).hom + rw [permMor_topSwap_eq] + change ((α_ (𝟙_ D) X X).hom ≫ (𝟙_ D ◁ (β_ X X).hom) ≫ + (α_ (𝟙_ D) X X).inv) ≫ + ((((λ_ X).hom ≫ (ρ_ X).inv) ▷ X) ≫ + (α_ X (𝟙_ D) X).hom) ≫ + (X ◁ ((λ_ X).hom ≫ (ρ_ X).inv)) = + ((((λ_ X).hom ≫ (ρ_ X).inv) ▷ X) ≫ + (α_ X (𝟙_ D) X).hom) ≫ + (X ◁ ((λ_ X).hom ≫ (ρ_ X).inv)) ≫ + (α_ X X (𝟙_ D)).inv ≫ ((β_ X X).hom ▷ 𝟙_ D) ≫ + (α_ X X (𝟙_ D)).hom + monoidal + | n + 1 => by + change permMor X (n + 2 + 1) + (Equiv.swap ⟨0, by omega⟩ ⟨1, by omega⟩) ≫ + (powPeel X (n + 1 + 1)).hom ≫ + (X ◁ (powPeel X (n + 1)).hom) = + (powPeel X (n + 1 + 1)).hom ≫ + (X ◁ (powPeel X (n + 1)).hom) ≫ + (α_ X X (tensorPow D X (n + 1))).inv ≫ + ((β_ X X).hom ▷ tensorPow D X (n + 1)) ≫ + (α_ X X (tensorPow D X (n + 1))).hom + have hsw : (Equiv.swap (⟨0, by omega⟩ : Fin (n + 2 + 1)) + ⟨1, by omega⟩) = + extPerm (Equiv.swap (⟨0, by omega⟩ : Fin (n + 2)) + ⟨1, by omega⟩) := by + rw [extPerm_swap] + rfl + rw [hsw, permMor_extPerm] + exact peel_low_gen X (powPeel X (n + 1)).hom + (powPeel X n).hom _ (powPeel_permMor_low X n) + +end PermPeel + +/-! ## The doubled step absorbs the boundary braiding + +The recursion of the power pairing consumes the top `M'`-factor +against the bottom `M`-factor; two consecutive steps consume the +top two `M'`-factors against the bottom two `M`-factors. The +boundary of the exchange law is that braiding the two consumed +`M'`-factors equals braiding the two consumed `M`-factors, across +the doubled step. Everything here is at general objects, over an +opaque pairing `u` and continuation `r`; commutativity of the +monoid enters exactly once, to exchange the two emitted scalars. +-/ + +section DblCore + +/-- The single pairing window over an opaque pairing: evaluate on +the head pair and braid the scalar out past the tail. -/ +private noncomputable def winU + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + (V' : D) (V : D) + (u : V' ⊗ V ⟶ A) (R : D) : + V' ⊗ (V ⊗ R) ⟶ R ⊗ A := + (α_ V' V R).inv ≫ (u ▷ R) ≫ (β_ A R).hom + +/-- The generic step over an opaque pairing, shaped exactly as +`pairStep` over `pairRaw`. -/ +private noncomputable def stepU + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (V' : D) (V : D) + (u : V' ⊗ V ⟶ A) {Q R : D} + (r : Q ⊗ R ⟶ A) : (Q ⊗ V') ⊗ (V ⊗ R) ⟶ A := + (α_ Q V' (V ⊗ R)).hom ≫ (Q ◁ winU A V' V u R) ≫ + (α_ Q R A).inv ≫ (r ▷ A) ≫ μ[A] + +/-- The doubled window: both consumed pairs fire, the two scalars +collected at the tail. -/ +private noncomputable def dblWin + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + (V' : D) (V : D) + (u : V' ⊗ V ⟶ A) (R : D) : + V' ⊗ (V' ⊗ (V ⊗ (V ⊗ R))) ⟶ R ⊗ (A ⊗ A) := + (V' ◁ winU A V' V u (V ⊗ R)) ≫ (α_ V' (V ⊗ R) A).inv ≫ + (winU A V' V u R ▷ A) ≫ (α_ R A A).hom + +/-- **The doubled step in window form**: two steps are the doubled +window on the consumed factors, the continuation, and the fold of +the two scalars. -/ +private theorem stepU_stepU + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (V' : D) (V : D) + (u : V' ⊗ V ⟶ A) {Q R : D} + (r : Q ⊗ R ⟶ A) : + stepU A V' V u (stepU A V' V u r) = + (α_ (Q ⊗ V') V' (V ⊗ (V ⊗ R))).hom ≫ + (α_ Q V' (V' ⊗ (V ⊗ (V ⊗ R)))).hom ≫ + (Q ◁ dblWin A V' V u R) ≫ + (α_ Q R (A ⊗ A)).inv ≫ (r ▷ (A ⊗ A)) ≫ + (A ◁ μ[A]) ≫ μ[A] := by + rw [stepU, stepU, dblWin] + simp only [winU, MonoidalCategory.comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [MonObj.mul_assoc] + monoidal + +/-- The pre-braiding of the two consumed `M'`-factors migrates +into the spine. -/ +private theorem braid_spine + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (V' : D) + (Q T : D) : + (((α_ Q V' V').hom ≫ (Q ◁ (β_ V' V').hom) ≫ + (α_ Q V' V').inv) ▷ T) ≫ + (α_ (Q ⊗ V') V' T).hom ≫ (α_ Q V' (V' ⊗ T)).hom = + (α_ (Q ⊗ V') V' T).hom ≫ (α_ Q V' (V' ⊗ T)).hom ≫ + (Q ◁ ((α_ V' V' T).inv ≫ ((β_ V' V').hom ▷ T) ≫ + (α_ V' V' T).hom)) := by + monoidal + +/-- A whiskering of the consumed tail migrates into the spine. -/ +private theorem whisk_spine [Category.{v} D] [MonoidalCategory D] (V' : D) + {Q T T' : D} (f : T ⟶ T') : + (((Q ⊗ V') ⊗ V') ◁ f) ≫ + (α_ (Q ⊗ V') V' T').hom ≫ (α_ Q V' (V' ⊗ T')).hom = + (α_ (Q ⊗ V') V' T).hom ≫ (α_ Q V' (V' ⊗ T)).hom ≫ + (Q ◁ (V' ◁ (V' ◁ f))) := by + rw [associator_naturality_right_assoc, + associator_naturality_right] + +/-- The scalar flip is absorbed by the commutative fold. -/ +private theorem flip_absorb + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [IsCommMonObj A] + {Q R : D} (r : Q ⊗ R ⟶ A) : + (Q ◁ (R ◁ (β_ A A).hom)) ≫ (α_ Q R (A ⊗ A)).inv ≫ + (r ▷ (A ⊗ A)) ≫ (A ◁ μ[A]) ≫ μ[A] = + (α_ Q R (A ⊗ A)).inv ≫ (r ▷ (A ⊗ A)) ≫ + (A ◁ μ[A]) ≫ μ[A] := by + rw [associator_inv_naturality_right_assoc, + whisker_exchange_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + IsCommMonObj.mul_comm] + +/-- **The doubled window in parallel form**: both pairs are routed +side by side, fire in parallel, and the scalars collect at the +tail. -/ +private theorem dblWin_par + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + (V' : D) (V : D) + (u : V' ⊗ V ⟶ A) (R : D) : + dblWin A V' V u R = + (V' ◁ (α_ V' V (V ⊗ R)).inv) ≫ + (α_ V' (V' ⊗ V) (V ⊗ R)).inv ≫ + ((β_ V' (V' ⊗ V)).hom ▷ (V ⊗ R)) ≫ + (α_ (V' ⊗ V) V' (V ⊗ R)).hom ≫ + ((V' ⊗ V) ◁ (α_ V' V R).inv) ≫ + (u ▷ ((V' ⊗ V) ⊗ R)) ≫ (A ◁ (u ▷ R)) ≫ + (A ◁ (β_ A R).hom) ≫ (β_ A (R ⊗ A)).hom ≫ + (α_ R A A).hom := by + have hb := braid_cross_pair (S := V') (T := V ⊗ R) A + (winU A V' V u R) + have hkey : (V' ◁ (β_ A (V ⊗ R)).hom) ≫ + (α_ V' (V ⊗ R) A).inv ≫ (winU A V' V u R ▷ A) = + (α_ V' A (V ⊗ R)).inv ≫ ((β_ V' A).hom ▷ (V ⊗ R)) ≫ + (α_ A V' (V ⊗ R)).hom ≫ (A ◁ winU A V' V u R) ≫ + (β_ A (R ⊗ A)).hom := by + rw [reassoc_of% hb] + simp only [Iso.inv_hom_id_assoc] + rw [← Category.assoc, ← Category.assoc, Category.assoc, + SymmetricCategory.symmetry, Category.comp_id] + simp only [Category.assoc] + rw [dblWin] + conv_lhs => rw [winU] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [reassoc_of% hkey] + rw [associator_inv_naturality_middle_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, + BraidedCategory.braiding_naturality_right, + MonoidalCategory.comp_whiskerRight, Category.assoc, + associator_naturality_left_assoc, + ← whisker_exchange_assoc] + conv_lhs => rw [winU] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [whisker_exchange_assoc, whisker_exchange_assoc] + +/-- The block braiding passes the parallel firing, becoming the +scalar braiding. -/ +private theorem fire_swap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + (V' : D) (V : D) + (u : V' ⊗ V ⟶ A) (R : D) : + ((α_ (V' ⊗ V) (V' ⊗ V) R).inv ≫ + ((β_ (V' ⊗ V) (V' ⊗ V)).hom ▷ R) ≫ + (α_ (V' ⊗ V) (V' ⊗ V) R).hom) ≫ + (u ▷ ((V' ⊗ V) ⊗ R)) ≫ (A ◁ (u ▷ R)) = + (u ▷ ((V' ⊗ V) ⊗ R)) ≫ (A ◁ (u ▷ R)) ≫ + ((α_ A A R).inv ≫ ((β_ A A).hom ▷ R) ≫ + (α_ A A R).hom) := by + rw [← MonoidalCategory.tensorHom_def_assoc, + ← MonoidalCategory.tensorHom_def] + rw [show (u ▷ R : (V' ⊗ V) ⊗ R ⟶ A ⊗ R) = u ⊗ₘ 𝟙 R from + (MonoidalCategory.tensorHom_id u R).symm] + simp only [Category.assoc] + rw [← MonoidalCategory.associator_naturality, + MonoidalCategory.associator_inv_naturality_assoc] + simp only [← Category.assoc] + refine congrArg (fun t => t ≫ (α_ A A R).hom) ?_ + simp only [Category.assoc] + refine congrArg (CategoryStruct.comp _) ?_ + rw [MonoidalCategory.tensorHom_id, + ← MonoidalCategory.comp_whiskerRight, + ← MonoidalCategory.comp_whiskerRight, + ← BraidedCategory.braiding_naturality] + +/-- The scalar braiding passes the collecting tail, becoming the +flip of the collected pair. -/ +private theorem tail_flip + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + (R : D) : + (α_ A A R).inv ≫ ((β_ A A).hom ▷ R) ≫ (α_ A A R).hom ≫ + (A ◁ (β_ A R).hom) ≫ (β_ A (R ⊗ A)).hom ≫ + (α_ R A A).hom = + (A ◁ (β_ A R).hom) ≫ (β_ A (R ⊗ A)).hom ≫ + (α_ R A A).hom ≫ (R ◁ (β_ A A).hom) := by + rw [BraidedCategory.braiding_tensor_right_hom A R A] + simp only [Category.assoc, Iso.inv_hom_id, Category.comp_id] + rw [BraidedCategory.yang_baxter_assoc] + simp only [Iso.inv_hom_id_assoc, + ← MonoidalCategory.whiskerLeft_comp, + SymmetricCategory.symmetry, + MonoidalCategory.whiskerLeft_id, Category.comp_id] + +/-- **The first pure routing law**: the braiding of the two +`M'`-factors before the parallel routing is the single interleave +crossing. -/ +private theorem route_fst + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (V' : D) + (V : D) + (R : D) : + ((α_ V' V' (V ⊗ (V ⊗ R))).inv ≫ + ((β_ V' V').hom ▷ (V ⊗ (V ⊗ R))) ≫ + (α_ V' V' (V ⊗ (V ⊗ R))).hom) ≫ + (V' ◁ (α_ V' V (V ⊗ R)).inv) ≫ + (α_ V' (V' ⊗ V) (V ⊗ R)).inv ≫ + ((β_ V' (V' ⊗ V)).hom ▷ (V ⊗ R)) ≫ + (α_ (V' ⊗ V) V' (V ⊗ R)).hom ≫ + ((V' ⊗ V) ◁ (α_ V' V R).inv) = + (V' ◁ ((α_ V' V (V ⊗ R)).inv ≫ + ((β_ V' V).hom ▷ (V ⊗ R)) ≫ + (α_ V V' (V ⊗ R)).hom ≫ (V ◁ (α_ V' V R).inv))) ≫ + (α_ V' V ((V' ⊗ V) ⊗ R)).inv := by + have hnat : ((β_ V' V').hom ▷ (V ⊗ (V ⊗ R))) ≫ + (α_ V' V' (V ⊗ (V ⊗ R))).hom ≫ + (V' ◁ (α_ V' V (V ⊗ R)).inv) ≫ + (α_ V' (V' ⊗ V) (V ⊗ R)).inv ≫ + ((α_ V' V' V).inv ▷ (V ⊗ R)) = + (α_ V' V' (V ⊗ (V ⊗ R))).hom ≫ + (V' ◁ (α_ V' V (V ⊗ R)).inv) ≫ + (α_ V' (V' ⊗ V) (V ⊗ R)).inv ≫ + ((α_ V' V' V).inv ▷ (V ⊗ R)) ≫ + (((β_ V' V').hom ▷ V) ▷ (V ⊗ R)) := by + monoidal + have hcancel : (((β_ V' V').hom ▷ V) ▷ (V ⊗ R)) ≫ + (((β_ V' V').hom ▷ V) ▷ (V ⊗ R)) = + 𝟙 (((V' ⊗ V') ⊗ V) ⊗ (V ⊗ R)) := by + rw [← MonoidalCategory.comp_whiskerRight, + ← MonoidalCategory.comp_whiskerRight, + SymmetricCategory.symmetry] + simp + rw [BraidedCategory.braiding_tensor_right_hom V' V' V] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [reassoc_of% hnat, reassoc_of% hcancel] + simp only [Iso.inv_hom_id_assoc] + monoidal + +/-- **The second pure routing law**: the braiding of the two +`M`-factors before the parallel routing, followed by the block +braiding, is the same single interleave crossing. -/ +private theorem route_snd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (V' : D) + (V : D) + (R : D) : + (V' ◁ (V' ◁ ((α_ V V R).inv ≫ ((β_ V V).hom ▷ R) ≫ + (α_ V V R).hom))) ≫ + (V' ◁ (α_ V' V (V ⊗ R)).inv) ≫ + (α_ V' (V' ⊗ V) (V ⊗ R)).inv ≫ + ((β_ V' (V' ⊗ V)).hom ▷ (V ⊗ R)) ≫ + (α_ (V' ⊗ V) V' (V ⊗ R)).hom ≫ + ((V' ⊗ V) ◁ (α_ V' V R).inv) ≫ + (α_ (V' ⊗ V) (V' ⊗ V) R).inv ≫ + ((β_ (V' ⊗ V) (V' ⊗ V)).hom ▷ R) ≫ + (α_ (V' ⊗ V) (V' ⊗ V) R).hom = + (V' ◁ ((α_ V' V (V ⊗ R)).inv ≫ + ((β_ V' V).hom ▷ (V ⊗ R)) ≫ + (α_ V V' (V ⊗ R)).hom ≫ (V ◁ (α_ V' V R).inv))) ≫ + (α_ V' V ((V' ⊗ V) ⊗ R)).inv := by + rw [BraidedCategory.braiding_tensor_right_hom V' V' V, + BraidedCategory.braiding_tensor_right_hom + (V' ⊗ V) V' V, + BraidedCategory.braiding_tensor_left_hom V' V V', + BraidedCategory.braiding_tensor_left_hom V' V V] + simp only [MonoidalCategory.comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + have hw1 : ((α_ V' V V').inv ▷ (V ⊗ R)) ≫ + (α_ (V' ⊗ V) V' (V ⊗ R)).hom ≫ + ((V' ⊗ V) ◁ (α_ V' V R).inv) ≫ + (α_ (V' ⊗ V) (V' ⊗ V) R).inv ≫ + ((α_ (V' ⊗ V) V' V).inv ▷ R) ≫ + (((α_ V' V V').hom ▷ V) ▷ R) = + (α_ (V' ⊗ (V ⊗ V')) V R).inv := by + monoidal + have hc1 : ((V' ◁ (β_ V' V).hom) ▷ (V ⊗ R)) ≫ + ((V' ◁ (β_ V V').hom) ▷ (V ⊗ R)) = + 𝟙 ((V' ⊗ (V' ⊗ V)) ⊗ (V ⊗ R)) := by + rw [← MonoidalCategory.comp_whiskerRight, + ← MonoidalCategory.whiskerLeft_comp, + SymmetricCategory.symmetry] + simp + rw [reassoc_of% hw1, ← associator_inv_naturality_left_assoc, + reassoc_of% hc1] + have hw2 : ((α_ V' V' V).hom ▷ (V ⊗ R)) ≫ + (α_ (V' ⊗ (V' ⊗ V)) V R).inv ≫ + ((α_ V' V' V).inv ▷ V ▷ R) = + (α_ ((V' ⊗ V') ⊗ V) V R).inv := by + monoidal + have hc2 : ((β_ V' V').hom ▷ V ▷ (V ⊗ R)) ≫ + ((β_ V' V').hom ▷ V ▷ (V ⊗ R)) = + 𝟙 (((V' ⊗ V') ⊗ V) ⊗ (V ⊗ R)) := by + rw [← MonoidalCategory.comp_whiskerRight, + ← MonoidalCategory.comp_whiskerRight, + SymmetricCategory.symmetry] + simp + rw [reassoc_of% hw2, ← associator_inv_naturality_left_assoc, + reassoc_of% hc2] + have hw3 : (V' ◁ V' ◁ (α_ V V R).hom) ≫ + (V' ◁ (α_ V' V (V ⊗ R)).inv) ≫ + (α_ V' (V' ⊗ V) (V ⊗ R)).inv ≫ + ((α_ V' V' V).inv ▷ (V ⊗ R)) ≫ + (α_ ((V' ⊗ V') ⊗ V) V R).inv ≫ + ((α_ V' V' V).hom ▷ V ▷ R) ≫ + ((α_ V' (V' ⊗ V) V).hom ▷ R) ≫ + ((V' ◁ (α_ V' V V).hom) ▷ R) = + (V' ◁ (α_ V' (V ⊗ V) R).inv) ≫ + (α_ V' (V' ⊗ (V ⊗ V)) R).inv := by + monoidal + have hc3 : (V' ◁ ((β_ V V).hom ▷ R)) ≫ + (V' ◁ ((β_ V V).hom ▷ R)) = + 𝟙 (V' ⊗ ((V ⊗ V) ⊗ R)) := by + rw [← MonoidalCategory.whiskerLeft_comp, + ← MonoidalCategory.comp_whiskerRight, + SymmetricCategory.symmetry] + simp + rw [reassoc_of% hw3, ← associator_inv_naturality_middle_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc] + simp only [Category.assoc] + rw [← associator_inv_naturality_middle, reassoc_of% hc3] + monoidal + +/-- **The window braid exchange**: braiding the two consumed +`M'`-factors before the doubled window equals braiding the two +consumed `M`-factors and flipping the two emitted scalars. -/ +private theorem dblWin_braid + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + (V' : D) (V : D) + (u : V' ⊗ V ⟶ A) (R : D) : + ((α_ V' V' (V ⊗ (V ⊗ R))).inv ≫ + ((β_ V' V').hom ▷ (V ⊗ (V ⊗ R))) ≫ + (α_ V' V' (V ⊗ (V ⊗ R))).hom) ≫ dblWin A V' V u R = + (V' ◁ (V' ◁ ((α_ V V R).inv ≫ ((β_ V V).hom ▷ R) ≫ + (α_ V V R).hom))) ≫ dblWin A V' V u R ≫ + (R ◁ (β_ A A).hom) := by + rw [dblWin_par] + simp only [Category.assoc] + trans (V' ◁ ((α_ V' V (V ⊗ R)).inv ≫ + ((β_ V' V).hom ▷ (V ⊗ R)) ≫ + (α_ V V' (V ⊗ R)).hom ≫ (V ◁ (α_ V' V R).inv))) ≫ + (α_ V' V ((V' ⊗ V) ⊗ R)).inv ≫ + (u ▷ ((V' ⊗ V) ⊗ R)) ≫ (A ◁ (u ▷ R)) ≫ + (A ◁ (β_ A R).hom) ≫ (β_ A (R ⊗ A)).hom ≫ + (α_ R A A).hom + · rw [reassoc_of% (route_fst V' V R)] + · rw [← reassoc_of% (route_snd V' V R), + reassoc_of% (fire_swap A V' V u R), + tail_flip A R] + +/-- **The doubled step absorbs the boundary braiding**: braiding +the two consumed `M'`-factors before the doubled step equals +braiding the two consumed `M`-factors. The two emitted scalars +exchange, which the commutative fold absorbs. -/ +private theorem stepU_dbl_braid + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [IsCommMonObj A] (V' : D) (V : D) + (u : V' ⊗ V ⟶ A) {Q R : D} + (r : Q ⊗ R ⟶ A) : + (((α_ Q V' V').hom ≫ (Q ◁ (β_ V' V').hom) ≫ + (α_ Q V' V').inv) ▷ (V ⊗ (V ⊗ R))) ≫ + stepU A V' V u (stepU A V' V u r) = + (((Q ⊗ V') ⊗ V') ◁ ((α_ V V R).inv ≫ + ((β_ V V).hom ▷ R) ≫ (α_ V V R).hom)) ≫ + stepU A V' V u (stepU A V' V u r) := by + rw [stepU_stepU] + rw [reassoc_of% (braid_spine V' Q (V ⊗ (V ⊗ R)))] + rw [← MonoidalCategory.whiskerLeft_comp_assoc, + dblWin_braid] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [reassoc_of% (whisk_spine V' (α_ V V R).hom), + reassoc_of% (whisk_spine V' ((β_ V V).hom ▷ R)), + reassoc_of% (whisk_spine V' (α_ V V R).inv)] + rw [flip_absorb] + +end DblCore + +/-! ## The exchange law -/ + +section Exchange + +/-- The doubled pairing step absorbs the boundary braiding. -/ +private theorem pairStep_dbl_braid + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + {Q R : D} (r : Q ⊗ R ⟶ A) : + (((α_ Q M'.X M'.X).hom ≫ (Q ◁ (β_ M'.X M'.X).hom) ≫ + (α_ Q M'.X M'.X).inv) ▷ (M.X ⊗ (M.X ⊗ R))) ≫ + pairStep A M M' d (pairStep A M M' d r) = + (((Q ⊗ M'.X) ⊗ M'.X) ◁ ((α_ M.X M.X R).inv ≫ + ((β_ M.X M.X).hom ▷ R) ≫ (α_ M.X M.X R).hom)) ≫ + pairStep A M M' d (pairStep A M M' d r) := + stepU_dbl_braid A M'.X M.X (pairRaw A M M' d) r + +/-- **The boundary of the exchange law**: the top transposition of +the `M'`-power crosses the pairing as the bottom transposition of +the `M`-power. -/ +private theorem rawPair_topSwap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (n : ℕ) : + (permMor M'.X (n + 1 + 1) topSwap ▷ + tensorPow D M.X (n + 1 + 1)) ≫ + rawPair A M M' d (n + 1 + 1) = + (tensorPow D M'.X (n + 1 + 1) ◁ + permMor M.X (n + 1 + 1) + (Equiv.swap ⟨0, by omega⟩ ⟨1, by omega⟩)) ≫ + rawPair A M M' d (n + 1 + 1) := by + have hpair : rawPair A M M' d (n + 1 + 1) = + (tensorPow D M'.X (n + 1 + 1) ◁ + ((powPeel M.X (n + 1)).hom ≫ + (M.X ◁ (powPeel M.X n).hom))) ≫ + pairStep A M M' d + (pairStep A M M' d (rawPair A M M' d n)) := by + erw [rawPair_succ_step, rawPair_succ_step, + ← pairStep_postcomp] + conv_rhs => erw [MonoidalCategory.whiskerLeft_comp] + erw [Category.assoc] + rfl + have hts : permMor M'.X (n + 1 + 1) topSwap = + swapTop M'.X n := + permMor_topSwap_eq M'.X n + have hlow : permMor M.X (n + 1 + 1) + (Equiv.swap ⟨0, by omega⟩ ⟨1, by omega⟩) ≫ + ((powPeel M.X (n + 1)).hom ≫ + (M.X ◁ (powPeel M.X n).hom)) = + ((powPeel M.X (n + 1)).hom ≫ + (M.X ◁ (powPeel M.X n).hom)) ≫ + ((α_ M.X M.X (tensorPow D M.X n)).inv ≫ + ((β_ M.X M.X).hom ▷ tensorPow D M.X n) ≫ + (α_ M.X M.X (tensorPow D M.X n)).hom) := by + have h := powPeel_permMor_low M.X n + simp only [Category.assoc] at h ⊢ + exact h + have hdbl : (tensorPow D M'.X (n + 1 + 1) ◁ + ((α_ M.X M.X (tensorPow D M.X n)).inv ≫ + ((β_ M.X M.X).hom ▷ tensorPow D M.X n) ≫ + (α_ M.X M.X (tensorPow D M.X n)).hom)) ≫ + pairStep A M M' d + (pairStep A M M' d (rawPair A M M' d n)) = + (swapTop M'.X n ▷ + (M.X ⊗ (M.X ⊗ tensorPow D M.X n))) ≫ + pairStep A M M' d + (pairStep A M M' d (rawPair A M M' d n)) := + (pairStep_dbl_braid A M M' d (rawPair A M M' d n)).symm + erw [hpair, hts, ← whisker_exchange_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, hlow] + conv_rhs => erw [MonoidalCategory.whiskerLeft_comp, Category.assoc] + exact congrArg (CategoryStruct.comp _) hdbl.symm + +/-- **The exchange law on adjacent transpositions**: the adjacent +braiding of `M`-slots `a, a + 1` crosses the raw pairing as the +adjacent braiding of `M'`-slots `b, b + 1`, mirrored across the +arity. -/ +private theorem rawPair_swap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + ∀ (a b m : ℕ) (_ : a + 2 + b = m), + (permMor M'.X m + (Equiv.swap ⟨b, by omega⟩ ⟨b + 1, by omega⟩) ▷ + tensorPow D M.X m) ≫ rawPair A M M' d m = + (tensorPow D M'.X m ◁ + permMor M.X m + (Equiv.swap ⟨a, by omega⟩ ⟨a + 1, by omega⟩)) ≫ + rawPair A M M' d m + | 0, b, m, h => by + subst h + have hc : (0 : ℕ) + 2 + b = b + 1 + 1 := by omega + have hL : permMor M'.X (0 + 2 + b) + (Equiv.swap ⟨b, by omega⟩ ⟨b + 1, by omega⟩) ≫ + powCast M'.X hc = + powCast M'.X hc ≫ permMor M'.X (b + 1 + 1) + (Equiv.swap ⟨b, by omega⟩ ⟨b + 1, by omega⟩) := + (powCast_permMor_swap M'.X hc ⟨b, by omega⟩ + ⟨b + 1, by omega⟩).symm + have hR : permMor M.X (0 + 2 + b) + (Equiv.swap ⟨0, by omega⟩ ⟨1, by omega⟩) ≫ + powCast M.X hc = + powCast M.X hc ≫ permMor M.X (b + 1 + 1) + (Equiv.swap ⟨0, by omega⟩ ⟨1, by omega⟩) := + (powCast_permMor_swap M.X hc ⟨0, by omega⟩ + ⟨1, by omega⟩).symm + rw [rawPair_cast A M M' d hc] + conv_lhs => rw [← MonoidalCategory.comp_whiskerRight_assoc, + hL, MonoidalCategory.comp_whiskerRight, Category.assoc, + ← whisker_exchange_assoc] + conv_rhs => rw [whisker_exchange_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, hR, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + refine congrArg (CategoryStruct.comp _) ?_ + refine congrArg (CategoryStruct.comp _) ?_ + exact rawPair_topSwap A M M' d b + | a + 1, b, m, h => by + subst h + have hc : a + 1 + 2 + b = a + 2 + b + 1 := by omega + have hL : permMor M'.X (a + 1 + 2 + b) + (Equiv.swap ⟨b, by omega⟩ ⟨b + 1, by omega⟩) ≫ + powCast M'.X hc = + powCast M'.X hc ≫ permMor M'.X (a + 2 + b + 1) + (Equiv.swap ⟨b, by omega⟩ ⟨b + 1, by omega⟩) := + (powCast_permMor_swap M'.X hc ⟨b, by omega⟩ + ⟨b + 1, by omega⟩).symm + have hR : permMor M.X (a + 1 + 2 + b) + (Equiv.swap ⟨a + 1, by omega⟩ ⟨a + 2, by omega⟩) ≫ + powCast M.X hc = + powCast M.X hc ≫ permMor M.X (a + 2 + b + 1) + (Equiv.swap ⟨a + 1, by omega⟩ ⟨a + 2, by omega⟩) := + (powCast_permMor_swap M.X hc ⟨a + 1, by omega⟩ + ⟨a + 2, by omega⟩).symm + have hcontent : (permMor M'.X (a + 2 + b + 1) + (Equiv.swap ⟨b, by omega⟩ ⟨b + 1, by omega⟩) ▷ + tensorPow D M.X (a + 2 + b + 1)) ≫ + rawPair A M M' d (a + 2 + b + 1) = + (tensorPow D M'.X (a + 2 + b + 1) ◁ + permMor M.X (a + 2 + b + 1) + (Equiv.swap ⟨a + 1, by omega⟩ + ⟨a + 2, by omega⟩)) ≫ + rawPair A M M' d (a + 2 + b + 1) := by + have hswL : (Equiv.swap + (⟨b, by omega⟩ : Fin (a + 2 + b + 1)) + ⟨b + 1, by omega⟩) = + extPerm (Equiv.swap + (⟨b, by omega⟩ : Fin (a + 2 + b)) + ⟨b + 1, by omega⟩) := by + rw [extPerm_swap] + rfl + have hpost : (tensorPow D M'.X (a + 2 + b + 1) ◁ + (M.X ◁ permMor M.X (a + 2 + b) + (Equiv.swap ⟨a, by omega⟩ ⟨a + 1, by omega⟩))) ≫ + pairStep A M M' d (rawPair A M M' d (a + 2 + b)) = + pairStep A M M' d + ((tensorPow D M'.X (a + 2 + b) ◁ + permMor M.X (a + 2 + b) + (Equiv.swap ⟨a, by omega⟩ ⟨a + 1, by omega⟩)) ≫ + rawPair A M M' d (a + 2 + b)) := + pairStep_postcomp A M M' d _ _ + have hstep : (permMor M'.X (a + 2 + b + 1) + (Equiv.swap ⟨b, by omega⟩ ⟨b + 1, by omega⟩) ▷ + (M.X ⊗ tensorPow D M.X (a + 2 + b))) ≫ + pairStep A M M' d (rawPair A M M' d (a + 2 + b)) = + pairStep A M M' d + ((permMor M'.X (a + 2 + b) + (Equiv.swap ⟨b, by omega⟩ ⟨b + 1, by omega⟩) ▷ + tensorPow D M.X (a + 2 + b)) ≫ + rawPair A M M' d (a + 2 + b)) := by + rw [hswL, permMor_extPerm] + exact pairStep_precomp A M M' d _ _ + rw [rawPair_succ_step] + erw [← whisker_exchange_assoc, hstep] + erw [← MonoidalCategory.whiskerLeft_comp_assoc, + powPeel_permMor_swap M.X (a + 2 + b) a b rfl, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + hpost] + exact congrArg (CategoryStruct.comp _) + (congrArg (pairStep A M M' d) + (rawPair_swap A M M' d a b (a + 2 + b) rfl)) + rw [rawPair_cast A M M' d hc] + conv_lhs => rw [← MonoidalCategory.comp_whiskerRight_assoc, + hL, MonoidalCategory.comp_whiskerRight, Category.assoc, + ← whisker_exchange_assoc] + conv_rhs => rw [whisker_exchange_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, hR, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + refine congrArg (CategoryStruct.comp _) ?_ + refine congrArg (CategoryStruct.comp _) ?_ + exact hcontent + +/-- **The exchange law**: a permutation of the `M`-power slots +crosses the raw power pairing as the order-reversing adjoint +permutation of the `M'`-power slots. -/ +theorem rawPair_perm [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + ∀ (n : ℕ) (σ : Equiv.Perm (Fin n)), + (permMor M'.X n (adjPerm σ) ▷ tensorPow D M.X n) ≫ + rawPair A M M' d n = + (tensorPow D M'.X n ◁ permMor M.X n σ) ≫ + rawPair A M M' d n + | 0, σ => by + have hσ : σ = 1 := Equiv.ext fun i => i.elim0 + rw [hσ, adjPerm_one, permMor_one, permMor_one] + simp + | 1, σ => by + have hσ : σ = 1 := Equiv.ext fun i => Subsingleton.elim _ _ + rw [hσ, adjPerm_one, permMor_one, permMor_one] + simp + | m + 2, σ => by + have hgen : ∀ i : Fin (m + 1), + (permMor M'.X (m + 2) + (adjPerm (Equiv.swap i.castSucc i.succ)) ▷ + tensorPow D M.X (m + 2)) ≫ + rawPair A M M' d (m + 2) = + (tensorPow D M'.X (m + 2) ◁ + permMor M.X (m + 2) + (Equiv.swap i.castSucc i.succ)) ≫ + rawPair A M M' d (m + 2) := by + intro i + have hlt := i.isLt + have h1 : (i.rev.castSucc : Fin (m + 2)) = + ⟨m - i.val, by omega⟩ := by + refine Fin.ext ?_ + simp only [Fin.val_castSucc, Fin.val_rev] + omega + have h2 : (i.rev.succ : Fin (m + 2)) = + ⟨m - i.val + 1, by omega⟩ := by + refine Fin.ext ?_ + simp only [Fin.val_succ, Fin.val_rev] + omega + have h3 : (i.castSucc : Fin (m + 2)) = + ⟨i.val, by omega⟩ := + Fin.ext rfl + have h4 : (i.succ : Fin (m + 2)) = + ⟨i.val + 1, by omega⟩ := + Fin.ext rfl + rw [adjPerm_swap_castSucc_succ, h1, h2, h3, h4] + exact rawPair_swap A M M' d i.val (m - i.val) (m + 2) + (by omega) + have key : ∀ τ : Equiv.Perm (Fin (m + 2)), + τ ∈ Submonoid.closure + (Set.range fun i : Fin (m + 1) => + Equiv.swap i.castSucc i.succ) → + (permMor M'.X (m + 2) (adjPerm τ) ▷ + tensorPow D M.X (m + 2)) ≫ + rawPair A M M' d (m + 2) = + (tensorPow D M'.X (m + 2) ◁ + permMor M.X (m + 2) τ) ≫ + rawPair A M M' d (m + 2) := by + intro τ hτ + induction hτ using Submonoid.closure_induction_left with + | one => + rw [adjPerm_one, permMor_one, permMor_one] + simp + | mul_left g hg τ' hτ' ih => + obtain ⟨i, rfl⟩ := hg + rw [adjPerm_mul, permMor_mul, permMor_mul] + simp only [MonoidalCategory.comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [ih, ← whisker_exchange_assoc, hgen i] + exact key σ (by + rw [Equiv.Perm.mclosure_swap_castSucc_succ]; trivial) + +/-! ## The descended exchange law and self-adjointness -/ + +section Descended + +/-- **The descended exchange law**: a permutation of the module +power crosses the descended pairing as its order-reversing +adjoint. -/ +theorem pairPow_perm [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [Preadditive D] [HasFiniteBiproducts D] [MonoidalPreadditive D] + (d : ModDualityDatum A M M') (n : ℕ) + (σ : Equiv.Perm (Fin n)) : + (modPowPerm (A := A) (X := M'.X) n (adjPerm σ) ▷ + modPow A M.X n) ≫ pairPow A M M' d n = + (modPow A M'.X n ◁ + modPowPerm (A := A) (X := M.X) n σ) ≫ + pairPow A M M' d n := by + have hππ : (modPowπ A M'.X n ▷ tensorPow D M.X n) ≫ + (modPow A M'.X n ◁ modPowπ A M.X n) ≫ + pairPow A M M' d n = rawPair A M M' d n := by + rw [← MonoidalCategory.tensorHom_def_assoc, + modPowπ_tensor_pairPow] + apply modPow_whiskerLeft_hom_ext A M.X (modPow A M'.X n) n + apply modPow_whiskerRight_hom_ext A M'.X n + (tensorPow D M.X n) + conv_lhs => rw [whisker_exchange_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, modPowπ_perm, + MonoidalCategory.comp_whiskerRight, Category.assoc] + conv_rhs => rw [← MonoidalCategory.whiskerLeft_comp_assoc, + modPowπ_perm, MonoidalCategory.whiskerLeft_comp, + Category.assoc, ← whisker_exchange_assoc] + rw [hππ] + exact rawPair_perm A M M' d n σ + +/-- **Self-adjointness of the symmetriser across the pairing**: +the symmetriser acting on either module power pairs equally. The +adjoint is a bijection of the group, so the average over all +permutations is invariant under the exchange law. -/ +theorem symPowIdem_pairPow + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [Preadditive D] [HasFiniteBiproducts D] [MonoidalPreadditive D] + [Linear ℂ D] [MonoidalLinear ℂ D] + (d : ModDualityDatum A M M') + (n : ℕ) : + (symPowIdem A M'.X n ▷ modPow A M.X n) ≫ + pairPow A M M' d n = + (modPow A M'.X n ◁ symPowIdem A M.X n) ≫ + pairPow A M M' d n := by + have hexpL : symPowIdem A M'.X n = + ((n.factorial : ℂ))⁻¹ • ∑ σ : Equiv.Perm (Fin n), + modPowPerm (A := A) (X := M'.X) n σ := by + rw [symPowIdem, symmetriser, map_smul, map_sum] + simp only [modPowAlg_single] + have hexpR : symPowIdem A M.X n = + ((n.factorial : ℂ))⁻¹ • ∑ σ : Equiv.Perm (Fin n), + modPowPerm (A := A) (X := M.X) n σ := by + rw [symPowIdem, symmetriser, map_smul, map_sum] + simp only [modPowAlg_single] + rw [hexpL, hexpR, MonoidalLinear.smul_whiskerRight, + MonoidalLinear.whiskerLeft_smul, Linear.smul_comp, + Linear.smul_comp] + refine congrArg (HSMul.hSMul (((n.factorial : ℂ))⁻¹)) ?_ + rw [sum_whiskerRight, whiskerLeft_sum, + Preadditive.sum_comp, Preadditive.sum_comp] + refine Fintype.sum_equiv + ⟨adjPerm, adjPerm, adjPerm_adjPerm, adjPerm_adjPerm⟩ + _ _ fun σ => ?_ + have h := pairPow_perm A M M' d n (adjPerm σ) + rw [adjPerm_adjPerm] at h + exact h + +/-- Self-adjointness of the symmetriser, in tensor form. -/ +theorem symPowIdem_pairPow_tensor + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [Preadditive D] [HasFiniteBiproducts D] [MonoidalPreadditive D] + [Linear ℂ D] [MonoidalLinear ℂ D] + (d : ModDualityDatum A M M') + (n : ℕ) : + (symPowIdem A M'.X n ⊗ₘ 𝟙 (modPow A M.X n)) ≫ + pairPow A M M' d n = + (𝟙 (modPow A M'.X n) ⊗ₘ symPowIdem A M.X n) ≫ + pairPow A M M' d n := by + rw [MonoidalCategory.tensorHom_id, + MonoidalCategory.id_tensorHom] + exact symPowIdem_pairPow A M M' d n + +end Descended + +end Exchange + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermNat.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermNat.lean new file mode 100644 index 0000000000..bd5fcc7db6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermNat.lean @@ -0,0 +1,394 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Intertwine +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorExact + +/-! +# Naturality of the symmetric-group action + +A morphism `f : X ⟶ Y` induces `f ^ ⊗ n` between the tensor powers, +and the permutation action of `Envelope/SymPerm.lean` is natural in +it: every braiding used there is a component of a natural +transformation, so the action of any group-algebra element commutes +with `f ^ ⊗ n`. The naturality lemmas follow the recursion that +defines the action — one lemma per auxiliary definition. + +Two consequences are recorded. Tensor powers of monomorphisms are +monomorphisms (and dually for epimorphisms), because tensoring is +exact in a rigid category (`TensorExact.lean`); and Schur vanishing +passes to subobjects, quotients and isomorphs (the idempotent-level +form of Deligne's 1.19, Catégories tensorielles): a mono `Y ⟶ X` +intertwines the two actions, so if the block idempotent kills +`X ^ ⊗ n` it kills `Y ^ ⊗ n` as well. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {A : Type u} + +/-! ## Tensor powers of a morphism -/ + +/-- **The tensor power of a morphism**: `f ^ ⊗ n` acts as `f` on +every factor, by the same recursion that defines `tensorPow`. -/ +noncomputable def tensorPowMap [Category.{v} A] [MonoidalCategory A] + {X Y : A} (f : X ⟶ Y) : + (n : ℕ) → (tensorPow A X n ⟶ tensorPow A Y n) + | 0 => 𝟙 (𝟙_ A) + | n + 1 => tensorPowMap f n ⊗ₘ f + +/-- The empty power of a morphism is the identity of the unit. -/ +@[simp] +theorem tensorPowMap_zero [Category.{v} A] [MonoidalCategory A] + {X Y : A} (f : X ⟶ Y) : + tensorPowMap f 0 = 𝟙 (𝟙_ A) := rfl + +/-- The defining recursion of `tensorPowMap`. -/ +theorem tensorPowMap_succ [Category.{v} A] [MonoidalCategory A] + {X Y : A} (f : X ⟶ Y) (n : ℕ) : + tensorPowMap f (n + 1) = tensorPowMap f n ⊗ₘ f := rfl + +/-- Tensor powers of the identity are the identity. -/ +@[simp] +theorem tensorPowMap_id [Category.{v} A] [MonoidalCategory A] + (X : A) (n : ℕ) : + tensorPowMap (𝟙 X) n = 𝟙 (tensorPow A X n) := by + induction n with + | zero => rfl + | succ n ih => + rw [tensorPowMap_succ, ih, MonoidalCategory.id_tensorHom_id] + rfl + +/-- Tensor powers are functorial in the morphism. -/ +theorem tensorPowMap_comp [Category.{v} A] [MonoidalCategory A] + {X Y Z : A} (f : X ⟶ Y) (g : Y ⟶ Z) + (n : ℕ) : + tensorPowMap (f ≫ g) n = tensorPowMap f n ≫ tensorPowMap g n := by + induction n with + | zero => exact (Category.id_comp _).symm + | succ n ih => + rw [tensorPowMap_succ, tensorPowMap_succ, tensorPowMap_succ, ih, + ← MonoidalCategory.tensorHom_comp_tensorHom] + rfl + +/-! ## Mono and epi transport + +In a rigid category tensoring is exact (`TensorExact.lean`), so both +whiskerings preserve monomorphisms and epimorphisms, and hence so +does the tensor power of a morphism. +-/ + +/-- **Tensor powers preserve monomorphisms** in a rigid category: +each factor of `f ⊗ₘ f`'s whiskering factorisation preserves +monomorphisms, because tensoring preserves limits. -/ +theorem tensorPowMap_mono [Category.{v} A] [MonoidalCategory A] + [RigidCategory A] {X Y : A} (f : X ⟶ Y) + [Mono f] (n : ℕ) : Mono (tensorPowMap f n) := by + induction n with + | zero => + exact inferInstanceAs (Mono (𝟙 (𝟙_ A))) + | succ n ih => + have : PreservesLimitsOfSize.{0, 0} (tensorRight X) := + preservesSmallestLimits_of_preservesLimits _ + have : PreservesLimitsOfSize.{0, 0} + (tensorLeft (tensorPow A Y n)) := + preservesSmallestLimits_of_preservesLimits _ + have := ih + have : Mono (tensorPowMap f n ▷ X) := + (tensorRight X).map_mono (tensorPowMap f n) + have : Mono (tensorPow A Y n ◁ f) := + (tensorLeft (tensorPow A Y n)).map_mono f + rw [tensorPowMap_succ, MonoidalCategory.tensorHom_def] + change Mono ((tensorPowMap f n ▷ X) ≫ (tensorPow A Y n ◁ f)) + exact mono_comp _ _ + +/-- **Tensor powers preserve monomorphisms**, from mono +preservation of the tensor factors alone — the form consumed over +an ind-completion, where tensoring is exact without rigidity. -/ +theorem tensorPowMap_mono' [Category.{v} A] [MonoidalCategory A] + [∀ Z : A, (tensorLeft Z).PreservesMonomorphisms] + [∀ Z : A, (tensorRight Z).PreservesMonomorphisms] + {X Y : A} (f : X ⟶ Y) [Mono f] (n : ℕ) : + Mono (tensorPowMap f n) := by + induction n with + | zero => + exact inferInstanceAs (Mono (𝟙 (𝟙_ A))) + | succ n ih => + have := ih + have : Mono (tensorPowMap f n ▷ X) := + (tensorRight X).map_mono (tensorPowMap f n) + have : Mono (tensorPow A Y n ◁ f) := + (tensorLeft (tensorPow A Y n)).map_mono f + rw [tensorPowMap_succ, MonoidalCategory.tensorHom_def] + change Mono ((tensorPowMap f n ▷ X) ≫ + (tensorPow A Y n ◁ f)) + exact mono_comp _ _ + +/-- **Tensor powers preserve epimorphisms** in a rigid category: +each factor of `f ⊗ₘ f`'s whiskering factorisation preserves +epimorphisms, because tensoring preserves colimits. -/ +theorem tensorPowMap_epi [Category.{v} A] [MonoidalCategory A] + [RigidCategory A] {X Y : A} (f : X ⟶ Y) + [Epi f] (n : ℕ) : Epi (tensorPowMap f n) := by + induction n with + | zero => + exact inferInstanceAs (Epi (𝟙 (𝟙_ A))) + | succ n ih => + have : PreservesColimitsOfSize.{0, 0} (tensorRight X) := + preservesSmallestColimits_of_preservesColimits _ + have : PreservesColimitsOfSize.{0, 0} + (tensorLeft (tensorPow A Y n)) := + preservesSmallestColimits_of_preservesColimits _ + have := ih + have : Epi (tensorPowMap f n ▷ X) := + (tensorRight X).map_epi (tensorPowMap f n) + have : Epi (tensorPow A Y n ◁ f) := + (tensorLeft (tensorPow A Y n)).map_epi f + rw [tensorPowMap_succ, MonoidalCategory.tensorHom_def] + change Epi ((tensorPowMap f n ▷ X) ≫ (tensorPow A Y n ◁ f)) + exact epi_comp _ _ + +/-! ## Naturality of the action + +Each auxiliary morphism of `Envelope/SymPerm.lean` is built from +braidings and associators, which are components of natural +transformations, so each commutes with a tensor power of `f`. The +lemmas follow the definitions' recursions exactly. +-/ + +/-- A morphism intertwining `v` and `w` still intertwines after +whiskering, against `v ⊗ₘ f`. Stated at general objects, so that no +tensor-power arity enters the rewriting. -/ +private theorem whisker_pass [Category.{v} A] [MonoidalCategory A] + {P Q X Y : A} {u : P ⟶ P} {v : P ⟶ Q} + {w : Q ⟶ Q} (f : X ⟶ Y) (h : u ≫ v = v ≫ w) : + (u ▷ X) ≫ (v ⊗ₘ f) = (v ⊗ₘ f) ≫ (w ▷ Y) := by + rw [← MonoidalCategory.tensorHom_id u X, + ← MonoidalCategory.tensorHom_id w Y, + MonoidalCategory.tensorHom_comp_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, h, + Category.id_comp, Category.comp_id] + +/-- A commutation in the second tensorand passes a tensored morphism +through a left whiskering. Stated at general objects. -/ +private theorem tensor_middle [Category.{v} A] [MonoidalCategory A] + {P Q S T U V : A} (g : P ⟶ Q) + (h : S ⟶ T) (k : T ⟶ U) (h' : S ⟶ V) (k' : V ⟶ U) + (w : h ≫ k = h' ≫ k') : + (g ⊗ₘ h) ≫ (Q ◁ k) = (P ◁ h') ≫ (g ⊗ₘ k') := by + rw [← MonoidalCategory.id_tensorHom Q k, + ← MonoidalCategory.id_tensorHom P h', + MonoidalCategory.tensorHom_comp_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, w, + Category.comp_id, Category.id_comp] + +/-- Two morphisms that each intertwine `T` compose to a morphism +intertwining `T`. Stated at general objects, so that no tensor-power +arity enters the rewriting. -/ +private theorem step_shuffle [Category.{v} A] + {P Q : A} {s u : P ⟶ P} {T : P ⟶ Q} + {s' u' : Q ⟶ Q} (hs : s ≫ T = T ≫ s') (hu : u ≫ T = T ≫ u') : + (s ≫ u) ≫ T = T ≫ (s' ≫ u') := by + rw [Category.assoc, hu, ← Category.assoc, hs, Category.assoc] + +section Symmetric + +/-- The braiding conjugate that defines `swapTop` is natural, at a +general base object. -/ +private theorem swap_conj_natural + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + {P Q X Y : A} (g : P ⟶ Q) + (f : X ⟶ Y) : + ((α_ P X X).hom ≫ (P ◁ (β_ X X).hom) ≫ (α_ P X X).inv) ≫ + ((g ⊗ₘ f) ⊗ₘ f) = + ((g ⊗ₘ f) ⊗ₘ f) ≫ + ((α_ Q Y Y).hom ≫ (Q ◁ (β_ Y Y).hom) ≫ (α_ Q Y Y).inv) := by + have hmid : (g ⊗ₘ (f ⊗ₘ f)) ≫ (Q ◁ (β_ Y Y).hom) = + (P ◁ (β_ X X).hom) ≫ (g ⊗ₘ (f ⊗ₘ f)) := + tensor_middle _ _ _ _ _ (BraidedCategory.braiding_naturality f f) + simp only [Category.assoc] + rw [← MonoidalCategory.associator_inv_naturality, + ← reassoc_of% hmid, + ← MonoidalCategory.associator_naturality_assoc] + +/-- **Naturality of the top braiding**: `swapTop` commutes with a +tensor power of `f`, by naturality of the associator and of the +braiding. -/ +theorem swapTop_natural + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + {X Y : A} (f : X ⟶ Y) (n : ℕ) : + swapTop X n ≫ tensorPowMap f (n + 2) = + tensorPowMap f (n + 2) ≫ swapTop Y n := + swap_conj_natural (tensorPowMap f n) f + +/-- **Naturality of the insertion cycle**, by the recursion that +defines it: each bubbling step is a top braiding, natural by +`swapTop_natural`, whiskered by factors `f` passes through by +`whisker_pass`. -/ +theorem insertTop_natural + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + {X Y : A} (f : X ⟶ Y) : + ∀ n k : ℕ, + insertTop X n k ≫ tensorPowMap f (n + 1) = + tensorPowMap f (n + 1) ≫ insertTop Y n k := by + intro n + induction n with + | zero => + intro k + rw [insertTop_of_zero, insertTop_of_zero, Category.id_comp, + Category.comp_id] + | succ n ih => + intro k + cases k with + | zero => + rw [insertTop_zero, insertTop_zero, Category.id_comp, + Category.comp_id] + | succ k => + have hw : (insertTop X n k ▷ X) ≫ tensorPowMap f (n + 1 + 1) = + tensorPowMap f (n + 1 + 1) ≫ (insertTop Y n k ▷ Y) := + whisker_pass f (ih k) + have hs : swapTop X n ≫ tensorPowMap f (n + 1 + 1) = + tensorPowMap f (n + 1 + 1) ≫ swapTop Y n := + swapTop_natural f n + rw [insertTop_succ, insertTop_succ] + exact step_shuffle hs hw + +/-- **Naturality of the permutation action**: the action of any +permutation commutes with a tensor power of `f`. The proof is the +recursion of `permMor` itself. -/ +theorem permMor_natural + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + {X Y : A} (f : X ⟶ Y) : + ∀ (n : ℕ) (σ : Equiv.Perm (Fin n)), + permMor X n σ ≫ tensorPowMap f n = + tensorPowMap f n ≫ permMor Y n σ := by + intro n + induction n with + | zero => + intro σ + change 𝟙 (𝟙_ A) ≫ 𝟙 (𝟙_ A) = 𝟙 (𝟙_ A) ≫ 𝟙 (𝟙_ A) + rfl + | succ n ih => + intro σ + have hw : (permMor X n (restPerm σ) ▷ X) ≫ tensorPowMap f (n + 1) = + tensorPowMap f (n + 1) ≫ (permMor Y n (restPerm σ) ▷ Y) := + whisker_pass f (ih (restPerm σ)) + rw [permMor_succ, permMor_succ] + exact step_shuffle hw (insertTop_natural f n (n - (topImage σ : ℕ))) + +end Symmetric + +section Linear + +/-- **Naturality of the symmetric-group action**: the action of any +group-algebra element commutes with a tensor power of `f`. Both +sides are `ℂ`-linear in the element, so the statement reduces to +basis permutations, where it is `permMor_natural`. -/ +theorem permAlg_natural + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] + {X Y : A} (f : X ⟶ Y) (n : ℕ) + (x : SymGroupAlgebra n) : + permAlg X n x ≫ tensorPowMap f n = + tensorPowMap f n ≫ permAlg Y n x := by + induction x using MonoidAlgebra.induction_on with + | of σ => + rw [show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin n))) σ = + MonoidAlgebra.single σ (1 : ℂ) from rfl, + permAlg_single, permAlg_single] + exact permMor_natural f n σ + | add x y hx hy => + rw [map_add, map_add] + exact intertwine_add hx hy + | smul r x hx => + rw [map_smul, map_smul] + exact intertwine_smul r hx + +/-! ## Stability of Schur vanishing + +The idempotent-level form of Deligne's 1.19 (Catégories +tensorielles): Schur vanishing passes along monomorphisms, +epimorphisms and isomorphisms, by cancelling the tensor power of the +morphism against the naturality square. +-/ + +/-- A morphism intertwined with zero across a monomorphism is zero. +Stated at general objects. -/ +private theorem zero_of_intertwine_mono [Category.{v} A] [Preadditive A] + {P Q : A} {a : P ⟶ P} + {b : Q ⟶ Q} {T : P ⟶ Q} [Mono T] (hnat : a ≫ T = T ≫ b) + (hb : b = 0) : a = 0 := + zero_of_comp_mono T (by rw [hnat, hb, comp_zero]) + +/-- A morphism intertwined with zero across an epimorphism is zero. +Stated at general objects. -/ +private theorem zero_of_intertwine_epi [Category.{v} A] [Preadditive A] + {P Q : A} {a : P ⟶ P} + {b : Q ⟶ Q} {T : P ⟶ Q} [Epi T] (hnat : a ≫ T = T ≫ b) + (ha : a = 0) : b = 0 := + zero_of_epi_comp T (by rw [← hnat, ha, zero_comp]) + +/-- A morphism intertwined with zero across a split epimorphism is +zero. Stated at general objects. -/ +private theorem zero_of_intertwine_split [Category.{v} A] [Preadditive A] + {P Q : A} {a : P ⟶ P} + {b : Q ⟶ Q} {T : P ⟶ Q} {S : Q ⟶ P} (hST : S ≫ T = 𝟙 Q) + (hnat : a ≫ T = T ≫ b) (ha : a = 0) : b = 0 := by + calc b = (S ≫ T) ≫ b := by rw [hST, Category.id_comp] + _ = S ≫ a ≫ T := by rw [Category.assoc, ← hnat] + _ = 0 := by rw [ha, zero_comp, comp_zero] + +/-- **Schur vanishing descends along monomorphisms** (the +subobject half of Deligne's 1.19, at the idempotent level): if the +block idempotent of `μ` kills `X ^ ⊗ μ.card` and `Y ⟶ X` is a +monomorphism, it kills `Y ^ ⊗ μ.card` as well. -/ +theorem SchurKilled.of_mono + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] + [RigidCategory A] (P : SchurPackage.{v}) + {X Y : A} (f : Y ⟶ X) [Mono f] {μ : YoungDiagram} + (h : SchurKilled P X μ) : SchurKilled P Y μ := by + have := tensorPowMap_mono f μ.card + exact zero_of_intertwine_mono (permAlg_natural f μ.card (P.e μ)) h + +/-- **Schur vanishing descends along epimorphisms** (the quotient +half of Deligne's 1.19, at the idempotent level). -/ +theorem SchurKilled.of_epi + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] + [RigidCategory A] (P : SchurPackage.{v}) + {X Y : A} (f : X ⟶ Y) [Epi f] {μ : YoungDiagram} + (h : SchurKilled P X μ) : SchurKilled P Y μ := by + have := tensorPowMap_epi f μ.card + exact zero_of_intertwine_epi (permAlg_natural f μ.card (P.e μ)) h + +/-- **Schur vanishing is invariant under isomorphism.** No rigidity +is needed: the tensor power of `e.inv` splits the tensor power of +`e.hom`, and the naturality square does the rest. -/ +theorem SchurKilled.of_iso + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] + (P : SchurPackage.{v}) {X Y : A} + (e : X ≅ Y) {μ : YoungDiagram} (h : SchurKilled P X μ) : + SchurKilled P Y μ := by + have hST : tensorPowMap e.inv μ.card ≫ tensorPowMap e.hom μ.card = + 𝟙 (tensorPow A Y μ.card) := by + rw [← tensorPowMap_comp, e.inv_hom_id, tensorPowMap_id] + exact zero_of_intertwine_split hST + (permAlg_natural e.hom μ.card (P.e μ)) h + +end Linear + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermRepChar.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermRepChar.lean new file mode 100644 index 0000000000..ef1f6b42d4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermRepChar.lean @@ -0,0 +1,323 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CharSplit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSeries +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignedTensor + +/-! +# One-sided super specialisations are multiplicities + +The Schur specialisations at the one-sided super power sums +`superPS p 0` and `superPS 0 q` are multiplicities of the recast +Jacobi–Trudi irreducibles in genuine representations of `S_n`, +hence natural numbers. The symmetric group permutes the +colourings `Fin n → Fin p` — the basis of the `n`-th tensor power +of `ℂ^p` — and the character of the resulting permutation +representation is the completed cycle product of `superPS p 0`: +the colourings fixed by a permutation are the colourings constant +on its orbits. Twisting by the sign character produces the +completed cycle product of `superPS 0 q`. Pairing either +character against a recast Jacobi–Trudi character identifies the +Schur specialisation as the dimension of an equivariant Hom +space. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv MonoidAlgebra + + + +/-! ### The colour space and its permutation action -/ + +/-- The colour space: all colourings of `n` sites in `p` colours, +the basis of the `n`-th tensor power of `ℂ^p`. -/ +def colourSpace (n p : ℕ) : Type := Fin n → Fin p + +/-- The colour space is finite. -/ +instance colourSpace.fintype (n p : ℕ) : Fintype (colourSpace n p) := + inferInstanceAs (Fintype (Fin n → Fin p)) + +/-- And its members can be compared. -/ +noncomputable instance colourSpace.decidableEq (n p : ℕ) : + DecidableEq (colourSpace n p) := + Classical.decEq _ + +/-- The symmetric group acts on the colour space by precomposition +with the inverse permutation. -/ +instance colourSpace.mulAction {n p : ℕ} : + MulAction (Equiv.Perm (Fin n)) (colourSpace n p) where + smul π g := g ∘ ⇑π⁻¹ + one_smul g := by + funext i + rfl + mul_smul π ρ g := by + change g ∘ ⇑(π * ρ)⁻¹ = (g ∘ ⇑ρ⁻¹) ∘ ⇑π⁻¹ + rw [mul_inv_rev] + rfl + +/-- The permutation representation of `S_n` on the free vector +space over the colour space: the `n`-th tensor power of the +defining `p`-dimensional permutation representation. -/ +noncomputable def permRep (p n : ℕ) : + Representation ℂ (Equiv.Perm (Fin n)) ℂ[colourSpace n p] := + Representation.ofMulAction ℂ _ _ + +private theorem fixed_iff_comp_eq {n p : ℕ} (π : Equiv.Perm (Fin n)) + (g : colourSpace n p) : + π • g = g ↔ g ∘ ⇑π = g := by + constructor + · intro h + funext i + have := congrFun h (π i) + change g (π⁻¹ (π i)) = g (π i) at this + simp at this + exact this.symm + · intro h + funext i + change g (π⁻¹ i) = g i + have := congrFun h (π⁻¹ i) + change g (π (π⁻¹ i)) = g (π⁻¹ i) at this + simp at this + exact this.symm + +/-! ### The character of the permutation representation -/ + +private theorem char_permRep_count (p n : ℕ) + (π : Equiv.Perm (Fin n)) : + (permRep p n).character π = + ((Finset.univ.filter + (fun g : colourSpace n p => π • g = g)).card : ℂ) := by + change LinearMap.trace ℂ _ ((permRep p n) π) = _ + set b := MonoidAlgebra.basis (colourSpace n p) ℂ with hb_def + rw [LinearMap.trace_eq_matrix_trace ℂ b] + change ∑ g : colourSpace n p, + LinearMap.toMatrix b b ((permRep p n) π) g g = _ + have hdiag : ∀ g : colourSpace n p, + LinearMap.toMatrix b b ((permRep p n) π) g g = + if π • g = g then 1 else 0 := by + intro g + rw [LinearMap.toMatrix_apply] + change (b.repr ((permRep p n) π (MonoidAlgebra.single g 1))) g = + if π • g = g then 1 else 0 + rw [show (permRep p n) π (MonoidAlgebra.single g 1) = + MonoidAlgebra.single (π • g) 1 from + Representation.ofMulAction_single π g 1] + change ((coeffLinearEquiv ℂ) + (MonoidAlgebra.single (π • g) (1 : ℂ))) g = + if π • g = g then 1 else 0 + rw [coeffLinearEquiv_apply] + simp [ Finsupp.single_apply, eq_comm] + rw [Finset.sum_congr rfl (fun g _ => hdiag g)] + rw [← Finset.sum_filter] + simp + +open scoped Classical in +private theorem fixedPoints_card (p n : ℕ) (π : Equiv.Perm (Fin n)) : + (Finset.univ.filter + (fun g : colourSpace n p => π • g = g)).card = + p ^ (Multiset.card π.cycleType + (n - π.cycleType.sum)) := by + have h1 : (Finset.univ.filter + (fun g : colourSpace n p => π • g = g)).card = + Fintype.card {g : colourSpace n p // π • g = g} := + (Fintype.card_subtype _).symm + have e : {g : colourSpace n p // π • g = g} ≃ + {f : Fin n → Fin p // f ∘ ⇑π = f} := + { toFun := fun g => ⟨g.1, (fixed_iff_comp_eq π g.1).mp g.2⟩ + invFun := fun f => ⟨f.1, (fixed_iff_comp_eq π f.1).mpr f.2⟩ + left_inv := fun g => rfl + right_inv := fun f => rfl } + have h2 : Fintype.card {g : colourSpace n p // π • g = g} = + Fintype.card {f : Fin n → Fin p // f ∘ ⇑π = f} := + Fintype.card_congr e + have h3 : Fintype.card {f : Fin n → Fin p // f ∘ ⇑π = f} = + Fintype.card (OrbitSpace π → Fin p) := + Fintype.card_congr (fixedFunEquiv π (Fin p)) + have h4 : Fintype.card (OrbitSpace π → Fin p) = + p ^ Fintype.card (OrbitSpace π) := by + rw [Fintype.card_fun, Fintype.card_fin] + rw [h1, h2, h3, h4, card_orbitSpace] + +/-- The completed cycle product of the one-sided super power sums +`superPS p 0` is `p` raised to the number of orbits. -/ +theorem cycleFun_superPS_h {n : ℕ} (p : ℕ) + (π : Equiv.Perm (Fin n)) : + cycleFun (superPS p 0) π = + (p : ℂ) ^ (Multiset.card π.cycleType + + (n - π.cycleType.sum)) := by + rw [show superPS p 0 = fun _ => (p : ℂ) from by + funext c; simp [superPS]] + rw [cycleFun_eq_cycleProd, cycleProd_const] + +/-- **The character of the colour-space permutation +representation** is the completed cycle product of the one-sided +super power sums `superPS p 0`. -/ +theorem char_permRep (p n : ℕ) (π : Equiv.Perm (Fin n)) : + (permRep p n).character π = cycleFun (superPS p 0) π := by + rw [char_permRep_count p n π, fixedPoints_card p n π, + cycleFun_superPS_h p π, Nat.cast_pow] + +/-! ### The sign twist -/ + +/-- The sign representation of the symmetric group on `ℂ`. -/ +noncomputable def signRep (n : ℕ) : + Representation ℂ (Equiv.Perm (Fin n)) ℂ where + toFun π := ((Equiv.Perm.sign π : ℤ) : ℂ) • LinearMap.id + map_one' := by simp [Module.End.one_eq_id] + map_mul' π ρ := by + refine LinearMap.ext fun z => ?_ + change ((Equiv.Perm.sign (π * ρ) : ℤ) : ℂ) • z = + ((Equiv.Perm.sign π : ℤ) : ℂ) • + (((Equiv.Perm.sign ρ : ℤ) : ℂ) • z) + rw [map_mul] + push_cast + rw [mul_smul] + +/-- The character of the sign representation is the sign. -/ +theorem char_signRep (n : ℕ) (π : Equiv.Perm (Fin n)) : + (signRep n).character π = ((Equiv.Perm.sign π : ℤ) : ℂ) := by + change LinearMap.trace ℂ ℂ + (((Equiv.Perm.sign π : ℤ) : ℂ) • LinearMap.id) = _ + rw [map_smul, LinearMap.trace_id] + simp + +/-- The sign twist of the colour-space permutation representation: +the tensor product with the sign character. -/ +noncomputable def signPermRep (q n : ℕ) : + Representation ℂ (Equiv.Perm (Fin n)) + (TensorProduct ℂ ℂ ℂ[colourSpace n q]) := + Representation.tprod (signRep n) (permRep q n) + +private theorem prod_map_sign_pow (m : Multiset ℕ) : + (m.map fun c => (-1 : ℂ) ^ (c + 1)).prod = + (-1 : ℂ) ^ (m.sum + Multiset.card m) := by + induction m using Multiset.induction_on with + | empty => simp + | cons a m ih => + rw [Multiset.map_cons, Multiset.prod_cons, ih, + Multiset.sum_cons, Multiset.card_cons, ← pow_add, + show a + 1 + (m.sum + Multiset.card m) = + a + m.sum + (Multiset.card m + 1) from by omega] + +/-- The completed cycle product of the one-sided super power sums +`superPS 0 q` is the sign times `q` raised to the number of +orbits. -/ +theorem cycleFun_superPS_e {n : ℕ} (q : ℕ) + (π : Equiv.Perm (Fin n)) : + cycleFun (superPS 0 q) π = + ((Equiv.Perm.sign π : ℤ) : ℂ) * + (q : ℂ) ^ (Multiset.card π.cycleType + + (n - π.cycleType.sum)) := by + rw [show superPS 0 q = + fun c => ((fun c => (-1 : ℂ) ^ (c + 1)) c) * + ((fun _ => (q : ℂ)) c) from by + funext c + change superPS 0 q c = (-1 : ℂ) ^ (c + 1) * (q : ℂ) + simp [superPS]] + rw [cycleFun_mul] + rw [show cycleFun (fun _ => (q : ℂ)) π = + (q : ℂ) ^ (Multiset.card π.cycleType + + (n - π.cycleType.sum)) from by + rw [cycleFun_eq_cycleProd, cycleProd_const]] + rw [show cycleFun (fun c => (-1 : ℂ) ^ (c + 1)) π = + ((Equiv.Perm.sign π : ℤ) : ℂ) from by + rw [cycleFun, prod_map_sign_pow, sign_cast_complex] + norm_num] + +/-- **The character of the sign-twisted permutation +representation** is the completed cycle product of the one-sided +super power sums `superPS 0 q`. -/ +theorem char_signPermRep (q n : ℕ) (π : Equiv.Perm (Fin n)) : + (signPermRep q n).character π = cycleFun (superPS 0 q) π := by + have h : (signPermRep q n).character π = + (signRep n).character π * (permRep q n).character π := by + change (Representation.tprod (signRep n) + (permRep q n)).character π = _ + rw [Representation.char_tensor] + rfl + rw [h, char_signRep, char_permRep, cycleFun_superPS_h, + cycleFun_superPS_e] + +/-! ### The multiplicity conclusions + +Pairing either character against a recast Jacobi–Trudi character +identifies the Schur specialisation at the one-sided super power +sums as the dimension of an equivariant Hom space. -/ + +/-- **Schur specialisations at `superPS p 0` are multiplicities**: +the value is the dimension of an equivariant Hom space, a natural +number. -/ +theorem diagramSchur_superPS_h_exists_nat {n : ℕ} (p : ℕ) + (μ : Shape n) : + ∃ m : ℕ, diagramSchur μ.val (superPS p 0) = m := by + classical + set ρμ : Representation ℂ (Equiv.Perm (Fin n)) + (subCarrier (jtSimple μ.val)) := + (rhoS (jtSimple μ.val)).comp (permCastHom μ.prop.symm) with hρμ + have hcard0 : ((Nat.card (Equiv.Perm (Fin n)) : ℂ)) ≠ 0 := by + rw [Nat.card_eq_fintype_card] + exact_mod_cast Fintype.card_ne_zero + have : Invertible ((Nat.card (Equiv.Perm (Fin n)) : ℂ)) := + invertibleOfNonzero hcard0 + have h := Representation.card_inv_mul_sum_char_mul_char_eq_finrank + ρμ (permRep p n) + refine ⟨Module.finrank ℂ + (Representation.IntertwiningMap ρμ (permRep p n)), ?_⟩ + rw [← h, ← jtChar_shape_frobenius μ (superPS p 0)] + rw [show ((Nat.card (Equiv.Perm (Fin n)) : ℂ))⁻¹ = + ((n.factorial : ℂ))⁻¹ from by + rw [Nat.card_eq_fintype_card, Fintype.card_perm, + Fintype.card_fin]] + congr 1 + refine Finset.sum_congr rfl fun π _ => ?_ + rw [char_permRep p n π] + rw [show ρμ.character π⁻¹ = + jtChar μ.val (permCast μ.prop.symm π) from by + rw [show ρμ.character π⁻¹ = + nChar (jtSimple μ.val) (permCast μ.prop.symm π⁻¹) from rfl, + permCast_inv, ← jtSimple_char μ.val, jtChar_inv]] + ring + +/-- **Schur specialisations at `superPS 0 q` are multiplicities**: +the value is the dimension of an equivariant Hom space, a natural +number. -/ +theorem diagramSchur_superPS_e_exists_nat {n : ℕ} (q : ℕ) + (μ : Shape n) : + ∃ m : ℕ, diagramSchur μ.val (superPS 0 q) = m := by + classical + set ρμ : Representation ℂ (Equiv.Perm (Fin n)) + (subCarrier (jtSimple μ.val)) := + (rhoS (jtSimple μ.val)).comp (permCastHom μ.prop.symm) with hρμ + have hcard0 : ((Nat.card (Equiv.Perm (Fin n)) : ℂ)) ≠ 0 := by + rw [Nat.card_eq_fintype_card] + exact_mod_cast Fintype.card_ne_zero + have : Invertible ((Nat.card (Equiv.Perm (Fin n)) : ℂ)) := + invertibleOfNonzero hcard0 + have h := Representation.card_inv_mul_sum_char_mul_char_eq_finrank + ρμ (signPermRep q n) + refine ⟨Module.finrank ℂ + (Representation.IntertwiningMap ρμ (signPermRep q n)), ?_⟩ + rw [← h, ← jtChar_shape_frobenius μ (superPS 0 q)] + rw [show ((Nat.card (Equiv.Perm (Fin n)) : ℂ))⁻¹ = + ((n.factorial : ℂ))⁻¹ from by + rw [Nat.card_eq_fintype_card, Fintype.card_perm, + Fintype.card_fin]] + congr 1 + refine Finset.sum_congr rfl fun π _ => ?_ + rw [char_signPermRep q n π] + rw [show ρμ.character π⁻¹ = + jtChar μ.val (permCast μ.prop.symm π) from by + rw [show ρμ.character π⁻¹ = + nChar (jtSimple μ.val) (permCast μ.prop.symm π⁻¹) from rfl, + permCast_inv, ← jtSimple_char μ.val, jtChar_inv]] + ring + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PieriPos.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PieriPos.lean new file mode 100644 index 0000000000..0f2664d27f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PieriPos.lean @@ -0,0 +1,1538 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.HookZero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.NewtonConv +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperValues + +/-! +# Pieri rules and hook positivity for Schur specialisations + +Three layers on top of the additive splitting of Schur +specialisations. + +1. **Linear independence**: the Schur specialisations of the shapes + of one size, as functions of the scalar sequence, are linearly + independent; a graded refinement separates sizes through the + homogeneity of the specialisation under `t c ↦ z^c · t c`. +2. **Pieri rules**: the Schur specialisation of a diagram at + `t + superPS 1 0` (one extra even variable) is the sum of the + Schur specialisations of its horizontal-strip sub-diagrams, by a + unipotent row operation on the Jacobi–Trudi matrix followed by a + multilinear expansion of the rows; at `t + superPS 0 1` (one + extra odd variable) the analogous identity over vertical-strip + sub-diagrams follows from a direct two-term expansion of the + rows. Extracting coefficients through the graded linear + independence yields the induction-multiplicity Pieri rules + `indMult lam μ (rowShape m)` and `indMult lam μ (colShape m)`. +3. **Hook positivity**: building a diagram avoiding the cell + `(p, q)` by horizontal strips in the first `p` rows and vertical + strips in the first `q` columns shows that its Schur + specialisation at `superPS p q` is a positive natural number — + the nonvanishing direction of Deligne 1.9 on the character side. +-/ + +@[expose] public section + +namespace RS + +open Finset Matrix + +/-! ### Linear independence of Schur specialisations at a fixed size + +The hypothesis pairs the class function +`π ↦ ∑ μ, c μ · jtChar μ (recast π)` to zero against every completed +cycle product; the Frobenius determination of class functions forces +the character combination to vanish, and orthonormality of the +recast characters extracts each coefficient. -/ + +/-- **Linear independence of Schur specialisations at a fixed +size**: a coefficient family on the shapes of size `n` whose +weighted sum of Schur specialisations vanishes at every scalar +sequence is identically zero. -/ +theorem diagramSchur_lin_indep {n : ℕ} (c : Shape n → ℂ) + (h : ∀ t : ℕ → ℂ, ∑ μ : Shape n, c μ * diagramSchur μ.val t = 0) : + ∀ μ, c μ = 0 := by + have hfac : ((n.factorial : ℕ) : ℂ) ≠ 0 := + Nat.cast_ne_zero.mpr (Nat.factorial_ne_zero n) + -- the character combination attached to the coefficients + set δ : Equiv.Perm (Fin n) → ℂ := fun π => + ∑ μ : Shape n, c μ * jtChar μ.val (permCast μ.prop.symm π) with hδ + have hconj : ∀ g k : Equiv.Perm (Fin n), δ (k * g * k⁻¹) = δ g := by + intro g k + rw [hδ] + refine Finset.sum_congr rfl fun μ _ => ?_ + congr 1 + rw [permCast_mul, permCast_mul, permCast_inv] + exact jtChar_conj μ.val (permCast μ.prop.symm k) + (permCast μ.prop.symm g) + have hvan : ∀ t : ℕ → ℂ, + ∑ π : Equiv.Perm (Fin n), δ π * cycleProd t π = 0 := by + intro t + rw [Finset.sum_congr rfl fun π _ => by rw [hδ, Finset.sum_mul]] + rw [Finset.sum_comm] + rw [Finset.sum_congr rfl fun μ _ => show + (∑ π : Equiv.Perm (Fin n), + c μ * jtChar μ.val (permCast μ.prop.symm π) * cycleProd t π) = + c μ * ((n.factorial : ℂ) * diagramSchur μ.val t) from by + rw [show ((n.factorial : ℂ)) * diagramSchur μ.val t = + ∑ π : Equiv.Perm (Fin n), + jtChar μ.val (permCast μ.prop.symm π) * cycleFun t π from by + rw [← jtChar_shape_frobenius μ t, ← mul_assoc, + mul_inv_cancel₀ hfac, one_mul]] + rw [Finset.mul_sum] + refine Finset.sum_congr rfl fun π _ => ?_ + rw [cycleFun_eq_cycleProd] + ring] + rw [Finset.sum_congr rfl fun μ _ => + mul_left_comm (c μ) ((n.factorial : ℂ)) (diagramSchur μ.val t)] + rw [← Finset.mul_sum, h t, mul_zero] + have hδ0 : ∀ π, δ π = 0 := + classFun_eq_zero_of_cycleProd δ hconj hvan + intro ν + have hnorm : ((n.factorial : ℂ))⁻¹ * ∑ π : Equiv.Perm (Fin n), + δ π * jtChar ν.val (permCast ν.prop.symm π) = c ν := by + rw [Finset.sum_congr rfl fun π _ => by rw [hδ, Finset.sum_mul]] + rw [Finset.sum_comm] + rw [Finset.sum_congr rfl fun μ _ => show + (∑ π : Equiv.Perm (Fin n), + c μ * jtChar μ.val (permCast μ.prop.symm π) * + jtChar ν.val (permCast ν.prop.symm π)) = + c μ * ∑ π : Equiv.Perm (Fin n), + jtChar μ.val (permCast μ.prop.symm π) * + jtChar ν.val (permCast ν.prop.symm π) from by + rw [Finset.mul_sum] + exact Finset.sum_congr rfl fun π _ => by ring] + rw [Finset.mul_sum] + rw [Finset.sum_congr rfl fun μ _ => + mul_left_comm ((n.factorial : ℂ))⁻¹ (c μ) _] + rw [Finset.sum_eq_single ν + (fun μ _ hμν => by rw [jtChar_orthogonal μ ν hμν, mul_zero]) + (fun hν => absurd (Finset.mem_univ ν) hν)] + rw [jtChar_shape_orthonormal ν, mul_one] + rw [← hnorm] + rw [Finset.sum_congr rfl fun π _ => by rw [hδ0 π, zero_mul]] + rw [Finset.sum_const_zero, mul_zero] + +/-! ### Homogeneity and the graded refinement -/ + +private theorem multiset_prod_map_pow (z : ℂ) (m : Multiset ℕ) : + (m.map fun c => z ^ c).prod = z ^ m.sum := by + induction m using Multiset.induction_on with + | empty => simp + | cons a s ih => + rw [Multiset.map_cons, Multiset.prod_cons, ih, + Multiset.sum_cons, pow_add] + +/-- The completed cycle product scales by `z^n` under the +substitution `t c ↦ z^c · t c`. -/ +theorem cycleFun_smul_pow {n : ℕ} (z : ℂ) (t : ℕ → ℂ) + (π : Equiv.Perm (Fin n)) : + cycleFun (fun c => z ^ c * t c) π = z ^ n * cycleFun t π := by + have hle : π.cycleType.sum ≤ n := by + have h := Equiv.Perm.sum_cycleType_le π + rwa [Fintype.card_fin] at h + have hpow : z ^ π.cycleType.sum * z ^ (n - π.cycleType.sum) = + z ^ n := by + rw [← pow_add] + congr 1 + omega + simp only [cycleFun] + rw [Multiset.prod_map_mul, multiset_prod_map_pow, pow_one, mul_pow] + linear_combination ((π.cycleType.map t).prod * + (t 1) ^ (n - π.cycleType.sum)) * hpow + +/-- **Homogeneity of the Schur specialisation**: substituting +`t c ↦ z^c · t c` scales the value of a diagram by `z` to its +number of cells. -/ +theorem diagramSchur_smul_pow (mu : YoungDiagram) (t : ℕ → ℂ) + (z : ℂ) : + diagramSchur mu (fun c => z ^ c * t c) = + z ^ mu.card * diagramSchur mu t := by + change diagramSchur (⟨mu, rfl⟩ : Shape mu.card).val + (fun c => z ^ c * t c) = + z ^ mu.card * diagramSchur (⟨mu, rfl⟩ : Shape mu.card).val t + rw [← jtChar_shape_frobenius (⟨mu, rfl⟩ : Shape mu.card) + (fun c => z ^ c * t c), + ← jtChar_shape_frobenius (⟨mu, rfl⟩ : Shape mu.card) t] + rw [Finset.sum_congr rfl fun π _ => by + rw [cycleFun_smul_pow z t π, + mul_left_comm _ (z ^ mu.card) (cycleFun t π)]] + rw [← Finset.mul_sum, mul_left_comm] + +/-- **Graded linear independence**: a size-indexed coefficient +family on the shapes of sizes `≤ n` whose combined Schur pairing +vanishes at every scalar sequence vanishes in every graded piece — +homogeneity separates the sizes, and the fixed-size independence +finishes. -/ +theorem diagramSchur_graded_lin_indep {n : ℕ} + (c : (k : ℕ) → Shape k → ℂ) + (h : ∀ t : ℕ → ℂ, ∑ k ∈ Finset.range (n + 1), ∑ κ : Shape k, + c k κ * diagramSchur κ.val t = 0) : + ∀ k, k ≤ n → ∀ κ : Shape k, c k κ = 0 := by + have hgrade : ∀ (t : ℕ → ℂ) (k), k ≤ n → + ∑ κ : Shape k, c k κ * diagramSchur κ.val t = 0 := by + intro t k hk + set p : Polynomial ℂ := ∑ j ∈ Finset.range (n + 1), + Polynomial.C (∑ κ : Shape j, c j κ * diagramSchur κ.val t) * + Polynomial.X ^ j with hp + have heval : ∀ z : ℂ, p.eval z = 0 := by + intro z + rw [hp, Polynomial.eval_finsetSum] + rw [Finset.sum_congr rfl fun j _ => by + rw [Polynomial.eval_mul, Polynomial.eval_C, + Polynomial.eval_pow, Polynomial.eval_X]] + have hz := h (fun c => z ^ c * t c) + rw [Finset.sum_congr rfl (fun j _ => Finset.sum_congr rfl + fun κ _ => by + rw [diagramSchur_smul_pow κ.val t z, κ.prop])] at hz + rw [← hz] + refine Finset.sum_congr rfl fun j _ => ?_ + rw [Finset.sum_mul] + refine Finset.sum_congr rfl fun κ _ => by ring + have hp0 : p = 0 := Polynomial.zero_of_eval_zero p heval + have hcoeff := congrArg (fun q : Polynomial ℂ => q.coeff k) hp0 + rw [hp, Polynomial.finsetSum_coeff, Polynomial.coeff_zero] + at hcoeff + rw [Finset.sum_congr rfl (fun j _ => by + rw [Polynomial.coeff_C_mul, Polynomial.coeff_X_pow])] at hcoeff + rw [Finset.sum_congr rfl (fun j _ => show + (∑ κ : Shape j, c j κ * diagramSchur κ.val t) * + (if k = j then (1 : ℂ) else 0) = + if j = k then (∑ κ : Shape j, c j κ * diagramSchur κ.val t) + else 0 from by + by_cases hjk : j = k + · rw [ite_eq_left hjk, ite_eq_left hjk.symm, mul_one] + · rw [ite_eq_right hjk, ite_eq_right (fun hkj => hjk hkj.symm), mul_zero])] + at hcoeff + rw [Finset.sum_ite_eq' (Finset.range (n + 1)) k + (fun j => ∑ κ : Shape j, c j κ * diagramSchur κ.val t), + ite_eq_left (Finset.mem_range.mpr (Nat.lt_succ_of_le hk))] at hcoeff + exact hcoeff + intro k hk + exact diagramSchur_lin_indep (c k) (fun t => hgrade t k hk) + +/-! ### Row-length utilities for Young diagrams -/ + +/-- Rows inside the row-length list are nonempty. -/ +theorem rowLen_pos_of_lt_length (mu : YoungDiagram) {i : ℕ} + (h : i < mu.rowLens.length) : 0 < mu.rowLen i := by + rw [YoungDiagram.length_rowLens] at h + exact YoungDiagram.mem_iff_lt_rowLen.mp + (YoungDiagram.mem_iff_lt_colLen.mpr h) + +/-- A membership description of every row pins the row length. -/ +private theorem rowLen_eq_of_forall {mu : YoungDiagram} {i L : ℕ} + (h : ∀ j, (i, j) ∈ mu ↔ j < L) : mu.rowLen i = L := by + rcases Nat.eq_zero_or_pos L with h0 | hpos + · subst h0 + by_contra hne + have hmem := YoungDiagram.mem_iff_lt_rowLen.mpr + (Nat.pos_of_ne_zero hne : 0 < mu.rowLen i) + exact absurd ((h 0).mp hmem) (by omega) + · have h1 : L - 1 < mu.rowLen i := + YoungDiagram.mem_iff_lt_rowLen.mp ((h (L - 1)).mpr (by omega)) + have h2 : ¬ L < mu.rowLen i := fun hlt => + absurd ((h L).mp (YoungDiagram.mem_iff_lt_rowLen.mpr hlt)) + (by omega) + omega + +/-- Diagrams with the same row lengths are equal. -/ +theorem ext_of_rowLen_eq {mu nu : YoungDiagram} + (h : ∀ i, mu.rowLen i = nu.rowLen i) : mu = nu := by + refine YoungDiagram.ext ?_ + refine Finset.ext fun c => ?_ + rw [YoungDiagram.mem_cells, YoungDiagram.mem_cells] + obtain ⟨i, j⟩ := c + rw [YoungDiagram.mem_iff_lt_rowLen, YoungDiagram.mem_iff_lt_rowLen, + h i] + +/-- Containment of diagrams is monotone on column lengths. -/ +theorem colLen_le_of_le {mu lam : YoungDiagram} (h : mu ≤ lam) + (j : ℕ) : mu.colLen j ≤ lam.colLen j := by + rcases Nat.eq_zero_or_pos (mu.colLen j) with h0 | hpos + · omega + · have hmem : (mu.colLen j - 1, j) ∈ mu := + YoungDiagram.mem_iff_lt_colLen.mpr (by omega) + have hmem' : (mu.colLen j - 1, j) ∈ lam := + (YoungDiagram.mem_cells _).mp + (YoungDiagram.cells_subset_iff.mpr h + ((YoungDiagram.mem_cells _).mpr hmem)) + have := YoungDiagram.mem_iff_lt_colLen.mp hmem' + omega + +/-- Rowwise domination of row lengths gives containment. -/ +theorem le_of_rowLen_le {mu lam : YoungDiagram} + (h : ∀ i, mu.rowLen i ≤ lam.rowLen i) : mu ≤ lam := by + rw [← YoungDiagram.cells_subset_iff] + intro c hc + rw [YoungDiagram.mem_cells] at hc ⊢ + obtain ⟨i, j⟩ := c + rw [YoungDiagram.mem_iff_lt_rowLen] at hc ⊢ + exact lt_of_lt_of_le hc (h i) + +private theorem list_sum_map_range (n : ℕ) (f : ℕ → ℕ) : + ((List.range n).map f).sum = ∑ i ∈ Finset.range n, f i := by + rw [Finset.sum_eq_multiset_sum, Finset.range_val, + ← Multiset.coe_range, Multiset.map_coe, Multiset.sum_coe] + +/-- The cell count as a row-length sum over any range covering the +column length. -/ +theorem card_eq_sum_range_rowLen (mu : YoungDiagram) (N : ℕ) + (hN : mu.colLen 0 ≤ N) : + mu.card = ∑ i ∈ Finset.range N, mu.rowLen i := by + rw [card_eq_sum_rowLens, + show mu.rowLens = (List.range (mu.colLen 0)).map mu.rowLen + from rfl, + list_sum_map_range] + refine Finset.sum_subset (Finset.range_subset_range.mpr hN) + fun i _ hi => ?_ + rw [Finset.mem_range, not_lt] at hi + exact rowLen_eq_zero_of_ge mu + (by rw [YoungDiagram.length_rowLens]; omega) + +/-! ### Diagrams from finite antitone row-length vectors -/ + +/-- Adjacent decrease of a vector on `Fin ℓ` implies full +antitonicity. -/ +private theorem fin_antitone_of_adjacent {ℓ : ℕ} {r : Fin ℓ → ℕ} + (h : ∀ (i : ℕ) (hi : i + 1 < ℓ), + r ⟨i + 1, hi⟩ ≤ r ⟨i, Nat.lt_of_succ_lt hi⟩) : + ∀ i j : Fin ℓ, i ≤ j → r j ≤ r i := by + suffices hd : ∀ (d : ℕ) (i j : Fin ℓ), (j : ℕ) = (i : ℕ) + d → + r j ≤ r i by + intro i j hij + exact hd ((j : ℕ) - (i : ℕ)) i j (by omega) + intro d + induction d with + | zero => + intro i j hij + rw [show j = i from Fin.ext (by omega)] + | succ e ih => + intro i j hij + have hlt : (i : ℕ) + e + 1 < ℓ := by + have := j.isLt + omega + have h1 : r j ≤ r ⟨(i : ℕ) + e, Nat.lt_of_succ_lt hlt⟩ := by + rw [show j = ⟨(i : ℕ) + e + 1, hlt⟩ from Fin.ext (by omega)] + exact h ((i : ℕ) + e) hlt + exact le_trans h1 (ih i ⟨(i : ℕ) + e, Nat.lt_of_succ_lt hlt⟩ + rfl) + +open scoped Classical in +/-- **The diagram of an antitone row-length vector** on `Fin ℓ`: +the Young diagram whose row `i < ℓ` has length `r i` (and `⊥` on +non-antitone junk input). -/ +noncomputable def stripDiagram {ℓ : ℕ} (r : Fin ℓ → ℕ) : + YoungDiagram := + if h : ∀ i j : Fin ℓ, i ≤ j → r j ≤ r i then + YoungDiagram.ofRowLens (List.ofFn r) + (List.sortedGE_iff_pairwise.mpr (List.pairwise_ofFn.mpr + fun i j hij => h i j (le_of_lt hij))) + else ⊥ + +/-- Membership in the diagram of a row-length vector. -/ +theorem stripDiagram_mem {ℓ : ℕ} {r : Fin ℓ → ℕ} + (h : ∀ i j : Fin ℓ, i ≤ j → r j ≤ r i) (c : ℕ × ℕ) : + c ∈ stripDiagram r ↔ ∃ hc : c.1 < ℓ, c.2 < r ⟨c.1, hc⟩ := by + rw [stripDiagram, dite_eq_left h, YoungDiagram.mem_ofRowLens] + constructor + · rintro ⟨h1, h2⟩ + have hc : c.1 < ℓ := by simpa using h1 + refine ⟨hc, ?_⟩ + rwa [List.getElem_ofFn] at h2 + · rintro ⟨hc, h2⟩ + have h1 : c.1 < (List.ofFn r).length := by simpa using hc + refine ⟨h1, ?_⟩ + rwa [List.getElem_ofFn] + +/-- Row lengths of the diagram of a vector, inside the range. -/ +theorem stripDiagram_rowLen_lt {ℓ : ℕ} {r : Fin ℓ → ℕ} + (h : ∀ i j : Fin ℓ, i ≤ j → r j ≤ r i) (i : Fin ℓ) : + (stripDiagram r).rowLen (i : ℕ) = r i := by + refine rowLen_eq_of_forall fun j => ?_ + rw [stripDiagram_mem h] + constructor + · rintro ⟨hc, h2⟩ + rwa [show (⟨(i : ℕ), hc⟩ : Fin ℓ) = i from Fin.ext rfl] at h2 + · intro hj + exact ⟨i.isLt, by + rwa [show (⟨(i : ℕ), i.isLt⟩ : Fin ℓ) = i from Fin.ext rfl]⟩ + +/-- Row lengths of the diagram of a vector, beyond the range. -/ +theorem stripDiagram_rowLen_le {ℓ : ℕ} {r : Fin ℓ → ℕ} + (h : ∀ i j : Fin ℓ, i ≤ j → r j ≤ r i) {i : ℕ} (hi : ℓ ≤ i) : + (stripDiagram r).rowLen i = 0 := by + refine rowLen_eq_of_forall fun j => ?_ + rw [stripDiagram_mem h] + constructor + · rintro ⟨hc, -⟩ + omega + · intro hj + exact absurd hj (Nat.not_lt_zero j) + +/-- The diagram of a vector on `Fin ℓ` has at most `ℓ` rows. -/ +theorem stripDiagram_colLen {ℓ : ℕ} {r : Fin ℓ → ℕ} + (h : ∀ i j : Fin ℓ, i ≤ j → r j ≤ r i) : + (stripDiagram r).colLen 0 ≤ ℓ := by + by_contra hlt + have hmem : (ℓ, 0) ∈ stripDiagram r := + YoungDiagram.mem_iff_lt_colLen.mpr (by omega) + obtain ⟨hc, -⟩ := (stripDiagram_mem h _).mp hmem + omega + +/-- A diagram with at most `ℓ` rows is the diagram of its own +row-length vector on `Fin ℓ`. -/ +theorem stripDiagram_of_rowLen {ℓ : ℕ} {mu : YoungDiagram} + (hc : mu.colLen 0 ≤ ℓ) : + stripDiagram (fun i : Fin ℓ => mu.rowLen (i : ℕ)) = mu := by + have h : ∀ i j : Fin ℓ, i ≤ j → + mu.rowLen (j : ℕ) ≤ mu.rowLen (i : ℕ) := + fun i j hij => mu.rowLen_anti _ _ hij + refine ext_of_rowLen_eq fun i => ?_ + rcases Nat.lt_or_ge i ℓ with hi | hi + · exact stripDiagram_rowLen_lt h ⟨i, hi⟩ + · rw [stripDiagram_rowLen_le h hi] + exact (rowLen_eq_zero_of_ge mu + (by rw [YoungDiagram.length_rowLens]; omega)).symm + +/-- The cell count of the diagram of a vector is the sum of the +vector. -/ +theorem stripDiagram_card {ℓ : ℕ} {r : Fin ℓ → ℕ} + (h : ∀ i j : Fin ℓ, i ≤ j → r j ≤ r i) : + (stripDiagram r).card = ∑ i, r i := by + rw [card_eq_sum_range_rowLen (stripDiagram r) ℓ + (stripDiagram_colLen h)] + rw [← Fin.sum_univ_eq_sum_range] + exact Finset.sum_congr rfl fun i _ => stripDiagram_rowLen_lt h i + +/-! ### Horizontal and vertical strips -/ + +/-- **Horizontal strip**: `mu` is contained in `lam` and interlaces +it — each row of `lam` reaches at most the previous row of `mu`, so +the removed skew cells occupy distinct columns. -/ +def IsHStrip (lam mu : YoungDiagram) : Prop := + mu ≤ lam ∧ ∀ i, lam.rowLen (i + 1) ≤ mu.rowLen i + +/-- **Vertical strip**: `mu` is contained in `lam` and each row +shrinks by at most one cell, so the removed skew cells occupy +distinct rows. -/ +def IsVStrip (lam mu : YoungDiagram) : Prop := + mu ≤ lam ∧ ∀ i, lam.rowLen i ≤ mu.rowLen i + 1 + +/-! ### The one-row and one-column shapes -/ + +/-- The single-row shape of size `m`. -/ +noncomputable def rowShape (m : ℕ) : Shape m := + ⟨stripDiagram (fun _ : Fin 1 => m), by + rw [stripDiagram_card (fun _ _ _ => le_refl m)] + simp⟩ + +/-- The single-column shape of size `m`. -/ +noncomputable def colShape (m : ℕ) : Shape m := + ⟨stripDiagram (fun _ : Fin m => 1), by + rw [stripDiagram_card (fun _ _ _ => le_refl 1)] + simp⟩ + +/-- The first row of the one-row shape. -/ +theorem rowShape_rowLen_zero (m : ℕ) : + (rowShape m).val.rowLen 0 = m := + stripDiagram_rowLen_lt (fun _ _ _ => le_refl m) ⟨0, Nat.one_pos⟩ + +/-- The later rows of the one-row shape. -/ +theorem rowShape_rowLen_succ (m i : ℕ) : + (rowShape m).val.rowLen (i + 1) = 0 := + stripDiagram_rowLen_le (fun _ _ _ => le_refl m) (by omega) + +/-- The one-row shape has at most one row. -/ +theorem rowShape_colLen (m : ℕ) : (rowShape m).val.colLen 0 ≤ 1 := + stripDiagram_colLen (fun _ _ _ => le_refl m) + +/-- The rows of the one-column shape, inside the column. -/ +theorem colShape_rowLen_lt (m : ℕ) {i : ℕ} (hi : i < m) : + (colShape m).val.rowLen i = 1 := + stripDiagram_rowLen_lt (fun _ _ _ => le_refl 1) ⟨i, hi⟩ + +/-- The rows of the one-column shape, beyond the column. -/ +theorem colShape_rowLen_le (m : ℕ) {i : ℕ} (hi : m ≤ i) : + (colShape m).val.rowLen i = 0 := + stripDiagram_rowLen_le (fun _ _ _ => le_refl 1) hi + +/-- The one-column shape has rows of length at most one. -/ +theorem colShape_rowLen_zero_le (m : ℕ) : + (colShape m).val.rowLen 0 ≤ 1 := by + rcases Nat.eq_zero_or_pos m with h0 | hpos + · rw [colShape_rowLen_le m (by omega)] + omega + · rw [colShape_rowLen_lt m hpos] + +/-- **Uniqueness of the one-row shape**: a shape of size `b` with +at most one row is `rowShape b`. -/ +theorem shape_eq_rowShape {b : ℕ} (ν : Shape b) + (h : ν.val.colLen 0 ≤ 1) : ν = rowShape b := by + have h0 : ν.val.rowLen 0 = b := by + have hcard := card_eq_sum_range_rowLen ν.val 1 h + rw [ν.prop, Finset.sum_range_one] at hcard + omega + refine Shape.ext (ext_of_rowLen_eq fun i => ?_) + cases i with + | zero => rw [h0, rowShape_rowLen_zero] + | succ j => + rw [rowShape_rowLen_succ] + exact rowLen_eq_zero_of_ge ν.val + (by rw [YoungDiagram.length_rowLens]; omega) + +/-- **Uniqueness of the one-column shape**: a shape of size `b` +with rows of length at most one is `colShape b`. -/ +theorem shape_eq_colShape {b : ℕ} (ν : Shape b) + (h : ν.val.rowLen 0 ≤ 1) : ν = colShape b := by + have hrow1 : ∀ i, i < ν.val.colLen 0 → ν.val.rowLen i = 1 := by + intro i hi + have hpos : 0 < ν.val.rowLen i := + rowLen_pos_of_lt_length ν.val + (by rw [YoungDiagram.length_rowLens]; omega) + have hle : ν.val.rowLen i ≤ ν.val.rowLen 0 := + ν.val.rowLen_anti 0 i (Nat.zero_le i) + omega + have hcard : b = ν.val.colLen 0 := by + have h1 := card_eq_sum_range_rowLen ν.val (ν.val.colLen 0) + (le_refl _) + rw [ν.prop] at h1 + rw [Finset.sum_congr rfl + (fun i hi => hrow1 i (Finset.mem_range.mp hi))] at h1 + rw [Finset.sum_const, Finset.card_range, smul_eq_mul, + mul_one] at h1 + exact h1 + refine Shape.ext (ext_of_rowLen_eq fun i => ?_) + rcases Nat.lt_or_ge i b with hi | hi + · rw [colShape_rowLen_lt b hi] + exact hrow1 i (by omega) + · rw [colShape_rowLen_le b hi] + exact rowLen_eq_zero_of_ge ν.val + (by rw [YoungDiagram.length_rowLens]; omega) + +/-! ### The graded reindexing of strip-vector sums + +A sum over a set of antitone row-length vectors, of a function of +the associated diagrams, is a graded sum over the shapes of each +size satisfying the membership predicate of the vector set. -/ + +open scoped Classical in +private theorem sum_stripDiagram_graded {ℓ n : ℕ} + (P : Finset (Fin ℓ → ℕ)) (p : YoungDiagram → Prop) + (F : YoungDiagram → ℂ) + (hanti : ∀ r ∈ P, ∀ i j : Fin ℓ, i ≤ j → r j ≤ r i) + (hp : ∀ r ∈ P, p (stripDiagram r)) + (hmem : ∀ mu : YoungDiagram, p mu → mu.card ≤ n ∧ + mu.colLen 0 ≤ ℓ ∧ (fun i : Fin ℓ => mu.rowLen (i : ℕ)) ∈ P) : + ∑ r ∈ P, F (stripDiagram r) = + ∑ k ∈ Finset.range (n + 1), ∑ μ : Shape k, + (if p μ.val then 1 else 0) * F μ.val := by + -- the indicator becomes a filter + rw [Finset.sum_congr rfl (fun k _ => show + (∑ μ : Shape k, (if p μ.val then (1 : ℂ) else 0) * F μ.val) = + ∑ μ ∈ Finset.univ.filter (fun μ : Shape k => p μ.val), + F μ.val from by + rw [Finset.sum_filter] + refine Finset.sum_congr rfl fun μ _ => ?_ + by_cases hμ : p μ.val + · rw [ite_eq_left hμ, ite_eq_left hμ, one_mul] + · rw [ite_eq_right hμ, ite_eq_right hμ, zero_mul])] + -- fiber the vector sum by the cell count + rw [← Finset.sum_fiberwise_of_maps_to + (g := fun r : Fin ℓ → ℕ => (stripDiagram r).card) + (t := Finset.range (n + 1)) + (fun r hr => Finset.mem_range.mpr (Nat.lt_succ_of_le + (hmem _ (hp r hr)).1)) + (fun r => F (stripDiagram r))] + refine Finset.sum_congr rfl fun k _ => ?_ + -- at each size the vectors of that count are the shapes with `p` + refine Finset.sum_bij' + (i := fun r hr => (⟨stripDiagram r, + (Finset.mem_filter.mp hr).2⟩ : Shape k)) + (j := fun μ _ => fun i : Fin ℓ => μ.val.rowLen (i : ℕ)) + ?_ ?_ ?_ ?_ ?_ + · intro r hr + exact Finset.mem_filter.mpr + ⟨Finset.mem_univ _, hp r (Finset.mem_filter.mp hr).1⟩ + · intro μ hμ + have hpμ : p μ.val := (Finset.mem_filter.mp hμ).2 + rw [Finset.mem_filter] + refine ⟨(hmem μ.val hpμ).2.2, ?_⟩ + rw [stripDiagram_of_rowLen (hmem μ.val hpμ).2.1] + exact μ.prop + · intro r hr + funext i + exact stripDiagram_rowLen_lt + (hanti r (Finset.mem_filter.mp hr).1) i + · intro μ hμ + have hpμ : p μ.val := (Finset.mem_filter.mp hμ).2 + exact Shape.ext (stripDiagram_of_rowLen (hmem μ.val hpμ).2.1) + · intro r _ + rfl + +/-! ### The Jacobi–Trudi determinant in row-length form -/ + +/-- The Schur specialisation of a diagram is its Jacobi–Trudi +determinant over any square of rows covering the column length, +with the row lengths as exponents — zero rows pad invisibly. -/ +theorem diagramSchur_eq_det_rowLen (mu : YoungDiagram) {k : ℕ} + (hk : mu.colLen 0 ≤ k) (t : ℕ → ℂ) : + diagramSchur mu t = + (Matrix.of fun i j : Fin k => + newtonHZ t ((mu.rowLen (i : ℕ) : ℤ) + + (j : ℤ) - (i : ℤ))).det := by + have hzero : ∀ i, mu.rowLens.length ≤ i → mu.rowLen i = 0 := + fun i hi => rowLen_eq_zero_of_ge mu hi + have hLk : mu.rowLens.length ≤ k := by + rw [YoungDiagram.length_rowLens] + exact hk + refine Eq.trans ?_ + (det_newtonHZ_pad t (fun i => mu.rowLen i) k hLk hzero).symm + rw [diagramSchur, schurDet] + congr 1 + refine Matrix.ext fun i j => ?_ + rw [Matrix.of_apply, Matrix.of_apply] + congr 2 + rw [List.get_eq_getElem, YoungDiagram.get_rowLens] + +/-! ### One extra even variable: the partial-sum sequence + +At `t + superPS 1 0` the complete homogeneous sequence is the +partial-sum sequence of that of `t`; its integer-indexed first +difference is `newtonHZ t`, and telescoping produces the +interval-sum identity feeding the row operation. -/ + +private theorem newtonH_add_superPS_row (t : ℕ → ℂ) (n : ℕ) : + newtonH (fun c => t c + superPS 1 0 c) n = + ∑ m ∈ Finset.range (n + 1), newtonH t m := by + rw [newtonH_add] + rw [Finset.sum_congr rfl fun ij _ => by + rw [newtonH_superPS_zero_q 1 ij.2 Nat.one_pos, + show (1 - 1 + ij.2).choose ij.2 = 1 from by + rw [show 1 - 1 + ij.2 = ij.2 from by omega, Nat.choose_self], + Nat.cast_one, mul_one]] + rw [Finset.Nat.sum_antidiagonal_eq_sum_range_succ_mk] + +private theorem newtonHZ_row_step (t : ℕ → ℂ) (w : ℤ) : + newtonHZ (fun c => t c + superPS 1 0 c) w = + newtonHZ (fun c => t c + superPS 1 0 c) (w - 1) + + newtonHZ t w := by + rcases lt_or_ge w 0 with hw | hw + · rw [newtonHZ_neg _ _ hw, newtonHZ_neg _ _ (by omega), + newtonHZ_neg _ _ hw] + ring + · obtain ⟨n, rfl⟩ := Int.eq_ofNat_of_zero_le hw + cases n with + | zero => + rw [newtonHZ_natCast, newtonHZ_natCast, newtonH_zero, + newtonH_zero, newtonHZ_neg _ _ (by norm_num)] + ring + | succ m => + rw [show ((m + 1 : ℕ) : ℤ) - 1 = ((m : ℕ) : ℤ) from by + push_cast; ring] + rw [newtonHZ_natCast, newtonHZ_natCast, newtonHZ_natCast, + newtonH_add_superPS_row, newtonH_add_superPS_row, + Finset.sum_range_succ] + +private theorem newtonHZ_row_sum (t : ℕ → ℂ) (z : ℤ) {b a : ℕ} + (hba : b ≤ a) : + newtonHZ (fun c => t c + superPS 1 0 c) ((a : ℤ) + z) = + newtonHZ (fun c => t c + superPS 1 0 c) ((b : ℤ) - 1 + z) + + ∑ μ ∈ Finset.Icc b a, newtonHZ t ((μ : ℤ) + z) := by + induction a, hba using Nat.le_induction with + | base => + rw [Finset.Icc_self, Finset.sum_singleton] + have hstep := newtonHZ_row_step t ((b : ℤ) + z) + rw [show (b : ℤ) + z - 1 = (b : ℤ) - 1 + z from by ring] + at hstep + exact hstep + | succ a hba ih => + have hins : Finset.Icc b (a + 1) = + insert (a + 1) (Finset.Icc b a) := by + ext x + simp only [Finset.mem_Icc, Finset.mem_insert] + omega + rw [hins, Finset.sum_insert (by + simp only [Finset.mem_Icc] + omega)] + have hstep := newtonHZ_row_step t (((a + 1 : ℕ) : ℤ) + z) + rw [show ((a + 1 : ℕ) : ℤ) + z - 1 = ((a : ℕ) : ℤ) + z from by + push_cast; ring] at hstep + rw [hstep, ih] + ring + +/-! ### The unipotent row operation -/ + +/-- The unipotent row-operation matrix subtracting from each row +its successor. -/ +noncomputable def rowOp (ℓ : ℕ) : Matrix (Fin ℓ) (Fin ℓ) ℂ := + Matrix.of fun i k => + if k = i then 1 else if (k : ℕ) = (i : ℕ) + 1 then -1 else 0 + +/-- The row operation is upper triangular. -/ +theorem rowOp_blockTriangular (ℓ : ℕ) : + (rowOp ℓ).BlockTriangular id := by + intro i k hki + have h : (k : ℕ) < (i : ℕ) := hki + simp only [rowOp, Matrix.of_apply] + split_ifs with h1 h2 + · exact absurd (congrArg Fin.val h1) (by omega) + · omega + · rfl + +/-- The row operation has determinant one. -/ +theorem det_rowOp (ℓ : ℕ) : (rowOp ℓ).det = 1 := by + rw [Matrix.det_of_isUpperTriangular (rowOp_blockTriangular ℓ)] + refine Finset.prod_eq_one fun i _ => ?_ + simp [rowOp] + +/-- Entries of a matrix transformed by the row operation. -/ +private theorem rowOp_mul_apply {ℓ : ℕ} + (M : Matrix (Fin ℓ) (Fin ℓ) ℂ) (i j : Fin ℓ) : + (rowOp ℓ * M) i j = + M i j - (if h : (i : ℕ) + 1 < ℓ then M ⟨(i : ℕ) + 1, h⟩ j + else 0) := by + rw [Matrix.mul_apply] + by_cases h : (i : ℕ) + 1 < ℓ + · rw [dite_eq_left h] + have hsplit : ∀ k : Fin ℓ, rowOp ℓ i k * M k j = + (if k = i then M k j else 0) + + (if k = (⟨(i : ℕ) + 1, h⟩ : Fin ℓ) then -M k j else 0) := by + intro k + simp only [rowOp, Matrix.of_apply] + by_cases h1 : k = i + · rw [ite_eq_left h1, ite_eq_left h1, one_mul, + ite_eq_right (fun he => by + have hv : (i : ℕ) = (i : ℕ) + 1 := + congrArg Fin.val (h1.symm.trans he) + omega), + add_zero] + · rw [ite_eq_right h1, ite_eq_right h1] + by_cases h2 : (k : ℕ) = (i : ℕ) + 1 + · rw [ite_eq_left h2, ite_eq_left (Fin.ext h2), neg_one_mul, zero_add] + · rw [ite_eq_right h2, + ite_eq_right (fun hk => h2 (congrArg Fin.val hk)), + zero_mul, add_zero] + rw [Finset.sum_congr rfl fun k _ => hsplit k, + Finset.sum_add_distrib, + Finset.sum_ite_eq' Finset.univ i (fun k => M k j), + ite_eq_left (Finset.mem_univ i), + Finset.sum_ite_eq' Finset.univ (⟨(i : ℕ) + 1, h⟩ : Fin ℓ) + (fun k => -M k j), + ite_eq_left (Finset.mem_univ _)] + ring + · rw [dite_eq_right h] + have hone : ∀ k : Fin ℓ, rowOp ℓ i k * M k j = + if k = i then M k j else 0 := by + intro k + simp only [rowOp, Matrix.of_apply] + by_cases h1 : k = i + · rw [ite_eq_left h1, ite_eq_left h1, one_mul] + · rw [ite_eq_right h1, ite_eq_right h1, + ite_eq_right (fun h2 : (k : ℕ) = (i : ℕ) + 1 => + h (h2 ▸ k.isLt)), + zero_mul] + rw [Finset.sum_congr rfl fun k _ => hone k, + Finset.sum_ite_eq' Finset.univ i (fun k => M k j), + ite_eq_left (Finset.mem_univ i)] + ring + +/-! ### The horizontal Pieri determinant identity -/ + +/-- The interlacing row-length vectors of a diagram: the exponent +choices of the horizontal-strip sub-diagrams. -/ +private def rowStripVecs (lam : YoungDiagram) : + Finset (Fin lam.rowLens.length → ℕ) := + Fintype.piFinset fun i => + Finset.Icc (lam.rowLen ((i : ℕ) + 1)) (lam.rowLen (i : ℕ)) + +private theorem mem_rowStripVecs {lam : YoungDiagram} + {r : Fin lam.rowLens.length → ℕ} (hr : r ∈ rowStripVecs lam) + (i : Fin lam.rowLens.length) : + lam.rowLen ((i : ℕ) + 1) ≤ r i ∧ r i ≤ lam.rowLen (i : ℕ) := + Finset.mem_Icc.mp (Fintype.mem_piFinset.mp hr i) + +private theorem rowStripVecs_anti {lam : YoungDiagram} : + ∀ r ∈ rowStripVecs lam, ∀ i j : Fin lam.rowLens.length, + i ≤ j → r j ≤ r i := by + intro r hr + refine fin_antitone_of_adjacent fun i hi => ?_ + exact le_trans (mem_rowStripVecs hr ⟨i + 1, hi⟩).2 + (mem_rowStripVecs hr ⟨i, Nat.lt_of_succ_lt hi⟩).1 + +open scoped Classical in +/-- **One extra even variable — the horizontal Pieri identity**: +the Schur specialisation of `lam` at `t + superPS 1 0` is the sum +of the Schur specialisations at `t` of the horizontal-strip +sub-diagrams of `lam`, presented as a graded sum over the shapes +of each size with the strip indicator. -/ +theorem diagramSchur_add_one_row (lam : YoungDiagram) (t : ℕ → ℂ) : + diagramSchur lam (fun c => t c + superPS 1 0 c) = + ∑ k ∈ Finset.range (lam.card + 1), ∑ μ : Shape k, + (if IsHStrip lam μ.val then 1 else 0) * + diagramSchur μ.val t := by + classical + set M : Matrix (Fin lam.rowLens.length) + (Fin lam.rowLens.length) ℂ := Matrix.of fun i j => + newtonHZ (fun c => t c + superPS 1 0 c) + ((lam.rowLen (i : ℕ) : ℤ) + (j : ℤ) - (i : ℤ)) with hM + -- the specialisation as the determinant of `M` + have h1 : diagramSchur lam (fun c => t c + superPS 1 0 c) = + M.det := + diagramSchur_eq_det_rowLen lam + (le_of_eq YoungDiagram.length_rowLens.symm) _ + -- rows after the row operation are interval sums + have h2 : ∀ i j : Fin lam.rowLens.length, + (rowOp lam.rowLens.length * M) i j = + ∑ μ ∈ Finset.Icc (lam.rowLen ((i : ℕ) + 1)) + (lam.rowLen (i : ℕ)), + newtonHZ t ((μ : ℤ) + (j : ℤ) - (i : ℤ)) := by + intro i j + rw [rowOp_mul_apply] + have hba : lam.rowLen ((i : ℕ) + 1) ≤ lam.rowLen (i : ℕ) := + lam.rowLen_anti _ _ (by omega) + have hsum := newtonHZ_row_sum t ((j : ℤ) - (i : ℤ)) hba + have harg : (lam.rowLen (i : ℕ) : ℤ) + (j : ℤ) - (i : ℤ) = + (lam.rowLen (i : ℕ) : ℤ) + ((j : ℤ) - (i : ℤ)) := by ring + have hfix : (∑ μ ∈ Finset.Icc (lam.rowLen ((i : ℕ) + 1)) + (lam.rowLen (i : ℕ)), + newtonHZ t ((μ : ℤ) + ((j : ℤ) - (i : ℤ)))) = + ∑ μ ∈ Finset.Icc (lam.rowLen ((i : ℕ) + 1)) + (lam.rowLen (i : ℕ)), + newtonHZ t ((μ : ℤ) + (j : ℤ) - (i : ℤ)) := by + refine Finset.sum_congr rfl fun μ _ => ?_ + congr 1 + ring + by_cases h : (i : ℕ) + 1 < lam.rowLens.length + · rw [dite_eq_left h] + change newtonHZ (fun c => t c + superPS 1 0 c) + ((lam.rowLen (i : ℕ) : ℤ) + (j : ℤ) - (i : ℤ)) - + newtonHZ (fun c => t c + superPS 1 0 c) + ((lam.rowLen ((i : ℕ) + 1) : ℤ) + (j : ℤ) - + (((i : ℕ) + 1 : ℕ) : ℤ)) = _ + rw [show (lam.rowLen ((i : ℕ) + 1) : ℤ) + (j : ℤ) - + (((i : ℕ) + 1 : ℕ) : ℤ) = + (lam.rowLen ((i : ℕ) + 1) : ℤ) - 1 + + ((j : ℤ) - (i : ℤ)) from by push_cast; ring] + rw [harg, hsum, hfix] + ring + · rw [dite_eq_right h] + have hneg : (lam.rowLen ((i : ℕ) + 1) : ℤ) - 1 + + ((j : ℤ) - (i : ℤ)) < 0 := by + rw [rowLen_eq_zero_of_ge lam (by omega)] + have hj := j.isLt + have hi := i.isLt + push_cast + omega + change newtonHZ (fun c => t c + superPS 1 0 c) + ((lam.rowLen (i : ℕ) : ℤ) + (j : ℤ) - (i : ℤ)) - 0 = _ + rw [harg, hsum, newtonHZ_neg _ _ hneg, hfix] + ring + -- multilinear expansion of the transformed determinant + have h3 : M.det = ∑ r ∈ rowStripVecs lam, + (Matrix.of fun i j : Fin lam.rowLens.length => + newtonHZ t ((r i : ℤ) + (j : ℤ) - (i : ℤ))).det := by + have hdet : M.det = (rowOp lam.rowLens.length * M).det := by + rw [Matrix.det_mul, det_rowOp, one_mul] + rw [hdet] + have hrows : (fun i : Fin lam.rowLens.length => + (rowOp lam.rowLens.length * M) i) = + fun i : Fin lam.rowLens.length => + ∑ μ ∈ Finset.Icc (lam.rowLen ((i : ℕ) + 1)) + (lam.rowLen (i : ℕ)), + (fun j : Fin lam.rowLens.length => + newtonHZ t ((μ : ℤ) + (j : ℤ) - (i : ℤ))) := by + funext i + funext j + rw [Finset.sum_apply] + exact h2 i j + change Matrix.detRowAlternating + (fun i : Fin lam.rowLens.length => + (rowOp lam.rowLens.length * M) i) = _ + rw [hrows] + exact (Matrix.detRowAlternating (n := Fin lam.rowLens.length) + (R := ℂ)).toMultilinearMap.map_sum_finset + (fun (i : Fin lam.rowLens.length) (μ : ℕ) => + fun j : Fin lam.rowLens.length => + newtonHZ t ((μ : ℤ) + (j : ℤ) - (i : ℤ))) + (fun i => Finset.Icc (lam.rowLen ((i : ℕ) + 1)) + (lam.rowLen (i : ℕ))) + -- each expansion term is the Schur value of its strip diagram + have h4 : ∀ r ∈ rowStripVecs lam, + (Matrix.of fun i j : Fin lam.rowLens.length => + newtonHZ t ((r i : ℤ) + (j : ℤ) - (i : ℤ))).det = + diagramSchur (stripDiagram r) t := by + intro r hr + rw [diagramSchur_eq_det_rowLen (stripDiagram r) + (k := lam.rowLens.length) + (stripDiagram_colLen (rowStripVecs_anti r hr)) t] + congr 1 + refine Matrix.ext fun i j => ?_ + rw [Matrix.of_apply, Matrix.of_apply, + stripDiagram_rowLen_lt (rowStripVecs_anti r hr) i] + -- assemble and reindex over the shapes of each size + rw [h1, h3, Finset.sum_congr rfl h4] + refine sum_stripDiagram_graded (rowStripVecs lam) + (IsHStrip lam) (fun mu => diagramSchur mu t) + rowStripVecs_anti ?_ ?_ + · intro r hr + constructor + · refine le_of_rowLen_le fun i => ?_ + rcases Nat.lt_or_ge i lam.rowLens.length with hi | hi + · rw [stripDiagram_rowLen_lt (rowStripVecs_anti r hr) ⟨i, hi⟩] + exact (mem_rowStripVecs hr ⟨i, hi⟩).2 + · rw [stripDiagram_rowLen_le (rowStripVecs_anti r hr) hi] + omega + · intro i + rcases Nat.lt_or_ge i lam.rowLens.length with hi | hi + · rw [stripDiagram_rowLen_lt (rowStripVecs_anti r hr) ⟨i, hi⟩] + exact (mem_rowStripVecs hr ⟨i, hi⟩).1 + · rw [rowLen_eq_zero_of_ge lam (by omega)] + omega + · intro mu hmu + refine ⟨YoungDiagram.card_le_card hmu.1, ?_, ?_⟩ + · rw [YoungDiagram.length_rowLens] + exact colLen_le_of_le hmu.1 0 + · rw [rowStripVecs, Fintype.mem_piFinset] + intro i + rw [Finset.mem_Icc] + exact ⟨hmu.2 (i : ℕ), rowLen_mono hmu.1 (i : ℕ)⟩ + +/-! ### One extra odd variable: the two-term sequence + +At `t + superPS 0 1` the complete homogeneous sequence is the +two-term convolution `h_n + h_{n-1}`: the generating series picks +up one factor `1 + X`. -/ + +private theorem newtonHZ_col_step (t : ℕ → ℂ) (z : ℤ) : + newtonHZ (fun c => t c + superPS 0 1 c) z = + newtonHZ t z + newtonHZ t (z - 1) := by + rcases lt_or_ge z 0 with hz | hz + · rw [newtonHZ_neg _ _ hz, newtonHZ_neg _ _ hz, + newtonHZ_neg _ _ (by omega)] + ring + · obtain ⟨n, rfl⟩ := Int.eq_ofNat_of_zero_le hz + have h := congrArg (PowerSeries.coeff n) + (newtonHSeries_add t (superPS 0 1)) + rw [show newtonHSeries (superPS 0 1) = 1 + PowerSeries.X from by + have h1 := newtonHSeries_superPS 0 1 + rwa [pow_zero, one_mul, pow_one] at h1] at h + rw [mul_add, mul_one, map_add] at h + simp only [newtonHSeries, PowerSeries.coeff_mk] at h + cases n with + | zero => + rw [PowerSeries.coeff_zero_mul_X] at h + rw [newtonHZ_natCast, newtonHZ_natCast, + newtonHZ_neg _ _ (by norm_num)] + exact h + | succ m => + rw [PowerSeries.coeff_succ_mul_X, PowerSeries.coeff_mk] at h + rw [show ((m + 1 : ℕ) : ℤ) - 1 = ((m : ℕ) : ℤ) from by + push_cast; ring] + rw [newtonHZ_natCast, newtonHZ_natCast, newtonHZ_natCast] + exact h + +/-! ### The vertical Pieri determinant identity -/ + +open scoped Classical in +/-- The near-constant row-length vectors of a diagram: the exponent +choices of the vertical-strip sub-diagrams, each row shrinking by +at most one, filtered by monotonicity. -/ +private noncomputable def colStripVecs (lam : YoungDiagram) : + Finset (Fin lam.rowLens.length → ℕ) := + (Fintype.piFinset fun i : Fin lam.rowLens.length => + Finset.Icc (lam.rowLen (i : ℕ) - 1) (lam.rowLen (i : ℕ))).filter + fun r => ∀ (i : ℕ) (hi : i + 1 < lam.rowLens.length), + r ⟨i + 1, hi⟩ ≤ r ⟨i, Nat.lt_of_succ_lt hi⟩ + +private theorem mem_colStripVecs {lam : YoungDiagram} + {r : Fin lam.rowLens.length → ℕ} (hr : r ∈ colStripVecs lam) + (i : Fin lam.rowLens.length) : + lam.rowLen (i : ℕ) - 1 ≤ r i ∧ r i ≤ lam.rowLen (i : ℕ) := by + classical + rw [colStripVecs, Finset.mem_filter] at hr + exact Finset.mem_Icc.mp (Fintype.mem_piFinset.mp hr.1 i) + +private theorem colStripVecs_good {lam : YoungDiagram} + {r : Fin lam.rowLens.length → ℕ} (hr : r ∈ colStripVecs lam) : + ∀ (i : ℕ) (hi : i + 1 < lam.rowLens.length), + r ⟨i + 1, hi⟩ ≤ r ⟨i, Nat.lt_of_succ_lt hi⟩ := by + classical + rw [colStripVecs, Finset.mem_filter] at hr + exact hr.2 + +private theorem colStripVecs_anti {lam : YoungDiagram} : + ∀ r ∈ colStripVecs lam, ∀ i j : Fin lam.rowLens.length, + i ≤ j → r j ≤ r i := by + intro r hr + exact fin_antitone_of_adjacent (colStripVecs_good hr) + +open scoped Classical in +private theorem colStripChoice_antitone_of_det_ne_zero (lam : YoungDiagram) (t : ℕ → ℂ) : + ∀ r ∈ Fintype.piFinset + (fun i : Fin lam.rowLens.length => + ({(lam.rowLen (i : ℕ) : ℤ) - 1, + (lam.rowLen (i : ℕ) : ℤ)} : Finset ℤ)), + (Matrix.of fun i j : Fin lam.rowLens.length => + newtonHZ t (r i + (j : ℤ) - (i : ℤ))).det ≠ 0 → + ∀ (i : ℕ) (hi : i + 1 < lam.rowLens.length), + r ⟨i + 1, hi⟩ ≤ r ⟨i, Nat.lt_of_succ_lt hi⟩ := by + classical + intro r hr hne i hi + by_contra hlt + rw [not_le] at hlt + have hm1 := Fintype.mem_piFinset.mp hr ⟨i, Nat.lt_of_succ_lt hi⟩ + have hm2 := Fintype.mem_piFinset.mp hr ⟨i + 1, hi⟩ + rw [Finset.mem_insert, Finset.mem_singleton] at hm1 hm2 + have hm1' : r ⟨i, Nat.lt_of_succ_lt hi⟩ = (lam.rowLen i : ℤ) - 1 ∨ + r ⟨i, Nat.lt_of_succ_lt hi⟩ = (lam.rowLen i : ℤ) := hm1 + have hm2' : r ⟨i + 1, hi⟩ = (lam.rowLen (i + 1) : ℤ) - 1 ∨ + r ⟨i + 1, hi⟩ = (lam.rowLen (i + 1) : ℤ) := hm2 + have hba : lam.rowLen (i + 1) ≤ lam.rowLen i := + lam.rowLen_anti _ _ (by omega) + have hkey : r ⟨i, Nat.lt_of_succ_lt hi⟩ = + (lam.rowLen i : ℤ) - 1 ∧ + r ⟨i + 1, hi⟩ = (lam.rowLen i : ℤ) := by + rcases hm1' with h1 | h1 <;> rcases hm2' with h2 | h2 <;> + constructor <;> omega + refine hne (Matrix.det_zero_of_row_eq + (i := (⟨i, Nat.lt_of_succ_lt hi⟩ : Fin lam.rowLens.length)) + (j := (⟨i + 1, hi⟩ : Fin lam.rowLens.length)) + (fun he => by + have hv : i = i + 1 := congrArg Fin.val he + omega) ?_) + funext j + change newtonHZ t (r ⟨i, Nat.lt_of_succ_lt hi⟩ + + (j : ℤ) - ((i : ℕ) : ℤ)) = + newtonHZ t (r ⟨i + 1, hi⟩ + (j : ℤ) - ((i + 1 : ℕ) : ℤ)) + rw [hkey.1, hkey.2] + congr 1 + push_cast + ring + +open scoped Classical in +/-- **One extra odd variable — the vertical Pieri identity**: the +Schur specialisation of `lam` at `t + superPS 0 1` is the sum of +the Schur specialisations at `t` of the vertical-strip sub-diagrams +of `lam`, presented as a graded sum over the shapes of each size +with the strip indicator. -/ +theorem diagramSchur_add_one_col (lam : YoungDiagram) (t : ℕ → ℂ) : + diagramSchur lam (fun c => t c + superPS 0 1 c) = + ∑ k ∈ Finset.range (lam.card + 1), ∑ μ : Shape k, + (if IsVStrip lam μ.val then 1 else 0) * + diagramSchur μ.val t := by + classical + set M : Matrix (Fin lam.rowLens.length) + (Fin lam.rowLens.length) ℂ := Matrix.of fun i j => + newtonHZ (fun c => t c + superPS 0 1 c) + ((lam.rowLen (i : ℕ) : ℤ) + (j : ℤ) - (i : ℤ)) with hM + have h1 : diagramSchur lam (fun c => t c + superPS 0 1 c) = + M.det := + diagramSchur_eq_det_rowLen lam + (le_of_eq YoungDiagram.length_rowLens.symm) _ + -- two-term decomposition of each row + have h2 : (fun i : Fin lam.rowLens.length => M i) = + fun i : Fin lam.rowLens.length => + ∑ z ∈ ({(lam.rowLen (i : ℕ) : ℤ) - 1, + (lam.rowLen (i : ℕ) : ℤ)} : Finset ℤ), + (fun j : Fin lam.rowLens.length => + newtonHZ t (z + (j : ℤ) - (i : ℤ))) := by + funext i + funext j + rw [Finset.sum_apply] + change newtonHZ (fun c => t c + superPS 0 1 c) + ((lam.rowLen (i : ℕ) : ℤ) + (j : ℤ) - (i : ℤ)) = _ + rw [newtonHZ_col_step, + Finset.sum_pair (by omega : (lam.rowLen (i : ℕ) : ℤ) - 1 ≠ + (lam.rowLen (i : ℕ) : ℤ)), + show (lam.rowLen (i : ℕ) : ℤ) + (j : ℤ) - (i : ℤ) - 1 = + (lam.rowLen (i : ℕ) : ℤ) - 1 + (j : ℤ) - (i : ℤ) from by + ring] + ring + -- multilinear expansion over the two-element choices + have h3 : M.det = ∑ r ∈ Fintype.piFinset + (fun i : Fin lam.rowLens.length => + ({(lam.rowLen (i : ℕ) : ℤ) - 1, + (lam.rowLen (i : ℕ) : ℤ)} : Finset ℤ)), + (Matrix.of fun i j : Fin lam.rowLens.length => + newtonHZ t (r i + (j : ℤ) - (i : ℤ))).det := by + change Matrix.detRowAlternating + (fun i : Fin lam.rowLens.length => M i) = _ + rw [h2] + exact (Matrix.detRowAlternating (n := Fin lam.rowLens.length) + (R := ℂ)).toMultilinearMap.map_sum_finset + (fun (i : Fin lam.rowLens.length) (z : ℤ) => + fun j : Fin lam.rowLens.length => + newtonHZ t (z + (j : ℤ) - (i : ℤ))) + (fun i => ({(lam.rowLen (i : ℕ) : ℤ) - 1, + (lam.rowLen (i : ℕ) : ℤ)} : Finset ℤ)) + -- non-monotone choices produce equal adjacent rows + have h4 := colStripChoice_antitone_of_det_ne_zero lam t + -- reindex the surviving choices to natural strip vectors + have h5 : ∑ r ∈ Fintype.piFinset + (fun i : Fin lam.rowLens.length => + ({(lam.rowLen (i : ℕ) : ℤ) - 1, + (lam.rowLen (i : ℕ) : ℤ)} : Finset ℤ)), + (Matrix.of fun i j : Fin lam.rowLens.length => + newtonHZ t (r i + (j : ℤ) - (i : ℤ))).det = + ∑ s ∈ colStripVecs lam, diagramSchur (stripDiagram s) t := by + rw [← Finset.sum_filter_of_ne (p := fun r => + ∀ (i : ℕ) (hi : i + 1 < lam.rowLens.length), + r ⟨i + 1, hi⟩ ≤ r ⟨i, Nat.lt_of_succ_lt hi⟩) h4] + refine Finset.sum_bij' + (i := fun r _ => fun i : Fin lam.rowLens.length => + (r i).toNat) + (j := fun s _ => fun i : Fin lam.rowLens.length => + ((s i : ℕ) : ℤ)) + ?_ ?_ ?_ ?_ ?_ + · intro r hr + have hrp := Finset.mem_filter.mp hr + rw [colStripVecs, Finset.mem_filter] + constructor + · rw [Fintype.mem_piFinset] + intro i + have hm := Fintype.mem_piFinset.mp hrp.1 i + rw [Finset.mem_insert, Finset.mem_singleton] at hm + have hpos : 0 < lam.rowLen (i : ℕ) := + rowLen_pos_of_lt_length lam i.isLt + rw [Finset.mem_Icc] + change lam.rowLen (i : ℕ) - 1 ≤ (r i).toNat ∧ + (r i).toNat ≤ lam.rowLen (i : ℕ) + rcases hm with h | h <;> omega + · intro i hi + have hle := hrp.2 i hi + change (r ⟨i + 1, hi⟩).toNat ≤ + (r ⟨i, Nat.lt_of_succ_lt hi⟩).toNat + omega + · intro s hs + have hgood := colStripVecs_good hs + rw [Finset.mem_filter] + constructor + · rw [Fintype.mem_piFinset] + intro i + have hpos : 0 < lam.rowLen (i : ℕ) := + rowLen_pos_of_lt_length lam i.isLt + have hb := mem_colStripVecs hs i + rw [Finset.mem_insert, Finset.mem_singleton] + show ((s i : ℕ) : ℤ) = (lam.rowLen (i : ℕ) : ℤ) - 1 ∨ + ((s i : ℕ) : ℤ) = (lam.rowLen (i : ℕ) : ℤ) + omega + · intro i hi + have := hgood i hi + change ((s ⟨i + 1, hi⟩ : ℕ) : ℤ) ≤ + ((s ⟨i, Nat.lt_of_succ_lt hi⟩ : ℕ) : ℤ) + omega + · intro r hr + funext i + have hm := Fintype.mem_piFinset.mp + (Finset.mem_filter.mp hr).1 i + rw [Finset.mem_insert, Finset.mem_singleton] at hm + have hpos : 0 < lam.rowLen (i : ℕ) := + rowLen_pos_of_lt_length lam i.isLt + change ((r i).toNat : ℤ) = r i + omega + · intro s _ + funext i + change ((s i : ℕ) : ℤ).toNat = s i + omega + · intro r hr + have hgood := (Finset.mem_filter.mp hr).2 + have hanti := fin_antitone_of_adjacent + (r := fun i : Fin lam.rowLens.length => (r i).toNat) + (fun i hi => by + have := hgood i hi + omega) + rw [diagramSchur_eq_det_rowLen + (stripDiagram (fun i : Fin lam.rowLens.length => + (r i).toNat)) + (k := lam.rowLens.length) (stripDiagram_colLen hanti) t] + congr 1 + refine Matrix.ext fun i j => ?_ + rw [Matrix.of_apply, Matrix.of_apply, + stripDiagram_rowLen_lt hanti i] + congr 1 + have hm := Fintype.mem_piFinset.mp + (Finset.mem_filter.mp hr).1 i + rw [Finset.mem_insert, Finset.mem_singleton] at hm + have hpos : 0 < lam.rowLen (i : ℕ) := + rowLen_pos_of_lt_length lam i.isLt + have hval : ((r i).toNat : ℤ) = r i := by omega + rw [hval] + -- assemble and reindex over the shapes of each size + rw [h1, h3, h5] + refine sum_stripDiagram_graded (colStripVecs lam) + (IsVStrip lam) (fun mu => diagramSchur mu t) + colStripVecs_anti ?_ ?_ + · intro s hs + constructor + · refine le_of_rowLen_le fun i => ?_ + rcases Nat.lt_or_ge i lam.rowLens.length with hi | hi + · rw [stripDiagram_rowLen_lt (colStripVecs_anti s hs) ⟨i, hi⟩] + exact (mem_colStripVecs hs ⟨i, hi⟩).2 + · rw [stripDiagram_rowLen_le (colStripVecs_anti s hs) hi] + omega + · intro i + rcases Nat.lt_or_ge i lam.rowLens.length with hi | hi + · rw [stripDiagram_rowLen_lt (colStripVecs_anti s hs) ⟨i, hi⟩] + have h1 : lam.rowLen i - 1 ≤ s ⟨i, hi⟩ := + (mem_colStripVecs hs ⟨i, hi⟩).1 + omega + · rw [rowLen_eq_zero_of_ge lam (by omega)] + omega + · intro mu hmu + refine ⟨YoungDiagram.card_le_card hmu.1, ?_, ?_⟩ + · rw [YoungDiagram.length_rowLens] + exact colLen_le_of_le hmu.1 0 + · rw [colStripVecs, Finset.mem_filter] + constructor + · rw [Fintype.mem_piFinset] + intro i + rw [Finset.mem_Icc] + have h1 := hmu.2 (i : ℕ) + have h2 := rowLen_mono hmu.1 (i : ℕ) + omega + · intro i hi + exact mu.rowLen_anti i (i + 1) (by omega) + +/-! ### The multiplicity Pieri rules + +Splitting `t + superPS 1 0` through `diagramSchur_add` collapses +the second tensor factor to the one-row shape; comparing with the +determinant identity through the graded linear independence reads +off the induction multiplicities. -/ + +/-- Pairing a coefficient family against the one-row indicator +collapses the shape sum to the one-row shape. -/ +private theorem sum_shape_superPS_row {b : ℕ} (G : Shape b → ℂ) : + ∑ ν : Shape b, G ν * diagramSchur ν.val (superPS 1 0) = + G (rowShape b) := by + rw [Finset.sum_congr rfl fun ν _ => by + rw [diagramSchur_superPS_row ν.val]] + rw [Finset.sum_eq_single (rowShape b) + (fun ν _ hne => by + rw [ite_eq_right (fun hle => hne (shape_eq_rowShape ν hle)), + mul_zero]) + (fun h => absurd (Finset.mem_univ _) h)] + rw [ite_eq_left (rowShape_colLen b), mul_one] + +/-- Pairing a coefficient family against the one-column indicator +collapses the shape sum to the one-column shape. -/ +private theorem sum_shape_superPS_col {b : ℕ} (G : Shape b → ℂ) : + ∑ ν : Shape b, G ν * diagramSchur ν.val (superPS 0 1) = + G (colShape b) := by + rw [Finset.sum_congr rfl fun ν _ => by + rw [diagramSchur_superPS_col ν.val]] + rw [Finset.sum_eq_single (colShape b) + (fun ν _ hne => by + rw [ite_eq_right (fun hle => hne (shape_eq_colShape ν hle)), + mul_zero]) + (fun h => absurd (Finset.mem_univ _) h)] + rw [ite_eq_left (colShape_rowLen_zero_le b), mul_one] + +/-- Transport of induction multiplicities along an equality of the +second size. -/ +private theorem indMult_congr {a b b' : ℕ} (h : b = b') + (lam : Shape (a + b)) (lam' : Shape (a + b')) + (hl : lam.val = lam'.val) (μ : Shape a) + (ν : Shape b) (ν' : Shape b') (hν : ν.val = ν'.val) : + indMult lam μ ν = indMult lam' μ ν' := by + subst h + rw [Shape.ext hl, Shape.ext hν] + +/-- The additive splitting at `t + superPS 1 0`, with the one-row +collapse and the antidiagonal reindexed over sizes. -/ +private theorem diagramSchur_add_superPS_row_expand {n : ℕ} + (lam : Shape n) (t : ℕ → ℂ) : + diagramSchur lam.val (fun c => t c + superPS 1 0 c) = + ∑ k ∈ Finset.range (n + 1), ∑ κ : Shape k, + (if h : k ≤ n then + indMult (⟨lam.val, by rw [lam.prop]; omega⟩ : + Shape (k + (n - k))) κ (rowShape (n - k)) + else 0) * diagramSchur κ.val t := by + rw [diagramSchur_add lam.val t (superPS 1 0)] + rw [Finset.sum_congr rfl fun ab _ => Finset.sum_congr rfl + fun κ _ => sum_shape_superPS_row (fun ν => + indMult ⟨lam.val, (Finset.mem_antidiagonal.mp ab.2).symm⟩ + κ ν * diagramSchur κ.val t)] + refine Finset.sum_bij' + (i := fun ab _ => ab.1.1) + (j := fun k hk => (⟨(k, lam.val.card - k), + Finset.mem_antidiagonal.mpr (by + have h1 := lam.prop + have h2 := Finset.mem_range.mp hk + omega)⟩ : + {x // x ∈ Finset.antidiagonal lam.val.card})) + ?_ ?_ ?_ ?_ ?_ + · intro ab _ + have h1 := Finset.mem_antidiagonal.mp ab.2 + have h2 := lam.prop + exact Finset.mem_range.mpr (by omega) + · intro k _ + exact Finset.mem_attach _ _ + · intro ab _ + have h1 := Finset.mem_antidiagonal.mp ab.2 + have h2 : lam.val.card - ab.1.1 = ab.1.2 := by omega + exact Subtype.ext (show (ab.1.1, lam.val.card - ab.1.1) = ab.1 + from by rw [h2]) + · intro k _ + rfl + · intro ab _ + refine Finset.sum_congr rfl fun κ _ => ?_ + have h1 := Finset.mem_antidiagonal.mp ab.2 + have h2 := lam.prop + rw [dite_eq_left (show ab.1.1 ≤ n by omega)] + congr 1 + exact indMult_congr (show ab.1.2 = n - ab.1.1 by omega) + _ _ rfl κ _ _ + (congrArg (fun x => (rowShape x).val) + (show ab.1.2 = n - ab.1.1 by omega)) + +/-- The additive splitting at `t + superPS 0 1`, with the +one-column collapse and the antidiagonal reindexed over sizes. -/ +private theorem diagramSchur_add_superPS_col_expand {n : ℕ} + (lam : Shape n) (t : ℕ → ℂ) : + diagramSchur lam.val (fun c => t c + superPS 0 1 c) = + ∑ k ∈ Finset.range (n + 1), ∑ κ : Shape k, + (if h : k ≤ n then + indMult (⟨lam.val, by rw [lam.prop]; omega⟩ : + Shape (k + (n - k))) κ (colShape (n - k)) + else 0) * diagramSchur κ.val t := by + rw [diagramSchur_add lam.val t (superPS 0 1)] + rw [Finset.sum_congr rfl fun ab _ => Finset.sum_congr rfl + fun κ _ => sum_shape_superPS_col (fun ν => + indMult ⟨lam.val, (Finset.mem_antidiagonal.mp ab.2).symm⟩ + κ ν * diagramSchur κ.val t)] + refine Finset.sum_bij' + (i := fun ab _ => ab.1.1) + (j := fun k hk => (⟨(k, lam.val.card - k), + Finset.mem_antidiagonal.mpr (by + have h1 := lam.prop + have h2 := Finset.mem_range.mp hk + omega)⟩ : + {x // x ∈ Finset.antidiagonal lam.val.card})) + ?_ ?_ ?_ ?_ ?_ + · intro ab _ + have h1 := Finset.mem_antidiagonal.mp ab.2 + have h2 := lam.prop + exact Finset.mem_range.mpr (by omega) + · intro k _ + exact Finset.mem_attach _ _ + · intro ab _ + have h1 := Finset.mem_antidiagonal.mp ab.2 + have h2 : lam.val.card - ab.1.1 = ab.1.2 := by omega + exact Subtype.ext (show (ab.1.1, lam.val.card - ab.1.1) = ab.1 + from by rw [h2]) + · intro k _ + rfl + · intro ab _ + refine Finset.sum_congr rfl fun κ _ => ?_ + have h1 := Finset.mem_antidiagonal.mp ab.2 + have h2 := lam.prop + rw [dite_eq_left (show ab.1.1 ≤ n by omega)] + congr 1 + exact indMult_congr (show ab.1.2 = n - ab.1.1 by omega) + _ _ rfl κ _ _ + (congrArg (fun x => (colShape x).val) + (show ab.1.2 = n - ab.1.1 by omega)) + +/-! ### Hook positivity + +Building a diagram avoiding `(p, q)` by strips: the first `p` rows +are grown one horizontal strip per new even variable, the columns +of the remainder one vertical strip per new odd variable. Every +term of the strip expansions is a natural number, and the specific +strip term is positive by induction, so the total is positive. -/ + +/-- A finite sum of natural values with one positive distinguished +term is a positive natural value. -/ +private theorem exists_pos_nat_sum {ι : Type*} (s : Finset ι) + (f : ι → ℂ) (hnat : ∀ i ∈ s, ∃ m : ℕ, f i = m) (i₀ : ι) + (hi₀ : i₀ ∈ s) (hpos : ∃ m : ℕ, 0 < m ∧ f i₀ = m) : + ∃ M : ℕ, 0 < M ∧ ∑ i ∈ s, f i = M := by + classical + obtain ⟨m, hm, hfm⟩ := hpos + obtain ⟨M', hM'⟩ := exists_nat_sum (s.erase i₀) f + (fun i hi => hnat i (Finset.mem_of_mem_erase hi)) + refine ⟨m + M', by omega, ?_⟩ + rw [← Finset.add_sum_erase s f hi₀, hfm, hM'] + push_cast + ring + +/-- **The rows phase**: a diagram with at most `p` rows has a +positive natural Schur value at `superPS p 0`. -/ +private theorem diagramSchur_superPS_pos_rows : + ∀ (p : ℕ) (lam : YoungDiagram), lam.colLen 0 ≤ p → + ∃ m : ℕ, 0 < m ∧ diagramSchur lam (superPS p 0) = m := by + intro p + induction p with + | zero => + intro lam hlam + refine ⟨1, Nat.one_pos, ?_⟩ + rw [diagramSchur_eq_det_rowLen lam (k := 0) (by omega) _] + rw [Matrix.det_isEmpty, Nat.cast_one] + | succ p ih => + intro lam hlam + classical + have hsplit : superPS (p + 1) 0 = + fun c => superPS p 0 c + superPS 1 0 c := + (superPS_add p 0 1 0).symm + rw [hsplit, diagramSchur_add_one_row lam (superPS p 0)] + -- the beheaded diagram: delete the first row + set r₀ : Fin lam.rowLens.length → ℕ := + fun i => lam.rowLen ((i : ℕ) + 1) with hr₀ + have hanti₀ : ∀ i j : Fin lam.rowLens.length, i ≤ j → + r₀ j ≤ r₀ i := + fun i j hij => lam.rowLen_anti _ _ (Nat.succ_le_succ hij) + have hstrip : IsHStrip lam (stripDiagram r₀) := by + constructor + · refine le_of_rowLen_le fun i => ?_ + rcases Nat.lt_or_ge i lam.rowLens.length with hi | hi + · rw [stripDiagram_rowLen_lt hanti₀ ⟨i, hi⟩] + exact lam.rowLen_anti i (i + 1) (by omega) + · rw [stripDiagram_rowLen_le hanti₀ hi] + omega + · intro i + rcases Nat.lt_or_ge i lam.rowLens.length with hi | hi + · rw [stripDiagram_rowLen_lt hanti₀ ⟨i, hi⟩] + · rw [stripDiagram_rowLen_le hanti₀ hi, + rowLen_eq_zero_of_ge lam (by omega)] + have hcol : (stripDiagram r₀).colLen 0 ≤ p := by + have hrp : (stripDiagram r₀).rowLen p = 0 := by + rcases Nat.lt_or_ge p lam.rowLens.length with hp | hp + · rw [stripDiagram_rowLen_lt hanti₀ ⟨p, hp⟩] + refine rowLen_eq_zero_of_ge lam ?_ + change lam.rowLens.length ≤ p + 1 + have hl := YoungDiagram.length_rowLens (μ := lam) + omega + · exact stripDiagram_rowLen_le hanti₀ hp + by_contra hlt + have hmem : (p, 0) ∈ stripDiagram r₀ := + YoungDiagram.mem_iff_lt_colLen.mpr (by omega) + rw [YoungDiagram.mem_iff_lt_rowLen] at hmem + omega + obtain ⟨m₀, hm₀, hval₀⟩ := ih (stripDiagram r₀) hcol + -- positivity of the graded sum through the strip term + refine exists_pos_nat_sum _ _ ?_ (stripDiagram r₀).card ?_ ?_ + · intro k _ + refine exists_nat_sum _ _ fun μ _ => ?_ + by_cases hμ : IsHStrip lam μ.val + · rw [ite_eq_left hμ, one_mul] + exact diagramSchur_superPS_exists_nat p 0 μ.val + · rw [ite_eq_right hμ, zero_mul] + exact ⟨0, by simp⟩ + · exact Finset.mem_range.mpr + (Nat.lt_succ_of_le (YoungDiagram.card_le_card hstrip.1)) + · refine exists_pos_nat_sum _ _ ?_ + (⟨stripDiagram r₀, rfl⟩ : Shape (stripDiagram r₀).card) + (Finset.mem_univ _) ?_ + · intro μ _ + by_cases hμ : IsHStrip lam μ.val + · rw [ite_eq_left hμ, one_mul] + exact diagramSchur_superPS_exists_nat p 0 μ.val + · rw [ite_eq_right hμ, zero_mul] + exact ⟨0, by simp⟩ + · refine ⟨m₀, hm₀, ?_⟩ + change (if IsHStrip lam (stripDiagram r₀) then (1 : ℂ) + else 0) * diagramSchur (stripDiagram r₀) + (superPS p 0) = (m₀ : ℂ) + rw [ite_eq_left hstrip, one_mul, hval₀] + +/-- **Hook positivity** (Deligne 1.9, nonvanishing direction, +character side): the Schur specialisation at the super power sums +of dimension `(p, q)` of any diagram avoiding the cell `(p, q)` is +a positive natural number. -/ +theorem diagramSchur_superPS_pos {p q : ℕ} (lam : YoungDiagram) + (hcell : (p, q) ∉ lam) : + ∃ m : ℕ, 0 < m ∧ diagramSchur lam (superPS p q) = m := by + induction q generalizing lam with + | zero => + have hcol : lam.colLen 0 ≤ p := by + rw [YoungDiagram.mem_iff_lt_colLen] at hcell + omega + exact diagramSchur_superPS_pos_rows p lam hcol + | succ q ih => + classical + have hrow : lam.rowLen p ≤ q + 1 := by + rw [YoungDiagram.mem_iff_lt_rowLen] at hcell + omega + have hsplit : superPS p (q + 1) = + fun c => superPS p q c + superPS 0 1 c := + (superPS_add p q 0 1).symm + rw [hsplit, diagramSchur_add_one_col lam (superPS p q)] + -- the trimmed diagram: shave one cell off each long row + set r₁ : Fin lam.rowLens.length → ℕ := + fun i => if q < lam.rowLen (i : ℕ) then + lam.rowLen (i : ℕ) - 1 else lam.rowLen (i : ℕ) with hr₁ + have hanti₁ : ∀ i j : Fin lam.rowLens.length, i ≤ j → + r₁ j ≤ r₁ i := by + intro i j hij + have h := lam.rowLen_anti (i : ℕ) (j : ℕ) hij + change (if q < lam.rowLen (j : ℕ) then lam.rowLen (j : ℕ) - 1 + else lam.rowLen (j : ℕ)) ≤ + (if q < lam.rowLen (i : ℕ) then lam.rowLen (i : ℕ) - 1 + else lam.rowLen (i : ℕ)) + split_ifs <;> omega + have hstrip : IsVStrip lam (stripDiagram r₁) := by + constructor + · refine le_of_rowLen_le fun i => ?_ + rcases Nat.lt_or_ge i lam.rowLens.length with hi | hi + · rw [stripDiagram_rowLen_lt hanti₁ ⟨i, hi⟩] + change (if q < lam.rowLen i then lam.rowLen i - 1 + else lam.rowLen i) ≤ lam.rowLen i + split_ifs <;> omega + · rw [stripDiagram_rowLen_le hanti₁ hi] + omega + · intro i + rcases Nat.lt_or_ge i lam.rowLens.length with hi | hi + · rw [stripDiagram_rowLen_lt hanti₁ ⟨i, hi⟩] + change lam.rowLen i ≤ (if q < lam.rowLen i then + lam.rowLen i - 1 else lam.rowLen i) + 1 + split_ifs <;> omega + · rw [stripDiagram_rowLen_le hanti₁ hi, + rowLen_eq_zero_of_ge lam (by omega)] + omega + have hnotmem : (p, q) ∉ stripDiagram r₁ := by + have hval : (stripDiagram r₁).rowLen p ≤ q := by + rcases Nat.lt_or_ge p lam.rowLens.length with hp | hp + · rw [stripDiagram_rowLen_lt hanti₁ ⟨p, hp⟩] + change (if q < lam.rowLen p then lam.rowLen p - 1 + else lam.rowLen p) ≤ q + split_ifs <;> omega + · rw [stripDiagram_rowLen_le hanti₁ hp] + omega + intro hmem + rw [YoungDiagram.mem_iff_lt_rowLen] at hmem + omega + obtain ⟨m₀, hm₀, hval₀⟩ := ih (stripDiagram r₁) hnotmem + refine exists_pos_nat_sum _ _ ?_ (stripDiagram r₁).card ?_ ?_ + · intro k _ + refine exists_nat_sum _ _ fun μ _ => ?_ + by_cases hμ : IsVStrip lam μ.val + · rw [ite_eq_left hμ, one_mul] + exact diagramSchur_superPS_exists_nat p q μ.val + · rw [ite_eq_right hμ, zero_mul] + exact ⟨0, by simp⟩ + · exact Finset.mem_range.mpr + (Nat.lt_succ_of_le (YoungDiagram.card_le_card hstrip.1)) + · refine exists_pos_nat_sum _ _ ?_ + (⟨stripDiagram r₁, rfl⟩ : Shape (stripDiagram r₁).card) + (Finset.mem_univ _) ?_ + · intro μ _ + by_cases hμ : IsVStrip lam μ.val + · rw [ite_eq_left hμ, one_mul] + exact diagramSchur_superPS_exists_nat p q μ.val + · rw [ite_eq_right hμ, zero_mul] + exact ⟨0, by simp⟩ + · refine ⟨m₀, hm₀, ?_⟩ + change (if IsVStrip lam (stripDiagram r₁) then (1 : ℂ) + else 0) * diagramSchur (stripDiagram r₁) + (superPS p q) = (m₀ : ℂ) + rw [ite_eq_left hstrip, one_mul, hval₀] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PlainShuffle.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PlainShuffle.lean new file mode 100644 index 0000000000..b17977798f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PlainShuffle.lean @@ -0,0 +1,97 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedDiag + +/-! +# The plain diagonal shuffle and its equivariance + +The diagonal shuffle `(X ⊗ Y) ^ ⊗ n ≅ X ^ ⊗ n ⊗ Y ^ ⊗ n` re-sorts a +tensor power of a tensor product: the empty power is the inverse +unitor, and each step of the recursion is the middle-four +interchange `tensorμ`, inverted by `tensorδ`. The shuffle is +equivariant for the symmetric-group actions: the diagonal action of +a permutation on the `(X ⊗ Y)`-factors passes through it to the +simultaneous action on the two plain powers. + +The isomorphism and its intertwining are carried by the distribution +isomorphism `tensorPowDistrib` of `Deligne/MixedDiag.lean`, whose +top-braiding square reduces to the componentwise braidings through +Mathlib's `tensor_associativity`, and whose functoriality follows +the recursions of `insertTop` and `permMor`. This module presents +the shuffle under its own name, with the defining recursion +equations on both the forward and the inverse maps and the +equivariance statements in the form the plain tensor-power calculus +consumes. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +variable {D : Type u} + +/-- **The plain diagonal shuffle** +`(X ⊗ Y) ^ ⊗ n ≅ X ^ ⊗ n ⊗ Y ^ ⊗ n`: the empty power is the inverse +unitor, and each further step of the recursion is the middle-four +interchange `tensorμ`, inverted by `tensorδ`. It is the +distribution isomorphism `tensorPowDistrib`, under the shuffle's +own name. -/ +noncomputable def plainShuffle + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (X Y : D) (n : ℕ) : + tensorPow D (X ⊗ Y) n ≅ tensorPow D X n ⊗ tensorPow D Y n := + tensorPowDistrib X Y n + +/-- The empty shuffle is the inverse unitor. -/ +@[simp] +theorem plainShuffle_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (X Y : D) : + plainShuffle X Y 0 = (λ_ (𝟙_ D)).symm := rfl + +/-- The defining recursion of the shuffle, on the forward maps: the +lower factors are shuffled and the newest `(X ⊗ Y)`-pair is routed +to its two destinations by the interchange. -/ +@[simp] +theorem plainShuffle_succ_hom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (X Y : D) (n : ℕ) : + (plainShuffle X Y (n + 1)).hom = + ((plainShuffle X Y n).hom ▷ (X ⊗ Y)) ≫ + tensorμ (tensorPow D X n) (tensorPow D Y n) X Y := rfl + +/-- The defining recursion of the shuffle, on the inverse maps: the +newest pair is split off by the inverse interchange and the lower +factors are unshuffled. -/ +@[simp] +theorem plainShuffle_succ_inv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (X Y : D) (n : ℕ) : + (plainShuffle X Y (n + 1)).inv = + tensorδ (tensorPow D X n) (tensorPow D Y n) X Y ≫ + ((plainShuffle X Y n).inv ▷ (X ⊗ Y)) := rfl + +/-- **Permutation equivariance of the plain shuffle**: the diagonal +action of a permutation on `(X ⊗ Y) ^ ⊗ n` passes through the +shuffle to its simultaneous action on the two plain tensor +powers. -/ +theorem plainShuffle_permMor + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (X Y : D) (n : ℕ) + (σ : Equiv.Perm (Fin n)) : + permMor (X ⊗ Y) n σ ≫ (plainShuffle X Y n).hom = + (plainShuffle X Y n).hom ≫ + (permMor X n σ ⊗ₘ permMor Y n σ) := + tensorPowDistrib_permMor X Y n σ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointBaseChange.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointBaseChange.lean new file mode 100644 index 0000000000..419ce48f0c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointBaseChange.lean @@ -0,0 +1,477 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairAdd +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShiftUnit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperPointMod + +/-! +# Base change of a free super module to a complex point + +Tensoring a super module with the residue module of a complex point +(`RS.SuperCommAlgebra.pointMod`) is base change along that point. +This file computes the base change of a free super module of rank +`(p | q)` and records that the answer is a finite-dimensional super +vector space of the same rank. + +The computation is pure additivity. Tensoring on the right by a +fixed module is an additive functor, so it carries a finite +biproduct to a finite biproduct; the two summands of a free module +are the unit and its parity shift, and tensoring either of them +with the residue module is already known — the unit case is the +left unitor and the shifted case is +`RS.SuperCommAlgebra.Mod.shiftUnitTensor`. What is left is a +biproduct of `p` copies of the residue module and `q` copies of its +parity shift, whose even part has dimension `p` and whose odd part +has dimension `q`. + +Finite-dimensionality is read off through the two component +functors to complex vector spaces. Taking the even part, or the +odd part, of a super module is an additive functor to `ModuleCat ℂ`, +so it turns the abstract biproduct of super modules into the +concrete product of the component spaces, and a finite product of +finite-dimensional spaces is finite-dimensional. + +## Contents + +* `RS.SuperCommAlgebra.Mod.evenModFunctor`, `oddModFunctor`: the two + component functors, and their additivity. +* `RS.SuperCommAlgebra.Mod.evenBiproductEquiv`, `oddBiproductEquiv`: + the component of a finite biproduct is the product of the + components. +* `RS.SuperCommAlgebra.Mod.tensorRightFunctor`: tensoring on the + right by a fixed module, as an additive functor. +* `RS.unitTensorPoint`, `RS.shiftTensorPoint`: base change of the + unit and of its parity shift. +* `RS.freeTensorPoint`: base change of a free module of rank + `(p | q)`. +* `RS.finiteDimensional_even_of_free`, + `RS.finiteDimensional_odd_of_free`: finite-dimensionality of the + base change of a free module. +* `RS.finrank_even_of_free`, `RS.finrank_odd_of_free`: the two + dimensions are `p` and `q`. +* `RS.toSuperVect`: the base change packaged as a super vector + space, with `RS.toSuperVectEvenEquiv`, `toSuperVectOddEquiv` and + the two explicit coordinate equivalences + `RS.freeEvenEquivFin`, `freeOddEquivFin`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Limits + +universe u + +namespace SuperCommAlgebra.Mod + +variable {S : SuperCommAlgebra.{u, u}} + +/-! ## The two component functors -/ + +/-- **The even component as a functor** to complex vector spaces. -/ +noncomputable def evenModFunctor (S : SuperCommAlgebra.{u, u}) : + S.Mod.{u, u, u, u} ⥤ ModuleCat.{u} ℂ where + obj M := ModuleCat.of ℂ M.even + map f := ModuleCat.ofHom f.evenMap + map_id _ := rfl + map_comp _ _ := rfl + +/-- **The odd component as a functor** to complex vector spaces. -/ +noncomputable def oddModFunctor (S : SuperCommAlgebra.{u, u}) : + S.Mod.{u, u, u, u} ⥤ ModuleCat.{u} ℂ where + obj M := ModuleCat.of ℂ M.odd + map f := ModuleCat.ofHom f.oddMap + map_id _ := rfl + map_comp _ _ := rfl + +/-- The even component functor is additive. -/ +instance evenModFunctor_additive (S : SuperCommAlgebra.{u, u}) : + (evenModFunctor S).Additive where + map_add := rfl + +/-- The odd component functor is additive. -/ +instance oddModFunctor_additive (S : SuperCommAlgebra.{u, u}) : + (oddModFunctor S).Additive where + map_add := rfl + +/-- An isomorphism of super modules is a linear equivalence on even +components. -/ +noncomputable def evenEquiv {M N : S.Mod.{u, u, u, u}} (e : M ≅ N) : + M.even ≃ₗ[ℂ] N.even := + ((evenModFunctor S).mapIso e).toLinearEquiv + +/-- An isomorphism of super modules is a linear equivalence on odd +components. -/ +noncomputable def oddEquiv {M N : S.Mod.{u, u, u, u}} (e : M ≅ N) : + M.odd ≃ₗ[ℂ] N.odd := + ((oddModFunctor S).mapIso e).toLinearEquiv + +/-! ## Components of a finite biproduct -/ + +/-- **The even component of a finite biproduct** is the product of +the even components. -/ +noncomputable def evenBiproductEquiv {J : Type} [Fintype J] + (g : J → S.Mod.{u, u, u, u}) : + (⨁ g).even ≃ₗ[ℂ] ∀ j, (g j).even := + (((evenModFunctor S).mapBiproduct g).trans + (ModuleCat.biproductIsoPi _)).toLinearEquiv + +/-- **The odd component of a finite biproduct** is the product of +the odd components. -/ +noncomputable def oddBiproductEquiv {J : Type} [Fintype J] + (g : J → S.Mod.{u, u, u, u}) : + (⨁ g).odd ≃ₗ[ℂ] ∀ j, (g j).odd := + (((oddModFunctor S).mapBiproduct g).trans + (ModuleCat.biproductIsoPi _)).toLinearEquiv + +/-! ## Tensoring on the right -/ + +/-- **Tensoring on the right by a fixed module**, as a functor. -/ +noncomputable def tensorRightFunctor (N : S.Mod.{u, u, u, u}) : + S.Mod.{u, u, u, u} ⥤ S.Mod.{u, u, u, u} where + obj M := M.tensor N + map f := tensorHom f (𝟙 N) + map_id M := tensorHom_id M N + map_comp f g := by + rw [← tensorHom_comp f g (𝟙 N) (𝟙 N), Category.comp_id] + +@[simp] theorem tensorRightFunctor_obj (N M : S.Mod.{u, u, u, u}) : + (tensorRightFunctor N).obj M = M.tensor N := rfl + +/-- Tensoring on the right by a fixed module is additive: this is +additivity of the tensor product in the left variable. -/ +instance tensorRightFunctor_additive (N : S.Mod.{u, u, u, u}) : + (tensorRightFunctor N).Additive where + map_add {_ _ f g} := tensorHom_add_left f g (𝟙 N) + +end SuperCommAlgebra.Mod + +open SuperCommAlgebra SuperCommAlgebra.Mod + +variable {S : SuperCommAlgebra.{u, u}} + +/-! ## Base change of the two free generators -/ + +/-- **Base change of the unit module**: tensoring the unit with the +residue module of a point returns the residue module. This is the +left unitor. -/ +noncomputable def unitTensorPoint (P : SuperPoint S) : + (S.unitMod.tensor (pointMod P) : S.Mod.{u, u, u, u}) ≅ + pointMod P := + leftUnitor (pointMod P) + +/-- **Base change of the shifted unit module**: tensoring the parity +shift of the unit with the residue module of a point returns the +parity shift of the residue module. -/ +noncomputable def shiftTensorPoint (P : SuperPoint S) : + ((shift S.unitMod).tensor (pointMod P) : S.Mod.{u, u, u, u}) ≅ + shift (pointMod P) := + shiftUnitTensor (pointMod P) + +/-! ## Base change of a free module -/ + +/-- **Base change of a free super module of rank `(p | q)`**: the +result is the biproduct of `p` copies of the residue module and `q` +copies of its parity shift. Tensoring on the right is additive, so +it carries the defining biproduct across, and the two summands are +handled by `RS.unitTensorPoint` and `RS.shiftTensorPoint`. -/ +noncomputable def freeTensorPoint (P : SuperPoint S) (p q : ℕ) : + ((⨁ fun i : Fin p ⊕ Fin q => + Sum.elim (fun _ => S.unitMod) + (fun _ => shift S.unitMod) i).tensor + (pointMod P) : S.Mod.{u, u, u, u}) ≅ + ⨁ fun i : Fin p ⊕ Fin q => + Sum.elim (fun _ => pointMod P) + (fun _ => shift (pointMod P)) i := + (tensorRightFunctor (pointMod P)).mapBiproduct + (fun i : Fin p ⊕ Fin q => + Sum.elim (fun _ => S.unitMod) + (fun _ => shift S.unitMod) i) ≪≫ + biproduct.mapIso fun i => + match i with + | Sum.inl _ => unitTensorPoint P + | Sum.inr _ => shiftTensorPoint P + +/-! ## The residue module is one-dimensional in even degree -/ + +/-- The even part of the residue module of a point is +finite-dimensional: it is a copy of the complex numbers. -/ +instance finiteDimensional_pointMod_even (P : SuperPoint S) : + FiniteDimensional ℂ (pointMod P : S.Mod.{u, u, u, u}).even := + (inferInstance : FiniteDimensional ℂ (ULift.{u} ℂ)) + +/-- The odd part of the residue module of a point is +finite-dimensional: it is zero. -/ +instance finiteDimensional_pointMod_odd (P : SuperPoint S) : + FiniteDimensional ℂ (pointMod P : S.Mod.{u, u, u, u}).odd := + (inferInstance : FiniteDimensional ℂ (ULift.{u} PUnit.{1})) + +/-- The even part of the residue module of a point is +one-dimensional. -/ +theorem finrank_pointMod_even (P : SuperPoint S) : + Module.finrank ℂ (pointMod P : S.Mod.{u, u, u, u}).even = 1 := by + change Module.finrank ℂ (ULift.{u} ℂ) = 1 + rw [LinearEquiv.finrank_eq (ULift.moduleEquiv (R := ℂ) (M := ℂ)), + Module.finrank_self] + +/-- The odd part of the residue module of a point is zero. -/ +theorem finrank_pointMod_odd (P : SuperPoint S) : + Module.finrank ℂ (pointMod P : S.Mod.{u, u, u, u}).odd = 0 := + Module.finrank_eq_zero_of_subsingleton ℂ (ULift.{u} PUnit.{1}) + +/-! ## The biproduct of residue modules -/ + +/-- The family of summands of the base change of a free module of +rank `(p | q)`: `p` copies of the residue module of the point and +`q` copies of its parity shift. -/ +noncomputable def residueShape (P : SuperPoint S) (p q : ℕ) : + Fin p ⊕ Fin q → S.Mod.{u, u, u, u} := fun i => + Sum.elim (fun _ => pointMod P) (fun _ => shift (pointMod P)) i + +/-- Every summand has finite-dimensional even part. -/ +instance finiteDimensional_residueShape_even (P : SuperPoint S) + (p q : ℕ) (i : Fin p ⊕ Fin q) : + FiniteDimensional ℂ (residueShape P p q i).even := by + cases i with + | inl _ => exact finiteDimensional_pointMod_even P + | inr _ => exact finiteDimensional_pointMod_odd P + +/-- Every summand has finite-dimensional odd part. -/ +instance finiteDimensional_residueShape_odd (P : SuperPoint S) + (p q : ℕ) (i : Fin p ⊕ Fin q) : + FiniteDimensional ℂ (residueShape P p q i).odd := by + cases i with + | inl _ => exact finiteDimensional_pointMod_odd P + | inr _ => exact finiteDimensional_pointMod_even P + +/-- The even part of the biproduct of residue modules is +finite-dimensional. -/ +instance finiteDimensional_biproduct_even (P : SuperPoint S) + (p q : ℕ) : + FiniteDimensional ℂ (⨁ residueShape P p q).even := + (evenBiproductEquiv (residueShape P p q)).symm.finiteDimensional + +/-- The odd part of the biproduct of residue modules is +finite-dimensional. -/ +instance finiteDimensional_biproduct_odd (P : SuperPoint S) + (p q : ℕ) : + FiniteDimensional ℂ (⨁ residueShape P p q).odd := + (oddBiproductEquiv (residueShape P p q)).symm.finiteDimensional + +/-- The even part of the biproduct of residue modules has +dimension `p`. -/ +theorem finrank_biproduct_even (P : SuperPoint S) (p q : ℕ) : + Module.finrank ℂ (⨁ residueShape P p q).even = p := by + rw [LinearEquiv.finrank_eq (evenBiproductEquiv (residueShape P p q)), + Module.finrank_pi_fintype ℂ, Fintype.sum_sum_type] + have h₁ : ∀ a : Fin p, + Module.finrank ℂ (residueShape P p q (Sum.inl a)).even = 1 := + fun _ => finrank_pointMod_even P + have h₂ : ∀ b : Fin q, + Module.finrank ℂ (residueShape P p q (Sum.inr b)).even = 0 := + fun _ => finrank_pointMod_odd P + rw [Finset.sum_congr rfl fun a _ => h₁ a, + Finset.sum_congr rfl fun b _ => h₂ b] + simp + +/-- The odd part of the biproduct of residue modules has +dimension `q`. -/ +theorem finrank_biproduct_odd (P : SuperPoint S) (p q : ℕ) : + Module.finrank ℂ (⨁ residueShape P p q).odd = q := by + rw [LinearEquiv.finrank_eq (oddBiproductEquiv (residueShape P p q)), + Module.finrank_pi_fintype ℂ, Fintype.sum_sum_type] + have h₁ : ∀ a : Fin p, + Module.finrank ℂ (residueShape P p q (Sum.inl a)).odd = 0 := + fun _ => finrank_pointMod_odd P + have h₂ : ∀ b : Fin q, + Module.finrank ℂ (residueShape P p q (Sum.inr b)).odd = 1 := + fun _ => finrank_pointMod_even P + rw [Finset.sum_congr rfl fun a _ => h₁ a, + Finset.sum_congr rfl fun b _ => h₂ b] + simp + +/-! ## Base change of a module known to be free -/ + +/-- **The base change of a free module of rank `(p | q)`**, in the +form used below: a module isomorphic to a free module of rank +`(p | q)` has base change the biproduct of residue modules. -/ +noncomputable def tensorPointIso (P : SuperPoint S) (p q : ℕ) + (M : S.Mod.{u, u, u, u}) + (e : M ≅ ⨁ fun i : Fin p ⊕ Fin q => + Sum.elim (fun _ => S.unitMod) + (fun _ => shift S.unitMod) i) : + M.tensor (pointMod P) ≅ ⨁ residueShape P p q := + (tensorRightFunctor (pointMod P)).mapIso e ≪≫ freeTensorPoint P p q + +/-- **The base change of a free module of rank `(p | q)` has +finite-dimensional even part.** -/ +theorem finiteDimensional_even_of_free (P : SuperPoint S) (p q : ℕ) + (M : S.Mod.{u, u, u, u}) + (e : M ≅ ⨁ fun i : Fin p ⊕ Fin q => + Sum.elim (fun _ => S.unitMod) + (fun _ => shift S.unitMod) i) : + FiniteDimensional ℂ (M.tensor (pointMod P)).even := + (evenEquiv (tensorPointIso P p q M e)).symm.finiteDimensional + +/-- **The base change of a free module of rank `(p | q)` has +finite-dimensional odd part.** -/ +theorem finiteDimensional_odd_of_free (P : SuperPoint S) (p q : ℕ) + (M : S.Mod.{u, u, u, u}) + (e : M ≅ ⨁ fun i : Fin p ⊕ Fin q => + Sum.elim (fun _ => S.unitMod) + (fun _ => shift S.unitMod) i) : + FiniteDimensional ℂ (M.tensor (pointMod P)).odd := + (oddEquiv (tensorPointIso P p q M e)).symm.finiteDimensional + +/-- **The even dimension of the base change of a free module of +rank `(p | q)` is `p`.** -/ +theorem finrank_even_of_free (P : SuperPoint S) (p q : ℕ) + (M : S.Mod.{u, u, u, u}) + (e : M ≅ ⨁ fun i : Fin p ⊕ Fin q => + Sum.elim (fun _ => S.unitMod) + (fun _ => shift S.unitMod) i) : + Module.finrank ℂ (M.tensor (pointMod P)).even = p := by + rw [LinearEquiv.finrank_eq (evenEquiv (tensorPointIso P p q M e)), + finrank_biproduct_even] + +/-- **The odd dimension of the base change of a free module of +rank `(p | q)` is `q`.** -/ +theorem finrank_odd_of_free (P : SuperPoint S) (p q : ℕ) + (M : S.Mod.{u, u, u, u}) + (e : M ≅ ⨁ fun i : Fin p ⊕ Fin q => + Sum.elim (fun _ => S.unitMod) + (fun _ => shift S.unitMod) i) : + Module.finrank ℂ (M.tensor (pointMod P)).odd = q := by + rw [LinearEquiv.finrank_eq (oddEquiv (tensorPointIso P p q M e)), + finrank_biproduct_odd] + +/-! ## The super vector space of a base change -/ + +-- The finite-dimensionality instances pin the intended value, and +-- are the signature the two coordinate equivalences are stated at. +/-- **The base change of a super module along a point, packaged as a +super vector space.** The components of a super module live in an +arbitrary universe, while `RS.SuperVect` asks for types in `Type`, +so the packaging is by coordinates: each component is replaced by +the space of coordinate vectors of its dimension. The two +equivalences `RS.toSuperVectEvenEquiv` and `RS.toSuperVectOddEquiv` +identify the components of the base change with the components of +this super vector space. -/ +noncomputable def toSuperVect (P : SuperPoint S) + (M : S.Mod.{u, u, u, u}) + : + SuperVect where + even := Fin (Module.finrank ℂ (M.tensor (pointMod P)).even) → ℂ + odd := Fin (Module.finrank ℂ (M.tensor (pointMod P)).odd) → ℂ + +@[simp] theorem toSuperVect_even (P : SuperPoint S) + (M : S.Mod.{u, u, u, u}) + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] : + (toSuperVect P M).even = + (Fin (Module.finrank ℂ (M.tensor (pointMod P)).even) → ℂ) := + rfl + +@[simp] theorem toSuperVect_odd (P : SuperPoint S) + (M : S.Mod.{u, u, u, u}) + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] : + (toSuperVect P M).odd = + (Fin (Module.finrank ℂ (M.tensor (pointMod P)).odd) → ℂ) := + rfl + +/-- The even part of the base change is the even part of the super +vector space attached to it. -/ +noncomputable def toSuperVectEvenEquiv (P : SuperPoint S) + (M : S.Mod.{u, u, u, u}) + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] : + (M.tensor (pointMod P)).even ≃ₗ[ℂ] (toSuperVect P M).even := + (Module.finBasis ℂ (M.tensor (pointMod P)).even).equivFun + +/-- The odd part of the base change is the odd part of the super +vector space attached to it. -/ +noncomputable def toSuperVectOddEquiv (P : SuperPoint S) + (M : S.Mod.{u, u, u, u}) + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] : + (M.tensor (pointMod P)).odd ≃ₗ[ℂ] (toSuperVect P M).odd := + (Module.finBasis ℂ (M.tensor (pointMod P)).odd).equivFun + +/-! ## Explicit coordinates in the free case -/ + +/-- **Coordinates on the even part**: the base change of a free +module of rank `(p | q)` has even part the space of `p`-tuples of +complex numbers. -/ +noncomputable def freeEvenEquivFin (P : SuperPoint S) (p q : ℕ) + (M : S.Mod.{u, u, u, u}) + (e : M ≅ ⨁ fun i : Fin p ⊕ Fin q => + Sum.elim (fun _ => S.unitMod) + (fun _ => shift S.unitMod) i) : + (M.tensor (pointMod P)).even ≃ₗ[ℂ] (Fin p → ℂ) := + haveI := finiteDimensional_even_of_free P p q M e + (Module.finBasisOfFinrankEq ℂ (M.tensor (pointMod P)).even + (finrank_even_of_free P p q M e)).equivFun + +/-- **Coordinates on the odd part**: the base change of a free +module of rank `(p | q)` has odd part the space of `q`-tuples of +complex numbers. -/ +noncomputable def freeOddEquivFin (P : SuperPoint S) (p q : ℕ) + (M : S.Mod.{u, u, u, u}) + (e : M ≅ ⨁ fun i : Fin p ⊕ Fin q => + Sum.elim (fun _ => S.unitMod) + (fun _ => shift S.unitMod) i) : + (M.tensor (pointMod P)).odd ≃ₗ[ℂ] (Fin q → ℂ) := + haveI := finiteDimensional_odd_of_free P p q M e + (Module.finBasisOfFinrankEq ℂ (M.tensor (pointMod P)).odd + (finrank_odd_of_free P p q M e)).equivFun + +/-- **The super vector space of the base change of a free module of +rank `(p | q)`** has even part of dimension `p`. -/ +theorem finrank_toSuperVect_even_of_free (P : SuperPoint S) + (p q : ℕ) (M : S.Mod.{u, u, u, u}) + (e : M ≅ ⨁ fun i : Fin p ⊕ Fin q => + Sum.elim (fun _ => S.unitMod) + (fun _ => shift S.unitMod) i) + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] : + Module.finrank ℂ (toSuperVect P M).even = p := by + rw [← finrank_even_of_free P p q M e] + change Module.finrank ℂ + (Fin (Module.finrank ℂ (M.tensor (pointMod P)).even) → ℂ) = _ + rw [Module.finrank_fin_fun ℂ] + +/-- **The super vector space of the base change of a free module of +rank `(p | q)`** has odd part of dimension `q`. -/ +theorem finrank_toSuperVect_odd_of_free (P : SuperPoint S) + (p q : ℕ) (M : S.Mod.{u, u, u, u}) + (e : M ≅ ⨁ fun i : Fin p ⊕ Fin q => + Sum.elim (fun _ => S.unitMod) + (fun _ => shift S.unitMod) i) + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] : + Module.finrank ℂ (toSuperVect P M).odd = q := by + rw [← finrank_odd_of_free P p q M e] + change Module.finrank ℂ + (Fin (Module.finrank ℂ (M.tensor (pointMod P)).odd) → ℂ) = _ + rw [Module.finrank_fin_fun ℂ] + + +/-! ## Sealing the coordinates + +The two coordinate equivalences are chosen bases, and nothing below +should depend on how they were chosen. Sealing them keeps `simp` +from unfolding a base change into a composite of `Module.finBasis` +coordinates, which is what makes the coherence laws of the base +change unmanageable downstream. -/ + +attribute [irreducible] toSuperVectEvenEquiv toSuperVectOddEquiv + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointFibre.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointFibre.lean new file mode 100644 index 0000000000..ae0677a19f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointFibre.lean @@ -0,0 +1,824 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverComplex +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverSplitting + +/-! +# The fibre functor into super vector spaces + +Base change along a ℂ-point of the Γ-algebra turns each super +module into a finite-dimensional super vector space +(`RS.toSuperVect` of +[PointBaseChange.lean](PointBaseChange.lean)). This module +upgrades that assignment to a functor, records its exactness, and +assembles the fibre functor of Deligne's theorem out of the fibre +functor over a splitting algebra and a ℂ-point of its Γ-algebra. + +Three things are needed for the assembly and are established here. + +* *Super vector spaces are an abelian category.* A super vector + space is a `Bool`-indexed family of finite-dimensional complex + vector spaces, and a morphism is a family of linear maps, so + `RS.SuperVect` is equivalent to the category of functors from the + discrete category on `Bool` to `FGModuleCat ℂ`. That functor + category is abelian, and abelianness transports along an + equivalence. This is what lets the exactness criterion + `RS.preservesFiniteLimits_of_shortExact` be applied to a functor + landing in `RS.SuperVect`. + +* *Base change is functorial.* Tensoring with the residue module + of the point is a functor, and `RS.toSuperVect` replaces the two + components of the result by coordinate spaces of the same + dimensions; conjugating by the coordinate equivalences turns the + first into a functor to `RS.SuperVect`. The conjugation cancels + in a composite, which is functoriality, and is additive + componentwise, which is additivity. + +* *Exactness comes from freeness.* Every module in the image of + the fibre functor over a splitting algebra is free, so a short + exact sequence of them splits, and base change carries the + splitting across; a split short complex is short exact. + +Faithfulness is then automatic: the functor is exact, so it carries +the image factorisation of a morphism to an image factorisation, +and an object whose fibre vanishes has both mixed ranks zero, hence +zero fibre already over the algebra, hence — the unit of the +algebra being a monomorphism — vanishes itself. + +## Contents + +* `RS.superVectComponents`, `RS.superVectAbelian`: the equivalence + with the diagram category, and the abelian structure it + transports. +* `RS.SuperCommAlgebra.Mod.instLinear`, + `RS.SuperCommAlgebra.Mod.tensorHom_smul_left`: the ℂ-linear + structure of the super modules, and ℂ-linearity of the tensor + product in the left variable. +* `RS.superVectHom`: base change of a morphism of super modules, + with `RS.superVectHom_id`, `superVectHom_comp`, `superVectHom_add` + and `superVectHom_smul`. +* `RS.superVectFunctor`: the base-change functor at a ℂ-point, with + `RS.superVectFunctor_additive` and + `RS.superVectFunctor_linear`. +* `RS.finrank_superVectFunctor_even`, `finrank_superVectFunctor_odd`: + the two dimensions of the base change of a free value. +* `RS.superVectSplitting`, `RS.superVectFunctor_shortExact`, + `RS.superVectFunctor_preservesFiniteLimits`, + `RS.superVectFunctor_preservesFiniteColimits`, + `RS.superVectFunctor_preservesHomology`: exactness. +* `RS.deligneFibre`: the fibre functor of a splitting algebra at a + point, with its additivity, exactness + (`RS.deligneFibre_preservesFiniteLimits`, + `deligneFibre_preservesFiniteColimits`) and faithfulness + (`RS.deligneFibre_faithful`). +* `RS.exists_deligneFibre_of_point`: the four properties packaged. +-/ + +@[expose] public section +namespace RS + +open CategoryTheory Limits +open SuperCommAlgebra (pointMod) +open SuperCommAlgebra.Mod + +universe u v₂ u₂ + +/-! ## Super vector spaces form an abelian category + +A super vector space is a `Bool`-indexed family of +finite-dimensional complex vector spaces, and a morphism is a +family of linear maps: the category is equivalent to the category +of functors from the discrete category on `Bool` to the +finite-dimensional complex vector spaces. That functor category is +abelian, so `RS.SuperVect` is abelian too. -/ + +section SuperVectAbelian + +/-- **The components of a super vector space**, as a functor to the +`Bool`-indexed diagrams of finite-dimensional complex vector +spaces. -/ +noncomputable def superVectComponents : + SuperVect ⥤ (Discrete Bool ⥤ FGModuleCat.{0} ℂ) where + obj V := Discrete.functor fun b => + cond b (FGModuleCat.of ℂ V.odd) (FGModuleCat.of ℂ V.even) + map f := Discrete.natTrans fun i => + match i with + | ⟨true⟩ => FGModuleCat.ofHom f.oddMap + | ⟨false⟩ => FGModuleCat.ofHom f.evenMap + map_id V := by + refine NatTrans.ext (funext fun i => ?_) + obtain ⟨b⟩ := i + cases b <;> rfl + map_comp f g := by + refine NatTrans.ext (funext fun i => ?_) + obtain ⟨b⟩ := i + cases b <;> rfl + +instance superVectComponents_faithful : superVectComponents.Faithful where + map_injective {_ _ f g} h := by + refine SuperVect.hom_ext ?_ ?_ + · exact congrArg (fun α => (α.app ⟨false⟩).hom.hom) h + · exact congrArg (fun α => (α.app ⟨true⟩).hom.hom) h + +instance superVectComponents_full : superVectComponents.Full where + map_surjective {_ _} α := + ⟨{ evenMap := (α.app ⟨false⟩).hom.hom + oddMap := (α.app ⟨true⟩).hom.hom }, by + refine NatTrans.ext (funext fun i => ?_) + obtain ⟨b⟩ := i + cases b <;> rfl⟩ + +instance superVectComponents_essSurj : superVectComponents.EssSurj where + mem_essImage Φ := + ⟨{ even := Φ.obj ⟨false⟩ + odd := Φ.obj ⟨true⟩ }, + ⟨Discrete.natIso fun i => + match i with + | ⟨true⟩ => Iso.refl _ + | ⟨false⟩ => Iso.refl _⟩⟩ + +instance superVectComponents_isEquivalence : + superVectComponents.IsEquivalence := + ⟨superVectComponents_faithful, superVectComponents_full, + superVectComponents_essSurj⟩ + +/-- Super vector spaces have finite products, transported along the +equivalence with the diagram category. -/ +noncomputable instance : Limits.HasFiniteProducts SuperVect := + ⟨fun _ => Adjunction.hasLimitsOfShape_of_equivalence + superVectComponents⟩ + +/-- **Super vector spaces form an abelian category.** -/ +noncomputable instance superVectAbelian : Abelian SuperVect := + abelianOfEquivalence superVectComponents + +end SuperVectAbelian + +/-! ## ℂ-linearity of the super modules over a super algebra + +Morphisms of super modules already carry a scaling by complex +numbers; the module axioms and the bilinearity of composition hold +componentwise, so the category is ℂ-linear. The tensor product is +ℂ-linear in each variable for the same reason. -/ + +namespace SuperCommAlgebra.Mod + +variable {S : SuperCommAlgebra.{u, u}} + +/-- Morphisms of super modules form a ℂ-module. -/ +instance homModule (M N : S.Mod.{u, u, u, u}) : Module ℂ (M ⟶ N) where + one_smul _ := Hom.ext (one_smul _ _) (one_smul _ _) + mul_smul _ _ _ := Hom.ext (mul_smul _ _ _) (mul_smul _ _ _) + smul_zero _ := Hom.ext (smul_zero _) (smul_zero _) + smul_add _ _ _ := Hom.ext (smul_add _ _ _) (smul_add _ _ _) + add_smul _ _ _ := Hom.ext (add_smul _ _ _) (add_smul _ _ _) + zero_smul _ := Hom.ext (zero_smul _ _) (zero_smul _ _) + +/-- **Super modules over a super algebra form a ℂ-linear +category.** -/ +instance instLinear : CategoryTheory.Linear ℂ S.Mod.{u, u, u, u} where + smul_comp _ _ _ c f g := + Hom.ext (LinearMap.comp_smul _ _ _) (LinearMap.comp_smul _ _ _) + comp_smul _ _ _ f c g := + Hom.ext (LinearMap.smul_comp _ _ _) (LinearMap.smul_comp _ _ _) + +variable {M N P Q : S.Mod.{u, u, u, u}} + +/-- **The tensor product of super modules is ℂ-linear in the left +variable.** -/ +theorem tensorHom_smul_left (c : ℂ) (f : M ⟶ P) (g : N ⟶ Q) : + tensorHom (c • f) g = c • tensorHom f g := by + refine hom_ext (fun m n => ?_) (fun m n => ?_) (fun m n => ?_) + (fun m n => ?_) <;> + simp only [tensorHom_evenMap_tmulEE, tensorHom_evenMap_tmulOO, + tensorHom_oddMap_tmulEO, tensorHom_oddMap_tmulOE, + smul_evenMap, smul_oddMap, LinearMap.smul_apply, map_smul] + +/-- Tensoring on the right by a fixed module is ℂ-linear. -/ +instance tensorRightFunctor_linear (N : S.Mod.{u, u, u, u}) : + (tensorRightFunctor N).Linear ℂ where + map_smul {_ _} f c := tensorHom_smul_left c f (𝟙 N) + +end SuperCommAlgebra.Mod + +section Transport + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) +variable {M N Q : S.Mod.{u, u, u, u}} + +/-- **Base change of a morphism of super modules along a ℂ-point.** +The morphism is tensored with the residue module and the result is +read in the coordinates that `RS.toSuperVect` installs on the two +components. -/ +noncomputable def superVectHom + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] + (u : M ⟶ N) : + toSuperVect P M ⟶ toSuperVect P N where + evenMap := (toSuperVectEvenEquiv P N).toLinearMap ∘ₗ + ((tensorRightFunctor (pointMod P)).map u).evenMap ∘ₗ + (toSuperVectEvenEquiv P M).symm.toLinearMap + oddMap := (toSuperVectOddEquiv P N).toLinearMap ∘ₗ + ((tensorRightFunctor (pointMod P)).map u).oddMap ∘ₗ + (toSuperVectOddEquiv P M).symm.toLinearMap + +/-- Base change fixes the identity. -/ +theorem superVectHom_id [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] : + superVectHom P (𝟙 M) = 𝟙 (toSuperVect P M) := by + refine SuperVect.hom_ext ?_ ?_ <;> refine LinearMap.ext fun x => ?_ + · change (toSuperVectEvenEquiv P M) + (((tensorRightFunctor (pointMod P)).map (𝟙 M)).evenMap + ((toSuperVectEvenEquiv P M).symm x)) = x + rw [CategoryTheory.Functor.map_id] + exact (toSuperVectEvenEquiv P M).apply_symm_apply x + · change (toSuperVectOddEquiv P M) + (((tensorRightFunctor (pointMod P)).map (𝟙 M)).oddMap + ((toSuperVectOddEquiv P M).symm x)) = x + rw [CategoryTheory.Functor.map_id] + exact (toSuperVectOddEquiv P M).apply_symm_apply x + +/-- Base change respects composition: the conjugating equivalences +cancel. -/ +theorem superVectHom_comp [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (Q.tensor (pointMod P)).even] + [FiniteDimensional ℂ (Q.tensor (pointMod P)).odd] + (u : M ⟶ N) (v : N ⟶ Q) : + superVectHom P (u ≫ v) = superVectHom P u ≫ superVectHom P v := by + refine SuperVect.hom_ext ?_ ?_ <;> refine LinearMap.ext fun x => ?_ + · change (toSuperVectEvenEquiv P Q) + (((tensorRightFunctor (pointMod P)).map (u ≫ v)).evenMap + ((toSuperVectEvenEquiv P M).symm x)) = _ + rw [CategoryTheory.Functor.map_comp] + change _ = (toSuperVectEvenEquiv P Q) + (((tensorRightFunctor (pointMod P)).map v).evenMap + ((toSuperVectEvenEquiv P N).symm ((toSuperVectEvenEquiv P N) + (((tensorRightFunctor (pointMod P)).map u).evenMap + ((toSuperVectEvenEquiv P M).symm x))))) + erw [LinearEquiv.symm_apply_apply] + rfl + · change (toSuperVectOddEquiv P Q) + (((tensorRightFunctor (pointMod P)).map (u ≫ v)).oddMap + ((toSuperVectOddEquiv P M).symm x)) = _ + rw [CategoryTheory.Functor.map_comp] + change _ = (toSuperVectOddEquiv P Q) + (((tensorRightFunctor (pointMod P)).map v).oddMap + ((toSuperVectOddEquiv P N).symm ((toSuperVectOddEquiv P N) + (((tensorRightFunctor (pointMod P)).map u).oddMap + ((toSuperVectOddEquiv P M).symm x))))) + erw [LinearEquiv.symm_apply_apply] + rfl + +/-- Base change is additive. -/ +theorem superVectHom_add [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] + (u v : M ⟶ N) : + superVectHom P (u + v) = superVectHom P u + superVectHom P v := by + refine SuperVect.hom_ext ?_ ?_ <;> refine LinearMap.ext fun x => ?_ + · change (toSuperVectEvenEquiv P N) + (((tensorRightFunctor (pointMod P)).map (u + v)).evenMap + ((toSuperVectEvenEquiv P M).symm x)) = _ + rw [CategoryTheory.Functor.map_add] + change (toSuperVectEvenEquiv P N) + ((((tensorRightFunctor (pointMod P)).map u).evenMap + + ((tensorRightFunctor (pointMod P)).map v).evenMap) + ((toSuperVectEvenEquiv P M).symm x)) = _ + exact map_add _ _ _ + · change (toSuperVectOddEquiv P N) + (((tensorRightFunctor (pointMod P)).map (u + v)).oddMap + ((toSuperVectOddEquiv P M).symm x)) = _ + rw [CategoryTheory.Functor.map_add] + change (toSuperVectOddEquiv P N) + ((((tensorRightFunctor (pointMod P)).map u).oddMap + + ((tensorRightFunctor (pointMod P)).map v).oddMap) + ((toSuperVectOddEquiv P M).symm x)) = _ + exact map_add _ _ _ + +/-- Base change is ℂ-linear. -/ +theorem superVectHom_smul [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] + (c : ℂ) (u : M ⟶ N) : + superVectHom P (c • u) = c • superVectHom P u := by + refine SuperVect.hom_ext ?_ ?_ <;> refine LinearMap.ext fun x => ?_ + · change (toSuperVectEvenEquiv P N) + (((tensorRightFunctor (pointMod P)).map (c • u)).evenMap + ((toSuperVectEvenEquiv P M).symm x)) = _ + rw [CategoryTheory.Functor.map_smul] + change (toSuperVectEvenEquiv P N) + ((c • ((tensorRightFunctor (pointMod P)).map u).evenMap) + ((toSuperVectEvenEquiv P M).symm x)) = _ + exact map_smul (toSuperVectEvenEquiv P N) c _ + · change (toSuperVectOddEquiv P N) + (((tensorRightFunctor (pointMod P)).map (c • u)).oddMap + ((toSuperVectOddEquiv P M).symm x)) = _ + rw [CategoryTheory.Functor.map_smul] + change (toSuperVectOddEquiv P N) + ((c • ((tensorRightFunctor (pointMod P)).map u).oddMap) + ((toSuperVectOddEquiv P M).symm x)) = _ + exact map_smul (toSuperVectOddEquiv P N) c _ + +end Transport + +section PointFunctor + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) {E : Type u₂} + +/-- **The base-change functor at a ℂ-point.** Each value of `G` is +tensored with the residue module of the point and packaged as a +super vector space; each morphism is conjugated through the +coordinate equivalences. -/ +noncomputable def superVectFunctor + [Category.{v₂} E] (G : E ⥤ S.Mod.{u, u, u, u}) + (hE : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).even) + (hO : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).odd) : + E ⥤ SuperVect where + obj X := toSuperVect P (G.obj X) + map {X Y} f := + @superVectHom _ P _ _ (hE X) (hO X) (hE Y) (hO Y) (G.map f) + map_id X := by + change @superVectHom _ P _ _ (hE X) (hO X) (hE X) (hO X) + (G.map (𝟙 X)) = _ + rw [CategoryTheory.Functor.map_id] + exact superVectHom_id P + map_comp {X Y Z} f g := by + change @superVectHom _ P _ _ (hE X) (hO X) (hE Z) (hO Z) + (G.map (f ≫ g)) = _ + rw [CategoryTheory.Functor.map_comp] + exact superVectHom_comp P _ _ + +@[simp] theorem superVectFunctor_obj + [Category.{v₂} E] (G : E ⥤ S.Mod.{u, u, u, u}) + (hE : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).even) + (hO : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).odd) + (X : E) : + (superVectFunctor P G hE hO).obj X = + toSuperVect P (G.obj X) := rfl + +@[simp] theorem superVectFunctor_map + [Category.{v₂} E] (G : E ⥤ S.Mod.{u, u, u, u}) + (hE : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).even) + (hO : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).odd) + {X Y : E} (f : X ⟶ Y) : + (superVectFunctor P G hE hO).map f = + @superVectHom _ P _ _ (hE X) (hO X) (hE Y) (hO Y) + (G.map f) := rfl + +/-! ## Additivity -/ + +/-- **The base-change functor is additive.** -/ +instance superVectFunctor_additive + [Category.{v₂} E] (G : E ⥤ S.Mod.{u, u, u, u}) + (hE : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).even) + (hO : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).odd) + [Preadditive E] [G.Additive] : + (superVectFunctor P G hE hO).Additive where + map_add {X Y f g} := by + change @superVectHom _ P _ _ (hE X) (hO X) (hE Y) (hO Y) + (G.map (f + g)) = _ + rw [CategoryTheory.Functor.map_add] + exact superVectHom_add P _ _ + +/-- **The base-change functor is ℂ-linear.** -/ +instance superVectFunctor_linear [Category.{v₂} E] (G : E ⥤ S.Mod.{u, u, u, u}) + (hE : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).even) + (hO : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).odd) + [Preadditive E] + [CategoryTheory.Linear ℂ E] [G.Linear ℂ] : + (superVectFunctor P G hE hO).Linear ℂ where + map_smul {X Y} f c := by + change @superVectHom _ P _ _ (hE X) (hO X) (hE Y) (hO Y) + (G.map (c • f)) = _ + rw [CategoryTheory.Functor.map_smul] + exact superVectHom_smul P _ _ + +/-! ## Dimensions -/ + +/-- **The even dimension of the base change of a free value.** If +`G` takes `X` to a free super module of rank `(p | q)` then the +even part of its base change has dimension `p`. -/ +theorem finrank_superVectFunctor_even + [Category.{v₂} E] (G : E ⥤ S.Mod.{u, u, u, u}) + (hE : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).even) + (hO : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).odd) + (X : E) (p q : ℕ) + (e : G.obj X ≅ ⨁ fun i : Fin p ⊕ Fin q => + Sum.elim (fun _ => S.unitMod) (fun _ => shift S.unitMod) i) : + Module.finrank ℂ ((superVectFunctor P G hE hO).obj X).even = p := + @finrank_toSuperVect_even_of_free _ P p q (G.obj X) e (hE X) (hO X) + +/-- **The odd dimension of the base change of a free value.** -/ +theorem finrank_superVectFunctor_odd + [Category.{v₂} E] (G : E ⥤ S.Mod.{u, u, u, u}) + (hE : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).even) + (hO : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).odd) + (X : E) (p q : ℕ) + (e : G.obj X ≅ ⨁ fun i : Fin p ⊕ Fin q => + Sum.elim (fun _ => S.unitMod) (fun _ => shift S.unitMod) i) : + Module.finrank ℂ ((superVectFunctor P G hE hO).obj X).odd = q := + @finrank_toSuperVect_odd_of_free _ P p q (G.obj X) e (hE X) (hO X) + +/-! ## Exactness -/ + +section Exact + +/-- **A splitting of the image under `G` gives a splitting after +base change.** All three terms are free over the Γ-algebra, so the +sequence splits before base change, and base change carries the +splitting across. -/ +noncomputable def superVectSplitting + [Category.{v₂} E] (G : E ⥤ S.Mod.{u, u, u, u}) + (hE : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).even) + (hO : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).odd) + [Abelian E] [G.Additive] + (T : CategoryTheory.ShortComplex E) (σ : (T.map G).Splitting) : + (T.map (superVectFunctor P G hE hO)).Splitting := + haveI : FiniteDimensional ℂ + (((T.map G).X₁).tensor (pointMod P)).even := hE T.X₁ + haveI : FiniteDimensional ℂ + (((T.map G).X₁).tensor (pointMod P)).odd := hO T.X₁ + haveI : FiniteDimensional ℂ + (((T.map G).X₂).tensor (pointMod P)).even := hE T.X₂ + haveI : FiniteDimensional ℂ + (((T.map G).X₂).tensor (pointMod P)).odd := hO T.X₂ + haveI : FiniteDimensional ℂ + (((T.map G).X₃).tensor (pointMod P)).even := hE T.X₃ + haveI : FiniteDimensional ℂ + (((T.map G).X₃).tensor (pointMod P)).odd := hO T.X₃ + { r := superVectHom P σ.r + s := superVectHom P σ.s + f_r := + Eq.trans (superVectHom_comp P (G.map T.f) σ.r).symm + (Eq.trans (congrArg (superVectHom P) σ.f_r) + (superVectHom_id P)) + s_g := + Eq.trans (superVectHom_comp P σ.s (G.map T.g)).symm + (Eq.trans (congrArg (superVectHom P) σ.s_g) + (superVectHom_id P)) + id := by + refine Eq.trans (congrArg₂ (· + ·) + (superVectHom_comp P σ.r (G.map T.f)).symm + (superVectHom_comp P (G.map T.g) σ.s).symm) ?_ + exact Eq.trans (superVectHom_add P _ _).symm + (Eq.trans (congrArg (superVectHom P) σ.id) + (superVectHom_id P)) } + +/-- **The base-change functor carries a split short exact sequence +to a short exact sequence.** -/ +theorem superVectFunctor_shortExact + [Category.{v₂} E] (G : E ⥤ S.Mod.{u, u, u, u}) + (hE : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).even) + (hO : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).odd) + [Abelian E] [G.Additive] + (T : CategoryTheory.ShortComplex E) (σ : (T.map G).Splitting) : + (T.map (superVectFunctor P G hE hO)).ShortExact := + (superVectSplitting P G hE hO T σ).shortExact + +/-- **The base-change functor preserves finite limits** as soon as +every short exact sequence splits after `G`. -/ +theorem superVectFunctor_preservesFiniteLimits + [Category.{v₂} E] (G : E ⥤ S.Mod.{u, u, u, u}) + (hE : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).even) + (hO : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).odd) + [Abelian E] [G.Additive] + (hsec : ∀ T : CategoryTheory.ShortComplex E, T.ShortExact → + Nonempty ((T.map G).Splitting)) : + Limits.PreservesFiniteLimits (superVectFunctor P G hE hO) := + preservesFiniteLimits_of_shortExact _ fun T hT => + superVectFunctor_shortExact P G hE hO T (hsec T hT).some + +/-- **The base-change functor preserves finite colimits** under the +same hypothesis; with the previous statement it is exact. -/ +theorem superVectFunctor_preservesFiniteColimits + [Category.{v₂} E] (G : E ⥤ S.Mod.{u, u, u, u}) + (hE : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).even) + (hO : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).odd) + [Abelian E] [G.Additive] + (hsec : ∀ T : CategoryTheory.ShortComplex E, T.ShortExact → + Nonempty ((T.map G).Splitting)) : + Limits.PreservesFiniteColimits (superVectFunctor P G hE hO) := + preservesFiniteColimits_of_shortExact _ fun T hT => + superVectFunctor_shortExact P G hE hO T (hsec T hT).some + +/-- **The base-change functor preserves homology**, hence +monomorphisms and epimorphisms. -/ +theorem superVectFunctor_preservesHomology + [Category.{v₂} E] (G : E ⥤ S.Mod.{u, u, u, u}) + (hE : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).even) + (hO : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).odd) + [Abelian E] [G.Additive] + (hsec : ∀ T : CategoryTheory.ShortComplex E, T.ShortExact → + Nonempty ((T.map G).Splitting)) : + (superVectFunctor P G hE hO).PreservesHomology := + preservesHomology_of_shortExact _ fun T hT => + superVectFunctor_shortExact P G hE hO T (hsec T hT).some + +end Exact + +end PointFunctor + +/-! ## The fibre functor of a splitting algebra at a point -/ + +section Fibre + +open MonoidalCategory +open scoped MonObj + +universe v + +variable {C : Type v} + +/-- The restricted fibre functor is additive. -/ +instance indFibre_additive + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [MonoidalPreadditive C] [CategoryTheory.Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] + [IsCommMonObj 𝔸] : + ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸).Additive := + haveI : (indOf (C := C)).Additive := indOf_additive + inferInstance + +/-- **The even part of the fibre of an embedded object at a point is +finite dimensional**, for an algebra splitting the embedding. -/ +theorem finiteDimensional_indFibre_even + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [MonoidalPreadditive C] [CategoryTheory.Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] + [IsCommMonObj 𝔸] + (hsp : SplitsOn L 𝔸 (indOf : C ⥤ Ind C)) + (P : SuperPoint (gammaAlgebra (Ind C) L 𝔸)) (X : C) : + FiniteDimensional ℂ + ((((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸).obj X).tensor + (pointMod P)).even := by + obtain ⟨p, q, ⟨e⟩⟩ := hsp X + exact finiteDimensional_fibre_tensor_point_even L 𝔸 P e + +/-- **The odd part of the fibre of an embedded object at a point is +finite dimensional.** -/ +theorem finiteDimensional_indFibre_odd + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [MonoidalPreadditive C] [CategoryTheory.Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] + [IsCommMonObj 𝔸] + (hsp : SplitsOn L 𝔸 (indOf : C ⥤ Ind C)) + (P : SuperPoint (gammaAlgebra (Ind C) L 𝔸)) (X : C) : + FiniteDimensional ℂ + ((((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸).obj X).tensor + (pointMod P)).odd := by + obtain ⟨p, q, ⟨e⟩⟩ := hsp X + exact finiteDimensional_fibre_tensor_point_odd L 𝔸 P e + +/-- **The fibre functor into super vector spaces**: embed, take the +fibre over the splitting algebra, and base change to the ℂ-point. -/ +noncomputable def deligneFibre + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [MonoidalPreadditive C] [CategoryTheory.Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] + [IsCommMonObj 𝔸] + (hsp : SplitsOn L 𝔸 (indOf : C ⥤ Ind C)) + (P : SuperPoint (gammaAlgebra (Ind C) L 𝔸)) : C ⥤ SuperVect := + superVectFunctor P ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸) + (finiteDimensional_indFibre_even L 𝔸 hsp P) + (finiteDimensional_indFibre_odd L 𝔸 hsp P) + +/-- **The fibre functor is additive.** -/ +instance deligneFibre_additive + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [MonoidalPreadditive C] [CategoryTheory.Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] + [IsCommMonObj 𝔸] + (hsp : SplitsOn L 𝔸 (indOf : C ⥤ Ind C)) + (P : SuperPoint (gammaAlgebra (Ind C) L 𝔸)) : + (deligneFibre L 𝔸 hsp P).Additive := + superVectFunctor_additive _ _ _ _ + +/-! ### Exactness -/ + +/-- The base-change hypothesis of `RS.exists_fibre_algebra`, as a +splitting of each embedded short exact sequence after the fibre +functor. -/ +theorem indFibre_nonempty_splitting + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + [CategoryTheory.Linear ℂ (Ind C)] [MonoidalLinear ℂ (Ind C)] + (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] [IsCommMonObj 𝔸] + (hsec : ∀ T : CategoryTheory.ShortComplex C, T.ShortExact → + ∃ s : freeMod 𝔸 ((T.map (indOf : C ⥤ Ind C)).X₃) ⟶ + freeMod 𝔸 ((T.map (indOf : C ⥤ Ind C)).X₂), + s ≫ freeModMap 𝔸 ((T.map (indOf : C ⥤ Ind C)).g) = + 𝟙 (freeMod 𝔸 ((T.map (indOf : C ⥤ Ind C)).X₃))) + (T : CategoryTheory.ShortComplex C) (hT : T.ShortExact) : + Nonempty + ((T.map ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸)).Splitting) := by + obtain ⟨s, hs⟩ := hsec T hT + rw [CategoryTheory.ShortComplex.map_comp] + exact ⟨fibreFunSplitting L 𝔸 (indOf_shortExact hT) s hs⟩ + +/-- **The fibre functor preserves finite limits.** -/ +theorem deligneFibre_preservesFiniteLimits + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + [CategoryTheory.Linear ℂ (Ind C)] [MonoidalLinear ℂ (Ind C)] + (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] [IsCommMonObj 𝔸] + (hsp : SplitsOn L 𝔸 (indOf : C ⥤ Ind C)) + (hsec : ∀ T : CategoryTheory.ShortComplex C, T.ShortExact → + ∃ s : freeMod 𝔸 ((T.map (indOf : C ⥤ Ind C)).X₃) ⟶ + freeMod 𝔸 ((T.map (indOf : C ⥤ Ind C)).X₂), + s ≫ freeModMap 𝔸 ((T.map (indOf : C ⥤ Ind C)).g) = + 𝟙 (freeMod 𝔸 ((T.map (indOf : C ⥤ Ind C)).X₃))) + (P : SuperPoint (gammaAlgebra (Ind C) L 𝔸)) : + Limits.PreservesFiniteLimits (deligneFibre L 𝔸 hsp P) := + superVectFunctor_preservesFiniteLimits P _ _ _ + (indFibre_nonempty_splitting L 𝔸 hsec) + +/-- **The fibre functor preserves finite colimits**; with the +previous statement it is exact. -/ +theorem deligneFibre_preservesFiniteColimits + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + [CategoryTheory.Linear ℂ (Ind C)] [MonoidalLinear ℂ (Ind C)] + (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] [IsCommMonObj 𝔸] + (hsp : SplitsOn L 𝔸 (indOf : C ⥤ Ind C)) + (hsec : ∀ T : CategoryTheory.ShortComplex C, T.ShortExact → + ∃ s : freeMod 𝔸 ((T.map (indOf : C ⥤ Ind C)).X₃) ⟶ + freeMod 𝔸 ((T.map (indOf : C ⥤ Ind C)).X₂), + s ≫ freeModMap 𝔸 ((T.map (indOf : C ⥤ Ind C)).g) = + 𝟙 (freeMod 𝔸 ((T.map (indOf : C ⥤ Ind C)).X₃))) + (P : SuperPoint (gammaAlgebra (Ind C) L 𝔸)) : + Limits.PreservesFiniteColimits (deligneFibre L 𝔸 hsp P) := + superVectFunctor_preservesFiniteColimits P _ _ _ + (indFibre_nonempty_splitting L 𝔸 hsec) + +/-! ### Dimensions and faithfulness -/ + +/-- **The fibre functor detects the zero object.** If the fibre of +an object is a zero super vector space then both ranks of its mixed +sum vanish, so its fibre over the algebra is already zero, and the +unit of the algebra being a monomorphism forces the object to +vanish. -/ +theorem id_eq_zero_of_deligneFibre_id_eq_zero + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [MonoidalPreadditive C] [CategoryTheory.Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] + [IsCommMonObj 𝔸] [∀ Z : Ind C, (tensorRight Z).PreservesMonomorphisms] + (hmono : Mono η[𝔸]) + (hsp : SplitsOn L 𝔸 (indOf : C ⥤ Ind C)) + (P : SuperPoint (gammaAlgebra (Ind C) L 𝔸)) (Z : C) + (hz : 𝟙 ((deligneFibre L 𝔸 hsp P).obj Z) = 0) : 𝟙 Z = 0 := by + have : (indOf (C := C)).Additive := indOf_additive + obtain ⟨p, q, ⟨e⟩⟩ := hsp Z + have hide : (LinearMap.id : + ((deligneFibre L 𝔸 hsp P).obj Z).even →ₗ[ℂ] + ((deligneFibre L 𝔸 hsp P).obj Z).even) = 0 := + congrArg SuperVect.Hom.evenMap hz + have hido : (LinearMap.id : + ((deligneFibre L 𝔸 hsp P).obj Z).odd →ₗ[ℂ] + ((deligneFibre L 𝔸 hsp P).obj Z).odd) = 0 := + congrArg SuperVect.Hom.oddMap hz + have : Subsingleton ((deligneFibre L 𝔸 hsp P).obj Z).even := + ⟨fun a b => by + have ha : a = 0 := by simpa using DFunLike.congr_fun hide a + have hb : b = 0 := by simpa using DFunLike.congr_fun hide b + rw [ha, hb]⟩ + have : Subsingleton ((deligneFibre L 𝔸 hsp P).obj Z).odd := + ⟨fun a b => by + have ha : a = 0 := by simpa using DFunLike.congr_fun hido a + have hb : b = 0 := by simpa using DFunLike.congr_fun hido b + rw [ha, hb]⟩ + have hp : p = 0 := by + refine Eq.trans ?_ (Module.finrank_eq_zero_of_subsingleton (R := ℂ) + (M := ((deligneFibre L 𝔸 hsp P).obj Z).even)) + exact (finrank_superVectFunctor_even P _ + (finiteDimensional_indFibre_even L 𝔸 hsp P) + (finiteDimensional_indFibre_odd L 𝔸 hsp P) Z p q + (fibreFreeIso L 𝔸 e)).symm + have hq : q = 0 := by + refine Eq.trans ?_ (Module.finrank_eq_zero_of_subsingleton (R := ℂ) + (M := ((deligneFibre L 𝔸 hsp P).obj Z).odd)) + exact (finrank_superVectFunctor_odd P _ + (finiteDimensional_indFibre_even L 𝔸 hsp P) + (finiteDimensional_indFibre_odd L 𝔸 hsp P) Z p q + (fibreFreeIso L 𝔸 e)).symm + subst hp + subst hq + have hB : 𝟙 (⨁ fun i : Fin 0 ⊕ Fin 0 => + Sum.elim (fun _ => (gammaAlgebra (Ind C) L 𝔸).unitMod) + (fun _ => SuperCommAlgebra.Mod.shift + (gammaAlgebra (Ind C) L 𝔸).unitMod) i) = 0 := by + refine Limits.biproduct.hom_ext _ _ ?_ + rintro (i | i) + exacts [i.elim0, i.elim0] + have hW : 𝟙 ((fibreFun L 𝔸).obj ((indOf : C ⥤ Ind C).obj Z)) = 0 := by + have h1 := (fibreFreeIso L 𝔸 e).hom_inv_id + rw [← Category.id_comp (fibreFreeIso L 𝔸 e).inv, hB, + Limits.zero_comp, Limits.comp_zero] at h1 + exact h1.symm + have h0 : (fibreFun L 𝔸).map + (𝟙 ((indOf : C ⥤ Ind C).obj Z)) = 0 := by + rw [CategoryTheory.Functor.map_id] + exact hW + have h1 : 𝟙 ((indOf : C ⥤ Ind C).obj Z) = 0 := + fibreFun_map_eq_zero L 𝔸 hmono _ e h0 + have h2 : (indOf : C ⥤ Ind C).map (𝟙 Z) = + (indOf : C ⥤ Ind C).map (0 : Z ⟶ Z) := by + rw [CategoryTheory.Functor.map_id, + CategoryTheory.Functor.map_zero] + exact h1 + exact (indOf (C := C)).map_injective h2 + +/-- **The fibre functor is faithful.** It is exact, so it carries +the image factorisation of a morphism to an image factorisation; +a morphism killed by the functor therefore has zero image, and an +object with zero fibre is zero. -/ +theorem deligneFibre_faithful + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + [CategoryTheory.Linear ℂ (Ind C)] [MonoidalLinear ℂ (Ind C)] + (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] [IsCommMonObj 𝔸] + [∀ Z : Ind C, (tensorRight Z).PreservesMonomorphisms] + (hmono : Mono η[𝔸]) + (hsp : SplitsOn L 𝔸 (indOf : C ⥤ Ind C)) + (hsec : ∀ T : CategoryTheory.ShortComplex C, T.ShortExact → + ∃ s : freeMod 𝔸 ((T.map (indOf : C ⥤ Ind C)).X₃) ⟶ + freeMod 𝔸 ((T.map (indOf : C ⥤ Ind C)).X₂), + s ≫ freeModMap 𝔸 ((T.map (indOf : C ⥤ Ind C)).g) = + 𝟙 (freeMod 𝔸 ((T.map (indOf : C ⥤ Ind C)).X₃))) + (P : SuperPoint (gammaAlgebra (Ind C) L 𝔸)) : + (deligneFibre L 𝔸 hsp P).Faithful := by + have : (deligneFibre L 𝔸 hsp P).PreservesHomology := + superVectFunctor_preservesHomology P _ _ _ + (indFibre_nonempty_splitting L 𝔸 hsec) + refine ⟨fun {X Y} f g hfg => ?_⟩ + have hd : (deligneFibre L 𝔸 hsp P).map (f - g) = 0 := by + rw [CategoryTheory.Functor.map_sub, hfg, sub_self] + have hfac : Abelian.factorThruImage (f - g) ≫ + Abelian.image.ι (f - g) = f - g := Abelian.image.fac (f - g) + have h1 : (deligneFibre L 𝔸 hsp P).map + (Abelian.factorThruImage (f - g)) ≫ + (deligneFibre L 𝔸 hsp P).map (Abelian.image.ι (f - g)) = 0 := by + rw [← CategoryTheory.Functor.map_comp, hfac, hd] + have h2 : (deligneFibre L 𝔸 hsp P).map + (Abelian.image.ι (f - g)) = 0 := + zero_of_epi_comp _ h1 + have h3 : 𝟙 ((deligneFibre L 𝔸 hsp P).obj + (Abelian.image (f - g))) = 0 := + (cancel_mono ((deligneFibre L 𝔸 hsp P).map + (Abelian.image.ι (f - g)))).mp + (by rw [Category.id_comp, h2, Limits.zero_comp]) + have h4 : 𝟙 (Abelian.image (f - g)) = 0 := + id_eq_zero_of_deligneFibre_id_eq_zero L 𝔸 hmono hsp P _ h3 + have h5 : Abelian.image.ι (f - g) = 0 := by + rw [← Category.id_comp (Abelian.image.ι (f - g)), h4, + Limits.zero_comp] + have h6 : f - g = 0 := by + rw [← hfac, h5, Limits.comp_zero] + exact sub_eq_zero.mp h6 + +/-! ### The packaged statement -/ + +/-- **A fibre functor into super vector spaces from a splitting +algebra with a ℂ-point.** Over an algebra whose unit is a nonzero +monomorphism, which splits every embedded object into a mixed sum +and every embedded short exact sequence after base change, the +composite of the embedding, the fibre functor over the algebra and +base change along the point is an additive, exact and faithful +functor to finite-dimensional super vector spaces. -/ +theorem exists_deligneFibre_of_point + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + [CategoryTheory.Linear ℂ (Ind C)] [MonoidalLinear ℂ (Ind C)] + (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] [IsCommMonObj 𝔸] + [∀ Z : Ind C, (tensorRight Z).PreservesMonomorphisms] + (hmono : Mono η[𝔸]) + (hsp : SplitsOn L 𝔸 (indOf : C ⥤ Ind C)) + (hsec : ∀ T : CategoryTheory.ShortComplex C, T.ShortExact → + ∃ s : freeMod 𝔸 ((T.map (indOf : C ⥤ Ind C)).X₃) ⟶ + freeMod 𝔸 ((T.map (indOf : C ⥤ Ind C)).X₂), + s ≫ freeModMap 𝔸 ((T.map (indOf : C ⥤ Ind C)).g) = + 𝟙 (freeMod 𝔸 ((T.map (indOf : C ⥤ Ind C)).X₃))) + (P : SuperPoint (gammaAlgebra (Ind C) L 𝔸)) : + ∃ ω : C ⥤ SuperVect, ω.Additive ∧ + Nonempty (Limits.PreservesFiniteLimits ω) ∧ + Nonempty (Limits.PreservesFiniteColimits ω) ∧ ω.Faithful := + ⟨deligneFibre L 𝔸 hsp P, deligneFibre_additive L 𝔸 hsp P, + ⟨deligneFibre_preservesFiniteLimits L 𝔸 hsp hsec P⟩, + ⟨deligneFibre_preservesFiniteColimits L 𝔸 hsp hsec P⟩, + deligneFibre_faithful L 𝔸 hmono hsp hsec P⟩ + +end Fibre + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal.lean new file mode 100644 index 0000000000..e297ae5049 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal.lean @@ -0,0 +1,26 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Functor + +/-! +# The monoidal comparison for base change at a complex point + +Base change along a ℂ-point of a super-commutative algebra, with +its comparison morphisms, their invertibility and the braided +monoidal structure they give the fibre functor, in the five parts +below: the residue algebra and base change over it +([Residue.lean](PointMonoidal/Residue.lean)), the comparison in +super vector spaces and its inverse +([Comparison.lean](PointMonoidal/Comparison.lean)), the calculus of +generators the laws are checked in +([Calculus.lean](PointMonoidal/Calculus.lean)), the coherence and +invertibility ([Coherence.lean](PointMonoidal/Coherence.lean)), and +the monoidal and braided structure of the functor +([Functor.lean](PointMonoidal/Functor.lean)). +-/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Calculus.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Calculus.lean new file mode 100644 index 0000000000..932b5ce501 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Calculus.lean @@ -0,0 +1,570 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Comparison + +/-! +# A point-free calculus for the two tensor products + +The laws of the comparison are proved by evaluating both sides on +generators. This module collects the evaluations: the structural +morphisms of the category of super modules over a super-commutative +algebra, and of `RS.SuperVect`, applied to a generator of a tensor +product, together with the extensionality principles that reduce an +identity of maps out of a twofold or threefold graded tensor +product to its values on generators. The comparison itself is +defined in [Comparison.lean](Comparison.lean) and its laws are +proved in [Coherence.lean](Coherence.lean). + +## Contents + +* `RS.whiskerRight_evenMap_tmulEE` and its fifteen companions, + `RS.modAssoc_evenMap_ee` and its seven, + `RS.mcTensorHom_evenMap_tmulEE` and its three, + `RS.modComp_evenMap_apply`: the structural morphisms of the + category of super modules, on generators. +* `RS.actEE_span_one`, `RS.actEO_span_one`: the action of a + complex scalar through the unit of the algebra. +* `RS.svWhiskerRight_evenMap_inl` and its fifteen companions, + `RS.svComp_evenMap_apply`, `RS.svAssoc_evenMap_ee` and its seven, + `RS.svBraiding_evenMap_inl` and its three, + `RS.svLeftUnitor_evenMap_inl` and `RS.svRightUnitor_evenMap_inl` + with their odd companions: the same for `RS.SuperVect`. +* `RS.superVectHom_evenMap_apply` and its odd companion: the fibre + functor on a morphism, on generators. +* `RS.gradedTriple_ext`, `RS.superVectTripleEven_ext`, + `RS.superVectTripleOdd_ext`, `RS.superVectPairEven_ext`, + `RS.superVectPairOdd_ext`: extensionality for a twofold and a + threefold graded tensor product. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open SuperCommAlgebra (pointMod) +open SuperCommAlgebra.Mod + +universe u + +/-! ## One-step computations on generators + +The whiskerings, the associator and the unitors of the super +modules, and the whiskerings and associator of the super vector +spaces, evaluated on the generators of a tensor product. Each is +an instance of a computation lemma of the construction; they are +collected here so that the coherence proofs below rewrite with +concrete equations only. -/ + +section Steps + +open scoped TensorProduct + +variable {S : SuperCommAlgebra.{u, u}} + +section ModSteps + +/-- Composition of super module morphisms, even degree, on an +element. -/ +theorem modComp_evenMap_apply {X Y Z : S.Mod.{u, u, u, u}} + (f : X ⟶ Y) (g : Y ⟶ Z) (x : X.even) : + (f ≫ g).evenMap x = g.evenMap (f.evenMap x) := rfl + +/-- Composition of super module morphisms, odd degree, on an +element. -/ +theorem modComp_oddMap_apply {X Y Z : S.Mod.{u, u, u, u}} + (f : X ⟶ Y) (g : Y ⟶ Z) (x : X.odd) : + (f ≫ g).oddMap x = g.oddMap (f.oddMap x) := rfl + +variable {X Y : S.Mod.{u, u, u, u}} (f : X ⟶ Y) (C : S.Mod.{u, u, u, u}) + +/-- Right whiskering on an even-even generator. -/ +theorem whiskerRight_evenMap_tmulEE (x : X.even) (c : C.even) : + (f ▷ C).evenMap (tmulEE X C x c) = + tmulEE Y C (f.evenMap x) c := + tensorHom_evenMap_tmulEE f (𝟙 C) x c + +/-- Right whiskering on an odd-odd generator. -/ +theorem whiskerRight_evenMap_tmulOO (x : X.odd) (c : C.odd) : + (f ▷ C).evenMap (tmulOO X C x c) = + tmulOO Y C (f.oddMap x) c := + tensorHom_evenMap_tmulOO f (𝟙 C) x c + +/-- Right whiskering on an even-odd generator. -/ +theorem whiskerRight_oddMap_tmulEO (x : X.even) (c : C.odd) : + (f ▷ C).oddMap (tmulEO X C x c) = + tmulEO Y C (f.evenMap x) c := + tensorHom_oddMap_tmulEO f (𝟙 C) x c + +/-- Right whiskering on an odd-even generator. -/ +theorem whiskerRight_oddMap_tmulOE (x : X.odd) (c : C.even) : + (f ▷ C).oddMap (tmulOE X C x c) = + tmulOE Y C (f.oddMap x) c := + tensorHom_oddMap_tmulOE f (𝟙 C) x c + +/-- Left whiskering on an even-even generator. -/ +theorem whiskerLeft_evenMap_tmulEE (a : C.even) (x : X.even) : + (C ◁ f).evenMap (tmulEE C X a x) = + tmulEE C Y a (f.evenMap x) := + tensorHom_evenMap_tmulEE (𝟙 C) f a x + +/-- Left whiskering on an odd-odd generator. -/ +theorem whiskerLeft_evenMap_tmulOO (a : C.odd) (x : X.odd) : + (C ◁ f).evenMap (tmulOO C X a x) = + tmulOO C Y a (f.oddMap x) := + tensorHom_evenMap_tmulOO (𝟙 C) f a x + +/-- Left whiskering on an even-odd generator. -/ +theorem whiskerLeft_oddMap_tmulEO (a : C.even) (x : X.odd) : + (C ◁ f).oddMap (tmulEO C X a x) = + tmulEO C Y a (f.oddMap x) := + tensorHom_oddMap_tmulEO (𝟙 C) f a x + +/-- Left whiskering on an odd-even generator. -/ +theorem whiskerLeft_oddMap_tmulOE (a : C.odd) (x : X.even) : + (C ◁ f).oddMap (tmulOE C X a x) = + tmulOE C Y a (f.evenMap x) := + tensorHom_oddMap_tmulOE (𝟙 C) f a x + +end ModSteps + +/-- A scalar multiple of the unit acts by that scalar, in even +degree. -/ +theorem actEE_span_one {X : S.Mod.{u, u, u, u}} (r : ℂ) + (z : X.even) : + X.actEE (LinearMap.toSpanSingleton ℂ S.even S.one r) z = + r • z := by + change X.actEE (r • S.one) z = r • z + rw [map_smul, LinearMap.smul_apply, X.one_act_e] + +/-- A scalar multiple of the unit acts by that scalar, in odd +degree. -/ +theorem actEO_span_one {X : S.Mod.{u, u, u, u}} (r : ℂ) + (z : X.odd) : + X.actEO (LinearMap.toSpanSingleton ℂ S.even S.one r) z = + r • z := by + change X.actEO (r • S.one) z = r • z + rw [map_smul, LinearMap.smul_apply, X.one_act_o] + +/-- The monoidal tensor of two morphisms on an even-even +generator. -/ +theorem mcTensorHom_evenMap_tmulEE {X Y X' Y' : S.Mod.{u, u, u, u}} + (f : X ⟶ Y) (g : X' ⟶ Y') (m : X.even) (n : X'.even) : + (f ⊗ₘ g).evenMap (tmulEE X X' m n) = + tmulEE Y Y' (f.evenMap m) (g.evenMap n) := + tensorHom_evenMap_tmulEE f g m n + +/-- The monoidal tensor of two morphisms on an odd-odd +generator. -/ +theorem mcTensorHom_evenMap_tmulOO {X Y X' Y' : S.Mod.{u, u, u, u}} + (f : X ⟶ Y) (g : X' ⟶ Y') (m : X.odd) (n : X'.odd) : + (f ⊗ₘ g).evenMap (tmulOO X X' m n) = + tmulOO Y Y' (f.oddMap m) (g.oddMap n) := + tensorHom_evenMap_tmulOO f g m n + +/-- The monoidal tensor of two morphisms on an even-odd +generator. -/ +theorem mcTensorHom_oddMap_tmulEO {X Y X' Y' : S.Mod.{u, u, u, u}} + (f : X ⟶ Y) (g : X' ⟶ Y') (m : X.even) (n : X'.odd) : + (f ⊗ₘ g).oddMap (tmulEO X X' m n) = + tmulEO Y Y' (f.evenMap m) (g.oddMap n) := + tensorHom_oddMap_tmulEO f g m n + +/-- The monoidal tensor of two morphisms on an odd-even +generator. -/ +theorem mcTensorHom_oddMap_tmulOE {X Y X' Y' : S.Mod.{u, u, u, u}} + (f : X ⟶ Y) (g : X' ⟶ Y') (m : X.odd) (n : X'.even) : + (f ⊗ₘ g).oddMap (tmulOE X X' m n) = + tmulOE Y Y' (f.oddMap m) (g.evenMap n) := + tensorHom_oddMap_tmulOE f g m n + +section AssocSteps + +variable (M N Q : S.Mod.{u, u, u, u}) + +/-- The associator on the even-even-even generators. -/ +theorem modAssoc_evenMap_ee (m : M.even) (n : N.even) (q : Q.even) : + (α_ M N Q).hom.evenMap + (tmulEE (M.tensor N) Q (tmulEE M N m n) q) = + tmulEE M (N.tensor Q) m (tmulEE N Q n q) := by + rw [modAssociator_hom, assocHom_evenMap_tmulEE, assocFee_tmulEE] + +/-- The associator on the odd-odd-even generators. -/ +theorem modAssoc_evenMap_oo (m : M.odd) (n : N.odd) (q : Q.even) : + (α_ M N Q).hom.evenMap + (tmulEE (M.tensor N) Q (tmulOO M N m n) q) = + tmulOO M (N.tensor Q) m (tmulOE N Q n q) := by + rw [modAssociator_hom, assocHom_evenMap_tmulEE, assocFee_tmulOO] + +/-- The associator on the even-odd-odd generators. -/ +theorem modAssoc_evenMap_eo (m : M.even) (n : N.odd) (q : Q.odd) : + (α_ M N Q).hom.evenMap + (tmulOO (M.tensor N) Q (tmulEO M N m n) q) = + tmulEE M (N.tensor Q) m (tmulOO N Q n q) := by + rw [modAssociator_hom, assocHom_evenMap_tmulOO, assocFoo_tmulEO] + +/-- The associator on the odd-even-odd generators. -/ +theorem modAssoc_evenMap_oe (m : M.odd) (n : N.even) (q : Q.odd) : + (α_ M N Q).hom.evenMap + (tmulOO (M.tensor N) Q (tmulOE M N m n) q) = + tmulOO M (N.tensor Q) m (tmulEO N Q n q) := by + rw [modAssociator_hom, assocHom_evenMap_tmulOO, assocFoo_tmulOE] + +/-- The associator on the even-even-odd generators. -/ +theorem modAssoc_oddMap_ee (m : M.even) (n : N.even) (q : Q.odd) : + (α_ M N Q).hom.oddMap + (tmulEO (M.tensor N) Q (tmulEE M N m n) q) = + tmulEO M (N.tensor Q) m (tmulEO N Q n q) := by + rw [modAssociator_hom, assocHom_oddMap_tmulEO, assocFeo_tmulEE] + +/-- The associator on the odd-odd-odd generators. -/ +theorem modAssoc_oddMap_oo (m : M.odd) (n : N.odd) (q : Q.odd) : + (α_ M N Q).hom.oddMap + (tmulEO (M.tensor N) Q (tmulOO M N m n) q) = + tmulOE M (N.tensor Q) m (tmulOO N Q n q) := by + rw [modAssociator_hom, assocHom_oddMap_tmulEO, assocFeo_tmulOO] + +/-- The associator on the even-odd-even generators. -/ +theorem modAssoc_oddMap_eo (m : M.even) (n : N.odd) (q : Q.even) : + (α_ M N Q).hom.oddMap + (tmulOE (M.tensor N) Q (tmulEO M N m n) q) = + tmulEO M (N.tensor Q) m (tmulOE N Q n q) := by + rw [modAssociator_hom, assocHom_oddMap_tmulOE, assocFoe_tmulEO] + +/-- The associator on the odd-even-even generators. -/ +theorem modAssoc_oddMap_oe (m : M.odd) (n : N.even) (q : Q.even) : + (α_ M N Q).hom.oddMap + (tmulOE (M.tensor N) Q (tmulOE M N m n) q) = + tmulOE M (N.tensor Q) m (tmulEE N Q n q) := by + rw [modAssociator_hom, assocHom_oddMap_tmulOE, assocFoe_tmulOE] + +end AssocSteps + +section SuperVectSteps + +variable {V W : SuperVect} (f : V ⟶ W) (X : SuperVect) + +/-- Right whiskering of super vector spaces, first summand. -/ +theorem svWhiskerRight_evenMap_inl (v : V.even) (x : X.even) : + (f ▷ X).evenMap (svEvenInl (v ⊗ₜ[ℂ] x)) = + svEvenInl ((f : V.Hom W).evenMap v ⊗ₜ[ℂ] x) := rfl + +/-- Right whiskering of super vector spaces, second summand. -/ +theorem svWhiskerRight_evenMap_inr (v : V.odd) (x : X.odd) : + (f ▷ X).evenMap (svEvenInr (v ⊗ₜ[ℂ] x)) = + svEvenInr ((f : V.Hom W).oddMap v ⊗ₜ[ℂ] x) := rfl + +/-- Right whiskering of super vector spaces, odd degree, first +summand. -/ +theorem svWhiskerRight_oddMap_inl (v : V.even) (x : X.odd) : + (f ▷ X).oddMap (svOddInl (v ⊗ₜ[ℂ] x)) = + svOddInl ((f : V.Hom W).evenMap v ⊗ₜ[ℂ] x) := rfl + +/-- Right whiskering of super vector spaces, odd degree, second +summand. -/ +theorem svWhiskerRight_oddMap_inr (v : V.odd) (x : X.even) : + (f ▷ X).oddMap (svOddInr (v ⊗ₜ[ℂ] x)) = + svOddInr ((f : V.Hom W).oddMap v ⊗ₜ[ℂ] x) := rfl + +/-- Left whiskering of super vector spaces, first summand. -/ +theorem svWhiskerLeft_evenMap_inl (x : X.even) (v : V.even) : + (X ◁ f).evenMap (svEvenInl (x ⊗ₜ[ℂ] v)) = + svEvenInl (x ⊗ₜ[ℂ] (f : V.Hom W).evenMap v) := rfl + +/-- Left whiskering of super vector spaces, second summand. -/ +theorem svWhiskerLeft_evenMap_inr (x : X.odd) (v : V.odd) : + (X ◁ f).evenMap (svEvenInr (x ⊗ₜ[ℂ] v)) = + svEvenInr (x ⊗ₜ[ℂ] (f : V.Hom W).oddMap v) := rfl + +/-- Left whiskering of super vector spaces, odd degree, first +summand. -/ +theorem svWhiskerLeft_oddMap_inl (x : X.even) (v : V.odd) : + (X ◁ f).oddMap (svOddInl (x ⊗ₜ[ℂ] v)) = + svOddInl (x ⊗ₜ[ℂ] (f : V.Hom W).oddMap v) := rfl + +/-- Left whiskering of super vector spaces, odd degree, second +summand. -/ +theorem svWhiskerLeft_oddMap_inr (x : X.odd) (v : V.even) : + (X ◁ f).oddMap (svOddInr (x ⊗ₜ[ℂ] v)) = + svOddInr (x ⊗ₜ[ℂ] (f : V.Hom W).evenMap v) := rfl + +/-- Composition of super vector space morphisms, even degree, on +an element. -/ +theorem svComp_evenMap_apply {V W Y : SuperVect} (f : V ⟶ W) + (g : W ⟶ Y) (x : V.even) : + ((f ≫ g : V ⟶ Y) : V.Hom Y).evenMap x = + (g : W.Hom Y).evenMap ((f : V.Hom W).evenMap x) := rfl + +/-- Composition of super vector space morphisms, odd degree, on an +element. -/ +theorem svComp_oddMap_apply {V W Y : SuperVect} (f : V ⟶ W) + (g : W ⟶ Y) (x : V.odd) : + ((f ≫ g : V ⟶ Y) : V.Hom Y).oddMap x = + (g : W.Hom Y).oddMap ((f : V.Hom W).oddMap x) := rfl + +/-- The Koszul braiding on an even-even generator. -/ +theorem svBraiding_evenMap_inl (V W : SuperVect) (x : V.even) + (y : W.even) : + ((β_ V W).hom : V ⊗ W ⟶ W ⊗ V).evenMap + (svEvenInl (x ⊗ₜ[ℂ] y)) = svEvenInl (y ⊗ₜ[ℂ] x) := rfl + +/-- The Koszul braiding on an odd-odd generator: this is where the +sign lives. -/ +theorem svBraiding_evenMap_inr (V W : SuperVect) (x : V.odd) + (y : W.odd) : + ((β_ V W).hom : V ⊗ W ⟶ W ⊗ V).evenMap + (svEvenInr (x ⊗ₜ[ℂ] y)) = + -svEvenInr (y ⊗ₜ[ℂ] x) := + Prod.ext neg_zero.symm rfl + +/-- The Koszul braiding on an even-odd generator. -/ +theorem svBraiding_oddMap_inl (V W : SuperVect) (x : V.even) + (y : W.odd) : + ((β_ V W).hom : V ⊗ W ⟶ W ⊗ V).oddMap + (svOddInl (x ⊗ₜ[ℂ] y)) = svOddInr (y ⊗ₜ[ℂ] x) := rfl + +/-- The Koszul braiding on an odd-even generator. -/ +theorem svBraiding_oddMap_inr (V W : SuperVect) (x : V.odd) + (y : W.even) : + ((β_ V W).hom : V ⊗ W ⟶ W ⊗ V).oddMap + (svOddInr (x ⊗ₜ[ℂ] y)) = svOddInl (y ⊗ₜ[ℂ] x) := rfl + +/-- The associator of super vector spaces on an even-even-even +generator. -/ +theorem svAssoc_evenMap_ee (V W X : SuperVect) (a : V.even) + (b : W.even) (c : X.even) : + ((α_ V W X).hom : (V ⊗ W) ⊗ X ⟶ V ⊗ (W ⊗ X)).evenMap + (svEvenInl (svEvenInl (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c)) = + svEvenInl (a ⊗ₜ[ℂ] svEvenInl (b ⊗ₜ[ℂ] c)) := + SuperVect.assocAux_ee a b c + +/-- The associator on an odd-odd-even generator. -/ +theorem svAssoc_evenMap_oo (V W X : SuperVect) (a : V.odd) + (b : W.odd) (c : X.even) : + ((α_ V W X).hom : (V ⊗ W) ⊗ X ⟶ V ⊗ (W ⊗ X)).evenMap + (svEvenInl (svEvenInr (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c)) = + svEvenInr (a ⊗ₜ[ℂ] svOddInr (b ⊗ₜ[ℂ] c)) := + SuperVect.assocAux_oo a b c + +/-- The associator on an even-odd-odd generator. -/ +theorem svAssoc_evenMap_eo (V W X : SuperVect) (a : V.even) + (b : W.odd) (c : X.odd) : + ((α_ V W X).hom : (V ⊗ W) ⊗ X ⟶ V ⊗ (W ⊗ X)).evenMap + (svEvenInr (svOddInl (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c)) = + svEvenInl (a ⊗ₜ[ℂ] svEvenInr (b ⊗ₜ[ℂ] c)) := + SuperVect.assocAux_eo a b c + +/-- The associator on an odd-even-odd generator. -/ +theorem svAssoc_evenMap_oe (V W X : SuperVect) (a : V.odd) + (b : W.even) (c : X.odd) : + ((α_ V W X).hom : (V ⊗ W) ⊗ X ⟶ V ⊗ (W ⊗ X)).evenMap + (svEvenInr (svOddInr (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c)) = + svEvenInr (a ⊗ₜ[ℂ] svOddInl (b ⊗ₜ[ℂ] c)) := + SuperVect.assocAux_oe a b c + +/-- The associator on an even-even-odd generator. -/ +theorem svAssoc_oddMap_ee (V W X : SuperVect) (a : V.even) + (b : W.even) (c : X.odd) : + ((α_ V W X).hom : (V ⊗ W) ⊗ X ⟶ V ⊗ (W ⊗ X)).oddMap + (svOddInl (svEvenInl (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c)) = + svOddInl (a ⊗ₜ[ℂ] svOddInl (b ⊗ₜ[ℂ] c)) := + SuperVect.assocAux_ee a b c + +/-- The associator on an odd-odd-odd generator. -/ +theorem svAssoc_oddMap_oo (V W X : SuperVect) (a : V.odd) + (b : W.odd) (c : X.odd) : + ((α_ V W X).hom : (V ⊗ W) ⊗ X ⟶ V ⊗ (W ⊗ X)).oddMap + (svOddInl (svEvenInr (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c)) = + svOddInr (a ⊗ₜ[ℂ] svEvenInr (b ⊗ₜ[ℂ] c)) := + SuperVect.assocAux_oo a b c + +/-- The associator on an even-odd-even generator. -/ +theorem svAssoc_oddMap_eo (V W X : SuperVect) (a : V.even) + (b : W.odd) (c : X.even) : + ((α_ V W X).hom : (V ⊗ W) ⊗ X ⟶ V ⊗ (W ⊗ X)).oddMap + (svOddInr (svOddInl (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c)) = + svOddInl (a ⊗ₜ[ℂ] svOddInr (b ⊗ₜ[ℂ] c)) := + SuperVect.assocAux_eo a b c + +/-- The associator on an odd-even-even generator. -/ +theorem svAssoc_oddMap_oe (V W X : SuperVect) (a : V.odd) + (b : W.even) (c : X.even) : + ((α_ V W X).hom : (V ⊗ W) ⊗ X ⟶ V ⊗ (W ⊗ X)).oddMap + (svOddInr (svOddInr (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c)) = + svOddInr (a ⊗ₜ[ℂ] svEvenInl (b ⊗ₜ[ℂ] c)) := + SuperVect.assocAux_oe a b c + +/-- The left unitor of super vector spaces on the first summand. -/ +theorem svLeftUnitor_evenMap_inl (V : SuperVect) (r : ℂ) + (x : V.even) : + ((λ_ V).hom : 𝟙_ SuperVect ⊗ V ⟶ V).evenMap + (svEvenInl (r ⊗ₜ[ℂ] x)) = r • x := rfl + +/-- The left unitor in odd degree, on the first summand. -/ +theorem svLeftUnitor_oddMap_inl (V : SuperVect) (r : ℂ) + (y : V.odd) : + ((λ_ V).hom : 𝟙_ SuperVect ⊗ V ⟶ V).oddMap + (svOddInl (r ⊗ₜ[ℂ] y)) = r • y := rfl + +/-- The right unitor of super vector spaces on the first +summand. -/ +theorem svRightUnitor_evenMap_inl (V : SuperVect) (x : V.even) + (r : ℂ) : + ((ρ_ V).hom : V ⊗ 𝟙_ SuperVect ⟶ V).evenMap + (svEvenInl (x ⊗ₜ[ℂ] r)) = r • x := rfl + +/-- The right unitor in odd degree, on the second summand. -/ +theorem svRightUnitor_oddMap_inr (V : SuperVect) (y : V.odd) + (r : ℂ) : + ((ρ_ V).hom : V ⊗ 𝟙_ SuperVect ⟶ V).oddMap + (svOddInr (y ⊗ₜ[ℂ] r)) = r • y := rfl + +end SuperVectSteps + +section HomSteps + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) + {M N : S.Mod.{u, u, u, u}} + +/-- Base change of a morphism, in even degree, on an element. -/ +theorem superVectHom_evenMap_apply + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] + (u : M ⟶ N) + (y : (toSuperVect P M).even) : + (superVectHom P u).evenMap y = + toSuperVectEvenEquiv P N + ((u ▷ pointMod P).evenMap + ((toSuperVectEvenEquiv P M).symm y)) := rfl + +/-- Base change of a morphism, in odd degree, on an element. -/ +theorem superVectHom_oddMap_apply + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] + (u : M ⟶ N) + (y : (toSuperVect P M).odd) : + (superVectHom P u).oddMap y = + toSuperVectOddEquiv P N + ((u ▷ pointMod P).oddMap + ((toSuperVectOddEquiv P M).symm y)) := rfl + +end HomSteps + +end Steps + +/-! ## Extensionality for a threefold graded tensor product -/ + +section TripleExt + +open scoped TensorProduct + +/-- **Two linear maps out of a threefold graded tensor product +agree** as soon as they agree on the four families of generators. +Both components of a threefold product of super vector spaces are +of this shape, the two `C`-slots taken in the two orders. -/ +theorem gradedTriple_ext {A₁ A₂ B₁ B₂ C₁ C₂ : Type*} + [AddCommGroup A₁] [Module ℂ A₁] [AddCommGroup A₂] [Module ℂ A₂] + [AddCommGroup B₁] [Module ℂ B₁] [AddCommGroup B₂] [Module ℂ B₂] + [AddCommGroup C₁] [Module ℂ C₁] [AddCommGroup C₂] [Module ℂ C₂] + {Z : Type*} [AddCommGroup Z] [Module ℂ Z] + {f g : ((((A₁ ⊗[ℂ] B₁) × (A₂ ⊗[ℂ] B₂)) ⊗[ℂ] C₁) × + (((A₁ ⊗[ℂ] B₂) × (A₂ ⊗[ℂ] B₁)) ⊗[ℂ] C₂)) →ₗ[ℂ] Z} + (h₁ : ∀ (a : A₁) (b : B₁) (c : C₁), + f ((a ⊗ₜ[ℂ] b, 0) ⊗ₜ[ℂ] c, 0) = g ((a ⊗ₜ[ℂ] b, 0) ⊗ₜ[ℂ] c, 0)) + (h₂ : ∀ (a : A₂) (b : B₂) (c : C₁), + f ((0, a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c, 0) = g ((0, a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c, 0)) + (h₃ : ∀ (a : A₁) (b : B₂) (c : C₂), + f (0, (a ⊗ₜ[ℂ] b, 0) ⊗ₜ[ℂ] c) = g (0, (a ⊗ₜ[ℂ] b, 0) ⊗ₜ[ℂ] c)) + (h₄ : ∀ (a : A₂) (b : B₁) (c : C₂), + f (0, (0, a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c) = + g (0, (0, a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c)) : f = g := by + refine LinearMap.prod_ext (TensorProduct.ext' fun w c => ?_) + (TensorProduct.ext' fun w c => ?_) + · exact LinearMap.congr_fun (LinearMap.prod_ext + (f := (f.comp (LinearMap.inl ℂ _ _)).comp + ((TensorProduct.mk ℂ _ C₁).flip c)) + (g := (g.comp (LinearMap.inl ℂ _ _)).comp + ((TensorProduct.mk ℂ _ C₁).flip c)) + (TensorProduct.ext' fun a b => h₁ a b c) + (TensorProduct.ext' fun a b => h₂ a b c)) w + · exact LinearMap.congr_fun (LinearMap.prod_ext + (f := (f.comp (LinearMap.inr ℂ _ _)).comp + ((TensorProduct.mk ℂ _ C₂).flip c)) + (g := (g.comp (LinearMap.inr ℂ _ _)).comp + ((TensorProduct.mk ℂ _ C₂).flip c)) + (TensorProduct.ext' fun a b => h₃ a b c) + (TensorProduct.ext' fun a b => h₄ a b c)) w + +/-- **Extensionality for the even part of a threefold product of +super vector spaces.** -/ +theorem superVectTripleEven_ext {V W X : SuperVect} {Z : Type*} + [AddCommGroup Z] [Module ℂ Z] + {f g : ((V ⊗ W) ⊗ X).even →ₗ[ℂ] Z} + (h₁ : ∀ (a : V.even) (b : W.even) (c : X.even), + f (svEvenInl (svEvenInl (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c)) = + g (svEvenInl (svEvenInl (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c))) + (h₂ : ∀ (a : V.odd) (b : W.odd) (c : X.even), + f (svEvenInl (svEvenInr (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c)) = + g (svEvenInl (svEvenInr (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c))) + (h₃ : ∀ (a : V.even) (b : W.odd) (c : X.odd), + f (svEvenInr (svOddInl (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c)) = + g (svEvenInr (svOddInl (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c))) + (h₄ : ∀ (a : V.odd) (b : W.even) (c : X.odd), + f (svEvenInr (svOddInr (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c)) = + g (svEvenInr (svOddInr (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c))) : f = g := + gradedTriple_ext h₁ h₂ h₃ h₄ + +/-- **Extensionality for the odd part of a threefold product of +super vector spaces.** -/ +theorem superVectTripleOdd_ext {V W X : SuperVect} {Z : Type*} + [AddCommGroup Z] [Module ℂ Z] + {f g : ((V ⊗ W) ⊗ X).odd →ₗ[ℂ] Z} + (h₁ : ∀ (a : V.even) (b : W.even) (c : X.odd), + f (svOddInl (svEvenInl (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c)) = + g (svOddInl (svEvenInl (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c))) + (h₂ : ∀ (a : V.odd) (b : W.odd) (c : X.odd), + f (svOddInl (svEvenInr (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c)) = + g (svOddInl (svEvenInr (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c))) + (h₃ : ∀ (a : V.even) (b : W.odd) (c : X.even), + f (svOddInr (svOddInl (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c)) = + g (svOddInr (svOddInl (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c))) + (h₄ : ∀ (a : V.odd) (b : W.even) (c : X.even), + f (svOddInr (svOddInr (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c)) = + g (svOddInr (svOddInr (a ⊗ₜ[ℂ] b) ⊗ₜ[ℂ] c))) : f = g := + gradedTriple_ext h₁ h₂ h₃ h₄ + +/-- **Extensionality for the even part of a product of super +vector spaces.** -/ +theorem superVectPairEven_ext {V W : SuperVect} {Z : Type*} + [AddCommGroup Z] [Module ℂ Z] {f g : (V ⊗ W).even →ₗ[ℂ] Z} + (h₁ : ∀ (a : V.even) (b : W.even), + f (svEvenInl (a ⊗ₜ[ℂ] b)) = g (svEvenInl (a ⊗ₜ[ℂ] b))) + (h₂ : ∀ (a : V.odd) (b : W.odd), + f (svEvenInr (a ⊗ₜ[ℂ] b)) = g (svEvenInr (a ⊗ₜ[ℂ] b))) : + f = g := + LinearMap.prod_ext (TensorProduct.ext' h₁) (TensorProduct.ext' h₂) + +/-- **Extensionality for the odd part of a product of super vector +spaces.** -/ +theorem superVectPairOdd_ext {V W : SuperVect} {Z : Type*} + [AddCommGroup Z] [Module ℂ Z] {f g : (V ⊗ W).odd →ₗ[ℂ] Z} + (h₁ : ∀ (a : V.even) (b : W.odd), + f (svOddInl (a ⊗ₜ[ℂ] b)) = g (svOddInl (a ⊗ₜ[ℂ] b))) + (h₂ : ∀ (a : V.odd) (b : W.even), + f (svOddInr (a ⊗ₜ[ℂ] b)) = g (svOddInr (a ⊗ₜ[ℂ] b))) : + f = g := + LinearMap.prod_ext (TensorProduct.ext' h₁) (TensorProduct.ext' h₂) + +end TripleExt + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Coherence.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Coherence.lean new file mode 100644 index 0000000000..34295c5e76 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Coherence.lean @@ -0,0 +1,1330 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Calculus + +/-! +# Coherence and invertibility of the comparison + +The comparison of [Comparison.lean](Comparison.lean) satisfies the +three laws of a lax monoidal structure and intertwines the +braidings: each is transported from the corresponding law over the +algebra, proved in [Residue.lean](Residue.lean), through the +coordinates, using the generator calculus of +[Calculus.lean](Calculus.lean). It is moreover invertible for +*every* pair of modules — the inverse built alongside it undoes it +on generators — as is the unit comparison; this is the usual +strength of base change along an algebra map, in super form. + +## Contents + +* `RS.superVectMu_associativity`, `RS.superVectMu_left_unitality`, + `RS.superVectMu_right_unitality`, `RS.superVectMu_braiding`: the + coherence of the comparison in `RS.SuperVect`. +* `RS.superVectMu_naturality_left`, + `RS.superVectMu_naturality_right`, + `RS.superVectMuEvenRaw_naturality` and its odd companion: + naturality in either variable, before and after the coordinates. +* `RS.superVectMuEvenRaw_baseNuEven`, + `RS.baseNuEven_superVectMuEvenRaw` and their odd companions: the + two composites of the comparison with its inverse. +* `RS.SuperVect.isoOfBijective`: a morphism of super vector spaces + with bijective components is an isomorphism. +* `RS.superVectEps`: the unit of the fibre functor. +* `RS.superVectMuIso`, `RS.isIso_superVectMu`, + `RS.superVectEpsIso`, `RS.isIso_superVectEps`: both comparisons + are invertible. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open SuperCommAlgebra (pointMod) +open SuperCommAlgebra.Mod + +universe u + +/-! ## Associativity of the comparison -/ + +section SuperVectAssoc + +open scoped TensorProduct + +attribute [local irreducible] superVectMu + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) + (M N Q : S.Mod.{u, u, u, u}) + +private theorem superVectMu_associativity_evenMap + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (Q.tensor (pointMod P)).even] + [FiniteDimensional ℂ (Q.tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((N.tensor Q).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((N.tensor Q).tensor (pointMod P)).odd] + [FiniteDimensional ℂ (((M.tensor N).tensor Q).tensor (pointMod P)).even] + [FiniteDimensional ℂ (((M.tensor N).tensor Q).tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((M.tensor (N.tensor Q)).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((M.tensor (N.tensor Q)).tensor (pointMod P)).odd] : + ((superVectMu P M N ▷ toSuperVect P Q) ≫ + superVectMu P (M.tensor N) Q ≫ + superVectHom P (α_ M N Q).hom).evenMap = + ((α_ (toSuperVect P M) (toSuperVect P N) + (toSuperVect P Q)).hom ≫ + (toSuperVect P M ◁ superVectMu P N Q) ≫ + superVectMu P M (N.tensor Q)).evenMap := by + refine superVectTripleEven_ext (fun a b c => ?_) (fun a b c => ?_) + (fun a b c => ?_) (fun a b c => ?_) + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.evenMap + (pointBaseMu_associativity P M N Q)) + (tmulEE ((M.tensor (pointMod P)).tensor (N.tensor (pointMod P))) + (Q.tensor (pointMod P)) + (tmulEE (M.tensor (pointMod P)) (N.tensor (pointMod P)) + ((toSuperVectEvenEquiv P M).symm a) + ((toSuperVectEvenEquiv P N).symm b)) + ((toSuperVectEvenEquiv P Q).symm c)) + simp only [modComp_evenMap_apply] at key + rw [whiskerRight_evenMap_tmulEE, modAssoc_evenMap_ee, + whiskerLeft_evenMap_tmulEE (pointBaseMu P N Q) + (M.tensor (pointMod P))] at key + simp only [svComp_evenMap_apply, + svWhiskerRight_evenMap_inl, + svWhiskerLeft_evenMap_inl, + svAssoc_evenMap_ee, + superVectMu_evenMap_ee, + superVectHom_evenMap_apply, + LinearEquiv.symm_apply_apply] + rw [key] + rfl + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.evenMap + (pointBaseMu_associativity P M N Q)) + (tmulEE ((M.tensor (pointMod P)).tensor (N.tensor (pointMod P))) + (Q.tensor (pointMod P)) + (tmulOO (M.tensor (pointMod P)) (N.tensor (pointMod P)) + ((toSuperVectOddEquiv P M).symm a) + ((toSuperVectOddEquiv P N).symm b)) + ((toSuperVectEvenEquiv P Q).symm c)) + simp only [modComp_evenMap_apply] at key + rw [whiskerRight_evenMap_tmulEE, modAssoc_evenMap_oo, + whiskerLeft_evenMap_tmulOO (pointBaseMu P N Q) + (M.tensor (pointMod P))] at key + simp only [svComp_evenMap_apply, + svWhiskerRight_evenMap_inl, + svWhiskerLeft_evenMap_inr, + svAssoc_evenMap_oo, + superVectMu_evenMap_ee, superVectMu_evenMap_oo, + superVectMu_oddMap_oe, + superVectHom_evenMap_apply, + LinearEquiv.symm_apply_apply] + rw [key] + rfl + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.evenMap + (pointBaseMu_associativity P M N Q)) + (tmulOO ((M.tensor (pointMod P)).tensor (N.tensor (pointMod P))) + (Q.tensor (pointMod P)) + (tmulEO (M.tensor (pointMod P)) (N.tensor (pointMod P)) + ((toSuperVectEvenEquiv P M).symm a) + ((toSuperVectOddEquiv P N).symm b)) + ((toSuperVectOddEquiv P Q).symm c)) + simp only [modComp_evenMap_apply] at key + rw [whiskerRight_evenMap_tmulOO, modAssoc_evenMap_eo, + whiskerLeft_evenMap_tmulEE (pointBaseMu P N Q) + (M.tensor (pointMod P))] at key + simp only [svComp_evenMap_apply, + svWhiskerRight_evenMap_inr, + svWhiskerLeft_evenMap_inl, + svAssoc_evenMap_eo, + superVectMu_evenMap_oo, + superVectMu_oddMap_eo, + superVectHom_evenMap_apply, + LinearEquiv.symm_apply_apply] + rw [key, superVectMu_evenMap_ee, + LinearEquiv.symm_apply_apply] + rfl + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.evenMap + (pointBaseMu_associativity P M N Q)) + (tmulOO ((M.tensor (pointMod P)).tensor (N.tensor (pointMod P))) + (Q.tensor (pointMod P)) + (tmulOE (M.tensor (pointMod P)) (N.tensor (pointMod P)) + ((toSuperVectOddEquiv P M).symm a) + ((toSuperVectEvenEquiv P N).symm b)) + ((toSuperVectOddEquiv P Q).symm c)) + simp only [modComp_evenMap_apply] at key + rw [whiskerRight_evenMap_tmulOO, modAssoc_evenMap_oe, + whiskerLeft_evenMap_tmulOO (pointBaseMu P N Q) + (M.tensor (pointMod P))] at key + simp only [svComp_evenMap_apply, + svWhiskerRight_evenMap_inr, + svWhiskerLeft_evenMap_inr, + svAssoc_evenMap_oe, + superVectMu_evenMap_oo, + superVectMu_oddMap_eo, superVectMu_oddMap_oe, + superVectHom_evenMap_apply, + LinearEquiv.symm_apply_apply] + rw [key] + rfl + +private theorem superVectMu_associativity_oddMap + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (Q.tensor (pointMod P)).even] + [FiniteDimensional ℂ (Q.tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((N.tensor Q).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((N.tensor Q).tensor (pointMod P)).odd] + [FiniteDimensional ℂ (((M.tensor N).tensor Q).tensor (pointMod P)).even] + [FiniteDimensional ℂ (((M.tensor N).tensor Q).tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((M.tensor (N.tensor Q)).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((M.tensor (N.tensor Q)).tensor (pointMod P)).odd] : + ((superVectMu P M N ▷ toSuperVect P Q) ≫ + superVectMu P (M.tensor N) Q ≫ + superVectHom P (α_ M N Q).hom).oddMap = + ((α_ (toSuperVect P M) (toSuperVect P N) + (toSuperVect P Q)).hom ≫ + (toSuperVect P M ◁ superVectMu P N Q) ≫ + superVectMu P M (N.tensor Q)).oddMap := by + refine superVectTripleOdd_ext (fun a b c => ?_) (fun a b c => ?_) + (fun a b c => ?_) (fun a b c => ?_) + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.oddMap + (pointBaseMu_associativity P M N Q)) + (tmulEO ((M.tensor (pointMod P)).tensor (N.tensor (pointMod P))) + (Q.tensor (pointMod P)) + (tmulEE (M.tensor (pointMod P)) (N.tensor (pointMod P)) + ((toSuperVectEvenEquiv P M).symm a) + ((toSuperVectEvenEquiv P N).symm b)) + ((toSuperVectOddEquiv P Q).symm c)) + simp only [modComp_oddMap_apply] at key + rw [whiskerRight_oddMap_tmulEO, modAssoc_oddMap_ee, + whiskerLeft_oddMap_tmulEO (pointBaseMu P N Q) + (M.tensor (pointMod P))] at key + simp only [ svComp_oddMap_apply, + svWhiskerRight_oddMap_inl, + svWhiskerLeft_oddMap_inl, + svAssoc_oddMap_ee, + superVectMu_evenMap_ee, + superVectMu_oddMap_eo, + superVectHom_oddMap_apply, + LinearEquiv.symm_apply_apply] + rw [key] + rfl + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.oddMap + (pointBaseMu_associativity P M N Q)) + (tmulEO ((M.tensor (pointMod P)).tensor (N.tensor (pointMod P))) + (Q.tensor (pointMod P)) + (tmulOO (M.tensor (pointMod P)) (N.tensor (pointMod P)) + ((toSuperVectOddEquiv P M).symm a) + ((toSuperVectOddEquiv P N).symm b)) + ((toSuperVectOddEquiv P Q).symm c)) + simp only [modComp_oddMap_apply] at key + rw [whiskerRight_oddMap_tmulEO, modAssoc_oddMap_oo, + whiskerLeft_oddMap_tmulOE (pointBaseMu P N Q) + (M.tensor (pointMod P))] at key + simp only [ svComp_oddMap_apply, + svWhiskerRight_oddMap_inl, + svWhiskerLeft_oddMap_inr, + svAssoc_oddMap_oo, + superVectMu_evenMap_oo, + superVectMu_oddMap_eo, + superVectHom_oddMap_apply, + LinearEquiv.symm_apply_apply] + rw [key, superVectMu_oddMap_oe, + LinearEquiv.symm_apply_apply] + rfl + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.oddMap + (pointBaseMu_associativity P M N Q)) + (tmulOE ((M.tensor (pointMod P)).tensor (N.tensor (pointMod P))) + (Q.tensor (pointMod P)) + (tmulEO (M.tensor (pointMod P)) (N.tensor (pointMod P)) + ((toSuperVectEvenEquiv P M).symm a) + ((toSuperVectOddEquiv P N).symm b)) + ((toSuperVectEvenEquiv P Q).symm c)) + simp only [modComp_oddMap_apply] at key + rw [whiskerRight_oddMap_tmulOE, modAssoc_oddMap_eo, + whiskerLeft_oddMap_tmulEO (pointBaseMu P N Q) + (M.tensor (pointMod P))] at key + simp only [ svComp_oddMap_apply, + svWhiskerRight_oddMap_inr, + svWhiskerLeft_oddMap_inl, + svAssoc_oddMap_eo, + superVectMu_oddMap_eo, superVectMu_oddMap_oe, + superVectHom_oddMap_apply, + LinearEquiv.symm_apply_apply] + rw [key] + rfl + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.oddMap + (pointBaseMu_associativity P M N Q)) + (tmulOE ((M.tensor (pointMod P)).tensor (N.tensor (pointMod P))) + (Q.tensor (pointMod P)) + (tmulOE (M.tensor (pointMod P)) (N.tensor (pointMod P)) + ((toSuperVectOddEquiv P M).symm a) + ((toSuperVectEvenEquiv P N).symm b)) + ((toSuperVectEvenEquiv P Q).symm c)) + simp only [modComp_oddMap_apply] at key + rw [whiskerRight_oddMap_tmulOE, modAssoc_oddMap_oe, + whiskerLeft_oddMap_tmulOE (pointBaseMu P N Q) + (M.tensor (pointMod P))] at key + simp only [ svComp_oddMap_apply, + svWhiskerRight_oddMap_inr, + svWhiskerLeft_oddMap_inr, + svAssoc_oddMap_oe, + superVectMu_evenMap_ee, + superVectMu_oddMap_oe, + superVectHom_oddMap_apply, + LinearEquiv.symm_apply_apply] + rw [key] + rfl + +/-- **Associativity of the monoidal comparison.** -/ +@[reassoc] +theorem superVectMu_associativity + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (Q.tensor (pointMod P)).even] + [FiniteDimensional ℂ (Q.tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((N.tensor Q).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((N.tensor Q).tensor (pointMod P)).odd] + [FiniteDimensional ℂ (((M.tensor N).tensor Q).tensor (pointMod P)).even] + [FiniteDimensional ℂ (((M.tensor N).tensor Q).tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((M.tensor (N.tensor Q)).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((M.tensor (N.tensor Q)).tensor (pointMod P)).odd] : + (superVectMu P M N ▷ toSuperVect P Q) ≫ + superVectMu P (M.tensor N) Q ≫ + superVectHom P (α_ M N Q).hom = + (α_ (toSuperVect P M) (toSuperVect P N) + (toSuperVect P Q)).hom ≫ + (toSuperVect P M ◁ superVectMu P N Q) ≫ + superVectMu P M (N.tensor Q) := by + exact SuperVect.hom_ext (superVectMu_associativity_evenMap P M N Q) + (superVectMu_associativity_oddMap P M N Q) + +end SuperVectAssoc + +/-! ## Naturality of the comparison in super vector spaces -/ + +section SuperVectNaturality + +open scoped TensorProduct + +attribute [local irreducible] superVectMu + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) + {M M' N N' : S.Mod.{u, u, u, u}} + +/-- **The comparison is natural in the left variable.** -/ +theorem superVectMu_naturality_left + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (M'.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M'.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((M'.tensor N).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((M'.tensor N).tensor (pointMod P)).odd] + (f : M ⟶ M') : + (superVectHom P f ▷ toSuperVect P N) ≫ superVectMu P M' N = + superVectMu P M N ≫ superVectHom P (f ▷ N) := by + refine SuperVect.hom_ext + (superVectPairEven_ext (fun x y => ?_) (fun x y => ?_)) + (superVectPairOdd_ext (fun x y => ?_) (fun x y => ?_)) + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.evenMap + (pointBaseMu_naturality P f (𝟙 N))) + (tmulEE (M ⊗ pointMod P) (N ⊗ pointMod P) + ((toSuperVectEvenEquiv P M).symm x) + ((toSuperVectEvenEquiv P N).symm y)) + simp only [modComp_evenMap_apply] at key + rw [mcTensorHom_evenMap_tmulEE, + MonoidalCategory.id_tensorHom_id, id_evenMap, + LinearMap.id_coe, id_eq, MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_id] at key + simp only [modTensorObj] at key + simp only [svComp_evenMap_apply] + rw [svWhiskerRight_evenMap_inl, superVectHom_evenMap_apply, + superVectMu_evenMap_ee, LinearEquiv.symm_apply_apply, + superVectMu_evenMap_ee, superVectHom_evenMap_apply, + LinearEquiv.symm_apply_apply, key] + rfl + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.evenMap + (pointBaseMu_naturality P f (𝟙 N))) + (tmulOO (M ⊗ pointMod P) (N ⊗ pointMod P) + ((toSuperVectOddEquiv P M).symm x) + ((toSuperVectOddEquiv P N).symm y)) + simp only [modComp_evenMap_apply] at key + rw [mcTensorHom_evenMap_tmulOO, MonoidalCategory.id_tensorHom_id, id_oddMap, + LinearMap.id_coe, id_eq, MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_id] at key + simp only [modTensorObj] at key + simp only [svComp_evenMap_apply] + rw [svWhiskerRight_evenMap_inr, superVectHom_oddMap_apply, + superVectMu_evenMap_oo, LinearEquiv.symm_apply_apply, + superVectMu_evenMap_oo, superVectHom_evenMap_apply, + LinearEquiv.symm_apply_apply, key] + rfl + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.oddMap + (pointBaseMu_naturality P f (𝟙 N))) + (tmulEO (M ⊗ pointMod P) (N ⊗ pointMod P) + ((toSuperVectEvenEquiv P M).symm x) + ((toSuperVectOddEquiv P N).symm y)) + simp only [modComp_oddMap_apply] at key + rw [mcTensorHom_oddMap_tmulEO, MonoidalCategory.id_tensorHom_id, id_oddMap, + LinearMap.id_coe, id_eq, MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_id] at key + simp only [modTensorObj] at key + simp only [svComp_oddMap_apply] + rw [svWhiskerRight_oddMap_inl, superVectHom_evenMap_apply, + superVectMu_oddMap_eo, LinearEquiv.symm_apply_apply, + superVectMu_oddMap_eo, superVectHom_oddMap_apply, + LinearEquiv.symm_apply_apply, key] + rfl + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.oddMap + (pointBaseMu_naturality P f (𝟙 N))) + (tmulOE (M ⊗ pointMod P) (N ⊗ pointMod P) + ((toSuperVectOddEquiv P M).symm x) + ((toSuperVectEvenEquiv P N).symm y)) + simp only [modComp_oddMap_apply] at key + rw [mcTensorHom_oddMap_tmulOE, MonoidalCategory.id_tensorHom_id, id_evenMap, + LinearMap.id_coe, id_eq, MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_id] at key + simp only [modTensorObj] at key + simp only [svComp_oddMap_apply] + rw [svWhiskerRight_oddMap_inr, superVectHom_oddMap_apply, + superVectMu_oddMap_oe, LinearEquiv.symm_apply_apply, + superVectMu_oddMap_oe, superVectHom_oddMap_apply, + LinearEquiv.symm_apply_apply, key] + rfl + +/-- **The comparison is natural in the right variable.** -/ +theorem superVectMu_naturality_right + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N'.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N'.tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((M.tensor N').tensor (pointMod P)).even] + [FiniteDimensional ℂ ((M.tensor N').tensor (pointMod P)).odd] + (g : N ⟶ N') : + (toSuperVect P M ◁ superVectHom P g) ≫ superVectMu P M N' = + superVectMu P M N ≫ superVectHom P (M ◁ g) := by + refine SuperVect.hom_ext + (superVectPairEven_ext (fun x y => ?_) (fun x y => ?_)) + (superVectPairOdd_ext (fun x y => ?_) (fun x y => ?_)) + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.evenMap + (pointBaseMu_naturality P (𝟙 M) g)) + (tmulEE (M ⊗ pointMod P) (N ⊗ pointMod P) + ((toSuperVectEvenEquiv P M).symm x) + ((toSuperVectEvenEquiv P N).symm y)) + simp only [modComp_evenMap_apply] at key + rw [mcTensorHom_evenMap_tmulEE, + MonoidalCategory.id_tensorHom_id, id_evenMap, + LinearMap.id_coe, id_eq, MonoidalCategory.tensorHom_id, + MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_id] at key + simp only [modTensorObj] at key + simp only [svComp_evenMap_apply] + rw [svWhiskerLeft_evenMap_inl, superVectHom_evenMap_apply, + superVectMu_evenMap_ee, LinearEquiv.symm_apply_apply, + superVectMu_evenMap_ee, superVectHom_evenMap_apply, + LinearEquiv.symm_apply_apply, key] + rfl + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.evenMap + (pointBaseMu_naturality P (𝟙 M) g)) + (tmulOO (M ⊗ pointMod P) (N ⊗ pointMod P) + ((toSuperVectOddEquiv P M).symm x) + ((toSuperVectOddEquiv P N).symm y)) + simp only [modComp_evenMap_apply] at key + rw [mcTensorHom_evenMap_tmulOO, MonoidalCategory.id_tensorHom_id, id_oddMap, + LinearMap.id_coe, id_eq, MonoidalCategory.tensorHom_id, + MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_id] at key + simp only [modTensorObj] at key + simp only [svComp_evenMap_apply] + rw [svWhiskerLeft_evenMap_inr, superVectHom_oddMap_apply, + superVectMu_evenMap_oo, LinearEquiv.symm_apply_apply, + superVectMu_evenMap_oo, superVectHom_evenMap_apply, + LinearEquiv.symm_apply_apply, key] + rfl + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.oddMap + (pointBaseMu_naturality P (𝟙 M) g)) + (tmulEO (M ⊗ pointMod P) (N ⊗ pointMod P) + ((toSuperVectEvenEquiv P M).symm x) + ((toSuperVectOddEquiv P N).symm y)) + simp only [modComp_oddMap_apply] at key + rw [mcTensorHom_oddMap_tmulEO, MonoidalCategory.id_tensorHom_id, id_evenMap, + LinearMap.id_coe, id_eq, MonoidalCategory.tensorHom_id, + MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_id] at key + simp only [modTensorObj] at key + simp only [svComp_oddMap_apply] + rw [svWhiskerLeft_oddMap_inl, superVectHom_oddMap_apply, + superVectMu_oddMap_eo, LinearEquiv.symm_apply_apply, + superVectMu_oddMap_eo, superVectHom_oddMap_apply, + LinearEquiv.symm_apply_apply, key] + rfl + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.oddMap + (pointBaseMu_naturality P (𝟙 M) g)) + (tmulOE (M ⊗ pointMod P) (N ⊗ pointMod P) + ((toSuperVectOddEquiv P M).symm x) + ((toSuperVectEvenEquiv P N).symm y)) + simp only [modComp_oddMap_apply] at key + rw [mcTensorHom_oddMap_tmulOE, MonoidalCategory.id_tensorHom_id, id_oddMap, + LinearMap.id_coe, id_eq, MonoidalCategory.tensorHom_id, + MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_id] at key + simp only [modTensorObj] at key + simp only [svComp_oddMap_apply] + rw [svWhiskerLeft_oddMap_inr, superVectHom_evenMap_apply, + superVectMu_oddMap_oe, LinearEquiv.symm_apply_apply, + superVectMu_oddMap_oe, superVectHom_oddMap_apply, + LinearEquiv.symm_apply_apply, key] + rfl + +end SuperVectNaturality + +/-! ## The comparison is invertible -/ + +section Invertible + +open scoped TensorProduct + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) + (M N : S.Mod.{u, u, u, u}) + +/-- A residue class is its own coordinate times the unit. -/ +theorem pointEven_eq_smul_one (a : (pointMod P : S.Mod.{u, u, u, u}).even) : + a = a.down • pointOne P := + ULift.ext _ _ (by + change a.down = a.down * 1 + rw [mul_one]) + +/-- The unit of the residue module is idempotent. -/ +theorem pointOne_mul_self : + (ULift.up ((pointOne P).down * (pointOne P).down) : + (pointMod P : S.Mod.{u, u, u, u}).even) = pointOne P := + ULift.ext _ _ (by + change (1 : ℂ) * 1 = 1 + rw [one_mul]) + +variable {M N} + +/-- An even product with a residue class is a multiple of the +product with the unit. -/ +theorem tmulEE_point_eq_smul (m : M.even) + (a : (pointMod P : S.Mod.{u, u, u, u}).even) : + tmulEE M (pointMod P) m a = + a.down • tmulEE M (pointMod P) m (pointOne P) := by + rw [← map_smul] + exact congrArg _ (pointEven_eq_smul_one P a) + +/-- An odd product with a residue class is a multiple of the +product with the unit. -/ +theorem tmulOE_point_eq_smul (m : M.odd) + (a : (pointMod P : S.Mod.{u, u, u, u}).even) : + tmulOE M (pointMod P) m a = + a.down • tmulOE M (pointMod P) m (pointOne P) := by + rw [← map_smul] + exact congrArg _ (pointEven_eq_smul_one P a) + +variable (M N) + +/-- **The comparison undoes the inverse**, in even degree. -/ +theorem superVectMuEvenRaw_baseNuEven (w : ((M.tensor N).tensor (pointMod P) : + S.Mod.{u, u, u, u}).even) : + superVectMuEvenRaw P M N (baseNuEven P M N w) = w := by + refine LinearMap.congr_fun (liftEven_unique (M.tensor N) + (pointMod P) ((superVectMuEvenRaw P M N).comp + (baseNuEven P M N)) LinearMap.id (fun t a => ?_) + (fun t v => ?_)) w + · change superVectMuEvenRaw P M N + (baseNuEven P M N (tmulEE (M.tensor N) (pointMod P) t a)) + = tmulEE (M.tensor N) (pointMod P) t a + rw [baseNuEven_tmulEE] + refine LinearMap.congr_fun (liftEven_unique M N + ((superVectMuEvenRaw P M N).comp + ((baseNuInnerEven P M N).flip a)) + ((tmulEE (M.tensor N) (pointMod P)).flip a) + (fun m n => ?_) (fun m n => ?_)) t + · change superVectMuEvenRaw P M N (baseNuFee P M N m n a) = _ + rw [baseNuFee_apply, map_smul] + change a.down • (pointBaseMu P M N).evenMap + (tmulEE (M.tensor (pointMod P)) (N.tensor (pointMod P)) + (tmulEE M (pointMod P) m (pointOne P)) + (tmulEE N (pointMod P) n (pointOne P))) = _ + rw [pointBaseMu_evenMap_ee, pointOne_mul_self, ← map_smul] + exact congrArg _ (pointEven_eq_smul_one P a).symm + · change superVectMuEvenRaw P M N (baseNuFoo P M N m n a) = _ + rw [baseNuFoo_apply, map_smul] + change a.down • (pointBaseMu P M N).evenMap + (tmulOO (M.tensor (pointMod P)) (N.tensor (pointMod P)) + (tmulOE M (pointMod P) m (pointOne P)) + (tmulOE N (pointMod P) n (pointOne P))) = _ + rw [pointBaseMu_evenMap_oo, pointOne_mul_self, ← map_smul] + exact congrArg _ (pointEven_eq_smul_one P a).symm + · rw [pointMod_odd_eq_zero P v, map_zero] + change superVectMuEvenRaw P M N (baseNuEven P M N 0) = 0 + rw [map_zero, map_zero] + +/-- **The comparison undoes the inverse**, in odd degree. -/ +theorem superVectMuOddRaw_baseNuOdd (w : ((M.tensor N).tensor (pointMod P) : + S.Mod.{u, u, u, u}).odd) : + superVectMuOddRaw P M N (baseNuOdd P M N w) = w := by + refine LinearMap.congr_fun (liftOdd_unique (M.tensor N) + (pointMod P) ((superVectMuOddRaw P M N).comp + (baseNuOdd P M N)) LinearMap.id (fun t v => ?_) + (fun t a => ?_)) w + · rw [pointMod_odd_eq_zero P v, map_zero] + change superVectMuOddRaw P M N (baseNuOdd P M N 0) = 0 + rw [map_zero, map_zero] + · change superVectMuOddRaw P M N + (baseNuOdd P M N (tmulOE (M.tensor N) (pointMod P) t a)) + = tmulOE (M.tensor N) (pointMod P) t a + rw [baseNuOdd_tmulOE] + refine LinearMap.congr_fun (liftOdd_unique M N + ((superVectMuOddRaw P M N).comp + ((baseNuInnerOdd P M N).flip a)) + ((tmulOE (M.tensor N) (pointMod P)).flip a) + (fun m n => ?_) (fun m n => ?_)) t + · change superVectMuOddRaw P M N (baseNuFeo P M N m n a) = _ + rw [baseNuFeo_apply, map_smul] + change a.down • (pointBaseMu P M N).oddMap + (tmulEO (M.tensor (pointMod P)) (N.tensor (pointMod P)) + (tmulEE M (pointMod P) m (pointOne P)) + (tmulOE N (pointMod P) n (pointOne P))) = _ + rw [pointBaseMu_oddMap_eo, pointOne_mul_self, ← map_smul] + exact congrArg _ (pointEven_eq_smul_one P a).symm + · change superVectMuOddRaw P M N (baseNuFoe P M N m n a) = _ + rw [baseNuFoe_apply, map_smul] + change a.down • (pointBaseMu P M N).oddMap + (tmulOE (M.tensor (pointMod P)) (N.tensor (pointMod P)) + (tmulOE M (pointMod P) m (pointOne P)) + (tmulEE N (pointMod P) n (pointOne P))) = _ + rw [pointBaseMu_oddMap_oe, pointOne_mul_self, ← map_smul] + exact congrArg _ (pointEven_eq_smul_one P a).symm + +/-- A scaled pure tensor in the first summand of a pair. -/ +theorem smulPairInl {X Y Z : Type*} [AddCommGroup X] [Module ℂ X] + [AddCommGroup Y] [Module ℂ Y] [AddCommGroup Z] [Module ℂ Z] + (c d : ℂ) (x : X) (y : Y) : + (c * d) • ((x ⊗ₜ[ℂ] y, (0 : Z))) = + ((c • x) ⊗ₜ[ℂ] (d • y), (0 : Z)) := by + have h : (c • x) ⊗ₜ[ℂ] (d • y) = (c * d) • (x ⊗ₜ[ℂ] y) := by + rw [TensorProduct.tmul_smul, ← TensorProduct.smul_tmul', + smul_smul, mul_comm] + rw [h, Prod.smul_mk, smul_zero] + +/-- A scaled pure tensor in the second summand of a pair. -/ +theorem smulPairInr {X Y Z : Type*} [AddCommGroup X] [Module ℂ X] + [AddCommGroup Y] [Module ℂ Y] [AddCommGroup Z] [Module ℂ Z] + (c d : ℂ) (x : X) (y : Y) : + (c * d) • (((0 : Z), x ⊗ₜ[ℂ] y)) = + ((0 : Z), (c • x) ⊗ₜ[ℂ] (d • y)) := by + have h : (c • x) ⊗ₜ[ℂ] (d • y) = (c * d) • (x ⊗ₜ[ℂ] y) := by + rw [TensorProduct.tmul_smul, ← TensorProduct.smul_tmul', + smul_smul, mul_comm] + rw [h, Prod.smul_mk, smul_zero] + +/-! ### The inverse undoes the comparison -/ + +/-- The even-even half of the inverse identity. -/ +theorem baseNuEven_muRaw_inl : + LinearMap.compr₂ + (LinearMap.compr₂ (TensorProduct.mk ℂ + (M.tensor (pointMod P)).even + (N.tensor (pointMod P)).even) (LinearMap.inl ℂ _ _)) + ((baseNuEven P M N).comp (superVectMuEvenRaw P M N)) = + LinearMap.compr₂ (TensorProduct.mk ℂ + (M.tensor (pointMod P)).even + (N.tensor (pointMod P)).even) (LinearMap.inl ℂ _ _) := by + refine liftEven_unique M (pointMod P) _ _ (fun m a => ?_) + (fun m v => ?_) + · refine liftEven_unique N (pointMod P) _ _ (fun n b => ?_) + (fun n w => ?_) + · change baseNuEven P M N ((pointBaseMu P M N).evenMap + (gradedTensorEven (M.tensor (pointMod P)) + (N.tensor (pointMod P)) + (tmulEE M (pointMod P) m a ⊗ₜ[ℂ] + tmulEE N (pointMod P) n b, 0))) = _ + rw [gradedTensorEven_ee, pointBaseMu_evenMap_ee] + erw [baseNuEven_tmulEE, baseNuInnerEven_tmulEE, baseNuFee_apply] + change (a.down * b.down) • _ = _ + rw [tmulEE_point_eq_smul P m a, tmulEE_point_eq_smul P n b] + exact smulPairInl _ _ _ _ + · rw [pointMod_odd_eq_zero P w, map_zero, map_zero, map_zero] + · rw [pointMod_odd_eq_zero P v, map_zero, map_zero, map_zero] + +/-- The odd-odd half of the inverse identity in even degree. -/ +theorem baseNuEven_muRaw_inr : + LinearMap.compr₂ + (LinearMap.compr₂ (TensorProduct.mk ℂ + (M.tensor (pointMod P)).odd + (N.tensor (pointMod P)).odd) (LinearMap.inr ℂ _ _)) + ((baseNuEven P M N).comp (superVectMuEvenRaw P M N)) = + LinearMap.compr₂ (TensorProduct.mk ℂ + (M.tensor (pointMod P)).odd + (N.tensor (pointMod P)).odd) (LinearMap.inr ℂ _ _) := by + refine liftOdd_unique M (pointMod P) _ _ (fun m v => ?_) + (fun m a => ?_) + · rw [pointMod_odd_eq_zero P v, map_zero, map_zero, map_zero] + · refine liftOdd_unique N (pointMod P) _ _ (fun n w => ?_) + (fun n b => ?_) + · rw [pointMod_odd_eq_zero P w, map_zero, map_zero, map_zero] + · change baseNuEven P M N ((pointBaseMu P M N).evenMap + (gradedTensorEven (M.tensor (pointMod P)) + (N.tensor (pointMod P)) + (0, tmulOE M (pointMod P) m a ⊗ₜ[ℂ] + tmulOE N (pointMod P) n b))) = _ + rw [gradedTensorEven_oo, pointBaseMu_evenMap_oo] + erw [baseNuEven_tmulEE, baseNuInnerEven_tmulOO, baseNuFoo_apply] + change (a.down * b.down) • _ = _ + rw [tmulOE_point_eq_smul P m a, tmulOE_point_eq_smul P n b] + exact smulPairInr _ _ _ _ + +/-- The even-odd half of the inverse identity in odd degree. -/ +theorem baseNuOdd_muRaw_inl : + LinearMap.compr₂ + (LinearMap.compr₂ (TensorProduct.mk ℂ + (M.tensor (pointMod P)).even + (N.tensor (pointMod P)).odd) (LinearMap.inl ℂ _ _)) + ((baseNuOdd P M N).comp (superVectMuOddRaw P M N)) = + LinearMap.compr₂ (TensorProduct.mk ℂ + (M.tensor (pointMod P)).even + (N.tensor (pointMod P)).odd) (LinearMap.inl ℂ _ _) := by + refine liftEven_unique M (pointMod P) _ _ (fun m a => ?_) + (fun m v => ?_) + · refine liftOdd_unique N (pointMod P) _ _ (fun n w => ?_) + (fun n b => ?_) + · rw [pointMod_odd_eq_zero P w, map_zero, map_zero, map_zero] + · change baseNuOdd P M N ((pointBaseMu P M N).oddMap + (gradedTensorOdd (M.tensor (pointMod P)) + (N.tensor (pointMod P)) + (tmulEE M (pointMod P) m a ⊗ₜ[ℂ] + tmulOE N (pointMod P) n b, 0))) = _ + rw [gradedTensorOdd_eo, pointBaseMu_oddMap_eo] + erw [baseNuOdd_tmulOE, baseNuInnerOdd_tmulEO, baseNuFeo_apply] + change (a.down * b.down) • _ = _ + rw [tmulEE_point_eq_smul P m a, tmulOE_point_eq_smul P n b] + exact smulPairInl _ _ _ _ + · rw [pointMod_odd_eq_zero P v, map_zero, map_zero, map_zero] + +/-- The odd-even half of the inverse identity in odd degree. -/ +theorem baseNuOdd_muRaw_inr : + LinearMap.compr₂ + (LinearMap.compr₂ (TensorProduct.mk ℂ + (M.tensor (pointMod P)).odd + (N.tensor (pointMod P)).even) (LinearMap.inr ℂ _ _)) + ((baseNuOdd P M N).comp (superVectMuOddRaw P M N)) = + LinearMap.compr₂ (TensorProduct.mk ℂ + (M.tensor (pointMod P)).odd + (N.tensor (pointMod P)).even) (LinearMap.inr ℂ _ _) := by + refine liftOdd_unique M (pointMod P) _ _ (fun m v => ?_) + (fun m a => ?_) + · rw [pointMod_odd_eq_zero P v, map_zero, map_zero, map_zero] + · refine liftEven_unique N (pointMod P) _ _ (fun n b => ?_) + (fun n w => ?_) + · change baseNuOdd P M N ((pointBaseMu P M N).oddMap + (gradedTensorOdd (M.tensor (pointMod P)) + (N.tensor (pointMod P)) + (0, tmulOE M (pointMod P) m a ⊗ₜ[ℂ] + tmulEE N (pointMod P) n b))) = _ + rw [gradedTensorOdd_oe, pointBaseMu_oddMap_oe] + erw [baseNuOdd_tmulOE, baseNuInnerOdd_tmulOE, baseNuFoe_apply] + change (a.down * b.down) • _ = _ + rw [tmulOE_point_eq_smul P m a, tmulEE_point_eq_smul P n b] + exact smulPairInr _ _ _ _ + · rw [pointMod_odd_eq_zero P w, map_zero, map_zero, map_zero] + +/-- **The inverse undoes the comparison**, in even degree. -/ +theorem baseNuEven_superVectMuEvenRaw (z : basePairEven P M N) : + baseNuEven P M N (superVectMuEvenRaw P M N z) = z := by + have h : (baseNuEven P M N).comp (superVectMuEvenRaw P M N) + = LinearMap.id := by + refine LinearMap.prod_ext ?_ ?_ + · exact TensorProduct.ext' fun x y => LinearMap.congr_fun + (LinearMap.congr_fun (baseNuEven_muRaw_inl P M N) x) y + · exact TensorProduct.ext' fun x y => LinearMap.congr_fun + (LinearMap.congr_fun (baseNuEven_muRaw_inr P M N) x) y + exact LinearMap.congr_fun h z + +/-- **The inverse undoes the comparison**, in odd degree. -/ +theorem baseNuOdd_superVectMuOddRaw (z : basePairOdd P M N) : + baseNuOdd P M N (superVectMuOddRaw P M N z) = z := by + have h : (baseNuOdd P M N).comp (superVectMuOddRaw P M N) + = LinearMap.id := by + refine LinearMap.prod_ext ?_ ?_ + · exact TensorProduct.ext' fun x y => LinearMap.congr_fun + (LinearMap.congr_fun (baseNuOdd_muRaw_inl P M N) x) y + · exact TensorProduct.ext' fun x y => LinearMap.congr_fun + (LinearMap.congr_fun (baseNuOdd_muRaw_inr P M N) x) y + exact LinearMap.congr_fun h z + +end Invertible + +/-! ## The comparison is an isomorphism -/ + +section MuIso + +open scoped TensorProduct + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) + +/-- **A morphism of super vector spaces with bijective components +is an isomorphism.** -/ +noncomputable def SuperVect.isoOfBijective {V W : SuperVect} + (f : V ⟶ W) (he : Function.Bijective (f : V.Hom W).evenMap) + (ho : Function.Bijective (f : V.Hom W).oddMap) : V ≅ W where + hom := f + inv := + { evenMap := (LinearEquiv.ofBijective + (f : V.Hom W).evenMap he).symm.toLinearMap + oddMap := (LinearEquiv.ofBijective + (f : V.Hom W).oddMap ho).symm.toLinearMap } + hom_inv_id := SuperVect.hom_ext + (LinearMap.ext fun x => LinearEquiv.symm_apply_apply + (LinearEquiv.ofBijective (f : V.Hom W).evenMap he) x) + (LinearMap.ext fun x => LinearEquiv.symm_apply_apply + (LinearEquiv.ofBijective (f : V.Hom W).oddMap ho) x) + inv_hom_id := SuperVect.hom_ext + (LinearMap.ext fun x => LinearEquiv.apply_symm_apply + (LinearEquiv.ofBijective (f : V.Hom W).evenMap he) x) + (LinearMap.ext fun x => LinearEquiv.apply_symm_apply + (LinearEquiv.ofBijective (f : V.Hom W).oddMap ho) x) + +variable (M N : S.Mod.{u, u, u, u}) + +/-- **The raw comparison is bijective in even degree.** -/ +theorem superVectMuEvenRaw_bijective : + Function.Bijective (superVectMuEvenRaw P M N) := + Function.bijective_iff_has_inverse.mpr + ⟨baseNuEven P M N, baseNuEven_superVectMuEvenRaw P M N, + superVectMuEvenRaw_baseNuEven P M N⟩ + +/-- **The raw comparison is bijective in odd degree.** -/ +theorem superVectMuOddRaw_bijective : + Function.Bijective (superVectMuOddRaw P M N) := + Function.bijective_iff_has_inverse.mpr + ⟨baseNuOdd P M N, baseNuOdd_superVectMuOddRaw P M N, + superVectMuOddRaw_baseNuOdd P M N⟩ + +/-- The even component of the comparison is bijective. -/ +theorem superVectMu_evenMap_bijective + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).odd] : + Function.Bijective (superVectMu P M N).evenMap := by + have h : ⇑(superVectMu P M N).evenMap = + (⇑(toSuperVectEvenEquiv P (M.tensor N)) ∘ + ⇑(superVectMuEvenRaw P M N)) ∘ + ⇑(superVectPairEvenEquiv P M N).symm := rfl + rw [h] + exact Function.Bijective.comp + (Function.Bijective.comp + (toSuperVectEvenEquiv P (M.tensor N)).bijective + (superVectMuEvenRaw_bijective P M N)) + (superVectPairEvenEquiv P M N).symm.bijective + +/-- The odd component of the comparison is bijective. -/ +theorem superVectMu_oddMap_bijective + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).odd] : + Function.Bijective (superVectMu P M N).oddMap := by + have h : ⇑(superVectMu P M N).oddMap = + (⇑(toSuperVectOddEquiv P (M.tensor N)) ∘ + ⇑(superVectMuOddRaw P M N)) ∘ + ⇑(superVectPairOddEquiv P M N).symm := rfl + rw [h] + exact Function.Bijective.comp + (Function.Bijective.comp + (toSuperVectOddEquiv P (M.tensor N)).bijective + (superVectMuOddRaw_bijective P M N)) + (superVectPairOddEquiv P M N).symm.bijective + +/-- **The monoidal comparison is an isomorphism of super vector +spaces**: base change at a complex point is strong, not merely +lax. -/ +noncomputable def superVectMuIso + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).odd] : + toSuperVect P M ⊗ toSuperVect P N ≅ toSuperVect P (M.tensor N) := + SuperVect.isoOfBijective (superVectMu P M N) + (superVectMu_evenMap_bijective P M N) + (superVectMu_oddMap_bijective P M N) + +/-- **The monoidal comparison is invertible.** -/ +instance isIso_superVectMu [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).odd] : + IsIso (superVectMu P M N) := + (superVectMuIso P M N).isIso_hom + +end MuIso + +section SuperVectUnit + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) + +/-- **The unit comparison of the fibre functor**, before the +coordinates are installed: a complex number is scaled into the +algebra and pushed into the base change. -/ +noncomputable def superVectEpsRaw : + ℂ →ₗ[ℂ] ((S.unitMod : S.Mod.{u, u, u, u}).tensor + (pointMod P)).even := + (pointBaseEps P).evenMap ∘ₗ + LinearMap.toSpanSingleton ℂ S.even S.one + +/-- **The unit comparison of the fibre functor**: the unit super +vector space maps to the base change of the unit module. -/ +noncomputable def superVectEps + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).even] + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).odd] : + 𝟙_ SuperVect ⟶ toSuperVect P (S.unitMod : S.Mod.{u, u, u, u}) where + evenMap := + LinearMap.comp + (toSuperVectEvenEquiv P + (S.unitMod : S.Mod.{u, u, u, u})).toLinearMap + (superVectEpsRaw P) + oddMap := 0 + +/-- The raw unit comparison, evaluated. -/ +theorem superVectEpsRaw_apply (r : ℂ) : + superVectEpsRaw P r = + (pointBaseEps P).evenMap + (LinearMap.toSpanSingleton ℂ S.even S.one r) := rfl + +/-- The unit comparison, evaluated. -/ +theorem superVectEps_evenMap_apply + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).even] + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).odd] + (r : ℂ) : + (superVectEps P).evenMap r = + toSuperVectEvenEquiv P (S.unitMod : S.Mod.{u, u, u, u}) + (superVectEpsRaw P r) := rfl + +end SuperVectUnit + +/-! ## The unit comparison is an isomorphism -/ + +section EpsIso + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) + +/-- **The unit comparison, read through the left unitor**, is the +canonical copy of a complex number in the residue module. -/ +theorem unitTensorPoint_superVectEpsRaw (c : ℂ) : + (unitTensorPoint P).hom.evenMap (superVectEpsRaw P c) = + ULift.up c := by + have h1 : (pointBaseEps P).evenMap (c • S.one) = + tmulEE (S.unitMod : S.Mod.{u, u, u, u}) (pointMod P) + (c • S.one) (pointOne P) := by + change (SuperCommAlgebra.Mod.tensorHom (𝟙 S.unitMod) + (pointUnitHom P)).evenMap + ((rightUnitorInv (S.unitMod : S.Mod.{u, u, u, u})).evenMap + (c • S.one)) = _ + rw [rightUnitorInv_evenMap, tensorHom_evenMap_tmulEE, + pointUnitHom_evenMap] + change tmulEE (S.unitMod : S.Mod.{u, u, u, u}) (pointMod P) + (LinearMap.id (c • S.one)) (ULift.up (P.chi 1)) = _ + rw [map_one] + rfl + change (leftUnitorHom (pointMod P)).evenMap + ((pointBaseEps P).evenMap (c • S.one)) = _ + rw [h1, leftUnitorHom_evenMap_tmulEE] + refine ULift.ext _ _ ?_ + change P.chi (c • S.one) * 1 = c + rw [mul_one, map_smul] + change c * P.chi 1 = c + rw [map_one, mul_one] + +/-- **The raw unit comparison is bijective.** -/ +theorem superVectEpsRaw_bijective : + Function.Bijective (superVectEpsRaw P) := by + rw [← Function.Bijective.of_comp_iff' + (evenEquiv (unitTensorPoint P)).bijective (superVectEpsRaw P)] + have h : ⇑(evenEquiv (unitTensorPoint P)) ∘ ⇑(superVectEpsRaw P) = + (ULift.up : ℂ → ULift.{u} ℂ) := + funext fun c => unitTensorPoint_superVectEpsRaw P c + rw [h] + exact (Equiv.ulift (α := ℂ)).symm.bijective + +/-- The odd part of the base change of the unit module vanishes. -/ +instance subsingleton_unitMod_tensor_point_odd : + Subsingleton ((S.unitMod : S.Mod.{u, u, u, u}).tensor + (pointMod P)).odd := + (oddEquiv (unitTensorPoint P)).toEquiv.subsingleton + +section EpsIsoSuper + +/-- The odd part of the fibre of the unit module vanishes. -/ +instance subsingleton_toSuperVect_unitMod_odd + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).even] + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).odd] : + Subsingleton + (toSuperVect P (S.unitMod : S.Mod.{u, u, u, u})).odd := + (toSuperVectOddEquiv P + (S.unitMod : S.Mod.{u, u, u, u})).symm.toEquiv.subsingleton + +/-- The even component of the unit comparison is bijective. -/ +theorem superVectEps_evenMap_bijective + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).even] + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).odd] : + Function.Bijective (superVectEps P).evenMap := by + have h : ⇑(superVectEps P).evenMap = + ⇑(toSuperVectEvenEquiv P (S.unitMod : S.Mod.{u, u, u, u})) ∘ + ⇑(superVectEpsRaw P) := rfl + rw [h] + exact Function.Bijective.comp + (toSuperVectEvenEquiv P + (S.unitMod : S.Mod.{u, u, u, u})).bijective + (superVectEpsRaw_bijective P) + +/-- The odd component of the unit comparison is bijective: both +sides vanish. -/ +theorem superVectEps_oddMap_bijective + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).even] + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).odd] : + Function.Bijective (superVectEps P).oddMap := by + have : Subsingleton (𝟙_ SuperVect).odd := + (inferInstance : Subsingleton PUnit.{1}) + exact ⟨fun _ _ _ => Subsingleton.elim _ _, + fun y => ⟨0, Subsingleton.elim _ y⟩⟩ + +/-- **The unit comparison is an isomorphism of super vector +spaces.** -/ +noncomputable def superVectEpsIso + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).even] + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).odd] : + 𝟙_ SuperVect ≅ toSuperVect P (S.unitMod : S.Mod.{u, u, u, u}) := + SuperVect.isoOfBijective (superVectEps P) + (superVectEps_evenMap_bijective P) + (superVectEps_oddMap_bijective P) + +/-- **The unit comparison is invertible.** -/ +instance isIso_superVectEps + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).even] + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).odd] : IsIso (superVectEps P) := + (superVectEpsIso P).isIso_hom + +end EpsIsoSuper + +end EpsIso + +/-! ## Unitality of the comparison -/ + +section SuperVectUnitality + +open scoped TensorProduct + +attribute [local irreducible] superVectMu + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) + (M : S.Mod.{u, u, u, u}) + +/-- **Left unitality of the monoidal comparison.** -/ +theorem superVectMu_left_unitality + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).even] + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).odd] + [FiniteDimensional ℂ (((S.unitMod : S.Mod.{u, u, u, u}).tensor M).tensor + (pointMod P)).even] + [FiniteDimensional ℂ (((S.unitMod : S.Mod.{u, u, u, u}).tensor M).tensor + (pointMod P)).odd] : + (λ_ (toSuperVect P M)).hom = + (superVectEps P ▷ toSuperVect P M) ≫ + superVectMu P S.unitMod M ≫ + superVectHom P (λ_ M).hom := by + have : Subsingleton (𝟙_ SuperVect).odd := + (inferInstance : Subsingleton PUnit.{1}) + refine SuperVect.hom_ext + (superVectPairEven_ext (fun r x => ?_) (fun u y => ?_)) + (superVectPairOdd_ext (fun r y => ?_) (fun u x => ?_)) + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.evenMap + (pointBaseMu_left_unitality P M)) + (tmulEE (S.unitMod : S.Mod.{u, u, u, u}) + (M.tensor (pointMod P)) (LinearMap.toSpanSingleton ℂ S.even S.one r) + ((toSuperVectEvenEquiv P M).symm x)) + simp only [modComp_evenMap_apply] at key + rw [modLeftUnitor_hom, leftUnitorHom_evenMap_tmulEE, + whiskerRight_evenMap_tmulEE, actEE_span_one] at key + simp only [svComp_evenMap_apply] + rw [svLeftUnitor_evenMap_inl, svWhiskerRight_evenMap_inl, + superVectEps_evenMap_apply, superVectMu_evenMap_ee, + LinearEquiv.symm_apply_apply, superVectHom_evenMap_apply, + LinearEquiv.symm_apply_apply, superVectEpsRaw_apply, ← key, + map_smul, LinearEquiv.apply_symm_apply] + · rw [Subsingleton.elim u 0, TensorProduct.zero_tmul, + svEvenInr_zero, map_zero, map_zero] + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.oddMap + (pointBaseMu_left_unitality P M)) + (tmulEO (S.unitMod : S.Mod.{u, u, u, u}) + (M.tensor (pointMod P)) (LinearMap.toSpanSingleton ℂ S.even S.one r) + ((toSuperVectOddEquiv P M).symm y)) + simp only [modComp_oddMap_apply] at key + rw [modLeftUnitor_hom, leftUnitorHom_oddMap_tmulEO, + whiskerRight_oddMap_tmulEO, actEO_span_one] at key + simp only [svComp_oddMap_apply] + rw [svLeftUnitor_oddMap_inl, svWhiskerRight_oddMap_inl, + superVectEps_evenMap_apply, superVectMu_oddMap_eo, + LinearEquiv.symm_apply_apply, superVectHom_oddMap_apply, + LinearEquiv.symm_apply_apply, superVectEpsRaw_apply, ← key, + map_smul, LinearEquiv.apply_symm_apply] + · rw [Subsingleton.elim u 0, TensorProduct.zero_tmul, + svOddInr_zero, map_zero, map_zero] + +/-- **Right unitality of the monoidal comparison.** -/ +theorem superVectMu_right_unitality + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).even] + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).odd] + [FiniteDimensional ℂ ((M.tensor (S.unitMod : S.Mod.{u, u, u, u})).tensor + (pointMod P)).even] + [FiniteDimensional ℂ ((M.tensor (S.unitMod : S.Mod.{u, u, u, u})).tensor + (pointMod P)).odd] : + (ρ_ (toSuperVect P M)).hom = + (toSuperVect P M ◁ superVectEps P) ≫ + superVectMu P M S.unitMod ≫ + superVectHom P (ρ_ M).hom := by + have : Subsingleton (𝟙_ SuperVect).odd := + (inferInstance : Subsingleton PUnit.{1}) + refine SuperVect.hom_ext + (superVectPairEven_ext (fun x r => ?_) (fun y u => ?_)) + (superVectPairOdd_ext (fun x u => ?_) (fun y r => ?_)) + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.evenMap + (pointBaseMu_right_unitality P M)) + (tmulEE (M.tensor (pointMod P)) + (S.unitMod : S.Mod.{u, u, u, u}) + ((toSuperVectEvenEquiv P M).symm x) + (LinearMap.toSpanSingleton ℂ S.even S.one r)) + simp only [modComp_evenMap_apply] at key + rw [modRightUnitor_hom, rightUnitorHom_evenMap_tmulEE, + whiskerLeft_evenMap_tmulEE, actEE_span_one] at key + simp only [svComp_evenMap_apply] + rw [svRightUnitor_evenMap_inl, svWhiskerLeft_evenMap_inl, + superVectEps_evenMap_apply, superVectMu_evenMap_ee, + LinearEquiv.symm_apply_apply, superVectHom_evenMap_apply, + LinearEquiv.symm_apply_apply, superVectEpsRaw_apply, ← key, + map_smul, LinearEquiv.apply_symm_apply] + · rw [Subsingleton.elim u 0, TensorProduct.tmul_zero, + svEvenInr_zero, map_zero, map_zero] + · rw [Subsingleton.elim u 0, TensorProduct.tmul_zero, + svOddInl_zero, map_zero, map_zero] + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.oddMap + (pointBaseMu_right_unitality P M)) + (tmulOE (M.tensor (pointMod P)) + (S.unitMod : S.Mod.{u, u, u, u}) + ((toSuperVectOddEquiv P M).symm y) + (LinearMap.toSpanSingleton ℂ S.even S.one r)) + simp only [modComp_oddMap_apply] at key + rw [modRightUnitor_hom, rightUnitorHom_oddMap_tmulOE, + whiskerLeft_oddMap_tmulOE, actEO_span_one] at key + simp only [svComp_oddMap_apply] + rw [svRightUnitor_oddMap_inr, svWhiskerLeft_oddMap_inr, + superVectEps_evenMap_apply, superVectMu_oddMap_oe, + LinearEquiv.symm_apply_apply, superVectHom_oddMap_apply, + LinearEquiv.symm_apply_apply, superVectEpsRaw_apply, ← key, + map_smul, LinearEquiv.apply_symm_apply] + +end SuperVectUnitality +/-! ## Naturality of the comparison -/ + +section RawNaturality + +open scoped TensorProduct + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) + {M M' N N' : S.Mod.{u, u, u, u}} + +/-- **The raw comparison is natural** in both variables, in even +degree. -/ +theorem superVectMuEvenRaw_naturality (f : M ⟶ M') (g : N ⟶ N') : + (SuperCommAlgebra.Mod.tensorHom + (SuperCommAlgebra.Mod.tensorHom f g) + (𝟙 (pointMod P))).evenMap.comp + (superVectMuEvenRaw P M N) = + (superVectMuEvenRaw P M' N').comp + (LinearMap.prodMap + (TensorProduct.map (SuperCommAlgebra.Mod.tensorHom f + (𝟙 (pointMod P))).evenMap + (SuperCommAlgebra.Mod.tensorHom g + (𝟙 (pointMod P))).evenMap) + (TensorProduct.map (SuperCommAlgebra.Mod.tensorHom f + (𝟙 (pointMod P))).oddMap + (SuperCommAlgebra.Mod.tensorHom g + (𝟙 (pointMod P))).oddMap)) := by + refine LinearMap.ext fun z => Eq.trans + (LinearMap.congr_fun (congrArg SuperCommAlgebra.Mod.Hom.evenMap + (pointBaseMu_naturality P f g)) _).symm ?_ + exact congrArg (pointBaseMu P M' N').evenMap + (LinearMap.congr_fun (gradedTensorEven_naturality + (M.tensor (pointMod P)) (N.tensor (pointMod P)) + (SuperCommAlgebra.Mod.tensorHom f (𝟙 (pointMod P))) + (SuperCommAlgebra.Mod.tensorHom g (𝟙 (pointMod P)))) z) + +end RawNaturality + +/-! ## The comparison intertwines the braidings -/ + +section SuperVectBraiding + +open scoped TensorProduct + +attribute [local irreducible] superVectMu + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) + (M N : S.Mod.{u, u, u, u}) + +/-- **The monoidal comparison intertwines the braidings**: the +Koszul sign of the super vector spaces is the sign of the braiding +of the super modules. -/ +@[reassoc] +theorem superVectMu_braiding [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((N.tensor M).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((N.tensor M).tensor (pointMod P)).odd] : + superVectMu P M N ≫ superVectHom P (β_ M N).hom = + (β_ (toSuperVect P M) (toSuperVect P N)).hom ≫ + superVectMu P N M := by + refine SuperVect.hom_ext + (superVectPairEven_ext (fun x y => ?_) (fun x y => ?_)) + (superVectPairOdd_ext (fun x y => ?_) (fun x y => ?_)) + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.evenMap (pointBaseMu_braiding P M N)) + (tmulEE (M ⊗ pointMod P) (N ⊗ pointMod P) + ((toSuperVectEvenEquiv P M).symm x) + ((toSuperVectEvenEquiv P N).symm y)) + simp only [modComp_evenMap_apply] at key + rw [modBraiding_hom (M ⊗ pointMod P) (N ⊗ pointMod P), + braidingHom_evenMap_tmulEE] at key + simp only [modTensorObj] at key + simp only [svComp_evenMap_apply] + rw [superVectMu_evenMap_ee, superVectHom_evenMap_apply, + LinearEquiv.symm_apply_apply, svBraiding_evenMap_inl, + superVectMu_evenMap_ee, key] + rfl + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.evenMap (pointBaseMu_braiding P M N)) + (tmulOO (M ⊗ pointMod P) (N ⊗ pointMod P) + ((toSuperVectOddEquiv P M).symm x) + ((toSuperVectOddEquiv P N).symm y)) + simp only [modComp_evenMap_apply] at key + rw [modBraiding_hom (M ⊗ pointMod P) (N ⊗ pointMod P), + braidingHom_evenMap_tmulOO, map_neg] at key + simp only [modTensorObj] at key + simp only [svComp_evenMap_apply] + rw [superVectMu_evenMap_oo, superVectHom_evenMap_apply, + LinearEquiv.symm_apply_apply, svBraiding_evenMap_inr, map_neg, + superVectMu_evenMap_oo, key, map_neg] + rfl + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.oddMap (pointBaseMu_braiding P M N)) + (tmulEO (M ⊗ pointMod P) (N ⊗ pointMod P) + ((toSuperVectEvenEquiv P M).symm x) + ((toSuperVectOddEquiv P N).symm y)) + simp only [modComp_oddMap_apply] at key + rw [modBraiding_hom (M ⊗ pointMod P) (N ⊗ pointMod P), + braidingHom_oddMap_tmulEO] at key + simp only [modTensorObj] at key + simp only [svComp_oddMap_apply] + rw [superVectMu_oddMap_eo, superVectHom_oddMap_apply, + LinearEquiv.symm_apply_apply, svBraiding_oddMap_inl, + superVectMu_oddMap_oe, key] + rfl + · have key := LinearMap.congr_fun (congrArg + SuperCommAlgebra.Mod.Hom.oddMap (pointBaseMu_braiding P M N)) + (tmulOE (M ⊗ pointMod P) (N ⊗ pointMod P) + ((toSuperVectOddEquiv P M).symm x) + ((toSuperVectEvenEquiv P N).symm y)) + simp only [modComp_oddMap_apply] at key + rw [modBraiding_hom (M ⊗ pointMod P) (N ⊗ pointMod P), + braidingHom_oddMap_tmulOE] at key + simp only [modTensorObj] at key + simp only [svComp_oddMap_apply] + rw [superVectMu_oddMap_oe, superVectHom_oddMap_apply, + LinearEquiv.symm_apply_apply, svBraiding_oddMap_inr, + superVectMu_oddMap_eo, key] + rfl + +end SuperVectBraiding + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Comparison.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Comparison.lean new file mode 100644 index 0000000000..68d03ea441 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Comparison.lean @@ -0,0 +1,810 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Residue + +/-! +# The comparison in super vector spaces, and its inverse + +The tensor product of two super vector spaces is the graded tensor +product of the components, while the tensor product of two super +modules is its quotient by the balancing relations; the quotient +map is the second half of the comparison, and composing it with the +comparison over the algebra of [Residue.lean](Residue.lean) gives +the comparison `RS.superVectMu` of the fibre functor. + +The inverse is built here as well: the residue module is generated +in even degree by the image of the unit, so +`(m ⊗ n) ⊗ a ↦ (m ⊗ a) ⊗ (n ⊗ 1)` is well defined — an even scalar +crosses either factor as its value at the point, and an odd scalar +kills both sides. That the two composites are the identity is +proved in [Coherence.lean](Coherence.lean); no freeness and no rank +hypothesis is needed. + +## Contents + +* `RS.pointOne`, `RS.pointScale`: the unit of the residue module + and the scaling it induces, with the four generator identities + `RS.tmulEE_actEE_pointOne` and companions. +* `RS.gradedTensorEven`, `RS.gradedTensorOdd`: the quotient maps + from the graded tensor product of the components, with their + surjectivity and their naturality. +* `RS.baseNuEven`, `RS.baseNuOdd`: the inverse comparison, built + from the four balanced blocks `RS.baseNuFee` and companions + through an inner and an outer lift. +* `RS.superVectMuEvenRaw`, `RS.superVectMuOddRaw`: the comparison + before the coordinates are installed. +* `RS.superVectMu`: the comparison of the fibre functor, in + `RS.SuperVect`, with the four generator formulas + `RS.superVectMu_evenMap_ee` and companions. +* `RS.svEvenInl` and its three companions: the four summands of a + tensor product of super vector spaces. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open SuperCommAlgebra (pointMod) +open SuperCommAlgebra.Mod + +universe u + +/-! ## The inverse comparison + +The residue module is generated in even degree by the image of the +unit, so the base change of a module is generated by the products +`m ⊗ 1`, and the map that sends `(m ⊗ n) ⊗ a` to +`(m ⊗ a) ⊗ (n ⊗ 1)` is well defined: an even scalar passes across +either factor as its value at the point, and an odd scalar kills +both sides. -/ + +section Inverse + +open scoped TensorProduct + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) + +/-- The unit of the residue module. -/ +noncomputable def pointOne : (pointMod P : S.Mod.{u, u, u, u}).even := + ULift.up 1 + +/-- **Scaling by a residue class**: a residue class acts on any +complex vector space by its underlying complex number. The residue +module being one dimensional in even degree, this describes every +linear map out of it. -/ +noncomputable def pointScale (X : Type u) [AddCommGroup X] + [Module ℂ X] : + X →ₗ[ℂ] ((pointMod P : S.Mod.{u, u, u, u}).even →ₗ[ℂ] X) where + toFun x := LinearMap.smulRight + (ULift.moduleEquiv (R := ℂ) (M := ℂ)).toLinearMap x + map_add' x y := LinearMap.ext fun a => by + change a.down • (x + y) = a.down • x + a.down • y + exact smul_add _ _ _ + map_smul' c x := LinearMap.ext fun a => by + change a.down • (c • x) = c • (a.down • x) + rw [smul_comm] + +/-- Scaling by a residue class, evaluated. -/ +@[simp] theorem pointScale_apply (X : Type u) [AddCommGroup X] + [Module ℂ X] (x : X) + (a : (pointMod P : S.Mod.{u, u, u, u}).even) : + pointScale P X x a = a.down • x := rfl + +variable (M : S.Mod.{u, u, u, u}) + +/-- An even scalar crosses an even product with the unit as its +value at the point. -/ +theorem tmulEE_actEE_pointOne (b : S.even) (m : M.even) : + tmulEE M (pointMod P) (M.actEE b m) (pointOne P) = + P.chi b • tmulEE M (pointMod P) m (pointOne P) := by + rw [tmulEE_balanced_eee] + have h : (pointMod P : S.Mod.{u, u, u, u}).actEE b (pointOne P) + = P.chi b • pointOne P := ULift.ext _ _ (by + change P.chi b * 1 = P.chi b * 1 + rfl) + rw [h, map_smul] + +/-- An even scalar crosses an odd product with the unit as its +value at the point. -/ +theorem tmulOE_actEO_pointOne (b : S.even) (m : M.odd) : + tmulOE M (pointMod P) (M.actEO b m) (pointOne P) = + P.chi b • tmulOE M (pointMod P) m (pointOne P) := by + rw [tmulOE_balanced_eoe] + have h : (pointMod P : S.Mod.{u, u, u, u}).actEE b (pointOne P) + = P.chi b • pointOne P := ULift.ext _ _ (by + change P.chi b * 1 = P.chi b * 1 + rfl) + rw [h, map_smul] + +/-- An odd scalar kills the even products with the unit. -/ +theorem tmulEE_actOO_pointOne (c : S.odd) (m : M.odd) : + tmulEE M (pointMod P) (M.actOO c m) (pointOne P) = 0 := by + rw [tmulEE_balanced_ooe, pointMod_actOE, map_zero, neg_zero] + +/-- An odd scalar kills the odd products with the unit. -/ +theorem tmulOE_actOE_pointOne (c : S.odd) (m : M.even) : + tmulOE M (pointMod P) (M.actOE c m) (pointOne P) = 0 := by + rw [tmulOE_balanced_oee, pointMod_actOE, map_zero] + +end Inverse + +/-! ## The comparison of the graded tensor product + +The even part of the tensor product of two super modules is a +quotient of the graded tensor product of their components, and +likewise in odd degree. The quotient maps are the comparison +between the tensor product of super vector spaces — which is the +graded tensor product of the components — and the tensor product +of super modules. -/ + +section GradedComparison + +variable {S : SuperCommAlgebra.{u, u}} (A B : S.Mod.{u, u, u, u}) + +open scoped TensorProduct + +/-- **The graded comparison in even degree**: the quotient map +onto the even part of the tensor product. -/ +noncomputable def gradedTensorEven : + (A.even ⊗[ℂ] B.even) × (A.odd ⊗[ℂ] B.odd) →ₗ[ℂ] + (A.tensor B : S.Mod.{u, u, u, u}).even := + (balEven A B).mkQ + +/-- **The graded comparison in odd degree**: the quotient map onto +the odd part of the tensor product. -/ +noncomputable def gradedTensorOdd : + (A.even ⊗[ℂ] B.odd) × (A.odd ⊗[ℂ] B.even) →ₗ[ℂ] + (A.tensor B : S.Mod.{u, u, u, u}).odd := + (balOdd A B).mkQ + +/-- The even comparison on an even-even product. -/ +@[simp] theorem gradedTensorEven_ee (a : A.even) (b : B.even) : + gradedTensorEven A B (a ⊗ₜ[ℂ] b, 0) = tmulEE A B a b := rfl + +/-- The even comparison on an odd-odd product. -/ +@[simp] theorem gradedTensorEven_oo (a : A.odd) (b : B.odd) : + gradedTensorEven A B (0, a ⊗ₜ[ℂ] b) = tmulOO A B a b := rfl + +/-- The odd comparison on an even-odd product. -/ +@[simp] theorem gradedTensorOdd_eo (a : A.even) (b : B.odd) : + gradedTensorOdd A B (a ⊗ₜ[ℂ] b, 0) = tmulEO A B a b := rfl + +/-- The odd comparison on an odd-even product. -/ +@[simp] theorem gradedTensorOdd_oe (a : A.odd) (b : B.even) : + gradedTensorOdd A B (0, a ⊗ₜ[ℂ] b) = tmulOE A B a b := rfl + +/-- **The graded comparison is natural**: the quotient maps +commute with the tensor product of two morphisms. -/ +theorem gradedTensorEven_naturality {A' B' : S.Mod.{u, u, u, u}} + (uu : A ⟶ A') (vv : B ⟶ B') : + (SuperCommAlgebra.Mod.tensorHom uu vv).evenMap.comp + (gradedTensorEven A B) = + (gradedTensorEven A' B').comp + (LinearMap.prodMap + (TensorProduct.map uu.evenMap vv.evenMap) + (TensorProduct.map uu.oddMap vv.oddMap)) := by + refine LinearMap.prod_ext (TensorProduct.ext' fun x y => ?_) + (TensorProduct.ext' fun x y => ?_) + · change (SuperCommAlgebra.Mod.tensorHom uu vv).evenMap + (tmulEE A B x y) = _ + rw [tensorHom_evenMap_tmulEE] + rfl + · change (SuperCommAlgebra.Mod.tensorHom uu vv).evenMap + (tmulOO A B x y) = _ + rw [tensorHom_evenMap_tmulOO] + rfl + +/-- **The graded comparison is natural**, in odd degree. -/ +theorem gradedTensorOdd_naturality {A' B' : S.Mod.{u, u, u, u}} + (uu : A ⟶ A') (vv : B ⟶ B') : + (SuperCommAlgebra.Mod.tensorHom uu vv).oddMap.comp + (gradedTensorOdd A B) = + (gradedTensorOdd A' B').comp + (LinearMap.prodMap + (TensorProduct.map uu.evenMap vv.oddMap) + (TensorProduct.map uu.oddMap vv.evenMap)) := by + refine LinearMap.prod_ext (TensorProduct.ext' fun x y => ?_) + (TensorProduct.ext' fun x y => ?_) + · change (SuperCommAlgebra.Mod.tensorHom uu vv).oddMap + (tmulEO A B x y) = _ + rw [tensorHom_oddMap_tmulEO] + rfl + · change (SuperCommAlgebra.Mod.tensorHom uu vv).oddMap + (tmulOE A B x y) = _ + rw [tensorHom_oddMap_tmulOE] + rfl + +end GradedComparison + +/-! ## The inverse of the comparison + +The comparison morphism is invertible: base change along a point +is strong monoidal, not merely lax. The inverse sends +`(m ⊗ n) ⊗ a` to `(m ⊗ a) ⊗ (n ⊗ 1)`; it is well defined because an +even scalar crosses both factors as its value at the point and an +odd scalar kills both sides. -/ + +section InverseMap + +open scoped TensorProduct + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) + (M N : S.Mod.{u, u, u, u}) + +/-- The even part of the graded tensor product of the two base +changes: the codomain of the inverse comparison in even degree. -/ +abbrev basePairEven : Type u := + ((M.tensor (pointMod P)).even ⊗[ℂ] + (N.tensor (pointMod P)).even) × + ((M.tensor (pointMod P)).odd ⊗[ℂ] + (N.tensor (pointMod P)).odd) + +/-- The odd part of the graded tensor product of the two base +changes. -/ +abbrev basePairOdd : Type u := + ((M.tensor (pointMod P)).even ⊗[ℂ] + (N.tensor (pointMod P)).odd) × + ((M.tensor (pointMod P)).odd ⊗[ℂ] + (N.tensor (pointMod P)).even) + +/-- The even-even block of the inverse comparison. -/ +noncomputable def baseNuFee : + M.even →ₗ[ℂ] N.even →ₗ[ℂ] + ((pointMod P : S.Mod.{u, u, u, u}).even →ₗ[ℂ] + basePairEven P M N) := + LinearMap.compr₂ + (LinearMap.compl₁₂ + (LinearMap.compr₂ (TensorProduct.mk ℂ + (M.tensor (pointMod P)).even + (N.tensor (pointMod P)).even) (LinearMap.inl ℂ _ _)) + ((tmulEE M (pointMod P)).flip (pointOne P)) + ((tmulEE N (pointMod P)).flip (pointOne P))) + (pointScale P (basePairEven P M N)) + +/-- The odd-odd block of the inverse comparison. -/ +noncomputable def baseNuFoo : + M.odd →ₗ[ℂ] N.odd →ₗ[ℂ] + ((pointMod P : S.Mod.{u, u, u, u}).even →ₗ[ℂ] + basePairEven P M N) := + LinearMap.compr₂ + (LinearMap.compl₁₂ + (LinearMap.compr₂ (TensorProduct.mk ℂ + (M.tensor (pointMod P)).odd + (N.tensor (pointMod P)).odd) (LinearMap.inr ℂ _ _)) + ((tmulOE M (pointMod P)).flip (pointOne P)) + ((tmulOE N (pointMod P)).flip (pointOne P))) + (pointScale P (basePairEven P M N)) + +/-- The even-odd block of the inverse comparison. -/ +noncomputable def baseNuFeo : + M.even →ₗ[ℂ] N.odd →ₗ[ℂ] + ((pointMod P : S.Mod.{u, u, u, u}).even →ₗ[ℂ] + basePairOdd P M N) := + LinearMap.compr₂ + (LinearMap.compl₁₂ + (LinearMap.compr₂ (TensorProduct.mk ℂ + (M.tensor (pointMod P)).even + (N.tensor (pointMod P)).odd) (LinearMap.inl ℂ _ _)) + ((tmulEE M (pointMod P)).flip (pointOne P)) + ((tmulOE N (pointMod P)).flip (pointOne P))) + (pointScale P (basePairOdd P M N)) + +/-- The odd-even block of the inverse comparison. -/ +noncomputable def baseNuFoe : + M.odd →ₗ[ℂ] N.even →ₗ[ℂ] + ((pointMod P : S.Mod.{u, u, u, u}).even →ₗ[ℂ] + basePairOdd P M N) := + LinearMap.compr₂ + (LinearMap.compl₁₂ + (LinearMap.compr₂ (TensorProduct.mk ℂ + (M.tensor (pointMod P)).odd + (N.tensor (pointMod P)).even) (LinearMap.inr ℂ _ _)) + ((tmulOE M (pointMod P)).flip (pointOne P)) + ((tmulEE N (pointMod P)).flip (pointOne P))) + (pointScale P (basePairOdd P M N)) + +variable {M N} + +/-- The even-even block, evaluated. -/ +@[simp] theorem baseNuFee_apply (m : M.even) (n : N.even) + (a : (pointMod P : S.Mod.{u, u, u, u}).even) : + baseNuFee P M N m n a = + a.down • (tmulEE M (pointMod P) m (pointOne P) ⊗ₜ[ℂ] + tmulEE N (pointMod P) n (pointOne P), 0) := rfl + +/-- The odd-odd block, evaluated. -/ +@[simp] theorem baseNuFoo_apply (m : M.odd) (n : N.odd) + (a : (pointMod P : S.Mod.{u, u, u, u}).even) : + baseNuFoo P M N m n a = + a.down • (0, tmulOE M (pointMod P) m (pointOne P) ⊗ₜ[ℂ] + tmulOE N (pointMod P) n (pointOne P)) := rfl + +/-- The even-odd block, evaluated. -/ +@[simp] theorem baseNuFeo_apply (m : M.even) (n : N.odd) + (a : (pointMod P : S.Mod.{u, u, u, u}).even) : + baseNuFeo P M N m n a = + a.down • (tmulEE M (pointMod P) m (pointOne P) ⊗ₜ[ℂ] + tmulOE N (pointMod P) n (pointOne P), 0) := rfl + +/-- The odd-even block, evaluated. -/ +@[simp] theorem baseNuFoe_apply (m : M.odd) (n : N.even) + (a : (pointMod P : S.Mod.{u, u, u, u}).even) : + baseNuFoe P M N m n a = + a.down • (0, tmulOE M (pointMod P) m (pointOne P) ⊗ₜ[ℂ] + tmulEE N (pointMod P) n (pointOne P)) := rfl + +/-! ### The inner lift of the inverse comparison -/ + +/-- Balancing of the even-even block against an even scalar. -/ +theorem baseNuFee_balanced_eee (b : S.even) (m : M.even) + (n : N.even) : + baseNuFee P M N (M.actEE b m) n = + baseNuFee P M N m (N.actEE b n) := by + refine LinearMap.ext fun a => ?_ + rw [baseNuFee_apply, baseNuFee_apply, tmulEE_actEE_pointOne, + tmulEE_actEE_pointOne, TensorProduct.smul_tmul] + +/-- Balancing of the odd-odd block against an even scalar. -/ +theorem baseNuFoo_balanced_eoo (b : S.even) (m : M.odd) + (n : N.odd) : + baseNuFoo P M N (M.actEO b m) n = + baseNuFoo P M N m (N.actEO b n) := by + refine LinearMap.ext fun a => ?_ + rw [baseNuFoo_apply, baseNuFoo_apply, tmulOE_actEO_pointOne, + tmulOE_actEO_pointOne, TensorProduct.smul_tmul] + +/-- Balancing of the blocks against an odd scalar, even-odd. -/ +theorem baseNuFoo_balanced_oeo (c : S.odd) (m : M.even) + (n : N.odd) : + baseNuFoo P M N (M.actOE c m) n = + baseNuFee P M N m (N.actOO c n) := by + refine LinearMap.ext fun a => ?_ + rw [baseNuFoo_apply, baseNuFee_apply, tmulOE_actOE_pointOne, + tmulEE_actOO_pointOne, TensorProduct.zero_tmul, + TensorProduct.tmul_zero] + +/-- Balancing of the blocks against an odd scalar, odd-even. -/ +theorem baseNuFee_balanced_ooe (c : S.odd) (m : M.odd) + (n : N.even) : + baseNuFee P M N (M.actOO c m) n = + -baseNuFoo P M N m (N.actOE c n) := by + refine LinearMap.ext fun a => ?_ + rw [LinearMap.neg_apply, baseNuFee_apply, baseNuFoo_apply, + tmulEE_actOO_pointOne, tmulOE_actOE_pointOne, + TensorProduct.zero_tmul, TensorProduct.tmul_zero] + simp + +/-- Balancing of the even-odd block against an even scalar. -/ +theorem baseNuFeo_balanced_eeo (b : S.even) (m : M.even) + (n : N.odd) : + baseNuFeo P M N (M.actEE b m) n = + baseNuFeo P M N m (N.actEO b n) := by + refine LinearMap.ext fun a => ?_ + rw [baseNuFeo_apply, baseNuFeo_apply, tmulEE_actEE_pointOne, + tmulOE_actEO_pointOne, TensorProduct.smul_tmul] + +/-- Balancing of the odd-even block against an even scalar. -/ +theorem baseNuFoe_balanced_eoe (b : S.even) (m : M.odd) + (n : N.even) : + baseNuFoe P M N (M.actEO b m) n = + baseNuFoe P M N m (N.actEE b n) := by + refine LinearMap.ext fun a => ?_ + rw [baseNuFoe_apply, baseNuFoe_apply, tmulOE_actEO_pointOne, + tmulEE_actEE_pointOne, TensorProduct.smul_tmul] + +/-- Balancing of the odd blocks against an odd scalar, +even-even. -/ +theorem baseNuFoe_balanced_oee (c : S.odd) (m : M.even) + (n : N.even) : + baseNuFoe P M N (M.actOE c m) n = + baseNuFeo P M N m (N.actOE c n) := by + refine LinearMap.ext fun a => ?_ + rw [baseNuFoe_apply, baseNuFeo_apply, tmulOE_actOE_pointOne, + tmulOE_actOE_pointOne, TensorProduct.zero_tmul, + TensorProduct.tmul_zero] + +/-- Balancing of the odd blocks against an odd scalar, odd-odd. -/ +theorem baseNuFeo_balanced_ooo (c : S.odd) (m : M.odd) + (n : N.odd) : + baseNuFeo P M N (M.actOO c m) n = + -baseNuFoe P M N m (N.actOO c n) := by + refine LinearMap.ext fun a => ?_ + rw [LinearMap.neg_apply, baseNuFeo_apply, baseNuFoe_apply, + tmulEE_actOO_pointOne, tmulEE_actOO_pointOne, + TensorProduct.zero_tmul, TensorProduct.tmul_zero] + simp + +variable (M N) + +/-- **The inner lift of the inverse comparison**, in even degree: +the two even blocks descend to the tensor product of the two +modules. -/ +noncomputable def baseNuInnerEven : + (M.tensor N : S.Mod.{u, u, u, u}).even →ₗ[ℂ] + ((pointMod P : S.Mod.{u, u, u, u}).even →ₗ[ℂ] + basePairEven P M N) := + liftEven M N (baseNuFee P M N) (baseNuFoo P M N) + (baseNuFee_balanced_eee P) (baseNuFoo_balanced_eoo P) + (baseNuFoo_balanced_oeo P) (baseNuFee_balanced_ooe P) + +/-- **The inner lift of the inverse comparison**, in odd degree. -/ +noncomputable def baseNuInnerOdd : + (M.tensor N : S.Mod.{u, u, u, u}).odd →ₗ[ℂ] + ((pointMod P : S.Mod.{u, u, u, u}).even →ₗ[ℂ] + basePairOdd P M N) := + liftOdd M N (baseNuFeo P M N) (baseNuFoe P M N) + (baseNuFeo_balanced_eeo P) (baseNuFoe_balanced_eoe P) + (baseNuFoe_balanced_oee P) (baseNuFeo_balanced_ooo P) + +variable {M N} + +/-- The inner lift on even-even products. -/ +@[simp] theorem baseNuInnerEven_tmulEE (m : M.even) (n : N.even) : + baseNuInnerEven P M N (tmulEE M N m n) = baseNuFee P M N m n := + liftEven_tmulEE _ _ _ _ _ _ _ _ m n + +/-- The inner lift on odd-odd products. -/ +@[simp] theorem baseNuInnerEven_tmulOO (m : M.odd) (n : N.odd) : + baseNuInnerEven P M N (tmulOO M N m n) = baseNuFoo P M N m n := + liftEven_tmulOO _ _ _ _ _ _ _ _ m n + +/-- The inner lift on even-odd products. -/ +@[simp] theorem baseNuInnerOdd_tmulEO (m : M.even) (n : N.odd) : + baseNuInnerOdd P M N (tmulEO M N m n) = baseNuFeo P M N m n := + liftOdd_tmulEO _ _ _ _ _ _ _ _ m n + +/-- The inner lift on odd-even products. -/ +@[simp] theorem baseNuInnerOdd_tmulOE (m : M.odd) (n : N.even) : + baseNuInnerOdd P M N (tmulOE M N m n) = baseNuFoe P M N m n := + liftOdd_tmulOE _ _ _ _ _ _ _ _ m n + +/-! ### The outer lift of the inverse comparison -/ + +/-- The even action of the residue module, on coordinates. -/ +@[simp] theorem pointMod_actEE_down (b : S.even) + (a : (pointMod P : S.Mod.{u, u, u, u}).even) : + ((pointMod P : S.Mod.{u, u, u, u}).actEE b a).down = + P.chi b * a.down := rfl + +/-- An even scalar crosses the inner lift in even degree. -/ +theorem baseNuInnerEven_actEE (b : S.even) + (t : (M.tensor N : S.Mod.{u, u, u, u}).even) + (a : (pointMod P : S.Mod.{u, u, u, u}).even) : + baseNuInnerEven P M N ((M.tensor N).actEE b t) a = + baseNuInnerEven P M N t ((pointMod P).actEE b a) := by + refine LinearMap.congr_fun (liftEven_unique M N + (((baseNuInnerEven P M N).flip a).comp + ((M.tensor N : S.Mod.{u, u, u, u}).actEE b)) + ((baseNuInnerEven P M N).flip + ((pointMod P : S.Mod.{u, u, u, u}).actEE b a)) + (fun m n => ?_) (fun m n => ?_)) t + · simp only [LinearMap.comp_apply, LinearMap.flip_apply, + actEE_tmulEE, baseNuInnerEven_tmulEE, baseNuFee_apply, + tmulEE_actEE_pointOne, pointMod_actEE_down, + TensorProduct.smul_tmul', Prod.smul_mk, smul_zero, + smul_smul, mul_comm] + · simp only [LinearMap.comp_apply, LinearMap.flip_apply, + actEE_tmulOO, baseNuInnerEven_tmulOO, baseNuFoo_apply, + tmulOE_actEO_pointOne, pointMod_actEE_down, + TensorProduct.smul_tmul', Prod.smul_mk, smul_zero, + smul_smul, mul_comm] + +/-- An odd scalar kills the inner lift in even degree. -/ +theorem baseNuInnerEven_actOO (c : S.odd) + (t : (M.tensor N : S.Mod.{u, u, u, u}).odd) + (a : (pointMod P : S.Mod.{u, u, u, u}).even) : + baseNuInnerEven P M N ((M.tensor N).actOO c t) a = 0 := by + refine LinearMap.congr_fun (liftOdd_unique M N + (((baseNuInnerEven P M N).flip a).comp + ((M.tensor N : S.Mod.{u, u, u, u}).actOO c)) 0 + (fun m n => ?_) (fun m n => ?_)) t + · simp only [LinearMap.comp_apply, LinearMap.flip_apply, + actOO_tmulEO, baseNuInnerEven_tmulOO, baseNuFoo_apply, + tmulOE_actOE_pointOne, TensorProduct.zero_tmul, + smul_zero, LinearMap.zero_apply, Prod.mk_zero_zero] + · simp only [LinearMap.comp_apply, LinearMap.flip_apply, + actOO_tmulOE, baseNuInnerEven_tmulEE, baseNuFee_apply, + tmulEE_actOO_pointOne, TensorProduct.zero_tmul, + smul_zero, LinearMap.zero_apply, Prod.mk_zero_zero] + +/-- An even scalar crosses the inner lift in odd degree. -/ +theorem baseNuInnerOdd_actEO (b : S.even) + (t : (M.tensor N : S.Mod.{u, u, u, u}).odd) + (a : (pointMod P : S.Mod.{u, u, u, u}).even) : + baseNuInnerOdd P M N ((M.tensor N).actEO b t) a = + baseNuInnerOdd P M N t ((pointMod P).actEE b a) := by + refine LinearMap.congr_fun (liftOdd_unique M N + (((baseNuInnerOdd P M N).flip a).comp + ((M.tensor N : S.Mod.{u, u, u, u}).actEO b)) + ((baseNuInnerOdd P M N).flip + ((pointMod P : S.Mod.{u, u, u, u}).actEE b a)) + (fun m n => ?_) (fun m n => ?_)) t + · simp only [LinearMap.comp_apply, LinearMap.flip_apply, + actEO_tmulEO, baseNuInnerOdd_tmulEO, baseNuFeo_apply, + tmulEE_actEE_pointOne, pointMod_actEE_down, + TensorProduct.smul_tmul', Prod.smul_mk, smul_zero, + smul_smul, mul_comm] + · simp only [LinearMap.comp_apply, LinearMap.flip_apply, + actEO_tmulOE, baseNuInnerOdd_tmulOE, baseNuFoe_apply, + tmulOE_actEO_pointOne, pointMod_actEE_down, + TensorProduct.smul_tmul', Prod.smul_mk, smul_zero, + smul_smul, mul_comm] + +/-- An odd scalar kills the inner lift in odd degree. -/ +theorem baseNuInnerOdd_actOE (c : S.odd) + (t : (M.tensor N : S.Mod.{u, u, u, u}).even) + (a : (pointMod P : S.Mod.{u, u, u, u}).even) : + baseNuInnerOdd P M N ((M.tensor N).actOE c t) a = 0 := by + refine LinearMap.congr_fun (liftEven_unique M N + (((baseNuInnerOdd P M N).flip a).comp + ((M.tensor N : S.Mod.{u, u, u, u}).actOE c)) 0 + (fun m n => ?_) (fun m n => ?_)) t + · simp only [LinearMap.comp_apply, LinearMap.flip_apply, + actOE_tmulEE, baseNuInnerOdd_tmulOE, baseNuFoe_apply, + tmulOE_actOE_pointOne, TensorProduct.zero_tmul, + smul_zero, LinearMap.zero_apply, Prod.mk_zero_zero] + · simp only [LinearMap.comp_apply, LinearMap.flip_apply, + actOE_tmulOO, baseNuInnerOdd_tmulEO, baseNuFeo_apply, + tmulEE_actOO_pointOne, TensorProduct.zero_tmul, + smul_zero, LinearMap.zero_apply, Prod.mk_zero_zero] + +variable (M N) + +/-- **The inverse comparison in even degree.** -/ +noncomputable def baseNuEven : + ((M.tensor N).tensor (pointMod P) : S.Mod.{u, u, u, u}).even →ₗ[ℂ] + basePairEven P M N := + liftEven (M.tensor N) (pointMod P) (baseNuInnerEven P M N) 0 + (fun b t a => baseNuInnerEven_actEE P b t a) + (fun _ _ _ => rfl) + (fun c t v => by + change (0 : basePairEven P M N) = _ + rw [pointMod_actOO, map_zero]) + (fun c t a => by + change baseNuInnerEven P M N ((M.tensor N).actOO c t) a = -0 + rw [baseNuInnerEven_actOO, neg_zero]) + +/-- **The inverse comparison in odd degree.** -/ +noncomputable def baseNuOdd : + ((M.tensor N).tensor (pointMod P) : S.Mod.{u, u, u, u}).odd →ₗ[ℂ] + basePairOdd P M N := + liftOdd (M.tensor N) (pointMod P) 0 (baseNuInnerOdd P M N) + (fun _ _ _ => rfl) + (fun b t a => baseNuInnerOdd_actEO P b t a) + (fun c t a => by + change baseNuInnerOdd P M N ((M.tensor N).actOE c t) a = 0 + rw [baseNuInnerOdd_actOE]) + (fun c t v => by + change (0 : basePairOdd P M N) = -_ + rw [pointMod_actOO, map_zero, neg_zero]) + +variable {M N} + +/-- The inverse comparison in even degree, on generators. -/ +@[simp] theorem baseNuEven_tmulEE (t : (M.tensor N : S.Mod.{u, u, u, u}).even) + (a : (pointMod P : S.Mod.{u, u, u, u}).even) : + baseNuEven P M N (tmulEE (M.tensor N) (pointMod P) t a) = + baseNuInnerEven P M N t a := + liftEven_tmulEE _ _ _ _ _ _ _ _ t a + +/-- The inverse comparison in odd degree, on generators. -/ +@[simp] theorem baseNuOdd_tmulOE (t : (M.tensor N : S.Mod.{u, u, u, u}).odd) + (a : (pointMod P : S.Mod.{u, u, u, u}).even) : + baseNuOdd P M N (tmulOE (M.tensor N) (pointMod P) t a) = + baseNuInnerOdd P M N t a := + liftOdd_tmulOE _ _ _ _ _ _ _ _ t a + +end InverseMap + +/-! ## The comparison in super vector spaces -/ + +section SuperVectComparison + +open scoped TensorProduct + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) + +variable (M N : S.Mod.{u, u, u, u}) + +/-- **The comparison morphism in super vector spaces**, in even +degree, before the coordinates are installed. -/ +noncomputable def superVectMuEvenRaw : + ((M.tensor (pointMod P)).even ⊗[ℂ] + (N.tensor (pointMod P)).even) × + ((M.tensor (pointMod P)).odd ⊗[ℂ] + (N.tensor (pointMod P)).odd) →ₗ[ℂ] + ((M.tensor N).tensor (pointMod P)).even := + (pointBaseMu P M N).evenMap ∘ₗ + gradedTensorEven (M.tensor (pointMod P)) (N.tensor (pointMod P)) + +/-- **The comparison morphism in super vector spaces**, in odd +degree, before the coordinates are installed. -/ +noncomputable def superVectMuOddRaw : + ((M.tensor (pointMod P)).even ⊗[ℂ] + (N.tensor (pointMod P)).odd) × + ((M.tensor (pointMod P)).odd ⊗[ℂ] + (N.tensor (pointMod P)).even) →ₗ[ℂ] + ((M.tensor N).tensor (pointMod P)).odd := + (pointBaseMu P M N).oddMap ∘ₗ + gradedTensorOdd (M.tensor (pointMod P)) (N.tensor (pointMod P)) + +/-- The coordinates on the even part of the tensor product of the +two base changes. -/ +noncomputable def superVectPairEvenEquiv + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] : + basePairEven P M N ≃ₗ[ℂ] + (toSuperVect P M ⊗ toSuperVect P N).even := + LinearEquiv.prodCongr + (TensorProduct.congr (toSuperVectEvenEquiv P M) + (toSuperVectEvenEquiv P N)) + (TensorProduct.congr (toSuperVectOddEquiv P M) + (toSuperVectOddEquiv P N)) + +/-- The coordinates on the odd part of the tensor product of the +two base changes. -/ +noncomputable def superVectPairOddEquiv + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] : + basePairOdd P M N ≃ₗ[ℂ] + (toSuperVect P M ⊗ toSuperVect P N).odd := + LinearEquiv.prodCongr + (TensorProduct.congr (toSuperVectEvenEquiv P M) + (toSuperVectOddEquiv P N)) + (TensorProduct.congr (toSuperVectOddEquiv P M) + (toSuperVectEvenEquiv P N)) + +/-- **The monoidal comparison of the fibre functor**: the tensor +product of the base changes maps to the base change of the tensor +product. It is the raw comparison, read in the coordinates that +`RS.toSuperVect` installs. -/ +noncomputable def superVectMu [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).odd] : + toSuperVect P M ⊗ toSuperVect P N ⟶ toSuperVect P (M.tensor N) where + evenMap := + (toSuperVectEvenEquiv P (M.tensor N)).toLinearMap ∘ₗ + superVectMuEvenRaw P M N ∘ₗ + (superVectPairEvenEquiv P M N).symm.toLinearMap + oddMap := + (toSuperVectOddEquiv P (M.tensor N)).toLinearMap ∘ₗ + superVectMuOddRaw P M N ∘ₗ + (superVectPairOddEquiv P M N).symm.toLinearMap + +end SuperVectComparison + +/-! ## The four summands of a tensor product of super vector spaces + +The even part of `V ⊗ W` is a sum of two blocks and so is the odd +part. Naming the four inclusions keeps every generator below at +its structural type, which is what lets the rewriting see through +the tensor product of super vector spaces. -/ + +section Summands + +open scoped TensorProduct + +/-- The even-even block of the even part. -/ +def svEvenInl {V W : SuperVect} (t : V.even ⊗[ℂ] W.even) : + (V ⊗ W).even := (t, 0) + +/-- The odd-odd block of the even part. -/ +def svEvenInr {V W : SuperVect} (t : V.odd ⊗[ℂ] W.odd) : + (V ⊗ W).even := (0, t) + +/-- The even-odd block of the odd part. -/ +def svOddInl {V W : SuperVect} (t : V.even ⊗[ℂ] W.odd) : + (V ⊗ W).odd := (t, 0) + +/-- The odd-even block of the odd part. -/ +def svOddInr {V W : SuperVect} (t : V.odd ⊗[ℂ] W.even) : + (V ⊗ W).odd := (0, t) + +/-- The odd-odd block of zero vanishes. -/ +theorem svEvenInr_zero {V W : SuperVect} : + svEvenInr (0 : V.odd ⊗[ℂ] W.odd) = 0 := rfl + +/-- The even-odd block of zero vanishes. -/ +theorem svOddInl_zero {V W : SuperVect} : + svOddInl (0 : V.even ⊗[ℂ] W.odd) = 0 := rfl + +/-- The odd-even block of zero vanishes. -/ +theorem svOddInr_zero {V W : SuperVect} : + svOddInr (0 : V.odd ⊗[ℂ] W.even) = 0 := rfl + +end Summands + +/-! ## The comparison on generators of the tensor product -/ + +section MuBlocks + +open scoped TensorProduct + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) + (M N : S.Mod.{u, u, u, u}) + +variable {M N} + +/-- The comparison on an even-even generator. -/ +theorem superVectMu_evenMap_ee + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).odd] + (x : (toSuperVect P M).even) + (y : (toSuperVect P N).even) : + (superVectMu P M N).evenMap (svEvenInl (x ⊗ₜ[ℂ] y)) = + toSuperVectEvenEquiv P (M.tensor N) + ((pointBaseMu P M N).evenMap + (tmulEE (M.tensor (pointMod P)) (N.tensor (pointMod P)) + ((toSuperVectEvenEquiv P M).symm x) + ((toSuperVectEvenEquiv P N).symm y))) := rfl + +/-- The comparison on an odd-odd generator. -/ +theorem superVectMu_evenMap_oo + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).odd] + (x : (toSuperVect P M).odd) + (y : (toSuperVect P N).odd) : + (superVectMu P M N).evenMap (svEvenInr (x ⊗ₜ[ℂ] y)) = + toSuperVectEvenEquiv P (M.tensor N) + ((pointBaseMu P M N).evenMap + (tmulOO (M.tensor (pointMod P)) (N.tensor (pointMod P)) + ((toSuperVectOddEquiv P M).symm x) + ((toSuperVectOddEquiv P N).symm y))) := rfl + +/-- The comparison on an even-odd generator. -/ +theorem superVectMu_oddMap_eo [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).odd] + (x : (toSuperVect P M).even) + (y : (toSuperVect P N).odd) : + (superVectMu P M N).oddMap (svOddInl (x ⊗ₜ[ℂ] y)) = + toSuperVectOddEquiv P (M.tensor N) + ((pointBaseMu P M N).oddMap + (tmulEO (M.tensor (pointMod P)) (N.tensor (pointMod P)) + ((toSuperVectEvenEquiv P M).symm x) + ((toSuperVectOddEquiv P N).symm y))) := rfl + +/-- The comparison on an odd-even generator. -/ +theorem superVectMu_oddMap_oe [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).even] + [FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).odd] + (x : (toSuperVect P M).odd) + (y : (toSuperVect P N).even) : + (superVectMu P M N).oddMap (svOddInr (x ⊗ₜ[ℂ] y)) = + toSuperVectOddEquiv P (M.tensor N) + ((pointBaseMu P M N).oddMap + (tmulOE (M.tensor (pointMod P)) (N.tensor (pointMod P)) + ((toSuperVectOddEquiv P M).symm x) + ((toSuperVectEvenEquiv P N).symm y))) := rfl + +end MuBlocks + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Functor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Functor.lean new file mode 100644 index 0000000000..7fd7b38b5a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Functor.lean @@ -0,0 +1,287 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Coherence + +/-! +# The monoidal fibre functor at a complex point + +The comparison and the unit of +[Comparison.lean](Comparison.lean), with the coherence proved in +[Coherence.lean](Coherence.lean), assemble the fibre functor at a +ℂ-point into a lax monoidal functor; both comparisons being +invertible it is strong monoidal, and it is braided as soon as the +functor upstream of it is. Applied to a splitting algebra this +gives a braided fibre functor out of the ambient category. + +## Contents + +* `RS.superVectFunctorLaxMonoidal`, `RS.superVectFunctorMonoidal`: + the fibre functor at a point is lax monoidal, and strong monoidal + as soon as the functor upstream of it is. +* `RS.isIso_superVectHom`: the fibre functor carries an + isomorphism to an isomorphism. +* `RS.superVectFunctorBraided`: the fibre functor at a point is + braided as soon as the functor upstream of it is. +* `RS.nonempty_braided_deligneFibre`: the fibre functor of a + splitting algebra at a complex point is braided. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open SuperCommAlgebra (pointMod) +open SuperCommAlgebra.Mod + +universe u + +/-! ## The lax monoidal structure of the fibre functor -/ + +section LaxMonoidal + +open scoped TensorProduct + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) + +/-- **The base change of a tensor product is finite dimensional** +in even degree as soon as the two factors are: the comparison is a +linear equivalence onto it. -/ +instance finiteDimensional_tensor_base_even (M N : S.Mod.{u, u, u, u}) + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] : + FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).even := + (LinearEquiv.ofBijective (superVectMuEvenRaw P M N) + (superVectMuEvenRaw_bijective P M N)).finiteDimensional + +/-- **The base change of a tensor product is finite dimensional** +in odd degree. -/ +instance finiteDimensional_tensor_base_odd (M N : S.Mod.{u, u, u, u}) + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] : + FiniteDimensional ℂ ((M.tensor N).tensor (pointMod P)).odd := + (LinearEquiv.ofBijective (superVectMuOddRaw P M N) + (superVectMuOddRaw_bijective P M N)).finiteDimensional + +/-- The same, for the monoidal notation. -/ +instance finiteDimensional_tensorObj_base_even (M N : S.Mod.{u, u, u, u}) + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] : + FiniteDimensional ℂ ((M ⊗ N).tensor (pointMod P)).even := + finiteDimensional_tensor_base_even P M N + +/-- The same in odd degree, for the monoidal notation. -/ +instance finiteDimensional_tensorObj_base_odd (M N : S.Mod.{u, u, u, u}) + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] : + FiniteDimensional ℂ ((M ⊗ N).tensor (pointMod P)).odd := + finiteDimensional_tensor_base_odd P M N + +variable {E : Type u₂} + +/-- **The fibre functor at a point is lax monoidal** whenever the +functor it is applied to is: the comparison of the base change is +composed with the comparison upstream. -/ +@[implicit_reducible] +noncomputable def superVectFunctorLaxMonoidal + [Category.{v₂} E] [MonoidalCategory E] (G : E ⥤ S.Mod.{u, u, u, u}) + [G.LaxMonoidal] + [hE : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).even] + [hO : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).even] + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).odd] : + (superVectFunctor P G hE hO).LaxMonoidal where + ε := superVectEps P ≫ superVectHom P (Functor.LaxMonoidal.ε G) + μ X Y := superVectMu P (G.obj X) (G.obj Y) ≫ + superVectHom P (Functor.LaxMonoidal.μ G X Y) + μ_natural_left {X Y} f X' := by + simp only [superVectFunctor_map, superVectFunctor_obj] + rw [← Category.assoc, superVectMu_naturality_left, + Category.assoc, ← superVectHom_comp, + Functor.LaxMonoidal.μ_natural_left, superVectHom_comp, + ← Category.assoc] + μ_natural_right X' {X Y} f := by + simp only [superVectFunctor_map, superVectFunctor_obj] + rw [← Category.assoc, superVectMu_naturality_right, + Category.assoc, ← superVectHom_comp, + Functor.LaxMonoidal.μ_natural_right, superVectHom_comp, + ← Category.assoc] + associativity X Y Z := by + simp only [superVectFunctor_map, superVectFunctor_obj, + MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [← Category.assoc (superVectHom P + (Functor.LaxMonoidal.μ G X Y) ▷ _), + superVectMu_naturality_left] + simp only [Category.assoc, ← superVectHom_comp] + rw [Functor.LaxMonoidal.associativity] + simp only [superVectHom_comp, modTensorObj] + rw [superVectMu_associativity_assoc] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [← Category.assoc (toSuperVect P (G.obj X) ◁ + superVectHom P (Functor.LaxMonoidal.μ G Y Z)), + superVectMu_naturality_right] + simp only [Category.assoc] + rfl + left_unitality X := by + simp only [superVectFunctor_map, superVectFunctor_obj, + MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [← Category.assoc (superVectHom P (Functor.LaxMonoidal.ε G) + ▷ _), superVectMu_naturality_left] + simp only [Category.assoc, ← superVectHom_comp] + rw [← Functor.LaxMonoidal.left_unitality] + exact superVectMu_left_unitality P (G.obj X) + right_unitality X := by + simp only [superVectFunctor_map, superVectFunctor_obj, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [← Category.assoc (toSuperVect P (G.obj X) ◁ + superVectHom P (Functor.LaxMonoidal.ε G)), + superVectMu_naturality_right] + simp only [Category.assoc, ← superVectHom_comp] + rw [← Functor.LaxMonoidal.right_unitality] + exact superVectMu_right_unitality P (G.obj X) + +/-- **Base change carries an isomorphism to an isomorphism.** -/ +instance isIso_superVectHom {M N : S.Mod.{u, u, u, u}} (u : M ⟶ N) + [IsIso u] + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] + [FiniteDimensional ℂ (N.tensor (pointMod P)).even] + [FiniteDimensional ℂ (N.tensor (pointMod P)).odd] : + IsIso (superVectHom P u) := + ⟨superVectHom P (inv u), by + rw [← superVectHom_comp, IsIso.hom_inv_id, superVectHom_id], + by rw [← superVectHom_comp, IsIso.inv_hom_id, + superVectHom_id]⟩ + +end LaxMonoidal + +section StrongMonoidal + +open scoped TensorProduct + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) {E : Type u₂} + +/-- **The fibre functor at a point is strong monoidal** whenever +the functor it is applied to is: both comparisons are invertible, +the one of the base change unconditionally. -/ +@[implicit_reducible] +noncomputable def superVectFunctorMonoidal + [Category.{v₂} E] [MonoidalCategory E] (G : E ⥤ S.Mod.{u, u, u, u}) + [G.Monoidal] + [hE : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).even] + [hO : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).even] + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).odd] : + (superVectFunctor P G hE hO).Monoidal := by + letI : (superVectFunctor P G hE hO).LaxMonoidal := + superVectFunctorLaxMonoidal P G + haveI : IsIso (Functor.LaxMonoidal.ε G) := + ⟨Functor.OplaxMonoidal.η G, Functor.Monoidal.ε_η G, + Functor.Monoidal.η_ε G⟩ + haveI : ∀ X Y, IsIso (Functor.LaxMonoidal.μ G X Y) := fun X Y => + ⟨Functor.OplaxMonoidal.δ G X Y, Functor.Monoidal.μ_δ G X Y, + Functor.Monoidal.δ_μ G X Y⟩ + haveI : IsIso (Functor.LaxMonoidal.ε + (superVectFunctor P G hE hO)) := + inferInstanceAs (IsIso (superVectEps P ≫ + superVectHom P (Functor.LaxMonoidal.ε G))) + haveI : ∀ X Y, IsIso (Functor.LaxMonoidal.μ + (superVectFunctor P G hE hO) X Y) := fun X Y => + inferInstanceAs (IsIso (superVectMu P (G.obj X) (G.obj Y) ≫ + superVectHom P (Functor.LaxMonoidal.μ G X Y))) + exact Functor.Monoidal.ofLaxMonoidal _ + +end StrongMonoidal + +/-! ## The braided structure of the fibre functor -/ + +section BraidedStructure + +open scoped TensorProduct + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) {E : Type u₂} + +/-- **The fibre functor at a point is braided** whenever the functor +it is applied to is: the comparison of the base change intertwines +the braidings, and so does the comparison upstream. -/ +@[implicit_reducible] +noncomputable def superVectFunctorBraided + [Category.{v₂} E] [MonoidalCategory E] [BraidedCategory E] + (G : E ⥤ S.Mod.{u, u, u, u}) [G.Braided] + [hE : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).even] + [hO : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).odd] + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).even] + [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod + P)).odd] : + (superVectFunctor P G hE hO).Braided where + toMonoidal := superVectFunctorMonoidal P G + braided X Y := by + change (superVectMu P (G.obj X) (G.obj Y) ≫ + superVectHom P (Functor.LaxMonoidal.μ G X Y)) ≫ + superVectHom P (G.map (β_ X Y).hom) = _ + simp only [Category.assoc, ← superVectHom_comp] + rw [Functor.LaxBraided.braided] + simp only [superVectHom_comp] + rw [superVectMu_braiding_assoc] + rfl + +end BraidedStructure + +/-! ## The fibre functor of a splitting algebra is braided -/ + +section DeligneFibreBraided + +open scoped MonObj + +variable {C : Type v} + +/-- **The fibre functor of a splitting algebra at a complex point is +braided.** Upstream, the restriction of the fibre functor along the +embedding is strong monoidal and lax braided; downstream, base +change at the point is strong monoidal and intertwines the Koszul +sign of the super vector spaces with the sign of the braiding of the +super modules. -/ +theorem nonempty_braided_deligneFibre + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + [CategoryTheory.Linear ℂ (Ind C)] [MonoidalLinear ℂ (Ind C)] + (L : OddLine (Ind C)) (𝔸 : Ind C) [MonObj 𝔸] [IsCommMonObj 𝔸] + (hsp : SplitsOn L 𝔸 (indOf : C ⥤ Ind C)) + (pt : SuperPoint (gammaAlgebra (Ind C) L 𝔸)) : + Nonempty (deligneFibre L 𝔸 hsp pt).Braided := by + let : ((indOf : C ⥤ Ind C) ⋙ fibreOver L 𝔸).Braided := + { toMonoidal := indFibreMonoidal L 𝔸 hsp + braided := Functor.LaxBraided.braided } + have hE : ∀ X, FiniteDimensional ℂ + ((((indOf : C ⥤ Ind C) ⋙ fibreOver L 𝔸).obj X).tensor + (pointMod pt)).even := + finiteDimensional_indFibre_even L 𝔸 hsp pt + have hO : ∀ X, FiniteDimensional ℂ + ((((indOf : C ⥤ Ind C) ⋙ fibreOver L 𝔸).obj X).tensor + (pointMod pt)).odd := + finiteDimensional_indFibre_odd L 𝔸 hsp pt + exact ⟨superVectFunctorBraided pt + ((indOf : C ⥤ Ind C) ⋙ fibreOver L 𝔸)⟩ + +end DeligneFibreBraided + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Residue.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Residue.lean new file mode 100644 index 0000000000..3e3447ac54 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Residue.lean @@ -0,0 +1,601 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointFibre + +/-! +# The residue algebra of a complex point + +The residue module of a ℂ-point of a super-commutative algebra `S` +has a copy of ℂ for its even part and a vanishing odd part, and the +point makes `S` act through its value. Multiplication of complex +numbers therefore descends to a morphism `k ⊗ k ⟶ k` of super +modules, and the point itself to a morphism from the unit module, +so the residue module is a commutative monoid object. Super +modules over `S` are symmetric monoidal, so the middle-four +interchange followed by that multiplication is a comparison +`(M ⊗ k) ⊗ (N ⊗ k) ⟶ (M ⊗ N) ⊗ k`, natural in both variables, and +the monoid laws are exactly what makes it lax monoidal and braided. +The comparison is carried down to super vector spaces in +[Comparison.lean](Comparison.lean). + +## Contents + +* `RS.pointMulHom`, `RS.pointUnitHom`: the residue module as a + commutative algebra over the base, with its associativity + `RS.pointMulHom_assoc`, its two unit laws and its commutativity + `RS.pointMulHom_comm`. +* `RS.pointBaseMu`, `RS.pointBaseEps`: the comparison morphisms + over the algebra, with `RS.pointBaseMu_naturality` and the four + generator formulas `RS.pointBaseMu_evenMap_ee` and companions. +* `RS.pointBaseMu_associativity`, `RS.pointBaseMu_left_unitality`, + `RS.pointBaseMu_right_unitality`: the three coherence laws of the + comparison over the algebra — base change over the algebra is lax + monoidal, and the multiplication of the residue module is what + makes it so. +* `RS.pointBaseMu_braiding`: the comparison over the algebra + intertwines the braidings, the residue factor contributing + nothing because its multiplication is commutative. +* `RS.modAssociator_hom` and its companions: the structural + morphisms of the category of super modules, in the form the + generator computations consume. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open SuperCommAlgebra (pointMod) +open SuperCommAlgebra.Mod + +universe u + +/-! ## The residue module is a commutative algebra -/ + +section ResidueAlgebra + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) + +/-- The odd part of the residue module has one element. -/ +instance pointMod_odd_subsingleton : + Subsingleton (pointMod P : S.Mod.{u, u, u, u}).odd := + (inferInstance : Subsingleton (ULift.{u} PUnit.{1})) + +/-- An element of the odd part of the residue module vanishes. -/ +theorem pointMod_odd_eq_zero + (v : (pointMod P : S.Mod.{u, u, u, u}).odd) : v = 0 := + Subsingleton.elim _ _ + +/-- The even action on the residue module is multiplication by the +value of the point. -/ +theorem pointMod_actEE (x : S.even) + (c : (pointMod P : S.Mod.{u, u, u, u}).even) : + (pointMod P).actEE x c = ULift.up (P.chi x * c.down) := rfl + +/-- The odd action on the even part of the residue module +vanishes. -/ +theorem pointMod_actOE (u : S.odd) + (c : (pointMod P : S.Mod.{u, u, u, u}).even) : + (pointMod P).actOE u c = 0 := rfl + +/-- The odd action on the odd part of the residue module +vanishes. -/ +theorem pointMod_actOO (u : S.odd) + (v : (pointMod P : S.Mod.{u, u, u, u}).odd) : + (pointMod P).actOO u v = 0 := rfl + +/-- **The multiplication of the residue module**, on even parts: +the residue module is a copy of ℂ in even degree, and this is the +multiplication of ℂ. -/ +noncomputable def pointMulLin : + (pointMod P : S.Mod.{u, u, u, u}).even →ₗ[ℂ] + (pointMod P : S.Mod.{u, u, u, u}).even →ₗ[ℂ] + (pointMod P : S.Mod.{u, u, u, u}).even := + LinearMap.mk₂ ℂ (fun a b => ULift.up (a.down * b.down)) + (fun a b c => ULift.ext _ _ (by + change (a.down + b.down) * c.down = _ + exact add_mul _ _ _)) + (fun r a b => ULift.ext _ _ (by + change (r * a.down) * b.down = r * (a.down * b.down) + exact mul_assoc _ _ _)) + (fun a b c => ULift.ext _ _ (by + change a.down * (b.down + c.down) = _ + exact mul_add _ _ _)) + (fun r a b => ULift.ext _ _ (by + change a.down * (r * b.down) = r * (a.down * b.down) + ring)) + +/-- The multiplication of the residue module, evaluated. -/ +@[simp] theorem pointMulLin_apply + (a b : (pointMod P : S.Mod.{u, u, u, u}).even) : + pointMulLin P a b = ULift.up (a.down * b.down) := rfl + +/-- **The data of the multiplication** of the residue module as a +morphism out of the tensor square: the even-even block is the +multiplication of ℂ and the three remaining blocks vanish, the odd +part of the residue module being zero. -/ +noncomputable def pointMulData : + TensorData (pointMod P : S.Mod.{u, u, u, u}) (pointMod P) + (pointMod P) where + fee := pointMulLin P + foo := 0 + feo := 0 + foe := 0 + hee b m n := ULift.ext _ _ (by + change P.chi b * m.down * n.down = m.down * (P.chi b * n.down) + ring) + hoo _ _ _ := rfl + hoeo c m n := by + rw [pointMod_actOO] + change (0 : (pointMod P).even) = pointMulLin P m 0 + rw [map_zero] + hooe c m n := by + rw [pointMod_actOO] + change pointMulLin P 0 n = -(0 : (pointMod P).even) + rw [map_zero, LinearMap.zero_apply, neg_zero] + heeo _ _ _ := Subsingleton.elim _ _ + heoe _ _ _ := Subsingleton.elim _ _ + hoee _ _ _ := Subsingleton.elim _ _ + hooo _ _ _ := Subsingleton.elim _ _ + aee a m n := ULift.ext _ _ (by + change P.chi a * m.down * n.down = P.chi a * (m.down * n.down) + ring) + aoo a m n := by + change (0 : (pointMod P).even) = (pointMod P).actEE a 0 + rw [map_zero] + aeo _ _ _ := Subsingleton.elim _ _ + aoe _ _ _ := Subsingleton.elim _ _ + cee _ _ _ := Subsingleton.elim _ _ + coo _ _ _ := Subsingleton.elim _ _ + ceo c m n := by + rw [pointMod_actOO] + rfl + coe c m n := by + rw [pointMod_actOO, pointMod_actOO] + show pointMulLin P 0 n = 0 + rw [map_zero, LinearMap.zero_apply] + +/-- **The multiplication of the residue module**, as a morphism of +super modules out of its tensor square. -/ +noncomputable def pointMulHom : + ((pointMod P : S.Mod.{u, u, u, u}).tensor (pointMod P)) ⟶ + pointMod P := + mkHom (pointMulData P) + +/-- The multiplication on even-even products. -/ +@[simp] theorem pointMulHom_evenMap_tmulEE + (a b : (pointMod P : S.Mod.{u, u, u, u}).even) : + (pointMulHom P).evenMap (tmulEE (pointMod P) (pointMod P) a b) = + ULift.up (a.down * b.down) := + mkHom_evenMap_tmulEE (pointMulData P) a b + +/-- **The unit of the residue module**: the point itself, read as a +morphism from the algebra. -/ +noncomputable def pointUnitHom : + (S.unitMod : S.Mod.{u, u, u, u}) ⟶ pointMod P where + evenMap := (ULift.moduleEquiv (R := ℂ) (M := ℂ)).symm.toLinearMap ∘ₗ + (P.chi.toLinearMap : S.even →ₗ[ℂ] ℂ) + oddMap := 0 + map_actEE x m := ULift.ext _ _ (by + change P.chi (S.mulEE x m) = P.chi x * P.chi m + exact map_mul P.chi x m) + map_actEO _ _ := Subsingleton.elim _ _ + map_actOE _ _ := Subsingleton.elim _ _ + map_actOO u m := ULift.ext _ _ (by + change P.chi (S.mulOO u m) = (0 : ULift.{u} ℂ).down + rw [P.vanishing] + rfl) + +/-- The unit of the residue module, evaluated. -/ +@[simp] theorem pointUnitHom_evenMap (x : S.even) : + (pointUnitHom P).evenMap x = ULift.up (P.chi x) := rfl + +/-- **The base change of the unit module is finite dimensional** in +even degree: the left unitor identifies it with the residue +module. -/ +instance finiteDimensional_unitMod_tensor_point_even : + FiniteDimensional ℂ + ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod P)).even := + (evenEquiv (unitTensorPoint P)).symm.finiteDimensional + +/-- **The base change of the unit module is finite dimensional** in +odd degree. -/ +instance finiteDimensional_unitMod_tensor_point_odd : + FiniteDimensional ℂ + ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod P)).odd := + (oddEquiv (unitTensorPoint P)).symm.finiteDimensional + +end ResidueAlgebra + +/-! ## The comparison over the algebra + +Base change is the functor `M ↦ M ⊗ k` for `k` the residue module +of the point. The residue module is a commutative algebra, so the +usual middle-four interchange followed by its multiplication is a +comparison morphism +`(M ⊗ k) ⊗ (N ⊗ k) ⟶ (M ⊗ N) ⊗ k`. -/ + +section BaseChangeComparison + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) + +/-- **The comparison morphism of base change**, over the algebra: +interchange the middle two factors and multiply the two copies of +the residue module. -/ +noncomputable def pointBaseMu (M N : S.Mod.{u, u, u, u}) : + ((M.tensor (pointMod P)).tensor (N.tensor (pointMod P)) : + S.Mod.{u, u, u, u}) ⟶ (M.tensor N).tensor (pointMod P) := + tensorμ M (pointMod P) N (pointMod P) ≫ + ((M.tensor N : S.Mod.{u, u, u, u}) ◁ pointMulHom P) + +/-- **The unit of base change**, over the algebra: the point read +as a morphism from the unit, followed by the inverse left unitor. -/ +noncomputable def pointBaseEps : + (S.unitMod : S.Mod.{u, u, u, u}) ⟶ + (S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod P) := + (ρ_ (S.unitMod : S.Mod.{u, u, u, u})).inv ≫ + ((S.unitMod : S.Mod.{u, u, u, u}) ◁ pointUnitHom P) + +/-- **The comparison over the algebra is natural** in both +variables: this is naturality of the middle-four interchange. -/ +theorem pointBaseMu_naturality {M M' N N' : S.Mod.{u, u, u, u}} + (f : M ⟶ M') (g : N ⟶ N') : + ((f ⊗ₘ 𝟙 (pointMod P)) ⊗ₘ (g ⊗ₘ 𝟙 (pointMod P))) ≫ + pointBaseMu P M' N' = + pointBaseMu P M N ≫ ((f ⊗ₘ g) ⊗ₘ 𝟙 (pointMod P)) := by + simp only [pointBaseMu, Category.assoc] + rw [← Category.assoc, tensorμ_natural, Category.assoc] + congr 1 + simp only [← id_tensorHom, tensorHom_comp_tensorHom, + Category.comp_id, Category.id_comp, id_tensorHom_id] + exact congrArg (fun h => h ⊗ₘ pointMulHom P) + (Category.comp_id (f ⊗ₘ g)) + +end BaseChangeComparison + +/-! ## The comparison over the algebra, on generators -/ + +section BaseMuFormulas + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) + (M N : S.Mod.{u, u, u, u}) + +/-- The monoidal associator of the super modules is the explicit +associator. -/ +theorem modAssociator_hom (X Y Z : S.Mod.{u, u, u, u}) : + (α_ X Y Z).hom = assocHom X Y Z := rfl + +/-- The inverse associator of the super modules is explicit. -/ +theorem modAssociator_inv (X Y Z : S.Mod.{u, u, u, u}) : + (α_ X Y Z).inv = assocInv X Y Z := rfl + +/-- The braiding of the super modules is the Koszul swap. -/ +theorem modBraiding_hom (X Y : S.Mod.{u, u, u, u}) : + (β_ X Y).hom = braidingHom X Y := rfl + +/-- Left whiskering of super modules is a tensor product of +morphisms. -/ +theorem modWhiskerLeft (X : S.Mod.{u, u, u, u}) + {Y Z : S.Mod.{u, u, u, u}} (f : Y ⟶ Z) : + X ◁ f = SuperCommAlgebra.Mod.tensorHom (𝟙 X) f := rfl + +/-- Right whiskering of super modules is a tensor product of +morphisms. -/ +theorem modWhiskerRight {Y Z : S.Mod.{u, u, u, u}} (f : Y ⟶ Z) + (X : S.Mod.{u, u, u, u}) : + f ▷ X = SuperCommAlgebra.Mod.tensorHom f (𝟙 X) := rfl + +/-- The monoidal tensor product of super modules is the balanced +tensor product. -/ +theorem modTensorObj (X Y : S.Mod.{u, u, u, u}) : + X ⊗ Y = X.tensor Y := rfl + +/-- The left unitor of the super modules is explicit. -/ +theorem modLeftUnitor_hom (X : S.Mod.{u, u, u, u}) : + (λ_ X).hom = leftUnitorHom X := rfl + +/-- The right unitor of the super modules is explicit. -/ +theorem modRightUnitor_hom (X : S.Mod.{u, u, u, u}) : + (ρ_ X).hom = rightUnitorHom X := rfl + +/-- The monoidal unit of the super modules is the algebra. -/ +theorem modTensorUnit : (𝟙_ (S.Mod.{u, u, u, u})) = S.unitMod := rfl + +/-- **The comparison over the algebra on even-even generators.** -/ +theorem pointBaseMu_evenMap_ee (m : M.even) + (a : (pointMod P : S.Mod.{u, u, u, u}).even) (n : N.even) + (b : (pointMod P : S.Mod.{u, u, u, u}).even) : + (pointBaseMu P M N).evenMap + (tmulEE (M.tensor (pointMod P)) (N.tensor (pointMod P)) + (tmulEE M (pointMod P) m a) + (tmulEE N (pointMod P) n b)) = + tmulEE (M.tensor N) (pointMod P) (tmulEE M N m n) + (ULift.up (a.down * b.down)) := by + simp [pointBaseMu, tensorμ, modTensorObj, modAssociator_hom, + modAssociator_inv, modBraiding_hom, modWhiskerLeft, + modWhiskerRight] + +/-- **The comparison over the algebra on odd-odd generators.** -/ +theorem pointBaseMu_evenMap_oo (m : M.odd) + (a : (pointMod P : S.Mod.{u, u, u, u}).even) (n : N.odd) + (b : (pointMod P : S.Mod.{u, u, u, u}).even) : + (pointBaseMu P M N).evenMap + (tmulOO (M.tensor (pointMod P)) (N.tensor (pointMod P)) + (tmulOE M (pointMod P) m a) + (tmulOE N (pointMod P) n b)) = + tmulEE (M.tensor N) (pointMod P) (tmulOO M N m n) + (ULift.up (a.down * b.down)) := by + simp [pointBaseMu, tensorμ, modTensorObj, modAssociator_hom, + modAssociator_inv, modBraiding_hom, modWhiskerLeft, + modWhiskerRight] + +/-- **The comparison over the algebra on even-odd generators.** -/ +theorem pointBaseMu_oddMap_eo (m : M.even) + (a : (pointMod P : S.Mod.{u, u, u, u}).even) (n : N.odd) + (b : (pointMod P : S.Mod.{u, u, u, u}).even) : + (pointBaseMu P M N).oddMap + (tmulEO (M.tensor (pointMod P)) (N.tensor (pointMod P)) + (tmulEE M (pointMod P) m a) + (tmulOE N (pointMod P) n b)) = + tmulOE (M.tensor N) (pointMod P) (tmulEO M N m n) + (ULift.up (a.down * b.down)) := by + simp [pointBaseMu, tensorμ, modTensorObj, modAssociator_hom, + modAssociator_inv, modBraiding_hom, modWhiskerLeft, + modWhiskerRight] + +/-- **The comparison over the algebra on odd-even generators.** -/ +theorem pointBaseMu_oddMap_oe (m : M.odd) + (a : (pointMod P : S.Mod.{u, u, u, u}).even) (n : N.even) + (b : (pointMod P : S.Mod.{u, u, u, u}).even) : + (pointBaseMu P M N).oddMap + (tmulOE (M.tensor (pointMod P)) (N.tensor (pointMod P)) + (tmulOE M (pointMod P) m a) + (tmulEE N (pointMod P) n b)) = + tmulOE (M.tensor N) (pointMod P) (tmulOE M N m n) + (ULift.up (a.down * b.down)) := by + simp [pointBaseMu, tensorμ, modTensorObj, modAssociator_hom, + modAssociator_inv, modBraiding_hom, modWhiskerLeft, + modWhiskerRight] + +end BaseMuFormulas + +/-! ## The residue module is a commutative monoid object + +The three monoid laws and commutativity, in the form the lax +structure of base change consumes. Every law is an identity of +complex numbers in the even-even-even block, and every other block +lands in the odd part of the residue module, which vanishes. -/ + +section MonoidLaws + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) + +/-- Associativity of the multiplication of the residue module, on +the one family of generators that does not vanish. -/ +private theorem point_triple_ee + (a b c : (pointMod P : S.Mod.{u, u, u, u}).even) : + ((pointMulHom P ▷ pointMod P) ≫ pointMulHom P).evenMap + (tmulEE ((pointMod P).tensor (pointMod P)) (pointMod P) + (tmulEE (pointMod P) (pointMod P) a b) c) = + ((α_ (pointMod P) (pointMod P) + (pointMod P : S.Mod.{u, u, u, u})).hom ≫ + ((pointMod P : S.Mod.{u, u, u, u}) ◁ pointMulHom P) ≫ + pointMulHom P).evenMap + (tmulEE ((pointMod P).tensor (pointMod P)) (pointMod P) + (tmulEE (pointMod P) (pointMod P) a b) c) := by + have e1 : (SuperCommAlgebra.Mod.tensorHom (pointMulHom P) + (𝟙 (pointMod P))).evenMap + (tmulEE ((pointMod P).tensor (pointMod P)) (pointMod P) + (tmulEE (pointMod P) (pointMod P) a b) c) = + tmulEE (pointMod P) (pointMod P) + (ULift.up (a.down * b.down)) c := by + rw [tensorHom_evenMap_tmulEE, pointMulHom_evenMap_tmulEE] + rfl + have e2 : (assocHom (pointMod P) (pointMod P) + (pointMod P : S.Mod.{u, u, u, u})).evenMap + (tmulEE ((pointMod P).tensor (pointMod P)) (pointMod P) + (tmulEE (pointMod P) (pointMod P) a b) c) = + tmulEE (pointMod P) ((pointMod P).tensor (pointMod P)) a + (tmulEE (pointMod P) (pointMod P) b c) := by + rw [assocHom_evenMap_tmulEE, assocFee_tmulEE] + have e3 : (SuperCommAlgebra.Mod.tensorHom (𝟙 (pointMod P)) + (pointMulHom P)).evenMap + (tmulEE (pointMod P) ((pointMod P).tensor (pointMod P)) a + (tmulEE (pointMod P) (pointMod P) b c)) = + tmulEE (pointMod P) (pointMod P) a + (ULift.up (b.down * c.down)) := by + rw [tensorHom_evenMap_tmulEE, pointMulHom_evenMap_tmulEE] + rfl + change (pointMulHom P).evenMap + ((SuperCommAlgebra.Mod.tensorHom (pointMulHom P) + (𝟙 (pointMod P))).evenMap + (tmulEE ((pointMod P).tensor (pointMod P)) (pointMod P) + (tmulEE (pointMod P) (pointMod P) a b) c)) = + (pointMulHom P).evenMap + ((SuperCommAlgebra.Mod.tensorHom (𝟙 (pointMod P)) + (pointMulHom P)).evenMap + ((assocHom (pointMod P) (pointMod P) + (pointMod P : S.Mod.{u, u, u, u})).evenMap + (tmulEE ((pointMod P).tensor (pointMod P)) (pointMod P) + (tmulEE (pointMod P) (pointMod P) a b) c))) + erw [e1, e2, e3, pointMulHom_evenMap_tmulEE, + pointMulHom_evenMap_tmulEE] + refine ULift.ext _ _ ?_ + change a.down * b.down * c.down = a.down * (b.down * c.down) + exact mul_assoc _ _ _ + +/-- **The multiplication of the residue module is associative.** -/ +theorem pointMulHom_assoc : + ((pointMulHom P ▷ pointMod P) ≫ pointMulHom P : + ((pointMod P).tensor (pointMod P)).tensor (pointMod P) ⟶ + pointMod P) = + (α_ (pointMod P) (pointMod P) + (pointMod P : S.Mod.{u, u, u, u})).hom ≫ + ((pointMod P : S.Mod.{u, u, u, u}) ◁ pointMulHom P) ≫ + pointMulHom P := by + refine hom_ext₃ (fun a b c => point_triple_ee P a b c) + (fun a b c => ?_) (fun a b c => ?_) (fun a b c => ?_) + (fun a b c => Subsingleton.elim _ _) + (fun a b c => Subsingleton.elim _ _) + (fun a b c => Subsingleton.elim _ _) + (fun a b c => Subsingleton.elim _ _) + · have h : tmulEE ((pointMod P).tensor (pointMod P)) + (pointMod P : S.Mod.{u, u, u, u}) + (tmulOO (pointMod P) (pointMod P) a b) c = 0 := by + rw [pointMod_odd_eq_zero P a, map_zero, LinearMap.zero_apply, + map_zero, LinearMap.zero_apply] + rw [h, map_zero, map_zero] + · have h : tmulOO ((pointMod P).tensor (pointMod P)) + (pointMod P : S.Mod.{u, u, u, u}) + (tmulEO (pointMod P) (pointMod P) a b) c = 0 := by + rw [pointMod_odd_eq_zero P c, map_zero] + rw [h, map_zero, map_zero] + · have h : tmulOO ((pointMod P).tensor (pointMod P)) + (pointMod P : S.Mod.{u, u, u, u}) + (tmulOE (pointMod P) (pointMod P) a b) c = 0 := by + rw [pointMod_odd_eq_zero P c, map_zero] + rw [h, map_zero, map_zero] + +/-- **The point is a left unit for the multiplication of the +residue module.** -/ +theorem pointMulHom_left_unit : + ((pointUnitHom P ▷ pointMod P) ≫ pointMulHom P : + (S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod P) ⟶ + pointMod P) = + (λ_ (pointMod P : S.Mod.{u, u, u, u})).hom := by + refine hom_ext (fun x a => ?_) (fun u v => ?_) + (fun x v => Subsingleton.elim _ _) + (fun u a => Subsingleton.elim _ _) + · conv_lhs => + rw [modWhiskerRight, comp_evenMap, LinearMap.comp_apply, tensorHom_evenMap_tmulEE, + pointUnitHom_evenMap, id_evenMap, LinearMap.id_coe, id_eq] + erw [pointMulHom_evenMap_tmulEE] + conv_rhs => rw [modLeftUnitor_hom, + leftUnitorHom_evenMap_tmulEE, pointMod_actEE] + · rw [pointMod_odd_eq_zero P v, map_zero, map_zero, map_zero] + +/-- **The point is a right unit for the multiplication of the +residue module.** -/ +theorem pointMulHom_right_unit : + (((pointMod P : S.Mod.{u, u, u, u}) ◁ pointUnitHom P) ≫ + pointMulHom P : + (pointMod P : S.Mod.{u, u, u, u}).tensor S.unitMod ⟶ + pointMod P) = + (ρ_ (pointMod P : S.Mod.{u, u, u, u})).hom := by + refine hom_ext (fun a x => ?_) (fun v u => ?_) + (fun a u => Subsingleton.elim _ _) + (fun v x => Subsingleton.elim _ _) + · conv_lhs => + rw [modWhiskerLeft, comp_evenMap, LinearMap.comp_apply, tensorHom_evenMap_tmulEE, + pointUnitHom_evenMap, id_evenMap, LinearMap.id_coe, id_eq] + erw [pointMulHom_evenMap_tmulEE] + conv_rhs => rw [modRightUnitor_hom, + rightUnitorHom_evenMap_tmulEE, pointMod_actEE] + exact ULift.ext _ _ (mul_comm _ _) + · rw [pointMod_odd_eq_zero P v, map_zero, LinearMap.zero_apply, + map_zero, map_zero] + +/-- **The multiplication of the residue module is commutative.** -/ +theorem pointMulHom_comm : + ((β_ (pointMod P) (pointMod P : S.Mod.{u, u, u, u})).hom ≫ + pointMulHom P) = pointMulHom P := by + refine hom_ext (fun a b => ?_) (fun a b => ?_) + (fun a b => Subsingleton.elim _ _) + (fun a b => Subsingleton.elim _ _) + · conv_lhs => rw [modBraiding_hom, comp_evenMap, + LinearMap.comp_apply, braidingHom_evenMap_tmulEE, + pointMulHom_evenMap_tmulEE] + conv_rhs => rw [pointMulHom_evenMap_tmulEE] + exact ULift.ext _ _ (mul_comm _ _) + · rw [pointMod_odd_eq_zero P a, map_zero, LinearMap.zero_apply, + map_zero, map_zero] + +end MonoidLaws + +/-! ## Base change over the algebra is lax monoidal -/ + +section AlgebraCoherence + +variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) + +/-- **Associativity of the comparison over the algebra.** -/ +theorem pointBaseMu_associativity (M N Q : S.Mod.{u, u, u, u}) : + (pointBaseMu P M N ▷ (Q.tensor (pointMod P))) ≫ + pointBaseMu P (M.tensor N) Q ≫ + ((α_ M N Q).hom ▷ pointMod P) = + (α_ (M.tensor (pointMod P)) (N.tensor (pointMod P)) + (Q.tensor (pointMod P))).hom ≫ + ((M.tensor (pointMod P) : S.Mod.{u, u, u, u}) ◁ + pointBaseMu P N Q) ≫ pointBaseMu P M (N.tensor Q) := by + simp only [pointBaseMu, ← modTensorObj, comp_whiskerRight, + whiskerLeft_comp, Category.assoc] + rw [← id_tensorHom (M ⊗ N) (pointMulHom P), + tensorμ_natural_left_assoc, id_whiskerRight, id_tensorHom, + ← whiskerLeft_comp_assoc, pointMulHom_assoc, + whiskerLeft_comp_assoc, whisker_exchange, + ← tensorHom_def'_assoc] + change tensorμ M (pointMod P) N (pointMod P) ▷ (Q ⊗ pointMod P) ≫ + tensorμ (M ⊗ N) (pointMod P ⊗ pointMod P) Q (pointMod P) ≫ + ((α_ M N Q).hom ⊗ₘ + (α_ (pointMod P) (pointMod P) (pointMod P)).hom) ≫ + ((M ⊗ N ⊗ Q) ◁ ((pointMod P ◁ pointMulHom P) ≫ + pointMulHom P)) = _ + rw [tensor_associativity_assoc, + ← id_tensorHom (N ⊗ Q) (pointMulHom P), + tensorμ_natural_right_assoc, whiskerLeft_id, id_tensorHom, + ← whiskerLeft_comp] + rfl + +/-- **Left unitality of the comparison over the algebra.** -/ +theorem pointBaseMu_left_unitality (M : S.Mod.{u, u, u, u}) : + (λ_ (M.tensor (pointMod P))).hom = + (pointBaseEps P ▷ (M.tensor (pointMod P))) ≫ + pointBaseMu P S.unitMod M ≫ ((λ_ M).hom ▷ pointMod P) := by + simp only [pointBaseMu, pointBaseEps, ← modTensorObj, + ← modTensorUnit, comp_whiskerRight, Category.assoc] + rw [← unitors_inv_equal, ← id_tensorHom (𝟙_ (S.Mod.{u, u, u, u})) + (pointUnitHom P), tensorμ_natural_left_assoc, id_whiskerRight, + id_tensorHom, ← whiskerLeft_comp_assoc, pointMulHom_left_unit, + ← tensorHom_def'] + exact tensor_left_unitality M (pointMod P) + +/-- **Right unitality of the comparison over the algebra.** -/ +theorem pointBaseMu_right_unitality (M : S.Mod.{u, u, u, u}) : + (ρ_ (M.tensor (pointMod P))).hom = + ((M.tensor (pointMod P) : S.Mod.{u, u, u, u}) ◁ + pointBaseEps P) ≫ + pointBaseMu P M S.unitMod ≫ ((ρ_ M).hom ▷ pointMod P) := by + simp only [pointBaseMu, pointBaseEps, ← modTensorObj, + ← modTensorUnit, whiskerLeft_comp, Category.assoc] + rw [← unitors_inv_equal, ← id_tensorHom (𝟙_ (S.Mod.{u, u, u, u})) + (pointUnitHom P), tensorμ_natural_right_assoc, whiskerLeft_id, + id_tensorHom, ← whiskerLeft_comp_assoc, pointMulHom_right_unit, + ← tensorHom_def'] + exact tensor_right_unitality M (pointMod P) + +/-- **The comparison over the algebra intertwines the braidings.** +The interchange does so by `RS.tensorμ_braiding`, and the residue +factor by commutativity of its multiplication. -/ +theorem pointBaseMu_braiding (M N : S.Mod.{u, u, u, u}) : + pointBaseMu P M N ≫ ((β_ M N).hom ▷ pointMod P) = + (β_ (M ⊗ pointMod P) (N ⊗ pointMod P)).hom ≫ + pointBaseMu P N M := by + simp only [pointBaseMu, ← modTensorObj, Category.assoc] + rw [tensorμ_braiding_assoc] + congr 1 + rw [← MonoidalCategory.id_tensorHom (M ⊗ N) (pointMulHom P), + ← MonoidalCategory.tensorHom_id (β_ M N).hom (pointMod P), + ← MonoidalCategory.id_tensorHom (N ⊗ M) (pointMulHom P), + MonoidalCategory.tensorHom_comp_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, Category.comp_id, + pointMulHom_comm, Category.id_comp, Category.comp_id] + +end AlgebraCoherence + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointTensor.lean new file mode 100644 index 0000000000..e6799e5bb3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointTensor.lean @@ -0,0 +1,77 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitSimple + +/-! +# Points of objects tensor without vanishing + +In the setting of Deligne's theorem the tensor unit is simple, so +a nonzero morphism out of it is a monomorphism; whiskering is +exact, so the tensor of two nonzero points is again a +monomorphism, and in particular nonzero. This is the input that +makes a tensor product of nonzero algebras nonzero. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Limits MonoidalCategory + +universe v u + +variable {A : Type u} + +/-- **A nonzero point is a monomorphism**: the unit is simple. -/ +theorem mono_of_point_ne_zero + [Category.{v} A] [Abelian A] [Linear ℂ A] [MonoidalCategory A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] [RigidCategory A] + (hu : HasScalarUnit A) {X : A} + {u : 𝟙_ A ⟶ X} (h : u ≠ 0) : Mono u := by + have := simple_unit_of_hasScalarUnit hu + exact mono_of_nonzero_from_simple h + +/-- **The tensor of two nonzero points is a monomorphism.** -/ +theorem mono_tensorHom_point + [Category.{v} A] [Abelian A] [Linear ℂ A] [MonoidalCategory A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] [RigidCategory A] + (hu : HasScalarUnit A) {X Y : A} + {u : 𝟙_ A ⟶ X} {v : 𝟙_ A ⟶ Y} (hu0 : u ≠ 0) (hv0 : v ≠ 0) : + Mono (u ⊗ₘ v) := by + have : Mono u := mono_of_point_ne_zero hu hu0 + have : Mono v := mono_of_point_ne_zero hu hv0 + have hR : (tensorRight (𝟙_ A)).PreservesMonomorphisms := + Functor.preservesMonomorphisms_of_adjunction + (tensorRightAdjunction (ᘁ(𝟙_ A)) (𝟙_ A)) + have hL : (tensorLeft X).PreservesMonomorphisms := + Functor.preservesMonomorphisms_of_adjunction + (tensorLeftAdjunction X (Xᘁ)) + have hmu : Mono (u ▷ 𝟙_ A) := hR.preserves (f := u) + have hmv : Mono (X ◁ v) := hL.preserves (f := v) + rw [MonoidalCategory.tensorHom_def] + exact mono_comp _ _ + +/-- **The tensor of two nonzero points is nonzero.** -/ +theorem tensorHom_point_ne_zero + [Category.{v} A] [Abelian A] [Linear ℂ A] [MonoidalCategory A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] [RigidCategory A] + (hu : HasScalarUnit A) {X Y : A} + {u : 𝟙_ A ⟶ X} {v : 𝟙_ A ⟶ Y} (hu0 : u ≠ 0) (hv0 : v ≠ 0) : + (u ⊗ₘ v) ≠ 0 := by + have := mono_tensorHom_point hu hu0 hv0 + intro h0 + have hid : 𝟙 (𝟙_ A ⊗ 𝟙_ A) = 0 := by + refine (cancel_mono (u ⊗ₘ v)).mp ?_ + rw [Category.id_comp, h0, Limits.zero_comp] + refine id_unit_ne_zero hu ?_ + have := congrArg + (fun t => (λ_ (𝟙_ A)).inv ≫ t ≫ (λ_ (𝟙_ A)).hom) hid + simpa using this + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowAct.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowAct.lean new file mode 100644 index 0000000000..e3f8780b29 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowAct.lean @@ -0,0 +1,1159 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymMul + +/-! +# The monoid action on module powers and symmetric powers + +Over an internal commutative monoid `A` and a left module `X` in a +braided category, the tensor powers of `X` carry an `A`-action +through their last factor, with `A` braided past the lower factors. +This module descends that action through the coequalizers of +`SymAlg.lean`, making every positive module power and every positive +symmetric power a module again. + +* `braidPast A V T`: the structural isomorphism carrying `A` across + a context `V`, with naturality in both the context and the tail. +* `actAcross`/`tensorLeftModObj`: a module tensored with an object + on the left is again a module, acting through the right factor — + the braided mirror of `tensorRightModObj`. +* `powTailAct`: the induced action on `tensorPow D X (n + 1)`. +* `modPowAct`/`modPowModObj`: over a commutative monoid the tail + action descends to the module power; the slot relations away from + the top factor pass by naturality alone, and the top slot passes + by one slot relation together with commutativity. +* `modPowAct_perm`/`modPowAct_alg`: the descended action commutes + with the permutation action and its `ℂ`-linear extension. +* `symPowAct`/`symPowModObj`: the action descends to the symmetric + power, with `symPowσ` a module map. +* `modPowMod`/`symPowMod`: the bundled modules. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## Braiding a monoid past a context -/ + +section BraidPast + +/-- Carry an object across a context: the isomorphism +`A ⊗ (V ⊗ T) ≅ V ⊗ (A ⊗ T)` braiding `A` past `V`. -/ +def braidPast [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (A V T : D) : A ⊗ (V ⊗ T) ≅ V ⊗ (A ⊗ T) := + (α_ A V T).symm ≪≫ whiskerRightIso (β_ A V) T ≪≫ α_ V A T + +@[simp] +theorem braidPast_hom [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (A V T : D) : + (braidPast A V T).hom = + (α_ A V T).inv ≫ ((β_ A V).hom ▷ T) ≫ (α_ V A T).hom := by + simp [braidPast] + +/-- The carrying isomorphism is natural in the tail. -/ +@[reassoc] +theorem braidPast_natural_tail + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (A V : D) {T T' : D} (g : T ⟶ T') : + (A ◁ (V ◁ g)) ≫ (braidPast A V T').hom = + (braidPast A V T).hom ≫ (V ◁ (A ◁ g)) := by + simp only [braidPast_hom] + rw [associator_inv_naturality_right_assoc, whisker_exchange_assoc, + associator_naturality_right] + simp only [Category.assoc] + +/-- The carrying isomorphism is natural in the context. -/ +@[reassoc] +theorem braidPast_natural_context + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (A : D) {V V' : D} (f : V ⟶ V') + (T : D) : + (A ◁ (f ▷ T)) ≫ (braidPast A V' T).hom = + (braidPast A V T).hom ≫ (f ▷ (A ⊗ T)) := by + simp only [braidPast_hom] + rw [associator_inv_naturality_middle_assoc, + ← comp_whiskerRight_assoc, + BraidedCategory.braiding_naturality_right, + comp_whiskerRight_assoc, associator_naturality_left] + simp only [Category.assoc] + +/-- Carrying past a tensor context is carrying past the factors in +turn. -/ +theorem braidPast_tensor_context + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (A V₁ V₂ T : D) : + (α_ A (V₁ ⊗ V₂) T).inv ≫ ((β_ A (V₁ ⊗ V₂)).hom ▷ T) ≫ + (α_ (V₁ ⊗ V₂) A T).hom ≫ (α_ V₁ V₂ (A ⊗ T)).hom = + (A ◁ (α_ V₁ V₂ T).hom) ≫ (braidPast A V₁ (V₂ ⊗ T)).hom ≫ + (V₁ ◁ (braidPast A V₂ T).hom) := by + rw [BraidedCategory.braiding_tensor_right_hom] + simp only [braidPast_hom, comp_whiskerRight, whiskerLeft_comp, + Category.assoc] + monoidal + +/-- Carrying a tensor pair past a context is carrying the factors +past it in turn. -/ +theorem braidPast_tensor_first + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (A₁ A₂ V T : D) : + (α_ (A₁ ⊗ A₂) V T).inv ≫ ((β_ (A₁ ⊗ A₂) V).hom ▷ T) ≫ + (α_ V (A₁ ⊗ A₂) T).hom = + (α_ A₁ A₂ (V ⊗ T)).hom ≫ (A₁ ◁ (braidPast A₂ V T).hom) ≫ + (braidPast A₁ V (A₂ ⊗ T)).hom ≫ (V ◁ (α_ A₁ A₂ T).inv) := by + rw [BraidedCategory.braiding_tensor_left_hom] + simp only [braidPast_hom, comp_whiskerRight, whiskerLeft_comp, + Category.assoc] + monoidal + +end BraidPast + +/-! ## The action through the right tensor factor -/ + +section ActAcross + +/-- The action of a monoid on `V ⊗ X` through the right factor: +braid `A` past `V`, then act on `X`. -/ +def actAcross [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] + (V X : D) [ModObj A X] : A ⊗ (V ⊗ X) ⟶ V ⊗ X := + (α_ A V X).inv ≫ ((β_ A V).hom ▷ X) ≫ (α_ V A X).hom ≫ + (V ◁ actLeft A X) + +/-- The action through the right factor, through the carrying +isomorphism. -/ +theorem actAcross_eq_braidPast + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] + (V X : D) [ModObj A X] : + actAcross A V X = (braidPast A V X).hom ≫ (V ◁ actLeft A X) := by + simp [actAcross] + +/-- The action through the right factor is natural in the +context. -/ +@[reassoc] +theorem actAcross_natural + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] + {V V' : D} (f : V ⟶ V') (X : D) + [ModObj A X] : + (A ◁ (f ▷ X)) ≫ actAcross A V' X = actAcross A V X ≫ (f ▷ X) := by + rw [actAcross_eq_braidPast A V' X, actAcross_eq_braidPast A V X, + ← Category.assoc, braidPast_natural_context, Category.assoc, + ← whisker_exchange] + simp only [Category.assoc] + +/-- Unitality of the action through the right factor. -/ +theorem one_actAcross + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] + (V X : D) [ModObj A X] : + η[A] ▷ (V ⊗ X) ≫ actAcross A V X = (λ_ (V ⊗ X)).hom := by + rw [actAcross, associator_inv_naturality_left_assoc, + ← comp_whiskerRight_assoc, + BraidedCategory.braiding_naturality_left, + braiding_tensorUnit_left, comp_whiskerRight_assoc, + associator_naturality_middle_assoc, ← whiskerLeft_comp, + one_actLeft] + monoidal + +/-- Associativity of the action through the right factor. -/ +theorem mul_actAcross + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] + (V X : D) [ModObj A X] : + μ[A] ▷ (V ⊗ X) ≫ actAcross A V X = + (α_ A A (V ⊗ X)).hom ≫ (A ◁ actAcross A V X) ≫ + actAcross A V X := by + have hL : μ[A] ▷ (V ⊗ X) ≫ actAcross A V X = + (α_ A A (V ⊗ X)).hom ≫ (A ◁ (braidPast A V X).hom) ≫ + (braidPast A V (A ⊗ X)).hom ≫ + (V ◁ ((α_ A A X).inv ≫ μ[A] ▷ X ≫ actLeft A X)) := by + rw [actAcross, associator_inv_naturality_left_assoc, + ← comp_whiskerRight_assoc, + BraidedCategory.braiding_naturality_left, + comp_whiskerRight_assoc, associator_naturality_middle_assoc, + reassoc_of% (braidPast_tensor_first A A V X)] + simp only [whiskerLeft_comp] + have hR : (A ◁ actAcross A V X) ≫ actAcross A V X = + (A ◁ (braidPast A V X).hom) ≫ (braidPast A V (A ⊗ X)).hom ≫ + (V ◁ ((α_ A A X).inv ≫ μ[A] ▷ X ≫ actLeft A X)) := by + rw [actAcross_eq_braidPast] + simp only [whiskerLeft_comp, Category.assoc] + rw [braidPast_natural_tail_assoc, ← whiskerLeft_comp, + actLeft_actLeft] + simp only [whiskerLeft_comp] + rw [hL, hR] + +/-- A left module tensored with an object on the left: the action +of `A` on `V ⊗ X` through the right factor. -/ +@[implicit_reducible] +def tensorLeftModObj + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] + (V X : D) [ModObj A X] : ModObj A (V ⊗ X) where + smul := actAcross A V X + one_smul := one_actAcross A V X + mul_smul := mul_actAcross A V X + +@[simp] theorem tensorLeftModObj_smul + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] + (V X : D) [ModObj A X] : + (tensorLeftModObj A V X).smul = + (α_ A V X).inv ≫ ((β_ A V).hom ▷ X) ≫ (α_ V A X).hom ≫ + (V ◁ actLeft A X) := + rfl + +/-- The action through the right factor decomposes over a tensor +context: braid past the outer factor, then act through the +inner one. -/ +@[reassoc] +theorem actAcross_context_split + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] + (V₁ V₂ X : D) [ModObj A X] : + actAcross A (V₁ ⊗ V₂) X ≫ (α_ V₁ V₂ X).hom = + (A ◁ (α_ V₁ V₂ X).hom) ≫ (braidPast A V₁ (V₂ ⊗ X)).hom ≫ + (V₁ ◁ actAcross A V₂ X) := by + rw [actAcross] + simp only [Category.assoc] + rw [associator_naturality_right, + reassoc_of% (braidPast_tensor_context A V₁ V₂ X), + actAcross_eq_braidPast] + simp only [whiskerLeft_comp] + +/-- The action through the right factor of a two-step context, +conjugated by the associator: braid past the outer factor, act +inside the last two. -/ +theorem actAcross_split_last + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] + (V X : D) [ModObj A X] : + (A ◁ (α_ V X X).inv) ≫ actAcross A (V ⊗ X) X = + (braidPast A V (X ⊗ X)).hom ≫ (V ◁ actAcross A X X) ≫ + (α_ V X X).inv := by + rw [← cancel_mono (α_ V X X).hom] + simp only [Category.assoc, Iso.inv_hom_id, Category.comp_id] + rw [actAcross_context_split, ← whiskerLeft_comp_assoc, + Iso.inv_hom_id, whiskerLeft_id, Category.id_comp] + +/-- An action through the right factor, precomposed with a +reassociated whiskered morphism into the context. -/ +theorem whiskerLeft_associator_inv_actAcross + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] + {P₁ P₂ Q : D} + (g : P₁ ⊗ P₂ ⟶ Q) (X : D) [ModObj A X] {Z : D} (p : Q ⊗ X ⟶ Z) : + (A ◁ ((α_ P₁ P₂ X).inv ≫ (g ▷ X))) ≫ actAcross A Q X ≫ p = + (A ◁ (α_ P₁ P₂ X).inv) ≫ actAcross A (P₁ ⊗ P₂) X ≫ + (g ▷ X) ≫ p := by + rw [whiskerLeft_comp, Category.assoc, actAcross_natural_assoc] + +/-- Over a commutative monoid the braided self-crossing of the +action agrees with the plain iterated action. -/ +theorem actAcross_actLeft + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] + [IsCommMonObj A] (X : D) [ModObj A X] : + actAcross A A X ≫ actLeft A X = + (A ◁ actLeft A X) ≫ actLeft A X := by + rw [actAcross] + simp only [Category.assoc] + rw [actLeft_actLeft] + simp only [Iso.hom_inv_id_assoc] + rw [← comp_whiskerRight_assoc, IsCommMonObj.mul_comm] + +/-- **The key commutation**: over a commutative monoid the external +action slides across a slot leg acting on the inner factor. -/ +theorem actAcross_winLegN + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] + [IsCommMonObj A] (X : D) [ModObj A X] : + actAcross A (X ⊗ A) X ≫ winLegN A X = + (A ◁ winLegN A X) ≫ actAcross A X X := by + rw [winLegN, ← Category.assoc, actAcross_context_split] + simp only [whiskerLeft_comp, Category.assoc] + rw [← whiskerLeft_comp, actAcross_actLeft, whiskerLeft_comp, + actAcross_eq_braidPast, ← braidPast_natural_tail_assoc] + +end ActAcross + +/-! ## The tail action on tensor powers -/ + +section PowTail + +/-- The raw tail action on a positive tensor power: the monoid acts +on the last factor, braided past the lower power. -/ +def powTailAct [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] + (n : ℕ) : + A ⊗ tensorPow D X (n + 1) ⟶ tensorPow D X (n + 1) := + (tensorLeftModObj A (tensorPow D X n) X).smul + +/-- The tail action is the action through the right factor at the +definitional fold of the tensor power. -/ +theorem powTailAct_eq + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] + (n : ℕ) : + powTailAct A X n = actAcross A (tensorPow D X n) X := + rfl + +/-- Unitality of the tail action. -/ +@[reassoc] +theorem powTailAct_one + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] + (n : ℕ) : + η[A] ▷ tensorPow D X (n + 1) ≫ powTailAct A X n = + (λ_ (tensorPow D X (n + 1))).hom := + one_actAcross A (tensorPow D X n) X + +/-- Associativity of the tail action. -/ +@[reassoc] +theorem powTailAct_mul + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] + (n : ℕ) : + μ[A] ▷ tensorPow D X (n + 1) ≫ powTailAct A X n = + (α_ A A (tensorPow D X (n + 1))).hom ≫ + (A ◁ powTailAct A X n) ≫ powTailAct A X n := + mul_actAcross A (tensorPow D X n) X + +end PowTail + +/-! ## Descent of the tail action to the module power + +The tail action coequalizes the whiskered relation legs: at a slot +away from the top factor the action and the leg touch disjoint +factors and pass one another by naturality, and at the top slot one +slot relation together with commutativity of the monoid closes the +square. Every equation crossing the definitional fold +`tensorPow D X (n + 1) = tensorPow D X n ⊗ X` is applied by exact +term-level composition, never by rewriting inside a foreign frame. +-/ + +section GlueAux + +/-- Splitting a below-top slot leg, at general objects. -/ +private theorem below_aux [Category.{v} D] [MonoidalCategory D] + {Y P Q B Z : D} (θ : P ⟶ Q) + (c : Q ⊗ B ⟶ Z) : + (θ ▷ (B ⊗ Y)) ≫ (α_ Q B Y).inv ≫ (c ▷ Y) = + (α_ P B Y).inv ≫ (((θ ▷ B) ≫ c) ▷ Y) := by + rw [associator_inv_naturality_left_assoc] + simp only [comp_whiskerRight] + +end GlueAux + +section ActDescent + +/-- The first assembled leg as a sum over the slots. -/ +private theorem legFst_eq_sum + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + (n : ℕ) : + modPowLegFst A X n = ∑ i : Fin (n - 1), + biproduct.π + (fun i : Fin (n - 1) => modPowMid A X i.val (n - 2 - i.val)) + i ≫ + (modPowLegM A X i.val (n - 2 - i.val) ≫ + powCast X (slot_decomp i)) := by + conv_lhs => rw [← Category.id_comp (modPowLegFst A X n), + ← biproduct.total] + rw [Preadditive.sum_comp] + refine Finset.sum_congr rfl fun i _ => ?_ + rw [Category.assoc, modPowLegFst, biproduct.ι_desc] + +/-- The second assembled leg as a sum over the slots. -/ +private theorem legSnd_eq_sum + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : D) + [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + (n : ℕ) : + modPowLegSnd A X n = ∑ i : Fin (n - 1), + biproduct.π + (fun i : Fin (n - 1) => modPowMid A X i.val (n - 2 - i.val)) + i ≫ + (modPowLegN A X i.val (n - 2 - i.val) ≫ + powCast X (slot_decomp i)) := by + conv_lhs => rw [← Category.id_comp (modPowLegSnd A X n), + ← biproduct.total] + rw [Preadditive.sum_comp] + refine Finset.sum_congr rfl fun i _ => ?_ + rw [Category.assoc, modPowLegSnd, biproduct.ι_desc] + +/-- A slot-wise coequalizing condition assembles over the +left-whiskered legs. -/ +private theorem legs_whiskerLeft_cond + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] + (P : D) {n : ℕ} {Z : D} + (k : P ⊗ tensorPow D X n ⟶ Z) + (h : ∀ a b (hab : a + 2 + b = n), + (P ◁ (modPowLegM A X a b ≫ powCast X hab)) ≫ k = + (P ◁ (modPowLegN A X a b ≫ powCast X hab)) ≫ k) : + (P ◁ modPowLegFst A X n) ≫ k = + (P ◁ modPowLegSnd A X n) ≫ k := by + rw [legFst_eq_sum, legSnd_eq_sum, whiskerLeft_sum, whiskerLeft_sum, + Preadditive.sum_comp, Preadditive.sum_comp] + refine Finset.sum_congr rfl fun i _ => ?_ + have hi := h i.val (n - 2 - i.val) (slot_decomp i) + simp only [whiskerLeft_comp, Category.assoc] at hi ⊢ + rw [hi] + +/-- **A below-top slot leg splits off the last factor**: the leg of +slot `(a, b + 1)` in arity `a + 2 + b + 1` is the leg of slot +`(a, b)` in arity `a + 2 + b`, whiskered by the untouched last +factor. -/ +private theorem leg_split_below + [Category.{v} D] [MonoidalCategory D] (A : D) (X : D) + (a b : ℕ) (w : (X ⊗ A) ⊗ X ⟶ X ⊗ X) : + ((tensorPow D X a ◁ w) ▷ tensorPow D X (b + 1)) ≫ + modPowGlue X a (b + 1) = + (α_ (tensorPow D X a ⊗ ((X ⊗ A) ⊗ X)) (tensorPow D X b) + X).inv ≫ + ((((tensorPow D X a ◁ w) ▷ tensorPow D X b) ≫ + modPowGlue X a b) ▷ X) := by + have h0 := below_aux (Y := X) + ((tensorPow D X a ◁ w) ≫ (α_ (tensorPow D X a) X X).inv) + ((tensorPowConcat X (a + 2) b).hom) + simp only [modPowGlue, tensorPowConcat_succ_hom, powExpose, + comp_whiskerRight, Category.assoc] at h0 ⊢ + simpa only [tensorPow, comp_whiskerRight, Category.assoc] using! h0 + +/-- **The below-top slots pass the tail action** by naturality. -/ +private theorem act_slot_below + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (a b : ℕ) : + (A ◁ modPowLegM A X a (b + 1)) ≫ powTailAct A X (a + 2 + b) ≫ + modPowπ A X (a + 2 + b + 1) = + (A ◁ modPowLegN A X a (b + 1)) ≫ powTailAct A X (a + 2 + b) ≫ + modPowπ A X (a + 2 + b + 1) := by + have hkey : ∀ w : (X ⊗ A) ⊗ X ⟶ X ⊗ X, + (A ◁ (((tensorPow D X a ◁ w) ▷ tensorPow D X (b + 1)) ≫ + modPowGlue X a (b + 1))) ≫ + powTailAct A X (a + 2 + b) ≫ modPowπ A X (a + 2 + b + 1) = + (A ◁ (α_ (tensorPow D X a ⊗ ((X ⊗ A) ⊗ X)) + (tensorPow D X b) X).inv) ≫ + actAcross A + ((tensorPow D X a ⊗ ((X ⊗ A) ⊗ X)) ⊗ tensorPow D X b) + X ≫ + ((((tensorPow D X a ◁ w) ▷ tensorPow D X b) ≫ + modPowGlue X a b) ▷ X) ≫ + modPowπ A X (a + 2 + b + 1) := + fun w => + (congrArg + (fun z : modPowMid A X a (b + 1) ⟶ + tensorPow D X (a + 2 + (b + 1)) => + (A ◁ z) ≫ powTailAct A X (a + 2 + b) ≫ + modPowπ A X (a + 2 + b + 1)) + (leg_split_below A X a b w)).trans + (whiskerLeft_associator_inv_actAcross A + (((tensorPow D X a ◁ w) ▷ tensorPow D X b) ≫ + modPowGlue X a b) + X (modPowπ A X (a + 2 + b + 1))) + have hid : powCast X (rfl : a + 2 + (b + 1) = a + 2 + b + 1) ≫ + modPowπ A X (a + 2 + b + 1) = modPowπ A X (a + 2 + b + 1) := + Category.id_comp _ + have hr : modPowLegM A X a (b + 1) ≫ modPowπ A X (a + 2 + b + 1) = + modPowLegN A X a (b + 1) ≫ modPowπ A X (a + 2 + b + 1) := + (congrArg (fun z => modPowLegM A X a (b + 1) ≫ z) + hid).symm.trans + ((modPow_rel A X a (b + 1) + (rfl : a + 2 + (b + 1) = a + 2 + b + 1)).trans + (congrArg (fun z => modPowLegN A X a (b + 1) ≫ z) hid)) + have hrelW : + ((((tensorPow D X a ◁ winLegM A X) ▷ tensorPow D X b) ≫ + modPowGlue X a b) ▷ X) ≫ modPowπ A X (a + 2 + b + 1) = + ((((tensorPow D X a ◁ winLegN A X) ▷ tensorPow D X b) ≫ + modPowGlue X a b) ▷ X) ≫ modPowπ A X (a + 2 + b + 1) := by + have hM := congrArg + (fun z : modPowMid A X a (b + 1) ⟶ + tensorPow D X (a + 2 + (b + 1)) => + z ≫ modPowπ A X (a + 2 + b + 1)) + (leg_split_below A X a b (winLegM A X)) + have hN := congrArg + (fun z : modPowMid A X a (b + 1) ⟶ + tensorPow D X (a + 2 + (b + 1)) => + z ≫ modPowπ A X (a + 2 + b + 1)) + (leg_split_below A X a b (winLegN A X)) + have h3 := hM.symm.trans (hr.trans hN) + have h4 := (Category.assoc + (α_ (tensorPow D X a ⊗ ((X ⊗ A) ⊗ X)) (tensorPow D X b) + X).inv + ((((tensorPow D X a ◁ winLegM A X) ▷ tensorPow D X b) ≫ + modPowGlue X a b) ▷ X) + (modPowπ A X (a + 2 + b + 1))).symm.trans + (h3.trans (Category.assoc + (α_ (tensorPow D X a ⊗ ((X ⊗ A) ⊗ X)) (tensorPow D X b) + X).inv + ((((tensorPow D X a ◁ winLegN A X) ▷ tensorPow D X b) ≫ + modPowGlue X a b) ▷ X) + (modPowπ A X (a + 2 + b + 1)))) + exact (cancel_epi + (α_ (tensorPow D X a ⊗ ((X ⊗ A) ⊗ X)) (tensorPow D X b) + X).inv).mp h4 + exact (hkey (winLegM A X)).trans + ((congrArg + (fun z => (A ◁ (α_ (tensorPow D X a ⊗ ((X ⊗ A) ⊗ X)) + (tensorPow D X b) X).inv) ≫ + actAcross A + ((tensorPow D X a ⊗ ((X ⊗ A) ⊗ X)) ⊗ tensorPow D X b) + X ≫ z) + hrelW).trans (hkey (winLegN A X)).symm) + +/-- The top-slot glue absorbed by the right unitor, at general +objects. -/ +private theorem top_glue_aux + [Category.{v} D] [MonoidalCategory D] (A : D) (X : D) + (V : D) {Z : D} + (w : (X ⊗ A) ⊗ X ⟶ X ⊗ X) (p : (V ⊗ X) ⊗ X ⟶ Z) : + (((V ◁ w) ▷ 𝟙_ D) ≫ ((α_ V X X).inv ▷ 𝟙_ D) ≫ + (ρ_ ((V ⊗ X) ⊗ X)).hom) ≫ p = + (ρ_ (V ⊗ ((X ⊗ A) ⊗ X))).hom ≫ (V ◁ w) ≫ + (α_ V X X).inv ≫ p := by + simp only [Category.assoc] + rw [← comp_whiskerRight_assoc, rightUnitor_naturality_assoc] + simp only [Category.assoc] + +/-- The whole top-slot conjugation of the tail action, at general +objects: unwrap the glue, braid past the lower power, and act +inside the window. -/ +private theorem top_act_aux + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] + (V : D) {Z : D} + (w : (X ⊗ A) ⊗ X ⟶ X ⊗ X) (p : (V ⊗ X) ⊗ X ⟶ Z) : + (A ◁ (((V ◁ w) ▷ 𝟙_ D) ≫ ((α_ V X X).inv ▷ 𝟙_ D) ≫ + (ρ_ ((V ⊗ X) ⊗ X)).hom)) ≫ actAcross A (V ⊗ X) X ≫ p = + (A ◁ (ρ_ (V ⊗ ((X ⊗ A) ⊗ X))).hom) ≫ + (braidPast A V ((X ⊗ A) ⊗ X)).hom ≫ + (V ◁ ((A ◁ w) ≫ actAcross A X X)) ≫ + (α_ V X X).inv ≫ p := by + have h1 : ((V ◁ w) ▷ 𝟙_ D) ≫ ((α_ V X X).inv ▷ 𝟙_ D) ≫ + (ρ_ ((V ⊗ X) ⊗ X)).hom = + (ρ_ (V ⊗ ((X ⊗ A) ⊗ X))).hom ≫ (V ◁ w) ≫ + (α_ V X X).inv := by + rw [← comp_whiskerRight_assoc, rightUnitor_naturality] + rw [h1] + simp only [whiskerLeft_comp, Category.assoc] + rw [reassoc_of% (actAcross_split_last A V X), + braidPast_natural_tail_assoc, ← whiskerLeft_comp_assoc] + +/-- The top-slot relation, with the empty upper context already +absorbed. -/ +private theorem rel_top + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (a : ℕ) : + (tensorPow D X a ◁ winLegM A X) ≫ + (α_ (tensorPow D X a) X X).inv ≫ modPowπ A X (a + 2) = + (tensorPow D X a ◁ winLegN A X) ≫ + (α_ (tensorPow D X a) X X).inv ≫ modPowπ A X (a + 2) := by + refine (cancel_epi + (ρ_ (tensorPow D X a ⊗ ((X ⊗ A) ⊗ X))).hom).mp ?_ + have hid : powCast X (rfl : a + 2 + 0 = a + 2) ≫ + modPowπ A X (a + 2) = modPowπ A X (a + 2) := + Category.id_comp _ + have hr : modPowLegM A X a 0 ≫ modPowπ A X (a + 2) = + modPowLegN A X a 0 ≫ modPowπ A X (a + 2) := + (congrArg (fun z => modPowLegM A X a 0 ≫ z) hid).symm.trans + ((modPow_rel A X a 0 (rfl : a + 2 + 0 = a + 2)).trans + (congrArg (fun z => modPowLegN A X a 0 ≫ z) hid)) + exact ((top_glue_aux A X (tensorPow D X a) (winLegM A X) + (modPowπ A X (a + 2))).symm.trans hr).trans + (top_glue_aux A X (tensorPow D X a) (winLegN A X) + (modPowπ A X (a + 2))) + +/-- **The top slot passes the tail action**: one slot relation, and +the commutation of the two actions across the window. -/ +private theorem act_slot_top + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [IsCommMonObj A] + (a : ℕ) : + (A ◁ modPowLegM A X a 0) ≫ powTailAct A X (a + 1) ≫ + modPowπ A X (a + 2) = + (A ◁ modPowLegN A X a 0) ≫ powTailAct A X (a + 1) ≫ + modPowπ A X (a + 2) := by + have hstep : ∀ w : (X ⊗ A) ⊗ X ⟶ X ⊗ X, + (A ◁ (((tensorPow D X a ◁ w) ▷ tensorPow D X 0) ≫ + modPowGlue X a 0)) ≫ + powTailAct A X (a + 1) ≫ modPowπ A X (a + 2) = + (A ◁ (ρ_ (tensorPow D X a ⊗ ((X ⊗ A) ⊗ X))).hom) ≫ + (braidPast A (tensorPow D X a) ((X ⊗ A) ⊗ X)).hom ≫ + (tensorPow D X a ◁ ((A ◁ w) ≫ actAcross A X X)) ≫ + (α_ (tensorPow D X a) X X).inv ≫ modPowπ A X (a + 2) := + fun w => top_act_aux A X (tensorPow D X a) w (modPowπ A X (a + 2)) + have hMwin : (A ◁ winLegM A X) ≫ actAcross A X X = + actAcross A (X ⊗ A) X ≫ winLegM A X := + actAcross_natural A (actRight A X) X + have hmid : + (A ◁ (ρ_ (tensorPow D X a ⊗ ((X ⊗ A) ⊗ X))).hom) ≫ + (braidPast A (tensorPow D X a) ((X ⊗ A) ⊗ X)).hom ≫ + (tensorPow D X a ◁ ((A ◁ winLegM A X) ≫ + actAcross A X X)) ≫ + (α_ (tensorPow D X a) X X).inv ≫ modPowπ A X (a + 2) = + (A ◁ (ρ_ (tensorPow D X a ⊗ ((X ⊗ A) ⊗ X))).hom) ≫ + (braidPast A (tensorPow D X a) ((X ⊗ A) ⊗ X)).hom ≫ + (tensorPow D X a ◁ ((A ◁ winLegN A X) ≫ + actAcross A X X)) ≫ + (α_ (tensorPow D X a) X X).inv ≫ modPowπ A X (a + 2) := by + rw [hMwin, whiskerLeft_comp] + simp only [Category.assoc] + rw [rel_top A X a, ← whiskerLeft_comp_assoc, actAcross_winLegN] + exact (hstep (winLegM A X)).trans + (hmid.trans (hstep (winLegN A X)).symm) + +/-- The raw action on the ambient power of the module power. -/ +noncomputable def modPowActRaw + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (n : ℕ) : + A ⊗ tensorPow D X (n + 1) ⟶ modPow A X (n + 1) := + powTailAct A X n ≫ modPowπ A X (n + 1) + +/-- **The raw action coequalizes the whiskered relation legs.** -/ +theorem modPowActRaw_cond + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + (n : ℕ) : + (A ◁ modPowLegFst A X (n + 1)) ≫ modPowActRaw A X n = + (A ◁ modPowLegSnd A X (n + 1)) ≫ modPowActRaw A X n := by + refine legs_whiskerLeft_cond A X A _ (fun a b hab => ?_) + cases b with + | zero => + obtain rfl : n = a + 1 := by omega + have hM : modPowLegM A X a 0 ≫ powCast X hab = + modPowLegM A X a 0 := Category.comp_id _ + have hN : modPowLegN A X a 0 ≫ powCast X hab = + modPowLegN A X a 0 := Category.comp_id _ + exact (congrArg + (fun z => (A ◁ z) ≫ modPowActRaw A X (a + 1)) hM).trans + ((act_slot_top A X a).trans + (congrArg + (fun z => (A ◁ z) ≫ modPowActRaw A X (a + 1)) hN).symm) + | succ b₀ => + obtain rfl : n = a + 2 + b₀ := by omega + have hM : modPowLegM A X a (b₀ + 1) ≫ powCast X hab = + modPowLegM A X a (b₀ + 1) := Category.comp_id _ + have hN : modPowLegN A X a (b₀ + 1) ≫ powCast X hab = + modPowLegN A X a (b₀ + 1) := Category.comp_id _ + exact (congrArg + (fun z => (A ◁ z) ≫ modPowActRaw A X (a + 2 + b₀)) hM).trans + ((act_slot_below A X a b₀).trans + (congrArg + (fun z => (A ◁ z) ≫ modPowActRaw A X (a + 2 + b₀)) + hN).symm) + +/-- **The monoid action on the module power**, descended from the +tail action through the whiskered coequalizer. -/ +noncomputable def modPowAct + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + A ⊗ modPow A X (n + 1) ⟶ modPow A X (n + 1) := + modPowWhiskerLeftDesc A X A (n + 1) (modPowActRaw A X n) + (modPowActRaw_cond A X n) + +/-- Defining equation of the descended action. -/ +@[reassoc (attr := simp)] +theorem whiskerLeft_modPowπ_modPowAct + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + (A ◁ modPowπ A X (n + 1)) ≫ modPowAct A X n = + powTailAct A X n ≫ modPowπ A X (n + 1) := + modPowπ_whiskerLeft_desc A X A (n + 1) _ _ + +/-- Unitality of the descended action. -/ +theorem modPowAct_one + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + η[A] ▷ modPow A X (n + 1) ≫ modPowAct A X n = + (λ_ (modPow A X (n + 1))).hom := by + apply modPow_whiskerLeft_hom_ext A X (𝟙_ D) (n + 1) + rw [whisker_exchange_assoc, whiskerLeft_modPowπ_modPowAct, + powTailAct_one_assoc, leftUnitor_naturality] + +/-- Associativity of the descended action. -/ +theorem modPowAct_mul + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + μ[A] ▷ modPow A X (n + 1) ≫ modPowAct A X n = + (α_ A A (modPow A X (n + 1))).hom ≫ + (A ◁ modPowAct A X n) ≫ modPowAct A X n := by + apply modPow_whiskerLeft_hom_ext A X (A ⊗ A) (n + 1) + conv_lhs => rw [whisker_exchange_assoc, + whiskerLeft_modPowπ_modPowAct, powTailAct_mul_assoc] + conv_rhs => rw [associator_naturality_right_assoc, + ← whiskerLeft_comp_assoc, whiskerLeft_modPowπ_modPowAct, + whiskerLeft_comp_assoc, whiskerLeft_modPowπ_modPowAct] + +/-- **The module power of a module is a module**, in every positive +arity. -/ +@[implicit_reducible] +noncomputable def modPowModObj + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + ModObj A (modPow A X (n + 1)) where + smul := modPowAct A X n + one_smul := modPowAct_one A X n + mul_smul := modPowAct_mul A X n + +/-- The module power of a module, bundled as a module. -/ +noncomputable def modPowMod + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : Mod D A := + letI := modPowModObj A X n + ⟨modPow A X (n + 1)⟩ + +@[simp] theorem modPowMod_X + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + (modPowMod A X n).X = modPow A X (n + 1) := rfl + +end ActDescent + +/-! ## Permutation equivariance of the descended action + +The descended action commutes with the permutation action: for a +top-fixing generator by naturality alone, and for the top +transposition by carrying the acting monoid into the top slot and +applying the slot relation there — the same slot the descent itself +used. Generation by the adjacent transpositions extends both to the +full symmetric group, and linearity to the group algebra. +-/ + +section ActGlue + +/-- Intertwining a whiskered action is closed under sums. -/ +private theorem whisker_act_add + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] + {P M : D} (act : P ⊗ M ⟶ M) + {u v : M ⟶ M} (hu : act ≫ u = (P ◁ u) ≫ act) + (hv : act ≫ v = (P ◁ v) ≫ act) : + act ≫ (u + v) = (P ◁ (u + v)) ≫ act := by + rw [Preadditive.comp_add, MonoidalPreadditive.whiskerLeft_add, + Preadditive.add_comp, hu, hv] + +/-- Intertwining a whiskered action is closed under scalars. -/ +private theorem whisker_act_smul + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [Linear ℂ D] [MonoidalLinear ℂ D] + {P M : D} (act : P ⊗ M ⟶ M) + (r : ℂ) {u : M ⟶ M} (hu : act ≫ u = (P ◁ u) ≫ act) : + act ≫ (r • u) = (P ◁ (r • u)) ≫ act := by + rw [Linear.comp_smul, MonoidalLinear.whiskerLeft_smul, + Linear.smul_comp, hu] + +end ActGlue + +section ActPerm + +/-- The window shuffle carrying the acting monoid into the top +slot: `d ⊗ (y ⊗ z) ↦ (z ⊗ d) ⊗ y`. -/ +def winShuffle + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + (X : D) : A ⊗ (X ⊗ X) ⟶ (X ⊗ A) ⊗ X := + (A ◁ (β_ X X).hom) ≫ (α_ A X X).inv ≫ ((β_ A X).hom ▷ X) + +/-- **The braided window identity for the first leg**: acting on +the top factor and braiding is shuffling and acting through the +braided right action. -/ +theorem actAcross_braiding + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] : + actAcross A X X ≫ (β_ X X).hom = + winShuffle A X ≫ winLegM A X := by + have hR : winShuffle A X ≫ winLegM A X = + (A ◁ (β_ X X).hom) ≫ (α_ A X X).inv ≫ (actLeft A X ▷ X) := by + rw [winShuffle, winLegM, actRight, comp_whiskerRight] + simp only [Category.assoc] + rw [← comp_whiskerRight_assoc, SymmetricCategory.symmetry, + id_whiskerRight, Category.id_comp] + have hL : actAcross A X X ≫ (β_ X X).hom = + (A ◁ (β_ X X).hom) ≫ (α_ A X X).inv ≫ (actLeft A X ▷ X) := by + rw [actAcross] + simp only [Category.assoc] + rw [BraidedCategory.braiding_naturality_right, + BraidedCategory.braiding_tensor_right_hom] + simp only [Category.assoc, Iso.hom_inv_id_assoc] + rw [← comp_whiskerRight_assoc, SymmetricCategory.symmetry, + id_whiskerRight, Category.id_comp, Iso.inv_hom_id_assoc] + rw [hL, hR] + +/-- **The braided window identity for the second leg**: the shuffle +followed by the second leg is braiding first, then acting on the +top factor. -/ +theorem winShuffle_winLegN + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] : + winShuffle A X ≫ winLegN A X = + (A ◁ (β_ X X).hom) ≫ actAcross A X X := by + rw [winShuffle, winLegN, actAcross] + simp only [Category.assoc] + +/-- The tail action framed through the top window, on the left of +the top braiding. -/ +private theorem swap_left_aux + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] + (V : D) {Z : D} (p : (V ⊗ X) ⊗ X ⟶ Z) : + actAcross A (V ⊗ X) X ≫ + ((α_ V X X).hom ≫ (V ◁ (β_ X X).hom) ≫ (α_ V X X).inv) ≫ + p = + (A ◁ (α_ V X X).hom) ≫ (braidPast A V (X ⊗ X)).hom ≫ + (V ◁ (actAcross A X X ≫ (β_ X X).hom)) ≫ + (α_ V X X).inv ≫ p := by + simp only [Category.assoc] + rw [actAcross_context_split_assoc, ← whiskerLeft_comp_assoc] + +/-- The tail action framed through the top window, on the right of +the top braiding. -/ +private theorem swap_right_aux + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] + (V : D) {Z : D} + (p : (V ⊗ X) ⊗ X ⟶ Z) : + (A ◁ ((α_ V X X).hom ≫ (V ◁ (β_ X X).hom) ≫ + (α_ V X X).inv)) ≫ actAcross A (V ⊗ X) X ≫ p = + (A ◁ (α_ V X X).hom) ≫ (braidPast A V (X ⊗ X)).hom ≫ + (V ◁ ((A ◁ (β_ X X).hom) ≫ actAcross A X X)) ≫ + (α_ V X X).inv ≫ p := by + simp only [whiskerLeft_comp, Category.assoc] + rw [reassoc_of% (actAcross_split_last A V X), + braidPast_natural_tail_assoc, ← whiskerLeft_comp_assoc] + +/-- **The tail action commutes with the top braiding after the +projection**: the braided slide moves the acting monoid across the +swapped pair, and the top slot relation closes the square. -/ +private theorem act_swapTop + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (m : ℕ) : + powTailAct A X (m + 1) ≫ swapTop X m ≫ modPowπ A X (m + 2) = + (A ◁ swapTop X m) ≫ powTailAct A X (m + 1) ≫ + modPowπ A X (m + 2) := by + have hwin : (A ◁ (α_ (tensorPow D X m) X X).hom) ≫ + (braidPast A (tensorPow D X m) (X ⊗ X)).hom ≫ + (tensorPow D X m ◁ (actAcross A X X ≫ (β_ X X).hom)) ≫ + (α_ (tensorPow D X m) X X).inv ≫ modPowπ A X (m + 2) = + (A ◁ (α_ (tensorPow D X m) X X).hom) ≫ + (braidPast A (tensorPow D X m) (X ⊗ X)).hom ≫ + (tensorPow D X m ◁ ((A ◁ (β_ X X).hom) ≫ + actAcross A X X)) ≫ + (α_ (tensorPow D X m) X X).inv ≫ modPowπ A X (m + 2) := by + rw [actAcross_braiding A X, whiskerLeft_comp] + simp only [Category.assoc] + rw [rel_top A X m, ← whiskerLeft_comp_assoc, + winShuffle_winLegN A X] + exact (swap_left_aux A X (tensorPow D X m) + (modPowπ A X (m + 2))).trans + (hwin.trans (swap_right_aux A X (tensorPow D X m) + (modPowπ A X (m + 2))).symm) + +/-- A raw intertwining of the tail action with a permutation +descends to the module power. -/ +private theorem modPowAct_perm_of_raw + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) + (σ : Equiv.Perm (Fin (n + 1))) + (h : powTailAct A X n ≫ permMor X (n + 1) σ ≫ + modPowπ A X (n + 1) = + (A ◁ permMor X (n + 1) σ) ≫ powTailAct A X n ≫ + modPowπ A X (n + 1)) : + modPowAct A X n ≫ modPowPerm (A := A) (X := X) (n + 1) σ = + (A ◁ modPowPerm (A := A) (X := X) (n + 1) σ) ≫ + modPowAct A X n := by + apply modPow_whiskerLeft_hom_ext A X A (n + 1) + conv_lhs => rw [whiskerLeft_modPowπ_modPowAct_assoc, + modPowπ_perm] + conv_rhs => rw [← whiskerLeft_comp_assoc, modPowπ_perm, + whiskerLeft_comp_assoc, whiskerLeft_modPowπ_modPowAct] + exact h + +/-- The raw intertwining for a top-fixing permutation, by +naturality in the context. -/ +private theorem act_perm_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (n : ℕ) (τ : Equiv.Perm (Fin n)) : + powTailAct A X n ≫ permMor X (n + 1) (extPerm τ) ≫ + modPowπ A X (n + 1) = + (A ◁ permMor X (n + 1) (extPerm τ)) ≫ powTailAct A X n ≫ + modPowπ A X (n + 1) := by + have hp := permMor_extPerm X n τ + exact (congrArg + (fun z : tensorPow D X (n + 1) ⟶ tensorPow D X (n + 1) => + powTailAct A X n ≫ z ≫ modPowπ A X (n + 1)) hp).trans + (((actAcross_natural_assoc A (permMor X n τ) X + (modPowπ A X (n + 1))).symm).trans + (congrArg + (fun z : tensorPow D X (n + 1) ⟶ tensorPow D X (n + 1) => + (A ◁ z) ≫ powTailAct A X n ≫ modPowπ A X (n + 1)) + hp).symm) + +/-- **The descended action commutes with every permutation.** -/ +theorem modPowAct_perm + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) (σ : Equiv.Perm (Fin (n + 1))) : + modPowAct A X n ≫ modPowPerm (A := A) (X := X) (n + 1) σ = + (A ◁ modPowPerm (A := A) (X := X) (n + 1) σ) ≫ + modPowAct A X n := by + cases n with + | zero => + have hσ : σ = 1 := Equiv.ext fun i => by + have h1 := (σ i).isLt + have h2 := i.isLt + rw [Equiv.Perm.one_apply] + exact Fin.ext (by omega) + rw [hσ, modPowPerm_one, Category.comp_id, whiskerLeft_id, + Category.id_comp] + | succ m => + have hgen : ∀ i : Fin (m + 1), + modPowAct A X (m + 1) ≫ modPowPerm (A := A) (X := X) (m + 2) + (Equiv.swap i.castSucc i.succ) = + (A ◁ modPowPerm (A := A) (X := X) (m + 2) + (Equiv.swap i.castSucc i.succ)) ≫ + modPowAct A X (m + 1) := by + intro i + refine Fin.lastCases ?_ (fun j => ?_) i + · have ht : Equiv.swap (Fin.last m).castSucc + (Fin.last m).succ = + (topSwap : Equiv.Perm (Fin (m + 2))) := by + rw [Fin.succ_last] + rfl + rw [ht] + refine modPowAct_perm_of_raw A X (m + 1) topSwap ?_ + have hp : permMor X (m + 2) + (topSwap : Equiv.Perm (Fin (m + 2))) = swapTop X m := + permMor_topSwap_eq X m + rw [hp] + exact act_swapTop A X m + · have he : Equiv.swap (Fin.castSucc j).castSucc + (Fin.castSucc j).succ = + extPerm (Equiv.swap j.castSucc j.succ) := + swap_castSucc_succ_castSucc j + rw [he] + exact modPowAct_perm_of_raw A X (m + 1) _ + (act_perm_ext A X (m + 1) (Equiv.swap j.castSucc j.succ)) + have key : ∀ τ : Equiv.Perm (Fin (m + 2)), + τ ∈ Submonoid.closure (Set.range fun i : Fin (m + 1) => + Equiv.swap i.castSucc i.succ) → + modPowAct A X (m + 1) ≫ + modPowPerm (A := A) (X := X) (m + 2) τ = + (A ◁ modPowPerm (A := A) (X := X) (m + 2) τ) ≫ + modPowAct A X (m + 1) := by + intro τ hτ + induction hτ using Submonoid.closure_induction_left with + | one => + rw [modPowPerm_one, Category.comp_id, whiskerLeft_id, + Category.id_comp] + | mul_left g hg τ' hτ' ih => + obtain ⟨i, rfl⟩ := hg + rw [modPowPerm_mul, whiskerLeft_comp, ← Category.assoc, ih, + Category.assoc, hgen i, ← Category.assoc] + exact key σ (by + rw [Equiv.Perm.mclosure_swap_castSucc_succ]; trivial) + +/-- **The descended action commutes with the group-algebra +action**, by linear extension of the permutation case. -/ +theorem modPowAct_alg + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + [Linear ℂ D] [MonoidalLinear ℂ D] + (n : ℕ) (z : SymGroupAlgebra (n + 1)) : + modPowAct A X n ≫ + (modPowAlg A X (n + 1) z : End (modPow A X (n + 1))) = + (A ◁ (modPowAlg A X (n + 1) z : + End (modPow A X (n + 1)))) ≫ + modPowAct A X n := by + induction z using MonoidAlgebra.induction_on with + | of σ => + rw [show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin (n + 1)))) σ = + MonoidAlgebra.single σ (1 : ℂ) from rfl, modPowAlg_single] + exact modPowAct_perm A X n σ + | add z₁ z₂ h₁ h₂ => + rw [map_add] + exact whisker_act_add (modPowAct A X n) h₁ h₂ + | smul r z' h => + rw [map_smul] + exact whisker_act_smul (modPowAct A X n) r h + +end ActPerm + +/-! ## The symmetric power as a module -/ + +section SymAct + +/-- **The monoid action on the symmetric power**, through the +section and the descended action. -/ +noncomputable def symPowAct + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + A ⊗ symPow A X (n + 1) ⟶ symPow A X (n + 1) := + (A ◁ symPowσ A X (n + 1)) ≫ modPowAct A X n ≫ + symPowπ A X (n + 1) + +/-- Defining equation of the symmetric-power action. -/ +@[reassoc (attr := simp)] +theorem whiskerLeft_symPowπ_symPowAct + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + (A ◁ symPowπ A X (n + 1)) ≫ symPowAct A X n = + modPowAct A X n ≫ symPowπ A X (n + 1) := by + have h' : modPowAct A X n ≫ symPowIdem A X (n + 1) = + (A ◁ symPowIdem A X (n + 1)) ≫ modPowAct A X n := + modPowAct_alg A X n (symmetriser (n + 1)) + rw [symPowAct, ← whiskerLeft_comp_assoc, symPowπ_symPowσ, + reassoc_of% h'.symm, symPowIdem_π] + +/-- Unitality of the symmetric-power action. -/ +theorem symPowAct_one + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + η[A] ▷ symPow A X (n + 1) ≫ symPowAct A X n = + (λ_ (symPow A X (n + 1))).hom := by + apply symPow_whiskerLeft_hom_ext A X (𝟙_ D) (n + 1) + rw [whisker_exchange_assoc, whiskerLeft_symPowπ_symPowAct, + reassoc_of% (modPowAct_one A X n), leftUnitor_naturality] + +/-- Associativity of the symmetric-power action. -/ +theorem symPowAct_mul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + μ[A] ▷ symPow A X (n + 1) ≫ symPowAct A X n = + (α_ A A (symPow A X (n + 1))).hom ≫ + (A ◁ symPowAct A X n) ≫ symPowAct A X n := by + apply symPow_whiskerLeft_hom_ext A X (A ⊗ A) (n + 1) + conv_lhs => rw [whisker_exchange_assoc, + whiskerLeft_symPowπ_symPowAct, + reassoc_of% (modPowAct_mul A X n)] + conv_rhs => rw [associator_naturality_right_assoc, + ← whiskerLeft_comp_assoc, whiskerLeft_symPowπ_symPowAct, + whiskerLeft_comp_assoc, whiskerLeft_symPowπ_symPowAct] + +/-- **The symmetric power of a module is a module**, in every +positive arity. -/ +@[implicit_reducible] +noncomputable def symPowModObj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + ModObj A (symPow A X (n + 1)) where + smul := symPowAct A X n + one_smul := symPowAct_one A X n + mul_smul := symPowAct_mul A X n + +/-- **The section of the symmetric power is a module map.** -/ +theorem symPowσ_modPowAct + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + (A ◁ symPowσ A X (n + 1)) ≫ modPowAct A X n = + symPowAct A X n ≫ symPowσ A X (n + 1) := by + have h' : modPowAct A X n ≫ symPowIdem A X (n + 1) = + (A ◁ symPowIdem A X (n + 1)) ≫ modPowAct A X n := + modPowAct_alg A X n (symmetriser (n + 1)) + have hσI : symPowσ A X (n + 1) ≫ symPowIdem A X (n + 1) = + symPowσ A X (n + 1) := by + rw [← symPowπ_symPowσ, symPowσ_symPowπ_assoc] + rw [symPowAct] + simp only [Category.assoc] + rw [symPowπ_symPowσ, h', ← whiskerLeft_comp_assoc, hσI] + +/-- The symmetric power of a module, bundled as a module. -/ +noncomputable def symPowMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : Mod D A := + letI := symPowModObj A X n + ⟨symPow A X (n + 1)⟩ + +@[simp] theorem symPowMod_X + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj A] + [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + (symPowMod A X n).X = symPow A X (n + 1) := rfl + +end SymAct + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowActMul.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowActMul.lean new file mode 100644 index 0000000000..bf17393643 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowActMul.lean @@ -0,0 +1,395 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowAct + +/-! +# Compatibility of the module-power action with the multiplication + +Over an internal commutative monoid `A` and a module `X`, the module +powers and symmetric powers carry both a multiplication +(`SymMul.lean`) and an `A`-action (`PowAct.lean`). This module +proves the two structures compatible: the multiplications are module +maps, in both factors — the statements that make the power algebras +into `A`-module algebras. + +* `powTailAct_concat`: on the ambient tensor powers, routing the + monoid to the tail of the second block and concatenating equals + concatenating and acting on the tail of the product. Because the + concatenation folds on the right, this is a naturality of the + concatenation against the action through the right factor. +* `modPowMul_actRight`/`symMul_actRight`: acting on the right + factor, with the monoid carried past the left factor, equals + multiplying and acting on the product. +* `modPowMul_braiding_exists`: the braiding of two module powers is, + across the multiplications, the action of a block permutation — + the descent of `tensorPowConcat_braiding_exists`. +* `modPowMul_actLeft`/`symMul_actLeft`: acting on the left factor + equals multiplying and acting on the product; proved from the + right version by braiding the factors, sliding the action across + the braiding, and absorbing the block permutation through the + equivariance of the descended action. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## The action through the right factor against a concatenation -/ + +section RawConcat + +/-- The action through the right factor of a tensor pair, with the +pair reassociated: carry the monoid past the first factor and act +through the second. -/ +theorem actAcross_split_pair + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] + (V₁ V₂ X : D) [ModObj A X] : + (A ◁ (α_ V₁ V₂ X).inv) ≫ actAcross A (V₁ ⊗ V₂) X = + (braidPast A V₁ (V₂ ⊗ X)).hom ≫ (V₁ ◁ actAcross A V₂ X) ≫ + (α_ V₁ V₂ X).inv := by + rw [← cancel_mono (α_ V₁ V₂ X).hom] + simp only [Category.assoc, Iso.inv_hom_id, Category.comp_id] + rw [actAcross_context_split A V₁ V₂ X, ← whiskerLeft_comp_assoc, + Iso.inv_hom_id, whiskerLeft_id, Category.id_comp] + +/-- **Naturality of a fold-and-collapse against the action**: acting +through the second factor of a pair and collapsing the pair onto a +codomain equals collapsing first and acting through the right factor +of the codomain. -/ +theorem actAcross_concat_context + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] + (V₁ V₂ Q : D) (c : V₁ ⊗ V₂ ⟶ Q) + (X : D) [ModObj A X] : + (braidPast A V₁ (V₂ ⊗ X)).hom ≫ (V₁ ◁ actAcross A V₂ X) ≫ + ((α_ V₁ V₂ X).inv ≫ (c ▷ X)) = + (A ◁ ((α_ V₁ V₂ X).inv ≫ (c ▷ X))) ≫ actAcross A Q X := by + have h := whiskerLeft_associator_inv_actAcross A c X (𝟙 (Q ⊗ X)) + simp only [Category.comp_id] at h + rw [h, reassoc_of% (actAcross_split_pair A V₁ V₂ X)] + +/-- **The tail action passes the concatenation**: carrying the +monoid to the tail of the second block and concatenating equals +concatenating and acting on the tail of the product. The +concatenation folds on the right, so the tail of the product is the +tail of the second block and no arity transport is needed. -/ +theorem powTailAct_concat + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] + (m n : ℕ) : + (braidPast A (tensorPow D X (m + 1)) + (tensorPow D X (n + 1))).hom ≫ + (tensorPow D X (m + 1) ◁ powTailAct A X n) ≫ + (tensorPowConcat X (m + 1) (n + 1)).hom = + (A ◁ (tensorPowConcat X (m + 1) (n + 1)).hom) ≫ + powTailAct A X (m + 1 + n) := + actAcross_concat_context A (tensorPow D X (m + 1)) + (tensorPow D X n) (tensorPow D X (m + 1 + n)) + (tensorPowConcat X (m + 1) n).hom X + +end RawConcat + +/-! ## The multiplication as a module map, right factor -/ + +section ModLevel + +/-- Morphisms out of a whiskered tensor pair of module powers are +determined by their composites with the tensored projections. -/ +theorem modPowTensorLeft_hom_ext + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (P : D) (m n : ℕ) {Z : D} + {k l : P ⊗ (modPow A X m ⊗ modPow A X n) ⟶ Z} + (h : (P ◁ (modPowπ A X m ⊗ₘ modPowπ A X n)) ≫ k = + (P ◁ (modPowπ A X m ⊗ₘ modPowπ A X n)) ≫ l) : k = l := by + simp only [tensorHom_def, whiskerLeft_comp, Category.assoc] at h + have h₂ := (cancel_epi (P ◁ (modPowπ A X m ▷ tensorPow D X n))).mp h + rw [← Iso.cancel_iso_hom_left + (α_ P (modPow A X m) (modPow A X n)) k l] + apply modPow_whiskerLeft_hom_ext A X (P ⊗ modPow A X m) n + simp only [associator_naturality_right_assoc] + rw [h₂] + +/-- The descended action passes an arity transport. -/ +theorem modPowAct_cast + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + [MonoidalPreadditive D] [IsCommMonObj A] + {a b : ℕ} (h : a + 1 = b + 1) : + (A ◁ modPowCast A X h) ≫ modPowAct A X b = + modPowAct A X a ≫ modPowCast A X h := by + obtain rfl : a = b := by omega + rw [modPowCast_irrel A X h rfl, modPowCast_rfl, whiskerLeft_id, + Category.id_comp, Category.comp_id] + +/-- **The raw multiplication is a module map in the right factor**: +acting on the right factor, with the monoid carried past the left +factor, equals multiplying and acting on the product. -/ +theorem modPowMul_actRight + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + [MonoidalPreadditive D] [IsCommMonObj A] + (m n : ℕ) : + (braidPast A (modPow A X (m + 1)) (modPow A X (n + 1))).hom ≫ + (modPow A X (m + 1) ◁ modPowAct A X n) ≫ + modPowMul A X (m + 1) (n + 1) = + (A ◁ modPowMul A X (m + 1) (n + 1)) ≫ + modPowAct A X (m + 1 + n) := by + apply modPowTensorLeft_hom_ext A X A (m + 1) (n + 1) + have hdef : (A ◁ modPowπ A X (m + 1 + (n + 1))) ≫ + modPowAct A X (m + 1 + n) = + powTailAct A X (m + 1 + n) ≫ + modPowπ A X (m + 1 + (n + 1)) := + whiskerLeft_modPowπ_modPowAct A X (m + 1 + n) + have hμ : (modPowπ A X (m + 1) ▷ tensorPow D X (n + 1)) ≫ + (modPow A X (m + 1) ◁ modPowπ A X (n + 1)) ≫ + modPowMul A X (m + 1) (n + 1) = + (tensorPowConcat X (m + 1) (n + 1)).hom ≫ + modPowπ A X (m + 1 + (n + 1)) := by + rw [← Category.assoc, ← tensorHom_def, modPowπ_tensor_modPowMul] + conv_lhs => rw [tensorHom_def, whiskerLeft_comp, Category.assoc, + braidPast_natural_tail_assoc, braidPast_natural_context_assoc, + ← whiskerLeft_comp_assoc, whiskerLeft_modPowπ_modPowAct, + whiskerLeft_comp, Category.assoc, ← whisker_exchange_assoc, hμ] + conv_rhs => rw [← whiskerLeft_comp_assoc, modPowπ_tensor_modPowMul, + whiskerLeft_comp, Category.assoc, hdef] + rw [reassoc_of% (powTailAct_concat A X m n)] + +end ModLevel + +/-! ## Braiding the monoid out of a braided pair -/ + +section BraidCancel + +/-- Braiding a pair with the monoid attached to its first factor, +then carrying the monoid back out of the second factor, is braiding +the bare pair under the monoid. -/ +@[reassoc] +theorem associator_inv_braiding_braidPast_inv + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (A V T : D) : + (α_ A V T).inv ≫ (β_ (A ⊗ V) T).hom ≫ (braidPast A T V).inv = + A ◁ (β_ V T).hom := by + rw [← cancel_mono (braidPast A T V).hom] + simp only [Category.assoc, Iso.inv_hom_id, Category.comp_id] + rw [braidPast_hom, BraidedCategory.braiding_tensor_left_hom] + simp only [Iso.inv_hom_id_assoc] + +end BraidCancel + +/-! ## The multiplication as a module map, left factor -/ + +section ModLeftLevel + +/-- **The braiding of module powers is a block permutation across +the multiplications**: the descent of +`tensorPowConcat_braiding_exists` through the projections. -/ +theorem modPowMul_braiding_exists + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (m n : ℕ) : + ∃ σ : Equiv.Perm (Fin (n + m)), + (β_ (modPow A X m) (modPow A X n)).hom ≫ modPowMul A X n m = + modPowMul A X m n ≫ + modPowCast A X (by omega : m + n = n + m) ≫ + modPowPerm (A := A) (X := X) (n + m) σ := by + obtain ⟨σ, hσ⟩ := tensorPowConcat_braiding_exists X n m + refine ⟨σ, ?_⟩ + apply modPowTensor_hom_ext A X m n + conv_lhs => rw [← Category.assoc, + BraidedCategory.braiding_naturality, Category.assoc, + modPowπ_tensor_modPowMul] + conv_rhs => rw [modPowπ_tensor_modPowMul_assoc, modPowπ_cast_assoc, + modPowπ_perm] + rw [reassoc_of% hσ] + +/-- **The raw multiplication is a module map in the left factor**: +acting on the left factor equals multiplying and acting on the +product, with no braiding of the monoid past anything. The action +slides from the tail of the left block to the tail of the product; +the slide is packaged through the braiding of the blocks, the +right-factor statement, and the equivariance of the descended +action. -/ +theorem modPowMul_actLeft + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + [IsCommMonObj A] + (m n : ℕ) : + (α_ A (modPow A X (m + 1)) (modPow A X (n + 1))).inv ≫ + (modPowAct A X m ▷ modPow A X (n + 1)) ≫ + modPowMul A X (m + 1) (n + 1) = + (A ◁ modPowMul A X (m + 1) (n + 1)) ≫ + modPowAct A X (m + 1 + n) := by + obtain ⟨σ, hσ⟩ := modPowMul_braiding_exists A X (m + 1) (n + 1) + have hpp : modPowPerm (A := A) (X := X) (n + 1 + (m + 1)) σ ≫ + modPowPerm (A := A) (X := X) (n + 1 + (m + 1)) σ⁻¹ = 𝟙 _ := by + rw [← modPowPerm_mul, inv_mul_cancel, modPowPerm_one] + have hcc : ∀ {a b : ℕ} (h : a = b) (h' : b = a), + modPowCast A X h ≫ modPowCast A X h' = 𝟙 (modPow A X a) := by + intro a b h h' + subst h + rw [modPowCast_irrel A X h' rfl, modPowCast_rfl, Category.comp_id] + have hA : (β_ (modPow A X (m + 1)) (modPow A X (n + 1))).hom ≫ + modPowMul A X (n + 1) (m + 1) ≫ + modPowPerm (A := A) (X := X) (n + 1 + (m + 1)) σ⁻¹ ≫ + modPowCast A X (by omega : n + 1 + (m + 1) = m + 1 + (n + 1)) = + modPowMul A X (m + 1) (n + 1) := by + rw [reassoc_of% hσ, reassoc_of% hpp, hcc, Category.comp_id] + have hR : (modPow A X (n + 1) ◁ modPowAct A X m) ≫ + modPowMul A X (n + 1) (m + 1) = + (braidPast A (modPow A X (n + 1)) (modPow A X (m + 1))).inv ≫ + (A ◁ modPowMul A X (n + 1) (m + 1)) ≫ + modPowAct A X (n + 1 + m) := by + rw [← modPowMul_actRight A X n m, Iso.inv_hom_id_assoc] + have hperm : (A ◁ modPowPerm (A := A) (X := X) + (n + 1 + (m + 1)) σ) ≫ modPowAct A X (n + 1 + m) = + modPowAct A X (n + 1 + m) ≫ + modPowPerm (A := A) (X := X) (n + 1 + (m + 1)) σ := + (modPowAct_perm A X (n + 1 + m) σ).symm + have hac : (A ◁ modPowCast A X + (by omega : m + 1 + (n + 1) = n + 1 + (m + 1))) ≫ + modPowAct A X (n + 1 + m) = + modPowAct A X (m + 1 + n) ≫ + modPowCast A X + (by omega : m + 1 + (n + 1) = n + 1 + (m + 1)) := + modPowAct_cast A X _ + conv_lhs => rw [← hA, BraidedCategory.braiding_naturality_left_assoc, + reassoc_of% hR, + reassoc_of% (associator_inv_braiding_braidPast_inv A + (modPow A X (m + 1)) (modPow A X (n + 1))), + ← whiskerLeft_comp_assoc, hσ] + simp only [whiskerLeft_comp, Category.assoc] + rw [reassoc_of% hperm, reassoc_of% hpp, reassoc_of% hac, hcc, + Category.comp_id] + +end ModLeftLevel + +/-! ## The symmetric multiplication as a module map -/ + +section SymLevel + +/-- Morphisms out of a whiskered tensor pair of symmetric powers +are determined by their composites with the tensored projections, +which are jointly split epi. -/ +theorem symPowTensorLeft_hom_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (P : D) (m n : ℕ) {Z : D} + {k l : P ⊗ (symPow A X m ⊗ symPow A X n) ⟶ Z} + (h : (P ◁ (symPowπ A X m ⊗ₘ symPowπ A X n)) ≫ k = + (P ◁ (symPowπ A X m ⊗ₘ symPowπ A X n)) ≫ l) : k = l := by + have hsec : (P ◁ (symPowσ A X m ⊗ₘ symPowσ A X n)) ≫ + (P ◁ (symPowπ A X m ⊗ₘ symPowπ A X n)) = 𝟙 _ := by + rw [← whiskerLeft_comp, tensorHom_comp_tensorHom, + symPowσ_symPowπ, symPowσ_symPowπ, tensorHom_id, + id_whiskerRight, whiskerLeft_id] + calc k = ((P ◁ (symPowσ A X m ⊗ₘ symPowσ A X n)) ≫ + (P ◁ (symPowπ A X m ⊗ₘ symPowπ A X n))) ≫ k := by + rw [hsec, Category.id_comp] + _ = ((P ◁ (symPowσ A X m ⊗ₘ symPowσ A X n)) ≫ + (P ◁ (symPowπ A X m ⊗ₘ symPowπ A X n))) ≫ l := by + rw [Category.assoc, Category.assoc, h] + _ = l := by rw [hsec, Category.id_comp] + +/-- **The symmetric multiplication is a module map in the right +factor**: acting on the right factor, with the monoid carried past +the left factor, equals multiplying and acting on the product. -/ +theorem symMul_actRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + [IsCommMonObj A] + (m n : ℕ) : + (braidPast A (symPow A X (m + 1)) (symPow A X (n + 1))).hom ≫ + (symPow A X (m + 1) ◁ symPowAct A X n) ≫ + symMul A X (m + 1) (n + 1) = + (A ◁ symMul A X (m + 1) (n + 1)) ≫ + symPowAct A X (m + 1 + n) := by + apply symPowTensorLeft_hom_ext A X A (m + 1) (n + 1) + have hdef : (A ◁ symPowπ A X (m + 1 + (n + 1))) ≫ + symPowAct A X (m + 1 + n) = + modPowAct A X (m + 1 + n) ≫ + symPowπ A X (m + 1 + (n + 1)) := + whiskerLeft_symPowπ_symPowAct A X (m + 1 + n) + have hμ : (symPowπ A X (m + 1) ▷ modPow A X (n + 1)) ≫ + (symPow A X (m + 1) ◁ symPowπ A X (n + 1)) ≫ + symMul A X (m + 1) (n + 1) = + modPowMul A X (m + 1) (n + 1) ≫ + symPowπ A X (m + 1 + (n + 1)) := by + rw [← Category.assoc, ← tensorHom_def, symPowπ_tensor_symMul] + conv_lhs => rw [tensorHom_def, whiskerLeft_comp, Category.assoc, + braidPast_natural_tail_assoc, braidPast_natural_context_assoc, + ← whiskerLeft_comp_assoc, whiskerLeft_symPowπ_symPowAct, + whiskerLeft_comp, Category.assoc, ← whisker_exchange_assoc, hμ] + conv_rhs => rw [← whiskerLeft_comp_assoc, symPowπ_tensor_symMul, + whiskerLeft_comp, Category.assoc, hdef] + rw [reassoc_of% (modPowMul_actRight A X m n)] + +/-- **The symmetric multiplication is a module map in the left +factor**: acting on the left factor equals multiplying and acting +on the product, with no braiding of the monoid past anything. -/ +theorem symMul_actLeft + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + [IsCommMonObj A] + (m n : ℕ) : + (α_ A (symPow A X (m + 1)) (symPow A X (n + 1))).inv ≫ + (symPowAct A X m ▷ symPow A X (n + 1)) ≫ + symMul A X (m + 1) (n + 1) = + (A ◁ symMul A X (m + 1) (n + 1)) ≫ + symPowAct A X (m + 1 + n) := by + apply symPowTensorLeft_hom_ext A X A (m + 1) (n + 1) + have hdef : (A ◁ symPowπ A X (m + 1 + (n + 1))) ≫ + symPowAct A X (m + 1 + n) = + modPowAct A X (m + 1 + n) ≫ + symPowπ A X (m + 1 + (n + 1)) := + whiskerLeft_symPowπ_symPowAct A X (m + 1 + n) + have hμ : (symPowπ A X (m + 1) ▷ modPow A X (n + 1)) ≫ + (symPow A X (m + 1) ◁ symPowπ A X (n + 1)) ≫ + symMul A X (m + 1) (n + 1) = + modPowMul A X (m + 1) (n + 1) ≫ + symPowπ A X (m + 1 + (n + 1)) := by + rw [← Category.assoc, ← tensorHom_def, symPowπ_tensor_symMul] + conv_lhs => rw [tensorHom_def, whiskerLeft_comp, Category.assoc, + associator_inv_naturality_right_assoc, + associator_inv_naturality_middle_assoc, + whisker_exchange_assoc, ← comp_whiskerRight_assoc, + whiskerLeft_symPowπ_symPowAct, comp_whiskerRight, + Category.assoc, hμ] + conv_rhs => rw [← whiskerLeft_comp_assoc, symPowπ_tensor_symMul, + whiskerLeft_comp, Category.assoc, hdef] + rw [reassoc_of% (modPowMul_actLeft A X m n)] + +end SymLevel + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowChain.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowChain.lean new file mode 100644 index 0000000000..c5a4d00d8e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowChain.lean @@ -0,0 +1,276 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainDelta + +/-! +# The power-level chain and the copairing powers + +The module-power mirror of the symmetric chain: the power +multiplication descends through the module-tensor coequalizer and +bundles as a module map; through the interchange, power stages +multiply; the copairing seeds the bottom stage, and the iterated +seed multiplication is the copairing power of the duality datum. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- The two module-tensor legs of a pair of module powers agree +after the power multiplication. -/ +theorem modPowMul_modTensor_cond + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (m n : ℕ) : + modTensorLegM A (modPowMod A X m) (modPowMod A X n) ≫ + modPowMul A X (m + 1) (n + 1) = + modTensorLegN A (modPowMod A X m) (modPowMod A X n) ≫ + modPowMul A X (m + 1) (n + 1) := by + have h3 := (modPowMul_actRight A X m n).trans + (modPowMul_actLeft A X m n).symm + simp only [braidPast_hom, Category.assoc] at h3 + have h4 := (cancel_epi + (α_ A (modPow A X (m + 1)) (modPow A X (n + 1))).inv).mp h3 + rw [modTensorLegM, modTensorLegN, actRight, + show actLeft A (modPowMod A X m).X = modPowAct A X m from + rfl, + show actLeft A (modPowMod A X n).X = modPowAct A X n from + rfl] + change (((β_ (modPow A X (m + 1)) A).hom ≫ modPowAct A X m) ▷ + modPow A X (n + 1)) ≫ modPowMul A X (m + 1) (n + 1) = + ((α_ (modPow A X (m + 1)) A (modPow A X (n + 1))).hom ≫ + (modPow A X (m + 1) ◁ modPowAct A X n)) ≫ + modPowMul A X (m + 1) (n + 1) + rw [comp_whiskerRight, Category.assoc, ← h4, + ← comp_whiskerRight_assoc, SymmetricCategory.symmetry, + MonoidalCategory.id_whiskerRight, Category.id_comp] + simp only [Category.assoc] + +/-- **The descended power multiplication** on the module tensor +product of two module powers. -/ +noncomputable def powMulDesc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (m n : ℕ) : + modTensor A (modPowMod A X m) (modPowMod A X n) ⟶ + modPow A X (m + 1 + n + 1) := + modTensorDesc A (modPowMod A X m) (modPowMod A X n) + (modPowMul A X (m + 1) (n + 1)) + (modPowMul_modTensor_cond A X m n) + +/-- Defining equation of the descended power multiplication. -/ +@[reassoc (attr := simp)] +theorem modTensorπ_powMulDesc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (m n : ℕ) : + modTensorπ A (modPowMod A X m) (modPowMod A X n) ≫ + powMulDesc A X m n = modPowMul A X (m + 1) (n + 1) := + modTensorπ_desc A (modPowMod A X m) (modPowMod A X n) _ _ + +/-- The descended power multiplication intertwines the module +actions. -/ +theorem powMulDesc_act + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (m n : ℕ) : + modTensorAct A (modPowMod A X m) (modPowMod A X n) ≫ + powMulDesc A X m n = + (A ◁ powMulDesc A X m n) ≫ modPowAct A X (m + 1 + n) := by + apply modTensor_whisker_hom_ext A (modPowMod A X m) + (modPowMod A X n) A + conv_lhs => rw [whiskerLeft_modTensorπ_act_assoc, + modTensorπ_powMulDesc] + conv_rhs => rw [← whiskerLeft_comp_assoc, + modTensorπ_powMulDesc] + have h := modPowMul_actLeft A X m n + change (α_ A (modPow A X (m + 1)) (modPow A X (n + 1))).inv ≫ + (modPowAct A X m ▷ modPow A X (n + 1)) ≫ + modPowMul A X (m + 1) (n + 1) = + (A ◁ modPowMul A X (m + 1) (n + 1)) ≫ + modPowAct A X (m + 1 + n) + simpa only [Category.assoc] using h + +/-- The descended power multiplication as a map of modules. -/ +noncomputable def powMulMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (m n : ℕ) : + modTensorMod A (modPowMod A X m) (modPowMod A X n) ⟶ + modPowMod A X (m + 1 + n) := + Mod.Hom.mk' (powMulDesc A X m n) (powMulDesc_act A X m n) + +/-- The inverse of the singleton power iso carries the module +action to the descended action. -/ +theorem actLeft_modPowOne_inv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] : + actLeft A X ≫ (modPowOne A X).inv = + (A ◁ (modPowOne A X).inv) ≫ modPowAct A X 0 := by + calc actLeft A X ≫ (modPowOne A X).inv + = (A ◁ (modPowOne A X).inv) ≫ + (A ◁ (modPowOne A X).hom) ≫ actLeft A X ≫ + (modPowOne A X).inv := by + rw [← MonoidalCategory.whiskerLeft_comp_assoc, + Iso.inv_hom_id, MonoidalCategory.whiskerLeft_id, + Category.id_comp] + _ = (A ◁ (modPowOne A X).inv) ≫ modPowAct A X 0 := by + rw [← reassoc_of% (modPowAct_modPowOne A X)] + simp only [Iso.hom_inv_id, Category.comp_id] + +/-- A module maps into the singleton stage of its power tower. -/ +noncomputable def toModPowModZero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) : + M ⟶ modPowMod A M.X 0 := + Mod.Hom.mk' ((modPowOne A M.X).inv) + (actLeft_modPowOne_inv A M.X) + +/-- One stage of the power chain: the module tensor product of +matching module powers of the dual pair, in copairing order. -/ +noncomputable def powStage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (k : ℕ) : D := + modTensor A (modPowMod A M.X k) (modPowMod A M'.X k) + +/-- **The power chain multiplication**: two power stages +interchange and multiply into the stage of summed arity. -/ +noncomputable def powChainMul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (m n : ℕ) : + powStage A M M' m ⊗ powStage A M M' n ⟶ + powStage A M M' (m + 1 + n) := + interchange A (modPowMod A M.X m) (modPowMod A M'.X m) + (modPowMod A M.X n) (modPowMod A M'.X n) ≫ + modTensorMap A (powMulMod A M.X m n) (powMulMod A M'.X m n) + +/-- **The seed of the power chain**: the copairing lands in the +bottom stage. -/ +noncomputable def powSeed + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + 𝟙_ D ⟶ powStage A M M' 0 := + copairUnit A M M' d ≫ + modTensorMap A (toModPowModZero A M) (toModPowModZero A M') + +/-- An arity transport of module powers, as a map of modules. -/ +noncomputable def modPowCastMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + {a b : ℕ} (h : a + 1 = b + 1) : + modPowMod A X a ⟶ modPowMod A X b := + Mod.Hom.mk' (modPowCast A X h) (modPowAct_cast A X h).symm + +/-- The braiding of the module tensor product, as a map of +modules. -/ +noncomputable def modTensorSwapMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] + (P Q : Mod D A) : + modTensorMod A P Q ⟶ modTensorMod A Q P := + Mod.Hom.mk' (modTensorSwap A P Q) (modTensorAct_swap A P Q) + +/-- **The power chain transition**: insert the seed at the outer +position of the nested pairing — the new factor joins the +`M`-power at the front and the `M'`-power at the back, so the +peel of the nested pairing removes exactly the inserted pair. -/ +noncomputable def powDelta + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (k : ℕ) : powStage A M M' k ⟶ powStage A M M' (k + 1) := + (ρ_ (powStage A M M' k)).inv ≫ + (powStage A M M' k ◁ powSeed A M M' d) ≫ + interchange A (modPowMod A M.X k) (modPowMod A M'.X k) + (modPowMod A M.X 0) (modPowMod A M'.X 0) ≫ + modTensorMap A + (modTensorSwapMod A (modPowMod A M.X k) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 k ≫ + modPowCastMod A M.X (by omega : 0 + 1 + k + 1 = k + 2)) + (powMulMod A M'.X k 0) + +/-- **The copairing powers**: the iterated seed multiplication +along the power chain. -/ +noncomputable def powUnitStage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + (k : ℕ) → (𝟙_ D ⟶ powStage A M M' k) + | 0 => powSeed A M M' d + | (k + 1) => powUnitStage A M M' d k ≫ powDelta A M M' d k + +/-- The copairing powers ride along the transitions. -/ +theorem powUnitStage_succ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (k : ℕ) : + powUnitStage A M M' d k ≫ powDelta A M M' d k = + powUnitStage A M M' d (k + 1) := + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowCopairing.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowCopairing.lean new file mode 100644 index 0000000000..fcab6e8832 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowCopairing.lean @@ -0,0 +1,236 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairing + +/-! +# The power copairing + +The mirror of the power pairing: the copairing side of a +Mod-internal duality datum. The copairing lands in the quotient +`modTensor A M M'`, so there is no raw section; every primitive +lives at the descended level. The file provides the copairing +unit `copairUnit` — the seed of the chain units of the Key +Lemma — with its linearity laws, the braiding `modTensorSwap` of +the module tensor product with its defining equation, involution +and module-linearity, and the zigzag scalar `zig` together with +the retraction law: under the zigzag identity of the datum the +scalar is the unit of the base. The retraction is the +nonvanishing engine of the Key Lemma's chain: a vanishing chain +unit forces the unit of the base to vanish. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## The copairing unit -/ + +section Braided + +/-- **The copairing unit**: the copairing of the datum evaluated +at the unit of the base. The seed of the chain units of the Key +Lemma. -/ +noncomputable def copairUnit + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + 𝟙_ D ⟶ modTensor A M M' := + η[A] ≫ d.copair + +/-- Linearity of the copairing, phrased at the descended action: +multiplying before the copairing is acting after it. -/ +@[reassoc] +theorem copair_act [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + μ[A] ≫ d.copair = + (A ◁ d.copair) ≫ modTensorAct A M M' := + d.copair_linear + +/-- Linearity through the braided right action: the copairing +carries right multiplication to the braided right action on the +module tensor product. -/ +@[reassoc] +theorem copair_braid_act + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + (d.copair ▷ A) ≫ (β_ (modTensor A M M') A).hom ≫ + modTensorAct A M M' = + μ[A] ≫ d.copair := by + rw [BraidedCategory.braiding_naturality_left_assoc, + ← copair_act A M M' d, IsCommMonObj.mul_comm_assoc] + +/-- The action on the copairing unit collapses onto the +copairing: the copairing unit is a relative invariant of the +module tensor product. -/ +@[reassoc] +theorem copairUnit_act [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + (A ◁ copairUnit A M M' d) ≫ modTensorAct A M M' = + (ρ_ A).hom ≫ d.copair := by + rw [copairUnit, MonoidalCategory.whiskerLeft_comp, + Category.assoc, ← copair_act A M M' d, ← Category.assoc, + MonObj.mul_one] + +end Braided + +/-! ## The braiding of the module tensor product + +The copairing is consumed against the pairing through the +braiding of the module tensor product: the braiding of the +underlying factors descends through the coequalizers, the +relation carried across by the window exchange of `ModCross`. +The exchange swaps the two legs, so the two-sided descent needs +the symmetric base — the generality of the Key Lemma itself. +-/ + +section Symmetric + +/-- The strand crossing behind the braiding of the module tensor +product: crossing the pair as a block and braiding back across +the first factor equals crossing the second factor alone. -/ +private theorem swap_cross + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (P Q R : D) : + (α_ P Q R).inv ≫ (β_ (P ⊗ Q) R).hom ≫ (α_ R P Q).inv ≫ + ((β_ R P).hom ▷ Q) = + (P ◁ (β_ Q R).hom) ≫ (α_ P R Q).inv := by + rw [BraidedCategory.braiding_tensor_left_hom] + simp only [Category.assoc, Iso.inv_hom_id_assoc, + Iso.hom_inv_id_assoc] + rw [← MonoidalCategory.comp_whiskerRight, + SymmetricCategory.symmetry, MonoidalCategory.id_whiskerRight, + Category.comp_id] + +section Swap + +/-- **The braiding of the module tensor product**: the braiding +of the underlying factors descends through the coequalizers, the +relation carried across by the window exchange. -/ +noncomputable def modTensorSwap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) : + modTensor A M N ⟶ modTensor A N M := + modTensorDesc A M N ((β_ M.X N.X).hom ≫ modTensorπ A N M) + (by rw [modWinSwap_legM_assoc, modWinSwap_legN_assoc, + modTensor_condition]) + +/-- Defining equation of the braiding of the module tensor +product: on the projection it is the braiding of the factors. -/ +@[reassoc (attr := simp)] +theorem modTensorπ_swap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) : + modTensorπ A M N ≫ modTensorSwap A M N = + (β_ M.X N.X).hom ≫ modTensorπ A N M := + modTensorπ_desc A M N _ _ + +/-- The braiding of the module tensor product is an +involution. -/ +@[reassoc (attr := simp)] +theorem modTensorSwap_modTensorSwap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (M : Mod D A) (N : Mod D A) : + modTensorSwap A M N ≫ modTensorSwap A N M = + 𝟙 (modTensor A M N) := by + apply modTensor_hom_ext + rw [modTensorπ_swap_assoc, modTensorπ_swap, ← Category.assoc, + SymmetricCategory.symmetry, Category.id_comp, + Category.comp_id] + +end Swap + +section SwapLinear + +/-- **The braiding of the module tensor product is a module +map**: it intertwines the descended actions. -/ +@[reassoc] +theorem modTensorAct_swap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [IsCommMonObj A] (M : Mod D A) (N : Mod D A) : + modTensorAct A M N ≫ modTensorSwap A M N = + (A ◁ modTensorSwap A M N) ≫ modTensorAct A N M := by + apply modTensor_whisker_hom_ext A M N A + have hleg : (N.X ◁ actLeft A M.X) ≫ modTensorπ A N M = + (α_ N.X A M.X).inv ≫ ((β_ N.X A).hom ▷ M.X) ≫ + (actLeft A N.X ▷ M.X) ≫ modTensorπ A N M := by + have h := modTensor_condition A N M + rw [modTensorLegM, modTensorLegN, actRight, + MonoidalCategory.comp_whiskerRight, Category.assoc, + Category.assoc] at h + rw [h, Iso.inv_hom_id_assoc] + conv_lhs => rw [whiskerLeft_modTensorπ_act_assoc, + modTensorπ_swap] + conv_lhs => rw [BraidedCategory.braiding_naturality_left_assoc, + hleg] + conv_rhs => rw [← MonoidalCategory.whiskerLeft_comp_assoc, + modTensorπ_swap, MonoidalCategory.whiskerLeft_comp_assoc, + whiskerLeft_modTensorπ_act] + conv_rhs => simp only [Category.assoc] + rw [reassoc_of% swap_cross A M.X N.X] + +end SwapLinear + +/-! ## The zigzag scalar and the retraction law + +The composite of the copairing with the pairing through the +braiding of the module tensor product. The zigzag identity of +the datum — Deligne's (1.15.1) duality — is taken as a +hypothesis; it is not derivable from the bare datum. +-/ + +section Zigzag + +/-- **The zigzag scalar** of a duality datum: the copairing +unit, braided across the module tensor product and consumed by +the pairing. -/ +noncomputable def zig + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + 𝟙_ D ⟶ A := + copairUnit A M M' d ≫ modTensorSwap A M M' ≫ d.pair + +/-- **The retraction law**: under the zigzag identity of the +datum, the zigzag scalar is the unit of the base. -/ +theorem zig_eq_unit [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (hzig : d.copair ≫ modTensorSwap A M M' ≫ d.pair = 𝟙 A) : + zig A M M' d = η[A] := by + rw [zig, copairUnit, Category.assoc, hzig, Category.comp_id] + +end Zigzag + +end Symmetric + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowDatum.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowDatum.lean new file mode 100644 index 0000000000..4ab271e557 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowDatum.lean @@ -0,0 +1,138 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZig +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagNonzero + +/-! +# The power duality datum + +The tensor powers of a dual pair of modules form a dual pair: +the power pairing and the copairing power assemble into a +`ModDualityDatum` at every level. The pairing's linearity is +`modPowPairing_linear`; the copairing's linearity is proved here +from the associativity of the descended action, since the +copairing power is the action on the unit-stage element. + +The zigzag laws for the power datum — the inheritance of the +triangle identities up the powers — are the peel induction and +live separately; once available, `ZigzagNonzero` applied to the +power datum detects the nonvanishing of the copairing powers +from the nonvanishing of the power modules. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **Acting on a point is linear**: for an associative action on +a carrier, the orbit map of a global point is a module map from +the regular module. Stated over an abstract carrier so that +instantiations at definitional wrappers stay uniformly typed. -/ +theorem act_on_point_linear + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + {X : D} (act : A ⊗ X ⟶ X) + (hact : (μ[A] ▷ X) ≫ act = + (α_ A A X).hom ≫ (A ◁ act) ≫ act) + (u : 𝟙_ D ⟶ X) : + μ[A] ≫ (ρ_ A).inv ≫ (A ◁ u) ≫ act = + (A ◁ ((ρ_ A).inv ≫ (A ◁ u) ≫ act)) ≫ act := by + have hnat : ((A ⊗ A) ◁ u) ≫ (α_ A A X).hom = + (α_ A A (𝟙_ D)).hom ≫ (A ◁ (A ◁ u)) := + associator_naturality_right A A u + rw [← Category.assoc, rightUnitor_inv_naturality, Category.assoc, + ← Category.assoc (μ[A] ▷ 𝟙_ D), ← whisker_exchange, + Category.assoc, hact, reassoc_of% hnat, + ← Category.assoc ((ρ_ (A ⊗ A)).inv), + (by monoidal : (ρ_ (A ⊗ A)).inv ≫ (α_ A A (𝟙_ D)).hom = + A ◁ (ρ_ A).inv), + MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + Category.assoc] + +/-- **The orbit map returns the point at the unit**: for a unital +action, evaluating the orbit map of a global point at the monoid +unit recovers the point. -/ +theorem act_on_point_unit + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + {X : D} (act : A ⊗ X ⟶ X) + (hone : (η[A] ▷ X) ≫ act = (λ_ X).hom) + (u : 𝟙_ D ⟶ X) : + η[A] ≫ (ρ_ A).inv ≫ (A ◁ u) ≫ act = u := by + rw [← Category.assoc, rightUnitor_inv_naturality, Category.assoc, + ← Category.assoc (η[A] ▷ 𝟙_ D), ← whisker_exchange, + Category.assoc, hone, leftUnitor_naturality, + ← Category.assoc, + (by monoidal : (ρ_ (𝟙_ D)).inv ≫ (λ_ (𝟙_ D)).hom = + 𝟙 (𝟙_ D)), + Category.id_comp] + +/-- **The unit of the copairing power is the unit stage**: the +copair element of the power datum is the chain unit. -/ +theorem powCopairA_unit + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (n : ℕ) : + η[A] ≫ powCopairA A M M' d n = powUnitStage A M M' d n := + act_on_point_unit A + (modTensorAct A (modPowMod A M.X n) (modPowMod A M'.X n)) + (modTensorAct_one A (modPowMod A M.X n) (modPowMod A M'.X n)) + (powUnitStage A M M' d n) + +/-- **The copairing power is linear**: the copairing power is the +action on the unit-stage element, so its linearity is the +associativity of the descended action. -/ +theorem powCopairA_linear + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (n : ℕ) : + haveI := modTensorModObj A (modPowMod A M.X n) + (modPowMod A M'.X n) + μ[A] ≫ powCopairA A M M' d n = + (A ◁ powCopairA A M M' d n) ≫ + actLeft A (modTensor A (modPowMod A M.X n) + (modPowMod A M'.X n)) := + act_on_point_linear A + (modTensorAct A (modPowMod A M.X n) (modPowMod A M'.X n)) + (modTensorAct_mul A (modPowMod A M.X n) (modPowMod A M'.X n)) + (powUnitStage A M M' d n) + +/-- **The power duality datum**: the tensor powers of a dual pair +form a dual pair, with the power pairing and the copairing +power. -/ +noncomputable def powDualityDatum + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (n : ℕ) : + ModDualityDatum A (modPowMod A M.X n) (modPowMod A M'.X n) where + pair := modPowPairing A M M' d n + copair := powCopairA A M M' d n + pair_linear := modPowPairing_linear A M M' d n + copair_linear := powCopairA_linear A M M' d n + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowInduct.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowInduct.lean new file mode 100644 index 0000000000..9cb07acc75 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowInduct.lean @@ -0,0 +1,133 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainNonzero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairSucc +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSuccMod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZigzag + +/-! +# The power zigzag induction + +The successor power datum is the transfer of the tensor of the +stage datum and the bottom datum along the merge isomorphism, so +the zigzag laws climb the powers: the base is the arity-one +transfer and the step is the tensor inheritance transferred along +the merge. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The successor power datum is the transferred tensor +datum**: the merge isomorphism carries the tensor of the stage +datum and the bottom datum to the successor datum. -/ +theorem powDualityDatum_succ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (n : ℕ) : + powDualityDatum A M M' d (n + 1) = + (tensorDatum A (powDualityDatum A M M' d n) + (powDualityDatum A M M' d 0)).transfer A + (powFrontModInv A M.X n) (powBackModInv A M'.X n) + (powFrontMod A M.X n) (powBackMod A M'.X n) := by + refine ModDualityDatum.ext' A ?_ ?_ + · change modPowPairing A M M' d (n + 1) = + modTensorMap A (powBackModInv A M'.X n) + (powFrontModInv A M.X n) ≫ + tensorPair A (powDualityDatum A M M' d n) + (powDualityDatum A M M' d 0) + rw [← modPowPairing_succ_tensor A M M' d n, + ← Category.assoc, ← modTensorMap_comp] + rw [show powBackModInv A M'.X n ≫ powMulMod A M'.X n 0 = + 𝟙 (modPowMod A M'.X (n + 1)) from + powBackModInv_powBackMod A M'.X n] + rw [show powFrontModInv A M.X n ≫ + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)) = + 𝟙 (modPowMod A M.X (n + 1)) from + powFrontModInv_powFrontMod A M.X n] + rw [modTensorMap_id, Category.id_comp] + · change powCopairA A M M' d (n + 1) = + tensorCopair A (powDualityDatum A M M' d n) + (powDualityDatum A M M' d 0) ≫ + modTensorMap A (powFrontMod A M.X n) + (powBackMod A M'.X n) + exact powCopairA_succ_tensor A M M' d n + +/-- **The power data satisfy the zigzag laws at every arity**: +the base is the arity-one transfer; the step transfers the tensor +inheritance along the merge isomorphism. -/ +theorem powDualityDatum_zigzag_all + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (hz : ModZigzagDatum A d) : + ∀ n, ModZigzagDatum A (powDualityDatum A M M' d n) + | 0 => powDualityDatum_zigzag_zero A M M' d hz + | (n + 1) => by + rw [powDualityDatum_succ A M M' d n] + have he : powFrontMod A M.X n ≫ powFrontModInv A M.X n = + 𝟙 _ := powFrontMod_powFrontModInv A M.X n + have he' : powBackMod A M'.X n ≫ powBackModInv A M'.X n = + 𝟙 _ := powBackMod_powBackModInv A M'.X n + exact modZigzagDatum_transfer A _ + (powFrontModInv A M.X n) (powBackModInv A M'.X n) + (powFrontMod A M.X n) (powBackMod A M'.X n) + (tensorDatum_zigzag A + (powDualityDatum A M M' d n) + (powDualityDatum A M M' d 0) + (powDualityDatum_zigzag_all A M M' d hz n) + (powDualityDatum_zigzag_zero A M M' d hz)) + (powFrontModInv_powFrontMod A M.X n) + (powBackModInv_powBackMod A M'.X n) + (by rw [he, he']) + +section Detection + +/-- **Unconditional nonvanishing of the chain unit stages**: for +a zigzag datum with nonvanishing symmetric powers, every chain +unit stage is nonzero. -/ +theorem chainUnitStage_ne_zero_all + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [CategoryTheory.Linear ℂ D] [MonoidalLinear ℂ D] + (d : ModDualityDatum A M M') + (hz : ModZigzagDatum A d) (n : ℕ) + (hS : ¬ IsZero (symPow A M.X (n + 1))) : + chainUnitStage A M M' d n ≠ 0 := + chainUnitStage_ne_zero' A M M' d n + (powDualityDatum_zigzag_all A M M' d hz n) hS + +end Detection + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowMerge.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowMerge.lean new file mode 100644 index 0000000000..21752d8dc3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowMerge.lean @@ -0,0 +1,1369 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowChain + +/-! +# The merge isomorphism for module powers + +The relative tensor product of two module powers is the module +power of the summed arity: the descended power multiplication +`powMulDesc` of `PowChain.lean` is an isomorphism +`modTensor A (modPowMod A X a) (modPowMod A X b) ≅ + modPow A X (a + 1 + b + 1)`, +with inverse `powSplit` descended from the inverse of the +concatenation of ambient tensor powers. + +* `headMod`: the head insertion `X ⊗ X^⊗b ⟶ modPow A X (b + 1)`; + through `modPowMul` with the singleton power it is a module map + for the action on the head factor (`headMod_act`) — the slide of + the monoid from the head to the tail of a module power, packaged + through the multiplication rather than proved slot by slot. +* `powSplit`: the inverse direction, descended through the wide + coequalizer. Each slot relation of the big power either lands + inside one half, where the corresponding half projection absorbs + it (`powSplit_cond_left`/`powSplit_cond_right`), or at the + boundary between the halves, where it becomes the coequalizer + relation of the module tensor product itself + (`powSplit_cond_bound`). +* `powMergeIso`: the packaged isomorphism, with `powMulDesc` as the + forward direction and `powSplit` as the inverse. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## Structural shuffles of the boundary window + +Both boundary computations move a window map across the split of +the ambient power into two halves. The shuffles are stated at +general objects, so that no tensor-power arity enters the +rewriting. +-/ + +section Shuffle + +/-- The left-window shuffle: a window map acting on the first two +window factors passes to the left half of the split. -/ +theorem split_shuffle_fst [Category.{v} D] [MonoidalCategory D] + {P Q R S B : D} (u : Q ⟶ R) : + ((P ◁ (u ▷ S)) ▷ B) ≫ ((α_ P R S).inv ▷ B) ≫ + (α_ (P ⊗ R) S B).hom = + (α_ P (Q ⊗ S) B).hom ≫ (P ◁ (α_ Q S B).hom) ≫ + (α_ P Q (S ⊗ B)).inv ≫ ((P ◁ u) ▷ (S ⊗ B)) := by + have hpent : (α_ P (R ⊗ S) B).hom ≫ (P ◁ (α_ R S B).hom) ≫ + (α_ P R (S ⊗ B)).inv = + ((α_ P R S).inv ▷ B) ≫ (α_ (P ⊗ R) S B).hom := by + monoidal + conv_rhs => rw [← associator_inv_naturality_middle, + ← whiskerLeft_comp_assoc, ← associator_naturality_left, + whiskerLeft_comp_assoc, ← associator_naturality_middle_assoc] + rw [hpent] + +/-- A whisker absorbed into the left factor of a tensor of +morphisms. -/ +theorem whiskerRight_tensorHom [Category.{v} D] [MonoidalCategory D] + {P₁ P₂ Q₂ R S : D} + (f : P₁ ⟶ P₂) (g : P₂ ⟶ S) (h : R ⟶ Q₂) : + (f ▷ R) ≫ (g ⊗ₘ h) = (f ≫ g) ⊗ₘ h := by + rw [← tensorHom_id f R, MonoidalCategory.tensorHom_comp_tensorHom, + Category.id_comp] + +/-- Two whiskers absorbed into the left factor of a tensor of +morphisms. -/ +theorem whiskerRight_tensorHom_whiskerRight + [Category.{v} D] [MonoidalCategory D] + {P₁ P₂ S T R Q₂ : D} + (f : P₁ ⟶ P₂) (g : P₂ ⟶ S) (k : S ⟶ T) (h : R ⟶ Q₂) : + (f ▷ R) ≫ (g ⊗ₘ h) ≫ (k ▷ Q₂) = (f ≫ g ≫ k) ⊗ₘ h := by + rw [← tensorHom_id f R, ← tensorHom_id k Q₂, + MonoidalCategory.tensorHom_comp_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom] + simp only [Category.id_comp, Category.comp_id] + +/-- A left whisker absorbed into the right factor of a tensor of +morphisms. -/ +theorem whiskerLeft_comp_tensorHom [Category.{v} D] [MonoidalCategory D] + {P Q₁ R₁ R₂ S : D} + (f : R₁ ⟶ R₂) (g : P ⟶ Q₁) (h : R₂ ⟶ S) : + (P ◁ f) ≫ (g ⊗ₘ h) = g ⊗ₘ (f ≫ h) := by + rw [← id_tensorHom P f, MonoidalCategory.tensorHom_comp_tensorHom, + Category.id_comp] + +/-- The right-window shuffle: a window map acting on the last two +window factors passes to the head of the right half of the +split. -/ +theorem split_shuffle_snd [Category.{v} D] [MonoidalCategory D] + {P Y G S B : D} (v : G ⊗ S ⟶ S) : + ((P ◁ ((α_ Y G S).hom ≫ (Y ◁ v))) ▷ B) ≫ + ((α_ P Y S).inv ▷ B) ≫ (α_ (P ⊗ Y) S B).hom = + (α_ P ((Y ⊗ G) ⊗ S) B).hom ≫ + (P ◁ (α_ (Y ⊗ G) S B).hom) ≫ + (α_ P (Y ⊗ G) (S ⊗ B)).inv ≫ + ((α_ P Y G).inv ▷ (S ⊗ B)) ≫ + (α_ (P ⊗ Y) G (S ⊗ B)).hom ≫ + ((P ⊗ Y) ◁ ((α_ G S B).inv ≫ (v ▷ B))) := by + have hstruct : (α_ P ((Y ⊗ G) ⊗ S) B).hom ≫ + (P ◁ (α_ (Y ⊗ G) S B).hom) ≫ + (α_ P (Y ⊗ G) (S ⊗ B)).inv ≫ + ((α_ P Y G).inv ▷ (S ⊗ B)) ≫ + (α_ (P ⊗ Y) G (S ⊗ B)).hom ≫ + ((P ⊗ Y) ◁ (α_ G S B).inv) = + ((P ◁ (α_ Y G S).hom) ▷ B) ≫ + ((α_ P Y (G ⊗ S)).inv ▷ B) ≫ + (α_ (P ⊗ Y) (G ⊗ S) B).hom := by + monoidal + have hnat : (P ◁ (Y ◁ v)) ≫ (α_ P Y S).inv = + (α_ P Y (G ⊗ S)).inv ≫ ((P ⊗ Y) ◁ v) := + associator_inv_naturality_right P Y v + conv_lhs => rw [MonoidalCategory.whiskerLeft_comp, + comp_whiskerRight, Category.assoc, + ← comp_whiskerRight_assoc (P ◁ (Y ◁ v)) (α_ P Y S).inv, + hnat, comp_whiskerRight_assoc, + associator_naturality_middle] + rw [← reassoc_of% hstruct, ← MonoidalCategory.whiskerLeft_comp] + +end Shuffle + +/-! ## The head insertion + +The split of the big power exposes the right half with its head +factor peeled: the map into the module power of the right half is +the peeling inverse followed by the projection. Through the +multiplication with the singleton power this insertion is a module +map for the action on the head factor — the slide of the monoid +from the head to the tail of a module power, obtained from +`modPowMul_actLeft` rather than slot by slot. +-/ + +section HeadJoin + +/-- The left unitor inverse, retyped so that its target is stated +through the singleton tensor power — this keeps every statement +about it type-correct at low transparency. -/ +noncomputable def toPowOne + [Category.{v} D] [MonoidalCategory D] (X : D) : X ⟶ tensorPow D X 1 := + (λ_ X).inv + +/-- The peeling inverse is the concatenation with a singleton +block, up to the unitor and an arity transport. -/ +@[reassoc] +theorem powPeel_inv_concat [Category.{v} D] [MonoidalCategory D] (X : D) + (b : ℕ) : + (toPowOne X ▷ tensorPow D X b) ≫ (tensorPowConcat X 1 b).hom ≫ + powCast X (by omega : 1 + b = b + 1) = + (powPeel X b).inv := by + rw [← cancel_epi (powPeel X b).hom, Iso.hom_inv_id] + have hcombine : (tensorPow D X 0 ◁ (powPeel X b).hom) ≫ + powAttach X 0 b ≫ (tensorPowConcat X (0 + 1) b).hom ≫ + powCast X (by omega : 0 + 1 + b = 0 + (b + 1)) = + (λ_ (tensorPow D X (b + 1))).hom ≫ + powCast X (by omega : b + 1 = 0 + (b + 1)) := by + rw [← tensorPowConcat_peel, tensorPowConcat_zero_left] + have hcoh : (λ_ X).inv ▷ tensorPow D X b = + (λ_ (X ⊗ tensorPow D X b)).inv ≫ + (α_ (𝟙_ D) X (tensorPow D X b)).inv := by + monoidal + have hsplit : powCast X (by omega : 0 + 1 + b = b + 1) = + powCast X (by omega : 0 + 1 + b = 0 + (b + 1)) ≫ + powCast X (by omega : 0 + (b + 1) = b + 1) := by + rw [powCast_comp] + have hcombine' : (𝟙_ D ◁ (powPeel X b).hom) ≫ + (α_ (𝟙_ D) X (tensorPow D X b)).inv ≫ + (tensorPowConcat X (0 + 1) b).hom ≫ + powCast X (by omega : 0 + 1 + b = 0 + (b + 1)) = + (λ_ (tensorPow D X (b + 1))).hom ≫ + powCast X (by omega : b + 1 = 0 + (b + 1)) := hcombine + have hgoal : (powPeel X b).hom ≫ + ((λ_ X).inv ▷ tensorPow D X b) ≫ + (tensorPowConcat X (0 + 1) b).hom ≫ + powCast X (by omega : 0 + 1 + b = b + 1) = + 𝟙 (tensorPow D X (b + 1)) := by + rw [hcoh, hsplit] + simp only [Category.assoc] + have hc := congrArg (fun t => t ≫ powCast X + (by omega : 0 + (b + 1) = b + 1)) hcombine' + repeat' erw [Category.assoc] at hc + erw [leftUnitor_inv_naturality_assoc, hc] + simp only [powCast_comp] + have hid : powCast X + (by omega : b + 1 = b + 1) = 𝟙 _ := powCast_rfl X (b + 1) + rw [hid, Category.comp_id, Iso.inv_hom_id] + exact hgoal + +/-- The head insertion of a factor into a module power: peel the +head off the target power and project. -/ +noncomputable def headMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] (X : D) [ModObj A X] + (b : ℕ) : + X ⊗ tensorPow D X b ⟶ modPow A X (b + 1) := + (powPeel X b).inv ≫ modPowπ A X (b + 1) + +/-- The head insertion is the multiplication with the singleton +power, up to the singleton isomorphism and an arity transport. -/ +theorem headMod_eq_mul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (X : D) [ModObj A X] + (b : ℕ) : + headMod A X b = + ((modPowOne A X).inv ⊗ₘ modPowπ A X b) ≫ + modPowMul A X 1 b ≫ + modPowCast A X (by omega : 1 + b = b + 1) := by + have h1 : (modPowOne A X).inv = toPowOne X ≫ modPowπ A X 1 := rfl + have hB : ((modPowOne A X).inv ⊗ₘ modPowπ A X b) = + (toPowOne X ▷ tensorPow D X b) ≫ + (modPowπ A X 1 ⊗ₘ modPowπ A X b) := by + rw [h1] + conv_lhs => rw [← Category.id_comp (modPowπ A X b), + ← MonoidalCategory.tensorHom_comp_tensorHom] + rw [tensorHom_id] + rw [hB] + simp only [Category.assoc] + rw [modPowπ_tensor_modPowMul_assoc, modPowπ_cast, + powPeel_inv_concat_assoc] + rfl + +/-- **The head insertion is a module map**: the monoid acting on +the head factor descends to the module-power action. At positive +arity this is `modPowMul_actLeft` with a singleton left block — the +slide of the monoid across the whole power, packaged through the +multiplication. -/ +theorem headMod_act [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (b : ℕ) : + (A ◁ headMod A X b) ≫ modPowAct A X b = + (α_ A X (tensorPow D X b)).inv ≫ + (actLeft A X ▷ tensorPow D X b) ≫ headMod A X b := by + cases b with + | zero => + have h0 : headMod A X 0 = + (show X ⊗ tensorPow D X 0 ⟶ X from (ρ_ X).hom) ≫ + (modPowOne A X).inv := by + change ((ρ_ X).hom ≫ (λ_ X).inv) ≫ modPowπ A X 1 = _ + erw [Category.assoc] + rfl + have hu : (actLeft A X ▷ tensorPow D X 0) ≫ + (show X ⊗ tensorPow D X 0 ⟶ X from (ρ_ X).hom) = + (show (A ⊗ X) ⊗ tensorPow D X 0 ⟶ A ⊗ X from + (ρ_ (A ⊗ X)).hom) ≫ actLeft A X := + rightUnitor_naturality (actLeft A X) + have hcoh : (α_ A X (tensorPow D X 0)).inv ≫ + (show (A ⊗ X) ⊗ tensorPow D X 0 ⟶ A ⊗ X from + (ρ_ (A ⊗ X)).hom) = + A ◁ (show X ⊗ tensorPow D X 0 ⟶ X from (ρ_ X).hom) := by + have hcoh0 : (α_ A X (𝟙_ D)).inv ≫ (ρ_ (A ⊗ X)).hom = + A ◁ (ρ_ X).hom := by monoidal + exact hcoh0 + have hu' := congrArg (fun t => t ≫ (modPowOne A X).inv) hu + repeat' erw [Category.assoc] at hu' + have hcoh' := congrArg (fun t => t ≫ actLeft A X ≫ (modPowOne A X).inv) hcoh + repeat' erw [Category.assoc] at hcoh' + erw [h0, MonoidalCategory.whiskerLeft_comp, Category.assoc, + ← actLeft_modPowOne_inv, hu', hcoh'] + | succ b₀ => + have hcast : (A ◁ modPowCast A X + (by omega : 1 + (b₀ + 1) = b₀ + 1 + 1)) ≫ + modPowAct A X (b₀ + 1) = + modPowAct A X (1 + b₀) ≫ modPowCast A X + (by omega : 1 + (b₀ + 1) = b₀ + 1 + 1) := + modPowAct_cast A X _ + have hml : (α_ A (modPow A X 1) (modPow A X (b₀ + 1))).inv ≫ + (modPowAct A X 0 ▷ modPow A X (b₀ + 1)) ≫ + modPowMul A X 1 (b₀ + 1) = + (A ◁ modPowMul A X 1 (b₀ + 1)) ≫ + modPowAct A X (1 + b₀) := + modPowMul_actLeft A X 0 b₀ + have hassoc : (A ◁ ((modPowOne A X).inv ⊗ₘ + modPowπ A X (b₀ + 1))) ≫ + (α_ A (modPow A X 1) (modPow A X (b₀ + 1))).inv = + (α_ A X (tensorPow D X (b₀ + 1))).inv ≫ + ((A ◁ (modPowOne A X).inv) ⊗ₘ + modPowπ A X (b₀ + 1)) := by + rw [← id_tensorHom, associator_inv_naturality, id_tensorHom] + have hact : ((A ◁ (modPowOne A X).inv) ⊗ₘ + modPowπ A X (b₀ + 1)) ≫ + (modPowAct A X 0 ▷ modPow A X (b₀ + 1)) = + (actLeft A X ▷ tensorPow D X (b₀ + 1)) ≫ + ((modPowOne A X).inv ⊗ₘ modPowπ A X (b₀ + 1)) := by + rw [← tensorHom_id, ← tensorHom_id, tensorHom_comp_tensorHom, + tensorHom_comp_tensorHom, Category.comp_id, + Category.id_comp, actLeft_modPowOne_inv] + rw [headMod_eq_mul A X (b₀ + 1), + MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rw [hcast, ← reassoc_of% hml, reassoc_of% hassoc, + reassoc_of% hact] + +end HeadJoin + +/-! ## The tail of the left half + +The braided right action of the monoid on the left half of the +split is, after the projection, the boundary window's action on +the last factor of the left half. +-/ + +section TailJoin + +/-- In a symmetric category, carrying past a context inverts to +carrying back past it. -/ +theorem braidPast_hom_swap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (U V T : D) : + (braidPast U V T).hom ≫ (braidPast V U T).hom = 𝟙 _ := by + simp only [braidPast_hom] + rw [Category.assoc, Category.assoc, Iso.hom_inv_id_assoc, + ← comp_whiskerRight_assoc, SymmetricCategory.symmetry, + MonoidalCategory.id_whiskerRight, Category.id_comp, + Iso.inv_hom_id] + +/-- **Braiding the monoid over a context pair**: the braided right +action through the last factor of a pair is the braiding of the +factor alone, then the action — the monoid never crosses the +context. -/ +theorem braiding_actAcross + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] + (P : D) : + (β_ (P ⊗ X) A).hom ≫ actAcross A P X = + (α_ P X A).hom ≫ (P ◁ actRight A X) := by + have h2 : (braidPast P A X).inv = (braidPast A P X).hom := by + rw [← cancel_epi (braidPast P A X).hom, Iso.hom_inv_id] + exact (braidPast_hom_swap P A X).symm + have h1 := associator_inv_braiding_braidPast_inv P X A + rw [h2] at h1 + have h3 : (β_ (P ⊗ X) A).hom ≫ (braidPast A P X).hom = + (α_ P X A).hom ≫ (P ◁ (β_ X A).hom) := by + rw [← h1, Iso.hom_inv_id_assoc] + rw [actAcross_eq_braidPast, ← Category.assoc, h3, + Category.assoc, ← MonoidalCategory.whiskerLeft_comp] + rfl + +/-- The braided right action of the module power, typed at the +plain power — this keeps every statement about it type-correct at +low transparency. -/ +noncomputable def powActRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (a : ℕ) : + modPow A X (a + 1) ⊗ A ⟶ modPow A X (a + 1) := + actRight A (modPowMod A X a).X + +/-- The boundary reassociation, retyped so that its target is +stated through the grown tensor power. -/ +noncomputable def boundAssoc + [Category.{v} D] [MonoidalCategory D] (A : D) (X : D) + (a : ℕ) : + tensorPow D X a ⊗ (X ⊗ A) ⟶ tensorPow D X (a + 1) ⊗ A := + (α_ (tensorPow D X a) X A).inv + +/-- **The braided right action of the left half after the +projection**: on the ambient power it is the boundary window's +right action on the last factor. -/ +theorem modPowπ_actRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (a : ℕ) : + (modPowπ A X (a + 1) ▷ A) ≫ powActRight A X a = + (α_ (tensorPow D X a) X A).hom ≫ + (tensorPow D X a ◁ actRight A X) ≫ modPowπ A X (a + 1) := by + have hβ : (modPowπ A X (a + 1) ▷ A) ≫ + (β_ (modPow A X (a + 1)) A).hom = + (β_ (tensorPow D X (a + 1)) A).hom ≫ + (A ◁ modPowπ A X (a + 1)) := + BraidedCategory.braiding_naturality_left (modPowπ A X (a + 1)) A + have hact : (A ◁ modPowπ A X (a + 1)) ≫ + actLeft A (modPowMod A X a).X = + powTailAct A X a ≫ modPowπ A X (a + 1) := + whiskerLeft_modPowπ_modPowAct A X a + have hkey : (β_ (tensorPow D X (a + 1)) A).hom ≫ + powTailAct A X a = + (α_ (tensorPow D X a) X A).hom ≫ + (tensorPow D X a ◁ actRight A X) := + braiding_actAcross A X (tensorPow D X a) + change (modPowπ A X (a + 1) ▷ A) ≫ + ((β_ (modPow A X (a + 1)) A).hom ≫ + actLeft A (modPowMod A X a).X) = _ + erw [← Category.assoc, hβ, Category.assoc, hact] + exact ((reassoc_of% hkey) (modPowπ A X (a + 1))).trans + (Category.assoc _ _ _) + +end TailJoin + +/-! ## The boundary bridge of the concatenation -/ + +section ConcatBound + +/-- Detach the top factor of the first block onto the second. The +associator, retyped so that its source is stated through the tensor +power — the inverse bridge to `powAttach`. -/ +noncomputable def powDetach [Category.{v} D] [MonoidalCategory D] (X : D) + (p q : ℕ) : + tensorPow D X (p + 1) ⊗ tensorPow D X q ⟶ + tensorPow D X p ⊗ (X ⊗ tensorPow D X q) := + (α_ (tensorPow D X p) X (tensorPow D X q)).hom + +/-- **The boundary split of the concatenation**: undoing the split +concatenation after the glued one detaches the exposed window +factor onto the right half and peels it back in. -/ +theorem concat_split_bound [Category.{v} D] [MonoidalCategory D] (X : D) + (a b : ℕ) : + (tensorPowConcat X (a + 1 + 1) b).hom ≫ + powCast X (by omega : a + 1 + 1 + b = a + 1 + (b + 1)) ≫ + (tensorPowConcat X (a + 1) (b + 1)).inv = + powDetach X (a + 1) b ≫ + (tensorPow D X (a + 1) ◁ (powPeel X b).inv) := by + rw [← cancel_mono (tensorPowConcat X (a + 1) (b + 1)).hom] + simp only [Category.assoc, Iso.inv_hom_id, Category.comp_id] + rw [tensorPowConcat_peel X (a + 1) b] + rw [← whiskerLeft_comp_assoc, Iso.inv_hom_id, + MonoidalCategory.whiskerLeft_id, Category.id_comp] + have hda : powDetach X (a + 1) b ≫ powAttach X (a + 1) b = + 𝟙 (tensorPow D X (a + 1 + 1) ⊗ tensorPow D X b) := + (α_ (tensorPow D X (a + 1)) X (tensorPow D X b)).hom_inv_id + rw [reassoc_of% hda] + +end ConcatBound + +/-! ## The boundary slot + +The slot relation straddling the two halves of the split becomes, +after both projections, the coequalizer relation of the module +tensor product: the boundary bridge carries the relation object +onto `(modPow ⊗ A) ⊗ modPow`, the braided right action of the left +half absorbs the `M`-leg, and the head insertion of the right half +absorbs the `N`-leg. +-/ + +section Boundary + +/-- The boundary bridge: reassociate the window across the split +and project both halves, keeping the monoid between them. -/ +noncomputable def boundBridge + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] (X : D) [ModObj A X] + (a b : ℕ) : + modPowMid A X a b ⟶ + (modPow A X (a + 1) ⊗ A) ⊗ modPow A X (b + 1) := + (α_ (tensorPow D X a) ((X ⊗ A) ⊗ X) (tensorPow D X b)).hom ≫ + (tensorPow D X a ◁ (α_ (X ⊗ A) X (tensorPow D X b)).hom) ≫ + (α_ (tensorPow D X a) (X ⊗ A) (X ⊗ tensorPow D X b)).inv ≫ + (boundAssoc A X a ▷ (X ⊗ tensorPow D X b)) ≫ + ((modPowπ A X (a + 1) ▷ A) ⊗ₘ headMod A X b) + +/-- The `M`-leg of the boundary slot factors through the boundary +bridge and the first module-tensor leg. -/ +theorem boundBridge_legM + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (a b : ℕ) : + modPowLegM A X a b ≫ + powCast X (by omega : a + 2 + b = a + 1 + (b + 1)) ≫ + (tensorPowConcat X (a + 1) (b + 1)).inv ≫ + (modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + modTensorπ A (modPowMod A X a) (modPowMod A X b) = + boundBridge A X a b ≫ + modTensorLegM A (modPowMod A X a) (modPowMod A X b) ≫ + modTensorπ A (modPowMod A X a) (modPowMod A X b) := by + have hsplit : (tensorPowConcat X (a + 2) b).hom ≫ + powCast X (by omega : a + 2 + b = a + 1 + (b + 1)) ≫ + (tensorPowConcat X (a + 1) (b + 1)).inv = + powDetach X (a + 1) b ≫ + (tensorPow D X (a + 1) ◁ (powPeel X b).inv) := + concat_split_bound X a b + have hM : ((tensorPow D X a ◁ (actRight A X ▷ X)) ▷ + tensorPow D X b) ≫ + ((α_ (tensorPow D X a) X X).inv ▷ tensorPow D X b) ≫ + powDetach X (a + 1) b = + (α_ (tensorPow D X a) ((X ⊗ A) ⊗ X) + (tensorPow D X b)).hom ≫ + (tensorPow D X a ◁ + (α_ (X ⊗ A) X (tensorPow D X b)).hom) ≫ + (α_ (tensorPow D X a) (X ⊗ A) + (X ⊗ tensorPow D X b)).inv ≫ + ((tensorPow D X a ◁ actRight A X) ▷ + (X ⊗ tensorPow D X b)) := + split_shuffle_fst (actRight A X) + have sub1 : (tensorPow D X (a + 1) ◁ (powPeel X b).inv) ≫ + (modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) = + (modPowπ A X (a + 1) ⊗ₘ headMod A X b) := + whiskerLeft_comp_tensorHom (powPeel X b).inv + (modPowπ A X (a + 1)) (modPowπ A X (b + 1)) + have hcancel : boundAssoc A X a ≫ + (α_ (tensorPow D X a) X A).hom ≫ + ((tensorPow D X a ◁ actRight A X) ≫ modPowπ A X (a + 1)) = + (tensorPow D X a ◁ actRight A X) ≫ modPowπ A X (a + 1) := + Iso.inv_hom_id_assoc (α_ (tensorPow D X a) X A) + ((tensorPow D X a ◁ actRight A X) ≫ modPowπ A X (a + 1)) + have hπR : (tensorPow D X a ◁ actRight A X) ≫ + modPowπ A X (a + 1) = + boundAssoc A X a ≫ (modPowπ A X (a + 1) ▷ A) ≫ + powActRight A X a := + hcancel.symm.trans (congrArg (fun z => boundAssoc A X a ≫ z) + (modPowπ_actRight A X a).symm) + have sub2 : ((tensorPow D X a ◁ actRight A X) ▷ + (X ⊗ tensorPow D X b)) ≫ + (modPowπ A X (a + 1) ⊗ₘ headMod A X b) = + (boundAssoc A X a ▷ (X ⊗ tensorPow D X b)) ≫ + ((modPowπ A X (a + 1) ▷ A) ⊗ₘ headMod A X b) ≫ + (powActRight A X a ▷ modPow A X (b + 1)) := + (whiskerRight_tensorHom (tensorPow D X a ◁ actRight A X) + (modPowπ A X (a + 1)) (headMod A X b)).trans + ((congrArg (· ⊗ₘ headMod A X b) hπR).trans + (whiskerRight_tensorHom_whiskerRight (boundAssoc A X a) + (modPowπ A X (a + 1) ▷ A) (powActRight A X a) + (headMod A X b)).symm) + have hLegM : (powActRight A X a ▷ modPow A X (b + 1)) = + modTensorLegM A (modPowMod A X a) (modPowMod A X b) := rfl + -- names for the factors of the chain + set w₁ := (tensorPow D X a ◁ (actRight A X ▷ X)) ▷ + tensorPow D X b with hw₁ + set w₂ := (α_ (tensorPow D X a) X X).inv ▷ tensorPow D X b + with hw₂ + set cc := (tensorPowConcat X (a + 2) b).hom with hcc + set ci := (tensorPowConcat X (a + 1) (b + 1)).inv with hci + set pd := powDetach X (a + 1) b with hpd + set pl := tensorPow D X (a + 1) ◁ (powPeel X b).inv with hpl + set ππ := modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1) with hππ + set mT := modTensorπ A (modPowMod A X a) (modPowMod A X b) + with hmT + set σ₁ := (α_ (tensorPow D X a) ((X ⊗ A) ⊗ X) + (tensorPow D X b)).hom with hσ₁ + set σ₂ := tensorPow D X a ◁ + (α_ (X ⊗ A) X (tensorPow D X b)).hom with hσ₂ + set σ₃ := (α_ (tensorPow D X a) (X ⊗ A) + (X ⊗ tensorPow D X b)).inv with hσ₃ + set wact := (tensorPow D X a ◁ actRight A X) ▷ + (X ⊗ tensorPow D X b) with hwact + set bA := boundAssoc A X a ▷ (X ⊗ tensorPow D X b) with hbA + set tH := (modPowπ A X (a + 1) ▷ A) ⊗ₘ headMod A X b with htH + set pR := powActRight A X a ▷ modPow A X (b + 1) with hpR + set cs := powCast X + (by omega : a + 2 + b = a + 1 + (b + 1)) with hcs + have E1 : cc ≫ (cs ≫ (ci ≫ (ππ ≫ mT))) = + pd ≫ (pl ≫ (ππ ≫ mT)) := + (reassoc_of% hsplit) (ππ ≫ mT) + have E2 : wact ≫ (pl ≫ (ππ ≫ mT)) = + bA ≫ (tH ≫ (pR ≫ mT)) := by + calc wact ≫ (pl ≫ (ππ ≫ mT)) + = wact ≫ ((pl ≫ ππ) ≫ mT) := + congrArg (fun z => wact ≫ z) + (Category.assoc pl ππ mT).symm + _ = wact ≫ ((modPowπ A X (a + 1) ⊗ₘ headMod A X b) ≫ + mT) := + congrArg (fun z => wact ≫ (z ≫ mT)) sub1 + _ = (wact ≫ (modPowπ A X (a + 1) ⊗ₘ headMod A X b)) ≫ + mT := + (Category.assoc wact _ mT).symm + _ = (bA ≫ (tH ≫ pR)) ≫ mT := congrArg (· ≫ mT) sub2 + _ = bA ≫ (tH ≫ (pR ≫ mT)) := + (Category.assoc bA (tH ≫ pR) mT).trans + (congrArg (fun z => bA ≫ z) + (Category.assoc tH pR mT)) + calc modPowLegM A X a b ≫ + (cs ≫ (ci ≫ (ππ ≫ mT))) + = (w₁ ≫ (w₂ ≫ cc)) ≫ (cs ≫ (ci ≫ (ππ ≫ mT))) := rfl + _ = w₁ ≫ ((w₂ ≫ cc) ≫ (cs ≫ (ci ≫ (ππ ≫ mT)))) := + Category.assoc w₁ (w₂ ≫ cc) _ + _ = w₁ ≫ (w₂ ≫ (cc ≫ (cs ≫ (ci ≫ (ππ ≫ mT))))) := + congrArg (fun z => w₁ ≫ z) (Category.assoc w₂ cc _) + _ = w₁ ≫ (w₂ ≫ (pd ≫ (pl ≫ (ππ ≫ mT)))) := + congrArg (fun z => w₁ ≫ (w₂ ≫ z)) E1 + _ = w₁ ≫ ((w₂ ≫ pd) ≫ (pl ≫ (ππ ≫ mT))) := + congrArg (fun z => w₁ ≫ z) + (Category.assoc w₂ pd _).symm + _ = (w₁ ≫ (w₂ ≫ pd)) ≫ (pl ≫ (ππ ≫ mT)) := + (Category.assoc w₁ (w₂ ≫ pd) _).symm + _ = (σ₁ ≫ (σ₂ ≫ (σ₃ ≫ wact))) ≫ (pl ≫ (ππ ≫ mT)) := + congrArg (· ≫ (pl ≫ (ππ ≫ mT))) hM + _ = σ₁ ≫ ((σ₂ ≫ (σ₃ ≫ wact)) ≫ (pl ≫ (ππ ≫ mT))) := + Category.assoc σ₁ _ _ + _ = σ₁ ≫ (σ₂ ≫ ((σ₃ ≫ wact) ≫ (pl ≫ (ππ ≫ mT)))) := + congrArg (fun z => σ₁ ≫ z) (Category.assoc σ₂ _ _) + _ = σ₁ ≫ (σ₂ ≫ (σ₃ ≫ (wact ≫ (pl ≫ (ππ ≫ mT))))) := + congrArg (fun z => σ₁ ≫ (σ₂ ≫ z)) + (Category.assoc σ₃ wact _) + _ = σ₁ ≫ (σ₂ ≫ (σ₃ ≫ (bA ≫ (tH ≫ (pR ≫ mT))))) := + congrArg (fun z => σ₁ ≫ (σ₂ ≫ (σ₃ ≫ z))) E2 + _ = σ₁ ≫ (σ₂ ≫ (σ₃ ≫ ((bA ≫ tH) ≫ (pR ≫ mT)))) := + congrArg (fun z => σ₁ ≫ (σ₂ ≫ (σ₃ ≫ z))) + (Category.assoc bA tH _).symm + _ = σ₁ ≫ (σ₂ ≫ ((σ₃ ≫ (bA ≫ tH)) ≫ (pR ≫ mT))) := + congrArg (fun z => σ₁ ≫ (σ₂ ≫ z)) + (Category.assoc σ₃ (bA ≫ tH) _).symm + _ = σ₁ ≫ ((σ₂ ≫ (σ₃ ≫ (bA ≫ tH))) ≫ (pR ≫ mT)) := + congrArg (fun z => σ₁ ≫ z) + (Category.assoc σ₂ (σ₃ ≫ (bA ≫ tH)) _).symm + _ = (σ₁ ≫ (σ₂ ≫ (σ₃ ≫ (bA ≫ tH)))) ≫ (pR ≫ mT) := + (Category.assoc σ₁ (σ₂ ≫ (σ₃ ≫ (bA ≫ tH))) + (pR ≫ mT)).symm + _ = boundBridge A X a b ≫ + (modTensorLegM A (modPowMod A X a) (modPowMod A X b) ≫ + mT) := + congrArg (fun z => boundBridge A X a b ≫ (z ≫ mT)) hLegM + +/-- The `N`-leg of the boundary slot factors through the boundary +bridge and the second module-tensor leg. -/ +theorem boundBridge_legN + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (a b : ℕ) : + modPowLegN A X a b ≫ + powCast X (by omega : a + 2 + b = a + 1 + (b + 1)) ≫ + (tensorPowConcat X (a + 1) (b + 1)).inv ≫ + (modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + modTensorπ A (modPowMod A X a) (modPowMod A X b) = + boundBridge A X a b ≫ + modTensorLegN A (modPowMod A X a) (modPowMod A X b) ≫ + modTensorπ A (modPowMod A X a) (modPowMod A X b) := by + have hsplit : (tensorPowConcat X (a + 2) b).hom ≫ + powCast X (by omega : a + 2 + b = a + 1 + (b + 1)) ≫ + (tensorPowConcat X (a + 1) (b + 1)).inv = + powDetach X (a + 1) b ≫ + (tensorPow D X (a + 1) ◁ (powPeel X b).inv) := + concat_split_bound X a b + have hN : ((tensorPow D X a ◁ + ((α_ X A X).hom ≫ (X ◁ actLeft A X))) ▷ + tensorPow D X b) ≫ + ((α_ (tensorPow D X a) X X).inv ▷ tensorPow D X b) ≫ + powDetach X (a + 1) b = + (α_ (tensorPow D X a) ((X ⊗ A) ⊗ X) + (tensorPow D X b)).hom ≫ + (tensorPow D X a ◁ + (α_ (X ⊗ A) X (tensorPow D X b)).hom) ≫ + (α_ (tensorPow D X a) (X ⊗ A) + (X ⊗ tensorPow D X b)).inv ≫ + (boundAssoc A X a ▷ (X ⊗ tensorPow D X b)) ≫ + (α_ (tensorPow D X (a + 1)) A + (X ⊗ tensorPow D X b)).hom ≫ + (tensorPow D X (a + 1) ◁ + ((α_ A X (tensorPow D X b)).inv ≫ + (actLeft A X ▷ tensorPow D X b))) := + split_shuffle_snd (actLeft A X) + have sub1 : (tensorPow D X (a + 1) ◁ (powPeel X b).inv) ≫ + (modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) = + (modPowπ A X (a + 1) ⊗ₘ headMod A X b) := + whiskerLeft_comp_tensorHom (powPeel X b).inv + (modPowπ A X (a + 1)) (modPowπ A X (b + 1)) + have n2 : (tensorPow D X (a + 1) ◁ + ((α_ A X (tensorPow D X b)).inv ≫ + (actLeft A X ▷ tensorPow D X b))) ≫ + (modPowπ A X (a + 1) ⊗ₘ headMod A X b) = + (modPowπ A X (a + 1) ⊗ₘ + (((α_ A X (tensorPow D X b)).inv ≫ + (actLeft A X ▷ tensorPow D X b)) ≫ + headMod A X b)) := + whiskerLeft_comp_tensorHom _ (modPowπ A X (a + 1)) + (headMod A X b) + have n3 : ((α_ A X (tensorPow D X b)).inv ≫ + (actLeft A X ▷ tensorPow D X b)) ≫ headMod A X b = + (A ◁ headMod A X b) ≫ modPowAct A X b := + (Category.assoc _ _ _).trans (headMod_act A X b).symm + have n4 : (modPowπ A X (a + 1) ⊗ₘ + ((A ◁ headMod A X b) ≫ modPowAct A X b)) = + (modPowπ A X (a + 1) ⊗ₘ (A ◁ headMod A X b)) ≫ + (modPow A X (a + 1) ◁ modPowAct A X b) := + (tensorHom_comp_whiskerLeft (modPowπ A X (a + 1)) + (A ◁ headMod A X b) (modPowAct A X b)).symm + have n5 : (α_ (tensorPow D X (a + 1)) A + (X ⊗ tensorPow D X b)).hom ≫ + (modPowπ A X (a + 1) ⊗ₘ (A ◁ headMod A X b)) = + ((modPowπ A X (a + 1) ▷ A) ⊗ₘ headMod A X b) ≫ + (α_ (modPow A X (a + 1)) A (modPow A X (b + 1))).hom := by + have hnat := associator_naturality (modPowπ A X (a + 1)) (𝟙 A) + (headMod A X b) + rw [tensorHom_id, id_tensorHom] at hnat + exact hnat.symm + have hLegN : (α_ (modPow A X (a + 1)) A + (modPow A X (b + 1))).hom ≫ + (modPow A X (a + 1) ◁ modPowAct A X b) = + modTensorLegN A (modPowMod A X a) (modPowMod A X b) := rfl + set w₁ := (tensorPow D X a ◁ + ((α_ X A X).hom ≫ (X ◁ actLeft A X))) ▷ tensorPow D X b + with hw₁ + set w₂ := (α_ (tensorPow D X a) X X).inv ▷ tensorPow D X b + with hw₂ + set cc := (tensorPowConcat X (a + 2) b).hom with hcc + set ci := (tensorPowConcat X (a + 1) (b + 1)).inv with hci + set pd := powDetach X (a + 1) b with hpd + set pl := tensorPow D X (a + 1) ◁ (powPeel X b).inv with hpl + set ππ := modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1) with hππ + set mT := modTensorπ A (modPowMod A X a) (modPowMod A X b) + with hmT + set σ₁ := (α_ (tensorPow D X a) ((X ⊗ A) ⊗ X) + (tensorPow D X b)).hom with hσ₁ + set σ₂ := tensorPow D X a ◁ + (α_ (X ⊗ A) X (tensorPow D X b)).hom with hσ₂ + set σ₃ := (α_ (tensorPow D X a) (X ⊗ A) + (X ⊗ tensorPow D X b)).inv with hσ₃ + set bA := boundAssoc A X a ▷ (X ⊗ tensorPow D X b) with hbA + set σ₅ := (α_ (tensorPow D X (a + 1)) A + (X ⊗ tensorPow D X b)).hom with hσ₅ + set wv := tensorPow D X (a + 1) ◁ + ((α_ A X (tensorPow D X b)).inv ≫ + (actLeft A X ▷ tensorPow D X b)) with hwv + set tH := (modPowπ A X (a + 1) ▷ A) ⊗ₘ headMod A X b with htH + set wq := modPow A X (a + 1) ◁ modPowAct A X b with hwq + set aₘ := (α_ (modPow A X (a + 1)) A + (modPow A X (b + 1))).hom with haₘ + set cs := powCast X + (by omega : a + 2 + b = a + 1 + (b + 1)) with hcs + have E1 : cc ≫ (cs ≫ (ci ≫ (ππ ≫ mT))) = + pd ≫ (pl ≫ (ππ ≫ mT)) := + (reassoc_of% hsplit) (ππ ≫ mT) + have E2 : σ₅ ≫ (wv ≫ (pl ≫ (ππ ≫ mT))) = + tH ≫ (modTensorLegN A (modPowMod A X a) (modPowMod A X b) ≫ + mT) := by + calc σ₅ ≫ (wv ≫ (pl ≫ (ππ ≫ mT))) + = σ₅ ≫ (wv ≫ ((pl ≫ ππ) ≫ mT)) := + congrArg (fun z => σ₅ ≫ (wv ≫ z)) + (Category.assoc pl ππ mT).symm + _ = σ₅ ≫ (wv ≫ ((modPowπ A X (a + 1) ⊗ₘ headMod A X b) ≫ + mT)) := + congrArg (fun z => σ₅ ≫ (wv ≫ (z ≫ mT))) sub1 + _ = σ₅ ≫ ((wv ≫ (modPowπ A X (a + 1) ⊗ₘ headMod A X b)) ≫ + mT) := + congrArg (fun z => σ₅ ≫ z) (Category.assoc wv _ mT).symm + _ = σ₅ ≫ ((modPowπ A X (a + 1) ⊗ₘ + (((α_ A X (tensorPow D X b)).inv ≫ + (actLeft A X ▷ tensorPow D X b)) ≫ + headMod A X b)) ≫ mT) := + congrArg (fun z => σ₅ ≫ (z ≫ mT)) n2 + _ = σ₅ ≫ ((modPowπ A X (a + 1) ⊗ₘ + ((A ◁ headMod A X b) ≫ modPowAct A X b)) ≫ mT) := + congrArg (fun z => σ₅ ≫ + ((modPowπ A X (a + 1) ⊗ₘ z) ≫ mT)) n3 + _ = σ₅ ≫ (((modPowπ A X (a + 1) ⊗ₘ + (A ◁ headMod A X b)) ≫ wq) ≫ mT) := + congrArg (fun z => σ₅ ≫ (z ≫ mT)) n4 + _ = σ₅ ≫ ((modPowπ A X (a + 1) ⊗ₘ + (A ◁ headMod A X b)) ≫ (wq ≫ mT)) := + congrArg (fun z => σ₅ ≫ z) + (Category.assoc _ wq mT) + _ = (σ₅ ≫ (modPowπ A X (a + 1) ⊗ₘ + (A ◁ headMod A X b))) ≫ (wq ≫ mT) := + (Category.assoc σ₅ _ (wq ≫ mT)).symm + _ = (tH ≫ aₘ) ≫ (wq ≫ mT) := + congrArg (· ≫ (wq ≫ mT)) n5 + _ = tH ≫ (aₘ ≫ (wq ≫ mT)) := + Category.assoc tH aₘ (wq ≫ mT) + _ = tH ≫ ((aₘ ≫ wq) ≫ mT) := + congrArg (fun z => tH ≫ z) + (Category.assoc aₘ wq mT).symm + _ = tH ≫ (modTensorLegN A (modPowMod A X a) + (modPowMod A X b) ≫ mT) := + congrArg (fun z => tH ≫ (z ≫ mT)) hLegN + calc modPowLegN A X a b ≫ (cs ≫ (ci ≫ (ππ ≫ mT))) + = (w₁ ≫ (w₂ ≫ cc)) ≫ (cs ≫ (ci ≫ (ππ ≫ mT))) := rfl + _ = w₁ ≫ ((w₂ ≫ cc) ≫ (cs ≫ (ci ≫ (ππ ≫ mT)))) := + Category.assoc w₁ (w₂ ≫ cc) _ + _ = w₁ ≫ (w₂ ≫ (cc ≫ (cs ≫ (ci ≫ (ππ ≫ mT))))) := + congrArg (fun z => w₁ ≫ z) (Category.assoc w₂ cc _) + _ = w₁ ≫ (w₂ ≫ (pd ≫ (pl ≫ (ππ ≫ mT)))) := + congrArg (fun z => w₁ ≫ (w₂ ≫ z)) E1 + _ = w₁ ≫ ((w₂ ≫ pd) ≫ (pl ≫ (ππ ≫ mT))) := + congrArg (fun z => w₁ ≫ z) + (Category.assoc w₂ pd _).symm + _ = (w₁ ≫ (w₂ ≫ pd)) ≫ (pl ≫ (ππ ≫ mT)) := + (Category.assoc w₁ (w₂ ≫ pd) _).symm + _ = (σ₁ ≫ (σ₂ ≫ (σ₃ ≫ (bA ≫ (σ₅ ≫ wv))))) ≫ + (pl ≫ (ππ ≫ mT)) := + congrArg (· ≫ (pl ≫ (ππ ≫ mT))) hN + _ = σ₁ ≫ ((σ₂ ≫ (σ₃ ≫ (bA ≫ (σ₅ ≫ wv)))) ≫ + (pl ≫ (ππ ≫ mT))) := + Category.assoc σ₁ _ _ + _ = σ₁ ≫ (σ₂ ≫ ((σ₃ ≫ (bA ≫ (σ₅ ≫ wv))) ≫ + (pl ≫ (ππ ≫ mT)))) := + congrArg (fun z => σ₁ ≫ z) (Category.assoc σ₂ _ _) + _ = σ₁ ≫ (σ₂ ≫ (σ₃ ≫ ((bA ≫ (σ₅ ≫ wv)) ≫ + (pl ≫ (ππ ≫ mT))))) := + congrArg (fun z => σ₁ ≫ (σ₂ ≫ z)) + (Category.assoc σ₃ _ _) + _ = σ₁ ≫ (σ₂ ≫ (σ₃ ≫ (bA ≫ ((σ₅ ≫ wv) ≫ + (pl ≫ (ππ ≫ mT)))))) := + congrArg (fun z => σ₁ ≫ (σ₂ ≫ (σ₃ ≫ z))) + (Category.assoc bA _ _) + _ = σ₁ ≫ (σ₂ ≫ (σ₃ ≫ (bA ≫ (σ₅ ≫ (wv ≫ + (pl ≫ (ππ ≫ mT))))))) := + congrArg (fun z => σ₁ ≫ (σ₂ ≫ (σ₃ ≫ (bA ≫ z)))) + (Category.assoc σ₅ wv _) + _ = σ₁ ≫ (σ₂ ≫ (σ₃ ≫ (bA ≫ (tH ≫ + (modTensorLegN A (modPowMod A X a) (modPowMod A X b) ≫ + mT))))) := + congrArg (fun z => σ₁ ≫ (σ₂ ≫ (σ₃ ≫ (bA ≫ z)))) E2 + _ = σ₁ ≫ (σ₂ ≫ (σ₃ ≫ ((bA ≫ tH) ≫ + (modTensorLegN A (modPowMod A X a) (modPowMod A X b) ≫ + mT)))) := + congrArg (fun z => σ₁ ≫ (σ₂ ≫ (σ₃ ≫ z))) + (Category.assoc bA tH _).symm + _ = σ₁ ≫ (σ₂ ≫ ((σ₃ ≫ (bA ≫ tH)) ≫ + (modTensorLegN A (modPowMod A X a) (modPowMod A X b) ≫ + mT))) := + congrArg (fun z => σ₁ ≫ (σ₂ ≫ z)) + (Category.assoc σ₃ (bA ≫ tH) _).symm + _ = σ₁ ≫ ((σ₂ ≫ (σ₃ ≫ (bA ≫ tH))) ≫ + (modTensorLegN A (modPowMod A X a) (modPowMod A X b) ≫ + mT)) := + congrArg (fun z => σ₁ ≫ z) + (Category.assoc σ₂ (σ₃ ≫ (bA ≫ tH)) _).symm + _ = (σ₁ ≫ (σ₂ ≫ (σ₃ ≫ (bA ≫ tH)))) ≫ + (modTensorLegN A (modPowMod A X a) (modPowMod A X b) ≫ + mT) := + (Category.assoc σ₁ _ _).symm + _ = boundBridge A X a b ≫ + (modTensorLegN A (modPowMod A X a) (modPowMod A X b) ≫ + mT) := rfl + +/-- **The boundary slot condition**: the slot relation straddling +the two halves is absorbed by the split, through the coequalizer +relation of the module tensor product. -/ +theorem powSplit_cond_bound + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (a b : ℕ) : + modPowLegM A X a b ≫ + powCast X (by omega : a + 2 + b = a + 1 + (b + 1)) ≫ + (tensorPowConcat X (a + 1) (b + 1)).inv ≫ + (modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + modTensorπ A (modPowMod A X a) (modPowMod A X b) = + modPowLegN A X a b ≫ + powCast X (by omega : a + 2 + b = a + 1 + (b + 1)) ≫ + (tensorPowConcat X (a + 1) (b + 1)).inv ≫ + (modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + modTensorπ A (modPowMod A X a) (modPowMod A X b) := + (boundBridge_legM A X a b).trans + ((congrArg (fun z => boundBridge A X a b ≫ z) + (modTensor_condition A (modPowMod A X a) + (modPowMod A X b))).trans + (boundBridge_legN A X a b).symm) + +end Boundary + +/-! ## The interior slots + +A slot relation lying inside one half of the split embeds across +the concatenation into that half and is absorbed by the half's own +projection. +-/ + +section Interior + +/-- The bridge of `midConcatFst`, as an isomorphism. -/ +noncomputable def midConcatFstIso + [Category.{v} D] [MonoidalCategory D] (A : D) (X : D) + (s t n : ℕ) : + modPowMid A X s t ⊗ tensorPow D X n ≅ + modPowMid A X s (t + n) := + α_ (tensorPow D X s ⊗ ((X ⊗ A) ⊗ X)) (tensorPow D X t) + (tensorPow D X n) ≪≫ + whiskerLeftIso (tensorPow D X s ⊗ ((X ⊗ A) ⊗ X)) + (tensorPowConcat X t n) + +/-- The bridge of `midConcatSnd`, as an isomorphism. -/ +noncomputable def midConcatSndIso + [Category.{v} D] [MonoidalCategory D] (A : D) (X : D) + (m s t : ℕ) : + tensorPow D X m ⊗ modPowMid A X s t ≅ + modPowMid A X (m + s) t := + (α_ (tensorPow D X m) + (tensorPow D X s ⊗ ((X ⊗ A) ⊗ X)) (tensorPow D X t)).symm ≪≫ + whiskerRightIso + ((α_ (tensorPow D X m) (tensorPow D X s) + ((X ⊗ A) ⊗ X)).symm ≪≫ + whiskerRightIso (tensorPowConcat X m s) ((X ⊗ A) ⊗ X)) + (tensorPow D X t) + +/-- **The in-left slot condition**: a slot relation of the left +half is absorbed by the left projection. -/ +theorem powSplit_cond_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (a b s t' : ℕ) (hL : s + 2 + t' = a + 1) : + modPowLegM A X s (t' + (b + 1)) ≫ + powCast X + (by omega : s + 2 + (t' + (b + 1)) = a + 1 + (b + 1)) ≫ + (tensorPowConcat X (a + 1) (b + 1)).inv ≫ + (modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + modTensorπ A (modPowMod A X a) (modPowMod A X b) = + modPowLegN A X s (t' + (b + 1)) ≫ + powCast X + (by omega : s + 2 + (t' + (b + 1)) = a + 1 + (b + 1)) ≫ + (tensorPowConcat X (a + 1) (b + 1)).inv ≫ + (modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + modTensorπ A (modPowMod A X a) (modPowMod A X b) := by + have hwrc := powCast_whiskerRight_concat X hL (b + 1) + have hc2 : (tensorPowConcat X (s + 2 + t') (b + 1)).hom ≫ + powCast X + (by omega : s + 2 + t' + (b + 1) = a + 1 + (b + 1)) ≫ + (tensorPowConcat X (a + 1) (b + 1)).inv = + powCast X hL ▷ tensorPow D X (b + 1) := by + rw [← reassoc_of% hwrc, Iso.hom_inv_id, Category.comp_id] + set ci := (tensorPowConcat X (a + 1) (b + 1)).inv with hci + set ππ := modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1) with hππ + set mT := modTensorπ A (modPowMod A X a) (modPowMod A X b) + with hmT + have key : ∀ w : (X ⊗ A) ⊗ X ⟶ X ⊗ X, + midConcatFst A X s t' (b + 1) ≫ + ((((tensorPow D X s ◁ w) ▷ tensorPow D X (t' + (b + 1))) ≫ + modPowGlue X s (t' + (b + 1))) ≫ + (powCast X (by omega : + s + 2 + (t' + (b + 1)) = a + 1 + (b + 1)) ≫ + (ci ≫ (ππ ≫ mT)))) = + (((((tensorPow D X s ◁ w) ▷ tensorPow D X t') ≫ + modPowGlue X s t') ≫ + (powCast X hL ≫ modPowπ A X (a + 1))) ⊗ₘ + modPowπ A X (b + 1)) ≫ mT := by + intro w + have hM1 := modPowLeg_concat_fst A X s t' (b + 1) w + have hT : powCast X (by omega : + s + 2 + (t' + (b + 1)) = a + 1 + (b + 1)) ≫ + (ci ≫ (ππ ≫ mT)) = + powCast X (by omega : s + 2 + (t' + (b + 1)) = + s + 2 + t' + (b + 1)) ≫ + (powCast X (by omega : s + 2 + t' + (b + 1) = + a + 1 + (b + 1)) ≫ + (ci ≫ (ππ ≫ mT))) := + (powCast_comp_assoc X _ _ _).symm + calc midConcatFst A X s t' (b + 1) ≫ + ((((tensorPow D X s ◁ w) ▷ tensorPow D X (t' + (b + 1))) ≫ + modPowGlue X s (t' + (b + 1))) ≫ + (powCast X (by omega : + s + 2 + (t' + (b + 1)) = a + 1 + (b + 1)) ≫ + (ci ≫ (ππ ≫ mT)))) + = midConcatFst A X s t' (b + 1) ≫ + (((tensorPow D X s ◁ w) ▷ + tensorPow D X (t' + (b + 1))) ≫ + (modPowGlue X s (t' + (b + 1)) ≫ + (powCast X (by omega : s + 2 + (t' + (b + 1)) = + s + 2 + t' + (b + 1)) ≫ + (powCast X (by omega : s + 2 + t' + (b + 1) = + a + 1 + (b + 1)) ≫ + (ci ≫ (ππ ≫ mT)))))) := by + exact congrArg (fun z => midConcatFst A X s t' (b + 1) ≫ z) + ((congrArg (fun z => + (((tensorPow D X s ◁ w) ▷ + tensorPow D X (t' + (b + 1))) ≫ + modPowGlue X s (t' + (b + 1))) ≫ z) hT).trans + (Category.assoc _ _ _)) + _ = (((tensorPow D X s ◁ w) ▷ tensorPow D X t') ≫ + modPowGlue X s t') ▷ tensorPow D X (b + 1) ≫ + ((tensorPowConcat X (s + 2 + t') (b + 1)).hom ≫ + (powCast X (by omega : s + 2 + t' + (b + 1) = + a + 1 + (b + 1)) ≫ + (ci ≫ (ππ ≫ mT)))) := + ((reassoc_of% hM1) + (powCast X (by omega : s + 2 + t' + (b + 1) = + a + 1 + (b + 1)) ≫ + (ci ≫ (ππ ≫ mT)))).symm + _ = (((tensorPow D X s ◁ w) ▷ tensorPow D X t') ≫ + modPowGlue X s t') ▷ tensorPow D X (b + 1) ≫ + ((powCast X hL ▷ tensorPow D X (b + 1)) ≫ + (ππ ≫ mT)) := + congrArg (fun z => + (((tensorPow D X s ◁ w) ▷ tensorPow D X t') ≫ + modPowGlue X s t') ▷ tensorPow D X (b + 1) ≫ z) + ((reassoc_of% hc2) (ππ ≫ mT)) + _ = (((tensorPow D X s ◁ w) ▷ tensorPow D X t') ≫ + modPowGlue X s t') ▷ tensorPow D X (b + 1) ≫ + (((powCast X hL ≫ modPowπ A X (a + 1)) ⊗ₘ + modPowπ A X (b + 1)) ≫ mT) := + congrArg (fun z => + (((tensorPow D X s ◁ w) ▷ tensorPow D X t') ≫ + modPowGlue X s t') ▷ tensorPow D X (b + 1) ≫ z) + ((Category.assoc _ ππ mT).symm.trans + (congrArg (· ≫ mT) + (whiskerRight_tensorHom (powCast X hL) + (modPowπ A X (a + 1)) (modPowπ A X (b + 1))))) + _ = ((((((tensorPow D X s ◁ w) ▷ tensorPow D X t') ≫ + modPowGlue X s t') ≫ + (powCast X hL ≫ modPowπ A X (a + 1))) ⊗ₘ + modPowπ A X (b + 1)) ≫ mT) := + ((Category.assoc _ _ mT).symm.trans + (congrArg (· ≫ mT) + (whiskerRight_tensorHom _ + (powCast X hL ≫ modPowπ A X (a + 1)) + (modPowπ A X (b + 1))))) + refine (Iso.cancel_iso_hom_left + (midConcatFstIso A X s t' (b + 1)) _ _).mp ?_ + refine (key (winLegM A X)).trans + (Eq.trans ?_ (key (winLegN A X)).symm) + exact congrArg + (fun z => (z ⊗ₘ modPowπ A X (b + 1)) ≫ mT) + (modPow_rel A X s t' hL) + +/-- **The in-right slot condition**: a slot relation of the right +half is absorbed by the right projection. -/ +theorem powSplit_cond_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (a b s' t : ℕ) + (hR : s' + 2 + t = b + 1) : + modPowLegM A X (a + 1 + s') t ≫ + powCast X + (by omega : a + 1 + s' + 2 + t = a + 1 + (b + 1)) ≫ + (tensorPowConcat X (a + 1) (b + 1)).inv ≫ + (modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + modTensorπ A (modPowMod A X a) (modPowMod A X b) = + modPowLegN A X (a + 1 + s') t ≫ + powCast X + (by omega : a + 1 + s' + 2 + t = a + 1 + (b + 1)) ≫ + (tensorPowConcat X (a + 1) (b + 1)).inv ≫ + (modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + modTensorπ A (modPowMod A X a) (modPowMod A X b) := by + have hwlc := powCast_whiskerLeft_concat X (a + 1) hR + have hc2 : (tensorPowConcat X (a + 1) (s' + 2 + t)).hom ≫ + powCast X + (by omega : a + 1 + (s' + 2 + t) = a + 1 + (b + 1)) ≫ + (tensorPowConcat X (a + 1) (b + 1)).inv = + tensorPow D X (a + 1) ◁ powCast X hR := by + rw [← reassoc_of% hwlc, Iso.hom_inv_id, Category.comp_id] + set ci := (tensorPowConcat X (a + 1) (b + 1)).inv with hci + set ππ := modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1) with hππ + set mT := modTensorπ A (modPowMod A X a) (modPowMod A X b) + with hmT + have key : ∀ w : (X ⊗ A) ⊗ X ⟶ X ⊗ X, + midConcatSnd A X (a + 1) s' t ≫ + ((((tensorPow D X (a + 1 + s') ◁ w) ▷ tensorPow D X t) ≫ + modPowGlue X (a + 1 + s') t) ≫ + (powCast X (by omega : + a + 1 + s' + 2 + t = a + 1 + (b + 1)) ≫ + (ci ≫ (ππ ≫ mT)))) = + (modPowπ A X (a + 1) ⊗ₘ + ((((tensorPow D X s' ◁ w) ▷ tensorPow D X t) ≫ + modPowGlue X s' t) ≫ + (powCast X hR ≫ modPowπ A X (b + 1)))) ≫ mT := by + intro w + have hM1 := modPowLeg_concat_snd A X (a + 1) s' t w + have hT : powCast X (by omega : + a + 1 + s' + 2 + t = a + 1 + (b + 1)) ≫ + (ci ≫ (ππ ≫ mT)) = + powCast X (by omega : a + 1 + s' + 2 + t = + a + 1 + (s' + 2 + t)) ≫ + (powCast X (by omega : a + 1 + (s' + 2 + t) = + a + 1 + (b + 1)) ≫ + (ci ≫ (ππ ≫ mT))) := + (powCast_comp_assoc X _ _ _).symm + calc midConcatSnd A X (a + 1) s' t ≫ + ((((tensorPow D X (a + 1 + s') ◁ w) ▷ tensorPow D X t) ≫ + modPowGlue X (a + 1 + s') t) ≫ + (powCast X (by omega : + a + 1 + s' + 2 + t = a + 1 + (b + 1)) ≫ + (ci ≫ (ππ ≫ mT)))) + = midConcatSnd A X (a + 1) s' t ≫ + (((tensorPow D X (a + 1 + s') ◁ w) ▷ + tensorPow D X t) ≫ + (modPowGlue X (a + 1 + s') t ≫ + (powCast X (by omega : a + 1 + s' + 2 + t = + a + 1 + (s' + 2 + t)) ≫ + (powCast X (by omega : a + 1 + (s' + 2 + t) = + a + 1 + (b + 1)) ≫ + (ci ≫ (ππ ≫ mT)))))) := by + exact congrArg + (fun z => midConcatSnd A X (a + 1) s' t ≫ z) + ((congrArg (fun z => + (((tensorPow D X (a + 1 + s') ◁ w) ▷ + tensorPow D X t) ≫ + modPowGlue X (a + 1 + s') t) ≫ z) hT).trans + (Category.assoc _ _ _)) + _ = (tensorPow D X (a + 1) ◁ + ((((tensorPow D X s' ◁ w) ▷ tensorPow D X t) ≫ + modPowGlue X s' t))) ≫ + ((tensorPowConcat X (a + 1) (s' + 2 + t)).hom ≫ + (powCast X (by omega : a + 1 + (s' + 2 + t) = + a + 1 + (b + 1)) ≫ + (ci ≫ (ππ ≫ mT)))) := + ((reassoc_of% hM1) + (powCast X (by omega : a + 1 + (s' + 2 + t) = + a + 1 + (b + 1)) ≫ + (ci ≫ (ππ ≫ mT)))).symm + _ = (tensorPow D X (a + 1) ◁ + ((((tensorPow D X s' ◁ w) ▷ tensorPow D X t) ≫ + modPowGlue X s' t))) ≫ + ((tensorPow D X (a + 1) ◁ powCast X hR) ≫ + (ππ ≫ mT)) := + congrArg (fun z => + (tensorPow D X (a + 1) ◁ + ((((tensorPow D X s' ◁ w) ▷ tensorPow D X t) ≫ + modPowGlue X s' t))) ≫ z) + ((reassoc_of% hc2) (ππ ≫ mT)) + _ = (tensorPow D X (a + 1) ◁ + ((((tensorPow D X s' ◁ w) ▷ tensorPow D X t) ≫ + modPowGlue X s' t))) ≫ + ((modPowπ A X (a + 1) ⊗ₘ + (powCast X hR ≫ modPowπ A X (b + 1))) ≫ mT) := + congrArg (fun z => + (tensorPow D X (a + 1) ◁ + ((((tensorPow D X s' ◁ w) ▷ tensorPow D X t) ≫ + modPowGlue X s' t))) ≫ z) + ((Category.assoc _ ππ mT).symm.trans + (congrArg (· ≫ mT) + (whiskerLeft_comp_tensorHom (powCast X hR) + (modPowπ A X (a + 1)) (modPowπ A X (b + 1))))) + _ = (modPowπ A X (a + 1) ⊗ₘ + ((((tensorPow D X s' ◁ w) ▷ tensorPow D X t) ≫ + modPowGlue X s' t) ≫ + (powCast X hR ≫ modPowπ A X (b + 1)))) ≫ mT := + ((Category.assoc _ _ mT).symm.trans + (congrArg (· ≫ mT) + (whiskerLeft_comp_tensorHom _ + (modPowπ A X (a + 1)) + (powCast X hR ≫ modPowπ A X (b + 1))))) + refine (Iso.cancel_iso_hom_left + (midConcatSndIso A X (a + 1) s' t) _ _).mp ?_ + refine (key (winLegM A X)).trans + (Eq.trans ?_ (key (winLegN A X)).symm) + exact congrArg + (fun z => (modPowπ A X (a + 1) ⊗ₘ z) ≫ mT) + (modPow_rel A X s' t hR) + +end Interior + +/-! ## The split and the merge isomorphism -/ + +section Merge + +/-- **The wide-coequalizer condition of the split**: every slot +relation of the big power is absorbed by the split — inside the +left half, at the boundary, or inside the right half. -/ +theorem powSplit_cond + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (a b : ℕ) : + ∀ s t (hst : s + 2 + t = a + 1 + b + 1), + modPowLegM A X s t ≫ powCast X hst ≫ + ((tensorPowConcat X (a + 1) (b + 1)).inv ≫ + (modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + modTensorπ A (modPowMod A X a) (modPowMod A X b)) = + modPowLegN A X s t ≫ powCast X hst ≫ + ((tensorPowConcat X (a + 1) (b + 1)).inv ≫ + (modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + modTensorπ A (modPowMod A X a) (modPowMod A X b)) := by + intro s t hst + rcases Nat.lt_trichotomy s a with h | h | h + · obtain ⟨t', rfl⟩ : ∃ t', t = t' + (b + 1) := + ⟨t - (b + 1), by omega⟩ + exact powSplit_cond_left A X a b s t' (by omega) + · subst h + obtain rfl : b = t := by omega + exact powSplit_cond_bound A X s b + · obtain ⟨s', rfl⟩ : ∃ s', s = a + 1 + s' := + ⟨s - (a + 1), by omega⟩ + exact powSplit_cond_right A X a b s' t (by omega) + +/-- **The split of a module power**: the inverse of the +concatenation descends through the wide coequalizer onto the +module tensor product of the two halves. -/ +noncomputable def powSplit + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (a b : ℕ) : + modPow A X (a + 1 + b + 1) ⟶ + modTensor A (modPowMod A X a) (modPowMod A X b) := + modPowDesc A X + ((tensorPowConcat X (a + 1) (b + 1)).inv ≫ + (modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + modTensorπ A (modPowMod A X a) (modPowMod A X b)) + (powSplit_cond A X a b) + +/-- Defining equation of the split. -/ +@[reassoc (attr := simp)] +theorem modPowπ_powSplit + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (a b : ℕ) : + modPowπ A X (a + 1 + b + 1) ≫ powSplit A X a b = + (tensorPowConcat X (a + 1) (b + 1)).inv ≫ + (modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + modTensorπ A (modPowMod A X a) (modPowMod A X b) := + modPowπ_desc A X _ _ + +/-- The split is a section of the descended power +multiplication. -/ +@[reassoc (attr := simp)] +theorem powSplit_powMulDesc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (a b : ℕ) : + powSplit A X a b ≫ powMulDesc A X a b = + 𝟙 (modPow A X (a + 1 + b + 1)) := by + apply modPow_hom_ext A X + calc modPowπ A X (a + 1 + b + 1) ≫ + (powSplit A X a b ≫ powMulDesc A X a b) + = (modPowπ A X (a + 1 + b + 1) ≫ powSplit A X a b) ≫ + powMulDesc A X a b := (Category.assoc _ _ _).symm + _ = ((tensorPowConcat X (a + 1) (b + 1)).inv ≫ + (modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + modTensorπ A (modPowMod A X a) (modPowMod A X b)) ≫ + powMulDesc A X a b := + congrArg (· ≫ powMulDesc A X a b) + (modPowπ_powSplit A X a b) + _ = (tensorPowConcat X (a + 1) (b + 1)).inv ≫ + (((modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + modTensorπ A (modPowMod A X a) (modPowMod A X b)) ≫ + powMulDesc A X a b) := Category.assoc _ _ _ + _ = (tensorPowConcat X (a + 1) (b + 1)).inv ≫ + ((modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + (modTensorπ A (modPowMod A X a) (modPowMod A X b) ≫ + powMulDesc A X a b)) := + congrArg + (fun z => (tensorPowConcat X (a + 1) (b + 1)).inv ≫ z) + (Category.assoc _ _ _) + _ = (tensorPowConcat X (a + 1) (b + 1)).inv ≫ + ((modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + modPowMul A X (a + 1) (b + 1)) := + congrArg + (fun z => (tensorPowConcat X (a + 1) (b + 1)).inv ≫ + ((modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ z)) + (modTensorπ_powMulDesc A X a b) + _ = (tensorPowConcat X (a + 1) (b + 1)).inv ≫ + ((tensorPowConcat X (a + 1) (b + 1)).hom ≫ + modPowπ A X (a + 1 + (b + 1))) := + congrArg + (fun z => (tensorPowConcat X (a + 1) (b + 1)).inv ≫ z) + (modPowπ_tensor_modPowMul A X (a + 1) (b + 1)) + _ = modPowπ A X (a + 1 + (b + 1)) := + Iso.inv_hom_id_assoc (tensorPowConcat X (a + 1) (b + 1)) _ + _ = modPowπ A X (a + 1 + b + 1) ≫ + 𝟙 (modPow A X (a + 1 + b + 1)) := + (Category.comp_id (modPowπ A X (a + 1 + b + 1))).symm + +/-- The split is a retraction of the descended power +multiplication. -/ +@[reassoc (attr := simp)] +theorem powMulDesc_powSplit + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (a b : ℕ) : + powMulDesc A X a b ≫ powSplit A X a b = + 𝟙 (modTensor A (modPowMod A X a) (modPowMod A X b)) := by + apply modTensor_hom_ext A (modPowMod A X a) (modPowMod A X b) + apply modPowTensor_hom_ext A X (a + 1) (b + 1) + have hs : modPowπ A X (a + 1 + (b + 1)) ≫ powSplit A X a b = + (tensorPowConcat X (a + 1) (b + 1)).inv ≫ + ((modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + modTensorπ A (modPowMod A X a) (modPowMod A X b)) := + modPowπ_powSplit A X a b + calc (modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + (modTensorπ A (modPowMod A X a) (modPowMod A X b) ≫ + (powMulDesc A X a b ≫ powSplit A X a b)) + = (modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + ((modTensorπ A (modPowMod A X a) (modPowMod A X b) ≫ + powMulDesc A X a b) ≫ powSplit A X a b) := + congrArg + (fun z => (modPowπ A X (a + 1) ⊗ₘ + modPowπ A X (b + 1)) ≫ z) + (Category.assoc _ _ _).symm + _ = (modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + (modPowMul A X (a + 1) (b + 1) ≫ powSplit A X a b) := + congrArg + (fun z => (modPowπ A X (a + 1) ⊗ₘ + modPowπ A X (b + 1)) ≫ (z ≫ powSplit A X a b)) + (modTensorπ_powMulDesc A X a b) + _ = ((modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + modPowMul A X (a + 1) (b + 1)) ≫ powSplit A X a b := + (Category.assoc _ _ _).symm + _ = ((tensorPowConcat X (a + 1) (b + 1)).hom ≫ + modPowπ A X (a + 1 + (b + 1))) ≫ powSplit A X a b := + congrArg (· ≫ powSplit A X a b) + (modPowπ_tensor_modPowMul A X (a + 1) (b + 1)) + _ = (tensorPowConcat X (a + 1) (b + 1)).hom ≫ + (modPowπ A X (a + 1 + (b + 1)) ≫ powSplit A X a b) := + Category.assoc _ _ _ + _ = (tensorPowConcat X (a + 1) (b + 1)).hom ≫ + ((tensorPowConcat X (a + 1) (b + 1)).inv ≫ + ((modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + modTensorπ A (modPowMod A X a) (modPowMod A X b))) := + congrArg + (fun z => (tensorPowConcat X (a + 1) (b + 1)).hom ≫ z) + hs + _ = (modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + modTensorπ A (modPowMod A X a) (modPowMod A X b) := + Iso.hom_inv_id_assoc (tensorPowConcat X (a + 1) (b + 1)) _ + _ = (modPowπ A X (a + 1) ⊗ₘ modPowπ A X (b + 1)) ≫ + (modTensorπ A (modPowMod A X a) (modPowMod A X b) ≫ + 𝟙 (modTensor A (modPowMod A X a) (modPowMod A X b))) := + congrArg + (fun z => (modPowπ A X (a + 1) ⊗ₘ + modPowπ A X (b + 1)) ≫ z) + (Category.comp_id _).symm + +/-- **The merge isomorphism**: the relative tensor product of two +module powers is the module power of the summed arity, with the +descended power multiplication as the forward direction and the +split as its inverse. -/ +noncomputable def powMergeIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (a b : ℕ) : + modTensor A (modPowMod A X a) (modPowMod A X b) ≅ + modPow A X (a + 1 + b + 1) where + hom := powMulDesc A X a b + inv := powSplit A X a b + hom_inv_id := powMulDesc_powSplit A X a b + inv_hom_id := powSplit_powMulDesc A X a b + +end Merge + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairSucc.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairSucc.lean new file mode 100644 index 0000000000..8d485e54df --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairSucc.lean @@ -0,0 +1,736 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSucc + +/-! +# The pair side of the power step + +Deligne's 1.15 power induction, pair side: pushing the primed back +merge and the swapped unprimed front merge into the successor power +pairing yields the tensor pairing of the stage datum with the bottom +datum. The comparison is taken over the projection cover, where the +successor triangle core (`powDeltaCore_pairing`) supplies the +identity after a symmetric rearrangement of the four carriers; the +rearrangement itself is the retraction `tensorMu_braid_retract`, a +pure braid coherence. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +section Coherence + +/-- Interchanging the middle factors twice is the identity: the two +elementary crossings cancel by the symmetry axiom. -/ +@[reassoc] +private theorem tensorMu_symm_cancel + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (a b c d : D) : + tensorμ a b c d ≫ tensorμ a c b d = + 𝟙 ((a ⊗ b) ⊗ (c ⊗ d)) := by + calc + tensorμ a b c d ≫ tensorμ a c b d + = 𝟙 ((a ⊗ b) ⊗ (c ⊗ d)) ⊗≫ + a ◁ ((β_ b c).hom ≫ (β_ c b).hom) ▷ d ⊗≫ + 𝟙 ((a ⊗ b) ⊗ (c ⊗ d)) := by + dsimp only [tensorμ] + monoidal + _ = 𝟙 ((a ⊗ b) ⊗ (c ⊗ d)) := by + rw [SymmetricCategory.symmetry] + monoidal + +/-- **The braid retraction of the double interchange**: shuffling, +braiding slotwise, shuffling the braided blocks, and braiding the +block pair returns every strand to its place. -/ +@[reassoc] +private theorem tensorMu_braid_retract + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (W X Y Z : D) : + tensorμ W X Y Z ≫ ((β_ W Y).hom ⊗ₘ (β_ X Z).hom) ≫ + tensorμ Y W Z X ≫ (β_ (Y ⊗ Z) (W ⊗ X)).hom = + 𝟙 ((W ⊗ X) ⊗ (Y ⊗ Z)) := by + rw [← tensorμ_braiding_assoc W X Y Z, + tensorMu_symm_cancel_assoc] + exact SymmetricCategory.symmetry _ _ + +end Coherence + +section Fold + +/-- Evaluating the tensor-pairing word on a pure tensor of +projections: the interchange seats each dual half against its own +carrier, the coordinatewise pairings evaluate, and the fold +multiplies the two scalars. -/ +private theorem tensorHom_π_pairFold + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {N₁ : Mod D A} {N₂ : Mod D A} + {N₁' : Mod D A} {N₂' : Mod D A} + (d₁ : ModDualityDatum A N₁ N₁') + (d₂ : ModDualityDatum A N₂ N₂') : + ((modTensorπ A N₁' N₂' ⊗ₘ modTensorπ A N₁ N₂) : + (N₁'.X ⊗ N₂'.X) ⊗ (N₁.X ⊗ N₂.X) ⟶ _) ≫ + interchange A N₁' N₂' N₁ N₂ ≫ + modTensorMap A d₁.pairMod d₂.pairMod ≫ regPairFold A = + tensorμ N₁'.X N₂'.X N₁.X N₂.X ≫ + ((modTensorπ A N₁' N₁ ≫ d₁.pair) ⊗ₘ + (modTensorπ A N₂' N₂ ≫ d₂.pair)) ≫ μ[A] := by + have hfold : modTensorπ A (regularMod A) (regularMod A) ≫ + regPairFold A = μ[A] := by + rw [regPairFold] + exact modTensorπ_desc A _ _ _ _ + have hm : modTensorπ A (modTensorMod A N₁' N₁) + (modTensorMod A N₂' N₂) ≫ + modTensorMap A d₁.pairMod d₂.pairMod = + (d₁.pair ⊗ₘ d₂.pair) ≫ + modTensorπ A (regularMod A) (regularMod A) := + modTensorπ_map A d₁.pairMod d₂.pairMod + have htail : (modTensorπ A N₁' N₁ ⊗ₘ modTensorπ A N₂' N₂) ≫ + modTensorπ A (modTensorMod A N₁' N₁) + (modTensorMod A N₂' N₂) ≫ + modTensorMap A d₁.pairMod d₂.pairMod ≫ + regPairFold A = + ((modTensorπ A N₁' N₁ ≫ d₁.pair) ⊗ₘ + (modTensorπ A N₂' N₂ ≫ d₂.pair)) ≫ μ[A] := by + have t2 : modTensorπ A (modTensorMod A N₁' N₁) + (modTensorMod A N₂' N₂) ≫ + modTensorMap A d₁.pairMod d₂.pairMod ≫ + regPairFold A = + (d₁.pair ⊗ₘ d₂.pair) ≫ μ[A] := by + rw [← Category.assoc, hm] + exact (Category.assoc _ _ _).trans + (congrArg (fun t : (regularMod A).X ⊗ + (regularMod A).X ⟶ A => + (d₁.pair ⊗ₘ d₂.pair) ≫ t) hfold) + exact (congrArg (fun t : (modTensorMod A N₁' N₁).X ⊗ + (modTensorMod A N₂' N₂).X ⟶ A => + (modTensorπ A N₁' N₁ ⊗ₘ modTensorπ A N₂' N₂) ≫ t) + t2).trans (by + rw [← MonoidalCategory.tensorHom_comp_tensorHom_assoc]) + erw [← Category.assoc, tensorHom_π_interchange, rawInterchangeπ, rawInterchange] + conv_lhs => erw [Category.assoc]; arg 2; erw [Category.assoc] + simpa only [Category.assoc] using congrArg (fun t : (N₁'.X ⊗ N₁.X) ⊗ (N₂'.X ⊗ N₂.X) ⟶ + A => tensorμ N₁'.X N₂'.X N₁.X N₂.X ≫ t) htail + +end Fold + +private theorem modPowPairing_succ_tensor_leftCover + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (n : ℕ) : + (modTensorπ A (modPowMod A M.X n) + (modPowMod A M'.X n) ⊗ₘ + modTensorπ A (modPowMod A M.X 0) (modPowMod A M'.X 0)) ≫ + interchange A (modPowMod A M.X n) (modPowMod A M'.X n) + (modPowMod A M.X 0) (modPowMod A M'.X 0) ≫ + modTensorMap A + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)) + (powMulMod A M'.X n 0) ≫ + modTensorSwap A (modPowMod A M.X (n + 1)) + (modPowMod A M'.X (n + 1)) ≫ + modPowPairing A M M' d (n + 1) = + tensorμ (modPowMod A M.X n).X (modPowMod A M'.X n).X + (modPowMod A M.X 0).X (modPowMod A M'.X 0).X ≫ + ((modTensorπ A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)).hom) ⊗ₘ + (modTensorπ A (modPowMod A M'.X n) + (modPowMod A M'.X 0) ≫ + (powMulMod A M'.X n 0).hom)) ≫ + (β_ (modPowMod A M.X (n + 1)).X + (modPowMod A M'.X (n + 1)).X).hom ≫ + pairPow A M M' d (n + 2) := by + have hstep : modTensorπ A (modPowMod A M.X (n + 1)) + (modPowMod A M'.X (n + 1)) ≫ + modTensorSwap A (modPowMod A M.X (n + 1)) + (modPowMod A M'.X (n + 1)) ≫ + modPowPairing A M M' d (n + 1) = + (β_ (modPowMod A M.X (n + 1)).X + (modPowMod A M'.X (n + 1)).X).hom ≫ + pairPow A M M' d (n + 2) := by + rw [modTensorπ_swap_assoc, modTensorπ_modPowPairing] + -- The triangle core, evaluated on the projection cover: left. + have hL2 : (modTensorπ A (modPowMod A M.X n) + (modPowMod A M'.X n) ⊗ₘ + modTensorπ A (modPowMod A M.X 0) (modPowMod A M'.X 0)) ≫ + interchange A (modPowMod A M.X n) (modPowMod A M'.X n) + (modPowMod A M.X 0) (modPowMod A M'.X 0) ≫ + modTensorMap A + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)) + (powMulMod A M'.X n 0) ≫ + modTensorSwap A (modPowMod A M.X (n + 1)) + (modPowMod A M'.X (n + 1)) ≫ + modPowPairing A M M' d (n + 1) = + tensorμ (modPowMod A M.X n).X (modPowMod A M'.X n).X + (modPowMod A M.X 0).X (modPowMod A M'.X 0).X ≫ + ((modTensorπ A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)).hom) ⊗ₘ + (modTensorπ A (modPowMod A M'.X n) + (modPowMod A M'.X 0) ≫ + (powMulMod A M'.X n 0).hom)) ≫ + (β_ (modPowMod A M.X (n + 1)).X + (modPowMod A M'.X (n + 1)).X).hom ≫ + pairPow A M M' d (n + 2) := by + have hmap2 : modTensorπ A + (modTensorMod A (modPowMod A M.X n) (modPowMod A M.X 0)) + (modTensorMod A (modPowMod A M'.X n) + (modPowMod A M'.X 0)) ≫ + modTensorMap A + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)) + (powMulMod A M'.X n 0) ≫ + modTensorSwap A (modPowMod A M.X (n + 1)) + (modPowMod A M'.X (n + 1)) ≫ + modPowPairing A M M' d (n + 1) = + ((modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)).hom ⊗ₘ + (powMulMod A M'.X n 0).hom) ≫ + (β_ (modPowMod A M.X (n + 1)).X + (modPowMod A M'.X (n + 1)).X).hom ≫ + pairPow A M M' d (n + 2) := by + refine Eq.trans (modTensorπ_map_assoc A _ _ _) ?_ + exact congrArg (fun t : (modPowMod A M.X (n + 1)).X ⊗ + (modPowMod A M'.X (n + 1)).X ⟶ A => + ((modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)).hom ⊗ₘ + (powMulMod A M'.X n 0).hom) ≫ t) hstep + erw [tensorHom_π_interchange_assoc, rawInterchangeπ, rawInterchange] + simp only [Category.assoc] + conv_lhs => arg 2; erw [Category.assoc] + refine Eq.trans (congrArg (fun t : + (modTensorMod A (modPowMod A M.X n) + (modPowMod A M.X 0)).X ⊗ + (modTensorMod A (modPowMod A M'.X n) + (modPowMod A M'.X 0)).X ⟶ A => + tensorμ (modPowMod A M.X n).X (modPowMod A M'.X n).X + (modPowMod A M.X 0).X (modPowMod A M'.X 0).X ≫ + (modTensorπ A (modPowMod A M.X n) + (modPowMod A M.X 0) ⊗ₘ + modTensorπ A (modPowMod A M'.X n) + (modPowMod A M'.X 0)) ≫ t) hmap2) ?_ + refine congrArg (fun t : ((modPowMod A M.X n).X ⊗ + (modPowMod A M.X 0).X) ⊗ + ((modPowMod A M'.X n).X ⊗ + (modPowMod A M'.X 0).X) ⟶ A => + tensorμ (modPowMod A M.X n).X (modPowMod A M'.X n).X + (modPowMod A M.X 0).X (modPowMod A M'.X 0).X ≫ t) ?_ + exact MonoidalCategory.tensorHom_comp_tensorHom_assoc + _ _ _ _ _ + -- The triangle core, covered by the projections. + exact hL2 + +private theorem modPowPairing_succ_tensor_rightCover + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (n : ℕ) : + (modTensorπ A (modPowMod A M.X n) + (modPowMod A M'.X n) ⊗ₘ + modTensorπ A (modPowMod A M.X 0) (modPowMod A M'.X 0)) ≫ + ((modTensorSwap A (modPowMod A M.X n) + (modPowMod A M'.X n) ≫ + modPowPairing A M M' d n) ⊗ₘ + (modTensorSwap A (modPowMod A M.X 0) + (modPowMod A M'.X 0) ≫ + modPowPairing A M M' d 0)) ≫ μ[A] = + ((β_ (modPowMod A M.X n).X + (modPowMod A M'.X n).X).hom ⊗ₘ + (β_ (modPowMod A M.X 0).X + (modPowMod A M'.X 0).X).hom) ≫ + ((modTensorπ A (modPowMod A M'.X n) + (modPowMod A M.X n) ≫ + modPowPairing A M M' d n) ⊗ₘ + (modTensorπ A (modPowMod A M'.X 0) + (modPowMod A M.X 0) ≫ + modPowPairing A M M' d 0)) ≫ μ[A] := by + have hswn : modTensorπ A (modPowMod A M.X n) + (modPowMod A M'.X n) ≫ + modTensorSwap A (modPowMod A M.X n) (modPowMod A M'.X n) ≫ + modPowPairing A M M' d n = + (β_ (modPowMod A M.X n).X (modPowMod A M'.X n).X).hom ≫ + modTensorπ A (modPowMod A M'.X n) (modPowMod A M.X n) ≫ + modPowPairing A M M' d n := by + rw [modTensorπ_swap_assoc] + have hsw0 : modTensorπ A (modPowMod A M.X 0) + (modPowMod A M'.X 0) ≫ + modTensorSwap A (modPowMod A M.X 0) (modPowMod A M'.X 0) ≫ + modPowPairing A M M' d 0 = + (β_ (modPowMod A M.X 0).X (modPowMod A M'.X 0).X).hom ≫ + modTensorπ A (modPowMod A M'.X 0) (modPowMod A M.X 0) ≫ + modPowPairing A M M' d 0 := by + rw [modTensorπ_swap_assoc] + -- The triangle core, evaluated on the projection cover: right. + have hR2 : (modTensorπ A (modPowMod A M.X n) + (modPowMod A M'.X n) ⊗ₘ + modTensorπ A (modPowMod A M.X 0) (modPowMod A M'.X 0)) ≫ + ((modTensorSwap A (modPowMod A M.X n) + (modPowMod A M'.X n) ≫ + modPowPairing A M M' d n) ⊗ₘ + (modTensorSwap A (modPowMod A M.X 0) + (modPowMod A M'.X 0) ≫ + modPowPairing A M M' d 0)) ≫ μ[A] = + ((β_ (modPowMod A M.X n).X + (modPowMod A M'.X n).X).hom ⊗ₘ + (β_ (modPowMod A M.X 0).X + (modPowMod A M'.X 0).X).hom) ≫ + ((modTensorπ A (modPowMod A M'.X n) + (modPowMod A M.X n) ≫ + modPowPairing A M M' d n) ⊗ₘ + (modTensorπ A (modPowMod A M'.X 0) + (modPowMod A M.X 0) ≫ + modPowPairing A M M' d 0)) ≫ μ[A] := by + rw [MonoidalCategory.tensorHom_comp_tensorHom_assoc, hswn, + hsw0, ← MonoidalCategory.tensorHom_comp_tensorHom_assoc] + -- The core identity over the cover. + exact hR2 + +private theorem modPowPairing_succ_tensor_braidingRetract + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (n : ℕ) : + tensorμ (modPowMod A M'.X n).X + (modPowMod A M'.X 0).X (modPowMod A M.X n).X + (modPowMod A M.X 0).X ≫ + ((β_ (modPowMod A M'.X n).X + (modPowMod A M.X n).X).hom ⊗ₘ + (β_ (modPowMod A M'.X 0).X + (modPowMod A M.X 0).X).hom) ≫ + tensorμ (modPowMod A M.X n).X (modPowMod A M'.X n).X + (modPowMod A M.X 0).X (modPowMod A M'.X 0).X ≫ + ((modTensorπ A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)).hom) ⊗ₘ + (modTensorπ A (modPowMod A M'.X n) + (modPowMod A M'.X 0) ≫ + (powMulMod A M'.X n 0).hom)) ≫ + (β_ (modPowMod A M.X (n + 1)).X + (modPowMod A M'.X (n + 1)).X).hom ≫ + pairPow A M M' d (n + 2) = + ((modTensorπ A (modPowMod A M'.X n) + (modPowMod A M'.X 0) ≫ + (powMulMod A M'.X n 0).hom) ⊗ₘ + (modTensorπ A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)).hom)) ≫ + pairPow A M M' d (n + 2) := by + have hnat3 : ((modTensorπ A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)).hom) ⊗ₘ + (modTensorπ A (modPowMod A M'.X n) + (modPowMod A M'.X 0) ≫ + (powMulMod A M'.X n 0).hom)) ≫ + (β_ (modPowMod A M.X (n + 1)).X + (modPowMod A M'.X (n + 1)).X).hom ≫ + pairPow A M M' d (n + 2) = + (β_ ((modPowMod A M.X n).X ⊗ (modPowMod A M.X 0).X) + ((modPowMod A M'.X n).X ⊗ + (modPowMod A M'.X 0).X)).hom ≫ + ((modTensorπ A (modPowMod A M'.X n) + (modPowMod A M'.X 0) ≫ + (powMulMod A M'.X n 0).hom) ⊗ₘ + (modTensorπ A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)).hom)) ≫ + pairPow A M M' d (n + 2) := + BraidedCategory.braiding_naturality_assoc + (modTensorπ A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)).hom) + (modTensorπ A (modPowMod A M'.X n) + (modPowMod A M'.X 0) ≫ + (powMulMod A M'.X n 0).hom) + (pairPow A M M' d (n + 2)) + -- The rearrangement retracts onto the merged pair. + have hfinalL : tensorμ (modPowMod A M'.X n).X + (modPowMod A M'.X 0).X (modPowMod A M.X n).X + (modPowMod A M.X 0).X ≫ + ((β_ (modPowMod A M'.X n).X + (modPowMod A M.X n).X).hom ⊗ₘ + (β_ (modPowMod A M'.X 0).X + (modPowMod A M.X 0).X).hom) ≫ + tensorμ (modPowMod A M.X n).X (modPowMod A M'.X n).X + (modPowMod A M.X 0).X (modPowMod A M'.X 0).X ≫ + ((modTensorπ A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)).hom) ⊗ₘ + (modTensorπ A (modPowMod A M'.X n) + (modPowMod A M'.X 0) ≫ + (powMulMod A M'.X n 0).hom)) ≫ + (β_ (modPowMod A M.X (n + 1)).X + (modPowMod A M'.X (n + 1)).X).hom ≫ + pairPow A M M' d (n + 2) = + ((modTensorπ A (modPowMod A M'.X n) + (modPowMod A M'.X 0) ≫ + (powMulMod A M'.X n 0).hom) ⊗ₘ + (modTensorπ A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)).hom)) ≫ + pairPow A M M' d (n + 2) := by + refine Eq.trans (congrArg (fun t : + ((modPowMod A M.X n).X ⊗ (modPowMod A M.X 0).X) ⊗ + ((modPowMod A M'.X n).X ⊗ + (modPowMod A M'.X 0).X) ⟶ A => + tensorμ (modPowMod A M'.X n).X (modPowMod A M'.X 0).X + (modPowMod A M.X n).X (modPowMod A M.X 0).X ≫ + ((β_ (modPowMod A M'.X n).X + (modPowMod A M.X n).X).hom ⊗ₘ + (β_ (modPowMod A M'.X 0).X + (modPowMod A M.X 0).X).hom) ≫ + tensorμ (modPowMod A M.X n).X (modPowMod A M'.X n).X + (modPowMod A M.X 0).X (modPowMod A M'.X 0).X ≫ t) + hnat3) ?_ + exact tensorMu_braid_retract_assoc _ _ _ _ _ + -- The two block braidings cancel. + exact hfinalL + +private theorem modPowPairing_succ_tensor_braidingCancel + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (n : ℕ) : + ((β_ (modPowMod A M'.X n).X + (modPowMod A M.X n).X).hom ⊗ₘ + (β_ (modPowMod A M'.X 0).X + (modPowMod A M.X 0).X).hom) ≫ + ((β_ (modPowMod A M.X n).X + (modPowMod A M'.X n).X).hom ⊗ₘ + (β_ (modPowMod A M.X 0).X + (modPowMod A M'.X 0).X).hom) ≫ + ((modTensorπ A (modPowMod A M'.X n) + (modPowMod A M.X n) ≫ + modPowPairing A M M' d n) ⊗ₘ + (modTensorπ A (modPowMod A M'.X 0) + (modPowMod A M.X 0) ≫ + modPowPairing A M M' d 0)) ≫ μ[A] = + ((modTensorπ A (modPowMod A M'.X n) + (modPowMod A M.X n) ≫ + modPowPairing A M M' d n) ⊗ₘ + (modTensorπ A (modPowMod A M'.X 0) + (modPowMod A M.X 0) ≫ + modPowPairing A M M' d 0)) ≫ μ[A] := by + have hcancel : ((β_ (modPowMod A M'.X n).X + (modPowMod A M.X n).X).hom ⊗ₘ + (β_ (modPowMod A M'.X 0).X + (modPowMod A M.X 0).X).hom) ≫ + ((β_ (modPowMod A M.X n).X + (modPowMod A M'.X n).X).hom ⊗ₘ + (β_ (modPowMod A M.X 0).X + (modPowMod A M'.X 0).X).hom) = + 𝟙 (((modPowMod A M'.X n).X ⊗ (modPowMod A M.X n).X) ⊗ + ((modPowMod A M'.X 0).X ⊗ (modPowMod A M.X 0).X)) := by + rw [MonoidalCategory.tensorHom_comp_tensorHom, + SymmetricCategory.symmetry, SymmetricCategory.symmetry, + MonoidalCategory.id_tensorHom_id] + have htail : ((β_ (modPowMod A M'.X n).X + (modPowMod A M.X n).X).hom ⊗ₘ + (β_ (modPowMod A M'.X 0).X + (modPowMod A M.X 0).X).hom) ≫ + ((β_ (modPowMod A M.X n).X + (modPowMod A M'.X n).X).hom ⊗ₘ + (β_ (modPowMod A M.X 0).X + (modPowMod A M'.X 0).X).hom) ≫ + ((modTensorπ A (modPowMod A M'.X n) + (modPowMod A M.X n) ≫ + modPowPairing A M M' d n) ⊗ₘ + (modTensorπ A (modPowMod A M'.X 0) + (modPowMod A M.X 0) ≫ + modPowPairing A M M' d 0)) ≫ μ[A] = + ((modTensorπ A (modPowMod A M'.X n) + (modPowMod A M.X n) ≫ + modPowPairing A M M' d n) ⊗ₘ + (modTensorπ A (modPowMod A M'.X 0) + (modPowMod A M.X 0) ≫ + modPowPairing A M M' d 0)) ≫ μ[A] := by + rw [← Category.assoc, hcancel, Category.id_comp] + -- The merged pair equals the crossed coordinatewise pairing. + exact htail + +/-- **The pair side of the power step** (Deligne 1.15): pushing the +primed back merge and the swapped unprimed front merge into the +successor power pairing yields the tensor pairing of the stage +datum with the bottom datum. -/ +theorem modPowPairing_succ_tensor + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (n : ℕ) : + modTensorMap A + (powMulMod A M'.X n 0) + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)) ≫ + modPowPairing A M M' d (n + 1) = + tensorPair A (powDualityDatum A M M' d n) + (powDualityDatum A M M' d 0) := by + -- Left descent: the merged pairing against the big projection. + have hLdesc : modTensorπ A + (modTensorMod A (modPowMod A M'.X n) (modPowMod A M'.X 0)) + (modTensorMod A (modPowMod A M.X n) (modPowMod A M.X 0)) ≫ + modTensorMap A + (powMulMod A M'.X n 0) + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)) ≫ + modPowPairing A M M' d (n + 1) = + ((powMulMod A M'.X n 0).hom ⊗ₘ + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)).hom) ≫ + pairPow A M M' d (n + 2) := by + rw [modTensorπ_map_assoc] + exact congrArg (fun t : (modPowMod A M'.X (n + 1)).X ⊗ + (modPowMod A M.X (n + 1)).X ⟶ A => + ((powMulMod A M'.X n 0).hom ⊗ₘ + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)).hom) ≫ t) + (modTensorπ_modPowPairing A M M' d (n + 1)) + -- Fuse the covering projections into the merge carriers. + have hLfuse : (modTensorπ A (modPowMod A M'.X n) + (modPowMod A M'.X 0) ⊗ₘ + modTensorπ A (modPowMod A M.X n) (modPowMod A M.X 0)) ≫ + ((powMulMod A M'.X n 0).hom ⊗ₘ + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)).hom) ≫ + pairPow A M M' d (n + 2) = + ((modTensorπ A (modPowMod A M'.X n) + (modPowMod A M'.X 0) ≫ + (powMulMod A M'.X n 0).hom) ⊗ₘ + (modTensorπ A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)).hom)) ≫ + pairPow A M M' d (n + 2) := by + erw [← Category.assoc, + MonoidalCategory.tensorHom_comp_tensorHom] + -- The successor pairing against the swapped projection. + have hL2 := modPowPairing_succ_tensor_leftCover A M M' d n + have hcov := congrArg + (fun t : modTensor A (modPowMod A M.X n) + (modPowMod A M'.X n) ⊗ + modTensor A (modPowMod A M.X 0) + (modPowMod A M'.X 0) ⟶ A => + (modTensorπ A (modPowMod A M.X n) + (modPowMod A M'.X n) ⊗ₘ + modTensorπ A (modPowMod A M.X 0) + (modPowMod A M'.X 0)) ≫ t) + (powDeltaCore_pairing A M M' d n) + -- The stage pairings against the swapped projections. + have hR2 := modPowPairing_succ_tensor_rightCover A M M' d n + have hmeet := hL2.symm.trans (hcov.trans hR2) + -- Braid the merged pair across the successor braiding. + have hfinalL := modPowPairing_succ_tensor_braidingRetract A M M' d n + have htail := modPowPairing_succ_tensor_braidingCancel A M M' d n + have hfinal : ((modTensorπ A (modPowMod A M'.X n) + (modPowMod A M'.X 0) ≫ + (powMulMod A M'.X n 0).hom) ⊗ₘ + (modTensorπ A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)).hom)) ≫ + pairPow A M M' d (n + 2) = + tensorμ (modPowMod A M'.X n).X (modPowMod A M'.X 0).X + (modPowMod A M.X n).X (modPowMod A M.X 0).X ≫ + ((modTensorπ A (modPowMod A M'.X n) + (modPowMod A M.X n) ≫ + modPowPairing A M M' d n) ⊗ₘ + (modTensorπ A (modPowMod A M'.X 0) + (modPowMod A M.X 0) ≫ + modPowPairing A M M' d 0)) ≫ μ[A] := by + refine Eq.trans hfinalL.symm ?_ + refine Eq.trans (congrArg (fun t : + ((modPowMod A M.X n).X ⊗ (modPowMod A M'.X n).X) ⊗ + ((modPowMod A M.X 0).X ⊗ + (modPowMod A M'.X 0).X) ⟶ A => + tensorμ (modPowMod A M'.X n).X (modPowMod A M'.X 0).X + (modPowMod A M.X n).X (modPowMod A M.X 0).X ≫ + ((β_ (modPowMod A M'.X n).X + (modPowMod A M.X n).X).hom ⊗ₘ + (β_ (modPowMod A M'.X 0).X + (modPowMod A M.X 0).X).hom) ≫ t) + hmeet) ?_ + exact congrArg (fun t : + ((modPowMod A M'.X n).X ⊗ (modPowMod A M.X n).X) ⊗ + ((modPowMod A M'.X 0).X ⊗ + (modPowMod A M.X 0).X) ⟶ A => + tensorμ (modPowMod A M'.X n).X (modPowMod A M'.X 0).X + (modPowMod A M.X n).X (modPowMod A M.X 0).X ≫ t) + htail + -- Right descent: the tensor pairing against the big projection. + have hdesc : modTensorπ A + (modTensorMod A (modPowMod A M'.X n) (modPowMod A M'.X 0)) + (modTensorMod A (modPowMod A M.X n) (modPowMod A M.X 0)) ≫ + tensorPair A (powDualityDatum A M M' d n) + (powDualityDatum A M M' d 0) = + interchange A (modPowMod A M'.X n) (modPowMod A M'.X 0) + (modPowMod A M.X n) (modPowMod A M.X 0) ≫ + modTensorMap A (powDualityDatum A M M' d n).pairMod + (powDualityDatum A M M' d 0).pairMod ≫ + regPairFold A := by + have hpair : tensorPair A (powDualityDatum A M M' d n) + (powDualityDatum A M M' d 0) = + interchangeDesc A (modPowMod A M'.X n) + (modPowMod A M'.X 0) (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + modTensorMap A (powDualityDatum A M M' d n).pairMod + (powDualityDatum A M M' d 0).pairMod ≫ + regPairFold A := rfl + rw [hpair, ← Category.assoc, modTensorπ_interchangeDesc] + rfl + -- The evaluated tensor pairing over the cover. + have hwP : (modTensorπ A (modPowMod A M'.X n) + (modPowMod A M'.X 0) ⊗ₘ + modTensorπ A (modPowMod A M.X n) (modPowMod A M.X 0)) ≫ + interchange A (modPowMod A M'.X n) (modPowMod A M'.X 0) + (modPowMod A M.X n) (modPowMod A M.X 0) ≫ + modTensorMap A (powDualityDatum A M M' d n).pairMod + (powDualityDatum A M M' d 0).pairMod ≫ + regPairFold A = + tensorμ (modPowMod A M'.X n).X (modPowMod A M'.X 0).X + (modPowMod A M.X n).X (modPowMod A M.X 0).X ≫ + ((modTensorπ A (modPowMod A M'.X n) + (modPowMod A M.X n) ≫ + modPowPairing A M M' d n) ⊗ₘ + (modTensorπ A (modPowMod A M'.X 0) + (modPowMod A M.X 0) ≫ + modPowPairing A M M' d 0)) ≫ μ[A] := + tensorHom_π_pairFold A (powDualityDatum A M M' d n) + (powDualityDatum A M M' d 0) + -- Assemble both sides over the common cover. + apply modTensor_hom_ext + refine (cancel_epi (modTensorπ A (modPowMod A M'.X n) + (modPowMod A M'.X 0) ⊗ₘ + modTensorπ A (modPowMod A M.X n) + (modPowMod A M.X 0))).mp ?_ + refine Eq.trans (congrArg (fun t : + (modTensorMod A (modPowMod A M'.X n) + (modPowMod A M'.X 0)).X ⊗ + (modTensorMod A (modPowMod A M.X n) + (modPowMod A M.X 0)).X ⟶ A => + (modTensorπ A (modPowMod A M'.X n) + (modPowMod A M'.X 0) ⊗ₘ + modTensorπ A (modPowMod A M.X n) + (modPowMod A M.X 0)) ≫ t) hLdesc) ?_ + refine Eq.trans hLfuse ?_ + refine Eq.trans hfinal ?_ + refine Eq.trans hwP.symm ?_ + exact (congrArg (fun t : + (modTensorMod A (modPowMod A M'.X n) + (modPowMod A M'.X 0)).X ⊗ + (modTensorMod A (modPowMod A M.X n) + (modPowMod A M.X 0)).X ⟶ A => + (modTensorπ A (modPowMod A M'.X n) + (modPowMod A M'.X 0) ⊗ₘ + modTensorπ A (modPowMod A M.X n) + (modPowMod A M.X 0)) ≫ t) hdesc).symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairing.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairing.lean new file mode 100644 index 0000000000..fc194eb3bc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairing.lean @@ -0,0 +1,1945 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowAct + +/-! +# The power pairing + +For a Mod-internal duality datum on a pair of modules, the nested +pairing of equal tensor powers: peel the innermost pair — the last +factor of the `M'`-power against the first factor of the +`M`-power — evaluate the datum, braid the scalar out, and multiply +onto the pairing of the remaining powers. The pairing is defined +at the raw tensor-power level by recursion on the arity; the +descent obligations through the module-power and module-tensor +coequalizers reduce, by the same recursion, to the datum's +linearity and the commutativity of the monoid. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +section Braided + +/-! ## The datum's pairing at the raw tensor level -/ + +section PairRaw + +/-- The datum's pairing evaluated on the raw tensor product. -/ +noncomputable def pairRaw + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + M'.X ⊗ M.X ⟶ A := + modTensorπ A M' M ≫ d.pair + +/-- Raw linearity of the pairing in the `M'`-factor: acting on the +first factor multiplies the scalar. -/ +@[reassoc] +theorem pairRaw_actLeft_fst + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + ((α_ A M'.X M.X).inv ≫ actLeft A M'.X ▷ M.X) ≫ + pairRaw A M M' d = + (A ◁ pairRaw A M M' d) ≫ μ[A] := by + have h : modTensorAct A M' M ≫ d.pair = + (A ◁ d.pair) ≫ μ[A] := d.pair_linear + rw [pairRaw] + conv_rhs => rw [MonoidalCategory.whiskerLeft_comp, + Category.assoc, ← h, whiskerLeft_modTensorπ_act_assoc] + simp only [Category.assoc] + +/-- The middle slide across the raw pairing: the braided right +action on `M'` and the left action on `M` pair equally. -/ +@[reassoc] +theorem pairRaw_slide [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + (actRight A M'.X ▷ M.X) ≫ pairRaw A M M' d = + ((α_ M'.X A M.X).hom ≫ M'.X ◁ actLeft A M.X) ≫ + pairRaw A M M' d := by + have h := modTensor_condition_assoc A M' M d.pair + rw [modTensorLegM, modTensorLegN] at h + simpa [pairRaw] using h + +/-- Raw linearity through the braided right action: acting on the +right of the `M'`-factor braids the scalar out to the left and +multiplies. -/ +@[reassoc] +theorem pairRaw_actRight_fst + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + (actRight A M'.X ▷ M.X) ≫ pairRaw A M M' d = + ((β_ M'.X A).hom ▷ M.X) ≫ (α_ A M'.X M.X).hom ≫ + (A ◁ pairRaw A M M' d) ≫ μ[A] := by + conv_rhs => rw [← pairRaw_actLeft_fst A M M' d] + simp only [Category.assoc, Iso.hom_inv_id_assoc] + rw [actRight, comp_whiskerRight, Category.assoc] + +/-- Raw linearity in the `M`-factor: acting on the left of the +`M`-factor braids the scalar out to the left and multiplies. -/ +@[reassoc] +theorem pairRaw_actLeft_snd + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + (M'.X ◁ actLeft A M.X) ≫ pairRaw A M M' d = + (α_ M'.X A M.X).inv ≫ ((β_ M'.X A).hom ▷ M.X) ≫ + (α_ A M'.X M.X).hom ≫ (A ◁ pairRaw A M M' d) ≫ μ[A] := by + rw [← pairRaw_actRight_fst, pairRaw_slide] + simp only [Category.assoc, Iso.inv_hom_id_assoc] + +end PairRaw + +/-! ## The nested power pairing -/ + +section RawPair + +/-- **The nested power pairing** at the raw tensor level, by +recursion on the arity: at `n + 1`, peel the first factor of the +`M`-power, pair it with the exposed last factor of the `M'`-power, +braid the resulting scalar past the remaining `M`-power, and +multiply it onto the pairing of the remaining powers. -/ +noncomputable def rawPair + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + (n : ℕ) → (tensorPow D M'.X n ⊗ tensorPow D M.X n ⟶ A) + | 0 => (λ_ (𝟙_ D)).hom ≫ η[A] + | n + 1 => + (tensorPow D M'.X (n + 1) ◁ (powPeel M.X n).hom) ≫ + (α_ (tensorPow D M'.X n) M'.X + (M.X ⊗ tensorPow D M.X n)).hom ≫ + (tensorPow D M'.X n ◁ + (α_ M'.X M.X (tensorPow D M.X n)).inv) ≫ + (tensorPow D M'.X n ◁ + (pairRaw A M M' d ▷ tensorPow D M.X n)) ≫ + (tensorPow D M'.X n ◁ (β_ A (tensorPow D M.X n)).hom) ≫ + (α_ (tensorPow D M'.X n) (tensorPow D M.X n) A).inv ≫ + (rawPair A M M' d n ▷ A) ≫ μ[A] + +/-- The base case of the power pairing. -/ +theorem rawPair_zero [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + rawPair A M M' d 0 = (λ_ (𝟙_ D)).hom ≫ η[A] := + rfl + +/-- The recursion of the power pairing. -/ +theorem rawPair_succ [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (n : ℕ) : + rawPair A M M' d (n + 1) = + (tensorPow D M'.X (n + 1) ◁ (powPeel M.X n).hom) ≫ + (α_ (tensorPow D M'.X n) M'.X + (M.X ⊗ tensorPow D M.X n)).hom ≫ + (tensorPow D M'.X n ◁ + (α_ M'.X M.X (tensorPow D M.X n)).inv) ≫ + (tensorPow D M'.X n ◁ + (pairRaw A M M' d ▷ tensorPow D M.X n)) ≫ + (tensorPow D M'.X n ◁ (β_ A (tensorPow D M.X n)).hom) ≫ + (α_ (tensorPow D M'.X n) (tensorPow D M.X n) A).inv ≫ + (rawPair A M M' d n ▷ A) ≫ μ[A] := + rfl + +end RawPair + +/-! ## The generic pairing step + +The recursion step of the power pairing, over an arbitrary +continuation pairing: pair the exposed last `M'`-factor against +the exposed head `M`-factor, braid the scalar past the remaining +block, and fold it onto the continuation by multiplication. All +extraction and naturality laws are proved at this generality, so +that the inductions over the arity reduce to threading through +the step. +-/ + +section PairStep + +/-- The generic recursion step of the power pairing. -/ +noncomputable def pairStep + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + {Q R : D} (r : Q ⊗ R ⟶ A) : + (Q ⊗ M'.X) ⊗ (M.X ⊗ R) ⟶ A := + (α_ Q M'.X (M.X ⊗ R)).hom ≫ + (Q ◁ ((α_ M'.X M.X R).inv ≫ + (pairRaw A M M' d ▷ R) ≫ (β_ A R).hom)) ≫ + (α_ Q R A).inv ≫ (r ▷ A) ≫ μ[A] + +/-- The recursion of the power pairing through the generic +step. -/ +theorem rawPair_succ_step + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (n : ℕ) : + rawPair A M M' d (n + 1) = + (tensorPow D M'.X (n + 1) ◁ (powPeel M.X n).hom) ≫ + pairStep A M M' d (rawPair A M M' d n) := by + rw [rawPair_succ, pairStep] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + rfl + +/-- Naturality of the step in the block variable. -/ +theorem pairStep_precomp + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + {Q' Q R : D} (f : Q' ⟶ Q) (r : Q ⊗ R ⟶ A) : + ((f ▷ M'.X) ▷ (M.X ⊗ R)) ≫ pairStep A M M' d r = + pairStep A M M' d ((f ▷ R) ≫ r) := by + rw [pairStep, pairStep, + associator_naturality_left_assoc, ← whisker_exchange_assoc, + associator_inv_naturality_left_assoc, + ← comp_whiskerRight_assoc] + +/-- Naturality of the step in the continuation variable. -/ +theorem pairStep_postcomp + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + {Q R' R : D} (g : R' ⟶ R) (r : Q ⊗ R ⟶ A) : + ((Q ⊗ M'.X) ◁ (M.X ◁ g)) ≫ pairStep A M M' d r = + pairStep A M M' d ((Q ◁ g) ≫ r) := by + rw [pairStep, pairStep, associator_naturality_right_assoc] + have hblock : (M'.X ◁ (M.X ◁ g)) ≫ + ((α_ M'.X M.X R).inv ≫ + (pairRaw A M M' d ▷ R) ≫ (β_ A R).hom) = + ((α_ M'.X M.X R').inv ≫ + (pairRaw A M M' d ▷ R') ≫ (β_ A R').hom) ≫ (g ▷ A) := by + rw [associator_inv_naturality_right_assoc, + whisker_exchange_assoc, + BraidedCategory.braiding_naturality_right] + simp only [Category.assoc] + rw [← MonoidalCategory.whiskerLeft_comp_assoc, hblock, + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rw [associator_inv_naturality_middle_assoc, + ← comp_whiskerRight_assoc] + +end PairStep + +/-- The mirror crossing coherence, for a strand arriving from the +left of the pair's second factor. -/ +private theorem cross_shuffle_snd + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (S T R C : D) : + (S ◁ (α_ C T R).inv) ≫ (α_ S (C ⊗ T) R).inv ≫ + ((S ◁ (β_ C T).hom) ▷ R) ≫ ((α_ S T C).inv ▷ R) ≫ + (β_ ((S ⊗ T) ⊗ C) R).hom = + (S ◁ (β_ C (T ⊗ R)).hom) ≫ (α_ S (T ⊗ R) C).inv ≫ + ((α_ S T R).inv ▷ C) ≫ ((β_ (S ⊗ T) R).hom ▷ C) ≫ + (α_ R (S ⊗ T) C).hom := by + rw [BraidedCategory.braiding_tensor_left_hom, + BraidedCategory.braiding_tensor_right_hom] + monoidal + +/-- A strand crossing a block from inside a left pair: crossing +the adjacent factor and then the whole block as a unit equals +first regrouping and crossing factor by factor. -/ +private theorem cross_shuffle + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (S T R C : D) : + (α_ (S ⊗ C) T R).inv ≫ ((α_ S C T).hom ▷ R) ≫ + ((S ◁ (β_ C T).hom) ▷ R) ≫ ((α_ S T C).inv ▷ R) ≫ + (β_ ((S ⊗ T) ⊗ C) R).hom = + (α_ S C (T ⊗ R)).hom ≫ (S ◁ (β_ C (T ⊗ R)).hom) ≫ + (α_ S (T ⊗ R) C).inv ≫ ((α_ S T R).inv ▷ C) ≫ + ((β_ (S ⊗ T) R).hom ▷ C) ≫ (α_ R (S ⊗ T) C).hom := by + rw [BraidedCategory.braiding_tensor_left_hom, + BraidedCategory.braiding_tensor_right_hom] + monoidal + +end Braided + +/-! ## Scalar extraction over a symmetric base + +The descent obligations move an acted scalar across whole tensor +blocks in both directions; the two routes agree only when the +braiding is symmetric. The pairing calculus therefore runs over a +symmetric base from here on — which is the generality of the Key +Lemma itself. The section is fresh, so that the symmetric +structure's braiding is the only braiding in scope. +-/ + +section ConcatPeel + +/-- **Concatenation against the head peel**: concatenating onto a +power with an exposed head factor and peeling the head of the +result equals peeling the first block and concatenating the +rest under the exposed factor. -/ +theorem concat_peel_head [Category.{v} D] [MonoidalCategory D] (X : D) + (p : ℕ) : ∀ q : ℕ, + (tensorPowConcat X (p + 1) q).hom ≫ + powCast X (by omega : p + 1 + q = p + q + 1) ≫ + (powPeel X (p + q)).hom = + ((powPeel X p).hom ▷ tensorPow D X q) ≫ + (α_ X (tensorPow D X p) (tensorPow D X q)).hom ≫ + (X ◁ (tensorPowConcat X p q).hom) + | 0 => by + rw [tensorPowConcat_zero, tensorPowConcat_zero] + change (ρ_ (tensorPow D X (p + 1))).hom ≫ + 𝟙 (tensorPow D X (p + 1)) ≫ (powPeel X p).hom = + ((powPeel X p).hom ▷ 𝟙_ D) ≫ + (α_ X (tensorPow D X p) (𝟙_ D)).hom ≫ + (X ◁ (ρ_ (tensorPow D X p)).hom) + rw [Category.id_comp] + monoidal + | q + 1 => by + rw [tensorPowConcat_succ, tensorPowConcat_succ] + change ((α_ (tensorPow D X (p + 1)) (tensorPow D X q) X).inv ≫ + ((tensorPowConcat X (p + 1) q).hom ▷ X)) ≫ + powCast X (by omega : p + 1 + q + 1 = p + q + 1 + 1) ≫ + (((powPeel X (p + q)).hom ▷ X) ≫ + (α_ X (tensorPow D X (p + q)) X).hom) = + ((powPeel X p).hom ▷ (tensorPow D X q ⊗ X)) ≫ + (α_ X (tensorPow D X p) (tensorPow D X q ⊗ X)).hom ≫ + (X ◁ ((α_ (tensorPow D X p) (tensorPow D X q) X).inv ≫ + ((tensorPowConcat X p q).hom ▷ X))) + rw [← powCast_whiskerRight X (by omega : p + 1 + q = p + q + 1)] + simp only [Category.assoc] + change (α_ (tensorPow D X (p + 1)) (tensorPow D X q) X).inv ≫ + ((tensorPowConcat X (p + 1) q).hom ▷ X) ≫ + (powCast X (by omega : p + 1 + q = p + q + 1) ▷ X) ≫ + ((powPeel X (p + q)).hom ▷ X) ≫ + (α_ X (tensorPow D X (p + q)) X).hom = + ((powPeel X p).hom ▷ (tensorPow D X q ⊗ X)) ≫ + (α_ X (tensorPow D X p) (tensorPow D X q ⊗ X)).hom ≫ + (X ◁ ((α_ (tensorPow D X p) (tensorPow D X q) X).inv ≫ + ((tensorPowConcat X p q).hom ▷ X))) + rw [← comp_whiskerRight_assoc, ← comp_whiskerRight_assoc, + Category.assoc, concat_peel_head X p q] + simp only [comp_whiskerRight, Category.assoc] + monoidal + +/-- **The head decomposition of a slot leg**: a leg with a +non-trivial left context, followed by the head peel, is the head +peel of the block followed by the leg at the lower context under +the exposed factor. -/ +private theorem leg_step_snd_eq [Category.{v} D] [MonoidalCategory D] + {A X : D} + (w : (X ⊗ A) ⊗ X ⟶ X ⊗ X) (a b : ℕ) : + ((tensorPow D X (a + 1) ◁ w) ▷ tensorPow D X b) ≫ + modPowGlue X (a + 1) b ≫ + powCast X (by omega : a + 1 + 2 + b = a + 2 + b + 1) ≫ + (powPeel X (a + 2 + b)).hom = + (((powPeel X a).hom ▷ ((X ⊗ A) ⊗ X)) ▷ tensorPow D X b) ≫ + ((α_ X (tensorPow D X a) ((X ⊗ A) ⊗ X)).hom ▷ + tensorPow D X b) ≫ + (α_ X (tensorPow D X a ⊗ ((X ⊗ A) ⊗ X)) + (tensorPow D X b)).hom ≫ + (X ◁ (((tensorPow D X a ◁ w) ▷ tensorPow D X b) ≫ + modPowGlue X a b)) := by + rw [modPowGlue, modPowGlue] + change ((tensorPow D X (a + 1) ◁ w) ▷ tensorPow D X b) ≫ + (((α_ (tensorPow D X (a + 1)) X X).inv ▷ tensorPow D X b) ≫ + (tensorPowConcat X (a + 2 + 1) b).hom) ≫ + powCast X (by omega : a + 2 + 1 + b = a + 2 + b + 1) ≫ + (powPeel X (a + 2 + b)).hom = _ + repeat' erw [Category.assoc] + refine Eq.trans (congrArg (fun t => + ((tensorPow D X (a + 1) ◁ w) ▷ tensorPow D X b) ≫ + ((α_ (tensorPow D X (a + 1)) X X).inv ▷ + tensorPow D X b) ≫ t) (concat_peel_head X (a + 2) b)) ?_ + trans (((tensorPow D X (a + 1) ◁ w) ▷ tensorPow D X b) ≫ + (((powPeel X a).hom ▷ (X ⊗ X)) ▷ tensorPow D X b) ≫ + ((α_ X (tensorPow D X a) (X ⊗ X)).hom ▷ tensorPow D X b) ≫ + (α_ X (tensorPow D X a ⊗ (X ⊗ X)) (tensorPow D X b)).hom ≫ + (X ◁ (((α_ (tensorPow D X a) X X).inv ▷ tensorPow D X b) ≫ + (tensorPowConcat X (a + 2) b).hom))) + · rw [show (powPeel X (a + 2)).hom = + ((((powPeel X a).hom ▷ X) ≫ + (α_ X (tensorPow D X a) X).hom) ▷ X) ≫ + (α_ X (tensorPow D X (a + 1)) X).hom from rfl] + monoidal + · rw [← comp_whiskerRight_assoc, whisker_exchange, + comp_whiskerRight, Category.assoc] + monoidal + +end ConcatPeel + +section Symmetric + +/-- A strand crossing out to the left through an evaluated pairing +may instead cross to the right and braid past the output. -/ +theorem braid_cross_pair + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + {S T Z : D} (C : D) (f : S ⊗ T ⟶ Z) : + ((β_ S C).hom ▷ T) ≫ (α_ C S T).hom ≫ (C ◁ f) = + (α_ S C T).hom ≫ (S ◁ (β_ C T).hom) ≫ (α_ S T C).inv ≫ + (f ▷ C) ≫ (β_ Z C).hom := by + rw [BraidedCategory.braiding_naturality_left f C, + BraidedCategory.braiding_tensor_left_hom] + simp only [Category.assoc, Iso.inv_hom_id_assoc] + rw [← MonoidalCategory.whiskerLeft_comp_assoc, + SymmetricCategory.symmetry] + simp + +/-- **Scalar extraction at the pair**: acting on the right of the +`M'`-factor equals sliding the scalar rightwards past the +`M`-factor, pairing, and multiplying from the right. -/ +@[reassoc] +theorem pairRaw_actRight_out + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + (actRight A M'.X ▷ M.X) ≫ pairRaw A M M' d = + (α_ M'.X A M.X).hom ≫ (M'.X ◁ (β_ A M.X).hom) ≫ + (α_ M'.X M.X A).inv ≫ (pairRaw A M M' d ▷ A) ≫ μ[A] := by + rw [pairRaw_actRight_fst, + reassoc_of% braid_cross_pair A (pairRaw A M M' d)] + rw [IsCommMonObj.mul_comm] + +/-- The inner extraction: acting on the right of the `M'`-factor +before a whiskered pairing-and-braid block equals braiding the +scalar past the block and folding it by multiplication. -/ +private theorem inner_extract + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (R : D) : + (actRight A M'.X ▷ (M.X ⊗ R)) ≫ (α_ M'.X M.X R).inv ≫ + (pairRaw A M M' d ▷ R) ≫ (β_ A R).hom = + (α_ M'.X A (M.X ⊗ R)).hom ≫ + (M'.X ◁ (β_ A (M.X ⊗ R)).hom) ≫ + (α_ M'.X (M.X ⊗ R) A).inv ≫ + (((α_ M'.X M.X R).inv ≫ (pairRaw A M M' d ▷ R) ≫ + (β_ A R).hom) ▷ A) ≫ + (α_ R A A).hom ≫ (R ◁ μ[A]) := by + rw [associator_inv_naturality_left_assoc, + ← comp_whiskerRight_assoc, pairRaw_actRight_out] + simp only [comp_whiskerRight, Category.assoc] + rw [BraidedCategory.braiding_naturality_left μ[A] R, + BraidedCategory.braiding_naturality_left_assoc + (pairRaw A M M' d ▷ A) R] + have hp : (pairRaw A M M' d ▷ R) ≫ (β_ A R).hom = + (β_ (M'.X ⊗ M.X) R).hom ≫ (R ◁ pairRaw A M M' d) := + BraidedCategory.braiding_naturality_left _ R + conv_rhs => rw [← comp_whiskerRight_assoc, + ← comp_whiskerRight_assoc, Category.assoc, hp] + simp only [comp_whiskerRight, Category.assoc] + rw [associator_naturality_middle_assoc] + rw [reassoc_of% cross_shuffle M'.X M.X R A] + +/-- **Scalar extraction at the pair, second slot**: acting on the +left of the `M`-factor equals sliding the scalar rightwards past +the `M`-factor, pairing, and multiplying from the right. -/ +@[reassoc] +theorem pairRaw_actLeft_out + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + (M'.X ◁ actLeft A M.X) ≫ pairRaw A M M' d = + (M'.X ◁ (β_ A M.X).hom) ≫ (α_ M'.X M.X A).inv ≫ + (pairRaw A M M' d ▷ A) ≫ μ[A] := by + rw [pairRaw_actLeft_snd, + reassoc_of% braid_cross_pair A (pairRaw A M M' d), + IsCommMonObj.mul_comm] + simp only [Iso.inv_hom_id_assoc] + +/-- **Scalar extraction at the pair, second slot from the +right**: acting through the braided right action on the +`M`-factor multiplies the pairing from the right, with no +crossing at all. -/ +@[reassoc] +theorem pairRaw_actRight_snd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + (M'.X ◁ actRight A M.X) ≫ pairRaw A M M' d = + (α_ M'.X M.X A).inv ≫ (pairRaw A M M' d ▷ A) ≫ μ[A] := by + rw [actRight, MonoidalCategory.whiskerLeft_comp, Category.assoc, + pairRaw_actLeft_out, ← MonoidalCategory.whiskerLeft_comp_assoc, + SymmetricCategory.symmetry] + simp + +/-- The mirror inner extraction: acting on the left of the +`M`-factor before a whiskered pairing-and-braid block equals +braiding the scalar past the block and folding by +multiplication. -/ +private theorem inner_extract_snd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (R : D) : + (M'.X ◁ ((α_ A M.X R).inv ≫ (actLeft A M.X ▷ R))) ≫ + (α_ M'.X M.X R).inv ≫ (pairRaw A M M' d ▷ R) ≫ + (β_ A R).hom = + (M'.X ◁ (β_ A (M.X ⊗ R)).hom) ≫ + (α_ M'.X (M.X ⊗ R) A).inv ≫ + (((α_ M'.X M.X R).inv ≫ (pairRaw A M M' d ▷ R) ≫ + (β_ A R).hom) ▷ A) ≫ + (α_ R A A).hom ≫ (R ◁ μ[A]) := by + rw [MonoidalCategory.whiskerLeft_comp, Category.assoc, + associator_inv_naturality_middle_assoc, + ← comp_whiskerRight_assoc, pairRaw_actLeft_out] + simp only [comp_whiskerRight, Category.assoc] + rw [BraidedCategory.braiding_naturality_left μ[A] R, + BraidedCategory.braiding_naturality_left_assoc + (pairRaw A M M' d ▷ A) R] + have hp : (pairRaw A M M' d ▷ R) ≫ (β_ A R).hom = + (β_ (M'.X ⊗ M.X) R).hom ≫ (R ◁ pairRaw A M M' d) := + BraidedCategory.braiding_naturality_left _ R + conv_rhs => rw [← comp_whiskerRight_assoc, + ← comp_whiskerRight_assoc, Category.assoc, hp] + simp only [comp_whiskerRight, Category.assoc] + rw [associator_naturality_middle_assoc] + rw [reassoc_of% cross_shuffle_snd M'.X M.X R A] + +/-- **Scalar extraction at the last `M'`-factor**: acting on the +right of the exposed last factor of the `M'`-power equals braiding +the scalar past the whole `M`-power and multiplying the pairing +from the right. -/ +theorem rawPair_actRight_last + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (n : ℕ) : + ((tensorPow D M'.X n ◁ actRight A M'.X) ▷ + tensorPow D M.X (n + 1)) ≫ rawPair A M M' d (n + 1) = + ((α_ (tensorPow D M'.X n) M'.X A).inv ▷ + tensorPow D M.X (n + 1)) ≫ + (α_ (tensorPow D M'.X (n + 1)) A + (tensorPow D M.X (n + 1))).hom ≫ + (tensorPow D M'.X (n + 1) ◁ + (β_ A (tensorPow D M.X (n + 1))).hom) ≫ + (α_ (tensorPow D M'.X (n + 1)) (tensorPow D M.X (n + 1)) + A).inv ≫ + (rawPair A M M' d (n + 1) ▷ A) ≫ μ[A] := by + conv_lhs => + change ((tensorPow D M'.X n ◁ actRight A M'.X) ▷ + tensorPow D M.X (n + 1)) ≫ + (((tensorPow D M'.X n ⊗ M'.X) ◁ (powPeel M.X n).hom) ≫ + (α_ (tensorPow D M'.X n) M'.X + (M.X ⊗ tensorPow D M.X n)).hom ≫ + (tensorPow D M'.X n ◁ + (α_ M'.X M.X (tensorPow D M.X n)).inv) ≫ + (tensorPow D M'.X n ◁ + (pairRaw A M M' d ▷ tensorPow D M.X n)) ≫ + (tensorPow D M'.X n ◁ (β_ A (tensorPow D M.X n)).hom) ≫ + (α_ (tensorPow D M'.X n) (tensorPow D M.X n) A).inv ≫ + (rawPair A M M' d n ▷ A) ≫ μ[A]) + conv_lhs => rw [← whisker_exchange_assoc, + associator_naturality_middle_assoc] + conv_lhs => simp only [← MonoidalCategory.whiskerLeft_comp_assoc] + conv_lhs => rw [inner_extract A M M' d (tensorPow D M.X n)] + conv_rhs => + change ((α_ (tensorPow D M'.X n) M'.X A).inv ▷ + tensorPow D M.X (n + 1)) ≫ + (α_ (tensorPow D M'.X n ⊗ M'.X) A + (tensorPow D M.X (n + 1))).hom ≫ + ((tensorPow D M'.X n ⊗ M'.X) ◁ + (β_ A (tensorPow D M.X (n + 1))).hom) ≫ + (α_ (tensorPow D M'.X n ⊗ M'.X) (tensorPow D M.X (n + 1)) + A).inv ≫ + ((((tensorPow D M'.X n ⊗ M'.X) ◁ (powPeel M.X n).hom) ≫ + (α_ (tensorPow D M'.X n) M'.X + (M.X ⊗ tensorPow D M.X n)).hom ≫ + (tensorPow D M'.X n ◁ + (α_ M'.X M.X (tensorPow D M.X n)).inv) ≫ + (tensorPow D M'.X n ◁ + (pairRaw A M M' d ▷ tensorPow D M.X n)) ≫ + (tensorPow D M'.X n ◁ (β_ A (tensorPow D M.X n)).hom) ≫ + (α_ (tensorPow D M'.X n) (tensorPow D M.X n) A).inv ≫ + (rawPair A M M' d n ▷ A) ≫ μ[A]) ▷ A) ≫ μ[A] + conv_rhs => simp only [comp_whiskerRight, Category.assoc] + conv_rhs => rw [MonObj.mul_assoc, + associator_naturality_left_assoc, ← whisker_exchange_assoc] + conv_rhs => rw [← associator_inv_naturality_middle_assoc] + conv_rhs => rw [← MonoidalCategory.whiskerLeft_comp_assoc, + ← BraidedCategory.braiding_naturality_right, + MonoidalCategory.whiskerLeft_comp] + conv_rhs => simp only [Category.assoc] + conv_rhs => rw [← associator_naturality_right_assoc] + conv_rhs => rw [← whisker_exchange_assoc] + monoidal + +/-- **Generic scalar extraction at the `M'`-slot of the step**: +acting through the braided right action on the exposed `M'`-factor +equals braiding the scalar past the peeled block and multiplying +the step from the right. -/ +theorem pairStep_actRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + {Q R : D} (r : Q ⊗ R ⟶ A) : + ((Q ◁ actRight A M'.X) ▷ (M.X ⊗ R)) ≫ + pairStep A M M' d r = + ((α_ Q M'.X A).inv ▷ (M.X ⊗ R)) ≫ + (α_ (Q ⊗ M'.X) A (M.X ⊗ R)).hom ≫ + ((Q ⊗ M'.X) ◁ (β_ A (M.X ⊗ R)).hom) ≫ + (α_ (Q ⊗ M'.X) (M.X ⊗ R) A).inv ≫ + (pairStep A M M' d r ▷ A) ≫ μ[A] := by + conv_lhs => rw [pairStep] + conv_lhs => rw [associator_naturality_middle_assoc] + conv_lhs => rw [← MonoidalCategory.whiskerLeft_comp_assoc] + conv_lhs => rw [inner_extract A M M' d R] + conv_rhs => rw [pairStep] + conv_rhs => simp only [comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + conv_rhs => rw [MonObj.mul_assoc, + associator_naturality_left_assoc, ← whisker_exchange_assoc] + conv_lhs => simp only [MonoidalCategory.whiskerLeft_comp, + Category.assoc] + monoidal + +/-- **Generic scalar extraction at the `M`-slot of the step**: +acting on the exposed head `M`-factor equals braiding the scalar +past the peeled block and multiplying the step from the right. -/ +theorem pairStep_actHead + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + {Q R : D} (r : Q ⊗ R ⟶ A) : + ((Q ⊗ M'.X) ◁ ((α_ A M.X R).inv ≫ + (actLeft A M.X ▷ R))) ≫ pairStep A M M' d r = + ((Q ⊗ M'.X) ◁ (β_ A (M.X ⊗ R)).hom) ≫ + (α_ (Q ⊗ M'.X) (M.X ⊗ R) A).inv ≫ + (pairStep A M M' d r ▷ A) ≫ μ[A] := by + conv_lhs => rw [pairStep] + conv_lhs => rw [associator_naturality_right_assoc] + conv_lhs => rw [← MonoidalCategory.whiskerLeft_comp_assoc] + conv_lhs => rw [inner_extract_snd A M M' d R] + conv_rhs => rw [pairStep] + conv_rhs => simp only [comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + conv_rhs => rw [MonObj.mul_assoc, + associator_naturality_left_assoc, ← whisker_exchange_assoc] + conv_lhs => simp only [MonoidalCategory.whiskerLeft_comp, + Category.assoc] + monoidal + +/-- Over a symmetric base the left action is the braided right +action after one crossing. -/ +theorem actLeft_eq_braid_actRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] + (X : D) [ModObj A X] : + actLeft A X = (β_ A X).hom ≫ actRight A X := by + rw [actRight, ← Category.assoc, SymmetricCategory.symmetry, + Category.id_comp] + +/-- Generic scalar extraction at the `M'`-slot, for a scalar +arriving from the left of the consumed factor. -/ +theorem pairStep_actLeft_pair + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + {Q R : D} (r : Q ⊗ R ⟶ A) : + ((Q ◁ actLeft A M'.X) ▷ (M.X ⊗ R)) ≫ + pairStep A M M' d r = + ((Q ◁ (β_ A M'.X).hom) ▷ (M.X ⊗ R)) ≫ + ((α_ Q M'.X A).inv ▷ (M.X ⊗ R)) ≫ + (α_ (Q ⊗ M'.X) A (M.X ⊗ R)).hom ≫ + ((Q ⊗ M'.X) ◁ (β_ A (M.X ⊗ R)).hom) ≫ + (α_ (Q ⊗ M'.X) (M.X ⊗ R) A).inv ≫ + (pairStep A M M' d r ▷ A) ≫ μ[A] := by + rw [actLeft_eq_braid_actRight, MonoidalCategory.whiskerLeft_comp, + comp_whiskerRight, Category.assoc, + pairStep_actRight A M M' d r] + +/-- The scalar strand crossing the whole pairing block: crossing +factor by factor before the block equals letting the block fire +and crossing its output. -/ +private theorem cross_block + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (R : D) : + ((β_ A M'.X).hom ▷ (M.X ⊗ R)) ≫ + (α_ M'.X A (M.X ⊗ R)).hom ≫ + (M'.X ◁ (β_ A (M.X ⊗ R)).hom) ≫ + (α_ M'.X (M.X ⊗ R) A).inv ≫ + (((α_ M'.X M.X R).inv ≫ (pairRaw A M M' d ▷ R) ≫ + (β_ A R).hom) ▷ A) = + (α_ A M'.X (M.X ⊗ R)).hom ≫ + (A ◁ ((α_ M'.X M.X R).inv ≫ (pairRaw A M M' d ▷ R) ≫ + (β_ A R).hom)) ≫ + (β_ A (R ⊗ A)).hom := by + rw [BraidedCategory.braiding_naturality_right A + ((α_ M'.X M.X R).inv ≫ (pairRaw A M M' d ▷ R) ≫ + (β_ A R).hom), + BraidedCategory.braiding_tensor_right_hom A M'.X (M.X ⊗ R)] + simp only [Category.assoc, Iso.hom_inv_id_assoc] + +/-- The core of the top-slot slide, after both legs have been +opened: an identity between two routings of the scalar through +the pairing block, valid for every continuation. -/ +private theorem slide_core + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + {Q R : D} (r : (Q ⊗ M'.X) ⊗ R ⟶ A) : + ((α_ Q (M'.X ⊗ A) M'.X).inv ▷ (M.X ⊗ R)) ≫ + (α_ (Q ⊗ (M'.X ⊗ A)) M'.X (M.X ⊗ R)).hom ≫ + ((Q ⊗ (M'.X ⊗ A)) ◁ (α_ M'.X M.X R).inv) ≫ + ((Q ⊗ (M'.X ⊗ A)) ◁ (pairRaw A M M' d ▷ R)) ≫ + ((Q ⊗ (M'.X ⊗ A)) ◁ (β_ A R).hom) ≫ + (α_ (Q ⊗ (M'.X ⊗ A)) R A).inv ≫ + (((α_ Q M'.X A).inv ▷ R) ▷ A) ≫ + ((α_ (Q ⊗ M'.X) A R).hom ▷ A) ≫ + (((Q ⊗ M'.X) ◁ (β_ A R).hom) ▷ A) ≫ + ((α_ (Q ⊗ M'.X) R A).inv ▷ A) ≫ + (α_ ((Q ⊗ M'.X) ⊗ R) A A).hom ≫ + (((Q ⊗ M'.X) ⊗ R) ◁ μ[A]) ≫ (r ▷ A) ≫ μ[A] = + ((Q ◁ (α_ M'.X A M'.X).hom) ▷ (M.X ⊗ R)) ≫ + ((α_ Q M'.X (A ⊗ M'.X)).inv ▷ (M.X ⊗ R)) ≫ + (((Q ⊗ M'.X) ◁ (β_ A M'.X).hom) ▷ (M.X ⊗ R)) ≫ + ((α_ (Q ⊗ M'.X) M'.X A).inv ▷ (M.X ⊗ R)) ≫ + (α_ ((Q ⊗ M'.X) ⊗ M'.X) A (M.X ⊗ R)).hom ≫ + (((Q ⊗ M'.X) ⊗ M'.X) ◁ (β_ A (M.X ⊗ R)).hom) ≫ + (α_ ((Q ⊗ M'.X) ⊗ M'.X) (M.X ⊗ R) A).inv ≫ + ((α_ (Q ⊗ M'.X) M'.X (M.X ⊗ R)).hom ▷ A) ≫ + (((Q ⊗ M'.X) ◁ (α_ M'.X M.X R).inv) ▷ A) ≫ + (((Q ⊗ M'.X) ◁ (pairRaw A M M' d ▷ R)) ▷ A) ≫ + (((Q ⊗ M'.X) ◁ (β_ A R).hom) ▷ A) ≫ + ((α_ (Q ⊗ M'.X) R A).inv ▷ A) ≫ + (α_ ((Q ⊗ M'.X) ⊗ R) A A).hom ≫ + (((Q ⊗ M'.X) ⊗ R) ◁ μ[A]) ≫ (r ▷ A) ≫ μ[A] := by + trans (((α_ Q (M'.X ⊗ A) M'.X).inv ▷ (M.X ⊗ R)) ≫ + (α_ (Q ⊗ (M'.X ⊗ A)) M'.X (M.X ⊗ R)).hom ≫ + ((Q ⊗ (M'.X ⊗ A)) ◁ ((α_ M'.X M.X R).inv ≫ + (pairRaw A M M' d ▷ R) ≫ (β_ A R).hom)) ≫ + (α_ (Q ⊗ (M'.X ⊗ A)) R A).inv ≫ + (((α_ Q M'.X A).inv ▷ R) ▷ A) ≫ + ((α_ (Q ⊗ M'.X) A R).hom ▷ A) ≫ + (((Q ⊗ M'.X) ◁ (β_ A R).hom) ▷ A) ≫ + ((α_ (Q ⊗ M'.X) R A).inv ▷ A) ≫ + (α_ ((Q ⊗ M'.X) ⊗ R) A A).hom ≫ + (((Q ⊗ M'.X) ⊗ R) ◁ (β_ A A).hom) ≫ + (((Q ⊗ M'.X) ⊗ R) ◁ μ[A]) ≫ (r ▷ A) ≫ μ[A]) + · conv_rhs => rw [← MonoidalCategory.whiskerLeft_comp_assoc, + IsCommMonObj.mul_comm] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + trans (((α_ Q (M'.X ⊗ A) M'.X).inv ▷ (M.X ⊗ R)) ≫ + (((α_ Q M'.X A).inv ▷ M'.X) ▷ (M.X ⊗ R)) ≫ + ((α_ (Q ⊗ M'.X) A M'.X).hom ▷ (M.X ⊗ R)) ≫ + (α_ (Q ⊗ M'.X) (A ⊗ M'.X) (M.X ⊗ R)).hom ≫ + ((Q ⊗ M'.X) ◁ ((α_ A M'.X (M.X ⊗ R)).hom ≫ + (A ◁ ((α_ M'.X M.X R).inv ≫ (pairRaw A M M' d ▷ R) ≫ + (β_ A R).hom)) ≫ + (β_ A (R ⊗ A)).hom)) ≫ + ((Q ⊗ M'.X) ◁ (α_ R A A).hom) ≫ + (α_ (Q ⊗ M'.X) R (A ⊗ A)).inv ≫ + (((Q ⊗ M'.X) ⊗ R) ◁ μ[A]) ≫ (r ▷ A) ≫ μ[A]) + · conv_rhs => rw [MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp, + BraidedCategory.braiding_tensor_right_hom A R A] + monoidal + · conv_lhs => rw [← cross_block A M M' d R] + monoidal + +/-- **The top-slot slide law**: for a continuation pairing that +absorbs the braided right action on its last block factor — the +extraction property of the power pairing — the two legs of the +top slot window agree after the generic step. -/ +theorem pairStep_slide + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') {Q R : D} + (r : (Q ⊗ M'.X) ⊗ R ⟶ A) + (hr : ((Q ◁ actRight A M'.X) ▷ R) ≫ r = + ((α_ Q M'.X A).inv ▷ R) ≫ (α_ (Q ⊗ M'.X) A R).hom ≫ + ((Q ⊗ M'.X) ◁ (β_ A R).hom) ≫ + (α_ (Q ⊗ M'.X) R A).inv ≫ (r ▷ A) ≫ μ[A]) : + ((Q ◁ winLegM A M'.X) ▷ (M.X ⊗ R)) ≫ + ((α_ Q M'.X M'.X).inv ▷ (M.X ⊗ R)) ≫ + pairStep A M M' d r = + ((Q ◁ winLegN A M'.X) ▷ (M.X ⊗ R)) ≫ + ((α_ Q M'.X M'.X).inv ▷ (M.X ⊗ R)) ≫ + pairStep A M M' d r := by + conv_lhs => rw [← comp_whiskerRight_assoc, winLegM, + associator_inv_naturality_middle, comp_whiskerRight, + Category.assoc, pairStep_precomp, hr] + conv_rhs => rw [← comp_whiskerRight_assoc, winLegN, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + associator_inv_naturality_right, comp_whiskerRight, + Category.assoc, comp_whiskerRight, Category.assoc, + pairStep_actLeft_pair] + conv_lhs => rw [pairStep] + conv_lhs => simp only [comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + conv_lhs => rw [MonObj.mul_assoc, + associator_naturality_left_assoc, ← whisker_exchange_assoc] + conv_rhs => rw [pairStep] + conv_rhs => simp only [comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + conv_rhs => rw [MonObj.mul_assoc, + associator_naturality_left_assoc, ← whisker_exchange_assoc] + exact slide_core A M M' d r + +/-- The core of the head-slot slide: two routings of a scalar +born between the two consumed factors, for opaque pairing and +continuation. -/ +private theorem slide_snd_core + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [IsCommMonObj A] + (V' V P R : D) + (u : V' ⊗ V ⟶ A) (t : P ⊗ (V ⊗ R) ⟶ A) : + (α_ P V' (((V ⊗ A) ⊗ V) ⊗ R)).hom ≫ + (P ◁ (V' ◁ (α_ (V ⊗ A) V R).hom)) ≫ + (P ◁ (α_ V' (V ⊗ A) (V ⊗ R)).inv) ≫ + (P ◁ ((α_ V' V A).inv ▷ (V ⊗ R))) ≫ + (P ◁ (β_ ((V' ⊗ V) ⊗ A) (V ⊗ R)).hom) ≫ + (P ◁ ((V ⊗ R) ◁ (u ▷ A))) ≫ + (α_ P (V ⊗ R) (A ⊗ A)).inv ≫ + (t ▷ (A ⊗ A)) ≫ (A ◁ μ[A]) ≫ μ[A] = + ((P ⊗ V') ◁ (α_ (V ⊗ A) V R).hom) ≫ + ((P ⊗ V') ◁ (α_ V A (V ⊗ R)).hom) ≫ + (α_ P V' (V ⊗ (A ⊗ (V ⊗ R)))).hom ≫ + (P ◁ (α_ V' V (A ⊗ (V ⊗ R))).inv) ≫ + (P ◁ (u ▷ (A ⊗ (V ⊗ R)))) ≫ + (P ◁ (β_ A (A ⊗ (V ⊗ R))).hom) ≫ + (α_ P (A ⊗ (V ⊗ R)) A).inv ≫ + ((P ◁ (β_ A (V ⊗ R)).hom) ▷ A) ≫ + ((α_ P (V ⊗ R) A).inv ▷ A) ≫ + (α_ (P ⊗ (V ⊗ R)) A A).hom ≫ + (t ▷ (A ⊗ A)) ≫ (A ◁ μ[A]) ≫ μ[A] := by + have hpull : (β_ ((V' ⊗ V) ⊗ A) (V ⊗ R)).hom ≫ + ((V ⊗ R) ◁ (u ▷ A)) = + ((u ▷ A) ▷ (V ⊗ R)) ≫ (β_ (A ⊗ A) (V ⊗ R)).hom := + (BraidedCategory.braiding_naturality_left (u ▷ A) + (V ⊗ R)).symm + conv_lhs => rw [← MonoidalCategory.whiskerLeft_comp_assoc P + (β_ ((V' ⊗ V) ⊗ A) (V ⊗ R)).hom + ((V ⊗ R) ◁ (u ▷ A)), hpull] + conv_lhs => rw [show μ[A] = (β_ A A).hom ≫ μ[A] from + (IsCommMonObj.mul_comm A).symm] + conv_rhs => rw [BraidedCategory.braiding_tensor_right_hom + A A (V ⊗ R)] + conv_lhs => simp only [MonoidalCategory.whiskerLeft_comp, + Category.assoc] + conv_rhs => simp only [MonoidalCategory.whiskerLeft_comp, + Category.assoc] + conv_lhs => rw [IsCommMonObj.mul_comm] + conv_lhs => rw [← whisker_exchange_assoc] + conv_lhs => rw [← associator_inv_naturality_right_assoc] + conv_lhs => rw [← MonoidalCategory.whiskerLeft_comp_assoc P + (β_ (A ⊗ A) (V ⊗ R)).hom ((V ⊗ R) ◁ (β_ A A).hom)] + conv_lhs => rw [show (β_ (A ⊗ A) (V ⊗ R)).hom ≫ + ((V ⊗ R) ◁ (β_ A A).hom) = + ((β_ A A).hom ▷ (V ⊗ R)) ≫ (β_ (A ⊗ A) (V ⊗ R)).hom from + (BraidedCategory.braiding_naturality_left (β_ A A).hom + (V ⊗ R)).symm] + conv_lhs => rw [BraidedCategory.braiding_tensor_left_hom + A A (V ⊗ R)] + monoidal + +/-- Transport of the head peel along an arity equality. -/ +private theorem powPeel_cast [Category.{v} D] [MonoidalCategory D] + {X : D} {m n : ℕ} (h : m = n) : + powCast X (by omega : m + 1 = n + 1) ≫ (powPeel X n).hom = + (powPeel X m).hom ≫ (X ◁ powCast X h) := by + subst h + simp only [powCast_rfl, MonoidalCategory.whiskerLeft_id] + exact (Category.id_comp _).trans (Category.comp_id _).symm + +/-- A head slot leg followed by the double peel: the empty left +context is absorbed and the window fires at the exposed head +pair. -/ +private theorem leg_head_snd_eq [Category.{v} D] [MonoidalCategory D] (A : D) + {X : D} + (w : (X ⊗ A) ⊗ X ⟶ X ⊗ X) (b : ℕ) : + ((tensorPow D X 0 ◁ w) ▷ tensorPow D X b) ≫ + modPowGlue X 0 b ≫ + powCast X (by omega : 0 + 2 + b = b + 1 + 1) ≫ + (powPeel X (b + 1)).hom ≫ (X ◁ (powPeel X b).hom) = + ((λ_ ((X ⊗ A) ⊗ X)).hom ▷ tensorPow D X b) ≫ + (w ▷ tensorPow D X b) ≫ (α_ X X (tensorPow D X b)).hom := by + rw [modPowGlue] + show ((tensorPow D X 0 ◁ w) ▷ tensorPow D X b) ≫ + (((α_ (tensorPow D X 0) X X).inv ▷ tensorPow D X b) ≫ + (tensorPowConcat X (0 + 2) b).hom) ≫ + powCast X (by omega : 0 + 2 + b = b + 1 + 1) ≫ + (powPeel X (b + 1)).hom ≫ (X ◁ (powPeel X b).hom) = _ + erw [Category.assoc] + rw [show powCast X (by omega : 0 + 2 + b = b + 1 + 1) = + powCast X (by omega : 0 + 2 + b = 1 + b + 1) ≫ + powCast X (by omega : 1 + b + 1 = b + 1 + 1) from + (powCast_comp X _ _).symm] + simp only [Category.assoc] + have h2 : powCast X (by omega : 1 + b + 1 = b + 1 + 1) ≫ + (powPeel X (b + 1)).hom ≫ (X ◁ (powPeel X b).hom) = + (powPeel X (1 + b)).hom ≫ + (X ◁ (powCast X (by omega : 1 + b = b + 1) ≫ + (powPeel X b).hom)) := by + rw [← Category.assoc, + powPeel_cast (X := X) (by omega : 1 + b = b + 1)] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + refine Eq.trans (congrArg (fun t => + ((tensorPow D X 0 ◁ w) ▷ tensorPow D X b) ≫ + ((α_ (tensorPow D X 0) X X).inv ▷ tensorPow D X b) ≫ + (tensorPowConcat X (0 + 2) b).hom ≫ + powCast X (by omega : 0 + 2 + b = 1 + b + 1) ≫ t) h2) ?_ + have hc := reassoc_of% (concat_peel_head X 1 b) + have h3 : (tensorPowConcat X (0 + 2) b).hom ≫ + powCast X (by omega : 0 + 2 + b = 1 + b + 1) ≫ + (powPeel X (1 + b)).hom ≫ + (X ◁ (powCast X (by omega : 1 + b = b + 1) ≫ + (powPeel X b).hom)) = + ((powPeel X 1).hom ▷ tensorPow D X b) ≫ + (α_ X (tensorPow D X 1) (tensorPow D X b)).hom ≫ + (X ◁ (tensorPowConcat X 1 b).hom) ≫ + (X ◁ (powCast X (by omega : 1 + b = b + 1) ≫ + (powPeel X b).hom)) := hc _ + refine Eq.trans (congrArg (fun t => + ((tensorPow D X 0 ◁ w) ▷ tensorPow D X b) ≫ + ((α_ (tensorPow D X 0) X X).inv ▷ tensorPow D X b) ≫ t) + h3) ?_ + have h4 : (tensorPowConcat X 1 b).hom ≫ + powCast X (by omega : 1 + b = b + 1) ≫ + (powPeel X b).hom = + ((powPeel X 0).hom ▷ tensorPow D X b) ≫ + (α_ X (tensorPow D X 0) (tensorPow D X b)).hom ≫ + (X ◁ ((tensorPowConcat X 0 b).hom ≫ + powCast X (by omega : 0 + b = b))) := by + rw [show powCast X (by omega : 1 + b = b + 1) = + powCast X (by omega : 1 + b = 0 + b + 1) ≫ + powCast X (by omega : 0 + b + 1 = b + 1) from + (powCast_comp X _ _).symm] + rw [Category.assoc, powPeel_cast (X := X) + (by omega : 0 + b = b)] + have hc0 := reassoc_of% (concat_peel_head X 0 b) + refine Eq.trans (hc0 _) ?_ + simp only [MonoidalCategory.whiskerLeft_comp] + have h4' : (X ◁ (tensorPowConcat X 1 b).hom) ≫ + (X ◁ (powCast X (by omega : 1 + b = b + 1) ≫ + (powPeel X b).hom)) = + X ◁ (((powPeel X 0).hom ▷ tensorPow D X b) ≫ + (α_ X (tensorPow D X 0) (tensorPow D X b)).hom ≫ + (X ◁ ((tensorPowConcat X 0 b).hom ≫ + powCast X (by omega : 0 + b = b)))) := by + rw [← MonoidalCategory.whiskerLeft_comp, h4] + refine Eq.trans (congrArg (fun t => + ((tensorPow D X 0 ◁ w) ▷ tensorPow D X b) ≫ + ((α_ (tensorPow D X 0) X X).inv ▷ tensorPow D X b) ≫ + ((powPeel X 1).hom ▷ tensorPow D X b) ≫ + (α_ X (tensorPow D X 1) (tensorPow D X b)).hom ≫ t) + h4') ?_ + have h5 : (tensorPowConcat X 0 b).hom ≫ + powCast X (by omega : 0 + b = b) = + (λ_ (tensorPow D X b)).hom := by + refine Eq.trans (congrArg + (fun t => t ≫ powCast X (by omega : 0 + b = b)) + (tensorPowConcat_zero_left (X := X) b)) ?_ + exact (Category.assoc _ _ _).trans + ((congrArg (fun t => (λ_ (tensorPow D X b)).hom ≫ t) + (powCast_comp X _ _)).trans (Category.comp_id _)) + rw [h5] + change ((𝟙_ D ◁ w) ▷ tensorPow D X b) ≫ + ((α_ (𝟙_ D) X X).inv ▷ tensorPow D X b) ≫ + (((((λ_ X).hom ≫ (ρ_ X).inv) ▷ X) ≫ + (α_ X (𝟙_ D) X).hom) ▷ tensorPow D X b) ≫ + (α_ X (𝟙_ D ⊗ X) (tensorPow D X b)).hom ≫ + (X ◁ ((((λ_ X).hom ≫ (ρ_ X).inv) ▷ tensorPow D X b) ≫ + (α_ X (𝟙_ D) (tensorPow D X b)).hom ≫ + (X ◁ (λ_ (tensorPow D X b)).hom))) = + ((λ_ ((X ⊗ A) ⊗ X)).hom ▷ tensorPow D X b) ≫ + (w ▷ tensorPow D X b) ≫ (α_ X X (tensorPow D X b)).hom + monoidal + +/-- Transport of the power pairing along an arity equality. -/ +theorem rawPair_cast [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') {m n : ℕ} + (h : m = n) : + rawPair A M M' d m = + (powCast M'.X h ▷ tensorPow D M.X m) ≫ + (tensorPow D M'.X n ◁ powCast M.X h) ≫ + rawPair A M M' d n := by + subst h + simp only [powCast_rfl, MonoidalCategory.whiskerLeft_id, + MonoidalCategory.id_whiskerRight, Category.id_comp] + +/-- **The head-slot slide law**: the two legs of a slot window on +the first two `M`-factors agree after the doubled generic step. +The statement is closed — the continuation is arbitrary. -/ +theorem pairStep_slide_snd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + {Q R : D} (r : Q ⊗ R ⟶ A) : + (((Q ⊗ M'.X) ⊗ M'.X) ◁ + ((winLegM A M.X ▷ R) ≫ (α_ M.X M.X R).hom)) ≫ + pairStep A M M' d (pairStep A M M' d r) = + (((Q ⊗ M'.X) ⊗ M'.X) ◁ + ((winLegN A M.X ▷ R) ≫ (α_ M.X M.X R).hom)) ≫ + pairStep A M M' d (pairStep A M M' d r) := by + have hN : ((((α_ M.X A M.X).hom ≫ + (M.X ◁ actLeft A M.X)) ▷ R) ≫ (α_ M.X M.X R).hom : + ((M.X ⊗ A) ⊗ M.X) ⊗ R ⟶ M.X ⊗ (M.X ⊗ R)) = + (α_ (M.X ⊗ A) M.X R).hom ≫ (α_ M.X A (M.X ⊗ R)).hom ≫ + (M.X ◁ ((α_ A M.X R).inv ≫ (actLeft A M.X ▷ R))) := by + simp only [comp_whiskerRight, Category.assoc] + monoidal + conv_rhs => rw [winLegN, hN] + conv_rhs => simp only [MonoidalCategory.whiskerLeft_comp, + Category.assoc] + conv_rhs => rw [pairStep_postcomp] + conv_rhs => rw [pairStep_postcomp] + have hArg : ((Q ⊗ M'.X) ◁ (α_ A M.X R).inv) ≫ + ((Q ⊗ M'.X) ◁ (actLeft A M.X ▷ R)) ≫ + pairStep A M M' d r = + ((Q ⊗ M'.X) ◁ (β_ A (M.X ⊗ R)).hom) ≫ + (α_ (Q ⊗ M'.X) (M.X ⊗ R) A).inv ≫ + (pairStep A M M' d r ▷ A) ≫ μ[A] := by + rw [← MonoidalCategory.whiskerLeft_comp_assoc] + exact pairStep_actHead A M M' d r + conv_rhs => rw [hArg] + have hM : (M'.X ◁ ((actRight A M.X ▷ M.X ▷ R) ≫ + (α_ M.X M.X R).hom)) ≫ + (α_ M'.X M.X (M.X ⊗ R)).inv ≫ + (pairRaw A M M' d ▷ (M.X ⊗ R)) ≫ + (β_ A (M.X ⊗ R)).hom = + (M'.X ◁ (α_ (M.X ⊗ A) M.X R).hom) ≫ + (α_ M'.X (M.X ⊗ A) (M.X ⊗ R)).inv ≫ + ((α_ M'.X M.X A).inv ▷ (M.X ⊗ R)) ≫ + (β_ ((M'.X ⊗ M.X) ⊗ A) (M.X ⊗ R)).hom ≫ + ((M.X ⊗ R) ◁ (pairRaw A M M' d ▷ A)) ≫ + ((M.X ⊗ R) ◁ μ[A]) := by + rw [associator_naturality_left, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + associator_inv_naturality_middle_assoc, + ← comp_whiskerRight_assoc, pairRaw_actRight_snd] + simp only [comp_whiskerRight, Category.assoc] + rw [BraidedCategory.braiding_naturality_left μ[A] (M.X ⊗ R), + BraidedCategory.braiding_naturality_left_assoc + (pairRaw A M M' d ▷ A) (M.X ⊗ R)] + conv_lhs => rw [winLegM, pairStep] + conv_lhs => rw [associator_naturality_right_assoc] + conv_lhs => rw [← MonoidalCategory.whiskerLeft_comp_assoc] + conv_lhs => rw [hM] + conv_rhs => rw [pairStep] + conv_rhs => simp only [comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + conv_rhs => rw [MonObj.mul_assoc, + associator_naturality_left_assoc, ← whisker_exchange_assoc] + conv_lhs => simp only [MonoidalCategory.whiskerLeft_comp, + Category.assoc] + conv_lhs => rw [associator_inv_naturality_right_assoc, + whisker_exchange_assoc] + conv_rhs => rw [whisker_exchange_assoc] + exact slide_snd_core A M'.X M.X (Q ⊗ M'.X) R + (pairRaw A M M' d) (pairStep A M M' d r) + +/-- A slot leg at the top decomposes as the window against the +unitor: the empty right context is absorbed. -/ +private theorem leg_top_eq + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (M' : Mod D A) + (w : (M'.X ⊗ A) ⊗ M'.X ⟶ M'.X ⊗ M'.X) + (a : ℕ) : + ((tensorPow D M'.X a ◁ w) ▷ tensorPow D M'.X 0) ≫ + modPowGlue M'.X a 0 = + (ρ_ (tensorPow D M'.X a ⊗ ((M'.X ⊗ A) ⊗ M'.X))).hom ≫ + (tensorPow D M'.X a ◁ w) ≫ + (α_ (tensorPow D M'.X a) M'.X M'.X).inv := by + rw [modPowGlue, tensorPowConcat_zero] + change ((tensorPow D M'.X a ◁ w) ▷ 𝟙_ D) ≫ + ((α_ (tensorPow D M'.X a) M'.X M'.X).inv ▷ 𝟙_ D) ≫ + (ρ_ ((tensorPow D M'.X a ⊗ M'.X) ⊗ M'.X)).hom = _ + rw [← comp_whiskerRight_assoc, + MonoidalCategory.rightUnitor_naturality] + +/-- **The top slot relation of the power pairing**: at the slot +touching the last two factors of the `M'`-power, the two legs +pair equally. -/ +theorem rawPair_rel_fst_top + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (a : ℕ) : + (modPowLegM A M'.X a 0 ▷ tensorPow D M.X (a + 2)) ≫ + rawPair A M M' d (a + 2) = + (modPowLegN A M'.X a 0 ▷ tensorPow D M.X (a + 2)) ≫ + rawPair A M M' d (a + 2) := by + have hM : modPowLegM A M'.X a 0 = + (ρ_ (tensorPow D M'.X a ⊗ ((M'.X ⊗ A) ⊗ M'.X))).hom ≫ + (tensorPow D M'.X a ◁ winLegM A M'.X) ≫ + (α_ (tensorPow D M'.X a) M'.X M'.X).inv := by + rw [modPowLegM]; exact leg_top_eq A M' _ a + have hN : modPowLegN A M'.X a 0 = + (ρ_ (tensorPow D M'.X a ⊗ ((M'.X ⊗ A) ⊗ M'.X))).hom ≫ + (tensorPow D M'.X a ◁ winLegN A M'.X) ≫ + (α_ (tensorPow D M'.X a) M'.X M'.X).inv := by + rw [modPowLegN]; exact leg_top_eq A M' _ a + rw [hM, hN] + change (((ρ_ (tensorPow D M'.X a ⊗ ((M'.X ⊗ A) ⊗ M'.X))).hom ≫ + (tensorPow D M'.X a ◁ winLegM A M'.X) ≫ + (α_ (tensorPow D M'.X a) M'.X M'.X).inv) ▷ + tensorPow D M.X (a + 1 + 1)) ≫ + rawPair A M M' d (a + 1 + 1) = + (((ρ_ (tensorPow D M'.X a ⊗ ((M'.X ⊗ A) ⊗ M'.X))).hom ≫ + (tensorPow D M'.X a ◁ winLegN A M'.X) ≫ + (α_ (tensorPow D M'.X a) M'.X M'.X).inv) ▷ + tensorPow D M.X (a + 1 + 1)) ≫ + rawPair A M M' d (a + 1 + 1) + rw [rawPair_succ_step] + simp only [comp_whiskerRight] + repeat' erw [Category.assoc] + rw [cancel_epi] + change ((tensorPow D M'.X a ◁ winLegM A M'.X) ▷ + tensorPow D M.X (a + 1 + 1)) ≫ + ((α_ (tensorPow D M'.X a) M'.X M'.X).inv ▷ + tensorPow D M.X (a + 1 + 1)) ≫ + (((tensorPow D M'.X a ⊗ M'.X) ⊗ M'.X) ◁ + (powPeel M.X (a + 1)).hom) ≫ + pairStep A M M' d (rawPair A M M' d (a + 1)) = + ((tensorPow D M'.X a ◁ winLegN A M'.X) ▷ + tensorPow D M.X (a + 1 + 1)) ≫ + ((α_ (tensorPow D M'.X a) M'.X M'.X).inv ▷ + tensorPow D M.X (a + 1 + 1)) ≫ + (((tensorPow D M'.X a ⊗ M'.X) ⊗ M'.X) ◁ + (powPeel M.X (a + 1)).hom) ≫ + pairStep A M M' d (rawPair A M M' d (a + 1)) + rw [← whisker_exchange_assoc, ← whisker_exchange_assoc, + ← whisker_exchange_assoc] + rw [cancel_epi] + exact pairStep_slide A M M' d (rawPair A M M' d (a + 1)) + (rawPair_actRight_last A M M' d a) + +/-- A slot leg with a non-empty right context peels its top +factor: the leg at the extended context is the leg at the lower +context whiskered by the exposed factor. -/ +private theorem leg_step_eq + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (M' : Mod D A) + (w : (M'.X ⊗ A) ⊗ M'.X ⟶ M'.X ⊗ M'.X) + (a b : ℕ) : + ((tensorPow D M'.X a ◁ w) ▷ tensorPow D M'.X (b + 1)) ≫ + modPowGlue M'.X a (b + 1) = + (α_ (tensorPow D M'.X a ⊗ ((M'.X ⊗ A) ⊗ M'.X)) + (tensorPow D M'.X b) M'.X).inv ≫ + ((((tensorPow D M'.X a ◁ w) ▷ tensorPow D M'.X b) ≫ + modPowGlue M'.X a b) ▷ M'.X) := by + rw [modPowGlue, modPowGlue, tensorPowConcat_succ] + change ((tensorPow D M'.X a ◁ w) ▷ + (tensorPow D M'.X b ⊗ M'.X)) ≫ + ((α_ (tensorPow D M'.X a) M'.X M'.X).inv ▷ + (tensorPow D M'.X b ⊗ M'.X)) ≫ + (α_ ((tensorPow D M'.X a ⊗ M'.X) ⊗ M'.X) (tensorPow D M'.X b) + M'.X).inv ≫ + ((tensorPowConcat M'.X (a + 2) b).hom ▷ M'.X) = _ + erw [associator_inv_naturality_left_assoc, + associator_inv_naturality_left_assoc] + conv_rhs => erw [comp_whiskerRight, comp_whiskerRight] + rfl + +/-- **The first slot relations of the power pairing**: at every +slot of the `M'`-power, the two legs pair equally. -/ +theorem rawPair_rel_fst + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (a : ℕ) : + ∀ b : ℕ, + (modPowLegM A M'.X a b ▷ tensorPow D M.X (a + 2 + b)) ≫ + rawPair A M M' d (a + 2 + b) = + (modPowLegN A M'.X a b ▷ tensorPow D M.X (a + 2 + b)) ≫ + rawPair A M M' d (a + 2 + b) + | 0 => rawPair_rel_fst_top A M M' d a + | b + 1 => by + have hM : modPowLegM A M'.X a (b + 1) = + (α_ (tensorPow D M'.X a ⊗ ((M'.X ⊗ A) ⊗ M'.X)) + (tensorPow D M'.X b) M'.X).inv ≫ + (modPowLegM A M'.X a b ▷ M'.X) := by + rw [modPowLegM, modPowLegM] + exact leg_step_eq A M' _ a b + have hN : modPowLegN A M'.X a (b + 1) = + (α_ (tensorPow D M'.X a ⊗ ((M'.X ⊗ A) ⊗ M'.X)) + (tensorPow D M'.X b) M'.X).inv ≫ + (modPowLegN A M'.X a b ▷ M'.X) := by + rw [modPowLegN, modPowLegN] + exact leg_step_eq A M' _ a b + rw [hM, hN] + change (((α_ (tensorPow D M'.X a ⊗ ((M'.X ⊗ A) ⊗ M'.X)) + (tensorPow D M'.X b) M'.X).inv ≫ + (modPowLegM A M'.X a b ▷ M'.X)) ▷ + tensorPow D M.X (a + 2 + b + 1)) ≫ + rawPair A M M' d (a + 2 + b + 1) = + (((α_ (tensorPow D M'.X a ⊗ ((M'.X ⊗ A) ⊗ M'.X)) + (tensorPow D M'.X b) M'.X).inv ≫ + (modPowLegN A M'.X a b ▷ M'.X)) ▷ + tensorPow D M.X (a + 2 + b + 1)) ≫ + rawPair A M M' d (a + 2 + b + 1) + simp only [comp_whiskerRight] + repeat' erw [Category.assoc] + rw [cancel_epi] + rw [rawPair_succ_step] + change ((modPowLegM A M'.X a b ▷ M'.X) ▷ + tensorPow D M.X (a + 2 + b + 1)) ≫ + ((tensorPow D M'.X (a + 2 + b) ⊗ M'.X) ◁ + (powPeel M.X (a + 2 + b)).hom) ≫ + pairStep A M M' d (rawPair A M M' d (a + 2 + b)) = + ((modPowLegN A M'.X a b ▷ M'.X) ▷ + tensorPow D M.X (a + 2 + b + 1)) ≫ + ((tensorPow D M'.X (a + 2 + b) ⊗ M'.X) ◁ + (powPeel M.X (a + 2 + b)).hom) ≫ + pairStep A M M' d (rawPair A M M' d (a + 2 + b)) + rw [← whisker_exchange_assoc, ← whisker_exchange_assoc] + rw [pairStep_precomp, pairStep_precomp, + rawPair_rel_fst A M M' d a b] + +/-- **The second slot relations of the power pairing**: at every +slot of the `M`-power, the two legs pair equally. -/ +theorem rawPair_rel_snd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (b : ℕ) : + ∀ (a m : ℕ) (h : a + 2 + b = m), + (tensorPow D M'.X m ◁ + (modPowLegM A M.X a b ≫ powCast M.X h)) ≫ + rawPair A M M' d m = + (tensorPow D M'.X m ◁ + (modPowLegN A M.X a b ≫ powCast M.X h)) ≫ + rawPair A M M' d m + | 0, m, h => by + subst h + rw [rawPair_cast A M M' d (by omega : 0 + 2 + b = b + 1 + 1)] + erw [rawPair_succ_step, rawPair_succ_step, + ← pairStep_postcomp] + rw [powCast_rfl, Category.comp_id, Category.comp_id] + rw [whisker_exchange_assoc, whisker_exchange_assoc] + refine congrArg (CategoryStruct.comp _) ?_ + have hside : ∀ w : (M.X ⊗ A) ⊗ M.X ⟶ M.X ⊗ M.X, + (tensorPow D M'.X (b + 1 + 1) ◁ + (((tensorPow D M.X 0 ◁ w) ▷ tensorPow D M.X b) ≫ + modPowGlue M.X 0 b)) ≫ + (tensorPow D M'.X (b + 1 + 1) ◁ + powCast M.X (by omega : 0 + 2 + b = b + 1 + 1)) ≫ + (tensorPow D M'.X (b + 1 + 1) ◁ + (powPeel M.X (b + 1)).hom) ≫ + ((tensorPow D M'.X (b + 1) ⊗ M'.X) ◁ + (M.X ◁ (powPeel M.X b).hom)) ≫ + pairStep A M M' d + (pairStep A M M' d (rawPair A M M' d b)) = + ((tensorPow D M'.X (b + 1) ⊗ M'.X) ◁ + (((λ_ ((M.X ⊗ A) ⊗ M.X)).hom ▷ tensorPow D M.X b) ≫ + (w ▷ tensorPow D M.X b) ≫ + (α_ M.X M.X (tensorPow D M.X b)).hom)) ≫ + pairStep A M M' d + (pairStep A M M' d (rawPair A M M' d b)) := by + intro w + change ((tensorPow D M'.X (b + 1) ⊗ M'.X) ◁ + (((tensorPow D M.X 0 ◁ w) ▷ tensorPow D M.X b) ≫ + modPowGlue M.X 0 b)) ≫ + ((tensorPow D M'.X (b + 1) ⊗ M'.X) ◁ + powCast M.X (by omega : 0 + 2 + b = b + 1 + 1)) ≫ + ((tensorPow D M'.X (b + 1) ⊗ M'.X) ◁ + (powPeel M.X (b + 1)).hom) ≫ + ((tensorPow D M'.X (b + 1) ⊗ M'.X) ◁ + (M.X ◁ (powPeel M.X b).hom)) ≫ + pairStep A M M' d + (pairStep A M M' d (rawPair A M M' d b)) = _ + rw [← MonoidalCategory.whiskerLeft_comp_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc] + conv_lhs => simp only [Category.assoc] + rw [leg_head_snd_eq A w b] + rfl + refine ((hside (winLegM A M.X)).trans ?_).trans + (hside (winLegN A M.X)).symm + rw [MonoidalCategory.whiskerLeft_comp _ + ((λ_ ((M.X ⊗ A) ⊗ M.X)).hom ▷ tensorPow D M.X b), + MonoidalCategory.whiskerLeft_comp _ + ((λ_ ((M.X ⊗ A) ⊗ M.X)).hom ▷ tensorPow D M.X b), + Category.assoc, Category.assoc] + refine congrArg (CategoryStruct.comp + ((tensorPow D M'.X (b + 1) ⊗ M'.X) ◁ + ((λ_ ((M.X ⊗ A) ⊗ M.X)).hom ▷ tensorPow D M.X b))) ?_ + exact pairStep_slide_snd A M M' d (rawPair A M M' d b) + | a + 1, m, h => by + subst h + rw [powCast_rfl, Category.comp_id, Category.comp_id] + rw [rawPair_cast A M M' d + (by omega : a + 1 + 2 + b = a + 2 + b + 1)] + rw [rawPair_succ_step] + rw [whisker_exchange_assoc, whisker_exchange_assoc] + refine congrArg (CategoryStruct.comp _) ?_ + have hIH := rawPair_rel_snd A M M' d b a (a + 2 + b) rfl + rw [powCast_rfl, Category.comp_id, Category.comp_id] at hIH + have hstep : ∀ w : (M.X ⊗ A) ⊗ M.X ⟶ M.X ⊗ M.X, + (tensorPow D M'.X (a + 2 + b + 1) ◁ + (((tensorPow D M.X (a + 1) ◁ w) ▷ tensorPow D M.X b) ≫ + modPowGlue M.X (a + 1) b)) ≫ + (tensorPow D M'.X (a + 2 + b + 1) ◁ + powCast M.X + (by omega : a + 1 + 2 + b = a + 2 + b + 1)) ≫ + (tensorPow D M'.X (a + 2 + b + 1) ◁ + (powPeel M.X (a + 2 + b)).hom) ≫ + pairStep A M M' d (rawPair A M M' d (a + 2 + b)) = + (tensorPow D M'.X (a + 2 + b + 1) ◁ + (((powPeel M.X a).hom ▷ ((M.X ⊗ A) ⊗ M.X)) ▷ + tensorPow D M.X b)) ≫ + (tensorPow D M'.X (a + 2 + b + 1) ◁ + ((α_ M.X (tensorPow D M.X a) + ((M.X ⊗ A) ⊗ M.X)).hom ▷ tensorPow D M.X b)) ≫ + (tensorPow D M'.X (a + 2 + b + 1) ◁ + (α_ M.X (tensorPow D M.X a ⊗ ((M.X ⊗ A) ⊗ M.X)) + (tensorPow D M.X b)).hom) ≫ + ((tensorPow D M'.X (a + 2 + b) ⊗ M'.X) ◁ + (M.X ◁ (((tensorPow D M.X a ◁ w) ▷ + tensorPow D M.X b) ≫ modPowGlue M.X a b))) ≫ + pairStep A M M' d (rawPair A M M' d (a + 2 + b)) := by + intro w + have h := congrArg (fun t => (tensorPow D M'.X (a + 2 + b + 1) ◁ t) ≫ + pairStep A M M' d (rawPair A M M' d (a + 2 + b))) + (leg_step_snd_eq w a b) + simp only [modPowGlue, tensorPow, MonoidalCategory.whiskerLeft_comp, + Category.assoc] at h ⊢ + erw [MonoidalCategory.whiskerLeft_comp _ + (powCast M.X (by omega : a + 1 + 2 + b = a + 2 + b + 1)) + (powPeel M.X (a + 2 + b)).hom] at h + simpa only [Category.assoc] using! h + refine ((hstep (winLegM A M.X)).trans ?_).trans + (hstep (winLegN A M.X)).symm + refine congrArg (CategoryStruct.comp _) ?_ + refine congrArg (CategoryStruct.comp _) ?_ + refine congrArg (CategoryStruct.comp _) ?_ + exact (pairStep_postcomp A M M' d (modPowLegM A M.X a b) + (rawPair A M M' d (a + 2 + b))).trans + ((congrArg (pairStep A M M' d) hIH).trans + (pairStep_postcomp A M M' d (modPowLegN A M.X a b) + (rawPair A M M' d (a + 2 + b))).symm) + +/-- **Extraction propagates through the step**: the step over an +extracted continuation is the extraction of the step, with the +scalar crossing the continuation block. -/ +theorem pairStep_ext [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + {Q R : D} (r : Q ⊗ R ⟶ A) : + pairStep A M M' d ((Q ◁ (β_ A R).hom) ≫ + (α_ Q R A).inv ≫ (r ▷ A) ≫ μ[A]) = + ((Q ⊗ M'.X) ◁ (M.X ◁ (β_ A R).hom)) ≫ + ((Q ⊗ M'.X) ◁ (α_ M.X R A).inv) ≫ + (α_ (Q ⊗ M'.X) (M.X ⊗ R) A).inv ≫ + (pairStep A M M' d r ▷ A) ≫ μ[A] := by + conv_lhs => rw [pairStep] + conv_lhs => simp only [comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + conv_lhs => rw [MonObj.mul_assoc, + associator_naturality_left_assoc, ← whisker_exchange_assoc] + conv_rhs => rw [pairStep] + conv_rhs => simp only [comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + conv_rhs => rw [MonObj.mul_assoc, + associator_naturality_left_assoc, ← whisker_exchange_assoc] + conv_lhs => rw [BraidedCategory.braiding_tensor_right_hom + A A R] + conv_rhs => rw [show ((Q ⊗ R) ◁ μ[A]) = + ((Q ⊗ R) ◁ ((β_ A A).hom ≫ μ[A])) from + congrArg (fun t => (Q ⊗ R) ◁ t) + (IsCommMonObj.mul_comm A).symm] + conv_rhs => rw [MonoidalCategory.whiskerLeft_comp] + trans ((α_ Q M'.X (M.X ⊗ (A ⊗ R))).hom ≫ + (Q ◁ (α_ M'.X M.X (A ⊗ R)).inv) ≫ + (Q ◁ (pairRaw A M M' d ▷ (A ⊗ R))) ≫ + (Q ◁ ((α_ A A R).inv ≫ ((β_ A A).hom ▷ R) ≫ + (α_ A A R).hom ≫ (A ◁ (β_ A R).hom) ≫ + (α_ A R A).inv ≫ ((β_ A R).hom ▷ A) ≫ + (α_ R A A).hom)) ≫ + (Q ◁ (R ◁ μ[A])) ≫ + (α_ Q R A).inv ≫ (r ▷ A) ≫ μ[A]) + · monoidal + · rw [BraidedCategory.yang_baxter] + rw [← MonoidalCategory.whiskerLeft_comp_assoc Q + (pairRaw A M M' d ▷ (A ⊗ R))] + rw [← whisker_exchange_assoc] + simp only [MonoidalCategory.whiskerLeft_comp, + Category.assoc] + monoidal + +/-- The tail action passes the head peel: acting on the last +factor and peeling the head equals peeling, braiding past the +exposed head, and acting on the tail below. -/ +private theorem powTailAct_peel + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + [BraidedCategory D] {X : D} + [ModObj A X] (n : ℕ) : + powTailAct A X (n + 1) ≫ (powPeel X (n + 1)).hom = + (A ◁ (powPeel X (n + 1)).hom) ≫ + (braidPast A X (tensorPow D X (n + 1))).hom ≫ + (X ◁ powTailAct A X n) := by + rw [powTailAct_eq, powTailAct_eq] + rw [show (powPeel X (n + 1)).hom = + ((powPeel X n).hom ▷ X) ≫ + (α_ X (tensorPow D X n) X).hom from rfl] + change actAcross A (tensorPow D X (n + 1)) X ≫ + ((powPeel X n).hom ▷ X) ≫ + (α_ X (tensorPow D X n) X).hom = + (A ◁ (((powPeel X n).hom ▷ X) ≫ + (α_ X (tensorPow D X n) X).hom)) ≫ + (braidPast A X (tensorPow D X n ⊗ X)).hom ≫ + (X ◁ actAcross A (tensorPow D X n) X) + rw [← actAcross_natural_assoc, actAcross_context_split] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + +/-- **Scalar extraction at the tail of the `M`-power**: the tail +action on the `M`-power extracts as the scalar braiding past the +whole power and multiplying the pairing from the right. -/ +theorem rawPair_actTail + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + ∀ n : ℕ, + (tensorPow D M'.X (n + 1) ◁ powTailAct A M.X n) ≫ + rawPair A M M' d (n + 1) = + (tensorPow D M'.X (n + 1) ◁ + (β_ A (tensorPow D M.X (n + 1))).hom) ≫ + (α_ (tensorPow D M'.X (n + 1)) (tensorPow D M.X (n + 1)) + A).inv ≫ + (rawPair A M M' d (n + 1) ▷ A) ≫ μ[A] + | 0 => by + have hact : powTailAct A M.X 0 ≫ (powPeel M.X 0).hom = + (A ◁ (powPeel M.X 0).hom) ≫ + (α_ A M.X (tensorPow D M.X 0)).inv ≫ + (actLeft A M.X ▷ tensorPow D M.X 0) := by + rw [powTailAct_eq] + change ((α_ A (tensorPow D M.X 0) M.X).inv ≫ + ((β_ A (𝟙_ D)).hom ▷ M.X) ≫ + (α_ (𝟙_ D) A M.X).hom ≫ + ((𝟙_ D) ◁ actLeft A M.X)) ≫ + ((λ_ M.X).hom ≫ (ρ_ M.X).inv) = + (A ◁ ((λ_ M.X).hom ≫ (ρ_ M.X).inv)) ≫ + (α_ A M.X (𝟙_ D)).inv ≫ + (actLeft A M.X ▷ 𝟙_ D) + rw [braiding_tensorUnit_right] + monoidal + rw [rawPair_succ_step] + conv_lhs => erw [← MonoidalCategory.whiskerLeft_comp_assoc, + hact] + conv_lhs => simp only [MonoidalCategory.whiskerLeft_comp] + conv_lhs => erw [Category.assoc, Category.assoc] + change ((tensorPow D M'.X 0 ⊗ M'.X) ◁ + (A ◁ (powPeel M.X 0).hom)) ≫ + ((tensorPow D M'.X 0 ⊗ M'.X) ◁ + (α_ A M.X (tensorPow D M.X 0)).inv) ≫ + ((tensorPow D M'.X 0 ⊗ M'.X) ◁ + (actLeft A M.X ▷ tensorPow D M.X 0)) ≫ + pairStep A M M' d (rawPair A M M' d 0) = _ + rw [← MonoidalCategory.whiskerLeft_comp_assoc + (tensorPow D M'.X 0 ⊗ M'.X) + (α_ A M.X (tensorPow D M.X 0)).inv] + rw [pairStep_actHead] + conv_rhs => erw [comp_whiskerRight] + conv_rhs => simp only [Category.assoc] + conv_rhs => rw [← associator_inv_naturality_middle_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + ← BraidedCategory.braiding_naturality_right, + MonoidalCategory.whiskerLeft_comp] + conv_rhs => + rw [show (tensorPow D M'.X 1 ◁ + (A ◁ (powPeel M.X 0).hom)) = + ((tensorPow D M'.X 0 ⊗ M'.X) ◁ + (A ◁ (powPeel M.X 0).hom)) from rfl] + conv_rhs => erw [Category.assoc] + refine congrArg (CategoryStruct.comp + ((tensorPow D M'.X 0 ⊗ M'.X) ◁ + (A ◁ (powPeel M.X 0).hom))) ?_ + monoidal + | n + 1 => by + rw [rawPair_succ_step] + conv_lhs => erw [← MonoidalCategory.whiskerLeft_comp_assoc, + powTailAct_peel A] + conv_lhs => simp only [MonoidalCategory.whiskerLeft_comp] + conv_lhs => erw [Category.assoc, Category.assoc] + change ((tensorPow D M'.X (n + 1) ⊗ M'.X) ◁ + (A ◁ (powPeel M.X (n + 1)).hom)) ≫ + ((tensorPow D M'.X (n + 1) ⊗ M'.X) ◁ + (braidPast A M.X (tensorPow D M.X (n + 1))).hom) ≫ + ((tensorPow D M'.X (n + 1) ⊗ M'.X) ◁ + (M.X ◁ powTailAct A M.X n)) ≫ + pairStep A M M' d (rawPair A M M' d (n + 1)) = _ + rw [pairStep_postcomp] + rw [rawPair_actTail A M M' d n] + rw [pairStep_ext] + conv_rhs => erw [comp_whiskerRight] + conv_rhs => simp only [Category.assoc] + conv_rhs => rw [← associator_inv_naturality_middle_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + ← BraidedCategory.braiding_naturality_right, + MonoidalCategory.whiskerLeft_comp] + conv_rhs => + rw [show (tensorPow D M'.X (n + 1 + 1) ◁ + (A ◁ (powPeel M.X (n + 1)).hom)) = + ((tensorPow D M'.X (n + 1) ⊗ M'.X) ◁ + (A ◁ (powPeel M.X (n + 1)).hom)) from rfl] + conv_rhs => erw [Category.assoc] + refine congrArg (CategoryStruct.comp + ((tensorPow D M'.X (n + 1) ⊗ M'.X) ◁ + (A ◁ (powPeel M.X (n + 1)).hom))) ?_ + conv_rhs => rw [BraidedCategory.braiding_tensor_right_hom + A M.X (tensorPow D M.X (n + 1))] + simp only [braidPast_hom, MonoidalCategory.whiskerLeft_comp, + Category.assoc] + monoidal + +/-- Braiding the scalar over the whole power and acting across to +the tail equals the braided right action at the last slot. -/ +private theorem braid_powTailAct + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] + {X : D} [ModObj A X] (n : ℕ) : + (β_ (tensorPow D X (n + 1)) A).hom ≫ powTailAct A X n = + (α_ (tensorPow D X n) X A).hom ≫ + (tensorPow D X n ◁ actRight A X) := by + rw [powTailAct_eq] + change (β_ (tensorPow D X n ⊗ X) A).hom ≫ + ((α_ A (tensorPow D X n) X).inv ≫ + ((β_ A (tensorPow D X n)).hom ▷ X) ≫ + (α_ (tensorPow D X n) A X).hom ≫ + (tensorPow D X n ◁ actLeft A X)) = _ + rw [BraidedCategory.braiding_tensor_left_hom] + simp only [Category.assoc, Iso.hom_inv_id_assoc] + rw [← comp_whiskerRight_assoc, SymmetricCategory.symmetry] + rw [actRight] + simp only [MonoidalCategory.id_whiskerRight, Category.id_comp, + MonoidalCategory.whiskerLeft_comp] + monoidal + +/-! ## The descended pairing + +The two-stage descent of the raw pairing through the module-power +coequalizers, mirroring the descent of the raw multiplication: +the slot relations assemble over the biproduct legs, the first +stage descends the `M'`-power against the ambient `M`-power, and +the second stage descends the `M`-power. +-/ + +section Descent + +/-- The first assembled leg as a sum over the slots. -/ +private theorem legFst_eq_sum' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [Preadditive D] [HasFiniteBiproducts D] + {X : D} [ModObj A X] (n : ℕ) : + modPowLegFst A X n = ∑ i : Fin (n - 1), + biproduct.π (fun i : Fin (n - 1) => + modPowMid A X i.val (n - 2 - i.val)) i ≫ + (modPowLegM A X i.val (n - 2 - i.val) ≫ + powCast X (slot_decomp i)) := by + conv_lhs => rw [← Category.id_comp (modPowLegFst A X n), + ← biproduct.total] + rw [Preadditive.sum_comp] + refine Finset.sum_congr rfl fun i _ => ?_ + rw [Category.assoc, modPowLegFst, biproduct.ι_desc] + +/-- The second assembled leg as a sum over the slots. -/ +private theorem legSnd_eq_sum' + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] [Preadditive D] + [HasFiniteBiproducts D] + {X : D} [ModObj A X] (n : ℕ) : + modPowLegSnd A X n = ∑ i : Fin (n - 1), + biproduct.π (fun i : Fin (n - 1) => + modPowMid A X i.val (n - 2 - i.val)) i ≫ + (modPowLegN A X i.val (n - 2 - i.val) ≫ + powCast X (slot_decomp i)) := by + conv_lhs => rw [← Category.id_comp (modPowLegSnd A X n), + ← biproduct.total] + rw [Preadditive.sum_comp] + refine Finset.sum_congr rfl fun i _ => ?_ + rw [Category.assoc, modPowLegSnd, biproduct.ι_desc] + +/-- A slot-wise condition assembles over the right-whiskered +legs. -/ +private theorem legs_whiskerRight_cond' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] + {X : D} [ModObj A X] + {m : ℕ} {W Z : D} (k : tensorPow D X m ⊗ W ⟶ Z) + (h : ∀ a b (hab : a + 2 + b = m), + ((modPowLegM A X a b ≫ powCast X hab) ▷ W) ≫ k = + ((modPowLegN A X a b ≫ powCast X hab) ▷ W) ≫ k) : + (modPowLegFst A X m ▷ W) ≫ k = + (modPowLegSnd A X m ▷ W) ≫ k := by + rw [legFst_eq_sum' A, legSnd_eq_sum' A] + rw [sum_whiskerRight, sum_whiskerRight, + Preadditive.sum_comp, Preadditive.sum_comp] + refine Finset.sum_congr rfl fun i _ => ?_ + have hi := h i.val (m - 2 - i.val) (slot_decomp i) + simp only [MonoidalCategory.comp_whiskerRight, + Category.assoc] at hi ⊢ + rw [hi] + +/-- A slot-wise condition assembles over the left-whiskered +legs. -/ +private theorem legs_whiskerLeft_cond' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] + {X : D} [ModObj A X] + {n : ℕ} {W Z : D} (k : W ⊗ tensorPow D X n ⟶ Z) + (h : ∀ a b (hab : a + 2 + b = n), + (W ◁ (modPowLegM A X a b ≫ powCast X hab)) ≫ k = + (W ◁ (modPowLegN A X a b ≫ powCast X hab)) ≫ k) : + (W ◁ modPowLegFst A X n) ≫ k = + (W ◁ modPowLegSnd A X n) ≫ k := by + rw [legFst_eq_sum' A, legSnd_eq_sum' A] + rw [whiskerLeft_sum, whiskerLeft_sum, + Preadditive.sum_comp, Preadditive.sum_comp] + refine Finset.sum_congr rfl fun i _ => ?_ + have hi := h i.val (n - 2 - i.val) (slot_decomp i) + simp only [MonoidalCategory.whiskerLeft_comp, + Category.assoc] at hi ⊢ + rw [hi] + +/-- The first slot relations, in cast-carrying form. -/ +theorem rawPair_rel_fst' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') {m : ℕ} + (a b : ℕ) (hab : a + 2 + b = m) : + ((modPowLegM A M'.X a b ≫ powCast M'.X hab) ▷ + tensorPow D M.X m) ≫ rawPair A M M' d m = + ((modPowLegN A M'.X a b ≫ powCast M'.X hab) ▷ + tensorPow D M.X m) ≫ rawPair A M M' d m := by + subst hab + rw [powCast_rfl, Category.comp_id, Category.comp_id] + exact rawPair_rel_fst A M M' d a b + +/-- **The first stage of the pairing descent**: the raw pairing +descends through the `M'`-power against the ambient +`M`-power. -/ +noncomputable def pairPowStage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [Preadditive D] [HasFiniteBiproducts D] [MonoidalPreadditive D] + (d : ModDualityDatum A M M') + (n : ℕ) : + modPow A M'.X n ⊗ tensorPow D M.X n ⟶ A := + modPowWhiskerRightDesc A M'.X n (tensorPow D M.X n) + (rawPair A M M' d n) + (by + exact legs_whiskerRight_cond' A (rawPair A M M' d n) + (fun a b hab => rawPair_rel_fst' A M M' d a b hab)) + +/-- Defining equation of the first stage. -/ +@[reassoc (attr := simp)] +theorem modPowπ_whiskerRight_pairPowStage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [Preadditive D] [HasFiniteBiproducts D] [MonoidalPreadditive D] + (d : ModDualityDatum A M M') (n : ℕ) : + (modPowπ A M'.X n ▷ tensorPow D M.X n) ≫ + pairPowStage A M M' d n = rawPair A M M' d n := + modPowπ_whiskerRight_desc A M'.X n (tensorPow D M.X n) _ _ + +/-- The first stage coequalizes the left-whiskered legs of the +`M`-power. -/ +theorem pairPowStage_cond + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [Preadditive D] [HasFiniteBiproducts D] [MonoidalPreadditive D] + (d : ModDualityDatum A M M') (n : ℕ) : + (modPow A M'.X n ◁ modPowLegFst A M.X n) ≫ + pairPowStage A M M' d n = + (modPow A M'.X n ◁ modPowLegSnd A M.X n) ≫ + pairPowStage A M M' d n := by + apply modPow_whiskerRight_hom_ext A M'.X n + (modPowSrc A M.X n) + rw [← MonoidalCategory.whisker_exchange_assoc, + ← MonoidalCategory.whisker_exchange_assoc, + modPowπ_whiskerRight_pairPowStage] + exact legs_whiskerLeft_cond' A (rawPair A M M' d n) + (fun a b hab => rawPair_rel_snd A M M' d b a n hab) + +/-- **The descended power pairing** on the module powers, in two +stages. -/ +noncomputable def pairPow + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [Preadditive D] [HasFiniteBiproducts D] [MonoidalPreadditive D] + (d : ModDualityDatum A M M') (n : ℕ) : + modPow A M'.X n ⊗ modPow A M.X n ⟶ A := + modPowWhiskerLeftDesc A M.X (modPow A M'.X n) n + (pairPowStage A M M' d n) (pairPowStage_cond A M M' d n) + +/-- Defining equation of the descended pairing. -/ +@[reassoc (attr := simp)] +theorem modPowπ_tensor_pairPow + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [Preadditive D] [HasFiniteBiproducts D] [MonoidalPreadditive D] + (d : ModDualityDatum A M M') + (n : ℕ) : + (modPowπ A M'.X n ⊗ₘ modPowπ A M.X n) ≫ + pairPow A M M' d n = rawPair A M M' d n := by + rw [MonoidalCategory.tensorHom_def, Category.assoc, pairPow] + rw [modPowπ_whiskerLeft_desc A M.X (modPow A M'.X n) n _ _] + exact modPowπ_whiskerRight_pairPowStage A M M' d n + +/-- **The middle relation**: the descended pairing coequalizes +the module-tensor legs of the power bundles. -/ +theorem pairPow_middle_cond + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [Preadditive D] [HasFiniteBiproducts D] [MonoidalPreadditive D] + (d : ModDualityDatum A M M') + (n : ℕ) : + modTensorLegM A (modPowMod A M'.X n) (modPowMod A M.X n) ≫ + pairPow A M M' d (n + 1) = + modTensorLegN A (modPowMod A M'.X n) (modPowMod A M.X n) ≫ + pairPow A M M' d (n + 1) := by + rw [modTensorLegM, modTensorLegN] + let := modPowModObj A M'.X n + let := modPowModObj A M.X n + change (actRight A (modPow A M'.X (n + 1)) ▷ + modPow A M.X (n + 1)) ≫ pairPow A M M' d (n + 1) = + ((α_ (modPow A M'.X (n + 1)) A (modPow A M.X (n + 1))).hom ≫ + (modPow A M'.X (n + 1) ◁ + actLeft A (modPow A M.X (n + 1)))) ≫ + pairPow A M M' d (n + 1) + apply modPow_whiskerLeft_hom_ext A M.X + (modPow A M'.X (n + 1) ⊗ A) (n + 1) + conv_lhs => rw [whisker_exchange_assoc, pairPow, + modPowπ_whiskerLeft_desc] + conv_rhs => simp only [Category.assoc] + conv_rhs => rw [associator_naturality_right_assoc, + show actLeft A (modPow A M.X (n + 1)) = + modPowAct A M.X n from rfl, + ← MonoidalCategory.whiskerLeft_comp_assoc, + whiskerLeft_modPowπ_modPowAct, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + pairPow, modPowπ_whiskerLeft_desc] + rw [← cancel_epi ((α_ (modPow A M'.X (n + 1)) A + (tensorPow D M.X (n + 1))).inv)] + apply modPow_whiskerRight_hom_ext A M'.X (n + 1) + (A ⊗ tensorPow D M.X (n + 1)) + simp only [Iso.inv_hom_id_assoc] + conv_rhs => rw [← whisker_exchange_assoc, + modPowπ_whiskerRight_pairPowStage, + rawPair_actTail A M M' d n] + have hM' : (modPowπ A M'.X (n + 1) ▷ A) ≫ + actRight A (modPow A M'.X (n + 1)) = + (β_ (tensorPow D M'.X (n + 1)) A).hom ≫ + powTailAct A M'.X n ≫ modPowπ A M'.X (n + 1) := by + rw [actRight, + show actLeft A (modPow A M'.X (n + 1)) = + modPowAct A M'.X n from rfl, + BraidedCategory.braiding_naturality_left_assoc, + whiskerLeft_modPowπ_modPowAct] + rw [reassoc_of% braid_powTailAct A n] at hM' + have hM'w := congrArg + (fun t => t ▷ tensorPow D M.X (n + 1)) hM' + conv_lhs => rw [associator_inv_naturality_left_assoc, + ← comp_whiskerRight_assoc, hM'w] + have hstage1 : ∀ {Y : D} (x : Y ⟶ tensorPow D M'.X (n + 1)), + ((x ≫ modPowπ A M'.X (n + 1)) ▷ + tensorPow D M.X (n + 1)) ≫ + pairPowStage A M M' d (n + 1) = + (x ▷ tensorPow D M.X (n + 1)) ≫ + rawPair A M M' d (n + 1) := by + intro Y x + rw [comp_whiskerRight, Category.assoc, + modPowπ_whiskerRight_pairPowStage] + have hstage : ∀ {Y Y' : D} (f : Y ⟶ Y') + (g : Y' ⟶ tensorPow D M'.X n ⊗ M'.X), + (((f ≫ g) ≫ modPowπ A M'.X (n + 1)) ▷ + tensorPow D M.X (n + 1)) ≫ + pairPowStage A M M' d (n + 1) = + (f ▷ tensorPow D M.X (n + 1)) ≫ + (g ▷ tensorPow D M.X (n + 1)) ≫ + rawPair A M M' d (n + 1) := by + intro Y Y' f g + refine (hstage1 (f ≫ g)).trans ?_ + erw [comp_whiskerRight, Category.assoc] + rfl + refine Eq.trans (congrArg (fun t => + (α_ (tensorPow D M'.X (n + 1)) A + (tensorPow D M.X (n + 1))).inv ≫ t) (hstage _ _)) ?_ + conv_lhs => rw [rawPair_actRight_last A M M' d n] + monoidal + +/-- **The Mod-internal power pairing**: the descended pairing on +the module tensor product of the power bundles. -/ +noncomputable def modPowPairing + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [Preadditive D] [HasFiniteBiproducts D] [MonoidalPreadditive D] + (d : ModDualityDatum A M M') + (n : ℕ) : + modTensor A (modPowMod A M'.X n) (modPowMod A M.X n) ⟶ A := + modTensorDesc A (modPowMod A M'.X n) (modPowMod A M.X n) + (pairPow A M M' d (n + 1)) (pairPow_middle_cond A M M' d n) + +/-- Defining equation of the Mod-internal power pairing. -/ +@[reassoc (attr := simp)] +theorem modTensorπ_modPowPairing + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [Preadditive D] [HasFiniteBiproducts D] [MonoidalPreadditive D] + (d : ModDualityDatum A M M') + (n : ℕ) : + modTensorπ A (modPowMod A M'.X n) (modPowMod A M.X n) ≫ + modPowPairing A M M' d n = + pairPow A M M' d (n + 1) := + modTensorπ_desc A _ _ _ _ + +section SymDescent + +/-- The section of the symmetric power, as a morphism of +modules. -/ +noncomputable def symPowσMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] [Preadditive D] + [HasFiniteBiproducts D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + {X : D} [ModObj A X] (n : ℕ) : + symPowMod A X n ⟶ modPowMod A X n := + letI := symPowModObj A X n + letI := modPowModObj A X n + Mod.Hom.mk (symPowσ A X (n + 1)) + (isModHom := ⟨(symPowσ_modPowAct A X n).symm⟩) + +@[simp] theorem symPowσMod_hom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] [Preadditive D] + [HasFiniteBiproducts D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + {X : D} [ModObj A X] (n : ℕ) : + (symPowσMod A (X := X) n).hom = symPowσ A X (n + 1) := + rfl + +/-- **The symmetric power pairing**: the Mod-internal pairing on +the symmetric powers, through the sections. -/ +noncomputable def symPowPairing + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [Preadditive D] [HasFiniteBiproducts D] [MonoidalPreadditive D] + [Linear ℂ D] [MonoidalLinear ℂ D] + (d : ModDualityDatum A M M') + (n : ℕ) : + modTensor A (symPowMod A M'.X n) (symPowMod A M.X n) ⟶ A := + modTensorMap A (symPowσMod A n) (symPowσMod A n) ≫ + modPowPairing A M M' d n + +/-- Defining equation of the symmetric power pairing. -/ +@[reassoc (attr := simp)] +theorem modTensorπ_symPowPairing + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [Preadditive D] [HasFiniteBiproducts D] [MonoidalPreadditive D] + [Linear ℂ D] [MonoidalLinear ℂ D] + (d : ModDualityDatum A M M') + (n : ℕ) : + modTensorπ A (symPowMod A M'.X n) (symPowMod A M.X n) ≫ + symPowPairing A M M' d n = + (symPowσ A M'.X (n + 1) ⊗ₘ symPowσ A M.X (n + 1)) ≫ + pairPow A M M' d (n + 1) := by + rw [symPowPairing, modTensorπ_map_assoc, + modTensorπ_modPowPairing] + rfl + +end SymDescent + +end Descent + +end Symmetric + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPoint.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPoint.lean new file mode 100644 index 0000000000..6b1f790c75 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPoint.lean @@ -0,0 +1,351 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.UnitEnd +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermNat +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitMod + +/-! +# Point powers and the trivial permutation action on unit strands + +The tensor powers of a point of an object, and their invariance +under the permutation action: permutations act trivially on powers +of the unit object, and naturality carries the invariance onto the +point powers. In a rigid category the point powers of a +monomorphism are monomorphisms. The substrate of the +nonvanishing of the local splitting algebra. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {D : Type u} + +/-- The top transposition on a power of the unit is the +identity. -/ +theorem swapTop_unit [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (n : ℕ) : + swapTop (𝟙_ D) n = 𝟙 (tensorPow D (𝟙_ D) (n + 2)) := by + unfold swapTop + erw [braiding_unit_self, MonoidalCategory.whiskerLeft_id, + Category.id_comp, Iso.hom_inv_id] + +/-- Every adjacent transposition acts trivially on a power of the +unit. -/ +theorem permMor_unit_adjSwap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] : + ∀ (n : ℕ) (i : Fin (n + 1)), + permMor (𝟙_ D) (n + 2) (Equiv.swap i.castSucc i.succ) = + 𝟙 (tensorPow D (𝟙_ D) (n + 2)) := by + intro n + induction n with + | zero => + intro i + refine Fin.lastCases ?_ (fun j => j.elim0) i + rw [show Equiv.swap (Fin.castSucc (Fin.last 0)) + (Fin.last 0).succ + = (topSwap : Equiv.Perm (Fin 2)) from by + rw [topSwap, Fin.succ_last], + permMor_topSwap_eq] + exact swapTop_unit 0 + | succ n ih => + intro i + refine Fin.lastCases ?_ (fun j => ?_) i + · rw [show Equiv.swap (Fin.castSucc (Fin.last (n + 1))) + (Fin.last (n + 1)).succ + = (topSwap : Equiv.Perm (Fin (n + 3))) from by + rw [topSwap, Fin.succ_last], + permMor_topSwap_eq] + exact swapTop_unit (n + 1) + · rw [swap_castSucc_succ_castSucc j, permMor_extPerm, ih j] + exact MonoidalCategory.id_whiskerRight _ _ + +/-- **Permutations act trivially on powers of the unit**: every +adjacent transposition does, and the action and the trivial +character are both multiplicative. -/ +theorem permMor_unit [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (n : ℕ) (σ : Equiv.Perm (Fin n)) : + permMor (𝟙_ D) n σ = 𝟙 (tensorPow D (𝟙_ D) n) := by + match n, σ with + | 0, σ => + have hσ : σ = 1 := Equiv.ext fun x => x.elim0 + rw [hσ, permMor_one] + | 1, σ => + have hσ : σ = 1 := Equiv.ext fun x => Fin.ext (by omega) + rw [hσ, permMor_one] + | n + 2, σ => + have key : ∀ τ : Equiv.Perm (Fin (n + 2)), + τ ∈ Submonoid.closure (Set.range fun i : Fin (n + 1) => + Equiv.swap i.castSucc i.succ) → + permMor (𝟙_ D) (n + 2) τ = + 𝟙 (tensorPow D (𝟙_ D) (n + 2)) := by + intro τ hτ + induction hτ using Submonoid.closure_induction_left with + | one => rw [permMor_one] + | mul_left g hg τ' hτ' ihτ' => + obtain ⟨i, rfl⟩ := hg + rw [permMor_mul, ihτ', permMor_unit_adjSwap n i] + simp + exact key σ (by + rw [Equiv.Perm.mclosure_swap_castSucc_succ]; trivial) + +section Point + +/-- The powers of the unit collapse onto the unit. -/ +noncomputable def unitPow [Category.{v} D] [MonoidalCategory D] : (n : ℕ) → + (tensorPow D (𝟙_ D) n ≅ 𝟙_ D) + | 0 => Iso.refl _ + | (n + 1) => (ρ_ (tensorPow D (𝟙_ D) n)) ≪≫ unitPow n + +variable {Y} in +/-- **The power of a point**: the collapsed unit power carried +into the power of the target. -/ +noncomputable def tensorPowPoint + [Category.{v} D] [MonoidalCategory D] {Y : D} (pt : 𝟙_ D ⟶ Y) + (n : ℕ) : + 𝟙_ D ⟶ tensorPow D Y n := + (unitPow n).inv ≫ tensorPowMap pt n + +variable {Y} in +/-- In a rigid category the power of a monic point is monic. -/ +theorem tensorPowPoint_mono + [Category.{v} D] [MonoidalCategory D] {Y : D} (pt : 𝟙_ D ⟶ Y) + [RigidCategory D] [Mono pt] (n : ℕ) : + Mono (tensorPowPoint pt n) := by + have := tensorPowMap_mono pt n + exact mono_comp _ _ + +variable {Y} in +/-- The power of a monic point is monic, from mono preservation +of the tensor factors alone. -/ +theorem tensorPowPoint_mono' + [Category.{v} D] [MonoidalCategory D] {Y : D} (pt : 𝟙_ D ⟶ Y) + [∀ Z : D, (tensorLeft Z).PreservesMonomorphisms] + [∀ Z : D, (tensorRight Z).PreservesMonomorphisms] + [Mono pt] (n : ℕ) : + Mono (tensorPowPoint pt n) := by + have := tensorPowMap_mono' pt n + exact mono_comp _ _ + +variable {Y} in +/-- The empty point power is the identity. -/ +theorem tensorPowPoint_zero + [Category.{v} D] [MonoidalCategory D] {Y : D} (pt : 𝟙_ D ⟶ Y) : + tensorPowPoint pt 0 = 𝟙 (𝟙_ D) := by + rw [tensorPowPoint, tensorPowMap_zero] + exact Category.comp_id _ + +variable {Y} in +/-- The recursion of the point powers: one more letter joins on +the right. -/ +theorem tensorPowPoint_succ + [Category.{v} D] [MonoidalCategory D] {Y : D} (pt : 𝟙_ D ⟶ Y) + (n : ℕ) : + tensorPowPoint pt (n + 1) = + (ρ_ (𝟙_ D)).inv ≫ (tensorPowPoint pt n ⊗ₘ pt) := by + rw [tensorPowPoint, tensorPowPoint, tensorPowMap_succ] + have hsplit : ((unitPow n).inv ≫ tensorPowMap pt n) ⊗ₘ pt = + ((unitPow n).inv ▷ (𝟙_ D)) ≫ + (tensorPowMap pt n ⊗ₘ pt) := by + rw [← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.id_comp] + rw [hsplit] + exact (eq_whisker (rightUnitor_inv_naturality + ((unitPow n).inv)) _).trans (Category.assoc _ _ _) + +variable {Y} in +/-- **Point powers concatenate**: the tensor of two point powers +meets the concatenation as the joint point power. -/ +theorem tensorPowPoint_concat + [Category.{v} D] [MonoidalCategory D] {Y : D} (pt : 𝟙_ D ⟶ Y) + (m : ℕ) : + ∀ n : ℕ, + (tensorPowPoint pt m ⊗ₘ tensorPowPoint pt n) ≫ + (tensorPowConcat Y m n).hom = + (λ_ (𝟙_ D)).hom ≫ tensorPowPoint pt (m + n) + | 0 => by + have hnat : (tensorPowPoint pt m ▷ (𝟙_ D)) ≫ + (ρ_ (tensorPow D Y m)).hom = + (ρ_ (𝟙_ D)).hom ≫ tensorPowPoint pt m := + rightUnitor_naturality _ + calc (tensorPowPoint pt m ⊗ₘ tensorPowPoint pt 0) ≫ + (tensorPowConcat Y m 0).hom + = (tensorPowPoint pt m ⊗ₘ 𝟙 (𝟙_ D)) ≫ + (ρ_ (tensorPow D Y m)).hom := by + rw [tensorPowPoint_zero] + rfl + _ = (ρ_ (𝟙_ D)).hom ≫ tensorPowPoint pt m := by + rw [MonoidalCategory.tensorHom_id] + exact hnat + _ = (λ_ (𝟙_ D)).hom ≫ tensorPowPoint pt (m + 0) := by + rw [unitors_equal] + rfl + | (n + 1) => by + have hsucc := tensorPowPoint_succ (pt := pt) n + have hdec : tensorPowPoint pt m ⊗ₘ + ((ρ_ (𝟙_ D)).inv ≫ + (tensorPowPoint pt n ⊗ₘ pt)) = + ((𝟙 (𝟙_ D)) ⊗ₘ (ρ_ (𝟙_ D)).inv) ≫ + (tensorPowPoint pt m ⊗ₘ + (tensorPowPoint pt n ⊗ₘ pt)) := by + rw [MonoidalCategory.tensorHom_comp_tensorHom, + Category.id_comp] + have hα : (tensorPowPoint pt m ⊗ₘ + (tensorPowPoint pt n ⊗ₘ pt)) ≫ + (α_ (tensorPow D Y m) (tensorPow D Y n) Y).inv = + (α_ (𝟙_ D) (𝟙_ D) (𝟙_ D)).inv ≫ + ((tensorPowPoint pt m ⊗ₘ tensorPowPoint pt n) ⊗ₘ + pt) := + associator_inv_naturality _ _ _ + have hIH : ((tensorPowPoint pt m ⊗ₘ + tensorPowPoint pt n) ⊗ₘ pt) ≫ + ((tensorPowConcat Y m n).hom ▷ Y) = + (((λ_ (𝟙_ D)).hom ≫ tensorPowPoint pt (m + n)) ⊗ₘ + pt) := by + rw [← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.comp_id, tensorPowPoint_concat pt m n] + have hcoh : ((𝟙 (𝟙_ D)) ⊗ₘ (ρ_ (𝟙_ D)).inv) ≫ + (α_ (𝟙_ D) (𝟙_ D) (𝟙_ D)).inv ≫ + ((λ_ (𝟙_ D)).hom ▷ (𝟙_ D)) = + (λ_ (𝟙_ D)).hom ≫ (ρ_ (𝟙_ D)).inv := by + monoidal + refine Eq.trans ?_ (whisker_eq (λ_ (𝟙_ D)).hom + (tensorPowPoint_succ (pt := pt) (m + n)).symm) + rw [hsucc] + change (tensorPowPoint pt m ⊗ₘ + ((ρ_ (𝟙_ D)).inv ≫ (tensorPowPoint pt n ⊗ₘ pt))) ≫ + (α_ (tensorPow D Y m) (tensorPow D Y n) Y).inv ≫ + ((tensorPowConcat Y m n).hom ▷ Y) = _ + erw [hdec, Category.assoc, reassoc_of% hα, hIH, + ← MonoidalCategory.whiskerRight_comp_tensorHom, + reassoc_of% hcoh] + rfl + +variable {Y} in +/-- **The permutation action fixes point powers**: naturality +carries the action onto the unit strands, where it is trivial. -/ +theorem tensorPowPoint_permMor + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] {Y : D} + (pt : 𝟙_ D ⟶ Y) + (n : ℕ) + (σ : Equiv.Perm (Fin n)) : + tensorPowPoint pt n ≫ permMor Y n σ = + tensorPowPoint pt n := by + rw [tensorPowPoint, Category.assoc, ← permMor_natural, + ← Category.assoc, permMor_unit, Category.comp_id] + +end Point + +section Symmetrise + +/-- **The symmetriser fixes point powers** in the module power: +every permutation fixes them, so their average does. -/ +theorem tensorPowPoint_symPowIdem + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] + (A : D) [MonObj A] (X : D) [ModObj A X] (pt : 𝟙_ D ⟶ X) + (n : ℕ) : + tensorPowPoint pt n ≫ modPowπ A X n ≫ symPowIdem A X n = + tensorPowPoint pt n ≫ modPowπ A X n := by + rw [symPowIdem, symmetriser, map_smul, map_sum] + simp only [modPowAlg_single] + change tensorPowPoint pt n ≫ modPowπ A X n ≫ + (((n.factorial : ℂ))⁻¹ • + ∑ σ : Equiv.Perm (Fin n), + (modPowPerm (A := A) (X := X) n σ : + modPow A X n ⟶ modPow A X n)) = + tensorPowPoint pt n ≫ modPowπ A X n + rw [Linear.comp_smul, Preadditive.comp_sum, Linear.comp_smul, + Preadditive.comp_sum] + have habs : ∀ σ : Equiv.Perm (Fin n), + tensorPowPoint pt n ≫ modPowπ A X n ≫ + modPowPerm (A := A) (X := X) n σ = + tensorPowPoint pt n ≫ modPowπ A X n := by + intro σ + rw [modPowπ_perm, ← Category.assoc, tensorPowPoint_permMor] + calc ((n.factorial : ℂ))⁻¹ • + ∑ σ : Equiv.Perm (Fin n), tensorPowPoint pt n ≫ + (modPowπ A X n ≫ modPowPerm (A := A) (X := X) n σ) + = ((n.factorial : ℂ))⁻¹ • + ∑ _σ : Equiv.Perm (Fin n), + tensorPowPoint pt n ≫ modPowπ A X n := by + refine congrArg _ (Finset.sum_congr rfl fun σ _ => ?_) + exact habs σ + _ = tensorPowPoint pt n ≫ modPowπ A X n := by + rw [Finset.sum_const, Finset.card_univ, Fintype.card_perm, + Fintype.card_fin, ← Nat.cast_smul_eq_nsmul ℂ, smul_smul, + inv_mul_cancel₀ (by + exact_mod_cast n.factorial_ne_zero), one_smul] + +end Symmetrise + +section Nonzero + +/-- **Nonvanishing of point powers in symmetric powers over the +unit monoid**: for a monic point of an object in a rigid category +with nonzero unit, no symmetrised point power vanishes. -/ +theorem point_symPow_ne_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] + [RigidCategory D] (X : D) + (pt : 𝟙_ D ⟶ X) [Mono pt] (h1 : ¬ IsZero (𝟙_ D)) (n : ℕ) : + tensorPowPoint pt n ≫ modPowπ (𝟙_ D) X n ≫ + symPowπ (𝟙_ D) X n ≠ 0 := by + intro h0 + have h2 : tensorPowPoint pt n ≫ modPowπ (𝟙_ D) X n ≫ + symPowIdem (𝟙_ D) X n = 0 := by + have := congrArg (fun t => t ≫ symPowσ (𝟙_ D) X n) h0 + simpa [symPowπ_symPowσ] using this + have h3 : tensorPowPoint pt n ≫ modPowπ (𝟙_ D) X n = 0 := + (tensorPowPoint_symPowIdem (𝟙_ D) X pt n).symm.trans h2 + have h4 : tensorPowPoint pt n = 0 := by + have := congrArg + (fun t => t ≫ inv (modPowπ (𝟙_ D) X n)) h3 + simpa using this + have := tensorPowPoint_mono pt n + exact h1 ((IsZero.iff_id_eq_zero _).mpr + ((cancel_mono (tensorPowPoint pt n)).mp + (by rw [h4, comp_zero, zero_comp]))) + +/-- The nonvanishing of symmetrised point powers, from mono +preservation of the tensor factors alone. -/ +theorem point_symPow_ne_zero' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] + (X : D) + [∀ Z : D, (tensorLeft Z).PreservesMonomorphisms] + [∀ Z : D, (tensorRight Z).PreservesMonomorphisms] + (pt : 𝟙_ D ⟶ X) [Mono pt] (h1 : ¬ IsZero (𝟙_ D)) (n : ℕ) : + tensorPowPoint pt n ≫ modPowπ (𝟙_ D) X n ≫ + symPowπ (𝟙_ D) X n ≠ 0 := by + intro h0 + have h2 : tensorPowPoint pt n ≫ modPowπ (𝟙_ D) X n ≫ + symPowIdem (𝟙_ D) X n = 0 := by + have := congrArg (fun t => t ≫ symPowσ (𝟙_ D) X n) h0 + simpa [symPowπ_symPowσ] using this + have h3 : tensorPowPoint pt n ≫ modPowπ (𝟙_ D) X n = 0 := + (tensorPowPoint_symPowIdem (𝟙_ D) X pt n).symm.trans h2 + have h4 : tensorPowPoint pt n = 0 := by + have := congrArg + (fun t => t ≫ inv (modPowπ (𝟙_ D) X n)) h3 + simpa using this + have := tensorPowPoint_mono' pt n + exact h1 ((IsZero.iff_id_eq_zero _).mpr + ((cancel_mono (tensorPowPoint pt n)).mp + (by rw [h4, comp_zero, zero_comp]))) + +end Nonzero + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSucc.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSucc.lean new file mode 100644 index 0000000000..aa64928ea8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSucc.lean @@ -0,0 +1,224 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBofA +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorZigzag + +/-! +# The successor power datum + +The step of the power induction: the copairing power at the +successor stage is the tensor copairing of the stage datum and +the bottom datum, pushed along the transition legs. The orbit +extension principle reduces the comparison to the unit elements, +where the chain recursion is definitional. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The orbit extension principle**: a linear map out of the +base is the orbit map of its unit element. -/ +theorem act_on_point_eq [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + {X : D} (act : A ⊗ X ⟶ X) (f : A ⟶ X) + (hf : μ[A] ≫ f = (A ◁ f) ≫ act) : + f = (ρ_ A).inv ≫ (A ◁ (η[A] ≫ f)) ≫ act := by + rw [MonoidalCategory.whiskerLeft_comp, Category.assoc, + ← hf, ← Category.assoc, ← Category.assoc, + show ((ρ_ A).inv ≫ (A ◁ η[A])) ≫ μ[A] = 𝟙 A from by + rw [Category.assoc, MonObj.mul_one, Iso.inv_hom_id], + Category.id_comp] + +/-- **The transition is linear**: the power chain transition +intertwines the descended actions of adjacent stages. -/ +theorem powDelta_actLeft + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (n : ℕ) : + modTensorAct A (modPowMod A M.X n) (modPowMod A M'.X n) ≫ + powDelta A M M' d n = + (A ◁ powDelta A M M' d n) ≫ + modTensorAct A (modPowMod A M.X (n + 1)) + (modPowMod A M'.X (n + 1)) := by + have hm : (modTensorAct A (modPowMod A M.X n) + (modPowMod A M'.X n) ▷ + modTensor A (modPowMod A M.X 0) (modPowMod A M'.X 0)) ≫ + (interchange A (modPowMod A M.X n) (modPowMod A M'.X n) + (modPowMod A M.X 0) (modPowMod A M'.X 0) ≫ + modTensorMap A + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)) + (powMulMod A M'.X n 0)) = + (α_ A + (modTensor A (modPowMod A M.X n) (modPowMod A M'.X n)) + (modTensor A (modPowMod A M.X 0) + (modPowMod A M'.X 0))).hom ≫ + (A ◁ (interchange A (modPowMod A M.X n) + (modPowMod A M'.X n) + (modPowMod A M.X 0) (modPowMod A M'.X 0) ≫ + modTensorMap A + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)) + (powMulMod A M'.X n 0))) ≫ + modTensorAct A (modPowMod A M.X (n + 1)) + (modPowMod A M'.X (n + 1)) := by + rw [← Category.assoc, + interchange_actLeft A (modPowMod A M.X n) + (modPowMod A M'.X n) (modPowMod A M.X 0) + (modPowMod A M'.X 0), + Category.assoc, Category.assoc, modTensorAct_map, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + exact act_insert_linear A + (modTensorAct A (modPowMod A M.X n) (modPowMod A M'.X n)) + (modTensorAct A (modPowMod A M.X (n + 1)) + (modPowMod A M'.X (n + 1))) + (powSeed A M M' d) + (interchange A (modPowMod A M.X n) (modPowMod A M'.X n) + (modPowMod A M.X 0) (modPowMod A M'.X 0) ≫ + modTensorMap A + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)) + (powMulMod A M'.X n 0)) + hm + +/-- **The successor copairing power is the tensor copairing +pushed along the transition legs** (Deligne 1.15, copair side of +the power step). -/ +theorem powCopairA_succ_tensor + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (n : ℕ) : + powCopairA A M M' d (n + 1) = + tensorCopair A (powDualityDatum A M M' d n) + (powDualityDatum A M M' d 0) ≫ + modTensorMap A + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)) + (powMulMod A M'.X n 0) := by + have hf : μ[A] ≫ + (tensorCopair A (powDualityDatum A M M' d n) + (powDualityDatum A M M' d 0) ≫ + modTensorMap A + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)) + (powMulMod A M'.X n 0)) = + (A ◁ (tensorCopair A (powDualityDatum A M M' d n) + (powDualityDatum A M M' d 0) ≫ + modTensorMap A + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)) + (powMulMod A M'.X n 0))) ≫ + modTensorAct A (modPowMod A M.X (n + 1)) + (modPowMod A M'.X (n + 1)) := by + rw [← Category.assoc, tensorCopair_linear, Category.assoc, + modTensorAct_map, ← Category.assoc, + ← MonoidalCategory.whiskerLeft_comp] + have hpt : (λ_ (𝟙_ D)).inv ≫ + (powUnitStage A M M' d n ⊗ₘ powSeed A M M' d) = + powUnitStage A M M' d n ≫ + (ρ_ (powStage A M M' n)).inv ≫ + (powStage A M M' n ◁ powSeed A M M' d) := by + rw [MonoidalCategory.tensorHom_def, ← Category.assoc, + show (λ_ (𝟙_ D)).inv = (ρ_ (𝟙_ D)).inv from by + rw [← unitors_inv_equal], + ← rightUnitor_inv_naturality, Category.assoc] + have hu : η[A] ≫ + (tensorCopair A (powDualityDatum A M M' d n) + (powDualityDatum A M M' d 0) ≫ + modTensorMap A + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)) + (powMulMod A M'.X n 0)) = + powUnitStage A M M' d (n + 1) := by + have h1 : η[A] ≫ powCopairA A M M' d n = + powUnitStage A M M' d n := powCopairA_unit A M M' d n + have h2 : η[A] ≫ powCopairA A M M' d 0 = + powSeed A M M' d := powCopairA_unit A M M' d 0 + rw [← Category.assoc, tensorCopair_point, + show (powDualityDatum A M M' d n).copair = + powCopairA A M M' d n from rfl, + show (powDualityDatum A M M' d 0).copair = + powCopairA A M M' d 0 from rfl] + refine Eq.trans (congrArg + (fun t : 𝟙_ D ⟶ powStage A M M' n => + ((λ_ (𝟙_ D)).inv ≫ + (t ⊗ₘ (η[A] ≫ powCopairA A M M' d 0)) ≫ + interchange A (modPowMod A M.X n) + (modPowMod A M'.X n) + (modPowMod A M.X 0) (modPowMod A M'.X 0)) ≫ + modTensorMap A + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)) + (powMulMod A M'.X n 0)) h1) ?_ + refine Eq.trans (congrArg + (fun t : 𝟙_ D ⟶ powStage A M M' 0 => + ((λ_ (𝟙_ D)).inv ≫ + (powUnitStage A M M' d n ⊗ₘ t) ≫ + interchange A (modPowMod A M.X n) + (modPowMod A M'.X n) + (modPowMod A M.X 0) (modPowMod A M'.X 0)) ≫ + modTensorMap A + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)) + (powMulMod A M'.X n 0)) h2) ?_ + erw [reassoc_of% hpt] + change _ = powUnitStage A M M' d n ≫ powDelta A M M' d n + rw [powDelta] + simp only [Category.assoc] + conv_lhs => arg 2; arg 2; erw [Category.assoc] + rfl + rw [powCopairA, ← hu] + exact (act_on_point_eq A + (modTensorAct A (modPowMod A M.X (n + 1)) + (modPowMod A M'.X (n + 1))) _ hf).symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSuccMod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSuccMod.lean new file mode 100644 index 0000000000..9e9b705859 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSuccMod.lean @@ -0,0 +1,274 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowMerge + +/-! +# Module-level inverses of the merge maps + +The merge isomorphism of `PowMerge.lean` upgrades to the category +of modules: the split intertwines the actions, so it bundles as a +module map inverse to the bundled power multiplication +`powMulMod`. From it, the two insertions of a single factor into +a module power — at the front, through the braiding, and at the +back — become isomorphisms of modules. + +* `powMulModInv`: the split as a map of modules, with the + roundtrips `powMulMod_powMulModInv` and + `powMulModInv_powMulMod`. +* `powFrontMod`/`powFrontModInv`: the front insertion — the + `M`-side leg of the chain transition `powDelta` — and its + inverse, with roundtrips. +* `powBackMod`/`powBackModInv`: the back insertion and its + inverse, with roundtrips. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## The split as a module map -/ + +/-- **The split intertwines the module actions**: the inverse of +an equivariant isomorphism is equivariant, by cancelling the +descended power multiplication on the right. -/ +theorem powSplit_act [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (a b : ℕ) : + modPowAct A X (a + 1 + b) ≫ powSplit A X a b = + (A ◁ powSplit A X a b) ≫ + modTensorAct A (modPowMod A X a) (modPowMod A X b) := by + have : IsIso (powMulDesc A X a b) := + ⟨powSplit A X a b, powMulDesc_powSplit A X a b, + powSplit_powMulDesc A X a b⟩ + rw [← cancel_mono (powMulDesc A X a b), Category.assoc, + Category.assoc, powSplit_powMulDesc, Category.comp_id, + powMulDesc_act, ← MonoidalCategory.whiskerLeft_comp_assoc, + powSplit_powMulDesc, MonoidalCategory.whiskerLeft_id, + Category.id_comp] + +/-- **The module-level inverse of the merge**: the split bundled +as a map of modules. -/ +noncomputable def powMulModInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (a b : ℕ) : + modPowMod A X (a + 1 + b) ⟶ + modTensorMod A (modPowMod A X a) (modPowMod A X b) := + Mod.Hom.mk' (powSplit A X a b) (powSplit_act A X a b) + +/-- The bundled merge and its inverse compose to the identity on +the module tensor product. -/ +@[reassoc (attr := simp)] +theorem powMulMod_powMulModInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (a b : ℕ) : + powMulMod A X a b ≫ powMulModInv A X a b = + 𝟙 (modTensorMod A (modPowMod A X a) (modPowMod A X b)) := by + apply Mod.hom_ext + change powMulDesc A X a b ≫ powSplit A X a b = 𝟙 _ + exact powMulDesc_powSplit A X a b + +/-- The bundled inverse and the merge compose to the identity on +the module power. -/ +@[reassoc (attr := simp)] +theorem powMulModInv_powMulMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (a b : ℕ) : + powMulModInv A X a b ≫ powMulMod A X a b = + 𝟙 (modPowMod A X (a + 1 + b)) := by + apply Mod.hom_ext + change powSplit A X a b ≫ powMulDesc A X a b = 𝟙 _ + exact powSplit_powMulDesc A X a b + +/-! ## Transport and braiding helpers at the module level -/ + +/-- Two opposite arity transports of module powers cancel. -/ +@[reassoc (attr := simp)] +theorem modPowCastMod_comp_id + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + {a b : ℕ} (h : a + 1 = b + 1) + (h' : b + 1 = a + 1) : + modPowCastMod A X h ≫ modPowCastMod A X h' = + 𝟙 (modPowMod A X a) := by + apply Mod.hom_ext + change modPowCast A X h ≫ modPowCast A X h' = 𝟙 _ + calc modPowCast A X h ≫ modPowCast A X h' + = modPowCast A X (h.trans h') := eqToHom_trans _ _ + _ = 𝟙 _ := modPowCast_rfl A X (a + 1) + +/-- The braiding of the module tensor product is an involution at +the module level. -/ +@[reassoc (attr := simp)] +theorem modTensorSwapMod_modTensorSwapMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] + (P Q : Mod D A) : + modTensorSwapMod A P Q ≫ modTensorSwapMod A Q P = + 𝟙 (modTensorMod A P Q) := by + apply Mod.hom_ext + change modTensorSwap A P Q ≫ modTensorSwap A Q P = 𝟙 _ + exact modTensorSwap_modTensorSwap A P Q + +/-! ## The front insertion -/ + +/-- **The front insertion**: merge a fresh factor onto the front +of a module power, through the braiding. This is the `M`-side leg +of the chain transition `powDelta`. -/ +noncomputable def powFrontMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (n : ℕ) : + modTensorMod A (modPowMod A X n) (modPowMod A X 0) ⟶ + modPowMod A X (n + 1) := + modTensorSwapMod A (modPowMod A X n) (modPowMod A X 0) ≫ + powMulMod A X 0 n ≫ + modPowCastMod A X (by omega : 0 + 1 + n + 1 = n + 2) + +/-- The inverse of the front insertion. -/ +noncomputable def powFrontModInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (n : ℕ) : + modPowMod A X (n + 1) ⟶ + modTensorMod A (modPowMod A X n) (modPowMod A X 0) := + modPowCastMod A X (by omega : n + 1 + 1 = 0 + 1 + n + 1) ≫ + powMulModInv A X 0 n ≫ + modTensorSwapMod A (modPowMod A X 0) (modPowMod A X n) + +/-- The front insertion and its inverse compose to the identity +on the module tensor product. -/ +@[reassoc (attr := simp)] +theorem powFrontMod_powFrontModInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (n : ℕ) : + powFrontMod A X n ≫ powFrontModInv A X n = + 𝟙 (modTensorMod A (modPowMod A X n) (modPowMod A X 0)) := by + rw [powFrontMod, powFrontModInv] + simp only [Category.assoc] + rw [modPowCastMod_comp_id_assoc A X + (by omega : 0 + 1 + n + 1 = n + 2) + (by omega : n + 1 + 1 = 0 + 1 + n + 1), + powMulMod_powMulModInv_assoc A X 0 n, + modTensorSwapMod_modTensorSwapMod] + +/-- The inverse of the front insertion and the front insertion +compose to the identity on the module power. -/ +@[reassoc (attr := simp)] +theorem powFrontModInv_powFrontMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (n : ℕ) : + powFrontModInv A X n ≫ powFrontMod A X n = + 𝟙 (modPowMod A X (n + 1)) := by + rw [powFrontModInv, powFrontMod] + simp only [Category.assoc] + rw [modTensorSwapMod_modTensorSwapMod_assoc A + (modPowMod A X 0) (modPowMod A X n), + powMulModInv_powMulMod_assoc A X 0 n, + modPowCastMod_comp_id A X + (by omega : n + 1 + 1 = 0 + 1 + n + 1) + (by omega : 0 + 1 + n + 1 = n + 1 + 1)] + +/-! ## The back insertion -/ + +/-- **The back insertion**: merge a fresh factor onto the back of +a module power — the bundled merge with a singleton right +block. -/ +noncomputable def powBackMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (n : ℕ) : + modTensorMod A (modPowMod A X n) (modPowMod A X 0) ⟶ + modPowMod A X (n + 1) := + powMulMod A X n 0 + +/-- The inverse of the back insertion. -/ +noncomputable def powBackModInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (n : ℕ) : + modPowMod A X (n + 1) ⟶ + modTensorMod A (modPowMod A X n) (modPowMod A X 0) := + powMulModInv A X n 0 + +/-- The back insertion and its inverse compose to the identity on +the module tensor product. -/ +@[reassoc (attr := simp)] +theorem powBackMod_powBackModInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (n : ℕ) : + powBackMod A X n ≫ powBackModInv A X n = + 𝟙 (modTensorMod A (modPowMod A X n) (modPowMod A X 0)) := + powMulMod_powMulModInv A X n 0 + +/-- The inverse of the back insertion and the back insertion +compose to the identity on the module power. -/ +@[reassoc (attr := simp)] +theorem powBackModInv_powBackMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] + (n : ℕ) : + powBackModInv A X n ≫ powBackMod A X n = + 𝟙 (modPowMod A X (n + 1)) := + powMulModInv_powMulMod A X n 0 + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowTriangle.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowTriangle.lean new file mode 100644 index 0000000000..3e878a61a7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowTriangle.lean @@ -0,0 +1,1030 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowChain +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulLaws + +/-! +# The triangle scalar of the power chain + +The copairing powers of a duality datum retract against the +nested power pairing: under the scalar zigzag, the pairing +evaluates every chain unit to the unit of the base. This is the +nonvanishing engine of the Key Lemma's chain. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +section SwapMap + +/-- The braiding of the module tensor product is natural. -/ +theorem modTensorMap_swap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] {P : Mod D A} {P' : Mod D A} + {Q : Mod D A} {Q' : Mod D A} + (f : P ⟶ P') (g : Q ⟶ Q') : + modTensorMap A f g ≫ modTensorSwap A P' Q' = + modTensorSwap A P Q ≫ modTensorMap A g f := by + apply modTensor_hom_ext + rw [modTensorπ_map_assoc, modTensorπ_swap, + modTensorπ_swap_assoc, ← Category.assoc, + BraidedCategory.braiding_naturality, Category.assoc, + modTensorπ_map] + +end SwapMap + +/-- The nested pairing at arity one is the pairing, through the +singleton isomorphisms. -/ +theorem modPowOne_pairPow + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + ((modPowOne A M'.X).inv ⊗ₘ (modPowOne A M.X).inv) ≫ + pairPow A M M' d 1 = pairRaw A M M' d := by + have hinv : ∀ (X : D) [ModObj A X], (modPowOne A X).inv = + (λ_ X).inv ≫ modPowπ A X 1 := by + intro X _ + erw [modPowOne, Iso.trans_inv] + rfl + erw [hinv, hinv, ← MonoidalCategory.tensorHom_comp_tensorHom, + Category.assoc] + refine ((congrArg (fun t => + ((λ_ M'.X).inv ⊗ₘ (λ_ M.X).inv) ≫ t) + (modPowπ_tensor_pairPow A M M' d 1)).trans ?_) + rw [rawPair_succ, rawPair_zero, powPeel_zero] + change ((λ_ M'.X).inv ⊗ₘ (λ_ M.X).inv) ≫ + ((𝟙_ D ⊗ M'.X) ◁ (λ_ M.X ≪≫ (ρ_ M.X).symm).hom) ≫ + (α_ (𝟙_ D) M'.X (M.X ⊗ 𝟙_ D)).hom ≫ + (𝟙_ D ◁ (α_ M'.X M.X (𝟙_ D)).inv) ≫ + (𝟙_ D ◁ (pairRaw A M M' d ▷ 𝟙_ D)) ≫ + (𝟙_ D ◁ (β_ A (𝟙_ D)).hom) ≫ + (α_ (𝟙_ D) (𝟙_ D) A).inv ≫ + (((λ_ (𝟙_ D)).hom ≫ η[A]) ▷ A) ≫ μ[A] = + pairRaw A M M' d + rw [Iso.trans_hom, braiding_tensorUnit_right, + comp_whiskerRight] + simp only [Category.assoc] + rw [MonObj.one_mul] + dsimp only [Iso.symm_hom] + monoidal + +/-- The Mod-internal power pairing at arity zero is the datum's +pairing, through the singleton stages. -/ +theorem toZero_modPowPairing + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + modTensorMap A (toModPowModZero A M') (toModPowModZero A M) ≫ + modPowPairing A M M' d 0 = d.pair := by + apply modTensor_hom_ext + rw [modTensorπ_map_assoc, modTensorπ_modPowPairing] + rw [show (toModPowModZero A M').hom = (modPowOne A M'.X).inv + from rfl, + show (toModPowModZero A M).hom = (modPowOne A M.X).inv + from rfl] + exact (modPowOne_pairPow A M M' d).trans rfl + +/-- **The seed retracts against the pairing**: under the scalar +zigzag, the bottom chain unit evaluates to the unit of the +base. -/ +theorem powSeed_pairing + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (hzig : d.copair ≫ modTensorSwap A M M' ≫ d.pair = 𝟙 A) : + powSeed A M M' d ≫ + modTensorSwap A (modPowMod A M.X 0) (modPowMod A M'.X 0) ≫ + modPowPairing A M M' d 0 = η[A] := by + erw [powSeed, Category.assoc] + have hX : modTensorMap A (toModPowModZero A M) + (toModPowModZero A M') ≫ + modTensorSwap A (modPowMod A M.X 0) (modPowMod A M'.X 0) ≫ + modPowPairing A M M' d 0 = + modTensorSwap A M M' ≫ + modTensorMap A (toModPowModZero A M') + (toModPowModZero A M) ≫ + modPowPairing A M M' d 0 := by + rw [← Category.assoc, modTensorMap_swap, Category.assoc] + refine ((congrArg (fun t => + copairUnit A M M' d ≫ t) hX).trans ?_) + rw [toZero_modPowPairing, copairUnit, Category.assoc, hzig, + Category.comp_id] + +section PowEpi + +/-- The module-power projection is an epimorphism. -/ +instance epi_modPowπ [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] (X : D) [ModObj A X] + (n : ℕ) : Epi (modPowπ A X n) := + ⟨fun _ _ w => modPow_hom_ext A X w⟩ + +/-- The tensor product of two module-power projections is an +epimorphism. -/ +instance epi_modPowπ_tensorHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (X : D) [ModObj A X] (Y : D) [ModObj A Y] + (m n : ℕ) : + Epi (modPowπ A X m ⊗ₘ modPowπ A Y n) := by + rw [MonoidalCategory.tensorHom_def] + infer_instance + +/-- A tensor pair of power projections whiskered on the right is +an epimorphism. -/ +instance epi_modPowπ_tensorHom_whiskerRight + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (X : D) [ModObj A X] (Y : D) [ModObj A Y] + (m n : ℕ) (W : D) : + Epi ((modPowπ A X m ⊗ₘ modPowπ A Y n) ▷ W) := by + rw [MonoidalCategory.tensorHom_def, comp_whiskerRight] + have h1 : Epi ((modPowπ A X m ▷ tensorPow D Y n) ▷ W) := by + rw [show (modPowπ A X m ▷ tensorPow D Y n) ▷ W = + (α_ (tensorPow D X m) (tensorPow D Y n) W).hom ≫ + (modPowπ A X m ▷ (tensorPow D Y n ⊗ W)) ≫ + (α_ (modPow A X m) (tensorPow D Y n) W).inv by + simp [MonoidalCategory.whiskerRight_tensor]] + infer_instance + have h2 : Epi ((modPow A X m ◁ modPowπ A Y n) ▷ W) := by + rw [MonoidalCategory.whisker_assoc] + infer_instance + exact epi_comp _ _ + +/-- A tensor square of power projection pairs is an +epimorphism. -/ +instance epi_modPowπ_tensorHom_tensorHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (X : D) [ModObj A X] (Y : D) [ModObj A Y] (Z' : D) + (W' : D) [ModObj A Z'] [ModObj A W'] + (a b c e : ℕ) : + Epi ((modPowπ A X a ⊗ₘ modPowπ A Y b) ⊗ₘ + (modPowπ A Z' c ⊗ₘ modPowπ A W' e)) := by + rw [MonoidalCategory.tensorHom_def] + have h2 : Epi ((modPow A X a ⊗ modPow A Y b) ◁ + (modPowπ A Z' c ⊗ₘ modPowπ A W' e)) := by + rw [MonoidalCategory.tensorHom_def, + MonoidalCategory.whiskerLeft_comp] + have h3 : Epi ((modPow A X a ⊗ modPow A Y b) ◁ + (modPow A Z' c ◁ modPowπ A W' e)) := by + rw [show (modPow A X a ⊗ modPow A Y b) ◁ + (modPow A Z' c ◁ modPowπ A W' e) = + (α_ (modPow A X a ⊗ modPow A Y b) (modPow A Z' c) + (tensorPow D W' e)).inv ≫ + (((modPow A X a ⊗ modPow A Y b) ⊗ modPow A Z' c) ◁ + modPowπ A W' e) ≫ + (α_ (modPow A X a ⊗ modPow A Y b) (modPow A Z' c) + (modPow A W' e)).hom by simp] + infer_instance + exact epi_comp _ _ + exact epi_comp _ _ + +/-- A left-whiskered power projection whiskered on the right is +an epimorphism. -/ +instance epi_whiskerLeft_modPowπ_whiskerRight' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (X : D) [ModObj A X] + (n : ℕ) + (Q W : D) : Epi ((Q ◁ modPowπ A X n) ▷ W) := by + rw [MonoidalCategory.whisker_assoc] + infer_instance + +end PowEpi + +section InterchangeMap + +/-- The interchange followed by a functorial map computes under +the stage projections: the raw crossing feeds the two module +maps. -/ +@[reassoc] +theorem tensorHom_π_interchange_map + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (N₁ : Mod D A) (N₂ : Mod D A) + (P₁ : Mod D A) (P₂ : Mod D A) + {Q R : Mod D A} + (f : modTensorMod A N₁ P₁ ⟶ Q) + (g : modTensorMod A N₂ P₂ ⟶ R) : + (modTensorπ A N₁ N₂ ⊗ₘ modTensorπ A P₁ P₂) ≫ + interchange A N₁ N₂ P₁ P₂ ≫ modTensorMap A f g = + tensorμ N₁.X N₂.X P₁.X P₂.X ≫ + ((modTensorπ A N₁ P₁ ≫ f.hom) ⊗ₘ + (modTensorπ A N₂ P₂ ≫ g.hom)) ≫ + modTensorπ A Q R := by + have h5 : (modTensorπ A N₁ N₂ ⊗ₘ modTensorπ A P₁ P₂) ≫ + interchange A N₁ N₂ P₁ P₂ ≫ modTensorMap A f g = + ((modTensorπ A N₁ N₂ ⊗ₘ modTensorπ A P₁ P₂) ≫ + interchange A N₁ N₂ P₁ P₂) ≫ modTensorMap A f g := + (Category.assoc _ _ _).symm + rw [h5, tensorHom_π_interchange, rawInterchangeπ, + rawInterchange] + simp only [Category.assoc] + have h6 : modTensorπ A (modTensorMod A N₁ P₁) + (modTensorMod A N₂ P₂) ≫ modTensorMap A f g = + (f.hom ⊗ₘ g.hom) ≫ modTensorπ A Q R := + modTensorπ_map A f g + conv_lhs => arg 2; erw [Category.assoc] + refine congrArg (CategoryStruct.comp _) ?_ + refine (congrArg (CategoryStruct.comp _) h6).trans ?_ + erw [← Category.assoc] + change ((modTensorπ A N₁ P₁ ⊗ₘ modTensorπ A N₂ P₂) ≫ + (f.hom ⊗ₘ g.hom)) ≫ modTensorπ A Q R = _ + erw [MonoidalCategory.tensorHom_comp_tensorHom] + +end InterchangeMap + +/-- The transition core under the stage projections: the raw +interchange, the aligned multiplications, and the pairing of the +joined arity. -/ +private theorem powDeltaCore_layer1 + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (n : ℕ) : + (modTensorπ A (modPowMod A M.X n) (modPowMod A M'.X n) ⊗ₘ + modTensorπ A (modPowMod A M.X 0) (modPowMod A M'.X 0)) ≫ + interchange A (modPowMod A M.X n) (modPowMod A M'.X n) + (modPowMod A M.X 0) (modPowMod A M'.X 0) ≫ + modTensorMap A + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)) + (powMulMod A M'.X n 0) ≫ + modTensorSwap A (modPowMod A M.X (n + 1)) + (modPowMod A M'.X (n + 1)) ≫ + modPowPairing A M M' d (n + 1) = + tensorμ (modPow A M.X (n + 1)) (modPow A M'.X (n + 1)) + (modPow A M.X (0 + 1)) (modPow A M'.X (0 + 1)) ≫ + (((β_ (modPow A M.X (n + 1)) (modPow A M.X (0 + 1))).hom ≫ + modPowMul A M.X (0 + 1) (n + 1) ≫ + modPowCast A M.X (by omega : 0 + 1 + n + 1 = n + 2)) ⊗ₘ + modPowMul A M'.X (n + 1) (0 + 1)) ≫ + (β_ (modPow A M.X (n + 2)) (modPow A M'.X (n + 2))).hom ≫ + pairPow A M M' d (n + 2) := by + rw [tensorHom_π_interchange_map_assoc, modTensorπ_swap_assoc, + modTensorπ_modPowPairing] + have hF : modTensorπ A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)).hom = + (β_ (modPow A M.X (n + 1)) (modPow A M.X (0 + 1))).hom ≫ + modPowMul A M.X (0 + 1) (n + 1) ≫ + modPowCast A M.X (by omega : 0 + 1 + n + 1 = n + 2) := by + change modTensorπ A (modPowMod A M.X n) (modPowMod A M.X 0) ≫ + modTensorSwap A (modPowMod A M.X n) (modPowMod A M.X 0) ≫ + powMulDesc A M.X 0 n ≫ + modPowCast A M.X (by omega : 0 + 1 + n + 1 = n + 2) = _ + rw [modTensorπ_swap_assoc, modTensorπ_powMulDesc_assoc] + rfl + have hG : modTensorπ A (modPowMod A M'.X n) + (modPowMod A M'.X 0) ≫ (powMulMod A M'.X n 0).hom = + modPowMul A M'.X (n + 1) (0 + 1) := by + change modTensorπ A (modPowMod A M'.X n) + (modPowMod A M'.X 0) ≫ powMulDesc A M'.X n 0 = _ + exact modTensorπ_powMulDesc A M'.X n 0 + rw [hF, hG] + rfl + +/-- The generic coherence core of the raw multiplicativity: the +inserted pair peels off and multiplies. -/ +private theorem rawMult_core + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] + {Y Y' P S : D} + (p : Y' ⊗ Y ⟶ A) (r : S ⊗ P ⟶ A) : + (α_ P S ((𝟙_ D ⊗ Y) ⊗ (𝟙_ D ⊗ Y'))).hom ≫ + (P ◁ (α_ S (𝟙_ D ⊗ Y) (𝟙_ D ⊗ Y')).inv) ≫ + (P ◁ ((β_ S (𝟙_ D ⊗ Y)).hom ▷ (𝟙_ D ⊗ Y'))) ≫ + (P ◁ (α_ (𝟙_ D ⊗ Y) S (𝟙_ D ⊗ Y')).hom) ≫ + (α_ P (𝟙_ D ⊗ Y) (S ⊗ (𝟙_ D ⊗ Y'))).inv ≫ + (β_ (P ⊗ (𝟙_ D ⊗ Y)) (S ⊗ (𝟙_ D ⊗ Y'))).hom ≫ + (((α_ S (𝟙_ D) Y').inv ≫ + ((ρ_ S).hom ▷ Y')) ⊗ₘ + ((β_ P (𝟙_ D ⊗ Y)).hom ≫ + (((λ_ Y).hom ≫ (ρ_ Y).inv) ▷ P) ≫ + (α_ Y (𝟙_ D) P).hom ≫ + (Y ◁ (λ_ P).hom))) ≫ + (α_ S Y' (Y ⊗ P)).hom ≫ + (S ◁ (α_ Y' Y P).inv) ≫ + (S ◁ (p ▷ P)) ≫ + (S ◁ (β_ A P).hom) ≫ + (α_ S P A).inv ≫ (r ▷ A) ≫ μ[A] = + ((P ⊗ S) ◁ ((β_ (𝟙_ D ⊗ Y) (𝟙_ D ⊗ Y')).hom ≫ + ((λ_ Y').hom ⊗ₘ (λ_ Y).hom) ≫ p)) ≫ + ((β_ P S).hom ≫ r) ▷ A ≫ μ[A] := by + rw [BraidedCategory.braiding_tensor_left_hom P (𝟙_ D ⊗ Y) + (S ⊗ (𝟙_ D ⊗ Y'))] + rw [BraidedCategory.braiding_tensor_right_hom P S + (𝟙_ D ⊗ Y')] + rw [BraidedCategory.braiding_tensor_right_hom (𝟙_ D ⊗ Y) S + (𝟙_ D ⊗ Y')] + rw [← MonoidalCategory.whiskerLeft_comp_assoc S (p ▷ P) + ((β_ A P).hom), + BraidedCategory.braiding_naturality_left p P, + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc, Iso.inv_hom_id_assoc, + ← MonoidalCategory.whiskerLeft_comp] + have hcancel1 : (α_ S (𝟙_ D ⊗ Y) (𝟙_ D ⊗ Y')).inv ≫ + ((β_ S (𝟙_ D ⊗ Y)).hom ▷ (𝟙_ D ⊗ Y')) ≫ + (α_ (𝟙_ D ⊗ Y) S (𝟙_ D ⊗ Y')).hom ≫ + ((α_ (𝟙_ D ⊗ Y) S (𝟙_ D ⊗ Y')).inv ≫ + ((β_ (𝟙_ D ⊗ Y) S).hom ▷ (𝟙_ D ⊗ Y')) ≫ + (α_ S (𝟙_ D ⊗ Y) (𝟙_ D ⊗ Y')).hom ≫ + (S ◁ (β_ (𝟙_ D ⊗ Y) (𝟙_ D ⊗ Y')).hom) ≫ + (α_ S (𝟙_ D ⊗ Y') (𝟙_ D ⊗ Y)).inv) = + (α_ S (𝟙_ D ⊗ Y) (𝟙_ D ⊗ Y')).inv ≫ + ((β_ S (𝟙_ D ⊗ Y)).hom ≫ (β_ (𝟙_ D ⊗ Y) S).hom) ▷ + (𝟙_ D ⊗ Y') ≫ + (α_ S (𝟙_ D ⊗ Y) (𝟙_ D ⊗ Y')).hom ≫ + (S ◁ (β_ (𝟙_ D ⊗ Y) (𝟙_ D ⊗ Y')).hom) ≫ + (α_ S (𝟙_ D ⊗ Y') (𝟙_ D ⊗ Y)).inv := by + simp only [Category.assoc, Iso.hom_inv_id_assoc, + comp_whiskerRight] + rw [SymmetricCategory.symmetry] at hcancel1 + simp only [MonoidalCategory.id_whiskerRight, + Category.id_comp, Iso.inv_hom_id_assoc] at hcancel1 + rw [← MonoidalCategory.whiskerLeft_comp_assoc P + (α_ S (𝟙_ D ⊗ Y) (𝟙_ D ⊗ Y')).inv + ((β_ S (𝟙_ D ⊗ Y)).hom ▷ (𝟙_ D ⊗ Y')), + ← MonoidalCategory.whiskerLeft_comp_assoc P _ + (α_ (𝟙_ D ⊗ Y) S (𝟙_ D ⊗ Y')).hom] + have hb : (((α_ S (𝟙_ D ⊗ Y) (𝟙_ D ⊗ Y')).inv ≫ + (β_ S (𝟙_ D ⊗ Y)).hom ▷ (𝟙_ D ⊗ Y')) ≫ + (α_ (𝟙_ D ⊗ Y) S (𝟙_ D ⊗ Y')).hom) ≫ + ((α_ (𝟙_ D ⊗ Y) S (𝟙_ D ⊗ Y')).inv ≫ + ((β_ (𝟙_ D ⊗ Y) S).hom ▷ (𝟙_ D ⊗ Y')) ≫ + (α_ S (𝟙_ D ⊗ Y) (𝟙_ D ⊗ Y')).hom ≫ + (S ◁ (β_ (𝟙_ D ⊗ Y) (𝟙_ D ⊗ Y')).hom) ≫ + (α_ S (𝟙_ D ⊗ Y') (𝟙_ D ⊗ Y)).inv) = + (S ◁ (β_ (𝟙_ D ⊗ Y) (𝟙_ D ⊗ Y')).hom) ≫ + (α_ S (𝟙_ D ⊗ Y') (𝟙_ D ⊗ Y)).inv := by + simp only [Category.assoc] + exact hcancel1 + rw [← MonoidalCategory.whiskerLeft_comp_assoc P _ _, + congrArg (fun t => P ◁ t) hb] + rw [BraidedCategory.braiding_tensor_left_hom Y' Y P] + have hslot2 : (β_ P (𝟙_ D ⊗ Y)).hom ≫ + (((λ_ Y).hom ≫ (ρ_ Y).inv) ▷ P) ≫ + (α_ Y (𝟙_ D) P).hom ≫ (Y ◁ (λ_ P).hom) = + (P ◁ (λ_ Y).hom) ≫ (β_ P Y).hom := by + rw [MonoidalCategory.comp_whiskerRight, Category.assoc, + show ((ρ_ Y).inv ▷ P) ≫ (α_ Y (𝟙_ D) P).hom ≫ + (Y ◁ (λ_ P).hom) = 𝟙 (Y ⊗ P) from by monoidal, + Category.comp_id, + ← BraidedCategory.braiding_naturality_right] + rw [hslot2] + conv_lhs => rw [MonoidalCategory.tensorHom_def] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [← MonoidalCategory.whiskerLeft_comp_assoc S + (α_ Y' Y P).inv (α_ Y' Y P).hom, Iso.inv_hom_id, + MonoidalCategory.whiskerLeft_id, Category.id_comp] + rw [associator_naturality_right_assoc] + rw [← MonoidalCategory.whiskerLeft_comp_assoc S _ _, + ← MonoidalCategory.whiskerLeft_comp Y' (β_ P Y).hom + (β_ Y P).hom, + SymmetricCategory.symmetry, MonoidalCategory.whiskerLeft_id, + MonoidalCategory.whiskerLeft_id, Category.id_comp] + rw [show (α_ S (𝟙_ D) Y').inv ≫ (ρ_ S).hom ▷ Y' = + S ◁ (λ_ Y').hom from by monoidal] + rw [← associator_naturality_left_assoc] + rw [← comp_whiskerRight_assoc] + have hcancel3 : ((α_ P S (𝟙_ D ⊗ Y')).inv ≫ + ((β_ P S).hom ▷ (𝟙_ D ⊗ Y')) ≫ + (α_ S P (𝟙_ D ⊗ Y')).hom ≫ + (S ◁ (β_ P (𝟙_ D ⊗ Y')).hom) ≫ + (α_ S (𝟙_ D ⊗ Y') P).inv) ≫ + ((S ◁ (λ_ Y').hom) ▷ P) = + (α_ P S (𝟙_ D ⊗ Y')).inv ≫ + ((P ⊗ S) ◁ (λ_ Y').hom) ≫ + ((β_ P S).hom ▷ Y') ≫ + (α_ S P Y').hom ≫ + (S ◁ (β_ P Y').hom) ≫ + (α_ S Y' P).inv := by + simp only [Category.assoc] + rw [← associator_inv_naturality_middle, + ← MonoidalCategory.whiskerLeft_comp_assoc S + (β_ P (𝟙_ D ⊗ Y')).hom ((λ_ Y').hom ▷ P), + ← BraidedCategory.braiding_naturality_right P + (λ_ Y').hom, + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rw [← associator_naturality_right_assoc, + ← whisker_exchange_assoc] + rw [congrArg (fun t => t ▷ (𝟙_ D ⊗ Y)) hcancel3] + simp only [comp_whiskerRight, Category.assoc] + rw [← associator_naturality_right_assoc, + whisker_exchange_assoc, whisker_exchange_assoc] + refine congrArg (CategoryStruct.comp _) ?_ + rw [← associator_naturality_right_assoc] + rw [← whisker_exchange_assoc, ← whisker_exchange_assoc, + ← whisker_exchange_assoc, ← whisker_exchange_assoc, + ← whisker_exchange_assoc] + have hcancel4 : ((S ◁ (β_ P Y').hom) ▷ Y) ≫ + ((α_ S Y' P).inv ▷ Y) ≫ (α_ (S ⊗ Y') P Y).hom ≫ + (α_ S Y' (P ⊗ Y)).hom ≫ (S ◁ (α_ Y' P Y).inv) ≫ + (S ◁ ((β_ Y' P).hom ▷ Y)) = + (α_ S (P ⊗ Y') Y).hom := by + have hmid : ((α_ S Y' P).inv ▷ Y) ≫ + (α_ (S ⊗ Y') P Y).hom ≫ (α_ S Y' (P ⊗ Y)).hom ≫ + (S ◁ (α_ Y' P Y).inv) = + (α_ S (Y' ⊗ P) Y).hom := by monoidal + rw [reassoc_of% hmid] + rw [associator_naturality_middle_assoc, + ← MonoidalCategory.whiskerLeft_comp, + ← comp_whiskerRight, SymmetricCategory.symmetry, + MonoidalCategory.id_whiskerRight, + MonoidalCategory.whiskerLeft_id, Category.comp_id] + rw [reassoc_of% hcancel4] + rw [whisker_exchange_assoc, whisker_exchange_assoc] + monoidal + +/-- The raw multiplicativity of the nested pairing at an aligned +insertion: the peel of the joined pairing extracts the inserted +block. -/ +private theorem powDeltaCore_raw + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (n : ℕ) : + tensorμ (tensorPow D M.X (n + 1)) (tensorPow D M'.X (n + 1)) + (tensorPow D M.X (0 + 1)) (tensorPow D M'.X (0 + 1)) ≫ + (((β_ (tensorPow D M.X (n + 1)) + (tensorPow D M.X (0 + 1))).hom ≫ + (tensorPowConcat M.X (0 + 1) (n + 1)).hom ≫ + powCast M.X + (by omega : 0 + 1 + (n + 1) = n + 1 + 1)) ⊗ₘ + (tensorPowConcat M'.X (n + 1) (0 + 1)).hom) ≫ + (β_ (tensorPow D M.X (n + 1 + 1)) + (tensorPow D M'.X (n + 1 + 1))).hom ≫ + rawPair A M M' d (n + 1 + 1) = + (((β_ (tensorPow D M.X (n + 1)) + (tensorPow D M'.X (n + 1))).hom ≫ + rawPair A M M' d (n + 1)) ⊗ₘ + ((β_ (tensorPow D M.X (0 + 1)) + (tensorPow D M'.X (0 + 1))).hom ≫ + rawPair A M M' d (0 + 1))) ≫ μ[A] := by + rw [rawPair_succ] + have hslide : (((β_ (tensorPow D M.X (n + 1)) + (tensorPow D M.X (0 + 1))).hom ≫ + (tensorPowConcat M.X (0 + 1) (n + 1)).hom ≫ + powCast M.X (by omega : 0 + 1 + (n + 1) = n + 1 + 1)) ⊗ₘ + (tensorPowConcat M'.X (n + 1) (0 + 1)).hom) ≫ + (β_ (tensorPow D M.X (n + 1 + 1)) + (tensorPow D M'.X (n + 1 + 1))).hom = + (β_ (tensorPow D M.X (n + 1) ⊗ tensorPow D M.X (0 + 1)) + (tensorPow D M'.X (n + 1) ⊗ + tensorPow D M'.X (0 + 1))).hom ≫ + ((tensorPowConcat M'.X (n + 1) (0 + 1)).hom ⊗ₘ + ((β_ (tensorPow D M.X (n + 1)) + (tensorPow D M.X (0 + 1))).hom ≫ + (tensorPowConcat M.X (0 + 1) (n + 1)).hom ≫ + powCast M.X + (by omega : 0 + 1 + (n + 1) = n + 1 + 1))) := + BraidedCategory.braiding_naturality _ _ + rw [reassoc_of% hslide] + have hpeelcast : ∀ {a b : ℕ} (h : a = b) + (hs : a + 1 = b + 1), + powCast M.X hs ≫ (powPeel M.X b).hom = + (powPeel M.X a).hom ≫ (M.X ◁ powCast M.X h) := by + intro a b h hs + subst h + rw [powCast_irrel M.X hs rfl, powCast_rfl, + Category.id_comp, powCast_rfl, + MonoidalCategory.whiskerLeft_id, Category.comp_id] + have hMword : ((β_ (tensorPow D M.X (n + 1)) + (tensorPow D M.X (0 + 1))).hom ≫ + (tensorPowConcat M.X (0 + 1) (n + 1)).hom ≫ + powCast M.X (by omega : 0 + 1 + (n + 1) = n + 1 + 1)) ≫ + (powPeel M.X (n + 1)).hom = + (β_ (tensorPow D M.X (n + 1)) + (tensorPow D M.X (0 + 1))).hom ≫ + (((λ_ M.X).hom ≫ (ρ_ M.X).inv) ▷ + tensorPow D M.X (n + 1)) ≫ + (α_ M.X (tensorPow D M.X 0) + (tensorPow D M.X (n + 1))).hom ≫ + (M.X ◁ (λ_ (tensorPow D M.X (n + 1))).hom) := by + rw [show powCast M.X + (by omega : 0 + 1 + (n + 1) = n + 1 + 1) = + powCast M.X (by omega : 0 + 1 + (n + 1) = 0 + (n + 1) + 1) + ≫ powCast M.X (by omega : 0 + (n + 1) + 1 = n + 1 + 1) + from (powCast_comp M.X _ _).symm] + simp only [Category.assoc] + rw [hpeelcast (by omega : 0 + (n + 1) = n + 1), + reassoc_of% (concat_peel_head M.X 0 (n + 1)), + powPeel_zero, tensorPowConcat_zero_left] + repeat' erw [← MonoidalCategory.whiskerLeft_comp] + have hslot : ((λ_ (tensorPow D M.X (n + 1))).hom ≫ + powCast M.X (by omega : n + 1 = 0 + (n + 1))) ≫ + powCast M.X (by omega : 0 + (n + 1) = n + 1) = + (λ_ (tensorPow D M.X (n + 1))).hom := by + rw [Category.assoc, powCast_comp, + powCast_irrel M.X _ rfl, powCast_rfl, Category.comp_id] + exact congrArg (fun t => + (β_ (tensorPow D M.X (n + 1)) + (tensorPow D M.X (0 + 1))).hom ≫ + (λ_ M.X ≪≫ (ρ_ M.X).symm).hom ▷ + tensorPow D M.X (n + 1) ≫ + (α_ M.X (tensorPow D M.X 0) + (tensorPow D M.X (n + 1))).hom ≫ + (M.X ◁ t)) hslot + have hmr : ∀ {X₁ X₂ Y₂ Z₁ : D} (a : X₁ ⟶ Z₁) (b : X₂ ⟶ Y₂) + (f : Y₂ ⟶ M.X ⊗ tensorPow D M.X (n + 1)) + {Z : D} (h : Z₁ ⊗ (M.X ⊗ tensorPow D M.X (n + 1)) ⟶ Z), + (a ⊗ₘ b) ≫ (Z₁ ◁ (f : Y₂ ⟶ _)) ≫ h = + (a ⊗ₘ (b ≫ f)) ≫ h := by + intro X₁ X₂ Y₂ Z₁ a b f Z h + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom_assoc, + Category.comp_id] + rw [hmr] + rw [congrArg (fun t => + (tensorPowConcat M'.X (n + 1) (0 + 1)).hom ⊗ₘ t) hMword] + have hraw1 : rawPair A M M' d (0 + 1) = + ((λ_ M'.X).hom ⊗ₘ (λ_ M.X).hom) ≫ pairRaw A M M' d := by + rw [rawPair_succ, rawPair_zero, powPeel_zero] + change ((𝟙_ D ⊗ M'.X) ◁ (λ_ M.X ≪≫ (ρ_ M.X).symm).hom) ≫ + (α_ (𝟙_ D) M'.X (M.X ⊗ 𝟙_ D)).hom ≫ + (𝟙_ D ◁ (α_ M'.X M.X (𝟙_ D)).inv) ≫ + (𝟙_ D ◁ (pairRaw A M M' d ▷ 𝟙_ D)) ≫ + (𝟙_ D ◁ (β_ A (𝟙_ D)).hom) ≫ + (α_ (𝟙_ D) (𝟙_ D) A).inv ≫ + (((λ_ (𝟙_ D)).hom ≫ η[A]) ▷ A) ≫ μ[A] = _ + rw [Iso.trans_hom, braiding_tensorUnit_right, + comp_whiskerRight] + simp only [Category.assoc] + rw [MonObj.one_mul] + dsimp only [Iso.symm_hom] + monoidal + rw [hraw1] + rw [show (tensorPowConcat M'.X (n + 1) (0 + 1)).hom = + (α_ (tensorPow D M'.X (n + 1)) (tensorPow D M'.X 0) + M'.X).inv ≫ + ((ρ_ (tensorPow D M'.X (n + 1))).hom ▷ M'.X) from rfl] + conv_rhs => rw [MonoidalCategory.tensorHom_def'] + simp only [tensorμ, Category.assoc] + exact rawMult_core A (pairRaw A M M' d) + (rawPair A M M' d (n + 1)) + +/-- The transition core at the raw power level: the peel of the +joined pairing extracts the inserted pair. -/ +private theorem powDeltaCore_layer2 + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (n : ℕ) : + tensorμ (modPow A M.X (n + 1)) (modPow A M'.X (n + 1)) + (modPow A M.X (0 + 1)) (modPow A M'.X (0 + 1)) ≫ + (((β_ (modPow A M.X (n + 1)) (modPow A M.X (0 + 1))).hom ≫ + modPowMul A M.X (0 + 1) (n + 1) ≫ + modPowCast A M.X (by omega : 0 + 1 + n + 1 = n + 2)) ⊗ₘ + modPowMul A M'.X (n + 1) (0 + 1)) ≫ + (β_ (modPow A M.X (n + 2)) (modPow A M'.X (n + 2))).hom ≫ + pairPow A M M' d (n + 2) = + (((β_ (modPow A M.X (n + 1)) (modPow A M'.X (n + 1))).hom ≫ + pairPow A M M' d (n + 1)) ⊗ₘ + ((β_ (modPow A M.X (0 + 1)) (modPow A M'.X (0 + 1))).hom ≫ + pairPow A M M' d (0 + 1))) ≫ μ[A] := by + rw [← cancel_epi + ((modPowπ A M.X (n + 1) ⊗ₘ modPowπ A M'.X (n + 1)) ⊗ₘ + (modPowπ A M.X (0 + 1) ⊗ₘ modPowπ A M'.X (0 + 1)))] + rw [reassoc_of% (tensorμ_natural (modPowπ A M.X (n + 1)) + (modPowπ A M'.X (n + 1)) (modPowπ A M.X (0 + 1)) + (modPowπ A M'.X (0 + 1)))] + rw [MonoidalCategory.tensorHom_comp_tensorHom_assoc, + MonoidalCategory.tensorHom_comp_tensorHom_assoc] + have hS1 : (modPowπ A M.X (n + 1) ⊗ₘ + modPowπ A M.X (0 + 1)) ≫ + ((β_ (modPow A M.X (n + 1)) (modPow A M.X (0 + 1))).hom ≫ + modPowMul A M.X (0 + 1) (n + 1) ≫ + modPowCast A M.X (by omega : 0 + 1 + n + 1 = n + 2)) = + (β_ (tensorPow D M.X (n + 1)) + (tensorPow D M.X (0 + 1))).hom ≫ + (tensorPowConcat M.X (0 + 1) (n + 1)).hom ≫ + powCast M.X (by omega : 0 + 1 + (n + 1) = n + 2) ≫ + modPowπ A M.X (n + 2) := by + rw [BraidedCategory.braiding_naturality_assoc, + reassoc_of% (modPowπ_tensor_modPowMul A M.X (0 + 1) + (n + 1)), + modPowπ_cast] + have hS2 : (modPowπ A M'.X (n + 1) ⊗ₘ + modPowπ A M'.X (0 + 1)) ≫ + modPowMul A M'.X (n + 1) (0 + 1) = + (tensorPowConcat M'.X (n + 1) (0 + 1)).hom ≫ + modPowπ A M'.X (n + 1 + (0 + 1)) := + modPowπ_tensor_modPowMul A M'.X (n + 1) (0 + 1) + rw [hS1, hS2] + have hR1 : (modPowπ A M.X (n + 1) ⊗ₘ + modPowπ A M'.X (n + 1)) ≫ + (β_ (modPow A M.X (n + 1)) (modPow A M'.X (n + 1))).hom ≫ + pairPow A M M' d (n + 1) = + (β_ (tensorPow D M.X (n + 1)) + (tensorPow D M'.X (n + 1))).hom ≫ + rawPair A M M' d (n + 1) := by + rw [BraidedCategory.braiding_naturality_assoc, + modPowπ_tensor_pairPow] + have hR2 : (modPowπ A M.X (0 + 1) ⊗ₘ + modPowπ A M'.X (0 + 1)) ≫ + (β_ (modPow A M.X (0 + 1)) (modPow A M'.X (0 + 1))).hom ≫ + pairPow A M M' d (0 + 1) = + (β_ (tensorPow D M.X (0 + 1)) + (tensorPow D M'.X (0 + 1))).hom ≫ + rawPair A M M' d (0 + 1) := by + rw [BraidedCategory.braiding_naturality_assoc, + modPowπ_tensor_pairPow] + rw [hR1, hR2] + have hsplit : ((β_ (tensorPow D M.X (n + 1)) + (tensorPow D M.X (0 + 1))).hom ≫ + (tensorPowConcat M.X (0 + 1) (n + 1)).hom ≫ + powCast M.X (by omega : 0 + 1 + (n + 1) = n + 2) ≫ + modPowπ A M.X (n + 2)) ⊗ₘ + ((tensorPowConcat M'.X (n + 1) (0 + 1)).hom ≫ + modPowπ A M'.X (n + 1 + (0 + 1))) = + (((β_ (tensorPow D M.X (n + 1)) + (tensorPow D M.X (0 + 1))).hom ≫ + (tensorPowConcat M.X (0 + 1) (n + 1)).hom ≫ + powCast M.X (by omega : 0 + 1 + (n + 1) = n + 2)) ⊗ₘ + (tensorPowConcat M'.X (n + 1) (0 + 1)).hom) ≫ + (modPowπ A M.X (n + 2) ⊗ₘ + modPowπ A M'.X (n + 1 + (0 + 1))) := by + rw [MonoidalCategory.tensorHom_comp_tensorHom] + simp only [Category.assoc] + rw [hsplit] + have hβfinal : (modPowπ A M.X (n + 2) ⊗ₘ + modPowπ A M'.X (n + 1 + (0 + 1))) ≫ + (β_ (modPow A M.X (n + 2)) (modPow A M'.X (n + 2))).hom ≫ + pairPow A M M' d (n + 2) = + (β_ (tensorPow D M.X (n + 2)) + (tensorPow D M'.X (n + 2))).hom ≫ + rawPair A M M' d (n + 2) := by + change (modPowπ A M.X (n + 2) ⊗ₘ modPowπ A M'.X (n + 2)) ≫ + (β_ (modPow A M.X (n + 2)) (modPow A M'.X (n + 2))).hom ≫ + pairPow A M M' d (n + 2) = _ + rw [BraidedCategory.braiding_naturality_assoc, + modPowπ_tensor_pairPow] + rw [Category.assoc + (((β_ (tensorPow D M.X (n + 1)) + (tensorPow D M.X (0 + 1))).hom ≫ + (tensorPowConcat M.X (0 + 1) (n + 1)).hom ≫ + powCast M.X (by omega : 0 + 1 + (n + 1) = n + 2)) ⊗ₘ + (tensorPowConcat M'.X (n + 1) (0 + 1)).hom) + (modPowπ A M.X (n + 2) ⊗ₘ + modPowπ A M'.X (n + 1 + (0 + 1)))] + rw [hβfinal] + exact powDeltaCore_raw A M M' d n + +/-- **Multiplicativity of the pairing against the transition +core**: the interchange followed by the aligned multiplications +and the pairing of the joined stage evaluates as the product of +the stage pairings. -/ +theorem powDeltaCore_pairing + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (n : ℕ) : + interchange A (modPowMod A M.X n) (modPowMod A M'.X n) + (modPowMod A M.X 0) (modPowMod A M'.X 0) ≫ + modTensorMap A + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X (by omega : 0 + 1 + n + 1 = n + 2)) + (powMulMod A M'.X n 0) ≫ + modTensorSwap A (modPowMod A M.X (n + 1)) + (modPowMod A M'.X (n + 1)) ≫ + modPowPairing A M M' d (n + 1) = + ((modTensorSwap A (modPowMod A M.X n) (modPowMod A M'.X n) ≫ + modPowPairing A M M' d n) ⊗ₘ + (modTensorSwap A (modPowMod A M.X 0) + (modPowMod A M'.X 0) ≫ + modPowPairing A M M' d 0)) ≫ μ[A] := by + rw [← cancel_epi + (modTensorπ A (modPowMod A M.X n) (modPowMod A M'.X n) ⊗ₘ + modTensorπ A (modPowMod A M.X 0) (modPowMod A M'.X 0))] + refine (powDeltaCore_layer1 A M M' d n).trans + ((powDeltaCore_layer2 A M M' d n).trans ?_) + rw [MonoidalCategory.tensorHom_comp_tensorHom_assoc] + have h1 : modTensorπ A (modPowMod A M.X n) + (modPowMod A M'.X n) ≫ + modTensorSwap A (modPowMod A M.X n) (modPowMod A M'.X n) ≫ + modPowPairing A M M' d n = + (β_ (modPow A M.X (n + 1)) (modPow A M'.X (n + 1))).hom ≫ + pairPow A M M' d (n + 1) := by + rw [modTensorπ_swap_assoc, modTensorπ_modPowPairing] + rfl + have h0 : modTensorπ A (modPowMod A M.X 0) + (modPowMod A M'.X 0) ≫ + modTensorSwap A (modPowMod A M.X 0) (modPowMod A M'.X 0) ≫ + modPowPairing A M M' d 0 = + (β_ (modPow A M.X (0 + 1)) (modPow A M'.X (0 + 1))).hom ≫ + pairPow A M M' d (0 + 1) := by + rw [modTensorπ_swap_assoc, modTensorπ_modPowPairing] + rfl + rw [h1, h0] + rfl + +/-- **The transition retracts against the pairing**: under the +scalar zigzag, one insertion peels off against one zigzag. -/ +theorem powDelta_pairing + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (hzig : d.copair ≫ modTensorSwap A M M' ≫ d.pair = 𝟙 A) + (n : ℕ) : + powDelta A M M' d n ≫ + modTensorSwap A (modPowMod A M.X (n + 1)) + (modPowMod A M'.X (n + 1)) ≫ + modPowPairing A M M' d (n + 1) = + modTensorSwap A (modPowMod A M.X n) + (modPowMod A M'.X n) ≫ + modPowPairing A M M' d n := by + have hflat : powDelta A M M' d n ≫ + modTensorSwap A (modPowMod A M.X (n + 1)) + (modPowMod A M'.X (n + 1)) ≫ + modPowPairing A M M' d (n + 1) = + (ρ_ (powStage A M M' n)).inv ≫ + (powStage A M M' n ◁ powSeed A M M' d) ≫ + (interchange A (modPowMod A M.X n) (modPowMod A M'.X n) + (modPowMod A M.X 0) (modPowMod A M'.X 0) ≫ + modTensorMap A + (modTensorSwapMod A (modPowMod A M.X n) + (modPowMod A M.X 0) ≫ + powMulMod A M.X 0 n ≫ + modPowCastMod A M.X + (by omega : 0 + 1 + n + 1 = n + 2)) + (powMulMod A M'.X n 0) ≫ + modTensorSwap A (modPowMod A M.X (n + 1)) + (modPowMod A M'.X (n + 1)) ≫ + modPowPairing A M M' d (n + 1)) := by + rw [powDelta] + repeat' erw [Category.assoc] + refine hflat.trans ?_ + refine ((congrArg (fun t => + (ρ_ (powStage A M M' n)).inv ≫ + (powStage A M M' n ◁ powSeed A M M' d) ≫ t) + (powDeltaCore_pairing A M M' d n)).trans ?_) + have hseed' : (powStage A M M' n ◁ powSeed A M M' d) ≫ + ((modTensorSwap A (modPowMod A M.X n) + (modPowMod A M'.X n) ≫ modPowPairing A M M' d n) ⊗ₘ + (modTensorSwap A (modPowMod A M.X 0) + (modPowMod A M'.X 0) ≫ modPowPairing A M M' d 0)) ≫ + μ[A] = + ((modTensorSwap A (modPowMod A M.X n) + (modPowMod A M'.X n) ≫ modPowPairing A M M' d n) ⊗ₘ + η[A]) ≫ μ[A] := by + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom_assoc, + Category.id_comp, powSeed_pairing A M M' d hzig] + rfl + refine ((congrArg (fun t => + (ρ_ (powStage A M M' n)).inv ≫ t) hseed').trans ?_) + rw [MonoidalCategory.tensorHom_def] + simp only [Category.assoc] + rw [MonObj.mul_one] + rw [rightUnitor_naturality] + exact Iso.inv_hom_id_assoc (ρ_ (powStage A M M' n)) _ + +/-- **The chain units retract against the pairing**: every +copairing power evaluates to the unit of the base. -/ +theorem powUnitStage_pairing + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (hzig : d.copair ≫ modTensorSwap A M M' ≫ d.pair = 𝟙 A) : + ∀ n : ℕ, powUnitStage A M M' d n ≫ + modTensorSwap A (modPowMod A M.X n) + (modPowMod A M'.X n) ≫ + modPowPairing A M M' d n = η[A] + | 0 => powSeed_pairing A M M' d hzig + | (n + 1) => by + change (powUnitStage A M M' d n ≫ powDelta A M M' d n) ≫ _ = _ + rw [Category.assoc, powDelta_pairing A M M' d hzig n] + exact powUnitStage_pairing A M M' d hzig n + +/-- **Scalar extraction at the head of the `M'`-power**: the tail +action on the `M'`-power extracts as the scalar multiplying the +pairing from the left. -/ +theorem rawPair_actHead + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (n : ℕ) : + (powTailAct A M'.X n ▷ tensorPow D M.X (n + 1)) ≫ + rawPair A M M' d (n + 1) = + (α_ A (tensorPow D M'.X (n + 1)) + (tensorPow D M.X (n + 1))).hom ≫ + (A ◁ rawPair A M M' d (n + 1)) ≫ μ[A] := by + have hsplit : powTailAct A M'.X n ▷ + tensorPow D M.X (n + 1) = + ((α_ A (tensorPow D M'.X n) M'.X).inv ▷ + tensorPow D M.X (n + 1)) ≫ + (((β_ A (tensorPow D M'.X n)).hom ▷ M'.X) ▷ + tensorPow D M.X (n + 1)) ≫ + ((α_ (tensorPow D M'.X n) A M'.X).hom ▷ + tensorPow D M.X (n + 1)) ≫ + ((tensorPow D M'.X n ◁ (β_ M'.X A).inv) ▷ + tensorPow D M.X (n + 1)) ≫ + ((tensorPow D M'.X n ◁ actRight A M'.X) ▷ + tensorPow D M.X (n + 1)) := by + rw [show powTailAct A M'.X n = + (α_ A (tensorPow D M'.X n) M'.X).inv ≫ + ((β_ A (tensorPow D M'.X n)).hom ▷ M'.X) ≫ + (α_ (tensorPow D M'.X n) A M'.X).hom ≫ + (tensorPow D M'.X n ◁ actLeft A M'.X) from rfl, + show actLeft A M'.X = (β_ M'.X A).inv ≫ + actRight A M'.X from by + rw [actRight, Iso.inv_hom_id_assoc]] + conv_rhs => rw [← comp_whiskerRight, ← comp_whiskerRight, + ← comp_whiskerRight, ← comp_whiskerRight] + refine congrArg (· ▷ tensorPow D M.X (n + 1)) ?_ + simp only [MonoidalCategory.whiskerLeft_comp] + rfl + have hsplit2 : (powTailAct A M'.X n ▷ + tensorPow D M.X (n + 1)) ≫ rawPair A M M' d (n + 1) = + ((α_ A (tensorPow D M'.X n) M'.X).inv ▷ + tensorPow D M.X (n + 1)) ≫ + (((β_ A (tensorPow D M'.X n)).hom ▷ M'.X) ▷ + tensorPow D M.X (n + 1)) ≫ + ((α_ (tensorPow D M'.X n) A M'.X).hom ▷ + tensorPow D M.X (n + 1)) ≫ + ((tensorPow D M'.X n ◁ (β_ M'.X A).inv) ▷ + tensorPow D M.X (n + 1)) ≫ + ((tensorPow D M'.X n ◁ actRight A M'.X) ▷ + tensorPow D M.X (n + 1)) ≫ rawPair A M M' d (n + 1) := by + rw [hsplit] + exact (Category.assoc _ _ _).trans + (congrArg (CategoryStruct.comp _) + ((Category.assoc _ _ _).trans + (congrArg (CategoryStruct.comp _) + ((Category.assoc _ _ _).trans + (congrArg (CategoryStruct.comp _) + (Category.assoc _ _ _)))))) + rw [hsplit2, rawPair_actRight_last A M M' d n] + rw [show (β_ M'.X A).inv = (β_ A M'.X).hom from by + rw [← cancel_epi (β_ M'.X A).hom, Iso.hom_inv_id, + SymmetricCategory.symmetry]] + conv_rhs => rw [← IsCommMonObj.mul_comm A, + BraidedCategory.braiding_naturality_right_assoc, + BraidedCategory.braiding_tensor_right_hom A + (tensorPow D M'.X (n + 1)) + (tensorPow D M.X (n + 1))] + have hβexp : (β_ A (tensorPow D M'.X (n + 1))).hom = + (α_ A (tensorPow D M'.X n) M'.X).inv ≫ + ((β_ A (tensorPow D M'.X n)).hom ▷ M'.X) ≫ + (α_ (tensorPow D M'.X n) A M'.X).hom ≫ + (tensorPow D M'.X n ◁ (β_ A M'.X).hom) ≫ + (α_ (tensorPow D M'.X n) M'.X A).inv := + BraidedCategory.braiding_tensor_right_hom A + (tensorPow D M'.X n) M'.X + conv_rhs => rw [hβexp] + monoidal + +/-- The head action extracts through the descended pairing. -/ +theorem pairPow_actHead + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (n : ℕ) : + (modPowAct A M'.X n ▷ modPow A M.X (n + 1)) ≫ + pairPow A M M' d (n + 1) = + (α_ A (modPow A M'.X (n + 1)) + (modPow A M.X (n + 1))).hom ≫ + (A ◁ pairPow A M M' d (n + 1)) ≫ μ[A] := by + refine (cancel_epi ((A ⊗ modPow A M'.X (n + 1)) ◁ + modPowπ A M.X (n + 1))).mp ?_ + refine (cancel_epi ((A ◁ modPowπ A M'.X (n + 1)) ▷ + tensorPow D M.X (n + 1))).mp ?_ + have hL1 : ((A ⊗ modPow A M'.X (n + 1)) ◁ + modPowπ A M.X (n + 1)) ≫ + (modPowAct A M'.X n ▷ modPow A M.X (n + 1)) = + (modPowAct A M'.X n ▷ tensorPow D M.X (n + 1)) ≫ + (modPow A M'.X (n + 1) ◁ modPowπ A M.X (n + 1)) := + whisker_exchange _ _ + have hL2 : ((A ◁ modPowπ A M'.X (n + 1)) ▷ + tensorPow D M.X (n + 1)) ≫ + (modPowAct A M'.X n ▷ tensorPow D M.X (n + 1)) = + (powTailAct A M'.X n ▷ tensorPow D M.X (n + 1)) ≫ + (modPowπ A M'.X (n + 1) ▷ tensorPow D M.X (n + 1)) := by + rw [← comp_whiskerRight, whiskerLeft_modPowπ_modPowAct, + comp_whiskerRight] + have hL3 : (modPowπ A M'.X (n + 1) ▷ + tensorPow D M.X (n + 1)) ≫ + (modPow A M'.X (n + 1) ◁ modPowπ A M.X (n + 1)) ≫ + pairPow A M M' d (n + 1) = + rawPair A M M' d (n + 1) := by + rw [← MonoidalCategory.tensorHom_def_assoc, + modPowπ_tensor_pairPow] + conv_lhs => rw [reassoc_of% hL1, reassoc_of% hL2, hL3, + rawPair_actHead A M M' d n] + have hR1 : ((A ◁ modPowπ A M'.X (n + 1)) ▷ + tensorPow D M.X (n + 1)) ≫ + ((A ⊗ modPow A M'.X (n + 1)) ◁ modPowπ A M.X (n + 1)) ≫ + (α_ A (modPow A M'.X (n + 1)) + (modPow A M.X (n + 1))).hom = + (α_ A (tensorPow D M'.X (n + 1)) + (tensorPow D M.X (n + 1))).hom ≫ + (A ◁ (modPowπ A M'.X (n + 1) ⊗ₘ + modPowπ A M.X (n + 1))) := by + rw [← MonoidalCategory.tensorHom_def_assoc] + have hnat := associator_naturality (𝟙 A) + (modPowπ A M'.X (n + 1)) (modPowπ A M.X (n + 1)) + simp only [MonoidalCategory.id_tensorHom] at hnat + exact hnat + conv_rhs => rw [reassoc_of% hR1, + ← MonoidalCategory.whiskerLeft_comp_assoc, + modPowπ_tensor_pairPow] + +/-- **The power pairing is linear**: it is a map of modules into +the regular module. -/ +theorem modPowPairing_linear + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (n : ℕ) : + haveI := modTensorModObj A (modPowMod A M'.X n) + (modPowMod A M.X n) + actLeft A (modTensor A (modPowMod A M'.X n) + (modPowMod A M.X n)) ≫ modPowPairing A M M' d n = + (A ◁ modPowPairing A M M' d n) ≫ μ[A] := by + let := modTensorModObj A (modPowMod A M'.X n) + (modPowMod A M.X n) + apply modTensor_whisker_hom_ext A (modPowMod A M'.X n) + (modPowMod A M.X n) A + conv_lhs => rw [show actLeft A (modTensor A + (modPowMod A M'.X n) (modPowMod A M.X n)) = + modTensorAct A (modPowMod A M'.X n) (modPowMod A M.X n) + from rfl] + conv_lhs => rw [whiskerLeft_modTensorπ_act_assoc, + modTensorπ_modPowPairing] + conv_rhs => rw [← MonoidalCategory.whiskerLeft_comp_assoc, + modTensorπ_modPowPairing] + change (α_ A (modPow A M'.X (n + 1)) + (modPow A M.X (n + 1))).inv ≫ + (modPowAct A M'.X n ▷ modPow A M.X (n + 1)) ≫ + pairPow A M M' d (n + 1) = + (A ◁ pairPow A M M' d (n + 1)) ≫ μ[A] + rw [pairPow_actHead A M M' d n, Iso.inv_hom_id_assoc] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowZig.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowZig.lean new file mode 100644 index 0000000000..04f0aa8924 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowZig.lean @@ -0,0 +1,317 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowTriangle + +/-! +# The carrier calculus of the power chain + +The scalar-based copairing powers of a duality datum, and the two +carrier-level operations the chain is built from: contraction +against a pairing (`RS.carrierContract`) and insertion of a +copairing (`RS.zigCarrier`), with their naturality in the module +and their evaluation on scalars. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The scalar-based copairing power**: the base acts on the +chain unit. -/ +noncomputable def powCopairA + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (n : ℕ) : A ⟶ powStage A M M' n := + (ρ_ A).inv ≫ (A ◁ powUnitStage A M M' d n) ≫ + modTensorAct A (modPowMod A M.X n) (modPowMod A M'.X n) + +/-- The bottom copairing power is the copairing, through the +singleton stages. -/ +theorem powCopairA_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + powCopairA A M M' d 0 = + d.copair ≫ modTensorMap A (toModPowModZero A M) + (toModPowModZero A M') := by + rw [powCopairA] + change (ρ_ A).inv ≫ (A ◁ (copairUnit A M M' d ≫ + modTensorMap A (toModPowModZero A M) + (toModPowModZero A M'))) ≫ + modTensorAct A (modPowMod A M.X 0) (modPowMod A M'.X 0) = _ + rw [copairUnit, MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + Category.assoc] + rw [show (A ◁ modTensorMap A (toModPowModZero A M) + (toModPowModZero A M')) ≫ + modTensorAct A (modPowMod A M.X 0) (modPowMod A M'.X 0) = + modTensorAct A M M' ≫ modTensorMap A (toModPowModZero A M) + (toModPowModZero A M') from + (modTensorAct_map A (toModPowModZero A M) + (toModPowModZero A M')).symm] + have hlin' : μ[A] ≫ d.copair = + (A ◁ d.copair) ≫ modTensorAct A M M' := d.copair_linear + rw [← reassoc_of% hlin'] + rw [← Category.assoc, ← Category.assoc] + rw [show ((ρ_ A).inv ≫ (A ◁ η[A])) ≫ μ[A] = 𝟙 A from by + rw [Category.assoc, MonObj.mul_one, Iso.inv_hom_id]] + rw [Category.id_comp] + +section CarrierZig + +/-- The carrier contraction: the module crosses the relative +tensor, pairs against it, and the scalar acts. -/ +noncomputable def carrierContract + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) : + M.X ⊗ modTensor A M' M ⟶ M.X := + modTensorWhiskerDesc A M' M M.X + ((β_ M.X (M'.X ⊗ M.X)).hom ≫ + ((modTensorπ A M' M ≫ p) ▷ M.X) ≫ actLeft A M.X) + (by + have hw : ∀ (w : (M'.X ⊗ A) ⊗ M.X ⟶ M'.X ⊗ M.X), + (M.X ◁ w) ≫ (β_ M.X (M'.X ⊗ M.X)).hom ≫ + ((modTensorπ A M' M ≫ p) ▷ M.X) ≫ + actLeft A M.X = + (β_ M.X ((M'.X ⊗ A) ⊗ M.X)).hom ≫ + ((w ≫ modTensorπ A M' M ≫ p) ▷ M.X) ≫ + actLeft A M.X := by + intro w + rw [BraidedCategory.braiding_naturality_right_assoc, + ← comp_whiskerRight_assoc] + rw [hw, hw] + have hcond : modTensorLegM A M' M ≫ + modTensorπ A M' M ≫ p = + modTensorLegN A M' M ≫ modTensorπ A M' M ≫ p := by + rw [← Category.assoc, modTensor_condition, + Category.assoc] + exact congrArg (fun t => + (β_ M.X ((M'.X ⊗ A) ⊗ M.X)).hom ≫ (t ▷ M.X) ≫ + actLeft A M.X) hcond) + +/-- Defining equation of the carrier contraction. -/ +@[reassoc (attr := simp)] +theorem whiskerLeft_π_carrierContract + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) : + (M.X ◁ modTensorπ A M' M) ≫ carrierContract A p = + (β_ M.X (M'.X ⊗ M.X)).hom ≫ + ((modTensorπ A M' M ≫ p) ▷ M.X) ≫ actLeft A M.X := + whiskerLeft_modTensorπ_whiskerDesc A M' M M.X _ _ + +/-- **The carrier zigzag** of a copairing and a pairing: insert +the copairing, cross, contract. -/ +noncomputable def zigCarrier + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {M' : Mod D A} + (c : A ⟶ modTensor A M' M) + (p : modTensor A M' M ⟶ A) : M.X ⟶ M.X := + (λ_ M.X).inv ≫ ((η[A] ≫ c) ▷ M.X) ≫ + (β_ (modTensor A M' M) M.X).hom ≫ carrierContract A p + +/-- The singleton stage maps back onto the module. -/ +noncomputable def fromModPowModZero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] + (M : Mod D A) : + modPowMod A M.X 0 ⟶ M := + Mod.Hom.mk' ((modPowOne A M.X).hom) + (modPowAct_modPowOne A M.X) + +/-- The carrier contraction transports along module maps of the +dual pair. -/ +theorem carrierContract_map + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {M' : Mod D A} + {N N' : Mod D A} + (e : M ⟶ N) (f : N ⟶ M) (f' : N' ⟶ M') + (hfe : f ≫ e = 𝟙 N) + (p : modTensor A M' M ⟶ A) (p' : modTensor A N' N ⟶ A) + (hp' : modTensorMap A f' f ≫ p = p') : + carrierContract A p' = + (f.hom ▷ modTensor A N' N) ≫ + (M.X ◁ modTensorMap A f' f) ≫ + carrierContract A p ≫ e.hom := by + apply modTensor_whisker_hom_ext A N' N N.X + rw [whiskerLeft_π_carrierContract] + have hpush : (N.X ◁ modTensorπ A N' N) ≫ + (f.hom ▷ modTensor A N' N) = + (f.hom ▷ (N'.X ⊗ N.X)) ≫ (M.X ◁ modTensorπ A N' N) := + whisker_exchange _ _ + rw [reassoc_of% hpush] + have hmerge : (M.X ◁ modTensorπ A N' N) ≫ + (M.X ◁ modTensorMap A f' f) = + M.X ◁ ((f'.hom ⊗ₘ f.hom) ≫ modTensorπ A M' M) := by + rw [← MonoidalCategory.whiskerLeft_comp, modTensorπ_map] + rw [reassoc_of% hmerge, MonoidalCategory.whiskerLeft_comp, + Category.assoc, whiskerLeft_π_carrierContract_assoc] + have hs1 : (M.X ◁ (f'.hom ⊗ₘ f.hom)) ≫ + (β_ M.X (M'.X ⊗ M.X)).hom = + (β_ M.X (N'.X ⊗ N.X)).hom ≫ + ((f'.hom ⊗ₘ f.hom) ▷ M.X) := by + rw [BraidedCategory.braiding_naturality_right] + rw [reassoc_of% hs1] + have hs2 : (f.hom ▷ (N'.X ⊗ N.X)) ≫ + (β_ M.X (N'.X ⊗ N.X)).hom = + (β_ N.X (N'.X ⊗ N.X)).hom ≫ + ((N'.X ⊗ N.X) ◁ f.hom) := by + rw [BraidedCategory.braiding_naturality_left] + rw [reassoc_of% hs2] + refine congrArg (CategoryStruct.comp _) ?_ + rw [whisker_exchange_assoc, whisker_exchange_assoc] + have := f.isModHom + rw [show (A ◁ f.hom) ≫ actLeft A M.X ≫ e.hom = + actLeft A N.X ≫ f.hom ≫ e.hom from by + rw [← actLeft_natural_assoc]] + rw [show f.hom ≫ e.hom = 𝟙 N.X from by + have h := congrArg Mod.Hom.hom hfe + exact h] + rw [Category.comp_id] + have hfinal : ((f'.hom ⊗ₘ f.hom) ▷ N.X) ≫ + ((modTensorπ A M' M ≫ p) ▷ N.X) = + ((modTensorπ A N' N ≫ p') ▷ N.X) := by + rw [← comp_whiskerRight] + congr 1 + rw [← Category.assoc, ← modTensorπ_map, Category.assoc, + hp'] + rw [reassoc_of% hfinal] + +/-- The carrier zigzag transports along module isomorphisms of +the dual pair. -/ +theorem zigCarrier_map + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {M' : Mod D A} + {N N' : Mod D A} + (e : M ⟶ N) (f : N ⟶ M) (e' : M' ⟶ N') (f' : N' ⟶ M') + (hfe : f ≫ e = 𝟙 N) (hef : e ≫ f = 𝟙 M) + (he'f' : e' ≫ f' = 𝟙 M') + (c : A ⟶ modTensor A M' M) (p : modTensor A M' M ⟶ A) + (c' : A ⟶ modTensor A N' N) (p' : modTensor A N' N ⟶ A) + (hc' : c' = c ≫ modTensorMap A e' e) + (hp' : modTensorMap A f' f ≫ p = p') : + zigCarrier A c' p' = + f.hom ≫ zigCarrier A c p ≫ e.hom := by + rw [zigCarrier, zigCarrier, + carrierContract_map A e f f' hfe p p' hp', hc'] + rw [Category.assoc, comp_whiskerRight, comp_whiskerRight, + Category.assoc, Category.assoc] + have hs2 : (modTensorMap A e' e ▷ N.X) ≫ + (β_ (modTensor A N' N) N.X).hom = + (β_ (modTensor A M' M) N.X).hom ≫ + (N.X ◁ modTensorMap A e' e) := by + rw [BraidedCategory.braiding_naturality_left] + rw [reassoc_of% hs2] + have hs3 : (N.X ◁ modTensorMap A e' e) ≫ + (f.hom ▷ modTensor A N' N) = + (f.hom ▷ modTensor A M' M) ≫ + (M.X ◁ modTensorMap A e' e) := + whisker_exchange _ _ + rw [reassoc_of% hs3] + have hs4 : (M.X ◁ modTensorMap A e' e) ≫ + (M.X ◁ modTensorMap A f' f) = 𝟙 _ := by + rw [← MonoidalCategory.whiskerLeft_comp, + ← modTensorMap_comp, he'f', hef, modTensorMap_id, + MonoidalCategory.whiskerLeft_id] + rw [reassoc_of% hs4] + have hs5 : (β_ (modTensor A M' M) N.X).hom ≫ + (f.hom ▷ modTensor A M' M) = + (modTensor A M' M ◁ f.hom) ≫ + (β_ (modTensor A M' M) M.X).hom := by + rw [BraidedCategory.braiding_naturality_right] + rw [reassoc_of% hs5] + have hs6a : (c ▷ N.X) ≫ (modTensor A M' M ◁ f.hom) = + (A ◁ f.hom) ≫ (c ▷ M.X) := + (whisker_exchange _ _).symm + rw [reassoc_of% hs6a] + have hs6b : (η[A] ▷ N.X) ≫ (A ◁ f.hom) = + (𝟙_ D ◁ f.hom) ≫ (η[A] ▷ M.X) := + (whisker_exchange _ _).symm + rw [reassoc_of% hs6b] + have hlam : (λ_ N.X).inv ≫ (𝟙_ D ◁ f.hom) = + f.hom ≫ (λ_ M.X).inv := by + rw [leftUnitor_inv_naturality] + rw [reassoc_of% hlam] + conv_rhs => rw [comp_whiskerRight] + simp only [Category.assoc] + +/-- The carrier contraction is the crossing, the pairing, and the +action, already at the quotient. -/ +theorem carrierContract_eq + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) : + carrierContract A p = + (β_ M.X (modTensor A M' M)).hom ≫ (p ▷ M.X) ≫ + actLeft A M.X := by + apply modTensor_whisker_hom_ext A M' M M.X + rw [whiskerLeft_π_carrierContract] + have hβ : (M.X ◁ modTensorπ A M' M) ≫ + (β_ M.X (modTensor A M' M)).hom = + (β_ M.X (M'.X ⊗ M.X)).hom ≫ + (modTensorπ A M' M ▷ M.X) := by + rw [BraidedCategory.braiding_naturality_right] + rw [reassoc_of% hβ, ← comp_whiskerRight_assoc] + +/-- **The scalar form of the carrier zigzag**: the zigzag is the +action of the paired copairing scalar. -/ +theorem zigCarrier_scalar + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] {M : Mod D A} {M' : Mod D A} + (c : A ⟶ modTensor A M' M) + (p : modTensor A M' M ⟶ A) : + zigCarrier A c p = + (λ_ M.X).inv ≫ ((η[A] ≫ c ≫ p) ▷ M.X) ≫ + actLeft A M.X := by + rw [zigCarrier, carrierContract_eq] + have hββ : (β_ (modTensor A M' M) M.X).hom ≫ + (β_ M.X (modTensor A M' M)).hom = 𝟙 _ := + SymmetricCategory.symmetry _ _ + rw [reassoc_of% hββ, ← comp_whiskerRight_assoc] + exact congrArg (fun t => + (λ_ M.X).inv ≫ (t ▷ M.X) ≫ actLeft A M.X) + (Category.assoc _ _ _) + +end CarrierZig + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowZigzag.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowZigzag.lean new file mode 100644 index 0000000000..32d63316ac --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowZigzag.lean @@ -0,0 +1,124 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransfer + +/-! +# The power datum inherits the zigzag laws + +Deligne's 1.15 tensor part, in chain form: the zigzag laws of a +duality datum pass to its tensor powers. The bottom stage is the +transfer of the datum along the arity-one comparison isomorphisms +— the transfer theorem applies with trivial idempotents. The +step peels one inserted couple off the onion-aligned copairing +power against the outermost ring of the nested pairing. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- The arity-one power pairing is the pairing, through the +comparison isomorphisms. -/ +theorem modPowPairing_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + modPowPairing A M M' d 0 = + modTensorMap A (fromModPowModZero A M') + (fromModPowModZero A M) ≫ d.pair := by + apply modTensor_hom_ext A (modPowMod A M'.X 0) + (modPowMod A M.X 0) + rw [modTensorπ_modPowPairing, ← Category.assoc, + modTensorπ_map] + have h2 : pairPow A M M' d 1 = + ((modPowOne A M'.X).hom ⊗ₘ (modPowOne A M.X).hom) ≫ + pairRaw A M M' d := by + rw [← modPowOne_pairPow A M M' d, ← Category.assoc, + MonoidalCategory.tensorHom_comp_tensorHom, + Iso.hom_inv_id, Iso.hom_inv_id, + MonoidalCategory.id_tensorHom_id, Category.id_comp] + rw [h2, pairRaw, + show (fromModPowModZero A M').hom = (modPowOne A M'.X).hom + from rfl, + show (fromModPowModZero A M).hom = (modPowOne A M.X).hom + from rfl, Category.assoc] + rfl + +/-- Duality data with equal pairings and copairings are equal. -/ +theorem ModDualityDatum.ext' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] + {N N' : Mod D A} + {x y : ModDualityDatum A N N'} + (hp : x.pair = y.pair) (hc : x.copair = y.copair) : + x = y := by + obtain ⟨p1, c1, _, _⟩ := x + obtain ⟨p2, c2, _, _⟩ := y + simp only at hp hc + subst hp + subst hc + rfl + +/-- **The bottom power datum is the transferred datum**: the +arity-one comparison isomorphisms carry the datum to its zeroth +power. -/ +theorem powDualityDatum_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + powDualityDatum A M M' d 0 = + d.transfer A (fromModPowModZero A M) (fromModPowModZero A M') + (toModPowModZero A M) (toModPowModZero A M') := + ModDualityDatum.ext' A (modPowPairing_zero A M M' d) + (powCopairA_zero A M M' d) + +/-- **The bottom power datum satisfies the zigzag laws.** -/ +theorem powDualityDatum_zigzag_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (hz : ModZigzagDatum A d) : + ModZigzagDatum A (powDualityDatum A M M' d 0) := by + rw [powDualityDatum_zero A M M' d] + have hsr : fromModPowModZero A M ≫ toModPowModZero A M = + 𝟙 (modPowMod A M.X 0) := + Mod.hom_ext _ _ ((modPowOne A M.X).hom_inv_id) + have hsr' : fromModPowModZero A M' ≫ toModPowModZero A M' = + 𝟙 (modPowMod A M'.X 0) := + Mod.hom_ext _ _ ((modPowOne A M'.X).hom_inv_id) + have he : toModPowModZero A M ≫ fromModPowModZero A M = + 𝟙 M := + Mod.hom_ext _ _ ((modPowOne A M.X).inv_hom_id) + have he' : toModPowModZero A M' ≫ fromModPowModZero A M' = + 𝟙 M' := + Mod.hom_ext _ _ ((modPowOne A M'.X).inv_hom_id) + exact modZigzagDatum_transfer A d _ _ _ _ hz hsr hsr' + (by rw [he, he']) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PresentedQuotient.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PresentedQuotient.lean new file mode 100644 index 0000000000..1b107233cc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PresentedQuotient.lean @@ -0,0 +1,339 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndImage + +/-! +# Quotients of countably presented ind-objects + +`RS.CountablyPresented` — a countable filtered colimit of embedded +objects — is the shape in which "built from countably much data" +enters the dimension count of +`RS.Classical.Deligne.GammaCountable`. This file shows the notion +stable under quotients: an epimorphic image of a countably presented +ind-object is countably presented +(`RS.CountablyPresented.of_epi`), over the same finite length +hypothesis that discharges `RS.IndImageEmbedded`. + +The argument. Write `Z` as the colimit of a countable filtered +diagram `D` of embedded objects and let `p : Z ⟶ Q` be an +epimorphism. The composites of the colimit inclusions with `p` form +a family `RS.quotientStage` of maps into `Q`, compatible with the +structural maps of `D`, and the images of its members assemble into a +diagram `RS.imageDiag` — functorially, because such a family is a +diagram in the arrow category and the image is a functor on the arrow +category (`CategoryTheory.Limits.im`). + +The colimit of that diagram is `Q` itself +(`RS.exists_iso_colimit_imageDiag`). It maps to `Q` by the image +inclusions; the map is a monomorphism because filtered colimits are +exact in the ind-completion, so `colim` preserves monomorphisms +(`CategoryTheory.Limits.colim.map_mono'` over the AB5 property of +`Ind C`), and an epimorphism because the members of the family are +jointly epimorphic (`RS.quotientStage_jointly_epi`) and each factors +through its image. + +Finite length makes each of those images embedded +(`RS.indImageEmbedded_of_lengthLE`), and a diagram of ind-objects all +of whose values are embedded is the embedding of a diagram in the +base category (`RS.liftEmbedded`), which is what +`RS.CountablyPresented` asks for. + +The dimension counts the descent consumes follow: the even component +of a countably presented ind-object is of at most countable dimension +(`RS.rank_hom_unit_le_aleph0_of_presented`), and hence so is that of +any of its quotients (`RS.rank_hom_unit_le_aleph0_of_epi`). +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +attribute [local instance] IsFiltered.isConnected + +/-! ## Lifting a diagram of embedded objects + +A diagram of ind-objects whose values are all embedded is the +embedding of a diagram in the base category: the structural maps are +transported through the full faithfulness of `RS.indOf`. -/ + +section Lift + +variable {C : Type v} + +/-- **A diagram of embedded objects comes from the base category**: +the chosen isomorphisms transport the structural maps down through +the full faithfulness of the embedding. -/ +noncomputable def liftEmbedded [SmallCategory C] + {I : Type v} [SmallCategory I] + (F : I ⥤ Ind C) (W : I → C) (θ : ∀ i, F.obj i ≅ indOf.obj (W i)) : + I ⥤ C where + obj := W + map {i j} α := Ind.yoneda.fullyFaithful.preimage + ((θ i).inv ≫ F.map α ≫ (θ j).hom) + map_id i := by + refine indOf.map_injective ?_ + rw [Ind.yoneda.fullyFaithful.map_preimage] + simp + map_comp {i j k} α β := by + refine indOf.map_injective ?_ + simp + +/-- The lifted diagram embeds back to the diagram it was lifted +from. -/ +noncomputable def liftEmbeddedIso [SmallCategory C] + {I : Type v} [SmallCategory I] + (F : I ⥤ Ind C) (W : I → C) (θ : ∀ i, F.obj i ≅ indOf.obj (W i)) : + liftEmbedded F W θ ⋙ indOf ≅ F := + NatIso.ofComponents (fun i => (θ i).symm) (by + intro i j α + change indOf.map (Ind.yoneda.fullyFaithful.preimage + ((θ i).inv ≫ F.map α ≫ (θ j).hom)) ≫ (θ j).inv = + (θ i).inv ≫ F.map α + rw [Ind.yoneda.fullyFaithful.map_preimage] + simp) + +end Lift + +/-! ## The diagram of images + +A compatible family of maps into a fixed object is a diagram in the +arrow category, and the image is a functor on the arrow category +(`CategoryTheory.Limits.im`), so the images of the members of the +family form a diagram again. -/ + +section ImageDiagram + +variable {C : Type v} + +/-- A compatible family of maps into a fixed object, read as a +diagram in the arrow category. -/ +noncomputable def arrowDiagram + [SmallCategory C] {I : Type v} [SmallCategory I] {D : I ⥤ Ind C} + {Q : Ind C} + (f : ∀ i, D.obj i ⟶ Q) + (hf : ∀ (i j : I) (α : i ⟶ j), D.map α ≫ f j = f i) : + I ⥤ Arrow (Ind C) where + obj i := Arrow.mk (f i) + map {i j} α := Arrow.homMk' (D.map α) (𝟙 Q) + (by rw [hf i j α, Category.comp_id]) + map_id i := by + ext + · exact D.map_id i + · rfl + map_comp α β := by + ext + · exact D.map_comp α β + · exact (Category.comp_id (𝟙 Q)).symm + +/-- **The diagram of images** of a compatible family of maps into a +fixed object. -/ +noncomputable def imageDiag + [SmallCategory C] [Abelian C] {I : Type v} [SmallCategory I] + {D : I ⥤ Ind C} {Q : Ind C} + (f : ∀ i, D.obj i ⟶ Q) + (hf : ∀ (i j : I) (α : i ⟶ j), D.map α ≫ f j = f i) : I ⥤ Ind C := + arrowDiagram f hf ⋙ Limits.im + +/-- The image inclusions, as a map into the constant diagram. -/ +noncomputable def imageDiagHom + [SmallCategory C] [Abelian C] {I : Type v} [SmallCategory I] + {D : I ⥤ Ind C} {Q : Ind C} + (f : ∀ i, D.obj i ⟶ Q) + (hf : ∀ (i j : I) (α : i ⟶ j), D.map α ≫ f j = f i) : + imageDiag f hf ⟶ (Functor.const I).obj Q where + app i := image.ι (f i) + naturality _ _ α := image.map_ι ((arrowDiagram f hf).map α) + +/-- The map from the colimit of the images to the common target. -/ +noncomputable def imageColimitDesc + [SmallCategory C] [Abelian C] {I : Type v} [SmallCategory I] + {D : I ⥤ Ind C} {Q : Ind C} + [IsFiltered I] + (f : ∀ i, D.obj i ⟶ Q) + (hf : ∀ (i j : I) (α : i ⟶ j), D.map α ≫ f j = f i) : + colimit (imageDiag f hf) ⟶ Q := + colimit.desc (imageDiag f hf) (Cocone.mk Q (imageDiagHom f hf)) + +theorem ι_imageColimitDesc + [SmallCategory C] [Abelian C] {I : Type v} [SmallCategory I] + {D : I ⥤ Ind C} {Q : Ind C} + [IsFiltered I] (f : ∀ i, D.obj i ⟶ Q) + (hf : ∀ (i j : I) (α : i ⟶ j), D.map α ≫ f j = f i) (i : I) : + colimit.ι (imageDiag f hf) i ≫ imageColimitDesc f hf = + image.ι (f i) := + colimit.ι_desc _ i + +/-- **The images of a jointly epimorphic filtered family exhaust +their target.** The map from the colimit of the images is a +monomorphism because filtered colimits are exact in the +ind-completion, and an epimorphism because every member of the family +factors through its image. -/ +theorem exists_iso_colimit_imageDiag + [SmallCategory C] [Abelian C] {I : Type v} [SmallCategory I] + {D : I ⥤ Ind C} {Q : Ind C} + [IsFiltered I] + (f : ∀ i, D.obj i ⟶ Q) + (hf : ∀ (i j : I) (α : i ⟶ j), D.map α ≫ f j = f i) + (hepi : ∀ {T : Ind C} (a b : Q ⟶ T), + (∀ i, f i ≫ a = f i ≫ b) → a = b) : + Nonempty (Q ≅ colimit (imageDiag f hf)) := by + have : ∀ i : I, Mono ((imageDiagHom f hf).app i) := fun i => + inferInstanceAs (Mono (image.ι (f i))) + have : Mono (imageDiagHom f hf) := NatTrans.mono_of_mono_app _ + have : Mono (imageColimitDesc f hf) := + colim.map_mono' (imageDiagHom f hf) (colimit.isColimit _) + (isColimitConstCocone I Q) (imageColimitDesc f hf) + (fun j => (ι_imageColimitDesc f hf j).trans + (Category.comp_id _).symm) + have : Epi (imageColimitDesc f hf) := by + refine ⟨fun a b hab => hepi a b (fun i => ?_)⟩ + have h1 : (colimit.ι (imageDiag f hf) i ≫ + imageColimitDesc f hf) ≫ a = + (colimit.ι (imageDiag f hf) i ≫ + imageColimitDesc f hf) ≫ b := + (Category.assoc _ _ _).trans + ((whisker_eq _ hab).trans (Category.assoc _ _ _).symm) + have h2 : image.ι (f i) ≫ a = image.ι (f i) ≫ b := + ((eq_whisker (ι_imageColimitDesc f hf i).symm a).trans h1).trans + (eq_whisker (ι_imageColimitDesc f hf i) b) + exact ((eq_whisker (image.fac (f i)).symm a).trans + ((Category.assoc _ _ _).trans ((whisker_eq _ h2).trans + (Category.assoc _ _ _).symm))).trans + (eq_whisker (image.fac (f i)) b) + have : IsIso (imageColimitDesc f hf) := isIso_of_mono_of_epi _ + exact ⟨(asIso (imageColimitDesc f hf)).symm⟩ + +end ImageDiagram + +/-! ## The quotient of a countably presented ind-object -/ + +section Quotient + +variable {C : Type v} + +/-- The stages of a presentation of `Z`, followed by a map out of +`Z`. -/ +noncomputable def quotientStage + [SmallCategory C] {I : Type v} [SmallCategory I] [IsFiltered I] + {D : I ⥤ Ind C} {Z : Ind C} {Q : Ind C} + (e : Z ≅ colimit D) (p : Z ⟶ Q) + (i : I) : D.obj i ⟶ Q := + colimit.ι D i ≫ e.inv ≫ p + +/-- The stages are compatible with the structural maps of the +presentation. -/ +theorem quotientStage_comp + [SmallCategory C] {I : Type v} [SmallCategory I] [IsFiltered I] + {D : I ⥤ Ind C} {Z : Ind C} {Q : Ind C} + (e : Z ≅ colimit D) (p : Z ⟶ Q) (i j : I) + (α : i ⟶ j) : + D.map α ≫ quotientStage e p j = quotientStage e p i := by + change D.map α ≫ colimit.ι D j ≫ e.inv ≫ p = + colimit.ι D i ≫ e.inv ≫ p + rw [← Category.assoc, colimit.w] + +/-- **The stages of a presentation, followed by an epimorphism, are +jointly epimorphic.** -/ +theorem quotientStage_jointly_epi + [SmallCategory C] {I : Type v} [SmallCategory I] [IsFiltered I] + {D : I ⥤ Ind C} {Z : Ind C} {Q : Ind C} + (e : Z ≅ colimit D) (p : Z ⟶ Q) + [Epi p] {T : Ind C} (a b : Q ⟶ T) + (h : ∀ i, quotientStage e p i ≫ a = quotientStage e p i ≫ b) : + a = b := by + refine (cancel_epi p).mp ((cancel_epi e.inv).mp + (colimit.hom_ext (fun i => ?_))) + calc colimit.ι D i ≫ e.inv ≫ p ≫ a + = colimit.ι D i ≫ (e.inv ≫ p) ≫ a := + whisker_eq _ (Category.assoc _ _ _).symm + _ = (colimit.ι D i ≫ e.inv ≫ p) ≫ a := (Category.assoc _ _ _).symm + _ = (colimit.ι D i ≫ e.inv ≫ p) ≫ b := h i + _ = colimit.ι D i ≫ (e.inv ≫ p) ≫ b := Category.assoc _ _ _ + _ = colimit.ι D i ≫ e.inv ≫ p ≫ b := + whisker_eq _ (Category.assoc _ _ _) + +/-- **A quotient of a countably presented ind-object is countably +presented.** Finite length makes the images of the stages embedded, +and those images exhaust the quotient. -/ +theorem CountablyPresented.of_epi [SmallCategory C] [Abelian C] + (hlen : ∀ Z : C, ∃ N, LengthLE Z N) {Z Q : Ind C} (p : Z ⟶ Q) + [Epi p] (h : CountablyPresented Z) : CountablyPresented Q := by + classical + obtain ⟨I, hcat, hfil, hcnt, G, ⟨e⟩⟩ := h + let := hcat + let := hfil + let := hcnt + have hcomp := quotientStage_comp e p + obtain ⟨eQ⟩ := exists_iso_colimit_imageDiag (quotientStage e p) + hcomp (fun a b hab => quotientStage_jointly_epi e p a b hab) + have hemb : ∀ i : I, ∃ V : C, + Nonempty ((imageDiag (quotientStage e p) hcomp).obj i ≅ + indOf.obj V) := fun i => + indImageEmbedded_of_lengthLE hlen (G.obj i) Q (quotientStage e p i) + choose W hW using hemb + refine ⟨I, hcat, hfil, hcnt, + liftEmbedded (imageDiag (quotientStage e p) hcomp) W + (fun i => (hW i).some), ⟨eQ ≪≫ ?_⟩⟩ + exact (HasColimit.isoOfNatIso (liftEmbeddedIso + (imageDiag (quotientStage e p) hcomp) W + (fun i => (hW i).some))).symm + +end Quotient + +/-! ## The dimension counts + +The even component of a countably presented ind-object is a countable +union of even components of embedded objects, hence of at most +countable dimension; the same then holds for every quotient. -/ + +section Rank + +variable {C : Type v} + +/-- **A countably presented ind-object has countable even +component**: it is a countable filtered colimit of embedded objects, +each of which has finite dimensional even component by finite +length. -/ +theorem rank_hom_unit_le_aleph0_of_presented + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ C] [MonoidalPreadditive C] [MonoidalLinear ℂ C] + [RigidCategory C] [CategoryTheory.Linear ℂ (Ind C)] + (hu : HasScalarUnit C) + (hsmul : IndOfLinear C) (hlen : ∀ Z : C, ∃ N : ℕ, LengthLE Z N) + {Z : Ind C} (h : CountablyPresented Z) : + Module.rank ℂ (𝟙_ (Ind C) ⟶ Z) ≤ Cardinal.aleph0 := by + obtain ⟨I, hcat, hfil, hcnt, G, ⟨e⟩⟩ := h + let := hcat + let := hfil + let := hcnt + refine rank_hom_unit_le_aleph0_of_iso e ?_ + exact rank_hom_unit_colimit_le_aleph0 _ (fun i => + rank_hom_unit_indOf_le_aleph0 hu hsmul (hlen (G.obj i))) + +/-- **A quotient of a countably presented ind-object has countable +even component.** This is the form in which the countable descent +consumes `RS.CountablyPresented.of_epi`. -/ +theorem rank_hom_unit_le_aleph0_of_epi + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ C] [MonoidalPreadditive C] [MonoidalLinear ℂ C] + [RigidCategory C] [CategoryTheory.Linear ℂ (Ind C)] + (hu : HasScalarUnit C) + (hsmul : IndOfLinear C) (hlen : ∀ Z : C, ∃ N : ℕ, LengthLE Z N) + {Z Q : Ind C} (p : Z ⟶ Q) [Epi p] (h : CountablyPresented Z) : + Module.rank ℂ (𝟙_ (Ind C) ⟶ Q) ≤ Cardinal.aleph0 := + rank_hom_unit_le_aleph0_of_presented hu hsmul hlen + (CountablyPresented.of_epi hlen p h) + +end Rank + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21.lean new file mode 100644 index 0000000000..c92a5c9c84 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21.lean @@ -0,0 +1,74 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21Core +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverSplitting +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSimple + +/-! +# Deligne's Proposition 2.1, over a category with an odd line + +If every object of a small abelian rigid symmetric monoidal +ℂ-linear category with scalar unit endomorphisms is killed by some +Schur functor, and its Ind-completion carries an odd line, then +there is a nonzero commutative algebra in the Ind-completion whose +fibre functor is strong monoidal, exact and faithful. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v + +variable {C : Type v} + +/-- **Deligne's Proposition 2.1** for a category whose +Ind-completion carries an odd line. -/ +theorem exists_fibre_functor + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + (ψ : ℂ ≃+* End (𝟙_ C)) + (P : SchurPackage.{v}) (P₀ : SchurPackage.{0}) + (L : OddLine (Ind C)) + (hkill : letI := linearOfScalarUnit ψ + ∀ Z : C, ∃ lam : YoungDiagram, SchurKilled P Z lam) : + letI := linearOfScalarUnit ψ + letI := monoidalLinearOfScalarUnitBraided ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + letI := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + ∃ (𝔸 : Ind C) (_ : MonObj 𝔸) (_ : IsCommMonObj 𝔸), + MonObj.one (X := 𝔸) ≠ 0 ∧ + Nonempty (((indOf : C ⥤ Ind C) ⋙ fibreOver L 𝔸).Monoidal) ∧ + Nonempty (Limits.PreservesFiniteLimits + ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸)) ∧ + Nonempty (Limits.PreservesFiniteColimits + ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸)) ∧ + ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸).Faithful := by + let := linearOfScalarUnit ψ + let := monoidalLinearOfScalarUnitBraided ψ + let := linearOfScalarUnit (indScalarUnit ψ) + let := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + obtain ⟨𝔸, hmon, hcomm, hne, hsp, hsec⟩ := + exists_fibre_algebra ψ P P₀ L hkill + let := hmon + let := hcomm + have hmono : Mono η[𝔸] := + mono_unit_ind (simple_unit_of_hasScalarUnit + (hasScalarUnit_of_scalarUnit ψ)) 𝔸 hne + have hpm : ∀ Z : Ind C, (tensorRight Z).PreservesMonomorphisms := + fun Z => inferInstance + exact ⟨𝔸, hmon, hcomm, hne, ⟨indFibreMonoidal L 𝔸 hsp⟩, + ⟨indFibre_preservesFiniteLimits L 𝔸 hsec⟩, + ⟨indFibre_preservesFiniteColimits L 𝔸 hsec⟩, + indFibre_faithful L 𝔸 hmono hsp⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21Core.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21Core.lean new file mode 100644 index 0000000000..32d8fe62c5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21Core.lean @@ -0,0 +1,77 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplittingAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndLocallyMixed +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplitSection +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndUnitNonzero +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitInd + +/-! +# The splitting algebra of a Schur-killed category + +Every object of a category all of whose objects are killed by some +Schur functor is locally mixed after the Ind-embedding, and every +short exact sequence splits after base change; so the universal +algebra of `RS.exists_splitting_algebra` splits every embedded +object and every embedded short exact sequence at once. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v + +variable {C : Type v} + +/-- **The fibre algebra of a Schur-killed category.** -/ +theorem exists_fibre_algebra + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + (ψ : ℂ ≃+* End (𝟙_ C)) + (P : SchurPackage.{v}) (P₀ : SchurPackage.{0}) + (L : OddLine (Ind C)) + (hkill : letI := linearOfScalarUnit ψ + ∀ Z : C, ∃ lam : YoungDiagram, SchurKilled P Z lam) : + letI := linearOfScalarUnit ψ + letI := monoidalLinearOfScalarUnitBraided ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + letI := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + ∃ (𝔸 : Ind C) (_ : MonObj 𝔸) (_ : IsCommMonObj 𝔸), + MonObj.one (X := 𝔸) ≠ 0 ∧ + SplitsOn L 𝔸 (indOf : C ⥤ Ind C) ∧ + (∀ T : ShortComplex C, T.ShortExact → + ∃ s : freeMod 𝔸 ((T.map (indOf : C ⥤ Ind C)).X₃) ⟶ + freeMod 𝔸 ((T.map (indOf : C ⥤ Ind C)).X₂), + s ≫ freeModMap 𝔸 ((T.map (indOf : C ⥤ Ind C)).g) = + 𝟙 (freeMod 𝔸 ((T.map (indOf : C ⥤ Ind C)).X₃))) := by + let := linearOfScalarUnit ψ + let := monoidalLinearOfScalarUnitBraided ψ + let := linearOfScalarUnit (indScalarUnit ψ) + let := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + classical + have hu : HasScalarUnit C := hasScalarUnit_of_scalarUnit ψ + have h1 : ¬ IsZero (𝟙_ (Ind C)) := not_isZero_unit_ind hu + obtain ⟨𝔸, hmon, hcomm, hne, hmixed, hsec⟩ := + exists_splitting_algebra (C := C) hu L + (K := { T : ShortComplex C // T.ShortExact }) + (fun k => (k.1.map (indOf : C ⥤ Ind C)).X₂) + (fun k => (k.1.map (indOf : C ⥤ Ind C)).X₃) + (fun k => (k.1.map (indOf : C ⥤ Ind C)).g) + (fun Z => by + obtain ⟨lam, hk⟩ := hkill Z + exact locallyMixed_indOf ψ P P₀ Z lam hk L h1) + (fun k => rappel210_indOf k.1 k.2 h1) + refine ⟨𝔸, hmon, hcomm, hne, hmixed, fun T hT => ?_⟩ + exact hsec ⟨T, hT⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21General.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21General.lean new file mode 100644 index 0000000000..f08455785b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21General.lean @@ -0,0 +1,124 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21 +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledLine +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledScalar +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledGrowth +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.EvenEmbedMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLineMap +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitEquiv + +/-! +# Deligne's Proposition 2.1 without an odd line + +`RS.exists_fibre_functor` produces the fibre algebra and its fibre +functor for a category whose ind-completion already carries an odd +line. A tensor category need not contain such an object; Deligne's +device is to pass to the ℤ/2-graded doubling, which always does, +and to restrict along the even embedding. + +This module runs that device. The doubling of a small abelian +rigid symmetric monoidal ℂ-linear category with scalar unit +endomorphisms and moderate length growth inherits every one of those +hypotheses, and its ind-completion carries the image of the odd line +`RS.doubledOddLine` under the embedding. Proposition 2.1 upstairs +therefore applies, and the resulting fibre functor restricts along +the even embedding `A ⥤ Doubled A`, which is strong braided +monoidal, exact and faithful; each of the four conclusions composes. + +The hypothesis of 2.1 — that every object is killed by some Schur +functor — is supplied by the growth dichotomy +`RS.forall_exists_schurKilled`, applied to the doubling. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v + +noncomputable section + +variable {A : Type v} + +/-- **The scalar unit of the doubling**, as the ring isomorphism +that Proposition 2.1 consumes: the unit of the doubling is the unit +of `A` in even degree, so its endomorphisms are the scalars. -/ +def doubledScalarUnit [SmallCategory A] [MonoidalCategory A] [Abelian A] + [MonoidalPreadditive A] [CategoryTheory.Linear ℂ A] + (hu : HasScalarUnit A) : + ℂ ≃+* End (𝟙_ (Doubled A)) := + scalarUnitEquiv (hasScalarUnit_doubled hu) + +/-- **The odd line of the ind-completion of the doubling**: the +image of the odd line of the doubling under the embedding, which is +strong braided monoidal and additive. -/ +def doubledIndOddLine + [SmallCategory A] [MonoidalCategory A] [SymmetricCategory A] [Abelian A] + [MonoidalPreadditive A] : OddLine (Ind (Doubled A)) := + letI := indOf_additive (C := Doubled A) + OddLine.map (indOf : Doubled A ⥤ Ind (Doubled A)) doubledOddLine + +/-- **Deligne's Proposition 2.1 in general**: no odd line is +assumed. The category is doubled, Proposition 2.1 runs on the +doubling — whose ind-completion carries an odd line — and the fibre +functor obtained there is restricted along the even embedding. The +composite is strong monoidal, preserves finite limits and finite +colimits, and is faithful. -/ +theorem exists_fibre_functor_general + [SmallCategory A] [MonoidalCategory A] [SymmetricCategory A] [Abelian A] + [RigidCategory A] [MonoidalPreadditive A] [CategoryTheory.Linear ℂ A] + (P : SchurPackage.{v}) + (P₀ : SchurPackage.{0}) (hu : HasScalarUnit A) + (hgrow : ModerateLengthGrowth A) : + letI := linearOfScalarUnit (doubledScalarUnit hu) + letI := monoidalLinearOfScalarUnitBraided (doubledScalarUnit hu) + letI := linearOfScalarUnit (indScalarUnit (doubledScalarUnit hu)) + letI := monoidalLinearOfScalarUnitBraided + (indScalarUnit (doubledScalarUnit hu)) + ∃ (𝔸 : Ind (Doubled A)) (_ : MonObj 𝔸) (_ : IsCommMonObj 𝔸), + MonObj.one (X := 𝔸) ≠ 0 ∧ + Nonempty ((Doubled.evenEmbed ⋙ + (indOf : Doubled A ⥤ Ind (Doubled A)) ⋙ + fibreOver doubledIndOddLine 𝔸).Monoidal) ∧ + Nonempty (Limits.PreservesFiniteLimits (Doubled.evenEmbed ⋙ + (indOf : Doubled A ⥤ Ind (Doubled A)) ⋙ + fibreFun doubledIndOddLine 𝔸)) ∧ + Nonempty (Limits.PreservesFiniteColimits (Doubled.evenEmbed ⋙ + (indOf : Doubled A ⥤ Ind (Doubled A)) ⋙ + fibreFun doubledIndOddLine 𝔸)) ∧ + (Doubled.evenEmbed ⋙ (indOf : Doubled A ⥤ Ind (Doubled A)) ⋙ + fibreFun doubledIndOddLine 𝔸).Faithful := by + let := linearOfScalarUnit (doubledScalarUnit hu) + let := monoidalLinearOfScalarUnitBraided (doubledScalarUnit hu) + let := linearOfScalarUnit (indScalarUnit (doubledScalarUnit hu)) + let := monoidalLinearOfScalarUnitBraided + (indScalarUnit (doubledScalarUnit hu)) + obtain ⟨𝔸, hmon, hcomm, hne, ⟨hM⟩, ⟨hL⟩, ⟨hCo⟩, hF⟩ := + exists_fibre_functor (C := Doubled A) (doubledScalarUnit hu) P P₀ + doubledIndOddLine + (forall_exists_schurKilled P + (hasScalarUnit_of_scalarUnit (doubledScalarUnit hu)) + (moderateLengthGrowth_doubled hgrow)) + let := hmon + let := hcomm + let := hM + let := hL + let := hCo + let := hF + exact ⟨𝔸, hmon, hcomm, hne, ⟨inferInstance⟩, + ⟨comp_preservesFiniteLimits _ _⟩, + ⟨comp_preservesFiniteColimits _ _⟩, inferInstance⟩ + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29.lean new file mode 100644 index 0000000000..f0f4340237 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29.lean @@ -0,0 +1,106 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaData +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing + +/-! +# The trichotomy statement + +Deligne's Proposition 2.9, the consumed direction: an object +killed by some Schur functor is locally a sum of copies of the +unit and an odd line. The odd line is an object squaring to the +unit with braiding `−1`; local means after base change to some +nonzero commutative algebra. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable (D : Type u) + +/-- **An odd line**: an object squaring to the unit whose +self-braiding is `−1`. -/ +structure OddLine + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] + where + /-- The underlying object. -/ + obj : D + /-- The square of the line is the unit. -/ + sq : obj ⊗ obj ≅ 𝟙_ D + /-- The self-braiding of the line is `−1`. -/ + braid_neg : (β_ obj obj).hom = -𝟙 (obj ⊗ obj) + +variable {D} + +/-- The mixed sum of `p` copies of the unit and `q` copies of the +line. -/ +noncomputable def OddLine.mix + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (p q : ℕ) : D := + ⨁ fun i : Fin p ⊕ Fin q => + Sum.elim (fun _ => 𝟙_ D) (fun _ => L.obj) i + +/-- The empty mixed sum is the zero object. -/ +theorem OddLine.isZero_mix_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) : + Limits.IsZero (L.mix 0 0) := by + rw [Limits.IsZero.iff_id_eq_zero] + apply biproduct.hom_ext + rintro (⟨_, h⟩ | ⟨_, h⟩) <;> exact absurd h (Nat.not_lt_zero _) + +/-- **Locally mixed**: after base change to some nonzero +commutative algebra, the object becomes a sum of copies of the +unit and the line. -/ +def OddLine.LocallyMixed + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (X : D) : Prop := + ∃ (p q : ℕ) (A : D) (_ : MonObj A) (_ : IsCommMonObj A), + η[A] ≠ 0 ∧ + Nonempty (freeMod A X ≅ freeMod A (L.mix p q)) + +/-- **Tensoring with the odd line reflects vanishing**: the +square of the line collapses to the unit, so the double twist is +the identity up to isomorphism. -/ +theorem OddLine.isZero_tensor_iff + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] + (L : OddLine D) (Y : D) : + Limits.IsZero (L.obj ⊗ Y) ↔ Limits.IsZero Y := by + constructor + · intro h + have h2 : Limits.IsZero (L.obj ⊗ (L.obj ⊗ Y)) := + isZero_whiskerLeft _ h + refine Limits.IsZero.of_iso h2 ?_ + exact (λ_ Y).symm ≪≫ + (whiskerRightIso L.sq.symm Y) ≪≫ α_ L.obj L.obj Y + · exact isZero_whiskerLeft _ + +/-- **The trichotomy statement of record** (Deligne 2.9, the +consumed direction): an object killed by some Schur functor is +locally a mixed sum of the unit and the odd line. -/ +def Prop29Statement [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [CategoryTheory.Linear ℂ D] + (P : SchurPackage.{v}) (L : OddLine D) + (X : D) : Prop := + (∃ lam : YoungDiagram, SchurKilled P X lam) → + L.LocallyMixed X + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29Close.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29Close.lean new file mode 100644 index 0000000000..7c188cfe36 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29Close.lean @@ -0,0 +1,56 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DevissageBound +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepB +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DescentClose +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitState +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KillerNonempty + +/-! +# The trichotomy, unconditionally + +Both steps of the dévissage are constructions, the trichotomy and +the exit are theorems, and a killing diagram bounds the counts, so +the recursion runs to completion from the initial state: an object +killed by some Schur functor is locally a mixed sum of the unit +and the odd line. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v + +variable {C : Type v} + +attribute [local instance] + hasBinaryBiproducts_of_finite_biproducts + +/-- **The trichotomy of Deligne 2.9, discharged**: an object with +an exact pairing that is killed by some Schur functor is locally +a mixed sum of the unit and the odd line. -/ +theorem prop29 + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + [CategoryTheory.Linear ℂ (Ind C)] [MonoidalLinear ℂ (Ind C)] + (P : SchurPackage.{v}) (P₀ : SchurPackage.{0}) + (L : OddLine (Ind C)) (X Y : Ind C) [ExactPairing X Y] + (h1 : ¬ IsZero (𝟙_ (Ind C))) : Prop29Statement P L X := by + rintro ⟨lam, hkill⟩ + obtain ⟨mu, hcard, hmu⟩ := exists_killer_card_ne_zero P hkill + exact devissage_run (Ind C) L X (devissageStepA L X) + (devissageStepB L X) (devissageTrichotomy P L X) + (devissageExit (Ind C) L X) (2 * mu.card) + (devissage_bound P P₀ L X hcard hmu) (devissageInit L X Y h1) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29State.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29State.lean new file mode 100644 index 0000000000..24e699c35e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29State.lean @@ -0,0 +1,210 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow + +/-! +# The dévissage state of the trichotomy + +The recursion state of Deligne's 2.9, direction (ii) ⇒ (i): a +nonzero commutative base algebra, counts of split-off unit and +line factors, and a dualizable remainder module, together with a +decomposition of the base change of the object as the mixed free +part plus the remainder. Each step of the dévissage either +splits a further unit factor off the remainder (through the Key +Lemma), splits a line factor (through the sign-twisted mirror), +or exits with the remainder already zero. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable (D : Type u) + +attribute [local instance] + hasBinaryBiproducts_of_finite_biproducts + +/-- **The dévissage state**: a nonzero commutative base, the +counts of unit and line factors already split off, a dualizable +remainder with its zigzag laws, and the decomposition of the base +change of the object. -/ +structure DevissageState + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (L : OddLine D) (X : D) where + /-- The current base algebra. -/ + base : D + /-- Its monoid structure. -/ + monObj : MonObj base + /-- Commutativity. -/ + comm : letI := monObj; IsCommMonObj base + /-- The base is nonzero: its unit does not vanish. -/ + unit_ne_zero : letI := monObj; η[base] ≠ 0 + /-- The number of unit factors split off. -/ + units : ℕ + /-- The number of line factors split off. -/ + lines : ℕ + /-- The remainder module. -/ + rest : letI := monObj; Mod D base + /-- The dual of the remainder. -/ + restDual : letI := monObj; Mod D base + /-- The duality datum of the remainder. -/ + datum : letI := monObj; letI := comm; + ModDualityDatum base rest restDual + /-- The zigzag laws of the duality datum. -/ + zigzag : letI := monObj; letI := comm; + ModZigzagDatum base datum + /-- The base change of the object decomposes as the mixed free + part plus the remainder. -/ + decomp : letI := monObj; letI := comm; + Nonempty (freeMod base X ≅ + modBiprod base (freeMod base (L.mix units lines)) rest) + +section Steps + +/-- **Case (a) of the dévissage**: when every symmetric power of +the remainder survives, a further unit factor splits off. -/ +def DevissageStepA [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + [Linear ℂ D] + (L : OddLine D) (X : D) : Prop := + ∀ st : DevissageState D L X, + (letI := st.monObj; + ∀ n : ℕ, ¬ IsZero (symPow st.base st.rest.X n)) → + ∃ st' : DevissageState D L X, + st'.units = st.units + 1 ∧ st'.lines = st.lines + +/-- **Case (b)**: when every alternating power of the remainder +survives, a further line factor splits off. -/ +def DevissageStepB [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + [Linear ℂ D] + (L : OddLine D) (X : D) : Prop := + ∀ st : DevissageState D L X, + (letI := st.monObj; + ∀ n : ℕ, ¬ IsZero (altPow st.base st.rest.X n)) → + ∃ st' : DevissageState D L X, + st'.units = st.units ∧ st'.lines = st.lines + 1 + +/-- **The exit**: a state whose remainder has died witnesses the +local mixed decomposition. -/ +def DevissageExit [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (L : OddLine D) (X : D) : Prop := + ∀ st : DevissageState D L X, + (letI := st.monObj; IsZero st.rest.X) → + L.LocallyMixed X + +/-- **The exit holds**: the decomposition collapses onto its +mixed free part once the remainder dies. -/ +theorem devissageExit + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (L : OddLine D) (X : D) : + DevissageExit D L X := by + intro st hz + let := st.monObj + let := st.comm + obtain ⟨e⟩ := st.decomp + refine ⟨st.units, st.lines, st.base, st.monObj, st.comm, + st.unit_ne_zero, ⟨e.trans ?_⟩⟩ + have hsnd : (biprod.snd : + (freeMod st.base (L.mix st.units st.lines)).X ⊞ + st.rest.X ⟶ st.rest.X) = 0 := + hz.eq_of_tgt _ _ + refine ⟨modBiprodFst st.base _ st.rest, + modBiprodInl st.base _ st.rest, ?_, ?_⟩ + · apply Mod.Hom.ext + change (biprod.fst ≫ biprod.inl : + (freeMod st.base (L.mix st.units st.lines)).X ⊞ + st.rest.X ⟶ _) = 𝟙 _ + rw [← biprod.total, hsnd, Limits.zero_comp, add_zero] + · apply Mod.Hom.ext + change (biprod.inl ≫ biprod.fst : _ ⟶ _) = 𝟙 _ + rw [biprod.inl_fst] + +/-- **The trichotomy**: over any state, either every symmetric +power of the remainder survives, or every alternating power +survives, or the remainder has died. -/ +def DevissageTrichotomy + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + [Linear ℂ D] + (L : OddLine D) (X : D) : Prop := + ∀ st : DevissageState D L X, + (letI := st.monObj; + ∀ n : ℕ, ¬ IsZero (symPow st.base st.rest.X n)) ∨ + (letI := st.monObj; + ∀ n : ℕ, ¬ IsZero (altPow st.base st.rest.X n)) ∨ + (letI := st.monObj; IsZero st.rest.X) + +/-- **The dévissage runs to completion**: given the two step +constructions, the trichotomy, the exit, and a uniform bound on +the number of split-off factors, every state leads to the local +mixed decomposition. -/ +theorem devissage_run + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + [Linear ℂ D] + (L : OddLine D) (X : D) + (hA : DevissageStepA D L X) (hB : DevissageStepB D L X) + (hT : DevissageTrichotomy D L X) + (hE : DevissageExit D L X) (bound : ℕ) + (hBound : ∀ st : DevissageState D L X, + st.units + st.lines ≤ bound) + (st₀ : DevissageState D L X) : L.LocallyMixed X := by + suffices h : ∀ fuel : ℕ, ∀ st : DevissageState D L X, + bound + 1 - (st.units + st.lines) ≤ fuel → + L.LocallyMixed X from + h (bound + 1) st₀ (by omega) + intro fuel + induction fuel with + | zero => + intro st hle + exact absurd (hBound st) (by omega) + | succ n ih => + intro st hle + rcases hT st with ha | hb | hdead + · obtain ⟨st', hu, hl⟩ := hA st ha + exact ih st' (by omega) + · obtain ⟨st', hu, hl⟩ := hB st hb + exact ih st' (by omega) + · exact hE st hdead + +end Steps + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210.lean new file mode 100644 index 0000000000..6c10caabf0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210.lean @@ -0,0 +1,67 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaData + +/-! +# The local splitting statement + +Deligne's 2.10, the consumed form: over a category where the +tensor structure is exact, every short exact sequence splits +after base change to some nonzero commutative algebra. The +splitting is a section of the base-changed epimorphism as module +maps over the algebra. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- The action square of the free module on a morphism. -/ +theorem freeModMap_lin [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + {V W : D} (f : V ⟶ W) : + ((α_ A A V).inv ≫ (μ[A] ▷ V)) ≫ (A ◁ f) = + (A ◁ (A ◁ f)) ≫ ((α_ A A W).inv ≫ (μ[A] ▷ W)) := by + rw [Category.assoc, ← whisker_exchange, + ← associator_inv_naturality_right_assoc] + +/-- The free module on a morphism. -/ +noncomputable def freeModMap + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] + {V W : D} (f : V ⟶ W) : + freeMod A V ⟶ freeMod A W := + Mod.Hom.mk' (A ◁ f) (freeModMap_lin A f) + +section Statement + +-- The short-exactness datum indexes the statement: it records which +-- sequences the assertion is made of, and the proofs of record are +-- stated at this signature. +/-- **The local splitting statement of record** (Deligne 2.10, +the consumed direction): a short exact sequence acquires a +module-level section of its epimorphism after base change to +some nonzero commutative algebra. -/ +def Rappel210Statement + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] [Abelian D] + (S : ShortComplex D) (_ : S.ShortExact) : + Prop := + ∃ (A : D) (_ : MonObj A) (_ : IsCommMonObj A), + η[A] ≠ 0 ∧ + ∃ s : freeMod A S.X₃ ⟶ freeMod A S.X₂, + s ≫ freeModMap A S.g = 𝟙 (freeMod A S.X₃) + +end Statement + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Bridge.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Bridge.lean new file mode 100644 index 0000000000..a8ab7a6e3b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Bridge.lean @@ -0,0 +1,232 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoverFactor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Chain + +/-! +# The stage units of the local splitting chain are point powers + +The bridge between the chain and the nonvanishing substrate: the +stage units of the local splitting chain are the symmetrised +point powers, so for a monic point in a rigid category with +nonzero unit no stage unit vanishes. The class of the object in +the splitting algebra restricts on the point to the unit. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- The singleton point in the tensor power, as the point against +the unitor. -/ +theorem tensorPowPoint_one + [Category.{v} D] [MonoidalCategory D] (Y : D) (pt : 𝟙_ D ⟶ Y) : + tensorPowPoint pt 1 = pt ≫ (λ_ Y).inv := by + rw [tensorPowPoint_succ, tensorPowPoint_zero] + have h : (𝟙 (𝟙_ D) ⊗ₘ pt) = ((𝟙_ D) ◁ pt) := + MonoidalCategory.id_tensorHom _ _ + exact (whisker_eq _ h).trans + ((eq_whisker unitors_inv_equal.symm _).trans + (leftUnitor_inv_naturality pt).symm) + +/-- **The seed is the symmetrised singleton point.** -/ +theorem splitSeed_eq [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] + (Y : D) (pt : 𝟙_ D ⟶ Y) : + splitSeed Y pt = + tensorPowPoint pt 1 ≫ modPowπ (𝟙_ D) Y 1 ≫ + symPowπ (𝟙_ D) Y 1 := by + rw [splitSeed, tensorPowPoint_one, + show (symPowOne (𝟙_ D) Y).inv = + (modPowOne (𝟙_ D) Y).inv ≫ symPowπ (𝟙_ D) Y 1 from rfl, + modPowOne_inv] + repeat' erw [Category.assoc] + rfl + +/-- **The stage units are the symmetrised point powers.** -/ +theorem splitUnitStage_eq + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) (pt : 𝟙_ D ⟶ Y) : + ∀ n : ℕ, + splitUnitStage Y pt n = + tensorPowPoint pt (n + 1) ≫ modPowπ (𝟙_ D) Y (n + 1) ≫ + symPowπ (𝟙_ D) Y (n + 1) + | 0 => splitSeed_eq Y pt + | (n + 1) => by + have hIH := splitUnitStage_eq Y pt n + have hpair : (tensorPowPoint pt (n + 1) ⊗ₘ + tensorPowPoint pt 1) ≫ + ((modPowπ (𝟙_ D) Y (n + 1) ≫ + symPowπ (𝟙_ D) Y (n + 1)) ⊗ₘ + (modPowπ (𝟙_ D) Y 1 ≫ symPowπ (𝟙_ D) Y 1)) ≫ + symMul (𝟙_ D) Y (n + 1) 1 = + (tensorPowPoint pt (n + 1) ⊗ₘ tensorPowPoint pt 1) ≫ + (tensorPowConcat Y (n + 1) 1).hom ≫ + modPowπ (𝟙_ D) Y (n + 1 + 1) ≫ + symPowπ (𝟙_ D) Y (n + 1 + 1) := by + rw [← MonoidalCategory.tensorHom_comp_tensorHom, + Category.assoc, symPowπ_tensor_symMul, + modPowπ_tensor_modPowMul_assoc] + have stage0 : (splitUnitStage Y pt (n + 1) : 𝟙_ D ⟶ splitStage Y (n + 1)) = + (tensorPowPoint pt (n + 1) ≫ + modPowπ (𝟙_ D) Y (n + 1) ≫ + symPowπ (𝟙_ D) Y (n + 1)) ≫ + (ρ_ (splitStage Y n)).inv ≫ + (splitStage Y n ◁ splitSeed Y pt) ≫ + symMul (𝟙_ D) Y (n + 1) 1 := by + rw [← splitUnitStage_succ, hIH] + rfl + have stage1 : (tensorPowPoint pt (n + 1) ≫ + modPowπ (𝟙_ D) Y (n + 1) ≫ + symPowπ (𝟙_ D) Y (n + 1)) ≫ + (ρ_ (splitStage Y n)).inv ≫ + (splitStage Y n ◁ splitSeed Y pt) ≫ + symMul (𝟙_ D) Y (n + 1) 1 = + ((ρ_ (𝟙_ D)).inv ≫ + ((tensorPowPoint pt (n + 1) ≫ + modPowπ (𝟙_ D) Y (n + 1) ≫ + symPowπ (𝟙_ D) Y (n + 1)) ⊗ₘ + splitSeed Y pt) ≫ + symMul (𝟙_ D) Y (n + 1) 1 : 𝟙_ D ⟶ splitStage Y (n + 1)) := by + have ha : (tensorPowPoint pt (n + 1) ≫ + modPowπ (𝟙_ D) Y (n + 1) ≫ + symPowπ (𝟙_ D) Y (n + 1)) ≫ + (ρ_ (splitStage Y n)).inv = + (ρ_ (𝟙_ D)).inv ≫ ((tensorPowPoint pt (n + 1) ≫ + modPowπ (𝟙_ D) Y (n + 1) ≫ + symPowπ (𝟙_ D) Y (n + 1)) ▷ (𝟙_ D)) := + rightUnitor_inv_naturality _ + have hb : ((tensorPowPoint pt (n + 1) ≫ + modPowπ (𝟙_ D) Y (n + 1) ≫ + symPowπ (𝟙_ D) Y (n + 1)) ▷ (𝟙_ D)) ≫ + (splitStage Y n ◁ splitSeed Y pt) = + ((tensorPowPoint pt (n + 1) ≫ + modPowπ (𝟙_ D) Y (n + 1) ≫ + symPowπ (𝟙_ D) Y (n + 1)) ⊗ₘ splitSeed Y pt) := + (MonoidalCategory.tensorHom_def _ _).symm + exact (Category.assoc _ _ _).symm.trans + ((eq_whisker ha _).trans + ((Category.assoc _ _ _).trans + (whisker_eq _ + ((Category.assoc _ _ _).symm.trans + (eq_whisker hb _))))) + have stage2 : ((ρ_ (𝟙_ D)).inv ≫ + ((tensorPowPoint pt (n + 1) ≫ + modPowπ (𝟙_ D) Y (n + 1) ≫ + symPowπ (𝟙_ D) Y (n + 1)) ⊗ₘ + splitSeed Y pt) ≫ + symMul (𝟙_ D) Y (n + 1) 1 : 𝟙_ D ⟶ splitStage Y (n + 1)) = + (ρ_ (𝟙_ D)).inv ≫ + ((tensorPowPoint pt (n + 1) ⊗ₘ + tensorPowPoint pt 1) ≫ + ((modPowπ (𝟙_ D) Y (n + 1) ≫ + symPowπ (𝟙_ D) Y (n + 1)) ⊗ₘ + (modPowπ (𝟙_ D) Y 1 ≫ + symPowπ (𝟙_ D) Y 1))) ≫ + symMul (𝟙_ D) Y (n + 1) 1 := by + rw [splitSeed_eq, + MonoidalCategory.tensorHom_comp_tensorHom] + rfl + have stage3 : (ρ_ (𝟙_ D)).inv ≫ + ((tensorPowPoint pt (n + 1) ⊗ₘ + tensorPowPoint pt 1) ≫ + ((modPowπ (𝟙_ D) Y (n + 1) ≫ + symPowπ (𝟙_ D) Y (n + 1)) ⊗ₘ + (modPowπ (𝟙_ D) Y 1 ≫ + symPowπ (𝟙_ D) Y 1))) ≫ + symMul (𝟙_ D) Y (n + 1) 1 = + (ρ_ (𝟙_ D)).inv ≫ + ((tensorPowPoint pt (n + 1) ⊗ₘ + tensorPowPoint pt 1) ≫ + (tensorPowConcat Y (n + 1) 1).hom) ≫ + modPowπ (𝟙_ D) Y (n + 1 + 1) ≫ + symPowπ (𝟙_ D) Y (n + 1 + 1) := by + rw [Category.assoc, hpair] + simp only [Category.assoc] + have stage4 : (ρ_ (𝟙_ D)).inv ≫ + ((tensorPowPoint pt (n + 1) ⊗ₘ + tensorPowPoint pt 1) ≫ + (tensorPowConcat Y (n + 1) 1).hom) ≫ + modPowπ (𝟙_ D) Y (n + 1 + 1) ≫ + symPowπ (𝟙_ D) Y (n + 1 + 1) = + (ρ_ (𝟙_ D)).inv ≫ ((λ_ (𝟙_ D)).hom ≫ + tensorPowPoint pt (n + 1 + 1)) ≫ + modPowπ (𝟙_ D) Y (n + 1 + 1) ≫ + symPowπ (𝟙_ D) Y (n + 1 + 1) := by + rw [tensorPowPoint_concat] + have stage5 : (ρ_ (𝟙_ D)).inv ≫ ((λ_ (𝟙_ D)).hom ≫ + tensorPowPoint pt (n + 1 + 1)) ≫ + modPowπ (𝟙_ D) Y (n + 1 + 1) ≫ + symPowπ (𝟙_ D) Y (n + 1 + 1) = + tensorPowPoint pt (n + 1 + 1) ≫ + modPowπ (𝟙_ D) Y (n + 1 + 1) ≫ + symPowπ (𝟙_ D) Y (n + 1 + 1) := by + have hrl : (ρ_ (𝟙_ D)).inv ≫ (λ_ (𝟙_ D)).hom = + 𝟙 (𝟙_ D) := by + rw [unitors_equal] + exact (ρ_ (𝟙_ D)).inv_hom_id + exact (whisker_eq _ (Category.assoc _ _ _)).trans + ((Category.assoc _ _ _).symm.trans + ((eq_whisker hrl _).trans (Category.id_comp _))) + exact stage0.trans (stage1.trans (stage2.trans (stage3.trans (stage4.trans (stage5))))) + +/-- The stage-unit nonvanishing, from mono preservation of the +tensor factors alone — the form consumed over an +ind-completion. -/ +theorem splitUnitStage_ne_zero' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) (pt : 𝟙_ D ⟶ Y) + [∀ Z : D, (tensorLeft Z).PreservesMonomorphisms] + [∀ Z : D, (tensorRight Z).PreservesMonomorphisms] + [Mono pt] (h1 : ¬ IsZero (𝟙_ D)) (n : ℕ) : + splitUnitStage Y pt n ≠ 0 := by + rw [splitUnitStage_eq] + exact point_symPow_ne_zero' Y pt h1 (n + 1) + +section Class + +/-- **The class of the object in the splitting algebra**: the +singleton power, included at the bottom stage. -/ +noncomputable def splitCls + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) (pt : 𝟙_ D ⟶ Y) [HasColimitsOfShape SmallNat.{v} D] : + Y ⟶ splitAlgebra Y pt := + (symPowOne (𝟙_ D) Y).inv ≫ + chainColimitι (splitStage Y) (splitDelta Y pt) 0 + +/-- **The class restricts on the point to the unit.** -/ +theorem splitCls_point + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) (pt : 𝟙_ D ⟶ Y) [HasColimitsOfShape SmallNat.{v} D] : + pt ≫ splitCls Y pt = splitAlgebraUnit Y pt := + (Category.assoc _ _ _).symm + +end Class + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Chain.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Chain.lean new file mode 100644 index 0000000000..52cd7ebdfa --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Chain.lean @@ -0,0 +1,443 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymMul +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainAlgebra + +/-! +# The local splitting chain + +The algebra of Deligne's 2.10: for a point of an object, the chain +of plain symmetric powers with transitions multiplication by the +point. The colimit is the quotient of the symmetric algebra +identifying the point with the unit; the stages, the seed, the +stage multiplication, and the stage units are pinned here, and the +laws assemble the colimit into a commutative algebra through the +generic chain kit. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- The stages of the local splitting chain: the plain symmetric +powers, one letter up. -/ +noncomputable def splitStage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] + (Y : D) + (n : ℕ) : D := + symPow (𝟙_ D) Y (n + 1) + +/-- The seed of the local splitting chain: the point, in the +singleton power. -/ +noncomputable def splitSeed + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] + (Y : D) (pt : 𝟙_ D ⟶ Y) : 𝟙_ D ⟶ splitStage Y 0 := + pt ≫ (symPowOne (𝟙_ D) Y).inv + +/-- The transition of the local splitting chain: multiplication +by the seed. -/ +noncomputable def splitDelta + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) (pt : 𝟙_ D ⟶ Y) + (n : ℕ) : + splitStage Y n ⟶ splitStage Y (n + 1) := + (ρ_ (splitStage Y n)).inv ≫ + (splitStage Y n ◁ splitSeed Y pt) ≫ + symMul (𝟙_ D) Y (n + 1) 1 + +/-- The stage multiplication of the local splitting chain. -/ +noncomputable def splitMu + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) + (i j : ℕ) : + splitStage Y i ⊗ splitStage Y j ⟶ splitStage Y (i + 1 + j) := + symMul (𝟙_ D) Y (i + 1) (j + 1) ≫ + symPowCast (𝟙_ D) Y + (by omega : i + 1 + (j + 1) = i + 1 + j + 1) + +/-- The stage units of the local splitting chain: the powers of +the point. -/ +noncomputable def splitUnitStage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) (pt : 𝟙_ D ⟶ Y) : + (n : ℕ) → (𝟙_ D ⟶ splitStage Y n) + | 0 => splitSeed Y pt + | (n + 1) => splitUnitStage Y pt n ≫ splitDelta Y pt n + +/-- The stage units ride along the transitions. -/ +theorem splitUnitStage_succ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) (pt : 𝟙_ D ⟶ Y) + (n : ℕ) : + splitUnitStage Y pt n ≫ splitDelta Y pt n = + splitUnitStage Y pt (n + 1) := + rfl + +/-! ## Stage laws + +The transitions, the stage multiplication and the seed satisfy the +five stagewise laws consumed by the chain kit, derived from the +symmetric-multiplication laws one letter up. The arity transports +over definitionally equal indices collapse to identities. -/ + +/-- Arity transports of the symmetric powers compose. -/ +private theorem splitPowCast_comp + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] + (Y : D) + {a b c : ℕ} (h : a = b) + (h' : b = c) : + symPowCast (𝟙_ D) Y h ≫ symPowCast (𝟙_ D) Y h' = + symPowCast (𝟙_ D) Y (h.trans h') := by + subst h h' + rw [symPowCast_rfl, Category.id_comp] + +/-- Commutativity of the symmetric multiplication, with both sides +transported to a common arity. -/ +private theorem splitSymMul_comm_cast + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) + {a b c : ℕ} (h : b + a = c) + (h' : a + b = c) : + (β_ (symPow (𝟙_ D) Y a) (symPow (𝟙_ D) Y b)).hom ≫ + symMul (𝟙_ D) Y b a ≫ symPowCast (𝟙_ D) Y h = + symMul (𝟙_ D) Y a b ≫ symPowCast (𝟙_ D) Y h' := by + subst h + rw [symPowCast_rfl, Category.comp_id] + exact symMul_comm (𝟙_ D) Y a b + +/-- The right seed law at the symmetric-power level, spelt +uniformly in the powers with the seed abstracted. -/ +private theorem symMul_seed_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) + (s : 𝟙_ D ⟶ symPow (𝟙_ D) Y 1) + (a b c : ℕ) (hc : a + b = c) (h₁ : a + (b + 1) = c + 1) : + (symPow (𝟙_ D) Y a ◁ + ((ρ_ (symPow (𝟙_ D) Y b)).inv ≫ + (symPow (𝟙_ D) Y b ◁ s) ≫ symMul (𝟙_ D) Y b 1)) ≫ + symMul (𝟙_ D) Y a (b + 1) ≫ symPowCast (𝟙_ D) Y h₁ = + (symMul (𝟙_ D) Y a b ≫ symPowCast (𝟙_ D) Y hc) ≫ + (ρ_ (symPow (𝟙_ D) Y c)).inv ≫ + (symPow (𝟙_ D) Y c ◁ s) ≫ symMul (𝟙_ D) Y c 1 := by + subst hc + have hk₁ : symPowCast (𝟙_ D) Y h₁ = 𝟙 _ := rfl + rw [hk₁, Category.comp_id, symPowCast_rfl, Category.comp_id] + have hassoc := symMul_assoc (𝟙_ D) Y a b 1 + have hk₂ : symPowCast (𝟙_ D) Y + (by omega : a + (b + 1) = a + b + 1) = 𝟙 _ := rfl + rw [hk₂, Category.comp_id] at hassoc + have h2 : (symPow (𝟙_ D) Y a ◁ symMul (𝟙_ D) Y b 1) ≫ + symMul (𝟙_ D) Y a (b + 1) = + (α_ (symPow (𝟙_ D) Y a) (symPow (𝟙_ D) Y b) + (symPow (𝟙_ D) Y 1)).inv ≫ + (symMul (𝟙_ D) Y a b ▷ symPow (𝟙_ D) Y 1) ≫ + symMul (𝟙_ D) Y (a + b) 1 := by + rw [Iso.eq_inv_comp] + exact hassoc.symm + have hcoh : (symPow (𝟙_ D) Y a ◁ + (ρ_ (symPow (𝟙_ D) Y b)).inv) ≫ + (α_ (symPow (𝟙_ D) Y a) (symPow (𝟙_ D) Y b) (𝟙_ D)).inv = + (ρ_ (symPow (𝟙_ D) Y a ⊗ symPow (𝟙_ D) Y b)).inv := by + monoidal + rw [MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + Category.assoc, h2, + MonoidalCategory.associator_inv_naturality_right_assoc, + reassoc_of% hcoh, whisker_exchange_assoc] + rw [reassoc_of% (MonoidalCategory.rightUnitor_inv_naturality + (symMul (𝟙_ D) Y a b)).symm] + +/-- **Right transition law**: transitioning the second factor and +multiplying is multiplying and transitioning, since the transition +is right multiplication by the seed. -/ +theorem splitDelta_mu_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) (pt : 𝟙_ D ⟶ Y) + (i j : ℕ) : + (splitStage Y i ◁ splitDelta Y pt j) ≫ splitMu Y i (j + 1) = + splitMu Y i j ≫ splitDelta Y pt (i + 1 + j) := + symMul_seed_right Y (splitSeed Y pt) (i + 1) (j + 1) + (i + 1 + j + 1) (by omega) (by omega) + +/-- **Right seed law**: multiplying by the seed on the right is the +transition, through the right unitor. -/ +theorem splitSeed_mu_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) (pt : 𝟙_ D ⟶ Y) + (i : ℕ) : + (splitStage Y i ◁ splitSeed Y pt) ≫ splitMu Y i 0 = + (ρ_ (splitStage Y i)).hom ≫ splitDelta Y pt i := by + change (splitStage Y i ◁ splitSeed Y pt) ≫ + symMul (𝟙_ D) Y (i + 1) (0 + 1) ≫ + symPowCast (𝟙_ D) Y + (by omega : i + 1 + (0 + 1) = i + 1 + 0 + 1) = + (ρ_ (splitStage Y i)).hom ≫ (ρ_ (splitStage Y i)).inv ≫ + (splitStage Y i ◁ splitSeed Y pt) ≫ symMul (𝟙_ D) Y (i + 1) 1 + have hk : symPowCast (𝟙_ D) Y + (by omega : i + 1 + (0 + 1) = i + 1 + 0 + 1) = 𝟙 _ := rfl + erw [hk, Category.comp_id, Iso.hom_inv_id_assoc] + +/-- Associativity of the symmetric multiplication with all four +arity transports abstracted, spelt uniformly in the powers. -/ +private theorem symMul_assoc_cast + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) + (a b g ab bg s t : ℕ) + (h₁ : a + b = ab) (h₂ : ab + g = t) (h₃ : b + g = bg) + (h₄ : a + bg = s) (h₅ : s = t) : + ((symMul (𝟙_ D) Y a b ≫ symPowCast (𝟙_ D) Y h₁) ▷ + symPow (𝟙_ D) Y g) ≫ + (symMul (𝟙_ D) Y ab g ≫ symPowCast (𝟙_ D) Y h₂) = + (α_ (symPow (𝟙_ D) Y a) (symPow (𝟙_ D) Y b) + (symPow (𝟙_ D) Y g)).hom ≫ + (symPow (𝟙_ D) Y a ◁ + (symMul (𝟙_ D) Y b g ≫ symPowCast (𝟙_ D) Y h₃)) ≫ + (symMul (𝟙_ D) Y a bg ≫ symPowCast (𝟙_ D) Y h₄) ≫ + symPowCast (𝟙_ D) Y h₅ := by + subst h₁ h₃ h₂ h₄ + simp only [symPowCast_rfl, Category.comp_id] + exact symMul_assoc (𝟙_ D) Y a b g + +/-- **Associativity of the stage multiplication**, up to the index +transport of `i + 1 + (j + 1 + k) = i + 1 + j + 1 + k`. -/ +theorem splitMu_assoc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) + (i j k : ℕ) : + (splitMu Y i j ▷ splitStage Y k) ≫ splitMu Y (i + 1 + j) k = + (α_ (splitStage Y i) (splitStage Y j) (splitStage Y k)).hom ≫ + (splitStage Y i ◁ splitMu Y j k) ≫ + splitMu Y i (j + 1 + k) ≫ + chainCast (splitStage Y) + (by omega : i + 1 + (j + 1 + k) = i + 1 + j + 1 + k) := + symMul_assoc_cast Y (i + 1) (j + 1) (k + 1) (i + 1 + j + 1) + (j + 1 + k + 1) (i + 1 + (j + 1 + k) + 1) + (i + 1 + j + 1 + k + 1) (by omega) (by omega) (by omega) + (by omega) (by omega) + +/-- **Commutativity of the stage multiplication**, up to the index +transport of `j + 1 + i = i + 1 + j`. -/ +theorem splitMu_comm [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) + (i j : ℕ) : + (β_ (splitStage Y i) (splitStage Y j)).hom ≫ splitMu Y j i ≫ + chainCast (splitStage Y) + (by omega : j + 1 + i = i + 1 + j) = + splitMu Y i j := by + change (β_ (symPow (𝟙_ D) Y (i + 1)) + (symPow (𝟙_ D) Y (j + 1))).hom ≫ + (symMul (𝟙_ D) Y (j + 1) (i + 1) ≫ + symPowCast (𝟙_ D) Y + (by omega : j + 1 + (i + 1) = j + 1 + i + 1)) ≫ + symPowCast (𝟙_ D) Y + (by omega : j + 1 + i + 1 = i + 1 + j + 1) = + symMul (𝟙_ D) Y (i + 1) (j + 1) ≫ + symPowCast (𝟙_ D) Y + (by omega : i + 1 + (j + 1) = i + 1 + j + 1) + rw [Category.assoc, splitPowCast_comp] + exact splitSymMul_comm_cast Y _ _ + +/-- The transitions commute with the index transports. -/ +private theorem chainCast_splitDelta + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) (pt : 𝟙_ D ⟶ Y) + {a b : ℕ} (h : a = b) : + chainCast (splitStage Y) h ≫ splitDelta Y pt b = + splitDelta Y pt a ≫ + chainCast (splitStage Y) (congrArg Nat.succ h) := by + subst h + rw [chainCast_rfl, Category.id_comp] + change splitDelta Y pt a = splitDelta Y pt a ≫ 𝟙 _ + rw [Category.comp_id] + +/-- **Left transition law**: transitioning the first factor and +multiplying is multiplying and transitioning, up to the index +transport, through the braiding and the right transition law. -/ +theorem splitDelta_mu_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) (pt : 𝟙_ D ⟶ Y) + (i j : ℕ) : + (splitDelta Y pt i ▷ splitStage Y j) ≫ splitMu Y (i + 1) j = + splitMu Y i j ≫ splitDelta Y pt (i + 1 + j) ≫ + chainCast (splitStage Y) + (Nat.add_right_comm (i + 1) j 1) := by + have hnat : (splitDelta Y pt i ▷ splitStage Y j) ≫ + (β_ (splitStage Y (i + 1)) (splitStage Y j)).hom = + (β_ (splitStage Y i) (splitStage Y j)).hom ≫ + (splitStage Y j ◁ splitDelta Y pt i) := + BraidedCategory.braiding_naturality_left _ _ + have h5 : (β_ (splitStage Y i) (splitStage Y j)).hom ≫ + splitMu Y j i = + splitMu Y i j ≫ chainCast (splitStage Y) + (by omega : i + 1 + j = j + 1 + i) := by + rw [← splitMu_comm Y i j, Category.assoc, Category.assoc, + chainCast_trans] + have hk : chainCast (splitStage Y) + (by omega : j + 1 + i = j + 1 + i) = 𝟙 _ := rfl + rw [hk, Category.comp_id] + rw [← splitMu_comm Y (i + 1) j, reassoc_of% hnat, + reassoc_of% (splitDelta_mu_right Y pt j i), reassoc_of% h5, + reassoc_of% (chainCast_splitDelta Y pt + (by omega : i + 1 + j = j + 1 + i)), + chainCast_trans] + +/-- A one-step chain morphism is the transition followed by the +index transport. -/ +private theorem splitChainMap_eq + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) (pt : 𝟙_ D ⟶ Y) + {a b : ℕ} (hab : a + 1 = b) + (h : a ≤ b) : + chainMap (splitStage Y) (splitDelta Y pt) h = + splitDelta Y pt a ≫ chainCast (splitStage Y) hab := by + subst hab + rw [chainCast_rfl, Category.comp_id] + exact chainMap_le_succ (splitStage Y) (splitDelta Y pt) a + +/-- **Left seed law**: multiplying by the seed on the left is the +one-step chain morphism, through the braiding of the unit. -/ +theorem splitSeed_mu_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) (pt : 𝟙_ D ⟶ Y) + (j : ℕ) : + (splitSeed Y pt ▷ splitStage Y j) ≫ splitMu Y 0 j = + (λ_ (splitStage Y j)).hom ≫ + chainMap (splitStage Y) (splitDelta Y pt) + (Nat.le_add_left j (0 + 1)) := by + have hmap : chainMap (splitStage Y) (splitDelta Y pt) + (Nat.le_add_left j (0 + 1)) = + splitDelta Y pt j ≫ chainCast (splitStage Y) + (by omega : j + 1 + 0 = 0 + 1 + j) := + splitChainMap_eq Y pt (by omega) _ + have hnat : (splitSeed Y pt ▷ splitStage Y j) ≫ + (β_ (splitStage Y 0) (splitStage Y j)).hom = + (β_ (𝟙_ D) (splitStage Y j)).hom ≫ + (splitStage Y j ◁ splitSeed Y pt) := + BraidedCategory.braiding_naturality_left _ _ + rw [hmap, ← splitMu_comm Y 0 j, reassoc_of% hnat, + reassoc_of% (splitSeed_mu_right Y pt j), + braiding_tensorUnit_left, Category.assoc, + Iso.inv_hom_id_assoc] + +section Colimit + +/-- **The local splitting algebra**: the colimit of the chain of +symmetric powers along multiplication by the point. -/ +noncomputable def splitAlgebra + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) (pt : 𝟙_ D ⟶ Y) [HasColimitsOfShape SmallNat.{v} D] : D := + chainColimit (splitStage Y) (splitDelta Y pt) + +/-- The unit of the local splitting algebra: the included seed. -/ +noncomputable def splitAlgebraUnit + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) (pt : 𝟙_ D ⟶ Y) [HasColimitsOfShape SmallNat.{v} D] : + 𝟙_ D ⟶ splitAlgebra Y pt := + chainColimitUnit (splitStage Y) (splitDelta Y pt) + (splitSeed Y pt) + +/-- **The local splitting algebra as a monoid object**: the unit is +the included seed and the multiplication is assembled from the stage +multiplications through the chain kit. -/ +@[reducible] +noncomputable def splitAlgebraMonObj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) (pt : 𝟙_ D ⟶ Y) [HasColimitsOfShape SmallNat.{v} D] + [∀ Z : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight Z)] + [∀ Z : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft Z)] : + MonObj (splitAlgebra Y pt) := + chainColimitMonObj (splitStage Y) (splitDelta Y pt) (splitMu Y) + (splitDelta_mu_left Y pt) (splitDelta_mu_right Y pt) + (splitSeed Y pt) (splitSeed_mu_left Y pt) + (splitSeed_mu_right Y pt) (splitMu_assoc Y) + +/-- **The local splitting algebra is commutative.** -/ +theorem splitAlgebra_isCommMonObj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (Y : D) (pt : 𝟙_ D ⟶ Y) [HasColimitsOfShape SmallNat.{v} D] + [∀ Z : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight Z)] + [∀ Z : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft Z)] : + @IsCommMonObj D _ _ _ (splitAlgebra Y pt) + (splitAlgebraMonObj Y pt) := + chainColimit_isCommMonObj (splitStage Y) (splitDelta Y pt) + (splitMu Y) (splitDelta_mu_left Y pt) + (splitDelta_mu_right Y pt) (splitSeed Y pt) + (splitSeed_mu_left Y pt) (splitSeed_mu_right Y pt) + (splitMu_assoc Y) (splitMu_comm Y) + +end Colimit + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Close.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Close.lean new file mode 100644 index 0000000000..d3680f57d1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Close.lean @@ -0,0 +1,73 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Bridge +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Reduce + +/-! +# The local splitting statement, up to unit nonvanishing + +The assembly of the local splitting statement: the splitting +algebra of the dualised unit-form point, with its class and the +restriction identity, feeds the reduction. What remains at each +consumer is the nonvanishing of the algebra's unit, which over an +ind-category follows from the stage units through the filtered +criterion. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- The splitting algebra of a short exact sequence: the local +splitting chain of the dualised unit-form point. -/ +noncomputable def rappel210Algebra + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [CategoryTheory.Linear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [HasColimitsOfShape SmallNat.{v} D] (S : ShortComplex D) + [HasRightDual (S.X₃ : D)] [HasRightDual (unitFormMid S : D)] : D := + splitAlgebra ((unitFormMid S)ᘁ) (unitFormPoint S) + +/-- **The local splitting statement holds once the unit of the +splitting algebra survives**: the class of the dual middle object +restricts on the point to the unit, so the reduction applies. -/ +theorem rappel210_of_unit_nonzero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [CategoryTheory.Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [HasColimitsOfShape SmallNat.{v} D] + [∀ Z : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight Z)] + (S : ShortComplex D) [HasRightDual (S.X₃ : D)] + [HasRightDual (unitFormMid S : D)] + (hS : S.ShortExact) + (hnz : splitAlgebraUnit ((unitFormMid S)ᘁ) + (unitFormPoint S) ≠ 0) : + Rappel210Statement S hS := by + let : MonObj (rappel210Algebra S) := + splitAlgebraMonObj (((unitFormMid S)ᘁ : D)) + (unitFormPoint S) + have : IsCommMonObj (rappel210Algebra S) := + splitAlgebra_isCommMonObj (((unitFormMid S)ᘁ : D)) + (unitFormPoint S) + exact rappel210_of_class S hS (rappel210Algebra S) hnz + (splitCls (((unitFormMid S)ᘁ : D)) (unitFormPoint S)) + (splitCls_point (((unitFormMid S)ᘁ : D)) + (unitFormPoint S)) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Ind.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Ind.lean new file mode 100644 index 0000000000..1baf9e65e3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Ind.lean @@ -0,0 +1,80 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBInd +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Close + +/-! +# The local splitting statement over the ind-completion + +The last hop of Deligne's 2.10: over the ind-completion of a +small rigid abelian tensor category, the unit of the splitting +algebra survives — the colimit unit dies only at a finite stage +by the filtered criterion, and no stage unit of a monic point +vanishes. The local splitting statement therefore holds for +every short exact sequence whose relevant objects carry duals. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v + +variable {C : Type v} + +/-- **The unit of the splitting algebra survives over the +ind-completion**: the colimit unit dies only at a finite stage, +and the stage units are nonvanishing symmetrised point powers of +the monic dualised point. -/ +theorem splitAlgebraUnit_ne_zero_ind + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] [Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] (S : ShortComplex (Ind C)) + [HasRightDual (S.X₃ : Ind C)] [HasLeftDual (((S.X₃)ᘁ) : Ind C)] + [HasRightDual (((S.X₃)ᘁ) : Ind C)] + [HasRightDual (unitFormMid S : Ind C)] + (hS : S.ShortExact) + (h1 : ¬ IsZero (𝟙_ (Ind C))) : + splitAlgebraUnit (((unitFormMid S)ᘁ) : Ind C) + (unitFormPoint S) ≠ 0 := by + have hmono : Mono (unitFormPoint S) := + mono_unitFormPoint S hS + intro h0 + obtain ⟨n, hn⟩ := (chainColimitUnit_eq_zero_iff + (splitStage (((unitFormMid S)ᘁ) : Ind C)) + (splitDelta (((unitFormMid S)ᘁ) : Ind C) + (unitFormPoint S)) + (splitUnitStage (((unitFormMid S)ᘁ) : Ind C) + (unitFormPoint S)) + (splitUnitStage_succ (((unitFormMid S)ᘁ) : Ind C) + (unitFormPoint S))).mp h0 + exact splitUnitStage_ne_zero' (((unitFormMid S)ᘁ) : Ind C) + (unitFormPoint S) h1 n hn + +/-- **The local splitting statement over the ind-completion** +(Deligne 2.10): every short exact sequence whose quotient and +derived objects carry duals splits after base change to a nonzero +commutative algebra. -/ +theorem rappel210_ind + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] [Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] (S : ShortComplex (Ind C)) + [HasRightDual (S.X₃ : Ind C)] [HasLeftDual (((S.X₃)ᘁ) : Ind C)] + [HasRightDual (((S.X₃)ᘁ) : Ind C)] + [HasRightDual (unitFormMid S : Ind C)] + (hS : S.ShortExact) + (h1 : ¬ IsZero (𝟙_ (Ind C))) : + Rappel210Statement S hS := + rappel210_of_unit_nonzero S hS + (splitAlgebraUnit_ne_zero_ind S hS h1) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Reduce.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Reduce.lean new file mode 100644 index 0000000000..0f1c97ae2c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Reduce.lean @@ -0,0 +1,776 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210 + +/-! +# Exactness of tensoring with a dualizable object + +The first stage of the reduction of the local splitting statement: +tensoring with a two-sided dualizable object is exact, because the +exact pairings make the tensor functor a left and a right adjoint +at once. A short exact sequence therefore stays short exact after +tensoring, which produces the internal-hom extension that the +pullback stage consumes. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {D : Type u} + +section Exactness + +/-- Tensoring on the left with an object with a left dual +preserves colimits: the exact pairing makes it a left adjoint. -/ +theorem tensorLeftPreservesColimits [Category.{v} D] [MonoidalCategory D] + (X : D) + [HasLeftDual X] : PreservesColimitsOfSize.{0, 0} + (tensorLeft X) := + (tensorLeftAdjunction (ᘁX) X).leftAdjoint_preservesColimits + +/-- Tensoring on the left with an object with a right dual +preserves limits: the exact pairing makes it a right adjoint. -/ +theorem tensorLeftPreservesLimits [Category.{v} D] [MonoidalCategory D] + (X : D) + [HasRightDual X] : PreservesLimitsOfSize.{0, 0} + (tensorLeft X) := + (tensorLeftAdjunction X (Xᘁ)).rightAdjoint_preservesLimits + +/-- **Tensoring with a two-sided dualizable object is exact**: +a short exact sequence stays short exact after tensoring on the +left. -/ +theorem ShortExact_tensorLeft [Category.{v} D] [MonoidalCategory D] [Abelian D] + [MonoidalPreadditive D] + {S : ShortComplex D} + (hS : S.ShortExact) (X : D) [HasLeftDual X] + [HasRightDual X] : + (S.map (tensorLeft X)).ShortExact := by + have := tensorLeftPreservesColimits X + have := tensorLeftPreservesLimits X + have : PreservesFiniteColimits (tensorLeft X) := + PreservesColimitsOfSize.preservesFiniteColimits _ + have : PreservesFiniteLimits (tensorLeft X) := + PreservesLimitsOfSize.preservesFiniteLimits _ + exact hS.map_of_exact (tensorLeft X) + +end Exactness + +section Reduction + +/-- The name of the identity: the coevaluation, braided into the +evaluation source. -/ +noncomputable def unitName + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (X : D) [HasRightDual X] : + 𝟙_ D ⟶ (Xᘁ) ⊗ X := + η_ X (Xᘁ) ≫ (β_ X (Xᘁ)).hom + +/-- The middle object of the unit-form extension: the pullback of +the internal-hom epimorphism along the name of the identity. -/ +noncomputable def unitFormMid + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + (S : ShortComplex D) [HasRightDual S.X₃] : D := + pullback (((S.X₃)ᘁ) ◁ S.g) (unitName S.X₃) + +/-- The inclusion of the unit-form extension. -/ +noncomputable def unitFormIn + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + [MonoidalPreadditive D] (S : ShortComplex D) [HasRightDual S.X₃] : + ((S.X₃)ᘁ) ⊗ S.X₁ ⟶ unitFormMid S := + pullback.lift (((S.X₃)ᘁ) ◁ S.f) 0 + (by rw [← MonoidalCategory.whiskerLeft_comp, S.zero, + MonoidalPreadditive.whiskerLeft_zero, zero_comp]) + +/-- **The unit-form extension**: the given sequence, internally +hommed and pulled back along the name of the identity, now with +unit quotient. -/ +noncomputable def unitForm + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + [MonoidalPreadditive D] (S : ShortComplex D) [HasRightDual S.X₃] : + ShortComplex D := + ShortComplex.mk (unitFormIn S) + (pullback.snd (((S.X₃)ᘁ) ◁ S.g) (unitName S.X₃)) + (pullback.lift_snd _ _ _) + +/-- Defining square of the inclusion. -/ +theorem unitFormIn_fst + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + [MonoidalPreadditive D] (S : ShortComplex D) [HasRightDual S.X₃] : + unitFormIn S ≫ pullback.fst (((S.X₃)ᘁ) ◁ S.g) + (unitName S.X₃) = + ((S.X₃)ᘁ) ◁ S.f := + pullback.lift_fst _ _ _ + +/-- **The unit-form extension is short exact**: the pullback of a +short exact sequence along a point of its quotient. -/ +theorem unitForm_shortExact + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + [MonoidalPreadditive D] (S : ShortComplex D) [HasRightDual S.X₃] + [HasLeftDual ((S.X₃)ᘁ : D)] [HasRightDual ((S.X₃)ᘁ : D)] + (hS : S.ShortExact) : + (unitForm S).ShortExact := by + have hT := ShortExact_tensorLeft hS ((S.X₃)ᘁ) + have hmf : Mono (((S.X₃)ᘁ) ◁ S.f) := hT.mono_f + have : Mono ((S.map (tensorLeft ((S.X₃)ᘁ))).f) := hT.mono_f + have hepig : Epi (((S.X₃)ᘁ) ◁ S.g) := hT.epi_g + have hw : (((S.X₃)ᘁ) ◁ S.f) ≫ (((S.X₃)ᘁ) ◁ S.g) = 0 := by + rw [← MonoidalCategory.whiskerLeft_comp, S.zero, + MonoidalPreadditive.whiskerLeft_zero] + have hfker : IsLimit (KernelFork.ofι (((S.X₃)ᘁ) ◁ S.f) hw) := + hT.exact.fIsKernel + have hmono : Mono (unitFormIn S) := by + have h1 : Mono (unitFormIn S ≫ + pullback.fst (((S.X₃)ᘁ) ◁ S.g) (unitName S.X₃)) := by + rw [unitFormIn_fst]; exact hmf + exact mono_of_mono (unitFormIn S) + (pullback.fst (((S.X₃)ᘁ) ◁ S.g) (unitName S.X₃)) + have : Mono ((unitForm S).f) := hmono + have hker : IsLimit (KernelFork.ofι (unitForm S).f + (unitForm S).zero) := by + refine KernelFork.IsLimit.ofι' _ _ (fun {W} t ht => ?_) + have htf : (t ≫ pullback.fst (((S.X₃)ᘁ) ◁ S.g) + (unitName S.X₃)) ≫ (((S.X₃)ᘁ) ◁ S.g) = 0 := + (Category.assoc _ _ _).trans + ((whisker_eq t pullback.condition).trans + ((Category.assoc _ _ _).symm.trans + ((eq_whisker ht _).trans zero_comp))) + obtain ⟨u, hu⟩ := KernelFork.IsLimit.lift' hfker + (t ≫ pullback.fst _ _) htf + refine ⟨u, ?_⟩ + have h2 : (unitForm S).f ≫ pullback.fst + (((S.X₃)ᘁ) ◁ S.g) (unitName S.X₃) = + ((S.X₃)ᘁ) ◁ S.f := unitFormIn_fst S + refine pullback.hom_ext ?_ ?_ + · exact (Category.assoc _ _ _).trans + ((whisker_eq u h2).trans hu) + · exact (Category.assoc _ _ _).trans + ((whisker_eq u (unitForm S).zero).trans + (comp_zero.trans ht.symm)) + exact { exact := ShortComplex.exact_of_f_is_kernel _ hker + mono_f := hmono + epi_g := Abelian.epi_pullback_of_epi_f + (((S.X₃)ᘁ) ◁ S.g) (unitName S.X₃) } + +end Reduction + +section MateDetect + +/-- **Epimorphisms dualise to monomorphisms**: the right adjoint +mate of an epimorphism is monic. -/ +theorem mono_rightAdjointMate [Category.{v} D] [MonoidalCategory D] + {X Y : D} [HasRightDual X] + [HasRightDual Y] + [∀ W : D, (tensorLeft W).PreservesEpimorphisms] + (f : X ⟶ Y) (hf : Epi f) : + Mono (fᘁ) := by + have := hf + constructor + intro W a b h + have : Epi (W ◁ f) := (tensorLeft W).map_epi f + have hslide : ∀ c : W ⟶ ((Yᘁ) : D), + ((c ≫ fᘁ) ▷ X) ≫ ε_ X (Xᘁ) = + (W ◁ f) ≫ (c ▷ Y) ≫ ε_ Y (Yᘁ) := by + intro c + rw [MonoidalCategory.comp_whiskerRight, Category.assoc, + rightAdjointMate_comp_evaluation, + ← Category.assoc, ← whisker_exchange, Category.assoc] + have key : (W ◁ f) ≫ (a ▷ Y) ≫ ε_ Y (Yᘁ) = + (W ◁ f) ≫ (b ▷ Y) ≫ ε_ Y (Yᘁ) := by + rw [← hslide a, ← hslide b, h] + have hΨ : (a ▷ Y) ≫ ε_ Y (Yᘁ) = (b ▷ Y) ≫ ε_ Y (Yᘁ) := + (cancel_epi (W ◁ f)).mp key + have h2 := congrArg (tensorRightHomEquiv W Y (Yᘁ) (𝟙_ D)) hΨ + rw [tensorRightHomEquiv_whiskerRight_comp_evaluation, + tensorRightHomEquiv_whiskerRight_comp_evaluation] at h2 + exact (cancel_mono (λ_ ((Yᘁ) : D)).inv).mp h2 + +end MateDetect + +section PointDual + +/-- The dual of the unit, canonically. -/ +noncomputable def unitDualIso + [Category.{v} D] [MonoidalCategory D] : (𝟙_ D : D) ≅ ((𝟙_ D : D)ᘁ) := + rightDualIso exactPairingUnit inferInstance + +/-- **The monic point of the dual**: the unit-form quotient, +dualised into a point of the dual of the middle object. -/ +noncomputable def unitFormPoint + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + [MonoidalPreadditive D] (S : ShortComplex D) [HasRightDual (S.X₃ : D)] + [HasRightDual (unitFormMid S : D)] : 𝟙_ D ⟶ ((unitFormMid S)ᘁ) := + unitDualIso.hom ≫ ((unitForm S).g)ᘁ + +/-- The point is monic when the sequence is short exact. -/ +theorem mono_unitFormPoint + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + [MonoidalPreadditive D] (S : ShortComplex D) [HasRightDual (S.X₃ : D)] + [HasRightDual (unitFormMid S : D)] + [HasLeftDual (((S.X₃)ᘁ) : D)] + [HasRightDual (((S.X₃)ᘁ) : D)] + [∀ W : D, (tensorLeft W).PreservesEpimorphisms] + (hS : S.ShortExact) : + Mono (unitFormPoint S) := by + have hm := mono_rightAdjointMate (X := unitFormMid S) + (Y := 𝟙_ D) ((unitForm S).g) + ((unitForm_shortExact S hS).epi_g) + exact mono_comp' inferInstance hm + +end PointDual + +section Transfer + +open scoped MonObj + +/-- The coevaluation meets the canonical unit-dual inverse as the +unit pairing's coevaluation. -/ +theorem coevaluation_unitDualIso_inv [Category.{v} D] [MonoidalCategory D] : + η_ (𝟙_ D) ((𝟙_ D)ᘁ) ≫ ((𝟙_ D) ◁ unitDualIso.inv) = + (ρ_ (𝟙_ D)).inv := by + have h := @coevaluation_comp_rightAdjointMate D _ _ + (𝟙_ D) (𝟙_ D) ⟨𝟙_ D⟩ inferInstance (𝟙 (𝟙_ D)) + rw [MonoidalCategory.id_whiskerRight, Category.comp_id] at h + exact h + +/-- **The point section**: the coevaluation, carried through a +class of the dual of the middle object. -/ +noncomputable def pointSection + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + (S : ShortComplex D) [HasRightDual (S.X₃ : D)] + [HasRightDual (unitFormMid S : D)] + (B : D) + (cls : ((unitFormMid S)ᘁ) ⟶ B) : + 𝟙_ D ⟶ unitFormMid S ⊗ B := + η_ (unitFormMid S) ((unitFormMid S)ᘁ) ≫ + (unitFormMid S ◁ cls) + +/-- The coevaluation carries the quotient onto the point, through +the canonical unit-dual identification. -/ +theorem coevaluation_unitFormPoint + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + [MonoidalPreadditive D] (S : ShortComplex D) [HasRightDual (S.X₃ : D)] + [HasRightDual (unitFormMid S : D)] : + η_ (𝟙_ D) ((𝟙_ D)ᘁ) ≫ + ((𝟙_ D) ◁ (unitDualIso.inv ≫ unitFormPoint S)) = + η_ (unitFormMid S) ((unitFormMid S)ᘁ) ≫ + ((unitForm S).g ▷ ((unitFormMid S)ᘁ)) := by + rw [unitFormPoint, Iso.inv_hom_id_assoc] + exact @coevaluation_comp_rightAdjointMate D _ _ + (unitFormMid S) (𝟙_ D) inferInstance hasRightDualUnit + ((unitForm S).g) + +/-- **The section property of the point section**: against the +unit-form quotient, a class restricting on the point to the unit +of the algebra yields the unit itself. -/ +theorem pointSection_section + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + [MonoidalPreadditive D] (S : ShortComplex D) [HasRightDual (S.X₃ : D)] + [HasRightDual (unitFormMid S : D)] + (B : D) [MonObj B] + (cls : ((unitFormMid S)ᘁ) ⟶ B) + (hcls : unitFormPoint S ≫ cls = η[B]) : + pointSection S B cls ≫ ((unitForm S).g ▷ B) = + (ρ_ (𝟙_ D)).inv ≫ ((𝟙_ D) ◁ η[B]) := by + have h1 : (unitFormMid S ◁ cls) ≫ ((unitForm S).g ▷ B) = + ((unitForm S).g ▷ ((unitFormMid S)ᘁ)) ≫ + ((𝟙_ D) ◁ cls) := + whisker_exchange _ _ + have h' : (unitDualIso.inv ≫ unitFormPoint S) ≫ cls = + unitDualIso.inv ≫ η[B] := + (Category.assoc _ _ _).trans (whisker_eq _ hcls) + exact (Category.assoc _ _ _).trans + ((whisker_eq (η_ _ _) h1).trans + ((Category.assoc _ _ _).symm.trans + ((eq_whisker (coevaluation_unitFormPoint S).symm _).trans + ((Category.assoc _ _ _).trans + ((whisker_eq (η_ _ _) + (MonoidalCategory.whiskerLeft_comp _ _ _).symm + ).trans + ((whisker_eq (η_ _ _) + (congrArg (fun t => (𝟙_ D) ◁ t) h')).trans + ((whisker_eq (η_ _ _) + (MonoidalCategory.whiskerLeft_comp + _ _ _)).trans + ((Category.assoc _ _ _).symm.trans + (eq_whisker + (coevaluation_unitDualIso_inv) _))))))))) + +/-- **The free section carrier**: the point section, folded into +the free module through the multiplication. -/ +noncomputable def freeSectionHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + (S : ShortComplex D) [HasRightDual (S.X₃ : D)] + [HasRightDual (unitFormMid S : D)] + (B : D) [MonObj B] + (cls : ((unitFormMid S)ᘁ) ⟶ B) : + B ⊗ 𝟙_ D ⟶ B ⊗ unitFormMid S := + (B ◁ pointSection S B cls) ≫ + (B ◁ (β_ (unitFormMid S) B).hom) ≫ + (α_ B B (unitFormMid S)).inv ≫ + (μ[B] ▷ unitFormMid S) + +/-- **The free section splits the quotient**: when the class +restricts on the point to the unit, the free section carrier is a +section of the whiskered quotient. -/ +theorem freeSectionHom_section + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + [MonoidalPreadditive D] (S : ShortComplex D) [HasRightDual (S.X₃ : D)] + [HasRightDual (unitFormMid S : D)] + (B : D) [MonObj B] + (cls : ((unitFormMid S)ᘁ) ⟶ B) + (hcls : unitFormPoint S ≫ cls = η[B]) : + freeSectionHom S B cls ≫ (B ◁ (unitForm S).g) = + 𝟙 (B ⊗ 𝟙_ D) := by + have h1 : (μ[B] ▷ unitFormMid S) ≫ (B ◁ (unitForm S).g) = + ((B ⊗ B) ◁ (unitForm S).g) ≫ (μ[B] ▷ (𝟙_ D)) := + (whisker_exchange _ _).symm + have h2 : (α_ B B (unitFormMid S)).inv ≫ + ((B ⊗ B) ◁ (unitForm S).g) = + (B ◁ (B ◁ (unitForm S).g)) ≫ (α_ B B (𝟙_ D)).inv := + (associator_inv_naturality_right _ _ _).symm + have h3 : (β_ (unitFormMid S) B).hom ≫ + (B ◁ (unitForm S).g) = + ((unitForm S).g ▷ B) ≫ (β_ (𝟙_ D) B).hom := + (BraidedCategory.braiding_naturality_left _ _).symm + have h4 : pointSection S B cls ≫ ((unitForm S).g ▷ B) = + (ρ_ (𝟙_ D)).inv ≫ ((𝟙_ D) ◁ η[B]) := + pointSection_section S B cls hcls + have h5 : ((𝟙_ D) ◁ η[B]) ≫ (β_ (𝟙_ D) B).hom = + (β_ (𝟙_ D) (𝟙_ D)).hom ≫ (η[B] ▷ (𝟙_ D)) := + (BraidedCategory.braiding_naturality_right _ _) + -- The inner element: the point section pushed through the + -- quotient and the braiding is the unit against the unitor. + have hinner : pointSection S B cls ≫ + (β_ (unitFormMid S) B).hom ≫ (B ◁ (unitForm S).g) = + (ρ_ (𝟙_ D)).inv ≫ (η[B] ▷ (𝟙_ D)) := + (whisker_eq _ h3).trans + ((Category.assoc _ _ _).symm.trans + ((eq_whisker h4 _).trans + ((Category.assoc _ _ _).trans + ((whisker_eq _ h5).trans + ((whisker_eq _ + (eq_whisker braiding_unit_self _)).trans + (whisker_eq _ (Category.id_comp _))))))) + have hfold : (B ◁ ((ρ_ (𝟙_ D)).inv ≫ (η[B] ▷ (𝟙_ D)))) ≫ + (α_ B B (𝟙_ D)).inv ≫ (μ[B] ▷ (𝟙_ D)) = + 𝟙 (B ⊗ 𝟙_ D) := by + rw [MonoidalCategory.whiskerLeft_comp, Category.assoc, + associator_inv_naturality_middle_assoc, + ← MonoidalCategory.comp_whiskerRight, MonObj.mul_one] + monoidal + have hstart : freeSectionHom S B cls ≫ (B ◁ (unitForm S).g) = + (B ◁ pointSection S B cls) ≫ + (B ◁ (β_ (unitFormMid S) B).hom) ≫ + (B ◁ (B ◁ (unitForm S).g)) ≫ + (α_ B B (𝟙_ D)).inv ≫ (μ[B] ▷ (𝟙_ D)) := by + rw [freeSectionHom] + simp only [Category.assoc] + rw [h1] + exact whisker_eq _ (whisker_eq _ + ((Category.assoc _ _ _).symm.trans + ((eq_whisker h2 _).trans (Category.assoc _ _ _)))) + have hpack : (B ◁ pointSection S B cls) ≫ + (B ◁ (β_ (unitFormMid S) B).hom) ≫ + (B ◁ (B ◁ (unitForm S).g)) ≫ + (α_ B B (𝟙_ D)).inv ≫ (μ[B] ▷ (𝟙_ D)) = + (B ◁ (pointSection S B cls ≫ + (β_ (unitFormMid S) B).hom ≫ (B ◁ (unitForm S).g))) ≫ + (α_ B B (𝟙_ D)).inv ≫ (μ[B] ▷ (𝟙_ D)) := by + repeat' erw [MonoidalCategory.whiskerLeft_comp, Category.assoc] + have hreplace := congrArg (fun t => (B ◁ t) ≫ + (α_ B B (𝟙_ D)).inv ≫ (μ[B] ▷ (𝟙_ D))) hinner + exact hstart.trans (hpack.trans (hreplace.trans hfold)) + +/-- **Extend a point to the free module**: any morphism into the +carrier of a module extends to a linear map from the free module, +through the action. -/ +noncomputable def freeModExtend [Category.{v} D] [MonoidalCategory D] + (B : D) [MonObj B] {V : D} + (M : Mod D B) (q : V ⟶ M.X) : freeMod B V ⟶ M := + Mod.Hom.mk' ((B ◁ q) ≫ actLeft B M.X) + (by + change ((α_ B B V).inv ≫ (μ[B] ▷ V)) ≫ + ((B ◁ q) ≫ actLeft B M.X) = + (B ◁ ((B ◁ q) ≫ actLeft B M.X)) ≫ actLeft B M.X + have h1 : (μ[B] ▷ V) ≫ (B ◁ q) = + ((B ⊗ B) ◁ q) ≫ (μ[B] ▷ M.X) := + (whisker_exchange _ _).symm + have h3 : (α_ B B V).inv ≫ ((B ⊗ B) ◁ q) = + (B ◁ (B ◁ q)) ≫ (α_ B B M.X).inv := + (associator_inv_naturality_right _ _ _).symm + calc ((α_ B B V).inv ≫ (μ[B] ▷ V)) ≫ + ((B ◁ q) ≫ actLeft B M.X) + = (α_ B B V).inv ≫ ((μ[B] ▷ V) ≫ (B ◁ q)) ≫ + actLeft B M.X := by + simp only [Category.assoc] + _ = (α_ B B V).inv ≫ (((B ⊗ B) ◁ q) ≫ + (μ[B] ▷ M.X)) ≫ actLeft B M.X := by rw [h1] + _ = ((α_ B B V).inv ≫ ((B ⊗ B) ◁ q)) ≫ + (μ[B] ▷ M.X) ≫ actLeft B M.X := by + simp only [Category.assoc] + _ = ((B ◁ (B ◁ q)) ≫ (α_ B B M.X).inv) ≫ + (μ[B] ▷ M.X) ≫ actLeft B M.X := by rw [h3] + _ = (B ◁ (B ◁ q)) ≫ (α_ B B M.X).inv ≫ + (α_ B B M.X).hom ≫ (B ◁ actLeft B M.X) ≫ + actLeft B M.X := by + rw [mul_actLeft] + simp only [Category.assoc] + _ = (B ◁ (B ◁ q)) ≫ (B ◁ actLeft B M.X) ≫ + actLeft B M.X := by rw [Iso.inv_hom_id_assoc] + _ = (B ◁ ((B ◁ q) ≫ actLeft B M.X)) ≫ + actLeft B M.X := by + simp only [MonoidalCategory.whiskerLeft_comp, + Category.assoc]) + +/-- **The free section**: the point section, braided and extended +to the free module. -/ +noncomputable def freeSection + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + (S : ShortComplex D) [HasRightDual (S.X₃ : D)] + [HasRightDual (unitFormMid S : D)] + (B : D) [MonObj B] + (cls : ((unitFormMid S)ᘁ) ⟶ B) : + freeMod B (𝟙_ D) ⟶ freeMod B (unitFormMid S) := + freeModExtend B (freeMod B (unitFormMid S)) + (pointSection S B cls ≫ (β_ (unitFormMid S) B).hom) + +/-- The free section's carrier is the folded point section. -/ +theorem freeSection_hom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + (S : ShortComplex D) [HasRightDual (S.X₃ : D)] + [HasRightDual (unitFormMid S : D)] + (B : D) [MonObj B] + (cls : ((unitFormMid S)ᘁ) ⟶ B) : + (freeSection S B cls).hom = freeSectionHom S B cls := by + change (B ◁ (pointSection S B cls ≫ + (β_ (unitFormMid S) B).hom)) ≫ + ((α_ B B (unitFormMid S)).inv ≫ + (μ[B] ▷ unitFormMid S)) = + freeSectionHom S B cls + rw [freeSectionHom] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + +/-- **Contract the dual against the argument**: braid the payload +out and evaluate. -/ +noncomputable def evalContract + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (X W : D) [HasRightDual X] : + (((Xᘁ) : D) ⊗ W) ⊗ X ⟶ W := + ((β_ ((Xᘁ) : D) W).hom ▷ X) ≫ (α_ W ((Xᘁ) : D) X).hom ≫ + (W ◁ ε_ X (Xᘁ)) ≫ (ρ_ W).hom + +/-- The contraction is natural in the payload. -/ +theorem evalContract_natural + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (X : D) [HasRightDual X] + {W W' : D} (h : W ⟶ W') : + ((((Xᘁ) : D) ◁ h) ▷ X) ≫ evalContract X W' = + evalContract X W ≫ h := by + rw [evalContract, evalContract] + have h1 : (((Xᘁ) : D) ◁ h) ≫ (β_ ((Xᘁ) : D) W').hom = + (β_ ((Xᘁ) : D) W).hom ≫ (h ▷ ((Xᘁ) : D)) := + BraidedCategory.braiding_naturality_right _ _ + have h2 : ((h ▷ ((Xᘁ) : D)) ▷ X) ≫ (α_ W' _ X).hom = + (α_ W _ X).hom ≫ (h ▷ (((Xᘁ) : D) ⊗ X)) := + associator_naturality_left _ _ _ + have h3 : (h ▷ (((Xᘁ) : D) ⊗ X)) ≫ (W' ◁ ε_ X (Xᘁ)) = + (W ◁ ε_ X (Xᘁ)) ≫ (h ▷ (𝟙_ D)) := + (whisker_exchange _ _).symm + have h4 : (h ▷ (𝟙_ D)) ≫ (ρ_ W').hom = (ρ_ W).hom ≫ h := by + simp + calc ((((Xᘁ) : D) ◁ h) ▷ X) ≫ (β_ ((Xᘁ) : D) W').hom ▷ X ≫ + (α_ W' ((Xᘁ) : D) X).hom ≫ (W' ◁ ε_ X (Xᘁ)) ≫ + (ρ_ W').hom + = ((((β_ ((Xᘁ) : D) W).hom ≫ (h ▷ ((Xᘁ) : D)))) ▷ X) ≫ + (α_ W' ((Xᘁ) : D) X).hom ≫ (W' ◁ ε_ X (Xᘁ)) ≫ + (ρ_ W').hom := by + rw [← MonoidalCategory.comp_whiskerRight_assoc, h1] + _ = ((β_ ((Xᘁ) : D) W).hom ▷ X) ≫ + ((h ▷ ((Xᘁ) : D)) ▷ X) ≫ + (α_ W' ((Xᘁ) : D) X).hom ≫ (W' ◁ ε_ X (Xᘁ)) ≫ + (ρ_ W').hom := by + rw [MonoidalCategory.comp_whiskerRight, + Category.assoc] + _ = ((β_ ((Xᘁ) : D) W).hom ▷ X) ≫ (α_ W _ X).hom ≫ + (h ▷ (((Xᘁ) : D) ⊗ X)) ≫ (W' ◁ ε_ X (Xᘁ)) ≫ + (ρ_ W').hom := by + rw [← Category.assoc ((h ▷ ((Xᘁ) : D)) ▷ X), h2, + Category.assoc] + _ = ((β_ ((Xᘁ) : D) W).hom ▷ X) ≫ (α_ W _ X).hom ≫ + (W ◁ ε_ X (Xᘁ)) ≫ (h ▷ (𝟙_ D)) ≫ (ρ_ W').hom := by + rw [← Category.assoc (h ▷ (((Xᘁ) : D) ⊗ X)), h3, + Category.assoc] + _ = ((β_ ((Xᘁ) : D) W).hom ▷ X) ≫ (α_ W _ X).hom ≫ + (W ◁ ε_ X (Xᘁ)) ≫ (ρ_ W).hom ≫ h := by + rw [h4] + _ = (((β_ ((Xᘁ) : D) W).hom ▷ X) ≫ (α_ W _ X).hom ≫ + (W ◁ ε_ X (Xᘁ)) ≫ (ρ_ W).hom) ≫ h := by + simp only [Category.assoc] + +/-- **The zigzag of the name**: the name of the identity, +contracted against the argument, is the unitor. -/ +theorem unitName_evalContract + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (X : D) [HasRightDual X] : + ((unitName X) ▷ X) ≫ evalContract X X = (λ_ X).hom := by + rw [unitName, evalContract, MonoidalCategory.comp_whiskerRight] + simp only [Category.assoc] + have hββ : ((β_ X ((Xᘁ) : D)).hom ▷ X) ≫ + ((β_ ((Xᘁ) : D) X).hom ▷ X) = 𝟙 _ := by + rw [← MonoidalCategory.comp_whiskerRight, + SymmetricCategory.symmetry, + MonoidalCategory.id_whiskerRight] + have hzig := ExactPairing.evaluation_coevaluation X ((Xᘁ) : D) + calc (η_ X (Xᘁ) ▷ X) ≫ ((β_ X ((Xᘁ) : D)).hom ▷ X) ≫ + ((β_ ((Xᘁ) : D) X).hom ▷ X) ≫ (α_ X ((Xᘁ) : D) X).hom ≫ + (X ◁ ε_ X (Xᘁ)) ≫ (ρ_ X).hom + = (η_ X (Xᘁ) ▷ X) ≫ (α_ X ((Xᘁ) : D) X).hom ≫ + (X ◁ ε_ X (Xᘁ)) ≫ (ρ_ X).hom := by + rw [← Category.assoc ((β_ X ((Xᘁ) : D)).hom ▷ X), hββ, + Category.id_comp] + _ = ((λ_ X).hom ≫ (ρ_ X).inv) ≫ (ρ_ X).hom := by + rw [← Category.assoc, ← Category.assoc, + Category.assoc (η_ X (Xᘁ) ▷ X), hzig] + _ = (λ_ X).hom := by + rw [Category.assoc, Iso.inv_hom_id, Category.comp_id] + +/-- **The element of the free section**: the unit, pushed through +the free section and out of the pullback. -/ +noncomputable def freeSectionPoint + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + (S : ShortComplex D) [HasRightDual (S.X₃ : D)] + [HasRightDual (unitFormMid S : D)] + (B : D) [MonObj B] + (cls : ((unitFormMid S)ᘁ) ⟶ B) : + 𝟙_ D ⟶ B ⊗ (((S.X₃)ᘁ) ⊗ S.X₂) := + (λ_ (𝟙_ D)).inv ≫ (η[B] ▷ (𝟙_ D)) ≫ + (freeSection S B cls).hom ≫ + (B ◁ pullback.fst (((S.X₃)ᘁ) ◁ S.g) (unitName S.X₃)) + +/-- The element carries the internal quotient onto the name. -/ +theorem freeSectionPoint_g + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + [MonoidalPreadditive D] (S : ShortComplex D) [HasRightDual (S.X₃ : D)] + [HasRightDual (unitFormMid S : D)] + (B : D) [MonObj B] + (cls : ((unitFormMid S)ᘁ) ⟶ B) + (hcls : unitFormPoint S ≫ cls = η[B]) : + freeSectionPoint S B cls ≫ (B ◁ (((S.X₃)ᘁ) ◁ S.g)) = + (λ_ (𝟙_ D)).inv ≫ (η[B] ▷ (𝟙_ D)) ≫ + (B ◁ unitName S.X₃) := by + have hpull : (B ◁ pullback.fst (((S.X₃)ᘁ) ◁ S.g) + (unitName S.X₃)) ≫ (B ◁ (((S.X₃)ᘁ) ◁ S.g)) = + (B ◁ (unitForm S).g) ≫ (B ◁ unitName S.X₃) := by + erw [← MonoidalCategory.whiskerLeft_comp, + ← MonoidalCategory.whiskerLeft_comp] + exact congrArg (fun t => B ◁ t) pullback.condition + have hsec : (freeSection S B cls).hom ≫ + (B ◁ (unitForm S).g) = 𝟙 (B ⊗ 𝟙_ D) := by + rw [freeSection_hom] + exact freeSectionHom_section S B cls hcls + have hsection : (freeSection S B cls).hom ≫ + (B ◁ pullback.fst (((S.X₃)ᘁ) ◁ S.g) (unitName S.X₃)) ≫ + (B ◁ (((S.X₃)ᘁ) ◁ S.g)) = B ◁ unitName S.X₃ := + (whisker_eq _ hpull).trans + ((Category.assoc _ _ _).symm.trans + ((eq_whisker hsec _).trans (Category.id_comp _))) + rw [freeSectionPoint] + simp only [Category.assoc] + exact whisker_eq _ (whisker_eq _ + ((Category.assoc _ _ _).trans hsection)) + +/-- **The transferred point**: the free-section element, +contracted against the argument. -/ +noncomputable def sectionPoint + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + (S : ShortComplex D) [HasRightDual (S.X₃ : D)] + [HasRightDual (unitFormMid S : D)] + (B : D) [MonObj B] + (cls : ((unitFormMid S)ᘁ) ⟶ B) : + S.X₃ ⟶ B ⊗ S.X₂ := + (λ_ (S.X₃)).inv ≫ (freeSectionPoint S B cls ▷ S.X₃) ≫ + (α_ B ((((S.X₃)ᘁ) ⊗ S.X₂)) (S.X₃)).hom ≫ + (B ◁ evalContract (S.X₃) (S.X₂)) + +/-- **The transferred point splits the quotient**: against the +quotient it is the unit against the argument. -/ +theorem sectionPoint_g + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + [MonoidalPreadditive D] (S : ShortComplex D) [HasRightDual (S.X₃ : D)] + [HasRightDual (unitFormMid S : D)] + (B : D) [MonObj B] + (cls : ((unitFormMid S)ᘁ) ⟶ B) + (hcls : unitFormPoint S ≫ cls = η[B]) : + sectionPoint S B cls ≫ (B ◁ S.g) = + (λ_ (S.X₃)).inv ≫ (η[B] ▷ S.X₃) := by + have hnat : (B ◁ evalContract (S.X₃) (S.X₂)) ≫ + (B ◁ S.g) = + (B ◁ (((((S.X₃)ᘁ) : D) ◁ S.g) ▷ S.X₃)) ≫ + (B ◁ evalContract (S.X₃) (S.X₃)) := by + rw [← MonoidalCategory.whiskerLeft_comp, + ← MonoidalCategory.whiskerLeft_comp] + exact congrArg (fun t => B ◁ t) + (evalContract_natural (S.X₃) S.g).symm + have hα : (α_ B ((((S.X₃)ᘁ) ⊗ S.X₂)) (S.X₃)).hom ≫ + (B ◁ (((((S.X₃)ᘁ) : D) ◁ S.g) ▷ S.X₃)) = + ((B ◁ ((((S.X₃)ᘁ) : D) ◁ S.g)) ▷ S.X₃) ≫ + (α_ B ((((S.X₃)ᘁ) ⊗ S.X₃)) (S.X₃)).hom := + (associator_naturality_middle _ _ _).symm + have hfsp : (freeSectionPoint S B cls ▷ S.X₃) ≫ + ((B ◁ ((((S.X₃)ᘁ) : D) ◁ S.g)) ▷ S.X₃) = + (((λ_ (𝟙_ D)).inv ≫ (η[B] ▷ (𝟙_ D)) ≫ + (B ◁ unitName S.X₃)) ▷ S.X₃) := by + rw [← MonoidalCategory.comp_whiskerRight, + freeSectionPoint_g S B cls hcls] + have hname : ((B ◁ unitName S.X₃) ▷ S.X₃) ≫ + (α_ B ((((S.X₃)ᘁ) ⊗ S.X₃)) (S.X₃)).hom ≫ + (B ◁ evalContract (S.X₃) (S.X₃)) = + (α_ B (𝟙_ D) (S.X₃)).hom ≫ (B ◁ (λ_ (S.X₃)).hom) := by + rw [associator_naturality_middle_assoc, + ← MonoidalCategory.whiskerLeft_comp, + unitName_evalContract] + have hη : (((η[B] ▷ (𝟙_ D))) ▷ S.X₃) ≫ + (α_ B (𝟙_ D) (S.X₃)).hom ≫ (B ◁ (λ_ (S.X₃)).hom) = + (α_ (𝟙_ D) (𝟙_ D) (S.X₃)).hom ≫ + ((𝟙_ D) ◁ (λ_ (S.X₃)).hom) ≫ (η[B] ▷ S.X₃) := by + rw [associator_naturality_left_assoc] + exact whisker_eq _ (whisker_exchange _ _).symm + have hcoh : (λ_ (S.X₃)).inv ≫ + (((λ_ (𝟙_ D)).inv) ▷ S.X₃) ≫ + (α_ (𝟙_ D) (𝟙_ D) (S.X₃)).hom ≫ + ((𝟙_ D) ◁ (λ_ (S.X₃)).hom) = (λ_ (S.X₃)).inv := by + monoidal + calc sectionPoint S B cls ≫ (B ◁ S.g) + = (λ_ (S.X₃)).inv ≫ (freeSectionPoint S B cls ▷ S.X₃) ≫ + (α_ B ((((S.X₃)ᘁ) ⊗ S.X₂)) (S.X₃)).hom ≫ + ((B ◁ evalContract (S.X₃) (S.X₂)) ≫ (B ◁ S.g)) := by + rw [sectionPoint] + simp only [Category.assoc] + _ = (λ_ (S.X₃)).inv ≫ (freeSectionPoint S B cls ▷ S.X₃) ≫ + ((α_ B ((((S.X₃)ᘁ) ⊗ S.X₂)) (S.X₃)).hom ≫ + (B ◁ (((((S.X₃)ᘁ) : D) ◁ S.g) ▷ S.X₃))) ≫ + (B ◁ evalContract (S.X₃) (S.X₃)) := by + rw [hnat] + simp only [Category.assoc] + _ = (λ_ (S.X₃)).inv ≫ + ((freeSectionPoint S B cls ▷ S.X₃) ≫ + ((B ◁ ((((S.X₃)ᘁ) : D) ◁ S.g)) ▷ S.X₃)) ≫ + (α_ B ((((S.X₃)ᘁ) ⊗ S.X₃)) (S.X₃)).hom ≫ + (B ◁ evalContract (S.X₃) (S.X₃)) := by + rw [hα] + simp only [Category.assoc] + _ = (λ_ (S.X₃)).inv ≫ + ((((λ_ (𝟙_ D)).inv ≫ (η[B] ▷ (𝟙_ D)) ≫ + (B ◁ unitName S.X₃)) ▷ S.X₃)) ≫ + (α_ B ((((S.X₃)ᘁ) ⊗ S.X₃)) (S.X₃)).hom ≫ + (B ◁ evalContract (S.X₃) (S.X₃)) := by + rw [hfsp] + _ = (λ_ (S.X₃)).inv ≫ (((λ_ (𝟙_ D)).inv) ▷ S.X₃) ≫ + (((η[B] ▷ (𝟙_ D))) ▷ S.X₃) ≫ + (((B ◁ unitName S.X₃)) ▷ S.X₃ ≫ + (α_ B ((((S.X₃)ᘁ) ⊗ S.X₃)) (S.X₃)).hom ≫ + (B ◁ evalContract (S.X₃) (S.X₃))) := by + simp only [MonoidalCategory.comp_whiskerRight, + Category.assoc] + _ = (λ_ (S.X₃)).inv ≫ (((λ_ (𝟙_ D)).inv) ▷ S.X₃) ≫ + (((η[B] ▷ (𝟙_ D))) ▷ S.X₃) ≫ + (α_ B (𝟙_ D) (S.X₃)).hom ≫ + (B ◁ (λ_ (S.X₃)).hom) := by + rw [hname] + _ = (λ_ (S.X₃)).inv ≫ (((λ_ (𝟙_ D)).inv) ▷ S.X₃) ≫ + (α_ (𝟙_ D) (𝟙_ D) (S.X₃)).hom ≫ + ((𝟙_ D) ◁ (λ_ (S.X₃)).hom) ≫ (η[B] ▷ S.X₃) := by + rw [hη] + _ = (λ_ (S.X₃)).inv ≫ (η[B] ▷ S.X₃) := by + rw [reassoc_of% hcoh] + +/-- **The section of the statement of record**: the transferred +point, extended to the free module. -/ +noncomputable def rappel210Section + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + (S : ShortComplex D) [HasRightDual (S.X₃ : D)] + [HasRightDual (unitFormMid S : D)] + (B : D) [MonObj B] + (cls : ((unitFormMid S)ᘁ) ⟶ B) : + freeMod B (S.X₃) ⟶ freeMod B (S.X₂) := + freeModExtend B (freeMod B (S.X₂)) (sectionPoint S B cls) + +/-- **The section splits the base-changed epimorphism**. -/ +theorem rappel210Section_splits + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + [MonoidalPreadditive D] (S : ShortComplex D) [HasRightDual (S.X₃ : D)] + [HasRightDual (unitFormMid S : D)] + (B : D) [MonObj B] + (cls : ((unitFormMid S)ᘁ) ⟶ B) + (hcls : unitFormPoint S ≫ cls = η[B]) : + rappel210Section S B cls ≫ freeModMap B S.g = + 𝟙 (freeMod B (S.X₃)) := + Mod.hom_ext _ _ (by + change ((B ◁ sectionPoint S B cls) ≫ + ((α_ B B (S.X₂)).inv ≫ (μ[B] ▷ S.X₂))) ≫ + (B ◁ S.g) = + 𝟙 (B ⊗ S.X₃) + have h1 : (μ[B] ▷ S.X₂) ≫ (B ◁ S.g) = + ((B ⊗ B) ◁ S.g) ≫ (μ[B] ▷ S.X₃) := + (whisker_exchange _ _).symm + have h2 : (α_ B B (S.X₂)).inv ≫ ((B ⊗ B) ◁ S.g) = + (B ◁ (B ◁ S.g)) ≫ (α_ B B (S.X₃)).inv := + (associator_inv_naturality_right _ _ _).symm + have h3 : (B ◁ sectionPoint S B cls) ≫ + (B ◁ (B ◁ S.g)) = + B ◁ ((λ_ (S.X₃)).inv ≫ (η[B] ▷ S.X₃)) := by + rw [← MonoidalCategory.whiskerLeft_comp, + sectionPoint_g S B cls hcls] + have hfold : (B ◁ ((λ_ (S.X₃)).inv ≫ (η[B] ▷ S.X₃))) ≫ + (α_ B B (S.X₃)).inv ≫ (μ[B] ▷ S.X₃) = + 𝟙 (B ⊗ S.X₃) := by + rw [MonoidalCategory.whiskerLeft_comp, Category.assoc, + associator_inv_naturality_middle_assoc, + ← MonoidalCategory.comp_whiskerRight, MonObj.mul_one] + monoidal + calc ((B ◁ sectionPoint S B cls) ≫ + ((α_ B B (S.X₂)).inv ≫ (μ[B] ▷ S.X₂))) ≫ + (B ◁ S.g) + = (B ◁ sectionPoint S B cls) ≫ + (α_ B B (S.X₂)).inv ≫ + (((B ⊗ B) ◁ S.g) ≫ (μ[B] ▷ S.X₃)) := by + simp only [Category.assoc] + rw [h1] + _ = (B ◁ sectionPoint S B cls) ≫ (B ◁ (B ◁ S.g)) ≫ + (α_ B B (S.X₃)).inv ≫ (μ[B] ▷ S.X₃) := by + rw [← Category.assoc (α_ B B (S.X₂)).inv, h2] + simp only [Category.assoc] + _ = (B ◁ ((λ_ (S.X₃)).inv ≫ (η[B] ▷ S.X₃))) ≫ + (α_ B B (S.X₃)).inv ≫ (μ[B] ▷ S.X₃) := by + rw [← Category.assoc (B ◁ sectionPoint S B cls), h3] + _ = 𝟙 (B ⊗ S.X₃) := hfold) + +/-- **The local splitting statement holds given a unital class on +the dual of the unit-form middle object**: the full reduction. -/ +theorem rappel210_of_class + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Abelian D] + [MonoidalPreadditive D] (S : ShortComplex D) [HasRightDual (S.X₃ : D)] + [HasRightDual (unitFormMid S : D)] + (hS : S.ShortExact) (B : D) + [MonObj B] [IsCommMonObj B] (hnz : η[B] ≠ 0) + (cls : ((unitFormMid S)ᘁ) ⟶ B) + (hcls : unitFormPoint S ≫ cls = η[B]) : + Rappel210Statement S hS := + ⟨B, ‹MonObj B›, ‹IsCommMonObj B›, hnz, + rappel210Section S B cls, rappel210Section_splits S B cls hcls⟩ + +end Transfer + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/RegularSum.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RegularSum.lean new file mode 100644 index 0000000000..401d2a1aea --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RegularSum.lean @@ -0,0 +1,1188 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ShapeAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PackageAssembly +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PieriChain + +/-! +# The regular-representation dimension bound + +For every `SchurPackage` and every size `n`, the central +idempotents of the shapes of size `n` are pairwise orthogonal and +sum to the identity of `ℂ[S_n]`; reading off the coefficient of +the identity permutation, the squares of the dimensions sum to +`n!` — the Wedderburn completeness of the blocks. The +Cauchy–Schwarz-free consequences `n! ≤ (∑ dim)²` and +`√(n!) ≤ ∑ dim` are the forms consumed by the Deligne development +(Catégories tensorielles, 1.20). + +The proof pins the package's characters: centrality makes them +class functions, and the Frobenius field determines a class +function completely, by linear independence of the completed +cycle-type monomials — so they agree with the Jacobi–Trudi +characters and the package idempotents are the native projectors. +Orthogonality then reduces, through the action table and the +faithfulness trick, to injectivity of the Schur specialisation +`μ ↦ diagramSchur μ`, proved by evaluating at genuine variable +families and extracting an alternant coefficient. Completeness is +a dimension count in the centre of the group algebra against the +class sums, which are no more numerous than the shapes. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv + +universe u + +/-! ### Polynomial identities from evaluations + +Two multivariate polynomials over `ℂ` agreeing at every point are +equal. (Mathlib's `MvPolynomial.funext` is not part of the tree's +Mathlib footprint, so the finitely-many-variables case is rebuilt +here from the one-variable statement.) -/ + +section MvFunext + +open MvPolynomial + +/-- A multivariate polynomial over `ℂ` in finitely many variables +vanishing at every point is zero. -/ +theorem mv_eval_zero_fin : + ∀ (m : ℕ) (p : MvPolynomial (Fin m) ℂ), + (∀ x : Fin m → ℂ, eval x p = 0) → p = 0 := by + intro m + induction m with + | zero => + intro p hp + obtain ⟨a, rfl⟩ := C_surjective (Fin 0) p + rw [show a = eval finZeroElim (C a : MvPolynomial (Fin 0) ℂ) + from (eval_C _).symm, hp finZeroElim, map_zero] + | succ m ih => + intro p hp + apply (finSuccEquiv ℂ m).injective + rw [map_zero] + apply Polynomial.eq_zero_of_infinite_isRoot + refine Set.Infinite.mono ?_ + (Set.infinite_univ.image + ((C_injective (Fin m) ℂ).injOn (s := Set.univ))) + rintro _ ⟨r, -, rfl⟩ + change Polynomial.IsRoot _ (C r) + rw [Polynomial.IsRoot] + apply ih + intro s + have hcomm : eval s (Polynomial.eval (C r) + ((finSuccEquiv ℂ m) p)) = + Polynomial.eval r + (Polynomial.map (eval s) ((finSuccEquiv ℂ m) p)) := by + rw [Polynomial.eval_map, Polynomial.eval, + Polynomial.hom_eval₂, RingHom.comp_id, eval_C] + rw [hcomm, ← eval_eq_eval_mv_eval'] + exact hp _ + +/-- Two multivariate polynomials over `ℂ` in finitely many +variables agreeing at every point are equal. -/ +theorem mv_funext_fin {m : ℕ} {p q : MvPolynomial (Fin m) ℂ} + (h : ∀ x : Fin m → ℂ, eval x p = eval x q) : p = q := by + rw [← sub_eq_zero] + apply mv_eval_zero_fin + intro x + rw [map_sub, h x, sub_self] + +/-- A multivariate polynomial over `ℂ` in countably many variables +vanishing at every point is zero. -/ +theorem mv_eval_zero_nat (p : MvPolynomial ℕ ℂ) + (hp : ∀ x : ℕ → ℂ, eval x p = 0) : p = 0 := by + obtain ⟨m, f, hf, q, rfl⟩ := exists_fin_rename p + suffices hq : q = 0 by rw [hq, map_zero] + apply mv_eval_zero_fin + intro y + have hev := hp (Function.extend f y 0) + rw [eval_rename] at hev + rwa [show (Function.extend f y 0) ∘ f = y from + funext fun i => hf.extend_apply _ _ _] at hev + +end MvFunext + +/-! ### Separation by the Schur specialisation + +The Jacobi–Trudi determinant is stable under padding the row-length +vector with zero rows, evaluates at genuine power sums to the +polynomial Jacobi–Trudi determinant, and — through the bialternant +identity and the strict alternant coefficient — separates diagrams: +`μ ↦ diagramSchur μ` is injective. -/ + +section Separation + +open MvPolynomial + +/-- Rows of zero length do not change the Jacobi–Trudi +determinant: padding the row-length vector is invisible. -/ +theorem det_newtonHZ_pad (t : ℕ → ℂ) (v : ℕ → ℕ) : + ∀ (k : ℕ) {L : ℕ}, L ≤ k → (∀ i, L ≤ i → v i = 0) → + (Matrix.of fun i j : Fin k => + newtonHZ t ((v i : ℤ) + (j : ℤ) - (i : ℤ))).det = + (Matrix.of fun i j : Fin L => + newtonHZ t ((v i : ℤ) + (j : ℤ) - (i : ℤ))).det := by + intro k + induction k with + | zero => + intro L hL _ + obtain rfl : L = 0 := Nat.le_zero.mp hL + rfl + | succ k ih => + intro L hL hv + rcases Nat.lt_or_ge L (k + 1) with hLk | hLk + swap + · obtain rfl : L = k + 1 := le_antisymm hL hLk + rfl + have hLk' : L ≤ k := Nat.lt_succ_iff.mp hLk + rw [Matrix.det_succ_row _ (Fin.last k)] + rw [Finset.sum_eq_single (Fin.last k) ?side ?empty] + · -- the surviving corner term + have hcorner : (Matrix.of fun i j : Fin (k + 1) => + newtonHZ t ((v i : ℤ) + (j : ℤ) - (i : ℤ))) + (Fin.last k) (Fin.last k) = 1 := by + simp only [Matrix.of_apply, Fin.val_last] + rw [hv k hLk'] + rw [show ((0 : ℕ) : ℤ) + (k : ℤ) - (k : ℤ) = ((0 : ℕ) : ℤ) + from by omega] + rw [newtonHZ_natCast, newtonH_zero] + rw [hcorner, mul_one] + have hsign : (-1 : ℂ) ^ (((Fin.last k : Fin (k + 1)) : ℕ) + + ((Fin.last k : Fin (k + 1)) : ℕ)) = 1 := by + rw [show (((Fin.last k : Fin (k + 1)) : ℕ) + + ((Fin.last k : Fin (k + 1)) : ℕ)) = 2 * k from by + rw [Fin.val_last]; ring] + rw [pow_mul, neg_one_sq, one_pow] + rw [hsign, one_mul] + have hminor : ((Matrix.of fun i j : Fin (k + 1) => + newtonHZ t ((v i : ℤ) + (j : ℤ) - (i : ℤ))).submatrix + (Fin.last k).succAbove (Fin.last k).succAbove) = + Matrix.of fun i j : Fin k => + newtonHZ t ((v i : ℤ) + (j : ℤ) - (i : ℤ)) := by + refine Matrix.ext fun i j => ?_ + simp only [Matrix.submatrix_apply, Fin.succAbove_last, + Matrix.of_apply, Fin.val_castSucc] + rw [hminor, ih hLk' hv] + · -- the other entries of the last row vanish + intro j _ hj + have hjlt : (j : ℕ) < k := by + rcases Fin.lt_or_eq_of_le (Fin.le_last j) with h | h + · exact Nat.lt_of_lt_of_le (Fin.lt_def.mp h) + (le_of_eq (Fin.val_last k)) + · exact absurd h hj + have hzero : (Matrix.of fun i j : Fin (k + 1) => + newtonHZ t ((v i : ℤ) + (j : ℤ) - (i : ℤ))) + (Fin.last k) j = 0 := by + simp only [Matrix.of_apply, Fin.val_last] + rw [hv k hLk'] + refine newtonHZ_neg _ _ ?_ + omega + rw [hzero, mul_zero, zero_mul] + · intro habs + exact absurd (Finset.mem_univ (Fin.last k)) habs + +/-- Evaluating the complete homogeneous polynomial in all variables +gives the complete homogeneous value. -/ +theorem eval_hSub_univ {k : ℕ} (x : Fin k → ℂ) (m : ℕ) : + eval x (hSub (Finset.univ : Finset (Fin k)) m) = hVal x m := by + classical + rw [hSub, Finset.filter_true_of_mem + (fun w _ => fun i _ => Finset.mem_univ i)] + rw [map_sum] + refine Finset.sum_congr rfl fun w _ => ?_ + rw [show (eval x) (w.1.map X).prod = + ((w.1.map X).map (eval x)).prod from + (map_multiset_prod (eval x) _)] + rw [Multiset.map_map] + congr 1 + exact Multiset.map_congr rfl fun i _ => eval_X i + +/-- Evaluating the `ℤ`-indexed complete homogeneous polynomial +gives the Newton lift of the power sums of the variables. -/ +theorem eval_hSubZ_univ {k : ℕ} (x : Fin k → ℂ) (z : ℤ) : + eval x (hSubZ (Finset.univ : Finset (Fin k)) z) = + newtonHZ (pVal x) z := by + rcases le_or_gt 0 z with hz | hz + · obtain ⟨m, rfl⟩ := Int.eq_ofNat_of_zero_le hz + rw [hSubZ_natCast, newtonHZ_natCast, eval_hSub_univ, + newtonH_pVal] + · rw [hSubZ_neg _ _ hz, newtonHZ_neg _ _ hz, map_zero] + +/-- The Jacobi–Trudi determinant of a diagram, evaluated at a +variable family, is the Schur specialisation at its power sums. -/ +theorem eval_jtMat_det (lam : YoungDiagram) {k : ℕ} + (hk : lam.colLen 0 ≤ k) (x : Fin k → ℂ) : + eval x ((jtMat (fun i : Fin k => lam.rowLen (i : ℕ))).det) = + diagramSchur lam (pVal x) := by + rw [RingHom.map_det] + have hentry : (eval x).mapMatrix + (jtMat (fun i : Fin k => lam.rowLen (i : ℕ))) = + Matrix.of fun i j : Fin k => + newtonHZ (pVal x) ((lam.rowLen (i : ℕ) : ℤ) + + (j : ℤ) - (i : ℤ)) := by + refine Matrix.ext fun i j => ?_ + rw [RingHom.mapMatrix_apply, Matrix.map_apply] + rw [show jtMat (fun i : Fin k => lam.rowLen (i : ℕ)) i j = + hSubZ Finset.univ ((lam.rowLen (i : ℕ) : ℤ) + + ((j : Fin k) : ℕ) - (i : ℕ)) from rfl] + rw [eval_hSubZ_univ] + rfl + rw [hentry] + have hzero : ∀ i, lam.rowLens.length ≤ i → lam.rowLen i = 0 := by + intro i hi + by_contra hne + have hmem : (i, 0) ∈ lam := + YoungDiagram.mem_iff_lt_rowLen.mpr (Nat.pos_of_ne_zero hne) + have := YoungDiagram.mem_iff_lt_colLen.mp hmem + rw [YoungDiagram.length_rowLens] at hi + omega + have hLk : lam.rowLens.length ≤ k := by + rw [YoungDiagram.length_rowLens]; exact hk + rw [det_newtonHZ_pad (pVal x) (fun i => lam.rowLen i) k hLk hzero] + rw [diagramSchur, schurDet] + congr 1 + refine Matrix.ext fun i j => ?_ + rw [Matrix.of_apply, Matrix.of_apply] + congr 1 + have hgr : lam.rowLens.get i = lam.rowLen (i : ℕ) := by + rw [List.get_eq_getElem] + exact YoungDiagram.get_rowLens + omega + +/-- **Injectivity of the Schur specialisation**: diagrams with the +same Schur values at every prospective power-sum sequence are +equal. -/ +theorem diagramSchur_injective {lam mu : YoungDiagram} + (h : ∀ t : ℕ → ℂ, diagramSchur lam t = diagramSchur mu t) : + lam = mu := by + classical + set k := max (lam.colLen 0) (mu.colLen 0) with hk + set vl : Fin k → ℕ := fun i => lam.rowLen (i : ℕ) with hvl + set vm : Fin k → ℕ := fun i => mu.rowLen (i : ℕ) with hvm + -- the polynomial Jacobi–Trudi determinants agree + have hdet : (jtMat vl).det = (jtMat vm).det := by + refine mv_funext_fin fun x => ?_ + rw [hvl, hvm, eval_jtMat_det lam (le_max_left _ _) x, + eval_jtMat_det mu (le_max_right _ _) x, h] + -- hence so do the alternants + have halt : altDet (eVec lam k) = altDet (eVec mu k) := by + rw [show altDet (eVec lam k) = (powMat vl).det from rfl, + show altDet (eVec mu k) = (powMat vm).det from rfl, + bialternant vl, bialternant vm, hdet] + -- extract the diagonal coefficient of the `lam` alternant + have h1 : (altDet (eVec lam k)).coeff (∑ i, Finsupp.single i (eVec lam k i)) = 1 := by + rw [alternant_coeff_strict _ _ (eVec_strict lam k) + (eVec_strict lam k), ite_eq_left rfl] + rw [halt, alternant_coeff_strict _ _ (eVec_strict mu k) + (eVec_strict lam k)] at h1 + have heVec : eVec mu k = eVec lam k := by + by_contra hne + rw [ite_eq_right hne] at h1 + exact zero_ne_one h1 + -- row lengths agree everywhere + have hzero : ∀ (nu : YoungDiagram) (i : ℕ), nu.colLen 0 ≤ i → + nu.rowLen i = 0 := by + intro nu i hi + by_contra hne + have hmem : (i, 0) ∈ nu := + YoungDiagram.mem_iff_lt_rowLen.mpr (Nat.pos_of_ne_zero hne) + have := YoungDiagram.mem_iff_lt_colLen.mp hmem + omega + have hrow : ∀ i : ℕ, lam.rowLen i = mu.rowLen i := by + intro i + rcases Nat.lt_or_ge i k with hik | hik + · have hfun := congrFun heVec ⟨i, hik⟩ + simp only [eVec] at hfun + omega + · rw [hzero lam i (le_trans (le_max_left _ _) hik), + hzero mu i (le_trans (le_max_right _ _) hik)] + -- and diagrams are determined by their row lengths + have hcells : lam.cells = mu.cells := by + refine Finset.ext fun c => ?_ + rw [YoungDiagram.mem_cells, YoungDiagram.mem_cells] + obtain ⟨i, j⟩ := c + rw [YoungDiagram.mem_iff_lt_rowLen, + YoungDiagram.mem_iff_lt_rowLen, hrow i] + exact YoungDiagram.ext hcells + +end Separation + +/-! ### Transport along an equality of sizes + +`Shape.e` recasts idempotents along `symCast` at an equality of +sizes; on coefficients this is relabelling of permutations along +`permCast`, which preserves products, inverses, and cycle types. -/ + +section Transport + +/-- Relabelling of permutations along an equality of sizes. -/ +def permCast {m n : ℕ} (h : m = n) : + Equiv.Perm (Fin m) ≃ Equiv.Perm (Fin n) := + Equiv.permCongr (finCongr h) + +/-- At `rfl`, relabelling is the identity. -/ +@[simp] +theorem permCast_rfl {n : ℕ} : + permCast (rfl : n = n) = Equiv.refl (Equiv.Perm (Fin n)) := by + refine Equiv.ext fun σ => ?_ + refine Equiv.ext fun y => ?_ + rw [permCast, finCongr_refl, Equiv.permCongr_apply] + rfl + +/-- Relabelling preserves products. -/ +theorem permCast_mul {m n : ℕ} (h : m = n) + (σ τ : Equiv.Perm (Fin m)) : + permCast h (σ * τ) = permCast h σ * permCast h τ := by + refine Equiv.ext fun y => ?_ + simp only [permCast, Equiv.permCongr_apply, Equiv.Perm.mul_apply, + Equiv.symm_apply_apply] + +/-- Relabelling fixes the identity. -/ +theorem permCast_one {m n : ℕ} (h : m = n) : + permCast h (1 : Equiv.Perm (Fin m)) = 1 := by + refine Equiv.ext fun y => ?_ + simp only [permCast, Equiv.permCongr_apply] + rw [Equiv.Perm.one_apply, Equiv.apply_symm_apply] + rfl + +/-- Relabelling preserves inverses. -/ +theorem permCast_inv {m n : ℕ} (h : m = n) (σ : Equiv.Perm (Fin m)) : + permCast h σ⁻¹ = (permCast h σ)⁻¹ := by + have hmul : permCast h σ⁻¹ * permCast h σ = 1 := by + rw [← permCast_mul, inv_mul_cancel, permCast_one] + exact (inv_eq_of_mul_eq_one_left hmul).symm + +/-- Relabelling preserves cycle types. -/ +theorem cycleType_permCast {m n : ℕ} (h : m = n) + (σ : Equiv.Perm (Fin m)) : + (permCast h σ).cycleType = σ.cycleType := + cycleType_permCongr (finCongr h) σ + +/-- `symCast` at a reflexive inequality is the identity. -/ +theorem symCast_le_refl {n : ℕ} (h : n ≤ n) (x : SymGroupAlgebra n) : + symCast h x = x := by + apply MonoidAlgebra.coeff_injective + change Finsupp.mapDomain + (⇑(Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h))) x.coeff = x.coeff + have hid : ∀ σ : Equiv.Perm (Fin n), + (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h)) σ = σ := by + intro σ + rw [Equiv.Perm.viaEmbeddingHom_apply] + refine Equiv.ext fun y => ?_ + have hy : (Fin.castLEEmb h) y = y := Fin.ext (by simp) + calc (σ.viaEmbedding (Fin.castLEEmb h)) y + = (σ.viaEmbedding (Fin.castLEEmb h)) ((Fin.castLEEmb h) y) := + by rw [hy] + _ = (Fin.castLEEmb h) (σ y) := + Equiv.Perm.viaEmbedding_apply σ _ y + _ = σ y := hy ▸ rfl + rw [show ⇑(Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h)) = id from + funext hid] + exact Finsupp.mapDomain_id + +/-- Coefficients of a recast element are coefficients of the +original, at the relabelled permutation. -/ +theorem symCast_apply_of_eq {m n : ℕ} (h : m = n) + (x : SymGroupAlgebra m) (g : Equiv.Perm (Fin n)) : + (symCast (le_of_eq h) x).coeff g = x.coeff ((permCast h).symm g) := by + subst h + rw [symCast_le_refl, permCast_rfl] + rfl + +/-- Recasting a class element relabels its coefficient +function. -/ +theorem symCast_classElem_of_eq {m n : ℕ} (h : m = n) + (c : Equiv.Perm (Fin m) → ℂ) : + symCast (le_of_eq h) (classElem c) = + classElem (fun g => c ((permCast h).symm g)) := by + subst h + rw [symCast_le_refl, permCast_rfl] + rfl + +end Transport + +/-! ### Coefficients of the package idempotents + +The coefficient function of `P.e μ`, the block-rank computation of +the identity coefficient, and the conjugation invariance of the +package's characters, forced by centrality. -/ + +section Coefficients + +/-- `charIdempotent` is the class element of the normalised +character — no inversion invariance required. -/ +theorem charIdempotent_eq_classElem' {n : ℕ} (d : ℕ) + (χ : Equiv.Perm (Fin n) → ℂ) : + charIdempotent d χ = + classElem (fun π : Equiv.Perm (Fin n) => + ((d : ℂ) / (n.factorial : ℂ)) * χ π) := by + rw [charIdempotent, classElem, Finset.smul_sum] + refine Finset.sum_congr rfl fun π _ => ?_ + rw [smul_smul] + rfl + +/-- The coefficients of the central idempotent of a shape. -/ +theorem SchurPackage.e_coeff (P : SchurPackage.{u}) + (μ : YoungDiagram) (π : Equiv.Perm (Fin μ.card)) : + (P.e μ).coeff π = + ((P.dim μ : ℂ) / (μ.card.factorial : ℂ)) * P.char μ π := by + rw [SchurPackage.e_def, charIdempotent_eq_classElem', + classElem_coeff] + +/-- The block rank at the identity coefficient: the square of the +dimension is `n!` times the identity coefficient of the +idempotent. -/ +theorem SchurPackage.dim_sq_eq_coeff_one (P : SchurPackage.{u}) + (μ : YoungDiagram) : + ((P.dim μ : ℂ)) ^ 2 = + (μ.card.factorial : ℂ) * (P.e μ).coeff 1 := by + have h := finrank_range_mulLeft + (G := Equiv.Perm (Fin μ.card)) (P.e μ) (P.idem μ) + rw [SchurPackage.e_def] at h + rw [P.block_rank μ] at h + rw [Fintype.card_perm, Fintype.card_fin] at h + rw [← SchurPackage.e_def] at h + exact_mod_cast h + +/-- The package's character at the identity is the dimension. -/ +theorem SchurPackage.char_one (P : SchurPackage.{u}) + (μ : YoungDiagram) : + P.char μ 1 = (P.dim μ : ℂ) := by + have h := P.dim_sq_eq_coeff_one μ + rw [P.e_coeff μ 1] at h + have hfac : ((μ.card.factorial : ℕ) : ℂ) ≠ 0 := + Nat.cast_ne_zero.mpr (Nat.factorial_ne_zero _) + have hdim : ((P.dim μ : ℕ) : ℂ) ≠ 0 := + Nat.cast_ne_zero.mpr (Nat.pos_iff_ne_zero.mp (P.dim_pos μ)) + have h2 : ((P.dim μ : ℂ)) ^ 2 = (P.dim μ : ℂ) * P.char μ 1 := by + rw [h] + field_simp + rw [sq] at h2 + exact (mul_left_cancel₀ hdim h2).symm + +/-- The central idempotents are nonzero. -/ +theorem SchurPackage.e_ne_zero (P : SchurPackage.{u}) + (μ : YoungDiagram) : + P.e μ ≠ 0 := by + intro h + have h2 := P.dim_sq_eq_coeff_one μ + rw [h] at h2 + rw [show ((0 : SymGroupAlgebra μ.card)).coeff 1 = 0 from rfl, + mul_zero] at h2 + have hdim : ((P.dim μ : ℕ) : ℂ) ≠ 0 := + Nat.cast_ne_zero.mpr (Nat.pos_iff_ne_zero.mp (P.dim_pos μ)) + exact pow_ne_zero 2 hdim h2 + +/-- Coefficients of an element commuting with the whole group +algebra are conjugation-invariant. -/ +theorem coeff_conj_of_comm {G : Type*} [Group G] + (x : MonoidAlgebra ℂ G) + (hx : ∀ y, x * y = y * x) (g c : G) : + x.coeff (c * g * c⁻¹) = x.coeff g := by + have h := congrArg (fun z : MonoidAlgebra ℂ G => z.coeff (c * g)) + (hx (MonoidAlgebra.single c 1)) + rw [show (x * MonoidAlgebra.single c (1 : ℂ)).coeff (c * g) = + x.coeff ((c * g) * c⁻¹) * 1 from + MonoidAlgebra.coeff_mul_single_apply x 1 c (c * g)] at h + rw [show (MonoidAlgebra.single c (1 : ℂ) * x).coeff (c * g) = + 1 * x.coeff (c⁻¹ * (c * g)) from + MonoidAlgebra.coeff_single_mul_apply x 1 c (c * g)] at h + rw [mul_one, one_mul, inv_mul_cancel_left] at h + exact h + +/-- The package's characters are class functions: conjugation +invariance is forced by the centrality of the idempotents. -/ +theorem SchurPackage.char_conj (P : SchurPackage.{u}) + (μ : YoungDiagram) (g c : Equiv.Perm (Fin μ.card)) : + P.char μ (c * g * c⁻¹) = P.char μ g := by + have h := coeff_conj_of_comm (P.e μ) + (fun y => P.central μ y) g c + rw [P.e_coeff, P.e_coeff] at h + have hne : ((P.dim μ : ℂ) / (μ.card.factorial : ℂ)) ≠ 0 := + div_ne_zero + (Nat.cast_ne_zero.mpr (Nat.pos_iff_ne_zero.mp (P.dim_pos μ))) + (Nat.cast_ne_zero.mpr (Nat.factorial_ne_zero _)) + exact mul_left_cancel₀ hne h + +end Coefficients + +/-! ### The Frobenius field determines the characters + +The completed cycle-type monomials attached to distinct cycle types +are distinct monomials, hence linearly independent as functions of +the prospective power sums; a class function with vanishing +cycle-weighted sums at every `t` is therefore zero. Comparing the +package's Frobenius field with the Jacobi–Trudi one pins +`P.char = jtChar` and `P.dim = nDim ∘ jtSimple`, identifying the +package idempotents with the native projectors. -/ + +section Determination + +open MvPolynomial + +/-- The exponent record of the completed cycle-type monomial. -/ +noncomputable def cycExp {n : ℕ} (π : Equiv.Perm (Fin n)) : + ℕ →₀ ℕ := + Multiset.toFinsupp π.cycleType + + Finsupp.single 1 (n - π.cycleType.sum) + +/-- Products of powers over a multiset's counting record. -/ +theorem prod_pow_toFinsupp (t : ℕ → ℂ) (m : Multiset ℕ) : + (Multiset.toFinsupp m).prod (fun c e => t c ^ e) = + (m.map t).prod := by + induction m using Multiset.induction_on with + | empty => simp + | cons a s ih => + rw [show a ::ₘ s = {a} + s from (Multiset.singleton_add a s).symm] + rw [Multiset.toFinsupp_add, Finsupp.prod_add_index' + (fun c => pow_zero (t c)) (fun c e e' => pow_add (t c) e e'), + Multiset.toFinsupp_singleton] + have hsingle : ((Finsupp.single a (1 : ℕ)).prod + fun c e => t c ^ e) = t a ^ (1 : ℕ) := + Finsupp.prod_single_index (pow_zero (t a)) + rw [hsingle, pow_one, ih, Multiset.map_add, Multiset.prod_add, + Multiset.map_singleton, Multiset.prod_singleton] + +/-- The completed cycle-type monomial evaluates to the completed +cycle-type product. -/ +theorem eval_cycExp (t : ℕ → ℂ) {n : ℕ} (π : Equiv.Perm (Fin n)) : + eval t (monomial (cycExp π) (1 : ℂ)) = cycleProd t π := by + rw [eval_monomial, one_mul, cycExp, Finsupp.prod_add_index' + (fun c => pow_zero (t c)) (fun c e e' => pow_add (t c) e e')] + have hsingle : (Finsupp.single 1 (n - π.cycleType.sum)).prod + (fun c e => t c ^ e) = t 1 ^ (n - π.cycleType.sum) := + Finsupp.prod_single_index (pow_zero (t 1)) + rw [prod_pow_toFinsupp, hsingle] + rfl + +/-- The exponent record determines, and is determined by, the +cycle type. -/ +theorem cycExp_eq_iff {n : ℕ} (π π' : Equiv.Perm (Fin n)) : + cycExp π = cycExp π' ↔ π.cycleType = π'.cycleType := by + constructor + · intro h + have hcount : ∀ c : ℕ, π.cycleType.count c = π'.cycleType.count c := by + intro c + rcases eq_or_ne c 1 with rfl | hc + · rw [Multiset.count_eq_zero_of_notMem + (fun hmem => by + have := Equiv.Perm.two_le_of_mem_cycleType hmem + omega), + Multiset.count_eq_zero_of_notMem + (fun hmem => by + have := Equiv.Perm.two_le_of_mem_cycleType hmem + omega)] + · have happ := congrArg (fun f : ℕ →₀ ℕ => f c) h + simp only [cycExp, Finsupp.add_apply, + Multiset.toFinsupp_apply, Finsupp.single_apply] at happ + simp only [ite_eq_right (fun h1 : (1 : ℕ) = c => hc h1.symm), + add_zero] at happ + exact happ + exact Multiset.ext.mpr hcount + · intro h + rw [cycExp, cycExp, h] + +/-- **A class function is determined by its Frobenius pairings**: +if all its completed cycle-weighted sums vanish, it vanishes. -/ +theorem classFun_eq_zero_of_cycleProd {n : ℕ} + (δ : Equiv.Perm (Fin n) → ℂ) + (hconj : ∀ g c : Equiv.Perm (Fin n), δ (c * g * c⁻¹) = δ g) + (hvan : ∀ t : ℕ → ℂ, + ∑ π : Equiv.Perm (Fin n), δ π * cycleProd t π = 0) : + ∀ π, δ π = 0 := by + classical + set p : MvPolynomial ℕ ℂ := + ∑ π : Equiv.Perm (Fin n), monomial (cycExp π) (δ π) with hp + have hp0 : p = 0 := by + refine mv_eval_zero_nat p fun t => ?_ + rw [hp, map_sum] + rw [Finset.sum_congr rfl fun π _ => show + eval t (monomial (cycExp π) (δ π)) = δ π * cycleProd t π + from by + rw [show monomial (cycExp π) (δ π) = + δ π • monomial (cycExp π) (1 : ℂ) from by + rw [smul_monomial, smul_eq_mul, mul_one]] + rw [smul_eq_C_mul, map_mul, eval_C, eval_cycExp]] + exact hvan t + intro π₀ + have hcoeff := congrArg (fun q : MvPolynomial ℕ ℂ => q.coeff (cycExp π₀)) hp0 + rw [hp, coeff_sum, AddMonoidAlgebra.coeff_zero] at hcoeff + rw [Finset.sum_congr rfl (fun π _ => coeff_monomial + (cycExp π₀) (cycExp π) (δ π))] at hcoeff + rw [Finset.sum_congr rfl (fun π _ => show + (if cycExp π = cycExp π₀ then δ π else 0) = + (if cycExp π = cycExp π₀ then δ π₀ else 0) from by + by_cases hπ : cycExp π = cycExp π₀ + · rw [ite_eq_left hπ, ite_eq_left hπ] + have hct := (cycExp_eq_iff π π₀).mp hπ + obtain ⟨c, hc⟩ := isConj_iff.mp + (Equiv.Perm.isConj_of_cycleType_eq hct.symm) + rw [← hc, hconj] + · rw [ite_eq_right hπ, ite_eq_right hπ])] at hcoeff + rw [← Finset.sum_filter, Finset.sum_const, nsmul_eq_mul] at hcoeff + have hmem : π₀ ∈ Finset.univ.filter + (fun π : Equiv.Perm (Fin n) => cycExp π = cycExp π₀) := + Finset.mem_filter.mpr ⟨Finset.mem_univ _, rfl⟩ + have hpos : (0 : ℕ) < (Finset.univ.filter + (fun π : Equiv.Perm (Fin n) => cycExp π = cycExp π₀)).card := + Finset.card_pos.mpr ⟨π₀, hmem⟩ + rcases mul_eq_zero.mp hcoeff with hcard | hδ + · exact absurd hcard (Nat.cast_ne_zero.mpr (Nat.pos_iff_ne_zero.mp + hpos)) + · exact hδ + +/-- **The package's characters are the Jacobi–Trudi ones.** -/ +theorem SchurPackage.char_eq_jtChar (P : SchurPackage.{u}) + (μ : YoungDiagram) (π : Equiv.Perm (Fin μ.card)) : + P.char μ π = jtChar μ π := by + have hzero := classFun_eq_zero_of_cycleProd + (fun π => P.char μ π - jtChar μ π) ?conj ?van π + · exact sub_eq_zero.mp hzero + case conj => + intro g c + rw [P.char_conj μ g c] + congr 1 + rw [jtSimple_char μ, jtSimple_char μ] + exact Representation.char_conj (ρ := rhoS (jtSimple μ)) g c + case van => + intro t + have h1 : ((μ.card.factorial : ℂ))⁻¹ * + ∑ π : Equiv.Perm (Fin μ.card), + P.char μ π * cycleProd t π = diagramSchur μ t := + P.frobenius μ t + have h2 := jtChar_frobenius' μ t + have hne : ((μ.card.factorial : ℂ))⁻¹ ≠ 0 := + inv_ne_zero (Nat.cast_ne_zero.mpr (Nat.factorial_ne_zero _)) + have hsum := mul_left_cancel₀ hne (h1.trans h2.symm) + rw [Finset.sum_congr rfl fun π _ => sub_mul (P.char μ π) + (jtChar μ π) (cycleProd t π)] + rw [Finset.sum_sub_distrib, hsum, sub_self] + +/-- **The package's dimensions are the native ones.** -/ +theorem SchurPackage.dim_eq (P : SchurPackage.{u}) + (μ : YoungDiagram) : + P.dim μ = nDim (jtSimple μ) := by + have h1 := P.char_one μ + rw [P.char_eq_jtChar μ 1, jtSimple_char μ 1] at h1 + have h2 : nChar (jtSimple μ) 1 = (nDim (jtSimple μ) : ℂ) := by + rw [nChar, Representation.char_one] + rfl + rw [h2] at h1 + exact_mod_cast h1.symm + +/-- **The package idempotents are the native projectors.** -/ +theorem SchurPackage.e_eq_nProjector (P : SchurPackage.{u}) + (μ : YoungDiagram) : + P.e μ = nProjector (jtSimple μ) := by + rw [SchurPackage.e_def, + show P.char μ = jtChar μ from funext (P.char_eq_jtChar μ), + P.dim_eq μ] + exact charIdempotent_jtSimple μ + +end Determination + +/-! ### Orthogonality of the blocks + +Distinct shapes of one size have orthogonal central idempotents: +through the native action table, a common simple module would force +the two Jacobi–Trudi characters to agree, hence the two Schur +specialisations, hence the shapes — by the separation theorem. -/ + +section Orthogonality + +/-- Relabelling as a homomorphism of permutation groups. -/ +def permCastHom {m n : ℕ} (h : m = n) : + Equiv.Perm (Fin m) →* Equiv.Perm (Fin n) where + toFun := permCast h + map_one' := permCast_one h + map_mul' := permCast_mul h + +/-- The inverse of a relabelling is the reverse relabelling. -/ +theorem permCast_symm {m n : ℕ} (h : m = n) : + (permCast h).symm = permCast h.symm := + rfl + +/-- Pulling a representation back along a relabelling preserves +irreducibility. -/ +theorem isIrreducible_comp_permCastHom {m n : ℕ} (h : m = n) + {V : Type*} [AddCommGroup V] [Module ℂ V] + (ρ : Representation ℂ (Equiv.Perm (Fin n)) V) + (hρ : ρ.IsIrreducible) : + Representation.IsIrreducible (ρ.comp (permCastHom h)) := by + subst h + have hid : permCastHom (rfl : m = m) = + MonoidHom.id (Equiv.Perm (Fin m)) := by + refine MonoidHom.ext fun g => ?_ + change permCast rfl g = g + rw [permCast_rfl] + rfl + rw [hid, MonoidHom.comp_id] + exact hρ + +/-- **Orthogonality of the recast idempotents**, unbundled form: +distinct diagrams of one size have orthogonal idempotents. -/ +theorem e_mul_e_eq_zero_of_ne (P : SchurPackage.{u}) {n : ℕ} + (lam mu : YoungDiagram) (hl : lam.card = n) (hm : mu.card = n) + (hne : lam ≠ mu) : + symCast (le_of_eq hl) (P.e lam) * + symCast (le_of_eq hm) (P.e mu) = 0 := by + classical + subst hl + rw [symCast_le_refl] + -- the second factor as a class element + set c' : Equiv.Perm (Fin lam.card) → ℂ := + fun g => nCoeff (jtSimple mu) ((permCast hm).symm g) with hc'def + have hB : symCast (le_of_eq hm) (P.e mu) = classElem c' := by + rw [P.e_eq_nProjector mu] + rw [show nProjector (jtSimple mu) = + classElem (nCoeff (jtSimple mu)) from rfl] + rw [symCast_classElem_of_eq] + have hc' : ∀ g c : Equiv.Perm (Fin lam.card), + c' (c * g * c⁻¹) = c' g := by + intro g c + rw [hc'def] + change nCoeff (jtSimple mu) + ((permCast hm).symm (c * g * c⁻¹)) = _ + rw [permCast_symm, permCast_mul, permCast_mul, permCast_inv] + exact nCoeff_classFun (jtSimple mu) _ _ + rw [P.e_eq_nProjector lam, hB] + -- kill every simple submodule + apply eq_zero_of_kills_simples + intro T hT s hs + rw [mul_assoc, + classElem_mul_mem_native (S := T) hT c' hc' s hs, + mul_smul_comm, + nProjector_mul_mem (jtSimple lam) T + (jtSimple_simple lam) hT s hs] + by_cases hiso : + Nonempty ((rhoS (jtSimple lam)).Equiv (rhoS T)) + swap + · rw [ite_eq_right hiso, zero_smul, smul_zero] + rw [ite_eq_left hiso, one_smul] + suffices hzero : (∑ g, c' g * nChar T g) = 0 by + rw [hzero, zero_div, zero_smul] + by_contra hne0 + -- reindex the pairing to the `mu`-side group + have hre : (∑ g : Equiv.Perm (Fin lam.card), c' g * nChar T g) = + ∑ g' : Equiv.Perm (Fin mu.card), + nCoeff (jtSimple mu) g' * nChar T (permCast hm g') := by + rw [← Equiv.sum_comp (permCast hm) + (fun g => c' g * nChar T g)] + refine Finset.sum_congr rfl fun g' _ => ?_ + congr 1 + -- the pulled-back representation of the common simple + set ρ' : Representation ℂ (Equiv.Perm (Fin mu.card)) + (subCarrier T) := (rhoS T).comp (permCastHom hm) with hρ' + have hirr' : ρ'.IsIrreducible := + isIrreducible_comp_permCastHom hm (rhoS T) + (rhoS_isIrreducible T hT) + have hirrS : (rhoS (jtSimple mu)).IsIrreducible := + rhoS_isIrreducible (jtSimple mu) (jtSimple_simple mu) + have hcard0 : ((Nat.card (Equiv.Perm (Fin mu.card)) : ℂ)) ≠ 0 := by + rw [Nat.card_eq_fintype_card] + exact_mod_cast Fintype.card_ne_zero + have : Invertible ((Nat.card (Equiv.Perm (Fin mu.card)) : ℂ)) := + invertibleOfNonzero hcard0 + have horth := Representation.char_orthonormal ρ' + (rhoS (jtSimple mu)) + -- evaluate the pairing + have hval : (∑ g' : Equiv.Perm (Fin mu.card), + nCoeff (jtSimple mu) g' * nChar T (permCast hm g')) = + ((nDim (jtSimple mu) : ℂ) / + (Fintype.card (Equiv.Perm (Fin mu.card)) : ℂ)) * + ∑ g' : Equiv.Perm (Fin mu.card), + ρ'.character g' * (rhoS (jtSimple mu)).character g'⁻¹ := by + rw [Finset.mul_sum] + refine Finset.sum_congr rfl fun g' _ => ?_ + rw [nCoeff] + rw [show nChar T (permCast hm g') = ρ'.character g' from rfl] + rw [show nChar (jtSimple mu) g'⁻¹ = + (rhoS (jtSimple mu)).character g'⁻¹ from rfl] + ring + have hval2 : (∑ g' : Equiv.Perm (Fin mu.card), + ρ'.character g' * (rhoS (jtSimple mu)).character g'⁻¹) = + (Nat.card (Equiv.Perm (Fin mu.card)) : ℂ) * + (if Nonempty ((rhoS (jtSimple mu)).Equiv ρ') + then 1 else 0) := by + rw [← horth, ← mul_assoc, mul_inv_cancel₀ hcard0, one_mul] + -- a common simple forces the characters to agree + have hiso2 : Nonempty ((rhoS (jtSimple mu)).Equiv ρ') := by + by_contra hempty + rw [hre, hval, hval2, ite_eq_right hempty, mul_zero, mul_zero] + at hne0 + exact hne0 rfl + obtain ⟨φlam⟩ := hiso + obtain ⟨φmu⟩ := hiso2 + have hcharlam : ∀ g, jtChar lam g = nChar T g := by + intro g + rw [jtSimple_char lam g] + exact congrFun (Representation.char_iso φlam) g + have hcharmu : ∀ g', jtChar mu g' = + nChar T (permCast hm g') := by + intro g' + rw [jtSimple_char mu g'] + exact congrFun (Representation.char_iso φmu) g' + -- hence the Schur specialisations agree, and the shapes + have hds : ∀ t, diagramSchur mu t = diagramSchur lam t := by + intro t + rw [← jtChar_frobenius' mu t, ← jtChar_frobenius' lam t] + have hfac : ((mu.card.factorial : ℂ))⁻¹ = + ((lam.card.factorial : ℂ))⁻¹ := by rw [hm] + have hsum : (∑ g' : Equiv.Perm (Fin mu.card), + jtChar mu g' * cycleProd t g') = + ∑ g : Equiv.Perm (Fin lam.card), + jtChar lam g * cycleProd t g := by + rw [← Equiv.sum_comp (permCast hm) + (fun g => jtChar lam g * cycleProd t g)] + refine Finset.sum_congr rfl fun g' _ => ?_ + rw [hcharmu g', ← hcharlam (permCast hm g')] + congr 1 + rw [cycleProd, cycleProd, cycleType_permCast] + have hexp : mu.card - g'.cycleType.sum = + lam.card - g'.cycleType.sum := by omega + rw [hexp] + rw [hfac, hsum] + exact hne (diagramSchur_injective hds).symm + +/-- **Orthogonality of the blocks**: distinct shapes of one size +have orthogonal recast idempotents. -/ +theorem SchurPackage.shape_e_orthogonal (P : SchurPackage.{u}) + {n : ℕ} (μ ν : Shape n) (hμν : μ ≠ ν) : + Shape.e P μ * Shape.e P ν = 0 := by + refine e_mul_e_eq_zero_of_ne P μ.val ν.val μ.prop ν.prop ?_ + intro h + exact hμν (Shape.ext h) + +end Orthogonality + +/-! ### Completeness of the blocks + +The recast idempotents are linearly independent — orthogonal +nonzero idempotents — and all lie in the span of the class sums, +which is at most `p(n)`-dimensional; as there are exactly `p(n)` +shapes, they must span, and expanding the identity over them forces +every coefficient to be `1`. -/ + +section Completeness + +/-- The full cycle type of a permutation of `Fin n`, completed by +its fixed points: a partition of `n`. -/ +noncomputable def fullPartition {n : ℕ} (π : Equiv.Perm (Fin n)) : + Nat.Partition n where + parts := π.cycleType + + Multiset.replicate (n - π.cycleType.sum) 1 + parts_pos := fun {p} hp => by + rcases Multiset.mem_add.mp hp with hp | hp + · have := Equiv.Perm.two_le_of_mem_cycleType hp + omega + · rw [Multiset.eq_of_mem_replicate hp] + exact Nat.one_pos + parts_sum := by + rw [Multiset.sum_add, Equiv.Perm.sum_cycleType, + Multiset.sum_replicate, smul_eq_mul, mul_one] + have hle : π.support.card ≤ n := by + have hcard := Finset.card_le_univ π.support + rwa [Fintype.card_fin] at hcard + omega + +/-- The full cycle type determines the cycle type. -/ +theorem cycleType_eq_of_fullPartition_eq {n : ℕ} + {π π' : Equiv.Perm (Fin n)} + (h : fullPartition π = fullPartition π') : + π.cycleType = π'.cycleType := by + classical + have hfil : ∀ σ : Equiv.Perm (Fin n), + (fullPartition σ).parts.filter (fun p => 2 ≤ p) = + σ.cycleType := by + intro σ + rw [show (fullPartition σ).parts = σ.cycleType + + Multiset.replicate (n - σ.cycleType.sum) 1 from rfl] + rw [Multiset.filter_add] + rw [Multiset.filter_eq_self.mpr + (fun a ha => Equiv.Perm.two_le_of_mem_cycleType ha)] + rw [Multiset.filter_eq_nil.mpr (fun a ha => by + rw [Multiset.eq_of_mem_replicate ha] + omega)] + rw [add_zero] + rw [← hfil π, ← hfil π', h] + +open scoped Classical in +/-- The class sum of a full cycle type. -/ +noncomputable def classSum (n : ℕ) (ρ : Nat.Partition n) : + SymGroupAlgebra n := + ∑ π ∈ Finset.univ.filter + (fun π : Equiv.Perm (Fin n) => fullPartition π = ρ), + MonoidAlgebra.single π 1 + +open scoped Classical in +/-- **Class elements lie in the span of the class sums**: the +conjugation-invariant elements are spanned by `p(n)` vectors. -/ +theorem classElem_mem_span_classSum {n : ℕ} + (c : Equiv.Perm (Fin n) → ℂ) + (hc : ∀ g k : Equiv.Perm (Fin n), c (k * g * k⁻¹) = c g) : + classElem c ∈ + Submodule.span ℂ (Set.range (classSum n)) := by + rw [classElem] + rw [← Finset.sum_fiberwise Finset.univ + (fun π : Equiv.Perm (Fin n) => fullPartition π) + (fun π => c π • MonoidAlgebra.single π (1 : ℂ))] + refine Submodule.sum_mem _ fun ρ _ => ?_ + by_cases hfib : (Finset.univ.filter + (fun π : Equiv.Perm (Fin n) => fullPartition π = ρ)).Nonempty + · obtain ⟨π₀, hπ₀⟩ := hfib + have hconst : ∀ π ∈ Finset.univ.filter + (fun π : Equiv.Perm (Fin n) => fullPartition π = ρ), + c π = c π₀ := by + intro π hπ + have hfp : fullPartition π = fullPartition π₀ := by + rw [(Finset.mem_filter.mp hπ).2, + (Finset.mem_filter.mp hπ₀).2] + have hct := cycleType_eq_of_fullPartition_eq hfp + obtain ⟨k, hk⟩ := isConj_iff.mp + (Equiv.Perm.isConj_of_cycleType_eq hct.symm) + rw [← hk, hc] + rw [Finset.sum_congr rfl fun π hπ => by rw [hconst π hπ]] + rw [← Finset.smul_sum] + exact Submodule.smul_mem _ _ + (Submodule.subset_span ⟨ρ, rfl⟩) + · rw [Finset.not_nonempty_iff_eq_empty.mp hfib, + Finset.sum_empty] + exact Submodule.zero_mem _ + +/-- The identity is a class element. -/ +theorem one_eq_classElem_ite (n : ℕ) : + (1 : SymGroupAlgebra n) = + classElem (fun π : Equiv.Perm (Fin n) => + if π = 1 then (1 : ℂ) else 0) := by + refine MonoidAlgebra.coeff_injective ?_ + ext k + show (1 : SymGroupAlgebra n).coeff k = + (classElem (fun π : Equiv.Perm (Fin n) => + if π = 1 then (1 : ℂ) else 0)).coeff k + rw [classElem_coeff] + rw [show (1 : SymGroupAlgebra n) = + MonoidAlgebra.single 1 1 from MonoidAlgebra.one_def] + rw [show (MonoidAlgebra.single (1 : Equiv.Perm (Fin n)) + (1 : ℂ)).coeff k = + (if (1 : Equiv.Perm (Fin n)) = k then (1 : ℂ) else 0) from + Finsupp.single_apply] + by_cases hk : k = 1 + · subst hk + rw [ite_eq_left rfl] + · rw [ite_eq_right (fun h => hk h.symm), ite_eq_right hk] + +/-- The recast idempotent of a shape is a class element. -/ +theorem shape_e_eq_classElem (P : SchurPackage.{u}) {n : ℕ} + (μ : Shape n) : + Shape.e P μ = classElem (fun g : Equiv.Perm (Fin n) => + nCoeff (jtSimple μ.val) ((permCast μ.prop).symm g)) := by + rw [Shape.e, P.e_eq_nProjector μ.val, + show nProjector (jtSimple μ.val) = + classElem (nCoeff (jtSimple μ.val)) from rfl, + symCast_classElem_of_eq] + +/-- The recast idempotents lie in the span of the class sums. -/ +theorem shape_e_mem_span (P : SchurPackage.{u}) {n : ℕ} + (μ : Shape n) : + Shape.e P μ ∈ + Submodule.span ℂ (Set.range (classSum n)) := by + rw [shape_e_eq_classElem] + refine classElem_mem_span_classSum _ ?_ + intro g k + show nCoeff (jtSimple μ.val) + ((permCast μ.prop).symm (k * g * k⁻¹)) = _ + rw [permCast_symm, permCast_mul, permCast_mul, permCast_inv] + exact nCoeff_classFun (jtSimple μ.val) _ _ + +/-- The recast idempotents are nonzero. -/ +theorem shape_e_ne_zero (P : SchurPackage.{u}) {n : ℕ} + (μ : Shape n) : + Shape.e P μ ≠ 0 := by + rw [Ne, Shape.e_eq_zero_iff] + exact P.e_ne_zero μ.val + +/-- Multiplying a weighted sum of the recast idempotents by one of +them extracts its term. -/ +theorem sum_smul_mul_shape_e (P : SchurPackage.{u}) {n : ℕ} + (c : Shape n → ℂ) (ν : Shape n) : + (∑ μ : Shape n, c μ • Shape.e P μ) * Shape.e P ν = + c ν • Shape.e P ν := by + rw [Finset.sum_mul] + rw [Finset.sum_eq_single ν + (fun μ _ hμν => by + rw [smul_mul_assoc, P.shape_e_orthogonal μ ν hμν, smul_zero]) + (fun h => absurd (Finset.mem_univ ν) h)] + rw [smul_mul_assoc, Shape.e_mul_self] + +/-- The recast idempotents are linearly independent. -/ +theorem shape_e_linearIndependent (P : SchurPackage.{u}) (n : ℕ) : + LinearIndependent ℂ (fun μ : Shape n => Shape.e P μ) := by + rw [Fintype.linearIndependent_iff] + intro c hc ν + have hL := sum_smul_mul_shape_e P c ν + rw [hc, zero_mul] at hL + rcases smul_eq_zero.mp hL.symm with h0 | h0 + · exact h0 + · exact absurd h0 (shape_e_ne_zero P ν) + +/-- The identity of the group algebra lies in the span of the +class sums. -/ +theorem one_mem_span_classSum (n : ℕ) : + (1 : SymGroupAlgebra n) ∈ + Submodule.span ℂ (Set.range (classSum n)) := by + rw [one_eq_classElem_ite] + refine classElem_mem_span_classSum _ ?_ + intro g k + show (if k * g * k⁻¹ = 1 then (1 : ℂ) else 0) = + (if g = 1 then (1 : ℂ) else 0) + by_cases hg : g = 1 + · subst hg + rw [ite_eq_left rfl, ite_eq_left (by group)] + · rw [ite_eq_right hg, ite_eq_right (fun h => hg (by + calc g = k⁻¹ * (k * g * k⁻¹) * k := by group + _ = 1 := by rw [h]; group))] + +/-- Every element in the class-sum span has coordinates in the recast +central idempotents. -/ +theorem eq_sum_shape_e_of_mem_span (P : SchurPackage.{u}) {n : ℕ} + {x : SymGroupAlgebra n} + (hx : x ∈ Submodule.span ℂ (Set.range (classSum n))) : + ∃ c : Shape n → ℂ, ∑ μ, c μ • Shape.e P μ = x := by + classical + set W := Submodule.span ℂ (Set.range (classSum n)) with hWdef + have : FiniteDimensional ℂ W := + FiniteDimensional.span_of_finite ℂ (Set.finite_range _) + have hfr : Module.finrank ℂ W ≤ Fintype.card (Nat.Partition n) := by + refine le_trans (finrank_span_le_card (Set.range (classSum n))) ?_ + rw [Set.toFinset_range] + exact le_trans Finset.card_image_le (le_of_eq Finset.card_univ) + have hmem : ∀ μ : Shape n, Shape.e P μ ∈ W := shape_e_mem_span P + set E' : Shape n → W := fun μ => ⟨Shape.e P μ, hmem μ⟩ with hE'def + have hli' : LinearIndependent ℂ E' := + LinearIndependent.of_comp W.subtype + (shape_e_linearIndependent P n) + have hcard : Fintype.card (Shape n) = Module.finrank ℂ W := + le_antisymm hli'.fintype_card_le_finrank + (le_trans hfr + (le_of_eq (Fintype.card_congr (shapeEquivPartition n)).symm)) + have hspan : Submodule.span ℂ (Set.range E') = ⊤ := + hli'.span_eq_top_of_card_eq_finrank' hcard + have h1sp : (⟨x, hx⟩ : W) ∈ Submodule.span ℂ (Set.range E') := by + rw [hspan] + exact Submodule.mem_top + rw [Submodule.mem_span_range_iff_exists_fun] at h1sp + obtain ⟨c, hc⟩ := h1sp + refine ⟨c, ?_⟩ + have hval : W.subtype (∑ μ : Shape n, c μ • E' μ) = + W.subtype ⟨x, hx⟩ := congrArg _ hc + rw [map_sum] at hval + rw [Finset.sum_congr rfl fun μ _ => + map_smul W.subtype (c μ) (E' μ)] at hval + exact hval + +/-- **Completeness of the blocks**: at every size the recast +central idempotents sum to the identity of the group algebra. -/ +theorem SchurPackage.sum_shape_e_eq_one (P : SchurPackage.{u}) + (n : ℕ) : + ∑ μ : Shape n, Shape.e P μ = 1 := by + classical + obtain ⟨c, hc'⟩ := eq_sum_shape_e_of_mem_span P + (one_mem_span_classSum n) + have hone : ∀ ν : Shape n, c ν = 1 := by + intro ν + have h := congrArg + (fun z : SymGroupAlgebra n => z * Shape.e P ν) hc' + rw [sum_smul_mul_shape_e P c ν, one_mul] at h + have hz : (c ν - 1) • Shape.e P ν = 0 := by + rw [sub_smul, one_smul, h, sub_self] + rcases smul_eq_zero.mp hz with h0 | h0 + · rwa [sub_eq_zero] at h0 + · exact absurd h0 (shape_e_ne_zero P ν) + rw [← hc'] + refine Finset.sum_congr rfl fun μ _ => ?_ + rw [hone μ, one_smul] + +end Completeness + +/-! ### The regular-representation dimension bound + +Reading the identity coefficient off the completeness identity +gives `∑ (dim μ)² = n!`; the elementary inequality +`∑ aᵢ² ≤ (∑ aᵢ)²` for naturals and a square root then give the +forms consumed by the Deligne development. -/ + +section RegularBound + +/-- The identity coefficient of a recast idempotent. -/ +theorem shape_e_coeff_one (P : SchurPackage.{u}) {n : ℕ} + (μ : Shape n) : + (Shape.e P μ).coeff 1 = + ((P.dim μ.val : ℂ)) ^ 2 / (n.factorial : ℂ) := by + have h1 : (Shape.e P μ).coeff 1 = (P.e μ.val).coeff 1 := by + change (symCast (le_of_eq μ.prop) (P.e μ.val)).coeff 1 = (P.e μ.val).coeff 1 + rw [symCast_apply_of_eq μ.prop (P.e μ.val) 1, + permCast_symm, permCast_one] + have hfac : ((μ.val.card.factorial : ℕ) : ℂ) ≠ 0 := + Nat.cast_ne_zero.mpr (Nat.factorial_ne_zero _) + have h3 : (P.e μ.val).coeff 1 = + ((P.dim μ.val : ℂ)) ^ 2 / (μ.val.card.factorial : ℂ) := by + rw [eq_div_iff hfac, mul_comm] + exact (P.dim_sq_eq_coeff_one μ.val).symm + rw [h1, h3, Shape.card_val] + +/-- **Wedderburn completeness of the blocks**: the squares of the +dimensions of the shapes of size `n` sum to `n!`. -/ +theorem SchurPackage.sum_dim_sq_eq (P : SchurPackage.{u}) (n : ℕ) : + ∑ μ : Shape n, P.dim μ.val ^ 2 = n.factorial := by + have hsum := congrArg (fun z : SymGroupAlgebra n => z.coeff 1) + (P.sum_shape_e_eq_one n) + rw [show (∑ μ : Shape n, Shape.e P μ).coeff 1 = + ∑ μ : Shape n, (Shape.e P μ).coeff 1 from by + rw [MonoidAlgebra.coeff_sum] + exact Finsupp.finsetSum_apply _ _ _] at hsum + rw [show ((1 : SymGroupAlgebra n)).coeff 1 = 1 from by + rw [show (1 : SymGroupAlgebra n) = + MonoidAlgebra.single 1 1 from MonoidAlgebra.one_def] + exact Finsupp.single_eq_same] at hsum + rw [Finset.sum_congr rfl fun μ _ => shape_e_coeff_one P μ] + at hsum + rw [← Finset.sum_div] at hsum + have hfac : ((n.factorial : ℕ) : ℂ) ≠ 0 := + Nat.cast_ne_zero.mpr (Nat.factorial_ne_zero _) + rw [div_eq_one_iff_eq hfac] at hsum + exact_mod_cast hsum + +/-- The factorial is at most the square of the dimension sum. -/ +theorem SchurPackage.factorial_le_sq_sum_dim (P : SchurPackage.{u}) + (n : ℕ) : + (n.factorial : ℝ) ≤ + ((∑ μ : Shape n, P.dim μ.val : ℕ) : ℝ) ^ 2 := by + have h1 := P.sum_dim_sq_eq n + have h2 : (∑ μ : Shape n, P.dim μ.val ^ 2) ≤ + (∑ μ : Shape n, P.dim μ.val) ^ 2 := + Finset.sum_sq_le_sq_sum_of_nonneg fun _ _ => Nat.zero_le _ + rw [h1] at h2 + exact_mod_cast h2 + +/-- **The regular-representation dimension bound**: the dimensions +of the shapes of size `n` sum to at least `√(n!)`. -/ +theorem SchurPackage.sqrt_factorial_le_sum_dim (P : SchurPackage.{u}) + (n : ℕ) : + Real.sqrt n.factorial ≤ + ((∑ μ : Shape n, P.dim μ.val : ℕ) : ℝ) := by + have h2 := Real.sqrt_le_sqrt (P.factorial_le_sq_sum_dim n) + rwa [Real.sqrt_sq (Nat.cast_nonneg _)] at h2 + +end RegularBound + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/RhoBiprod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RhoBiprod.lean new file mode 100644 index 0000000000..dc32863e56 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RhoBiprod.lean @@ -0,0 +1,53 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.RhoTwist + +/-! +# The realization of a biproduct + +Morphisms into a finite biproduct are families of morphisms into +the summands, ℂ-linearly. With the distribution of a tensor over +a biproduct this computes `ρ` on a mixed sum. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {D : Type u} + +/-- **Morphisms into a biproduct are families of morphisms**, as +ℂ-modules. -/ +noncomputable def homBiproductEquiv + [Category.{v} D] [Preadditive D] [HasFiniteBiproducts D] + [CategoryTheory.Linear ℂ D] + {J : Type} [Finite J] (P : D) + (f : J → D) : (P ⟶ ⨁ f) ≃ₗ[ℂ] ∀ j, (P ⟶ f j) where + toFun g := fun j => g ≫ biproduct.π f j + map_add' g h := by + funext j + exact Preadditive.add_comp _ _ _ g h _ + map_smul' r g := by + funext j + exact Linear.smul_comp _ _ _ r g _ + invFun h := biproduct.lift h + left_inv g := by + apply biproduct.hom_ext + intro j + rw [biproduct.lift_π] + right_inv h := by + funext j + change biproduct.lift h ≫ biproduct.π f j = h j + rw [biproduct.lift_π] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/RhoTwist.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RhoTwist.lean new file mode 100644 index 0000000000..edbc1add15 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RhoTwist.lean @@ -0,0 +1,69 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddParity + +/-! +# The realization of a twisted object + +Deligne's `ρ(M) = (Hom(𝟙, M), Hom(1̄, M))` is computed on a twist +by one of the two generators of `⟨1, 1̄⟩`: twisting by the unit +changes nothing, and twisting by the odd line exchanges the two +components. These four identifications are the base cases of the +computation of `ρ` on the free modules of 2.11. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {D : Type u} + +/-- **The even part of a twist by the unit.** -/ +noncomputable def rhoEvenUnit + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [CategoryTheory.Linear ℂ D] + (M : D) : + (𝟙_ D ⟶ M ⊗ 𝟙_ D) ≃ₗ[ℂ] (𝟙_ D ⟶ M) := + Linear.homCongr ℂ (Iso.refl (𝟙_ D)) (ρ_ M) + +/-- **The odd part of a twist by the unit.** -/ +noncomputable def rhoOddUnit + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [CategoryTheory.Linear ℂ D] + (L : OddLine D) (M : D) : + (L.obj ⟶ M ⊗ 𝟙_ D) ≃ₗ[ℂ] (L.obj ⟶ M) := + Linear.homCongr ℂ (Iso.refl L.obj) (ρ_ M) + +/-- **The even part of a twist by the odd line** is the odd part +of the object. -/ +noncomputable def rhoEvenOdd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (M : D) : + (𝟙_ D ⟶ M ⊗ L.obj) ≃ₗ[ℂ] (L.obj ⟶ M) := + oddParitySwap L M + +/-- **The odd part of a twist by the odd line** is the even part +of the object. -/ +noncomputable def rhoOddOdd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (M : D) : + (L.obj ⟶ M ⊗ L.obj) ≃ₗ[ℂ] (𝟙_ D ⟶ M) := + (oddParitySwap L (M ⊗ L.obj)).symm.trans + (Linear.homCongr ℂ (Iso.refl (𝟙_ D)) + ((α_ M L.obj L.obj) ≪≫ whiskerLeftIso M L.sq ≪≫ ρ_ M)) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/RowColIdem.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RowColIdem.lean new file mode 100644 index 0000000000..9d9decc102 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RowColIdem.lean @@ -0,0 +1,708 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos + +/-! +# The one-row and one-column idempotents + +The central idempotent of the single-row shape of size `n` is the +symmetriser of `ℂ[S_n]`, and that of the single-column shape is the +antisymmetriser: `Shape.e P (rowShape n) = symmetriser n` and +`Shape.e P (colShape n) = antisymmetriser n`. + +The route runs through the Frobenius field of the package. The +Schur specialisation of the single-row shape is the complete +homogeneous value `newtonH t n` (a one-by-one Jacobi–Trudi +determinant), and that of the single-column shape is the elementary +value `(-1)^n · newtonH (-t) n` (an `n × n` determinant, evaluated +by clearing with the unitriangular matrix of `newtonHZ (-t)` through +the convolution identity of `NewtonConv.lean`). The cycle-sum +identity of `SchurTheory/CycleSum.lean` expresses the same two +specialisations as the Frobenius pairings of the constant and the +sign character, so the determination theorem of `RegularSum.lean` +pins the package's characters on these shapes; idempotency then +forces dimension one, and the idempotents coincide with the +symmetriser and antisymmetriser on the nose. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv + +universe u + +/-! ### Complete homogeneous values: the zero and alternating +sequences -/ + +/-- The complete homogeneous values of the zero sequence vanish in +positive degree. -/ +theorem newtonH_zero_fun (m : ℕ) : + newtonH (fun _ => (0 : ℂ)) (m + 1) = 0 := by + rw [newtonH] + rw [Finset.sum_congr rfl fun i _ => by + change (fun _ => (0 : ℂ)) (i + 1) * _ = (0 : ℂ) + exact zero_mul _] + rw [Finset.sum_const_zero, mul_zero] + +/-- The complete homogeneous values of the alternating twist of a +sequence are, up to sign, those of its negation. -/ +theorem newtonH_alt (t : ℕ → ℂ) : + ∀ m, newtonH (fun c => (-1) ^ (c + 1) * t c) m = + (-1) ^ m * newtonH (fun c => -t c) m + | 0 => by rw [newtonH, newtonH]; norm_num + | m + 1 => by + rw [newtonH, newtonH] + have hterm : ∀ i ∈ Finset.range (m + 1), + (fun c => (-1 : ℂ) ^ (c + 1) * t c) (i + 1) * + newtonH (fun c => (-1 : ℂ) ^ (c + 1) * t c) (m - i) = + (-1) ^ (m + 1) * + ((fun c => -t c) (i + 1) * + newtonH (fun c => -t c) (m - i)) := by + intro i hi + have him : i ≤ m := by + have := Finset.mem_range.mp hi + omega + rw [newtonH_alt t (m - i)] + have hpow : (-1 : ℂ) ^ (i + 1 + 1) * (-1) ^ (m - i) = + (-1) ^ (m + 1) * (-1) := by + rw [← pow_add, ← pow_succ] + congr 1 + omega + change (-1 : ℂ) ^ (i + 1 + 1) * t (i + 1) * + ((-1) ^ (m - i) * newtonH (fun c => -t c) (m - i)) = + (-1) ^ (m + 1) * + (-t (i + 1) * newtonH (fun c => -t c) (m - i)) + linear_combination + (t (i + 1) * newtonH (fun c => -t c) (m - i)) * hpow + rw [Finset.sum_congr rfl hterm, ← Finset.mul_sum] + ring + decreasing_by exact Nat.lt_succ_of_le (Nat.sub_le m i) + +/-! ### The row lengths of the one-row and one-column shapes -/ + +/-- The single-row shape of size zero has no rows. -/ +theorem rowShape_rowLens_zero : (rowShape 0).val.rowLens = [] := by + have hcol : (rowShape 0).val.colLen 0 = 0 := by + by_contra h + have hmem : ((0, 0) : ℕ × ℕ) ∈ (rowShape 0).val := + YoungDiagram.mem_iff_lt_colLen.mpr (Nat.pos_of_ne_zero h) + rw [YoungDiagram.mem_iff_lt_rowLen, rowShape_rowLen_zero] at hmem + omega + rw [show (rowShape 0).val.rowLens = + (List.range ((rowShape 0).val.colLen 0)).map + (rowShape 0).val.rowLen from rfl, hcol] + rfl + +/-- The single-row shape of positive size has row-length list +`[n]`. -/ +theorem rowShape_rowLens_pos {n : ℕ} (hn : 0 < n) : + (rowShape n).val.rowLens = [n] := by + have hcol : (rowShape n).val.colLen 0 = 1 := by + have hle := rowShape_colLen n + have hmem : ((0, 0) : ℕ × ℕ) ∈ (rowShape n).val := by + rw [YoungDiagram.mem_iff_lt_rowLen, rowShape_rowLen_zero] + exact hn + have := YoungDiagram.mem_iff_lt_colLen.mp hmem + omega + rw [show (rowShape n).val.rowLens = + (List.range ((rowShape n).val.colLen 0)).map + (rowShape n).val.rowLen from rfl, hcol] + rw [List.range_one, List.map_singleton, rowShape_rowLen_zero] + +/-- The Schur specialisation of the single-row shape is the +complete homogeneous value. -/ +theorem diagramSchur_rowShape (n : ℕ) (t : ℕ → ℂ) : + diagramSchur (rowShape n).val t = newtonH t n := by + cases n with + | zero => + rw [diagramSchur, rowShape_rowLens_zero] + rw [show schurDet t [] = Matrix.det (Matrix.of fun i j : Fin 0 => + newtonHZ t ((([] : List ℕ).get i : ℤ) + (j : ℤ) - (i : ℤ))) + from rfl] + rw [Matrix.det_fin_zero, newtonH_zero] + | succ m => + rw [diagramSchur, rowShape_rowLens_pos (Nat.succ_pos m)] + rw [show schurDet t [m + 1] = + Matrix.det (Matrix.of fun i j : Fin 1 => + newtonHZ t ((([m + 1] : List ℕ).get i : ℤ) + + (j : ℤ) - (i : ℤ))) from rfl] + rw [Matrix.det_fin_one, Matrix.of_apply] + norm_num + rw [show ((m : ℤ) + 1) = ((m + 1 : ℕ) : ℤ) by push_cast; ring, + newtonHZ_natCast] + +/-- The first column of the single-column shape has length `n`. -/ +theorem colShape_colLen_zero (n : ℕ) : + (colShape n).val.colLen 0 = n := by + rcases Nat.eq_zero_or_pos n with rfl | hn + · by_contra h + have hmem : ((0, 0) : ℕ × ℕ) ∈ (colShape 0).val := + YoungDiagram.mem_iff_lt_colLen.mpr (Nat.pos_of_ne_zero h) + rw [YoungDiagram.mem_iff_lt_rowLen, + colShape_rowLen_le 0 (Nat.zero_le _)] at hmem + omega + · have h1 : n - 1 < (colShape n).val.colLen 0 := by + have hmem : ((n - 1, 0) : ℕ × ℕ) ∈ (colShape n).val := by + rw [YoungDiagram.mem_iff_lt_rowLen, + colShape_rowLen_lt n (by omega)] + omega + exact YoungDiagram.mem_iff_lt_colLen.mp hmem + have h2 : ¬ n < (colShape n).val.colLen 0 := by + intro h + have hmem := YoungDiagram.mem_iff_lt_colLen.mpr h + rw [YoungDiagram.mem_iff_lt_rowLen, + colShape_rowLen_le n le_rfl] at hmem + omega + omega + +/-- The single-column shape has row-length list `[1, …, 1]`. -/ +theorem colShape_rowLens (n : ℕ) : + (colShape n).val.rowLens = List.replicate n 1 := by + rw [show (colShape n).val.rowLens = + (List.range ((colShape n).val.colLen 0)).map + (colShape n).val.rowLen from rfl, colShape_colLen_zero] + refine List.ext_getElem (by simp) ?_ + intro i h1 h2 + simp only [List.getElem_map, List.getElem_range, + List.getElem_replicate] + exact colShape_rowLen_lt n (by simpa using h1) + +/-! ### The single-column Jacobi–Trudi determinant -/ + +/-- The Jacobi–Trudi matrix of the single-column shape of size +`n`. -/ +noncomputable def colJTMat (t : ℕ → ℂ) (n : ℕ) : + Matrix (Fin n) (Fin n) ℂ := + Matrix.of fun i j => newtonHZ t (1 + (j : ℤ) - (i : ℤ)) + +/-- The Schur specialisation of the single-column shape is the +determinant of `colJTMat`. -/ +theorem schurDet_replicate_one (t : ℕ → ℂ) (n : ℕ) : + schurDet t (List.replicate n 1) = (colJTMat t n).det := by + have hlen : (List.replicate n (1 : ℕ)).length = n := + List.length_replicate .. + calc schurDet t (List.replicate n 1) + = ((colJTMat t n).submatrix + (finCongr hlen) (finCongr hlen)).det := by + rw [schurDet] + congr 1 + ext i j + rw [Matrix.of_apply, Matrix.submatrix_apply] + rw [show (colJTMat t n) (finCongr hlen i) (finCongr hlen j) = + newtonHZ t (1 + ((finCongr hlen j : ℕ) : ℤ) - + ((finCongr hlen i : ℕ) : ℤ)) from rfl] + have hget : (List.replicate n (1 : ℕ)).get i = 1 := by + simp [List.get_eq_getElem] + rw [hget] + norm_num + _ = (colJTMat t n).det := Matrix.det_submatrix_equiv_self _ _ + +/-- The unitriangular convolution matrix of the negated +sequence. -/ +noncomputable def negHMat (t : ℕ → ℂ) (n : ℕ) : + Matrix (Fin n) (Fin n) ℂ := + Matrix.of fun i j => newtonHZ (fun c => -t c) ((j : ℤ) - (i : ℤ)) + +/-- The convolution matrix is unitriangular: determinant one. -/ +theorem negHMat_det (t : ℕ → ℂ) (n : ℕ) : (negHMat t n).det = 1 := by + have htri : (negHMat t n).BlockTriangular id := by + intro i j hij + change newtonHZ (fun c => -t c) ((j : ℤ) - (i : ℤ)) = 0 + refine newtonHZ_neg _ _ ?_ + have : (j : ℕ) < (i : ℕ) := hij + omega + rw [Matrix.det_of_isUpperTriangular htri] + refine Finset.prod_eq_one fun i _ => ?_ + change newtonHZ (fun c => -t c) ((i : ℤ) - (i : ℤ)) = 1 + rw [sub_self, show (0 : ℤ) = ((0 : ℕ) : ℤ) from rfl, + newtonHZ_natCast, newtonH_zero] + +/-- The alternating `h`-convolution vanishes: the guarded +convolution sum of `newtonHZ t` against `newtonHZ (-t)` along a row +of positive index reduces to a Kronecker delta. -/ +private theorem conv_sum_pos (t : ℕ → ℂ) {n ik kk : ℕ} + (hik : 0 < ik) (hkn : kk < n) : + ∑ j ∈ Finset.range n, + newtonHZ t (1 + (j : ℤ) - (ik : ℤ)) * + newtonHZ (fun c => -t c) ((kk : ℤ) - (j : ℤ)) = + if kk + 1 = ik then 1 else 0 := by + rcases Nat.lt_or_ge (kk + 1) ik with hB | hA + · -- below the surviving band every term vanishes + rw [ite_eq_right (by omega)] + refine Finset.sum_eq_zero fun j hj => ?_ + rcases Nat.lt_or_ge (j + 1) ik with hj' | hj' + · rw [newtonHZ_neg t (1 + (j : ℤ) - (ik : ℤ)) (by omega), + zero_mul] + · rw [newtonHZ_neg (fun c => -t c) ((kk : ℤ) - (j : ℤ)) + (by omega), mul_zero] + · -- the full antidiagonal convolution + have h3 : ∀ d ∈ Finset.range (n - (ik - 1)), + newtonHZ t (1 + ((ik - 1 + d : ℕ) : ℤ) - (ik : ℤ)) * + newtonHZ (fun c => -t c) + ((kk : ℤ) - ((ik - 1 + d : ℕ) : ℤ)) = + newtonHZ t (d : ℤ) * + newtonHZ (fun c => -t c) + (((kk + 1 - ik : ℕ) : ℤ) - (d : ℤ)) := by + intro d _ + have e1 : 1 + ((ik - 1 + d : ℕ) : ℤ) - (ik : ℤ) = (d : ℤ) := by + omega + have e2 : (kk : ℤ) - ((ik - 1 + d : ℕ) : ℤ) = + ((kk + 1 - ik : ℕ) : ℤ) - (d : ℤ) := by + omega + rw [e1, e2] + have h5 : ∀ d ∈ Finset.range (kk + 1 - ik + 1), + newtonHZ t (d : ℤ) * newtonHZ (fun c => -t c) + (((kk + 1 - ik : ℕ) : ℤ) - (d : ℤ)) = + newtonH t d * newtonH (fun c => -t c) (kk + 1 - ik - d) := by + intro d hd + rw [Finset.mem_range] at hd + rw [newtonHZ_natCast, show ((kk + 1 - ik : ℕ) : ℤ) - (d : ℤ) = + ((kk + 1 - ik - d : ℕ) : ℤ) by omega, newtonHZ_natCast] + calc ∑ j ∈ Finset.range n, + newtonHZ t (1 + (j : ℤ) - (ik : ℤ)) * + newtonHZ (fun c => -t c) ((kk : ℤ) - (j : ℤ)) + = ∑ j ∈ Finset.Ico (ik - 1) n, + newtonHZ t (1 + (j : ℤ) - (ik : ℤ)) * + newtonHZ (fun c => -t c) ((kk : ℤ) - (j : ℤ)) := by + refine (Finset.sum_subset ?_ ?_).symm + · intro x hx + rw [Finset.mem_Ico] at hx + exact Finset.mem_range.mpr hx.2 + · intro x hx hnot + rw [Finset.mem_range] at hx + have hxlt : x < ik - 1 := by + rw [Finset.mem_Ico] at hnot + omega + rw [newtonHZ_neg t (1 + (x : ℤ) - (ik : ℤ)) (by omega), + zero_mul] + _ = ∑ d ∈ Finset.range (n - (ik - 1)), + newtonHZ t (1 + ((ik - 1 + d : ℕ) : ℤ) - (ik : ℤ)) * + newtonHZ (fun c => -t c) + ((kk : ℤ) - ((ik - 1 + d : ℕ) : ℤ)) := + Finset.sum_Ico_eq_sum_range _ _ _ + _ = ∑ d ∈ Finset.range (n - (ik - 1)), + newtonHZ t (d : ℤ) * + newtonHZ (fun c => -t c) + (((kk + 1 - ik : ℕ) : ℤ) - (d : ℤ)) := + Finset.sum_congr rfl h3 + _ = ∑ d ∈ Finset.range (kk + 1 - ik + 1), + newtonHZ t (d : ℤ) * + newtonHZ (fun c => -t c) + (((kk + 1 - ik : ℕ) : ℤ) - (d : ℤ)) := by + have hsub : Finset.range (kk + 1 - ik + 1) ⊆ + Finset.range (n - (ik - 1)) := + Finset.range_subset_range.mpr (by omega) + refine (Finset.sum_subset hsub ?_).symm + intro x _ hnot + rw [Finset.mem_range] at hnot + rw [newtonHZ_neg (fun c => -t c) + (((kk + 1 - ik : ℕ) : ℤ) - (x : ℤ)) (by omega), + mul_zero] + _ = ∑ d ∈ Finset.range (kk + 1 - ik + 1), + newtonH t d * + newtonH (fun c => -t c) (kk + 1 - ik - d) := + Finset.sum_congr rfl h5 + _ = newtonH (fun c => t c + -t c) (kk + 1 - ik) := by + have h6 := newtonH_add t (fun c => -t c) (kk + 1 - ik) + rw [Finset.Nat.sum_antidiagonal_eq_sum_range_succ_mk] at h6 + exact h6.symm + _ = if kk + 1 = ik then 1 else 0 := by + rw [show (fun c => t c + -t c) = (fun _ => (0 : ℂ)) from + funext fun c => by ring] + rcases Nat.eq_zero_or_pos (kk + 1 - ik) with hz | hp + · rw [hz, newtonH_zero, ite_eq_left (by omega)] + · obtain ⟨l, hl⟩ : ∃ l, kk + 1 - ik = l + 1 := + ⟨kk - ik, by omega⟩ + rw [hl, newtonH_zero_fun, ite_eq_right (by omega)] + +/-- The top-row convolution sum: the missing degree-zero term +leaves the negated elementary value. -/ +private theorem conv_sum_zero (t : ℕ → ℂ) {n kk : ℕ} + (hkn : kk < n) : + ∑ j ∈ Finset.range n, + newtonHZ t (1 + (j : ℤ)) * + newtonHZ (fun c => -t c) ((kk : ℤ) - (j : ℤ)) = + -newtonH (fun c => -t c) (kk + 1) := by + have hstep : ∀ j ∈ Finset.range (kk + 1), + newtonH t (j + 1) * newtonH (fun c => -t c) (kk - j) = + (fun d => newtonH t d * + newtonH (fun c => -t c) (kk + 1 - d)) (j + 1) := by + intro j _ + change _ = newtonH t (j + 1) * + newtonH (fun c => -t c) (kk + 1 - (j + 1)) + rw [Nat.succ_sub_succ] + have hconv : ∑ d ∈ Finset.range (kk + 1 + 1), + newtonH t d * newtonH (fun c => -t c) (kk + 1 - d) = + newtonH (fun c => t c + -t c) (kk + 1) := by + have h6 := newtonH_add t (fun c => -t c) (kk + 1) + rw [Finset.Nat.sum_antidiagonal_eq_sum_range_succ_mk] at h6 + exact h6.symm + have hzero : newtonH (fun c => t c + -t c) (kk + 1) = 0 := by + rw [show (fun c => t c + -t c) = (fun _ => (0 : ℂ)) from + funext fun c => by ring] + exact newtonH_zero_fun kk + have hsucc := Finset.sum_range_succ' + (fun d => newtonH t d * newtonH (fun c => -t c) (kk + 1 - d)) + (kk + 1) + have h0 : (fun d => newtonH t d * + newtonH (fun c => -t c) (kk + 1 - d)) 0 = + newtonH (fun c => -t c) (kk + 1) := by + change newtonH t 0 * newtonH (fun c => -t c) (kk + 1 - 0) = _ + rw [newtonH_zero, one_mul, Nat.sub_zero] + calc ∑ j ∈ Finset.range n, + newtonHZ t (1 + (j : ℤ)) * + newtonHZ (fun c => -t c) ((kk : ℤ) - (j : ℤ)) + = ∑ j ∈ Finset.range (kk + 1), + newtonHZ t (1 + (j : ℤ)) * + newtonHZ (fun c => -t c) ((kk : ℤ) - (j : ℤ)) := by + have hsub : Finset.range (kk + 1) ⊆ Finset.range n := + Finset.range_subset_range.mpr (by omega) + refine (Finset.sum_subset hsub ?_).symm + intro x _ hnot + rw [Finset.mem_range] at hnot + rw [newtonHZ_neg (fun c => -t c) + ((kk : ℤ) - (x : ℤ)) (by omega), mul_zero] + _ = ∑ j ∈ Finset.range (kk + 1), + newtonH t (j + 1) * + newtonH (fun c => -t c) (kk - j) := by + refine Finset.sum_congr rfl fun j hj => ?_ + rw [Finset.mem_range] at hj + rw [show 1 + (j : ℤ) = ((j + 1 : ℕ) : ℤ) by omega, + newtonHZ_natCast, + show (kk : ℤ) - (j : ℤ) = ((kk - j : ℕ) : ℤ) by omega, + newtonHZ_natCast] + _ = ∑ j ∈ Finset.range (kk + 1), + (fun d => newtonH t d * + newtonH (fun c => -t c) (kk + 1 - d)) (j + 1) := + Finset.sum_congr rfl hstep + _ = -newtonH (fun c => -t c) (kk + 1) := by + have hs : (0 : ℂ) = ∑ j ∈ Finset.range (kk + 1), + (fun d => newtonH t d * + newtonH (fun c => -t c) (kk + 1 - d)) (j + 1) + + newtonH (fun c => -t c) (kk + 1) := by + rw [← h0, ← hsucc, hconv, hzero] + linear_combination -hs + +/-- The positive-index rows of the cleared Jacobi–Trudi matrix form +a shifted identity. -/ +theorem colJT_mul_negH_pos (t : ℕ → ℂ) {n : ℕ} (i k : Fin n) + (hi : 0 < (i : ℕ)) : + (colJTMat t n * negHMat t n) i k = + if (k : ℕ) + 1 = (i : ℕ) then 1 else 0 := by + rw [Matrix.mul_apply] + calc ∑ j, colJTMat t n i j * negHMat t n j k + = ∑ j ∈ Finset.range n, + newtonHZ t (1 + (j : ℤ) - ((i : ℕ) : ℤ)) * + newtonHZ (fun c => -t c) (((k : ℕ) : ℤ) - (j : ℤ)) := + Fin.sum_univ_eq_sum_range + (fun j => newtonHZ t (1 + (j : ℤ) - ((i : ℕ) : ℤ)) * + newtonHZ (fun c => -t c) (((k : ℕ) : ℤ) - (j : ℤ))) n + _ = _ := conv_sum_pos t hi k.isLt + +/-- The top row of the cleared Jacobi–Trudi matrix carries the +negated elementary values. -/ +theorem colJT_mul_negH_zero (t : ℕ → ℂ) {n : ℕ} (i k : Fin n) + (hi : (i : ℕ) = 0) : + (colJTMat t n * negHMat t n) i k = + -newtonH (fun c => -t c) ((k : ℕ) + 1) := by + rw [Matrix.mul_apply] + calc ∑ j, colJTMat t n i j * negHMat t n j k + = ∑ j ∈ Finset.range n, + newtonHZ t (1 + (j : ℤ) - ((i : ℕ) : ℤ)) * + newtonHZ (fun c => -t c) (((k : ℕ) : ℤ) - (j : ℤ)) := + Fin.sum_univ_eq_sum_range + (fun j => newtonHZ t (1 + (j : ℤ) - ((i : ℕ) : ℤ)) * + newtonHZ (fun c => -t c) (((k : ℕ) : ℤ) - (j : ℤ))) n + _ = ∑ j ∈ Finset.range n, + newtonHZ t (1 + (j : ℤ)) * + newtonHZ (fun c => -t c) (((k : ℕ) : ℤ) - (j : ℤ)) := by + simp only [hi, Nat.cast_zero, sub_zero] + _ = _ := conv_sum_zero t k.isLt + +/-- **The single-column determinant**: the Jacobi–Trudi determinant +of the one-column shape is the elementary value +`(-1)^n · newtonH (-t) n`. -/ +theorem colJTMat_det (t : ℕ → ℂ) (n : ℕ) : + (colJTMat t n).det = (-1) ^ n * newtonH (fun c => -t c) n := by + cases n with + | zero => + rw [Matrix.det_fin_zero, newtonH_zero] + norm_num + | succ m => + have hdetP : (colJTMat t (m + 1) * negHMat t (m + 1)).det = + (colJTMat t (m + 1)).det := by + rw [Matrix.det_mul, negHMat_det, mul_one] + have htri : ((colJTMat t (m + 1) * negHMat t (m + 1)).submatrix + (finRotate (m + 1)) id).BlockTriangular + OrderDual.toDual := by + intro a b hab + have hab' : a < b := OrderDual.toDual_lt_toDual.mp hab + have hne : a ≠ Fin.last m := by + intro h + rw [h] at hab' + exact absurd hab' (not_lt.mpr (Fin.le_last b)) + rw [Matrix.submatrix_apply, id_eq] + rw [colJT_mul_negH_pos t _ _ (by + rw [coe_finRotate_of_ne_last hne] + omega)] + rw [ite_eq_right (by + rw [coe_finRotate_of_ne_last hne] + have : (a : ℕ) < (b : ℕ) := hab' + omega)] + have hdiag : ((colJTMat t (m + 1) * negHMat t (m + 1)).submatrix + (finRotate (m + 1)) id).det = + -newtonH (fun c => -t c) (m + 1) := by + rw [Matrix.det_of_isLowerTriangular _ htri] + rw [Fin.prod_univ_castSucc] + have hone : ∀ i : Fin m, + ((colJTMat t (m + 1) * negHMat t (m + 1)).submatrix + (finRotate (m + 1)) id) i.castSucc i.castSucc = 1 := by + intro i + have hne : i.castSucc ≠ Fin.last m := + (Fin.castSucc_lt_last i).ne + rw [Matrix.submatrix_apply, id_eq] + rw [colJT_mul_negH_pos t _ _ (by + rw [coe_finRotate_of_ne_last hne] + omega)] + rw [ite_eq_left (by rw [coe_finRotate_of_ne_last hne])] + rw [Finset.prod_congr rfl fun i _ => hone i, + Finset.prod_const_one, one_mul] + rw [Matrix.submatrix_apply, id_eq, finRotate_last] + rw [colJT_mul_negH_zero t _ _ (by simp), Fin.val_last] + have hperm := Matrix.det_permute (finRotate (m + 1)) + (colJTMat t (m + 1) * negHMat t (m + 1)) + rw [hdiag, hdetP, sign_finRotate] at hperm + have hfin : (-1 : ℂ) ^ m * (colJTMat t (m + 1)).det = + -newtonH (fun c => -t c) (m + 1) := by + rw [hperm, Nat.add_sub_cancel] + push_cast + ring + have hsq : (-1 : ℂ) ^ m * (-1 : ℂ) ^ m = 1 := by + rw [← pow_add] + exact Even.neg_one_pow ⟨m, rfl⟩ + calc (colJTMat t (m + 1)).det + = ((-1 : ℂ) ^ m * (-1 : ℂ) ^ m) * + (colJTMat t (m + 1)).det := by + rw [hsq, one_mul] + _ = (-1 : ℂ) ^ m * + ((-1 : ℂ) ^ m * (colJTMat t (m + 1)).det) := by + ring + _ = (-1 : ℂ) ^ m * (-newtonH (fun c => -t c) (m + 1)) := by + rw [hfin] + _ = (-1 : ℂ) ^ (m + 1) * newtonH (fun c => -t c) (m + 1) := by + ring + +/-- The Schur specialisation of the single-column shape is the +elementary value. -/ +theorem diagramSchur_colShape (n : ℕ) (t : ℕ → ℂ) : + diagramSchur (colShape n).val t = + (-1) ^ n * newtonH (fun c => -t c) n := by + rw [diagramSchur, colShape_rowLens, schurDet_replicate_one, + colJTMat_det] + +/-! ### The signed cycle sum -/ + +/-- The product of alternating signs over a multiset. -/ +private theorem prod_map_neg_one_pow (m : Multiset ℕ) : + (m.map fun c => (-1 : ℂ) ^ (c + 1)).prod = + (-1) ^ (m.sum + Multiset.card m) := by + induction m using Multiset.induction_on with + | empty => simp + | cons a s ih => + rw [Multiset.map_cons, Multiset.prod_cons, ih, + Multiset.sum_cons, Multiset.card_cons, ← pow_add] + congr 1 + omega + +/-- The sign of a permutation times its completed cycle product is +the completed cycle product of the alternating twist. -/ +theorem sign_mul_cycleProd (t : ℕ → ℂ) {n : ℕ} + (π : Equiv.Perm (Fin n)) : + ((Equiv.Perm.sign π : ℤ) : ℂ) * cycleProd t π = + cycleProd (fun c => (-1) ^ (c + 1) * t c) π := by + change ((Equiv.Perm.sign π : ℤ) : ℂ) * + ((π.cycleType.map t).prod * t 1 ^ (n - π.cycleType.sum)) = + (π.cycleType.map fun c => (-1 : ℂ) ^ (c + 1) * t c).prod * + ((-1 : ℂ) ^ (1 + 1) * t 1) ^ (n - π.cycleType.sum) + rw [Multiset.prod_map_mul, prod_map_neg_one_pow, + Equiv.Perm.sign_of_cycleType] + push_cast + ring + +/-- **The signed cycle sum**: the sign-weighted completed cycle +products of all permutations sum to `n!` times the elementary +value. -/ +theorem signed_cycleSum (t : ℕ → ℂ) (n : ℕ) : + ∑ π : Equiv.Perm (Fin n), + ((Equiv.Perm.sign π : ℤ) : ℂ) * cycleProd t π = + (n.factorial : ℂ) * + ((-1) ^ n * newtonH (fun c => -t c) n) := by + rw [Finset.sum_congr rfl fun π _ => sign_mul_cycleProd t π] + rw [cycleSum_eq, newtonH_alt] + +/-! ### Pinning the characters of the one-row and one-column +shapes -/ + +/-- A package character agreeing with a class function in all +Frobenius pairings is that class function. -/ +theorem SchurPackage.char_eq_of_frobenius + (P : SchurPackage.{u}) (μ : YoungDiagram) + (χ : Equiv.Perm (Fin μ.card) → ℂ) + (hconj : ∀ g c : Equiv.Perm (Fin μ.card), χ (c * g * c⁻¹) = χ g) + (hsum : ∀ t : ℕ → ℂ, + ∑ π : Equiv.Perm (Fin μ.card), χ π * cycleProd t π = + (μ.card.factorial : ℂ) * diagramSchur μ t) + (π : Equiv.Perm (Fin μ.card)) : + P.char μ π = χ π := by + have hconj' : ∀ g c : Equiv.Perm (Fin μ.card), + P.char μ (c * g * c⁻¹) - χ (c * g * c⁻¹) = + P.char μ g - χ g := by + intro g c + rw [P.char_conj μ g c, hconj g c] + have hvan : ∀ t : ℕ → ℂ, + ∑ π' : Equiv.Perm (Fin μ.card), + (P.char μ π' - χ π') * cycleProd t π' = 0 := by + intro t + have hne : ((μ.card.factorial : ℕ) : ℂ) ≠ 0 := + Nat.cast_ne_zero.mpr (Nat.factorial_ne_zero _) + have h1 : ∑ π' : Equiv.Perm (Fin μ.card), + P.char μ π' * cycleProd t π' = + (μ.card.factorial : ℂ) * diagramSchur μ t := by + calc ∑ π' : Equiv.Perm (Fin μ.card), + P.char μ π' * cycleProd t π' + = (μ.card.factorial : ℂ) * + (((μ.card.factorial : ℂ))⁻¹ * + ∑ π' : Equiv.Perm (Fin μ.card), + P.char μ π' * cycleProd t π') := by + rw [← mul_assoc, mul_inv_cancel₀ hne, one_mul] + _ = (μ.card.factorial : ℂ) * diagramSchur μ t := by + rw [show ((μ.card.factorial : ℂ))⁻¹ * + ∑ π' : Equiv.Perm (Fin μ.card), + P.char μ π' * cycleProd t π' = + diagramSchur μ t from P.frobenius μ t] + rw [Finset.sum_congr rfl fun π' _ => + sub_mul (P.char μ π') (χ π') (cycleProd t π')] + rw [Finset.sum_sub_distrib, h1, hsum t, sub_self] + exact sub_eq_zero.mp (classFun_eq_zero_of_cycleProd + (fun π' => P.char μ π' - χ π') hconj' hvan π) + +/-- The character of the single-row shape is constant one. -/ +theorem SchurPackage.char_rowShape (P : SchurPackage.{u}) (n : ℕ) + (π : Equiv.Perm (Fin (rowShape n).val.card)) : + P.char (rowShape n).val π = 1 := by + refine P.char_eq_of_frobenius (rowShape n).val (fun _ => 1) + (fun _ _ => rfl) ?_ π + intro t + show ∑ π' : Equiv.Perm (Fin (rowShape n).val.card), + (1 : ℂ) * cycleProd t π' = _ + simp only [one_mul] + rw [cycleSum_eq, diagramSchur_rowShape, (rowShape n).prop] + +/-- The character of the single-column shape is the sign. -/ +theorem SchurPackage.char_colShape (P : SchurPackage.{u}) (n : ℕ) + (π : Equiv.Perm (Fin (colShape n).val.card)) : + P.char (colShape n).val π = + ((Equiv.Perm.sign π : ℤ) : ℂ) := by + refine P.char_eq_of_frobenius (colShape n).val + (fun σ => ((Equiv.Perm.sign σ : ℤ) : ℂ)) ?_ ?_ π + · intro g c + have hs : Equiv.Perm.sign (c * g * c⁻¹) = Equiv.Perm.sign g := by + rw [map_mul, map_mul, map_inv, + mul_comm (Equiv.Perm.sign c) (Equiv.Perm.sign g), + mul_assoc, mul_inv_cancel, mul_one] + rw [hs] + · intro t + show ∑ π' : Equiv.Perm (Fin (colShape n).val.card), + ((Equiv.Perm.sign π' : ℤ) : ℂ) * cycleProd t π' = _ + rw [signed_cycleSum, diagramSchur_colShape, (colShape n).prop] + +/-! ### The idempotents -/ + +/-- The single-row dimension is one. -/ +theorem SchurPackage.dim_rowShape (P : SchurPackage.{u}) (n : ℕ) : + P.dim (rowShape n).val = 1 := by + have h := P.char_one (rowShape n).val + rw [P.char_rowShape n 1] at h + exact_mod_cast h.symm + +/-- The single-column dimension is one. -/ +theorem SchurPackage.dim_colShape (P : SchurPackage.{u}) (n : ℕ) : + P.dim (colShape n).val = 1 := by + have h := P.char_one (colShape n).val + rw [P.char_colShape n 1, map_one] at h + have h1 : ((P.dim (colShape n).val : ℕ) : ℂ) = + ((1 : ℕ) : ℂ) := by + rw [← h] + norm_num + exact Nat.cast_injective h1 + +/-- `charIdempotent` at dimension one and the constant character: +the symmetriser. -/ +theorem charIdempotent_const_one (n : ℕ) : + charIdempotent (n := n) 1 (fun _ => (1 : ℂ)) = + symmetriser n := by + rw [charIdempotent, symmetriser] + congr 1 + · rw [Nat.cast_one, one_div] + · refine Finset.sum_congr rfl fun π _ => ?_ + show (1 : ℂ) • MonoidAlgebra.of ℂ (Equiv.Perm (Fin n)) π = + MonoidAlgebra.single π (1 : ℂ) + rw [one_smul, MonoidAlgebra.of_apply] + +/-- `charIdempotent` at dimension one and the sign character: the +antisymmetriser. -/ +theorem charIdempotent_sign (n : ℕ) : + charIdempotent (n := n) 1 + (fun π => ((Equiv.Perm.sign π : ℤ) : ℂ)) = + antisymmetriser n := by + rw [charIdempotent, antisymmetriser] + congr 1 + · rw [Nat.cast_one, one_div] + · refine Finset.sum_congr rfl fun π _ => ?_ + show ((Equiv.Perm.sign π : ℤ) : ℂ) • + MonoidAlgebra.of ℂ (Equiv.Perm (Fin n)) π = + MonoidAlgebra.single π ((Equiv.Perm.sign π : ℤ) : ℂ) + rw [MonoidAlgebra.of_apply, MonoidAlgebra.smul_single', mul_one] + +/-- The package idempotent of the single-row shape is the +symmetriser, at the native size. -/ +theorem SchurPackage.e_rowShape (P : SchurPackage.{u}) (n : ℕ) : + P.e (rowShape n).val = symmetriser (rowShape n).val.card := by + rw [SchurPackage.e_def, P.dim_rowShape n, + show P.char (rowShape n).val = (fun _ => (1 : ℂ)) from + funext (P.char_rowShape n), + charIdempotent_const_one] + +/-- The package idempotent of the single-column shape is the +antisymmetriser, at the native size. -/ +theorem SchurPackage.e_colShape (P : SchurPackage.{u}) (n : ℕ) : + P.e (colShape n).val = + antisymmetriser (colShape n).val.card := by + rw [SchurPackage.e_def, P.dim_colShape n, + show P.char (colShape n).val = + (fun π => ((Equiv.Perm.sign π : ℤ) : ℂ)) from + funext (P.char_colShape n), + charIdempotent_sign] + +/-- Recasting the symmetriser along an equality of sizes. -/ +theorem symCast_symmetriser {m n : ℕ} (h : m = n) : + symCast (le_of_eq h) (symmetriser m) = symmetriser n := by + subst h + exact symCast_le_refl _ _ + +/-- Recasting the antisymmetriser along an equality of sizes. -/ +theorem symCast_antisymmetriser {m n : ℕ} (h : m = n) : + symCast (le_of_eq h) (antisymmetriser m) = antisymmetriser n := by + subst h + exact symCast_le_refl _ _ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichMerge.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichMerge.lean new file mode 100644 index 0000000000..afe3a5263c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichMerge.lean @@ -0,0 +1,156 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAssoc +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowDescent +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistPow + +/-! +# Merging the sandwich tower into a power pair + +Each stage of the sandwich tower reassembles, up to associators +and braidings of the module tensor product, into a pair of module +powers: the stage `sandwichTower A M M' (k + 1)` carries `k + 2` +letters `M` interleaved with `k + 1` letters `M'`, and the +shuffle collects them into `modPowMod A M.X (k + 1)` (carrier +`modPow A M.X (k + 2)`, so `k + 2` letters `M`) tensored with +`modPowMod A M'.X k` (carrier `modPow A M'.X (k + 1)`, so `k + 1` +letters `M'`). + +* `modTensorSwapModIso`: the braiding as a module isomorphism. +* `leftMergeModIso`: absorb a module into its own power from the + left. +* `sandwichMergeModIso`: the merge, as modules. +* `sandwichMergeIso`: the merge at the carrier level. +* `isZero_sandwichTower_of_isZero_modPow`: vanishing of the power + descends to every tower stage. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- The braiding of the module tensor product, as an isomorphism +of modules. -/ +noncomputable def modTensorSwapModIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] + (P Q : Mod D A) : + modTensorMod A P Q ≅ modTensorMod A Q P where + hom := modTensorSwapMod A P Q + inv := modTensorSwapMod A Q P + hom_inv_id := modTensorSwapMod_modTensorSwapMod A P Q + inv_hom_id := modTensorSwapMod_modTensorSwapMod A Q P + +/-- **The left absorption**: a module merges into its own power +from the left, through the braiding, the bottom-stage +identification and the adjacent merge. -/ +noncomputable def leftMergeModIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] + (N : Mod D A) (n : ℕ) : + modTensorMod A N (modPowMod A N.X n) ≅ + modPowMod A N.X (n + 1) := + modTensorSwapModIso A N (modPowMod A N.X n) ≪≫ + modTensorMapIso A (Iso.refl (modPowMod A N.X n)) + (modPowModZeroIso A N).symm ≪≫ + powMergeModIso A N.X n + +/-- **The sandwich merge**: the `(k + 1)`-st tower stage carries +`k + 2` letters `M` and `k + 1` letters `M'`, and reassembles as +the module tensor product of the corresponding module powers. -/ +noncomputable def sandwichMergeModIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) : + (k : ℕ) → + sandwichTower A M M' (k + 1) ≅ + modTensorMod A (modPowMod A M.X (k + 1)) + (modPowMod A M'.X k) + | 0 => + modTensorSwapModIso A (modTensorMod A M M') M ≪≫ + (modTensorAssocModIso A M M M').symm ≪≫ + modTensorMapIso A + (modTensorMapIso A (Iso.refl M) + (modPowModZeroIso A M).symm ≪≫ + leftMergeModIso A M 0) + (modPowModZeroIso A M').symm + | (k + 1) => + modTensorMapIso A (Iso.refl (modTensorMod A M M')) + (sandwichMergeModIso A M M' k) ≪≫ + modTensorAssocModIso A M M' + (modTensorMod A (modPowMod A M.X (k + 1)) + (modPowMod A M'.X k)) ≪≫ + modTensorMapIso A (Iso.refl M) + ((modTensorAssocModIso A M' (modPowMod A M.X (k + 1)) + (modPowMod A M'.X k)).symm ≪≫ + modTensorMapIso A + (modTensorSwapModIso A M' (modPowMod A M.X (k + 1))) + (Iso.refl (modPowMod A M'.X k)) ≪≫ + modTensorAssocModIso A (modPowMod A M.X (k + 1)) M' + (modPowMod A M'.X k)) ≪≫ + (modTensorAssocModIso A M (modPowMod A M.X (k + 1)) + (modTensorMod A M' (modPowMod A M'.X k))).symm ≪≫ + modTensorMapIso A (leftMergeModIso A M (k + 1)) + (leftMergeModIso A M' k) + +/-- **The sandwich merge at the carrier level**: the carrier of +the `(k + 1)`-st tower stage is the relative tensor product of +`modPow A M.X (k + 2)` with `modPow A M'.X (k + 1)`, presented +through the bundled module powers. -/ +noncomputable def sandwichMergeIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (k : ℕ) : + (sandwichTower A M M' (k + 1)).X ≅ + modTensor A (modPowMod A M.X (k + 1)) + (modPowMod A M'.X k) where + hom := (sandwichMergeModIso A M M' k).hom.hom + inv := (sandwichMergeModIso A M M' k).inv.hom + hom_inv_id := congrArg Mod.Hom.hom + (sandwichMergeModIso A M M' k).hom_inv_id + inv_hom_id := congrArg Mod.Hom.hom + (sandwichMergeModIso A M M' k).inv_hom_id + +/-- **Vanishing descends the tower**: if the `(k + 2)`-nd relative +power of the module vanishes, so does the carrier of the +`(k + 1)`-st sandwich tower stage. -/ +theorem isZero_sandwichTower_of_isZero_modPow + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (k : ℕ) + (h : IsZero (modPow A M.X (k + 2))) : + IsZero ((sandwichTower A M M' (k + 1)).X) := + (isZero_modTensor_left A (modPowMod A M.X (k + 1)) + (modPowMod A M'.X k) h).of_iso + (sandwichMergeIso A M M' k) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichRetract.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichRetract.lean new file mode 100644 index 0000000000..3c0b274051 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichRetract.lean @@ -0,0 +1,200 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle + +/-! +# The sandwich retract legs + +The insertion and contraction making a module a retract of its +double-dual sandwich, built from bundled pieces: the unit +collapses of the relative tensor as module isomorphisms, the +bundled copairing and pairing, and the associator. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- The left unit collapse intertwines the actions. -/ +theorem modTensorUnitLeft_act + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (N : Mod D A) : + modTensorAct A (regularMod A) N ≫ + (modTensorUnitLeft A N).hom = + (A ◁ (modTensorUnitLeft A N).hom) ≫ actLeft A N.X := by + apply modTensor_whisker_hom_ext A (regularMod A) N A + have hπ : modTensorπ A (regularMod A) N ≫ + (modTensorUnitLeft A N).hom = actLeft A N.X := + modTensorπ_desc A (regularMod A) N _ _ + have hL : (A ◁ modTensorπ A (regularMod A) N) ≫ + modTensorAct A (regularMod A) N ≫ + (modTensorUnitLeft A N).hom = + ((α_ A A N.X).inv ≫ (μ[A] ▷ N.X)) ≫ + actLeft A N.X := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (whiskerLeft_modTensorπ_act A (regularMod A) N) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ hπ + have hR : (A ◁ modTensorπ A (regularMod A) N) ≫ + (A ◁ (modTensorUnitLeft A N).hom) ≫ actLeft A N.X = + (A ◁ actLeft A N.X) ≫ actLeft A N.X := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp A _ _).symm _) ?_ + exact eq_whisker (congrArg (fun t => A ◁ t) hπ) _ + refine hL.trans (Eq.trans ?_ hR.symm) + refine Eq.symm ?_ + refine Eq.trans (actLeft_actLeft A N.X) ?_ + simp only [Category.assoc] + +/-- **The left unit collapse, as a module isomorphism.** -/ +noncomputable def modTensorUnitLeftMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (N : Mod D A) : + modTensorMod A (regularMod A) N ≅ N where + hom := Mod.Hom.mk' (modTensorUnitLeft A N).hom (by + exact modTensorUnitLeft_act A N) + inv := Mod.Hom.mk' (modTensorUnitLeft A N).inv (by + exact act_inv_of_act_hom A (modTensorUnitLeft A N) + (modTensorUnitLeft_act A N)) + hom_inv_id := by + apply Mod.Hom.ext + exact (modTensorUnitLeft A N).hom_inv_id + inv_hom_id := by + apply Mod.Hom.ext + exact (modTensorUnitLeft A N).inv_hom_id + +/-- The right unit collapse intertwines the actions. -/ +theorem modTensorUnitRight_act + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] + (M : Mod D A) : + modTensorAct A M (regularMod A) ≫ + (modTensorUnitRight A M).hom = + (A ◁ (modTensorUnitRight A M).hom) ≫ + actLeft A M.X := by + apply modTensor_whisker_hom_ext A M (regularMod A) A + have hπ : modTensorπ A M (regularMod A) ≫ + (modTensorUnitRight A M).hom = actRight A M.X := + modTensorπ_desc A M (regularMod A) _ _ + have hL : (A ◁ modTensorπ A M (regularMod A)) ≫ + modTensorAct A M (regularMod A) ≫ + (modTensorUnitRight A M).hom = + ((α_ A M.X A).inv ≫ (actLeft A M.X ▷ A)) ≫ + actRight A M.X := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (whiskerLeft_modTensorπ_act A M (regularMod A)) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ hπ + have hR : (A ◁ modTensorπ A M (regularMod A)) ≫ + (A ◁ (modTensorUnitRight A M).hom) ≫ + actLeft A M.X = + (A ◁ actRight A M.X) ≫ actLeft A M.X := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp A _ _).symm _) ?_ + exact eq_whisker (congrArg (fun t => A ◁ t) hπ) _ + refine hL.trans (Eq.trans ?_ hR.symm) + refine Eq.symm ?_ + refine Eq.trans (actLeft_actRight A M.X) ?_ + simp only [Category.assoc] + +/-- **The right unit collapse, as a module isomorphism.** -/ +noncomputable def modTensorUnitRightMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] + (M : Mod D A) : + modTensorMod A M (regularMod A) ≅ M where + hom := Mod.Hom.mk' (modTensorUnitRight A M).hom (by + exact modTensorUnitRight_act A M) + inv := Mod.Hom.mk' (modTensorUnitRight A M).inv (by + exact act_inv_of_act_hom A (modTensorUnitRight A M) + (modTensorUnitRight_act A M)) + hom_inv_id := by + apply Mod.Hom.ext + exact (modTensorUnitRight A M).hom_inv_id + inv_hom_id := by + apply Mod.Hom.ext + exact (modTensorUnitRight A M).inv_hom_id + +section Legs + +/-- **The sandwich insertion**: expand the unit and insert the +copairing on the left. -/ +noncomputable def sandwichIns + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + M ⟶ modTensorMod A (modTensorMod A M M') M := + (modTensorUnitLeftMod A M).symm.hom ≫ + modTensorMapMod A (d.copairMod) (𝟙 M) + +/-- **The sandwich contraction**: reassociate, contract the +trailing pair, and collapse the unit. -/ +noncomputable def sandwichCon + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + modTensorMod A (modTensorMod A M M') M ⟶ M := + (modTensorAssocModIso A M M' M).hom ≫ + modTensorMapMod A (𝟙 M) (d.pairMod) ≫ + (modTensorUnitRightMod A M).hom + +/-- **The dual sandwich insertion**: expand the unit and insert +the copairing on the right. -/ +noncomputable def sandwichInsR + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + M' ⟶ modTensorMod A M' (modTensorMod A M M') := + (modTensorUnitRightMod A M').symm.hom ≫ + modTensorMapMod A (𝟙 M') (d.copairMod) + +/-- **The dual sandwich contraction**: reassociate backwards, +contract the leading pair, and collapse the unit. -/ +noncomputable def sandwichConR + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + modTensorMod A M' (modTensorMod A M M') ⟶ M' := + (modTensorAssocModIso A M' M M').inv ≫ + modTensorMapMod A (d.pairMod) (𝟙 M') ≫ + (modTensorUnitLeftMod A M').hom + +end Legs + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichZig.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichZig.lean new file mode 100644 index 0000000000..5f8b41a69d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichZig.lean @@ -0,0 +1,57 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMultiTriple +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagSandwich + +/-! +# The sandwich retract of the zig triangle + +Over a zigzag datum the sandwich insertion is a section of the +sandwich contraction: the module is a retract of its double-dual +sandwich. The two legs are read on the carrier, where the zig +triangle already lives; `RS.Classical.Deligne.ZigzagSandwich` +supplies those two readings, `RS.sandwichIns_hom` and +`RS.modTensorπ_sandwichCon`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The sandwich retract**: over a zigzag datum the sandwich +insertion is a section of the sandwich contraction. -/ +theorem sandwichIns_sandwichCon + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') + (hz : ModZigzagDatum A d) : + sandwichIns A d ≫ sandwichCon A d = 𝟙 M := by + apply Mod.hom_ext + have hcar := zig_carrier_of_multi A d.copair d.pair + d.pair_linear hz.zig + refine Eq.trans ?_ hcar + change (sandwichIns A d).hom ≫ (sandwichCon A d).hom = _ + refine Eq.trans (eq_whisker (sandwichIns_hom A d) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine whisker_eq _ ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (modTensorπ_sandwichCon A d) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarBraiding.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarBraiding.lean new file mode 100644 index 0000000000..caf43c993d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarBraiding.lean @@ -0,0 +1,410 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.UnitEnd +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodTransfer + +/-! +# Scalar self-braidings and the vanishing for even and odd lines + +When the self-braiding of an object is a scalar, the whole +symmetric-group action on its tensor powers is by that scalar's +sign character: the top swap acts by the scalar, every +transposition is conjugate to it, and transpositions generate. +For a trivial self-braiding (the unit) the central idempotents +then act by the plain character sum — the Schur specialisation at +one even variable — and for braiding `−1` (an odd line) by the +signed sum — the specialisation at one odd variable. The +one-variable indicator evaluations kill every non-row +(respectively non-column) Schur functor, and iterated direct sums +give the vanishing half of Deligne 1.9 for `𝟙^p ⊕ 1̄^q` inside any +ambient category — the engine of the trichotomy 2.9. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits Finset + +universe v u + +variable {A : Type u} + +private theorem conj_smul_id [Category.{v} A] [Preadditive A] [Linear ℂ A] + {W V : A} (e : W ≅ V) (c : ℂ) : + e.hom ≫ (c • 𝟙 V) ≫ e.inv = c • 𝟙 W := by + simp + +/-- A scalar self-braiding makes the top swap act by the +scalar. -/ +theorem swapTop_of_scalar + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] + {X : A} {c : ℂ} + (hβ : (β_ X X).hom = c • 𝟙 (X ⊗ X)) (n : ℕ) : + swapTop X n = c • 𝟙 (tensorPow A X (n + 2)) := by + rw [swapTop, hβ, MonoidalLinear.whiskerLeft_smul, + MonoidalCategory.whiskerLeft_id] + exact conj_smul_id (α_ (tensorPow A X n) X X) c + +/-- Every transposition acts by the scalar: the top swap does, and +transpositions are conjugate with central scalar values. -/ +theorem permMor_swap_of_scalar + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] + {X : A} {c : ℂ} + (hβ : (β_ X X).hom = c • 𝟙 (X ⊗ X)) : + ∀ {n : ℕ} (x y : Fin n), x ≠ y → + permMor X n (Equiv.swap x y) = + c • 𝟙 (tensorPow A X n) := by + intro n + match n with + | 0 => exact fun x _ _ => absurd x.isLt (by omega) + | 1 => exact fun x y hxy => absurd (Subsingleton.elim x y) hxy + | m + 2 => + intro x y hxy + have htop : permMor X (m + 2) topSwap = + c • 𝟙 (tensorPow A X (m + 2)) := by + rw [permMor_topSwap_eq, swapTop_of_scalar hβ] + have hconj : IsConj (topSwap : Equiv.Perm (Fin (m + 2))) + (Equiv.swap x y) := by + rw [topSwap] + exact Equiv.Perm.isConj_swap + (by + intro h + have := congrArg Fin.val h + simp [Fin.last] at this) hxy + obtain ⟨g, hg⟩ := isConj_iff.mp hconj + rw [← hg, permMor_mul, permMor_mul, htop, Linear.smul_comp, + Linear.comp_smul, Category.id_comp, ← permMor_mul, + mul_inv_cancel, permMor_one] + +/-- **Scalar self-braiding acts by the sign character**: with a +scalar square root of unity as self-braiding, every permutation +acts by the scalar raised to its sign. -/ +theorem permMor_of_scalar + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] + {X : A} {c : ℂ} + (hβ : (β_ X X).hom = c • 𝟙 (X ⊗ X)) (hc2 : c * c = 1) + {n : ℕ} (σ : Equiv.Perm (Fin n)) : + permMor X n σ = + (if Equiv.Perm.sign σ = 1 then (1 : ℂ) else c) • + 𝟙 (tensorPow A X n) := by + induction σ using Equiv.Perm.swap_induction_on with + | one => rw [permMor_one, Equiv.Perm.sign_one, ite_eq_left rfl, + one_smul] + | swap_mul σ x y hxy ih => + rw [permMor_mul, ih, permMor_swap_of_scalar hβ x y hxy, + Linear.smul_comp, Linear.comp_smul, Category.comp_id, + smul_smul, Equiv.Perm.sign_mul, Equiv.Perm.sign_swap hxy] + by_cases hs : Equiv.Perm.sign σ = 1 + · rw [ite_eq_left hs, hs] + norm_num + · have hs' : Equiv.Perm.sign σ = -1 := + (Int.units_eq_one_or _).resolve_left hs + rw [ite_eq_right hs, hs'] + norm_num [hc2] + +/-- The group-algebra action under a scalar self-braiding is +multiplication by the twisted coefficient sum. -/ +theorem permAlg_of_scalar + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] + {X : A} {c : ℂ} + (hβ : (β_ X X).hom = c • 𝟙 (X ⊗ X)) (hc2 : c * c = 1) + {n : ℕ} (x : SymGroupAlgebra n) : + permAlg X n x = + (∑ σ : Equiv.Perm (Fin n), x.coeff σ * + (if Equiv.Perm.sign σ = 1 then (1 : ℂ) else c)) • + 𝟙 (tensorPow A X n) := by + classical + have hlift : permAlg X n x = + x.coeff.sum fun σ r => r • permMor X n σ := by + rw [permAlg] + exact MonoidAlgebra.lift_apply _ _ + rw [hlift] + rw [show (x.coeff.sum fun σ r => r • permMor X n σ) = + ∑ σ ∈ x.coeff.support, x.coeff σ • permMor X n σ from rfl] + rw [Finset.sum_congr rfl fun σ _ => by + rw [permMor_of_scalar hβ hc2 σ, smul_smul]] + rw [← Finset.sum_smul] + congr 1 + refine Finset.sum_subset (Finset.subset_univ _) fun σ _ hσ => ?_ + rw [Finsupp.notMem_support_iff.mp hσ, zero_mul] + +/-- The identification of the raw idempotent with its Shape form +at its own size. -/ +theorem pe_eq_shape_e (P : SchurPackage.{v}) (lam : YoungDiagram) : + P.e lam = Shape.e P (⟨lam, rfl⟩ : Shape lam.card) := by + unfold Shape.e + erw [symCast_le_refl] + +/-- The plain coefficient sum of the central idempotent is the +dimension times the Schur specialisation at one even variable. -/ +theorem sum_e_coeff (P : SchurPackage.{v}) (lam : YoungDiagram) : + (∑ σ : Equiv.Perm (Fin lam.card), (P.e lam).coeff σ) = + (P.dim lam : ℂ) * diagramSchur lam (superPS 1 0) := by + classical + have hfrob : ((lam.card.factorial : ℂ))⁻¹ * + ∑ π : Equiv.Perm (Fin lam.card), + jtChar lam (permCast (rfl : lam.card = lam.card).symm π) * + cycleFun (superPS 1 0) π = + diagramSchur lam (superPS 1 0) := + jtChar_shape_frobenius (⟨lam, rfl⟩ : Shape lam.card) + (superPS 1 0) + have hone : ∀ π : Equiv.Perm (Fin lam.card), + cycleFun (superPS 1 0) π = 1 := fun π => by + rw [cycleFun_superPS_h] + norm_num + rw [show (∑ π : Equiv.Perm (Fin lam.card), + jtChar lam (permCast (rfl : lam.card = lam.card).symm π) * + cycleFun (superPS 1 0) π) = + ∑ π : Equiv.Perm (Fin lam.card), + jtChar lam (permCast (rfl : lam.card = lam.card).symm π) + from Finset.sum_congr rfl fun π _ => by + rw [hone π, mul_one]] at hfrob + calc ∑ σ : Equiv.Perm (Fin lam.card), (P.e lam).coeff σ + = ∑ σ : Equiv.Perm (Fin lam.card), + ((P.dim lam : ℂ) / (lam.card.factorial : ℂ)) * + jtChar lam (permCast (rfl : lam.card = lam.card).symm + σ) := by + refine Finset.sum_congr rfl fun σ _ => ?_ + rw [pe_eq_shape_e] + exact shape_e_coeff P (⟨lam, rfl⟩ : Shape lam.card) σ + _ = ((P.dim lam : ℂ) / (lam.card.factorial : ℂ)) * + ∑ σ : Equiv.Perm (Fin lam.card), + jtChar lam (permCast (rfl : lam.card = lam.card).symm + σ) := by + rw [← Finset.mul_sum] + _ = (P.dim lam : ℂ) * diagramSchur lam (superPS 1 0) := by + rw [← hfrob] + field_simp + +/-- The signed coefficient sum of the central idempotent is the +dimension times the Schur specialisation at one odd variable. -/ +theorem sum_e_coeff_sign (P : SchurPackage.{v}) + (lam : YoungDiagram) : + (∑ σ : Equiv.Perm (Fin lam.card), (P.e lam).coeff σ * + ((Equiv.Perm.sign σ : ℤ) : ℂ)) = + (P.dim lam : ℂ) * diagramSchur lam (superPS 0 1) := by + classical + have hfrob : ((lam.card.factorial : ℂ))⁻¹ * + ∑ π : Equiv.Perm (Fin lam.card), + jtChar lam (permCast (rfl : lam.card = lam.card).symm π) * + cycleFun (superPS 0 1) π = + diagramSchur lam (superPS 0 1) := + jtChar_shape_frobenius (⟨lam, rfl⟩ : Shape lam.card) + (superPS 0 1) + have hsgn : ∀ π : Equiv.Perm (Fin lam.card), + cycleFun (superPS 0 1) π = + ((Equiv.Perm.sign π : ℤ) : ℂ) := fun π => by + rw [cycleFun_superPS_e] + norm_num + rw [show (∑ π : Equiv.Perm (Fin lam.card), + jtChar lam (permCast (rfl : lam.card = lam.card).symm π) * + cycleFun (superPS 0 1) π) = + ∑ π : Equiv.Perm (Fin lam.card), + jtChar lam (permCast (rfl : lam.card = lam.card).symm π) * + ((Equiv.Perm.sign π : ℤ) : ℂ) + from Finset.sum_congr rfl fun π _ => by rw [hsgn π]] at hfrob + calc ∑ σ : Equiv.Perm (Fin lam.card), (P.e lam).coeff σ * + ((Equiv.Perm.sign σ : ℤ) : ℂ) + = ∑ σ : Equiv.Perm (Fin lam.card), + ((P.dim lam : ℂ) / (lam.card.factorial : ℂ)) * + (jtChar lam (permCast (rfl : lam.card = lam.card).symm + σ) * ((Equiv.Perm.sign σ : ℤ) : ℂ)) := by + refine Finset.sum_congr rfl fun σ _ => ?_ + have hc : (P.e lam).coeff σ = + ((P.dim lam : ℂ) / (lam.card.factorial : ℂ)) * + jtChar lam + (permCast (rfl : lam.card = lam.card).symm σ) := by + rw [pe_eq_shape_e] + exact shape_e_coeff P (⟨lam, rfl⟩ : Shape lam.card) σ + rw [hc] + ring + _ = ((P.dim lam : ℂ) / (lam.card.factorial : ℂ)) * + ∑ σ : Equiv.Perm (Fin lam.card), + jtChar lam (permCast (rfl : lam.card = lam.card).symm + σ) * ((Equiv.Perm.sign σ : ℤ) : ℂ) := by + rw [← Finset.mul_sum] + _ = (P.dim lam : ℂ) * diagramSchur lam (superPS 0 1) := by + rw [← hfrob] + field_simp + +/-- **Trivial self-braiding kills every non-row Schur functor**: +the central idempotent acts by the plain character sum, the Schur +specialisation at one even variable. -/ +theorem schurKilled_of_braiding_id + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] + (P : SchurPackage.{v}) {X : A} + (hβ : (β_ X X).hom = 𝟙 (X ⊗ X)) {lam : YoungDiagram} + (hlam : 1 < lam.colLen 0) : SchurKilled P X lam := by + classical + rw [SchurKilled] + have hβ' : (β_ X X).hom = (1 : ℂ) • 𝟙 (X ⊗ X) := by + rw [one_smul, hβ] + rw [permAlg_of_scalar hβ' (by norm_num)] + rw [show (∑ σ : Equiv.Perm (Fin lam.card), (P.e lam).coeff σ * + (if Equiv.Perm.sign σ = 1 then (1 : ℂ) else 1)) = + ∑ σ : Equiv.Perm (Fin lam.card), (P.e lam).coeff σ from + Finset.sum_congr rfl fun σ _ => by rw [ite_self, mul_one]] + rw [sum_e_coeff, diagramSchur_superPS_row, + ite_eq_right (by omega), mul_zero, zero_smul] + +/-- **Self-braiding `−1` kills every non-column Schur functor**: +the central idempotent acts by the signed character sum, the Schur +specialisation at one odd variable. -/ +theorem schurKilled_of_braiding_neg + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] + (P : SchurPackage.{v}) {X : A} + (hβ : (β_ X X).hom = -(𝟙 (X ⊗ X))) {lam : YoungDiagram} + (hlam : 1 < lam.rowLen 0) : SchurKilled P X lam := by + classical + rw [SchurKilled] + have hβ' : (β_ X X).hom = (-1 : ℂ) • 𝟙 (X ⊗ X) := by + rw [neg_one_smul, hβ] + rw [permAlg_of_scalar hβ' (by norm_num)] + rw [show (∑ σ : Equiv.Perm (Fin lam.card), (P.e lam).coeff σ * + (if Equiv.Perm.sign σ = 1 then (1 : ℂ) else -1)) = + ∑ σ : Equiv.Perm (Fin lam.card), (P.e lam).coeff σ * + ((Equiv.Perm.sign σ : ℤ) : ℂ) from + Finset.sum_congr rfl fun σ _ => by + by_cases hs : Equiv.Perm.sign σ = 1 + · rw [ite_eq_left hs, hs] + norm_num + · rw [ite_eq_right hs, + (Int.units_eq_one_or _).resolve_left hs] + norm_num] + rw [sum_e_coeff_sign, diagramSchur_superPS_col, + ite_eq_right (by omega), mul_zero, zero_smul] + +/-- The unit is killed at the two-cell column. -/ +theorem schurKilled_unit_col + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] + (P : SchurPackage.{v}) : + SchurKilled P (𝟙_ A) (colShape 2).val := by + refine schurKilled_of_braiding_id P braiding_unit_self ?_ + have hmem : ((1, 0) : ℕ × ℕ) ∈ (colShape 2).val := by + rw [YoungDiagram.mem_iff_lt_rowLen, + colShape_rowLen_lt 2 one_lt_two] + omega + exact YoungDiagram.mem_iff_lt_colLen.mp hmem + +/-- An odd line is killed at the two-cell row. -/ +theorem schurKilled_odd_row + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] + (P : SchurPackage.{v}) {U : A} + (hβ : (β_ U U).hom = -(𝟙 (U ⊗ U))) : + SchurKilled P U (rowShape 2).val := by + refine schurKilled_of_braiding_neg P hβ ?_ + rw [rowShape_rowLen_zero] + omega + +section Sums + +/-- `p + 1` biproduct copies of an object. -/ +noncomputable def sumPow + [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + (X : A) : ℕ → A + | 0 => X + | k + 1 => sumPow X k ⊞ X + +/-- Column bound for the one-column shape. -/ +theorem colShape_colLen_le (m : ℕ) : + (colShape m).val.colLen 0 ≤ m := by + by_contra h + have hmem : ((m, 0) : ℕ × ℕ) ∈ (colShape m).val := + YoungDiagram.mem_iff_lt_colLen.mpr (by omega) + rw [YoungDiagram.mem_iff_lt_rowLen, + colShape_rowLen_le m le_rfl] at hmem + omega + +/-- Iterated unit sums are killed at the corresponding column. -/ +theorem schurKilled_sumPow_unit + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] [HasBinaryBiproducts A] + (P : SchurPackage.{v}) (p : ℕ) : + SchurKilled P (sumPow (𝟙_ A) p) (colShape (p + 2)).val := by + induction p with + | zero => exact schurKilled_unit_col P + | succ k ih => + refine SchurKilled.biprod P (p := k + 1) (q := 0) (r := 1) + (s := 0) ?_ ?_ ?_ ?_ ih (schurKilled_unit_col P) ?_ + · exact colShape_colLen_le (k + 2) + · exact colShape_rowLen_zero_le (k + 2) + · exact colShape_colLen_le 2 + · exact colShape_rowLen_zero_le 2 + · rw [YoungDiagram.mem_iff_lt_rowLen, + colShape_rowLen_lt (k + 3) (by omega)] + omega + +/-- Row bound for the one-row shape. -/ +theorem rowShape_colLen_le (m : ℕ) : + (rowShape m).val.colLen 0 ≤ 1 := + rowShape_colLen m + +/-- Iterated odd sums are killed at the corresponding row. -/ +theorem schurKilled_sumPow_odd + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] [HasBinaryBiproducts A] + (P : SchurPackage.{v}) {U : A} + (hβ : (β_ U U).hom = -(𝟙 (U ⊗ U))) (q : ℕ) : + SchurKilled P (sumPow U q) (rowShape (q + 2)).val := by + induction q with + | zero => exact schurKilled_odd_row P hβ + | succ k ih => + refine SchurKilled.biprod P (p := 0) (q := k + 1) (r := 0) + (s := 1) ?_ ?_ ?_ ?_ ih (schurKilled_odd_row P hβ) ?_ + · exact rowShape_colLen_le (k + 2) + · rw [rowShape_rowLen_zero] + · exact rowShape_colLen_le 2 + · rw [rowShape_rowLen_zero] + · rw [YoungDiagram.mem_iff_lt_rowLen, rowShape_rowLen_zero] + omega + +/-- **The vanishing half of Deligne 1.9, internally**: a direct +sum of `p + 1` unit copies and `q + 1` odd-line copies is killed +at every diagram containing the cell `(p + 1, q + 1)`. -/ +theorem schurKilled_unit_odd + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] [HasBinaryBiproducts A] + (P : SchurPackage.{v}) {U : A} + (hβ : (β_ U U).hom = -(𝟙 (U ⊗ U))) (p q : ℕ) + {lam : YoungDiagram} (hcell : (p + 1, q + 1) ∈ lam) : + SchurKilled P (sumPow (𝟙_ A) p ⊞ sumPow U q) lam := by + refine SchurKilled.biprod P (p := p + 1) (q := 0) (r := 0) + (s := q + 1) ?_ ?_ ?_ ?_ (schurKilled_sumPow_unit P p) + (schurKilled_sumPow_odd P hβ q) ?_ + · exact colShape_colLen_le (p + 2) + · exact colShape_rowLen_zero_le (p + 2) + · exact rowShape_colLen_le (q + 2) + · rw [rowShape_rowLen_zero] + · show (p + 1 + 0, 0 + (q + 1)) ∈ lam + rw [Nat.add_zero, Nat.zero_add] + exact hcell + +end Sums + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarLinear.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarLinear.lean new file mode 100644 index 0000000000..1e23076620 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarLinear.lean @@ -0,0 +1,406 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndTensorExact +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPerm + +/-! +# ℂ-linearity from the scalar unit + +A preadditive monoidal category whose unit endomorphisms are +identified with ℂ carries a ℂ-linear structure on every hom-set: +the scalar `c` acts by conjugating the unit endomorphism `φ c` +through the left unitor and composing. The file proves the module +laws and assembles `CategoryTheory.Linear ℂ D` from a single ring +isomorphism `φ : ℂ ≃+* End (𝟙_ D)`, then instantiates the input at +`Ind C`: the unit of the transported monoidal structure is the +embedded unit (`RS.indOfUnitIso`), so a scalar unit for `C` induces +one for `Ind C` (`RS.indScalarUnit`). + +Two points of care. + +* `End`-multiplication is reversed composition, and ℂ is + commutative; `RS.scalarUnit_map_mul` records the translation + `φ (a * b) = φ a ≫ φ b` on which `mul_smul` rests. +* The monoidal-linear laws need more than the module laws: left + whiskering moves the scalar to the *right* leg of the tensor, so + `whiskerLeft_smul` needs the left-unitor conjugate of `φ c ▷ X` + to agree with the right-unitor conjugate of `X ◁ φ c`. This is + not a theorem of general monoidal categories (in bimodules over a + commutative ring `R` with an automorphism, the two conjugates + differ on twisted bimodules even when `End (𝟙) = ℂ`), but it + holds in braided ones. The agreement is therefore isolated as + the hypothesis `RS.ScalarBalanced`, discharged for braided + categories by `RS.scalarBalanced_of_braided`. + +Everything here is a `def` or a `theorem`, never an instance: a +global `Linear ℂ` instance built from an arbitrary `φ` would clash +with existing linear structures (and with itself, for two different +`φ`), so callers install the structure with `letI` at use sites. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u v' u' + +noncomputable section + +/-! ## The scalar action of the unit's endomorphisms -/ + +section General + +variable {D : Type u} + +/-- The unit endomorphism `φ c`, typed as a morphism rather than as +an element of the endomorphism ring, so that sums and composites of +these values elaborate at the hom-set instances. -/ +def scalarHom [Category.{v} D] [MonoidalCategory D] [Preadditive D] + (φ : ℂ ≃+* End (𝟙_ D)) (c : ℂ) : 𝟙_ D ⟶ 𝟙_ D := + φ c + +/-- `End`-multiplication is reversed composition, and ℂ is +commutative, so a ring isomorphism out of ℂ turns products into +composites in either order; this is the composition-order reading +used throughout. -/ +theorem scalarUnit_map_mul [Category.{v} D] [MonoidalCategory D] [Preadditive D] + (φ : ℂ ≃+* End (𝟙_ D)) (a b : ℂ) : + scalarHom φ (a * b) = scalarHom φ a ≫ scalarHom φ b := by + simp only [scalarHom] + rw [mul_comm a b, map_mul, End.mul_def] + +/-- **The scalar `c` as an endomorphism of `X`**: whisker the unit +endomorphism `φ c` onto `X` and cancel the unit through the left +unitor. -/ +def scalarEnd [Category.{v} D] [MonoidalCategory D] [Preadditive D] + (φ : ℂ ≃+* End (𝟙_ D)) (c : ℂ) (X : D) : X ⟶ X := + (λ_ X).inv ≫ (scalarHom φ c ▷ X) ≫ (λ_ X).hom + +/-- The scalar `1` acts as the identity. -/ +theorem scalarEnd_one [Category.{v} D] [MonoidalCategory D] [Preadditive D] + (φ : ℂ ≃+* End (𝟙_ D)) (X : D) : + scalarEnd φ 1 X = 𝟙 X := by + have h : scalarHom φ 1 = 𝟙 (𝟙_ D) := map_one φ + simp [scalarEnd, h] + +/-- The action turns multiplication into composition. -/ +theorem scalarEnd_mul [Category.{v} D] [MonoidalCategory D] [Preadditive D] + (φ : ℂ ≃+* End (𝟙_ D)) (a b : ℂ) (X : D) : + scalarEnd φ (a * b) X = scalarEnd φ a X ≫ scalarEnd φ b X := by + simp [scalarEnd, scalarUnit_map_mul φ a b] + +/-- **The scalar action is central**: it exchanges with every +morphism. Left-unitor naturality moves the unitors across `f`, and +the whisker exchange moves `φ c ▷ −` across `𝟙 ◁ f`. -/ +theorem scalarEnd_naturality + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + (φ : ℂ ≃+* End (𝟙_ D)) (c : ℂ) + {X Y : D} (f : X ⟶ Y) : + scalarEnd φ c X ≫ f = f ≫ scalarEnd φ c Y := by + simp only [scalarEnd, Category.assoc] + rw [← leftUnitor_naturality, ← whisker_exchange_assoc, + ← leftUnitor_inv_naturality_assoc] + +/-- The scalar action whiskers on the right: the left-unitor +conjugate at `X ⊗ Y` restricts to the one at `X`. -/ +theorem scalarEnd_whiskerRight + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + (φ : ℂ ≃+* End (𝟙_ D)) (c : ℂ) + (X Y : D) : + scalarEnd φ c X ▷ Y = scalarEnd φ c (X ⊗ Y) := by + simp [scalarEnd] + +/-- **The two-sided agreement of the unit action**: the left-unitor +conjugate of `φ c ▷ X` is the right-unitor conjugate of `X ◁ φ c`. +This is *not* automatic in a monoidal category — bimodule categories +with `End (𝟙) = ℂ` can act by different ring embeddings on the two +sides of an object — and it is exactly what the monoidal-linear law +for left whiskering needs, so it is a named hypothesis, discharged +in the braided case by `RS.scalarBalanced_of_braided`. -/ +def ScalarBalanced [Category.{v} D] [MonoidalCategory D] [Preadditive D] + (φ : ℂ ≃+* End (𝟙_ D)) : Prop := + ∀ (c : ℂ) (X : D), + (λ_ X).inv ≫ (scalarHom φ c ▷ X) ≫ (λ_ X).hom = + (ρ_ X).inv ≫ (X ◁ scalarHom φ c) ≫ (ρ_ X).hom + +/-- In a braided category the unit action is balanced: the braiding +with the unit carries `φ c ▷ X` to `X ◁ φ c` and exchanges the two +unitors. -/ +theorem scalarBalanced_of_braided + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [BraidedCategory D] + (φ : ℂ ≃+* End (𝟙_ D)) : ScalarBalanced φ := by + intro c X + have h : (scalarHom φ c ▷ X) ≫ (β_ (𝟙_ D) X).hom = + (β_ (𝟙_ D) X).hom ≫ (X ◁ scalarHom φ c) := + BraidedCategory.braiding_naturality_left _ X + have h' : scalarHom φ c ▷ X = + (β_ (𝟙_ D) X).hom ≫ (X ◁ scalarHom φ c) ≫ + (β_ (𝟙_ D) X).inv := by + rw [← Category.assoc, ← h, Category.assoc, Iso.hom_inv_id, + Category.comp_id] + rw [h', braiding_tensorUnit_left, braiding_inv_tensorUnit_left] + simp + +/-- Left whiskering carries the left-unitor conjugate of a unit +endomorphism into the right-unitor conjugate, whiskered on the +right: the triangle identity trades `X ◁ (λ_ Y)` for +`(ρ_ X) ▷ Y` around the middle associator. -/ +theorem whiskerLeft_unitConj [Category.{v} D] [MonoidalCategory D] + (u : 𝟙_ D ⟶ 𝟙_ D) (X Y : D) : + X ◁ ((λ_ Y).inv ≫ (u ▷ Y) ≫ (λ_ Y).hom) = + ((ρ_ X).inv ≫ (X ◁ u) ≫ (ρ_ X).hom) ▷ Y := by + have hmid : X ◁ (u ▷ Y) = + (α_ X (𝟙_ D) Y).inv ≫ + ((X ◁ u) ▷ Y) ≫ (α_ X (𝟙_ D) Y).hom := by + rw [whisker_assoc] + simp + simp only [MonoidalCategory.whiskerLeft_comp, hmid, + comp_whiskerRight, Category.assoc] + rw [← triangle_assoc_comp_left_inv_assoc, ← MonoidalCategory.triangle] + +/-- The scalar action whiskers on the left, given the two-sided +agreement, which converts the right-unitor data produced by +`RS.whiskerLeft_unitConj` back to left-unitor data at `X`. -/ +theorem whiskerLeft_scalarEnd + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + (φ : ℂ ≃+* End (𝟙_ D)) + (h : ScalarBalanced φ) (c : ℂ) (X Y : D) : + X ◁ scalarEnd φ c Y = scalarEnd φ c (X ⊗ Y) := by + calc X ◁ scalarEnd φ c Y + = ((ρ_ X).inv ≫ (X ◁ scalarHom φ c) ≫ (ρ_ X).hom) ▷ Y := + whiskerLeft_unitConj (scalarHom φ c) X Y + _ = ((λ_ X).inv ≫ (scalarHom φ c ▷ X) ≫ (λ_ X).hom) ▷ Y := + by rw [← h c X] + _ = scalarEnd φ c X ▷ Y := rfl + _ = scalarEnd φ c (X ⊗ Y) := scalarEnd_whiskerRight φ c X Y + +/-! ## The hom-set modules and the linear structure -/ + +/-- The action is additive in the scalar. -/ +theorem scalarEnd_add [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] + (φ : ℂ ≃+* End (𝟙_ D)) (a b : ℂ) (X : D) : + scalarEnd φ (a + b) X = scalarEnd φ a X + scalarEnd φ b X := by + have h : scalarHom φ (a + b) = scalarHom φ a + scalarHom φ b := + map_add φ a b + simp only [scalarEnd, h, MonoidalPreadditive.add_whiskerRight, + Preadditive.add_comp, Preadditive.comp_add] + +/-- The scalar `0` acts as zero. -/ +theorem scalarEnd_zero [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] + (φ : ℂ ≃+* End (𝟙_ D)) (X : D) : + scalarEnd φ 0 X = 0 := by + have h : scalarHom φ 0 = (0 : 𝟙_ D ⟶ 𝟙_ D) := map_zero φ + simp [scalarEnd, h] + +/-- **The scalar action on a hom-set**: whisker the unit +endomorphism through the left unitor of the source and compose. -/ +def scalarSmul [Category.{v} D] [MonoidalCategory D] [Preadditive D] + (φ : ℂ ≃+* End (𝟙_ D)) {X Y : D} (c : ℂ) + (f : X ⟶ Y) : X ⟶ Y := + (λ_ X).inv ≫ (scalarHom φ c ▷ X) ≫ (λ_ X).hom ≫ f + +/-- The action on morphisms is composition with the endomorphism +form of the scalar. -/ +theorem scalarSmul_eq [Category.{v} D] [MonoidalCategory D] [Preadditive D] + (φ : ℂ ≃+* End (𝟙_ D)) {X Y : D} (c : ℂ) + (f : X ⟶ Y) : scalarSmul φ c f = scalarEnd φ c X ≫ f := by + simp [scalarSmul, scalarEnd] + +/-- The ℂ-module structure on a hom-set induced by the scalar +unit. -/ +@[reducible] def scalarModule + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] + (φ : ℂ ≃+* End (𝟙_ D)) (X Y : D) : + Module ℂ (X ⟶ Y) where + smul c f := scalarSmul φ c f + one_smul f := by + change scalarSmul φ 1 f = f + rw [scalarSmul_eq, scalarEnd_one, Category.id_comp] + mul_smul a b f := by + change scalarSmul φ (a * b) f = scalarSmul φ a (scalarSmul φ b f) + rw [scalarSmul_eq, scalarSmul_eq, scalarSmul_eq, scalarEnd_mul, + Category.assoc] + smul_zero c := by + change scalarSmul φ c 0 = 0 + rw [scalarSmul_eq, Limits.comp_zero] + smul_add c f g := by + change scalarSmul φ c (f + g) = scalarSmul φ c f + scalarSmul φ c g + rw [scalarSmul_eq, scalarSmul_eq, scalarSmul_eq, + Preadditive.comp_add] + add_smul a b f := by + change scalarSmul φ (a + b) f = scalarSmul φ a f + scalarSmul φ b f + rw [scalarSmul_eq, scalarSmul_eq, scalarSmul_eq, scalarEnd_add, + Preadditive.add_comp] + zero_smul f := by + change scalarSmul φ 0 f = 0 + rw [scalarSmul_eq, scalarEnd_zero, Limits.zero_comp] + +/-- **ℂ-linearity from the scalar unit**: a ring isomorphism +`ℂ ≃+* End (𝟙_ D)` makes a preadditive monoidal category ℂ-linear. +A `def`, not an instance: an unconditional instance would clash with +every existing linear structure, so callers install it by `letI`. -/ +@[reducible] def linearOfScalarUnit + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] + (φ : ℂ ≃+* End (𝟙_ D)) : + CategoryTheory.Linear ℂ D where + homModule X Y := scalarModule φ X Y + smul_comp X Y Z r f g := by + change scalarSmul φ r f ≫ g = scalarSmul φ r (f ≫ g) + rw [scalarSmul_eq, scalarSmul_eq, Category.assoc] + comp_smul X Y Z f r g := by + change f ≫ scalarSmul φ r g = scalarSmul φ r (f ≫ g) + rw [scalarSmul_eq, scalarSmul_eq, ← Category.assoc, + ← scalarEnd_naturality, Category.assoc] + +/-- **Monoidal ℂ-linearity from the scalar unit**, given the +two-sided agreement of the unit action: whiskering is ℂ-linear in +each variable. Stated under `letI := linearOfScalarUnit φ`; use it +the same way. -/ +theorem monoidalLinearOfScalarUnit + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] + (φ : ℂ ≃+* End (𝟙_ D)) + (h : ScalarBalanced φ) : + letI := linearOfScalarUnit φ + MonoidalLinear ℂ D := by + let := linearOfScalarUnit φ + refine ⟨fun X {Y Z} r f => ?_, fun r {Y Z} f X => ?_⟩ + · change X ◁ scalarSmul φ r f = scalarSmul φ r (X ◁ f) + rw [scalarSmul_eq, scalarSmul_eq, + MonoidalCategory.whiskerLeft_comp, whiskerLeft_scalarEnd φ h] + · change scalarSmul φ r f ▷ X = scalarSmul φ r (f ▷ X) + rw [scalarSmul_eq, scalarSmul_eq, comp_whiskerRight, + scalarEnd_whiskerRight] + +/-- Monoidal ℂ-linearity from the scalar unit in a braided category, +where the two-sided agreement is automatic. -/ +theorem monoidalLinearOfScalarUnitBraided + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] + [BraidedCategory D] + (φ : ℂ ≃+* End (𝟙_ D)) : + letI := linearOfScalarUnit φ + MonoidalLinear ℂ D := + monoidalLinearOfScalarUnit φ (scalarBalanced_of_braided φ) + +end General + +/-! ## Endomorphism rings under isomorphism and embedding -/ + +section EndTransport + +variable {E : Type u'} + +/-- Conjugation by an isomorphism as a ring equivalence of +endomorphism rings; conjugation preserves the reversed products +because the connecting isomorphisms cancel in the middle. -/ +def endCongrRingEquiv [Category.{v'} E] [Preadditive E] + {X Y : E} (α : X ≅ Y) : End X ≃+* End Y := + { α.conj with + map_add' := fun f g => by + have h : ∀ p q : X ⟶ X, α.inv ≫ (p + q) ≫ α.hom = + (α.inv ≫ p ≫ α.hom) + (α.inv ≫ q ≫ α.hom) := fun p q => by + rw [Preadditive.add_comp, Preadditive.comp_add] + exact h f g } + +end EndTransport + +/-! ## The scalar unit of `Ind C` -/ + +section Ind + +variable {C : Type v} + +/-- The embedding `C ⥤ Ind C` is additive: it preserves finite +colimits, hence binary biproducts, between preadditive +categories. -/ +theorem indOf_additive [SmallCategory C] [Preadditive C] [HasFiniteColimits C] : + (indOf (C := C)).Additive := by + have : Limits.HasFiniteBiproducts C := + Limits.HasFiniteBiproducts.of_hasFiniteCoproducts + have : Limits.HasBinaryBiproducts C := + Limits.hasBinaryBiproducts_of_finite_biproducts C + have : Limits.HasBinaryBiproducts (Ind C) := + Limits.hasBinaryBiproducts_of_finite_biproducts (Ind C) + have : (indOf (C := C)).PreservesZeroMorphisms := + Functor.preservesZeroMorphisms_of_map_zero_object + (isZero_indOf (Limits.isZero_zero C)).isoZero + have := Limits.preservesBinaryBiproducts_of_preservesBinaryCoproducts + (indOf (C := C)) + exact Functor.additive_of_preservesBinaryBiproducts _ + +/-- Full faithfulness of the embedding on endomorphisms, as a ring +equivalence; `End`-multiplication is reversed composition on both +sides, so functoriality preserves it verbatim. -/ +def indOfEndRingEquiv [SmallCategory C] [Preadditive C] [HasFiniteColimits C] + (x : C) : End x ≃+* End (indOf.obj x) where + toFun f := indOf.map f + invFun g := Ind.yoneda.fullyFaithful.preimage g + left_inv f := Ind.yoneda.fullyFaithful.preimage_map f + right_inv g := Ind.yoneda.fullyFaithful.map_preimage g + map_mul' f g := by + rw [End.mul_def, End.mul_def, Functor.map_comp] + map_add' f g := by + have := indOf_additive (C := C) + exact Functor.map_add (F := indOf (C := C)) + +/-- **The scalar unit of `Ind C`**: a ring isomorphism +`ℂ ≃+* End (𝟙_ C)` transports along the embedding and the unit +identification to one for `Ind C`. -/ +def indScalarUnit [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] + (ψ : ℂ ≃+* End (𝟙_ C)) : + ℂ ≃+* End (𝟙_ (Ind C)) := + (ψ.trans (indOfEndRingEquiv (𝟙_ C))).trans + (endCongrRingEquiv (indOfUnitIso (C := C)).symm) + +end Ind + +/-! ## Acceptance -/ + +section Acceptance + +variable {C : Type v} + +example + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [MonoidalPreadditive C] + (ψ : ℂ ≃+* End (𝟙_ C)) : CategoryTheory.Linear ℂ (Ind C) := + linearOfScalarUnit (indScalarUnit ψ) + +example + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [MonoidalPreadditive C] + [BraidedCategory C] (ψ : ℂ ≃+* End (𝟙_ C)) : + letI := linearOfScalarUnit (indScalarUnit ψ) + MonoidalLinear ℂ (Ind C) := + monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + +example + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [MonoidalPreadditive C] + [SymmetricCategory C] (ψ : ℂ ≃+* End (𝟙_ C)) (X : Ind C) + (n : ℕ) : + letI := linearOfScalarUnit (indScalarUnit ψ) + SymGroupAlgebra n →ₐ[ℂ] End (tensorPow (Ind C) X n) := + letI := linearOfScalarUnit (indScalarUnit ψ) + permAlg X n + +end Acceptance + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitEquiv.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitEquiv.lean new file mode 100644 index 0000000000..a332a792bd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitEquiv.lean @@ -0,0 +1,60 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Definitions + +/-! +# The scalar unit as a ring isomorphism + +The scalar-unit hypothesis says that scaling the identity of the +tensor unit is a bijection from the complex numbers. It is also a +ring homomorphism, so it is a ring isomorphism, which is the form +in which the ℂ-linear structure of the Ind-completion consumes it. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +variable (A : Type u) + +/-- Scaling the identity of the tensor unit, as a ring +homomorphism. -/ +def scalarUnitRingHom + [Category.{v} A] [Preadditive A] [CategoryTheory.Linear ℂ A] + [MonoidalCategory A] : ℂ →+* End (𝟙_ A) where + toFun c := c • 𝟙 (𝟙_ A) + map_one' := one_smul _ _ + map_mul' a b := by + change (a * b) • 𝟙 (𝟙_ A) = (b • 𝟙 (𝟙_ A)) ≫ (a • 𝟙 (𝟙_ A)) + rw [Linear.smul_comp, Linear.comp_smul, Category.comp_id, + smul_smul, mul_comm] + map_zero' := zero_smul _ _ + map_add' a b := add_smul _ _ _ + +variable {A} + +/-- **The scalar unit as a ring isomorphism.** -/ +noncomputable def scalarUnitEquiv + [Category.{v} A] [Preadditive A] [CategoryTheory.Linear ℂ A] + [MonoidalCategory A] + (h : HasScalarUnit A) : + ℂ ≃+* End (𝟙_ A) := + RingEquiv.ofBijective (scalarUnitRingHom A) h + +@[simp] theorem scalarUnitEquiv_apply + [Category.{v} A] [Preadditive A] [CategoryTheory.Linear ℂ A] + [MonoidalCategory A] + (h : HasScalarUnit A) (c : ℂ) : + scalarUnitEquiv h c = c • 𝟙 (𝟙_ A) := rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitInd.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitInd.lean new file mode 100644 index 0000000000..e0a1e49755 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitInd.lean @@ -0,0 +1,65 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear + +/-! +# The scalar-unit hypothesis from a scalar unit + +Under the linear structure induced by a ring isomorphism +`ℂ ≃+* End (𝟙_ D)`, scaling the identity of the unit recovers the +isomorphism, so the scalar-unit hypothesis holds. Applied to the +ind-completion this supplies the hypothesis upstairs from the one +downstairs. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {D : Type u} + +/-- Scaling the identity of the unit recovers the scalar. -/ +theorem scalarEnd_unit [Category.{v} D] [MonoidalCategory D] [Preadditive D] + (φ : ℂ ≃+* End (𝟙_ D)) (c : ℂ) : + scalarEnd φ c (𝟙_ D) = scalarHom φ c := by + rw [scalarEnd, unitors_equal, unitors_inv_equal, + rightUnitor_naturality, ← Category.assoc, Iso.inv_hom_id, + Category.id_comp] + +/-- **The scalar-unit hypothesis holds** under the induced linear +structure. -/ +theorem hasScalarUnit_of_scalarUnit + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] + (φ : ℂ ≃+* End (𝟙_ D)) : + letI := linearOfScalarUnit φ + HasScalarUnit D := by + let := linearOfScalarUnit φ + have hval : ∀ c : ℂ, (c • 𝟙 (𝟙_ D) : 𝟙_ D ⟶ 𝟙_ D) = + scalarHom φ c := by + intro c + change scalarSmul φ c (𝟙 (𝟙_ D)) = scalarHom φ c + rw [scalarSmul_eq, Category.comp_id, scalarEnd_unit] + constructor + · intro a b hab + refine φ.injective ?_ + have h1 := (hval a).symm.trans (hab.trans (hval b)) + exact h1 + · intro f + refine ⟨φ.symm f, ?_⟩ + change ((φ.symm f) • 𝟙 (𝟙_ D) : 𝟙_ D ⟶ 𝟙_ D) = f + rw [hval] + change (φ (φ.symm f) : 𝟙_ D ⟶ 𝟙_ D) = f + rw [RingEquiv.apply_symm_apply] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurTransport.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurTransport.lean new file mode 100644 index 0000000000..9c4fc428c0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurTransport.lean @@ -0,0 +1,495 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchur +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarTrace + +/-! +# Schur-vanishing transport along the embedding `C ⥤ Ind C` + +`RS.Classical.Deligne.IndSchur` transports the permutation action on +tensor powers across the embedding at the `permMor` level, and +`RS.Classical.Deligne.ScalarLinear` equips `Ind C` with the ℂ-linear +structure induced by a scalar unit `ψ : ℂ ≃+* End (𝟙_ C)`. This file +joins the two: under `letI := linearOfScalarUnit (indScalarUnit ψ)` +the whole group-algebra action transports, and Schur vanishing on an +embedded object is Schur vanishing downstairs. + +* `RS.smul_eq_unitConj` — a scalar acts by conjugating the unit + endomorphism `c • 𝟙` through the left unitor; +* `RS.dayCoyonedaIso_hom_leftUnitor`/`RS.dayYonedaIso_hom_leftUnitor` + — the Day tensor of (co)representables intertwines the left + unitor, completing the coherence package of + `RS.dayCoyonedaIso_hom_braiding`/`_associator`; +* `RS.indOf_leftUnitor_hom` — the unit comparison and the + embedding-tensor comparison satisfy the left unitality of a + monoidal functor up to isomorphism; +* `RS.indOf_map_smul` — the embedding carries the scalar action of + `C` to the scalar action `RS.scalarSmul (indScalarUnit ψ)`; +* `RS.permAlg_indOf_conj` — the symmetric-group algebra action on + the powers of an embedded object is conjugate, under + `RS.indOfPowIso`, to the embedded action; +* **`RS.schurKilled_indOf_iff`** — Schur vanishing transports + faithfully along `C ⥤ Ind C`, with the `HasScalarUnit` + instantiation `RS.schurKilled_indOf_iff_of_hasScalarUnit`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory MonoidalCategory.DayFunctor Limits +open Opposite + +universe v u + +noncomputable section + +/-! ## The scalar action as a unitor conjugate -/ + +section SmulConj + +variable {D : Type u} + +/-- **The scalar action is a unitor conjugate**: `c • f` is +precomposition with the left-unitor conjugate of the unit +endomorphism `c • 𝟙`. -/ +theorem smul_eq_unitConj + [Category.{v} D] [MonoidalCategory D] [Preadditive D] [Linear ℂ D] + [MonoidalPreadditive D] [MonoidalLinear ℂ D] + (c : ℂ) {X Y : D} (f : X ⟶ Y) : + c • f = + (λ_ X).inv ≫ ((c • 𝟙 (𝟙_ D)) ▷ X) ≫ (λ_ X).hom ≫ f := by + rw [MonoidalLinear.smul_whiskerRight, MonoidalCategory.id_whiskerRight, + Linear.smul_comp, Linear.comp_smul, Category.id_comp, + Iso.inv_hom_id_assoc] + +end SmulConj + +/-! ## The Day left unitor on corepresentables -/ + +section DayUnitCalculus + +attribute [local instance] dayConv +attribute [local instance] dayConvPlain + +variable {D : Type v} + +/-- The Day unit comparison carries the canonical unit element to +the identity. -/ +lemma dayUnitIso_hom_app_nu [SmallCategory D] [MonoidalCategory D] : + (dayUnitIso D).hom.natTrans.app (𝟙_ D) + (ν D (Type v) PUnit.unit) = 𝟙 (𝟙_ D) := by + have h := corepresentableBy_homEquiv_uniqueUpToIso_hom + (dayUnitCorepresentableBy (D := D)) + (coyonedaDayCorepresentableBy (𝟙_ D)) + rw [show (dayUnitCorepresentableBy (D := D)).uniqueUpToIso + (coyonedaDayCorepresentableBy (𝟙_ D)) = dayUnitIso D + from rfl] at h + refine h.trans ?_ + change coyonedaEquiv (𝟙 (coyoneda.obj (op (𝟙_ D)))) = 𝟙 (𝟙_ D) + rfl + +/-- The inverse of the Day unit comparison carries the identity to +the canonical unit element. -/ +lemma dayUnitIso_inv_app_id [SmallCategory D] [MonoidalCategory D] : + (dayUnitIso D).inv.natTrans.app (𝟙_ D) (𝟙 (𝟙_ D)) = + ν D (Type v) PUnit.unit := by + have h₀ := congrArg (fun t => t.natTrans.app (𝟙_ D)) + (dayUnitIso D).hom_inv_id + have h₁ := ConcreteCategory.congr_hom h₀ (ν D (Type v) PUnit.unit) + simp only [comp_natTrans, id_natTrans, NatTrans.comp_app] at h₁ + rw [← dayUnitIso_hom_app_nu] + exact h₁.trans rfl + +/-- Right-whiskering the inverse Day unit comparison carries the +canonical element of the Day tensor to the Kan-extension unit +evaluated on the canonical unit element. -/ +lemma whiskerRight_dayUnitIso_inv_app_unitElt + [SmallCategory D] [MonoidalCategory D] + (a : D) : + ((dayUnitIso D).inv ▷ + DayFunctor.mk (coyoneda.obj (op a))).natTrans.app (𝟙_ D ⊗ a) + (dayCoyonedaUnitElt (𝟙_ D) a) = + (η (𝟙_ (D ⊛⥤ Type v)) + (DayFunctor.mk (coyoneda.obj (op a)))).app (𝟙_ D, a) + ((ν D (Type v) PUnit.unit, 𝟙 a)) := by + have h₀ := congrArg (fun t => t.app (𝟙_ D ⊗ a)) + (natTrans_whiskerRight (dayUnitIso D).inv + (DayFunctor.mk (coyoneda.obj (op a)))) + have h₁ := ConcreteCategory.congr_hom h₀ (dayCoyonedaUnitElt (𝟙_ D) a) + have h₂' := DayConvolution.unit_app_map_app + (f := (dayUnitIso D).inv.natTrans) + (g := 𝟙 ((DayFunctor.mk (coyoneda.obj (op a))).functor)) + (x := 𝟙_ D) (y := a) + have h₂ : (DayConvolution.map (dayUnitIso D).inv.natTrans + (𝟙 ((DayFunctor.mk (coyoneda.obj (op a))).functor))).app + (𝟙_ D ⊗ a) (dayCoyonedaUnitElt (𝟙_ D) a) = + (η (𝟙_ (D ⊛⥤ Type v)) + (DayFunctor.mk (coyoneda.obj (op a)))).app (𝟙_ D, a) + (((dayUnitIso D).inv.natTrans.app (𝟙_ D) (𝟙 (𝟙_ D)), 𝟙 a)) := + ConcreteCategory.congr_hom h₂' + ((𝟙 (𝟙_ D), 𝟙 a) : ((𝟙_ D) ⟶ (𝟙_ D)) × (a ⟶ a)) + rw [h₁] + refine h₂.trans ?_ + exact congrArg + (fun z => (η (𝟙_ (D ⊛⥤ Type v)) + (DayFunctor.mk (coyoneda.obj (op a)))).app (𝟙_ D, a) + ((z, 𝟙 a))) + dayUnitIso_inv_app_id + +/-- **The Day left unitor, evaluated on a Kan-extension unit +element**: it strips the canonical unit element and applies the +inverse base left unitor. -/ +lemma day_leftUnitor_hom_app_eta [SmallCategory D] [MonoidalCategory D] + (F : D ⊛⥤ Type v) (y : D) + (x : F.functor.obj y) : + (λ_ F).hom.natTrans.app (𝟙_ D ⊗ y) + ((η (𝟙_ (D ⊛⥤ Type v)) F).app (𝟙_ D, y) + ((ν D (Type v) PUnit.unit, x))) = + F.functor.map (λ_ y).inv x := by + have h := LawfulDayConvolutionMonoidalCategoryStruct.leftUnitor_hom_unit_app + (C := D) (Type v) F y + have h' := ConcreteCategory.congr_hom h + ((PUnit.unit, x) : 𝟙_ (Type v) ⊗ F.functor.obj y) + exact h' + +/-- **The Day unit intertwines the left unitor on +corepresentables**: under the co-Yoneda identifications, the Day +left unitor at a corepresentable is precomposition with the inverse +base left unitor. -/ +lemma dayCoyonedaIso_hom_leftUnitor [SmallCategory D] [MonoidalCategory D] + (a : D) : + ((dayUnitIso D).hom ▷ DayFunctor.mk (coyoneda.obj (op a))) ≫ + (dayCoyonedaIso (𝟙_ D) a).hom ≫ + (⟨coyoneda.map ((λ_ a).inv.op)⟩ : + DayFunctor.mk (coyoneda.obj (op (𝟙_ D ⊗ a))) ⟶ + DayFunctor.mk (coyoneda.obj (op a))) = + (λ_ (DayFunctor.mk (coyoneda.obj (op a)))).hom := by + have aux : ((dayUnitIso D).inv ▷ + DayFunctor.mk (coyoneda.obj (op a))) ≫ + (λ_ (DayFunctor.mk (coyoneda.obj (op a)))).hom = + (dayCoyonedaIso (𝟙_ D) a).hom ≫ + (⟨coyoneda.map ((λ_ a).inv.op)⟩ : + DayFunctor.mk (coyoneda.obj (op (𝟙_ D ⊗ a))) ⟶ + DayFunctor.mk (coyoneda.obj (op a))) := by + apply (dayCoyonedaCorepresentableBy (𝟙_ D) a).homEquiv.injective + change (λ_ (DayFunctor.mk (coyoneda.obj (op a)))).hom.natTrans.app (𝟙_ D ⊗ a) + (((dayUnitIso D).inv ▷ DayFunctor.mk (coyoneda.obj (op a))).natTrans.app + (𝟙_ D ⊗ a) (dayCoyonedaUnitElt (𝟙_ D) a)) = + (coyoneda.map ((λ_ a).inv.op)).app (𝟙_ D ⊗ a) + ((dayCoyonedaIso (𝟙_ D) a).hom.natTrans.app (𝟙_ D ⊗ a) + (dayCoyonedaUnitElt (𝟙_ D) a)) + rw [dayCoyonedaIso_hom_app_unitElt, + whiskerRight_dayUnitIso_inv_app_unitElt, day_leftUnitor_hom_app_eta] + change 𝟙 a ≫ (λ_ a).inv = (λ_ a).inv ≫ 𝟙 (𝟙_ D ⊗ a) + rw [Category.id_comp, Category.comp_id] + rw [← aux, ← Category.assoc, ← MonoidalCategory.comp_whiskerRight, + Iso.hom_inv_id, MonoidalCategory.id_whiskerRight, + Category.id_comp] + +end DayUnitCalculus + +/-! ## The Yoneda form and the embedded left unitor -/ + +section IndUnit + +variable {C : Type v} + +/-- Composing the transports of an isomorphism and of its reverse +along `RS.dayMkIso`, in the reversed order. -/ +lemma dayMkIso_symm_hom_hom [SmallCategory C] [MonoidalCategory C] + {A B : Cᵒᵖ ⥤ Type v} (e : A ≅ B) : + (dayMkIso e.symm).hom ≫ (dayMkIso e).hom = + 𝟙 (DayFunctor.mk B : Cᵒᵖ ⊛⥤ Type v) := + (dayMkIso e).inv_hom_id + +/-- **The Day tensor of representables intertwines the left +unitor**: the Yoneda form of `RS.dayCoyonedaIso_hom_leftUnitor`. +The unit leg is the composite identification of the Day unit with +the representable at `𝟙_ C`, as in `RS.indOfUnitIso`. -/ +lemma dayYonedaIso_hom_leftUnitor [SmallCategory C] [MonoidalCategory C] + (x : C) : + (((dayUnitIso Cᵒᵖ).hom ≫ + (dayMkIso (Coyoneda.objOpOp (𝟙_ C))).hom) ▷ + DayFunctor.mk (yoneda.obj x)) ≫ + (dayYonedaIso (𝟙_ C) x).hom ≫ ⟨yoneda.map (λ_ x).hom⟩ = + (λ_ (DayFunctor.mk (yoneda.obj x))).hom := by + have s₂ : (⟨coyoneda.map ((λ_ (op x)).inv.op)⟩ : + DayFunctor.mk (coyoneda.obj (op (op (𝟙_ C) ⊗ op x))) ⟶ + DayFunctor.mk (coyoneda.obj (op (op x)))) ≫ + (dayMkIso (Coyoneda.objOpOp x)).hom = + (dayMkIso (Coyoneda.objOpOp (𝟙_ C ⊗ x))).hom ≫ + ⟨yoneda.map (λ_ x).hom⟩ := by + ext1 + exact coyoneda_map_op_op_comp_objOpOp_hom (λ_ x).hom + have hcu : ((dayUnitIso Cᵒᵖ).hom ▷ + DayFunctor.mk (coyoneda.obj (op (op x)))) ≫ + (dayCoyonedaIso (op (𝟙_ C)) (op x)).hom ≫ + (⟨coyoneda.map ((λ_ (op x)).inv.op)⟩ : + DayFunctor.mk (coyoneda.obj (op (op (𝟙_ C) ⊗ op x))) ⟶ + DayFunctor.mk (coyoneda.obj (op (op x)))) = + (λ_ (DayFunctor.mk (coyoneda.obj (op (op x))))).hom := + dayCoyonedaIso_hom_leftUnitor (D := Cᵒᵖ) (op x) + have e₁ : (((dayUnitIso Cᵒᵖ).hom ≫ + (dayMkIso (Coyoneda.objOpOp (𝟙_ C))).hom) ▷ + DayFunctor.mk (yoneda.obj x)) ≫ + ((dayMkIso (Coyoneda.objOpOp (𝟙_ C)).symm).hom ⊗ₘ + (dayMkIso (Coyoneda.objOpOp x).symm).hom) = + (𝟙_ (Cᵒᵖ ⊛⥤ Type v) ◁ + (dayMkIso (Coyoneda.objOpOp x).symm).hom) ≫ + ((dayUnitIso Cᵒᵖ).hom ▷ + DayFunctor.mk (coyoneda.obj (op (op x)))) := by + erw [← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom, Category.id_comp, + Category.assoc, comp_dayMkIso_hom_symm_hom, + MonoidalCategory.tensorHom_def'] + simp only [dayYonedaIso, Iso.trans_hom, tensorIso_hom, + Category.assoc] + rw [reassoc_of% e₁, ← s₂, reassoc_of% hcu, + MonoidalCategory.leftUnitor_naturality_assoc, + dayMkIso_symm_hom_hom, Category.comp_id] + +/-- The embedding into the Day presheaf category carries the unit +comparison to its Day-level composite. -/ +lemma indToDay_map_indOfUnitIso_hom [SmallCategory C] [MonoidalCategory C] : + (indToDay (C := C)).map (indOfUnitIso (C := C)).hom = + (Functor.Monoidal.εIso (indToDay (C := C))).inv ≫ + (dayUnitIso Cᵒᵖ).hom ≫ + (dayMkIso (Coyoneda.objOpOp (𝟙_ C))).hom ≫ + (indToDayIndOfIso (𝟙_ C)).inv := by + rw [indOfUnitIso, Functor.FullyFaithful.preimageIso_hom, + Functor.FullyFaithful.map_preimage] + simp only [Iso.trans_hom, Iso.symm_hom] + +/-- **Left unitality of the embedding comparison**: the left unitor +of an embedded object factors as the unit comparison, the +embedding-tensor comparison, and the embedded left unitor. This is +the unit axiom of the monoidal-functor-up-to-isomorphism structure +of `indOf`. -/ +lemma indOf_leftUnitor_hom [SmallCategory C] [MonoidalCategory C] + (X : C) : + (λ_ (indOf.obj X)).hom = + ((indOfUnitIso (C := C)).hom ▷ indOf.obj X) ≫ + (indOfTensorIso (𝟙_ C) X).hom ≫ indOf.map (λ_ X).hom := by + apply (indToDay (C := C)).map_injective + rw [Functor.map_comp, Functor.map_comp, + Functor.Monoidal.map_whiskerRight (F := indToDay (C := C)), + Functor.Monoidal.map_leftUnitor (F := indToDay (C := C)), + indToDay_map_indOfUnitIso_hom, indToDay_map_indOfTensorIso_hom] + simp only [indToDayTensorIso, Iso.trans_hom, Iso.symm_hom, + tensorIso_hom, Functor.Monoidal.μIso_inv, Category.assoc, + Functor.Monoidal.μ_δ_assoc, MonoidalCategory.comp_whiskerRight] + rw [← comp_indToDayIndOfIso_inv] + have hA : ((indToDayIndOfIso (𝟙_ C)).inv ▷ + (indToDay (C := C)).obj (indOf.obj X)) ≫ + ((indToDayIndOfIso (𝟙_ C)).hom ⊗ₘ (indToDayIndOfIso X).hom) = + DayFunctor.mk (yoneda.obj (𝟙_ C)) ◁ (indToDayIndOfIso X).hom := by + erw [← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom, Iso.inv_hom_id, + Category.id_comp, MonoidalCategory.id_tensorHom] + have hB : ((dayUnitIso Cᵒᵖ).hom ▷ + (indToDay (C := C)).obj (indOf.obj X)) ≫ + ((dayMkIso (Coyoneda.objOpOp (𝟙_ C))).hom ▷ + (indToDay (C := C)).obj (indOf.obj X)) ≫ + (DayFunctor.mk (yoneda.obj (𝟙_ C)) ◁ (indToDayIndOfIso X).hom) = + (𝟙_ (Cᵒᵖ ⊛⥤ Type v) ◁ (indToDayIndOfIso X).hom) ≫ + (((dayUnitIso Cᵒᵖ).hom ≫ + (dayMkIso (Coyoneda.objOpOp (𝟙_ C))).hom) ▷ + DayFunctor.mk (yoneda.obj X)) := by + rw [← MonoidalCategory.comp_whiskerRight_assoc] + exact (MonoidalCategory.whisker_exchange _ _).symm + rw [reassoc_of% hA, reassoc_of% hB, + reassoc_of% dayYonedaIso_hom_leftUnitor X, + MonoidalCategory.leftUnitor_naturality_assoc, Iso.hom_inv_id, + Category.comp_id, Functor.Monoidal.εIso_inv] + +/-- Iso form of `RS.indOf_leftUnitor_hom`. -/ +lemma indOf_leftUnitorIso [SmallCategory C] [MonoidalCategory C] + (X : C) : + λ_ (indOf.obj X) = + whiskerRightIso (indOfUnitIso (C := C)) (indOf.obj X) ≪≫ + indOfTensorIso (𝟙_ C) X ≪≫ indOf.mapIso (λ_ X) := + Iso.ext (by simpa using indOf_leftUnitor_hom X) + +/-- Inverse form of `RS.indOf_leftUnitor_hom`. -/ +lemma indOf_leftUnitor_inv [SmallCategory C] [MonoidalCategory C] + (X : C) : + (λ_ (indOf.obj X)).inv = + indOf.map (λ_ X).inv ≫ (indOfTensorIso (𝟙_ C) X).inv ≫ + ((indOfUnitIso (C := C)).inv ▷ indOf.obj X) := by + rw [indOf_leftUnitorIso X] + simp + +/-- **Transport of unit-endomorphism conjugates**: conjugating the +`indOfUnitIso`-transport of a unit endomorphism through the left +unitor of an embedded object is the image of the conjugate +downstairs. -/ +theorem indOf_map_unitConj [SmallCategory C] [MonoidalCategory C] + (X : C) (u : 𝟙_ C ⟶ 𝟙_ C) : + (λ_ (indOf.obj X)).inv ≫ + (((indOfUnitIso (C := C)).hom ≫ indOf.map u ≫ + (indOfUnitIso (C := C)).inv) ▷ indOf.obj X) ≫ + (λ_ (indOf.obj X)).hom = + indOf.map ((λ_ X).inv ≫ (u ▷ X) ≫ (λ_ X).hom) := by + rw [indOf_leftUnitor_hom X, indOf_leftUnitor_inv X] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc, + MonoidalCategory.inv_hom_whiskerRight_assoc] + rw [reassoc_of% indOfTensorIso_hom_natural_left u X, + Iso.inv_hom_id_assoc, Functor.map_comp, Functor.map_comp] + +end IndUnit + +/-! ## The scalar transport -/ + +section ScalarTransport + +variable {C : Type v} + +/-- The scalar unit of `Ind C`, evaluated: the +`indOfUnitIso`-conjugate of the embedded unit endomorphism. -/ +lemma indScalarUnit_apply [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] + (ψ : ℂ ≃+* End (𝟙_ C)) (c : ℂ) : + scalarHom (indScalarUnit ψ) c = + (indOfUnitIso (C := C)).hom ≫ indOf.map (ψ c) ≫ + (indOfUnitIso (C := C)).inv := + rfl + +/-- **The embedding intertwines the scalar actions**: `indOf` +carries `c • f` to the `RS.scalarSmul` action of `c` on the image, +for the scalar unit transported by `RS.indScalarUnit`. -/ +theorem indOf_map_smul [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] [Linear ℂ C] [MonoidalPreadditive C] + [MonoidalLinear ℂ C] + (ψ : ℂ ≃+* End (𝟙_ C)) + (hψ : ∀ c : ℂ, ψ c = c • 𝟙 (𝟙_ C)) (c : ℂ) {X Y : C} + (f : X ⟶ Y) : + indOf.map (c • f) = + scalarSmul (indScalarUnit ψ) c (indOf.map f) := by + rw [smul_eq_unitConj] + simp only [scalarSmul] + rw [indScalarUnit_apply ψ c, hψ c, + reassoc_of% indOf_map_unitConj X (c • 𝟙 (𝟙_ C)), + ← Functor.map_comp] + simp only [Category.assoc] + +end ScalarTransport + +/-! ## The algebra transport and the summit -/ + +section AlgebraTransport + +variable {E : Type u} + +/-- Intertwining `T` is closed under sums. Stated at general +objects and applied by `exact`, so the endomorphism-ring structure +never enters the rewriting. -/ +private theorem add_pass [Category.{v} E] + [Preadditive E] {P Q : E} {a b : P ⟶ P} + {a' b' : Q ⟶ Q} {T : P ⟶ Q} (ha : a ≫ T = T ≫ a') + (hb : b ≫ T = T ≫ b') : + (a + b) ≫ T = T ≫ (a' + b') := by + rw [Preadditive.add_comp, Preadditive.comp_add, ha, hb] + +/-- Intertwining `T` is closed under scalars. Stated at general +objects and applied by `exact`. -/ +private theorem smul_pass [Category.{v} E] + [Preadditive E] [Linear ℂ E] {P Q : E} + {a : P ⟶ P} {a' : Q ⟶ Q} {T : P ⟶ Q} (r : ℂ) + (h : a ≫ T = T ≫ a') : + (r • a) ≫ T = T ≫ (r • a') := by + rw [Linear.smul_comp, Linear.comp_smul, h] + +/-- **Transport of the group-algebra action**: under the ℂ-linear +structure induced on `Ind C` by a scalar unit `ψ` for `C`, the +action of the symmetric-group algebra on the tensor powers of an +embedded object is conjugate, under `RS.indOfPowIso`, to the +embedded action. -/ +theorem permAlg_indOf_conj {C : Type v} [SmallCategory C] [MonoidalCategory C] + [SymmetricCategory C] [Preadditive C] [Linear ℂ C] [HasFiniteColimits C] + [MonoidalPreadditive C] [MonoidalLinear ℂ C] + (ψ : ℂ ≃+* End (𝟙_ C)) + (hψ : ∀ c : ℂ, ψ c = c • 𝟙 (𝟙_ C)) (X : C) {n : ℕ} + (x : SymGroupAlgebra n) : + letI := linearOfScalarUnit (indScalarUnit ψ) + permAlg (indOf.obj X) n x ≫ (indOfPowIso X n).hom = + (indOfPowIso X n).hom ≫ indOf.map (permAlg X n x) := by + let := linearOfScalarUnit (indScalarUnit ψ) + have := indOf_additive (C := C) + induction x using MonoidAlgebra.induction_on with + | of σ => + rw [MonoidAlgebra.of_apply, permAlg_single, permAlg_single] + exact indOfPowIso_permMor X n σ + | add p q hp hq => + rw [map_add, map_add] + exact (add_pass hp hq).trans + (congrArg (fun m => (indOfPowIso X n).hom ≫ m) + (Functor.map_add (F := indOf (C := C))).symm) + | smul c p hp => + rw [map_smul, map_smul] + exact (smul_pass c hp).trans + (congrArg (fun m => (indOfPowIso X n).hom ≫ m) + (indOf_map_smul ψ hψ c (permAlg X n p)).symm) + +/-- **Schur-vanishing transport along the embedding `C ⥤ Ind C`**: +with the ℂ-linear structure induced on `Ind C` by a scalar unit for +`C`, a shape kills an embedded object precisely when it kills the +object downstairs. -/ +theorem schurKilled_indOf_iff + {C : Type v} [SmallCategory C] [MonoidalCategory C] + [SymmetricCategory C] [Preadditive C] [Linear ℂ C] [HasFiniteColimits C] + [MonoidalPreadditive C] [MonoidalLinear ℂ C] + (P : SchurPackage.{v}) + (ψ : ℂ ≃+* End (𝟙_ C)) (hψ : ∀ c : ℂ, ψ c = c • 𝟙 (𝟙_ C)) + {X : C} {μ : YoungDiagram} : + letI := linearOfScalarUnit (indScalarUnit ψ) + (SchurKilled P (indOf.obj X) μ ↔ SchurKilled P X μ) := by + let := linearOfScalarUnit (indScalarUnit ψ) + have hconj : permAlg (indOf.obj X) μ.card (P.e μ) = + (indOfPowIso X μ.card).hom ≫ + indOf.map (permAlg X μ.card (P.e μ)) ≫ + (indOfPowIso X μ.card).inv := by + rw [← reassoc_of% permAlg_indOf_conj ψ hψ X (P.e μ), + Iso.hom_inv_id, Category.comp_id] + constructor + · intro h0 + rw [schurKilled_iff_indOf_map_permAlg_eq_zero P X μ] + have h0' : permAlg (indOf.obj X) μ.card (P.e μ) = + (0 : tensorPow (Ind C) (indOf.obj X) μ.card ⟶ + tensorPow (Ind C) (indOf.obj X) μ.card) := h0 + rw [hconj] at h0' + have h1 := (indOfPowIso X μ.card).inv ≫= h0' =≫ + (indOfPowIso X μ.card).hom + simpa using h1 + · intro h0 + change permAlg (indOf.obj X) μ.card (P.e μ) = 0 + rw [hconj, (schurKilled_iff_indOf_map_permAlg_eq_zero P X μ).mp h0, + zero_comp, comp_zero] + + +/-- `RS.schurKilled_indOf_iff`, instantiated at the scalar unit of +a category whose unit endomorphisms are exactly the scalars. -/ +theorem schurKilled_indOf_iff_of_hasScalarUnit + {C : Type v} [SmallCategory C] [MonoidalCategory C] + [SymmetricCategory C] [Preadditive C] [Linear ℂ C] [HasFiniteColimits C] + [MonoidalPreadditive C] [MonoidalLinear ℂ C] + (P : SchurPackage.{v}) + (hu : HasScalarUnit C) {X : C} {μ : YoungDiagram} : + letI := linearOfScalarUnit + (indScalarUnit (unitScalarEquiv hu).toRingEquiv) + (SchurKilled P (indOf.obj X) μ ↔ SchurKilled P X μ) := + schurKilled_indOf_iff P (unitScalarEquiv hu).toRingEquiv + (fun _ => rfl) + +end AlgebraTransport + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurVanishing.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurVanishing.lean new file mode 100644 index 0000000000..63271c0aca --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurVanishing.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPermCast + +/-! +# Schur-functor vanishing at the idempotent level + +Deligne's Schur functor `S_μ(X)` (Catégories tensorielles, 1.4) is +the multiplicity space of the shape `μ` in the tensor power +`X ^ ⊗ μ.card`; its vanishing is equivalent to the vanishing of the +`μ`-isotypic summand, which is the image of the central idempotent +`e μ` acting through `permAlg`. This module phrases the condition +on the idempotent's action — no image objects are needed — and +proves Deligne's upward closure (Catégories tensorielles, 1.7) from +the Schur package alone: `branching` puts a nonzero sandwich +`e μ · (e λ ⊗ 1) · e μ` in the block of `μ`, `block_faithful` +turns nonvanishing of `e μ`'s action into injectivity on that +block, and `permAlg_compat` carries the vanishing of `e λ`'s +action up the standard embedding. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +variable {A : Type u} + +/-- **Schur vanishing**: the shape `μ` kills `X` when the central +idempotent of its block acts as zero on the `μ.card`-th tensor +power of `X`. This is the vanishing of the `μ`-isotypic summand +of `X ^ ⊗ μ.card`, i.e. of Deligne's Schur functor `S_μ(X)`. -/ +def SchurKilled [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] + (P : SchurPackage.{v}) (X : A) (μ : YoungDiagram) : + Prop := + permAlg X μ.card (P.e μ) = 0 + +/-- **Upward closure of Schur vanishing** (Catégories +tensorielles, 1.7): if the shape `λ` kills `X` then so does every +shape containing it. -/ +theorem SchurKilled.mono + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] + (P : SchurPackage.{v}) {X : A} + {lam mu : YoungDiagram} (hle : lam ≤ mu) + (h : SchurKilled P X lam) : SchurKilled P X mu := by + by_contra hne + have hcard : lam.card ≤ mu.card := YoungDiagram.card_le_card hle + have hlow : permAlg X mu.card (symCast hcard (P.e lam)) = 0 := + permAlg_compat X hcard _ h + have hz : permAlg X mu.card + (P.e mu * (symCast hcard (P.e lam) * P.e mu)) = 0 := by + rw [map_mul, map_mul, hlow, zero_mul, mul_zero] + have hker := P.block_faithful mu _ (permAlg X mu.card) hne _ hz + rw [← mul_assoc] at hker + exact P.branching lam mu hle hcard hker +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SeedIns.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SeedIns.lean new file mode 100644 index 0000000000..6eb518497c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SeedIns.lean @@ -0,0 +1,2536 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.InterchangeAct +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGr + +/-! +# The seed entries of the splitting data + +The three entry maps of the splitting algebra: the base algebra, +the module, and the dual module enter the two-index chain stages +through the seed element. These are the stage-level precursors +of the `ofBase`, `ins` and `ins'` fields of the splitting data of +the Key Lemma. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The base entry**: the base algebra acts on the seed element +in the bottom stage. -/ +noncomputable def chainBaseStage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + A ⟶ chainStage2 A M M' 0 0 := + (ρ_ A).inv ≫ + MonoidalCategory.whiskerLeft A + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + modTensorAct A (symPowMod A M'.X 0) (symPowMod A M.X 0) + +/-- **The module entry**: the module joins the seed element in +the second slot, one degree up. -/ +noncomputable def chainSeedQ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + M.X ⟶ chainStage2 A M M' 0 1 := + (ρ_ M.X).inv ≫ + MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainInsQ A M M' 0 0 + +/-- **The dual entry**: the dual module joins the seed element in +the first slot, one degree down. -/ +noncomputable def chainSeedP + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + M'.X ⟶ chainStage2 A M M' 1 0 := + (ρ_ M'.X).inv ≫ + MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainInsP A M M' 0 0 + +/-- The unit of the base enters as the seed element. -/ +theorem unit_chainBaseStage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + η[A] ≫ chainBaseStage A M M' d = chainSeed A M M' d := by + have h1 : η[A] ≫ (ρ_ A).inv = + (ρ_ (𝟙_ D)).inv ≫ + MonoidalCategory.whiskerRight η[A] (𝟙_ D) := + rightUnitor_inv_naturality _ + have h2 : MonoidalCategory.whiskerRight η[A] (𝟙_ D) ≫ + MonoidalCategory.whiskerLeft A + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) = + MonoidalCategory.whiskerLeft (𝟙_ D) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + MonoidalCategory.whiskerRight η[A] + (chainStage2 A M M' 0 0) := + (whisker_exchange _ _).symm + have h3 : MonoidalCategory.whiskerRight η[A] + (chainStage2 A M M' 0 0) ≫ + modTensorAct A (symPowMod A M'.X 0) (symPowMod A M.X 0) = + (λ_ (chainStage2 A M M' 0 0)).hom := modTensorAct_one A _ _ + have h4 : MonoidalCategory.whiskerLeft (𝟙_ D) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + (λ_ (chainStage2 A M M' 0 0)).hom = + (λ_ (𝟙_ D)).hom ≫ chainSeed A M M' d := + leftUnitor_naturality _ + erw [chainBaseStage, reassoc_of% h1, reassoc_of% h2] + exact (congrArg (fun t => (ρ_ (𝟙_ D)).inv ≫ + MonoidalCategory.whiskerLeft (𝟙_ D) + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d) ≫ t) h3).trans + ((congrArg (fun t => (ρ_ (𝟙_ D)).inv ≫ t) h4).trans + (by rw [unitors_equal]; exact Iso.inv_hom_id_assoc _ _)) + +/-! ## The entries against the base action -/ + +/-- The base action commutes with the stage transports. -/ +theorem chainStage2Cast_actLeft + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + {p q p' q' : ℕ} (hp : p = p') (hq : q = q') : + (A ◁ chainStage2Cast A M M' hp hq) ≫ + modTensorAct A (symPowMod A M'.X p') (symPowMod A M.X q') = + modTensorAct A (symPowMod A M'.X p) (symPowMod A M.X q) ≫ + chainStage2Cast A M M' hp hq := by + subst hp hq + erw [chainStage2Cast_rfl, MonoidalCategory.whiskerLeft_id, + Category.id_comp, Category.comp_id] + +/-- **The two-index transition is linear over the base**: acting +on a stage and raising is raising and acting. -/ +theorem chainDelta2_actLeft + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (p q : ℕ) : + (A ◁ chainDelta2 A M M' d p q) ≫ + modTensorAct A (symPowMod A M'.X (p + 1)) (symPowMod A M.X (q + 1)) = + modTensorAct A (symPowMod A M'.X p) (symPowMod A M.X q) ≫ + chainDelta2 A M M' d p q := by + have ha : (A ◁ chainMul2 A M M' p q 0 0) ≫ + modTensorAct A (symPowMod A M'.X (p + 1)) + (symPowMod A M.X (q + 1)) = + (α_ A (chainStage2 A M M' p q) + (chainStage2 A M M' 0 0)).inv ≫ + (modTensorAct A (symPowMod A M'.X p) + (symPowMod A M.X q) ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p q 0 0 := by + have h := chainMul2_actLeft A M M' p q 0 0 + have h' := congrArg (fun t => (α_ A + (modTensor A (symPowMod A M'.X p) (symPowMod A M.X q)) + (modTensor A (symPowMod A M'.X 0) + (symPowMod A M.X 0))).inv ≫ t) h + exact (h'.trans (Iso.inv_hom_id_assoc _ _)).symm + have hc : (A ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + (α_ A (chainStage2 A M M' p q) + (chainStage2 A M M' 0 0)).inv = + (α_ A (chainStage2 A M M' p q) (𝟙_ D)).inv ≫ + MonoidalCategory.whiskerLeft + (A ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d) := + associator_inv_naturality_right _ _ _ + have hd : MonoidalCategory.whiskerLeft + (A ⊗ chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + (modTensorAct A (symPowMod A M'.X p) + (symPowMod A M.X q) ▷ chainStage2 A M M' 0 0) = + (modTensorAct A (symPowMod A M'.X p) + (symPowMod A M.X q) ▷ 𝟙_ D) ≫ + MonoidalCategory.whiskerLeft (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d) := + whisker_exchange _ _ + have he : (A ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (α_ A (chainStage2 A M M' p q) (𝟙_ D)).inv = + (ρ_ (A ⊗ chainStage2 A M M' p q)).inv := by + monoidal + have hf : (ρ_ (A ⊗ chainStage2 A M M' p q)).inv ≫ + (modTensorAct A (symPowMod A M'.X p) + (symPowMod A M.X q) ▷ 𝟙_ D) = + modTensorAct A (symPowMod A M'.X p) (symPowMod A M.X q) ≫ + (ρ_ (chainStage2 A M M' p q)).inv := + (rightUnitor_inv_naturality _).symm + have hsplit : A ◁ chainDelta2 A M M' d p q = + (A ◁ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + (A ◁ MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ≫ + (A ◁ chainMul2 A M M' p q 0 0) := by + rw [chainDelta2, MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp] + refine Eq.trans (eq_whisker hsplit + (modTensorAct A (symPowMod A M'.X (p + 1)) + (symPowMod A M.X (q + 1)))) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ ha)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker hc _)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (Category.assoc _ _ _).symm)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (eq_whisker hd _))) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (Category.assoc _ _ _))) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker he _) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker hf _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (by rw [chainDelta2]; rfl) + +/-- **Multiplication by the base entry on the left** is the stage +action followed by the transition, up to the index transport. -/ +theorem chainBaseStage_mul2 + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') (p q : ℕ) : + (chainBaseStage A M M' d ▷ chainStage2 A M M' p q) ≫ + chainMul2 A M M' 0 0 p q = + modTensorAct A (symPowMod A M'.X p) (symPowMod A M.X q) ≫ + chainDelta2 A M M' d p q ≫ + chainStage2Cast A M M' (by omega : p + 1 = 0 + 1 + p) + (by omega : q + 1 = 0 + 1 + q) := by + have hsplit : chainBaseStage A M M' d ▷ + chainStage2 A M M' p q = + ((ρ_ A).inv ▷ chainStage2 A M M' p q) ≫ + (MonoidalCategory.whiskerLeft A + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ▷ + chainStage2 A M M' p q) ≫ + (modTensorAct A (symPowMod A M'.X 0) + (symPowMod A M.X 0) ▷ chainStage2 A M M' p q) := by + erw [chainBaseStage, MonoidalCategory.comp_whiskerRight, + MonoidalCategory.comp_whiskerRight] + rfl + have hb : (modTensorAct A (symPowMod A M'.X 0) + (symPowMod A M.X 0) ▷ chainStage2 A M M' p q) ≫ + chainMul2 A M M' 0 0 p q = + (α_ A (chainStage2 A M M' 0 0) + (chainStage2 A M M' p q)).hom ≫ + (A ◁ chainMul2 A M M' 0 0 p q) ≫ + modTensorAct A (symPowMod A M'.X (0 + 1 + p)) + (symPowMod A M.X (0 + 1 + q)) := + chainMul2_actLeft A M M' 0 0 p q + have hm : (MonoidalCategory.whiskerLeft A + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ▷ + chainStage2 A M M' p q) ≫ + (α_ A (chainStage2 A M M' 0 0) + (chainStage2 A M M' p q)).hom = + (α_ A (𝟙_ D) (chainStage2 A M M' p q)).hom ≫ + (A ◁ (chainSeed A M M' d ▷ chainStage2 A M M' p q)) := + associator_naturality_middle _ _ _ + have hwm : (A ◁ (chainSeed A M M' d ▷ + chainStage2 A M M' p q)) ≫ + (A ◁ chainMul2 A M M' 0 0 p q) = + A ◁ ((chainSeed A M M' d ▷ chainStage2 A M M' p q) ≫ + chainMul2 A M M' 0 0 p q) := + (MonoidalCategory.whiskerLeft_comp _ _ _).symm + have hA : A ◁ ((chainSeed A M M' d ▷ + chainStage2 A M M' p q) ≫ chainMul2 A M M' 0 0 p q) = + A ◁ ((λ_ (chainStage2 A M M' p q)).hom ≫ + chainDelta2 A M M' d p q ≫ + chainStage2Cast A M M' (by omega : p + 1 = 0 + 1 + p) + (by omega : q + 1 = 0 + 1 + q)) := + congrArg (fun t : 𝟙_ D ⊗ chainStage2 A M M' p q ⟶ + chainStage2 A M M' (0 + 1 + p) (0 + 1 + q) => A ◁ t) + (chainSeed_mul2_left A M M' d p q) + have hr : ((ρ_ A).inv ▷ chainStage2 A M M' p q) ≫ + (α_ A (𝟙_ D) (chainStage2 A M M' p q)).hom = + A ◁ (λ_ (chainStage2 A M M' p q)).inv := by + monoidal + have hmerge : (A ◁ (λ_ (chainStage2 A M M' p q)).inv) ≫ + (A ◁ ((λ_ (chainStage2 A M M' p q)).hom ≫ + chainDelta2 A M M' d p q ≫ + chainStage2Cast A M M' (by omega : p + 1 = 0 + 1 + p) + (by omega : q + 1 = 0 + 1 + q))) = + A ◁ (chainDelta2 A M M' d p q ≫ + chainStage2Cast A M M' (by omega : p + 1 = 0 + 1 + p) + (by omega : q + 1 = 0 + 1 + q)) := + (MonoidalCategory.whiskerLeft_comp _ _ _).symm.trans + (congrArg (fun t : chainStage2 A M M' p q ⟶ + chainStage2 A M M' (0 + 1 + p) (0 + 1 + q) => A ◁ t) + (Iso.inv_hom_id_assoc _ _)) + have hcast : (A ◁ chainStage2Cast A M M' + (by omega : p + 1 = 0 + 1 + p) + (by omega : q + 1 = 0 + 1 + q)) ≫ + modTensorAct A (symPowMod A M'.X (0 + 1 + p)) + (symPowMod A M.X (0 + 1 + q)) = + modTensorAct A (symPowMod A M'.X (p + 1)) + (symPowMod A M.X (q + 1)) ≫ + chainStage2Cast A M M' + (by omega : p + 1 = 0 + 1 + p) + (by omega : q + 1 = 0 + 1 + q) := + chainStage2Cast_actLeft A M M' _ _ + refine Eq.trans (eq_whisker hsplit + (chainMul2 A M M' 0 0 p q)) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ hb)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker hm _)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (Category.assoc _ _ _).symm)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (eq_whisker hwm _))) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (eq_whisker hA _))) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker hr _) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker hmerge _) ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp _ _ _) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ hcast) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (chainDelta2_actLeft A M M' d p q) _) ?_ + exact Category.assoc _ _ _ + +/-! ## The letter action against the insertions -/ + +section LetterAct + +/-- **The insertion is compatible with the action on the inserted +letter**: acting on the letter and inserting is inserting and +acting on the enlarged power. -/ +theorem symInsL_actLetter + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X : D) [ModObj A X] (n : ℕ) : + (actLeft A X ▷ symPow A X (n + 1)) ≫ symInsL A X n = + (α_ A X (symPow A X (n + 1))).hom ≫ + (A ◁ symInsL A X n) ≫ symPowAct A X (n + 1) := by + have h1 : actLeft A X ≫ (symPowOne A X).inv = + (A ◁ (symPowOne A X).inv) ≫ symPowAct A X 0 := + actLeft_symPowOne_inv A X + have h2 : (symPowAct A X 0 ▷ symPow A X (n + 1)) ≫ + symMul A X 1 (n + 1) = + (α_ A (symPow A X 1) (symPow A X (n + 1))).hom ≫ + (A ◁ symMul A X 1 (n + 1)) ≫ + symPowAct A X (1 + n) := by + have h := symMul_actLeft A X 0 n + have h' := congrArg (fun t => + (α_ A (symPow A X (0 + 1)) + (symPow A X (n + 1))).hom ≫ t) h + exact (Iso.hom_inv_id_assoc _ _).symm.trans h' + have h3 : symPowAct A X (1 + n) ≫ + symPowCast A X (by omega : 1 + (n + 1) = n + 2) = + (A ◁ symPowCast A X + (by omega : 1 + (n + 1) = n + 2)) ≫ + symPowAct A X (n + 1) := + symPowAct_symPowCast A X (by omega) + have h4 : ((A ◁ (symPowOne A X).inv) ▷ symPow A X (n + 1)) ≫ + (α_ A (symPow A X 1) (symPow A X (n + 1))).hom = + (α_ A X (symPow A X (n + 1))).hom ≫ + (A ◁ ((symPowOne A X).inv ▷ symPow A X (n + 1))) := + associator_naturality_middle _ _ _ + rw [symInsL, MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp, + ← MonoidalCategory.comp_whiskerRight_assoc, h1, + MonoidalCategory.comp_whiskerRight] + simp only [Category.assoc] + rw [reassoc_of% h2, h3, reassoc_of% h4] + +end LetterAct + +/-- **The first-slot insertion is linear over the base in the +letter**: acting on the inserted dual module and inserting is +inserting and acting on the raised stage. -/ +theorem chainInsP_actLetter + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) (p q : ℕ) : + (actLeft A M'.X ▷ chainStage2 A M M' p q) ≫ + chainInsP A M M' p q = + (α_ A M'.X (chainStage2 A M M' p q)).hom ≫ + (A ◁ chainInsP A M M' p q) ≫ + modTensorAct A (symPowMod A M'.X (p + 1)) (symPowMod A M.X q) := by + have l1 : ((A ⊗ M'.X) ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q)) ≫ + (actLeft A M'.X ▷ chainStage2 A M M' p q) = + (actLeft A M'.X ▷ + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1))) ≫ + (M'.X ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q)) := + whisker_exchange _ _ + have l3 : (actLeft A M'.X ▷ + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1))) ≫ + (α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv = + (α_ (A ⊗ M'.X) (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((actLeft A M'.X ▷ symPow A M'.X (p + 1)) ▷ + symPow A M.X (q + 1)) := + associator_inv_naturality_left _ _ _ + have r1 : ((A ⊗ M'.X) ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q)) ≫ + (α_ A M'.X (chainStage2 A M M' p q)).hom = + (α_ A M'.X + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1))).hom ≫ + (A ◁ (M'.X ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q))) := + associator_naturality_right _ _ _ + have r4 : (A ◁ modTensorπ A (symPowMod A M'.X (p + 1)) + (symPowMod A M.X q)) ≫ + modTensorAct A (symPowMod A M'.X (p + 1)) + (symPowMod A M.X q) = + ((α_ A (symPow A M'.X (p + 2)) + (symPow A M.X (q + 1))).inv ≫ + (symPowAct A M'.X (p + 1) ▷ symPow A M.X (q + 1))) ≫ + modTensorπ A (symPowMod A M'.X (p + 1)) + (symPowMod A M.X q) := + whiskerLeft_modTensorπ_act A _ _ + have hmid : (A ◁ (symInsL A M'.X p ▷ + symPow A M.X (q + 1))) ≫ + (α_ A (symPow A M'.X (p + 2)) + (symPow A M.X (q + 1))).inv = + (α_ A (M'.X ⊗ symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((A ◁ symInsL A M'.X p) ▷ symPow A M.X (q + 1)) := + associator_inv_naturality_middle _ _ _ + have hcoh : (α_ (A ⊗ M'.X) (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv ≫ + ((α_ A M'.X (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 1)) = + (α_ A M'.X + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1))).hom ≫ + (A ◁ (α_ M'.X (symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv) ≫ + (α_ A (M'.X ⊗ symPow A M'.X (p + 1)) + (symPow A M.X (q + 1))).inv := by + monoidal + refine (cancel_epi ((A ⊗ M'.X) ◁ + modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q))).mp ?_ + -- The action side reduces to the symmetric-power level. + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker l1 _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (whiskerLeft_π_chainInsP A M M' p q)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker l3 _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + ((Category.assoc _ _ _).symm.trans (eq_whisker + (MonoidalCategory.comp_whiskerRight _ _ _).symm _))) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + (congrArg (fun t : (A ⊗ M'.X) ⊗ symPow A M'.X (p + 1) ⟶ + symPow A M'.X (p + 2) => t ▷ symPow A M.X (q + 1)) + (symInsL_actLetter A M'.X p)) _)) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + ((MonoidalCategory.comp_whiskerRight _ _ _).trans + (whisker_eq _ + (MonoidalCategory.comp_whiskerRight _ _ _))) _)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (Category.assoc _ _ _))) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker hcoh _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + -- The insertion side reduces to the same normal form. + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker r1 _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + (MonoidalCategory.whiskerLeft_comp _ _ _).symm _)) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + (congrArg (fun t : M'.X ⊗ + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) ⟶ + chainStage2 A M M' (p + 1) q => A ◁ t) + (whiskerLeft_π_chainInsP A M M' p q)) _)) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + ((MonoidalCategory.whiskerLeft_comp _ _ _).trans + (whisker_eq _ + (MonoidalCategory.whiskerLeft_comp _ _ _))) _)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (Category.assoc _ _ _))) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (whisker_eq _ r4))) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (whisker_eq _ (Category.assoc _ _ _)))) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (Category.assoc _ _ _).symm)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (eq_whisker hmid _))) ?_ + exact whisker_eq _ (whisker_eq _ (Category.assoc _ _ _)) + +/-- **The dual entry is linear over the base**: the action on the +dual module followed by the entry is the entry followed by the +stage action. -/ +theorem chainSeedP_linear + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + actLeft A M'.X ≫ chainSeedP A M M' d = + (A ◁ chainSeedP A M M' d) ≫ + modTensorAct A (symPowMod A M'.X 1) (symPowMod A M.X 0) := by + have hsplit : chainSeedP A M M' d = + (ρ_ M'.X).inv ≫ + MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainInsP A M M' 0 0 := rfl + have h1 : actLeft A M'.X ≫ (ρ_ M'.X).inv = + (ρ_ (A ⊗ M'.X)).inv ≫ (actLeft A M'.X ▷ 𝟙_ D) := + rightUnitor_inv_naturality _ + have h2 : (actLeft A M'.X ▷ 𝟙_ D) ≫ + MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) = + MonoidalCategory.whiskerLeft (A ⊗ M'.X) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + (actLeft A M'.X ▷ chainStage2 A M M' 0 0) := + (whisker_exchange _ _).symm + have h3 : (actLeft A M'.X ▷ chainStage2 A M M' 0 0) ≫ + chainInsP A M M' 0 0 = + (α_ A M'.X (chainStage2 A M M' 0 0)).hom ≫ + (A ◁ chainInsP A M M' 0 0) ≫ + modTensorAct A (symPowMod A M'.X 1) + (symPowMod A M.X 0) := + chainInsP_actLetter A M M' 0 0 + have h4 : MonoidalCategory.whiskerLeft (A ⊗ M'.X) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + (α_ A M'.X (chainStage2 A M M' 0 0)).hom = + (α_ A M'.X (𝟙_ D)).hom ≫ + (A ◁ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) := + associator_naturality_right _ _ _ + have h5 : (ρ_ (A ⊗ M'.X)).inv ≫ (α_ A M'.X (𝟙_ D)).hom = + A ◁ (ρ_ M'.X).inv := by + monoidal + refine Eq.trans (whisker_eq _ hsplit) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker h1 _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker h2 _)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ h3)) ?_ + refine Eq.trans (whisker_eq _ + (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker h4 _)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker h5 _) ?_ + refine Eq.symm ?_ + refine Eq.trans (eq_whisker + (congrArg (fun t : M'.X ⟶ chainStage2 A M M' 1 0 => + A ◁ t) hsplit) _) ?_ + refine Eq.trans (eq_whisker + ((MonoidalCategory.whiskerLeft_comp _ _ _).trans + (whisker_eq _ + (MonoidalCategory.whiskerLeft_comp _ _ _))) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (Category.assoc _ _ _) + +/-- The braided crossing of a tensor pair past a factor splits +into the crossings of its parts, one on either side of the +carried slot. -/ +private theorem letter_cross_struct_aux + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (P Q V T : D) : + (α_ (P ⊗ Q) V T).inv ≫ ((β_ (P ⊗ Q) V).hom ▷ T) ≫ + (α_ V (P ⊗ Q) T).hom = + (α_ P Q (V ⊗ T)).hom ≫ (P ◁ (α_ Q V T).inv) ≫ + (P ◁ ((β_ Q V).hom ▷ T)) ≫ (P ◁ (α_ V Q T).hom) ≫ + (α_ P V (Q ⊗ T)).inv ≫ ((β_ P V).hom ▷ (Q ⊗ T)) ≫ + (α_ V P (Q ⊗ T)).hom ≫ (V ◁ (α_ P Q T).inv) := by + rw [BraidedCategory.braiding_tensor_left_hom] + simp only [MonoidalCategory.comp_whiskerRight, + Category.assoc] + monoidal + +/-- Acting on a letter destined for the second slot commutes with +the braided crossing: the acting object crosses the first factor +alongside the letter and acts once the letter has entered. -/ +private theorem letter_cross_snd_aux + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + {P Q V T T' W : D} (u : P ⊗ Q ⟶ Q) (f : Q ⊗ T ⟶ T') (a' : P ⊗ T' ⟶ T') + (w : V ⊗ T' ⟶ W) (hf : (P ◁ f) ≫ a' = + (α_ P Q T).inv ≫ (u ▷ T) ≫ f) : + (u ▷ (V ⊗ T)) ≫ ((α_ Q V T).inv ≫ + ((β_ Q V).hom ▷ T) ≫ (α_ V Q T).hom ≫ + (V ◁ f) ≫ w) = + (α_ P Q (V ⊗ T)).hom ≫ ((P ◁ (α_ Q V T).inv) ≫ + (P ◁ ((β_ Q V).hom ▷ T)) ≫ (P ◁ (α_ V Q T).hom) ≫ + (P ◁ (V ◁ f)) ≫ ((α_ P V T').inv ≫ + ((β_ P V).hom ▷ T') ≫ (α_ V P T').hom ≫ + (V ◁ a') ≫ w)) := by + have hfV : (V ◁ (P ◁ f)) ≫ (V ◁ a') = + (V ◁ (α_ P Q T).inv) ≫ (V ◁ (u ▷ T)) ≫ (V ◁ f) := by + rw [← MonoidalCategory.whiskerLeft_comp, hf] + simp only [MonoidalCategory.whiskerLeft_comp] + rw [associator_inv_naturality_left_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, + BraidedCategory.braiding_naturality_left, + MonoidalCategory.comp_whiskerRight_assoc, + associator_naturality_middle_assoc, + associator_inv_naturality_right_assoc, + whisker_exchange_assoc, + associator_naturality_right_assoc, + reassoc_of% hfV, + reassoc_of% (letter_cross_struct_aux P Q V T)] + +/-- **The second-slot insertion is linear over the base in the +letter**: acting on the inserted module and inserting is +inserting and acting on the raised stage. The letter enters the +second slot through the braided crossing, while the descended +action passes through the first factor; over a symmetric base the +two meet in the second slot. -/ +theorem chainInsQ_actLetter + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) (p q : ℕ) : + (actLeft A M.X ▷ chainStage2 A M M' p q) ≫ + chainInsQ A M M' p q = + (α_ A M.X (chainStage2 A M M' p q)).hom ≫ + (A ◁ chainInsQ A M M' p q) ≫ + modTensorAct A (symPowMod A M'.X p) (symPowMod A M.X (q + 1)) := by + have hf : (A ◁ symInsL A M.X q) ≫ symPowAct A M.X (q + 1) = + (α_ A M.X (symPow A M.X (q + 1))).inv ≫ + (actLeft A M.X ▷ symPow A M.X (q + 1)) ≫ + symInsL A M.X q := by + rw [symInsL_actLetter A M.X q, Iso.inv_hom_id_assoc] + have l1 : ((A ⊗ M.X) ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q)) ≫ + (actLeft A M.X ▷ chainStage2 A M M' p q) = + (actLeft A M.X ▷ + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1))) ≫ + (M.X ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q)) := + whisker_exchange _ _ + have r1 : ((A ⊗ M.X) ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q)) ≫ + (α_ A M.X (chainStage2 A M M' p q)).hom = + (α_ A M.X + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1))).hom ≫ + (A ◁ (M.X ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q))) := + associator_naturality_right _ _ _ + have r4 : (A ◁ modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X (q + 1))) ≫ + modTensorAct A (symPowMod A M'.X p) + (symPowMod A M.X (q + 1)) = + (α_ A (symPow A M'.X (p + 1)) + (symPow A M.X (q + 2))).inv ≫ + ((β_ A (symPow A M'.X (p + 1))).hom ▷ + symPow A M.X (q + 2)) ≫ + (α_ (symPow A M'.X (p + 1)) A + (symPow A M.X (q + 2))).hom ≫ + (symPow A M'.X (p + 1) ◁ symPowAct A M.X (q + 1)) ≫ + modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X (q + 1)) := + whiskerLeft_modTensorπ_act_snd A _ _ + refine (cancel_epi ((A ⊗ M.X) ◁ + modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X q))).mp ?_ + -- The action side reduces through the crossing helper. + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker l1 _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (whiskerLeft_π_chainInsQ A M M' p q)) ?_ + refine Eq.trans (letter_cross_snd_aux + (V := symPow A M'.X (p + 1)) (actLeft A M.X) + (symInsL A M.X q) (symPowAct A M.X (q + 1)) + (modTensorπ A (symPowMod A M'.X p) + (symPowMod A M.X (q + 1))) hf) ?_ + -- The insertion side reduces to the same normal form. + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker r1 _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + (MonoidalCategory.whiskerLeft_comp _ _ _).symm _)) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + (congrArg (fun t : M.X ⊗ + (symPow A M'.X (p + 1) ⊗ symPow A M.X (q + 1)) ⟶ + chainStage2 A M M' p (q + 1) => A ◁ t) + (whiskerLeft_π_chainInsQ A M M' p q)) _)) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + ((MonoidalCategory.whiskerLeft_comp _ _ _).trans + (whisker_eq _ + ((MonoidalCategory.whiskerLeft_comp _ _ _).trans + (whisker_eq _ + ((MonoidalCategory.whiskerLeft_comp _ _ _).trans + (whisker_eq _ + (MonoidalCategory.whiskerLeft_comp + _ _ _))))))) _)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (Category.assoc _ _ _))) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ (whisker_eq _ + (Category.assoc _ _ _)))) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ (whisker_eq _ + (whisker_eq _ (Category.assoc _ _ _))))) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ (whisker_eq _ + (whisker_eq _ (whisker_eq _ r4))))) ?_ + rfl + +/-- **The module entry is linear over the base**: the action on +the module followed by the entry is the entry followed by the +stage action. -/ +theorem chainSeedQ_linear + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + actLeft A M.X ≫ chainSeedQ A M M' d = + (A ◁ chainSeedQ A M M' d) ≫ + modTensorAct A (symPowMod A M'.X 0) (symPowMod A M.X 1) := by + have hsplit : chainSeedQ A M M' d = + (ρ_ M.X).inv ≫ + MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + chainInsQ A M M' 0 0 := rfl + have h1 : actLeft A M.X ≫ (ρ_ M.X).inv = + (ρ_ (A ⊗ M.X)).inv ≫ (actLeft A M.X ▷ 𝟙_ D) := + rightUnitor_inv_naturality _ + have h2 : (actLeft A M.X ▷ 𝟙_ D) ≫ + MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) = + MonoidalCategory.whiskerLeft (A ⊗ M.X) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + (actLeft A M.X ▷ chainStage2 A M M' 0 0) := + (whisker_exchange _ _).symm + have h3 : (actLeft A M.X ▷ chainStage2 A M M' 0 0) ≫ + chainInsQ A M M' 0 0 = + (α_ A M.X (chainStage2 A M M' 0 0)).hom ≫ + (A ◁ chainInsQ A M M' 0 0) ≫ + modTensorAct A (symPowMod A M'.X 0) + (symPowMod A M.X 1) := + chainInsQ_actLetter A M M' 0 0 + have h4 : MonoidalCategory.whiskerLeft (A ⊗ M.X) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + (α_ A M.X (chainStage2 A M M' 0 0)).hom = + (α_ A M.X (𝟙_ D)).hom ≫ + (A ◁ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) := + associator_naturality_right _ _ _ + have h5 : (ρ_ (A ⊗ M.X)).inv ≫ (α_ A M.X (𝟙_ D)).hom = + A ◁ (ρ_ M.X).inv := by + monoidal + refine Eq.trans (whisker_eq _ hsplit) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker h1 _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker h2 _)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ h3)) ?_ + refine Eq.trans (whisker_eq _ + (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker h4 _)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker h5 _) ?_ + refine Eq.symm ?_ + refine Eq.trans (eq_whisker + (congrArg (fun t : M.X ⟶ chainStage2 A M M' 0 1 => + A ◁ t) hsplit) _) ?_ + refine Eq.trans (eq_whisker + ((MonoidalCategory.whiskerLeft_comp _ _ _).trans + (whisker_eq _ + (MonoidalCategory.whiskerLeft_comp _ _ _))) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (Category.assoc _ _ _) + +/-! ## The pair product of the entries -/ + +section PairMul + +/-- Whiskered map into a tensored pair, absorbed on the left. -/ +private theorem whiskerR_tensor [Category.{v} D] [MonoidalCategory D] + {W X Y P Q : D} (f : W ⟶ X) (g : X ⟶ P) (h : Y ⟶ Q) : + (f ▷ Y) ≫ (g ⊗ₘ h) = (f ≫ g) ⊗ₘ h := by + rw [← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.id_comp] + +/-- Whiskered map into a tensored pair, absorbed on the right. -/ +private theorem whiskerL_tensor [Category.{v} D] [MonoidalCategory D] + {W X Y P Q : D} (f : W ⟶ X) (g : Y ⟶ P) (h : X ⟶ Q) : + (Y ◁ f) ≫ (g ⊗ₘ h) = g ⊗ₘ (f ≫ h) := by + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.id_comp] + +/-- A tensored pair followed by a first-slot whisker. -/ +private theorem tensor_whiskerR [Category.{v} D] [MonoidalCategory D] + {W X Y P Q : D} (g : W ⟶ X) (k : X ⟶ P) (h : Y ⟶ Q) : + (g ⊗ₘ h) ≫ (k ▷ Q) = (g ≫ k) ⊗ₘ h := by + rw [← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.comp_id] + +/-- A tensored pair followed by a second-slot whisker. -/ +private theorem tensor_whiskerL [Category.{v} D] [MonoidalCategory D] + {W X Y P Q : D} (g : W ⟶ X) (h : Y ⟶ P) (k : P ⟶ Q) : + (g ⊗ₘ h) ≫ (X ◁ k) = g ⊗ₘ (h ≫ k) := by + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.comp_id] + +/-- **The raw pair product**: both entries enter and multiply +into the diagonal stage two levels up. -/ +noncomputable def chainPairRaw + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : M.X ⊗ M'.X ⟶ + chainStage2 A M M' 2 2 := + (chainSeedQ A M M' d ⊗ₘ chainSeedP A M M' d) ≫ + chainMul2 A M M' 0 1 1 0 + +/-- The common normal form of the two balance legs: the base +strand braids out front and acts after the raw pair product. -/ +private noncomputable def pairOmega + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : (M.X ⊗ A) ⊗ M'.X ⟶ + chainStage2 A M M' 2 2 := + ((β_ M.X A).hom ▷ M'.X) ≫ (α_ A M.X M'.X).hom ≫ + (A ◁ chainPairRaw A M M' d) ≫ + modTensorAct A (symPowMod A M'.X (0 + 1 + 1)) + (symPowMod A M.X (1 + 1 + 0)) + +/-- The associator carries the whiskered entries onto the +whiskered pair. -/ +private theorem pair_assoc_nat + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + ((A ◁ chainSeedQ A M M' d) ⊗ₘ chainSeedP A M M' d) ≫ + (α_ A (chainStage2 A M M' 0 1) (chainStage2 A M M' 1 0)).hom = + (α_ A M.X M'.X).hom ≫ + (A ◁ (chainSeedQ A M M' d ⊗ₘ chainSeedP A M M' d)) := by + have h := associator_naturality (𝟙 A) (chainSeedQ A M M' d) + (chainSeedP A M M' d) + simp only [MonoidalCategory.id_tensorHom] at h + exact h + +/-- **The first balance leg reaches the normal form.** -/ +private theorem legM_pairRaw + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + modTensorLegM A M M' ≫ chainPairRaw A M M' d = + pairOmega A M M' d := by + have h2 : (actLeft A M.X ▷ M'.X) ≫ + (chainSeedQ A M M' d ⊗ₘ chainSeedP A M M' d) = + ((A ◁ chainSeedQ A M M' d) ⊗ₘ chainSeedP A M M' d) ≫ + (modTensorAct A (symPowMod A M'.X 0) + (symPowMod A M.X 1) ▷ + modTensor A (symPowMod A M'.X 1) + (symPowMod A M.X 0)) := + (whiskerR_tensor _ _ _).trans + ((congrArg (fun t => t ⊗ₘ chainSeedP A M M' d) + (chainSeedQ_linear A M M' d)).trans + (tensor_whiskerR _ _ _).symm) + have hE1 : modTensorLegM A M M' ≫ chainPairRaw A M M' d = + (((β_ M.X A).hom ≫ actLeft A M.X) ▷ M'.X) ≫ + ((chainSeedQ A M M' d ⊗ₘ chainSeedP A M M' d) ≫ + chainMul2 A M M' 0 1 1 0) := rfl + have hE2 : (((β_ M.X A).hom ≫ actLeft A M.X) ▷ M'.X) ≫ + ((chainSeedQ A M M' d ⊗ₘ chainSeedP A M M' d) ≫ + chainMul2 A M M' 0 1 1 0) = + ((β_ M.X A).hom ▷ M'.X) ≫ ((actLeft A M.X ▷ M'.X) ≫ + ((chainSeedQ A M M' d ⊗ₘ chainSeedP A M M' d) ≫ + chainMul2 A M M' 0 1 1 0)) := + (eq_whisker (MonoidalCategory.comp_whiskerRight + (β_ M.X A).hom (actLeft A M.X) M'.X) _).trans + (Category.assoc _ _ _) + have hE3 : (actLeft A M.X ▷ M'.X) ≫ + ((chainSeedQ A M M' d ⊗ₘ chainSeedP A M M' d) ≫ + chainMul2 A M M' 0 1 1 0) = + ((A ◁ chainSeedQ A M M' d) ⊗ₘ chainSeedP A M M' d) ≫ + ((modTensorAct A (symPowMod A M'.X 0) + (symPowMod A M.X 1) ▷ + modTensor A (symPowMod A M'.X 1) + (symPowMod A M.X 0)) ≫ + chainMul2 A M M' 0 1 1 0) := + (Category.assoc _ _ _).symm.trans + ((eq_whisker h2 _).trans (Category.assoc _ _ _)) + have hE4 : (modTensorAct A (symPowMod A M'.X 0) + (symPowMod A M.X 1) ▷ + modTensor A (symPowMod A M'.X 1) + (symPowMod A M.X 0)) ≫ + chainMul2 A M M' 0 1 1 0 = + (α_ A (modTensor A (symPowMod A M'.X 0) + (symPowMod A M.X 1)) + (modTensor A (symPowMod A M'.X 1) + (symPowMod A M.X 0))).hom ≫ + (A ◁ chainMul2 A M M' 0 1 1 0) ≫ + modTensorAct A (symPowMod A M'.X (0 + 1 + 1)) + (symPowMod A M.X (1 + 1 + 0)) := + chainMul2_actLeft A M M' 0 1 1 0 + have hE5 : ((A ◁ chainSeedQ A M M' d) ⊗ₘ + chainSeedP A M M' d) ≫ + ((α_ A (modTensor A (symPowMod A M'.X 0) + (symPowMod A M.X 1)) + (modTensor A (symPowMod A M'.X 1) + (symPowMod A M.X 0))).hom ≫ + (A ◁ chainMul2 A M M' 0 1 1 0) ≫ + modTensorAct A (symPowMod A M'.X (0 + 1 + 1)) + (symPowMod A M.X (1 + 1 + 0))) = + (α_ A M.X M'.X).hom ≫ + ((A ◁ (chainSeedQ A M M' d ⊗ₘ chainSeedP A M M' d)) ≫ + ((A ◁ chainMul2 A M M' 0 1 1 0) ≫ + modTensorAct A (symPowMod A M'.X (0 + 1 + 1)) + (symPowMod A M.X (1 + 1 + 0)))) := + (Category.assoc _ _ _).symm.trans + ((eq_whisker (pair_assoc_nat A M M' d) _).trans + (Category.assoc _ _ _)) + have hE6 : (A ◁ (chainSeedQ A M M' d ⊗ₘ + chainSeedP A M M' d)) ≫ + ((A ◁ chainMul2 A M M' 0 1 1 0) ≫ + modTensorAct A (symPowMod A M'.X (0 + 1 + 1)) + (symPowMod A M.X (1 + 1 + 0))) = + (A ◁ chainPairRaw A M M' d) ≫ + modTensorAct A (symPowMod A M'.X (0 + 1 + 1)) + (symPowMod A M.X (1 + 1 + 0)) := + (Category.assoc _ _ _).symm.trans + (eq_whisker + (MonoidalCategory.whiskerLeft_comp A + (chainSeedQ A M M' d ⊗ₘ chainSeedP A M M' d) + (chainMul2 A M M' 0 1 1 0)).symm _) + exact hE1.trans (hE2.trans (whisker_eq _ + (hE3.trans ((whisker_eq _ hE4).trans + (hE5.trans (whisker_eq _ hE6)))))) + +/-- The inverse associator carries the pair onto the whiskered +entries. -/ +private theorem rpair_assoc_nat + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + (chainSeedQ A M M' d ⊗ₘ (A ◁ chainSeedP A M M' d)) ≫ + (α_ (chainStage2 A M M' 0 1) A + (chainStage2 A M M' 1 0)).inv = + (α_ M.X A M'.X).inv ≫ + ((chainSeedQ A M M' d ▷ A) ⊗ₘ + chainSeedP A M M' d) := by + have h := associator_inv_naturality (chainSeedQ A M M' d) + (𝟙 A) (chainSeedP A M M' d) + simp only [MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_id] at h + exact h + +/-- **The second balance leg reaches the normal form.** -/ +private theorem legN_pairRaw + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + modTensorLegN A M M' ≫ chainPairRaw A M M' d = + pairOmega A M M' d := by + have h2 : (M.X ◁ actLeft A M'.X) ≫ + (chainSeedQ A M M' d ⊗ₘ chainSeedP A M M' d) = + (chainSeedQ A M M' d ⊗ₘ (A ◁ chainSeedP A M M' d)) ≫ + (modTensor A (symPowMod A M'.X 0) + (symPowMod A M.X 1) ◁ + modTensorAct A (symPowMod A M'.X 1) + (symPowMod A M.X 0)) := + (whiskerL_tensor _ _ _).trans + ((congrArg (fun t => chainSeedQ A M M' d ⊗ₘ t) + (chainSeedP_linear A M M' d)).trans + (tensor_whiskerL _ _ _).symm) + have h6 : ((chainSeedQ A M M' d ▷ A) ⊗ₘ + chainSeedP A M M' d) ≫ + ((β_ (modTensor A (symPowMod A M'.X 0) + (symPowMod A M.X 1)) A).hom ▷ + modTensor A (symPowMod A M'.X 1) + (symPowMod A M.X 0)) = + ((β_ M.X A).hom ▷ M'.X) ≫ + ((A ◁ chainSeedQ A M M' d) ⊗ₘ + chainSeedP A M M' d) := + (tensor_whiskerR _ _ _).trans + ((congrArg (fun t => t ⊗ₘ chainSeedP A M M' d) + (BraidedCategory.braiding_naturality_left + (chainSeedQ A M M' d) A)).trans + (whiskerR_tensor _ _ _).symm) + have hE3 : (M.X ◁ actLeft A M'.X) ≫ + ((chainSeedQ A M M' d ⊗ₘ chainSeedP A M M' d) ≫ + chainMul2 A M M' 0 1 1 0) = + (chainSeedQ A M M' d ⊗ₘ (A ◁ chainSeedP A M M' d)) ≫ + ((modTensor A (symPowMod A M'.X 0) + (symPowMod A M.X 1) ◁ + modTensorAct A (symPowMod A M'.X 1) + (symPowMod A M.X 0)) ≫ + chainMul2 A M M' 0 1 1 0) := + (Category.assoc _ _ _).symm.trans + ((eq_whisker h2 _).trans (Category.assoc _ _ _)) + have hE4 : (modTensor A (symPowMod A M'.X 0) + (symPowMod A M.X 1) ◁ + modTensorAct A (symPowMod A M'.X 1) + (symPowMod A M.X 0)) ≫ + chainMul2 A M M' 0 1 1 0 = + (α_ (modTensor A (symPowMod A M'.X 0) + (symPowMod A M.X 1)) A + (modTensor A (symPowMod A M'.X 1) + (symPowMod A M.X 0))).inv ≫ + ((β_ (modTensor A (symPowMod A M'.X 0) + (symPowMod A M.X 1)) A).hom ▷ + modTensor A (symPowMod A M'.X 1) + (symPowMod A M.X 0)) ≫ + (α_ A (modTensor A (symPowMod A M'.X 0) + (symPowMod A M.X 1)) + (modTensor A (symPowMod A M'.X 1) + (symPowMod A M.X 0))).hom ≫ + (A ◁ chainMul2 A M M' 0 1 1 0) ≫ + modTensorAct A (symPowMod A M'.X (0 + 1 + 1)) + (symPowMod A M.X (1 + 1 + 0)) := + chainMul2_actMid A M M' 0 1 1 0 + have hE5 : (chainSeedQ A M M' d ⊗ₘ + (A ◁ chainSeedP A M M' d)) ≫ + ((α_ (modTensor A (symPowMod A M'.X 0) + (symPowMod A M.X 1)) A + (modTensor A (symPowMod A M'.X 1) + (symPowMod A M.X 0))).inv ≫ + ((β_ (modTensor A (symPowMod A M'.X 0) + (symPowMod A M.X 1)) A).hom ▷ + modTensor A (symPowMod A M'.X 1) + (symPowMod A M.X 0)) ≫ + (α_ A (modTensor A (symPowMod A M'.X 0) + (symPowMod A M.X 1)) + (modTensor A (symPowMod A M'.X 1) + (symPowMod A M.X 0))).hom ≫ + (A ◁ chainMul2 A M M' 0 1 1 0) ≫ + modTensorAct A (symPowMod A M'.X (0 + 1 + 1)) + (symPowMod A M.X (1 + 1 + 0))) = + (α_ M.X A M'.X).inv ≫ + (((chainSeedQ A M M' d ▷ A) ⊗ₘ + chainSeedP A M M' d) ≫ + (((β_ (modTensor A (symPowMod A M'.X 0) + (symPowMod A M.X 1)) A).hom ▷ + modTensor A (symPowMod A M'.X 1) + (symPowMod A M.X 0)) ≫ + (α_ A (modTensor A (symPowMod A M'.X 0) + (symPowMod A M.X 1)) + (modTensor A (symPowMod A M'.X 1) + (symPowMod A M.X 0))).hom ≫ + (A ◁ chainMul2 A M M' 0 1 1 0) ≫ + modTensorAct A (symPowMod A M'.X (0 + 1 + 1)) + (symPowMod A M.X (1 + 1 + 0)))) := + (Category.assoc _ _ _).symm.trans + ((eq_whisker (rpair_assoc_nat A M M' d) _).trans + (Category.assoc _ _ _)) + have hE6 : ((chainSeedQ A M M' d ▷ A) ⊗ₘ + chainSeedP A M M' d) ≫ + (((β_ (modTensor A (symPowMod A M'.X 0) + (symPowMod A M.X 1)) A).hom ▷ + modTensor A (symPowMod A M'.X 1) + (symPowMod A M.X 0)) ≫ + (α_ A (modTensor A (symPowMod A M'.X 0) + (symPowMod A M.X 1)) + (modTensor A (symPowMod A M'.X 1) + (symPowMod A M.X 0))).hom ≫ + (A ◁ chainMul2 A M M' 0 1 1 0) ≫ + modTensorAct A (symPowMod A M'.X (0 + 1 + 1)) + (symPowMod A M.X (1 + 1 + 0))) = + ((β_ M.X A).hom ▷ M'.X) ≫ + (((A ◁ chainSeedQ A M M' d) ⊗ₘ + chainSeedP A M M' d) ≫ + ((α_ A (modTensor A (symPowMod A M'.X 0) + (symPowMod A M.X 1)) + (modTensor A (symPowMod A M'.X 1) + (symPowMod A M.X 0))).hom ≫ + (A ◁ chainMul2 A M M' 0 1 1 0) ≫ + modTensorAct A (symPowMod A M'.X (0 + 1 + 1)) + (symPowMod A M.X (1 + 1 + 0)))) := + (Category.assoc _ _ _).symm.trans + ((eq_whisker (h6) _).trans (Category.assoc _ _ _)) + have hE7 : ((A ◁ chainSeedQ A M M' d) ⊗ₘ + chainSeedP A M M' d) ≫ + ((α_ A (modTensor A (symPowMod A M'.X 0) + (symPowMod A M.X 1)) + (modTensor A (symPowMod A M'.X 1) + (symPowMod A M.X 0))).hom ≫ + (A ◁ chainMul2 A M M' 0 1 1 0) ≫ + modTensorAct A (symPowMod A M'.X (0 + 1 + 1)) + (symPowMod A M.X (1 + 1 + 0))) = + (α_ A M.X M'.X).hom ≫ + ((A ◁ (chainSeedQ A M M' d ⊗ₘ chainSeedP A M M' d)) ≫ + ((A ◁ chainMul2 A M M' 0 1 1 0) ≫ + modTensorAct A (symPowMod A M'.X (0 + 1 + 1)) + (symPowMod A M.X (1 + 1 + 0)))) := + (Category.assoc _ _ _).symm.trans + ((eq_whisker (pair_assoc_nat A M M' d) _).trans + (Category.assoc _ _ _)) + have hE8 : (A ◁ (chainSeedQ A M M' d ⊗ₘ + chainSeedP A M M' d)) ≫ + ((A ◁ chainMul2 A M M' 0 1 1 0) ≫ + modTensorAct A (symPowMod A M'.X (0 + 1 + 1)) + (symPowMod A M.X (1 + 1 + 0))) = + (A ◁ chainPairRaw A M M' d) ≫ + modTensorAct A (symPowMod A M'.X (0 + 1 + 1)) + (symPowMod A M.X (1 + 1 + 0)) := + (Category.assoc _ _ _).symm.trans + (eq_whisker + (MonoidalCategory.whiskerLeft_comp A + (chainSeedQ A M M' d ⊗ₘ chainSeedP A M M' d) + (chainMul2 A M M' 0 1 1 0)).symm _) + refine (Category.assoc _ _ _).trans ?_ + refine (whisker_eq _ (hE3.trans ((whisker_eq _ hE4).trans + hE5))).trans ?_ + refine (Iso.hom_inv_id_assoc _ _).trans ?_ + exact hE6.trans (whisker_eq _ (hE7.trans + (whisker_eq _ hE8))) + +/-- The two balance legs agree. -/ +theorem chainPair_cond + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + modTensorLegM A M M' ≫ chainPairRaw A M M' d = + modTensorLegN A M M' ≫ chainPairRaw A M M' d := + (legM_pairRaw A M M' d).trans (legN_pairRaw A M M' d).symm + +/-- **The pair product of the entries**, descended to the +relative tensor product. -/ +noncomputable def chainPairMul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : modTensor A M M' ⟶ + chainStage2 A M M' 2 2 := + modTensorDesc A M M' (chainPairRaw A M M' d) + (chainPair_cond A M M' d) + +/-- Defining equation of the descended pair product. -/ +@[reassoc] +theorem modTensorπ_chainPairMul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + modTensorπ A M M' ≫ chainPairMul A M M' d = + chainPairRaw A M M' d := + modTensorπ_desc A M M' _ _ + +/-- The insertion at the bottom, cast-free. -/ +private theorem symInsL_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (X : D) [ModObj A X] : + symInsL A X 0 = + ((symPowOne A X).inv ▷ symPow A X 1) ≫ + symMul A X 1 1 := by + rw [symInsL, + show symPowCast A X (by omega : 1 + (0 + 1) = 0 + 2) = + 𝟙 (symPow A X (0 + 2)) from rfl, Category.comp_id] + +private theorem pairIns_leftCover [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) : + ((M'.X ⊗ M.X) ◁ modTensorπ A + (symPowMod A M'.X 0) (symPowMod A M.X 0)) ≫ + ((((symPowOne A M'.X).inv ⊗ₘ + (symPowOne A M.X).inv) ≫ + modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 0)) ▷ + chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' 0 0 0 0 = + tensorμ M'.X M.X (symPow A M'.X 1) (symPow A M.X 1) ≫ + (symInsL A M'.X 0 ⊗ₘ symInsL A M.X 0) ≫ + modTensorπ A (symPowMod A M'.X 1) + (symPowMod A M.X 1) := by + have hL1 : ((M'.X ⊗ M.X) ◁ + modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 0)) ≫ + ((((symPowOne A M'.X).inv ⊗ₘ (symPowOne A M.X).inv) ≫ + modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 0)) ▷ chainStage2 A M M' 0 0) = + ((((symPowOne A M'.X).inv ⊗ₘ (symPowOne A M.X).inv) ≫ + modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 0)) ▷ + (symPow A M'.X 1 ⊗ symPow A M.X 1)) ≫ + ((modTensor A (symPowMod A M'.X 0) + (symPowMod A M.X 0)) ◁ + modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 0)) := + whisker_exchange _ _ + have hL2 : ((((symPowOne A M'.X).inv ⊗ₘ + (symPowOne A M.X).inv) ≫ + modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 0)) ▷ + (symPow A M'.X 1 ⊗ symPow A M.X 1)) ≫ + ((modTensor A (symPowMod A M'.X 0) + (symPowMod A M.X 0)) ◁ + modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 0)) = + (((symPowOne A M'.X).inv ⊗ₘ (symPowOne A M.X).inv) ▷ + (symPow A M'.X 1 ⊗ symPow A M.X 1)) ≫ + (modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 0) ⊗ₘ + modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 0)) := by + erw [MonoidalCategory.comp_whiskerRight, Category.assoc, + ← MonoidalCategory.tensorHom_def] + have hL3 : (modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 0) ⊗ₘ + modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 0)) ≫ + chainMul2 A M M' 0 0 0 0 = + tensorμ (symPow A M'.X 1) (symPow A M.X 1) + (symPow A M'.X 1) (symPow A M.X 1) ≫ + (symMul A M'.X 1 1 ⊗ₘ symMul A M.X 1 1) ≫ + modTensorπ A (symPowMod A M'.X 1) + (symPowMod A M.X 1) := + tensorHom_π_chainMul2 A M M' 0 0 0 0 + have hL4 : (((symPowOne A M'.X).inv ⊗ₘ + (symPowOne A M.X).inv) ▷ + (symPow A M'.X 1 ⊗ symPow A M.X 1)) ≫ + tensorμ (symPow A M'.X 1) (symPow A M.X 1) + (symPow A M'.X 1) (symPow A M.X 1) = + tensorμ M'.X M.X (symPow A M'.X 1) (symPow A M.X 1) ≫ + (((symPowOne A M'.X).inv ▷ symPow A M'.X 1) ⊗ₘ + ((symPowOne A M.X).inv ▷ symPow A M.X 1)) := by + have h := tensorμ_natural (symPowOne A M'.X).inv + (symPowOne A M.X).inv (𝟙 (symPow A M'.X 1)) + (𝟙 (symPow A M.X 1)) + simp only [MonoidalCategory.tensorHom_id] at h + simpa using h + -- Right side: naturality of the associator, the two insertion + -- defining equations, and the rearrangement identifying the + -- crossing with the interchange. + have hIns : ((symPowOne A M'.X).inv ▷ symPow A M'.X 1) ≫ + symMul A M'.X 1 1 = symInsL A M'.X 0 := + (symInsL_zero A M'.X).symm + have hIns' : ((symPowOne A M.X).inv ▷ symPow A M.X 1) ≫ + symMul A M.X 1 1 = symInsL A M.X 0 := + (symInsL_zero A M.X).symm + have hMuls : (((symPowOne A M'.X).inv ▷ symPow A M'.X 1) ⊗ₘ + ((symPowOne A M.X).inv ▷ symPow A M.X 1)) ≫ + (symMul A M'.X 1 1 ⊗ₘ symMul A M.X 1 1) = + symInsL A M'.X 0 ⊗ₘ symInsL A M.X 0 := + (MonoidalCategory.tensorHom_comp_tensorHom _ _ _ _).trans + (congrArg₂ (· ⊗ₘ ·) hIns hIns') + have hLfinal : ((M'.X ⊗ M.X) ◁ modTensorπ A + (symPowMod A M'.X 0) (symPowMod A M.X 0)) ≫ + ((((symPowOne A M'.X).inv ⊗ₘ + (symPowOne A M.X).inv) ≫ + modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 0)) ▷ + chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' 0 0 0 0 = + tensorμ M'.X M.X (symPow A M'.X 1) (symPow A M.X 1) ≫ + (symInsL A M'.X 0 ⊗ₘ symInsL A M.X 0) ≫ + modTensorπ A (symPowMod A M'.X 1) + (symPowMod A M.X 1) := by + refine (Category.assoc _ _ _).symm.trans ?_ + refine (eq_whisker hL1 _).trans ?_ + refine (eq_whisker hL2 _).trans ?_ + refine (Category.assoc _ _ _).trans ?_ + refine (whisker_eq _ hL3).trans ?_ + refine (Category.assoc _ _ _).symm.trans ?_ + refine (eq_whisker hL4 _).trans ?_ + refine (Category.assoc _ _ _).trans ?_ + refine whisker_eq _ ?_ + refine (Category.assoc _ _ _).symm.trans ?_ + exact eq_whisker hMuls _ + exact hLfinal + +/-- **Pair multiplication is double insertion**: multiplying the +embedded letter pair onto a bottom-stage element inserts the two +letters. -/ +theorem pairIns [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) : + ((((symPowOne A M'.X).inv ⊗ₘ (symPowOne A M.X).inv) ≫ + modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 0)) ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' 0 0 0 0 = + (α_ M'.X M.X (chainStage2 A M M' 0 0)).hom ≫ + (M'.X ◁ chainInsQ A M M' 0 0) ≫ + chainInsP A M M' 0 1 := by + refine (cancel_epi ((M'.X ⊗ M.X) ◁ + modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 0))).mp ?_ + -- Left side: exchange the cover, pair the projections, expand + -- the multiplication, and slide the singleton maps through the + -- interchange. + have hR1 : ((M'.X ⊗ M.X) ◁ + modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 0)) ≫ + (α_ M'.X M.X (chainStage2 A M M' 0 0)).hom = + (α_ M'.X M.X (symPow A M'.X 1 ⊗ symPow A M.X 1)).hom ≫ + (M'.X ◁ (M.X ◁ modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 0))) := + associator_naturality_right _ _ _ + have hR2 : (M'.X ◁ (M.X ◁ modTensorπ A + (symPowMod A M'.X 0) (symPowMod A M.X 0))) ≫ + (M'.X ◁ chainInsQ A M M' 0 0) = + M'.X ◁ ((α_ M.X (symPow A M'.X 1) + (symPow A M.X 1)).inv ≫ + ((β_ M.X (symPow A M'.X 1)).hom ▷ symPow A M.X 1) ≫ + (α_ (symPow A M'.X 1) M.X (symPow A M.X 1)).hom ≫ + (symPow A M'.X 1 ◁ symInsL A M.X 0) ≫ + modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 1)) := + (MonoidalCategory.whiskerLeft_comp _ _ _).symm.trans + (congrArg (fun t => M'.X ◁ t) + (whiskerLeft_π_chainInsQ A M M' 0 0)) + have hR3 : (M'.X ◁ modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 1)) ≫ chainInsP A M M' 0 1 = + (α_ M'.X (symPow A M'.X 1) (symPow A M.X 2)).inv ≫ + (symInsL A M'.X 0 ▷ symPow A M.X 2) ≫ + modTensorπ A (symPowMod A M'.X 1) + (symPowMod A M.X 1) := + whiskerLeft_π_chainInsP A M M' 0 1 + have hR4 : (M'.X ◁ (symPow A M'.X 1 ◁ + symInsL A M.X 0)) ≫ + (α_ M'.X (symPow A M'.X 1) (symPow A M.X 2)).inv = + (α_ M'.X (symPow A M'.X 1) + (M.X ⊗ symPow A M.X 1)).inv ≫ + ((M'.X ⊗ symPow A M'.X 1) ◁ symInsL A M.X 0) := + associator_inv_naturality_right _ _ _ + have hR5 : ((M'.X ⊗ symPow A M'.X 1) ◁ + symInsL A M.X 0) ≫ + (symInsL A M'.X 0 ▷ symPow A M.X 2) = + (symInsL A M'.X 0 ▷ (M.X ⊗ symPow A M.X 1)) ≫ + (symPow A M'.X (0 + 2) ◁ symInsL A M.X 0) := + whisker_exchange _ _ + have hR7 : (α_ M'.X M.X (symPow A M'.X 1 ⊗ + symPow A M.X 1)).hom ≫ + (M'.X ◁ (α_ M.X (symPow A M'.X 1) + (symPow A M.X 1)).inv) ≫ + (M'.X ◁ ((β_ M.X (symPow A M'.X 1)).hom ▷ + symPow A M.X 1)) ≫ + (M'.X ◁ (α_ (symPow A M'.X 1) M.X + (symPow A M.X 1)).hom) ≫ + (α_ M'.X (symPow A M'.X 1) + (M.X ⊗ symPow A M.X 1)).inv = + tensorμ M'.X M.X (symPow A M'.X 1) (symPow A M.X 1) := + rfl + have hR8 : (symInsL A M'.X 0 ▷ (M.X ⊗ symPow A M.X 1)) ≫ + (symPow A M'.X (0 + 2) ◁ symInsL A M.X 0) = + symInsL A M'.X 0 ⊗ₘ symInsL A M.X 0 := + (MonoidalCategory.tensorHom_def _ _).symm + -- Assemble both sides at the common form + -- tensorμ ≫ (symInsL ⊗ symInsL) ≫ π. + have hLfinal := pairIns_leftCover A M M' + have hexp : M'.X ◁ ((α_ M.X (symPow A M'.X 1) + (symPow A M.X 1)).inv ≫ + ((β_ M.X (symPow A M'.X 1)).hom ▷ symPow A M.X 1) ≫ + (α_ (symPow A M'.X 1) M.X (symPow A M.X 1)).hom ≫ + (symPow A M'.X 1 ◁ symInsL A M.X 0) ≫ + modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 1)) = + (M'.X ◁ (α_ M.X (symPow A M'.X 1) + (symPow A M.X 1)).inv) ≫ + (M'.X ◁ ((β_ M.X (symPow A M'.X 1)).hom ▷ + symPow A M.X 1)) ≫ + (M'.X ◁ (α_ (symPow A M'.X 1) M.X + (symPow A M.X 1)).hom) ≫ + (M'.X ◁ (symPow A M'.X 1 ◁ symInsL A M.X 0)) ≫ + (M'.X ◁ modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 1)) := by + repeat' erw [MonoidalCategory.whiskerLeft_comp] + have hRfinal : ((M'.X ⊗ M.X) ◁ modTensorπ A + (symPowMod A M'.X 0) (symPowMod A M.X 0)) ≫ + (α_ M'.X M.X (chainStage2 A M M' 0 0)).hom ≫ + (M'.X ◁ chainInsQ A M M' 0 0) ≫ + chainInsP A M M' 0 1 = + tensorμ M'.X M.X (symPow A M'.X 1) (symPow A M.X 1) ≫ + (symInsL A M'.X 0 ⊗ₘ symInsL A M.X 0) ≫ + modTensorπ A (symPowMod A M'.X 1) + (symPowMod A M.X 1) := by + refine (Category.assoc _ _ _).symm.trans ?_ + refine (eq_whisker hR1 _).trans ?_ + refine (Category.assoc _ _ _).trans ?_ + refine (whisker_eq _ ((Category.assoc _ _ _).symm.trans + ((eq_whisker hR2 _).trans + (eq_whisker hexp _)))).trans ?_ + -- peel the five whiskers + refine (whisker_eq _ (by + repeat' erw [Category.assoc] : + ((M'.X ◁ (α_ M.X (symPow A M'.X 1) + (symPow A M.X 1)).inv) ≫ + (M'.X ◁ ((β_ M.X (symPow A M'.X 1)).hom ▷ + symPow A M.X 1)) ≫ + (M'.X ◁ (α_ (symPow A M'.X 1) M.X + (symPow A M.X 1)).hom) ≫ + (M'.X ◁ (symPow A M'.X 1 ◁ symInsL A M.X 0)) ≫ + (M'.X ◁ modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 1))) ≫ + chainInsP A M M' 0 1 = + (M'.X ◁ (α_ M.X (symPow A M'.X 1) + (symPow A M.X 1)).inv) ≫ + (M'.X ◁ ((β_ M.X (symPow A M'.X 1)).hom ▷ + symPow A M.X 1)) ≫ + (M'.X ◁ (α_ (symPow A M'.X 1) M.X + (symPow A M.X 1)).hom) ≫ + (M'.X ◁ (symPow A M'.X 1 ◁ symInsL A M.X 0)) ≫ + ((M'.X ◁ modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 1)) ≫ + chainInsP A M M' 0 1))).trans ?_ + refine (whisker_eq _ (whisker_eq _ (whisker_eq _ + (whisker_eq _ (whisker_eq _ hR3))))).trans ?_ + refine (whisker_eq _ (whisker_eq _ (whisker_eq _ + (whisker_eq _ ((Category.assoc _ _ _).symm.trans + ((eq_whisker hR4 _).trans + (Category.assoc _ _ _))))))).trans ?_ + refine (whisker_eq _ (whisker_eq _ (whisker_eq _ + (whisker_eq _ (whisker_eq _ + ((Category.assoc _ _ _).symm.trans + ((eq_whisker hR5 _).trans + (Category.assoc _ _ _)))))))).trans ?_ + refine ((by simp only [Category.assoc] : + (α_ M'.X M.X (symPow A M'.X 1 ⊗ + symPow A M.X 1)).hom ≫ + (M'.X ◁ (α_ M.X (symPow A M'.X 1) + (symPow A M.X 1)).inv) ≫ + (M'.X ◁ ((β_ M.X (symPow A M'.X 1)).hom ▷ + symPow A M.X 1)) ≫ + (M'.X ◁ (α_ (symPow A M'.X 1) M.X + (symPow A M.X 1)).hom) ≫ + (α_ M'.X (symPow A M'.X 1) + (M.X ⊗ symPow A M.X 1)).inv ≫ + (symInsL A M'.X 0 ▷ (M.X ⊗ symPow A M.X 1)) ≫ + (symPow A M'.X (0 + 2) ◁ symInsL A M.X 0) ≫ + modTensorπ A (symPowMod A M'.X 1) + (symPowMod A M.X 1) = + ((α_ M'.X M.X (symPow A M'.X 1 ⊗ + symPow A M.X 1)).hom ≫ + (M'.X ◁ (α_ M.X (symPow A M'.X 1) + (symPow A M.X 1)).inv) ≫ + (M'.X ◁ ((β_ M.X (symPow A M'.X 1)).hom ▷ + symPow A M.X 1)) ≫ + (M'.X ◁ (α_ (symPow A M'.X 1) M.X + (symPow A M.X 1)).hom) ≫ + (α_ M'.X (symPow A M'.X 1) + (M.X ⊗ symPow A M.X 1)).inv) ≫ + (symInsL A M'.X 0 ▷ (M.X ⊗ symPow A M.X 1)) ≫ + (symPow A M'.X (0 + 2) ◁ symInsL A M.X 0) ≫ + modTensorπ A (symPowMod A M'.X 1) + (symPowMod A M.X 1))).trans ?_ + refine (eq_whisker hR7 _).trans ?_ + refine whisker_eq _ ?_ + refine (Category.assoc _ _ _).symm.trans ?_ + exact eq_whisker hR8 _ + exact hLfinal.trans hRfinal.symm + +/-- The first-slot insertion against the multiplication, solved +for the whiskered form. -/ +private theorem insP_solved + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) : + (chainInsP A M M' 0 0 ▷ chainStage2 A M M' 0 1) ≫ + chainMul2 A M M' (0 + 1) 0 0 1 = + (α_ M'.X (chainStage2 A M M' 0 0) (chainStage2 A M M' 0 1)).hom ≫ + (M'.X ◁ chainMul2 A M M' 0 0 0 1) ≫ + chainInsP A M M' (0 + 1 + 0) (0 + 1 + 1) := by + have h := chainInsP_mul A M M' 0 0 0 1 + rw [show chainStage2Cast A M M' + (by omega : 0 + 1 + 1 + 0 = 0 + 1 + 0 + 1) + (by omega : 0 + 1 + 1 = 0 + 1 + 1) = + 𝟙 (chainStage2 A M M' (0 + 1 + 0 + 1) (0 + 1 + 1)) from + rfl, Category.comp_id] at h + rw [h, Iso.hom_inv_id_assoc] + +/-- The second-slot insertion against the multiplication, solved +for the whiskered form. -/ +private theorem insQ_solved + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) : + (chainInsQ A M M' 0 0 ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' 0 (0 + 1) 0 0 = + (α_ M.X (chainStage2 A M M' 0 0) (chainStage2 A M M' 0 0)).hom ≫ + (M.X ◁ chainMul2 A M M' 0 0 0 0) ≫ + chainInsQ A M M' (0 + 1 + 0) (0 + 1 + 0) := by + have h := chainInsQ_mul A M M' 0 0 0 0 + rw [show chainStage2Cast A M M' + (by omega : 0 + 1 + 0 = 0 + 1 + 0) + (by omega : 0 + 1 + 1 + 0 = 0 + 1 + 0 + 1) = + 𝟙 (chainStage2 A M M' (0 + 1 + 0) (0 + 1 + 0 + 1)) from + rfl, Category.comp_id] at h + rw [h, Iso.hom_inv_id_assoc] + +/-- The multiplication with the first-slot insertion in its +second factor: braid, insert, multiply. -/ +private theorem insP_snd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) : + (chainStage2 A M M' 0 1 ◁ chainInsP A M M' 0 0) ≫ + chainMul2 A M M' 0 1 1 0 = + (β_ (chainStage2 A M M' 0 1) (M'.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (α_ M'.X (chainStage2 A M M' 0 0) (chainStage2 A M M' 0 1)).hom ≫ + (M'.X ◁ chainMul2 A M M' 0 0 0 1) ≫ + chainInsP A M M' (0 + 1 + 0) (0 + 1 + 1) := by + have hcomm : chainMul2 A M M' 0 1 1 0 = + (β_ (chainStage2 A M M' 0 1) + (chainStage2 A M M' 1 0)).hom ≫ + chainMul2 A M M' 1 0 0 1 ≫ + chainStage2Cast A M M' + (by omega : 1 + 1 + 0 = 0 + 1 + 1) + (by omega : 0 + 1 + 1 = 1 + 1 + 0) := + (chainMul2_comm A M M' 0 1 1 0).symm + rw [show chainStage2Cast A M M' + (by omega : 1 + 1 + 0 = 0 + 1 + 1) + (by omega : 0 + 1 + 1 = 1 + 1 + 0) = + 𝟙 (chainStage2 A M M' (0 + 1 + 1) (1 + 1 + 0)) from + rfl, Category.comp_id] at hcomm + have hnat : (chainStage2 A M M' 0 1 ◁ + chainInsP A M M' 0 0) ≫ + (β_ (chainStage2 A M M' 0 1) + (chainStage2 A M M' 1 0)).hom = + (β_ (chainStage2 A M M' 0 1) + (M'.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (chainInsP A M M' 0 0 ▷ chainStage2 A M M' 0 1) := + BraidedCategory.braiding_naturality_right _ _ + calc (chainStage2 A M M' 0 1 ◁ chainInsP A M M' 0 0) ≫ + chainMul2 A M M' 0 1 1 0 + = (chainStage2 A M M' 0 1 ◁ chainInsP A M M' 0 0) ≫ + (β_ (chainStage2 A M M' 0 1) + (chainStage2 A M M' 1 0)).hom ≫ + chainMul2 A M M' 1 0 0 1 := by + rw [hcomm] + _ = (β_ (chainStage2 A M M' 0 1) + (M'.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + ((chainInsP A M M' 0 0 ▷ + chainStage2 A M M' 0 1) ≫ + chainMul2 A M M' 1 0 0 1) := by + rw [← Category.assoc, hnat, Category.assoc] + _ = (β_ (chainStage2 A M M' 0 1) + (M'.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + ((chainInsP A M M' 0 0 ▷ + chainStage2 A M M' 0 1) ≫ + chainMul2 A M M' (0 + 1) 0 0 1) := by + rw [show chainMul2 A M M' 1 0 0 1 = + chainMul2 A M M' (0 + 1) 0 0 1 from rfl] + _ = (β_ (chainStage2 A M M' 0 1) + (M'.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (α_ M'.X (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 1)).hom ≫ + (M'.X ◁ chainMul2 A M M' 0 0 0 1) ≫ + chainInsP A M M' (0 + 1 + 0) (0 + 1 + 1) := by + rw [insP_solved] + +/-- The multiplication with the second-slot insertion in its +second factor: braid, insert, multiply. -/ +private theorem insQ_snd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) : + (chainStage2 A M M' 0 0 ◁ chainInsQ A M M' 0 0) ≫ + chainMul2 A M M' 0 0 0 1 = + (β_ (chainStage2 A M M' 0 0) (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (α_ M.X (chainStage2 A M M' 0 0) (chainStage2 A M M' 0 0)).hom ≫ + (M.X ◁ chainMul2 A M M' 0 0 0 0) ≫ + chainInsQ A M M' (0 + 1 + 0) (0 + 1 + 0) := by + have hcomm : chainMul2 A M M' 0 0 0 1 = + (β_ (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 1)).hom ≫ + chainMul2 A M M' 0 1 0 0 ≫ + chainStage2Cast A M M' + (by omega : 0 + 1 + 0 = 0 + 1 + 0) + (by omega : 1 + 1 + 0 = 0 + 1 + 1) := + (chainMul2_comm A M M' 0 0 0 1).symm + rw [show chainStage2Cast A M M' + (by omega : 0 + 1 + 0 = 0 + 1 + 0) + (by omega : 1 + 1 + 0 = 0 + 1 + 1) = + 𝟙 (chainStage2 A M M' (0 + 1 + 0) (0 + 1 + 1)) from + rfl, Category.comp_id] at hcomm + have hnat : (chainStage2 A M M' 0 0 ◁ + chainInsQ A M M' 0 0) ≫ + (β_ (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 1)).hom = + (β_ (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (chainInsQ A M M' 0 0 ▷ chainStage2 A M M' 0 0) := + BraidedCategory.braiding_naturality_right _ _ + calc (chainStage2 A M M' 0 0 ◁ chainInsQ A M M' 0 0) ≫ + chainMul2 A M M' 0 0 0 1 + = (chainStage2 A M M' 0 0 ◁ chainInsQ A M M' 0 0) ≫ + (β_ (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 1)).hom ≫ + chainMul2 A M M' 0 1 0 0 := by + rw [hcomm] + _ = (β_ (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + ((chainInsQ A M M' 0 0 ▷ + chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' 0 1 0 0) := by + rw [← Category.assoc, hnat, Category.assoc] + _ = (β_ (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + ((chainInsQ A M M' 0 0 ▷ + chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' 0 (0 + 1) 0 0) := by + rw [show chainMul2 A M M' 0 1 0 0 = + chainMul2 A M M' 0 (0 + 1) 0 0 from rfl] + _ = (β_ (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (α_ M.X (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 0)).hom ≫ + (M.X ◁ chainMul2 A M M' 0 0 0 0) ≫ + chainInsQ A M M' (0 + 1 + 0) (0 + 1 + 0) := by + rw [insQ_solved] + +/-- Any morphism into a stage followed by the transition is the +seed fed beside it. -/ +private theorem comp_chainDelta2 + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') {W : D} (p q : ℕ) + (f : W ⟶ chainStage2 A M M' p q) : + f ≫ chainDelta2 A M M' d p q = + (ρ_ W).inv ≫ + (W ◁ chainSeed A M M' d) ≫ + ((f ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p q 0 0) := by + have h1 : f ≫ (ρ_ (chainStage2 A M M' p q)).inv = + (ρ_ W).inv ≫ (f ▷ (𝟙_ D)) := + rightUnitor_inv_naturality _ + have h2 : (f ▷ (𝟙_ D)) ≫ + MonoidalCategory.whiskerLeft (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) = + (W ◁ chainSeed A M M' d) ≫ + (f ▷ chainStage2 A M M' 0 0) := + (whisker_exchange _ _).symm + calc f ≫ chainDelta2 A M M' d p q + = (f ≫ (ρ_ (chainStage2 A M M' p q)).inv) ≫ + MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d) ≫ + chainMul2 A M M' p q 0 0 := by + rw [chainDelta2] + simp only [Category.assoc] + _ = (ρ_ W).inv ≫ ((f ▷ (𝟙_ D)) ≫ + MonoidalCategory.whiskerLeft + (chainStage2 A M M' p q) + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ≫ + chainMul2 A M M' p q 0 0 := by + rw [h1] + simp only [Category.assoc] + _ = (ρ_ W).inv ≫ + (W ◁ chainSeed A M M' d) ≫ + ((f ▷ chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' p q 0 0) := by + rw [h2] + repeat' erw [Category.assoc] + +/-- **The raw pair product, normalised**: both letters braid to +canonical position, the seeds feed in, and the two insertions +stack. -/ +private theorem pairRaw_normal + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + chainPairRaw A M M' d = + (β_ M.X M'.X).hom ≫ + ((((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ⊗ₘ + ((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d))) ≫ + (α_ M'.X (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (M'.X ◁ ((β_ (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (α_ M.X (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 0)).hom ≫ + (M.X ◁ chainMul2 A M M' 0 0 0 0) ≫ + chainInsQ A M M' (0 + 1 + 0) (0 + 1 + 0))) ≫ + chainInsP A M M' (0 + 1 + 0) (0 + 1 + 1)) := by + have hW2 : chainSeedQ A M M' d ⊗ₘ chainSeedP A M M' d = + (((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ⊗ₘ + ((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d))) ≫ + (chainInsQ A M M' 0 0 ⊗ₘ chainInsP A M M' 0 0) := by + rw [show chainSeedQ A M M' d = + ((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ≫ chainInsQ A M M' 0 0 from + (Category.assoc _ _ _).symm, + show chainSeedP A M M' d = + ((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ≫ chainInsP A M M' 0 0 from + (Category.assoc _ _ _).symm, + MonoidalCategory.tensorHom_comp_tensorHom] + have hW3 : (chainInsQ A M M' 0 0 ⊗ₘ + chainInsP A M M' 0 0) ≫ chainMul2 A M M' 0 1 1 0 = + (chainInsQ A M M' 0 0 ▷ (M'.X ⊗ chainStage2 A M M' 0 0)) ≫ + ((chainStage2 A M M' 0 1 ◁ chainInsP A M M' 0 0) ≫ + chainMul2 A M M' 0 1 1 0) := + (eq_whisker (MonoidalCategory.tensorHom_def _ _) _).trans + (Category.assoc _ _ _) + have hW5 : (chainInsQ A M M' 0 0 ▷ + (M'.X ⊗ chainStage2 A M M' 0 0)) ≫ + (β_ (chainStage2 A M M' 0 1) + (M'.X ⊗ chainStage2 A M M' 0 0)).hom = + (β_ (M.X ⊗ chainStage2 A M M' 0 0) + (M'.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + ((M'.X ⊗ chainStage2 A M M' 0 0) ◁ chainInsQ A M M' 0 0) := + BraidedCategory.braiding_naturality_left _ _ + have hW6 : ((M'.X ⊗ chainStage2 A M M' 0 0) ◁ + chainInsQ A M M' 0 0) ≫ + (α_ M'.X (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 1)).hom = + (α_ M'.X (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (M'.X ◁ ((chainStage2 A M M' 0 0) ◁ + chainInsQ A M M' 0 0)) := + associator_naturality_right _ _ _ + have hW7 : (M'.X ◁ ((chainStage2 A M M' 0 0) ◁ + chainInsQ A M M' 0 0)) ≫ + (M'.X ◁ chainMul2 A M M' 0 0 0 1) = + M'.X ◁ ((β_ (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (α_ M.X (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 0)).hom ≫ + (M.X ◁ chainMul2 A M M' 0 0 0 0) ≫ + chainInsQ A M M' (0 + 1 + 0) (0 + 1 + 0)) := + (MonoidalCategory.whiskerLeft_comp _ _ _).symm.trans + (congrArg (fun t => M'.X ◁ t) (insQ_snd A M M')) + have hW8 : (((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ⊗ₘ + ((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d))) ≫ + (β_ (M.X ⊗ chainStage2 A M M' 0 0) + (M'.X ⊗ chainStage2 A M M' 0 0)).hom = + (β_ M.X M'.X).hom ≫ + (((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ⊗ₘ + ((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d))) := + BraidedCategory.braiding_naturality _ _ + calc chainPairRaw A M M' d + = (((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ⊗ₘ + ((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d))) ≫ + ((chainInsQ A M M' 0 0 ⊗ₘ chainInsP A M M' 0 0) ≫ + chainMul2 A M M' 0 1 1 0) := by + rw [chainPairRaw, hW2] + simp only [Category.assoc] + _ = (((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ⊗ₘ + ((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d))) ≫ + (chainInsQ A M M' 0 0 ▷ + (M'.X ⊗ chainStage2 A M M' 0 0)) ≫ + ((β_ (chainStage2 A M M' 0 1) + (M'.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (α_ M'.X (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 1)).hom ≫ + (M'.X ◁ chainMul2 A M M' 0 0 0 1) ≫ + chainInsP A M M' (0 + 1 + 0) (0 + 1 + 1)) := by + rw [hW3, insP_snd] + _ = (((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ⊗ₘ + ((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d))) ≫ + (β_ (M.X ⊗ chainStage2 A M M' 0 0) + (M'.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + ((M'.X ⊗ chainStage2 A M M' 0 0) ◁ + chainInsQ A M M' 0 0) ≫ + (α_ M'.X (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 1)).hom ≫ + (M'.X ◁ chainMul2 A M M' 0 0 0 1) ≫ + chainInsP A M M' (0 + 1 + 0) (0 + 1 + 1) := by + rw [← Category.assoc + (chainInsQ A M M' 0 0 ▷ + (M'.X ⊗ chainStage2 A M M' 0 0)), hW5] + simp only [Category.assoc] + _ = (β_ M.X M'.X).hom ≫ + (((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ⊗ₘ + ((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d))) ≫ + ((M'.X ⊗ chainStage2 A M M' 0 0) ◁ + chainInsQ A M M' 0 0) ≫ + (α_ M'.X (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 1)).hom ≫ + (M'.X ◁ chainMul2 A M M' 0 0 0 1) ≫ + chainInsP A M M' (0 + 1 + 0) (0 + 1 + 1) := by + rw [← Category.assoc _ + (β_ (M.X ⊗ chainStage2 A M M' 0 0) + (M'.X ⊗ chainStage2 A M M' 0 0)).hom, hW8] + simp only [Category.assoc] + _ = (β_ M.X M'.X).hom ≫ + (((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ⊗ₘ + ((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d))) ≫ + (α_ M'.X (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + ((M'.X ◁ ((chainStage2 A M M' 0 0) ◁ + chainInsQ A M M' 0 0)) ≫ + (M'.X ◁ chainMul2 A M M' 0 0 0 1)) ≫ + chainInsP A M M' (0 + 1 + 0) (0 + 1 + 1) := by + rw [← Category.assoc + ((M'.X ⊗ chainStage2 A M M' 0 0) ◁ + chainInsQ A M M' 0 0), hW6] + simp only [Category.assoc] + _ = (β_ M.X M'.X).hom ≫ + (((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ⊗ₘ + ((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d))) ≫ + (α_ M'.X (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (M'.X ◁ ((β_ (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (α_ M.X (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 0)).hom ≫ + (M.X ◁ chainMul2 A M M' 0 0 0 0) ≫ + chainInsQ A M M' (0 + 1 + 0) (0 + 1 + 0))) ≫ + chainInsP A M M' (0 + 1 + 0) (0 + 1 + 1) := by + rw [hW7] + +/-- **The swapped base element against the double transition, +normalised**: the pair element rides the first transition into +the double insertion, and the second transition slides inside. -/ +private theorem swapDelta_normal + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + ((((symPowOne A M'.X).inv ⊗ₘ (symPowOne A M.X).inv) ≫ + modTensorπ A (symPowMod A M'.X 0) (symPowMod A M.X 0)) ≫ + chainDelta2 A M M' d 0 0) ≫ chainDelta2 A M M' d 1 1 = + (ρ_ (M'.X ⊗ M.X)).inv ≫ + (α_ M'.X M.X (𝟙_ D)).hom ≫ + (M'.X ◁ (M.X ◁ (chainSeed A M M' d ≫ + chainDelta2 A M M' d 0 0))) ≫ + (M'.X ◁ chainInsQ A M M' (0 + 1) (0 + 1)) ≫ + chainInsP A M M' (0 + 1) (1 + 1) := by + have hU2 := comp_chainDelta2 A M M' d 0 0 + ((((symPowOne A M'.X).inv ⊗ₘ (symPowOne A M.X).inv) ≫ + modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 0))) + have hU4 : chainInsP A M M' 0 1 ≫ + chainDelta2 A M M' d 1 1 = + (M'.X ◁ chainDelta2 A M M' d 0 1) ≫ + chainInsP A M M' (0 + 1) (1 + 1) := by + rw [show chainDelta2 A M M' d 1 1 = + chainDelta2 A M M' d (0 + 1) 1 from rfl] + exact (chainInsP_delta2 A M M' d 0 1).symm + have hU5 : chainInsQ A M M' 0 0 ≫ + chainDelta2 A M M' d 0 1 = + (M.X ◁ chainDelta2 A M M' d 0 0) ≫ + chainInsQ A M M' (0 + 1) (0 + 1) := by + rw [show chainDelta2 A M M' d 0 1 = + chainDelta2 A M M' d 0 (0 + 1) from rfl] + exact (chainInsQ_delta2 A M M' d 0 0).symm + have hU6 : ((M'.X ⊗ M.X) ◁ chainSeed A M M' d) ≫ + (α_ M'.X M.X (chainStage2 A M M' 0 0)).hom = + (α_ M'.X M.X (𝟙_ D)).hom ≫ + (M'.X ◁ (M.X ◁ chainSeed A M M' d)) := + associator_naturality_right _ _ _ + have C12 : ((((symPowOne A M'.X).inv ⊗ₘ + (symPowOne A M.X).inv) ≫ + modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 0)) ≫ + chainDelta2 A M M' d 0 0) ≫ chainDelta2 A M M' d 1 1 = + ((ρ_ (M'.X ⊗ M.X)).inv ≫ + ((M'.X ⊗ M.X) ◁ chainSeed A M M' d) ≫ + ((α_ M'.X M.X (chainStage2 A M M' 0 0)).hom ≫ + (M'.X ◁ chainInsQ A M M' 0 0) ≫ + chainInsP A M M' 0 1)) ≫ + chainDelta2 A M M' d 1 1 := + eq_whisker (hU2.trans (whisker_eq _ + (whisker_eq _ (pairIns A M M')))) _ + have C3 : ((ρ_ (M'.X ⊗ M.X)).inv ≫ + ((M'.X ⊗ M.X) ◁ chainSeed A M M' d) ≫ + ((α_ M'.X M.X (chainStage2 A M M' 0 0)).hom ≫ + (M'.X ◁ chainInsQ A M M' 0 0) ≫ + chainInsP A M M' 0 1)) ≫ + chainDelta2 A M M' d 1 1 = + (ρ_ (M'.X ⊗ M.X)).inv ≫ + ((M'.X ⊗ M.X) ◁ chainSeed A M M' d) ≫ + (α_ M'.X M.X (chainStage2 A M M' 0 0)).hom ≫ + (M'.X ◁ chainInsQ A M M' 0 0) ≫ + (chainInsP A M M' 0 1 ≫ + chainDelta2 A M M' d 1 1) := by + repeat' erw [Category.assoc] + have C4 : (ρ_ (M'.X ⊗ M.X)).inv ≫ + ((M'.X ⊗ M.X) ◁ chainSeed A M M' d) ≫ + (α_ M'.X M.X (chainStage2 A M M' 0 0)).hom ≫ + (M'.X ◁ chainInsQ A M M' 0 0) ≫ + (chainInsP A M M' 0 1 ≫ + chainDelta2 A M M' d 1 1) = + (ρ_ (M'.X ⊗ M.X)).inv ≫ + ((M'.X ⊗ M.X) ◁ chainSeed A M M' d) ≫ + (α_ M'.X M.X (chainStage2 A M M' 0 0)).hom ≫ + (M'.X ◁ chainInsQ A M M' 0 0) ≫ + ((M'.X ◁ chainDelta2 A M M' d 0 1) ≫ + chainInsP A M M' (0 + 1) (1 + 1)) := + whisker_eq _ (whisker_eq _ (whisker_eq _ + (whisker_eq _ hU4))) + have C5 : (M'.X ◁ chainInsQ A M M' 0 0) ≫ + ((M'.X ◁ chainDelta2 A M M' d 0 1) ≫ + chainInsP A M M' (0 + 1) (1 + 1)) = + (M'.X ◁ (M.X ◁ chainDelta2 A M M' d 0 0)) ≫ + (M'.X ◁ chainInsQ A M M' (0 + 1) (0 + 1)) ≫ + chainInsP A M M' (0 + 1) (1 + 1) := + (Category.assoc _ _ _).symm.trans + ((eq_whisker + ((MonoidalCategory.whiskerLeft_comp _ _ _).symm.trans + ((congrArg (fun t => M'.X ◁ t) hU5).trans + (MonoidalCategory.whiskerLeft_comp _ _ _))) _).trans + (Category.assoc _ _ _)) + have C6 : ((M'.X ⊗ M.X) ◁ chainSeed A M M' d) ≫ + (α_ M'.X M.X (chainStage2 A M M' 0 0)).hom ≫ + (M'.X ◁ (M.X ◁ chainDelta2 A M M' d 0 0)) ≫ + (M'.X ◁ chainInsQ A M M' (0 + 1) (0 + 1)) ≫ + chainInsP A M M' (0 + 1) (1 + 1) = + (α_ M'.X M.X (𝟙_ D)).hom ≫ + (M'.X ◁ (M.X ◁ (chainSeed A M M' d ≫ + chainDelta2 A M M' d 0 0))) ≫ + (M'.X ◁ chainInsQ A M M' (0 + 1) (0 + 1)) ≫ + chainInsP A M M' (0 + 1) (1 + 1) := + (Category.assoc _ _ _).symm.trans + ((eq_whisker hU6 _).trans + ((Category.assoc _ _ _).trans (whisker_eq _ + ((Category.assoc _ _ _).symm.trans + (eq_whisker + ((MonoidalCategory.whiskerLeft_comp + _ _ _).symm.trans + (congrArg (fun t => M'.X ◁ t) + (MonoidalCategory.whiskerLeft_comp + _ _ _).symm)) _))))) + exact C12.trans (C3.trans (C4.trans + ((whisker_eq _ (whisker_eq _ (whisker_eq _ C5))).trans + (whisker_eq _ C6)))) + +/-- The unit-strand coherence of the two seed routes. -/ +private theorem pairPrefix_coh + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (M : Mod D A) (M' : Mod D A) : + ((ρ_ M'.X).inv ▷ M.X) ≫ (α_ M'.X (𝟙_ D) M.X).hom ≫ + (M'.X ◁ ((β_ (𝟙_ D) M.X).hom ≫ + ((ρ_ M.X).inv ▷ (𝟙_ D)) ≫ + (α_ M.X (𝟙_ D) (𝟙_ D)).hom)) = + (ρ_ (M'.X ⊗ M.X)).inv ≫ (α_ M'.X M.X (𝟙_ D)).hom ≫ + (M'.X ◁ (M.X ◁ (ρ_ (𝟙_ D)).inv)) := by + rw [braiding_tensorUnit_left] + monoidal + +/-- A point whiskered onto the left braids to the unit strand. -/ +private theorem seedShuffle + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (M : Mod D A) {S : D} (t : 𝟙_ D ⟶ S) : + (t ▷ M.X) ≫ (β_ S M.X).hom ≫ ((ρ_ M.X).inv ▷ S) ≫ + (α_ M.X (𝟙_ D) S).hom = + (β_ (𝟙_ D) M.X).hom ≫ ((ρ_ M.X).inv ▷ (𝟙_ D)) ≫ + (α_ M.X (𝟙_ D) (𝟙_ D)).hom ≫ + (M.X ◁ ((𝟙_ D) ◁ t)) := by + have h1 : (t ▷ M.X) ≫ (β_ S M.X).hom = + (β_ (𝟙_ D) M.X).hom ≫ (M.X ◁ t) := + BraidedCategory.braiding_naturality_left _ _ + have h2 : (M.X ◁ t) ≫ ((ρ_ M.X).inv ▷ S) = + ((ρ_ M.X).inv ▷ (𝟙_ D)) ≫ ((M.X ⊗ (𝟙_ D)) ◁ t) := + whisker_exchange _ _ + have h3 : ((M.X ⊗ (𝟙_ D)) ◁ t) ≫ + (α_ M.X (𝟙_ D) S).hom = + (α_ M.X (𝟙_ D) (𝟙_ D)).hom ≫ (M.X ◁ ((𝟙_ D) ◁ t)) := + associator_naturality_right _ _ _ + calc (t ▷ M.X) ≫ (β_ S M.X).hom ≫ + ((ρ_ M.X).inv ▷ S) ≫ (α_ M.X (𝟙_ D) S).hom + = (β_ (𝟙_ D) M.X).hom ≫ ((M.X ◁ t) ≫ + ((ρ_ M.X).inv ▷ S)) ≫ (α_ M.X (𝟙_ D) S).hom := by + rw [← Category.assoc, h1] + simp only [Category.assoc] + _ = (β_ (𝟙_ D) M.X).hom ≫ ((ρ_ M.X).inv ▷ (𝟙_ D)) ≫ + (((M.X ⊗ (𝟙_ D)) ◁ t) ≫ + (α_ M.X (𝟙_ D) S).hom) := by + rw [h2] + simp only [Category.assoc] + _ = (β_ (𝟙_ D) M.X).hom ≫ ((ρ_ M.X).inv ▷ (𝟙_ D)) ≫ + (α_ M.X (𝟙_ D) (𝟙_ D)).hom ≫ + (M.X ◁ ((𝟙_ D) ◁ t)) := by + rw [h3] + +/-- The unit-strand coherence, with a generic continuation. -/ +private theorem pairPrefix_coh' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (M : Mod D A) (M' : Mod D A) {T : D} + (g : M.X ⊗ ((𝟙_ D) ⊗ (𝟙_ D)) ⟶ T) : + ((ρ_ M'.X).inv ▷ M.X) ≫ (α_ M'.X (𝟙_ D) M.X).hom ≫ + (M'.X ◁ ((β_ (𝟙_ D) M.X).hom ≫ + ((ρ_ M.X).inv ▷ (𝟙_ D)) ≫ + (α_ M.X (𝟙_ D) (𝟙_ D)).hom ≫ g)) = + (ρ_ (M'.X ⊗ M.X)).inv ≫ (α_ M'.X M.X (𝟙_ D)).hom ≫ + (M'.X ◁ ((M.X ◁ (ρ_ (𝟙_ D)).inv) ≫ g)) := by + have hsplit : M'.X ◁ ((β_ (𝟙_ D) M.X).hom ≫ + ((ρ_ M.X).inv ▷ (𝟙_ D)) ≫ + (α_ M.X (𝟙_ D) (𝟙_ D)).hom ≫ g) = + (M'.X ◁ ((β_ (𝟙_ D) M.X).hom ≫ + ((ρ_ M.X).inv ▷ (𝟙_ D)) ≫ + (α_ M.X (𝟙_ D) (𝟙_ D)).hom)) ≫ (M'.X ◁ g) := by + simp only [MonoidalCategory.whiskerLeft_comp, + Category.assoc] + have hsplit' : M'.X ◁ ((M.X ◁ (ρ_ (𝟙_ D)).inv) ≫ g) = + (M'.X ◁ (M.X ◁ (ρ_ (𝟙_ D)).inv)) ≫ (M'.X ◁ g) := + MonoidalCategory.whiskerLeft_comp _ _ _ + rw [hsplit, hsplit'] + rw [reassoc_of% (pairPrefix_coh A M M')] + +private theorem pairSeed_tensor_prefix + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + (((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ⊗ₘ + ((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d))) ≫ + (α_ M'.X (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (M'.X ◁ ((β_ (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (α_ M.X (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 0)).hom ≫ + (M.X ◁ chainMul2 A M M' 0 0 0 0))) + = (((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ▷ M.X) ≫ + (α_ M'.X (chainStage2 A M M' 0 0) M.X).hom ≫ + (M'.X ◁ (((chainStage2 A M M' 0 0) ◁ + ((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d))) ≫ + (β_ (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (α_ M.X (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 0)).hom ≫ + (M.X ◁ chainMul2 A M M' 0 0 0 0))) := by + have hD1 : (((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ⊗ₘ + ((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d))) = + (((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ▷ M.X) ≫ + ((M'.X ⊗ (chainStage2 A M M' 0 0)) ◁ + ((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d))) := + MonoidalCategory.tensorHom_def _ _ + have hD2 : ((M'.X ⊗ (chainStage2 A M M' 0 0)) ◁ + ((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d))) ≫ + (α_ M'.X (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom = + (α_ M'.X (chainStage2 A M M' 0 0) M.X).hom ≫ + (M'.X ◁ ((chainStage2 A M M' 0 0) ◁ + ((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)))) := + associator_naturality_right _ _ _ + rw [hD1] + simp only [Category.assoc] + rw [← Category.assoc ((M'.X ⊗ (chainStage2 A M M' 0 0)) ◁ + ((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d))), hD2] + simp only [Category.assoc, + MonoidalCategory.whiskerLeft_comp] + +/-- **The two seed routes agree**: feeding the seeds through the +pair equals feeding them through the transition. -/ +private theorem pairSeed_match + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + (((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ⊗ₘ + ((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d))) ≫ + (α_ M'.X (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (M'.X ◁ ((β_ (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (α_ M.X (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 0)).hom ≫ + (M.X ◁ chainMul2 A M M' 0 0 0 0))) = + (ρ_ (M'.X ⊗ M.X)).inv ≫ (α_ M'.X M.X (𝟙_ D)).hom ≫ + (M'.X ◁ (M.X ◁ (chainSeed A M M' d ≫ + chainDelta2 A M M' d 0 0))) := by + have hD4 : ((chainStage2 A M M' 0 0) ◁ + ((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d))) ≫ + (β_ (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom = + (β_ (chainStage2 A M M' 0 0) M.X).hom ≫ + (((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ▷ + (chainStage2 A M M' 0 0)) := + BraidedCategory.braiding_naturality_right _ _ + have hD6 : ((MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ▷ + (chainStage2 A M M' 0 0)) ≫ + (α_ M.X (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 0)).hom = + (α_ M.X (𝟙_ D) (chainStage2 A M M' 0 0)).hom ≫ + (M.X ◁ (chainSeed A M M' d ▷ (chainStage2 A M M' 0 0))) := + associator_naturality_middle _ _ _ + have hD8 : ((MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ▷ M.X) ≫ + (α_ M'.X (chainStage2 A M M' 0 0) M.X).hom = + (α_ M'.X (𝟙_ D) M.X).hom ≫ + (M'.X ◁ (chainSeed A M M' d ▷ M.X)) := + associator_naturality_middle _ _ _ + have hSeed : chainSeed A M M' d ≫ + chainDelta2 A M M' d 0 0 = + (ρ_ (𝟙_ D)).inv ≫ ((𝟙_ D) ◁ chainSeed A M M' d) ≫ + ((chainSeed A M M' d ▷ (chainStage2 A M M' 0 0)) ≫ + chainMul2 A M M' 0 0 0 0) := + comp_chainDelta2 A M M' d 0 0 (chainSeed A M M' d) + -- Assemble: reduce the left side to the coherence prefix + -- against the common seed tail, then close by the unit-strand + -- coherence. + calc (((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ⊗ₘ + ((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d))) ≫ + (α_ M'.X (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (M'.X ◁ ((β_ (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (α_ M.X (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 0)).hom ≫ + (M.X ◁ chainMul2 A M M' 0 0 0 0))) + = (((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ▷ M.X) ≫ + (α_ M'.X (chainStage2 A M M' 0 0) M.X).hom ≫ + (M'.X ◁ (((chainStage2 A M M' 0 0) ◁ + ((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d))) ≫ + (β_ (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (α_ M.X (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 0)).hom ≫ + (M.X ◁ chainMul2 A M M' 0 0 0 0))) := pairSeed_tensor_prefix A M M' d + _ = (((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ▷ M.X) ≫ + (α_ M'.X (chainStage2 A M M' 0 0) M.X).hom ≫ + (M'.X ◁ ((β_ (chainStage2 A M M' 0 0) M.X).hom ≫ + ((ρ_ M.X).inv ▷ (chainStage2 A M M' 0 0)) ≫ + ((MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ▷ + (chainStage2 A M M' 0 0)) ≫ + (α_ M.X (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 0)).hom ≫ + (M.X ◁ chainMul2 A M M' 0 0 0 0))) := by + refine whisker_eq _ (whisker_eq _ + (congrArg (fun t => M'.X ◁ t) ?_)) + refine (Category.assoc _ _ _).symm.trans ?_ + refine (eq_whisker hD4 _).trans ?_ + simp only [Category.assoc, + MonoidalCategory.comp_whiskerRight] + _ = (((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ▷ M.X) ≫ + (α_ M'.X (chainStage2 A M M' 0 0) M.X).hom ≫ + (M'.X ◁ ((β_ (chainStage2 A M M' 0 0) M.X).hom ≫ + ((ρ_ M.X).inv ▷ (chainStage2 A M M' 0 0)) ≫ + (α_ M.X (𝟙_ D) (chainStage2 A M M' 0 0)).hom ≫ + (M.X ◁ ((chainSeed A M M' d ▷ + (chainStage2 A M M' 0 0)) ≫ + chainMul2 A M M' 0 0 0 0)))) := by + refine whisker_eq _ (whisker_eq _ + (congrArg (fun t => M'.X ◁ t) + (whisker_eq _ (whisker_eq _ ?_)))) + refine (Category.assoc _ _ _).symm.trans ?_ + refine (eq_whisker hD6 _).trans ?_ + refine (Category.assoc _ _ _).trans (whisker_eq _ ?_) + exact (MonoidalCategory.whiskerLeft_comp _ _ _).symm + _ = ((ρ_ M'.X).inv ▷ M.X) ≫ + (α_ M'.X (𝟙_ D) M.X).hom ≫ + (M'.X ◁ (((chainSeed A M M' d) ▷ M.X) ≫ + (β_ (chainStage2 A M M' 0 0) M.X).hom ≫ + ((ρ_ M.X).inv ▷ (chainStage2 A M M' 0 0)) ≫ + (α_ M.X (𝟙_ D) (chainStage2 A M M' 0 0)).hom ≫ + (M.X ◁ ((chainSeed A M M' d ▷ + (chainStage2 A M M' 0 0)) ≫ + chainMul2 A M M' 0 0 0 0)))) := by + refine (eq_whisker + (MonoidalCategory.comp_whiskerRight + (ρ_ M'.X).inv (MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) M.X) _).trans ?_ + refine (Category.assoc _ _ _).trans ?_ + refine whisker_eq _ ?_ + refine (Category.assoc _ _ _).symm.trans ?_ + refine (eq_whisker hD8 _).trans ?_ + refine (Category.assoc _ _ _).trans ?_ + refine whisker_eq _ ?_ + exact (MonoidalCategory.whiskerLeft_comp _ _ _).symm + _ = ((ρ_ M'.X).inv ▷ M.X) ≫ + (α_ M'.X (𝟙_ D) M.X).hom ≫ + (M'.X ◁ ((β_ (𝟙_ D) M.X).hom ≫ + ((ρ_ M.X).inv ▷ (𝟙_ D)) ≫ + (α_ M.X (𝟙_ D) (𝟙_ D)).hom ≫ + (M.X ◁ (((𝟙_ D) ◁ chainSeed A M M' d) ≫ + ((chainSeed A M M' d ▷ + (chainStage2 A M M' 0 0)) ≫ + chainMul2 A M M' 0 0 0 0))))) := by + refine whisker_eq _ (whisker_eq _ + (congrArg (fun t => M'.X ◁ t) ?_)) + have hre : ((chainSeed A M M' d) ▷ M.X) ≫ + (β_ (chainStage2 A M M' 0 0) M.X).hom ≫ + ((ρ_ M.X).inv ▷ (chainStage2 A M M' 0 0)) ≫ + (α_ M.X (𝟙_ D) (chainStage2 A M M' 0 0)).hom ≫ + (M.X ◁ ((chainSeed A M M' d ▷ + (chainStage2 A M M' 0 0)) ≫ + chainMul2 A M M' 0 0 0 0)) = + (((chainSeed A M M' d) ▷ M.X) ≫ + (β_ (chainStage2 A M M' 0 0) M.X).hom ≫ + ((ρ_ M.X).inv ▷ (chainStage2 A M M' 0 0)) ≫ + (α_ M.X (𝟙_ D) (chainStage2 A M M' 0 0)).hom) ≫ + (M.X ◁ ((chainSeed A M M' d ▷ + (chainStage2 A M M' 0 0)) ≫ + chainMul2 A M M' 0 0 0 0)) := by + repeat' erw [Category.assoc] + refine hre.trans ?_ + refine (eq_whisker (seedShuffle A M + (S := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) _).trans ?_ + simp only [Category.assoc] + refine whisker_eq _ (whisker_eq _ (whisker_eq _ ?_)) + exact (MonoidalCategory.whiskerLeft_comp _ _ _).symm + _ = (ρ_ (M'.X ⊗ M.X)).inv ≫ + (α_ M'.X M.X (𝟙_ D)).hom ≫ + (M'.X ◁ ((M.X ◁ (ρ_ (𝟙_ D)).inv) ≫ + (M.X ◁ (((𝟙_ D) ◁ chainSeed A M M' d) ≫ + ((chainSeed A M M' d ▷ + (chainStage2 A M M' 0 0)) ≫ + chainMul2 A M M' 0 0 0 0))))) := + pairPrefix_coh' A M M' _ + _ = (ρ_ (M'.X ⊗ M.X)).inv ≫ + (α_ M'.X M.X (𝟙_ D)).hom ≫ + (M'.X ◁ (M.X ◁ (chainSeed A M M' d ≫ + chainDelta2 A M M' d 0 0))) := by + refine whisker_eq _ (whisker_eq _ + (congrArg (fun t => M'.X ◁ t) ?_)) + refine ((MonoidalCategory.whiskerLeft_comp + _ _ _).symm.trans + (congrArg (fun t => M.X ◁ t) ?_)) + exact hSeed.symm + +/-- The seed-route agreement, with a generic continuation. -/ +private theorem pairSeed_match' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') {T : D} (g : M'.X ⊗ (M.X ⊗ chainStage2 A M M' + (0 + 1) (0 + 1)) ⟶ T) : + ((((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ⊗ₘ + ((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d))) ≫ + (α_ M'.X (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (M'.X ◁ ((β_ (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (α_ M.X (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 0)).hom ≫ + (M.X ◁ chainMul2 A M M' 0 0 0 0))) ≫ g) = + (ρ_ (M'.X ⊗ M.X)).inv ≫ (α_ M'.X M.X (𝟙_ D)).hom ≫ + (M'.X ◁ (M.X ◁ (chainSeed A M M' d ≫ + chainDelta2 A M M' d 0 0))) ≫ g := by + have h1 : ((((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ⊗ₘ + ((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d))) ≫ + (α_ M'.X (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (M'.X ◁ ((β_ (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (α_ M.X (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 0)).hom ≫ + (M.X ◁ chainMul2 A M M' 0 0 0 0))) ≫ g) = + ((((ρ_ M'.X).inv ≫ MonoidalCategory.whiskerLeft M'.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ⊗ₘ + ((ρ_ M.X).inv ≫ MonoidalCategory.whiskerLeft M.X + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d))) ≫ + (α_ M'.X (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (M'.X ◁ ((β_ (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (α_ M.X (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 0)).hom ≫ + (M.X ◁ chainMul2 A M M' 0 0 0 0)))) ≫ g := by + simp only [Category.assoc] + have h2 : (ρ_ (M'.X ⊗ M.X)).inv ≫ + (α_ M'.X M.X (𝟙_ D)).hom ≫ + (M'.X ◁ (M.X ◁ (chainSeed A M M' d ≫ + chainDelta2 A M M' d 0 0))) ≫ g = + ((ρ_ (M'.X ⊗ M.X)).inv ≫ + (α_ M'.X M.X (𝟙_ D)).hom ≫ + (M'.X ◁ (M.X ◁ (chainSeed A M M' d ≫ + chainDelta2 A M M' d 0 0)))) ≫ g := by + simp only [Category.assoc] + rw [h1, h2, pairSeed_match] + +/-- **The raw pair product is the swapped base element against +the double transition.** -/ +theorem chainPairRaw_eq + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + chainPairRaw A M M' d = + (β_ M.X M'.X).hom ≫ + (((((symPowOne A M'.X).inv ⊗ₘ + (symPowOne A M.X).inv) ≫ + modTensorπ A (symPowMod A M'.X 0) (symPowMod A M.X 0)) ≫ + chainDelta2 A M M' d 0 0) ≫ + chainDelta2 A M M' d 1 1) := by + rw [pairRaw_normal, swapDelta_normal] + refine whisker_eq _ ?_ + have hsplit : M'.X ◁ ((β_ (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (α_ M.X (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 0)).hom ≫ + (M.X ◁ chainMul2 A M M' 0 0 0 0) ≫ + chainInsQ A M M' (0 + 1 + 0) (0 + 1 + 0)) = + (M'.X ◁ ((β_ (chainStage2 A M M' 0 0) + (M.X ⊗ chainStage2 A M M' 0 0)).hom ≫ + (α_ M.X (chainStage2 A M M' 0 0) + (chainStage2 A M M' 0 0)).hom ≫ + (M.X ◁ chainMul2 A M M' 0 0 0 0))) ≫ + (M'.X ◁ chainInsQ A M M' (0 + 1 + 0) (0 + 1 + 0)) := by + simp only [MonoidalCategory.whiskerLeft_comp, + Category.assoc] + rw [hsplit] + rw [show chainInsQ A M M' (0 + 1 + 0) (0 + 1 + 0) = + chainInsQ A M M' (0 + 1) (0 + 1) from rfl] + rw [show chainInsP A M M' (0 + 1 + 0) (0 + 1 + 1) = + chainInsP A M M' (0 + 1) (1 + 1) from rfl] + refine Eq.trans + (whisker_eq _ (whisker_eq _ (Category.assoc _ _ _))) ?_ + exact pairSeed_match' A M M' d + ((M'.X ◁ chainInsQ A M M' (0 + 1) (0 + 1)) ≫ + chainInsP A M M' (0 + 1) (1 + 1)) + +/-- **The descended pair product is the swap, the pair +embedding, and the double transition** — the map form of the +section identity. -/ +theorem chainPairMul_eq + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + chainPairMul A M M' d = + modTensorSwap A M M' ≫ + modTensorMap A (toSymPowModZero A M') (toSymPowModZero A M) ≫ + chainDelta2 A M M' d 0 0 ≫ + chainDelta2 A M M' d 1 1 := by + refine modTensor_hom_ext A M M' ?_ + rw [modTensorπ_chainPairMul, chainPairRaw_eq] + have hRside : modTensorπ A M M' ≫ modTensorSwap A M M' ≫ + modTensorMap A (toSymPowModZero A M') + (toSymPowModZero A M) ≫ + chainDelta2 A M M' d 0 0 ≫ + chainDelta2 A M M' d 1 1 = + (β_ M.X M'.X).hom ≫ + (((symPowOne A M'.X).inv ⊗ₘ (symPowOne A M.X).inv) ≫ + modTensorπ A (symPowMod A M'.X 0) + (symPowMod A M.X 0)) ≫ + chainDelta2 A M M' d 0 0 ≫ + chainDelta2 A M M' d 1 1 := by + rw [modTensorπ_swap_assoc, modTensorπ_map_assoc] + rw [show (toSymPowModZero A M').hom = + (symPowOne A M'.X).inv from rfl, + show (toSymPowModZero A M).hom = + (symPowOne A M.X).inv from rfl] + repeat' erw [Category.assoc] + rfl + rw [hRside] + exact whisker_eq _ (Category.assoc _ _ _) + +/-- **The copair element multiplies to the doubly advanced +seed**: the element form of the section identity. -/ +theorem copairUnit_chainPairMul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + copairUnit A M M' d ≫ chainPairMul A M M' d = + chainSeed A M M' d ≫ chainDelta2 A M M' d 0 0 ≫ + chainDelta2 A M M' d 1 1 := by + rw [chainPairMul_eq] + have h : copairUnit A M M' d ≫ modTensorSwap A M M' ≫ + modTensorMap A (toSymPowModZero A M') + (toSymPowModZero A M) = chainSeed A M M' d := rfl + exact (whisker_eq _ (Category.assoc _ _ _).symm).trans + ((Category.assoc _ _ _).symm.trans (eq_whisker h _)) + +end PairMul + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ShapeAlgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ShapeAlgebra.lean new file mode 100644 index 0000000000..dbdd7dbb3d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ShapeAlgebra.lean @@ -0,0 +1,60 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ShapeFintype +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage + +/-! +# The central idempotents, indexed by shapes of a fixed size + +`SchurPackage.e μ` lives in the group algebra of `S_{μ.card}`; the +Deligne development sums such idempotents over all shapes of one +size `n`, so it needs them all in the *same* algebra. `Shape.e` +recasts the idempotent of `μ : Shape n` into `SymGroupAlgebra n` +along the standard embedding at `μ.prop : μ.val.card = n` — an +algebra map, so idempotence and products transport; an injective +one, so nonvanishing transports too. +-/ + +@[expose] public section + +namespace RS + +/-- `symCast` along an equality of sizes is injective (it is +`mapDomain` along an injective map). -/ +theorem symCast_injective {m n : ℕ} (h : m ≤ n) : + Function.Injective (symCast (m := m) (n := n) h) := by + intro x y hxy + exact MonoidAlgebra.mapDomain_injective + (Equiv.Perm.viaEmbeddingHom_injective (Fin.castLEEmb h)) hxy + +/-- The central idempotent of a shape of size `n`, recast into the +group algebra of `S_n`. -/ +noncomputable def Shape.e (P : SchurPackage.{u}) {n : ℕ} + (μ : Shape n) : SymGroupAlgebra n := + symCast (le_of_eq μ.prop) (P.e μ.val) + +/-- The recast idempotent is idempotent. -/ +theorem Shape.e_mul_self (P : SchurPackage.{u}) {n : ℕ} + (μ : Shape n) : Shape.e P μ * Shape.e P μ = Shape.e P μ := by + rw [Shape.e, ← map_mul] + exact congrArg _ (P.idem μ.val) + +/-- The recast idempotent is nonzero exactly when the original +is. -/ +theorem Shape.e_eq_zero_iff (P : SchurPackage.{u}) {n : ℕ} + (μ : Shape n) : Shape.e P μ = 0 ↔ P.e μ.val = 0 := by + constructor + · intro h + apply symCast_injective (le_of_eq μ.prop) + rw [map_zero] + exact h + · intro h + rw [Shape.e, h, map_zero] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ShapeFintype.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ShapeFintype.lean new file mode 100644 index 0000000000..1b7c556558 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ShapeFintype.lean @@ -0,0 +1,100 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams + +/-! +# Young diagrams of a fixed size + +`Shape n` is the type of Young diagrams with exactly `n` cells. It +carries decidable equality and a `Fintype` instance, obtained from the +correspondence with `Nat.Partition n` that reads off the row lengths. +This is the tree's standard idiom for "sum over the partitions of `n`". +-/ + +@[expose] public section + +namespace RS + +/-! ### Counting cells by rows -/ + +/-- Young diagrams are determined by their lists of row lengths. -/ +theorem rowLens_injective : Function.Injective YoungDiagram.rowLens := + fun _ _ h => YoungDiagram.equivListRowLens.injective (Subtype.ext h) + +/-! ### Shapes -/ + +/-- The Young diagrams with `n` cells. -/ +def Shape (n : ℕ) : Type := {μ : YoungDiagram // μ.card = n} + +namespace Shape + +/-- A shape's diagram has exactly `n` cells. -/ +@[simp] +theorem card_val {n : ℕ} (μ : Shape n) : μ.val.card = n := μ.property + +/-- Shapes are equal as soon as their diagrams are. -/ +@[ext] +theorem ext {n : ℕ} {μ ν : Shape n} (h : μ.val = ν.val) : μ = ν := + Subtype.ext h + +end Shape + +/-- Equality of shapes is decidable, cell set by cell set. -/ +instance (n : ℕ) : DecidableEq (Shape n) := fun μ ν => + decidable_of_iff (μ.val.cells = ν.val.cells) + ((Subtype.ext_iff.trans YoungDiagram.ext_iff).symm) + +/-! ### The correspondence with partitions -/ + +/-- Young diagrams of size `n` correspond to partitions of `n`, +by reading off the row lengths. -/ +noncomputable def shapeEquivPartition (n : ℕ) : + Shape n ≃ Nat.Partition n where + toFun μ := + { parts := ↑μ.val.rowLens + parts_pos := fun hi => + μ.val.pos_of_mem_rowLens _ (Multiset.mem_coe.mp hi) + parts_sum := by + rw [Multiset.sum_coe, ← card_eq_sum_rowLens, μ.card_val] } + invFun p := + ⟨YoungDiagram.ofRowLens (p.parts.sort (· ≥ ·)) + (Multiset.pairwise_sort p.parts (· ≥ ·)).sortedGE, + by + rw [card_eq_sum_rowLens, + YoungDiagram.rowLens_ofRowLens_eq_self + (fun x hx => p.parts_pos ((Multiset.mem_sort _).mp hx)), + ← Multiset.sum_coe, Multiset.sort_eq, p.parts_sum]⟩ + left_inv μ := by + apply Shape.ext + apply rowLens_injective + rw [YoungDiagram.rowLens_ofRowLens_eq_self + (fun x hx => μ.val.pos_of_mem_rowLens _ + (Multiset.mem_coe.mp ((Multiset.mem_sort _).mp hx))), + Multiset.coe_sort, + List.mergeSort_eq_self _ (μ.val.rowLens_sorted.pairwise)] + right_inv p := by + apply Nat.Partition.ext + dsimp only + rw [YoungDiagram.rowLens_ofRowLens_eq_self + (fun x hx => p.parts_pos ((Multiset.mem_sort _).mp hx)), + Multiset.sort_eq] + +/-- The multiset of parts of the partition attached to a shape is the +multiset of its row lengths. -/ +@[simp] +theorem shapeEquivPartition_apply_parts {n : ℕ} (μ : Shape n) : + ((shapeEquivPartition n) μ).parts = ↑μ.val.rowLens := + rfl + +/-- There are finitely many Young diagrams with `n` cells: as many as +there are partitions of `n`. -/ +noncomputable instance (n : ℕ) : Fintype (Shape n) := + Fintype.ofEquiv _ (shapeEquivPartition n).symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SignConj.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SignConj.lean new file mode 100644 index 0000000000..092cf113f5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SignConj.lean @@ -0,0 +1,280 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoverFactor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddPermSign + +/-! +# Conjugating the permutation action through the twisted power +identification + +Over the plain covers the twisted power identification is the +shuffle followed by the projection, so the descended permutation +action on the powers of a twisted module conjugates to the +simultaneous action: the plain action on the twisting powers +alongside the descended action on the module powers. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The conjugated permutation action**: through the twisted +power identification, the descended action on the powers of a +twisted module is the simultaneous action on the twisting powers +and the module powers. -/ +theorem twistPow_perm_conj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] + (V : D) (R : Mod D A) (k : ℕ) + (σ : Equiv.Perm (Fin (k + 1))) : + modPowPerm (A := A) (X := (tensorLeftMod A V R).X) + (k + 1) σ ≫ ((twistPowModIso A V R k).hom).hom = + ((twistPowModIso A V R k).hom).hom ≫ + (permMor V (k + 1) σ ⊗ₘ + modPowPerm (A := A) (X := R.X) (k + 1) σ) := by + refine (cancel_epi + (modPowπ A ((tensorLeftMod A V R).X) (k + 1))).mp ?_ + have hcov := twistPow_cover_factor A V R k + have h2 : permMor ((tensorLeftMod A V R).X) (k + 1) σ ≫ + (plainShuffle V R.X (k + 1)).hom = + (plainShuffle V R.X (k + 1)).hom ≫ + (permMor V (k + 1) σ ⊗ₘ permMor R.X (k + 1) σ) := + plainShuffle_permMor V R.X (k + 1) σ + have h3 : (permMor V (k + 1) σ ⊗ₘ + permMor R.X (k + 1) σ) ≫ + (tensorPow D V (k + 1) ◁ modPowπ A R.X (k + 1)) = + (tensorPow D V (k + 1) ◁ modPowπ A R.X (k + 1)) ≫ + (permMor V (k + 1) σ ⊗ₘ + modPowPerm (A := A) (X := R.X) (k + 1) σ) := by + erw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.comp_id, Category.id_comp, modPowπ_perm] + erw [modPowπ_perm_assoc, hcov] + exact ((Category.assoc _ _ _).symm.trans + ((eq_whisker h2 _).trans + ((Category.assoc _ _ _).trans + ((whisker_eq _ h3).trans + ((Category.assoc _ _ _).symm.trans + ((eq_whisker hcov.symm _).trans + (Category.assoc _ _ _))))))) + +/-- The carrier of the twisted power identification. -/ +noncomputable def twistPowCarrierIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] + (V : D) (R : Mod D A) + (k : ℕ) : + modPow A ((tensorLeftMod A V R).X) (k + 1) ≅ + tensorPow D V (k + 1) ⊗ modPow A R.X (k + 1) where + hom := ((twistPowModIso A V R k).hom).hom + inv := ((twistPowModIso A V R k).inv).hom + hom_inv_id := by + exact congrArg Mod.Hom.hom + (twistPowModIso A V R k).hom_inv_id + inv_hom_id := by + exact congrArg Mod.Hom.hom + (twistPowModIso A V R k).inv_hom_id + +section Collapse + +/-- Each conjugated permutation over an odd line is the sign +times the whiskered module action. -/ +theorem twistPow_perm_conj_oddLine + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (R : Mod D A) + (k : ℕ) (σ : Equiv.Perm (Fin (k + 1))) : + modPowPerm (A := A) (X := (tensorLeftMod A L.obj R).X) + (k + 1) σ ≫ ((twistPowModIso A L.obj R k).hom).hom = + ((Equiv.Perm.sign σ : ℤ) : ℂ) • + (((twistPowModIso A L.obj R k).hom).hom ≫ + (tensorPow D L.obj (k + 1) ◁ + modPowPerm (A := A) (X := R.X) (k + 1) σ)) := by + erw [twistPow_perm_conj, oddLine_permMor, + MonoidalCategory.tensorHom_def, + MonoidalLinear.smul_whiskerRight, Linear.smul_comp, + MonoidalCategory.id_whiskerRight, Category.id_comp] + exact Linear.comp_smul _ _ _ _ _ _ + +/-- **The symmetriser collapses over an odd line**: through the +twisted power identification, the symmetriser of the twisted +module powers is the whiskered antisymmetriser of the module +powers. -/ +theorem twistPow_symIdem_conj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (R : Mod D A) + (k : ℕ) : + symPowIdem A ((tensorLeftMod A L.obj R).X) (k + 1) ≫ + ((twistPowModIso A L.obj R k).hom).hom = + ((twistPowModIso A L.obj R k).hom).hom ≫ + (tensorPow D L.obj (k + 1) ◁ + altPowIdem A R.X (k + 1)) := by + have halt : ∀ σ : Equiv.Perm (Fin (k + 1)), + modPowAlg A R.X (k + 1) (MonoidAlgebra.single σ + ((Equiv.Perm.sign σ : ℤ) : ℂ)) = + ((Equiv.Perm.sign σ : ℤ) : ℂ) • + modPowPerm (A := A) (X := R.X) (k + 1) σ := by + intro σ + rw [show MonoidAlgebra.single σ + ((Equiv.Perm.sign σ : ℤ) : ℂ) = + ((Equiv.Perm.sign σ : ℤ) : ℂ) • + MonoidAlgebra.single σ (1 : ℂ) from by + rw [MonoidAlgebra.smul_single', mul_one], + map_smul, modPowAlg_single] + -- The antisymmetriser's whiskered normal form, free of the + -- identification. + have hb : tensorPow D L.obj (k + 1) ◁ + altPowIdem A R.X (k + 1) = + ((Nat.factorial (k + 1) : ℂ))⁻¹ • + ∑ σ : Equiv.Perm (Fin (k + 1)), + ((Equiv.Perm.sign σ : ℤ) : ℂ) • + (tensorPow D L.obj (k + 1) ◁ + modPowPerm (A := A) (X := R.X) (k + 1) σ) := by + rw [altPowIdem, antisymmetriser, map_smul, map_sum] + simp only [halt] + change tensorPow D L.obj (k + 1) ◁ + (((Nat.factorial (k + 1) : ℂ))⁻¹ • + ∑ σ : Equiv.Perm (Fin (k + 1)), + ((Equiv.Perm.sign σ : ℤ) : ℂ) • + (modPowPerm (A := A) (X := R.X) (k + 1) σ : + modPow A R.X (k + 1) ⟶ + modPow A R.X (k + 1))) = _ + rw [MonoidalLinear.whiskerLeft_smul, + whiskerLeft_sum] + exact congrArg _ (Finset.sum_congr rfl fun σ _ => + MonoidalLinear.whiskerLeft_smul _ _ _) + have hc : ((twistPowModIso A L.obj R k).hom).hom ≫ + (tensorPow D L.obj (k + 1) ◁ altPowIdem A R.X (k + 1)) = + ((Nat.factorial (k + 1) : ℂ))⁻¹ • + ∑ σ : Equiv.Perm (Fin (k + 1)), + ((Equiv.Perm.sign σ : ℤ) : ℂ) • + (((twistPowModIso A L.obj R k).hom).hom ≫ + (tensorPow D L.obj (k + 1) ◁ + modPowPerm (A := A) (X := R.X) (k + 1) σ)) := by + refine Eq.trans (congrArg (fun t : + tensorPow D L.obj (k + 1) ⊗ modPow A R.X (k + 1) ⟶ + tensorPow D L.obj (k + 1) ⊗ modPow A R.X (k + 1) => + ((twistPowModIso A L.obj R k).hom).hom ≫ t) hb) ?_ + refine Eq.trans (Linear.comp_smul _ _ _ _ _ _) + (congrArg _ ?_) + refine Eq.trans (Preadditive.comp_sum _ _ _) ?_ + exact Finset.sum_congr rfl fun σ _ => + Linear.comp_smul _ _ _ _ _ _ + refine Eq.trans ?_ hc.symm + rw [symPowIdem, symmetriser, map_smul, map_sum] + simp only [modPowAlg_single] + change (((Nat.factorial (k + 1) : ℂ))⁻¹ • + ∑ σ : Equiv.Perm (Fin (k + 1)), + (modPowPerm (A := A) + (X := (tensorLeftMod A L.obj R).X) (k + 1) σ : + modPow A ((tensorLeftMod A L.obj R).X) (k + 1) ⟶ + modPow A ((tensorLeftMod A L.obj R).X) (k + 1))) ≫ + ((twistPowModIso A L.obj R k).hom).hom = _ + erw [Linear.smul_comp, Preadditive.sum_comp] + exact congrArg _ (Finset.sum_congr rfl fun σ _ => + twistPow_perm_conj_oddLine A L R k σ) + +/-- **The symmetric powers of an odd twist are the twisted +alternating powers**: the coequalizer transports along the +identification through the symmetriser collapse, and the twist +passes out of the colimit. -/ +noncomputable def symPowOddTwistIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) + (R : Mod D A) (k : ℕ) : + symPow A ((tensorLeftMod A L.obj R).X) (k + 1) ≅ + tensorPow D L.obj (k + 1) ⊗ altPow A R.X (k + 1) := + HasColimit.isoOfNatIso (parallelPair.ext + (F := parallelPair + (symPowIdem A ((tensorLeftMod A L.obj R).X) (k + 1)) + (𝟙 (modPow A ((tensorLeftMod A L.obj R).X) (k + 1)))) + (G := parallelPair (altPowIdem A R.X (k + 1)) + (𝟙 (modPow A R.X (k + 1))) ⋙ + tensorLeft (tensorPow D L.obj (k + 1))) + (twistPowCarrierIso A L.obj R k) + (twistPowCarrierIso A L.obj R k) + (twistPow_symIdem_conj A L R k) + ((Category.id_comp _).trans + ((Category.comp_id _).symm.trans + (whisker_eq _ + (CategoryTheory.Functor.map_id _ _).symm)))) ≪≫ + (preservesColimitIso + (tensorLeft (tensorPow D L.obj (k + 1))) + (parallelPair (altPowIdem A R.X (k + 1)) + (𝟙 (modPow A R.X (k + 1))))).symm + +/-- Tensor powers of the odd line reflect vanishing. -/ +theorem OddLine.isZero_tensorPow_tensor_iff + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] + (L : OddLine D) + (n : ℕ) (Z : D) : + IsZero (tensorPow D L.obj n ⊗ Z) ↔ IsZero Z := by + induction n generalizing Z with + | zero => + exact ⟨fun h => h.of_iso (λ_ Z).symm, + fun h => isZero_whiskerLeft _ h⟩ + | succ n ih => + refine Iff.trans + ⟨fun h => h.of_iso (α_ _ _ _).symm, + fun h => h.of_iso (α_ _ _ _)⟩ ?_ + exact (ih (L.obj ⊗ Z)).trans (L.isZero_tensor_iff Z) + +/-- **The vanishing criterion for symmetric powers of an odd +twist**: they vanish exactly when the alternating powers of the +module do. -/ +theorem symPowOddTwist_isZero_iff + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + (L : OddLine D) (R : Mod D A) + (k : ℕ) : + IsZero (symPow A ((tensorLeftMod A L.obj R).X) (k + 1)) ↔ + IsZero (altPow A R.X (k + 1)) := + Iff.trans + ⟨fun h => h.of_iso (symPowOddTwistIso A L R k).symm, + fun h => h.of_iso (symPowOddTwistIso A L R k)⟩ + (OddLine.isZero_tensorPow_tensor_iff L (k + 1) + (altPow A R.X (k + 1))) + +end Collapse + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleGenerator.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleGenerator.lean new file mode 100644 index 0000000000..5294a8e42c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleGenerator.lean @@ -0,0 +1,77 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GeneratorAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleQuotient + +/-! +# A simple algebra splitting the tensor generator + +Composing the two halves: the splitting algebra of a single object +is countably presented, and every nonzero algebra object has a +simple quotient. Base change carries the splitting down, so a +single simple algebra splits the chosen object. + +Over a simple algebra the regular module is a simple object of the +module category, and so is its twist by the odd line, so a free +mixed module is semisimple of finite length. That is what will +carry the splitting from the tensor generator to every subquotient, +and with it to the whole category. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v + +variable {C : Type v} + +/-- **A simple algebra splitting a chosen object**, obtained from a +countably presented splitting algebra by passing to the quotient by +a maximal ideal. The countably presented algebra above is kept, +together with the projection, because the dimension count for the +scalars of the quotient runs through it. -/ +theorem exists_simple_generator_algebra + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + (ψ : ℂ ≃+* End (𝟙_ C)) + (P : SchurPackage.{v}) (P₀ : SchurPackage.{0}) + (L : OddLine (Ind C)) (X₀ : C) (lam : YoungDiagram) + (hkill : letI := linearOfScalarUnit ψ; SchurKilled P X₀ lam) + (hlen : ∀ Z : C, ∃ N : ℕ, LengthLE Z N) : + letI := linearOfScalarUnit ψ + letI := monoidalLinearOfScalarUnitBraided ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + letI := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + ∃ (p q : ℕ) (𝔸 𝔹 : Ind C) (_ : MonObj 𝔸) (_ : IsCommMonObj 𝔸) + (_ : MonObj 𝔹) (_ : IsCommMonObj 𝔹) (π : 𝔸 ⟶ 𝔹), + η[𝔹] ≠ 0 ∧ CountablyPresented 𝔸 ∧ Epi π ∧ IsMonHom π ∧ + (∀ I : Subobject 𝔹, IsIdeal 𝔹 I → I = ⊥ ∨ I = ⊤) ∧ + Nonempty (freeMod 𝔹 ((indOf : C ⥤ Ind C).obj X₀) ≅ + freeMod 𝔹 (L.mix p q)) := by + let := linearOfScalarUnit ψ + let := monoidalLinearOfScalarUnitBraided ψ + let := linearOfScalarUnit (indScalarUnit ψ) + let := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + obtain ⟨p, q, 𝔸, hmon, hcomm, hne, hcp, ⟨e⟩⟩ := + exists_generator_algebra ψ P P₀ L X₀ lam hkill hlen + let := hmon + let := hcomm + obtain ⟨𝔹, hmon', hcomm', π, hne', hepi, hhom, hsimple⟩ := + exists_simple_quotient 𝔸 hne + let := hmon' + let := hcomm' + have := hhom + exact ⟨p, q, 𝔸, 𝔹, hmon, hcomm, hmon', hcomm', π, hne', hcp, hepi, + hhom, hsimple, ⟨freeModIsoBaseChange 𝔸 𝔹 π e⟩⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimplePoint.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimplePoint.lean new file mode 100644 index 0000000000..371c6c237b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimplePoint.lean @@ -0,0 +1,88 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaComplex + +/-! +# The complex point of a simple algebra + +The even part of the Γ-algebra of a simple countably presented +algebra is the complex numbers and its odd part vanishes, so the +Γ-algebra has a complex point on the nose: the inverse of the +structure map, with nothing to check on the odd side. + +This is the last input of the fibre functor: with a point in hand +the base change of `RS/Classical/Deligne/PointFibre.lean` lands in +finite-dimensional super vector spaces. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v + +variable {C : Type v} + +/-- **The structure map of the scalars is bijective** for a simple +countably presented algebra: injective because the scalars form a +field, surjective because every scalar is a complex multiple of the +unit. -/ +theorem bijective_algebraMap_gammaEven + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] [CategoryTheory.Linear ℂ C] + [MonoidalLinear ℂ C] [CategoryTheory.Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] + (hu : HasScalarUnit C) + (hsmul : IndOfLinear C) (hlen : ∀ Z : C, ∃ N : ℕ, LengthLE Z N) + (L : OddLine (Ind C)) {𝔸 𝔹 : Ind C} [MonObj 𝔸] [MonObj 𝔹] + [IsCommMonObj 𝔹] (π : 𝔸 ⟶ 𝔹) [Epi π] + (hcp : CountablyPresented 𝔸) (hne : η[𝔹] ≠ 0) + (hsimple : ∀ I : Subobject 𝔹, IsIdeal 𝔹 I → I = ⊥ ∨ I = ⊤) : + letI : Field ((gammaAlgebra (Ind C) L 𝔹).even) := + gammaEvenField 𝔹 L hsimple hne + Function.Bijective + (algebraMap ℂ ((gammaAlgebra (Ind C) L 𝔹).even)) := by + let : Field ((gammaAlgebra (Ind C) L 𝔹).even) := + gammaEvenField 𝔹 L hsimple hne + refine ⟨(algebraMap ℂ _).injective, fun g => ?_⟩ + obtain ⟨c, hc⟩ := + exists_smul_one_of_simple_of_epi hu hsmul hlen L π hcp hne hsimple g + exact ⟨c, by rw [Algebra.algebraMap_eq_smul_one]; exact hc.symm⟩ + +/-- **A simple countably presented algebra has a complex point.** +The even part is the complex numbers and the odd part vanishes, so +the point is the inverse of the structure map and the vanishing +condition is vacuous. -/ +noncomputable def superPointOfSimple + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] [CategoryTheory.Linear ℂ C] + [MonoidalLinear ℂ C] [CategoryTheory.Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] + (hu : HasScalarUnit C) + (hsmul : IndOfLinear C) (hlen : ∀ Z : C, ∃ N : ℕ, LengthLE Z N) + (L : OddLine (Ind C)) {𝔸 𝔹 : Ind C} [MonObj 𝔸] [MonObj 𝔹] + [IsCommMonObj 𝔹] (π : 𝔸 ⟶ 𝔹) [Epi π] + (hcp : CountablyPresented 𝔸) (hne : η[𝔹] ≠ 0) + (hsimple : ∀ I : Subobject 𝔹, IsIdeal 𝔹 I → I = ⊥ ∨ I = ⊤) : + SuperPoint (gammaAlgebra (Ind C) L 𝔹) where + chi := + letI : Field ((gammaAlgebra (Ind C) L 𝔹).even) := + gammaEvenField 𝔹 L hsimple hne + (AlgEquiv.ofBijective (Algebra.ofId ℂ _) + (bijective_algebraMap_gammaEven hu hsmul hlen L π hcp hne + hsimple)).symm.toAlgHom + vanishing u v := by + have hu0 : u = 0 := hom_oddLine_eq_zero_of_simple 𝔹 L hsimple u + rw [hu0, map_zero] + simp + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleQuotient.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleQuotient.lean new file mode 100644 index 0000000000..a5b072d8ec --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleQuotient.lean @@ -0,0 +1,734 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescentClose +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KernelPow + +/-! +# Simple quotients of commutative algebras in the ind-completion + +Every nonzero commutative algebra object of `Ind C` has a quotient +algebra which is simple as an algebra: its only ideals are `⊥` and +`⊤`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v + +variable {C : Type v} + +/-! ## Well-poweredness of the ind-completion -/ + +/-- **The ind-completion is well powered.** The embedded objects +form a separating family, hence a detecting one, and a category with +a small detecting family is well powered. -/ +noncomputable instance wellPoweredInd + [SmallCategory C] [Abelian C] : WellPowered.{v} (Ind C) := + CategoryTheory.wellPowered_of_isDetecting + (Ind.isSeparating_range_yoneda (C := C)).isDetecting + +/-! ## Factoring through a subobject -/ + +/-- A commuting triangle exhibits a factorisation through a +subobject. -/ +theorem factors_of_comm [SmallCategory C] + {X Y : Ind C} {P : Subobject Y} {f : X ⟶ Y} + (g : X ⟶ (P : Ind C)) (h : g ≫ P.arrow = f) : P.Factors f := + h ▸ Subobject.factors_comp_arrow g + +/-- The factorisation named by `Subobject.Factors`, read back as an +explicit commuting triangle. -/ +theorem exists_factor [SmallCategory C] + {X Y : Ind C} {P : Subobject Y} {f : X ⟶ Y} + (h : P.Factors f) : ∃ g : X ⟶ (P : Ind C), g ≫ P.arrow = f := + ⟨P.factorThru f h, P.factorThru_arrow f h⟩ + +/-- **Factoring through a subobject is being killed by its +cokernel.** A monomorphism of an abelian category is the kernel of +its own cokernel, so a morphism factors through a subobject exactly +when it dies against the cokernel of the subobject's arrow. -/ +theorem factors_iff_comp_cokernel [SmallCategory C] [Abelian C] + {X Y : Ind C} (P : Subobject Y) + (f : X ⟶ Y) : P.Factors f ↔ f ≫ cokernel.π P.arrow = 0 := by + constructor + · intro hf + rw [← P.factorThru_arrow f hf, Category.assoc, + cokernel.condition, comp_zero] + · intro h + obtain ⟨l, hl⟩ := KernelFork.IsLimit.lift' + (Abelian.monoIsKernelOfCokernel _ + (cokernelIsCokernel P.arrow)) f h + exact factors_of_comm l hl + +/-- **Factoring is detected on a colimit cocone**: a morphism out of +a colimit factors through a subobject as soon as each of its +restrictions to the stages does. -/ +theorem factors_of_isColimit [SmallCategory C] [Abelian C] + {J : Type v} [SmallCategory J] + {F : J ⥤ Ind C} (c : Cocone F) (hc : IsColimit c) {W : Ind C} + (P : Subobject W) (f : c.pt ⟶ W) + (h : ∀ j, P.Factors (c.ι.app j ≫ f)) : P.Factors f := by + rw [factors_iff_comp_cokernel] + refine hc.hom_ext (fun j => ?_) + refine Eq.trans (Category.assoc _ _ _).symm ?_ + exact ((factors_iff_comp_cokernel P _).1 (h j)).trans + (comp_zero).symm + +/-! ## Ideals -/ + +/-- **An ideal of an algebra object**: a subobject that absorbs +multiplication by the algebra. -/ +def IsIdeal [SmallCategory C] [MonoidalCategory C] + (𝔸 : Ind C) [MonObj 𝔸] (I : Subobject 𝔸) : Prop := + I.Factors ((𝔸 ◁ I.arrow) ≫ μ[𝔸]) + +/-- **The zero subobject is an ideal.** -/ +theorem isIdeal_bot [SmallCategory C] [MonoidalCategory C] [Abelian C] + [MonoidalPreadditive C] + (𝔸 : Ind C) [MonObj 𝔸] : IsIdeal 𝔸 ⊥ := by + have hz : IsZero (Subobject.underlying.obj (⊥ : Subobject 𝔸)) := + IsZero.of_iso (isZero_zero (Ind C)) Subobject.botCoeIsoZero + have h : (⊥ : Subobject 𝔸).arrow = 0 := hz.eq_zero_of_src _ + change (⊥ : Subobject 𝔸).Factors _ + rw [Subobject.bot_factors_iff_zero, h, + MonoidalPreadditive.whiskerLeft_zero, zero_comp] + +/-! ## Proper ideals -/ + +/-- **A proper subobject**: one through which the unit of the +algebra does not factor. -/ +def IsProper [SmallCategory C] [MonoidalCategory C] + (𝔸 : Ind C) [MonObj 𝔸] (I : Subobject 𝔸) : Prop := + ¬ I.Factors η[𝔸] + +/-- **For an ideal, properness is exactly being different from the +whole algebra.** If the unit factors through an ideal then the +arrow of the ideal is a split epimorphism, hence an isomorphism. -/ +theorem isProper_iff_ne_top [SmallCategory C] [MonoidalCategory C] + (𝔸 : Ind C) [MonObj 𝔸] + {I : Subobject 𝔸} (hI : IsIdeal 𝔸 I) : + IsProper 𝔸 I ↔ I ≠ ⊤ := by + constructor + · intro hp htop + exact hp (htop ▸ Subobject.top_factors η[𝔸]) + · intro hne hfac + obtain ⟨a, ha⟩ := exists_factor hfac + obtain ⟨b, hb⟩ := exists_factor hI + have key : (𝔸 ◁ a) ≫ (𝔸 ◁ I.arrow) ≫ μ[𝔸] = (ρ_ 𝔸).hom := by + rw [← Category.assoc, ← MonoidalCategory.whiskerLeft_comp, ha, + MonObj.mul_one] + have hs : ((ρ_ 𝔸).inv ≫ (𝔸 ◁ a) ≫ b) ≫ I.arrow = 𝟙 𝔸 := by + rw [Category.assoc, Category.assoc, hb, key, Iso.inv_hom_id] + have : IsSplitEpi I.arrow := IsSplitEpi.mk' ⟨_, hs⟩ + have : IsIso I.arrow := isIso_of_mono_of_isSplitEpi _ + exact hne (Subobject.eq_top_of_isIso_arrow I) + +/-- **The zero ideal is proper as soon as the unit is nonzero.** -/ +theorem isProper_bot [SmallCategory C] [MonoidalCategory C] [Abelian C] + (𝔸 : Ind C) [MonObj 𝔸] (hne : η[𝔸] ≠ 0) : + IsProper 𝔸 ⊥ := fun h => + hne ((Subobject.bot_factors_iff_zero η[𝔸]).1 h) + +/-! ## Suprema of ideals -/ + +/-- Arbitrary suprema of subobjects of an ind-object, from +well-poweredness, images and coproducts. -/ +noncomputable instance completeSemilatticeSupSubobject + [SmallCategory C] [Abelian C] + (A : Ind C) : + CompleteSemilatticeSup (Subobject A) := + Subobject.completeSemilatticeSup.{v} + +/-! ## Compactness of the unit -/ + +/-- **Compactness transports along an isomorphism.** -/ +theorem IndCompactObj.of_iso [SmallCategory C] + {X Y : Ind C} (e : X ≅ Y) + (h : IndCompactObj X) : IndCompactObj Y := fun D f => by + obtain ⟨i, g, hg⟩ := h D (e.hom ≫ f) + refine ⟨i, e.inv ≫ g, ?_⟩ + rw [Category.assoc, hg, ← Category.assoc, e.inv_hom_id, + Category.id_comp] + +/-- **The unit object of the ind-completion is compact**: it is the +embedded unit of the small category. -/ +theorem indCompactObj_tensorUnit [SmallCategory C] [MonoidalCategory C] : + IndCompactObj (𝟙_ (Ind C)) := + IndCompactObj.of_iso (indOfUnitIso (C := C)).symm + (indCompactObj_indOf (𝟙_ C)) + +/-! ## The union of a directed family of subobjects -/ + +/-- A family of subobjects of an ind-object is `v`-small. -/ +instance small_subobject_subset [SmallCategory C] [Abelian C] + {A : Ind C} (s : Set (Subobject A)) : + Small.{v} ↥s := + small_of_injective (f := (Subtype.val : ↥s → Subobject A)) + Subtype.val_injective + +/-- A `v`-small copy of a family of subobjects of an ind-object, +serving as the index of the diagram of its members. -/ +def SubIndex [SmallCategory C] [Abelian C] + {A : Ind C} (s : Set (Subobject A)) : Type v := + Shrink.{v} ↥s + +/-- The subobject named by an index. -/ +noncomputable def SubIndex.val [SmallCategory C] [Abelian C] + {A : Ind C} {s : Set (Subobject A)} + (j : SubIndex s) : Subobject A := + ((equivShrink ↥s).symm j).1 + +/-- The subobject named by an index belongs to the family. -/ +theorem SubIndex.val_mem [SmallCategory C] [Abelian C] + {A : Ind C} {s : Set (Subobject A)} + (j : SubIndex s) : SubIndex.val j ∈ s := + ((equivShrink ↥s).symm j).2 + +/-- Every member of the family is named by an index. -/ +theorem SubIndex.val_index [SmallCategory C] [Abelian C] + {A : Ind C} {s : Set (Subobject A)} + {I : Subobject A} (hI : I ∈ s) : + SubIndex.val (equivShrink ↥s ⟨I, hI⟩) = I := + congrArg Subtype.val (Equiv.symm_apply_apply _ _) + +/-- The index of a family of subobjects, ordered by inclusion of the +subobjects it names. -/ +noncomputable instance subIndexPreorder [SmallCategory C] [Abelian C] + {A : Ind C} + (s : Set (Subobject A)) : Preorder (SubIndex s) := + Preorder.lift SubIndex.val + +/-- A morphism of the index category is an inclusion of the +subobjects it names. -/ +theorem SubIndex.le_of_hom [SmallCategory C] [Abelian C] + {A : Ind C} {s : Set (Subobject A)} + {j k : SubIndex s} (h : j ⟶ k) : + SubIndex.val j ≤ SubIndex.val k := (leOfHom h : j ≤ k) + +/-- **The index of a nonempty directed family is filtered.** -/ +theorem isFiltered_subIndex [SmallCategory C] [Abelian C] + {A : Ind C} {s : Set (Subobject A)} + (hne : s.Nonempty) (hdir : DirectedOn (· ≤ ·) s) : + IsFiltered (SubIndex s) := by + obtain ⟨x, hx⟩ := hne + have : Nonempty (SubIndex s) := ⟨equivShrink ↥s ⟨x, hx⟩⟩ + have : IsDirectedOrder (SubIndex s) := by + refine ⟨fun j k => ?_⟩ + obtain ⟨z, hz, h₁, h₂⟩ := hdir _ (SubIndex.val_mem j) _ + (SubIndex.val_mem k) + refine ⟨equivShrink ↥s ⟨z, hz⟩, ?_, ?_⟩ + · change SubIndex.val j ≤ SubIndex.val _ + rw [SubIndex.val_index hz]; exact h₁ + · change SubIndex.val k ≤ SubIndex.val _ + rw [SubIndex.val_index hz]; exact h₂ + exact isFiltered_of_directed_le_nonempty _ + +/-- The diagram of the members of a family of subobjects. -/ +noncomputable def subDiagram [SmallCategory C] [Abelian C] + {A : Ind C} (s : Set (Subobject A)) : + SubIndex s ⥤ Ind C where + obj j := (SubIndex.val j : Ind C) + map {j k} h := Subobject.ofLE _ _ (SubIndex.le_of_hom h) + map_id j := by + refine (cancel_mono (SubIndex.val j).arrow).1 ?_ + rw [Subobject.ofLE_arrow, Category.id_comp] + map_comp {j k l} f g := by + refine (cancel_mono (SubIndex.val l).arrow).1 ?_ + rw [Category.assoc, Subobject.ofLE_arrow, Subobject.ofLE_arrow, + Subobject.ofLE_arrow] + +/-- The tautological cocone of `RS.subDiagram` on the ambient +ind-object, given by the arrows of the members. -/ +noncomputable def subCocone [SmallCategory C] [Abelian C] + {A : Ind C} (s : Set (Subobject A)) : + Cocone (subDiagram s) := + Cocone.mk A + { app := fun j => (SubIndex.val j).arrow + naturality := fun _ _ h => + (Subobject.ofLE_arrow (SubIndex.le_of_hom h)).trans + (Category.comp_id _).symm } + +/-- The comparison morphism from the colimit of a family of +subobjects to the ambient ind-object. -/ +noncomputable def subUnionHom [SmallCategory C] [Abelian C] + {A : Ind C} (s : Set (Subobject A)) : + colimit (subDiagram s) ⟶ A := + colimit.desc _ (subCocone s) + +/-- The colimit injections composed with the comparison morphism are +the arrows of the members. -/ +theorem ι_subUnionHom [SmallCategory C] [Abelian C] + {A : Ind C} (s : Set (Subobject A)) + (j : SubIndex s) : + colimit.ι (subDiagram s) j ≫ subUnionHom s = + (SubIndex.val j).arrow := + colimit.ι_desc _ _ + +/-- **The colimit of a constant diagram over a filtered index is the +constant value.** -/ +noncomputable def constColimitIso [SmallCategory C] + {J : Type v} [SmallCategory J] + [IsFiltered J] (A : Ind C) : + colimit ((Functor.const J).obj A) ≅ A := + haveI : IsConnected J := IsFiltered.isConnected J + (colimit.isColimit ((Functor.const J).obj A)).coconePointUniqueUpToIso + (isColimitConstCocone J A) + +/-- Each injection of the constant colimit is undone by +`RS.constColimitIso`. -/ +theorem ι_constColimitIso [SmallCategory C] + {J : Type v} [SmallCategory J] + [IsFiltered J] (A : Ind C) (j : J) : + colimit.ι ((Functor.const J).obj A) j ≫ (constColimitIso A).hom + = 𝟙 A := by + have : IsConnected J := IsFiltered.isConnected J + exact Eq.trans (IsColimit.comp_coconePointUniqueUpToIso_hom _ _ _) + rfl + +/-- **The union of a filtered family of subobjects is a +subobject**: filtered colimits are exact in the ind-completion, so +the comparison morphism of `RS.subUnionHom` is a monomorphism. -/ +instance mono_subUnionHom [SmallCategory C] [Abelian C] + {A : Ind C} (s : Set (Subobject A)) + [IsFiltered (SubIndex s)] : Mono (subUnionHom s) := by + have : ∀ j, Mono ((subCocone s).ι.app j) := fun j => + inferInstanceAs (Mono (SubIndex.val j).arrow) + have : Mono ((subCocone s).ι) := NatTrans.mono_of_mono_app _ + have : Mono (colimMap ((subCocone s).ι)) := by + rw [colimMap_eq] + exact (colim (J := SubIndex s) (C := Ind C)).map_mono _ + have hd : subUnionHom s = + colimMap ((subCocone s).ι) ≫ (constColimitIso A).hom := by + refine colimit.hom_ext (fun j => ?_) + have h₁ : colimit.ι (subDiagram s) j ≫ subUnionHom s = + (subCocone s).ι.app j := colimit.ι_desc _ _ + have h₂ : colimit.ι (subDiagram s) j ≫ + (colimMap ((subCocone s).ι) ≫ (constColimitIso A).hom) = + (subCocone s).ι.app j := by + erw [← Category.assoc, ι_colimMap, Category.assoc, + show colimit.ι ((Functor.const (SubIndex s)).obj + (subCocone s).pt) j ≫ (constColimitIso A).hom = 𝟙 A from + ι_constColimitIso A j] + exact Category.comp_id _ + exact h₁.trans h₂.symm + rw [hd] + refine ⟨fun {Z} f g h => ?_⟩ + apply (cancel_mono (colimMap ((subCocone s).ι))).mp + apply (Iso.cancel_iso_hom_right _ _ (constColimitIso (J := SubIndex s) A)).mp + erw [Category.assoc, Category.assoc] + exact h + +/-! ## The chain condition -/ + +/-- **A nonempty directed family of proper ideals is bounded above by +a proper ideal.** The bound is the union of the family: it is an +ideal because tensoring preserves the colimit of the members, and it +is proper because the unit is compact, so a factorisation of the unit +through the union already factors through a member. -/ +theorem exists_ub_of_directed + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + (𝔸 : Ind C) [MonObj 𝔸] + {c : Set (Subobject 𝔸)} (hne : c.Nonempty) + (hdir : DirectedOn (· ≤ ·) c) (hid : ∀ I ∈ c, IsIdeal 𝔸 I) + (hpr : ∀ I ∈ c, IsProper 𝔸 I) : + ∃ ub : Subobject 𝔸, IsIdeal 𝔸 ub ∧ IsProper 𝔸 ub ∧ + ∀ I ∈ c, I ≤ ub := by + have := isFiltered_subIndex hne hdir + have harrow : (Subobject.mk (subUnionHom c)).arrow = + (Subobject.underlyingIso (subUnionHom c)).hom ≫ subUnionHom c := + (Iso.inv_comp_eq _).1 (Subobject.underlyingIso_arrow _) + have hlej : ∀ j : SubIndex c, + SubIndex.val j ≤ Subobject.mk (subUnionHom c) := fun j => + le_trans (le_of_eq (Subobject.mk_arrow (SubIndex.val j)).symm) + (Subobject.mk_le_mk_of_comm (colimit.ι (subDiagram c) j) + (ι_subUnionHom c j)) + refine ⟨Subobject.mk (subUnionHom c), ?_, ?_, ?_⟩ + · have hstep : (Subobject.mk (subUnionHom c)).Factors + ((𝔸 ◁ subUnionHom c) ≫ μ[𝔸]) := by + refine factors_of_isColimit + ((tensorLeft 𝔸).mapCocone (colimit.cocone (subDiagram c))) + (isColimitOfPreserves _ (colimit.isColimit _)) _ _ (fun j => ?_) + have hj : (𝔸 ◁ colimit.ι (subDiagram c) j) ≫ + ((𝔸 ◁ subUnionHom c) ≫ μ[𝔸]) = + (𝔸 ◁ (SubIndex.val j).arrow) ≫ μ[𝔸] := by + rw [← Category.assoc, ← MonoidalCategory.whiskerLeft_comp, + ι_subUnionHom] + rfl + refine Eq.mpr (congrArg + (fun t => (Subobject.mk (subUnionHom c)).Factors t) hj) ?_ + exact Subobject.factors_of_le _ (hlej j) + (hid _ (SubIndex.val_mem j)) + have : Epi + (𝔸 ◁ (Subobject.underlyingIso (subUnionHom c)).inv) := + inferInstanceAs (Epi ((tensorLeft 𝔸).map _)) + have hgoal : (𝔸 ◁ (Subobject.underlyingIso (subUnionHom c)).inv) + ≫ (𝔸 ◁ (Subobject.mk (subUnionHom c)).arrow) ≫ μ[𝔸] = + (𝔸 ◁ subUnionHom c) ≫ μ[𝔸] := + (Category.assoc _ _ _).symm.trans + (congrArg (fun t => t ≫ μ[𝔸]) + ((MonoidalCategory.whiskerLeft_comp 𝔸 _ _).symm.trans + (congrArg (fun t => 𝔸 ◁ t) + (Subobject.underlyingIso_arrow (subUnionHom c))))) + refine factors_of_epi_comp _ + (𝔸 ◁ (Subobject.underlyingIso (subUnionHom c)).inv) _ ?_ + exact Eq.mpr (congrArg + (fun t => (Subobject.mk (subUnionHom c)).Factors t) hgoal) hstep + · intro hfac + obtain ⟨g, hg⟩ := exists_factor hfac + obtain ⟨j, g₀, hg₀⟩ := indCompactObj_tensorUnit (C := C) + (subDiagram c) + (g ≫ (Subobject.underlyingIso (subUnionHom c)).hom) + refine hpr _ (SubIndex.val_mem j) (factors_of_comm g₀ ?_) + refine Eq.trans (congrArg (fun t => g₀ ≫ t) + (ι_subUnionHom c j)).symm ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (congrArg (fun t => t ≫ subUnionHom c) hg₀) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact Eq.trans (congrArg (fun t => g ≫ t) harrow.symm) hg + · intro I hI + have h := hlej (equivShrink ↥c ⟨I, hI⟩) + rwa [SubIndex.val_index hI] at h + +/-! ## Maximal proper ideals -/ + +/-- **Every algebra with a nonzero unit has a maximal proper +ideal.** -/ +theorem exists_maximal_ideal + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + (𝔸 : Ind C) [MonObj 𝔸] + (hne : η[𝔸] ≠ 0) : + ∃ 𝔪 : Subobject 𝔸, IsIdeal 𝔸 𝔪 ∧ IsProper 𝔸 𝔪 ∧ + ∀ J : Subobject 𝔸, IsIdeal 𝔸 J → IsProper 𝔸 J → 𝔪 ≤ J → + J ≤ 𝔪 := by + have hbdd : ∀ cc ⊆ {I : Subobject 𝔸 | IsIdeal 𝔸 I ∧ IsProper 𝔸 I}, + IsChain (· ≤ ·) cc → ∀ y ∈ cc, + ∃ ub ∈ {I : Subobject 𝔸 | IsIdeal 𝔸 I ∧ IsProper 𝔸 I}, + ∀ z ∈ cc, z ≤ ub := by + intro cc hcc hchain y hy + obtain ⟨ub, h₁, h₂, h₃⟩ := exists_ub_of_directed 𝔸 ⟨y, hy⟩ + hchain.directedOn (fun I hI => (hcc hI).1) + (fun I hI => (hcc hI).2) + exact ⟨ub, ⟨h₁, h₂⟩, h₃⟩ + obtain ⟨m, -, hm⟩ := zorn_le_nonempty₀ _ hbdd ⊥ + ⟨isIdeal_bot 𝔸, isProper_bot 𝔸 hne⟩ + exact ⟨m, hm.1.1, hm.1.2, + fun J hJ hJp hle => hm.2 ⟨hJ, hJp⟩ hle⟩ + +/-! ## Transport of an algebra structure along an epimorphism -/ + +/-- **An epimorphism transports an algebra structure.** If a unit +and a multiplication on the target are compatible with those of the +source along an epimorphism, they satisfy the algebra laws. -/ +@[reducible] noncomputable def monObjOfEpi + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + {A B : Ind C} [MonObj A] + (p : A ⟶ B) + [Epi p] (o : 𝟙_ (Ind C) ⟶ B) (m : B ⊗ B ⟶ B) + (ho : η[A] ≫ p = o) (hm : (p ⊗ₘ p) ≫ m = μ[A] ≫ p) : + MonObj B where + one := o + mul := m + one_mul := by + have : Epi (𝟙_ (Ind C) ◁ p) := + inferInstanceAs (Epi ((tensorLeft _).map p)) + have h₁ : (𝟙_ (Ind C) ◁ p) ≫ (o ▷ B) = (η[A] ▷ A) ≫ (p ⊗ₘ p) := by + refine Eq.trans (tensorHom_def' o p).symm ?_ + rw [← tensorHom_id, tensorHom_comp_tensorHom, ho, + Category.id_comp] + refine (cancel_epi (𝟙_ (Ind C) ◁ p)).1 ?_ + rw [← Category.assoc, h₁, Category.assoc, hm, ← Category.assoc, + MonObj.one_mul, leftUnitor_naturality] + mul_one := by + have : Epi (p ▷ 𝟙_ (Ind C)) := + inferInstanceAs (Epi ((tensorRight _).map p)) + have h₁ : (p ▷ 𝟙_ (Ind C)) ≫ (B ◁ o) = (A ◁ η[A]) ≫ (p ⊗ₘ p) := by + refine Eq.trans (tensorHom_def p o).symm ?_ + rw [← id_tensorHom, tensorHom_comp_tensorHom, ho, + Category.id_comp] + refine (cancel_epi (p ▷ 𝟙_ (Ind C))).1 ?_ + rw [← Category.assoc, h₁, Category.assoc, hm, ← Category.assoc, + MonObj.mul_one, rightUnitor_naturality] + mul_assoc := by + have h₁ : ((p ⊗ₘ p) ⊗ₘ p) ≫ (m ▷ B) = (μ[A] ▷ A) ≫ (p ⊗ₘ p) := by + rw [← tensorHom_id, tensorHom_comp_tensorHom, hm, + Category.comp_id, ← tensorHom_id, tensorHom_comp_tensorHom, + Category.id_comp] + have h₂ : (p ⊗ₘ (p ⊗ₘ p)) ≫ (B ◁ m) = + (A ◁ μ[A]) ≫ (p ⊗ₘ p) := by + rw [← id_tensorHom, tensorHom_comp_tensorHom, hm, + Category.comp_id, ← id_tensorHom, tensorHom_comp_tensorHom, + Category.id_comp] + have hL : ((p ⊗ₘ p) ⊗ₘ p) ≫ (m ▷ B) ≫ m = + ((μ[A] ▷ A) ≫ μ[A]) ≫ p := by + rw [← Category.assoc, h₁, Category.assoc, hm, ← Category.assoc] + have hR : ((p ⊗ₘ p) ⊗ₘ p) ≫ (α_ B B B).hom ≫ (B ◁ m) ≫ m = + ((α_ A A A).hom ≫ (A ◁ μ[A]) ≫ μ[A]) ≫ p := by + rw [← Category.assoc, associator_naturality, Category.assoc, + ← Category.assoc (p ⊗ₘ (p ⊗ₘ p)), h₂, Category.assoc, hm] + simp only [Category.assoc] + refine (cancel_epi ((p ⊗ₘ p) ⊗ₘ p)).1 ?_ + rw [hL, hR, MonObj.mul_assoc] + +/-- **An epimorphism transports commutativity.** -/ +theorem isCommMonObj_of_epi + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + {A B : Ind C} [MonObj A] [IsCommMonObj A] + [MonObj B] (p : A ⟶ B) [Epi p] + (hm : (p ⊗ₘ p) ≫ μ[B] = μ[A] ≫ p) : IsCommMonObj B where + mul_comm := by + refine (cancel_epi (p ⊗ₘ p)).1 ?_ + rw [← Category.assoc, BraidedCategory.braiding_naturality, + Category.assoc, hm, ← Category.assoc, + IsCommMonObj.mul_comm A] + +/-! ## The quotient of an algebra by an ideal -/ + +/-- The multiplication of the algebra against an ideal dies in the +quotient by that ideal. -/ +theorem whiskerLeft_arrow_mul_π + [SmallCategory C] [MonoidalCategory C] [Abelian C] + (𝔸 : Ind C) [MonObj 𝔸] + (𝔪 : Subobject 𝔸) (h𝔪 : IsIdeal 𝔸 𝔪) : + (𝔸 ◁ 𝔪.arrow) ≫ μ[𝔸] ≫ cokernel.π 𝔪.arrow = 0 := by + obtain ⟨b, hb⟩ := exists_factor h𝔪 + rw [← Category.assoc, ← hb, Category.assoc, cokernel.condition, + comp_zero] + +/-- The same on the other side, by commutativity. -/ +theorem whiskerRight_arrow_mul_π + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + (𝔸 : Ind C) [MonObj 𝔸] + [IsCommMonObj 𝔸] (𝔪 : Subobject 𝔸) (h𝔪 : IsIdeal 𝔸 𝔪) : + (𝔪.arrow ▷ 𝔸) ≫ μ[𝔸] ≫ cokernel.π 𝔪.arrow = 0 := by + have h : (𝔪.arrow ▷ 𝔸) ≫ μ[𝔸] = + (β_ (𝔪 : Ind C) 𝔸).hom ≫ (𝔸 ◁ 𝔪.arrow) ≫ μ[𝔸] := by + rw [← Category.assoc, ← BraidedCategory.braiding_naturality_left, + Category.assoc, IsCommMonObj.mul_comm 𝔸] + rw [← Category.assoc, h] + simp only [Category.assoc] + rw [whiskerLeft_arrow_mul_π 𝔸 𝔪 h𝔪, comp_zero] + +/-- The multiplication of the algebra, descended in its second +variable to the quotient by an ideal. -/ +noncomputable def quotMulAux + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + (𝔸 : Ind C) [MonObj 𝔸] + (𝔪 : Subobject 𝔸) (h𝔪 : IsIdeal 𝔸 𝔪) : + 𝔸 ⊗ cokernel 𝔪.arrow ⟶ cokernel 𝔪.arrow := + (CokernelCofork.IsColimit.desc' + (isColimitOfHasCokernelOfPreservesColimit (tensorLeft 𝔸) 𝔪.arrow) + (μ[𝔸] ≫ cokernel.π 𝔪.arrow) + (whiskerLeft_arrow_mul_π 𝔸 𝔪 h𝔪)).1 + +/-- The defining property of `RS.quotMulAux`. -/ +theorem whiskerLeft_π_quotMulAux + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] + (𝔸 : Ind C) [MonObj 𝔸] + (𝔪 : Subobject 𝔸) (h𝔪 : IsIdeal 𝔸 𝔪) : + (𝔸 ◁ cokernel.π 𝔪.arrow) ≫ quotMulAux 𝔸 𝔪 h𝔪 = + μ[𝔸] ≫ cokernel.π 𝔪.arrow := + (CokernelCofork.IsColimit.desc' + (isColimitOfHasCokernelOfPreservesColimit (tensorLeft 𝔸) 𝔪.arrow) + (μ[𝔸] ≫ cokernel.π 𝔪.arrow) + (whiskerLeft_arrow_mul_π 𝔸 𝔪 h𝔪)).2 + +/-- The half-descended multiplication kills the ideal in its first +variable as well. -/ +theorem whiskerRight_quotMulAux + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + (𝔸 : Ind C) [MonObj 𝔸] + [IsCommMonObj 𝔸] (𝔪 : Subobject 𝔸) (h𝔪 : IsIdeal 𝔸 𝔪) : + (𝔪.arrow ▷ cokernel 𝔪.arrow) ≫ quotMulAux 𝔸 𝔪 h𝔪 = 0 := by + have : Epi ((𝔪 : Ind C) ◁ cokernel.π 𝔪.arrow) := + inferInstanceAs (Epi ((tensorLeft _).map _)) + refine zero_of_epi_comp ((𝔪 : Ind C) ◁ cokernel.π 𝔪.arrow) ?_ + rw [← Category.assoc, whisker_exchange, Category.assoc, + whiskerLeft_π_quotMulAux, whiskerRight_arrow_mul_π 𝔸 𝔪 h𝔪] + +/-- **The multiplication of the quotient algebra.** -/ +noncomputable def quotMul + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + (𝔸 : Ind C) [MonObj 𝔸] [IsCommMonObj 𝔸] + (𝔪 : Subobject 𝔸) (h𝔪 : IsIdeal 𝔸 𝔪) : + cokernel 𝔪.arrow ⊗ cokernel 𝔪.arrow ⟶ cokernel 𝔪.arrow := + (CokernelCofork.IsColimit.desc' + (isColimitOfHasCokernelOfPreservesColimit + (tensorRight (cokernel 𝔪.arrow)) 𝔪.arrow) + (quotMulAux 𝔸 𝔪 h𝔪) (whiskerRight_quotMulAux 𝔸 𝔪 h𝔪)).1 + +/-- The defining property of `RS.quotMul`. -/ +theorem whiskerRight_π_quotMul + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + (𝔸 : Ind C) [MonObj 𝔸] + [IsCommMonObj 𝔸] (𝔪 : Subobject 𝔸) (h𝔪 : IsIdeal 𝔸 𝔪) : + (cokernel.π 𝔪.arrow ▷ cokernel 𝔪.arrow) ≫ quotMul 𝔸 𝔪 h𝔪 = + quotMulAux 𝔸 𝔪 h𝔪 := + (CokernelCofork.IsColimit.desc' + (isColimitOfHasCokernelOfPreservesColimit + (tensorRight (cokernel 𝔪.arrow)) 𝔪.arrow) + (quotMulAux 𝔸 𝔪 h𝔪) (whiskerRight_quotMulAux 𝔸 𝔪 h𝔪)).2 + +/-- **The projection is multiplicative.** -/ +theorem tensorHom_π_quotMul + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + (𝔸 : Ind C) [MonObj 𝔸] [IsCommMonObj 𝔸] + (𝔪 : Subobject 𝔸) (h𝔪 : IsIdeal 𝔸 𝔪) : + (cokernel.π 𝔪.arrow ⊗ₘ cokernel.π 𝔪.arrow) ≫ quotMul 𝔸 𝔪 h𝔪 = + μ[𝔸] ≫ cokernel.π 𝔪.arrow := by + rw [tensorHom_def', Category.assoc, whiskerRight_π_quotMul, + whiskerLeft_π_quotMulAux] + +/-- **The quotient of an algebra by an ideal is an algebra.** -/ +@[reducible] noncomputable def quotMonObj + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + (𝔸 : Ind C) [MonObj 𝔸] + [IsCommMonObj 𝔸] (𝔪 : Subobject 𝔸) (h𝔪 : IsIdeal 𝔸 𝔪) : + MonObj (cokernel 𝔪.arrow) := + monObjOfEpi (cokernel.π 𝔪.arrow) (η[𝔸] ≫ cokernel.π 𝔪.arrow) + (quotMul 𝔸 𝔪 h𝔪) rfl (tensorHom_π_quotMul 𝔸 𝔪 h𝔪) + +/-! ## Pulling ideals back along the projection -/ + +/-- **Pulling a subobject back**: a morphism factors through the +pullback of a subobject exactly when its composite factors through +the subobject. -/ +theorem factors_pullback_iff [SmallCategory C] [Abelian C] + {A B W : Ind C} (I : Subobject B) + (p : A ⟶ B) (h : W ⟶ A) : + (Subobject.mk (pullback.snd I.arrow p)).Factors h ↔ + I.Factors (h ≫ p) := by + have harrow : (Subobject.underlyingIso (pullback.snd I.arrow p)).inv + ≫ (Subobject.mk (pullback.snd I.arrow p)).arrow = + pullback.snd I.arrow p := Subobject.underlyingIso_arrow _ + have harrow' : (Subobject.mk (pullback.snd I.arrow p)).arrow = + (Subobject.underlyingIso (pullback.snd I.arrow p)).hom ≫ + pullback.snd I.arrow p := (Iso.inv_comp_eq _).1 harrow + constructor + · intro hf + obtain ⟨l, hl⟩ := exists_factor hf + refine factors_of_comm ((l ≫ + (Subobject.underlyingIso (pullback.snd I.arrow p)).hom) ≫ + pullback.fst I.arrow p) ?_ + rw [Category.assoc, pullback.condition, ← Category.assoc, + Category.assoc l, ← harrow', hl] + · intro hf + obtain ⟨k, hk⟩ := exists_factor hf + refine factors_of_comm (pullback.lift k h hk ≫ + (Subobject.underlyingIso (pullback.snd I.arrow p)).inv) ?_ + rw [Category.assoc, harrow, pullback.lift_snd] + +/-! ## The simple quotient -/ + +/-- **Every commutative algebra object of the ind-completion with a +nonzero unit has a simple quotient**: a quotient algebra whose only +ideals are the zero subobject and the whole object. The quotient is +by a maximal proper ideal, and ideals of the quotient correspond to +ideals of the algebra containing that maximal ideal. -/ +theorem exists_simple_quotient + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + (𝔸 : Ind C) [MonObj 𝔸] + [IsCommMonObj 𝔸] (hne : η[𝔸] ≠ 0) : + ∃ (𝔹 : Ind C) (_ : MonObj 𝔹) (_ : IsCommMonObj 𝔹) (π : 𝔸 ⟶ 𝔹), + η[𝔹] ≠ 0 ∧ Epi π ∧ IsMonHom π ∧ + (∀ I : Subobject 𝔹, IsIdeal 𝔹 I → I = ⊥ ∨ I = ⊤) := by + obtain ⟨𝔪, hid, hpr, hmax⟩ := exists_maximal_ideal 𝔸 hne + let : MonObj (cokernel 𝔪.arrow) := quotMonObj 𝔸 𝔪 hid + have hmul : (cokernel.π 𝔪.arrow ⊗ₘ cokernel.π 𝔪.arrow) ≫ + μ[cokernel 𝔪.arrow] = μ[𝔸] ≫ cokernel.π 𝔪.arrow := + tensorHom_π_quotMul 𝔸 𝔪 hid + let : IsCommMonObj (cokernel 𝔪.arrow) := + isCommMonObj_of_epi (cokernel.π 𝔪.arrow) hmul + have : IsMonHom (cokernel.π 𝔪.arrow) := ⟨rfl, hmul.symm⟩ + refine ⟨cokernel 𝔪.arrow, inferInstance, inferInstance, + cokernel.π 𝔪.arrow, ?_, inferInstance, inferInstance, ?_⟩ + · intro h0 + exact hpr ((factors_iff_comp_cokernel 𝔪 η[𝔸]).2 h0) + · intro I hI + by_cases hIp : IsProper (cokernel 𝔪.arrow) I + · left + obtain ⟨t, ht⟩ := exists_factor + ((factors_pullback_iff I (cokernel.π 𝔪.arrow) + (Subobject.mk + (pullback.snd I.arrow (cokernel.π 𝔪.arrow))).arrow).1 + (Subobject.factors_self _)) + have hPid : IsIdeal 𝔸 + (Subobject.mk (pullback.snd I.arrow + (cokernel.π 𝔪.arrow))) := by + refine (factors_pullback_iff I (cokernel.π 𝔪.arrow) _).2 ?_ + have h1 : (𝔸 ◁ (Subobject.mk (pullback.snd I.arrow + (cokernel.π 𝔪.arrow))).arrow) ≫ + (𝔸 ◁ cokernel.π 𝔪.arrow) = + (𝔸 ◁ t) ≫ (𝔸 ◁ I.arrow) := by + rw [← MonoidalCategory.whiskerLeft_comp, + ← MonoidalCategory.whiskerLeft_comp, ht] + have hcomp : ((𝔸 ◁ (Subobject.mk (pullback.snd I.arrow + (cokernel.π 𝔪.arrow))).arrow) ≫ μ[𝔸]) ≫ + cokernel.π 𝔪.arrow = + (𝔸 ◁ t) ≫ (cokernel.π 𝔪.arrow ▷ (I : Ind C)) ≫ + (cokernel 𝔪.arrow ◁ I.arrow) ≫ + μ[cokernel 𝔪.arrow] := by + rw [Category.assoc, ← hmul, tensorHom_def'] + simp only [Category.assoc] + rw [← Category.assoc (𝔸 ◁ (Subobject.mk (pullback.snd + I.arrow (cokernel.π 𝔪.arrow))).arrow), h1] + simp only [Category.assoc] + rw [← Category.assoc (𝔸 ◁ I.arrow), whisker_exchange] + simp only [Category.assoc] + rw [hcomp] + exact Subobject.factors_of_factors_right _ + (Subobject.factors_of_factors_right _ hI) + have hPpr : IsProper 𝔸 + (Subobject.mk (pullback.snd I.arrow + (cokernel.π 𝔪.arrow))) := fun hf => + hIp ((factors_pullback_iff I (cokernel.π 𝔪.arrow) η[𝔸]).1 hf) + have hmP : 𝔪 ≤ Subobject.mk (pullback.snd I.arrow + (cokernel.π 𝔪.arrow)) := + Subobject.le_of_factors + ((factors_pullback_iff I (cokernel.π 𝔪.arrow) 𝔪.arrow).2 + (by rw [cokernel.condition]; exact Subobject.factors_zero)) + have hPm := hmax _ hPid hPpr hmP + have hsnd : pullback.snd I.arrow (cokernel.π 𝔪.arrow) = + (Subobject.underlyingIso (pullback.snd I.arrow + (cokernel.π 𝔪.arrow))).inv ≫ + Subobject.ofLE _ _ hPm ≫ 𝔪.arrow := by + rw [Subobject.ofLE_arrow, Subobject.underlyingIso_arrow] + have hzero : pullback.snd I.arrow (cokernel.π 𝔪.arrow) ≫ + cokernel.π 𝔪.arrow = 0 := by + rw [hsnd, Category.assoc, Category.assoc, + cokernel.condition, comp_zero, comp_zero] + have : Epi (pullback.fst I.arrow (cokernel.π 𝔪.arrow)) := + Abelian.epi_pullback_of_epi_g _ _ + have hIarrow : I.arrow = 0 := by + refine zero_of_epi_comp + (pullback.fst I.arrow (cokernel.π 𝔪.arrow)) ?_ + rw [pullback.condition, hzero] + exact (Subobject.mk_arrow I).symm.trans + (Subobject.mk_eq_bot_iff_zero.2 hIarrow) + · right + exact not_not.1 + (fun hne' => hIp ((isProper_iff_ne_top _ hI).2 hne')) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleScalars.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleScalars.lean new file mode 100644 index 0000000000..0833213cd5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleScalars.lean @@ -0,0 +1,361 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleQuotient +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MulBy + +/-! +# The scalars of a simple algebra + +For a commutative algebra object `R` whose only ideals are `⊥` and +`⊤`, multiplication by a nonzero even scalar is an isomorphism, so +the even part of the Γ-algebra of `R` is a field; and the odd part +of that Γ-algebra vanishes. + +The mechanism is `RS.mulBy`: multiplication by an even scalar is a +module endomorphism of `R` (`RS.mul_comp_mulBy`), so its kernel and +its image are ideals (`RS.isIdeal_kernelSubobject_mulBy`, +`RS.isIdeal_imageSubobject_mulBy`). Simplicity forces the kernel to +be `⊥` and the image to be `⊤`, whence the endomorphism is an +isomorphism (`RS.isIso_mulBy_of_simple`) and the preimage of the +unit inverts the scalar (`RS.exists_inverse_of_simple`). + +The odd part goes the same way. An odd element `f` acts on `R` by +`RS.gmul f (𝟙 R)`, whose image is an ideal for the same reason; an +odd element squares to zero, so that action kills its own image, and +under either alternative of simplicity the action vanishes +(`RS.hom_oddLine_eq_zero_of_simple`). +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +/-! ## Convolution against the identity -/ + +section Ungraded + +variable {D : Type u} + +/-- Whiskering a morphism into the algebra and multiplying is the +convolution with the identity. -/ +theorem whiskerLeft_comp_mul + [Category.{v} D] [MonoidalCategory D] (R : D) [MonObj R] + {X : D} (k : X ⟶ R) : + (R ◁ k) ≫ μ[R] = gmul (𝟙 R) k := by + rw [gmul_def, id_tensorHom] + +/-- The convolution of the identity with itself is the +multiplication. -/ +theorem gmul_id_id [Category.{v} D] [MonoidalCategory D] (R : D) [MonObj R] : + gmul (𝟙 R) (𝟙 R) = μ[R] := by + rw [gmul_def, id_tensorHom, MonoidalCategory.whiskerLeft_id, + Category.id_comp] + +end Ungraded + +section UngradedAdditive + +variable {D : Type u} + +/-- Convolution with a zero morphism vanishes. -/ +theorem zero_gmul [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] (R : D) [MonObj R] + {X Y : D} (b : Y ⟶ R) : + gmul (0 : X ⟶ R) b = 0 := by + rw [gmul_def, tensorHom_def, MonoidalPreadditive.zero_whiskerRight, + zero_comp, zero_comp] + +end UngradedAdditive + +/-! ## Multiplication by a scalar is a module endomorphism -/ + +section Commutative + +variable {D : Type u} + +/-- Convolution with an even scalar reads the same on either side, +once the source is identified with its tensor with the unit. -/ +theorem leftUnitor_inv_gmul_comm + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] [IsCommMonObj R] + {X : D} (a : X ⟶ R) + (g : 𝟙_ D ⟶ R) : + (λ_ X).inv ≫ gmul g a = (ρ_ X).inv ≫ gmul a g := by + have hb : (ρ_ X).inv ≫ (β_ X (𝟙_ D)).hom = (λ_ X).inv := by + rw [← cancel_mono (λ_ X).hom, Category.assoc, + braiding_leftUnitor, Iso.inv_hom_id, Iso.inv_hom_id] + rw [gmul_comm a g, ← Category.assoc, hb] + +/-- Multiplication by an even scalar, written on the other side. -/ +theorem mulBy_eq_gmul_id + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] [IsCommMonObj R] + (g : 𝟙_ D ⟶ R) : + mulBy R g = (ρ_ R).inv ≫ gmul (𝟙 R) g := + leftUnitor_inv_gmul_comm R (𝟙 R) g + +/-- **Multiplication by an even scalar is a module +endomorphism**: it commutes with the multiplication of the algebra +in the second variable. Both sides say `g·(a·b) = a·(g·b)`. -/ +theorem mul_comp_mulBy + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] [IsCommMonObj R] + (g : 𝟙_ D ⟶ R) : + μ[R] ≫ mulBy R g = (R ◁ mulBy R g) ≫ μ[R] := by + have h5 : gmul (𝟙 R) (gmul (𝟙 R) g) = + (α_ R R (𝟙_ D)).inv ≫ gmul μ[R] g := by + rw [← gmul_id_id R, gmul_assoc, ← Category.assoc, Iso.inv_hom_id, + Category.id_comp] + have h6 : R ◁ (ρ_ R).inv ≫ (α_ R R (𝟙_ D)).inv = + (ρ_ (R ⊗ R)).inv := by monoidal + have hR : gmul (𝟙 R) (mulBy R g) = + (ρ_ (R ⊗ R)).inv ≫ gmul μ[R] g := by + rw [mulBy_eq_gmul_id, gmul_comp, h5, ← Category.assoc, h6] + rw [whiskerLeft_comp_mul, hR, comp_mulBy, + leftUnitor_inv_gmul_comm] + +/-- **The action of a fixed element is a module map.** For any +`f : X ⟶ R` the convolution `gmul f (𝟙 R)` absorbs multiplication +by the algebra: `a·(f·b) = f·(a·b)`. -/ +theorem act_comp_gmul_id + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (R : D) + [MonObj R] [IsCommMonObj R] + {X : D} (f : X ⟶ R) : + ((β_ R (X ⊗ R)).hom ≫ (α_ X R R).hom ≫ (X ◁ μ[R])) ≫ + gmul f (𝟙 R) = + (R ◁ gmul f (𝟙 R)) ≫ μ[R] := by + have hf : gmul f μ[R] = (X ◁ μ[R]) ≫ gmul f (𝟙 R) := by + rw [← gmul_comp, Category.comp_id] + rw [whiskerLeft_comp_mul, gmul_comm (𝟙 R) (gmul f (𝟙 R)), + gmul_assoc, gmul_id_id, hf] + simp only [Category.assoc] + +end Commutative + +/-! ## Images as subobjects -/ + +section Ind + +variable {C : Type v} + +/-- The factorisation of a morphism through its image, read as a +morphism into the image subobject. -/ +noncomputable def imageFactor [SmallCategory C] [Abelian C] + {X Y : Ind C} (k : X ⟶ Y) : + X ⟶ ((Subobject.mk (image.ι k) : Subobject Y) : Ind C) := + factorThruImage k ≫ (Subobject.underlyingIso (image.ι k)).inv + +/-- The factorisation through the image subobject recovers the +morphism. -/ +theorem imageFactor_arrow [SmallCategory C] [Abelian C] + {X Y : Ind C} (k : X ⟶ Y) : + imageFactor k ≫ (Subobject.mk (image.ι k)).arrow = k := by + rw [imageFactor, Category.assoc, Subobject.underlyingIso_arrow, + image.fac] + +/-- The factorisation through the image subobject is an +epimorphism. -/ +instance epi_imageFactor [SmallCategory C] [Abelian C] + {X Y : Ind C} (k : X ⟶ Y) : + Epi (imageFactor k) := by + change Epi (factorThruImage k ≫ _) + exact epi_comp _ _ + +/-! ## Kernel and image are ideals -/ + +/-- **The kernel of multiplication by a scalar is an ideal**: +multiplication by a scalar is a module endomorphism, so anything it +kills stays killed after multiplying by the algebra. -/ +theorem isIdeal_kernelSubobject_mulBy + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [MonoidalPreadditive C] (R : Ind C) [MonObj R] [IsCommMonObj R] + (g : 𝟙_ (Ind C) ⟶ R) : + IsIdeal R (kernelSubobject (mulBy R g)) := by + refine (kernelSubobject_factors_iff _ _).2 ?_ + rw [Category.assoc, mul_comp_mulBy, ← Category.assoc, + ← MonoidalCategory.whiskerLeft_comp, kernelSubobject_arrow_comp, + MonoidalPreadditive.whiskerLeft_zero, zero_comp] + +/-- **The image of a module map is an ideal.** If a morphism into +the algebra absorbs multiplication by the algebra, its image does +too: tensoring preserves the covering epimorphism onto the image. -/ +theorem isIdeal_imageSubobject_of + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] (R : Ind C) [MonObj R] + {X : Ind C} (k : X ⟶ R) + (θ : R ⊗ X ⟶ X) (hθ : θ ≫ k = (R ◁ k) ≫ μ[R]) : + IsIdeal R (Subobject.mk (image.ι k)) := by + have : Epi (R ◁ imageFactor k) := + inferInstanceAs (Epi ((tensorLeft R).map _)) + refine factors_of_epi_comp _ (R ◁ imageFactor k) _ ?_ + refine factors_of_comm (θ ≫ imageFactor k) ?_ + rw [Category.assoc, imageFactor_arrow, hθ, ← Category.assoc, + ← MonoidalCategory.whiskerLeft_comp, imageFactor_arrow] + +/-- **The image of multiplication by a scalar is an ideal.** -/ +theorem isIdeal_imageSubobject_mulBy + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] (R : Ind C) [MonObj R] + [IsCommMonObj R] + (g : 𝟙_ (Ind C) ⟶ R) : + IsIdeal R (Subobject.mk (image.ι (mulBy R g))) := + isIdeal_imageSubobject_of R (mulBy R g) μ[R] (mul_comp_mulBy R g) + +/-! ## Simplicity makes multiplication invertible -/ + +/-- A subobject equal to `⊥` has a zero arrow, so a morphism whose +image it is vanishes. -/ +theorem eq_zero_of_imageSubobject_eq_bot [SmallCategory C] [Abelian C] + {X Y : Ind C} {k : X ⟶ Y} + (h : Subobject.mk (image.ι k) = ⊥) : k = 0 := by + rw [← image.fac k, Subobject.mk_eq_bot_iff_zero.1 h, comp_zero] + +/-- A morphism whose image subobject is `⊤` is an epimorphism. -/ +theorem epi_of_imageSubobject_eq_top [SmallCategory C] [Abelian C] + {X Y : Ind C} {k : X ⟶ Y} + (h : Subobject.mk (image.ι k) = ⊤) : Epi k := by + have : IsIso (Subobject.mk (image.ι k)).arrow := + (Subobject.isIso_arrow_iff_eq_top _).2 h + have : IsIso (image.ι k) := by + rw [← Subobject.underlyingIso_arrow (image.ι k)] + infer_instance + have he : Epi (factorThruImage k ≫ image.ι k) := epi_comp _ _ + rwa [image.fac] at he + +/-- **Simplicity makes multiplication by a nonzero scalar +invertible.** The kernel is an ideal different from `⊤`, because a +scalar whose multiplication vanishes is itself zero; the image is an +ideal different from `⊥`, for the same reason. So the kernel is `⊥` +and the image is `⊤`, and a monomorphism which is an epimorphism of +an abelian category is an isomorphism. No hypothesis on the unit is +needed: a nonzero scalar already rules out both bad alternatives. -/ +theorem isIso_mulBy_of_simple + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] (R : Ind C) [MonObj R] + [IsCommMonObj R] + (hsimple : ∀ I : Subobject R, IsIdeal R I → I = ⊥ ∨ I = ⊤) + {g : 𝟙_ (Ind C) ⟶ R} (hg : g ≠ 0) : + IsIso (mulBy R g) := by + have hz : mulBy R g ≠ 0 := fun h => + hg (eq_zero_of_mulBy_eq_zero R h) + have : Mono (mulBy R g) := by + rcases hsimple _ (isIdeal_kernelSubobject_mulBy R g) with h | h + · refine Preadditive.mono_of_kernel_zero ?_ + have ha : (kernelSubobject (mulBy R g)).arrow = 0 := by + rw [h, Subobject.bot_arrow] + have hk := kernelSubobject_arrow' (mulBy R g) + rw [ha, comp_zero] at hk + exact hk.symm + · have : IsIso (kernelSubobject (mulBy R g)).arrow := + (Subobject.isIso_arrow_iff_eq_top _).2 h + exact absurd (zero_of_epi_comp _ + (kernelSubobject_arrow_comp (mulBy R g))) hz + have : Epi (mulBy R g) := by + rcases hsimple _ (isIdeal_imageSubobject_mulBy R g) with h | h + · exact absurd (eq_zero_of_imageSubobject_eq_bot h) hz + · exact epi_of_imageSubobject_eq_top h + exact isIso_of_mono_of_epi _ + +/-! ## The even part is a field -/ + +/-- **Every nonzero even scalar of a simple algebra is +invertible**: the preimage of the unit under multiplication by the +scalar is its inverse. -/ +theorem exists_inverse_of_simple + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] (R : Ind C) [MonObj R] + [IsCommMonObj R] + (hsimple : ∀ I : Subobject R, IsIdeal R I → I = ⊥ ∨ I = ⊤) + {g : 𝟙_ (Ind C) ⟶ R} (hg : g ≠ 0) : + ∃ g' : 𝟙_ (Ind C) ⟶ R, + (λ_ (𝟙_ (Ind C))).inv ≫ gmul g g' = η[R] := by + have := isIso_mulBy_of_simple R hsimple hg + refine ⟨η[R] ≫ inv (mulBy R g), ?_⟩ + rw [← comp_mulBy, Category.assoc, IsIso.inv_hom_id, + Category.comp_id] + +/-- **The even part of the Γ-algebra of a simple algebra is a +field.** -/ +theorem isField_gammaEven + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] (R : Ind C) [MonObj R] + [IsCommMonObj R] [CategoryTheory.Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] + (L : OddLine (Ind C)) + (hsimple : ∀ I : Subobject R, IsIdeal R I → I = ⊥ ∨ I = ⊤) + (hne : η[R] ≠ 0) : + IsField ((gammaAlgebra (Ind C) L R).even) := by + refine ⟨⟨1, 0, ?_⟩, mul_comm, ?_⟩ + · intro h + exact hne h + · intro a ha + obtain ⟨b, hb⟩ := exists_inverse_of_simple R hsimple (g := a) ha + exact ⟨b, hb⟩ + +/-- The even part of the Γ-algebra of a simple algebra, as a +field. -/ +@[reducible] noncomputable def gammaEvenField + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] (R : Ind C) [MonObj R] + [IsCommMonObj R] [CategoryTheory.Linear ℂ (Ind C)] + [MonoidalLinear ℂ (Ind C)] + (L : OddLine (Ind C)) + (hsimple : ∀ I : Subobject R, IsIdeal R I → I = ⊥ ∨ I = ⊤) + (hne : η[R] ≠ 0) : Field ((gammaAlgebra (Ind C) L R).even) := + (isField_gammaEven R L hsimple hne).toField + +/-! ## The odd part vanishes -/ + +/-- **The odd part of the Γ-algebra of a simple algebra +vanishes.** An odd element `f` acts on the algebra by +`gmul f (𝟙 R)`, whose image is an ideal, so simplicity leaves two +alternatives and the action vanishes under both: if the image is +`⊥` the action is zero outright, and if the image is `⊤` the action +is an epimorphism, which the square-zero law of an odd element +makes annihilate itself. Evaluating the zero action at the unit +returns `f`. -/ +theorem hom_oddLine_eq_zero_of_simple + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] (R : Ind C) [MonObj R] + [IsCommMonObj R] [CategoryTheory.Linear ℂ (Ind C)] + (L : OddLine (Ind C)) + (hsimple : ∀ I : Subobject R, IsIdeal R I → I = ⊥ ∨ I = ⊤) + (f : L.obj ⟶ R) : f = 0 := by + have hid : IsIdeal R (Subobject.mk (image.ι (gmul f (𝟙 R)))) := + isIdeal_imageSubobject_of R (gmul f (𝟙 R)) _ + (act_comp_gmul_id R f) + have hsq : gmul f (gmul f (𝟙 R)) = 0 := by + have h := gmul_assoc f f (𝟙 R) + rw [gmul_self_eq_zero_of_oddLine R L f, zero_gmul] at h + have h2 := congrArg (fun t => (α_ L.obj L.obj R).inv ≫ t) h + simpa using h2.symm + have hzero : gmul f (𝟙 R) = 0 := by + rcases hsimple _ hid with h | h + · exact eq_zero_of_imageSubobject_eq_bot h + · have := epi_of_imageSubobject_eq_top h + have : Epi (L.obj ◁ gmul f (𝟙 R)) := + inferInstanceAs (Epi ((tensorLeft L.obj).map _)) + refine zero_of_epi_comp (L.obj ◁ gmul f (𝟙 R)) ?_ + rw [← gmul_comp, Category.comp_id] + exact hsq + have hfac : (L.obj ◁ η[R]) ≫ gmul f (𝟙 R) = + (ρ_ L.obj).hom ≫ f := by + rw [← gmul_comp, Category.comp_id, gmul_one_right] + rw [hzero, comp_zero] at hfac + exact (cancel_epi (ρ_ L.obj).hom).1 + (hfac.symm.trans (comp_zero).symm) + +end Ind + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleSplit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleSplit.lean new file mode 100644 index 0000000000..e541c7e8bd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleSplit.lean @@ -0,0 +1,638 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleQuotient +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeSummand +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffleLine +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAbelian + +/-! +# Free mixed modules over a simple algebra + +Over a commutative algebra object of the ind-completion whose only +ideals are the zero subobject and the whole algebra, the free +modules on mixed sums of the unit and of an odd line are +semisimple of finite length. Consequently subobjects, quotients +and subquotients of objects whose free module is a mixed sum again +have free modules that are mixed sums, and every epimorphism out of +a free mixed module has a section. + +The development runs in three steps. + +* The regular module is simple. Submodules of the regular module + are exactly the ideals of the algebra: the intertwining law of a + module map `g` into the regular module says precisely that + multiplication by the algebra against the image of `g` lands in + that image, which is `RS.isIdeal_mk_hom`; simplicity of the + algebra then leaves only the zero and the whole subobject, and + `RS.mono_iff_hom`/`RS.epi_iff_hom` carry the conclusion back to + the category of modules (`RS.simple_regularMod`). +* The free module on the odd line is simple. Whiskering on the + right by the line is invertible up to the rotation + `RS.OddLine.rot` coming from the square of the line, so a + submodule of the free module on the line becomes, after + twisting, a submodule of the regular module + (`RS.lineToRegular`); whiskering by the line reflects both + vanishing and invertibility, so simplicity transfers + (`RS.simple_freeMod_oddLine`). The route taken is the direct + one: no auto-equivalence of the category of modules is built, + only the single twisting functor's action on objects and + morphisms, and the coherence identity `RS.rot_act` saying that + the rotation intertwines an action with its double twist. +* The free module on a mixed sum is a `RS.mixSum` of copies of the + regular module and of the free module on the line + (`RS.freeModMixIso`), by peeling summands with + `RS.OddLine.mixSuccIso` and `RS.OddLine.mixLineSuccIso` and + carrying them across with `RS.freeModBiprodIso`. + +The payoff combines these with the engine of +`RS/Classical/Deligne/ModAbelian.lean`: `RS.exists_mixSum_iso_of_mono` +and `RS.exists_mixSum_iso_of_epi` give +`RS.exists_mix_of_mono_of_simple`, `RS.exists_mix_of_epi_of_simple` +and `RS.exists_mix_of_isSubquotient`, since tensoring in `Ind C` is +exact and so the free-module functor preserves monomorphisms and +epimorphisms. + +A last section splits epimorphisms. In any abelian category an +epimorphism out of a finite direct sum of simple objects has a +section (`RS.exists_section_idxSum`, from the binary step +`RS.exists_section_biprod`), so over a simple algebra every +epimorphism out of a free mixed module splits +(`RS.exists_section_freeMod_mix`), which supplies the section datum +of the local splitting statement without constructing it by hand. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v uE vE jE + +/-! ## Splitting epimorphisms out of a sum of simple objects -/ + +section SplitEpi + +variable {E : Type uE} + +/-- **The inductive step for splitting an epimorphism**: an +epimorphism out of `X ⊞ T` with `X` simple splits as soon as every +epimorphism out of `T` splits. Either the second summand already +covers the target — the cokernel of its restriction vanishes — and +the section comes from the hypothesis on `T`; or the simple summand +maps isomorphically onto that cokernel, which exhibits the target as +the cokernel together with the image of the second summand, and the +two halves of the section are assembled by addition. -/ +theorem exists_section_biprod [Category.{vE} E] [Abelian E] + {X T N : E} [Simple X] + (f : (X ⊞ T) ⟶ N) (hf : Epi f) + (hT : ∀ {N' : E} (g : T ⟶ N'), Epi g → + ∃ s : N' ⟶ T, s ≫ g = 𝟙 N') : + ∃ s : N ⟶ (X ⊞ T), s ≫ f = 𝟙 N := by + have := hf + have hg : biprod.inr ≫ f ≫ cokernel.π (biprod.inr ≫ f) = 0 := by + rw [← Category.assoc] + exact cokernel.condition _ + have hfac : f ≫ cokernel.π (biprod.inr ≫ f) = + biprod.fst ≫ + (biprod.inl ≫ f ≫ cokernel.π (biprod.inr ≫ f)) := by + refine biprod.hom_ext' _ _ ?_ ?_ <;> simp [hg] + have : Epi (biprod.inl ≫ f ≫ cokernel.π (biprod.inr ≫ f)) := by + have h1 : Epi (f ≫ cokernel.π (biprod.inr ≫ f)) := epi_comp _ _ + rw [hfac] at h1 + exact epi_of_epi (biprod.fst : (X ⊞ T) ⟶ X) + (biprod.inl ≫ f ≫ cokernel.π (biprod.inr ≫ f)) + by_cases hu : biprod.inl ≫ f ≫ cokernel.π (biprod.inr ≫ f) = 0 + · have hc0 : cokernel.π (biprod.inr ≫ f) = 0 := by + refine zero_of_epi_comp f ?_ + rw [hfac, hu, Limits.comp_zero] + have : Epi (biprod.inr ≫ f) := by + rw [Preadditive.epi_iff_cancel_zero] + intro R w hw + rw [← cokernel.π_desc (biprod.inr ≫ f) w hw, hc0, + Limits.zero_comp] + obtain ⟨s₀, hs₀⟩ := hT (biprod.inr ≫ f) inferInstance + refine ⟨s₀ ≫ biprod.inr, ?_⟩ + rw [Category.assoc] + exact hs₀ + · have : IsIso (biprod.inl ≫ f ≫ cokernel.π (biprod.inr ≫ f)) := + isIso_of_epi_of_nonzero hu + have hs : (inv (biprod.inl ≫ f ≫ cokernel.π (biprod.inr ≫ f)) + ≫ (biprod.inl ≫ f)) ≫ cokernel.π (biprod.inr ≫ f) = + 𝟙 (cokernel (biprod.inr ≫ f)) := by + rw [Category.assoc, Category.assoc] + exact IsIso.inv_hom_id _ + obtain ⟨t, ht⟩ := + hT (Abelian.factorThruImage (biprod.inr ≫ f)) inferInstance + have hti : t ≫ (biprod.inr ≫ f) = + kernel.ι (cokernel.π (biprod.inr ≫ f)) := + (whisker_eq t + (Abelian.image.fac (biprod.inr ≫ f)).symm).trans + ((Category.assoc _ _ _).symm.trans + ((eq_whisker ht _).trans (Category.id_comp _))) + refine ⟨sectionRetraction _ _ hs ≫ t ≫ biprod.inr + + cokernel.π (biprod.inr ≫ f) ≫ + inv (biprod.inl ≫ f ≫ cokernel.π (biprod.inr ≫ f)) ≫ + biprod.inl, ?_⟩ + rw [Preadditive.add_comp] + simp only [Category.assoc] + rw [hti, sectionRetraction_ι] + abel + +/-- **An epimorphism out of a finite direct sum of simple objects +splits.** -/ +theorem exists_section_idxSum [Category.{vE} E] [Abelian E] + {J : Type jE} (S : J → E) : + ∀ (L : List J), (∀ j ∈ L, Simple (S j)) → + ∀ {N : E} (f : idxSum S L ⟶ N), Epi f → + ∃ s : N ⟶ idxSum S L, s ≫ f = 𝟙 N := by + intro L + induction L with + | nil => + intro _ N f hf + have := hf + have h0 : f = 0 := (isZero_zero E).eq_zero_of_src f + have h1 : (𝟙 N : N ⟶ N) = 0 := by + refine (cancel_epi f).1 ?_ + rw [Category.comp_id, h0, Limits.zero_comp] + exact ⟨0, by rw [Limits.zero_comp, h1]⟩ + | cons i L₀ ih => + intro hS N f hf + have : Simple (S i) := hS i (List.mem_cons_self ..) + exact exists_section_biprod + (X := S i) (T := idxSum S L₀) (N := N) f hf + (fun g hg => + ih (fun j hj => hS j (List.mem_cons_of_mem i hj)) g hg) + +/-- **An epimorphism out of a sum of copies of two simple objects +splits.** -/ +theorem exists_section_mixSum [Category.{vE} E] [Abelian E] + (X Y : E) [Simple X] [Simple Y] + (p q : ℕ) {N : E} (f : mixSum X Y p q ⟶ N) (hf : Epi f) : + ∃ s : N ⟶ mixSum X Y p q, s ≫ f = 𝟙 N := + exists_section_idxSum (id : E → E) + (List.replicate p X ++ List.replicate q Y) + (simple_of_mem_mix X Y p q) f hf + +end SplitEpi + +variable {C : Type v} + +section Regular + +/-- **A module map is an isomorphism exactly when its underlying +morphism is.** -/ +theorem isIso_iff_hom + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] (𝔹 : Ind C) [MonObj 𝔹] + {M N : Mod (Ind C) 𝔹} (f : M ⟶ N) : + IsIso f ↔ IsIso f.hom := by + constructor + · intro h + have := h + exact inferInstanceAs (IsIso ((Mod.forget (D := Ind C) 𝔹).map f)) + · intro h + have := h + have : Mono f := (mono_iff_hom 𝔹 f).2 inferInstance + have : Epi f := (epi_iff_hom 𝔹 f).2 inferInstance + exact isIso_of_mono_of_epi f + +/-- **A submodule of the regular module is an ideal.** The +intertwining law of a module map into the regular module says +exactly that multiplication by the algebra lands in the +subobject. -/ +theorem isIdeal_mk_hom + [SmallCategory C] [MonoidalCategory C] (𝔹 : Ind C) [MonObj 𝔹] + {M : Mod (Ind C) 𝔹} (g : M ⟶ regularMod 𝔹) + [Mono g.hom] : IsIdeal 𝔹 (Subobject.mk g.hom) := by + have hlaw : actLeft 𝔹 M.X ≫ g.hom = (𝔹 ◁ g.hom) ≫ μ[𝔹] := + g.isModHom.smul_hom + have harrow : (Subobject.mk g.hom).arrow = + (Subobject.underlyingIso g.hom).hom ≫ g.hom := + (Iso.inv_comp_eq _).1 (Subobject.underlyingIso_arrow _) + change (Subobject.mk g.hom).Factors + ((𝔹 ◁ (Subobject.mk g.hom).arrow) ≫ μ[𝔹]) + refine factors_of_comm + ((𝔹 ◁ (Subobject.underlyingIso g.hom).hom) ≫ + actLeft 𝔹 M.X ≫ (Subobject.underlyingIso g.hom).inv) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (Subobject.underlyingIso_arrow g.hom))) ?_ + refine Eq.trans (whisker_eq _ hlaw) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp 𝔹 _ _).symm _) ?_ + exact congrArg (fun t => (𝔹 ◁ t) ≫ μ[𝔹]) harrow.symm + +/-- **The regular module over a simple algebra is simple**: its +submodules are exactly the ideals of the algebra. -/ +theorem simple_regularMod + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] (𝔹 : Ind C) [MonObj 𝔹] + (hsimple : ∀ I : Subobject 𝔹, IsIdeal 𝔹 I → I = ⊥ ∨ I = ⊤) + (hne : η[𝔹] ≠ 0) : Simple (regularMod 𝔹) := by + constructor + intro M g hg + have := hg + have hmono : Mono g.hom := (mono_iff_hom 𝔹 g).1 hg + constructor + · intro hiso h0 + have := hiso + refine hne ?_ + have h1 : (𝟙 (regularMod 𝔹) : regularMod 𝔹 ⟶ regularMod 𝔹) = 0 := + (IsIso.inv_hom_id g).symm.trans + ((congrArg (fun t => inv g ≫ t) h0).trans Limits.comp_zero) + have h2 : (𝟙 𝔹 : 𝔹 ⟶ 𝔹) = 0 := congrArg Mod.Hom.hom h1 + exact (Category.comp_id η[𝔹]).symm.trans + ((congrArg (fun t => η[𝔹] ≫ t) h2).trans Limits.comp_zero) + · intro hg0 + have hghom : g.hom ≠ 0 := fun h => hg0 (Mod.hom_ext _ _ h) + rcases hsimple _ (isIdeal_mk_hom 𝔹 g) with h | h + · exact absurd (Subobject.mk_eq_bot_iff_zero.1 h) hghom + · have : IsIso g.hom := (Subobject.isIso_iff_mk_eq_top g.hom).2 h + exact (isIso_iff_hom 𝔹 g).2 inferInstance + +end Regular + +/-! ## Rotating by the odd line -/ + +section Rotation + +/-- **The rotation is compatible with whiskering on the left**: a +purely structural identity, once the square of the line is moved to +a common position on both sides. -/ +@[reassoc] +theorem whiskerLeft_rot + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + (L : OddLine (Ind C)) + (A X : Ind C) : + (α_ A (X ⊗ L.obj) L.obj).inv ≫ ((α_ A X L.obj).inv ▷ L.obj) ≫ + (L.rot (A ⊗ X)).hom = A ◁ (L.rot X).hom := by + have hu : (α_ A (X ⊗ L.obj) L.obj).inv ≫ + ((α_ A X L.obj).inv ▷ L.obj) ≫ + (α_ (A ⊗ X) L.obj L.obj).hom ≫ + (α_ A X (L.obj ⊗ L.obj)).hom = + A ◁ (α_ X L.obj L.obj).hom := by + monoidal + have hv : (α_ A X (𝟙_ (Ind C))).hom ≫ (A ◁ (ρ_ X).hom) = + (ρ_ (A ⊗ X)).hom := by + monoidal + rw [OddLine.rot_hom, OddLine.rot_hom] + simp only [MonoidalCategory.whiskerLeft_comp] + rw [← hv, associator_naturality_right_assoc, reassoc_of% hu] + +/-- **The rotation intertwines an action with its double twist by +the line.** -/ +theorem rot_act + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + (L : OddLine (Ind C)) + {A X : Ind C} (act : A ⊗ X ⟶ X) : + ((α_ A (X ⊗ L.obj) L.obj).inv ≫ + (((α_ A X L.obj).inv ≫ act ▷ L.obj) ▷ L.obj)) ≫ + (L.rot X).hom = (A ◁ (L.rot X).hom) ≫ act := by + rw [MonoidalCategory.comp_whiskerRight] + simp only [Category.assoc] + rw [L.whiskerRight_rot act, whiskerLeft_rot_assoc] + +/-- **Whiskering by the line carries an intertwiner to an +intertwiner** for the twisted actions. -/ +theorem whiskerRight_act + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + (L : OddLine (Ind C)) + {A X Y : Ind C} (actX : A ⊗ X ⟶ X) + (actY : A ⊗ Y ⟶ Y) (f : X ⟶ Y) + (hf : actX ≫ f = (A ◁ f) ≫ actY) : + ((α_ A X L.obj).inv ≫ actX ▷ L.obj) ≫ (f ▷ L.obj) = + (A ◁ (f ▷ L.obj)) ≫ + ((α_ A Y L.obj).inv ≫ actY ▷ L.obj) := by + rw [Category.assoc, ← MonoidalCategory.comp_whiskerRight, hf, + MonoidalCategory.comp_whiskerRight, + associator_inv_naturality_middle_assoc] + +/-- **Whiskering by the line reflects isomorphisms.** -/ +theorem isIso_of_whiskerRight + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + (L : OddLine (Ind C)) + {X Y : Ind C} (f : X ⟶ Y) + (h : IsIso (f ▷ L.obj)) : IsIso f := by + have := h + have : IsIso ((f ▷ L.obj) ▷ L.obj) := + inferInstanceAs (IsIso ((tensorRight L.obj).map (f ▷ L.obj))) + have hf : f = (L.rot X).inv ≫ ((f ▷ L.obj) ▷ L.obj) ≫ + (L.rot Y).hom := (L.rot_whiskerRight f).symm + rw [hf] + infer_instance + +end Rotation + +/-! ## The free module on the odd line -/ + +section OddLineFree + +/-- A module twisted on the right by the odd line. -/ +noncomputable def modLine + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + (𝔹 : Ind C) [MonObj 𝔹] (L : OddLine (Ind C)) + (M : Mod (Ind C) 𝔹) : Mod (Ind C) 𝔹 := + letI := tensorRightModObj 𝔹 M.X L.obj + ⟨M.X ⊗ L.obj⟩ + +@[simp] theorem modLine_X + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + (𝔹 : Ind C) [MonObj 𝔹] (L : OddLine (Ind C)) + (M : Mod (Ind C) 𝔹) : + (modLine 𝔹 L M).X = M.X ⊗ L.obj := rfl + +/-- **A submodule of the free module on the line becomes a +submodule of the regular module** after twisting by the line: the +twist of the free module on the line is the regular module, by the +rotation. -/ +noncomputable def lineToRegular + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + (𝔹 : Ind C) [MonObj 𝔹] (L : OddLine (Ind C)) + {M : Mod (Ind C) 𝔹} + (g : M ⟶ freeMod 𝔹 L.obj) : modLine 𝔹 L M ⟶ regularMod 𝔹 := + Mod.Hom.mk' ((g.hom ▷ L.obj) ≫ (L.rot 𝔹).hom) (by + have hf : actLeft 𝔹 M.X ≫ g.hom = + (𝔹 ◁ g.hom) ≫ ((α_ 𝔹 𝔹 L.obj).inv ≫ μ[𝔹] ▷ L.obj) := + g.isModHom.smul_hom + have h1 := whiskerRight_act L (actLeft 𝔹 M.X) + ((α_ 𝔹 𝔹 L.obj).inv ≫ μ[𝔹] ▷ L.obj) g.hom hf + have h2 := rot_act L (A := 𝔹) (X := 𝔹) μ[𝔹] + change ((α_ 𝔹 M.X L.obj).inv ≫ actLeft 𝔹 M.X ▷ L.obj) ≫ + ((g.hom ▷ L.obj) ≫ (L.rot 𝔹).hom) = + (𝔹 ◁ ((g.hom ▷ L.obj) ≫ (L.rot 𝔹).hom)) ≫ μ[𝔹] + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker h1 _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ h2) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + exact eq_whisker + (MonoidalCategory.whiskerLeft_comp 𝔹 _ _).symm _) + +/-- The twisted map vanishes exactly when the original does. -/ +theorem lineToRegular_eq_zero_iff + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [MonoidalPreadditive C] (𝔹 : Ind C) [MonObj 𝔹] (L : OddLine (Ind C)) + {M : Mod (Ind C) 𝔹} + (g : M ⟶ freeMod 𝔹 L.obj) : + lineToRegular 𝔹 L g = 0 ↔ g = 0 := by + constructor + · intro h + have h1 : (g.hom ▷ L.obj) ≫ (L.rot 𝔹).hom = 0 := + congrArg Mod.Hom.hom h + have h2 : g.hom ▷ L.obj = 0 := + (Iso.cancel_iso_hom_right _ _ (L.rot 𝔹)).mp + (h1.trans Limits.zero_comp.symm) + exact Mod.hom_ext _ _ (L.eq_zero_of_whiskerRight g.hom h2) + · intro h + refine Mod.hom_ext _ _ ?_ + change (g.hom ▷ L.obj) ≫ (L.rot 𝔹).hom = 0 + erw [show g.hom = 0 from congrArg Mod.Hom.hom h, + MonoidalPreadditive.zero_whiskerRight, Limits.zero_comp] + +/-- **The free module on the odd line is nonzero** as soon as the +unit of the algebra is: the rotation identifies its double twist +with the algebra. -/ +theorem id_freeMod_oddLine_ne_zero + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [MonoidalPreadditive C] (𝔹 : Ind C) [MonObj 𝔹] (L : OddLine (Ind C)) + (hne : η[𝔹] ≠ 0) : + (𝟙 (freeMod 𝔹 L.obj) : freeMod 𝔹 L.obj ⟶ freeMod 𝔹 L.obj) + ≠ 0 := by + intro h + have h1 : (𝟙 (𝔹 ⊗ L.obj) : 𝔹 ⊗ L.obj ⟶ 𝔹 ⊗ L.obj) = 0 := + congrArg Mod.Hom.hom h + have h2 : (𝟙 ((𝔹 ⊗ L.obj) ⊗ L.obj) : + (𝔹 ⊗ L.obj) ⊗ L.obj ⟶ (𝔹 ⊗ L.obj) ⊗ L.obj) = 0 := by + rw [← MonoidalCategory.id_whiskerRight (𝔹 ⊗ L.obj) L.obj, h1, + MonoidalPreadditive.zero_whiskerRight] + have hz : IsZero 𝔹 := + IsZero.of_iso ((IsZero.iff_id_eq_zero _).2 h2) (L.rot 𝔹).symm + exact hne (hz.eq_zero_of_tgt _) + +/-- **The free module on the odd line over a simple algebra is +simple.** Twisting by the line carries its submodules to +submodules of the regular module, and whiskering by the line +reflects both vanishing and invertibility. -/ +theorem simple_freeMod_oddLine + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] (𝔹 : Ind C) [MonObj 𝔹] + (L : OddLine (Ind C)) + (hsimple : ∀ I : Subobject 𝔹, IsIdeal 𝔹 I → I = ⊥ ∨ I = ⊤) + (hne : η[𝔹] ≠ 0) : Simple (freeMod 𝔹 L.obj) := by + have := simple_regularMod 𝔹 hsimple hne + constructor + intro M g hg + have := hg + have hgm : Mono g.hom := (mono_iff_hom 𝔹 g).1 hg + have hwm : Mono (g.hom ▷ L.obj) := + inferInstanceAs (Mono ((tensorRight L.obj).map g.hom)) + have hrot : IsIso (L.rot 𝔹).hom := (L.rot 𝔹).isIso_hom + have hrotMono : Mono (L.rot 𝔹).hom := @IsIso.mono_of_iso _ _ _ _ _ (L.rot 𝔹).isIso_hom + have hhm : Mono (lineToRegular 𝔹 L g) := by + refine mono_of_mono_hom _ ?_ + change Mono ((g.hom ▷ L.obj) ≫ (L.rot 𝔹).hom) + exact mono_comp' hwm hrotMono + constructor + · intro hiso h0 + have := hiso + refine id_freeMod_oddLine_ne_zero 𝔹 L hne ?_ + exact (IsIso.inv_hom_id g).symm.trans + ((congrArg (fun t => inv g ≫ t) h0).trans Limits.comp_zero) + · intro h0 + have : IsIso (lineToRegular 𝔹 L g) := + isIso_of_mono_of_nonzero + (fun h => h0 ((lineToRegular_eq_zero_iff 𝔹 L g).1 h)) + have : IsIso ((g.hom ▷ L.obj) ≫ (L.rot 𝔹).hom) := + (isIso_iff_hom 𝔹 (lineToRegular 𝔹 L g)).1 inferInstance + have : IsIso (g.hom ▷ L.obj) := + @IsIso.of_isIso_comp_right _ _ _ _ _ _ _ hrot + ((isIso_iff_hom 𝔹 (lineToRegular 𝔹 L g)).1 inferInstance) + exact (isIso_iff_hom 𝔹 g).2 + (isIso_of_whiskerRight L g.hom inferInstance) + +end OddLineFree + +/-! ## The free module on a mixed sum -/ + +section MixedFree + +/-- A module whose carrier vanishes vanishes. -/ +theorem isZero_of_isZero_X [SmallCategory C] [MonoidalCategory C] [Abelian C] + [MonoidalPreadditive C] (𝔹 : Ind C) [MonObj 𝔹] + {M : Mod (Ind C) 𝔹} (h : IsZero M.X) : + IsZero M := by + rw [IsZero.iff_id_eq_zero] + exact Mod.hom_ext _ _ ((IsZero.iff_id_eq_zero M.X).1 h) + +/-- **The free module on a mixed sum is a mixed sum of copies of +the regular module and of the free module on the odd line.** The +free-module functor carries the peeling isomorphisms of the mixed +sum to biproduct decompositions of the module. -/ +noncomputable def freeModMixIso + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] (𝔹 : Ind C) [MonObj 𝔹] + (L : OddLine (Ind C)) : ∀ p q : ℕ, + freeMod 𝔹 (L.mix p q) ≅ + mixSum (regularMod 𝔹) (freeMod 𝔹 L.obj) p q + | 0, 0 => + IsZero.iso + (isZero_of_isZero_X 𝔹 (freeModZeroIso 𝔹 L.isZero_mix_zero)) + (isZero_zero (Mod (Ind C) 𝔹)) + | 0, q + 1 => + freeModMapIso 𝔹 (L.mixLineSuccIso 0 q) ≪≫ + freeModBiprodIso 𝔹 L.obj (L.mix 0 q) ≪≫ + modBiprodMapIso 𝔹 _ _ (Iso.refl (freeMod 𝔹 L.obj)) + (freeModMixIso 𝔹 L 0 q) ≪≫ + biprod.uniqueUpToIso _ _ (modBinaryBiconeIsBilimit 𝔹 _ _) + | p + 1, q => + freeModMapIso 𝔹 (L.mixSuccIso p q) ≪≫ + freeModBiprodIso 𝔹 (𝟙_ (Ind C)) (L.mix p q) ≪≫ + modBiprodMapIso 𝔹 _ _ (freeModUnitIso 𝔹) + (freeModMixIso 𝔹 L p q) ≪≫ + biprod.uniqueUpToIso _ _ (modBinaryBiconeIsBilimit 𝔹 _ _) + +end MixedFree + +/-! ## Subquotients of a free mixed module -/ + +section Payoff + +/-- **The free-module functor preserves monomorphisms**: tensoring +in the ind-completion is exact. -/ +theorem mono_freeModMap + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] (𝔹 : Ind C) [MonObj 𝔹] + {V W : Ind C} (f : V ⟶ W) (hf : Mono f) : + Mono (freeModMap 𝔹 f) := by + have := hf + refine mono_of_mono_hom _ ?_ + change Mono (𝔹 ◁ f) + exact inferInstanceAs (Mono ((tensorLeft 𝔹).map f)) + +/-- **The free-module functor preserves epimorphisms.** -/ +theorem epi_freeModMap + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive C] (𝔹 : Ind C) [MonObj 𝔹] + {V W : Ind C} (f : V ⟶ W) (hf : Epi f) : + Epi (freeModMap 𝔹 f) := by + have := hf + refine epi_of_epi_hom _ ?_ + change Epi (𝔹 ◁ f) + exact inferInstanceAs (Epi ((tensorLeft 𝔹).map f)) + +/-- **A subobject of an object with free mixed module has a free +mixed module.** -/ +theorem exists_mix_of_mono_of_simple + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] (𝔹 : Ind C) [MonObj 𝔹] + (L : OddLine (Ind C)) + (hsimple : ∀ I : Subobject 𝔹, IsIdeal 𝔹 I → I = ⊥ ∨ I = ⊤) + (hne : η[𝔹] ≠ 0) {Y W : Ind C} (f : Y ⟶ W) (hf : Mono f) + {p q : ℕ} (e : freeMod 𝔹 W ≅ freeMod 𝔹 (L.mix p q)) : + ∃ p' q' : ℕ, + Nonempty (freeMod 𝔹 Y ≅ freeMod 𝔹 (L.mix p' q')) := by + have := simple_regularMod 𝔹 hsimple hne + have := simple_freeMod_oddLine 𝔹 L hsimple hne + have := mono_freeModMap 𝔹 f hf + obtain ⟨p', q', -, -, ⟨w⟩⟩ := + exists_mixSum_iso_of_mono (regularMod 𝔹) (freeMod 𝔹 L.obj) p q + (freeModMap 𝔹 f ≫ e.hom ≫ (freeModMixIso 𝔹 L p q).hom) + (mono_comp _ _) + exact ⟨p', q', ⟨w ≪≫ (freeModMixIso 𝔹 L p' q').symm⟩⟩ + +/-- **A quotient of an object with free mixed module has a free +mixed module.** -/ +theorem exists_mix_of_epi_of_simple + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] (𝔹 : Ind C) [MonObj 𝔹] + (L : OddLine (Ind C)) + (hsimple : ∀ I : Subobject 𝔹, IsIdeal 𝔹 I → I = ⊥ ∨ I = ⊤) + (hne : η[𝔹] ≠ 0) {Y W : Ind C} (f : W ⟶ Y) (hf : Epi f) + {p q : ℕ} (e : freeMod 𝔹 W ≅ freeMod 𝔹 (L.mix p q)) : + ∃ p' q' : ℕ, + Nonempty (freeMod 𝔹 Y ≅ freeMod 𝔹 (L.mix p' q')) := by + have := simple_regularMod 𝔹 hsimple hne + have := simple_freeMod_oddLine 𝔹 L hsimple hne + have := epi_freeModMap 𝔹 f hf + obtain ⟨p', q', -, -, ⟨w⟩⟩ := + exists_mixSum_iso_of_epi (regularMod 𝔹) (freeMod 𝔹 L.obj) p q + ((freeModMixIso 𝔹 L p q).inv ≫ e.inv ≫ freeModMap 𝔹 f) + (epi_comp _ _) + exact ⟨p', q', ⟨w ≪≫ (freeModMixIso 𝔹 L p' q').symm⟩⟩ + +/-- **A subquotient of an object with free mixed module has a free +mixed module.** -/ +theorem exists_mix_of_isSubquotient + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] (𝔹 : Ind C) [MonObj 𝔹] + (L : OddLine (Ind C)) + (hsimple : ∀ I : Subobject 𝔹, IsIdeal 𝔹 I → I = ⊥ ∨ I = ⊤) + (hne : η[𝔹] ≠ 0) {Y W : Ind C} (h : IsSubquotientOf Y W) + {p q : ℕ} (e : freeMod 𝔹 W ≅ freeMod 𝔹 (L.mix p q)) : + ∃ p' q' : ℕ, + Nonempty (freeMod 𝔹 Y ≅ freeMod 𝔹 (L.mix p' q')) := by + obtain ⟨S, i, r, hi, hr⟩ := h + obtain ⟨p₁, q₁, ⟨e₁⟩⟩ := + exists_mix_of_mono_of_simple 𝔹 L hsimple hne i hi e + exact exists_mix_of_epi_of_simple 𝔹 L hsimple hne r hr e₁ + +/-- **Every epimorphism out of a free mixed module splits.** Over +a simple algebra a free mixed module is a finite direct sum of +copies of two simple modules, and an epimorphism out of such a sum +has a section. -/ +theorem exists_section_freeMod_mix + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] (𝔹 : Ind C) [MonObj 𝔹] + (L : OddLine (Ind C)) + (hsimple : ∀ I : Subobject 𝔹, IsIdeal 𝔹 I → I = ⊥ ∨ I = ⊤) + (hne : η[𝔹] ≠ 0) (p q : ℕ) {N : Mod (Ind C) 𝔹} + (f : freeMod 𝔹 (L.mix p q) ⟶ N) (hf : Epi f) : + ∃ s : N ⟶ freeMod 𝔹 (L.mix p q), s ≫ f = 𝟙 N := by + have := simple_regularMod 𝔹 hsimple hne + have := simple_freeMod_oddLine 𝔹 L hsimple hne + have := hf + obtain ⟨s₀, hs₀⟩ := + exists_section_mixSum (regularMod 𝔹) (freeMod 𝔹 L.obj) p q + ((freeModMixIso 𝔹 L p q).inv ≫ f) (epi_comp _ _) + refine ⟨s₀ ≫ (freeModMixIso 𝔹 L p q).inv, ?_⟩ + rw [Category.assoc] + exact hs₀ + +/-- **A morphism whose source has a free mixed module has a +module-level section as soon as its free module is an +epimorphism.** This is the section datum of the local splitting +statement, supplied by semisimplicity rather than by hand. -/ +theorem exists_section_of_simple + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] (𝔹 : Ind C) [MonObj 𝔹] + (L : OddLine (Ind C)) + (hsimple : ∀ I : Subobject 𝔹, IsIdeal 𝔹 I → I = ⊥ ∨ I = ⊤) + (hne : η[𝔹] ≠ 0) {V W : Ind C} (g : V ⟶ W) + (hV : ∃ p q : ℕ, + Nonempty (freeMod 𝔹 V ≅ freeMod 𝔹 (L.mix p q))) + (hepi : Epi (freeModMap 𝔹 g)) : + ∃ s : freeMod 𝔹 W ⟶ freeMod 𝔹 V, + s ≫ freeModMap 𝔹 g = 𝟙 (freeMod 𝔹 W) := by + have := hepi + obtain ⟨p, q, ⟨e⟩⟩ := hV + obtain ⟨s₀, hs₀⟩ := + exists_section_freeMod_mix 𝔹 L hsimple hne p q + (e.inv ≫ freeModMap 𝔹 g) (epi_comp _ _) + refine ⟨s₀ ≫ e.inv, ?_⟩ + rw [Category.assoc] + exact hs₀ + +end Payoff + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SmallReduction.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SmallReduction.lean new file mode 100644 index 0000000000..3598b10e8b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SmallReduction.lean @@ -0,0 +1,448 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneTheorem + +/-! +# Deligne's theorem reduced to a genuinely small category + +`RS.DeligneTheoremStatement` quantifies over a category `A : Type u` +with `Category.{v} A` that is only *essentially* small, whereas the +constructions of the development live over a `SmallCategory`. This +module supplies the bridge: `RS.deligneTheoremStatement_of_small` +derives the statement in its stated generality from the special case +of a small category. + +The route is Mathlib's `CategoryTheory.SmallModel`, carrying the +monoidal structure transported along `CategoryTheory.equivSmallModel` +(`CategoryTheory.Monoidal.Transported`). Along that equivalence: + +* the abelian, preadditive, ℂ-linear, monoidal preadditive, monoidal + ℂ-linear and rigid structures are transported to the small model + (`RS.SmallDeligne`), the ℂ-linear one by `RS.linearOfFullyFaithful` + and the rest by Mathlib's transfer lemmas; +* Deligne's three hypotheses are transported — + `RS.hasScalarUnit_of_fullyFaithful`, `RS.tensorGeneratedBy_map` and + `RS.moderateLengthGrowth_map` — using the comparison isomorphisms + `RS.tensorPowMapIso`, `RS.rightDualMapIso` and `RS.mixedPowMapIso` + of a monoidal equivalence, together with the behaviour of + subquotients and of bounded length under a fully faithful functor + (`RS.isSubquotientOf_map`, `RS.lengthLE_of_map`); +* the fibre functor comes back by precomposition, + `RS.DeligneFibreFunctor.precompose`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Limits MonoidalCategory + +universe v₁ u₁ v₂ u₂ v u + +/-! ## A linear structure pulled back along a fully faithful functor -/ + +section LinearTransfer + +/-- The `R`-linear structure that a fully faithful additive functor +into an `R`-linear category induces on its source: a morphism is +rescaled by rescaling its image and taking the preimage. -/ +@[implicit_reducible] +def linearOfFullyFaithful (R : Type*) [Semiring R] {B : Type u₁} + [Category.{v₁} B] [Preadditive B] {A : Type u₂} [Category.{v₂} A] + [Preadditive A] [Linear R A] {G : B ⥤ A} (hG : G.FullyFaithful) + [G.Additive] : Linear R B where + homModule X Y := by + letI : SMul R (X ⟶ Y) := ⟨fun r f => hG.preimage (r • G.map f)⟩ + exact Function.Injective.module R (G.mapAddHom (X := X) (Y := Y)) + (fun _ _ h => hG.map_injective h) (fun _ _ => hG.map_preimage _) + smul_comp X Y Z r f g := hG.map_injective (by + change G.map ((hG.preimage (r • G.map f)) ≫ g) = _ + rw [Functor.map_comp, hG.map_preimage] + change _ = G.map (hG.preimage (r • G.map (f ≫ g))) + rw [hG.map_preimage, Functor.map_comp, Linear.smul_comp]) + comp_smul X Y Z f r g := hG.map_injective (by + change G.map (f ≫ (hG.preimage (r • G.map g))) = _ + rw [Functor.map_comp, hG.map_preimage] + change _ = G.map (hG.preimage (r • G.map (f ≫ g))) + rw [hG.map_preimage, Functor.map_comp, Linear.comp_smul]) + +/-- The inducing functor is linear for the induced structure: that +structure is defined so that it is. -/ +theorem functorLinearOfFullyFaithful (R : Type*) [Semiring R] + {B : Type u₁} [Category.{v₁} B] [Preadditive B] {A : Type u₂} + [Category.{v₂} A] [Preadditive A] [Linear R A] {G : B ⥤ A} + (hG : G.FullyFaithful) [G.Additive] : + letI := linearOfFullyFaithful R hG + G.Linear R := + letI := linearOfFullyFaithful R hG + { map_smul := fun _ _ => hG.map_preimage _ } + +end LinearTransfer + +/-! ## Comparison isomorphisms of a monoidal functor -/ + +section MonoidalComparison + +/-- A monoidal functor carries a tensor power to the tensor power of +the image: the comparison isomorphisms assembled by induction on the +exponent. -/ +noncomputable def tensorPowMapIso {A : Type u₁} [Category.{v₁} A] + [MonoidalCategory A] {B : Type u₂} [Category.{v₂} B] + [MonoidalCategory B] (G : A ⥤ B) [G.Monoidal] (X : A) : + ∀ n : ℕ, G.obj (tensorPow A X n) ≅ tensorPow B (G.obj X) n + | 0 => (Functor.Monoidal.εIso G).symm + | n + 1 => (Functor.Monoidal.μIso G (tensorPow A X n) X).symm ≪≫ + tensorIso (tensorPowMapIso G X n) (Iso.refl (G.obj X)) + +/-- Tensor powers respect isomorphisms of the base object. -/ +noncomputable def tensorPowCongrIso {B : Type u₂} [Category.{v₂} B] + [MonoidalCategory B] {X Y : B} (i : X ≅ Y) : + ∀ n : ℕ, tensorPow B X n ≅ tensorPow B Y n + | 0 => Iso.refl _ + | n + 1 => tensorIso (tensorPowCongrIso i n) i + +/-- A monoidal equivalence of rigid categories carries right duals to +right duals: the image of a dualising pair is a dualising pair +because the inverse functor reflects one, and right duals are unique +up to isomorphism. -/ +noncomputable def rightDualMapIso {A : Type u₁} [Category.{v₁} A] + [MonoidalCategory A] [RigidCategory A] {B : Type u₂} + [Category.{v₂} B] [MonoidalCategory B] [RigidCategory B] + (e : A ≌ B) [e.inverse.Monoidal] (X : A) : + e.functor.obj (Xᘁ) ≅ (e.functor.obj X)ᘁ := by + have u : ∀ Z : A, Z ≅ e.inverse.obj (e.functor.obj Z) := fun Z => + e.unitIso.app Z + haveI : ExactPairing (e.inverse.obj (e.functor.obj X)) + (e.inverse.obj (e.functor.obj (Xᘁ))) := + exactPairingCongr (u X).symm (u (Xᘁ)).symm + haveI hpair : ExactPairing (e.functor.obj X) (e.functor.obj (Xᘁ)) := + ExactPairing.ofFullyFaithful e.inverse _ _ + exact rightDualIso hpair HasRightDual.exact + +/-- A monoidal equivalence of rigid categories carries mixed tensor +powers to mixed tensor powers. -/ +noncomputable def mixedPowMapIso {A : Type u₁} [Category.{v₁} A] + [MonoidalCategory A] [RigidCategory A] {B : Type u₂} + [Category.{v₂} B] [MonoidalCategory B] [RigidCategory B] + (e : A ≌ B) [e.functor.Monoidal] [e.inverse.Monoidal] (X : A) + (a b : ℕ) : + e.functor.obj (mixedPow A X a b) ≅ mixedPow B (e.functor.obj X) a b := + (Functor.Monoidal.μIso e.functor (tensorPow A X a) + (tensorPow A (Xᘁ) b)).symm ≪≫ + tensorIso (tensorPowMapIso e.functor X a) + (tensorPowMapIso e.functor (Xᘁ) b ≪≫ + tensorPowCongrIso (rightDualMapIso e X) b) + +end MonoidalComparison + +/-! ## Subquotients and bounded length along a functor -/ + +section SubquotientLength + +/-- A functor preserving monomorphisms and epimorphisms carries +subquotients to subquotients. -/ +theorem isSubquotientOf_map {A : Type u₁} [Category.{v₁} A] + {B : Type u₂} [Category.{v₂} B] (G : A ⥤ B) + [G.PreservesMonomorphisms] [G.PreservesEpimorphisms] {Y Z : A} + (h : IsSubquotientOf Y Z) : + IsSubquotientOf (G.obj Y) (G.obj Z) := by + obtain ⟨S, i, p, hi, hp⟩ := h + have := hi + have := hp + exact ⟨G.obj S, G.map i, G.map p, inferInstance, inferInstance⟩ + +/-- The subquotient relation transfers along isomorphisms of both +arguments. -/ +theorem IsSubquotientOf.congr {A : Type u₁} [Category.{v₁} A] + {Y Y' Z Z' : A} (h : IsSubquotientOf Y Z) (iY : Y ≅ Y') + (iZ : Z ≅ Z') : IsSubquotientOf Y' Z' := by + obtain ⟨S, i, p, hi, hp⟩ := h + have := hi + have := hp + exact ⟨S, i ≫ iZ.hom, p ≫ iY.hom, inferInstance, inferInstance⟩ + +/-- A fully faithful functor preserving monomorphisms reflects the +length bound: it embeds the subobject order of `Z` in that of +`G.obj Z`, so a strictly increasing chain over `Z` gives one over +`G.obj Z`. -/ +theorem lengthLE_of_map {A : Type u₁} [Category.{v₁} A] + {B : Type u₂} [Category.{v₂} B] (G : B ⥤ A) (hG : G.FullyFaithful) + [G.PreservesMonomorphisms] {Z : B} {k : ℕ} + (h : LengthLE (G.obj Z) k) : LengthLE Z k := by + intro f hf + have hmono : ∀ {S T : Subobject Z}, S ≤ T → + Subobject.mk (G.map S.arrow) ≤ Subobject.mk (G.map T.arrow) := by + intro S T hST + refine Subobject.mk_le_mk_of_comm (G.map (Subobject.ofLE S T hST)) ?_ + rw [← G.map_comp, Subobject.ofLE_arrow] + have hrefl : ∀ {S T : Subobject Z}, + Subobject.mk (G.map S.arrow) ≤ Subobject.mk (G.map T.arrow) → + S ≤ T := by + intro S T hle + refine Subobject.le_of_comm + (hG.preimage + (Subobject.ofMkLEMk (G.map S.arrow) (G.map T.arrow) hle)) ?_ + refine hG.map_injective ?_ + rw [G.map_comp, hG.map_preimage, Subobject.ofMkLEMk_comp] + refine h (fun i => Subobject.mk (G.map (f i).arrow)) ?_ + intro i j hij + have hlt : f i < f j := hf hij + exact lt_of_le_of_ne (hmono hlt.le) fun heq => + hlt.ne (le_antisymm hlt.le (hrefl (le_of_eq heq.symm))) + +end SubquotientLength + +/-! ## Deligne's hypotheses along an equivalence -/ + +section Hypotheses + +/-- Scalar unit endomorphisms transfer along a fully faithful +ℂ-linear monoidal functor: the map `c ↦ c • 𝟙` on the source is +carried onto the one on the target by the functor followed by +conjugation with the unit comparison, and both of those are +bijective. -/ +theorem hasScalarUnit_of_fullyFaithful {A : Type u₁} [Category.{v₁} A] + [Preadditive A] [Linear ℂ A] [MonoidalCategory A] {B : Type u₂} + [Category.{v₂} B] [Preadditive B] [Linear ℂ B] [MonoidalCategory B] + (G : B ⥤ A) (hG : G.FullyFaithful) [G.Linear ℂ] + [G.Monoidal] (h : HasScalarUnit A) : HasScalarUnit B := by + have h' : Function.Bijective + (fun c : ℂ => (c • 𝟙 (𝟙_ A) : 𝟙_ A ⟶ 𝟙_ A)) := h + change Function.Bijective (fun c : ℂ => (c • 𝟙 (𝟙_ B) : 𝟙_ B ⟶ 𝟙_ B)) + set α : G.obj (𝟙_ B) ≅ 𝟙_ A := (Functor.Monoidal.εIso G).symm + have hcomp : (fun c : ℂ => (c • 𝟙 (𝟙_ A) : 𝟙_ A ⟶ 𝟙_ A)) = + (fun g : G.obj (𝟙_ B) ⟶ G.obj (𝟙_ B) => α.conj g) ∘ + (fun f : 𝟙_ B ⟶ 𝟙_ B => G.map f) ∘ + (fun c : ℂ => (c • 𝟙 (𝟙_ B) : 𝟙_ B ⟶ 𝟙_ B)) := by + funext c + simp [Iso.conj_apply, Functor.map_smul] + have hbij : Function.Bijective + ((fun g : G.obj (𝟙_ B) ⟶ G.obj (𝟙_ B) => α.conj g) ∘ + (fun f : 𝟙_ B ⟶ 𝟙_ B => G.map f)) := + Function.Bijective.comp α.conj.bijective hG.homEquiv.bijective + rw [hcomp] at h' + exact (Function.Bijective.of_comp_iff' hbij _).mp h' + +/-- Finite tensor generation transfers along a monoidal equivalence: +the image of a generator generates, because the equivalence carries +the subquotient witness of the preimage of an object to one for the +object, biproducts to biproducts and mixed powers to mixed powers. -/ +theorem tensorGeneratedBy_map {A : Type u₁} [Category.{v₁} A] + [Preadditive A] [HasFiniteBiproducts A] [MonoidalCategory A] + [RigidCategory A] {B : Type u₂} [Category.{v₂} B] [Preadditive B] + [HasFiniteBiproducts B] [MonoidalCategory B] [RigidCategory B] + (e : A ≌ B) [e.functor.Monoidal] [e.inverse.Monoidal] + [e.functor.Additive] {X : A} (h : TensorGeneratedBy A X) : + TensorGeneratedBy B (e.functor.obj X) := by + have cu : ∀ Z : B, e.functor.obj (e.inverse.obj Z) ≅ Z := fun Z => + e.counitIso.app Z + intro Y + obtain ⟨k, ab, hsub⟩ := h (e.inverse.obj Y) + refine ⟨k, ab, (isSubquotientOf_map e.functor hsub).congr (cu Y) ?_⟩ + exact e.functor.mapBiproduct _ ≪≫ + biproduct.mapIso fun t => mixedPowMapIso e X (ab t).1 (ab t).2 + +/-- Moderate length growth transfers along a monoidal equivalence: +the inverse functor carries a tensor power to the tensor power of the +preimage, and reflects the length bound. -/ +theorem moderateLengthGrowth_map {A : Type u₁} [Category.{v₁} A] + [MonoidalCategory A] {B : Type u₂} [Category.{v₂} B] + [MonoidalCategory B] (e : A ≌ B) [e.inverse.Monoidal] + (h : ModerateLengthGrowth A) : ModerateLengthGrowth B := by + intro Y + obtain ⟨c₀, c₁, hc⟩ := h (e.inverse.obj Y) + exact ⟨c₀, c₁, fun N => lengthLE_of_map e.inverse + e.fullyFaithfulInverse + ((hc N).of_iso (tensorPowMapIso e.inverse Y N).symm)⟩ + +end Hypotheses + +/-! ## The fibre functor along a functor -/ + +section Fibre + +/-- Precomposing a Deligne fibre functor with an exact, faithful, +ℂ-linear symmetric monoidal functor gives a Deligne fibre functor: +every clause of the conclusion is stable under composition. -/ +noncomputable def DeligneFibreFunctor.precompose {A : Type u₁} + [Category.{v₁} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] {B : Type u₂} [Category.{v₂} B] + [MonoidalCategory B] [SymmetricCategory B] [Preadditive B] + [Linear ℂ B] (F : DeligneFibreFunctor B) (G : A ⥤ B) [G.Braided] + [G.Additive] [G.Linear ℂ] [G.Faithful] [PreservesFiniteLimits G] + [PreservesFiniteColimits G] : DeligneFibreFunctor A := + letI := F.braided + letI := F.additive + letI := F.linear + letI := F.faithful + letI := F.preservesFiniteLimits + letI := F.preservesFiniteColimits + { ω := G ⋙ F.ω + braided := inferInstance + additive := inferInstance + linear := inferInstance + faithful := inferInstance + preservesFiniteLimits := comp_preservesFiniteLimits G F.ω + preservesFiniteColimits := comp_preservesFiniteColimits G F.ω } + +end Fibre + +/-! ## The small model of a candidate tensor category -/ + +section SmallModel + +variable (A : Type u) + +/-- The small model of an essentially small monoidal category, +carrying the monoidal structure transported along +`CategoryTheory.equivSmallModel`. -/ +@[reducible] noncomputable def SmallDeligne + [Category.{v} A] [EssentiallySmall.{v} A] : Type v := + Monoidal.Transported (equivSmallModel.{v} A) + +/-- The transporting equivalence onto the small model, monoidal by +construction. -/ +@[reducible] noncomputable def smallDeligneEquiv + [Category.{v} A] [EssentiallySmall.{v} A] : A ≌ SmallDeligne A := + Monoidal.equivalenceTransported (equivSmallModel.{v} A) + +/-- The preadditive structure of the small model. -/ +@[implicit_reducible] +noncomputable def smallDelignePreadditive + [Category.{v} A] [Abelian A] [EssentiallySmall.{v} A] : + Preadditive (SmallDeligne A) := + Preadditive.ofFullyFaithful (smallDeligneEquiv A).fullyFaithfulInverse + +attribute [local instance] smallDelignePreadditive + +/-- The inverse of the transporting equivalence is additive. -/ +theorem smallDeligneInverseAdditive + [Category.{v} A] [Abelian A] [EssentiallySmall.{v} A] : + (smallDeligneEquiv A).inverse.Additive := + (smallDeligneEquiv A).fullyFaithfulInverse.additive_ofFullyFaithful + +attribute [local instance] smallDeligneInverseAdditive + +/-- The transporting equivalence is additive. -/ +theorem smallDeligneFunctorAdditive + [Category.{v} A] [Abelian A] [EssentiallySmall.{v} A] : + (smallDeligneEquiv A).functor.Additive := + haveI : (smallDeligneEquiv A).symm.functor.Additive := + smallDeligneInverseAdditive A + Equivalence.inverse_additive (smallDeligneEquiv A).symm + +attribute [local instance] smallDeligneFunctorAdditive + +/-- The ℂ-linear structure of the small model. -/ +@[implicit_reducible] +noncomputable def smallDeligneLinear + [Category.{v} A] [Abelian A] [Linear ℂ A] [EssentiallySmall.{v} A] : + Linear ℂ (SmallDeligne A) := + linearOfFullyFaithful ℂ (smallDeligneEquiv A).fullyFaithfulInverse + +attribute [local instance] smallDeligneLinear + +/-- The inverse of the transporting equivalence is ℂ-linear. -/ +theorem smallDeligneInverseLinear + [Category.{v} A] [Abelian A] [Linear ℂ A] [EssentiallySmall.{v} A] : + (smallDeligneEquiv A).inverse.Linear ℂ := + functorLinearOfFullyFaithful ℂ + (smallDeligneEquiv A).fullyFaithfulInverse + +attribute [local instance] smallDeligneInverseLinear + +/-- The transporting equivalence is ℂ-linear. -/ +theorem smallDeligneFunctorLinear + [Category.{v} A] [Abelian A] [Linear ℂ A] [EssentiallySmall.{v} A] : + (smallDeligneEquiv A).functor.Linear ℂ := + haveI : (smallDeligneEquiv A).symm.functor.Linear ℂ := + smallDeligneInverseLinear A + Equivalence.inverseLinear (R := ℂ) (smallDeligneEquiv A).symm + +attribute [local instance] smallDeligneFunctorLinear + +/-- The small model has finite limits. -/ +theorem smallDeligneFiniteLimits + [Category.{v} A] [Abelian A] [EssentiallySmall.{v} A] : + HasFiniteLimits (SmallDeligne A) := + ⟨fun _ _ _ => + Adjunction.hasLimitsOfShape_of_equivalence (smallDeligneEquiv A).inverse⟩ + +attribute [local instance] smallDeligneFiniteLimits + +/-- The small model is abelian. -/ +@[implicit_reducible] +noncomputable def smallDeligneAbelian + [Category.{v} A] [Abelian A] [EssentiallySmall.{v} A] : + Abelian (SmallDeligne A) := + abelianOfEquivalence (smallDeligneEquiv A).inverse + +attribute [local instance] smallDeligneAbelian + +/-- The small model has finite biproducts. -/ +theorem smallDeligneBiproducts + [Category.{v} A] [Abelian A] [EssentiallySmall.{v} A] : + HasFiniteBiproducts (SmallDeligne A) := + HasFiniteBiproducts.of_hasFiniteProducts + +attribute [local instance] smallDeligneBiproducts + +/-- The tensor product of the small model is biadditive. -/ +theorem smallDeligneMonoidalPreadditive + [Category.{v} A] [Abelian A] [MonoidalCategory A] + [MonoidalPreadditive A] [EssentiallySmall.{v} A] : + MonoidalPreadditive (SmallDeligne A) := + monoidalPreadditive_of_faithful (smallDeligneEquiv A).inverse + +attribute [local instance] smallDeligneMonoidalPreadditive + +/-- The tensor product of the small model is ℂ-bilinear. -/ +theorem smallDeligneMonoidalLinear + [Category.{v} A] [Abelian A] [Linear ℂ A] [MonoidalCategory A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] [EssentiallySmall.{v} A] : + MonoidalLinear ℂ (SmallDeligne A) := + MonoidalLinear.ofFaithful ℂ (smallDeligneEquiv A).inverse + +attribute [local instance] smallDeligneMonoidalLinear + +/-- The small model is rigid. -/ +@[implicit_reducible] +noncomputable def smallDeligneRigid + [Category.{v} A] [MonoidalCategory A] [RigidCategory A] + [EssentiallySmall.{v} A] : RigidCategory (SmallDeligne A) := + rigidCategoryOfEquivalence (smallDeligneEquiv A).symm.toAdjunction + +attribute [local instance] smallDeligneRigid + +/-- **Deligne's theorem reduces to the small case.** Given the +conclusion of Théorème 0.6 for every small category carrying the +hypotheses, it holds for every essentially small one: transport the +structure and the hypotheses to the small model, apply the small +case, and precompose the resulting fibre functor with the +transporting equivalence. -/ +theorem deligneTheoremStatement_of_small + (h : ∀ (B : Type v) [SmallCategory B] [Abelian B] [Linear ℂ B] + [MonoidalCategory B] [SymmetricCategory B] [MonoidalPreadditive B] + [MonoidalLinear ℂ B] [HasFiniteBiproducts B] [RigidCategory B], + HasScalarUnit B → (∃ X : B, TensorGeneratedBy B X) → + ModerateLengthGrowth B → Nonempty (DeligneFibreFunctor B)) : + DeligneTheoremStatement.{u, v} := by + intro A _ _ _ _ _ _ _ _ _ _ hunit hgen hgrow + obtain ⟨X, hX⟩ := hgen + obtain ⟨F⟩ := h (SmallDeligne A) + (hasScalarUnit_of_fullyFaithful (smallDeligneEquiv A).inverse + (smallDeligneEquiv A).fullyFaithfulInverse hunit) + ⟨(smallDeligneEquiv A).functor.obj X, + tensorGeneratedBy_map (smallDeligneEquiv A) hX⟩ + (moderateLengthGrowth_map (smallDeligneEquiv A) hgrow) + exact ⟨F.precompose (smallDeligneEquiv A).functor⟩ + +end SmallModel + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAdjoint.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAdjoint.lean new file mode 100644 index 0000000000..41d34b40a2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAdjoint.lean @@ -0,0 +1,158 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeAdjoint + +/-! +# Adjointness of the split idempotents + +The split idempotent on the base change and its dual counterpart +are adjoint for the base-changed pairing: moving either across +the pairing gives the other. The two coevaluation identities +turn each side into a tensor of the two evaluations, and the +whisker exchange identifies them. + +Passing to the complementary idempotents gives the adjointness +in the form the dévissage step consumes. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The split idempotents are adjoint for the base-changed +pairing.** -/ +theorem splitIdem_adj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} (v : M.X ⟶ B) + (w : M'.X ⟶ B) + (d : ModDualityDatum A M M') + (hz : ModZigzagDatum A d) + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + (splitIdemDual A B φ v w d hv hw ▷ + (baseChangeMod φ M).X) ≫ + modTensorπ B (baseChangeMod φ M') (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair = + ((baseChangeMod φ M').X ◁ + splitIdem A B φ v w d hv hw) ≫ + modTensorπ B (baseChangeMod φ M') (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair := by + rw [splitIdemDual, splitIdem, + MonoidalCategory.comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rw [splitCoevalDual_pair A B φ v d hz hv, + splitCoeval_pair A B φ w d hz hw] + exact (whisker_exchange_assoc (splitEval A B φ w hw) + (splitEval A B φ v hv) μ[B]).symm + +/-- **The complementary split idempotents are adjoint for the +base-changed pairing**, at the carrier. -/ +theorem splitComplIdem_adj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} (v : M.X ⟶ B) + (w : M'.X ⟶ B) + (d : ModDualityDatum A M M') + (hz : ModZigzagDatum A d) + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + ((𝟙 (baseChange φ M') - + splitIdemDual A B φ v w d hv hw) ▷ + (baseChangeMod φ M).X) ≫ + modTensorπ B (baseChangeMod φ M') (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair = + ((baseChangeMod φ M').X ◁ + (𝟙 (baseChange φ M) - + splitIdem A B φ v w d hv hw)) ≫ + modTensorπ B (baseChangeMod φ M') (baseChangeMod φ M) ≫ + (baseChangeDatum A B φ d).pair := by + have hsubR : ∀ {U V : D} (f g : U ⟶ V) (W : D), + (f - g) ▷ W = f ▷ W - g ▷ W := by + intro U V f g W + exact (tensorRight W).map_sub + have hsubL : ∀ {U V : D} (W : D) (f g : U ⟶ V), + W ◁ (f - g) = W ◁ f - W ◁ g := by + intro U V W f g + exact (tensorLeft W).map_sub + rw [hsubR, hsubL, Preadditive.sub_comp, Preadditive.sub_comp, + MonoidalCategory.id_whiskerRight, + MonoidalCategory.whiskerLeft_id, + splitIdem_adj A B φ v w d hz hv hw] + rfl + +/-- **Adjointness of the split idempotents**, in the module form +the dévissage step consumes. -/ +theorem splitComplMap_adj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [HasKernels D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] {M : Mod D A} {M' : Mod D A} (v : M.X ⟶ B) + (w : M'.X ⟶ B) + (d : ModDualityDatum A M M') + (hz : ModZigzagDatum A d) + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) + (hδ : η[A] ≫ d.copair ≫ p = η[B]) : + modTensorMap B + (splitComplProjModDual A B φ v w d hv hw p hp hδ ≫ + splitComplInclDual A B φ v w d hv hw) + (𝟙 (baseChangeMod φ M)) ≫ + (baseChangeDatum A B φ d).pair = + modTensorMap B + (𝟙 (baseChangeMod φ M')) + (splitComplProjMod A B φ v w d hv hw p hp hδ ≫ + splitComplIncl A B φ v w d hv hw) ≫ + (baseChangeDatum A B φ d).pair := by + apply modTensor_hom_ext + rw [← Category.assoc, ← Category.assoc, modTensorπ_map, + modTensorπ_map] + simp only [Category.assoc, Mod.comp_hom', Mod.id_hom', + MonoidalCategory.tensorHom_id, + MonoidalCategory.id_tensorHom] + have hd : (splitComplProjModDual A B φ v w d hv hw p hp + hδ).hom ≫ + (splitComplInclDual A B φ v w d hv hw).hom = + 𝟙 (baseChange φ M') - splitIdemDual A B φ v w d hv hw := + splitComplProjDual_ι A B φ v w d hv hw p hp hδ + have hpr : (splitComplProjMod A B φ v w d hv hw p hp hδ).hom ≫ + (splitComplIncl A B φ v w d hv hw).hom = + 𝟙 (baseChange φ M) - splitIdem A B φ v w d hv hw := + splitComplProj_ι A B φ v w d hv hw p hp hδ + rw [hd, hpr] + exact splitComplIdem_adj A B φ v w d hz hv hw + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAssemble.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAssemble.lean new file mode 100644 index 0000000000..acb2330acb --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAssemble.lean @@ -0,0 +1,576 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SeedIns + +/-! +# Assembly of the splitting-data entries on the graded carrier + +The stage-level entries of the splitting algebra — the base +algebra, the module and the dual module — are lifted from the +two-index chain stages to the graded splitting algebra carrier: +the base enters the degree-zero component at the bottom stage, +the module the degree `+1` component and the dual module the +degree `−1` component. The base entry carries the unit to the +unit, and both module entries are linear over the base through +the base entry, in the exact shape of the splitting data of the +Key Lemma. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The base entry on the carrier**: the base algebra enters +the degree-zero component at the bottom stage. -/ +noncomputable def splitOfBase + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + (d : ModDualityDatum A M M') : + A ⟶ chainBGr A M M' d := + chainBaseStage A M M' d ≫ chainBGrCompι A M M' d 0 0 ≫ + chainBGrι A M M' d 0 + +/-- **The module entry on the carrier**: the module enters the +degree `+1` component at the bottom stage. -/ +noncomputable def splitIns + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + (d : ModDualityDatum A M M') : + M.X ⟶ chainBGr A M M' d := + chainSeedQ A M M' d ≫ chainBGrCompι A M M' d 1 0 ≫ + chainBGrι A M M' d 1 + +/-- **The dual entry on the carrier**: the dual module enters the +degree `−1` component at the bottom stage, through the arity +transport identifying the bottom stage of the `−1` line. -/ +noncomputable def splitIns' + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + (d : ModDualityDatum A M M') : + M'.X ⟶ chainBGr A M M' d := + chainSeedP A M M' d ≫ + chainStage2Cast A M M' + (by omega : 1 = (-(-1 : ℤ)).toNat + 0) + (by omega : 0 = ((-1 : ℤ)).toNat + 0) ≫ + chainBGrCompι A M M' d (-1) 0 ≫ + chainBGrι A M M' d (-1) + +/-- **The base entry carries the unit to the unit**: the carrier +entry of the base algebra is unital. -/ +theorem splitOfBase_unit + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + (d : ModDualityDatum A M M') : + η[A] ≫ splitOfBase A M M' d = chainBGrUnit A M M' d := by + have h1 : η[A] ≫ splitOfBase A M M' d = + chainSeed A M M' d ≫ chainBGrCompι A M M' d 0 0 ≫ + chainBGrι A M M' d 0 := by + rw [splitOfBase, reassoc_of% unit_chainBaseStage A M M' d] + rfl + have h2 : chainBGrUnit A M M' d = + chainSeed A M M' d ≫ chainBGrCompι A M M' d 0 0 ≫ + chainBGrι A M M' d 0 := by + erw [chainBGrUnit, ← Category.assoc, + chainBUnit_chainBGrComponentZeroIso_inv, Category.assoc] + exact h1.trans h2.symm + +section Linear + +-- Linearity of the insertion unfolds the module +-- action through the duality datum on one generator. +/-- **The module entry is linear over the base**, through the +carrier entry of the base algebra: the splitting-data shape of +the linearity law. -/ +theorem splitIns_linear + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') : + actLeft A M.X ≫ splitIns A M M' d = + (A ◁ splitIns A M M' d) ≫ + (splitOfBase A M M' d ▷ chainBGr A M M' d) ≫ + (letI := chainBGrMonObj A M M' d; + μ[chainBGr A M M' d]) := by + change actLeft A M.X ≫ splitIns A M M' d = + (A ◁ splitIns A M M' d) ≫ + (splitOfBase A M M' d ▷ chainBGr A M M' d) ≫ + chainBGrMul A M M' d + refine Eq.symm ?_ + rw [← Category.assoc, ← MonoidalCategory.tensorHom_def', + splitOfBase, splitIns, + ← MonoidalCategory.tensorHom_comp_tensorHom, + ← MonoidalCategory.tensorHom_comp_tensorHom] + simp only [Category.assoc] + rw [ι_tensorHom_chainBGrMul A M M' d 0 1] + show (chainBaseStage A M M' d ⊗ₘ chainSeedQ A M M' d) ≫ + (chainBGrCompι A M M' d 0 0 ⊗ₘ + chainBGrCompι A M M' d 1 0) ≫ + chainBGrCompMul A M M' d 0 1 ≫ + chainBGrι A M M' d (0 + 1) = + actLeft A M.X ≫ chainSeedQ A M M' d ≫ + chainBGrCompι A M M' d 1 0 ≫ chainBGrι A M M' d 1 + have hz : (chainBGrCompι A M M' d 0 0 ⊗ₘ + chainBGrCompι A M M' d 1 0 : + chainStage2 A M M' 0 0 ⊗ chainStage2 A M M' 0 1 ⟶ + chainBGrComponent A M M' d 0 ⊗ + chainBGrComponent A M M' d 1) ≫ + chainBGrCompMul A M M' d 0 1 = + (chainMul2 A M M' 0 0 0 1 ≫ + chainStage2Cast A M M' + (by omega : 0 + 1 + 0 = + (-((0 : ℤ) + 1)).toNat + (0 + 1)) + (by omega : 0 + 1 + 1 = + ((0 : ℤ) + 1).toNat + (0 + 1))) ≫ + chainBGrCompι A M M' d (0 + 1) (0 + 1) := + ι_tensorHom_chainBGrCompMul_zero_left A M M' d 1 0 + rw [reassoc_of% hz] + rw [MonoidalCategory.tensorHom_def' (chainBaseStage A M M' d) + (chainSeedQ A M M' d)] + simp only [Category.assoc] + have e1 : chainBGrCompι A M M' d (0 + 1) (0 + 1) ≫ + chainBGrι A M M' d (0 + 1) = + chainStage2Cast A M M' + (by omega : (-((0 : ℤ) + 1)).toNat + (0 + 1) = + (-(1 : ℤ)).toNat + (0 + 1)) + (by omega : ((0 : ℤ) + 1).toNat + (0 + 1) = + (1 : ℤ).toNat + (0 + 1)) ≫ + chainBGrCompι A M M' d 1 (0 + 1) ≫ + chainBGrι A M M' d 1 := by + refine Eq.trans (whisker_eq _ + (eqToHom_chainBGrι A M M' d (Int.zero_add 1)).symm) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (chainBGrCompι_eqToHom + A M M' d (Int.zero_add 1) (0 + 1)) _) ?_ + exact Category.assoc _ _ _ + have e2 : chainStage2Cast A M M' + (by omega : 0 + 1 = 0 + 1 + 0) + (by omega : 1 + 1 = 0 + 1 + 1) ≫ + chainStage2Cast A M M' + (by omega : 0 + 1 + 0 = + (-((0 : ℤ) + 1)).toNat + (0 + 1)) + (by omega : 0 + 1 + 1 = + ((0 : ℤ) + 1).toNat + (0 + 1)) ≫ + chainStage2Cast A M M' + (by omega : (-((0 : ℤ) + 1)).toNat + (0 + 1) = + (-(1 : ℤ)).toNat + (0 + 1)) + (by omega : ((0 : ℤ) + 1).toNat + (0 + 1) = + (1 : ℤ).toNat + (0 + 1)) ≫ + chainBGrCompι A M M' d 1 (0 + 1) ≫ + chainBGrι A M M' d 1 = + chainStage2Cast A M M' + (by omega : 0 + 1 = (-(1 : ℤ)).toNat + (0 + 1)) + (by omega : 1 + 1 = (1 : ℤ).toNat + (0 + 1)) ≫ + chainBGrCompι A M M' d 1 (0 + 1) ≫ + chainBGrι A M M' d 1 := by + refine Eq.trans (chainStage2Cast_trans_assoc + A M M' _ _ _ _ _) ?_ + exact chainStage2Cast_trans_assoc A M M' _ _ _ _ _ + have e3 : chainStage2Cast A M M' + (by omega : 0 + 1 = (-(1 : ℤ)).toNat + (0 + 1)) + (by omega : 1 + 1 = (1 : ℤ).toNat + (0 + 1)) ≫ + chainBGrCompι A M M' d 1 (0 + 1) ≫ + chainBGrι A M M' d 1 = + chainBGrCompι A M M' d 1 (0 + 1) ≫ + chainBGrι A M M' d 1 := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + exact eq_whisker (chainStage2Cast_chainBGrCompι A M M' d 1 + (rfl : (0 + 1 : ℕ) = 0 + 1)) _ + have hd : chainDelta2 A M M' d 0 1 ≫ + chainBGrCompι A M M' d 1 (0 + 1) = + chainBGrCompι A M M' d 1 0 := + chainDelta2_chainBGrCompι A M M' d 1 0 + have habs : (chainDelta2 A M M' d 0 1 ≫ + chainStage2Cast A M M' + (by omega : 0 + 1 = 0 + 1 + 0) + (by omega : 1 + 1 = 0 + 1 + 1)) ≫ + chainStage2Cast A M M' + (by omega : 0 + 1 + 0 = + (-((0 : ℤ) + 1)).toNat + (0 + 1)) + (by omega : 0 + 1 + 1 = + ((0 : ℤ) + 1).toNat + (0 + 1)) ≫ + chainBGrCompι A M M' d (0 + 1) (0 + 1) ≫ + chainBGrι A M M' d (0 + 1) = + chainBGrCompι A M M' d 1 0 ≫ chainBGrι A M M' d 1 := by + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (whisker_eq _ e1))) ?_ + refine Eq.trans (whisker_eq _ e2) ?_ + refine Eq.trans (whisker_eq _ e3) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + exact eq_whisker hd _ + have h1 : (chainBaseStage A M M' d ▷ + chainStage2 A M M' 0 1) ≫ + chainMul2 A M M' 0 0 0 1 ≫ + chainStage2Cast A M M' + (by omega : 0 + 1 + 0 = + (-((0 : ℤ) + 1)).toNat + (0 + 1)) + (by omega : 0 + 1 + 1 = + ((0 : ℤ) + 1).toNat + (0 + 1)) ≫ + chainBGrCompι A M M' d (0 + 1) (0 + 1) ≫ + chainBGrι A M M' d (0 + 1) = + modTensorAct A (symPowMod A M'.X 0) (symPowMod A M.X 1) ≫ + (chainDelta2 A M M' d 0 1 ≫ + chainStage2Cast A M M' + (by omega : 0 + 1 = 0 + 1 + 0) + (by omega : 1 + 1 = 0 + 1 + 1)) ≫ + chainStage2Cast A M M' + (by omega : 0 + 1 + 0 = + (-((0 : ℤ) + 1)).toNat + (0 + 1)) + (by omega : 0 + 1 + 1 = + ((0 : ℤ) + 1).toNat + (0 + 1)) ≫ + chainBGrCompι A M M' d (0 + 1) (0 + 1) ≫ + chainBGrι A M M' d (0 + 1) := + (Category.assoc _ _ _).symm.trans + ((eq_whisker (chainBaseStage_mul2 A M M' d 0 1) _).trans + (Category.assoc _ _ _)) + refine Eq.trans (whisker_eq _ h1) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (chainSeedQ_linear A M M' d).symm _) ?_ + refine Eq.trans (whisker_eq _ habs) ?_ + exact Category.assoc _ _ _ + +-- Linearity of the insertion unfolds the module +-- action through the duality datum on one generator. +private theorem splitIns_dualStage_absorb + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') : + (chainDelta2 A M M' d ((-(-1 : ℤ)).toNat + 0) + ((-1 : ℤ).toNat + 0) ≫ + chainStage2Cast A M M' + (by omega : (-(-1 : ℤ)).toNat + 0 + 1 = + 0 + 1 + ((-(-1 : ℤ)).toNat + 0)) + (by omega : (-1 : ℤ).toNat + 0 + 1 = + 0 + 1 + ((-1 : ℤ).toNat + 0))) ≫ + chainStage2Cast A M M' + (by omega : 0 + 1 + ((-(-1 : ℤ)).toNat + 0) = + (-((0 : ℤ) + -1)).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat))) + (by omega : 0 + 1 + ((-1 : ℤ).toNat + 0) = + ((0 : ℤ) + -1).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat))) ≫ + chainBGrCompι A M M' d ((0 : ℤ) + -1) + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat)) ≫ + chainBGrι A M M' d ((0 : ℤ) + -1) = + chainBGrCompι A M M' d (-1) 0 ≫ + chainBGrι A M M' d (-1) := by + have e1m : chainBGrCompι A M M' d ((0 : ℤ) + -1) + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat)) ≫ + chainBGrι A M M' d ((0 : ℤ) + -1) = + chainStage2Cast A M M' + (by omega : (-((0 : ℤ) + -1)).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat)) = + (-(-1 : ℤ)).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat))) + (by omega : ((0 : ℤ) + -1).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat)) = + (-1 : ℤ).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat))) ≫ + chainBGrCompι A M M' d (-1) + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat)) ≫ + chainBGrι A M M' d (-1) := by + refine Eq.trans (whisker_eq _ + (eqToHom_chainBGrι A M M' d (Int.zero_add (-1))).symm) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (chainBGrCompι_eqToHom + A M M' d (Int.zero_add (-1)) + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat))) _) ?_ + exact Category.assoc _ _ _ + have e2m : chainStage2Cast A M M' + (by omega : (-(-1 : ℤ)).toNat + 0 + 1 = + 0 + 1 + ((-(-1 : ℤ)).toNat + 0)) + (by omega : (-1 : ℤ).toNat + 0 + 1 = + 0 + 1 + ((-1 : ℤ).toNat + 0)) ≫ + chainStage2Cast A M M' + (by omega : 0 + 1 + ((-(-1 : ℤ)).toNat + 0) = + (-((0 : ℤ) + -1)).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat))) + (by omega : 0 + 1 + ((-1 : ℤ).toNat + 0) = + ((0 : ℤ) + -1).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat))) ≫ + chainStage2Cast A M M' + (by omega : (-((0 : ℤ) + -1)).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat)) = + (-(-1 : ℤ)).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat))) + (by omega : ((0 : ℤ) + -1).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat)) = + (-1 : ℤ).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat))) ≫ + chainBGrCompι A M M' d (-1) + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat)) ≫ + chainBGrι A M M' d (-1) = + chainStage2Cast A M M' + (by omega : (-(-1 : ℤ)).toNat + 0 + 1 = + (-(-1 : ℤ)).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat))) + (by omega : (-1 : ℤ).toNat + 0 + 1 = + (-1 : ℤ).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat))) ≫ + chainBGrCompι A M M' d (-1) + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat)) ≫ + chainBGrι A M M' d (-1) := by + refine Eq.trans (chainStage2Cast_trans_assoc + A M M' _ _ _ _ _) ?_ + exact chainStage2Cast_trans_assoc A M M' _ _ _ _ _ + have e3m : chainStage2Cast A M M' + (by omega : (-(-1 : ℤ)).toNat + 0 + 1 = + (-(-1 : ℤ)).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat))) + (by omega : (-1 : ℤ).toNat + 0 + 1 = + (-1 : ℤ).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat))) ≫ + chainBGrCompι A M M' d (-1) + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat)) ≫ + chainBGrι A M M' d (-1) = + chainBGrCompι A M M' d (-1) (0 + 1) ≫ + chainBGrι A M M' d (-1) := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + exact eq_whisker (chainStage2Cast_chainBGrCompι A M M' d (-1) + (by omega : (0 + 1 : ℕ) = + 0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat))) _ + have hdm : chainDelta2 A M M' d ((-(-1 : ℤ)).toNat + 0) + ((-1 : ℤ).toNat + 0) ≫ + chainBGrCompι A M M' d (-1) (0 + 1) = + chainBGrCompι A M M' d (-1) 0 := + chainDelta2_chainBGrCompι A M M' d (-1) 0 + have habsm : (chainDelta2 A M M' d ((-(-1 : ℤ)).toNat + 0) + ((-1 : ℤ).toNat + 0) ≫ + chainStage2Cast A M M' + (by omega : (-(-1 : ℤ)).toNat + 0 + 1 = + 0 + 1 + ((-(-1 : ℤ)).toNat + 0)) + (by omega : (-1 : ℤ).toNat + 0 + 1 = + 0 + 1 + ((-1 : ℤ).toNat + 0))) ≫ + chainStage2Cast A M M' + (by omega : 0 + 1 + ((-(-1 : ℤ)).toNat + 0) = + (-((0 : ℤ) + -1)).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat))) + (by omega : 0 + 1 + ((-1 : ℤ).toNat + 0) = + ((0 : ℤ) + -1).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat))) ≫ + chainBGrCompι A M M' d ((0 : ℤ) + -1) + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat)) ≫ + chainBGrι A M M' d ((0 : ℤ) + -1) = + chainBGrCompι A M M' d (-1) 0 ≫ + chainBGrι A M M' d (-1) := by + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (whisker_eq _ e1m))) ?_ + refine Eq.trans (whisker_eq _ e2m) ?_ + refine Eq.trans (whisker_eq _ e3m) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + exact eq_whisker hdm _ + exact habsm + +/-- **The dual entry is linear over the base**, through the +carrier entry of the base algebra: the splitting-data shape of +the linearity law for the dual module. -/ +theorem splitIns'_linear + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') : + actLeft A M'.X ≫ splitIns' A M M' d = + (A ◁ splitIns' A M M' d) ≫ + (splitOfBase A M M' d ▷ chainBGr A M M' d) ≫ + (letI := chainBGrMonObj A M M' d; + μ[chainBGr A M M' d]) := by + change actLeft A M'.X ≫ splitIns' A M M' d = + (A ◁ splitIns' A M M' d) ≫ + (splitOfBase A M M' d ▷ chainBGr A M M' d) ≫ + chainBGrMul A M M' d + refine Eq.symm ?_ + rw [← Category.assoc, ← MonoidalCategory.tensorHom_def', + splitOfBase, splitIns', + ← Category.assoc (chainSeedP A M M' d), + ← MonoidalCategory.tensorHom_comp_tensorHom, + ← MonoidalCategory.tensorHom_comp_tensorHom] + simp only [Category.assoc] + rw [ι_tensorHom_chainBGrMul A M M' d 0 (-1)] + have hzm : (chainBGrCompι A M M' d 0 0 ⊗ₘ + chainBGrCompι A M M' d (-1) 0 : + chainStage2 A M M' 0 0 ⊗ + chainStage2 A M M' ((-(-1 : ℤ)).toNat + 0) + ((-1 : ℤ).toNat + 0) ⟶ + chainBGrComponent A M M' d 0 ⊗ + chainBGrComponent A M M' d (-1)) ≫ + chainBGrCompMul A M M' d 0 (-1) = + (chainMul2 A M M' 0 0 ((-(-1 : ℤ)).toNat + 0) + ((-1 : ℤ).toNat + 0) ≫ + chainStage2Cast A M M' + (by omega : 0 + 1 + ((-(-1 : ℤ)).toNat + 0) = + (-((0 : ℤ) + -1)).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat))) + (by omega : 0 + 1 + ((-1 : ℤ).toNat + 0) = + ((0 : ℤ) + -1).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat)))) ≫ + chainBGrCompι A M M' d ((0 : ℤ) + -1) + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat)) := + ι_tensorHom_chainBGrCompMul_zero_left A M M' d (-1) 0 + rw [reassoc_of% hzm] + rw [MonoidalCategory.tensorHom_def' (chainBaseStage A M M' d) + (chainSeedP A M M' d ≫ chainStage2Cast A M M' + (by omega : 1 = (-(-1 : ℤ)).toNat + 0) + (by omega : 0 = ((-1 : ℤ)).toNat + 0))] + simp only [Category.assoc] + have habsm := splitIns_dualStage_absorb A M M' d + have h1m : (chainBaseStage A M M' d ▷ + chainStage2 A M M' ((-(-1 : ℤ)).toNat + 0) + ((-1 : ℤ).toNat + 0)) ≫ + chainMul2 A M M' 0 0 ((-(-1 : ℤ)).toNat + 0) + ((-1 : ℤ).toNat + 0) ≫ + chainStage2Cast A M M' + (by omega : 0 + 1 + ((-(-1 : ℤ)).toNat + 0) = + (-((0 : ℤ) + -1)).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat))) + (by omega : 0 + 1 + ((-1 : ℤ).toNat + 0) = + ((0 : ℤ) + -1).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat))) ≫ + chainBGrCompι A M M' d ((0 : ℤ) + -1) + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat)) ≫ + chainBGrι A M M' d ((0 : ℤ) + -1) = + modTensorAct A (symPowMod A M'.X ((-(-1 : ℤ)).toNat + 0)) + (symPowMod A M.X ((-1 : ℤ).toNat + 0)) ≫ + (chainDelta2 A M M' d ((-(-1 : ℤ)).toNat + 0) + ((-1 : ℤ).toNat + 0) ≫ + chainStage2Cast A M M' + (by omega : (-(-1 : ℤ)).toNat + 0 + 1 = + 0 + 1 + ((-(-1 : ℤ)).toNat + 0)) + (by omega : (-1 : ℤ).toNat + 0 + 1 = + 0 + 1 + ((-1 : ℤ).toNat + 0))) ≫ + chainStage2Cast A M M' + (by omega : 0 + 1 + ((-(-1 : ℤ)).toNat + 0) = + (-((0 : ℤ) + -1)).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat))) + (by omega : 0 + 1 + ((-1 : ℤ).toNat + 0) = + ((0 : ℤ) + -1).toNat + + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat))) ≫ + chainBGrCompι A M M' d ((0 : ℤ) + -1) + (0 + 1 + 0 + ((0 : ℤ).toNat + (-1 : ℤ).toNat - + ((0 : ℤ) + -1).toNat)) ≫ + chainBGrι A M M' d ((0 : ℤ) + -1) := + (Category.assoc _ _ _).symm.trans + ((eq_whisker (chainBaseStage_mul2 A M M' d + ((-(-1 : ℤ)).toNat + 0) ((-1 : ℤ).toNat + 0)) _).trans + (Category.assoc _ _ _)) + have hqm : (A ◁ (chainSeedP A M M' d ≫ + chainStage2Cast A M M' + (by omega : 1 = (-(-1 : ℤ)).toNat + 0) + (by omega : 0 = ((-1 : ℤ)).toNat + 0))) ≫ + modTensorAct A (symPowMod A M'.X ((-(-1 : ℤ)).toNat + 0)) + (symPowMod A M.X ((-1 : ℤ).toNat + 0)) = + (actLeft A M'.X ≫ chainSeedP A M M' d) ≫ + chainStage2Cast A M M' + (by omega : 1 = (-(-1 : ℤ)).toNat + 0) + (by omega : 0 = ((-1 : ℤ)).toNat + 0) := by + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp A + (chainSeedP A M M' d) _) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (chainStage2Cast_actLeft A M M' + (by omega : 1 = (-(-1 : ℤ)).toNat + 0) + (by omega : 0 = ((-1 : ℤ)).toNat + 0))) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + exact eq_whisker (chainSeedP_linear A M M' d).symm _ + refine Eq.trans (whisker_eq _ h1m) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker hqm _) ?_ + refine Eq.trans (whisker_eq _ habsm) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact Category.assoc _ _ _ + +end Linear + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitClosure.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitClosure.lean new file mode 100644 index 0000000000..7247f69b6e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitClosure.lean @@ -0,0 +1,431 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreRestrict +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffleLine + +/-! +# The objects split by a fixed algebra + +An object is *split* by an algebra when its free module is +isomorphic to the free module on a mixed sum of copies of the unit +and of the odd line. This file collects the closure properties of +that class: the unit and the odd line are split, and split objects +are closed under zero objects, finite biproducts and tensor +products. + +The bookkeeping is entirely at the level of the mixed sums: the +free module functor carries binary biproducts to module biproducts +(`RS.freeModBiprodIso`) and tensor products to relative tensor +products (`RS.freeModTensorIso`), so each closure statement reduces +to an isomorphism of mixed sums in the ambient category, and those +are proved by peeling summands with `RS.OddLine.mixSuccIso` and +`RS.OddLine.mixLineSuccIso`. + +The payoff is `RS.splitsOn_of_generator`: an algebra splitting a +tensor generator and its dual splits every embedded object, once +subquotients of split objects are known to be split. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v₂ u₂ v u + +section FinBiproduct + +variable {D : Type u} + +attribute [local instance] hasBinaryBiproducts_of_finite_biproducts + +/-- The empty biproduct vanishes. -/ +theorem isZero_biproductFinZero + [Category.{v} D] [Preadditive D] [HasFiniteBiproducts D] + (g : Fin 0 → D) : IsZero (⨁ g) := by + rw [IsZero.iff_id_eq_zero] + apply biproduct.hom_ext + rintro ⟨_, hj⟩ + exact absurd hj (Nat.not_lt_zero _) + +/-- The first inclusion misses the shifted projections. -/ +@[reassoc] +theorem biproductFin_ι_zero_lift + [Category.{v} D] [Preadditive D] [HasFiniteBiproducts D] + {k : ℕ} (g : Fin (k + 1) → D) : + biproduct.ι g 0 ≫ + (biproduct.lift fun i : Fin k => biproduct.π g i.succ) = 0 := by + apply biproduct.hom_ext + intro i + rw [Category.assoc, biproduct.lift_π, zero_comp, + biproduct.ι_π_ne _ (Fin.succ_ne_zero i).symm] + +/-- A shifted inclusion meets the shifted projections diagonally. -/ +@[reassoc] +theorem biproductFin_ι_succ_lift + [Category.{v} D] [Preadditive D] [HasFiniteBiproducts D] + {k : ℕ} (g : Fin (k + 1) → D) + (i : Fin k) : + biproduct.ι g i.succ ≫ + (biproduct.lift fun i' : Fin k => biproduct.π g i'.succ) = + biproduct.ι (fun i : Fin k => g i.succ) i := by + apply biproduct.hom_ext + intro i' + rw [Category.assoc, biproduct.lift_π] + by_cases hii : i = i' + · subst hii + rw [biproduct.ι_π_self, biproduct.ι_π_self] + · rw [biproduct.ι_π_ne _ (fun hh => hii (Fin.succ_inj.mp hh)), + biproduct.ι_π_ne _ hii] + +/-- Peeling the first summand off a biproduct indexed by +`Fin (k + 1)`. -/ +noncomputable def biprodPeelFinIso + [Category.{v} D] [Preadditive D] [HasFiniteBiproducts D] + {k : ℕ} (g : Fin (k + 1) → D) : + (⨁ g) ≅ g 0 ⊞ (⨁ fun i : Fin k => g i.succ) where + hom := biprod.lift (biproduct.π g 0) + (biproduct.lift fun i : Fin k => biproduct.π g i.succ) + inv := biprod.desc (biproduct.ι g 0) + (biproduct.desc fun i : Fin k => biproduct.ι g i.succ) + hom_inv_id := by + apply biproduct.hom_ext' + intro j + refine Fin.cases ?_ (fun i => ?_) j <;> + simp [biprod.lift_desc, biproductFin_ι_zero_lift_assoc, + biproductFin_ι_succ_lift_assoc, Fin.succ_ne_zero] + inv_hom_id := by + apply biprod.hom_ext' + · apply biprod.hom_ext + · simp + · simp [biproductFin_ι_zero_lift] + · apply biproduct.hom_ext' + intro i + apply biprod.hom_ext + · simp [Fin.succ_ne_zero] + · simp [biproductFin_ι_succ_lift] + +end FinBiproduct + +/-! ## Mixed sums are closed under biproducts and tensors -/ + +section Mix + +variable {D : Type u} + +attribute [local instance] hasBinaryBiproducts_of_finite_biproducts + +/-- The mixed sum of one unit and no line is the unit. -/ +noncomputable def OddLine.mixOneZeroIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) : + L.mix 1 0 ≅ 𝟙_ D := + L.mixSuccIso 0 0 ≪≫ (isoBiprodZero L.isZero_mix_zero).symm + +/-- The mixed sum of no unit and one line is the line. -/ +noncomputable def OddLine.mixZeroOneIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) : + L.mix 0 1 ≅ L.obj := + L.mixLineSuccIso 0 0 ≪≫ (isoBiprodZero L.isZero_mix_zero).symm + +/-- **A biproduct of mixed sums is a mixed sum.** -/ +theorem OddLine.exists_mix_biprod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) : + ∀ p q p' q' : ℕ, ∃ a b : ℕ, + Nonempty (L.mix p q ⊞ L.mix p' q' ≅ L.mix a b) := by + intro p + induction p with + | zero => + intro q + induction q with + | zero => + intro p' q' + exact ⟨p', q', + ⟨(isoZeroBiprod L.isZero_mix_zero).symm⟩⟩ + | succ q ihq => + intro p' q' + obtain ⟨a, b, ⟨e⟩⟩ := ihq p' q' + exact ⟨a, b + 1, + ⟨biprod.mapIso (L.mixLineSuccIso 0 q) (Iso.refl _) ≪≫ + biprod.associator _ _ _ ≪≫ + biprod.mapIso (Iso.refl L.obj) e ≪≫ + (L.mixLineSuccIso a b).symm⟩⟩ + | succ p ihp => + intro q p' q' + obtain ⟨a, b, ⟨e⟩⟩ := ihp q p' q' + exact ⟨a + 1, b, + ⟨biprod.mapIso (L.mixSuccIso p q) (Iso.refl _) ≪≫ + biprod.associator _ _ _ ≪≫ + biprod.mapIso (Iso.refl (𝟙_ D)) e ≪≫ + (L.mixSuccIso a b).symm⟩⟩ + +/-- **The line times a mixed sum is a mixed sum**: the line +exchanges the unit summands with the line summands. -/ +theorem OddLine.exists_mix_line_tensor + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + (L : OddLine D) : + ∀ p q : ℕ, ∃ a b : ℕ, + Nonempty (L.obj ⊗ L.mix p q ≅ L.mix a b) := by + intro p + induction p with + | zero => + intro q + induction q with + | zero => + exact ⟨0, 0, + ⟨(isZero_whiskerLeft L.obj L.isZero_mix_zero).iso + L.isZero_mix_zero⟩⟩ + | succ q ihq => + obtain ⟨a, b, ⟨e⟩⟩ := ihq + exact ⟨a + 1, b, + ⟨whiskerLeftIso L.obj (L.mixLineSuccIso 0 q) ≪≫ + tensorBiprodIso L.obj L.obj (L.mix 0 q) ≪≫ + biprod.mapIso L.sq e ≪≫ (L.mixSuccIso a b).symm⟩⟩ + | succ p ihp => + intro q + obtain ⟨a, b, ⟨e⟩⟩ := ihp q + exact ⟨a, b + 1, + ⟨whiskerLeftIso L.obj (L.mixSuccIso p q) ≪≫ + tensorBiprodIso L.obj (𝟙_ D) (L.mix p q) ≪≫ + biprod.mapIso (ρ_ L.obj) e ≪≫ + (L.mixLineSuccIso a b).symm⟩⟩ + +/-- **A tensor product of mixed sums is a mixed sum.** -/ +theorem OddLine.exists_mix_tensor + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + (L : OddLine D) : + ∀ p q p' q' : ℕ, ∃ a b : ℕ, + Nonempty (L.mix p q ⊗ L.mix p' q' ≅ L.mix a b) := by + intro p + induction p with + | zero => + intro q + induction q with + | zero => + intro p' q' + exact ⟨0, 0, + ⟨(isZero_whiskerRight L.isZero_mix_zero _).iso + L.isZero_mix_zero⟩⟩ + | succ q ihq => + intro p' q' + obtain ⟨a, b, ⟨e⟩⟩ := ihq p' q' + obtain ⟨c, d, ⟨f⟩⟩ := L.exists_mix_line_tensor p' q' + obtain ⟨m, n, ⟨g⟩⟩ := L.exists_mix_biprod c d a b + exact ⟨m, n, + ⟨whiskerRightIso (L.mixLineSuccIso 0 q) (L.mix p' q') ≪≫ + biprodTensorIso L.obj (L.mix 0 q) (L.mix p' q') ≪≫ + biprod.mapIso f e ≪≫ g⟩⟩ + | succ p ihp => + intro q p' q' + obtain ⟨a, b, ⟨e⟩⟩ := ihp q p' q' + obtain ⟨m, n, ⟨g⟩⟩ := L.exists_mix_biprod p' q' a b + exact ⟨m, n, + ⟨whiskerRightIso (L.mixSuccIso p q) (L.mix p' q') ≪≫ + biprodTensorIso (𝟙_ D) (L.mix p q) (L.mix p' q') ≪≫ + biprod.mapIso (λ_ (L.mix p' q')) e ≪≫ g⟩⟩ + +end Mix + +/-! ## Split objects -/ + +section Split + +variable {D : Type u} + +attribute [local instance] hasBinaryBiproducts_of_finite_biproducts + +/-- An object is *split* by `R` when its free module is a mixed +sum: a sum of copies of the unit and of the odd line. -/ +def IsSplit [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (R : D) [MonObj R] (Y : D) : Prop := + ∃ p q : ℕ, Nonempty (freeMod R Y ≅ freeMod R (L.mix p q)) + +/-- Splitness transports along an isomorphism. -/ +theorem IsSplit.of_iso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] (L : OddLine D) (R : D) + [MonObj R] + {Y Z : D} (e : Y ≅ Z) (h : IsSplit L R Y) : + IsSplit L R Z := by + obtain ⟨p, q, ⟨f⟩⟩ := h + exact ⟨p, q, ⟨(freeModMapIso R e).symm ≪≫ f⟩⟩ + +/-- **The unit is split**: it is the mixed sum of a single unit. -/ +theorem isSplit_unit [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] (L : OddLine D) (R : D) + [MonObj R] : IsSplit L R (𝟙_ D) := + ⟨1, 0, ⟨freeModMapIso R L.mixOneZeroIso.symm⟩⟩ + +/-- **A zero object is split**: it is the empty mixed sum. -/ +theorem isSplit_zero [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] (L : OddLine D) (R : D) + [MonObj R] + {Y : D} (h : IsZero Y) : IsSplit L R Y := + ⟨0, 0, ⟨freeModMapIso R (h.iso L.isZero_mix_zero)⟩⟩ + +/-- **Split objects are closed under binary biproducts**, the +ranks adding. -/ +theorem IsSplit.biprod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] (L : OddLine D) (R : D) + [MonObj R] [MonoidalPreadditive D] + {Y Z : D} (hY : IsSplit L R Y) + (hZ : IsSplit L R Z) : IsSplit L R (Y ⊞ Z) := by + obtain ⟨p, q, ⟨eY⟩⟩ := hY + obtain ⟨p', q', ⟨eZ⟩⟩ := hZ + obtain ⟨a, b, ⟨g⟩⟩ := L.exists_mix_biprod p q p' q' + exact ⟨a, b, ⟨freeModBiprodIso R Y Z ≪≫ + modBiprodMapIso R _ _ eY eZ ≪≫ + (freeModBiprodIso R (L.mix p q) (L.mix p' q')).symm ≪≫ + freeModMapIso R g⟩⟩ + +/-- **Split objects are closed under finite biproducts.** -/ +theorem IsSplit.biproduct + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] (L : OddLine D) (R : D) + [MonObj R] [MonoidalPreadditive D] : ∀ (k : ℕ) (g : Fin k → D), + (∀ t, IsSplit L R (g t)) → IsSplit L R (⨁ g) := by + intro k + induction k with + | zero => + exact fun g _ => isSplit_zero L R (isZero_biproductFinZero g) + | succ k ih => + intro g hg + exact IsSplit.of_iso L R (biprodPeelFinIso g).symm + (IsSplit.biprod L R (hg 0) (ih _ fun i => hg i.succ)) + +/-- **Split objects are closed under tensor products**: the free +module functor carries the tensor product to the relative tensor +product, and a tensor product of mixed sums is a mixed sum. -/ +theorem IsSplit.tensor + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] (L : OddLine D) (R : D) + [MonObj R] [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj R] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + {Y Z : D} (hY : IsSplit L R Y) + (hZ : IsSplit L R Z) : IsSplit L R (Y ⊗ Z) := by + obtain ⟨p, q, ⟨eY⟩⟩ := hY + obtain ⟨p', q', ⟨eZ⟩⟩ := hZ + obtain ⟨a, b, ⟨g⟩⟩ := L.exists_mix_tensor p q p' q' + exact ⟨a, b, ⟨(freeModTensorIso R Y Z).symm ≪≫ + modTensorMapIso R eY eZ ≪≫ + freeModTensorIso R (L.mix p q) (L.mix p' q') ≪≫ + freeModMapIso R g⟩⟩ + +/-- **Split objects are closed under tensor powers.** -/ +theorem IsSplit.tensorPow + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] (L : OddLine D) (R : D) + [MonObj R] [MonoidalPreadditive D] [HasCoequalizers D] [IsCommMonObj R] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + {Y : D} (h : IsSplit L R Y) (n : ℕ) : + IsSplit L R (tensorPow D Y n) := by + induction n with + | zero => exact isSplit_unit L R + | succ n ih => exact IsSplit.tensor L R ih h + +end Split + +/-! ## The generator splits the embedded category -/ + +section IndGenerator + +variable {C : Type v} + +/-- **The embedded tensor powers of a split object are split**: +the embedding is strong monoidal, so it carries the tensor power +downstairs to the tensor power upstairs. -/ +theorem isSplit_indOf_tensorPow + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [MonoidalPreadditive (Ind C)] [SymmetricCategory (Ind C)] + [HasCoequalizers (Ind C)] + [∀ Z : Ind C, PreservesColimitsOfShape WalkingParallelPair (tensorLeft + Z)] [HasFiniteBiproducts (Ind C)] (L : OddLine (Ind C)) (𝔸 : Ind C) + [MonObj 𝔸] [IsCommMonObj 𝔸] + (X : C) + (hX : IsSplit L 𝔸 ((indOf : C ⥤ Ind C).obj X)) (n : ℕ) : + IsSplit L 𝔸 ((indOf : C ⥤ Ind C).obj (tensorPow C X n)) := by + induction n with + | zero => + exact IsSplit.of_iso L 𝔸 (indOfUnitIso (C := C)) + (isSplit_unit L 𝔸) + | succ n ih => + exact IsSplit.of_iso L 𝔸 (indOfTensorIso (tensorPow C X n) X) + (IsSplit.tensor L 𝔸 ih hX) + +/-- **The embedded mixed tensor powers of a generator are split**, +given that the generator and its dual are. -/ +theorem isSplit_indOf_mixedPow + [SmallCategory C] [MonoidalCategory C] [Abelian C] [RigidCategory C] + [MonoidalPreadditive (Ind C)] [SymmetricCategory (Ind C)] + [HasCoequalizers (Ind C)] + [∀ Z : Ind C, PreservesColimitsOfShape WalkingParallelPair (tensorLeft + Z)] [HasFiniteBiproducts (Ind C)] (L : OddLine (Ind C)) (𝔸 : Ind C) + [MonObj 𝔸] [IsCommMonObj 𝔸] + (X : C) + (hX : IsSplit L 𝔸 ((indOf : C ⥤ Ind C).obj X)) + (hXd : IsSplit L 𝔸 ((indOf : C ⥤ Ind C).obj (Xᘁ))) + (a b : ℕ) : + IsSplit L 𝔸 ((indOf : C ⥤ Ind C).obj (mixedPow C X a b)) := by + have h : IsSplit L 𝔸 ((indOf : C ⥤ Ind C).obj + (tensorPow C X a ⊗ tensorPow C (Xᘁ) b)) := + IsSplit.of_iso L 𝔸 + (indOfTensorIso (tensorPow C X a) (tensorPow C (Xᘁ) b)) + (IsSplit.tensor L 𝔸 + (isSplit_indOf_tensorPow L 𝔸 X hX a) + (isSplit_indOf_tensorPow L 𝔸 (Xᘁ) hXd b)) + exact h + +/-- **A splitting generator splits the whole embedded category.** +Every object of `C` is a subquotient of a finite biproduct of +mixed tensor powers of the generator; the embedding is additive, so +it carries that biproduct into `Ind C`, where the closure +properties above make it split, and the subquotient hypothesis +finishes. + +The subquotient hypothesis is phrased downstairs: for objects `Y` +and `Z` of `C` with `Y` a subquotient of `Z`, splitness of the +embedded `Z` implies splitness of the embedded `Y`. -/ +theorem splitsOn_of_generator [SmallCategory C] [MonoidalCategory C] [Abelian C] + [HasFiniteBiproducts C] [RigidCategory C] [MonoidalPreadditive (Ind C)] + [SymmetricCategory (Ind C)] [HasCoequalizers (Ind C)] + [∀ Z : Ind C, PreservesColimitsOfShape WalkingParallelPair (tensorLeft + Z)] [HasFiniteBiproducts (Ind C)] (L : OddLine (Ind C)) (𝔸 : Ind C) + [MonObj 𝔸] [IsCommMonObj 𝔸] + (X : C) + (hX : IsSplit L 𝔸 ((indOf : C ⥤ Ind C).obj X)) + (hXd : IsSplit L 𝔸 ((indOf : C ⥤ Ind C).obj (Xᘁ))) + (hsub : ∀ Y Z : C, IsSubquotientOf Y Z → + IsSplit L 𝔸 ((indOf : C ⥤ Ind C).obj Z) → + IsSplit L 𝔸 ((indOf : C ⥤ Ind C).obj Y)) + (hgen : TensorGeneratedBy C X) : + SplitsOn L 𝔸 (indOf : C ⥤ Ind C) := by + have : (indOf (C := C)).Additive := indOf_additive + intro Y + obtain ⟨k, ab, hsq⟩ := hgen Y + change IsSplit L 𝔸 ((indOf : C ⥤ Ind C).obj Y) + refine hsub Y _ hsq ?_ + refine IsSplit.of_iso L 𝔸 + (((indOf : C ⥤ Ind C).mapBiproduct + (fun t => mixedPow C X (ab t).1 (ab t).2)).symm) ?_ + exact IsSplit.biproduct L 𝔸 k _ + (fun t => isSplit_indOf_mixedPow L 𝔸 X hX hXd _ _) + +end IndGenerator + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitComplement.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitComplement.lean new file mode 100644 index 0000000000..1300f087ce --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitComplement.lean @@ -0,0 +1,743 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod + +/-! +# The complement of the split factor + +The evaluation followed by the coevaluation is a linear +idempotent on the base change of the module; its kernel is the +complement of the split unit factor, and carries the descended +action. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The split idempotent** on the base change: evaluate, then +coevaluate. -/ +noncomputable def splitIdem + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} + {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + baseChange φ M ⟶ baseChange φ M := + splitEval A B φ v hv ≫ splitCoeval A B φ w d hw + +/-- The split idempotent is idempotent. -/ +theorem splitIdem_idem + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} + {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) + (hδ : η[A] ≫ d.copair ≫ p = η[B]) : + splitIdem A B φ v w d hv hw ≫ + splitIdem A B φ v w d hv hw = + splitIdem A B φ v w d hv hw := by + rw [splitIdem, Category.assoc, + ← Category.assoc (splitCoeval A B φ w d hw), + splitCoeval_splitEval A B φ v w d hv hw p hp hδ, + Category.id_comp] + +/-- The split idempotent is linear over the algebra. -/ +theorem baseChangeAct_splitIdem + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} + {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + baseChangeAct φ M ≫ splitIdem A B φ v w d hv hw = + (B ◁ splitIdem A B φ v w d hv hw) ≫ + baseChangeAct φ M := by + rw [splitIdem, ← Category.assoc, + baseChangeAct_splitEval A B φ v hv, Category.assoc, + mul_splitCoeval A B φ w d hw, + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + +section Complement + +/-- **The complement carrier**: the kernel of the split +idempotent. -/ +noncomputable def splitCompl + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] + {M : Mod D A} {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : D := + kernel (splitIdem A B φ v w d hv hw) + +/-- The action of the algebra descends to the complement. -/ +noncomputable def splitComplAct + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + B ⊗ splitCompl A B φ v w d hv hw ⟶ + splitCompl A B φ v w d hv hw := + kernel.lift _ + ((B ◁ kernel.ι (splitIdem A B φ v w d hv hw)) ≫ + baseChangeAct φ M) (by + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (baseChangeAct_splitIdem A B φ v w d hv hw)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => B ◁ t) + (kernel.condition + (splitIdem A B φ v w d hv hw))) _) ?_ + rw [MonoidalPreadditive.whiskerLeft_zero, + Limits.zero_comp] + rfl) + +/-- Defining equation of the complement action. -/ +@[reassoc] +theorem splitComplAct_ι + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + splitComplAct A B φ v w d hv hw ≫ + kernel.ι (splitIdem A B φ v w d hv hw) = + (B ◁ kernel.ι (splitIdem A B φ v w d hv hw)) ≫ + baseChangeAct φ M := + kernel.lift_ι _ _ _ + +/-- The unit law of the complement action. -/ +theorem splitComplAct_one + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + (η[B] ▷ splitCompl A B φ v w d hv hw) ≫ + splitComplAct A B φ v w d hv hw = + (λ_ (splitCompl A B φ v w d hv hw)).hom := by + let := baseChangeModObj φ M + have hι : ((η[B] ▷ splitCompl A B φ v w d hv hw) ≫ + splitComplAct A B φ v w d hv hw) ≫ + kernel.ι (splitIdem A B φ v w d hv hw) = + (λ_ (splitCompl A B φ v w d hv hw)).hom ≫ + kernel.ι (splitIdem A B φ v w d hv hw) := by + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (splitComplAct_ι A B φ v w d hv hw)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (whisker_exchange η[B] (kernel.ι + (splitIdem A B φ v w d hv hw))).symm _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (one_actLeft B (baseChange φ M))) ?_ + exact leftUnitor_naturality _ + exact (cancel_mono + (kernel.ι (splitIdem A B φ v w d hv hw))).mp hι + +/-- The multiplication law of the complement action. -/ +theorem splitComplAct_mul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + (μ[B] ▷ splitCompl A B φ v w d hv hw) ≫ + splitComplAct A B φ v w d hv hw = + (α_ B B (splitCompl A B φ v w d hv hw)).hom ≫ + (B ◁ splitComplAct A B φ v w d hv hw) ≫ + splitComplAct A B φ v w d hv hw := by + let := baseChangeModObj φ M + have hι : ((μ[B] ▷ splitCompl A B φ v w d hv hw) ≫ + splitComplAct A B φ v w d hv hw) ≫ + kernel.ι (splitIdem A B φ v w d hv hw) = + ((α_ B B (splitCompl A B φ v w d hv hw)).hom ≫ + (B ◁ splitComplAct A B φ v w d hv hw) ≫ + splitComplAct A B φ v w d hv hw) ≫ + kernel.ι (splitIdem A B φ v w d hv hw) := by + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (splitComplAct_ι A B φ v w d hv hw)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (whisker_exchange μ[B] (kernel.ι + (splitIdem A B φ v w d hv hw))).symm _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (mul_actLeft B (baseChange φ M))) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (associator_naturality_right B B (kernel.ι + (splitIdem A B φ v w d hv hw))) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine whisker_eq _ ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (splitComplAct_ι A B φ v w d hv hw)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => B ◁ t) + (splitComplAct_ι A B φ v w d hv hw)) _) ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _) _) ?_ + exact Category.assoc _ _ _ + exact (cancel_mono + (kernel.ι (splitIdem A B φ v w d hv hw))).mp hι + +/-- The complement, as a module over the algebra. -/ +@[implicit_reducible] +noncomputable def splitComplModObj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + ModObj B (splitCompl A B φ v w d hv hw) where + smul := splitComplAct A B φ v w d hv hw + one_smul := splitComplAct_one A B φ v w d hv hw + mul_smul := splitComplAct_mul A B φ v w d hv hw + +/-- The complement, bundled. -/ +noncomputable def splitComplMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : Mod D B := + letI := splitComplModObj A B φ v w d hv hw + ⟨splitCompl A B φ v w d hv hw⟩ + +/-- The projection onto the complement: the complementary +idempotent, corestricted to the kernel. -/ +noncomputable def splitComplProj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] + {M : Mod D A} {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) + (hδ : η[A] ≫ d.copair ≫ p = η[B]) : + baseChange φ M ⟶ splitCompl A B φ v w d hv hw := + kernel.lift _ (𝟙 (baseChange φ M) - + splitIdem A B φ v w d hv hw) (by + rw [Preadditive.sub_comp, Category.id_comp, + splitIdem_idem A B φ v w d hv hw p hp hδ, sub_self]) + +/-- Defining equation of the projection. -/ +@[reassoc] +theorem splitComplProj_ι + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] + {M : Mod D A} {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) + (hδ : η[A] ≫ d.copair ≫ p = η[B]) : + splitComplProj A B φ v w d hv hw p hp hδ ≫ + kernel.ι (splitIdem A B φ v w d hv hw) = + 𝟙 (baseChange φ M) - splitIdem A B φ v w d hv hw := + kernel.lift_ι _ _ _ + +/-- **The decomposition of the base change**, carrier level: the +algebra summand against the complement. -/ +noncomputable def splitDecomp + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] + {M : Mod D A} {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + [HasBinaryBiproducts D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) + (hδ : η[A] ≫ d.copair ≫ p = η[B]) : + baseChange φ M ≅ B ⊞ splitCompl A B φ v w d hv hw where + hom := biprod.lift (splitEval A B φ v hv) + (splitComplProj A B φ v w d hv hw p hp hδ) + inv := biprod.desc (splitCoeval A B φ w d hw) + (kernel.ι (splitIdem A B φ v w d hv hw)) + hom_inv_id := by + erw [biprod.lift_desc, + splitComplProj_ι A B φ v w d hv hw p hp hδ] + rw [show splitEval A B φ v hv ≫ + splitCoeval A B φ w d hw = + splitIdem A B φ v w d hv hw from rfl] + rw [add_sub_cancel] + inv_hom_id := by + apply biprod.hom_ext' + · erw [biprod.inl_desc_assoc, Category.comp_id] + apply biprod.hom_ext + · rw [Category.assoc, biprod.lift_fst, biprod.inl_fst, + splitCoeval_splitEval A B φ v w d hv hw p hp hδ] + · rw [Category.assoc, biprod.lift_snd, biprod.inl_snd] + refine (cancel_mono (kernel.ι + (splitIdem A B φ v w d hv hw))).mp ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (splitComplProj_ι A B φ v w d hv hw p hp hδ)) ?_ + rw [Preadditive.comp_sub, Category.comp_id] + refine Eq.trans ?_ (Limits.zero_comp (f := kernel.ι + (splitIdem A B φ v w d hv hw))).symm + rw [show splitCoeval A B φ w d hw ≫ + splitIdem A B φ v w d hv hw = + (splitCoeval A B φ w d hw ≫ + splitEval A B φ v hv) ≫ + splitCoeval A B φ w d hw from + (Category.assoc _ _ _).symm] + rw [splitCoeval_splitEval A B φ v w d hv hw p hp hδ, + Category.id_comp, sub_self] + · erw [biprod.inr_desc_assoc, Category.comp_id] + apply biprod.hom_ext + · erw [Category.assoc, biprod.lift_fst, biprod.inr_fst] + have : IsSplitMono (splitCoeval A B φ w d hw) := + IsSplitMono.mk' ⟨splitEval A B φ v hv, + splitCoeval_splitEval A B φ v w d hv hw p hp hδ⟩ + refine (cancel_mono + (splitCoeval A B φ w d hw)).mp ?_ + erw [Limits.zero_comp, Category.assoc] + exact kernel.condition _ + · erw [Category.assoc, biprod.lift_snd, biprod.inr_snd] + refine (cancel_mono (kernel.ι + (splitIdem A B φ v w d hv hw))).mp ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (splitComplProj_ι A B φ v w d hv hw p hp hδ)) ?_ + erw [Preadditive.comp_sub, Category.comp_id] + have h1 : kernel.ι (splitIdem A B φ v w d hv hw) ≫ + splitIdem A B φ v w d hv hw = 0 := + kernel.condition _ + refine Eq.trans (congrArg (fun t => + kernel.ι (splitIdem A B φ v w d hv hw) - t) h1) ?_ + refine Eq.trans (sub_zero _) ?_ + exact (Category.id_comp _).symm + +/-- The projection is linear over the algebra. -/ +@[reassoc] +theorem baseChangeAct_splitComplProj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) + (hδ : η[A] ≫ d.copair ≫ p = η[B]) : + baseChangeAct φ M ≫ + splitComplProj A B φ v w d hv hw p hp hδ = + (B ◁ splitComplProj A B φ v w d hv hw p hp hδ) ≫ + splitComplAct A B φ v w d hv hw := by + refine (cancel_mono (kernel.ι + (splitIdem A B φ v w d hv hw))).mp ?_ + have hL : (baseChangeAct φ M ≫ + splitComplProj A B φ v w d hv hw p hp hδ) ≫ + kernel.ι (splitIdem A B φ v w d hv hw) = + baseChangeAct φ M - + (B ◁ splitIdem A B φ v w d hv hw) ≫ + baseChangeAct φ M := by + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (splitComplProj_ι A B φ v w d hv hw p hp hδ)) ?_ + rw [Preadditive.comp_sub, Category.comp_id, + baseChangeAct_splitIdem A B φ v w d hv hw] + have hR : ((B ◁ splitComplProj A B φ v w d hv hw p hp hδ) ≫ + splitComplAct A B φ v w d hv hw) ≫ + kernel.ι (splitIdem A B φ v w d hv hw) = + baseChangeAct φ M - + (B ◁ splitIdem A B φ v w d hv hw) ≫ + baseChangeAct φ M := by + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (splitComplAct_ι A B φ v w d hv hw)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => B ◁ t) + (splitComplProj_ι A B φ v w d hv hw p hp hδ)) _) ?_ + rw [show B ◁ (𝟙 (baseChange φ M) - + splitIdem A B φ v w d hv hw) = + B ◁ 𝟙 (baseChange φ M) - + B ◁ splitIdem A B φ v w d hv hw from + Functor.map_sub (F := tensorLeft B)] + rw [Preadditive.sub_comp, + MonoidalCategory.whiskerLeft_id, Category.id_comp] + exact hL.trans hR.symm + +/-- Morphisms out of a tensored biproduct are determined by the +two whiskered injections. -/ +private theorem whisker_biprod_ext + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] + {P X Y Z : D} + {f g : P ⊗ (X ⊞ Y) ⟶ Z} + (h1 : (P ◁ biprod.inl) ≫ f = (P ◁ biprod.inl) ≫ g) + (h2 : (P ◁ biprod.inr) ≫ f = (P ◁ biprod.inr) ≫ g) : + f = g := by + have htot : 𝟙 (P ⊗ (X ⊞ Y)) = + (P ◁ biprod.fst) ≫ (P ◁ biprod.inl) + + (P ◁ biprod.snd) ≫ (P ◁ biprod.inr) := by + rw [← MonoidalCategory.whiskerLeft_comp, + ← MonoidalCategory.whiskerLeft_comp, + ← MonoidalPreadditive.whiskerLeft_add, biprod.total, + MonoidalCategory.whiskerLeft_id] + calc f = 𝟙 (P ⊗ (X ⊞ Y)) ≫ f := (Category.id_comp f).symm + _ = ((P ◁ biprod.fst) ≫ (P ◁ biprod.inl) + + (P ◁ biprod.snd) ≫ (P ◁ biprod.inr)) ≫ f := by + rw [← htot] + _ = (P ◁ biprod.fst) ≫ ((P ◁ biprod.inl) ≫ g) + + (P ◁ biprod.snd) ≫ ((P ◁ biprod.inr) ≫ g) := by + rw [Preadditive.add_comp] + simp only [Category.assoc] + rw [h1, h2] + _ = ((P ◁ biprod.fst) ≫ (P ◁ biprod.inl) + + (P ◁ biprod.snd) ≫ (P ◁ biprod.inr)) ≫ g := by + rw [Preadditive.add_comp] + simp only [Category.assoc] + _ = 𝟙 (P ⊗ (X ⊞ Y)) ≫ g := by rw [← htot] + _ = g := Category.id_comp g + +/-- The decomposition intertwines the actions, forward +direction. -/ +theorem baseChangeAct_splitDecompHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + [HasBinaryBiproducts D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) + (hδ : η[A] ≫ d.copair ≫ p = η[B]) : + baseChangeAct φ M ≫ + biprod.lift (splitEval A B φ v hv) + (splitComplProj A B φ v w d hv hw p hp hδ) = + (B ◁ biprod.lift (splitEval A B φ v hv) + (splitComplProj A B φ v w d hv hw p hp hδ)) ≫ + modBiprodAct B (regularMod B) + (splitComplMod A B φ v w d hv hw) := by + apply biprod.hom_ext + · refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (biprod.lift_fst _ _)) ?_ + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (modBiprodAct_fst B (regularMod B) + (splitComplMod A B φ v w d hv hw))) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => B ◁ t) + (biprod.lift_fst (splitEval A B φ v hv) + (splitComplProj A B φ v w d hv hw p hp hδ))) _) ?_ + exact (baseChangeAct_splitEval A B φ v hv).symm + · refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (biprod.lift_snd _ _)) ?_ + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (modBiprodAct_snd B (regularMod B) + (splitComplMod A B φ v w d hv hw))) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => B ◁ t) + (biprod.lift_snd (splitEval A B φ v hv) + (splitComplProj A B φ v w d hv hw p hp hδ))) _) ?_ + exact + (baseChangeAct_splitComplProj A B φ v w d hv hw + p hp hδ).symm + +/-- The decomposition intertwines the actions, inverse +direction. -/ +theorem modBiprodAct_splitDecompInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + [HasBinaryBiproducts D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + modBiprodAct B (regularMod B) + (splitComplMod A B φ v w d hv hw) ≫ + biprod.desc (splitCoeval A B φ w d hw) + (kernel.ι (splitIdem A B φ v w d hv hw)) = + (B ◁ biprod.desc (splitCoeval A B φ w d hw) + (kernel.ι (splitIdem A B φ v w d hv hw))) ≫ + baseChangeAct φ M := by + apply whisker_biprod_ext + · refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (actLeft_modBiprodInl B (regularMod B) + (splitComplMod A B φ v w d hv hw)).symm _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (biprod.inl_desc _ _)) ?_ + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => B ◁ t) + (biprod.inl_desc (splitCoeval A B φ w d hw) + (kernel.ι (splitIdem A B φ v w d hv hw)))) _) ?_ + exact (mul_splitCoeval A B φ w d hw).symm + · refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (actLeft_modBiprodInr B (regularMod B) + (splitComplMod A B φ v w d hv hw)).symm _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (biprod.inr_desc _ _)) ?_ + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => B ◁ t) + (biprod.inr_desc (splitCoeval A B φ w d hw) + (kernel.ι (splitIdem A B φ v w d hv hw)))) _) ?_ + exact (splitComplAct_ι A B φ v w d hv hw).symm + +/-- **The decomposition at the module level**: the base change +of the module is the regular module plus the complement, as +modules over the algebra. -/ +noncomputable def splitDecompMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + [HasBinaryBiproducts D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) + (hδ : η[A] ≫ d.copair ≫ p = η[B]) : + baseChangeMod φ M ≅ + modBiprod B (regularMod B) + (splitComplMod A B φ v w d hv hw) where + hom := Mod.Hom.mk' + (biprod.lift (splitEval A B φ v hv) + (splitComplProj A B φ v w d hv hw p hp hδ)) + (by + exact baseChangeAct_splitDecompHom A B φ v w d hv hw + p hp hδ) + inv := Mod.Hom.mk' + (biprod.desc (splitCoeval A B φ w d hw) + (kernel.ι (splitIdem A B φ v w d hv hw))) + (by exact modBiprodAct_splitDecompInv A B φ v w d hv hw) + hom_inv_id := by + apply Mod.Hom.ext + change biprod.lift (splitEval A B φ v hv) + (splitComplProj A B φ v w d hv hw p hp hδ) ≫ + biprod.desc (splitCoeval A B φ w d hw) + (kernel.ι (splitIdem A B φ v w d hv hw)) = + 𝟙 (baseChange φ M) + exact (splitDecomp A B φ v w d hv hw p hp hδ).hom_inv_id + inv_hom_id := by + apply Mod.Hom.ext + change biprod.desc (splitCoeval A B φ w d hw) + (kernel.ι (splitIdem A B φ v w d hv hw)) ≫ + biprod.lift (splitEval A B φ v hv) + (splitComplProj A B φ v w d hv hw p hp hδ) = + 𝟙 (B ⊞ splitCompl A B φ v w d hv hw) + exact (splitDecomp A B φ v w d hv hw p hp hδ).inv_hom_id + +end Complement + +section Retract + +/-- The kernel inclusion of the complement, as a module map. -/ +noncomputable def splitComplIncl + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + splitComplMod A B φ v w d hv hw ⟶ baseChangeMod φ M := + Mod.Hom.mk' (kernel.ι (splitIdem A B φ v w d hv hw)) (by + exact splitComplAct_ι A B φ v w d hv hw) + +/-- The projection onto the complement, as a module map. -/ +noncomputable def splitComplProjMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) + (hδ : η[A] ≫ d.copair ≫ p = η[B]) : + baseChangeMod φ M ⟶ splitComplMod A B φ v w d hv hw := + Mod.Hom.mk' (splitComplProj A B φ v w d hv hw p hp hδ) (by + exact baseChangeAct_splitComplProj A B φ v w d hv hw + p hp hδ) + +/-- **The complement is a retract of the base change**, at the +carrier. -/ +theorem splitCompl_ι_proj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] + {M : Mod D A} {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) + (hδ : η[A] ≫ d.copair ≫ p = η[B]) : + kernel.ι (splitIdem A B φ v w d hv hw) ≫ + splitComplProj A B φ v w d hv hw p hp hδ = + 𝟙 (splitCompl A B φ v w d hv hw) := by + refine (cancel_mono + (kernel.ι (splitIdem A B φ v w d hv hw))).mp ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (splitComplProj_ι A B φ v w d hv hw p hp hδ)) ?_ + rw [Preadditive.comp_sub, Category.comp_id] + have h1 : kernel.ι (splitIdem A B φ v w d hv hw) ≫ + splitIdem A B φ v w d hv hw = 0 := kernel.condition _ + refine Eq.trans (congrArg (fun t => + kernel.ι (splitIdem A B φ v w d hv hw) - t) h1) ?_ + refine Eq.trans (sub_zero _) ?_ + exact (Category.id_comp _).symm + +/-- **The complement is a retract of the base change**, as +modules. -/ +theorem splitComplIncl_proj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) + (hδ : η[A] ≫ d.copair ≫ p = η[B]) : + splitComplIncl A B φ v w d hv hw ≫ + splitComplProjMod A B φ v w d hv hw p hp hδ = + 𝟙 (splitComplMod A B φ v w d hv hw) := by + apply Mod.Hom.ext + exact splitCompl_ι_proj A B φ v w d hv hw p hp hδ + +end Retract + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitEverything.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitEverything.lean new file mode 100644 index 0000000000..e05abe6d4e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitEverything.lean @@ -0,0 +1,100 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleGenerator +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimplePoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitClosure +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfLinear +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleSplit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SmallReduction + +/-! +# One simple algebra splits the whole category + +Splitting the single object `X ⊞ Xᘁ` and passing to a simple +quotient gives an algebra that splits the tensor generator and its +dual, a direct summand being a subquotient. The split objects are +closed under sums and tensor products, so they contain every mixed +power, and over a simple algebra they are closed under subquotients +as well (`RS.exists_mix_of_isSubquotient`), so finite tensor +generation carries them to every object. The scalars of that +algebra are the complex numbers, so its Γ-algebra has a complex +point. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v + +variable {C : Type v} + +/-- **One simple algebra splits everything, and its Γ-algebra has a +complex point.** -/ +theorem exists_splitting_simple_algebra + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] [HasFiniteBiproducts C] + (ψ : ℂ ≃+* End (𝟙_ C)) + (P : SchurPackage.{v}) (P₀ : SchurPackage.{0}) + (L : OddLine (Ind C)) (X : C) + (hgen : TensorGeneratedBy C X) + (hgrow : letI := linearOfScalarUnit ψ; ModerateLengthGrowth C) + (hlen : ∀ Z : C, ∃ N : ℕ, LengthLE Z N) + : + letI := linearOfScalarUnit ψ + letI := monoidalLinearOfScalarUnitBraided ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + letI := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + ∃ (𝔹 : Ind C) (_ : MonObj 𝔹) (_ : IsCommMonObj 𝔹), + η[𝔹] ≠ 0 ∧ + (∀ I : Subobject 𝔹, IsIdeal 𝔹 I → I = ⊥ ∨ I = ⊤) ∧ + SplitsOn L 𝔹 (indOf : C ⥤ Ind C) ∧ + Nonempty (SuperPoint (gammaAlgebra (Ind C) L 𝔹)) := by + let := linearOfScalarUnit ψ + let := monoidalLinearOfScalarUnitBraided ψ + let := linearOfScalarUnit (indScalarUnit ψ) + let := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + have hu : HasScalarUnit C := hasScalarUnit_of_scalarUnit ψ + obtain ⟨lam, hkill⟩ := + forall_exists_schurKilled P hu hgrow (X ⊞ (Xᘁ)) + obtain ⟨p, q, 𝔸, 𝔹, hmonA, hcommA, hmon, hcomm, π, hne, hcp, hepi, + hhom, hsimple, ⟨e⟩⟩ := + exists_simple_generator_algebra ψ P P₀ L (X ⊞ (Xᘁ)) lam hkill hlen + let := hmonA + let := hcommA + let := hmon + let := hcomm + have := hepi + have hbig : IsSplit L 𝔹 ((indOf : C ⥤ Ind C).obj (X ⊞ (Xᘁ))) := + ⟨p, q, ⟨e⟩⟩ + have hsubB : ∀ Y Z : C, IsSubquotientOf Y Z → + IsSplit L 𝔹 ((indOf : C ⥤ Ind C).obj Z) → + IsSplit L 𝔹 ((indOf : C ⥤ Ind C).obj Y) := by + intro Y Z hsq hZ + obtain ⟨a, b, ⟨eZ⟩⟩ := hZ + have : (indOf (C := C)).Additive := indOf_additive + exact exists_mix_of_isSubquotient 𝔹 L hsimple hne + (isSubquotientOf_map (indOf : C ⥤ Ind C) hsq) eZ + have hX : IsSplit L 𝔹 ((indOf : C ⥤ Ind C).obj X) := + hsubB X (X ⊞ (Xᘁ)) + (isSubquotientOf_of_retract biprod.inl biprod.fst + (by simp)) hbig + have hXd : IsSplit L 𝔹 ((indOf : C ⥤ Ind C).obj (Xᘁ)) := + hsubB (Xᘁ) (X ⊞ (Xᘁ)) + (isSubquotientOf_of_retract biprod.inr biprod.snd + (by simp)) hbig + refine ⟨𝔹, hmon, hcomm, hne, hsimple, + splitsOn_of_generator L 𝔹 X hX hXd hsubB hgen, + ⟨superPointOfSimple hu ?_ hlen L π hcp hne hsimple⟩⟩ + exact indOfLinear_of_scalarUnit ψ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExact.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExact.lean new file mode 100644 index 0000000000..40977f4a13 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExact.lean @@ -0,0 +1,58 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreAdditive +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModAbelian + +/-! +# Split short exact sequences and additive functors + +A short exact sequence whose epimorphism admits a section is split, +and a split sequence stays split — hence short exact — under any +additive functor. This is the mechanism by which the fibre functor +of `RS.Classical.Deligne.FibreAdditive` is seen to carry short exact +sequences to short exact sequences: base change produces a section +of the epimorphism, and the splitting is then transported by +additivity alone, with no exactness hypothesis on the functor. + +Both steps are available in Mathlib. The splitting induced by a +section is `CategoryTheory.ShortComplex.Splitting.ofExactOfSection`, +which needs only a balanced preadditive category, and the transport +is `CategoryTheory.ShortComplex.Splitting.map` followed by +`CategoryTheory.ShortComplex.Splitting.shortExact`. The three +two results below are the packaged forms used in this development, +naming the general statements at the shape in which they are +consumed. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Limits + +universe v u v' u' + +section General + +variable {C : Type u} + +/-- **A section of the epimorphism splits a short exact sequence.** +The retraction is the factorization of `𝟙 - g ≫ s` through the +kernel `f`. -/ +noncomputable def ShortComplex.ShortExact.splittingOfSplitEpi + [Category.{v} C] [Abelian C] + {S : CategoryTheory.ShortComplex C} (hS : S.ShortExact) + (s : S.X₃ ⟶ S.X₂) (hs : s ≫ S.g = 𝟙 S.X₃) : + S.Splitting := + CategoryTheory.ShortComplex.Splitting.ofExactOfSection S hS.exact s + hs hS.mono_f + +end General + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtract.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtract.lean new file mode 100644 index 0000000000..5272f570d7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtract.lean @@ -0,0 +1,346 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowCopairing + +/-! +# Factor extraction from splitting data + +The dévissage engine of the trichotomy: from splitting data over +a duality datum, the unit of the splitting algebra is a direct +factor of the base change of the module. The insertion extends +`B`-linearly to an evaluation on the base change; the copairing +against the dual insertion supplies a coevaluation; the section +identity of the data makes the pair a retract. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +section Eval + +/-- **The descent condition of the evaluation**: an insertion +that is linear over the base through `φ` coequalizes the two +legs of the base-change tensor. -/ +theorem splitEvalCond + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] {M : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (v : M.X ⟶ B) + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) : + modTensorLegM A (restrictRegular φ) M ≫ + (B ◁ v) ≫ μ[B] = + modTensorLegN A (restrictRegular φ) M ≫ + (B ◁ v) ≫ μ[B] := by + have h1 : modTensorLegM A (restrictRegular φ) M = + (B ◁ φ ≫ μ[B]) ▷ M.X := + congrArg (· ▷ M.X) (actRight_restrictRegular φ) + have h2 : modTensorLegN A (restrictRegular φ) M = + (α_ B A M.X).hom ≫ (B ◁ actLeft A M.X) := rfl + rw [h1, h2, Category.assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, hv] + simp only [MonoidalCategory.whiskerLeft_comp, + Category.assoc, MonoidalCategory.comp_whiskerRight] + rw [MonObj.mul_assoc_flip] + simp only [← Category.assoc] + congr 1 + simp only [Category.assoc] + rw [← whisker_exchange] + rw [← whisker_exchange_assoc] + rw [← associator_naturality_right_assoc] + rw [← associator_naturality_middle_assoc] + simp + +/-- **The evaluation of the insertion on the base change**: the +`B`-linear extension of a base-linear insertion. -/ +noncomputable def splitEval + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] {M : Mod D A} (B : D) [MonObj B] + [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] (v : M.X ⟶ B) + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) : + baseChange φ M ⟶ B := + modTensorDesc A (restrictRegular φ) M ((B ◁ v) ≫ μ[B]) + (splitEvalCond A B φ v hv) + +/-- Defining equation of the evaluation. -/ +@[reassoc] +theorem modTensorπ_splitEval + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] {M : Mod D A} (B : D) [MonObj B] + [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] (v : M.X ⟶ B) + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) : + modTensorπ A (restrictRegular φ) M ≫ + splitEval A B φ v hv = (B ◁ v) ≫ μ[B] := + modTensorπ_desc A (restrictRegular φ) M _ _ + +end Eval + +section Coeval + +/-- A base-linear insertion, bundled as a module morphism into +the restricted regular module. -/ +noncomputable def insHom + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] {M' : Mod D A} + (B : D) [MonObj B] (φ : A ⟶ B) [IsMonHom φ] (w : M'.X ⟶ B) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + M' ⟶ restrictRegular φ := + Mod.Hom.mk' w (by exact hw) + +@[simp] +theorem insHom_hom + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] {M' : Mod D A} + (B : D) [MonObj B] (φ : A ⟶ B) [IsMonHom φ] (w : M'.X ⟶ B) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + (insHom A B φ w hw).hom = w := rfl + +/-- **The coevaluation core**: swap the pair and push the dual +factor into the algebra — the module tensor product lands in the +base change. -/ +noncomputable def splitCoevalCore + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] {M : Mod D A} {M' : Mod D A} + (B : D) [MonObj B] (φ : A ⟶ B) [IsMonHom φ] (w : M'.X ⟶ B) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + modTensor A M M' ⟶ baseChange φ M := + modTensorSwap A M M' ≫ + modTensorMap A (insHom A B φ w hw) (𝟙 M) + +/-- Defining equation of the coevaluation core. -/ +@[reassoc] +theorem modTensorπ_splitCoevalCore + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] {M : Mod D A} {M' : Mod D A} + (B : D) [MonObj B] (φ : A ⟶ B) [IsMonHom φ] (w : M'.X ⟶ B) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + modTensorπ A M M' ≫ splitCoevalCore A B φ w hw = + (β_ M.X M'.X).hom ≫ (w ▷ M.X) ≫ + modTensorπ A (restrictRegular φ) M := by + rw [splitCoevalCore] + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (modTensorπ_swap A M M') _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine whisker_eq _ ?_ + refine Eq.trans + (modTensorπ_map A (insHom A B φ w hw) (𝟙 M)) ?_ + exact eq_whisker (by simp) _ + +end Coeval + +section Retract + +/-- **Evaluating the coevaluation core multiplies the two +insertions**: the core composite is any descended pair +product. -/ +theorem splitCoevalCore_splitEval + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] {M : Mod D A} {M' : Mod D A} + (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + (v : M.X ⟶ B) (w : M'.X ⟶ B) + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) : + splitCoevalCore A B φ w hw ≫ splitEval A B φ v hv = + p := by + apply modTensor_hom_ext + rw [hp, modTensorπ_splitCoevalCore_assoc A B φ w hw] + have h1 : ((β_ M.X M'.X).hom ≫ (w ▷ M.X) ≫ + modTensorπ A (restrictRegular φ) M) ≫ + splitEval A B φ v hv = + (β_ M.X M'.X).hom ≫ (w ▷ M.X) ≫ (B ◁ v) ≫ μ[B] := by + refine Eq.trans (Category.assoc _ _ _) ?_ + refine whisker_eq _ ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (modTensorπ_splitEval A B φ v hv) + have h2 : (β_ M.X M'.X).hom ≫ (w ▷ M.X) ≫ + (B ◁ v) ≫ μ[B] = (v ⊗ₘ w) ≫ μ[B] := by + rw [← MonoidalCategory.tensorHom_def_assoc, + ← BraidedCategory.braiding_naturality_assoc, + IsCommMonObj.mul_comm] + exact h1.trans h2 + +/-- **The evaluation is linear over the algebra.** -/ +@[reassoc] +theorem baseChangeAct_splitEval + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] {M : Mod D A} (B : D) [MonObj B] + [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) : + baseChangeAct φ M ≫ splitEval A B φ v hv = + (B ◁ splitEval A B φ v hv) ≫ μ[B] := by + apply modTensor_whisker_hom_ext A (restrictRegular φ) M B + have h1 : B ◁ modTensorπ A (restrictRegular φ) M ≫ + baseChangeAct φ M ≫ splitEval A B φ v hv = + ((α_ B B M.X).inv ≫ μ[B] ▷ M.X) ≫ + (B ◁ v) ≫ μ[B] := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (whiskerLeft_modTensorπ_baseChangeAct φ M) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (modTensorπ_splitEval A B φ v hv) + have h2 : B ◁ modTensorπ A (restrictRegular φ) M ≫ + B ◁ splitEval A B φ v hv ≫ μ[B] = + (B ◁ ((B ◁ v) ≫ μ[B])) ≫ μ[B] := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + exact eq_whisker (congrArg (fun t => B ◁ t) + (modTensorπ_splitEval A B φ v hv)) _ + have h3 : ((α_ B B M.X).inv ≫ μ[B] ▷ M.X) ≫ + (B ◁ v) ≫ μ[B] = + (B ◁ ((B ◁ v) ≫ μ[B])) ≫ μ[B] := by + simp only [MonoidalCategory.whiskerLeft_comp, + Category.assoc] + rw [← whisker_exchange_assoc, MonObj.mul_assoc, + associator_naturality_right_assoc] + simp + exact h1.trans (h3.trans h2.symm) + +/-- **The coevaluation**: the copair element with its dual +factor pushed into the algebra, multiplied against the +algebra. -/ +noncomputable def splitCoeval + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} + {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (w : M'.X ⟶ B) (d : ModDualityDatum A M M') + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + B ⟶ baseChange φ M := + (ρ_ B).inv ≫ + (B ◁ (η[A] ≫ d.copair ≫ + splitCoevalCore A B φ w hw)) ≫ + baseChangeAct φ M + +/-- **The coevaluation is linear over the algebra.** -/ +@[reassoc] +theorem mul_splitCoeval + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} + {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (w : M'.X ⟶ B) (d : ModDualityDatum A M M') + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + μ[B] ≫ splitCoeval A B φ w d hw = + (B ◁ splitCoeval A B φ w d hw) ≫ + baseChangeAct φ M := by + let := baseChangeModObj φ M + have hact : (μ[B] ▷ baseChange φ M) ≫ baseChangeAct φ M = + (α_ B B (baseChange φ M)).hom ≫ + (B ◁ baseChangeAct φ M) ≫ baseChangeAct φ M := + mul_actLeft B (baseChange φ M) + rw [splitCoeval] + rw [rightUnitor_inv_naturality_assoc] + rw [← whisker_exchange_assoc] + rw [hact] + simp only [MonoidalCategory.whiskerLeft_comp, + Category.assoc] + simp only [associator_naturality_right_assoc] + rw [reassoc_of% (show (ρ_ (B ⊗ B)).inv ≫ + (α_ B B (𝟙_ D)).hom = B ◁ (ρ_ B).inv from by monoidal)] + +/-- **The retract identity** (the dévissage step of the +trichotomy): over splitting data, the coevaluation followed by +the evaluation is the identity — the algebra is a direct factor +of the base change of the module. -/ +theorem splitCoeval_splitEval + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} + {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) + (hδ : η[A] ≫ d.copair ≫ p = η[B]) : + splitCoeval A B φ w d hw ≫ splitEval A B φ v hv = + 𝟙 B := by + have hx : (η[A] ≫ d.copair ≫ + splitCoevalCore A B φ w hw) ≫ + splitEval A B φ v hv = η[B] := by + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (splitCoevalCore_splitEval A B φ v w hv hw p hp))) ?_ + exact hδ + change ((ρ_ B).inv ≫ + (B ◁ (η[A] ≫ d.copair ≫ + splitCoevalCore A B φ w hw)) ≫ + baseChangeAct φ M) ≫ splitEval A B φ v hv = 𝟙 B + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (baseChangeAct_splitEval A B φ v hv))) ?_ + refine Eq.trans + (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _)) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + (congrArg (fun t => B ◁ t) hx) _)) ?_ + refine Eq.trans (whisker_eq _ (MonObj.mul_one B)) ?_ + exact (ρ_ B).inv_hom_id + +/-- The evaluation, as a module morphism onto the regular +module. -/ +noncomputable def splitEvalMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] {M : Mod D A} (B : D) [MonObj B] + [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) : + baseChangeMod φ M ⟶ regularMod B := + Mod.Hom.mk' (splitEval A B φ v hv) + (by exact baseChangeAct_splitEval A B φ v hv) + +/-- The coevaluation, as a module morphism from the regular +module. -/ +noncomputable def splitCoevalMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} + {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (w : M'.X ⟶ B) (d : ModDualityDatum A M M') + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + regularMod B ⟶ baseChangeMod φ M := + Mod.Hom.mk' (splitCoeval A B φ w d hw) + (by exact mul_splitCoeval A B φ w d hw) + +end Retract + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtractDual.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtractDual.lean new file mode 100644 index 0000000000..042a33a3c5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtractDual.lean @@ -0,0 +1,883 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitComplement + +/-! +# Factor extraction on the dual module + +The mirror of the splitting extraction: over the same splitting +data, the unit of the splitting algebra is a direct factor of +the base change of the *dual* module. The dual insertion +extends `B`-linearly to an evaluation on the base change of the +dual; the copairing, with the primal factor pushed into the +algebra, supplies a coevaluation; the section identity again +makes the pair a retract, and the kernel of the induced linear +idempotent is the complement. No braiding is needed anywhere: +the copairing already presents the primal factor on the left. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The dual coevaluation core**: push the primal factor into +the algebra — the module tensor product lands in the base change +of the dual module. No swap is needed: the primal factor is +already on the left. -/ +noncomputable def splitCoevalCoreDual + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] {M : Mod D A} {M' : Mod D A} + (B : D) [MonObj B] (φ : A ⟶ B) [IsMonHom φ] (v : M.X ⟶ B) + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) : + modTensor A M M' ⟶ baseChange φ M' := + modTensorMap A (insHom A B φ v hv) (𝟙 M') + +/-- Defining equation of the dual coevaluation core. -/ +@[reassoc] +theorem modTensorπ_splitCoevalCoreDual + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] {M : Mod D A} {M' : Mod D A} + (B : D) [MonObj B] (φ : A ⟶ B) [IsMonHom φ] (v : M.X ⟶ B) + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) : + modTensorπ A M M' ≫ splitCoevalCoreDual A B φ v hv = + (v ▷ M'.X) ≫ modTensorπ A (restrictRegular φ) M' := by + rw [splitCoevalCoreDual] + refine Eq.trans + (modTensorπ_map A (insHom A B φ v hv) (𝟙 M')) ?_ + exact eq_whisker (by simp) _ + +/-- **Evaluating the dual coevaluation core multiplies the two +insertions**: the core composite is any descended pair product. +Unlike the primal statement, no braiding step is needed. -/ +theorem splitCoevalCoreDual_splitEval + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] {M : Mod D A} {M' : Mod D A} + (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + (v : M.X ⟶ B) (w : M'.X ⟶ B) + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) : + splitCoevalCoreDual A B φ v hv ≫ splitEval A B φ w hw = + p := by + apply modTensor_hom_ext + rw [hp, modTensorπ_splitCoevalCoreDual_assoc A B φ v hv] + have h1 : (v ▷ M'.X) ≫ + modTensorπ A (restrictRegular φ) M' ≫ + splitEval A B φ w hw = + (v ▷ M'.X) ≫ (B ◁ w) ≫ μ[B] := + whisker_eq _ (modTensorπ_splitEval A B φ w hw) + have h2 : (v ▷ M'.X) ≫ (B ◁ w) ≫ μ[B] = + (v ⊗ₘ w) ≫ μ[B] := by + rw [← MonoidalCategory.tensorHom_def_assoc] + exact (Category.assoc _ _ _).trans (h1.trans h2) + +/-- **The dual coevaluation**: the copair element with its +primal factor pushed into the algebra, multiplied against the +algebra. -/ +noncomputable def splitCoevalDual + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} + {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (d : ModDualityDatum A M M') + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) : + B ⟶ baseChange φ M' := + (ρ_ B).inv ≫ + (B ◁ (η[A] ≫ d.copair ≫ + splitCoevalCoreDual A B φ v hv)) ≫ + baseChangeAct φ M' + +/-- **The dual coevaluation is linear over the algebra.** -/ +@[reassoc] +theorem mul_splitCoevalDual + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} + {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (d : ModDualityDatum A M M') + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) : + μ[B] ≫ splitCoevalDual A B φ v d hv = + (B ◁ splitCoevalDual A B φ v d hv) ≫ + baseChangeAct φ M' := by + let := baseChangeModObj φ M' + have hact : (μ[B] ▷ baseChange φ M') ≫ baseChangeAct φ M' = + (α_ B B (baseChange φ M')).hom ≫ + (B ◁ baseChangeAct φ M') ≫ baseChangeAct φ M' := + mul_actLeft B (baseChange φ M') + rw [splitCoevalDual] + rw [rightUnitor_inv_naturality_assoc] + rw [← whisker_exchange_assoc] + rw [hact] + simp only [MonoidalCategory.whiskerLeft_comp, + Category.assoc] + simp only [associator_naturality_right_assoc] + rw [reassoc_of% (show (ρ_ (B ⊗ B)).inv ≫ + (α_ B B (𝟙_ D)).hom = B ◁ (ρ_ B).inv from by monoidal)] + +/-- **The dual retract identity**: over splitting data, the dual +coevaluation followed by the dual evaluation is the identity — +the algebra is a direct factor of the base change of the dual +module. -/ +theorem splitCoevalDual_splitEval + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} + {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) + (hδ : η[A] ≫ d.copair ≫ p = η[B]) : + splitCoevalDual A B φ v d hv ≫ splitEval A B φ w hw = + 𝟙 B := by + have hx : (η[A] ≫ d.copair ≫ + splitCoevalCoreDual A B φ v hv) ≫ + splitEval A B φ w hw = η[B] := by + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (splitCoevalCoreDual_splitEval A B φ v w hv hw + p hp))) ?_ + exact hδ + change ((ρ_ B).inv ≫ + (B ◁ (η[A] ≫ d.copair ≫ + splitCoevalCoreDual A B φ v hv)) ≫ + baseChangeAct φ M') ≫ splitEval A B φ w hw = 𝟙 B + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (baseChangeAct_splitEval A B φ w hw))) ?_ + refine Eq.trans + (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _)) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + (congrArg (fun t => B ◁ t) hx) _)) ?_ + refine Eq.trans (whisker_eq _ (MonObj.mul_one B)) ?_ + exact (ρ_ B).inv_hom_id + +/-- The dual coevaluation, as a module morphism from the regular +module. -/ +noncomputable def splitCoevalDualMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} + {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (d : ModDualityDatum A M M') + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) : + regularMod B ⟶ baseChangeMod φ M' := + Mod.Hom.mk' (splitCoevalDual A B φ v d hv) + (by exact mul_splitCoevalDual A B φ v d hv) + +/-- **The dual split idempotent** on the base change of the dual +module: evaluate, then coevaluate. -/ +noncomputable def splitIdemDual + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} + {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + baseChange φ M' ⟶ baseChange φ M' := + splitEval A B φ w hw ≫ splitCoevalDual A B φ v d hv + +/-- The dual split idempotent is idempotent. -/ +theorem splitIdemDual_idem + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} + {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) + (hδ : η[A] ≫ d.copair ≫ p = η[B]) : + splitIdemDual A B φ v w d hv hw ≫ + splitIdemDual A B φ v w d hv hw = + splitIdemDual A B φ v w d hv hw := by + rw [splitIdemDual, Category.assoc, + ← Category.assoc (splitCoevalDual A B φ v d hv), + splitCoevalDual_splitEval A B φ v w d hv hw p hp hδ, + Category.id_comp] + +/-- The dual split idempotent is linear over the algebra. -/ +theorem baseChangeAct_splitIdemDual + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} + {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + baseChangeAct φ M' ≫ splitIdemDual A B φ v w d hv hw = + (B ◁ splitIdemDual A B φ v w d hv hw) ≫ + baseChangeAct φ M' := by + rw [splitIdemDual, ← Category.assoc, + baseChangeAct_splitEval A B φ w hw, Category.assoc, + mul_splitCoevalDual A B φ v d hv, + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + +section Complement + +/-- **The dual complement carrier**: the kernel of the dual +split idempotent. -/ +noncomputable def splitComplDual + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] + {M : Mod D A} {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : D := + kernel (splitIdemDual A B φ v w d hv hw) + +/-- The action of the algebra descends to the dual +complement. -/ +noncomputable def splitComplActDual + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + B ⊗ splitComplDual A B φ v w d hv hw ⟶ + splitComplDual A B φ v w d hv hw := + kernel.lift _ + ((B ◁ kernel.ι (splitIdemDual A B φ v w d hv hw)) ≫ + baseChangeAct φ M') (by + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (baseChangeAct_splitIdemDual A B φ v w d hv hw)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => B ◁ t) + (kernel.condition + (splitIdemDual A B φ v w d hv hw))) _) ?_ + rw [MonoidalPreadditive.whiskerLeft_zero, + Limits.zero_comp] + rfl) + +/-- Defining equation of the dual complement action. -/ +@[reassoc] +theorem splitComplActDual_ι + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + splitComplActDual A B φ v w d hv hw ≫ + kernel.ι (splitIdemDual A B φ v w d hv hw) = + (B ◁ kernel.ι (splitIdemDual A B φ v w d hv hw)) ≫ + baseChangeAct φ M' := + kernel.lift_ι _ _ _ + +/-- The unit law of the dual complement action. -/ +theorem splitComplActDual_one + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + (η[B] ▷ splitComplDual A B φ v w d hv hw) ≫ + splitComplActDual A B φ v w d hv hw = + (λ_ (splitComplDual A B φ v w d hv hw)).hom := by + let := baseChangeModObj φ M' + have hι : ((η[B] ▷ splitComplDual A B φ v w d hv hw) ≫ + splitComplActDual A B φ v w d hv hw) ≫ + kernel.ι (splitIdemDual A B φ v w d hv hw) = + (λ_ (splitComplDual A B φ v w d hv hw)).hom ≫ + kernel.ι (splitIdemDual A B φ v w d hv hw) := by + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (splitComplActDual_ι A B φ v w d hv hw)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (whisker_exchange η[B] (kernel.ι + (splitIdemDual A B φ v w d hv hw))).symm _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (one_actLeft B (baseChange φ M'))) ?_ + exact leftUnitor_naturality _ + exact (cancel_mono + (kernel.ι (splitIdemDual A B φ v w d hv hw))).mp hι + +/-- The multiplication law of the dual complement action. -/ +theorem splitComplActDual_mul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + (μ[B] ▷ splitComplDual A B φ v w d hv hw) ≫ + splitComplActDual A B φ v w d hv hw = + (α_ B B (splitComplDual A B φ v w d hv hw)).hom ≫ + (B ◁ splitComplActDual A B φ v w d hv hw) ≫ + splitComplActDual A B φ v w d hv hw := by + let := baseChangeModObj φ M' + have hι : ((μ[B] ▷ splitComplDual A B φ v w d hv hw) ≫ + splitComplActDual A B φ v w d hv hw) ≫ + kernel.ι (splitIdemDual A B φ v w d hv hw) = + ((α_ B B (splitComplDual A B φ v w d hv hw)).hom ≫ + (B ◁ splitComplActDual A B φ v w d hv hw) ≫ + splitComplActDual A B φ v w d hv hw) ≫ + kernel.ι (splitIdemDual A B φ v w d hv hw) := by + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (splitComplActDual_ι A B φ v w d hv hw)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (whisker_exchange μ[B] (kernel.ι + (splitIdemDual A B φ v w d hv hw))).symm _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (mul_actLeft B (baseChange φ M'))) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (associator_naturality_right B B (kernel.ι + (splitIdemDual A B φ v w d hv hw))) _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine whisker_eq _ ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (splitComplActDual_ι A B φ v w d hv hw)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => B ◁ t) + (splitComplActDual_ι A B φ v w d hv hw)) _) ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _) _) ?_ + exact Category.assoc _ _ _ + exact (cancel_mono + (kernel.ι (splitIdemDual A B φ v w d hv hw))).mp hι + +/-- The dual complement, as a module over the algebra. -/ +@[implicit_reducible] +noncomputable def splitComplModObjDual + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + ModObj B (splitComplDual A B φ v w d hv hw) where + smul := splitComplActDual A B φ v w d hv hw + one_smul := splitComplActDual_one A B φ v w d hv hw + mul_smul := splitComplActDual_mul A B φ v w d hv hw + +/-- The dual complement, bundled. -/ +noncomputable def splitComplModDual + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : Mod D B := + letI := splitComplModObjDual A B φ v w d hv hw + ⟨splitComplDual A B φ v w d hv hw⟩ + +/-- The projection onto the dual complement: the complementary +idempotent, corestricted to the kernel. -/ +noncomputable def splitComplProjDual + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] + {M : Mod D A} {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) + (hδ : η[A] ≫ d.copair ≫ p = η[B]) : + baseChange φ M' ⟶ splitComplDual A B φ v w d hv hw := + kernel.lift _ (𝟙 (baseChange φ M') - + splitIdemDual A B φ v w d hv hw) (by + rw [Preadditive.sub_comp, Category.id_comp, + splitIdemDual_idem A B φ v w d hv hw p hp hδ, + sub_self]) + +/-- Defining equation of the dual projection. -/ +@[reassoc] +theorem splitComplProjDual_ι + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] + {M : Mod D A} {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) + (hδ : η[A] ≫ d.copair ≫ p = η[B]) : + splitComplProjDual A B φ v w d hv hw p hp hδ ≫ + kernel.ι (splitIdemDual A B φ v w d hv hw) = + 𝟙 (baseChange φ M') - + splitIdemDual A B φ v w d hv hw := + kernel.lift_ι _ _ _ + +/-- **The decomposition of the dual base change**, carrier +level: the algebra summand against the dual complement. -/ +noncomputable def splitDecompDual + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] + {M : Mod D A} {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + [HasBinaryBiproducts D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) + (hδ : η[A] ≫ d.copair ≫ p = η[B]) : + baseChange φ M' ≅ + B ⊞ splitComplDual A B φ v w d hv hw where + hom := biprod.lift (splitEval A B φ w hw) + (splitComplProjDual A B φ v w d hv hw p hp hδ) + inv := biprod.desc (splitCoevalDual A B φ v d hv) + (kernel.ι (splitIdemDual A B φ v w d hv hw)) + hom_inv_id := by + erw [biprod.lift_desc, + splitComplProjDual_ι A B φ v w d hv hw p hp hδ] + rw [show splitEval A B φ w hw ≫ + splitCoevalDual A B φ v d hv = + splitIdemDual A B φ v w d hv hw from rfl] + rw [add_sub_cancel] + inv_hom_id := by + apply biprod.hom_ext' + · erw [biprod.inl_desc_assoc, Category.comp_id] + apply biprod.hom_ext + · rw [Category.assoc, biprod.lift_fst, biprod.inl_fst, + splitCoevalDual_splitEval A B φ v w d hv hw p hp hδ] + · rw [Category.assoc, biprod.lift_snd, biprod.inl_snd] + refine (cancel_mono (kernel.ι + (splitIdemDual A B φ v w d hv hw))).mp ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (splitComplProjDual_ι A B φ v w d hv hw + p hp hδ)) ?_ + rw [Preadditive.comp_sub, Category.comp_id] + refine Eq.trans ?_ (Limits.zero_comp (f := kernel.ι + (splitIdemDual A B φ v w d hv hw))).symm + rw [show splitCoevalDual A B φ v d hv ≫ + splitIdemDual A B φ v w d hv hw = + (splitCoevalDual A B φ v d hv ≫ + splitEval A B φ w hw) ≫ + splitCoevalDual A B φ v d hv from + (Category.assoc _ _ _).symm] + rw [splitCoevalDual_splitEval A B φ v w d hv hw + p hp hδ, + Category.id_comp, sub_self] + · erw [biprod.inr_desc_assoc, Category.comp_id] + apply biprod.hom_ext + · erw [Category.assoc, biprod.lift_fst, biprod.inr_fst] + have : IsSplitMono (splitCoevalDual A B φ v d hv) := + IsSplitMono.mk' ⟨splitEval A B φ w hw, + splitCoevalDual_splitEval A B φ v w d hv hw + p hp hδ⟩ + refine (cancel_mono + (splitCoevalDual A B φ v d hv)).mp ?_ + erw [Limits.zero_comp, Category.assoc] + exact kernel.condition _ + · erw [Category.assoc, biprod.lift_snd, biprod.inr_snd] + refine (cancel_mono (kernel.ι + (splitIdemDual A B φ v w d hv hw))).mp ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (splitComplProjDual_ι A B φ v w d hv hw + p hp hδ)) ?_ + erw [Preadditive.comp_sub, Category.comp_id] + have h1 : kernel.ι (splitIdemDual A B φ v w d hv hw) ≫ + splitIdemDual A B φ v w d hv hw = 0 := + kernel.condition _ + refine Eq.trans (congrArg (fun t => + kernel.ι (splitIdemDual A B φ v w d hv hw) - t) + h1) ?_ + refine Eq.trans (sub_zero _) ?_ + exact (Category.id_comp _).symm + +/-- The dual projection is linear over the algebra. -/ +@[reassoc] +theorem baseChangeAct_splitComplProjDual + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) + (hδ : η[A] ≫ d.copair ≫ p = η[B]) : + baseChangeAct φ M' ≫ + splitComplProjDual A B φ v w d hv hw p hp hδ = + (B ◁ splitComplProjDual A B φ v w d hv hw p hp hδ) ≫ + splitComplActDual A B φ v w d hv hw := by + refine (cancel_mono (kernel.ι + (splitIdemDual A B φ v w d hv hw))).mp ?_ + have hL : (baseChangeAct φ M' ≫ + splitComplProjDual A B φ v w d hv hw p hp hδ) ≫ + kernel.ι (splitIdemDual A B φ v w d hv hw) = + baseChangeAct φ M' - + (B ◁ splitIdemDual A B φ v w d hv hw) ≫ + baseChangeAct φ M' := by + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (splitComplProjDual_ι A B φ v w d hv hw p hp hδ)) ?_ + rw [Preadditive.comp_sub, Category.comp_id, + baseChangeAct_splitIdemDual A B φ v w d hv hw] + have hR : ((B ◁ + splitComplProjDual A B φ v w d hv hw p hp hδ) ≫ + splitComplActDual A B φ v w d hv hw) ≫ + kernel.ι (splitIdemDual A B φ v w d hv hw) = + baseChangeAct φ M' - + (B ◁ splitIdemDual A B φ v w d hv hw) ≫ + baseChangeAct φ M' := by + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (splitComplActDual_ι A B φ v w d hv hw)) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => B ◁ t) + (splitComplProjDual_ι A B φ v w d hv hw + p hp hδ)) _) ?_ + rw [show B ◁ (𝟙 (baseChange φ M') - + splitIdemDual A B φ v w d hv hw) = + B ◁ 𝟙 (baseChange φ M') - + B ◁ splitIdemDual A B φ v w d hv hw from + Functor.map_sub (F := tensorLeft B)] + rw [Preadditive.sub_comp, + MonoidalCategory.whiskerLeft_id, Category.id_comp] + exact hL.trans hR.symm + +/-- Morphisms out of a tensored biproduct are determined by the +two whiskered injections. -/ +private theorem whisker_biprod_ext + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] + {P X Y Z : D} + {f g : P ⊗ (X ⊞ Y) ⟶ Z} + (h1 : (P ◁ biprod.inl) ≫ f = (P ◁ biprod.inl) ≫ g) + (h2 : (P ◁ biprod.inr) ≫ f = (P ◁ biprod.inr) ≫ g) : + f = g := by + have htot : 𝟙 (P ⊗ (X ⊞ Y)) = + (P ◁ biprod.fst) ≫ (P ◁ biprod.inl) + + (P ◁ biprod.snd) ≫ (P ◁ biprod.inr) := by + rw [← MonoidalCategory.whiskerLeft_comp, + ← MonoidalCategory.whiskerLeft_comp, + ← MonoidalPreadditive.whiskerLeft_add, biprod.total, + MonoidalCategory.whiskerLeft_id] + calc f = 𝟙 (P ⊗ (X ⊞ Y)) ≫ f := (Category.id_comp f).symm + _ = ((P ◁ biprod.fst) ≫ (P ◁ biprod.inl) + + (P ◁ biprod.snd) ≫ (P ◁ biprod.inr)) ≫ f := by + rw [← htot] + _ = (P ◁ biprod.fst) ≫ ((P ◁ biprod.inl) ≫ g) + + (P ◁ biprod.snd) ≫ ((P ◁ biprod.inr) ≫ g) := by + rw [Preadditive.add_comp] + simp only [Category.assoc] + rw [h1, h2] + _ = ((P ◁ biprod.fst) ≫ (P ◁ biprod.inl) + + (P ◁ biprod.snd) ≫ (P ◁ biprod.inr)) ≫ g := by + rw [Preadditive.add_comp] + simp only [Category.assoc] + _ = 𝟙 (P ⊗ (X ⊞ Y)) ≫ g := by rw [← htot] + _ = g := Category.id_comp g + +/-- The dual decomposition intertwines the actions, forward +direction. -/ +theorem baseChangeAct_splitDecompDualHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + [HasBinaryBiproducts D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) + (hδ : η[A] ≫ d.copair ≫ p = η[B]) : + baseChangeAct φ M' ≫ + biprod.lift (splitEval A B φ w hw) + (splitComplProjDual A B φ v w d hv hw p hp hδ) = + (B ◁ biprod.lift (splitEval A B φ w hw) + (splitComplProjDual A B φ v w d hv hw p hp hδ)) ≫ + modBiprodAct B (regularMod B) + (splitComplModDual A B φ v w d hv hw) := by + apply biprod.hom_ext + · refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (biprod.lift_fst _ _)) ?_ + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (modBiprodAct_fst B (regularMod B) + (splitComplModDual A B φ v w d hv hw))) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => B ◁ t) + (biprod.lift_fst (splitEval A B φ w hw) + (splitComplProjDual A B φ v w d hv hw + p hp hδ))) _) ?_ + exact (baseChangeAct_splitEval A B φ w hw).symm + · refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (biprod.lift_snd _ _)) ?_ + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (modBiprodAct_snd B (regularMod B) + (splitComplModDual A B φ v w d hv hw))) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => B ◁ t) + (biprod.lift_snd (splitEval A B φ w hw) + (splitComplProjDual A B φ v w d hv hw + p hp hδ))) _) ?_ + exact + (baseChangeAct_splitComplProjDual A B φ v w d hv hw + p hp hδ).symm + +/-- The dual decomposition intertwines the actions, inverse +direction. -/ +theorem modBiprodAct_splitDecompDualInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + [HasBinaryBiproducts D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + modBiprodAct B (regularMod B) + (splitComplModDual A B φ v w d hv hw) ≫ + biprod.desc (splitCoevalDual A B φ v d hv) + (kernel.ι (splitIdemDual A B φ v w d hv hw)) = + (B ◁ biprod.desc (splitCoevalDual A B φ v d hv) + (kernel.ι (splitIdemDual A B φ v w d hv hw))) ≫ + baseChangeAct φ M' := by + apply whisker_biprod_ext + · refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (actLeft_modBiprodInl B (regularMod B) + (splitComplModDual A B φ v w d hv hw)).symm _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (biprod.inl_desc _ _)) ?_ + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => B ◁ t) + (biprod.inl_desc (splitCoevalDual A B φ v d hv) + (kernel.ι + (splitIdemDual A B φ v w d hv hw)))) _) ?_ + exact (mul_splitCoevalDual A B φ v d hv).symm + · refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (actLeft_modBiprodInr B (regularMod B) + (splitComplModDual A B φ v w d hv hw)).symm _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (biprod.inr_desc _ _)) ?_ + refine Eq.symm ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (MonoidalCategory.whiskerLeft_comp B _ _).symm _) ?_ + refine Eq.trans (eq_whisker (congrArg (fun t => B ◁ t) + (biprod.inr_desc (splitCoevalDual A B φ v d hv) + (kernel.ι + (splitIdemDual A B φ v w d hv hw)))) _) ?_ + exact (splitComplActDual_ι A B φ v w d hv hw).symm + +end Complement + +section RetractDual + +/-- The kernel inclusion of the dual complement, as a module +map. -/ +noncomputable def splitComplInclDual + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) : + splitComplModDual A B φ v w d hv hw ⟶ + baseChangeMod φ M' := + Mod.Hom.mk' (kernel.ι (splitIdemDual A B φ v w d hv hw)) + (by exact splitComplActDual_ι A B φ v w d hv hw) + +/-- The projection onto the dual complement, as a module map. -/ +noncomputable def splitComplProjModDual + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) + (hδ : η[A] ≫ d.copair ≫ p = η[B]) : + baseChangeMod φ M' ⟶ + splitComplModDual A B φ v w d hv hw := + Mod.Hom.mk' + (splitComplProjDual A B φ v w d hv hw p hp hδ) (by + exact baseChangeAct_splitComplProjDual A B φ v w d + hv hw p hp hδ) + +/-- **The dual complement is a retract of the base change**, at +the carrier. -/ +theorem splitComplDual_ι_proj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] + {M : Mod D A} {M' : Mod D A} (B : D) [MonObj B] [IsCommMonObj B] + (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) + (hδ : η[A] ≫ d.copair ≫ p = η[B]) : + kernel.ι (splitIdemDual A B φ v w d hv hw) ≫ + splitComplProjDual A B φ v w d hv hw p hp hδ = + 𝟙 (splitComplDual A B φ v w d hv hw) := by + refine (cancel_mono + (kernel.ι (splitIdemDual A B φ v w d hv hw))).mp ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (splitComplProjDual_ι A B φ v w d hv hw p hp hδ)) ?_ + rw [Preadditive.comp_sub, Category.comp_id] + have h1 : kernel.ι (splitIdemDual A B φ v w d hv hw) ≫ + splitIdemDual A B φ v w d hv hw = 0 := + kernel.condition _ + refine Eq.trans (congrArg (fun t => + kernel.ι (splitIdemDual A B φ v w d hv hw) - t) h1) ?_ + refine Eq.trans (sub_zero _) ?_ + exact (Category.id_comp _).symm + +/-- **The dual complement is a retract of the base change**, as +modules. -/ +theorem splitComplInclDual_proj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] (A : D) + [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} (B : D) + [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) [IsMonHom φ] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (v : M.X ⟶ B) (w : M'.X ⟶ B) (d : ModDualityDatum A M M') [HasKernels D] + (hv : actLeft A M.X ≫ v = + (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) + (hw : actLeft A M'.X ≫ w = + (A ◁ w) ≫ (φ ▷ B) ≫ μ[B]) + (p : modTensor A M M' ⟶ B) + (hp : modTensorπ A M M' ≫ p = (v ⊗ₘ w) ≫ μ[B]) + (hδ : η[A] ≫ d.copair ≫ p = η[B]) : + splitComplInclDual A B φ v w d hv hw ≫ + splitComplProjModDual A B φ v w d hv hw p hp hδ = + 𝟙 (splitComplModDual A B φ v w d hv hw) := by + apply Mod.Hom.ext + exact splitComplDual_ι_proj A B φ v w d hv hw p hp hδ + +end RetractDual + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitMonHom.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitMonHom.lean new file mode 100644 index 0000000000..ee58b86e35 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitMonHom.lean @@ -0,0 +1,266 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAssemble + +/-! +# The base entry is multiplicative + +The carrier entry of the base algebra respects the +multiplication: multiplying in the base and entering the graded +splitting algebra carrier agrees with entering twice and +multiplying on the carrier. Together with unitality this is the +monoid-morphism property of the base entry of the splitting +data. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The base entry is multiplicative against the base +action**: multiplying in the base before entering the bottom +stage is entering on the right tensor factor and acting. -/ +theorem mul_chainBaseStage + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') : + μ[A] ≫ chainBaseStage A M M' d = + (A ◁ chainBaseStage A M M' d) ≫ + modTensorAct A (symPowMod A M'.X 0) + (symPowMod A M.X 0) := by + refine Eq.symm ?_ + have ha : (A ◁ modTensorAct A (symPowMod A M'.X 0) + (symPowMod A M.X 0)) ≫ + modTensorAct A (symPowMod A M'.X 0) (symPowMod A M.X 0) = + (α_ A A (chainStage2 A M M' 0 0)).inv ≫ + (μ[A] ▷ chainStage2 A M M' 0 0) ≫ + modTensorAct A (symPowMod A M'.X 0) + (symPowMod A M.X 0) := by + have h := modTensorAct_mul A (symPowMod A M'.X 0) + (symPowMod A M.X 0) + have h' := congrArg (fun t => (α_ A A + (modTensor A (symPowMod A M'.X 0) + (symPowMod A M.X 0))).inv ≫ t) h + exact (h'.trans (Iso.inv_hom_id_assoc _ _)).symm + have hc : (A ◁ MonoidalCategory.whiskerLeft A + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d)) ≫ + (α_ A A (chainStage2 A M M' 0 0)).inv = + (α_ A A (𝟙_ D)).inv ≫ + MonoidalCategory.whiskerLeft (A ⊗ A) + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d) := + associator_inv_naturality_right _ _ _ + have hd : MonoidalCategory.whiskerLeft (A ⊗ A) + (Y₂ := chainStage2 A M M' 0 0) (chainSeed A M M' d) ≫ + (μ[A] ▷ chainStage2 A M M' 0 0) = + (μ[A] ▷ 𝟙_ D) ≫ + MonoidalCategory.whiskerLeft A + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d) := + whisker_exchange _ _ + have he : (A ◁ (ρ_ A).inv) ≫ (α_ A A (𝟙_ D)).inv = + (ρ_ (A ⊗ A)).inv := by + monoidal + have hf : (ρ_ (A ⊗ A)).inv ≫ (μ[A] ▷ 𝟙_ D) = + μ[A] ≫ (ρ_ A).inv := + (rightUnitor_inv_naturality _).symm + have hsplit : A ◁ chainBaseStage A M M' d = + (A ◁ (ρ_ A).inv) ≫ + (A ◁ MonoidalCategory.whiskerLeft A + (Y₂ := chainStage2 A M M' 0 0) + (chainSeed A M M' d)) ≫ + (A ◁ modTensorAct A (symPowMod A M'.X 0) + (symPowMod A M.X 0)) := by + erw [chainBaseStage, MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp] + rfl + refine Eq.trans (eq_whisker hsplit + (modTensorAct A (symPowMod A M'.X 0) + (symPowMod A M.X 0))) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ ha)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker hc _)) ?_ + refine Eq.trans (whisker_eq _ (Category.assoc _ _ _)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (Category.assoc _ _ _).symm)) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (eq_whisker hd _))) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (Category.assoc _ _ _))) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker he _) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker hf _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (by rw [chainBaseStage]; rfl) + +-- The multiplication of the split algebra unfolds +-- through both stage inclusions and the duality datum. +/-- **The base entry is multiplicative**: the carrier entry of +the base algebra respects the multiplication, the multiplicative +half of the monoid-morphism property of the base entry. -/ +theorem splitOfBase_mul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') : + μ[A] ≫ splitOfBase A M M' d = + (splitOfBase A M M' d ⊗ₘ splitOfBase A M M' d) ≫ + (letI := chainBGrMonObj A M M' d; + μ[chainBGr A M M' d]) := by + change μ[A] ≫ splitOfBase A M M' d = + (splitOfBase A M M' d ⊗ₘ splitOfBase A M M' d) ≫ + chainBGrMul A M M' d + refine Eq.symm ?_ + rw [splitOfBase, + ← MonoidalCategory.tensorHom_comp_tensorHom, + ← MonoidalCategory.tensorHom_comp_tensorHom] + simp only [Category.assoc] + rw [ι_tensorHom_chainBGrMul A M M' d 0 0] + have hz : (chainBGrCompι A M M' d 0 0 ⊗ₘ + chainBGrCompι A M M' d 0 0 : + chainStage2 A M M' 0 0 ⊗ chainStage2 A M M' 0 0 ⟶ + chainBGrComponent A M M' d 0 ⊗ + chainBGrComponent A M M' d 0) ≫ + chainBGrCompMul A M M' d 0 0 = + (chainMul2 A M M' 0 0 0 0 ≫ + chainStage2Cast A M M' + (by omega : 0 + 1 + 0 = + (-((0 : ℤ) + 0)).toNat + (0 + 1)) + (by omega : 0 + 1 + 0 = + ((0 : ℤ) + 0).toNat + (0 + 1))) ≫ + chainBGrCompι A M M' d ((0 : ℤ) + 0) (0 + 1) := + ι_tensorHom_chainBGrCompMul_zero_left A M M' d 0 0 + rw [reassoc_of% hz] + rw [MonoidalCategory.tensorHom_def' (chainBaseStage A M M' d) + (chainBaseStage A M M' d)] + simp only [Category.assoc] + have e1 : chainBGrCompι A M M' d ((0 : ℤ) + 0) (0 + 1) ≫ + chainBGrι A M M' d ((0 : ℤ) + 0) = + chainStage2Cast A M M' + (by omega : (-((0 : ℤ) + 0)).toNat + (0 + 1) = + (-(0 : ℤ)).toNat + (0 + 1)) + (by omega : ((0 : ℤ) + 0).toNat + (0 + 1) = + (0 : ℤ).toNat + (0 + 1)) ≫ + chainBGrCompι A M M' d 0 (0 + 1) ≫ + chainBGrι A M M' d 0 := by + refine Eq.trans (whisker_eq _ + (eqToHom_chainBGrι A M M' d (Int.add_zero 0)).symm) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker (chainBGrCompι_eqToHom + A M M' d (Int.add_zero 0) (0 + 1)) _) ?_ + exact Category.assoc _ _ _ + have e2 : chainStage2Cast A M M' + (by omega : 0 + 1 = 0 + 1 + 0) + (by omega : 0 + 1 = 0 + 1 + 0) ≫ + chainStage2Cast A M M' + (by omega : 0 + 1 + 0 = + (-((0 : ℤ) + 0)).toNat + (0 + 1)) + (by omega : 0 + 1 + 0 = + ((0 : ℤ) + 0).toNat + (0 + 1)) ≫ + chainStage2Cast A M M' + (by omega : (-((0 : ℤ) + 0)).toNat + (0 + 1) = + (-(0 : ℤ)).toNat + (0 + 1)) + (by omega : ((0 : ℤ) + 0).toNat + (0 + 1) = + (0 : ℤ).toNat + (0 + 1)) ≫ + chainBGrCompι A M M' d 0 (0 + 1) ≫ + chainBGrι A M M' d 0 = + chainStage2Cast A M M' + (by omega : 0 + 1 = (-(0 : ℤ)).toNat + (0 + 1)) + (by omega : 0 + 1 = (0 : ℤ).toNat + (0 + 1)) ≫ + chainBGrCompι A M M' d 0 (0 + 1) ≫ + chainBGrι A M M' d 0 := by + refine Eq.trans (chainStage2Cast_trans_assoc + A M M' _ _ _ _ _) ?_ + exact chainStage2Cast_trans_assoc A M M' _ _ _ _ _ + have e3 : chainStage2Cast A M M' + (by omega : 0 + 1 = (-(0 : ℤ)).toNat + (0 + 1)) + (by omega : 0 + 1 = (0 : ℤ).toNat + (0 + 1)) ≫ + chainBGrCompι A M M' d 0 (0 + 1) ≫ + chainBGrι A M M' d 0 = + chainBGrCompι A M M' d 0 (0 + 1) ≫ + chainBGrι A M M' d 0 := by + refine Eq.trans (Category.assoc _ _ _).symm ?_ + exact eq_whisker (chainStage2Cast_chainBGrCompι A M M' d 0 + (rfl : (0 + 1 : ℕ) = 0 + 1)) _ + have hd : chainDelta2 A M M' d 0 0 ≫ + chainBGrCompι A M M' d 0 (0 + 1) = + chainBGrCompι A M M' d 0 0 := + chainDelta2_chainBGrCompι A M M' d 0 0 + have habs : (chainDelta2 A M M' d 0 0 ≫ + chainStage2Cast A M M' + (by omega : 0 + 1 = 0 + 1 + 0) + (by omega : 0 + 1 = 0 + 1 + 0)) ≫ + chainStage2Cast A M M' + (by omega : 0 + 1 + 0 = + (-((0 : ℤ) + 0)).toNat + (0 + 1)) + (by omega : 0 + 1 + 0 = + ((0 : ℤ) + 0).toNat + (0 + 1)) ≫ + chainBGrCompι A M M' d ((0 : ℤ) + 0) (0 + 1) ≫ + chainBGrι A M M' d ((0 : ℤ) + 0) = + chainBGrCompι A M M' d 0 0 ≫ chainBGrι A M M' d 0 := by + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (whisker_eq _ e1))) ?_ + refine Eq.trans (whisker_eq _ e2) ?_ + refine Eq.trans (whisker_eq _ e3) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + exact eq_whisker hd _ + have h1 : (chainBaseStage A M M' d ▷ + chainStage2 A M M' 0 0) ≫ + chainMul2 A M M' 0 0 0 0 ≫ + chainStage2Cast A M M' + (by omega : 0 + 1 + 0 = + (-((0 : ℤ) + 0)).toNat + (0 + 1)) + (by omega : 0 + 1 + 0 = + ((0 : ℤ) + 0).toNat + (0 + 1)) ≫ + chainBGrCompι A M M' d ((0 : ℤ) + 0) (0 + 1) ≫ + chainBGrι A M M' d ((0 : ℤ) + 0) = + modTensorAct A (symPowMod A M'.X 0) (symPowMod A M.X 0) ≫ + (chainDelta2 A M M' d 0 0 ≫ + chainStage2Cast A M M' + (by omega : 0 + 1 = 0 + 1 + 0) + (by omega : 0 + 1 = 0 + 1 + 0)) ≫ + chainStage2Cast A M M' + (by omega : 0 + 1 + 0 = + (-((0 : ℤ) + 0)).toNat + (0 + 1)) + (by omega : 0 + 1 + 0 = + ((0 : ℤ) + 0).toNat + (0 + 1)) ≫ + chainBGrCompι A M M' d ((0 : ℤ) + 0) (0 + 1) ≫ + chainBGrι A M M' d ((0 : ℤ) + 0) := + (Category.assoc _ _ _).symm.trans + ((eq_whisker (chainBaseStage_mul2 A M M' d 0 0) _).trans + (Category.assoc _ _ _)) + refine Eq.trans (whisker_eq _ h1) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (mul_chainBaseStage A M M' d).symm _) ?_ + refine Eq.trans (whisker_eq _ habs) ?_ + exact Category.assoc _ _ _ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitPairDef.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitPairDef.lean new file mode 100644 index 0000000000..c62f9ce320 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitPairDef.lean @@ -0,0 +1,179 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAssemble +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairCarrier + +/-! +# Defining equation of the carrier-level pair product + +Through the projection onto the relative tensor product, the +carrier-level pair product of the splitting data is computed by +the graded multiplication of the carrier: the two module entries +enter their components at the bottom stage and multiply into the +degree-zero component two stages up. This is the defining +equation of the pair product field of the splitting data of the +Key Lemma. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- A component insertion followed by the carrier inclusion, +transported along an equality of degrees. -/ +private theorem compι_ι_degCast + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + (d : ModDualityDatum A M M') + {x y : ℤ} (h : x = y) (k : ℕ) : + chainBGrCompι A M M' d x k ≫ chainBGrι A M M' d x = + chainStage2Cast A M M' + (by omega : (-x).toNat + k = (-y).toNat + k) + (by omega : x.toNat + k = y.toNat + k) ≫ + chainBGrCompι A M M' d y k ≫ chainBGrι A M M' d y := by + refine Eq.trans (whisker_eq _ + (eqToHom_chainBGrι A M M' d h).symm) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker + (chainBGrCompι_eqToHom A M M' d h k) _) ?_ + exact Category.assoc _ _ _ + +-- The relative tensor projection unfolds against +-- the pair multiplication on one generator. +/-- **Defining equation of the carrier-level pair product**: +through the projection of the relative tensor product, the pair +product is the graded product of the two module entries. -/ +theorem modTensorπ_splitPairMul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [HasColimitsOfShape SmallNat.{v} D] [HasColimitsOfShape (Discrete ℤ) D] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorRight X)] + [∀ X : D, PreservesColimitsOfShape SmallNat.{v} (tensorLeft X)] + [∀ X : D, PreservesColimitsOfShape (Discrete ℤ) (tensorLeft X)] + (d : ModDualityDatum A M M') : + modTensorπ A M M' ≫ splitPairMul A M M' d = + (splitIns A M M' d ⊗ₘ splitIns' A M M' d) ≫ + (letI := chainBGrMonObj A M M' d; + μ[chainBGr A M M' d]) := by + change modTensorπ A M M' ≫ splitPairMul A M M' d = + (splitIns A M M' d ⊗ₘ splitIns' A M M' d) ≫ + chainBGrMul A M M' d + have hcastL : chainStage2Cast A M M' + (by omega : 2 = (-(0 : ℤ)).toNat + 2) + (by omega : 2 = (0 : ℤ).toNat + 2) ≫ + chainBGrCompι A M M' d 0 2 = + chainBGrCompι A M M' d 0 2 := + chainStage2Cast_chainBGrCompι A M M' d 0 + (rfl : (2 : ℕ) = 2) + have hL : modTensorπ A M M' ≫ splitPairMul A M M' d = + chainPairRaw A M M' d ≫ + chainBGrCompι A M M' d 0 2 ≫ chainBGrι A M M' d 0 := by + change modTensorπ A M M' ≫ chainPairMul A M M' d ≫ + chainStage2Cast A M M' + (by omega : 2 = (-(0 : ℤ)).toNat + 2) + (by omega : 2 = (0 : ℤ).toNat + 2) ≫ + chainBGrCompι A M M' d 0 2 ≫ chainBGrι A M M' d 0 = + chainPairRaw A M M' d ≫ + chainBGrCompι A M M' d 0 2 ≫ chainBGrι A M M' d 0 + rw [modTensorπ_chainPairMul_assoc A M M' d, + reassoc_of% hcastL] + have h1 : (chainSeedQ A M M' d ⊗ₘ + (chainSeedP A M M' d ≫ chainStage2Cast A M M' + (by omega : 1 = (-(-1 : ℤ)).toNat + 0) + (by omega : 0 = ((-1 : ℤ)).toNat + 0))) ≫ + (chainBGrCompι A M M' d 1 0 ⊗ₘ + chainBGrCompι A M M' d (-1) 0) ≫ + (chainBGrι A M M' d 1 ⊗ₘ chainBGrι A M M' d (-1)) = + splitIns A M M' d ⊗ₘ splitIns' A M M' d := by + refine Eq.trans (whisker_eq _ + (MonoidalCategory.tensorHom_comp_tensorHom _ _ _ _)) ?_ + refine Eq.trans + (MonoidalCategory.tensorHom_comp_tensorHom _ _ _ _) ?_ + rw [splitIns, splitIns'] + simp only [Category.assoc] + have hw : chainSeedQ A M M' d ⊗ₘ + (chainSeedP A M M' d ≫ chainStage2Cast A M M' + (by omega : 1 = (-(-1 : ℤ)).toNat + 0) + (by omega : 0 = ((-1 : ℤ)).toNat + 0)) = + (chainSeedQ A M M' d ⊗ₘ chainSeedP A M M' d) ≫ + (chainStage2 A M M' 0 1 ◁ chainStage2Cast A M M' + (by omega : 1 = (-(-1 : ℤ)).toNat + 0) + (by omega : 0 = ((-1 : ℤ)).toNat + 0)) := by + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.comp_id] + have h4 := whiskerLeft_chainStage2Cast_chainMul2 A M M' 0 1 + (by omega : 1 = (-(-1 : ℤ)).toNat + 0) + (by omega : 0 = ((-1 : ℤ)).toNat + 0) + have hfront : (chainSeedQ A M M' d ⊗ₘ + (chainSeedP A M M' d ≫ chainStage2Cast A M M' + (by omega : 1 = (-(-1 : ℤ)).toNat + 0) + (by omega : 0 = ((-1 : ℤ)).toNat + 0))) ≫ + chainMul2 A M M' ((-(1 : ℤ)).toNat + 0) + ((1 : ℤ).toNat + 0) ((-(-1 : ℤ)).toNat + 0) + (((-1 : ℤ)).toNat + 0) = + chainPairRaw A M M' d ≫ chainStage2Cast A M M' + (by omega : 0 + 1 + 1 = + 0 + 1 + ((-(-1 : ℤ)).toNat + 0)) + (by omega : 1 + 1 + 0 = + 1 + 1 + (((-1 : ℤ)).toNat + 0)) := by + refine Eq.trans (eq_whisker hw _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ h4) ?_ + exact (Category.assoc _ _ _).symm + have hS : (2 : ℕ) = 0 + 1 + 0 + + ((1 : ℤ).toNat + (-1 : ℤ).toNat - + ((1 : ℤ) + -1).toNat) := by omega + have habs := chainStage2Cast_chainBGrCompι A M M' d 0 hS + have hR : (splitIns A M M' d ⊗ₘ splitIns' A M M' d) ≫ + chainBGrMul A M M' d = + chainPairRaw A M M' d ≫ + chainBGrCompι A M M' d 0 2 ≫ chainBGrι A M M' d 0 := by + refine Eq.trans + (eq_whisker h1.symm (chainBGrMul A M M' d)) ?_ + simp only [Category.assoc] + refine Eq.trans (whisker_eq _ (whisker_eq _ + (ι_tensorHom_chainBGrMul A M M' d 1 (-1)))) ?_ + refine Eq.trans (whisker_eq _ + (Category.assoc _ _ _).symm) ?_ + refine Eq.trans (whisker_eq _ (eq_whisker + (ι_tensorHom_chainBGrCompMul A M M' d 1 (-1) 0 0) _)) ?_ + refine Eq.trans (whisker_eq _ ((Category.assoc _ _ _).trans + (Category.assoc _ _ _))) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ (whisker_eq _ + (compι_ι_degCast A M M' d + (by omega : (1 : ℤ) + -1 = 0) _)))) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ + (chainStage2Cast_trans_assoc A M M' _ _ _ _ _))) ?_ + refine Eq.trans (Category.assoc _ _ _).symm ?_ + refine Eq.trans (eq_whisker hfront _) ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + refine Eq.trans (whisker_eq _ + (chainStage2Cast_trans_assoc A M M' _ _ _ _ _)) ?_ + exact whisker_eq _ ((Category.assoc _ _ _).symm.trans + (eq_whisker habs _)) + exact hL.trans hR.symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitReduce.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitReduce.lean new file mode 100644 index 0000000000..2197d3c4f2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitReduce.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorExact + +/-! +# Sections through the dual: the reduction of 2.10 + +Deligne reduces local splitting of a general short exact sequence +to sequences ending at the unit: a section of an epimorphism onto +`C` is the same thing as a unit-side lifting through the left +dual. This is the pure rigid-adjunction kernel of that reduction; +the splitting-algebra argument then only ever meets maps out of +the unit. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +variable {A : Type u} + +/-- The dual-side comparison point: the image of the right unitor +under the duality adjunction — the coevaluation-flavoured map the +liftings are measured against. -/ +noncomputable def dualUnitPoint + [Category.{v} A] [MonoidalCategory A] [RigidCategory A] + (C : A) : 𝟙_ A ⟶ (ᘁC) ⊗ C := + tensorLeftHomEquiv (𝟙_ A) (ᘁC) C C (ρ_ C).hom + +/-- **Sections through the dual**: an epimorphism onto `C` admits +a section exactly when the dual-side unit map lifts through it. -/ +theorem exists_section_iff_unit_lift + [Category.{v} A] [MonoidalCategory A] [RigidCategory A] + {B C : A} (b : B ⟶ C) : + (∃ t : C ⟶ B, t ≫ b = 𝟙 C) ↔ + (∃ s : 𝟙_ A ⟶ (ᘁC) ⊗ B, + s ≫ ((ᘁC) ◁ b) = dualUnitPoint C) := by + constructor + · rintro ⟨t, ht⟩ + refine ⟨tensorLeftHomEquiv (𝟙_ A) (ᘁC) C B + ((ρ_ C).hom ≫ t), ?_⟩ + rw [dualUnitPoint, ← tensorLeftHomEquiv_naturality] + congr 1 + rw [Category.assoc, ht, Category.comp_id] + · rintro ⟨s, hs⟩ + refine ⟨(ρ_ C).inv ≫ + (tensorLeftHomEquiv (𝟙_ A) (ᘁC) C B).symm s, ?_⟩ + have hnat : (tensorLeftHomEquiv (𝟙_ A) (ᘁC) C B).symm s ≫ b = + (tensorLeftHomEquiv (𝟙_ A) (ᘁC) C C).symm + (s ≫ ((ᘁC) ◁ b)) := by + apply (tensorLeftHomEquiv (𝟙_ A) (ᘁC) C C).injective + rw [tensorLeftHomEquiv_naturality, Equiv.apply_symm_apply, + Equiv.apply_symm_apply] + rw [Category.assoc, hnat, hs, dualUnitPoint, + Equiv.symm_apply_apply, Iso.inv_hom_id] + +section Pullback + +open Limits + +/-- The unit-ending object of the reduction: the preimage of the +dual-side unit point inside the dual-twisted middle term. -/ +noncomputable def unitEnd + [Category.{v} A] [MonoidalCategory A] [RigidCategory A] [Abelian A] + {B C : A} (b : B ⟶ C) : A := + pullback ((ᘁC) ◁ b) (dualUnitPoint C) + +/-- Its projection to the unit. -/ +noncomputable def unitEndProj + [Category.{v} A] [MonoidalCategory A] [RigidCategory A] [Abelian A] + {B C : A} (b : B ⟶ C) : + unitEnd b ⟶ 𝟙_ A := + pullback.snd _ _ + +/-- The kernel of the second pullback projection is the kernel of +the first leg. -/ +noncomputable def kernelPullbackSndIso [Category.{v} A] [Abelian A] + {X Y Z : A} (f : X ⟶ Z) + (g : Y ⟶ Z) : + kernel (pullback.snd f g) ≅ kernel f := by + refine ⟨kernel.lift f + (kernel.ι (pullback.snd f g) ≫ pullback.fst f g) ?_, + kernel.lift (pullback.snd f g) + (pullback.lift (kernel.ι f) 0 ?_) ?_, ?_, ?_⟩ + · rw [Category.assoc, pullback.condition, ← Category.assoc, + kernel.condition, Limits.zero_comp] + · rw [kernel.condition, Limits.zero_comp] + · rw [pullback.lift_snd] + · rw [← cancel_mono (kernel.ι (pullback.snd f g))] + rw [Category.assoc, kernel.lift_ι, Category.id_comp] + apply pullback.hom_ext + · rw [Category.assoc, pullback.lift_fst, kernel.lift_ι] + · rw [Category.assoc, pullback.lift_snd, Limits.comp_zero, + kernel.condition] + · rw [← cancel_mono (kernel.ι f)] + rw [Category.assoc, kernel.lift_ι, ← Category.assoc, + kernel.lift_ι, pullback.lift_fst, Category.id_comp] + +end Pullback + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitTransport.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitTransport.lean new file mode 100644 index 0000000000..6e6da91654 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitTransport.lean @@ -0,0 +1,104 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedTransport +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTransport + +/-! +# Transport of a splitting along a base change + +The base-change comparison of free modules is natural in the +object, so a section of a free morphism over one algebra +base-changes to a section over any algebra under it. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The base-change comparison is natural**, at the carrier. -/ +theorem baseChangeFreeInv_natural + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] + {V W : D} (f : V ⟶ W) : + (B ◁ f) ≫ baseChangeFreeInv A B φ W = + baseChangeFreeInv A B φ V ≫ + (baseChangeMapMod A B φ (freeModMap A f)).hom := by + have hcore : f ≫ ((λ_ W).inv ≫ (η[A] ▷ W)) = + ((λ_ V).inv ≫ (η[A] ▷ V)) ≫ (A ◁ f) := by + rw [leftUnitor_inv_naturality_assoc, whisker_exchange, + Category.assoc] + have hmap : modTensorπ A (restrictRegular φ) (freeMod A V) ≫ + modTensorMap A (𝟙 (restrictRegular φ)) (freeModMap A f) = + (B ◁ (A ◁ f)) ≫ + modTensorπ A (restrictRegular φ) (freeMod A W) := by + refine Eq.trans (modTensorπ_map A _ _) ?_ + rw [Mod.id_hom', MonoidalCategory.id_tensorHom] + rfl + rw [baseChangeMapMod_hom, baseChangeFreeInv, baseChangeFreeInv] + refine Eq.trans ?_ (Eq.trans (Category.assoc _ _ _) + (whisker_eq _ hmap)).symm + erw [← MonoidalCategory.whiskerLeft_comp_assoc, hcore, + MonoidalCategory.whiskerLeft_comp_assoc] + rfl + +/-- **The base-change comparison is natural**, as module maps. -/ +theorem baseChangeFreeIso_inv_natural + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] + {V W : D} (f : V ⟶ W) : + freeModMap B f ≫ (baseChangeFreeIso A B φ W).inv = + (baseChangeFreeIso A B φ V).inv ≫ + baseChangeMapMod A B φ (freeModMap A f) := by + apply Mod.Hom.ext + rw [Mod.comp_hom', Mod.comp_hom'] + change (B ◁ f) ≫ baseChangeFreeInv A B φ W = + baseChangeFreeInv A B φ V ≫ + (baseChangeMapMod A B φ (freeModMap A f)).hom + exact baseChangeFreeInv_natural A B φ f + +/-- **A section of a free morphism base-changes.** -/ +theorem exists_section_baseChange + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] + (ψ : A ⟶ B) [IsMonHom ψ] + {V W : D} (g : V ⟶ W) + (s : freeMod A W ⟶ freeMod A V) + (hs : s ≫ freeModMap A g = 𝟙 (freeMod A W)) : + ∃ t : freeMod B W ⟶ freeMod B V, + t ≫ freeModMap B g = 𝟙 (freeMod B W) := by + refine ⟨(baseChangeFreeIso A B ψ W).inv ≫ + baseChangeMapMod A B ψ s ≫ + (baseChangeFreeIso A B ψ V).hom, ?_⟩ + have hnat := baseChangeFreeIso_inv_natural A B ψ g + have hkey : (baseChangeFreeIso A B ψ V).hom ≫ freeModMap B g = + baseChangeMapMod A B ψ (freeModMap A g) ≫ + (baseChangeFreeIso A B ψ W).hom := by + rw [← Iso.eq_inv_comp, ← Category.assoc, ← hnat, + Category.assoc, Iso.inv_hom_id, Category.comp_id] + rw [Category.assoc, Category.assoc, hkey, ← Category.assoc + (baseChangeMapMod A B ψ s), ← baseChangeMapMod_comp, hs, + baseChangeMapMod_id, Category.id_comp] + simp + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplittingAlgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplittingAlgebra.lean new file mode 100644 index 0000000000..a2ebc3ac04 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplittingAlgebra.lean @@ -0,0 +1,61 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UniversalAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreRestrict + +/-! +# The splitting algebra of the embedded category + +The universal algebra of `RS.exists_universal_algebra`, taken over +the family of all objects of the small category, splits the image of +the Ind-embedding in the sense of `RS.SplitsOn`, and simultaneously +splits every chosen epimorphism. These are exactly the two +hypotheses under which the fibre functor over that algebra is strong +monoidal and exact. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v + +variable {C : Type v} + +/-- **The splitting algebra**: one nonzero commutative algebra that +splits every embedded object into a mixed sum and splits every +chosen epimorphism. -/ +theorem exists_splitting_algebra + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ C] [MonoidalPreadditive C] [MonoidalLinear ℂ C] + [RigidCategory C] [SymmetricCategory (Ind C)] [HasCoequalizers (Ind C)] + [∀ Z : Ind C, PreservesColimitsOfShape WalkingParallelPair (tensorLeft + Z)] [HasFiniteBiproducts (Ind C)] + (hu : HasScalarUnit C) + (L : OddLine (Ind C)) {K : Type v} (V W : K → Ind C) + (g : ∀ k, V k ⟶ W k) + (hmix : ∀ X : C, L.LocallyMixed ((indOf : C ⥤ Ind C).obj X)) + (hsplit : ∀ k, ∃ (A : Ind C) (_ : MonObj A) + (_ : IsCommMonObj A), MonObj.one (X := A) ≠ 0 ∧ + ∃ s : freeMod A (W k) ⟶ freeMod A (V k), + s ≫ freeModMap A (g k) = 𝟙 (freeMod A (W k))) : + ∃ (𝔸 : Ind C) (_ : MonObj 𝔸) (_ : IsCommMonObj 𝔸), + MonObj.one (X := 𝔸) ≠ 0 ∧ + SplitsOn L 𝔸 (indOf : C ⥤ Ind C) ∧ + (∀ k, ∃ s : freeMod 𝔸 (W k) ⟶ freeMod 𝔸 (V k), + s ≫ freeModMap 𝔸 (g k) = 𝟙 (freeMod 𝔸 (W k))) := by + obtain ⟨𝔸, hmon, hcomm, hne, hmixed, hsec⟩ := + exists_universal_algebra hu L + (fun X : C => (indOf : C ⥤ Ind C).obj X) V W g hmix hsplit + exact ⟨𝔸, hmon, hcomm, hne, hmixed, hsec⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/StateTransport.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StateTransport.lean new file mode 100644 index 0000000000..d7678c1aaa --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StateTransport.lean @@ -0,0 +1,81 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29State +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle + +/-! +# Transport of a dévissage state along an isomorphism + +The state depends on the object only through the free module it +generates, so an isomorphism of objects carries a state to a +state without disturbing any of the counts. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +attribute [local instance] + hasBinaryBiproducts_of_finite_biproducts + +/-- **Transport of a dévissage state along an isomorphism** of +the object being decomposed. -/ +noncomputable def DevissageState.transportObj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + {L : OddLine D} {X Y : D} (e : X ≅ Y) + (st : DevissageState D L X) : DevissageState D L Y := + letI := st.monObj + letI := st.comm + { base := st.base + monObj := st.monObj + comm := st.comm + unit_ne_zero := st.unit_ne_zero + units := st.units + lines := st.lines + rest := st.rest + restDual := st.restDual + datum := st.datum + zigzag := st.zigzag + decomp := st.decomp.elim fun f => + ⟨(freeModMapIso st.base e.symm).trans f⟩ } + +/-- Transport leaves the unit count untouched. -/ +@[simp] theorem DevissageState.transportObj_units + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + {L : OddLine D} {X Y : D} (e : X ≅ Y) + (st : DevissageState D L X) : + (st.transportObj e).units = st.units := rfl + +/-- Transport leaves the line count untouched. -/ +@[simp] theorem DevissageState.transportObj_lines + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + {L : OddLine D} {X Y : D} (e : X ≅ Y) + (st : DevissageState D L X) : + (st.transportObj e).lines = st.lines := rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepA.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepA.lean new file mode 100644 index 0000000000..d4902f3a35 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepA.lean @@ -0,0 +1,121 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaClose +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAdjoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29State + +/-! +# The unit step of the dévissage + +When every symmetric power of the remainder survives, the Key +Lemma splits a unit factor off it: the splitting algebra becomes +the new base, the complement becomes the new remainder, and the +mixed free part gains one unit summand. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v + +variable {C : Type v} + +attribute [local instance] + hasBinaryBiproducts_of_finite_biproducts + +/-- **The unit step of the dévissage**: when every symmetric +power of the remainder survives, the Key Lemma splits a unit +factor off it. -/ +theorem devissageStepA + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + [CategoryTheory.Linear ℂ (Ind C)] [MonoidalLinear ℂ (Ind C)] + (L : OddLine (Ind C)) (X : Ind C) : + DevissageStepA (Ind C) L X := by + intro st hSym + let := st.monObj + let := st.comm + obtain ⟨sd⟩ := keyLemmaData_ind st.base st.rest st.restDual + st.datum st.zigzag st.unit_ne_zero hSym + let := sd.monObj + let := sd.comm + let := sd.ofBase_monHom + obtain ⟨e⟩ := st.decomp + refine ⟨{ base := sd.carrier + monObj := sd.monObj + comm := sd.comm + unit_ne_zero := sd.unit_ne_zero + units := st.units + 1 + lines := st.lines + rest := splitComplMod st.base sd.carrier sd.ofBase + sd.ins sd.ins' st.datum sd.ins_linear + sd.ins'_linear + restDual := splitComplModDual st.base sd.carrier + sd.ofBase sd.ins sd.ins' st.datum sd.ins_linear + sd.ins'_linear + datum := (baseChangeDatum st.base sd.carrier + sd.ofBase st.datum).transfer sd.carrier + (splitComplIncl st.base sd.carrier sd.ofBase + sd.ins sd.ins' st.datum sd.ins_linear + sd.ins'_linear) + (splitComplInclDual st.base sd.carrier sd.ofBase + sd.ins sd.ins' st.datum sd.ins_linear + sd.ins'_linear) + (splitComplProjMod st.base sd.carrier sd.ofBase + sd.ins sd.ins' st.datum sd.ins_linear + sd.ins'_linear sd.pairMul sd.pairMul_def + sd.delta_eq) + (splitComplProjModDual st.base sd.carrier + sd.ofBase sd.ins sd.ins' st.datum + sd.ins_linear sd.ins'_linear sd.pairMul + sd.pairMul_def sd.delta_eq) + zigzag := modZigzagDatum_transfer sd.carrier + (baseChangeDatum st.base sd.carrier sd.ofBase + st.datum) + (splitComplIncl st.base sd.carrier sd.ofBase + sd.ins sd.ins' st.datum sd.ins_linear + sd.ins'_linear) + (splitComplInclDual st.base sd.carrier sd.ofBase + sd.ins sd.ins' st.datum sd.ins_linear + sd.ins'_linear) + (splitComplProjMod st.base sd.carrier sd.ofBase + sd.ins sd.ins' st.datum sd.ins_linear + sd.ins'_linear sd.pairMul sd.pairMul_def + sd.delta_eq) + (splitComplProjModDual st.base sd.carrier + sd.ofBase sd.ins sd.ins' st.datum + sd.ins_linear sd.ins'_linear sd.pairMul + sd.pairMul_def sd.delta_eq) + (baseChangeZigzag (Ind C) st.base _ _ st.rest + st.restDual st.datum st.zigzag sd.carrier _ _ + sd.ofBase _) + (splitComplIncl_proj st.base sd.carrier sd.ofBase + sd.ins sd.ins' st.datum sd.ins_linear + sd.ins'_linear sd.pairMul sd.pairMul_def + sd.delta_eq) + (splitComplInclDual_proj st.base sd.carrier + sd.ofBase sd.ins sd.ins' st.datum + sd.ins_linear sd.ins'_linear sd.pairMul + sd.pairMul_def sd.delta_eq) + (splitComplMap_adj st.base sd.carrier sd.ofBase + sd.ins sd.ins' st.datum st.zigzag + sd.ins_linear sd.ins'_linear sd.pairMul + sd.pairMul_def sd.delta_eq) + decomp := ⟨transportDecomp st.base sd.carrier + sd.ofBase L st.units st.lines e + (splitDecompMod st.base sd.carrier sd.ofBase + sd.ins sd.ins' st.datum sd.ins_linear + sd.ins'_linear sd.pairMul sd.pairMul_def + sd.delta_eq)⟩ }, rfl, rfl⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepATransport.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepATransport.lean new file mode 100644 index 0000000000..93f7e20071 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepATransport.lean @@ -0,0 +1,135 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeFree +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffle + +/-! +# Transport of the dévissage decomposition + +The decomposition of a state is carried along a base change and +recombined with the splitting of the remainder: one further unit +summand joins the mixed free part. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +attribute [local instance] + hasBinaryBiproducts_of_finite_biproducts + +/-- **Base change on morphisms of modules.** -/ +noncomputable def baseChangeMapMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] + {P Q : Mod D A} + (g : P ⟶ Q) : baseChangeMod φ P ⟶ baseChangeMod φ Q := + Mod.Hom.mk' (modTensorMap A (𝟙 (restrictRegular φ)) g) (by + exact baseChangeAct_modTensorMap A B φ g) + +@[simp] lemma baseChangeMapMod_hom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] + {P Q : Mod D A} + (g : P ⟶ Q) : + (baseChangeMapMod A B φ g).hom = + modTensorMap A (𝟙 (restrictRegular φ)) g := rfl + +/-- **Base change is functorial on isomorphisms.** -/ +noncomputable def baseChangeMapIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] + {P Q : Mod D A} (e : P ≅ Q) : + baseChangeMod φ P ≅ baseChangeMod φ Q where + hom := Mod.Hom.mk' + (modTensorMap A (𝟙 (restrictRegular φ)) e.hom) (by + exact baseChangeAct_modTensorMap A B φ e.hom) + inv := Mod.Hom.mk' + (modTensorMap A (𝟙 (restrictRegular φ)) e.inv) (by + exact baseChangeAct_modTensorMap A B φ e.inv) + hom_inv_id := by + apply Mod.Hom.ext + change modTensorMap A (𝟙 (restrictRegular φ)) e.hom ≫ + modTensorMap A (𝟙 (restrictRegular φ)) e.inv = + 𝟙 (modTensor A (restrictRegular φ) P) + rw [← modTensorMap_comp, Category.comp_id, e.hom_inv_id, + modTensorMap_id] + inv_hom_id := by + apply Mod.Hom.ext + change modTensorMap A (𝟙 (restrictRegular φ)) e.inv ≫ + modTensorMap A (𝟙 (restrictRegular φ)) e.hom = + 𝟙 (modTensor A (restrictRegular φ) Q) + rw [← modTensorMap_comp, Category.comp_id, e.inv_hom_id, + modTensorMap_id] + +section Mixed + +/-- **The mixed free part absorbs a unit summand.** -/ +noncomputable def freeMixSuccIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] (B : D) + [MonObj B] (L : OddLine D) (r : ℕ) (s : ℕ) : + modBiprod B (regularMod B) (freeMod B (L.mix r s)) ≅ + freeMod B (L.mix (r + 1) s) := + (modBiprodMapIso B _ _ (freeModUnitIso B).symm + (Iso.refl (freeMod B (L.mix r s)))).trans + ((freeModBiprodIso B (𝟙_ D) (L.mix r s)).symm.trans + (freeModMapIso B (L.mixSuccIso r s).symm)) + +/-- **The transported decomposition**: a state decomposition, +base-changed and recombined with a splitting of the remainder, +gains one unit summand in the mixed free part. -/ +noncomputable def transportDecomp + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (B : D) [MonObj B] [IsCommMonObj B] (φ : A ⟶ B) + [IsMonHom φ] (L : OddLine D) (r : ℕ) (s : ℕ) + {X : D} {R : Mod D A} + (e : freeMod A X ≅ modBiprod A (freeMod A (L.mix r s)) R) + {R'' : Mod D B} + (f : baseChangeMod φ R ≅ + modBiprod B (regularMod B) R'') : + freeMod B X ≅ + modBiprod B (freeMod B (L.mix (r + 1) s)) R'' := + (baseChangeFreeIso A B φ X).symm.trans + ((baseChangeMapIso A B φ e).trans + ((baseChangeBiprodIso A B φ (freeMod A (L.mix r s)) R + ).trans + ((modBiprodMapIso B _ _ + (baseChangeFreeIso A B φ (L.mix r s)) f).trans + ((modBiprodAssocIso B (freeMod B (L.mix r s)) + (regularMod B) R'').symm.trans + (modBiprodMapIso B _ _ + ((modBiprodSymmIso B (freeMod B (L.mix r s)) + (regularMod B)).trans + (freeMixSuccIso B L r s)) + (Iso.refl R'')))))) + +end Mixed + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepB.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepB.lean new file mode 100644 index 0000000000..b950b1fb03 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepB.lean @@ -0,0 +1,55 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepA +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistState +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistSymPow + +/-! +# The line step of the dévissage + +When every alternating power of the remainder survives, twisting +by the odd line turns them into surviving symmetric powers, so +the unit step applies to the twisted state and splits a unit +factor off it. Twisting back turns that unit factor into a line +factor of the original state. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v + +variable {C : Type v} + +attribute [local instance] + hasBinaryBiproducts_of_finite_biproducts + +/-- **The line step of the dévissage**: when every alternating +power of the remainder survives, a further line factor splits +off it. -/ +theorem devissageStepB + [SmallCategory C] [MonoidalCategory C] [SymmetricCategory C] [Abelian C] + [RigidCategory C] [MonoidalPreadditive C] + [CategoryTheory.Linear ℂ (Ind C)] [MonoidalLinear ℂ (Ind C)] + (L : OddLine (Ind C)) (X : Ind C) : + DevissageStepB (Ind C) L X := by + intro st hAlt + let := st.monObj + let := st.comm + obtain ⟨st', hu, hl⟩ := + devissageStepA L (L.obj ⊗ X) (twistState L st) + (not_isZero_symPow_twist st.base L st.rest hAlt) + exact ⟨(twistState L st').transportObj (untwistIso L X), + hl, hu⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed.lean new file mode 100644 index 0000000000..cd38c3de35 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed.lean @@ -0,0 +1,22 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Standard + +/-! +# Transport of the standard nonvanishing into the ambient category + +The nonvanishing of the standard super object carried into any +ambient symmetric ℂ-linear category with an odd invertible line, in +the three parts below: the Koszul sign of a permutation of slot +labels ([Signs.lean](SuperEmbed/Signs.lean)), the letter systems +that make the action of the group algebra model independent +([Letters.lean](SuperEmbed/Letters.lean)), and the two systems and +the conclusion they force +([Standard.lean](SuperEmbed/Standard.lean)). +-/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Letters.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Letters.lean new file mode 100644 index 0000000000..f3d8f4c31a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Letters.lean @@ -0,0 +1,1402 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Signs + +/-! +# Letter systems and the sign transport + +A `MixedLetters` system exhibits an object of a monoidal category +as a family of letters, each of them the unit or a fixed odd line. +The tensor power then decomposes into colourings, and a permutation +routes a colouring to its shuffle scaled by the Koszul sign of +[Signs.lean](Signs.lean). The matrix of the action of the group +algebra is therefore the same in every ambient category carrying +such a system, which is what makes the colour sum an obstruction +that transports; the two systems it is applied to are built in +[Standard.lean](Standard.lean). + +* `MixedLetters`: the structure, with the colouring maps + `colourInto`/`colourFrom`, their orthogonality and their + completeness `sum_colourFrom_colourInto`. +* `normIso`, `nIn`, `nOut`: the normalised form of a word power and + the colouring maps through it. +* `nIn_permMor`: the sign transport — a permutation carries a + normalised colouring to its shuffle, scaled by `parSign`. +* `colourSum`: the colour sum of a group-algebra element, with + `colourSum_eq_zero` and `permAlg_eq_zero`: an element kills the + tensor power exactly when its colour sums vanish. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +/-! ## Letter systems + +A `MixedLetters` system exhibits an object `M` as a biproduct-style +family of letters, each a monoidal unit (even) or a fixed line `U` +(odd), without asking the ambient category for biproducts: only the +inclusions, projections, orthogonality and completeness are used. -/ + +section Letters + +variable {A : Type u} + +/-- The letter object of a label: the line `U` when the label is +odd, the monoidal unit when it is even. -/ +abbrev letterObj [Category.{v} A] [MonoidalCategory A] + (U : A) {K : Type} (par : K → Bool) (k : K) : A := + bif par k then U else 𝟙_ A + +/-- **A letter system on `M`**: unit and `U`-letters included into +and projected from `M`, orthonormally and completely. -/ +structure MixedLetters + [Category.{v} A] [MonoidalCategory A] + [Preadditive A] (K : Type) [Fintype K] + (par : K → Bool) (U M : A) where + /-- The inclusion of the letter labelled `k`. -/ + ins : (k : K) → (letterObj U par k ⟶ M) + /-- The projection onto the letter labelled `k`. -/ + prj : (k : K) → (M ⟶ letterObj U par k) + /-- A letter's round trip through `M` is the identity. -/ + ins_prj : ∀ k, ins k ≫ prj k = 𝟙 (letterObj U par k) + /-- Distinct letters' round trips vanish. -/ + ins_prj_ne : ∀ {k k' : K}, k ≠ k' → ins k ≫ prj k' = 0 + /-- The projections and inclusions decompose the identity. -/ + total : (∑ k : K, prj k ≫ ins k) = 𝟙 M + +namespace MixedLetters + +/-- **The inclusion of a colouring**: the fold of the letterwise +inclusions into the tensor power, in slot order. -/ +noncomputable def colourInto + [Category.{v} A] [MonoidalCategory A] [Preadditive A] {K : Type} + [Fintype K] {par : K → Bool} {U : A} {M : A} + (S : MixedLetters K par U M) : + (n : ℕ) → (c : Fin n → K) → + (wordPow U (𝟙_ A) n (par ∘ c) ⟶ tensorPow A M n) + | 0, _ => 𝟙 (𝟙_ A) + | n + 1, c => + S.colourInto n (c ∘ Fin.castSucc) ⊗ₘ S.ins (c (Fin.last n)) + +/-- **The projection onto a colouring**: the fold of the letterwise +projections from the tensor power. -/ +noncomputable def colourFrom + [Category.{v} A] [MonoidalCategory A] [Preadditive A] {K : Type} + [Fintype K] {par : K → Bool} {U : A} {M : A} + (S : MixedLetters K par U M) : + (n : ℕ) → (c : Fin n → K) → + (tensorPow A M n ⟶ wordPow U (𝟙_ A) n (par ∘ c)) + | 0, _ => 𝟙 (𝟙_ A) + | n + 1, c => + S.colourFrom n (c ∘ Fin.castSucc) ⊗ₘ S.prj (c (Fin.last n)) + +/-- The defining recursion of `colourInto`. -/ +theorem colourInto_succ + [Category.{v} A] [MonoidalCategory A] [Preadditive A] {K : Type} + [Fintype K] {par : K → Bool} {U : A} {M : A} + (S : MixedLetters K par U M) (n : ℕ) + (c : Fin (n + 1) → K) : + S.colourInto (n + 1) c = + S.colourInto n (c ∘ Fin.castSucc) ⊗ₘ S.ins (c (Fin.last n)) := + rfl + +/-- Sections tensor to a section; stated at general objects. -/ +private theorem tensor_section [Category.{v} A] [MonoidalCategory A] + {P Q R T : A} (f : P ⟶ Q) (g : Q ⟶ P) + (h : R ⟶ T) (k : T ⟶ R) (hfg : f ≫ g = 𝟙 P) (hhk : h ≫ k = 𝟙 R) : + (f ⊗ₘ h) ≫ (g ⊗ₘ k) = 𝟙 (P ⊗ R) := by + rw [MonoidalCategory.tensorHom_comp_tensorHom, hfg, hhk, + MonoidalCategory.id_tensorHom_id] + +/-- **Same-colouring round trip**: a colouring included into the +power and projected back is unchanged. -/ +theorem colourInto_colourFrom_same + [Category.{v} A] [MonoidalCategory A] [Preadditive A] {K : Type} + [Fintype K] {par : K → Bool} {U : A} {M : A} + (S : MixedLetters K par U M) : + ∀ (n : ℕ) (c : Fin n → K), + S.colourInto n c ≫ S.colourFrom n c = + 𝟙 (wordPow U (𝟙_ A) n (par ∘ c)) := by + intro n + induction n with + | zero => intro c; exact Category.id_comp _ + | succ n ih => + intro c + exact tensor_section _ _ _ _ (ih (c ∘ Fin.castSucc)) + (S.ins_prj (c (Fin.last n))) + +/-- Two colourings of positive length differ in the last letter or +in the rest. -/ +private theorem colour_ne_cases {K : Type} + {n : ℕ} {c c' : Fin (n + 1) → K} + (hcc' : c ≠ c') : + c ∘ Fin.castSucc ≠ c' ∘ Fin.castSucc ∨ + c (Fin.last n) ≠ c' (Fin.last n) := by + by_contra hcon + rw [not_or, not_not, not_not] at hcon + obtain ⟨h1, h2⟩ := hcon + refine hcc' (funext fun i => ?_) + induction i using Fin.lastCases with + | last => exact h2 + | cast j => exact congrFun h1 j + +section MonPre + +/-- A vanishing first factor kills the tensor. -/ +private theorem tensor_zero_fst + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] + {P Q R T V W : A} + (f : P ⟶ Q) (g : Q ⟶ R) (h : T ⟶ V) (k : V ⟶ W) + (hfg : f ≫ g = 0) : (f ⊗ₘ h) ≫ (g ⊗ₘ k) = 0 := by + rw [MonoidalCategory.tensorHom_comp_tensorHom, hfg, + MonoidalPreadditive.zero_tensor] + +/-- A vanishing second factor kills the tensor. -/ +private theorem tensor_zero_snd + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] + {P Q R T V W : A} + (f : P ⟶ Q) (g : Q ⟶ R) (h : T ⟶ V) (k : V ⟶ W) + (hhk : h ≫ k = 0) : (f ⊗ₘ h) ≫ (g ⊗ₘ k) = 0 := by + rw [MonoidalCategory.tensorHom_comp_tensorHom, hhk, + MonoidalPreadditive.tensor_zero] + +/-- **Distinct-colouring round trips vanish.** -/ +theorem colourInto_colourFrom_ne + [Category.{v} A] [MonoidalCategory A] [Preadditive A] {K : Type} + [Fintype K] {par : K → Bool} {U : A} {M : A} [MonoidalPreadditive A] + (S : MixedLetters K par U M) : + ∀ (n : ℕ) {c c' : Fin n → K}, c ≠ c' → + S.colourInto n c ≫ S.colourFrom n c' = 0 := by + intro n + induction n with + | zero => + intro c c' hcc' + exact absurd (funext fun i => i.elim0) hcc' + | succ n ih => + intro c c' hcc' + rcases colour_ne_cases hcc' with h | h + · exact tensor_zero_fst _ _ _ _ (ih h) + · exact tensor_zero_snd _ _ _ _ (S.ins_prj_ne h) + +/-- One colouring's round trip through the full power, split into +the shorter colouring's round trip and the last letter's. -/ +private theorem fromInto_snoc + [Category.{v} A] [MonoidalCategory A] [Preadditive A] {K : Type} + [Fintype K] {par : K → Bool} {U : A} {M : A} + (S : MixedLetters K par U M) (n : ℕ) + (c' : Fin n → K) (k : K) : + S.colourFrom (n + 1) (Fin.snoc c' k) ≫ + S.colourInto (n + 1) (Fin.snoc c' k) = + (S.colourFrom n c' ≫ S.colourInto n c') ⊗ₘ + (S.prj k ≫ S.ins k) := by + have hw : (Fin.snoc c' k : Fin (n + 1) → K) ∘ Fin.castSucc = c' := + Fin.snoc_comp_castSucc + have hb : (Fin.snoc c' k : Fin (n + 1) → K) (Fin.last n) = k := + Fin.snoc_last .. + have hww : S.colourFrom n (Fin.snoc c' k ∘ Fin.castSucc) ≫ + S.colourInto n (Fin.snoc c' k ∘ Fin.castSucc) = + S.colourFrom n c' ≫ S.colourInto n c' := by rw [hw] + have hbb : S.prj ((Fin.snoc c' k : Fin (n + 1) → K) (Fin.last n)) ≫ + S.ins ((Fin.snoc c' k : Fin (n + 1) → K) (Fin.last n)) = + S.prj k ≫ S.ins k := by rw [hb] + rw [← hww, ← hbb] + exact MonoidalCategory.tensorHom_comp_tensorHom (C := A) _ _ _ _ + +/-- **Completeness of the colouring decomposition**: the round +trips through the colourings sum to the identity of the power. -/ +theorem sum_colourFrom_colourInto + [Category.{v} A] [MonoidalCategory A] [Preadditive A] {K : Type} + [Fintype K] {par : K → Bool} {U : A} {M : A} [MonoidalPreadditive A] + (S : MixedLetters K par U M) : + ∀ n : ℕ, + (∑ c : Fin n → K, S.colourFrom n c ≫ S.colourInto n c) = + 𝟙 (tensorPow A M n) := by + intro n + induction n with + | zero => + rw [Fintype.sum_unique] + exact Category.id_comp _ + | succ n ih => + have e1 : (∑ c : Fin (n + 1) → K, + S.colourFrom (n + 1) c ≫ S.colourInto (n + 1) c) = + ∑ p : K × (Fin n → K), + S.colourFrom (n + 1) (Fin.snoc p.2 p.1) ≫ + S.colourInto (n + 1) (Fin.snoc p.2 p.1) := + (Equiv.sum_comp (Fin.snocEquiv fun _ : Fin (n + 1) => K) + (fun c => S.colourFrom (n + 1) c ≫ + S.colourInto (n + 1) c)).symm + have e2 : (∑ p : K × (Fin n → K), + S.colourFrom (n + 1) (Fin.snoc p.2 p.1) ≫ + S.colourInto (n + 1) (Fin.snoc p.2 p.1)) = + ∑ p : K × (Fin n → K), + ((S.colourFrom n p.2 ≫ S.colourInto n p.2) ⊗ₘ + (S.prj p.1 ≫ S.ins p.1) : + tensorPow A M (n + 1) ⟶ tensorPow A M (n + 1)) := + Finset.sum_congr rfl fun p _ => S.fromInto_snoc n p.2 p.1 + have e3 : (∑ p : K × (Fin n → K), + ((S.colourFrom n p.2 ≫ S.colourInto n p.2) ⊗ₘ + (S.prj p.1 ≫ S.ins p.1) : + tensorPow A M (n + 1) ⟶ tensorPow A M (n + 1))) = + ∑ k : K, ∑ c' : Fin n → K, + ((S.colourFrom n c' ≫ S.colourInto n c') ⊗ₘ + (S.prj k ≫ S.ins k) : + tensorPow A M (n + 1) ⟶ tensorPow A M (n + 1)) := + Fintype.sum_prod_type _ + have e4 : ∀ k : K, + (∑ c' : Fin n → K, + ((S.colourFrom n c' ≫ S.colourInto n c') ⊗ₘ + (S.prj k ≫ S.ins k) : + tensorPow A M (n + 1) ⟶ tensorPow A M (n + 1))) = + 𝟙 (tensorPow A M n) ⊗ₘ (S.prj k ≫ S.ins k) := by + intro k + rw [← ih] + exact (sum_tensor _ _ _).symm + have e5 : (∑ k : K, ∑ c' : Fin n → K, + ((S.colourFrom n c' ≫ S.colourInto n c') ⊗ₘ + (S.prj k ≫ S.ins k) : + tensorPow A M (n + 1) ⟶ tensorPow A M (n + 1))) = + ∑ k : K, 𝟙 (tensorPow A M n) ⊗ₘ (S.prj k ≫ S.ins k) := + Finset.sum_congr rfl fun k _ => e4 k + have e6 : (∑ k : K, 𝟙 (tensorPow A M n) ⊗ₘ + (S.prj k ≫ S.ins k)) = + 𝟙 (tensorPow A M (n + 1)) := by + rw [← tensor_sum, S.total, MonoidalCategory.id_tensorHom_id] + rfl + exact e1.trans (e2.trans (e3.trans (e5.trans e6))) + +end MonPre + +end MixedLetters + +end Letters + +/-! ## Normalising word powers + +Every word power of `U` and the unit normalises, by unitors alone, +to the pure power of `U` counted by the word. Reading the +colouring inclusions and projections through this normal form +confines every transport to powers of `U` indexed by counts. -/ + +section Norm + +variable {A : Type u} + +/-- Absorbing one letter into a power of `U`: a `U`-letter extends +the power, a unit letter is stripped by the right unitor. -/ +noncomputable def tailIso [Category.{v} A] [MonoidalCategory A] + (U : A) (k : ℕ) : (b : Bool) → + (tensorPow A U k ⊗ (bif b then U else 𝟙_ A) ≅ + tensorPow A U (k + (bif b then 1 else 0))) + | true => Iso.refl (tensorPow A U (k + 1)) + | false => ρ_ (tensorPow A U k) + +/-- **The normalisation of a word power**: strip the unit letters +by unitors, leaving the power of `U` of the word's count. -/ +noncomputable def normIso [Category.{v} A] [MonoidalCategory A] + (U : A) : (n : ℕ) → (w : Fin n → Bool) → + (wordPow U (𝟙_ A) n w ≅ tensorPow A U (popCount w)) + | 0, w => eqToIso (congrArg (tensorPow A U) (popCount_nil w).symm) + | n + 1, w => + whiskerRightIso (normIso U n (w ∘ Fin.castSucc)) + (bif w (Fin.last n) then U else 𝟙_ A) ≪≫ + tailIso U (popCount (w ∘ Fin.castSucc)) (w (Fin.last n)) ≪≫ + eqToIso (congrArg (tensorPow A U) (popCount_succ w).symm) + +end Norm + +section NormMaps + +variable {A : Type u} + +/-- The recursion of the normalisation, inverse side. -/ +private theorem normIso_inv_succ [Category.{v} A] [MonoidalCategory A] + (U : A) {n : ℕ} + (w : Fin (n + 1) → Bool) : + (normIso U (n + 1) w).inv = + eqToHom (congrArg (tensorPow A U) (popCount_succ w)) ≫ + (tailIso U (popCount (w ∘ Fin.castSucc)) (w (Fin.last n))).inv ≫ + ((normIso U n (w ∘ Fin.castSucc)).inv ▷ + (bif w (Fin.last n) then U else 𝟙_ A)) := by + change (whiskerRightIso (normIso U n (w ∘ Fin.castSucc)) _ ≪≫ + tailIso U (popCount (w ∘ Fin.castSucc)) (w (Fin.last n)) ≪≫ + eqToIso (congrArg (tensorPow A U) (popCount_succ w).symm)).inv = _ + simp only [Iso.trans_inv, whiskerRightIso_inv, eqToIso.inv, + Category.assoc] + +/-- The recursion of the normalisation, hom side. -/ +private theorem normIso_hom_succ [Category.{v} A] [MonoidalCategory A] + (U : A) {n : ℕ} + (w : Fin (n + 1) → Bool) : + (normIso U (n + 1) w).hom = + ((normIso U n (w ∘ Fin.castSucc)).hom ▷ + (bif w (Fin.last n) then U else 𝟙_ A)) ≫ + (tailIso U (popCount (w ∘ Fin.castSucc)) (w (Fin.last n))).hom ≫ + eqToHom (congrArg (tensorPow A U) (popCount_succ w).symm) := by + change (whiskerRightIso (normIso U n (w ∘ Fin.castSucc)) _ ≪≫ + tailIso U (popCount (w ∘ Fin.castSucc)) (w (Fin.last n)) ≪≫ + eqToIso (congrArg (tensorPow A U) (popCount_succ w).symm)).hom = _ + simp only [Iso.trans_hom, whiskerRightIso_hom, eqToIso.hom] + +/-- A whisker followed by a tensor merges on the first factor. +Stated at general objects. -/ +private theorem whisker_then_tensor [Category.{v} A] [MonoidalCategory A] + {P Q R T V : A} + (f : P ⟶ Q) (g : Q ⟶ R) (h : T ⟶ V) : + (f ▷ T) ≫ (g ⊗ₘ h) = (f ≫ g) ⊗ₘ h := by + rw [← MonoidalCategory.tensorHom_id f T, + MonoidalCategory.tensorHom_comp_tensorHom, Category.id_comp] + +/-- Gluing a whisker-ended factorisation onto a tensor. Stated at +general objects. -/ +private theorem split_glue [Category.{v} A] [MonoidalCategory A] + {W X P P' L Q Q' : A} + (E : W ⟶ X) (T : X ⟶ P ⊗ L) (N : P ⟶ P') (I : P' ⟶ Q) + (J : L ⟶ Q') : + (E ≫ T ≫ (N ▷ L)) ≫ (I ⊗ₘ J) = E ≫ T ≫ ((N ≫ I) ⊗ₘ J) := by + simp only [Category.assoc] + rw [whisker_then_tensor] + +/-- A tensor followed by a whisker merges on the first factor. +Stated at general objects. -/ +private theorem tensor_then_whisker [Category.{v} A] [MonoidalCategory A] + {P Q R T V : A} + (f : P ⟶ Q) (g : Q ⟶ R) (h : T ⟶ V) : + (f ⊗ₘ h) ≫ (g ▷ V) = (f ≫ g) ⊗ₘ h := by + rw [← MonoidalCategory.tensorHom_id g V, + MonoidalCategory.tensorHom_comp_tensorHom, Category.comp_id] + +end NormMaps + +/-! ## The normalised colouring maps -/ + +namespace MixedLetters + +variable {A : Type u} + +/-- **The normalised inclusion of a colouring**: the colouring +inclusion, read off the `U`-power normal form of its word power. -/ +noncomputable def nIn + [Category.{v} A] [MonoidalCategory A] [Preadditive A] {K : Type} + [Fintype K] {par : K → Bool} {U : A} {M : A} + (S : MixedLetters K par U M) (n : ℕ) + (c : Fin n → K) : + tensorPow A U (popCount (par ∘ c)) ⟶ tensorPow A M n := + (normIso U n (par ∘ c)).inv ≫ S.colourInto n c + +/-- **The normalised projection onto a colouring.** -/ +noncomputable def nOut + [Category.{v} A] [MonoidalCategory A] [Preadditive A] {K : Type} + [Fintype K] {par : K → Bool} {U : A} {M : A} + (S : MixedLetters K par U M) (n : ℕ) + (c : Fin n → K) : + tensorPow A M n ⟶ tensorPow A U (popCount (par ∘ c)) := + S.colourFrom n c ≫ (normIso U n (par ∘ c)).hom + +/-- The colouring inclusion factors through its normalised form. -/ +theorem colourInto_eq_nIn + [Category.{v} A] [MonoidalCategory A] [Preadditive A] {K : Type} + [Fintype K] {par : K → Bool} {U : A} {M : A} + (S : MixedLetters K par U M) (n : ℕ) + (c : Fin n → K) : + S.colourInto n c = (normIso U n (par ∘ c)).hom ≫ S.nIn n c := by + rw [nIn, Iso.hom_inv_id_assoc] + +/-- **Same-colouring round trip of the normalised maps.** -/ +theorem nIn_nOut_same + [Category.{v} A] [MonoidalCategory A] [Preadditive A] {K : Type} + [Fintype K] {par : K → Bool} {U : A} {M : A} + (S : MixedLetters K par U M) (n : ℕ) + (c : Fin n → K) : + S.nIn n c ≫ S.nOut n c = + 𝟙 (tensorPow A U (popCount (par ∘ c))) := by + rw [nIn, nOut] + slice_lhs 2 3 => rw [S.colourInto_colourFrom_same n c] + rw [Category.id_comp, Iso.inv_hom_id] + +/-- **Distinct-colouring round trips of the normalised maps +vanish.** -/ +theorem nIn_nOut_ne + [Category.{v} A] [MonoidalCategory A] [Preadditive A] {K : Type} + [Fintype K] {par : K → Bool} {U : A} {M : A} + [MonoidalPreadditive A] + (S : MixedLetters K par U M) (n : ℕ) {c c' : Fin n → K} + (h : c ≠ c') : S.nIn n c ≫ S.nOut n c' = 0 := by + rw [nIn, nOut] + slice_lhs 2 3 => rw [S.colourInto_colourFrom_ne n h] + rw [Limits.zero_comp, Limits.comp_zero] + +/-- The recursion of the normalised inclusion: strip the top +letter. -/ +theorem nIn_succ + [Category.{v} A] [MonoidalCategory A] [Preadditive A] {K : Type} + [Fintype K] {par : K → Bool} {U : A} {M : A} + (S : MixedLetters K par U M) (n : ℕ) + (c : Fin (n + 1) → K) : + S.nIn (n + 1) c = + eqToHom (congrArg (tensorPow A U) (popCount_succ (par ∘ c))) ≫ + (tailIso U (popCount (par ∘ (c ∘ Fin.castSucc))) + (par (c (Fin.last n)))).inv ≫ + (S.nIn n (c ∘ Fin.castSucc) ⊗ₘ S.ins (c (Fin.last n))) := by + rw [nIn, colourInto_succ, normIso_inv_succ] + exact split_glue _ _ _ _ _ + +/-- Transport of the normalised inclusion along an equality of +colourings. -/ +theorem nIn_congr + [Category.{v} A] [MonoidalCategory A] [Preadditive A] {K : Type} + [Fintype K] {par : K → Bool} {U : A} {M : A} + (S : MixedLetters K par U M) {n : ℕ} + {c c' : Fin n → K} (h : c = c') + (hp : popCount (par ∘ c) = popCount (par ∘ c')) : + S.nIn n c = eqToHom (congrArg (tensorPow A U) hp) ≫ S.nIn n c' + := by + subst h + rw [show congrArg (tensorPow A U) hp = + (rfl : tensorPow A U (popCount (par ∘ c)) = + tensorPow A U (popCount (par ∘ c))) from rfl] + rw [eqToHom_refl, Category.id_comp] + +end MixedLetters + +/-! ## Reindexing along the generators -/ + +section PermFacts + +open Equiv + +/-- Extension to one more slot commutes with inversion. -/ +theorem extPerm_inv {n : ℕ} (τ : Equiv.Perm (Fin n)) : + (extPerm τ)⁻¹ = extPerm τ⁻¹ := by + rw [eq_comm, eq_inv_iff_mul_eq_one, ← extPerm_mul, + inv_mul_cancel, extPerm_one] + +/-- Reindexing along a top-fixing permutation restricts below the +top slot. -/ +theorem permIndex_extPerm_castSucc {K : Type*} {n : ℕ} + (τ : Equiv.Perm (Fin n)) (c : Fin (n + 1) → K) : + permIndex (extPerm τ) c ∘ Fin.castSucc = + permIndex τ (c ∘ Fin.castSucc) := by + funext j + change c ((extPerm τ)⁻¹ (Fin.castSucc j)) = c (Fin.castSucc (τ⁻¹ j)) + rw [extPerm_inv, extPerm_castSucc] + +/-- Reindexing along a top-fixing permutation fixes the top +letter. -/ +theorem permIndex_extPerm_last {K : Type*} {n : ℕ} + (τ : Equiv.Perm (Fin n)) (c : Fin (n + 1) → K) : + permIndex (extPerm τ) c (Fin.last n) = c (Fin.last n) := by + change c ((extPerm τ)⁻¹ (Fin.last n)) = c (Fin.last n) + rw [extPerm_inv, extPerm_last] + +/-- The top transposition is its own inverse. -/ +theorem topSwap_inv {n : ℕ} : + (topSwap : Equiv.Perm (Fin (n + 2)))⁻¹ = topSwap := + Equiv.swap_inv _ _ + +/-- Reindexing along the top transposition, top letter. -/ +theorem permIndex_topSwap_last {K : Type*} {n : ℕ} + (c : Fin (n + 2) → K) : + permIndex topSwap c (Fin.last (n + 1)) = + c (Fin.castSucc (Fin.last n)) := by + change c (topSwap⁻¹ (Fin.last (n + 1))) = _ + rw [topSwap_inv, topSwap_last] + +/-- Reindexing along the top transposition, second letter. -/ +theorem permIndex_topSwap_castSucc_last {K : Type*} {n : ℕ} + (c : Fin (n + 2) → K) : + permIndex topSwap c (Fin.castSucc (Fin.last n)) = + c (Fin.last (n + 1)) := by + change c (topSwap⁻¹ (Fin.castSucc (Fin.last n))) = _ + rw [topSwap_inv, topSwap_castSucc_last] + +/-- Reindexing along the top transposition, lower letters. -/ +theorem permIndex_topSwap_low {K : Type*} {n : ℕ} + (c : Fin (n + 2) → K) : + permIndex topSwap c ∘ Fin.castSucc ∘ Fin.castSucc = + c ∘ Fin.castSucc ∘ Fin.castSucc := by + funext j + change c (topSwap⁻¹ (Fin.castSucc (Fin.castSucc j))) = _ + rw [topSwap_inv, topSwap_castSucc_castSucc] + rfl + +end PermFacts + +/-! ## The braiding on a pair of letters -/ + +section LetterSwap + +variable {A : Type u} + +/-- Conjugation of a scalar of the identity by an isomorphism. +Stated at general objects. -/ +private theorem conj_smul_id' [Category.{v} A] + [Preadditive A] [Linear ℂ A] + {W V : A} (e : W ≅ V) (c : ℂ) : + e.hom ≫ (c • 𝟙 V) ≫ e.inv = c • 𝟙 W := by + simp + +/-- Exchanging a braiding of the ambient object for the braiding of +the two included letters. Stated at general objects. -/ +private theorem tensor_swap_exchange [Category.{v} A] [MonoidalCategory A] + [BraidedCategory A] + {P Q N La Lb : A} (F : P ⟶ Q) (g : La ⟶ N) (h : Lb ⟶ N) : + ((F ⊗ₘ g) ⊗ₘ h) ≫ (α_ Q N N).hom ≫ (Q ◁ (β_ N N).hom) ≫ + (α_ Q N N).inv = + (α_ P La Lb).hom ≫ (P ◁ (β_ La Lb).hom) ≫ (α_ P Lb La).inv ≫ + ((F ⊗ₘ h) ⊗ₘ g) := by + calc ((F ⊗ₘ g) ⊗ₘ h) ≫ (α_ Q N N).hom ≫ (Q ◁ (β_ N N).hom) ≫ + (α_ Q N N).inv + = (α_ P La Lb).hom ≫ (F ⊗ₘ (g ⊗ₘ h)) ≫ (Q ◁ (β_ N N).hom) ≫ + (α_ Q N N).inv := by + rw [← Category.assoc, MonoidalCategory.associator_naturality, + Category.assoc] + _ = (α_ P La Lb).hom ≫ (F ⊗ₘ ((g ⊗ₘ h) ≫ (β_ N N).hom)) ≫ + (α_ Q N N).inv := by + rw [← MonoidalCategory.id_tensorHom, + ← Category.assoc (F ⊗ₘ (g ⊗ₘ h)), + MonoidalCategory.tensorHom_comp_tensorHom, Category.comp_id] + _ = (α_ P La Lb).hom ≫ (F ⊗ₘ ((β_ La Lb).hom ≫ (h ⊗ₘ g))) ≫ + (α_ Q N N).inv := by + rw [BraidedCategory.braiding_naturality] + _ = (α_ P La Lb).hom ≫ (P ◁ (β_ La Lb).hom) ≫ + (F ⊗ₘ (h ⊗ₘ g)) ≫ (α_ Q N N).inv := by + rw [show F ⊗ₘ ((β_ La Lb).hom ≫ (h ⊗ₘ g)) = + (P ◁ (β_ La Lb).hom) ≫ (F ⊗ₘ (h ⊗ₘ g)) from by + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.id_comp]] + rw [Category.assoc] + _ = (α_ P La Lb).hom ≫ (P ◁ (β_ La Lb).hom) ≫ (α_ P Lb La).inv ≫ + ((F ⊗ₘ h) ⊗ₘ g) := by + rw [MonoidalCategory.associator_inv_naturality] + +/-- The conjugated braiding of two unit letters is the identity. -/ +private theorem letter_swap_unit_unit [Category.{v} A] [MonoidalCategory A] + [SymmetricCategory A] (P : A) : + (α_ P (𝟙_ A) (𝟙_ A)).hom ≫ (P ◁ (β_ (𝟙_ A) (𝟙_ A)).hom) ≫ + (α_ P (𝟙_ A) (𝟙_ A)).inv = 𝟙 ((P ⊗ 𝟙_ A) ⊗ 𝟙_ A) := by + rw [braiding_unit_self, MonoidalCategory.whiskerLeft_id, + Category.id_comp, Iso.hom_inv_id] + +/-- The conjugated braiding of two odd letters is minus the +identity. -/ +private theorem letter_swap_odd_odd [Category.{v} A] [MonoidalCategory A] + [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] (P : A) {U : A} + (hβ : (β_ U U).hom = -(𝟙 (U ⊗ U))) : + (α_ P U U).hom ≫ (P ◁ (β_ U U).hom) ≫ (α_ P U U).inv = + -(𝟙 ((P ⊗ U) ⊗ U)) := by + have h1 : (β_ U U).hom = (-1 : ℂ) • 𝟙 (U ⊗ U) := by + rw [hβ] + exact (neg_one_smul ℂ _).symm + rw [h1, MonoidalLinear.whiskerLeft_smul, + MonoidalCategory.whiskerLeft_id, + conj_smul_id' (α_ P U U) (-1 : ℂ), neg_one_smul] + +/-- The conjugated braiding of a unit letter under an odd letter is +absorbed by unitors. -/ +private theorem letter_swap_unit_odd [Category.{v} A] [MonoidalCategory A] + [SymmetricCategory A] + (P U : A) : + ((ρ_ P).inv ▷ U) ≫ (α_ P (𝟙_ A) U).hom ≫ + (P ◁ (β_ (𝟙_ A) U).hom) ≫ (α_ P U (𝟙_ A)).inv = + (ρ_ (P ⊗ U)).inv := by + have hb : (β_ (𝟙_ A) U).hom = (λ_ U).hom ≫ (ρ_ U).inv := by + rw [← braiding_rightUnitor U, Category.assoc, Iso.hom_inv_id, + Category.comp_id] + rw [hb] + monoidal + +/-- The conjugated braiding of an odd letter under a unit letter is +absorbed by unitors. -/ +private theorem letter_swap_odd_unit [Category.{v} A] [MonoidalCategory A] + [SymmetricCategory A] + (P U : A) : + (ρ_ (P ⊗ U)).inv ≫ (α_ P U (𝟙_ A)).hom ≫ + (P ◁ (β_ U (𝟙_ A)).hom) ≫ (α_ P (𝟙_ A) U).inv = + (ρ_ P).inv ▷ U := by + have hb : (β_ U (𝟙_ A)).hom = (ρ_ U).hom ≫ (λ_ U).inv := by + rw [← braiding_leftUnitor U, Category.assoc, Iso.hom_inv_id, + Category.comp_id] + rw [hb] + monoidal + +end LetterSwap + +/-! ## The sign transport of the permutation action + +The heart of the comparison: on the normal form, the action of a +permutation is the transport between the shuffled colourings, +scaled by the combinatorial Koszul sign — the same scalar in every +ambient category. -/ + +namespace MixedLetters + +variable {A : Type u} + +/-- Scalars pull out of the first factor of a tensor. -/ +private theorem smul_tensorHom + [Category.{v} A] [MonoidalCategory A] [Preadditive A] [Linear ℂ A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] + {P Q R T : A} (a : ℂ) (f : P ⟶ Q) + (g : R ⟶ T) : (a • f) ⊗ₘ g = a • (f ⊗ₘ g) := by + rw [MonoidalCategory.tensorHom_def, MonoidalCategory.tensorHom_def, + MonoidalLinear.smul_whiskerRight, Linear.smul_comp] + +/-- The identity-preserving statement of the sign transport for a +single permutation, quantified over the count proof. -/ +private def SignStmt [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] {K : Type} [Fintype K] {par : K → Bool} + {U : A} {M : A} + (S : MixedLetters K par U M) (n : ℕ) + (σ : Equiv.Perm (Fin n)) : Prop := + ∀ (c : Fin n → K) + (h : popCount (par ∘ c) = popCount (par ∘ permIndex σ c)), + S.nIn n c ≫ permMor M n σ = + parSign σ (par ∘ c) • + (eqToHom (congrArg (tensorPow A U) h) ≫ + S.nIn n (permIndex σ c)) + +/-- The sign transport for the identity permutation. -/ +private theorem signStmt_one + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] {K : Type} [Fintype K] {par : K → Bool} + {U : A} {M : A} + (S : MixedLetters K par U M) (n : ℕ) : + S.SignStmt n 1 := by + intro c h + rw [permMor_one, Category.comp_id, parSign_one, one_smul] + exact S.nIn_congr (permIndex_one c).symm h + +/-- The sign transport is closed under composition. -/ +private theorem signStmt_mul + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] {K : Type} [Fintype K] {par : K → Bool} + {U : A} {M : A} + (S : MixedLetters K par U M) {n : ℕ} + {g τ : Equiv.Perm (Fin n)} (hg : S.SignStmt n g) + (hτ : S.SignStmt n τ) : S.SignStmt n (g * τ) := by + intro c h + rw [permMor_mul, ← Category.assoc, + hτ c (popCount_permIndex τ (par ∘ c)).symm, Linear.smul_comp, + Category.assoc, + hg (permIndex τ c) + (popCount_permIndex g (permIndex τ (par ∘ c))).symm, + Linear.comp_smul, smul_smul, parSign_mul, mul_comm, + eqToHom_trans_assoc] + rfl + +/-- The unit-letter absorption, spelled. -/ +@[simp] +theorem tailIso_false [Category.{v} A] [MonoidalCategory A] + {U : A} (k : ℕ) : + tailIso U k false = ρ_ (tensorPow A U k) := rfl + +/-- The `U`-letter absorption, spelled. -/ +@[simp] +theorem tailIso_true [Category.{v} A] [MonoidalCategory A] + {U : A} (k : ℕ) : + tailIso U k true = Iso.refl (tensorPow A U (k + 1)) := rfl + +/-- A count transport passes the letter absorption. -/ +private theorem tailIso_inv_cast [Category.{v} A] [MonoidalCategory A] + (U : A) {k k' : ℕ} (hk : k = k') + (b : Bool) : + (tailIso U k b).inv ≫ + (eqToHom (congrArg (tensorPow A U) hk) ▷ + (bif b then U else 𝟙_ A)) = + eqToHom (congrArg (tensorPow A U) + (congrArg (· + (bif b then 1 else 0)) hk)) ≫ + (tailIso U k' b).inv := by + subst hk + have e1 : eqToHom (congrArg (tensorPow A U) (Eq.refl k)) = + 𝟙 (tensorPow A U k) := eqToHom_refl _ _ + have e2 : eqToHom (congrArg (tensorPow A U) + (congrArg (· + (bif b then 1 else 0)) (Eq.refl k))) = + 𝟙 (tensorPow A U (k + (bif b then 1 else 0))) := + eqToHom_refl _ _ + rw [e1, e2, MonoidalCategory.id_whiskerRight, Category.comp_id, + Category.id_comp] + +/-- A count transport passes the letter absorption, with a tail. -/ +private theorem tailIso_inv_cast_assoc [Category.{v} A] [MonoidalCategory A] + (U : A) {k k' : ℕ} + (hk : k = k') (b : Bool) {Z : A} + (X : tensorPow A U k' ⊗ (bif b then U else 𝟙_ A) ⟶ Z) : + (tailIso U k b).inv ≫ + ((eqToHom (congrArg (tensorPow A U) hk) ▷ + (bif b then U else 𝟙_ A)) ≫ X) = + eqToHom (congrArg (tensorPow A U) + (congrArg (· + (bif b then 1 else 0)) hk)) ≫ + (tailIso U k' b).inv ≫ X := by + rw [← Category.assoc, tailIso_inv_cast U hk b, Category.assoc] + +/-- The letter count of a colouring splits off the last letter, in +the composite spelling. -/ +theorem popCount_split {K : Type} {par : K → Bool} + {n : ℕ} (c : Fin (n + 1) → K) : + popCount (par ∘ c) = + popCount (par ∘ (c ∘ Fin.castSucc)) + + (bif par (c (Fin.last n)) then 1 else 0) := + popCount_succ (par ∘ c) + +/-- Reindexing preserves letter counts, in the composite +spelling. -/ +theorem popCount_permIndex' {K : Type} {par : K → Bool} + {n : ℕ} (σ : Equiv.Perm (Fin n)) + (c : Fin n → K) : + popCount (par ∘ c) = popCount (par ∘ permIndex σ c) := + (popCount_permIndex σ (par ∘ c)).symm + +/-- Splitting the normalised inclusion at the last letter, with the +tail and last letter replaced by given values. -/ +theorem nIn_split + [Category.{v} A] [MonoidalCategory A] [Preadditive A] {K : Type} + [Fintype K] {par : K → Bool} {U : A} {M : A} + (S : MixedLetters K par U M) (n : ℕ) + (c : Fin (n + 1) → K) (c' : Fin n → K) (k : K) + (hc : c ∘ Fin.castSucc = c') (hk : c (Fin.last n) = k) + (h : popCount (par ∘ c) = + popCount (par ∘ c') + (bif par k then 1 else 0)) : + S.nIn (n + 1) c = + eqToHom (congrArg (tensorPow A U) h) ≫ + (tailIso U (popCount (par ∘ c')) (par k)).inv ≫ + (S.nIn n c' ⊗ₘ S.ins k) := by + subst hc + subst hk + exact S.nIn_succ n c + +/-- The complete gluing of the top-fixing case. All specific +morphisms enter as parameters, so the tensor-power arities never +meet a rewrite. -/ +private theorem ext_glue + [Category.{v} A] [MonoidalCategory A] [Preadditive A] [Linear ℂ A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] + {W W' Xa Xb Pd Pe Pn L N : A} + (E₀ : W ⟶ Xa) (Ti : Xa ⟶ Pd ⊗ L) (I : Pd ⟶ Pn) (J : L ⟶ N) + (G : Pn ⟶ Pn) (a : ℂ) (Ec : Pd ⟶ Pe) (I' : Pe ⟶ Pn) + (Ed : Xa ⟶ Xb) (Ti' : Xb ⟶ Pe ⊗ L) (Eh : W ⟶ W') (E₂ : W' ⟶ Xb) + (hI : I ≫ G = a • (Ec ≫ I')) + (hT : Ti ≫ (Ec ▷ L) = Ed ≫ Ti') + (hE : E₀ ≫ Ed = Eh ≫ E₂) : + (E₀ ≫ Ti ≫ (I ⊗ₘ J)) ≫ (G ▷ N) = + a • (Eh ≫ E₂ ≫ Ti' ≫ (I' ⊗ₘ J)) := by + calc (E₀ ≫ Ti ≫ (I ⊗ₘ J)) ≫ (G ▷ N) + = E₀ ≫ Ti ≫ ((I ≫ G) ⊗ₘ J) := by + simp only [Category.assoc] + rw [tensor_then_whisker] + _ = a • (E₀ ≫ Ti ≫ ((Ec ≫ I') ⊗ₘ J)) := by + rw [hI, smul_tensorHom] + simp only [Linear.comp_smul] + _ = a • (E₀ ≫ (Ti ≫ (Ec ▷ L)) ≫ (I' ⊗ₘ J)) := by + rw [← whisker_then_tensor] + simp only [Category.assoc] + _ = a • ((E₀ ≫ Ed) ≫ Ti' ≫ (I' ⊗ₘ J)) := by + rw [hT] + simp only [Category.assoc] + _ = a • (Eh ≫ E₂ ≫ Ti' ≫ (I' ⊗ₘ J)) := by + rw [hE] + simp only [Category.assoc] + +/-- The sign transport lifts along a top-fixing extension. -/ +private theorem signStmt_extPerm + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] {K : Type} [Fintype K] {par : K → Bool} {U : A} + {M : A} + (S : MixedLetters K par U M) + {n : ℕ} {τ : Equiv.Perm (Fin n)} (hτ : S.SignStmt n τ) + (hε : ∀ c : Fin (n + 1) → K, + parSign (extPerm τ) (par ∘ c) = + parSign τ (par ∘ (c ∘ Fin.castSucc))) : + S.SignStmt (n + 1) (extPerm τ) := by + intro c h + have hcount : popCount (par ∘ permIndex (extPerm τ) c) = + popCount (par ∘ permIndex τ (c ∘ Fin.castSucc)) + + (bif par (c (Fin.last n)) then 1 else 0) := by + have h1 := popCount_succ (par ∘ permIndex (extPerm τ) c) + rw [h1, + show (par ∘ permIndex (extPerm τ) c) ∘ Fin.castSucc = + par ∘ permIndex τ (c ∘ Fin.castSucc) from + congrArg (fun f => par ∘ f) (permIndex_extPerm_castSucc τ c), + show (par ∘ permIndex (extPerm τ) c) (Fin.last n) = + par (c (Fin.last n)) from + congrArg par (permIndex_extPerm_last τ c)] + rw [permMor_extPerm, + S.nIn_split n c (c ∘ Fin.castSucc) (c (Fin.last n)) rfl rfl + (popCount_split c), + S.nIn_split n (permIndex (extPerm τ) c) + (permIndex τ (c ∘ Fin.castSucc)) (c (Fin.last n)) + (permIndex_extPerm_castSucc τ c) (permIndex_extPerm_last τ c) + hcount, + hε c] + exact ext_glue _ _ _ _ _ _ _ _ _ _ _ _ + (hτ (c ∘ Fin.castSucc) + (popCount_permIndex' τ (c ∘ Fin.castSucc))) + (tailIso_inv_cast U (popCount_permIndex' τ (c ∘ Fin.castSucc)) + (par (c (Fin.last n)))) + (by rw [eqToHom_trans, eqToHom_trans]) + +/-- Prefixing a scalar identity of chains. Stated at general +objects. -/ +private theorem smul_chain_glue [Category.{v} A] [Preadditive A] [Linear ℂ A] + {W X Y : A} (E E' : W ⟶ X) + (hE : E = E') (F G : X ⟶ Y) (a : ℂ) (hFG : F = a • G) : + E ≫ F = a • (E' ≫ G) := by + subst hE + rw [hFG, Linear.comp_smul] + +/-- The letter-swap chain at two even letters. -/ +private theorem chain_ff + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] {U : A} + (m : ℕ) (a : ℂ) (ha : a = 1) + (E : tensorPow A U m ⟶ tensorPow A U m) (hE : E = 𝟙 _) : + (ρ_ (tensorPow A U m)).inv ≫ + ((ρ_ (tensorPow A U m)).inv ▷ 𝟙_ A) ≫ + (α_ (tensorPow A U m) (𝟙_ A) (𝟙_ A)).hom ≫ + (tensorPow A U m ◁ (β_ (𝟙_ A) (𝟙_ A)).hom) ≫ + (α_ (tensorPow A U m) (𝟙_ A) (𝟙_ A)).inv = + a • (E ≫ (ρ_ (tensorPow A U m)).inv ≫ + ((ρ_ (tensorPow A U m)).inv ▷ 𝟙_ A)) := by + subst ha + rw [hE, one_smul, Category.id_comp, + letter_swap_unit_unit (tensorPow A U m), Category.comp_id] + +/-- The letter-swap chain at an even letter under an odd one. -/ +private theorem chain_ft + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] {U : A} + (m : ℕ) (a : ℂ) (ha : a = 1) + (E : tensorPow A U m ⊗ U ⟶ tensorPow A U m ⊗ U) (hE : E = 𝟙 _) : + 𝟙 (tensorPow A U m ⊗ U) ≫ + ((ρ_ (tensorPow A U m)).inv ▷ U) ≫ + (α_ (tensorPow A U m) (𝟙_ A) U).hom ≫ + (tensorPow A U m ◁ (β_ (𝟙_ A) U).hom) ≫ + (α_ (tensorPow A U m) U (𝟙_ A)).inv = + a • (E ≫ (ρ_ (tensorPow A U m ⊗ U)).inv ≫ + (𝟙 (tensorPow A U m ⊗ U) ▷ 𝟙_ A)) := by + subst ha + rw [hE, one_smul, Category.id_comp, Category.id_comp, + MonoidalCategory.id_whiskerRight, Category.comp_id] + exact letter_swap_unit_odd (tensorPow A U m) U + +/-- The letter-swap chain at an odd letter under an even one. -/ +private theorem chain_tf + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] {U : A} + (m : ℕ) (a : ℂ) (ha : a = 1) + (E : tensorPow A U m ⊗ U ⟶ tensorPow A U m ⊗ U) (hE : E = 𝟙 _) : + (ρ_ (tensorPow A U m ⊗ U)).inv ≫ + (𝟙 (tensorPow A U m ⊗ U) ▷ 𝟙_ A) ≫ + (α_ (tensorPow A U m) U (𝟙_ A)).hom ≫ + (tensorPow A U m ◁ (β_ U (𝟙_ A)).hom) ≫ + (α_ (tensorPow A U m) (𝟙_ A) U).inv = + a • (E ≫ 𝟙 (tensorPow A U m ⊗ U) ≫ + ((ρ_ (tensorPow A U m)).inv ▷ U)) := by + subst ha + rw [hE, one_smul, MonoidalCategory.id_whiskerRight, + Category.id_comp, Category.id_comp, Category.id_comp] + exact letter_swap_odd_unit (tensorPow A U m) U + +/-- The letter-swap chain at two odd letters: the sign appears. -/ +private theorem chain_tt + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] {U : A} + (hβ : (β_ U U).hom = -(𝟙 (U ⊗ U))) + (m : ℕ) (a : ℂ) (ha : a = -1) + (E : (tensorPow A U m ⊗ U) ⊗ U ⟶ (tensorPow A U m ⊗ U) ⊗ U) + (hE : E = 𝟙 _) : + 𝟙 ((tensorPow A U m ⊗ U) ⊗ U) ≫ + (𝟙 (tensorPow A U m ⊗ U) ▷ U) ≫ + (α_ (tensorPow A U m) U U).hom ≫ + (tensorPow A U m ◁ (β_ U U).hom) ≫ + (α_ (tensorPow A U m) U U).inv = + a • (E ≫ 𝟙 ((tensorPow A U m ⊗ U) ⊗ U) ≫ + (𝟙 (tensorPow A U m ⊗ U) ▷ U)) := by + subst ha + rw [hE, Category.id_comp, MonoidalCategory.id_whiskerRight, + Category.id_comp, Category.id_comp, Category.id_comp, + letter_swap_odd_odd (tensorPow A U m) hβ] + exact (neg_one_smul ℂ _).symm + +/-- **The letter-swap core**: on normal forms, braiding the top two +letters is the transport to the swapped word, with sign `−1` +exactly when both letters are odd. The case analysis on the two +letters happens here, where they are free Booleans. -/ +private theorem tail_swap_core + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] {U : A} + (hβ : (β_ U U).hom = -(𝟙 (U ⊗ U))) + (m : ℕ) (b₁ b₂ : Bool) + (hQ : tensorPow A U + (m + (bif b₁ then 1 else 0) + (bif b₂ then 1 else 0)) = + tensorPow A U + (m + (bif b₂ then 1 else 0) + (bif b₁ then 1 else 0))) : + (tailIso U (m + (bif b₁ then 1 else 0)) b₂).inv ≫ + ((tailIso U m b₁).inv ▷ (bif b₂ then U else 𝟙_ A)) ≫ + (α_ (tensorPow A U m) (bif b₁ then U else 𝟙_ A) + (bif b₂ then U else 𝟙_ A)).hom ≫ + (tensorPow A U m ◁ + (β_ (bif b₁ then U else 𝟙_ A) (bif b₂ then U else 𝟙_ A)).hom) + ≫ + (α_ (tensorPow A U m) (bif b₂ then U else 𝟙_ A) + (bif b₁ then U else 𝟙_ A)).inv = + (if b₁ = true ∧ b₂ = true then (-1 : ℂ) else 1) • + (eqToHom hQ ≫ + (tailIso U (m + (bif b₂ then 1 else 0)) b₁).inv ≫ + ((tailIso U m b₂).inv ▷ (bif b₁ then U else 𝟙_ A))) := by + cases b₁ <;> cases b₂ + · exact chain_ff m _ (by simp) _ (eqToHom_refl _ _) + · exact chain_ft m _ (by simp) _ (eqToHom_refl _ _) + · exact chain_tf m _ (by simp) _ (eqToHom_refl _ _) + · exact chain_tt hβ m _ (by simp) _ (eqToHom_refl _ _) + +/-- The complete gluing of the top-transposition case: the two +letter maps exchange through the braiding of the ambient object, +and everything else is carried by the core hypothesis. Stated at +general objects. -/ +private theorem topSwap_glue + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] + {W W' Xa Xb Xc Xd Q₂ Q₁ P Pm L₁ L₂ N : A} + (a : ℂ) + (E₀ : W ⟶ Xa) (T₂i : Xa ⟶ Q₂ ⊗ L₂) + (E₁ : Q₂ ⟶ Xc) (T₁i : Xc ⟶ P ⊗ L₁) + (I : P ⟶ Pm) (J₁ : L₁ ⟶ N) (J₂ : L₂ ⟶ N) + (Eh : W ⟶ W') (E₂ : W' ⟶ Xb) (T₂i' : Xb ⟶ Q₁ ⊗ L₁) + (E₁' : Q₁ ⟶ Xd) (T₁i' : Xd ⟶ P ⊗ L₂) + (hcore : E₀ ≫ T₂i ≫ ((E₁ ≫ T₁i) ▷ L₂) ≫ (α_ P L₁ L₂).hom ≫ + (P ◁ (β_ L₁ L₂).hom) ≫ (α_ P L₂ L₁).inv = + a • (Eh ≫ E₂ ≫ T₂i' ≫ ((E₁' ≫ T₁i') ▷ L₁))) : + (E₀ ≫ T₂i ≫ ((E₁ ≫ T₁i ≫ (I ⊗ₘ J₁)) ⊗ₘ J₂)) ≫ + (α_ Pm N N).hom ≫ (Pm ◁ (β_ N N).hom) ≫ (α_ Pm N N).inv = + a • (Eh ≫ E₂ ≫ T₂i' ≫ ((E₁' ≫ T₁i' ≫ (I ⊗ₘ J₂)) ⊗ₘ J₁)) := by + have hsplit : (E₁ ≫ T₁i ≫ (I ⊗ₘ J₁)) ⊗ₘ J₂ = + ((E₁ ≫ T₁i) ▷ L₂) ≫ ((I ⊗ₘ J₁) ⊗ₘ J₂) := by + rw [whisker_then_tensor] + simp only [Category.assoc] + have hsplit' : (E₁' ≫ T₁i' ≫ (I ⊗ₘ J₂)) ⊗ₘ J₁ = + ((E₁' ≫ T₁i') ▷ L₁) ≫ ((I ⊗ₘ J₂) ⊗ₘ J₁) := by + rw [whisker_then_tensor] + simp only [Category.assoc] + rw [hsplit, hsplit'] + simp only [Category.assoc] + rw [tensor_swap_exchange I J₁ J₂] + have h1 := congrArg (fun t => t ≫ ((I ⊗ₘ J₂) ⊗ₘ J₁)) hcore + simp only [Category.assoc, Linear.smul_comp] at h1 + exact h1 +/-- Composing a scalar identity of chains across a transport. +Stated at general objects. -/ +private theorem smul_cast_glue [Category.{v} A] [Preadditive A] [Linear ℂ A] + {W X X' Y : A} (E : W ⟶ X) + (Ecast : X ⟶ X') (E' : W ⟶ X') (F : X ⟶ Y) (G : X' ⟶ Y) (a : ℂ) + (hEE : E ≫ Ecast = E') (hFG : F = a • (Ecast ≫ G)) : + E ≫ F = a • (E' ≫ G) := by + rw [hFG, Linear.comp_smul, ← Category.assoc, hEE] + +/-- The sign transport holds for the top transposition. -/ +private theorem signStmt_topSwap + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] {K : Type} [Fintype K] {par : K → Bool} {U : A} + {M : A} + (S : MixedLetters K par U M) + (hβ : (β_ U U).hom = -(𝟙 (U ⊗ U))) {n : ℕ} : + S.SignStmt (n + 2) (topSwap : Equiv.Perm (Fin (n + 2))) := by + intro c h + have hd_last : permIndex topSwap c (Fin.last (n + 1)) = + c (Fin.castSucc (Fin.last n)) := permIndex_topSwap_last c + have hd_mid : (permIndex topSwap c ∘ Fin.castSucc) (Fin.last n) = + c (Fin.last (n + 1)) := permIndex_topSwap_castSucc_last c + have hd_low : (permIndex topSwap c ∘ Fin.castSucc) ∘ Fin.castSucc = + c ∘ Fin.castSucc ∘ Fin.castSucc := permIndex_topSwap_low c + have hm₁ : popCount (par ∘ (c ∘ Fin.castSucc)) = + popCount (par ∘ (c ∘ Fin.castSucc ∘ Fin.castSucc)) + + (bif par (c (Fin.castSucc (Fin.last n))) then 1 else 0) := + popCount_split (c ∘ Fin.castSucc) + have hcount₁ : popCount (par ∘ permIndex topSwap c) = + popCount (par ∘ (permIndex topSwap c ∘ Fin.castSucc)) + + (bif par (c (Fin.castSucc (Fin.last n))) then 1 else 0) := by + have h0 := popCount_split (par := par) (permIndex topSwap c) + rwa [show par (permIndex topSwap c (Fin.last (n + 1))) = + par (c (Fin.castSucc (Fin.last n))) from congrArg par hd_last] + at h0 + have hcount₂ : + popCount (par ∘ (permIndex topSwap c ∘ Fin.castSucc)) = + popCount (par ∘ (c ∘ Fin.castSucc ∘ Fin.castSucc)) + + (bif par (c (Fin.last (n + 1))) then 1 else 0) := by + have h0 := popCount_split (par := par) + (permIndex topSwap c ∘ Fin.castSucc) + rwa [show par ((permIndex topSwap c ∘ Fin.castSucc) (Fin.last n)) + = par (c (Fin.last (n + 1))) from congrArg par hd_mid, + show (permIndex topSwap c ∘ Fin.castSucc) ∘ Fin.castSucc = + c ∘ Fin.castSucc ∘ Fin.castSucc from hd_low] at h0 + have hws : parSign topSwap (par ∘ c) = + if par (c (Fin.castSucc (Fin.last n))) = true ∧ + par (c (Fin.last (n + 1))) = true then (-1 : ℂ) else 1 := by + rw [show (topSwap : Equiv.Perm (Fin (n + 2))) = + Equiv.swap (Fin.last n).castSucc (Fin.last n).succ from by + rw [topSwap, Fin.succ_last], + parSign_swap (Fin.last n) (par ∘ c), + show (Fin.last n).succ = Fin.last (n + 1) from Fin.succ_last n] + rfl + rw [permMor_topSwap_eq, + show swapTop M n = (α_ (tensorPow A M n) M M).hom ≫ + (tensorPow A M n ◁ (β_ M M).hom) ≫ + (α_ (tensorPow A M n) M M).inv from rfl, + S.nIn_split (n + 1) c (c ∘ Fin.castSucc) (c (Fin.last (n + 1))) + rfl rfl (popCount_split c), + S.nIn_split n (c ∘ Fin.castSucc) + (c ∘ Fin.castSucc ∘ Fin.castSucc) + (c (Fin.castSucc (Fin.last n))) rfl rfl hm₁, + S.nIn_split (n + 1) (permIndex topSwap c) + (permIndex topSwap c ∘ Fin.castSucc) + (c (Fin.castSucc (Fin.last n))) rfl hd_last hcount₁, + S.nIn_split n (permIndex topSwap c ∘ Fin.castSucc) + (c ∘ Fin.castSucc ∘ Fin.castSucc) (c (Fin.last (n + 1))) + hd_low hd_mid hcount₂, + hws] + refine topSwap_glue _ _ _ _ _ _ _ _ _ _ _ _ _ ?_ + rw [MonoidalCategory.comp_whiskerRight, + MonoidalCategory.comp_whiskerRight] + simp only [Category.assoc] + rw [tailIso_inv_cast_assoc U hm₁ (par (c (Fin.last (n + 1)))), + tailIso_inv_cast_assoc U hcount₂ + (par (c (Fin.castSucc (Fin.last n)))), + eqToHom_trans_assoc, eqToHom_trans_assoc, eqToHom_trans_assoc] + exact smul_cast_glue _ + (eqToHom (congrArg (tensorPow A U) + (Nat.add_right_comm + (popCount (par ∘ (c ∘ Fin.castSucc ∘ Fin.castSucc))) + (bif par (c (Fin.castSucc (Fin.last n))) then 1 else 0) + (bif par (c (Fin.last (n + 1))) then 1 else 0)))) _ _ _ _ + (by rw [eqToHom_trans]) + (tail_swap_core hβ + (popCount (par ∘ (c ∘ Fin.castSucc ∘ Fin.castSucc))) + (par (c (Fin.castSucc (Fin.last n)))) + (par (c (Fin.last (n + 1)))) + (congrArg (tensorPow A U) + (Nat.add_right_comm + (popCount (par ∘ (c ∘ Fin.castSucc ∘ Fin.castSucc))) + (bif par (c (Fin.castSucc (Fin.last n))) then 1 else 0) + (bif par (c (Fin.last (n + 1))) then 1 else 0)))) + +/-- The sign transport holds for every permutation: generators and +closure. -/ +private theorem signStmt_all + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] {K : Type} [Fintype K] {par : K → Bool} {U : A} + {M : A} + (S : MixedLetters K par U M) + (hβ : (β_ U U).hom = -(𝟙 (U ⊗ U))) : + ∀ (n : ℕ) (σ : Equiv.Perm (Fin n)), S.SignStmt n σ := by + intro n + induction n with + | zero => + intro σ + rw [show σ = 1 from Equiv.ext fun x => x.elim0] + exact S.signStmt_one 0 + | succ n' ih => + match n' with + | 0 => + intro σ + rw [show σ = 1 from Equiv.ext fun x => Fin.ext (by omega)] + exact S.signStmt_one 1 + | n'' + 1 => + intro σ + have hgen : ∀ i : Fin (n'' + 1), + S.SignStmt (n'' + 2) (Equiv.swap i.castSucc i.succ) := by + intro i + refine Fin.lastCases ?_ (fun j => ?_) i + · rw [show Equiv.swap (Fin.castSucc (Fin.last n'')) + (Fin.last n'').succ = + (topSwap : Equiv.Perm (Fin (n'' + 2))) from by + rw [topSwap, Fin.succ_last]] + exact S.signStmt_topSwap hβ + · rw [swap_castSucc_succ_castSucc j] + refine S.signStmt_extPerm + (ih (Equiv.swap j.castSucc j.succ)) ?_ + intro c + rw [← swap_castSucc_succ_castSucc j, + parSign_swap (Fin.castSucc j) (par ∘ c), + parSign_swap j (par ∘ (c ∘ Fin.castSucc)), + Fin.succ_castSucc] + rfl + have key : ∀ τ : Equiv.Perm (Fin (n'' + 2)), + τ ∈ Submonoid.closure + (Set.range fun i : Fin (n'' + 1) => + Equiv.swap i.castSucc i.succ) → + S.SignStmt (n'' + 2) τ := by + intro τ hτ + induction hτ using Submonoid.closure_induction_left with + | one => exact S.signStmt_one _ + | mul_left g hg τ' hτ' ihτ' => + obtain ⟨i, rfl⟩ := hg + exact S.signStmt_mul (hgen i) ihτ' + exact key σ (by + rw [Equiv.Perm.mclosure_swap_castSucc_succ]; trivial) + +/-- **The sign transport of the permutation action**: on normal +forms, a permutation acts on a colouring of a letter system by the +transport to the shuffled colouring, scaled by the combinatorial +Koszul sign of the shuffle. -/ +theorem nIn_permMor [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] {K : Type} [Fintype K] {par : K → Bool} {U : A} + {M : A} + (S : MixedLetters K par U M) + (hβ : (β_ U U).hom = -(𝟙 (U ⊗ U))) {n : ℕ} + (σ : Equiv.Perm (Fin n)) (c : Fin n → K) + (h : popCount (par ∘ c) = popCount (par ∘ permIndex σ c)) : + S.nIn n c ≫ permMor M n σ = + parSign σ (par ∘ c) • + (eqToHom (congrArg (tensorPow A U) h) ≫ + S.nIn n (permIndex σ c)) := + S.signStmt_all hβ n σ c h + +end MixedLetters + +/-! ## The colour sum + +The matrix coefficient of a group-algebra element between two +colourings: the sum of its coefficients over the permutations +routing the one colouring to the other, weighted by the Koszul +sign. It is purely combinatorial — the same scalar in every +ambient category carrying a letter system. -/ + +/-- **The colour sum**: the signed coefficient sum of a +group-algebra element over the permutations carrying `c` to `d`. -/ +noncomputable def colourSum {K : Type} [DecidableEq K] + (par : K → Bool) {n : ℕ} (x : SymGroupAlgebra n) + (c d : Fin n → K) : ℂ := + ∑ σ ∈ Finset.univ.filter + (fun σ : Equiv.Perm (Fin n) => permIndex σ c = d), + x.coeff σ * parSign σ (par ∘ c) + +/-- The colour sum vanishes between colourings of different +counts. -/ +theorem colourSum_eq_zero_of_ne {K : Type} [DecidableEq K] + (par : K → Bool) {n : ℕ} (x : SymGroupAlgebra n) + {c d : Fin n → K} + (h : popCount (par ∘ c) ≠ popCount (par ∘ d)) : + colourSum par x c d = 0 := by + rw [colourSum] + refine Finset.sum_eq_zero fun σ hσ => ?_ + exfalso + refine h ?_ + rw [← (Finset.mem_filter.mp hσ).2] + exact (popCount_permIndex σ (par ∘ c)).symm + +namespace MixedLetters + +section Entries + +variable {A : Type u} + +/-- The group-algebra action expanded over the group. -/ +private theorem permAlg_expand + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] + (X : A) {n : ℕ} + (x : SymGroupAlgebra n) : + permAlg X n x = ∑ σ : Equiv.Perm (Fin n), x.coeff σ • permMor X n σ + := by + classical + have hlift : permAlg X n x = + x.coeff.sum fun σ r => r • permMor X n σ := by + rw [permAlg] + exact MonoidAlgebra.lift_apply _ _ + rw [hlift, show (x.coeff.sum fun σ r => r • permMor X n σ) = + ∑ σ ∈ x.coeff.support, x.coeff σ • permMor X n σ from rfl] + refine Finset.sum_subset (Finset.subset_univ _) fun σ _ hσ => ?_ + rw [Finsupp.notMem_support_iff.mp hσ, zero_smul] + +/-- The round trip through equal colourings is the transport. -/ +private theorem nIn_nOut_of_eq + [Category.{v} A] [MonoidalCategory A] [Preadditive A] {K : Type} + [Fintype K] {par : K → Bool} {U : A} {M : A} + (S : MixedLetters K par U M) {n : ℕ} + {c' d : Fin n → K} (hcd : c' = d) : + S.nIn n c' ≫ S.nOut n d = + eqToHom (congrArg (fun e => tensorPow A U (popCount (par ∘ e))) + hcd) := by + subst hcd + rw [S.nIn_nOut_same] + exact (eqToHom_refl _ _).symm + +/-- **The entry formula**: between two colourings, the normalised +matrix entry of a group-algebra element is the colour sum times the +count transport. -/ +theorem nIn_permAlg_nOut + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] {K : Type} [Fintype K] [DecidableEq K] + {par : K → Bool} {U : A} {M : A} + (S : MixedLetters K par U M) + (hβ : (β_ U U).hom = -(𝟙 (U ⊗ U))) {n : ℕ} + (x : SymGroupAlgebra n) (c d : Fin n → K) : + S.nIn n c ≫ permAlg M n x ≫ S.nOut n d = + if hpop : popCount (par ∘ c) = popCount (par ∘ d) then + colourSum par x c d • + eqToHom (congrArg (tensorPow A U) hpop) + else 0 := by + have hstep : S.nIn n c ≫ permAlg M n x ≫ S.nOut n d = + ∑ σ : Equiv.Perm (Fin n), + ((x.coeff σ * parSign σ (par ∘ c)) • + (eqToHom (congrArg (tensorPow A U) + (popCount_permIndex' σ c)) ≫ + S.nIn n (permIndex σ c))) ≫ S.nOut n d := by + rw [permAlg_expand M x, Preadditive.sum_comp, + Preadditive.comp_sum] + refine Finset.sum_congr rfl fun σ _ => ?_ + rw [Linear.smul_comp, Linear.comp_smul, ← Category.assoc, + S.nIn_permMor hβ σ c (popCount_permIndex' σ c), + Linear.smul_comp, smul_smul, Linear.smul_comp] + rw [hstep] + by_cases hpop : popCount (par ∘ c) = popCount (par ∘ d) + · rw [dite_eq_left hpop, colourSum, Finset.sum_filter, + Finset.sum_smul] + refine Finset.sum_congr rfl fun σ _ => ?_ + by_cases hσ : permIndex σ c = d + · rw [ite_eq_left hσ, Linear.smul_comp, Category.assoc, + S.nIn_nOut_of_eq hσ, eqToHom_trans] + · rw [ite_eq_right hσ, Linear.smul_comp, Category.assoc, + S.nIn_nOut_ne n hσ, Limits.comp_zero, smul_zero, zero_smul] + · rw [dite_eq_right hpop] + refine Finset.sum_eq_zero fun σ _ => ?_ + have hσ : permIndex σ c ≠ d := fun hcd => hpop (by + rw [← hcd] + exact popCount_permIndex' σ c) + rw [Linear.smul_comp, Category.assoc, S.nIn_nOut_ne n hσ, + Limits.comp_zero, smul_zero] + +/-- The colouring projection factors through its normalised form. -/ +theorem colourFrom_eq_nOut + [Category.{v} A] [MonoidalCategory A] [Preadditive A] {K : Type} + [Fintype K] {par : K → Bool} {U : A} {M : A} + (S : MixedLetters K par U M) (n : ℕ) + (d : Fin n → K) : + S.colourFrom n d = S.nOut n d ≫ (normIso U n (par ∘ d)).inv := by + rw [nOut, Category.assoc, Iso.hom_inv_id, Category.comp_id] + +/-- **Extraction**: if a group-algebra element acts as zero on the +tensor power of the mixed object, all its colour sums vanish — +provided no power of the odd line is a zero object. -/ +theorem colourSum_eq_zero + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] {K : Type} [Fintype K] [DecidableEq K] + {par : K → Bool} {U : A} {M : A} + (S : MixedLetters K par U M) + (hβ : (β_ U U).hom = -(𝟙 (U ⊗ U))) + (hU : ∀ k : ℕ, 𝟙 (tensorPow A U k) ≠ + (0 : tensorPow A U k ⟶ tensorPow A U k)) + {n : ℕ} {x : SymGroupAlgebra n} (hx : permAlg M n x = 0) + (c d : Fin n → K) : colourSum par x c d = 0 := by + by_cases hpop : popCount (par ∘ c) = popCount (par ∘ d) + · have hx' : permAlg M n x = + (0 : tensorPow A M n ⟶ tensorPow A M n) := hx + have h0 : S.nIn n c ≫ permAlg M n x ≫ S.nOut n d = 0 := by + rw [hx', Limits.zero_comp, Limits.comp_zero] + rw [S.nIn_permAlg_nOut hβ x c d, dite_eq_left hpop] at h0 + by_contra hne + have h1 : eqToHom (congrArg (tensorPow A U) hpop) = + (0 : tensorPow A U (popCount (par ∘ c)) ⟶ + tensorPow A U (popCount (par ∘ d))) := by + have h2 := congrArg + (fun t => (colourSum par x c d)⁻¹ • t) h0 + simp only [smul_smul, inv_mul_cancel₀ hne, one_smul, + smul_zero] at h2 + exact h2 + have h3 : 𝟙 (tensorPow A U (popCount (par ∘ c))) = + (0 : tensorPow A U (popCount (par ∘ c)) ⟶ + tensorPow A U (popCount (par ∘ c))) := by + have h4 := congrArg (fun t => t ≫ + eqToHom (congrArg (tensorPow A U) hpop).symm) h1 + simpa only [eqToHom_trans, eqToHom_refl, Limits.zero_comp] + using h4 + exact hU _ h3 + · exact colourSum_eq_zero_of_ne par x hpop + +/-- **Reconstruction**: if all colour sums of a group-algebra +element vanish, it acts as zero on the tensor power of the mixed +object. -/ +theorem permAlg_eq_zero + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] {K : Type} [Fintype K] [DecidableEq K] + {par : K → Bool} {U : A} {M : A} + (S : MixedLetters K par U M) + (hβ : (β_ U U).hom = -(𝟙 (U ⊗ U))) {n : ℕ} + {x : SymGroupAlgebra n} + (hx : ∀ c d : Fin n → K, colourSum par x c d = 0) : + permAlg M n x = 0 := by + have hmid : ∀ c d : Fin n → K, + S.colourInto n c ≫ permAlg M n x ≫ S.colourFrom n d = 0 := by + intro c d + calc S.colourInto n c ≫ permAlg M n x ≫ S.colourFrom n d + = (normIso U n (par ∘ c)).hom ≫ + (S.nIn n c ≫ permAlg M n x ≫ S.nOut n d) ≫ + (normIso U n (par ∘ d)).inv := by + rw [S.colourInto_eq_nIn n c, S.colourFrom_eq_nOut n d] + simp only [Category.assoc] + _ = 0 := by + rw [S.nIn_permAlg_nOut hβ x c d] + by_cases hpop : popCount (par ∘ c) = popCount (par ∘ d) + · rw [dite_eq_left hpop, hx c d, zero_smul, Limits.zero_comp, + Limits.comp_zero] + · rw [dite_eq_right hpop, Limits.zero_comp, Limits.comp_zero] + have hmid2 : ∀ c : Fin n → K, + S.colourInto n c ≫ permAlg M n x ≫ + (∑ d : Fin n → K, S.colourFrom n d ≫ S.colourInto n d) = 0 + := by + intro c + rw [Preadditive.comp_sum, Preadditive.comp_sum] + refine Finset.sum_eq_zero fun d _ => ?_ + rw [show S.colourInto n c ≫ permAlg M n x ≫ + S.colourFrom n d ≫ S.colourInto n d = + (S.colourInto n c ≫ permAlg M n x ≫ S.colourFrom n d) ≫ + S.colourInto n d from by simp only [Category.assoc]] + rw [hmid c d, Limits.zero_comp] + calc permAlg M n x + = 𝟙 (tensorPow A M n) ≫ permAlg M n x ≫ + 𝟙 (tensorPow A M n) := by + rw [Category.id_comp, Category.comp_id] + _ = (∑ c : Fin n → K, S.colourFrom n c ≫ S.colourInto n c) ≫ + permAlg M n x ≫ + (∑ d : Fin n → K, S.colourFrom n d ≫ S.colourInto n d) := by + rw [S.sum_colourFrom_colourInto n] + _ = ∑ c : Fin n → K, S.colourFrom n c ≫ + (S.colourInto n c ≫ permAlg M n x ≫ + (∑ d : Fin n → K, S.colourFrom n d ≫ S.colourInto n d)) + := by + rw [Preadditive.sum_comp] + refine Finset.sum_congr rfl fun c _ => ?_ + simp only [Category.assoc] + _ = 0 := by + refine Finset.sum_eq_zero fun c _ => ?_ + rw [hmid2 c, Limits.comp_zero] + +end Entries + +end MixedLetters + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Signs.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Signs.lean new file mode 100644 index 0000000000..7e2d27fb56 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Signs.lean @@ -0,0 +1,426 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarBraiding +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperVectSchur + +/-! +# Slot labellings and the Koszul sign of a permutation + +The combinatorial half of the transport. A word `Fin n → Bool` +records which slots of a tensor power carry the odd line, a +permutation reindexes it, and the induced permutation of the odd +slots alone has a sign — the sign a symmetric category produces +when the letters of the word are permuted, one factor of `−1` per +crossing of two odd letters. Nothing here mentions a category; the +categorical side consumes it in [Letters.lean](Letters.lean). + +* `permIndex`: the reindexing of a slot labelling by a + permutation, with its two functoriality laws. +* `trueSet`, `popCount_eq_card`: the odd slots of a word. +* `oddPerm`, `parSign`: the induced permutation of the odd slots + and its sign, with `oddPerm_mul` and `parSign_mul`, and the value + `parSign_swap` on an adjacent transposition. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +/-! ## Reindexing slot labellings + +A permutation routes the factor in slot `i` to slot `σ i` +(`permMor`); the labelling of the slots follows along. -/ + +/-- Reindexing a slot labelling along a permutation: the label of +slot `i` moves to slot `σ i`. -/ +def permIndex {K : Type*} {n : ℕ} (σ : Equiv.Perm (Fin n)) + (c : Fin n → K) : Fin n → K := + c ∘ ⇑σ⁻¹ + +/-- The identity permutation does not move labels. -/ +@[simp] +theorem permIndex_one {K : Type*} {n : ℕ} (c : Fin n → K) : + permIndex 1 c = c := rfl + +/-- The label a slot receives under reindexing. -/ +theorem permIndex_apply {K : Type*} {n : ℕ} + (σ : Equiv.Perm (Fin n)) (c : Fin n → K) (i : Fin n) : + permIndex σ c i = c (σ⁻¹ i) := rfl + +/-- The label of the image slot is the original label. -/ +theorem permIndex_apply_self {K : Type*} {n : ℕ} + (σ : Equiv.Perm (Fin n)) (c : Fin n → K) (i : Fin n) : + permIndex σ c (σ i) = c i := by + rw [permIndex_apply] + exact congrArg c (σ.symm_apply_apply i) + +/-! ## The odd slots of a word and the Koszul sign + +For a parity word `w : Fin n → Bool` the `true` slots are the odd +ones. A permutation induces a bijection from the odd slots of `w` +to those of the shuffled word; conjugating by the monotone +enumerations gives a permutation of `Fin (popCount w)` whose sign +is the Koszul sign of the shuffle. -/ + +/-- The set of `true` slots of a word. -/ +def trueSet {n : ℕ} (w : Fin n → Bool) : Finset (Fin n) := + Finset.univ.filter fun i => w i = true + +/-- Membership in the `true` slots. -/ +theorem mem_trueSet {n : ℕ} {w : Fin n → Bool} {i : Fin n} : + i ∈ trueSet w ↔ w i = true := by + simp [trueSet] + +/-- `popCount` is the size of the set of `true` slots. -/ +theorem popCount_eq_card {n : ℕ} (w : Fin n → Bool) : + popCount w = (trueSet w).card := rfl + +/-- Reindexing maps the `true` slots along the permutation. -/ +theorem trueSet_permIndex {n : ℕ} (σ : Equiv.Perm (Fin n)) + (w : Fin n → Bool) : + trueSet (permIndex σ w) = (trueSet w).map σ.toEmbedding := by + ext j + simp only [mem_trueSet, Finset.mem_map, Equiv.coe_toEmbedding] + constructor + · intro hj + exact ⟨σ⁻¹ j, hj, σ.apply_symm_apply j⟩ + · rintro ⟨i, hi, rfl⟩ + rw [permIndex_apply_self] + exact hi + +/-- Reindexing preserves the number of `true` slots. -/ +theorem popCount_permIndex {n : ℕ} (σ : Equiv.Perm (Fin n)) + (w : Fin n → Bool) : + popCount (permIndex σ w) = popCount w := by + rw [popCount_eq_card, popCount_eq_card, trueSet_permIndex, + Finset.card_map] + +/-- The monotone enumeration of the `true` slots. -/ +noncomputable def trueEnum {n : ℕ} (w : Fin n → Bool) : + Fin (popCount w) ≃o {i // i ∈ trueSet w} := + (trueSet w).orderIsoOfFin rfl + +/-- A permutation carries the `true` slots of a word bijectively +onto the `true` slots of the shuffled word. -/ +def trueShift {n : ℕ} (σ : Equiv.Perm (Fin n)) (w : Fin n → Bool) : + {i // i ∈ trueSet w} ≃ {i // i ∈ trueSet (permIndex σ w)} := + (σ : Fin n ≃ Fin n).subtypeEquiv fun i => by + rw [mem_trueSet, mem_trueSet] + change w i = true ↔ permIndex σ w (σ i) = true + rw [permIndex_apply_self] + +/-- The shift, applied. -/ +theorem trueShift_apply {n : ℕ} (σ : Equiv.Perm (Fin n)) + (w : Fin n → Bool) (i : {i // i ∈ trueSet w}) : + (trueShift σ w i : Fin n) = σ i := rfl + +/-- **The induced permutation on the odd slots**: conjugate the +shift by the monotone enumerations. -/ +noncomputable def oddPerm {n : ℕ} (σ : Equiv.Perm (Fin n)) + (w : Fin n → Bool) : Equiv.Perm (Fin (popCount w)) := + (trueEnum w).toEquiv.trans ((trueShift σ w).trans + ((trueEnum (permIndex σ w)).toEquiv.symm.trans + (finCongr (popCount_permIndex σ w)))) + +/-- The induced permutation, applied. -/ +theorem oddPerm_apply {n : ℕ} (σ : Equiv.Perm (Fin n)) + (w : Fin n → Bool) (x : Fin (popCount w)) : + oddPerm σ w x = + finCongr (popCount_permIndex σ w) + ((trueEnum (permIndex σ w)).toEquiv.symm + (trueShift σ w (trueEnum w x))) := rfl + +/-- **The Koszul sign of a shuffle**: the sign of the induced +permutation of the odd slots. -/ +noncomputable def parSign {n : ℕ} (σ : Equiv.Perm (Fin n)) + (w : Fin n → Bool) : ℂ := + ((Equiv.Perm.sign (oddPerm σ w) : ℤ) : ℂ) + +/-- The identity shuffles nothing: its Koszul sign is `1`. -/ +@[simp] +theorem parSign_one {n : ℕ} (w : Fin n → Bool) : + parSign 1 w = 1 := by + have h : oddPerm 1 w = 1 := by + refine Equiv.ext fun x => ?_ + rw [oddPerm_apply] + have hmk : trueShift 1 w (trueEnum w x) = trueEnum w x := by + refine Subtype.ext ?_ + rw [trueShift_apply] + rfl + rw [hmk] + have hsymm : (trueEnum (permIndex 1 w)).toEquiv.symm + (trueEnum w x) = x := + (trueEnum w).toEquiv.symm_apply_apply x + rw [hsymm] + exact Fin.ext rfl + rw [parSign, h, Equiv.Perm.sign_one] + norm_num + +/-- A permutation acting strictly monotonically is the identity. -/ +private theorem perm_eq_one_of_strictMono {k : ℕ} + (π : Equiv.Perm (Fin k)) (h : StrictMono ⇑π) : π = 1 := by + have hinv : StrictMono ⇑π⁻¹ := by + intro a b hab + by_contra hle + have h1 : π⁻¹ b ≤ π⁻¹ a := not_lt.mp hle + have h2 : π (π⁻¹ b) ≤ π (π⁻¹ a) := h.monotone h1 + have e1 : π (π⁻¹ b) = b := π.apply_symm_apply b + have e2 : π (π⁻¹ a) = a := π.apply_symm_apply a + rw [e1, e2] at h2 + exact absurd hab (not_lt.mpr h2) + refine Equiv.ext fun x => ?_ + have h1 : x ≤ π x := h.le_apply + have h2 : π x ≤ π⁻¹ (π x) := hinv.le_apply + have e3 : π⁻¹ (π x) = x := π.symm_apply_apply x + rw [e3] at h2 + exact le_antisymm h2 h1 + +/-- The value of the induced permutation, as a slot number. -/ +theorem oddPerm_val {n : ℕ} (σ : Equiv.Perm (Fin n)) + (w : Fin n → Bool) (x : Fin (popCount w)) : + (oddPerm σ w x : ℕ) = + ((trueEnum (permIndex σ w)).toEquiv.symm + (trueShift σ w (trueEnum w x)) : Fin (popCount (permIndex σ w))).val + := rfl + +/-- **The induced permutation is multiplicative**, up to transport +of the count equality. -/ +theorem oddPerm_mul {n : ℕ} (σ τ : Equiv.Perm (Fin n)) + (w : Fin n → Bool) : + oddPerm (σ * τ) w = + ((finCongr (popCount_permIndex τ w)).permCongr + (oddPerm σ (permIndex τ w))) * oddPerm τ w := by + refine Equiv.ext fun x => ?_ + rw [Equiv.Perm.mul_apply, Equiv.permCongr_apply] + have hcast : (finCongr (popCount_permIndex τ w)).symm + (oddPerm τ w x) = + (trueEnum (permIndex τ w)).toEquiv.symm + (trueShift τ w (trueEnum w x)) := by + rw [oddPerm_apply] + exact (finCongr (popCount_permIndex τ w)).symm_apply_apply _ + rw [hcast, oddPerm_apply, oddPerm_apply] + have henum : (trueEnum (permIndex τ w)) + ((trueEnum (permIndex τ w)).toEquiv.symm + (trueShift τ w (trueEnum w x))) = + trueShift τ w (trueEnum w x) := + (trueEnum (permIndex τ w)).toEquiv.apply_symm_apply _ + rw [henum] + rfl + +/-- **The Koszul sign is a cocycle** for the shuffle action. -/ +theorem parSign_mul {n : ℕ} (σ τ : Equiv.Perm (Fin n)) + (w : Fin n → Bool) : + parSign (σ * τ) w = + parSign σ (permIndex τ w) * parSign τ w := by + rw [parSign, parSign, parSign, oddPerm_mul, map_mul, + Equiv.Perm.sign_permCongr] + push_cast + ring + +/-! ### The Koszul sign of an adjacent transposition + +An adjacent swap crosses exactly one pair of letters: its Koszul +sign is `−1` when both are odd and `1` otherwise. -/ + +/-- Evaluating the enumeration inverse across an equality of +words. -/ +private theorem enumSymm_val_congr {n : ℕ} {w w' : Fin n → Bool} + (h : w = w') (a : {i // i ∈ trueSet w}) (b : {i // i ∈ trueSet w'}) + (hab : (a : Fin n) = (b : Fin n)) : + ((trueEnum w).toEquiv.symm a : ℕ) = + ((trueEnum w').toEquiv.symm b : ℕ) := by + subst h + rw [Subtype.ext hab] + +/-- An adjacent swap of two `true` slots fixes the parity word. -/ +private theorem permIndex_swap_of_both {n : ℕ} {w : Fin (n + 1) → Bool} + {i : Fin n} (ha : w i.castSucc = true) (hb : w i.succ = true) : + permIndex (Equiv.swap i.castSucc i.succ) w = w := by + funext j + rw [permIndex_apply, Equiv.swap_inv] + rcases eq_or_ne j i.castSucc with rfl | hja + · rw [Equiv.swap_apply_left, hb, ha] + · rcases eq_or_ne j i.succ with rfl | hjb + · rw [Equiv.swap_apply_right, ha, hb] + · rw [Equiv.swap_apply_of_ne_of_ne hja hjb] + +/-- A swap of two `true` slots preserves the set of `true` slots. -/ +private theorem swap_mem_trueSet {n : ℕ} {w : Fin (n + 1) → Bool} + {i : Fin n} (ha : w i.castSucc = true) (hb : w i.succ = true) + {j : Fin (n + 1)} (hj : j ∈ trueSet w) : + Equiv.swap i.castSucc i.succ j ∈ trueSet w := by + rw [mem_trueSet] at hj ⊢ + rcases eq_or_ne j i.castSucc with rfl | hja + · rwa [Equiv.swap_apply_left] + · rcases eq_or_ne j i.succ with rfl | hjb + · rwa [Equiv.swap_apply_right] + · rwa [Equiv.swap_apply_of_ne_of_ne hja hjb] + +/-- **An adjacent swap of two odd slots induces a transposition** +of the corresponding enumeration indices. -/ +private theorem oddPerm_swap_of_both {n : ℕ} {w : Fin (n + 1) → Bool} + {i : Fin n} (ha : w i.castSucc = true) (hb : w i.succ = true) : + oddPerm (Equiv.swap i.castSucc i.succ) w = + Equiv.swap + ((trueEnum w).toEquiv.symm ⟨i.castSucc, mem_trueSet.mpr ha⟩) + ((trueEnum w).toEquiv.symm ⟨i.succ, mem_trueSet.mpr hb⟩) := by + set s := Equiv.swap i.castSucc i.succ with hs + set xa := (trueEnum w).toEquiv.symm ⟨i.castSucc, mem_trueSet.mpr ha⟩ + with hxa + set xb := (trueEnum w).toEquiv.symm ⟨i.succ, mem_trueSet.mpr hb⟩ + with hxb + have hww : permIndex s w = w := permIndex_swap_of_both ha hb + refine Equiv.ext fun x => Fin.ext ?_ + have hval : (oddPerm s w x : ℕ) = + ((trueEnum w).toEquiv.symm + ⟨s ((trueEnum w x : Fin (n + 1))), + swap_mem_trueSet ha hb (trueEnum w x).2⟩ : ℕ) := by + rw [oddPerm_val] + exact enumSymm_val_congr hww _ _ (trueShift_apply s w (trueEnum w x)) + rw [hval] + rcases eq_or_ne x xa with rfl | hxa' + · have hEa : trueEnum w xa = ⟨i.castSucc, mem_trueSet.mpr ha⟩ := by + rw [hxa] + exact (trueEnum w).toEquiv.apply_symm_apply _ + have harg : (⟨s ((trueEnum w xa : Fin (n + 1))), + swap_mem_trueSet ha hb (trueEnum w xa).2⟩ : + {j // j ∈ trueSet w}) = ⟨i.succ, mem_trueSet.mpr hb⟩ := by + refine Subtype.ext ?_ + change s ((trueEnum w xa : Fin (n + 1))) = i.succ + have hv : (trueEnum w xa : Fin (n + 1)) = i.castSucc := + congrArg Subtype.val hEa + rw [hv] + exact Equiv.swap_apply_left _ _ + rw [harg, Equiv.swap_apply_left] + · rcases eq_or_ne x xb with rfl | hxb' + · have hEb : trueEnum w xb = ⟨i.succ, mem_trueSet.mpr hb⟩ := by + rw [hxb] + exact (trueEnum w).toEquiv.apply_symm_apply _ + have harg : (⟨s ((trueEnum w xb : Fin (n + 1))), + swap_mem_trueSet ha hb (trueEnum w xb).2⟩ : + {j // j ∈ trueSet w}) = ⟨i.castSucc, mem_trueSet.mpr ha⟩ := by + refine Subtype.ext ?_ + change s ((trueEnum w xb : Fin (n + 1))) = i.castSucc + have hv : (trueEnum w xb : Fin (n + 1)) = i.succ := + congrArg Subtype.val hEb + rw [hv] + exact Equiv.swap_apply_right _ _ + rw [harg, Equiv.swap_apply_right] + · have hja : (trueEnum w x : Fin (n + 1)) ≠ i.castSucc := by + intro h + have hEx : trueEnum w x = ⟨i.castSucc, mem_trueSet.mpr ha⟩ := + Subtype.ext h + refine hxa' ?_ + rw [hxa, ← hEx] + exact ((trueEnum w).toEquiv.symm_apply_apply x).symm + have hjb : (trueEnum w x : Fin (n + 1)) ≠ i.succ := by + intro h + have hEx : trueEnum w x = ⟨i.succ, mem_trueSet.mpr hb⟩ := + Subtype.ext h + refine hxb' ?_ + rw [hxb, ← hEx] + exact ((trueEnum w).toEquiv.symm_apply_apply x).symm + have harg : (⟨s ((trueEnum w x : Fin (n + 1))), + swap_mem_trueSet ha hb (trueEnum w x).2⟩ : + {j // j ∈ trueSet w}) = trueEnum w x := by + refine Subtype.ext ?_ + change s ((trueEnum w x : Fin (n + 1))) = + ((trueEnum w x : {j // j ∈ trueSet w}) : Fin (n + 1)) + exact Equiv.swap_apply_of_ne_of_ne hja hjb + rw [harg, Equiv.swap_apply_of_ne_of_ne hxa' hxb'] + exact congrArg Fin.val ((trueEnum w).symm_apply_apply x) + +/-- An adjacent swap with at most one `true` endpoint is strictly +monotone on the `true` slots. -/ +private theorem swap_strictMono_on {n : ℕ} {w : Fin (n + 1) → Bool} + {i : Fin n} (hnot : ¬(w i.castSucc = true ∧ w i.succ = true)) + {j j' : Fin (n + 1)} (hj : w j = true) (hj' : w j' = true) + (hjj : j < j') : + Equiv.swap i.castSucc i.succ j < Equiv.swap i.castSucc i.succ j' + := by + have hba : (i.succ : ℕ) = (i.castSucc : ℕ) + 1 := by simp + rcases eq_or_ne j i.castSucc with rfl | hja + · rw [Equiv.swap_apply_left] + rcases eq_or_ne j' i.succ with rfl | h'b + · exact absurd ⟨hj, hj'⟩ hnot + · rcases eq_or_ne j' i.castSucc with rfl | h'a + · exact absurd hjj (lt_irrefl _) + · rw [Equiv.swap_apply_of_ne_of_ne h'a h'b] + rw [Fin.lt_def] at hjj ⊢ + simp only [ne_eq, Fin.ext_iff] at h'a h'b + omega + · rcases eq_or_ne j i.succ with rfl | hjb + · rw [Equiv.swap_apply_right] + rcases eq_or_ne j' i.castSucc with rfl | h'a + · exfalso + rw [Fin.lt_def] at hjj + omega + · rcases eq_or_ne j' i.succ with rfl | h'b + · exact absurd hjj (lt_irrefl _) + · rw [Equiv.swap_apply_of_ne_of_ne h'a h'b] + rw [Fin.lt_def] at hjj ⊢ + omega + · rw [Equiv.swap_apply_of_ne_of_ne hja hjb] + rcases eq_or_ne j' i.castSucc with rfl | h'a + · rw [Equiv.swap_apply_left] + rw [Fin.lt_def] at hjj ⊢ + omega + · rcases eq_or_ne j' i.succ with rfl | h'b + · rw [Equiv.swap_apply_right] + rw [Fin.lt_def] at hjj ⊢ + simp only [ne_eq, Fin.ext_iff] at hja + omega + · rw [Equiv.swap_apply_of_ne_of_ne h'a h'b] + exact hjj + +/-- **An adjacent swap with at most one odd endpoint induces the +identity** on the enumeration indices. -/ +private theorem oddPerm_swap_of_not {n : ℕ} {w : Fin (n + 1) → Bool} + {i : Fin n} (hnot : ¬(w i.castSucc = true ∧ w i.succ = true)) : + oddPerm (Equiv.swap i.castSucc i.succ) w = 1 := by + set s := Equiv.swap i.castSucc i.succ with hs + refine perm_eq_one_of_strictMono _ ?_ + intro x y hxy + rw [Fin.lt_def, oddPerm_val, oddPerm_val] + have h1 : trueShift s w (trueEnum w x) < trueShift s w (trueEnum w y) + := by + rw [Subtype.mk_lt_mk, trueShift_apply, trueShift_apply] + refine swap_strictMono_on hnot + (mem_trueSet.mp (trueEnum w x).2) + (mem_trueSet.mp (trueEnum w y).2) ?_ + exact Subtype.coe_lt_coe.mpr ((trueEnum w).lt_iff_lt.mpr hxy) + have h2 : (trueEnum (permIndex s w)).toEquiv.symm + (trueShift s w (trueEnum w x)) < + (trueEnum (permIndex s w)).toEquiv.symm + (trueShift s w (trueEnum w y)) := + (trueEnum (permIndex s w)).symm.lt_iff_lt.mpr h1 + exact h2 + +/-- **The Koszul sign of an adjacent transposition**: `−1` when +both crossed letters are odd, `1` otherwise. -/ +theorem parSign_swap {n : ℕ} (i : Fin n) (w : Fin (n + 1) → Bool) : + parSign (Equiv.swap i.castSucc i.succ) w = + if w i.castSucc = true ∧ w i.succ = true then -1 else 1 := by + by_cases hab : w i.castSucc = true ∧ w i.succ = true + · rw [ite_eq_left hab, parSign, oddPerm_swap_of_both hab.1 hab.2, + Equiv.Perm.sign_swap] + · norm_num + · intro h + have h1 := (trueEnum w).toEquiv.symm.injective h + have h2 : i.castSucc = i.succ := congrArg Subtype.val h1 + exact absurd h2 (Fin.castSucc_lt_succ (i := i)).ne + · rw [ite_eq_right hab, parSign, oddPerm_swap_of_not hab, + Equiv.Perm.sign_one] + norm_num + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Standard.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Standard.lean new file mode 100644 index 0000000000..eae6730e54 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Standard.lean @@ -0,0 +1,895 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Letters + +/-! +# The standard super object and the mixed sum + +Two letter systems and the conclusion they force. In an ambient +symmetric ℂ-linear category with an odd invertible line `U` the +mixed biproduct sum `𝟙 ^ ⊕ (p+1) ⊞ U ^ ⊕ (q+1)` carries one; so +does the standard super object of `RS.SuperVect`, whose braiding on +the odd line is `−1`. A group-algebra element killing the ambient +tensor power has vanishing colour sums by +[Letters.lean](Letters.lean), hence kills the standard super object +as well — contradicting `not_schurKilled_stdSuper`. + +* `mixedSumLetters`, `stdSuperLetters`: the two letter systems, + built from the biproduct insertions and projections + `sumPowIns`/`sumPowPrj` and from the coordinates of the standard + super object. +* The `MonoidalPreadditive` and `MonoidalLinear` structures of + `RS.SuperVect`, and `stdSuper_braiding_neg`: the odd line of + `RS.SuperVect` is odd. +* `tensorPow_id_ne_zero`: a tensor power of a nonzero unit is + nonzero. +* `not_schurKilled_sum`: the mixed sum is not Schur-killed at any + diagram avoiding the cell `(p + 1, q + 1)` — the exact complement + of `schurKilled_unit_odd`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +/-! ## The letter system of a mixed biproduct sum + +In an ambient category with binary biproducts, the object +`𝟙 ^ ⊕ (p+1) ⊞ U ^ ⊕ (q+1)` carries the evident letter system: +unit letters through the first summand, odd letters through the +second. -/ + +/-- The parity of a mixed letter label: even on the first summand, +odd on the second. -/ +abbrev mixedPar {p q : ℕ} : Fin (p + 1) ⊕ Fin (q + 1) → Bool := + fun k => Sum.rec (fun _ => false) (fun _ => true) k + +section BiprodLetters + +variable {A : Type u} + +/-- The inclusion of one copy into an iterated biproduct sum. -/ +noncomputable def sumPowIns + [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + (X : A) : (k : ℕ) → Fin (k + 1) → + (X ⟶ sumPow X k) + | 0, _ => 𝟙 X + | k + 1, i => + Fin.lastCases biprod.inr + (fun j => sumPowIns X k j ≫ biprod.inl) i + +/-- The projection onto one copy of an iterated biproduct sum. -/ +noncomputable def sumPowPrj + [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + (X : A) : (k : ℕ) → Fin (k + 1) → + (sumPow X k ⟶ X) + | 0, _ => 𝟙 X + | k + 1, i => + Fin.lastCases biprod.snd + (fun j => biprod.fst ≫ sumPowPrj X k j) i + +/-- The recursion of the copy inclusion. -/ +theorem sumPowIns_succ [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + (X : A) (k : ℕ) (i : Fin (k + 2)) : + sumPowIns X (k + 1) i = + Fin.lastCases biprod.inr + (fun j => sumPowIns X k j ≫ biprod.inl) i := rfl + +/-- The recursion of the copy projection. -/ +theorem sumPowPrj_succ [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + (X : A) (k : ℕ) (i : Fin (k + 2)) : + sumPowPrj X (k + 1) i = + Fin.lastCases biprod.snd + (fun j => biprod.fst ≫ sumPowPrj X k j) i := rfl + +/-- Sandwich of a first-summand round trip. Stated at general +objects. -/ +private theorem inl_sandwich + [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + {X P Q : A} (f : X ⟶ P) (g : P ⟶ X) + (h : f ≫ g = 𝟙 X) : + (f ≫ (biprod.inl : P ⟶ P ⊞ Q)) ≫ (biprod.fst ≫ g) = 𝟙 X := by + rw [Category.assoc, biprod.inl_fst_assoc, h] + +/-- Sandwich of a vanishing first-summand round trip. Stated at +general objects. -/ +private theorem inl_sandwich_zero + [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + {X X' P Q : A} (f : X ⟶ P) + (g : P ⟶ X') (h : f ≫ g = 0) : + (f ≫ (biprod.inl : P ⟶ P ⊞ Q)) ≫ (biprod.fst ≫ g) = 0 := by + rw [Category.assoc, biprod.inl_fst_assoc, h] + +/-- The second summand misses a first-summand projection. Stated +at general objects. -/ +private theorem inr_miss + [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + {X' P Q : A} (g : P ⟶ X') : + (biprod.inr : Q ⟶ P ⊞ Q) ≫ (biprod.fst ≫ g) = 0 := by + rw [← Category.assoc, biprod.inr_fst, Limits.zero_comp] + +/-- The first summand misses the second-summand projection. +Stated at general objects. -/ +private theorem inl_miss + [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + {X P Q : A} (f : X ⟶ P) : + (f ≫ (biprod.inl : P ⟶ P ⊞ Q)) ≫ biprod.snd = 0 := by + rw [Category.assoc, biprod.inl_snd, Limits.comp_zero] + +/-- A copy's round trip through the sum is the identity. -/ +theorem sumPowIns_prj_same + [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + (X : A) : + ∀ (k : ℕ) (i : Fin (k + 1)), + sumPowIns X k i ≫ sumPowPrj X k i = 𝟙 X := by + intro k + induction k with + | zero => intro i; exact Category.id_comp _ + | succ k ih => + intro i + induction i using Fin.lastCases with + | last => + erw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_last, + Fin.lastCases_last] + exact biprod.inr_snd + | cast j => + erw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_castSucc, + Fin.lastCases_castSucc] + exact inl_sandwich _ _ (ih j) + +/-- Distinct copies' round trips vanish. -/ +theorem sumPowIns_prj_ne + [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + (X : A) : + ∀ (k : ℕ) {i i' : Fin (k + 1)}, i ≠ i' → + sumPowIns X k i ≫ sumPowPrj X k i' = 0 := by + intro k + induction k with + | zero => + intro i i' hii' + exact absurd (Fin.ext (by omega)) hii' + | succ k ih => + intro i i' hii' + induction i using Fin.lastCases with + | last => + induction i' using Fin.lastCases with + | last => exact absurd rfl hii' + | cast j' => + erw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_last, + Fin.lastCases_castSucc] + exact inr_miss _ + | cast j => + induction i' using Fin.lastCases with + | last => + erw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_castSucc, + Fin.lastCases_last] + exact inl_miss _ + | cast j' => + erw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_castSucc, + Fin.lastCases_castSucc] + exact inl_sandwich_zero _ _ + (ih (fun h => hii' (congrArg Fin.castSucc h))) + +/-- One-step gathering of the summand round trips. Stated at +general objects. -/ +private theorem biprod_gather + [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + {P Q X : A} {m : ℕ} + (p : Fin m → (P ⟶ X)) (i : Fin m → (X ⟶ P)) + (htot : (∑ j : Fin m, p j ≫ i j) = 𝟙 P) : + (∑ j : Fin m, (biprod.fst ≫ p j) ≫ (i j ≫ biprod.inl)) + + biprod.snd ≫ biprod.inr = 𝟙 (P ⊞ Q) := by + have h1 : (∑ j : Fin m, ((biprod.fst : P ⊞ Q ⟶ P) ≫ p j) ≫ + (i j ≫ (biprod.inl : P ⟶ P ⊞ Q))) = + (biprod.fst : P ⊞ Q ⟶ P) ≫ (∑ j : Fin m, p j ≫ i j) ≫ + biprod.inl := by + rw [Preadditive.sum_comp, Preadditive.comp_sum] + refine Finset.sum_congr rfl fun j _ => ?_ + simp only [Category.assoc] + rw [h1, htot, Category.id_comp] + exact biprod.total + +/-- The copies decompose the identity of the sum. -/ +theorem sumPow_total [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] + (X : A) : + ∀ k : ℕ, + (∑ i : Fin (k + 1), sumPowPrj X k i ≫ sumPowIns X k i) = + 𝟙 (sumPow X k) := by + intro k + induction k with + | zero => + change (∑ i : Fin 1, sumPowPrj X 0 i ≫ sumPowIns X 0 i) = + 𝟙 (sumPow X 0) + rw [Fin.sum_univ_one] + exact Category.id_comp _ + | succ k ih => + rw [Fin.sum_univ_castSucc] + rw [Finset.sum_congr rfl fun j (_ : j ∈ Finset.univ) => by + erw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_castSucc, + Fin.lastCases_castSucc]] + erw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_last, + Fin.lastCases_last] + exact biprod_gather (sumPowPrj X k) (sumPowIns X k) ih + +/-- **The letter system of the mixed sum**: `p + 1` unit letters +through the first summand and `q + 1` odd letters through the +second. -/ +noncomputable def mixedSumLetters + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [HasBinaryBiproducts A] + (p q : ℕ) (U : A) : + MixedLetters (Fin (p + 1) ⊕ Fin (q + 1)) mixedPar U + (sumPow (𝟙_ A) p ⊞ sumPow U q) where + ins k := + Sum.rec (fun i => sumPowIns (𝟙_ A) p i ≫ biprod.inl) + (fun j => sumPowIns U q j ≫ biprod.inr) k + prj k := + Sum.rec (fun i => biprod.fst ≫ sumPowPrj (𝟙_ A) p i) + (fun j => biprod.snd ≫ sumPowPrj U q j) k + ins_prj k := by + cases k with + | inl i => + change (sumPowIns (𝟙_ A) p i ≫ biprod.inl) ≫ + (biprod.fst ≫ sumPowPrj (𝟙_ A) p i) = 𝟙 _ + rw [Category.assoc, biprod.inl_fst_assoc] + exact sumPowIns_prj_same (𝟙_ A) p i + | inr j => + change (sumPowIns U q j ≫ biprod.inr) ≫ + (biprod.snd ≫ sumPowPrj U q j) = 𝟙 _ + rw [Category.assoc, biprod.inr_snd_assoc] + exact sumPowIns_prj_same U q j + ins_prj_ne {k k'} hkk' := by + cases k with + | inl i => + cases k' with + | inl i' => + change (sumPowIns (𝟙_ A) p i ≫ biprod.inl) ≫ + (biprod.fst ≫ sumPowPrj (𝟙_ A) p i') = 0 + rw [Category.assoc, biprod.inl_fst_assoc, + sumPowIns_prj_ne (𝟙_ A) p + (fun h => hkk' (congrArg Sum.inl h))] + | inr j' => + change (sumPowIns (𝟙_ A) p i ≫ biprod.inl) ≫ + (biprod.snd ≫ sumPowPrj U q j') = 0 + rw [Category.assoc, biprod.inl_snd_assoc, + Limits.zero_comp, Limits.comp_zero] + | inr j => + cases k' with + | inl i' => + change (sumPowIns U q j ≫ biprod.inr) ≫ + (biprod.fst ≫ sumPowPrj (𝟙_ A) p i') = 0 + rw [Category.assoc, biprod.inr_fst_assoc, + Limits.zero_comp, Limits.comp_zero] + | inr j' => + change (sumPowIns U q j ≫ biprod.inr) ≫ + (biprod.snd ≫ sumPowPrj U q j') = 0 + rw [Category.assoc, biprod.inr_snd_assoc, + sumPowIns_prj_ne U q + (fun h => hkk' (congrArg Sum.inr h))] + total := by + rw [Fintype.sum_sum_type] + have h1 : (∑ i : Fin (p + 1), + ((biprod.fst : sumPow (𝟙_ A) p ⊞ sumPow U q ⟶ _) ≫ + sumPowPrj (𝟙_ A) p i) ≫ + (sumPowIns (𝟙_ A) p i ≫ + (biprod.inl : _ ⟶ sumPow (𝟙_ A) p ⊞ sumPow U q))) = + (biprod.fst : sumPow (𝟙_ A) p ⊞ sumPow U q ⟶ _) ≫ + (𝟙 (sumPow (𝟙_ A) p)) ≫ + (biprod.inl : _ ⟶ sumPow (𝟙_ A) p ⊞ sumPow U q) := by + rw [← sumPow_total (𝟙_ A) p, Preadditive.sum_comp, + Preadditive.comp_sum] + refine Finset.sum_congr rfl fun i _ => ?_ + simp only [Category.assoc] + have h2 : (∑ j : Fin (q + 1), + ((biprod.snd : sumPow (𝟙_ A) p ⊞ sumPow U q ⟶ _) ≫ + sumPowPrj U q j) ≫ + (sumPowIns U q j ≫ + (biprod.inr : _ ⟶ sumPow (𝟙_ A) p ⊞ sumPow U q))) = + (biprod.snd : sumPow (𝟙_ A) p ⊞ sumPow U q ⟶ _) ≫ + (𝟙 (sumPow U q)) ≫ + (biprod.inr : _ ⟶ sumPow (𝟙_ A) p ⊞ sumPow U q) := by + rw [← sumPow_total U q, Preadditive.sum_comp, + Preadditive.comp_sum] + refine Finset.sum_congr rfl fun j _ => ?_ + simp only [Category.assoc] + change (∑ i : Fin (p + 1), + ((biprod.fst : sumPow (𝟙_ A) p ⊞ sumPow U q ⟶ _) ≫ + sumPowPrj (𝟙_ A) p i) ≫ + (sumPowIns (𝟙_ A) p i ≫ + (biprod.inl : _ ⟶ sumPow (𝟙_ A) p ⊞ sumPow U q))) + + (∑ j : Fin (q + 1), + ((biprod.snd : sumPow (𝟙_ A) p ⊞ sumPow U q ⟶ _) ≫ + sumPowPrj U q j) ≫ + (sumPowIns U q j ≫ + (biprod.inr : _ ⟶ sumPow (𝟙_ A) p ⊞ sumPow U q))) = + 𝟙 (sumPow (𝟙_ A) p ⊞ sumPow U q) + rw [h1, h2, Category.id_comp, Category.id_comp] + exact biprod.total + +end BiprodLetters + +/-! ## Nonvanishing of the odd-line powers -/ + +section Nonzero + +variable {A : Type u} + +/-- A zero identity transfers along an isomorphism. Stated at +general objects. -/ +private theorem id_zero_transfer [Category.{v} A] [Preadditive A] + {X Y : A} (e : X ≅ Y) + (h : 𝟙 X = 0) : 𝟙 Y = 0 := by + calc 𝟙 Y = e.inv ≫ 𝟙 X ≫ e.hom := by + rw [Category.id_comp, e.inv_hom_id] + _ = 0 := by rw [h, Limits.zero_comp, Limits.comp_zero] + +/-- **Powers of an invertible line are nonzero** when the unit is: +tensoring with one more copy of the line is undone through its +self-pairing. -/ +theorem tensorPow_id_ne_zero + [Category.{v} A] [MonoidalCategory A] [Preadditive A] + [MonoidalPreadditive A] + (hone : ¬ Limits.IsZero (𝟙_ A)) + {U : A} (hUU : U ⊗ U ≅ 𝟙_ A) : + ∀ k : ℕ, 𝟙 (tensorPow A U k) ≠ + (0 : tensorPow A U k ⟶ tensorPow A U k) := by + intro k + induction k with + | zero => + intro h + exact hone ((Limits.IsZero.iff_id_eq_zero (𝟙_ A)).mpr h) + | succ k ih => + intro h + have h1 : 𝟙 (tensorPow A U (k + 1) ⊗ U) = 0 := by + rw [← MonoidalCategory.id_whiskerRight, h, + MonoidalPreadditive.zero_whiskerRight] + exact ih (id_zero_transfer + ((α_ (tensorPow A U k) U U) ≪≫ + whiskerLeftIso (tensorPow A U k) hUU ≪≫ + ρ_ (tensorPow A U k)) h1) + +end Nonzero + +/-! ## The ambient extraction -/ + +section AmbientSide + +variable {A : Type u} + +/-- **Extraction in the ambient category**: if the mixed sum is +Schur-killed at a diagram, every colour sum of the block idempotent +vanishes — a purely combinatorial consequence, shared with every +other model. -/ +theorem colourSum_eq_zero_of_schurKilled + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] [HasBinaryBiproducts A] + (P : SchurPackage.{v}) + (hone : ¬ Limits.IsZero (𝟙_ A)) {U : A} (hUU : U ⊗ U ≅ 𝟙_ A) + (hβ : (β_ U U).hom = -(𝟙 (U ⊗ U))) (p q : ℕ) + {lam : YoungDiagram} + (hkill : SchurKilled P (sumPow (𝟙_ A) p ⊞ sumPow U q) lam) : + ∀ c d : Fin lam.card → Fin (p + 1) ⊕ Fin (q + 1), + colourSum mixedPar (P.e lam) c d = 0 := + fun c d => (mixedSumLetters p q U).colourSum_eq_zero hβ + (tensorPow_id_ne_zero hone hUU) hkill c d + +end AmbientSide + +/-! ## Additive and linear monoidal structure of `SuperVect` + +The graded tensor product is additive and ℂ-linear in each +argument, componentwise. -/ + +section SuperVectInstances + +open scoped TensorProduct + +/-- The parallel pair of zero maps is zero. -/ +private theorem prodMap_zero₂ {M₁ M₂ N₁ N₂ : Type*} + [AddCommGroup M₁] [Module ℂ M₁] [AddCommGroup M₂] [Module ℂ M₂] + [AddCommGroup N₁] [Module ℂ N₁] [AddCommGroup N₂] [Module ℂ N₂] : + LinearMap.prodMap (0 : M₁ →ₗ[ℂ] N₁) (0 : M₂ →ₗ[ℂ] N₂) = 0 := + LinearMap.ext fun _ => rfl + +/-- The parallel pair of sums is the sum of the parallel pairs. -/ +private theorem prodMap_add₂ {M₁ M₂ N₁ N₂ : Type*} + [AddCommGroup M₁] [Module ℂ M₁] [AddCommGroup M₂] [Module ℂ M₂] + [AddCommGroup N₁] [Module ℂ N₁] [AddCommGroup N₂] [Module ℂ N₂] + (f f' : M₁ →ₗ[ℂ] N₁) (g g' : M₂ →ₗ[ℂ] N₂) : + LinearMap.prodMap (f + f') (g + g') = + LinearMap.prodMap f g + LinearMap.prodMap f' g' := + LinearMap.ext fun _ => rfl + +/-- The parallel pair of scalings is the scaling of the pair. -/ +private theorem prodMap_smul₂ {M₁ M₂ N₁ N₂ : Type*} + [AddCommGroup M₁] [Module ℂ M₁] [AddCommGroup M₂] [Module ℂ M₂] + [AddCommGroup N₁] [Module ℂ N₁] [AddCommGroup N₂] [Module ℂ N₂] + (r : ℂ) (f : M₁ →ₗ[ℂ] N₁) (g : M₂ →ₗ[ℂ] N₂) : + LinearMap.prodMap (r • f) (r • g) = + r • LinearMap.prodMap f g := + LinearMap.ext fun _ => rfl + +/-- `SuperVect` is monoidal preadditive: whiskering is additive. -/ +instance : MonoidalPreadditive SuperVect where + whiskerLeft_zero {X Y Z} := by + apply SuperVect.hom_ext + · change LinearMap.prodMap + (TensorProduct.map LinearMap.id + (SuperVect.Hom.evenMap (0 : Y ⟶ Z))) + (TensorProduct.map LinearMap.id + (SuperVect.Hom.oddMap (0 : Y ⟶ Z))) = + SuperVect.Hom.evenMap (0 : X ⊗ Y ⟶ X ⊗ Z) + rw [SuperVect.zero_evenMap, SuperVect.zero_oddMap, + TensorProduct.map_zero_right, TensorProduct.map_zero_right, + prodMap_zero₂] + rfl + · change LinearMap.prodMap + (TensorProduct.map LinearMap.id + (SuperVect.Hom.oddMap (0 : Y ⟶ Z))) + (TensorProduct.map LinearMap.id + (SuperVect.Hom.evenMap (0 : Y ⟶ Z))) = + SuperVect.Hom.oddMap (0 : X ⊗ Y ⟶ X ⊗ Z) + rw [SuperVect.zero_evenMap, SuperVect.zero_oddMap, + TensorProduct.map_zero_right, TensorProduct.map_zero_right, + prodMap_zero₂] + rfl + zero_whiskerRight {X Y Z} := by + apply SuperVect.hom_ext + · change LinearMap.prodMap + (TensorProduct.map (SuperVect.Hom.evenMap (0 : Y ⟶ Z)) + LinearMap.id) + (TensorProduct.map (SuperVect.Hom.oddMap (0 : Y ⟶ Z)) + LinearMap.id) = + SuperVect.Hom.evenMap (0 : Y ⊗ X ⟶ Z ⊗ X) + rw [SuperVect.zero_evenMap, SuperVect.zero_oddMap, + TensorProduct.map_zero_left, TensorProduct.map_zero_left, + prodMap_zero₂] + rfl + · change LinearMap.prodMap + (TensorProduct.map (SuperVect.Hom.evenMap (0 : Y ⟶ Z)) + LinearMap.id) + (TensorProduct.map (SuperVect.Hom.oddMap (0 : Y ⟶ Z)) + LinearMap.id) = + SuperVect.Hom.oddMap (0 : Y ⊗ X ⟶ Z ⊗ X) + rw [SuperVect.zero_evenMap, SuperVect.zero_oddMap, + TensorProduct.map_zero_left, TensorProduct.map_zero_left, + prodMap_zero₂] + rfl + whiskerLeft_add {X Y Z} f g := by + apply SuperVect.hom_ext + · change LinearMap.prodMap + (TensorProduct.map LinearMap.id + (SuperVect.Hom.evenMap (f + g))) + (TensorProduct.map LinearMap.id + (SuperVect.Hom.oddMap (f + g))) = + SuperVect.Hom.evenMap (X ◁ f + X ◁ g) + rw [SuperVect.add_evenMap, SuperVect.add_oddMap, + TensorProduct.map_add_right, TensorProduct.map_add_right, + prodMap_add₂] + rfl + · change LinearMap.prodMap + (TensorProduct.map LinearMap.id + (SuperVect.Hom.oddMap (f + g))) + (TensorProduct.map LinearMap.id + (SuperVect.Hom.evenMap (f + g))) = + SuperVect.Hom.oddMap (X ◁ f + X ◁ g) + rw [SuperVect.add_evenMap, SuperVect.add_oddMap, + TensorProduct.map_add_right, TensorProduct.map_add_right, + prodMap_add₂] + rfl + add_whiskerRight {X Y Z} f g := by + apply SuperVect.hom_ext + · change LinearMap.prodMap + (TensorProduct.map (SuperVect.Hom.evenMap (f + g)) + LinearMap.id) + (TensorProduct.map (SuperVect.Hom.oddMap (f + g)) + LinearMap.id) = + SuperVect.Hom.evenMap (f ▷ X + g ▷ X) + rw [SuperVect.add_evenMap, SuperVect.add_oddMap, + TensorProduct.map_add_left, TensorProduct.map_add_left, + prodMap_add₂] + rfl + · change LinearMap.prodMap + (TensorProduct.map (SuperVect.Hom.evenMap (f + g)) + LinearMap.id) + (TensorProduct.map (SuperVect.Hom.oddMap (f + g)) + LinearMap.id) = + SuperVect.Hom.oddMap (f ▷ X + g ▷ X) + rw [SuperVect.add_evenMap, SuperVect.add_oddMap, + TensorProduct.map_add_left, TensorProduct.map_add_left, + prodMap_add₂] + rfl + +/-- `SuperVect` is monoidal ℂ-linear: whiskering is ℂ-linear. -/ +instance : MonoidalLinear ℂ SuperVect where + whiskerLeft_smul X Y Z r f := by + apply SuperVect.hom_ext + · change LinearMap.prodMap + (TensorProduct.map LinearMap.id + (SuperVect.Hom.evenMap (r • f))) + (TensorProduct.map LinearMap.id + (SuperVect.Hom.oddMap (r • f))) = + SuperVect.Hom.evenMap (r • (X ◁ f)) + rw [SuperVect.smul_evenMap, SuperVect.smul_oddMap, + TensorProduct.map_smul_right, TensorProduct.map_smul_right, + prodMap_smul₂] + rfl + · change LinearMap.prodMap + (TensorProduct.map LinearMap.id + (SuperVect.Hom.oddMap (r • f))) + (TensorProduct.map LinearMap.id + (SuperVect.Hom.evenMap (r • f))) = + SuperVect.Hom.oddMap (r • (X ◁ f)) + rw [SuperVect.smul_evenMap, SuperVect.smul_oddMap, + TensorProduct.map_smul_right, TensorProduct.map_smul_right, + prodMap_smul₂] + rfl + smul_whiskerRight r {Y Z} f X := by + apply SuperVect.hom_ext + · change LinearMap.prodMap + (TensorProduct.map (SuperVect.Hom.evenMap (r • f)) + LinearMap.id) + (TensorProduct.map (SuperVect.Hom.oddMap (r • f)) + LinearMap.id) = + SuperVect.Hom.evenMap (r • (f ▷ X)) + rw [SuperVect.smul_evenMap, SuperVect.smul_oddMap, + TensorProduct.map_smul_left, TensorProduct.map_smul_left, + prodMap_smul₂] + rfl + · change LinearMap.prodMap + (TensorProduct.map (SuperVect.Hom.evenMap (r • f)) + LinearMap.id) + (TensorProduct.map (SuperVect.Hom.oddMap (r • f)) + LinearMap.id) = + SuperVect.Hom.oddMap (r • (f ▷ X)) + rw [SuperVect.smul_evenMap, SuperVect.smul_oddMap, + TensorProduct.map_smul_left, TensorProduct.map_smul_left, + prodMap_smul₂] + rfl + +end SuperVectInstances + +/-! ## The odd line of `SuperVect` + +The standard super object `ℂ^{0|1}` self-braids by `−1`: its even +component is the zero space, and the Koszul sign acts on the +odd square. -/ + +section OddLine + +open scoped TensorProduct + +/-- A tensor product with the zero space on the left is trivial. -/ +private theorem tensor_zero_left_eq {M : Type*} [AddCommGroup M] + [Module ℂ M] (z : (Fin 0 → ℂ) ⊗[ℂ] M) : z = 0 := by + have h0 : (LinearMap.id : (Fin 0 → ℂ) →ₗ[ℂ] (Fin 0 → ℂ)) = 0 := + Subsingleton.elim _ _ + calc z = TensorProduct.map LinearMap.id LinearMap.id z := by + rw [TensorProduct.map_id] + rfl + _ = TensorProduct.map 0 LinearMap.id z := by rw [h0] + _ = 0 := by rw [TensorProduct.map_zero_left]; rfl + +/-- A tensor product with the zero space on the right is +trivial. -/ +private theorem tensor_zero_right_eq {M : Type*} [AddCommGroup M] + [Module ℂ M] (z : M ⊗[ℂ] (Fin 0 → ℂ)) : z = 0 := by + have h0 : (LinearMap.id : (Fin 0 → ℂ) →ₗ[ℂ] (Fin 0 → ℂ)) = 0 := + Subsingleton.elim _ _ + calc z = TensorProduct.map LinearMap.id LinearMap.id z := by + rw [TensorProduct.map_id] + rfl + _ = TensorProduct.map LinearMap.id 0 z := by rw [h0] + _ = 0 := by rw [TensorProduct.map_zero_right]; rfl + +/-- The flip on the square of a line is the identity. -/ +private theorem comm_line_self (b : (Fin 1 → ℂ) ⊗[ℂ] (Fin 1 → ℂ)) : + TensorProduct.comm ℂ (Fin 1 → ℂ) (Fin 1 → ℂ) b = b := by + induction b using TensorProduct.inductionOn with + | add x y hx hy => rw [map_add, hx, hy] + | tmul v w => + have hrep : ∀ v : Fin 1 → ℂ, + v = v 0 • (fun _ => (1 : ℂ)) := by + intro v + funext i + rw [Subsingleton.elim i 0] + simp + rw [TensorProduct.comm_tmul, hrep v, hrep w, + ← TensorProduct.smul_tmul', ← TensorProduct.smul_tmul', + TensorProduct.tmul_smul, TensorProduct.tmul_smul, + smul_smul, smul_smul, mul_comm] + +/-- **The odd line self-braids by `−1`.** -/ +theorem stdSuper_braiding_neg : + (β_ (stdSuper 0 1) (stdSuper 0 1)).hom = + -(𝟙 (stdSuper 0 1 ⊗ stdSuper 0 1)) := by + have hEE : ∀ x y : (Fin 0 → ℂ) ⊗[ℂ] (Fin 0 → ℂ), x = y := by + intro x y + rw [tensor_zero_left_eq x, tensor_zero_left_eq y] + have hEO : ∀ x y : (Fin 0 → ℂ) ⊗[ℂ] (Fin 1 → ℂ), x = y := by + intro x y + rw [tensor_zero_left_eq x, tensor_zero_left_eq y] + have hOE : ∀ x y : (Fin 1 → ℂ) ⊗[ℂ] (Fin 0 → ℂ), x = y := by + intro x y + rw [tensor_zero_right_eq x, tensor_zero_right_eq y] + apply SuperVect.hom_ext + · apply LinearMap.ext + rintro ⟨a, b⟩ + change ((TensorProduct.comm ℂ (Fin 0 → ℂ) (Fin 0 → ℂ)) a, + -((TensorProduct.comm ℂ (Fin 1 → ℂ) (Fin 1 → ℂ)) b)) = + (-a, -b) + refine Prod.ext (hEE _ _) ?_ + exact congrArg Neg.neg (comm_line_self b) + · apply LinearMap.ext + rintro ⟨x, y⟩ + change ((TensorProduct.comm ℂ (Fin 1 → ℂ) (Fin 0 → ℂ)) y, + (TensorProduct.comm ℂ (Fin 0 → ℂ) (Fin 1 → ℂ)) x) = + (-x, -y) + exact Prod.ext (hEO _ _) (hOE _ _) + +end OddLine + +/-! ## The letter system of the standard super object + +`ℂ^{p+1|q+1}` carries the evident letter system in `SuperVect`: +unit letters along the even coordinates and odd-line letters along +the odd coordinates. No biproducts are needed — the inclusions and +projections are written down directly. -/ + +section SuperLetters + +/-- The even component, as an additive map of homs. -/ +private def evenMapAdd (V W : SuperVect) : + (V ⟶ W) →+ (V.even →ₗ[ℂ] W.even) where + toFun f := SuperVect.Hom.evenMap f + map_zero' := rfl + map_add' _ _ := rfl + +/-- The odd component, as an additive map of homs. -/ +private def oddMapAdd (V W : SuperVect) : + (V ⟶ W) →+ (V.odd →ₗ[ℂ] W.odd) where + toFun f := SuperVect.Hom.oddMap f + map_zero' := rfl + map_add' _ _ := rfl + +/-- The inclusion of an even coordinate line. -/ +noncomputable def unitIn (p q : ℕ) (i : Fin (p + 1)) : + 𝟙_ SuperVect ⟶ stdSuper (p + 1) (q + 1) where + evenMap := LinearMap.single ℂ (fun _ => ℂ) i + oddMap := 0 + +/-- The projection onto an even coordinate line. -/ +noncomputable def unitPrj (p q : ℕ) (i : Fin (p + 1)) : + stdSuper (p + 1) (q + 1) ⟶ 𝟙_ SuperVect where + evenMap := LinearMap.proj i + oddMap := 0 + +/-- The inclusion of an odd coordinate line. -/ +noncomputable def oddIn (p q : ℕ) (j : Fin (q + 1)) : + stdSuper 0 1 ⟶ stdSuper (p + 1) (q + 1) where + evenMap := 0 + oddMap := + (LinearMap.single ℂ (fun _ => ℂ) j).comp + (LinearMap.proj (0 : Fin 1)) + +/-- The projection onto an odd coordinate line. -/ +noncomputable def oddPrj (p q : ℕ) (j : Fin (q + 1)) : + stdSuper (p + 1) (q + 1) ⟶ stdSuper 0 1 where + evenMap := 0 + oddMap := LinearMap.pi fun _ : Fin 1 => LinearMap.proj j + +/-- The letter inclusions of the standard super object. -/ +noncomputable def stdIns (p q : ℕ) + (k : Fin (p + 1) ⊕ Fin (q + 1)) : + letterObj (stdSuper 0 1) mixedPar k ⟶ stdSuper (p + 1) (q + 1) + := + Sum.rec (fun i => unitIn p q i) (fun j => oddIn p q j) k + +/-- The letter projections of the standard super object. -/ +noncomputable def stdPrj (p q : ℕ) + (k : Fin (p + 1) ⊕ Fin (q + 1)) : + stdSuper (p + 1) (q + 1) ⟶ letterObj (stdSuper 0 1) mixedPar k + := + Sum.rec (fun i => unitPrj p q i) (fun j => oddPrj p q j) k + +/-- The letter decomposition of the identity of the standard super +object. -/ +private theorem stdSuper_total (p q : ℕ) : + (∑ k : Fin (p + 1) ⊕ Fin (q + 1), + (stdPrj p q k ≫ stdIns p q k : + stdSuper (p + 1) (q + 1) ⟶ stdSuper (p + 1) (q + 1))) = + 𝟙 (stdSuper (p + 1) (q + 1)) := by + apply SuperVect.hom_ext + · have h1 : SuperVect.Hom.evenMap + ((∑ k : Fin (p + 1) ⊕ Fin (q + 1), + stdPrj p q k ≫ stdIns p q k : + stdSuper (p + 1) (q + 1) ⟶ stdSuper (p + 1) (q + 1))) = + ∑ k : Fin (p + 1) ⊕ Fin (q + 1), + SuperVect.Hom.evenMap (stdPrj p q k ≫ stdIns p q k) := + map_sum (evenMapAdd _ _) _ _ + rw [h1, Fintype.sum_sum_type] + refine LinearMap.ext fun v => ?_ + rw [LinearMap.add_apply, LinearMap.sum_apply, + LinearMap.sum_apply] + have hA : ∀ i : Fin (p + 1), SuperVect.Hom.evenMap + (stdPrj p q (Sum.inl i) ≫ stdIns p q (Sum.inl i)) v = + Pi.single i (v i) := fun i => rfl + have hB : ∀ j : Fin (q + 1), SuperVect.Hom.evenMap + (stdPrj p q (Sum.inr j) ≫ stdIns p q (Sum.inr j)) v = 0 := + fun j => rfl + rw [Finset.sum_congr rfl fun i (_ : i ∈ Finset.univ) => hA i, + Finset.sum_congr rfl fun j (_ : j ∈ Finset.univ) => hB j, + Finset.sum_const, smul_zero, add_zero] + exact Finset.univ_sum_single v + · have h1 : SuperVect.Hom.oddMap + ((∑ k : Fin (p + 1) ⊕ Fin (q + 1), + stdPrj p q k ≫ stdIns p q k : + stdSuper (p + 1) (q + 1) ⟶ stdSuper (p + 1) (q + 1))) = + ∑ k : Fin (p + 1) ⊕ Fin (q + 1), + SuperVect.Hom.oddMap (stdPrj p q k ≫ stdIns p q k) := + map_sum (oddMapAdd _ _) _ _ + rw [h1, Fintype.sum_sum_type] + refine LinearMap.ext fun v => ?_ + rw [LinearMap.add_apply, LinearMap.sum_apply, + LinearMap.sum_apply] + have hA : ∀ i : Fin (p + 1), SuperVect.Hom.oddMap + (stdPrj p q (Sum.inl i) ≫ stdIns p q (Sum.inl i)) v = 0 := + fun i => rfl + have hB : ∀ j : Fin (q + 1), SuperVect.Hom.oddMap + (stdPrj p q (Sum.inr j) ≫ stdIns p q (Sum.inr j)) v = + Pi.single j (v j) := fun j => rfl + rw [Finset.sum_congr rfl fun i (_ : i ∈ Finset.univ) => hA i, + Finset.sum_congr rfl fun j (_ : j ∈ Finset.univ) => hB j, + Finset.sum_const, smul_zero, zero_add] + exact Finset.univ_sum_single v + +/-- **The letter system of the standard super object.** -/ +noncomputable def stdSuperLetters (p q : ℕ) : + MixedLetters (Fin (p + 1) ⊕ Fin (q + 1)) mixedPar + (stdSuper 0 1) (stdSuper (p + 1) (q + 1)) where + ins := stdIns p q + prj := stdPrj p q + ins_prj k := by + cases k with + | inl i => + apply SuperVect.hom_ext + · change (LinearMap.proj (R := ℂ) (φ := fun _ : Fin (p + 1) => ℂ) + i).comp (LinearMap.single ℂ (fun _ => ℂ) i) = + LinearMap.id + refine LinearMap.ext fun z => ?_ + change Pi.single (M := fun _ : Fin (p + 1) => ℂ) i z i = z + rw [Pi.single_eq_same] + · refine LinearMap.ext fun z => ?_ + exact Subsingleton.elim (α := PUnit) _ _ + | inr j => + apply SuperVect.hom_ext + · refine LinearMap.ext fun z => ?_ + exact Subsingleton.elim (α := Fin 0 → ℂ) _ _ + · change (LinearMap.pi fun _ : Fin 1 => + LinearMap.proj (R := ℂ) (φ := fun _ : Fin (q + 1) => ℂ) j).comp + ((LinearMap.single ℂ (fun _ => ℂ) j).comp + (LinearMap.proj (R := ℂ) (φ := fun _ : Fin 1 => ℂ) 0)) = + LinearMap.id + refine LinearMap.ext fun v => ?_ + funext i + change Pi.single (M := fun _ : Fin (q + 1) => ℂ) j (v 0) j = + v i + rw [Pi.single_eq_same, Subsingleton.elim i 0] + ins_prj_ne {k k'} hkk' := by + cases k with + | inl i => + cases k' with + | inl i' => + apply SuperVect.hom_ext + · change (LinearMap.proj (R := ℂ) (φ := fun _ : Fin (p + 1) => ℂ) + i').comp (LinearMap.single ℂ (fun _ => ℂ) i) = 0 + refine LinearMap.ext fun z => ?_ + change Pi.single (M := fun _ : Fin (p + 1) => ℂ) i z i' = 0 + exact Pi.single_eq_of_ne (M := fun _ : Fin (p + 1) => ℂ) + (fun h => hkk' (congrArg Sum.inl h.symm)) z + · refine LinearMap.ext fun z => ?_ + exact Subsingleton.elim (α := PUnit) _ _ + | inr j' => + apply SuperVect.hom_ext + · refine LinearMap.ext fun z => ?_ + exact Subsingleton.elim (α := Fin 0 → ℂ) _ _ + · refine LinearMap.ext fun z => ?_ + change (LinearMap.pi fun _ : Fin 1 => + LinearMap.proj (R := ℂ) + (φ := fun _ : Fin (q + 1) => ℂ) j') + ((0 : PUnit →ₗ[ℂ] (Fin (q + 1) → ℂ)) z) = 0 + erw [LinearMap.zero_apply, map_zero] + | inr j => + cases k' with + | inl i' => + apply SuperVect.hom_ext + · refine LinearMap.ext fun z => ?_ + change (LinearMap.proj (R := ℂ) + (φ := fun _ : Fin (p + 1) => ℂ) i') + ((0 : (Fin 0 → ℂ) →ₗ[ℂ] (Fin (p + 1) → ℂ)) z) = 0 + rfl + · refine LinearMap.ext fun z => ?_ + exact Subsingleton.elim (α := PUnit) _ _ + | inr j' => + apply SuperVect.hom_ext + · refine LinearMap.ext fun z => ?_ + exact Subsingleton.elim (α := Fin 0 → ℂ) _ _ + · change (LinearMap.pi fun _ : Fin 1 => + LinearMap.proj (R := ℂ) (φ := fun _ : Fin (q + 1) => ℂ) + j').comp + ((LinearMap.single ℂ (fun _ => ℂ) j).comp + (LinearMap.proj (R := ℂ) (φ := fun _ : Fin 1 => ℂ) 0)) = 0 + refine LinearMap.ext fun v => ?_ + funext i + change Pi.single (M := fun _ : Fin (q + 1) => ℂ) j (v 0) j' + = 0 + exact Pi.single_eq_of_ne (M := fun _ : Fin (q + 1) => ℂ) + (fun h => hkk' (congrArg Sum.inr h.symm)) (v 0) + total := by exact stdSuper_total p q + +/-- **Reconstruction in `SuperVect`**: vanishing colour sums force +the block idempotent to kill the standard super object. -/ +theorem schurKilled_stdSuper_of_colourSum (P₀ : SchurPackage.{0}) + (p q : ℕ) {lam : YoungDiagram} + (hcs : ∀ c d : Fin lam.card → Fin (p + 1) ⊕ Fin (q + 1), + colourSum mixedPar (P₀.e lam) c d = 0) : + SchurKilled P₀ (stdSuper (p + 1) (q + 1)) lam := + (stdSuperLetters p q).permAlg_eq_zero stdSuper_braiding_neg hcs + +end SuperLetters + +/-! ## The summit: nonvanishing of the mixed sum + +The exact complement of `schurKilled_unit_odd`: at every diagram +avoiding the cell `(p + 1, q + 1)`, the mixed sum survives. The +ambient extraction pins the colour sums of the block idempotent to +zero, the reconstruction transports this into `SuperVect`, and the +super trace computation of `not_schurKilled_stdSuper` refutes it. +Both Schur packages have the Jacobi–Trudi character, so their block +idempotents coincide and the two worlds speak about the same +group-algebra element. -/ + +section Summit + +variable {A : Type u} + +/-- **The nonvanishing half of Deligne 1.9, internally**: in a +nontrivial ambient category, a direct sum of `p + 1` unit copies +and `q + 1` odd-line copies is *not* Schur-killed at any diagram +avoiding the cell `(p + 1, q + 1)`. Together with +`schurKilled_unit_odd` this characterises the killed diagrams of +the mixed sum exactly. -/ +theorem not_schurKilled_sum + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] [HasBinaryBiproducts A] + (P : SchurPackage.{v}) + (P₀ : SchurPackage.{0}) (hone : ¬ Limits.IsZero (𝟙_ A)) + {U : A} (hUU : U ⊗ U ≅ 𝟙_ A) + (hβ : (β_ U U).hom = -(𝟙 (U ⊗ U))) (p q : ℕ) + {lam : YoungDiagram} + (hcell : ((p + 1, q + 1) : ℕ × ℕ) ∉ lam) : + ¬ SchurKilled P (sumPow (𝟙_ A) p ⊞ sumPow U q) lam := by + intro hkill + have he : P.e lam = P₀.e lam := by + rw [P.e_eq_nProjector lam, P₀.e_eq_nProjector lam] + have hcs := + colourSum_eq_zero_of_schurKilled P hone hUU hβ p q hkill + rw [he] at hcs + exact not_schurKilled_stdSuper P₀ hcell + (schurKilled_stdSuper_of_colourSum P₀ p q hcs) + +end Summit + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEvenRing.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEvenRing.lean new file mode 100644 index 0000000000..bef8e02a47 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEvenRing.lean @@ -0,0 +1,167 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.NullPoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperRealize + +/-! +# The even ring acting on the odd part, and ℂ-points + +The ordinary commutative ℂ-algebra structure of the even component +of a `RS.SuperCommAlgebra`, and the nilness of the odd-generated +ideal, are established in +[SuperRealize.lean](SuperRealize.lean) (`instCommRingEven`, +`instAlgebraEven`, `oddIdeal_le_nilradical`, `oddIdeal_ne_top`). +This module adds the two things Deligne's §4.5 ending consumes on +top of them. + +* The odd component is a module over the even ring + (`instModuleEvenOdd`), the action being the even-odd + multiplication block, compatibly with the ambient ℂ-action + (`instIsScalarTowerComplexEvenOdd`, + `instSMulCommClassComplexEvenOdd`); the odd-odd block is + bilinear for that action (`mulOO_smul_left`, `mulOO_smul_right`), + which is what makes `oddIdeal` the image of the odd part under + multiplication rather than merely its span. + +* `RS.SuperPoint` — a super-algebra map to ℂ concentrated in even + degree: a ℂ-algebra map off the even component killing every + product of two odd elements. Such a map is exactly a ℂ-algebra + map off the odd-nil quotient (`SuperPoint.toQuotient`, + `SuperPoint.ofQuotient`), so on a nonzero algebra of finite type + one exists (`nonempty_superPoint`), by the Nullstellensatz input + `RS.exists_algHom_complex` of + [NullPoint.lean](NullPoint.lean). +-/ + +@[expose] public section + +namespace RS + +universe u u' + +namespace SuperCommAlgebra + +variable (S : SuperCommAlgebra.{u, u'}) + +/-! ## The odd component as a module over the even ring -/ + +/-- The odd component is a module over the even ring, the action +being the even-odd multiplication block: the module axioms are the +unit law `one_mul_o`, the associativity pattern `assoc_eeo` and the +ℂ-bilinearity of the block. -/ +instance instModuleEvenOdd : Module S.even S.odd where + smul x u := S.mulEO x u + one_smul := S.one_mul_o + mul_smul := S.assoc_eeo + smul_zero x := map_zero (S.mulEO x) + smul_add x u v := map_add (S.mulEO x) u v + add_smul x y u := by + change S.mulEO (x + y) u = S.mulEO x u + S.mulEO y u + rw [map_add S.mulEO x y, LinearMap.add_apply] + zero_smul u := by + change S.mulEO 0 u = 0 + rw [map_zero S.mulEO, LinearMap.zero_apply] + +/-- The scalar actions of ℂ and of the even ring on the odd +component are compatible: the even-odd block is ℂ-linear in its +even argument. -/ +instance instIsScalarTowerComplexEvenOdd : + IsScalarTower ℂ S.even S.odd where + smul_assoc r x u := by + change S.mulEO (r • x) u = r • S.mulEO x u + rw [map_smul S.mulEO r x, LinearMap.smul_apply] + +/-- The two scalar actions on the odd component commute: the +even-odd block is ℂ-linear in its odd argument. -/ +instance instSMulCommClassComplexEvenOdd : + SMulCommClass ℂ S.even S.odd where + smul_comm r x u := (map_smul (S.mulEO x) r u).symm + +/-- The odd-odd block is linear over the even ring in its left +argument. -/ +theorem mulOO_smul_left (x : S.even) (u v : S.odd) : + S.mulOO (x • u) v = x * S.mulOO u v := S.assoc_eoo x u v + +/-- The odd-odd block is linear over the even ring in its right +argument. -/ +theorem mulOO_smul_right (x : S.even) (u v : S.odd) : + S.mulOO u (x • v) = x * S.mulOO u v := by + have h : S.mulOO u (S.mulEO x v) = x * S.mulOO u v := by + rw [← S.assoc_oeo u x v, ← S.comm_eo x u] + exact S.assoc_eoo x u v + exact h + +/-! ## Nilness of the odd products, in ring form -/ + +/-- Each generator of the odd-generated ideal lies in it. -/ +theorem mulOO_mem_oddIdeal (u v : S.odd) : + S.mulOO u v ∈ S.oddIdeal := + Ideal.subset_span ⟨(u, v), rfl⟩ + +end SuperCommAlgebra + +/-! ## ℂ-points concentrated in even degree -/ + +/-- A *ℂ-point* of a super-commutative ℂ-algebra: a map of +super-algebras to ℂ, which carries no odd component, so it is a +ℂ-algebra map off the even part annihilating every product of two +odd elements. -/ +structure SuperPoint (S : SuperCommAlgebra.{u, u'}) where + /-- The ℂ-algebra map on the even component. -/ + chi : S.even →ₐ[ℂ] ℂ + /-- The odd degree is killed: products of odd elements go to + zero. -/ + vanishing : ∀ u v : S.odd, chi (S.mulOO u v) = 0 + +namespace SuperPoint + +variable {S : SuperCommAlgebra.{u, u'}} + +/-- A point annihilates the whole odd-generated ideal, not only +its generators. -/ +theorem apply_eq_zero_of_mem_oddIdeal (P : SuperPoint S) + {x : S.even} (hx : x ∈ S.oddIdeal) : P.chi x = 0 := by + have hle : S.oddIdeal ≤ RingHom.ker (P.chi : S.even →+* ℂ) := by + rw [SuperCommAlgebra.oddIdeal, Ideal.span_le] + rintro y ⟨⟨u, v⟩, rfl⟩ + exact RingHom.mem_ker.mpr (P.vanishing u v) + exact RingHom.mem_ker.mp (hle hx) + +/-- A point factors through the odd-nil quotient. -/ +noncomputable def toQuotient (P : SuperPoint S) : + (S.even ⧸ S.oddIdeal) →ₐ[ℂ] ℂ := + Ideal.Quotient.liftₐ S.oddIdeal P.chi fun _ hx => + P.apply_eq_zero_of_mem_oddIdeal hx + +/-- A ℂ-algebra map off the odd-nil quotient is a point. -/ +noncomputable def ofQuotient (S : SuperCommAlgebra.{u, u'}) + (f : (S.even ⧸ S.oddIdeal) →ₐ[ℂ] ℂ) : SuperPoint S where + chi := f.comp (Ideal.Quotient.mkₐ ℂ S.oddIdeal) + vanishing u v := by + have hz : Ideal.Quotient.mk S.oddIdeal (S.mulOO u v) = 0 := + Ideal.Quotient.eq_zero_iff_mem.mpr (S.mulOO_mem_oddIdeal u v) + rw [AlgHom.comp_apply, Ideal.Quotient.mkₐ_eq_mk, hz, map_zero] + +end SuperPoint + +/-- **Existence of a ℂ-point** (Deligne §4.5, step (ii)): a +super-commutative ℂ-algebra with nonzero even part whose odd-nil +quotient is of finite type admits a ℂ-point. The quotient is a +nonzero ordinary commutative ℂ-algebra of finite type +(`SuperCommAlgebra.nontrivial_quotient_oddIdeal`), so the +Nullstellensatz gives it a ℂ-algebra map to ℂ, which pulls back +along the quotient map. -/ +theorem nonempty_superPoint (S : SuperCommAlgebra.{u, u'}) + [Nontrivial S.even] + [Algebra.FiniteType ℂ (S.even ⧸ S.oddIdeal)] : + Nonempty (SuperPoint S) := + haveI := S.nontrivial_quotient_oddIdeal + (exists_algHom_complex (S.even ⧸ S.oddIdeal)).map (SuperPoint.ofQuotient S) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGamma.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGamma.lean new file mode 100644 index 0000000000..aa757731d0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGamma.lean @@ -0,0 +1,395 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSmall + +/-! +# The four-block Γ-algebra of a commutative monoid at an odd line + +`RS.SuperRealize` supplies the even half of the §4 monoid +transport: the convolution product `unitHomMul` making `𝟙_ D ⟶ R` +a commutative ℂ-algebra for a commutative monoid object `R`. This +file supplies the full super-commutative algebra. Fix an *odd +line* `o : D`: an object with a chosen trivialization +`ho : o ⊗ o ≅ 𝟙_ D` on which the braiding acts by `-1`. The four +graded blocks of `R`-valued points are + +* even = `𝟙_ D ⟶ R` and odd = `o ⟶ R` — the `o ⟶ R` form is + chosen over `𝟙_ D ⟶ o ⊗ R` because the odd-odd product then + pairs the two source copies of `o` directly through `ho`; +* `EE` = convolution through `(λ_ (𝟙_ D)).inv` (definitionally + the existing `unitHomMul`); +* `EO` = convolution through `(λ_ o).inv`; +* `OE` = convolution through `(ρ_ o).inv`; +* `OO` = convolution through `ho.inv`. + +All four are instances of a single construction, *convolution +along a prefix*: `convAlong R p f g = p ≫ (f ⊗ₘ g) ≫ μ` for a +chosen `p : A ⟶ X ⊗ Y`. Associativity holds once and for all +(`convAlong_assoc`) given a single coherence identity relating the +four prefixes involved; the eight parity associativities are the +eight instantiations. Seven of the eight coherence residues are +consequences of monoidal coherence and the naturality of the +unitors; the eighth — the odd-odd-odd pattern — genuinely compares +the two ways of trivializing one factor of `o ⊗ o ⊗ o` through +`ho` and is *not* a formal consequence of the data `(ho, hβ)`. It +is stated as the hypothesis `hα` of +`superGammaAlgebra`; it holds in super vector spaces (both sides +are `x ↦ e ⊗ e ⊗ x`-type maps for a basis vector `e` of the odd +line) and more generally whenever `ho` is a coherent +self-duality. + +Commutativity likewise holds once (`convAlong_braid`, from the +commutativity of `μ` and the naturality of the braiding); the +even-even and even-odd patterns follow from the unit braiding +identities, and the odd-odd pattern picks up the Koszul sign from +`hβ`. The package `superGammaAlgebra` assembles the blocks into +an `RS.SuperCommAlgebra`, feeding the odd-nil quotient theory of +`RS.SuperRealize`. +-/ + +@[expose] public section + +namespace RS + +noncomputable section + +open CategoryTheory MonoidalCategory MonObj +open scoped MonObj + +universe u u' + +variable {D : Type u} + +/-! ## Convolution along a prefix -/ + +section ConvAlong + +/-- *Convolution along a prefix*: for a monoid object `R` and a +chosen morphism `p : A ⟶ X ⊗ Y`, the pairing sending +`f : X ⟶ R` and `g : Y ⟶ R` to `p ≫ (f ⊗ₘ g) ≫ μ : A ⟶ R`. +All four graded multiplication blocks of the Γ-algebra at an odd +line are instances, at the prefixes `(λ_ (𝟙_ D)).inv`, +`(λ_ o).inv`, `(ρ_ o).inv` and `ho.inv`. -/ +def convAlong [Category.{u'} D] [MonoidalCategory D] (R : D) [MonObj R] + {A X Y : D} (p : A ⟶ X ⊗ Y) + (f : X ⟶ R) (g : Y ⟶ R) : A ⟶ R := + p ≫ (f ⊗ₘ g) ≫ μ + +/-- The monoid unit is a left unit for convolution along a left +unitor prefix. -/ +theorem convAlong_one_left + [Category.{u'} D] [MonoidalCategory D] (R : D) [MonObj R] + {Z : D} (x : Z ⟶ R) : + convAlong R (λ_ Z).inv η x = x := by + rw [convAlong, MonObj.one_mul_hom, Iso.inv_hom_id_assoc] + +/-- **Generic associativity of prefixed convolution.** Given +inner and outer prefixes on each side whose two composites into +`X ⊗ Y ⊗ Z` agree (`hpq`), the two iterated convolutions agree. +The eight parity associativities of the Γ-algebra are the eight +instantiations, with `hpq` a coherence residue in each case. -/ +theorem convAlong_assoc + [Category.{u'} D] [MonoidalCategory D] (R : D) [MonObj R] + {B A A' X Y Z : D} + (q : B ⟶ A ⊗ Z) (p : A ⟶ X ⊗ Y) + (q' : B ⟶ X ⊗ A') (p' : A' ⟶ Y ⊗ Z) + (hpq : q ≫ p ▷ Z ≫ (α_ X Y Z).hom = q' ≫ X ◁ p') + (f : X ⟶ R) (g : Y ⟶ R) (h : Z ⟶ R) : + convAlong R q (convAlong R p f g) h = + convAlong R q' f (convAlong R p' g h) := by + have hL : convAlong R q (convAlong R p f g) h = + q ≫ p ▷ Z ≫ (α_ X Y Z).hom ≫ (f ⊗ₘ (g ⊗ₘ h)) ≫ + R ◁ μ ≫ μ := by + rw [convAlong, convAlong, tensorHom_def (p ≫ (f ⊗ₘ g) ≫ μ) h] + simp only [comp_whiskerRight, Category.assoc] + rw [← whisker_exchange_assoc, ← tensorHom_def_assoc, + MonObj.mul_assoc, associator_naturality_assoc] + have hR : convAlong R q' f (convAlong R p' g h) = + q' ≫ X ◁ p' ≫ (f ⊗ₘ (g ⊗ₘ h)) ≫ R ◁ μ ≫ μ := by + rw [convAlong, convAlong, + tensorHom_def' f (p' ≫ (g ⊗ₘ h) ≫ μ)] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [whisker_exchange_assoc, ← tensorHom_def'_assoc] + rw [hL, hR, reassoc_of% hpq] + +/-- **Generic commutativity of prefixed convolution** against a +commutative monoid object: exchanging the two arguments costs +composing the prefix with the braiding. The Koszul signs of the +Γ-algebra arise from evaluating the braiding on the prefixes. -/ +theorem convAlong_braid + [Category.{u'} D] [MonoidalCategory D] (R : D) [MonObj R] + [BraidedCategory D] [IsCommMonObj R] + {A X Y : D} (p : A ⟶ X ⊗ Y) (f : X ⟶ R) (g : Y ⟶ R) : + convAlong R p f g = convAlong R (p ≫ (β_ X Y).hom) g f := by + simp only [convAlong, Category.assoc] + conv_lhs => rw [← IsCommMonObj.mul_comm R] + rw [BraidedCategory.braiding_naturality_assoc] + +/-- Even-even commutativity: at the unit prefix the braiding +correction collapses through the unit braiding identities. -/ +theorem convAlong_ee_comm + [Category.{u'} D] [MonoidalCategory D] (R : D) [MonObj R] + [BraidedCategory D] [IsCommMonObj R] + (a b : 𝟙_ D ⟶ R) : + convAlong R (λ_ (𝟙_ D)).inv a b = + convAlong R (λ_ (𝟙_ D)).inv b a := by + rw [convAlong_braid R (λ_ (𝟙_ D)).inv a b, + braiding_tensorUnit_left, Iso.inv_hom_id_assoc, + ← unitors_inv_equal] + +/-- Even-odd commutativity: the braiding against the unit turns +the left unitor prefix into the right unitor prefix, with no +sign. -/ +theorem convAlong_eo_comm + [Category.{u'} D] [MonoidalCategory D] (R : D) [MonObj R] + [BraidedCategory D] [IsCommMonObj R] + {o : D} (a : 𝟙_ D ⟶ R) (x : o ⟶ R) : + convAlong R (λ_ o).inv a x = convAlong R (ρ_ o).inv x a := by + rw [convAlong_braid R (ρ_ o).inv x a, braiding_tensorUnit_right, + Iso.inv_hom_id_assoc] + +end ConvAlong + +/-! ## Bilinearity -/ + +section Bilinear + +/-- Prefixed convolution is additive in the left argument. -/ +theorem convAlong_add_left + [Category.{u'} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] (R : D) [MonObj R] + {A X Y : D} (p : A ⟶ X ⊗ Y) + (f f' : X ⟶ R) (g : Y ⟶ R) : + convAlong R p (f + f') g = + convAlong R p f g + convAlong R p f' g := by + rw [convAlong, convAlong, convAlong, + MonoidalPreadditive.add_tensor, Preadditive.add_comp, + Preadditive.comp_add] + +/-- Prefixed convolution is additive in the right argument. -/ +theorem convAlong_add_right + [Category.{u'} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] (R : D) [MonObj R] + {A X Y : D} (p : A ⟶ X ⊗ Y) + (f : X ⟶ R) (g g' : Y ⟶ R) : + convAlong R p f (g + g') = + convAlong R p f g + convAlong R p f g' := by + rw [convAlong, convAlong, convAlong, + MonoidalPreadditive.tensor_add, Preadditive.add_comp, + Preadditive.comp_add] + +/-- **Odd-odd anticommutativity.** At a trivialization prefix +`ho.inv` on whose source the braiding acts by `-1`, exchanging the +arguments of prefixed convolution costs the Koszul sign. -/ +theorem convAlong_oo_comm + [Category.{u'} D] [MonoidalCategory D] [Preadditive D] (R : D) + [MonObj R] + [BraidedCategory D] [IsCommMonObj R] + {o : D} (ho : o ⊗ o ≅ 𝟙_ D) + (hβ : (β_ o o).hom = -𝟙 (o ⊗ o)) (x y : o ⟶ R) : + convAlong R ho.inv x y = -convAlong R ho.inv y x := by + rw [convAlong_braid R ho.inv x y, hβ, convAlong, convAlong, + Preadditive.comp_neg, Category.comp_id, Preadditive.neg_comp] + +/-- Prefixed convolution is ℂ-homogeneous in the left argument. -/ +theorem convAlong_smul_left + [Category.{u'} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] (R : D) [MonObj R] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + {A X Y : D} (p : A ⟶ X ⊗ Y) (r : ℂ) + (f : X ⟶ R) (g : Y ⟶ R) : + convAlong R p (r • f) g = r • convAlong R p f g := by + have h : (r • f) ⊗ₘ g = r • (f ⊗ₘ g) := by + rw [tensorHom_def, tensorHom_def, + MonoidalLinear.smul_whiskerRight, Linear.smul_comp] + rw [convAlong, convAlong, h, Linear.smul_comp, Linear.comp_smul] + +/-- Prefixed convolution is ℂ-homogeneous in the right +argument. -/ +theorem convAlong_smul_right + [Category.{u'} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] (R : D) [MonObj R] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + {A X Y : D} (p : A ⟶ X ⊗ Y) (r : ℂ) + (f : X ⟶ R) (g : Y ⟶ R) : + convAlong R p f (r • g) = r • convAlong R p f g := by + have h : f ⊗ₘ (r • g) = r • (f ⊗ₘ g) := by + rw [tensorHom_def', tensorHom_def', + MonoidalLinear.whiskerLeft_smul, Linear.smul_comp] + rw [convAlong, convAlong, h, Linear.smul_comp, Linear.comp_smul] + +/-- Prefixed convolution packaged as a ℂ-bilinear map on hom +ℂ-modules. -/ +def convAlongHom [Category.{u'} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] (R : D) [MonObj R] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + {A X Y : D} (p : A ⟶ X ⊗ Y) : + (X ⟶ R) →ₗ[ℂ] (Y ⟶ R) →ₗ[ℂ] (A ⟶ R) := + LinearMap.mk₂ ℂ (convAlong R p) + (convAlong_add_left R p) + (fun r f g => convAlong_smul_left R p r f g) + (convAlong_add_right R p) + (fun r f g => convAlong_smul_right R p r f g) + +/-- Application of the packaged bilinear map is prefixed +convolution. -/ +@[simp] theorem convAlongHom_apply + [Category.{u'} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] (R : D) [MonObj R] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] + {A X Y : D} (p : A ⟶ X ⊗ Y) + (f : X ⟶ R) (g : Y ⟶ R) : + convAlongHom R p f g = convAlong R p f g := rfl + +end Bilinear + +/-! ## The Γ-algebra at an odd line -/ + +section Residues + +/-- The even-odd-odd coherence residue: trivializing `o ⊗ o` after +inserting a unit on the left agrees with inserting the +trivialized unit directly. Naturality of the left unitor. -/ +private theorem residue_eoo [Category.{u'} D] [MonoidalCategory D] {o : D} + (ho : o ⊗ o ≅ 𝟙_ D) : + ho.inv ≫ (λ_ o).inv ▷ o ≫ (α_ (𝟙_ D) o o).hom = + (λ_ (𝟙_ D)).inv ≫ 𝟙_ D ◁ ho.inv := by + rw [← leftUnitor_tensor_inv, leftUnitor_inv_naturality] + +/-- The odd-odd-even coherence residue: trivializing `o ⊗ o` +before inserting a unit on the right agrees with inserting the +unit inside. Naturality of the right unitor. -/ +private theorem residue_ooe [Category.{u'} D] [MonoidalCategory D] {o : D} + (ho : o ⊗ o ≅ 𝟙_ D) : + (λ_ (𝟙_ D)).inv ≫ ho.inv ▷ 𝟙_ D ≫ (α_ o o (𝟙_ D)).hom = + ho.inv ≫ o ◁ (ρ_ o).inv := by + rw [unitors_inv_equal, ← rightUnitor_inv_naturality_assoc, + rightUnitor_tensor_inv] + simp only [Category.assoc, Iso.inv_hom_id, Category.comp_id] + +end Residues + +section OddLine + +/-- **The four-block Γ-algebra of a commutative monoid object at +an odd line.** For a commutative monoid object `R` of a braided +ℂ-linear monoidal category and an odd line `o` — an object with a +trivialization `ho : o ⊗ o ≅ 𝟙_ D` on which the braiding acts by +`-1` (`hβ`) and which is associativity-coherent (`hα`: the two +insertions of `ho.inv` into `o` agree through the associator) — +the morphisms `𝟙_ D ⟶ R` and `o ⟶ R` form a super-commutative +ℂ-algebra under prefixed convolution. The even block is the +convolution algebra of `RS.SuperRealize`; the odd-odd block pairs +the sources through `ho` and anticommutes by `hβ`. + +The hypothesis `hα` is not a formal consequence of `(ho, hβ)`: it +pins down the compatibility of the chosen trivialization with the +associator, and holds for the standard odd line of super vector +spaces (hence in `Ind SmallSuperVect`). -/ +def superGammaAlgebra [Category.{u'} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] (R : D) [MonObj R] [IsCommMonObj R] + (o : D) (ho : o ⊗ o ≅ 𝟙_ D) + (hβ : (β_ o o).hom = -𝟙 (o ⊗ o)) + (hα : (λ_ o).inv ≫ ho.inv ▷ o ≫ (α_ o o o).hom = + (ρ_ o).inv ≫ o ◁ ho.inv) : + SuperCommAlgebra where + even := 𝟙_ D ⟶ R + odd := o ⟶ R + one := η + mulEE := convAlongHom R (λ_ (𝟙_ D)).inv + mulEO := convAlongHom R (λ_ o).inv + mulOE := convAlongHom R (ρ_ o).inv + mulOO := convAlongHom R ho.inv + one_mul_e := fun x => by + change convAlong R (λ_ (𝟙_ D)).inv η x = x + exact convAlong_one_left R x + one_mul_o := fun u => by + change convAlong R (λ_ o).inv η u = u + exact convAlong_one_left R u + assoc_eee := fun x y z => by + change convAlong R (λ_ (𝟙_ D)).inv + (convAlong R (λ_ (𝟙_ D)).inv x y) z = + convAlong R (λ_ (𝟙_ D)).inv x + (convAlong R (λ_ (𝟙_ D)).inv y z) + exact convAlong_assoc R _ _ _ _ (by monoidal) x y z + assoc_eeo := fun x y u => by + change convAlong R (λ_ o).inv + (convAlong R (λ_ (𝟙_ D)).inv x y) u = + convAlong R (λ_ o).inv x (convAlong R (λ_ o).inv y u) + exact convAlong_assoc R _ _ _ _ (by monoidal) x y u + assoc_eoe := fun x u y => by + change convAlong R (ρ_ o).inv + (convAlong R (λ_ o).inv x u) y = + convAlong R (λ_ o).inv x (convAlong R (ρ_ o).inv u y) + exact convAlong_assoc R _ _ _ _ (by monoidal) x u y + assoc_eoo := fun x u v => by + change convAlong R ho.inv (convAlong R (λ_ o).inv x u) v = + convAlong R (λ_ (𝟙_ D)).inv x (convAlong R ho.inv u v) + exact convAlong_assoc R _ _ _ _ (residue_eoo ho) x u v + assoc_oee := fun u x y => by + change convAlong R (ρ_ o).inv + (convAlong R (ρ_ o).inv u x) y = + convAlong R (ρ_ o).inv u + (convAlong R (λ_ (𝟙_ D)).inv x y) + exact convAlong_assoc R _ _ _ _ (by monoidal) u x y + assoc_oeo := fun u x v => by + change convAlong R ho.inv (convAlong R (ρ_ o).inv u x) v = + convAlong R ho.inv u (convAlong R (λ_ o).inv x v) + exact convAlong_assoc R _ _ _ _ (by monoidal) u x v + assoc_ooe := fun u v y => by + change convAlong R (λ_ (𝟙_ D)).inv + (convAlong R ho.inv u v) y = + convAlong R ho.inv u (convAlong R (ρ_ o).inv v y) + exact convAlong_assoc R _ _ _ _ (residue_ooe ho) u v y + assoc_ooo := fun u v w => by + change convAlong R (λ_ o).inv (convAlong R ho.inv u v) w = + convAlong R (ρ_ o).inv u (convAlong R ho.inv v w) + exact convAlong_assoc R _ _ _ _ hα u v w + comm_ee := fun x y => by + change convAlong R (λ_ (𝟙_ D)).inv x y = + convAlong R (λ_ (𝟙_ D)).inv y x + exact convAlong_ee_comm R x y + comm_eo := fun x u => by + change convAlong R (λ_ o).inv x u = convAlong R (ρ_ o).inv u x + exact convAlong_eo_comm R x u + comm_oo := fun u v => by + change convAlong R ho.inv u v = -convAlong R ho.inv v u + exact convAlong_oo_comm R ho hβ u v + +end OddLine + +/-! +## Instantiation notes: `D := Ind SmallSuperVect` + +Applying `superGammaAlgebra` over the intended ind-completion +requires the following instance stack on `Ind SmallSuperVect` +(not assembled here; recorded for the instantiation lane): + +* `Preadditive (Ind SmallSuperVect)` and the ℂ-linear structure — + the tree's route is through `RS.ScalarLinear` (linearity of a + preadditive category over the scalars of its unit + endomorphisms) rather than a direct Day-convolution transport; +* the monoidal structure and its braiding on the ind-completion — + `RS.IndMonoidal` / `RS.ScalarBraiding` layer, with + `MonoidalPreadditive` and `MonoidalLinear ℂ` verified against + the transported tensor; +* the odd line: `o := indOf sOdd`, with `ho` induced by the + isomorphism `sOdd ⊗ sOdd ≅ sEven ≅ 𝟙` of `RS.SuperSmall` + (`sEvenIso` after the embedding), `hβ` from the sign of the + super braiding on the odd generator, and `hα` by evaluating + both sides on the one-dimensional odd line; +* the monoid object `R` supplied by the §4 descent, with + `IsCommMonObj R` from commutativity of the transported + multiplication. +-/ + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGammaInst.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGammaInst.lean new file mode 100644 index 0000000000..439797480c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGammaInst.lean @@ -0,0 +1,775 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperGamma +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurTransport + +/-! +# Instantiation of the Γ-algebra substrate at `Ind SmallSuperVect` + +`RS.SuperGamma` builds the four-block super-commutative algebra +`superGammaAlgebra` of a commutative monoid object over any +braided ℂ-linear ambient with an odd line `(o, ho, hβ, hα)`. This +file executes the instantiation plan recorded there: the ambient +is `Ind SmallSuperVect`, the odd line is the embedded odd +generator `indOf.obj sOdd`, and the three hypotheses are proved. + +* The transported monoidal, symmetric and preadditive structure on + `SmallSuperVect` is installed from `SuperVect` across the + small-model equivalence (`Monoidal.transport`); the scalar unit + `ℂ ≃+* End (𝟙_ SmallSuperVect)` follows by full faithfulness of + the inclusion. + +* The three odd-line facts are proved once, by hand, in + `SuperVect` at the standard odd line `ℂ^{0|1}` (`hβ` is the + existing `stdSuper_braiding_neg`; `hα` is the elementwise + computation `superOdd_coherence`), then moved along functors by + a reusable *braided comparison* calculus: a + `RS.BraidedComparison F` packages a unit comparison, a tensor + comparison, and the monoidal-functor axioms for `F`, and the + odd-line data `(ho, hβ, hα)` transports forwards along any + comparison (`coherence_map`, `braiding_neg_map`) and reflects + backwards along a faithful one (`coherence_reflect`, + `braiding_neg_reflect`). Reflection along the small-model + inclusion lands the facts on `sOdd`; forward transport along the + embedding comparison of `indOf` (assembled from the + `IndSchur`/`SchurTransport` lemmas as `indOfComparison`) lifts + them to `Ind SmallSuperVect`. + +* `superGammaAlgebraInd` assembles the resulting + `RS.SuperCommAlgebra` for any commutative monoid object `R` of + `Ind SmallSuperVect`, with the ℂ-linear structure installed from + the scalar unit as in `RS.ScalarLinear`. +-/ + +@[expose] public section + +namespace RS + +noncomputable section + +open CategoryTheory MonoidalCategory Limits + +universe v v' u u' + +/-! ## Braided comparisons and transport of odd-line data + +A *braided comparison* on a functor between braided monoidal +categories is monoidal-functor data up to isomorphism: a unit +comparison, a tensor comparison, and the naturality, associativity, +unitality and braiding axioms. `indOf` carries exactly this data +through the lemmas of `RS.IndTensorExact`, `RS.IndSchur` and +`RS.SchurTransport` without a registered `Functor.Monoidal` +instance, which is why the data is packaged explicitly rather than +through the Mathlib classes. Right unitality is derived from left +unitality through the braiding, so it is not a field. -/ + +section Comparison + +variable {C : Type u} + +/-- Monoidal-functor data up to isomorphism on `F`, with the +braiding axiom: the odd-line transport interface. -/ +structure BraidedComparison + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] {D : Type u'} + [Category.{v'} D] [MonoidalCategory D] [BraidedCategory D] + (F : C ⥤ D) where + /-- The unit comparison. -/ + unitIso : 𝟙_ D ≅ F.obj (𝟙_ C) + /-- The tensor comparison. -/ + tensorIso : ∀ x y : C, F.obj x ⊗ F.obj y ≅ F.obj (x ⊗ y) + /-- Naturality of the tensor comparison in the left factor. -/ + natural_left : ∀ {x x' : C} (f : x ⟶ x') (y : C), + (F.map f ▷ F.obj y) ≫ (tensorIso x' y).hom = + (tensorIso x y).hom ≫ F.map (f ▷ y) + /-- Naturality of the tensor comparison in the right factor. -/ + natural_right : ∀ (x : C) {y y' : C} (g : y ⟶ y'), + (F.obj x ◁ F.map g) ≫ (tensorIso x y').hom = + (tensorIso x y).hom ≫ F.map (x ◁ g) + /-- The associativity axiom. -/ + associativity : ∀ x y z : C, + ((tensorIso x y).hom ▷ F.obj z) ≫ (tensorIso (x ⊗ y) z).hom ≫ + F.map (α_ x y z).hom = + (α_ (F.obj x) (F.obj y) (F.obj z)).hom ≫ + (F.obj x ◁ (tensorIso y z).hom) ≫ (tensorIso x (y ⊗ z)).hom + /-- The left unitality axiom. -/ + left_unitality : ∀ x : C, + (λ_ (F.obj x)).hom = (unitIso.hom ▷ F.obj x) ≫ + (tensorIso (𝟙_ C) x).hom ≫ F.map (λ_ x).hom + /-- The braiding axiom. -/ + braiding : ∀ x y : C, + (β_ (F.obj x) (F.obj y)).hom ≫ (tensorIso y x).hom = + (tensorIso x y).hom ≫ F.map (β_ x y).hom + +namespace BraidedComparison + +/-- A braided functor carries the canonical braided comparison. -/ +def ofBraidedFunctor + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] {D : Type u'} + [Category.{v'} D] [MonoidalCategory D] [BraidedCategory D] + (F : C ⥤ D) [F.Braided] : + BraidedComparison F where + unitIso := Functor.Monoidal.εIso F + tensorIso x y := Functor.Monoidal.μIso F x y + natural_left f y := Functor.LaxMonoidal.μ_natural_left F f y + natural_right x {_ _} g := + Functor.LaxMonoidal.μ_natural_right F x g + associativity x y z := Functor.LaxMonoidal.associativity F x y z + left_unitality x := Functor.LaxMonoidal.left_unitality F x + braiding x y := (Functor.LaxBraided.braided x y).symm + +/-- **Right unitality is derived**: the braiding turns the right +unitor of `F.obj x` into its left unitor, the braiding axiom +carries the braiding downstairs, and the braiding identity of the +base returns the right unitor. -/ +theorem right_unitality + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] {D : Type u'} + [Category.{v'} D] [MonoidalCategory D] [BraidedCategory D] {F : C ⥤ D} + (P : BraidedComparison F) (x : C) : + (ρ_ (F.obj x)).hom = (F.obj x ◁ P.unitIso.hom) ≫ + (P.tensorIso x (𝟙_ C)).hom ≫ F.map (ρ_ x).hom := by + rw [← braiding_leftUnitor (F.obj x), P.left_unitality x, + ← BraidedCategory.braiding_naturality_right_assoc, + reassoc_of% P.braiding x (𝟙_ C), ← Functor.map_comp, + braiding_leftUnitor] + +/-- The transported odd-square trivialization: conjugate `ho` by +the tensor and unit comparisons. -/ +def square + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] {D : Type u'} + [Category.{v'} D] [MonoidalCategory D] [BraidedCategory D] {F : C ⥤ D} + (P : BraidedComparison F) (o : C) + (ho : o ⊗ o ≅ 𝟙_ C) : F.obj o ⊗ F.obj o ≅ 𝟙_ D := + P.tensorIso o o ≪≫ F.mapIso ho ≪≫ P.unitIso.symm + +/-- The inverse of the transported odd square, in components. -/ +theorem square_inv + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] {D : Type u'} + [Category.{v'} D] [MonoidalCategory D] [BraidedCategory D] {F : C ⥤ D} + (P : BraidedComparison F) (o : C) + (ho : o ⊗ o ≅ 𝟙_ C) : + (P.square o ho).inv = + P.unitIso.hom ≫ F.map ho.inv ≫ (P.tensorIso o o).inv := by + simp [square] + +/-- Inverse form of left unitality. -/ +theorem leftUnitor_inv + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] {D : Type u'} + [Category.{v'} D] [MonoidalCategory D] [BraidedCategory D] {F : C ⥤ D} + (P : BraidedComparison F) (x : C) : + (λ_ (F.obj x)).inv = F.map (λ_ x).inv ≫ + (P.tensorIso (𝟙_ C) x).inv ≫ (P.unitIso.inv ▷ F.obj x) := by + have h : λ_ (F.obj x) = + whiskerRightIso P.unitIso (F.obj x) ≪≫ + P.tensorIso (𝟙_ C) x ≪≫ F.mapIso (λ_ x) := + Iso.ext (by simpa using P.left_unitality x) + rw [h] + simp + +/-- Inverse form of right unitality. -/ +theorem rightUnitor_inv + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] {D : Type u'} + [Category.{v'} D] [MonoidalCategory D] [BraidedCategory D] {F : C ⥤ D} + (P : BraidedComparison F) (x : C) : + (ρ_ (F.obj x)).inv = F.map (ρ_ x).inv ≫ + (P.tensorIso x (𝟙_ C)).inv ≫ (F.obj x ◁ P.unitIso.inv) := by + have h : ρ_ (F.obj x) = + whiskerLeftIso (F.obj x) P.unitIso ≪≫ + P.tensorIso x (𝟙_ C) ≪≫ F.mapIso (ρ_ x) := + Iso.ext (by simpa using P.right_unitality x) + rw [h] + simp + +/-- Inverse form of naturality in the left factor. -/ +theorem natural_left_inv + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] {D : Type u'} + [Category.{v'} D] [MonoidalCategory D] [BraidedCategory D] {F : C ⥤ D} + (P : BraidedComparison F) + {x x' : C} (f : x ⟶ x') (y : C) : + (P.tensorIso x y).inv ≫ (F.map f ▷ F.obj y) = + F.map (f ▷ y) ≫ (P.tensorIso x' y).inv := by + rw [← cancel_mono (P.tensorIso x' y).hom] + simp only [Category.assoc] + rw [P.natural_left f y, Iso.inv_hom_id, Category.comp_id, + Iso.inv_hom_id_assoc] + +/-- Inverse form of naturality in the right factor. -/ +theorem natural_right_inv + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] {D : Type u'} + [Category.{v'} D] [MonoidalCategory D] [BraidedCategory D] {F : C ⥤ D} + (P : BraidedComparison F) + (x : C) {y y' : C} (g : y ⟶ y') : + (P.tensorIso x y).inv ≫ (F.obj x ◁ F.map g) = + F.map (x ◁ g) ≫ (P.tensorIso x y').inv := by + rw [← cancel_mono (P.tensorIso x y').hom] + simp only [Category.assoc] + rw [P.natural_right x g, Iso.inv_hom_id, Category.comp_id, + Iso.inv_hom_id_assoc] + +/-- Inverse form of associativity. -/ +theorem associativity_inv + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] {D : Type u'} + [Category.{v'} D] [MonoidalCategory D] [BraidedCategory D] {F : C ⥤ D} + (P : BraidedComparison F) (x y z : C) : + (P.tensorIso (x ⊗ y) z).inv ≫ + ((P.tensorIso x y).inv ▷ F.obj z) ≫ + (α_ (F.obj x) (F.obj y) (F.obj z)).hom = + F.map (α_ x y z).hom ≫ (P.tensorIso x (y ⊗ z)).inv ≫ + (F.obj x ◁ (P.tensorIso y z).inv) := by + rw [← cancel_mono (F.obj x ◁ (P.tensorIso y z).hom), + ← cancel_mono (P.tensorIso x (y ⊗ z)).hom] + simp only [Category.assoc] + rw [← P.associativity x y z, + MonoidalCategory.inv_hom_whiskerRight_assoc, + Iso.inv_hom_id_assoc, + MonoidalCategory.whiskerLeft_inv_hom_assoc, + Iso.inv_hom_id, Category.comp_id] + +/-- **The left odd-line pattern in components**: the transported +form of `(λ_ o).inv ≫ ho.inv ▷ o ≫ (α_ o o o).hom` is the image of +the pattern downstairs, followed by the inverse triple-tensor +comparison. -/ +theorem conv_left + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] {D : Type u'} + [Category.{v'} D] [MonoidalCategory D] [BraidedCategory D] {F : C ⥤ D} + (P : BraidedComparison F) (o : C) + (ho : o ⊗ o ≅ 𝟙_ C) : + (λ_ (F.obj o)).inv ≫ ((P.square o ho).inv ▷ F.obj o) ≫ + (α_ (F.obj o) (F.obj o) (F.obj o)).hom = + F.map ((λ_ o).inv ≫ (ho.inv ▷ o) ≫ (α_ o o o).hom) ≫ + (P.tensorIso o (o ⊗ o)).inv ≫ + (F.obj o ◁ (P.tensorIso o o).inv) := by + rw [P.leftUnitor_inv o, P.square_inv o ho] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc, + Functor.map_comp] + rw [MonoidalCategory.inv_hom_whiskerRight_assoc, + reassoc_of% P.natural_left_inv ho.inv o, + P.associativity_inv o o o] + +/-- **The right odd-line pattern in components**: the transported +form of `(ρ_ o).inv ≫ o ◁ ho.inv` is the image of the pattern +downstairs, followed by the same inverse comparison. -/ +theorem conv_right + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] {D : Type u'} + [Category.{v'} D] [MonoidalCategory D] [BraidedCategory D] {F : C ⥤ D} + (P : BraidedComparison F) (o : C) + (ho : o ⊗ o ≅ 𝟙_ C) : + (ρ_ (F.obj o)).inv ≫ (F.obj o ◁ (P.square o ho).inv) = + F.map ((ρ_ o).inv ≫ (o ◁ ho.inv)) ≫ + (P.tensorIso o (o ⊗ o)).inv ≫ + (F.obj o ◁ (P.tensorIso o o).inv) := by + rw [P.rightUnitor_inv o, P.square_inv o ho] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc, + Functor.map_comp] + rw [MonoidalCategory.whiskerLeft_inv_hom_assoc, + reassoc_of% P.natural_right_inv o ho.inv] + +/-- **Forward transport of the odd-cubed coherence**: the +hypothesis `hα` of `RS.superGammaAlgebra` moves along any braided +comparison. -/ +theorem coherence_map + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] {D : Type u'} + [Category.{v'} D] [MonoidalCategory D] [BraidedCategory D] {F : C ⥤ D} + (P : BraidedComparison F) (o : C) + (ho : o ⊗ o ≅ 𝟙_ C) + (hα : (λ_ o).inv ≫ (ho.inv ▷ o) ≫ (α_ o o o).hom = + (ρ_ o).inv ≫ (o ◁ ho.inv)) : + (λ_ (F.obj o)).inv ≫ ((P.square o ho).inv ▷ F.obj o) ≫ + (α_ (F.obj o) (F.obj o) (F.obj o)).hom = + (ρ_ (F.obj o)).inv ≫ (F.obj o ◁ (P.square o ho).inv) := by + rw [P.conv_left o ho, P.conv_right o ho, hα] + +/-- **Reflection of the odd-cubed coherence**: along a faithful +braided comparison, `hα` downstairs at the transported square +forces `hα` upstairs. -/ +theorem coherence_reflect + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] {D : Type u'} + [Category.{v'} D] [MonoidalCategory D] [BraidedCategory D] {F : C ⥤ D} + (P : BraidedComparison F) [F.Faithful] + (o : C) (ho : o ⊗ o ≅ 𝟙_ C) + (hα : (λ_ (F.obj o)).inv ≫ + ((P.square o ho).inv ▷ F.obj o) ≫ + (α_ (F.obj o) (F.obj o) (F.obj o)).hom = + (ρ_ (F.obj o)).inv ≫ (F.obj o ◁ (P.square o ho).inv)) : + (λ_ o).inv ≫ (ho.inv ▷ o) ≫ (α_ o o o).hom = + (ρ_ o).inv ≫ (o ◁ ho.inv) := by + apply F.map_injective + have h := (P.conv_left o ho).symm.trans + (hα.trans (P.conv_right o ho)) + have h2 := congrArg + (fun m => m ≫ (F.obj o ◁ (P.tensorIso o o).hom) ≫ + (P.tensorIso o (o ⊗ o)).hom) h + simpa only [Category.assoc, + MonoidalCategory.whiskerLeft_inv_hom_assoc, + Iso.inv_hom_id, Category.comp_id] using h2 + +/-- **Forward transport of the odd braiding sign** along an +additive braided comparison. -/ +theorem braiding_neg_map + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] {D : Type u'} + [Category.{v'} D] [MonoidalCategory D] [BraidedCategory D] {F : C ⥤ D} + [Preadditive C] [Preadditive D] + [F.Additive] (P : BraidedComparison F) {o : C} + (hβ : (β_ o o).hom = -𝟙 (o ⊗ o)) : + (β_ (F.obj o) (F.obj o)).hom = + -𝟙 (F.obj o ⊗ F.obj o) := by + have h := P.braiding o o + rw [hβ, F.map_neg, F.map_id, Preadditive.comp_neg, + Category.comp_id] at h + calc (β_ (F.obj o) (F.obj o)).hom + = ((β_ (F.obj o) (F.obj o)).hom ≫ + (P.tensorIso o o).hom) ≫ (P.tensorIso o o).inv := by + rw [Category.assoc, Iso.hom_inv_id, Category.comp_id] + _ = -𝟙 (F.obj o ⊗ F.obj o) := by + rw [h, Preadditive.neg_comp, Iso.hom_inv_id] + +/-- **Reflection of the odd braiding sign** along a faithful +additive braided comparison. -/ +theorem braiding_neg_reflect + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] {D : Type u'} + [Category.{v'} D] [MonoidalCategory D] [BraidedCategory D] {F : C ⥤ D} + [Preadditive C] [Preadditive D] + [F.Additive] [F.Faithful] (P : BraidedComparison F) {o : C} + (hβ : (β_ (F.obj o) (F.obj o)).hom = + -𝟙 (F.obj o ⊗ F.obj o)) : + (β_ o o).hom = -𝟙 (o ⊗ o) := by + apply F.map_injective + have h := P.braiding o o + rw [hβ, Preadditive.neg_comp, Category.id_comp] at h + rw [F.map_neg, F.map_id] + calc F.map (β_ o o).hom + = (P.tensorIso o o).inv ≫ ((P.tensorIso o o).hom ≫ + F.map (β_ o o).hom) := by rw [Iso.inv_hom_id_assoc] + _ = -𝟙 (F.obj (o ⊗ o)) := by + rw [← h, Preadditive.comp_neg, Iso.inv_hom_id] + +end BraidedComparison + +end Comparison + +/-! ## The odd line of `SuperVect`, trivialized + +The standard odd line `ℂ^{0|1}` of `SuperVect` carries the +trivialization `superOddSquare : ℂ^{0|1} ⊗ ℂ^{0|1} ≅ 𝟙`, pairing +the two odd generators; its braiding sign is +`RS.stdSuper_braiding_neg`, and the odd-cubed coherence `hα` is +the elementwise computation `superOdd_coherence`: both insertions +of the trivialized square send the odd generator `e` to +`e ⊗ e ⊗ e`. -/ + +section SuperVectOdd + +open scoped TensorProduct + +/-- Every element of a tensor product with a subsingleton factor +on the left vanishes. -/ +private theorem tensor_zero_left {A M : Type} [AddCommGroup A] + [Module ℂ A] [Subsingleton A] [AddCommGroup M] [Module ℂ M] + (z : A ⊗[ℂ] M) : z = 0 := by + have h0 : (LinearMap.id : A →ₗ[ℂ] A) = 0 := + Subsingleton.elim _ _ + calc z = TensorProduct.map LinearMap.id LinearMap.id z := by + rw [TensorProduct.map_id]; rfl + _ = TensorProduct.map 0 LinearMap.id z := by rw [h0] + _ = 0 := by rw [TensorProduct.map_zero_left]; rfl + +/-- Every element of a tensor product with a subsingleton factor +on the right vanishes. -/ +private theorem tensor_zero_right {A M : Type} [AddCommGroup A] + [Module ℂ A] [Subsingleton A] [AddCommGroup M] [Module ℂ M] + (z : M ⊗[ℂ] A) : z = 0 := by + have h0 : (LinearMap.id : A →ₗ[ℂ] A) = 0 := + Subsingleton.elim _ _ + calc z = TensorProduct.map LinearMap.id LinearMap.id z := by + rw [TensorProduct.map_id]; rfl + _ = TensorProduct.map LinearMap.id 0 z := by rw [h0] + _ = 0 := by rw [TensorProduct.map_zero_right]; rfl + +private instance {A M : Type} [AddCommGroup A] [Module ℂ A] + [Subsingleton A] [AddCommGroup M] [Module ℂ M] : + Subsingleton (A ⊗[ℂ] M) := + ⟨fun a b => by rw [tensor_zero_left a, tensor_zero_left b]⟩ + +private instance {A M : Type} [AddCommGroup A] [Module ℂ A] + [Subsingleton A] [AddCommGroup M] [Module ℂ M] : + Subsingleton (M ⊗[ℂ] A) := + ⟨fun a b => by rw [tensor_zero_right a, tensor_zero_right b]⟩ + +private instance : Subsingleton (stdSuper 0 1).even := + inferInstanceAs (Subsingleton (Fin 0 → ℂ)) + +private instance : Subsingleton (𝟙_ SuperVect).odd := + inferInstanceAs (Subsingleton PUnit) + +private instance : Subsingleton (stdSuper 0 1 ⊗ stdSuper 0 1).odd := + inferInstanceAs (Subsingleton + (((stdSuper 0 1).even ⊗[ℂ] (stdSuper 0 1).odd) × + ((stdSuper 0 1).odd ⊗[ℂ] (stdSuper 0 1).even))) + +/-- A product with a subsingleton first factor is its second +factor. -/ +def prodZeroEquiv (A M : Type) [AddCommGroup A] + [Module ℂ A] [AddCommGroup M] [Module ℂ M] [Subsingleton A] : + (A × M) ≃ₗ[ℂ] M where + toFun p := p.2 + map_add' _ _ := rfl + map_smul' _ _ := rfl + invFun m := (0, m) + left_inv _ := Prod.ext (Subsingleton.elim _ _) rfl + right_inv _ := rfl + +/-- The square of the scalar line, trivialized. -/ +def lineTensorEquiv : + (Fin 1 → ℂ) ⊗[ℂ] (Fin 1 → ℂ) ≃ₗ[ℂ] ℂ := + TensorProduct.congr (LinearEquiv.funUnique (Fin 1) ℂ ℂ) + (LinearEquiv.funUnique (Fin 1) ℂ ℂ) ≪≫ₗ TensorProduct.lid ℂ ℂ + +/-- **The trivialization of the odd square in `SuperVect`**: the +even component pairs the two odd lines through `lineTensorEquiv`, +and the odd component is trivial. -/ +def superOddSquare : stdSuper 0 1 ⊗ stdSuper 0 1 ≅ 𝟙_ SuperVect := + let : Subsingleton ((stdSuper 0 1).even ⊗[ℂ] (stdSuper 0 1).even) := by + infer_instance + let : Subsingleton (stdSuper 0 1 ⊗ stdSuper 0 1).odd := by infer_instance + let : Subsingleton (𝟙_ SuperVect).odd := by infer_instance + SuperVect.isoOfEquivs + (prodZeroEquiv _ _ ≪≫ₗ lineTensorEquiv) + (zeroLinearEquiv _ _) + +/-- The odd generator of the standard odd line. -/ +private def oddGen : Fin 1 → ℂ := fun _ => 1 + +private theorem oddGen_rep (x : Fin 1 → ℂ) : x = x 0 • oddGen := by + funext i + rw [Subsingleton.elim i 0] + simp [oddGen] + +/-- The inverse even component of the trivialization sends `1` to +the pairing tensor of the two odd generators. -/ +private theorem superOddSquare_inv_evenMap_one : + superOddSquare.inv.evenMap (1 : ℂ) = + ((0 : (Fin 0 → ℂ) ⊗[ℂ] (Fin 0 → ℂ)), + oddGen ⊗ₜ[ℂ] oddGen) := by + change (prodZeroEquiv ((Fin 0 → ℂ) ⊗[ℂ] (Fin 0 → ℂ)) + ((Fin 1 → ℂ) ⊗[ℂ] (Fin 1 → ℂ)) ≪≫ₗ + lineTensorEquiv).symm.toLinearMap (1 : ℂ) = _ + have hg : (LinearEquiv.funUnique (Fin 1) ℂ ℂ).symm 1 = oddGen := + rfl + simp only [LinearEquiv.coe_coe, LinearEquiv.trans_symm, + LinearEquiv.trans_apply, lineTensorEquiv, + TensorProduct.lid_symm_apply, TensorProduct.congr_symm_tmul, + hg] + rfl + +/-- The pivot of the odd-cubed coherence: on the line, tensoring +the generator against the paired generator-and-argument agrees +with tensoring the argument against the paired generators. -/ +private theorem line_pair_swap (x : Fin 1 → ℂ) : + oddGen ⊗ₜ[ℂ] + (((0 : (Fin 0 → ℂ) ⊗[ℂ] (Fin 0 → ℂ)), + oddGen ⊗ₜ[ℂ] x) : + ((Fin 0 → ℂ) ⊗[ℂ] (Fin 0 → ℂ)) × + ((Fin 1 → ℂ) ⊗[ℂ] (Fin 1 → ℂ))) = + x ⊗ₜ[ℂ] (0, oddGen ⊗ₜ[ℂ] oddGen) := by + have h1 : (((0 : (Fin 0 → ℂ) ⊗[ℂ] (Fin 0 → ℂ)), + oddGen ⊗ₜ[ℂ] (x 0 • oddGen)) : + ((Fin 0 → ℂ) ⊗[ℂ] (Fin 0 → ℂ)) × + ((Fin 1 → ℂ) ⊗[ℂ] (Fin 1 → ℂ))) = + x 0 • (0, oddGen ⊗ₜ[ℂ] oddGen) := by + refine Prod.ext ?_ ?_ + · exact Subsingleton.elim _ _ + · change oddGen ⊗ₜ[ℂ] (x 0 • oddGen) = + x 0 • (oddGen ⊗ₜ[ℂ] oddGen) + rw [TensorProduct.tmul_smul] + conv_lhs => rw [oddGen_rep x] + conv_rhs => rw [oddGen_rep x] + rw [h1, TensorProduct.tmul_smul, TensorProduct.smul_tmul'] + +/-- The odd-cubed coherence of `SuperVect`, in raw components: the +two composites agree on every argument, for any inverse components +`E`, `O` of a trivialization whose even part pairs the odd +generators. -/ +private theorem raw_coherence (E : ℂ →ₗ[ℂ] ((Fin 0 → ℂ) ⊗[ℂ] (Fin 0 → ℂ)) × + ((Fin 1 → ℂ) ⊗[ℂ] (Fin 1 → ℂ))) + (O : PUnit →ₗ[ℂ] ((Fin 0 → ℂ) ⊗[ℂ] (Fin 1 → ℂ)) × + ((Fin 1 → ℂ) ⊗[ℂ] (Fin 0 → ℂ))) + (hE : E 1 = (0, oddGen ⊗ₜ[ℂ] oddGen)) (x : Fin 1 → ℂ) : + (SuperVect.assocAux (Fin 0 → ℂ) (Fin 1 → ℂ) (Fin 0 → ℂ) + (Fin 1 → ℂ) (Fin 1 → ℂ) (Fin 0 → ℂ)).toLinearMap + (LinearMap.prodMap (TensorProduct.map E LinearMap.id) + (TensorProduct.map O LinearMap.id) + ((LinearMap.inl ℂ (ℂ ⊗[ℂ] (Fin 1 → ℂ)) + (PUnit ⊗[ℂ] (Fin 0 → ℂ)) ∘ₗ + (TensorProduct.lid ℂ (Fin 1 → ℂ)).symm.toLinearMap) + x)) = + LinearMap.prodMap (TensorProduct.map LinearMap.id O) + (TensorProduct.map LinearMap.id E) + ((LinearMap.inr ℂ ((Fin 0 → ℂ) ⊗[ℂ] PUnit) + ((Fin 1 → ℂ) ⊗[ℂ] ℂ) ∘ₗ + (TensorProduct.rid ℂ (Fin 1 → ℂ)).symm.toLinearMap) + x) := by + simp only [LinearMap.coe_comp, Function.comp_apply, + LinearEquiv.coe_coe, TensorProduct.lid_symm_apply, + TensorProduct.rid_symm_apply, LinearMap.inl_apply, + LinearMap.inr_apply, LinearMap.prodMap_apply, + TensorProduct.map_tmul, LinearMap.id_apply, map_zero, hE] + have h := assocAux_pure (0 : Fin 0 → ℂ) oddGen + (0 : Fin 0 → ℂ) oddGen x (0 : Fin 0 → ℂ) + simp only [TensorProduct.zero_tmul, TensorProduct.tmul_zero] + at h + rw [h] + exact Prod.ext rfl (line_pair_swap x) + +/-- **The odd-cubed coherence holds in `SuperVect`** at the +standard odd line: both insertions of the trivialized square send +the odd generator to the triple tensor of generators. -/ +theorem superOdd_coherence : + (λ_ (stdSuper 0 1)).inv ≫ + (superOddSquare.inv ▷ stdSuper 0 1) ≫ + (α_ (stdSuper 0 1) (stdSuper 0 1) (stdSuper 0 1)).hom = + (ρ_ (stdSuper 0 1)).inv ≫ + (stdSuper 0 1 ◁ superOddSquare.inv) := by + apply SuperVect.hom_ext + · exact Subsingleton.elim _ _ + · exact LinearMap.ext fun x => + raw_coherence superOddSquare.inv.evenMap + superOddSquare.inv.oddMap superOddSquare_inv_evenMap_one x + +end SuperVectOdd + +/-! ## The transported structure on the small model + +`SmallSuperVect` receives the monoidal and symmetric structure of +`SuperVect` across the small-model equivalence, by +`Monoidal.transport`; the inclusion is then monoidal, braided, +faithful and additive, so preadditivity of the tensor and the +scalar unit follow by reflection. -/ + +section SmallModel + +/-- The monoidal structure of the small model, transported from +`SuperVect` across the small-model equivalence. -/ +noncomputable instance : MonoidalCategory SmallSuperVect := + Monoidal.transport smallSuperEquiv.symm + +/-- The symmetry of the small model. -/ +noncomputable instance : SymmetricCategory SmallSuperVect := + inferInstanceAs + (SymmetricCategory (Monoidal.Transported smallSuperEquiv.symm)) + +/-- The inclusion is monoidal for the transported structure. -/ +noncomputable instance : smallSuperInclusion.Monoidal := + inferInstanceAs + ((Monoidal.equivalenceTransported + smallSuperEquiv.symm).inverse.Monoidal) + +/-- The inclusion is braided for the transported structure. -/ +noncomputable instance : smallSuperInclusion.Braided := + inferInstanceAs + ((Monoidal.equivalenceTransported + smallSuperEquiv.symm).inverse.Braided) + +/-- The small model is monoidal preadditive, by reflection along +the faithful additive monoidal inclusion. -/ +noncomputable instance : MonoidalPreadditive SmallSuperVect := + monoidalPreadditive_of_faithful smallSuperInclusion + +/-- The even component of a unit endomorphism, at the scalar +type. -/ +def unitEvenMap (f : End (𝟙_ SuperVect)) : ℂ →ₗ[ℂ] ℂ := + f.evenMap + +/-- **The scalar unit of `SuperVect`**: endomorphisms of the +monoidal unit are the scalars. -/ +def superVectScalarUnit : ℂ ≃+* End (𝟙_ SuperVect) where + toFun c := ⟨c • (LinearMap.id : ℂ →ₗ[ℂ] ℂ), 0⟩ + invFun f := unitEvenMap f 1 + left_inv c := by + change (c • (LinearMap.id : ℂ →ₗ[ℂ] ℂ)) 1 = c + simp + right_inv f := by + apply SuperVect.hom_ext + · change (unitEvenMap f 1) • (LinearMap.id : ℂ →ₗ[ℂ] ℂ) = + unitEvenMap f + refine LinearMap.ext fun z => ?_ + calc (unitEvenMap f 1 • (LinearMap.id : ℂ →ₗ[ℂ] ℂ)) z + = z • unitEvenMap f 1 := by + change unitEvenMap f 1 * z = _ + rw [smul_eq_mul, mul_comm] + _ = unitEvenMap f (z • 1) := + (map_smul (unitEvenMap f) z 1).symm + _ = unitEvenMap f z := by + rw [smul_eq_mul, mul_one] + · exact Subsingleton.elim _ _ + map_mul' a b := by + apply SuperVect.hom_ext + · change (a * b) • (LinearMap.id : ℂ →ₗ[ℂ] ℂ) = + (a • (LinearMap.id : ℂ →ₗ[ℂ] ℂ)) ∘ₗ + (b • (LinearMap.id : ℂ →ₗ[ℂ] ℂ)) + refine LinearMap.ext fun z => ?_ + change (a * b) * z = a * (b * z) + rw [mul_assoc] + · exact Subsingleton.elim _ _ + map_add' a b := by + apply SuperVect.hom_ext + · change (a + b) • (LinearMap.id : ℂ →ₗ[ℂ] ℂ) = + a • (LinearMap.id : ℂ →ₗ[ℂ] ℂ) + + b • (LinearMap.id : ℂ →ₗ[ℂ] ℂ) + exact add_smul a b _ + · exact Subsingleton.elim _ _ + +/-- Full faithfulness of the inclusion on endomorphisms, as a ring +isomorphism; `End`-multiplication is reversed composition on both +sides, and the inclusion is functorial on the nose. -/ +def smallEndRingEquiv (x : SmallSuperVect) : + End x ≃+* End (smallSuperInclusion.obj x) := + { InducedCategory.homAddEquiv (C := SuperVect) + (F := SuperVect.stdObj) (X := x) (Y := x) with + map_mul' := fun _ _ => rfl } + +/-- **The scalar unit of the small model**: transport the scalar +unit of `SuperVect` along the unit comparison of the inclusion and +pull back by full faithfulness. -/ +def smallScalarUnit : ℂ ≃+* End (𝟙_ SmallSuperVect) := + (superVectScalarUnit.trans + (endCongrRingEquiv + (Functor.Monoidal.εIso smallSuperInclusion))).trans + (smallEndRingEquiv (𝟙_ SmallSuperVect)).symm + +/-- The canonical braided comparison on the inclusion. -/ +noncomputable def smallComparison : + BraidedComparison smallSuperInclusion := + BraidedComparison.ofBraidedFunctor smallSuperInclusion + +/-- **The trivialized odd square of the small model**: the +`SuperVect` trivialization of the embedded odd generator, pulled +back through the fully faithful inclusion. -/ +noncomputable def smallOddSquare : sOdd ⊗ sOdd ≅ 𝟙_ SmallSuperVect := + (fullyFaithfulInducedFunctor SuperVect.stdObj).preimageIso + ((Functor.Monoidal.μIso smallSuperInclusion sOdd sOdd).symm ≪≫ + superOddSquare ≪≫ + Functor.Monoidal.εIso smallSuperInclusion) + +/-- The comparison square of `smallOddSquare` is the `SuperVect` +trivialization it was pulled back from. -/ +theorem smallComparison_square : + smallComparison.square sOdd smallOddSquare = superOddSquare := by + refine Iso.ext ?_ + change (Functor.Monoidal.μIso smallSuperInclusion sOdd sOdd).hom ≫ + smallSuperInclusion.map smallOddSquare.hom ≫ + (Functor.Monoidal.εIso smallSuperInclusion).inv = + superOddSquare.hom + rw [smallOddSquare, Functor.FullyFaithful.preimageIso_hom, + Functor.FullyFaithful.map_preimage] + simp only [Iso.trans_hom, Iso.symm_hom, Category.assoc, Iso.hom_inv_id_assoc] + erw [Iso.trans_hom, Category.assoc, Iso.hom_inv_id, Category.comp_id] + +/-- **The braiding sign at the small odd generator**, by +reflection along the inclusion from `RS.stdSuper_braiding_neg`. -/ +theorem smallOdd_braiding : + (β_ sOdd sOdd).hom = -𝟙 (sOdd ⊗ sOdd) := + smallComparison.braiding_neg_reflect stdSuper_braiding_neg + +/-- **The odd-cubed coherence at the small odd generator**, by +reflection along the inclusion from `RS.superOdd_coherence`. -/ +theorem smallOdd_coherence : + (λ_ sOdd).inv ≫ (smallOddSquare.inv ▷ sOdd) ≫ + (α_ sOdd sOdd sOdd).hom = + (ρ_ sOdd).inv ≫ (sOdd ◁ smallOddSquare.inv) := + smallComparison.coherence_reflect sOdd smallOddSquare + (by rw [smallComparison_square]; exact superOdd_coherence) + +end SmallModel + +/-! ## The embedding comparison of `indOf` -/ + +section IndComparison + +variable {C : Type v} + +/-- **The braided comparison of the ind-embedding**: the unit and +tensor comparisons of `RS.IndSchur` and `RS.SchurTransport` +assemble into a braided comparison on `indOf`, over any braided +small base. -/ +def indOfComparison [SmallCategory C] [MonoidalCategory C] [BraidedCategory C] : + BraidedComparison (indOf (C := C)) where + unitIso := indOfUnitIso + tensorIso x y := indOfTensorIso x y + natural_left f y := indOfTensorIso_hom_natural_left f y + natural_right x {_ _} g := indOfTensorIso_hom_natural_right x g + associativity x y z := indOfTensorIso_hom_associator x y z + left_unitality x := indOf_leftUnitor_hom x + braiding x y := indOfTensorIso_hom_braiding x y + +end IndComparison + +/-! ## The odd line of `Ind SmallSuperVect` and the Γ-algebra -/ + +section IndAssembly + +/-- **The odd line of the instantiated ambient**: the embedded odd +generator of the small model. -/ +def indOddLine : Ind SmallSuperVect := indOf.obj sOdd + +/-- **The trivialized odd square of the ambient**: the transported +small-model trivialization. -/ +def indOddSquare : + indOddLine ⊗ indOddLine ≅ 𝟙_ (Ind SmallSuperVect) := + indOfComparison.square sOdd smallOddSquare + +/-- **The braiding sign at the odd line of the ambient**: the +hypothesis `hβ` of `RS.superGammaAlgebra`. -/ +theorem indOdd_braiding : + (β_ indOddLine indOddLine).hom = + -𝟙 (indOddLine ⊗ indOddLine) := + haveI := indOf_additive (C := SmallSuperVect) + indOfComparison.braiding_neg_map smallOdd_braiding + +/-- **The odd-cubed coherence at the odd line of the ambient**: +the hypothesis `hα` of `RS.superGammaAlgebra`. -/ +theorem indOdd_coherence : + (λ_ indOddLine).inv ≫ (indOddSquare.inv ▷ indOddLine) ≫ + (α_ indOddLine indOddLine indOddLine).hom = + (ρ_ indOddLine).inv ≫ (indOddLine ◁ indOddSquare.inv) := + indOfComparison.coherence_map sOdd smallOddSquare + smallOdd_coherence + +/-- **The Γ-algebra of the instantiated ambient**: for any +commutative monoid object `R` of `Ind SmallSuperVect`, the +morphisms out of the unit and out of the embedded odd generator +form a super-commutative ℂ-algebra under prefixed convolution — +`RS.superGammaAlgebra` at the odd line `indOddLine`, with the +ℂ-linear structure installed from the scalar unit of the small +model as in `RS.ScalarLinear`. -/ +def superGammaAlgebraInd (R : Ind SmallSuperVect) [MonObj R] + [IsCommMonObj R] : SuperCommAlgebra := + letI := linearOfScalarUnit (indScalarUnit smallScalarUnit) + haveI : MonoidalLinear ℂ (Ind SmallSuperVect) := + monoidalLinearOfScalarUnitBraided + (indScalarUnit smallScalarUnit) + superGammaAlgebra R indOddLine indOddSquare indOdd_braiding + indOdd_coherence + +/-! ## Acceptance -/ + +/- The carriers are the ones recorded in the instantiation plan: +`R`-valued points of the unit and of the embedded odd generator. -/ + +example (R : Ind SmallSuperVect) [MonObj R] [IsCommMonObj R] : + (superGammaAlgebraInd R).even = + (𝟙_ (Ind SmallSuperVect) ⟶ R) := rfl + +example (R : Ind SmallSuperVect) [MonObj R] [IsCommMonObj R] : + (superGammaAlgebraInd R).odd = (indOf.obj sOdd ⟶ R) := rfl + +end IndAssembly + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModAbelian.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModAbelian.lean new file mode 100644 index 0000000000..0566579112 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModAbelian.lean @@ -0,0 +1,707 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprod + +/-! +# Super modules form an abelian category + +A module over a super-commutative ℂ-algebra `S` is a pair of +ℂ-modules carrying four bilinear action blocks, and a morphism is a +pair of ℂ-linear maps intertwining those blocks. Every construction +needed for abelianness is therefore performed degreewise in +`Module ℂ`: + +* the kernel is the pair of kernels of the two components, and the + four blocks restrict to it; +* the cokernel is the pair of quotients by the two ranges, and the + four blocks descend to them; +* a morphism is a monomorphism exactly when both of its components + are injective, and an epimorphism exactly when both are + surjective — the forward directions are read off the kernel and + the cokernel respectively; +* a monomorphism is the kernel of its cokernel and an epimorphism is + the cokernel of its kernel, because a degreewise factorisation + through an injective (respectively surjective) component again + intertwines the four blocks. + +The route taken to `CategoryTheory.Abelian` is therefore the +normality route: the two normality instances, together with the +finite products of `RS.Classical.Deligne.SuperModBiprod` and the +kernels and cokernels built here. + +Two small pieces of linear algebra carry all of the graded +bookkeeping. `RS.SuperCommAlgebra.Mod.actRestrict` restricts a +bilinear action block to a pair of submodules stable under it, and +`RS.SuperCommAlgebra.Mod.actQuot` descends one to a pair of +quotients; the ten axioms of a super module are pointwise +identities, so each survives verbatim in a submodule and in a +quotient. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Limits + +universe u + +namespace SuperCommAlgebra.Mod + +variable {S : SuperCommAlgebra.{u, u}} + +/-! ## Restricting and descending an action block -/ + +section Blocks + +variable {A E F : Type*} + +/-- **The restriction of an action block** to a pair of submodules +carried into one another by it. -/ +def actRestrict [AddCommGroup A] [Module ℂ A] [AddCommGroup E] [Module ℂ E] + [AddCommGroup F] [Module ℂ F] + (φ : A →ₗ[ℂ] E →ₗ[ℂ] F) {p : Submodule ℂ E} + {q : Submodule ℂ F} (h : ∀ a : A, ∀ e ∈ p, φ a e ∈ q) : + A →ₗ[ℂ] p →ₗ[ℂ] q where + toFun a := + LinearMap.codRestrict q ((φ a).comp p.subtype) + fun e => h a e e.2 + map_add' a b := by + refine LinearMap.ext fun e => Subtype.ext ?_ + simp + rfl + map_smul' c a := by + refine LinearMap.ext fun e => Subtype.ext ?_ + simp + rfl + +@[simp] +theorem actRestrict_coe + [AddCommGroup A] [Module ℂ A] [AddCommGroup E] [Module ℂ E] + [AddCommGroup F] [Module ℂ F] + (φ : A →ₗ[ℂ] E →ₗ[ℂ] F) + {p : Submodule ℂ E} {q : Submodule ℂ F} + (h : ∀ a : A, ∀ e ∈ p, φ a e ∈ q) (a : A) (e : p) : + (actRestrict φ h a e : F) = φ a e := rfl + +/-- **The descent of an action block** to a pair of quotients, the +first by a submodule carried by the block into the second. -/ +def actQuot [AddCommGroup A] [Module ℂ A] [AddCommGroup E] [Module ℂ E] + [AddCommGroup F] [Module ℂ F] + (φ : A →ₗ[ℂ] E →ₗ[ℂ] F) {p : Submodule ℂ E} + {q : Submodule ℂ F} (h : ∀ a : A, ∀ e ∈ p, φ a e ∈ q) : + A →ₗ[ℂ] (E ⧸ p) →ₗ[ℂ] (F ⧸ q) := + (p.liftQ (LinearMap.compr₂ φ q.mkQ).flip + (by + intro e he + refine LinearMap.mem_ker.2 (LinearMap.ext fun a => ?_) + exact (Submodule.Quotient.mk_eq_zero q).2 (h a e he))).flip + +@[simp] +theorem actQuot_mk [AddCommGroup A] [Module ℂ A] [AddCommGroup E] [Module ℂ E] + [AddCommGroup F] [Module ℂ F] + (φ : A →ₗ[ℂ] E →ₗ[ℂ] F) {p : Submodule ℂ E} + {q : Submodule ℂ F} (h : ∀ a : A, ∀ e ∈ p, φ a e ∈ q) (a : A) + (e : E) : + actQuot φ h a (Submodule.Quotient.mk e) + = (Submodule.Quotient.mk (φ a e) : F ⧸ q) := rfl + +/-- Congruence for the class map of a quotient module. -/ +theorem quotMk_congr [AddCommGroup F] [Module ℂ F] + {q : Submodule ℂ F} {a b : F} (h : a = b) : + (Submodule.Quotient.mk a : F ⧸ q) = Submodule.Quotient.mk b := + congrArg _ h + +end Blocks + +/-! ## Degreewise factorisation -/ + +section Factor + +variable {E F G : Type*} + +/-- **The factorisation of a linear map through an injective one** +whose range contains its values. -/ +noncomputable def preimageMap + [AddCommGroup E] [Module ℂ E] [AddCommGroup F] [Module ℂ F] + [AddCommGroup G] [Module ℂ G] + (g : E →ₗ[ℂ] G) (φ : F →ₗ[ℂ] G) + (hφ : Function.Injective φ) + (h : ∀ e, g e ∈ LinearMap.range φ) : E →ₗ[ℂ] F := + (LinearEquiv.ofInjective φ hφ).symm.toLinearMap.comp + (LinearMap.codRestrict (LinearMap.range φ) g h) + +@[simp] +theorem preimageMap_spec + [AddCommGroup E] [Module ℂ E] [AddCommGroup F] [Module ℂ F] + [AddCommGroup G] [Module ℂ G] + (g : E →ₗ[ℂ] G) (φ : F →ₗ[ℂ] G) + (hφ : Function.Injective φ) + (h : ∀ e, g e ∈ LinearMap.range φ) (e : E) : + φ (preimageMap g φ hφ h e) = g e := + LinearEquiv.ofInjective_symm_apply (h := hφ) φ _ + +/-- A linear map annihilating the kernel of another has a larger +kernel. -/ +theorem ker_le_ker [AddCommGroup E] [Module ℂ E] [AddCommGroup F] [Module ℂ F] + [AddCommGroup G] [Module ℂ G] + (g : E →ₗ[ℂ] G) (φ : E →ₗ[ℂ] F) + (h : ∀ e, φ e = 0 → g e = 0) : + LinearMap.ker φ ≤ LinearMap.ker g := by + intro e he + exact LinearMap.mem_ker.2 (h e (LinearMap.mem_ker.1 he)) + +/-- **The factorisation of a linear map through a surjective one** +whose kernel it annihilates. -/ +noncomputable def quotientMap + [AddCommGroup E] [Module ℂ E] [AddCommGroup F] [Module ℂ F] + [AddCommGroup G] [Module ℂ G] + (g : E →ₗ[ℂ] G) (φ : E →ₗ[ℂ] F) + (hφ : Function.Surjective φ) + (h : ∀ e, φ e = 0 → g e = 0) : F →ₗ[ℂ] G := + (Submodule.liftQ (LinearMap.ker φ) g (ker_le_ker g φ h)).comp + (LinearMap.quotKerEquivOfSurjective φ hφ).symm.toLinearMap + +@[simp] +theorem quotientMap_spec + [AddCommGroup E] [Module ℂ E] [AddCommGroup F] [Module ℂ F] + [AddCommGroup G] [Module ℂ G] + (g : E →ₗ[ℂ] G) (φ : E →ₗ[ℂ] F) + (hφ : Function.Surjective φ) + (h : ∀ e, φ e = 0 → g e = 0) (e : E) : + quotientMap g φ hφ h (φ e) = g e := by + have hs : (LinearMap.quotKerEquivOfSurjective φ hφ).symm (φ e) + = Submodule.Quotient.mk e := + LinearMap.quotKerEquivOfSurjective_symm_apply φ hφ e + change Submodule.liftQ (LinearMap.ker φ) g (ker_le_ker g φ h) + ((LinearMap.quotKerEquivOfSurjective φ hφ).symm (φ e)) = g e + rw [hs] + rfl + +end Factor + +/-! ## Degreewise criteria for monomorphisms and epimorphisms -/ + +section Criteria + +variable {M N : S.Mod.{u, u, u, u}} + +/-- A degreewise injective morphism of super modules is a +monomorphism. -/ +theorem mono_of_injective (f : M ⟶ N) + (he : Function.Injective f.evenMap) + (ho : Function.Injective f.oddMap) : Mono f where + right_cancellation {W} g h heq := by + refine Hom.ext (LinearMap.ext fun w => he ?_) + (LinearMap.ext fun w => ho ?_) + · exact congrArg (fun t : W ⟶ N => t.evenMap w) heq + · exact congrArg (fun t : W ⟶ N => t.oddMap w) heq + +/-- A degreewise surjective morphism of super modules is an +epimorphism. -/ +theorem epi_of_surjective (f : M ⟶ N) + (he : Function.Surjective f.evenMap) + (ho : Function.Surjective f.oddMap) : Epi f where + left_cancellation {W} g h heq := by + refine Hom.ext (LinearMap.ext fun n => ?_) + (LinearMap.ext fun n => ?_) + · obtain ⟨m, rfl⟩ := he n + exact congrArg (fun t : M ⟶ W => t.evenMap m) heq + · obtain ⟨m, rfl⟩ := ho n + exact congrArg (fun t : M ⟶ W => t.oddMap m) heq + +end Criteria + +/-! ## Kernels -/ + +section Kernels + +variable {M N : S.Mod.{u, u, u, u}} (f : M ⟶ N) + +theorem actEE_mem_ker (x : S.even) (m : M.even) + (hm : m ∈ LinearMap.ker f.evenMap) : + M.actEE x m ∈ LinearMap.ker f.evenMap := by + refine LinearMap.mem_ker.2 ?_ + rw [f.map_actEE, LinearMap.mem_ker.1 hm, map_zero] + +theorem actEO_mem_ker (x : S.even) (m : M.odd) + (hm : m ∈ LinearMap.ker f.oddMap) : + M.actEO x m ∈ LinearMap.ker f.oddMap := by + refine LinearMap.mem_ker.2 ?_ + rw [f.map_actEO, LinearMap.mem_ker.1 hm, map_zero] + +theorem actOE_mem_ker (v : S.odd) (m : M.even) + (hm : m ∈ LinearMap.ker f.evenMap) : + M.actOE v m ∈ LinearMap.ker f.oddMap := by + refine LinearMap.mem_ker.2 ?_ + rw [f.map_actOE, LinearMap.mem_ker.1 hm, map_zero] + +theorem actOO_mem_ker (v : S.odd) (m : M.odd) + (hm : m ∈ LinearMap.ker f.oddMap) : + M.actOO v m ∈ LinearMap.ker f.evenMap := by + refine LinearMap.mem_ker.2 ?_ + rw [f.map_actOO, LinearMap.mem_ker.1 hm, map_zero] + +/-- **The kernel of a morphism of super modules**: the kernels of +the two components, with the four action blocks restricted. -/ +def kerMod : S.Mod.{u, u, u, u} where + even := LinearMap.ker f.evenMap + odd := LinearMap.ker f.oddMap + actEE := actRestrict M.actEE (actEE_mem_ker f) + actEO := actRestrict M.actEO (actEO_mem_ker f) + actOE := actRestrict M.actOE (actOE_mem_ker f) + actOO := actRestrict M.actOO (actOO_mem_ker f) + one_act_e m := Subtype.ext (M.one_act_e m.1) + one_act_o m := Subtype.ext (M.one_act_o m.1) + assoc_eee x y m := Subtype.ext (M.assoc_eee x y m.1) + assoc_eeo x y m := Subtype.ext (M.assoc_eeo x y m.1) + assoc_eoe x v m := Subtype.ext (M.assoc_eoe x v m.1) + assoc_eoo x v m := Subtype.ext (M.assoc_eoo x v m.1) + assoc_oee v x m := Subtype.ext (M.assoc_oee v x m.1) + assoc_oeo v x m := Subtype.ext (M.assoc_oeo v x m.1) + assoc_ooe v w m := Subtype.ext (M.assoc_ooe v w m.1) + assoc_ooo v w m := Subtype.ext (M.assoc_ooo v w m.1) + +/-- The inclusion of the kernel of a morphism of super modules. -/ +def kerIncl : kerMod f ⟶ M where + evenMap := (LinearMap.ker f.evenMap).subtype + oddMap := (LinearMap.ker f.oddMap).subtype + map_actEE _ _ := rfl + map_actEO _ _ := rfl + map_actOE _ _ := rfl + map_actOO _ _ := rfl + +theorem kerIncl_comp : kerIncl f ≫ f = 0 := by + refine Hom.ext (LinearMap.ext fun z => ?_) + (LinearMap.ext fun z => ?_) + · exact LinearMap.mem_ker.1 z.2 + · exact LinearMap.mem_ker.1 z.2 + +/-- The inclusion of the kernel is a monomorphism. -/ +theorem mono_kerIncl : Mono (kerIncl f) := + mono_of_injective _ Subtype.coe_injective Subtype.coe_injective + +/-- The lift of a morphism annihilated by `f` through the +inclusion of the kernel. -/ +def kerLift {W : S.Mod.{u, u, u, u}} (k : W ⟶ M) + (hk : k ≫ f = 0) : W ⟶ kerMod f where + evenMap := + LinearMap.codRestrict _ k.evenMap fun w => + LinearMap.mem_ker.2 + (congrArg (fun t : W ⟶ N => t.evenMap w) hk) + oddMap := + LinearMap.codRestrict _ k.oddMap fun w => + LinearMap.mem_ker.2 + (congrArg (fun t : W ⟶ N => t.oddMap w) hk) + map_actEE x m := Subtype.ext (k.map_actEE x m) + map_actEO x m := Subtype.ext (k.map_actEO x m) + map_actOE v m := Subtype.ext (k.map_actOE v m) + map_actOO v m := Subtype.ext (k.map_actOO v m) + +theorem kerLift_comp {W : S.Mod.{u, u, u, u}} (k : W ⟶ M) + (hk : k ≫ f = 0) : kerLift f k hk ≫ kerIncl f = k := + Hom.ext (LinearMap.ext fun _ => rfl) (LinearMap.ext fun _ => rfl) + +/-- The kernel fork of a morphism of super modules. -/ +def kernelFork : KernelFork f := + KernelFork.ofι (kerIncl f) (kerIncl_comp f) + +/-- **The kernel fork is limiting.** -/ +def kernelForkIsLimit : IsLimit (kernelFork f) := + have : Mono (kerIncl f) := mono_kerIncl f + KernelFork.IsLimit.ofι' (kerIncl f) (kerIncl_comp f) + fun k hk => ⟨kerLift f k hk, kerLift_comp f k hk⟩ + +/-- **Super modules have kernels**, computed degreewise. -/ +instance instHasKernels : HasKernels S.Mod.{u, u, u, u} where + has_limit f := HasLimit.mk + { cone := kernelFork f + isLimit := kernelForkIsLimit f } + +end Kernels + +/-! ## Cokernels -/ + +section Cokernels + +variable {M N : S.Mod.{u, u, u, u}} (f : M ⟶ N) + +theorem actEE_mem_range (x : S.even) (n : N.even) + (hn : n ∈ LinearMap.range f.evenMap) : + N.actEE x n ∈ LinearMap.range f.evenMap := by + obtain ⟨m, rfl⟩ := hn + exact ⟨M.actEE x m, f.map_actEE x m⟩ + +theorem actEO_mem_range (x : S.even) (n : N.odd) + (hn : n ∈ LinearMap.range f.oddMap) : + N.actEO x n ∈ LinearMap.range f.oddMap := by + obtain ⟨m, rfl⟩ := hn + exact ⟨M.actEO x m, f.map_actEO x m⟩ + +theorem actOE_mem_range (v : S.odd) (n : N.even) + (hn : n ∈ LinearMap.range f.evenMap) : + N.actOE v n ∈ LinearMap.range f.oddMap := by + obtain ⟨m, rfl⟩ := hn + exact ⟨M.actOE v m, f.map_actOE v m⟩ + +theorem actOO_mem_range (v : S.odd) (n : N.odd) + (hn : n ∈ LinearMap.range f.oddMap) : + N.actOO v n ∈ LinearMap.range f.evenMap := by + obtain ⟨m, rfl⟩ := hn + exact ⟨M.actOO v m, f.map_actOO v m⟩ + +/-- **The cokernel of a morphism of super modules**: the quotients +of the two components by the two ranges, with the four action +blocks descended. -/ +def cokerMod : S.Mod.{u, u, u, u} where + even := N.even ⧸ LinearMap.range f.evenMap + odd := N.odd ⧸ LinearMap.range f.oddMap + actEE := actQuot N.actEE (actEE_mem_range f) + actEO := actQuot N.actEO (actEO_mem_range f) + actOE := actQuot N.actOE (actOE_mem_range f) + actOO := actQuot N.actOO (actOO_mem_range f) + one_act_e z := by + obtain ⟨n, rfl⟩ := Submodule.Quotient.mk_surjective _ z + exact quotMk_congr (N.one_act_e n) + one_act_o z := by + obtain ⟨n, rfl⟩ := Submodule.Quotient.mk_surjective _ z + exact quotMk_congr (N.one_act_o n) + assoc_eee x y z := by + obtain ⟨n, rfl⟩ := Submodule.Quotient.mk_surjective _ z + exact quotMk_congr (N.assoc_eee x y n) + assoc_eeo x y z := by + obtain ⟨n, rfl⟩ := Submodule.Quotient.mk_surjective _ z + exact quotMk_congr (N.assoc_eeo x y n) + assoc_eoe x v z := by + obtain ⟨n, rfl⟩ := Submodule.Quotient.mk_surjective _ z + exact quotMk_congr (N.assoc_eoe x v n) + assoc_eoo x v z := by + obtain ⟨n, rfl⟩ := Submodule.Quotient.mk_surjective _ z + exact quotMk_congr (N.assoc_eoo x v n) + assoc_oee v x z := by + obtain ⟨n, rfl⟩ := Submodule.Quotient.mk_surjective _ z + exact quotMk_congr (N.assoc_oee v x n) + assoc_oeo v x z := by + obtain ⟨n, rfl⟩ := Submodule.Quotient.mk_surjective _ z + exact quotMk_congr (N.assoc_oeo v x n) + assoc_ooe v w z := by + obtain ⟨n, rfl⟩ := Submodule.Quotient.mk_surjective _ z + exact quotMk_congr (N.assoc_ooe v w n) + assoc_ooo v w z := by + obtain ⟨n, rfl⟩ := Submodule.Quotient.mk_surjective _ z + exact quotMk_congr (N.assoc_ooo v w n) + +/-- The projection onto the cokernel of a morphism of super +modules. -/ +def cokerProj : N ⟶ cokerMod f where + evenMap := (LinearMap.range f.evenMap).mkQ + oddMap := (LinearMap.range f.oddMap).mkQ + map_actEE _ _ := rfl + map_actEO _ _ := rfl + map_actOE _ _ := rfl + map_actOO _ _ := rfl + +theorem comp_cokerProj : f ≫ cokerProj f = 0 := by + refine Hom.ext (LinearMap.ext fun m => ?_) + (LinearMap.ext fun m => ?_) + · exact (Submodule.Quotient.mk_eq_zero _).2 ⟨m, rfl⟩ + · exact (Submodule.Quotient.mk_eq_zero _).2 ⟨m, rfl⟩ + +/-- The projection onto the cokernel is an epimorphism. -/ +theorem epi_cokerProj : Epi (cokerProj f) := + epi_of_surjective _ (Submodule.mkQ_surjective _) + (Submodule.mkQ_surjective _) + +/-- The descent of a morphism annihilating `f` through the +projection onto the cokernel. -/ +def cokerDesc {W : S.Mod.{u, u, u, u}} (k : N ⟶ W) + (hk : f ≫ k = 0) : cokerMod f ⟶ W where + evenMap := + Submodule.liftQ _ k.evenMap + (by + refine LinearMap.range_le_ker_iff.2 ?_ + have h : k.evenMap.comp f.evenMap + = (0 : M.even →ₗ[ℂ] W.even) := + congrArg (fun t : M ⟶ W => t.evenMap) hk + exact h) + oddMap := + Submodule.liftQ _ k.oddMap + (by + refine LinearMap.range_le_ker_iff.2 ?_ + have h : k.oddMap.comp f.oddMap + = (0 : M.odd →ₗ[ℂ] W.odd) := + congrArg (fun t : M ⟶ W => t.oddMap) hk + exact h) + map_actEE x z := by + obtain ⟨n, rfl⟩ := Submodule.Quotient.mk_surjective _ z + exact k.map_actEE x n + map_actEO x z := by + obtain ⟨n, rfl⟩ := Submodule.Quotient.mk_surjective _ z + exact k.map_actEO x n + map_actOE v z := by + obtain ⟨n, rfl⟩ := Submodule.Quotient.mk_surjective _ z + exact k.map_actOE v n + map_actOO v z := by + obtain ⟨n, rfl⟩ := Submodule.Quotient.mk_surjective _ z + exact k.map_actOO v n + +theorem cokerProj_desc {W : S.Mod.{u, u, u, u}} (k : N ⟶ W) + (hk : f ≫ k = 0) : cokerProj f ≫ cokerDesc f k hk = k := + Hom.ext (LinearMap.ext fun _ => rfl) (LinearMap.ext fun _ => rfl) + +/-- The cokernel cofork of a morphism of super modules. -/ +def cokernelCofork : CokernelCofork f := + CokernelCofork.ofπ (cokerProj f) (comp_cokerProj f) + +/-- **The cokernel cofork is colimiting.** -/ +def cokernelCoforkIsColimit : IsColimit (cokernelCofork f) := + have : Epi (cokerProj f) := epi_cokerProj f + CokernelCofork.IsColimit.ofπ' (cokerProj f) (comp_cokerProj f) + fun k hk => ⟨cokerDesc f k hk, cokerProj_desc f k hk⟩ + +/-- **Super modules have cokernels**, computed degreewise. -/ +instance instHasCokernels : HasCokernels S.Mod.{u, u, u, u} where + has_colimit f := HasColimit.mk + { cocone := cokernelCofork f + isColimit := cokernelCoforkIsColimit f } + +end Cokernels + +/-! ## The degreewise bridges -/ + +section Bridges + +variable {M N : S.Mod.{u, u, u, u}} + +/-- **A morphism of super modules is a monomorphism exactly when +both of its components are injective.** -/ +theorem mono_iff (f : M ⟶ N) : Mono f ↔ + Function.Injective f.evenMap ∧ Function.Injective f.oddMap := by + refine ⟨fun hf => ?_, fun h => mono_of_injective f h.1 h.2⟩ + have h0 : kerIncl f = 0 := by + refine (cancel_mono f).1 ?_ + rw [kerIncl_comp, Limits.zero_comp] + constructor + · refine LinearMap.ker_eq_bot.1 (Submodule.eq_bot_iff _ |>.2 ?_) + intro m hm + exact congrArg + (fun t : kerMod f ⟶ M => t.evenMap ⟨m, hm⟩) h0 + · refine LinearMap.ker_eq_bot.1 (Submodule.eq_bot_iff _ |>.2 ?_) + intro m hm + exact congrArg + (fun t : kerMod f ⟶ M => t.oddMap ⟨m, hm⟩) h0 + +/-- **A morphism of super modules is an epimorphism exactly when +both of its components are surjective.** -/ +theorem epi_iff (f : M ⟶ N) : Epi f ↔ + Function.Surjective f.evenMap ∧ Function.Surjective f.oddMap := by + refine ⟨fun hf => ?_, fun h => epi_of_surjective f h.1 h.2⟩ + have h0 : cokerProj f = 0 := by + refine (cancel_epi f).1 ?_ + rw [comp_cokerProj, Limits.comp_zero] + constructor + · refine LinearMap.range_eq_top.1 (Submodule.eq_top_iff'.2 ?_) + intro n + have h : (Submodule.Quotient.mk n : + N.even ⧸ LinearMap.range f.evenMap) = 0 := + congrArg (fun t : N ⟶ cokerMod f => t.evenMap n) h0 + exact (Submodule.Quotient.mk_eq_zero _).1 h + · refine LinearMap.range_eq_top.1 (Submodule.eq_top_iff'.2 ?_) + intro n + have h : (Submodule.Quotient.mk n : + N.odd ⧸ LinearMap.range f.oddMap) = 0 := + congrArg (fun t : N ⟶ cokerMod f => t.oddMap n) h0 + exact (Submodule.Quotient.mk_eq_zero _).1 h + +end Bridges + +/-! ## Normality -/ + +section Normal + +variable {M N : S.Mod.{u, u, u, u}} (f : M ⟶ N) + +/-- The degreewise factorisation of a morphism annihilated by the +projection onto the cokernel of a degreewise injective `f`. -/ +noncomputable def monoLift {W : S.Mod.{u, u, u, u}} + (he : Function.Injective f.evenMap) + (ho : Function.Injective f.oddMap) (k : W ⟶ N) + (hme : ∀ w, k.evenMap w ∈ LinearMap.range f.evenMap) + (hmo : ∀ w, k.oddMap w ∈ LinearMap.range f.oddMap) : + W ⟶ M where + evenMap := preimageMap k.evenMap f.evenMap he hme + oddMap := preimageMap k.oddMap f.oddMap ho hmo + map_actEE x m := by + refine he ?_ + rw [preimageMap_spec, f.map_actEE, preimageMap_spec, + k.map_actEE] + map_actEO x m := by + refine ho ?_ + rw [preimageMap_spec, f.map_actEO, preimageMap_spec, + k.map_actEO] + map_actOE v m := by + refine ho ?_ + rw [preimageMap_spec, f.map_actOE, preimageMap_spec, + k.map_actOE] + map_actOO v m := by + refine he ?_ + rw [preimageMap_spec, f.map_actOO, preimageMap_spec, + k.map_actOO] + +theorem monoLift_comp {W : S.Mod.{u, u, u, u}} + (he : Function.Injective f.evenMap) + (ho : Function.Injective f.oddMap) (k : W ⟶ N) + (hme : ∀ w, k.evenMap w ∈ LinearMap.range f.evenMap) + (hmo : ∀ w, k.oddMap w ∈ LinearMap.range f.oddMap) : + monoLift f he ho k hme hmo ≫ f = k := + Hom.ext + (LinearMap.ext fun w => + preimageMap_spec k.evenMap f.evenMap he hme w) + (LinearMap.ext fun w => + preimageMap_spec k.oddMap f.oddMap ho hmo w) + +theorem evenMap_mem_range {W : S.Mod.{u, u, u, u}} (k : W ⟶ N) + (hk : k ≫ cokerProj f = 0) (w : W.even) : + k.evenMap w ∈ LinearMap.range f.evenMap := by + have h : (Submodule.Quotient.mk (k.evenMap w) : + N.even ⧸ LinearMap.range f.evenMap) = 0 := + congrArg (fun t : W ⟶ cokerMod f => t.evenMap w) hk + exact (Submodule.Quotient.mk_eq_zero _).1 h + +theorem oddMap_mem_range {W : S.Mod.{u, u, u, u}} (k : W ⟶ N) + (hk : k ≫ cokerProj f = 0) (w : W.odd) : + k.oddMap w ∈ LinearMap.range f.oddMap := by + have h : (Submodule.Quotient.mk (k.oddMap w) : + N.odd ⧸ LinearMap.range f.oddMap) = 0 := + congrArg (fun t : W ⟶ cokerMod f => t.oddMap w) hk + exact (Submodule.Quotient.mk_eq_zero _).1 h + +/-- **A degreewise injective morphism of super modules is the +kernel of its cokernel.** -/ +@[implicit_reducible] +noncomputable def normalMonoOfInjective (he : Function.Injective f.evenMap) + (ho : Function.Injective f.oddMap) : NormalMono f where + Z := cokerMod f + g := cokerProj f + w := comp_cokerProj f + isLimit := + have : Mono f := mono_of_injective f he ho + KernelFork.IsLimit.ofι' f (comp_cokerProj f) + fun k hk => + ⟨monoLift f he ho k (evenMap_mem_range f k hk) + (oddMap_mem_range f k hk), + monoLift_comp f he ho k _ _⟩ + +/-- The degreewise factorisation of a morphism annihilating the +inclusion of the kernel of a degreewise surjective `f`. -/ +noncomputable def epiDesc {W : S.Mod.{u, u, u, u}} + (he : Function.Surjective f.evenMap) + (ho : Function.Surjective f.oddMap) (k : M ⟶ W) + (hke : ∀ m, f.evenMap m = 0 → k.evenMap m = 0) + (hko : ∀ m, f.oddMap m = 0 → k.oddMap m = 0) : + N ⟶ W where + evenMap := quotientMap k.evenMap f.evenMap he hke + oddMap := quotientMap k.oddMap f.oddMap ho hko + map_actEE x n := by + obtain ⟨m, rfl⟩ := he n + rw [← f.map_actEE, quotientMap_spec, quotientMap_spec, + k.map_actEE] + map_actEO x n := by + obtain ⟨m, rfl⟩ := ho n + rw [← f.map_actEO, quotientMap_spec, quotientMap_spec, + k.map_actEO] + map_actOE v n := by + obtain ⟨m, rfl⟩ := he n + rw [← f.map_actOE, quotientMap_spec, quotientMap_spec, + k.map_actOE] + map_actOO v n := by + obtain ⟨m, rfl⟩ := ho n + rw [← f.map_actOO, quotientMap_spec, quotientMap_spec, + k.map_actOO] + +theorem comp_epiDesc {W : S.Mod.{u, u, u, u}} + (he : Function.Surjective f.evenMap) + (ho : Function.Surjective f.oddMap) (k : M ⟶ W) + (hke : ∀ m, f.evenMap m = 0 → k.evenMap m = 0) + (hko : ∀ m, f.oddMap m = 0 → k.oddMap m = 0) : + f ≫ epiDesc f he ho k hke hko = k := + Hom.ext + (LinearMap.ext fun m => + quotientMap_spec k.evenMap f.evenMap he hke m) + (LinearMap.ext fun m => + quotientMap_spec k.oddMap f.oddMap ho hko m) + +theorem evenMap_eq_zero_of_comp {W : S.Mod.{u, u, u, u}} + (k : M ⟶ W) (hk : kerIncl f ≫ k = 0) (m : M.even) + (hm : f.evenMap m = 0) : k.evenMap m = 0 := + congrArg + (fun t : kerMod f ⟶ W => + t.evenMap ⟨m, LinearMap.mem_ker.2 hm⟩) hk + +theorem oddMap_eq_zero_of_comp {W : S.Mod.{u, u, u, u}} + (k : M ⟶ W) (hk : kerIncl f ≫ k = 0) (m : M.odd) + (hm : f.oddMap m = 0) : k.oddMap m = 0 := + congrArg + (fun t : kerMod f ⟶ W => + t.oddMap ⟨m, LinearMap.mem_ker.2 hm⟩) hk + +/-- **A degreewise surjective morphism of super modules is the +cokernel of its kernel.** -/ +@[implicit_reducible] +noncomputable def normalEpiOfSurjective (he : Function.Surjective f.evenMap) + (ho : Function.Surjective f.oddMap) : NormalEpi f where + W := kerMod f + g := kerIncl f + w := kerIncl_comp f + isColimit := + have : Epi f := epi_of_surjective f he ho + CokernelCofork.IsColimit.ofπ' f (kerIncl_comp f) + fun k hk => + ⟨epiDesc f he ho k (evenMap_eq_zero_of_comp f k hk) + (oddMap_eq_zero_of_comp f k hk), + comp_epiDesc f he ho k _ _⟩ + +end Normal + +/-! ## Abelianness -/ + +/-- **Every monomorphism of super modules is a kernel.** -/ +instance instIsNormalMonoCategory : + IsNormalMonoCategory S.Mod.{u, u, u, u} where + normalMonoOfMono f hf := + ⟨normalMonoOfInjective f ((mono_iff f).1 hf).1 + ((mono_iff f).1 hf).2⟩ + +/-- **Every epimorphism of super modules is a cokernel.** -/ +instance instIsNormalEpiCategory : + IsNormalEpiCategory S.Mod.{u, u, u, u} where + normalEpiOfEpi f hf := + ⟨normalEpiOfSurjective f ((epi_iff f).1 hf).1 + ((epi_iff f).1 hf).2⟩ + +/-- Super modules have finite products: they have a zero object and +binary biproducts. -/ +instance instHasFiniteProducts : + HasFiniteProducts S.Mod.{u, u, u, u} := + hasFiniteProducts_of_has_binary_and_terminal + +/-- **Modules over a super-commutative ℂ-algebra form an abelian +category**, with kernels, cokernels and biproducts all computed +degreewise. -/ +noncomputable instance instAbelian : Abelian S.Mod.{u, u, u, u} where + normalMonoOfMono f hf := + ⟨normalMonoOfInjective f ((mono_iff f).1 hf).1 + ((mono_iff f).1 hf).2⟩ + normalEpiOfEpi f hf := + ⟨normalEpiOfSurjective f ((epi_iff f).1 hf).1 + ((epi_iff f).1 hf).2⟩ + +end SuperCommAlgebra.Mod + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModBiprod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModBiprod.lean new file mode 100644 index 0000000000..8b2f4fd4ad --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModBiprod.lean @@ -0,0 +1,264 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom + +/-! +# Biproducts of super modules + +Super modules over a fixed super-commutative ℂ-algebra carry a zero +object and binary biproducts, and both are computed componentwise: +the zero module is trivial in each degree, and the biproduct of two +super modules is the product of the even components together with +the product of the odd components, acted on blockwise. + +Nothing here needs the graded axioms in any essential way. Each of +the ten axioms of `RS.SuperCommAlgebra.Mod` is a pointwise identity, +so it holds in a product as soon as it holds in each factor, and the +four structure morphisms are the four ℂ-linear structure maps of a +product of modules taken in each degree at once. + +Since the category is preadditive, the bicone assembled from those +four morphisms is a bilimit as soon as it satisfies the total +identity `fst ≫ inl + snd ≫ inr = 𝟙`, which in each degree is the +componentwise statement `(p.1, 0) + (0, p.2) = p`. Finite +biproducts then follow formally from the zero object and the binary +ones. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Limits + +universe u u' w w' + +namespace SuperCommAlgebra.Mod + +variable {S : SuperCommAlgebra.{u, u'}} + +/-! ## Componentwise action blocks -/ + +section Componentwise + +variable {A E₁ E₂ F₁ F₂ : Type*} + +/-- **The componentwise action block**: a pair of bilinear action +blocks acting on the two factors of a product separately. The four +action blocks of a biproduct of super modules are the four instances +of this construction. -/ +def prodAct [AddCommGroup A] [Module ℂ A] [AddCommGroup E₁] [Module ℂ E₁] + [AddCommGroup E₂] [Module ℂ E₂] [AddCommGroup F₁] [Module ℂ F₁] + [AddCommGroup F₂] [Module ℂ F₂] + (f : A →ₗ[ℂ] E₁ →ₗ[ℂ] F₁) (g : A →ₗ[ℂ] E₂ →ₗ[ℂ] F₂) : + A →ₗ[ℂ] (E₁ × E₂) →ₗ[ℂ] F₁ × F₂ := + LinearMap.mk₂ ℂ (fun a p => (f a p.1, g a p.2)) + (fun _ _ _ => by simp) (fun _ _ _ => by simp) + (fun _ _ _ => by simp) (fun _ _ _ => by simp) + +@[simp] +theorem prodAct_apply + [AddCommGroup A] [Module ℂ A] [AddCommGroup E₁] [Module ℂ E₁] + [AddCommGroup E₂] [Module ℂ E₂] [AddCommGroup F₁] [Module ℂ F₁] + [AddCommGroup F₂] [Module ℂ F₂] + (f : A →ₗ[ℂ] E₁ →ₗ[ℂ] F₁) + (g : A →ₗ[ℂ] E₂ →ₗ[ℂ] F₂) (a : A) (p : E₁ × E₂) : + prodAct f g a p = (f a p.1, g a p.2) := rfl + +/-- The total identity for a product of ℂ-modules, in the form in +which each degree of the biproduct of super modules needs it. -/ +theorem inl_fst_add_inr_snd + [AddCommGroup E₁] [Module ℂ E₁] [AddCommGroup E₂] [Module ℂ E₂] + (p : E₁ × E₂) : + LinearMap.inl ℂ E₁ E₂ (LinearMap.fst ℂ E₁ E₂ p) + + LinearMap.inr ℂ E₁ E₂ (LinearMap.snd ℂ E₁ E₂ p) = p := by + simp + +end Componentwise + +/-! ## The zero module -/ + +/-- **The zero super module**: both components trivial, all four +actions zero. -/ +def zeroMod (S : SuperCommAlgebra.{u, u'}) : Mod.{u, u', w, w'} S + where + even := PUnit + odd := PUnit + actEE := 0 + actEO := 0 + actOE := 0 + actOO := 0 + one_act_e _ := rfl + one_act_o _ := rfl + assoc_eee _ _ _ := rfl + assoc_eeo _ _ _ := rfl + assoc_eoe _ _ _ := rfl + assoc_eoo _ _ _ := rfl + assoc_oee _ _ _ := rfl + assoc_oeo _ _ _ := rfl + assoc_ooe _ _ _ := rfl + assoc_ooo _ _ _ := rfl + +/-- The zero super module is a zero object. -/ +theorem isZero_zeroMod (S : SuperCommAlgebra.{u, u'}) : + IsZero (zeroMod.{u, u', w, w'} S) := + (IsZero.iff_id_eq_zero _).2 (Hom.ext rfl rfl) + +/-- **Super modules have a zero object.** -/ +instance hasZeroObject : + HasZeroObject (Mod.{u, u', w, w'} S) := + (isZero_zeroMod S).hasZeroObject + +/-! ## The binary biproduct -/ + +/-- **The biproduct of two super modules**: the product of the even +components, the product of the odd components, and the four action +blocks taken componentwise. -/ +def biprod (M N : Mod.{u, u', w, w'} S) : Mod.{u, u', w, w'} S + where + even := M.even × N.even + odd := M.odd × N.odd + actEE := prodAct M.actEE N.actEE + actEO := prodAct M.actEO N.actEO + actOE := prodAct M.actOE N.actOE + actOO := prodAct M.actOO N.actOO + one_act_e m := Prod.ext (M.one_act_e m.1) (N.one_act_e m.2) + one_act_o m := Prod.ext (M.one_act_o m.1) (N.one_act_o m.2) + assoc_eee x y m := + Prod.ext (M.assoc_eee x y m.1) (N.assoc_eee x y m.2) + assoc_eeo x y m := + Prod.ext (M.assoc_eeo x y m.1) (N.assoc_eeo x y m.2) + assoc_eoe x uu m := + Prod.ext (M.assoc_eoe x uu m.1) (N.assoc_eoe x uu m.2) + assoc_eoo x uu m := + Prod.ext (M.assoc_eoo x uu m.1) (N.assoc_eoo x uu m.2) + assoc_oee uu x m := + Prod.ext (M.assoc_oee uu x m.1) (N.assoc_oee uu x m.2) + assoc_oeo uu x m := + Prod.ext (M.assoc_oeo uu x m.1) (N.assoc_oeo uu x m.2) + assoc_ooe uu v m := + Prod.ext (M.assoc_ooe uu v m.1) (N.assoc_ooe uu v m.2) + assoc_ooo uu v m := + Prod.ext (M.assoc_ooo uu v m.1) (N.assoc_ooo uu v m.2) + +/-! ## The four structure morphisms -/ + +/-- The injection of the first summand into the biproduct. -/ +def biprodInl (M N : S.Mod) : M ⟶ M.biprod N where + evenMap := LinearMap.inl ℂ M.even N.even + oddMap := LinearMap.inl ℂ M.odd N.odd + map_actEE _ _ := Prod.ext rfl (map_zero _).symm + map_actEO _ _ := Prod.ext rfl (map_zero _).symm + map_actOE _ _ := Prod.ext rfl (map_zero _).symm + map_actOO _ _ := Prod.ext rfl (map_zero _).symm + +/-- The injection of the second summand into the biproduct. -/ +def biprodInr (M N : S.Mod) : N ⟶ M.biprod N where + evenMap := LinearMap.inr ℂ M.even N.even + oddMap := LinearMap.inr ℂ M.odd N.odd + map_actEE _ _ := Prod.ext (map_zero _).symm rfl + map_actEO _ _ := Prod.ext (map_zero _).symm rfl + map_actOE _ _ := Prod.ext (map_zero _).symm rfl + map_actOO _ _ := Prod.ext (map_zero _).symm rfl + +/-- The projection of the biproduct onto the first summand. -/ +def biprodFst (M N : S.Mod) : M.biprod N ⟶ M where + evenMap := LinearMap.fst ℂ M.even N.even + oddMap := LinearMap.fst ℂ M.odd N.odd + map_actEE _ _ := rfl + map_actEO _ _ := rfl + map_actOE _ _ := rfl + map_actOO _ _ := rfl + +/-- The projection of the biproduct onto the second summand. -/ +def biprodSnd (M N : S.Mod) : M.biprod N ⟶ N where + evenMap := LinearMap.snd ℂ M.even N.even + oddMap := LinearMap.snd ℂ M.odd N.odd + map_actEE _ _ := rfl + map_actEO _ _ := rfl + map_actOE _ _ := rfl + map_actOO _ _ := rfl + +@[simp] theorem comp_evenMap {M N P : S.Mod} (f : M ⟶ N) + (g : N ⟶ P) : (f ≫ g).evenMap = g.evenMap.comp f.evenMap := rfl + +@[simp] theorem comp_oddMap {M N P : S.Mod} (f : M ⟶ N) + (g : N ⟶ P) : (f ≫ g).oddMap = g.oddMap.comp f.oddMap := rfl + +@[simp] theorem id_evenMap (M : S.Mod) : + Hom.evenMap (𝟙 M) = LinearMap.id := rfl + +@[simp] theorem id_oddMap (M : S.Mod) : + Hom.oddMap (𝟙 M) = LinearMap.id := rfl + +/-! ## The bicone identities -/ + +@[simp] theorem biprodInl_fst (M N : S.Mod) : + biprodInl M N ≫ biprodFst M N = 𝟙 M := + Hom.ext (LinearMap.ext fun _ => rfl) (LinearMap.ext fun _ => rfl) + +@[simp] theorem biprodInl_snd (M N : S.Mod) : + biprodInl M N ≫ biprodSnd M N = 0 := + Hom.ext (LinearMap.ext fun _ => rfl) (LinearMap.ext fun _ => rfl) + +@[simp] theorem biprodInr_fst (M N : S.Mod) : + biprodInr M N ≫ biprodFst M N = 0 := + Hom.ext (LinearMap.ext fun _ => rfl) (LinearMap.ext fun _ => rfl) + +@[simp] theorem biprodInr_snd (M N : S.Mod) : + biprodInr M N ≫ biprodSnd M N = 𝟙 N := + Hom.ext (LinearMap.ext fun _ => rfl) (LinearMap.ext fun _ => rfl) + +/-- **The total identity**: the two projections followed by the two +injections recover the identity of the biproduct. -/ +theorem biprodTotal (M N : S.Mod) : + biprodFst M N ≫ biprodInl M N + + biprodSnd M N ≫ biprodInr M N = 𝟙 (M.biprod N) := + Hom.ext (LinearMap.ext fun p => inl_fst_add_inr_snd p) + (LinearMap.ext fun p => inl_fst_add_inr_snd p) + +/-! ## Binary and finite biproducts -/ + +/-- The binary bicone of two super modules, with vertex their +biproduct. -/ +def biprodBicone (M N : S.Mod) : BinaryBicone M N where + pt := M.biprod N + fst := biprodFst M N + snd := biprodSnd M N + inl := biprodInl M N + inr := biprodInr M N + inl_fst := biprodInl_fst M N + inl_snd := biprodInl_snd M N + inr_fst := biprodInr_fst M N + inr_snd := biprodInr_snd M N + +/-- **The biproduct bicone is a bilimit**: it is simultaneously a +product cone and a coproduct cocone. -/ +def biprodBiconeIsBilimit (M N : S.Mod) : + (biprodBicone M N).IsBilimit := + isBinaryBilimitOfTotal _ (biprodTotal M N) + +/-- **Super modules have binary biproducts.** -/ +instance hasBinaryBiproducts : + HasBinaryBiproducts (Mod.{u, u', w, w'} S) where + has_binary_biproduct M N := + HasBinaryBiproduct.mk + { bicone := biprodBicone M N + isBilimit := biprodBiconeIsBilimit M N } + +/-- **Super modules have finite biproducts.** -/ +instance hasFiniteBiproducts : + HasFiniteBiproducts (Mod.{u, u', w, w'} S) := + have : HasFiniteProducts (Mod.{u, u', w, w'} S) := + hasFiniteProducts_of_has_binary_and_terminal + HasFiniteBiproducts.of_hasFiniteProducts + +end SuperCommAlgebra.Mod + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModBiprodMap.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModBiprodMap.lean new file mode 100644 index 0000000000..9d1e745af2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModBiprodMap.lean @@ -0,0 +1,72 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModIso + +/-! +# Functoriality of the biproduct of super modules + +A pair of morphisms of super modules induces one on the +biproducts, componentwise; a pair of isomorphisms induces an +isomorphism. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +universe u u' + +namespace SuperCommAlgebra.Mod + +variable {S : SuperCommAlgebra.{u, u'}} + +/-- **The biproduct of two morphisms of super modules.** -/ +def biprodMap {M M' N N' : S.Mod} (f : M ⟶ M') (g : N ⟶ N') : + M.biprod N ⟶ M'.biprod N' where + evenMap := LinearMap.prodMap f.evenMap g.evenMap + oddMap := LinearMap.prodMap f.oddMap g.oddMap + map_actEE _ _ := Prod.ext (f.map_actEE _ _) (g.map_actEE _ _) + map_actEO _ _ := Prod.ext (f.map_actEO _ _) (g.map_actEO _ _) + map_actOE _ _ := Prod.ext (f.map_actOE _ _) (g.map_actOE _ _) + map_actOO _ _ := Prod.ext (f.map_actOO _ _) (g.map_actOO _ _) + +/-- The even component of an isomorphism is bijective. -/ +theorem bijective_evenMap {M N : S.Mod} (e : M ≅ N) : + Function.Bijective e.hom.evenMap := by + refine Function.bijective_iff_has_inverse.mpr + ⟨e.inv.evenMap, ?_, ?_⟩ + · intro m + change (e.hom ≫ e.inv).evenMap m = m + rw [e.hom_inv_id] + rfl + · intro n + change (e.inv ≫ e.hom).evenMap n = n + rw [e.inv_hom_id] + rfl + +/-- The odd component of an isomorphism is bijective. -/ +theorem bijective_oddMap {M N : S.Mod} (e : M ≅ N) : + Function.Bijective e.hom.oddMap := by + refine Function.bijective_iff_has_inverse.mpr + ⟨e.inv.oddMap, ?_, ?_⟩ + · intro m + change (e.hom ≫ e.inv).oddMap m = m + rw [e.hom_inv_id] + rfl + · intro n + change (e.inv ≫ e.hom).oddMap n = n + rw [e.inv_hom_id] + rfl + +end SuperCommAlgebra.Mod + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModHom.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModHom.lean new file mode 100644 index 0000000000..717ec73aea --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModHom.lean @@ -0,0 +1,244 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModule + +/-! +# Morphisms of super modules + +A morphism of super modules over a super-commutative algebra is a +pair of ℂ-linear maps, one in each degree, commuting with the +four action blocks. Postcomposition with a morphism of module +objects realizes one. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe u u' + +/-- **A morphism of super modules**: a degreewise ℂ-linear map +commuting with all four actions. -/ +@[ext] +structure SuperCommAlgebra.Mod.Hom {S : SuperCommAlgebra} + (M N : S.Mod) where + /-- The even component. -/ + evenMap : M.even →ₗ[ℂ] N.even + /-- The odd component. -/ + oddMap : M.odd →ₗ[ℂ] N.odd + /-- Compatibility with the even-on-even action. -/ + map_actEE : ∀ x m, evenMap (M.actEE x m) = N.actEE x (evenMap m) + /-- Compatibility with the even-on-odd action. -/ + map_actEO : ∀ x m, oddMap (M.actEO x m) = N.actEO x (oddMap m) + /-- Compatibility with the odd-on-even action. -/ + map_actOE : ∀ u m, oddMap (M.actOE u m) = N.actOE u (evenMap m) + /-- Compatibility with the odd-on-odd action. -/ + map_actOO : ∀ u m, evenMap (M.actOO u m) = N.actOO u (oddMap m) + +namespace SuperCommAlgebra.Mod + +variable {S : SuperCommAlgebra} + +/-- The identity morphism of super modules. -/ +def Hom.id (M : S.Mod) : Hom M M where + evenMap := LinearMap.id + oddMap := LinearMap.id + map_actEE _ _ := rfl + map_actEO _ _ := rfl + map_actOE _ _ := rfl + map_actOO _ _ := rfl + +/-- Composition of morphisms of super modules. -/ +def Hom.comp {M N P : S.Mod} (f : Hom M N) (g : Hom N P) : + Hom M P where + evenMap := g.evenMap.comp f.evenMap + oddMap := g.oddMap.comp f.oddMap + map_actEE x m := by + change g.evenMap (f.evenMap _) = _ + rw [f.map_actEE, g.map_actEE] + rfl + map_actEO x m := by + change g.oddMap (f.oddMap _) = _ + rw [f.map_actEO, g.map_actEO] + rfl + map_actOE u m := by + change g.oddMap (f.oddMap _) = _ + rw [f.map_actOE, g.map_actOE] + rfl + map_actOO u m := by + change g.evenMap (f.evenMap _) = _ + rw [f.map_actOO, g.map_actOO] + rfl + +/-- Super modules over a fixed algebra form a category. -/ +instance instCategory : Category S.Mod where + Hom := Hom + id := Hom.id + comp f g := Hom.comp f g + id_comp _ := rfl + comp_id _ := rfl + assoc _ _ _ := rfl + +/-- The zero morphism of super modules. -/ +instance homZero (M N : S.Mod) : Zero (M ⟶ N) := + ⟨{ evenMap := 0 + oddMap := 0 + map_actEE := fun _ _ => by simp + map_actEO := fun _ _ => by simp + map_actOE := fun _ _ => by simp + map_actOO := fun _ _ => by simp }⟩ + +/-- Addition of morphisms of super modules. -/ +instance homAdd (M N : S.Mod) : Add (M ⟶ N) := + ⟨fun f g => + { evenMap := f.evenMap + g.evenMap + oddMap := f.oddMap + g.oddMap + map_actEE := fun x m => by + simp only [LinearMap.add_apply, map_add] + rw [f.map_actEE, g.map_actEE] + map_actEO := fun x m => by + simp only [LinearMap.add_apply, map_add] + rw [f.map_actEO, g.map_actEO] + map_actOE := fun u m => by + simp only [LinearMap.add_apply, map_add] + rw [f.map_actOE, g.map_actOE] + map_actOO := fun u m => by + simp only [LinearMap.add_apply, map_add] + rw [f.map_actOO, g.map_actOO] }⟩ + +/-- Negation of morphisms of super modules. -/ +instance homNeg (M N : S.Mod) : Neg (M ⟶ N) := + ⟨fun f => + { evenMap := -f.evenMap + oddMap := -f.oddMap + map_actEE := fun x m => by + simp only [LinearMap.neg_apply, map_neg] + rw [f.map_actEE] + map_actEO := fun x m => by + simp only [LinearMap.neg_apply, map_neg] + rw [f.map_actEO] + map_actOE := fun u m => by + simp only [LinearMap.neg_apply, map_neg] + rw [f.map_actOE] + map_actOO := fun u m => by + simp only [LinearMap.neg_apply, map_neg] + rw [f.map_actOO] }⟩ + +/-- Scaling of morphisms of super modules. -/ +instance homSMul (M N : S.Mod) : SMul ℂ (M ⟶ N) := + ⟨fun c f => + { evenMap := c • f.evenMap + oddMap := c • f.oddMap + map_actEE := fun x m => by + simp only [LinearMap.smul_apply, map_smul] + rw [f.map_actEE] + map_actEO := fun x m => by + simp only [LinearMap.smul_apply, map_smul] + rw [f.map_actEO] + map_actOE := fun u m => by + simp only [LinearMap.smul_apply, map_smul] + rw [f.map_actOE] + map_actOO := fun u m => by + simp only [LinearMap.smul_apply, map_smul] + rw [f.map_actOO] }⟩ + +@[simp] theorem add_evenMap {M N : S.Mod} (f g : M ⟶ N) : + (f + g).evenMap = f.evenMap + g.evenMap := rfl + +@[simp] theorem add_oddMap {M N : S.Mod} (f g : M ⟶ N) : + (f + g).oddMap = f.oddMap + g.oddMap := rfl + +@[simp] theorem zero_evenMap {M N : S.Mod} : + (0 : M ⟶ N).evenMap = 0 := rfl + +@[simp] theorem zero_oddMap {M N : S.Mod} : + (0 : M ⟶ N).oddMap = 0 := rfl + +@[simp] theorem neg_evenMap {M N : S.Mod} (f : M ⟶ N) : + (-f).evenMap = -f.evenMap := rfl + +@[simp] theorem neg_oddMap {M N : S.Mod} (f : M ⟶ N) : + (-f).oddMap = -f.oddMap := rfl + +@[simp] theorem smul_evenMap {M N : S.Mod} (c : ℂ) (f : M ⟶ N) : + (c • f).evenMap = c • f.evenMap := rfl + +@[simp] theorem smul_oddMap {M N : S.Mod} (c : ℂ) (f : M ⟶ N) : + (c • f).oddMap = c • f.oddMap := rfl + +/-- Morphisms of super modules form an additive group. -/ +instance homAddCommGroup (M N : S.Mod) : AddCommGroup (M ⟶ N) where + add_assoc f g h := Hom.ext (add_assoc _ _ _) (add_assoc _ _ _) + zero_add f := Hom.ext (zero_add _) (zero_add _) + add_zero f := Hom.ext (add_zero _) (add_zero _) + add_comm f g := Hom.ext (add_comm _ _) (add_comm _ _) + neg_add_cancel f := + Hom.ext (neg_add_cancel _) (neg_add_cancel _) + nsmul := nsmulRec + zsmul := zsmulRec + +/-- Super modules form a preadditive category. -/ +instance instPreadditive : Preadditive S.Mod where + add_comp _ _ _ f f' g := by + refine Hom.ext (LinearMap.ext fun x => ?_) + (LinearMap.ext fun x => ?_) + · change g.evenMap (f.evenMap x + f'.evenMap x) = _ + exact map_add _ _ _ + · change g.oddMap (f.oddMap x + f'.oddMap x) = _ + exact map_add _ _ _ + comp_add _ _ _ f g g' := Hom.ext rfl rfl + +end SuperCommAlgebra.Mod + +section Realize + +universe v + +variable {D : Type u} + +/-- The convolution action is natural in the module object. -/ +theorem gact_naturality [Category.{v} D] [MonoidalCategory D] (R : D) [MonObj R] + {M N : D} [ModObj R M] [ModObj R N] + (f : M ⟶ N) [IsModHom R f] {X Y : D} (a : X ⟶ R) + (m : Y ⟶ M) : + gact (R := R) a m ≫ f = gact (R := R) a (m ≫ f) := by + have hf : actLeft R M ≫ f = (R ◁ f) ≫ actLeft R N := + IsModHom.smul_hom + rw [gact_def, gact_def, Category.assoc, hf, ← Category.assoc, + ← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, Category.comp_id] + +/-- **Postcomposition realizes a morphism of super modules.** -/ +noncomputable def gammaModuleMap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] (L : OddLine D) (R : D) [MonObj R] [IsCommMonObj R] + {M N : D} [ModObj R M] + [ModObj R N] (f : M ⟶ N) [IsModHom R f] : + gammaModule D L R M ⟶ gammaModule D L R N where + evenMap := Linear.rightComp ℂ _ f + oddMap := Linear.rightComp ℂ _ f + map_actEE x m := by + exact (Category.assoc _ _ _).trans + (congrArg _ (gact_naturality R f x m)) + map_actEO x m := by + exact (Category.assoc _ _ _).trans + (congrArg _ (gact_naturality R f x m)) + map_actOE u m := by + exact (Category.assoc _ _ _).trans + (congrArg _ (gact_naturality R f u m)) + map_actOO u m := by + exact (Category.assoc _ _ _).trans + (congrArg _ (gact_naturality R f u m)) + +end Realize + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModIso.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModIso.lean new file mode 100644 index 0000000000..7f588f1fac --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModIso.lean @@ -0,0 +1,79 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom + +/-! +# Recognising isomorphisms of super modules + +A morphism of super modules whose two components are bijective is +an isomorphism: the componentwise inverses are again ℂ-linear and +again commute with the four actions, because the actions on the +source are determined by those on the target. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +universe u u' + +namespace SuperCommAlgebra.Mod + +variable {S : SuperCommAlgebra.{u, u'}} + +/-- **A degreewise bijective morphism of super modules is an +isomorphism.** -/ +noncomputable def isoOfComponents {M N : S.Mod} (f : M ⟶ N) + (he : Function.Bijective f.evenMap) + (ho : Function.Bijective f.oddMap) : M ≅ N where + hom := f + inv := + { evenMap := (LinearEquiv.ofBijective f.evenMap he).symm + oddMap := (LinearEquiv.ofBijective f.oddMap ho).symm + map_actEE := fun x n => by + refine he.1 ?_ + rw [f.map_actEE] + simp + map_actEO := fun x n => by + refine ho.1 ?_ + rw [f.map_actEO] + simp + map_actOE := fun u n => by + refine ho.1 ?_ + rw [f.map_actOE] + simp + map_actOO := fun u n => by + refine he.1 ?_ + rw [f.map_actOO] + simp } + hom_inv_id := by + refine Hom.ext (LinearMap.ext fun m => ?_) + (LinearMap.ext fun m => ?_) + · exact (LinearEquiv.ofBijective f.evenMap he).symm_apply_apply m + · exact (LinearEquiv.ofBijective f.oddMap ho).symm_apply_apply m + inv_hom_id := by + refine Hom.ext (LinearMap.ext fun n => ?_) + (LinearMap.ext fun n => ?_) + · exact (LinearEquiv.ofBijective f.evenMap he).apply_symm_apply n + · exact (LinearEquiv.ofBijective f.oddMap ho).apply_symm_apply n + +/-- **A degreewise bijective morphism of super modules is an +isomorphism**, as an instance-friendly statement. -/ +theorem isIso_of_components {M N : S.Mod} (f : M ⟶ N) + (he : Function.Bijective f.evenMap) + (ho : Function.Bijective f.oddMap) : IsIso f := + ⟨(isoOfComponents f he ho).inv, + (isoOfComponents f he ho).hom_inv_id, + (isoOfComponents f he ho).inv_hom_id⟩ + +end SuperCommAlgebra.Mod + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModMonoidal.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModMonoidal.lean new file mode 100644 index 0000000000..d25c238ecd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModMonoidal.lean @@ -0,0 +1,2445 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModTensor + +/-! +# The symmetric monoidal structure on super modules + +For a super-commutative ℂ-algebra `S` the category `S.Mod` of +modules over it carries a symmetric monoidal structure, built +throughout from the universal property of +`RS.SuperCommAlgebra.Mod.tensor` established in +`RS.Classical.Deligne.SuperModTensor`. + +Every map out of a tensor product is produced by `liftEven` and +`liftOdd`, and every identity between two such maps is proved by +`liftEven_unique` and `liftOdd_unique`, packaged here as the +extensionality principles `hom_ext`, `hom_ext₃` and `hom_ext₄` for +morphisms out of a two-, three- and four-fold tensor product. + +## Contents + +* `RS.bicomp`: the composite `(a, a') ↦ f a ∘ₗ g a'` of two + bilinear maps, used to feed a lift into a lift. +* `RS.SuperCommAlgebra.Mod.mkHom`: a morphism out of a tensor + product from four bilinear maps, eight balancing laws and eight + action laws. +* `RS.SuperCommAlgebra.Mod.hom_ext`, `hom_ext₃`, `hom_ext₄`: + extensionality for morphisms out of iterated tensor products. +* `RS.SuperCommAlgebra.Mod.tensorHom`, with `tensorHom_id` and + `tensorHom_comp`. +* `RS.SuperCommAlgebra.Mod.unitMod`: the algebra as a module over + itself, the tensor unit. +* `RS.SuperCommAlgebra.Mod.leftUnitor`, `rightUnitor`, + `associator`, `braiding`, with their naturality. +* The pentagon and triangle identities, and the resulting + `MonoidalCategory` and `SymmetricCategory` instances. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe u + +/-! ## Composing bilinear maps -/ + +section Bicomp + +variable {A A' B C D : Type*} + +/-- The composite of two bilinear maps, `(a, a') ↦ f a ∘ₗ g a'`, +again bilinear. This is the shape in which a lift out of a tensor +product is fed into a second lift: the value of the outer lift is +itself a linear map. -/ +noncomputable def bicomp + [AddCommGroup A] [Module ℂ A] [AddCommGroup A'] [Module ℂ A'] + [AddCommGroup B] [Module ℂ B] [AddCommGroup C] [Module ℂ C] + [AddCommGroup D] [Module ℂ D] + (f : A →ₗ[ℂ] B →ₗ[ℂ] C) + (g : A' →ₗ[ℂ] D →ₗ[ℂ] B) : A →ₗ[ℂ] A' →ₗ[ℂ] (D →ₗ[ℂ] C) := + (LinearMap.llcomp ℂ D B C).compl₁₂ f g + +@[simp] +theorem bicomp_apply + [AddCommGroup A] [Module ℂ A] [AddCommGroup A'] [Module ℂ A'] + [AddCommGroup B] [Module ℂ B] [AddCommGroup C] [Module ℂ C] + [AddCommGroup D] [Module ℂ D] + (f : A →ₗ[ℂ] B →ₗ[ℂ] C) + (g : A' →ₗ[ℂ] D →ₗ[ℂ] B) (a : A) (a' : A') (d : D) : + bicomp f g a a' d = f a (g a' d) := rfl + +/-- The composite of two bilinear maps in which the *first* +argument is the one held back: `(a', d) ↦ (a ↦ f (g a a') d)`. +This is the shape needed when the inner lift is taken in the +second factor of a tensor product. -/ +noncomputable def bicompFlip + [AddCommGroup A] [Module ℂ A] [AddCommGroup A'] [Module ℂ A'] + [AddCommGroup B] [Module ℂ B] [AddCommGroup C] [Module ℂ C] + [AddCommGroup D] [Module ℂ D] + (f : B →ₗ[ℂ] C →ₗ[ℂ] A') + (g : A →ₗ[ℂ] D →ₗ[ℂ] B) : D →ₗ[ℂ] C →ₗ[ℂ] (A →ₗ[ℂ] A') := + (bicomp f.flip g.flip).flip + +@[simp] +theorem bicompFlip_apply + [AddCommGroup A] [Module ℂ A] [AddCommGroup A'] [Module ℂ A'] + [AddCommGroup B] [Module ℂ B] [AddCommGroup C] [Module ℂ C] + [AddCommGroup D] [Module ℂ D] + (f : B →ₗ[ℂ] C →ₗ[ℂ] A') + (g : A →ₗ[ℂ] D →ₗ[ℂ] B) (d : D) (c : C) (a : A) : + bicompFlip f g d c a = f (g a d) c := rfl + +end Bicomp + +namespace SuperCommAlgebra.Mod + +variable {S : SuperCommAlgebra.{u, u}} + +/-! ## Extensionality for maps out of a tensor product -/ + +section Ext + +variable {M N P Q : S.Mod.{u, u, u, u}} + +/-- **Extensionality for a morphism out of a tensor product**: two +morphisms agreeing on all four families of products agree. -/ +theorem hom_ext {f g : M.tensor N ⟶ P} + (hEE : ∀ m n, f.evenMap (tmulEE M N m n) + = g.evenMap (tmulEE M N m n)) + (hOO : ∀ m n, f.evenMap (tmulOO M N m n) + = g.evenMap (tmulOO M N m n)) + (hEO : ∀ m n, f.oddMap (tmulEO M N m n) + = g.oddMap (tmulEO M N m n)) + (hOE : ∀ m n, f.oddMap (tmulOE M N m n) + = g.oddMap (tmulOE M N m n)) : f = g := + Hom.ext (liftEven_unique M N _ _ hEE hOO) + (liftOdd_unique M N _ _ hEO hOE) + +variable {T : Type u} + +/-- **Uniqueness in even degree for a threefold tensor product**: +the even part of `(M ⊗ N) ⊗ P` is generated by the four families +of triple products of even total degree. -/ +theorem liftEven₃_unique [AddCommGroup T] [Module ℂ T] + (g g' : ((M.tensor N).tensor P).even →ₗ[ℂ] T) + (h₁ : ∀ m n p, g (tmulEE (M.tensor N) P (tmulEE M N m n) p) + = g' (tmulEE (M.tensor N) P (tmulEE M N m n) p)) + (h₂ : ∀ m n p, g (tmulEE (M.tensor N) P (tmulOO M N m n) p) + = g' (tmulEE (M.tensor N) P (tmulOO M N m n) p)) + (h₃ : ∀ m n p, g (tmulOO (M.tensor N) P (tmulEO M N m n) p) + = g' (tmulOO (M.tensor N) P (tmulEO M N m n) p)) + (h₄ : ∀ m n p, g (tmulOO (M.tensor N) P (tmulOE M N m n) p) + = g' (tmulOO (M.tensor N) P (tmulOE M N m n) p)) : + g = g' := by + refine liftEven_unique (M.tensor N) P g g' (fun t p => ?_) + (fun t p => ?_) + · exact LinearMap.congr_fun (liftEven_unique M N + (g ∘ₗ (tmulEE (M.tensor N) P).flip p) + (g' ∘ₗ (tmulEE (M.tensor N) P).flip p) + (fun m n => h₁ m n p) (fun m n => h₂ m n p)) t + · exact LinearMap.congr_fun (liftOdd_unique M N + (g ∘ₗ (tmulOO (M.tensor N) P).flip p) + (g' ∘ₗ (tmulOO (M.tensor N) P).flip p) + (fun m n => h₃ m n p) (fun m n => h₄ m n p)) t + +/-- **Uniqueness in odd degree for a threefold tensor product**. -/ +theorem liftOdd₃_unique [AddCommGroup T] [Module ℂ T] + (g g' : ((M.tensor N).tensor P).odd →ₗ[ℂ] T) + (h₁ : ∀ m n p, g (tmulEO (M.tensor N) P (tmulEE M N m n) p) + = g' (tmulEO (M.tensor N) P (tmulEE M N m n) p)) + (h₂ : ∀ m n p, g (tmulEO (M.tensor N) P (tmulOO M N m n) p) + = g' (tmulEO (M.tensor N) P (tmulOO M N m n) p)) + (h₃ : ∀ m n p, g (tmulOE (M.tensor N) P (tmulEO M N m n) p) + = g' (tmulOE (M.tensor N) P (tmulEO M N m n) p)) + (h₄ : ∀ m n p, g (tmulOE (M.tensor N) P (tmulOE M N m n) p) + = g' (tmulOE (M.tensor N) P (tmulOE M N m n) p)) : + g = g' := by + refine liftOdd_unique (M.tensor N) P g g' (fun t p => ?_) + (fun t p => ?_) + · exact LinearMap.congr_fun (liftEven_unique M N + (g ∘ₗ (tmulEO (M.tensor N) P).flip p) + (g' ∘ₗ (tmulEO (M.tensor N) P).flip p) + (fun m n => h₁ m n p) (fun m n => h₂ m n p)) t + · exact LinearMap.congr_fun (liftOdd_unique M N + (g ∘ₗ (tmulOE (M.tensor N) P).flip p) + (g' ∘ₗ (tmulOE (M.tensor N) P).flip p) + (fun m n => h₃ m n p) (fun m n => h₄ m n p)) t + +/-- **Extensionality for a morphism out of a threefold tensor +product**: two morphisms out of `(M ⊗ N) ⊗ P` agreeing on all +eight families of triple products agree. -/ +theorem hom_ext₃ {f g : (M.tensor N).tensor P ⟶ Q} + (h₁ : ∀ m n p, f.evenMap (tmulEE (M.tensor N) P + (tmulEE M N m n) p) + = g.evenMap (tmulEE (M.tensor N) P (tmulEE M N m n) p)) + (h₂ : ∀ m n p, f.evenMap (tmulEE (M.tensor N) P + (tmulOO M N m n) p) + = g.evenMap (tmulEE (M.tensor N) P (tmulOO M N m n) p)) + (h₃ : ∀ m n p, f.evenMap (tmulOO (M.tensor N) P + (tmulEO M N m n) p) + = g.evenMap (tmulOO (M.tensor N) P (tmulEO M N m n) p)) + (h₄ : ∀ m n p, f.evenMap (tmulOO (M.tensor N) P + (tmulOE M N m n) p) + = g.evenMap (tmulOO (M.tensor N) P (tmulOE M N m n) p)) + (h₅ : ∀ m n p, f.oddMap (tmulEO (M.tensor N) P + (tmulEE M N m n) p) + = g.oddMap (tmulEO (M.tensor N) P (tmulEE M N m n) p)) + (h₆ : ∀ m n p, f.oddMap (tmulEO (M.tensor N) P + (tmulOO M N m n) p) + = g.oddMap (tmulEO (M.tensor N) P (tmulOO M N m n) p)) + (h₇ : ∀ m n p, f.oddMap (tmulOE (M.tensor N) P + (tmulEO M N m n) p) + = g.oddMap (tmulOE (M.tensor N) P (tmulEO M N m n) p)) + (h₈ : ∀ m n p, f.oddMap (tmulOE (M.tensor N) P + (tmulOE M N m n) p) + = g.oddMap (tmulOE (M.tensor N) P (tmulOE M N m n) p)) : + f = g := + Hom.ext (liftEven₃_unique _ _ h₁ h₂ h₃ h₄) + (liftOdd₃_unique _ _ h₅ h₆ h₇ h₈) + +/-- **Uniqueness in even degree for a right-nested threefold +tensor product**. -/ +theorem liftEven₃'_unique [AddCommGroup T] [Module ℂ T] + (g g' : (M.tensor (N.tensor P)).even →ₗ[ℂ] T) + (h₁ : ∀ m n p, g (tmulEE M (N.tensor P) m (tmulEE N P n p)) + = g' (tmulEE M (N.tensor P) m (tmulEE N P n p))) + (h₂ : ∀ m n p, g (tmulEE M (N.tensor P) m (tmulOO N P n p)) + = g' (tmulEE M (N.tensor P) m (tmulOO N P n p))) + (h₃ : ∀ m n p, g (tmulOO M (N.tensor P) m (tmulEO N P n p)) + = g' (tmulOO M (N.tensor P) m (tmulEO N P n p))) + (h₄ : ∀ m n p, g (tmulOO M (N.tensor P) m (tmulOE N P n p)) + = g' (tmulOO M (N.tensor P) m (tmulOE N P n p))) : + g = g' := by + refine liftEven_unique M (N.tensor P) g g' (fun m w => ?_) + (fun m w => ?_) + · exact LinearMap.congr_fun (liftEven_unique N P + (g ∘ₗ tmulEE M (N.tensor P) m) + (g' ∘ₗ tmulEE M (N.tensor P) m) + (fun n p => h₁ m n p) (fun n p => h₂ m n p)) w + · exact LinearMap.congr_fun (liftOdd_unique N P + (g ∘ₗ tmulOO M (N.tensor P) m) + (g' ∘ₗ tmulOO M (N.tensor P) m) + (fun n p => h₃ m n p) (fun n p => h₄ m n p)) w + +/-- **Uniqueness in odd degree for a right-nested threefold tensor +product**. -/ +theorem liftOdd₃'_unique [AddCommGroup T] [Module ℂ T] + (g g' : (M.tensor (N.tensor P)).odd →ₗ[ℂ] T) + (h₁ : ∀ m n p, g (tmulEO M (N.tensor P) m (tmulEO N P n p)) + = g' (tmulEO M (N.tensor P) m (tmulEO N P n p))) + (h₂ : ∀ m n p, g (tmulEO M (N.tensor P) m (tmulOE N P n p)) + = g' (tmulEO M (N.tensor P) m (tmulOE N P n p))) + (h₃ : ∀ m n p, g (tmulOE M (N.tensor P) m (tmulEE N P n p)) + = g' (tmulOE M (N.tensor P) m (tmulEE N P n p))) + (h₄ : ∀ m n p, g (tmulOE M (N.tensor P) m (tmulOO N P n p)) + = g' (tmulOE M (N.tensor P) m (tmulOO N P n p))) : + g = g' := by + refine liftOdd_unique M (N.tensor P) g g' (fun m w => ?_) + (fun m w => ?_) + · exact LinearMap.congr_fun (liftOdd_unique N P + (g ∘ₗ tmulEO M (N.tensor P) m) + (g' ∘ₗ tmulEO M (N.tensor P) m) + (fun n p => h₁ m n p) (fun n p => h₂ m n p)) w + · exact LinearMap.congr_fun (liftEven_unique N P + (g ∘ₗ tmulOE M (N.tensor P) m) + (g' ∘ₗ tmulOE M (N.tensor P) m) + (fun n p => h₃ m n p) (fun n p => h₄ m n p)) w + +/-- **Extensionality for a morphism out of a right-nested +threefold tensor product**. -/ +theorem hom_ext₃' {f g : M.tensor (N.tensor P) ⟶ Q} + (h₁ : ∀ m n p, f.evenMap (tmulEE M (N.tensor P) m + (tmulEE N P n p)) + = g.evenMap (tmulEE M (N.tensor P) m (tmulEE N P n p))) + (h₂ : ∀ m n p, f.evenMap (tmulEE M (N.tensor P) m + (tmulOO N P n p)) + = g.evenMap (tmulEE M (N.tensor P) m (tmulOO N P n p))) + (h₃ : ∀ m n p, f.evenMap (tmulOO M (N.tensor P) m + (tmulEO N P n p)) + = g.evenMap (tmulOO M (N.tensor P) m (tmulEO N P n p))) + (h₄ : ∀ m n p, f.evenMap (tmulOO M (N.tensor P) m + (tmulOE N P n p)) + = g.evenMap (tmulOO M (N.tensor P) m (tmulOE N P n p))) + (h₅ : ∀ m n p, f.oddMap (tmulEO M (N.tensor P) m + (tmulEO N P n p)) + = g.oddMap (tmulEO M (N.tensor P) m (tmulEO N P n p))) + (h₆ : ∀ m n p, f.oddMap (tmulEO M (N.tensor P) m + (tmulOE N P n p)) + = g.oddMap (tmulEO M (N.tensor P) m (tmulOE N P n p))) + (h₇ : ∀ m n p, f.oddMap (tmulOE M (N.tensor P) m + (tmulEE N P n p)) + = g.oddMap (tmulOE M (N.tensor P) m (tmulEE N P n p))) + (h₈ : ∀ m n p, f.oddMap (tmulOE M (N.tensor P) m + (tmulOO N P n p)) + = g.oddMap (tmulOE M (N.tensor P) m (tmulOO N P n p))) : + f = g := + Hom.ext (liftEven₃'_unique _ _ h₁ h₂ h₃ h₄) + (liftOdd₃'_unique _ _ h₅ h₆ h₇ h₈) + +/-- **Uniqueness in even degree for a fourfold tensor product**, +left-nested. -/ +theorem liftEven₄_unique [AddCommGroup T] [Module ℂ T] + (g g' : (((M.tensor N).tensor P).tensor Q).even →ₗ[ℂ] T) + (h₁ : ∀ m n p q, g (tmulEE ((M.tensor N).tensor P) Q + (tmulEE (M.tensor N) P (tmulEE M N m n) p) q) + = g' (tmulEE ((M.tensor N).tensor P) Q + (tmulEE (M.tensor N) P (tmulEE M N m n) p) q)) + (h₂ : ∀ m n p q, g (tmulEE ((M.tensor N).tensor P) Q + (tmulEE (M.tensor N) P (tmulOO M N m n) p) q) + = g' (tmulEE ((M.tensor N).tensor P) Q + (tmulEE (M.tensor N) P (tmulOO M N m n) p) q)) + (h₃ : ∀ m n p q, g (tmulEE ((M.tensor N).tensor P) Q + (tmulOO (M.tensor N) P (tmulEO M N m n) p) q) + = g' (tmulEE ((M.tensor N).tensor P) Q + (tmulOO (M.tensor N) P (tmulEO M N m n) p) q)) + (h₄ : ∀ m n p q, g (tmulEE ((M.tensor N).tensor P) Q + (tmulOO (M.tensor N) P (tmulOE M N m n) p) q) + = g' (tmulEE ((M.tensor N).tensor P) Q + (tmulOO (M.tensor N) P (tmulOE M N m n) p) q)) + (h₅ : ∀ m n p q, g (tmulOO ((M.tensor N).tensor P) Q + (tmulEO (M.tensor N) P (tmulEE M N m n) p) q) + = g' (tmulOO ((M.tensor N).tensor P) Q + (tmulEO (M.tensor N) P (tmulEE M N m n) p) q)) + (h₆ : ∀ m n p q, g (tmulOO ((M.tensor N).tensor P) Q + (tmulEO (M.tensor N) P (tmulOO M N m n) p) q) + = g' (tmulOO ((M.tensor N).tensor P) Q + (tmulEO (M.tensor N) P (tmulOO M N m n) p) q)) + (h₇ : ∀ m n p q, g (tmulOO ((M.tensor N).tensor P) Q + (tmulOE (M.tensor N) P (tmulEO M N m n) p) q) + = g' (tmulOO ((M.tensor N).tensor P) Q + (tmulOE (M.tensor N) P (tmulEO M N m n) p) q)) + (h₈ : ∀ m n p q, g (tmulOO ((M.tensor N).tensor P) Q + (tmulOE (M.tensor N) P (tmulOE M N m n) p) q) + = g' (tmulOO ((M.tensor N).tensor P) Q + (tmulOE (M.tensor N) P (tmulOE M N m n) p) q)) : + g = g' := by + refine liftEven_unique ((M.tensor N).tensor P) Q g g' + (fun t q => ?_) (fun t q => ?_) + · exact LinearMap.congr_fun (liftEven₃_unique + (g ∘ₗ (tmulEE ((M.tensor N).tensor P) Q).flip q) + (g' ∘ₗ (tmulEE ((M.tensor N).tensor P) Q).flip q) + (fun m n p => h₁ m n p q) (fun m n p => h₂ m n p q) + (fun m n p => h₃ m n p q) (fun m n p => h₄ m n p q)) t + · exact LinearMap.congr_fun (liftOdd₃_unique + (g ∘ₗ (tmulOO ((M.tensor N).tensor P) Q).flip q) + (g' ∘ₗ (tmulOO ((M.tensor N).tensor P) Q).flip q) + (fun m n p => h₅ m n p q) (fun m n p => h₆ m n p q) + (fun m n p => h₇ m n p q) (fun m n p => h₈ m n p q)) t + +/-- **Uniqueness in odd degree for a fourfold tensor product**, +left-nested. -/ +theorem liftOdd₄_unique [AddCommGroup T] [Module ℂ T] + (g g' : (((M.tensor N).tensor P).tensor Q).odd →ₗ[ℂ] T) + (h₁ : ∀ m n p q, g (tmulEO ((M.tensor N).tensor P) Q + (tmulEE (M.tensor N) P (tmulEE M N m n) p) q) + = g' (tmulEO ((M.tensor N).tensor P) Q + (tmulEE (M.tensor N) P (tmulEE M N m n) p) q)) + (h₂ : ∀ m n p q, g (tmulEO ((M.tensor N).tensor P) Q + (tmulEE (M.tensor N) P (tmulOO M N m n) p) q) + = g' (tmulEO ((M.tensor N).tensor P) Q + (tmulEE (M.tensor N) P (tmulOO M N m n) p) q)) + (h₃ : ∀ m n p q, g (tmulEO ((M.tensor N).tensor P) Q + (tmulOO (M.tensor N) P (tmulEO M N m n) p) q) + = g' (tmulEO ((M.tensor N).tensor P) Q + (tmulOO (M.tensor N) P (tmulEO M N m n) p) q)) + (h₄ : ∀ m n p q, g (tmulEO ((M.tensor N).tensor P) Q + (tmulOO (M.tensor N) P (tmulOE M N m n) p) q) + = g' (tmulEO ((M.tensor N).tensor P) Q + (tmulOO (M.tensor N) P (tmulOE M N m n) p) q)) + (h₅ : ∀ m n p q, g (tmulOE ((M.tensor N).tensor P) Q + (tmulEO (M.tensor N) P (tmulEE M N m n) p) q) + = g' (tmulOE ((M.tensor N).tensor P) Q + (tmulEO (M.tensor N) P (tmulEE M N m n) p) q)) + (h₆ : ∀ m n p q, g (tmulOE ((M.tensor N).tensor P) Q + (tmulEO (M.tensor N) P (tmulOO M N m n) p) q) + = g' (tmulOE ((M.tensor N).tensor P) Q + (tmulEO (M.tensor N) P (tmulOO M N m n) p) q)) + (h₇ : ∀ m n p q, g (tmulOE ((M.tensor N).tensor P) Q + (tmulOE (M.tensor N) P (tmulEO M N m n) p) q) + = g' (tmulOE ((M.tensor N).tensor P) Q + (tmulOE (M.tensor N) P (tmulEO M N m n) p) q)) + (h₈ : ∀ m n p q, g (tmulOE ((M.tensor N).tensor P) Q + (tmulOE (M.tensor N) P (tmulOE M N m n) p) q) + = g' (tmulOE ((M.tensor N).tensor P) Q + (tmulOE (M.tensor N) P (tmulOE M N m n) p) q)) : + g = g' := by + refine liftOdd_unique ((M.tensor N).tensor P) Q g g' + (fun t q => ?_) (fun t q => ?_) + · exact LinearMap.congr_fun (liftEven₃_unique + (g ∘ₗ (tmulEO ((M.tensor N).tensor P) Q).flip q) + (g' ∘ₗ (tmulEO ((M.tensor N).tensor P) Q).flip q) + (fun m n p => h₁ m n p q) (fun m n p => h₂ m n p q) + (fun m n p => h₃ m n p q) (fun m n p => h₄ m n p q)) t + · exact LinearMap.congr_fun (liftOdd₃_unique + (g ∘ₗ (tmulOE ((M.tensor N).tensor P) Q).flip q) + (g' ∘ₗ (tmulOE ((M.tensor N).tensor P) Q).flip q) + (fun m n p => h₅ m n p q) (fun m n p => h₆ m n p q) + (fun m n p => h₇ m n p q) (fun m n p => h₈ m n p q)) t + +/-- **Extensionality for a morphism out of a fourfold tensor +product**: two morphisms out of `((M ⊗ N) ⊗ P) ⊗ Q` agreeing on +all sixteen families of quadruple products agree. -/ +theorem hom_ext₄ {R : S.Mod.{u, u, u, u}} + {f g : ((M.tensor N).tensor P).tensor Q ⟶ R} + (h₁ : ∀ m n p q, f.evenMap (tmulEE ((M.tensor N).tensor P) Q + (tmulEE (M.tensor N) P (tmulEE M N m n) p) q) + = g.evenMap (tmulEE ((M.tensor N).tensor P) Q + (tmulEE (M.tensor N) P (tmulEE M N m n) p) q)) + (h₂ : ∀ m n p q, f.evenMap (tmulEE ((M.tensor N).tensor P) Q + (tmulEE (M.tensor N) P (tmulOO M N m n) p) q) + = g.evenMap (tmulEE ((M.tensor N).tensor P) Q + (tmulEE (M.tensor N) P (tmulOO M N m n) p) q)) + (h₃ : ∀ m n p q, f.evenMap (tmulEE ((M.tensor N).tensor P) Q + (tmulOO (M.tensor N) P (tmulEO M N m n) p) q) + = g.evenMap (tmulEE ((M.tensor N).tensor P) Q + (tmulOO (M.tensor N) P (tmulEO M N m n) p) q)) + (h₄ : ∀ m n p q, f.evenMap (tmulEE ((M.tensor N).tensor P) Q + (tmulOO (M.tensor N) P (tmulOE M N m n) p) q) + = g.evenMap (tmulEE ((M.tensor N).tensor P) Q + (tmulOO (M.tensor N) P (tmulOE M N m n) p) q)) + (h₅ : ∀ m n p q, f.evenMap (tmulOO ((M.tensor N).tensor P) Q + (tmulEO (M.tensor N) P (tmulEE M N m n) p) q) + = g.evenMap (tmulOO ((M.tensor N).tensor P) Q + (tmulEO (M.tensor N) P (tmulEE M N m n) p) q)) + (h₆ : ∀ m n p q, f.evenMap (tmulOO ((M.tensor N).tensor P) Q + (tmulEO (M.tensor N) P (tmulOO M N m n) p) q) + = g.evenMap (tmulOO ((M.tensor N).tensor P) Q + (tmulEO (M.tensor N) P (tmulOO M N m n) p) q)) + (h₇ : ∀ m n p q, f.evenMap (tmulOO ((M.tensor N).tensor P) Q + (tmulOE (M.tensor N) P (tmulEO M N m n) p) q) + = g.evenMap (tmulOO ((M.tensor N).tensor P) Q + (tmulOE (M.tensor N) P (tmulEO M N m n) p) q)) + (h₈ : ∀ m n p q, f.evenMap (tmulOO ((M.tensor N).tensor P) Q + (tmulOE (M.tensor N) P (tmulOE M N m n) p) q) + = g.evenMap (tmulOO ((M.tensor N).tensor P) Q + (tmulOE (M.tensor N) P (tmulOE M N m n) p) q)) + (k₁ : ∀ m n p q, f.oddMap (tmulEO ((M.tensor N).tensor P) Q + (tmulEE (M.tensor N) P (tmulEE M N m n) p) q) + = g.oddMap (tmulEO ((M.tensor N).tensor P) Q + (tmulEE (M.tensor N) P (tmulEE M N m n) p) q)) + (k₂ : ∀ m n p q, f.oddMap (tmulEO ((M.tensor N).tensor P) Q + (tmulEE (M.tensor N) P (tmulOO M N m n) p) q) + = g.oddMap (tmulEO ((M.tensor N).tensor P) Q + (tmulEE (M.tensor N) P (tmulOO M N m n) p) q)) + (k₃ : ∀ m n p q, f.oddMap (tmulEO ((M.tensor N).tensor P) Q + (tmulOO (M.tensor N) P (tmulEO M N m n) p) q) + = g.oddMap (tmulEO ((M.tensor N).tensor P) Q + (tmulOO (M.tensor N) P (tmulEO M N m n) p) q)) + (k₄ : ∀ m n p q, f.oddMap (tmulEO ((M.tensor N).tensor P) Q + (tmulOO (M.tensor N) P (tmulOE M N m n) p) q) + = g.oddMap (tmulEO ((M.tensor N).tensor P) Q + (tmulOO (M.tensor N) P (tmulOE M N m n) p) q)) + (k₅ : ∀ m n p q, f.oddMap (tmulOE ((M.tensor N).tensor P) Q + (tmulEO (M.tensor N) P (tmulEE M N m n) p) q) + = g.oddMap (tmulOE ((M.tensor N).tensor P) Q + (tmulEO (M.tensor N) P (tmulEE M N m n) p) q)) + (k₆ : ∀ m n p q, f.oddMap (tmulOE ((M.tensor N).tensor P) Q + (tmulEO (M.tensor N) P (tmulOO M N m n) p) q) + = g.oddMap (tmulOE ((M.tensor N).tensor P) Q + (tmulEO (M.tensor N) P (tmulOO M N m n) p) q)) + (k₇ : ∀ m n p q, f.oddMap (tmulOE ((M.tensor N).tensor P) Q + (tmulOE (M.tensor N) P (tmulEO M N m n) p) q) + = g.oddMap (tmulOE ((M.tensor N).tensor P) Q + (tmulOE (M.tensor N) P (tmulEO M N m n) p) q)) + (k₈ : ∀ m n p q, f.oddMap (tmulOE ((M.tensor N).tensor P) Q + (tmulOE (M.tensor N) P (tmulOE M N m n) p) q) + = g.oddMap (tmulOE ((M.tensor N).tensor P) Q + (tmulOE (M.tensor N) P (tmulOE M N m n) p) q)) : + f = g := + Hom.ext (liftEven₄_unique _ _ h₁ h₂ h₃ h₄ h₅ h₆ h₇ h₈) + (liftOdd₄_unique _ _ k₁ k₂ k₃ k₄ k₅ k₆ k₇ k₈) + +end Ext + +/-! ## Building a morphism out of a tensor product -/ + +section MkHom + +/-- **The data of a morphism out of a tensor product**: four +degreewise bilinear maps, balanced against the eight relator +families and compatible with the four action blocks. + +The eight balancing laws are exactly the hypotheses of `liftEven` +and `liftOdd`. The eight action laws say that each bilinear map +intertwines the action on the left factor of the source with the +action on the target, one for each pair of a scalar parity and a +block. -/ +structure TensorData (M N Q : S.Mod.{u, u, u, u}) where + /-- The even-even block. -/ + fee : M.even →ₗ[ℂ] N.even →ₗ[ℂ] Q.even + /-- The odd-odd block. -/ + foo : M.odd →ₗ[ℂ] N.odd →ₗ[ℂ] Q.even + /-- The even-odd block. -/ + feo : M.even →ₗ[ℂ] N.odd →ₗ[ℂ] Q.odd + /-- The odd-even block. -/ + foe : M.odd →ₗ[ℂ] N.even →ₗ[ℂ] Q.odd + /-- Balancing at parity pattern even-even-even. -/ + hee : ∀ (b : S.even) (m : M.even) (n : N.even), + fee (M.actEE b m) n = fee m (N.actEE b n) + /-- Balancing at parity pattern even-odd-odd. -/ + hoo : ∀ (b : S.even) (m : M.odd) (n : N.odd), + foo (M.actEO b m) n = foo m (N.actEO b n) + /-- Balancing at parity pattern odd-even-odd. -/ + hoeo : ∀ (c : S.odd) (m : M.even) (n : N.odd), + foo (M.actOE c m) n = fee m (N.actOO c n) + /-- Balancing at parity pattern odd-odd-even. -/ + hooe : ∀ (c : S.odd) (m : M.odd) (n : N.even), + fee (M.actOO c m) n = -foo m (N.actOE c n) + /-- Balancing at parity pattern even-even-odd. -/ + heeo : ∀ (b : S.even) (m : M.even) (n : N.odd), + feo (M.actEE b m) n = feo m (N.actEO b n) + /-- Balancing at parity pattern even-odd-even. -/ + heoe : ∀ (b : S.even) (m : M.odd) (n : N.even), + foe (M.actEO b m) n = foe m (N.actEE b n) + /-- Balancing at parity pattern odd-even-even. -/ + hoee : ∀ (c : S.odd) (m : M.even) (n : N.even), + foe (M.actOE c m) n = feo m (N.actOE c n) + /-- Balancing at parity pattern odd-odd-odd. -/ + hooo : ∀ (c : S.odd) (m : M.odd) (n : N.odd), + feo (M.actOO c m) n = -foe m (N.actOO c n) + /-- An even scalar passes through the even-even block. -/ + aee : ∀ (a : S.even) (m : M.even) (n : N.even), + fee (M.actEE a m) n = Q.actEE a (fee m n) + /-- An even scalar passes through the odd-odd block. -/ + aoo : ∀ (a : S.even) (m : M.odd) (n : N.odd), + foo (M.actEO a m) n = Q.actEE a (foo m n) + /-- An even scalar passes through the even-odd block. -/ + aeo : ∀ (a : S.even) (m : M.even) (n : N.odd), + feo (M.actEE a m) n = Q.actEO a (feo m n) + /-- An even scalar passes through the odd-even block. -/ + aoe : ∀ (a : S.even) (m : M.odd) (n : N.even), + foe (M.actEO a m) n = Q.actEO a (foe m n) + /-- An odd scalar passes through the even-even block. -/ + cee : ∀ (c : S.odd) (m : M.even) (n : N.even), + foe (M.actOE c m) n = Q.actOE c (fee m n) + /-- An odd scalar passes through the odd-odd block. -/ + coo : ∀ (c : S.odd) (m : M.odd) (n : N.odd), + feo (M.actOO c m) n = Q.actOE c (foo m n) + /-- An odd scalar passes through the even-odd block. -/ + ceo : ∀ (c : S.odd) (m : M.even) (n : N.odd), + foo (M.actOE c m) n = Q.actOO c (feo m n) + /-- An odd scalar passes through the odd-even block. -/ + coe : ∀ (c : S.odd) (m : M.odd) (n : N.even), + fee (M.actOO c m) n = Q.actOO c (foe m n) + +variable {M N Q : S.Mod.{u, u, u, u}} (d : TensorData M N Q) + +/-- **A morphism out of a tensor product**: the two lifts of the +four blocks of a `TensorData`, assembled into a morphism of super +modules out of `M ⊗ N`. -/ +noncomputable def mkHom : M.tensor N ⟶ Q where + evenMap := liftEven M N d.fee d.foo d.hee d.hoo d.hoeo d.hooe + oddMap := liftOdd M N d.feo d.foe d.heeo d.heoe d.hoee d.hooo + map_actEE x t := by + refine LinearMap.congr_fun (liftEven_unique M N + (LinearMap.comp + (liftEven M N d.fee d.foo d.hee d.hoo d.hoeo d.hooe) + ((M.tensor N).actEE x)) + (LinearMap.comp (Q.actEE x) + (liftEven M N d.fee d.foo d.hee d.hoo d.hoeo d.hooe)) + (fun m n => ?_) (fun m n => ?_)) t + · simp only [LinearMap.comp_apply, actEE_tmulEE, liftEven_tmulEE] + exact d.aee x m n + · simp only [LinearMap.comp_apply, actEE_tmulOO, liftEven_tmulOO] + exact d.aoo x m n + map_actEO x t := by + refine LinearMap.congr_fun (liftOdd_unique M N + (LinearMap.comp + (liftOdd M N d.feo d.foe d.heeo d.heoe d.hoee d.hooo) + ((M.tensor N).actEO x)) + (LinearMap.comp (Q.actEO x) + (liftOdd M N d.feo d.foe d.heeo d.heoe d.hoee d.hooo)) + (fun m n => ?_) (fun m n => ?_)) t + · simp only [LinearMap.comp_apply, actEO_tmulEO, liftOdd_tmulEO] + exact d.aeo x m n + · simp only [LinearMap.comp_apply, actEO_tmulOE, liftOdd_tmulOE] + exact d.aoe x m n + map_actOE v t := by + refine LinearMap.congr_fun (liftEven_unique M N + (LinearMap.comp + (liftOdd M N d.feo d.foe d.heeo d.heoe d.hoee d.hooo) + ((M.tensor N).actOE v)) + (LinearMap.comp (Q.actOE v) + (liftEven M N d.fee d.foo d.hee d.hoo d.hoeo d.hooe)) + (fun m n => ?_) (fun m n => ?_)) t + · simp only [LinearMap.comp_apply, actOE_tmulEE, liftOdd_tmulOE, + liftEven_tmulEE] + exact d.cee v m n + · simp only [LinearMap.comp_apply, actOE_tmulOO, liftOdd_tmulEO, + liftEven_tmulOO] + exact d.coo v m n + map_actOO v t := by + refine LinearMap.congr_fun (liftOdd_unique M N + (LinearMap.comp + (liftEven M N d.fee d.foo d.hee d.hoo d.hoeo d.hooe) + ((M.tensor N).actOO v)) + (LinearMap.comp (Q.actOO v) + (liftOdd M N d.feo d.foe d.heeo d.heoe d.hoee d.hooo)) + (fun m n => ?_) (fun m n => ?_)) t + · simp only [LinearMap.comp_apply, actOO_tmulEO, liftEven_tmulOO, + liftOdd_tmulEO] + exact d.ceo v m n + · simp only [LinearMap.comp_apply, actOO_tmulOE, liftEven_tmulEE, + liftOdd_tmulOE] + exact d.coe v m n + +@[simp] +theorem mkHom_evenMap_tmulEE (m : M.even) (n : N.even) : + (mkHom d).evenMap (tmulEE M N m n) = d.fee m n := + liftEven_tmulEE M N d.fee d.foo d.hee d.hoo d.hoeo d.hooe m n + +@[simp] +theorem mkHom_evenMap_tmulOO (m : M.odd) (n : N.odd) : + (mkHom d).evenMap (tmulOO M N m n) = d.foo m n := + liftEven_tmulOO M N d.fee d.foo d.hee d.hoo d.hoeo d.hooe m n + +@[simp] +theorem mkHom_oddMap_tmulEO (m : M.even) (n : N.odd) : + (mkHom d).oddMap (tmulEO M N m n) = d.feo m n := + liftOdd_tmulEO M N d.feo d.foe d.heeo d.heoe d.hoee d.hooo m n + +@[simp] +theorem mkHom_oddMap_tmulOE (m : M.odd) (n : N.even) : + (mkHom d).oddMap (tmulOE M N m n) = d.foe m n := + liftOdd_tmulOE M N d.feo d.foe d.heeo d.heoe d.hoee d.hooo m n + +end MkHom + +/-! ## Functoriality of the tensor product -/ + +section TensorHom + +variable {M M' M'' N N' N'' : S.Mod.{u, u, u, u}} + +/-- The data of the tensor product of two morphisms. -/ +noncomputable def tensorHomData (f : M ⟶ M') (g : N ⟶ N') : + TensorData M N (M'.tensor N') where + fee := (tmulEE M' N').compl₁₂ f.evenMap g.evenMap + foo := (tmulOO M' N').compl₁₂ f.oddMap g.oddMap + feo := (tmulEO M' N').compl₁₂ f.evenMap g.oddMap + foe := (tmulOE M' N').compl₁₂ f.oddMap g.evenMap + hee := fun b m n => by + simp only [LinearMap.compl₁₂_apply] + rw [f.map_actEE, g.map_actEE] + exact tmulEE_balanced_eee M' N' b _ _ + hoo := fun b m n => by + simp only [LinearMap.compl₁₂_apply] + rw [f.map_actEO, g.map_actEO] + exact tmulOO_balanced_eoo M' N' b _ _ + hoeo := fun c m n => by + simp only [LinearMap.compl₁₂_apply] + rw [f.map_actOE, g.map_actOO] + exact tmulOO_balanced_oeo M' N' c _ _ + hooe := fun c m n => by + simp only [LinearMap.compl₁₂_apply] + rw [f.map_actOO, g.map_actOE] + exact tmulEE_balanced_ooe M' N' c _ _ + heeo := fun b m n => by + simp only [LinearMap.compl₁₂_apply] + rw [f.map_actEE, g.map_actEO] + exact tmulEO_balanced_eeo M' N' b _ _ + heoe := fun b m n => by + simp only [LinearMap.compl₁₂_apply] + rw [f.map_actEO, g.map_actEE] + exact tmulOE_balanced_eoe M' N' b _ _ + hoee := fun c m n => by + simp only [LinearMap.compl₁₂_apply] + rw [f.map_actOE, g.map_actOE] + exact tmulOE_balanced_oee M' N' c _ _ + hooo := fun c m n => by + simp only [LinearMap.compl₁₂_apply] + rw [f.map_actOO, g.map_actOO] + exact tmulEO_balanced_ooo M' N' c _ _ + aee := fun a m n => by + simp only [LinearMap.compl₁₂_apply] + rw [f.map_actEE] + exact (actEE_tmulEE M' N' a _ _).symm + aoo := fun a m n => by + simp only [LinearMap.compl₁₂_apply] + rw [f.map_actEO] + exact (actEE_tmulOO M' N' a _ _).symm + aeo := fun a m n => by + simp only [LinearMap.compl₁₂_apply] + rw [f.map_actEE] + exact (actEO_tmulEO M' N' a _ _).symm + aoe := fun a m n => by + simp only [LinearMap.compl₁₂_apply] + rw [f.map_actEO] + exact (actEO_tmulOE M' N' a _ _).symm + cee := fun c m n => by + simp only [LinearMap.compl₁₂_apply] + rw [f.map_actOE] + exact (actOE_tmulEE M' N' c _ _).symm + coo := fun c m n => by + simp only [LinearMap.compl₁₂_apply] + rw [f.map_actOO] + exact (actOE_tmulOO M' N' c _ _).symm + ceo := fun c m n => by + simp only [LinearMap.compl₁₂_apply] + rw [f.map_actOE] + exact (actOO_tmulEO M' N' c _ _).symm + coe := fun c m n => by + simp only [LinearMap.compl₁₂_apply] + rw [f.map_actOO] + exact (actOO_tmulOE M' N' c _ _).symm + +/-- **The tensor product of two morphisms**: apply each morphism +in its own factor, degreewise. -/ +noncomputable def tensorHom (f : M ⟶ M') (g : N ⟶ N') : + M.tensor N ⟶ M'.tensor N' := + mkHom (tensorHomData f g) + +@[simp] +theorem tensorHom_evenMap_tmulEE (f : M ⟶ M') (g : N ⟶ N') + (m : M.even) (n : N.even) : + (tensorHom f g).evenMap (tmulEE M N m n) + = tmulEE M' N' (f.evenMap m) (g.evenMap n) := + mkHom_evenMap_tmulEE (tensorHomData f g) m n + +@[simp] +theorem tensorHom_evenMap_tmulOO (f : M ⟶ M') (g : N ⟶ N') + (m : M.odd) (n : N.odd) : + (tensorHom f g).evenMap (tmulOO M N m n) + = tmulOO M' N' (f.oddMap m) (g.oddMap n) := + mkHom_evenMap_tmulOO (tensorHomData f g) m n + +@[simp] +theorem tensorHom_oddMap_tmulEO (f : M ⟶ M') (g : N ⟶ N') + (m : M.even) (n : N.odd) : + (tensorHom f g).oddMap (tmulEO M N m n) + = tmulEO M' N' (f.evenMap m) (g.oddMap n) := + mkHom_oddMap_tmulEO (tensorHomData f g) m n + +@[simp] +theorem tensorHom_oddMap_tmulOE (f : M ⟶ M') (g : N ⟶ N') + (m : M.odd) (n : N.even) : + (tensorHom f g).oddMap (tmulOE M N m n) + = tmulOE M' N' (f.oddMap m) (g.evenMap n) := + mkHom_oddMap_tmulOE (tensorHomData f g) m n + +/-- The tensor product preserves identities. -/ +theorem tensorHom_id (M N : S.Mod.{u, u, u, u}) : + tensorHom (𝟙 M) (𝟙 N) = 𝟙 (M.tensor N) := by + refine hom_ext (fun m n => ?_) (fun m n => ?_) (fun m n => ?_) + (fun m n => ?_) <;> + simp only [tensorHom_evenMap_tmulEE, tensorHom_evenMap_tmulOO, + tensorHom_oddMap_tmulEO, tensorHom_oddMap_tmulOE, + id_evenMap, id_oddMap, LinearMap.id_coe, id_eq] + +/-- The tensor product preserves composition. -/ +theorem tensorHom_comp (f : M ⟶ M') (f' : M' ⟶ M'') (g : N ⟶ N') + (g' : N' ⟶ N'') : + tensorHom (f ≫ f') (g ≫ g') + = tensorHom f g ≫ tensorHom f' g' := by + refine hom_ext (fun m n => ?_) (fun m n => ?_) (fun m n => ?_) + (fun m n => ?_) <;> + simp only [comp_evenMap, comp_oddMap, LinearMap.comp_apply, + tensorHom_evenMap_tmulEE, tensorHom_evenMap_tmulOO, + tensorHom_oddMap_tmulEO, tensorHom_oddMap_tmulOE] + +end TensorHom + +/-! ## The tensor unit -/ + +section Unit + +/-- **The tensor unit**: the algebra regarded as a module over +itself, the four action blocks being the four multiplication +blocks. The ten module axioms are the algebra's own unit and +associativity laws. + +It is `reducible` so that the identification of its components +with those of `S` is transparent to unification and to `rw`. -/ +@[reducible] +def _root_.RS.SuperCommAlgebra.unitMod (S : SuperCommAlgebra.{u, u}) : + S.Mod.{u, u, u, u} where + even := S.even + odd := S.odd + actEE := S.mulEE + actEO := S.mulEO + actOE := S.mulOE + actOO := S.mulOO + one_act_e := S.one_mul_e + one_act_o := S.one_mul_o + assoc_eee := S.assoc_eee + assoc_eeo := S.assoc_eeo + assoc_eoe := S.assoc_eoe + assoc_eoo := S.assoc_eoo + assoc_oee := S.assoc_oee + assoc_oeo := S.assoc_oeo + assoc_ooe := S.assoc_ooe + assoc_ooo := S.assoc_ooo + +@[simp] +theorem unitMod_actEE (x y : S.even) : + S.unitMod.actEE x y = S.mulEE x y := rfl + +@[simp] +theorem unitMod_actEO (x : S.even) (u : S.odd) : + S.unitMod.actEO x u = S.mulEO x u := rfl + +@[simp] +theorem unitMod_actOE (u : S.odd) (x : S.even) : + S.unitMod.actOE u x = S.mulOE u x := rfl + +@[simp] +theorem unitMod_actOO (u v : S.odd) : + S.unitMod.actOO u v = S.mulOO u v := rfl + +/-- Acting by an even scalar on the unit returns the scalar. -/ +theorem unitMod_actEE_one (x : S.even) : + S.unitMod.actEE x S.one = x := by + rw [unitMod_actEE, S.comm_ee, S.one_mul_e] + +/-- Acting by an odd scalar on the unit returns the scalar. -/ +theorem unitMod_actOE_one (u : S.odd) : + S.unitMod.actOE u S.one = u := by + rw [unitMod_actOE, ← S.comm_eo, S.one_mul_o] + +end Unit + +/-! ## The left unitor -/ + +section LeftUnitor + +variable (M : S.Mod.{u, u, u, u}) + +/-- The data of the left unitor: the unit factor acts on the +module. Every law is one of the module axioms, conjugated where +needed by the commutativity of `S`. -/ +def leftUnitorData : TensorData S.unitMod M M where + fee := M.actEE + foo := M.actOO + feo := M.actEO + foe := M.actOE + hee := fun b x m => by + rw [unitMod_actEE, S.comm_ee, M.assoc_eee] + hoo := fun b u m => by + rw [unitMod_actEO, S.comm_eo, M.assoc_oeo] + hoeo := fun c x m => by + rw [unitMod_actOE, ← S.comm_eo, M.assoc_eoo] + hooe := fun c u m => by + rw [unitMod_actOO, S.comm_oo, map_neg, LinearMap.neg_apply, + M.assoc_ooe] + heeo := fun b x m => by + rw [unitMod_actEE, S.comm_ee, M.assoc_eeo] + heoe := fun b u m => by + rw [unitMod_actEO, S.comm_eo, M.assoc_oee] + hoee := fun c x m => by + rw [unitMod_actOE, ← S.comm_eo, M.assoc_eoe] + hooo := fun c u m => by + rw [unitMod_actOO, S.comm_oo, map_neg, LinearMap.neg_apply, + M.assoc_ooo] + aee := fun a x m => M.assoc_eee a x m + aoo := fun a u m => M.assoc_eoo a u m + aeo := fun a x m => M.assoc_eeo a x m + aoe := fun a u m => M.assoc_eoe a u m + cee := fun c x m => M.assoc_oee c x m + coo := fun c u m => M.assoc_ooo c u m + ceo := fun c x m => M.assoc_oeo c x m + coe := fun c u m => M.assoc_ooe c u m + +/-- The structure map of the left unitor. -/ +noncomputable def leftUnitorHom : S.unitMod.tensor M ⟶ M := + mkHom (leftUnitorData M) + +@[simp] +theorem leftUnitorHom_evenMap_tmulEE (x : S.even) (m : M.even) : + (leftUnitorHom M).evenMap (tmulEE S.unitMod M x m) + = M.actEE x m := + mkHom_evenMap_tmulEE (leftUnitorData M) x m + +@[simp] +theorem leftUnitorHom_evenMap_tmulOO (u : S.odd) (m : M.odd) : + (leftUnitorHom M).evenMap (tmulOO S.unitMod M u m) + = M.actOO u m := + mkHom_evenMap_tmulOO (leftUnitorData M) u m + +@[simp] +theorem leftUnitorHom_oddMap_tmulEO (x : S.even) (m : M.odd) : + (leftUnitorHom M).oddMap (tmulEO S.unitMod M x m) + = M.actEO x m := + mkHom_oddMap_tmulEO (leftUnitorData M) x m + +@[simp] +theorem leftUnitorHom_oddMap_tmulOE (u : S.odd) (m : M.even) : + (leftUnitorHom M).oddMap (tmulOE S.unitMod M u m) + = M.actOE u m := + mkHom_oddMap_tmulOE (leftUnitorData M) u m + +/-- The inverse of the left unitor: tensor with the algebra +unit. -/ +noncomputable def leftUnitorInv : M ⟶ S.unitMod.tensor M where + evenMap := tmulEE S.unitMod M S.one + oddMap := tmulEO S.unitMod M S.one + map_actEE x m := by + rw [actEE_tmulEE] + exact (tmulEE_balanced_eee S.unitMod M x S.one m).symm + map_actEO x m := by + rw [actEO_tmulEO] + exact (tmulEO_balanced_eeo S.unitMod M x S.one m).symm + map_actOE u m := by + rw [actOE_tmulEE] + exact (tmulOE_balanced_oee S.unitMod M u S.one m).symm + map_actOO u m := by + rw [actOO_tmulEO] + exact (tmulOO_balanced_oeo S.unitMod M u S.one m).symm + +@[simp] +theorem leftUnitorInv_evenMap (m : M.even) : + (leftUnitorInv M).evenMap m = tmulEE S.unitMod M S.one m := rfl + +@[simp] +theorem leftUnitorInv_oddMap (m : M.odd) : + (leftUnitorInv M).oddMap m = tmulEO S.unitMod M S.one m := rfl + +/-- **The left unitor**: tensoring with the unit on the left +changes nothing. -/ +noncomputable def leftUnitor : S.unitMod.tensor M ≅ M where + hom := leftUnitorHom M + inv := leftUnitorInv M + hom_inv_id := by + refine hom_ext (fun (x : S.even) m => ?_) (fun (u : S.odd) m => ?_) + (fun (x : S.even) m => ?_) (fun (u : S.odd) m => ?_) + · rw [comp_evenMap, LinearMap.comp_apply, + leftUnitorHom_evenMap_tmulEE, leftUnitorInv_evenMap, + id_evenMap, LinearMap.id_coe, id_eq, + ← tmulEE_balanced_eee, unitMod_actEE_one] + · rw [comp_evenMap, LinearMap.comp_apply, + leftUnitorHom_evenMap_tmulOO, leftUnitorInv_evenMap, + id_evenMap, LinearMap.id_coe, id_eq, + ← tmulOO_balanced_oeo, unitMod_actOE_one] + · rw [comp_oddMap, LinearMap.comp_apply, + leftUnitorHom_oddMap_tmulEO, leftUnitorInv_oddMap, + id_oddMap, LinearMap.id_coe, id_eq, + ← tmulEO_balanced_eeo, unitMod_actEE_one] + · rw [comp_oddMap, LinearMap.comp_apply, + leftUnitorHom_oddMap_tmulOE, leftUnitorInv_oddMap, + id_oddMap, LinearMap.id_coe, id_eq, + ← tmulOE_balanced_oee, unitMod_actOE_one] + inv_hom_id := by + refine Hom.ext (LinearMap.ext fun m => ?_) + (LinearMap.ext fun m => ?_) + · change (leftUnitorHom M).evenMap (tmulEE S.unitMod M S.one m) = m + rw [leftUnitorHom_evenMap_tmulEE] + exact M.one_act_e m + · change (leftUnitorHom M).oddMap (tmulEO S.unitMod M S.one m) = m + rw [leftUnitorHom_oddMap_tmulEO] + exact M.one_act_o m + +end LeftUnitor + +/-! ## The right unitor -/ + +section RightUnitor + +variable (M : S.Mod.{u, u, u, u}) + +/-- The data of the right unitor: the unit factor acts on the +module, with the Koszul sign when both factors are odd. -/ +noncomputable def rightUnitorData : TensorData M S.unitMod M where + fee := M.actEE.flip + foo := -M.actOO.flip + feo := M.actOE.flip + foe := M.actEO.flip + hee := fun b m x => by + simp only [LinearMap.flip_apply] + rw [S.comm_ee, M.assoc_eee] + hoo := fun b m u => by + simp only [LinearMap.flip_apply, LinearMap.neg_apply] + rw [S.comm_eo, M.assoc_oeo] + hoeo := fun c m u => by + simp only [LinearMap.flip_apply, LinearMap.neg_apply] + rw [M.assoc_ooe] + exact (M.actOO_actOE_neg c u m).symm + hooe := fun c m x => by + simp only [LinearMap.flip_apply, LinearMap.neg_apply, neg_neg] + rw [M.assoc_oeo, M.actEE_actOO] + heeo := fun b m u => by + simp only [LinearMap.flip_apply] + rw [S.comm_eo, M.assoc_oee] + heoe := fun b m x => by + simp only [LinearMap.flip_apply] + rw [S.comm_ee, M.assoc_eeo] + hoee := fun c m x => by + simp only [LinearMap.flip_apply] + rw [M.assoc_oee, M.actEO_actOE] + hooo := fun c m u => by + simp only [LinearMap.flip_apply] + rw [M.assoc_ooo, M.actOE_actOO_neg] + aee := fun a m x => M.actEE_actEE_comm x a m + aoo := fun a m u => by + simp only [LinearMap.flip_apply, LinearMap.neg_apply] + rw [map_neg, M.actEE_actOO] + aeo := fun a m u => (M.actEO_actOE a u m).symm + aoe := fun a m x => M.actEO_actEO_comm x a m + cee := fun c m x => M.actEO_actOE x c m + coo := fun c m u => by + simp only [LinearMap.flip_apply, LinearMap.neg_apply] + rw [map_neg, M.actOE_actOO_neg] + ceo := fun c m u => by + simp only [LinearMap.flip_apply, LinearMap.neg_apply] + exact (M.actOO_actOE_neg c u m).symm + coe := fun c m x => M.actEE_actOO x c m + +/-- The structure map of the right unitor. -/ +noncomputable def rightUnitorHom : M.tensor S.unitMod ⟶ M := + mkHom (rightUnitorData M) + +@[simp] +theorem rightUnitorHom_evenMap_tmulEE (m : M.even) (x : S.even) : + (rightUnitorHom M).evenMap (tmulEE M S.unitMod m x) + = M.actEE x m := + mkHom_evenMap_tmulEE (rightUnitorData M) m x + +@[simp] +theorem rightUnitorHom_evenMap_tmulOO (m : M.odd) (u : S.odd) : + (rightUnitorHom M).evenMap (tmulOO M S.unitMod m u) + = -M.actOO u m := + mkHom_evenMap_tmulOO (rightUnitorData M) m u + +@[simp] +theorem rightUnitorHom_oddMap_tmulEO (m : M.even) (u : S.odd) : + (rightUnitorHom M).oddMap (tmulEO M S.unitMod m u) + = M.actOE u m := + mkHom_oddMap_tmulEO (rightUnitorData M) m u + +@[simp] +theorem rightUnitorHom_oddMap_tmulOE (m : M.odd) (x : S.even) : + (rightUnitorHom M).oddMap (tmulOE M S.unitMod m x) + = M.actEO x m := + mkHom_oddMap_tmulOE (rightUnitorData M) m x + +/-- The inverse of the right unitor: tensor with the algebra unit +on the right. -/ +noncomputable def rightUnitorInv : M ⟶ M.tensor S.unitMod where + evenMap := (tmulEE M S.unitMod).flip S.one + oddMap := (tmulOE M S.unitMod).flip S.one + map_actEE _ _ := rfl + map_actEO _ _ := rfl + map_actOE u m := (actOE_tmulEE M S.unitMod u m S.one).symm + map_actOO u m := (actOO_tmulOE M S.unitMod u m S.one).symm + +@[simp] +theorem rightUnitorInv_evenMap (m : M.even) : + (rightUnitorInv M).evenMap m = tmulEE M S.unitMod m S.one := rfl + +@[simp] +theorem rightUnitorInv_oddMap (m : M.odd) : + (rightUnitorInv M).oddMap m = tmulOE M S.unitMod m S.one := rfl + +/-- **The right unitor**: tensoring with the unit on the right +changes nothing. -/ +noncomputable def rightUnitor : M.tensor S.unitMod ≅ M where + hom := rightUnitorHom M + inv := rightUnitorInv M + hom_inv_id := by + refine hom_ext (fun m (x : S.even) => ?_) (fun m (u : S.odd) => ?_) + (fun m (u : S.odd) => ?_) (fun m (x : S.even) => ?_) + · rw [comp_evenMap, LinearMap.comp_apply, + rightUnitorHom_evenMap_tmulEE, rightUnitorInv_evenMap, + id_evenMap, LinearMap.id_coe, id_eq, + tmulEE_balanced_eee, unitMod_actEE_one] + · rw [comp_evenMap, LinearMap.comp_apply, + rightUnitorHom_evenMap_tmulOO, rightUnitorInv_evenMap, + map_neg, LinearMap.neg_apply, id_evenMap, LinearMap.id_coe, + id_eq, + tmulEE_balanced_ooe, unitMod_actOE_one, neg_neg] + · rw [comp_oddMap, LinearMap.comp_apply, + rightUnitorHom_oddMap_tmulEO, rightUnitorInv_oddMap, + id_oddMap, LinearMap.id_coe, id_eq, + tmulOE_balanced_oee, unitMod_actOE_one] + · rw [comp_oddMap, LinearMap.comp_apply, + rightUnitorHom_oddMap_tmulOE, rightUnitorInv_oddMap, + id_oddMap, LinearMap.id_coe, id_eq, + tmulOE_balanced_eoe, unitMod_actEE_one] + inv_hom_id := by + refine Hom.ext (LinearMap.ext fun m => ?_) + (LinearMap.ext fun m => ?_) + · change (rightUnitorHom M).evenMap + (tmulEE M S.unitMod m S.one) = m + rw [rightUnitorHom_evenMap_tmulEE] + exact M.one_act_e m + · change (rightUnitorHom M).oddMap + (tmulOE M S.unitMod m S.one) = m + rw [rightUnitorHom_oddMap_tmulOE] + exact M.one_act_o m + +end RightUnitor + +/-! ## Naturality of the unitors -/ + +section UnitorNaturality + +variable {M N : S.Mod.{u, u, u, u}} + +/-- The left unitor is natural. -/ +theorem leftUnitor_naturality (f : M ⟶ N) : + tensorHom (𝟙 S.unitMod) f ≫ leftUnitorHom N + = leftUnitorHom M ≫ f := by + refine hom_ext (fun (x : S.even) m => ?_) (fun (u : S.odd) m => ?_) + (fun (x : S.even) m => ?_) (fun (u : S.odd) m => ?_) <;> + simp only [comp_evenMap, comp_oddMap, LinearMap.comp_apply] + · rw [tensorHom_evenMap_tmulEE, id_evenMap, LinearMap.id_coe, + id_eq, leftUnitorHom_evenMap_tmulEE, + leftUnitorHom_evenMap_tmulEE, f.map_actEE] + · rw [tensorHom_evenMap_tmulOO, id_oddMap, LinearMap.id_coe, + id_eq, leftUnitorHom_evenMap_tmulOO, + leftUnitorHom_evenMap_tmulOO, f.map_actOO] + · rw [tensorHom_oddMap_tmulEO, id_evenMap, LinearMap.id_coe, + id_eq, leftUnitorHom_oddMap_tmulEO, + leftUnitorHom_oddMap_tmulEO, f.map_actEO] + · rw [tensorHom_oddMap_tmulOE, id_oddMap, LinearMap.id_coe, + id_eq, leftUnitorHom_oddMap_tmulOE, + leftUnitorHom_oddMap_tmulOE, f.map_actOE] + +/-- The right unitor is natural. -/ +theorem rightUnitor_naturality (f : M ⟶ N) : + tensorHom f (𝟙 S.unitMod) ≫ rightUnitorHom N + = rightUnitorHom M ≫ f := by + refine hom_ext (fun m (x : S.even) => ?_) (fun m (u : S.odd) => ?_) + (fun m (u : S.odd) => ?_) (fun m (x : S.even) => ?_) <;> + simp only [comp_evenMap, comp_oddMap, LinearMap.comp_apply] + · rw [tensorHom_evenMap_tmulEE, id_evenMap, LinearMap.id_coe, + id_eq, rightUnitorHom_evenMap_tmulEE, + rightUnitorHom_evenMap_tmulEE, f.map_actEE] + · rw [tensorHom_evenMap_tmulOO, id_oddMap, LinearMap.id_coe, + id_eq, rightUnitorHom_evenMap_tmulOO, + rightUnitorHom_evenMap_tmulOO, map_neg, f.map_actOO] + · rw [tensorHom_oddMap_tmulEO, id_oddMap, LinearMap.id_coe, + id_eq, rightUnitorHom_oddMap_tmulEO, + rightUnitorHom_oddMap_tmulEO, f.map_actOE] + · rw [tensorHom_oddMap_tmulOE, id_evenMap, LinearMap.id_coe, + id_eq, rightUnitorHom_oddMap_tmulOE, + rightUnitorHom_oddMap_tmulOE, f.map_actEO] + +end UnitorNaturality + +/-! ## The braiding -/ + +section Braiding + +variable (M N : S.Mod.{u, u, u, u}) + +/-- The data of the Koszul swap: interchange the two factors, with +a sign when both are odd. -/ +noncomputable def braidingData : TensorData M N (N.tensor M) where + fee := (tmulEE N M).flip + foo := -(tmulOO N M).flip + feo := (tmulOE N M).flip + foe := (tmulEO N M).flip + hee := fun b m n => (tmulEE_balanced_eee N M b n m).symm + hoo := fun b m n => by + simp only [LinearMap.neg_apply, LinearMap.flip_apply] + rw [tmulOO_balanced_eoo N M b n m] + hoeo := fun c m n => by + simp only [LinearMap.neg_apply, LinearMap.flip_apply] + exact (tmulEE_balanced_ooe N M c n m).symm + hooe := fun c m n => by + simp only [LinearMap.neg_apply, LinearMap.flip_apply, neg_neg] + exact (tmulOO_balanced_oeo N M c n m).symm + heeo := fun b m n => (tmulOE_balanced_eoe N M b n m).symm + heoe := fun b m n => (tmulEO_balanced_eeo N M b n m).symm + hoee := fun c m n => (tmulOE_balanced_oee N M c n m).symm + hooo := fun c m n => by + simp only [LinearMap.flip_apply] + rw [tmulEO_balanced_ooo N M c n m, neg_neg] + aee := fun a m n => by + simp only [LinearMap.flip_apply] + rw [actEE_tmulEE] + exact (tmulEE_balanced_eee N M a n m).symm + aoo := fun a m n => by + simp only [LinearMap.neg_apply, LinearMap.flip_apply] + rw [map_neg, actEE_tmulOO, tmulOO_balanced_eoo N M a n m] + aeo := fun a m n => by + simp only [LinearMap.flip_apply] + rw [actEO_tmulOE] + exact (tmulOE_balanced_eoe N M a n m).symm + aoe := fun a m n => by + simp only [LinearMap.flip_apply] + rw [actEO_tmulEO] + exact (tmulEO_balanced_eeo N M a n m).symm + cee := fun c m n => by + simp only [LinearMap.flip_apply] + rw [actOE_tmulEE] + exact (tmulOE_balanced_oee N M c n m).symm + coo := fun c m n => by + simp only [LinearMap.neg_apply, LinearMap.flip_apply] + rw [map_neg, actOE_tmulOO, tmulEO_balanced_ooo N M c n m, + neg_neg] + ceo := fun c m n => by + simp only [LinearMap.neg_apply, LinearMap.flip_apply] + rw [actOO_tmulOE] + exact (tmulEE_balanced_ooe N M c n m).symm + coe := fun c m n => by + simp only [LinearMap.flip_apply] + rw [actOO_tmulEO] + exact (tmulOO_balanced_oeo N M c n m).symm + +/-- The structure map of the braiding. -/ +noncomputable def braidingHom : M.tensor N ⟶ N.tensor M := + mkHom (braidingData M N) + +@[simp] +theorem braidingHom_evenMap_tmulEE (m : M.even) (n : N.even) : + (braidingHom M N).evenMap (tmulEE M N m n) = tmulEE N M n m := + mkHom_evenMap_tmulEE (braidingData M N) m n + +@[simp] +theorem braidingHom_evenMap_tmulOO (m : M.odd) (n : N.odd) : + (braidingHom M N).evenMap (tmulOO M N m n) = -tmulOO N M n m := + mkHom_evenMap_tmulOO (braidingData M N) m n + +@[simp] +theorem braidingHom_oddMap_tmulEO (m : M.even) (n : N.odd) : + (braidingHom M N).oddMap (tmulEO M N m n) = tmulOE N M n m := + mkHom_oddMap_tmulEO (braidingData M N) m n + +@[simp] +theorem braidingHom_oddMap_tmulOE (m : M.odd) (n : N.even) : + (braidingHom M N).oddMap (tmulOE M N m n) = tmulEO N M n m := + mkHom_oddMap_tmulOE (braidingData M N) m n + +/-- **The Koszul swap is an involution**: swapping twice restores +the original order, the two signs cancelling. -/ +theorem braidingHom_braidingHom : + braidingHom M N ≫ braidingHom N M = 𝟙 (M.tensor N) := by + refine hom_ext (fun m n => ?_) (fun m n => ?_) (fun m n => ?_) + (fun m n => ?_) <;> + simp only [comp_evenMap, comp_oddMap, LinearMap.comp_apply] + · rw [braidingHom_evenMap_tmulEE, braidingHom_evenMap_tmulEE, + id_evenMap, LinearMap.id_coe, id_eq] + · rw [braidingHom_evenMap_tmulOO, map_neg, + braidingHom_evenMap_tmulOO, neg_neg, id_evenMap, + LinearMap.id_coe, id_eq] + · rw [braidingHom_oddMap_tmulEO, braidingHom_oddMap_tmulOE, + id_oddMap, LinearMap.id_coe, id_eq] + · rw [braidingHom_oddMap_tmulOE, braidingHom_oddMap_tmulEO, + id_oddMap, LinearMap.id_coe, id_eq] + +/-- **The braiding**: the Koszul swap of the two factors. -/ +noncomputable def braiding : M.tensor N ≅ N.tensor M where + hom := braidingHom M N + inv := braidingHom N M + hom_inv_id := braidingHom_braidingHom M N + inv_hom_id := braidingHom_braidingHom N M + +end Braiding + +/-! ## Lifting one degree at a time -/ + +section LiftData + +/-- **The data of a linear map out of the even part** of a tensor +product: two balanced bilinear blocks. -/ +structure LiftEvenData (M N : S.Mod.{u, u, u, u}) (T : Type u) + [AddCommGroup T] [Module ℂ T] where + /-- The even-even block. -/ + fee : M.even →ₗ[ℂ] N.even →ₗ[ℂ] T + /-- The odd-odd block. -/ + foo : M.odd →ₗ[ℂ] N.odd →ₗ[ℂ] T + /-- Balancing at parity pattern even-even-even. -/ + hee : ∀ (b : S.even) (m : M.even) (n : N.even), + fee (M.actEE b m) n = fee m (N.actEE b n) + /-- Balancing at parity pattern even-odd-odd. -/ + hoo : ∀ (b : S.even) (m : M.odd) (n : N.odd), + foo (M.actEO b m) n = foo m (N.actEO b n) + /-- Balancing at parity pattern odd-even-odd. -/ + hoeo : ∀ (c : S.odd) (m : M.even) (n : N.odd), + foo (M.actOE c m) n = fee m (N.actOO c n) + /-- Balancing at parity pattern odd-odd-even. -/ + hooe : ∀ (c : S.odd) (m : M.odd) (n : N.even), + fee (M.actOO c m) n = -foo m (N.actOE c n) + +/-- **The data of a linear map out of the odd part** of a tensor +product: two balanced bilinear blocks. -/ +structure LiftOddData (M N : S.Mod.{u, u, u, u}) (T : Type u) + [AddCommGroup T] [Module ℂ T] where + /-- The even-odd block. -/ + feo : M.even →ₗ[ℂ] N.odd →ₗ[ℂ] T + /-- The odd-even block. -/ + foe : M.odd →ₗ[ℂ] N.even →ₗ[ℂ] T + /-- Balancing at parity pattern even-even-odd. -/ + heeo : ∀ (b : S.even) (m : M.even) (n : N.odd), + feo (M.actEE b m) n = feo m (N.actEO b n) + /-- Balancing at parity pattern even-odd-even. -/ + heoe : ∀ (b : S.even) (m : M.odd) (n : N.even), + foe (M.actEO b m) n = foe m (N.actEE b n) + /-- Balancing at parity pattern odd-even-even. -/ + hoee : ∀ (c : S.odd) (m : M.even) (n : N.even), + foe (M.actOE c m) n = feo m (N.actOE c n) + /-- Balancing at parity pattern odd-odd-odd. -/ + hooo : ∀ (c : S.odd) (m : M.odd) (n : N.odd), + feo (M.actOO c m) n = -foe m (N.actOO c n) + +variable {M N : S.Mod.{u, u, u, u}} {T : Type u} + +/-- The even-degree lift of a `LiftEvenData`. -/ +noncomputable def liftE [AddCommGroup T] [Module ℂ T] + (d : LiftEvenData M N T) : + (M.tensor N).even →ₗ[ℂ] T := + liftEven M N d.fee d.foo d.hee d.hoo d.hoeo d.hooe + +/-- The odd-degree lift of a `LiftOddData`. -/ +noncomputable def liftO [AddCommGroup T] [Module ℂ T] + (d : LiftOddData M N T) : + (M.tensor N).odd →ₗ[ℂ] T := + liftOdd M N d.feo d.foe d.heeo d.heoe d.hoee d.hooo + +@[simp] +theorem liftE_tmulEE [AddCommGroup T] [Module ℂ T] + (d : LiftEvenData M N T) (m : M.even) + (n : N.even) : liftE d (tmulEE M N m n) = d.fee m n := + liftEven_tmulEE M N d.fee d.foo d.hee d.hoo d.hoeo d.hooe m n + +@[simp] +theorem liftE_tmulOO [AddCommGroup T] [Module ℂ T] + (d : LiftEvenData M N T) (m : M.odd) + (n : N.odd) : liftE d (tmulOO M N m n) = d.foo m n := + liftEven_tmulOO M N d.fee d.foo d.hee d.hoo d.hoeo d.hooe m n + +@[simp] +theorem liftO_tmulEO [AddCommGroup T] [Module ℂ T] + (d : LiftOddData M N T) (m : M.even) + (n : N.odd) : liftO d (tmulEO M N m n) = d.feo m n := + liftOdd_tmulEO M N d.feo d.foe d.heeo d.heoe d.hoee d.hooo m n + +@[simp] +theorem liftO_tmulOE [AddCommGroup T] [Module ℂ T] + (d : LiftOddData M N T) (m : M.odd) + (n : N.even) : liftO d (tmulOE M N m n) = d.foe m n := + liftOdd_tmulOE M N d.feo d.foe d.heeo d.heoe d.hoee d.hooo m n + +end LiftData + +/-! ## The associator -/ + +section Associator + +variable (M N P : S.Mod.{u, u, u, u}) + +/-- The even-even and odd-odd blocks of the associator in even +total degree. -/ +noncomputable def assocFeeData : + LiftEvenData M N (P.even →ₗ[ℂ] (M.tensor (N.tensor P)).even) where + fee := bicomp (tmulEE M (N.tensor P)) (tmulEE N P) + foo := bicomp (tmulOO M (N.tensor P)) (tmulOE N P) + hee := fun b m n => LinearMap.ext fun p => by + simp only [bicomp_apply] + rw [tmulEE_balanced_eee M (N.tensor P) b m (tmulEE N P n p), + actEE_tmulEE] + hoo := fun b m n => LinearMap.ext fun p => by + simp only [bicomp_apply] + rw [tmulOO_balanced_eoo M (N.tensor P) b m (tmulOE N P n p), + actEO_tmulOE] + hoeo := fun c m n => LinearMap.ext fun p => by + simp only [bicomp_apply] + rw [tmulOO_balanced_oeo M (N.tensor P) c m (tmulOE N P n p), + actOO_tmulOE] + hooe := fun c m n => LinearMap.ext fun p => by + simp only [bicomp_apply, LinearMap.neg_apply] + rw [tmulEE_balanced_ooe M (N.tensor P) c m (tmulEE N P n p), + actOE_tmulEE] + +/-- The even-odd and odd-even blocks of the associator in even +total degree. -/ +noncomputable def assocFooData : + LiftOddData M N (P.odd →ₗ[ℂ] (M.tensor (N.tensor P)).even) where + feo := bicomp (tmulEE M (N.tensor P)) (tmulOO N P) + foe := bicomp (tmulOO M (N.tensor P)) (tmulEO N P) + heeo := fun b m n => LinearMap.ext fun p => by + simp only [bicomp_apply] + rw [tmulEE_balanced_eee M (N.tensor P) b m (tmulOO N P n p), + actEE_tmulOO] + heoe := fun b m n => LinearMap.ext fun p => by + simp only [bicomp_apply] + rw [tmulOO_balanced_eoo M (N.tensor P) b m (tmulEO N P n p), + actEO_tmulEO] + hoee := fun c m n => LinearMap.ext fun p => by + simp only [bicomp_apply] + rw [tmulOO_balanced_oeo M (N.tensor P) c m (tmulEO N P n p), + actOO_tmulEO] + hooo := fun c m n => LinearMap.ext fun p => by + simp only [bicomp_apply, LinearMap.neg_apply] + rw [tmulEE_balanced_ooe M (N.tensor P) c m (tmulOO N P n p), + actOE_tmulOO] + +/-- The even-even and odd-odd blocks of the associator in odd +total degree. -/ +noncomputable def assocFeoData : + LiftEvenData M N (P.odd →ₗ[ℂ] (M.tensor (N.tensor P)).odd) where + fee := bicomp (tmulEO M (N.tensor P)) (tmulEO N P) + foo := bicomp (tmulOE M (N.tensor P)) (tmulOO N P) + hee := fun b m n => LinearMap.ext fun p => by + simp only [bicomp_apply] + rw [tmulEO_balanced_eeo M (N.tensor P) b m (tmulEO N P n p), + actEO_tmulEO] + hoo := fun b m n => LinearMap.ext fun p => by + simp only [bicomp_apply] + rw [tmulOE_balanced_eoe M (N.tensor P) b m (tmulOO N P n p), + actEE_tmulOO] + hoeo := fun c m n => LinearMap.ext fun p => by + simp only [bicomp_apply] + rw [tmulOE_balanced_oee M (N.tensor P) c m (tmulOO N P n p), + actOE_tmulOO] + hooe := fun c m n => LinearMap.ext fun p => by + simp only [bicomp_apply, LinearMap.neg_apply] + rw [tmulEO_balanced_ooo M (N.tensor P) c m (tmulEO N P n p), + actOO_tmulEO] + +/-- The even-odd and odd-even blocks of the associator in odd +total degree. -/ +noncomputable def assocFoeData : + LiftOddData M N (P.even →ₗ[ℂ] (M.tensor (N.tensor P)).odd) where + feo := bicomp (tmulEO M (N.tensor P)) (tmulOE N P) + foe := bicomp (tmulOE M (N.tensor P)) (tmulEE N P) + heeo := fun b m n => LinearMap.ext fun p => by + simp only [bicomp_apply] + rw [tmulEO_balanced_eeo M (N.tensor P) b m (tmulOE N P n p), + actEO_tmulOE] + heoe := fun b m n => LinearMap.ext fun p => by + simp only [bicomp_apply] + rw [tmulOE_balanced_eoe M (N.tensor P) b m (tmulEE N P n p), + actEE_tmulEE] + hoee := fun c m n => LinearMap.ext fun p => by + simp only [bicomp_apply] + rw [tmulOE_balanced_oee M (N.tensor P) c m (tmulEE N P n p), + actOE_tmulEE] + hooo := fun c m n => LinearMap.ext fun p => by + simp only [bicomp_apply, LinearMap.neg_apply] + rw [tmulEO_balanced_ooo M (N.tensor P) c m (tmulOE N P n p), + actOO_tmulOE] + +/-- The even-degree block of the associator, in the first two +factors. -/ +noncomputable def assocFee : (M.tensor N).even →ₗ[ℂ] + (P.even →ₗ[ℂ] (M.tensor (N.tensor P)).even) := + liftE (assocFeeData M N P) + +/-- The odd-degree block of the associator taking an odd third +factor to an even value. -/ +noncomputable def assocFoo : (M.tensor N).odd →ₗ[ℂ] + (P.odd →ₗ[ℂ] (M.tensor (N.tensor P)).even) := + liftO (assocFooData M N P) + +/-- The even-degree block of the associator taking an odd third +factor to an odd value. -/ +noncomputable def assocFeo : (M.tensor N).even →ₗ[ℂ] + (P.odd →ₗ[ℂ] (M.tensor (N.tensor P)).odd) := + liftE (assocFeoData M N P) + +/-- The odd-degree block of the associator taking an even third +factor to an odd value. -/ +noncomputable def assocFoe : (M.tensor N).odd →ₗ[ℂ] + (P.even →ₗ[ℂ] (M.tensor (N.tensor P)).odd) := + liftO (assocFoeData M N P) + +@[simp] +theorem assocFee_tmulEE (m : M.even) (n : N.even) (p : P.even) : + assocFee M N P (tmulEE M N m n) p + = tmulEE M (N.tensor P) m (tmulEE N P n p) := + LinearMap.congr_fun (liftE_tmulEE (assocFeeData M N P) m n) p + +@[simp] +theorem assocFee_tmulOO (m : M.odd) (n : N.odd) (p : P.even) : + assocFee M N P (tmulOO M N m n) p + = tmulOO M (N.tensor P) m (tmulOE N P n p) := + LinearMap.congr_fun (liftE_tmulOO (assocFeeData M N P) m n) p + +@[simp] +theorem assocFoo_tmulEO (m : M.even) (n : N.odd) (p : P.odd) : + assocFoo M N P (tmulEO M N m n) p + = tmulEE M (N.tensor P) m (tmulOO N P n p) := + LinearMap.congr_fun (liftO_tmulEO (assocFooData M N P) m n) p + +@[simp] +theorem assocFoo_tmulOE (m : M.odd) (n : N.even) (p : P.odd) : + assocFoo M N P (tmulOE M N m n) p + = tmulOO M (N.tensor P) m (tmulEO N P n p) := + LinearMap.congr_fun (liftO_tmulOE (assocFooData M N P) m n) p + +@[simp] +theorem assocFeo_tmulEE (m : M.even) (n : N.even) (p : P.odd) : + assocFeo M N P (tmulEE M N m n) p + = tmulEO M (N.tensor P) m (tmulEO N P n p) := + LinearMap.congr_fun (liftE_tmulEE (assocFeoData M N P) m n) p + +@[simp] +theorem assocFeo_tmulOO (m : M.odd) (n : N.odd) (p : P.odd) : + assocFeo M N P (tmulOO M N m n) p + = tmulOE M (N.tensor P) m (tmulOO N P n p) := + LinearMap.congr_fun (liftE_tmulOO (assocFeoData M N P) m n) p + +@[simp] +theorem assocFoe_tmulEO (m : M.even) (n : N.odd) (p : P.even) : + assocFoe M N P (tmulEO M N m n) p + = tmulEO M (N.tensor P) m (tmulOE N P n p) := + LinearMap.congr_fun (liftO_tmulEO (assocFoeData M N P) m n) p + +@[simp] +theorem assocFoe_tmulOE (m : M.odd) (n : N.even) (p : P.even) : + assocFoe M N P (tmulOE M N m n) p + = tmulOE M (N.tensor P) m (tmulEE N P n p) := + LinearMap.congr_fun (liftO_tmulOE (assocFoeData M N P) m n) p + +/-- The data of the associator: reassociate a triple product. +There is no sign; every law is an instance of the balancing and +action laws of the two inner tensor products. -/ +noncomputable def assocHomData : + TensorData (M.tensor N) P (M.tensor (N.tensor P)) where + fee := assocFee M N P + foo := assocFoo M N P + feo := assocFeo M N P + foe := assocFoe M N P + hee := fun b t p => by + refine LinearMap.congr_fun (liftEven_unique M N + ((assocFee M N P).flip p ∘ₗ (M.tensor N).actEE b) + ((assocFee M N P).flip (P.actEE b p)) + (fun m n => ?_) (fun m n => ?_)) t <;> + simp only [LinearMap.comp_apply, LinearMap.flip_apply] + · rw [actEE_tmulEE, assocFee_tmulEE, assocFee_tmulEE, + tmulEE_balanced_eee M (N.tensor P) b m (tmulEE N P n p), + actEE_tmulEE, tmulEE_balanced_eee N P b n p] + · rw [actEE_tmulOO, assocFee_tmulOO, assocFee_tmulOO, + tmulOO_balanced_eoo M (N.tensor P) b m (tmulOE N P n p), + actEO_tmulOE, tmulOE_balanced_eoe N P b n p] + hoo := fun b t p => by + refine LinearMap.congr_fun (liftOdd_unique M N + ((assocFoo M N P).flip p ∘ₗ (M.tensor N).actEO b) + ((assocFoo M N P).flip (P.actEO b p)) + (fun m n => ?_) (fun m n => ?_)) t <;> + simp only [LinearMap.comp_apply, LinearMap.flip_apply] + · rw [actEO_tmulEO, assocFoo_tmulEO, assocFoo_tmulEO, + tmulEE_balanced_eee M (N.tensor P) b m (tmulOO N P n p), + actEE_tmulOO, tmulOO_balanced_eoo N P b n p] + · rw [actEO_tmulOE, assocFoo_tmulOE, assocFoo_tmulOE, + tmulOO_balanced_eoo M (N.tensor P) b m (tmulEO N P n p), + actEO_tmulEO, tmulEO_balanced_eeo N P b n p] + hoeo := fun c t p => by + refine LinearMap.congr_fun (liftEven_unique M N + ((assocFoo M N P).flip p ∘ₗ (M.tensor N).actOE c) + ((assocFee M N P).flip (P.actOO c p)) + (fun m n => ?_) (fun m n => ?_)) t <;> + simp only [LinearMap.comp_apply, LinearMap.flip_apply] + · rw [actOE_tmulEE, assocFoo_tmulOE, assocFee_tmulEE, + tmulOO_balanced_oeo M (N.tensor P) c m (tmulEO N P n p), + actOO_tmulEO, tmulOO_balanced_oeo N P c n p] + · rw [actOE_tmulOO, assocFoo_tmulEO, assocFee_tmulOO, + tmulEE_balanced_ooe M (N.tensor P) c m (tmulOO N P n p), + actOE_tmulOO, tmulEO_balanced_ooo N P c n p, map_neg, + neg_neg] + hooe := fun c t p => by + refine LinearMap.congr_fun (liftOdd_unique M N + ((assocFee M N P).flip p ∘ₗ (M.tensor N).actOO c) + (-((assocFoo M N P).flip (P.actOE c p))) + (fun m n => ?_) (fun m n => ?_)) t <;> + simp only [LinearMap.comp_apply, LinearMap.flip_apply, + LinearMap.neg_apply] + · rw [actOO_tmulEO, assocFee_tmulOO, assocFoo_tmulEO, + tmulOO_balanced_oeo M (N.tensor P) c m (tmulOE N P n p), + actOO_tmulOE, tmulEE_balanced_ooe N P c n p, map_neg] + · rw [actOO_tmulOE, assocFee_tmulEE, assocFoo_tmulOE, + tmulEE_balanced_ooe M (N.tensor P) c m (tmulEE N P n p), + actOE_tmulEE, tmulOE_balanced_oee N P c n p] + heeo := fun b t p => by + refine LinearMap.congr_fun (liftEven_unique M N + ((assocFeo M N P).flip p ∘ₗ (M.tensor N).actEE b) + ((assocFeo M N P).flip (P.actEO b p)) + (fun m n => ?_) (fun m n => ?_)) t <;> + simp only [LinearMap.comp_apply, LinearMap.flip_apply] + · rw [actEE_tmulEE, assocFeo_tmulEE, assocFeo_tmulEE, + tmulEO_balanced_eeo M (N.tensor P) b m (tmulEO N P n p), + actEO_tmulEO, tmulEO_balanced_eeo N P b n p] + · rw [actEE_tmulOO, assocFeo_tmulOO, assocFeo_tmulOO, + tmulOE_balanced_eoe M (N.tensor P) b m (tmulOO N P n p), + actEE_tmulOO, tmulOO_balanced_eoo N P b n p] + heoe := fun b t p => by + refine LinearMap.congr_fun (liftOdd_unique M N + ((assocFoe M N P).flip p ∘ₗ (M.tensor N).actEO b) + ((assocFoe M N P).flip (P.actEE b p)) + (fun m n => ?_) (fun m n => ?_)) t <;> + simp only [LinearMap.comp_apply, LinearMap.flip_apply] + · rw [actEO_tmulEO, assocFoe_tmulEO, assocFoe_tmulEO, + tmulEO_balanced_eeo M (N.tensor P) b m (tmulOE N P n p), + actEO_tmulOE, tmulOE_balanced_eoe N P b n p] + · rw [actEO_tmulOE, assocFoe_tmulOE, assocFoe_tmulOE, + tmulOE_balanced_eoe M (N.tensor P) b m (tmulEE N P n p), + actEE_tmulEE, tmulEE_balanced_eee N P b n p] + hoee := fun c t p => by + refine LinearMap.congr_fun (liftEven_unique M N + ((assocFoe M N P).flip p ∘ₗ (M.tensor N).actOE c) + ((assocFeo M N P).flip (P.actOE c p)) + (fun m n => ?_) (fun m n => ?_)) t <;> + simp only [LinearMap.comp_apply, LinearMap.flip_apply] + · rw [actOE_tmulEE, assocFoe_tmulOE, assocFeo_tmulEE, + tmulOE_balanced_oee M (N.tensor P) c m (tmulEE N P n p), + actOE_tmulEE, tmulOE_balanced_oee N P c n p] + · rw [actOE_tmulOO, assocFoe_tmulEO, assocFeo_tmulOO, + tmulEO_balanced_ooo M (N.tensor P) c m (tmulOE N P n p), + actOO_tmulOE, tmulEE_balanced_ooe N P c n p, map_neg, + neg_neg] + hooo := fun c t p => by + refine LinearMap.congr_fun (liftOdd_unique M N + ((assocFeo M N P).flip p ∘ₗ (M.tensor N).actOO c) + (-((assocFoe M N P).flip (P.actOO c p))) + (fun m n => ?_) (fun m n => ?_)) t <;> + simp only [LinearMap.comp_apply, LinearMap.flip_apply, + LinearMap.neg_apply] + · rw [actOO_tmulEO, assocFeo_tmulOO, assocFoe_tmulEO, + tmulOE_balanced_oee M (N.tensor P) c m (tmulOO N P n p), + actOE_tmulOO, tmulEO_balanced_ooo N P c n p, map_neg] + · rw [actOO_tmulOE, assocFeo_tmulEE, assocFoe_tmulOE, + tmulEO_balanced_ooo M (N.tensor P) c m (tmulEO N P n p), + actOO_tmulEO, tmulOO_balanced_oeo N P c n p] + aee := fun a t p => by + refine LinearMap.congr_fun (liftEven_unique M N + ((assocFee M N P).flip p ∘ₗ (M.tensor N).actEE a) + ((M.tensor (N.tensor P)).actEE a ∘ₗ (assocFee M N P).flip p) + (fun m n => ?_) (fun m n => ?_)) t <;> + simp only [LinearMap.comp_apply, LinearMap.flip_apply] + · rw [actEE_tmulEE, assocFee_tmulEE, assocFee_tmulEE, + actEE_tmulEE] + · rw [actEE_tmulOO, assocFee_tmulOO, assocFee_tmulOO, + actEE_tmulOO] + aoo := fun a t p => by + refine LinearMap.congr_fun (liftOdd_unique M N + ((assocFoo M N P).flip p ∘ₗ (M.tensor N).actEO a) + ((M.tensor (N.tensor P)).actEE a ∘ₗ (assocFoo M N P).flip p) + (fun m n => ?_) (fun m n => ?_)) t <;> + simp only [LinearMap.comp_apply, LinearMap.flip_apply] + · rw [actEO_tmulEO, assocFoo_tmulEO, assocFoo_tmulEO, + actEE_tmulEE] + · rw [actEO_tmulOE, assocFoo_tmulOE, assocFoo_tmulOE, + actEE_tmulOO] + aeo := fun a t p => by + refine LinearMap.congr_fun (liftEven_unique M N + ((assocFeo M N P).flip p ∘ₗ (M.tensor N).actEE a) + ((M.tensor (N.tensor P)).actEO a ∘ₗ (assocFeo M N P).flip p) + (fun m n => ?_) (fun m n => ?_)) t <;> + simp only [LinearMap.comp_apply, LinearMap.flip_apply] + · rw [actEE_tmulEE, assocFeo_tmulEE, assocFeo_tmulEE, + actEO_tmulEO] + · rw [actEE_tmulOO, assocFeo_tmulOO, assocFeo_tmulOO, + actEO_tmulOE] + aoe := fun a t p => by + refine LinearMap.congr_fun (liftOdd_unique M N + ((assocFoe M N P).flip p ∘ₗ (M.tensor N).actEO a) + ((M.tensor (N.tensor P)).actEO a ∘ₗ (assocFoe M N P).flip p) + (fun m n => ?_) (fun m n => ?_)) t <;> + simp only [LinearMap.comp_apply, LinearMap.flip_apply] + · rw [actEO_tmulEO, assocFoe_tmulEO, assocFoe_tmulEO, + actEO_tmulEO] + · rw [actEO_tmulOE, assocFoe_tmulOE, assocFoe_tmulOE, + actEO_tmulOE] + cee := fun c t p => by + refine LinearMap.congr_fun (liftEven_unique M N + ((assocFoe M N P).flip p ∘ₗ (M.tensor N).actOE c) + ((M.tensor (N.tensor P)).actOE c ∘ₗ (assocFee M N P).flip p) + (fun m n => ?_) (fun m n => ?_)) t <;> + simp only [LinearMap.comp_apply, LinearMap.flip_apply] + · rw [actOE_tmulEE, assocFoe_tmulOE, assocFee_tmulEE, + actOE_tmulEE] + · rw [actOE_tmulOO, assocFoe_tmulEO, assocFee_tmulOO, + actOE_tmulOO] + coo := fun c t p => by + refine LinearMap.congr_fun (liftOdd_unique M N + ((assocFeo M N P).flip p ∘ₗ (M.tensor N).actOO c) + ((M.tensor (N.tensor P)).actOE c ∘ₗ (assocFoo M N P).flip p) + (fun m n => ?_) (fun m n => ?_)) t <;> + simp only [LinearMap.comp_apply, LinearMap.flip_apply] + · rw [actOO_tmulEO, assocFeo_tmulOO, assocFoo_tmulEO, + actOE_tmulEE] + · rw [actOO_tmulOE, assocFeo_tmulEE, assocFoo_tmulOE, + actOE_tmulOO] + ceo := fun c t p => by + refine LinearMap.congr_fun (liftEven_unique M N + ((assocFoo M N P).flip p ∘ₗ (M.tensor N).actOE c) + ((M.tensor (N.tensor P)).actOO c ∘ₗ (assocFeo M N P).flip p) + (fun m n => ?_) (fun m n => ?_)) t <;> + simp only [LinearMap.comp_apply, LinearMap.flip_apply] + · rw [actOE_tmulEE, assocFoo_tmulOE, assocFeo_tmulEE, + actOO_tmulEO] + · rw [actOE_tmulOO, assocFoo_tmulEO, assocFeo_tmulOO, + actOO_tmulOE] + coe := fun c t p => by + refine LinearMap.congr_fun (liftOdd_unique M N + ((assocFee M N P).flip p ∘ₗ (M.tensor N).actOO c) + ((M.tensor (N.tensor P)).actOO c ∘ₗ (assocFoe M N P).flip p) + (fun m n => ?_) (fun m n => ?_)) t <;> + simp only [LinearMap.comp_apply, LinearMap.flip_apply] + · rw [actOO_tmulEO, assocFee_tmulOO, assocFoe_tmulEO, + actOO_tmulEO] + · rw [actOO_tmulOE, assocFee_tmulEE, assocFoe_tmulOE, + actOO_tmulOE] + +/-- The structure map of the associator. -/ +noncomputable def assocHom : + (M.tensor N).tensor P ⟶ M.tensor (N.tensor P) := + mkHom (assocHomData M N P) + +@[simp] +theorem assocHom_evenMap_tmulEE (t : (M.tensor N).even) + (p : P.even) : + (assocHom M N P).evenMap (tmulEE (M.tensor N) P t p) + = assocFee M N P t p := + mkHom_evenMap_tmulEE (assocHomData M N P) t p + +@[simp] +theorem assocHom_evenMap_tmulOO (t : (M.tensor N).odd) (p : P.odd) : + (assocHom M N P).evenMap (tmulOO (M.tensor N) P t p) + = assocFoo M N P t p := + mkHom_evenMap_tmulOO (assocHomData M N P) t p + +@[simp] +theorem assocHom_oddMap_tmulEO (t : (M.tensor N).even) (p : P.odd) : + (assocHom M N P).oddMap (tmulEO (M.tensor N) P t p) + = assocFeo M N P t p := + mkHom_oddMap_tmulEO (assocHomData M N P) t p + +@[simp] +theorem assocHom_oddMap_tmulOE (t : (M.tensor N).odd) (p : P.even) : + (assocHom M N P).oddMap (tmulOE (M.tensor N) P t p) + = assocFoe M N P t p := + mkHom_oddMap_tmulOE (assocHomData M N P) t p + +/-! ### The inverse of the associator -/ + +/-- The even-even and odd-odd blocks of the inverse associator in +even total degree, lifted in the last two factors. -/ +noncomputable def assocInvFeeData : + LiftEvenData N P (M.even →ₗ[ℂ] ((M.tensor N).tensor P).even) where + fee := bicompFlip (tmulEE (M.tensor N) P) (tmulEE M N) + foo := bicompFlip (tmulOO (M.tensor N) P) (tmulEO M N) + hee := fun b n p => LinearMap.ext fun m => by + simp only [bicompFlip_apply] + rw [← tmulEE_balanced_eee M N b m n, ← actEE_tmulEE, + tmulEE_balanced_eee] + hoo := fun b n p => LinearMap.ext fun m => by + simp only [bicompFlip_apply] + rw [← tmulEO_balanced_eeo M N b m n, ← actEO_tmulEO, + tmulOO_balanced_eoo] + hoeo := fun c n p => LinearMap.ext fun m => by + simp only [bicompFlip_apply] + rw [← tmulOE_balanced_oee M N c m n, ← actOE_tmulEE, + tmulOO_balanced_oeo] + hooe := fun c n p => LinearMap.ext fun m => by + simp only [bicompFlip_apply, LinearMap.neg_apply] + rw [← tmulOO_balanced_oeo M N c m n, ← actOO_tmulEO, + tmulEE_balanced_ooe] + +/-- The even-odd and odd-even blocks of the inverse associator in +even total degree. -/ +noncomputable def assocInvFooData : + LiftOddData N P (M.odd →ₗ[ℂ] ((M.tensor N).tensor P).even) where + feo := bicompFlip (tmulOO (M.tensor N) P) (tmulOE M N) + foe := bicompFlip (tmulEE (M.tensor N) P) (tmulOO M N) + heeo := fun b n p => LinearMap.ext fun m => by + simp only [bicompFlip_apply] + rw [← tmulOE_balanced_eoe M N b m n, ← actEO_tmulOE, + tmulOO_balanced_eoo] + heoe := fun b n p => LinearMap.ext fun m => by + simp only [bicompFlip_apply] + rw [← tmulOO_balanced_eoo M N b m n, ← actEE_tmulOO, + tmulEE_balanced_eee] + hoee := fun c n p => LinearMap.ext fun m => by + simp only [bicompFlip_apply] + have h : tmulOO M N m (N.actOE c n) + = -tmulEE M N (M.actOO c m) n := by + rw [tmulEE_balanced_ooe, neg_neg] + rw [h, map_neg, LinearMap.neg_apply, ← actOO_tmulOE, + tmulEE_balanced_ooe, neg_neg] + hooo := fun c n p => LinearMap.ext fun m => by + simp only [bicompFlip_apply, LinearMap.neg_apply] + have h : tmulOE M N m (N.actOO c n) + = -tmulEO M N (M.actOO c m) n := by + rw [tmulEO_balanced_ooo, neg_neg] + rw [h, map_neg, LinearMap.neg_apply, ← actOE_tmulOO, + tmulOO_balanced_oeo] + +/-- The even-odd and odd-even blocks of the inverse associator in +odd total degree. -/ +noncomputable def assocInvFeoData : + LiftOddData N P (M.even →ₗ[ℂ] ((M.tensor N).tensor P).odd) where + feo := bicompFlip (tmulEO (M.tensor N) P) (tmulEE M N) + foe := bicompFlip (tmulOE (M.tensor N) P) (tmulEO M N) + heeo := fun b n p => LinearMap.ext fun m => by + simp only [bicompFlip_apply] + rw [← tmulEE_balanced_eee M N b m n, ← actEE_tmulEE, + tmulEO_balanced_eeo] + heoe := fun b n p => LinearMap.ext fun m => by + simp only [bicompFlip_apply] + rw [← tmulEO_balanced_eeo M N b m n, ← actEO_tmulEO, + tmulOE_balanced_eoe] + hoee := fun c n p => LinearMap.ext fun m => by + simp only [bicompFlip_apply] + rw [← tmulOE_balanced_oee M N c m n, ← actOE_tmulEE, + tmulOE_balanced_oee] + hooo := fun c n p => LinearMap.ext fun m => by + simp only [bicompFlip_apply, LinearMap.neg_apply] + rw [← tmulOO_balanced_oeo M N c m n, ← actOO_tmulEO, + tmulEO_balanced_ooo] + +/-- The even-even and odd-odd blocks of the inverse associator in +odd total degree. -/ +noncomputable def assocInvFoeData : + LiftEvenData N P (M.odd →ₗ[ℂ] ((M.tensor N).tensor P).odd) where + fee := bicompFlip (tmulOE (M.tensor N) P) (tmulOE M N) + foo := bicompFlip (tmulEO (M.tensor N) P) (tmulOO M N) + hee := fun b n p => LinearMap.ext fun m => by + simp only [bicompFlip_apply] + rw [← tmulOE_balanced_eoe M N b m n, ← actEO_tmulOE, + tmulOE_balanced_eoe] + hoo := fun b n p => LinearMap.ext fun m => by + simp only [bicompFlip_apply] + rw [← tmulOO_balanced_eoo M N b m n, ← actEE_tmulOO, + tmulEO_balanced_eeo] + hoeo := fun c n p => LinearMap.ext fun m => by + simp only [bicompFlip_apply] + have h : tmulOO M N m (N.actOE c n) + = -tmulEE M N (M.actOO c m) n := by + rw [tmulEE_balanced_ooe, neg_neg] + rw [h, map_neg, LinearMap.neg_apply, ← actOO_tmulOE, + tmulEO_balanced_ooo, neg_neg] + hooe := fun c n p => LinearMap.ext fun m => by + simp only [bicompFlip_apply, LinearMap.neg_apply] + have h : tmulOE M N m (N.actOO c n) + = -tmulEO M N (M.actOO c m) n := by + rw [tmulEO_balanced_ooo, neg_neg] + rw [h, map_neg, LinearMap.neg_apply, ← actOE_tmulOO, + tmulOE_balanced_oee] + +/-- The even-degree block of the inverse associator. -/ +noncomputable def assocInvFee : M.even →ₗ[ℂ] + (N.tensor P).even →ₗ[ℂ] ((M.tensor N).tensor P).even := + (liftE (assocInvFeeData M N P)).flip + +/-- The block of the inverse associator on an odd second factor +with an odd first factor. -/ +noncomputable def assocInvFoo : M.odd →ₗ[ℂ] + (N.tensor P).odd →ₗ[ℂ] ((M.tensor N).tensor P).even := + (liftO (assocInvFooData M N P)).flip + +/-- The block of the inverse associator on an odd second factor +with an even first factor. -/ +noncomputable def assocInvFeo : M.even →ₗ[ℂ] + (N.tensor P).odd →ₗ[ℂ] ((M.tensor N).tensor P).odd := + (liftO (assocInvFeoData M N P)).flip + +/-- The block of the inverse associator on an even second factor +with an odd first factor. -/ +noncomputable def assocInvFoe : M.odd →ₗ[ℂ] + (N.tensor P).even →ₗ[ℂ] ((M.tensor N).tensor P).odd := + (liftE (assocInvFoeData M N P)).flip + +@[simp] +theorem assocInvFee_tmulEE (m : M.even) (n : N.even) (p : P.even) : + assocInvFee M N P m (tmulEE N P n p) + = tmulEE (M.tensor N) P (tmulEE M N m n) p := + LinearMap.congr_fun (liftE_tmulEE (assocInvFeeData M N P) n p) m + +@[simp] +theorem assocInvFee_tmulOO (m : M.even) (n : N.odd) (p : P.odd) : + assocInvFee M N P m (tmulOO N P n p) + = tmulOO (M.tensor N) P (tmulEO M N m n) p := + LinearMap.congr_fun (liftE_tmulOO (assocInvFeeData M N P) n p) m + +@[simp] +theorem assocInvFoo_tmulEO (m : M.odd) (n : N.even) (p : P.odd) : + assocInvFoo M N P m (tmulEO N P n p) + = tmulOO (M.tensor N) P (tmulOE M N m n) p := + LinearMap.congr_fun (liftO_tmulEO (assocInvFooData M N P) n p) m + +@[simp] +theorem assocInvFoo_tmulOE (m : M.odd) (n : N.odd) (p : P.even) : + assocInvFoo M N P m (tmulOE N P n p) + = tmulEE (M.tensor N) P (tmulOO M N m n) p := + LinearMap.congr_fun (liftO_tmulOE (assocInvFooData M N P) n p) m + +@[simp] +theorem assocInvFeo_tmulEO (m : M.even) (n : N.even) (p : P.odd) : + assocInvFeo M N P m (tmulEO N P n p) + = tmulEO (M.tensor N) P (tmulEE M N m n) p := + LinearMap.congr_fun (liftO_tmulEO (assocInvFeoData M N P) n p) m + +@[simp] +theorem assocInvFeo_tmulOE (m : M.even) (n : N.odd) (p : P.even) : + assocInvFeo M N P m (tmulOE N P n p) + = tmulOE (M.tensor N) P (tmulEO M N m n) p := + LinearMap.congr_fun (liftO_tmulOE (assocInvFeoData M N P) n p) m + +@[simp] +theorem assocInvFoe_tmulEE (m : M.odd) (n : N.even) (p : P.even) : + assocInvFoe M N P m (tmulEE N P n p) + = tmulOE (M.tensor N) P (tmulOE M N m n) p := + LinearMap.congr_fun (liftE_tmulEE (assocInvFoeData M N P) n p) m + +@[simp] +theorem assocInvFoe_tmulOO (m : M.odd) (n : N.odd) (p : P.odd) : + assocInvFoe M N P m (tmulOO N P n p) + = tmulEO (M.tensor N) P (tmulOO M N m n) p := + LinearMap.congr_fun (liftE_tmulOO (assocInvFoeData M N P) n p) m + +/-- The data of the inverse associator. -/ +noncomputable def assocInvData : + TensorData M (N.tensor P) ((M.tensor N).tensor P) where + fee := assocInvFee M N P + foo := assocInvFoo M N P + feo := assocInvFeo M N P + foe := assocInvFoe M N P + hee := fun b m w => by + refine LinearMap.congr_fun (liftEven_unique N P + (assocInvFee M N P (M.actEE b m)) + (assocInvFee M N P m ∘ₗ (N.tensor P).actEE b) + (fun n p => ?_) (fun n p => ?_)) w <;> + simp only [LinearMap.comp_apply] + · rw [actEE_tmulEE, assocInvFee_tmulEE, assocInvFee_tmulEE, + tmulEE_balanced_eee M N b m n] + · rw [actEE_tmulOO, assocInvFee_tmulOO, assocInvFee_tmulOO, + tmulEO_balanced_eeo M N b m n] + hoo := fun b m w => by + refine LinearMap.congr_fun (liftOdd_unique N P + (assocInvFoo M N P (M.actEO b m)) + (assocInvFoo M N P m ∘ₗ (N.tensor P).actEO b) + (fun n p => ?_) (fun n p => ?_)) w <;> + simp only [LinearMap.comp_apply] + · rw [actEO_tmulEO, assocInvFoo_tmulEO, assocInvFoo_tmulEO, + tmulOE_balanced_eoe M N b m n] + · rw [actEO_tmulOE, assocInvFoo_tmulOE, assocInvFoo_tmulOE, + tmulOO_balanced_eoo M N b m n] + hoeo := fun c m w => by + refine LinearMap.congr_fun (liftOdd_unique N P + (assocInvFoo M N P (M.actOE c m)) + (assocInvFee M N P m ∘ₗ (N.tensor P).actOO c) + (fun n p => ?_) (fun n p => ?_)) w <;> + simp only [LinearMap.comp_apply] + · rw [actOO_tmulEO, assocInvFoo_tmulEO, assocInvFee_tmulOO, + tmulOE_balanced_oee M N c m n] + · rw [actOO_tmulOE, assocInvFoo_tmulOE, assocInvFee_tmulEE, + tmulOO_balanced_oeo M N c m n] + hooe := fun c m w => by + refine LinearMap.congr_fun (liftEven_unique N P + (assocInvFee M N P (M.actOO c m)) + (-(assocInvFoo M N P m ∘ₗ (N.tensor P).actOE c)) + (fun n p => ?_) (fun n p => ?_)) w <;> + simp only [LinearMap.comp_apply, LinearMap.neg_apply] + · rw [actOE_tmulEE, assocInvFee_tmulEE, assocInvFoo_tmulOE, + tmulEE_balanced_ooe M N c m n, map_neg, + LinearMap.neg_apply] + · rw [actOE_tmulOO, assocInvFee_tmulOO, assocInvFoo_tmulEO, + tmulEO_balanced_ooo M N c m n, map_neg, + LinearMap.neg_apply] + heeo := fun b m w => by + refine LinearMap.congr_fun (liftOdd_unique N P + (assocInvFeo M N P (M.actEE b m)) + (assocInvFeo M N P m ∘ₗ (N.tensor P).actEO b) + (fun n p => ?_) (fun n p => ?_)) w <;> + simp only [LinearMap.comp_apply] + · rw [actEO_tmulEO, assocInvFeo_tmulEO, assocInvFeo_tmulEO, + tmulEE_balanced_eee M N b m n] + · rw [actEO_tmulOE, assocInvFeo_tmulOE, assocInvFeo_tmulOE, + tmulEO_balanced_eeo M N b m n] + heoe := fun b m w => by + refine LinearMap.congr_fun (liftEven_unique N P + (assocInvFoe M N P (M.actEO b m)) + (assocInvFoe M N P m ∘ₗ (N.tensor P).actEE b) + (fun n p => ?_) (fun n p => ?_)) w <;> + simp only [LinearMap.comp_apply] + · rw [actEE_tmulEE, assocInvFoe_tmulEE, assocInvFoe_tmulEE, + tmulOE_balanced_eoe M N b m n] + · rw [actEE_tmulOO, assocInvFoe_tmulOO, assocInvFoe_tmulOO, + tmulOO_balanced_eoo M N b m n] + hoee := fun c m w => by + refine LinearMap.congr_fun (liftEven_unique N P + (assocInvFoe M N P (M.actOE c m)) + (assocInvFeo M N P m ∘ₗ (N.tensor P).actOE c) + (fun n p => ?_) (fun n p => ?_)) w <;> + simp only [LinearMap.comp_apply] + · rw [actOE_tmulEE, assocInvFoe_tmulEE, assocInvFeo_tmulOE, + tmulOE_balanced_oee M N c m n] + · rw [actOE_tmulOO, assocInvFoe_tmulOO, assocInvFeo_tmulEO, + tmulOO_balanced_oeo M N c m n] + hooo := fun c m w => by + refine LinearMap.congr_fun (liftOdd_unique N P + (assocInvFeo M N P (M.actOO c m)) + (-(assocInvFoe M N P m ∘ₗ (N.tensor P).actOO c)) + (fun n p => ?_) (fun n p => ?_)) w <;> + simp only [LinearMap.comp_apply, LinearMap.neg_apply] + · rw [actOO_tmulEO, assocInvFeo_tmulEO, assocInvFoe_tmulOO, + tmulEE_balanced_ooe M N c m n, map_neg, + LinearMap.neg_apply] + · rw [actOO_tmulOE, assocInvFeo_tmulOE, assocInvFoe_tmulEE, + tmulEO_balanced_ooo M N c m n, map_neg, + LinearMap.neg_apply] + aee := fun a m w => by + refine LinearMap.congr_fun (liftEven_unique N P + (assocInvFee M N P (M.actEE a m)) + (((M.tensor N).tensor P).actEE a ∘ₗ assocInvFee M N P m) + (fun n p => ?_) (fun n p => ?_)) w <;> + simp only [LinearMap.comp_apply] + · rw [assocInvFee_tmulEE, assocInvFee_tmulEE, actEE_tmulEE, + actEE_tmulEE] + · rw [assocInvFee_tmulOO, assocInvFee_tmulOO, actEE_tmulOO, + actEO_tmulEO] + aoo := fun a m w => by + refine LinearMap.congr_fun (liftOdd_unique N P + (assocInvFoo M N P (M.actEO a m)) + (((M.tensor N).tensor P).actEE a ∘ₗ assocInvFoo M N P m) + (fun n p => ?_) (fun n p => ?_)) w <;> + simp only [LinearMap.comp_apply] + · rw [assocInvFoo_tmulEO, assocInvFoo_tmulEO, actEE_tmulOO, + actEO_tmulOE] + · rw [assocInvFoo_tmulOE, assocInvFoo_tmulOE, actEE_tmulEE, + actEE_tmulOO] + aeo := fun a m w => by + refine LinearMap.congr_fun (liftOdd_unique N P + (assocInvFeo M N P (M.actEE a m)) + (((M.tensor N).tensor P).actEO a ∘ₗ assocInvFeo M N P m) + (fun n p => ?_) (fun n p => ?_)) w <;> + simp only [LinearMap.comp_apply] + · rw [assocInvFeo_tmulEO, assocInvFeo_tmulEO, actEO_tmulEO, + actEE_tmulEE] + · rw [assocInvFeo_tmulOE, assocInvFeo_tmulOE, actEO_tmulOE, + actEO_tmulEO] + aoe := fun a m w => by + refine LinearMap.congr_fun (liftEven_unique N P + (assocInvFoe M N P (M.actEO a m)) + (((M.tensor N).tensor P).actEO a ∘ₗ assocInvFoe M N P m) + (fun n p => ?_) (fun n p => ?_)) w <;> + simp only [LinearMap.comp_apply] + · rw [assocInvFoe_tmulEE, assocInvFoe_tmulEE, actEO_tmulOE, + actEO_tmulOE] + · rw [assocInvFoe_tmulOO, assocInvFoe_tmulOO, actEO_tmulEO, + actEE_tmulOO] + cee := fun c m w => by + refine LinearMap.congr_fun (liftEven_unique N P + (assocInvFoe M N P (M.actOE c m)) + (((M.tensor N).tensor P).actOE c ∘ₗ assocInvFee M N P m) + (fun n p => ?_) (fun n p => ?_)) w <;> + simp only [LinearMap.comp_apply] + · rw [assocInvFoe_tmulEE, assocInvFee_tmulEE, actOE_tmulEE, + actOE_tmulEE] + · rw [assocInvFoe_tmulOO, assocInvFee_tmulOO, actOE_tmulOO, + actOO_tmulEO] + coo := fun c m w => by + refine LinearMap.congr_fun (liftOdd_unique N P + (assocInvFeo M N P (M.actOO c m)) + (((M.tensor N).tensor P).actOE c ∘ₗ assocInvFoo M N P m) + (fun n p => ?_) (fun n p => ?_)) w <;> + simp only [LinearMap.comp_apply] + · rw [assocInvFeo_tmulEO, assocInvFoo_tmulEO, actOE_tmulOO, + actOO_tmulOE] + · rw [assocInvFeo_tmulOE, assocInvFoo_tmulOE, actOE_tmulEE, + actOE_tmulOO] + ceo := fun c m w => by + refine LinearMap.congr_fun (liftOdd_unique N P + (assocInvFoo M N P (M.actOE c m)) + (((M.tensor N).tensor P).actOO c ∘ₗ assocInvFeo M N P m) + (fun n p => ?_) (fun n p => ?_)) w <;> + simp only [LinearMap.comp_apply] + · rw [assocInvFoo_tmulEO, assocInvFeo_tmulEO, actOO_tmulEO, + actOE_tmulEE] + · rw [assocInvFoo_tmulOE, assocInvFeo_tmulOE, actOO_tmulOE, + actOO_tmulEO] + coe := fun c m w => by + refine LinearMap.congr_fun (liftEven_unique N P + (assocInvFee M N P (M.actOO c m)) + (((M.tensor N).tensor P).actOO c ∘ₗ assocInvFoe M N P m) + (fun n p => ?_) (fun n p => ?_)) w <;> + simp only [LinearMap.comp_apply] + · rw [assocInvFee_tmulEE, assocInvFoe_tmulEE, actOO_tmulOE, + actOO_tmulOE] + · rw [assocInvFee_tmulOO, assocInvFoe_tmulOO, actOO_tmulEO, + actOE_tmulOO] + +/-- The structure map of the inverse associator. -/ +noncomputable def assocInv : + M.tensor (N.tensor P) ⟶ (M.tensor N).tensor P := + mkHom (assocInvData M N P) + +@[simp] +theorem assocInv_evenMap_tmulEE (m : M.even) (w : (N.tensor P).even) : + (assocInv M N P).evenMap (tmulEE M (N.tensor P) m w) + = assocInvFee M N P m w := + mkHom_evenMap_tmulEE (assocInvData M N P) m w + +@[simp] +theorem assocInv_evenMap_tmulOO (m : M.odd) (w : (N.tensor P).odd) : + (assocInv M N P).evenMap (tmulOO M (N.tensor P) m w) + = assocInvFoo M N P m w := + mkHom_evenMap_tmulOO (assocInvData M N P) m w + +@[simp] +theorem assocInv_oddMap_tmulEO (m : M.even) (w : (N.tensor P).odd) : + (assocInv M N P).oddMap (tmulEO M (N.tensor P) m w) + = assocInvFeo M N P m w := + mkHom_oddMap_tmulEO (assocInvData M N P) m w + +@[simp] +theorem assocInv_oddMap_tmulOE (m : M.odd) (w : (N.tensor P).even) : + (assocInv M N P).oddMap (tmulOE M (N.tensor P) m w) + = assocInvFoe M N P m w := + mkHom_oddMap_tmulOE (assocInvData M N P) m w + +/-- Reassociating and then reassociating back is the identity. -/ +theorem assocHom_assocInv : + assocHom M N P ≫ assocInv M N P + = 𝟙 ((M.tensor N).tensor P) := by + refine hom_ext₃ (fun m n p => ?_) (fun m n p => ?_) + (fun m n p => ?_) (fun m n p => ?_) (fun m n p => ?_) + (fun m n p => ?_) (fun m n p => ?_) (fun m n p => ?_) + · rw [comp_evenMap, LinearMap.comp_apply, + assocHom_evenMap_tmulEE, assocFee_tmulEE, + assocInv_evenMap_tmulEE, assocInvFee_tmulEE, id_evenMap, + LinearMap.id_coe, id_eq] + · rw [comp_evenMap, LinearMap.comp_apply, + assocHom_evenMap_tmulEE, assocFee_tmulOO, + assocInv_evenMap_tmulOO, assocInvFoo_tmulOE, id_evenMap, + LinearMap.id_coe, id_eq] + · rw [comp_evenMap, LinearMap.comp_apply, + assocHom_evenMap_tmulOO, assocFoo_tmulEO, + assocInv_evenMap_tmulEE, assocInvFee_tmulOO, id_evenMap, + LinearMap.id_coe, id_eq] + · rw [comp_evenMap, LinearMap.comp_apply, + assocHom_evenMap_tmulOO, assocFoo_tmulOE, + assocInv_evenMap_tmulOO, assocInvFoo_tmulEO, id_evenMap, + LinearMap.id_coe, id_eq] + · rw [comp_oddMap, LinearMap.comp_apply, + assocHom_oddMap_tmulEO, assocFeo_tmulEE, + assocInv_oddMap_tmulEO, assocInvFeo_tmulEO, id_oddMap, + LinearMap.id_coe, id_eq] + · rw [comp_oddMap, LinearMap.comp_apply, + assocHom_oddMap_tmulEO, assocFeo_tmulOO, + assocInv_oddMap_tmulOE, assocInvFoe_tmulOO, id_oddMap, + LinearMap.id_coe, id_eq] + · rw [comp_oddMap, LinearMap.comp_apply, + assocHom_oddMap_tmulOE, assocFoe_tmulEO, + assocInv_oddMap_tmulEO, assocInvFeo_tmulOE, id_oddMap, + LinearMap.id_coe, id_eq] + · rw [comp_oddMap, LinearMap.comp_apply, + assocHom_oddMap_tmulOE, assocFoe_tmulOE, + assocInv_oddMap_tmulOE, assocInvFoe_tmulEE, id_oddMap, + LinearMap.id_coe, id_eq] + +/-- Reassociating back and then reassociating is the identity. -/ +theorem assocInv_assocHom : + assocInv M N P ≫ assocHom M N P + = 𝟙 (M.tensor (N.tensor P)) := by + refine hom_ext₃' (fun m n p => ?_) (fun m n p => ?_) + (fun m n p => ?_) (fun m n p => ?_) (fun m n p => ?_) + (fun m n p => ?_) (fun m n p => ?_) (fun m n p => ?_) + · rw [comp_evenMap, LinearMap.comp_apply, + assocInv_evenMap_tmulEE, assocInvFee_tmulEE, + assocHom_evenMap_tmulEE, assocFee_tmulEE, id_evenMap, + LinearMap.id_coe, id_eq] + · rw [comp_evenMap, LinearMap.comp_apply, + assocInv_evenMap_tmulEE, assocInvFee_tmulOO, + assocHom_evenMap_tmulOO, assocFoo_tmulEO, id_evenMap, + LinearMap.id_coe, id_eq] + · rw [comp_evenMap, LinearMap.comp_apply, + assocInv_evenMap_tmulOO, assocInvFoo_tmulEO, + assocHom_evenMap_tmulOO, assocFoo_tmulOE, id_evenMap, + LinearMap.id_coe, id_eq] + · rw [comp_evenMap, LinearMap.comp_apply, + assocInv_evenMap_tmulOO, assocInvFoo_tmulOE, + assocHom_evenMap_tmulEE, assocFee_tmulOO, id_evenMap, + LinearMap.id_coe, id_eq] + · rw [comp_oddMap, LinearMap.comp_apply, + assocInv_oddMap_tmulEO, assocInvFeo_tmulEO, + assocHom_oddMap_tmulEO, assocFeo_tmulEE, id_oddMap, + LinearMap.id_coe, id_eq] + · rw [comp_oddMap, LinearMap.comp_apply, + assocInv_oddMap_tmulEO, assocInvFeo_tmulOE, + assocHom_oddMap_tmulOE, assocFoe_tmulEO, id_oddMap, + LinearMap.id_coe, id_eq] + · rw [comp_oddMap, LinearMap.comp_apply, + assocInv_oddMap_tmulOE, assocInvFoe_tmulEE, + assocHom_oddMap_tmulOE, assocFoe_tmulOE, id_oddMap, + LinearMap.id_coe, id_eq] + · rw [comp_oddMap, LinearMap.comp_apply, + assocInv_oddMap_tmulOE, assocInvFoe_tmulOO, + assocHom_oddMap_tmulEO, assocFeo_tmulOO, id_oddMap, + LinearMap.id_coe, id_eq] + +/-- **The associator**: reassociation of a threefold tensor +product, with no sign. -/ +noncomputable def associator : + (M.tensor N).tensor P ≅ M.tensor (N.tensor P) where + hom := assocHom M N P + inv := assocInv M N P + hom_inv_id := assocHom_assocInv M N P + inv_hom_id := assocInv_assocHom M N P + +end Associator + +/-! ## Naturality of the associator -/ + +section AssociatorNaturality + +variable {M M' N N' P P' : S.Mod.{u, u, u, u}} + +/-- The associator is natural in all three arguments. -/ +theorem assocHom_naturality (f : M ⟶ M') (g : N ⟶ N') + (h : P ⟶ P') : + tensorHom (tensorHom f g) h ≫ assocHom M' N' P' + = assocHom M N P ≫ tensorHom f (tensorHom g h) := by + refine hom_ext₃ (fun m n p => ?_) (fun m n p => ?_) + (fun m n p => ?_) (fun m n p => ?_) (fun m n p => ?_) + (fun m n p => ?_) (fun m n p => ?_) (fun m n p => ?_) <;> + simp only [comp_evenMap, comp_oddMap, LinearMap.comp_apply] + · rw [tensorHom_evenMap_tmulEE, tensorHom_evenMap_tmulEE, + assocHom_evenMap_tmulEE, assocFee_tmulEE, + assocHom_evenMap_tmulEE, assocFee_tmulEE, + tensorHom_evenMap_tmulEE, tensorHom_evenMap_tmulEE] + · rw [tensorHom_evenMap_tmulEE, tensorHom_evenMap_tmulOO, + assocHom_evenMap_tmulEE, assocFee_tmulOO, + assocHom_evenMap_tmulEE, assocFee_tmulOO, + tensorHom_evenMap_tmulOO, tensorHom_oddMap_tmulOE] + · rw [tensorHom_evenMap_tmulOO, tensorHom_oddMap_tmulEO, + assocHom_evenMap_tmulOO, assocFoo_tmulEO, + assocHom_evenMap_tmulOO, assocFoo_tmulEO, + tensorHom_evenMap_tmulEE, tensorHom_evenMap_tmulOO] + · rw [tensorHom_evenMap_tmulOO, tensorHom_oddMap_tmulOE, + assocHom_evenMap_tmulOO, assocFoo_tmulOE, + assocHom_evenMap_tmulOO, assocFoo_tmulOE, + tensorHom_evenMap_tmulOO, tensorHom_oddMap_tmulEO] + · rw [tensorHom_oddMap_tmulEO, tensorHom_evenMap_tmulEE, + assocHom_oddMap_tmulEO, assocFeo_tmulEE, + assocHom_oddMap_tmulEO, assocFeo_tmulEE, + tensorHom_oddMap_tmulEO, tensorHom_oddMap_tmulEO] + · rw [tensorHom_oddMap_tmulEO, tensorHom_evenMap_tmulOO, + assocHom_oddMap_tmulEO, assocFeo_tmulOO, + assocHom_oddMap_tmulEO, assocFeo_tmulOO, + tensorHom_oddMap_tmulOE, tensorHom_evenMap_tmulOO] + · rw [tensorHom_oddMap_tmulOE, tensorHom_oddMap_tmulEO, + assocHom_oddMap_tmulOE, assocFoe_tmulEO, + assocHom_oddMap_tmulOE, assocFoe_tmulEO, + tensorHom_oddMap_tmulEO, tensorHom_oddMap_tmulOE] + · rw [tensorHom_oddMap_tmulOE, tensorHom_oddMap_tmulOE, + assocHom_oddMap_tmulOE, assocFoe_tmulOE, + assocHom_oddMap_tmulOE, assocFoe_tmulOE, + tensorHom_oddMap_tmulOE, tensorHom_evenMap_tmulEE] + +end AssociatorNaturality + +/-! ## The triangle identity -/ + +section Triangle + +variable (M N : S.Mod.{u, u, u, u}) + +/-- **The triangle identity**: the two ways of cancelling a unit +in the middle of a threefold product agree. -/ +theorem triangle_identity : + assocHom M S.unitMod N ≫ tensorHom (𝟙 M) (leftUnitorHom N) + = tensorHom (rightUnitorHom M) (𝟙 N) := by + refine hom_ext₃ (fun m x n => ?_) (fun m u n => ?_) + (fun m u n => ?_) (fun m x n => ?_) (fun m x n => ?_) + (fun m u n => ?_) (fun m u n => ?_) (fun m x n => ?_) <;> + simp only [comp_evenMap, comp_oddMap, LinearMap.comp_apply] + · rw [assocHom_evenMap_tmulEE, assocFee_tmulEE, + tensorHom_evenMap_tmulEE, tensorHom_evenMap_tmulEE] + simp only [id_evenMap, LinearMap.id_coe, id_eq] + rw [leftUnitorHom_evenMap_tmulEE, + rightUnitorHom_evenMap_tmulEE, tmulEE_balanced_eee] + · rw [assocHom_evenMap_tmulEE, assocFee_tmulOO, + tensorHom_evenMap_tmulOO, tensorHom_evenMap_tmulEE] + simp only [id_evenMap, id_oddMap, LinearMap.id_coe, id_eq] + rw [leftUnitorHom_oddMap_tmulOE, + rightUnitorHom_evenMap_tmulOO, map_neg, LinearMap.neg_apply, + tmulEE_balanced_ooe, neg_neg] + · rw [assocHom_evenMap_tmulOO, assocFoo_tmulEO, + tensorHom_evenMap_tmulEE, tensorHom_evenMap_tmulOO] + simp only [id_evenMap, id_oddMap, LinearMap.id_coe, id_eq] + rw [leftUnitorHom_evenMap_tmulOO, + rightUnitorHom_oddMap_tmulEO, tmulOO_balanced_oeo] + · rw [assocHom_evenMap_tmulOO, assocFoo_tmulOE, + tensorHom_evenMap_tmulOO, tensorHom_evenMap_tmulOO] + simp only [id_oddMap, LinearMap.id_coe, id_eq] + rw [leftUnitorHom_oddMap_tmulEO, + rightUnitorHom_oddMap_tmulOE, tmulOO_balanced_eoo] + · rw [assocHom_oddMap_tmulEO, assocFeo_tmulEE, + tensorHom_oddMap_tmulEO, tensorHom_oddMap_tmulEO] + simp only [id_evenMap, id_oddMap, LinearMap.id_coe, id_eq] + rw [leftUnitorHom_oddMap_tmulEO, + rightUnitorHom_evenMap_tmulEE, tmulEO_balanced_eeo] + · rw [assocHom_oddMap_tmulEO, assocFeo_tmulOO, + tensorHom_oddMap_tmulOE, tensorHom_oddMap_tmulEO] + simp only [id_oddMap, LinearMap.id_coe, id_eq] + rw [leftUnitorHom_evenMap_tmulOO, + rightUnitorHom_evenMap_tmulOO, map_neg, LinearMap.neg_apply, + tmulEO_balanced_ooo, neg_neg] + · rw [assocHom_oddMap_tmulOE, assocFoe_tmulEO, + tensorHom_oddMap_tmulEO, tensorHom_oddMap_tmulOE] + simp only [id_evenMap, LinearMap.id_coe, id_eq] + rw [leftUnitorHom_oddMap_tmulOE, + rightUnitorHom_oddMap_tmulEO, tmulOE_balanced_oee] + · rw [assocHom_oddMap_tmulOE, assocFoe_tmulOE, + tensorHom_oddMap_tmulOE, tensorHom_oddMap_tmulOE] + simp only [id_evenMap, id_oddMap, LinearMap.id_coe, id_eq] + rw [leftUnitorHom_evenMap_tmulEE, + rightUnitorHom_oddMap_tmulOE, tmulOE_balanced_eoe] + +end Triangle + +/-! ## The pentagon identity -/ + +section Pentagon + +variable (M N P Q : S.Mod.{u, u, u, u}) + +/-- **The pentagon identity**: the two ways of reassociating a +fourfold product agree. -/ +theorem pentagon_identity : + tensorHom (assocHom M N P) (𝟙 Q) ≫ assocHom M (N.tensor P) Q + ≫ tensorHom (𝟙 M) (assocHom N P Q) + = assocHom (M.tensor N) P Q ≫ assocHom M N (P.tensor Q) := by + refine hom_ext₄ (fun m n p q => ?_) (fun m n p q => ?_) + (fun m n p q => ?_) (fun m n p q => ?_) (fun m n p q => ?_) + (fun m n p q => ?_) (fun m n p q => ?_) (fun m n p q => ?_) + (fun m n p q => ?_) (fun m n p q => ?_) (fun m n p q => ?_) + (fun m n p q => ?_) (fun m n p q => ?_) (fun m n p q => ?_) + (fun m n p q => ?_) (fun m n p q => ?_) <;> + simp only [comp_evenMap, comp_oddMap, LinearMap.comp_apply, + tensorHom_evenMap_tmulEE, tensorHom_evenMap_tmulOO, + tensorHom_oddMap_tmulEO, tensorHom_oddMap_tmulOE, + assocHom_evenMap_tmulEE, assocHom_evenMap_tmulOO, + assocHom_oddMap_tmulEO, assocHom_oddMap_tmulOE, + assocFee_tmulEE, assocFee_tmulOO, assocFoo_tmulEO, + assocFoo_tmulOE, assocFeo_tmulEE, assocFeo_tmulOO, + assocFoe_tmulEO, assocFoe_tmulOE, id_evenMap, id_oddMap, + LinearMap.id_coe, id_eq] + +end Pentagon + +/-! ## The monoidal structure -/ + +/-- **Super modules over a super-commutative ℂ-algebra form a +monoidal category**, with the balanced tensor product, the algebra +itself as unit, and the associator and unitors built from the +universal property. -/ +noncomputable instance instMonoidalCategory : + MonoidalCategory S.Mod.{u, u, u, u} where + tensorObj M N := M.tensor N + whiskerLeft := fun M {_ _} f => tensorHom (𝟙 M) f + whiskerRight := fun {_ _} f N => tensorHom f (𝟙 N) + tensorHom := fun {_ _ _ _} f g => tensorHom f g + tensorUnit := S.unitMod + associator M N P := Mod.associator M N P + leftUnitor M := Mod.leftUnitor M + rightUnitor M := Mod.rightUnitor M + tensorHom_def f g := by + rw [← tensorHom_comp, Category.comp_id, Category.id_comp] + id_tensorHom_id M N := tensorHom_id M N + tensorHom_comp_tensorHom f₁ f₂ g₁ g₂ := + (tensorHom_comp f₁ g₁ f₂ g₂).symm + whiskerLeft_id M N := tensorHom_id M N + id_whiskerRight M N := tensorHom_id M N + associator_naturality f₁ f₂ f₃ := assocHom_naturality f₁ f₂ f₃ + leftUnitor_naturality f := Mod.leftUnitor_naturality f + rightUnitor_naturality f := Mod.rightUnitor_naturality f + pentagon M N P Q := pentagon_identity M N P Q + triangle M N := triangle_identity M N + +/-! ## The symmetry -/ + +section Symmetry + +/-- The braiding is natural in its right-hand argument. -/ +theorem braidingHom_naturality_right (X : S.Mod.{u, u, u, u}) + {Y Z : S.Mod.{u, u, u, u}} (f : Y ⟶ Z) : + tensorHom (𝟙 X) f ≫ braidingHom X Z + = braidingHom X Y ≫ tensorHom f (𝟙 X) := by + refine hom_ext (fun m n => ?_) (fun m n => ?_) (fun m n => ?_) + (fun m n => ?_) <;> + simp only [comp_evenMap, comp_oddMap, LinearMap.comp_apply, + tensorHom_evenMap_tmulEE, tensorHom_evenMap_tmulOO, + tensorHom_oddMap_tmulEO, tensorHom_oddMap_tmulOE, + braidingHom_evenMap_tmulEE, braidingHom_evenMap_tmulOO, + braidingHom_oddMap_tmulEO, braidingHom_oddMap_tmulOE, + id_evenMap, id_oddMap, LinearMap.id_coe, id_eq, map_neg] + +/-- The braiding is natural in its left-hand argument. -/ +theorem braidingHom_naturality_left {X Y : S.Mod.{u, u, u, u}} + (f : X ⟶ Y) (Z : S.Mod.{u, u, u, u}) : + tensorHom f (𝟙 Z) ≫ braidingHom Y Z + = braidingHom X Z ≫ tensorHom (𝟙 Z) f := by + refine hom_ext (fun m n => ?_) (fun m n => ?_) (fun m n => ?_) + (fun m n => ?_) <;> + simp only [comp_evenMap, comp_oddMap, LinearMap.comp_apply, + tensorHom_evenMap_tmulEE, tensorHom_evenMap_tmulOO, + tensorHom_oddMap_tmulEO, tensorHom_oddMap_tmulOE, + braidingHom_evenMap_tmulEE, braidingHom_evenMap_tmulOO, + braidingHom_oddMap_tmulEO, braidingHom_oddMap_tmulOE, + id_evenMap, id_oddMap, LinearMap.id_coe, id_eq, map_neg] + +/-- **The first hexagon identity.** -/ +theorem hexagon_forward_identity (X Y Z : S.Mod.{u, u, u, u}) : + assocHom X Y Z ≫ braidingHom X (Y.tensor Z) ≫ assocHom Y Z X + = tensorHom (braidingHom X Y) (𝟙 Z) ≫ assocHom Y X Z + ≫ tensorHom (𝟙 Y) (braidingHom X Z) := by + refine hom_ext₃ (fun m n p => ?_) (fun m n p => ?_) + (fun m n p => ?_) (fun m n p => ?_) (fun m n p => ?_) + (fun m n p => ?_) (fun m n p => ?_) (fun m n p => ?_) <;> + simp only [comp_evenMap, comp_oddMap, LinearMap.comp_apply, + tensorHom_evenMap_tmulEE, tensorHom_evenMap_tmulOO, + tensorHom_oddMap_tmulEO, tensorHom_oddMap_tmulOE, + braidingHom_evenMap_tmulEE, braidingHom_evenMap_tmulOO, + braidingHom_oddMap_tmulEO, braidingHom_oddMap_tmulOE, + assocHom_evenMap_tmulEE, assocHom_evenMap_tmulOO, + assocHom_oddMap_tmulEO, assocHom_oddMap_tmulOE, + assocFee_tmulEE, assocFee_tmulOO, assocFoo_tmulEO, + assocFoo_tmulOE, assocFeo_tmulEE, assocFeo_tmulOO, + assocFoe_tmulEO, assocFoe_tmulOE, id_evenMap, id_oddMap, + LinearMap.id_coe, id_eq, map_neg, LinearMap.neg_apply, + neg_neg] + +/-- **The second hexagon identity.** -/ +theorem hexagon_reverse_identity (X Y Z : S.Mod.{u, u, u, u}) : + assocInv X Y Z ≫ braidingHom (X.tensor Y) Z ≫ assocInv Z X Y + = tensorHom (𝟙 X) (braidingHom Y Z) ≫ assocInv X Z Y + ≫ tensorHom (braidingHom X Z) (𝟙 Y) := by + refine hom_ext₃' (fun m n p => ?_) (fun m n p => ?_) + (fun m n p => ?_) (fun m n p => ?_) (fun m n p => ?_) + (fun m n p => ?_) (fun m n p => ?_) (fun m n p => ?_) <;> + simp only [comp_evenMap, comp_oddMap, LinearMap.comp_apply, + tensorHom_evenMap_tmulEE, tensorHom_evenMap_tmulOO, + tensorHom_oddMap_tmulEO, tensorHom_oddMap_tmulOE, + braidingHom_evenMap_tmulEE, braidingHom_evenMap_tmulOO, + braidingHom_oddMap_tmulEO, braidingHom_oddMap_tmulOE, + assocInv_evenMap_tmulEE, assocInv_evenMap_tmulOO, + assocInv_oddMap_tmulEO, assocInv_oddMap_tmulOE, + assocInvFee_tmulEE, assocInvFee_tmulOO, assocInvFoo_tmulEO, + assocInvFoo_tmulOE, assocInvFeo_tmulEO, assocInvFeo_tmulOE, + assocInvFoe_tmulEE, assocInvFoe_tmulOO, id_evenMap, + id_oddMap, LinearMap.id_coe, id_eq, map_neg, + LinearMap.neg_apply, neg_neg] + +/-- **Super modules over a super-commutative ℂ-algebra form a +symmetric monoidal category**, the braiding being the Koszul +swap. -/ +noncomputable instance instSymmetricCategory : + SymmetricCategory S.Mod.{u, u, u, u} where + braiding M N := Mod.braiding M N + braiding_naturality_right := fun X {_ _} f => + braidingHom_naturality_right X f + braiding_naturality_left := fun {_ _} f Z => + braidingHom_naturality_left f Z + hexagon_forward X Y Z := hexagon_forward_identity X Y Z + hexagon_reverse X Y Z := hexagon_reverse_identity X Y Z + symmetry M N := braidingHom_braidingHom M N + +end Symmetry + +end SuperCommAlgebra.Mod + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShift.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShift.lean new file mode 100644 index 0000000000..dd9ca07acb --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShift.lean @@ -0,0 +1,61 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModule + +/-! +# The parity shift of a super module + +Exchanging the two components of a super module and relabelling +the four action blocks accordingly again gives a super module: +the module parity is only a label, so the eight associativities +permute among themselves and no sign appears. This is the module +underlying a twist by the odd line. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +universe u u' + +namespace SuperCommAlgebra.Mod + +variable {S : SuperCommAlgebra.{u, u'}} + +/-- **The parity shift** of a super module. -/ +def shift (M : S.Mod) : S.Mod where + even := M.odd + odd := M.even + actEE := M.actEO + actEO := M.actEE + actOE := M.actOO + actOO := M.actOE + one_act_e := M.one_act_o + one_act_o := M.one_act_e + assoc_eee := M.assoc_eeo + assoc_eeo := M.assoc_eee + assoc_eoe := M.assoc_eoo + assoc_eoo := M.assoc_eoe + assoc_oee := M.assoc_oeo + assoc_oeo := M.assoc_oee + assoc_ooe := M.assoc_ooo + assoc_ooo := M.assoc_ooe + +/-- The even component of the shift is the odd component. This is +definitional, and is stated for use by name: as a `simp` rule it +would rewrite the type arguments of every application of the +shifted module's interface and so stop that interface firing. -/ +theorem shift_even (M : S.Mod) : (shift M).even = M.odd := + rfl + +end SuperCommAlgebra.Mod + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShiftUnit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShiftUnit.lean new file mode 100644 index 0000000000..9184e5ed15 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShiftUnit.lean @@ -0,0 +1,251 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModMonoidal +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShift + +/-! +# Tensoring with the shifted unit is the parity shift + +For a super-commutative ℂ-algebra `S` and a module `M` over it, +the parity shift of the unit module is invertible for the tensor +product of `RS.Classical.Deligne.SuperModTensor`: + + `(shift S.unitMod) ⊗ M ≅ shift M`. + +The construction is the exact analogue of the left unitor of +`RS.Classical.Deligne.SuperModMonoidal`, with the parity of the +algebra factor reversed. Reversing that parity forces two of the +four blocks to carry a sign: the shifted unit relabels the four +multiplication blocks of `S`, and the eight balancing laws of the +tensor product then hold only for the block pattern + + `fee = M.actOE`, `foo = -M.actEO`, + `feo = -M.actOO`, `foe = M.actEE`, + +whose relative signs are pinned by the odd-odd relators (where the +Koszul sign lives) and by the odd action laws; the overall sign is +the one free choice, normalised here by taking the even-even block +unsigned. The inverse carries the matching sign, `−1` in even +degree and `+1` in odd degree. + +## Contents + +* `RS.SuperCommAlgebra.Mod.shiftUnitMod_actOO_one`, + `shiftUnitMod_actEO_one`: acting on the algebra unit inside the + shifted unit module returns the scalar. +* `RS.SuperCommAlgebra.Mod.shiftUnitData`: the four blocks with + their eight balancing laws and eight action laws. +* `RS.SuperCommAlgebra.Mod.shiftUnitHom`, `shiftUnitInv`: the two + structure maps, with their computation rules. +* `RS.SuperCommAlgebra.Mod.shiftUnitTensor`: the isomorphism. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe u + +namespace SuperCommAlgebra.Mod + +variable {S : SuperCommAlgebra.{u, u}} + +/-! ## The shifted unit module -/ + +/-- Acting by an odd scalar on the algebra unit, viewed inside the +shifted unit module, returns the scalar. In the shifted module +the algebra unit is odd, so the relevant block is `actOO`. -/ +theorem shiftUnitMod_actOO_one (v : S.odd) : + (shift S.unitMod).actOO v S.one = v := + unitMod_actOE_one v + +/-- Acting by an even scalar on the algebra unit, viewed inside +the shifted unit module, returns the scalar. -/ +theorem shiftUnitMod_actEO_one (x : S.even) : + (shift S.unitMod).actEO x S.one = x := + unitMod_actEE_one x + +/-! ## The four blocks -/ + +section ShiftUnit + +variable (M : S.Mod.{u, u, u, u}) + +/-- The data of the shift-unit isomorphism: the shifted unit +factor acts on the module, with the parities of the algebra +relabelled. The odd-odd and even-odd blocks carry a sign, forced +by the four mixed balancing laws and by the four odd action +laws. -/ +def shiftUnitData : TensorData (shift S.unitMod) M (shift M) where + fee := M.actOE + foo := -M.actEO + feo := -M.actOO + foe := M.actEE + hee := fun b m n => by + change M.actOE (S.mulEO b m) n = M.actOE m (M.actEE b n) + erw [← M.assoc_oee, ← S.comm_eo] + hoo := fun b m n => by + change -M.actEO (S.mulEE b m) n = -M.actEO m (M.actEO b n) + erw [M.assoc_eeo, M.actEO_actEO_comm] + hoeo := fun c m n => by + change -M.actEO (S.mulOO c m) n = M.actOE m (M.actOO c n) + erw [M.assoc_ooo, M.actOE_actOO_neg, neg_neg] + hooe := fun c m n => by + change M.actOE (S.mulOE c m) n + = -(-(M.actEO m (M.actOE c n))) + erw [neg_neg, M.assoc_oee, M.actEO_actOE] + heeo := fun b m n => by + change -M.actOO (S.mulEO b m) n = -M.actOO m (M.actEO b n) + erw [M.assoc_eoo, M.actEE_actOO] + heoe := fun b m n => by + change M.actEE (S.mulEE b m) n = M.actEE m (M.actEE b n) + erw [M.assoc_eee, M.actEE_actEE_comm] + hoee := fun c m n => by + change M.actEE (S.mulOO c m) n = -(M.actOO m (M.actOE c n)) + erw [M.assoc_ooe, M.actOO_actOE_neg] + hooo := fun c m n => by + change -M.actOO (S.mulOE c m) n = -(M.actEE m (M.actOO c n)) + erw [M.assoc_oeo, M.actEE_actOO] + aee := fun a m n => M.assoc_eoe a m n + aoo := fun a m n => by + change -M.actEO (S.mulEE a m) n = M.actEO a (-(M.actEO m n)) + erw [M.assoc_eeo, map_neg] + aeo := fun a m n => by + change -M.actOO (S.mulEO a m) n = M.actEE a (-(M.actOO m n)) + erw [M.assoc_eoo, map_neg] + aoe := fun a m n => M.assoc_eee a m n + cee := fun c m n => M.assoc_ooe c m n + coo := fun c m n => by + change -M.actOO (S.mulOE c m) n = M.actOO c (-(M.actEO m n)) + erw [M.assoc_oeo, map_neg] + ceo := fun c m n => by + change -M.actEO (S.mulOO c m) n = M.actOE c (-(M.actOO m n)) + erw [M.assoc_ooo, map_neg] + coe := fun c m n => M.assoc_oee c m n + +/-! ## The structure maps -/ + +/-- The structure map of the shift-unit isomorphism. -/ +noncomputable def shiftUnitHom : + (shift S.unitMod).tensor M ⟶ shift M := + mkHom (shiftUnitData M) + +/-- The structure map on an even-even generator. -/ +@[simp] theorem shiftUnitHom_evenMap_tmulEE (v : S.odd) (m : M.even) : + (shiftUnitHom M).evenMap (tmulEE (shift S.unitMod) M v m) + = M.actOE v m := + mkHom_evenMap_tmulEE (shiftUnitData M) v m + +/-- The structure map on an odd-odd generator. -/ +@[simp] theorem shiftUnitHom_evenMap_tmulOO (x : S.even) (m : M.odd) : + (shiftUnitHom M).evenMap (tmulOO (shift S.unitMod) M x m) + = -M.actEO x m := + mkHom_evenMap_tmulOO (shiftUnitData M) x m + +/-- The structure map on an even-odd generator. -/ +@[simp] theorem shiftUnitHom_oddMap_tmulEO (v : S.odd) (m : M.odd) : + (shiftUnitHom M).oddMap (tmulEO (shift S.unitMod) M v m) + = -M.actOO v m := + mkHom_oddMap_tmulEO (shiftUnitData M) v m + +/-- The structure map on an odd-even generator. -/ +@[simp] theorem shiftUnitHom_oddMap_tmulOE (x : S.even) (m : M.even) : + (shiftUnitHom M).oddMap (tmulOE (shift S.unitMod) M x m) + = M.actEE x m := + mkHom_oddMap_tmulOE (shiftUnitData M) x m + +/-- The inverse of the shift-unit isomorphism: tensor with the +algebra unit, which is odd in the shifted unit module. The even +component carries a sign, forced by the odd-odd Koszul relator. -/ +noncomputable def shiftUnitInv : + shift M ⟶ (shift S.unitMod).tensor M where + evenMap := -tmulOO (shift S.unitMod) M S.one + oddMap := tmulOE (shift S.unitMod) M S.one + map_actEE x m := by + change -(tmulOO (shift S.unitMod) M S.one (M.actEO x m)) + = ((shift S.unitMod).tensor M).actEE x + (-(tmulOO (shift S.unitMod) M S.one m)) + erw [map_neg, actEE_tmulOO, tmulOO_balanced_eoo] + map_actEO x m := by + change tmulOE (shift S.unitMod) M S.one (M.actEE x m) + = ((shift S.unitMod).tensor M).actEO x + (tmulOE (shift S.unitMod) M S.one m) + exact ((actEO_tmulOE (shift S.unitMod) M x S.one m).trans + (tmulOE_balanced_eoe (shift S.unitMod) M x S.one m)).symm + map_actOE v m := by + change tmulOE (shift S.unitMod) M S.one (M.actOO v m) + = ((shift S.unitMod).tensor M).actOE v + (-(tmulOO (shift S.unitMod) M S.one m)) + rw [map_neg] + erw [actOE_tmulOO (shift S.unitMod) M v S.one m] + simpa only [neg_neg] using + (congrArg Neg.neg (tmulEO_balanced_ooo (shift S.unitMod) M v S.one m)).symm + map_actOO v m := by + change -(tmulOO (shift S.unitMod) M S.one (M.actOE v m)) + = ((shift S.unitMod).tensor M).actOO v + (tmulOE (shift S.unitMod) M S.one m) + erw [actOO_tmulOE, tmulEE_balanced_ooe] + +/-- The inverse in even degree. -/ +@[simp] theorem shiftUnitInv_evenMap (m : M.odd) : + (shiftUnitInv M).evenMap m + = -tmulOO (shift S.unitMod) M S.one m := rfl + +/-- The inverse in odd degree. -/ +@[simp] theorem shiftUnitInv_oddMap (m : M.even) : + (shiftUnitInv M).oddMap m + = tmulOE (shift S.unitMod) M S.one m := rfl + +/-! ## The isomorphism -/ + +/-- **The parity shift of the unit is invertible**: tensoring with +the shifted unit module shifts the parity. -/ +noncomputable def shiftUnitTensor : + (shift S.unitMod).tensor M ≅ shift M where + hom := shiftUnitHom M + inv := shiftUnitInv M + hom_inv_id := by + refine hom_ext (fun (v : S.odd) m => ?_) + (fun (x : S.even) m => ?_) (fun (v : S.odd) m => ?_) + (fun (x : S.even) m => ?_) + · erw [comp_evenMap, LinearMap.comp_apply, + shiftUnitHom_evenMap_tmulEE, shiftUnitInv_evenMap, + id_evenMap, LinearMap.id_coe, id_eq, + ← tmulEE_balanced_ooe, shiftUnitMod_actOO_one] + · erw [comp_evenMap, LinearMap.comp_apply, + shiftUnitHom_evenMap_tmulOO, shiftUnitInv_evenMap, map_neg, + neg_neg, id_evenMap, LinearMap.id_coe, id_eq, + ← tmulOO_balanced_eoo, shiftUnitMod_actEO_one] + · erw [comp_oddMap, LinearMap.comp_apply, + shiftUnitHom_oddMap_tmulEO, shiftUnitInv_oddMap, map_neg, + id_oddMap, LinearMap.id_coe, id_eq, + ← tmulEO_balanced_ooo, shiftUnitMod_actOO_one] + · erw [comp_oddMap, LinearMap.comp_apply, + shiftUnitHom_oddMap_tmulOE, shiftUnitInv_oddMap, + id_oddMap, LinearMap.id_coe, id_eq, + ← tmulOE_balanced_eoe, shiftUnitMod_actEO_one] + inv_hom_id := by + refine Hom.ext (LinearMap.ext fun m => ?_) + (LinearMap.ext fun m => ?_) + · change (shiftUnitHom M).evenMap + (-(tmulOO (shift S.unitMod) M S.one m)) = m + refine Eq.trans (map_neg _ _) ?_ + refine Eq.trans (congrArg Neg.neg + (shiftUnitHom_evenMap_tmulOO M S.one m)) ?_ + exact Eq.trans (neg_neg _) (M.one_act_o m) + · exact Eq.trans (shiftUnitHom_oddMap_tmulOE M S.one m) + (M.one_act_e m) + +end ShiftUnit + +end SuperCommAlgebra.Mod + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModTensor.lean new file mode 100644 index 0000000000..7f5f72687d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModTensor.lean @@ -0,0 +1,1145 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModule + +/-! +# The tensor product of two super modules + +For a super-commutative ℂ-algebra `S` and two modules `M`, `N` over +it (`RS.SuperCommAlgebra.Mod`) this file builds the tensor product +`M ⊗_S N` as another `S`-module, together with the canonical +balanced map into it and its universal property. + +The underlying ℤ/2-graded ℂ-space is the graded tensor product of +`RS.SuperVect.tensorObj`: the even part of `M ⊗_ℂ N` is +`(M₀ ⊗ N₀) × (M₁ ⊗ N₁)` and the odd part is `(M₀ ⊗ N₁) × (M₁ ⊗ N₀)`, +where `M₀ = M.even` and `M₁ = M.odd`. Balancing over `S` is +imposed by quotienting each degree by the span of the relators +listed below. + +## The sign convention + +A left module over a super-commutative algebra is a right module +under `m · a = (−1)^{|a||m|} a · m`, and the balancing relation of +the tensor product is `(m · a) ⊗ n = m ⊗ (a · n)`. Written with +left actions throughout, the relator at homogeneous `a`, `m`, `n` +is + + `(a · m) ⊗ n − (−1)^{|a||m|} m ⊗ (a · n)`, + +so the only sign is a `−1` when *both* the scalar and the left +argument are odd; the parity of `n` never enters. The eight +relator families are `relEvenXYZ` in total degree +`|a| + |m| + |n| = 0` and `relOddXYZ` in total degree `1`, four +each, indexed by the parity pattern `(|a|, |m|, |n|)`. + +The `S`-action on the quotient is the action on the *left* factor, +with no sign: `a · (m ⊗ n) = (a · m) ⊗ n`. It descends because +`a · ((b · m) ⊗ n − (−1)^{|b||m|} m ⊗ (b · n))` is `(−1)^{|a||b|}` +times the relator of `b` at `(a · m, n)`; this is the one place +where the super-commutativity of `S` is used, and it is the reason +the construction needs a *commutative* base. + +## Contents + +* `RS.SuperCommAlgebra.Mod.actEE_actEE_comm` and its five + companions: an even scalar commutes with every scalar, and two + odd scalars anticommute, in their action on a module. +* `RS.tensorLeftDiag`, `RS.tensorLeftSwap`: the two shapes of a + parity block acting on the left factor of a two-summand graded + tensor product, degree-preserving and degree-reversing. +* `RS.descendAct`: descent of a bilinear action along a pair of + quotients. +* `RS.SuperCommAlgebra.Mod.balEven`, `balOdd`: the balancing + submodules, and `preActEE`, `preActEO`, `preActOE`, `preActOO`: + the four action blocks before quotienting, with the ten module + laws proved at that level. +* `RS.SuperCommAlgebra.Mod.tensor`: the tensor product as an + `S`-module. +* `RS.SuperCommAlgebra.Mod.tmulEE`, `tmulEO`, `tmulOE`, `tmulOO`: + the canonical map, with its eight balancing laws and its eight + action laws. +* `RS.SuperCommAlgebra.Mod.liftEven`, `liftOdd` and + `liftEven_unique`, `liftOdd_unique`: the universal property, + packaged as `exists_unique_liftEven` and `exists_unique_liftOdd`. +-/ + +@[expose] public section + +namespace RS + +open scoped TensorProduct + +universe u u' v w w' + +/-! ## Parity blocks acting on the left factor -/ + +section GradedBlocks + +variable (P Q : Type*) + +/-- A pair of parity blocks acting on the *left* factor of a +two-summand graded tensor product, in the degree-preserving +pattern: each summand stays where it is. -/ +noncomputable def tensorLeftDiag + [AddCommGroup P] [Module ℂ P] [AddCommGroup Q] [Module ℂ Q] {A : Type*} + {X₁ : Type*} {X₂ : Type*} {Y₁ : Type*} {Y₂ : Type*} [AddCommGroup A] + [Module ℂ A] [AddCommGroup X₁] [Module ℂ X₁] [AddCommGroup X₂] + [Module ℂ X₂] [AddCommGroup Y₁] [Module ℂ Y₁] [AddCommGroup Y₂] + [Module ℂ Y₂] + (f : A →ₗ[ℂ] X₁ →ₗ[ℂ] X₂) + (g : A →ₗ[ℂ] Y₁ →ₗ[ℂ] Y₂) : + A →ₗ[ℂ] (X₁ ⊗[ℂ] P) × (Y₁ ⊗[ℂ] Q) →ₗ[ℂ] + (X₂ ⊗[ℂ] P) × (Y₂ ⊗[ℂ] Q) where + toFun a := ((f a).rTensor P).prodMap ((g a).rTensor Q) + map_add' a b := by + rw [map_add, map_add, LinearMap.rTensor_add, + LinearMap.rTensor_add, LinearMap.prodMap_add] + map_smul' r a := by + rw [RingHom.id_apply, map_smul, map_smul, LinearMap.rTensor_smul, + LinearMap.rTensor_smul, LinearMap.prodMap_smul] + +/-- The degree-preserving block pattern, evaluated. -/ +@[simp] +theorem tensorLeftDiag_apply + [AddCommGroup P] [Module ℂ P] [AddCommGroup Q] [Module ℂ Q] {A : Type*} + {X₁ : Type*} {X₂ : Type*} {Y₁ : Type*} {Y₂ : Type*} [AddCommGroup A] + [Module ℂ A] [AddCommGroup X₁] [Module ℂ X₁] [AddCommGroup X₂] + [Module ℂ X₂] [AddCommGroup Y₁] [Module ℂ Y₁] [AddCommGroup Y₂] + [Module ℂ Y₂] + (f : A →ₗ[ℂ] X₁ →ₗ[ℂ] X₂) + (g : A →ₗ[ℂ] Y₁ →ₗ[ℂ] Y₂) (a : A) + (t : (X₁ ⊗[ℂ] P) × (Y₁ ⊗[ℂ] Q)) : + tensorLeftDiag P Q f g a t = + ((f a).rTensor P t.1, (g a).rTensor Q t.2) := rfl + +/-- A pair of parity blocks acting on the *left* factor of a +two-summand graded tensor product, in the degree-reversing +pattern: the two summands are interchanged. -/ +noncomputable def tensorLeftSwap + [AddCommGroup P] [Module ℂ P] [AddCommGroup Q] [Module ℂ Q] {A : Type*} + {X₁ : Type*} {X₂ : Type*} {Y₁ : Type*} {Y₂ : Type*} [AddCommGroup A] + [Module ℂ A] [AddCommGroup X₁] [Module ℂ X₁] [AddCommGroup X₂] + [Module ℂ X₂] [AddCommGroup Y₁] [Module ℂ Y₁] [AddCommGroup Y₂] + [Module ℂ Y₂] + (f : A →ₗ[ℂ] X₁ →ₗ[ℂ] X₂) + (g : A →ₗ[ℂ] Y₁ →ₗ[ℂ] Y₂) : + A →ₗ[ℂ] (X₁ ⊗[ℂ] P) × (Y₁ ⊗[ℂ] Q) →ₗ[ℂ] + (Y₂ ⊗[ℂ] Q) × (X₂ ⊗[ℂ] P) where + toFun a := (tensorLeftDiag Q P g f a).comp + (LinearEquiv.prodComm ℂ (X₁ ⊗[ℂ] P) (Y₁ ⊗[ℂ] Q)).toLinearMap + map_add' a b := by rw [map_add, LinearMap.add_comp] + map_smul' r a := by + rw [RingHom.id_apply, map_smul, LinearMap.smul_comp] + +/-- The degree-reversing block pattern, evaluated. -/ +@[simp] +theorem tensorLeftSwap_apply + [AddCommGroup P] [Module ℂ P] [AddCommGroup Q] [Module ℂ Q] {A : Type*} + {X₁ : Type*} {X₂ : Type*} {Y₁ : Type*} {Y₂ : Type*} [AddCommGroup A] + [Module ℂ A] [AddCommGroup X₁] [Module ℂ X₁] [AddCommGroup X₂] + [Module ℂ X₂] [AddCommGroup Y₁] [Module ℂ Y₁] [AddCommGroup Y₂] + [Module ℂ Y₂] + (f : A →ₗ[ℂ] X₁ →ₗ[ℂ] X₂) + (g : A →ₗ[ℂ] Y₁ →ₗ[ℂ] Y₂) (a : A) + (t : (X₁ ⊗[ℂ] P) × (Y₁ ⊗[ℂ] Q)) : + tensorLeftSwap P Q f g a t = + ((g a).rTensor Q t.2, (f a).rTensor P t.1) := rfl + +end GradedBlocks + +/-! ## Descent of an action along a quotient -/ + +section Descend + +variable {A T T' : Type*} + +/-- Descend a bilinear action along a pair of quotients: a +bilinear action of `A` carrying a submodule `R` of its source into +a submodule `R'` of its target induces an action on the +quotients. -/ +noncomputable def descendAct + [AddCommGroup A] [Module ℂ A] [AddCommGroup T] [Module ℂ T] + [AddCommGroup T'] [Module ℂ T'] + (R : Submodule ℂ T) (R' : Submodule ℂ T') + (f : A →ₗ[ℂ] T →ₗ[ℂ] T') + (h : ∀ a : A, ∀ t ∈ R, f a t ∈ R') : + A →ₗ[ℂ] (T ⧸ R) →ₗ[ℂ] (T' ⧸ R') := + (R.liftQ (LinearMap.flip (f.compr₂ R'.mkQ)) (by + intro t ht + rw [LinearMap.mem_ker] + exact LinearMap.ext fun a => + (Submodule.Quotient.mk_eq_zero R').mpr (h a t ht))).flip + +/-- The descended action, evaluated on a class. -/ +@[simp] +theorem descendAct_apply + [AddCommGroup A] [Module ℂ A] [AddCommGroup T] [Module ℂ T] + [AddCommGroup T'] [Module ℂ T'] + (R : Submodule ℂ T) (R' : Submodule ℂ T') + (f : A →ₗ[ℂ] T →ₗ[ℂ] T') (h : ∀ a : A, ∀ t ∈ R, f a t ∈ R') + (a : A) (t : T) : + descendAct R R' f h a (Submodule.Quotient.mk t) = + Submodule.Quotient.mk (f a t) := rfl + +end Descend + +namespace SuperCommAlgebra.Mod + +/-! ## Commutation of the action blocks -/ + +section Commutation + +variable {S : SuperCommAlgebra.{u, u'}} (M : S.Mod.{u, u', w, w'}) + +/-- Two even scalars commute on the even component. -/ +theorem actEE_actEE_comm (a b : S.even) (m : M.even) : + M.actEE a (M.actEE b m) = M.actEE b (M.actEE a m) := by + rw [← M.assoc_eee, S.comm_ee, M.assoc_eee] + +/-- Two even scalars commute on the odd component. -/ +theorem actEO_actEO_comm (a b : S.even) (m : M.odd) : + M.actEO a (M.actEO b m) = M.actEO b (M.actEO a m) := by + rw [← M.assoc_eeo, S.comm_ee, M.assoc_eeo] + +/-- An even scalar commutes with an odd one, on the even +component. -/ +theorem actEO_actOE (a : S.even) (c : S.odd) (m : M.even) : + M.actEO a (M.actOE c m) = M.actOE c (M.actEE a m) := by + rw [← M.assoc_eoe, S.comm_eo, M.assoc_oee] + +/-- An even scalar commutes with an odd one, on the odd +component. -/ +theorem actEE_actOO (a : S.even) (c : S.odd) (m : M.odd) : + M.actEE a (M.actOO c m) = M.actOO c (M.actEO a m) := by + rw [← M.assoc_eoo, S.comm_eo, M.assoc_oeo] + +/-- Two odd scalars anticommute, on the even component. -/ +theorem actOO_actOE_neg (c d : S.odd) (m : M.even) : + M.actOO c (M.actOE d m) = -M.actOO d (M.actOE c m) := by + rw [← M.assoc_ooe, S.comm_oo, map_neg, LinearMap.neg_apply, + M.assoc_ooe] + +/-- Two odd scalars anticommute, on the odd component. -/ +theorem actOE_actOO_neg (c d : S.odd) (m : M.odd) : + M.actOE c (M.actOO d m) = -M.actOE d (M.actOO c m) := by + rw [← M.assoc_ooo, S.comm_oo, map_neg, LinearMap.neg_apply, + M.assoc_ooo] + +end Commutation + +/-! ## The graded tensor product over ℂ -/ + +section Tensor + +variable {S : SuperCommAlgebra.{u, u'}} (M N : S.Mod.{u, u', w, w'}) + +/-- The even component of the graded ℂ-tensor product of the +underlying super spaces. -/ +abbrev tenEven : Type max w w' := + (M.even ⊗[ℂ] N.even) × (M.odd ⊗[ℂ] N.odd) + +/-- The odd component of the graded ℂ-tensor product of the +underlying super spaces. -/ +abbrev tenOdd : Type max w w' := + (M.even ⊗[ℂ] N.odd) × (M.odd ⊗[ℂ] N.even) + +/-! ### The balancing relators -/ + +/-- The even-degree relator at parity pattern even-even-even. -/ +def relEvenEEE (b : S.even) (m : M.even) (n : N.even) : + tenEven M N := + (M.actEE b m ⊗ₜ[ℂ] n - m ⊗ₜ[ℂ] N.actEE b n, 0) + +/-- The even-degree relator at parity pattern even-odd-odd. -/ +def relEvenEOO (b : S.even) (m : M.odd) (n : N.odd) : + tenEven M N := + (0, M.actEO b m ⊗ₜ[ℂ] n - m ⊗ₜ[ℂ] N.actEO b n) + +/-- The even-degree relator at parity pattern odd-even-odd. The +scalar is odd and the left argument even, so the Koszul sign is +`+1`. -/ +def relEvenOEO (c : S.odd) (m : M.even) (n : N.odd) : + tenEven M N := + (-(m ⊗ₜ[ℂ] N.actOO c n), M.actOE c m ⊗ₜ[ℂ] n) + +/-- The even-degree relator at parity pattern odd-odd-even. Both +the scalar and the left argument are odd, so the Koszul sign is +`−1` and the two terms are added. -/ +def relEvenOOE (c : S.odd) (m : M.odd) (n : N.even) : + tenEven M N := + (M.actOO c m ⊗ₜ[ℂ] n, m ⊗ₜ[ℂ] N.actOE c n) + +/-- The odd-degree relator at parity pattern even-even-odd. -/ +def relOddEEO (b : S.even) (m : M.even) (n : N.odd) : + tenOdd M N := + (M.actEE b m ⊗ₜ[ℂ] n - m ⊗ₜ[ℂ] N.actEO b n, 0) + +/-- The odd-degree relator at parity pattern even-odd-even. -/ +def relOddEOE (b : S.even) (m : M.odd) (n : N.even) : + tenOdd M N := + (0, M.actEO b m ⊗ₜ[ℂ] n - m ⊗ₜ[ℂ] N.actEE b n) + +/-- The odd-degree relator at parity pattern odd-even-even. The +Koszul sign is `+1`. -/ +def relOddOEE (c : S.odd) (m : M.even) (n : N.even) : + tenOdd M N := + (-(m ⊗ₜ[ℂ] N.actOE c n), M.actOE c m ⊗ₜ[ℂ] n) + +/-- The odd-degree relator at parity pattern odd-odd-odd. The +Koszul sign is `−1`. -/ +def relOddOOO (c : S.odd) (m : M.odd) (n : N.odd) : + tenOdd M N := + (M.actOO c m ⊗ₜ[ℂ] n, m ⊗ₜ[ℂ] N.actOO c n) + +/-- The balancing submodule in even degree: the span of the four +even-degree relator families. -/ +def balEven : Submodule ℂ (tenEven M N) := + Submodule.span ℂ + ({t | ∃ b m n, t = relEvenEEE M N b m n} ∪ + {t | ∃ b m n, t = relEvenEOO M N b m n} ∪ + {t | ∃ c m n, t = relEvenOEO M N c m n} ∪ + {t | ∃ c m n, t = relEvenOOE M N c m n}) + +/-- The balancing submodule in odd degree: the span of the four +odd-degree relator families. -/ +def balOdd : Submodule ℂ (tenOdd M N) := + Submodule.span ℂ + ({t | ∃ b m n, t = relOddEEO M N b m n} ∪ + {t | ∃ b m n, t = relOddEOE M N b m n} ∪ + {t | ∃ c m n, t = relOddOEE M N c m n} ∪ + {t | ∃ c m n, t = relOddOOO M N c m n}) + +/-- The even-even-even relators are balanced. -/ +theorem relEvenEEE_mem (b : S.even) (m : M.even) (n : N.even) : + relEvenEEE M N b m n ∈ balEven M N := + Submodule.subset_span (Or.inl (Or.inl (Or.inl ⟨b, m, n, rfl⟩))) + +/-- The even-odd-odd relators are balanced. -/ +theorem relEvenEOO_mem (b : S.even) (m : M.odd) (n : N.odd) : + relEvenEOO M N b m n ∈ balEven M N := + Submodule.subset_span (Or.inl (Or.inl (Or.inr ⟨b, m, n, rfl⟩))) + +/-- The odd-even-odd relators are balanced. -/ +theorem relEvenOEO_mem (c : S.odd) (m : M.even) (n : N.odd) : + relEvenOEO M N c m n ∈ balEven M N := + Submodule.subset_span (Or.inl (Or.inr ⟨c, m, n, rfl⟩)) + +/-- The odd-odd-even relators are balanced. -/ +theorem relEvenOOE_mem (c : S.odd) (m : M.odd) (n : N.even) : + relEvenOOE M N c m n ∈ balEven M N := + Submodule.subset_span (Or.inr ⟨c, m, n, rfl⟩) + +/-- The even-even-odd relators are balanced. -/ +theorem relOddEEO_mem (b : S.even) (m : M.even) (n : N.odd) : + relOddEEO M N b m n ∈ balOdd M N := + Submodule.subset_span (Or.inl (Or.inl (Or.inl ⟨b, m, n, rfl⟩))) + +/-- The even-odd-even relators are balanced. -/ +theorem relOddEOE_mem (b : S.even) (m : M.odd) (n : N.even) : + relOddEOE M N b m n ∈ balOdd M N := + Submodule.subset_span (Or.inl (Or.inl (Or.inr ⟨b, m, n, rfl⟩))) + +/-- The odd-even-even relators are balanced. -/ +theorem relOddOEE_mem (c : S.odd) (m : M.even) (n : N.even) : + relOddOEE M N c m n ∈ balOdd M N := + Submodule.subset_span (Or.inl (Or.inr ⟨c, m, n, rfl⟩)) + +/-- The odd-odd-odd relators are balanced. -/ +theorem relOddOOO_mem (c : S.odd) (m : M.odd) (n : N.odd) : + relOddOOO M N c m n ∈ balOdd M N := + Submodule.subset_span (Or.inr ⟨c, m, n, rfl⟩) + +/-- The negated odd-even-odd relators, in expanded form. -/ +theorem relEvenOEO_neg_mem (c : S.odd) (m : M.even) (n : N.odd) : + ((m ⊗ₜ[ℂ] N.actOO c n, -(M.actOE c m ⊗ₜ[ℂ] n)) : tenEven M N) + ∈ balEven M N := by + have h := neg_mem (relEvenOEO_mem M N c m n) + simpa [relEvenOEO] using h + +/-- The negated odd-odd-even relators, in expanded form. -/ +theorem relEvenOOE_neg_mem (c : S.odd) (m : M.odd) (n : N.even) : + ((-(M.actOO c m ⊗ₜ[ℂ] n), -(m ⊗ₜ[ℂ] N.actOE c n)) : + tenEven M N) ∈ balEven M N := by + have h := neg_mem (relEvenOOE_mem M N c m n) + simpa [relEvenOOE] using h + +/-- The negated odd-even-even relators, in expanded form. -/ +theorem relOddOEE_neg_mem (c : S.odd) (m : M.even) (n : N.even) : + ((m ⊗ₜ[ℂ] N.actOE c n, -(M.actOE c m ⊗ₜ[ℂ] n)) : tenOdd M N) + ∈ balOdd M N := by + have h := neg_mem (relOddOEE_mem M N c m n) + simpa [relOddOEE] using h + +/-- The negated odd-odd-odd relators, in expanded form. -/ +theorem relOddOOO_neg_mem (c : S.odd) (m : M.odd) (n : N.odd) : + ((-(M.actOO c m ⊗ₜ[ℂ] n), -(m ⊗ₜ[ℂ] N.actOO c n)) : + tenOdd M N) ∈ balOdd M N := by + have h := neg_mem (relOddOOO_mem M N c m n) + simpa [relOddOOO] using h + +/-! ### The four action blocks before quotienting -/ + +/-- An even scalar acting on the left factor of the even part. -/ +noncomputable def preActEE : + S.even →ₗ[ℂ] tenEven M N →ₗ[ℂ] tenEven M N := + tensorLeftDiag N.even N.odd M.actEE M.actEO + +/-- An even scalar acting on the left factor of the odd part. -/ +noncomputable def preActEO : + S.even →ₗ[ℂ] tenOdd M N →ₗ[ℂ] tenOdd M N := + tensorLeftDiag N.odd N.even M.actEE M.actEO + +/-- An odd scalar acting on the left factor of the even part. -/ +noncomputable def preActOE : + S.odd →ₗ[ℂ] tenEven M N →ₗ[ℂ] tenOdd M N := + tensorLeftSwap N.even N.odd M.actOE M.actOO + +/-- An odd scalar acting on the left factor of the odd part. -/ +noncomputable def preActOO : + S.odd →ₗ[ℂ] tenOdd M N →ₗ[ℂ] tenEven M N := + tensorLeftSwap N.odd N.even M.actOE M.actOO + +/-- The even-even block, evaluated. -/ +@[simp] +theorem preActEE_apply (a : S.even) (t : tenEven M N) : + preActEE M N a t = + ((M.actEE a).rTensor N.even t.1, + (M.actEO a).rTensor N.odd t.2) := rfl + +/-- The even-odd block, evaluated. -/ +@[simp] +theorem preActEO_apply (a : S.even) (t : tenOdd M N) : + preActEO M N a t = + ((M.actEE a).rTensor N.odd t.1, + (M.actEO a).rTensor N.even t.2) := rfl + +/-- The odd-even block, evaluated. -/ +@[simp] +theorem preActOE_apply (c : S.odd) (t : tenEven M N) : + preActOE M N c t = + ((M.actOO c).rTensor N.odd t.2, + (M.actOE c).rTensor N.even t.1) := rfl + +/-- The odd-odd block, evaluated. -/ +@[simp] +theorem preActOO_apply (c : S.odd) (t : tenOdd M N) : + preActOO M N c t = + ((M.actOO c).rTensor N.even t.2, + (M.actOE c).rTensor N.odd t.1) := rfl + +/-! ### The module laws before quotienting -/ + +/-- The unit acts as the identity on the even part. -/ +theorem preActEE_one (t : tenEven M N) : + preActEE M N S.one t = t := by + have h1 : M.actEE S.one = LinearMap.id := LinearMap.ext M.one_act_e + have h2 : M.actEO S.one = LinearMap.id := LinearMap.ext M.one_act_o + rw [preActEE_apply, h1, h2, LinearMap.rTensor_id_apply, + LinearMap.rTensor_id_apply] + +/-- The unit acts as the identity on the odd part. -/ +theorem preActEO_one (t : tenOdd M N) : + preActEO M N S.one t = t := by + have h1 : M.actEE S.one = LinearMap.id := LinearMap.ext M.one_act_e + have h2 : M.actEO S.one = LinearMap.id := LinearMap.ext M.one_act_o + rw [preActEO_apply, h1, h2, LinearMap.rTensor_id_apply, + LinearMap.rTensor_id_apply] + +/-- Associativity at parity pattern even-even-even. -/ +theorem preActEE_mulEE (x y : S.even) (t : tenEven M N) : + preActEE M N (S.mulEE x y) t + = preActEE M N x (preActEE M N y t) := by + have h1 : M.actEE (S.mulEE x y) = M.actEE x ∘ₗ M.actEE y := + LinearMap.ext (M.assoc_eee x y) + have h2 : M.actEO (S.mulEE x y) = M.actEO x ∘ₗ M.actEO y := + LinearMap.ext (M.assoc_eeo x y) + simp only [preActEE_apply] + rw [h1, h2, LinearMap.rTensor_comp_apply, + LinearMap.rTensor_comp_apply] + +/-- Associativity at parity pattern even-even-odd. -/ +theorem preActEO_mulEE (x y : S.even) (t : tenOdd M N) : + preActEO M N (S.mulEE x y) t + = preActEO M N x (preActEO M N y t) := by + have h1 : M.actEE (S.mulEE x y) = M.actEE x ∘ₗ M.actEE y := + LinearMap.ext (M.assoc_eee x y) + have h2 : M.actEO (S.mulEE x y) = M.actEO x ∘ₗ M.actEO y := + LinearMap.ext (M.assoc_eeo x y) + simp only [preActEO_apply] + rw [h1, h2, LinearMap.rTensor_comp_apply, + LinearMap.rTensor_comp_apply] + +/-- Associativity at parity pattern even-odd-even. -/ +theorem preActOE_mulEO (x : S.even) (u : S.odd) (t : tenEven M N) : + preActOE M N (S.mulEO x u) t + = preActEO M N x (preActOE M N u t) := by + have h1 : M.actOO (S.mulEO x u) = M.actEE x ∘ₗ M.actOO u := + LinearMap.ext (M.assoc_eoo x u) + have h2 : M.actOE (S.mulEO x u) = M.actEO x ∘ₗ M.actOE u := + LinearMap.ext (M.assoc_eoe x u) + simp only [preActOE_apply, preActEO_apply] + rw [h1, h2, LinearMap.rTensor_comp_apply, + LinearMap.rTensor_comp_apply] + +/-- Associativity at parity pattern even-odd-odd. -/ +theorem preActOO_mulEO (x : S.even) (u : S.odd) (t : tenOdd M N) : + preActOO M N (S.mulEO x u) t + = preActEE M N x (preActOO M N u t) := by + have h1 : M.actOO (S.mulEO x u) = M.actEE x ∘ₗ M.actOO u := + LinearMap.ext (M.assoc_eoo x u) + have h2 : M.actOE (S.mulEO x u) = M.actEO x ∘ₗ M.actOE u := + LinearMap.ext (M.assoc_eoe x u) + simp only [preActOO_apply, preActEE_apply] + rw [h1, h2, LinearMap.rTensor_comp_apply, + LinearMap.rTensor_comp_apply] + +/-- Associativity at parity pattern odd-even-even. -/ +theorem preActOE_mulOE (u : S.odd) (x : S.even) (t : tenEven M N) : + preActOE M N (S.mulOE u x) t + = preActOE M N u (preActEE M N x t) := by + have h1 : M.actOO (S.mulOE u x) = M.actOO u ∘ₗ M.actEO x := + LinearMap.ext (M.assoc_oeo u x) + have h2 : M.actOE (S.mulOE u x) = M.actOE u ∘ₗ M.actEE x := + LinearMap.ext (M.assoc_oee u x) + simp only [preActOE_apply, preActEE_apply] + rw [h1, h2, LinearMap.rTensor_comp_apply, + LinearMap.rTensor_comp_apply] + +/-- Associativity at parity pattern odd-even-odd. -/ +theorem preActOO_mulOE (u : S.odd) (x : S.even) (t : tenOdd M N) : + preActOO M N (S.mulOE u x) t + = preActOO M N u (preActEO M N x t) := by + have h1 : M.actOO (S.mulOE u x) = M.actOO u ∘ₗ M.actEO x := + LinearMap.ext (M.assoc_oeo u x) + have h2 : M.actOE (S.mulOE u x) = M.actOE u ∘ₗ M.actEE x := + LinearMap.ext (M.assoc_oee u x) + simp only [preActOO_apply, preActEO_apply] + rw [h1, h2, LinearMap.rTensor_comp_apply, + LinearMap.rTensor_comp_apply] + +/-- Associativity at parity pattern odd-odd-even. -/ +theorem preActEE_mulOO (u v : S.odd) (t : tenEven M N) : + preActEE M N (S.mulOO u v) t + = preActOO M N u (preActOE M N v t) := by + have h1 : M.actEE (S.mulOO u v) = M.actOO u ∘ₗ M.actOE v := + LinearMap.ext (M.assoc_ooe u v) + have h2 : M.actEO (S.mulOO u v) = M.actOE u ∘ₗ M.actOO v := + LinearMap.ext (M.assoc_ooo u v) + simp only [preActEE_apply, preActOO_apply, preActOE_apply] + rw [h1, h2, LinearMap.rTensor_comp_apply, + LinearMap.rTensor_comp_apply] + +/-- Associativity at parity pattern odd-odd-odd. -/ +theorem preActEO_mulOO (u v : S.odd) (t : tenOdd M N) : + preActEO M N (S.mulOO u v) t + = preActOE M N u (preActOO M N v t) := by + have h1 : M.actEE (S.mulOO u v) = M.actOO u ∘ₗ M.actOE v := + LinearMap.ext (M.assoc_ooe u v) + have h2 : M.actEO (S.mulOO u v) = M.actOE u ∘ₗ M.actOO v := + LinearMap.ext (M.assoc_ooo u v) + simp only [preActEO_apply, preActOE_apply, preActOO_apply] + rw [h1, h2, LinearMap.rTensor_comp_apply, + LinearMap.rTensor_comp_apply] + +/-! ### The blocks preserve balancing -/ + +/-- An even scalar carries the even balancing submodule into +itself. -/ +theorem preActEE_mem_balEven (a : S.even) (t : tenEven M N) + (ht : t ∈ balEven M N) : preActEE M N a t ∈ balEven M N := by + have key : balEven M N ≤ + Submodule.comap (preActEE M N a) (balEven M N) := by + refine Submodule.span_le.mpr ?_ + intro s hs + simp only [SetLike.mem_coe, Submodule.mem_comap] + rcases hs with (((⟨b, m, n, rfl⟩ | ⟨b, m, n, rfl⟩) | + ⟨c, m, n, rfl⟩) | ⟨c, m, n, rfl⟩) + · simp only [relEvenEEE, preActEE_apply, map_sub, map_zero, + LinearMap.rTensor_tmul] + rw [M.actEE_actEE_comm] + exact relEvenEEE_mem M N b (M.actEE a m) n + · simp only [relEvenEOO, preActEE_apply, map_sub, map_zero, + LinearMap.rTensor_tmul] + rw [M.actEO_actEO_comm] + exact relEvenEOO_mem M N b (M.actEO a m) n + · simp only [relEvenOEO, preActEE_apply, map_neg, + LinearMap.rTensor_tmul] + rw [M.actEO_actOE] + exact relEvenOEO_mem M N c (M.actEE a m) n + · simp only [relEvenOOE, preActEE_apply, + LinearMap.rTensor_tmul] + rw [M.actEE_actOO] + exact relEvenOOE_mem M N c (M.actEO a m) n + exact key ht + +/-- An even scalar carries the odd balancing submodule into +itself. -/ +theorem preActEO_mem_balOdd (a : S.even) (t : tenOdd M N) + (ht : t ∈ balOdd M N) : preActEO M N a t ∈ balOdd M N := by + have key : balOdd M N ≤ + Submodule.comap (preActEO M N a) (balOdd M N) := by + refine Submodule.span_le.mpr ?_ + intro s hs + simp only [SetLike.mem_coe, Submodule.mem_comap] + rcases hs with (((⟨b, m, n, rfl⟩ | ⟨b, m, n, rfl⟩) | + ⟨c, m, n, rfl⟩) | ⟨c, m, n, rfl⟩) + · simp only [relOddEEO, preActEO_apply, map_sub, map_zero, + LinearMap.rTensor_tmul] + rw [M.actEE_actEE_comm] + exact relOddEEO_mem M N b (M.actEE a m) n + · simp only [relOddEOE, preActEO_apply, map_sub, map_zero, + LinearMap.rTensor_tmul] + rw [M.actEO_actEO_comm] + exact relOddEOE_mem M N b (M.actEO a m) n + · simp only [relOddOEE, preActEO_apply, map_neg, + LinearMap.rTensor_tmul] + rw [M.actEO_actOE] + exact relOddOEE_mem M N c (M.actEE a m) n + · simp only [relOddOOO, preActEO_apply, + LinearMap.rTensor_tmul] + rw [M.actEE_actOO] + exact relOddOOO_mem M N c (M.actEO a m) n + exact key ht + +/-- An odd scalar carries the even balancing submodule into the +odd one. -/ +theorem preActOE_mem_balOdd (c : S.odd) (t : tenEven M N) + (ht : t ∈ balEven M N) : preActOE M N c t ∈ balOdd M N := by + have key : balEven M N ≤ + Submodule.comap (preActOE M N c) (balOdd M N) := by + refine Submodule.span_le.mpr ?_ + intro s hs + simp only [SetLike.mem_coe, Submodule.mem_comap] + rcases hs with (((⟨b, m, n, rfl⟩ | ⟨b, m, n, rfl⟩) | + ⟨d, m, n, rfl⟩) | ⟨d, m, n, rfl⟩) + · simp only [relEvenEEE, preActOE_apply, map_sub, map_zero, + LinearMap.rTensor_tmul] + rw [← M.actEO_actOE] + exact relOddEOE_mem M N b (M.actOE c m) n + · simp only [relEvenEOO, preActOE_apply, map_sub, map_zero, + LinearMap.rTensor_tmul] + rw [← M.actEE_actOO] + exact relOddEEO_mem M N b (M.actOO c m) n + · simp only [relEvenOEO, preActOE_apply, map_neg, + LinearMap.rTensor_tmul] + rw [M.actOO_actOE_neg, TensorProduct.neg_tmul] + exact relOddOOO_neg_mem M N d (M.actOE c m) n + · simp only [relEvenOOE, preActOE_apply, + LinearMap.rTensor_tmul] + rw [M.actOE_actOO_neg, TensorProduct.neg_tmul] + exact relOddOEE_neg_mem M N d (M.actOO c m) n + exact key ht + +/-- An odd scalar carries the odd balancing submodule into the +even one. -/ +theorem preActOO_mem_balEven (c : S.odd) (t : tenOdd M N) + (ht : t ∈ balOdd M N) : preActOO M N c t ∈ balEven M N := by + have key : balOdd M N ≤ + Submodule.comap (preActOO M N c) (balEven M N) := by + refine Submodule.span_le.mpr ?_ + intro s hs + simp only [SetLike.mem_coe, Submodule.mem_comap] + rcases hs with (((⟨b, m, n, rfl⟩ | ⟨b, m, n, rfl⟩) | + ⟨d, m, n, rfl⟩) | ⟨d, m, n, rfl⟩) + · simp only [relOddEEO, preActOO_apply, map_sub, map_zero, + LinearMap.rTensor_tmul] + rw [← M.actEO_actOE] + exact relEvenEOO_mem M N b (M.actOE c m) n + · simp only [relOddEOE, preActOO_apply, map_sub, map_zero, + LinearMap.rTensor_tmul] + rw [← M.actEE_actOO] + exact relEvenEEE_mem M N b (M.actOO c m) n + · simp only [relOddOEE, preActOO_apply, map_neg, + LinearMap.rTensor_tmul] + rw [M.actOO_actOE_neg, TensorProduct.neg_tmul] + exact relEvenOOE_neg_mem M N d (M.actOE c m) n + · simp only [relOddOOO, preActOO_apply, + LinearMap.rTensor_tmul] + rw [M.actOE_actOO_neg, TensorProduct.neg_tmul] + exact relEvenOEO_neg_mem M N d (M.actOO c m) n + exact key ht + +/-! ### The tensor product -/ + +/-- **The tensor product of two super modules** over a +super-commutative ℂ-algebra: the graded ℂ-tensor product of the +underlying super spaces, quotiented in each degree by the +balancing relators, with the `S`-action induced from the action on +the left factor. -/ +noncomputable def tensor : S.Mod where + even := tenEven M N ⧸ balEven M N + odd := tenOdd M N ⧸ balOdd M N + actEE := descendAct _ _ (preActEE M N) (preActEE_mem_balEven M N) + actEO := descendAct _ _ (preActEO M N) (preActEO_mem_balOdd M N) + actOE := descendAct _ _ (preActOE M N) (preActOE_mem_balOdd M N) + actOO := descendAct _ _ (preActOO M N) (preActOO_mem_balEven M N) + one_act_e m := by + obtain ⟨t, rfl⟩ := Submodule.Quotient.mk_surjective _ m + rw [descendAct_apply, preActEE_one] + one_act_o m := by + obtain ⟨t, rfl⟩ := Submodule.Quotient.mk_surjective _ m + rw [descendAct_apply, preActEO_one] + assoc_eee x y m := by + obtain ⟨t, rfl⟩ := Submodule.Quotient.mk_surjective _ m + rw [descendAct_apply, descendAct_apply, descendAct_apply, + preActEE_mulEE] + assoc_eeo x y m := by + obtain ⟨t, rfl⟩ := Submodule.Quotient.mk_surjective _ m + rw [descendAct_apply, descendAct_apply, descendAct_apply, + preActEO_mulEE] + assoc_eoe x u m := by + obtain ⟨t, rfl⟩ := Submodule.Quotient.mk_surjective _ m + rw [descendAct_apply, descendAct_apply, descendAct_apply, + preActOE_mulEO] + assoc_eoo x u m := by + obtain ⟨t, rfl⟩ := Submodule.Quotient.mk_surjective _ m + rw [descendAct_apply, descendAct_apply, descendAct_apply, + preActOO_mulEO] + assoc_oee u x m := by + obtain ⟨t, rfl⟩ := Submodule.Quotient.mk_surjective _ m + rw [descendAct_apply, descendAct_apply, descendAct_apply, + preActOE_mulOE] + assoc_oeo u x m := by + obtain ⟨t, rfl⟩ := Submodule.Quotient.mk_surjective _ m + rw [descendAct_apply, descendAct_apply, descendAct_apply, + preActOO_mulOE] + assoc_ooe u v m := by + obtain ⟨t, rfl⟩ := Submodule.Quotient.mk_surjective _ m + rw [descendAct_apply, descendAct_apply, descendAct_apply, + preActEE_mulOO] + assoc_ooo u v m := by + obtain ⟨t, rfl⟩ := Submodule.Quotient.mk_surjective _ m + rw [descendAct_apply, descendAct_apply, descendAct_apply, + preActEO_mulOO] + +/-! ### The canonical balanced map -/ + +/-- The canonical map, even times even. -/ +noncomputable def tmulEE : + M.even →ₗ[ℂ] N.even →ₗ[ℂ] (tensor M N).even := + LinearMap.compr₂ (TensorProduct.mk ℂ M.even N.even) + ((balEven M N).mkQ ∘ₗ LinearMap.inl ℂ _ _) + +/-- The canonical map, odd times odd. -/ +noncomputable def tmulOO : + M.odd →ₗ[ℂ] N.odd →ₗ[ℂ] (tensor M N).even := + LinearMap.compr₂ (TensorProduct.mk ℂ M.odd N.odd) + ((balEven M N).mkQ ∘ₗ LinearMap.inr ℂ _ _) + +/-- The canonical map, even times odd. -/ +noncomputable def tmulEO : + M.even →ₗ[ℂ] N.odd →ₗ[ℂ] (tensor M N).odd := + LinearMap.compr₂ (TensorProduct.mk ℂ M.even N.odd) + ((balOdd M N).mkQ ∘ₗ LinearMap.inl ℂ _ _) + +/-- The canonical map, odd times even. -/ +noncomputable def tmulOE : + M.odd →ₗ[ℂ] N.even →ₗ[ℂ] (tensor M N).odd := + LinearMap.compr₂ (TensorProduct.mk ℂ M.odd N.even) + ((balOdd M N).mkQ ∘ₗ LinearMap.inr ℂ _ _) + +/-- The even-even canonical map, evaluated. Not a `simp` lemma: +the quotient class is the implementation, and `tmulEE` is the +interface the computation rules downstream are stated in. -/ +theorem tmulEE_apply (m : M.even) (n : N.even) : + tmulEE M N m n = + Submodule.Quotient.mk ((m ⊗ₜ[ℂ] n, 0) : tenEven M N) := rfl + +/-- The odd-odd canonical map, evaluated. Not a `simp` lemma, for +the reason given at `tmulEE_apply`. -/ +theorem tmulOO_apply (m : M.odd) (n : N.odd) : + tmulOO M N m n = + Submodule.Quotient.mk ((0, m ⊗ₜ[ℂ] n) : tenEven M N) := rfl + +/-- The even-odd canonical map, evaluated. Not a `simp` lemma, for +the reason given at `tmulEE_apply`. -/ +theorem tmulEO_apply (m : M.even) (n : N.odd) : + tmulEO M N m n = + Submodule.Quotient.mk ((m ⊗ₜ[ℂ] n, 0) : tenOdd M N) := rfl + +/-- The odd-even canonical map, evaluated. Not a `simp` lemma, for +the reason given at `tmulEE_apply`. -/ +theorem tmulOE_apply (m : M.odd) (n : N.even) : + tmulOE M N m n = + Submodule.Quotient.mk ((0, m ⊗ₜ[ℂ] n) : tenOdd M N) := rfl + +/-! #### Balancing -/ + +/-- Balancing at parity pattern even-even-even. -/ +theorem tmulEE_balanced_eee (b : S.even) (m : M.even) (n : N.even) : + tmulEE M N (M.actEE b m) n = tmulEE M N m (N.actEE b n) := by + rw [tmulEE_apply, tmulEE_apply] + refine (Submodule.Quotient.eq _).mpr ?_ + rw [Prod.mk_sub_mk, sub_zero] + exact relEvenEEE_mem M N b m n + +/-- Balancing at parity pattern even-odd-odd. -/ +theorem tmulOO_balanced_eoo (b : S.even) (m : M.odd) (n : N.odd) : + tmulOO M N (M.actEO b m) n = tmulOO M N m (N.actEO b n) := by + rw [tmulOO_apply, tmulOO_apply] + refine (Submodule.Quotient.eq _).mpr ?_ + rw [Prod.mk_sub_mk, sub_zero] + exact relEvenEOO_mem M N b m n + +/-- Balancing at parity pattern odd-even-odd. -/ +theorem tmulOO_balanced_oeo (c : S.odd) (m : M.even) (n : N.odd) : + tmulOO M N (M.actOE c m) n = tmulEE M N m (N.actOO c n) := by + rw [tmulOO_apply, tmulEE_apply] + refine (Submodule.Quotient.eq _).mpr ?_ + rw [Prod.mk_sub_mk, zero_sub, sub_zero] + exact relEvenOEO_mem M N c m n + +/-- Balancing at parity pattern odd-odd-even: both arguments are +odd, so the Koszul sign appears. -/ +theorem tmulEE_balanced_ooe (c : S.odd) (m : M.odd) (n : N.even) : + tmulEE M N (M.actOO c m) n = -tmulOO M N m (N.actOE c n) := by + rw [tmulEE_apply, tmulOO_apply] + refine (Submodule.Quotient.eq _).mpr ?_ + rw [Prod.neg_mk, neg_zero, Prod.mk_sub_mk, sub_zero, + sub_neg_eq_add, zero_add] + exact relEvenOOE_mem M N c m n + +/-- Balancing at parity pattern even-even-odd. -/ +theorem tmulEO_balanced_eeo (b : S.even) (m : M.even) (n : N.odd) : + tmulEO M N (M.actEE b m) n = tmulEO M N m (N.actEO b n) := by + rw [tmulEO_apply, tmulEO_apply] + refine (Submodule.Quotient.eq _).mpr ?_ + rw [Prod.mk_sub_mk, sub_zero] + exact relOddEEO_mem M N b m n + +/-- Balancing at parity pattern even-odd-even. -/ +theorem tmulOE_balanced_eoe (b : S.even) (m : M.odd) (n : N.even) : + tmulOE M N (M.actEO b m) n = tmulOE M N m (N.actEE b n) := by + rw [tmulOE_apply, tmulOE_apply] + refine (Submodule.Quotient.eq _).mpr ?_ + rw [Prod.mk_sub_mk, sub_zero] + exact relOddEOE_mem M N b m n + +/-- Balancing at parity pattern odd-even-even. -/ +theorem tmulOE_balanced_oee (c : S.odd) (m : M.even) (n : N.even) : + tmulOE M N (M.actOE c m) n = tmulEO M N m (N.actOE c n) := by + rw [tmulOE_apply, tmulEO_apply] + refine (Submodule.Quotient.eq _).mpr ?_ + rw [Prod.mk_sub_mk, zero_sub, sub_zero] + exact relOddOEE_mem M N c m n + +/-- Balancing at parity pattern odd-odd-odd: both arguments are +odd, so the Koszul sign appears. -/ +theorem tmulEO_balanced_ooo (c : S.odd) (m : M.odd) (n : N.odd) : + tmulEO M N (M.actOO c m) n = -tmulOE M N m (N.actOO c n) := by + rw [tmulEO_apply, tmulOE_apply] + refine (Submodule.Quotient.eq _).mpr ?_ + rw [Prod.neg_mk, neg_zero, Prod.mk_sub_mk, sub_zero, + sub_neg_eq_add, zero_add] + exact relOddOOO_mem M N c m n + +/-! #### The action on the canonical map -/ + +/-- An even scalar acts on the left factor, even times even. -/ +theorem actEE_tmulEE (a : S.even) (m : M.even) (n : N.even) : + (tensor M N).actEE a (tmulEE M N m n) + = tmulEE M N (M.actEE a m) n := rfl + +/-- An even scalar acts on the left factor, odd times odd. -/ +theorem actEE_tmulOO (a : S.even) (m : M.odd) (n : N.odd) : + (tensor M N).actEE a (tmulOO M N m n) + = tmulOO M N (M.actEO a m) n := rfl + +/-- An even scalar acts on the left factor, even times odd. -/ +theorem actEO_tmulEO (a : S.even) (m : M.even) (n : N.odd) : + (tensor M N).actEO a (tmulEO M N m n) + = tmulEO M N (M.actEE a m) n := rfl + +/-- An even scalar acts on the left factor, odd times even. -/ +theorem actEO_tmulOE (a : S.even) (m : M.odd) (n : N.even) : + (tensor M N).actEO a (tmulOE M N m n) + = tmulOE M N (M.actEO a m) n := rfl + +/-- An odd scalar acts on the left factor, even times even. -/ +theorem actOE_tmulEE (c : S.odd) (m : M.even) (n : N.even) : + (tensor M N).actOE c (tmulEE M N m n) + = tmulOE M N (M.actOE c m) n := by + change Submodule.Quotient.mk + (preActOE M N c ((m ⊗ₜ[ℂ] n, 0) : tenEven M N)) + = Submodule.Quotient.mk + ((0, M.actOE c m ⊗ₜ[ℂ] n) : tenOdd M N) + rw [preActOE_apply] + simp only [LinearMap.rTensor_tmul, map_zero] + +/-- An odd scalar acts on the left factor, odd times odd. -/ +theorem actOE_tmulOO (c : S.odd) (m : M.odd) (n : N.odd) : + (tensor M N).actOE c (tmulOO M N m n) + = tmulEO M N (M.actOO c m) n := by + change Submodule.Quotient.mk + (preActOE M N c ((0, m ⊗ₜ[ℂ] n) : tenEven M N)) + = Submodule.Quotient.mk + ((M.actOO c m ⊗ₜ[ℂ] n, 0) : tenOdd M N) + rw [preActOE_apply] + simp only [LinearMap.rTensor_tmul, map_zero] + +/-- An odd scalar acts on the left factor, even times odd. -/ +theorem actOO_tmulEO (c : S.odd) (m : M.even) (n : N.odd) : + (tensor M N).actOO c (tmulEO M N m n) + = tmulOO M N (M.actOE c m) n := by + change Submodule.Quotient.mk + (preActOO M N c ((m ⊗ₜ[ℂ] n, 0) : tenOdd M N)) + = Submodule.Quotient.mk + ((0, M.actOE c m ⊗ₜ[ℂ] n) : tenEven M N) + rw [preActOO_apply] + simp only [LinearMap.rTensor_tmul, map_zero] + +/-- An odd scalar acts on the left factor, odd times even. -/ +theorem actOO_tmulOE (c : S.odd) (m : M.odd) (n : N.even) : + (tensor M N).actOO c (tmulOE M N m n) + = tmulEE M N (M.actOO c m) n := by + change Submodule.Quotient.mk + (preActOO M N c ((0, m ⊗ₜ[ℂ] n) : tenOdd M N)) + = Submodule.Quotient.mk + ((M.actOO c m ⊗ₜ[ℂ] n, 0) : tenEven M N) + rw [preActOO_apply] + simp only [LinearMap.rTensor_tmul, map_zero] + +/-! ### The universal property -/ + +section Universal + +variable {P : Type v} + +/-- **The even-degree lift**: a pair of ℂ-bilinear maps out of the +even-even and odd-odd blocks, balanced against the four +even-degree relator families, factors through the even part of the +tensor product. -/ +noncomputable def liftEven [AddCommGroup P] [Module ℂ P] + (fee : M.even →ₗ[ℂ] N.even →ₗ[ℂ] P) + (foo : M.odd →ₗ[ℂ] N.odd →ₗ[ℂ] P) + (hee : ∀ (b : S.even) (m : M.even) (n : N.even), + fee (M.actEE b m) n = fee m (N.actEE b n)) + (hoo : ∀ (b : S.even) (m : M.odd) (n : N.odd), + foo (M.actEO b m) n = foo m (N.actEO b n)) + (hoeo : ∀ (c : S.odd) (m : M.even) (n : N.odd), + foo (M.actOE c m) n = fee m (N.actOO c n)) + (hooe : ∀ (c : S.odd) (m : M.odd) (n : N.even), + fee (M.actOO c m) n = -foo m (N.actOE c n)) : + (tensor M N).even →ₗ[ℂ] P := + (balEven M N).liftQ + ((TensorProduct.lift fee).coprod (TensorProduct.lift foo)) (by + refine Submodule.span_le.mpr ?_ + intro s hs + simp only [SetLike.mem_coe, LinearMap.mem_ker] + rcases hs with (((⟨b, m, n, rfl⟩ | ⟨b, m, n, rfl⟩) | + ⟨c, m, n, rfl⟩) | ⟨c, m, n, rfl⟩) + · simp only [relEvenEEE, LinearMap.coprod_apply, map_sub, + map_zero, TensorProduct.lift.tmul, add_zero, sub_eq_zero] + exact hee b m n + · simp only [relEvenEOO, LinearMap.coprod_apply, map_sub, + map_zero, TensorProduct.lift.tmul, zero_add, sub_eq_zero] + exact hoo b m n + · simp only [relEvenOEO, LinearMap.coprod_apply, map_neg, + TensorProduct.lift.tmul, neg_add_eq_zero] + exact (hoeo c m n).symm + · simp only [relEvenOOE, LinearMap.coprod_apply, + TensorProduct.lift.tmul, add_eq_zero_iff_eq_neg] + exact hooe c m n) + +/-- **The odd-degree lift**: a pair of ℂ-bilinear maps out of the +even-odd and odd-even blocks, balanced against the four odd-degree +relator families, factors through the odd part of the tensor +product. -/ +noncomputable def liftOdd [AddCommGroup P] [Module ℂ P] + (feo : M.even →ₗ[ℂ] N.odd →ₗ[ℂ] P) + (foe : M.odd →ₗ[ℂ] N.even →ₗ[ℂ] P) + (heeo : ∀ (b : S.even) (m : M.even) (n : N.odd), + feo (M.actEE b m) n = feo m (N.actEO b n)) + (heoe : ∀ (b : S.even) (m : M.odd) (n : N.even), + foe (M.actEO b m) n = foe m (N.actEE b n)) + (hoee : ∀ (c : S.odd) (m : M.even) (n : N.even), + foe (M.actOE c m) n = feo m (N.actOE c n)) + (hooo : ∀ (c : S.odd) (m : M.odd) (n : N.odd), + feo (M.actOO c m) n = -foe m (N.actOO c n)) : + (tensor M N).odd →ₗ[ℂ] P := + (balOdd M N).liftQ + ((TensorProduct.lift feo).coprod (TensorProduct.lift foe)) (by + refine Submodule.span_le.mpr ?_ + intro s hs + simp only [SetLike.mem_coe, LinearMap.mem_ker] + rcases hs with (((⟨b, m, n, rfl⟩ | ⟨b, m, n, rfl⟩) | + ⟨c, m, n, rfl⟩) | ⟨c, m, n, rfl⟩) + · simp only [relOddEEO, LinearMap.coprod_apply, map_sub, + map_zero, TensorProduct.lift.tmul, add_zero, sub_eq_zero] + exact heeo b m n + · simp only [relOddEOE, LinearMap.coprod_apply, map_sub, + map_zero, TensorProduct.lift.tmul, zero_add, sub_eq_zero] + exact heoe b m n + · simp only [relOddOEE, LinearMap.coprod_apply, map_neg, + TensorProduct.lift.tmul, neg_add_eq_zero] + exact (hoee c m n).symm + · simp only [relOddOOO, LinearMap.coprod_apply, + TensorProduct.lift.tmul, add_eq_zero_iff_eq_neg] + exact hooo c m n) + +/-- The even-degree lift computes on even-even products. -/ +@[simp] +theorem liftEven_tmulEE + [AddCommGroup P] [Module ℂ P] (fee : M.even →ₗ[ℂ] N.even →ₗ[ℂ] P) + (foo : M.odd →ₗ[ℂ] N.odd →ₗ[ℂ] P) + (hee : ∀ (b : S.even) (m : M.even) (n : N.even), fee (M.actEE b m) n = + fee m (N.actEE b n)) + (hoo : ∀ (b : S.even) (m : M.odd) (n : N.odd), foo (M.actEO b m) n = foo + m (N.actEO b n)) + (hoeo : ∀ (c : S.odd) (m : M.even) (n : N.odd), foo (M.actOE c m) n = + fee m (N.actOO c n)) + (hooe : ∀ (c : S.odd) (m : M.odd) (n : N.even), fee (M.actOO c m) n = + -foo m (N.actOE c n)) + (m : M.even) (n : N.even) : + liftEven M N fee foo hee hoo hoeo hooe (tmulEE M N m n) + = fee m n := by + change TensorProduct.lift fee (m ⊗ₜ[ℂ] n) + + TensorProduct.lift foo 0 = fee m n + rw [map_zero, add_zero, TensorProduct.lift.tmul] + +/-- The even-degree lift computes on odd-odd products. -/ +@[simp] +theorem liftEven_tmulOO + [AddCommGroup P] [Module ℂ P] (fee : M.even →ₗ[ℂ] N.even →ₗ[ℂ] P) + (foo : M.odd →ₗ[ℂ] N.odd →ₗ[ℂ] P) + (hee : ∀ (b : S.even) (m : M.even) (n : N.even), fee (M.actEE b m) n = + fee m (N.actEE b n)) + (hoo : ∀ (b : S.even) (m : M.odd) (n : N.odd), foo (M.actEO b m) n = foo + m (N.actEO b n)) + (hoeo : ∀ (c : S.odd) (m : M.even) (n : N.odd), foo (M.actOE c m) n = + fee m (N.actOO c n)) + (hooe : ∀ (c : S.odd) (m : M.odd) (n : N.even), fee (M.actOO c m) n = + -foo m (N.actOE c n)) + (m : M.odd) (n : N.odd) : + liftEven M N fee foo hee hoo hoeo hooe (tmulOO M N m n) + = foo m n := by + change TensorProduct.lift fee 0 + + TensorProduct.lift foo (m ⊗ₜ[ℂ] n) = foo m n + rw [map_zero, zero_add, TensorProduct.lift.tmul] + +/-- The odd-degree lift computes on even-odd products. -/ +@[simp] +theorem liftOdd_tmulEO + [AddCommGroup P] [Module ℂ P] (feo : M.even →ₗ[ℂ] N.odd →ₗ[ℂ] P) + (foe : M.odd →ₗ[ℂ] N.even →ₗ[ℂ] P) + (heeo : ∀ (b : S.even) (m : M.even) (n : N.odd), feo (M.actEE b m) n = + feo m (N.actEO b n)) + (heoe : ∀ (b : S.even) (m : M.odd) (n : N.even), foe (M.actEO b m) n = + foe m (N.actEE b n)) + (hoee : ∀ (c : S.odd) (m : M.even) (n : N.even), foe (M.actOE c m) n = + feo m (N.actOE c n)) + (hooo : ∀ (c : S.odd) (m : M.odd) (n : N.odd), feo (M.actOO c m) n = + -foe m (N.actOO c n)) + (m : M.even) (n : N.odd) : + liftOdd M N feo foe heeo heoe hoee hooo (tmulEO M N m n) + = feo m n := by + change TensorProduct.lift feo (m ⊗ₜ[ℂ] n) + + TensorProduct.lift foe 0 = feo m n + rw [map_zero, add_zero, TensorProduct.lift.tmul] + +/-- The odd-degree lift computes on odd-even products. -/ +@[simp] +theorem liftOdd_tmulOE + [AddCommGroup P] [Module ℂ P] (feo : M.even →ₗ[ℂ] N.odd →ₗ[ℂ] P) + (foe : M.odd →ₗ[ℂ] N.even →ₗ[ℂ] P) + (heeo : ∀ (b : S.even) (m : M.even) (n : N.odd), feo (M.actEE b m) n = + feo m (N.actEO b n)) + (heoe : ∀ (b : S.even) (m : M.odd) (n : N.even), foe (M.actEO b m) n = + foe m (N.actEE b n)) + (hoee : ∀ (c : S.odd) (m : M.even) (n : N.even), foe (M.actOE c m) n = + feo m (N.actOE c n)) + (hooo : ∀ (c : S.odd) (m : M.odd) (n : N.odd), feo (M.actOO c m) n = + -foe m (N.actOO c n)) + (m : M.odd) (n : N.even) : + liftOdd M N feo foe heeo heoe hoee hooo (tmulOE M N m n) + = foe m n := by + change TensorProduct.lift feo 0 + + TensorProduct.lift foe (m ⊗ₜ[ℂ] n) = foe m n + rw [map_zero, zero_add, TensorProduct.lift.tmul] + +/-- **Uniqueness in even degree**: the even part of the tensor +product is generated by the even-even and odd-odd products. -/ +theorem liftEven_unique [AddCommGroup P] [Module ℂ P] + (g g' : (tensor M N).even →ₗ[ℂ] P) + (hE : ∀ m n, g (tmulEE M N m n) = g' (tmulEE M N m n)) + (hO : ∀ m n, g (tmulOO M N m n) = g' (tmulOO M N m n)) : + g = g' := + Submodule.linearMap_qext _ + (LinearMap.prod_ext (TensorProduct.ext' hE) (TensorProduct.ext' hO)) + +/-- **Uniqueness in odd degree**: the odd part of the tensor +product is generated by the even-odd and odd-even products. -/ +theorem liftOdd_unique [AddCommGroup P] [Module ℂ P] + (g g' : (tensor M N).odd →ₗ[ℂ] P) + (hE : ∀ m n, g (tmulEO M N m n) = g' (tmulEO M N m n)) + (hO : ∀ m n, g (tmulOE M N m n) = g' (tmulOE M N m n)) : + g = g' := + Submodule.linearMap_qext _ + (LinearMap.prod_ext (TensorProduct.ext' hE) (TensorProduct.ext' hO)) + +/-- **The universal property in even degree**: a balanced pair of +ℂ-bilinear maps out of the even-even and odd-odd blocks factors +uniquely through the even part of the tensor product. -/ +theorem exists_unique_liftEven + [AddCommGroup P] [Module ℂ P] (fee : M.even →ₗ[ℂ] N.even →ₗ[ℂ] P) + (foo : M.odd →ₗ[ℂ] N.odd →ₗ[ℂ] P) + (hee : ∀ (b : S.even) (m : M.even) (n : N.even), fee (M.actEE b m) n = + fee m (N.actEE b n)) + (hoo : ∀ (b : S.even) (m : M.odd) (n : N.odd), foo (M.actEO b m) n = foo + m (N.actEO b n)) + (hoeo : ∀ (c : S.odd) (m : M.even) (n : N.odd), foo (M.actOE c m) n = + fee m (N.actOO c n)) + (hooe : ∀ (c : S.odd) (m : M.odd) (n : N.even), fee (M.actOO c m) n = + -foo m (N.actOE c n)) : + ∃! g : (tensor M N).even →ₗ[ℂ] P, + (∀ m n, g (tmulEE M N m n) = fee m n) ∧ + (∀ m n, g (tmulOO M N m n) = foo m n) := + ⟨liftEven M N fee foo hee hoo hoeo hooe, + ⟨liftEven_tmulEE M N fee foo hee hoo hoeo hooe, + liftEven_tmulOO M N fee foo hee hoo hoeo hooe⟩, + fun g hg => liftEven_unique M N g _ + (fun m n => (hg.1 m n).trans + (liftEven_tmulEE M N fee foo hee hoo hoeo hooe m n).symm) + (fun m n => (hg.2 m n).trans + (liftEven_tmulOO M N fee foo hee hoo hoeo hooe m n).symm)⟩ + +/-- **The universal property in odd degree**: a balanced pair of +ℂ-bilinear maps out of the even-odd and odd-even blocks factors +uniquely through the odd part of the tensor product. -/ +theorem exists_unique_liftOdd + [AddCommGroup P] [Module ℂ P] (feo : M.even →ₗ[ℂ] N.odd →ₗ[ℂ] P) + (foe : M.odd →ₗ[ℂ] N.even →ₗ[ℂ] P) + (heeo : ∀ (b : S.even) (m : M.even) (n : N.odd), feo (M.actEE b m) n = + feo m (N.actEO b n)) + (heoe : ∀ (b : S.even) (m : M.odd) (n : N.even), foe (M.actEO b m) n = + foe m (N.actEE b n)) + (hoee : ∀ (c : S.odd) (m : M.even) (n : N.even), foe (M.actOE c m) n = + feo m (N.actOE c n)) + (hooo : ∀ (c : S.odd) (m : M.odd) (n : N.odd), feo (M.actOO c m) n = + -foe m (N.actOO c n)) : + ∃! g : (tensor M N).odd →ₗ[ℂ] P, + (∀ m n, g (tmulEO M N m n) = feo m n) ∧ + (∀ m n, g (tmulOE M N m n) = foe m n) := + ⟨liftOdd M N feo foe heeo heoe hoee hooo, + ⟨liftOdd_tmulEO M N feo foe heeo heoe hoee hooo, + liftOdd_tmulOE M N feo foe heeo heoe hoee hooo⟩, + fun g hg => liftOdd_unique M N g _ + (fun m n => (hg.1 m n).trans + (liftOdd_tmulEO M N feo foe heeo heoe hoee hooo m n).symm) + (fun m n => (hg.2 m n).trans + (liftOdd_tmulOE M N feo foe heeo heoe hoee hooo m n).symm)⟩ + +end Universal + +end Tensor + +end SuperCommAlgebra.Mod + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperPointMod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperPointMod.lean new file mode 100644 index 0000000000..a85879b7ef --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperPointMod.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEvenRing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModule + +/-! +# The residue module of a complex point + +A complex point of a super-commutative algebra makes the complex +numbers, concentrated in even degree, a module over that algebra: +the even part acts through the point and the odd part acts by zero, +which is consistent exactly because a point kills the products of +two odd elements. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +universe u u' w + +namespace SuperCommAlgebra + +variable {S : SuperCommAlgebra.{u, u'}} + +/-- **The residue module of a complex point**: the complex numbers +in even degree and zero in odd degree, with the even part of the +algebra acting through the point. -/ +noncomputable def pointMod (P : SuperPoint S) : + S.Mod.{u, u', w, w} where + even := ULift.{w} ℂ + odd := ULift.{w} PUnit.{1} + actEE := LinearMap.mk₂ ℂ + (fun x c => ULift.up (P.chi x * c.down)) + (fun x y c => ULift.ext _ _ (by + simp only [map_add, ULift.add_down] + ring)) + (fun r x c => ULift.ext _ _ (by + simp only [map_smul, smul_eq_mul, ULift.smul_down] + ring)) + (fun x c d => ULift.ext _ _ (by + simp only [ULift.add_down] + ring)) + (fun r x c => ULift.ext _ _ (by + simp only [ULift.smul_down, smul_eq_mul] + ring)) + actEO := 0 + actOE := 0 + actOO := 0 + one_act_e m := by + refine ULift.ext _ _ ?_ + change P.chi 1 * m.down = m.down + rw [map_one, one_mul] + one_act_o m := Subsingleton.elim _ _ + assoc_eee x y m := by + refine ULift.ext _ _ ?_ + change P.chi (S.mulEE x y) * m.down = P.chi x * (P.chi y * m.down) + rw [show S.mulEE x y = x * y from rfl, map_mul, mul_assoc] + assoc_eeo _ _ _ := Subsingleton.elim _ _ + assoc_eoe _ _ _ := Subsingleton.elim _ _ + assoc_eoo x u m := by + refine ULift.ext _ _ ?_ + change (0 : ℂ) = P.chi x * (0 : ULift.{w} ℂ).down + simp + assoc_oee _ _ _ := Subsingleton.elim _ _ + assoc_oeo x u m := by + refine ULift.ext _ _ ?_ + change (0 : ℂ) = (0 : ULift.{w} ℂ).down + rfl + assoc_ooe u v m := by + refine ULift.ext _ _ ?_ + change P.chi (S.mulOO u v) * m.down = (0 : ULift.{w} ℂ).down + rw [P.vanishing, zero_mul]; rfl + assoc_ooo _ _ _ := Subsingleton.elim _ _ + +end SuperCommAlgebra + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean new file mode 100644 index 0000000000..f202cd0f98 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean @@ -0,0 +1,816 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear + +/-! +# Realization of ind-super-objects as super algebras + +The §4 descent works with commutative algebra in genuine +ℤ/2-graded ℂ-modules. This file supplies the bridge in three +layers. + +* `RS.SuperCommAlgebra` — a super-commutative ℂ-algebra presented + as a pair of ℂ-modules with the four graded multiplication + blocks and the Koszul sign rule, mirroring the two-component + design of `RS.SuperVect`. The key lemmas: the + ideal generated by the odd part is nil + (`oddIdeal_le_nilradical`, `isNilpotent_of_mem_oddIdeal`), hence + proper on a nonzero algebra (`oddIdeal_ne_top`), so the quotient + `S.even ⧸ S.oddIdeal` is a nonzero *ordinary* commutative + ℂ-algebra (`nontrivial_quotient_of_nontrivial`) — step (i) of + Deligne's §4.5 ending, feeding `RS.exists_algHom_complex`. + +* `RS.SuperMod` — the category of ℤ/2-graded ℂ-modules of + arbitrary dimension: pairs of ℂ-modules with grading-preserving + linear maps, `RS.SuperVect` with the finiteness constraints + removed, with its additive and ℂ-linear structure. + +* `RS.superRealize` — the Γ-functor. The whole Ind-layer runs + over a small category (`RS.indOf`, the `Ind C` instances), and + `RS.SuperVect` is large, so the functor is stated at the tree's + standard generality: a small preadditive `C` with finite + colimits and a chosen generator pair `g₀ g₁ : C` (the unit and + the odd line of a small model of `SuperVect`; `SuperSmall.lean` + builds one). On an + ind-object it takes `Hom(indOf g₀, −)` and `Hom(indOf g₁, −)` as + the even and odd parts, with ℂ-module structures from the linear + structure of `Ind C`. It is additive and ℂ-linear + (`superRealize_additive`, `superRealize_linear`), and it + reflects zero objects whenever the pair biproduct-generates `C` + (`isZero_of_isZero_superRealize`), via the embedded-generator + vanishing lemma `indOf_hom_eq_zero` and the recognition + `isZero_of_generator_hom_eq_zero` of zero ind-objects by their + values on `C`. +-/ + +@[expose] public section + +namespace RS + +/-! ## Super-commutative ℂ-algebras as graded pairs -/ + +universe u u' v + +/-- A *super-commutative ℂ-algebra*, presented as a pair of +ℂ-modules — the even and odd components — with the four graded +multiplication blocks, associativity at every parity pattern, and +commutativity with the Koszul sign: even elements are central and +odd elements anticommute. This is the algebraic realization of +a commutative monoid object of the ind-completion of super vector +spaces. -/ +-- `u` and `u'` are the universes of the even and odd components: +-- independent by design, and the structure is a pair, so they can +-- only ever occur together in its type. +structure SuperCommAlgebra where + /-- The even component. -/ + even : Type u + /-- The odd component. -/ + odd : Type u' + [evenAddCommGroup : AddCommGroup even] + [evenModule : Module ℂ even] + [oddAddCommGroup : AddCommGroup odd] + [oddModule : Module ℂ odd] + /-- The multiplicative unit, an even element. -/ + one : even + /-- Multiplication, even times even. -/ + mulEE : even →ₗ[ℂ] even →ₗ[ℂ] even + /-- Multiplication, even times odd. -/ + mulEO : even →ₗ[ℂ] odd →ₗ[ℂ] odd + /-- Multiplication, odd times even. -/ + mulOE : odd →ₗ[ℂ] even →ₗ[ℂ] odd + /-- Multiplication, odd times odd. -/ + mulOO : odd →ₗ[ℂ] odd →ₗ[ℂ] even + /-- The unit law on the even component. -/ + one_mul_e : ∀ x, mulEE one x = x + /-- The unit law on the odd component. -/ + one_mul_o : ∀ u, mulEO one u = u + /-- Associativity at parity pattern even-even-even. -/ + assoc_eee : ∀ x y z, mulEE (mulEE x y) z = mulEE x (mulEE y z) + /-- Associativity at parity pattern even-even-odd. -/ + assoc_eeo : ∀ x y u, mulEO (mulEE x y) u = mulEO x (mulEO y u) + /-- Associativity at parity pattern even-odd-even. -/ + assoc_eoe : ∀ x u y, mulOE (mulEO x u) y = mulEO x (mulOE u y) + /-- Associativity at parity pattern even-odd-odd. -/ + assoc_eoo : ∀ x u v, mulOO (mulEO x u) v = mulEE x (mulOO u v) + /-- Associativity at parity pattern odd-even-even. -/ + assoc_oee : ∀ u x y, mulOE (mulOE u x) y = mulOE u (mulEE x y) + /-- Associativity at parity pattern odd-even-odd. -/ + assoc_oeo : ∀ u x v, mulOO (mulOE u x) v = mulOO u (mulEO x v) + /-- Associativity at parity pattern odd-odd-even. -/ + assoc_ooe : ∀ u v y, mulEE (mulOO u v) y = mulOO u (mulOE v y) + /-- Associativity at parity pattern odd-odd-odd. -/ + assoc_ooo : ∀ u v w, mulEO (mulOO u v) w = mulOE u (mulOO v w) + /-- Even elements commute. -/ + comm_ee : ∀ x y, mulEE x y = mulEE y x + /-- Even and odd elements commute: the sign `(−1)^{0·1}` is + `1`. -/ + comm_eo : ∀ x u, mulEO x u = mulOE u x + /-- Odd elements anticommute: the Koszul sign `(−1)^{1·1}` is + `−1`. -/ + comm_oo : ∀ u v, mulOO u v = -mulOO v u + +attribute [instance] SuperCommAlgebra.evenAddCommGroup + SuperCommAlgebra.evenModule SuperCommAlgebra.oddAddCommGroup + SuperCommAlgebra.oddModule + +namespace SuperCommAlgebra + +variable (S : SuperCommAlgebra.{u, u'}) + +/-- In a ℂ-module an element equal to its own negative vanishes: +division by two is available in characteristic zero. -/ +private theorem eq_zero_of_self_eq_neg {M : Type*} [AddCommGroup M] + [Module ℂ M] {x : M} (h : x = -x) : x = 0 := by + have h2 : (2 : ℂ) • x = 0 := by + rw [two_smul] + nth_rewrite 2 [h] + exact add_neg_cancel x + have hx : ((2 : ℂ)⁻¹) • ((2 : ℂ) • x) = x := by + rw [smul_smul] + norm_num + rw [← hx, h2, smul_zero] + +/-- The recurring cancellation `(uv)·u = 0` for odd `u`, `v`: +moving `u` across `v` and across itself produces the two opposite +signs at once. -/ +theorem mulEO_mulOO_self (u v : S.odd) : + S.mulEO (S.mulOO u v) u = 0 := by + have ha : S.mulEO (S.mulOO u v) u = -S.mulOE u (S.mulOO u v) := by + rw [S.assoc_ooo, S.comm_oo v u, map_neg] + have hb : S.mulEO (S.mulOO u v) u = S.mulOE u (S.mulOO u v) := + S.comm_eo _ u + have hb0 : S.mulOE u (S.mulOO u v) = 0 := + eq_zero_of_self_eq_neg (hb.symm.trans ha) + exact hb.trans hb0 + +/-- Products of two odd elements are square-zero in the even +component. -/ +theorem mulEE_mulOO_self (u v : S.odd) : + S.mulEE (S.mulOO u v) (S.mulOO u v) = 0 := by + rw [← S.assoc_eoo, S.mulEO_mulOO_self, map_zero, + LinearMap.zero_apply] + +/-- The even component is an ordinary commutative ring under the +even-even multiplication block. -/ +instance instCommRingEven : CommRing S.even := + { S.evenAddCommGroup with + mul := fun x y => S.mulEE x y + one := S.one + left_distrib := fun x y z => map_add (S.mulEE x) y z + right_distrib := fun x y z => by + change S.mulEE (x + y) z = S.mulEE x z + S.mulEE y z + rw [map_add S.mulEE x y, LinearMap.add_apply] + zero_mul := fun x => by + change S.mulEE 0 x = 0 + rw [map_zero S.mulEE, LinearMap.zero_apply] + mul_zero := fun x => map_zero (S.mulEE x) + mul_assoc := S.assoc_eee + one_mul := S.one_mul_e + mul_one := fun x => (S.comm_ee x S.one).trans (S.one_mul_e x) + mul_comm := S.comm_ee } + +/-- Multiplication in the even ring is the even-even block. -/ +theorem mul_def (x y : S.even) : x * y = S.mulEE x y := rfl + +/-- The unit of the even ring is the structural unit. -/ +theorem one_def : (1 : S.even) = S.one := rfl + +/-- The even component is a ℂ-algebra: the scalar action is the +module structure, compatible with multiplication by bilinearity of +the even-even block. -/ +instance instAlgebraEven : Algebra ℂ S.even := + Algebra.ofModule + (fun r x y => by + change S.mulEE (r • x) y = r • S.mulEE x y + rw [map_smul S.mulEE r x, LinearMap.smul_apply]) + (fun r x y => map_smul (S.mulEE x) r y) + +/-- The even part of the ideal generated by the odd component: the +ideal of the even ring spanned by the products of two odd +elements. -/ +def oddIdeal : Ideal S.even := + Ideal.span (Set.range fun p : S.odd × S.odd => S.mulOO p.1 p.2) + +/-- **The odd-generated ideal is nil**: it is spanned by +square-zero elements of a commutative ring, so it lies inside the +nilradical. -/ +theorem oddIdeal_le_nilradical : S.oddIdeal ≤ nilradical S.even := by + rw [oddIdeal, Ideal.span_le] + rintro x ⟨⟨u, v⟩, rfl⟩ + exact mem_nilradical.mpr ⟨2, by + rw [pow_two, mul_def]; exact S.mulEE_mulOO_self u v⟩ + +/-- Every element of the odd-generated ideal is nilpotent. -/ +theorem isNilpotent_of_mem_oddIdeal {x : S.even} + (hx : x ∈ S.oddIdeal) : IsNilpotent x := + mem_nilradical.mp (S.oddIdeal_le_nilradical hx) + +/-- On a nonzero even ring the odd-generated ideal is proper: the +unit is not nilpotent. -/ +theorem oddIdeal_ne_top [Nontrivial S.even] : S.oddIdeal ≠ ⊤ := by + intro h + have h1 : (1 : S.even) ∈ S.oddIdeal := h ▸ Submodule.mem_top + obtain ⟨n, hn⟩ := S.isNilpotent_of_mem_oddIdeal h1 + rw [one_pow] at hn + exact one_ne_zero hn + +/-- Killing the odd-generated ideal of a super-commutative +ℂ-algebra with nonzero even part leaves a nonzero ordinary +commutative ℂ-algebra. -/ +theorem nontrivial_quotient_oddIdeal [Nontrivial S.even] : + Nontrivial (S.even ⧸ S.oddIdeal) := + Ideal.Quotient.nontrivial_iff.mpr S.oddIdeal_ne_top + +/-- A trivial even component trivializes the odd component: the +unit acts as the identity on odd elements. -/ +theorem subsingleton_odd (h : Subsingleton S.even) : + Subsingleton S.odd := by + refine subsingleton_of_forall_eq 0 fun u => ?_ + have h1 : S.one = (0 : S.even) := Subsingleton.elim _ _ + have h2 : S.mulEO S.one u = u := S.one_mul_o u + rw [h1, map_zero, LinearMap.zero_apply] at h2 + exact h2.symm + +/-- A nonzero super-commutative ℂ-algebra has nonzero even +part. -/ +theorem nontrivial_even_of_nontrivial + (h : Nontrivial S.even ∨ Nontrivial S.odd) : + Nontrivial S.even := by + rcases h with h | h + · exact h + · by_contra hc + rw [not_nontrivial_iff_subsingleton] at hc + exact not_subsingleton_iff_nontrivial.mpr h (S.subsingleton_odd hc) + +/-- **The odd-nil quotient** (Deligne §4.5, step (i)): a nonzero +super-commutative ℂ-algebra has a nonzero *ordinary* commutative +ℂ-algebra quotient — the even part modulo the ideal generated by +the odd part. The `CommRing` and `Algebra ℂ` structures on the +quotient are the `Ideal.Quotient` instances over +`instCommRingEven` and `instAlgebraEven`. -/ +theorem nontrivial_quotient_of_nontrivial + (h : Nontrivial S.even ∨ Nontrivial S.odd) : + Nontrivial (S.even ⧸ S.oddIdeal) := + haveI := S.nontrivial_even_of_nontrivial h + S.nontrivial_quotient_oddIdeal + +end SuperCommAlgebra + +/-! ## The category of ℤ/2-graded ℂ-modules -/ + +/-- A *super module* over ℂ: a pair of complex modules of +arbitrary dimension, the even and odd components — `RS.SuperVect` +with the finiteness constraints removed. -/ +structure SuperMod where + /-- The even-graded component. -/ + even : Type u + /-- The odd-graded component. -/ + odd : Type u + [evenAddCommGroup : AddCommGroup even] + [evenModule : Module ℂ even] + [oddAddCommGroup : AddCommGroup odd] + [oddModule : Module ℂ odd] + +attribute [instance] SuperMod.evenAddCommGroup SuperMod.evenModule + SuperMod.oddAddCommGroup SuperMod.oddModule + +namespace SuperMod + +open CategoryTheory + +/-- A morphism of super modules: a pair of ℂ-linear maps +preserving the grading. -/ +@[ext] +structure Hom (V W : SuperMod.{u}) where + /-- The even component of the morphism. -/ + evenMap : V.even →ₗ[ℂ] W.even + /-- The odd component of the morphism. -/ + oddMap : V.odd →ₗ[ℂ] W.odd + +/-- The identity morphism on a super module. -/ +@[simp] +def Hom.id (V : SuperMod.{u}) : Hom V V where + evenMap := LinearMap.id + oddMap := LinearMap.id + +/-- Composition of super-module morphisms. -/ +@[simp] +def Hom.comp {V W X : SuperMod.{u}} (g : Hom W X) (f : Hom V W) : + Hom V X where + evenMap := g.evenMap.comp f.evenMap + oddMap := g.oddMap.comp f.oddMap + +/-- Super modules and grading-preserving maps form a category. -/ +instance instCategoryStruct : CategoryStruct SuperMod.{u} where + Hom := Hom + id := Hom.id + comp f g := Hom.comp g f + +/-- Two morphisms agreeing in both components are equal. -/ +@[ext] +theorem hom_ext {V W : SuperMod.{u}} {f g : V ⟶ W} + (he : (f : Hom V W).evenMap = (g : Hom V W).evenMap) + (ho : (f : Hom V W).oddMap = (g : Hom V W).oddMap) : f = g := + Hom.ext he ho + +/-- SuperMod forms a category with grading-preserving linear +maps. -/ +instance instCategory : Category SuperMod.{u} where + id_comp _ := by ext <;> simp [CategoryStruct.comp, CategoryStruct.id] + comp_id _ := by ext <;> simp [CategoryStruct.comp, CategoryStruct.id] + assoc _ _ _ := by ext <;> simp [CategoryStruct.comp] + +/-! ### Additive and linear structure, mirroring `SuperVect` -/ + +/-- The zero morphism: zero in both components. -/ +instance {V W : SuperMod.{u}} : Zero (V ⟶ W) := + ⟨⟨0, 0⟩⟩ + +/-- Componentwise addition of morphisms. -/ +instance {V W : SuperMod.{u}} : Add (V ⟶ W) := + ⟨fun f g => ⟨f.evenMap + g.evenMap, f.oddMap + g.oddMap⟩⟩ + +/-- Componentwise negation. -/ +instance {V W : SuperMod.{u}} : Neg (V ⟶ W) := + ⟨fun f => ⟨-f.evenMap, -f.oddMap⟩⟩ + +/-- Componentwise subtraction. -/ +instance {V W : SuperMod.{u}} : Sub (V ⟶ W) := + ⟨fun f g => ⟨f.evenMap - g.evenMap, f.oddMap - g.oddMap⟩⟩ + +/-- Componentwise scaling by a complex number. -/ +instance {V W : SuperMod.{u}} : SMul ℂ (V ⟶ W) := + ⟨fun c f => ⟨c • f.evenMap, c • f.oddMap⟩⟩ + +/-- Componentwise natural scaling, definitional so that the +`AddCommGroup` structure below has no transported `nsmul` +field. -/ +instance {V W : SuperMod.{u}} : SMul ℕ (V ⟶ W) := + ⟨fun n f => ⟨n • f.evenMap, n • f.oddMap⟩⟩ + +/-- Componentwise integer scaling, likewise definitional. -/ +instance {V W : SuperMod.{u}} : SMul ℤ (V ⟶ W) := + ⟨fun n f => ⟨n • f.evenMap, n • f.oddMap⟩⟩ + +/-- The components of a morphism determine it; the additive and +module structures are pulled back componentwise. -/ +def homComponents {V W : SuperMod.{u}} (f : V ⟶ W) : + (V.even →ₗ[ℂ] W.even) × (V.odd →ₗ[ℂ] W.odd) := + (f.evenMap, f.oddMap) + +/-- Componentwise equality of morphisms. -/ +theorem homComponents_injective {V W : SuperMod.{u}} : + Function.Injective (homComponents (V := V) (W := W)) := + fun _ _ h => Hom.ext (congrArg Prod.fst h) (congrArg Prod.snd h) + +/-- Morphisms form an abelian group, pulled back along the +injection into the pair of component maps. -/ +instance {V W : SuperMod.{u}} : AddCommGroup (V ⟶ W) := + homComponents_injective.addCommGroup homComponents + rfl (fun _ _ => rfl) (fun _ => rfl) (fun _ _ => rfl) + (fun _ _ => rfl) (fun _ _ => rfl) + +/-- Morphisms form a ℂ-module, pulled back the same way. -/ +instance {V W : SuperMod.{u}} : Module ℂ (V ⟶ W) := + homComponents_injective.module ℂ + { toFun := homComponents + map_zero' := rfl + map_add' := fun _ _ => rfl } + (fun _ _ => rfl) + +/-- Addition of morphisms is componentwise on the even part. -/ +@[simp] +theorem add_evenMap {V W : SuperMod.{u}} (f g : V ⟶ W) : + (f + g).evenMap = f.evenMap + g.evenMap := rfl + +/-- Addition of morphisms is componentwise on the odd part. -/ +@[simp] +theorem add_oddMap {V W : SuperMod.{u}} (f g : V ⟶ W) : + (f + g).oddMap = f.oddMap + g.oddMap := rfl + +/-- The zero morphism's even component is zero. -/ +@[simp] +theorem zero_evenMap {V W : SuperMod.{u}} : + (0 : V ⟶ W).evenMap = 0 := rfl + +/-- The zero morphism's odd component is zero. -/ +@[simp] +theorem zero_oddMap {V W : SuperMod.{u}} : + (0 : V ⟶ W).oddMap = 0 := rfl + +/-- Scalar multiplication is componentwise on the even part. -/ +@[simp] +theorem smul_evenMap {V W : SuperMod.{u}} (c : ℂ) (f : V ⟶ W) : + (c • f).evenMap = c • f.evenMap := rfl + +/-- Scalar multiplication is componentwise on the odd part. -/ +@[simp] +theorem smul_oddMap {V W : SuperMod.{u}} (c : ℂ) (f : V ⟶ W) : + (c • f).oddMap = c • f.oddMap := rfl + +/-- SuperMod is preadditive: composition is bilinear +componentwise. -/ +instance instPreadditive : Preadditive SuperMod.{u} where + add_comp _ _ _ f f' g := by + apply Hom.ext + · change g.evenMap ∘ₗ (f.evenMap + f'.evenMap) = _ + exact LinearMap.comp_add _ _ _ + · change g.oddMap ∘ₗ (f.oddMap + f'.oddMap) = _ + exact LinearMap.comp_add _ _ _ + comp_add _ _ _ f g g' := by + apply Hom.ext + · change (g.evenMap + g'.evenMap) ∘ₗ f.evenMap = _ + exact LinearMap.add_comp _ _ _ + · change (g.oddMap + g'.oddMap) ∘ₗ f.oddMap = _ + exact LinearMap.add_comp _ _ _ + +/-- SuperMod is ℂ-linear: composition is ℂ-bilinear +componentwise. -/ +instance instLinear : CategoryTheory.Linear ℂ SuperMod.{u} where + smul_comp _ _ _ c f g := by + apply Hom.ext + · change g.evenMap ∘ₗ (c • f.evenMap) = _ + exact LinearMap.comp_smul _ _ _ + · change g.oddMap ∘ₗ (c • f.oddMap) = _ + exact LinearMap.comp_smul _ _ _ + comp_smul _ _ _ f c g := by + apply Hom.ext + · change (c • g.evenMap) ∘ₗ f.evenMap = _ + exact LinearMap.smul_comp _ _ _ + · change (c • g.oddMap) ∘ₗ f.oddMap = _ + exact LinearMap.smul_comp _ _ _ + +/-- Even elements of a zero super module vanish: the identity +morphism is the zero morphism. -/ +theorem even_eq_zero_of_isZero {V : SuperMod.{u}} + (h : Limits.IsZero V) (x : V.even) : x = 0 := by + have h1 : 𝟙 V = (0 : V ⟶ V) := h.eq_of_src _ _ + have h2 : (𝟙 V : Hom V V).evenMap x = (0 : V ⟶ V).evenMap x := + congrArg (fun f => (f : Hom V V).evenMap x) h1 + exact h2 + +/-- Odd elements of a zero super module vanish. -/ +theorem odd_eq_zero_of_isZero {V : SuperMod.{u}} + (h : Limits.IsZero V) (x : V.odd) : x = 0 := by + have h1 : 𝟙 V = (0 : V ⟶ V) := h.eq_of_src _ _ + have h2 : (𝟙 V : Hom V V).oddMap x = (0 : V ⟶ V).oddMap x := + congrArg (fun f => (f : Hom V V).oddMap x) h1 + exact h2 + +end SuperMod + +/-! ## The Γ-functor on the ind-completion -/ + +noncomputable section Realize + +open CategoryTheory Limits Opposite ZeroObject + +attribute [local instance] HasFiniteBiproducts.of_hasFiniteCoproducts + +variable {C : Type v} + +/-- **The realization functor** relative to a generator pair +`g₀ g₁ : C` — the unit and the odd line of the small model of +`SuperVect` in the intended instantiation. An ind-object realizes +as the ℤ/2-graded ℂ-module of morphisms out of the embedded +generators: `Hom(indOf g₀, −)` in even degree and +`Hom(indOf g₁, −)` in odd degree, with the ℂ-module structures +given by the linear structure of `Ind C`. -/ +def superRealize [SmallCategory C] [Preadditive C] [HasFiniteColimits C] + (g₀ g₁ : C) [Linear ℂ (Ind C)] : + Ind C ⥤ SuperMod.{v} where + obj F := + { even := indOf.obj g₀ ⟶ F + odd := indOf.obj g₁ ⟶ F } + map φ := + { evenMap := Linear.rightComp ℂ _ φ + oddMap := Linear.rightComp ℂ _ φ } + map_id F := by + apply SuperMod.hom_ext <;> + exact LinearMap.ext fun f => Category.comp_id f + map_comp φ ψ := by + apply SuperMod.hom_ext <;> + exact LinearMap.ext fun f => (Category.assoc f φ ψ).symm + +/-- The realization functor is additive: postcomposition +distributes over sums of morphisms of ind-objects. -/ +instance superRealize_additive + [SmallCategory C] [Preadditive C] [HasFiniteColimits C] + (g₀ g₁ : C) [Linear ℂ (Ind C)] : + (superRealize g₀ g₁).Additive where + map_add {F G φ ψ} := by + apply SuperMod.hom_ext <;> + exact LinearMap.ext fun f => Preadditive.comp_add _ _ _ f φ ψ + +/-- The realization functor is ℂ-linear. -/ +instance superRealize_linear + [SmallCategory C] [Preadditive C] [HasFiniteColimits C] + (g₀ g₁ : C) [Linear ℂ (Ind C)] : + Functor.Linear ℂ (superRealize g₀ g₁) where + map_smul {F G φ} r := by + apply SuperMod.hom_ext <;> + exact LinearMap.ext fun f => Linear.comp_smul _ _ _ f r φ + +/-! ### Zero reflection -/ + +/-- A family of objects *biproduct-generates* a category if every +object is isomorphic to a finite biproduct of members of the +family. For the small model of `SuperVect` the two-member family +of the unit and the odd line generates in this sense. -/ +def BiproductGenerates [SmallCategory C] [Preadditive C] [HasFiniteColimits C] + {ι : Type*} (g : ι → C) : Prop := + ∀ X : C, ∃ (n : ℕ) (w : Fin n → ι), Nonempty (X ≅ ⨁ (g ∘ w)) + +/-- Morphisms from an embedded object into an ind-object vanish +once they vanish from the embedded generators, along a biproduct +decomposition of the object: the embedding is additive, so the +biproduct decomposition of the identity transports. -/ +theorem indOf_hom_eq_zero + [SmallCategory C] [Preadditive C] [HasFiniteColimits C] + {ι : Type*} {g : ι → C} {F : Ind C} + (hvan : ∀ (i : ι) (f : indOf.obj (g i) ⟶ F), f = 0) + {n : ℕ} {w : Fin n → ι} {X : C} (φ : X ≅ ⨁ (g ∘ w)) + (f : indOf.obj X ⟶ F) : f = 0 := by + have : (indOf (C := C)).Additive := indOf_additive + have hdec : f = indOf.map φ.hom ≫ (indOf.map φ.inv ≫ f) := by + rw [← Category.assoc, ← Functor.map_comp, φ.hom_inv_id, + CategoryTheory.Functor.map_id, Category.id_comp] + have hk : indOf.map φ.inv ≫ f = 0 := by + have h1 : indOf.map φ.inv ≫ f = + indOf.map (𝟙 (⨁ (g ∘ w))) ≫ (indOf.map φ.inv ≫ f) := by + rw [CategoryTheory.Functor.map_id, Category.id_comp] + rw [h1, ← biproduct.total, Functor.map_sum, + Preadditive.sum_comp] + refine Finset.sum_eq_zero fun i _ => ?_ + rw [Functor.map_comp, Category.assoc] + have h0 : indOf.map (biproduct.ι (g ∘ w) i) ≫ + (indOf.map φ.inv ≫ f) = 0 := hvan (w i) _ + rw [h0, comp_zero] + rw [hdec, hk, comp_zero] + +/-- **Zero recognition on values**: an ind-object with no nonzero +morphism from any embedded object is zero. The underlying +presheaf has singleton values, so it is isomorphic to the presheaf +of the embedded zero object, and full faithfulness of the +inclusion pulls the isomorphism back. -/ +theorem isZero_ind_of_hom_eq_zero + [SmallCategory C] [Preadditive C] [HasFiniteColimits C] + {F : Ind C} + (h : ∀ (X : C) (f : indOf.obj X ⟶ F), f = 0) : IsZero F := by + have : HasZeroObject C := hasZeroObject_of_hasInitial_object + let e : ∀ (G : Ind C) (X : C), + (indOf.obj X ⟶ G) ≃ ((Ind.inclusion C).obj G).obj (op X) := + fun G X => + (Ind.inclusion.fullyFaithful.homEquiv.trans + ((Ind.yonedaCompInclusion.app X).homCongr + (Iso.refl ((Ind.inclusion C).obj G)))).trans yonedaEquiv + have hzero : IsZero (indOf.obj (0 : C)) := + isZero_indOf (isZero_zero C) + have hsubF : ∀ X : C, + Subsingleton (((Ind.inclusion C).obj F).obj (op X)) := by + intro X + have : Subsingleton (indOf.obj X ⟶ F) := + subsingleton_of_forall_eq 0 fun f => + (h X f).trans (h X 0).symm + exact (e F X).symm.subsingleton + have hsub0 : ∀ X : C, + Subsingleton + (((Ind.inclusion C).obj (indOf.obj (0 : C))).obj (op X)) := by + intro X + have : Subsingleton (indOf.obj X ⟶ indOf.obj (0 : C)) := + subsingleton_of_forall_eq 0 fun f => hzero.eq_of_tgt f 0 + exact (e (indOf.obj (0 : C)) X).symm.subsingleton + have hiso : (Ind.inclusion C).obj F ≅ + (Ind.inclusion C).obj (indOf.obj (0 : C)) := by + refine NatIso.ofComponents (fun X => ?_) (fun {X Y} k => ?_) + · haveI : Subsingleton (((Ind.inclusion C).obj F).obj X) := + hsubF X.unop + haveI : Subsingleton + (((Ind.inclusion C).obj (indOf.obj (0 : C))).obj X) := + hsub0 X.unop + exact Equiv.toIso (equivOfSubsingletonOfSubsingleton + (fun _ => e (indOf.obj (0 : C)) X.unop 0) + (fun _ => e F X.unop 0)) + · have : Subsingleton + (((Ind.inclusion C).obj (indOf.obj (0 : C))).obj Y) := + hsub0 Y.unop + have : Subsingleton (((Ind.inclusion C).obj F).obj X ⟶ + ((Ind.inclusion C).obj (indOf.obj (0 : C))).obj Y) := + ⟨fun p q => by + ext x + exact Subsingleton.elim _ _⟩ + exact Subsingleton.elim _ _ + exact hzero.of_iso (Ind.inclusion.fullyFaithful.preimageIso hiso) + +/-- **Zero recognition by generators**: an ind-object with no +nonzero morphism from the embedded members of a +biproduct-generating family is zero. -/ +theorem isZero_of_generator_hom_eq_zero + [SmallCategory C] [Preadditive C] [HasFiniteColimits C] + {ι : Type*} {g : ι → C} + (hgen : BiproductGenerates g) {F : Ind C} + (hvan : ∀ (i : ι) (f : indOf.obj (g i) ⟶ F), f = 0) : + IsZero F := by + refine isZero_ind_of_hom_eq_zero fun X f => ?_ + obtain ⟨n, w, ⟨φ⟩⟩ := hgen X + exact indOf_hom_eq_zero hvan φ f + +/-- The generator pair of the realization functor as a +`Bool`-indexed family: `false` is the even generator, `true` the +odd one. -/ +def generatorPair (g₀ g₁ : C) : Bool → C := + fun b => bif b then g₁ else g₀ + +/-- **The realization functor reflects zero objects**: over a +biproduct-generating pair, an ind-object whose even and odd +realizations vanish is zero. -/ +theorem isZero_of_isZero_superRealize + [SmallCategory C] [Preadditive C] [HasFiniteColimits C] + (g₀ g₁ : C) + [Linear ℂ (Ind C)] + (hgen : BiproductGenerates (generatorPair g₀ g₁)) + {F : Ind C} + (hF : IsZero ((superRealize g₀ g₁).obj F)) : IsZero F := by + refine isZero_of_generator_hom_eq_zero hgen fun b => ?_ + cases b + · exact fun f => SuperMod.even_eq_zero_of_isZero hF f + · exact fun f => SuperMod.odd_eq_zero_of_isZero hF f + +end Realize + +/-! ## The convolution algebra of a commutative monoid object + +The even half of the monoid transport: for a commutative monoid +object `R` of a braided ℂ-linear monoidal category — `Ind C` with +its transported structure in the intended instantiation — the +morphisms `𝟙 ⟶ R` carry an ordinary commutative ℂ-algebra +structure under the convolution product +`a · b = λ⁻¹ ≫ (a ⊗ b) ≫ μ`. Together with the unit +identification `indOfUnitIso` this equips the even part of +`superRealize` on a commutative monoid object with its ring +structure. -/ + +section HomAlgebra + +open CategoryTheory MonoidalCategory MonObj +open scoped MonObj + +variable {D : Type u} + +/-- The convolution product of morphisms from the unit into a +monoid object. -/ +noncomputable def unitHomMul [Category.{u'} D] [MonoidalCategory D] + (R : D) [MonObj R] + (a b : 𝟙_ D ⟶ R) : 𝟙_ D ⟶ R := + (λ_ (𝟙_ D)).inv ≫ (a ⊗ₘ b) ≫ μ + +/-- The monoid unit is a left unit for convolution. -/ +theorem one_unitHomMul [Category.{u'} D] [MonoidalCategory D] (R : D) [MonObj R] + (a : 𝟙_ D ⟶ R) : unitHomMul R η a = a := by + rw [unitHomMul, MonObj.one_mul_hom, Iso.inv_hom_id_assoc] + +/-- The monoid unit is a right unit for convolution. -/ +theorem unitHomMul_one [Category.{u'} D] [MonoidalCategory D] (R : D) [MonObj R] + (a : 𝟙_ D ⟶ R) : unitHomMul R a η = a := by + rw [unitHomMul, MonObj.mul_one_hom, ← unitors_equal, + Iso.inv_hom_id_assoc] + +/-- Convolution is associative. -/ +theorem unitHomMul_assoc + [Category.{u'} D] [MonoidalCategory D] (R : D) [MonObj R] + (a b c : 𝟙_ D ⟶ R) : + unitHomMul R (unitHomMul R a b) c = + unitHomMul R a (unitHomMul R b c) := by + have key : μ[R] ≫ (ρ_ R).inv ≫ R ◁ c ≫ μ[R] = + (ρ_ (R ⊗ R)).inv ≫ (α_ R R (𝟙_ D)).hom ≫ + R ◁ R ◁ c ≫ R ◁ μ[R] ≫ μ[R] := by + rw [rightUnitor_inv_naturality_assoc, ← whisker_exchange_assoc, + MonObj.mul_assoc, associator_naturality_right_assoc] + simp only [unitHomMul, tensorHom_def, whiskerRight_id, Category.assoc, whiskerLeft_comp, + whiskerLeft_rightUnitor, whiskerLeft_rightUnitor_inv, triangle_assoc_comp_left_inv_assoc, + Iso.hom_inv_id_assoc, Iso.inv_hom_id_assoc, Iso.cancel_iso_inv_left, Iso.cancel_iso_hom_left] + rw [← unitors_equal] + simp only [Iso.inv_hom_id_assoc] + rw [key] + +/-- Convolution against a commutative monoid object is +commutative. -/ +theorem unitHomMul_comm + [Category.{u'} D] [MonoidalCategory D] (R : D) [MonObj R] + [BraidedCategory D] [IsCommMonObj R] + (a b : 𝟙_ D ⟶ R) : unitHomMul R a b = unitHomMul R b a := by + have h : (a ⊗ₘ b) ≫ μ[R] = + (β_ (𝟙_ D) (𝟙_ D)).hom ≫ (b ⊗ₘ a) ≫ μ[R] := by + conv_lhs => rw [← IsCommMonObj.mul_comm R] + rw [BraidedCategory.braiding_naturality_assoc] + rw [unitHomMul, unitHomMul, h, braiding_tensorUnit_left] + simp [← unitors_inv_equal] + +section Bilinear + +/-- Convolution is additive on the left. -/ +theorem add_unitHomMul [Category.{u'} D] [MonoidalCategory D] (R : D) [MonObj R] + [Preadditive D] [MonoidalPreadditive D] + (a a' b : 𝟙_ D ⟶ R) : + unitHomMul R (a + a') b = unitHomMul R a b + unitHomMul R a' b := by + rw [unitHomMul, unitHomMul, unitHomMul, + MonoidalPreadditive.add_tensor, Preadditive.add_comp, + Preadditive.comp_add] + +/-- Convolution is additive on the right. -/ +theorem unitHomMul_add [Category.{u'} D] [MonoidalCategory D] (R : D) [MonObj R] + [Preadditive D] [MonoidalPreadditive D] + (a b b' : 𝟙_ D ⟶ R) : + unitHomMul R a (b + b') = unitHomMul R a b + unitHomMul R a b' := by + rw [unitHomMul, unitHomMul, unitHomMul, + MonoidalPreadditive.tensor_add, Preadditive.add_comp, + Preadditive.comp_add] + +/-- Convolution kills zero on the left. -/ +theorem zero_unitHomMul + [Category.{u'} D] [MonoidalCategory D] (R : D) [MonObj R] + [Preadditive D] [MonoidalPreadditive D] + (b : 𝟙_ D ⟶ R) : unitHomMul R 0 b = 0 := by + simp [unitHomMul] + +/-- Convolution kills zero on the right. -/ +theorem unitHomMul_zero + [Category.{u'} D] [MonoidalCategory D] (R : D) [MonObj R] + [Preadditive D] [MonoidalPreadditive D] + (a : 𝟙_ D ⟶ R) : unitHomMul R a 0 = 0 := by + simp [unitHomMul] + +/-- Convolution is ℂ-homogeneous on the left. -/ +theorem smul_unitHomMul + [Category.{u'} D] [MonoidalCategory D] (R : D) [MonObj R] + [Preadditive D] [MonoidalPreadditive D] + [Linear ℂ D] [MonoidalLinear ℂ D] (r : ℂ) + (a b : 𝟙_ D ⟶ R) : + unitHomMul R (r • a) b = r • unitHomMul R a b := by + have h : (r • a) ⊗ₘ b = r • (a ⊗ₘ b) := by + rw [tensorHom_def, tensorHom_def, + MonoidalLinear.smul_whiskerRight, Linear.smul_comp] + rw [unitHomMul, unitHomMul, h, Linear.smul_comp, Linear.comp_smul] + +/-- Convolution is ℂ-homogeneous on the right. -/ +theorem unitHomMul_smul + [Category.{u'} D] [MonoidalCategory D] (R : D) [MonObj R] + [Preadditive D] [MonoidalPreadditive D] + [Linear ℂ D] [MonoidalLinear ℂ D] (r : ℂ) + (a b : 𝟙_ D ⟶ R) : + unitHomMul R a (r • b) = r • unitHomMul R a b := by + have h : a ⊗ₘ (r • b) = r • (a ⊗ₘ b) := by + rw [tensorHom_def', tensorHom_def', + MonoidalLinear.whiskerLeft_smul, Linear.smul_comp] + rw [unitHomMul, unitHomMul, h, Linear.smul_comp, Linear.comp_smul] + +/-- **The convolution ring**: for a commutative monoid object of a +braided preadditive monoidal category the morphisms from the unit +form a commutative ring under convolution. Deliberately a +definition rather than an instance: at `R = 𝟙` the type coincides +with `End (𝟙_ D)`, whose composition monoid is a distinct (if +Eckmann–Hilton-equal) multiplication. -/ +@[reducible] noncomputable def unitHomCommRing + [Category.{u'} D] [MonoidalCategory D] (R : D) [MonObj R] + [Preadditive D] [MonoidalPreadditive D] + [BraidedCategory D] + [IsCommMonObj R] : CommRing (𝟙_ D ⟶ R) := + { (inferInstance : AddCommGroup (𝟙_ D ⟶ R)) with + mul := unitHomMul R + one := η + left_distrib := unitHomMul_add R + right_distrib := add_unitHomMul R + zero_mul := zero_unitHomMul R + mul_zero := unitHomMul_zero R + mul_assoc := unitHomMul_assoc R + one_mul := one_unitHomMul R + mul_one := unitHomMul_one R + mul_comm := unitHomMul_comm R } + +/-- **The convolution ℂ-algebra**: with ℂ-linear structure the +convolution ring of a commutative monoid object is a commutative +ℂ-algebra — the even Γ-algebra of the monoid transport once the +unit of `Ind C` is identified with the embedded even generator +(`indOfUnitIso`). -/ +@[reducible] noncomputable def unitHomAlgebra + [Category.{u'} D] [MonoidalCategory D] (R : D) [MonObj R] + [Preadditive D] [MonoidalPreadditive D] + [BraidedCategory D] + [Linear ℂ D] [MonoidalLinear ℂ D] [IsCommMonObj R] : + letI := unitHomCommRing R + Algebra ℂ (𝟙_ D ⟶ R) := + letI := unitHomCommRing R + @Algebra.ofModule ℂ (𝟙_ D ⟶ R) _ _ (Linear.homModule _ _) + (smul_unitHomMul R) (unitHomMul_smul R) + +end Bilinear + +end HomAlgebra + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSeries.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSeries.lean new file mode 100644 index 0000000000..0d3f8d4c28 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSeries.lean @@ -0,0 +1,243 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialH + +/-! +# Super power sums and their generating series + +The power-sum sequence of the super vector space `ℂ^{p|q}` is +`superPS p q c = p + (−1)^{c+1} q`: `p` copies of `+1` and `q` copies +of `−1`, the latter weighted by the super sign. The central result of +this module is the generating-function identity + + `(1 − X)^p · newtonHSeries (superPS p q) = (1 + X)^q` + +in `ℂ⟦X⟧`, proved by showing that both sides satisfy the differential +equation `(1 + X) · F′ = q · F` with constant coefficient `1`, whose +coefficient recursion pins the coefficients to `C(q, n)`. Coefficient +extraction yields binomial evaluations of `newtonH (superPS p q)` in +the pure cases and, for `n > q`, a linear recurrence of order `p` — +the input for hook-vanishing arguments. +-/ + +@[expose] public section + +namespace RS + +open Finset PowerSeries + +/-! ### The super power sums -/ + +/-- The power sums of the super vector space `ℂ^{p|q}`: `p` copies of +`+1` and `q` copies of `−1` with the super sign, so +`superPS p q 1 = p + q`, `superPS p q 2 = p − q`, and so on. -/ +noncomputable def superPS (p q : ℕ) : ℕ → ℂ := + fun c => (p : ℂ) + (-1) ^ (c + 1) * (q : ℂ) + +/-- Super power sums add under direct sums of super vector spaces. -/ +theorem superPS_add (p q r s : ℕ) : + (fun c => superPS p q c + superPS r s c) = superPS (p + r) (q + s) := by + funext c + simp only [superPS] + push_cast + ring + +/-- Super power sums multiply under tensor products of super vector +spaces. -/ +theorem superPS_mul (p q r s : ℕ) : + (fun c => superPS p q c * superPS r s c) = + superPS (p * r + q * s) (p * s + q * r) := by + funext c + have h : (-1 : ℂ) ^ (c + 1) * (-1) ^ (c + 1) = 1 := by + rw [← pow_add] + exact Even.neg_one_pow ⟨c + 1, by ring⟩ + simp only [superPS] + push_cast + linear_combination ((q : ℂ) * (s : ℂ)) * h + +/-! ### Binomial coefficients of `(1 ± X)^k` -/ + +private theorem coeff_one_add_X_pow (q n : ℕ) : + coeff n ((1 + X : ℂ⟦X⟧) ^ q) = (q.choose n : ℂ) := by + have h : ((1 + Polynomial.X : Polynomial ℂ) : ℂ⟦X⟧) = 1 + X := by + rw [Polynomial.coe_add, Polynomial.coe_one, Polynomial.coe_X] + rw [← h, ← Polynomial.coe_pow, Polynomial.coeff_coe, + Polynomial.coeff_one_add_X_pow] + +private theorem coeff_one_sub_X_pow (p n : ℕ) : + coeff n ((1 - X : ℂ⟦X⟧) ^ p) = (-1 : ℂ) ^ n * (p.choose n : ℂ) := by + have h : rescale (-1 : ℂ) ((1 + X) ^ p) = (1 - X) ^ p := by + rw [map_pow, map_add, map_one, rescale_neg_one_X] + ring + rw [← h, coeff_rescale, coeff_one_add_X_pow] + +/-! ### The differential equation of the super series -/ + +private theorem one_sub_X_mul_geom : + (1 - X : ℂ⟦X⟧) * PowerSeries.mk (fun _ => (1 : ℂ)) = 1 := by + ext n + rw [sub_mul, one_mul, map_sub] + cases n with + | zero => simp + | succ m => simp [coeff_succ_X_mul] + +private theorem one_add_X_mul_alt : + (1 + X : ℂ⟦X⟧) * PowerSeries.mk (fun n => (-1 : ℂ) ^ n) = 1 := by + ext n + rw [add_mul, one_mul, map_add] + cases n with + | zero => simp + | succ m => + rw [coeff_succ_X_mul, coeff_mk, coeff_mk, coeff_one, + ite_eq_right (Nat.succ_ne_zero m), pow_succ] + ring + +private theorem powerSumSeries_superPS_eq (p q : ℕ) : + powerSumSeries (superPS p q) = + C (p : ℂ) * PowerSeries.mk (fun _ => (1 : ℂ)) + + C (q : ℂ) * PowerSeries.mk (fun n => (-1 : ℂ) ^ n) := by + ext n + simp only [powerSumSeries, superPS, map_add, coeff_C_mul, coeff_mk, + pow_succ] + ring + +private theorem key_poly_identity (p q : ℕ) : + (1 - X) * ((1 + X) * powerSumSeries (superPS p q)) = + C (p : ℂ) * (1 + X) + C (q : ℂ) * (1 - X) := by + rw [powerSumSeries_superPS_eq] + linear_combination (C (p : ℂ) * (1 + X)) * one_sub_X_mul_geom + + (C (q : ℂ) * (1 - X)) * one_add_X_mul_alt + +private theorem one_sub_X_mul_derivative_pow (p : ℕ) : + (1 - X) * (PowerSeries.derivative (R := ℂ)) ((1 - X : ℂ⟦X⟧) ^ p) = + -(C (p : ℂ)) * (1 - X) ^ p := by + induction p with + | zero => + rw [pow_zero, Derivation.map_one_eq_zero, mul_zero, Nat.cast_zero, + map_zero, neg_zero, zero_mul] + | succ m ih => + have hD : (PowerSeries.derivative (R := ℂ)) (1 - X : ℂ⟦X⟧) = -1 := by + rw [Derivation.map_sub, derivative_X, Derivation.map_one_eq_zero, + zero_sub] + have hC : ((m + 1 : ℕ) : ℂ) = (m : ℂ) + 1 := by push_cast; ring + rw [pow_succ, Derivation.leibniz, smul_eq_mul, smul_eq_mul, hD, hC, + map_add, map_one] + linear_combination (1 - X) * ih + +private theorem superSeries_ode (p q : ℕ) : + (1 + X) * (PowerSeries.derivative (R := ℂ)) ((1 - X) ^ p * newtonHSeries (superPS p q)) = + C (q : ℂ) * ((1 - X) ^ p * newtonHSeries (superPS p q)) := by + have hunit : IsUnit (1 - X : ℂ⟦X⟧) := + IsUnit.of_mul_eq_one _ one_sub_X_mul_geom + refine hunit.mul_right_inj.mp ?_ + have hprod : (PowerSeries.derivative (R := ℂ)) ((1 - X) ^ p * newtonHSeries (superPS p q)) = + (1 - X) ^ p * + (powerSumSeries (superPS p q) * newtonHSeries (superPS p q)) + + newtonHSeries (superPS p q) * (PowerSeries.derivative (R := ℂ)) ((1 - X : ℂ⟦X⟧) ^ p) := by + rw [Derivation.leibniz, smul_eq_mul, smul_eq_mul, newtonH_derivative] + rw [hprod] + linear_combination + ((1 - X) ^ p * newtonHSeries (superPS p q)) * key_poly_identity p q + + ((1 + X) * newtonHSeries (superPS p q)) * + one_sub_X_mul_derivative_pow p + +private theorem superSeries_constantCoeff (p q : ℕ) : + constantCoeff ((1 - X) ^ p * newtonHSeries (superPS p q)) = 1 := by + rw [map_mul, map_pow, map_sub, map_one, constantCoeff_X, sub_zero, + one_pow, newtonH_series_constantCoeff, mul_one] + +/-- Any power series `F` with `(1 + X) · F′ = q · F` and constant +coefficient `1` has coefficients `C(q, n)`, by the coefficient +recursion `(n + 1) · F_{n+1} = (q − n) · F_n`. -/ +private theorem coeff_eq_choose_of_ode {q : ℕ} {F : ℂ⟦X⟧} + (h0 : constantCoeff F = 1) + (hode : (1 + X) * (PowerSeries.derivative (R := ℂ)) F = C (q : ℂ) * F) : + ∀ n, coeff n F = (q.choose n : ℂ) := by + intro n + induction n with + | zero => + rw [coeff_zero_eq_constantCoeff_apply, h0, Nat.choose_zero_right, + Nat.cast_one] + | succ m ih => + have h := congrArg (coeff m) hode + rw [add_mul, one_mul, map_add, coeff_derivative, coeff_C_mul] at h + have hX : coeff m (X * (PowerSeries.derivative (R := ℂ)) F) = (m : ℂ) * coeff m F := by + cases m with + | zero => rw [coeff_zero_X_mul, Nat.cast_zero, zero_mul] + | succ k => + rw [coeff_succ_X_mul, coeff_derivative] + push_cast + ring + rw [hX, ih] at h + have hrec : ((m : ℂ) + 1) * (q.choose (m + 1) : ℂ) = + ((q : ℂ) - (m : ℂ)) * (q.choose m : ℂ) := by + rcases lt_or_ge m q with hlt | hge + · have hc := congrArg (Nat.cast (R := ℂ)) + (Nat.choose_succ_right_eq q m) + push_cast [Nat.cast_sub hlt.le] at hc + linear_combination hc + · rw [Nat.choose_eq_zero_of_lt (by omega), Nat.cast_zero, mul_zero] + rcases eq_or_lt_of_le hge with heq | hlt + · rw [heq, sub_self, zero_mul] + · rw [Nat.choose_eq_zero_of_lt hlt, Nat.cast_zero, mul_zero] + apply mul_right_cancel₀ (Nat.cast_add_one_ne_zero m : + ((m : ℂ) + 1) ≠ 0) + linear_combination h - hrec + +/-! ### The generating-function identity -/ + +/-- **The super binomial identity.** The generating series of the +complete homogeneous sequence of the super power sums `superPS p q` +satisfies `(1 − X)^p · H = (1 + X)^q` in `ℂ⟦X⟧`. -/ +theorem newtonHSeries_superPS (p q : ℕ) : + (1 - PowerSeries.X) ^ p * newtonHSeries (superPS p q) = + (1 + PowerSeries.X) ^ q := by + ext n + rw [coeff_eq_choose_of_ode (superSeries_constantCoeff p q) + (superSeries_ode p q) n, coeff_one_add_X_pow] + +/-! ### Binomial evaluations -/ + +/-- With `p = 0` the complete homogeneous values are the binomial +coefficients of `(1 + X)^q`. -/ +theorem newtonH_superPS_zero_p (q n : ℕ) : + newtonH (superPS 0 q) n = (q.choose n : ℂ) := by + have h := congrArg (coeff n) (newtonHSeries_superPS 0 q) + rw [pow_zero, one_mul, coeff_one_add_X_pow] at h + simpa [newtonHSeries, coeff_mk] using h + +/-- With `q = 0` and `p` positive the complete homogeneous values are +the binomial coefficients of `(1 − X)^{−p}`. -/ +theorem newtonH_superPS_zero_q (p n : ℕ) (hp : 0 < p) : + newtonH (superPS p 0) n = ((p - 1 + n).choose n : ℂ) := by + have hfun : superPS p 0 = fun _ => (p : ℂ) := by + funext c + simp [superPS] + rw [hfun, newtonH_const, show p + n - 1 = p - 1 + n from by omega] + +/-! ### The recurrence beyond degree `q` -/ + +/-- **The order-`p` recurrence beyond degree `q`**, antidiagonal form: +for `n > q` the convolution of the signed binomial row of `(1 − X)^p` +with the complete homogeneous sequence of `superPS p q` vanishes. -/ +theorem newtonH_superPS_rec_antidiagonal (p q : ℕ) {n : ℕ} + (hn : q < n) : + ∑ ij ∈ Finset.antidiagonal n, + (-1 : ℂ) ^ ij.1 * (p.choose ij.1 : ℂ) * + newtonH (superPS p q) ij.2 = 0 := by + have h := congrArg (coeff n) (newtonHSeries_superPS p q) + rw [coeff_mul, coeff_one_add_X_pow, Nat.choose_eq_zero_of_lt hn, + Nat.cast_zero] at h + rw [← h] + refine Finset.sum_congr rfl fun ij _ => ?_ + rw [coeff_one_sub_X_pow] + simp only [newtonHSeries, coeff_mk] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSmall.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSmall.lean new file mode 100644 index 0000000000..6cc81848a1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSmall.lean @@ -0,0 +1,623 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperRealize + +/-! +# A small model of `SuperVect` + +`RS.SuperVect` is a large category: its objects are pairs of +finite-dimensional complex vector spaces drawn from `Type`, so the +type of objects lives in `Type 1`, while every hom-space is a pair +of linear maps in `Type 0`. The whole Ind-layer — +`RS.indOf`, the `Ind C` instances, and the realization functor +`RS.superRealize` — runs over a *small* preadditive category with +finite colimits and a biproduct-generating pair. This file +supplies the missing bridge. + +* Classification: every super vector space is isomorphic to the + standard object `stdObj (p, q)` — `Fin p → ℂ` in even degree, + `Fin q → ℂ` in odd degree — of its dimension pair (`isoStdObj`). + +* Colimit structure: `SuperVect` has a zero object, all finite + biproducts (componentwise products, `piBicone`), and cokernels + (componentwise quotients, `cokerIsColimit`), hence coequalizers + and all finite colimits. + +* The small model `SmallSuperVect`: the category induced on the + dimension pairs `ℕ × ℕ` by `stdObj`. It is a small category + with `Preadditive`, `Linear ℂ`, and `HasFiniteColimits` + instances, and the inclusion `smallSuperInclusion` is an + equivalence (`smallSuperEquiv`); in particular `SuperVect` is + essentially small relative to `Type 0`. + +* Generators: the images `sEven = (1, 0)` and `sOdd = (0, 1)` of + the unit and the odd line biproduct-generate the small model + (`biproductGenerates_smallSuper`): a `(p, q)`-dimensional object + is the biproduct of `p` copies of the unit and `q` copies of the + odd line. This discharges the hypothesis of + `RS.isZero_of_isZero_superRealize` at `C := SmallSuperVect`. + +The small model is built as an `InducedCategory` on `ℕ × ℕ` +rather than through Mathlib's `SmallModel`: the induced +category's hom-spaces are the hom-spaces of `SuperVect` between +standard objects, wrapped in the one-field structure +`InducedCategory.Hom`, so smallness, `Preadditive`, `Linear ℂ`, +and full faithfulness of the inclusion are existing Mathlib +instances, whereas `SmallModel` (a skeleton quotient) would need +every instance conjugated across `equivSmallModel`. Mathlib's +`EssentiallySmall`/`SmallModel`/`equivSmallModel` API, the +biproduct machinery (`Bicone`, `isBilimitOfTotal`, +`biproduct.uniqueUpToIso`, `biproduct.reindex`), and the colimit +constructions (`Preadditive.hasCoequalizers_of_hasCokernels`, +`hasFiniteColimits_of_hasCoequalizers_and_finite_coproducts`) are +all reachable through the funnel; `isBilimitOfTotal` lives in the +root `CategoryTheory.Limits` namespace, not on `Bicone`. +-/ + +@[expose] public section + +namespace RS + +noncomputable section + +open CategoryTheory Limits + +namespace SuperVect + +/-! ### Standard objects and the classification by dimension -/ + +/-- The standard super vector space of a dimension pair: +`Fin p → ℂ` in even degree and `Fin q → ℂ` in odd degree. Every +super vector space is isomorphic to exactly one standard object, +which is the entire content of the small model below. -/ +def stdObj (pq : ℕ × ℕ) : SuperVect where + even := Fin pq.1 → ℂ + odd := Fin pq.2 → ℂ + +/-- The even component of a standard object. -/ +@[simp] +theorem stdObj_even (pq : ℕ × ℕ) : + (stdObj pq).even = (Fin pq.1 → ℂ) := rfl + +/-- The odd component of a standard object. -/ +@[simp] +theorem stdObj_odd (pq : ℕ × ℕ) : + (stdObj pq).odd = (Fin pq.2 → ℂ) := rfl + +/-- Componentwise linear equivalences assemble to an isomorphism +of super vector spaces. -/ +def isoOfEquivs {V W : SuperVect} (e : V.even ≃ₗ[ℂ] W.even) + (o : V.odd ≃ₗ[ℂ] W.odd) : V ≅ W where + hom := ⟨e.toLinearMap, o.toLinearMap⟩ + inv := ⟨e.symm.toLinearMap, o.symm.toLinearMap⟩ + hom_inv_id := hom_ext + (LinearMap.ext fun x => e.symm_apply_apply x) + (LinearMap.ext fun x => o.symm_apply_apply x) + inv_hom_id := hom_ext + (LinearMap.ext fun x => e.apply_symm_apply x) + (LinearMap.ext fun x => o.apply_symm_apply x) + +/-- **Classification of super vector spaces**: every object of +`SuperVect` is isomorphic to the standard object of its dimension +pair, componentwise by `LinearEquiv.ofFinrankEq`. -/ +def isoStdObj (V : SuperVect) : + V ≅ stdObj (Module.finrank ℂ V.even, Module.finrank ℂ V.odd) := + isoOfEquivs + (LinearEquiv.ofFinrankEq _ _ (Module.finrank_fin_fun ℂ).symm) + (LinearEquiv.ofFinrankEq _ _ (Module.finrank_fin_fun ℂ).symm) + +/-! ### Subsingleton hom-spaces -/ + +/-- The even component of a purely odd standard object is +trivial. -/ +instance (q : ℕ) : Subsingleton (stdObj (0, q)).even := + inferInstanceAs (Subsingleton (Fin 0 → ℂ)) + +/-- The odd component of a purely even standard object is +trivial. -/ +instance (p : ℕ) : Subsingleton (stdObj (p, 0)).odd := + inferInstanceAs (Subsingleton (Fin 0 → ℂ)) + +/-- Hom-spaces whose component spaces of linear maps are +subsingletons are themselves subsingletons: this recognises the +zero object and kills the mixed-parity morphisms between the two +generator lines. -/ +theorem hom_eq_of_subsingleton {V W : SuperVect} + (he : Subsingleton (V.even →ₗ[ℂ] W.even)) + (ho : Subsingleton (V.odd →ₗ[ℂ] W.odd)) (f g : V ⟶ W) : + f = g := + hom_ext (he.elim _ _) (ho.elim _ _) + +/-- A subsingleton instance form of `hom_eq_of_subsingleton`. -/ +instance homSubsingleton {V W : SuperVect} + [Subsingleton (V.even →ₗ[ℂ] W.even)] + [Subsingleton (V.odd →ₗ[ℂ] W.odd)] : Subsingleton (V ⟶ W) := + ⟨fun f g => hom_eq_of_subsingleton ‹_› ‹_› f g⟩ + +/-! ### The zero object -/ + +/-- The standard object of dimensions `(0, 0)` is a zero +object. -/ +theorem isZero_stdObj_zero : IsZero (stdObj (0, 0)) := by + constructor + · exact fun Y => ⟨⟨⟨0⟩, fun f => Subsingleton.elim f 0⟩⟩ + · exact fun Y => ⟨⟨⟨0⟩, fun f => Subsingleton.elim f 0⟩⟩ + +/-- `SuperVect` has a zero object. -/ +instance : HasZeroObject SuperVect := + ⟨stdObj (0, 0), isZero_stdObj_zero⟩ + +/-! ### Finite biproducts -/ + +/-- The sum of the coordinate inclusion-projection round trips on +a finite product of modules is the identity. -/ +theorem sum_single_comp_proj {ι : Type} [Fintype ι] [DecidableEq ι] + (φ : ι → Type) [∀ i, AddCommGroup (φ i)] [∀ i, Module ℂ (φ i)] : + ∑ j, (LinearMap.single ℂ φ j ∘ₗ LinearMap.proj j) = + (LinearMap.id : (∀ i, φ i) →ₗ[ℂ] ∀ i, φ i) := by + refine LinearMap.ext fun x => ?_ + simp [LinearMap.sum_apply, Finset.univ_sum_single] + +/-- The componentwise product of a finite family of super vector +spaces: the biproduct candidate. -/ +def piObj {n : ℕ} (f : Fin n → SuperVect) : SuperVect where + even := ∀ j, (f j).even + odd := ∀ j, (f j).odd + +/-- The componentwise bicone over a finite family: coordinate +projections and inclusions in each degree. -/ +def piBicone {n : ℕ} (f : Fin n → SuperVect) : Bicone f where + pt := piObj f + π j := ⟨LinearMap.proj (φ := fun i => (f i).even) j, + LinearMap.proj (φ := fun i => (f i).odd) j⟩ + ι j := ⟨LinearMap.single ℂ (fun i => (f i).even) j, + LinearMap.single ℂ (fun i => (f i).odd) j⟩ + ι_π j j' := by + rcases eq_or_ne j j' with rfl | hne + · rw [dite_eq_left rfl, eqToHom_refl] + refine hom_ext (LinearMap.ext fun x => ?_) + (LinearMap.ext fun x => ?_) + · change Pi.single (M := fun i => (f i).even) j x j = x + exact Pi.single_eq_same (M := fun i => (f i).even) j x + · change Pi.single (M := fun i => (f i).odd) j x j = x + exact Pi.single_eq_same (M := fun i => (f i).odd) j x + · rw [dite_eq_right hne] + refine hom_ext (LinearMap.ext fun x => ?_) + (LinearMap.ext fun x => ?_) + · change Pi.single (M := fun i => (f i).even) j x j' = 0 + exact Pi.single_eq_of_ne (M := fun i => (f i).even) hne.symm x + · change Pi.single (M := fun i => (f i).odd) j x j' = 0 + exact Pi.single_eq_of_ne (M := fun i => (f i).odd) hne.symm x + +/-- Taking the even component of a morphism is additive. -/ +def evenMapAddHom (V W : SuperVect) : + (V ⟶ W) →+ (V.even →ₗ[ℂ] W.even) where + toFun f := f.evenMap + map_zero' := rfl + map_add' _ _ := rfl + +/-- Taking the odd component of a morphism is additive. -/ +def oddMapAddHom (V W : SuperVect) : + (V ⟶ W) →+ (V.odd →ₗ[ℂ] W.odd) where + toFun f := f.oddMap + map_zero' := rfl + map_add' _ _ := rfl + +/-- The even component of a finite sum of morphisms is the sum of +the even components. -/ +theorem sum_evenMap {α : Type*} (s : Finset α) {V W : SuperVect} + (f : α → (V ⟶ W)) : + (∑ i ∈ s, f i).evenMap = ∑ i ∈ s, (f i).evenMap := + map_sum (evenMapAddHom V W) f s + +/-- The odd component of a finite sum of morphisms is the sum of +the odd components. -/ +theorem sum_oddMap {α : Type*} (s : Finset α) {V W : SuperVect} + (f : α → (V ⟶ W)) : + (∑ i ∈ s, f i).oddMap = ∑ i ∈ s, (f i).oddMap := + map_sum (oddMapAddHom V W) f s + +/-- The componentwise bicone is a bilimit: the coordinate round +trips sum to the identity in each degree. -/ +def piBiconeIsBilimit {n : ℕ} (f : Fin n → SuperVect) : + (piBicone f).IsBilimit := by + refine isBilimitOfTotal _ (hom_ext ?_ ?_) + · rw [sum_evenMap] + exact sum_single_comp_proj fun i => (f i).even + · rw [sum_oddMap] + exact sum_single_comp_proj fun i => (f i).odd + +/-- `SuperVect` has all finite biproducts, componentwise. -/ +instance : HasFiniteBiproducts SuperVect where + out _ := + { has_biproduct := fun f => + HasBiproduct.mk ⟨piBicone f, piBiconeIsBilimit f⟩ } + +/-! ### Cokernels and finite colimits -/ + +/-- The componentwise cokernel object of a morphism: the quotient +by the range in each degree. -/ +def cokerObj {V W : SuperVect} (f : V ⟶ W) : SuperVect where + even := W.even ⧸ LinearMap.range f.evenMap + odd := W.odd ⧸ LinearMap.range f.oddMap + +/-- The projection onto the componentwise cokernel. -/ +def cokerπ {V W : SuperVect} (f : V ⟶ W) : W ⟶ cokerObj f where + evenMap := (LinearMap.range f.evenMap).mkQ + oddMap := (LinearMap.range f.oddMap).mkQ + +/-- The cokernel projection annihilates the morphism. -/ +theorem comp_cokerπ {V W : SuperVect} (f : V ⟶ W) : + f ≫ cokerπ f = 0 := + hom_ext + (LinearMap.ext fun x => + (Submodule.Quotient.mk_eq_zero _).mpr + (LinearMap.mem_range_self f.evenMap x)) + (LinearMap.ext fun x => + (Submodule.Quotient.mk_eq_zero _).mpr + (LinearMap.mem_range_self f.oddMap x)) + +/-- Descent through the componentwise cokernel: a morphism +annihilating `f` factors through the quotient in each degree. -/ +def cokerDesc {V W Z : SuperVect} (f : V ⟶ W) (g : W ⟶ Z) + (hg : f ≫ g = 0) : cokerObj f ⟶ Z where + evenMap := (LinearMap.range f.evenMap).liftQ g.evenMap + (LinearMap.range_le_ker_iff.mpr (congrArg Hom.evenMap hg)) + oddMap := (LinearMap.range f.oddMap).liftQ g.oddMap + (LinearMap.range_le_ker_iff.mpr (congrArg Hom.oddMap hg)) + +/-- The componentwise cokernel is a categorical cokernel. -/ +def cokerIsColimit {V W : SuperVect} (f : V ⟶ W) : + IsColimit (CokernelCofork.ofπ (cokerπ f) (comp_cokerπ f)) := + CokernelCofork.IsColimit.ofπ _ _ + (fun g hg => cokerDesc f g hg) + (fun _ _ => hom_ext + (Submodule.liftQ_mkQ _ _ _) + (Submodule.liftQ_mkQ _ _ _)) + (fun _ _ _ hm => hom_ext + ((LinearMap.range f.evenMap).linearMap_qext + ((congrArg Hom.evenMap hm).trans + (Submodule.liftQ_mkQ _ _ _).symm)) + ((LinearMap.range f.oddMap).linearMap_qext + ((congrArg Hom.oddMap hm).trans + (Submodule.liftQ_mkQ _ _ _).symm))) + +/-- `SuperVect` has all cokernels, componentwise. -/ +instance : HasCokernels SuperVect where + has_colimit f := HasColimit.mk ⟨_, cokerIsColimit f⟩ + +/-- `SuperVect` has coequalizers: in a preadditive category they +are cokernels of differences. -/ +instance : HasCoequalizers SuperVect := + Preadditive.hasCoequalizers_of_hasCokernels + +/-- **`SuperVect` has all finite colimits**: finite coproducts +come from the componentwise biproducts and coequalizers from the +componentwise cokernels. -/ +instance : HasFiniteColimits SuperVect := + hasFiniteColimits_of_hasCoequalizers_and_finite_coproducts + +/-! ### The generator lines -/ + +/-- The inclusion of the even line at coordinate `i`: the even +component places the scalar at coordinate `i`, the odd component +is zero. -/ +def evenLineIn (p q : ℕ) (i : Fin p) : + stdObj (1, 0) ⟶ stdObj (p, q) where + evenMap := LinearMap.single ℂ (fun _ : Fin p => ℂ) i ∘ₗ + LinearMap.proj (φ := fun _ : Fin 1 => ℂ) 0 + oddMap := 0 + +/-- The projection onto the even line at coordinate `i`. -/ +def evenLinePrj (p q : ℕ) (i : Fin p) : + stdObj (p, q) ⟶ stdObj (1, 0) where + evenMap := LinearMap.single ℂ (fun _ : Fin 1 => ℂ) 0 ∘ₗ + LinearMap.proj (φ := fun _ : Fin p => ℂ) i + oddMap := 0 + +/-- The inclusion of the odd line at coordinate `j`. -/ +def oddLineIn (p q : ℕ) (j : Fin q) : + stdObj (0, 1) ⟶ stdObj (p, q) where + evenMap := 0 + oddMap := LinearMap.single ℂ (fun _ : Fin q => ℂ) j ∘ₗ + LinearMap.proj (φ := fun _ : Fin 1 => ℂ) 0 + +/-- The projection onto the odd line at coordinate `j`. -/ +def oddLinePrj (p q : ℕ) (j : Fin q) : + stdObj (p, q) ⟶ stdObj (0, 1) where + evenMap := 0 + oddMap := LinearMap.single ℂ (fun _ : Fin 1 => ℂ) 0 ∘ₗ + LinearMap.proj (φ := fun _ : Fin q => ℂ) j + +/-- The even-line round trip through `stdObj (p, q)` at equal +coordinates is the identity. -/ +theorem evenLineIn_comp_prj_same (p q : ℕ) (i : Fin p) : + evenLineIn p q i ≫ evenLinePrj p q i = 𝟙 (stdObj (1, 0)) := by + refine hom_ext (LinearMap.ext fun x => funext fun k => ?_) + (Subsingleton.elim _ _) + obtain rfl : k = 0 := Subsingleton.elim k 0 + change Pi.single (M := fun _ : Fin 1 => ℂ) 0 + (Pi.single (M := fun _ : Fin p => ℂ) i (x 0) i) 0 = x 0 + simp [Pi.single_eq_same] + +/-- The even-line round trip at distinct coordinates vanishes. -/ +theorem evenLineIn_comp_prj_ne (p q : ℕ) {i i' : Fin p} + (h : i ≠ i') : evenLineIn p q i ≫ evenLinePrj p q i' = 0 := by + refine hom_ext (LinearMap.ext fun x => funext fun k => ?_) + (Subsingleton.elim _ _) + change Pi.single (M := fun _ : Fin 1 => ℂ) 0 + (Pi.single (M := fun _ : Fin p => ℂ) i (x 0) i') k = 0 + rw [Pi.single_eq_of_ne (Ne.symm h), Pi.single_zero] + rfl + +/-- The odd-line round trip at equal coordinates is the +identity. -/ +theorem oddLineIn_comp_prj_same (p q : ℕ) (j : Fin q) : + oddLineIn p q j ≫ oddLinePrj p q j = 𝟙 (stdObj (0, 1)) := by + refine hom_ext (Subsingleton.elim _ _) + (LinearMap.ext fun x => funext fun k => ?_) + obtain rfl : k = 0 := Subsingleton.elim k 0 + change Pi.single (M := fun _ : Fin 1 => ℂ) 0 + (Pi.single (M := fun _ : Fin q => ℂ) j (x 0) j) 0 = x 0 + simp [Pi.single_eq_same] + +/-- The odd-line round trip at distinct coordinates vanishes. -/ +theorem oddLineIn_comp_prj_ne (p q : ℕ) {j j' : Fin q} + (h : j ≠ j') : oddLineIn p q j ≫ oddLinePrj p q j' = 0 := by + refine hom_ext (Subsingleton.elim _ _) + (LinearMap.ext fun x => funext fun k => ?_) + change Pi.single (M := fun _ : Fin 1 => ℂ) 0 + (Pi.single (M := fun _ : Fin q => ℂ) j (x 0) j') k = 0 + rw [Pi.single_eq_of_ne (Ne.symm h), Pi.single_zero] + rfl + +/-- Mixed-parity composites vanish: even line into odd line. -/ +theorem evenLineIn_comp_oddPrj (p q : ℕ) (i : Fin p) (j : Fin q) : + evenLineIn p q i ≫ oddLinePrj p q j = 0 := + hom_eq_of_subsingleton inferInstance inferInstance _ _ + +/-- Mixed-parity composites vanish: odd line into even line. -/ +theorem oddLineIn_comp_evenPrj (p q : ℕ) (i : Fin p) (j : Fin q) : + oddLineIn p q j ≫ evenLinePrj p q i = 0 := + hom_eq_of_subsingleton inferInstance inferInstance _ _ + +/-- The even component of the even-line +projection-then-inclusion round trip through the point is the +coordinate round trip. -/ +theorem evenLinePrj_comp_in_evenMap (p q : ℕ) (i : Fin p) : + (evenLinePrj p q i ≫ evenLineIn p q i).evenMap = + LinearMap.single ℂ (fun _ : Fin p => ℂ) i ∘ₗ + LinearMap.proj (φ := fun _ : Fin p => ℂ) i := by + refine LinearMap.ext fun x => funext fun k => ?_ + change Pi.single (M := fun _ : Fin p => ℂ) i + (Pi.single (M := fun _ : Fin 1 => ℂ) 0 (x i) 0) k = + Pi.single (M := fun _ : Fin p => ℂ) i (x i) k + rw [Pi.single_eq_same] + +/-- The odd component of the even-line round trip through the +point vanishes. -/ +theorem evenLinePrj_comp_in_oddMap (p q : ℕ) (i : Fin p) : + (evenLinePrj p q i ≫ evenLineIn p q i).oddMap = 0 := + LinearMap.zero_comp 0 + +/-- The odd component of the odd-line +projection-then-inclusion round trip through the point is the +coordinate round trip. -/ +theorem oddLinePrj_comp_in_oddMap (p q : ℕ) (j : Fin q) : + (oddLinePrj p q j ≫ oddLineIn p q j).oddMap = + LinearMap.single ℂ (fun _ : Fin q => ℂ) j ∘ₗ + LinearMap.proj (φ := fun _ : Fin q => ℂ) j := by + refine LinearMap.ext fun x => funext fun k => ?_ + change Pi.single (M := fun _ : Fin q => ℂ) j + (Pi.single (M := fun _ : Fin 1 => ℂ) 0 (x j) 0) k = + Pi.single (M := fun _ : Fin q => ℂ) j (x j) k + rw [Pi.single_eq_same] + +/-- The even component of the odd-line round trip through the +point vanishes. -/ +theorem oddLinePrj_comp_in_evenMap (p q : ℕ) (j : Fin q) : + (oddLinePrj p q j ≫ oddLineIn p q j).evenMap = 0 := + LinearMap.zero_comp 0 + +/-- **The line decomposition of a standard object**: the sum of +all line round trips through `stdObj (p, q)` is the identity. -/ +theorem lines_total (p q : ℕ) : + (∑ i : Fin p, evenLinePrj p q i ≫ evenLineIn p q i) + + (∑ j : Fin q, oddLinePrj p q j ≫ oddLineIn p q j) = + 𝟙 (stdObj (p, q)) := by + refine hom_ext ?_ ?_ + · rw [add_evenMap, sum_evenMap, sum_evenMap, + Finset.sum_congr rfl fun i _ => evenLinePrj_comp_in_evenMap p q i, + Finset.sum_congr rfl fun j _ => oddLinePrj_comp_in_evenMap p q j, + Finset.sum_const_zero, add_zero] + exact sum_single_comp_proj fun _ => ℂ + · rw [add_oddMap, sum_oddMap, sum_oddMap, + Finset.sum_congr rfl fun i _ => evenLinePrj_comp_in_oddMap p q i, + Finset.sum_congr rfl fun j _ => oddLinePrj_comp_in_oddMap p q j, + Finset.sum_const_zero, zero_add] + exact sum_single_comp_proj fun _ => ℂ + +end SuperVect + +/-! ## The small model -/ + +/-- **The small model of `SuperVect`**: the category induced on +the type `ℕ × ℕ` of dimension pairs by the standard objects. Its +hom-spaces are the hom-spaces of `SuperVect` between standard +objects (wrapped in `InducedCategory.homMk`), so smallness, +`Preadditive`, `Linear ℂ`, and full faithfulness of the inclusion +are all Mathlib instances on `InducedCategory` — the choice of an +induced category over Mathlib's `SmallModel` (a skeleton +quotient, which would need every instance conjugated across +`equivSmallModel`) is what makes them free. -/ +abbrev SmallSuperVect : Type := + InducedCategory SuperVect SuperVect.stdObj + +/-- The inclusion of the small model into `SuperVect`, sending a +dimension pair to its standard object. An abbreviation so that +the `InducedCategory` instances (full, faithful, additive) apply +to it directly. -/ +abbrev smallSuperInclusion : SmallSuperVect ⥤ SuperVect := + inducedFunctor SuperVect.stdObj + +/-- The inclusion of the small model is essentially surjective: +every super vector space is standard up to isomorphism. -/ +instance : smallSuperInclusion.EssSurj where + mem_essImage V := + ⟨(Module.finrank ℂ V.even, Module.finrank ℂ V.odd), + ⟨(SuperVect.isoStdObj V).symm⟩⟩ + +/-- The inclusion of the small model is an equivalence: fully +faithful and essentially surjective. -/ +instance : smallSuperInclusion.IsEquivalence := {} + +/-- **The small-model equivalence**: the small model is equivalent +to `SuperVect`. -/ +def smallSuperEquiv : SmallSuperVect ≌ SuperVect := + smallSuperInclusion.asEquivalence + +/-- **`SuperVect` is essentially small** relative to `Type 0`: the +small model is a witness. -/ +instance : EssentiallySmall.{0} SuperVect := + ⟨⟨SmallSuperVect, inferInstance, ⟨smallSuperEquiv.symm⟩⟩⟩ + +/-- The small model has all finite colimits, transported across +the inclusion equivalence from the componentwise colimits of +`SuperVect`. -/ +instance : HasFiniteColimits SmallSuperVect := + ⟨fun _ _ _ => + Adjunction.hasColimitsOfShape_of_equivalence smallSuperInclusion⟩ + +/-! ## The generator pair -/ + +/-- The even generator of the small model: the unit line +`(1, 0)`, whose standard object is the monoidal unit of +`SuperVect` up to isomorphism (`sEvenIso`). -/ +def sEven : SmallSuperVect := (1, 0) + +/-- The odd generator of the small model: the odd line +`(0, 1)`. -/ +def sOdd : SmallSuperVect := (0, 1) + +/-- Any two subsingleton ℂ-modules are linearly equivalent by the +zero map. -/ +def zeroLinearEquiv (M N : Type) [AddCommGroup M] [Module ℂ M] + [AddCommGroup N] [Module ℂ N] [Subsingleton M] + [Subsingleton N] : M ≃ₗ[ℂ] N where + toFun _ := 0 + map_add' _ _ := (add_zero 0).symm + map_smul' c _ := (smul_zero c).symm + invFun _ := 0 + left_inv _ := Subsingleton.elim _ _ + right_inv _ := Subsingleton.elim _ _ + +open MonoidalCategory in +/-- The standard object of the even generator is the monoidal +unit of `SuperVect`: `Fin 1 → ℂ` is the scalar line and the odd +component is trivial. -/ +def sEvenIso : smallSuperInclusion.obj sEven ≅ 𝟙_ SuperVect := + haveI : Subsingleton (𝟙_ SuperVect).odd := + inferInstanceAs (Subsingleton PUnit) + haveI : Subsingleton (smallSuperInclusion.obj sEven).odd := + inferInstanceAs (Subsingleton (Fin 0 → ℂ)) + SuperVect.isoOfEquivs (LinearEquiv.funUnique (Fin 1) ℂ ℂ) + (zeroLinearEquiv _ _) + +/-! ## Biproduct generation -/ + +/-- The parity word of the generating decomposition of `(p, q)`: +the first `p` letters select the even generator, the last `q` the +odd one. -/ +def genWord (p q : ℕ) (s : Fin p ⊕ Fin q) : Bool := + Sum.elim (fun _ => false) (fun _ => true) s + +/-- The sum-indexed generator family underlying the generating +biproduct decomposition of `(p, q)`. -/ +def genFamily (p q : ℕ) (s : Fin p ⊕ Fin q) : SmallSuperVect := + generatorPair sEven sOdd (genWord p q s) + +/-- The underlying morphism of the zero morphism of the small +model is zero. -/ +theorem smallZero_hom {X Y : SmallSuperVect} : + (0 : X ⟶ Y).hom = 0 := by + have h := map_zero (InducedCategory.homAddEquiv + (C := SuperVect) (F := SuperVect.stdObj) (X := X) (Y := Y)) + simpa using h + +/-- The generating bicone: `(p, q)` carries the line inclusions +and projections over the sum-indexed generator family. -/ +def genBicone (p q : ℕ) : Bicone (genFamily p q) where + pt := ((p, q) : SmallSuperVect) + π s := match s with + | .inl i => InducedCategory.homMk (SuperVect.evenLinePrj p q i) + | .inr j => InducedCategory.homMk (SuperVect.oddLinePrj p q j) + ι s := match s with + | .inl i => InducedCategory.homMk (SuperVect.evenLineIn p q i) + | .inr j => InducedCategory.homMk (SuperVect.oddLineIn p q j) + ι_π s t := by + rcases s with i | j <;> rcases t with i' | j' + · rcases eq_or_ne i i' with rfl | hne + · rw [dite_eq_left rfl, eqToHom_refl] + exact InducedCategory.hom_ext + (SuperVect.evenLineIn_comp_prj_same p q i) + · rw [dite_eq_right fun h => hne (Sum.inl.inj h)] + refine InducedCategory.hom_ext ?_ + rw [smallZero_hom] + exact SuperVect.evenLineIn_comp_prj_ne p q hne + · rw [dite_eq_right (Sum.inl_ne_inr)] + refine InducedCategory.hom_ext ?_ + rw [smallZero_hom] + exact SuperVect.evenLineIn_comp_oddPrj p q i j' + · rw [dite_eq_right (Sum.inr_ne_inl)] + refine InducedCategory.hom_ext ?_ + rw [smallZero_hom] + exact SuperVect.oddLineIn_comp_evenPrj p q i' j + · rcases eq_or_ne j j' with rfl | hne + · rw [dite_eq_left rfl, eqToHom_refl] + exact InducedCategory.hom_ext + (SuperVect.oddLineIn_comp_prj_same p q j) + · rw [dite_eq_right fun h => hne (Sum.inr.inj h)] + refine InducedCategory.hom_ext ?_ + rw [smallZero_hom] + exact SuperVect.oddLineIn_comp_prj_ne p q hne + +/-- The generating bicone is a bilimit: the line round trips sum +to the identity. -/ +def genBiconeIsBilimit (p q : ℕ) : (genBicone p q).IsBilimit := by + refine isBilimitOfTotal _ (InducedCategory.hom_ext ?_) + have hsum : (∑ s : Fin p ⊕ Fin q, + (genBicone p q).π s ≫ (genBicone p q).ι s).hom = + ∑ s : Fin p ⊕ Fin q, + ((genBicone p q).π s ≫ (genBicone p q).ι s).hom := + map_sum (InducedCategory.homAddEquiv + (C := SuperVect) (F := SuperVect.stdObj)) _ Finset.univ + rw [hsum, Fintype.sum_sum_type] + exact SuperVect.lines_total p q + +attribute [local instance] HasFiniteBiproducts.of_hasFiniteCoproducts + +/-- **Biproduct generation for the small model**: every dimension +pair is a finite biproduct of copies of the unit line and the odd +line — `(p, q)` decomposes as `p` copies of `sEven` followed by +`q` copies of `sOdd`. This discharges the generation hypothesis +of `RS.isZero_of_isZero_superRealize` at `C := SmallSuperVect`. -/ +theorem biproductGenerates_smallSuper : + BiproductGenerates (generatorPair sEven sOdd) := by + intro X + obtain ⟨p, q⟩ := X + refine ⟨p + q, fun j => genWord p q (finSumFinEquiv.symm j), ?_⟩ + have : HasBiproduct (genFamily p q) := + HasBiproduct.mk ⟨genBicone p q, genBiconeIsBilimit p q⟩ + exact ⟨biproduct.uniqueUpToIso (genFamily p q) + (genBiconeIsBilimit p q) ≪≫ + (biproduct.reindex finSumFinEquiv.symm (genFamily p q)).symm⟩ + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperValues.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperValues.lean new file mode 100644 index 0000000000..04aea6f87d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperValues.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermRepChar + +/-! +# Schur specialisations at super power sums are multiplicities + +The additive splitting identity decomposes `superPS p q` as +`superPS p 0 + superPS 0 q`; both one-sided values are intertwiner +dimensions, and the induction multiplicities are natural numbers, +so every Schur specialisation at a super power sum is a natural +number — the full nonnegativity input for the hook arguments of +Deligne 1.10/1.12. +-/ + +@[expose] public section + +namespace RS + +/-- A finite sum of natural values is a natural value. -/ +theorem exists_nat_sum {ι : Type*} (s : Finset ι) (f : ι → ℂ) + (h : ∀ i ∈ s, ∃ m : ℕ, f i = m) : + ∃ M : ℕ, ∑ i ∈ s, f i = M := by + classical + induction s using Finset.induction_on with + | empty => exact ⟨0, by simp⟩ + | insert a s ha ih => + obtain ⟨m, hm⟩ := h a (Finset.mem_insert_self a s) + obtain ⟨M, hM⟩ := ih fun i hi => + h i (Finset.mem_insert_of_mem hi) + exact ⟨m + M, by + rw [Finset.sum_insert ha, hm, hM, Nat.cast_add]⟩ + +/-- **Schur specialisations at super power sums are natural +numbers**: the two-sided value splits into one-sided multiplicities +through the additive identity. -/ +theorem diagramSchur_superPS_exists_nat (p q : ℕ) + (lam : YoungDiagram) : + ∃ m : ℕ, diagramSchur lam (superPS p q) = m := by + have hsplit : superPS p q = + fun c => superPS p 0 c + superPS 0 q c := by + funext c + simp [superPS] + rw [hsplit, diagramSchur_add] + refine exists_nat_sum _ _ fun ab _ => ?_ + refine exists_nat_sum _ _ fun μ _ => ?_ + refine exists_nat_sum _ _ fun ν _ => ?_ + obtain ⟨m₁, h₁⟩ := indMult_exists_nat + (⟨lam, (Finset.mem_antidiagonal.mp ab.2).symm⟩ : + Shape (ab.1.1 + ab.1.2)) μ ν + obtain ⟨m₂, h₂⟩ := diagramSchur_superPS_h_exists_nat p μ + obtain ⟨m₃, h₃⟩ := diagramSchur_superPS_e_exists_nat q ν + exact ⟨m₁ * m₂ * m₃, by + rw [h₁, h₂, h₃, Nat.cast_mul, Nat.cast_mul]⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean new file mode 100644 index 0000000000..03600d4c6a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean @@ -0,0 +1,1272 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing +public import LeanPool.RegtsSevenster.RS.Classical.Super.TotalSpace + +/-! +# Schur nonvanishing on the standard super vector space + +The nonvanishing half of Deligne 1.9 in `SuperVect`: on the standard +super object of dimension `(p, q)` the central idempotent of every +diagram avoiding the cell `(p, q)` acts nonzero on the tensor power. + +The route is a trace computation. The *super trace functional* +`sTr` — the plain trace of the even and odd components — is linear, +cyclic, and multiplicative for the graded tensor product, so +`σ ↦ sTr (permMor X n σ)` is a class function multiplicative over +block embeddings. A partial-trace identity for the Koszul braiding +(`sTr_swap_conj`) evaluates it on the standard cycles, giving the +character formula `sTr (permMor X n σ) = cycleFun (superPS p q) σ`. +Evaluating `sTr ∘ permAlg` on a package idempotent through the +Frobenius formula then yields `dim λ · s_λ(superPS p q)`, positive by +hook positivity — so the idempotent's action cannot vanish. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open scoped TensorProduct + +noncomputable section + +/-! ## The standard super vector space -/ + +/-- **The standard super vector space of dimension `(p, q)`**: +`ℂ^p` in even degree and `ℂ^q` in odd degree. -/ +def stdSuper (p q : ℕ) : SuperVect where + even := Fin p → ℂ + odd := Fin q → ℂ + +/-- The even component of the standard super object. -/ +@[simp] +theorem stdSuper_even (p q : ℕ) : (stdSuper p q).even = (Fin p → ℂ) := + rfl + +/-- The odd component of the standard super object. -/ +@[simp] +theorem stdSuper_odd (p q : ℕ) : (stdSuper p q).odd = (Fin q → ℂ) := + rfl + +/-! ## The super trace functional + +The plain trace of a grading-preserving endomorphism: the sum of the +traces of its two components. (This is the trace of the underlying +linear endomorphism, not the supertrace; the Koszul signs of the +braiding enter through the action itself.) -/ + +/-- The trace of an endomorphism in `SuperVect`: the sum of the +traces of its even and odd components. -/ +def sTr {V : SuperVect} (f : V ⟶ V) : ℂ := + LinearMap.trace ℂ V.even (SuperVect.Hom.evenMap f) + + LinearMap.trace ℂ V.odd (SuperVect.Hom.oddMap f) + +/-- The super trace as a linear functional on endomorphisms. -/ +def sTrL (V : SuperVect) : (V ⟶ V) →ₗ[ℂ] ℂ where + toFun := sTr + map_add' f g := by + simp [sTr, SuperVect.add_evenMap, SuperVect.add_oddMap] + ring + map_smul' c f := by + simp [sTr, SuperVect.smul_evenMap, SuperVect.smul_oddMap] + ring + +/-- `sTrL` evaluates to `sTr`. -/ +@[simp] +theorem sTrL_apply (V : SuperVect) (f : V ⟶ V) : sTrL V f = sTr f := + rfl + +/-- The super trace of the identity is the total dimension. -/ +theorem sTr_id (V : SuperVect) : + sTr (𝟙 V) = (Module.finrank ℂ V.even : ℂ) + + (Module.finrank ℂ V.odd : ℂ) := by + simp [sTr, SuperVect.cat_id_evenMap, SuperVect.cat_id_oddMap, + LinearMap.trace_id] + +/-- **Cyclicity of the super trace.** -/ +theorem sTr_comp_comm {V W : SuperVect} (f : V ⟶ W) (g : W ⟶ V) : + sTr (f ≫ g) = sTr (g ≫ f) := by + simp only [sTr, SuperVect.cat_comp_evenMap, SuperVect.cat_comp_oddMap] + rw [LinearMap.trace_comp_comm', LinearMap.trace_comp_comm' + (SuperVect.Hom.oddMap f) (SuperVect.Hom.oddMap g)] + +/-- The super trace is invariant under conjugation by an +isomorphism. -/ +theorem sTr_conj {V W : SuperVect} (e : V ≅ W) (f : V ⟶ V) : + sTr (e.inv ≫ f ≫ e.hom) = sTr f := by + rw [sTr_comp_comm, Category.assoc, e.hom_inv_id, Category.comp_id] + +/-- **Multiplicativity of the super trace** for the graded tensor +product of endomorphisms. -/ +theorem sTr_tensorHom {V W : SuperVect} (f : V ⟶ V) (g : W ⟶ W) : + sTr (f ⊗ₘ g) = sTr f * sTr g := by + change sTr (SuperVect.tensorHom f g) = sTr f * sTr g + rw [sTr, SuperVect.tensorHom_evenMap, SuperVect.tensorHom_oddMap] + rw [show LinearMap.trace ℂ (SuperVect.tensorObj V W).even + (LinearMap.prodMap (TensorProduct.map f.evenMap g.evenMap) + (TensorProduct.map f.oddMap g.oddMap)) = + LinearMap.trace ℂ V.even f.evenMap * + LinearMap.trace ℂ W.even g.evenMap + + LinearMap.trace ℂ V.odd f.oddMap * + LinearMap.trace ℂ W.odd g.oddMap from by + change LinearMap.trace ℂ + ((V.even ⊗[ℂ] W.even) × (V.odd ⊗[ℂ] W.odd)) _ = _ + rw [LinearMap.trace_prodMap', LinearMap.trace_tensorProduct', + LinearMap.trace_tensorProduct']] + rw [show LinearMap.trace ℂ (SuperVect.tensorObj V W).odd + (LinearMap.prodMap (TensorProduct.map f.evenMap g.oddMap) + (TensorProduct.map f.oddMap g.evenMap)) = + LinearMap.trace ℂ V.even f.evenMap * + LinearMap.trace ℂ W.odd g.oddMap + + LinearMap.trace ℂ V.odd f.oddMap * + LinearMap.trace ℂ W.even g.evenMap from by + change LinearMap.trace ℂ + ((V.even ⊗[ℂ] W.odd) × (V.odd ⊗[ℂ] W.even)) _ = _ + rw [LinearMap.trace_prodMap', LinearMap.trace_tensorProduct', + LinearMap.trace_tensorProduct']] + rw [sTr, sTr] + ring + +/-! ## The parity involution -/ + +/-- The parity involution of a super vector space: the identity on +the even component and minus the identity on the odd component. -/ +def parHom (V : SuperVect) : V ⟶ V where + evenMap := LinearMap.id + oddMap := -LinearMap.id + +/-- The even component of the parity involution. -/ +@[simp] +theorem parHom_evenMap (V : SuperVect) : + (parHom V).evenMap = LinearMap.id := rfl + +/-- The odd component of the parity involution. -/ +@[simp] +theorem parHom_oddMap (V : SuperVect) : + (parHom V).oddMap = -LinearMap.id := rfl + +/-- The parity involution commutes with every morphism. -/ +theorem parHom_comm {V W : SuperVect} (f : V ⟶ W) : + f ≫ parHom W = parHom V ≫ f := by + apply SuperVect.hom_ext + · simp [SuperVect.cat_comp_evenMap] + · simp [SuperVect.cat_comp_oddMap, LinearMap.comp_neg, + LinearMap.neg_comp] + +/-- The iterated parity involution. -/ +def parPow (V : SuperVect) : ℕ → (V ⟶ V) + | 0 => 𝟙 V + | n + 1 => parPow V n ≫ parHom V + +/-- The even component of the iterated parity involution. -/ +theorem parPow_evenMap (V : SuperVect) (n : ℕ) : + (parPow V n).evenMap = LinearMap.id := by + induction n with + | zero => rfl + | succ n ih => + change ((parPow V n) ≫ parHom V).evenMap = _ + rw [SuperVect.cat_comp_evenMap, parHom_evenMap, ih] + rfl + +/-- The odd component of the iterated parity involution. -/ +theorem parPow_oddMap (V : SuperVect) (n : ℕ) : + (parPow V n).oddMap = ((-1 : ℂ) ^ n) • LinearMap.id := by + induction n with + | zero => simp [parPow, SuperVect.cat_id_oddMap] + | succ n ih => + change ((parPow V n) ≫ parHom V).oddMap = _ + rw [SuperVect.cat_comp_oddMap, parHom_oddMap, ih, pow_succ] + ext v + simp + +/-- The super trace of an iterated parity involution. -/ +theorem sTr_parPow (V : SuperVect) (n : ℕ) : + sTr (parPow V n) = (Module.finrank ℂ V.even : ℂ) + + (-1 : ℂ) ^ n * (Module.finrank ℂ V.odd : ℂ) := by + rw [sTr, parPow_evenMap, parPow_oddMap, map_smul, + LinearMap.trace_id, LinearMap.trace_id] + simp + +/-! ## The total space and the total tensor identification + +The underlying vector space of a super vector space is the product +of its components; the graded tensor product's total space is the +tensor product of the total spaces, by the four-block shuffle +`totTensor`. All structure maps of `SuperVect` are conjugates of +plain linear maps under this identification, which is what the +braiding trace identity is proved through. -/ + +/-- The super trace is the plain trace of the total map. -/ +theorem sTr_eq_trace_tot {V : SuperVect} (f : V ⟶ V) : + sTr f = LinearMap.trace ℂ (Tot V) (tot f) := by + rw [sTr, tot, LinearMap.trace_prodMap'] + +/-- The middle shuffle of four product components: +`((A × B) × (C × D)) ≃ₗ ((A × D) × (B × C))`. -/ +def prodShuffle (A B C D : Type*) + [AddCommGroup A] [Module ℂ A] [AddCommGroup B] [Module ℂ B] + [AddCommGroup C] [Module ℂ C] [AddCommGroup D] [Module ℂ D] : + ((A × B) × (C × D)) ≃ₗ[ℂ] ((A × D) × (B × C)) where + toFun x := ((x.1.1, x.2.2), (x.1.2, x.2.1)) + map_add' _ _ := rfl + map_smul' _ _ := rfl + invFun x := ((x.1.1, x.2.1), (x.2.2, x.1.2)) + left_inv _ := rfl + right_inv _ := rfl + +/-- The shuffle, applied. -/ +@[simp] +theorem prodShuffle_apply (A B C D : Type*) + [AddCommGroup A] [Module ℂ A] [AddCommGroup B] [Module ℂ B] + [AddCommGroup C] [Module ℂ C] [AddCommGroup D] [Module ℂ D] + (x : (A × B) × (C × D)) : + prodShuffle A B C D x = ((x.1.1, x.2.2), (x.1.2, x.2.1)) := rfl + +/-- **The total tensor identification**: the total space of a graded +tensor product is the tensor product of the total spaces, by the +four-block shuffle. -/ +def totTensor (V W : SuperVect) : + (Tot V ⊗[ℂ] Tot W) ≃ₗ[ℂ] Tot (SuperVect.tensorObj V W) := + (TensorProduct.prodLeft ℂ ℂ V.even V.odd (Tot W)).trans + ((LinearEquiv.prodCongr + (TensorProduct.prodRight ℂ ℂ V.even W.even W.odd) + (TensorProduct.prodRight ℂ ℂ V.odd W.even W.odd)).trans + (prodShuffle (V.even ⊗[ℂ] W.even) (V.even ⊗[ℂ] W.odd) + (V.odd ⊗[ℂ] W.even) (V.odd ⊗[ℂ] W.odd))) + +/-- The total tensor identification on a pure tensor. -/ +@[simp] +theorem totTensor_tmul (V W : SuperVect) (x : Tot V) (y : Tot W) : + totTensor V W (x ⊗ₜ y) = + ((x.1 ⊗ₜ y.1, x.2 ⊗ₜ y.2), (x.1 ⊗ₜ y.2, x.2 ⊗ₜ y.1)) := by + obtain ⟨x1, x2⟩ := x + obtain ⟨y1, y2⟩ := y + simp only [totTensor, LinearEquiv.trans_apply, + TensorProduct.prodLeft_tmul] + rfl + +/-- **Naturality of the total tensor identification**: the total map +of a graded tensor of morphisms is the plain tensor of the total +maps, conjugated by `totTensor`. -/ +theorem tot_tensorHom {V₁ V₂ W₁ W₂ : SuperVect} + (f : V₁ ⟶ V₂) (g : W₁ ⟶ W₂) : + (tot (f ⊗ₘ g)).comp (totTensor V₁ W₁).toLinearMap = + (totTensor V₂ W₂).toLinearMap.comp + (TensorProduct.map (tot f) (tot g)) := by + apply TensorProduct.ext' + intro x y + change tot (f ⊗ₘ g) (totTensor V₁ W₁ (x ⊗ₜ y)) = + totTensor V₂ W₂ (TensorProduct.map (tot f) (tot g) (x ⊗ₜ y)) + rw [TensorProduct.map_tmul, totTensor_tmul, totTensor_tmul] + change tot (SuperVect.tensorHom f g) _ = _ + simp only [tot, SuperVect.tensorHom_evenMap, SuperVect.tensorHom_oddMap, + LinearMap.prodMap_apply] + rfl + +/-! ## The associator under the total identification -/ + +/-- The inverse of `prodRight` reassembles a pair of tensors with a +common first factor. -/ +theorem prodRight_symm_tmul {A B C : Type*} + [AddCommGroup A] [Module ℂ A] [AddCommGroup B] [Module ℂ B] + [AddCommGroup C] [Module ℂ C] (a : A) (b : B) (c : C) : + (TensorProduct.prodRight ℂ ℂ A B C).symm (a ⊗ₜ b, a ⊗ₜ c) = + a ⊗ₜ (b, c) := by + apply (TensorProduct.prodRight ℂ ℂ A B C).injective + rw [LinearEquiv.apply_symm_apply, TensorProduct.prodRight_tmul] + +/-- The module-level associator block of `SuperVect`, applied to the +pure elements produced by the total identification. -/ +theorem assocAux_pure {A₁ A₂ B₁ B₂ C₁ C₂ : Type*} + [AddCommGroup A₁] [Module ℂ A₁] [AddCommGroup A₂] [Module ℂ A₂] + [AddCommGroup B₁] [Module ℂ B₁] [AddCommGroup B₂] [Module ℂ B₂] + [AddCommGroup C₁] [Module ℂ C₁] [AddCommGroup C₂] [Module ℂ C₂] + (a₁ : A₁) (a₂ : A₂) (b₁ : B₁) (b₂ : B₂) (c₁ : C₁) (c₂ : C₂) : + SuperVect.assocAux A₁ A₂ B₁ B₂ C₁ C₂ + ((a₁ ⊗ₜ b₁, a₂ ⊗ₜ b₂) ⊗ₜ c₁, (a₁ ⊗ₜ b₂, a₂ ⊗ₜ b₁) ⊗ₜ c₂) = + (a₁ ⊗ₜ (b₁ ⊗ₜ c₁, b₂ ⊗ₜ c₂), a₂ ⊗ₜ (b₁ ⊗ₜ c₂, b₂ ⊗ₜ c₁)) := by + have h4 : ∀ (x : ((A₁ ⊗[ℂ] B₁) ⊗[ℂ] C₁) × ((A₂ ⊗[ℂ] B₂) ⊗[ℂ] C₁)) + (y : ((A₁ ⊗[ℂ] B₂) ⊗[ℂ] C₂) × ((A₂ ⊗[ℂ] B₁) ⊗[ℂ] C₂)), + SuperVect.prod4Perm ((A₁ ⊗[ℂ] B₁) ⊗[ℂ] C₁) + ((A₂ ⊗[ℂ] B₂) ⊗[ℂ] C₁) ((A₁ ⊗[ℂ] B₂) ⊗[ℂ] C₂) + ((A₂ ⊗[ℂ] B₁) ⊗[ℂ] C₂) (x, y) = + ((x.1, y.1), (y.2, x.2)) := fun _ _ => rfl + simp only [SuperVect.assocAux, LinearEquiv.trans_apply, + LinearEquiv.prodCongr_apply, + TensorProduct.prodLeft_tmul, h4, TensorProduct.assoc_tmul, + prodRight_symm_tmul] + +/-- **The associator under the total identification** is the plain +associator of the total spaces. -/ +theorem tot_associator (V W Z : SuperVect) : + (tot (α_ V W Z).hom).comp + ((totTensor (SuperVect.tensorObj V W) Z).toLinearMap.comp + (TensorProduct.map (totTensor V W).toLinearMap + LinearMap.id)) = + ((totTensor V (SuperVect.tensorObj W Z)).toLinearMap.comp + (TensorProduct.map LinearMap.id + (totTensor W Z).toLinearMap)).comp + (TensorProduct.assoc ℂ (Tot V) (Tot W) (Tot Z)).toLinearMap + := by + apply TensorProduct.ext' + intro u z + induction u using TensorProduct.inductionOn with + | add a b ha hb => simp only [TensorProduct.add_tmul, map_add, ha, hb] + | tmul x y => + change tot (α_ V W Z).hom + (totTensor (SuperVect.tensorObj V W) Z + (TensorProduct.map (totTensor V W).toLinearMap + LinearMap.id ((x ⊗ₜ y) ⊗ₜ z))) = + totTensor V (SuperVect.tensorObj W Z) + (TensorProduct.map LinearMap.id (totTensor W Z).toLinearMap + (TensorProduct.assoc ℂ (Tot V) (Tot W) (Tot Z) + ((x ⊗ₜ y) ⊗ₜ z))) + rw [TensorProduct.map_tmul, TensorProduct.assoc_tmul, + TensorProduct.map_tmul, LinearMap.id_apply, + LinearMap.id_apply, LinearEquiv.coe_coe, + LinearEquiv.coe_coe, totTensor_tmul, totTensor_tmul, + totTensor_tmul, totTensor_tmul] + change (LinearMap.prodMap + ((SuperVect.associator V W Z).hom.evenMap) + ((SuperVect.associator V W Z).hom.oddMap)) _ = _ + rw [SuperVect.associator_hom_evenMap, + SuperVect.associator_hom_oddMap] + change ((SuperVect.assocEvenEquiv V W Z) _, + (SuperVect.assocOddEquiv V W Z) _) = _ + rw [show SuperVect.assocEvenEquiv V W Z = + SuperVect.assocAux V.even V.odd W.even W.odd Z.even Z.odd + from rfl] + rw [show SuperVect.assocOddEquiv V W Z = + SuperVect.assocAux V.even V.odd W.even W.odd Z.odd Z.even + from rfl] + dsimp only + exact congrArg₂ Prod.mk + (assocAux_pure x.1 x.2 y.1 y.2 z.1 z.2) + (assocAux_pure x.1 x.2 y.1 y.2 z.2 z.1) + +/-! ## The Koszul braiding under the total identification -/ + +/-- Projection onto the even summand of a total space. -/ +def totEvenProj (V : SuperVect) : Tot V →ₗ[ℂ] Tot V := + (LinearMap.inl ℂ V.even V.odd).comp (LinearMap.fst ℂ V.even V.odd) + +/-- Projection onto the odd summand of a total space. -/ +def totOddProj (V : SuperVect) : Tot V →ₗ[ℂ] Tot V := + (LinearMap.inr ℂ V.even V.odd).comp (LinearMap.snd ℂ V.even V.odd) + +/-- **The signed flip of total spaces**: the plain flip on the even +part of the first factor, and the parity-twisted flip on its odd +part — the Koszul rule `(−1)^{|x||y|}` in operator form. -/ +def signedFlip (V W : SuperVect) : + (Tot V ⊗[ℂ] Tot W) →ₗ[ℂ] (Tot W ⊗[ℂ] Tot V) := + (TensorProduct.comm ℂ (Tot V) (Tot W)).toLinearMap.comp + (TensorProduct.map (totEvenProj V) LinearMap.id + + TensorProduct.map (totOddProj V) (tot (parHom W))) + +/-- The signed flip on a pure tensor. -/ +theorem signedFlip_tmul (V W : SuperVect) (x : Tot V) (y : Tot W) : + signedFlip V W (x ⊗ₜ y) = + y ⊗ₜ ((x.1, 0) : Tot V) + + ((y.1, -y.2) : Tot W) ⊗ₜ ((0, x.2) : Tot V) := by + simp only [signedFlip, LinearMap.comp_apply, LinearMap.add_apply, + TensorProduct.map_tmul, map_add] + rfl + +/-- The even Koszul block on a pair. -/ +theorem koszulBraidingEven_pair (V W : SuperVect) + (a : V.even ⊗[ℂ] W.even) (b : V.odd ⊗[ℂ] W.odd) : + SuperVect.koszulBraidingEven V W (a, b) = + (TensorProduct.comm ℂ V.even W.even a, + -(TensorProduct.comm ℂ V.odd W.odd b)) := rfl + +/-- **The Koszul braiding under the total identification** is the +signed flip. -/ +theorem tot_koszulBraiding (V W : SuperVect) : + (tot (β_ V W).hom).comp (totTensor V W).toLinearMap = + (totTensor W V).toLinearMap.comp (signedFlip V W) := by + apply TensorProduct.ext' + intro x y + obtain ⟨x1, x2⟩ := x + have hx : ((x1, x2) : Tot V) = (x1, 0) + (0, x2) := by + rw [Prod.mk_add_mk, add_zero, zero_add] + change tot (β_ V W).hom (totTensor V W ((x1, x2) ⊗ₜ y)) = + totTensor W V (signedFlip V W ((x1, x2) ⊗ₜ y)) + rw [hx, TensorProduct.add_tmul, map_add, map_add, map_add, map_add] + refine congrArg₂ (· + ·) ?_ ?_ + · rw [totTensor_tmul, signedFlip_tmul] + dsimp only + rw [show ((0, 0) : Tot V) = 0 from rfl, TensorProduct.tmul_zero, + add_zero, TensorProduct.zero_tmul, + TensorProduct.zero_tmul, totTensor_tmul] + change (SuperVect.koszulBraidingEven V W (x1 ⊗ₜ y.1, 0), + SuperVect.koszulBraidingOdd V W (x1 ⊗ₜ y.2, 0)) = _ + rw [koszulBraidingEven_pair, SuperVect.koszulBraidingOdd_pair] + simp [TensorProduct.comm_tmul, TensorProduct.tmul_zero] + · rw [totTensor_tmul, signedFlip_tmul] + dsimp only + rw [show ((0, 0) : Tot V) = 0 from rfl, TensorProduct.tmul_zero, + zero_add, TensorProduct.zero_tmul, + TensorProduct.zero_tmul, totTensor_tmul] + change (SuperVect.koszulBraidingEven V W (0, x2 ⊗ₜ y.2), + SuperVect.koszulBraidingOdd V W (0, x2 ⊗ₜ y.1)) = _ + rw [koszulBraidingEven_pair, SuperVect.koszulBraidingOdd_pair] + simp [TensorProduct.comm_tmul, TensorProduct.tmul_zero, + TensorProduct.neg_tmul] + +/-! ## Plain trace identities + +The linear-algebra core of the braiding trace computation: tracing +a tensor of maps against the flip contracts to the trace of the +composite, and the same identity holds with a spectator factor and a +twist on the last slot. -/ + +section PlainTrace + +variable {U V : Type*} + +/-- **The contraction identity**: the trace of `f ⊗ g` against the +flip is the trace of `f ∘ g`. -/ +theorem trace_map_comp_comm + [AddCommGroup V] [Module ℂ V] [FiniteDimensional ℂ V] + (f g : V →ₗ[ℂ] V) : + LinearMap.trace ℂ (V ⊗[ℂ] V) + ((TensorProduct.map f g).comp + (TensorProduct.comm ℂ V V).toLinearMap) = + LinearMap.trace ℂ V (f.comp g) := by + classical + set b := Module.Free.chooseBasis ℂ V with hb + rw [LinearMap.trace_eq_matrix_trace ℂ (b.tensorProduct b), + LinearMap.trace_eq_matrix_trace ℂ b, Matrix.trace, Matrix.trace, + Fintype.sum_prod_type] + refine Finset.sum_congr rfl fun i _ => ?_ + have hdiag : ∀ j, + (LinearMap.toMatrix (b.tensorProduct b) (b.tensorProduct b) + ((TensorProduct.map f g).comp + (TensorProduct.comm ℂ V V).toLinearMap)).diag (i, j) = + b.repr (g (b i)) j * b.repr (f (b j)) i := by + intro j + rw [Matrix.diag_apply, LinearMap.toMatrix_apply, + Module.Basis.tensorProduct_apply, LinearMap.comp_apply, + LinearEquiv.coe_coe, TensorProduct.comm_tmul, + TensorProduct.map_tmul, + Module.Basis.tensorProduct_repr_tmul_apply, smul_eq_mul] + rw [Finset.sum_congr rfl fun j _ => hdiag j, Matrix.diag_apply, + LinearMap.toMatrix_apply, LinearMap.comp_apply] + conv_rhs => rw [show g (b i) = ∑ j, b.repr (g (b i)) j • b j from + (b.sum_repr _).symm] + simp only [map_sum, map_smul, Finsupp.finsetSum_apply, + Finsupp.smul_apply, smul_eq_mul] + +/-- **The spectator contraction identity**: with a spectator factor +`U`, a twist `H` on the outer slot and modifications `s`, `t` inside +the flip, the trace contracts to a trace over `U ⊗ V`. -/ +theorem trace_flip_twist + [AddCommGroup U] [Module ℂ U] [FiniteDimensional ℂ U] [AddCommGroup V] + [Module ℂ V] [FiniteDimensional ℂ V] + (G : U ⊗[ℂ] V →ₗ[ℂ] U ⊗[ℂ] V) + (H s t : V →ₗ[ℂ] V) : + LinearMap.trace ℂ ((U ⊗[ℂ] V) ⊗[ℂ] V) + ((TensorProduct.map LinearMap.id H).comp + ((TensorProduct.map G LinearMap.id).comp + (((TensorProduct.assoc ℂ U V V).symm.toLinearMap).comp + ((TensorProduct.map LinearMap.id + ((TensorProduct.comm ℂ V V).toLinearMap.comp + (TensorProduct.map s t))).comp + (TensorProduct.assoc ℂ U V V).toLinearMap)))) = + LinearMap.trace ℂ (U ⊗[ℂ] V) + (G.comp (TensorProduct.map LinearMap.id + ((t.comp H).comp s))) := by + classical + -- reduce to pure tensors of endomorphisms via the hom-tensor-hom + -- equivalence + obtain ⟨T, rfl⟩ := (homTensorHomEquiv ℂ U V U V).surjective G + rw [homTensorHomEquiv_apply] + induction T using TensorProduct.inductionOn with + | add a c ha hc => + rw [map_add, TensorProduct.map_add_left, LinearMap.add_comp, + LinearMap.comp_add, map_add, ha, hc, LinearMap.add_comp, + map_add] + | tmul f₀ g₀ => + rw [TensorProduct.homTensorHomMap_apply] + -- identify the composite with an associator conjugate + have hcomp : + (TensorProduct.map LinearMap.id H).comp + ((TensorProduct.map (TensorProduct.map f₀ g₀) + LinearMap.id).comp + (((TensorProduct.assoc ℂ U V V).symm.toLinearMap).comp + ((TensorProduct.map LinearMap.id + ((TensorProduct.comm ℂ V V).toLinearMap.comp + (TensorProduct.map s t))).comp + (TensorProduct.assoc ℂ U V V).toLinearMap))) = + (((TensorProduct.assoc ℂ U V V).symm.toLinearMap).comp + ((TensorProduct.map f₀ + ((TensorProduct.map (g₀.comp t) (H.comp s)).comp + (TensorProduct.comm ℂ V V).toLinearMap)).comp + (TensorProduct.assoc ℂ U V V).toLinearMap)) := by + apply TensorProduct.ext' + intro w z + induction w using TensorProduct.inductionOn with + | add w₁ w₂ h₁ h₂ => + rw [TensorProduct.add_tmul, map_add, map_add, h₁, h₂] + | tmul u v => + simp [TensorProduct.assoc_tmul, TensorProduct.comm_tmul, + TensorProduct.map_tmul, TensorProduct.assoc_symm_tmul] + rw [hcomp] + -- conjugation by the associator preserves the trace + rw [show (((TensorProduct.assoc ℂ U V V).symm.toLinearMap).comp + ((TensorProduct.map f₀ + ((TensorProduct.map (g₀.comp t) (H.comp s)).comp + (TensorProduct.comm ℂ V V).toLinearMap)).comp + (TensorProduct.assoc ℂ U V V).toLinearMap)) = + (TensorProduct.assoc ℂ U V V).symm.conj + (TensorProduct.map f₀ + ((TensorProduct.map (g₀.comp t) (H.comp s)).comp + (TensorProduct.comm ℂ V V).toLinearMap)) from by + rw [LinearEquiv.conj_apply, LinearEquiv.symm_symm] + rfl] + rw [LinearMap.trace_conj', LinearMap.trace_tensorProduct', + trace_map_comp_comm] + rw [show (TensorProduct.map f₀ g₀).comp + (TensorProduct.map LinearMap.id ((t.comp H).comp s)) = + TensorProduct.map f₀ (g₀.comp ((t.comp H).comp s)) from by + rw [← TensorProduct.map_comp, LinearMap.comp_id]] + rw [LinearMap.trace_tensorProduct'] + congr 2 + +end PlainTrace + +/-! ## The braiding partial-trace identity -/ + +/-- A monoid-instance form of the trace commutation, so that the +statement's instances match those of concretely built product and +tensor types without deep unfolding. -/ +private theorem trace_comp_comm_monoid {M N : Type*} + [AddCommMonoid M] [Module ℂ M] [Module.Free ℂ M] + [Module.Finite ℂ M] [AddCommMonoid N] [Module ℂ N] + [Module.Free ℂ N] [Module.Finite ℂ N] + (f : M →ₗ[ℂ] N) (g : N →ₗ[ℂ] M) : + LinearMap.trace ℂ M (g ∘ₗ f) = LinearMap.trace ℂ N (f ∘ₗ g) := by + let : AddCommGroup M := Module.addCommMonoidToAddCommGroup ℂ + let : AddCommGroup N := Module.addCommMonoidToAddCommGroup ℂ + exact LinearMap.trace_comp_comm' f g + +-- The supertrace is conjugated through the +-- braiding on each of the four parity blocks. +private theorem sTr_comp_whiskerLeft_total (P X : SuperVect) + (g : SuperVect.tensorObj P X ⟶ SuperVect.tensorObj P X) (k : X ⟶ X) : + sTr (g ≫ (P ◁ k)) = + LinearMap.trace ℂ _ + ((((totTensor P X).symm.toLinearMap.comp (tot g)).comp + (totTensor P X).toLinearMap).comp + (TensorProduct.map LinearMap.id (tot k))) := by + classical + set TP := totTensor P X + set g' : (Tot P ⊗[ℂ] Tot X) →ₗ[ℂ] Tot P ⊗[ℂ] Tot X := + (TP.symm.toLinearMap.comp (tot g)).comp TP.toLinearMap with hg' + have hwhiskk : ∀ y, tot (P ◁ k) (TP y) = + TP (TensorProduct.map LinearMap.id (tot k) y) := by + intro y + have h1 := LinearMap.congr_fun (tot_tensorHom (𝟙 P) k) y + rwa [tot_id] at h1 + have hRHS : sTr (g ≫ (P ◁ k)) = + LinearMap.trace ℂ _ + (g'.comp (TensorProduct.map LinearMap.id (tot k))) := by + rw [sTr_eq_trace_tot, tot_comp] + have hcomp2 : tot (P ◁ k) = + (TP.toLinearMap.comp + (TensorProduct.map LinearMap.id (tot k))).comp + TP.symm.toLinearMap := by + refine LinearMap.ext fun z => ?_ + have h1 := hwhiskk (TP.symm z) + rw [LinearEquiv.apply_symm_apply] at h1 + simpa using h1 + rw [hcomp2] + rw [show ((TP.toLinearMap.comp + (TensorProduct.map LinearMap.id (tot k))).comp + TP.symm.toLinearMap).comp (tot g) = + TP.toLinearMap.comp + (((TensorProduct.map LinearMap.id (tot k)).comp + TP.symm.toLinearMap).comp (tot g)) from by + simp only [LinearMap.comp_assoc]] + rw [LinearMap.trace_comp_comm'] + rw [show (((TensorProduct.map LinearMap.id (tot k)).comp + TP.symm.toLinearMap).comp (tot g)).comp TP.toLinearMap = + (TensorProduct.map LinearMap.id (tot k)).comp g' from by + rw [hg'] + simp only [LinearMap.comp_assoc]] + rw [LinearMap.trace_comp_comm'] + exact hRHS + +/-- **The braiding partial-trace identity**: composing the braiding +of the top two slots with a whiskered endomorphism and a twist of +the top slot traces to the endomorphism alone, with the twist +parity-corrected and moved down one slot. This is the engine of the +cycle evaluation. -/ +theorem sTr_swap_conj (P X : SuperVect) + (g : SuperVect.tensorObj P X ⟶ SuperVect.tensorObj P X) + (h : X ⟶ X) : + sTr ((α_ P X X).hom ≫ (P ◁ (β_ X X).hom) ≫ (α_ P X X).inv ≫ + (g ▷ X) ≫ (SuperVect.tensorObj P X ◁ h)) = + sTr (g ≫ (P ◁ (h ≫ parHom X))) := by + classical + set TP := totTensor P X with hTP + set TXX := totTensor X X with hTXX + set TA := totTensor (SuperVect.tensorObj P X) X with hTA + set TB := totTensor P (SuperVect.tensorObj X X) with hTB + set A := TensorProduct.assoc ℂ (Tot P) (Tot X) (Tot X) with hAdef + set Jlin : ((Tot P ⊗[ℂ] Tot X) ⊗[ℂ] Tot X) →ₗ[ℂ] + Tot (SuperVect.tensorObj (SuperVect.tensorObj P X) X) := + TA.toLinearMap.comp + (TensorProduct.map TP.toLinearMap LinearMap.id) with hJlin + set J'lin : (Tot P ⊗[ℂ] (Tot X ⊗[ℂ] Tot X)) →ₗ[ℂ] + Tot (SuperVect.tensorObj P (SuperVect.tensorObj X X)) := + TB.toLinearMap.comp + (TensorProduct.map LinearMap.id TXX.toLinearMap) with hJ'lin + set g' : (Tot P ⊗[ℂ] Tot X) →ₗ[ℂ] Tot P ⊗[ℂ] Tot X := + (TP.symm.toLinearMap.comp (tot g)).comp TP.toLinearMap with hg' + set k : X ⟶ X := h ≫ parHom X with hk + -- the five conjugation steps, pointwise + have halpha : ∀ x, tot (α_ P X X).hom (Jlin x) = J'lin (A x) := + fun x => LinearMap.congr_fun (tot_associator P X X) x + have hwhiskβ : ∀ y, tot (P ◁ (β_ X X).hom) (TB y) = + TB (TensorProduct.map LinearMap.id (tot (β_ X X).hom) y) := by + intro y + have h1 := LinearMap.congr_fun + (tot_tensorHom (𝟙 P) (β_ X X).hom) y + rwa [tot_id] at h1 + have hbeta : ∀ x, tot (P ◁ (β_ X X).hom) (J'lin x) = + J'lin (TensorProduct.map LinearMap.id (signedFlip X X) x) := by + intro x + change tot (P ◁ (β_ X X).hom) + (TB (TensorProduct.map LinearMap.id TXX.toLinearMap x)) = + TB (TensorProduct.map LinearMap.id TXX.toLinearMap + (TensorProduct.map LinearMap.id (signedFlip X X) x)) + rw [hwhiskβ, TensorProduct.map_map, TensorProduct.map_map, + tot_koszulBraiding] + have hcancelα : ∀ y, tot (α_ P X X).inv (tot (α_ P X X).hom y) = y + := by + intro y + rw [← LinearMap.comp_apply, ← tot_comp, Iso.hom_inv_id, tot_id, + LinearMap.id_apply] + have halphainv : ∀ x, tot (α_ P X X).inv (J'lin x) = + Jlin (A.symm x) := by + intro x + have h1 := halpha (A.symm x) + rw [LinearEquiv.apply_symm_apply] at h1 + rw [← h1, hcancelα] + have hgconj : (tot g).comp TP.toLinearMap = TP.toLinearMap.comp g' + := by + refine LinearMap.ext fun y => ?_ + change tot g (TP y) = TP (g' y) + rw [hg'] + simp + have hwhiskg : ∀ y, tot (g ▷ X) (TA y) = + TA (TensorProduct.map (tot g) LinearMap.id y) := by + intro y + have h1 := LinearMap.congr_fun (tot_tensorHom g (𝟙 X)) y + rwa [tot_id] at h1 + have hgstep : ∀ x, tot (g ▷ X) (Jlin x) = + Jlin (TensorProduct.map g' LinearMap.id x) := by + intro x + change tot (g ▷ X) + (TA (TensorProduct.map TP.toLinearMap LinearMap.id x)) = + TA (TensorProduct.map TP.toLinearMap LinearMap.id + (TensorProduct.map g' LinearMap.id x)) + rw [hwhiskg, TensorProduct.map_map, TensorProduct.map_map, + hgconj] + have hwhiskh : ∀ y, + tot (SuperVect.tensorObj P X ◁ h) (TA y) = + TA (TensorProduct.map LinearMap.id (tot h) y) := by + intro y + have h1 := LinearMap.congr_fun + (tot_tensorHom (𝟙 (SuperVect.tensorObj P X)) h) y + rwa [tot_id] at h1 + have hhstep : ∀ x, tot (SuperVect.tensorObj P X ◁ h) (Jlin x) = + Jlin (TensorProduct.map LinearMap.id (tot h) x) := by + intro x + change tot (SuperVect.tensorObj P X ◁ h) + (TA (TensorProduct.map TP.toLinearMap LinearMap.id x)) = + TA (TensorProduct.map TP.toLinearMap LinearMap.id + (TensorProduct.map LinearMap.id (tot h) x)) + rw [hwhiskh, TensorProduct.map_map, TensorProduct.map_map] + simp only [LinearMap.id_comp, LinearMap.comp_id] + -- the conjugated composite + set C' : ((Tot P ⊗[ℂ] Tot X) ⊗[ℂ] Tot X) →ₗ[ℂ] + ((Tot P ⊗[ℂ] Tot X) ⊗[ℂ] Tot X) := + (TensorProduct.map LinearMap.id (tot h)).comp + ((TensorProduct.map g' LinearMap.id).comp + (A.symm.toLinearMap.comp + ((TensorProduct.map LinearMap.id (signedFlip X X)).comp + A.toLinearMap))) with hC' + have htotpt : ∀ {V₁ V₂ V₃ : SuperVect} (a : V₁ ⟶ V₂) + (b : V₂ ⟶ V₃) (y : Tot V₁), + tot (a ≫ b) y = tot b (tot a y) := by + intro V₁ V₂ V₃ a b y + rw [tot_comp] + rfl + have hchain : ∀ x, + tot ((α_ P X X).hom ≫ (P ◁ (β_ X X).hom) ≫ (α_ P X X).inv ≫ + (g ▷ X) ≫ (SuperVect.tensorObj P X ◁ h)) (Jlin x) = + Jlin (C' x) := by + intro x + rw [htotpt, htotpt, htotpt, htotpt, halpha, hbeta, halphainv, + hgstep, hhstep] + rfl + -- the total identification as an equivalence, and the trace + set JE : ((Tot P ⊗[ℂ] Tot X) ⊗[ℂ] Tot X) ≃ₗ[ℂ] + Tot (SuperVect.tensorObj (SuperVect.tensorObj P X) X) := + (TensorProduct.congr TP (LinearEquiv.refl ℂ (Tot X))).trans TA + with hJE + have hJapp : ∀ x, JE x = Jlin x := fun _ => rfl + have hfact : + tot ((α_ P X X).hom ≫ (P ◁ (β_ X X).hom) ≫ (α_ P X X).inv ≫ + (g ▷ X) ≫ (SuperVect.tensorObj P X ◁ h)) = + (JE.toLinearMap.comp C').comp JE.symm.toLinearMap := by + refine LinearMap.ext fun z => ?_ + change tot _ z = JE (C' (JE.symm z)) + conv_lhs => rw [show z = JE (JE.symm z) from + (JE.apply_symm_apply z).symm] + rw [show (JE (JE.symm z) : + Tot (SuperVect.tensorObj (SuperVect.tensorObj P X) X)) = + Jlin (JE.symm z) from hJapp _] + rw [hchain] + exact (hJapp _).symm + have htrace1 : + sTr ((α_ P X X).hom ≫ (P ◁ (β_ X X).hom) ≫ (α_ P X X).inv ≫ + (g ▷ X) ≫ (SuperVect.tensorObj P X ◁ h)) = + LinearMap.trace ℂ _ C' := by + have e1 : LinearMap.trace ℂ + (Tot (SuperVect.tensorObj (SuperVect.tensorObj P X) X)) + ((JE.toLinearMap.comp C').comp JE.symm.toLinearMap) = + LinearMap.trace ℂ ((Tot P ⊗[ℂ] Tot X) ⊗[ℂ] Tot X) + (JE.symm.toLinearMap.comp (JE.toLinearMap.comp C')) := + trace_comp_comm_monoid JE.symm.toLinearMap + (JE.toLinearMap.comp C') + have e2 : JE.symm.toLinearMap.comp (JE.toLinearMap.comp C') = C' + := LinearMap.ext fun z => JE.symm_apply_apply (C' z) + rw [e2] at e1 + rw [sTr_eq_trace_tot, hfact] + exact e1 + -- split the signed flip and contract each summand + have hsplit : C' = + (TensorProduct.map LinearMap.id (tot h)).comp + ((TensorProduct.map g' LinearMap.id).comp + (A.symm.toLinearMap.comp + ((TensorProduct.map LinearMap.id + ((TensorProduct.comm ℂ (Tot X) (Tot X)).toLinearMap.comp + (TensorProduct.map (totEvenProj X) + LinearMap.id))).comp A.toLinearMap))) + + (TensorProduct.map LinearMap.id (tot h)).comp + ((TensorProduct.map g' LinearMap.id).comp + (A.symm.toLinearMap.comp + ((TensorProduct.map LinearMap.id + ((TensorProduct.comm ℂ (Tot X) (Tot X)).toLinearMap.comp + (TensorProduct.map (totOddProj X) + (tot (parHom X))))).comp A.toLinearMap))) := by + rw [hC', signedFlip, LinearMap.comp_add, + TensorProduct.map_add_right, LinearMap.add_comp, + LinearMap.comp_add, LinearMap.comp_add, LinearMap.comp_add] + have htrace2 : LinearMap.trace ℂ _ C' = + LinearMap.trace ℂ _ (g'.comp (TensorProduct.map LinearMap.id + ((LinearMap.id.comp (tot h)).comp (totEvenProj X)))) + + LinearMap.trace ℂ _ (g'.comp (TensorProduct.map LinearMap.id + (((tot (parHom X)).comp (tot h)).comp (totOddProj X)))) := by + rw [hsplit, map_add] + exact congrArg₂ (· + ·) + (trace_flip_twist g' (tot h) (totEvenProj X) LinearMap.id) + (trace_flip_twist g' (tot h) (totOddProj X) (tot (parHom X))) + have hkey : (LinearMap.id.comp (tot h)).comp (totEvenProj X) + + ((tot (parHom X)).comp (tot h)).comp (totOddProj X) = tot k + := by + refine LinearMap.ext fun x => ?_ + change (tot h ((x.1, 0) : Tot X)) + + tot (parHom X) (tot h ((0, x.2) : Tot X)) = tot k x + rw [hk] + change ((SuperVect.Hom.evenMap h x.1, SuperVect.Hom.oddMap h 0) + : Tot X) + + ((SuperVect.Hom.evenMap h 0, + -SuperVect.Hom.oddMap h x.2) : Tot X) = + ((SuperVect.Hom.evenMap h x.1, -SuperVect.Hom.oddMap h x.2) + : Tot X) + rw [map_zero, map_zero, Prod.mk_add_mk, add_zero, zero_add] + have htrace3 : LinearMap.trace ℂ _ C' = + LinearMap.trace ℂ _ + (g'.comp (TensorProduct.map LinearMap.id (tot k))) := by + rw [htrace2] + have hsum : g'.comp (TensorProduct.map LinearMap.id + ((LinearMap.id.comp (tot h)).comp (totEvenProj X))) + + g'.comp (TensorProduct.map LinearMap.id + (((tot (parHom X)).comp (tot h)).comp (totOddProj X))) = + g'.comp (TensorProduct.map LinearMap.id (tot k)) := by + rw [← LinearMap.comp_add, ← TensorProduct.map_add_right, hkey] + rw [← map_add, hsum] + -- identify the right-hand side + have hRHS := sTr_comp_whiskerLeft_total P X g k + rw [htrace1, htrace3, hRHS] + +/-! ## The trace of the standard cycles + +Unrolling the bubbling `insertTop X n n` through the braiding +partial-trace identity leaves an iterated parity twist: each +braiding step converts one slot's twist into a parity correction. -/ + +/-- **The bubbling trace, with a twist**: the full insertion +composed with a twist of the top slot traces to the `n`-fold parity +correction of the twist. -/ +theorem sTr_insertTop_full (X : SuperVect) : + ∀ (n : ℕ) (h : X ⟶ X), + sTr (insertTop X n n ≫ (tensorPow SuperVect X n ◁ h)) = + sTr (parPow X n ≫ h) := by + intro n + induction n with + | zero => + intro h + erw [show insertTop X 0 0 = 𝟙 _ from insertTop_zero X 0, + Category.id_comp] + change sTr (𝟙 (tensorPow SuperVect X 0) ⊗ₘ h) = _ + rw [sTr_tensorHom, sTr_id, parPow, Category.id_comp] + rw [show Module.finrank ℂ (tensorPow SuperVect X 0).even + = 1 from Module.finrank_self ℂ] + have : Subsingleton (tensorPow SuperVect X 0).odd := + inferInstanceAs (Subsingleton PUnit) + rw [show Module.finrank ℂ (tensorPow SuperVect X 0).odd + = 0 from Module.finrank_eq_zero_of_subsingleton _ _] + norm_num + | succ n ih => + intro h + have h1 : sTr (insertTop X (n + 1) (n + 1) ≫ + (tensorPow SuperVect X (n + 1) ◁ h)) = + sTr (insertTop X n n ≫ + (tensorPow SuperVect X n ◁ (h ≫ parHom X))) := + sTr_swap_conj (tensorPow SuperVect X n) X (insertTop X n n) + h + rw [h1, ih (h ≫ parHom X)] + rw [show parPow X n ≫ h ≫ parHom X = + parPow X (n + 1) ≫ h from by + rw [parHom_comm h, ← Category.assoc] + rfl] + +/-- **The trace of the standard cycle** on the tensor power is the +alternating parity trace. -/ +theorem sTr_permMor_topCycle_zero (X : SuperVect) (n : ℕ) : + sTr (permMor X (n + 1) (topCycle (0 : Fin (n + 1)))) = + sTr (parPow X n) := by + have h2 : insertTop X n n ≫ + (tensorPow SuperVect X n ◁ (𝟙 X)) = insertTop X n n := by + rw [MonoidalCategory.whiskerLeft_id] + change insertTop X n n ≫ 𝟙 (tensorPow SuperVect X (n + 1)) = _ + rw [Category.comp_id] + rw [permMor_topCycle, + show ((0 : Fin (n + 1)) : ℕ) = 0 from rfl, Nat.sub_zero] + calc sTr (insertTop X n n) + = sTr (insertTop X n n ≫ + (tensorPow SuperVect X n ◁ (𝟙 X))) := + (congrArg sTr h2).symm + _ = sTr (parPow X n ≫ 𝟙 X) := sTr_insertTop_full X n (𝟙 X) + _ = sTr (parPow X n) := congrArg sTr (Category.comp_id _) + +/-! ## The super character of the permutation action -/ + +/-- **The super character**: the trace of a permutation's action on +the tensor power of the standard super object. -/ +def superChar (p q n : ℕ) (σ : Equiv.Perm (Fin n)) : ℂ := + sTr (permMor (stdSuper p q) n σ) + +/-- The super character is a class function. -/ +theorem superChar_conj (p q : ℕ) {n : ℕ} + (τ σ : Equiv.Perm (Fin n)) : + superChar p q n (τ * σ * τ⁻¹) = superChar p q n σ := by + unfold superChar + rw [show τ * σ * τ⁻¹ = τ * (σ * τ⁻¹) from mul_assoc τ σ τ⁻¹, + permMor_mul, permMor_mul] + rw [Category.assoc, sTr_comp_comm] + rw [Category.assoc, ← permMor_mul, inv_mul_cancel, permMor_one, + Category.comp_id] + +/-- The super character is multiplicative over block embeddings. -/ +theorem superChar_blockEmbed (p q : ℕ) {a b : ℕ} + (σ : Equiv.Perm (Fin a)) (τ : Equiv.Perm (Fin b)) : + superChar p q (a + b) (blockEmbed σ τ) = + superChar p q a σ * superChar p q b τ := by + set X := stdSuper p q with hX + have h1 : permMor X (a + b) (blockEmbed σ τ) = + (tensorPowConcat X a b).inv ≫ + ((permMor X a σ ⊗ₘ permMor X b τ) ≫ + (tensorPowConcat X a b).hom) := by + rw [← tensorPowConcat_permMor, Iso.inv_hom_id_assoc] + unfold superChar + rw [h1, sTr_conj, sTr_tensorHom] + +/-- The standard cycle of each length: the full rotation. -/ +def nfCycle : (c : ℕ) → Equiv.Perm (Fin c) + | 0 => 1 + | _ + 1 => topCycle 0 + +/-- The super character of a standard cycle is the super power +sum. -/ +theorem superChar_nfCycle (p q : ℕ) {c : ℕ} (hc : 1 ≤ c) : + superChar p q c (nfCycle c) = superPS p q c := by + obtain ⟨m, rfl⟩ : ∃ m, c = m + 1 := ⟨c - 1, by omega⟩ + unfold superChar + rw [show nfCycle (m + 1) = topCycle 0 from rfl, + sTr_permMor_topCycle_zero, sTr_parPow] + rw [show Module.finrank ℂ (stdSuper p q).even = p from + Module.finrank_fin_fun ℂ] + rw [show Module.finrank ℂ (stdSuper p q).odd = q from + Module.finrank_fin_fun ℂ] + rw [superPS, show (-1 : ℂ) ^ (m + 1 + 1) = (-1 : ℂ) ^ m from by + rw [pow_succ, pow_succ] + ring] + +/-! ## Normal forms and cycle types -/ + +/-- Relabelling along an embedding preserves the cycle type. -/ +theorem cycleType_viaEmbedding {α β : Type*} + [Fintype α] [DecidableEq α] [Fintype β] [DecidableEq β] + (e : Equiv.Perm α) (ι : α ↪ β) : + (e.viaEmbedding ι).cycleType = e.cycleType := by + rw [Equiv.Perm.viaEmbedding] + let : DecidablePred (· ∈ Set.range ι.toFun) := + fun a => Classical.propDecidable _ + exact Equiv.Perm.cycleType_extendDomain _ + +/-- A one-sided block embedding is a relabelling along the +first-block embedding. -/ +theorem blockEmbed_fst_viaEmbedding {a b : ℕ} + (σ : Equiv.Perm (Fin a)) : + blockEmbed σ (1 : Equiv.Perm (Fin b)) = + σ.viaEmbedding (Fin.castAddEmb b) := by + refine Equiv.ext fun x => ?_ + induction x using Fin.addCases with + | left i => + rw [blockEmbed_castAdd, + show Fin.castAdd b i = Fin.castAddEmb b i from rfl, + Equiv.Perm.viaEmbedding_apply] + rfl + | right j => + rw [blockEmbed_natAdd, Equiv.Perm.one_apply, + Equiv.Perm.viaEmbedding_apply_of_notMem] + rintro ⟨i, hi⟩ + have := congrArg Fin.val hi + simp only [Fin.castAddEmb_apply, Fin.val_castAdd, + Fin.val_natAdd] at this + omega + +/-- A one-sided block embedding is a relabelling along the +last-block embedding. -/ +theorem blockEmbed_snd_viaEmbedding {a b : ℕ} + (τ : Equiv.Perm (Fin b)) : + blockEmbed (1 : Equiv.Perm (Fin a)) τ = + τ.viaEmbedding (Fin.natAddEmb a) := by + refine Equiv.ext fun x => ?_ + induction x using Fin.addCases with + | left i => + rw [blockEmbed_castAdd, Equiv.Perm.one_apply, + Equiv.Perm.viaEmbedding_apply_of_notMem] + rintro ⟨j, hj⟩ + have := congrArg Fin.val hj + simp only [Fin.natAddEmb_apply, Fin.val_natAdd, + Fin.val_castAdd] at this + omega + | right j => + rw [blockEmbed_natAdd, + show Fin.natAdd a j = Fin.natAddEmb a j from rfl, + Equiv.Perm.viaEmbedding_apply] + rfl + +/-- The two one-sided block embeddings are disjoint. -/ +theorem blockEmbed_disjoint {a b : ℕ} (σ : Equiv.Perm (Fin a)) + (τ : Equiv.Perm (Fin b)) : + Equiv.Perm.Disjoint (blockEmbed σ (1 : Equiv.Perm (Fin b))) + (blockEmbed (1 : Equiv.Perm (Fin a)) τ) := by + intro x + induction x using Fin.addCases with + | left i => + right + rw [blockEmbed_castAdd, Equiv.Perm.one_apply] + | right j => + left + rw [blockEmbed_natAdd, Equiv.Perm.one_apply] + +/-- The cycle type of a block embedding is the sum of the cycle +types. -/ +theorem cycleType_blockEmbed {a b : ℕ} (σ : Equiv.Perm (Fin a)) + (τ : Equiv.Perm (Fin b)) : + (blockEmbed σ τ).cycleType = σ.cycleType + τ.cycleType := by + rw [blockEmbed_decompose, + (blockEmbed_disjoint σ τ).cycleType_mul, + blockEmbed_fst_viaEmbedding, blockEmbed_snd_viaEmbedding, + cycleType_viaEmbedding, cycleType_viaEmbedding] + +/-- The cycle type of a standard cycle of length at least two. -/ +theorem cycleType_nfCycle_of_two_le {c : ℕ} (hc : 2 ≤ c) : + (nfCycle c).cycleType = {c} := by + obtain ⟨m, rfl⟩ : ∃ m, c = m + 1 := ⟨c - 1, by omega⟩ + rw [show nfCycle (m + 1) = topCycle 0 from rfl, topCycle_zero] + exact cycleType_finRotate_of_le hc + +/-- The cycle type of a short standard cycle is empty. -/ +theorem cycleType_nfCycle_of_le_one {c : ℕ} (hc : c ≤ 1) : + (nfCycle c).cycleType = 0 := by + match c, hc with + | 0, _ => exact Equiv.Perm.cycleType_one + | 1, _ => + rw [show nfCycle 1 = 1 from Subsingleton.elim _ _] + exact Equiv.Perm.cycleType_one + +/-- **The normal form of a cycle-length list**: the block product +of standard cycles. -/ +def nfPerm : (cs : List ℕ) → Equiv.Perm (Fin cs.sum) + | [] => 1 + | c :: cs => blockEmbed (nfCycle c) (nfPerm cs) + +/-- The cycle type of a normal form: the cycle lengths of at least +two. -/ +theorem cycleType_nfPerm : ∀ cs : List ℕ, + (nfPerm cs).cycleType = + ((cs.filter (fun c => decide (2 ≤ c))) : Multiset ℕ) := by + intro cs + induction cs with + | nil => exact Equiv.Perm.cycleType_one + | cons c cs ih => + refine Eq.trans + (cycleType_blockEmbed (nfCycle c) (nfPerm cs)) ?_ + rw [ih] + by_cases hc : 2 ≤ c + · rw [cycleType_nfCycle_of_two_le hc, + List.filter_cons_of_pos (by simpa using hc), + Multiset.singleton_add] + rfl + · rw [cycleType_nfCycle_of_le_one (by omega), + List.filter_cons_of_neg (by simpa using hc), zero_add] + +/-- The super character of a normal form is the product of the +super power sums of its cycle lengths. -/ +theorem superChar_nfPerm (p q : ℕ) : ∀ cs : List ℕ, + (∀ c ∈ cs, 1 ≤ c) → + superChar p q cs.sum (nfPerm cs) = + (cs.map (fun c => superPS p q c)).prod := by + intro cs + induction cs with + | nil => + intro _ + change superChar p q 0 1 = (List.map (fun c => superPS p q c) + []).prod + unfold superChar + rw [permMor_one, sTr_id] + rw [show Module.finrank ℂ + (tensorPow SuperVect (stdSuper p q) 0).even = 1 from + Module.finrank_self ℂ] + have : Subsingleton + (tensorPow SuperVect (stdSuper p q) 0).odd := + inferInstanceAs (Subsingleton PUnit) + rw [show Module.finrank ℂ + (tensorPow SuperVect (stdSuper p q) 0).odd = 0 from + Module.finrank_eq_zero_of_subsingleton _ _] + rw [List.map_nil, List.prod_nil] + norm_num + | cons c cs ih => + intro hpos + refine Eq.trans + (superChar_blockEmbed p q (nfCycle c) (nfPerm cs)) ?_ + rw [superChar_nfCycle p q (hpos c List.mem_cons_self), + ih (fun d hd => hpos d (List.mem_cons_of_mem c hd)), + List.map_cons, List.prod_cons] + +/-- Relabelling along an equality of sizes preserves the super +character. -/ +theorem superChar_permCast (p q : ℕ) {m n : ℕ} (h : m = n) + (σ : Equiv.Perm (Fin m)) : + superChar p q n (permCast h σ) = superChar p q m σ := by + subst h + rw [permCast_rfl] + rfl + +/-! ## The character formula -/ + +/-- **The super character formula** (super Schur–Weyl, character +side): the trace of a permutation's action on the tensor power of +the standard super object of dimension `(p, q)` is the completed +cycle product of the super power sums. -/ +theorem sTr_permMor (p q : ℕ) {n : ℕ} (σ : Equiv.Perm (Fin n)) : + sTr (permMor (stdSuper p q) n σ) = cycleFun (superPS p q) σ := by + classical + set cs : List ℕ := σ.cycleType.toList ++ + List.replicate (n - σ.cycleType.sum) 1 with hcs + have hpos : ∀ c ∈ cs, 1 ≤ c := by + intro c hc + rcases List.mem_append.mp hc with h1 | h1 + · have := Equiv.Perm.two_le_of_mem_cycleType + (Multiset.mem_toList.mp h1) + omega + · rw [List.eq_of_mem_replicate h1] + have hsumle : σ.cycleType.sum ≤ n := by + have h1 := Equiv.Perm.sum_cycleType_le σ + rwa [Fintype.card_fin] at h1 + have hsum : cs.sum = n := by + rw [hcs, List.sum_append, List.sum_replicate, smul_eq_mul, + mul_one, Multiset.sum_toList] + omega + have hfilter : cs.filter (fun c => decide (2 ≤ c)) = + σ.cycleType.toList := by + rw [hcs, List.filter_append] + have h1 : σ.cycleType.toList.filter (fun c => decide (2 ≤ c)) = + σ.cycleType.toList := + List.filter_eq_self.mpr fun c hc => by + simpa using Equiv.Perm.two_le_of_mem_cycleType + (Multiset.mem_toList.mp hc) + have h2 : (List.replicate (n - σ.cycleType.sum) 1).filter + (fun c => decide (2 ≤ c)) = [] := by + refine List.filter_eq_nil_iff.mpr fun a ha => ?_ + rw [List.eq_of_mem_replicate ha] + decide + rw [h1, h2, List.append_nil] + have hct : (permCast hsum (nfPerm cs)).cycleType = σ.cycleType + := by + rw [cycleType_permCast, cycleType_nfPerm, hfilter, + Multiset.coe_toList] + have hconj : IsConj σ (permCast hsum (nfPerm cs)) := + Equiv.Perm.isConj_iff_cycleType_eq.mpr hct.symm + obtain ⟨u, hu⟩ := isConj_iff.mp hconj + have hchar : sTr (permMor (stdSuper p q) n σ) = + (cs.map (fun c => superPS p q c)).prod := by + calc sTr (permMor (stdSuper p q) n σ) + = superChar p q n (u * σ * u⁻¹) := + (superChar_conj p q u σ).symm + _ = superChar p q n (permCast hsum (nfPerm cs)) := by rw [hu] + _ = superChar p q cs.sum (nfPerm cs) := + superChar_permCast p q hsum _ + _ = (cs.map (fun c => superPS p q c)).prod := + superChar_nfPerm p q cs hpos + rw [hchar, hcs, List.map_append, List.prod_append, + List.map_replicate, List.prod_replicate, cycleFun] + rw [show ((σ.cycleType.toList.map fun c => superPS p q c).prod) = + (σ.cycleType.map (superPS p q)).prod from by + conv_rhs => rw [← Multiset.coe_toList σ.cycleType] + rfl] + +/-! ## Nonvanishing of the idempotent action -/ + +/-- **The idempotent trace formula**: the super trace of a package +idempotent's action on the tensor power of the standard super +object is the dimension times the Schur specialisation at the super +power sums. -/ +theorem sTr_permAlg_e (P : SchurPackage.{0}) (p q : ℕ) + (lam : YoungDiagram) : + sTr (permAlg (stdSuper p q) lam.card (P.e lam)) = + (P.dim lam : ℂ) * diagramSchur lam (superPS p q) := by + classical + set L : SymGroupAlgebra lam.card →ₗ[ℂ] ℂ := + (sTrL (tensorPow SuperVect (stdSuper p q) lam.card)).comp + (permAlg (stdSuper p q) lam.card).toLinearMap with hL + have hLof : ∀ π : Equiv.Perm (Fin lam.card), + L (MonoidAlgebra.of ℂ (Equiv.Perm (Fin lam.card)) π) = + cycleFun (superPS p q) π := by + intro π + change sTrL _ (permAlg (stdSuper p q) lam.card + (MonoidAlgebra.of ℂ (Equiv.Perm (Fin lam.card)) π)) = _ + rw [show MonoidAlgebra.of ℂ (Equiv.Perm (Fin lam.card)) π = + MonoidAlgebra.single π (1 : ℂ) from rfl, permAlg_single, + sTrL_apply, sTr_permMor] + have hgoal : sTr (permAlg (stdSuper p q) lam.card (P.e lam)) = + L (P.e lam) := rfl + rw [hgoal, SchurPackage.e_def, charIdempotent, map_smul, map_sum] + rw [Finset.sum_congr rfl fun π _ => show + L (P.char lam π • MonoidAlgebra.of ℂ + (Equiv.Perm (Fin lam.card)) π) = + P.char lam π * cycleFun (superPS p q) π from by + rw [map_smul, hLof π, smul_eq_mul]] + rw [smul_eq_mul, show ((P.dim lam : ℂ) / + (lam.card.factorial : ℂ)) * + (∑ π : Equiv.Perm (Fin lam.card), + P.char lam π * cycleFun (superPS p q) π) = + (P.dim lam : ℂ) * (((lam.card.factorial : ℂ))⁻¹ * + ∑ π : Equiv.Perm (Fin lam.card), + P.char lam π * cycleFun (superPS p q) π) from by ring] + congr 1 + exact P.frobenius lam (superPS p q) + +/-- **Schur nonvanishing on the standard super vector space** +(Deligne 1.9, nonvanishing direction): a diagram avoiding the cell +`(p, q)` does not kill the standard super object of dimension +`(p, q)` — the central idempotent of its block acts nonzero on the +tensor power. -/ +theorem not_schurKilled_stdSuper (P : SchurPackage.{0}) {p q : ℕ} + {lam : YoungDiagram} (h : (p, q) ∉ lam) : + ¬ SchurKilled P (stdSuper p q) lam := by + intro h0 + have hval := sTr_permAlg_e P p q lam + have h0' : permAlg (stdSuper p q) lam.card (P.e lam) = 0 := h0 + rw [h0'] at hval + obtain ⟨m, hm, hs⟩ := diagramSchur_superPS_pos lam h + rw [hs] at hval + have hzero : sTr (0 : tensorPow SuperVect (stdSuper p q) lam.card + ⟶ tensorPow SuperVect (stdSuper p q) lam.card) = 0 := by + rw [sTr, SuperVect.zero_evenMap, SuperVect.zero_oddMap, + map_zero, map_zero, add_zero] + have hd := P.dim_pos lam + have hne : ((P.dim lam : ℂ)) * (m : ℂ) ≠ 0 := by + refine mul_ne_zero ?_ ?_ + · exact Nat.cast_ne_zero.mpr (by omega) + · exact Nat.cast_ne_zero.mpr (by omega) + exact hne (hzero.symm.trans hval).symm + +/-! ## The graded signed permutation representation + +The same action, packaged as a genuine representation of the +symmetric group on the total space of the tensor power — the free +module on colourings carrying the Koszul signs, in its categorical +presentation. -/ + +/-- **The graded signed permutation representation**: the symmetric +group acting on the total space of the tensor power of the standard +super object, by the categorical action with its Koszul signs. -/ +def gradedSignRep (p q n : ℕ) : + Representation ℂ (Equiv.Perm (Fin n)) + (Tot (tensorPow SuperVect (stdSuper p q) n)) where + toFun σ := tot (permMor (stdSuper p q) n σ) + map_one' := by rw [permMor_one, tot_id]; rfl + map_mul' σ τ := by + change tot (permMor (stdSuper p q) n (σ * τ)) = _ + rw [permMor_mul, tot_comp] + rfl + +/-- The representation of a permutation is the total map of its +categorical action. -/ +theorem gradedSignRep_apply (p q n : ℕ) (σ : Equiv.Perm (Fin n)) : + gradedSignRep p q n σ = tot (permMor (stdSuper p q) n σ) := rfl + +/-- The algebra action of the representation is the total map of +the categorical algebra action. -/ +theorem gradedSignRep_asAlgebraHom (p q n : ℕ) + (z : SymGroupAlgebra n) : + (gradedSignRep p q n).asAlgebraHom z = + tot (permAlg (stdSuper p q) n z) := by + induction z using MonoidAlgebra.induction_on with + | of σ => + change (gradedSignRep p q n).asAlgebraHom + (MonoidAlgebra.single σ (1 : ℂ)) = + tot (permAlg (stdSuper p q) n + (MonoidAlgebra.single σ (1 : ℂ))) + rw [Representation.asAlgebraHom_single, one_smul, + gradedSignRep_apply] + exact congrArg tot (permAlg_single _ _ σ).symm + | add a b ha hb => + rw [map_add, map_add, ha, hb] + exact (tot_add (permAlg (stdSuper p q) n a) + (permAlg (stdSuper p q) n b)).symm + | smul r a ha => + rw [map_smul, map_smul, ha] + exact (tot_smul r (permAlg (stdSuper p q) n a)).symm + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymAlg.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymAlg.lean new file mode 100644 index 0000000000..395edefb25 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymAlg.lean @@ -0,0 +1,1981 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedConc + +/-! +# Module powers and symmetric powers over an internal monoid + +The substrate of the Key Lemma: for an internal monoid `A` and a +left module `X` in a symmetric monoidal category, the `n`-th module +power `X ^ ⊗_A n` is presented in one step, with no associativity of +a binary product anywhere — it is the coequalizer of a single pair + + `⊕ᵢ Rᵢ ⇉ X ^ ⊗ n` + +whose source is the finite biproduct, over the `n − 1` adjacent +slots, of the relation objects `Rᵢ = X^⊗a ⊗ ((X ⊗ A) ⊗ X) ⊗ X^⊗b` +(`a + 2 + b = n`), and whose legs act on the slot through the +braided right action and the left action respectively — identifying +`(x·c) ⊗ y` with `x ⊗ (c·y)` in every adjacent slot at once. + +* `modPow A X n`, `modPowπ`, `modPowDesc`, `modPow_hom_ext`: the + power and its universal property. Slot conditions are quantified + over decompositions `a + 2 + b = n` (with a `powCast` transport), + so consumers never meet truncated subtraction. +* `modPowZero`, `modPowOne`: at `n ≤ 1` there are no slots, the + legs agree, and the projection is an isomorphism. +* `modPowPerm`: the permutation action of `Envelope/SymPerm.lean` + descends to the module power; `modPowPermHom`, `modPowAlg` package + it as a monoid homomorphism and a `ℂ`-algebra map. The descent is + proved on the adjacent transpositions and extended by generation; + commutativity of `A` is not needed, because the braided right + action is by definition the left action through the braiding. +* `symmetriser n`: the trivial-character central idempotent + `(1/n!) • ∑ σ, σ` of the group algebra, with absorption and + idempotency. +* `symPow A X n`: the symmetric power, presented as the coequalizer + of `modPowAlg (symmetriser n)` against the identity — the + coinvariants — which the idempotent splits into a direct summand: + `symPowσ ≫ symPowπ = 𝟙` and `symPowπ ≫ symPowσ` is the + symmetriser's action. This presentation is chosen because the + consumers build morphisms out of `symPow` by descent along + `symPowπ` and morphisms in through the section `symPowσ`. +The multiplication maps between module powers of different arities +are outside this module's scope; `tensorPowConcat_peel` and the +frame machinery below are the concatenation substrate they will +consume. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## Transport along equal arities -/ + +section PowCast + +/-- Transport of a tensor power along an equality of arities. It is +an `eqToHom`, so it composes and cancels by `eqToHom` simp lemmas. -/ +def powCast [Category.{v} D] [MonoidalCategory D] (X : D) + {m n : ℕ} (h : m = n) : + tensorPow D X m ⟶ tensorPow D X n := + eqToHom (congrArg (tensorPow D X) h) + +@[simp] +theorem powCast_rfl [Category.{v} D] [MonoidalCategory D] (X : D) + (n : ℕ) : powCast X (rfl : n = n) = 𝟙 _ := rfl + +@[reassoc (attr := simp)] +theorem powCast_comp [Category.{v} D] [MonoidalCategory D] (X : D) + {m n k : ℕ} (h : m = n) (h' : n = k) : + powCast X h ≫ powCast X h' = powCast X (h.trans h') := by + simp [powCast] + +/-- Two arity transports with the same endpoints agree. -/ +theorem powCast_irrel [Category.{v} D] [MonoidalCategory D] (X : D) + {m n : ℕ} (h h' : m = n) : + powCast X h = powCast X h' := rfl + +/-- Whiskering an arity transport is an arity transport. -/ +theorem powCast_whiskerRight [Category.{v} D] [MonoidalCategory D] (X : D) + {m n : ℕ} (h : m = n) : + powCast X h ▷ X = powCast X (by omega : m + 1 = n + 1) := by + subst h + simp only [powCast_rfl, MonoidalCategory.id_whiskerRight] + rfl + +end PowCast + +/-! ## Peeling the first factor off a tensor power + +The tensor power grows at the top, so the bottom factor is exposed +by a recursion of its own; the peeling intertwines the two +concatenation stages `p + (q + 1)` and `(p + 1) + q`, which is what +lets a relation slot and an adjacent braiding that overlap in one +module factor be compared in a common frame. +-/ + +section Peel + +/-- Peel the first factor off a non-empty tensor power. -/ +noncomputable def powPeel + [Category.{v} D] [MonoidalCategory D] (X : D) : (q : ℕ) → + (tensorPow D X (q + 1) ≅ X ⊗ tensorPow D X q) + | 0 => λ_ X ≪≫ (ρ_ X).symm + | q + 1 => whiskerRightIso (powPeel X q) X ≪≫ α_ X (tensorPow D X q) X + +/-- The base case of the peeling. -/ +theorem powPeel_zero [Category.{v} D] [MonoidalCategory D] (X : D) : + powPeel X 0 = λ_ X ≪≫ (ρ_ X).symm := rfl + +/-- Attach a peeled factor to the power below it. The associator, +retyped so that its target is stated through the tensor power — this +keeps every statement about it type-correct at low transparency. -/ +noncomputable def powAttach [Category.{v} D] [MonoidalCategory D] (X : D) + (p q : ℕ) : + tensorPow D X p ⊗ (X ⊗ tensorPow D X q) ⟶ + tensorPow D X (p + 1) ⊗ tensorPow D X q := + (α_ (tensorPow D X p) X (tensorPow D X q)).inv + +/-- Expose the top factor of the second block of a pair of powers. +The associator, retyped so that its source is stated through the +tensor power. -/ +noncomputable def powExpose [Category.{v} D] [MonoidalCategory D] (X : D) + (p q : ℕ) : + tensorPow D X p ⊗ tensorPow D X (q + 1) ⟶ + (tensorPow D X p ⊗ tensorPow D X q) ⊗ X := + (α_ (tensorPow D X p) (tensorPow D X q) X).inv + +/-- The successor stage of the concatenation, through the exposed +top factor; definitional. -/ +theorem tensorPowConcat_succ_hom [Category.{v} D] [MonoidalCategory D] (X : D) + (p q : ℕ) : + (tensorPowConcat X p (q + 1)).hom = + powExpose X p q ≫ ((tensorPowConcat X p q).hom ▷ X) := + rfl + +/-- The base case of the concatenation shift, at general objects. -/ +private theorem concat_peel_zero_aux + [Category.{v} D] [MonoidalCategory D] (X : D) + (P : D) : + (α_ P (𝟙_ D) X).inv ≫ ((ρ_ P).hom ▷ X) = + (P ◁ ((λ_ X).hom ≫ (ρ_ X).inv)) ≫ (α_ P X (𝟙_ D)).inv ≫ + (ρ_ (P ⊗ X)).hom := by + monoidal + +/-- The associator shuffle of the concatenation shift, at general +objects. -/ +private theorem concat_peel_step_aux + [Category.{v} D] [MonoidalCategory D] (X : D) + {P R S : D} (e : R ⟶ X ⊗ S) : + (α_ P R X).inv ≫ ((P ◁ e) ▷ X) ≫ ((α_ P X S).inv ▷ X) = + (P ◁ ((e ▷ X) ≫ (α_ X S X).hom)) ≫ + (α_ P X (S ⊗ X)).inv ≫ (α_ (P ⊗ X) S X).inv := by + have hpent : (α_ P (X ⊗ S) X).inv ≫ ((α_ P X S).inv ▷ X) = + (P ◁ (α_ X S X).hom) ≫ (α_ P X (S ⊗ X)).inv ≫ + (α_ (P ⊗ X) S X).inv := by + monoidal + rw [MonoidalCategory.whiskerLeft_comp, Category.assoc, ← hpent, + ← MonoidalCategory.associator_inv_naturality_middle_assoc] + +/-- The step of the concatenation shift, stated through the retyped +bridges and the unexpanded peeling, so that every composite is typed +at a tensor power. -/ +private theorem concat_peel_step [Category.{v} D] [MonoidalCategory D] (X : D) + (p q : ℕ) : + powExpose X p (q + 1) ≫ + ((tensorPow D X p ◁ (powPeel X q).hom) ▷ X) ≫ + (powAttach X p q ▷ X) ≫ + ((tensorPowConcat X (p + 1) q).hom ▷ X) = + (tensorPow D X p ◁ (powPeel X (q + 1)).hom) ≫ + powAttach X p (q + 1) ≫ + (tensorPowConcat X (p + 1) (q + 1)).hom := by + suffices hpre : powExpose X p (q + 1) ≫ + ((tensorPow D X p ◁ (powPeel X q).hom) ▷ X) ≫ + (powAttach X p q ▷ X) = + (tensorPow D X p ◁ (powPeel X (q + 1)).hom) ≫ + powAttach X p (q + 1) ≫ powExpose X (p + 1) q by + rw [tensorPowConcat_succ_hom X (p + 1) q] + simp only [← Category.assoc] at hpre ⊢ + rw [hpre] + simp only [Category.assoc] + rfl + exact concat_peel_step_aux X (powPeel X q).hom + +/-- **The concatenation shift**: concatenating `p` with `q + 1` +factors is peeling the first of the `q + 1`, attaching it to the +`p`, and concatenating `p + 1` with `q`. -/ +theorem tensorPowConcat_peel [Category.{v} D] [MonoidalCategory D] (X : D) + (p : ℕ) : ∀ q : ℕ, + (tensorPowConcat X p (q + 1)).hom = + (tensorPow D X p ◁ (powPeel X q).hom) ≫ + powAttach X p q ≫ + (tensorPowConcat X (p + 1) q).hom ≫ + powCast X (by omega : p + 1 + q = p + (q + 1)) + | 0 => by + rw [tensorPowConcat_succ X p 0, powPeel_zero, + tensorPowConcat_zero, tensorPowConcat_zero] + simp only [Iso.trans_hom, Iso.symm_hom] + exact (concat_peel_zero_aux X (tensorPow D X p)).trans + (congrArg (fun z => + (tensorPow D X p ◁ ((λ_ X).hom ≫ (ρ_ X).inv)) ≫ + (α_ (tensorPow D X p) X (𝟙_ D)).inv ≫ z) + (Category.comp_id (ρ_ (tensorPow D X p ⊗ X)).hom)).symm + | q + 1 => by + rw [tensorPowConcat_succ_hom X p (q + 1), tensorPowConcat_peel X p q] + simp only [MonoidalCategory.comp_whiskerRight] + erw [powCast_whiskerRight, reassoc_of% (concat_peel_step X p q)] + exact (Category.assoc _ _ _).trans (congrArg + (fun z => (tensorPow D X p ◁ (powPeel X (q + 1)).hom) ≫ z) + (Category.assoc _ _ _)) + +end Peel + +/-! ## The slot relation + +The local shape of one relation slot: on `(X ⊗ A) ⊗ X`, either the +monoid acts on the left factor through the braided right action, or +it associates and acts on the right factor. These are the legs of +`ModTensor.lean` at the module `X` itself, unbundled. +-/ + +section WinLeg + +/-- The slot leg acting on the left factor, through the braided +right action. -/ +noncomputable def winLegM + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] : (X ⊗ A) ⊗ X ⟶ X ⊗ X := + actRight A X ▷ X + +/-- The slot leg acting on the right factor: associate, then act. -/ +noncomputable def winLegN + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : D) + [ModObj A X] : (X ⊗ A) ⊗ X ⟶ X ⊗ X := + (α_ X A X).hom ≫ X ◁ actLeft A X + +end WinLeg + +/-! ## The relation pair of the module power -/ + +section ModPowDefs + +/-- The relation object of the slot `a + 2 + b = n`: the ambient +power with the monoid inserted between the module factors in slots +`a` and `a + 1`. An abbreviation, so that statements about it stay +type-correct at low transparency. -/ +abbrev modPowMid [Category.{v} D] [MonoidalCategory D] (A : D) (X : D) + (a b : ℕ) : D := + (tensorPow D X a ⊗ ((X ⊗ A) ⊗ X)) ⊗ tensorPow D X b + +/-- Glue a resolved slot back into the ambient power: reassociate +the two exposed factors onto the lower power and concatenate. -/ +noncomputable def modPowGlue [Category.{v} D] [MonoidalCategory D] (X : D) + (a b : ℕ) : + (tensorPow D X a ⊗ (X ⊗ X)) ⊗ tensorPow D X b ⟶ + tensorPow D X (a + 2 + b) := + ((α_ (tensorPow D X a) X X).inv ▷ tensorPow D X b) ≫ + (tensorPowConcat X (a + 2) b).hom + +/-- The first relation leg at slot `(a, b)`: act on the left module +factor through the braided right action, then glue. -/ +noncomputable def modPowLegM + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] + (a b : ℕ) : + modPowMid A X a b ⟶ tensorPow D X (a + 2 + b) := + ((tensorPow D X a ◁ winLegM A X) ▷ tensorPow D X b) ≫ + modPowGlue X a b + +/-- The second relation leg at slot `(a, b)`: associate and act on +the right module factor, then glue. -/ +noncomputable def modPowLegN + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : D) + [ModObj A X] + (a b : ℕ) : + modPowMid A X a b ⟶ tensorPow D X (a + 2 + b) := + ((tensorPow D X a ◁ winLegN A X) ▷ tensorPow D X b) ≫ + modPowGlue X a b + +variable {A X} in +/-- Each slot index of arity `n` decomposes it. -/ +theorem slot_decomp {n : ℕ} (i : Fin (n - 1)) : + i.val + 2 + (n - 2 - i.val) = n := by + have := i.isLt; omega + +/-- The source of the relation pair: the biproduct of the relation +objects over all `n − 1` adjacent slots. An abbreviation, so that +the biproduct API applies to the legs without unfolding. -/ +noncomputable abbrev modPowSrc + [Category.{v} D] [MonoidalCategory D] (A : D) (X : D) [Preadditive D] + [HasFiniteBiproducts D] + (n : ℕ) : D := + ⨁ fun i : Fin (n - 1) => modPowMid A X i.val (n - 2 - i.val) + +/-- The first leg of the relation pair, assembled over all slots. -/ +noncomputable def modPowLegFst + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + (n : ℕ) : + modPowSrc A X n ⟶ tensorPow D X n := + biproduct.desc fun i => + modPowLegM A X i.val (n - 2 - i.val) ≫ powCast X (slot_decomp i) + +/-- The second leg of the relation pair, assembled over all slots. -/ +noncomputable def modPowLegSnd + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : D) + [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + (n : ℕ) : + modPowSrc A X n ⟶ tensorPow D X n := + biproduct.desc fun i => + modPowLegN A X i.val (n - 2 - i.val) ≫ powCast X (slot_decomp i) + +end ModPowDefs + +/-! ## The module power and its universal property -/ + +section ModPow + +/-- **The `n`-th module power** of `X` over `A`: the coequalizer of +the wide relation pair, identifying `(x·c) ⊗ y ~ x ⊗ (c·y)` in every +adjacent slot simultaneously. No binary module tensor product and +no associativity enter. -/ +noncomputable def modPow + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (n : ℕ) : D := + coequalizer (modPowLegFst A X n) (modPowLegSnd A X n) + +/-- The projection of the ambient power onto the module power. -/ +noncomputable def modPowπ + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (n : ℕ) : + tensorPow D X n ⟶ modPow A X n := + coequalizer.π _ _ + +instance [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (n : ℕ) : Epi (modPowπ A X n) := + inferInstanceAs (Epi (coequalizer.π _ _)) + +/-- The two assembled legs agree after the projection. -/ +@[reassoc] +theorem modPow_condition + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (n : ℕ) : + modPowLegFst A X n ≫ modPowπ A X n = + modPowLegSnd A X n ≫ modPowπ A X n := + coequalizer.condition _ _ + +/-- **The slot relation in the module power**: at every +decomposition `a + 2 + b = n` the two slot legs agree after the +projection. -/ +@[reassoc] +theorem modPow_rel + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + {n : ℕ} (a b : ℕ) (h : a + 2 + b = n) : + modPowLegM A X a b ≫ powCast X h ≫ modPowπ A X n = + modPowLegN A X a b ≫ powCast X h ≫ modPowπ A X n := by + have hb : b = n - 2 - a := by omega + subst hb + have hi : a < n - 1 := by omega + have h2 : biproduct.ι + (fun i : Fin (n - 1) => modPowMid A X i.val (n - 2 - i.val)) + ⟨a, hi⟩ ≫ modPowLegFst A X n ≫ modPowπ A X n = + biproduct.ι + (fun i : Fin (n - 1) => modPowMid A X i.val (n - 2 - i.val)) + ⟨a, hi⟩ ≫ modPowLegSnd A X n ≫ modPowπ A X n := by + rw [modPow_condition] + simp only [modPowLegFst, modPowLegSnd, biproduct.ι_desc_assoc, + Category.assoc] at h2 + exact h2 + +/-- Morphisms out of the module power are determined by their +composite with the projection. -/ +theorem modPow_hom_ext + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + {n : ℕ} {W : D} {k l : modPow A X n ⟶ W} + (h : modPowπ A X n ≫ k = modPowπ A X n ≫ l) : k = l := + coequalizer.hom_ext h + +/-- Descend a morphism that coequalizes every slot relation to the +module power. -/ +noncomputable def modPowDesc + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + {n : ℕ} {W : D} (k : tensorPow D X n ⟶ W) + (h : ∀ a b (hab : a + 2 + b = n), + modPowLegM A X a b ≫ powCast X hab ≫ k = + modPowLegN A X a b ≫ powCast X hab ≫ k) : + modPow A X n ⟶ W := + coequalizer.desc k (by + apply biproduct.hom_ext' + intro i + simp only [modPowLegFst, modPowLegSnd, biproduct.ι_desc_assoc, + Category.assoc] + exact h i.val (n - 2 - i.val) (slot_decomp i)) + +/-- The descent factors the given morphism through the +projection. -/ +@[reassoc (attr := simp)] +theorem modPowπ_desc + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + {n : ℕ} {W : D} (k : tensorPow D X n ⟶ W) + (h : ∀ a b (hab : a + 2 + b = n), + modPowLegM A X a b ≫ powCast X hab ≫ k = + modPowLegN A X a b ≫ powCast X hab ≫ k) : + modPowπ A X n ≫ modPowDesc A X k h = k := + coequalizer.π_desc _ _ + +/-! ### The empty and singleton powers + +At `n ≤ 1` there are no adjacent slots: the relation source is the +empty biproduct, the legs agree, and the projection is an +isomorphism. +-/ + +/-- Below two factors the projection is an isomorphism. -/ +noncomputable def modPowTriv + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + {n : ℕ} (h : n ≤ 1) : + modPow A X n ≅ tensorPow D X n where + hom := modPowDesc A X (𝟙 _) (fun a b hab => absurd hab (by omega)) + inv := modPowπ A X n + hom_inv_id := modPow_hom_ext A X (by + rw [modPowπ_desc_assoc, Category.id_comp, Category.comp_id]) + inv_hom_id := modPowπ_desc A X _ _ + +/-- **The empty module power is the unit.** -/ +noncomputable def modPowZero + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] : modPow A X 0 ≅ 𝟙_ D := + modPowTriv A X (by omega) + +/-- **The singleton module power is the module.** -/ +noncomputable def modPowOne + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] : modPow A X 1 ≅ X := + modPowTriv A X (by omega) ≪≫ λ_ X + +/-! ### Whiskering the presentation on the right + +Tensoring on the right by a fixed object carries the coequalizer +presenting the module power to a coequalizer, so a morphism out of +the whiskered module power is a morphism out of the whiskered +ambient power that respects the whiskered relation. The hypothesis +is the exact colimit preservation needed, so that the kit applies +both where tensoring on the left is assumed exact and where +tensoring on the right is. +-/ + +/-- Whiskering the module-power coequalizer on the right yields a +colimit cofork. -/ +noncomputable def modPowWhiskerRightIsColimit + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] (n : ℕ) (W : D) + [PreservesColimit (parallelPair (modPowLegFst A X n) (modPowLegSnd A X + n)) (tensorRight W)] : + IsColimit (Cofork.ofπ (modPowπ A X n ▷ W) + (by rw [← MonoidalCategory.comp_whiskerRight, modPow_condition, + MonoidalCategory.comp_whiskerRight]) : + Cofork (modPowLegFst A X n ▷ W) (modPowLegSnd A X n ▷ W)) := + isColimitOfHasCoequalizerOfPreservesColimit (tensorRight W) _ _ + +/-- Morphisms out of a right-whiskered module power are determined +by their composite with the whiskered projection. -/ +theorem modPow_whiskerRight_hom_ext + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] (n : ℕ) (W : D) + [PreservesColimit (parallelPair (modPowLegFst A X n) (modPowLegSnd A X + n)) (tensorRight W)] + {Z : D} + {k l : modPow A X n ⊗ W ⟶ Z} + (h : (modPowπ A X n ▷ W) ≫ k = (modPowπ A X n ▷ W) ≫ l) : + k = l := + Cofork.IsColimit.hom_ext (modPowWhiskerRightIsColimit A X n W) h + +/-- The right-whiskered projection is an epimorphism. -/ +instance epi_modPowπ_whiskerRight + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] (n : ℕ) (W : D) + [PreservesColimit (parallelPair (modPowLegFst A X n) (modPowLegSnd A X + n)) (tensorRight W)] : Epi (modPowπ A X n ▷ W) := + epi_of_isColimit_cofork (modPowWhiskerRightIsColimit A X n W) + +/-- Descend a morphism along the right-whiskered projection. -/ +noncomputable def modPowWhiskerRightDesc + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] (n : ℕ) (W : D) + [PreservesColimit (parallelPair (modPowLegFst A X n) (modPowLegSnd A X + n)) (tensorRight W)] + {Z : D} + (k : tensorPow D X n ⊗ W ⟶ Z) + (h : (modPowLegFst A X n ▷ W) ≫ k = + (modPowLegSnd A X n ▷ W) ≫ k) : + modPow A X n ⊗ W ⟶ Z := + Cofork.IsColimit.desc (modPowWhiskerRightIsColimit A X n W) k h + +/-- The right-whiskered descent factors through the whiskered +projection. -/ +@[reassoc (attr := simp)] +theorem modPowπ_whiskerRight_desc + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] (n : ℕ) (W : D) + [PreservesColimit (parallelPair (modPowLegFst A X n) (modPowLegSnd A X + n)) (tensorRight W)] + {Z : D} + (k : tensorPow D X n ⊗ W ⟶ Z) + (h : (modPowLegFst A X n ▷ W) ≫ k = + (modPowLegSnd A X n ▷ W) ≫ k) : + (modPowπ A X n ▷ W) ≫ modPowWhiskerRightDesc A X n W k h = k := + Cofork.IsColimit.π_desc' (modPowWhiskerRightIsColimit A X n W) k h + +end ModPow + +/-! ## The adjacent transposition on the ambient power + +The permutation action descends to the module power once it +descends on the adjacent transpositions, which act by a braiding of +two adjacent slots — the top braiding of the first `a + 2` factors, +conjugated into the ambient power by the concatenation. +-/ + +section AdjSwap + +/-- The braiding of slots `a` and `a + 1` of the ambient power: +the top braiding of the first `a + 2` factors, in block form. -/ +noncomputable def adjSwapMor + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) + (a b : ℕ) : + tensorPow D X (a + 2 + b) ⟶ tensorPow D X (a + 2 + b) := + (tensorPowConcat X (a + 2) b).inv ≫ + (swapTop X a ▷ tensorPow D X b) ≫ + (tensorPowConcat X (a + 2) b).hom + +/-- Conjugation carries a transposition to the transposition of the +images. -/ +private theorem permCongr_swap {α β : Type*} [DecidableEq α] + [DecidableEq β] (e : α ≃ β) (u v : α) : + e.permCongr (Equiv.swap u v) = Equiv.swap (e u) (e v) := by + rw [Equiv.permCongr_def] + exact Equiv.symm_trans_swap_trans u v e + +/-- A block-embedded transposition of the first block. -/ +private theorem blockEmbed_swap_one {p b : ℕ} (u v : Fin p) : + blockEmbed (Equiv.swap u v) (1 : Equiv.Perm (Fin b)) = + Equiv.swap (Fin.castAdd b u) (Fin.castAdd b v) := by + rw [blockEmbed, Equiv.Perm.one_def, Equiv.Perm.sumCongr_swap_refl, + permCongr_swap] + rfl + +/-- A block-embedded transposition of the last block. -/ +private theorem blockEmbed_one_swap {p b : ℕ} (u v : Fin b) : + blockEmbed (1 : Equiv.Perm (Fin p)) (Equiv.swap u v) = + Equiv.swap (Fin.natAdd p u) (Fin.natAdd p v) := by + rw [blockEmbed, Equiv.Perm.one_def, Equiv.Perm.sumCongr_refl_swap, + permCongr_swap] + rfl + +/-- The top transposition, as a transposition of explicit slots. -/ +private theorem topSwap_eq_mk (a : ℕ) : + (topSwap : Equiv.Perm (Fin (a + 2))) = + Equiv.swap ⟨a, by omega⟩ ⟨a + 1, by omega⟩ := + rfl + +/-- **The adjacent braiding is the action of the adjacent +transposition.** -/ +theorem adjSwapMor_eq_permMor + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) + (a b : ℕ) : + adjSwapMor X a b = + permMor X (a + 2 + b) + (Equiv.swap ⟨a, by omega⟩ ⟨a + 1, by omega⟩) := by + have hswap : + (Equiv.swap (⟨a, by omega⟩ : Fin (a + 2 + b)) ⟨a + 1, by omega⟩) + = blockEmbed (topSwap : Equiv.Perm (Fin (a + 2))) + (1 : Equiv.Perm (Fin b)) := by + rw [topSwap_eq_mk, blockEmbed_swap_one] + rfl + rw [hswap, adjSwapMor, ← permMor_topSwap_eq, Iso.inv_comp_eq, + tensorPowConcat_permMor_fst] + +/-- Transport of a permutation action along an equality of +arities. -/ +theorem powCast_permMor + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) + {m n : ℕ} (h : m = n) + (σ : Equiv.Perm (Fin m)) : + powCast X h ≫ permMor X n ((finCongr h).permCongr σ) = + permMor X m σ ≫ powCast X h := by + subst h + have hσ : (finCongr (rfl : m = m)).permCongr σ = σ := + Equiv.ext fun i => by simp + rw [hσ] + simp [powCast] + +/-- Transport of a transposition action along an equality of +arities. -/ +theorem powCast_permMor_swap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) + {m n : ℕ} (h : m = n) (u v : Fin m) : + powCast X h ≫ permMor X n (Equiv.swap (Fin.cast h u) (Fin.cast h v)) = + permMor X m (Equiv.swap u v) ≫ powCast X h := by + have h2 := powCast_permMor X h (Equiv.swap u v) + rwa [permCongr_swap, finCongr_apply, finCongr_apply] at h2 + +end AdjSwap + +/-! ## The braiding at a relation slot + +The braiding of the two module factors of a slot carries the monoid +along; the relation legs intertwine it with the plain braiding on +the resolved slot. No commutativity of the monoid is needed: the +braided right action is by definition the left action through the +braiding, so the exchanged slot acts by the same morphism. +-/ + +section WinSwap + +/-- Exchange of the two module factors of a relation slot, carrying +the monoid along: `(x ⊗ c) ⊗ y ↦ (y ⊗ c) ⊗ x`. -/ +noncomputable def winSwap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (A X : D) : (X ⊗ A) ⊗ X ⟶ (X ⊗ A) ⊗ X := + (β_ (X ⊗ A) X).hom ≫ (X ◁ (β_ X A).hom) ≫ (α_ X A X).inv + +/-- The slot exchange is an involution. -/ +@[reassoc (attr := simp)] +theorem winSwap_winSwap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (A X : D) : + winSwap A X ≫ winSwap A X = 𝟙 _ := by + simp only [winSwap, BraidedCategory.braiding_tensor_left_hom, + Category.assoc, Iso.inv_hom_id_assoc] + rw [← MonoidalCategory.whiskerLeft_comp_assoc X (β_ X A).hom + (β_ A X).hom, SymmetricCategory.symmetry, + MonoidalCategory.whiskerLeft_id, Category.id_comp, + Iso.hom_inv_id_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, + SymmetricCategory.symmetry, MonoidalCategory.id_whiskerRight, + Category.id_comp, Iso.inv_hom_id_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + SymmetricCategory.symmetry, MonoidalCategory.whiskerLeft_id, + Category.id_comp, Iso.hom_inv_id] + +/-- The first leg intertwines the slot exchange with the braiding: +acting on the left factor and braiding is exchanging and acting on +the right factor. -/ +theorem winLegM_braiding + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] : + winLegM A X ≫ (β_ X X).hom = winSwap A X ≫ winLegN A X := by + rw [winLegM, BraidedCategory.braiding_naturality_left, actRight, + MonoidalCategory.whiskerLeft_comp, winSwap, winLegN] + simp only [Category.assoc, Iso.inv_hom_id_assoc] + +/-- The second leg intertwines the slot exchange with the braiding, +by the involutivity of both. -/ +theorem winLegN_braiding + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] : + winLegN A X ≫ (β_ X X).hom = winSwap A X ≫ winLegM A X := by + have h1 : winLegM A X = winSwap A X ≫ winLegN A X ≫ (β_ X X).hom := by + rw [← Category.assoc, ← winLegM_braiding, Category.assoc, + SymmetricCategory.symmetry, Category.comp_id] + rw [h1, ← Category.assoc, ← Category.assoc, winSwap_winSwap, + Category.id_comp] + +end WinSwap + +/-! ## Descent of the slot relations under the adjacent braiding -/ + +section Descent + +/-- The same-slot conjugation, at general objects, so that no +tensor-power arity enters the rewriting. -/ +private theorem glue_adjSwap_aux + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + (X : D) + {P Q N : D} + (C : ((P ⊗ X) ⊗ X) ⊗ Q ≅ N) (u : (X ⊗ A) ⊗ X ⟶ X ⊗ X) : + (((P ◁ u) ▷ Q) ≫ ((α_ P X X).inv ▷ Q ≫ C.hom)) ≫ + (C.inv ≫ + (((α_ P X X).hom ≫ (P ◁ (β_ X X).hom) ≫ (α_ P X X).inv) ▷ Q) + ≫ C.hom) = + ((P ◁ (u ≫ (β_ X X).hom)) ▷ Q) ≫ + ((α_ P X X).inv ▷ Q ≫ C.hom) := by + have h : ((α_ P X X).inv ▷ Q) ≫ + (((α_ P X X).hom ≫ (P ◁ (β_ X X).hom) ≫ (α_ P X X).inv) ▷ Q) = + ((P ◁ (β_ X X).hom) ▷ Q) ≫ ((α_ P X X).inv ▷ Q) := by + rw [← MonoidalCategory.comp_whiskerRight, Iso.inv_hom_id_assoc, + MonoidalCategory.comp_whiskerRight] + simp only [Category.assoc, Iso.hom_inv_id_assoc] + rw [reassoc_of% h, ← MonoidalCategory.comp_whiskerRight_assoc, + ← MonoidalCategory.whiskerLeft_comp] + +/-- Postcomposing a glued slot morphism with the adjacent braiding +at the same slot braids the resolved factors. -/ +private theorem glue_adjSwap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + (X : D) + (a b : ℕ) (u : (X ⊗ A) ⊗ X ⟶ X ⊗ X) : + (((tensorPow D X a ◁ u) ▷ tensorPow D X b) ≫ modPowGlue X a b) ≫ + adjSwapMor X a b = + ((tensorPow D X a ◁ (u ≫ (β_ X X).hom)) ▷ tensorPow D X b) ≫ + modPowGlue X a b := + glue_adjSwap_aux A X (tensorPowConcat X (a + 2) b) u + +/-- The slot relation with no arity transport. -/ +@[reassoc] +theorem modPow_rel_self + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (a b : ℕ) : + modPowLegM A X a b ≫ modPowπ A X (a + 2 + b) = + modPowLegN A X a b ≫ modPowπ A X (a + 2 + b) := by + have h := modPow_rel A X a b (rfl : a + 2 + b = a + 2 + b) + simpa using h + +/-- **Descent along the projection**: the property that an ambient +endomorphism carries every slot relation into the kernel of the +projection again. -/ +def modPowDescends + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (n : ℕ) + (f : tensorPow D X n ⟶ tensorPow D X n) : Prop := + ∀ a b (hab : a + 2 + b = n), + modPowLegM A X a b ≫ powCast X hab ≫ f ≫ modPowπ A X n = + modPowLegN A X a b ≫ powCast X hab ≫ f ≫ modPowπ A X n + +/-- **The same-slot case**: the adjacent braiding at the slot of the +relation itself. -/ +private theorem adjSwap_rel_same + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (a b : ℕ) : + modPowLegM A X a b ≫ adjSwapMor X a b ≫ + modPowπ A X (a + 2 + b) = + modPowLegN A X a b ≫ adjSwapMor X a b ≫ + modPowπ A X (a + 2 + b) := by + have h1 : modPowLegM A X a b ≫ adjSwapMor X a b = + ((tensorPow D X a ◁ winSwap A X) ▷ tensorPow D X b) ≫ + modPowLegN A X a b := by + rw [modPowLegM, modPowLegN, glue_adjSwap A X a b, + winLegM_braiding, MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.comp_whiskerRight, Category.assoc] + have h2 : modPowLegN A X a b ≫ adjSwapMor X a b = + ((tensorPow D X a ◁ winSwap A X) ▷ tensorPow D X b) ≫ + modPowLegM A X a b := by + rw [modPowLegN, modPowLegM, glue_adjSwap A X a b, + winLegN_braiding, MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [← Category.assoc, h1, ← Category.assoc, h2, Category.assoc, + Category.assoc, modPow_rel_self] + +/-! ### The disjoint cases + +When the braided pair lies entirely inside the upper or lower +context of the relation slot, the braiding passes the legs by the +exchange law, through the block form of the embedded permutation. +-/ + +/-- A morphism conjugate to one of the upper context passes a glued +slot leg; at general objects. -/ +private theorem ctx_above_aux + [Category.{v} D] [MonoidalCategory D] (A : D) (X : D) + {P Q N : D} + (C : ((P ⊗ X) ⊗ X) ⊗ Q ≅ N) (w : (X ⊗ A) ⊗ X ⟶ X ⊗ X) + (v : Q ⟶ Q) (E : N ⟶ N) + (hE : C.hom ≫ E = (((P ⊗ X) ⊗ X) ◁ v) ≫ C.hom) : + (((P ◁ w) ▷ Q) ≫ ((α_ P X X).inv ▷ Q ≫ C.hom)) ≫ E = + ((P ⊗ ((X ⊗ A) ⊗ X)) ◁ v) ≫ + (((P ◁ w) ▷ Q) ≫ ((α_ P X X).inv ▷ Q ≫ C.hom)) := by + simp only [Category.assoc, hE] + rw [← MonoidalCategory.whisker_exchange_assoc, + ← MonoidalCategory.whisker_exchange_assoc] + +/-- A morphism conjugate to one of the lower context passes a glued +slot leg; at general objects. -/ +private theorem ctx_below_aux + [Category.{v} D] [MonoidalCategory D] (A : D) (X : D) + {P Q N : D} + (C : ((P ⊗ X) ⊗ X) ⊗ Q ≅ N) (w : (X ⊗ A) ⊗ X ⟶ X ⊗ X) + (v : P ⟶ P) (E : N ⟶ N) + (hE : C.hom ≫ E = (((v ▷ X) ▷ X) ▷ Q) ≫ C.hom) : + (((P ◁ w) ▷ Q) ≫ ((α_ P X X).inv ▷ Q ≫ C.hom)) ≫ E = + ((v ▷ ((X ⊗ A) ⊗ X)) ▷ Q) ≫ + (((P ◁ w) ▷ Q) ≫ ((α_ P X X).inv ▷ Q ≫ C.hom)) := by + have hinner : (P ◁ w) ≫ (α_ P X X).inv ≫ ((v ▷ X) ▷ X) = + (v ▷ ((X ⊗ A) ⊗ X)) ≫ (P ◁ w) ≫ (α_ P X X).inv := by + rw [← MonoidalCategory.associator_inv_naturality_left, + ← MonoidalCategory.whisker_exchange_assoc] + simp only [Category.assoc, hE] + rw [← MonoidalCategory.comp_whiskerRight_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc] + simp only [Category.assoc] + rw [hinner] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + +variable {A X} in +/-- **The disjoint case, braid above**: the adjacent braiding lies +inside the upper context of the relation slot. -/ +private theorem adjSwap_rel_above + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] {A : D} + [MonObj A] {X : D} [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (a j b₀ : ℕ) + (h : a + 2 + (j + 2 + b₀) = a + 2 + j + 2 + b₀) : + modPowLegM A X a (j + 2 + b₀) ≫ powCast X h ≫ + adjSwapMor X (a + 2 + j) b₀ ≫ + modPowπ A X (a + 2 + j + 2 + b₀) = + modPowLegN A X a (j + 2 + b₀) ≫ powCast X h ≫ + adjSwapMor X (a + 2 + j) b₀ ≫ + modPowπ A X (a + 2 + j + 2 + b₀) := by + have hcast : powCast X h ≫ adjSwapMor X (a + 2 + j) b₀ = + permMor X (a + 2 + (j + 2 + b₀)) + (Equiv.swap ⟨a + 2 + j, by omega⟩ ⟨a + 2 + j + 1, by omega⟩) + ≫ powCast X h := by + rw [adjSwapMor_eq_permMor] + exact powCast_permMor_swap X h ⟨a + 2 + j, by omega⟩ + ⟨a + 2 + j + 1, by omega⟩ + have hE : (tensorPowConcat X (a + 2) (j + 2 + b₀)).hom ≫ + permMor X (a + 2 + (j + 2 + b₀)) + (Equiv.swap ⟨a + 2 + j, by omega⟩ ⟨a + 2 + j + 1, by omega⟩) = + (tensorPow D X (a + 2) ◁ adjSwapMor X j b₀) ≫ + (tensorPowConcat X (a + 2) (j + 2 + b₀)).hom := by + have hsw : (Equiv.swap (⟨a + 2 + j, by omega⟩ : + Fin (a + 2 + (j + 2 + b₀))) ⟨a + 2 + j + 1, by omega⟩) = + blockEmbed (1 : Equiv.Perm (Fin (a + 2))) + (Equiv.swap ⟨j, by omega⟩ ⟨j + 1, by omega⟩) := by + rw [blockEmbed_one_swap] + rfl + rw [hsw, adjSwapMor_eq_permMor, tensorPowConcat_permMor_snd] + have hM : ∀ w : (X ⊗ A) ⊗ X ⟶ X ⊗ X, + (((tensorPow D X a ◁ w) ▷ tensorPow D X (j + 2 + b₀)) ≫ + modPowGlue X a (j + 2 + b₀)) ≫ powCast X h ≫ + adjSwapMor X (a + 2 + j) b₀ ≫ + modPowπ A X (a + 2 + j + 2 + b₀) = + ((tensorPow D X a ⊗ ((X ⊗ A) ⊗ X)) ◁ adjSwapMor X j b₀) ≫ + (((tensorPow D X a ◁ w) ▷ tensorPow D X (j + 2 + b₀)) ≫ + modPowGlue X a (j + 2 + b₀)) ≫ powCast X h ≫ + modPowπ A X (a + 2 + j + 2 + b₀) := by + intro w + conv_lhs => rw [reassoc_of% hcast] + rw [modPowGlue] + simp only [Category.assoc] + repeat' erw [Category.assoc] + erw [reassoc_of% (ctx_above_aux A X + (tensorPowConcat X (a + 2) (j + 2 + b₀)) w + (adjSwapMor X j b₀) _ hE)] + rw [modPowLegM, modPowLegN, hM (winLegM A X), hM (winLegN A X), + ← modPowLegM, ← modPowLegN, modPow_rel A X a (j + 2 + b₀) h] + +variable {A X} in +/-- **The disjoint case, braid below**: the adjacent braiding lies +inside the lower context of the relation slot. -/ +private theorem adjSwap_rel_below + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] {A : D} + [MonObj A] {X : D} [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (a₀ j b : ℕ) + (h : a₀ + 2 + j + 2 + b = a₀ + 2 + (j + 2 + b)) : + modPowLegM A X (a₀ + 2 + j) b ≫ powCast X h ≫ + adjSwapMor X a₀ (j + 2 + b) ≫ + modPowπ A X (a₀ + 2 + (j + 2 + b)) = + modPowLegN A X (a₀ + 2 + j) b ≫ powCast X h ≫ + adjSwapMor X a₀ (j + 2 + b) ≫ + modPowπ A X (a₀ + 2 + (j + 2 + b)) := by + have hcast : powCast X h ≫ adjSwapMor X a₀ (j + 2 + b) = + permMor X (a₀ + 2 + j + 2 + b) + (Equiv.swap ⟨a₀, by omega⟩ ⟨a₀ + 1, by omega⟩) + ≫ powCast X h := by + rw [adjSwapMor_eq_permMor] + exact powCast_permMor_swap X h ⟨a₀, by omega⟩ ⟨a₀ + 1, by omega⟩ + have hlow : permMor X (a₀ + 2 + j + 2) + (Equiv.swap ⟨a₀, by omega⟩ ⟨a₀ + 1, by omega⟩) = + (adjSwapMor X a₀ j ▷ X) ▷ X := by + have hsw : (Equiv.swap (⟨a₀, by omega⟩ : Fin (a₀ + 2 + j + 2)) + ⟨a₀ + 1, by omega⟩) = + extPerm (extPerm + (Equiv.swap (⟨a₀, by omega⟩ : Fin (a₀ + 2 + j)) + ⟨a₀ + 1, by omega⟩)) := by + rw [extPerm_swap, extPerm_swap] + rfl + rw [hsw, permMor_extPerm, permMor_extPerm, adjSwapMor_eq_permMor] + rfl + have hE : (tensorPowConcat X (a₀ + 2 + j + 2) b).hom ≫ + permMor X (a₀ + 2 + j + 2 + b) + (Equiv.swap ⟨a₀, by omega⟩ ⟨a₀ + 1, by omega⟩) = + (((adjSwapMor X a₀ j ▷ X) ▷ X) ▷ tensorPow D X b) ≫ + (tensorPowConcat X (a₀ + 2 + j + 2) b).hom := by + have hsw : (Equiv.swap (⟨a₀, by omega⟩ : Fin (a₀ + 2 + j + 2 + b)) + ⟨a₀ + 1, by omega⟩) = + blockEmbed + (Equiv.swap (⟨a₀, by omega⟩ : Fin (a₀ + 2 + j + 2)) + ⟨a₀ + 1, by omega⟩) (1 : Equiv.Perm (Fin b)) := by + rw [blockEmbed_swap_one] + rfl + rw [hsw, ← hlow, tensorPowConcat_permMor_fst] + rfl + have hM : ∀ w : (X ⊗ A) ⊗ X ⟶ X ⊗ X, + (((tensorPow D X (a₀ + 2 + j) ◁ w) ▷ tensorPow D X b) ≫ + modPowGlue X (a₀ + 2 + j) b) ≫ powCast X h ≫ + adjSwapMor X a₀ (j + 2 + b) ≫ + modPowπ A X (a₀ + 2 + (j + 2 + b)) = + ((adjSwapMor X a₀ j ▷ ((X ⊗ A) ⊗ X)) ▷ tensorPow D X b) ≫ + (((tensorPow D X (a₀ + 2 + j) ◁ w) ▷ tensorPow D X b) ≫ + modPowGlue X (a₀ + 2 + j) b) ≫ powCast X h ≫ + modPowπ A X (a₀ + 2 + (j + 2 + b)) := by + intro w + conv_lhs => rw [reassoc_of% hcast] + rw [modPowGlue] + simp only [Category.assoc] + repeat' erw [Category.assoc] + erw [reassoc_of% (ctx_below_aux A X + (tensorPowConcat X (a₀ + 2 + j + 2) b) w + (adjSwapMor X a₀ j) _ hE)] + rw [modPowLegM, modPowLegN, hM (winLegM A X), hM (winLegN A X), + ← modPowLegM, ← modPowLegN, modPow_rel A X (a₀ + 2 + j) b h] + +/-! ### The three-slot window + +The two overlapping cases — the braided pair sharing one module +factor with the relation slot — are compared inside a window of +three module factors. The window morphisms below are stated on +`((X ⊗ A) ⊗ X) ⊗ X` and `X ⊗ ((X ⊗ A) ⊗ X)`, with the monoid +carried along; their identities against the slot legs are the local +content of the two cases. +-/ + +/-- The braiding of the two upper factors of the resolved window. -/ +noncomputable def winHigh + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) : + (X ⊗ X) ⊗ X ⟶ (X ⊗ X) ⊗ X := + (α_ X X X).hom ≫ (X ◁ (β_ X X).hom) ≫ (α_ X X X).inv + +/-- The braiding of the two lower factors of the resolved window. -/ +noncomputable def winLow + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) : + (X ⊗ X) ⊗ X ⟶ (X ⊗ X) ⊗ X := + (β_ X X).hom ▷ X + +/-- Exchange of the two pure module factors of a lower-relation +window, carrying nothing else along. -/ +noncomputable def winTSwap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + (X : D) : ((X ⊗ A) ⊗ X) ⊗ X ⟶ ((X ⊗ A) ⊗ X) ⊗ X := + (α_ (X ⊗ A) X X).hom ≫ ((X ⊗ A) ◁ (β_ X X).hom) ≫ + (α_ (X ⊗ A) X X).inv + +/-- From a lower-relation window to an upper-relation window: the +top module factor moves down past the flanked pair, by the braiding +against the pair. -/ +noncomputable def winShiftUp + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + (X : D) : ((X ⊗ A) ⊗ X) ⊗ X ⟶ X ⊗ ((X ⊗ A) ⊗ X) := + ((α_ X A X).hom ▷ X) ≫ (α_ X (A ⊗ X) X).hom ≫ + (X ◁ (β_ (A ⊗ X) X).hom) ≫ (X ◁ (α_ X A X).inv) + +/-- From an upper-relation window to a lower-relation window: the +bottom module factor moves up past the flanked pair. -/ +noncomputable def winShiftDown + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + (X : D) : X ⊗ ((X ⊗ A) ⊗ X) ⟶ ((X ⊗ A) ⊗ X) ⊗ X := + (α_ X (X ⊗ A) X).inv ≫ ((β_ X (X ⊗ A)).hom ▷ X) + +/-- Exchange of the two lower module factors of an upper-relation +window, across the monoid. -/ +noncomputable def winNSwap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + (X : D) : X ⊗ ((X ⊗ A) ⊗ X) ⟶ X ⊗ ((X ⊗ A) ⊗ X) := + (α_ X (X ⊗ A) X).inv ≫ + (((α_ X X A).inv ≫ ((β_ X X).hom ▷ A) ≫ (α_ X X A).hom) ▷ X) ≫ + (α_ X (X ⊗ A) X).hom + +/-- **Lower window, first leg**: the first leg passes the upper +braiding, exchanging the two untouched module factors. -/ +private theorem winLegM_winHigh + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + (X : D) + (u : X ⊗ A ⟶ X) : + ((u ▷ X) ▷ X) ≫ winHigh X = winTSwap A X ≫ ((u ▷ X) ▷ X) := by + rw [winHigh, winTSwap, ← Category.assoc, + MonoidalCategory.associator_naturality_left] + simp only [Category.assoc] + rw [← MonoidalCategory.whisker_exchange_assoc, + MonoidalCategory.associator_inv_naturality_left] + +/-- The braiding against a pair, unwound at the swapped slot: the +hexagon against the symmetry. -/ +private theorem braiding_pair_unwind + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + (X : D) : + (β_ (A ⊗ X) X).hom ≫ (α_ X A X).inv ≫ ((β_ X A).hom ▷ X) = + (α_ A X X).hom ≫ (A ◁ (β_ X X).hom) ≫ (α_ A X X).inv := by + rw [BraidedCategory.braiding_tensor_left_hom] + simp only [Category.assoc, Iso.hom_inv_id_assoc] + rw [← MonoidalCategory.comp_whiskerRight, + SymmetricCategory.symmetry, MonoidalCategory.id_whiskerRight, + Category.comp_id] + +/-- Conjugating an endomorphism of the two upper factors from the +lower-window bracketing to the deep bracketing. -/ +private theorem shift_conj_aux + [Category.{v} D] [MonoidalCategory D] (A : D) (X : D) + (g : X ⊗ X ⟶ X ⊗ X) : + (α_ (X ⊗ A) X X).hom ≫ ((X ⊗ A) ◁ g) ≫ (α_ (X ⊗ A) X X).inv ≫ + ((α_ X A X).hom ▷ X) = + ((α_ X A X).hom ▷ X) ≫ (α_ X (A ⊗ X) X).hom ≫ + (X ◁ (α_ A X X).hom) ≫ (X ◁ (A ◁ g)) ≫ + (X ◁ (α_ A X X).inv) ≫ (α_ X (A ⊗ X) X).inv := by + have hg : (X ⊗ A) ◁ g = (α_ X A (X ⊗ X)).hom ≫ (X ◁ (A ◁ g)) ≫ + (α_ X A (X ⊗ X)).inv := by + rw [← MonoidalCategory.associator_naturality_right_assoc, + Iso.hom_inv_id, Category.comp_id] + have hpre : (α_ (X ⊗ A) X X).hom ≫ (α_ X A (X ⊗ X)).hom = + ((α_ X A X).hom ▷ X) ≫ (α_ X (A ⊗ X) X).hom ≫ + (X ◁ (α_ A X X).hom) := by + monoidal + have hpost : (α_ X A (X ⊗ X)).inv ≫ (α_ (X ⊗ A) X X).inv ≫ + ((α_ X A X).hom ▷ X) = + (X ◁ (α_ A X X).inv) ≫ (α_ X (A ⊗ X) X).inv := by + monoidal + rw [hg] + simp only [Category.assoc] + rw [reassoc_of% hpre, hpost] + +/-- **Lower window, exchanged second leg**: the exchange followed by +the second leg is the shift followed by the upper first leg. -/ +private theorem winTSwap_winLegN + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] : + winTSwap A X ≫ (winLegN A X ▷ X) = + winShiftUp A X ≫ (X ◁ winLegM A X) ≫ (α_ X X X).inv := by + conv_lhs => rw [winLegN, MonoidalCategory.comp_whiskerRight, + winTSwap] + conv_rhs => rw [winLegM, winShiftUp, actRight, + MonoidalCategory.comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rw [MonoidalCategory.associator_inv_naturality_middle, + ← MonoidalCategory.whiskerLeft_comp_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc] + simp only [Category.assoc] + rw [braiding_pair_unwind A X] + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [← reassoc_of% (shift_conj_aux A X (β_ X X).hom)] + +/-- **Lower window, second leg**: the second leg passes the upper +braiding through the shifted window's second leg. -/ +private theorem winShiftUp_winLegN + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] : + winShiftUp A X ≫ (X ◁ winLegN A X) ≫ (α_ X X X).inv = + (winLegN A X ▷ X) ≫ winHigh X := by + have hnat : ((X ◁ actLeft A X) ▷ X) ≫ (α_ X X X).hom ≫ + (X ◁ (β_ X X).hom) = + (α_ X (A ⊗ X) X).hom ≫ (X ◁ (β_ (A ⊗ X) X).hom) ≫ + (X ◁ (X ◁ actLeft A X)) := by + rw [MonoidalCategory.associator_naturality_middle_assoc, + ← MonoidalCategory.whiskerLeft_comp, + BraidedCategory.braiding_naturality_left, + MonoidalCategory.whiskerLeft_comp] + conv_rhs => rw [winLegN, winHigh, + MonoidalCategory.comp_whiskerRight] + have hcancel : ∀ {W : D} (f : X ⊗ (X ⊗ (A ⊗ X)) ⟶ W), + X ◁ (α_ X A X).inv ≫ X ◁ (α_ X A X).hom ≫ f = f := by + intro W f + rw [← Category.assoc, ← MonoidalCategory.whiskerLeft_comp, + Iso.inv_hom_id, MonoidalCategory.whiskerLeft_id, + Category.id_comp] + conv_lhs => rw [winShiftUp, winLegN, + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rw [reassoc_of% hnat, hcancel] + +/-- **Upper window, first leg**: the shift followed by the lower +first leg is the upper first leg followed by the lower braiding. -/ +private theorem winShiftDown_winLegM + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] : + winShiftDown A X ≫ (winLegM A X ▷ X) = + ((X ◁ winLegM A X) ≫ (α_ X X X).inv) ≫ winLow X := by + conv_lhs => rw [winShiftDown, winLegM, Category.assoc, + ← MonoidalCategory.comp_whiskerRight, + ← BraidedCategory.braiding_naturality_right, + MonoidalCategory.comp_whiskerRight] + conv_rhs => rw [winLegM, winLow, Category.assoc, + MonoidalCategory.associator_inv_naturality_middle_assoc] + +/-- **Upper window, exchanged first leg**: the exchange followed by +the first leg is the shift followed by the lower second leg. -/ +private theorem winNSwap_winLegM + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] : + winNSwap A X ≫ (X ◁ winLegM A X) ≫ (α_ X X X).inv = + winShiftDown A X ≫ (winLegN A X ▷ X) := by + have hmid : (α_ X (X ⊗ A) X).hom ≫ (X ◁ ((β_ X A).hom ▷ X)) ≫ + (α_ X (A ⊗ X) X).inv = (X ◁ (β_ X A).hom) ▷ X := by + rw [← MonoidalCategory.associator_naturality_middle_assoc, + Iso.hom_inv_id, Category.comp_id] + have hPu : winNSwap A X ≫ (X ◁ ((β_ X A).hom ▷ X)) ≫ + (α_ X (A ⊗ X) X).inv = + (α_ X (X ⊗ A) X).inv ≫ ((β_ X (X ⊗ A)).hom ▷ X) ≫ + ((α_ X A X).hom ▷ X) := by + rw [winNSwap, + show (β_ X (X ⊗ A)).hom = (α_ X X A).inv ≫ + ((β_ X X).hom ▷ A) ≫ (α_ X X A).hom ≫ + (X ◁ (β_ X A).hom) ≫ (α_ X A X).inv from + BraidedCategory.braiding_tensor_right_hom X X A] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [hmid, + show (α_ X A X).inv ▷ X ≫ (α_ X A X).hom ▷ X = + 𝟙 ((X ⊗ (A ⊗ X)) ⊗ X) from by + rw [← MonoidalCategory.comp_whiskerRight, Iso.inv_hom_id, + MonoidalCategory.id_whiskerRight], + Category.comp_id] + conv_lhs => rw [winLegM, actRight, + MonoidalCategory.comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + MonoidalCategory.associator_inv_naturality_middle] + conv_rhs => rw [winShiftDown, winLegN, + MonoidalCategory.comp_whiskerRight] + rw [reassoc_of% hPu] + simp only [Category.assoc] + +/-- **Upper window, second leg**: the exchange followed by the +second leg is the second leg followed by the lower braiding. -/ +private theorem winNSwap_winLegN + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] : + winNSwap A X ≫ (X ◁ winLegN A X) ≫ (α_ X X X).inv = + ((X ◁ winLegN A X) ≫ (α_ X X X).inv) ≫ winLow X := by + have htail : ((α_ X X A).hom ▷ X) ≫ (α_ X (X ⊗ A) X).hom ≫ + (X ◁ (α_ X A X).hom) ≫ (α_ X X (A ⊗ X)).inv = + (α_ (X ⊗ X) A X).hom := by + monoidal + have hpre : (α_ X (X ⊗ A) X).inv ≫ ((α_ X X A).inv ▷ X) ≫ + (α_ (X ⊗ X) A X).hom = + (X ◁ (α_ X A X).hom) ≫ (α_ X X (A ⊗ X)).inv := by + monoidal + have hkey : winNSwap A X ≫ (X ◁ (α_ X A X).hom) ≫ + (α_ X X (A ⊗ X)).inv = + (X ◁ (α_ X A X).hom) ≫ (α_ X X (A ⊗ X)).inv ≫ + ((β_ X X).hom ▷ (A ⊗ X)) := by + rw [winNSwap] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [htail, MonoidalCategory.associator_naturality_left, + reassoc_of% hpre] + conv_lhs => rw [winLegN, MonoidalCategory.whiskerLeft_comp, + Category.assoc, MonoidalCategory.associator_inv_naturality_right] + conv_rhs => rw [winLegN, winLow, + MonoidalCategory.whiskerLeft_comp, Category.assoc, + Category.assoc, + MonoidalCategory.associator_inv_naturality_right_assoc, + MonoidalCategory.whisker_exchange] + rw [reassoc_of% hkey] + +/-! ### The three-slot frame + +Both overlap cases are compared in a frame `(Xᵃ ⊗ V) ⊗ Xᑫ` around a +three-slot window `V`, glued into the ambient power through the +assembled window and the concatenation. +-/ + +/-- Assemble a resolved three-slot window onto the power below. -/ +noncomputable def winAssemble [Category.{v} D] [MonoidalCategory D] (X : D) + (a : ℕ) : + tensorPow D X a ⊗ ((X ⊗ X) ⊗ X) ⟶ tensorPow D X (a + 3) := + (α_ (tensorPow D X a) (X ⊗ X) X).inv ≫ + ((α_ (tensorPow D X a) X X).inv ▷ X) + +/-- The framed window morphism: act inside the window, assemble, +concatenate, and transport. -/ +noncomputable def winFrame [Category.{v} D] [MonoidalCategory D] (X : D) + (a q : ℕ) {n : ℕ} (h : a + 3 + q = n) + {V : D} (u : V ⟶ (X ⊗ X) ⊗ X) : + (tensorPow D X a ⊗ V) ⊗ tensorPow D X q ⟶ tensorPow D X n := + ((tensorPow D X a ◁ u) ▷ tensorPow D X q) ≫ + (winAssemble X a ▷ tensorPow D X q) ≫ + (tensorPowConcat X (a + 3) q).hom ≫ powCast X h + +/-- Precomposition inside the frame. -/ +theorem winFrame_pre [Category.{v} D] [MonoidalCategory D] (X : D) + (a q : ℕ) {n : ℕ} (h : a + 3 + q = n) + {V V' : D} (m : V' ⟶ V) (u : V ⟶ (X ⊗ X) ⊗ X) : + winFrame X a q h (m ≫ u) = + ((tensorPow D X a ◁ m) ▷ tensorPow D X q) ≫ + winFrame X a q h u := by + rw [winFrame, winFrame, MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.comp_whiskerRight, Category.assoc] + +/-- The lower-relation mid object entering the frame. -/ +noncomputable def winFromLower + [Category.{v} D] [MonoidalCategory D] (A : D) (X : D) + (a q : ℕ) : + modPowMid A X a (q + 1) ≅ + (tensorPow D X a ⊗ (((X ⊗ A) ⊗ X) ⊗ X)) ⊗ tensorPow D X q := + whiskerLeftIso (tensorPow D X a ⊗ ((X ⊗ A) ⊗ X)) (powPeel X q) ≪≫ + (α_ (tensorPow D X a ⊗ ((X ⊗ A) ⊗ X)) X (tensorPow D X q)).symm ≪≫ + whiskerRightIso (α_ (tensorPow D X a) ((X ⊗ A) ⊗ X) X) + (tensorPow D X q) + +/-- The upper-relation mid object entering the frame. -/ +noncomputable def winFromUpper + [Category.{v} D] [MonoidalCategory D] (A : D) (X : D) + (a q : ℕ) : + modPowMid A X (a + 1) q ≅ + (tensorPow D X a ⊗ (X ⊗ ((X ⊗ A) ⊗ X))) ⊗ tensorPow D X q := + whiskerRightIso (α_ (tensorPow D X a) X ((X ⊗ A) ⊗ X)) + (tensorPow D X q) + +/-- The upper legs enter the frame; at general objects. -/ +private theorem frame_upper_aux [Category.{v} D] [MonoidalCategory D] (X : D) + {P Q W N : D} (w : W ⟶ X ⊗ X) + (C : (((P ⊗ X) ⊗ X) ⊗ X) ⊗ Q ⟶ N) : + (((P ⊗ X) ◁ w) ▷ Q) ≫ ((α_ (P ⊗ X) X X).inv ▷ Q) ≫ C = + ((α_ P X W).hom ▷ Q) ≫ + ((P ◁ ((X ◁ w) ≫ (α_ X X X).inv)) ▷ Q) ≫ + (((α_ P (X ⊗ X) X).inv ≫ ((α_ P X X).inv ▷ X)) ▷ Q) ≫ C := by + have hw : (P ⊗ X) ◁ w = + (α_ P X W).hom ≫ (P ◁ (X ◁ w)) ≫ (α_ P X (X ⊗ X)).inv := by + rw [← MonoidalCategory.associator_naturality_right_assoc, + Iso.hom_inv_id, Category.comp_id] + have hco : (α_ P X (X ⊗ X)).inv ≫ (α_ (P ⊗ X) X X).inv = + (P ◁ (α_ X X X).inv) ≫ + ((α_ P (X ⊗ X) X).inv ≫ ((α_ P X X).inv ▷ X)) := by + monoidal + have hpre : ((P ⊗ X) ◁ w) ≫ (α_ (P ⊗ X) X X).inv = + (α_ P X W).hom ≫ (P ◁ ((X ◁ w) ≫ (α_ X X X).inv)) ≫ + ((α_ P (X ⊗ X) X).inv ≫ ((α_ P X X).inv ▷ X)) := by + rw [hw] + simp only [Category.assoc] + rw [hco, MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rw [← MonoidalCategory.comp_whiskerRight_assoc, hpre, + MonoidalCategory.comp_whiskerRight, + MonoidalCategory.comp_whiskerRight] + simp only [Category.assoc] + +/-- The upper legs enter the frame. -/ +private theorem legUpper_frame + [Category.{v} D] [MonoidalCategory D] (A : D) (X : D) + (a q : ℕ) {n : ℕ} + (h12 : a + 1 + 2 + q = n) (h3 : a + 3 + q = n) + (w : (X ⊗ A) ⊗ X ⟶ X ⊗ X) {W' : D} + (k : tensorPow D X n ⟶ W') : + ((tensorPow D X (a + 1) ◁ w) ▷ tensorPow D X q) ≫ + modPowGlue X (a + 1) q ≫ powCast X h12 ≫ k = + (winFromUpper A X a q).hom ≫ + winFrame X a q h3 ((X ◁ w) ≫ (α_ X X X).inv) ≫ k := by + have h0 := frame_upper_aux X (P := tensorPow D X a) + (Q := tensorPow D X q) w + ((tensorPowConcat X (a + 1 + 2) q).hom ≫ powCast X h12 ≫ k) + simp only [modPowGlue, winFrame, winFromUpper, + whiskerRightIso_hom, Category.assoc] at h0 ⊢ + simpa only [tensorPow, tensorPowConcat, Iso.trans_inv, whiskerRightIso_inv, + Iso.symm_inv, winAssemble, Category.assoc] using! h0 + +/-- The lower legs enter the frame; at general objects, against a +peeled upper context. -/ +private theorem frame_lower_aux [Category.{v} D] [MonoidalCategory D] (X : D) + {P Q R W N : D} (w : W ⟶ X ⊗ X) + (e : R ⟶ X ⊗ Q) (C₁ : ((P ⊗ X) ⊗ X) ⊗ R ⟶ N) + (C₃ : (((P ⊗ X) ⊗ X) ⊗ X) ⊗ Q ⟶ N) + (hC : C₁ = (((P ⊗ X) ⊗ X) ◁ e) ≫ + (α_ ((P ⊗ X) ⊗ X) X Q).inv ≫ C₃) : + ((P ◁ w) ▷ R) ≫ ((α_ P X X).inv ▷ R) ≫ C₁ = + (((P ⊗ W) ◁ e) ≫ ((α_ (P ⊗ W) X Q).inv ≫ + ((α_ P W X).hom ▷ Q))) ≫ + ((P ◁ (w ▷ X)) ▷ Q) ≫ + (((α_ P (X ⊗ X) X).inv ≫ ((α_ P X X).inv ▷ X)) ▷ Q) ≫ C₃ := by + subst hC + have hmid : (α_ P W X).hom ≫ (P ◁ (w ▷ X)) ≫ + (α_ P (X ⊗ X) X).inv ≫ ((α_ P X X).inv ▷ X) = + ((P ◁ w) ▷ X) ≫ ((α_ P X X).inv ▷ X) := by + rw [← MonoidalCategory.associator_naturality_middle_assoc, + Iso.hom_inv_id_assoc] + conv_lhs => rw [← MonoidalCategory.whisker_exchange_assoc, + ← MonoidalCategory.whisker_exchange_assoc] + conv_rhs => simp only [Category.assoc] + conv_rhs => rw [← MonoidalCategory.comp_whiskerRight_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc] + conv_rhs => simp only [Category.assoc] + conv_rhs => rw [hmid] + conv_rhs => simp only [MonoidalCategory.comp_whiskerRight, + Category.assoc] + conv_rhs => rw [← MonoidalCategory.associator_inv_naturality_left_assoc, + ← MonoidalCategory.associator_inv_naturality_left_assoc] + +/-- The shift instance of the lower-frame decomposition. -/ +private theorem legLower_shift [Category.{v} D] [MonoidalCategory D] (X : D) + (a q : ℕ) {n : ℕ} + (h12 : a + 2 + (q + 1) = n) (h3 : a + 3 + q = n) : + (tensorPowConcat X (a + 2) (q + 1)).hom ≫ powCast X h12 = + (((tensorPow D X a ⊗ X) ⊗ X) ◁ (powPeel X q).hom) ≫ + (α_ ((tensorPow D X a ⊗ X) ⊗ X) X (tensorPow D X q)).inv ≫ + (tensorPowConcat X (a + 3) q).hom ≫ powCast X h3 := by + rw [tensorPowConcat_peel X (a + 2) q] + simp only [Category.assoc, powCast_comp] + rfl + +/-- The lower legs enter the frame. -/ +private theorem legLower_frame + [Category.{v} D] [MonoidalCategory D] (A : D) (X : D) + (a q : ℕ) {n : ℕ} + (h12 : a + 2 + (q + 1) = n) (h3 : a + 3 + q = n) + (w : (X ⊗ A) ⊗ X ⟶ X ⊗ X) {W' : D} + (k : tensorPow D X n ⟶ W') : + ((tensorPow D X a ◁ w) ▷ tensorPow D X (q + 1)) ≫ + modPowGlue X a (q + 1) ≫ powCast X h12 ≫ k = + (winFromLower A X a q).hom ≫ + winFrame X a q h3 (w ▷ X) ≫ k := by + have hC : (tensorPowConcat X (a + 2) (q + 1)).hom ≫ + powCast X h12 ≫ k = + (((tensorPow D X a ⊗ X) ⊗ X) ◁ (powPeel X q).hom) ≫ + (α_ ((tensorPow D X a ⊗ X) ⊗ X) X (tensorPow D X q)).inv ≫ + ((tensorPowConcat X (a + 3) q).hom ≫ powCast X h3) ≫ k := by + rw [← Category.assoc, legLower_shift X a q h12 h3] + exact (Category.assoc _ _ _).trans (congrArg + (fun z => (((tensorPow D X a ⊗ X) ⊗ X) ◁ (powPeel X q).hom) ≫ z) + (Category.assoc _ _ _)) + have h0 := frame_lower_aux X w (powPeel X q).hom + ((tensorPowConcat X (a + 2) (q + 1)).hom ≫ powCast X h12 ≫ k) + (((tensorPowConcat X (a + 3) q).hom ≫ powCast X h3) ≫ k) hC + simp only [modPowGlue, winFrame, winFromLower, Iso.trans_hom, + whiskerLeftIso_hom, Iso.symm_hom, whiskerRightIso_hom, + Category.assoc] at h0 ⊢ + repeat' erw [Category.assoc] at h0 ⊢ + exact h0 + +/-- The upper-pair braiding conjugated through the frame; at +general objects. -/ +private theorem frame_swap_high_aux + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) + {P Q N V : D} + (u : V ⟶ (X ⊗ X) ⊗ X) + (Ca : (((P ⊗ X) ⊗ X) ⊗ X) ⊗ Q ⟶ N) + (Cb : (((P ⊗ X) ⊗ X) ⊗ X) ⊗ Q ≅ N) (hab : Ca = Cb.hom) : + (((P ◁ u) ▷ Q) ≫ + (((α_ P (X ⊗ X) X).inv ≫ ((α_ P X X).inv ▷ X)) ▷ Q) ≫ Ca) ≫ + (Cb.inv ≫ + (((α_ (P ⊗ X) X X).hom ≫ ((P ⊗ X) ◁ (β_ X X).hom) ≫ + (α_ (P ⊗ X) X X).inv) ▷ Q) ≫ Cb.hom) = + ((P ◁ (u ≫ winHigh X)) ▷ Q) ≫ + (((α_ P (X ⊗ X) X).inv ≫ ((α_ P X X).inv ▷ X)) ▷ Q) ≫ Ca := by + subst hab + have hcore : ((α_ P (X ⊗ X) X).inv ≫ ((α_ P X X).inv ▷ X)) ≫ + ((α_ (P ⊗ X) X X).hom ≫ ((P ⊗ X) ◁ (β_ X X).hom) ≫ + (α_ (P ⊗ X) X X).inv) = + (P ◁ winHigh X) ≫ + ((α_ P (X ⊗ X) X).inv ≫ ((α_ P X X).inv ▷ X)) := by + have hθ : (α_ P (X ⊗ X) X).inv ≫ ((α_ P X X).inv ▷ X) ≫ + (α_ (P ⊗ X) X X).hom = + (P ◁ (α_ X X X).hom) ≫ (α_ P X (X ⊗ X)).inv := by + monoidal + have hpent : (α_ P X (X ⊗ X)).inv ≫ (α_ (P ⊗ X) X X).inv = + (P ◁ (α_ X X X).inv) ≫ (α_ P (X ⊗ X) X).inv ≫ + ((α_ P X X).inv ▷ X) := by + monoidal + rw [winHigh] + simp only [Category.assoc, MonoidalCategory.whiskerLeft_comp] + rw [reassoc_of% hθ, + ← MonoidalCategory.associator_inv_naturality_right_assoc, + hpent] + simp only [Category.assoc, Iso.hom_inv_id_assoc] + rw [← MonoidalCategory.comp_whiskerRight_assoc + ((α_ P (X ⊗ X) X).inv ≫ ((α_ P X X).inv ▷ X)), + hcore, MonoidalCategory.comp_whiskerRight] + simp only [Category.assoc] + rw [← MonoidalCategory.comp_whiskerRight_assoc (P ◁ u), + ← MonoidalCategory.whiskerLeft_comp] + +/-- The upper-pair braiding through the frame. -/ +private theorem winFrame_adjSwap_high + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) + (a q : ℕ) + (h3 : a + 3 + q = a + 1 + 2 + q) {V : D} + (u : V ⟶ (X ⊗ X) ⊗ X) : + winFrame X a q h3 u ≫ adjSwapMor X (a + 1) q = + winFrame X a q h3 (u ≫ winHigh X) := by + have h0 := frame_swap_high_aux X (P := tensorPow D X a) u + ((tensorPowConcat X (a + 3) q).hom ≫ powCast X h3) + (tensorPowConcat X (a + 1 + 2) q) + (show (tensorPowConcat X (a + 3) q).hom ≫ powCast X h3 = + (tensorPowConcat X (a + 1 + 2) q).hom from + Category.comp_id _) + simp only [winFrame, winAssemble, adjSwapMor, swapTop, + Category.assoc] at h0 ⊢ + simpa only [tensorPow, tensorPowConcat, Iso.trans_inv, whiskerRightIso_inv, + Iso.symm_inv, winAssemble, Category.assoc] using! h0 + +/-- The lower-pair braiding conjugated through the frame; at +general objects, against a peeled upper context. -/ +private theorem frame_swap_low_aux + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) + {P Q R N V : D} + (u : V ⟶ (X ⊗ X) ⊗ X) (e : R ≅ X ⊗ Q) + (C₃ : (((P ⊗ X) ⊗ X) ⊗ X) ⊗ Q ⟶ N) + (Cb : ((P ⊗ X) ⊗ X) ⊗ R ≅ N) + (hCb : Cb.hom = (((P ⊗ X) ⊗ X) ◁ e.hom) ≫ + (α_ ((P ⊗ X) ⊗ X) X Q).inv ≫ C₃) : + (((P ◁ u) ▷ Q) ≫ + (((α_ P (X ⊗ X) X).inv ≫ ((α_ P X X).inv ▷ X)) ▷ Q) ≫ C₃) ≫ + (Cb.inv ≫ + (((α_ P X X).hom ≫ (P ◁ (β_ X X).hom) ≫ (α_ P X X).inv) ▷ R) + ≫ Cb.hom) = + ((P ◁ (u ≫ winLow X)) ▷ Q) ≫ + (((α_ P (X ⊗ X) X).inv ≫ ((α_ P X X).inv ▷ X)) ▷ Q) ≫ C₃ := by + have hC₃ : C₃ ≫ Cb.inv = + (α_ ((P ⊗ X) ⊗ X) X Q).hom ≫ (((P ⊗ X) ⊗ X) ◁ e.inv) := by + rw [Iso.comp_inv_eq, hCb] + simp only [Category.assoc] + rw [← MonoidalCategory.whiskerLeft_comp_assoc, Iso.inv_hom_id, + MonoidalCategory.whiskerLeft_id, Category.id_comp, + Iso.hom_inv_id_assoc] + have hcore : ((α_ P (X ⊗ X) X).inv ≫ ((α_ P X X).inv ▷ X)) ≫ + (((α_ P X X).hom ≫ (P ◁ (β_ X X).hom) ≫ (α_ P X X).inv) ▷ X) = + (P ◁ winLow X) ≫ + ((α_ P (X ⊗ X) X).inv ≫ ((α_ P X X).inv ▷ X)) := by + conv_rhs => rw [winLow] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [← MonoidalCategory.comp_whiskerRight_assoc ((α_ P X X).inv), + Iso.inv_hom_id, MonoidalCategory.id_whiskerRight, + Category.id_comp, + ← MonoidalCategory.associator_inv_naturality_middle_assoc] + simp only [Category.assoc] + rw [reassoc_of% hC₃, MonoidalCategory.whisker_exchange_assoc, hCb, + ← MonoidalCategory.whiskerLeft_comp_assoc, Iso.inv_hom_id, + MonoidalCategory.whiskerLeft_id, Category.id_comp, + ← MonoidalCategory.associator_naturality_left_assoc, + Iso.hom_inv_id_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc + ((α_ P (X ⊗ X) X).inv ≫ ((α_ P X X).inv ▷ X)), + hcore, MonoidalCategory.comp_whiskerRight] + simp only [Category.assoc] + rw [← MonoidalCategory.comp_whiskerRight_assoc (P ◁ u), + ← MonoidalCategory.whiskerLeft_comp] + +/-- The lower-pair braiding through the frame. -/ +private theorem winFrame_adjSwap_low + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) + (a q : ℕ) + (h3 : a + 3 + q = a + 2 + (q + 1)) {V : D} + (u : V ⟶ (X ⊗ X) ⊗ X) : + winFrame X a q h3 u ≫ adjSwapMor X a (q + 1) = + winFrame X a q h3 (u ≫ winLow X) := by + have hCb : (tensorPowConcat X (a + 2) (q + 1)).hom = + (((tensorPow D X a ⊗ X) ⊗ X) ◁ (powPeel X q).hom) ≫ + (α_ ((tensorPow D X a ⊗ X) ⊗ X) X (tensorPow D X q)).inv ≫ + ((tensorPowConcat X (a + 3) q).hom ≫ powCast X h3) := by + have h0 := legLower_shift X a q + (rfl : a + 2 + (q + 1) = a + 2 + (q + 1)) h3 + rwa [powCast_rfl, Category.comp_id] at h0 + have h0 := frame_swap_low_aux X (P := tensorPow D X a) u + (powPeel X q) + ((tensorPowConcat X (a + 3) q).hom ≫ powCast X h3) + (tensorPowConcat X (a + 2) (q + 1)) hCb + simp only [winFrame, winAssemble, adjSwapMor, swapTop, + Category.assoc] at h0 ⊢ + simp only [tensorPow, tensorPowConcat, Iso.trans_inv, + Iso.symm_inv, Category.assoc] at h0 ⊢ + repeat' erw [Category.assoc] at h0 + exact h0 + +variable {A X} in +/-- **The overlap case, braid above**: the braided pair shares its +lower factor with the upper module factor of the relation slot. -/ +private theorem adjSwap_rel_LU + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] {A : D} + [MonObj A] {X : D} [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (a q : ℕ) + (h : a + 2 + (q + 1) = a + 1 + 2 + q) : + modPowLegM A X a (q + 1) ≫ powCast X h ≫ + adjSwapMor X (a + 1) q ≫ modPowπ A X (a + 1 + 2 + q) = + modPowLegN A X a (q + 1) ≫ powCast X h ≫ + adjSwapMor X (a + 1) q ≫ modPowπ A X (a + 1 + 2 + q) := by + have h3 : a + 3 + q = a + 1 + 2 + q := by omega + have hbarL : winFrame X a q h3 (winLegM A X ▷ X) ≫ + modPowπ A X (a + 1 + 2 + q) = + winFrame X a q h3 (winLegN A X ▷ X) ≫ + modPowπ A X (a + 1 + 2 + q) := by + have hr := modPow_rel A X a (q + 1) h + rw [modPowLegM, modPowLegN, Category.assoc, Category.assoc, + legLower_frame A X a q h h3 (winLegM A X) (modPowπ A X _), + legLower_frame A X a q h h3 (winLegN A X) (modPowπ A X _)] + at hr + exact (cancel_epi (winFromLower A X a q).hom).mp hr + have hbarU : winFrame X a q h3 + ((X ◁ winLegM A X) ≫ (α_ X X X).inv) ≫ + modPowπ A X (a + 1 + 2 + q) = + winFrame X a q h3 ((X ◁ winLegN A X) ≫ (α_ X X X).inv) ≫ + modPowπ A X (a + 1 + 2 + q) := by + have hr := modPow_rel A X (a + 1) q + (rfl : a + 1 + 2 + q = a + 1 + 2 + q) + rw [modPowLegM, modPowLegN, Category.assoc, Category.assoc, + legUpper_frame A X a q rfl h3 (winLegM A X) (modPowπ A X _), + legUpper_frame A X a q rfl h3 (winLegN A X) (modPowπ A X _)] + at hr + exact (cancel_epi (winFromUpper A X a q).hom).mp hr + rw [modPowLegM, modPowLegN, Category.assoc, Category.assoc, + legLower_frame A X a q h h3 (winLegM A X) + (adjSwapMor X (a + 1) q ≫ modPowπ A X _), + legLower_frame A X a q h h3 (winLegN A X) + (adjSwapMor X (a + 1) q ≫ modPowπ A X _), + cancel_epi (winFromLower A X a q).hom, + reassoc_of% (winFrame_adjSwap_high X a q h3 (winLegM A X ▷ X)), + reassoc_of% (winFrame_adjSwap_high X a q h3 (winLegN A X ▷ X)), + show (winLegM A X ▷ X) ≫ winHigh X = + winTSwap A X ≫ (winLegM A X ▷ X) from + winLegM_winHigh A X (actRight A X), + winFrame_pre, Category.assoc, hbarL, ← Category.assoc, + ← winFrame_pre, winTSwap_winLegN A X, winFrame_pre, + Category.assoc, hbarU, ← Category.assoc, ← winFrame_pre, + winShiftUp_winLegN A X] + +variable {A X} in +/-- **The overlap case, braid below**: the braided pair shares its +upper factor with the lower module factor of the relation slot. -/ +private theorem adjSwap_rel_UL + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] {A : D} + [MonObj A] {X : D} [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (a q : ℕ) + (h : a + 1 + 2 + q = a + 2 + (q + 1)) : + modPowLegM A X (a + 1) q ≫ powCast X h ≫ + adjSwapMor X a (q + 1) ≫ modPowπ A X (a + 2 + (q + 1)) = + modPowLegN A X (a + 1) q ≫ powCast X h ≫ + adjSwapMor X a (q + 1) ≫ modPowπ A X (a + 2 + (q + 1)) := by + have h3 : a + 3 + q = a + 2 + (q + 1) := by omega + have hbarL : winFrame X a q h3 (winLegM A X ▷ X) ≫ + modPowπ A X (a + 2 + (q + 1)) = + winFrame X a q h3 (winLegN A X ▷ X) ≫ + modPowπ A X (a + 2 + (q + 1)) := by + have hr := modPow_rel A X a (q + 1) + (rfl : a + 2 + (q + 1) = a + 2 + (q + 1)) + rw [modPowLegM, modPowLegN, Category.assoc, Category.assoc, + legLower_frame A X a q rfl h3 (winLegM A X) (modPowπ A X _), + legLower_frame A X a q rfl h3 (winLegN A X) (modPowπ A X _)] + at hr + exact (cancel_epi (winFromLower A X a q).hom).mp hr + have hbarU : winFrame X a q h3 + ((X ◁ winLegM A X) ≫ (α_ X X X).inv) ≫ + modPowπ A X (a + 2 + (q + 1)) = + winFrame X a q h3 ((X ◁ winLegN A X) ≫ (α_ X X X).inv) ≫ + modPowπ A X (a + 2 + (q + 1)) := by + have hr := modPow_rel A X (a + 1) q h + rw [modPowLegM, modPowLegN, Category.assoc, Category.assoc, + legUpper_frame A X a q h h3 (winLegM A X) (modPowπ A X _), + legUpper_frame A X a q h h3 (winLegN A X) (modPowπ A X _)] + at hr + exact (cancel_epi (winFromUpper A X a q).hom).mp hr + have hu1 : (X ◁ winLegM A X) ≫ (α_ X X X).inv ≫ winLow X = + winShiftDown A X ≫ (winLegM A X ▷ X) := by + rw [winShiftDown_winLegM] + exact (Category.assoc _ _ _).symm + have hu2b : winNSwap A X ≫ (X ◁ winLegN A X) ≫ (α_ X X X).inv = + (X ◁ winLegN A X) ≫ (α_ X X X).inv ≫ winLow X := by + rw [winNSwap_winLegN] + exact Category.assoc _ _ _ + rw [modPowLegM, modPowLegN, Category.assoc, Category.assoc, + legUpper_frame A X a q h h3 (winLegM A X) + (adjSwapMor X a (q + 1) ≫ modPowπ A X _), + legUpper_frame A X a q h h3 (winLegN A X) + (adjSwapMor X a (q + 1) ≫ modPowπ A X _), + cancel_epi (winFromUpper A X a q).hom, + reassoc_of% (winFrame_adjSwap_low X a q h3 + ((X ◁ winLegM A X) ≫ (α_ X X X).inv)), + reassoc_of% (winFrame_adjSwap_low X a q h3 + ((X ◁ winLegN A X) ≫ (α_ X X X).inv)), + hu1, winFrame_pre, Category.assoc, hbarL, + ← Category.assoc, ← winFrame_pre, ← winNSwap_winLegM A X, + winFrame_pre, Category.assoc, hbarU, ← Category.assoc, + ← winFrame_pre, hu2b] + +variable {A X} in +/-- Descent transports along an equality of arities. -/ +theorem modPowDescends_cast + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] {A : D} + [MonObj A] {X : D} [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + {n₁ n₂ : ℕ} (h : n₁ = n₂) + {f₁ : tensorPow D X n₁ ⟶ tensorPow D X n₁} + {f₂ : tensorPow D X n₂ ⟶ tensorPow D X n₂} + (hf : powCast X h ≫ f₂ = f₁ ≫ powCast X h) + (hd : modPowDescends A X n₁ f₁) : + modPowDescends A X n₂ f₂ := by + subst h + rw [powCast_rfl, Category.id_comp, Category.comp_id] at hf + exact hf ▸ hd + +variable {A X} in +/-- **Descent of the adjacent braiding**: every slot relation passes +every adjacent braiding, by the same-slot, disjoint and overlap +cases. -/ +theorem modPowDescends_adjSwap + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] {A : D} + [MonObj A] {X : D} [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (a₀ b₀ : ℕ) : + modPowDescends A X (a₀ + 2 + b₀) (adjSwapMor X a₀ b₀) := by + intro a b hab + rcases Nat.lt_trichotomy a a₀ with hlt | rfl | hgt + · rcases Nat.lt_or_ge a₀ (a + 2) with h2 | h2 + · obtain rfl : a₀ = a + 1 := by omega + obtain rfl : b = b₀ + 1 := by omega + exact adjSwap_rel_LU a b₀ hab + · obtain ⟨j, rfl⟩ : ∃ j, a₀ = a + 2 + j := ⟨a₀ - a - 2, by omega⟩ + obtain rfl : b = j + 2 + b₀ := by omega + exact adjSwap_rel_above a j b₀ hab + · obtain rfl : b = b₀ := by omega + rw [powCast_irrel X hab rfl, powCast_rfl, Category.id_comp] + exact adjSwap_rel_same A X a b + · rcases Nat.lt_or_ge a (a₀ + 2) with h2 | h2 + · obtain rfl : a = a₀ + 1 := by omega + obtain rfl : b₀ = b + 1 := by omega + exact adjSwap_rel_UL a₀ b hab + · obtain ⟨j, rfl⟩ : ∃ j, a = a₀ + 2 + j := ⟨a - a₀ - 2, by omega⟩ + obtain rfl : b₀ = j + 2 + b := by omega + exact adjSwap_rel_below a₀ j b hab + +variable {A X} in +/-- **Descent of the permutation action**: every slot relation +passes the action of every permutation — on the adjacent +transpositions by the case analysis, and in general by generation +and multiplicativity, exactly as the ambient action itself was +assembled. -/ +theorem modPowDescends_permMor + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] {A : D} + [MonObj A] {X : D} [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] : + ∀ (n : ℕ) (σ : Equiv.Perm (Fin n)), + modPowDescends A X n (permMor X n σ) + | 0, _ => fun _ _ hab => absurd hab (by omega) + | 1, _ => fun _ _ hab => absurd hab (by omega) + | m + 2, σ => by + have hgen : ∀ i : Fin (m + 1), + modPowDescends A X (m + 2) + (permMor X (m + 2) (Equiv.swap i.castSucc i.succ)) := by + intro i + have he : i.val + 2 + (m - i.val) = m + 2 := by + have := i.isLt; omega + have hmor : powCast X he ≫ + permMor X (m + 2) (Equiv.swap i.castSucc i.succ) = + adjSwapMor X i.val (m - i.val) ≫ powCast X he := by + rw [adjSwapMor_eq_permMor] + exact powCast_permMor_swap X he ⟨i.val, by omega⟩ + ⟨i.val + 1, by omega⟩ + exact modPowDescends_cast he hmor + (modPowDescends_adjSwap i.val (m - i.val)) + have hone : modPowDescends A X (m + 2) (permMor X (m + 2) 1) := by + intro a b hab + rw [permMor_one] + simpa using modPow_rel A X a b hab + have key : ∀ τ : Equiv.Perm (Fin (m + 2)), + τ ∈ Submonoid.closure (Set.range fun i : Fin (m + 1) => + Equiv.swap i.castSucc i.succ) → + modPowDescends A X (m + 2) (permMor X (m + 2) τ) := by + intro τ hτ + induction hτ using Submonoid.closure_induction_left with + | one => exact hone + | mul_left g hg τ' hτ' ih => + obtain ⟨i, rfl⟩ := hg + intro a b hab + rw [permMor_mul] + have hfac : permMor X (m + 2) + (Equiv.swap i.castSucc i.succ) ≫ modPowπ A X (m + 2) = + modPowπ A X (m + 2) ≫ modPowDesc A X + (permMor X (m + 2) (Equiv.swap i.castSucc i.succ) ≫ + modPowπ A X (m + 2)) (hgen i) := + (modPowπ_desc A X _ _).symm + rw [Category.assoc, hfac, reassoc_of% (ih a b hab)] + exact key σ (by + rw [Equiv.Perm.mclosure_swap_castSucc_succ]; trivial) + +variable {A X} in +/-- **The permutation action descends to the module power.** -/ +noncomputable def modPowPerm + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] {A : D} + [MonObj A] {X : D} [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (n : ℕ) (σ : Equiv.Perm (Fin n)) : + modPow A X n ⟶ modPow A X n := + modPowDesc A X (permMor X n σ ≫ modPowπ A X n) + (modPowDescends_permMor n σ) + +variable {A X} in +/-- Defining square of the descended action. -/ +@[reassoc (attr := simp)] +theorem modPowπ_perm + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] {A : D} + [MonObj A] {X : D} [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (n : ℕ) (σ : Equiv.Perm (Fin n)) : + modPowπ A X n ≫ modPowPerm (A := A) (X := X) n σ = + permMor X n σ ≫ modPowπ A X n := + modPowπ_desc A X _ _ + +variable {A X} in +/-- The identity acts as the identity on the module power. -/ +theorem modPowPerm_one + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] {A : D} + [MonObj A] {X : D} [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (n : ℕ) : + modPowPerm (A := A) (X := X) n 1 = 𝟙 (modPow A X n) := by + apply modPow_hom_ext + rw [modPowπ_perm, permMor_one, Category.id_comp, Category.comp_id] + +variable {A X} in +/-- The descended action is functorial. -/ +theorem modPowPerm_mul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] {A : D} + [MonObj A] {X : D} [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (n : ℕ) (σ τ : Equiv.Perm (Fin n)) : + modPowPerm (A := A) (X := X) n (σ * τ) = + modPowPerm (A := A) (X := X) n τ ≫ + modPowPerm (A := A) (X := X) n σ := by + apply modPow_hom_ext + rw [modPowπ_perm, permMor_mul, modPowπ_perm_assoc, Category.assoc, + modPowπ_perm] + +/-- **The symmetric group acting on the module power**, as a monoid +homomorphism. -/ +@[simps] +noncomputable def modPowPermHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (n : ℕ) : + Equiv.Perm (Fin n) →* End (modPow A X n) where + toFun := modPowPerm n + map_one' := modPowPerm_one n + map_mul' := modPowPerm_mul n + +end Descent + +/-! ## The symmetriser + +The trivial-character central idempotent of the group algebra +`ℂ[Sₙ]` — the `charIdempotent 1 (fun _ => 1)` of the Schur +interface, written directly. +-/ + +section Symmetriser + +/-- **The symmetriser** `(1/n!) • ∑ σ, σ` of the symmetric-group +algebra. -/ +noncomputable def symmetriser (n : ℕ) : SymGroupAlgebra n := + ((n.factorial : ℂ))⁻¹ • + ∑ σ : Equiv.Perm (Fin n), MonoidAlgebra.single σ 1 + +/-- The symmetriser absorbs every group element on the right. -/ +@[simp] +theorem symmetriser_mul_single (n : ℕ) (τ : Equiv.Perm (Fin n)) : + symmetriser n * MonoidAlgebra.single τ (1 : ℂ) = symmetriser n := by + unfold symmetriser + rw [smul_mul_assoc, Finset.sum_mul] + congr 1 + refine Fintype.sum_equiv (Equiv.mulRight τ) _ _ fun σ => ?_ + simp [MonoidAlgebra.single_mul_single] + +/-- The symmetriser absorbs every group element on the left. -/ +@[simp] +theorem single_mul_symmetriser (n : ℕ) (τ : Equiv.Perm (Fin n)) : + MonoidAlgebra.single τ (1 : ℂ) * symmetriser n = symmetriser n := by + unfold symmetriser + rw [mul_smul_comm, Finset.mul_sum] + congr 1 + refine Fintype.sum_equiv (Equiv.mulLeft τ) _ _ fun σ => ?_ + simp [MonoidAlgebra.single_mul_single] + +/-- **The symmetriser is idempotent.** -/ +theorem symmetriser_idem (n : ℕ) : + symmetriser n * symmetriser n = symmetriser n := by + nth_rewrite 2 [symmetriser] + rw [mul_smul_comm, Finset.mul_sum] + simp only [symmetriser_mul_single, Finset.sum_const, + Finset.card_univ] + rw [Fintype.card_perm, Fintype.card_fin, + ← Nat.cast_smul_eq_nsmul ℂ, smul_smul, inv_mul_cancel₀ (by + exact_mod_cast n.factorial_ne_zero), one_smul] + +end Symmetriser + +/-! ## The group algebra on the module power, and the symmetric +power -/ + +section SymPow + +/-- **The symmetric-group algebra acting on the module power**, the +`ℂ`-linear extension of the descended action. -/ +noncomputable def modPowAlg + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) : + SymGroupAlgebra n →ₐ[ℂ] End (modPow A X n) := + MonoidAlgebra.lift ℂ (End (modPow A X n)) (Equiv.Perm (Fin n)) + (modPowPermHom A X n) + +/-- The algebra map sends a group element to its action. -/ +@[simp] +theorem modPowAlg_single + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) (σ : Equiv.Perm (Fin n)) : + modPowAlg A X n (MonoidAlgebra.single σ (1 : ℂ)) = + modPowPerm (A := A) (X := X) n σ := by + rw [modPowAlg, MonoidAlgebra.lift_single, one_smul] + rfl + +/-- The symmetriser acting on the module power. -/ +noncomputable def symPowIdem + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) : modPow A X n ⟶ modPow A X n := + modPowAlg A X n (symmetriser n) + +/-- The symmetriser's action is idempotent. -/ +theorem symPowIdem_idem + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) : + symPowIdem A X n ≫ symPowIdem A X n = symPowIdem A X n := by + have h := congrArg (modPowAlg A X n) (symmetriser_idem n) + rw [map_mul] at h + exact h + +/-- **The symmetric power**: the coinvariants of the symmetriser's +action — the coequalizer of the action against the identity. The +idempotency splits it off as a direct summand of the module power, +with section `symPowσ`; this presentation is chosen because the +consumers of the Key Lemma build morphisms out of the symmetric +power by descent along `symPowπ` and morphisms into it through the +section. -/ +noncomputable def symPow + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) : D := + coequalizer (symPowIdem A X n) (𝟙 (modPow A X n)) + +/-- The projection onto the symmetric power. -/ +noncomputable def symPowπ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) : modPow A X n ⟶ symPow A X n := + coequalizer.π _ _ + +instance [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) : Epi (symPowπ A X n) := + inferInstanceAs (Epi (coequalizer.π _ _)) + +/-- The symmetriser is absorbed by the projection. -/ +@[reassoc (attr := simp)] +theorem symPowIdem_π + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) : + symPowIdem A X n ≫ symPowπ A X n = symPowπ A X n := by + have h := coequalizer.condition (symPowIdem A X n) + (𝟙 (modPow A X n)) + rwa [Category.id_comp] at h + +/-- The section of the symmetric power, from idempotency. -/ +noncomputable def symPowσ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) : symPow A X n ⟶ modPow A X n := + coequalizer.desc (symPowIdem A X n) + (by rw [Category.id_comp, symPowIdem_idem]) + +/-- The section realises the symmetriser as projection followed by +inclusion. -/ +@[reassoc (attr := simp)] +theorem symPowπ_symPowσ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) : + symPowπ A X n ≫ symPowσ A X n = symPowIdem A X n := + coequalizer.π_desc _ _ + +/-- Morphisms out of the symmetric power are determined by their +composite with the projection. -/ +theorem symPow_hom_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + {n : ℕ} {W : D} {k l : symPow A X n ⟶ W} + (h : symPowπ A X n ≫ k = symPowπ A X n ≫ l) : k = l := + coequalizer.hom_ext h + +/-- **The symmetric power is a direct summand**: the section +followed by the projection is the identity. -/ +@[reassoc (attr := simp)] +theorem symPowσ_symPowπ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) : + symPowσ A X n ≫ symPowπ A X n = 𝟙 (symPow A X n) := by + apply symPow_hom_ext A X + rw [← Category.assoc, symPowπ_symPowσ, symPowIdem_π, + Category.comp_id] + +/-- Descend a morphism absorbed by the symmetriser to the symmetric +power. -/ +noncomputable def symPowDesc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + {n : ℕ} {W : D} (k : modPow A X n ⟶ W) + (h : symPowIdem A X n ≫ k = k) : symPow A X n ⟶ W := + coequalizer.desc k (by rw [Category.id_comp, h]) + +/-- The descent factors the given morphism through the +projection. -/ +@[reassoc (attr := simp)] +theorem symPowπ_desc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + {n : ℕ} {W : D} (k : modPow A X n ⟶ W) + (h : symPowIdem A X n ≫ k = k) : + symPowπ A X n ≫ symPowDesc A X k h = k := + coequalizer.π_desc _ _ + +end SymPow + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymDatum.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymDatum.lean new file mode 100644 index 0000000000..9eb4daaa14 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymDatum.lean @@ -0,0 +1,116 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowDatum + +/-! +# The symmetric power duality datum + +Duality data transfer along module maps, and its instance of +record: the symmetric powers of a dual pair form a dual pair, +by transferring the power datum along the symmetriser section +and projection. The transfer needs no compatibility between the +chosen maps — linearity is compositional; the zigzag laws of the +transferred datum are where retraction and self-adjointness +enter, and they live with the pairing calculus. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +section Transfer + +/-- **Duality data transfer**: a duality datum for a pair of +modules induces one on any pair connected to it by module maps — +the pairing pulls back along maps into the pair, the copairing +pushes forward along maps out of it. Linearity is inherited +compositionally. -/ +noncomputable def ModDualityDatum.transfer + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] {P : Mod D A} {P' : Mod D A} + {Q : Mod D A} {Q' : Mod D A} + (d : ModDualityDatum A P P') (s : Q ⟶ P) (s' : Q' ⟶ P') + (r : P ⟶ Q) (r' : P' ⟶ Q') : ModDualityDatum A Q Q' where + pair := modTensorMap A s' s ≫ d.pair + copair := d.copair ≫ modTensorMap A r r' + pair_linear := by + let := modTensorModObj A Q' Q + let := modTensorModObj A P' P + have hp : modTensorAct A P' P ≫ d.pair = + (A ◁ d.pair) ≫ μ[A] := d.pair_linear + change modTensorAct A Q' Q ≫ modTensorMap A s' s ≫ d.pair = + (A ◁ (modTensorMap A s' s ≫ d.pair)) ≫ μ[A] + rw [← Category.assoc, modTensorAct_map, Category.assoc, hp, + ← MonoidalCategory.whiskerLeft_comp_assoc] + copair_linear := by + let := modTensorModObj A Q Q' + let := modTensorModObj A P P' + have hc : μ[A] ≫ d.copair = + (A ◁ d.copair) ≫ modTensorAct A P P' := d.copair_linear + change μ[A] ≫ d.copair ≫ modTensorMap A r r' = + (A ◁ (d.copair ≫ modTensorMap A r r')) ≫ + modTensorAct A Q Q' + rw [← Category.assoc, hc, Category.assoc, modTensorAct_map, + ← Category.assoc, ← MonoidalCategory.whiskerLeft_comp] + +end Transfer + +section SymBundles + +/-- The symmetriser projection, as a morphism of bundled +modules; the mirror of `symPowσMod`. -/ +noncomputable def symPowπMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] {X : D} [ModObj A X] + (n : ℕ) : + modPowMod A X n ⟶ symPowMod A X n := + letI := symPowModObj A X n + letI := modPowModObj A X n + Mod.Hom.mk (symPowπ A X (n + 1)) + (isModHom := + ⟨(whiskerLeft_symPowπ_symPowAct A X n).symm⟩) + +end SymBundles + +section SymDatum + +/-- **The symmetric power duality datum**: the symmetric powers +of a dual pair form a dual pair, by transferring the power datum +along the symmetriser section and projection. -/ +noncomputable def symDualityDatum + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] [CategoryTheory.Linear ℂ D] + [MonoidalLinear ℂ D] (M : Mod D A) (M' : Mod D A) + (d : ModDualityDatum A M M') + (n : ℕ) : + ModDualityDatum A (symPowMod A M.X n) (symPowMod A M'.X n) := + (powDualityDatum A M M' d n).transfer A + (symPowσMod A n) (symPowσMod A n) + (symPowπMod A n) (symPowπMod A n) + +end SymDatum + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymMul.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymMul.lean new file mode 100644 index 0000000000..52aa83fd4f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymMul.lean @@ -0,0 +1,1725 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymAlg + +/-! +# Multiplication on symmetric module powers + +The multiplication layer of Deligne (2002), §2.8: over an internal +monoid `A` and a module `X`, the concatenation of tensor powers +descends through the module-power coequalizers of `SymAlg.lean` to a +multiplication `modPow A X m ⊗ modPow A X n ⟶ modPow A X (m + n)`, +and then, through the symmetrisers, to the symmetric powers. + +* `tensorPowConcat_assoc`: the concatenation isomorphisms are + associative up to the `powCast` of `p + (q + r) = p + q + r`. +* `midConcatFst`/`midConcatSnd` and `modPowMul_rel_fst/snd`: the + slot relations of arity `m` (resp. `n`) embed across the + concatenation boundary into slots of `m + n`. +* `modPowMul`: the raw multiplication, descended in two stages + through whiskered coequalizers; its defining equation is + `(modPowπ ⊗ₘ modPowπ) ≫ modPowMul = concat ≫ modPowπ`. +* `modPowMul_perm`/`modPowMul_alg`: equivariance for the block + embedding of permutations and its `ℂ`-bilinear extension. +* `symMul`: the multiplication on symmetric powers, with defining + equation `(symPowπ ⊗ₘ symPowπ) ≫ symMul = modPowMul ≫ symPowπ`, + by absorption of the block-embedded symmetrisers. +* Laws: `symPowZero`, unit laws (`symMul_zero_left/right`), + associativity (`symMul_assoc`) and commutativity (`symMul_comm`, + through `tensorPowConcat_braiding_exists`: the braiding of two + tensor powers is, across the concatenations, the action of a + permutation, which the symmetriser absorbs). + +Whiskered coequalizers are handled by an instance parameter asking +that each `tensorLeft Y` preserve colimits of parallel pairs — in a +braided category the `tensorRight` mirror follows — together with +`MonoidalPreadditive D` for the biproduct legs; these hold in the +intended consumers. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## Associativity of the concatenation -/ + +section ConcatAssoc + +/-- The base of the associativity recursion, at general objects. -/ +private theorem concat_assoc_zero_aux [Category.{v} D] [MonoidalCategory D] + {P Q R : D} (c : P ⊗ Q ⟶ R) : + (c ▷ 𝟙_ D) ≫ (ρ_ R).hom = + (α_ P Q (𝟙_ D)).hom ≫ (P ◁ (ρ_ Q).hom) ≫ c := by + have h : (α_ P Q (𝟙_ D)).hom ≫ (P ◁ (ρ_ Q).hom) = + (ρ_ (P ⊗ Q)).hom := by monoidal + rw [← Category.assoc, h, MonoidalCategory.rightUnitor_naturality] + +/-- The step of the associativity recursion, at general objects: +one exposed top factor passes from the inner to the outer +concatenation stage. -/ +private theorem concat_assoc_step_aux [Category.{v} D] [MonoidalCategory D] + {P Q R S T Y : D} + (cq : Q ⊗ R ⟶ S) (cp : P ⊗ S ⟶ T) : + (α_ P Q (R ⊗ Y)).hom ≫ + (P ◁ ((α_ Q R Y).inv ≫ (cq ▷ Y))) ≫ + (α_ P S Y).inv ≫ (cp ▷ Y) = + (α_ (P ⊗ Q) R Y).inv ≫ ((α_ P Q R).hom ▷ Y) ≫ + (((P ◁ cq) ≫ cp) ▷ Y) := by + have hpent : (α_ P Q (R ⊗ Y)).hom ≫ (P ◁ (α_ Q R Y).inv) ≫ + (α_ P (Q ⊗ R) Y).inv = + (α_ (P ⊗ Q) R Y).inv ≫ ((α_ P Q R).hom ▷ Y) := by + monoidal + rw [MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rw [MonoidalCategory.associator_inv_naturality_middle_assoc, + reassoc_of% hpent, ← MonoidalCategory.comp_whiskerRight] + +/-- **Associativity of the concatenation**: concatenating the first +two blocks and then the third agrees, up to the arity transport of +`p + (q + r) = p + q + r`, with concatenating the last two blocks +and then the first. -/ +theorem tensorPowConcat_assoc [Category.{v} D] [MonoidalCategory D] (X : D) + (p q : ℕ) : ∀ r : ℕ, + ((tensorPowConcat X p q).hom ▷ tensorPow D X r) ≫ + (tensorPowConcat X (p + q) r).hom = + (α_ (tensorPow D X p) (tensorPow D X q) (tensorPow D X r)).hom ≫ + (tensorPow D X p ◁ (tensorPowConcat X q r).hom) ≫ + (tensorPowConcat X p (q + r)).hom ≫ + powCast X (by omega : p + (q + r) = p + q + r) + | 0 => by + have hc : powCast X + (by omega : p + (q + 0) = p + q + 0) = 𝟙 _ := rfl + rw [tensorPowConcat_zero, tensorPowConcat_zero, hc, + Category.comp_id] + exact concat_assoc_zero_aux ((tensorPowConcat X p q).hom) + | r + 1 => by + have hstep := concat_assoc_step_aux (Y := X) + ((tensorPowConcat X q r).hom) ((tensorPowConcat X p (q + r)).hom) + have hcast : powCast X + (by omega : p + (q + (r + 1)) = p + q + (r + 1)) = + powCast X (by omega : p + (q + r) = p + q + r) ▷ X := by + rw [powCast_whiskerRight] + change ((tensorPowConcat X p q).hom ▷ + (tensorPow D X r ⊗ X)) ≫ + (powExpose X (p + q) r ≫ + ((tensorPowConcat X (p + q) r).hom ▷ X)) = + (α_ (tensorPow D X p) (tensorPow D X q) + (tensorPow D X r ⊗ X)).hom ≫ + (tensorPow D X p ◁ (powExpose X q r ≫ + ((tensorPowConcat X q r).hom ▷ X))) ≫ + (powExpose X p (q + r) ≫ + ((tensorPowConcat X p (q + r)).hom ▷ X)) ≫ + powCast X (by omega : p + (q + (r + 1)) = p + q + (r + 1)) + rw [hcast, powExpose, powExpose, powExpose] + repeat' erw [Category.assoc] + rw [MonoidalCategory.associator_inv_naturality_left_assoc, + ← MonoidalCategory.comp_whiskerRight, + tensorPowConcat_assoc X p q r] + simp only [MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.comp_whiskerRight, Category.assoc] at hstep ⊢ + erw [reassoc_of% hstep] + rfl + +/-- Concatenation with an empty first block is the left unitor, up +to the arity transport. -/ +theorem tensorPowConcat_zero_left + [Category.{v} D] [MonoidalCategory D] (X : D) : ∀ n : ℕ, + (tensorPowConcat X 0 n).hom = + (λ_ (tensorPow D X n)).hom ≫ powCast X (by omega : n = 0 + n) + | 0 => by + have hc : powCast X (by omega : 0 = 0 + 0) = 𝟙 _ := rfl + rw [tensorPowConcat_zero, hc, Category.comp_id] + change (ρ_ (𝟙_ D)).hom = (λ_ (𝟙_ D)).hom + rw [← unitors_equal] + | n + 1 => by + have hcast : powCast X (by omega : n + 1 = 0 + (n + 1)) = + powCast X (by omega : n = 0 + n) ▷ X := by + rw [powCast_whiskerRight] + have hlam : (α_ (𝟙_ D) (tensorPow D X n) X).inv ≫ + ((λ_ (tensorPow D X n)).hom ▷ X) = + (λ_ (tensorPow D X n ⊗ X)).hom := by + monoidal + rw [tensorPowConcat_succ_hom X 0 n, tensorPowConcat_zero_left X n] + change (α_ (𝟙_ D) (tensorPow D X n) X).inv ≫ + (((λ_ (tensorPow D X n)).hom ≫ + powCast X (by omega : n = 0 + n)) ▷ X) = + (λ_ (tensorPow D X n ⊗ X)).hom ≫ + powCast X (by omega : n + 1 = 0 + (n + 1)) + rw [MonoidalCategory.comp_whiskerRight, ← Category.assoc, hlam, + hcast] + rfl + +end ConcatAssoc + +/-! ## Transport of concatenation and projections along arities -/ + +section CastTransport + +/-- An arity transport of the first block passes the +concatenation. -/ +theorem powCast_whiskerRight_concat + [Category.{v} D] [MonoidalCategory D] (X : D) + {k m : ℕ} (h : k = m) (n : ℕ) : + (powCast X h ▷ tensorPow D X n) ≫ (tensorPowConcat X m n).hom = + (tensorPowConcat X k n).hom ≫ + powCast X (by omega : k + n = m + n) := by + subst h + simp + +/-- An arity transport of the second block passes the +concatenation. -/ +theorem powCast_whiskerLeft_concat [Category.{v} D] [MonoidalCategory D] (X : D) + (m : ℕ) {k n : ℕ} (h : k = n) : + (tensorPow D X m ◁ powCast X h) ≫ (tensorPowConcat X m n).hom = + (tensorPowConcat X m k).hom ≫ + powCast X (by omega : m + k = m + n) := by + subst h + simp + +end CastTransport + +section ModCast + +/-- Transport of a module power along an equality of arities. -/ +noncomputable def modPowCast + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + {m n : ℕ} (h : m = n) : + modPow A X m ⟶ modPow A X n := + eqToHom (congrArg (modPow A X) h) + +@[simp] +theorem modPowCast_rfl + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (n : ℕ) : + modPowCast A X (rfl : n = n) = 𝟙 _ := rfl + +/-- Two module-power transports with the same endpoints agree. -/ +theorem modPowCast_irrel + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + {m n : ℕ} (h h' : m = n) : + modPowCast A X h = modPowCast A X h' := rfl + +/-- The projection intertwines the two arity transports. -/ +@[reassoc] +theorem modPowπ_cast + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + {m n : ℕ} (h : m = n) : + modPowπ A X m ≫ modPowCast A X h = + powCast X h ≫ modPowπ A X n := by + subst h + simp [powCast] + +end ModCast + +/-! ## Embedding the slot relations across the concatenation + +A relation slot of the left block, whiskered by the right block and +concatenated, is a relation slot of the concatenated power; and +mirrored for the right block. Each embedding is mediated by a +structural bridge morphism that is independent of the relation leg, +so both legs of a slot embed through the same bridge and the ambient +relation applies. +-/ + +section SlotEmbed + +/-- The bridge carrying a left-block slot into the concatenated +power: reassociate the right block onto the slot context and +concatenate the contexts. -/ +noncomputable def midConcatFst + [Category.{v} D] [MonoidalCategory D] (A : D) (X : D) + (a b n : ℕ) : + modPowMid A X a b ⊗ tensorPow D X n ⟶ modPowMid A X a (b + n) := + (α_ (tensorPow D X a ⊗ ((X ⊗ A) ⊗ X)) (tensorPow D X b) + (tensorPow D X n)).hom ≫ + ((tensorPow D X a ⊗ ((X ⊗ A) ⊗ X)) ◁ + (tensorPowConcat X b n).hom) + +/-- The bridge carrying a right-block slot into the concatenated +power: reassociate the left block onto the slot's lower context and +concatenate. -/ +noncomputable def midConcatSnd + [Category.{v} D] [MonoidalCategory D] (A : D) (X : D) + (m a b : ℕ) : + tensorPow D X m ⊗ modPowMid A X a b ⟶ modPowMid A X (m + a) b := + (α_ (tensorPow D X m) (tensorPow D X a ⊗ ((X ⊗ A) ⊗ X)) + (tensorPow D X b)).inv ≫ + (((α_ (tensorPow D X m) (tensorPow D X a) ((X ⊗ A) ⊗ X)).inv ≫ + ((tensorPowConcat X m a).hom ▷ ((X ⊗ A) ⊗ X))) ▷ + tensorPow D X b) + +/-- The exchange across the reassociated context, at general +objects. -/ +private theorem exchange_assoc_aux [Category.{v} D] [MonoidalCategory D] + {P M Q N S : D} (f : P ⟶ M) + (c : Q ⊗ N ⟶ S) : + ((f ▷ Q) ▷ N) ≫ (α_ M Q N).hom ≫ (M ◁ c) = + (α_ P Q N).hom ≫ (P ◁ c) ≫ (f ▷ S) := by + rw [MonoidalCategory.associator_naturality_left_assoc, + ← MonoidalCategory.whisker_exchange] + +/-- The left-block embedding at general objects, against an opaque +outer stage `E` carrying the associativity shift. -/ +private theorem leg_fst_aux [Category.{v} D] [MonoidalCategory D] (X : D) + {P V B N S U Z : D} (w : V ⟶ X ⊗ X) + (cbn : B ⊗ N ⟶ S) (cab : ((P ⊗ X) ⊗ X) ⊗ B ⟶ U) + (Cout : U ⊗ N ⟶ Z) (E : ((P ⊗ X) ⊗ X) ⊗ S ⟶ Z) + (hs : (cab ▷ N) ≫ Cout = + (α_ ((P ⊗ X) ⊗ X) B N).hom ≫ + (((P ⊗ X) ⊗ X) ◁ cbn) ≫ E) : + ((((P ◁ w) ▷ B) ≫ ((α_ P X X).inv ▷ B) ≫ cab) ▷ N) ≫ Cout = + ((α_ (P ⊗ V) B N).hom ≫ ((P ⊗ V) ◁ cbn)) ≫ + ((P ◁ w) ▷ S) ≫ ((α_ P X X).inv ▷ S) ≫ E := by + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [hs, ← MonoidalCategory.comp_whiskerRight_assoc, + ← MonoidalCategory.comp_whiskerRight, + MonoidalCategory.associator_naturality_left_assoc, + MonoidalCategory.whisker_exchange_assoc] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [← MonoidalCategory.whisker_exchange_assoc] + +/-- **A left-block slot leg embeds across the concatenation**: the +same computation for both legs, with the leg abstracted as `w`. -/ +theorem modPowLeg_concat_fst + [Category.{v} D] [MonoidalCategory D] (A : D) (X : D) + (a b n : ℕ) + (w : (X ⊗ A) ⊗ X ⟶ X ⊗ X) : + ((((tensorPow D X a ◁ w) ▷ tensorPow D X b) ≫ + modPowGlue X a b) ▷ tensorPow D X n) ≫ + (tensorPowConcat X (a + 2 + b) n).hom = + midConcatFst A X a b n ≫ + ((tensorPow D X a ◁ w) ▷ tensorPow D X (b + n)) ≫ + modPowGlue X a (b + n) ≫ + powCast X (by omega : a + 2 + (b + n) = a + 2 + b + n) := by + have h0 := leg_fst_aux X w ((tensorPowConcat X b n).hom) + ((tensorPowConcat X (a + 2) b).hom) + ((tensorPowConcat X (a + 2 + b) n).hom) + ((tensorPowConcat X (a + 2) (b + n)).hom ≫ + powCast X (by omega : a + 2 + (b + n) = a + 2 + b + n)) + (tensorPowConcat_assoc X (a + 2) b n) + simp only [modPowGlue, midConcatFst, Category.assoc] at h0 ⊢ + repeat' erw [Category.assoc] + exact h0 + +/-- The core of the right-block embedding, at general objects. -/ +private theorem concat_snd_core_aux + [Category.{v} D] [MonoidalCategory D] (X : D) + {P Q V M : D} (w : V ⟶ X ⊗ X) + (c : P ⊗ Q ⟶ M) : + (P ◁ ((Q ◁ w) ≫ (α_ Q X X).inv)) ≫ + (α_ P (Q ⊗ X) X).inv ≫ + (((α_ P Q X).inv ≫ (c ▷ X)) ▷ X) = + (α_ P Q V).inv ≫ (c ▷ V) ≫ (M ◁ w) ≫ (α_ M X X).inv := by + have hpent : (P ◁ (α_ Q X X).inv) ≫ (α_ P (Q ⊗ X) X).inv ≫ + ((α_ P Q X).inv ▷ X) = + (α_ P Q (X ⊗ X)).inv ≫ (α_ (P ⊗ Q) X X).inv := by + monoidal + rw [MonoidalCategory.whiskerLeft_comp] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + rw [reassoc_of% hpent, + MonoidalCategory.associator_inv_naturality_right_assoc, + ← MonoidalCategory.associator_inv_naturality_left, + MonoidalCategory.whisker_exchange_assoc] + +/-- The right-block embedding at general objects, against an opaque +outer stage `E` carrying the associativity shift. -/ +private theorem leg_snd_aux [Category.{v} D] [MonoidalCategory D] (X : D) + {P Q V B N Z M : D} (w : V ⟶ X ⊗ X) + (c : P ⊗ Q ⟶ M) (cab : ((Q ⊗ X) ⊗ X) ⊗ B ⟶ N) + (Cbig : P ⊗ N ⟶ Z) (E : ((M ⊗ X) ⊗ X) ⊗ B ⟶ Z) + (hs : (P ◁ cab) ≫ Cbig = + (α_ P ((Q ⊗ X) ⊗ X) B).inv ≫ + (((α_ P (Q ⊗ X) X).inv ≫ + (((α_ P Q X).inv ≫ (c ▷ X)) ▷ X)) ▷ B) ≫ E) : + (P ◁ (((Q ◁ w) ▷ B) ≫ ((α_ Q X X).inv ▷ B) ≫ cab)) ≫ Cbig = + (α_ P (Q ⊗ V) B).inv ≫ + (((α_ P Q V).inv ≫ (c ▷ V)) ▷ B) ≫ + ((M ◁ w) ▷ B) ≫ ((α_ M X X).inv ▷ B) ≫ E := by + have hbody : ((P ◁ (Q ◁ w)) ≫ (P ◁ (α_ Q X X).inv)) ≫ + ((α_ P (Q ⊗ X) X).inv ≫ + (((α_ P Q X).inv ≫ (c ▷ X)) ▷ X)) = + (α_ P Q V).inv ≫ (c ▷ V) ≫ (M ◁ w) ≫ (α_ M X X).inv := by + rw [← MonoidalCategory.whiskerLeft_comp] + exact concat_snd_core_aux X w c + rw [MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rw [hs, MonoidalCategory.associator_inv_naturality_middle_assoc, + MonoidalCategory.associator_inv_naturality_middle_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, hbody] + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + +/-- **A right-block slot leg embeds across the concatenation**: the +same computation for both legs, with the leg abstracted as `w`. -/ +theorem modPowLeg_concat_snd + [Category.{v} D] [MonoidalCategory D] (A : D) (X : D) + (m a b : ℕ) + (w : (X ⊗ A) ⊗ X ⟶ X ⊗ X) : + (tensorPow D X m ◁ (((tensorPow D X a ◁ w) ▷ tensorPow D X b) ≫ + modPowGlue X a b)) ≫ + (tensorPowConcat X m (a + 2 + b)).hom = + midConcatSnd A X m a b ≫ + ((tensorPow D X (m + a) ◁ w) ▷ tensorPow D X b) ≫ + modPowGlue X (m + a) b ≫ + powCast X (by omega : m + a + 2 + b = m + (a + 2 + b)) := by + have hassoc := tensorPowConcat_assoc X m (a + 2) b + have hshift : (tensorPow D X m ◁ (tensorPowConcat X (a + 2) b).hom) + ≫ (tensorPowConcat X m (a + 2 + b)).hom = + (α_ (tensorPow D X m) (tensorPow D X (a + 2)) + (tensorPow D X b)).inv ≫ + ((tensorPowConcat X m (a + 2)).hom ▷ tensorPow D X b) ≫ + (tensorPowConcat X (m + (a + 2)) b).hom ≫ + powCast X (by omega : m + (a + 2) + b = m + (a + 2 + b)) := by + rw [Iso.eq_inv_comp, reassoc_of% hassoc, powCast_comp] + have hc : powCast X + (by omega : m + (a + 2 + b) = m + (a + 2 + b)) = 𝟙 _ := rfl + rw [hc, Category.comp_id] + have h0 := leg_snd_aux X w + ((tensorPowConcat X m a).hom) ((tensorPowConcat X (a + 2) b).hom) + ((tensorPowConcat X m (a + 2 + b)).hom) + ((tensorPowConcat X (m + (a + 2)) b).hom ≫ + powCast X (by omega : m + (a + 2) + b = m + (a + 2 + b))) + hshift + simp only [modPowGlue, midConcatSnd, Category.assoc] at h0 ⊢ + repeat' erw [Category.assoc] + exact h0 + +end SlotEmbed + +/-! ## The slot relations across the concatenation boundary -/ + +section RelEmbed + +/-- **Left-block slot relations embed**: a relation slot of the +left block, whiskered by the right block and concatenated into the +ambient power of arity `m + n`, is absorbed by the projection. -/ +theorem modPowMul_rel_fst + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + {m : ℕ} (n a b : ℕ) (hab : a + 2 + b = m) : + ((modPowLegM A X a b ≫ powCast X hab) ▷ tensorPow D X n) ≫ + (tensorPowConcat X m n).hom ≫ modPowπ A X (m + n) = + ((modPowLegN A X a b ≫ powCast X hab) ▷ tensorPow D X n) ≫ + (tensorPowConcat X m n).hom ≫ modPowπ A X (m + n) := by + subst hab + have hM := modPowLeg_concat_fst A X a b n (winLegM A X) + have hN := modPowLeg_concat_fst A X a b n (winLegN A X) + have hrel := modPow_rel A X a (b + n) + (by omega : a + 2 + (b + n) = a + 2 + b + n) + simp only [powCast_rfl, Category.comp_id, modPowLegM, modPowLegN, + Category.assoc] at hrel ⊢ + rw [reassoc_of% hM, reassoc_of% hN, hrel] + +/-- **Right-block slot relations embed**: a relation slot of the +right block, whiskered by the left block and concatenated into the +ambient power of arity `m + n`, is absorbed by the projection. -/ +theorem modPowMul_rel_snd + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + (m : ℕ) {n : ℕ} (a b : ℕ) + (hab : a + 2 + b = n) : + (tensorPow D X m ◁ (modPowLegM A X a b ≫ powCast X hab)) ≫ + (tensorPowConcat X m n).hom ≫ modPowπ A X (m + n) = + (tensorPow D X m ◁ (modPowLegN A X a b ≫ powCast X hab)) ≫ + (tensorPowConcat X m n).hom ≫ modPowπ A X (m + n) := by + subst hab + have hM := modPowLeg_concat_snd A X m a b (winLegM A X) + have hN := modPowLeg_concat_snd A X m a b (winLegN A X) + have hrel := modPow_rel A X (m + a) b + (by omega : m + a + 2 + b = m + (a + 2 + b)) + simp only [powCast_rfl, Category.comp_id, modPowLegM, modPowLegN, + Category.assoc] at hrel ⊢ + rw [reassoc_of% hM, reassoc_of% hN, hrel] + +end RelEmbed + +/-! ## Whiskered coequalizers of the module power + +The two-stage descent needs the module-power coequalizer to remain +a colimit after whiskering on either side; this is exactly the +preservation of parallel-pair colimits by `tensorLeft`/`tensorRight`, +taken as instance parameters. +-/ + +section WhiskerColimit + +/-- Whiskering the module-power coequalizer on the left yields a +colimit cofork. -/ +noncomputable def modPowWhiskerLeftIsColimit + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (P : D) (n : ℕ) : + IsColimit (Cofork.ofπ (P ◁ modPowπ A X n) + (by rw [← MonoidalCategory.whiskerLeft_comp, modPow_condition, + MonoidalCategory.whiskerLeft_comp]) : + Cofork (P ◁ modPowLegFst A X n) (P ◁ modPowLegSnd A X n)) := + isColimitOfHasCoequalizerOfPreservesColimit (tensorLeft P) _ _ + +/-- Morphisms out of a left-whiskered module power are determined +by their composite with the whiskered projection. -/ +theorem modPow_whiskerLeft_hom_ext + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (P : D) (n : ℕ) {Z : D} + {k l : P ⊗ modPow A X n ⟶ Z} + (h : (P ◁ modPowπ A X n) ≫ k = (P ◁ modPowπ A X n) ≫ l) : + k = l := + Cofork.IsColimit.hom_ext (modPowWhiskerLeftIsColimit A X P n) h + +/-- Descend a morphism along the left-whiskered projection. -/ +noncomputable def modPowWhiskerLeftDesc + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (P : D) (n : ℕ) {Z : D} + (k : P ⊗ tensorPow D X n ⟶ Z) + (h : (P ◁ modPowLegFst A X n) ≫ k = + (P ◁ modPowLegSnd A X n) ≫ k) : + P ⊗ modPow A X n ⟶ Z := + Cofork.IsColimit.desc (modPowWhiskerLeftIsColimit A X P n) k h + +/-- The left-whiskered descent factors through the whiskered +projection. -/ +@[reassoc (attr := simp)] +theorem modPowπ_whiskerLeft_desc + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (P : D) (n : ℕ) {Z : D} + (k : P ⊗ tensorPow D X n ⟶ Z) + (h : (P ◁ modPowLegFst A X n) ≫ k = + (P ◁ modPowLegSnd A X n) ≫ k) : + (P ◁ modPowπ A X n) ≫ modPowWhiskerLeftDesc A X P n k h = k := + Cofork.IsColimit.π_desc' (modPowWhiskerLeftIsColimit A X P n) k h + +/-- A doubly whiskered projection is still a colimit cofork. -/ +noncomputable def modPowWhiskerRightLeftIsColimit + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) (W P : D) : + IsColimit (Cofork.ofπ (P ◁ (modPowπ A X n ▷ W)) + (by rw [← MonoidalCategory.whiskerLeft_comp, + ← MonoidalCategory.comp_whiskerRight, modPow_condition, + MonoidalCategory.comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp]) : + Cofork (P ◁ (modPowLegFst A X n ▷ W)) + (P ◁ (modPowLegSnd A X n ▷ W))) := + isColimitCoforkMapOfIsColimit (tensorLeft P) _ + (modPowWhiskerRightIsColimit A X n W) + +/-- The left-whiskered projection is an epimorphism. -/ +instance epi_whiskerLeft_modPowπ + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (P : D) (n : ℕ) : + Epi (P ◁ modPowπ A X n) := + epi_of_isColimit_cofork (modPowWhiskerLeftIsColimit A X P n) + +/-- The doubly whiskered projection is an epimorphism. -/ +instance epi_whiskerLeft_modPowπ_whiskerRight + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) (W P : D) : + Epi (P ◁ (modPowπ A X n ▷ W)) := + epi_of_isColimit_cofork + (modPowWhiskerRightLeftIsColimit A X n W P) + +/-- Morphisms out of a tensor product of module powers are +determined by their composite with the tensored projections. -/ +theorem modPowTensor_hom_ext + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (m n : ℕ) {Z : D} + {k l : modPow A X m ⊗ modPow A X n ⟶ Z} + (h : (modPowπ A X m ⊗ₘ modPowπ A X n) ≫ k = + (modPowπ A X m ⊗ₘ modPowπ A X n) ≫ l) : k = l := by + apply modPow_whiskerLeft_hom_ext A X (modPow A X m) n + apply modPow_whiskerRight_hom_ext A X m (tensorPow D X n) + simpa only [MonoidalCategory.tensorHom_def, Category.assoc] using h + +end WhiskerColimit + +/-! ## The raw multiplication -/ + +section MulDesc + +/-- The first assembled leg as a sum over the slots. -/ +private theorem modPowLegFst_eq_sum + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + (n : ℕ) : + modPowLegFst A X n = ∑ i : Fin (n - 1), + biproduct.π + (fun i : Fin (n - 1) => modPowMid A X i.val (n - 2 - i.val)) + i ≫ + (modPowLegM A X i.val (n - 2 - i.val) ≫ + powCast X (slot_decomp i)) := by + conv_lhs => rw [← Category.id_comp (modPowLegFst A X n), + ← biproduct.total] + rw [Preadditive.sum_comp] + refine Finset.sum_congr rfl fun i _ => ?_ + rw [Category.assoc, modPowLegFst, biproduct.ι_desc] + +/-- The second assembled leg as a sum over the slots. -/ +private theorem modPowLegSnd_eq_sum + [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (X : D) + [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + (n : ℕ) : + modPowLegSnd A X n = ∑ i : Fin (n - 1), + biproduct.π + (fun i : Fin (n - 1) => modPowMid A X i.val (n - 2 - i.val)) + i ≫ + (modPowLegN A X i.val (n - 2 - i.val) ≫ + powCast X (slot_decomp i)) := by + conv_lhs => rw [← Category.id_comp (modPowLegSnd A X n), + ← biproduct.total] + rw [Preadditive.sum_comp] + refine Finset.sum_congr rfl fun i _ => ?_ + rw [Category.assoc, modPowLegSnd, biproduct.ι_desc] + +/-- A slot-wise condition assembles over the right-whiskered legs. -/ +private theorem legs_whiskerRight_cond + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] + {m : ℕ} (n : ℕ) {Z : D} + (k : tensorPow D X m ⊗ tensorPow D X n ⟶ Z) + (h : ∀ a b (hab : a + 2 + b = m), + ((modPowLegM A X a b ≫ powCast X hab) ▷ tensorPow D X n) ≫ k = + ((modPowLegN A X a b ≫ powCast X hab) ▷ tensorPow D X n) ≫ k) : + (modPowLegFst A X m ▷ tensorPow D X n) ≫ k = + (modPowLegSnd A X m ▷ tensorPow D X n) ≫ k := by + rw [modPowLegFst_eq_sum, modPowLegSnd_eq_sum, + sum_whiskerRight, sum_whiskerRight, + Preadditive.sum_comp, Preadditive.sum_comp] + refine Finset.sum_congr rfl fun i _ => ?_ + have hi := h i.val (m - 2 - i.val) (slot_decomp i) + simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] + at hi ⊢ + rw [hi] + +/-- A slot-wise condition assembles over the left-whiskered legs. -/ +private theorem legs_whiskerLeft_cond + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [MonoidalPreadditive D] + (m : ℕ) {n : ℕ} {Z : D} + (k : tensorPow D X m ⊗ tensorPow D X n ⟶ Z) + (h : ∀ a b (hab : a + 2 + b = n), + (tensorPow D X m ◁ (modPowLegM A X a b ≫ powCast X hab)) ≫ k = + (tensorPow D X m ◁ (modPowLegN A X a b ≫ powCast X hab)) ≫ k) : + (tensorPow D X m ◁ modPowLegFst A X n) ≫ k = + (tensorPow D X m ◁ modPowLegSnd A X n) ≫ k := by + rw [modPowLegFst_eq_sum, modPowLegSnd_eq_sum, + whiskerLeft_sum, whiskerLeft_sum, + Preadditive.sum_comp, Preadditive.sum_comp] + refine Finset.sum_congr rfl fun i _ => ?_ + have hi := h i.val (n - 2 - i.val) (slot_decomp i) + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + at hi ⊢ + rw [hi] + +/-- The first stage of the multiplication: the concatenation +descends through the left factor against an ambient right factor. -/ +noncomputable def modPowMulStage + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (m n : ℕ) : + modPow A X m ⊗ tensorPow D X n ⟶ modPow A X (m + n) := + modPowWhiskerRightDesc A X m (tensorPow D X n) + ((tensorPowConcat X m n).hom ≫ modPowπ A X (m + n)) + (by + exact legs_whiskerRight_cond A X n _ + (fun a b hab => modPowMul_rel_fst A X n a b hab)) + +/-- Defining equation of the first stage. -/ +@[reassoc (attr := simp)] +theorem modPowπ_whiskerRight_mulStage + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (m n : ℕ) : + (modPowπ A X m ▷ tensorPow D X n) ≫ modPowMulStage A X m n = + (tensorPowConcat X m n).hom ≫ modPowπ A X (m + n) := + modPowπ_whiskerRight_desc A X m (tensorPow D X n) _ _ + +/-- The first stage coequalizes the left-whiskered legs of the +right factor. -/ +theorem modPowMulStage_cond + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (m n : ℕ) : + (modPow A X m ◁ modPowLegFst A X n) ≫ modPowMulStage A X m n = + (modPow A X m ◁ modPowLegSnd A X n) ≫ modPowMulStage A X m n := by + apply modPow_whiskerRight_hom_ext A X m (modPowSrc A X n) + rw [← MonoidalCategory.whisker_exchange_assoc, + ← MonoidalCategory.whisker_exchange_assoc, + modPowπ_whiskerRight_mulStage] + exact legs_whiskerLeft_cond A X m _ + (fun a b hab => modPowMul_rel_snd A X m a b hab) + +/-- **The raw multiplication** on module powers, descended from the +concatenation of the ambient tensor powers in two stages. -/ +noncomputable def modPowMul + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (m n : ℕ) : + modPow A X m ⊗ modPow A X n ⟶ modPow A X (m + n) := + modPowWhiskerLeftDesc A X (modPow A X m) n (modPowMulStage A X m n) + (modPowMulStage_cond A X m n) + +/-- The second-stage defining equation. -/ +@[reassoc (attr := simp)] +theorem modPow_whiskerLeft_modPowMul + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (m n : ℕ) : + (modPow A X m ◁ modPowπ A X n) ≫ modPowMul A X m n = + modPowMulStage A X m n := + modPowπ_whiskerLeft_desc A X (modPow A X m) n _ _ + +/-- **Defining equation of the raw multiplication**: on the ambient +tensor powers it is the concatenation followed by the projection. -/ +@[reassoc] +theorem modPowπ_tensor_modPowMul + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (m n : ℕ) : + (modPowπ A X m ⊗ₘ modPowπ A X n) ≫ modPowMul A X m n = + (tensorPowConcat X m n).hom ≫ modPowπ A X (m + n) := by + rw [MonoidalCategory.tensorHom_def, Category.assoc, + modPow_whiskerLeft_modPowMul, modPowπ_whiskerRight_mulStage] + +end MulDesc + +/-! ## Bilinear glue for the algebra intertwining -/ + +section LinearGlue + +/-- Intertwining across `T` is closed under sums in the second +factor. -/ +private theorem tensor_add_glue + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] + {P Q R : D} {T : P ⊗ Q ⟶ R} + {u v : R ⟶ R} {f : P ⟶ P} {g h : Q ⟶ Q} + (hu : (f ⊗ₘ g) ≫ T = T ≫ u) (hv : (f ⊗ₘ h) ≫ T = T ≫ v) : + (f ⊗ₘ (g + h)) ≫ T = T ≫ (u + v) := by + rw [MonoidalPreadditive.tensor_add, Preadditive.add_comp, + Preadditive.comp_add, hu, hv] + +/-- Intertwining across `T` is closed under sums in the first +factor. -/ +private theorem add_tensor_glue + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] + {P Q R : D} {T : P ⊗ Q ⟶ R} + {u v : R ⟶ R} {f g : P ⟶ P} {h : Q ⟶ Q} + (hu : (f ⊗ₘ h) ≫ T = T ≫ u) (hv : (g ⊗ₘ h) ≫ T = T ≫ v) : + ((f + g) ⊗ₘ h) ≫ T = T ≫ (u + v) := by + rw [MonoidalPreadditive.add_tensor, Preadditive.add_comp, + Preadditive.comp_add, hu, hv] + +/-- The tensor product of morphisms is homogeneous in the second +factor. -/ +private theorem tensorHom_smul + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [Linear ℂ D] [MonoidalLinear ℂ D] + {P Q R S : D} (f : P ⟶ Q) (r : ℂ) + (g : R ⟶ S) : f ⊗ₘ (r • g) = r • (f ⊗ₘ g) := by + rw [MonoidalCategory.tensorHom_def, MonoidalCategory.tensorHom_def, + MonoidalLinear.whiskerLeft_smul, Linear.comp_smul] + +/-- The tensor product of morphisms is homogeneous in the first +factor. -/ +private theorem smul_tensorHom + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [Linear ℂ D] [MonoidalLinear ℂ D] + {P Q R S : D} (r : ℂ) (f : P ⟶ Q) + (g : R ⟶ S) : (r • f) ⊗ₘ g = r • (f ⊗ₘ g) := by + rw [MonoidalCategory.tensorHom_def, MonoidalCategory.tensorHom_def, + MonoidalLinear.smul_whiskerRight, Linear.smul_comp] + +/-- Intertwining across `T` is closed under scalars in the second +factor. -/ +private theorem tensor_smul_glue + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [Linear ℂ D] [MonoidalLinear ℂ D] + {P Q R : D} {T : P ⊗ Q ⟶ R} + {u : R ⟶ R} {f : P ⟶ P} {g : Q ⟶ Q} (r : ℂ) + (h : (f ⊗ₘ g) ≫ T = T ≫ u) : + (f ⊗ₘ (r • g)) ≫ T = T ≫ (r • u) := by + rw [tensorHom_smul, Linear.smul_comp, Linear.comp_smul, h] + +/-- Intertwining across `T` is closed under scalars in the first +factor. -/ +private theorem smul_tensor_glue + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [Linear ℂ D] [MonoidalLinear ℂ D] + {P Q R : D} {T : P ⊗ Q ⟶ R} + {u : R ⟶ R} {f : P ⟶ P} {g : Q ⟶ Q} (r : ℂ) + (h : (f ⊗ₘ g) ≫ T = T ≫ u) : + ((r • f) ⊗ₘ g) ≫ T = T ≫ (r • u) := by + rw [smul_tensorHom, Linear.smul_comp, Linear.comp_smul, h] + +end LinearGlue + +/-! ## Equivariance of the raw multiplication -/ + +section Equivariance + +/-- **Equivariance**: the raw multiplication intertwines the pair +of permutation actions with the block-embedded action. -/ +theorem modPowMul_perm + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (m n : ℕ) (σ : Equiv.Perm (Fin m)) + (τ : Equiv.Perm (Fin n)) : + (modPowPerm (A := A) (X := X) m σ ⊗ₘ + modPowPerm (A := A) (X := X) n τ) ≫ modPowMul A X m n = + modPowMul A X m n ≫ + modPowPerm (A := A) (X := X) (m + n) (blockEmbed σ τ) := by + apply modPowTensor_hom_ext A X m n + conv_lhs => rw [← Category.assoc, tensorHom_comp_tensorHom, + modPowπ_perm, modPowπ_perm, ← tensorHom_comp_tensorHom, + Category.assoc, modPowπ_tensor_modPowMul, ← Category.assoc, + ← tensorPowConcat_permMor, Category.assoc] + conv_rhs => rw [← Category.assoc, modPowπ_tensor_modPowMul, + Category.assoc, modPowπ_perm] + +/-- **Linear equivariance**: the raw multiplication intertwines the +group-algebra actions with the block embedding of group algebras, +by bilinear extension of the permutation case. -/ +theorem modPowMul_alg + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + [Linear ℂ D] [MonoidalLinear ℂ D] + (m n : ℕ) (x : SymGroupAlgebra m) + (y : SymGroupAlgebra n) : + ((modPowAlg A X m x : End _) ⊗ₘ (modPowAlg A X n y : End _)) ≫ + modPowMul A X m n = + modPowMul A X m n ≫ modPowAlg A X (m + n) (blockAlgEmbed x y) := by + induction x using MonoidAlgebra.induction_on with + | of σ => + induction y using MonoidAlgebra.induction_on with + | of τ => + rw [show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin m))) σ = + MonoidAlgebra.single σ (1 : ℂ) from rfl, + show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin n))) τ = + MonoidAlgebra.single τ (1 : ℂ) from rfl, + blockAlgEmbed_single, one_mul, modPowAlg_single, + modPowAlg_single, modPowAlg_single] + exact modPowMul_perm A X m n σ τ + | add y₁ y₂ hy₁ hy₂ => + rw [blockAlgEmbed_add_snd, map_add, map_add] + exact tensor_add_glue hy₁ hy₂ + | smul r y' hy => + rw [blockAlgEmbed_smul_snd, map_smul, map_smul] + exact tensor_smul_glue r hy + | add x₁ x₂ hx₁ hx₂ => + rw [blockAlgEmbed_add_fst, map_add, map_add] + exact add_tensor_glue hx₁ hx₂ + | smul r x' hx => + rw [blockAlgEmbed_smul_fst, map_smul, map_smul] + exact smul_tensor_glue r hx + +end Equivariance + +/-! ## Absorption of embedded symmetrisers -/ + +section Absorption + +/-- The full symmetriser absorbs the image of any mass-one average: +pushing a symmetriser forward along any group homomorphism into the +larger symmetric group leaves the larger symmetriser fixed. -/ +theorem symmetriser_mul_mapDomain {k N : ℕ} + (f : Equiv.Perm (Fin k) →* Equiv.Perm (Fin N)) : + symmetriser N * + MonoidAlgebra.mapDomainAlgHom ℂ ℂ f (symmetriser k) = + symmetriser N := by + have hmap : MonoidAlgebra.mapDomainAlgHom ℂ ℂ f (symmetriser k) = + ((k.factorial : ℂ))⁻¹ • + ∑ σ : Equiv.Perm (Fin k), + MonoidAlgebra.single (f σ) (1 : ℂ) := by + rw [symmetriser, map_smul, map_sum] + congr 1 + refine Finset.sum_congr rfl fun σ _ => ?_ + change MonoidAlgebra.mapDomain _ _ = _ + exact MonoidAlgebra.mapDomain_single + rw [hmap, mul_smul_comm, Finset.mul_sum] + simp only [symmetriser_mul_single] + rw [Finset.sum_const, Finset.card_univ, Fintype.card_perm, + Fintype.card_fin, ← Nat.cast_smul_eq_nsmul ℂ, smul_smul, + inv_mul_cancel₀ + (by exact_mod_cast k.factorial_ne_zero : (k.factorial : ℂ) ≠ 0), + one_smul] + +/-- **The coset identity**: the block embedding of the two +symmetrisers is absorbed by the full symmetriser. -/ +theorem symmetriser_mul_blockAlgEmbed (m n : ℕ) : + symmetriser (m + n) * + blockAlgEmbed (symmetriser m) (symmetriser n) = + symmetriser (m + n) := by + rw [blockAlgEmbed, ← mul_assoc, symmetriser_mul_mapDomain, + symmetriser_mul_mapDomain] + +/-- The block embedding of a one-sided unit is one-sided. -/ +theorem blockAlgEmbed_one_left {m n : ℕ} (y : SymGroupAlgebra n) : + blockAlgEmbed (1 : SymGroupAlgebra m) y = + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedSndHom m n) y := by + rw [blockAlgEmbed, map_one, one_mul] + +/-- The block embedding of a one-sided unit is one-sided. -/ +theorem blockAlgEmbed_one_right {m n : ℕ} (x : SymGroupAlgebra m) : + blockAlgEmbed x (1 : SymGroupAlgebra n) = + MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedFstHom m n) x := by + rw [blockAlgEmbed, map_one, mul_one] + +/-- Any element absorbed by the symmetriser acts trivially after +the symmetric-power projection. -/ +theorem modPowAlg_absorb + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + {N : ℕ} (z : SymGroupAlgebra N) + (hz : symmetriser N * z = symmetriser N) : + (modPowAlg A X N z : End _) ≫ symPowπ A X N = symPowπ A X N := by + have h2 : (modPowAlg A X N z : End _) ≫ symPowIdem A X N = + symPowIdem A X N := by + have h3 := congrArg (modPowAlg A X N) hz + rw [map_mul] at h3 + exact h3 + conv_lhs => rw [← symPowIdem_π A X N, ← Category.assoc, h2] + rw [symPowIdem_π] + +end Absorption + +/-! ## The multiplication on symmetric powers -/ + +section SymMulDef + +/-- **The multiplication on symmetric powers**, through the +sections and the raw multiplication. -/ +noncomputable def symMul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] [Linear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (m n : ℕ) : + symPow A X m ⊗ symPow A X n ⟶ symPow A X (m + n) := + (symPowσ A X m ⊗ₘ symPowσ A X n) ≫ modPowMul A X m n ≫ + symPowπ A X (m + n) + +/-- **Defining equation of the symmetric multiplication**: the two +projections carry the raw multiplication to `symMul`. The two +factor symmetrisers introduced by the sections are absorbed by the +full symmetriser through equivariance and the coset identity. -/ +@[reassoc] +theorem symPowπ_tensor_symMul + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (m n : ℕ) : + (symPowπ A X m ⊗ₘ symPowπ A X n) ≫ symMul A X m n = + modPowMul A X m n ≫ symPowπ A X (m + n) := by + have h1 : (symPowIdem A X m ⊗ₘ symPowIdem A X n) ≫ + modPowMul A X m n = + modPowMul A X m n ≫ modPowAlg A X (m + n) + (blockAlgEmbed (symmetriser m) (symmetriser n)) := + modPowMul_alg A X m n (symmetriser m) (symmetriser n) + rw [symMul, ← Category.assoc, tensorHom_comp_tensorHom, + symPowπ_symPowσ, symPowπ_symPowσ, reassoc_of% h1, + modPowAlg_absorb A X _ (symmetriser_mul_blockAlgEmbed m n)] + +/-- Morphisms out of a tensor product of symmetric powers are +determined by their composites with the tensored projections. -/ +theorem symPowTensor_hom_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (m n : ℕ) {Z : D} + {k l : symPow A X m ⊗ symPow A X n ⟶ Z} + (h : (symPowπ A X m ⊗ₘ symPowπ A X n) ≫ k = + (symPowπ A X m ⊗ₘ symPowπ A X n) ≫ l) : k = l := by + have hsec : (symPowσ A X m ⊗ₘ symPowσ A X n) ≫ + (symPowπ A X m ⊗ₘ symPowπ A X n) = 𝟙 _ := by + rw [tensorHom_comp_tensorHom, symPowσ_symPowπ, symPowσ_symPowπ, + tensorHom_id, MonoidalCategory.id_whiskerRight] + calc k = ((symPowσ A X m ⊗ₘ symPowσ A X n) ≫ + (symPowπ A X m ⊗ₘ symPowπ A X n)) ≫ k := by + rw [hsec, Category.id_comp] + _ = ((symPowσ A X m ⊗ₘ symPowσ A X n) ≫ + (symPowπ A X m ⊗ₘ symPowπ A X n)) ≫ l := by + rw [Category.assoc, Category.assoc, h] + _ = l := by rw [hsec, Category.id_comp] + +end SymMulDef + +/-! ## The empty symmetric power -/ + +section ZeroPow + +/-- At arity zero the symmetriser is the unit of the group +algebra. -/ +theorem symmetriser_zero : symmetriser 0 = 1 := by + let : Unique (Equiv.Perm (Fin 0)) := + ⟨⟨1⟩, fun σ => Equiv.ext fun x => x.elim0⟩ + rw [symmetriser, Fintype.sum_unique] + change ((Nat.factorial 0 : ℂ))⁻¹ • + MonoidAlgebra.single 1 (1 : ℂ) = 1 + rw [Nat.factorial_zero, Nat.cast_one, inv_one, one_smul] + exact MonoidAlgebra.one_def.symm + +/-- At arity zero the symmetriser acts as the identity. -/ +theorem symPowIdem_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] : symPowIdem A X 0 = 𝟙 (modPow A X 0) := by + rw [symPowIdem, symmetriser_zero, map_one] + rfl + +/-- **The empty symmetric power is the unit object.** -/ +noncomputable def symPowZero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] : symPow A X 0 ≅ 𝟙_ D where + hom := symPowσ A X 0 ≫ (modPowZero A X).hom + inv := (modPowZero A X).inv ≫ symPowπ A X 0 + hom_inv_id := by + rw [Category.assoc, Iso.hom_inv_id_assoc, symPowσ_symPowπ] + inv_hom_id := by + rw [Category.assoc, symPowπ_symPowσ_assoc, symPowIdem_zero, + Category.id_comp, Iso.inv_hom_id] + +/-- At arity one the symmetriser is the unit of the group +algebra. -/ +theorem symmetriser_one : symmetriser 1 = 1 := by + let : Unique (Equiv.Perm (Fin 1)) := + ⟨⟨1⟩, fun σ => Equiv.ext fun x => Subsingleton.elim _ _⟩ + rw [symmetriser, Fintype.sum_unique] + change ((Nat.factorial 1 : ℂ))⁻¹ • + MonoidAlgebra.single 1 (1 : ℂ) = 1 + rw [Nat.factorial_one, Nat.cast_one, inv_one, one_smul] + exact MonoidAlgebra.one_def.symm + +/-- At arity one the symmetriser acts as the identity. -/ +theorem symPowIdem_one + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] : symPowIdem A X 1 = 𝟙 (modPow A X 1) := by + rw [symPowIdem, symmetriser_one, map_one] + rfl + +/-- **The singleton symmetric power is the module.** -/ +noncomputable def symPowOne + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] : symPow A X 1 ≅ X where + hom := symPowσ A X 1 ≫ (modPowOne A X).hom + inv := (modPowOne A X).inv ≫ symPowπ A X 1 + hom_inv_id := by + rw [Category.assoc, Iso.hom_inv_id_assoc, symPowσ_symPowπ] + inv_hom_id := by + rw [Category.assoc, symPowπ_symPowσ_assoc, symPowIdem_one, + Category.id_comp, Iso.inv_hom_id] + +/-- Transport of a symmetric power along an equality of arities. -/ +noncomputable def symPowCast + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + {m n : ℕ} (h : m = n) : + symPow A X m ⟶ symPow A X n := + eqToHom (congrArg (symPow A X) h) + +@[simp] +theorem symPowCast_rfl + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) : + symPowCast A X (rfl : n = n) = 𝟙 _ := rfl + +/-- The projection intertwines the module- and symmetric-power +transports. -/ +@[reassoc] +theorem symPowπ_cast + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + {m n : ℕ} (h : m = n) : + symPowπ A X m ≫ symPowCast A X h = + modPowCast A X h ≫ symPowπ A X n := by + subst h + simp [symPowCast] + +/-- Morphisms out of a left-whiskered symmetric power are +determined by the whiskered projection, which is split epi. -/ +theorem symPow_whiskerLeft_hom_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (P : D) (n : ℕ) {Z : D} + {k l : P ⊗ symPow A X n ⟶ Z} + (h : (P ◁ symPowπ A X n) ≫ k = (P ◁ symPowπ A X n) ≫ l) : + k = l := by + have hsec : (P ◁ symPowσ A X n) ≫ (P ◁ symPowπ A X n) = 𝟙 _ := by + rw [← MonoidalCategory.whiskerLeft_comp, symPowσ_symPowπ, + MonoidalCategory.whiskerLeft_id] + calc k = ((P ◁ symPowσ A X n) ≫ (P ◁ symPowπ A X n)) ≫ k := by + rw [hsec, Category.id_comp] + _ = ((P ◁ symPowσ A X n) ≫ (P ◁ symPowπ A X n)) ≫ l := by + rw [Category.assoc, Category.assoc, h] + _ = l := by rw [hsec, Category.id_comp] + +/-- Morphisms out of a right-whiskered symmetric power are +determined by the whiskered projection, which is split epi. -/ +theorem symPow_whiskerRight_hom_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (n : ℕ) (W : D) {Z : D} + {k l : symPow A X n ⊗ W ⟶ Z} + (h : (symPowπ A X n ▷ W) ≫ k = (symPowπ A X n ▷ W) ≫ l) : + k = l := by + have hsec : (symPowσ A X n ▷ W) ≫ (symPowπ A X n ▷ W) = 𝟙 _ := by + rw [← MonoidalCategory.comp_whiskerRight, symPowσ_symPowπ, + MonoidalCategory.id_whiskerRight] + calc k = ((symPowσ A X n ▷ W) ≫ (symPowπ A X n ▷ W)) ≫ k := by + rw [hsec, Category.id_comp] + _ = ((symPowσ A X n ▷ W) ≫ (symPowπ A X n ▷ W)) ≫ l := by + rw [Category.assoc, Category.assoc, h] + _ = l := by rw [hsec, Category.id_comp] + +end ZeroPow + +/-! ## Unit laws -/ + +section UnitLaws + +/-- **Left unit law at the module-power level**: multiplying by the +empty power is the left unitor, up to the arity transport. -/ +theorem modPowMul_zero_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + ((modPowZero A X).inv ▷ modPow A X n) ≫ modPowMul A X 0 n = + (λ_ (modPow A X n)).hom ≫ + modPowCast A X (by omega : n = 0 + n) := by + apply modPow_whiskerLeft_hom_ext A X (𝟙_ D) n + have h0 : (tensorPowConcat X 0 n).hom ≫ modPowπ A X (0 + n) = + ((λ_ (tensorPow D X n)).hom ≫ + powCast X (by omega : n = 0 + n)) ≫ modPowπ A X (0 + n) := + congrArg (· ≫ modPowπ A X (0 + n)) (tensorPowConcat_zero_left X n) + have hkey : ((modPowZero A X).inv ▷ tensorPow D X n) ≫ + modPowMulStage A X 0 n = + (λ_ (tensorPow D X n)).hom ≫ + powCast X (by omega : n = 0 + n) ≫ modPowπ A X (0 + n) := + (modPowπ_whiskerRight_mulStage A X 0 n).trans + (h0.trans (Category.assoc _ _ _)) + conv_lhs => rw [MonoidalCategory.whisker_exchange_assoc, + modPow_whiskerLeft_modPowMul, hkey] + conv_rhs => rw [MonoidalCategory.leftUnitor_naturality_assoc, + modPowπ_cast] + +/-- **Right unit law at the module-power level**: multiplying by +the empty power is the right unitor, up to the arity transport. -/ +theorem modPowMul_zero_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + (modPow A X n ◁ (modPowZero A X).inv) ≫ modPowMul A X n 0 = + (ρ_ (modPow A X n)).hom ≫ + modPowCast A X (by omega : n = n + 0) := by + apply modPow_whiskerRight_hom_ext A X n (𝟙_ D) + have hc : powCast X (by omega : n = n + 0) = 𝟙 _ := rfl + have h2 : (tensorPow D X n ◁ modPowπ A X 0) ≫ + (modPowπ A X n ▷ modPow A X 0) ≫ modPowMul A X n 0 = + (modPowπ A X n ⊗ₘ modPowπ A X 0) ≫ modPowMul A X n 0 := by + rw [← Category.assoc, ← MonoidalCategory.tensorHom_def'] + have h0 : (tensorPowConcat X n 0).hom ≫ modPowπ A X (n + 0) = + (ρ_ (tensorPow D X n)).hom ≫ modPowπ A X (n + 0) := + congrArg (· ≫ modPowπ A X (n + 0)) + (congrArg Iso.hom (tensorPowConcat_zero X n)) + have hkey : (tensorPow D X n ◁ (modPowZero A X).inv) ≫ + (modPowπ A X n ▷ modPow A X 0) ≫ modPowMul A X n 0 = + (ρ_ (tensorPow D X n)).hom ≫ modPowπ A X (n + 0) := + h2.trans ((modPowπ_tensor_modPowMul A X n 0).trans h0) + conv_lhs => rw [← MonoidalCategory.whisker_exchange_assoc, hkey] + conv_rhs => rw [MonoidalCategory.rightUnitor_naturality_assoc, + modPowπ_cast, hc, Category.id_comp] + +end UnitLaws + +/-! ## Unit laws for the symmetric multiplication -/ + +section SymUnitLaws + +/-- The unit section of the empty symmetric power lifts to the +empty module power. -/ +theorem symPowZero_inv_symPowσ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] : + (symPowZero A X).inv ≫ symPowσ A X 0 = (modPowZero A X).inv := by + change ((modPowZero A X).inv ≫ symPowπ A X 0) ≫ symPowσ A X 0 = + (modPowZero A X).inv + rw [Category.assoc, symPowπ_symPowσ, symPowIdem_zero, + Category.comp_id] + +/-- **Left unit law**: multiplying by the empty symmetric power is +the left unitor, up to the arity transport. -/ +theorem symMul_zero_left + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (n : ℕ) : + ((symPowZero A X).inv ▷ symPow A X n) ≫ symMul A X 0 n = + (λ_ (symPow A X n)).hom ≫ + symPowCast A X (by omega : n = 0 + n) := by + apply symPow_whiskerLeft_hom_ext A X (𝟙_ D) n + have hA : (symPow A X 0 ◁ symPowπ A X n) ≫ symMul A X 0 n = + (symPowσ A X 0 ⊗ₘ symPowIdem A X n) ≫ modPowMul A X 0 n ≫ + symPowπ A X (0 + n) := by + rw [symMul, ← Category.assoc, ← MonoidalCategory.id_tensorHom, + tensorHom_comp_tensorHom, Category.id_comp, symPowπ_symPowσ] + have hsplit : (modPowZero A X).inv ⊗ₘ symPowIdem A X n = + ((modPowZero A X).inv ⊗ₘ 𝟙 (modPow A X n)) ≫ + (𝟙 (modPow A X 0) ⊗ₘ symPowIdem A X n) := by + rw [tensorHom_comp_tensorHom, Category.id_comp, Category.comp_id] + have hD : (𝟙 (modPow A X 0) ⊗ₘ symPowIdem A X n) ≫ + modPowMul A X 0 n = + modPowMul A X 0 n ≫ + modPowAlg A X (0 + n) (blockAlgEmbed 1 (symmetriser n)) := by + have h := modPowMul_alg A X 0 n 1 (symmetriser n) + rwa [map_one] at h + have hE : modPowAlg A X (0 + n) + (blockAlgEmbed 1 (symmetriser n)) ≫ symPowπ A X (0 + n) = + symPowπ A X (0 + n) := + modPowAlg_absorb A X _ + (by rw [blockAlgEmbed_one_left, symmetriser_mul_mapDomain]) + conv_lhs => rw [MonoidalCategory.whisker_exchange_assoc, hA, + ← Category.assoc, ← MonoidalCategory.tensorHom_id, + tensorHom_comp_tensorHom, Category.id_comp, + symPowZero_inv_symPowσ, hsplit, Category.assoc, + reassoc_of% hD, hE, MonoidalCategory.tensorHom_id, + reassoc_of% (modPowMul_zero_left A X n)] + conv_rhs => rw [MonoidalCategory.leftUnitor_naturality_assoc, + symPowπ_cast] + +end SymUnitLaws +/-! ## Associativity -/ + +section WhiskerConj + +/-- A doubly right-whiskered morphism, conjugated to a single +whisker. -/ +private theorem whiskerRight_whiskerRight_conj + [Category.{v} D] [MonoidalCategory D] + {P Q : D} + (f : P ⟶ Q) (Y Z : D) : + (f ▷ Y) ▷ Z = + (α_ P Y Z).hom ≫ (f ▷ (Y ⊗ Z)) ≫ (α_ Q Y Z).inv := by + rw [← MonoidalCategory.associator_naturality_left_assoc, + Iso.hom_inv_id, Category.comp_id] + +/-- A left-then-right whiskered morphism, conjugated to nested +whiskers. -/ +private theorem whiskerLeft_whiskerRight_conj + [Category.{v} D] [MonoidalCategory D] + (P : D) {Q R : D} + (g : Q ⟶ R) (Z : D) : + (P ◁ g) ▷ Z = + (α_ P Q Z).hom ≫ (P ◁ (g ▷ Z)) ≫ (α_ P R Z).inv := by + rw [← MonoidalCategory.associator_naturality_middle_assoc, + Iso.hom_inv_id, Category.comp_id] + +end WhiskerConj + +section AssocLaw + +instance [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (m n : ℕ) : Epi (modPowπ A X m ⊗ₘ modPowπ A X n) := by + rw [MonoidalCategory.tensorHom_def] + exact epi_comp _ _ + +instance [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (m n r : ℕ) : + Epi ((modPowπ A X m ⊗ₘ modPowπ A X n) ▷ tensorPow D X r) := by + rw [MonoidalCategory.tensorHom_def, + MonoidalCategory.comp_whiskerRight, + whiskerRight_whiskerRight_conj, whiskerLeft_whiskerRight_conj] + infer_instance + +/-- Morphisms out of a triple tensor product of module powers are +determined by their composites with the tensored projections. -/ +theorem modPowTriple_hom_ext + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (m n r : ℕ) {Z : D} + {k l : (modPow A X m ⊗ modPow A X n) ⊗ modPow A X r ⟶ Z} + (h : ((modPowπ A X m ⊗ₘ modPowπ A X n) ⊗ₘ modPowπ A X r) ≫ k = + ((modPowπ A X m ⊗ₘ modPowπ A X n) ⊗ₘ modPowπ A X r) ≫ l) : + k = l := by + apply modPow_whiskerLeft_hom_ext A X + (modPow A X m ⊗ modPow A X n) r + refine (cancel_epi + ((modPowπ A X m ⊗ₘ modPowπ A X n) ▷ tensorPow D X r)).mp ?_ + rw [← Category.assoc, ← Category.assoc, + ← MonoidalCategory.tensorHom_def] + simpa only [Category.assoc] using h + +/-- **Associativity of the raw multiplication**, up to the arity +transport of `m + (n + r) = m + n + r`. -/ +theorem modPowMul_assoc + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (m n r : ℕ) : + (modPowMul A X m n ▷ modPow A X r) ≫ modPowMul A X (m + n) r = + (α_ (modPow A X m) (modPow A X n) (modPow A X r)).hom ≫ + (modPow A X m ◁ modPowMul A X n r) ≫ + modPowMul A X m (n + r) ≫ + modPowCast A X (by omega : m + (n + r) = m + n + r) := by + apply modPowTriple_hom_ext A X m n r + have hsplit1 : ((tensorPowConcat X m n).hom ≫ modPowπ A X (m + n)) + ⊗ₘ modPowπ A X r = + ((tensorPowConcat X m n).hom ⊗ₘ 𝟙 (tensorPow D X r)) ≫ + (modPowπ A X (m + n) ⊗ₘ modPowπ A X r) := by + rw [tensorHom_comp_tensorHom, Category.id_comp] + have hsplit2 : modPowπ A X m ⊗ₘ + ((tensorPowConcat X n r).hom ≫ modPowπ A X (n + r)) = + (𝟙 (tensorPow D X m) ⊗ₘ (tensorPowConcat X n r).hom) ≫ + (modPowπ A X m ⊗ₘ modPowπ A X (n + r)) := by + rw [tensorHom_comp_tensorHom, Category.id_comp] + have hL : (((tensorPowConcat X m n).hom ≫ modPowπ A X (m + n)) + ⊗ₘ modPowπ A X r) ≫ modPowMul A X (m + n) r = + ((tensorPowConcat X m n).hom ▷ tensorPow D X r) ≫ + (tensorPowConcat X (m + n) r).hom ≫ + modPowπ A X (m + n + r) := by + rw [hsplit1, Category.assoc, modPowπ_tensor_modPowMul, + MonoidalCategory.tensorHom_id] + have hR : (modPowπ A X m ⊗ₘ + ((tensorPowConcat X n r).hom ≫ modPowπ A X (n + r))) ≫ + modPowMul A X m (n + r) = + (tensorPow D X m ◁ (tensorPowConcat X n r).hom) ≫ + (tensorPowConcat X m (n + r)).hom ≫ + modPowπ A X (m + (n + r)) := by + rw [hsplit2, Category.assoc, modPowπ_tensor_modPowMul, + MonoidalCategory.id_tensorHom] + conv_lhs => rw [← MonoidalCategory.tensorHom_id, + tensorHom_comp_tensorHom_assoc, Category.comp_id, + modPowπ_tensor_modPowMul, hL, + reassoc_of% (tensorPowConcat_assoc X m n r)] + conv_rhs => rw [MonoidalCategory.associator_naturality_assoc, + ← MonoidalCategory.id_tensorHom, tensorHom_comp_tensorHom_assoc, + Category.comp_id, modPowπ_tensor_modPowMul, + reassoc_of% hR, modPowπ_cast] + +end AssocLaw + +/-! ## Associativity of the symmetric multiplication -/ + +section SymAssocLaw + +/-- Morphisms out of a triple tensor product of symmetric powers +are determined by their composites with the tensored projections, +which are jointly split epi. -/ +theorem symPowTriple_hom_ext + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (m n r : ℕ) {Z : D} + {k l : (symPow A X m ⊗ symPow A X n) ⊗ symPow A X r ⟶ Z} + (h : ((symPowπ A X m ⊗ₘ symPowπ A X n) ⊗ₘ symPowπ A X r) ≫ k = + ((symPowπ A X m ⊗ₘ symPowπ A X n) ⊗ₘ symPowπ A X r) ≫ l) : + k = l := by + have hsec : ((symPowσ A X m ⊗ₘ symPowσ A X n) ⊗ₘ symPowσ A X r) ≫ + ((symPowπ A X m ⊗ₘ symPowπ A X n) ⊗ₘ symPowπ A X r) = + 𝟙 _ := by + simp only [tensorHom_comp_tensorHom, symPowσ_symPowπ, + MonoidalCategory.tensorHom_id, + MonoidalCategory.id_whiskerRight] + calc k = (((symPowσ A X m ⊗ₘ symPowσ A X n) ⊗ₘ symPowσ A X r) ≫ + ((symPowπ A X m ⊗ₘ symPowπ A X n) ⊗ₘ symPowπ A X r)) ≫ k := by + rw [hsec, Category.id_comp] + _ = (((symPowσ A X m ⊗ₘ symPowσ A X n) ⊗ₘ symPowσ A X r) ≫ + ((symPowπ A X m ⊗ₘ symPowπ A X n) ⊗ₘ symPowπ A X r)) ≫ l := by + rw [Category.assoc, Category.assoc, h] + _ = l := by rw [hsec, Category.id_comp] + +/-- **Associativity of the symmetric multiplication**, up to the +arity transport of `m + (n + r) = m + n + r`. -/ +theorem symMul_assoc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (m n r : ℕ) : + (symMul A X m n ▷ symPow A X r) ≫ symMul A X (m + n) r = + (α_ (symPow A X m) (symPow A X n) (symPow A X r)).hom ≫ + (symPow A X m ◁ symMul A X n r) ≫ + symMul A X m (n + r) ≫ + symPowCast A X (by omega : m + (n + r) = m + n + r) := by + apply symPowTriple_hom_ext A X m n r + have hsplit1 : (modPowMul A X m n ≫ symPowπ A X (m + n)) ⊗ₘ + symPowπ A X r = + (modPowMul A X m n ⊗ₘ 𝟙 (modPow A X r)) ≫ + (symPowπ A X (m + n) ⊗ₘ symPowπ A X r) := by + rw [tensorHom_comp_tensorHom, Category.id_comp] + have hsplit2 : symPowπ A X m ⊗ₘ + (modPowMul A X n r ≫ symPowπ A X (n + r)) = + (𝟙 (modPow A X m) ⊗ₘ modPowMul A X n r) ≫ + (symPowπ A X m ⊗ₘ symPowπ A X (n + r)) := by + rw [tensorHom_comp_tensorHom, Category.id_comp] + have hL : ((modPowMul A X m n ≫ symPowπ A X (m + n)) ⊗ₘ + symPowπ A X r) ≫ symMul A X (m + n) r = + (modPowMul A X m n ▷ modPow A X r) ≫ + modPowMul A X (m + n) r ≫ symPowπ A X (m + n + r) := by + rw [hsplit1, Category.assoc, symPowπ_tensor_symMul, + MonoidalCategory.tensorHom_id] + have hR : (symPowπ A X m ⊗ₘ + (modPowMul A X n r ≫ symPowπ A X (n + r))) ≫ + symMul A X m (n + r) = + (modPow A X m ◁ modPowMul A X n r) ≫ + modPowMul A X m (n + r) ≫ symPowπ A X (m + (n + r)) := by + rw [hsplit2, Category.assoc, symPowπ_tensor_symMul, + MonoidalCategory.id_tensorHom] + conv_lhs => rw [← MonoidalCategory.tensorHom_id, + tensorHom_comp_tensorHom_assoc, Category.comp_id, + symPowπ_tensor_symMul, hL, + reassoc_of% (modPowMul_assoc A X m n r)] + conv_rhs => rw [MonoidalCategory.associator_naturality_assoc, + ← MonoidalCategory.id_tensorHom, tensorHom_comp_tensorHom_assoc, + Category.comp_id, symPowπ_tensor_symMul, + reassoc_of% hR, symPowπ_cast] + +end SymAssocLaw + +/-! ## Commutativity + +The braiding of two tensor powers is, through the concatenations, a +permutation action; commutativity of `symMul` then follows because +the symmetriser absorbs every permutation. The permutation itself +is never computed: each intertwining is established with an +existentially quantified permutation, assembled by the same +recursion as the concatenation. -/ + +section CommPerm + +/-- **The peeled braiding of one factor with a power acts by a +permutation**, assembled by the recursion of the power itself. -/ +theorem braiding_one_pow_exists + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) : + ∀ n : ℕ, + ∃ τ : Equiv.Perm (Fin (n + 1)), + (powPeel X n).hom ≫ (β_ X (tensorPow D X n)).hom = + permMor X (n + 1) τ + | 0 => ⟨1, by + rw [powPeel_zero, permMor_one] + change ((λ_ X).hom ≫ (ρ_ X).inv) ≫ (β_ X (𝟙_ D)).hom = + 𝟙 (𝟙_ D ⊗ X) + rw [braiding_tensorUnit_right, Category.assoc, + Iso.inv_hom_id_assoc, Iso.hom_inv_id]⟩ + | n + 1 => by + obtain ⟨τ, hn⟩ := braiding_one_pow_exists X n + refine ⟨topSwap * extPerm τ, ?_⟩ + have hstep1 : (powPeel X (n + 1)).hom ≫ + (β_ X (tensorPow D X (n + 1))).hom = + (((powPeel X n).hom ▷ X) ≫ + (α_ X (tensorPow D X n) X).hom) ≫ + (β_ X (tensorPow D X n ⊗ X)).hom := rfl + rw [hstep1, Category.assoc, + BraidedCategory.braiding_tensor_right_hom, + Iso.hom_inv_id_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc] + have s1 : (((powPeel X n).hom ≫ + (β_ X (tensorPow D X n)).hom) ▷ X) ≫ + (α_ (tensorPow D X n) X X).hom ≫ + (tensorPow D X n ◁ (β_ X X).hom) ≫ + (α_ (tensorPow D X n) X X).inv = + (permMor X (n + 1) τ ▷ X) ≫ swapTop X n := by + rw [hn]; rfl + have s2 : (permMor X (n + 1) τ ▷ X) ≫ swapTop X n = + permMor X (n + 2) (topSwap * extPerm τ) := by + rw [permMor_mul, permMor_extPerm, permMor_topSwap_eq] + rfl + exact s1.trans s2 + +end CommPerm + +/-- The hexagon step of the braiding–concatenation intertwining, at +general objects. -/ +private theorem comm_step_aux + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) + {Pm Pn Q : D} (c : Pn ⊗ Pm ⟶ Q) + {w : Pm ⊗ Pn ⟶ Q} (hIH : (β_ Pm Pn).hom ≫ c = w) : + (β_ (Pm ⊗ X) Pn).hom ≫ (α_ Pn Pm X).inv ≫ (c ▷ X) = + (α_ Pm X Pn).hom ≫ (Pm ◁ (β_ X Pn).hom) ≫ + (α_ Pm Pn X).inv ≫ (w ▷ X) := by + rw [BraidedCategory.braiding_tensor_left_hom] + simp only [Category.assoc, Iso.hom_inv_id_assoc] + rw [← MonoidalCategory.comp_whiskerRight, hIH] + +section CommMain + +/-- The head of the commutation step: attaching the peeled factor +to the first block. -/ +private theorem comm_head [Category.{v} D] [MonoidalCategory D] (X : D) + (m n : ℕ) : + (α_ (tensorPow D X m) X (tensorPow D X n)).hom ≫ + (tensorPow D X m ◁ (powPeel X n).inv) ≫ + (tensorPowConcat X m (n + 1)).hom = + (tensorPowConcat X (m + 1) n).hom ≫ + powCast X (by omega : m + 1 + n = m + (n + 1)) := by + have hcanc : (α_ (tensorPow D X m) X (tensorPow D X n)).hom ≫ + powAttach X m n = 𝟙 _ := Iso.hom_inv_id _ + rw [tensorPowConcat_peel X m n, + ← MonoidalCategory.whiskerLeft_comp_assoc, Iso.inv_hom_id, + MonoidalCategory.whiskerLeft_id, Category.id_comp, + reassoc_of% hcanc] + exact Category.id_comp _ + +/-- The whiskered braiding expands through the peel. -/ +private theorem comm_beta_expand + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) + (m n : ℕ) : + (tensorPow D X m ◁ (powPeel X n).inv) ≫ + (tensorPow D X m ◁ + ((powPeel X n).hom ≫ (β_ X (tensorPow D X n)).hom)) = + tensorPow D X m ◁ (β_ X (tensorPow D X n)).hom := by + rw [← MonoidalCategory.whiskerLeft_comp, Iso.inv_hom_id_assoc] + +/-- **The braiding of tensor powers is a permutation across the +concatenations**: for some permutation `σ` of the slots. -/ +theorem tensorPowConcat_braiding_exists + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (X : D) + (n : ℕ) : ∀ m : ℕ, + ∃ σ : Equiv.Perm (Fin (n + m)), + (β_ (tensorPow D X m) (tensorPow D X n)).hom ≫ + (tensorPowConcat X n m).hom = + (tensorPowConcat X m n).hom ≫ + powCast X (by omega : m + n = n + m) ≫ + permMor X (n + m) σ + | 0 => ⟨1, by + rw [permMor_one, Category.comp_id, tensorPowConcat_zero, + tensorPowConcat_zero_left] + change (β_ (𝟙_ D) (tensorPow D X n)).hom ≫ + (ρ_ (tensorPow D X n)).hom = + ((λ_ (tensorPow D X n)).hom ≫ + powCast X (by omega : n = 0 + n)) ≫ + powCast X (by omega : 0 + n = n + 0) + have hc : powCast X (by omega : n = n + 0) = 𝟙 _ := rfl + rw [Category.assoc, powCast_comp, hc, Category.comp_id, + braiding_tensorUnit_left, Category.assoc, Iso.inv_hom_id, + Category.comp_id]⟩ + | m + 1 => by + obtain ⟨σ, hm⟩ := tensorPowConcat_braiding_exists X n m + obtain ⟨τ, hτ⟩ := braiding_one_pow_exists X n + refine ⟨extPerm σ * + (finCongr (by omega : m + (n + 1) = n + (m + 1))).permCongr + (blockEmbed 1 τ), ?_⟩ + have g1 : (β_ (tensorPow D X (m + 1)) (tensorPow D X n)).hom ≫ + (tensorPowConcat X n (m + 1)).hom = + (β_ (tensorPow D X m ⊗ X) (tensorPow D X n)).hom ≫ + (α_ (tensorPow D X n) (tensorPow D X m) X).inv ≫ + ((tensorPowConcat X n m).hom ▷ X) := rfl + have g2 := comm_step_aux X ((tensorPowConcat X n m).hom) hm + have g4 : (α_ (tensorPow D X m) (tensorPow D X n) X).inv ≫ + ((tensorPowConcat X m n).hom ▷ X) = + (tensorPowConcat X m (n + 1)).hom := rfl + have e3a : (α_ (tensorPow D X m) X (tensorPow D X n)).hom ≫ + (tensorPow D X m ◁ (β_ X (tensorPow D X n)).hom) ≫ + (α_ (tensorPow D X m) (tensorPow D X n) X).inv ≫ + (((tensorPowConcat X m n).hom ≫ + powCast X (by omega : m + n = n + m) ≫ + permMor X (n + m) σ) ▷ X) = + (α_ (tensorPow D X m) X (tensorPow D X n)).hom ≫ + (tensorPow D X m ◁ (powPeel X n).inv) ≫ + ((tensorPow D X m ◁ permMor X (n + 1) τ) ≫ + (tensorPowConcat X m (n + 1)).hom) ≫ + ((powCast X (by omega : m + n = n + m) ≫ + permMor X (n + m) σ) ▷ X) := by + conv_lhs => rw [MonoidalCategory.comp_whiskerRight, + reassoc_of% g4, ← comm_beta_expand X m n, hτ] + repeat' erw [Category.assoc] + rfl + have hw : ((powCast X (by omega : m + n = n + m) ≫ + permMor X (n + m) σ) ▷ X) = + powCast X (by omega : m + n + 1 = n + m + 1) ≫ + permMor X (n + m + 1) (extPerm σ) := by + rw [MonoidalCategory.comp_whiskerRight, powCast_whiskerRight, + ← permMor_extPerm] + rfl + have hcp := reassoc_of% (powCast_permMor X + (by omega : m + (n + 1) = n + (m + 1)) (blockEmbed 1 τ)) + have hfinal : ((tensorPowConcat X (m + 1) n).hom ≫ + powCast X (by omega : m + 1 + n = m + (n + 1))) ≫ + permMor X (m + (n + 1)) (blockEmbed 1 τ) ≫ + powCast X (by omega : m + n + 1 = n + m + 1) ≫ + permMor X (n + m + 1) (extPerm σ) = + (tensorPowConcat X (m + 1) n).hom ≫ + powCast X (by omega : m + 1 + n = n + (m + 1)) ≫ + permMor X (n + (m + 1)) + (extPerm σ * + (finCongr + (by omega : m + (n + 1) = n + (m + 1))).permCongr + (blockEmbed 1 τ)) := by + have hb1 : (powCast X (by omega : m + n + 1 = n + m + 1) : + tensorPow D X (m + (n + 1)) ⟶ + tensorPow D X (n + (m + 1))) = + powCast X (by omega : m + (n + 1) = n + (m + 1)) := rfl + have hb2 : (permMor X (n + m + 1) (extPerm σ) : + tensorPow D X (n + (m + 1)) ⟶ + tensorPow D X (n + (m + 1))) = + permMor X (n + (m + 1)) (extPerm σ) := rfl + rw [Category.assoc, hb1, hb2, ← hcp, powCast_comp_assoc, + ← permMor_mul] + have e3b : (α_ (tensorPow D X m) X (tensorPow D X n)).hom ≫ + (tensorPow D X m ◁ (powPeel X n).inv) ≫ + ((tensorPow D X m ◁ permMor X (n + 1) τ) ≫ + (tensorPowConcat X m (n + 1)).hom) ≫ + ((powCast X (by omega : m + n = n + m) ≫ + permMor X (n + m) σ) ▷ X) = + (tensorPowConcat X (m + 1) n).hom ≫ + powCast X (by omega : m + 1 + n = n + (m + 1)) ≫ + permMor X (n + (m + 1)) + (extPerm σ * + (finCongr + (by omega : m + (n + 1) = n + (m + 1))).permCongr + (blockEmbed 1 τ)) := by + rw [(tensorPowConcat_permMor_snd X m (n + 1) τ).symm] + erw [hw] + change (α_ (tensorPow D X m) X (tensorPow D X n)).hom ≫ + (tensorPow D X m ◁ (powPeel X n).inv) ≫ + ((tensorPowConcat X m (n + 1)).hom ≫ + permMor X (m + (n + 1)) (blockEmbed 1 τ)) ≫ + powCast X (by omega : m + (n + 1) = n + (m + 1)) ≫ + permMor X (n + (m + 1)) (extPerm σ) = _ + simp only [Category.assoc] + rw [reassoc_of% (comm_head X m n)] + exact hfinal + exact g1.trans (g2.trans (e3a.trans e3b)) + +end CommMain + +/-! ## Commutativity of the symmetric multiplication -/ + +section SymCommLaw + +/-- Every permutation action on the ambient power is absorbed by +the two projections: the symmetriser eats it. -/ +theorem permMor_π_absorb + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] + (N : ℕ) (τ : Equiv.Perm (Fin N)) : + permMor X N τ ≫ modPowπ A X N ≫ symPowπ A X N = + modPowπ A X N ≫ symPowπ A X N := by + have h1 : modPowPerm (A := A) (X := X) N τ ≫ symPowπ A X N = + symPowπ A X N := by + have h2 := modPowAlg_absorb A X (MonoidAlgebra.single τ (1 : ℂ)) + (symmetriser_mul_single N τ) + rwa [modPowAlg_single] at h2 + rw [← modPowπ_perm_assoc, h1] + +/-- **Commutativity of the symmetric multiplication**, up to the +arity transport of `m + n = n + m`. -/ +theorem symMul_comm + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (X : D) [ModObj A X] [Preadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [MonoidalPreadditive D] [Linear ℂ D] + [MonoidalLinear ℂ D] + [∀ Y : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Y)] + (m n : ℕ) : + (β_ (symPow A X m) (symPow A X n)).hom ≫ symMul A X n m = + symMul A X m n ≫ + symPowCast A X (by omega : m + n = n + m) := by + obtain ⟨σ, hσ⟩ := tensorPowConcat_braiding_exists X n m + apply symPowTensor_hom_ext A X m n + conv_lhs => rw [← Category.assoc, + BraidedCategory.braiding_naturality, Category.assoc, + symPowπ_tensor_symMul] + conv_rhs => rw [← Category.assoc, symPowπ_tensor_symMul, + Category.assoc, symPowπ_cast] + apply modPowTensor_hom_ext A X m n + conv_lhs => rw [← Category.assoc, + BraidedCategory.braiding_naturality, Category.assoc, + modPowπ_tensor_modPowMul_assoc] + conv_rhs => rw [modPowπ_tensor_modPowMul_assoc, modPowπ_cast_assoc] + rw [reassoc_of% hσ, permMor_π_absorb] + +end SymCommLaw + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorDatum.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorDatum.lean new file mode 100644 index 0000000000..b5f8ab3373 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorDatum.lean @@ -0,0 +1,237 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.InterchangeAct + +/-! +# The tensor product of duality data + +Deligne's 1.15 tensor part: dual pairs tensor. The pairing of +the tensor datum crosses the middle factors through the descended +interchange and pairs coordinatewise into the regular module; the +copairing unfolds the unit and inserts both copairings. The +descended interchange exists because the interchange is linear in +both factors. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +section InterchangeDesc + +/-- **The descended interchange**: the interchange of module +tensor products descends to the relative tensor of the bundles, +because it is linear in both factors. -/ +noncomputable def interchangeDesc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X₁ : Mod D A) (X₂ : Mod D A) + (Y₁ : Mod D A) (Y₂ : Mod D A) : + modTensor A (modTensorMod A X₁ X₂) (modTensorMod A Y₁ Y₂) ⟶ + modTensor A (modTensorMod A X₁ Y₁) (modTensorMod A X₂ Y₂) := + modTensorDesc A (modTensorMod A X₁ X₂) (modTensorMod A Y₁ Y₂) + (interchange A X₁ X₂ Y₁ Y₂) + (by + rw [modTensorLegM, modTensorLegN, actRight] + change ((β_ (modTensor A X₁ X₂) A).hom ≫ + modTensorAct A X₁ X₂) ▷ modTensor A Y₁ Y₂ ≫ + interchange A X₁ X₂ Y₁ Y₂ = + ((α_ (modTensor A X₁ X₂) A (modTensor A Y₁ Y₂)).hom ≫ + modTensor A X₁ X₂ ◁ modTensorAct A Y₁ Y₂) ≫ + interchange A X₁ X₂ Y₁ Y₂ + rw [comp_whiskerRight, Category.assoc, + interchange_actLeft A X₁ X₂ Y₁ Y₂, Category.assoc, + interchange_actMid A X₁ X₂ Y₁ Y₂, + Iso.hom_inv_id_assoc]) + +/-- Defining equation of the descended interchange. -/ +@[reassoc (attr := simp)] +theorem modTensorπ_interchangeDesc + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X₁ : Mod D A) (X₂ : Mod D A) + (Y₁ : Mod D A) (Y₂ : Mod D A) : + modTensorπ A (modTensorMod A X₁ X₂) (modTensorMod A Y₁ Y₂) ≫ + interchangeDesc A X₁ X₂ Y₁ Y₂ = + interchange A X₁ X₂ Y₁ Y₂ := + modTensorπ_desc A _ _ _ _ + +/-- The descended interchange intertwines the actions. -/ +@[reassoc] +theorem interchangeDesc_act + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (X₁ : Mod D A) (X₂ : Mod D A) + (Y₁ : Mod D A) (Y₂ : Mod D A) : + modTensorAct A (modTensorMod A X₁ X₂) (modTensorMod A Y₁ Y₂) ≫ + interchangeDesc A X₁ X₂ Y₁ Y₂ = + (A ◁ interchangeDesc A X₁ X₂ Y₁ Y₂) ≫ + modTensorAct A (modTensorMod A X₁ Y₁) + (modTensorMod A X₂ Y₂) := by + apply modTensor_whisker_hom_ext A (modTensorMod A X₁ X₂) + (modTensorMod A Y₁ Y₂) A + conv_lhs => rw [whiskerLeft_modTensorπ_act_assoc, + modTensorπ_interchangeDesc] + conv_rhs => rw [← MonoidalCategory.whiskerLeft_comp_assoc, + modTensorπ_interchangeDesc] + change (α_ A (modTensor A X₁ X₂) (modTensor A Y₁ Y₂)).inv ≫ + (modTensorAct A X₁ X₂ ▷ modTensor A Y₁ Y₂) ≫ + interchange A X₁ X₂ Y₁ Y₂ = + (A ◁ interchange A X₁ X₂ Y₁ Y₂) ≫ + modTensorAct A (modTensorMod A X₁ Y₁) + (modTensorMod A X₂ Y₂) + rw [interchange_actLeft A X₁ X₂ Y₁ Y₂, + Iso.inv_hom_id_assoc] + +end InterchangeDesc + +section Datum + +/-- The fold of the doubled regular module onto the base. -/ +noncomputable def regPairFold + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] : + modTensor A (regularMod A) (regularMod A) ⟶ A := + (modTensorUnitLeft A (regularMod A)).hom + +/-- **The tensor pairing**: cross through the descended +interchange, pair coordinatewise, and fold. -/ +noncomputable def tensorPair + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {N₁ : Mod D A} {N₂ : Mod D A} + {N₁' : Mod D A} {N₂' : Mod D A} + (d₁ : ModDualityDatum A N₁ N₁') + (d₂ : ModDualityDatum A N₂ N₂') : + modTensor A (modTensorMod A N₁' N₂') (modTensorMod A N₁ N₂) + ⟶ A := + interchangeDesc A N₁' N₂' N₁ N₂ ≫ + modTensorMap A d₁.pairMod d₂.pairMod ≫ regPairFold A + +/-- The unfolding of the base into the doubled regular module. -/ +noncomputable def regPairUnfold + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] : + A ⟶ modTensor A (regularMod A) (regularMod A) := + (modTensorUnitLeft A (regularMod A)).inv + +/-- **The tensor copairing**: unfold the unit, insert both +copairings, and regroup through the descended interchange. -/ +noncomputable def tensorCopair + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {N₁ : Mod D A} {N₂ : Mod D A} + {N₁' : Mod D A} {N₂' : Mod D A} + (d₁ : ModDualityDatum A N₁ N₁') + (d₂ : ModDualityDatum A N₂ N₂') : + A ⟶ modTensor A (modTensorMod A N₁ N₂) + (modTensorMod A N₁' N₂') := + regPairUnfold A ≫ + modTensorMap A d₁.copairMod d₂.copairMod ≫ + interchangeDesc A N₁ N₁' N₂ N₂' + +/-- The inverse of the doubled-unit fold intertwines the +multiplication and the action. -/ +theorem regPairUnfold_act + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] : + μ[A] ≫ regPairUnfold A = + (A ◁ regPairUnfold A) ≫ + modTensorAct A (regularMod A) (regularMod A) := by + rw [regPairUnfold, Iso.comp_inv_eq, Category.assoc, + modTensorUnitLeft_hom_actLeft, ← Category.assoc, + ← MonoidalCategory.whiskerLeft_comp, Iso.inv_hom_id, + MonoidalCategory.whiskerLeft_id, Category.id_comp] + rfl + +/-- **The tensor pairing is linear.** -/ +theorem tensorPair_linear + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {N₁ : Mod D A} {N₂ : Mod D A} + {N₁' : Mod D A} {N₂' : Mod D A} + (d₁ : ModDualityDatum A N₁ N₁') + (d₂ : ModDualityDatum A N₂ N₂') : + modTensorAct A (modTensorMod A N₁' N₂') + (modTensorMod A N₁ N₂) ≫ tensorPair A d₁ d₂ = + (A ◁ tensorPair A d₁ d₂) ≫ μ[A] := by + rw [tensorPair, ← Category.assoc, interchangeDesc_act, + Category.assoc, + reassoc_of% (modTensorAct_map A d₁.pairMod d₂.pairMod), + regPairFold, modTensorUnitLeft_hom_actLeft, + ← MonoidalCategory.whiskerLeft_comp_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + Category.assoc] + rfl + +/-- **The tensor copairing is linear.** -/ +theorem tensorCopair_linear + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {N₁ : Mod D A} {N₂ : Mod D A} + {N₁' : Mod D A} {N₂' : Mod D A} + (d₁ : ModDualityDatum A N₁ N₁') + (d₂ : ModDualityDatum A N₂ N₂') : + μ[A] ≫ tensorCopair A d₁ d₂ = + (A ◁ tensorCopair A d₁ d₂) ≫ + modTensorAct A (modTensorMod A N₁ N₂) + (modTensorMod A N₁' N₂') := by + rw [tensorCopair, ← Category.assoc, regPairUnfold_act, + Category.assoc, + reassoc_of% (modTensorAct_map A d₁.copairMod d₂.copairMod), + interchangeDesc_act, + ← MonoidalCategory.whiskerLeft_comp_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + Category.assoc] + +/-- **The tensor product of duality data** (Deligne 1.15, tensor +part): dual pairs tensor, with the crossed coordinatewise pairing +and copairing. -/ +noncomputable def tensorDatum + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {N₁ : Mod D A} {N₂ : Mod D A} + {N₁' : Mod D A} {N₂' : Mod D A} + (d₁ : ModDualityDatum A N₁ N₁') + (d₂ : ModDualityDatum A N₂ N₂') : + ModDualityDatum A (modTensorMod A N₁ N₂) + (modTensorMod A N₁' N₂') where + pair := tensorPair A d₁ d₂ + copair := tensorCopair A d₁ d₂ + pair_linear := tensorPair_linear A d₁ d₂ + copair_linear := tensorCopair_linear A d₁ d₂ + +end Datum + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorExact.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorExact.lean new file mode 100644 index 0000000000..614297cdd6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorExact.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Definitions + +/-! +# Tensoring is exact in a rigid abelian category + +Deligne's 1.14 (Catégories tensorielles): in a rigid category the +functor `− ⊗ X` has `− ⊗ Xᘁ` as a two-sided adjoint, so over an +abelian base it preserves all finite limits and colimits — it is +exact. The consequences collected here: tensoring preserves +monomorphisms, epimorphisms, and +zero objects, and a tensor power of a nonzero object detects +nothing (`X ^ ⊗ n = 0` forces `X = 0`, Deligne 1.17). +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {A : Type u} + +/-- Right tensoring preserves all colimits: `− ⊗ X` is a left +adjoint (Frobenius reciprocity, with adjoint `− ⊗ Xᘁ`). -/ +noncomputable instance tensorRight_preservesColimits + [Category.{v} A] [MonoidalCategory A] [RigidCategory A] + (X : A) : + PreservesColimitsOfSize.{v, v} (tensorRight X) := + (tensorRightAdjunction X (Xᘁ)).leftAdjoint_preservesColimits + +/-- Right tensoring preserves all limits: `− ⊗ X` is a right +adjoint (with adjoint `− ⊗ ᘁX`). -/ +noncomputable instance tensorRight_preservesLimits + [Category.{v} A] [MonoidalCategory A] [RigidCategory A] + (X : A) : + PreservesLimitsOfSize.{v, v} (tensorRight X) := + (tensorRightAdjunction (ᘁX) X).rightAdjoint_preservesLimits + +/-- Left tensoring preserves all colimits. -/ +noncomputable instance tensorLeft_preservesColimits + [Category.{v} A] [MonoidalCategory A] [RigidCategory A] + (X : A) : + PreservesColimitsOfSize.{v, v} (tensorLeft X) := + (tensorLeftAdjunction (ᘁX) X).leftAdjoint_preservesColimits + +/-- Left tensoring preserves all limits. -/ +noncomputable instance tensorLeft_preservesLimits + [Category.{v} A] [MonoidalCategory A] [RigidCategory A] + (X : A) : + PreservesLimitsOfSize.{v, v} (tensorLeft X) := + (tensorLeftAdjunction X (Xᘁ)).rightAdjoint_preservesLimits + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorMuBraid.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorMuBraid.lean new file mode 100644 index 0000000000..05bd298092 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorMuBraid.lean @@ -0,0 +1,133 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# The interchange `tensorμ` intertwines the braidings + +In a symmetric monoidal category the interchange morphism +`tensorμ a b c d : (a ⊗ b) ⊗ (c ⊗ d) ⟶ (a ⊗ c) ⊗ (b ⊗ d)` makes the +tensor product a braided functor: braiding the two tensor pairs and +then interchanging agrees with interchanging and then braiding +slotwise. Mathlib records only the diagonal special case +`SymmetricCategory.tensorμ_braid_swap`; this file proves the general +four-object statement. + +The proof decomposes the block braiding `β_ (a ⊗ b) (c ⊗ d)` into the +four elementary crossings `β_ b c`, `β_ b d`, `β_ a c`, `β_ a d` via +the hexagon identities; the crossing `β_ d a` supplied by +`tensorμ c d a b` then cancels `β_ a d` by the symmetry axiom, and one +exchange of the disjoint crossings `β_ a c` and `β_ b d` produces the +right-hand side. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +variable {D : Type u} + +/-- In a symmetric category the interchange `tensorμ` makes the tensor +product a braided functor: braiding the tensor pairs and then +interchanging equals interchanging and then braiding slotwise. -/ +@[reassoc] +theorem tensorμ_braiding + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (a b c d : D) : + (β_ (a ⊗ b) (c ⊗ d)).hom ≫ tensorμ c d a b = + tensorμ a b c d ≫ ((β_ a c).hom ⊗ₘ (β_ b d).hom) := by + calc + (β_ (a ⊗ b) (c ⊗ d)).hom ≫ tensorμ c d a b + = 𝟙 _ ⊗≫ a ◁ (β_ b c).hom ▷ d ⊗≫ + ((a ⊗ c) ◁ (β_ b d).hom ≫ (β_ a c).hom ▷ (d ⊗ b)) ⊗≫ + c ◁ ((β_ a d).hom ≫ (β_ d a).hom) ▷ b ⊗≫ 𝟙 _ := by + dsimp only [tensorμ] + rw [BraidedCategory.braiding_tensor_left_hom a b (c ⊗ d), + BraidedCategory.braiding_tensor_right_hom b c d, + BraidedCategory.braiding_tensor_right_hom a c d] + monoidal + _ = 𝟙 _ ⊗≫ a ◁ (β_ b c).hom ▷ d ⊗≫ + ((β_ a c).hom ▷ (b ⊗ d) ≫ (c ⊗ a) ◁ (β_ b d).hom) ⊗≫ + 𝟙 _ := by + rw [SymmetricCategory.symmetry, + whisker_exchange (β_ a c).hom (β_ b d).hom] + monoidal + _ = tensorμ a b c d ≫ ((β_ a c).hom ⊗ₘ (β_ b d).hom) := by + dsimp only [tensorμ] + rw [tensorHom_def] + monoidal + +/-- Slide an evaluation cap through a crossing: braiding `P` across +`Q` and then capping `P` against `X` equals braiding `Q` across `X` +and capping on the far side. Uses the hexagon, naturality of the +braiding against the cap, and the symmetry axiom. -/ +private lemma braiding_evaluation_slide + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (P Q X : D) [ExactPairing X P] : + (β_ P Q).hom ▷ X ⊗≫ Q ◁ ε_ X P ⊗≫ 𝟙 Q = + 𝟙 ((P ⊗ Q) ⊗ X) ⊗≫ P ◁ (β_ Q X).hom ⊗≫ ε_ X P ▷ Q ⊗≫ 𝟙 Q := by + calc + (β_ P Q).hom ▷ X ⊗≫ Q ◁ ε_ X P ⊗≫ 𝟙 Q + = 𝟙 _ ⊗≫ P ◁ ((β_ Q X).hom ≫ (β_ X Q).hom) ⊗≫ + (β_ P Q).hom ▷ X ⊗≫ Q ◁ ε_ X P ⊗≫ 𝟙 Q := by + rw [SymmetricCategory.symmetry Q X] + monoidal + _ = 𝟙 _ ⊗≫ P ◁ (β_ Q X).hom ⊗≫ + ((β_ (P ⊗ X) Q).hom ≫ Q ◁ ε_ X P) ⊗≫ 𝟙 Q := by + rw [BraidedCategory.braiding_tensor_left_hom P X Q] + monoidal + _ = 𝟙 _ ⊗≫ P ◁ (β_ Q X).hom ⊗≫ + (ε_ X P ▷ Q ≫ (β_ (𝟙_ D) Q).hom) ⊗≫ 𝟙 Q := by + rw [BraidedCategory.braiding_naturality_left (ε_ X P) Q] + _ = 𝟙 ((P ⊗ Q) ⊗ X) ⊗≫ P ◁ (β_ Q X).hom ⊗≫ ε_ X P ▷ Q ⊗≫ 𝟙 Q := by + rw [braiding_tensorUnit_left] + monoidal + +/-- The tensor evaluation of `ExactPairing.tensor` is compatible with +the braidings: crossing the two dual pairs converts the arc nesting of +the double evaluation, inner `(Q, Y)`/outer `(P, X)` against inner +`(P, X)`/outer `(Q, Y)`. -/ +@[reassoc] +theorem tensor_evaluation_braiding + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (X Y P Q : D) + [ExactPairing X P] [ExactPairing Y Q] : + ε_ (Y ⊗ X) (P ⊗ Q) = + ((β_ P Q).hom ▷ (Y ⊗ X)) ≫ + ((Q ⊗ P) ◁ (β_ Y X).hom) ≫ ε_ (X ⊗ Y) (Q ⊗ P) := by + symm + calc + ((β_ P Q).hom ▷ (Y ⊗ X)) ≫ + ((Q ⊗ P) ◁ (β_ Y X).hom) ≫ ε_ (X ⊗ Y) (Q ⊗ P) + = 𝟙 _ ⊗≫ (P ⊗ Q) ◁ (β_ Y X).hom ⊗≫ + ((β_ P Q).hom ▷ X ⊗≫ Q ◁ ε_ X P ⊗≫ 𝟙 Q) ▷ Y ⊗≫ ε_ Y Q := by + rw [ExactPairing.tensor_evaluation, ← whisker_exchange_assoc] + monoidal + _ = 𝟙 _ ⊗≫ P ◁ (β_ (Q ⊗ Y) X).hom ⊗≫ + ε_ X P ▷ (Q ⊗ Y) ⊗≫ ε_ Y Q := by + rw [braiding_evaluation_slide, + BraidedCategory.braiding_tensor_left_hom Q Y X] + monoidal + _ = 𝟙 _ ⊗≫ P ◁ (β_ (Q ⊗ Y) X).hom ⊗≫ + ((P ⊗ X) ◁ ε_ Y Q ≫ ε_ X P ▷ 𝟙_ D) ⊗≫ 𝟙 _ := by + rw [whisker_exchange (ε_ X P) (ε_ Y Q)] + monoidal + _ = 𝟙 _ ⊗≫ P ◁ (ε_ Y Q ▷ X ≫ (β_ (𝟙_ D) X).hom) ⊗≫ + ε_ X P ⊗≫ 𝟙 _ := by + rw [BraidedCategory.braiding_naturality_left (ε_ Y Q) X] + monoidal + _ = ε_ (Y ⊗ X) (P ⊗ Q) := by + rw [ExactPairing.tensor_evaluation, braiding_tensorUnit_left] + monoidal + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorPowZero.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorPowZero.lean new file mode 100644 index 0000000000..8466aa4e70 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorPowZero.lean @@ -0,0 +1,98 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive +public import LeanPool.RegtsSevenster.RS.Definitions + +/-! +# A vanishing tensor power forces a vanishing object + +Deligne's 1.17 (Catégories tensorielles, 2002): in a symmetric +monoidal preadditive category, an object `X` with a right dual +whose `n`-th tensor power vanishes for some `n ≠ 0` vanishes +itself. + +The descent step is `isZero_tensorPow_pred`: a vanishing +`(n + 2)`-nd power forces a vanishing `(n + 1)`-st power. Writing +the `(n + 1)`-st power as `P ⊗ X`, the triangle identity for the +exact pairing `(X, Xᘁ)`, whiskered on the left by `P`, factors the +identity of `P ⊗ X` through `P ⊗ ((X ⊗ Xᘁ) ⊗ X)`; associators and +one braiding identify that object with the `(n + 2)`-nd power +tensored with `Xᘁ`, which is zero because tensoring preserves zero +objects over a preadditive monoidal structure. Downward induction +and the left unitor then give the theorem. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {A : Type u} + +/-- The descent step at a general left factor: if `(P ⊗ X) ⊗ X` +vanishes, so does `P ⊗ X`. The identity of `P ⊗ X` factors +through `P ⊗ ((X ⊗ Xᘁ) ⊗ X)` by the triangle identity for the +pairing `(X, Xᘁ)` whiskered by `P`, and that object is zero, +being isomorphic to `((P ⊗ X) ⊗ X) ⊗ Xᘁ` by associators and the +braiding `β_ Xᘁ X`. -/ +theorem isZero_tensorObj_of_isZero_tensorObj + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [MonoidalPreadditive A] + (X : A) + [HasRightDual X] {P : A} + (h : Limits.IsZero ((P ⊗ X) ⊗ X)) : + Limits.IsZero (P ⊗ X) := by + have hmid : Limits.IsZero (P ⊗ ((X ⊗ Xᘁ) ⊗ X)) := + (isZero_whiskerRight h (Xᘁ)).of_iso + (whiskerLeftIso P (α_ X (Xᘁ) X) ≪≫ + (α_ P X ((Xᘁ) ⊗ X)).symm ≪≫ + whiskerLeftIso (P ⊗ X) (β_ (Xᘁ) X) ≪≫ + (α_ (P ⊗ X) X (Xᘁ)).symm) + rw [Limits.IsZero.iff_id_eq_zero] + have key : (P ◁ ((λ_ X).inv ≫ η_ X (Xᘁ) ▷ X)) ≫ + (P ◁ ((α_ X (Xᘁ) X).hom ≫ X ◁ ε_ X (Xᘁ) ≫ (ρ_ X).hom)) = + 𝟙 (P ⊗ X) := by + rw [← whiskerLeft_comp] + simp + rw [← key, + hmid.eq_zero_of_src + (P ◁ ((α_ X (Xᘁ) X).hom ≫ X ◁ ε_ X (Xᘁ) ≫ (ρ_ X).hom)), + comp_zero] + +/-- Deligne 1.17, descent: a vanishing `(n + 2)`-nd tensor power +forces a vanishing `(n + 1)`-st tensor power. -/ +theorem isZero_tensorPow_pred + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [MonoidalPreadditive A] + (X : A) [HasRightDual X] {n : ℕ} + (h : Limits.IsZero (tensorPow A X (n + 2))) : + Limits.IsZero (tensorPow A X (n + 1)) := + isZero_tensorObj_of_isZero_tensorObj (P := tensorPow A X n) X h + +/-- **Deligne 1.17** (Catégories tensorielles): a vanishing tensor +power forces a vanishing object — if `X ^ ⊗ n = 0` for some +`n ≠ 0`, then `X = 0`. -/ +theorem isZero_of_isZero_tensorPow + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [MonoidalPreadditive A] + (X : A) [HasRightDual X] {n : ℕ} + (hn : n ≠ 0) (h : Limits.IsZero (tensorPow A X n)) : + Limits.IsZero X := by + induction n with + | zero => exact absurd rfl hn + | succ m ih => + cases m with + | zero => exact h.of_iso (λ_ X).symm + | succ k => + exact ih k.succ_ne_zero (isZero_tensorPow_pred X h) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorTransfer.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorTransfer.lean new file mode 100644 index 0000000000..c8e1b22ec1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorTransfer.lean @@ -0,0 +1,344 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodTransfer +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KronKill +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedDiag + +/-! +# The tensor-product transfer of Schur vanishing + +Deligne 1.13, second half: if a Schur functor kills `X` and one +kills `Y`, a product-hook Schur functor kills `X ⊗ Y`. The +distribution isomorphism carries the diagonal action on +`(X ⊗ Y)^⊗n` to the double action on `X^⊗n ⊗ Y^⊗n`, which extends +to the group algebra of `S_n × S_n`; there the diagonal image of +the central idempotent of `λ` meets the complete family of external +products of block idempotents, where every term dies — by the +Kronecker kill when the multiplicity vanishes, and through the +killed whiskered factor when it does not, since a nonzero +multiplicity pushes a bounding-box cell into `μ'` or `ν'` +(Deligne 1.12). +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {A : Type u} + +/-- **Left whiskering by a fixed object is an algebra map** on +endomorphisms, the mirror of `whiskerAlg`. Multiplicativity is +functoriality of `◁` — note that `End` multiplies in the order +opposite to composition, which is why no reversal appears. -/ +noncomputable def whiskerLeftAlg + [Category.{v} A] [MonoidalCategory A] [Preadditive A] [Linear ℂ A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] + (P X : A) : + End X →ₐ[ℂ] End (P ⊗ X) where + toFun f := P ◁ f + map_one' := MonoidalCategory.whiskerLeft_id P X + map_mul' f g := MonoidalCategory.whiskerLeft_comp P g f + map_zero' := MonoidalPreadditive.whiskerLeft_zero + map_add' f g := MonoidalPreadditive.whiskerLeft_add f g + commutes' c := by + change P ◁ (c • 𝟙 X) = c • 𝟙 (P ⊗ X) + rw [MonoidalLinear.whiskerLeft_smul, + MonoidalCategory.whiskerLeft_id] + +/-- **The double action of a pair of permutations** on +`X ^ ⊗ n ⊗ Y ^ ⊗ n`, as a monoid homomorphism on the product +group: `(σ, τ)` acts by the two actions tensored together. -/ +@[simps] +noncomputable def pairPermHom + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] + (X Y : A) (n : ℕ) : + Equiv.Perm (Fin n) × Equiv.Perm (Fin n) →* + End (tensorPow A X n ⊗ tensorPow A Y n) where + toFun g := permMor X n g.1 ⊗ₘ permMor Y n g.2 + map_one' := by + change permMor X n 1 ⊗ₘ permMor Y n 1 = + 𝟙 (tensorPow A X n ⊗ tensorPow A Y n) + rw [permMor_one, permMor_one, MonoidalCategory.id_tensorHom_id] + map_mul' g h := by + change permMor X n (g.1 * h.1) ⊗ₘ permMor Y n (g.2 * h.2) = + (permMor X n h.1 ⊗ₘ permMor Y n h.2) ≫ + (permMor X n g.1 ⊗ₘ permMor Y n g.2) + rw [permMor_mul, permMor_mul, + MonoidalCategory.tensorHom_comp_tensorHom] + +/-- **The double action of the product group algebra** on +`X ^ ⊗ n ⊗ Y ^ ⊗ n`: the linear extension of +`(σ, τ) ↦ permMor X n σ ⊗ₘ permMor Y n τ`. Since `End` multiplies +in the order opposite to composition, `pairAlg (a * b)` is +`pairAlg b ≫ pairAlg a` as a morphism. -/ +noncomputable def pairAlg + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] + (X Y : A) (n : ℕ) : + MonoidAlgebra ℂ (Equiv.Perm (Fin n) × Equiv.Perm (Fin n)) →ₐ[ℂ] + End (tensorPow A X n ⊗ tensorPow A Y n) := + MonoidAlgebra.lift ℂ (End (tensorPow A X n ⊗ tensorPow A Y n)) + (Equiv.Perm (Fin n) × Equiv.Perm (Fin n)) (pairPermHom X Y n) + +/-- The pair algebra map sends a pair of group elements to the +tensor product of their two actions. -/ +@[simp] +theorem pairAlg_single + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] + (X Y : A) (n : ℕ) + (σ τ : Equiv.Perm (Fin n)) : + pairAlg X Y n (MonoidAlgebra.single (σ, τ) (1 : ℂ)) = + permMor X n σ ⊗ₘ permMor Y n τ := by + rw [pairAlg, MonoidAlgebra.lift_single, one_smul] + rfl + +/-- **The double action restricted to the diagonal** is the +diagonal double action: `pairAlg` extends `diagAlg` along +`diagEmbed`. -/ +theorem pairAlg_diagEmbed + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] + (X Y : A) (n : ℕ) + (x : SymGroupAlgebra n) : + pairAlg X Y n (diagEmbed x) = diagAlg X Y n x := by + have hext : (pairAlg X Y n).comp diagEmbed = diagAlg X Y n := by + refine MonoidAlgebra.algHom_ext (fun σ => ?_) (Subsingleton.elim _ _) + change pairAlg X Y n (diagEmbed (MonoidAlgebra.single σ 1)) = + diagAlg X Y n (MonoidAlgebra.single σ 1) + have hd : diagEmbed (MonoidAlgebra.single σ (1 : ℂ)) = + MonoidAlgebra.single + ((σ, σ) : Equiv.Perm (Fin n) × Equiv.Perm (Fin n)) + (1 : ℂ) := by + change MonoidAlgebra.mapDomain _ (MonoidAlgebra.single σ 1) = _ + exact MonoidAlgebra.mapDomain_single + rw [hd, pairAlg_single, diagAlg_single] + exact DFunLike.congr_fun hext x + +/-- **The double action on the first external image** is the right +whiskering of the one-sided action: `pairAlg` extends +`permAlg X n · ▷ Y ^ ⊗ n` along the first-factor embedding. -/ +theorem pairAlg_extFst + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] + (X Y : A) (n : ℕ) (x : SymGroupAlgebra n) : + pairAlg X Y n + (MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extFstHom n) x) = + permAlg X n x ▷ tensorPow A Y n := by + have hext : (pairAlg X Y n).comp + (MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extFstHom n)) = + (whiskerAlg (tensorPow A X n) (tensorPow A Y n)).comp + (permAlg X n) := by + refine MonoidAlgebra.algHom_ext (fun σ => ?_) (Subsingleton.elim _ _) + change pairAlg X Y n (MonoidAlgebra.mapDomainAlgHom ℂ ℂ + (extFstHom n) (MonoidAlgebra.single σ 1)) = + whiskerAlg (tensorPow A X n) (tensorPow A Y n) + (permAlg X n (MonoidAlgebra.single σ 1)) + have hf : MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extFstHom n) + (MonoidAlgebra.single σ (1 : ℂ)) = + MonoidAlgebra.single + ((σ, 1) : Equiv.Perm (Fin n) × Equiv.Perm (Fin n)) + (1 : ℂ) := by + change MonoidAlgebra.mapDomain _ (MonoidAlgebra.single σ 1) = _ + exact MonoidAlgebra.mapDomain_single + rw [hf, pairAlg_single, permAlg_single, permMor_one, + MonoidalCategory.tensorHom_id] + rfl + exact DFunLike.congr_fun hext x + +/-- **The double action on the second external image** is the left +whiskering of the one-sided action: `pairAlg` extends +`X ^ ⊗ n ◁ permAlg Y n ·` along the second-factor embedding. -/ +theorem pairAlg_extSnd + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] + (X Y : A) (n : ℕ) (y : SymGroupAlgebra n) : + pairAlg X Y n + (MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extSndHom n) y) = + tensorPow A X n ◁ permAlg Y n y := by + have hext : (pairAlg X Y n).comp + (MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extSndHom n)) = + (whiskerLeftAlg (tensorPow A X n) (tensorPow A Y n)).comp + (permAlg Y n) := by + refine MonoidAlgebra.algHom_ext (fun τ => ?_) (Subsingleton.elim _ _) + change pairAlg X Y n (MonoidAlgebra.mapDomainAlgHom ℂ ℂ + (extSndHom n) (MonoidAlgebra.single τ 1)) = + whiskerLeftAlg (tensorPow A X n) (tensorPow A Y n) + (permAlg Y n (MonoidAlgebra.single τ 1)) + have hs : MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extSndHom n) + (MonoidAlgebra.single τ (1 : ℂ)) = + MonoidAlgebra.single + ((1, τ) : Equiv.Perm (Fin n) × Equiv.Perm (Fin n)) + (1 : ℂ) := by + change MonoidAlgebra.mapDomain _ (MonoidAlgebra.single τ 1) = _ + exact MonoidAlgebra.mapDomain_single + rw [hs, pairAlg_single, permAlg_single, permMor_one, + MonoidalCategory.id_tensorHom] + rfl + exact DFunLike.congr_fun hext y + +/-- **The double action on an external product**, as a morphism: +the left whiskering of the second factor's action followed by the +right whiskering of the first's. This composite order is `End`'s +`pairAlg (extProd x y) = pairAlg (sndImage y) ≫ pairAlg +(fstImage x)`, the form the per-term kill composes with. -/ +theorem pairAlg_extProd + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] + (X Y : A) (n : ℕ) + (x y : SymGroupAlgebra n) : + pairAlg X Y n (extProd x y) = + (tensorPow A X n ◁ permAlg Y n y) ≫ + (permAlg X n x ▷ tensorPow A Y n) := by + unfold extProd + rw [map_mul, pairAlg_extFst, pairAlg_extSnd] + rfl + +/-- The external products of the recast block idempotents are a +complete family in the product group algebra. -/ +theorem sum_extProd_shape_e (P : SchurPackage.{v}) (n : ℕ) : + ∑ μ' : Shape n, ∑ ν' : Shape n, + extProd (Shape.e P μ') (Shape.e P ν') = + (1 : MonoidAlgebra ℂ + (Equiv.Perm (Fin n) × Equiv.Perm (Fin n))) := by + classical + calc ∑ μ' : Shape n, ∑ ν' : Shape n, + extProd (Shape.e P μ') (Shape.e P ν') + = (MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extFstHom n) + (∑ μ' : Shape n, Shape.e P μ')) * + (MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extSndHom n) + (∑ ν' : Shape n, Shape.e P ν')) := by + rw [map_sum, map_sum, Finset.sum_mul_sum] + exact Finset.sum_congr rfl fun μ' _ => + Finset.sum_congr rfl fun ν' _ => rfl + _ = 1 := by + rw [P.sum_shape_e_eq_one, map_one, map_one, one_mul] + +/-- **The tensor-product transfer** (Deligne 1.13, ⊗ half): Schur +vanishing for `X` at `μ` and `Y` at `ν` forces Schur vanishing for +`X ⊗ Y` at every diagram containing the product-hook cell of the +two bounding boxes. -/ +theorem SchurKilled.tensorObj + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] + (P : SchurPackage.{v}) {X Y : A} + {μ ν lam : YoungDiagram} {p q r s : ℕ} + (hμc : μ.colLen 0 ≤ p + 1) (hμr : μ.rowLen 0 ≤ q + 1) + (hνc : ν.colLen 0 ≤ r + 1) (hνr : ν.rowLen 0 ≤ s + 1) + (hX : SchurKilled P X μ) (hY : SchurKilled P Y ν) + (hcell : (p * r + q * s, p * s + q * r) ∈ lam) : + SchurKilled P (X ⊗ Y) lam := by + classical + rw [SchurKilled] + -- The recast idempotent at size `lam.card` is the idempotent. + have heS : Shape.e P (⟨lam, rfl⟩ : Shape lam.card) = P.e lam := by + unfold Shape.e + erw [symCast_le_refl] + -- Each external term of the double action dies. + have hterm : ∀ μ' ν' : Shape lam.card, + (pairAlg X Y lam.card + (extProd (Shape.e P μ') (Shape.e P ν') * + diagEmbed (P.e lam)) : + tensorPow A X lam.card ⊗ tensorPow A Y lam.card ⟶ + tensorPow A X lam.card ⊗ tensorPow A Y lam.card) = + 0 := by + intro μ' ν' + by_cases hk : kronMult (⟨lam, rfl⟩ : Shape lam.card) μ' ν' = 0 + · -- The Kronecker kill. + have hz0 : extProd (Shape.e P μ') (Shape.e P ν') * + diagEmbed (P.e lam) = 0 := by + rw [show P.e lam = + Shape.e P (⟨lam, rfl⟩ : Shape lam.card) from heS.symm] + exact extProd_mul_diagEmbed_eq_zero P ⟨lam, rfl⟩ μ' ν' hk + rw [hz0] + exact map_zero _ + · -- A bounding-box cell lands in `μ'` or `ν'`; that factor is + -- killed and its whiskering propagates the zero. + have hcell' := cell_of_kronMult_ne_zero + (⟨lam, rfl⟩ : Shape lam.card) μ' ν' + (p := p) (q := q) (r := r) (s := s) hk hcell + have hsplit : pairAlg X Y lam.card + (extProd (Shape.e P μ') (Shape.e P ν') * + diagEmbed (P.e lam)) = + pairAlg X Y lam.card (diagEmbed (P.e lam)) ≫ + pairAlg X Y lam.card + (extProd (Shape.e P μ') (Shape.e P ν')) := by + rw [map_mul] + rfl + rw [hsplit, pairAlg_extProd] + rcases hcell' with hcμ | hcν + · have hkilled : SchurKilled P X μ'.val := + hX.mono P (le_of_box_of_cell hμc hμr hcμ) + have hz : permAlg X lam.card (Shape.e P μ') = + (0 : tensorPow A X lam.card ⟶ + tensorPow A X lam.card) := by + rw [Shape.e] + exact permAlg_compat X _ _ hkilled + rw [hz, MonoidalPreadditive.zero_whiskerRight, + Limits.comp_zero, Limits.comp_zero] + · have hkilled : SchurKilled P Y ν'.val := + hY.mono P (le_of_box_of_cell hνc hνr hcν) + have hz : permAlg Y lam.card (Shape.e P ν') = + (0 : tensorPow A Y lam.card ⟶ + tensorPow A Y lam.card) := by + rw [Shape.e] + exact permAlg_compat Y _ _ hkilled + rw [hz, MonoidalPreadditive.whiskerLeft_zero, + Limits.zero_comp, Limits.comp_zero] + -- The diagonal double action of the idempotent vanishes: expand + -- the diagonal image over the complete external family. + have hdiag : (diagAlg X Y lam.card (P.e lam) : + tensorPow A X lam.card ⊗ tensorPow A Y lam.card ⟶ + tensorPow A X lam.card ⊗ tensorPow A Y lam.card) = 0 := by + rw [← pairAlg_diagEmbed] + have hexp : diagEmbed (P.e lam) = + ∑ μ' : Shape lam.card, ∑ ν' : Shape lam.card, + extProd (Shape.e P μ') (Shape.e P ν') * + diagEmbed (P.e lam) := by + conv_lhs => rw [show diagEmbed (P.e lam) = + 1 * diagEmbed (P.e lam) from (one_mul _).symm, + ← sum_extProd_shape_e P lam.card] + rw [Finset.sum_mul] + exact Finset.sum_congr rfl fun μ' _ => Finset.sum_mul _ _ _ + have hdist : (pairAlg X Y lam.card (diagEmbed (P.e lam)) : + tensorPow A X lam.card ⊗ tensorPow A Y lam.card ⟶ + tensorPow A X lam.card ⊗ tensorPow A Y lam.card) = + ∑ μ' : Shape lam.card, ∑ ν' : Shape lam.card, + pairAlg X Y lam.card + (extProd (Shape.e P μ') (Shape.e P ν') * + diagEmbed (P.e lam)) := by + conv_lhs => rw [hexp] + rw [map_sum] + exact Finset.sum_congr rfl fun μ' _ => map_sum _ _ _ + rw [hdist] + refine Finset.sum_eq_zero fun μ' _ => ?_ + refine Finset.sum_eq_zero fun ν' _ => ?_ + exact hterm μ' ν' + -- Transport back through the distribution isomorphism. + have hcomp : permAlg (X ⊗ Y) lam.card (P.e lam) ≫ + (tensorPowDistrib X Y lam.card).hom = 0 := by + rw [tensorPowDistrib_permAlg, hdiag] + exact Limits.comp_zero + calc permAlg (X ⊗ Y) lam.card (P.e lam) + = (permAlg (X ⊗ Y) lam.card (P.e lam) ≫ + (tensorPowDistrib X Y lam.card).hom) ≫ + (tensorPowDistrib X Y lam.card).inv := by + rw [Category.assoc, Iso.hom_inv_id, Category.comp_id] + _ = 0 := by rw [hcomp, Limits.zero_comp] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorZigzag.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorZigzag.lean new file mode 100644 index 0000000000..37282bc080 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorZigzag.lean @@ -0,0 +1,1035 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MuInterchange +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZagAction +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagCarrier + +/-! +# The tensor datum inherits the zigzag laws + +Deligne's 1.15 tensor part, the verification "left to the +reader": the zigzag laws of two duality data pass to their +tensor. The tensor copair element is the interchange of the two +copair elements, and the tensor contraction against a pure tensor +of carriers is the tensor of the component contractions; nesting +the two component triangles closes the tensor triangle. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The tensor copair element is the interchange of the copair +elements.** -/ +theorem tensorCopair_point + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {N₁ : Mod D A} {N₂ : Mod D A} + {N₁' : Mod D A} {N₂' : Mod D A} + (d₁ : ModDualityDatum A N₁ N₁') + (d₂ : ModDualityDatum A N₂ N₂') : + η[A] ≫ tensorCopair A d₁ d₂ = + (λ_ (𝟙_ D)).inv ≫ + ((η[A] ≫ d₁.copair) ⊗ₘ (η[A] ≫ d₂.copair)) ≫ + interchange A N₁ N₁' N₂ N₂' := by + rw [tensorCopair] + show η[A] ≫ regPairUnfold A ≫ + modTensorMap A d₁.copairMod d₂.copairMod ≫ + interchangeDesc A N₁ N₁' N₂ N₂' = + (λ_ (𝟙_ D)).inv ≫ + ((η[A] ≫ d₁.copair) ⊗ₘ (η[A] ≫ d₂.copair)) ≫ + interchange A N₁ N₁' N₂ N₂' + have hunfold : η[A] ≫ regPairUnfold A = + (λ_ (𝟙_ D)).inv ≫ (η[A] ⊗ₘ η[A]) ≫ + modTensorπ A (regularMod A) (regularMod A) := by + rw [regPairUnfold] + change η[A] ≫ (λ_ A).inv ≫ η[A] ▷ A ≫ + modTensorπ A (regularMod A) (regularMod A) = _ + rw [leftUnitor_inv_naturality_assoc, + whisker_exchange_assoc, MonoidalCategory.tensorHom_def, + Category.assoc] + have hmap : modTensorπ A (regularMod A) (regularMod A) ≫ + modTensorMap A d₁.copairMod d₂.copairMod = + (d₁.copair ⊗ₘ d₂.copair) ≫ + modTensorπ A (modTensorMod A N₁ N₁') + (modTensorMod A N₂ N₂') := + modTensorπ_map A d₁.copairMod d₂.copairMod + have htail : modTensorπ A (regularMod A) (regularMod A) ≫ + modTensorMap A d₁.copairMod d₂.copairMod ≫ + interchangeDesc A N₁ N₁' N₂ N₂' = + (d₁.copair ⊗ₘ d₂.copair) ≫ + interchange A N₁ N₁' N₂ N₂' := by + erw [← Category.assoc, hmap, Category.assoc] + exact congrArg (fun t : (modTensorMod A N₁ N₁').X ⊗ + (modTensorMod A N₂ N₂').X ⟶ + modTensor A (modTensorMod A N₁ N₂) + (modTensorMod A N₁' N₂') => + (d₁.copair ⊗ₘ d₂.copair) ≫ t) + (modTensorπ_interchangeDesc A N₁ N₁' N₂ N₂') + rw [reassoc_of% hunfold, htail, + ← MonoidalCategory.tensorHom_comp_tensorHom_assoc] + +/-- **Paired right actions descend to the joint action**: acting +on both carriers and projecting is multiplying the scalars and +acting on the projected pair — the quotient relation of the +relative tensor. -/ +theorem tensorHom_actRight_π + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] + (N₁ N₂ : Mod D A) : + (actRight A N₁.X ⊗ₘ actRight A N₂.X) ≫ modTensorπ A N₁ N₂ = + tensorμ N₁.X A N₂.X A ≫ + ((N₁.X ⊗ N₂.X) ◁ μ[A]) ≫ + (modTensorπ A N₁ N₂ ▷ A) ≫ + (β_ (modTensor A N₁ N₂) A).hom ≫ + modTensorAct A N₁ N₂ := by + have hR : (modTensorπ A N₁ N₂ ▷ A) ≫ + (β_ (modTensor A N₁ N₂) A).hom ≫ + modTensorAct A N₁ N₂ = + (β_ (N₁.X ⊗ N₂.X) A).hom ≫ + (α_ A N₁.X N₂.X).inv ≫ + (actLeft A N₁.X ▷ N₂.X) ≫ modTensorπ A N₁ N₂ := by + rw [BraidedCategory.braiding_naturality_left_assoc, + whiskerLeft_modTensorπ_act] + simp only [Category.assoc] + have hcond : (actRight A N₁.X ▷ N₂.X) ≫ modTensorπ A N₁ N₂ = + (α_ N₁.X A N₂.X).hom ≫ + (N₁.X ◁ actLeft A N₂.X) ≫ modTensorπ A N₁ N₂ := by + have h := modTensor_condition A N₁ N₂ + rw [modTensorLegM, modTensorLegN] at h + simpa using h + have hcond' : (N₁.X ◁ actLeft A N₂.X) ≫ modTensorπ A N₁ N₂ = + (α_ N₁.X A N₂.X).inv ≫ + (actRight A N₁.X ▷ N₂.X) ≫ modTensorπ A N₁ N₂ := by + rw [hcond, Iso.inv_hom_id_assoc] + have h2 : (N₁.X ◁ actRight A N₂.X) ≫ modTensorπ A N₁ N₂ = + (N₁.X ◁ (β_ N₂.X A).hom) ≫ (α_ N₁.X A N₂.X).inv ≫ + (actRight A N₁.X ▷ N₂.X) ≫ modTensorπ A N₁ N₂ := by + rw [actRight, MonoidalCategory.whiskerLeft_comp, + Category.assoc, hcond'] + have h3 : (actRight A N₁.X ▷ A ≫ actRight A N₁.X) ▷ N₂.X ≫ + modTensorπ A N₁ N₂ = + ((α_ N₁.X A A).hom ▷ N₂.X) ≫ + ((N₁.X ◁ μ[A]) ▷ N₂.X) ≫ + (actRight A N₁.X ▷ N₂.X) ≫ modTensorπ A N₁ N₂ := by + rw [actRight_actRight] + simp only [comp_whiskerRight, Category.assoc] + conv_lhs => rw [MonoidalCategory.tensorHom_def, + Category.assoc, h2, + ← whisker_exchange_assoc (actRight A N₁.X) + ((β_ N₂.X A).hom), + associator_inv_naturality_left_assoc, + ← comp_whiskerRight_assoc, h3] + conv_lhs => rw [(show actRight A N₁.X = + (β_ N₁.X A).hom ≫ actLeft A N₁.X from rfl), + comp_whiskerRight, Category.assoc] + conv_rhs => rw [hR] + have hβμ : ((N₁.X ◁ μ[A]) ▷ N₂.X) ≫ + ((β_ N₁.X A).hom ▷ N₂.X) = + ((β_ N₁.X (A ⊗ A)).hom ▷ N₂.X) ≫ + ((μ[A] ▷ N₁.X) ▷ N₂.X) := by + rw [← comp_whiskerRight, + BraidedCategory.braiding_naturality_right, + comp_whiskerRight] + have hβμ' : ((N₁.X ⊗ N₂.X) ◁ μ[A]) ≫ + (β_ (N₁.X ⊗ N₂.X) A).hom = + (β_ (N₁.X ⊗ N₂.X) (A ⊗ A)).hom ≫ + (μ[A] ▷ (N₁.X ⊗ N₂.X)) := by + rw [BraidedCategory.braiding_naturality_right] + conv_lhs => rw [reassoc_of% hβμ] + conv_rhs => rw [reassoc_of% hβμ', + associator_inv_naturality_left_assoc] + have hpre : ((N₁.X ⊗ A) ◁ (β_ N₂.X A).hom) ≫ + (α_ (N₁.X ⊗ A) A N₂.X).inv ≫ + ((α_ N₁.X A A).hom ▷ N₂.X) ≫ + ((β_ N₁.X (A ⊗ A)).hom ▷ N₂.X) = + tensorμ N₁.X A N₂.X A ≫ + (β_ (N₁.X ⊗ N₂.X) (A ⊗ A)).hom ≫ + (α_ (A ⊗ A) N₁.X N₂.X).inv := + braid_prefix_coherence N₁.X A N₂.X + rw [reassoc_of% hpre] + +private theorem tensorDatum_pair_rawInterchange + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {N₁ : Mod D A} {N₂ : Mod D A} + {N₁' : Mod D A} {N₂' : Mod D A} + (d₁ : ModDualityDatum A N₁ N₁') + (d₂ : ModDualityDatum A N₂ N₂') : + ((modTensorπ A N₁' N₂' ⊗ₘ modTensorπ A N₁ N₂) : + (N₁'.X ⊗ N₂'.X) ⊗ (N₁.X ⊗ N₂.X) ⟶ _) ≫ + interchange A N₁' N₂' N₁ N₂ ≫ + modTensorMap A d₁.pairMod d₂.pairMod ≫ regPairFold A = + tensorμ N₁'.X N₂'.X N₁.X N₂.X ≫ + ((modTensorπ A N₁' N₁ ≫ d₁.pair) ⊗ₘ + (modTensorπ A N₂' N₂ ≫ d₂.pair)) ≫ μ[A] := by + have hfold : modTensorπ A (regularMod A) (regularMod A) ≫ + regPairFold A = μ[A] := by + rw [regPairFold] + exact modTensorπ_desc A _ _ _ _ + have hw : ((modTensorπ A N₁' N₂' ⊗ₘ modTensorπ A N₁ N₂) : + (N₁'.X ⊗ N₂'.X) ⊗ (N₁.X ⊗ N₂.X) ⟶ _) ≫ + interchange A N₁' N₂' N₁ N₂ ≫ + modTensorMap A d₁.pairMod d₂.pairMod ≫ regPairFold A = + tensorμ N₁'.X N₂'.X N₁.X N₂.X ≫ + ((modTensorπ A N₁' N₁ ≫ d₁.pair) ⊗ₘ + (modTensorπ A N₂' N₂ ≫ d₂.pair)) ≫ μ[A] := by + have hm : modTensorπ A (modTensorMod A N₁' N₁) + (modTensorMod A N₂' N₂) ≫ + modTensorMap A d₁.pairMod d₂.pairMod = + (d₁.pair ⊗ₘ d₂.pair) ≫ + modTensorπ A (regularMod A) (regularMod A) := + modTensorπ_map A d₁.pairMod d₂.pairMod + have htail : (modTensorπ A N₁' N₁ ⊗ₘ modTensorπ A N₂' N₂) ≫ + modTensorπ A (modTensorMod A N₁' N₁) + (modTensorMod A N₂' N₂) ≫ + modTensorMap A d₁.pairMod d₂.pairMod ≫ + regPairFold A = + ((modTensorπ A N₁' N₁ ≫ d₁.pair) ⊗ₘ + (modTensorπ A N₂' N₂ ≫ d₂.pair)) ≫ μ[A] := by + have t2 : modTensorπ A (modTensorMod A N₁' N₁) + (modTensorMod A N₂' N₂) ≫ + modTensorMap A d₁.pairMod d₂.pairMod ≫ + regPairFold A = + (d₁.pair ⊗ₘ d₂.pair) ≫ μ[A] := by + rw [← Category.assoc, hm] + exact (Category.assoc _ _ _).trans + (congrArg (fun t : (regularMod A).X ⊗ + (regularMod A).X ⟶ A => + (d₁.pair ⊗ₘ d₂.pair) ≫ t) hfold) + exact (congrArg (fun t : (modTensorMod A N₁' N₁).X ⊗ + (modTensorMod A N₂' N₂).X ⟶ A => + (modTensorπ A N₁' N₁ ⊗ₘ modTensorπ A N₂' N₂) ≫ t) + t2).trans (by + rw [← MonoidalCategory.tensorHom_comp_tensorHom_assoc]) + erw [← Category.assoc, tensorHom_π_interchange, + rawInterchangeπ, rawInterchange] + conv_lhs => erw [Category.assoc]; arg 2; erw [Category.assoc] + simpa only [Category.assoc] using congrArg (fun t : (N₁'.X ⊗ N₁.X) ⊗ (N₂'.X ⊗ N₂.X) ⟶ + A => tensorμ N₁'.X N₂'.X N₁.X N₂.X ≫ t) htail + exact hw + +private theorem zigContract_tensor_components_raw + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {N₁ : Mod D A} {N₂ : Mod D A} + {N₁' : Mod D A} {N₂' : Mod D A} + (d₁ : ModDualityDatum A N₁ N₁') + (d₂ : ModDualityDatum A N₂ N₂') : + ((modTensorπ A N₁ N₁' ⊗ₘ modTensorπ A N₂ N₂') ▷ + (N₁.X ⊗ N₂.X)) ≫ + (tensorμ (modTensor A N₁ N₁') (modTensor A N₂ N₂') + N₁.X N₂.X ≫ + ((zigContract A d₁.pair d₁.pair_linear ⊗ₘ + zigContract A d₂.pair d₂.pair_linear) ≫ + modTensorπ A N₁ N₂)) = + tensorμ (N₁.X ⊗ N₁'.X) (N₂.X ⊗ N₂'.X) N₁.X N₂.X ≫ + (((α_ N₁.X N₁'.X N₁.X).hom ⊗ₘ + (α_ N₂.X N₂'.X N₂.X).hom) ≫ + (((N₁.X ◁ (modTensorπ A N₁' N₁ ≫ d₁.pair)) ⊗ₘ + (N₂.X ◁ (modTensorπ A N₂' N₂ ≫ d₂.pair))) ≫ + (tensorμ N₁.X A N₂.X A ≫ + ((N₁.X ⊗ N₂.X) ◁ μ[A]) ≫ + (modTensorπ A N₁ N₂ ▷ A) ≫ + (β_ (modTensor A N₁ N₂) A).hom ≫ + modTensorAct A N₁ N₂))) := by + have hμnat : ((modTensorπ A N₁ N₁' ⊗ₘ modTensorπ A N₂ N₂') ▷ + (N₁.X ⊗ N₂.X)) ≫ + tensorμ (modTensor A N₁ N₁') (modTensor A N₂ N₂') + N₁.X N₂.X = + tensorμ (N₁.X ⊗ N₁'.X) (N₂.X ⊗ N₂'.X) N₁.X N₂.X ≫ + ((modTensorπ A N₁ N₁' ▷ N₁.X) ⊗ₘ + (modTensorπ A N₂ N₂' ▷ N₂.X)) := by + simpa using tensorμ_natural (modTensorπ A N₁ N₁') + (modTensorπ A N₂ N₂') (𝟙 N₁.X) (𝟙 N₂.X) + have hzc₁ : (modTensorπ A N₁ N₁' ▷ N₁.X) ≫ + zigContract A d₁.pair d₁.pair_linear = + (α_ N₁.X N₁'.X N₁.X).hom ≫ + (N₁.X ◁ (modTensorπ A N₁' N₁ ≫ d₁.pair)) ≫ + actRight A N₁.X := + whiskerRight_modTensorπ_zigContract A d₁.pair + d₁.pair_linear + have hzc₂ : (modTensorπ A N₂ N₂' ▷ N₂.X) ≫ + zigContract A d₂.pair d₂.pair_linear = + (α_ N₂.X N₂'.X N₂.X).hom ≫ + (N₂.X ◁ (modTensorπ A N₂' N₂ ≫ d₂.pair)) ≫ + actRight A N₂.X := + whiskerRight_modTensorπ_zigContract A d₂.pair + d₂.pair_linear + have hpair2 : ((modTensorπ A N₁ N₁' ▷ N₁.X) ⊗ₘ + (modTensorπ A N₂ N₂' ▷ N₂.X)) ≫ + (zigContract A d₁.pair d₁.pair_linear ⊗ₘ + zigContract A d₂.pair d₂.pair_linear) = + ((α_ N₁.X N₁'.X N₁.X).hom ⊗ₘ + (α_ N₂.X N₂'.X N₂.X).hom) ≫ + ((N₁.X ◁ (modTensorπ A N₁' N₁ ≫ d₁.pair)) ⊗ₘ + (N₂.X ◁ (modTensorπ A N₂' N₂ ≫ d₂.pair))) ≫ + (actRight A N₁.X ⊗ₘ actRight A N₂.X) := by + rw [MonoidalCategory.tensorHom_comp_tensorHom, hzc₁, hzc₂, + ← MonoidalCategory.tensorHom_comp_tensorHom, + ← MonoidalCategory.tensorHom_comp_tensorHom] + have hR : ((modTensorπ A N₁ N₁' ⊗ₘ modTensorπ A N₂ N₂') ▷ + (N₁.X ⊗ N₂.X)) ≫ + (tensorμ (modTensor A N₁ N₁') (modTensor A N₂ N₂') + N₁.X N₂.X ≫ + ((zigContract A d₁.pair d₁.pair_linear ⊗ₘ + zigContract A d₂.pair d₂.pair_linear) ≫ + modTensorπ A N₁ N₂)) = + tensorμ (N₁.X ⊗ N₁'.X) (N₂.X ⊗ N₂'.X) N₁.X N₂.X ≫ + (((α_ N₁.X N₁'.X N₁.X).hom ⊗ₘ + (α_ N₂.X N₂'.X N₂.X).hom) ≫ + (((N₁.X ◁ (modTensorπ A N₁' N₁ ≫ d₁.pair)) ⊗ₘ + (N₂.X ◁ (modTensorπ A N₂' N₂ ≫ d₂.pair))) ≫ + (tensorμ N₁.X A N₂.X A ≫ + ((N₁.X ⊗ N₂.X) ◁ μ[A]) ≫ + (modTensorπ A N₁ N₂ ▷ A) ≫ + (β_ (modTensor A N₁ N₂) A).hom ≫ + modTensorAct A N₁ N₂))) := + (Category.assoc _ _ _).symm.trans <| + (congrArg (fun t : (((N₁.X ⊗ N₁'.X) ⊗ (N₂.X ⊗ N₂'.X)) ⊗ + (N₁.X ⊗ N₂.X)) ⟶ + ((modTensor A N₁ N₁' ⊗ N₁.X) ⊗ + (modTensor A N₂ N₂' ⊗ N₂.X)) => + t ≫ ((zigContract A d₁.pair d₁.pair_linear ⊗ₘ + zigContract A d₂.pair d₂.pair_linear) ≫ + modTensorπ A N₁ N₂)) hμnat).trans <| + (Category.assoc _ _ _).trans <| + congrArg (fun t : ((N₁.X ⊗ N₁'.X) ⊗ N₁.X) ⊗ + ((N₂.X ⊗ N₂'.X) ⊗ N₂.X) ⟶ modTensor A N₁ N₂ => + tensorμ (N₁.X ⊗ N₁'.X) (N₂.X ⊗ N₂'.X) N₁.X N₂.X ≫ t) <| + (Category.assoc _ _ _).symm.trans <| + (congrArg (fun t : ((N₁.X ⊗ N₁'.X) ⊗ N₁.X) ⊗ + ((N₂.X ⊗ N₂'.X) ⊗ N₂.X) ⟶ N₁.X ⊗ N₂.X => + t ≫ modTensorπ A N₁ N₂) hpair2).trans <| + (Category.assoc _ _ _).trans <| + congrArg (fun t : (N₁.X ⊗ (N₁'.X ⊗ N₁.X)) ⊗ + (N₂.X ⊗ (N₂'.X ⊗ N₂.X)) ⟶ modTensor A N₁ N₂ => + ((α_ N₁.X N₁'.X N₁.X).hom ⊗ₘ + (α_ N₂.X N₂'.X N₂.X).hom) ≫ t) <| + (Category.assoc _ _ _).trans <| + congrArg (fun t : (N₁.X ⊗ A) ⊗ (N₂.X ⊗ A) ⟶ + modTensor A N₁ N₂ => + ((N₁.X ◁ (modTensorπ A N₁' N₁ ≫ d₁.pair)) ⊗ₘ + (N₂.X ◁ (modTensorπ A N₂' N₂ ≫ d₂.pair))) ≫ t) + (tensorHom_actRight_π A N₁ N₂) + exact hR + +private theorem zagContract_tensor_components_raw + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {N₁ : Mod D A} {N₂ : Mod D A} + {N₁' : Mod D A} {N₂' : Mod D A} + (d₁ : ModDualityDatum A N₁ N₁') + (d₂ : ModDualityDatum A N₂ N₂') : + ((N₁'.X ⊗ N₂'.X) ◁ + (modTensorπ A N₁ N₁' ⊗ₘ modTensorπ A N₂ N₂')) ≫ + (tensorμ N₁'.X N₂'.X (modTensor A N₁ N₁') + (modTensor A N₂ N₂') ≫ + ((zagContract A d₁.pair d₁.pair_linear ⊗ₘ + zagContract A d₂.pair d₂.pair_linear) ≫ + modTensorπ A N₁' N₂')) = + tensorμ N₁'.X N₂'.X (N₁.X ⊗ N₁'.X) (N₂.X ⊗ N₂'.X) ≫ + (((α_ N₁'.X N₁.X N₁'.X).inv ⊗ₘ + (α_ N₂'.X N₂.X N₂'.X).inv) ≫ + ((((modTensorπ A N₁' N₁ ≫ d₁.pair) ▷ N₁'.X) ⊗ₘ + ((modTensorπ A N₂' N₂ ≫ d₂.pair) ▷ N₂'.X)) ≫ + (tensorμ A N₁'.X A N₂'.X ≫ + (μ[A] ▷ (N₁'.X ⊗ N₂'.X)) ≫ + (A ◁ modTensorπ A N₁' N₂') ≫ + modTensorAct A N₁' N₂'))) := by + have hμnat : ((N₁'.X ⊗ N₂'.X) ◁ + (modTensorπ A N₁ N₁' ⊗ₘ modTensorπ A N₂ N₂')) ≫ + tensorμ N₁'.X N₂'.X (modTensor A N₁ N₁') + (modTensor A N₂ N₂') = + tensorμ N₁'.X N₂'.X (N₁.X ⊗ N₁'.X) (N₂.X ⊗ N₂'.X) ≫ + ((N₁'.X ◁ modTensorπ A N₁ N₁') ⊗ₘ + (N₂'.X ◁ modTensorπ A N₂ N₂')) := by + simpa using tensorμ_natural (𝟙 N₁'.X) (𝟙 N₂'.X) + (modTensorπ A N₁ N₁') (modTensorπ A N₂ N₂') + have hzagc₁ : (N₁'.X ◁ modTensorπ A N₁ N₁') ≫ + zagContract A d₁.pair d₁.pair_linear = + (α_ N₁'.X N₁.X N₁'.X).inv ≫ + ((modTensorπ A N₁' N₁ ≫ d₁.pair) ▷ N₁'.X) ≫ + actLeft A N₁'.X := + whiskerLeft_modTensorπ_zagContract A d₁.pair + d₁.pair_linear + have hzagc₂ : (N₂'.X ◁ modTensorπ A N₂ N₂') ≫ + zagContract A d₂.pair d₂.pair_linear = + (α_ N₂'.X N₂.X N₂'.X).inv ≫ + ((modTensorπ A N₂' N₂ ≫ d₂.pair) ▷ N₂'.X) ≫ + actLeft A N₂'.X := + whiskerLeft_modTensorπ_zagContract A d₂.pair + d₂.pair_linear + have hpair2 : ((N₁'.X ◁ modTensorπ A N₁ N₁') ⊗ₘ + (N₂'.X ◁ modTensorπ A N₂ N₂')) ≫ + (zagContract A d₁.pair d₁.pair_linear ⊗ₘ + zagContract A d₂.pair d₂.pair_linear) = + ((α_ N₁'.X N₁.X N₁'.X).inv ⊗ₘ + (α_ N₂'.X N₂.X N₂'.X).inv) ≫ + (((modTensorπ A N₁' N₁ ≫ d₁.pair) ▷ N₁'.X) ⊗ₘ + ((modTensorπ A N₂' N₂ ≫ d₂.pair) ▷ N₂'.X)) ≫ + (actLeft A N₁'.X ⊗ₘ actLeft A N₂'.X) := by + rw [MonoidalCategory.tensorHom_comp_tensorHom, + hzagc₁, hzagc₂, + ← MonoidalCategory.tensorHom_comp_tensorHom, + ← MonoidalCategory.tensorHom_comp_tensorHom] + have hR : ((N₁'.X ⊗ N₂'.X) ◁ + (modTensorπ A N₁ N₁' ⊗ₘ modTensorπ A N₂ N₂')) ≫ + (tensorμ N₁'.X N₂'.X (modTensor A N₁ N₁') + (modTensor A N₂ N₂') ≫ + ((zagContract A d₁.pair d₁.pair_linear ⊗ₘ + zagContract A d₂.pair d₂.pair_linear) ≫ + modTensorπ A N₁' N₂')) = + tensorμ N₁'.X N₂'.X (N₁.X ⊗ N₁'.X) (N₂.X ⊗ N₂'.X) ≫ + (((α_ N₁'.X N₁.X N₁'.X).inv ⊗ₘ + (α_ N₂'.X N₂.X N₂'.X).inv) ≫ + ((((modTensorπ A N₁' N₁ ≫ d₁.pair) ▷ N₁'.X) ⊗ₘ + ((modTensorπ A N₂' N₂ ≫ d₂.pair) ▷ N₂'.X)) ≫ + (tensorμ A N₁'.X A N₂'.X ≫ + (μ[A] ▷ (N₁'.X ⊗ N₂'.X)) ≫ + (A ◁ modTensorπ A N₁' N₂') ≫ + modTensorAct A N₁' N₂'))) := + (Category.assoc _ _ _).symm.trans <| + (congrArg (fun t : ((N₁'.X ⊗ N₂'.X) ⊗ + ((N₁.X ⊗ N₁'.X) ⊗ (N₂.X ⊗ N₂'.X))) ⟶ + ((N₁'.X ⊗ modTensor A N₁ N₁') ⊗ + (N₂'.X ⊗ modTensor A N₂ N₂')) => + t ≫ ((zagContract A d₁.pair d₁.pair_linear ⊗ₘ + zagContract A d₂.pair d₂.pair_linear) ≫ + modTensorπ A N₁' N₂')) hμnat).trans <| + (Category.assoc _ _ _).trans <| + congrArg (fun t : (N₁'.X ⊗ (N₁.X ⊗ N₁'.X)) ⊗ + (N₂'.X ⊗ (N₂.X ⊗ N₂'.X)) ⟶ modTensor A N₁' N₂' => + tensorμ N₁'.X N₂'.X (N₁.X ⊗ N₁'.X) + (N₂.X ⊗ N₂'.X) ≫ t) <| + (Category.assoc _ _ _).symm.trans <| + (congrArg (fun t : (N₁'.X ⊗ (N₁.X ⊗ N₁'.X)) ⊗ + (N₂'.X ⊗ (N₂.X ⊗ N₂'.X)) ⟶ N₁'.X ⊗ N₂'.X => + t ≫ modTensorπ A N₁' N₂') hpair2).trans <| + (Category.assoc _ _ _).trans <| + congrArg (fun t : ((N₁'.X ⊗ N₁.X) ⊗ N₁'.X) ⊗ + ((N₂'.X ⊗ N₂.X) ⊗ N₂'.X) ⟶ modTensor A N₁' N₂' => + ((α_ N₁'.X N₁.X N₁'.X).inv ⊗ₘ + (α_ N₂'.X N₂.X N₂'.X).inv) ≫ t) <| + (Category.assoc _ _ _).trans <| + congrArg (fun t : (A ⊗ N₁'.X) ⊗ (A ⊗ N₂'.X) ⟶ + modTensor A N₁' N₂' => + (((modTensorπ A N₁' N₁ ≫ d₁.pair) ▷ N₁'.X) ⊗ₘ + ((modTensorπ A N₂' N₂ ≫ d₂.pair) ▷ N₂'.X)) ≫ t) + (tensorHom_actLeft_π A N₁' N₂') + exact hR + +/-- **The tensor contraction against the interchange is the +tensor of the component contractions**: the crossing seats each +dual half against its own carrier. -/ +theorem interchange_zigContract + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {N₁ : Mod D A} {N₂ : Mod D A} + {N₁' : Mod D A} {N₂' : Mod D A} + (d₁ : ModDualityDatum A N₁ N₁') + (d₂ : ModDualityDatum A N₂ N₂') : + ((modTensor A N₁ N₁' ⊗ modTensor A N₂ N₂') ◁ + modTensorπ A N₁ N₂) ≫ + (interchange A N₁ N₁' N₂ N₂' ▷ modTensor A N₁ N₂) ≫ + zigContract A (tensorDatum A d₁ d₂).pair + (tensorDatum A d₁ d₂).pair_linear = + tensorμ (modTensor A N₁ N₁') (modTensor A N₂ N₂') + N₁.X N₂.X ≫ + (zigContract A d₁.pair d₁.pair_linear ⊗ₘ + zigContract A d₂.pair d₂.pair_linear) ≫ + modTensorπ A N₁ N₂ := by + refine (cancel_epi + ((modTensorπ A N₁ N₁' ⊗ₘ modTensorπ A N₂ N₂') ▷ + (N₁.X ⊗ N₂.X))).mp ?_ + have hpair : (tensorDatum A d₁ d₂).pair = + interchangeDesc A N₁' N₂' N₁ N₂ ≫ + modTensorMap A d₁.pairMod d₂.pairMod ≫ + regPairFold A := rfl + have hinner : modTensorπ A (modTensorMod A N₁' N₂') + (modTensorMod A N₁ N₂) ≫ (tensorDatum A d₁ d₂).pair = + interchange A N₁' N₂' N₁ N₂ ≫ + modTensorMap A d₁.pairMod d₂.pairMod ≫ + regPairFold A := by + rw [hpair, ← Category.assoc, modTensorπ_interchangeDesc] + rfl + conv_lhs => erw [← whisker_exchange_assoc, + ← comp_whiskerRight_assoc, tensorHom_π_interchange, + rawInterchangeπ, rawInterchange] + have hzdef : (MonoidalCategory.whiskerRight + (X₁ := modTensor A N₁ N₂ ⊗ modTensor A N₁' N₂') + (modTensorπ A (modTensorMod A N₁ N₂) + (modTensorMod A N₁' N₂')) + (modTensor A N₁ N₂)) ≫ + zigContract A (tensorDatum A d₁ d₂).pair + (tensorDatum A d₁ d₂).pair_linear = + (α_ (modTensorMod A N₁ N₂).X (modTensorMod A N₁' N₂').X + (modTensorMod A N₁ N₂).X).hom ≫ + ((modTensorMod A N₁ N₂).X ◁ + (modTensorπ A (modTensorMod A N₁' N₂') + (modTensorMod A N₁ N₂) ≫ + (tensorDatum A d₁ d₂).pair)) ≫ + actRight A (modTensorMod A N₁ N₂).X := + whiskerRight_modTensorπ_zigContract A + (tensorDatum A d₁ d₂).pair + (tensorDatum A d₁ d₂).pair_linear + conv_lhs => erw [ + comp_whiskerRight (tensorμ N₁.X N₁'.X N₂.X N₂'.X) + ((modTensorπ A N₁ N₂ ⊗ₘ modTensorπ A N₁' N₂') ≫ (modTensorπ A (modTensorMod A N₁ N₂) + (modTensorMod A N₁' N₂'))) _, + comp_whiskerRight (modTensorπ A N₁ N₂ ⊗ₘ modTensorπ A N₁' N₂') (modTensorπ A + (modTensorMod A N₁ N₂) (modTensorMod A N₁' N₂')) _, + Category.assoc, Category.assoc, hzdef] + -- The inner contraction word, fully reduced at the fold. + have hw := tensorDatum_pair_rawInterchange A d₁ d₂ + conv_lhs => rw [hinner] + conv_lhs => erw [whisker_exchange_assoc + (tensorμ N₁.X N₁'.X N₂.X N₂'.X) (modTensorπ A N₁ N₂), + whisker_exchange_assoc + (modTensorπ A N₁ N₂ ⊗ₘ modTensorπ A N₁' N₂') + (modTensorπ A N₁ N₂)] + conv_lhs => erw [← reassoc_of% (MonoidalCategory.tensorHom_def + (modTensorπ A N₁ N₂ ⊗ₘ modTensorπ A N₁' N₂') + (modTensorπ A N₁ N₂))] + have hα : ((modTensorπ A N₁ N₂ ⊗ₘ modTensorπ A N₁' N₂') ⊗ₘ + modTensorπ A N₁ N₂) ≫ + (α_ (modTensor A N₁ N₂) (modTensor A N₁' N₂') + (modTensor A N₁ N₂)).hom = + (α_ (N₁.X ⊗ N₂.X) (N₁'.X ⊗ N₂'.X) (N₁.X ⊗ N₂.X)).hom ≫ + (modTensorπ A N₁ N₂ ⊗ₘ + (modTensorπ A N₁' N₂' ⊗ₘ modTensorπ A N₁ N₂)) := + associator_naturality (modTensorπ A N₁ N₂) + (modTensorπ A N₁' N₂') (modTensorπ A N₁ N₂) + have hbig : (modTensorπ A N₁ N₂ ⊗ₘ + (modTensorπ A N₁' N₂' ⊗ₘ modTensorπ A N₁ N₂)) ≫ + (modTensor A N₁ N₂ ◁ + (interchange A N₁' N₂' N₁ N₂ ≫ + modTensorMap A d₁.pairMod d₂.pairMod ≫ + regPairFold A)) = + modTensorπ A N₁ N₂ ⊗ₘ + (tensorμ N₁'.X N₂'.X N₁.X N₂.X ≫ + ((modTensorπ A N₁' N₁ ≫ d₁.pair) ⊗ₘ + (modTensorπ A N₂' N₂ ≫ d₂.pair)) ≫ μ[A]) := by + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.comp_id] + exact congrArg (fun t : (N₁'.X ⊗ N₂'.X) ⊗ (N₁.X ⊗ N₂.X) ⟶ + A => modTensorπ A N₁ N₂ ⊗ₘ t) hw + have hslot : (modTensorπ A N₁ N₂ ⊗ₘ + (modTensorπ A N₁' N₂' ⊗ₘ modTensorπ A N₁ N₂)) ≫ + ((modTensor A N₁ N₂ ◁ + (interchange A N₁' N₂' N₁ N₂ ≫ + modTensorMap A d₁.pairMod d₂.pairMod ≫ + regPairFold A)) ≫ + actRight A (modTensorMod A N₁ N₂).X) = + (modTensorπ A N₁ N₂ ⊗ₘ + (tensorμ N₁'.X N₂'.X N₁.X N₂.X ≫ + ((modTensorπ A N₁' N₁ ≫ d₁.pair) ⊗ₘ + (modTensorπ A N₂' N₂ ≫ d₂.pair)) ≫ μ[A])) ≫ + actRight A (modTensorMod A N₁ N₂).X := + (Category.assoc _ _ _).symm.trans + (congrArg (fun t : (N₁.X ⊗ N₂.X) ⊗ + ((N₁'.X ⊗ N₂'.X) ⊗ (N₁.X ⊗ N₂.X)) ⟶ + modTensor A N₁ N₂ ⊗ A => + t ≫ actRight A (modTensorMod A N₁ N₂).X) hbig) + have hstep : ((modTensorπ A N₁ N₂ ⊗ₘ modTensorπ A N₁' N₂') ⊗ₘ + modTensorπ A N₁ N₂) ≫ + ((α_ (modTensor A N₁ N₂) (modTensor A N₁' N₂') + (modTensor A N₁ N₂)).hom ≫ + ((modTensor A N₁ N₂ ◁ + (interchange A N₁' N₂' N₁ N₂ ≫ + modTensorMap A d₁.pairMod d₂.pairMod ≫ + regPairFold A)) ≫ + actRight A (modTensorMod A N₁ N₂).X)) = + (α_ (N₁.X ⊗ N₂.X) (N₁'.X ⊗ N₂'.X) (N₁.X ⊗ N₂.X)).hom ≫ + ((modTensorπ A N₁ N₂ ⊗ₘ + (tensorμ N₁'.X N₂'.X N₁.X N₂.X ≫ + ((modTensorπ A N₁' N₁ ≫ d₁.pair) ⊗ₘ + (modTensorπ A N₂' N₂ ≫ d₂.pair)) ≫ μ[A])) ≫ + actRight A (modTensorMod A N₁ N₂).X) := + (Category.assoc _ _ _).symm.trans <| + (congrArg (fun t : ((N₁.X ⊗ N₂.X) ⊗ (N₁'.X ⊗ N₂'.X)) ⊗ + (N₁.X ⊗ N₂.X) ⟶ + modTensor A N₁ N₂ ⊗ + (modTensor A N₁' N₂' ⊗ modTensor A N₁ N₂) => + t ≫ ((modTensor A N₁ N₂ ◁ + (interchange A N₁' N₂' N₁ N₂ ≫ + modTensorMap A d₁.pairMod d₂.pairMod ≫ + regPairFold A)) ≫ + actRight A (modTensorMod A N₁ N₂).X)) hα).trans <| + (Category.assoc _ _ _).trans <| + congrArg (fun t : (N₁.X ⊗ N₂.X) ⊗ + ((N₁'.X ⊗ N₂'.X) ⊗ (N₁.X ⊗ N₂.X)) ⟶ + modTensor A N₁ N₂ => + (α_ (N₁.X ⊗ N₂.X) (N₁'.X ⊗ N₂'.X) + (N₁.X ⊗ N₂.X)).hom ≫ t) hslot + refine Eq.trans (congrArg (fun s : ((N₁.X ⊗ N₂.X) ⊗ + (N₁'.X ⊗ N₂'.X)) ⊗ (N₁.X ⊗ N₂.X) ⟶ + modTensor A N₁ N₂ => + tensorμ N₁.X N₁'.X N₂.X N₂'.X ▷ (N₁.X ⊗ N₂.X) ≫ s) + hstep) ?_ + have hL : (modTensorπ A N₁ N₂ ⊗ₘ + (tensorμ N₁'.X N₂'.X N₁.X N₂.X ≫ + ((modTensorπ A N₁' N₁ ≫ d₁.pair) ⊗ₘ + (modTensorπ A N₂' N₂ ≫ d₂.pair)) ≫ μ[A])) ≫ + actRight A (modTensorMod A N₁ N₂).X = + ((N₁.X ⊗ N₂.X) ◁ + (tensorμ N₁'.X N₂'.X N₁.X N₂.X ≫ + ((modTensorπ A N₁' N₁ ≫ d₁.pair) ⊗ₘ + (modTensorπ A N₂' N₂ ≫ d₂.pair)) ≫ μ[A])) ≫ + (β_ (N₁.X ⊗ N₂.X) A).hom ≫ + (A ◁ modTensorπ A N₁ N₂) ≫ modTensorAct A N₁ N₂ := by + change (modTensorπ A N₁ N₂ ⊗ₘ + (tensorμ N₁'.X N₂'.X N₁.X N₂.X ≫ + ((modTensorπ A N₁' N₁ ≫ d₁.pair) ⊗ₘ + (modTensorπ A N₂' N₂ ≫ d₂.pair)) ≫ μ[A])) ≫ + (β_ (modTensor A N₁ N₂) A).hom ≫ + modTensorAct A N₁ N₂ = _ + rw [← Category.assoc, + BraidedCategory.braiding_naturality, Category.assoc, + MonoidalCategory.tensorHom_def, ← Category.assoc, + ← Category.assoc, + ← BraidedCategory.braiding_naturality_right] + simp only [Category.assoc] + refine Eq.trans (congrArg (fun t : (N₁.X ⊗ N₂.X) ⊗ + ((N₁'.X ⊗ N₂'.X) ⊗ (N₁.X ⊗ N₂.X)) ⟶ + modTensor A N₁ N₂ => + tensorμ N₁.X N₁'.X N₂.X N₂'.X ▷ (N₁.X ⊗ N₂.X) ≫ + ((α_ (N₁.X ⊗ N₂.X) (N₁'.X ⊗ N₂'.X) + (N₁.X ⊗ N₂.X)).hom ≫ t)) hL) ?_ + have hR := zigContract_tensor_components_raw A d₁ d₂ + refine Eq.trans ?_ hR.symm + conv_lhs => rw [MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + conv_lhs => rw [reassoc_of% (tensorMu_assoc_swap + N₁.X N₁'.X N₂.X N₂'.X N₁.X N₂.X)] + have hμnat₂ : ((N₁.X ◁ (modTensorπ A N₁' N₁ ≫ d₁.pair)) ⊗ₘ + (N₂.X ◁ (modTensorπ A N₂' N₂ ≫ d₂.pair))) ≫ + tensorμ N₁.X A N₂.X A = + tensorμ N₁.X (N₁'.X ⊗ N₁.X) N₂.X (N₂'.X ⊗ N₂.X) ≫ + ((N₁.X ⊗ N₂.X) ◁ + ((modTensorπ A N₁' N₁ ≫ d₁.pair) ⊗ₘ + (modTensorπ A N₂' N₂ ≫ d₂.pair))) := by + simpa using tensorμ_natural (𝟙 N₁.X) + (modTensorπ A N₁' N₁ ≫ d₁.pair) (𝟙 N₂.X) + (modTensorπ A N₂' N₂ ≫ d₂.pair) + have hβl : (modTensorπ A N₁ N₂ ▷ A) ≫ + (β_ (modTensor A N₁ N₂) A).hom = + (β_ (N₁.X ⊗ N₂.X) A).hom ≫ (A ◁ modTensorπ A N₁ N₂) := + BraidedCategory.braiding_naturality_left + (modTensorπ A N₁ N₂) A + conv_rhs => rw [reassoc_of% hμnat₂, reassoc_of% hβl] + +/-- **The tensor contraction against the interchange is the +tensor of the component contractions**, zag side: the crossing +seats each dual half against its own carrier. -/ +theorem interchange_zagContract + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {N₁ : Mod D A} {N₂ : Mod D A} + {N₁' : Mod D A} {N₂' : Mod D A} + (d₁ : ModDualityDatum A N₁ N₁') + (d₂ : ModDualityDatum A N₂ N₂') : + (modTensorπ A N₁' N₂' ▷ + (modTensor A N₁ N₁' ⊗ modTensor A N₂ N₂')) ≫ + (modTensor A N₁' N₂' ◁ interchange A N₁ N₁' N₂ N₂') ≫ + zagContract A (tensorDatum A d₁ d₂).pair + (tensorDatum A d₁ d₂).pair_linear = + tensorμ N₁'.X N₂'.X (modTensor A N₁ N₁') + (modTensor A N₂ N₂') ≫ + (zagContract A d₁.pair d₁.pair_linear ⊗ₘ + zagContract A d₂.pair d₂.pair_linear) ≫ + modTensorπ A N₁' N₂' := by + refine (cancel_epi + ((N₁'.X ⊗ N₂'.X) ◁ + (modTensorπ A N₁ N₁' ⊗ₘ modTensorπ A N₂ N₂'))).mp ?_ + have hpair : (tensorDatum A d₁ d₂).pair = + interchangeDesc A N₁' N₂' N₁ N₂ ≫ + modTensorMap A d₁.pairMod d₂.pairMod ≫ + regPairFold A := rfl + have hinner : modTensorπ A (modTensorMod A N₁' N₂') + (modTensorMod A N₁ N₂) ≫ (tensorDatum A d₁ d₂).pair = + interchange A N₁' N₂' N₁ N₂ ≫ + modTensorMap A d₁.pairMod d₂.pairMod ≫ + regPairFold A := by + rw [hpair, ← Category.assoc, modTensorπ_interchangeDesc] + rfl + conv_lhs => erw [whisker_exchange_assoc + (modTensorπ A N₁' N₂') + (modTensorπ A N₁ N₁' ⊗ₘ modTensorπ A N₂ N₂'), + ← MonoidalCategory.whiskerLeft_comp_assoc, + tensorHom_π_interchange, rawInterchangeπ, rawInterchange] + have hzagdef : (MonoidalCategory.whiskerLeft + (modTensor A N₁' N₂') + (modTensorπ A (modTensorMod A N₁ N₂) + (modTensorMod A N₁' N₂'))) ≫ + zagContract A (tensorDatum A d₁ d₂).pair + (tensorDatum A d₁ d₂).pair_linear = + (α_ (modTensorMod A N₁' N₂').X (modTensorMod A N₁ N₂).X + (modTensorMod A N₁' N₂').X).inv ≫ + ((modTensorπ A (modTensorMod A N₁' N₂') + (modTensorMod A N₁ N₂) ≫ + (tensorDatum A d₁ d₂).pair) ▷ + (modTensorMod A N₁' N₂').X) ≫ + actLeft A (modTensorMod A N₁' N₂').X := + whiskerLeft_modTensorπ_zagContract A + (tensorDatum A d₁ d₂).pair + (tensorDatum A d₁ d₂).pair_linear + conv_lhs => erw [ + MonoidalCategory.whiskerLeft_comp _ (tensorμ N₁.X N₁'.X N₂.X N₂'.X) + ((modTensorπ A N₁ N₂ ⊗ₘ modTensorπ A N₁' N₂') ≫ (modTensorπ A (modTensorMod A N₁ N₂) + (modTensorMod A N₁' N₂'))), + MonoidalCategory.whiskerLeft_comp _ (modTensorπ A N₁ N₂ ⊗ₘ modTensorπ A N₁' N₂') + (modTensorπ A (modTensorMod A N₁ N₂) (modTensorMod A N₁' N₂')), + Category.assoc, Category.assoc] + refine Eq.trans (congrArg + (fun t : modTensor A N₁' N₂' ⊗ + (modTensor A N₁ N₂ ⊗ modTensor A N₁' N₂') ⟶ + modTensor A N₁' N₂' => + (modTensorπ A N₁' N₂' ▷ + ((N₁.X ⊗ N₁'.X) ⊗ (N₂.X ⊗ N₂'.X))) ≫ + ((modTensor A N₁' N₂' ◁ + tensorμ N₁.X N₁'.X N₂.X N₂'.X) ≫ + ((modTensor A N₁' N₂' ◁ + (modTensorπ A N₁ N₂ ⊗ₘ modTensorπ A N₁' N₂')) ≫ + t))) hzagdef) ?_ + conv_lhs => rw [hinner] + conv_lhs => erw [← whisker_exchange_assoc + (modTensorπ A N₁' N₂') + (tensorμ N₁.X N₁'.X N₂.X N₂'.X), + ← whisker_exchange_assoc (modTensorπ A N₁' N₂') + (modTensorπ A N₁ N₂ ⊗ₘ modTensorπ A N₁' N₂')] + -- The inner contraction word, fully reduced at the fold. + have hw := tensorDatum_pair_rawInterchange A d₁ d₂ + conv_lhs => erw [← reassoc_of% (MonoidalCategory.tensorHom_def' + (modTensorπ A N₁' N₂') + (modTensorπ A N₁ N₂ ⊗ₘ modTensorπ A N₁' N₂'))] + have hα : (modTensorπ A N₁' N₂' ⊗ₘ + (modTensorπ A N₁ N₂ ⊗ₘ modTensorπ A N₁' N₂')) ≫ + (α_ (modTensor A N₁' N₂') (modTensor A N₁ N₂) + (modTensor A N₁' N₂')).inv = + (α_ (N₁'.X ⊗ N₂'.X) (N₁.X ⊗ N₂.X) + (N₁'.X ⊗ N₂'.X)).inv ≫ + ((modTensorπ A N₁' N₂' ⊗ₘ modTensorπ A N₁ N₂) ⊗ₘ + modTensorπ A N₁' N₂') := + associator_inv_naturality (modTensorπ A N₁' N₂') + (modTensorπ A N₁ N₂) (modTensorπ A N₁' N₂') + have hbig : ((modTensorπ A N₁' N₂' ⊗ₘ modTensorπ A N₁ N₂) ⊗ₘ + modTensorπ A N₁' N₂') ≫ + ((interchange A N₁' N₂' N₁ N₂ ≫ + modTensorMap A d₁.pairMod d₂.pairMod ≫ + regPairFold A) ▷ modTensor A N₁' N₂') = + (tensorμ N₁'.X N₂'.X N₁.X N₂.X ≫ + ((modTensorπ A N₁' N₁ ≫ d₁.pair) ⊗ₘ + (modTensorπ A N₂' N₂ ≫ d₂.pair)) ≫ μ[A]) ⊗ₘ + modTensorπ A N₁' N₂' := by + rw [← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.comp_id] + exact congrArg (fun t : (N₁'.X ⊗ N₂'.X) ⊗ (N₁.X ⊗ N₂.X) ⟶ + A => t ⊗ₘ modTensorπ A N₁' N₂') hw + have hslot : ((modTensorπ A N₁' N₂' ⊗ₘ modTensorπ A N₁ N₂) ⊗ₘ + modTensorπ A N₁' N₂') ≫ + (((interchange A N₁' N₂' N₁ N₂ ≫ + modTensorMap A d₁.pairMod d₂.pairMod ≫ + regPairFold A) ▷ modTensor A N₁' N₂') ≫ + actLeft A (modTensorMod A N₁' N₂').X) = + ((tensorμ N₁'.X N₂'.X N₁.X N₂.X ≫ + ((modTensorπ A N₁' N₁ ≫ d₁.pair) ⊗ₘ + (modTensorπ A N₂' N₂ ≫ d₂.pair)) ≫ μ[A]) ⊗ₘ + modTensorπ A N₁' N₂') ≫ + actLeft A (modTensorMod A N₁' N₂').X := + (Category.assoc _ _ _).symm.trans + (congrArg (fun t : ((N₁'.X ⊗ N₂'.X) ⊗ (N₁.X ⊗ N₂.X)) ⊗ + (N₁'.X ⊗ N₂'.X) ⟶ A ⊗ modTensor A N₁' N₂' => + t ≫ actLeft A (modTensorMod A N₁' N₂').X) hbig) + have hstep : (modTensorπ A N₁' N₂' ⊗ₘ + (modTensorπ A N₁ N₂ ⊗ₘ modTensorπ A N₁' N₂')) ≫ + ((α_ (modTensor A N₁' N₂') (modTensor A N₁ N₂) + (modTensor A N₁' N₂')).inv ≫ + (((interchange A N₁' N₂' N₁ N₂ ≫ + modTensorMap A d₁.pairMod d₂.pairMod ≫ + regPairFold A) ▷ modTensor A N₁' N₂') ≫ + actLeft A (modTensorMod A N₁' N₂').X)) = + (α_ (N₁'.X ⊗ N₂'.X) (N₁.X ⊗ N₂.X) + (N₁'.X ⊗ N₂'.X)).inv ≫ + (((tensorμ N₁'.X N₂'.X N₁.X N₂.X ≫ + ((modTensorπ A N₁' N₁ ≫ d₁.pair) ⊗ₘ + (modTensorπ A N₂' N₂ ≫ d₂.pair)) ≫ μ[A]) ⊗ₘ + modTensorπ A N₁' N₂') ≫ + actLeft A (modTensorMod A N₁' N₂').X) := + (Category.assoc _ _ _).symm.trans <| + (congrArg (fun t : ((N₁'.X ⊗ N₂'.X) ⊗ + ((N₁.X ⊗ N₂.X) ⊗ (N₁'.X ⊗ N₂'.X))) ⟶ + (modTensor A N₁' N₂' ⊗ modTensor A N₁ N₂) ⊗ + modTensor A N₁' N₂' => + t ≫ (((interchange A N₁' N₂' N₁ N₂ ≫ + modTensorMap A d₁.pairMod d₂.pairMod ≫ + regPairFold A) ▷ modTensor A N₁' N₂') ≫ + actLeft A (modTensorMod A N₁' N₂').X)) hα).trans <| + (Category.assoc _ _ _).trans <| + congrArg (fun t : ((N₁'.X ⊗ N₂'.X) ⊗ (N₁.X ⊗ N₂.X)) ⊗ + (N₁'.X ⊗ N₂'.X) ⟶ modTensor A N₁' N₂' => + (α_ (N₁'.X ⊗ N₂'.X) (N₁.X ⊗ N₂.X) + (N₁'.X ⊗ N₂'.X)).inv ≫ t) hslot + refine Eq.trans (congrArg (fun s : (N₁'.X ⊗ N₂'.X) ⊗ + ((N₁.X ⊗ N₂.X) ⊗ (N₁'.X ⊗ N₂'.X)) ⟶ + modTensor A N₁' N₂' => + ((N₁'.X ⊗ N₂'.X) ◁ tensorμ N₁.X N₁'.X N₂.X N₂'.X) ≫ s) + hstep) ?_ + have hL : ((tensorμ N₁'.X N₂'.X N₁.X N₂.X ≫ + ((modTensorπ A N₁' N₁ ≫ d₁.pair) ⊗ₘ + (modTensorπ A N₂' N₂ ≫ d₂.pair)) ≫ μ[A]) ⊗ₘ + modTensorπ A N₁' N₂') ≫ + actLeft A (modTensorMod A N₁' N₂').X = + ((tensorμ N₁'.X N₂'.X N₁.X N₂.X ≫ + ((modTensorπ A N₁' N₁ ≫ d₁.pair) ⊗ₘ + (modTensorπ A N₂' N₂ ≫ d₂.pair)) ≫ μ[A]) ▷ + (N₁'.X ⊗ N₂'.X)) ≫ + (A ◁ modTensorπ A N₁' N₂') ≫ + modTensorAct A N₁' N₂' := by + change ((tensorμ N₁'.X N₂'.X N₁.X N₂.X ≫ + ((modTensorπ A N₁' N₁ ≫ d₁.pair) ⊗ₘ + (modTensorπ A N₂' N₂ ≫ d₂.pair)) ≫ μ[A]) ⊗ₘ + modTensorπ A N₁' N₂') ≫ + modTensorAct A N₁' N₂' = _ + rw [MonoidalCategory.tensorHom_def, Category.assoc] + refine Eq.trans (congrArg (fun t : ((N₁'.X ⊗ N₂'.X) ⊗ + (N₁.X ⊗ N₂.X)) ⊗ (N₁'.X ⊗ N₂'.X) ⟶ + modTensor A N₁' N₂' => + ((N₁'.X ⊗ N₂'.X) ◁ tensorμ N₁.X N₁'.X N₂.X N₂'.X) ≫ + ((α_ (N₁'.X ⊗ N₂'.X) (N₁.X ⊗ N₂.X) + (N₁'.X ⊗ N₂'.X)).inv ≫ t)) hL) ?_ + have hR := zagContract_tensor_components_raw A d₁ d₂ + refine Eq.trans ?_ hR.symm + conv_lhs => rw [comp_whiskerRight, comp_whiskerRight] + simp only [Category.assoc] + conv_lhs => rw [reassoc_of% (tensorMu_assoc_swap_inv + N₁'.X N₂'.X N₁.X N₁'.X N₂.X N₂'.X)] + have hμnat₂ : (((modTensorπ A N₁' N₁ ≫ d₁.pair) ▷ N₁'.X) ⊗ₘ + ((modTensorπ A N₂' N₂ ≫ d₂.pair) ▷ N₂'.X)) ≫ + tensorμ A N₁'.X A N₂'.X = + tensorμ (N₁'.X ⊗ N₁.X) N₁'.X (N₂'.X ⊗ N₂.X) N₂'.X ≫ + (((modTensorπ A N₁' N₁ ≫ d₁.pair) ⊗ₘ + (modTensorπ A N₂' N₂ ≫ d₂.pair)) ▷ + (N₁'.X ⊗ N₂'.X)) := by + simpa using tensorμ_natural + (modTensorπ A N₁' N₁ ≫ d₁.pair) (𝟙 N₁'.X) + (modTensorπ A N₂' N₂ ≫ d₂.pair) (𝟙 N₂'.X) + conv_rhs => rw [reassoc_of% hμnat₂] + +/-- **The tensor datum inherits the carrier zig identity.** -/ +theorem tensorDatum_carrier_zig + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {N₁ : Mod D A} {N₂ : Mod D A} + {N₁' : Mod D A} {N₂' : Mod D A} + (d₁ : ModDualityDatum A N₁ N₁') + (d₂ : ModDualityDatum A N₂ N₂') + (hz₁ : (λ_ N₁.X).inv ≫ ((η[A] ≫ d₁.copair) ▷ N₁.X) ≫ + zigContract A d₁.pair d₁.pair_linear = 𝟙 N₁.X) + (hz₂ : (λ_ N₂.X).inv ≫ ((η[A] ≫ d₂.copair) ▷ N₂.X) ≫ + zigContract A d₂.pair d₂.pair_linear = 𝟙 N₂.X) : + (λ_ (modTensor A N₁ N₂)).inv ≫ + ((η[A] ≫ (tensorDatum A d₁ d₂).copair) ▷ + modTensor A N₁ N₂) ≫ + zigContract A (tensorDatum A d₁ d₂).pair + (tensorDatum A d₁ d₂).pair_linear = + 𝟙 (modTensor A N₁ N₂) := by + have hpt₁ : (η[A] ≫ d₁.copair) ▷ N₁.X ≫ + zigContract A d₁.pair d₁.pair_linear = + (λ_ N₁.X).hom := by + have h := congrArg (fun t => (λ_ N₁.X).hom ≫ t) hz₁ + simpa using h + have hpt₂ : (η[A] ≫ d₂.copair) ▷ N₂.X ≫ + zigContract A d₂.pair d₂.pair_linear = + (λ_ N₂.X).hom := by + have h := congrArg (fun t => (λ_ N₂.X).hom ≫ t) hz₂ + simpa using h + apply modTensor_hom_ext A N₁ N₂ + have hslide : modTensorπ A N₁ N₂ ≫ + (λ_ (modTensor A N₁ N₂)).inv ≫ + ((η[A] ≫ (tensorDatum A d₁ d₂).copair) ▷ + modTensor A N₁ N₂) = + (λ_ (N₁.X ⊗ N₂.X)).inv ≫ + ((η[A] ≫ (tensorDatum A d₁ d₂).copair) ▷ + (N₁.X ⊗ N₂.X)) ≫ + ((modTensor A (modTensorMod A N₁ N₂) + (modTensorMod A N₁' N₂')) ◁ modTensorπ A N₁ N₂) := by + rw [leftUnitor_inv_naturality_assoc, whisker_exchange] + have hcop : (tensorDatum A d₁ d₂).copair = + tensorCopair A d₁ d₂ := rfl + erw [← Category.assoc, ← Category.assoc, Category.assoc + (modTensorπ A N₁ N₂), hslide, hcop, tensorCopair_point, + Category.assoc, Category.assoc] + have hμnat : ((η[A] ≫ d₁.copair ⊗ₘ η[A] ≫ d₂.copair) ▷ + (N₁.X ⊗ N₂.X)) ≫ + tensorμ (modTensor A N₁ N₁') (modTensor A N₂ N₂') + N₁.X N₂.X = + tensorμ (𝟙_ D) (𝟙_ D) N₁.X N₂.X ≫ + (((η[A] ≫ d₁.copair) ▷ N₁.X) ⊗ₘ + ((η[A] ≫ d₂.copair) ▷ N₂.X)) := by + simpa using tensorμ_natural (η[A] ≫ d₁.copair) + (η[A] ≫ d₂.copair) (𝟙 N₁.X) (𝟙 N₂.X) + have hcoh : (λ_ (N₁.X ⊗ N₂.X)).inv ≫ + ((λ_ (𝟙_ D)).inv ▷ (N₁.X ⊗ N₂.X)) ≫ + tensorμ (𝟙_ D) (𝟙_ D) N₁.X N₂.X ≫ + ((λ_ N₁.X).hom ⊗ₘ (λ_ N₂.X).hom) = 𝟙 (N₁.X ⊗ N₂.X) := by + simp only [tensorμ, braiding_tensorUnit_left] + monoidal + rw [comp_whiskerRight] + rw [comp_whiskerRight] + rw [Category.assoc, Category.assoc] + erw [← whisker_exchange_assoc + (interchange A N₁ N₁' N₂ N₂') (modTensorπ A N₁ N₂)] + rw [interchange_zigContract A d₁ d₂] + have hfinal : (λ_ (N₁.X ⊗ N₂.X)).inv ≫ + ((λ_ (𝟙_ D)).inv ▷ (N₁.X ⊗ N₂.X)) ≫ + ((η[A] ≫ d₁.copair ⊗ₘ η[A] ≫ d₂.copair) ▷ + (N₁.X ⊗ N₂.X)) ≫ + tensorμ (modTensor A N₁ N₁') (modTensor A N₂ N₂') + N₁.X N₂.X ≫ + (zigContract A d₁.pair d₁.pair_linear ⊗ₘ + zigContract A d₂.pair d₂.pair_linear) ≫ + modTensorπ A N₁ N₂ = + modTensorπ A N₁ N₂ ≫ 𝟙 (modTensor A N₁ N₂) := by + rw [reassoc_of% hμnat, + MonoidalCategory.tensorHom_comp_tensorHom_assoc, + hpt₁, hpt₂, reassoc_of% hcoh, Category.comp_id] + exact hfinal + +/-- **The tensor datum inherits the carrier zag identity.** -/ +theorem tensorDatum_carrier_zag + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {N₁ : Mod D A} {N₂ : Mod D A} + {N₁' : Mod D A} {N₂' : Mod D A} + (d₁ : ModDualityDatum A N₁ N₁') + (d₂ : ModDualityDatum A N₂ N₂') + (hz₁ : (ρ_ N₁'.X).inv ≫ (N₁'.X ◁ (η[A] ≫ d₁.copair)) ≫ + zagContract A d₁.pair d₁.pair_linear = 𝟙 N₁'.X) + (hz₂ : (ρ_ N₂'.X).inv ≫ (N₂'.X ◁ (η[A] ≫ d₂.copair)) ≫ + zagContract A d₂.pair d₂.pair_linear = 𝟙 N₂'.X) : + (ρ_ (modTensor A N₁' N₂')).inv ≫ + (modTensor A N₁' N₂' ◁ + (η[A] ≫ (tensorDatum A d₁ d₂).copair)) ≫ + zagContract A (tensorDatum A d₁ d₂).pair + (tensorDatum A d₁ d₂).pair_linear = + 𝟙 (modTensor A N₁' N₂') := by + have hpt₁ : N₁'.X ◁ (η[A] ≫ d₁.copair) ≫ + zagContract A d₁.pair d₁.pair_linear = + (ρ_ N₁'.X).hom := by + have h := congrArg (fun t => (ρ_ N₁'.X).hom ≫ t) hz₁ + simpa using h + have hpt₂ : N₂'.X ◁ (η[A] ≫ d₂.copair) ≫ + zagContract A d₂.pair d₂.pair_linear = + (ρ_ N₂'.X).hom := by + have h := congrArg (fun t => (ρ_ N₂'.X).hom ≫ t) hz₂ + simpa using h + apply modTensor_hom_ext A N₁' N₂' + have hslide : modTensorπ A N₁' N₂' ≫ + (ρ_ (modTensor A N₁' N₂')).inv ≫ + (modTensor A N₁' N₂' ◁ + (η[A] ≫ (tensorDatum A d₁ d₂).copair)) = + (ρ_ (N₁'.X ⊗ N₂'.X)).inv ≫ + ((N₁'.X ⊗ N₂'.X) ◁ + (η[A] ≫ (tensorDatum A d₁ d₂).copair)) ≫ + (modTensorπ A N₁' N₂' ▷ + (modTensor A (modTensorMod A N₁ N₂) + (modTensorMod A N₁' N₂'))) := by + rw [rightUnitor_inv_naturality_assoc, ← whisker_exchange] + have hcop : (tensorDatum A d₁ d₂).copair = + tensorCopair A d₁ d₂ := rfl + erw [← Category.assoc, ← Category.assoc, Category.assoc + (modTensorπ A N₁' N₂'), hslide, hcop, tensorCopair_point, + Category.assoc, Category.assoc] + have hμnat : ((N₁'.X ⊗ N₂'.X) ◁ + (η[A] ≫ d₁.copair ⊗ₘ η[A] ≫ d₂.copair)) ≫ + tensorμ N₁'.X N₂'.X (modTensor A N₁ N₁') + (modTensor A N₂ N₂') = + tensorμ N₁'.X N₂'.X (𝟙_ D) (𝟙_ D) ≫ + ((N₁'.X ◁ (η[A] ≫ d₁.copair)) ⊗ₘ + (N₂'.X ◁ (η[A] ≫ d₂.copair))) := by + simpa using tensorμ_natural (𝟙 N₁'.X) (𝟙 N₂'.X) + (η[A] ≫ d₁.copair) (η[A] ≫ d₂.copair) + have hcoh : (ρ_ (N₁'.X ⊗ N₂'.X)).inv ≫ + ((N₁'.X ⊗ N₂'.X) ◁ (λ_ (𝟙_ D)).inv) ≫ + tensorμ N₁'.X N₂'.X (𝟙_ D) (𝟙_ D) ≫ + ((ρ_ N₁'.X).hom ⊗ₘ (ρ_ N₂'.X).hom) = + 𝟙 (N₁'.X ⊗ N₂'.X) := by + simp only [tensorμ, braiding_tensorUnit_right] + monoidal + rw [MonoidalCategory.whiskerLeft_comp] + rw [MonoidalCategory.whiskerLeft_comp] + rw [Category.assoc, Category.assoc] + erw [whisker_exchange_assoc + (modTensorπ A N₁' N₂') (interchange A N₁ N₁' N₂ N₂')] + rw [interchange_zagContract A d₁ d₂] + have hfinal : (ρ_ (N₁'.X ⊗ N₂'.X)).inv ≫ + ((N₁'.X ⊗ N₂'.X) ◁ (λ_ (𝟙_ D)).inv) ≫ + ((N₁'.X ⊗ N₂'.X) ◁ + (η[A] ≫ d₁.copair ⊗ₘ η[A] ≫ d₂.copair)) ≫ + tensorμ N₁'.X N₂'.X (modTensor A N₁ N₁') + (modTensor A N₂ N₂') ≫ + (zagContract A d₁.pair d₁.pair_linear ⊗ₘ + zagContract A d₂.pair d₂.pair_linear) ≫ + modTensorπ A N₁' N₂' = + modTensorπ A N₁' N₂' ≫ 𝟙 (modTensor A N₁' N₂') := by + rw [reassoc_of% hμnat, + MonoidalCategory.tensorHom_comp_tensorHom_assoc, + hpt₁, hpt₂, reassoc_of% hcoh, Category.comp_id] + exact hfinal + +/-- **The tensor of zigzag data is a zigzag datum** (Deligne +1.15, tensor part, in triangle form). -/ +theorem tensorDatum_zigzag + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {N₁ : Mod D A} {N₂ : Mod D A} + {N₁' : Mod D A} {N₂' : Mod D A} + (d₁ : ModDualityDatum A N₁ N₁') + (d₂ : ModDualityDatum A N₂ N₂') + (hz₁ : ModZigzagDatum A d₁) (hz₂ : ModZigzagDatum A d₂) : + ModZigzagDatum A (tensorDatum A d₁ d₂) := + modZigzagDatum_of_carrier A + (tensorDatum_carrier_zig A d₁ d₂ + (zigzag_carrier_zig A hz₁) (zigzag_carrier_zig A hz₂)) + (tensorDatum_carrier_zag A d₁ d₂ + (zigzag_carrier_zag A hz₁) (zigzag_carrier_zag A hz₂)) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TrichotomyClose.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TrichotomyClose.lean new file mode 100644 index 0000000000..e9be1a0420 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TrichotomyClose.lean @@ -0,0 +1,179 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchur +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29State + +/-! +# The trichotomy, closed over a descent + +The case analysis of the dévissage trichotomy: over any state, +classically either all symmetric powers of the remainder survive, +or all alternating powers survive, or some power of each dies — +and then the Schur collapse and the power descent kill the +remainder. The descent is a parameter, discharged by the +sandwich retract. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +/-- The antisymmetriser at arity one is the identity. -/ +theorem antisymmetriser_one : antisymmetriser 1 = 1 := by + rw [antisymmetriser] + rw [show (Finset.univ : Finset (Equiv.Perm (Fin 1))) = + {1} from Finset.eq_singleton_iff_unique_mem.mpr + ⟨Finset.mem_univ _, fun σ _ => + Subsingleton.elim σ 1⟩] + simp [MonoidAlgebra.one_def] + +/-- The antisymmetriser at arity zero is the identity. -/ +theorem antisymmetriser_zero : antisymmetriser 0 = 1 := by + rw [antisymmetriser] + rw [show (Finset.univ : Finset (Equiv.Perm (Fin 0))) = + {1} from Finset.eq_singleton_iff_unique_mem.mpr + ⟨Finset.mem_univ _, fun σ _ => + Subsingleton.elim σ 1⟩] + simp [MonoidAlgebra.one_def] + +variable {D : Type u} + +/-- A dead arity-one symmetric power kills the module. -/ +theorem isZero_of_isZero_symPowOne + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] + (A : D) [MonObj A] (X : D) [ModObj A X] + (h : IsZero (symPow A X 1)) : IsZero X := by + have h0 : symPowIdem A X 1 = 0 := + (symPowIdem_eq_zero_iff A X 1).mpr h + rw [show symPowIdem A X 1 = + modPowAlg A X 1 (symmetriser 1) from rfl, + symmetriser_one, map_one] at h0 + have hm : IsZero (modPow A X 1) := by + rw [Limits.IsZero.iff_id_eq_zero] + exact h0 + exact hm.of_iso (modPowOne A X).symm + +/-- A dead arity-one alternating power kills the module. -/ +theorem isZero_of_isZero_altPow_one + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] + (A : D) [MonObj A] (X : D) [ModObj A X] + (h : IsZero (altPow A X 1)) : IsZero X := by + have h0 : altPowIdem A X 1 = 0 := + (altPowIdem_eq_zero_iff A X 1).mpr h + rw [show altPowIdem A X 1 = + modPowAlg A X 1 (antisymmetriser 1) from rfl, + antisymmetriser_one, map_one] at h0 + have hm : IsZero (modPow A X 1) := by + rw [Limits.IsZero.iff_id_eq_zero] + exact h0 + exact hm.of_iso (modPowOne A X).symm + +/-- A dead tensor unit kills every object. -/ +theorem isZero_of_isZero_unit + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] (X : D) + (h : IsZero (𝟙_ D)) : + IsZero X := + (isZero_whiskerLeft X h).of_iso (ρ_ X).symm + +/-- A dead arity-zero symmetric power kills the module. -/ +theorem isZero_of_isZero_symPowZero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] (A : D) [MonObj A] (X : D) [ModObj A X] + (h : IsZero (symPow A X 0)) : IsZero X := + isZero_of_isZero_unit X + (h.of_iso (symPowZero A X).symm) + +/-- A dead arity-zero alternating power kills the module. -/ +theorem isZero_of_isZero_altPow_zero + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] (A : D) [MonObj A] (X : D) [ModObj A X] + (h : IsZero (altPow A X 0)) : IsZero X := by + have h0 : altPowIdem A X 0 = 0 := + (altPowIdem_eq_zero_iff A X 0).mpr h + rw [show altPowIdem A X 0 = + modPowAlg A X 0 (antisymmetriser 0) from rfl, + antisymmetriser_zero, map_one] at h0 + have hm : IsZero (modPow A X 0) := by + rw [Limits.IsZero.iff_id_eq_zero] + exact h0 + exact isZero_of_isZero_unit X + (hm.of_iso (modPowZero A X).symm) + +section Main + +/-- **The trichotomy holds over a power descent**: classically, +either all symmetric powers of the remainder survive, or all +alternating powers survive, or the Schur collapse and the +descent kill the remainder. -/ +theorem devissageTrichotomy_of_descent + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (P : SchurPackage.{v}) + (L : OddLine D) (X : D) + (hdesc : ∀ (B : D) (_ : MonObj B) (_ : IsCommMonObj B) + (R R' : Mod D B) (d : ModDualityDatum B R R') + (_ : ModZigzagDatum B d) (k : ℕ), + IsZero (modPow B R.X (k + 2)) → IsZero R.X) : + DevissageTrichotomy D L X := by + intro st + let := st.monObj + let := st.comm + by_cases hS : ∀ n : ℕ, + ¬ IsZero (symPow st.base st.rest.X n) + · exact Or.inl hS + right + by_cases hA : ∀ n : ℕ, + ¬ IsZero (altPow st.base st.rest.X n) + · exact Or.inl hA + right + push Not at hS hA + obtain ⟨n₀, hn₀⟩ := hS + obtain ⟨m₀, hm₀⟩ := hA + match n₀, hn₀ with + | 0, hn => + exact isZero_of_isZero_symPowZero st.base st.rest.X hn + | 1, hn => + exact isZero_of_isZero_symPowOne st.base st.rest.X hn + | (n + 2), hn => + match m₀, hm₀ with + | 0, hm => + exact isZero_of_isZero_altPow_zero st.base + st.rest.X hm + | 1, hm => + exact isZero_of_isZero_altPow_one st.base + st.rest.X hm + | (m + 2), hm => + have hp : IsZero (modPow st.base st.rest.X + ((n + 1) * (m + 1) + 1)) := + isZero_modPow_of_isZero_sym_alt st.base st.rest.X + P (n := n + 1) (m := m + 1) hn hm + have hcast : ∀ {j k : ℕ}, j = k + 2 → + IsZero (modPow st.base st.rest.X j) → + IsZero (modPow st.base st.rest.X (k + 2)) := by + rintro j k rfl h + exact h + exact hdesc st.base _ _ st.rest st.restDual st.datum + st.zigzag (n * m + n + m) + (hcast (by ring) hp) + +end Main + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistBiprod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistBiprod.lean new file mode 100644 index 0000000000..6690168bfc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistBiprod.lean @@ -0,0 +1,298 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistShuffle + +/-! +# Twisting distributes over the biproduct of modules + +Tensoring on the left by a fixed object distributes over the +biproduct of two modules. At the level of carriers this is the +standard distributivity of the tensor over a binary biproduct, +assembled from `biprod.lift` and `biprod.desc`; the two round-trips +use the totality relation of the biproduct together with the +additivity of the left whiskering. The distributivity map +intertwines the action through the right tensor factor with the +componentwise action of the biproduct, because each biproduct +projection is a module map and the twist of a module map is again +a module map. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## The carrier-level distributivity -/ + +section Carrier + +/-- **Distributivity of the tensor over a binary biproduct**: the +comparison map assembled from the two whiskered projections. -/ +noncomputable def tensorLeftBiprodHom + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (V : D) (X : D) (Y : D) : + V ⊗ (X ⊞ Y) ⟶ (V ⊗ X) ⊞ (V ⊗ Y) := + biprod.lift (V ◁ biprod.fst) (V ◁ biprod.snd) + +/-- The inverse comparison map, assembled from the two whiskered +injections. -/ +noncomputable def tensorLeftBiprodInv + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (V : D) (X : D) (Y : D) : + (V ⊗ X) ⊞ (V ⊗ Y) ⟶ V ⊗ (X ⊞ Y) := + biprod.desc (V ◁ biprod.inl) (V ◁ biprod.inr) + +@[simp] lemma tensorLeftBiprodHom_fst + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (V : D) (X : D) (Y : D) : + tensorLeftBiprodHom V X Y ≫ biprod.fst = V ◁ biprod.fst := + biprod.lift_fst _ _ + +@[simp] lemma tensorLeftBiprodHom_snd + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (V : D) (X : D) (Y : D) : + tensorLeftBiprodHom V X Y ≫ biprod.snd = V ◁ biprod.snd := + biprod.lift_snd _ _ + +@[simp] lemma inl_tensorLeftBiprodInv + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (V : D) (X : D) (Y : D) : + biprod.inl ≫ tensorLeftBiprodInv V X Y = V ◁ biprod.inl := + biprod.inl_desc _ _ + +@[simp] lemma inr_tensorLeftBiprodInv + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] (V : D) (X : D) (Y : D) : + biprod.inr ≫ tensorLeftBiprodInv V X Y = V ◁ biprod.inr := + biprod.inr_desc _ _ + +/-- The comparison map is split by its inverse: the totality +relation of the biproduct, whiskered. -/ +@[simp] theorem tensorLeftBiprodHom_inv + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] (V : D) (X : D) (Y : D) : + tensorLeftBiprodHom V X Y ≫ tensorLeftBiprodInv V X Y = + 𝟙 (V ⊗ (X ⊞ Y)) := by + rw [tensorLeftBiprodHom, tensorLeftBiprodInv, biprod.lift_desc, + ← MonoidalCategory.whiskerLeft_comp, + ← MonoidalCategory.whiskerLeft_comp, + ← MonoidalPreadditive.whiskerLeft_add, biprod.total, + MonoidalCategory.whiskerLeft_id] + +/-- The inverse comparison map is split by the comparison map. -/ +@[simp] theorem tensorLeftBiprodInv_hom + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] (V : D) (X : D) (Y : D) : + tensorLeftBiprodInv V X Y ≫ tensorLeftBiprodHom V X Y = + 𝟙 ((V ⊗ X) ⊞ (V ⊗ Y)) := by + refine biprod.hom_ext' _ _ ?_ ?_ + · rw [← Category.assoc, inl_tensorLeftBiprodInv, + Category.comp_id] + refine biprod.hom_ext _ _ ?_ ?_ + · rw [Category.assoc, tensorLeftBiprodHom_fst, + ← MonoidalCategory.whiskerLeft_comp, biprod.inl_fst, + MonoidalCategory.whiskerLeft_id, biprod.inl_fst] + · rw [Category.assoc, tensorLeftBiprodHom_snd, + ← MonoidalCategory.whiskerLeft_comp, biprod.inl_snd, + MonoidalPreadditive.whiskerLeft_zero, biprod.inl_snd] + · rw [← Category.assoc, inr_tensorLeftBiprodInv, + Category.comp_id] + refine biprod.hom_ext _ _ ?_ ?_ + · rw [Category.assoc, tensorLeftBiprodHom_fst, + ← MonoidalCategory.whiskerLeft_comp, biprod.inr_fst, + MonoidalPreadditive.whiskerLeft_zero, biprod.inr_fst] + · rw [Category.assoc, tensorLeftBiprodHom_snd, + ← MonoidalCategory.whiskerLeft_comp, biprod.inr_snd, + MonoidalCategory.whiskerLeft_id, biprod.inr_snd] + +end Carrier + +/-! ## The distributivity as a module isomorphism -/ + +section ModuleMap + +/-- **The twist of a module map is a module map**: a map +intertwining the actions still intertwines them after whiskering +by a fixed object on the left. -/ +theorem actAcross_whiskerLeft_of + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (V : D) + {X Y : D} [ModObj A X] [ModObj A Y] + (g : X ⟶ Y) + (hg : actLeft A X ≫ g = (A ◁ g) ≫ actLeft A Y) : + actAcross A V X ≫ (V ◁ g) = + (A ◁ (V ◁ g)) ≫ actAcross A V Y := by + rw [actAcross_eq_braidPast, actAcross_eq_braidPast, + Category.assoc, ← MonoidalCategory.whiskerLeft_comp, hg, + MonoidalCategory.whiskerLeft_comp, + braidPast_natural_tail_assoc] + +/-- The action on the twist of the module biproduct, retyped. -/ +noncomputable def twistBiprodActL + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] [SymmetricCategory D] (A : D) [MonObj A] (V : D) + (P : Mod D A) (Q : Mod D A) : + A ⊗ (V ⊗ (P.X ⊞ Q.X)) ⟶ V ⊗ (P.X ⊞ Q.X) := + actAcross A V (modBiprod A P Q).X + +/-- The componentwise action on the biproduct of the twists, +retyped. -/ +noncomputable def twistBiprodActR + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] [SymmetricCategory D] (A : D) [MonObj A] (V : D) + (P : Mod D A) (Q : Mod D A) : + A ⊗ ((V ⊗ P.X) ⊞ (V ⊗ Q.X)) ⟶ (V ⊗ P.X) ⊞ (V ⊗ Q.X) := + modBiprodAct A (tensorLeftMod A V P) (tensorLeftMod A V Q) + +/-- The twisted first projection intertwines the actions. -/ +theorem twistBiprodActL_fst + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] [SymmetricCategory D] (A : D) [MonObj A] (V : D) + (P : Mod D A) (Q : Mod D A) : + twistBiprodActL A V P Q ≫ + (V ◁ (biprod.fst : P.X ⊞ Q.X ⟶ P.X)) = + (A ◁ (V ◁ (biprod.fst : P.X ⊞ Q.X ⟶ P.X))) ≫ + actAcross A V P.X := by + let := modBiprodModObj A P Q + exact actAcross_whiskerLeft_of A V biprod.fst + (modBiprodAct_fst A P Q) + +/-- The twisted second projection intertwines the actions. -/ +theorem twistBiprodActL_snd + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] [SymmetricCategory D] (A : D) [MonObj A] (V : D) + (P : Mod D A) (Q : Mod D A) : + twistBiprodActL A V P Q ≫ + (V ◁ (biprod.snd : P.X ⊞ Q.X ⟶ Q.X)) = + (A ◁ (V ◁ (biprod.snd : P.X ⊞ Q.X ⟶ Q.X))) ≫ + actAcross A V Q.X := by + let := modBiprodModObj A P Q + exact actAcross_whiskerLeft_of A V biprod.snd + (modBiprodAct_snd A P Q) + +/-- The first component of the componentwise action. -/ +theorem twistBiprodActR_fst + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] [SymmetricCategory D] (A : D) [MonObj A] (V : D) + (P : Mod D A) (Q : Mod D A) : + twistBiprodActR A V P Q ≫ biprod.fst = + (A ◁ biprod.fst) ≫ actAcross A V P.X := + modBiprodAct_fst A (tensorLeftMod A V P) (tensorLeftMod A V Q) + +/-- The second component of the componentwise action. -/ +theorem twistBiprodActR_snd + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] [SymmetricCategory D] (A : D) [MonObj A] (V : D) + (P : Mod D A) (Q : Mod D A) : + twistBiprodActR A V P Q ≫ biprod.snd = + (A ◁ biprod.snd) ≫ actAcross A V Q.X := + modBiprodAct_snd A (tensorLeftMod A V P) (tensorLeftMod A V Q) + +/-- **The distributivity map is linear**: it intertwines the action +through the right tensor factor with the componentwise action of +the biproduct. -/ +theorem twistBiprodActL_hom + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] [SymmetricCategory D] (A : D) [MonObj A] (V : D) + (P : Mod D A) (Q : Mod D A) : + twistBiprodActL A V P Q ≫ tensorLeftBiprodHom V P.X Q.X = + (A ◁ tensorLeftBiprodHom V P.X Q.X) ≫ + twistBiprodActR A V P Q := by + refine biprod.hom_ext _ _ ?_ ?_ + · rw [Category.assoc, tensorLeftBiprodHom_fst, Category.assoc, + twistBiprodActR_fst, + ← MonoidalCategory.whiskerLeft_comp_assoc, + tensorLeftBiprodHom_fst] + exact twistBiprodActL_fst A V P Q + · rw [Category.assoc, tensorLeftBiprodHom_snd, Category.assoc, + twistBiprodActR_snd, + ← MonoidalCategory.whiskerLeft_comp_assoc, + tensorLeftBiprodHom_snd] + exact twistBiprodActL_snd A V P Q + +/-- **The inverse distributivity map is linear.** -/ +theorem twistBiprodActR_inv + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] [SymmetricCategory D] + (A : D) [MonObj A] (V : D) (P : Mod D A) (Q : Mod D A) : + twistBiprodActR A V P Q ≫ tensorLeftBiprodInv V P.X Q.X = + (A ◁ tensorLeftBiprodInv V P.X Q.X) ≫ + twistBiprodActL A V P Q := by + have : IsIso (tensorLeftBiprodHom V P.X Q.X) := + ⟨tensorLeftBiprodInv V P.X Q.X, + tensorLeftBiprodHom_inv V P.X Q.X, + tensorLeftBiprodInv_hom V P.X Q.X⟩ + rw [← cancel_mono (tensorLeftBiprodHom V P.X Q.X), + Category.assoc, Category.assoc, tensorLeftBiprodInv_hom, + Category.comp_id, twistBiprodActL_hom, ← Category.assoc, + ← MonoidalCategory.whiskerLeft_comp, tensorLeftBiprodInv_hom, + MonoidalCategory.whiskerLeft_id, Category.id_comp] + +/-- The distributivity map, as a module map. -/ +noncomputable def tensorLeftBiprodModHom + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] [SymmetricCategory D] (A : D) [MonObj A] (V : D) + (P : Mod D A) (Q : Mod D A) : + tensorLeftMod A V (modBiprod A P Q) ⟶ + modBiprod A (tensorLeftMod A V P) + (tensorLeftMod A V Q) := + Mod.Hom.mk' (tensorLeftBiprodHom V P.X Q.X) + (by exact twistBiprodActL_hom A V P Q) + +/-- The inverse distributivity map, as a module map. -/ +noncomputable def tensorLeftBiprodModInv + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] [SymmetricCategory D] + (A : D) [MonObj A] (V : D) (P : Mod D A) (Q : Mod D A) : + modBiprod A (tensorLeftMod A V P) (tensorLeftMod A V Q) ⟶ + tensorLeftMod A V (modBiprod A P Q) := + Mod.Hom.mk' (tensorLeftBiprodInv V P.X Q.X) + (by exact twistBiprodActR_inv A V P Q) + +@[simp] lemma tensorLeftBiprodModHom_hom + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [HasBinaryBiproducts D] [SymmetricCategory D] (A : D) [MonObj A] (V : D) + (P : Mod D A) (Q : Mod D A) : + (tensorLeftBiprodModHom A V P Q).hom = + tensorLeftBiprodHom V P.X Q.X := rfl + +@[simp] lemma tensorLeftBiprodModInv_hom + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] [SymmetricCategory D] + (A : D) [MonObj A] (V : D) (P : Mod D A) (Q : Mod D A) : + (tensorLeftBiprodModInv A V P Q).hom = + tensorLeftBiprodInv V P.X Q.X := rfl + +/-- **Twisting distributes over the biproduct of modules**: the +twist of a biproduct of modules is the biproduct of the twists. -/ +noncomputable def tensorLeftBiprodIso + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] [SymmetricCategory D] + (A : D) [MonObj A] + (V : D) (P Q : Mod D A) : + tensorLeftMod A V (modBiprod A P Q) ≅ + modBiprod A (tensorLeftMod A V P) + (tensorLeftMod A V Q) where + hom := tensorLeftBiprodModHom A V P Q + inv := tensorLeftBiprodModInv A V P Q + hom_inv_id := + Mod.hom_ext _ _ (tensorLeftBiprodHom_inv V P.X Q.X) + inv_hom_id := + Mod.hom_ext _ _ (tensorLeftBiprodInv_hom V P.X Q.X) + +end ModuleMap + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistCoherence.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistCoherence.lean new file mode 100644 index 0000000000..53e1f7629f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistCoherence.lean @@ -0,0 +1,141 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid + +/-! +# The twist-shuffle coherence + +The pure braid identity of the twist shuffle: routing the scalar +out of the first twisted factor, through the interchange, and +back into the middle equals associating it into the second factor +and interchanging. Two crossings cancel by symmetry. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +variable {D : Type u} + +/-- The twist-shuffle coherence: extracting `A` from the twisted +factor `V ⊗ R`, interchanging, and reinserting it between `R` and +`S` agrees with associating `A` into `W ⊗ S` and interchanging. +The block braiding `β_ (V ⊗ R) A` contributes crossings of `A` past +`R` and past `V`; the latter cancels against `β_ A V` by symmetry, +the former is conjugated through the interchange block by +naturality of the braiding and cancels against `(β_ R A).inv`, and +the residual word is the interchange of `V ⊗ R` with +`W ⊗ (A ⊗ S)`. -/ +@[reassoc] +theorem twist_shuffle_coherence + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (V R A W S : D) : + (β_ (V ⊗ R) A).hom ▷ (W ⊗ S) ≫ + (α_ A V R).inv ▷ (W ⊗ S) ≫ + (β_ A V).hom ▷ R ▷ (W ⊗ S) ≫ + (α_ V A R).hom ▷ (W ⊗ S) ≫ + tensorμ V (A ⊗ R) W S ≫ + ((V ⊗ W) ◁ ((β_ R A).inv ▷ S)) ≫ + ((V ⊗ W) ◁ (α_ R A S).hom) = + (α_ (V ⊗ R) A (W ⊗ S)).hom ≫ + ((V ⊗ R) ◁ (α_ A W S).inv) ≫ + ((V ⊗ R) ◁ ((β_ A W).hom ▷ S)) ≫ + ((V ⊗ R) ◁ (α_ W A S).hom) ≫ + tensorμ V R W (A ⊗ S) := by + calc + (β_ (V ⊗ R) A).hom ▷ (W ⊗ S) ≫ + (α_ A V R).inv ▷ (W ⊗ S) ≫ + (β_ A V).hom ▷ R ▷ (W ⊗ S) ≫ + (α_ V A R).hom ▷ (W ⊗ S) ≫ + tensorμ V (A ⊗ R) W S ≫ + ((V ⊗ W) ◁ ((β_ R A).inv ▷ S)) ≫ + ((V ⊗ W) ◁ (α_ R A S).hom) + = 𝟙 _ ⊗≫ (V ◁ (β_ R A).hom) ▷ (W ⊗ S) ⊗≫ + (((β_ V A).hom ≫ (β_ A V).hom) ▷ R) ▷ (W ⊗ S) ⊗≫ + V ◁ ((β_ (A ⊗ R) W).hom ▷ S) ⊗≫ + (V ⊗ W) ◁ ((β_ R A).inv ▷ S) ⊗≫ 𝟙 _ := by + dsimp only [tensorμ] + rw [BraidedCategory.braiding_tensor_left_hom V R A] + monoidal + _ = 𝟙 _ ⊗≫ + V ◁ (((β_ R A).hom ▷ W ≫ (β_ (A ⊗ R) W).hom) ▷ S) ⊗≫ + (V ⊗ W) ◁ ((β_ R A).inv ▷ S) ⊗≫ 𝟙 _ := by + rw [SymmetricCategory.symmetry V A] + monoidal + _ = 𝟙 _ ⊗≫ V ◁ ((β_ (R ⊗ A) W).hom ▷ S) ⊗≫ + (V ⊗ W) ◁ (((β_ R A).hom ≫ (β_ A R).hom) ▷ S) ⊗≫ + 𝟙 _ := by + rw [← SymmetricCategory.braiding_swap_eq_inv_braiding R A, + BraidedCategory.braiding_naturality_left (β_ R A).hom W] + monoidal + _ = 𝟙 _ ⊗≫ V ◁ ((β_ (R ⊗ A) W).hom ▷ S) ⊗≫ 𝟙 _ := by + rw [SymmetricCategory.symmetry R A] + monoidal + _ = (α_ (V ⊗ R) A (W ⊗ S)).hom ≫ + ((V ⊗ R) ◁ (α_ A W S).inv) ≫ + ((V ⊗ R) ◁ ((β_ A W).hom ▷ S)) ≫ + ((V ⊗ R) ◁ (α_ W A S).hom) ≫ + tensorμ V R W (A ⊗ S) := by + dsimp only [tensorμ] + rw [BraidedCategory.braiding_tensor_left_hom R A W] + monoidal + +/-- The twist-act coherence: extracting `A` from the twisted factor +`V ⊗ R` before the interchange agrees with interchanging first and +then extracting `A` from the product `V ⊗ W`. Both words consist +of the crossings of `A` past `V`, of `R` past `W`, and of `A` past +`W`, each occurring exactly once; the two sides differ only in the +order of the first two, which act on disjoint factors and are +exchanged as whiskerings. -/ +@[reassoc] +theorem twist_act_coherence + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (A V R W S : D) : + (α_ A (V ⊗ R) (W ⊗ S)).inv ≫ + (α_ A V R).inv ▷ (W ⊗ S) ≫ + ((β_ A V).hom ▷ R) ▷ (W ⊗ S) ≫ + (α_ V A R).hom ▷ (W ⊗ S) ≫ + tensorμ V (A ⊗ R) W S = + A ◁ tensorμ V R W S ≫ + (α_ A (V ⊗ W) (R ⊗ S)).inv ≫ + ((β_ A (V ⊗ W)).hom ▷ (R ⊗ S)) ≫ + (α_ (V ⊗ W) A (R ⊗ S)).hom ≫ + ((V ⊗ W) ◁ (α_ A R S).inv) := by + calc + (α_ A (V ⊗ R) (W ⊗ S)).inv ≫ + (α_ A V R).inv ▷ (W ⊗ S) ≫ + ((β_ A V).hom ▷ R) ▷ (W ⊗ S) ≫ + (α_ V A R).hom ▷ (W ⊗ S) ≫ + tensorμ V (A ⊗ R) W S + = 𝟙 _ ⊗≫ + ((β_ A V).hom ▷ ((R ⊗ W) ⊗ S) ≫ + (V ⊗ A) ◁ ((β_ R W).hom ▷ S)) ⊗≫ + V ◁ (((β_ A W).hom ▷ R) ▷ S) ⊗≫ 𝟙 _ := by + dsimp only [tensorμ] + rw [BraidedCategory.braiding_tensor_left_hom A R W] + monoidal + _ = 𝟙 _ ⊗≫ + ((A ⊗ V) ◁ ((β_ R W).hom ▷ S) ≫ + (β_ A V).hom ▷ ((W ⊗ R) ⊗ S)) ⊗≫ + V ◁ (((β_ A W).hom ▷ R) ▷ S) ⊗≫ 𝟙 _ := by + rw [← whisker_exchange] + _ = A ◁ tensorμ V R W S ≫ + (α_ A (V ⊗ W) (R ⊗ S)).inv ≫ + ((β_ A (V ⊗ W)).hom ▷ (R ⊗ S)) ≫ + (α_ (V ⊗ W) A (R ⊗ S)).hom ≫ + ((V ⊗ W) ◁ (α_ A R S).inv) := by + dsimp only [tensorμ] + rw [BraidedCategory.braiding_tensor_right_hom A V W] + monoidal + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistDatum.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistDatum.lean new file mode 100644 index 0000000000..63987dedaf --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistDatum.lean @@ -0,0 +1,163 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitFreeMod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistFreeTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransferIso +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorZigzag +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTransport +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLinePairing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensor + +/-! +# The odd twist of a duality datum + +A self-dual object of the ambient category makes the free module +it generates self-dual over any commutative base: the duality +datum over the trivial base is carried onto the free module and +then base-changed, and both steps preserve the zigzag laws. For +an odd line the self-duality is the square trivialisation, so +tensoring a duality datum with the line datum and transporting +along the twist shuffle gives the odd twist of a duality datum, +zigzag laws included. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +section SelfDual + +/-- The self-duality datum over the trivial base, carried onto +the free module of the trivial base. -/ +noncomputable def unitFreeDatum + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (V : D) [ExactPairing V V] : + ModDualityDatum (𝟙_ D) (freeMod (𝟙_ D) V) + (freeMod (𝟙_ D) V) := + (unitBaseDatum V V).transferIso (𝟙_ D) + (unitFreeIso V).symm (unitFreeIso V).symm + +/-- The carried datum satisfies the zigzag laws. -/ +theorem unitFreeDatum_zigzag + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (V : D) [ExactPairing V V] : + ModZigzagDatum (𝟙_ D) (unitFreeDatum V) := + modZigzagDatum_transferIso (𝟙_ D) (unitBaseDatum V V) + (unitFreeIso V).symm (unitFreeIso V).symm + (unitBaseDatum_zigzag V V) + +/-- **The free module on a self-dual object is self-dual** over +any commutative base. -/ +noncomputable def freeSelfDatum + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (V : D) [ExactPairing V V] : + ModDualityDatum A (freeMod A V) (freeMod A V) := + (baseChangeDatum (𝟙_ D) A η[A] (unitFreeDatum V)).transferIso A + (baseChangeFreeIso (𝟙_ D) A η[A] V).symm + (baseChangeFreeIso (𝟙_ D) A η[A] V).symm + +/-- The free self-duality datum satisfies the zigzag laws. -/ +theorem freeSelfDatum_zigzag + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (V : D) [ExactPairing V V] : + ModZigzagDatum A (freeSelfDatum A V) := + modZigzagDatum_transferIso A + (baseChangeDatum (𝟙_ D) A η[A] (unitFreeDatum V)) + (baseChangeFreeIso (𝟙_ D) A η[A] V).symm + (baseChangeFreeIso (𝟙_ D) A η[A] V).symm + (baseChangeZigzag D (𝟙_ D) _ _ (freeMod (𝟙_ D) V) + (freeMod (𝟙_ D) V) (unitFreeDatum V) + (unitFreeDatum_zigzag V) A _ _ η[A] _) + +end SelfDual + +section Twist + +/-- **The line datum**: the module generated by the odd line is +self-dual over any commutative base. -/ +noncomputable def lineDatum + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (L : OddLine D) : + ModDualityDatum A (freeMod A L.obj) (freeMod A L.obj) := + letI := L.exactPairing + freeSelfDatum A L.obj + +/-- The line datum satisfies the zigzag laws. -/ +theorem lineDatum_zigzag + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (L : OddLine D) : + ModZigzagDatum A (lineDatum A L) := + letI := L.exactPairing + freeSelfDatum_zigzag A L.obj + +/-- **The odd twist of a duality datum**: tensor with the line +datum and transport along the twist shuffle. -/ +noncomputable def twistDatum + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (L : OddLine D) {M : Mod D A} + {M' : Mod D A} + (d : ModDualityDatum A M M') : + ModDualityDatum A (tensorLeftMod A L.obj M) + (tensorLeftMod A L.obj M') := + (tensorDatum A (lineDatum A L) d).transferIso A + (freeTensorTwistIso A L.obj M).symm + (freeTensorTwistIso A L.obj M').symm + +/-- **The odd twist preserves the zigzag laws.** -/ +theorem twistDatum_zigzag + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (L : OddLine D) {M : Mod D A} + {M' : Mod D A} + (d : ModDualityDatum A M M') + (hz : ModZigzagDatum A d) : + ModZigzagDatum A (twistDatum A L d) := + modZigzagDatum_transferIso A (tensorDatum A (lineDatum A L) d) + (freeTensorTwistIso A L.obj M).symm + (freeTensorTwistIso A L.obj M').symm + (tensorDatum_zigzag A (lineDatum A L) d + (lineDatum_zigzag A L) hz) + +end Twist + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistFreeTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistFreeTensor.lean new file mode 100644 index 0000000000..154cc47eef --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistFreeTensor.lean @@ -0,0 +1,104 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichRetract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistUnitor + +/-! +# The free module inside the relative tensor + +Tensoring against a free module changes nothing but the twist: the +algebra of the free module is absorbed by the relative tensor and +only the generating object survives, carried across by the +braiding. + +* `freeRegTwistIso`: the free module on an object is the twist of + the regular module by that object, through the braiding. +* `freeTensorTwistIso`: the relative tensor of a free module with + a module is the twist of that module by the generating object. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## The free module as a twisted regular module -/ + +/-- The braiding intertwines the free action on the generator with +the twist of the regular action: both hexagon legs multiply the +two algebra factors after carrying the generator to the front. -/ +theorem freeRegTwist_act + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] + (V : D) : + letI := ModObj.regular A + ((α_ A A V).inv ≫ (μ[A] ▷ V)) ≫ (β_ A V).hom = + (A ◁ (β_ A V).hom) ≫ actAcross A V A := by + let := ModObj.regular A + change ((α_ A A V).inv ≫ (μ[A] ▷ V)) ≫ (β_ A V).hom = + (A ◁ (β_ A V).hom) ≫ actAcross A V A + rw [actAcross_eq_braidPast, braidPast_hom, + show actLeft A A = μ[A] from rfl, Category.assoc, + BraidedCategory.braiding_naturality_left, + BraidedCategory.braiding_tensor_left_hom] + simp only [Category.assoc, Iso.inv_hom_id_assoc] + +/-- **The free module is a twisted regular module**: the free +module on `V` is the twist by `V` of the regular module, through +the braiding carrying the algebra past the generator. -/ +noncomputable def freeRegTwistIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] + (V : D) : + freeMod A V ≅ tensorLeftMod A V (regularMod A) where + hom := Mod.Hom.mk' (β_ A V).hom (by + let := ModObj.regular A + change ((α_ A A V).inv ≫ (μ[A] ▷ V)) ≫ (β_ A V).hom = + (A ◁ (β_ A V).hom) ≫ actAcross A V A + exact freeRegTwist_act A V) + inv := Mod.Hom.mk' (β_ A V).inv (by + let := ModObj.regular A + change actAcross A V A ≫ (β_ A V).inv = + (A ◁ (β_ A V).inv) ≫ ((α_ A A V).inv ≫ (μ[A] ▷ V)) + exact act_inv_of_act_hom A (β_ A V) (freeRegTwist_act A V)) + hom_inv_id := by + apply Mod.Hom.ext + exact (β_ A V).hom_inv_id + inv_hom_id := by + apply Mod.Hom.ext + exact (β_ A V).inv_hom_id + +/-! ## Absorbing a free factor -/ + +/-- **The free factor twists**: the relative tensor of the free +module on `V` with a module `M` is the twist of `M` by `V`. The +free module is the twisted regular module, the twist shuffle +collects both twists in front, and the regular module is the unit +of the relative tensor. -/ +noncomputable def freeTensorTwistIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] + (V : D) (M : Mod D A) : + modTensorMod A (freeMod A V) M ≅ tensorLeftMod A V M := + modTensorMapIso A (freeRegTwistIso A V) + (tensorLeftUnitMod A M).symm ≪≫ + twistShuffleModIso A V (𝟙_ D) (regularMod A) M ≪≫ + tensorLeftModContextIso A (ρ_ V) + (modTensorMod A (regularMod A) M) ≪≫ + tensorLeftModWhiskerIso A V (modTensorUnitLeftMod A M) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistMixLine.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistMixLine.lean new file mode 100644 index 0000000000..656f36942a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistMixLine.lean @@ -0,0 +1,59 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffleLine + +/-! +# Tensoring a mixed sum with the odd line + +Tensoring the mixed sum `L.mix p q` with the odd line exchanges +the two kinds of summand: each unit summand becomes a line, by +the right unitor, and each line summand becomes a unit, by the +square of the line. Reindexing along the swap of the summand +labels therefore identifies `L.obj ⊗ L.mix p q` with the mixed +sum `L.mix q p` of `q` copies of the unit and `p` copies of the +line. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {D : Type u} + +/-- Tensoring a summand of `L.mix p q` with the line gives the +summand of `L.mix q p` at the swapped index: a unit summand +becomes a line, a line summand becomes a unit. -/ +noncomputable def OddLine.twistSummandIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] + (L : OddLine D) + (p q : ℕ) : + ∀ j : Fin p ⊕ Fin q, + L.mixFun q p (Equiv.sumComm (Fin p) (Fin q) j) ≅ + L.obj ⊗ L.mixFun p q j + | Sum.inl _ => (ρ_ L.obj).symm + | Sum.inr _ => L.sq.symm + +/-- **Twisting a mixed sum by the line**: tensoring with the odd +line turns `p` units and `q` lines into `q` units and `p` lines. +-/ +noncomputable def OddLine.twistMixIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + (L : OddLine D) (p q : ℕ) : + L.obj ⊗ L.mix p q ≅ L.mix q p := + leftDistributor L.obj (L.mixFun p q) ≪≫ + biproduct.whiskerEquiv (Equiv.sumComm (Fin p) (Fin q)) + (L.twistSummandIso p q) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistPow.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistPow.lean new file mode 100644 index 0000000000..6529996197 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistPow.lean @@ -0,0 +1,104 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSuccMod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZigzag +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistShuffle + +/-! +# Iso builders for the twisted power induction + +Functoriality of the relative tensor and of the left twist on +isomorphisms: the two transport devices consumed by the k-fold +twisted power identification. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- The double twist transport: object and module isomorphisms +together. -/ +noncomputable def tensorLeftModMapIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] + {V V' : D} (e : V ≅ V') + {M N : Mod D A} (f : M ≅ N) : + tensorLeftMod A V M ≅ tensorLeftMod A V' N := + tensorLeftModContextIso A e M ≪≫ + tensorLeftModWhiskerIso A V' f + +section Powers + +/-- The bottom power module is the module. -/ +noncomputable def modPowModZeroIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] + (M : Mod D A) : + modPowMod A M.X 0 ≅ M where + hom := fromModPowModZero A M + inv := toModPowModZero A M + hom_inv_id := Mod.hom_ext _ _ (modPowOne A M.X).hom_inv_id + inv_hom_id := Mod.hom_ext _ _ (modPowOne A M.X).inv_hom_id + +/-- The merge of adjacent power modules, as a module +isomorphism. -/ +noncomputable def powMergeModIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] + (X : D) [ModObj A X] (k : ℕ) : + modTensorMod A (modPowMod A X k) (modPowMod A X 0) ≅ + modPowMod A X (k + 1) where + hom := powMulMod A X k 0 + inv := powMulModInv A X k 0 + hom_inv_id := powMulMod_powMulModInv A X k 0 + inv_hom_id := powMulModInv_powMulMod A X k 0 + +/-- **The twisted power identification**: the relative powers of +a twisted module are the twist of the powers by the tensor powers +of the twisting object. -/ +noncomputable def twistPowModIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] [Preadditive D] + [MonoidalPreadditive D] [HasFiniteBiproducts D] + (V : D) (R : Mod D A) : + (k : ℕ) → + (modPowMod A ((tensorLeftMod A V R).X) k ≅ + tensorLeftMod A (tensorPow D V (k + 1)) (modPowMod A R.X k)) + | 0 => + modPowModZeroIso A (tensorLeftMod A V R) ≪≫ + tensorLeftModMapIso A (λ_ V).symm + (modPowModZeroIso A R).symm + | (k + 1) => + (powMergeModIso A ((tensorLeftMod A V R).X) k).symm ≪≫ + modTensorMapIso A (twistPowModIso A V R k) + (twistPowModIso A V R 0) ≪≫ + twistShuffleModIso A (tensorPow D V (k + 1)) + (tensorPow D V 1) (modPowMod A R.X k) + (modPowMod A R.X 0) ≪≫ + tensorLeftModMapIso A (tensorPowConcat V (k + 1) 1) + (powMergeModIso A R.X k) + +end Powers + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistShuffle.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistShuffle.lean new file mode 100644 index 0000000000..270878a8ef --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistShuffle.lean @@ -0,0 +1,588 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistCoherence + +/-! +# The twist shuffle + +The relative tensor of two twisted modules is the twist of the +relative tensor by the tensor of the twisting objects: the middle +twisting object crosses the first module through the braiding. +The cover-level shuffle is the middle-four interchange, so the +committed interchange toolbox applies; the twisting is fully +general, and the sign phenomena of the odd line enter only at the +symmetriser conjugation downstream. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- The twist of a module by an object on the left, bundled. -/ +noncomputable def tensorLeftMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] + (V : D) (M : Mod D A) : + Mod D A := + letI := tensorLeftModObj A V M.X + ⟨V ⊗ M.X⟩ + +@[simp] lemma tensorLeftMod_X + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] + (V : D) (M : Mod D A) : + (tensorLeftMod A V M).X = V ⊗ M.X := + rfl + +/-- The cover map of the twist shuffle: the middle-four +interchange followed by the projection under the twists. -/ +noncomputable def twistShuffleCover + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (V : D) (W : D) (R : Mod D A) + (S : Mod D A) : + (V ⊗ R.X) ⊗ (W ⊗ S.X) ⟶ (V ⊗ W) ⊗ modTensor A R S := + tensorμ V R.X W S.X ≫ ((V ⊗ W) ◁ modTensorπ A R S) + +/-- The cover map coequalizes the twisted balance relation. -/ +theorem twistShuffleCover_cond + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (V : D) (W : D) (R : Mod D A) + (S : Mod D A) : + modTensorLegM A (tensorLeftMod A V R) (tensorLeftMod A W S) ≫ + twistShuffleCover A V W R S = + modTensorLegN A (tensorLeftMod A V R) + (tensorLeftMod A W S) ≫ + twistShuffleCover A V W R S := by + rw [modTensorLegM, modTensorLegN, twistShuffleCover] + rw [show actLeft A (tensorLeftMod A W S).X = + actAcross A W S.X from rfl, + show actRight A (tensorLeftMod A V R).X = + (β_ (V ⊗ R.X) A).hom ≫ actAcross A V R.X from rfl] + have hN : ((V ⊗ R.X) ◁ (W ◁ actLeft A S.X)) ≫ + tensorμ V R.X W S.X = + tensorμ V R.X W (A ⊗ S.X) ≫ + ((V ⊗ W) ◁ (R.X ◁ actLeft A S.X)) := by + simpa using tensorμ_natural (𝟙 V) (𝟙 R.X) (𝟙 W) + (actLeft A S.X) + have hM : ((V ◁ actLeft A R.X) ▷ (W ⊗ S.X)) ≫ + tensorμ V R.X W S.X = + tensorμ V (A ⊗ R.X) W S.X ≫ + ((V ⊗ W) ◁ (actLeft A R.X ▷ S.X)) := by + simpa using tensorμ_natural (𝟙 V) (actLeft A R.X) (𝟙 W) + (𝟙 S.X) + have hswap : (actLeft A R.X ▷ S.X) ≫ modTensorπ A R S = + ((β_ R.X A).inv ▷ S.X) ≫ (α_ R.X A S.X).hom ≫ + (R.X ◁ actLeft A S.X) ≫ modTensorπ A R S := by + have h := modTensor_condition A R S + rw [modTensorLegM, modTensorLegN] at h + rw [show actLeft A R.X ▷ S.X = + ((β_ R.X A).inv ▷ S.X) ≫ (actRight A R.X ▷ S.X) from by + rw [← comp_whiskerRight, + show actRight A R.X = + (β_ R.X A).hom ≫ actLeft A R.X from rfl, + Iso.inv_hom_id_assoc], + Category.assoc, h] + simp only [Category.assoc] + rw [actAcross, actAcross] + change ((β_ (V ⊗ R.X) A).hom ≫ (α_ A V R.X).inv ≫ + ((β_ A V).hom ▷ R.X) ≫ (α_ V A R.X).hom ≫ + (V ◁ actLeft A R.X)) ▷ (W ⊗ S.X) ≫ + tensorμ V R.X W S.X ≫ ((V ⊗ W) ◁ modTensorπ A R S) = + ((α_ (V ⊗ R.X) A (W ⊗ S.X)).hom ≫ + ((V ⊗ R.X) ◁ ((α_ A W S.X).inv ≫ + ((β_ A W).hom ▷ S.X) ≫ (α_ W A S.X).hom ≫ + (W ◁ actLeft A S.X)))) ≫ + tensorμ V R.X W S.X ≫ ((V ⊗ W) ◁ modTensorπ A R S) + simp only [MonoidalCategory.comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [reassoc_of% hM, reassoc_of% hN] + rw [← MonoidalCategory.whiskerLeft_comp + (V ⊗ W) (actLeft A R.X ▷ S.X) (modTensorπ A R S), + hswap] + simp only [MonoidalCategory.whiskerLeft_comp] + have hpure : (β_ (V ⊗ R.X) A).hom ▷ (W ⊗ S.X) ≫ + (α_ A V R.X).inv ▷ (W ⊗ S.X) ≫ + (β_ A V).hom ▷ R.X ▷ (W ⊗ S.X) ≫ + (α_ V A R.X).hom ▷ (W ⊗ S.X) ≫ + tensorμ V (A ⊗ R.X) W S.X ≫ + ((V ⊗ W) ◁ ((β_ R.X A).inv ▷ S.X)) ≫ + ((V ⊗ W) ◁ (α_ R.X A S.X).hom) = + (α_ (V ⊗ R.X) A (W ⊗ S.X)).hom ≫ + ((V ⊗ R.X) ◁ (α_ A W S.X).inv) ≫ + ((V ⊗ R.X) ◁ ((β_ A W).hom ▷ S.X)) ≫ + ((V ⊗ R.X) ◁ (α_ W A S.X).hom) ≫ + tensorμ V R.X W (A ⊗ S.X) := + twist_shuffle_coherence V R.X A W S.X + rw [reassoc_of% hpure] + +/-- **The twist shuffle**: the relative tensor of two twisted +modules maps to the twist of the relative tensor. -/ +noncomputable def twistShuffleHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (V : D) (W : D) (R : Mod D A) + (S : Mod D A) : + modTensor A (tensorLeftMod A V R) (tensorLeftMod A W S) ⟶ + (V ⊗ W) ⊗ modTensor A R S := + modTensorDesc A (tensorLeftMod A V R) (tensorLeftMod A W S) + (twistShuffleCover A V W R S) + (twistShuffleCover_cond A V W R S) + +/-- Defining equation of the twist shuffle. -/ +@[reassoc (attr := simp)] +theorem modTensorπ_twistShuffleHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (V : D) (W : D) (R : Mod D A) + (S : Mod D A) : + modTensorπ A (tensorLeftMod A V R) (tensorLeftMod A W S) ≫ + twistShuffleHom A V W R S = + twistShuffleCover A V W R S := + modTensorπ_desc A _ _ _ _ + +/-- The cover map of the inverse twist shuffle: split into the +twisted pairs and project. -/ +noncomputable def twistShuffleInvCover + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (V : D) (W : D) (R : Mod D A) + (S : Mod D A) : + (V ⊗ W) ⊗ (R.X ⊗ S.X) ⟶ + modTensor A (tensorLeftMod A V R) (tensorLeftMod A W S) := + tensorδ V R.X W S.X ≫ + modTensorπ A (tensorLeftMod A V R) (tensorLeftMod A W S) + +/-- The interchange splitting is invertible. -/ +instance isIso_tensorμ + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (X₁ X₂ Y₁ Y₂ : D) : + IsIso (tensorμ X₁ X₂ Y₁ Y₂) := + ⟨tensorδ X₁ X₂ Y₁ Y₂, + tensorμ_tensorδ X₁ X₂ Y₁ Y₂, tensorδ_tensorμ X₁ X₂ Y₁ Y₂⟩ + +/-- The second-slot action slides through the splitting. -/ +theorem tensorδ_slide_snd + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (V : D) (W : D) (R : Mod D A) (S : Mod D A) : + ((V ⊗ W) ◁ (R.X ◁ actLeft A S.X)) ≫ + tensorδ V R.X W S.X = + tensorδ V R.X W (A ⊗ S.X) ≫ + ((V ⊗ R.X) ◁ (W ◁ actLeft A S.X)) := by + have hN : ((V ⊗ R.X) ◁ (W ◁ actLeft A S.X)) ≫ + tensorμ V R.X W S.X = + tensorμ V R.X W (A ⊗ S.X) ≫ + ((V ⊗ W) ◁ (R.X ◁ actLeft A S.X)) := by + simpa using tensorμ_natural (𝟙 V) (𝟙 R.X) (𝟙 W) + (actLeft A S.X) + rw [← cancel_mono (tensorμ V R.X W S.X), Category.assoc, + Category.assoc, tensorδ_tensorμ, Category.comp_id, hN, + ← Category.assoc, tensorδ_tensorμ, Category.id_comp] + +/-- The first-slot action slides through the splitting. -/ +theorem tensorδ_slide_fst + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] (V : D) (W : D) (R : Mod D A) (S : Mod D A) : + ((V ⊗ W) ◁ (actLeft A R.X ▷ S.X)) ≫ + tensorδ V R.X W S.X = + tensorδ V (A ⊗ R.X) W S.X ≫ + ((V ◁ actLeft A R.X) ▷ (W ⊗ S.X)) := by + have hM : ((V ◁ actLeft A R.X) ▷ (W ⊗ S.X)) ≫ + tensorμ V R.X W S.X = + tensorμ V (A ⊗ R.X) W S.X ≫ + ((V ⊗ W) ◁ (actLeft A R.X ▷ S.X)) := by + simpa using tensorμ_natural (𝟙 V) (actLeft A R.X) (𝟙 W) + (𝟙 S.X) + rw [← cancel_mono (tensorμ V R.X W S.X), Category.assoc, + Category.assoc, tensorδ_tensorμ, Category.comp_id, hM, + ← Category.assoc, tensorδ_tensorμ, Category.id_comp] + +/-- The inverse cover coequalizes the whiskered balance +relation. -/ +theorem twistShuffleInvCover_cond + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] (V : D) (W : D) (R : Mod D A) + (S : Mod D A) : + ((V ⊗ W) ◁ modTensorLegM A R S) ≫ + twistShuffleInvCover A V W R S = + ((V ⊗ W) ◁ modTensorLegN A R S) ≫ + twistShuffleInvCover A V W R S := by + rw [modTensorLegM, modTensorLegN, twistShuffleInvCover, + show actRight A R.X = (β_ R.X A).hom ≫ actLeft A R.X + from rfl] + simp only [MonoidalCategory.comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + erw [reassoc_of% (tensorδ_slide_fst A V W R S), + reassoc_of% (tensorδ_slide_snd A V W R S)] + have hcond := modTensor_condition A (tensorLeftMod A V R) + (tensorLeftMod A W S) + rw [modTensorLegM, modTensorLegN, + show actLeft A (tensorLeftMod A W S).X = + actAcross A W S.X from rfl, + show actRight A (tensorLeftMod A V R).X = + (β_ (V ⊗ R.X) A).hom ≫ actAcross A V R.X from rfl, + actAcross, actAcross] at hcond + have hbig : (β_ (V ⊗ R.X) A).hom ▷ (W ⊗ S.X) ≫ + (α_ A V R.X).inv ▷ (W ⊗ S.X) ≫ + (β_ A V).hom ▷ R.X ▷ (W ⊗ S.X) ≫ + (α_ V A R.X).hom ▷ (W ⊗ S.X) ≫ + (V ◁ actLeft A R.X) ▷ (W ⊗ S.X) ≫ + modTensorπ A (tensorLeftMod A V R) + (tensorLeftMod A W S) = + (α_ (V ⊗ R.X) A (W ⊗ S.X)).hom ≫ + ((V ⊗ R.X) ◁ (α_ A W S.X).inv) ≫ + ((V ⊗ R.X) ◁ ((β_ A W).hom ▷ S.X)) ≫ + ((V ⊗ R.X) ◁ (α_ W A S.X).hom) ≫ + ((V ⊗ R.X) ◁ (W ◁ actLeft A S.X)) ≫ + modTensorπ A (tensorLeftMod A V R) + (tensorLeftMod A W S) := by + have h' : ((β_ (V ⊗ R.X) A).hom ≫ (α_ A V R.X).inv ≫ + ((β_ A V).hom ▷ R.X) ≫ (α_ V A R.X).hom ≫ + (V ◁ actLeft A R.X)) ▷ (W ⊗ S.X) ≫ + modTensorπ A (tensorLeftMod A V R) + (tensorLeftMod A W S) = + ((α_ (V ⊗ R.X) A (W ⊗ S.X)).hom ≫ + ((V ⊗ R.X) ◁ ((α_ A W S.X).inv ≫ + ((β_ A W).hom ▷ S.X) ≫ (α_ W A S.X).hom ≫ + (W ◁ actLeft A S.X)))) ≫ + modTensorπ A (tensorLeftMod A V R) + (tensorLeftMod A W S) := hcond + simp only [MonoidalCategory.comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp] at h' + repeat' erw [Category.assoc] at h' + exact h' + have htail : (V ◁ actLeft A R.X) ▷ (W ⊗ S.X) ≫ + modTensorπ A (tensorLeftMod A V R) + (tensorLeftMod A W S) = + (α_ V A R.X).inv ▷ (W ⊗ S.X) ≫ + ((β_ A V).inv ▷ R.X) ▷ (W ⊗ S.X) ≫ + (α_ A V R.X).hom ▷ (W ⊗ S.X) ≫ + (β_ (V ⊗ R.X) A).inv ▷ (W ⊗ S.X) ≫ + (α_ (V ⊗ R.X) A (W ⊗ S.X)).hom ≫ + ((V ⊗ R.X) ◁ (α_ A W S.X).inv) ≫ + ((V ⊗ R.X) ◁ ((β_ A W).hom ▷ S.X)) ≫ + ((V ⊗ R.X) ◁ (α_ W A S.X).hom) ≫ + ((V ⊗ R.X) ◁ (W ◁ actLeft A S.X)) ≫ + modTensorπ A (tensorLeftMod A V R) + (tensorLeftMod A W S) := by + rw [← hbig] + simp only [← MonoidalCategory.comp_whiskerRight_assoc, + Iso.inv_hom_id_assoc, Iso.hom_inv_id_assoc, + Iso.inv_hom_id, MonoidalCategory.id_whiskerRight, + Category.id_comp] + have hmirror : (V ⊗ W) ◁ ((β_ R.X A).hom ▷ S.X) ≫ + tensorδ V (A ⊗ R.X) W S.X ≫ + (α_ V A R.X).inv ▷ (W ⊗ S.X) ≫ + ((β_ A V).inv ▷ R.X) ▷ (W ⊗ S.X) ≫ + (α_ A V R.X).hom ▷ (W ⊗ S.X) ≫ + (β_ (V ⊗ R.X) A).inv ▷ (W ⊗ S.X) ≫ + (α_ (V ⊗ R.X) A (W ⊗ S.X)).hom ≫ + ((V ⊗ R.X) ◁ (α_ A W S.X).inv) ≫ + ((V ⊗ R.X) ◁ ((β_ A W).hom ▷ S.X)) ≫ + ((V ⊗ R.X) ◁ (α_ W A S.X).hom) = + (V ⊗ W) ◁ (α_ R.X A S.X).hom ≫ + tensorδ V R.X W (A ⊗ S.X) := by + rw [← cancel_mono (tensorμ V R.X W (A ⊗ S.X))] + simp only [Category.assoc] + rw [← twist_shuffle_coherence V R.X A W S.X] + simp only [← MonoidalCategory.comp_whiskerRight_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, + Iso.inv_hom_id_assoc, Iso.hom_inv_id_assoc, + MonoidalCategory.hom_inv_whiskerRight, + Iso.inv_hom_id, MonoidalCategory.id_whiskerRight, + MonoidalCategory.whiskerLeft_id, + Category.id_comp, Category.comp_id, + tensorδ_tensorμ, tensorδ_tensorμ_assoc] + rw [htail, reassoc_of% hmirror] + +/-- **The inverse twist shuffle.** -/ +noncomputable def twistShuffleInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (V : D) (W : D) (R : Mod D A) (S : Mod D A) : + (V ⊗ W) ⊗ modTensor A R S ⟶ + modTensor A (tensorLeftMod A V R) (tensorLeftMod A W S) := + modTensorWhiskerDesc A R S (V ⊗ W) + (twistShuffleInvCover A V W R S) + (twistShuffleInvCover_cond A V W R S) + +/-- Defining equation of the inverse twist shuffle. -/ +@[reassoc] +theorem whiskerLeft_π_twistShuffleInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (V : D) (W : D) (R : Mod D A) (S : Mod D A) : + ((V ⊗ W) ◁ modTensorπ A R S) ≫ twistShuffleInv A V W R S = + twistShuffleInvCover A V W R S := + whiskerLeft_modTensorπ_whiskerDesc A R S (V ⊗ W) _ _ + +/-- The twist shuffle retracts the inverse shuffle. -/ +@[reassoc (attr := simp)] +theorem twistShuffleHom_twistShuffleInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (V : D) (W : D) (R : Mod D A) (S : Mod D A) : + twistShuffleHom A V W R S ≫ twistShuffleInv A V W R S = + 𝟙 (modTensor A (tensorLeftMod A V R) + (tensorLeftMod A W S)) := by + apply modTensor_hom_ext A (tensorLeftMod A V R) + (tensorLeftMod A W S) + rw [modTensorπ_twistShuffleHom_assoc, Category.comp_id, + twistShuffleCover] + change (tensorμ V R.X W S.X ≫ + ((V ⊗ W) ◁ modTensorπ A R S)) ≫ + twistShuffleInv A V W R S = + modTensorπ A (tensorLeftMod A V R) (tensorLeftMod A W S) + erw [Category.assoc, whiskerLeft_π_twistShuffleInv, + twistShuffleInvCover, ← Category.assoc, tensorμ_tensorδ, + Category.id_comp] + +/-- The inverse shuffle retracts the twist shuffle. -/ +@[reassoc (attr := simp)] +theorem twistShuffleInv_twistShuffleHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] (V : D) (W : D) (R : Mod D A) (S : Mod D A) : + twistShuffleInv A V W R S ≫ twistShuffleHom A V W R S = + 𝟙 ((V ⊗ W) ⊗ modTensor A R S) := by + apply modTensor_whisker_hom_ext A R S (V ⊗ W) + rw [whiskerLeft_π_twistShuffleInv_assoc, Category.comp_id, + twistShuffleInvCover] + show (tensorδ V R.X W S.X ≫ + modTensorπ A (tensorLeftMod A V R) + (tensorLeftMod A W S)) ≫ + twistShuffleHom A V W R S = + (V ⊗ W) ◁ modTensorπ A R S + erw [Category.assoc] + erw [modTensorπ_twistShuffleHom] + rw [twistShuffleCover, ← Category.assoc, tensorδ_tensorμ, + Category.id_comp] + +/-- **The twist shuffle is a module map**: it intertwines the +descended action of the twisted pair with the twist action of +the shuffled pair. -/ +theorem twistShuffleHom_act + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (V : D) (W : D) (R : Mod D A) + (S : Mod D A) : + letI := modTensorModObj A R S + modTensorAct A (tensorLeftMod A V R) (tensorLeftMod A W S) ≫ + twistShuffleHom A V W R S = + (A ◁ twistShuffleHom A V W R S) ≫ + actAcross A (V ⊗ W) (modTensor A R S) := by + let := modTensorModObj A R S + apply modTensor_whisker_hom_ext A (tensorLeftMod A V R) + (tensorLeftMod A W S) A + conv_lhs => rw [whiskerLeft_modTensorπ_act_assoc] + rw [show actLeft A (tensorLeftMod A V R).X = + actAcross A V R.X from rfl] + conv_rhs => rw [← MonoidalCategory.whiskerLeft_comp_assoc, + modTensorπ_twistShuffleHom] + conv_lhs => rw [modTensorπ_twistShuffleHom] + rw [twistShuffleCover, + show actAcross A (V ⊗ W) (modTensor A R S) = + (braidPast A (V ⊗ W) (modTensor A R S)).hom ≫ + ((V ⊗ W) ◁ modTensorAct A R S) from by + rw [actAcross_eq_braidPast] + rfl] + change (α_ A (V ⊗ R.X) (W ⊗ S.X)).inv ≫ + (actAcross A V R.X ▷ (W ⊗ S.X)) ≫ + (tensorμ V R.X W S.X ≫ ((V ⊗ W) ◁ modTensorπ A R S)) = + (A ◁ (tensorμ V R.X W S.X ≫ + ((V ⊗ W) ◁ modTensorπ A R S))) ≫ + ((braidPast A (V ⊗ W) (modTensor A R S)).hom ≫ + ((V ⊗ W) ◁ modTensorAct A R S)) + conv_rhs => rw [MonoidalCategory.whiskerLeft_comp, + Category.assoc, + ← Category.assoc (A ◁ ((V ⊗ W) ◁ modTensorπ A R S)), + braidPast_natural_tail A (V ⊗ W) (modTensorπ A R S), + Category.assoc, + ← MonoidalCategory.whiskerLeft_comp + (V ⊗ W) (A ◁ modTensorπ A R S) (modTensorAct A R S), + whiskerLeft_modTensorπ_act] + rw [actAcross] + show (α_ A (V ⊗ R.X) (W ⊗ S.X)).inv ≫ + ((α_ A V R.X).inv ≫ ((β_ A V).hom ▷ R.X) ≫ + (α_ V A R.X).hom ≫ (V ◁ actLeft A R.X)) ▷ (W ⊗ S.X) ≫ + tensorμ V R.X W S.X ≫ ((V ⊗ W) ◁ modTensorπ A R S) = + A ◁ tensorμ V R.X W S.X ≫ + (braidPast A (V ⊗ W) (R.X ⊗ S.X)).hom ≫ + (V ⊗ W) ◁ (((α_ A R.X S.X).inv ≫ + (actLeft A R.X ▷ S.X)) ≫ modTensorπ A R S) + have hM : ((V ◁ actLeft A R.X) ▷ (W ⊗ S.X)) ≫ + tensorμ V R.X W S.X = + tensorμ V (A ⊗ R.X) W S.X ≫ + ((V ⊗ W) ◁ (actLeft A R.X ▷ S.X)) := by + simpa using tensorμ_natural (𝟙 V) (actLeft A R.X) (𝟙 W) + (𝟙 S.X) + simp only [MonoidalCategory.comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [reassoc_of% hM] + have hpure2 : (α_ A (V ⊗ R.X) (W ⊗ S.X)).inv ≫ + (α_ A V R.X).inv ▷ (W ⊗ S.X) ≫ + ((β_ A V).hom ▷ R.X) ▷ (W ⊗ S.X) ≫ + (α_ V A R.X).hom ▷ (W ⊗ S.X) ≫ + tensorμ V (A ⊗ R.X) W S.X = + A ◁ tensorμ V R.X W S.X ≫ + (braidPast A (V ⊗ W) (R.X ⊗ S.X)).hom ≫ + ((V ⊗ W) ◁ (α_ A R.X S.X).inv) := by + simp only [braidPast_hom, Category.assoc] + exact twist_act_coherence A V R.X W S.X + rw [reassoc_of% hpure2] + +/-- **The twist shuffle as a module map**: the shuffled pair maps +to the twist of the relative tensor. -/ +noncomputable def twistShuffleModHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (V : D) (W : D) (R : Mod D A) + (S : Mod D A) : + modTensorMod A (tensorLeftMod A V R) (tensorLeftMod A W S) ⟶ + tensorLeftMod A (V ⊗ W) (modTensorMod A R S) := + Mod.Hom.mk' (twistShuffleHom A V W R S) + (twistShuffleHom_act A V W R S) + +/-- The inverse twist shuffle intertwines the actions. -/ +theorem twistShuffleInv_act + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (V : D) (W : D) (R : Mod D A) + (S : Mod D A) : + letI := modTensorModObj A R S + actAcross A (V ⊗ W) (modTensor A R S) ≫ + twistShuffleInv A V W R S = + (A ◁ twistShuffleInv A V W R S) ≫ + modTensorAct A (tensorLeftMod A V R) + (tensorLeftMod A W S) := by + let := modTensorModObj A R S + have : IsIso (twistShuffleHom A V W R S) := + ⟨twistShuffleInv A V W R S, + twistShuffleHom_twistShuffleInv A V W R S, + twistShuffleInv_twistShuffleHom A V W R S⟩ + rw [← cancel_mono (twistShuffleHom A V W R S)] + have h := twistShuffleHom_act A V W R S + rw [Category.assoc, Category.assoc, + twistShuffleInv_twistShuffleHom, Category.comp_id, h, + ← Category.assoc, ← MonoidalCategory.whiskerLeft_comp, + twistShuffleInv_twistShuffleHom, + MonoidalCategory.whiskerLeft_id, Category.id_comp] + +/-- The inverse twist shuffle as a module map. -/ +noncomputable def twistShuffleModInv + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (V : D) (W : D) (R : Mod D A) + (S : Mod D A) : + tensorLeftMod A (V ⊗ W) (modTensorMod A R S) ⟶ + modTensorMod A (tensorLeftMod A V R) (tensorLeftMod A W S) := + Mod.Hom.mk' (twistShuffleInv A V W R S) + (twistShuffleInv_act A V W R S) + +/-- The module-level twist shuffle is an isomorphism. -/ +noncomputable def twistShuffleModIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] (V : D) (W : D) (R : Mod D A) + (S : Mod D A) : + modTensorMod A (tensorLeftMod A V R) (tensorLeftMod A W S) ≅ + tensorLeftMod A (V ⊗ W) (modTensorMod A R S) where + hom := twistShuffleModHom A V W R S + inv := twistShuffleModInv A V W R S + hom_inv_id := Mod.hom_ext _ _ + (twistShuffleHom_twistShuffleInv A V W R S) + inv_hom_id := Mod.hom_ext _ _ + (twistShuffleInv_twistShuffleHom A V W R S) + +/-- An object map in the twist slot, as a module map: the twist +action carries past the context naturally. -/ +noncomputable def tensorLeftModContextHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] + {V V' : D} + (f : V ⟶ V') (M : Mod D A) : + tensorLeftMod A V M ⟶ tensorLeftMod A V' M := + Mod.Hom.mk' (f ▷ M.X) + (by + change actAcross A V M.X ≫ (f ▷ M.X) = + (A ◁ (f ▷ M.X)) ≫ actAcross A V' M.X + exact (actAcross_natural A f M.X).symm) + +/-- A module map under the twist, as a module map. -/ +noncomputable def tensorLeftModWhiskerHom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] + (V : D) + {M N : Mod D A} (g : M ⟶ N) : + tensorLeftMod A V M ⟶ tensorLeftMod A V N := + Mod.Hom.mk' (V ◁ g.hom) + (by + change actAcross A V M.X ≫ (V ◁ g.hom) = + (A ◁ (V ◁ g.hom)) ≫ actAcross A V N.X + have hg : actLeft A M.X ≫ g.hom = + (A ◁ g.hom) ≫ actLeft A N.X := IsModHom.smul_hom + rw [actAcross_eq_braidPast, actAcross_eq_braidPast, + Category.assoc, ← MonoidalCategory.whiskerLeft_comp, + hg, MonoidalCategory.whiskerLeft_comp, ← Category.assoc, + ← braidPast_natural_tail, Category.assoc]) + +/-- The twist-slot transport of an object isomorphism. -/ +noncomputable def tensorLeftModContextIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] + {V V' : D} + (e : V ≅ V') (M : Mod D A) : + tensorLeftMod A V M ≅ tensorLeftMod A V' M where + hom := tensorLeftModContextHom A e.hom M + inv := tensorLeftModContextHom A e.inv M + hom_inv_id := Mod.hom_ext _ _ (by + change (e.hom ▷ M.X) ≫ (e.inv ▷ M.X) = 𝟙 _ + rw [← MonoidalCategory.comp_whiskerRight, Iso.hom_inv_id, + MonoidalCategory.id_whiskerRight]) + inv_hom_id := Mod.hom_ext _ _ (by + change (e.inv ▷ M.X) ≫ (e.hom ▷ M.X) = 𝟙 _ + rw [← MonoidalCategory.comp_whiskerRight, Iso.inv_hom_id, + MonoidalCategory.id_whiskerRight]) + +/-- The twist of a module isomorphism. -/ +noncomputable def tensorLeftModWhiskerIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] + (V : D) + {M N : Mod D A} (f : M ≅ N) : + tensorLeftMod A V M ≅ tensorLeftMod A V N where + hom := tensorLeftModWhiskerHom A V f.hom + inv := tensorLeftModWhiskerHom A V f.inv + hom_inv_id := Mod.hom_ext _ _ (by + change (V ◁ f.hom.hom) ≫ (V ◁ f.inv.hom) = 𝟙 _ + rw [← MonoidalCategory.whiskerLeft_comp, + show f.hom.hom ≫ f.inv.hom = 𝟙 M.X from + congrArg Mod.Hom.hom f.hom_inv_id, + MonoidalCategory.whiskerLeft_id]) + inv_hom_id := Mod.hom_ext _ _ (by + change (V ◁ f.inv.hom) ≫ (V ◁ f.hom.hom) = 𝟙 _ + rw [← MonoidalCategory.whiskerLeft_comp, + show f.inv.hom ≫ f.hom.hom = 𝟙 N.X from + congrArg Mod.Hom.hom f.inv_hom_id, + MonoidalCategory.whiskerLeft_id]) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistState.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistState.lean new file mode 100644 index 0000000000..3a22268981 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistState.lean @@ -0,0 +1,118 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistMixLine +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.StateTransport + +/-! +# The odd twist of a dévissage state + +Twisting the object by the odd line twists the whole state: the +remainder and its dual acquire a line factor, their duality datum +is the odd twist, and the mixed free part turns each unit summand +into a line and each line summand into a unit, so the two counts +change places. Twisting twice returns to the original object. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +attribute [local instance] + hasBinaryBiproducts_of_finite_biproducts + +/-- **The twist of the mixed free part**: twisting the free +module on a mixed sum exchanges the two counts. -/ +noncomputable def freeMixTwistIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + (L : OddLine D) + (A : D) [MonObj A] (p q : ℕ) : + tensorLeftMod A L.obj (freeMod A (L.mix p q)) ≅ + freeMod A (L.mix q p) := + (freeTwistIso A L.obj (L.mix p q)).symm.trans + (freeModMapIso A (L.twistMixIso p q)) + +/-- **The odd twist of a dévissage state**: the counts change +places and the remainder gains a line factor. -/ +noncomputable def twistState + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (L : OddLine D) + {X : D} + (st : DevissageState D L X) : + DevissageState D L (L.obj ⊗ X) := + letI := st.monObj + letI := st.comm + { base := st.base + monObj := st.monObj + comm := st.comm + unit_ne_zero := st.unit_ne_zero + units := st.lines + lines := st.units + rest := tensorLeftMod st.base L.obj st.rest + restDual := tensorLeftMod st.base L.obj st.restDual + datum := twistDatum st.base L st.datum + zigzag := twistDatum_zigzag st.base L st.datum st.zigzag + decomp := st.decomp.elim fun e => + ⟨(freeTwistIso st.base L.obj X).trans + ((tensorLeftModWhiskerIso st.base L.obj e).trans + ((tensorLeftBiprodIso st.base L.obj + (freeMod st.base (L.mix st.units st.lines)) + st.rest).trans + (modBiprodMapIso st.base _ _ + (freeMixTwistIso L st.base st.units st.lines) + (Iso.refl _))))⟩ } + +/-- The twist exchanges the unit count for the line count. -/ +@[simp] theorem twistState_units + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (L : OddLine D) + {X : D} + (st : DevissageState D L X) : + (twistState L st).units = st.lines := rfl + +/-- The twist exchanges the line count for the unit count. -/ +@[simp] theorem twistState_lines + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (L : OddLine D) + {X : D} + (st : DevissageState D L X) : + (twistState L st).lines = st.units := rfl + +/-- **Twisting twice is trivial**: the square trivialisation +undoes the double twist. -/ +noncomputable def untwistIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] (L : OddLine D) + (X : D) : + L.obj ⊗ (L.obj ⊗ X) ≅ X := + (α_ L.obj L.obj X).symm.trans + ((whiskerRightIso L.sq X).trans (λ_ X)) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistSymPow.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistSymPow.lean new file mode 100644 index 0000000000..2769a4a9a6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistSymPow.lean @@ -0,0 +1,55 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SignConj +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TrichotomyClose + +/-! +# Symmetric powers of an odd twist + +Twisting a module by the odd line exchanges the two halves of +the trichotomy: the symmetric powers of the twist survive +exactly when the alternating powers of the module do. In arity +zero both are the tensor unit, so the exchange holds there +too. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **Surviving alternating powers become surviving symmetric +powers after the odd twist.** -/ +theorem not_isZero_symPow_twist + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [CategoryTheory.Linear ℂ D] [MonoidalLinear ℂ D] (A : D) [MonObj A] + [IsCommMonObj A] + (L : OddLine D) (R : Mod D A) + (hA : ∀ n : ℕ, ¬ IsZero (altPow A R.X n)) (n : ℕ) : + ¬ IsZero (symPow A ((tensorLeftMod A L.obj R).X) n) := by + cases n with + | zero => + intro h + exact hA 0 (isZero_of_isZero_unit _ + (h.of_iso + (symPowZero A ((tensorLeftMod A L.obj R).X)).symm)) + | succ k => + intro h + exact hA (k + 1) ((symPowOddTwist_isZero_iff A L R k).mp h) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistUnitor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistUnitor.lean new file mode 100644 index 0000000000..846e9b5730 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistUnitor.lean @@ -0,0 +1,198 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistShuffle + +/-! +# Unit, associativity and functoriality of the left twist + +The twist of a module by an object on the left is unital and +associative, is functorial in both of its slots, and carries the +free modules along the braiding. Every isomorphism here is a +structural isomorphism of the ambient category, promoted to the +category of modules by checking that it intertwines the twisted +actions. + +* `tensorLeftUnitMod`: twisting by the tensor unit is the left + unitor. +* `tensorLeftAssocMod`: nested twists collapse to a single twist + by the tensor of the twisting objects. +* functoriality in the module slot and in the twisting object: + `RS.tensorLeftModWhiskerIso` and `RS.tensorLeftModContextIso` + of `TwistShuffle.lean`. +* `freeTwistIso`: the free module on a twisted object is the + twist of the free module, through the carrying isomorphism. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-! ## The unit twist -/ + +/-- The left unitor intertwines the twist by the tensor unit with +the plain action. -/ +theorem actAcross_unit + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] + (X : D) [ModObj A X] : + actAcross A (𝟙_ D) X ≫ (λ_ X).hom = + (A ◁ (λ_ X).hom) ≫ actLeft A X := by + have h : (α_ A (𝟙_ D) X).inv ≫ ((β_ A (𝟙_ D)).hom ▷ X) ≫ + (α_ (𝟙_ D) A X).hom ≫ (λ_ (A ⊗ X)).hom = + A ◁ (λ_ X).hom := by + rw [braiding_tensorUnit_right] + monoidal + rw [actAcross] + simp only [Category.assoc] + rw [leftUnitor_naturality, reassoc_of% h] + +/-- **The unit twist collapses**: twisting a module by the tensor +unit is the left unitor, as a module isomorphism. -/ +noncomputable def tensorLeftUnitMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] + (M : Mod D A) : + tensorLeftMod A (𝟙_ D) M ≅ M where + hom := Mod.Hom.mk' (λ_ M.X).hom (by + change actAcross A (𝟙_ D) M.X ≫ (λ_ M.X).hom = + (A ◁ (λ_ M.X).hom) ≫ actLeft A M.X + exact actAcross_unit A M.X) + inv := Mod.Hom.mk' (λ_ M.X).inv (by + change actLeft A M.X ≫ (λ_ M.X).inv = + (A ◁ (λ_ M.X).inv) ≫ actAcross A (𝟙_ D) M.X + exact act_inv_of_act_hom A (λ_ M.X) (actAcross_unit A M.X)) + hom_inv_id := by + apply Mod.Hom.ext + exact (λ_ M.X).hom_inv_id + inv_hom_id := by + apply Mod.Hom.ext + exact (λ_ M.X).inv_hom_id + +/-! ## Nested twists -/ + +/-- The associator intertwines the twist by a tensor of twisting +objects with the nested twist. -/ +theorem actAcross_assoc_split + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] + (V W : D) (M : Mod D A) : + actAcross A (V ⊗ W) M.X ≫ (α_ V W M.X).hom = + (A ◁ (α_ V W M.X).hom) ≫ + actAcross A V (tensorLeftMod A W M).X := by + have h : actAcross A V (tensorLeftMod A W M).X = + (braidPast A V (W ⊗ M.X)).hom ≫ + (V ◁ actAcross A W M.X) := + actAcross_eq_braidPast A V (tensorLeftMod A W M).X + rw [h] + exact actAcross_context_split A V W M.X + +/-- **Nested twists collapse**: twisting by `W` and then by `V` is +twisting by `V ⊗ W`, through the associator. -/ +noncomputable def tensorLeftAssocMod + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] + (V W : D) (M : Mod D A) : + tensorLeftMod A V (tensorLeftMod A W M) ≅ + tensorLeftMod A (V ⊗ W) M where + hom := Mod.Hom.mk' (α_ V W M.X).inv (by + change actAcross A V (tensorLeftMod A W M).X ≫ + (α_ V W M.X).inv = + (A ◁ (α_ V W M.X).inv) ≫ actAcross A (V ⊗ W) M.X + exact act_inv_of_act_hom A (α_ V W M.X) + (actAcross_assoc_split A V W M)) + inv := Mod.Hom.mk' (α_ V W M.X).hom (by + change actAcross A (V ⊗ W) M.X ≫ (α_ V W M.X).hom = + (A ◁ (α_ V W M.X).hom) ≫ + actAcross A V (tensorLeftMod A W M).X + exact actAcross_assoc_split A V W M) + hom_inv_id := by + apply Mod.Hom.ext + exact (α_ V W M.X).inv_hom_id + inv_hom_id := by + apply Mod.Hom.ext + exact (α_ V W M.X).hom_inv_id + +/-! ## The free module on a twisted object -/ + +/-- The carrying isomorphism is natural in the crossing object. -/ +theorem braidPast_natural_head + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + {P Q : D} (f : P ⟶ Q) (V T : D) : + (f ▷ (V ⊗ T)) ≫ (braidPast Q V T).hom = + (braidPast P V T).hom ≫ (V ◁ (f ▷ T)) := by + simp only [braidPast_hom] + rw [associator_inv_naturality_left_assoc, + ← comp_whiskerRight_assoc, + BraidedCategory.braiding_naturality_left, + comp_whiskerRight_assoc, associator_naturality_middle] + simp only [Category.assoc] + +/-- The carrying isomorphism intertwines the free action on a +twisted object with the twist of the free action. -/ +theorem freeTwist_act + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] + (V X : D) : + ((α_ A A (V ⊗ X)).inv ≫ (μ[A] ▷ (V ⊗ X))) ≫ + (braidPast A V X).hom = + (A ◁ (braidPast A V X).hom) ≫ + actAcross A V (freeMod A X).X := by + let := freeModObj A X + have hbp : (braidPast (A ⊗ A) V X).hom = + (α_ A A (V ⊗ X)).hom ≫ (A ◁ (braidPast A V X).hom) ≫ + (braidPast A V (A ⊗ X)).hom ≫ (V ◁ (α_ A A X).inv) := by + rw [braidPast_hom] + exact braidPast_tensor_first A A V X + change ((α_ A A (V ⊗ X)).inv ≫ (μ[A] ▷ (V ⊗ X))) ≫ + (braidPast A V X).hom = + (A ◁ (braidPast A V X).hom) ≫ actAcross A V (A ⊗ X) + rw [actAcross_eq_braidPast A V (A ⊗ X), + show actLeft A (A ⊗ X) = (α_ A A X).inv ≫ (μ[A] ▷ X) + from rfl, + Category.assoc, braidPast_natural_head μ[A] V X, hbp] + simp only [Category.assoc, Iso.inv_hom_id_assoc, + ← MonoidalCategory.whiskerLeft_comp] + +/-- **The free module on a twisted object**: the free module on +`V ⊗ X` is the twist by `V` of the free module on `X`, through the +isomorphism carrying the algebra across the twisting object. -/ +noncomputable def freeTwistIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) + [MonObj A] + (V X : D) : + freeMod A (V ⊗ X) ≅ tensorLeftMod A V (freeMod A X) where + hom := Mod.Hom.mk' (braidPast A V X).hom (by + change ((α_ A A (V ⊗ X)).inv ≫ (μ[A] ▷ (V ⊗ X))) ≫ + (braidPast A V X).hom = + (A ◁ (braidPast A V X).hom) ≫ + actAcross A V (freeMod A X).X + exact freeTwist_act A V X) + inv := Mod.Hom.mk' (braidPast A V X).inv (by + change actAcross A V (freeMod A X).X ≫ + (braidPast A V X).inv = + (A ◁ (braidPast A V X).inv) ≫ + ((α_ A A (V ⊗ X)).inv ≫ (μ[A] ▷ (V ⊗ X))) + exact act_inv_of_act_hom A (braidPast A V X) + (freeTwist_act A V X)) + hom_inv_id := by + apply Mod.Hom.ext + exact (braidPast A V X).hom_inv_id + inv_hom_id := by + apply Mod.Hom.ext + exact (braidPast A V X).inv_hom_id + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitBase.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitBase.lean new file mode 100644 index 0000000000..7cf4ca5c76 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitBase.lean @@ -0,0 +1,181 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod + +/-! +# Modules over the tensor unit + +Over the tensor unit as base algebra, relative module theory +collapses to the ambient category. + +* `unitMod`: any object, as a module over the unit through the + trivial action; the unit law forces the action of any module + over the unit to be the left unitor (`modObj_unitBase_smul`). +* `modTensorUnitBase`: over the trivial base the two coequalizer + legs agree, so the module tensor product collapses to the plain + tensor product of the carriers. +* `freeModUnitBase`: the free module on `V` over the unit is `V` + itself, via the left unitor. +* `modBiprodZeroLeft`: over any base, the biproduct with a module + whose carrier is zero collapses to the other summand. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +section UnitModule + +/-- Any object, as a module over the tensor unit through the +trivial action. -/ +def unitMod [Category.{v} D] [MonoidalCategory D] + (X : D) : Mod D (𝟙_ D) := ⟨X⟩ + +@[simp] lemma unitMod_X [Category.{v} D] [MonoidalCategory D] + (X : D) : (unitMod X).X = X := rfl + +/-- Any action of the tensor unit is the left unitor: the unit +law forces it, since the unit of the trivial base is the +identity. The instance is quantified, so the lemma applies to +the action of any module over the unit, not only the trivial +one. -/ +lemma modObj_unitBase_smul + [Category.{v} D] [MonoidalCategory D] (X : D) [inst : ModObj (𝟙_ D) X] : + γ[𝟙_ D, X] = (λ_ X).hom := by + have h := ModObj.one_smul_self (𝟙_ D) X + rw [MonObj.one_def, MonoidalCategory.id_whiskerRight, + Category.id_comp] at h + exact h + +/-- The action of any module over the unit, in `actLeft` form. -/ +lemma actLeft_unitBase + [Category.{v} D] [MonoidalCategory D] (X : D) [inst : ModObj (𝟙_ D) X] : + actLeft (𝟙_ D) X = (λ_ X).hom := + modObj_unitBase_smul X + +end UnitModule + +section TensorUnitBase + +/-- The braided right action of any module over the unit is the +right unitor. -/ +lemma actRight_unitBase + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (X : D) [inst : ModObj (𝟙_ D) X] : + actRight (𝟙_ D) X = (ρ_ X).hom := by + rw [actRight, actLeft_unitBase, braiding_tensorUnit_right] + simp + +/-- Over the trivial base the two coequalizer legs of the module +tensor product are equal morphisms. -/ +lemma modTensorLegM_unitBase_eq + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (M : Mod D (𝟙_ D)) (N : Mod D (𝟙_ D)) : + modTensorLegM (𝟙_ D) M N = modTensorLegN (𝟙_ D) M N := by + rw [modTensorLegM, modTensorLegN, + actRight_unitBase M.X (inst := M.mod), + actLeft_unitBase N.X (inst := N.mod)] + monoidal + +/-- **Over the trivial base the module tensor product is the +plain tensor product**: the coequalizer of a pair of equal legs +is the target itself. -/ +@[simps] +noncomputable def modTensorUnitBase + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (M : Mod D (𝟙_ D)) (N : Mod D (𝟙_ D)) [HasCoequalizers D] : + modTensor (𝟙_ D) M N ≅ M.X ⊗ N.X where + hom := modTensorDesc (𝟙_ D) M N (𝟙 (M.X ⊗ N.X)) + (by rw [modTensorLegM_unitBase_eq]) + inv := modTensorπ (𝟙_ D) M N + hom_inv_id := by + apply modTensor_hom_ext + rw [modTensorπ_desc_assoc, Category.id_comp, + Category.comp_id] + inv_hom_id := modTensorπ_desc (𝟙_ D) M N _ _ + +end TensorUnitBase + +section FreeUnitBase + +/-- The left unitor intertwines the free action over the unit +with the trivial action. -/ +theorem freeModUnitBase_linear [Category.{v} D] [MonoidalCategory D] (V : D) : + ((α_ (𝟙_ D) (𝟙_ D) V).inv ≫ (λ_ (𝟙_ D)).hom ▷ V) ≫ + (λ_ V).hom = + (𝟙_ D) ◁ (λ_ V).hom ≫ (λ_ V).hom := by + monoidal + +/-- The left unitor intertwines the trivial action with the free +action over the unit. -/ +theorem freeModUnitBase_linear_inv + [Category.{v} D] [MonoidalCategory D] (V : D) : + (λ_ V).hom ≫ (λ_ V).inv = + (𝟙_ D) ◁ (λ_ V).inv ≫ + ((α_ (𝟙_ D) (𝟙_ D) V).inv ≫ (λ_ (𝟙_ D)).hom ▷ V) := by + monoidal + +/-- **The free module over the trivial base is its generator**, +via the left unitor. -/ +noncomputable def freeModUnitBase + [Category.{v} D] [MonoidalCategory D] (V : D) : + freeMod (𝟙_ D) V ≅ unitMod V where + hom := Mod.Hom.mk' (λ_ V).hom (by + change ((α_ (𝟙_ D) (𝟙_ D) V).inv ≫ (λ_ (𝟙_ D)).hom ▷ V) ≫ + (λ_ V).hom = + (𝟙_ D) ◁ (λ_ V).hom ≫ (λ_ V).hom + exact freeModUnitBase_linear V) + inv := Mod.Hom.mk' (λ_ V).inv (by + change (λ_ V).hom ≫ (λ_ V).inv = + (𝟙_ D) ◁ (λ_ V).inv ≫ + ((α_ (𝟙_ D) (𝟙_ D) V).inv ≫ (λ_ (𝟙_ D)).hom ▷ V) + exact freeModUnitBase_linear_inv V) + hom_inv_id := by + apply Mod.Hom.ext + exact (λ_ V).hom_inv_id + inv_hom_id := by + apply Mod.Hom.ext + exact (λ_ V).inv_hom_id + +end FreeUnitBase + +section BiprodZero + +/-- **Collapse of a zero summand**: over any base, the module +biproduct with a module whose carrier is zero is the other +summand. -/ +noncomputable def modBiprodZeroLeft + [Category.{v} D] [MonoidalCategory D] [Preadditive D] + [MonoidalPreadditive D] [HasBinaryBiproducts D] (A : D) [MonObj A] + (Z : Mod D A) (N : Mod D A) + (hZ : IsZero Z.X) : + modBiprod A Z N ≅ N where + hom := modBiprodSnd A Z N + inv := modBiprodInr A Z N + hom_inv_id := by + apply Mod.Hom.ext + change (biprod.snd ≫ biprod.inr : Z.X ⊞ N.X ⟶ _) = 𝟙 _ + have hfst : (biprod.fst : Z.X ⊞ N.X ⟶ Z.X) = 0 := + hZ.eq_of_tgt _ _ + rw [← biprod.total, hfst, Limits.zero_comp, zero_add] + inv_hom_id := by + apply Mod.Hom.ext + change (biprod.inr ≫ biprod.snd : N.X ⟶ _) = 𝟙 _ + rw [biprod.inr_snd] + +end BiprodZero + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitFreeMod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitFreeMod.lean new file mode 100644 index 0000000000..eacf4ea32c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitFreeMod.lean @@ -0,0 +1,55 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitBase + +/-! +# The trivial module as a free module + +Over the tensor unit as base algebra the free module on `V` and +the trivial module on `V` agree, through the left unitor. + +* `unitFreeIso`: the trivial module `unitMod V` is isomorphic, as + a module over the unit, to the free module `freeMod (𝟙_ D) V`, + by the inverse left unitor `(λ_ V).inv : V ⟶ 𝟙_ D ⊗ V`. + +This is the collapse `freeModUnitBase` read in the direction that +presents a bare object as a free module; the linearity of either +leg is the coherence identity in the monoidal unit recorded by +`freeModUnitBase_linear` and `freeModUnitBase_linear_inv`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +variable {D : Type u} + +section UnitFree + +/-- **The trivial module on `V` is the free module on `V` over +the tensor unit**, through the inverse left unitor. -/ +noncomputable def unitFreeIso [Category.{v} D] [MonoidalCategory D] (V : D) : + unitMod V ≅ freeMod (𝟙_ D) V := + (freeModUnitBase V).symm + +@[simp] lemma unitFreeIso_hom_hom + [Category.{v} D] [MonoidalCategory D] (V : D) : + (unitFreeIso V).hom.hom = (λ_ V).inv := rfl + +@[simp] lemma unitFreeIso_inv_hom + [Category.{v} D] [MonoidalCategory D] (V : D) : + (unitFreeIso V).inv.hom = (λ_ V).hom := rfl + +end UnitFree + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitMod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitMod.lean new file mode 100644 index 0000000000..176f3d0f8b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitMod.lean @@ -0,0 +1,93 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymAlg + +/-! +# Module powers over the unit monoid + +Over the trivial monoid the module relations collapse: both slot +legs are the same unitor slide, the assembled relation pair is +equal, and the module power projection is an isomorphism onto the +plain tensor power. Symmetric powers of a bare object are thereby +the general machinery instantiated at the unit, with every +multiplication law inherited — the substrate of the local +splitting algebra. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- Over the unit monoid the action is the left unitor. -/ +theorem actLeft_unit [Category.{v} D] [MonoidalCategory D] + (X : D) : + actLeft (𝟙_ D) X = (λ_ X).hom := rfl + +/-- Over the unit monoid the braided right action is the right +unitor. -/ +theorem actRight_unit [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (X : D) : + actRight (𝟙_ D) X = (ρ_ X).hom := by + rw [actRight, actLeft_unit] + simp + +/-- Over the unit monoid the two slot legs coincide. -/ +theorem winLeg_unit [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + (X : D) : + winLegM (𝟙_ D) X = winLegN (𝟙_ D) X := by + rw [winLegM, winLegN, actRight_unit, actLeft_unit] + exact (MonoidalCategory.triangle X X).symm + +section Pow + +/-- Over the unit monoid the assembled relation legs coincide. -/ +theorem modPowLeg_unit [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] + (X : D) (n : ℕ) : + modPowLegFst (𝟙_ D) X n = modPowLegSnd (𝟙_ D) X n := by + rw [modPowLegFst, modPowLegSnd] + refine biproduct.hom_ext' _ _ fun i => ?_ + simp only [biproduct.ι_desc] + rw [modPowLegM, modPowLegN, winLeg_unit] + +/-- **The module power over the unit monoid is the plain tensor +power**: the relation pair is equal, so the coequalizer collapses +onto its target. -/ +noncomputable def modPowUnitIso + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + (X : D) (n : ℕ) : + modPow (𝟙_ D) X n ≅ tensorPow D X n where + hom := coequalizer.desc (𝟙 _) + (by rw [modPowLeg_unit]) + inv := modPowπ (𝟙_ D) X n + hom_inv_id := coequalizer.hom_ext + (((Category.assoc _ _ _).symm.trans + ((eq_whisker (coequalizer.π_desc _ _) _).trans + (Category.id_comp _))).trans (Category.comp_id _).symm) + inv_hom_id := coequalizer.π_desc _ _ + +/-- The projection onto the module power over the unit monoid is +invertible. -/ +instance [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + (X : D) (n : ℕ) : IsIso (modPowπ (𝟙_ D) X n) := + ⟨(modPowUnitIso X n).hom, (modPowUnitIso X n).inv_hom_id, + (modPowUnitIso X n).hom_inv_id⟩ + +end Pow + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitSimple.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitSimple.lean new file mode 100644 index 0000000000..01b860a35c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitSimple.lean @@ -0,0 +1,457 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Definitions + +/-! +# Simplicity of the tensor unit + +In the setting of Deligne's theorem — an abelian ℂ-linear rigid +monoidal category whose unit endomorphisms are exactly the scalars — +the tensor unit is a simple object. This is Proposition 1.17 of +Deligne–Milne, *Tannakian categories*. + +The argument follows Deligne–Milne. Given a nonzero subobject +`i : U ⟶ 𝟙`, write `V` for the cokernel of `i` and `D : 𝟙 ⟶ 𝟙 ⊗ Uᘁ` +for the mate of `i` under the duality adjunction, and set +`W := ker D`. Exactness of the tensor product in each variable +(rigidity provides two-sided adjoints to whiskering) yields +`V ⊗ U = 0`, `U ⊗ V = 0` and `W ⊗ U = 0`, from which the composite +`W ⟶ 𝟙 ⟶ V` is an isomorphism. The resulting splitting of `𝟙 ↠ V` +produces an idempotent unit endomorphism, and `End (𝟙) = ℂ` has no +idempotents besides `0` and `1`: the value `1` would force `i = 0`, +so the idempotent vanishes, `V = 0`, and `i` is an isomorphism. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Limits MonoidalCategory + +universe v u + +/-! ## Scalars on the unit + +Consequences of `HasScalarUnit` alone: the identity of the unit is +nonzero, and the only idempotent endomorphisms of the unit are `0` +and the identity. -/ + +section UnitScalars + +variable {A : Type u} + +/-- Under `HasScalarUnit`, the identity of the unit is nonzero. -/ +theorem id_unit_ne_zero + [Category.{v} A] [Preadditive A] [Linear ℂ A] [MonoidalCategory A] + (hu : HasScalarUnit A) : 𝟙 (𝟙_ A) ≠ 0 := by + intro h + have h1 : ((1 : ℂ) • 𝟙 (𝟙_ A) : 𝟙_ A ⟶ 𝟙_ A) = (0 : ℂ) • 𝟙 (𝟙_ A) := by + rw [one_smul, zero_smul, h] + exact one_ne_zero (hu.injective h1) + +/-- Under `HasScalarUnit`, the only idempotent endomorphisms of the +unit are `0` and the identity: composition of scalar endomorphisms +is multiplication in ℂ, and a field has no other idempotents. -/ +theorem HasScalarUnit.idempotent_eq_zero_or_id + [Category.{v} A] [Preadditive A] [Linear ℂ A] [MonoidalCategory A] + (hu : HasScalarUnit A) + {e : 𝟙_ A ⟶ 𝟙_ A} (he : e ≫ e = e) : e = 0 ∨ e = 𝟙 (𝟙_ A) := by + obtain ⟨c, hc⟩ := hu.surjective e + replace hc : c • 𝟙 (𝟙_ A) = e := hc + have h1 : ((c * c) • 𝟙 (𝟙_ A) : 𝟙_ A ⟶ 𝟙_ A) = c • 𝟙 (𝟙_ A) := by + calc ((c * c) • 𝟙 (𝟙_ A) : 𝟙_ A ⟶ 𝟙_ A) + = (c • 𝟙 (𝟙_ A)) ≫ (c • 𝟙 (𝟙_ A)) := by + simp [Linear.comp_smul, smul_smul] + _ = e ≫ e := by rw [hc] + _ = e := he + _ = c • 𝟙 (𝟙_ A) := hc.symm + have hcc : c * c = c := hu.injective h1 + have hcases : c = 0 ∨ c = 1 := by + rcases mul_eq_zero.mp + (show c * (c - 1) = 0 by rw [mul_sub, mul_one, hcc, sub_self]) + with h | h + · exact Or.inl h + · exact Or.inr (sub_eq_zero.mp h) + rcases hcases with h | h + · exact Or.inl (by rw [← hc, h, zero_smul]) + · exact Or.inr (by rw [← hc, h, one_smul]) + +end UnitScalars + +/-! ## Exactness of whiskering + +In a rigid category each whiskering functor has adjoints on both +sides, so it preserves monomorphisms, epimorphisms and kernels. -/ + +section Whiskering + +variable {A : Type u} + +/-- Whiskering on the left preserves monomorphisms. -/ +private theorem tensorLeft_preservesMono + [Category.{v} A] [MonoidalCategory A] [RigidCategory A] + (X : A) : + (tensorLeft X).PreservesMonomorphisms := + Functor.preservesMonomorphisms_of_adjunction (tensorLeftAdjunction X (Xᘁ)) + +/-- Whiskering on the left preserves epimorphisms. -/ +private theorem tensorLeft_preservesEpi + [Category.{v} A] [MonoidalCategory A] [RigidCategory A] + (X : A) : + (tensorLeft X).PreservesEpimorphisms := + Functor.preservesEpimorphisms_of_adjunction (tensorLeftAdjunction (ᘁX) X) + +/-- Whiskering on the right preserves monomorphisms. -/ +private theorem tensorRight_preservesMono + [Category.{v} A] [MonoidalCategory A] [RigidCategory A] + (X : A) : + (tensorRight X).PreservesMonomorphisms := + Functor.preservesMonomorphisms_of_adjunction (tensorRightAdjunction (ᘁX) X) + +/-- Whiskering on the right preserves epimorphisms. -/ +private theorem tensorRight_preservesEpi + [Category.{v} A] [MonoidalCategory A] [RigidCategory A] + (X : A) : + (tensorRight X).PreservesEpimorphisms := + Functor.preservesEpimorphisms_of_adjunction (tensorRightAdjunction X (Xᘁ)) + +/-- Whiskering on the left preserves limits, in particular kernels. -/ +private theorem tensorLeft_preservesLimits + [Category.{v} A] [MonoidalCategory A] [RigidCategory A] + (X : A) : + PreservesLimitsOfSize.{0, 0} (tensorLeft X) := + (tensorLeftAdjunction X (Xᘁ)).rightAdjoint_preservesLimits + +end Whiskering + +/-! ## The mate of a subobject of the unit + +For a monomorphism `i : U ⟶ 𝟙` the mate `D : 𝟙 ⟶ 𝟙 ⊗ Uᘁ` under the +duality adjunction detects which maps into the unit are annihilated +by tensoring with `U`: if `x ≫ D = 0` then `x ▷ U = 0`. -/ + +section Mate + +variable {A : Type u} + +/-- A monomorphism that vanishes has a zero source. -/ +private theorem isZero_of_mono_eq_zero [Category.{v} A] [Preadditive A] + {X Y : A} (f : X ⟶ Y) [Mono f] + (h : f = 0) : IsZero X := by + rw [IsZero.iff_id_eq_zero, ← cancel_mono f, h, comp_zero, zero_comp] + +/-- The duality correspondence sends zero to zero. -/ +private theorem tensorRightHomEquiv_zero + [Category.{v} A] [Preadditive A] [MonoidalCategory A] + [MonoidalPreadditive A] + (X Y Y' Z : A) + [ExactPairing Y Y'] : tensorRightHomEquiv X Y Y' Z 0 = 0 := by + simp [tensorRightHomEquiv] + +/-- The inverse duality correspondence sends zero to zero. -/ +private theorem tensorRightHomEquiv_symm_zero + [Category.{v} A] [Preadditive A] [MonoidalCategory A] + [MonoidalPreadditive A] + (X Y Y' Z : A) + [ExactPairing Y Y'] : (tensorRightHomEquiv X Y Y' Z).symm 0 = 0 := by + simp [tensorRightHomEquiv] + +/-- The mate `𝟙 ⟶ 𝟙 ⊗ Uᘁ` of a subobject inclusion `i : U ⟶ 𝟙` +under the duality adjunction for `U`. -/ +private noncomputable def unitMate + [Category.{v} A] [MonoidalCategory A] [RigidCategory A] + {U : A} (i : U ⟶ 𝟙_ A) : + 𝟙_ A ⟶ 𝟙_ A ⊗ Uᘁ := + tensorRightHomEquiv (𝟙_ A) U (Uᘁ) (𝟙_ A) ((λ_ U).hom ≫ i) + +/-- Maps into the unit annihilated by the mate are annihilated by +tensoring with the subobject. -/ +private theorem whiskerRight_eq_zero_of_comp_unitMate + [Category.{v} A] [Preadditive A] [MonoidalCategory A] + [MonoidalPreadditive A] [RigidCategory A] + {U X : A} + (i : U ⟶ 𝟙_ A) [Mono i] (x : X ⟶ 𝟙_ A) + (hx : x ≫ unitMate i = 0) : x ▷ U = 0 := by + have h1 : (tensorRightHomEquiv X U (Uᘁ) (𝟙_ A)).symm (x ≫ unitMate i) + = x ▷ U ≫ (λ_ U).hom ≫ i := by + rw [tensorRightHomEquiv_symm_naturality, unitMate, + Equiv.symm_apply_apply] + rw [hx, tensorRightHomEquiv_symm_zero] at h1 + have h2 : x ▷ U ≫ (λ_ U).hom = 0 := by + rw [← cancel_mono i, Category.assoc, ← h1, zero_comp] + rw [← cancel_mono (λ_ U).hom, h2, zero_comp] + +end Mate + +/-! ## Vanishing tensor products + +For a subobject `i : U ⟶ 𝟙` with cokernel `V`, both `V ⊗ U` and +`U ⊗ V` vanish: the composite of the whiskered epimorphism and the +whiskered monomorphism through them is `i ≫ π = 0`. The kernel `W` +of the mate also satisfies `W ⊗ U = 0`, by construction of the +mate. -/ + +section Vanishing + +variable {A : Type u} + +/-- `V ⊗ U = 0` for the cokernel `V` of a subobject `U` of the +unit. -/ +private theorem isZero_coker_tensor + [Category.{v} A] [Abelian A] [MonoidalCategory A] [RigidCategory A] + {U : A} (i : U ⟶ 𝟙_ A) [Mono i] : + IsZero (cokernel i ⊗ U) := by + have := tensorLeft_preservesMono (A := A) (cokernel i) + have := tensorRight_preservesEpi (A := A) U + have : Mono (cokernel i ◁ i) := + Functor.map_mono (tensorLeft (cokernel i)) i + have : Epi (cokernel.π i ▷ U) := + Functor.map_epi (tensorRight U) (cokernel.π i) + have hcomp : cokernel.π i ▷ U ≫ cokernel i ◁ i = 0 := by + rw [← whisker_exchange] + simp [unitors_inv_equal] + exact isZero_of_mono_eq_zero _ (zero_of_epi_comp _ hcomp) + +/-- `U ⊗ V = 0` for the cokernel `V` of a subobject `U` of the +unit. -/ +private theorem isZero_tensor_coker + [Category.{v} A] [Abelian A] [MonoidalCategory A] [RigidCategory A] + {U : A} (i : U ⟶ 𝟙_ A) [Mono i] : + IsZero (U ⊗ cokernel i) := by + have := tensorRight_preservesMono (A := A) (cokernel i) + have := tensorLeft_preservesEpi (A := A) U + have : Mono (i ▷ cokernel i) := + Functor.map_mono (tensorRight (cokernel i)) i + have : Epi (U ◁ cokernel.π i) := + Functor.map_epi (tensorLeft U) (cokernel.π i) + have hcomp : U ◁ cokernel.π i ≫ i ▷ cokernel i = 0 := by + rw [whisker_exchange] + simp [unitors_equal] + exact isZero_of_mono_eq_zero _ (zero_of_epi_comp _ hcomp) + +/-- `W ⊗ U = 0` for the kernel `W` of the mate of `i : U ⟶ 𝟙`. -/ +private theorem isZero_kernelMate_tensor + [Category.{v} A] [Abelian A] [MonoidalCategory A] + [MonoidalPreadditive A] [RigidCategory A] + {U : A} (i : U ⟶ 𝟙_ A) + [Mono i] : IsZero (kernel (unitMate i) ⊗ U) := by + have := tensorRight_preservesMono (A := A) U + have : Mono (kernel.ι (unitMate i) ▷ U) := + Functor.map_mono (tensorRight U) (kernel.ι (unitMate i)) + exact isZero_of_mono_eq_zero _ + (whiskerRight_eq_zero_of_comp_unitMate i _ (kernel.condition _)) + +end Vanishing + +/-! ## The kernel of the mate maps onto the cokernel + +Whiskering the mate by the cokernel `V` kills it, because the mate +factors through `i` and `V ⊗ U = 0`. Since whiskering preserves +kernels, `V ◁ kernel.ι` is then the kernel of a zero map, hence an +isomorphism `V ⊗ W ≅ V ⊗ 𝟙`. -/ + +section KernelMate + +variable {A : Type u} + +/-- Whiskering the mate of `i` by the cokernel of `i` gives zero. -/ +private theorem whiskerLeft_unitMate_zero + [Category.{v} A] [Abelian A] [MonoidalCategory A] + [MonoidalPreadditive A] [RigidCategory A] + {U : A} (i : U ⟶ 𝟙_ A) + [Mono i] : cokernel i ◁ unitMate i = 0 := by + have hz : cokernel i ◁ i = 0 := + (isZero_coker_tensor i).eq_zero_of_src _ + have h1 := tensorRightHomEquiv_tensor (Y := U) (unitMate i) + (𝟙 (cokernel i)) + have h2 : (tensorRightHomEquiv (𝟙_ A) U (Uᘁ) (𝟙_ A)).symm (unitMate i) + = (λ_ U).hom ≫ i := by + rw [unitMate, Equiv.symm_apply_apply] + rw [h2] at h1 + have h3 : (α_ (cokernel i) (𝟙_ A) U).hom + ≫ (𝟙 (cokernel i) ⊗ₘ ((λ_ U).hom ≫ i)) = 0 := by + simp [hz] + rw [h3] at h1 + have h4 : (𝟙 (cokernel i) ⊗ₘ unitMate i) + ≫ (α_ (cokernel i) (𝟙_ A) (Uᘁ)).inv = 0 := by + have h5 := congrArg + (tensorRightHomEquiv (cokernel i ⊗ 𝟙_ A) U (Uᘁ) + (cokernel i ⊗ 𝟙_ A)) h1 + rwa [Equiv.apply_symm_apply, tensorRightHomEquiv_zero] at h5 + rw [← cancel_mono (α_ (cokernel i) (𝟙_ A) (Uᘁ)).inv, zero_comp, + ← MonoidalCategory.id_tensorHom] + exact h4 + +/-- The cokernel-whiskered kernel inclusion of the mate is an +isomorphism `V ⊗ W ≅ V ⊗ 𝟙`. -/ +private theorem isIso_whiskerLeft_kernelMate + [Category.{v} A] [Abelian A] [MonoidalCategory A] + [MonoidalPreadditive A] [RigidCategory A] + {U : A} (i : U ⟶ 𝟙_ A) + [Mono i] : IsIso (cokernel i ◁ kernel.ι (unitMate i)) := by + have : PreservesLimitsOfSize.{0, 0} (tensorLeft (cokernel i)) := + tensorLeft_preservesLimits (cokernel i) + have hlim := isLimitForkMapOfIsLimit' (tensorLeft (cokernel i)) + (kernel.condition (unitMate i)) (kernelIsKernel (unitMate i)) + have hzero : (tensorLeft (cokernel i)).map (unitMate i) = 0 := + whiskerLeft_unitMate_zero i + obtain ⟨l, hl⟩ := KernelFork.IsLimit.lift' hlim + (𝟙 ((tensorLeft (cokernel i)).obj (𝟙_ A))) + (by rw [hzero, comp_zero]) + simp only [Fork.ι_ofι] at hl + have : IsSplitEpi + ((tensorLeft (cokernel i)).map (kernel.ι (unitMate i))) := + IsSplitEpi.mk' ⟨l, hl⟩ + have := tensorLeft_preservesMono (A := A) (cokernel i) + have : Mono ((tensorLeft (cokernel i)).map (kernel.ι (unitMate i))) := + Functor.map_mono _ _ + exact isIso_of_mono_of_epi + ((tensorLeft (cokernel i)).map (kernel.ι (unitMate i))) + +end KernelMate + +/-! ## Subobjects of `U` killed by `⊗ U` + +A subobject `T` of `U` with `T ⊗ U = 0` is zero: `T ⊗ V` vanishes +because `U ⊗ V` does, and whiskering the exact sequence +`U ⟶ 𝟙 ⟶ V` by `T` exhibits `T ≅ T ⊗ 𝟙` as an extension of the two +vanishing ends. -/ + +section Subobjects + +variable {A : Type u} + +/-- A subobject of `U` annihilated by tensoring with `U` is zero. -/ +private theorem isZero_of_sub_of_tensor_isZero + [Category.{v} A] [Abelian A] [MonoidalCategory A] [RigidCategory A] + {U T : A} + (i : U ⟶ 𝟙_ A) [Mono i] (t : T ⟶ U) (ht : Mono t) + (hT : IsZero (T ⊗ U)) : IsZero T := by + have := ht + have := tensorRight_preservesMono (A := A) (cokernel i) + have : Mono (t ▷ cokernel i) := + Functor.map_mono (tensorRight (cokernel i)) t + have hTV : IsZero (T ⊗ cokernel i) := + IsZero.of_mono (t ▷ cokernel i) (isZero_tensor_coker i) + have : PreservesLimitsOfSize.{0, 0} (tensorLeft T) := + tensorLeft_preservesLimits T + have hbase : IsLimit (KernelFork.ofι i (cokernel.condition i)) := + Abelian.monoIsKernelOfCokernel + (CokernelCofork.ofπ (cokernel.π i) (cokernel.condition i)) + (cokernelIsCokernel i) + have hlim := isLimitForkMapOfIsLimit' (tensorLeft T) + (cokernel.condition i) hbase + have : Mono (T ◁ cokernel.π i) := + Preadditive.mono_of_isZero_kernel' _ hlim hT + have := tensorLeft_preservesEpi (A := A) T + have : Epi (T ◁ cokernel.π i) := + Functor.map_epi (tensorLeft T) (cokernel.π i) + have : IsIso (T ◁ cokernel.π i) := isIso_of_mono_of_epi _ + have h1 : IsZero (T ⊗ 𝟙_ A) := + hTV.of_iso (asIso (T ◁ cokernel.π i)) + exact h1.of_iso (ρ_ T).symm + +end Subobjects + +/-! ## The theorem -/ + +section Main + +/-- **The tensor unit is simple** in the setting of Deligne's +theorem: in an abelian ℂ-linear rigid monoidal category whose unit +endomorphisms are exactly the scalars, `𝟙_ A` is a simple object. +This is Proposition 1.17 of Deligne–Milne, *Tannakian categories*. -/ +theorem simple_unit_of_hasScalarUnit + {A : Type u} [Category.{v} A] [Abelian A] [Linear ℂ A] + [MonoidalCategory A] [MonoidalPreadditive A] + [RigidCategory A] (hu : HasScalarUnit A) : + Simple (𝟙_ A) := by + constructor + intro U i hi + have := hi + constructor + · -- an isomorphism into the unit is nonzero + intro hIso h0 + have := hIso + have hU : IsZero (𝟙_ A) := + (isZero_of_mono_eq_zero i h0).of_iso (asIso i).symm + exact id_unit_ne_zero hu (hU.eq_zero_of_src _) + · -- a nonzero subobject of the unit is everything + intro hne + -- `W ⟶ 𝟙 ⟶ V` is epi: it factors as + -- `λ⁻¹ ≫ (π ▷ W ≫ V ◁ ι) ≫ ρ` with `V ◁ ι` invertible + have : IsIso (cokernel i ◁ kernel.ι (unitMate i)) := + isIso_whiskerLeft_kernelMate i + have := tensorRight_preservesEpi (A := A) (kernel (unitMate i)) + have : Epi (cokernel.π i ▷ kernel (unitMate i)) := + Functor.map_epi (tensorRight (kernel (unitMate i))) + (cokernel.π i) + have hfact : kernel.ι (unitMate i) ≫ cokernel.π i + = (λ_ (kernel (unitMate i))).inv + ≫ (cokernel.π i ▷ kernel (unitMate i) + ≫ cokernel i ◁ kernel.ι (unitMate i)) + ≫ (ρ_ (cokernel i)).hom := by + rw [← whisker_exchange] + simp [unitors_inv_equal] + have : Epi (kernel.ι (unitMate i) ≫ cokernel.π i) := by + rw [hfact]; infer_instance + -- `W ⟶ 𝟙 ⟶ V` is mono: its kernel lies in both `U` and `W`, + -- so it is killed by `⊗ U`, hence zero + have hbase : IsLimit (KernelFork.ofι i (cokernel.condition i)) := + Abelian.monoIsKernelOfCokernel + (CokernelCofork.ofπ (cokernel.π i) (cokernel.condition i)) + (cokernelIsCokernel i) + obtain ⟨j, hj⟩ := KernelFork.IsLimit.lift' hbase + (kernel.ι (kernel.ι (unitMate i) ≫ cokernel.π i) + ≫ kernel.ι (unitMate i)) + (by rw [Category.assoc]; exact kernel.condition _) + simp only [Fork.ι_ofι] at hj + have : Mono (j ≫ i) := by rw [hj]; exact mono_comp _ _ + have := tensorRight_preservesMono (A := A) U + have : Mono + (kernel.ι (kernel.ι (unitMate i) ≫ cokernel.π i) ▷ U) := + Functor.map_mono (tensorRight U) _ + have hKU : IsZero + (kernel (kernel.ι (unitMate i) ≫ cokernel.π i) ⊗ U) := + isZero_of_mono_eq_zero + (kernel.ι (kernel.ι (unitMate i) ≫ cokernel.π i) ▷ U) + ((isZero_kernelMate_tensor i).eq_zero_of_tgt _) + have hK : IsZero (kernel (kernel.ι (unitMate i) ≫ cokernel.π i)) := + isZero_of_sub_of_tensor_isZero i j (mono_of_mono j i) hKU + have : Mono (kernel.ι (unitMate i) ≫ cokernel.π i) := + Abelian.mono_of_kernel_ι_eq_zero _ (hK.eq_zero_of_src _) + have : IsIso (kernel.ι (unitMate i) ≫ cokernel.π i) := + isIso_of_mono_of_epi _ + -- the resulting splitting of `𝟙 ↠ V` is an idempotent scalar + set σ : cokernel i ⟶ 𝟙_ A := + inv (kernel.ι (unitMate i) ≫ cokernel.π i) + ≫ kernel.ι (unitMate i) + have hσq : σ ≫ cokernel.π i = 𝟙 (cokernel i) := by + rw [Category.assoc, IsIso.inv_hom_id] + have hidem : (cokernel.π i ≫ σ) ≫ (cokernel.π i ≫ σ) + = cokernel.π i ≫ σ := by + rw [Category.assoc, ← Category.assoc σ, hσq, Category.id_comp] + rcases hu.idempotent_eq_zero_or_id hidem with h0 | h1 + · -- idempotent zero: the cokernel vanishes and `i` is epi + have hq0 : cokernel.π i = 0 := by + have h2 : (cokernel.π i ≫ σ) ≫ cokernel.π i = cokernel.π i := by + rw [Category.assoc, hσq, Category.comp_id] + rw [h0, zero_comp] at h2 + exact h2.symm + have : Epi i := Abelian.epi_of_cokernel_π_eq_zero i hq0 + exact isIso_of_mono_of_epi i + · -- idempotent one: `i` would vanish, contradiction + refine absurd ?_ hne + have h2 : i ≫ cokernel.π i ≫ σ = i := by + rw [h1, Category.comp_id] + rw [← h2, ← Category.assoc, cokernel.condition, zero_comp] + +end Main + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitStage.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitStage.lean new file mode 100644 index 0000000000..201b5433ec --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitStage.lean @@ -0,0 +1,97 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear + +/-! +# Stage detection for maps out of the unit + +The monoidal unit of the ind-category is the embedded unit, so +maps out of it into filtered colimits factor through stages — the +form in which the Key Lemma's colimit algebra is probed. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v + +variable {C : Type v} + +/-- A map from the monoidal unit of the ind-category into a +filtered colimit factors through a stage. -/ +theorem exists_factor_of_unit_hom_colimit [SmallCategory C] [MonoidalCategory C] + {I : Type v} + [SmallCategory I] [IsFiltered I] (D : I ⥤ Ind C) + (f : 𝟙_ (Ind C) ⟶ colimit D) : + ∃ (i : I) (g : 𝟙_ (Ind C) ⟶ D.obj i), + g ≫ colimit.ι D i = f := by + obtain ⟨i, g, hg⟩ := exists_factor_of_hom_colimit D (𝟙_ C) + ((indOfUnitIso (C := C)).inv ≫ f) + refine ⟨i, (indOfUnitIso (C := C)).hom ≫ g, ?_⟩ + rw [Category.assoc, hg, ← Category.assoc, Iso.hom_inv_id, + Category.id_comp] + +/-- Two maps from the unit merged in a filtered colimit merge at a +stage. -/ +theorem unit_factor_eq_of_hom_colimit [SmallCategory C] [MonoidalCategory C] + {I : Type v} + [SmallCategory I] [IsFiltered I] (D : I ⥤ Ind C) {i j : I} + (g₁ : 𝟙_ (Ind C) ⟶ D.obj i) (g₂ : 𝟙_ (Ind C) ⟶ D.obj j) + (h : g₁ ≫ colimit.ι D i = g₂ ≫ colimit.ι D j) : + ∃ (k : I) (α : i ⟶ k) (β : j ⟶ k), + g₁ ≫ D.map α = g₂ ≫ D.map β := by + obtain ⟨k, α, β, hk⟩ := factor_eq_of_hom_colimit D (𝟙_ C) + ((indOfUnitIso (C := C)).inv ≫ g₁) + ((indOfUnitIso (C := C)).inv ≫ g₂) + (by rw [Category.assoc, Category.assoc, h]) + refine ⟨k, α, β, ?_⟩ + calc g₁ ≫ D.map α + = ((indOfUnitIso (C := C)).hom ≫ + ((indOfUnitIso (C := C)).inv ≫ g₁)) ≫ D.map α := by + rw [← Category.assoc, Iso.hom_inv_id, Category.id_comp] + _ = (indOfUnitIso (C := C)).hom ≫ + (((indOfUnitIso (C := C)).inv ≫ g₁) ≫ D.map α) := + Category.assoc _ _ _ + _ = (indOfUnitIso (C := C)).hom ≫ + (((indOfUnitIso (C := C)).inv ≫ g₂) ≫ D.map β) := by + rw [hk] + _ = ((indOfUnitIso (C := C)).hom ≫ + ((indOfUnitIso (C := C)).inv ≫ g₂)) ≫ D.map β := + (Category.assoc _ _ _).symm + _ = g₂ ≫ D.map β := by + rw [← Category.assoc, Iso.hom_inv_id, Category.id_comp] + +/-- **Vanishing at a stage**: a unit-map's image in the colimit is +zero exactly when a transition map kills it. -/ +theorem unit_colimit_eq_zero_iff + [SmallCategory C] [MonoidalCategory C] [Preadditive C] + [HasFiniteColimits C] + {I : Type v} [SmallCategory I] + [IsFiltered I] (D : I ⥤ Ind C) {i : I} + (u : 𝟙_ (Ind C) ⟶ D.obj i) : + u ≫ colimit.ι D i = 0 ↔ + ∃ (k : I) (α : i ⟶ k), u ≫ D.map α = 0 := by + constructor + · intro h + obtain ⟨k, α, β, hk⟩ := unit_factor_eq_of_hom_colimit D u + (0 : 𝟙_ (Ind C) ⟶ D.obj i) + (by rw [h, Limits.zero_comp]) + exact ⟨k, α, by rw [hk, Limits.zero_comp]⟩ + · rintro ⟨k, α, hk⟩ + calc u ≫ colimit.ι D i + = u ≫ D.map α ≫ colimit.ι D k := by + rw [colimit.w] + _ = (u ≫ D.map α) ≫ colimit.ι D k := + (Category.assoc _ _ _).symm + _ = 0 := by rw [hk, Limits.zero_comp] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UniversalAlgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UniversalAlgebra.lean new file mode 100644 index 0000000000..f866827430 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UniversalAlgebra.lean @@ -0,0 +1,85 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CommonAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitTransport + +/-! +# The universal algebra of Deligne 2.11 + +Choosing, for every object, an algebra over which it becomes a +mixed sum, and for every short exact sequence an algebra over +which it splits, and taking the tensor product of all of them, +gives a single nonzero algebra over which every object is a mixed +sum and every short exact sequence splits. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v + +variable {C : Type v} + +/-- **The universal algebra**: one nonzero algebra over which +every object of the family becomes a mixed sum and every chosen +morphism acquires a section. -/ +theorem exists_universal_algebra + [SmallCategory C] [MonoidalCategory C] [Abelian C] + [CategoryTheory.Linear ℂ C] [MonoidalPreadditive C] [MonoidalLinear ℂ C] + [RigidCategory C] [SymmetricCategory (Ind C)] [HasCoequalizers (Ind C)] + [∀ Z : Ind C, PreservesColimitsOfShape WalkingParallelPair (tensorLeft + Z)] [HasFiniteBiproducts (Ind C)] + (hu : HasScalarUnit C) + (L : OddLine (Ind C)) {J K : Type v} (X : J → Ind C) + (V W : K → Ind C) (g : ∀ k, V k ⟶ W k) + (hmix : ∀ j, L.LocallyMixed (X j)) + (hsplit : ∀ k, ∃ (A : Ind C) (_ : MonObj A) (_ : IsCommMonObj A), + MonObj.one (X := A) ≠ 0 ∧ + ∃ s : freeMod A (W k) ⟶ freeMod A (V k), + s ≫ freeModMap A (g k) = 𝟙 (freeMod A (W k))) : + ∃ (𝔸 : Ind C) (_ : MonObj 𝔸) (_ : IsCommMonObj 𝔸), + MonObj.one (X := 𝔸) ≠ 0 ∧ + (∀ j, ∃ p q : ℕ, + Nonempty (freeMod 𝔸 (X j) ≅ freeMod 𝔸 (L.mix p q))) ∧ + (∀ k, ∃ s : freeMod 𝔸 (W k) ⟶ freeMod 𝔸 (V k), + s ≫ freeModMap 𝔸 (g k) = 𝟙 (freeMod 𝔸 (W k))) := by + classical + choose pm qm Am Amon Acomm Ane Aiso using hmix + choose Bs Bmon Bcomm Bne Bsec using hsplit + let : ∀ i : J ⊕ K, MonObj (Sum.elim Am Bs i) := fun i => + match i with + | Sum.inl j => Amon j + | Sum.inr k => Bmon k + let : ∀ i : J ⊕ K, IsCommMonObj (Sum.elim Am Bs i) := fun i => + match i with + | Sum.inl j => Acomm j + | Sum.inr k => Bcomm k + obtain ⟨𝔸, hmon, hcomm, hne, hmap⟩ := + exists_common_algebra hu (Sum.elim Am Bs) + (fun i => match i with + | Sum.inl j => Ane j + | Sum.inr k => Bne k) + refine ⟨𝔸, hmon, hcomm, hne, ?_, ?_⟩ + · intro j + obtain ⟨φ, hφ⟩ := hmap (Sum.inl j) + have : IsMonHom (show Am j ⟶ 𝔸 from φ) := hφ + exact ⟨pm j, qm j, + ⟨freeModIsoBaseChange (Am j) 𝔸 (show Am j ⟶ 𝔸 from φ) + (Aiso j).some⟩⟩ + · intro k + obtain ⟨φ, hφ⟩ := hmap (Sum.inr k) + have : IsMonHom (show Bs k ⟶ 𝔸 from φ) := hφ + obtain ⟨s, hs⟩ := Bsec k + exact exists_section_baseChange (Bs k) 𝔸 + (show Bs k ⟶ 𝔸 from φ) (g k) s hs + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/WhiskerFaithful.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/WhiskerFaithful.lean new file mode 100644 index 0000000000..9ceab00fa8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/WhiskerFaithful.lean @@ -0,0 +1,178 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorExact +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPermCast + +/-! +# Whiskering by a nonzero object is faithful + +In a rigid symmetric abelian category with simple unit, tensoring +with a nonzero object kills no nonzero morphism. The contraction +`X ⊗ Xᘁ ⟶ 𝟙` (evaluation through the braiding) is nonzero — else +the zigzag identity kills `𝟙 X` — hence an epimorphism onto the +simple unit; whiskering preserves it, and the exchange law then +cancels it against `f ▷ (X ⊗ Xᘁ) = 0`. + +Simplicity of the unit is carried as a hypothesis and discharged +where `End 𝟙 = ℂ` is available. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits + +universe v u + +variable {A : Type u} + +/-- The evaluation of a nonzero object is nonzero: were it zero, +the zigzag identity would make `𝟙 X` zero. -/ +theorem evaluation_ne_zero [Category.{v} A] [Abelian A] [MonoidalCategory A] + [MonoidalPreadditive A] [RigidCategory A] + {X : A} (hX : ¬ IsZero X) : + (ε_ X (Xᘁ)) ≠ 0 := by + intro hz + apply hX + rw [IsZero.iff_id_eq_zero] + calc 𝟙 X + = (λ_ X).inv ≫ ((λ_ X).hom ≫ (ρ_ X).inv) ≫ (ρ_ X).hom := by + simp + _ = (λ_ X).inv ≫ (η_ X (Xᘁ) ▷ X ≫ (α_ _ _ _).hom ≫ + X ◁ ε_ X (Xᘁ)) ≫ (ρ_ X).hom := by + rw [ExactPairing.evaluation_coevaluation] + _ = 0 := by + rw [hz] + simp + +/-- **Whiskering by a nonzero object is faithful** on morphisms: in +a rigid symmetric abelian category with simple unit, `f ▷ X = 0` +forces `f = 0` when `X` is nonzero. -/ +theorem eq_zero_of_whiskerRight_eq_zero + [Category.{v} A] [Abelian A] [MonoidalCategory A] [SymmetricCategory A] + [MonoidalPreadditive A] [RigidCategory A] + (hs : Simple (𝟙_ A)) + {X : A} (hX : ¬ IsZero X) {P Q : A} {f : P ⟶ Q} + (hw : f ▷ X = 0) : f = 0 := by + have := hs + set ev' : X ⊗ (Xᘁ) ⟶ 𝟙_ A := (β_ X (Xᘁ)).hom ≫ ε_ X (Xᘁ) + with hev' + have hne : ev' ≠ 0 := by + intro hz + refine evaluation_ne_zero hX ?_ + have := congrArg (fun g => (β_ X (Xᘁ)).inv ≫ g) hz + simpa [hev'] using this + have : Epi ev' := epi_of_nonzero_to_simple hne + have : Epi (P ◁ ev') := by + have heq : (tensorLeft P).map ev' = P ◁ ev' := rfl + have : (tensorLeft P).PreservesEpimorphisms := + Functor.preservesEpimorphisms_of_adjunction + (tensorLeftAdjunction (ᘁP) P) + rw [← heq] + exact (tensorLeft P).map_epi ev' + have hmid : f ▷ (X ⊗ (Xᘁ)) = 0 := by + rw [MonoidalCategory.whiskerRight_tensor, hw] + simp + have hexch : (P ◁ ev') ≫ (f ▷ (𝟙_ A)) = 0 := by + rw [whisker_exchange, hmid, zero_comp] + have hzero : f ▷ (𝟙_ A) = 0 := by + have h0 : (P ◁ ev') ≫ (f ▷ (𝟙_ A)) = (P ◁ ev') ≫ 0 := by + rw [hexch, comp_zero] + exact (cancel_epi (P ◁ ev')).mp h0 + calc f = (ρ_ P).inv ≫ (f ▷ (𝟙_ A)) ≫ (ρ_ Q).hom := by simp + _ = 0 := by rw [hzero]; simp + +section Transport + +/-- **Nonvanishing transports up the standard embedding**: if an +element of the group algebra acts nonzero at its own size, it acts +nonzero at every larger size — the extended action is the whiskered +one, and whiskering by the nonzero `X` is faithful. -/ +private theorem whiskerPowAlg_ne_zero + [Category.{v} A] [Abelian A] [MonoidalCategory A] [SymmetricCategory A] + [MonoidalPreadditive A] [RigidCategory A] [Linear ℂ A] + [MonoidalLinear ℂ A] + (hs : Simple (𝟙_ A)) + {X : A} (hX : ¬ Limits.IsZero X) {m : ℕ} (k : ℕ) + (f : End (tensorPow A X m)) (hf : f ≠ 0) : + whiskerPowAlg X m k f ≠ 0 := by + induction k with + | zero => exact hf + | succ k ih => + intro hz + exact ih (eq_zero_of_whiskerRight_eq_zero hs hX + (show (whiskerPowAlg X m k f) ▷ X = 0 from hz)) + +theorem permAlg_symCast_ne_zero + [Category.{v} A] [Abelian A] [MonoidalCategory A] [SymmetricCategory A] + [MonoidalPreadditive A] [RigidCategory A] [Linear ℂ A] + [MonoidalLinear ℂ A] + (hs : Simple (𝟙_ A)) + {X : A} (hX : ¬ Limits.IsZero X) {m n : ℕ} (h : m ≤ n) + (x : SymGroupAlgebra m) (hx : permAlg X m x ≠ 0) : + permAlg X n (symCast h x) ≠ 0 := by + obtain ⟨k, rfl⟩ := Nat.exists_eq_add_of_le h + rw [permAlg_symCast] + exact whiskerPowAlg_ne_zero hs hX k _ hx + +end Transport + +/-- A zero factor makes the tensor zero. -/ +theorem isZero_tensor_of_isZero_left + [Category.{v} A] [Abelian A] [MonoidalCategory A] + [MonoidalPreadditive A] + {B V : A} + (hB : Limits.IsZero B) : Limits.IsZero (B ⊗ V) := by + rw [Limits.IsZero.iff_id_eq_zero] at hB ⊢ + rw [show 𝟙 (B ⊗ V) = 𝟙 B ▷ V from + (MonoidalCategory.id_whiskerRight _ _).symm, hB, + MonoidalPreadditive.zero_whiskerRight] + +/-- **Base-change faithfulness** (the kernel of Deligne 2.3): if +the tensor with a nonzero dualizable object vanishes, the other +factor vanishes — the whiskered evaluation is an epimorphism from +a zero object. -/ +theorem isZero_left_of_tensor_isZero + [Category.{v} A] [Abelian A] [MonoidalCategory A] [SymmetricCategory A] + [MonoidalPreadditive A] [RigidCategory A] + (hs : Simple (𝟙_ A)) + {B V : A} (hV : ¬ Limits.IsZero V) + (h : Limits.IsZero (B ⊗ V)) : Limits.IsZero B := by + -- The braided evaluation out of `V ⊗ Vᘁ` is epi onto the unit. + have hev : Epi ((β_ V (Vᘁ)).hom ≫ ε_ V (Vᘁ)) := by + have hne : (β_ V (Vᘁ)).hom ≫ ε_ V (Vᘁ) ≠ 0 := by + intro h0 + apply evaluation_ne_zero (A := A) hV + rw [show ε_ V (Vᘁ) = + (β_ V (Vᘁ)).inv ≫ ((β_ V (Vᘁ)).hom ≫ ε_ V (Vᘁ)) from by + rw [← Category.assoc, Iso.inv_hom_id, Category.id_comp], + h0, Limits.comp_zero] + have := hs + exact epi_of_nonzero_to_simple hne + -- Whisker it by `B`: an epi onto `B`, from a zero object. + have hepi : Epi ((B ◁ ((β_ V (Vᘁ)).hom ≫ ε_ V (Vᘁ))) ≫ + (ρ_ B).hom) := by + have : Epi (B ◁ ((β_ V (Vᘁ)).hom ≫ ε_ V (Vᘁ))) := by + have hpc : Limits.PreservesColimitsOfSize.{v, v} + (tensorLeft B) := tensorLeft_preservesColimits B + exact (tensorLeft B).map_epi _ + exact epi_comp _ _ + have hsrc : Limits.IsZero (B ⊗ (V ⊗ Vᘁ)) := by + have h1 : Limits.IsZero ((B ⊗ V) ⊗ Vᘁ) := + isZero_tensor_of_isZero_left h + exact h1.of_iso (α_ B V (Vᘁ)).symm + -- An epi from a zero object kills the target. + rw [Limits.IsZero.iff_id_eq_zero] + have hzero : (B ◁ ((β_ V (Vᘁ)).hom ≫ ε_ V (Vᘁ))) ≫ + (ρ_ B).hom = 0 := hsrc.eq_of_src _ _ + rw [← cancel_epi ((B ◁ ((β_ V (Vᘁ)).hom ≫ ε_ V (Vᘁ))) ≫ + (ρ_ B).hom), hzero, Limits.zero_comp, Limits.comp_zero] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/WordMap.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/WordMap.lean new file mode 100644 index 0000000000..43f85d9a4a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/WordMap.lean @@ -0,0 +1,936 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodPow + +/-! +# Word maps of an arbitrary pair of morphisms + +`BiprodPow` folds the letterwise biproduct inclusions of `X ⊞ Y` +into the mixed inclusions `mixedInto` and sorts them under the +symmetric-group action. Its sorting arguments never use that the +letters are biproduct inclusions — only monoidal coherence and +naturality. This file replays that machinery at two arbitrary +morphisms with a common target, `f : U ⟶ Z` and `g : V ⟶ Z`, in a +monoidal category. + +The letterwise fold of `f` and `g` over a word is the word map +`wordMap`. It is natural in the letters: composing with a +letterwise fold `wordCongrMap` of morphisms of the sources composes +the letters (`wordMap_natural`). On a sorted word the word map is +the concatenation of the pure powers of `f` and `g` +(`wordMap_standard`), and in a symmetric category every word map, +followed by the action of its sorting permutation, is that sorted +concatenation — up to the isomorphism `wordSortIso` of the source +and an arity transport at the target (`wordMap_sorted`). + +The word powers `wordPow`, the letter counts `popCount`, the sorted +words `standardWord`, their structural isomorphism +`standardMixedIso` and the sorting permutations `sortPerm` are +reused from `BiprodPow` unchanged: they depend only on the two +source objects, never on the letter maps. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +variable {A : Type u} + +/-! ## Letter maps and the word map -/ + +/-- The morphism selected by one letter: `f` on a `true` letter and +`g` on a `false` one. -/ +def letterMap [Category.{v} A] {U : A} {V : A} {Z : A} + (f : U ⟶ Z) (g : V ⟶ Z) : + (b : Bool) → ((bif b then U else V) ⟶ Z) + | true => f + | false => g + +/-- **The word map**: the fold of the letter maps of `f` and `g` +over a word, by the recursion of `wordPow`. -/ +noncomputable def wordMap + [Category.{v} A] [MonoidalCategory A] {U : A} {V : A} {Z : A} + (f : U ⟶ Z) (g : V ⟶ Z) : + (n : ℕ) → (w : Fin n → Bool) → + (wordPow U V n w ⟶ tensorPow A Z n) + | 0, _ => 𝟙 (𝟙_ A) + | n + 1, w => + wordMap f g n (w ∘ Fin.castSucc) ⊗ₘ + letterMap f g (w (Fin.last n)) + +/-! ## Naturality in the letters -/ + +/-- The source morphism selected by one letter: `α` on a `true` +letter and `β` on a `false` one. -/ +def letterCongr [Category.{v} A] {U : A} {V : A} {U' : A} {V' : A} + (α : U' ⟶ U) (β : V' ⟶ V) : + (b : Bool) → ((bif b then U' else V') ⟶ (bif b then U else V)) + | true => α + | false => β + +/-- A letter's congruence map composed with its letter map is the +letter map of the composites. -/ +theorem letterCongr_letterMap + [Category.{v} A] {U : A} {V : A} {Z : A} {U' : A} {V' : A} + (α : U' ⟶ U) (β : V' ⟶ V) + (f : U ⟶ Z) (g : V ⟶ Z) (b : Bool) : + letterCongr α β b ≫ letterMap f g b = + letterMap (α ≫ f) (β ≫ g) b := by + cases b <;> rfl + +/-- **The letterwise congruence map** between word powers on the +same word: the fold of `α` on the `true` letters and `β` on the +`false` ones, by the recursion of `wordPow`. -/ +noncomputable def wordCongrMap + [Category.{v} A] [MonoidalCategory A] {U : A} {V : A} {U' : A} {V' : A} + (α : U' ⟶ U) (β : V' ⟶ V) : + (n : ℕ) → (w : Fin n → Bool) → + (wordPow U' V' n w ⟶ wordPow U V n w) + | 0, _ => 𝟙 (𝟙_ A) + | n + 1, w => + wordCongrMap α β n (w ∘ Fin.castSucc) ⊗ₘ + letterCongr α β (w (Fin.last n)) + +/-- **Naturality of the word map in the letters**: the letterwise +congruence map composed with the word map of `f` and `g` is the +word map of the composed letters. -/ +theorem wordMap_natural + [Category.{v} A] [MonoidalCategory A] {U : A} {V : A} {Z : A} {U' : A} + {V' : A} + (α : U' ⟶ U) (β : V' ⟶ V) + (f : U ⟶ Z) (g : V ⟶ Z) : + ∀ (n : ℕ) (w : Fin n → Bool), + wordCongrMap α β n w ≫ wordMap f g n w = + wordMap (α ≫ f) (β ≫ g) n w := by + intro n + induction n with + | zero => intro w; exact Category.id_comp _ + | succ n ih => + intro w + change (wordCongrMap α β n (w ∘ Fin.castSucc) ⊗ₘ + letterCongr α β (w (Fin.last n))) ≫ + (wordMap f g n (w ∘ Fin.castSucc) ⊗ₘ + letterMap f g (w (Fin.last n))) = + wordMap (α ≫ f) (β ≫ g) n (w ∘ Fin.castSucc) ⊗ₘ + letterMap (α ≫ f) (β ≫ g) (w (Fin.last n)) + rw [MonoidalCategory.tensorHom_comp_tensorHom, + ih (w ∘ Fin.castSucc), letterCongr_letterMap] + +/-! ## Transport and splitting -/ + +/-- Transport of `wordMap` along an equality of words. -/ +theorem wordMap_congr + [Category.{v} A] [MonoidalCategory A] {U : A} {V : A} {Z : A} + (f : U ⟶ Z) (g : V ⟶ Z) {n : ℕ} + {w w' : Fin n → Bool} (h : w = w') : + wordMap f g n w = + eqToHom (congrArg (wordPow U V n) h) ≫ wordMap f g n w' := by + subst h + rw [eqToHom_refl, Category.id_comp] + +/-- Splitting `wordMap` at the last letter, with the recursion's +word and letter replaced by given values. -/ +theorem wordMap_split + [Category.{v} A] [MonoidalCategory A] {U : A} {V : A} {Z : A} + (f : U ⟶ Z) (g : V ⟶ Z) (n : ℕ) + (w : Fin (n + 1) → Bool) (w' : Fin n → Bool) (b : Bool) + (hw : w ∘ Fin.castSucc = w') (hb : w (Fin.last n) = b) + (h : wordPow U V (n + 1) w = + wordPow U V n w' ⊗ (bif b then U else V)) : + wordMap f g (n + 1) w = + eqToHom h ≫ (wordMap f g n w' ⊗ₘ letterMap f g b) := by + subst hw + subst hb + exact (Category.id_comp _).symm + +/-- The last-letter split of `wordMap` at a `false` letter, with +the selected object and morphism spelled as `V` and `g`. -/ +theorem wordMap_split_false + [Category.{v} A] [MonoidalCategory A] {U : A} {V : A} {Z : A} + (f : U ⟶ Z) (g : V ⟶ Z) (n : ℕ) + (w : Fin (n + 1) → Bool) (w' : Fin n → Bool) + (hw : w ∘ Fin.castSucc = w') (hb : w (Fin.last n) = false) + (h : wordPow U V (n + 1) w = wordPow U V n w' ⊗ V) : + wordMap f g (n + 1) w = + eqToHom h ≫ (wordMap f g n w' ⊗ₘ g) := + wordMap_split f g n w w' false hw hb h + +/-- The last-letter split of `wordMap` at a `true` letter, with +the selected object and morphism spelled as `U` and `f`. -/ +theorem wordMap_split_true + [Category.{v} A] [MonoidalCategory A] {U : A} {V : A} {Z : A} + (f : U ⟶ Z) (g : V ⟶ Z) (n : ℕ) + (w : Fin (n + 1) → Bool) (w' : Fin n → Bool) + (hw : w ∘ Fin.castSucc = w') (hb : w (Fin.last n) = true) + (h : wordPow U V (n + 1) w = wordPow U V n w' ⊗ U) : + wordMap f g (n + 1) w = + eqToHom h ≫ (wordMap f g n w' ⊗ₘ f) := + wordMap_split f g n w w' true hw hb h + +/-! ## The base-point map + +On a sorted word, `wordMap` is the concatenation of the two pure +powers. The gluing helpers are stated at general objects and +applied by `exact`, so that no tensor-power arity enters the +rewriting. +-/ + +/-- An `eqToHom` pulls out of the first factor of a tensor. Stated +at general objects. -/ +private theorem eqToHom_tensor_pull [Category.{v} A] [MonoidalCategory A] + {P P' Q R S : A} (h : P = P') + (k : P' ⟶ Q) (l : R ⟶ S) : + (eqToHom h ≫ k) ⊗ₘ l = + eqToHom (congrArg (· ⊗ R) h) ≫ (k ⊗ₘ l) := by + subst h + rw [eqToHom_refl, eqToHom_refl, Category.id_comp, Category.id_comp] + +/-- On an all-`true` word the word map is the pure power of `f`. -/ +theorem wordMap_const_true + [Category.{v} A] [MonoidalCategory A] {U : A} {V : A} {Z : A} + (f : U ⟶ Z) (g : V ⟶ Z) : + ∀ n : ℕ, + wordMap f g n (fun _ => true) = + eqToHom (wordPow_const_true U V n) ≫ tensorPowMap f n := by + intro n + induction n with + | zero => + exact (Category.id_comp _).symm + | succ n ih => + change wordMap f g n (fun _ => true) ⊗ₘ f = _ + rw [ih] + exact eqToHom_tensor_pull (wordPow_const_true U V n) _ _ + +/-- Tensoring with the unit's identity is unitor conjugation. +Stated at general objects. -/ +private theorem unit_tensor_unitor [Category.{v} A] [MonoidalCategory A] + {P Q : A} (k : P ⟶ Q) : + (k ⊗ₘ 𝟙 (𝟙_ A)) ≫ (ρ_ Q).hom = (ρ_ P).hom ≫ k := by + rw [MonoidalCategory.tensorHom_id] + exact MonoidalCategory.rightUnitor_naturality k + +/-- One stage of the concatenation glued onto an intertwining of +the previous stage. Stated at general objects. -/ +private theorem concat_step_glue [Category.{v} A] [MonoidalCategory A] + {P Q W R P' Q' S T : A} + (u : P ⊗ Q ⟶ W) (M : W ⟶ R) (v₁ : P ⟶ P') (v₂ : Q ⟶ Q') + (c : P' ⊗ Q' ⟶ R) (e : S ⟶ T) + (hih : u ≫ M = (v₁ ⊗ₘ v₂) ≫ c) : + (α_ P Q S).inv ≫ ((u ▷ S) ≫ (M ⊗ₘ e)) = + (v₁ ⊗ₘ (v₂ ⊗ₘ e)) ≫ (α_ P' Q' T).inv ≫ (c ▷ T) := by + have h1 : (u ▷ S) ≫ (M ⊗ₘ e) = (u ≫ M) ⊗ₘ e := by + rw [← MonoidalCategory.tensorHom_id u S, + MonoidalCategory.tensorHom_comp_tensorHom, Category.id_comp] + have h2 : ((v₁ ⊗ₘ v₂) ⊗ₘ e) ≫ (c ▷ T) = ((v₁ ⊗ₘ v₂) ≫ c) ⊗ₘ e := by + rw [← MonoidalCategory.tensorHom_id c T, + MonoidalCategory.tensorHom_comp_tensorHom, Category.comp_id] + have h3 : (α_ P Q S).inv ≫ ((v₁ ⊗ₘ v₂) ⊗ₘ e) = + (v₁ ⊗ₘ (v₂ ⊗ₘ e)) ≫ (α_ P' Q' T).inv := + (MonoidalCategory.associator_inv_naturality v₁ v₂ e).symm + calc (α_ P Q S).inv ≫ ((u ▷ S) ≫ (M ⊗ₘ e)) + = (α_ P Q S).inv ≫ (((v₁ ⊗ₘ v₂) ≫ c) ⊗ₘ e) := by rw [h1, hih] + _ = (α_ P Q S).inv ≫ ((v₁ ⊗ₘ v₂) ⊗ₘ e) ≫ (c ▷ T) := by rw [h2] + _ = ((v₁ ⊗ₘ (v₂ ⊗ₘ e)) ≫ (α_ P' Q' T).inv) ≫ (c ▷ T) := by + rw [← Category.assoc, h3] + _ = (v₁ ⊗ₘ (v₂ ⊗ₘ e)) ≫ (α_ P' Q' T).inv ≫ (c ▷ T) := + Category.assoc _ _ _ + +/-- A transport and its inverse cancel across a decomposition of +the middle morphism. Stated at general objects and applied by +`exact`, so the defeq-mismatched arities never enter a rewrite. -/ +private theorem cast_cancel_glue [Category.{v} A] + {M N W R : A} (h : N = W) + (h' : W = N) (a : M ⟶ N) (D : W ⟶ R) (T : N ⟶ R) + (hD : D = eqToHom h' ≫ T) : + (a ≫ eqToHom h) ≫ D = a ≫ T := by + subst h + rw [hD, show h' = rfl from rfl, eqToHom_refl, + Category.id_comp, Category.comp_id] + +/-- Transport along the `p + 0` arity cast composes away against +the pure power of the first letter. -/ +private theorem map_pow_cast + [Category.{v} A] [MonoidalCategory A] {U : A} {Z : A} + (f : U ⟶ Z) (m : ℕ) + (H : tensorPow A U m = tensorPow A U (m + 0)) : + eqToHom H ≫ tensorPowMap f (m + 0) = tensorPowMap f m := by + rw [show H = rfl from rfl, eqToHom_refl, Category.id_comp] + rfl + +/-- **The base-point map**: on a sorted word, `wordMap` is the +concatenation of the pure powers of the two letter maps. -/ +theorem wordMap_standard + [Category.{v} A] [MonoidalCategory A] {U : A} {V : A} {Z : A} + (f : U ⟶ Z) (g : V ⟶ Z) (p : ℕ) : + ∀ q : ℕ, + (standardMixedIso U V p q).inv ≫ + wordMap f g (p + q) (standardWord p q) = + (tensorPowMap f p ⊗ₘ tensorPowMap g q) ≫ + (tensorPowConcat Z p q).hom := by + intro q + induction q with + | zero => + have hkey : eqToHom (wordPow_standard_zero U V p).symm ≫ + wordMap f g (p + 0) (standardWord p 0) = + tensorPowMap f p := by + rw [wordMap_congr f g (standardWord_zero p), + wordMap_const_true f g, eqToHom_trans_assoc, + eqToHom_trans_assoc] + exact map_pow_cast f p _ + change ((ρ_ (tensorPow A U p)).hom ≫ + eqToHom (wordPow_standard_zero U V p).symm) ≫ + wordMap f g (p + 0) (standardWord p 0) = + (tensorPowMap f p ⊗ₘ 𝟙 (𝟙_ A)) ≫ + (ρ_ (tensorPow A Z p)).hom + rw [Category.assoc, hkey] + exact (unit_tensor_unitor (tensorPowMap f p)).symm + | succ q ih => + have hstep : wordPow U V (p + q + 1) (standardWord p (q + 1)) = + wordPow U V (p + q) (standardWord p q) ⊗ V := + wordPow_standard_succ U V p q + have hsplit := wordMap_split_false f g (p + q) + (standardWord p (q + 1)) (standardWord p q) + (standardWord_castSucc p q) (standardWord_last p q) hstep + refine (cast_cancel_glue hstep.symm hstep + ((α_ (tensorPow A U p) (tensorPow A V q) V).inv ≫ + ((standardMixedIso U V p q).inv ▷ V)) + (wordMap f g (p + q + 1) (standardWord p (q + 1))) + (wordMap f g (p + q) (standardWord p q) ⊗ₘ g) + hsplit).trans ?_ + erw [Category.assoc] + exact concat_step_glue (standardMixedIso U V p q).inv + (wordMap f g (p + q) (standardWord p q)) + (tensorPowMap f p) (tensorPowMap g q) + (tensorPowConcat Z p q).hom g ih + +/-! ## Sorting + +Every word map is the base-point map of its sorted form, up to the +symmetric-group action. The bubbling infrastructure — +`permMor_ofSplit`, `putBelow`, `insertTop_full` and +`putBelow_concat` — is reused from `BiprodPow`; the gluing helpers +below replicate its private steps at general letters. +-/ + +section Symmetric + +/-- A whiskered arity transport is the transport one arity up. +Stated with both transports explicit, so it applies by `exact` +wherever the endpoints agree definitionally. -/ +private theorem cast_whiskerRight_eq [Category.{v} A] [MonoidalCategory A] + (W : A) {P Q : A} (h : P = Q) + (h' : P ⊗ W = Q ⊗ W) : + eqToHom h ▷ W = eqToHom h' := by + subst h + rw [show h' = rfl from rfl, eqToHom_refl, eqToHom_refl, + MonoidalCategory.id_whiskerRight] + +/-- Splitting the first factor off a composite tensored against a +morphism. Stated at general objects. -/ +private theorem tensor_split_first [Category.{v} A] [MonoidalCategory A] + {P Q R S T : A} (a : P ⟶ Q) + (v : Q ⟶ R) (k : S ⟶ T) : + (a ≫ v) ⊗ₘ k = (a ▷ S) ≫ (v ⊗ₘ k) := by + calc (a ≫ v) ⊗ₘ k = (a ≫ v) ⊗ₘ (𝟙 S ≫ k) := by + rw [Category.id_comp] + _ = (a ⊗ₘ 𝟙 S) ≫ (v ⊗ₘ k) := + (MonoidalCategory.tensorHom_comp_tensorHom _ _ _ _).symm + _ = (a ▷ S) ≫ (v ⊗ₘ k) := by + rw [MonoidalCategory.tensorHom_id] + +/-- Splitting the last factor off a composite tensored against a +morphism. Stated at general objects. -/ +private theorem tensor_split_last [Category.{v} A] [MonoidalCategory A] + {P Q R S T : A} (v : P ⟶ Q) + (E : Q ⟶ R) (k : S ⟶ T) : + (v ≫ E) ⊗ₘ k = (v ⊗ₘ k) ≫ (E ▷ T) := by + calc (v ≫ E) ⊗ₘ k = (v ≫ E) ⊗ₘ (k ≫ 𝟙 T) := by + rw [Category.comp_id] + _ = (v ⊗ₘ k) ≫ (E ⊗ₘ 𝟙 T) := + (MonoidalCategory.tensorHom_comp_tensorHom _ _ _ _).symm + _ = (v ⊗ₘ k) ≫ (E ▷ T) := by + rw [MonoidalCategory.tensorHom_id] + +/-- A tensor absorbed into the second factor through a left +whiskering. Stated at general objects. -/ +private theorem tensor_then_whiskerLeft [Category.{v} A] [MonoidalCategory A] + {P Q S T W : A} (a : P ⟶ Q) + (h : S ⟶ T) (k : T ⟶ W) : + (a ⊗ₘ h) ≫ (Q ◁ k) = a ⊗ₘ (h ≫ k) := by + rw [← MonoidalCategory.id_tensorHom Q k, + MonoidalCategory.tensorHom_comp_tensorHom, Category.comp_id] + +/-- A left whiskering absorbed into the second factor of a tensor. +Stated at general objects. -/ +private theorem whiskerLeft_then_tensor [Category.{v} A] [MonoidalCategory A] + {P Q S T W : A} (a : P ⟶ Q) + (h : S ⟶ T) (k : T ⟶ W) : + (P ◁ h) ≫ (a ⊗ₘ k) = a ⊗ₘ (h ≫ k) := by + rw [← MonoidalCategory.id_tensorHom P h, + MonoidalCategory.tensorHom_comp_tensorHom, Category.id_comp] + +/-- `tensor_then_whiskerLeft` against a tail. -/ +private theorem tensor_then_whiskerLeft_assoc + [Category.{v} A] [MonoidalCategory A] + {P Q S T W R : A} + (a : P ⟶ Q) (h : S ⟶ T) (k : T ⟶ W) (rest : Q ⊗ W ⟶ R) : + (a ⊗ₘ h) ≫ (Q ◁ k) ≫ rest = (a ⊗ₘ (h ≫ k)) ≫ rest := by + rw [← Category.assoc, tensor_then_whiskerLeft] + +/-- `whiskerLeft_then_tensor` against a tail. -/ +private theorem whiskerLeft_then_tensor_assoc + [Category.{v} A] [MonoidalCategory A] + {P Q S T W R : A} + (a : P ⟶ Q) (h : S ⟶ T) (k : T ⟶ W) (rest : Q ⊗ W ⟶ R) : + (P ◁ h) ≫ (a ⊗ₘ k) ≫ rest = (a ⊗ₘ (h ≫ k)) ≫ rest := by + rw [← Category.assoc, whiskerLeft_then_tensor] + +/-- One whiskered concatenation stage: reassociate and take the +next stage. -/ +private theorem concat_whisker_step [Category.{v} A] [MonoidalCategory A] + (T : A) (p m : ℕ) : + ((tensorPowConcat T p m).hom ▷ T) = + (α_ (tensorPow A T p) (tensorPow A T m) T).hom ≫ + (tensorPowConcat T p (m + 1)).hom := + (Iso.hom_inv_id_assoc + (α_ (tensorPow A T p) (tensorPow A T m) T) _).symm + +/-- One whiskered concatenation stage against the insertion cycle: +reassociate, insert within the second block, and concatenate. -/ +private theorem concat_whisker_insert + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (T : A) (p m : ℕ) : + ((tensorPowConcat T p m).hom ▷ T) ≫ insertTop T (p + m) m = + (α_ (tensorPow A T p) (tensorPow A T m) T).hom ≫ + ((tensorPow A T p ◁ insertTop T m m) ≫ + (tensorPowConcat T p (m + 1)).hom) := by + have h1 := tensorPowConcat_insertTop T p m m le_rfl + calc ((tensorPowConcat T p m).hom ▷ T) ≫ insertTop T (p + m) m + = ((α_ (tensorPow A T p) (tensorPow A T m) T).hom ≫ + (tensorPowConcat T p (m + 1)).hom) ≫ + insertTop T (p + m) m := by + rw [concat_whisker_step] + exact rfl + _ = (α_ (tensorPow A T p) (tensorPow A T m) T).hom ≫ + ((tensorPowConcat T p (m + 1)).hom ≫ + insertTop T (p + m) m) := Category.assoc _ _ _ + _ = (α_ (tensorPow A T p) (tensorPow A T m) T).hom ≫ + ((tensorPow A T p ◁ insertTop T m m) ≫ + (tensorPowConcat T p (m + 1)).hom) := + congrArg + (fun t => (α_ (tensorPow A T p) (tensorPow A T m) T).hom ≫ t) + h1 + +/-- A tensor absorbed through a right whiskering. Stated at +general objects. -/ +private theorem tensor_then_whiskerRight [Category.{v} A] [MonoidalCategory A] + {P Q R S T : A} + (a : P ⟶ Q) (u : Q ⟶ R) (k : S ⟶ T) : + (a ⊗ₘ k) ≫ (u ▷ T) = (a ≫ u) ⊗ₘ k := by + rw [← MonoidalCategory.tensorHom_id u T, + MonoidalCategory.tensorHom_comp_tensorHom, Category.comp_id] + +/-- Reassociating a parenthesised three-chain against a tail. -/ +private theorem assoc₃ [Category.{v} A] + {P Q R S T : A} (a : P ⟶ Q) (b : Q ⟶ R) + (c : R ⟶ S) (d : S ⟶ T) : + (a ≫ b ≫ c) ≫ d = a ≫ b ≫ c ≫ d := by + simp only [Category.assoc] + +/-- The false-branch gluing at general objects: tensoring a +four-chain with a letter splits it around the reassociation. -/ +private theorem sorted_false_glue [Category.{v} A] [MonoidalCategory A] + {W P Q P' Q' N N' S T : A} + (a : W ⟶ P ⊗ Q) (v₁ : P ⟶ P') (v₂ : Q ⟶ Q') + (c : P' ⊗ Q' ⟶ N) (E : N ⟶ N') (k : S ⟶ T) : + (a ≫ (v₁ ⊗ₘ v₂) ≫ c ≫ E) ⊗ₘ k = + (a ▷ S) ≫ (α_ P Q S).hom ≫ (v₁ ⊗ₘ (v₂ ⊗ₘ k)) ≫ + (α_ P' Q' T).inv ≫ (c ▷ T) ≫ (E ▷ T) := by + rw [tensor_split_first, tensor_split_last, + MonoidalCategory.comp_whiskerRight, + MonoidalCategory.associator_conjugation] + simp only [Category.assoc] + +/-- Arity transport commutes with the insertion cycle. -/ +private theorem insertTop_cast + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (T : A) (a b k : ℕ) (hab : a = b) + (H : tensorPow A T a = tensorPow A T b) : + (eqToHom H ▷ T) ≫ insertTop T b k = + insertTop T a k ≫ (eqToHom H ▷ T) := by + subst hab + erw [show H = rfl from rfl, eqToHom_refl, + MonoidalCategory.id_whiskerRight, Category.id_comp] + exact (Category.comp_id _).symm + +/-- An arity transport composed with a whiskered one is the joint +transport. -/ +private theorem cast_then_cast_whisker [Category.{v} A] [MonoidalCategory A] + (T : A) {a b n : ℕ} + (hab : a = b + 1) (hbn : b = n) + (H₁ : tensorPow A T a = tensorPow A T (b + 1)) + (H₂ : tensorPow A T b = tensorPow A T n) + (H₃ : tensorPow A T a = tensorPow A T (n + 1)) : + eqToHom H₁ ≫ (eqToHom H₂ ▷ T) = eqToHom H₃ := by + subst hbn + subst hab + erw [show H₁ = rfl from rfl, show H₂ = rfl from rfl, + show H₃ = rfl from rfl, eqToHom_refl, eqToHom_refl, + MonoidalCategory.id_whiskerRight, Category.id_comp] + rfl + +/-- **Sorting one appended `true` letter**: the base-point map with +one more `f` in the last slot, bubbled down past the whole `g` +block, is the base-point map of the grown `f` block — up to +braiding the appended factor past the `V` power on the mixed side +and the arity transport `(p + 1) + m = p + (m + 1)` at the +target. -/ +private theorem letter_insert_true + [Category.{v} A] [MonoidalCategory A] {U : A} {V : A} {Z : A} + [SymmetricCategory A] + (f : U ⟶ Z) (g : V ⟶ Z) + (p m : ℕ) : + (((tensorPowMap f p ⊗ₘ tensorPowMap g m) ≫ + (tensorPowConcat Z p m).hom) ⊗ₘ f) ≫ + insertTop Z (p + m) m = + (α_ (tensorPow A U p) (tensorPow A V m) U).hom ≫ + (tensorPow A U p ◁ (β_ (tensorPow A V m) U).hom) ≫ + (α_ (tensorPow A U p) U (tensorPow A V m)).inv ≫ + (tensorPowMap f (p + 1) ⊗ₘ tensorPowMap g m) ≫ + (tensorPowConcat Z (p + 1) m).hom ≫ + eqToHom (congrArg (tensorPow A Z) + (Nat.succ_add_eq_add_succ p m)) := by + rw [tensor_split_last] + repeat' erw [Category.assoc] + rw [concat_whisker_insert, insertTop_full, + MonoidalCategory.associator_naturality_assoc, + tensor_then_whiskerLeft_assoc, + BraidedCategory.braiding_naturality_assoc, + ← whiskerLeft_then_tensor_assoc, ← tensor_then_whiskerLeft_assoc, + putBelow_concat, MonoidalCategory.associator_inv_naturality_assoc] + exact rfl + +/-- Regrouping a flat seven-chain into the packaged form. Stated +at general objects. -/ +private theorem false_final_shape [Category.{v} A] + {W₀ W₁ P R₁ R₂ R₃ R₄ R₅ : A} + (a : W₀ ⟶ W₁) (b : W₁ ⟶ P) (c : P ⟶ R₁) (t : R₁ ⟶ R₂) + (ai : R₂ ⟶ R₃) (cw : R₃ ⟶ R₄) (e : R₄ ⟶ R₅) : + a ≫ b ≫ c ≫ t ≫ ai ≫ cw ≫ e = + (a ≫ b ≫ c) ≫ t ≫ (ai ≫ cw) ≫ e := by + simp only [Category.assoc] + +/-- **The sorting square grows by a `false` letter**: the appended +`V` slot joins the top of the `g` block and nothing is bubbled. -/ +private theorem sorted_step_false + [Category.{v} A] [MonoidalCategory A] {U : A} {V : A} {Z : A} + [SymmetricCategory A] + (f : U ⟶ Z) (g : V ⟶ Z) {n : ℕ} + (w : Fin (n + 1) → Bool) (p m : ℕ) + (hpm : p + m = n) (hq1 : p + (m + 1) = n + 1) + (e' : wordPow U V n (w ∘ Fin.castSucc) ≅ + tensorPow A U p ⊗ tensorPow A V m) + (hobj : wordPow U V (n + 1) w = + wordPow U V n (w ∘ Fin.castSucc) ⊗ V) + (hb : w (Fin.last n) = false) + (hperm : permMor Z (n + 1) (sortPerm w) = + permMor Z n (sortPerm (w ∘ Fin.castSucc)) ▷ Z) + (hsq' : wordMap f g n (w ∘ Fin.castSucc) ≫ + permMor Z n (sortPerm (w ∘ Fin.castSucc)) = + e'.hom ≫ + (tensorPowMap f p ⊗ₘ tensorPowMap g m) ≫ + (tensorPowConcat Z p m).hom ≫ + eqToHom (congrArg (tensorPow A Z) hpm)) : + wordMap f g (n + 1) w ≫ permMor Z (n + 1) (sortPerm w) = + (eqToIso hobj ≪≫ whiskerRightIso e' V ≪≫ + α_ (tensorPow A U p) (tensorPow A V m) V).hom ≫ + (tensorPowMap f p ⊗ₘ tensorPowMap g (m + 1)) ≫ + (tensorPowConcat Z p (m + 1)).hom ≫ + eqToHom (congrArg (tensorPow A Z) hq1) := by + have hsplit := wordMap_split_false f g n w (w ∘ Fin.castSucc) + rfl hb hobj + have hcast := cast_whiskerRight_eq Z + (congrArg (tensorPow A Z) hpm) + (congrArg (tensorPow A Z) hq1) + have h1 : wordMap f g (n + 1) w ≫ + permMor Z (n + 1) (sortPerm w) + = (eqToHom hobj ≫ + (wordMap f g n (w ∘ Fin.castSucc) ⊗ₘ g)) ≫ + (permMor Z n (sortPerm (w ∘ Fin.castSucc)) ▷ Z) := by + rw [hsplit, hperm] + exact rfl + have h2 : (eqToHom hobj ≫ + (wordMap f g n (w ∘ Fin.castSucc) ⊗ₘ g)) ≫ + (permMor Z n (sortPerm (w ∘ Fin.castSucc)) ▷ Z) + = eqToHom hobj ≫ + ((wordMap f g n (w ∘ Fin.castSucc) ⊗ₘ g) ≫ + (permMor Z n (sortPerm (w ∘ Fin.castSucc)) ▷ Z)) := + Category.assoc _ _ _ + have h3 : eqToHom hobj ≫ + ((wordMap f g n (w ∘ Fin.castSucc) ⊗ₘ g) ≫ + (permMor Z n (sortPerm (w ∘ Fin.castSucc)) ▷ Z)) + = eqToHom hobj ≫ + ((wordMap f g n (w ∘ Fin.castSucc) ≫ + permMor Z n (sortPerm (w ∘ Fin.castSucc))) ⊗ₘ g) := + congrArg (fun t => eqToHom hobj ≫ t) + (tensor_then_whiskerRight _ _ _) + have h4 : eqToHom hobj ≫ + ((wordMap f g n (w ∘ Fin.castSucc) ≫ + permMor Z n (sortPerm (w ∘ Fin.castSucc))) ⊗ₘ g) + = eqToHom hobj ≫ + ((e'.hom ≫ + (tensorPowMap f p ⊗ₘ tensorPowMap g m) ≫ + (tensorPowConcat Z p m).hom ≫ + eqToHom (congrArg (tensorPow A Z) hpm)) ⊗ₘ g) := by + rw [hsq'] + have h5 : eqToHom hobj ≫ + ((e'.hom ≫ + (tensorPowMap f p ⊗ₘ tensorPowMap g m) ≫ + (tensorPowConcat Z p m).hom ≫ + eqToHom (congrArg (tensorPow A Z) hpm)) ⊗ₘ g) + = eqToHom hobj ≫ + ((e'.hom ▷ V) ≫ + (α_ (tensorPow A U p) (tensorPow A V m) V).hom ≫ + (tensorPowMap f p ⊗ₘ (tensorPowMap g m ⊗ₘ g)) ≫ + (α_ (tensorPow A Z p) (tensorPow A Z m) Z).inv ≫ + ((tensorPowConcat Z p m).hom ▷ Z) ≫ + (eqToHom (congrArg (tensorPow A Z) hpm) ▷ Z)) := + congrArg (fun t => eqToHom hobj ≫ t) + (sorted_false_glue e'.hom _ _ _ _ _) + have h6 : eqToHom hobj ≫ + ((e'.hom ▷ V) ≫ + (α_ (tensorPow A U p) (tensorPow A V m) V).hom ≫ + (tensorPowMap f p ⊗ₘ (tensorPowMap g m ⊗ₘ g)) ≫ + (α_ (tensorPow A Z p) (tensorPow A Z m) Z).inv ≫ + ((tensorPowConcat Z p m).hom ▷ Z) ≫ + (eqToHom (congrArg (tensorPow A Z) hpm) ▷ Z)) + = eqToHom hobj ≫ + ((e'.hom ▷ V) ≫ + (α_ (tensorPow A U p) (tensorPow A V m) V).hom ≫ + (tensorPowMap f p ⊗ₘ (tensorPowMap g m ⊗ₘ g)) ≫ + (α_ (tensorPow A Z p) (tensorPow A Z m) Z).inv ≫ + ((tensorPowConcat Z p m).hom ▷ Z) ≫ + eqToHom (congrArg (tensorPow A Z) hq1)) := by + rw [hcast] + exact rfl + have h7 : eqToHom hobj ≫ + ((e'.hom ▷ V) ≫ + (α_ (tensorPow A U p) (tensorPow A V m) V).hom ≫ + (tensorPowMap f p ⊗ₘ (tensorPowMap g m ⊗ₘ g)) ≫ + (α_ (tensorPow A Z p) (tensorPow A Z m) Z).inv ≫ + ((tensorPowConcat Z p m).hom ▷ Z) ≫ + eqToHom (congrArg (tensorPow A Z) hq1)) + = (eqToIso hobj ≪≫ whiskerRightIso e' V ≪≫ + α_ (tensorPow A U p) (tensorPow A V m) V).hom ≫ + (tensorPowMap f p ⊗ₘ tensorPowMap g (m + 1)) ≫ + (tensorPowConcat Z p (m + 1)).hom ≫ + eqToHom (congrArg (tensorPow A Z) hq1) := + false_final_shape _ _ _ _ _ _ _ + exact h1.trans (h2.trans (h3.trans (h4.trans (h5.trans + (h6.trans h7))))) + +/-- Regrouping the true-branch chain into the packaged form. +Stated at general objects. -/ +private theorem true_final_shape [Category.{v} A] + {W₀ W₁ P R₀ R₁ R₂ R₃ R₄ R₅ R₆ : A} + (a : W₀ ⟶ W₁) (b : W₁ ⟶ P) (c : P ⟶ R₀) (d : R₀ ⟶ R₁) + (e : R₁ ⟶ R₂) (t : R₂ ⟶ R₃) (cw : R₃ ⟶ R₄) (e₁ : R₄ ⟶ R₅) + (e₂ : R₅ ⟶ R₆) : + a ≫ ((b ≫ (c ≫ d ≫ e ≫ t ≫ cw ≫ e₁)) ≫ e₂) = + (a ≫ b ≫ c ≫ d ≫ e) ≫ t ≫ cw ≫ e₁ ≫ e₂ := by + simp only [Category.assoc] + +/-- **The sorting square grows by a `true` letter**: the appended +`U` slot is bubbled down past the whole `g` block onto the top of +the `f` block. -/ +private theorem sorted_step_true + [Category.{v} A] [MonoidalCategory A] {U : A} {V : A} {Z : A} + [SymmetricCategory A] + (f : U ⟶ Z) (g : V ⟶ Z) {n : ℕ} + (w : Fin (n + 1) → Bool) (p m : ℕ) + (hpm : p + m = n) (hm : n - p = m) + (hq1 : p + 1 + m = n + 1) + (e' : wordPow U V n (w ∘ Fin.castSucc) ≅ + tensorPow A U p ⊗ tensorPow A V m) + (hobj : wordPow U V (n + 1) w = + wordPow U V n (w ∘ Fin.castSucc) ⊗ U) + (hb : w (Fin.last n) = true) + (hperm : permMor Z (n + 1) (sortPerm w) = + (permMor Z n (sortPerm (w ∘ Fin.castSucc)) ▷ Z) ≫ + insertTop Z n (n - p)) + (hsq' : wordMap f g n (w ∘ Fin.castSucc) ≫ + permMor Z n (sortPerm (w ∘ Fin.castSucc)) = + e'.hom ≫ + (tensorPowMap f p ⊗ₘ tensorPowMap g m) ≫ + (tensorPowConcat Z p m).hom ≫ + eqToHom (congrArg (tensorPow A Z) hpm)) : + wordMap f g (n + 1) w ≫ permMor Z (n + 1) (sortPerm w) = + (eqToIso hobj ≪≫ whiskerRightIso e' U ≪≫ + α_ (tensorPow A U p) (tensorPow A V m) U ≪≫ + whiskerLeftIso (tensorPow A U p) + (β_ (tensorPow A V m) U) ≪≫ + (α_ (tensorPow A U p) U (tensorPow A V m)).symm).hom ≫ + (tensorPowMap f (p + 1) ⊗ₘ tensorPowMap g m) ≫ + (tensorPowConcat Z (p + 1) m).hom ≫ + eqToHom (congrArg (tensorPow A Z) hq1) := by + have hsplit := wordMap_split_true f g n w (w ∘ Fin.castSucc) + rfl hb hobj + have hmerge := cast_then_cast_whisker Z + (a := p + 1 + m) (b := p + m) (n := n) + (by omega) hpm + (congrArg (tensorPow A Z) (Nat.succ_add_eq_add_succ p m)) + (congrArg (tensorPow A Z) hpm) + (congrArg (tensorPow A Z) hq1) + have h1 : wordMap f g (n + 1) w ≫ + permMor Z (n + 1) (sortPerm w) + = (eqToHom hobj ≫ + (wordMap f g n (w ∘ Fin.castSucc) ⊗ₘ f)) ≫ + ((permMor Z n (sortPerm (w ∘ Fin.castSucc)) ▷ Z) ≫ + insertTop Z n (n - p)) := by + rw [hsplit, hperm] + exact rfl + refine (h1.trans ?_) + refine (Category.assoc _ _ _).trans ?_ + refine (congrArg (fun t => eqToHom hobj ≫ t) + (Category.assoc _ _ _).symm).trans ?_ + refine (congrArg + (fun t => eqToHom hobj ≫ + (t ≫ insertTop Z n (n - p))) + (tensor_then_whiskerRight _ _ _)).trans ?_ + refine (?_ : + eqToHom hobj ≫ + (((wordMap f g n (w ∘ Fin.castSucc) ≫ + permMor Z n (sortPerm (w ∘ Fin.castSucc))) ⊗ₘ f) ≫ + insertTop Z n (n - p)) = _) + rw [hsq'] + refine (congrArg + (fun v => eqToHom hobj ≫ + ((v ⊗ₘ f) ≫ insertTop Z n (n - p))) + (assoc₃ e'.hom _ _ _).symm).trans ?_ + refine (congrArg + (fun t => eqToHom hobj ≫ + (t ≫ insertTop Z n (n - p))) + (tensor_split_last _ _ _)).trans ?_ + refine (congrArg (fun t => eqToHom hobj ≫ t) + (Category.assoc _ _ _)).trans ?_ + refine (congrArg + (fun t => eqToHom hobj ≫ + (((e'.hom ≫ + (tensorPowMap f p ⊗ₘ tensorPowMap g m) ≫ + (tensorPowConcat Z p m).hom) ⊗ₘ f) ≫ t)) + (insertTop_cast Z (p + m) n (n - p) hpm + (congrArg (tensorPow A Z) hpm))).trans ?_ + refine (congrArg + (fun k => eqToHom hobj ≫ + (((e'.hom ≫ + (tensorPowMap f p ⊗ₘ tensorPowMap g m) ≫ + (tensorPowConcat Z p m).hom) ⊗ₘ f) ≫ + (insertTop Z (p + m) k ≫ + (eqToHom (congrArg (tensorPow A Z) hpm) ▷ Z)))) + hm).trans ?_ + refine (congrArg (fun t => eqToHom hobj ≫ t) + (Category.assoc _ _ _).symm).trans ?_ + refine (congrArg + (fun t => eqToHom hobj ≫ + ((t ≫ insertTop Z (p + m) m) ≫ + (eqToHom (congrArg (tensorPow A Z) hpm) ▷ Z))) + (tensor_split_first e'.hom _ _)).trans ?_ + refine (congrArg + (fun t => eqToHom hobj ≫ + (t ≫ (eqToHom (congrArg (tensorPow A Z) hpm) ▷ Z))) + (Category.assoc _ _ _)).trans ?_ + refine (congrArg + (fun t => eqToHom hobj ≫ + (((e'.hom ▷ U) ≫ t) ≫ + (eqToHom (congrArg (tensorPow A Z) hpm) ▷ Z))) + (letter_insert_true f g p m)).trans ?_ + refine (true_final_shape (eqToHom hobj) (e'.hom ▷ U) + (α_ (tensorPow A U p) (tensorPow A V m) U).hom + (tensorPow A U p ◁ (β_ (tensorPow A V m) U).hom) + (α_ (tensorPow A U p) U (tensorPow A V m)).inv + (tensorPowMap f (p + 1) ⊗ₘ tensorPowMap g m) + (tensorPowConcat Z (p + 1) m).hom + (eqToHom (congrArg (tensorPow A Z) + (Nat.succ_add_eq_add_succ p m))) + (eqToHom (congrArg (tensorPow A Z) hpm) ▷ Z)).trans ?_ + exact congrArg + (fun s => (eqToHom hobj ≫ (e'.hom ▷ U) ≫ + (α_ (tensorPow A U p) (tensorPow A V m) U).hom ≫ + (tensorPow A U p ◁ (β_ (tensorPow A V m) U).hom) ≫ + (α_ (tensorPow A U p) U (tensorPow A V m)).inv) ≫ + (tensorPowMap f (p + 1) ⊗ₘ tensorPowMap g m) ≫ + (tensorPowConcat Z (p + 1) m).hom ≫ s) + hmerge + +/-- Append a definitionally trivial transport to a three-step +factorisation. -/ +private theorem comp_cast_end₃ [Category.{v} A] + {P Q R S : A} {k : P ⟶ S} + {g₁ : P ⟶ Q} {g₂ : Q ⟶ R} {g₃ : R ⟶ S} (H : S = S) + (hkg : k = g₁ ≫ g₂ ≫ g₃) : + k = g₁ ≫ g₂ ≫ g₃ ≫ eqToHom H := by + rw [show H = rfl from rfl, eqToHom_refl, Category.comp_id, hkg] + +/-- Renaming the block sizes of a sorting square: the data and the +square transport along equalities of the two sizes. -/ +private theorem sorted_pack + [Category.{v} A] [MonoidalCategory A] {U : A} {V : A} {Z : A} + (f : U ⟶ Z) (g : V ⟶ Z) {n : ℕ} + {W : A} (mi : W ⟶ tensorPow A Z n) (p q pc qc : ℕ) + (hp : p = pc) (hq : q = qc) (hpq : p + q = n) + (hpcqc : pc + qc = n) + (e : W ≅ tensorPow A U p ⊗ tensorPow A V q) + (hsq : mi = e.hom ≫ + (tensorPowMap f p ⊗ₘ tensorPowMap g q) ≫ + (tensorPowConcat Z p q).hom ≫ + eqToHom (congrArg (tensorPow A Z) hpq)) : + ∃ e' : W ≅ tensorPow A U pc ⊗ tensorPow A V qc, + mi = e'.hom ≫ + (tensorPowMap f pc ⊗ₘ tensorPowMap g qc) ≫ + (tensorPowConcat Z pc qc).hom ≫ + eqToHom (congrArg (tensorPow A Z) hpcqc) := by + subst hp + subst hq + exact ⟨e, hsq⟩ + +/-- **The sorting lemma**: every word map is a permuted base-point +map. For each word `w` there is an isomorphism of the word power +with `U ^ ⊗ popCount w ⊗ V ^ ⊗ (n − popCount w)` under which +`wordMap f g`, followed by the action of `sortPerm w`, is the +concatenation of the pure powers of `f` and `g`, transported along +`popCount w + (n − popCount w) = n` at the target. -/ +theorem wordMap_sorted_exists + [Category.{v} A] [MonoidalCategory A] {U : A} {V : A} {Z : A} + [SymmetricCategory A] + (f : U ⟶ Z) (g : V ⟶ Z) : + ∀ (n : ℕ) (w : Fin n → Bool), + ∃ e : wordPow U V n w ≅ + tensorPow A U (popCount w) ⊗ + tensorPow A V (n - popCount w), + wordMap f g n w ≫ permMor Z n (sortPerm w) = + e.hom ≫ + (tensorPowMap f (popCount w) ⊗ₘ + tensorPowMap g (n - popCount w)) ≫ + (tensorPowConcat Z (popCount w) (n - popCount w)).hom ≫ + eqToHom (congrArg (tensorPow A Z) + (Nat.add_sub_cancel' (popCount_le w))) := by + intro n + induction n with + | zero => + intro w + refine sorted_pack f g + (wordMap f g 0 w ≫ permMor Z 0 (sortPerm w)) + 0 0 (popCount w) (0 - popCount w) (popCount_nil w).symm + (by rw [popCount_nil]) rfl + (Nat.add_sub_cancel' (popCount_le w)) + (ρ_ (𝟙_ A)).symm ?_ + have hz : (𝟙 (𝟙_ A) ≫ 𝟙 (𝟙_ A) : 𝟙_ A ⟶ 𝟙_ A) = + (ρ_ (𝟙_ A)).inv ≫ (𝟙 (𝟙_ A) ⊗ₘ 𝟙 (𝟙_ A)) ≫ + (ρ_ (𝟙_ A)).hom := by + rw [MonoidalCategory.id_tensorHom_id, Category.id_comp, + Category.id_comp, Iso.inv_hom_id] + refine comp_cast_end₃ _ ?_ + exact hz + | succ n ih => + intro w + obtain ⟨e', hsq'⟩ := ih (w ∘ Fin.castSucc) + have hple := popCount_le (w ∘ Fin.castSucc) + cases hb : w (Fin.last n) with + | false => + have hpw : popCount w = popCount (w ∘ Fin.castSucc) := by + rw [popCount_succ, hb] + rfl + have hobj : wordPow U V (n + 1) w = + wordPow U V n (w ∘ Fin.castSucc) ⊗ V := by + rw [wordPow_succ, hb] + rfl + have hperm : permMor Z (n + 1) (sortPerm w) = + permMor Z n (sortPerm (w ∘ Fin.castSucc)) ▷ Z := by + rw [sortPerm_succ, hb, Bool.cond_false, permMor_ofSplit, + show ((Fin.last n : Fin (n + 1)) : ℕ) = n from rfl, + Nat.sub_self, insertTop_zero] + exact Category.comp_id _ + have hq1 : popCount (w ∘ Fin.castSucc) + + (n - popCount (w ∘ Fin.castSucc) + 1) = n + 1 := by + omega + refine sorted_pack f g + (wordMap f g (n + 1) w ≫ + permMor Z (n + 1) (sortPerm w)) + (popCount (w ∘ Fin.castSucc)) + (n - popCount (w ∘ Fin.castSucc) + 1) + (popCount w) (n + 1 - popCount w) hpw.symm (by omega) hq1 + (Nat.add_sub_cancel' (popCount_le w)) _ + (sorted_step_false f g w (popCount (w ∘ Fin.castSucc)) + (n - popCount (w ∘ Fin.castSucc)) + (Nat.add_sub_cancel' hple) hq1 e' hobj hb hperm hsq') + | true => + have hpw : popCount w = popCount (w ∘ Fin.castSucc) + 1 := by + rw [popCount_succ, hb] + rfl + have hobj : wordPow U V (n + 1) w = + wordPow U V n (w ∘ Fin.castSucc) ⊗ U := by + rw [wordPow_succ, hb] + rfl + have hperm : permMor Z (n + 1) (sortPerm w) = + (permMor Z n (sortPerm (w ∘ Fin.castSucc)) ▷ Z) ≫ + insertTop Z n + (n - popCount (w ∘ Fin.castSucc)) := by + rw [sortPerm_succ, hb, Bool.cond_true, permMor_ofSplit] + have hq1 : popCount (w ∘ Fin.castSucc) + 1 + + (n - popCount (w ∘ Fin.castSucc)) = n + 1 := by + omega + refine sorted_pack f g + (wordMap f g (n + 1) w ≫ + permMor Z (n + 1) (sortPerm w)) + (popCount (w ∘ Fin.castSucc) + 1) + (n - popCount (w ∘ Fin.castSucc)) + (popCount w) (n + 1 - popCount w) hpw.symm (by omega) hq1 + (Nat.add_sub_cancel' (popCount_le w)) _ + (sorted_step_true f g w (popCount (w ∘ Fin.castSucc)) + (n - popCount (w ∘ Fin.castSucc)) + (Nat.add_sub_cancel' hple) rfl hq1 e' hobj hb hperm hsq') + +/-- **The sorting isomorphism**, chosen once and for all from the +sorting lemma: `wordPow U V n w` against the sorted concatenation +of pure powers. -/ +noncomputable def wordSortIso + [Category.{v} A] [MonoidalCategory A] {U : A} {V : A} {Z : A} + [SymmetricCategory A] + (f : U ⟶ Z) (g : V ⟶ Z) (n : ℕ) + (w : Fin n → Bool) : + wordPow U V n w ≅ + tensorPow A U (popCount w) ⊗ tensorPow A V (n - popCount w) := + (wordMap_sorted_exists f g n w).choose + +/-- **The sorting square**, for the chosen isomorphism +`wordSortIso`: the word map of `f` and `g`, followed by the action +of the sorting permutation, is the concatenation of the pure powers +of `f` and `g`, up to `wordSortIso` at the source and the arity +transport at the target. -/ +theorem wordMap_sorted + [Category.{v} A] [MonoidalCategory A] {U : A} {V : A} {Z : A} + [SymmetricCategory A] + (f : U ⟶ Z) (g : V ⟶ Z) (n : ℕ) + (w : Fin n → Bool) : + wordMap f g n w ≫ permMor Z n (sortPerm w) = + (wordSortIso f g n w).hom ≫ + (tensorPowMap f (popCount w) ⊗ₘ + tensorPowMap g (n - popCount w)) ≫ + (tensorPowConcat Z (popCount w) (n - popCount w)).hom ≫ + eqToHom (congrArg (tensorPow A Z) + (Nat.add_sub_cancel' (popCount_le w))) := + (wordMap_sorted_exists f g n w).choose_spec + +end Symmetric + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZagAction.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZagAction.lean new file mode 100644 index 0000000000..7c74003e3b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZagAction.lean @@ -0,0 +1,122 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BraidCoherence +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorDatum + +/-! +# Paired left actions and the joint action + +The zag companion of the paired right action relation: acting on +both carriers on the left and projecting is multiplying the +scalars and acting on the projected pair. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- Pure braid coherence for the zag prefix: reassociating and +braiding the block `P ⊗ Q` past `P'`, then swapping `P'` back past +`P`, agrees with interchanging via `tensorμ` and reassociating. +The block braiding decomposes into the elementary crossings +`β_ Q P'` and `β_ P P'`; the latter cancels against the final +`β_ P' P` by the symmetry axiom, leaving exactly the single +crossing carried by `tensorμ`. -/ +@[reassoc] +theorem zag_prefix_coherence + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + (P Q P' R : D) : + (α_ (P ⊗ Q) P' R).inv ≫ + ((β_ (P ⊗ Q) P').hom ▷ R) ≫ + ((α_ P' P Q).inv ▷ R) ≫ + (((β_ P' P).hom ▷ Q) ▷ R) = + tensorμ P Q P' R ≫ (α_ (P ⊗ P') Q R).inv := by + calc + (α_ (P ⊗ Q) P' R).inv ≫ + ((β_ (P ⊗ Q) P').hom ▷ R) ≫ + ((α_ P' P Q).inv ▷ R) ≫ + (((β_ P' P).hom ▷ Q) ▷ R) + = 𝟙 _ ⊗≫ ((P ◁ (β_ Q P').hom) ▷ R) ⊗≫ + ((((β_ P P').hom ≫ (β_ P' P).hom) ▷ Q) ▷ R) ⊗≫ + 𝟙 _ := by + rw [BraidedCategory.braiding_tensor_left_hom P Q P'] + monoidal + _ = 𝟙 _ ⊗≫ ((P ◁ (β_ Q P').hom) ▷ R) ⊗≫ 𝟙 _ := by + rw [SymmetricCategory.symmetry P P'] + monoidal + _ = tensorμ P Q P' R ≫ (α_ (P ⊗ P') Q R).inv := by + dsimp only [tensorμ] + monoidal + +/-- **Paired left actions descend to the joint action**: acting on +both carriers on the left and projecting is multiplying the +scalars and acting on the projected pair — the zag companion of +the paired right action relation of the relative tensor. -/ +theorem tensorHom_actLeft_π + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] + (N₁ N₂ : Mod D A) : + (actLeft A N₁.X ⊗ₘ actLeft A N₂.X) ≫ modTensorπ A N₁ N₂ = + tensorμ A N₁.X A N₂.X ≫ + (μ[A] ▷ (N₁.X ⊗ N₂.X)) ≫ + (A ◁ modTensorπ A N₁ N₂) ≫ + modTensorAct A N₁ N₂ := by + have hR : (A ◁ modTensorπ A N₁ N₂) ≫ modTensorAct A N₁ N₂ = + ((α_ A N₁.X N₂.X).inv ≫ actLeft A N₁.X ▷ N₂.X) ≫ + modTensorπ A N₁ N₂ := + whiskerLeft_modTensorπ_act A N₁ N₂ + have hcond : (actRight A N₁.X ▷ N₂.X) ≫ modTensorπ A N₁ N₂ = + (α_ N₁.X A N₂.X).hom ≫ + (N₁.X ◁ actLeft A N₂.X) ≫ modTensorπ A N₁ N₂ := by + have h := modTensor_condition A N₁ N₂ + rw [modTensorLegM, modTensorLegN] at h + simpa using h + have hcond' : (N₁.X ◁ actLeft A N₂.X) ≫ modTensorπ A N₁ N₂ = + (α_ N₁.X A N₂.X).inv ≫ + (actRight A N₁.X ▷ N₂.X) ≫ modTensorπ A N₁ N₂ := by + rw [hcond, Iso.inv_hom_id_assoc] + have hAA : actLeft A N₁.X ▷ A ≫ actRight A N₁.X = + (β_ (A ⊗ N₁.X) A).hom ≫ (α_ A A N₁.X).inv ≫ + ((β_ A A).hom ▷ N₁.X) ≫ μ[A] ▷ N₁.X ≫ + actLeft A N₁.X := by + conv_rhs => rw [← comp_whiskerRight_assoc, + IsCommMonObj.mul_comm A] + rw [(show actRight A N₁.X = + (β_ N₁.X A).hom ≫ actLeft A N₁.X from rfl), + ← Category.assoc, + BraidedCategory.braiding_naturality_left, + Category.assoc, actLeft_actLeft] + have h3 : ((actLeft A N₁.X ▷ A ≫ actRight A N₁.X) ▷ N₂.X) ≫ + modTensorπ A N₁ N₂ = + ((β_ (A ⊗ N₁.X) A).hom ▷ N₂.X) ≫ + ((α_ A A N₁.X).inv ▷ N₂.X) ≫ + (((β_ A A).hom ▷ N₁.X) ▷ N₂.X) ≫ + ((μ[A] ▷ N₁.X) ▷ N₂.X) ≫ + (actLeft A N₁.X ▷ N₂.X) ≫ modTensorπ A N₁ N₂ := by + rw [hAA] + simp only [comp_whiskerRight, Category.assoc] + conv_lhs => rw [MonoidalCategory.tensorHom_def, + Category.assoc, hcond', + associator_inv_naturality_left_assoc, + ← comp_whiskerRight_assoc, h3] + conv_rhs => rw [hR] + simp only [Category.assoc] + conv_rhs => rw [associator_inv_naturality_left_assoc] + rw [zag_prefix_coherence_assoc A N₁.X A N₂.X] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagCarrier.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagCarrier.lean new file mode 100644 index 0000000000..d814019e7f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagCarrier.lean @@ -0,0 +1,925 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma + +/-! +# Carrier-level zigzag identities + +The zigzag laws of a Mod-internal duality datum are stated at the +multi-tensor level, where the wide-coequalizer presentation keeps +them associativity-free. Their consumers work on the carriers +`M.X` and `M'.X`, through the binary relative tensor alone: insert +the copairing beside the carrier, contract the crossing pair +through the descended pairing, and let the resulting scalar act on +the inserted half. This file identifies both triangle composites +with their carrier forms, unconditionally, and derives the +carrier-level triangle identities from the multi-level laws and +conversely. + +* `zigContract`, `zagContract`: the carrier contractions, morphisms + out of `modTensor A M M' ⊗ M.X` and `M'.X ⊗ modTensor A M M'` + descended along the whiskered module-tensor coequalizers, with + defining equations isolating `modTensorπ A M' M ≫ p`. +* `zigComposite_eq_carrier`, `zagComposite_eq_carrier`: the + multi-level triangle composites are the singleton conjugates of + the carrier words. No zigzag hypothesis enters. +* `zigzag_carrier_zig`, `zigzag_carrier_zag`: the carrier triangle + identities of a zigzag datum, with quantified variants for any + solution of the contraction's defining equation. +* `modZigzagDatum_of_carrier`: the converse packaging, producing + the multi-level laws from the carrier-level identities. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- Conjugation by an isomorphism preserves and reflects the +identity. -/ +theorem iso_conj_id_iff [Category.{v} D] + {X Y : D} (i : X ≅ Y) {g : Y ⟶ Y} : + i.hom ≫ g ≫ i.inv = 𝟙 X ↔ g = 𝟙 Y := by + constructor + · intro h + have h2 := congrArg (fun t => i.inv ≫ t ≫ i.hom) h + simpa using h2 + · intro h + rw [h, Category.id_comp, Iso.hom_inv_id] + +/-! ## The singleton comparison as a conjugation -/ + +section Single + +/-- The singleton projection against the comparison iso: the right +unitor of the carrier. -/ +@[reassoc] +theorem modMultiπ_single + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] + (X : Mod D A) : + modMultiπ A [X] ≫ (modMultiSingle A X).hom = (ρ_ X.X).hom := by + change (modMultiTriv A (modSlots_singleton A X)).inv ≫ + (modMultiTriv A (modSlots_singleton A X)).hom ≫ + (ρ_ X.X).hom = (ρ_ X.X).hom + erw [Iso.inv_hom_id_assoc] + +/-- Recognise a singleton conjugate: a multi-level morphism whose +projection matches a carrier morphism through the unitor is the +conjugate of that morphism. -/ +theorem eq_single_conj [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] + {X Y : Mod D A} + {f : modMulti A [X] ⟶ modMulti A [Y]} {g : X.X ⟶ Y.X} + (h : modMultiπ A [X] ≫ f ≫ (modMultiSingle A Y).hom = + (ρ_ X.X).hom ≫ g) : + f = (modMultiSingle A X).hom ≫ g ≫ + (modMultiSingle A Y).inv := by + apply modMulti_hom_ext + have h' : (modMultiπ A [X] ≫ f ≫ (modMultiSingle A Y).hom) ≫ + (modMultiSingle A Y).inv = + ((ρ_ X.X).hom ≫ g) ≫ (modMultiSingle A Y).inv := + congrArg (fun t => t ≫ (modMultiSingle A Y).inv) h + have hL : (modMultiπ A [X] ≫ f ≫ (modMultiSingle A Y).hom) ≫ + (modMultiSingle A Y).inv = modMultiπ A [X] ≫ f := by + simp only [Category.assoc, Iso.hom_inv_id, Category.comp_id] + have hR : ((ρ_ X.X).hom ≫ g) ≫ (modMultiSingle A Y).inv = + (ρ_ X.X).hom ≫ g ≫ (modMultiSingle A Y).inv := + Category.assoc _ _ _ + exact ((hL.symm.trans h').trans hR).trans + (modMultiπ_single_assoc A X + (g ≫ (modMultiSingle A Y).inv)).symm + +end Single + +/-! ## The zig triangle on the carrier -/ + +section ZigCarrier + +/-- The trailing contraction fold against the singleton +comparison: pair the trailing window, act on the head from the +right. -/ +theorem contract3Fold_single + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) : + contract3Fold A p M ≫ (modMultiSingle A M).hom = + (M.X ◁ ((M'.X ◁ (ρ_ M.X).hom) ≫ + modTensorπ A M' M ≫ p)) ≫ actRight A M.X := by + have hfold : contract3Fold A p M = + (M.X ◁ ((M'.X ◁ (ρ_ M.X).hom) ≫ + modTensorπ A M' M ≫ p)) ≫ + actRight A M.X ≫ (modMultiSingle A M).inv := rfl + have hcancel : ((M.X ◁ ((M'.X ◁ (ρ_ M.X).hom) ≫ + modTensorπ A M' M ≫ p)) ≫ + actRight A M.X ≫ (modMultiSingle A M).inv) ≫ + (modMultiSingle A M).hom = + (M.X ◁ ((M'.X ◁ (ρ_ M.X).hom) ≫ + modTensorπ A M' M ≫ p)) ≫ actRight A M.X := by + simp only [Category.assoc, Iso.inv_hom_id, Category.comp_id] + exact (congrArg (fun t => t ≫ (modMultiSingle A M).hom) + hfold).trans hcancel + +/-- A trailing window against the resolved contraction: stripping +the unit seed of the fold, the window meets the carrier +contraction word. -/ +theorem window_contract3Fold_carrier + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (w : (M.X ⊗ A) ⊗ M'.X ⟶ M.X ⊗ M'.X) : + ((((M.X ⊗ A) ⊗ M'.X) ◁ (ρ_ M.X).inv) ≫ + ((w ▷ modList A [M]) ≫ + (α_ M.X M'.X (modList A [M])).hom)) ≫ + contract3Fold A p M ≫ (modMultiSingle A M).hom = + (w ▷ M.X) ≫ (α_ M.X M'.X M.X).hom ≫ + (M.X ◁ (modTensorπ A M' M ≫ p)) ≫ actRight A M.X := by + have h1 := congrArg + (fun t => ((((M.X ⊗ A) ⊗ M'.X) ◁ (ρ_ M.X).inv) ≫ + ((w ▷ modList A [M]) ≫ + (α_ M.X M'.X (modList A [M])).hom)) ≫ t) + (contract3Fold_single A p) + have h2 : ((((M.X ⊗ A) ⊗ M'.X) ◁ (ρ_ M.X).inv) ≫ + ((w ▷ (M.X ⊗ 𝟙_ D)) ≫ + (α_ M.X M'.X (M.X ⊗ 𝟙_ D)).hom)) ≫ + ((M.X ◁ ((M'.X ◁ (ρ_ M.X).hom) ≫ + modTensorπ A M' M ≫ p)) ≫ actRight A M.X) = + (w ▷ M.X) ≫ (α_ M.X M'.X M.X).hom ≫ + (M.X ◁ (modTensorπ A M' M ≫ p)) ≫ actRight A M.X := by + have hx : ((((M.X ⊗ A) ⊗ M'.X)) ◁ (ρ_ M.X).inv) ≫ + (w ▷ (M.X ⊗ 𝟙_ D)) = + (w ▷ M.X) ≫ ((M.X ⊗ M'.X) ◁ (ρ_ M.X).inv) := + whisker_exchange w (ρ_ M.X).inv + have hcoh : ((M.X ⊗ M'.X) ◁ (ρ_ M.X).inv) ≫ + (α_ M.X M'.X (M.X ⊗ 𝟙_ D)).hom ≫ + (M.X ◁ (M'.X ◁ (ρ_ M.X).hom)) = + (α_ M.X M'.X M.X).hom := by + monoidal + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [reassoc_of% hx, reassoc_of% hcoh] + exact h1.trans h2 + +/-- The descent condition of the trailing carrier contraction: the +two legs of the crossing pair agree, through the boundary +condition of the fold-level contraction. -/ +theorem zigContract_cond + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) : + (modTensorLegM A M M' ▷ M.X) ≫ (α_ M.X M'.X M.X).hom ≫ + (M.X ◁ (modTensorπ A M' M ≫ p)) ≫ actRight A M.X = + (modTensorLegN A M M' ▷ M.X) ≫ (α_ M.X M'.X M.X).hom ≫ + (M.X ◁ (modTensorπ A M' M ≫ p)) ≫ actRight A M.X := by + have hcond' : ((modTensorLegM A M M' ▷ modList A [M]) ≫ + (α_ M.X M'.X (modList A [M])).hom) ≫ + contract3Fold A p M = + ((modTensorLegN A M M' ▷ modList A [M]) ≫ + (α_ M.X M'.X (modList A [M])).hom) ≫ + contract3Fold A p M := + contract3Fold_boundary_cond A p hp M + have hmid := congrArg + (fun t => ((((M.X ⊗ A) ⊗ M'.X)) ◁ (ρ_ M.X).inv) ≫ + t ≫ (modMultiSingle A M).hom) hcond' + have aM : ((((M.X ⊗ A) ⊗ M'.X) ◁ (ρ_ M.X).inv) ≫ + ((modTensorLegM A M M' ▷ modList A [M]) ≫ + (α_ M.X M'.X (modList A [M])).hom)) ≫ + contract3Fold A p M ≫ (modMultiSingle A M).hom = + ((((M.X ⊗ A) ⊗ M'.X)) ◁ (ρ_ M.X).inv) ≫ + (((modTensorLegM A M M' ▷ modList A [M]) ≫ + (α_ M.X M'.X (modList A [M])).hom) ≫ + contract3Fold A p M) ≫ (modMultiSingle A M).hom := by + repeat' erw [Category.assoc] + have aN : ((((M.X ⊗ A) ⊗ M'.X) ◁ (ρ_ M.X).inv) ≫ + ((modTensorLegN A M M' ▷ modList A [M]) ≫ + (α_ M.X M'.X (modList A [M])).hom)) ≫ + contract3Fold A p M ≫ (modMultiSingle A M).hom = + ((((M.X ⊗ A) ⊗ M'.X)) ◁ (ρ_ M.X).inv) ≫ + (((modTensorLegN A M M' ▷ modList A [M]) ≫ + (α_ M.X M'.X (modList A [M])).hom) ≫ + contract3Fold A p M) ≫ (modMultiSingle A M).hom := by + repeat' erw [Category.assoc] + exact (window_contract3Fold_carrier A p + (modTensorLegM A M M')).symm.trans + ((aM.trans (hmid.trans aN.symm)).trans + (window_contract3Fold_carrier A p (modTensorLegN A M M'))) + +/-- **The carrier contraction of the zig triangle**: on +`modTensor A M M' ⊗ M.X`, the inserted `M'`-half pairs against +the trailing carrier through the descended pairing and the +resulting scalar acts on the inserted `M`-half from the right. +Descended along the right-whiskered module-tensor coequalizer. -/ +noncomputable def zigContract + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) : + modTensor A M M' ⊗ M.X ⟶ M.X := + modTensorWhiskerRDesc A M M' M.X + ((α_ M.X M'.X M.X).hom ≫ + (M.X ◁ (modTensorπ A M' M ≫ p)) ≫ actRight A M.X) + (zigContract_cond A p hp) + +/-- Defining equation of the zig carrier contraction: the pairing +occurrence is isolated as `modTensorπ A M' M ≫ p`. -/ +@[reassoc (attr := simp)] +theorem whiskerRight_modTensorπ_zigContract + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) : + (modTensorπ A M M' ▷ M.X) ≫ zigContract A p hp = + (α_ M.X M'.X M.X).hom ≫ + (M.X ◁ (modTensorπ A M' M ≫ p)) ≫ actRight A M.X := + whiskerRight_modTensorπ_whiskerRDesc A M M' M.X _ _ + +/-- The zig carrier contraction is the unique solution of its +defining equation. -/ +theorem zigContract_unique + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) + {e : modTensor A M M' ⊗ M.X ⟶ M.X} + (he : (modTensorπ A M M' ▷ M.X) ≫ e = + (α_ M.X M'.X M.X).hom ≫ + (M.X ◁ (modTensorπ A M' M ≫ p)) ≫ actRight A M.X) : + e = zigContract A p hp := + modTensor_whiskerR_hom_ext A M M' M.X + (he.trans + (whiskerRight_modTensorπ_zigContract A p hp).symm) + +/-- The inserted pair against the concatenation and trailing +contraction: the multi-level word collapses to the carrier +contraction. -/ +theorem pairInv_concat_contract3_single + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) : + (modMultiPairInv A M M' ▷ modList A [M]) ≫ + modMultiConcatFst A [M, M'] [M] ≫ + modMultiContract3 A p hp M ≫ (modMultiSingle A M).hom = + (modTensor A M M' ◁ (ρ_ M.X).hom) ≫ zigContract A p hp := by + apply modTensor_whiskerR_hom_ext A M M' (modList A [M]) + have s1 : (modTensorπ A M M' ▷ modList A [M]) ≫ + (modMultiPairInv A M M' ▷ modList A [M]) = + (pairResolveInv A M M' ▷ modList A [M]) ≫ + (modMultiπ A [M, M'] ▷ modList A [M]) := by + rw [← MonoidalCategory.comp_whiskerRight, + modTensorπ_pairInv, MonoidalCategory.comp_whiskerRight] + have s2 : (modMultiπ A [M, M'] ▷ modList A [M]) ≫ + modMultiConcatFst A [M, M'] [M] = + (modListConcat A [M, M'] [M]).hom ≫ + modMultiπ A ([M, M'] ++ [M]) := + whiskerRight_modMultiπ_concatFst A [M, M'] [M] + have s3 : modMultiπ A ([M, M'] ++ [M]) ≫ + modMultiContract3 A p hp M = contract3Fold A p M := + modMultiπ_contract3 A p hp M + rw [reassoc_of% s1, reassoc_of% s2, reassoc_of% s3] + have hL2 := congrArg + (fun t => (pairResolveInv A M M' ▷ modList A [M]) ≫ + (modListConcat A [M, M'] [M]).hom ≫ t) + (contract3Fold_single A p) + have hnat : ((M.X ◁ (ρ_ M'.X).inv) ▷ (M.X ⊗ 𝟙_ D)) ≫ + ((α_ M.X (M'.X ⊗ 𝟙_ D) (M.X ⊗ 𝟙_ D)).hom ≫ + (M.X ◁ ((α_ M'.X (𝟙_ D) (M.X ⊗ 𝟙_ D)).hom ≫ + (M'.X ◁ (λ_ (M.X ⊗ 𝟙_ D)).hom)))) ≫ + ((M.X ◁ ((M'.X ◁ (ρ_ M.X).hom) ≫ + modTensorπ A M' M ≫ p)) ≫ actRight A M.X) = + ((M.X ⊗ M'.X) ◁ (ρ_ M.X).hom) ≫ (α_ M.X M'.X M.X).hom ≫ + (M.X ◁ (modTensorπ A M' M ≫ p)) ≫ actRight A M.X := by + have hcoh : ((M.X ◁ (ρ_ M'.X).inv) ▷ (M.X ⊗ 𝟙_ D)) ≫ + (α_ M.X (M'.X ⊗ 𝟙_ D) (M.X ⊗ 𝟙_ D)).hom ≫ + (M.X ◁ (α_ M'.X (𝟙_ D) (M.X ⊗ 𝟙_ D)).hom) ≫ + (M.X ◁ (M'.X ◁ (λ_ (M.X ⊗ 𝟙_ D)).hom)) ≫ + (M.X ◁ (M'.X ◁ (ρ_ M.X).hom)) = + ((M.X ⊗ M'.X) ◁ (ρ_ M.X).hom) ≫ + (α_ M.X M'.X M.X).hom := by + monoidal + simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + rw [reassoc_of% hcoh] + have hR : (modTensorπ A M M' ▷ (M.X ⊗ 𝟙_ D)) ≫ + (modTensor A M M' ◁ (ρ_ M.X).hom) ≫ zigContract A p hp = + ((M.X ⊗ M'.X) ◁ (ρ_ M.X).hom) ≫ (α_ M.X M'.X M.X).hom ≫ + (M.X ◁ (modTensorπ A M' M ≫ p)) ≫ actRight A M.X := by + have hx : (modTensorπ A M M' ▷ (M.X ⊗ 𝟙_ D)) ≫ + (modTensor A M M' ◁ (ρ_ M.X).hom) = + ((M.X ⊗ M'.X) ◁ (ρ_ M.X).hom) ≫ + (modTensorπ A M M' ▷ M.X) := + (whisker_exchange (modTensorπ A M M') (ρ_ M.X).hom).symm + rw [reassoc_of% hx, whiskerRight_modTensorπ_zigContract] + exact (hL2.trans hnat).trans hR.symm + +/-- The image of a copairing splits into the copairing and the +pair comparison. -/ +theorem copairImage_eq [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] {M : Mod D A} {M' : Mod D A} + (c : A ⟶ modTensor A M M') : + copairImage A c = (η[A] ≫ c) ≫ modMultiPairInv A M M' := by + simp only [copairImage] + rw [← Category.assoc] + rfl + +/-- **The zig composite in carrier form**: conjugated by the +singleton comparison, the multi-level zig composite is the +carrier insertion of the copairing followed by the carrier +contraction. No zigzag law enters. -/ +theorem zigComposite_eq_carrier + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (c : A ⟶ modTensor A M M') + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) : + zigComposite A c p hp = + (modMultiSingle A M).hom ≫ + ((λ_ M.X).inv ≫ ((η[A] ≫ c) ▷ M.X) ≫ + zigContract A p hp) ≫ + (modMultiSingle A M).inv := by + apply eq_single_conj + have s1 : modMultiπ A [M] ≫ (λ_ (modMulti A [M])).inv = + (λ_ (modList A [M])).inv ≫ (𝟙_ D ◁ modMultiπ A [M]) := + leftUnitor_inv_naturality _ + have s2 : (𝟙_ D ◁ modMultiπ A [M]) ≫ + (copairImage A c ▷ modMulti A [M]) = + (copairImage A c ▷ modList A [M]) ≫ + (modMulti A [M, M'] ◁ modMultiπ A [M]) := + whisker_exchange _ _ + have hbig : modMultiπ A [M] ≫ zigComposite A c p hp ≫ + (modMultiSingle A M).hom = + (λ_ (modList A [M])).inv ≫ + ((η[A] ≫ c) ▷ modList A [M]) ≫ + ((modMultiPairInv A M M' ▷ modList A [M]) ≫ + modMultiConcatFst A [M, M'] [M] ≫ + modMultiContract3 A p hp M ≫ + (modMultiSingle A M).hom) := by + simp only [zigComposite, Category.assoc] + rw [reassoc_of% s1, reassoc_of% s2, + whiskerLeft_modMultiπ_concat_assoc, copairImage_eq, + MonoidalCategory.comp_whiskerRight] + repeat' erw [Category.assoc] + have hcore := pairInv_concat_contract3_single A p hp + have hfin : (λ_ (M.X ⊗ 𝟙_ D)).inv ≫ + ((η[A] ≫ c) ▷ (M.X ⊗ 𝟙_ D)) ≫ + ((modTensor A M M' ◁ (ρ_ M.X).hom) ≫ + zigContract A p hp) = + (ρ_ M.X).hom ≫ (λ_ M.X).inv ≫ ((η[A] ≫ c) ▷ M.X) ≫ + zigContract A p hp := by + have s5 : ((η[A] ≫ c) ▷ (M.X ⊗ 𝟙_ D)) ≫ + (modTensor A M M' ◁ (ρ_ M.X).hom) = + (𝟙_ D ◁ (ρ_ M.X).hom) ≫ ((η[A] ≫ c) ▷ M.X) := + (whisker_exchange _ _).symm + have s6 : (λ_ (M.X ⊗ 𝟙_ D)).inv ≫ + (𝟙_ D ◁ (ρ_ M.X).hom) = + (ρ_ M.X).hom ≫ (λ_ M.X).inv := by + monoidal + rw [reassoc_of% s5, reassoc_of% s6] + exact hbig.trans + ((congrArg (fun t => (λ_ (modList A [M])).inv ≫ + ((η[A] ≫ c) ▷ modList A [M]) ≫ t) hcore).trans hfin) + +/-- The carrier zig identity from the multi-level zig law. -/ +theorem zig_carrier_of_multi + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (c : A ⟶ modTensor A M M') + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) + (h : zigComposite A c p hp = 𝟙 (modMulti A [M])) : + (λ_ M.X).inv ≫ ((η[A] ≫ c) ▷ M.X) ≫ zigContract A p hp = + 𝟙 M.X := + (iso_conj_id_iff (modMultiSingle A M)).mp + ((zigComposite_eq_carrier A c p hp).symm.trans h) + +/-- The multi-level zig law from the carrier zig identity. -/ +theorem multi_of_zig_carrier + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (c : A ⟶ modTensor A M M') + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) + (h : (λ_ M.X).inv ≫ ((η[A] ≫ c) ▷ M.X) ≫ + zigContract A p hp = 𝟙 M.X) : + zigComposite A c p hp = 𝟙 (modMulti A [M]) := by + rw [zigComposite_eq_carrier A c p hp, h, Category.id_comp, + Iso.hom_inv_id] + +end ZigCarrier + +/-! ## The zag triangle on the carrier -/ + +section ZagCarrier + +/-- The leading contraction fold against the singleton +comparison: pair the leading window, act on the remainder from +the left. -/ +theorem contract3LFold_single + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) : + contract3LFold A p M' ≫ (modMultiSingle A M').hom = + (α_ M'.X M.X (M'.X ⊗ 𝟙_ D)).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ (M'.X ⊗ 𝟙_ D)) ≫ + (A ◁ (ρ_ M'.X).hom) ≫ actLeft A M'.X := by + have hfold : contract3LFold A p M' = + (α_ M'.X M.X (M'.X ⊗ 𝟙_ D)).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ (M'.X ⊗ 𝟙_ D)) ≫ + ((α_ A M'.X (𝟙_ D)).inv ≫ + (actLeft A M'.X ▷ (𝟙_ D))) ≫ + modMultiπ A [M'] := rfl + have hstep : ((α_ M'.X M.X (M'.X ⊗ 𝟙_ D)).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ (M'.X ⊗ 𝟙_ D)) ≫ + ((α_ A M'.X (𝟙_ D)).inv ≫ + (actLeft A M'.X ▷ (𝟙_ D))) ≫ + modMultiπ A [M']) ≫ (modMultiSingle A M').hom = + (α_ M'.X M.X (M'.X ⊗ 𝟙_ D)).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ (M'.X ⊗ 𝟙_ D)) ≫ + ((α_ A M'.X (𝟙_ D)).inv ≫ + (actLeft A M'.X ▷ (𝟙_ D))) ≫ + (modMultiπ A [M'] ≫ (modMultiSingle A M').hom) := by + repeat' erw [Category.assoc] + have hmid := congrArg + (fun t => (α_ M'.X M.X (M'.X ⊗ 𝟙_ D)).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ (M'.X ⊗ 𝟙_ D)) ≫ + ((α_ A M'.X (𝟙_ D)).inv ≫ + (actLeft A M'.X ▷ (𝟙_ D))) ≫ t) + (modMultiπ_single A M') + have htail : (α_ M'.X M.X (M'.X ⊗ 𝟙_ D)).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ (M'.X ⊗ 𝟙_ D)) ≫ + ((α_ A M'.X (𝟙_ D)).inv ≫ + (actLeft A M'.X ▷ (𝟙_ D))) ≫ (ρ_ M'.X).hom = + (α_ M'.X M.X (M'.X ⊗ 𝟙_ D)).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ (M'.X ⊗ 𝟙_ D)) ≫ + (A ◁ (ρ_ M'.X).hom) ≫ actLeft A M'.X := by + have hcoh : (α_ A M'.X (𝟙_ D)).inv ≫ + (ρ_ (A ⊗ M'.X)).hom = A ◁ (ρ_ M'.X).hom := by + monoidal + have h1 : ((α_ A M'.X (𝟙_ D)).inv ≫ + (actLeft A M'.X ▷ (𝟙_ D))) ≫ (ρ_ M'.X).hom = + (A ◁ (ρ_ M'.X).hom) ≫ actLeft A M'.X := by + rw [Category.assoc, rightUnitor_naturality, + reassoc_of% hcoh] + rw [h1] + exact ((congrArg (fun t => t ≫ (modMultiSingle A M').hom) + hfold).trans hstep).trans (hmid.trans htail) + +/-- A leading window against the resolved contraction: stripping +the unit seed of the fold, the window meets the carrier +contraction word. -/ +theorem window_contract3LFold_carrier + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] (A : D) + [MonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (w : (M.X ⊗ A) ⊗ M'.X ⟶ M.X ⊗ M'.X) : + (M'.X ◁ ((ρ_ ((M.X ⊗ A) ⊗ M'.X)).inv ≫ + ((w ▷ modList A []) ≫ + (α_ M.X M'.X (modList A [])).hom))) ≫ + contract3LFold A p M' ≫ (modMultiSingle A M').hom = + (M'.X ◁ w) ≫ (α_ M'.X M.X M'.X).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ M'.X) ≫ actLeft A M'.X := by + have h1 := congrArg + (fun t => (M'.X ◁ ((ρ_ ((M.X ⊗ A) ⊗ M'.X)).inv ≫ + ((w ▷ modList A []) ≫ + (α_ M.X M'.X (modList A [])).hom))) ≫ t) + (contract3LFold_single A p) + have h2 : (M'.X ◁ ((ρ_ ((M.X ⊗ A) ⊗ M'.X)).inv ≫ + ((w ▷ (𝟙_ D)) ≫ (α_ M.X M'.X (𝟙_ D)).hom))) ≫ + ((α_ M'.X M.X (M'.X ⊗ 𝟙_ D)).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ (M'.X ⊗ 𝟙_ D)) ≫ + (A ◁ (ρ_ M'.X).hom) ≫ actLeft A M'.X) = + (M'.X ◁ w) ≫ (α_ M'.X M.X M'.X).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ M'.X) ≫ actLeft A M'.X := by + have hw : (ρ_ ((M.X ⊗ A) ⊗ M'.X)).inv ≫ + ((w ▷ (𝟙_ D)) ≫ (α_ M.X M'.X (𝟙_ D)).hom) = + w ≫ (ρ_ (M.X ⊗ M'.X)).inv ≫ + (α_ M.X M'.X (𝟙_ D)).hom := by + have hnatw : (ρ_ ((M.X ⊗ A) ⊗ M'.X)).inv ≫ + (w ▷ (𝟙_ D)) = w ≫ (ρ_ (M.X ⊗ M'.X)).inv := + (rightUnitor_inv_naturality w).symm + rw [← Category.assoc, hnatw, Category.assoc] + have hx : ((modTensorπ A M' M ≫ p) ▷ (M'.X ⊗ 𝟙_ D)) ≫ + (A ◁ (ρ_ M'.X).hom) = + ((M'.X ⊗ M.X) ◁ (ρ_ M'.X).hom) ≫ + ((modTensorπ A M' M ≫ p) ▷ M'.X) := + (whisker_exchange (modTensorπ A M' M ≫ p) + (ρ_ M'.X).hom).symm + have hcoh : (M'.X ◁ (ρ_ (M.X ⊗ M'.X)).inv) ≫ + (M'.X ◁ (α_ M.X M'.X (𝟙_ D)).hom) ≫ + (α_ M'.X M.X (M'.X ⊗ 𝟙_ D)).inv ≫ + ((M'.X ⊗ M.X) ◁ (ρ_ M'.X).hom) = + (α_ M'.X M.X M'.X).inv := by + monoidal + rw [hw] + simp only [MonoidalCategory.whiskerLeft_comp, + Category.assoc] + rw [reassoc_of% hx, reassoc_of% hcoh] + exact h1.trans h2 + +/-- The descent condition of the leading carrier contraction: the +two legs of the crossing pair agree, through the boundary +condition of the fold-level contraction. -/ +theorem zagContract_cond + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) : + (M'.X ◁ modTensorLegM A M M') ≫ (α_ M'.X M.X M'.X).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ M'.X) ≫ actLeft A M'.X = + (M'.X ◁ modTensorLegN A M M') ≫ (α_ M'.X M.X M'.X).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ M'.X) ≫ actLeft A M'.X := by + have hcond' : (M'.X ◁ ((modTensorLegM A M M' ▷ + modList A []) ≫ + (α_ M.X M'.X (modList A [])).hom)) ≫ + contract3LFold A p M' = + (M'.X ◁ ((modTensorLegN A M M' ▷ modList A []) ≫ + (α_ M.X M'.X (modList A [])).hom)) ≫ + contract3LFold A p M' := + contract3LFold_boundary_cond A p hp M' + have hmid := congrArg + (fun t => (M'.X ◁ (ρ_ ((M.X ⊗ A) ⊗ M'.X)).inv) ≫ + t ≫ (modMultiSingle A M').hom) hcond' + have aM : (M'.X ◁ ((ρ_ ((M.X ⊗ A) ⊗ M'.X)).inv ≫ + ((modTensorLegM A M M' ▷ modList A []) ≫ + (α_ M.X M'.X (modList A [])).hom))) ≫ + contract3LFold A p M' ≫ (modMultiSingle A M').hom = + (M'.X ◁ (ρ_ ((M.X ⊗ A) ⊗ M'.X)).inv) ≫ + ((M'.X ◁ ((modTensorLegM A M M' ▷ modList A []) ≫ + (α_ M.X M'.X (modList A [])).hom)) ≫ + contract3LFold A p M') ≫ + (modMultiSingle A M').hom := by + rw [MonoidalCategory.whiskerLeft_comp] + repeat' erw [Category.assoc] + have aN : (M'.X ◁ ((ρ_ ((M.X ⊗ A) ⊗ M'.X)).inv ≫ + ((modTensorLegN A M M' ▷ modList A []) ≫ + (α_ M.X M'.X (modList A [])).hom))) ≫ + contract3LFold A p M' ≫ (modMultiSingle A M').hom = + (M'.X ◁ (ρ_ ((M.X ⊗ A) ⊗ M'.X)).inv) ≫ + ((M'.X ◁ ((modTensorLegN A M M' ▷ modList A []) ≫ + (α_ M.X M'.X (modList A [])).hom)) ≫ + contract3LFold A p M') ≫ + (modMultiSingle A M').hom := by + rw [MonoidalCategory.whiskerLeft_comp] + repeat' erw [Category.assoc] + exact (window_contract3LFold_carrier A p + (modTensorLegM A M M')).symm.trans + ((aM.trans (hmid.trans aN.symm)).trans + (window_contract3LFold_carrier A p + (modTensorLegN A M M'))) + +/-- **The carrier contraction of the zag triangle**: on +`M'.X ⊗ modTensor A M M'`, the leading carrier pairs against the +inserted `M`-half through the descended pairing and the resulting +scalar acts on the inserted `M'`-half from the left. Descended +along the left-whiskered module-tensor coequalizer. -/ +noncomputable def zagContract + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) : + M'.X ⊗ modTensor A M M' ⟶ M'.X := + modTensorWhiskerDesc A M M' M'.X + ((α_ M'.X M.X M'.X).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ M'.X) ≫ actLeft A M'.X) + (zagContract_cond A p hp) + +/-- Defining equation of the zag carrier contraction: the pairing +occurrence is isolated as `modTensorπ A M' M ≫ p`. -/ +@[reassoc (attr := simp)] +theorem whiskerLeft_modTensorπ_zagContract + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) : + (M'.X ◁ modTensorπ A M M') ≫ zagContract A p hp = + (α_ M'.X M.X M'.X).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ M'.X) ≫ actLeft A M'.X := + whiskerLeft_modTensorπ_whiskerDesc A M M' M'.X _ _ + +/-- The zag carrier contraction is the unique solution of its +defining equation. -/ +theorem zagContract_unique + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) + {e : M'.X ⊗ modTensor A M M' ⟶ M'.X} + (he : (M'.X ◁ modTensorπ A M M') ≫ e = + (α_ M'.X M.X M'.X).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ M'.X) ≫ actLeft A M'.X) : + e = zagContract A p hp := + modTensor_whisker_hom_ext A M M' M'.X + (he.trans + (whiskerLeft_modTensorπ_zagContract A p hp).symm) + +/-- The inserted pair against the concatenation and leading +contraction: the multi-level word collapses to the carrier +contraction. -/ +theorem pairInv_concat_contract3L_single + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) : + (modList A [M'] ◁ modMultiPairInv A M M') ≫ + (modMultiπ A [M'] ▷ modMulti A [M, M']) ≫ + modMultiConcat A [M'] [M, M'] ≫ + modMultiContract3L A p hp M' ≫ + (modMultiSingle A M').hom = + ((ρ_ M'.X).hom ▷ modTensor A M M') ≫ + zagContract A p hp := by + apply modTensor_whisker_hom_ext A M M' (modList A [M']) + have s1 : (modList A [M'] ◁ modTensorπ A M M') ≫ + (modList A [M'] ◁ modMultiPairInv A M M') = + (modList A [M'] ◁ pairResolveInv A M M') ≫ + (modList A [M'] ◁ modMultiπ A [M, M']) := by + rw [← MonoidalCategory.whiskerLeft_comp, + modTensorπ_pairInv, MonoidalCategory.whiskerLeft_comp] + have s2 : (modList A [M'] ◁ modMultiπ A [M, M']) ≫ + (modMultiπ A [M'] ▷ modMulti A [M, M']) = + (modMultiπ A [M'] ▷ modList A [M, M']) ≫ + (modMulti A [M'] ◁ modMultiπ A [M, M']) := + whisker_exchange _ _ + have s4 : (modMultiπ A [M'] ▷ modList A [M, M']) ≫ + modMultiConcatFst A [M'] [M, M'] = + (modListConcat A [M'] [M, M']).hom ≫ + modMultiπ A ([M'] ++ [M, M']) := + whiskerRight_modMultiπ_concatFst A [M'] [M, M'] + have s5 : modMultiπ A ([M'] ++ [M, M']) ≫ + modMultiContract3L A p hp M' = contract3LFold A p M' := + modMultiπ_contract3L A p hp M' + rw [reassoc_of% s1, reassoc_of% s2, + whiskerLeft_modMultiπ_concat_assoc, reassoc_of% s4, + reassoc_of% s5] + have hL2 := congrArg + (fun t => (modList A [M'] ◁ pairResolveInv A M M') ≫ + (modListConcat A [M'] [M, M']).hom ≫ t) + (contract3LFold_single A p) + have hnat : ((M'.X ⊗ 𝟙_ D) ◁ (M.X ◁ (ρ_ M'.X).inv)) ≫ + ((α_ M'.X (𝟙_ D) (M.X ⊗ (M'.X ⊗ 𝟙_ D))).hom ≫ + (M'.X ◁ (λ_ (M.X ⊗ (M'.X ⊗ 𝟙_ D))).hom)) ≫ + ((α_ M'.X M.X (M'.X ⊗ 𝟙_ D)).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ (M'.X ⊗ 𝟙_ D)) ≫ + (A ◁ (ρ_ M'.X).hom) ≫ actLeft A M'.X) = + ((ρ_ M'.X).hom ▷ (M.X ⊗ M'.X)) ≫ + (α_ M'.X M.X M'.X).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ M'.X) ≫ actLeft A M'.X := by + have hx : ((modTensorπ A M' M ≫ p) ▷ (M'.X ⊗ 𝟙_ D)) ≫ + (A ◁ (ρ_ M'.X).hom) = + ((M'.X ⊗ M.X) ◁ (ρ_ M'.X).hom) ≫ + ((modTensorπ A M' M ≫ p) ▷ M'.X) := + (whisker_exchange (modTensorπ A M' M ≫ p) + (ρ_ M'.X).hom).symm + have hcoh : ((M'.X ⊗ 𝟙_ D) ◁ (M.X ◁ (ρ_ M'.X).inv)) ≫ + (α_ M'.X (𝟙_ D) (M.X ⊗ (M'.X ⊗ 𝟙_ D))).hom ≫ + (M'.X ◁ (λ_ (M.X ⊗ (M'.X ⊗ 𝟙_ D))).hom) ≫ + (α_ M'.X M.X (M'.X ⊗ 𝟙_ D)).inv ≫ + ((M'.X ⊗ M.X) ◁ (ρ_ M'.X).hom) = + ((ρ_ M'.X).hom ▷ (M.X ⊗ M'.X)) ≫ + (α_ M'.X M.X M'.X).inv := by + monoidal + repeat' erw [Category.assoc] + rw [reassoc_of% hx, reassoc_of% hcoh] + have hR : ((M'.X ⊗ 𝟙_ D) ◁ modTensorπ A M M') ≫ + ((ρ_ M'.X).hom ▷ modTensor A M M') ≫ + zagContract A p hp = + ((ρ_ M'.X).hom ▷ (M.X ⊗ M'.X)) ≫ + (α_ M'.X M.X M'.X).inv ≫ + ((modTensorπ A M' M ≫ p) ▷ M'.X) ≫ actLeft A M'.X := by + have hx2 : ((M'.X ⊗ 𝟙_ D) ◁ modTensorπ A M M') ≫ + ((ρ_ M'.X).hom ▷ modTensor A M M') = + ((ρ_ M'.X).hom ▷ (M.X ⊗ M'.X)) ≫ + (M'.X ◁ modTensorπ A M M') := + whisker_exchange _ _ + rw [reassoc_of% hx2, whiskerLeft_modTensorπ_zagContract] + exact (hL2.trans hnat).trans hR.symm + +/-- **The zag composite in carrier form**: conjugated by the +singleton comparison, the multi-level zag composite is the +carrier insertion of the copairing followed by the carrier +contraction. No zigzag law enters. -/ +theorem zagComposite_eq_carrier + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (c : A ⟶ modTensor A M M') + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) : + zagComposite A c p hp = + (modMultiSingle A M').hom ≫ + ((ρ_ M'.X).inv ≫ (M'.X ◁ (η[A] ≫ c)) ≫ + zagContract A p hp) ≫ + (modMultiSingle A M').inv := by + apply eq_single_conj + have s1 : modMultiπ A [M'] ≫ (ρ_ (modMulti A [M'])).inv = + (ρ_ (modList A [M'])).inv ≫ + (modMultiπ A [M'] ▷ (𝟙_ D)) := + rightUnitor_inv_naturality _ + have s2 : (modMultiπ A [M'] ▷ (𝟙_ D)) ≫ + (modMulti A [M'] ◁ copairImage A c) = + (modList A [M'] ◁ copairImage A c) ≫ + (modMultiπ A [M'] ▷ modMulti A [M, M']) := + (whisker_exchange _ _).symm + have hbig : modMultiπ A [M'] ≫ zagComposite A c p hp ≫ + (modMultiSingle A M').hom = + (ρ_ (modList A [M'])).inv ≫ + (modList A [M'] ◁ (η[A] ≫ c)) ≫ + ((modList A [M'] ◁ modMultiPairInv A M M') ≫ + (modMultiπ A [M'] ▷ modMulti A [M, M']) ≫ + modMultiConcat A [M'] [M, M'] ≫ + modMultiContract3L A p hp M' ≫ + (modMultiSingle A M').hom) := by + simp only [zagComposite, Category.assoc] + rw [reassoc_of% s1, reassoc_of% s2, copairImage_eq, + MonoidalCategory.whiskerLeft_comp] + repeat' erw [Category.assoc] + have hcore := pairInv_concat_contract3L_single A p hp + have hfin : (ρ_ (M'.X ⊗ 𝟙_ D)).inv ≫ + ((M'.X ⊗ 𝟙_ D) ◁ (η[A] ≫ c)) ≫ + (((ρ_ M'.X).hom ▷ modTensor A M M') ≫ + zagContract A p hp) = + (ρ_ M'.X).hom ≫ (ρ_ M'.X).inv ≫ + (M'.X ◁ (η[A] ≫ c)) ≫ zagContract A p hp := by + have s5 : ((M'.X ⊗ 𝟙_ D) ◁ (η[A] ≫ c)) ≫ + ((ρ_ M'.X).hom ▷ modTensor A M M') = + ((ρ_ M'.X).hom ▷ (𝟙_ D)) ≫ (M'.X ◁ (η[A] ≫ c)) := + whisker_exchange _ _ + have s6 : (ρ_ (M'.X ⊗ 𝟙_ D)).inv ≫ + ((ρ_ M'.X).hom ▷ (𝟙_ D)) = + (ρ_ M'.X).hom ≫ (ρ_ M'.X).inv := by + monoidal + rw [reassoc_of% s5, reassoc_of% s6] + exact hbig.trans + ((congrArg (fun t => (ρ_ (modList A [M'])).inv ≫ + (modList A [M'] ◁ (η[A] ≫ c)) ≫ t) hcore).trans hfin) + +/-- The carrier zag identity from the multi-level zag law. -/ +theorem zag_carrier_of_multi + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (c : A ⟶ modTensor A M M') + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) + (h : zagComposite A c p hp = 𝟙 (modMulti A [M'])) : + (ρ_ M'.X).inv ≫ (M'.X ◁ (η[A] ≫ c)) ≫ + zagContract A p hp = 𝟙 M'.X := + (iso_conj_id_iff (modMultiSingle A M')).mp + ((zagComposite_eq_carrier A c p hp).symm.trans h) + +/-- The multi-level zag law from the carrier zag identity. -/ +theorem multi_of_zag_carrier + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (c : A ⟶ modTensor A M M') + (p : modTensor A M' M ⟶ A) + (hp : haveI := modTensorModObj A M' M + actLeft A (modTensor A M' M) ≫ p = (A ◁ p) ≫ μ[A]) + (h : (ρ_ M'.X).inv ≫ (M'.X ◁ (η[A] ≫ c)) ≫ + zagContract A p hp = 𝟙 M'.X) : + zagComposite A c p hp = 𝟙 (modMulti A [M']) := by + rw [zagComposite_eq_carrier A c p hp, h, Category.id_comp, + Iso.hom_inv_id] + +end ZagCarrier + +/-! ## The carrier identities of a zigzag datum -/ + +section Datum + +/-- **The carrier zig identity of a zigzag datum**: insert the +copairing on the left of the carrier and contract; the composite +is the identity of `M.X`. -/ +@[reassoc] +theorem zigzag_carrier_zig + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + {d : ModDualityDatum A M M'} + (hz : ModZigzagDatum A d) : + (λ_ M.X).inv ≫ ((η[A] ≫ d.copair) ▷ M.X) ≫ + zigContract A d.pair d.pair_linear = 𝟙 M.X := + zig_carrier_of_multi A d.copair d.pair d.pair_linear hz.zig + +/-- **The carrier zag identity of a zigzag datum**: insert the +copairing on the right of the dual carrier and contract; the +composite is the identity of `M'.X`. -/ +@[reassoc] +theorem zigzag_carrier_zag + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + {d : ModDualityDatum A M M'} + (hz : ModZigzagDatum A d) : + (ρ_ M'.X).inv ≫ (M'.X ◁ (η[A] ≫ d.copair)) ≫ + zagContract A d.pair d.pair_linear = 𝟙 M'.X := + zag_carrier_of_multi A d.copair d.pair d.pair_linear hz.zag + +/-- **The converse packaging**: the multi-level zigzag laws from +the carrier-level triangle identities. -/ +theorem modZigzagDatum_of_carrier + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + {d : ModDualityDatum A M M'} + (hzig : (λ_ M.X).inv ≫ ((η[A] ≫ d.copair) ▷ M.X) ≫ + zigContract A d.pair d.pair_linear = 𝟙 M.X) + (hzag : (ρ_ M'.X).inv ≫ (M'.X ◁ (η[A] ≫ d.copair)) ≫ + zagContract A d.pair d.pair_linear = 𝟙 M'.X) : + ModZigzagDatum A d := + ⟨multi_of_zig_carrier A d.copair d.pair d.pair_linear hzig, + multi_of_zag_carrier A d.copair d.pair d.pair_linear hzag⟩ + +end Datum + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagNonzero.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagNonzero.lean new file mode 100644 index 0000000000..313148923a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagNonzero.lean @@ -0,0 +1,76 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma + +/-! +# Nonvanishing detection from the zigzag laws + +The general engine behind every stage-unit nonvanishing argument +in the Key Lemma: for a duality datum satisfying the zigzag laws, +the copair element detects nonvanishing of the module. If the +element `η ≫ copair` vanishes then the zig composite vanishes, +yet the zigzag law says it is the identity of the single-factor +multi-tensor, which is therefore zero — and so is the module. + +This is the open-diagram detection: it consumes the triangle +identity, never the loop composite, so it is uniform in the +categorical dimension of the module. Applied to the power, +symmetric-power and chain-stage data it yields the stage units' +nonvanishing exactly from the nonvanishing of the corresponding +power objects. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- If the copair element vanishes, so does the module: the zig +composite factors through the copair element, and the zigzag law +makes it the identity. -/ +theorem isZero_of_unit_copair_eq_zero + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') (hz : ModZigzagDatum A d) + (h0 : η[A] ≫ d.copair = 0) : IsZero M.X := by + have hci : copairImage A d.copair = 0 := by + rw [copairImage, ← Category.assoc, h0, zero_comp] + have hzig : zigComposite A d.copair d.pair d.pair_linear = 0 := by + rw [zigComposite, hci] + simp + have hid : IsZero (modMulti A [M]) := by + rw [IsZero.iff_id_eq_zero] + exact hz.zig.symm.trans hzig + exact IsZero.of_iso hid (modMultiSingle A M).symm + +/-- **The copair element detects nonvanishing**: over a zigzag +datum for a nonzero module, the copair element is nonzero. This +is the open-diagram stage-unit detection of the Key Lemma. -/ +theorem unit_copair_ne_zero + [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') (hz : ModZigzagDatum A d) + (hM : ¬ IsZero M.X) : η[A] ≫ d.copair ≠ 0 := + fun h0 => hM (isZero_of_unit_copair_eq_zero A d hz h0) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagSandwich.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagSandwich.lean new file mode 100644 index 0000000000..3ee322a6bb --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagSandwich.lean @@ -0,0 +1,311 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichRetract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagCarrier + +/-! +# The zigzag laws as a sandwich retract + +The triangle identities of a Mod-internal duality datum are +carrier-level statements about insertion and contraction. This +file rewrites them inside the monoidal structure of the category +of modules: the zig triangle says exactly that the sandwich +insertion followed by the sandwich contraction is the identity, +where both legs are built from the module unitors, the module +associator and the relative tensor of morphisms. + +That form is what a strong monoidal functor transports, so it is +the shape in which base change consumes the zigzag laws. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +/-- **The sandwich contraction descends the carrier +contraction**: reassociating, contracting the trailing pair and +collapsing the regular factor is the carrier contraction of the +zig triangle. -/ +theorem modTensorπ_sandwichCon + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + modTensorπ A (modTensorMod A M M') M ≫ + (sandwichCon A d).hom = + zigContract A d.pair d.pair_linear := by + refine zigContract_unique A d.pair d.pair_linear ?_ + have hcon : (sandwichCon A d).hom = + modTensorAssocHom A M M' M ≫ + modTensorMap A (𝟙 M) (d.pairMod) ≫ + (modTensorUnitRight A M).hom := rfl + have key : ∀ {Z : D} + (h : modTensor A M (modTensorMod A M' M) ⟶ Z), + (modTensorπ A M M' ▷ M.X) ≫ + modTensorAssocMid A M M' M ≫ h = + (α_ M.X M'.X M.X).hom ≫ (M.X ◁ modTensorπ A M' M) ≫ + modTensorπ A M (modTensorMod A M' M) ≫ h := by + intro Z h + rw [← Category.assoc, whiskerRight_modTensorπ_assocMid, + modTensorAssocCover] + repeat' erw [Category.assoc] + have tail : modTensorπ A M (modTensorMod A M' M) ≫ + modTensorMap A (𝟙 M) (d.pairMod) ≫ + (modTensorUnitRight A M).hom = + (M.X ◁ d.pair) ≫ actRight A M.X := by + rw [modTensorπ_map_assoc, Mod.id_hom', + MonoidalCategory.id_tensorHom, + show (d.pairMod).hom = d.pair from rfl, + modTensorUnitRight_hom, modTensorπ_desc] + rfl + rw [hcon, modTensorπ_assocHom_assoc] + refine Eq.trans (key _) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ tail)) ?_ + rw [← MonoidalCategory.whiskerLeft_comp_assoc] + +/-- **Naming a map out of the regular module**: inserting the name +of a module map beside the carrier and projecting is the relative +tensor of the map with the identity. -/ +theorem modTensorMap_of_regular + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] + (P N : Mod D A) + (f : regularMod A ⟶ P) : + (modTensorUnitLeft A N).hom ≫ (λ_ N.X).inv ≫ + ((η[A] ≫ f.hom) ▷ N.X) ≫ modTensorπ A P N = + modTensorMap A f (𝟙 N) := by + have hlin : μ[A] ≫ f.hom = (A ◁ f.hom) ≫ actLeft A P.X := + f.isModHom.smul_hom + have hname : (λ_ (regularMod A).X).inv ≫ + ((η[A] ≫ f.hom) ▷ (regularMod A).X) ≫ actRight A P.X = + f.hom := by + simp only [actRight, MonoidalCategory.comp_whiskerRight, + Category.assoc] + rw [BraidedCategory.braiding_naturality_left_assoc, ← hlin, + reassoc_of% (IsCommMonObj.mul_comm A), + MonObj.one_mul_assoc, Iso.inv_hom_id_assoc] + have hcond : (P.X ◁ actLeft A N.X) ≫ modTensorπ A P N = + (α_ P.X A N.X).inv ≫ (actRight A P.X ▷ N.X) ≫ + modTensorπ A P N := by + have h := modTensor_condition A P N + rw [modTensorLegM, modTensorLegN, Category.assoc] at h + rw [h, Iso.inv_hom_id_assoc] + apply modTensor_hom_ext + rw [modTensorπ_map, Mod.id_hom', MonoidalCategory.tensorHom_id, + modTensorUnitLeft_hom, modTensorπ_desc_assoc, + leftUnitor_inv_naturality_assoc, whisker_exchange_assoc, + hcond, associator_inv_naturality_left_assoc, + ← leftUnitor_inv_whiskerRight_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc] + simp only [Category.assoc] + rw [hname] + +/-- **The sandwich insertion is the copairing insertion**: on +carriers, expanding the unit and inserting the copairing is +naming the copairing beside the carrier. -/ +theorem sandwichIns_hom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + (sandwichIns A d).hom = + (λ_ M.X).inv ≫ ((η[A] ≫ d.copair) ▷ M.X) ≫ + modTensorπ A (modTensorMod A M M') M := by + have h := modTensorMap_of_regular A (modTensorMod A M M') M + (d.copairMod) + change (modTensorUnitLeft A M).inv ≫ + modTensorMap A (d.copairMod) (𝟙 M) = _ + rw [← h, Iso.inv_hom_id_assoc] + rfl + +/-- **The sandwich composite is the zig composite**: the retract +word of the double-dual sandwich has the carrier zig triangle as +its underlying morphism. -/ +theorem sandwich_zig_carrier + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + (sandwichIns A d ≫ sandwichCon A d).hom = + (λ_ M.X).inv ≫ ((η[A] ≫ d.copair) ▷ M.X) ≫ + zigContract A d.pair d.pair_linear := by + change (sandwichIns A d).hom ≫ (sandwichCon A d).hom = _ + rw [sandwichIns_hom] + refine Eq.trans (Category.assoc _ _ _) ?_ + refine whisker_eq _ ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (modTensorπ_sandwichCon A d) + +/-- **The zig triangle is the sandwich retract identity**: a +duality datum satisfies the carrier zig law exactly when the +module is a retract of its double-dual sandwich through the +canonical insertion and contraction. -/ +theorem sandwich_zig_iff + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + sandwichIns A d ≫ sandwichCon A d = 𝟙 M ↔ + (λ_ M.X).inv ≫ ((η[A] ≫ d.copair) ▷ M.X) ≫ + zigContract A d.pair d.pair_linear = 𝟙 M.X := by + rw [← sandwich_zig_carrier] + constructor + · intro h + rw [h] + exact Mod.id_hom' M + · intro h + refine Mod.Hom.ext ?_ + rw [h] + exact (Mod.id_hom' M).symm + +/-- **The dual sandwich contraction descends the dual carrier +contraction**. -/ +theorem modTensorπ_sandwichConR + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + modTensorπ A M' (modTensorMod A M M') ≫ + (sandwichConR A d).hom = + zagContract A d.pair d.pair_linear := by + refine zagContract_unique A d.pair d.pair_linear ?_ + have hcon : (sandwichConR A d).hom = + modTensorAssocInv A M' M M' ≫ + modTensorMap A (d.pairMod) (𝟙 M') ≫ + (modTensorUnitLeft A M').hom := rfl + have key : ∀ {Z : D} + (h : modTensor A (modTensorMod A M' M) M' ⟶ Z), + (M'.X ◁ modTensorπ A M M') ≫ + modTensorAssocInvMid A M' M M' ≫ h = + (α_ M'.X M.X M'.X).inv ≫ + (modTensorπ A M' M ▷ M'.X) ≫ + modTensorπ A (modTensorMod A M' M) M' ≫ h := by + intro Z h + rw [← Category.assoc, whiskerLeft_modTensorπ_assocInvMid, + modTensorAssocInvCover] + repeat' erw [Category.assoc] + have tail : modTensorπ A (modTensorMod A M' M) M' ≫ + modTensorMap A (d.pairMod) (𝟙 M') ≫ + (modTensorUnitLeft A M').hom = + (d.pair ▷ M'.X) ≫ actLeft A M'.X := by + rw [modTensorπ_map_assoc, Mod.id_hom', + MonoidalCategory.tensorHom_id, + show (d.pairMod).hom = d.pair from rfl, + modTensorUnitLeft_hom, modTensorπ_desc] + rfl + rw [hcon, modTensorπ_assocInv_assoc] + refine Eq.trans (key _) ?_ + refine Eq.trans (whisker_eq _ (whisker_eq _ tail)) ?_ + rw [← MonoidalCategory.comp_whiskerRight_assoc] + +/-- **Naming a map out of the regular module on the right**. -/ +theorem modTensorMap_of_regular_right + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] (A : D) [MonObj A] [IsCommMonObj A] + (N P : Mod D A) + (f : regularMod A ⟶ P) : + (modTensorUnitRight A N).hom ≫ (ρ_ N.X).inv ≫ + (N.X ◁ (η[A] ≫ f.hom)) ≫ modTensorπ A N P = + modTensorMap A (𝟙 N) f := by + have hlin : μ[A] ≫ f.hom = (A ◁ f.hom) ≫ actLeft A P.X := + f.isModHom.smul_hom + have hname : (ρ_ A).inv ≫ (A ◁ (η[A] ≫ f.hom)) ≫ + actLeft A P.X = f.hom := by + rw [MonoidalCategory.whiskerLeft_comp, Category.assoc, + ← hlin, MonObj.mul_one_assoc, Iso.inv_hom_id_assoc] + have hcond : (actRight A N.X ▷ P.X) ≫ modTensorπ A N P = + (α_ N.X A P.X).hom ≫ (N.X ◁ actLeft A P.X) ≫ + modTensorπ A N P := by + have h := modTensor_condition A N P + rw [modTensorLegM, modTensorLegN, Category.assoc] at h + exact h + apply modTensor_hom_ext + rw [modTensorπ_map, Mod.id_hom', MonoidalCategory.id_tensorHom, + modTensorUnitRight_hom, modTensorπ_desc_assoc, + rightUnitor_inv_naturality_assoc, ← whisker_exchange_assoc, + hcond, associator_naturality_right_assoc, + ← whiskerLeft_rightUnitor_inv_assoc] + simp only [← MonoidalCategory.whiskerLeft_comp_assoc] + rw [hname] + +/-- **The dual sandwich insertion is the copairing insertion**. -/ +theorem sandwichInsR_hom + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + (sandwichInsR A d).hom = + (ρ_ M'.X).inv ≫ (M'.X ◁ (η[A] ≫ d.copair)) ≫ + modTensorπ A M' (modTensorMod A M M') := by + have h := modTensorMap_of_regular_right A M' + (modTensorMod A M M') (d.copairMod) + change (modTensorUnitRight A M').inv ≫ + modTensorMap A (𝟙 M') (d.copairMod) = _ + rw [← h, Iso.inv_hom_id_assoc] + rfl + +/-- **The dual sandwich composite is the zag composite**. -/ +theorem sandwich_zag_carrier + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + (sandwichInsR A d ≫ sandwichConR A d).hom = + (ρ_ M'.X).inv ≫ (M'.X ◁ (η[A] ≫ d.copair)) ≫ + zagContract A d.pair d.pair_linear := by + change (sandwichInsR A d).hom ≫ (sandwichConR A d).hom = _ + rw [sandwichInsR_hom] + refine Eq.trans (Category.assoc _ _ _) ?_ + refine whisker_eq _ ?_ + refine Eq.trans (Category.assoc _ _ _) ?_ + exact whisker_eq _ (modTensorπ_sandwichConR A d) + +/-- **The zag triangle is the dual sandwich retract +identity**. -/ +theorem sandwich_zag_iff + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {M : Mod D A} {M' : Mod D A} + (d : ModDualityDatum A M M') : + sandwichInsR A d ≫ sandwichConR A d = 𝟙 M' ↔ + (ρ_ M'.X).inv ≫ (M'.X ◁ (η[A] ≫ d.copair)) ≫ + zagContract A d.pair d.pair_linear = 𝟙 M'.X := by + rw [← sandwich_zag_carrier] + constructor + · intro h + rw [h] + exact Mod.id_hom' M' + · intro h + refine Mod.Hom.ext ?_ + rw [h] + exact (Mod.id_hom' M').symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagTransfer.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagTransfer.lean new file mode 100644 index 0000000000..28bee4fbda --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagTransfer.lean @@ -0,0 +1,372 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagCarrier +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairPerm + +/-! +# Transfer of the zigzag laws along retractions + +The zigzag laws pass from a duality datum to its transfer along a +section–retraction pair, given the self-adjointness of the +composite idempotent across the pairing. The transferred zig +factors as section, original zig, retraction: the idempotent +slides across the pairing once and then dissolves into the +retraction. Instantiated at the symmetriser section and +projection, this gives the zigzag laws of the symmetric-power +datum from those of the power datum — Deligne's 1.15.1. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +section Equivariance + +end Equivariance + +section Transfer + +/-- **Retraction images contract through the transferred +contraction**: precomposing the transferred zig contraction with +the retraction image is the section, the original contraction, +and the retraction — the idempotent slides across the pairing +and dissolves into the retraction. -/ +theorem map_zigContract + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {P : Mod D A} {P' : Mod D A} + {Q : Mod D A} {Q' : Mod D A} (d₀ : ModDualityDatum A P P') (s : Q ⟶ P) + (s' : Q' ⟶ P') (r : P ⟶ Q) (r' : P' ⟶ Q') + (hsr : s ≫ r = 𝟙 Q) + (hadj : modTensorMap A (r' ≫ s') (𝟙 P) ≫ d₀.pair = + modTensorMap A (𝟙 P') (r ≫ s) ≫ d₀.pair) : + (modTensorMap A r r' ▷ Q.X) ≫ + zigContract A (d₀.transfer A s s' r r').pair + (d₀.transfer A s s' r r').pair_linear = + (modTensor A P P' ◁ s.hom) ≫ + zigContract A d₀.pair d₀.pair_linear ≫ r.hom := by + apply modTensor_whiskerR_hom_ext A P P' Q.X + have hpair : (d₀.transfer A s s' r r').pair = + modTensorMap A s' s ≫ d₀.pair := rfl + -- The inner pairing occurrence: idempotent slide and + -- dissolution into the retraction. + have hstep1 : (r'.hom ⊗ₘ 𝟙 Q.X) ≫ modTensorπ A Q' Q = + modTensorπ A P' Q ≫ modTensorMap A r' (𝟙 Q) := + (modTensorπ_map A r' (𝟙 Q)).symm + have hstep2 : (𝟙 P'.X ⊗ₘ s.hom) ≫ modTensorπ A P' P = + modTensorπ A P' Q ≫ modTensorMap A (𝟙 P') s := + (modTensorπ_map A (𝟙 P') s).symm + have hmaps : modTensorMap A r' (𝟙 Q) ≫ modTensorMap A s' s = + modTensorMap A (𝟙 P') s ≫ + modTensorMap A (r' ≫ s') (𝟙 P) := by + rw [← modTensorMap_comp, ← modTensorMap_comp, + Category.id_comp, Category.id_comp, Category.comp_id] + have hs3 : s ≫ r ≫ s = s := by + rw [← Category.assoc, hsr, Category.id_comp] + have hinner : (r'.hom ⊗ₘ 𝟙 Q.X) ≫ + (modTensorπ A Q' Q ≫ (d₀.transfer A s s' r r').pair) = + (𝟙 P'.X ⊗ₘ s.hom) ≫ + (modTensorπ A P' P ≫ d₀.pair) := by + rw [hpair, ← Category.assoc, hstep1, Category.assoc, + ← Category.assoc (modTensorMap A r' (𝟙 Q)), hmaps, + Category.assoc, hadj, + ← Category.assoc (modTensorMap A (𝟙 P') s), + ← modTensorMap_comp, Category.id_comp, hs3, + ← Category.assoc, ← hstep2, Category.assoc] + -- Reduce the left side to the raw word and slide. + have hA : ((r.hom ⊗ₘ r'.hom) ▷ Q.X) ≫ + (α_ Q.X Q'.X Q.X).hom = + (α_ P.X P'.X Q.X).hom ≫ + (r.hom ⊗ₘ (r'.hom ⊗ₘ 𝟙 Q.X)) := by + simpa using associator_naturality r.hom r'.hom (𝟙 Q.X) + have hB : (r.hom ⊗ₘ (r'.hom ⊗ₘ 𝟙 Q.X)) ≫ + (Q.X ◁ (modTensorπ A Q' Q ≫ + (d₀.transfer A s s' r r').pair)) = + r.hom ⊗ₘ ((r'.hom ⊗ₘ 𝟙 Q.X) ≫ + (modTensorπ A Q' Q ≫ + (d₀.transfer A s s' r r').pair)) := by + simpa using MonoidalCategory.tensorHom_comp_tensorHom + r.hom (r'.hom ⊗ₘ 𝟙 Q.X) (𝟙 Q.X) + (modTensorπ A Q' Q ≫ (d₀.transfer A s s' r r').pair) + have hC : r.hom ⊗ₘ ((𝟙 P'.X ⊗ₘ s.hom) ≫ + (modTensorπ A P' P ≫ d₀.pair)) = + (P.X ◁ (𝟙 P'.X ⊗ₘ s.hom)) ≫ + (r.hom ⊗ₘ (modTensorπ A P' P ≫ d₀.pair)) := by + simpa using (MonoidalCategory.tensorHom_comp_tensorHom + (𝟙 P.X) (𝟙 P'.X ⊗ₘ s.hom) r.hom + (modTensorπ A P' P ≫ d₀.pair)).symm + have hD : (r.hom ⊗ₘ (modTensorπ A P' P ≫ d₀.pair)) ≫ + actRight A Q.X = + (P.X ◁ (modTensorπ A P' P ≫ d₀.pair)) ≫ + actRight A P.X ≫ r.hom := by + have hd1 : r.hom ⊗ₘ (modTensorπ A P' P ≫ d₀.pair) = + (P.X ◁ (modTensorπ A P' P ≫ d₀.pair)) ≫ + (r.hom ▷ A) := + MonoidalCategory.tensorHom_def' _ _ + rw [hd1, Category.assoc, ← actRight_natural_mod] + have hE : (α_ P.X P'.X Q.X).hom ≫ + (P.X ◁ (𝟙 P'.X ⊗ₘ s.hom)) = + ((P.X ⊗ P'.X) ◁ s.hom) ≫ (α_ P.X P'.X P.X).hom := by + simp + conv_lhs => rw [← comp_whiskerRight_assoc, modTensorπ_map, + comp_whiskerRight, Category.assoc, + whiskerRight_modTensorπ_zigContract, reassoc_of% hA, + reassoc_of% hB, hinner, hC, Category.assoc, hD, + reassoc_of% hE] + conv_rhs => rw [← whisker_exchange_assoc, + whiskerRight_modTensorπ_zigContract_assoc] + +/-- **The transferred carrier zig identity**: the zig of the +transferred datum factors as section, original zig, retraction. -/ +theorem transfer_carrier_zig + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {P : Mod D A} {P' : Mod D A} + {Q : Mod D A} {Q' : Mod D A} (d₀ : ModDualityDatum A P P') (s : Q ⟶ P) + (s' : Q' ⟶ P') (r : P ⟶ Q) (r' : P' ⟶ Q') + (hz₀ : ModZigzagDatum A d₀) + (hsr : s ≫ r = 𝟙 Q) + (hadj : modTensorMap A (r' ≫ s') (𝟙 P) ≫ d₀.pair = + modTensorMap A (𝟙 P') (r ≫ s) ≫ d₀.pair) : + (λ_ Q.X).inv ≫ + ((η[A] ≫ (d₀.transfer A s s' r r').copair) ▷ Q.X) ≫ + zigContract A (d₀.transfer A s s' r r').pair + (d₀.transfer A s s' r r').pair_linear = 𝟙 Q.X := by + have hcop : (d₀.transfer A s s' r r').copair = + d₀.copair ≫ modTensorMap A r r' := rfl + have hins : (λ_ Q.X).inv ≫ + ((η[A] ≫ d₀.copair) ▷ Q.X) ≫ + (modTensor A P P' ◁ s.hom) = + s.hom ≫ (λ_ P.X).inv ≫ ((η[A] ≫ d₀.copair) ▷ P.X) := by + rw [← whisker_exchange, ← leftUnitor_inv_naturality_assoc] + rw [hcop, ← Category.assoc η[A], comp_whiskerRight, + Category.assoc, map_zigContract A d₀ s s' r r' hsr hadj, + ← Category.assoc, ← Category.assoc, Category.assoc + ((λ_ Q.X).inv), hins, Category.assoc, Category.assoc, + zigzag_carrier_zig_assoc A hz₀] + have : s.hom ≫ r.hom = 𝟙 Q.X := by + have h2 := congrArg Mod.Hom.hom hsr + simpa using h2 + exact this + +/-- **Retraction images contract through the transferred zag +contraction**: the mirror of `map_zigContract`. -/ +theorem map_zagContract + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] {P : Mod D A} {P' : Mod D A} + {Q : Mod D A} {Q' : Mod D A} (d₀ : ModDualityDatum A P P') (s : Q ⟶ P) + (s' : Q' ⟶ P') (r : P ⟶ Q) (r' : P' ⟶ Q') + (hsr' : s' ≫ r' = 𝟙 Q') + (hadj : modTensorMap A (r' ≫ s') (𝟙 P) ≫ d₀.pair = + modTensorMap A (𝟙 P') (r ≫ s) ≫ d₀.pair) : + (Q'.X ◁ modTensorMap A r r') ≫ + zagContract A (d₀.transfer A s s' r r').pair + (d₀.transfer A s s' r r').pair_linear = + (s'.hom ▷ modTensor A P P') ≫ + zagContract A d₀.pair d₀.pair_linear ≫ r'.hom := by + apply modTensor_whisker_hom_ext A P P' Q'.X + have hpair : (d₀.transfer A s s' r r').pair = + modTensorMap A s' s ≫ d₀.pair := rfl + have hstep1 : (𝟙 Q'.X ⊗ₘ r.hom) ≫ modTensorπ A Q' Q = + modTensorπ A Q' P ≫ modTensorMap A (𝟙 Q') r := + (modTensorπ_map A (𝟙 Q') r).symm + have hstep2 : (s'.hom ⊗ₘ 𝟙 P.X) ≫ modTensorπ A P' P = + modTensorπ A Q' P ≫ modTensorMap A s' (𝟙 P) := + (modTensorπ_map A s' (𝟙 P)).symm + have hmaps : modTensorMap A (𝟙 Q') r ≫ modTensorMap A s' s = + modTensorMap A s' (𝟙 P) ≫ + modTensorMap A (𝟙 P') (r ≫ s) := by + rw [← modTensorMap_comp, ← modTensorMap_comp, + Category.id_comp, Category.id_comp, Category.comp_id] + have hs3 : s' ≫ r' ≫ s' = s' := by + rw [← Category.assoc, hsr', Category.id_comp] + have hinner : (𝟙 Q'.X ⊗ₘ r.hom) ≫ + (modTensorπ A Q' Q ≫ (d₀.transfer A s s' r r').pair) = + (s'.hom ⊗ₘ 𝟙 P.X) ≫ + (modTensorπ A P' P ≫ d₀.pair) := by + rw [hpair, ← Category.assoc, hstep1, Category.assoc, + ← Category.assoc (modTensorMap A (𝟙 Q') r), hmaps, + Category.assoc, ← hadj, + ← Category.assoc (modTensorMap A s' (𝟙 P)), + ← modTensorMap_comp, Category.id_comp, hs3, + ← Category.assoc, ← hstep2, Category.assoc] + have hA : (Q'.X ◁ (r.hom ⊗ₘ r'.hom)) ≫ + (α_ Q'.X Q.X Q'.X).inv = + (α_ Q'.X P.X P'.X).inv ≫ + ((𝟙 Q'.X ⊗ₘ r.hom) ⊗ₘ r'.hom) := by + simpa using associator_inv_naturality (𝟙 Q'.X) r.hom r'.hom + have hB : ((𝟙 Q'.X ⊗ₘ r.hom) ⊗ₘ r'.hom) ≫ + ((modTensorπ A Q' Q ≫ + (d₀.transfer A s s' r r').pair) ▷ Q'.X) = + ((𝟙 Q'.X ⊗ₘ r.hom) ≫ + (modTensorπ A Q' Q ≫ + (d₀.transfer A s s' r r').pair)) ⊗ₘ r'.hom := by + simpa using MonoidalCategory.tensorHom_comp_tensorHom + (𝟙 Q'.X ⊗ₘ r.hom) r'.hom + (modTensorπ A Q' Q ≫ (d₀.transfer A s s' r r').pair) + (𝟙 Q'.X) + have hC : ((s'.hom ⊗ₘ 𝟙 P.X) ≫ + (modTensorπ A P' P ≫ d₀.pair)) ⊗ₘ r'.hom = + ((s'.hom ⊗ₘ 𝟙 P.X) ⊗ₘ 𝟙 P'.X) ≫ + ((modTensorπ A P' P ≫ d₀.pair) ⊗ₘ r'.hom) := by + simpa using (MonoidalCategory.tensorHom_comp_tensorHom + (s'.hom ⊗ₘ 𝟙 P.X) (𝟙 P'.X) + (modTensorπ A P' P ≫ d₀.pair) r'.hom).symm + have hD : ((modTensorπ A P' P ≫ d₀.pair) ⊗ₘ r'.hom) ≫ + actLeft A Q'.X = + ((modTensorπ A P' P ≫ d₀.pair) ▷ P'.X) ≫ + actLeft A P'.X ≫ r'.hom := by + have := r'.isModHom + have hd1 : (modTensorπ A P' P ≫ d₀.pair) ⊗ₘ r'.hom = + ((modTensorπ A P' P ≫ d₀.pair) ▷ P'.X) ≫ + (A ◁ r'.hom) := + MonoidalCategory.tensorHom_def _ _ + rw [hd1, Category.assoc, ← actLeft_natural] + have hE : (α_ Q'.X P.X P'.X).inv ≫ + ((s'.hom ⊗ₘ 𝟙 P.X) ⊗ₘ 𝟙 P'.X) = + (s'.hom ▷ (P.X ⊗ P'.X)) ≫ + (α_ P'.X P.X P'.X).inv := by + simp + conv_lhs => rw [← MonoidalCategory.whiskerLeft_comp_assoc, + modTensorπ_map, MonoidalCategory.whiskerLeft_comp, + Category.assoc, whiskerLeft_modTensorπ_zagContract, + reassoc_of% hA, reassoc_of% hB, hinner, hC, + Category.assoc, hD, reassoc_of% hE] + conv_rhs => rw [whisker_exchange_assoc, + whiskerLeft_modTensorπ_zagContract_assoc] + +/-- **The transferred carrier zag identity**: the mirror +factorization through the dual-side section and retraction. -/ +theorem transfer_carrier_zag + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {P : Mod D A} {P' : Mod D A} + {Q : Mod D A} {Q' : Mod D A} (d₀ : ModDualityDatum A P P') (s : Q ⟶ P) + (s' : Q' ⟶ P') (r : P ⟶ Q) (r' : P' ⟶ Q') + (hz₀ : ModZigzagDatum A d₀) + (hsr' : s' ≫ r' = 𝟙 Q') + (hadj : modTensorMap A (r' ≫ s') (𝟙 P) ≫ d₀.pair = + modTensorMap A (𝟙 P') (r ≫ s) ≫ d₀.pair) : + (ρ_ Q'.X).inv ≫ + (Q'.X ◁ (η[A] ≫ (d₀.transfer A s s' r r').copair)) ≫ + zagContract A (d₀.transfer A s s' r r').pair + (d₀.transfer A s s' r r').pair_linear = 𝟙 Q'.X := by + have hcop : (d₀.transfer A s s' r r').copair = + d₀.copair ≫ modTensorMap A r r' := rfl + have hins : (ρ_ Q'.X).inv ≫ + (Q'.X ◁ (η[A] ≫ d₀.copair)) ≫ + (s'.hom ▷ modTensor A P P') = + s'.hom ≫ (ρ_ P'.X).inv ≫ + (P'.X ◁ (η[A] ≫ d₀.copair)) := by + rw [whisker_exchange, ← rightUnitor_inv_naturality_assoc] + rw [hcop, ← Category.assoc η[A], + MonoidalCategory.whiskerLeft_comp, Category.assoc, + map_zagContract A d₀ s s' r r' hsr' hadj, + ← Category.assoc, ← Category.assoc, Category.assoc + ((ρ_ Q'.X).inv), hins, Category.assoc, Category.assoc, + zigzag_carrier_zag_assoc A hz₀] + have : s'.hom ≫ r'.hom = 𝟙 Q'.X := by + have h2 := congrArg Mod.Hom.hom hsr' + simpa using h2 + exact this + +/-- **The zigzag laws transfer along retractions**: given the +self-adjointness of the composite idempotents across the pairing, +the transferred datum satisfies the zigzag laws. -/ +theorem modZigzagDatum_transfer + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {P : Mod D A} {P' : Mod D A} + {Q : Mod D A} {Q' : Mod D A} (d₀ : ModDualityDatum A P P') (s : Q ⟶ P) + (s' : Q' ⟶ P') (r : P ⟶ Q) (r' : P' ⟶ Q') + (hz₀ : ModZigzagDatum A d₀) + (hsr : s ≫ r = 𝟙 Q) (hsr' : s' ≫ r' = 𝟙 Q') + (hadj : modTensorMap A (r' ≫ s') (𝟙 P) ≫ d₀.pair = + modTensorMap A (𝟙 P') (r ≫ s) ≫ d₀.pair) : + ModZigzagDatum A (d₀.transfer A s s' r r') := + modZigzagDatum_of_carrier A + (transfer_carrier_zig A d₀ s s' r r' hz₀ hsr hadj) + (transfer_carrier_zag A d₀ s s' r r' hz₀ hsr' hadj) + +end Transfer + +section SymInstance + +/-- **The symmetric-power datum inherits the zigzag laws** +(Deligne 1.15.1): the transfer along the symmetriser section and +projection, with the self-adjointness of the symmetriser across +the nested pairing as the idempotent-slide input. -/ +theorem symDualityDatum_zigzag + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] (M : Mod D A) (M' : Mod D A) + [CategoryTheory.Linear ℂ D] [MonoidalLinear ℂ D] + (d : ModDualityDatum A M M') + (n : ℕ) + (hz : ModZigzagDatum A (powDualityDatum A M M' d n)) : + ModZigzagDatum A (symDualityDatum A M M' d n) := by + have hsr : symPowσMod A n ≫ symPowπMod A n = + 𝟙 (symPowMod A M.X n) := + Mod.hom_ext _ _ (symPowσ_symPowπ A M.X (n + 1)) + have hsr' : symPowσMod A n ≫ symPowπMod A n = + 𝟙 (symPowMod A M'.X n) := + Mod.hom_ext _ _ (symPowσ_symPowπ A M'.X (n + 1)) + have h1 : (symPowπMod A n ≫ symPowσMod A n : + modPowMod A M'.X n ⟶ modPowMod A M'.X n).hom = + symPowIdem A M'.X (n + 1) := + symPowπ_symPowσ A M'.X (n + 1) + have h2 : (symPowπMod A n ≫ symPowσMod A n : + modPowMod A M.X n ⟶ modPowMod A M.X n).hom = + symPowIdem A M.X (n + 1) := + symPowπ_symPowσ A M.X (n + 1) + have hadj : modTensorMap A (symPowπMod A n ≫ symPowσMod A n) + (𝟙 (modPowMod A M.X n)) ≫ + (powDualityDatum A M M' d n).pair = + modTensorMap A (𝟙 (modPowMod A M'.X n)) + (symPowπMod A n ≫ symPowσMod A n) ≫ + (powDualityDatum A M M' d n).pair := by + apply modTensor_hom_ext A (modPowMod A M'.X n) + (modPowMod A M.X n) + have hp : (powDualityDatum A M M' d n).pair = + modPowPairing A M M' d n := rfl + rw [← Category.assoc, modTensorπ_map, ← Category.assoc, + modTensorπ_map, hp, Category.assoc, Category.assoc, + modTensorπ_modPowPairing, h1, h2] + exact symPowIdem_pairPow_tensor A M M' d (n + 1) + exact modZigzagDatum_transfer A (powDualityDatum A M M' d n) + (symPowσMod A n) (symPowσMod A n) + (symPowπMod A n) (symPowπMod A n) hz hsr hsr' hadj + +end SymInstance + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagTransferIso.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagTransferIso.lean new file mode 100644 index 0000000000..c7da3c653d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagTransferIso.lean @@ -0,0 +1,75 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransfer + +/-! +# Transport of the zigzag laws along isomorphisms + +An isomorphism is a section–retraction pair whose composite +idempotent is the identity, so the adjointness condition of the +transfer is vacuous and the zigzag laws pass across without any +further hypothesis. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Limits +open scoped MonObj + +universe v u + +variable {D : Type u} + +section TransferIso + +/-- **Transport of a duality datum along isomorphisms** of the +two modules. -/ +noncomputable def ModDualityDatum.transferIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] {P : Mod D A} {P' : Mod D A} + {Q : Mod D A} {Q' : Mod D A} (d₀ : ModDualityDatum A P P') (i : Q ≅ P) + (i' : Q' ≅ P') : + ModDualityDatum A Q Q' := + d₀.transfer A i.hom i'.hom i.inv i'.inv + +/-- The adjointness condition of the transfer is vacuous for +isomorphisms: both composite idempotents are identities. -/ +theorem transferIso_adj + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + (A : D) [MonObj A] [IsCommMonObj A] {P : Mod D A} {P' : Mod D A} + {Q : Mod D A} {Q' : Mod D A} (d₀ : ModDualityDatum A P P') (i : Q ≅ P) + (i' : Q' ≅ P') : + modTensorMap A (i'.inv ≫ i'.hom) (𝟙 P) ≫ d₀.pair = + modTensorMap A (𝟙 P') (i.inv ≫ i.hom) ≫ d₀.pair := by + rw [i.inv_hom_id, i'.inv_hom_id] + +/-- **The zigzag laws transport along isomorphisms.** -/ +theorem modZigzagDatum_transferIso + [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] + [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] + [HasCoequalizers D] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] + [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorRight Z)] + (A : D) [MonObj A] [IsCommMonObj A] {P : Mod D A} {P' : Mod D A} + {Q : Mod D A} {Q' : Mod D A} (d₀ : ModDualityDatum A P P') (i : Q ≅ P) + (i' : Q' ≅ P') + (hz₀ : ModZigzagDatum A d₀) : + ModZigzagDatum A (d₀.transferIso A i i') := + modZigzagDatum_transfer A d₀ i.hom i'.hom i.inv i'.inv hz₀ + i.hom_inv_id i'.hom_inv_id (transferIso_adj A d₀ i i') + +end TransferIso + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DeligneBridge.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DeligneBridge.lean new file mode 100644 index 0000000000..0362e3b3d0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DeligneBridge.lean @@ -0,0 +1,78 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.FibreTransport +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.SnakeTransport + +/-! +# The Deligne bridge + +Connecting the fibre-functor interface to the extraction: a +braided monoidal functor into SuperVect carries a self-dual +object with a supersymmetric form to a standard orthosymplectic +model. The pairing transports by `ExactPairing.map`, the +supersymmetry by the braided-functor axiom, and +`exists_std_model` produces the coordinates. +-/ + +@[expose] public section + +noncomputable section + +namespace RS + +open CategoryTheory MonoidalCategory +open Functor.LaxMonoidal Functor.OplaxMonoidal + +variable {A : Type*} + +/-- Supersymmetry transports along a braided functor into +SuperVect: the transported form absorbs the Koszul braiding. -/ +theorem braided_transported_supersymmetry + [Category A] [MonoidalCategory A] [SymmetricCategory A] + (ω : A ⥤ SuperVect) + [ω.Braided] (X : A) [ExactPairing X X] + (hsym : (β_ X X).hom ≫ ε_ X X = ε_ X X) : + SuperVect.Hom.comp (μ ω X X ≫ ω.map (ε_ X X) ≫ η ω) + (SuperVect.koszulBraiding (ω.obj X) (ω.obj X)) = + (μ ω X X ≫ ω.map (ε_ X X) ≫ η ω) := by + change (β_ (ω.obj X) (ω.obj X)).hom ≫ + (μ ω X X ≫ ω.map (ε_ X X) ≫ η ω) = _ + rw [← Category.assoc, ← Functor.Braided.braided, + Category.assoc, ← Functor.map_comp_assoc, hsym] + +/-- **The Deligne bridge**: a braided monoidal functor into +SuperVect carries a self-dual object with a supersymmetric form +to a standard orthosymplectic model — the transported form +becomes the standard form and the transported copairing the +standard copairing. -/ +theorem braided_std_model + [Category A] [MonoidalCategory A] [SymmetricCategory A] + (ω : A ⥤ SuperVect) [ω.Braided] + (X : A) [ExactPairing X X] + (hsym : (β_ X X).hom ≫ ε_ X X = ε_ X X) : + ∃ (k ℓ : ℕ) (e : SuperVect.Hom (stdSuperPair k ℓ) (ω.obj X)) + (e' : SuperVect.Hom (ω.obj X) (stdSuperPair k ℓ)), + SuperVect.Hom.comp e' e = + SuperVect.Hom.id (stdSuperPair k ℓ) ∧ + SuperVect.Hom.comp e e' = SuperVect.Hom.id (ω.obj X) ∧ + SuperVect.Hom.comp (μ ω X X ≫ ω.map (ε_ X X) ≫ η ω) + (SuperVect.tensorHom e e) = stdForm k ℓ ∧ + SuperVect.Hom.comp (SuperVect.tensorHom e' e') + (ε ω ≫ ω.map (η_ X X) ≫ δ ω X X) = stdCopair k ℓ := by + let EP : ExactPairing (ω.obj X) (ω.obj X) := + ExactPairing.map ω (X := X) (Y := X) + exact exists_std_model + (μ ω X X ≫ ω.map (ε_ X X) ≫ η ω) + (ε ω ≫ ω.map (η_ X X) ≫ δ ω X X) + (braided_transported_supersymmetry ω X hsym) + EP.coevaluation_evaluation' + EP.evaluation_coevaluation' + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DelignePackage.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DelignePackage.lean new file mode 100644 index 0000000000..07a925c74b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DelignePackage.lean @@ -0,0 +1,52 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.SuperVect + +/-! +# The Deligne fibre-functor interface + +What the development actually consumes from a fibre functor. +Deligne's theorem is stated with his own hypotheses in +`DeligneTheorem.lean`, and its conclusion is +`DeligneFibreFunctor`: an exact, faithful, ℂ-linear symmetric +monoidal functor to super vector spaces. Only the symmetric +monoidal ℂ-linear structure is used downstream, so exactness and +faithfulness are forgotten here, by +`DeligneFibreFunctor.toPackage`. Weakening the interface weakens +what is assumed. + +The package is stated over an arbitrary carrier, so it can be +instantiated at the constructed envelope; the hypotheses of the +cited theorem are discharged for that envelope in +`RS/Novel/Envelope/EnvDelignePackage.lean`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +/-- The Deligne fibre-functor input for a candidate tensor +category: a ℂ-linear symmetric monoidal functor into SuperVect. +This is the conclusion of Deligne's theorem for a category +satisfying its hypotheses, weakened to the structure the +Regts–Sevenster extraction consumes. -/ +structure DelignePackage (A : Type*) [Category A] [MonoidalCategory A] + [SymmetricCategory A] [Preadditive A] [Linear ℂ A] where + /-- The fibre functor. -/ + ω : A ⥤ SuperVect + /-- The fibre functor is symmetric monoidal. -/ + braided : ω.Braided + /-- The fibre functor is additive. -/ + additive : ω.Additive + /-- The fibre functor is ℂ-linear. -/ + linear : ω.Linear ℂ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DelignePackageRestrict.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DelignePackageRestrict.lean new file mode 100644 index 0000000000..8dc691b7ea --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DelignePackageRestrict.lean @@ -0,0 +1,45 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage + +/-! +# Restriction of Deligne packages + +A Deligne fibre-functor package restricts along any braided +monoidal, additive, ℂ-linear functor: compose the fibre functor +with the embedding. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +/-- Restrict a Deligne package along a braided linear functor. -/ +noncomputable def DelignePackage.restrict + {A : Type*} [Category A] [MonoidalCategory A] + [SymmetricCategory A] [Preadditive A] [Linear ℂ A] + {B : Type*} [Category B] [MonoidalCategory B] + [SymmetricCategory B] [Preadditive B] [Linear ℂ B] + (F : B ⥤ A) [F.Braided] [F.Additive] [F.Linear ℂ] + (P : DelignePackage A) : DelignePackage B where + ω := F ⋙ P.ω + braided := + letI := P.braided + inferInstance + additive := + letI := P.additive + inferInstance + linear := + letI := P.additive + letI := P.linear + inferInstance + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DeligneTheorem.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DeligneTheorem.lean new file mode 100644 index 0000000000..f838277915 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DeligneTheorem.lean @@ -0,0 +1,50 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Growth + +/-! +# Deligne's theorem on tensor categories + +`DeligneTheoremStatement`, carrying Deligne's own hypotheses with +`DeligneFibreFunctor` as its conclusion, is stated in +`RS/Definitions.lean`, together with a hypothesis-by-hypothesis +correspondence against Théorème 0.6 and §0.1 of *Catégories +tensorielles* (Moscow Math. J. **2** (2002), 227–248; see also +Ostrik, arXiv:math/0401347, Thm 2.3). It is proved in +`RS/Classical/Deligne/`, as `RS.deligne_theorem`. + +This module carries the step from the conclusion to the consumed +interface: `DeligneFibreFunctor.toPackage` forgets faithfulness and +exactness, leaving the symmetric monoidal ℂ-linear functor the +development uses (`DelignePackage`). The conclusion is taken in +fibre-functor form rather than as the ⊗-equivalence with the +representations of a supergroup, which yields the functor by +composing with the forgetful functor. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Limits MonoidalCategory + +universe u v + +/-- Forgetting exactness and faithfulness of a Deligne fibre functor +leaves the structure the development consumes. -/ +def DeligneFibreFunctor.toPackage {A : Type*} [Category A] + [MonoidalCategory A] [SymmetricCategory A] [Preadditive A] + [Linear ℂ A] (F : DeligneFibreFunctor A) : DelignePackage A where + ω := F.ω + braided := F.braided + additive := F.additive + linear := F.linear + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/EulerianIndependence.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/EulerianIndependence.lean new file mode 100644 index 0000000000..f60be41f7b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/EulerianIndependence.lean @@ -0,0 +1,120 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition + +/-! +# The Eulerian-independence interface + +Regts–Sevenster's Proposition 3: the Definition 5 summand of an +Eulerian edge subset does not depend on the choice of transition +system and orientation. This Prop names the statement; it is +proved as `RS.eulerianIndependence` in +`RS/Novel/Skein/AllInternalAgreement.lean`. `mixedValue_eq_summand` +eliminates the choice in `EdgeSubset.mixedValue` against any +concrete transition data. +-/ + +@[expose] public section + +namespace RS + +/-- The Eulerian-independence statement (Regts–Sevenster, +arXiv:1807.04494, Proposition 3): the mixed summand is independent +of the transition system and orientation. Proved as +`RS.eulerianIndependence` in +`RS/Novel/Skein/AllInternalAgreement.lean`. -/ +def EulerianIndependence : Prop := + ∀ {α : Type} {W : Fragment α} (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) + {κ κ' : F.TransitionSystem} + (o : κ.Orientation) (o' : κ'.Orientation), + F.mixedSummand h o = F.mixedSummand h o' + +/-- Under Eulerian independence, the choice-based value of an edge +subset equals the summand at any concrete transition data. -/ +theorem EdgeSubset.mixedValue_eq_summand + (hInd : EulerianIndependence) + {α : Type} {W : Fragment α} (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) + {κ : F.TransitionSystem} (o : κ.Orientation) : + F.mixedValue h = F.mixedSummand h o := by + have hne : Nonempty ((κ' : F.TransitionSystem) × κ'.Orientation) := + ⟨⟨κ, o⟩⟩ + rw [EdgeSubset.mixedValue, dite_eq_left hne] + exact hInd F h _ o + +open Classical in +/-- **Transport invariance of the Definition 5 value**: under the +Eulerian-independence input, the choice-based value of a +transported edge subset is the original value. -/ +theorem EdgeSubset.mixedValue_transport (hInd : EulerianIndependence) + {α : Type} {W₁ W₂ : Fragment α} (e : W₁.Equiv W₂) + (F : EdgeSubset W₁) {k ℓ : ℕ} (h : MixedFunctional k ℓ) : + (EdgeSubset.transport e F).mixedValue h = F.mixedValue h := by + by_cases hne : Nonempty ((κ : F.TransitionSystem) × κ.Orientation) + · obtain ⟨⟨κ, o⟩⟩ := hne + rw [EdgeSubset.mixedValue_eq_summand hInd _ h + (EdgeSubset.TransitionSystem.Orientation.transport e o), + EdgeSubset.mixedValue_eq_summand hInd F h o] + exact EdgeSubset.mixedSummand_transport e h o + · have hne₂ : ¬ Nonempty + ((κ : (EdgeSubset.transport e F).TransitionSystem) × + κ.Orientation) := by + rintro ⟨⟨κ₂, o₂⟩⟩ + apply hne + have hback : Nonempty + ((κ' : (EdgeSubset.transport e.symm + (EdgeSubset.transport e F)).TransitionSystem) × + κ'.Orientation) := + ⟨⟨κ₂.transport e.symm, + EdgeSubset.TransitionSystem.Orientation.transport e.symm o₂⟩⟩ + rwa [EdgeSubset.transport_symm_transport] at hback + rw [EdgeSubset.mixedValue, EdgeSubset.mixedValue, + dite_eq_right hne, dite_eq_right hne₂] + +open Classical in +/-- **Isomorphism invariance of the mixed partition function**: +under the Eulerian-independence input, equivalent fragments have +equal Definition 5 values. -/ +theorem mixedPartition_transport (hInd : EulerianIndependence) + {α : Type} {W₁ W₂ : Fragment α} (e : W₁.Equiv W₂) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) : + mixedPartition h W₁ = mixedPartition h W₂ := by + unfold mixedPartition + rw [e.circles_eq] + congr 1 + refine Fintype.sum_equiv (Equiv.finsetCongr e.flagEquiv) _ _ (fun s => ?_) + rw [Equiv.finsetCongr_apply] + have hpair : ∀ g : W₂.Flag, e.flagEquiv.symm (W₂.pairing g) = + W₁.pairing (e.flagEquiv.symm g) := fun g => by + apply e.flagEquiv.injective + rw [Equiv.apply_symm_apply, e.pairing_comm, Equiv.apply_symm_apply] + have hclosed : (∀ f ∈ s, W₁.pairing f ∈ s) ↔ + (∀ g ∈ s.map e.flagEquiv.toEmbedding, + W₂.pairing g ∈ s.map e.flagEquiv.toEmbedding) := by + constructor + · intro hc g hg + rw [Finset.mem_map_equiv] at hg ⊢ + rw [hpair] + exact hc _ hg + · intro hc f hf + have hg := hc (e.flagEquiv f) + (by rw [Finset.mem_map_equiv, Equiv.symm_apply_apply]; exact hf) + rwa [Finset.mem_map_equiv, hpair, Equiv.symm_apply_apply] at hg + by_cases hc : ∀ f ∈ s, W₁.pairing f ∈ s + · rw [dite_eq_left hc, dite_eq_left (hclosed.mp hc)] + rw [show EdgeSubset.mk (s.map e.flagEquiv.toEmbedding) + (hclosed.mp hc) = + EdgeSubset.transport e (EdgeSubset.mk s hc) + from EdgeSubset.ext rfl] + simp only [EdgeSubset.transport_eulerian, + EdgeSubset.mixedValue_transport hInd] + · rw [dite_eq_right hc, dite_eq_right (fun hcc => hc (hclosed.mpr hcc))] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/FibreTransport.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/FibreTransport.lean new file mode 100644 index 0000000000..45c97d80f3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/FibreTransport.lean @@ -0,0 +1,89 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Monoidal functors preserve exact pairings + +We show that a monoidal functor `F : C ⥤ D` sends an +exact pairing `(X, Y)` in the source to an exact pairing +`(F.obj X, F.obj Y)` in the target, with evaluation and +coevaluation obtained by conjugating through the +tensorator and unit isomorphisms of `F`. + +This is the forward direction of the standard fact +"monoidal functors preserve dualizability". The reverse +direction (pulling back exact pairings along a faithful +monoidal functor) is Mathlib's +`ExactPairing.ofFaithful`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Category +open Functor.LaxMonoidal Functor.OplaxMonoidal +open Functor.Monoidal + +variable {C D : Type*} + +/-- Monoidal functors preserve exact pairings: +an `ExactPairing X Y` in `C` yields an +`ExactPairing (F.obj X) (F.obj Y)` in `D`, +with evaluation and coevaluation conjugated +through the tensorator and unit isomorphisms +of `F`. -/ +@[instance_reducible] +def ExactPairing.map + [Category C] [Category D] [MonoidalCategory C] [MonoidalCategory D] + (F : C ⥤ D) [F.Monoidal] + {X Y : C} + [ExactPairing X Y] : + ExactPairing (F.obj X) (F.obj Y) where + evaluation' := + μ F Y X ≫ F.map (ε_ X Y) ≫ η F + coevaluation' := + ε F ≫ F.map (η_ X Y) ≫ δ F X Y + coevaluation_evaluation' := by + simp only [whiskerLeft_comp, + comp_whiskerRight, assoc] + rw [map_associator_inv' F Y X Y] + simp only [assoc, whiskerLeft_δ_μ_assoc, + whiskerRight_δ_μ_assoc] + rw [μ_natural_right_assoc, + δ_natural_left_assoc, + ← Functor.map_comp_assoc, + ← Functor.map_comp_assoc, assoc, + ExactPairing.coevaluation_evaluation, + Functor.map_comp, assoc, + map_rightUnitor_assoc F, + μ_δ_assoc, whiskerLeft_ε_η_assoc, + map_leftUnitor_inv F] + simp only [assoc, μ_δ_assoc, + whiskerRight_ε_η, comp_id] + evaluation_coevaluation' := by + simp only [comp_whiskerRight, + whiskerLeft_comp, assoc] + rw [map_associator' F X Y X] + simp only [assoc, whiskerRight_δ_μ_assoc, + whiskerLeft_δ_μ_assoc] + rw [μ_natural_left_assoc, + δ_natural_right_assoc, + ← Functor.map_comp_assoc, + ← Functor.map_comp_assoc, assoc, + ExactPairing.evaluation_coevaluation, + Functor.map_comp, assoc, + map_leftUnitor_assoc F, + μ_δ_assoc, whiskerRight_ε_η_assoc, + map_rightUnitor_inv F] + simp only [assoc, μ_δ_assoc, + whiskerLeft_ε_η, comp_id] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/KoszulAction.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/KoszulAction.lean new file mode 100644 index 0000000000..67db1071e2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/KoszulAction.lean @@ -0,0 +1,113 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaTensorPower + +/-! +# The even-component restriction of the super permutation action + +The even and odd components of a `SuperVect` endomorphism, and the +even-component representation of `SymGroupAlgebra n` they give: +`superPermAction` followed by the even-component extraction, which +is linear, so the composite is again linear. + +Extraction is a linear map, so it carries zero to zero: whatever +the super permutation action kills, the even-component +representation kills too. That containment is what the sector +trace needs. +-/ + +@[expose] public section + +noncomputable section + +namespace RS + +open CategoryTheory MonoidalCategory Category +open Functor.LaxMonoidal Functor.OplaxMonoidal + +variable {R : ℕ} (f : EdgeRankParameter R) + (P : DelignePackage (SkeinObj f)) + +/-! ### Even and odd components -/ + +/-- The even component of a SuperVect endomorphism, viewed as a +module endomorphism. -/ +def evenComponent (W : SuperVect) (g : End W) : + Module.End ℂ W.even := + (g : SuperVect.Hom W W).evenMap + +/-- The odd component of a SuperVect endomorphism. -/ +def oddComponent (W : SuperVect) (g : End W) : + Module.End ℂ W.odd := + (g : SuperVect.Hom W W).oddMap + +/-- The even component of zero is zero. -/ +@[simp] +theorem evenComponent_zero (W : SuperVect) : + evenComponent W 0 = 0 := rfl + +/-- The odd component of zero is zero. -/ +@[simp] +theorem oddComponent_zero (W : SuperVect) : + oddComponent W 0 = 0 := rfl + +/-- Even extraction is additive. -/ +theorem evenComponent_add (W : SuperVect) + (g₁ g₂ : End W) : + evenComponent W (g₁ + g₂) = + evenComponent W g₁ + evenComponent W g₂ := rfl + +/-- Even extraction commutes with scaling. -/ +theorem evenComponent_smul (W : SuperVect) + (r : ℂ) (g : End W) : + evenComponent W (r • g) = r • evenComponent W g := rfl + +/-- The even-component extraction is a linear map from the +endomorphism algebra to the module endomorphism ring. -/ +def evenComponentLinear (W : SuperVect) : + End W →ₗ[ℂ] Module.End ℂ W.even where + toFun := evenComponent W + map_add' := evenComponent_add W + map_smul' := evenComponent_smul W + +/-! ### The even-component representation -/ + +/-- The even-component representation of `SymGroupAlgebra n` +on `(superPow V n).even`: the composite of `superPermAction` +with the even-component linear extraction. -/ +noncomputable def evenPermRep (n : ℕ) : + SymGroupAlgebra n →ₗ[ℂ] + Module.End ℂ (superPow (strandImage f P) n).even := by + letI := P.additive + letI := P.linear + exact (evenComponentLinear + (superPow (strandImage f P) n)).comp + (superPermAction f P n).toLinearMap + +/-- **Even-restriction zero implication**: if the super-permutation +action kills an element, so does the even-component representation. +This is immediate because the even component of a zero SuperVect +morphism is zero. -/ +theorem superPermAction_zero_imp_evenPermRep_zero (n : ℕ) + (x : SymGroupAlgebra n) : + letI := P.additive + letI := P.linear + superPermAction f P n x = 0 → + evenPermRep f P n x = 0 := by + let := P.additive + let := P.linear + intro h + change (evenComponentLinear _).comp + (superPermAction f P n).toLinearMap x = 0 + simp only [LinearMap.comp_apply, AlgHom.toLinearMap_apply, h, + map_zero] + +end RS + +end diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaPerm.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaPerm.lean new file mode 100644 index 0000000000..72263580ae --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaPerm.lean @@ -0,0 +1,116 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.FibreTransport +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ExactPairingInstance + +/-! +# Omega-equivariance of the symmetric-group action + +The braiding-generated symmetric-group action on the skein +endomorphism algebra `skeinEnd f n` transports along the Deligne +package's fibre functor `ω` to a well-defined algebra homomorphism +`SymGroupAlgebra n →ₐ[ℂ] End (ω.obj (SkeinObj.mk n))`. + +## Main results + +* `omegaPermHom` -- the monoid homomorphism + `Perm (Fin n) →* End (ω.obj (SkeinObj.mk n))` obtained by + composing the permutation-to-endomorphism map with the functorial + action on endomorphisms. +* `omegaSkeinRep` -- the algebra homomorphism + `SymGroupAlgebra n →ₐ[ℂ] End (ω.obj (SkeinObj.mk n))` lifted + from `omegaPermHom` via the universal property of the group + algebra. +* `omegaSkeinRep_of` -- on a single permutation `σ`, the + representation yields `ω.map (permClass f n σ)`. +* `omegaSkeinRep_eq` -- the transported representation agrees with + applying `ω.map` to the skein representation: + `omegaSkeinRep f P n x = ω.map (skeinRep f n x)`. + +## Formulation + +The skein category's symmetric-group action is the algebra +homomorphism `skeinRep f n : SymGroupAlgebra n →ₐ[ℂ] skeinEnd f n` +built from `σ ↦ [permFragment σ]` (see `RS.Novel.Envelope.SkeinTower`). +The fibre functor `ω` from a Deligne package induces a ring +homomorphism on endomorphisms via functoriality. The composite +`ω.map ∘ skeinRep f n` is therefore an algebra homomorphism from +the symmetric-group algebra to `End (ω.obj (SkeinObj.mk n))`, and +agreeing on the generators `σ` makes it that composite. +-/ + +@[expose] public section + +noncomputable section + +namespace RS + +open CategoryTheory MonoidalCategory Category +open Functor.LaxMonoidal Functor.OplaxMonoidal + +variable {R : ℕ} (f : EdgeRankParameter R) + (P : DelignePackage (SkeinObj f)) + +/-! ### The transported permutation representation -/ + +/-- The monoid homomorphism sending a permutation `σ : Perm (Fin n)` +to the endomorphism `ω.map (permClass f n σ)` of the image object. +This is the composition of the skein permutation-to-endomorphism +map `permToEnd f n` with the functorial action `ω.mapEnd`. -/ +noncomputable def omegaPermHom (n : ℕ) : + Equiv.Perm (Fin n) →* End (P.ω.obj (SkeinObj.mk n)) := + (P.ω.mapEnd (SkeinObj.mk n)).comp (permToEnd f n) + +/-- The transported symmetric-group representation: the algebra +homomorphism `SymGroupAlgebra n →ₐ[ℂ] End (ω.obj (SkeinObj.mk n))` +obtained by lifting `omegaPermHom` through the universal property +of the group algebra. -/ +noncomputable def omegaSkeinRep (n : ℕ) : + SymGroupAlgebra n →ₐ[ℂ] End (P.ω.obj (SkeinObj.mk n)) := + MonoidAlgebra.lift ℂ (End (P.ω.obj (SkeinObj.mk n))) + (Equiv.Perm (Fin n)) (omegaPermHom f P n) + +/-- On a single permutation, the transported representation yields +`ω.map (permClass f n σ)`. -/ +theorem omegaSkeinRep_of (n : ℕ) (σ : Equiv.Perm (Fin n)) : + omegaSkeinRep f P n (MonoidAlgebra.of ℂ (Equiv.Perm (Fin n)) σ) = + P.ω.map (permClass f n σ) := + MonoidAlgebra.lift_of (omegaPermHom f P n) σ + +/-- **Equivariance**: the transported representation agrees with +applying `ω.map` to the skein representation element by element. +Both sides are algebra homs agreeing on generators, hence equal +on all elements by the universal property. -/ +theorem omegaSkeinRep_eq (n : ℕ) (x : SymGroupAlgebra n) : + omegaSkeinRep f P n x = P.ω.map (skeinRep f n x) := by + let := P.additive + let := P.linear + -- Both sides are equal on generators and respect the algebra + -- operations. We proceed by induction on the group algebra + -- element. + apply MonoidAlgebra.induction_on x + · -- Generator case: both sides give ω.map (permClass f n σ) + intro σ + rw [omegaSkeinRep_of, skeinRep_of] + · -- Addition case + intro a b ha hb + simp only [map_add, ha, hb] + exact (Functor.map_add (F := P.ω) + (f := skeinRep f n a) (g := skeinRep f n b)).symm + · -- Scalar multiplication case + intro c a ha + simp only [map_smul, ha] + exact (Functor.map_smul (F := P.ω) + (r := c) (f := skeinRep f n a)).symm + +end RS + +end diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaTensorPower.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaTensorPower.lean new file mode 100644 index 0000000000..23f8bf0516 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaTensorPower.lean @@ -0,0 +1,296 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaPerm +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPower + +/-! +# Tensor-power decomposition of the fibre-functor image + +The fibre functor `ω` of a Deligne package sends the skein object +`SkeinObj.mk n` to a super vector space that is canonically +isomorphic to the `n`-th monoidal power of `V := ω.obj (SkeinObj.mk 1)`. +This file builds the chain: + +## Part A — Iterated tensorator + +* `omegaPow n : superPow V n ≅ ω.obj (SkeinObj.mk n)` — + by induction on `n` using the unit comparison `ε`/`η` and + the tensorator `μ`/`δ`. + +## Part B — Conjugated action + +* `superPermAction n` — the algebra homomorphism + `SymGroupAlgebra n →ₐ[ℂ] End (superPow V n)` obtained by + conjugating `omegaSkeinRep` through `omegaPow`. +* `superPermAction_eq_zero_iff` — conjugation by an iso preserves + zero: `superPermAction x = 0 ↔ omegaSkeinRep x = 0`. + +## Part C — The permutation-level formula + +* `superPermAction_perm` — on a single permutation `σ`, + `superPermAction σ` equals the conjugation of `ω.map (permClass σ)` + by `omegaPow`. +-/ + +@[expose] public section + +noncomputable section + +namespace RS + +open CategoryTheory MonoidalCategory Category +open Functor.LaxMonoidal Functor.OplaxMonoidal + +variable {R : ℕ} (f : EdgeRankParameter R) + (P : DelignePackage (SkeinObj f)) + +/-! ### Part A: The iterated tensorator -/ + +/-- Abbreviation for the strand image. -/ +abbrev strandImage : SuperVect := + P.ω.obj (SkeinObj.mk 1) + +/-- The forward map of the iterated tensorator: +`superPow V n ⟶ ω.obj (SkeinObj.mk n)`, built left-nested +using the unit comparison and the tensorator. -/ +noncomputable def omegaPowHom : + (n : ℕ) → (superPow (strandImage f P) n ⟶ + P.ω.obj (SkeinObj.mk n)) + | 0 => + letI := P.braided + ε P.ω + | n + 1 => + letI := P.braided + ((omegaPowHom n ⊗ₘ (𝟙 (P.ω.obj (SkeinObj.mk 1)))) ≫ + μ P.ω (SkeinObj.mk n) (SkeinObj.mk 1)) + +/-- The backward map of the iterated tensorator: +`ω.obj (SkeinObj.mk n) ⟶ superPow V n`, built by inverting +the tensorator at each step. -/ +noncomputable def omegaPowInv : + (n : ℕ) → (P.ω.obj (SkeinObj.mk n) ⟶ + superPow (strandImage f P) n) + | 0 => + letI := P.braided + η P.ω + | n + 1 => + letI := P.braided + (δ P.ω (SkeinObj.mk n) (SkeinObj.mk 1) ≫ + (omegaPowInv n ⊗ₘ (𝟙 (P.ω.obj (SkeinObj.mk 1))))) + +/-- The backward-then-forward composite is the identity +(the fibre side). -/ +theorem omegaPow_inv_hom : + ∀ n : ℕ, + (omegaPowInv f P n ≫ omegaPowHom f P n : + P.ω.obj (SkeinObj.mk n) ⟶ + P.ω.obj (SkeinObj.mk n)) = + 𝟙 (P.ω.obj (SkeinObj.mk n)) + | 0 => by + let := P.braided + change (η P.ω ≫ ε P.ω : P.ω.obj (SkeinObj.mk 0) ⟶ _) = 𝟙 _ + exact Functor.Monoidal.η_ε P.ω + | n + 1 => by + let := P.braided + change (δ P.ω (SkeinObj.mk n) (SkeinObj.mk 1) ≫ + (omegaPowInv f P n ⊗ₘ 𝟙 (P.ω.obj (SkeinObj.mk 1)))) ≫ + ((omegaPowHom f P n ⊗ₘ 𝟙 (P.ω.obj (SkeinObj.mk 1))) ≫ + μ P.ω (SkeinObj.mk n) (SkeinObj.mk 1)) = 𝟙 _ + simp only [assoc] + rw [← assoc (omegaPowInv f P n ⊗ₘ _)] + rw [MonoidalCategory.tensorHom_comp_tensorHom] + rw [omegaPow_inv_hom n, comp_id] + rw [MonoidalCategory.id_tensorHom_id] + rw [id_comp] + exact Functor.Monoidal.δ_μ P.ω (SkeinObj.mk n) (SkeinObj.mk 1) + +/-- The forward-then-backward composite is the identity +(the model side). -/ +theorem omegaPow_hom_inv : + ∀ n : ℕ, + (omegaPowHom f P n ≫ omegaPowInv f P n : + superPow (strandImage f P) n ⟶ + superPow (strandImage f P) n) = + 𝟙 (superPow (strandImage f P) n) + | 0 => by + let := P.braided + change (ε P.ω ≫ η P.ω : SuperVect.tensorUnit ⟶ _) = 𝟙 _ + exact Functor.Monoidal.ε_η P.ω + | n + 1 => by + let := P.braided + change ((omegaPowHom f P n ⊗ₘ 𝟙 (P.ω.obj (SkeinObj.mk 1))) ≫ + μ P.ω (SkeinObj.mk n) (SkeinObj.mk 1)) ≫ + (δ P.ω (SkeinObj.mk n) (SkeinObj.mk 1) ≫ + (omegaPowInv f P n ⊗ₘ 𝟙 (P.ω.obj (SkeinObj.mk 1)))) = 𝟙 _ + simp only [assoc] + rw [← assoc (μ P.ω (SkeinObj.mk n) (SkeinObj.mk 1))] + rw [show (μ P.ω (SkeinObj.mk n) (SkeinObj.mk 1) : + P.ω.obj (SkeinObj.mk n) ⊗ P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk (n + 1))) ≫ + δ P.ω (SkeinObj.mk n) (SkeinObj.mk 1) = 𝟙 _ from + Functor.Monoidal.μ_δ P.ω (SkeinObj.mk n) (SkeinObj.mk 1)] + rw [id_comp] + rw [MonoidalCategory.tensorHom_comp_tensorHom] + rw [omegaPow_hom_inv n, comp_id] + exact MonoidalCategory.id_tensorHom_id _ _ + +/-- **The iterated tensorator**: the `n`-th monoidal power of the +strand image is isomorphic to `ω.obj (SkeinObj.mk n)`, built by +iterating the tensorator `μ`/`δ`. -/ +noncomputable def omegaPow (n : ℕ) : + superPow (strandImage f P) n ≅ P.ω.obj (SkeinObj.mk n) where + hom := omegaPowHom f P n + inv := omegaPowInv f P n + hom_inv_id := omegaPow_hom_inv f P n + inv_hom_id := omegaPow_inv_hom f P n + +/-! ### Part B: The conjugated action -/ + +/-- Conjugation of an endomorphism by an isomorphism: +`e.hom ≫ f ≫ e.inv`, transporting `f : End Y` to `End X` +via `e : X ≅ Y`. -/ +def isoConj {C : Type*} [Category C] {X Y : C} (e : X ≅ Y) + (f : End Y) : End X := + e.hom ≫ f ≫ e.inv + +/-- Conjugation by an isomorphism, unfolded. -/ +@[simp] +theorem isoConj_unfold {C : Type*} [Category C] {X Y : C} + (e : X ≅ Y) (f : End Y) : + isoConj e f = e.hom ≫ f ≫ e.inv := rfl + +/-- It preserves the identity. -/ +theorem isoConj_one {C : Type*} [Category C] {X Y : C} + (e : X ≅ Y) : + isoConj e (𝟙 Y) = 𝟙 X := by + simp only [isoConj, id_comp, e.hom_inv_id] + +/-- And composition. -/ +theorem isoConj_mul {C : Type*} [Category C] + {X Y : C} (e : X ≅ Y) (f g : End Y) : + isoConj e (f ≫ g) = + isoConj e f ≫ isoConj e g := by + simp only [isoConj, assoc] + rw [← assoc e.inv e.hom, e.inv_hom_id, id_comp] + +/-- It sends zero to zero. -/ +theorem isoConj_zero {C : Type*} [Category C] [Preadditive C] + {X Y : C} (e : X ≅ Y) : + isoConj e (0 : End Y) = 0 := by + change e.hom ≫ (0 : Y ⟶ Y) ≫ e.inv = 0 + simp + +/-- And is additive — so it is an algebra map on endomorphisms. -/ +theorem isoConj_add {C : Type*} [Category C] [Preadditive C] + {X Y : C} (e : X ≅ Y) (f g : End Y) : + isoConj e (f + g) = isoConj e f + isoConj e g := by + change e.hom ≫ (f + g) ≫ e.inv = + e.hom ≫ f ≫ e.inv + e.hom ≫ g ≫ e.inv + have h1 : (f + g) ≫ e.inv = f ≫ e.inv + g ≫ e.inv := + map_add (Preadditive.rightComp Y e.inv) f g + rw [h1] + exact map_add (Preadditive.leftComp X e.hom) (f ≫ e.inv) (g ≫ e.inv) + +/-- Conjugation by an iso preserves scalar multiplication. -/ +theorem isoConj_smul {C : Type*} [Category C] [Preadditive C] + [Linear ℂ C] {X Y : C} (e : X ≅ Y) + (r : ℂ) (f : End Y) : + isoConj e (r • f) = r • isoConj e f := by + change e.hom ≫ (r • f) ≫ e.inv = r • (e.hom ≫ f ≫ e.inv) + have h1 : (r • f) ≫ e.inv = r • (f ≫ e.inv) := + Linear.smul_comp _ _ _ r f e.inv + rw [h1] + exact Linear.comp_smul _ _ _ e.hom r (f ≫ e.inv) + +/-- Conjugation by an iso is injective. -/ +theorem isoConj_injective {C : Type*} [Category C] + {X Y : C} + (e : X ≅ Y) : Function.Injective (isoConj e) := by + intro f g (h : e.hom ≫ f ≫ e.inv = e.hom ≫ g ≫ e.inv) + have h2 : e.inv ≫ (e.hom ≫ f ≫ e.inv) ≫ e.hom = + e.inv ≫ (e.hom ≫ g ≫ e.inv) ≫ e.hom := by rw [h] + simp only [Iso.inv_hom_id_assoc, Category.assoc, Iso.inv_hom_id, + Category.comp_id] at h2 + exact h2 + +/-- Conjugation by an iso preserves zero iff: +`isoConj e f = 0 ↔ f = 0`. -/ +theorem isoConj_eq_zero_iff {C : Type*} [Category C] + [Preadditive C] {X Y : C} (e : X ≅ Y) (f : End Y) : + isoConj e f = 0 ↔ f = 0 := by + constructor + · intro h + exact isoConj_injective e (h.trans (isoConj_zero e).symm) + · intro h + rw [h, isoConj_zero] + +/-- **The transported symmetric-group action on the tensor power**: +the algebra homomorphism obtained by conjugating `omegaSkeinRep` +through the iterated tensorator `omegaPow`. -/ +noncomputable def superPermAction (n : ℕ) : + SymGroupAlgebra n →ₐ[ℂ] + End (superPow (strandImage f P) n) := by + letI := P.additive + letI := P.linear + exact { + toFun := fun x => isoConj (omegaPow f P n) + (omegaSkeinRep f P n x) + map_one' := by rw [map_one]; exact isoConj_one _ + map_mul' := fun x y => by + rw [map_mul]; exact isoConj_mul _ _ _ + map_zero' := by rw [map_zero]; exact isoConj_zero _ + map_add' := fun x y => by + rw [map_add]; exact isoConj_add _ _ _ + commutes' := fun r => by + simp only [Algebra.algebraMap_eq_smul_one, map_smul, + map_one] + -- Goal: isoConj e (r • 1) = r • 1 + -- where 1 : End Y = 𝟙 Y + have h1 : (1 : End (P.ω.obj (SkeinObj.mk n))) = + 𝟙 (P.ω.obj (SkeinObj.mk n)) := rfl + have h2 : (1 : End (superPow (strandImage f P) n)) = + 𝟙 (superPow (strandImage f P) n) := rfl + rw [h1, isoConj_smul, isoConj_one, h2] + } + +/-- **Zero equivalence**: the transported action kills an element +if and only if the original fibre-functor action does. -/ +theorem superPermAction_eq_zero_iff (n : ℕ) + (x : SymGroupAlgebra n) : + letI := P.additive + letI := P.linear + superPermAction f P n x = 0 ↔ + omegaSkeinRep f P n x = 0 := by + let := P.additive + let := P.linear + exact isoConj_eq_zero_iff (omegaPow f P n) + (omegaSkeinRep f P n x) + +/-! ### Part C: Permutation-level formula -/ + +/-- On a single permutation, `superPermAction` is the conjugation +of `ω.map (permClass σ)` by `omegaPow`. -/ +theorem superPermAction_perm (n : ℕ) + (σ : Equiv.Perm (Fin n)) : + letI := P.additive + letI := P.linear + superPermAction f P n + (MonoidAlgebra.of ℂ (Equiv.Perm (Fin n)) σ) = + isoConj (omegaPow f P n) + (P.ω.map (permClass f n σ)) := by + let := P.additive + let := P.linear + change isoConj (omegaPow f P n) + (omegaSkeinRep f P n + (MonoidAlgebra.of ℂ (Equiv.Perm (Fin n)) σ)) = _ + rw [omegaSkeinRep_of] + +end RS + +end diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SchurPackage.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SchurPackage.lean new file mode 100644 index 0000000000..a4e843f1fe --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SchurPackage.lean @@ -0,0 +1,134 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums + +/-! +# The symmetric-group Schur interface + +`SchurPackage` bundles, as hypotheses, the classical representation +theory of the symmetric groups that the development consumes: for +each Young diagram `μ` a dimension `dim μ` and a character +`char μ : Perm (Fin μ.card) → ℂ`, such that the attached elements + + `e μ = (dim μ / μ.card !) • ∑ π, char μ π • π` + +are central idempotents of the group algebra `ℂ[S_{μ.card}]` whose +blocks have dimension `(dim μ)²` and are faithfully represented or +killed as a whole (`block_faithful`); together with the branching +containment (`branching`), the growth of the square-diagram +dimension (`square_dim`), and the Frobenius character formula +stated against the Jacobi–Trudi determinant of +`SymFun/PowerSums.lean` (`frobenius`). + +Everything here is standard — Fulton–Harris §4, Sagan, or +James–Kerber; the fields are exactly what the hook-confinement and +trace arguments of `Envelope/` consume, no more. A term is +constructed from mathlib's linear algebra as `RS.schurPackage` in +`RS/Classical/SchurTheory/Package.lean`. +-/ + +@[expose] public section + +namespace RS + +universe u + +open Equiv + +/-- The complex group algebra of the symmetric group `S_n`. -/ +abbrev SymGroupAlgebra (n : ℕ) : Type := + MonoidAlgebra ℂ (Equiv.Perm (Fin n)) + +/-- Extension of scalars of the group algebra along the standard +embedding `S_m ↪ S_n` (permutations extended by the identity), +for `m ≤ n`. -/ +noncomputable def symCast {m n : ℕ} (h : m ≤ n) : + SymGroupAlgebra m →ₐ[ℂ] SymGroupAlgebra n := + MonoidAlgebra.mapDomainAlgHom ℂ ℂ + (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h)) + +/-- The group-algebra element `(d / n!) • ∑ π, χ π • π` attached to +a prospective dimension `d` and character `χ`. -/ +noncomputable def charIdempotent {n : ℕ} (d : ℕ) (χ : Perm (Fin n) → ℂ) : + SymGroupAlgebra n := + ((d : ℂ) / (n.factorial : ℂ)) • + ∑ π : Perm (Fin n), χ π • (MonoidAlgebra.of ℂ (Perm (Fin n)) π) + +/-- The classical representation theory of the symmetric groups, as +consumed by this development. A term of this structure is an input +of the development. -/ +structure SchurPackage where + /-- The dimension of the irreducible representation of shape `μ`. -/ + dim : YoungDiagram → ℕ + /-- The irreducible character of shape `μ`. -/ + char : (μ : YoungDiagram) → Perm (Fin μ.card) → ℂ + /-- Dimensions are positive. -/ + dim_pos : ∀ μ : YoungDiagram, 0 < dim μ + /-- The attached idempotents are central. -/ + central : ∀ (μ : YoungDiagram) (x : SymGroupAlgebra μ.card), + charIdempotent (dim μ) (char μ) * x = x * charIdempotent (dim μ) (char μ) + /-- The attached elements are idempotent. -/ + idem : ∀ μ : YoungDiagram, + charIdempotent (dim μ) (char μ) * charIdempotent (dim μ) (char μ) = + charIdempotent (dim μ) (char μ) + /-- The block of shape `μ` — the ideal `e μ * ℂ[S_n]` — has + dimension `(dim μ)²`. -/ + block_rank : ∀ μ : YoungDiagram, + Module.finrank ℂ + (LinearMap.range (LinearMap.mulLeft ℂ (charIdempotent (dim μ) (char μ)))) + = + dim μ ^ 2 + /-- Blocks are simple: an algebra morphism that does not kill + `e μ` is injective on the block of `μ`. -/ + block_faithful : ∀ (μ : YoungDiagram) (B : Type u) [Ring B] [Algebra ℂ B] + (φ : SymGroupAlgebra μ.card →ₐ[ℂ] B), + φ (charIdempotent (dim μ) (char μ)) ≠ 0 → + ∀ x : SymGroupAlgebra μ.card, + φ (charIdempotent (dim μ) (char μ) * x) = 0 → + charIdempotent (dim μ) (char μ) * x = 0 + /-- Branching containment: for `lam ⊆ mu` the element + `e mu * (e lam ⊗ 1) * e mu` of the block of `mu` is nonzero. -/ + branching : ∀ (lam mu : YoungDiagram), lam ≤ mu → + ∀ h : lam.card ≤ mu.card, + charIdempotent (dim mu) (char mu) * + symCast h (charIdempotent (dim lam) (char lam)) * + charIdempotent (dim mu) (char mu) ≠ 0 + /-- The square-diagram dimensions outgrow every exponential + `R ^ (s²)`. -/ + square_dim : ∀ R : ℕ, ∃ s : ℕ, R ^ (s ^ 2) < dim (squareDiagram s) + /-- The Frobenius character formula, stated against the + Jacobi–Trudi determinant: for every scalar sequence `t`, + `(1/n!) ∑ π, char μ π · ∏_{c ∈ ρ(π)} t c = s_μ[t]`, where + `ρ(π)` is the full cycle type including fixed points — the + `cycleType` of mathlib excludes one-cycles, so the product is + completed by `(t 1) ^ (#fixed points)`. (The uncompleted form + is false already at `n = 1`.) -/ + frobenius : ∀ (μ : YoungDiagram) (t : ℕ → ℂ), + ((μ.card.factorial : ℂ))⁻¹ * + ∑ π : Perm (Fin μ.card), char μ π * + ((π.cycleType.map t).prod * + (t 1) ^ (μ.card - π.cycleType.sum)) = + diagramSchur μ t + +namespace SchurPackage + +/-- The central idempotent of shape `μ`. -/ +noncomputable def e (P : SchurPackage) (μ : YoungDiagram) : + SymGroupAlgebra μ.card := + charIdempotent (P.dim μ) (P.char μ) + +/-- `e` unfolds to `charIdempotent` of the package's data. -/ +theorem e_def (P : SchurPackage) (μ : YoungDiagram) : + P.e μ = charIdempotent (P.dim μ) (P.char μ) := + rfl + +end SchurPackage + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorDischarge.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorDischarge.lean new file mode 100644 index 0000000000..ad7794212e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorDischarge.lean @@ -0,0 +1,328 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SectorIntertwine +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialDet +public import LeanPool.RegtsSevenster.RS.QuantSector + +/-! +# Sector discharge: the last gap of the quantitative Regts–Sevenster theorem + +Given `SquareBinomialDetPos` (the Lindström–Gessel–Viennot core: the +binomial Toeplitz determinant for `squareDiagram s` at `−m` is nonzero +whenever `1 ≤ s ≤ m`), we discharge `SquareSectorBound`: when the +super permutation action kills the square-block idempotent at every +side `s' ≥ s`, both sector dimensions `k` (even) and `2l` (odd) of the +standard model `stdSuperPair k l` lie strictly below `s`. + +The proof transports the abstract `superPermAction` on +`superPow (strandImage f P) n` to the model action `modelPermMap` on +`superPow (stdSuperPair k l) n` via the iterated iso built from the +standard-model extraction `(e, e')`, then feeds the sector traces +`evenSectorTr` / `oddSectorTr` through `sector_bound_of_dead` / +`sector_bound_of_dead_signed`. + +## Main result + +* `squareSectorBound_of_detPos` — the last gap of the quantitative theorem. +-/ + +@[expose] public section + +noncomputable section + +namespace RS + +open CategoryTheory MonoidalCategory Category MonoidAlgebra +open Functor.LaxMonoidal Functor.OplaxMonoidal + + + +/-! ## Transport identification + +The iterated standard-model transport `stdToOmega ≫ omegaPowInv` +conjugates `superPermAction` to `modelPermMap`. +-/ + +/-- The transport of the permutation action through the standard-model +iso equals the model permutation map. The chain: + + `stdToOmega ≫ omegaPowInv ≫ superPermAction(σ) ≫ omegaPowHom ≫ stdFromOmega` + = `stdToOmega ≫ ω.map(permClass σ) ≫ stdFromOmega` [omegaPow cancellation] + = `stdToOmega ≫ ω.map(bundleMapClass σ) ≫ stdFromOmega` + [permClass = bundleMapClass] + = `modelPermMap σ ≫ stdToOmega ≫ stdFromOmega` [intertwining] + = `modelPermMap σ` [stdToOmega ≫ stdFromOmega = 𝟙] -/ +private theorem transport_perm_eq {R : ℕ} (f : EdgeRankParameter R) + (P : DelignePackage (SkeinObj f)) + {k l : ℕ} + (e : SuperVect.Hom (stdSuperPair k l) (strandImage f P)) + (e' : SuperVect.Hom (strandImage f P) (stdSuperPair k l)) + (he'e : SuperVect.Hom.comp e' e = SuperVect.Hom.id (stdSuperPair k l)) + (_hee' : SuperVect.Hom.comp e e' = + SuperVect.Hom.id (strandImage f P)) + (n : ℕ) (σ : Equiv.Perm (Fin n)) : + letI := P.additive; letI := P.linear; letI := P.braided + (stdToOmega f P e n ≫ omegaPowInv f P n) ≫ + (superPermAction f P n (MonoidAlgebra.of ℂ _ σ)) ≫ + (omegaPowHom f P n ≫ stdFromOmega f P e' n) = + modelPermMap σ := by + let := P.additive + let := P.linear + let := P.braided + -- Step 1: unfold superPermAction to isoConj(omegaPow)(ω.map(permClass σ)) + rw [superPermAction_perm] + -- Step 2: unfold isoConj and omegaPow projections + simp only [isoConj_unfold, + show (omegaPow f P n).hom = omegaPowHom f P n from rfl, + show (omegaPow f P n).inv = omegaPowInv f P n from rfl] + -- Step 3: fully right-associate + simp only [assoc] + -- Step 4: cancel first omegaPowInv ≫ omegaPowHom + rw [← assoc (omegaPowInv f P n) (omegaPowHom f P n)] + rw [show (omegaPowInv f P n ≫ omegaPowHom f P n : + P.ω.obj (SkeinObj.mk n) ⟶ _) = 𝟙 _ from + omegaPow_inv_hom f P n] + rw [id_comp] + -- Step 5: cancel second omegaPowInv ≫ omegaPowHom + rw [← assoc (omegaPowInv f P n) (omegaPowHom f P n)] + rw [show (omegaPowInv f P n ≫ omegaPowHom f P n : + P.ω.obj (SkeinObj.mk n) ⟶ _) = 𝟙 _ from + omegaPow_inv_hom f P n] + rw [id_comp] + -- Now LHS = stdToOmega ≫ ω.map(permClass σ) ≫ stdFromOmega + -- Step 6: permClass = bundleMapClass + rw [permClass_eq_bundleMapClass] + -- Step 7: intertwining + rw [← assoc (stdToOmega f P e n)] + rw [stdToOmega_bmc_perm_all f P e n σ] + -- Now LHS = modelPermMap σ ≫ stdToOmega ≫ stdFromOmega + rw [assoc] + -- Step 8: stdToOmega ≫ stdFromOmega = 𝟙 + rw [stdToOmega_stdFromOmega f P e e' he'e n] + -- Step 9: comp_id + exact comp_id _ + +/-! ## Even sector bound -/ + +/-- The conjugation of an even-part endomorphism through the +transport: sends `Module.End ℂ (strandImage power).even` to +`Module.End ℂ (stdSuperPair power).even`. -/ +private def evenConjTransport {R : ℕ} (f : EdgeRankParameter R) + (P : DelignePackage (SkeinObj f)) + {k l : ℕ} + (e : SuperVect.Hom (stdSuperPair k l) (strandImage f P)) + (e' : SuperVect.Hom (strandImage f P) (stdSuperPair k l)) + (n : ℕ) : + letI := P.braided + Module.End ℂ (superPow (strandImage f P) n).even →ₗ[ℂ] + Module.End ℂ (superPow (stdSuperPair k l) n).even := by + letI := P.braided + exact { + toFun := fun T => + (omegaPowHom f P n ≫ stdFromOmega f P e' n : + SuperVect.Hom _ _).evenMap.comp + (T.comp (stdToOmega f P e n ≫ omegaPowInv f P n : + SuperVect.Hom _ _).evenMap) + map_add' := fun T₁ T₂ => by + simp only [LinearMap.add_comp, LinearMap.comp_add] + map_smul' := fun r T => by + simp only [RingHom.id_apply, LinearMap.smul_comp, + LinearMap.comp_smul] + } + +/-- The even sector trace transported to the abstract strand power: +composes conjugation-by-transport with `evenSectorTr`. -/ +private def evenSectorTrTransport {R : ℕ} (f : EdgeRankParameter R) + (P : DelignePackage (SkeinObj f)) + {k l : ℕ} + (e : SuperVect.Hom (stdSuperPair k l) (strandImage f P)) + (e' : SuperVect.Hom (strandImage f P) (stdSuperPair k l)) + (n : ℕ) : + letI := P.braided + Module.End ℂ (superPow (strandImage f P) n).even →ₗ[ℂ] ℂ := by + letI := P.braided + exact (evenSectorTr k l n).comp (evenConjTransport f P e e' n) + +/-- The odd sector trace transported to the abstract strand power +(for even `n`). -/ +private def oddSectorTrTransport {R : ℕ} (f : EdgeRankParameter R) + (P : DelignePackage (SkeinObj f)) + {k l : ℕ} + (e : SuperVect.Hom (stdSuperPair k l) (strandImage f P)) + (e' : SuperVect.Hom (strandImage f P) (stdSuperPair k l)) + (n : ℕ) (hn : Even n) : + letI := P.braided + Module.End ℂ (superPow (strandImage f P) n).even →ₗ[ℂ] ℂ := by + letI := P.braided + exact (oddSectorTr k l n hn).comp (evenConjTransport f P e e' n) + +/-- **Even character formula through the transport**: the even sector +trace of the transported even representation equals +`cycleProd (const k)`. -/ +private theorem evenSectorTrTransport_perm + {R : ℕ} (f : EdgeRankParameter R) + (P : DelignePackage (SkeinObj f)) + {k l : ℕ} + (e : SuperVect.Hom (stdSuperPair k l) (strandImage f P)) + (e' : SuperVect.Hom (strandImage f P) (stdSuperPair k l)) + (he'e : SuperVect.Hom.comp e' e = SuperVect.Hom.id (stdSuperPair k l)) + (hee' : SuperVect.Hom.comp e e' = + SuperVect.Hom.id (strandImage f P)) + (n : ℕ) (σ : Equiv.Perm (Fin n)) : + letI := P.additive; letI := P.linear; letI := P.braided + evenSectorTrTransport f P e e' n + (evenPermRep f P n (MonoidAlgebra.of ℂ _ σ)) = + cycleProd (fun _ => (k : ℂ)) σ := by + let := P.additive + let := P.linear + let := P.braided + change (evenSectorTr k l n).comp (evenConjTransport f P e e' n) + (evenPermRep f P n (MonoidAlgebra.of ℂ _ σ)) = _ + simp only [LinearMap.comp_apply] + -- The argument of evenSectorTr equals (modelPermMap σ).evenMap + -- by the transport identification + have hkey : evenConjTransport f P e e' n + (evenPermRep f P n (MonoidAlgebra.of ℂ _ σ)) = + ((modelPermMap σ : SuperVect.Hom + (superPow (stdSuperPair k l) n) + (superPow (stdSuperPair k l) n))).evenMap := + congrArg SuperVect.Hom.evenMap + (transport_perm_eq f P e e' he'e hee' n σ) + rw [hkey] + exact evenSectorTr_perm k l n σ + +/-- **Odd character formula through the transport**: the odd sector +trace of the transported even representation equals +`sign(σ) · cycleProd (const (2l))` (for even `n`). -/ +private theorem oddSectorTrTransport_perm + {R : ℕ} (f : EdgeRankParameter R) + (P : DelignePackage (SkeinObj f)) + {k l : ℕ} + (e : SuperVect.Hom (stdSuperPair k l) (strandImage f P)) + (e' : SuperVect.Hom (strandImage f P) (stdSuperPair k l)) + (he'e : SuperVect.Hom.comp e' e = SuperVect.Hom.id (stdSuperPair k l)) + (hee' : SuperVect.Hom.comp e e' = + SuperVect.Hom.id (strandImage f P)) + (n : ℕ) (hn : Even n) + (σ : Equiv.Perm (Fin n)) : + letI := P.additive; letI := P.linear; letI := P.braided + oddSectorTrTransport f P e e' n hn + (evenPermRep f P n (MonoidAlgebra.of ℂ _ σ)) = + ((Equiv.Perm.sign σ : ℤ) : ℂ) * + cycleProd (fun _ => ((2 * l : ℕ) : ℂ)) σ := by + let := P.additive + let := P.linear + let := P.braided + change (oddSectorTr k l n hn).comp (evenConjTransport f P e e' n) + (evenPermRep f P n (MonoidAlgebra.of ℂ _ σ)) = _ + simp only [LinearMap.comp_apply] + have hkey : evenConjTransport f P e e' n + (evenPermRep f P n (MonoidAlgebra.of ℂ _ σ)) = + ((modelPermMap σ : SuperVect.Hom + (superPow (stdSuperPair k l) n) + (superPow (stdSuperPair k l) n))).evenMap := + congrArg SuperVect.Hom.evenMap + (transport_perm_eq f P e e' he'e hee' n σ) + rw [hkey] + exact oddSectorTr_perm k l n hn σ + +/-! ## Even (s²) is equivalent to even s -/ + +private theorem even_sq_of_even {s : ℕ} (hs : Even s) : + Even (s ^ 2) := by + obtain ⟨a, rfl⟩ := hs + exact ⟨2 * a ^ 2, by ring⟩ + +private theorem even_squareDiagram_card_of_even {s : ℕ} (hs : Even s) : + Even (squareDiagram s).card := by + rw [squareDiagram_card]; exact even_sq_of_even hs + +/-! ## The main theorem -/ + +/-- **Discharge of `SquareSectorBound`**: the last gap of the +quantitative Regts–Sevenster theorem. + +Given `SquareBinomialDetPos` (the binomial determinant nonvanishing), +we show that when `superPermAction` kills the square-block idempotent +at every side `s' ≥ s` with `1 ≤ s`, both sector dimensions `k` +(even) and `2l` (odd) of the standard model lie below `s`. -/ +theorem squareSectorBound_of_detPos (H : SquareBinomialDetPos) : + SquareSectorBound := by + intro R f P k l s hs1 e e' he'e hee' hdead + let := P.additive + let := P.linear + let := P.braided + constructor + · -- **k < s** via the even sector + -- Apply sector_bound_of_dead with: + -- M = Module.End ℂ (superPow (strandImage f P) (squareDiagram s).card).even + -- ρ = evenPermRep f P (squareDiagram s).card + -- tr = evenSectorTrTransport f P e e' (squareDiagram s).card + exact sector_bound_of_dead + (evenPermRep f P (squareDiagram s).card) + (evenSectorTrTransport f P e e' (squareDiagram s).card) + -- Character: tr(ρ(of π)) = cycleProd(const k) π + (fun π => evenSectorTrTransport_perm f P e e' he'e hee' + (squareDiagram s).card π) + -- Schur nonvanishing: s ≤ k → diagramSchur ≠ 0 + (fun hm => diagramSchur_square_const_ne_zero s k hm) + -- Kill: evenPermRep(charIdempotent) = 0 + (superPermAction_zero_imp_evenPermRep_zero f P _ _ + (hdead s (le_refl s))) + · -- **2 * l < s** via the odd sector with parity trick + -- Pick s'' ≥ s with Even s'' + set s'' := if Even s then s else s + 1 with hs''_def + have hs''_ge : s ≤ s'' := by + simp only [hs''_def]; split <;> omega + have hs''_even : Even s'' := by + simp only [hs''_def] + split + · assumption + · next h => + rw [Nat.even_add_one] + exact h + have hs''1 : 1 ≤ s'' := le_trans hs1 hs''_ge + have hn_even : Even (squareDiagram s'').card := + even_squareDiagram_card_of_even hs''_even + -- Apply sector_bound_of_dead_signed with: + -- s := s'', m := 2 * l + -- ρ = evenPermRep at s'' + -- tr = oddSectorTrTransport + have h2l_lt_s'' : 2 * l < s'' := + sector_bound_of_dead_signed + (evenPermRep f P (squareDiagram s'').card) + (oddSectorTrTransport f P e e' (squareDiagram s'').card hn_even) + -- Character: tr(ρ(of π)) = sign(π) * cycleProd(const (2l)) π + (fun π => oddSectorTrTransport_perm f P e e' he'e hee' + (squareDiagram s'').card hn_even π) + -- Schur nonvanishing: s'' ≤ 2*l → diagramSchur(−(2l)) ≠ 0 + (fun hm => diagramSchur_square_neg_const_ne_zero H s'' (2 * l) hm) + -- Kill: evenPermRep(charIdempotent at s'') = 0 + (superPermAction_zero_imp_evenPermRep_zero f P _ _ + (hdead s'' hs''_ge)) + -- Conclude 2 * l < s from 2 * l < s'' by parity analysis + by_cases hes : Even s + · -- Even s: s'' = s, immediate + rw [show s'' = s from by simp [hs''_def, hes]] at h2l_lt_s'' + exact h2l_lt_s'' + · -- Odd s: s'' = s + 1, so 2l < s+1, i.e. 2l ≤ s. + -- Since 2l is even and s is odd, 2l ≠ s, hence 2l < s. + rw [show s'' = s + 1 from by simp [hs''_def, hes]] at h2l_lt_s'' + -- h2l_lt_s'' : 2 * l < s + 1, i.e. 2 * l ≤ s + have h2l_le : 2 * l ≤ s := by omega + -- 2l is even, s is odd, so 2l ≠ s + have h2l_ne_s : 2 * l ≠ s := by + intro h_eq + have : Even s := h_eq ▸ ⟨l, by ring⟩ + exact hes this + omega + +end RS + +end diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorIntertwine.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorIntertwine.lean new file mode 100644 index 0000000000..98b6f8b798 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorIntertwine.lean @@ -0,0 +1,516 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.KoszulAction +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorNonvanishing +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelPermCoord + +/-! +# Sector intertwining for the standard model + +The even and odd sector trace functionals for the standard model +`stdSuperPair k ℓ`, and their character formulas: the intertwining that +carries the abstract `superPermAction` kernel containment of +`KoszulAction.lean` to concrete characters. + +## Main definitions + +* `evenSectorTr k ℓ n` — the partial trace on the all-even colour + block of `(superPow (stdSuperPair k ℓ) n).even` +* `oddSectorTr k ℓ n` — the partial trace on the all-odd colour + block (in the even component when `n` is even) + +## Main results + +* `evenSectorTr_perm` — the character formula: + `evenSectorTr k ℓ n (modelPermMap σ).evenMap = cycleProd (const k) σ` +* `oddSectorTr_perm` — the signed character formula: + `oddSectorTr k ℓ n (modelPermMap σ).evenMap = + sign(σ) · cycleProd (const (2ℓ)) σ` + (for even `n`) + +## The transport to an abstract package + +The transport from `stdSuperPair k ℓ` to `strandImage f P` (for an +abstract Deligne package with `strandImage ≅ stdSuperPair k ℓ`) requires +conjugating `evenSectorTr` / `oddSectorTr` by the induced +`LinearEquiv` on `(superPow V n).even`. Concretely: given a super +iso pair `(e, e')` with `e' ∘ e = id` and `e ∘ e' = id`, the +functoriality of `superPow` (tensorHom iterated) gives + `superPowIso : superPow (stdSuperPair k ℓ) n ≅ superPow (strandImage f P) n` +and + `evenSectorTr k ℓ n ∘ (conjugate by superPowIso.even) = evenSectorTr' f P n` +intertwines `modelPermMap` with `evenPermRep`. The kernel containment + `superPermAction f P n x = 0 → evenSectorTr' (evenPermRep f P n x) = 0` +follows from `superPermAction_zero_imp_evenPermRep_zero` in +`KoszulAction.lean`. +-/ + +@[expose] public section + +noncomputable section + +namespace RS + +open Finset MonoidAlgebra + + + +/-! ## All-even colourings -/ + +/-- The all-even colouring: every position gets an even colour. -/ +def allEvenEmb (k ℓ n : ℕ) (f : Fin n → Fin k) : MixedColouring k ℓ n := + fun i => Sum.inl (f i) + +/-- All-even colourings have empty odd support, hence even parity. -/ +theorem allEvenEmb_isEven (k ℓ n : ℕ) (f : Fin n → Fin k) : + (allEvenEmb k ℓ n f).IsEven := by + unfold MixedColouring.IsEven MixedColouring.oddSet allEvenEmb + have : Finset.univ.filter + (fun i : Fin n => + (Sum.inl (f i) : Fin k ⊕ Fin (2 * ℓ)).isRight) = ∅ := by + rw [Finset.filter_false_of_mem] + intro i _ + simp [Sum.isRight] + rw [this]; exact ⟨0, by simp⟩ + +/-- Composing an all-even colouring with a permutation. -/ +theorem allEvenEmb_comp (k ℓ n : ℕ) (f : Fin n → Fin k) + (σ : Equiv.Perm (Fin n)) : + allEvenEmb k ℓ n f ∘ σ = allEvenEmb k ℓ n (f ∘ σ) := rfl + +/-- The all-even embedding is injective. -/ +theorem allEvenEmb_injective (k ℓ n : ℕ) : + Function.Injective (allEvenEmb k ℓ n) := by + intro f g h + exact funext fun i => Sum.inl.inj (congrFun h i) + +/-- `oddInversions` vanishes on all-even colourings: no position +is odd-coloured, so the inversion filter is empty. -/ +theorem oddInversions_allEvenEmb (k ℓ n : ℕ) + (σ : Equiv.Perm (Fin n)) (f : Fin n → Fin k) : + oddInversions σ (allEvenEmb k ℓ n f) = 0 := by + unfold oddInversions allEvenEmb + rw [show Finset.univ.filter (fun p : Fin n × Fin n => + p.1 < p.2 ∧ σ p.1 > σ p.2 ∧ + (Sum.inl (f (σ p.1)) : Fin k ⊕ Fin (2 * ℓ)).isRight ∧ + (Sum.inl (f (σ p.2)) : Fin k ⊕ Fin (2 * ℓ)).isRight) = + ∅ from by + rw [Finset.filter_false_of_mem] + intro ⟨a, b⟩ _ + simp [Sum.isRight]] + exact Finset.card_empty + +/-! ## Colour-model basis vectors -/ + +/-- A basis vector of the even colour model at an even colouring. -/ +noncomputable def evenBasis (k ℓ n : ℕ) + (c : {c : MixedColouring k ℓ n // c.IsEven}) : + (superPow (stdSuperPair k ℓ) n).even := + (colourPowerEquiv k ℓ n).evenEquiv.symm + (show (colourPower k ℓ n).even from Pi.single c 1) + +/-- The colour-model coordinate at an even colouring, +evaluated on a basis vector. -/ +private theorem evenCoord_basis (k ℓ n : ℕ) + (c₁ c₂ : {c : MixedColouring k ℓ n // c.IsEven}) : + (colourPowerEquiv k ℓ n).evenEquiv (evenBasis k ℓ n c₂) c₁ = + if c₁ = c₂ then 1 else 0 := by + unfold evenBasis + have hrw : (colourPowerEquiv k ℓ n).evenEquiv + ((colourPowerEquiv k ℓ n).evenEquiv.symm + (show (colourPower k ℓ n).even from Pi.single c₂ 1)) = + (show (colourPower k ℓ n).even from Pi.single c₂ 1) := + (colourPowerEquiv k ℓ n).evenEquiv.apply_symm_apply _ + -- Apply function extensionality to extract the c₁ component + have happ := congrFun hrw c₁ + simp only at happ + rw [happ] + -- Goal is now about Pi.single c₂ 1 applied to c₁ + by_cases h : c₁ = c₂ <;> simp [h] + +/-- Specialisation: the coordinate at `allEvenEmb f` of +the basis vector at `allEvenEmb g`. -/ +private theorem coordOf_basis_allEven (k ℓ n : ℕ) + (f g : Fin n → Fin k) : + coordOf (evenBasis k ℓ n + ⟨allEvenEmb k ℓ n g, allEvenEmb_isEven k ℓ n g⟩) + (allEvenEmb k ℓ n f) = + if f = g then 1 else 0 := by + unfold coordOf + rw [dite_eq_left (allEvenEmb_isEven k ℓ n f)] + rw [evenCoord_basis] + by_cases h : f = g + · subst h; rw [ite_eq_left rfl, ite_eq_left rfl] + · rw [ite_eq_right h, ite_eq_right (fun hh => h + (allEvenEmb_injective k ℓ n (congrArg Subtype.val hh)))] + +/-! ## The even sector trace -/ + +/-- The even sector trace functional: the partial trace of an +endomorphism of `(superPow (stdSuperPair k ℓ) n).even` restricted to +the all-even colour block. -/ +noncomputable def evenSectorTr (k ℓ n : ℕ) : + Module.End ℂ (superPow (stdSuperPair k ℓ) n).even →ₗ[ℂ] ℂ where + toFun T := ∑ f : Fin n → Fin k, + (colourPowerEquiv k ℓ n).evenEquiv + (T (evenBasis k ℓ n + ⟨allEvenEmb k ℓ n f, allEvenEmb_isEven k ℓ n f⟩)) + ⟨allEvenEmb k ℓ n f, allEvenEmb_isEven k ℓ n f⟩ + map_add' T₁ T₂ := by + rw [← Finset.sum_add_distrib] + refine Finset.sum_congr rfl fun f _ => ?_ + rw [LinearMap.add_apply] + exact congrFun (map_add (colourPowerEquiv k ℓ n).evenEquiv + (T₁ (evenBasis k ℓ n _)) (T₂ (evenBasis k ℓ n _))) _ + map_smul' r T := by + simp only [RingHom.id_apply] + have hterm : ∀ f : Fin n → Fin k, + (colourPowerEquiv k ℓ n).evenEquiv + ((r • T) (evenBasis k ℓ n + ⟨allEvenEmb k ℓ n f, allEvenEmb_isEven k ℓ n f⟩)) + ⟨allEvenEmb k ℓ n f, allEvenEmb_isEven k ℓ n f⟩ = + r • (colourPowerEquiv k ℓ n).evenEquiv + (T (evenBasis k ℓ n + ⟨allEvenEmb k ℓ n f, allEvenEmb_isEven k ℓ n f⟩)) + ⟨allEvenEmb k ℓ n f, allEvenEmb_isEven k ℓ n f⟩ := by + intro f + rw [LinearMap.smul_apply] + exact congrFun (map_smul (colourPowerEquiv k ℓ n).evenEquiv r _) _ + rw [show (∑ f, (colourPowerEquiv k ℓ n).evenEquiv + ((r • T) (evenBasis k ℓ n + ⟨allEvenEmb k ℓ n f, allEvenEmb_isEven k ℓ n f⟩)) + ⟨allEvenEmb k ℓ n f, allEvenEmb_isEven k ℓ n f⟩) = + ∑ f, r • (colourPowerEquiv k ℓ n).evenEquiv + (T (evenBasis k ℓ n + ⟨allEvenEmb k ℓ n f, allEvenEmb_isEven k ℓ n f⟩)) + ⟨allEvenEmb k ℓ n f, allEvenEmb_isEven k ℓ n f⟩ from + Finset.sum_congr rfl fun f _ => hterm f] + exact (Finset.smul_sum).symm + +/-! ## Fixed-point count -/ + +open scoped Classical in +/-- The sum over `if f ∘ σ = f then 1 else 0` equals `cycleProd (const m)`. -/ +theorem fixedCount_eq_cycleProd (n m : ℕ) (σ : Equiv.Perm (Fin n)) : + (∑ f : Fin n → Fin m, + if f ∘ σ = f then (1 : ℂ) else 0) = + cycleProd (fun _ => (m : ℂ)) σ := by + -- Step 1: sum = card of fixed-point subtype + rw [Finset.sum_boole] + -- Step 2: card of filter = card of subtype + rw [show #{f ∈ Finset.univ | f ∘ σ = f} = + Fintype.card {f : Fin n → Fin m // f ∘ σ = f} from by + rw [Fintype.card_subtype]] + -- Step 3: fixed functions ≃ OrbitSpace → Fin m + rw [Fintype.card_congr (fixedFunEquiv σ (Fin m)), + Fintype.card_fun, Fintype.card_fin] + -- Step 4: cycleProd (const m) = m ^ #orbits + rw [cycleProd_const, card_orbitSpace] + push_cast; ring + +/-! ## The even character formula -/ + +/-- **Even character formula**: the even sector trace of +`modelPermMap σ` equals `cycleProd (fun _ => k) σ`. -/ +theorem evenSectorTr_perm (k ℓ n : ℕ) (σ : Equiv.Perm (Fin n)) : + evenSectorTr k ℓ n + ((modelPermMap σ : + SuperVect.Hom (superPow (stdSuperPair k ℓ) n) + (superPow (stdSuperPair k ℓ) n)).evenMap) = + cycleProd (fun _ => (k : ℂ)) σ := by + -- Unfold evenSectorTr + change ∑ f : Fin n → Fin k, + (colourPowerEquiv k ℓ n).evenEquiv + (((modelPermMap σ : SuperVect.Hom _ _).evenMap) + (evenBasis k ℓ n + ⟨allEvenEmb k ℓ n f, allEvenEmb_isEven k ℓ n f⟩)) + ⟨allEvenEmb k ℓ n f, allEvenEmb_isEven k ℓ n f⟩ = _ + -- Each summand = coordOf of the modelPermMap image + have hstep : ∀ f : Fin n → Fin k, + (colourPowerEquiv k ℓ n).evenEquiv + (((modelPermMap σ : SuperVect.Hom _ _).evenMap) + (evenBasis k ℓ n + ⟨allEvenEmb k ℓ n f, allEvenEmb_isEven k ℓ n f⟩)) + ⟨allEvenEmb k ℓ n f, allEvenEmb_isEven k ℓ n f⟩ = + coordOf (((modelPermMap σ : SuperVect.Hom _ _).evenMap) + (evenBasis k ℓ n + ⟨allEvenEmb k ℓ n f, allEvenEmb_isEven k ℓ n f⟩)) + (allEvenEmb k ℓ n f) := fun f => by + unfold coordOf + rw [dite_eq_left (allEvenEmb_isEven k ℓ n f)] + rw [Finset.sum_congr rfl (fun f _ => hstep f)] + -- Apply coordOf_modelPermMap' + have hcoord : ∀ f : Fin n → Fin k, + coordOf (((modelPermMap σ : SuperVect.Hom _ _).evenMap) + (evenBasis k ℓ n + ⟨allEvenEmb k ℓ n f, allEvenEmb_isEven k ℓ n f⟩)) + (allEvenEmb k ℓ n f) = + if f ∘ σ = f then 1 else 0 := fun f => by + rw [coordOf_modelPermMap' σ] + rw [oddInversions_allEvenEmb, pow_zero, one_mul, allEvenEmb_comp] + exact coordOf_basis_allEven k ℓ n (f ∘ σ) f + rw [Finset.sum_congr rfl (fun f _ => hcoord f)] + exact fixedCount_eq_cycleProd n k σ + +/-! ## All-odd colourings (even-n case) -/ + +/-- The all-odd colouring: every position gets an odd colour. -/ +def allOddEmb (k ℓ n : ℕ) (g : Fin n → Fin (2 * ℓ)) : + MixedColouring k ℓ n := + fun i => Sum.inr (g i) + +/-- An all-odd colouring has `oddSet = univ`. -/ +theorem allOddEmb_oddSet_card (k ℓ n : ℕ) + (g : Fin n → Fin (2 * ℓ)) : + (allOddEmb k ℓ n g).oddSet.card = n := by + unfold MixedColouring.oddSet allOddEmb + have : Finset.univ.filter + (fun i : Fin n => + (Sum.inr (g i) : Fin k ⊕ Fin (2 * ℓ)).isRight) = + Finset.univ := by + rw [Finset.filter_true_of_mem] + intro i _; simp [Sum.isRight] + rw [this]; exact Finset.card_fin n + +/-- All-odd colourings are even-parity iff `n` is even. -/ +theorem allOddEmb_isEven_iff (k ℓ n : ℕ) + (g : Fin n → Fin (2 * ℓ)) : + (allOddEmb k ℓ n g).IsEven ↔ Even n := by + unfold MixedColouring.IsEven + rw [allOddEmb_oddSet_card] + +/-- For even `n`, all-odd colourings are even-parity. -/ +theorem allOddEmb_isEven (k ℓ n : ℕ) (hn : Even n) + (g : Fin n → Fin (2 * ℓ)) : + (allOddEmb k ℓ n g).IsEven := + (allOddEmb_isEven_iff k ℓ n g).mpr hn + +/-- Composing an all-odd colouring with a permutation. -/ +theorem allOddEmb_comp (k ℓ n : ℕ) (g : Fin n → Fin (2 * ℓ)) + (σ : Equiv.Perm (Fin n)) : + allOddEmb k ℓ n g ∘ σ = allOddEmb k ℓ n (g ∘ σ) := rfl + +/-- The all-odd embedding is injective. -/ +theorem allOddEmb_injective (k ℓ n : ℕ) : + Function.Injective (allOddEmb k ℓ n) := by + intro f g h + exact funext fun i => Sum.inr.inj (congrFun h i) + +/-! ## Sign equals `(-1)^inversions` -/ + +/-- `adjTrans i` is a swap of two distinct elements. -/ +private theorem adjTrans_isSwap {n : ℕ} (i : Fin n) : + (adjTrans i).IsSwap := by + exact ⟨i.castSucc, i.succ, by + intro h; exact absurd (Fin.ext_iff.mp h) (by simp [Fin.val_succ]), + rfl⟩ + +/-- The sign of a permutation equals `(-1)` raised to the +length of its adjacent-transposition word. -/ +private theorem sign_eq_neg_one_pow_adjWord_length + {n : ℕ} (σ : Equiv.Perm (Fin (n + 1))) : + (Equiv.Perm.sign σ : ℤˣ) = + (-1 : ℤˣ) ^ (adjWord σ).length := by + conv_lhs => rw [← adjWord_spec σ] + rw [Equiv.Perm.sign_prod_list_swap + (fun g hg => by + rw [List.mem_map] at hg + obtain ⟨i, _, rfl⟩ := hg + exact adjTrans_isSwap i)] + congr 1; exact List.length_map .. + +/-- `wordSign w c = (-1)^(length w)` when `c` is all-odd. -/ +private theorem wordSign_allOdd {n : ℕ} (w : List (Fin n)) + (g : Fin (n + 1) → Fin (2 * ℓ)) : + wordSign w (allOddEmb k ℓ (n + 1) g) = + (-1 : ℂ) ^ w.length := by + induction w generalizing g with + | nil => simp [wordSign] + | cons i w ih => + change adjSign (allOddEmb k ℓ (n + 1) g) + ⟨i.val, by omega⟩ ⟨i.val + 1, by omega⟩ * + wordSign w (allOddEmb k ℓ (n + 1) g ∘ + Equiv.swap ⟨i.val, by omega⟩ ⟨i.val + 1, by omega⟩) = + (-1 : ℂ) ^ (i :: w).length + have hadj : adjSign (allOddEmb k ℓ (n + 1) g) + ⟨i.val, by omega⟩ ⟨i.val + 1, by omega⟩ = -1 := by + unfold adjSign allOddEmb + rw [ite_eq_left ⟨by simp [Sum.isRight], by simp [Sum.isRight]⟩] + rw [hadj] + have hswap : allOddEmb k ℓ (n + 1) g ∘ + Equiv.swap (⟨i.val, by omega⟩ : Fin (n + 1)) + ⟨i.val + 1, by omega⟩ = + allOddEmb k ℓ (n + 1) (g ∘ + Equiv.swap (⟨i.val, by omega⟩ : Fin (n + 1)) + ⟨i.val + 1, by omega⟩) := rfl + rw [hswap, ih, List.length_cons, pow_succ]; ring + +/-- `(-1)^oddInversions σ c = sign σ` when `c` is all-odd, at +positive arity. -/ +theorem neg_one_pow_oddInversions_allOdd {n : ℕ} + (σ : Equiv.Perm (Fin (n + 1))) + (g : Fin (n + 1) → Fin (2 * ℓ)) : + (-1 : ℂ) ^ oddInversions σ (allOddEmb k ℓ (n + 1) g) = + ((Equiv.Perm.sign σ : ℤ) : ℂ) := by + have hw := wordSign_eq_oddInversions (k := k) (ℓ := ℓ) + (adjWord σ) (allOddEmb k ℓ (n + 1) g) + rw [wordPerm_adjWord] at hw + rw [← hw, wordSign_allOdd (adjWord σ) g] + -- Goal: (-1 : ℂ) ^ |w| = ((sign σ : ℤ) : ℂ) + have hsign := sign_eq_neg_one_pow_adjWord_length σ + have hval : (Equiv.Perm.sign σ : ℤ) = + (-1 : ℤ) ^ (adjWord σ).length := by + calc (Equiv.Perm.sign σ : ℤ) + = ↑((Equiv.Perm.sign σ : ℤˣ)) := rfl + _ = ↑((-1 : ℤˣ) ^ (adjWord σ).length) := by rw [hsign] + _ = (↑(-1 : ℤˣ)) ^ (adjWord σ).length := + (Units.val_pow_eq_pow_val _ _).symm + _ = (-1 : ℤ) ^ (adjWord σ).length := rfl + rw [hval]; push_cast; ring + +/-- The sign-inversion identity at all arities. -/ +theorem neg_one_pow_oddInversions_allOdd' (n : ℕ) + (σ : Equiv.Perm (Fin n)) + (g : Fin n → Fin (2 * ℓ)) : + (-1 : ℂ) ^ oddInversions σ (allOddEmb k ℓ n g) = + ((Equiv.Perm.sign σ : ℤ) : ℂ) := by + match n with + | 0 => + have hσ : σ = 1 := Subsingleton.elim _ _ + subst hσ + suffices oddInversions (1 : Equiv.Perm (Fin 0)) + (allOddEmb k ℓ 0 g) = 0 by + rw [this]; norm_num [Equiv.Perm.sign_one] + unfold oddInversions + convert Finset.card_empty (α := Fin 0 × Fin 0) + exact Finset.eq_empty_of_forall_notMem + fun ⟨a, _⟩ => Fin.elim0 a + | n + 1 => exact neg_one_pow_oddInversions_allOdd σ g + +/-! ## The odd sector trace (even-n case) -/ + +/-- The odd sector trace functional (for even `n`): the partial +trace on the all-odd colour block of +`(superPow (stdSuperPair k ℓ) n).even`. -/ +noncomputable def oddSectorTr (k ℓ n : ℕ) (hn : Even n) : + Module.End ℂ (superPow (stdSuperPair k ℓ) n).even →ₗ[ℂ] ℂ where + toFun T := ∑ g : Fin n → Fin (2 * ℓ), + (colourPowerEquiv k ℓ n).evenEquiv + (T (evenBasis k ℓ n + ⟨allOddEmb k ℓ n g, allOddEmb_isEven k ℓ n hn g⟩)) + ⟨allOddEmb k ℓ n g, allOddEmb_isEven k ℓ n hn g⟩ + map_add' T₁ T₂ := by + rw [← Finset.sum_add_distrib] + refine Finset.sum_congr rfl fun g _ => ?_ + rw [LinearMap.add_apply] + exact congrFun (map_add (colourPowerEquiv k ℓ n).evenEquiv + (T₁ (evenBasis k ℓ n _)) (T₂ (evenBasis k ℓ n _))) _ + map_smul' r T := by + simp only [RingHom.id_apply] + have hterm : ∀ g : Fin n → Fin (2 * ℓ), + (colourPowerEquiv k ℓ n).evenEquiv + ((r • T) (evenBasis k ℓ n + ⟨allOddEmb k ℓ n g, allOddEmb_isEven k ℓ n hn g⟩)) + ⟨allOddEmb k ℓ n g, allOddEmb_isEven k ℓ n hn g⟩ = + r • (colourPowerEquiv k ℓ n).evenEquiv + (T (evenBasis k ℓ n + ⟨allOddEmb k ℓ n g, allOddEmb_isEven k ℓ n hn g⟩)) + ⟨allOddEmb k ℓ n g, allOddEmb_isEven k ℓ n hn g⟩ := by + intro g + rw [LinearMap.smul_apply] + exact congrFun (map_smul (colourPowerEquiv k ℓ n).evenEquiv r _) _ + rw [show (∑ g, (colourPowerEquiv k ℓ n).evenEquiv + ((r • T) (evenBasis k ℓ n + ⟨allOddEmb k ℓ n g, allOddEmb_isEven k ℓ n hn g⟩)) + ⟨allOddEmb k ℓ n g, allOddEmb_isEven k ℓ n hn g⟩) = + ∑ g, r • (colourPowerEquiv k ℓ n).evenEquiv + (T (evenBasis k ℓ n + ⟨allOddEmb k ℓ n g, allOddEmb_isEven k ℓ n hn g⟩)) + ⟨allOddEmb k ℓ n g, allOddEmb_isEven k ℓ n hn g⟩ from + Finset.sum_congr rfl fun g _ => hterm g] + exact (Finset.smul_sum).symm + +/-- Specialisation: the coordinate at `allOddEmb g₁` of +the basis vector at `allOddEmb g₂`. -/ +private theorem coordOf_basis_allOdd (k ℓ n : ℕ) (hn : Even n) + (g₁ g₂ : Fin n → Fin (2 * ℓ)) : + coordOf (evenBasis k ℓ n + ⟨allOddEmb k ℓ n g₂, allOddEmb_isEven k ℓ n hn g₂⟩) + (allOddEmb k ℓ n g₁) = + if g₁ = g₂ then 1 else 0 := by + unfold coordOf + rw [dite_eq_left (allOddEmb_isEven k ℓ n hn g₁)] + rw [evenCoord_basis] + by_cases h : g₁ = g₂ + · subst h; rw [ite_eq_left rfl, ite_eq_left rfl] + · rw [ite_eq_right h, ite_eq_right (fun hh => h + (allOddEmb_injective k ℓ n (congrArg Subtype.val hh)))] + +/-- **Odd character formula (even-n case)**: the odd sector trace +of `modelPermMap σ` equals `sign(σ) · cycleProd (const (2ℓ)) σ`. -/ +theorem oddSectorTr_perm (k ℓ n : ℕ) (hn : Even n) + (σ : Equiv.Perm (Fin n)) : + oddSectorTr k ℓ n hn + ((modelPermMap σ : + SuperVect.Hom (superPow (stdSuperPair k ℓ) n) + (superPow (stdSuperPair k ℓ) n)).evenMap) = + ((Equiv.Perm.sign σ : ℤ) : ℂ) * + cycleProd (fun _ => ((2 * ℓ : ℕ) : ℂ)) σ := by + -- Unfold + change ∑ g : Fin n → Fin (2 * ℓ), + (colourPowerEquiv k ℓ n).evenEquiv + (((modelPermMap σ : SuperVect.Hom _ _).evenMap) + (evenBasis k ℓ n + ⟨allOddEmb k ℓ n g, allOddEmb_isEven k ℓ n hn g⟩)) + ⟨allOddEmb k ℓ n g, allOddEmb_isEven k ℓ n hn g⟩ = _ + -- Rewrite via coordOf + have hstep : ∀ g : Fin n → Fin (2 * ℓ), + (colourPowerEquiv k ℓ n).evenEquiv + (((modelPermMap σ : SuperVect.Hom _ _).evenMap) + (evenBasis k ℓ n + ⟨allOddEmb k ℓ n g, allOddEmb_isEven k ℓ n hn g⟩)) + ⟨allOddEmb k ℓ n g, allOddEmb_isEven k ℓ n hn g⟩ = + coordOf (((modelPermMap σ : SuperVect.Hom _ _).evenMap) + (evenBasis k ℓ n + ⟨allOddEmb k ℓ n g, allOddEmb_isEven k ℓ n hn g⟩)) + (allOddEmb k ℓ n g) := fun g => by + unfold coordOf + rw [dite_eq_left (allOddEmb_isEven k ℓ n hn g)] + rw [Finset.sum_congr rfl (fun g _ => hstep g)] + -- Apply coordOf_modelPermMap' + have hcoord : ∀ g : Fin n → Fin (2 * ℓ), + coordOf (((modelPermMap σ : SuperVect.Hom _ _).evenMap) + (evenBasis k ℓ n + ⟨allOddEmb k ℓ n g, allOddEmb_isEven k ℓ n hn g⟩)) + (allOddEmb k ℓ n g) = + (-1 : ℂ) ^ oddInversions σ (allOddEmb k ℓ n g) * + (if g ∘ σ = g then 1 else 0) := fun g => by + rw [coordOf_modelPermMap' σ, allOddEmb_comp] + exact congrArg + ((-1 : ℂ) ^ oddInversions σ (allOddEmb k ℓ n g) * ·) + (coordOf_basis_allOdd k ℓ n hn (g ∘ σ) g) + rw [Finset.sum_congr rfl (fun g _ => hcoord g)] + -- Factor out the sign (oddInversions is constant) + have hsign : ∀ g : Fin n → Fin (2 * ℓ), + (-1 : ℂ) ^ oddInversions σ (allOddEmb k ℓ n g) = + ((Equiv.Perm.sign σ : ℤ) : ℂ) := + neg_one_pow_oddInversions_allOdd' n σ + rw [show (∑ g : Fin n → Fin (2 * ℓ), + (-1 : ℂ) ^ oddInversions σ (allOddEmb k ℓ n g) * + (if g ∘ σ = g then 1 else 0)) = + ((Equiv.Perm.sign σ : ℤ) : ℂ) * + ∑ g : Fin n → Fin (2 * ℓ), + (if g ∘ σ = g then (1 : ℂ) else 0) from by + rw [Finset.mul_sum] + exact Finset.sum_congr rfl fun g _ => by rw [hsign g]] + rw [fixedCount_eq_cycleProd] + +end RS + +end diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/TotalDimension.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/TotalDimension.lean new file mode 100644 index 0000000000..cd2023f3bf --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/TotalDimension.lean @@ -0,0 +1,145 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.ExponentialGrowth +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.WordCommutant +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourTotal +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaTensorPower +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.Frobenius +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.RankDimension + +/-! +# The total dimension bound for the standard model + +The fibre action on colour words factors through the skein +endomorphism algebra, whose dimension is at most `R ^ (2 * n)`. +The monomial word action has polynomial commutant dimension. Native +block faithfulness therefore bounds `(k + 2 * ℓ) ^ n` by `R ^ n` +times a fixed polynomial, forcing `k + 2 * ℓ ≤ R`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Representation + +noncomputable section + +private def stdOmegaIso {R k ℓ : ℕ} (f : EdgeRankParameter R) + (P : DelignePackage (SkeinObj f)) + (e : stdSuperPair k ℓ ≅ strandImage f P) (n : ℕ) : + superPow (stdSuperPair k ℓ) n ≅ P.ω.obj (SkeinObj.mk n) where + hom := stdToOmega f P e.hom n + inv := stdFromOmega f P e.inv n + hom_inv_id := stdToOmega_stdFromOmega f P e.hom e.inv + e.hom_inv_id n + inv_hom_id := stdFromOmega_stdToOmega f P e.hom e.inv + e.inv_hom_id n + +private theorem stdOmegaIso_perm {R k ℓ : ℕ} + (f : EdgeRankParameter R) (P : DelignePackage (SkeinObj f)) + (e : stdSuperPair k ℓ ≅ strandImage f P) (n : ℕ) + (σ : Equiv.Perm (Fin n)) : + letI := P.braided + (stdOmegaIso f P e n).hom ≫ + P.ω.map (permClass f n σ) ≫ (stdOmegaIso f P e n).inv = + modelPermMap σ := by + let := P.braided + change stdToOmega f P e.hom n ≫ P.ω.map (permClass f n σ) ≫ + stdFromOmega f P e.inv n = _ + rw [permClass_eq_bundleMapClass, ← Category.assoc, + stdToOmega_bmc_perm_all, Category.assoc, + stdToOmega_stdFromOmega f P e.hom e.inv e.hom_inv_id n, + Category.comp_id] + +/-- At every tensor power the standard model's squared dimension +is bounded by connection rank times a fixed polynomial. -/ +theorem stdModel_pow_le_connectionRank {R k ℓ : ℕ} + (f : EdgeRankParameter R) (P : DelignePackage (SkeinObj f)) + (e : stdSuperPair k ℓ ≅ strandImage f P) (n : ℕ) : + (k + 2 * ℓ) ^ (2 * n) ≤ connectionRank f.val (2 * n) * + (n + 1) ^ (2 * (k + 2 * ℓ) ^ 2) := by + classical + let := P.additive + let := P.linear + let := P.braided + let C := MixedColouring k ℓ n → ℂ + let c : Tot (P.ω.obj (SkeinObj.mk n)) ≃ₗ[ℂ] C := + (totIso (stdOmegaIso f P e n)).symm.trans (colourTotalEquiv k ℓ n) + let ψ : SymGroupAlgebra n →ₐ[ℂ] Module.End ℂ C := + (c.conjAlgEquiv ℂ).toAlgHom.comp + ((totAlgHom (P.ω.obj (SkeinObj.mk n))).comp (omegaSkeinRep f P n)) + let ρ : Representation ℂ (Equiv.Perm (Fin n)) C := + ψ.toMonoidHom.comp (MonoidAlgebra.of ℂ _) + have hρ : ρ.asAlgebraHom = ψ := by + apply MonoidAlgebra.algHom_ext + · intro σ + rw [Representation.asAlgebraHom_single, one_smul] + rfl + · exact Subsingleton.elim _ _ + have hker : ∀ x, skeinRep f n x = 0 → ρ.asAlgebraHom x = 0 := by + intro x hx + rw [hρ] + change (c.conjAlgEquiv ℂ) + (totAlgHom (P.ω.obj (SkeinObj.mk n)) (omegaSkeinRep f P n x)) = 0 + have hz : omegaSkeinRep f P n x = 0 := by + rw [omegaSkeinRep_eq, hx] + exact P.ω.map_zero _ _ + rw [hz, map_zero, map_zero] + have haction (σ : Equiv.Perm (Fin n)) (v : C) : + ρ σ v = colourTotalEquiv k ℓ n + (tot (modelPermMap σ) ((colourTotalEquiv k ℓ n).symm v)) := by + change c (tot (omegaSkeinRep f P n + (MonoidAlgebra.of ℂ _ σ)) (c.symm v)) = _ + rw [omegaSkeinRep_of] + change colourTotalEquiv k ℓ n + (tot (stdOmegaIso f P e n).inv + (tot (P.ω.map (permClass f n σ)) + (tot (stdOmegaIso f P e n).hom + ((colourTotalEquiv k ℓ n).symm v)))) = _ + rw [← LinearMap.comp_apply, ← tot_comp, + ← LinearMap.comp_apply, ← tot_comp, stdOmegaIso_perm] + let M : MonomialWordAction ρ := { + weight := fun σ c => (-1 : ℂ) ^ oddInversions σ c + weight_ne_zero := fun _ _ => pow_ne_zero _ (by norm_num) + apply_eq := fun σ v c => by + rw [haction] + exact colourTotalEquiv_modelPermMap σ v c + } + have hdim := finrank_sq_le_mul_commutant_sq ρ (skeinRep f n) hker + have hcomm := finrank_commutant_le_word_counts M + have h := hdim.trans (Nat.mul_le_mul_left _ + (Nat.pow_le_pow_left hcomm 2)) + rw [connectionRank_eq_skeinEnd_finrank] + simpa [C, MixedColouring, Module.finrank_pi, Fintype.card_fun, + ← pow_mul, Nat.mul_comm] using h + +/-- The standard model's total dimension is bounded by every +edge-rank base for the same parameter. -/ +theorem stdModel_total_dimension_le_of_rank_bound {R k ℓ B : ℕ} + (f : EdgeRankParameter R) (P : DelignePackage (SkeinObj f)) + (e : stdSuperPair k ℓ ≅ strandImage f P) + (hB : EdgeRankBounded f.val B) : k + 2 * ℓ ≤ B := by + have h := le_of_pow_le_pow_mul_polynomial + ((k + 2 * ℓ) ^ 2) (B ^ 2) (2 * (k + 2 * ℓ) ^ 2) (fun n => by + have hdim := (stdModel_pow_le_connectionRank f P e n).trans + (Nat.mul_le_mul_right _ (connectionRank_le_pow hB (2 * n))) + simpa only [← pow_mul] using hdim) + nlinarith + +/-- The standard model supplied by any Deligne package has total +dimension at most the original edge-rank base. -/ +theorem stdModel_total_dimension_le {R k ℓ : ℕ} + (f : EdgeRankParameter R) (P : DelignePackage (SkeinObj f)) + (e : stdSuperPair k ℓ ≅ strandImage f P) : k + 2 * ℓ ≤ R := + stdModel_total_dimension_le_of_rank_bound f P e f.rank_bounded + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BlockKill.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BlockKill.lean new file mode 100644 index 0000000000..1ec785c12e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BlockKill.lean @@ -0,0 +1,53 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.KillSimples + +/-! +# Kill criteria for the block development + +Vanishing of the `ofModule` action is elementwise annihilation; +intertwiners commute with the whole algebra action, so +annihilation transports along equivalences of representations. +-/ + +@[expose] public section + +namespace RS + +open Finset LinearMap + +variable {G : Type*} + +/-- An intertwiner commutes with the algebra action. -/ +theorem intertwiner_comp_asAlgebraHom [Group G] + {V W : Type*} [AddCommGroup V] [Module ℂ V] + [AddCommGroup W] [Module ℂ W] + {ρ : Representation ℂ G V} {σ : Representation ℂ G W} + (f : V →ₗ[ℂ] W) (hf : ∀ g : G, f ∘ₗ (ρ g : V →ₗ[ℂ] V) = + (σ g : W →ₗ[ℂ] W) ∘ₗ f) (y : MonoidAlgebra ℂ G) : + f ∘ₗ ρ.asAlgebraHom y = σ.asAlgebraHom y ∘ₗ f := by + induction y using MonoidAlgebra.induction_on with + | of g => + rw [show MonoidAlgebra.of ℂ G g = + MonoidAlgebra.single g (1 : ℂ) from rfl] + rw [show (ρ.asAlgebraHom (MonoidAlgebra.single g 1) : + V →ₗ[ℂ] V) = (ρ g : V →ₗ[ℂ] V) from by + rw [Representation.asAlgebraHom_single, one_smul]] + rw [show (σ.asAlgebraHom (MonoidAlgebra.single g 1) : + W →ₗ[ℂ] W) = (σ g : W →ₗ[ℂ] W) from by + rw [Representation.asAlgebraHom_single, one_smul]] + exact hf g + | add a b ha hb => + rw [map_add, map_add, LinearMap.comp_add, LinearMap.add_comp, + ha, hb] + | smul r a ha => + rw [map_smul, map_smul, LinearMap.comp_smul, + LinearMap.smul_comp, ha] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BranchTrace.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BranchTrace.lean new file mode 100644 index 0000000000..e02fff86aa --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BranchTrace.lean @@ -0,0 +1,151 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PackageAssembly + +/-! +# Branching from the restriction pairing + +If the mixed character pairing of `lam` against the restriction of +`mu` does not vanish, the branching sandwich is nonzero: apply the +block representation of `mu`, use that its projector acts as the +identity, and compute the trace of the cast idempotent as the +pairing. +-/ + +@[expose] public section + +namespace RS + +open Finset + +open scoped Classical in +/-- The mixed restriction pairing. -/ +noncomputable def restrPairing (lam mu : YoungDiagram) + (h : lam.card ≤ mu.card) : ℂ := + ∑ σ : Equiv.Perm (Fin lam.card), + jtChar lam σ * + jtChar mu (Equiv.Perm.viaEmbeddingHom + (Fin.castLEEmb h) σ) + +open scoped Classical in +/-- The trace of the block representation on the cast idempotent +is the normalized restriction pairing. -/ +theorem trace_symCast_charIdempotent (lam mu : YoungDiagram) + (h : lam.card ≤ mu.card) : + LinearMap.trace ℂ (subCarrier (jtSimple mu)) + ((rhoS (jtSimple mu)).asAlgebraHom + (symCast h + (charIdempotent (nDim (jtSimple lam)) (jtChar lam)))) = + ((nDim (jtSimple lam) : ℂ) / (lam.card.factorial : ℂ)) * + restrPairing lam mu h := by + classical + set L : MonoidAlgebra ℂ (Equiv.Perm (Fin lam.card)) →ₗ[ℂ] ℂ := + (LinearMap.trace ℂ (subCarrier (jtSimple mu))).comp + ((((rhoS (jtSimple mu)).asAlgebraHom : + MonoidAlgebra ℂ (Equiv.Perm (Fin mu.card)) →ₐ[ℂ] + Module.End ℂ (subCarrier (jtSimple mu))).toLinearMap + ).comp + ((symCast h : + SymGroupAlgebra lam.card →ₐ[ℂ] + SymGroupAlgebra mu.card).toLinearMap)) with hLdef + have hsingle : ∀ σ : Equiv.Perm (Fin lam.card), + L (MonoidAlgebra.of ℂ (Equiv.Perm (Fin lam.card)) σ) = + jtChar mu (Equiv.Perm.viaEmbeddingHom + (Fin.castLEEmb h) σ) := by + intro σ + rw [hLdef] + rw [LinearMap.comp_apply, LinearMap.comp_apply] + rw [show ((symCast h : + SymGroupAlgebra lam.card →ₐ[ℂ] + SymGroupAlgebra mu.card).toLinearMap) + (MonoidAlgebra.of ℂ (Equiv.Perm (Fin lam.card)) σ) = + MonoidAlgebra.of ℂ (Equiv.Perm (Fin mu.card)) + (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ) from by + change symCast h (MonoidAlgebra.of ℂ _ σ) = _ + rw [symCast, MonoidAlgebra.of_apply, MonoidAlgebra.of_apply] + change MonoidAlgebra.mapDomain + (⇑(Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h))) + (MonoidAlgebra.single σ (1 : ℂ)) = _ + rw [MonoidAlgebra.mapDomain_single]] + rw [show (((rhoS (jtSimple mu)).asAlgebraHom : + MonoidAlgebra ℂ (Equiv.Perm (Fin mu.card)) →ₐ[ℂ] + Module.End ℂ (subCarrier (jtSimple mu))).toLinearMap) + (MonoidAlgebra.of ℂ (Equiv.Perm (Fin mu.card)) + (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ)) = + rhoS (jtSimple mu) + (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ) from by + change (rhoS (jtSimple mu)).asAlgebraHom + (MonoidAlgebra.of ℂ _ _) = _ + rw [MonoidAlgebra.of_apply, + Representation.asAlgebraHom_single, one_smul]] + rw [jtSimple_char mu] + rfl + have hL : LinearMap.trace ℂ (subCarrier (jtSimple mu)) + ((rhoS (jtSimple mu)).asAlgebraHom + (symCast h + (charIdempotent (nDim (jtSimple lam)) + (jtChar lam)))) = + L (charIdempotent (nDim (jtSimple lam)) (jtChar lam)) := by + rw [hLdef] + rfl + rw [hL, charIdempotent, map_smul, map_sum] + rw [Finset.sum_congr rfl + (fun (σ : Equiv.Perm (Fin lam.card)) + (_ : σ ∈ Finset.univ) => map_smul L (jtChar lam σ) _)] + rw [Finset.sum_congr rfl + (fun (σ : Equiv.Perm (Fin lam.card)) + (_ : σ ∈ Finset.univ) => by rw [hsingle σ])] + rw [restrPairing, smul_eq_mul, Finset.mul_sum, + Finset.mul_sum] + refine Finset.sum_congr rfl fun σ _ => ?_ + rw [smul_eq_mul] + +open scoped Classical in +/-- **Branching from a nonvanishing pairing.** -/ +theorem branching_of_pairing (lam mu : YoungDiagram) + (h : lam.card ≤ mu.card) + (HB : restrPairing lam mu h ≠ 0) : + charIdempotent (nDim (jtSimple mu)) (jtChar mu) * + symCast h + (charIdempotent (nDim (jtSimple lam)) (jtChar lam)) * + charIdempotent (nDim (jtSimple mu)) (jtChar mu) ≠ 0 := by + classical + intro hzero + set y := symCast h + (charIdempotent (nDim (jtSimple lam)) (jtChar lam)) with hy + have hproj := charIdempotent_jtSimple mu + have hψ : (rhoS (jtSimple mu)).asAlgebraHom + (charIdempotent (nDim (jtSimple mu)) (jtChar mu) * y * + charIdempotent (nDim (jtSimple mu)) (jtChar mu)) = 0 := by + rw [hzero, map_zero] + rw [map_mul, map_mul, hproj, + nPsi_projector_eq_one (jtSimple mu) (jtSimple_simple mu), + one_mul, mul_one] at hψ + have htr := trace_symCast_charIdempotent lam mu h + rw [← hy, hψ, map_zero] at htr + have hd : ((nDim (jtSimple lam) : ℂ)) ≠ 0 := by + have := jtSimple_simple lam + have := IsSimpleModule.nontrivial + (MonoidAlgebra ℂ (Equiv.Perm (Fin lam.card))) + (jtSimple lam) + have : Nontrivial (subCarrier (jtSimple lam)) := + inferInstanceAs (Nontrivial (jtSimple lam)) + have := Module.finrank_pos + (R := ℂ) (M := subCarrier (jtSimple lam)) + exact_mod_cast Nat.cast_ne_zero.mpr this.ne' + have hf : ((lam.card.factorial : ℂ)) ≠ 0 := by + exact_mod_cast Nat.factorial_ne_zero lam.card + have hcoef : ((nDim (jtSimple lam) : ℂ) / + (lam.card.factorial : ℂ)) ≠ 0 := div_ne_zero hd hf + apply HB + rcases mul_eq_zero.mp htr.symm with h1 | h1 + · exact absurd h1 hcoef + · exact h1 + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CentralElem.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CentralElem.lean new file mode 100644 index 0000000000..bbe2e40884 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CentralElem.lean @@ -0,0 +1,84 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.RegularTrace + +/-! +# Class functions give central elements + +The group-algebra element attached to a conjugation-invariant +coefficient function is central — pure coefficient algebra, no +representation theory. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {G : Type*} + +/-- The group-algebra element attached to a coefficient +function. -/ +noncomputable def classElem [Group G] [Fintype G] + (c : G → ℂ) : MonoidAlgebra ℂ G := + ∑ g : G, c g • MonoidAlgebra.single g 1 + +/-- The element built from a coefficient function has exactly those +coefficients. -/ +theorem classElem_coeff [Group G] [Fintype G] + (c : G → ℂ) (k : G) : + (classElem c).coeff k = c k := by + classical + rw [classElem] + rw [show ((∑ g : G, c g • MonoidAlgebra.single g 1).coeff k) = + ∑ g : G, (c g • MonoidAlgebra.single g (1 : ℂ)).coeff k from by + rw [MonoidAlgebra.coeff_sum] + exact Finsupp.finsetSum_apply _ _ _] + rw [Finset.sum_congr rfl (fun g _ => show + (c g • MonoidAlgebra.single g (1 : ℂ)).coeff k = + if g = k then c g else 0 from by + rw [show (c g • MonoidAlgebra.single g (1 : ℂ)).coeff k = + c g • (MonoidAlgebra.single g (1 : ℂ)).coeff k from + MonoidAlgebra.coeff_smul_apply (c g) _ k] + rw [show (MonoidAlgebra.single g (1 : ℂ)).coeff k = + if g = k then 1 else 0 from Finsupp.single_apply] + by_cases h : g = k <;> simp [h])] + rw [Finset.sum_ite_eq' Finset.univ k c] + rw [ite_eq_left (Finset.mem_univ k)] + +/-- **Class functions give central elements.** -/ +theorem classElem_mul_comm [Group G] [Fintype G] + (c : G → ℂ) + (hc : ∀ g h : G, c (h * g * h⁻¹) = c g) + (y : MonoidAlgebra ℂ G) : + classElem c * y = y * classElem c := by + classical + induction y using MonoidAlgebra.induction_on with + | of m => + refine MonoidAlgebra.coeff_injective ?_ + ext k + change (classElem c * MonoidAlgebra.of ℂ G m).coeff k = + (MonoidAlgebra.of ℂ G m * classElem c).coeff k + rw [show MonoidAlgebra.of ℂ G m = + MonoidAlgebra.single m (1 : ℂ) from rfl] + rw [show (classElem c * MonoidAlgebra.single m (1 : ℂ)).coeff k = + (classElem c).coeff (k * m⁻¹) * 1 from + MonoidAlgebra.coeff_mul_single_apply (classElem c) 1 m k, + show (MonoidAlgebra.single m (1 : ℂ) * classElem c).coeff k = + 1 * (classElem c).coeff (m⁻¹ * k) from + MonoidAlgebra.coeff_single_mul_apply (classElem c) 1 m k] + rw [classElem_coeff, classElem_coeff, mul_one, one_mul] + have := hc (k * m⁻¹) m⁻¹ + rw [show m⁻¹ * (k * m⁻¹) * m⁻¹⁻¹ = m⁻¹ * k from by group] at this + exact this.symm + | add a b ha hb => rw [mul_add, add_mul, ha, hb] + | smul r a ha => rw [mul_smul_comm, smul_mul_assoc, ha] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharClass.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharClass.lean new file mode 100644 index 0000000000..0f0c3dd752 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharClass.lean @@ -0,0 +1,100 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTChar + +/-! +# Class-function properties of the colour and Jacobi–Trudi +characters + +`colourChar α` and `jtChar μ` are invariant under conjugation, and +under inversion (a permutation is conjugate to its inverse, having +the same cycle type). +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv + +variable {n N : ℕ} + +/-- Fibre sizes are invariant under precomposition with a +permutation. -/ +theorem fibreCard_comp_perm (g : Fin n → Fin N) + (τ : Equiv.Perm (Fin n)) (j : Fin N) : + fibreCard (g ∘ τ) j = fibreCard g j := by + rw [fibreCard_eq_count, fibreCard_eq_count, content_comp_perm] + +open scoped Classical in +/-- **The colour character is a class function.** -/ +theorem colourChar_conj (α : Fin N → ℕ) + (π τ : Equiv.Perm (Fin n)) : + colourChar α (τ * π * τ⁻¹) = colourChar α π := by + rw [colourChar, colourChar] + refine Finset.card_bij' + (fun g _ => g ∘ ⇑τ) (fun g _ => g ∘ ⇑τ⁻¹) ?_ ?_ ?_ ?_ + · intro g hg + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + at hg ⊢ + obtain ⟨hcls, hfix⟩ := hg + constructor + · intro j + rw [fibreCard_comp_perm] + exact hcls j + · funext i + have h1 := congrFun hfix (τ i) + simp only [Function.comp_apply, Equiv.Perm.mul_apply, + Equiv.Perm.inv_def, Equiv.symm_apply_apply] at h1 + simp only [Function.comp_apply] + exact h1 + · intro g hg + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + at hg ⊢ + obtain ⟨hcls, hfix⟩ := hg + constructor + · intro j + rw [fibreCard_comp_perm] + exact hcls j + · funext i + have h1 := congrFun hfix (τ⁻¹ i) + simp only [Function.comp_apply] at h1 + simp only [Function.comp_apply, Equiv.Perm.mul_apply, + Equiv.Perm.inv_def, Equiv.symm_apply_apply] + exact h1 + · intro g _ + funext i + simp [Equiv.Perm.inv_def] + · intro g _ + funext i + simp [Equiv.Perm.inv_def] + +open scoped Classical in +/-- The colour character is invariant under inversion. -/ +theorem colourChar_inv (α : Fin N → ℕ) (π : Equiv.Perm (Fin n)) : + colourChar α π⁻¹ = colourChar α π := by + have hconj : IsConj π π⁻¹ := by + rw [Equiv.Perm.isConj_iff_cycleType_eq] + exact (Equiv.Perm.cycleType_inv π).symm + obtain ⟨τ, hτ⟩ := isConj_iff.mp hconj + rw [← hτ, colourChar_conj] + +open scoped Classical in +/-- The Jacobi–Trudi character is invariant under inversion. -/ +theorem jtChar_inv (μ : YoungDiagram) + (π : Equiv.Perm (Fin μ.card)) : + jtChar μ π⁻¹ = jtChar μ π := by + rw [jtChar, jtChar] + refine Finset.sum_congr rfl fun σ _ => ?_ + congr 1 + by_cases hp : ∀ i, 0 ≤ jtSigned μ σ i + · rw [ite_eq_left hp, ite_eq_left hp, colourChar_inv] + · rw [ite_eq_right hp, ite_eq_right hp] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharDecomp.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharDecomp.lean new file mode 100644 index 0000000000..44f2d8618d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharDecomp.lean @@ -0,0 +1,230 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharEquiv +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SimpleEmbed + +/-! +# Character decomposition into native characters + +Every character of a finite-dimensional representation over ℂ +decomposes as a sum of native characters `nChar S g` for simple +submodules `S` of the regular module. +-/ + +@[expose] public section + +namespace RS + +open Finset LinearMap DirectSum + +variable {G : Type*} + +section Aux + +/-- `ρ g` preserves every `MonoidAlgebra ℂ G`-submodule of `ρ.asModule`. -/ +private theorem rho_mem_of_mem + [Group G] {V : Type*} [AddCommGroup V] [Module ℂ V] + (ρ : Representation ℂ G V) + (U : Submodule (MonoidAlgebra ℂ G) ρ.asModule) (g : G) + {v : ρ.asModule} (hv : v ∈ U) : ρ g v ∈ U := by + have key : (MonoidAlgebra.single g (1 : ℂ)) • v ∈ U := U.smul_mem _ hv + have heq : MonoidAlgebra.single g (1 : ℂ) • v = ρ g v := by + rw [Representation.single_smul, one_smul]; rfl + rw [← heq]; exact key + +/-- The representation on a `MonoidAlgebra ℂ G`-submodule of `ρ.asModule`, +using the restrictScalars carrier. -/ +private noncomputable def rhoSub + [Group G] {V : Type*} [AddCommGroup V] [Module ℂ V] + (ρ : Representation ℂ G V) + (U : Submodule (MonoidAlgebra ℂ G) ρ.asModule) : + Representation ℂ G ↥(U.restrictScalars ℂ) := + Representation.ofModule' (k := ℂ) (G := G) ↥(U.restrictScalars ℂ) + +/-- The algebra action of `rhoSub` is scalar multiplication. -/ +private theorem rhoSub_asAlgebraHom_apply + [Group G] {V : Type*} [AddCommGroup V] [Module ℂ V] + (ρ : Representation ℂ G V) + (U : Submodule (MonoidAlgebra ℂ G) ρ.asModule) + (y : MonoidAlgebra ℂ G) (m : ↥(U.restrictScalars ℂ)) : + (rhoSub ρ U).asAlgebraHom y m = y • m := by + rw [rhoSub, Representation.asAlgebraHom_def, Representation.ofModule'] + rw [Equiv.apply_symm_apply] + rfl + +/-- The `rhoSub` action at `g` coerces to `ρ g` on the ambient module. -/ +private theorem rhoSub_val_eq + [Group G] {V : Type*} [AddCommGroup V] [Module ℂ V] + (ρ : Representation ℂ G V) + (U : Submodule (MonoidAlgebra ℂ G) ρ.asModule) + (g : G) (m : ↥(U.restrictScalars ℂ)) : + (rhoSub ρ U g m : ρ.asModule) = ρ g (m : ρ.asModule) := by + have h1 : rhoSub ρ U g m = (MonoidAlgebra.single g (1 : ℂ)) • m := by + have h := rhoSub_asAlgebraHom_apply ρ U (MonoidAlgebra.single g 1) m + rw [Representation.asAlgebraHom_single, one_smul] at h + exact h + rw [h1] + change (MonoidAlgebra.single g (1 : ℂ)) • (m : ρ.asModule) = ρ g (m : + ρ.asModule) + rw [Representation.single_smul, one_smul]; rfl + +end Aux + +section Main + +private theorem character_zero_of_finrank_zero {G : Type*} [Group G] + {V : Type*} [AddCommGroup V] [Module ℂ V] [FiniteDimensional ℂ V] + (ρ : Representation ℂ G V) (hd : Module.finrank ℂ V = 0) (g : G) : + ρ.character g = 0 := by + have hall : ∀ x : V, x = 0 := finrank_zero_iff_forall_zero.mp hd + change (trace ℂ V) (ρ g) = 0 + rw [show (ρ g : V →ₗ[ℂ] V) = 0 from by ext v; exact hall _] + exact map_zero _ + +private theorem character_eq_sum_nChar_aux {G : Type*} [Group G] [Finite G] : + ∀ (n : ℕ) {V : Type*} [AddCommGroup V] [Module ℂ V] [FiniteDimensional ℂ V] + (ρ : Representation ℂ G V), + Module.finrank ℂ V ≤ n → + ∃ (m : ℕ) (S : Fin m → Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)), + (∀ i, IsSimpleModule (MonoidAlgebra ℂ G) (S i)) ∧ + ∀ g : G, ρ.character g = ∑ i, nChar (S i) g := by + classical + let := Fintype.ofFinite G + intro n + induction n with + | zero => + intro V _ _ _ ρ hn + exact ⟨0, Fin.elim0, fun i => i.elim0, fun g => by + rw [character_zero_of_finrank_zero ρ (Nat.le_zero.mp hn) g]; simp⟩ + | succ n ih => + intro V inst1 inst2 inst3 ρ hn + by_cases htriv : Module.finrank ℂ V = 0 + · exact ⟨0, Fin.elim0, fun i => i.elim0, fun g => by + rw [character_zero_of_finrank_zero ρ htriv g]; simp⟩ + · have hfpos : 0 < Module.finrank ℂ V := Nat.pos_of_ne_zero htriv + have hnt : Nontrivial V := Module.nontrivial_of_finrank_pos hfpos + have : Nontrivial ρ.asModule := hnt + have : NeZero ((Nat.card G : ℂ)) := ⟨by + rw [Nat.card_eq_fintype_card] + exact_mod_cast Fintype.card_ne_zero⟩ + have : IsSemisimpleRing (MonoidAlgebra ℂ G) := inferInstance + have : IsSemisimpleModule (MonoidAlgebra ℂ G) ρ.asModule := + IsSemisimpleRing.isSemisimpleModule + obtain ⟨T, hTsimp⟩ := + IsSemisimpleModule.exists_simple_submodule (MonoidAlgebra ℂ G) + ρ.asModule + obtain ⟨W, hTW⟩ := exists_isCompl T + have : Nontrivial (↥T) := IsSimpleModule.nontrivial (MonoidAlgebra ℂ G) T + have hTpos : 0 < Module.finrank ℂ ↥(T.restrictScalars ℂ) := by + have : Nontrivial ↥(T.restrictScalars ℂ) := inferInstanceAs + (Nontrivial ↥T) + exact Module.finrank_pos + have hTW_C : IsCompl (T.restrictScalars ℂ : Submodule ℂ ρ.asModule) + (W.restrictScalars ℂ) := + (Submodule.isCompl_restrictScalars_iff ℂ).mpr hTW + have hWfin : Module.finrank ℂ ↥(W.restrictScalars ℂ) ≤ n := by + have h1 := Submodule.finrank_add_eq_of_isCompl hTW_C + change Module.finrank ℂ ↥(T.restrictScalars ℂ) + + Module.finrank ℂ ↥(W.restrictScalars ℂ) = + Module.finrank ℂ V at h1 + omega + let ρW := rhoSub ρ W + obtain ⟨m', S', hS'simp, hS'char⟩ := @ih ↥(W.restrictScalars ℂ) _ _ _ ρW + hWfin + let ρT := rhoSub ρ T + obtain ⟨S₀, hS₀simp, ⟨eTS⟩⟩ := + exists_simple_submodule_linearEquiv (↥T) hTsimp + -- Character of ρT = nChar S₀ + have hcharT : ∀ g : G, ρT.character g = nChar S₀ g := by + intro g + apply character_of_equiv + refine Representation.Equiv.mk (eTS.symm.restrictScalars ℂ) (fun g + => ?_) + apply LinearMap.ext; intro ⟨v, hv⟩ + simp only [comp_apply] + -- Both ρT and rhoS act by single g 1 •, and eTS.symm is + -- MonoidAlgebra-linear + change eTS.symm (ρT g ⟨v, hv⟩) = rhoS S₀ g (eTS.symm ⟨v, hv⟩) + have h1 : ρT g ⟨v, hv⟩ = (MonoidAlgebra.single g (1 : ℂ)) • + (⟨v, hv⟩ : ↥(T.restrictScalars ℂ)) := by + change (rhoSub ρ T) g ⟨v, hv⟩ = _ + have h := rhoSub_asAlgebraHom_apply ρ T (MonoidAlgebra.single g 1) + ⟨v, hv⟩ + rw [Representation.asAlgebraHom_single, one_smul] at h + exact h + have h2 : rhoS S₀ g (eTS.symm ⟨v, hv⟩) = + (MonoidAlgebra.single g (1 : ℂ)) • eTS.symm ⟨v, hv⟩ := + rhoS_apply S₀ g _ + erw [h1, map_smul, h2] + rfl + -- Character additivity via trace decomposition + have hchar_split : ∀ g : G, + ρ.character g = ρT.character g + ρW.character g := by + intro g + -- Cast ρ g to an endomorphism of ρ.asModule for type compatibility + let f : ρ.asModule →ₗ[ℂ] ρ.asModule := ρ g + -- Bool-indexed decomposition: true ↦ T, false ↦ W + let N : Bool → Submodule ℂ ρ.asModule := fun b => + bif b then T.restrictScalars ℂ else W.restrictScalars ℂ + have hInt : IsInternal N := + (isInternal_submodule_iff_isCompl N (i := true) (j := false) + (by decide) + (by ext x; cases x <;> simp [Set.mem_insert_iff])).mpr hTW_C + have hMaps : ∀ i, Set.MapsTo f ↑(N i) ↑(N i) := by + intro i; cases i <;> dsimp only [N, f, cond] + · exact fun _ hv => rho_mem_of_mem ρ W g hv + · exact fun _ hv => rho_mem_of_mem ρ T g hv + have htrace := trace_eq_sum_trace_restrict hInt hMaps + -- ρ.character g = trace ℂ V (ρ g) = trace ℂ ρ.asModule f + change (trace ℂ V) (ρ g) = (trace ℂ _) (ρT g) + (trace ℂ _) (ρW g) + change (trace ℂ ρ.asModule) f = _ + rw [htrace, Fintype.sum_bool] + -- After sum_bool: trace on N true + trace on N false = ρT + ρW + -- N true = T.restrictScalars ℂ, N false = W.restrictScalars ℂ + congr 1 + · -- trace on N true (= T) = ρT.character g + change (trace ℂ ↥(T.restrictScalars ℂ)) (f.restrict (hMaps true)) = + (trace ℂ _) (ρT g) + congr 1 + ext ⟨v, hv⟩ : 1 + apply Subtype.ext + exact (rhoSub_val_eq ρ T g ⟨v, hv⟩).symm + · -- trace on N false (= W) = ρW.character g + change (trace ℂ ↥(W.restrictScalars ℂ)) (f.restrict (hMaps false)) = + (trace ℂ _) (ρW g) + congr 1 + ext ⟨v, hv⟩ : 1 + apply Subtype.ext + exact (rhoSub_val_eq ρ W g ⟨v, hv⟩).symm + -- Assemble final result + refine ⟨m' + 1, Fin.cons S₀ S', ?_, ?_⟩ + · intro ⟨i, hi⟩ + cases i with + | zero => exact hS₀simp + | succ j => exact hS'simp ⟨j, Nat.lt_of_succ_lt_succ hi⟩ + · intro g + rw [hchar_split g, hcharT g, hS'char g, Fin.sum_univ_succ] + simp [Fin.cons_zero, Fin.cons_succ] + +/-- **Every character decomposes** into native characters of simple +submodules of the regular module. -/ +theorem character_eq_sum_nChar {G : Type*} [Group G] [Finite G] + {V : Type*} [AddCommGroup V] [Module ℂ V] + [FiniteDimensional ℂ V] (ρ : Representation ℂ G V) : + ∃ (m : ℕ) (S : Fin m → Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)), + (∀ i, IsSimpleModule (MonoidAlgebra ℂ G) (S i)) ∧ + ∀ g : G, ρ.character g = ∑ i, nChar (S i) g := by + classical + let := Fintype.ofFinite G + exact + character_eq_sum_nChar_aux (Module.finrank ℂ V) ρ le_rfl + +end Main + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharEquiv.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharEquiv.lean new file mode 100644 index 0000000000..0ddba300d7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharEquiv.lean @@ -0,0 +1,48 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeTable + +/-! +# Character invariance under representation equivalence + +The character of a representation is invariant under equivalence: +two equivalent representations have the same character at every +group element. The corollary specialises this to the native +submodule representations `rhoS`. +-/ + +@[expose] public section + +namespace RS + +open Finset LinearMap + +variable {G : Type*} + +/-- Equivalent representations have the same character. -/ +theorem character_of_equiv [Group G] + {V W : Type*} + [AddCommGroup V] [Module ℂ V] [AddCommGroup W] [Module ℂ W] + {ρ : Representation ℂ G V} {σ : Representation ℂ G W} + (e : ρ.Equiv σ) (g : G) : + ρ.character g = σ.character g := + congr_fun (Representation.char_iso e) g + +/-- Equivalent native representations have the same native +character. -/ +theorem nChar_of_equiv [Group G] [Finite G] + {S T : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)} + (e : (rhoS S).Equiv (rhoS T)) (g : G) : + nChar S g = nChar T g := by + classical + let := Fintype.ofFinite G + unfold nChar + exact character_of_equiv e g + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ColourCycleSum.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ColourCycleSum.lean new file mode 100644 index 0000000000..9fd5a5c03c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ColourCycleSum.lean @@ -0,0 +1,49 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharClass +public import LeanPool.RegtsSevenster.RS.Common.PermCongr +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SigmaCycleType + +/-! +# Discharge of the cycle-type transport hypotheses + +`cycleType_permCongr` and `cycleType_sigmaCongrRight` discharge +the `PermCongrCT` and `SigmaCT` hypotheses: the colour cycle sum +and the Frobenius formula for the Jacobi–Trudi character hold +unconditionally. +-/ + +@[expose] public section + +namespace RS + +open Finset + +/-- Transport preserves cycle type, discharging the colour cycle +sum's hypothesis. -/ +theorem permCongrCT : PermCongrCT := + fun _ _ _ _ _ _ e σ => cycleType_permCongr e σ + +/-- And so does the fibrewise congruence, discharging the Frobenius +formula's. -/ +theorem sigmaCT : SigmaCT := + fun _ _ _ _ _ _ σ => cycleType_sigmaCongrRight σ + +open scoped Classical in +/-- **The Frobenius formula for the Jacobi–Trudi character**, +unconditionally: its normalized cycle-weighted sum is the +Jacobi–Trudi determinant. -/ +theorem jtChar_frobenius' (μ : YoungDiagram) (t : ℕ → ℂ) : + ((μ.card.factorial : ℂ))⁻¹ * + ∑ π : Equiv.Perm (Fin μ.card), + jtChar μ π * cycleProd t π = + diagramSchur μ t := + jtChar_frobenius permCongrCT sigmaCT μ t + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ColourWeight.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ColourWeight.lean new file mode 100644 index 0000000000..dcd061ee0f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ColourWeight.lean @@ -0,0 +1,153 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ContentCount +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.StabCount + +/-! +# Colour classes of prescribed composition + +Colourings `Fin n → Fin N` with prescribed fibre sizes +`α : Fin N → ℕ`: the class count (`n!` divided by the fibre +factorials, in product form), the fixed-colouring permutation +character `colourChar`, and the Fubini exchange expressing its +weighted permutation sum as a sum of stabilizer weights over the +class. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {n N : ℕ} + +/-- The content multiset of a composition. -/ +def compContent (α : Fin N → ℕ) : Multiset (Fin N) := + ∑ j : Fin N, Multiset.replicate (α j) j + +/-- A composition's content multiset carries each colour as often as +prescribed. -/ +theorem compContent_count (α : Fin N → ℕ) (j : Fin N) : + (compContent α).count j = α j := by + classical + rw [compContent, Multiset.count_sum'] + rw [Finset.sum_eq_single j + (fun b _ hb => by + rw [Multiset.count_replicate, ite_eq_right hb]) + (fun h => absurd (Finset.mem_univ j) h)] + rw [Multiset.count_replicate, ite_eq_left rfl] + +/-- Its size is the composition's total. -/ +theorem compContent_card (α : Fin N → ℕ) : + Multiset.card (compContent α) = ∑ j : Fin N, α j := by + rw [compContent] + simp [Multiset.card_replicate] + +/-- The composition content as a symmetric power, given total +`n`. -/ +def compContentSym (α : Fin N → ℕ) (hsum : ∑ j : Fin N, α j = n) : + Sym (Fin N) n := + ⟨compContent α, by rw [compContent_card, hsum]⟩ + +/-- A colouring has fibre sizes `α` iff its content is +`compContent α`. -/ +theorem fibreCard_eq_iff (g : Fin n → Fin N) (α : Fin N → ℕ) : + (∀ j, fibreCard g j = α j) ↔ (content g).1 = compContent α := by + constructor + · intro h + refine Multiset.ext.mpr fun j => ?_ + rw [← fibreCard_eq_count, compContent_count, h j] + · intro h j + rw [fibreCard_eq_count, h, compContent_count] + +/-- **The colour-class count**: the number of colourings with +fibre sizes `α` times the product of the fibre factorials is +`n!`. -/ +theorem card_colourClass (α : Fin N → ℕ) + (hsum : ∑ j : Fin N, α j = n) : + Fintype.card {g : Fin n → Fin N // ∀ j, fibreCard g j = α j} * + ∏ j : Fin N, (α j).factorial = n.factorial := by + classical + obtain ⟨f₀, hf₀⟩ := exists_content_eq (compContentSym α hsum) + have h := orbit_stab f₀ (card_fixing_perms f₀) + have hval : (content f₀).1 = compContent α := by + rw [hf₀]; rfl + have hcount : ∀ j : Fin N, (content f₀).1.count j = α j := by + intro j + rw [hval, compContent_count] + have hequiv : + Fintype.card {g : Fin n → Fin N // content g = content f₀} = + Fintype.card + {g : Fin n → Fin N // ∀ j, fibreCard g j = α j} := by + apply Fintype.card_congr + apply Equiv.subtypeEquivRight + intro g + constructor + · intro hc + refine (fibreCard_eq_iff g α).mpr ?_ + rw [congrArg Subtype.val hc, hval] + · intro hc + apply Subtype.ext + rw [(fibreCard_eq_iff g α).mp hc, hval] + rw [hequiv] at h + rw [Finset.prod_congr rfl (fun j _ => by rw [hcount j])] at h + exact h + +open scoped Classical in +/-- The permutation character of the colour class `α`: the number +of colourings with fibre sizes `α` fixed by `π`. -/ +noncomputable def colourChar (α : Fin N → ℕ) + (π : Equiv.Perm (Fin n)) : ℕ := + (Finset.univ.filter + (fun g : Fin n → Fin N => + (∀ j, fibreCard g j = α j) ∧ g ∘ π = g)).card + +open scoped Classical in +/-- **Fubini for the colour character**: the `colourChar`-weighted +permutation sum is the sum, over the colour class, of the +stabilizer weight sums. -/ +theorem sum_colourChar_weight (α : Fin N → ℕ) + (W : Equiv.Perm (Fin n) → ℂ) : + (∑ π : Equiv.Perm (Fin n), (colourChar α π : ℂ) * W π) = + ∑ g : {g : Fin n → Fin N // ∀ j, fibreCard g j = α j}, + ∑ π ∈ Finset.univ.filter + (fun π : Equiv.Perm (Fin n) => g.1 ∘ π = g.1), W π := by + calc (∑ π : Equiv.Perm (Fin n), (colourChar α π : ℂ) * W π) + = ∑ π : Equiv.Perm (Fin n), ∑ g : Fin n → Fin N, + (if (∀ j, fibreCard g j = α j) ∧ g ∘ π = g + then W π else 0) := by + refine Finset.sum_congr rfl fun π _ => ?_ + rw [colourChar, ← Finset.sum_filter, Finset.sum_const, + nsmul_eq_mul] + _ = ∑ g : Fin n → Fin N, ∑ π : Equiv.Perm (Fin n), + (if (∀ j, fibreCard g j = α j) ∧ g ∘ π = g + then W π else 0) := Finset.sum_comm + _ = ∑ g : Fin n → Fin N, + (if (∀ j, fibreCard g j = α j) + then ∑ π ∈ Finset.univ.filter + (fun π : Equiv.Perm (Fin n) => g ∘ π = g), W π + else 0) := by + refine Finset.sum_congr rfl fun g _ => ?_ + by_cases hg : ∀ j, fibreCard g j = α j + · rw [ite_eq_left hg, Finset.sum_filter] + exact Finset.sum_congr rfl fun π _ => by + by_cases hf : g ∘ π = g + · rw [ite_eq_left ⟨hg, hf⟩, ite_eq_left hf] + · rw [ite_eq_right (fun hc => hf hc.2), ite_eq_right hf] + · rw [ite_eq_right hg] + rw [Finset.sum_eq_zero fun π _ => + ite_eq_right (fun hc => hg hc.1)] + _ = ∑ g : {g : Fin n → Fin N // ∀ j, fibreCard g j = α j}, + ∑ π ∈ Finset.univ.filter + (fun π : Equiv.Perm (Fin n) => g.1 ∘ π = g.1), W π := by + rw [← Finset.sum_filter] + exact Finset.sum_subtype _ (fun g => by simp) _ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CommutantBound.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CommutantBound.lean new file mode 100644 index 0000000000..4fc5c32d8a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CommutantBound.lean @@ -0,0 +1,250 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharDecomp +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeFaithful + +/-! +# Dimension bounds through the commutant + +A representation factoring through an algebra of dimension at most +`B ^ 2` has dimension at most `B` times the dimension of its commutant. +Each simple constituent has dimension at most `B`, by native block +faithfulness, and the commutant dimension bounds the number of simple +summands, counted with multiplicity. +-/ + +@[expose] public section + +namespace RS + +open Finset LinearMap Representation + + +noncomputable section + +variable {G V W : Type*} + +private def IsNativeCharacterSum [Group G] + [AddCommGroup V] [Module ℂ V] + (ρ : Representation ℂ G V) {m : ℕ} + (S : Fin m → Submodule (MonoidAlgebra ℂ G) + (MonoidAlgebra ℂ G)) : Prop := + ∀ g, ρ.character g = ∑ i, nChar (S i) g + +private noncomputable instance cardComplexInvertible + [Group G] [Fintype G] : + Invertible (Nat.card G : ℂ) := + invertibleOfNonzero (by + rw [Nat.card_eq_fintype_card] + exact_mod_cast Fintype.card_ne_zero) + +private theorem intertwining_finrank_sum_right + [Group G] [Finite G] + [AddCommGroup V] [Module ℂ V] [FiniteDimensional ℂ V] + [AddCommGroup W] [Module ℂ W] [FiniteDimensional ℂ W] + (ρ : Representation ℂ G V) (τ : Representation ℂ G W) + {m : ℕ} + (S : Fin m → Submodule (MonoidAlgebra ℂ G) + (MonoidAlgebra ℂ G)) + (hchar : IsNativeCharacterSum ρ S) : + Module.finrank ℂ (IntertwiningMap τ ρ) = + ∑ i, Module.finrank ℂ (IntertwiningMap τ (rhoS (S i))) := by + classical + let := Fintype.ofFinite G + dsimp only [IsNativeCharacterSum] at hchar + apply Nat.cast_injective (R := ℂ) + rw [Nat.cast_sum] + simp_rw [← card_inv_mul_sum_char_mul_char_eq_finrank, hchar, + nChar, Finset.sum_mul] + rw [Finset.sum_comm, Finset.mul_sum] + +private theorem intertwining_finrank_sum_left + [Group G] [Finite G] + [AddCommGroup V] [Module ℂ V] [FiniteDimensional ℂ V] + [AddCommGroup W] [Module ℂ W] [FiniteDimensional ℂ W] + (ρ : Representation ℂ G V) (τ : Representation ℂ G W) + {m : ℕ} + (S : Fin m → Submodule (MonoidAlgebra ℂ G) + (MonoidAlgebra ℂ G)) + (hchar : IsNativeCharacterSum ρ S) : + Module.finrank ℂ (IntertwiningMap ρ τ) = + ∑ i, Module.finrank ℂ (IntertwiningMap (rhoS (S i)) τ) := by + classical + let := Fintype.ofFinite G + dsimp only [IsNativeCharacterSum] at hchar + apply Nat.cast_injective (R := ℂ) + rw [Nat.cast_sum] + simp_rw [← card_inv_mul_sum_char_mul_char_eq_finrank, hchar, + nChar, Finset.mul_sum] + rw [Finset.sum_comm] + +private theorem constituent_multiplicity_pos + [Group G] [Finite G] + [AddCommGroup V] [Module ℂ V] [FiniteDimensional ℂ V] + (ρ : Representation ℂ G V) {m : ℕ} + (S : Fin m → Submodule (MonoidAlgebra ℂ G) + (MonoidAlgebra ℂ G)) + (hS : ∀ i, IsSimpleModule (MonoidAlgebra ℂ G) (S i)) + (hchar : IsNativeCharacterSum ρ S) + (i : Fin m) : + 0 < Module.finrank ℂ (IntertwiningMap (rhoS (S i)) ρ) := by + classical + let := Fintype.ofFinite G + rw [intertwining_finrank_sum_right ρ _ S hchar] + have := rhoS_isIrreducible (S i) (hS i) + have hself : Module.finrank ℂ + (IntertwiningMap (rhoS (S i)) (rhoS (S i))) = 1 := by simp + have hle := Finset.single_le_sum + (fun j (_ : j ∈ (Finset.univ : Finset (Fin m))) => + Nat.zero_le (Module.finrank ℂ + (IntertwiningMap (rhoS (S i)) (rhoS (S j))))) + (Finset.mem_univ i) + rw [hself] at hle + exact hle + +private theorem trace_nProjector + [Group G] [Fintype G] + [AddCommGroup V] [Module ℂ V] [FiniteDimensional ℂ V] + (ρ : Representation ℂ G V) + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) : + LinearMap.trace ℂ V (ρ.asAlgebraHom (nProjector S)) = + (nDim S : ℂ) * + Module.finrank ℂ (IntertwiningMap (rhoS S) ρ) := by + rw [nProjector, trace_asAlgebraHom_classElem, + ← card_inv_mul_sum_char_mul_char_eq_finrank] + simp_rw [nCoeff, nChar, div_eq_mul_inv] + rw [Nat.card_eq_fintype_card, ← mul_assoc, Finset.mul_sum] + apply Finset.sum_congr rfl + intro g _ + ring + +open scoped Classical in +/-- A nonzero native block in a finite-dimensional algebra has at +least the square of its simple constituent's dimension. -/ +theorem nDim_sq_le_finrank_of_projector_ne_zero + [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (hS : IsSimpleModule (MonoidAlgebra ℂ G) S) + {A : Type*} [Ring A] [Algebra ℂ A] [FiniteDimensional ℂ A] + (φ : MonoidAlgebra ℂ G →ₐ[ℂ] A) + (hne : φ (nProjector S) ≠ 0) : + nDim S ^ 2 ≤ Module.finrank ℂ A := by + rw [← nProjector_block_rank S hS] + let I := LinearMap.range (LinearMap.mulLeft ℂ (nProjector S)) + have hinj : Function.Injective (φ.toLinearMap.comp I.subtype) := by + rw [← LinearMap.ker_eq_bot, LinearMap.ker_eq_bot'] + rintro ⟨x, hx⟩ hzero + obtain ⟨y, rfl⟩ := hx + have hy : φ (nProjector S * y) = 0 := by + simpa [LinearMap.mulLeft_apply] using hzero + simpa [LinearMap.mulLeft_apply] using + nProjector_block_faithful S hS φ hne y hy + exact LinearMap.finrank_le_finrank_of_injective hinj + +/-- The dimension of a finite-group representation is bounded by +the square root of the dimension of a factoring algebra, times the +dimension of its commutant. -/ +theorem finrank_le_sqrt_mul_commutant + [Group G] [Finite G] + [AddCommGroup V] [Module ℂ V] [FiniteDimensional ℂ V] + (ρ : Representation ℂ G V) + {A : Type*} [Ring A] [Algebra ℂ A] [FiniteDimensional ℂ A] + (φ : MonoidAlgebra ℂ G →ₐ[ℂ] A) + (hker : ∀ x, φ x = 0 → ρ.asAlgebraHom x = 0) : + Module.finrank ℂ V ≤ + Nat.sqrt (Module.finrank ℂ A) * + Module.finrank ℂ (IntertwiningMap ρ ρ) := by + classical + let := Fintype.ofFinite G + obtain ⟨m, S, hS, hchar⟩ := character_eq_sum_nChar ρ + have hdim : Module.finrank ℂ V = ∑ i, nDim (S i) := by + have h := hchar 1 + simp only [nChar, char_one] at h + exact_mod_cast h + let B := Nat.sqrt (Module.finrank ℂ A) + have hsimple : ∀ i, nDim (S i) ≤ B := by + intro i + have hne : φ (nProjector (S i)) ≠ 0 := by + intro hzero + have ht := congrArg (LinearMap.trace ℂ V) (hker _ hzero) + rw [trace_nProjector, map_zero] at ht + have : Nontrivial (subCarrier (S i)) := + (isIrredRep_rhoS (S i) (hS i)).1 + have hd : (nDim (S i) : ℂ) ≠ 0 := + Nat.cast_ne_zero.mpr Module.finrank_pos.ne' + have hm : (Module.finrank ℂ + (IntertwiningMap (rhoS (S i)) ρ) : ℂ) ≠ 0 := + Nat.cast_ne_zero.mpr + (constituent_multiplicity_pos ρ S hS hchar i).ne' + exact (mul_ne_zero hd hm) ht + exact Nat.le_sqrt'.mpr + (nDim_sq_le_finrank_of_projector_ne_zero (S i) (hS i) φ hne) + have hlength : m ≤ Module.finrank ℂ (IntertwiningMap ρ ρ) := by + rw [intertwining_finrank_sum_left ρ ρ S hchar] + simpa using Finset.sum_le_sum (s := Finset.univ) + (fun i _ => show 1 ≤ Module.finrank ℂ + (IntertwiningMap (rhoS (S i)) ρ) from + constituent_multiplicity_pos ρ S hS hchar i) + calc + Module.finrank ℂ V = ∑ i, nDim (S i) := hdim + _ ≤ ∑ _i : Fin m, B := Finset.sum_le_sum fun i _ => hsimple i + _ = B * m := by simp [Nat.mul_comm] + _ ≤ B * Module.finrank ℂ (IntertwiningMap ρ ρ) := + Nat.mul_le_mul_left B hlength + +/-- If a finite-group representation factors through an algebra of +dimension at most `B ^ 2`, its dimension is at most `B` times the +dimension of its commutant. -/ +theorem finrank_le_mul_commutant + [Group G] [Finite G] + [AddCommGroup V] [Module ℂ V] [FiniteDimensional ℂ V] + (ρ : Representation ℂ G V) + {A : Type*} [Ring A] [Algebra ℂ A] [FiniteDimensional ℂ A] + (φ : MonoidAlgebra ℂ G →ₐ[ℂ] A) + (hker : ∀ x, φ x = 0 → ρ.asAlgebraHom x = 0) + (B : ℕ) (hB : Module.finrank ℂ A ≤ B ^ 2) : + Module.finrank ℂ V ≤ + B * Module.finrank ℂ (IntertwiningMap ρ ρ) := by + classical + let := Fintype.ofFinite G + have hsqrt : Nat.sqrt (Module.finrank ℂ A) ≤ B := by + have := Nat.sqrt_le' (Module.finrank ℂ A) + nlinarith + exact (finrank_le_sqrt_mul_commutant ρ φ hker).trans + (Nat.mul_le_mul_right _ hsqrt) + +/-- The square of the representation dimension is at most the +factoring algebra dimension times the square of the commutant +dimension. -/ +theorem finrank_sq_le_mul_commutant_sq + [Group G] [Finite G] + [AddCommGroup V] [Module ℂ V] [FiniteDimensional ℂ V] + (ρ : Representation ℂ G V) + {A : Type*} [Ring A] [Algebra ℂ A] [FiniteDimensional ℂ A] + (φ : MonoidAlgebra ℂ G →ₐ[ℂ] A) + (hker : ∀ x, φ x = 0 → ρ.asAlgebraHom x = 0) : + Module.finrank ℂ V ^ 2 ≤ Module.finrank ℂ A * + Module.finrank ℂ (IntertwiningMap ρ ρ) ^ 2 := by + classical + let := Fintype.ofFinite G + have h := finrank_le_sqrt_mul_commutant ρ φ hker + calc + Module.finrank ℂ V ^ 2 ≤ + (Nat.sqrt (Module.finrank ℂ A) * + Module.finrank ℂ (IntertwiningMap ρ ρ)) ^ 2 := by + exact Nat.pow_le_pow_left h 2 + _ = Nat.sqrt (Module.finrank ℂ A) ^ 2 * + Module.finrank ℂ (IntertwiningMap ρ ρ) ^ 2 := mul_pow _ _ _ + _ ≤ Module.finrank ℂ A * + Module.finrank ℂ (IntertwiningMap ρ ρ) ^ 2 := + Nat.mul_le_mul_right _ (Nat.sqrt_le' _) + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ContentCount.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ContentCount.lean new file mode 100644 index 0000000000..6d10ba8996 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ContentCount.lean @@ -0,0 +1,251 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FibreCard + +/-! +# Content-grouped counting identity + +The identity + ∑ f, (∏ j, (fibreCard f j)!) · ∏ i, x (f i) = n! · hVal x n +groups the sum over colourings `f : Fin n → Fin N` by content multiset +and uses an orbit-stabilizer argument. The stabiliser count enters as +a hypothesis, discharged as `card_fixing_perms` in `StabCount.lean`. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {n N : ℕ} + +/-! ### Basic helpers -/ + +/-- The weight of a colouring depends only on its content. -/ +theorem prod_eq_content_prod (f : Fin n → Fin N) (x : Fin N → ℂ) : + ∏ i : Fin n, x (f i) = ((content f).1.map x).prod := by + change (Finset.univ.val.map (x ∘ f)).prod = ((Finset.univ.val.map f).map x).prod + rw [Multiset.map_map] + +/-- The fibre-factorial product equals the count-factorial product. -/ +theorem fibreFactorial_eq_count_factorial (f : Fin n → Fin N) : + ∏ j : Fin N, (fibreCard f j).factorial = + ∏ j : Fin N, ((content f).1.count j).factorial := + Finset.prod_congr rfl fun j _ => by rw [fibreCard_eq_count] + +/-- Mapping `univ.val` by a permutation gives `univ.val`. -/ +private theorem perm_map_univ_val (σ : Equiv.Perm (Fin n)) : + Finset.univ.val.map σ = Finset.univ.val := by + have : Finset.univ.map σ.toEmbedding = Finset.univ := + Finset.map_univ_equiv σ + exact_mod_cast congr_arg Finset.val this + +/-- Precomposing by a permutation preserves content. -/ +theorem content_comp_perm (f : Fin n → Fin N) (σ : Equiv.Perm (Fin n)) : + content (f ∘ σ) = content f := by + unfold content; refine Subtype.ext ?_ + change Finset.univ.val.map (f ∘ ⇑σ) = Finset.univ.val.map f + conv_lhs => rw [show (f ∘ ⇑σ) = f ∘ ⇑σ from rfl] + rw [← Multiset.map_map f σ, perm_map_univ_val] + +/-! ### Transitivity of the content-class action -/ + +/-- Two monotone tuples with the same content are equal. -/ +private theorem monotone_eq_of_content_eq {h₁ h₂ : Fin n → Fin N} + (hm₁ : Monotone h₁) (hm₂ : Monotone h₂) + (hc : content h₁ = content h₂) : h₁ = h₂ := by + apply List.ofFn_injective + apply List.Perm.eq_of_sortedLE hm₁.sortedLE_ofFn hm₂.sortedLE_ofFn + rw [← Multiset.coe_eq_coe] + show (↑(List.ofFn h₁) : Multiset (Fin N)) = ↑(List.ofFn h₂) + rw [← Fin.univ_val_map h₁, ← Fin.univ_val_map h₂] + exact congrArg Subtype.val hc + +/-- If two colourings have the same content, some permutation maps +one to the other. -/ +theorem content_eq_exists_perm (f g : Fin n → Fin N) + (h : content f = content g) : + ∃ σ : Equiv.Perm (Fin n), f ∘ σ = g := by + have hsf := Tuple.monotone_sort f + have hsg := Tuple.monotone_sort g + have heq : f ∘ ⇑(Tuple.sort f) = g ∘ ⇑(Tuple.sort g) := + monotone_eq_of_content_eq hsf hsg + ((content_comp_perm f _).trans (h.trans (content_comp_perm g _).symm)) + refine ⟨Tuple.sort f * (Tuple.sort g)⁻¹, funext fun i => ?_⟩ + change f ((Tuple.sort f) ((Tuple.sort g)⁻¹ i)) = g i + have := congrFun heq ((Tuple.sort g).symm i) + simp only [Function.comp_apply, Equiv.apply_symm_apply] at this + exact this + +/-! ### Existence of colourings with prescribed content -/ + +/-- Every `s : Sym (Fin N) n` is the content of some colouring. -/ +theorem exists_content_eq (s : Sym (Fin N) n) : + ∃ f : Fin n → Fin N, content f = s := by + classical + have hlen : s.1.toList.length = n := by + rw [Multiset.length_toList]; exact s.2 + refine ⟨fun i => s.1.toList.get ⟨i.1, by omega⟩, Subtype.ext ?_⟩ + rw [show (content (fun i : Fin n => s.1.toList.get ⟨i.1, by omega⟩)).1 = + Finset.univ.val.map (fun i : Fin n => s.1.toList.get ⟨i.1, by omega⟩) + from rfl] + rw [Fin.univ_val_map] + rw [show (List.ofFn fun i : Fin n => + s.1.toList.get ⟨↑i, by omega⟩) = s.1.toList from by + apply List.ext_get + · simp + · intro i hi₁ hi₂ + simp] + exact Multiset.coe_toList s.1 + +/-! ### Coset counting -/ + +/-- The fibre of `σ ↦ f ∘ σ` over `g` bijects with the stabilizer +when `g` is in the orbit. -/ +private theorem card_fibre_eq_stab (f g : Fin n → Fin N) + (σ₀ : Equiv.Perm (Fin n)) (hσ₀ : f ∘ σ₀ = g) : + (univ.filter (fun σ : Equiv.Perm (Fin n) => f ∘ σ = g)).card = + (univ.filter (fun σ : Equiv.Perm (Fin n) => f ∘ σ = f)).card := by + classical + refine Finset.card_bij' + (fun σ _ => σ * σ₀⁻¹) (fun τ _ => τ * σ₀) ?_ ?_ ?_ ?_ + · -- forward: f ∘ σ = g → f ∘ (σ * σ₀⁻¹) = f + intro σ hσ + simp only [mem_filter, mem_univ, true_and] at hσ ⊢ + ext i + simp only [Function.comp_apply, Equiv.Perm.mul_apply, Equiv.Perm.inv_def] + have h1 : ∀ j, f (σ j) = g j := congrFun hσ + have h2 : ∀ j, f (σ₀ j) = g j := congrFun hσ₀ + rw [h1, ← h2, Equiv.apply_symm_apply] + · -- backward: f ∘ τ = f → f ∘ (τ * σ₀) = g + intro τ hτ + simp only [mem_filter, mem_univ, true_and] at hτ ⊢ + ext i + simp only [Function.comp_apply, Equiv.Perm.mul_apply] + have h1 : ∀ j, f (τ j) = f j := congrFun hτ + have h2 : ∀ j, f (σ₀ j) = g j := congrFun hσ₀ + rw [h1, h2] + · intro σ _; simp [mul_assoc] + · intro τ _; simp [mul_assoc] + +/-- The fibre of `σ ↦ f ∘ σ` over `g` is empty when `g` is NOT +in the orbit. -/ +private theorem card_fibre_eq_zero (f g : Fin n → Fin N) + (h : ¬∃ σ : Equiv.Perm (Fin n), f ∘ σ = g) : + (univ.filter (fun σ : Equiv.Perm (Fin n) => f ∘ σ = g)).card = 0 := by + rw [Finset.card_eq_zero, Finset.filter_eq_empty_iff] + exact fun σ _ hfσ => h ⟨σ, hfσ⟩ + +/-! ### The orbit-stabilizer identity -/ + +/-- Orbit-stabilizer: class size times stabilizer size equals `n!`. -/ +theorem orbit_stab (f₀ : Fin n → Fin N) + (hstab₀ : (univ.filter (fun σ : Equiv.Perm (Fin n) => f₀ ∘ σ = f₀)).card = + ∏ j : Fin N, (fibreCard f₀ j).factorial) : + Fintype.card {g : Fin n → Fin N // content g = content f₀} * + (∏ j : Fin N, ((content f₀).1.count j).factorial) = n.factorial := by + classical + have hperm : Fintype.card (Equiv.Perm (Fin n)) = n.factorial := + Fintype.card_perm.trans (by rw [Fintype.card_fin]) + -- Sum fiberwise: n! = ∑_g card{σ ∈ univ | f₀ ∘ σ = g} + have hfib' : n.factorial = + ∑ g : Fin n → Fin N, + (univ.filter (fun σ : Equiv.Perm (Fin n) => f₀ ∘ σ = g)).card := by + rw [← hperm] + exact Finset.card_eq_sum_card_fiberwise (fun _ _ => mem_univ _) + -- Each fibre depends on whether g is in the orbit + have hfibre_val : ∀ g : Fin n → Fin N, + (univ.filter (fun σ : Equiv.Perm (Fin n) => f₀ ∘ σ = g)).card = + if content g = content f₀ + then (univ.filter (fun σ : Equiv.Perm (Fin n) => f₀ ∘ σ = f₀)).card + else 0 := by + intro g + split + case isTrue hc => + obtain ⟨σ₀, hσ₀⟩ := content_eq_exists_perm f₀ g hc.symm + exact card_fibre_eq_stab f₀ g σ₀ hσ₀ + case isFalse hc => + apply card_fibre_eq_zero + rintro ⟨σ, hσ⟩ + exact hc (show content g = content f₀ from hσ ▸ content_comp_perm f₀ σ) + -- Simplify + rw [Finset.sum_congr rfl (fun g _ => hfibre_val g)] at hfib' + simp only [Finset.sum_ite, Finset.sum_const_zero, add_zero, + Finset.sum_const, smul_eq_mul] at hfib' + rw [show (Finset.univ.filter (fun g : Fin n → Fin N => + content g = content f₀)).card = + Fintype.card {g : Fin n → Fin N // content g = content f₀} from + (Fintype.card_subtype _).symm] at hfib' + rw [hstab₀, fibreFactorial_eq_count_factorial] at hfib' + exact hfib'.symm + +/-! ### Main theorem -/ + +/-- **The content-grouped count**: weighting each colouring by its +stabiliser size and its colour product sums to the factorial times +the complete homogeneous value. -/ +theorem sum_fibreFactorial_weight' {n N : ℕ} (x : Fin N → ℂ) + (hstab : ∀ f : Fin n → Fin N, + (Finset.univ.filter + (fun π : Equiv.Perm (Fin n) => f ∘ π = f)).card = + ∏ j : Fin N, (fibreCard f j).factorial) : + ∑ f : Fin n → Fin N, + ((∏ j : Fin N, (fibreCard f j).factorial : ℕ) : ℂ) * + ∏ i, x (f i) = + (n.factorial : ℂ) * hVal x n := by + classical + -- Step 1: Group by content + rw [show (∑ f : Fin n → Fin N, + ((∏ j : Fin N, (fibreCard f j).factorial : ℕ) : ℂ) * + ∏ i, x (f i)) = + ∑ s : Sym (Fin N) n, ∑ f : {f // content f = s}, + ((∏ j : Fin N, (fibreCard f.1 j).factorial : ℕ) : ℂ) * + ∏ i, x (f.1 i) from + (Fintype.sum_fiberwise content _).symm] + -- Step 2: Within each class, the summand is constant + have hinner : ∀ s : Sym (Fin N) n, + (∑ f : {f // content f = s}, + ((∏ j : Fin N, (fibreCard f.1 j).factorial : ℕ) : ℂ) * + ∏ i, x (f.1 i)) = + ↑(Fintype.card {f // content f = s}) * + ((∏ j : Fin N, (s.1.count j).factorial : ℕ) : ℂ) * + ((s.1.map x).prod) := by + intro s + have hsummand : ∀ (f : {f // content f = s}), + ((∏ j : Fin N, (fibreCard f.1 j).factorial : ℕ) : ℂ) * + ∏ i, x (f.1 i) = + ((∏ j : Fin N, (s.1.count j).factorial : ℕ) : ℂ) * + (s.1.map x).prod := by + rintro ⟨f, hf⟩ + change ((∏ j : Fin N, (fibreCard f j).factorial : ℕ) : ℂ) * + ∏ i, x (f i) = _ + rw [show (∏ j : Fin N, (fibreCard f j).factorial : ℕ) = + (∏ j : Fin N, (s.1.count j).factorial : ℕ) from by + rw [fibreFactorial_eq_count_factorial, hf]] + rw [show (∏ i : Fin n, x (f i)) = (s.1.map x).prod from by + rw [prod_eq_content_prod, hf]] + simp_rw [hsummand] + rw [Finset.sum_const, Finset.card_univ, nsmul_eq_mul, mul_assoc] + rw [Finset.sum_congr rfl (fun s _ => hinner s)] + -- Step 3: Use orbit-stabilizer + have horbstab : ∀ s : Sym (Fin N) n, + ↑(Fintype.card {f // content f = s}) * + ((∏ j : Fin N, (s.1.count j).factorial : ℕ) : ℂ) = + (n.factorial : ℂ) := by + intro s + obtain ⟨f₀, hf₀⟩ := exists_content_eq s + have h := orbit_stab f₀ (hstab f₀) + rw [hf₀] at h + exact_mod_cast h + rw [Finset.sum_congr rfl (fun s _ => by rw [horbstab s])] + -- Step 4: Factor out n! + rw [← Finset.mul_sum, hVal] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleFactor.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleFactor.lean new file mode 100644 index 0000000000..9373d9a82b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleFactor.lean @@ -0,0 +1,69 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SameCycleQuot + +/-! +# The orbit factorization of a fixed-colouring sum + +For a permutation `π` of `Fin n`, the sum of colouring weights +over the colourings fixed by `π` factorizes over the orbit space: +each orbit is coloured uniformly, contributing a power sum in its +size. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv Equiv.Perm + +/-- The completed cycle-type product of a prospective power-sum +sequence: the product over the full cycle type, fixed points +included. -/ +noncomputable def cycleProd (t : ℕ → ℂ) {n : ℕ} + (π : Equiv.Perm (Fin n)) : ℂ := + (π.cycleType.map t).prod * t 1 ^ (n - π.cycleType.sum) + +variable {n N : ℕ} + +/-- **The orbit factorization**: the fixed-colouring weight sum of +a permutation is the product of the power sums of its orbit +sizes. -/ +theorem sum_fixedFun_eq_prod_orbits (x : Fin N → ℂ) + (π : Equiv.Perm (Fin n)) : + (∑ f : {f : Fin n → Fin N // f ∘ π = f}, ∏ i, x (f.1 i)) = + ∏ O : OrbitSpace π, pVal x (orbCard π O) := by + classical + rw [Fintype.sum_equiv (fixedFunEquiv π (Fin N)) + (fun f => ∏ i, x (f.1 i)) + (fun g => ∏ O, x (g O) ^ orbCard π O) ?_] + · -- the coloured-orbit sum is the product of power sums + rw [show (∏ O : OrbitSpace π, pVal x (orbCard π O)) = + ∏ O : OrbitSpace π, ∑ j ∈ (Finset.univ : Finset (Fin N)), + x j ^ orbCard π O from Finset.prod_congr rfl fun O _ => rfl] + rw [Finset.prod_univ_sum] + rw [Fintype.piFinset_univ] + · -- pointwise: group the weight product by orbits + intro f + rw [← Finset.prod_fiberwise_of_maps_to + (g := orbitOf π) (t := (Finset.univ : Finset (OrbitSpace π))) + (fun i _ => Finset.mem_univ _) (fun i => x (f.1 i))] + refine Finset.prod_congr rfl fun O _ => ?_ + have hfib : Finset.univ.filter (fun i => orbitOf π i = O) = + orbFibre π O := by + rw [orbFibre] + rw [hfib] + rw [Finset.prod_congr rfl (fun i hi => + show x (f.1 i) = x (fixedFunEquiv π (Fin N) f O) from by + rw [← (mem_orbFibre π).mp hi] + exact (congrArg x + (fixedFunEquiv_apply_orbitOf π f i)).symm)] + rw [Finset.prod_const, orbCard] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleSum.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleSum.lean new file mode 100644 index 0000000000..6a240419ab --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleSum.lean @@ -0,0 +1,72 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleSumPrep +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.OrbitBridge +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.StabCount +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ContentCount + +/-! +# The cycle-sum identity (assembly) + +The fixed-colouring sum of a permutation is its completed +cycle-type product in the power sums of the colours; summed over +the symmetric group this yields `n! · h_n`. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv Equiv.Perm + +variable {n N : ℕ} + +/-- The fixed-colouring sum of a permutation is its completed +cycle-type product. -/ +theorem sum_fixedFun_eq_cycleProd (x : Fin N → ℂ) + (π : Equiv.Perm (Fin n)) : + (∑ f : {f : Fin n → Fin N // f ∘ π = f}, ∏ i, x (f.1 i)) = + cycleProd (pVal x) π := by + rw [sum_fixedFun_eq_prod_orbits] + rw [show (∏ O : OrbitSpace π, pVal x (orbCard π O)) = + (((Finset.univ : Finset (OrbitSpace π)).val.map + (orbCard π)).map (pVal x)).prod from by + rw [Multiset.map_map] + rfl] + rw [orbCard_multiset] + rw [Multiset.map_add, Multiset.prod_add, Multiset.map_replicate, + Multiset.prod_replicate] + rfl + +/-- The cycle sum at a realized specialization. -/ +theorem cycleSum_spec (x : Fin N → ℂ) : + (∑ π : Equiv.Perm (Fin n), cycleProd (pVal x) π) = + (n.factorial : ℂ) * hVal x n := by + classical + rw [Finset.sum_congr rfl (fun π (_ : π ∈ Finset.univ) => + (sum_fixedFun_eq_cycleProd x π).symm)] + rw [sum_perm_fixed_weight (fun f => ∏ i, x (f i))] + rw [Finset.sum_congr rfl (fun f (_ : f ∈ Finset.univ) => by + rw [card_fixing_perms f])] + exact sum_fibreFactorial_weight' x card_fixing_perms + +/-- **The cycle-sum identity**: over any prospective power-sum +sequence, the completed cycle-type products of all permutations +sum to `n! · h_n`. -/ +theorem cycleSum_eq (t : ℕ → ℂ) (n : ℕ) : + (∑ π : Equiv.Perm (Fin n), cycleProd t π) = + (n.factorial : ℂ) * newtonH t n := by + classical + obtain ⟨N, x, hx⟩ := exists_pVal_eq n t + rw [Finset.sum_congr rfl (fun π (_ : π ∈ Finset.univ) => + cycleProd_congr π (fun c h1 h2 => (hx c h1 h2).symm))] + rw [cycleSum_spec, ← newtonH_pVal x n, + newtonH_congr n (fun c hc1 hc2 => hx c hc1 hc2)] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleSumPrep.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleSumPrep.lean new file mode 100644 index 0000000000..18683ffb95 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleSumPrep.lean @@ -0,0 +1,96 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleFactor + +/-! +# Preparation for the cycle-sum identity + +The Fubini exchange between permutations and their fixed +colourings, and the congruence lemmas allowing transfer of the +cycle-sum identity from realized power sums to arbitrary +prospective ones. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv Equiv.Perm + +variable {n N : ℕ} + +/-- `newtonH` only depends on the first `k` power sums. -/ +theorem newtonH_congr {t t' : ℕ → ℂ} : + ∀ k, (∀ c, 1 ≤ c → c ≤ k → t c = t' c) → + newtonH t k = newtonH t' k + | 0, _ => by rw [newtonH, newtonH] + | k + 1, h => by + rw [newtonH, newtonH] + congr 1 + refine Finset.sum_congr rfl fun i hi => ?_ + have hik : i < k + 1 := Finset.mem_range.mp hi + rw [h (i + 1) (by omega) (by omega), + newtonH_congr (k - i) (fun c h1 hc => h c h1 (by omega))] + decreasing_by exact Nat.lt_succ_of_le (Nat.sub_le k i) + +/-- `cycleProd` only depends on the first `n` power sums. -/ +theorem cycleProd_congr {t t' : ℕ → ℂ} (π : Equiv.Perm (Fin n)) + (h : ∀ c, 1 ≤ c → c ≤ n → t c = t' c) : + cycleProd t π = cycleProd t' π := by + rcases Nat.eq_zero_or_pos n with hn | hn + · subst hn + rw [cycleProd, cycleProd] + rw [show π.cycleType = 0 from by + rw [Equiv.Perm.cycleType_eq_zero] + exact Subsingleton.elim π 1] + simp + · rw [cycleProd, cycleProd, h 1 le_rfl hn] + congr 2 + refine Multiset.map_congr rfl fun c hc => ?_ + have h2 : 2 ≤ c := Equiv.Perm.two_le_of_mem_cycleType hc + have hle : c ≤ π.cycleType.sum := + Multiset.single_le_sum (fun x _ => Nat.zero_le x) c hc + have hsupp := Equiv.Perm.sum_cycleType π + have hcard : π.support.card ≤ n := by + have := Finset.card_le_univ π.support + simpa using this + exact h c (by omega) (by omega) + +/-- **Fubini for fixed colourings**: summing a colouring weight +over all permutations and their fixed colourings counts each +colouring once per stabilizing permutation. -/ +theorem sum_perm_fixed_weight (w : (Fin n → Fin N) → ℂ) : + (∑ π : Equiv.Perm (Fin n), + ∑ f : {f : Fin n → Fin N // f ∘ π = f}, w f.1) = + ∑ f : Fin n → Fin N, + ((Finset.univ.filter + (fun π : Equiv.Perm (Fin n) => f ∘ π = f)).card : ℂ) * + w f := by + classical + calc (∑ π : Equiv.Perm (Fin n), + ∑ f : {f : Fin n → Fin N // f ∘ π = f}, w f.1) + = ∑ π : Equiv.Perm (Fin n), + ∑ f ∈ Finset.univ.filter + (fun f : Fin n → Fin N => f ∘ π = f), w f := + Finset.sum_congr rfl (fun π _ => + (Finset.sum_subtype _ (fun f => by simp) w).symm) + _ = ∑ π : Equiv.Perm (Fin n), ∑ f : Fin n → Fin N, + if f ∘ π = f then w f else 0 := + Finset.sum_congr rfl (fun π _ => + Finset.sum_filter (fun f : Fin n → Fin N => f ∘ π = f) w) + _ = ∑ f : Fin n → Fin N, ∑ π : Equiv.Perm (Fin n), + if f ∘ π = f then w f else 0 := Finset.sum_comm + _ = ∑ f : Fin n → Fin N, + ((Finset.univ.filter + (fun π : Equiv.Perm (Fin n) => f ∘ π = f)).card : ℂ) * + w f := + Finset.sum_congr rfl (fun f _ => by + rw [← Finset.sum_filter, Finset.sum_const, nsmul_eq_mul]) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/EndSum.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/EndSum.lean new file mode 100644 index 0000000000..320684ff40 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/EndSum.lean @@ -0,0 +1,52 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PowerSurj + +/-! +# Constructive simplicity of endomorphism algebras + +Every nonzero endomorphism of a finite-dimensional complex vector space +generates the full endomorphism algebra in the sense that it can be +"sandwiched" to produce the identity: there exist endomorphisms +`U i`, `W i` such that `∑ i, U i * A * W i = 1`. +-/ + +@[expose] public section + +namespace RS + +open Module in +/-- **The sandwich identity**: a nonzero endomorphism generates the +identity as a finite sum of two-sided products. -/ +theorem exists_sum_conj_eq_one {V : Type*} [AddCommGroup V] + [Module ℂ V] [FiniteDimensional ℂ V] + (A : Module.End ℂ V) (hA : A ≠ 0) : + ∃ (n : ℕ) (U W : Fin n → Module.End ℂ V), + ∑ i, U i * A * W i = 1 := by + -- Since A ≠ 0, pick v with A v ≠ 0 + have hAne : ∃ v, A v ≠ 0 := by + by_contra h + push Not at h + exact hA (LinearMap.ext h) + obtain ⟨v, hv⟩ := hAne + -- Get a dual functional φ with φ (A v) = 1 + obtain ⟨φ, hφ⟩ := Projective.exists_dual_eq_one ℂ hv + -- Get a finite basis + set d := finrank ℂ V + set b := Module.finBasis ℂ V + -- Define W j : y ↦ (b.coord j y) • v and U j : y ↦ φ y • b j + refine ⟨d, fun j => φ.smulRight (b j), fun j => (b.coord j).smulRight v, ?_⟩ + -- Show ∑ j, U j * A * W j = 1 + ext y + simp only [LinearMap.sum_apply, Module.End.mul_apply, + LinearMap.smulRight_apply, + Basis.coord_apply, Module.End.one_apply, map_smul, hφ, smul_smul, mul_one] + exact b.sum_repr y + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/FibreCard.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/FibreCard.lean new file mode 100644 index 0000000000..1e37699367 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/FibreCard.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PowerSurj + +/-! +# Fibres of a colouring + +Shared definitions for the cycle sums: the fibre counts of +a function `Fin n → Fin N` and its content multiset. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {n N : ℕ} + +/-- The size of the fibre of a colouring over a colour. -/ +noncomputable def fibreCard (f : Fin n → Fin N) (j : Fin N) : ℕ := by + classical + exact (Finset.univ.filter (fun i => f i = j)).card + +/-- The content of a colouring: the multiset of its values. -/ +def content (f : Fin n → Fin N) : Sym (Fin N) n := + ⟨Finset.univ.val.map f, by + rw [Multiset.card_map] + simp⟩ + +/-- Counts over all colours total the size of a multiset. -/ +theorem sum_count_univ (m : Multiset (Fin N)) : + ∑ j : Fin N, m.count j = Multiset.card m := by + classical + rw [← Multiset.toFinset_sum_count_eq m] + exact (Finset.sum_subset (Finset.subset_univ _) + (fun a _ ha => Multiset.count_eq_zero.mpr + (fun hmem => ha (Multiset.mem_toFinset.mpr hmem)))).symm + +/-- A fibre's size is the colour's multiplicity in the content. -/ +theorem fibreCard_eq_count (f : Fin n → Fin N) (j : Fin N) : + fibreCard f j = (content f).1.count j := by + classical + rw [fibreCard, content, Multiset.count_map] + rw [Multiset.filter_congr + (fun x _ => (eq_comm : j = f x ↔ f x = j))] + rfl + +/-- The fibres partition the domain. -/ +theorem sum_fibreCard (f : Fin n → Fin N) : + ∑ j : Fin N, fibreCard f j = n := by + classical + rw [Finset.sum_congr rfl (fun j _ => fibreCard_eq_count f j), + sum_count_univ] + exact (content f).2 + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/FixWeight.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/FixWeight.lean new file mode 100644 index 0000000000..01552e6181 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/FixWeight.lean @@ -0,0 +1,170 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourWeight +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleSum + +/-! +# Weighted stabilizer factorization + +The completed cycle-type weight summed over the stabilizer of a +colouring factorizes over the fibres, and the colour-character +weighted permutation sum evaluates to `n!` times the product of +the complete homogeneous values of the fibre sizes. The two +cycle-type transport facts (invariance under `permCongr` and +additivity over `sigmaCongrRight`) enter as explicit hypotheses, +discharged in `ColourCycleSum.lean`. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv + +variable {n N : ℕ} + +/-- The completed cycle-type product on an arbitrary finite +carrier. -/ +noncomputable def cycleProdOn {γ : Type} [Fintype γ] [DecidableEq γ] + (t : ℕ → ℂ) (σ : Equiv.Perm γ) : ℂ := + (σ.cycleType.map t).prod * + t 1 ^ (Fintype.card γ - σ.cycleType.sum) + +/-- The permCongr-invariance hypothesis. -/ +abbrev PermCongrCT : Prop := + ∀ (A B : Type) [Fintype A] [DecidableEq A] [Fintype B] + [DecidableEq B] (e : A ≃ B) (σ : Equiv.Perm A), + (e.permCongr σ).cycleType = σ.cycleType + +/-- The sigma-additivity hypothesis. -/ +abbrev SigmaCT : Prop := + ∀ (I : Type) [Fintype I] [DecidableEq I] (β : I → Type) + [∀ i, Fintype (β i)] [∀ i, DecidableEq (β i)] + (σ : ∀ i, Equiv.Perm (β i)), + (Equiv.Perm.sigmaCongrRight σ).cycleType = + ∑ i, (σ i).cycleType + +/-- The general-carrier cycle sum, by transport along an +enumeration. -/ +theorem sum_cycleProdOn_eq (H1 : PermCongrCT) {γ : Type} + [Fintype γ] [DecidableEq γ] (t : ℕ → ℂ) : + ∑ σ : Equiv.Perm γ, cycleProdOn t σ = + ((Fintype.card γ).factorial : ℂ) * + newtonH t (Fintype.card γ) := by + classical + set e : γ ≃ Fin (Fintype.card γ) := Fintype.equivFin γ with he + rw [show (∑ σ : Equiv.Perm γ, cycleProdOn t σ) = + ∑ π : Equiv.Perm (Fin (Fintype.card γ)), cycleProd t π from ?_] + · exact cycleSum_eq t (Fintype.card γ) + · rw [← Equiv.sum_comp (e.permCongr) (cycleProd t)] + refine Finset.sum_congr rfl fun σ _ => ?_ + rw [cycleProdOn, cycleProd, H1 γ (Fin (Fintype.card γ)) e σ] + +/-- Multiset products of mapped Finset sums split. -/ +private theorem prod_map_finset_sum {ι : Type*} (t : ℕ → ℂ) + (s : Finset ι) (F : ι → Multiset ℕ) : + (((∑ i ∈ s, F i).map t).prod) = + ∏ i ∈ s, ((F i).map t).prod := by + classical + induction s using Finset.induction_on with + | empty => simp + | insert a s ha ih => + rw [Finset.sum_insert ha, Finset.prod_insert ha, + Multiset.map_add, Multiset.prod_add, ih] + +/-- **The fiberwise cycle weight**: the completed cycle weight of +an assembled fixing permutation is the product of the fibre +weights. -/ +theorem cycleProd_ofFibrePerms (H1 : PermCongrCT) (H2 : SigmaCT) + (t : ℕ → ℂ) (f : Fin n → Fin N) + (σ : ∀ j : Fin N, Equiv.Perm {i : Fin n // f i = j}) : + cycleProd t (ofFibrePerms f σ) = + ∏ j : Fin N, cycleProdOn t (σ j) := by + classical + have hct : (ofFibrePerms f σ).cycleType = + ∑ j : Fin N, (σ j).cycleType := by + rw [ofFibrePerms_def, H1 _ _ (sigmaFiberEquiv f) + (Equiv.Perm.sigmaCongrRight σ), H2 _ _ σ] + have hsle : ∀ j : Fin N, + (σ j).cycleType.sum ≤ fibreCard f j := by + intro j + rw [Equiv.Perm.sum_cycleType, fibreCard_eq_card] + exact le_trans (Finset.card_le_univ _) + (le_of_eq (Finset.card_univ)) + have hsum_m : ∑ j : Fin N, fibreCard f j = n := sum_fibreCard f + rw [cycleProd, hct, prod_map_finset_sum] + rw [show (n - (∑ j : Fin N, (σ j).cycleType).sum) = + ∑ j : Fin N, (fibreCard f j - (σ j).cycleType.sum) from ?_] + · rw [← Finset.prod_pow_eq_pow_sum, ← Finset.prod_mul_distrib] + refine Finset.prod_congr rfl fun j _ => ?_ + rw [cycleProdOn, fibreCard_eq_card] + · rw [show (∑ j : Fin N, (σ j).cycleType).sum = + ∑ j : Fin N, (σ j).cycleType.sum from + map_sum Multiset.sumAddMonoidHom _ _] + rw [Finset.sum_tsub_distrib _ (fun j _ => hsle j), hsum_m] + +/-- **The weighted stabilizer factorization**: the completed cycle +weight summed over the stabilizer of a colouring is the product of +the fibre factorial-homogeneous values. -/ +theorem sum_fixing_cycleProd (H1 : PermCongrCT) (H2 : SigmaCT) + (t : ℕ → ℂ) (f : Fin n → Fin N) : + ∑ π ∈ Finset.univ.filter + (fun π : Equiv.Perm (Fin n) => f ∘ π = f), + cycleProd t π = + ∏ j : Fin N, ((fibreCard f j).factorial : ℂ) * + newtonH t (fibreCard f j) := by + classical + calc ∑ π ∈ Finset.univ.filter + (fun π : Equiv.Perm (Fin n) => f ∘ π = f), cycleProd t π + = ∑ πh : {π : Equiv.Perm (Fin n) // f ∘ π = f}, + cycleProd t πh.1 := + Finset.sum_subtype _ (fun π => by simp) _ + _ = ∑ σ : ∀ j : Fin N, Equiv.Perm {i : Fin n // f i = j}, + cycleProd t (ofFibrePerms f σ) := by + rw [← Equiv.sum_comp (fixingEquiv f).symm + (fun πh : {π : Equiv.Perm (Fin n) // f ∘ π = f} => + cycleProd t πh.1)] + refine Finset.sum_congr rfl fun σ _ => ?_ + rw [fixingEquiv_symm_apply] + _ = ∑ σ : ∀ j : Fin N, Equiv.Perm {i : Fin n // f i = j}, + ∏ j : Fin N, cycleProdOn t (σ j) := + Finset.sum_congr rfl fun σ _ => + cycleProd_ofFibrePerms H1 H2 t f σ + _ = ∏ j : Fin N, ∑ σj : Equiv.Perm {i : Fin n // f i = j}, + cycleProdOn t σj := by + rw [Finset.prod_univ_sum, Fintype.piFinset_univ] + _ = ∏ j : Fin N, ((fibreCard f j).factorial : ℂ) * + newtonH t (fibreCard f j) := by + refine Finset.prod_congr rfl fun j _ => ?_ + rw [sum_cycleProdOn_eq H1 t, ← fibreCard_eq_card] + +/-- **The colour cycle sum**: the `colourChar`-weighted completed +cycle sum evaluates to `n!` times the product of the complete +homogeneous values of the composition. -/ +theorem colour_cycleSum (H1 : PermCongrCT) (H2 : SigmaCT) + (t : ℕ → ℂ) (α : Fin N → ℕ) (hsum : ∑ j : Fin N, α j = n) : + ∑ π : Equiv.Perm (Fin n), + (colourChar α π : ℂ) * cycleProd t π = + (n.factorial : ℂ) * ∏ j : Fin N, newtonH t (α j) := by + classical + rw [sum_colourChar_weight α (cycleProd t)] + rw [Finset.sum_congr rfl + (fun (g : {g : Fin n → Fin N // ∀ j, fibreCard g j = α j}) + (_ : g ∈ Finset.univ) => sum_fixing_cycleProd H1 H2 t g.1)] + rw [Finset.sum_congr rfl + (fun (g : {g : Fin n → Fin N // ∀ j, fibreCard g j = α j}) + (_ : g ∈ Finset.univ) => + Finset.prod_congr rfl (fun j _ => by rw [g.2 j]))] + rw [Finset.sum_const, Finset.card_univ, nsmul_eq_mul] + rw [Finset.prod_mul_distrib, ← mul_assoc] + congr 1 + exact_mod_cast congrArg (Nat.cast (R := ℂ)) + (card_colourClass α hsum) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/HVal.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/HVal.lean new file mode 100644 index 0000000000..1df76e74e7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/HVal.lean @@ -0,0 +1,181 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums + +/-! +# Evaluated symmetric values and the power–complete Newton identity + +The specialization layer works with complex +values rather than a formal symmetric-function ring: for a finite +family `x : Fin N → ℂ` we define the power sums `pVal x c` and the +complete homogeneous values `hVal x k` (a sum over size-`k` +multisets), and prove the Newton identity + + `(k+1) · h_{k+1} = ∑_{i ≤ k} p_{i+1} · h_{k−i}` + +by double counting: adding `i+1` copies of a marked variable to a +size-`(k−i)` multiset produces each size-`(k+1)` multiset once per +unit of multiplicity. Consequently `hVal x` satisfies the defining +recursion of `newtonH (pVal x)`. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {N : ℕ} + +/-- The power sum of exponent `c` of a finite family. -/ +noncomputable def pVal (x : Fin N → ℂ) (c : ℕ) : ℂ := + ∑ j : Fin N, x j ^ c + +/-- The complete homogeneous value of degree `k` of a finite +family: the sum of the products of all size-`k` multisets. -/ +noncomputable def hVal (x : Fin N → ℂ) (k : ℕ) : ℂ := + ∑ s : Sym (Fin N) k, (s.1.map x).prod + +/-- The degree-zero complete homogeneous value is `1`. -/ +@[simp] theorem hVal_zero (x : Fin N → ℂ) : hVal x 0 = 1 := by + rw [hVal] + rw [show (Finset.univ : Finset (Sym (Fin N) 0)) = {Sym.nil} from + Finset.eq_singleton_iff_unique_mem.mpr + ⟨Finset.mem_univ _, fun s _ => Sym.eq_nil_of_card_zero s⟩] + simp + +/-- The per-variable splitting identity: marking `i+1` copies of +`j` inside a size-`(k+1)` multiset, every multiset arises once per +unit of the multiplicity of `j`. -/ +theorem sum_split_eq_count (x : Fin N → ℂ) (k : ℕ) (j : Fin N) : + (∑ i ∈ range (k + 1), ∑ s : Sym (Fin N) (k - i), + x j ^ (i + 1) * (s.1.map x).prod) = + ∑ S : Sym (Fin N) (k + 1), + (S.1.count j : ℂ) * (S.1.map x).prod := by + classical + rw [← Finset.sum_sigma (range (k + 1)) + (fun i => (Finset.univ : Finset (Sym (Fin N) (k - i)))) + (fun p => x j ^ (p.1 + 1) * (p.2.1.map x).prod)] + rw [show (∑ S : Sym (Fin N) (k + 1), + (S.1.count j : ℂ) * (S.1.map x).prod) = + ∑ q ∈ (Finset.univ : Finset (Sym (Fin N) (k + 1))).sigma + (fun S => range (S.1.count j)), + ((q.1 : Sym (Fin N) (k + 1)).1.map x).prod from by + rw [Finset.sum_sigma + (Finset.univ : Finset (Sym (Fin N) (k + 1))) + (fun S => range (S.1.count j)) + (fun q => ((q.1 : Sym (Fin N) (k + 1)).1.map x).prod)] + refine Finset.sum_congr rfl fun S _ => ?_ + change (S.1.count j : ℂ) * (S.1.map x).prod = + ∑ _s ∈ range (S.1.count j), (S.1.map x).prod + rw [Finset.sum_const, Finset.card_range, nsmul_eq_mul]] + refine Finset.sum_bij' + (fun p hp => ⟨⟨p.2.1 + Multiset.replicate (p.1 + 1) j, by + have hik : p.1 < k + 1 := + Finset.mem_range.mp (Finset.mem_sigma.mp hp).1 + rw [Multiset.card_add, p.2.2, Multiset.card_replicate] + omega⟩, p.1⟩) + (fun q hq => ⟨q.2, ⟨q.1.1 - Multiset.replicate (q.2 + 1) j, by + have hd : q.2 < q.1.1.count j := + Finset.mem_range.mp (Finset.mem_sigma.mp hq).2 + have hle : Multiset.replicate (q.2 + 1) j ≤ q.1.1 := + Multiset.le_count_iff_replicate_le.mp hd + rw [Multiset.card_sub hle, q.1.2, Multiset.card_replicate] + omega⟩⟩) + ?_ ?_ ?_ ?_ ?_ + · -- forward membership + intro p hp + refine Finset.mem_sigma.mpr ⟨Finset.mem_univ _, ?_⟩ + refine Finset.mem_range.mpr ?_ + change p.1 < Multiset.count j (p.2.1 + Multiset.replicate (p.1 + 1) j) + rw [Multiset.count_add, Multiset.count_replicate, ite_eq_left rfl] + omega + · -- backward membership + intro q hq + refine Finset.mem_sigma.mpr ⟨?_, Finset.mem_univ _⟩ + refine Finset.mem_range.mpr ?_ + have hd : q.2 < q.1.1.count j := + Finset.mem_range.mp (Finset.mem_sigma.mp hq).2 + have hcc := Multiset.count_le_card j q.1.1 + rw [q.1.2] at hcc + change q.2 < k + 1 + omega + · -- left inverse + intro p hp + refine Sigma.ext rfl (heq_of_eq ?_) + refine Subtype.ext ?_ + change (p.2.1 + Multiset.replicate (p.1 + 1) j) - + Multiset.replicate (p.1 + 1) j = p.2.1 + exact Multiset.add_sub_cancel_right + · -- right inverse + intro q hq + refine Sigma.ext ?_ (heq_of_eq rfl) + refine Subtype.ext ?_ + have hd : q.2 < q.1.1.count j := + Finset.mem_range.mp (Finset.mem_sigma.mp hq).2 + have hle : Multiset.replicate (q.2 + 1) j ≤ q.1.1 := + Multiset.le_count_iff_replicate_le.mp hd + change (q.1.1 - Multiset.replicate (q.2 + 1) j) + + Multiset.replicate (q.2 + 1) j = q.1.1 + exact Multiset.sub_add_cancel hle + · -- weights + intro p hp + change x j ^ (p.1 + 1) * (p.2.1.map x).prod = + ((p.2.1 + Multiset.replicate (p.1 + 1) j).map x).prod + rw [Multiset.map_add, Multiset.prod_add, Multiset.map_replicate, + Multiset.prod_replicate, mul_comm] + +/-- **The power–complete Newton identity**, at the level of +values. -/ +theorem hVal_newton (x : Fin N → ℂ) (k : ℕ) : + ((k : ℂ) + 1) * hVal x (k + 1) = + ∑ i ∈ range (k + 1), pVal x (i + 1) * hVal x (k - i) := by + classical + rw [Finset.sum_congr rfl (fun i (_ : i ∈ range (k + 1)) => + show pVal x (i + 1) * hVal x (k - i) = + ∑ j : Fin N, x j ^ (i + 1) * hVal x (k - i) from by + rw [pVal, Finset.sum_mul])] + rw [Finset.sum_comm] + rw [show (∑ j : Fin N, ∑ i ∈ range (k + 1), + x j ^ (i + 1) * hVal x (k - i)) = + ∑ j : Fin N, ∑ S : Sym (Fin N) (k + 1), + (S.1.count j : ℂ) * (S.1.map x).prod from + Finset.sum_congr rfl fun j _ => by + rw [← sum_split_eq_count x k j] + exact Finset.sum_congr rfl fun i _ => by + rw [hVal, Finset.mul_sum]] + rw [Finset.sum_comm] + rw [hVal, Finset.mul_sum] + refine Finset.sum_congr rfl fun S _ => ?_ + rw [← Finset.sum_mul] + congr 1 + rw [← Nat.cast_sum] + rw [show (∑ j : Fin N, S.1.count j) = Multiset.card S.1 from ?_] + · rw [S.2, Nat.cast_add, Nat.cast_one] + · rw [← Multiset.toFinset_sum_count_eq S.1] + exact (Finset.sum_subset (Finset.subset_univ _) + (fun a _ ha => Multiset.count_eq_zero.mpr + (fun hmem => ha (Multiset.mem_toFinset.mpr hmem)))).symm + +/-- `hVal` satisfies the `newtonH` recursion: the complete +homogeneous values are the Newton lifts of the power sums. -/ +theorem newtonH_pVal (x : Fin N → ℂ) : ∀ k, newtonH (pVal x) k = hVal x k + | 0 => by rw [newtonH, hVal_zero] + | k + 1 => by + rw [newtonH] + have hrec : ∀ i ∈ range (k + 1), + pVal x (i + 1) * newtonH (pVal x) (k - i) = + pVal x (i + 1) * hVal x (k - i) := fun i _ => by + rw [newtonH_pVal x (k - i)] + rw [Finset.sum_congr rfl hrec, ← hVal_newton] + rw [← mul_assoc, inv_mul_cancel₀ + (Nat.cast_add_one_ne_zero k : ((k : ℂ) + 1) ≠ 0), one_mul] + decreasing_by exact Nat.lt_succ_of_le (Nat.sub_le k i) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/IdempotentBridge.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/IdempotentBridge.lean new file mode 100644 index 0000000000..962f609d8a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/IdempotentBridge.lean @@ -0,0 +1,57 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeTable +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage + +/-! +# The interface idempotent as a class element + +`charIdempotent` of the interface unfolds to a `classElem` of the +projector theory; for inversion-invariant class functions the +normalizations agree, identifying `charIdempotent (nDim S) (nChar S)` +with `nProjector S` over the symmetric group. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv + +variable {n : ℕ} + +/-- `charIdempotent` is the class element of the normalized +inverted character. -/ +theorem charIdempotent_eq_classElem (d : ℕ) + (χ : Equiv.Perm (Fin n) → ℂ) (hinv : ∀ π, χ π⁻¹ = χ π) : + charIdempotent d χ = + classElem (fun π : Equiv.Perm (Fin n) => + ((d : ℂ) / (n.factorial : ℂ)) * χ π⁻¹) := by + rw [charIdempotent, classElem, Finset.smul_sum] + refine Finset.sum_congr rfl fun π _ => ?_ + rw [hinv π, smul_smul] + rfl + +/-- Over the symmetric group, `charIdempotent` of a simple +submodule's data is the native projector. -/ +theorem charIdempotent_eq_nProjector + (S : Submodule (MonoidAlgebra ℂ (Equiv.Perm (Fin n))) + (MonoidAlgebra ℂ (Equiv.Perm (Fin n)))) + (χ : Equiv.Perm (Fin n) → ℂ) + (hχ : ∀ π, χ π = nChar S π) (hinv : ∀ π, χ π⁻¹ = χ π) : + charIdempotent (nDim S) χ = nProjector S := by + rw [charIdempotent_eq_classElem (nDim S) χ hinv, nProjector] + congr 1 + funext π + rw [nCoeff, hχ π⁻¹] + rw [show (Fintype.card (Equiv.Perm (Fin n)) : ℂ) = + (n.factorial : ℂ) from by + rw [Fintype.card_perm, Fintype.card_fin]] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTChar.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTChar.lean new file mode 100644 index 0000000000..40fdf19a90 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTChar.lean @@ -0,0 +1,153 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FixWeight +public import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams + +/-! +# The Jacobi–Trudi virtual character + +For a Young diagram `μ` with `n = μ.card` cells and `k` rows, the +virtual character `jtChar μ` is the signed sum, over `σ ∈ S_k`, of +the colour characters of the shifted compositions +`i ↦ μᵢ + σ(i) − i` (terms with a negative part vanish). Its +Frobenius transform is the Jacobi–Trudi determinant +`diagramSchur μ`: each Leibniz term is evaluated by the colour +cycle sum. The two cycle-type transport facts enter as explicit +hypotheses, discharged in `ColourCycleSum.lean`. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv + +/-- List sums over `Fin` indexing. -/ +private theorem list_sum_eq_fin_sum (l : List ℕ) : + l.sum = ∑ i : Fin l.length, l.get i := by + conv_lhs => rw [← List.ofFn_get l] + rw [List.sum_ofFn] + +/-- The signed Jacobi–Trudi degree of row `i` under `σ`. -/ +def jtSigned (μ : YoungDiagram) + (σ : Equiv.Perm (Fin μ.rowLens.length)) + (i : Fin μ.rowLens.length) : ℤ := + (μ.rowLens.get i : ℤ) + ((σ i : ℕ) : ℤ) - ((i : ℕ) : ℤ) + +/-- The shifted composition sums to the diagram's size, the shifts +cancelling. -/ +theorem sum_jtSigned (μ : YoungDiagram) + (σ : Equiv.Perm (Fin μ.rowLens.length)) : + ∑ i, jtSigned μ σ i = (μ.card : ℤ) := by + unfold jtSigned + rw [Finset.sum_sub_distrib, Finset.sum_add_distrib] + rw [show (∑ i : Fin μ.rowLens.length, ((σ i : ℕ) : ℤ)) = + ∑ i : Fin μ.rowLens.length, ((i : ℕ) : ℤ) from + Equiv.sum_comp σ (fun i : Fin μ.rowLens.length => + ((i : ℕ) : ℤ))] + rw [add_sub_cancel_right] + rw [card_eq_sum_rowLens, list_sum_eq_fin_sum, Nat.cast_sum] + +/-- The shifted composition attached to a Leibniz term, when +nonnegative. -/ +def jtComp (μ : YoungDiagram) + (σ : Equiv.Perm (Fin μ.rowLens.length)) + (i : Fin μ.rowLens.length) : ℕ := + (jtSigned μ σ i).toNat + +/-- Hence when no part is negative the composition itself does. -/ +theorem sum_jtComp (μ : YoungDiagram) + (σ : Equiv.Perm (Fin μ.rowLens.length)) + (hp : ∀ i, 0 ≤ jtSigned μ σ i) : + ∑ i, jtComp μ σ i = μ.card := by + have h1 : ((∑ i, jtComp μ σ i : ℕ) : ℤ) = (μ.card : ℤ) := by + rw [Nat.cast_sum] + rw [Finset.sum_congr rfl + (fun (i : Fin μ.rowLens.length) (_ : i ∈ Finset.univ) => + show ((jtComp μ σ i : ℕ) : ℤ) = jtSigned μ σ i from by + rw [jtComp, Int.toNat_of_nonneg (hp i)])] + exact sum_jtSigned μ σ + exact_mod_cast h1 + +open scoped Classical in +/-- **The Jacobi–Trudi virtual character** of shape `μ`. -/ +noncomputable def jtChar (μ : YoungDiagram) + (π : Equiv.Perm (Fin μ.card)) : ℂ := + ∑ σ : Equiv.Perm (Fin μ.rowLens.length), + ((Equiv.Perm.sign σ : ℤ) : ℂ) * + (if ∀ i, 0 ≤ jtSigned μ σ i + then (colourChar (jtComp μ σ) π : ℂ) + else 0) + +open scoped Classical in +/-- **The Frobenius formula for the Jacobi–Trudi character**: its +normalized cycle-weighted sum is the Jacobi–Trudi determinant. -/ +theorem jtChar_frobenius (H1 : PermCongrCT) (H2 : SigmaCT) + (μ : YoungDiagram) (t : ℕ → ℂ) : + ((μ.card.factorial : ℂ))⁻¹ * + ∑ π : Equiv.Perm (Fin μ.card), + jtChar μ π * cycleProd t π = + diagramSchur μ t := by + classical + have hswap : (∑ π : Equiv.Perm (Fin μ.card), + jtChar μ π * cycleProd t π) = + ∑ σ : Equiv.Perm (Fin μ.rowLens.length), + ((Equiv.Perm.sign σ : ℤ) : ℂ) * + (if ∀ i, 0 ≤ jtSigned μ σ i + then ∑ π : Equiv.Perm (Fin μ.card), + (colourChar (jtComp μ σ) π : ℂ) * cycleProd t π + else 0) := by + rw [Finset.sum_congr rfl (fun π (_ : π ∈ Finset.univ) => by + rw [jtChar, Finset.sum_mul])] + rw [Finset.sum_comm] + refine Finset.sum_congr rfl fun σ _ => ?_ + by_cases hp : ∀ i, 0 ≤ jtSigned μ σ i + · rw [ite_eq_left hp, Finset.mul_sum] + refine Finset.sum_congr rfl fun π _ => ?_ + rw [ite_eq_left hp, mul_assoc] + · rw [ite_eq_right hp] + rw [Finset.sum_eq_zero fun π _ => by + rw [ite_eq_right hp, mul_zero, zero_mul]] + rw [mul_zero] + have hterm : ∀ σ : Equiv.Perm (Fin μ.rowLens.length), + ((Equiv.Perm.sign σ : ℤ) : ℂ) * + (if ∀ i, 0 ≤ jtSigned μ σ i + then ∑ π : Equiv.Perm (Fin μ.card), + (colourChar (jtComp μ σ) π : ℂ) * cycleProd t π + else 0) = + (μ.card.factorial : ℂ) * + (((Equiv.Perm.sign σ : ℤ) : ℂ) * + ∏ i, newtonHZ t (jtSigned μ σ i)) := by + intro σ + by_cases hp : ∀ i, 0 ≤ jtSigned μ σ i + · rw [ite_eq_left hp] + rw [colour_cycleSum H1 H2 t (jtComp μ σ) (sum_jtComp μ σ hp)] + rw [show (∏ i, newtonHZ t (jtSigned μ σ i)) = + ∏ i, newtonH t (jtComp μ σ i) from + Finset.prod_congr rfl fun i _ => by + rw [jtComp] + conv_lhs => rw [← Int.toNat_of_nonneg (hp i)] + rw [newtonHZ_natCast]] + ring + · rw [ite_eq_right hp] + rw [not_forall] at hp + obtain ⟨i0, hi0⟩ := hp + rw [Finset.prod_eq_zero (Finset.mem_univ i0) + (newtonHZ_neg t _ (not_le.mp hi0))] + ring + rw [hswap, Finset.sum_congr rfl (fun σ _ => hterm σ), + ← Finset.mul_sum, ← mul_assoc, + inv_mul_cancel₀ + (by exact_mod_cast Nat.factorial_ne_zero μ.card), one_mul] + rw [diagramSchur, schurDet, ← Matrix.det_transpose, + Matrix.det_apply'] + refine Finset.sum_congr rfl fun σ _ => ?_ + congr 1 + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIntChar.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIntChar.lean new file mode 100644 index 0000000000..a1174cc767 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIntChar.lean @@ -0,0 +1,118 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharDecomp +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PermModule + +/-! +# The Jacobi–Trudi virtual character as a signed sum of native characters + +Every summand in the Jacobi–Trudi character formula is a colour-class +representation character, hence decomposes into native characters of +simple submodules. Assembling these decompositions over the Leibniz +sum yields `jtChar μ` as a signed combination of native characters +with signs in `{±1}`. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv + +open scoped Classical in +/-- **The Jacobi–Trudi character is a signed sum of native +characters**: each summand of the formula is a colour-class +character, which decomposes into simples. -/ +theorem jtChar_eq_sum_sign_nChar (μ : YoungDiagram) : + ∃ (J : Type) (_ : Fintype J) (ε : J → ℤ) + (T : J → Submodule (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) + (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card)))), + (∀ j, IsSimpleModule (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) (T j)) ∧ + (∀ j, ε j = 1 ∨ ε j = -1) ∧ + ∀ π : Equiv.Perm (Fin μ.card), + jtChar μ π = ∑ j, ((ε j : ℤ) : ℂ) * nChar (T j) π := by + classical + -- Step 1: For each σ, produce a decomposition of the jtChar summand + -- into a sum of signed native characters. + have hdecomp : ∀ σ : Equiv.Perm (Fin μ.rowLens.length), + ∃ (m : ℕ) (S : Fin m → Submodule (MonoidAlgebra ℂ (Equiv.Perm (Fin + μ.card))) + (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card)))), + (∀ i, IsSimpleModule (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) (S i)) + ∧ + ∀ π, ((Equiv.Perm.sign σ : ℤ) : ℂ) * + (if ∀ i, 0 ≤ jtSigned μ σ i + then (colourChar (jtComp μ σ) π : ℂ) else 0) = + ∑ i : Fin m, ((Equiv.Perm.sign σ : ℤ) : ℂ) * nChar (S i) π := by + intro σ + by_cases hp : ∀ i, 0 ≤ jtSigned μ σ i + · -- Guard true: decompose the colour representation character + obtain ⟨m, S, hSimp, hChar⟩ := + character_eq_sum_nChar (G := Equiv.Perm (Fin μ.card)) (colourRep + (jtComp μ σ)) + refine ⟨m, S, hSimp, fun π => ?_⟩ + rw [ite_eq_left hp] + -- colourRep_character converts representation character to colourChar + have hconv : (colourChar (jtComp μ σ) π : ℂ) = + ∑ i : Fin m, nChar (S i) π := by + rw [← colourRep_character (jtComp μ σ) π] + exact hChar π + rw [hconv, Finset.mul_sum] + · -- Guard false: empty family, both sides are zero + exact ⟨0, Fin.elim0, fun i => i.elim0, fun π => by + rw [ite_eq_right hp, mul_zero]; simp⟩ + -- Step 2: Extract the families via Classical.choose + let dm : Equiv.Perm (Fin μ.rowLens.length) → ℕ := + fun σ => (hdecomp σ).choose + let dS : (σ : Equiv.Perm (Fin μ.rowLens.length)) → + Fin (dm σ) → Submodule (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) + (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) := + fun σ => (hdecomp σ).choose_spec.choose + have hdS_simp : ∀ σ i, + IsSimpleModule (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) (dS σ i) := + fun σ => (hdecomp σ).choose_spec.choose_spec.1 + have hdS_char : ∀ σ π, + ((Equiv.Perm.sign σ : ℤ) : ℂ) * + (if ∀ i, 0 ≤ jtSigned μ σ i + then (colourChar (jtComp μ σ) π : ℂ) else 0) = + ∑ i : Fin (dm σ), ((Equiv.Perm.sign σ : ℤ) : ℂ) * nChar (dS σ i) π := + fun σ => (hdecomp σ).choose_spec.choose_spec.2 + -- Step 3: Build the sigma type J and the witnesses + let J := Σ σ : Equiv.Perm (Fin μ.rowLens.length), Fin (dm σ) + let ε : J → ℤ := fun j => (Equiv.Perm.sign j.1 : ℤ) + let T : J → Submodule (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) + (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) := + fun j => dS j.1 j.2 + refine ⟨J, inferInstance, ε, T, ?_, ?_, ?_⟩ + · -- Simplicity + intro ⟨σ, i⟩ + exact hdS_simp σ i + · -- Sign values: (Perm.sign σ : ℤ) ∈ {1, -1} + intro ⟨σ, _⟩ + change (Equiv.Perm.sign σ : ℤ) = 1 ∨ (Equiv.Perm.sign σ : ℤ) = -1 + rcases Int.units_eq_one_or (Equiv.Perm.sign σ) with h | h + · left; exact congrArg Units.val h + · right; exact congrArg Units.val h + · -- Character identity + intro π + -- Unfold jtChar to the outer sum + change jtChar μ π = ∑ j : J, ((ε j : ℤ) : ℂ) * nChar (T j) π + -- Step 3a: rewrite each summand of jtChar using hdS_char + have h1 : jtChar μ π = + ∑ σ : Equiv.Perm (Fin μ.rowLens.length), + ∑ i : Fin (dm σ), + ((Equiv.Perm.sign σ : ℤ) : ℂ) * nChar (dS σ i) π := by + unfold jtChar + refine Finset.sum_congr rfl fun σ _ => ?_ + exact hdS_char σ π + -- Step 3b: convert double sum to sigma sum + rw [h1] + rw [← Fintype.sum_sigma'] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIrreducible.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIrreducible.lean new file mode 100644 index 0000000000..adde1ee38a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIrreducible.lean @@ -0,0 +1,241 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTOrtho +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharEquiv +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharClass + +/-! +# Norm one forces a single simple + +A `±1`-signed combination of native characters with norm one is +`±` a single native character: group the index set by equivalence +of the underlying simples, express the norm as a sum of integer +squares over the classes, and conclude a unique class with +coefficient `±1`. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv + +/-- A finite sum of integer squares equal to one has exactly one +nonzero term, of value `±1`. -/ +theorem sum_sq_eq_one {Q : Type*} [Fintype Q] (Z : Q → ℤ) + (h : ∑ q : Q, Z q * Z q = 1) : + ∃ q₀ : Q, (Z q₀ = 1 ∨ Z q₀ = -1) ∧ + ∀ q : Q, q ≠ q₀ → Z q = 0 := by + classical + have hnn : ∀ q : Q, 0 ≤ Z q * Z q := fun q => mul_self_nonneg _ + have hex : ∃ q₀ : Q, Z q₀ ≠ 0 := by + by_contra hc + rw [not_exists] at hc + have h0 : (∑ q : Q, Z q * Z q) = 0 := + Finset.sum_eq_zero fun q _ => by + rw [not_not.mp (hc q), mul_zero] + omega + obtain ⟨q₀, hq₀⟩ := hex + have h1 : 1 ≤ Z q₀ * Z q₀ := by + rcases lt_trichotomy (Z q₀) 0 with hlt | heq | hgt + · nlinarith + · exact absurd heq hq₀ + · nlinarith + have hsplit : (∑ q : Q, Z q * Z q) = + Z q₀ * Z q₀ + ∑ q ∈ Finset.univ.erase q₀, Z q * Z q := by + rw [add_comm, Finset.sum_erase_add _ _ (Finset.mem_univ q₀)] + have hrest : (∑ q ∈ Finset.univ.erase q₀, Z q * Z q) = 0 := by + have hnn2 : 0 ≤ ∑ q ∈ Finset.univ.erase q₀, Z q * Z q := + Finset.sum_nonneg fun q _ => hnn q + omega + have hz : ∀ q : Q, q ≠ q₀ → Z q = 0 := by + intro q hq + have h2 := (Finset.sum_eq_zero_iff_of_nonneg + (fun q _ => hnn q)).mp hrest q + (Finset.mem_erase.mpr ⟨hq, Finset.mem_univ q⟩) + nlinarith [mul_self_nonneg (Z q)] + have hsq : Z q₀ * Z q₀ = 1 := by omega + exact ⟨q₀, mul_self_eq_one_iff.mp hsq, hz⟩ + +open scoped Classical in +/-- **Norm one forces a single simple.** -/ +theorem jt_pm_nChar (μ : YoungDiagram) {J : Type} [Fintype J] + (ε : J → ℤ) + (T : J → Submodule (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) + (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card)))) + (hT : ∀ j, IsSimpleModule + (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) (T j)) + (hchar : ∀ π : Equiv.Perm (Fin μ.card), + jtChar μ π = ∑ j, ((ε j : ℤ) : ℂ) * nChar (T j) π) : + ∃ S₀ : Submodule (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) + (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))), + IsSimpleModule (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) + S₀ ∧ + ((∀ π, jtChar μ π = nChar S₀ π) ∨ + (∀ π, jtChar μ π = - nChar S₀ π)) := by + classical + -- ═══════ SETUP: THE CLASSES OF EQUAL CHARACTERS ═══════ + -- Irreducible constituents with equal characters are identified, + -- and `Z` records the common multiplicity of a class. + have hip : ∀ j j' : J, + ((μ.card.factorial : ℂ))⁻¹ * + ∑ π : Equiv.Perm (Fin μ.card), + nChar (T j) π * nChar (T j') π⁻¹ = + (if Nonempty ((rhoS (T j')).Equiv (rhoS (T j))) + then (1 : ℂ) else 0) := by + intro j j' + have := rhoS_isIrreducible (T j) (hT j) + have := rhoS_isIrreducible (T j') (hT j') + have : Invertible ((Nat.card (Equiv.Perm (Fin μ.card)) : ℂ)) := + invertibleOfNonzero (by + rw [Nat.card_eq_fintype_card] + exact_mod_cast Fintype.card_ne_zero) + have horth := Representation.char_orthonormal + (rhoS (T j)) (rhoS (T j')) + rw [show (Nat.card (Equiv.Perm (Fin μ.card)) : ℂ) = + (μ.card.factorial : ℂ) from by + rw [Nat.card_eq_fintype_card, Fintype.card_perm, + Fintype.card_fin]] at horth + exact horth + let sd : Setoid J := + ⟨fun j j' => Nonempty ((rhoS (T j)).Equiv (rhoS (T j'))), + fun _ => ⟨Representation.Equiv.refl _⟩, + fun ⟨e⟩ => ⟨e.symm⟩, + fun ⟨e⟩ ⟨f⟩ => ⟨e.trans f⟩⟩ + let g : J → Quotient sd := Quotient.mk sd + have hgr : ∀ j j' : J, g j = g j' ↔ + Nonempty ((rhoS (T j)).Equiv (rhoS (T j'))) := by + intro j j' + exact ⟨fun h => Quotient.exact h, fun h => Quotient.sound h⟩ + let Z : Quotient sd → ℤ := fun q => + ∑ j ∈ Finset.univ.filter (fun j => g j = q), ε j + have hZc : ∀ q : Quotient sd, ((Z q : ℤ) : ℂ) = + ∑ j ∈ Finset.univ.filter (fun j => g j = q), + ((ε j : ℤ) : ℂ) := by + intro q + rw [show Z q = ∑ j ∈ Finset.univ.filter + (fun j => g j = q), ε j from rfl] + push_cast + rfl + -- ═══════ STAGE 1: THE NORM AS A SUM OF SQUARES ═══════ + have hkey : ((μ.card.factorial : ℂ))⁻¹ * + (∑ π : Equiv.Perm (Fin μ.card), jtChar μ π * jtChar μ π) = + ∑ j : J, ∑ j' : J, ((ε j : ℤ) : ℂ) * ((ε j' : ℤ) : ℂ) * + (if g j = g j' then (1 : ℂ) else 0) := by + rw [Finset.sum_congr rfl (fun π (_ : π ∈ Finset.univ) => show + jtChar μ π * jtChar μ π = + ∑ j : J, ∑ j' : J, + (((ε j : ℤ) : ℂ) * nChar (T j) π) * + (((ε j' : ℤ) : ℂ) * nChar (T j') π⁻¹) from by + rw [show jtChar μ π * jtChar μ π = + jtChar μ π * jtChar μ π⁻¹ from by rw [jtChar_inv]] + rw [hchar π, hchar π⁻¹, Finset.sum_mul_sum])] + rw [Finset.sum_comm] + rw [Finset.sum_congr rfl + (fun j (_ : j ∈ Finset.univ) => Finset.sum_comm)] + rw [Finset.mul_sum] + refine Finset.sum_congr rfl fun j _ => ?_ + rw [Finset.mul_sum] + refine Finset.sum_congr rfl fun j' _ => ?_ + rw [show (if g j = g j' then (1 : ℂ) else 0) = + (if Nonempty ((rhoS (T j')).Equiv (rhoS (T j))) + then (1 : ℂ) else 0) from by + by_cases hc : Nonempty ((rhoS (T j')).Equiv (rhoS (T j))) + · rw [ite_eq_left hc, ite_eq_left ((hgr j j').mpr ⟨hc.some.symm⟩)] + · rw [ite_eq_right hc, ite_eq_right (fun hgj => hc + ⟨((hgr j j').mp hgj).some.symm⟩)]] + rw [← hip j j'] + rw [Finset.mul_sum, Finset.mul_sum] + refine Eq.trans ?_ (Finset.mul_sum _ _ _).symm + refine Finset.sum_congr rfl fun π _ => ?_ + ring + have hnorm : (∑ q : Quotient sd, + ((Z q : ℤ) : ℂ) * ((Z q : ℤ) : ℂ)) = 1 := by + have h0 := jtChar_orthonormal μ + rw [hkey] at h0 + rw [← h0] + rw [Finset.sum_congr rfl (fun j (_ : j ∈ Finset.univ) => show + (∑ j' : J, ((ε j : ℤ) : ℂ) * ((ε j' : ℤ) : ℂ) * + (if g j = g j' then (1 : ℂ) else 0)) = + ((ε j : ℤ) : ℂ) * ((Z (g j) : ℤ) : ℂ) from by + rw [Finset.sum_congr rfl (fun j' (_ : j' ∈ Finset.univ) => + show ((ε j : ℤ) : ℂ) * ((ε j' : ℤ) : ℂ) * + (if g j = g j' then (1 : ℂ) else 0) = + (if g j' = g j + then ((ε j : ℤ) : ℂ) * ((ε j' : ℤ) : ℂ) else 0) + from by + by_cases hc : g j = g j' + · rw [ite_eq_left hc, ite_eq_left hc.symm, mul_one] + · rw [ite_eq_right hc, ite_eq_right (fun h => hc h.symm), mul_zero])] + rw [← Finset.sum_filter, hZc, Finset.mul_sum])] + rw [← Fintype.sum_fiberwise g + (fun j => ((ε j : ℤ) : ℂ) * ((Z (g j) : ℤ) : ℂ))] + refine Finset.sum_congr rfl fun q _ => ?_ + rw [show (∑ j : {j : J // g j = q}, + ((ε j.1 : ℤ) : ℂ) * ((Z (g j.1) : ℤ) : ℂ)) = + ∑ j : {j : J // g j = q}, + ((ε j.1 : ℤ) : ℂ) * ((Z q : ℤ) : ℂ) from + Finset.sum_congr rfl fun j _ => by rw [j.2]] + rw [← Finset.sum_mul] + congr 1 + rw [hZc] + exact Finset.sum_subtype _ (fun j => + ⟨fun h => (Finset.mem_filter.mp h).2, + fun h => Finset.mem_filter.mpr ⟨Finset.mem_univ j, h⟩⟩) + (fun j => ((ε j : ℤ) : ℂ)) + have hnormZ : (∑ q : Quotient sd, Z q * Z q) = 1 := by + have h2 : (((∑ q : Quotient sd, Z q * Z q : ℤ)) : ℂ) = + ((1 : ℤ) : ℂ) := by + push_cast + exact_mod_cast hnorm + exact_mod_cast h2 + -- ═══════ STAGE 2: ONE CLASS CARRIES MULTIPLICITY ±1 ═══════ + obtain ⟨q₀, hpm, hzero⟩ := sum_sq_eq_one Z hnormZ + refine ⟨T q₀.out, hT q₀.out, ?_⟩ + -- ═══════ STAGE 3: COLLAPSE THE SUM TO THAT CLASS ═══════ + have hcollapse : ∀ π : Equiv.Perm (Fin μ.card), + jtChar μ π = ((Z q₀ : ℤ) : ℂ) * nChar (T q₀.out) π := by + intro π + rw [hchar π] + rw [← Fintype.sum_fiberwise g + (fun j => ((ε j : ℤ) : ℂ) * nChar (T j) π)] + rw [Finset.sum_congr rfl (fun q (_ : q ∈ Finset.univ) => show + (∑ j : {j : J // g j = q}, + ((ε j.1 : ℤ) : ℂ) * nChar (T j.1) π) = + ((Z q : ℤ) : ℂ) * nChar (T q.out) π from by + rw [show (∑ j : {j : J // g j = q}, + ((ε j.1 : ℤ) : ℂ) * nChar (T j.1) π) = + ∑ j : {j : J // g j = q}, + ((ε j.1 : ℤ) : ℂ) * nChar (T q.out) π from + Finset.sum_congr rfl fun j _ => by + rw [nChar_of_equiv (((hgr j.1 q.out).mp + (by rw [j.2]; exact (Quotient.out_eq q).symm)).some) + π]] + rw [← Finset.sum_mul, hZc] + congr 1 + exact (Finset.sum_subtype _ (fun j => + ⟨fun h => (Finset.mem_filter.mp h).2, + fun h => Finset.mem_filter.mpr ⟨Finset.mem_univ j, h⟩⟩) + (fun j => ((ε j : ℤ) : ℂ))).symm)] + rw [Finset.sum_eq_single q₀ + (fun q _ hq => by rw [hzero q hq]; push_cast; ring) + (fun h => absurd (Finset.mem_univ q₀) h)] + rcases hpm with h1 | h1 + · left + intro π + rw [hcollapse π, h1] + push_cast + ring + · right + intro π + rw [hcollapse π, h1] + push_cast + ring + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTOrtho.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTOrtho.lean new file mode 100644 index 0000000000..eff762f6c1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTOrtho.lean @@ -0,0 +1,207 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairChar +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairTuple +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.TCount +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTChar + +/-! +# Orthonormality of the Jacobi–Trudi characters + +The Jacobi–Trudi characters are orthonormal for the class inner +product of the symmetric group, which is what makes them the +irreducible characters. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv + +open scoped Classical in +/-- **The Jacobi–Trudi characters are of unit norm** for the class +inner product — which is what makes them irreducible characters. -/ +theorem jtChar_orthonormal (μ : YoungDiagram) : + ((μ.card.factorial : ℂ))⁻¹ * + ∑ π : Equiv.Perm (Fin μ.card), jtChar μ π * jtChar μ π = 1 := by + set n := μ.card with hn_def + -- ═══════ SETUP: THE SORT HYPOTHESIS FOR `t_count` ═══════ + have hsort : ∀ i j : Fin μ.rowLens.length, i ≤ j → + (fun i : Fin μ.rowLens.length => μ.rowLens.get i) j ≤ + (fun i : Fin μ.rowLens.length => μ.rowLens.get i) i := + μ.rowLens_sorted.antitone_get + suffices hsum : (∑ π : Equiv.Perm (Fin n), + jtChar μ π * jtChar μ π : ℂ) = (n.factorial : ℂ) by + rw [hsum, inv_mul_cancel₀ + (by exact_mod_cast Nat.factorial_ne_zero n)] + -- ═══════ STAGE 1: EXPAND `jtChar` AND EXCHANGE THE SUMS ═══════ + -- to ∑ σ ∑ τ ... (∑ π colourChar * colourChar) + have hstep1 : (∑ π : Equiv.Perm (Fin n), + jtChar μ π * jtChar μ π : ℂ) = + ∑ σ : Equiv.Perm (Fin μ.rowLens.length), ∑ τ : Equiv.Perm (Fin + μ.rowLens.length), + ((Equiv.Perm.sign σ : ℤ) : ℂ) * ((Equiv.Perm.sign τ : ℤ) : ℂ) * + (if (∀ i, 0 ≤ jtSigned μ σ i) ∧ (∀ i, 0 ≤ jtSigned μ τ i) + then ∑ π : Equiv.Perm (Fin n), + (colourChar (jtComp μ σ) π : ℂ) * (colourChar (jtComp μ τ) π : ℂ) + else 0) := by + -- Expand jtChar * jtChar as a double sum + rw [Finset.sum_congr rfl (fun (π : Equiv.Perm (Fin n)) (_ : π ∈ Finset.univ) + => + show jtChar μ π * jtChar μ π = + ∑ σ : Equiv.Perm (Fin μ.rowLens.length), ∑ τ : Equiv.Perm (Fin + μ.rowLens.length), + (((Equiv.Perm.sign σ : ℤ) : ℂ) * + (if ∀ i, 0 ≤ jtSigned μ σ i + then (colourChar (jtComp μ σ) π : ℂ) else 0)) * + (((Equiv.Perm.sign τ : ℤ) : ℂ) * + (if ∀ i, 0 ≤ jtSigned μ τ i + then (colourChar (jtComp μ τ) π : ℂ) else 0)) + from by rw [jtChar, Finset.sum_mul_sum])] + rw [Finset.sum_comm] + refine Finset.sum_congr rfl fun σ _ => ?_ + rw [Finset.sum_comm] + refine Finset.sum_congr rfl fun τ _ => ?_ + by_cases hσ : ∀ i, 0 ≤ jtSigned μ σ i + · by_cases hτ : ∀ i, 0 ≤ jtSigned μ τ i + · rw [ite_eq_left ⟨hσ, hτ⟩, Finset.mul_sum] + refine Finset.sum_congr rfl fun π _ => ?_ + rw [ite_eq_left hσ, ite_eq_left hτ]; ring + · rw [ite_eq_right (fun hc => hτ hc.2)] + rw [Finset.sum_eq_zero fun π _ => by + rw [ite_eq_right hτ, mul_zero, mul_zero]] + rw [mul_zero] + · rw [ite_eq_right (fun hc => hσ hc.1)] + rw [show (∑ π : Equiv.Perm (Fin n), + ((Equiv.Perm.sign σ : ℤ) : ℂ) * + (if ∀ i, 0 ≤ jtSigned μ σ i + then (colourChar (jtComp μ σ) π : ℂ) else 0) * + (((Equiv.Perm.sign τ : ℤ) : ℂ) * + (if ∀ i, 0 ≤ jtSigned μ τ i + then (colourChar (jtComp μ τ) π : ℂ) else 0))) = 0 + from Finset.sum_eq_zero fun π _ => by + rw [ite_eq_right hσ, mul_zero, zero_mul]] + rw [mul_zero] + -- ═══════ STAGE 2: PRODUCTS OF CHARACTERS AS FILTER CARDS ═══════ + -- colourChar values are ℕ, so colourChar * colourChar is ℕ too + have hstep2 : ∀ (σ τ : Equiv.Perm (Fin μ.rowLens.length)), + (∀ i, 0 ≤ jtSigned μ σ i) → (∀ i, 0 ≤ jtSigned μ τ i) → + (∑ π : Equiv.Perm (Fin n), + (colourChar (jtComp μ σ) π : ℂ) * + (colourChar (jtComp μ τ) π : ℂ)) = + ((∑ π : Equiv.Perm (Fin n), + colourChar (jtComp μ σ) π * colourChar (jtComp μ τ) π : ℕ) : ℂ) := by + intro σ τ _ _ + push_cast + rfl + -- ═══════ STAGE 3: THE COUNT IS `n!` TIMES A PAIR COUNT ═══════ + have hstep3 : ∀ (σ τ : Equiv.Perm (Fin μ.rowLens.length)), + (∀ i, 0 ≤ jtSigned μ σ i) → (∀ i, 0 ≤ jtSigned μ τ i) → + (∑ π : Equiv.Perm (Fin n), + colourChar (jtComp μ σ) π * colourChar (jtComp μ τ) π : ℕ) = + n.factorial * Fintype.card {s : Sym (Fin μ.rowLens.length × Fin + μ.rowLens.length) n // + (∀ a, (∑ b : Fin μ.rowLens.length, s.1.count (a, b)) = jtComp μ σ a) ∧ + (∀ b, (∑ a : Fin μ.rowLens.length, s.1.count (a, b)) = jtComp μ τ b)} + := by + intro σ τ _ _ + rw [Finset.sum_congr rfl (fun (π : Equiv.Perm (Fin n)) (_ : π ∈ Finset.univ) + => + colourChar_mul (jtComp μ σ) (jtComp μ τ) π)] + exact pair_count_sum (jtComp μ σ) (jtComp μ τ) + -- ═══════ STAGE 4: PAIR COUNT AS TUPLE COUNT ═══════ + have hstep4 : ∀ (σ τ : Equiv.Perm (Fin μ.rowLens.length)), + (hσ : ∀ i, 0 ≤ jtSigned μ σ i) → (hτ : ∀ i, 0 ≤ jtSigned μ τ i) → + Fintype.card {s : Sym (Fin μ.rowLens.length × Fin μ.rowLens.length) n // + (∀ a, (∑ b : Fin μ.rowLens.length, s.1.count (a, b)) = jtComp μ σ a) ∧ + (∀ b, (∑ a : Fin μ.rowLens.length, s.1.count (a, b)) = jtComp μ τ b)} = + Fintype.card {W : ∀ a : Fin μ.rowLens.length, Sym (Fin μ.rowLens.length) + (jtComp μ σ a) // + ∀ b : Fin μ.rowLens.length, (∑ a : Fin μ.rowLens.length, (W a).1.count + b) = jtComp μ τ b} := by + intro σ τ hσ _ + exact pair_tuple_card (jtComp μ σ) (jtComp μ τ) (sum_jtComp μ σ hσ) + -- ═══════ ASSEMBLY: CHAIN THE FOUR STAGES INTO `t_count` ═══════ + rw [hstep1] + -- Rewrite each (σ, τ) term + have hterm : ∀ (σ τ : Equiv.Perm (Fin μ.rowLens.length)), + ((Equiv.Perm.sign σ : ℤ) : ℂ) * ((Equiv.Perm.sign τ : ℤ) : ℂ) * + (if (∀ i, 0 ≤ jtSigned μ σ i) ∧ (∀ i, 0 ≤ jtSigned μ τ i) + then ∑ π : Equiv.Perm (Fin n), + (colourChar (jtComp μ σ) π : ℂ) * (colourChar (jtComp μ τ) π : ℂ) + else 0) = + (n.factorial : ℂ) * + (((Equiv.Perm.sign σ : ℤ) : ℂ) * ((Equiv.Perm.sign τ : ℤ) : ℂ) * + (if (∀ i, 0 ≤ jtSigned μ σ i) ∧ (∀ i, 0 ≤ jtSigned μ τ i) + then (Fintype.card {W : ∀ a : Fin μ.rowLens.length, + Sym (Fin μ.rowLens.length) (jtComp μ σ a) // + ∀ b : Fin μ.rowLens.length, (∑ a : Fin μ.rowLens.length, (W + a).1.count b) = + jtComp μ τ b} : ℂ) + else 0)) := by + intro σ τ + by_cases hboth : (∀ i, 0 ≤ jtSigned μ σ i) ∧ (∀ i, 0 ≤ jtSigned μ τ i) + · rw [ite_eq_left hboth, ite_eq_left hboth] + rw [hstep2 σ τ hboth.1 hboth.2, hstep3 σ τ hboth.1 hboth.2, + hstep4 σ τ hboth.1 hboth.2] + push_cast; ring + · rw [ite_eq_right hboth, ite_eq_right hboth, mul_zero, mul_zero] + rw [Finset.sum_congr rfl (fun (σ : Equiv.Perm (Fin μ.rowLens.length)) (_ : σ ∈ + Finset.univ) => + Finset.sum_congr rfl (fun (τ : Equiv.Perm (Fin μ.rowLens.length)) (_ : τ ∈ + Finset.univ) => + hterm σ τ))] + simp only [← Finset.mul_sum] + -- Now need: n.factorial * (∑ σ ∑ τ ...) = n.factorial + -- Suffices: the double sum = 1 + suffices hdbl : (∑ σ : Equiv.Perm (Fin μ.rowLens.length), ∑ τ : Equiv.Perm + (Fin μ.rowLens.length), + ((Equiv.Perm.sign σ : ℤ) : ℂ) * ((Equiv.Perm.sign τ : ℤ) : ℂ) * + (if (∀ i, 0 ≤ jtSigned μ σ i) ∧ (∀ i, 0 ≤ jtSigned μ τ i) + then (Fintype.card {W : ∀ a : Fin μ.rowLens.length, + Sym (Fin μ.rowLens.length) (jtComp μ σ a) // + ∀ b : Fin μ.rowLens.length, (∑ a : Fin μ.rowLens.length, (W + a).1.count b) = + jtComp μ τ b} : ℂ) + else 0)) = 1 by + rw [hdbl, mul_one] + -- Swap sum order to match t_count (which has τ outer, σ inner) + rw [Finset.sum_comm] + -- Now: ∑ τ ∑ σ, sign σ * sign τ * if ... then card{W...} else 0 + -- Swap sign σ and sign τ to match t_count + rw [Finset.sum_congr rfl (fun (τ : Equiv.Perm (Fin μ.rowLens.length)) (_ : τ ∈ + Finset.univ) => + Finset.sum_congr rfl (fun (σ : Equiv.Perm (Fin μ.rowLens.length)) (_ : σ ∈ + Finset.univ) => + show ((Equiv.Perm.sign σ : ℤ) : ℂ) * ((Equiv.Perm.sign τ : ℤ) : ℂ) * + (if (∀ i, 0 ≤ jtSigned μ σ i) ∧ (∀ i, 0 ≤ jtSigned μ τ i) + then (Fintype.card {W : ∀ a : Fin μ.rowLens.length, + Sym (Fin μ.rowLens.length) (jtComp μ σ a) // + ∀ b : Fin μ.rowLens.length, (∑ a : Fin μ.rowLens.length, (W + a).1.count b) = + jtComp μ τ b} : ℂ) + else 0) = + ((Equiv.Perm.sign τ : ℤ) : ℂ) * ((Equiv.Perm.sign σ : ℤ) : ℂ) * + (if (∀ i, 0 ≤ jtSigned μ σ i) ∧ (∀ i, 0 ≤ jtSigned μ τ i) + then (Fintype.card {W : ∀ a : Fin μ.rowLens.length, + Sym (Fin μ.rowLens.length) (jtComp μ σ a) // + ∀ b : Fin μ.rowLens.length, (∑ a : Fin μ.rowLens.length, (W + a).1.count b) = + jtComp μ τ b} : ℂ) + else 0) from by ring_nf))] + -- Now match with t_count + -- t_count uses v = μ.rowLens.get; jtSigned/jtComp are defined in terms of + -- this + -- Need to show-retype to align definitional forms + convert t_count (fun i : Fin μ.rowLens.length => μ.rowLens.get i) hsort + using 2 + exact rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean new file mode 100644 index 0000000000..57b5b415de --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean @@ -0,0 +1,495 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTChar + +/-! +# Zero-row padding for the Jacobi–Trudi character + +When `k ≥ μ.rowLens.length`, the Jacobi–Trudi character `jtChar μ` +can equivalently be written as a sum over `Perm (Fin k)`: every +extra permutation index beyond the diagram's row count contributes +zero weight, because the guard forces it to be fixed. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv + +/-! ### Row lengths vanish beyond the diagram -/ + +/-- `μ.rowLen i = 0` for `i ≥ μ.rowLens.length`. -/ +theorem rowLen_eq_zero_of_ge (μ : YoungDiagram) {i : ℕ} + (hi : μ.rowLens.length ≤ i) : μ.rowLen i = 0 := by + by_contra h + have h0 : 0 < μ.rowLen i := Nat.pos_of_ne_zero h + have hmem : (i, 0) ∈ μ := YoungDiagram.mem_iff_lt_rowLen.mpr h0 + have hlt : i < μ.colLen 0 := YoungDiagram.mem_iff_lt_colLen.mp hmem + rw [YoungDiagram.length_rowLens] at hi + omega + +/-- `μ.rowLens.get i = μ.rowLen i` (bridging `List.get` and `rowLen`). -/ +theorem get_rowLens_eq_rowLen (μ : YoungDiagram) + (i : Fin μ.rowLens.length) : + μ.rowLens.get i = μ.rowLen (i : ℕ) := by + rw [List.get_eq_getElem] + exact YoungDiagram.get_rowLens + +/-! ### Tail-fixing: permutations satisfying the guard fix indices +beyond the diagram -/ + +/-- If σ : Perm (Fin k) satisfies the nonnegativity guard and +`(i : ℕ) ≥ μ.rowLens.length`, then `σ i = i`. -/ +private theorem tail_ge_of_guard (μ : YoungDiagram) {k : ℕ} + (_hk : μ.rowLens.length ≤ k) + (σ : Equiv.Perm (Fin k)) + (hguard : ∀ i : Fin k, + 0 ≤ (μ.rowLen (i : ℕ) : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ)) + (j : Fin k) (hj : μ.rowLens.length ≤ (j : ℕ)) : + (j : ℕ) ≤ (σ j : ℕ) := by + have hr : μ.rowLen (j : ℕ) = 0 := rowLen_eq_zero_of_ge μ hj + have := hguard j + simp [hr] at this + omega + +/-- The guard forces a permutation to fix every index beyond the +diagram's rows: the row length there is zero, so the guard fails +unless the index is fixed. -/ +theorem tail_fixed_of_guard (μ : YoungDiagram) {k : ℕ} + (hk : μ.rowLens.length ≤ k) + (σ : Equiv.Perm (Fin k)) + (hguard : ∀ i : Fin k, + 0 ≤ (μ.rowLen (i : ℕ) : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ)) + (i : Fin k) (hi : μ.rowLens.length ≤ (i : ℕ)) : + σ i = i := by + -- Downward induction on d where (i : ℕ) + d + 1 ≥ k. + suffices key : ∀ d : ℕ, ∀ j : Fin k, + μ.rowLens.length ≤ (j : ℕ) → k ≤ (j : ℕ) + d + 1 → σ j = j by + exact key (k - 1 - (i : ℕ)) i hi (by omega) + intro d + induction d with + | zero => + intro j hj hd + have hge := tail_ge_of_guard μ hk σ hguard j hj + have hlt := (σ j).isLt + have hjk : (j : ℕ) = k - 1 := by omega + ext; omega + | succ d ih => + intro j hj hd + have hge := tail_ge_of_guard μ hk σ hguard j hj + by_cases heq : (σ j : ℕ) = (j : ℕ) + · exact Fin.ext heq + · -- (σ j : ℕ) > (j : ℕ), so σ j is also a tail index + have hgt : (j : ℕ) < (σ j : ℕ) := by omega + have hσj_tail : μ.rowLens.length ≤ (σ j : ℕ) := by omega + have hσj_bound : k ≤ (σ j : ℕ) + d + 1 := by omega + -- By IH, σ (σ j) = σ j + have hfix := ih (σ j) hσj_tail hσj_bound + -- By injectivity, σ j = j + exact absurd (σ.injective hfix) (by intro h; exact heq (by rw [h])) + +/-! ### Restriction and extension of tail-fixing permutations -/ + +/-- A tail-fixing permutation maps head indices to head indices. -/ +private theorem head_maps_head (μ : YoungDiagram) {k : ℕ} + (hk : μ.rowLens.length ≤ k) + (σ : Equiv.Perm (Fin k)) + (hfix : ∀ i : Fin k, μ.rowLens.length ≤ (i : ℕ) → σ i = i) + (j : Fin μ.rowLens.length) : + (σ (Fin.castLE hk j) : ℕ) < μ.rowLens.length := by + by_contra h + push Not at h + have hm := hfix (σ (Fin.castLE hk j)) h + -- hm : σ (σ (castLE j)) = σ (castLE j), i.e. σ A = σ B with A = σ(..), B = + -- castLE j + have hinj : σ (Fin.castLE hk j) = Fin.castLE hk j := σ.injective hm + have hval : (Fin.castLE hk j : ℕ) = (j : ℕ) := Fin.val_castLE hk j + rw [hinj, show (Fin.castLE hk j : Fin k).val = (j : ℕ) from hval] at h + exact absurd j.isLt (by omega) + +/-- Restrict a tail-fixing permutation to the head indices. -/ +noncomputable def restrictHead (μ : YoungDiagram) {k : ℕ} + (hk : μ.rowLens.length ≤ k) + (σ : Equiv.Perm (Fin k)) + (hfix : ∀ i : Fin k, μ.rowLens.length ≤ (i : ℕ) → σ i = i) : + Equiv.Perm (Fin μ.rowLens.length) where + toFun j := ⟨(σ (Fin.castLE hk j) : ℕ), by exact head_maps_head μ hk σ hfix j⟩ + invFun j := ⟨(σ⁻¹ (Fin.castLE hk j) : ℕ), + by exact (head_maps_head μ hk σ⁻¹ (fun i hi => by + have h1 := hfix i hi + change σ.symm i = i + rw [Equiv.symm_apply_eq] + exact h1.symm) j)⟩ + left_inv j := by + ext; simp [Fin.val_castLE] + right_inv j := by + ext; simp [Fin.val_castLE] + +/-- Extend a permutation of `Fin μ.rowLens.length` to `Fin k` by +fixing tail indices. -/ +noncomputable def extendTail (μ : YoungDiagram) {k : ℕ} + (hk : μ.rowLens.length ≤ k) + (σ' : Equiv.Perm (Fin μ.rowLens.length)) : + Equiv.Perm (Fin k) := + Equiv.Perm.viaEmbedding σ' (Fin.castLEEmb hk) + +/-- The extension fixes the tail indices by construction. -/ +theorem extendTail_fixes_tail (μ : YoungDiagram) {k : ℕ} + (hk : μ.rowLens.length ≤ k) + (σ' : Equiv.Perm (Fin μ.rowLens.length)) + (i : Fin k) (hi : μ.rowLens.length ≤ (i : ℕ)) : + extendTail μ hk σ' i = i := by + unfold extendTail + apply Equiv.Perm.viaEmbedding_apply_of_notMem + intro ⟨j, hj⟩ + have : (Fin.castLEEmb hk j : ℕ) = (j : ℕ) := rfl + rw [show Fin.castLEEmb hk j = i from hj] at this + omega + +/-- On head indices it acts as the permutation extended. -/ +theorem extendTail_apply (μ : YoungDiagram) {k : ℕ} + (hk : μ.rowLens.length ≤ k) + (σ' : Equiv.Perm (Fin μ.rowLens.length)) + (j : Fin μ.rowLens.length) : + extendTail μ hk σ' (Fin.castLE hk j) = Fin.castLE hk (σ' j) := by + unfold extendTail + have : (Fin.castLEEmb hk) j = Fin.castLE hk j := rfl + rw [← this] + have : (Fin.castLEEmb hk) (σ' j) = Fin.castLE hk (σ' j) := rfl + rw [← this] + exact Equiv.Perm.viaEmbedding_apply σ' (Fin.castLEEmb hk) j + +/-- Restricting an extension recovers the permutation. -/ +theorem restrictHead_extendTail (μ : YoungDiagram) {k : ℕ} + (hk : μ.rowLens.length ≤ k) + (σ' : Equiv.Perm (Fin μ.rowLens.length)) : + restrictHead μ hk (extendTail μ hk σ') + (extendTail_fixes_tail μ hk σ') = σ' := by + ext j + simp [restrictHead, extendTail_apply μ hk σ' j, Fin.val_castLE] + +/-- And extending a restriction recovers the tail-fixing +permutation: the two are inverse. -/ +theorem extendTail_restrictHead (μ : YoungDiagram) {k : ℕ} + (hk : μ.rowLens.length ≤ k) + (σ : Equiv.Perm (Fin k)) + (hfix : ∀ i : Fin k, μ.rowLens.length ≤ (i : ℕ) → σ i = i) : + extendTail μ hk (restrictHead μ hk σ hfix) = σ := by + ext i + by_cases hi : (i : ℕ) < μ.rowLens.length + · -- Head index: use extendTail_apply + restrictHead def + have heq : i = Fin.castLE hk ⟨(i : ℕ), hi⟩ := by ext; simp + rw [heq, extendTail_apply] + simp [restrictHead] + · -- Tail index: both sides fix it + push Not at hi + rw [extendTail_fixes_tail μ hk _ i hi, hfix i hi] + +/-! ### Sign preservation -/ + +/-- Extension preserves sign, fixing the added indices. -/ +theorem sign_extendTail (μ : YoungDiagram) {k : ℕ} + (hk : μ.rowLens.length ≤ k) + (σ' : Equiv.Perm (Fin μ.rowLens.length)) : + Equiv.Perm.sign (extendTail μ hk σ') = Equiv.Perm.sign σ' := by + simp only [extendTail, Equiv.Perm.viaEmbedding] + rw [Equiv.Perm.sign_extendDomain] + +/-! ### colourChar extension by zeros -/ + +/-- If `fibreCard g j = 0` for all j beyond N, then g maps into Fin N. -/ +private theorem range_lt_of_fibreCard_zero {n k : ℕ} {N : ℕ} + (g : Fin n → Fin k) + (hfib : ∀ j : Fin k, N ≤ (j : ℕ) → fibreCard g j = 0) + (x : Fin n) : (g x : ℕ) < N := by + by_contra h + push Not at h + have hcard := hfib (g x) h + rw [fibreCard] at hcard + have hmem : x ∈ (Finset.univ.filter fun y => g y = g x) := by + simp [Finset.mem_filter] + rw [Finset.card_eq_zero.mp hcard] at hmem + simp at hmem + +open scoped Classical in +/-- `colourChar` is invariant under extending the composition by +zeros. -/ +theorem colourChar_extend_zero {n N k : ℕ} (hNk : N ≤ k) + (α : Fin N → ℕ) (_hsum : ∑ j : Fin N, α j = n) + (π : Equiv.Perm (Fin n)) : + colourChar α π = + colourChar + (fun i : Fin k => if h : (i : ℕ) < N then α ⟨i, h⟩ else 0) + π := by + classical + let β : Fin k → ℕ := fun i => if h : (i : ℕ) < N then α ⟨i, h⟩ else 0 + change colourChar α π = colourChar β π + unfold colourChar + -- Helper: extended fibre condition forces range into first N + have range_bound : ∀ g : Fin n → Fin k, + (∀ j, fibreCard g j = β j) → ∀ x, (g x : ℕ) < N := by + intro g hfib x + exact range_lt_of_fibreCard_zero g (fun j hj => by + have := hfib j + simp only [β, dite_eq_right (by omega : ¬ (j : ℕ) < N)] at this + exact this) x + -- Key lemma: fibreCard of castLE ∘ g at a head index + have fwd_fib_head : ∀ (g : Fin n → Fin N) (j : Fin N), + fibreCard (Fin.castLE hNk ∘ g) (Fin.castLE hNk j) = fibreCard g j := by + intro g j + simp only [fibreCard.eq_1] + congr 1; ext x + simp only [Finset.mem_filter, Finset.mem_univ, true_and, Function.comp] + rw [Fin.ext_iff, Fin.ext_iff] + simp [Fin.val_castLE] + -- Key lemma: fibreCard of castLE ∘ g at a tail index + have fwd_fib_tail : ∀ (g : Fin n → Fin N) (j : Fin k), + ¬ (j : ℕ) < N → fibreCard (Fin.castLE hNk ∘ g) j = 0 := by + intro g j hj + simp only [fibreCard.eq_1] + apply Finset.card_eq_zero.mpr + ext x + simp only [Finset.mem_filter, Finset.mem_univ, true_and, Function.comp] + constructor + · intro h + have := congrArg Fin.val h + simp only [Fin.val_castLE] at this + exact absurd (this ▸ (g x).isLt) (by omega) + · intro h; exact absurd h (by simp) + -- Key lemma: fibreCard of restriction + have bwd_fib : ∀ (g : Fin n → Fin k) (hb : ∀ x, (g x : ℕ) < N) (j : Fin N), + fibreCard (fun x => (⟨(g x : ℕ), hb x⟩ : Fin N)) j = + fibreCard g (Fin.castLE hNk j) := by + intro g hb j + simp only [fibreCard.eq_1] + congr 1; ext x + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + rw [Fin.ext_iff, Fin.ext_iff] + simp [Fin.val_castLE] + -- Helper: extract backward map as a standalone function + let bwd_map : ∀ (g : Fin n → Fin k), + (∀ j, fibreCard g j = β j) → + Fin n → Fin N := + fun g hfib x => ⟨(g x : ℕ), range_bound g hfib x⟩ + apply Finset.card_bij' + (fun g _ => Fin.castLE hNk ∘ g) + (fun g hg => bwd_map g (Finset.mem_filter.mp hg).2.1) + · -- Goal 1: hj (backward preserves filter) + -- g : Fin n → Fin k, need bwd_map g ... ∈ s + intro g hg + have hfilt := (Finset.mem_filter.mp hg).2 + have hb : ∀ x, (g x : ℕ) < N := range_bound g hfilt.1 + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + constructor + · intro j + change fibreCard (fun x => (⟨(g x : ℕ), hb x⟩ : Fin N)) j = α j + rw [bwd_fib g hb j] + have hβ : β (Fin.castLE hNk j) = α j := by + change (if h : (Fin.castLE hNk j : ℕ) < N then α ⟨(Fin.castLE hNk j : ℕ), + h⟩ else 0) = α j + have hlt : (Fin.castLE hNk j : ℕ) < N := by + rw [Fin.val_castLE hNk j]; exact j.isLt + rw [dite_eq_left hlt, show (⟨(Fin.castLE hNk j : ℕ), hlt⟩ : Fin N) = j from + Fin.ext (Fin.val_castLE hNk j)] + rw [← hβ] + exact hfilt.1 (Fin.castLE hNk j) + · change (fun x => (⟨(g x : ℕ), hb x⟩ : Fin N)) ∘ ↑π = fun x => ⟨(g x : ℕ), hb + x⟩ + ext x + simp only [Function.comp] + exact congrArg Fin.val (congr_fun hfilt.2 x) + · -- Goal 2: left_inv (bwd_map (castLE ∘ g) ... = g) + intro g hg + ext x + simp only [bwd_map, Function.comp, Fin.val_castLE] + · -- Goal 3: right_inv (castLE ∘ bwd_map g ... = g) + intro g hg + have hfilt := (Finset.mem_filter.mp hg).2 + ext x + simp only [bwd_map, Function.comp, Fin.val_castLE] + · -- Goal 4: hi (forward preserves filter) + -- g : Fin n → Fin N, need castLE ∘ g ∈ t + intro g hg + have hfilt := (Finset.mem_filter.mp hg).2 + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + constructor + · intro j + change fibreCard (Fin.castLE hNk ∘ g) j = + (if h : (j : ℕ) < N then α ⟨(j : ℕ), h⟩ else 0) + by_cases hj : (j : ℕ) < N + · rw [dite_eq_left hj] + have heq : j = Fin.castLE hNk ⟨(j : ℕ), hj⟩ := by ext; simp + calc fibreCard (Fin.castLE hNk ∘ g) j + = fibreCard (Fin.castLE hNk ∘ g) (Fin.castLE hNk ⟨(j : ℕ), hj⟩) + := by rw [← heq] + _ = fibreCard g ⟨(j : ℕ), hj⟩ := fwd_fib_head g ⟨(j : ℕ), hj⟩ + _ = α ⟨(j : ℕ), hj⟩ := hfilt.1 ⟨(j : ℕ), hj⟩ + · rw [dite_eq_right hj] + exact fwd_fib_tail g j hj + · ext x + simp only [Function.comp] + exact congrArg Fin.val (congrArg (Fin.castLE hNk) (congr_fun hfilt.2 x)) + +/-! ### Main theorem -/ + +open scoped Classical in +/-- **The padded Jacobi–Trudi character**: summing over `Perm (Fin k)` +for any `k` at least the row count gives the same value, the extra +indices contributing only through the terms their guard admits. -/ +theorem jtChar_pad (μ : YoungDiagram) {k : ℕ} + (hk : μ.rowLens.length ≤ k) (π : Equiv.Perm (Fin μ.card)) : + jtChar μ π = + ∑ σ : Equiv.Perm (Fin k), + ((Equiv.Perm.sign σ : ℤ) : ℂ) * + (if ∀ i : Fin k, + 0 ≤ (μ.rowLen (i : ℕ) : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) + then (colourChar + (fun i : Fin k => + ((μ.rowLen (i : ℕ) : ℤ) + ((σ i : Fin k) : ℕ) - + (i : ℕ)).toNat) π : ℂ) + else 0) + := by + classical + -- ═══════ SETUP: THE BIG TERM AND THE TAIL-FIXING PREDICATE ═══════ + set n := μ.rowLens.length with hn_def + -- The "big term" for σ : Perm (Fin k) + let bigTerm (σ : Equiv.Perm (Fin k)) : ℂ := + ((Equiv.Perm.sign σ : ℤ) : ℂ) * + (if ∀ i : Fin k, + 0 ≤ (μ.rowLen (i : ℕ) : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) + then (colourChar + (fun i : Fin k => + ((μ.rowLen (i : ℕ) : ℤ) + ((σ i : Fin k) : ℕ) - + (i : ℕ)).toNat) π : ℂ) + else 0) + -- The tail-fixing predicate + let tailFix (σ : Equiv.Perm (Fin k)) : Prop := + ∀ i : Fin k, n ≤ (i : ℕ) → σ i = i + -- ═══════ STAGE 1: NON-TAIL-FIXING TERMS VANISH ═══════ + have vanish : ∀ σ : Equiv.Perm (Fin k), ¬ tailFix σ → bigTerm σ = 0 := by + intro σ hσ + show bigTerm σ = 0 + simp only [bigTerm] + rw [show (if ∀ i : Fin k, 0 ≤ (μ.rowLen (i : ℕ) : ℤ) + ((σ i : Fin k) : ℕ) - + (i : ℕ) + then _ else (0 : ℂ)) = 0 from by + rw [ite_eq_right] + intro hguard + exact hσ (fun i hi => tail_fixed_of_guard μ hk σ hguard i (hn_def ▸ hi))] + simp + -- ═══════ STAGE 2: RESTRICT THE SUM TO THE TAIL-FIXING TERMS ═══════ + have filter_eq : ∑ σ : Equiv.Perm (Fin k), bigTerm σ = + ∑ σ ∈ Finset.univ.filter (fun σ : Equiv.Perm (Fin k) => tailFix σ), + bigTerm σ := by + symm + exact Finset.sum_filter_of_ne (fun σ _ hne => + by_contra fun h => hne (vanish σ h)) + -- ═══════ STAGE 3: THE SIGNED VALUE OF AN EXTENDED PERMUTATION ═══════ + have signed_eq : ∀ (σ' : Equiv.Perm (Fin n)) (i : Fin k), + (μ.rowLen (i : ℕ) : ℤ) + ((extendTail μ hk σ' i : ℕ) : ℤ) - ((i : ℕ) : ℤ) + = + if h : (i : ℕ) < n then jtSigned μ σ' ⟨(i : ℕ), h⟩ else 0 := by + intro σ' i + by_cases hi : (i : ℕ) < n + · rw [dite_eq_left hi] + have heqi : i = Fin.castLE hk ⟨(i : ℕ), hi⟩ := + Fin.ext (Fin.val_castLE hk ⟨(i : ℕ), hi⟩).symm + have hext : (extendTail μ hk σ' i : ℕ) = (σ' ⟨(i : ℕ), hi⟩ : ℕ) := by + conv_lhs => rw [heqi, extendTail_apply] + exact Fin.val_castLE hk _ + have hrow : μ.rowLen (i : ℕ) = μ.rowLens.get ⟨(i : ℕ), hi⟩ := + (get_rowLens_eq_rowLen μ ⟨(i : ℕ), hi⟩).symm + simp only [jtSigned, hext, hrow] + · rw [dite_eq_right hi] + push Not at hi + rw [extendTail_fixes_tail μ hk σ' i hi, rowLen_eq_zero_of_ge μ hi] + simp + -- Guard equivalence + have guard_iff : ∀ σ' : Equiv.Perm (Fin n), + (∀ i : Fin k, + 0 ≤ (μ.rowLen (i : ℕ) : ℤ) + ((extendTail μ hk σ' i : ℕ) : ℤ) - ((i : ℕ) + : ℤ)) ↔ + (∀ j : Fin n, 0 ≤ jtSigned μ σ' j) := by + intro σ' + constructor + · intro hbig j + have h1 := hbig (Fin.castLE hk j) + rw [signed_eq] at h1 + rwa [dite_eq_left (show (Fin.castLE hk j : ℕ) < n from by + rw [Fin.val_castLE]; exact j.isLt), + show (⟨(Fin.castLE hk j : ℕ), _⟩ : Fin n) = j from + Fin.ext (Fin.val_castLE hk j)] at h1 + · intro hsmall i + rw [signed_eq] + split + · next hi => exact hsmall ⟨(i : ℕ), hi⟩ + · exact le_refl 0 + -- Composition equality under guard + have comp_eq : ∀ (σ' : Equiv.Perm (Fin n)), + (∀ j : Fin n, 0 ≤ jtSigned μ σ' j) → + colourChar + (fun i : Fin k => + ((μ.rowLen (i : ℕ) : ℤ) + ((extendTail μ hk σ' i : ℕ) : ℤ) - + ((i : ℕ) : ℤ)).toNat) π = + colourChar (jtComp μ σ') π := by + intro σ' hguard + rw [colourChar_extend_zero hk (jtComp μ σ') (sum_jtComp μ σ' hguard) π] + congr 1; ext i + have hsig := signed_eq σ' i + by_cases hi : (i : ℕ) < n + · rw [dite_eq_left hi] at hsig; rw [dite_eq_left hi, hsig]; rfl + · rw [dite_eq_right hi] at hsig; rw [dite_eq_right hi, hsig]; simp + -- ═══════ ASSEMBLY ═══════ + calc jtChar μ π + = ∑ σ' : Equiv.Perm (Fin n), + ((Equiv.Perm.sign σ' : ℤ) : ℂ) * + (if ∀ i, 0 ≤ jtSigned μ σ' i + then (colourChar (jtComp μ σ') π : ℂ) else 0) := by + rfl + _ = ∑ σ ∈ Finset.univ.filter (fun σ : Equiv.Perm (Fin k) => tailFix σ), + bigTerm σ := by + apply Finset.sum_nbij' + (fun σ' => extendTail μ hk σ') + (fun σ => if h : tailFix σ then restrictHead μ hk σ h else 1) + · -- hi: extendTail maps univ into filter + intro σ' _ + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + exact fun i hi => extendTail_fixes_tail μ hk σ' i hi + · -- hj: j_map maps filter into univ + intro _ _; exact Finset.mem_univ _ + · -- left_inv + intro σ' _ + have hfix : tailFix (extendTail μ hk σ') := + fun i hi => extendTail_fixes_tail μ hk σ' i hi + rw [dite_eq_left hfix] + exact restrictHead_extendTail μ hk σ' + · -- right_inv + intro σ hσ + rw [dite_eq_left (Finset.mem_filter.mp hσ).2] + exact extendTail_restrictHead μ hk σ (Finset.mem_filter.mp hσ).2 + · -- term matching + intro σ' _ + change ((Equiv.Perm.sign σ' : ℤ) : ℂ) * + (if ∀ i, 0 ≤ jtSigned μ σ' i + then (colourChar (jtComp μ σ') π : ℂ) else 0) = + bigTerm (extendTail μ hk σ') + simp only [bigTerm] + rw [show Equiv.Perm.sign (extendTail μ hk σ') = Equiv.Perm.sign σ' + from + sign_extendTail μ hk σ'] + congr 1 + by_cases hguard : ∀ i, 0 ≤ jtSigned μ σ' i + · rw [ite_eq_left hguard, ite_eq_left ((guard_iff σ').mpr hguard)] + exact_mod_cast (comp_eq σ' hguard).symm + · rw [ite_eq_right hguard, + ite_eq_right (fun h => hguard ((guard_iff σ').mp h))] + _ = ∑ σ, bigTerm σ := filter_eq.symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTSimple.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTSimple.lean new file mode 100644 index 0000000000..b3ebda5bac --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTSimple.lean @@ -0,0 +1,34 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTIntChar +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTIrreducible + +/-! +# The Jacobi–Trudi character is plus-or-minus a native character +-/ + +@[expose] public section + +namespace RS + +open scoped Classical in +/-- **The Jacobi–Trudi character is `±` a single native +character.** -/ +theorem jtChar_pm_simple (μ : YoungDiagram) : + ∃ S₀ : Submodule (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) + (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))), + IsSimpleModule (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) + S₀ ∧ + ((∀ π, jtChar μ π = nChar S₀ π) ∨ + (∀ π, jtChar μ π = - nChar S₀ π)) := by + obtain ⟨J, hJ, ε, T, hT, hε, hchar⟩ := jtChar_eq_sum_sign_nChar μ + let := hJ + exact jt_pm_nChar μ ε T hT hchar + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/KillSimples.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/KillSimples.lean new file mode 100644 index 0000000000..a1017d9912 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/KillSimples.lean @@ -0,0 +1,60 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ScalarTrace + +/-! +# The faithfulness trick + +An element of the group algebra that kills every simple submodule +of the regular module is zero: by Maschke the regular module is a +supremum of simple submodules, so `1` decomposes as a finite sum +of elements of simples, and left multiplication kills each +summand. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {G : Type*} + +/-- **The faithfulness trick**: killing every simple submodule of +the regular module forces vanishing. -/ +theorem eq_zero_of_kills_simples [Group G] [Finite G] + (x : MonoidAlgebra ℂ G) + (hx : ∀ S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G), + IsSimpleModule (MonoidAlgebra ℂ G) S → + ∀ s ∈ S, x * s = 0) : + x = 0 := by + classical + let := Fintype.ofFinite G + have : NeZero ((Nat.card G : ℂ)) := ⟨by + rw [Nat.card_eq_fintype_card] + exact_mod_cast Fintype.card_ne_zero⟩ + have htop := IsSemisimpleModule.sSup_simples_eq_top + (R := MonoidAlgebra ℂ G) (M := MonoidAlgebra ℂ G) + have h1 : (1 : MonoidAlgebra ℂ G) ∈ + sSup {m : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G) | + IsSimpleModule (MonoidAlgebra ℂ G) m} := by + rw [htop] + trivial + rw [sSup_eq_iSup'] at h1 + rw [Submodule.mem_iSup_iff_exists_finsupp] at h1 + obtain ⟨f, hf, hsum⟩ := h1 + have hx1 : x * 1 = 0 := by + rw [← hsum] + rw [Finsupp.sum, Finset.mul_sum] + refine Finset.sum_eq_zero fun S _ => ?_ + exact hx S.1 S.2 (f S) (hf S) + rw [mul_one] at hx1 + exact hx1 + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedCount.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedCount.lean new file mode 100644 index 0000000000..dcb2b31251 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedCount.lean @@ -0,0 +1,147 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedFixed +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourWeight + +/-! +# Mixed fixed-point convolution + +Expresses the colour character of a lifted permutation as a convolution +over tail-content vectors. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv.Perm Fin + +open scoped Classical in +/-- The colour character of a lifted permutation is a convolution +over how the free tail is coloured. -/ +theorem colourChar_viaEmbedding {m n N : ℕ} (h : m ≤ n) + (σ : Equiv.Perm (Fin m)) (α : Fin N → ℕ) : + colourChar α (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ) = + ∑ w ∈ Fintype.piFinset (fun _ : Fin N => Finset.range (n + 1)), + (if ∀ a, w a ≤ α a then + colourChar (fun a => α a - w a) σ * + (Finset.univ.filter + (fun t : ({i : Fin n // m ≤ (i : ℕ)} → Fin N) => + ∀ a, (Finset.univ.filter (fun i => t i = a)).card + = w a)).card + else 0) := by + classical + set ι := Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ with ι_def + -- fibreCard decomposes through mixedFixedEquiv + have fib_decomp : ∀ (f : {f : Fin n → Fin N // f ∘ ⇑ι = f}) (a : Fin N), + fibreCard f.1 a = fibreCard ((mixedFixedEquiv h σ f).1).1 a + + (univ.filter (fun i : {i : Fin n // m ≤ (i : ℕ)} => + (mixedFixedEquiv h σ f).2 i = a)).card := by + intro f a + have := mixedFixedEquiv_symm_fibreCard h σ + (mixedFixedEquiv h σ f).1 (mixedFixedEquiv h σ f).2 a + rwa [Prod.mk.eta, Equiv.symm_apply_apply] at this + -- Core equivalence: LHS subtype ≃ product subtype with combined margin + have main_equiv : + {f : Fin n → Fin N // (∀ j, fibreCard f j = α j) ∧ f ∘ ⇑ι = f} ≃ + {p : {g : Fin m → Fin N // g ∘ ⇑σ = g} × ({i : Fin n // m ≤ (i : ℕ)} → Fin + N) // + ∀ a, fibreCard p.1.1 a + + (univ.filter (fun i : {i : Fin n // m ≤ (i : ℕ)} => p.2 i = a)).card = + α a} := + (Equiv.subtypeEquivRight (fun _ => And.comm)).trans + ((Equiv.subtypeSubtypeEquivSubtypeInter + (fun f : Fin n → Fin N => f ∘ ⇑ι = f) + (fun f => ∀ j, fibreCard f j = α j)).symm.trans + (Equiv.subtypeEquiv (mixedFixedEquiv h σ) (fun f => + ⟨fun hm a => by rw [← fib_decomp f a]; exact hm a, + fun hm a => by rw [fib_decomp f a]; exact hm a⟩))) + -- Convert LHS to Fintype.card of product subtype, then to filter card + have lhs_eq : colourChar α ι = + Fintype.card {p : {g : Fin m → Fin N // g ∘ ⇑σ = g} × + ({i : Fin n // m ≤ (i : ℕ)} → Fin N) // + ∀ a, fibreCard p.1.1 a + + (univ.filter (fun i : {i : Fin n // m ≤ (i : ℕ)} => p.2 i = a)).card = + α a} := by + change (univ.filter _).card = _ + rw [← Fintype.card_subtype] + exact Fintype.card_congr main_equiv + rw [lhs_eq, Fintype.card_subtype] + -- Set up partition machinery + set S := (univ : + Finset ({g : Fin m → Fin N // g ∘ ⇑σ = g} × ({i : Fin n // m ≤ (i : ℕ)} → + Fin N))).filter + (fun p => ∀ a, fibreCard p.1.1 a + + (univ.filter (fun i : {i : Fin n // m ≤ (i : ℕ)} => p.2 i = a)).card = α + a) with S_def + set cmap := fun (p : {g : Fin m → Fin N // g ∘ ⇑σ = g} × + ({i : Fin n // m ≤ (i : ℕ)} → Fin N)) (a : Fin N) => + (univ.filter (fun i : {i : Fin n // m ≤ (i : ℕ)} => p.2 i = a)).card + with cmap_def + set W := Fintype.piFinset (fun _ : Fin N => Finset.range (n + 1)) with W_def + -- cmap maps S into W + have hcmap_mem : ∀ p ∈ S, cmap p ∈ W := by + intro p _ + simp only [W_def, Fintype.mem_piFinset, mem_range, cmap_def] + intro a + have h1 : (univ.filter (fun i : {i : Fin n // m ≤ (i : ℕ)} => p.2 i = + a)).card ≤ + Fintype.card {i : Fin n // m ≤ (i : ℕ)} := by + rw [← card_univ]; exact card_filter_le _ _ + rw [card_tail h] at h1; omega + -- Partition by tail content + conv_lhs => + rw [show S.card = ∑ w ∈ W, (S.filter (fun p => cmap p = w)).card from + card_eq_sum_card_fiberwise hcmap_mem] + -- Per-fibre analysis + refine sum_congr rfl fun w _ => ?_ + by_cases hw : ∀ a, w a ≤ α a + · -- Case w ≤ α: factor the fibre as product of independent filters + rw [ite_eq_left hw] + -- Rewrite fibre as product + have fibre_eq : + S.filter (fun p => cmap p = w) = + (univ.filter (fun g : {g : Fin m → Fin N // g ∘ ⇑σ = g} => + ∀ a, fibreCard g.1 a = α a - w a)) ×ˢ + (univ.filter (fun t : {i : Fin n // m ≤ (i : ℕ)} → Fin N => + ∀ a, (univ.filter (fun i : {i : Fin n // m ≤ (i : ℕ)} => t i = + a)).card = w a)) := by + ext ⟨g, t⟩ + simp only [S_def, cmap_def, mem_filter, mem_univ, true_and, mem_product] + constructor + · rintro ⟨hm, hc⟩ + refine ⟨fun a => ?_, fun a => congr_fun hc a⟩ + have := hm a; rw [congr_fun hc a] at this; omega + · rintro ⟨hg, ht⟩ + refine ⟨fun a => ?_, funext ht⟩ + have hwa := hw a; rw [ht a, hg a]; omega + rw [fibre_eq, card_product] + -- First factor: colourChar connection + congr 1 + · rw [colourChar, ← Fintype.card_subtype, ← Fintype.card_subtype] + exact Fintype.card_congr + ((Equiv.subtypeSubtypeEquivSubtypeInter + (fun g : Fin m → Fin N => g ∘ ⇑σ = g) + (fun g => ∀ a, fibreCard g a = α a - w a)).trans + (Equiv.subtypeEquivRight (fun _ => And.comm))) + · -- Case w ≰ α: fibre is empty + rw [ite_eq_right hw, card_eq_zero, filter_eq_empty_iff] + intro ⟨g, t⟩ hp hcmap_eq + rw [S_def] at hp + simp only [mem_filter, mem_univ, true_and] at hp + rw [cmap_def] at hcmap_eq + simp only [not_forall, not_le] at hw + obtain ⟨a, ha⟩ := hw + have h1 := hp a + have h2 : (univ.filter (fun i : {i : Fin n // m ≤ (i : ℕ)} => t i = a)).card + = w a := + congr_fun hcmap_eq a + omega + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedFixed.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedFixed.lean new file mode 100644 index 0000000000..f7a627eaa3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedFixed.lean @@ -0,0 +1,148 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FibreCard + +/-! +# Mixed fixed-point decomposition + +Decomposes the subtype of colourings fixed by a lifted permutation +`viaEmbeddingHom (castLEEmb h) σ` into a product of the fixed colourings +on the first `m` coordinates and free colourings on the tail. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv.Perm Fin + +variable {m n N : ℕ} + +/-- The tail has the expected size. -/ +theorem card_tail (h : m ≤ n) : + Fintype.card {i : Fin n // m ≤ (i : ℕ)} = n - m := by + have : Fintype.card {i : Fin n // m ≤ (i : ℕ)} = + Fintype.card {i : Fin n // ¬ (i : ℕ) < m} := + Fintype.card_congr (Equiv.subtypeEquivRight (fun i => Nat.not_lt.symm)) + rw [this, Fintype.card_subtype_compl (p := fun i : Fin n => (i : ℕ) < m), + Fintype.card_fin, Fintype.card_fin_lt_of_le h] + +private theorem lift_castLE (h : m ≤ n) (σ : Equiv.Perm (Fin m)) (j : Fin m) : + (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ) (Fin.castLE h j) = + Fin.castLE h (σ j) := by + rw [Equiv.Perm.viaEmbeddingHom_apply] + exact Equiv.Perm.viaEmbedding_apply σ (Fin.castLEEmb h) j + +private theorem castLEEmb_range_subset (h : m ≤ n) (i : Fin n) + (hi : i ∈ Set.range (Fin.castLEEmb h)) : (i : ℕ) < m := by + obtain ⟨j, rfl⟩ := hi + exact j.2 + +open scoped Classical in +/-- **The fixed-point decomposition**: a colouring fixed by a lifted +permutation is a fixed colouring on the head together with a free +one on the tail, which the lift does not move. -/ +noncomputable def mixedFixedEquiv (h : m ≤ n) (σ : Equiv.Perm (Fin m)) : + {f : Fin n → Fin N // + f ∘ ⇑(Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ) = f} ≃ + {g : Fin m → Fin N // g ∘ ⇑σ = g} × + ({i : Fin n // m ≤ (i : ℕ)} → Fin N) where + toFun f := + (⟨f.1 ∘ Fin.castLE h, by + funext j + simp only [Function.comp_apply] + have hf := congr_fun f.2 (Fin.castLE h j) + simp only [Function.comp_apply] at hf + rw [lift_castLE h σ j] at hf + exact hf⟩, + fun i => f.1 i.1) + invFun p := + ⟨fun i => if hi : (i : ℕ) < m then p.1.1 ⟨i, hi⟩ else p.2 ⟨i, by omega⟩, by + funext i + simp only [Function.comp_apply] + by_cases hi : (i : ℕ) < m + · have heq : (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ) i = + Fin.castLE h (σ ⟨i, hi⟩) := by + conv_lhs => rw [show i = Fin.castLE h ⟨i, hi⟩ from Fin.ext (by simp)] + exact lift_castLE h σ ⟨i, hi⟩ + rw [heq] + have hσval : (Fin.castLE h (σ ⟨i, hi⟩) : ℕ) < m := (σ ⟨i, hi⟩).2 + rw [dite_eq_left hσval, dite_eq_left hi] + have hfix := congr_fun p.1.2 ⟨i, hi⟩ + simp only [Function.comp_apply] at hfix + rw [show (⟨↑(Fin.castLE h (σ ⟨↑i, hi⟩)), hσval⟩ : Fin m) = σ ⟨i, hi⟩ + from Fin.ext rfl] + exact hfix + · have hmem : i ∉ Set.range (Fin.castLEEmb h) := by + intro hmem; exact hi (castLEEmb_range_subset h i hmem) + rw [Equiv.Perm.viaEmbeddingHom_apply, + Equiv.Perm.viaEmbedding_apply_of_notMem σ (Fin.castLEEmb h) i hmem]⟩ + left_inv f := by + apply Subtype.ext; funext i; simp only + by_cases hi : (i : ℕ) < m + · rw [dite_eq_left hi]; simp only [Function.comp_apply]; congr 1 + · rw [dite_eq_right hi] + right_inv p := by + apply Prod.ext + · apply Subtype.ext; funext j; simp only [Function.comp_apply] + rw [dite_eq_left (show (Fin.castLE h j : ℕ) < m from j.2)]; congr 1 + · funext ⟨i, hi⟩; simp only + rw [dite_eq_right (show ¬ (i : ℕ) < m by omega)] + +/-- The colour counts add across the split. -/ +theorem mixedFixedEquiv_symm_fibreCard (h : m ≤ n) + (σ : Equiv.Perm (Fin m)) + (g : {g : Fin m → Fin N // g ∘ ⇑σ = g}) + (t : {i : Fin n // m ≤ (i : ℕ)} → Fin N) (c : Fin N) : + fibreCard ((mixedFixedEquiv h σ).symm (g, t)).1 c = + fibreCard g.1 c + + (Finset.univ.filter (fun i : {i : Fin n // m ≤ (i : ℕ)} => + t i = c)).card := by + classical + simp only [fibreCard] + rw [← Fintype.card_subtype, ← Fintype.card_subtype, + ← Fintype.card_subtype (fun i : {i : Fin n // m ≤ (i : ℕ)} => t i = c), + ← Fintype.card_sum] + apply Fintype.card_congr + -- {i : Fin n // F i = c} ≃ {j : Fin m // g j = c} ⊕ {s : tail // t s = c} + -- F = ((mixedFixedEquiv h σ).symm (g, t)).1, definitionally the dite function + have glue_eq : ∀ (i : Fin n), + ((mixedFixedEquiv h σ).symm (g, t)).1 i = + if hi : (i : ℕ) < m then g.1 ⟨i, hi⟩ + else t ⟨i, by omega⟩ := fun _ => rfl + refine { + toFun := fun ⟨i, hi⟩ => + if him : (i : ℕ) < m then + Sum.inl ⟨⟨i, him⟩, by rw [glue_eq, dite_eq_left him] at hi; exact hi⟩ + else + Sum.inr + ⟨⟨i, Nat.not_lt.mp him⟩, by rw [glue_eq, dite_eq_right him] at hi; exact hi⟩ + invFun := fun x => x.elim + (fun ⟨j, hj⟩ => ⟨Fin.castLE h j, by + have : (Fin.castLE h j : ℕ) < m := j.2 + rw [glue_eq, dite_eq_left this]; convert hj using 1; exact Fin.ext rfl⟩) + (fun ⟨s, hs⟩ => ⟨s.1, by + have : ¬ (s.1 : ℕ) < m := Nat.not_lt.mpr s.2 + rw [glue_eq, dite_eq_right this] + exact (congr_arg t (Subtype.ext rfl)).trans hs⟩) + left_inv := ?_ + right_inv := ?_ } + · rintro ⟨i, hi⟩ + simp only + split_ifs with him + · exact Subtype.ext rfl + · exact Subtype.ext rfl + · rintro (⟨j, hj⟩ | ⟨s, hs⟩) + · dsimp only [Sum.elim_inl] + rw [dite_eq_left (show (Fin.castLE h j : ℕ) < m from j.2)] + exact congr_arg Sum.inl (Subtype.ext (Fin.ext rfl)) + · dsimp only [Sum.elim_inr] + simp only [dite_eq_right (show ¬ (s.1 : ℕ) < m from Nat.not_lt.mpr s.2)] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeAction.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeAction.lean new file mode 100644 index 0000000000..cb11fa6f3f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeAction.lean @@ -0,0 +1,135 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BlockKill +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.EndSum + +/-! +# The native simple-submodule representation + +The representation of a simple submodule of the regular module, +carried on the canonically-instanced restricted-scalars subtype +via `Representation.ofModule'`: the algebra action is +definitionally scalar multiplication, so no transparency options +and no equivalence transport are needed. +-/ + +@[expose] public section + +namespace RS + +open Finset LinearMap + +variable {G : Type*} + +/-- The canonically-instanced carrier. -/ +abbrev subCarrier + [Group G] (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) : + Type _ := + ↥(S.restrictScalars ℂ) + +/-- The submodule carries the group-algebra action, definitionally +by scalar multiplication. -/ +noncomputable instance + [Group G] (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) : + Module (MonoidAlgebra ℂ G) + (subCarrier S) := + inferInstanceAs (Module (MonoidAlgebra ℂ G) ↥S) + +/-- The complex and group-algebra actions agree on scalars. -/ +instance [Group G] (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) : + IsScalarTower ℂ (MonoidAlgebra ℂ G) (subCarrier S) where + smul_assoc z y m := by + apply Subtype.ext + change ((z • y) • (m : MonoidAlgebra ℂ G)) = + z • (y • (m : MonoidAlgebra ℂ G)) + rw [smul_assoc] + +/-- The native representation of a submodule of the regular +module. -/ +noncomputable def rhoS + [Group G] (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) : + Representation ℂ G (subCarrier S) := + Representation.ofModule' (k := ℂ) (G := G) (subCarrier S) + +/-- The algebra action of the native representation is scalar +multiplication. -/ +theorem rhoS_asAlgebraHom_apply + [Group G] (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (y : MonoidAlgebra ℂ G) + (m : subCarrier S) : + (rhoS S).asAlgebraHom y m = y • m := by + rw [rhoS, Representation.asAlgebraHom_def, + Representation.ofModule'] + rw [Equiv.apply_symm_apply] + rfl + +/-- Its group action is scalar multiplication by the group +element. -/ +theorem rhoS_apply + [Group G] (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (g : G) (m : subCarrier S) : + rhoS S g m = (MonoidAlgebra.single g (1 : ℂ)) • m := by + have h := rhoS_asAlgebraHom_apply S + (MonoidAlgebra.single g 1) m + rw [show ((rhoS S).asAlgebraHom (MonoidAlgebra.single g 1)) m = + rhoS S g m from by + rw [Representation.asAlgebraHom_single, one_smul]] at h + exact h + +/-- The native representation of a simple submodule satisfies the +invariant-submodule irreducibility. -/ +theorem isIrredRep_rhoS + [Group G] (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (hS : IsSimpleModule (MonoidAlgebra ℂ G) S) : + IsIrredRep (rhoS S) := by + constructor + · -- Nontrivial + have := IsSimpleModule.nontrivial (MonoidAlgebra ℂ G) S + exact inferInstanceAs (Nontrivial ↥S) + · intro p hp + -- The invariant ℂ-subspace is a `ℂ[G]`-submodule. + have hclosed : ∀ (y : MonoidAlgebra ℂ G) (m : subCarrier S), + m ∈ p → y • m ∈ p := by + intro y + induction y using MonoidAlgebra.induction_on with + | of g => + intro m hm + have := hp g m hm + rw [rhoS_apply] at this + rw [show MonoidAlgebra.of ℂ G g = + MonoidAlgebra.single g (1 : ℂ) from rfl] + exact this + | add a b ha hb => + intro m hm + rw [add_smul] + exact p.add_mem (ha m hm) (hb m hm) + | smul r a ha => + intro m hm + rw [smul_assoc] + exact p.smul_mem r (ha m hm) + -- Transfer to the simple lattice. + set q : Submodule (MonoidAlgebra ℂ G) ↥S := + { carrier := (p : Set (subCarrier S)) + add_mem' := fun ha hb => p.add_mem ha hb + zero_mem' := p.zero_mem + smul_mem' := fun y {m} hm => hclosed y m hm } with hq + rcases hS.eq_bot_or_eq_top q with hb | ht + · left + apply (Submodule.eq_bot_iff _).mpr + intro m hm + have : m ∈ q := hm + rw [hb] at this + exact this + · right + apply Submodule.eq_top_iff'.mpr + intro m + have : m ∈ q := by rw [ht]; trivial + exact this + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeFaithful.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeFaithful.lean new file mode 100644 index 0000000000..557d93ba90 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeFaithful.lean @@ -0,0 +1,364 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeTable + +/-! +# Native block faithfulness + +The representation map of the native carrier is injective on the +block (kill criterion plus the faithfulness trick) and surjective +onto the submodule endomorphisms (dimension count over canonical +instances); the sandwich identity of a nonzero block element then +pulls back to express the projector in the two-sided ideal it +generates, so an algebra map vanishing on a block element but not +on the projector is impossible. +-/ + +@[expose] public section + +namespace RS + +open Finset LinearMap + +variable {G : Type*} + +/-- The native representation map. -/ +noncomputable abbrev nPsi + [Group G] (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) : + MonoidAlgebra ℂ G →ₐ[ℂ] Module.End ℂ (subCarrier S) := + (rhoS S).asAlgebraHom + +/-- The kill criterion for the native action. -/ +theorem nPsi_eq_zero_iff + [Group G] (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (y : MonoidAlgebra ℂ G) : + nPsi S y = 0 ↔ ∀ t ∈ S, y * t = 0 := by + constructor + · intro h0 t ht + have happ := congrFun (congrArg (fun (f : Module.End ℂ + (subCarrier S)) => (f : subCarrier S → subCarrier S)) h0) + ⟨t, mem_subCarrier S ht⟩ + rw [rhoS_asAlgebraHom_apply] at happ + have h2 := congrArg + (fun v : subCarrier S => (v : MonoidAlgebra ℂ G)) happ + rw [show ((y • (⟨t, mem_subCarrier S ht⟩ : subCarrier S) : + subCarrier S) : MonoidAlgebra ℂ G) = y * t from rfl] at h2 + rw [h2] + rfl + · intro hk + apply LinearMap.ext + intro m + rw [rhoS_asAlgebraHom_apply] + apply Subtype.ext + rw [show ((y • m : subCarrier S) : MonoidAlgebra ℂ G) = + y * (m : MonoidAlgebra ℂ G) from rfl] + rw [hk _ m.2] + rfl + +/-- Annihilation transports along equivalences of the native +representations. -/ +theorem kills_of_equiv_kills_native + [Group G] (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (T : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (hequiv : Nonempty ((rhoS S).Equiv (rhoS T))) + (y : MonoidAlgebra ℂ G) + (hy : ∀ s ∈ S, y * s = 0) : ∀ t ∈ T, y * t = 0 := by + obtain ⟨e⟩ := hequiv + rw [← nPsi_eq_zero_iff] at hy ⊢ + have hcomm := intertwiner_comp_asAlgebraHom + (e.toLinearEquiv : subCarrier S →ₗ[ℂ] subCarrier T) + (fun g => by + apply LinearMap.ext + intro v + exact congrFun (congrArg (fun (f : subCarrier S →ₗ[ℂ] + subCarrier T) => (f : subCarrier S → subCarrier T)) + (e.isIntertwining' g)) v) y + apply LinearMap.ext + intro m + have h2 := congrFun (congrArg (fun (f : subCarrier S →ₗ[ℂ] + subCarrier T) => (f : subCarrier S → subCarrier T)) hcomm) + (e.toLinearEquiv.symm m) + simp only [LinearMap.comp_apply] at h2 + rw [hy] at h2 + simp only [LinearMap.zero_apply, map_zero] at h2 + have h3 : (nPsi T y) (e.toLinearEquiv + (e.toLinearEquiv.symm m)) = 0 := h2.symm + rw [LinearEquiv.apply_symm_apply] at h3 + simpa using h3 + +open scoped Classical in +/-- A block element acting as zero on its simple kills every +simple submodule. -/ +theorem natBlock_kills_of_psi_zero [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (hS : IsSimpleModule (MonoidAlgebra ℂ G) S) + (x : MonoidAlgebra ℂ G) + (h0 : nPsi S (nProjector S * x) = 0) : + nProjector S * x = 0 := by + classical + have hkS := (nPsi_eq_zero_iff S _).mp h0 + refine eq_zero_of_kills_simples _ ?_ + intro T hT t ht + by_cases heq : Nonempty ((rhoS S).Equiv (rhoS T)) + · exact kills_of_equiv_kills_native S T heq _ hkS t ht + · rw [mul_assoc] + have hxt : x * t ∈ T := T.smul_mem x ht + rw [nProjector_mul_mem S T hS hT _ hxt, ite_eq_right heq, + zero_smul] + +open scoped Classical in +/-- The projector acts as the identity on its own simple. -/ +theorem nPsi_projector_eq_one [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (hS : IsSimpleModule (MonoidAlgebra ℂ G) S) : + nPsi S (nProjector S) = 1 := by + classical + apply LinearMap.ext + intro m + rw [show (nPsi S (nProjector S)) m = nProjector S • m from + rhoS_asAlgebraHom_apply S _ m] + apply Subtype.ext + rw [show ((nProjector S • m : subCarrier S) : + MonoidAlgebra ℂ G) = nProjector S * (m : MonoidAlgebra ℂ G) + from rfl] + rw [nProjector_mul_mem S S hS hS _ m.2] + rw [ite_eq_left ⟨Representation.Equiv.refl _⟩, one_smul] + rfl + +/-- The native block. -/ +noncomputable abbrev natBlock [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) : + Submodule ℂ (MonoidAlgebra ℂ G) := + LinearMap.range (mulLeft ℂ (nProjector S)) + +/-- The standard-coordinates equivalence of the carrier. -/ +noncomputable def stdEquiv [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) : + subCarrier S ≃ₗ[ℂ] (Fin (nDim S) → ℂ) := + (Module.finBasis ℂ (subCarrier S)).equivFun + +/-- The block map in standard coordinates. -/ +noncomputable def mPsi [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (y : MonoidAlgebra ℂ G) : + (Fin (nDim S) → ℂ) →ₗ[ℂ] (Fin (nDim S) → ℂ) := + ((stdEquiv S).toLinearMap.comp (nPsi S y)).comp + (stdEquiv S).symm.toLinearMap + +/-- The coordinate form of the block map, unfolded. -/ +theorem mPsi_apply [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (y : MonoidAlgebra ℂ G) + (v : Fin (nDim S) → ℂ) : + mPsi S y v = stdEquiv S (nPsi S y ((stdEquiv S).symm v)) := + rfl + +/-- It carries multiplication to composition. -/ +theorem mPsi_mul [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (y y' : MonoidAlgebra ℂ G) : + mPsi S (y * y') = (mPsi S y).comp (mPsi S y') := by + apply LinearMap.ext + intro v + rw [LinearMap.comp_apply, mPsi_apply, mPsi_apply, mPsi_apply] + rw [(stdEquiv S).symm_apply_apply] + rw [show nPsi S (y * y') = nPsi S y * nPsi S y' from + map_mul _ _ _] + rfl + +/-- It vanishes exactly when the block map does, the coordinates +being an isomorphism. -/ +theorem mPsi_zero_iff [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (y : MonoidAlgebra ℂ G) : + mPsi S y = 0 ↔ nPsi S y = 0 := by + constructor + · intro h0 + apply LinearMap.ext + intro m + have h2 := congrFun (congrArg (fun (f : (Fin (nDim S) → ℂ) + →ₗ[ℂ] (Fin (nDim S) → ℂ)) => (f : _ → _)) h0) + (stdEquiv S m) + rw [mPsi_apply, (stdEquiv S).symm_apply_apply] at h2 + have h3 := congrArg (stdEquiv S).symm h2 + simp only [LinearMap.zero_apply, map_zero, + LinearEquiv.symm_apply_apply] at h3 + simpa using h3 + · intro h0 + apply LinearMap.ext + intro v + rw [mPsi_apply, h0] + simp + +/-- The projector acts as the identity on the carrier. -/ +theorem mPsi_projector_eq_one [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (hS : IsSimpleModule (MonoidAlgebra ℂ G) S) : + mPsi S (nProjector S) = LinearMap.id := by + classical + apply LinearMap.ext + intro v + rw [mPsi_apply, nPsi_projector_eq_one S hS] + rw [show ((1 : Module.End ℂ (subCarrier S))) + ((stdEquiv S).symm v) = (stdEquiv S).symm v from rfl] + rw [(stdEquiv S).apply_symm_apply] + rfl + +/-- The standard-coordinates block map on the block. -/ +noncomputable def mPsiLin [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) : + natBlock S →ₗ[ℂ] + ((Fin (nDim S) → ℂ) →ₗ[ℂ] (Fin (nDim S) → ℂ)) where + toFun y := mPsi S y.1 + map_add' a b := by + apply LinearMap.ext + intro v + rw [show mPsi S ((a + b : natBlock S) : MonoidAlgebra ℂ G) = + mPsi S ((a : MonoidAlgebra ℂ G) + b) from rfl] + rw [mPsi_apply] + rw [show nPsi S ((a : MonoidAlgebra ℂ G) + b) = + nPsi S (a : MonoidAlgebra ℂ G) + nPsi S (b : MonoidAlgebra ℂ G) + from map_add _ _ _] + simp [mPsi_apply] + map_smul' c a := by + apply LinearMap.ext + intro v + rw [show mPsi S ((c • a : natBlock S) : MonoidAlgebra ℂ G) = + mPsi S (c • (a : MonoidAlgebra ℂ G)) from rfl] + rw [mPsi_apply] + rw [show nPsi S (c • (a : MonoidAlgebra ℂ G)) = + c • nPsi S (a : MonoidAlgebra ℂ G) from map_smul _ _ _] + simp [mPsi_apply] + +/-- The coordinate block map is injective. -/ +theorem mPsiLin_injective [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (hS : IsSimpleModule (MonoidAlgebra ℂ G) S) : + Function.Injective (mPsiLin S) := by + classical + intro a b hab + have hd : mPsiLin S (a - b) = 0 := by + rw [map_sub, hab, sub_self] + obtain ⟨w, hw⟩ := (a - b).2 + have h1 : nPsi S (nProjector S * w) = 0 := by + rw [show nProjector S * w = ((a - b : natBlock S) : + MonoidAlgebra ℂ G) from hw] + exact (mPsi_zero_iff S _).mp hd + have h2 := natBlock_kills_of_psi_zero S hS w h1 + have h3 : (a - b : natBlock S) = 0 := by + apply Subtype.ext + rw [← hw] + exact h2 + exact sub_eq_zero.mp h3 + +/-- And surjective onto the endomorphisms, by a dimension count — +so the block is the full matrix algebra of its carrier. -/ +theorem mPsiLin_surjective [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (hS : IsSimpleModule (MonoidAlgebra ℂ G) S) : + Function.Surjective (mPsiLin S) := by + classical + have hrk : Module.finrank ℂ (natBlock S) = + Module.finrank ℂ + ((Fin (nDim S) → ℂ) →ₗ[ℂ] (Fin (nDim S) → ℂ)) := by + rw [nProjector_block_rank S hS, Module.finrank_linearMap, + Module.finrank_pi, Fintype.card_fin, sq] + intro A + refine ⟨(LinearMap.linearEquivOfInjective (mPsiLin S) + (mPsiLin_injective S hS) hrk).symm A, ?_⟩ + exact (LinearMap.linearEquivOfInjective (mPsiLin S) + (mPsiLin_injective S hS) hrk).apply_symm_apply A + +open scoped Classical in +/-- **Native block faithfulness**: an algebra map that does not +kill the projector is injective on its block. -/ +theorem nProjector_block_faithful [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (hS : IsSimpleModule (MonoidAlgebra ℂ G) S) + {B : Type*} [Ring B] [Algebra ℂ B] + (φ : MonoidAlgebra ℂ G →ₐ[ℂ] B) + (hφ : φ (nProjector S) ≠ 0) + (x : MonoidAlgebra ℂ G) + (h0 : φ (nProjector S * x) = 0) : + nProjector S * x = 0 := by + classical + by_contra hne + have hA : mPsi S (nProjector S * x) ≠ 0 := by + intro hz + exact hne (natBlock_kills_of_psi_zero S hS x + ((mPsi_zero_iff S _).mp hz)) + obtain ⟨n, U, W, hUW⟩ := exists_sum_conj_eq_one + (V := Fin (nDim S) → ℂ) (mPsi S (nProjector S * x)) hA + choose u hup using fun i => mPsiLin_surjective S hS (U i) + choose w hwp using fun i => mPsiLin_surjective S hS (W i) + have hblock : ∀ i : Fin n, + ((u i : MonoidAlgebra ℂ G) * (nProjector S * x) * + (w i : MonoidAlgebra ℂ G)) ∈ natBlock S := by + intro i + obtain ⟨a, ha⟩ := (u i).2 + exact ⟨a * (nProjector S * x) * (w i : MonoidAlgebra ℂ G), + by + rw [← ha] + change nProjector S * (a * (nProjector S * x) * + (w i : MonoidAlgebra ℂ G)) = + nProjector S * a * (nProjector S * x) * + (w i : MonoidAlgebra ℂ G) + simp only [mul_assoc]⟩ + have hproj : nProjector S ∈ natBlock S := + ⟨nProjector S, nProjector_idem S hS⟩ + have hmem : (∑ i : Fin n, + ((u i : MonoidAlgebra ℂ G) * (nProjector S * x) * + (w i : MonoidAlgebra ℂ G))) ∈ natBlock S := + Submodule.sum_mem _ (fun i _ => hblock i) + have hsum : (∑ i : Fin n, + ((u i : MonoidAlgebra ℂ G) * (nProjector S * x) * + (w i : MonoidAlgebra ℂ G))) = nProjector S := by + have hsub : (⟨∑ i : Fin n, + ((u i : MonoidAlgebra ℂ G) * (nProjector S * x) * + (w i : MonoidAlgebra ℂ G)), hmem⟩ : natBlock S) = + ∑ i : Fin n, (⟨((u i : MonoidAlgebra ℂ G) * + (nProjector S * x) * (w i : MonoidAlgebra ℂ G)), + hblock i⟩ : natBlock S) := by + apply Subtype.ext + simp + have happly : mPsiLin S ⟨∑ i : Fin n, + ((u i : MonoidAlgebra ℂ G) * (nProjector S * x) * + (w i : MonoidAlgebra ℂ G)), hmem⟩ = + mPsiLin S ⟨nProjector S, hproj⟩ := by + rw [hsub, map_sum] + rw [show mPsiLin S (⟨nProjector S, hproj⟩ : natBlock S) = + mPsi S (nProjector S) from rfl] + rw [mPsi_projector_eq_one S hS] + rw [Finset.sum_congr rfl (fun i _ => show + mPsiLin S (⟨((u i : MonoidAlgebra ℂ G) * + (nProjector S * x) * (w i : MonoidAlgebra ℂ G)), + hblock i⟩ : natBlock S) = + U i * mPsi S (nProjector S * x) * W i from by + rw [show mPsiLin S (⟨((u i : MonoidAlgebra ℂ G) * + (nProjector S * x) * (w i : MonoidAlgebra ℂ G)), + hblock i⟩ : natBlock S) = + mPsi S ((u i : MonoidAlgebra ℂ G) * + (nProjector S * x) * (w i : MonoidAlgebra ℂ G)) + from rfl] + rw [mul_assoc] + rw [mPsi_mul, mPsi_mul] + rw [show mPsi S ((u i : MonoidAlgebra ℂ G)) = U i from + hup i] + rw [show mPsi S ((w i : MonoidAlgebra ℂ G)) = W i from + hwp i] + rfl)] + exact hUW + have hinj := mPsiLin_injective S hS happly + exact congrArg Subtype.val hinj + apply hφ + rw [← hsum, map_sum] + refine Finset.sum_eq_zero fun i _ => ?_ + rw [map_mul, map_mul, h0, mul_zero, zero_mul] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeTable.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeTable.lean new file mode 100644 index 0000000000..09d503ab55 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeTable.lean @@ -0,0 +1,242 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeAction + +/-! +# The native projector and its action table + +Character, dimension, and normalized projector of a simple +submodule on the native carrier; the scalar action, the +orthogonality-evaluated action table, idempotency, centrality, +and the block rank. +-/ + +@[expose] public section + +namespace RS + +open Finset LinearMap + +variable {G : Type*} + +/-- The character of a submodule of the regular module. -/ +noncomputable def nChar + [Group G] (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (g : G) : ℂ := + (rhoS S).character g + +/-- The dimension of a submodule of the regular module. -/ +noncomputable def nDim + [Group G] (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) : ℕ := + Module.finrank ℂ (subCarrier S) + +/-- The normalized projector coefficient. -/ +noncomputable def nCoeff [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) : G → ℂ := + fun g => ((nDim S : ℂ) / (Fintype.card G : ℂ)) * nChar S g⁻¹ + +/-- The normalized projector. -/ +noncomputable def nProjector [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) : + MonoidAlgebra ℂ G := + classElem (nCoeff S) + +/-- The native projector's coefficient is a class function. -/ +theorem nCoeff_classFun [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (g h : G) : + nCoeff S (h * g * h⁻¹) = nCoeff S g := by + rw [nCoeff, nCoeff] + congr 1 + rw [show (h * g * h⁻¹)⁻¹ = h * g⁻¹ * h⁻¹ from by group] + exact (rhoS S).char_conj g⁻¹ h + +/-- Membership transfer to the restricted-scalars form. -/ +theorem mem_subCarrier + [Group G] (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + {t : MonoidAlgebra ℂ G} (ht : t ∈ S) : + t ∈ S.restrictScalars ℂ := ht + +/-- **The native scalar action**: a class element multiplies each +element of a simple submodule by the character-pairing scalar. -/ +theorem classElem_mul_mem_native [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (hS : IsSimpleModule (MonoidAlgebra ℂ G) S) + (c : G → ℂ) (hc : ∀ g h : G, c (h * g * h⁻¹) = c g) + (t : MonoidAlgebra ℂ G) (ht : t ∈ S) : + classElem c * t = + ((∑ g : G, c g * nChar S g) / (nDim S : ℂ)) • t := by + classical + have hsc := classElem_scalar_eq (ρ := rhoS S) + (isIrredRep_rhoS S hS) c hc + have happ := congrFun (congrArg (fun (f : Module.End ℂ + (subCarrier S)) => (f : subCarrier S → subCarrier S)) hsc) + ⟨t, mem_subCarrier S ht⟩ + simp only [LinearMap.smul_apply, LinearMap.id_apply] at happ + rw [rhoS_asAlgebraHom_apply] at happ + have h2 := congrArg + (fun v : subCarrier S => (v : MonoidAlgebra ℂ G)) happ + rw [show ((classElem c • (⟨t, mem_subCarrier S ht⟩ : + subCarrier S) : subCarrier S) : MonoidAlgebra ℂ G) = + classElem c * t from rfl] at h2 + rw [h2] + rfl + +/-- The native representation of a simple submodule is +irreducible in the subrepresentation-lattice sense. -/ +theorem rhoS_isIrreducible + [Group G] (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (hS : IsSimpleModule (MonoidAlgebra ℂ G) S) : + (rhoS S).IsIrreducible := by + have hirr := isIrredRep_rhoS S hS + have hnt : Nontrivial (Subrepresentation (rhoS S)) := by + refine ⟨⟨⊥, ⊤, ?_⟩⟩ + have : Nontrivial (subCarrier S) := hirr.1 + intro hbt + have h1 := congrArg Subrepresentation.toSubmodule hbt + have h2 : (⊥ : Submodule ℂ (subCarrier S)) = + (⊤ : Submodule ℂ (subCarrier S)) := h1 + obtain ⟨x, y, hxy⟩ := exists_pair_ne (subCarrier S) + apply hxy + have hx : x ∈ (⊥ : Submodule ℂ (subCarrier S)) := by + rw [h2]; trivial + have hy : y ∈ (⊥ : Submodule ℂ (subCarrier S)) := by + rw [h2]; trivial + rw [Submodule.mem_bot] at hx hy + rw [hx, hy] + refine ⟨?_⟩ + intro σ + rcases hirr.2 σ.toSubmodule + (fun g v hv => σ.apply_mem_toSubmodule g hv) with hb | ht + · left + apply Subrepresentation.toSubmodule_injective + exact hb + · right + apply Subrepresentation.toSubmodule_injective + exact ht + +open scoped Classical in +/-- **The native action table**: the projector of a simple +submodule acts on each simple submodule as `1` or `0` by +equivalence. -/ +theorem nProjector_mul_mem [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (T : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (hS : IsSimpleModule (MonoidAlgebra ℂ G) S) + (hT : IsSimpleModule (MonoidAlgebra ℂ G) T) + (t : MonoidAlgebra ℂ G) (ht : t ∈ T) : + nProjector S * t = + (if Nonempty ((rhoS S).Equiv (rhoS T)) then (1 : ℂ) else 0) + • t := by + classical + have := rhoS_isIrreducible S hS + have := rhoS_isIrreducible T hT + rw [nProjector, classElem_mul_mem_native T hT _ + (nCoeff_classFun S) t ht] + congr 1 + have hcard0 : ((Nat.card G : ℂ)) ≠ 0 := by + rw [Nat.card_eq_fintype_card] + exact_mod_cast Fintype.card_ne_zero + have : Invertible ((Nat.card G : ℂ)) := invertibleOfNonzero hcard0 + have horth := Representation.char_orthonormal (rhoS T) (rhoS S) + have hcard : ((Nat.card G : ℂ)) ≠ 0 := by + rw [Nat.card_eq_fintype_card] + exact_mod_cast Fintype.card_ne_zero + have hsum : (∑ g : G, nCoeff S g * nChar T g) = + ((nDim S : ℂ) / (Fintype.card G : ℂ)) * + ∑ g : G, (rhoS T).character g * + (rhoS S).character g⁻¹ := by + rw [Finset.mul_sum] + refine Finset.sum_congr rfl fun g _ => ?_ + rw [nCoeff, nChar, nChar] + ring + have h2 : (∑ g : G, (rhoS T).character g * + (rhoS S).character g⁻¹) = + (Nat.card G : ℂ) * + (if Nonempty ((rhoS S).Equiv (rhoS T)) then 1 else 0) := by + rw [← horth, ← mul_assoc, mul_inv_cancel₀ hcard, one_mul] + rw [hsum, h2] + by_cases heq : Nonempty ((rhoS S).Equiv (rhoS T)) + · rw [ite_eq_left heq] + have hdim : nDim S = nDim T := by + obtain ⟨e⟩ := heq + exact e.toLinearEquiv.finrank_eq + rw [hdim, Nat.card_eq_fintype_card, mul_one] + have hd : ((nDim T : ℂ)) ≠ 0 := by + have : Nontrivial (subCarrier T) := + (isIrredRep_rhoS T hT).1 + have h1 := Module.finrank_pos + (R := ℂ) (M := subCarrier T) + exact_mod_cast Nat.cast_ne_zero.mpr h1.ne' + have hc : ((Fintype.card G : ℂ)) ≠ 0 := by + exact_mod_cast Fintype.card_ne_zero + field_simp + · rw [ite_eq_right heq] + simp + +open scoped Classical in +/-- **Idempotency of the native projector.** -/ +theorem nProjector_idem [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (hS : IsSimpleModule (MonoidAlgebra ℂ G) S) : + nProjector S * nProjector S = nProjector S := by + classical + have hkill : ∀ T : Submodule (MonoidAlgebra ℂ G) + (MonoidAlgebra ℂ G), + IsSimpleModule (MonoidAlgebra ℂ G) T → + ∀ t ∈ T, (nProjector S * nProjector S - + nProjector S) * t = 0 := by + intro T hT t ht + rw [sub_mul, mul_assoc] + rw [nProjector_mul_mem S T hS hT t ht] + rw [mul_smul_comm, nProjector_mul_mem S T hS hT t ht] + by_cases heq : Nonempty ((rhoS S).Equiv (rhoS T)) + · rw [ite_eq_left heq, one_smul, one_smul, sub_self] + · rw [ite_eq_right heq] + simp + have h0 := eq_zero_of_kills_simples _ hkill + exact sub_eq_zero.mp h0 + +/-- Centrality of the native projector. -/ +theorem nProjector_central [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (y : MonoidAlgebra ℂ G) : + nProjector S * y = y * nProjector S := by + classical + exact + classElem_mul_comm (nCoeff S) (nCoeff_classFun S) y + +/-- The projector's coefficient at the identity. -/ +theorem nProjector_coeff_one [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) : + (nProjector S).coeff 1 = + ((nDim S : ℂ) ^ 2) / (Fintype.card G : ℂ) := by + classical + rw [nProjector, classElem_coeff, nCoeff, inv_one] + rw [nChar, Representation.char_one] + rw [show Module.finrank ℂ (subCarrier S) = nDim S from rfl] + ring + +/-- **The native block rank.** -/ +theorem nProjector_block_rank [Group G] [Fintype G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (hS : IsSimpleModule (MonoidAlgebra ℂ G) S) : + Module.finrank ℂ + (LinearMap.range (mulLeft ℂ (nProjector S))) = + nDim S ^ 2 := by + classical + have h := finrank_range_mulLeft (nProjector S) + (nProjector_idem S hS) + rw [nProjector_coeff_one] at h + have hc : ((Fintype.card G : ℂ)) ≠ 0 := by + exact_mod_cast Fintype.card_ne_zero + rw [mul_div_cancel₀ _ hc] at h + exact_mod_cast h + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/OrbitBridge.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/OrbitBridge.lean new file mode 100644 index 0000000000..14e92e7658 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/OrbitBridge.lean @@ -0,0 +1,207 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SameCycleQuot + +/-! +# Orbit-size multiset identity + +The multiset of orbit sizes of a permutation `π : Equiv.Perm (Fin n)` equals +its cycle type plus singleton fixed-point orbits. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv Equiv.Perm + +variable {n : ℕ} + +/-! ## Helper lemmas -/ + +section Helpers + +variable (π : Equiv.Perm (Fin n)) + +/-- The fibre of a fixed-point orbit is a singleton. -/ +private lemma orbFibre_of_fixed {i : Fin n} (hi : π i = i) : + orbFibre π (orbitOf π i) = {i} := by + classical + ext j + simp only [mem_orbFibre, Finset.mem_singleton] + rw [eq_comm, orbitOf_eq_iff] + exact ⟨fun h => (h.eq_of_left hi).symm, fun h => h ▸ SameCycle.refl _ _⟩ + +/-- The fibre of a non-fixed-point orbit equals the `cycleOf` support. -/ +private lemma orbFibre_of_nonfixed {i : Fin n} (hi : π i ≠ i) : + orbFibre π (orbitOf π i) = (π.cycleOf i).support := by + classical + ext j + simp only [mem_orbFibre] + rw [eq_comm, orbitOf_eq_iff] + exact (mem_support_cycleOf_iff' hi).symm + +/-- An orbit has size 1 iff its representative is a fixed point. -/ +private lemma orbCard_orbitOf_eq_one (i : Fin n) : + orbCard π (orbitOf π i) = 1 ↔ π i = i := by + classical + constructor + · intro h + by_contra hi + rw [orbCard, orbFibre_of_nonfixed π hi] at h + exact absurd h (Nat.ne_of_gt (isCycle_cycleOf π hi).two_le_card_support) + · intro hi + rw [orbCard, orbFibre_of_fixed π hi, card_singleton] + +/-- A non-fixed-point orbit has size equal to the support of its `cycleOf`. -/ +private lemma orbCard_eq_cycleOf_support {i : Fin n} (hi : π i ≠ i) : + orbCard π (orbitOf π i) = (π.cycleOf i).support.card := by + classical + rw [orbCard, orbFibre_of_nonfixed π hi] + +/-- Pick a canonical representative from an orbit fibre. -/ +private noncomputable def orbRep (O : OrbitSpace π) : Fin n := + (orbFibre π O).min' (orbFibre_nonempty π O) + +private lemma orbRep_mem (O : OrbitSpace π) : orbitOf π (orbRep π O) = O := + (mem_orbFibre π).mp ((orbFibre π O).min'_mem (orbFibre_nonempty π O)) + +/-- Singleton orbits biject with fixed points of `π`. -/ +private lemma card_singleton_orbits : + ((Finset.univ : Finset (OrbitSpace π)).filter (fun O => orbCard π O = + 1)).card = + n - π.cycleType.sum := by + -- n - cycleType.sum = supportᶜ.card + suffices h : ((Finset.univ : Finset (OrbitSpace π)).filter + (fun O => orbCard π O = 1)).card = π.supportᶜ.card by + rwa [Finset.card_compl, Fintype.card_fin, ← sum_cycleType] at h + symm + apply Finset.card_bij (fun i _ => orbitOf π i) + · intro i hi + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + rw [Finset.mem_compl, mem_support, not_not] at hi + exact (orbCard_orbitOf_eq_one π i).mpr hi + · intro i hi j hj hij + rw [Finset.mem_compl, mem_support, not_not] at hi hj + exact ((orbitOf_eq_iff π).mp hij).eq_of_left hi + · intro O hO + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hO + obtain ⟨i, hi⟩ := orbFibre_nonempty π O + rw [mem_orbFibre] at hi + refine ⟨i, ?_, hi⟩ + rw [Finset.mem_compl, mem_support, not_not] + exact (orbCard_orbitOf_eq_one π i).mp (hi ▸ hO) + +/-- Big orbits (size ≥ 2) biject with cycle factors, preserving sizes. -/ +private lemma card_big_orbits_count (m : ℕ) (hm : 2 ≤ m) : + ((Finset.univ : Finset (OrbitSpace π)).filter (fun O => orbCard π O = + m)).card = + (π.cycleFactorsFinset.filter (fun c => c.support.card = m)).card := by + apply Finset.card_bij (fun O _ => π.cycleOf (orbRep π O)) + · -- MapsTo + intro O hO + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hO + rw [Finset.mem_filter] + set r := orbRep π O + have hr := orbRep_mem π O + have hr_supp : r ∈ π.support := by + rw [mem_support]; intro heq + have := hr ▸ (orbCard_orbitOf_eq_one π r).mpr heq; omega + refine ⟨cycleOf_mem_cycleFactorsFinset_iff.mpr hr_supp, ?_⟩ + rw [← orbCard_eq_cycleOf_support π (mem_support.mp hr_supp), hr, hO] + · -- Injective + intro O₁ hO₁ O₂ hO₂ heq + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hO₁ hO₂ + set r₁ := orbRep π O₁ + set r₂ := orbRep π O₂ + have hr₁ := orbRep_mem π O₁ + have hr₂ := orbRep_mem π O₂ + have hs₁ : r₁ ∈ π.support := by + rw [mem_support] + intro h + have := hr₁ ▸ (orbCard_orbitOf_eq_one π r₁).mpr h + omega + have hmem : r₁ ∈ (π.cycleOf r₂).support := by + rw [← heq, mem_support_cycleOf_iff' (mem_support.mp hs₁)] + rw [mem_support_cycleOf_iff] at hmem + rw [← hr₁, ← hr₂, (orbitOf_eq_iff π).mpr hmem.1.symm] + · -- Surjective + intro c hc + rw [Finset.mem_filter] at hc + obtain ⟨hc_mem, hc_card⟩ := hc + obtain ⟨a, ha⟩ := (mem_cycleFactorsFinset_iff.mp hc_mem).1.nonempty_support + have ha_supp : a ∈ π.support := mem_cycleFactorsFinset_support_le hc_mem ha + have hO_mem : orbitOf π a ∈ (Finset.univ : Finset (OrbitSpace π)).filter + (fun O => orbCard π O = m) := by + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + rw [orbCard_eq_cycleOf_support π (mem_support.mp ha_supp), + ← cycle_is_cycleOf ha hc_mem, hc_card] + refine ⟨orbitOf π a, hO_mem, ?_⟩ + set r := orbRep π (orbitOf π a) + have hr := orbRep_mem π (orbitOf π a) + have hsc : π.SameCycle r a := (orbitOf_eq_iff π).mp hr + rw [hsc.cycleOf_eq, (cycle_is_cycleOf ha hc_mem).symm] + +end Helpers + +/-! ## Main theorem -/ + +-- The orbit cardinality is computed by rewriting a +-- `Finset` sum into a `Multiset` count, which unfolds both sides +-- of the correspondence. +/-- The orbit sizes are the cycle type together with a singleton per +fixed point. -/ +theorem orbCard_multiset (π : Equiv.Perm (Fin n)) : + ((Finset.univ : Finset (OrbitSpace π)).val.map (orbCard π)) = + π.cycleType + Multiset.replicate (n - π.cycleType.sum) 1 := by + classical + ext m + simp only [Multiset.count_add, Multiset.count_map, Multiset.count_replicate] + -- Convert Multiset.filter to Finset.filter + have hconv : (Multiset.filter (fun a => m = orbCard π a) + (Finset.univ : Finset (OrbitSpace π)).val).card = + ((Finset.univ : Finset (OrbitSpace π)).filter (fun O => orbCard π O = + m)).card := by + congr 1; exact Multiset.filter_congr (fun _ _ => eq_comm) + rw [hconv] + by_cases hm0 : m = 0 + · -- m = 0: both sides are 0 + subst hm0 + have h1 : ((Finset.univ : Finset (OrbitSpace π)).filter + (fun O => orbCard π O = 0)).card = 0 := by + rw [Finset.card_eq_zero, Finset.filter_eq_empty_iff] + intro O _ + exact Nat.pos_of_ne_zero (fun h => absurd (orbCard_pos π O) (by omega)) + |>.ne' + rw [h1] + have h2 : Multiset.count 0 π.cycleType = 0 := + Multiset.count_eq_zero.mpr (fun h => absurd (two_le_of_mem_cycleType h) + (by omega)) + rw [h2, zero_add, ite_eq_right (by omega : ¬(1 : ℕ) = 0)] + by_cases hm1 : m = 1 + · -- m = 1 + subst hm1 + have ct_no_ones : Multiset.count 1 π.cycleType = 0 := + Multiset.count_eq_zero.mpr (fun h => absurd (two_le_of_mem_cycleType h) + (by omega)) + rw [ct_no_ones, zero_add, ite_eq_left rfl] + exact card_singleton_orbits π + · -- m ≥ 2 + have hm_ge2 : 2 ≤ m := by omega + rw [ite_eq_right (fun h : (1 : ℕ) = m => hm1 h.symm), add_zero] + rw [cycleType_def, Multiset.count_map] + have hconv2 : (Multiset.filter (fun a => m = (Finset.card ∘ + Equiv.Perm.support) a) + π.cycleFactorsFinset.val).card = + (π.cycleFactorsFinset.filter (fun c => c.support.card = m)).card := by + congr 1; exact Multiset.filter_congr (fun _ _ => by simp [eq_comm]) + rw [hconv2] + exact card_big_orbits_count π m hm_ge2 + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/Package.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/Package.lean new file mode 100644 index 0000000000..80180e7a13 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/Package.lean @@ -0,0 +1,34 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairingPos +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTPad +public import LeanPool.RegtsSevenster.RS.Common.FactorialBound + +/-! +# The Schur package, unconditionally + +Discharging the padding and branching inputs: the classical +symmetric-group representation theory consumed by the development +is a theorem of this tree. +-/ + +@[expose] public section + +namespace RS + +open scoped Classical in +/-- **The Schur package.** -/ +noncomputable def schurPackage : SchurPackage.{u} := + schurPackageOf three_pow_mul_factorial_ge + (fun lam mu hle h => + branching_of_pairing lam mu h + (restrPairing_ne_zero + (fun μ {_k} hk π => jtChar_pad μ hk π) lam mu hle h)) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PackageAssembly.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PackageAssembly.lean new file mode 100644 index 0000000000..f41505f83b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PackageAssembly.lean @@ -0,0 +1,95 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowth +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.IdempotentBridge +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeFaithful + +/-! +# Assembly of the Schur package + +The choice of a simple submodule realizing each Jacobi–Trudi +character, and the construction of a `SchurPackage` from the theory. +The branching field and the factorial bound enter as parameters, +discharged in `PairingPos.lean` and `Common/FactorialBound.lean`. +-/ + +@[expose] public section + +namespace RS + +open Finset + +open scoped Classical in +/-- The chosen simple submodule realizing `jtChar μ`. -/ +noncomputable def jtSimple (μ : YoungDiagram) : + Submodule (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) + (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) := + Classical.choose (jtChar_eq_nChar μ) + +open scoped Classical in +/-- The chosen submodule is simple. -/ +theorem jtSimple_simple (μ : YoungDiagram) : + IsSimpleModule (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) + (jtSimple μ) := + (Classical.choose_spec (jtChar_eq_nChar μ)).1 + +open scoped Classical in +/-- And its character is the Jacobi–Trudi one it was chosen for. -/ +theorem jtSimple_char (μ : YoungDiagram) : + ∀ π, jtChar μ π = nChar (jtSimple μ) π := + (Classical.choose_spec (jtChar_eq_nChar μ)).2 + +/-- The chosen idempotent is the native projector. -/ +theorem charIdempotent_jtSimple (μ : YoungDiagram) : + charIdempotent (nDim (jtSimple μ)) (jtChar μ) = + nProjector (jtSimple μ) := by + refine charIdempotent_eq_nProjector (jtSimple μ) (jtChar μ) + (jtSimple_char μ) (fun π => jtChar_inv μ π) + +/-- **The Schur package**, given the branching fact and the +factorial bound. -/ +noncomputable def schurPackageOf + (H3 : ∀ n : ℕ, n ^ n ≤ 3 ^ n * n.factorial) + (Hbranch : ∀ (lam mu : YoungDiagram), lam ≤ mu → + ∀ h : lam.card ≤ mu.card, + charIdempotent (nDim (jtSimple mu)) (jtChar mu) * + symCast h + (charIdempotent (nDim (jtSimple lam)) (jtChar lam)) * + charIdempotent (nDim (jtSimple mu)) (jtChar mu) ≠ 0) : + SchurPackage.{u} where + dim := fun μ => nDim (jtSimple μ) + char := fun μ => jtChar μ + dim_pos := fun μ => by + have := jtSimple_simple μ + have := IsSimpleModule.nontrivial + (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) (jtSimple μ) + have : Nontrivial (subCarrier (jtSimple μ)) := + inferInstanceAs (Nontrivial (jtSimple μ)) + exact Module.finrank_pos + central := fun μ x => by + rw [charIdempotent_jtSimple μ] + exact nProjector_central (jtSimple μ) x + idem := fun μ => by + rw [charIdempotent_jtSimple μ] + exact nProjector_idem (jtSimple μ) (jtSimple_simple μ) + block_rank := fun μ => by + rw [charIdempotent_jtSimple μ] + exact nProjector_block_rank (jtSimple μ) (jtSimple_simple μ) + block_faithful := fun μ B _ _ φ hφ x h0 => by + rw [charIdempotent_jtSimple μ] at hφ h0 ⊢ + exact nProjector_block_faithful (jtSimple μ) + (jtSimple_simple μ) φ hφ x h0 + branching := Hbranch + square_dim := fun R => by + obtain ⟨s, hs⟩ := square_growth H3 R + exact ⟨s, hs (jtSimple (squareDiagram s)) + (jtSimple_char (squareDiagram s))⟩ + frobenius := fun μ t => jtChar_frobenius' μ t + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairChar.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairChar.lean new file mode 100644 index 0000000000..e82ca23c7b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairChar.lean @@ -0,0 +1,57 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourWeight + +/-! +# The colour character of a pair + +The colour character is multiplicative in the colour vector: the +character of a pair of colourings is the product of the two +characters at the same permutation. +-/ + +@[expose] public section + +namespace RS + +open Finset + +open scoped Classical in +/-- **The colour character is multiplicative**: a product of two +characters counts the fixed pair-colourings with the two prescribed +margins. -/ +theorem colourChar_mul {n k : ℕ} (α β : Fin k → ℕ) (π : Equiv.Perm (Fin n)) : + colourChar α π * colourChar β π = + (Finset.univ.filter (fun p : Fin n → Fin k × Fin k => + (∀ a, fibreCard (fun i => (p i).1) a = α a) ∧ + (∀ b, fibreCard (fun i => (p i).2) b = β b) ∧ + p ∘ π = p)).card := by + unfold colourChar + rw [← card_product] + apply card_bij (fun (gh : (Fin n → Fin k) × (Fin n → Fin k)) _ => + fun i => (gh.1 i, gh.2 i)) + · -- forward membership + intro ⟨g, h⟩ hmem + simp only [mem_filter, mem_univ, true_and, mem_product] at hmem ⊢ + refine ⟨hmem.1.1, hmem.2.1, funext fun i => ?_⟩ + exact Prod.ext (congrFun hmem.1.2 i) (congrFun hmem.2.2 i) + · -- injectivity + intro ⟨g₁, h₁⟩ _ ⟨g₂, h₂⟩ _ heq + exact Prod.ext + (funext fun i => congrArg Prod.fst (congrFun heq i)) + (funext fun i => congrArg Prod.snd (congrFun heq i)) + · -- surjectivity + intro p hmem + refine ⟨(fun i => (p i).1, fun i => (p i).2), ?_, funext fun i + => Prod.mk.eta⟩ + simp only [mem_filter, mem_univ, true_and, mem_product] at hmem ⊢ + exact ⟨⟨hmem.1, funext fun i => congrArg Prod.fst (congrFun hmem.2.2 i)⟩, + ⟨hmem.2.1, funext fun i => congrArg Prod.snd (congrFun hmem.2.2 i)⟩⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairInner.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairInner.lean new file mode 100644 index 0000000000..b31385ba9e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairInner.lean @@ -0,0 +1,239 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairOrbit + +/-! +# The pair-colouring count with margins + +Summed over all permutations, the number of fixed pair colourings +with prescribed row and column margins is `n!` times the number of +pair contents with those margins: Fubini, the pair stabilizer +count, content grouping, and orbit–stabilizer. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv + +variable {n k : ℕ} + +/-- The pair content as a symmetric power. -/ +def pairContentSym (p : Fin n → Fin k × Fin k) : + Sym (Fin k × Fin k) n := + ⟨pairContent p, by + rw [pairContent, Multiset.card_map] + simp⟩ + +/-- Every pair content is realized. -/ +theorem pair_exists_content (s : Sym (Fin k × Fin k) n) : + ∃ p : Fin n → Fin k × Fin k, pairContentSym p = s := by + classical + have hlen : s.1.toList.length = n := by + rw [Multiset.length_toList] + exact s.2 + refine ⟨fun i => s.1.toList.get ⟨i.1, by omega⟩, + Subtype.ext ?_⟩ + rw [show (pairContentSym (fun i : Fin n => + s.1.toList.get ⟨i.1, by omega⟩)).1 = + Finset.univ.val.map (fun i : Fin n => + s.1.toList.get ⟨i.1, by omega⟩) from rfl] + rw [Fin.univ_val_map] + rw [show (List.ofFn fun i : Fin n => + s.1.toList.get ⟨↑i, by omega⟩) = s.1.toList from by + apply List.ext_get + · simp + · intro i hi₁ hi₂ + simp] + exact Multiset.coe_toList s.1 + +/-- Margins are determined by the content. -/ +theorem margin_fst_of_content (p : Fin n → Fin k × Fin k) + (a : Fin k) : + fibreCard (fun i => (p i).1) a = + ∑ b : Fin k, (pairContentSym p).1.count (a, b) := by + classical + rw [fibreCard_fst_eq_sum] + exact Finset.sum_congr rfl fun b _ => pairFibre_eq_count p (a, b) + +/-- The second-coordinate analogue. -/ +theorem margin_snd_of_content (p : Fin n → Fin k × Fin k) + (b : Fin k) : + fibreCard (fun i => (p i).2) b = + ∑ a : Fin k, (pairContentSym p).1.count (a, b) := by + classical + rw [fibreCard_snd_eq_sum] + exact Finset.sum_congr rfl fun a _ => pairFibre_eq_count p (a, b) + +open scoped Classical in +/-- **The pair-colouring count with margins.** -/ +theorem pair_count_sum (α β : Fin k → ℕ) : + (∑ π : Equiv.Perm (Fin n), + (Finset.univ.filter (fun p : Fin n → Fin k × Fin k => + (∀ a, fibreCard (fun i => (p i).1) a = α a) ∧ + (∀ b, fibreCard (fun i => (p i).2) b = β b) ∧ + p ∘ π = p)).card) = + n.factorial * Fintype.card {s : Sym (Fin k × Fin k) n // + (∀ a, (∑ b : Fin k, s.1.count (a, b)) = α a) ∧ + (∀ b, (∑ a : Fin k, s.1.count (a, b)) = β b)} := by + classical + -- ═══════ STAGE 1: FUBINI ON THE TWO SUMS ═══════ + have h1 : (∑ π : Equiv.Perm (Fin n), + (Finset.univ.filter (fun p : Fin n → Fin k × Fin k => + (∀ a, fibreCard (fun i => (p i).1) a = α a) ∧ + (∀ b, fibreCard (fun i => (p i).2) b = β b) ∧ + p ∘ π = p)).card) = + ∑ p ∈ Finset.univ.filter (fun p : Fin n → Fin k × Fin k => + (∀ a, fibreCard (fun i => (p i).1) a = α a) ∧ + (∀ b, fibreCard (fun i => (p i).2) b = β b)), + (Finset.univ.filter + (fun π : Equiv.Perm (Fin n) => p ∘ π = p)).card := by + calc (∑ π : Equiv.Perm (Fin n), + (Finset.univ.filter (fun p : Fin n → Fin k × Fin k => + (∀ a, fibreCard (fun i => (p i).1) a = α a) ∧ + (∀ b, fibreCard (fun i => (p i).2) b = β b) ∧ + p ∘ π = p)).card) + = ∑ π : Equiv.Perm (Fin n), + ∑ p : Fin n → Fin k × Fin k, + (if ((∀ a, fibreCard (fun i => (p i).1) a = α a) ∧ + (∀ b, fibreCard (fun i => (p i).2) b = β b)) ∧ + p ∘ π = p + then 1 else 0) := by + refine Finset.sum_congr rfl fun π _ => ?_ + rw [Finset.card_filter] + refine Finset.sum_congr rfl fun p _ => ?_ + by_cases hm : (∀ a, fibreCard (fun i => (p i).1) a = + α a) ∧ (∀ b, fibreCard (fun i => (p i).2) b = β b) + · by_cases hf : p ∘ π = p + · rw [ite_eq_left ⟨hm.1, hm.2, hf⟩, ite_eq_left ⟨hm, hf⟩] + · rw [ite_eq_right (fun hc => hf hc.2.2), + ite_eq_right (fun hc => hf hc.2)] + · rw [ite_eq_right (fun hc => hm ⟨hc.1, hc.2.1⟩), + ite_eq_right (fun hc => hm hc.1)] + _ = ∑ p : Fin n → Fin k × Fin k, + ∑ π : Equiv.Perm (Fin n), + (if ((∀ a, fibreCard (fun i => (p i).1) a = α a) ∧ + (∀ b, fibreCard (fun i => (p i).2) b = β b)) ∧ + p ∘ π = p + then 1 else 0) := Finset.sum_comm + _ = ∑ p ∈ Finset.univ.filter + (fun p : Fin n → Fin k × Fin k => + (∀ a, fibreCard (fun i => (p i).1) a = α a) ∧ + (∀ b, fibreCard (fun i => (p i).2) b = β b)), + (Finset.univ.filter + (fun π : Equiv.Perm (Fin n) => p ∘ π = p)).card := by + rw [Finset.sum_filter] + refine Finset.sum_congr rfl fun p _ => ?_ + by_cases hm : (∀ a, fibreCard (fun i => (p i).1) a = + α a) ∧ (∀ b, fibreCard (fun i => (p i).2) b = β b) + · rw [ite_eq_left hm, Finset.card_filter] + refine Finset.sum_congr rfl fun π _ => ?_ + by_cases hf : p ∘ π = p + · rw [ite_eq_left ⟨hm, hf⟩, ite_eq_left hf] + · rw [ite_eq_right (fun hc => hf hc.2), ite_eq_right hf] + · rw [ite_eq_right hm] + rw [Finset.sum_eq_zero fun π _ => + ite_eq_right (fun hc => hm hc.1)] + rw [h1] + -- ═══════ STAGE 2: THE STABILIZER COUNT PER COLOURING ═══════ + rw [Finset.sum_congr rfl (fun p _ => card_fixing_pairs p)] + -- ═══════ STAGE 3: GROUP THE COLOURINGS BY CONTENT ═══════ + rw [show (∑ p ∈ Finset.univ.filter + (fun p : Fin n → Fin k × Fin k => + (∀ a, fibreCard (fun i => (p i).1) a = α a) ∧ + (∀ b, fibreCard (fun i => (p i).2) b = β b)), + ∏ c : Fin k × Fin k, (pairFibre p c).factorial) = + ∑ p : Fin n → Fin k × Fin k, + (if (∀ a, (∑ b : Fin k, + (pairContentSym p).1.count (a, b)) = α a) ∧ + (∀ b, (∑ a : Fin k, + (pairContentSym p).1.count (a, b)) = β b) + then ∏ c : Fin k × Fin k, + ((pairContentSym p).1.count c).factorial + else 0) from by + rw [Finset.sum_filter] + refine Finset.sum_congr rfl fun p _ => ?_ + have hiff : ((∀ a, fibreCard (fun i => (p i).1) a = α a) ∧ + (∀ b, fibreCard (fun i => (p i).2) b = β b)) ↔ + ((∀ a, (∑ b : Fin k, + (pairContentSym p).1.count (a, b)) = α a) ∧ + (∀ b, (∑ a : Fin k, + (pairContentSym p).1.count (a, b)) = β b)) := by + constructor + · intro hm + exact ⟨fun a => by + rw [← margin_fst_of_content]; exact hm.1 a, + fun b => by + rw [← margin_snd_of_content]; exact hm.2 b⟩ + · intro hm + exact ⟨fun a => by + rw [margin_fst_of_content]; exact hm.1 a, + fun b => by + rw [margin_snd_of_content]; exact hm.2 b⟩ + by_cases hm : (∀ a, fibreCard (fun i => (p i).1) a = α a) ∧ + (∀ b, fibreCard (fun i => (p i).2) b = β b) + · rw [ite_eq_left hm, ite_eq_left (hiff.mp hm)] + refine Finset.prod_congr rfl fun c _ => ?_ + rw [pairFibre_eq_count] + rfl + · rw [ite_eq_right hm, ite_eq_right (fun hc => hm (hiff.mpr hc))]] + rw [← Fintype.sum_fiberwise pairContentSym + (fun p => (if (∀ a, (∑ b : Fin k, + (pairContentSym p).1.count (a, b)) = α a) ∧ + (∀ b, (∑ a : Fin k, + (pairContentSym p).1.count (a, b)) = β b) + then ∏ c : Fin k × Fin k, + ((pairContentSym p).1.count c).factorial + else 0))] + -- ═══════ STAGE 4: EVALUATE ONE CONTENT CLASS ═══════ + have hclass : ∀ s : Sym (Fin k × Fin k) n, + (∑ p : {p : Fin n → Fin k × Fin k // pairContentSym p = s}, + (if (∀ a, (∑ b : Fin k, + (pairContentSym p.1).1.count (a, b)) = α a) ∧ + (∀ b, (∑ a : Fin k, + (pairContentSym p.1).1.count (a, b)) = β b) + then ∏ c : Fin k × Fin k, + ((pairContentSym p.1).1.count c).factorial + else 0)) = + if (∀ a, (∑ b : Fin k, s.1.count (a, b)) = α a) ∧ + (∀ b, (∑ a : Fin k, s.1.count (a, b)) = β b) + then n.factorial else 0 := by + intro s + obtain ⟨p₀, hp₀⟩ := pair_exists_content s + rw [Finset.sum_congr rfl + (fun (p : {p : Fin n → Fin k × Fin k // + pairContentSym p = s}) (_ : p ∈ Finset.univ) => by + rw [p.2])] + rw [Finset.sum_const, Finset.card_univ, smul_eq_mul] + by_cases hm : (∀ a, (∑ b : Fin k, s.1.count (a, b)) = α a) ∧ + (∀ b, (∑ a : Fin k, s.1.count (a, b)) = β b) + · rw [ite_eq_left hm, ite_eq_left hm] + have h := pair_orbit_stab p₀ + have hv : pairContent p₀ = s.1 := congrArg Subtype.val hp₀ + rw [hv] at h + have hc : Fintype.card + {p : Fin n → Fin k × Fin k // pairContentSym p = s} = + Fintype.card + {p : Fin n → Fin k × Fin k // pairContent p = s.1} := + Fintype.card_congr (Equiv.subtypeEquivRight fun p => + ⟨fun h' => congrArg Subtype.val h', + fun h' => Subtype.ext h'⟩) + rw [hc] + exact h + · rw [ite_eq_right hm, ite_eq_right hm, mul_zero] + rw [Finset.sum_congr rfl + (fun (s : Sym (Fin k × Fin k) n) (_ : s ∈ Finset.univ) => + hclass s)] + -- ═══════ ASSEMBLY: TOTAL OVER THE MARGIN CLASSES ═══════ + rw [Finset.sum_ite, Finset.sum_const_zero, add_zero, + Finset.sum_const, smul_eq_mul, mul_comm, + Fintype.card_subtype] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairOrbit.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairOrbit.lean new file mode 100644 index 0000000000..01a96c82d1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairOrbit.lean @@ -0,0 +1,162 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairStab + +/-! +# Orbit–stabilizer for pair colourings + +Pair contents, the orbit–stabilizer identity for pair-colouring +classes (transported along `finProdFinEquiv`), and the +fibre-margin partition. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv + +variable {n k : ℕ} + +/-- The content multiset of a pair colouring. -/ +def pairContent (p : Fin n → Fin k × Fin k) : + Multiset (Fin k × Fin k) := + Finset.univ.val.map p + +/-- A pair-colouring's fibre size is the pair's multiplicity in its +content. -/ +theorem pairFibre_eq_count (p : Fin n → Fin k × Fin k) + (c : Fin k × Fin k) : + pairFibre p c = (pairContent p).count c := by + classical + rw [pairFibre, pairContent, Multiset.count_map] + rw [Multiset.filter_congr + (fun x _ => (eq_comm : c = p x ↔ p x = c))] + rfl + +/-- Content of the transported colouring. -/ +theorem content_comp_equiv (p : Fin n → Fin k × Fin k) : + (content (finProdFinEquiv ∘ p)).1 = + (pairContent p).map finProdFinEquiv := by + rw [content, pairContent] + change Finset.univ.val.map (finProdFinEquiv ∘ p) = _ + rw [← Multiset.map_map] + +open scoped Classical in +/-- **Orbit–stabilizer for pair classes**: the class size times the +content factorial product is `n!`. -/ +theorem pair_orbit_stab (p₀ : Fin n → Fin k × Fin k) : + Fintype.card {p : Fin n → Fin k × Fin k // + pairContent p = pairContent p₀} * + ∏ c : Fin k × Fin k, + ((pairContent p₀).count c).factorial = n.factorial := by + classical + have h := orbit_stab (finProdFinEquiv ∘ p₀) + (card_fixing_perms (finProdFinEquiv ∘ p₀)) + have hkey : ∀ g : Fin n → Fin (k * k), + (content g).1 = + (pairContent (fun i => finProdFinEquiv.symm (g i))).map + finProdFinEquiv := by + intro g + have h1 := content_comp_equiv + (fun i => finProdFinEquiv.symm (g i)) + rw [show (finProdFinEquiv ∘ fun i => + finProdFinEquiv.symm (g i)) = g from + funext fun i => Equiv.apply_symm_apply _ _] at h1 + exact h1 + have hcardeq : + Fintype.card {g : Fin n → Fin (k * k) // + content g = content (finProdFinEquiv ∘ p₀)} = + Fintype.card {p : Fin n → Fin k × Fin k // + pairContent p = pairContent p₀} := by + apply Fintype.card_congr + refine Equiv.subtypeEquiv + (Equiv.arrowCongr (Equiv.refl (Fin n)) + finProdFinEquiv).symm (fun g => ?_) + rw [show ((Equiv.arrowCongr (Equiv.refl (Fin n)) + finProdFinEquiv).symm g : Fin n → Fin k × Fin k) = + fun i => finProdFinEquiv.symm (g i) from rfl] + constructor + · intro hc + apply Multiset.map_injective finProdFinEquiv.injective + rw [← hkey g, ← content_comp_equiv p₀] + exact congrArg Subtype.val hc + · intro hc + apply Subtype.ext + rw [hkey g, content_comp_equiv p₀, hc] + have hcnt : ∀ j : Fin (k * k), + ((pairContent p₀).map finProdFinEquiv).count j = + (pairContent p₀).count (finProdFinEquiv.symm j) := by + intro j + conv_lhs => rw [show j = + finProdFinEquiv (finProdFinEquiv.symm j) from + (Equiv.apply_symm_apply _ _).symm] + exact Multiset.count_map_eq_count' _ _ + finProdFinEquiv.injective _ + have hprodeq : + (∏ j : Fin (k * k), + ((content (finProdFinEquiv ∘ p₀)).1.count j).factorial) = + ∏ c : Fin k × Fin k, + ((pairContent p₀).count c).factorial := by + rw [show (∏ j : Fin (k * k), + ((content (finProdFinEquiv ∘ p₀)).1.count j).factorial) = + ∏ j : Fin (k * k), + (((pairContent p₀).map finProdFinEquiv).count + j).factorial from by rw [content_comp_equiv]] + rw [Finset.prod_congr rfl + (fun j (_ : j ∈ Finset.univ) => by rw [hcnt j])] + exact Equiv.prod_comp finProdFinEquiv.symm + (fun c => ((pairContent p₀).count c).factorial) + rw [hcardeq, hprodeq] at h + exact h + +open scoped Classical in +/-- **The fibre-margin partition**: a first-coordinate fibre size +is the row sum of the pair fibres. -/ +theorem fibreCard_fst_eq_sum (p : Fin n → Fin k × Fin k) + (a : Fin k) : + fibreCard (fun i => (p i).1) a = + ∑ b : Fin k, pairFibre p (a, b) := by + classical + rw [fibreCard] + rw [Finset.card_eq_sum_card_fiberwise + (f := fun i => (p i).2) (t := Finset.univ) + (fun i _ => Finset.mem_univ _)] + refine Finset.sum_congr rfl fun b _ => ?_ + rw [pairFibre, Finset.filter_filter] + congr 1 + refine Finset.filter_congr fun i _ => ?_ + constructor + · intro hi + exact Prod.ext hi.1 hi.2 + · intro hi + exact ⟨congrArg Prod.fst hi, congrArg Prod.snd hi⟩ + +open scoped Classical in +/-- The second-coordinate analogue. -/ +theorem fibreCard_snd_eq_sum (p : Fin n → Fin k × Fin k) + (b : Fin k) : + fibreCard (fun i => (p i).2) b = + ∑ a : Fin k, pairFibre p (a, b) := by + classical + rw [fibreCard] + rw [Finset.card_eq_sum_card_fiberwise + (f := fun i => (p i).1) (t := Finset.univ) + (fun i _ => Finset.mem_univ _)] + refine Finset.sum_congr rfl fun a _ => ?_ + rw [pairFibre, Finset.filter_filter] + congr 1 + refine Finset.filter_congr fun i _ => ?_ + constructor + · intro hi + exact Prod.ext hi.2 hi.1 + · intro hi + exact ⟨congrArg Prod.snd hi, congrArg Prod.fst hi⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairStab.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairStab.lean new file mode 100644 index 0000000000..4baac7d506 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairStab.lean @@ -0,0 +1,75 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourWeight + +/-! +# Stabilizer counts for pair colourings + +The stabilizer count for colourings by pairs, transported along +`finProdFinEquiv` from the `Fin`-codomain machinery. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv + +variable {n k : ℕ} + +open scoped Classical in +/-- The fibre size of a pair colouring over a pair colour. -/ +noncomputable def pairFibre (p : Fin n → Fin k × Fin k) + (c : Fin k × Fin k) : ℕ := + (Finset.univ.filter (fun i => p i = c)).card + +open scoped Classical in +/-- **The pair stabilizer count**: permutations fixing a pair +colouring number the product of its fibre factorials. -/ +theorem card_fixing_pairs (p : Fin n → Fin k × Fin k) : + (Finset.univ.filter + (fun π : Equiv.Perm (Fin n) => p ∘ π = p)).card = + ∏ c : Fin k × Fin k, (pairFibre p c).factorial := by + classical + have hcond : ∀ π : Equiv.Perm (Fin n), + ((finProdFinEquiv ∘ p) ∘ π = finProdFinEquiv ∘ p) ↔ + (p ∘ π = p) := by + intro π + constructor + · intro h + funext i + have h1 := congrFun h i + exact finProdFinEquiv.injective h1 + · intro h + funext i + have h1 := congrFun h i + change finProdFinEquiv (p (π i)) = finProdFinEquiv (p i) + rw [show p (π i) = p i from h1] + have h1 : (Finset.univ.filter + (fun π : Equiv.Perm (Fin n) => p ∘ π = p)).card = + (Finset.univ.filter + (fun π : Equiv.Perm (Fin n) => + (finProdFinEquiv ∘ p) ∘ π = finProdFinEquiv ∘ p)).card := by + congr 1 + exact Finset.filter_congr fun π _ => (hcond π).symm + rw [h1, card_fixing_perms (finProdFinEquiv ∘ p)] + have h2 : ∀ j : Fin (k * k), + fibreCard (finProdFinEquiv ∘ p) j = + pairFibre p (finProdFinEquiv.symm j) := by + intro j + rw [fibreCard, pairFibre] + congr 1 + refine Finset.filter_congr fun i _ => ?_ + change finProdFinEquiv (p i) = j ↔ p i = finProdFinEquiv.symm j + exact (Equiv.eq_symm_apply finProdFinEquiv).symm + rw [Finset.prod_congr rfl (fun j _ => by rw [h2 j])] + exact Equiv.prod_comp finProdFinEquiv.symm + (fun c => (pairFibre p c).factorial) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairTuple.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairTuple.lean new file mode 100644 index 0000000000..684fa5f80b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairTuple.lean @@ -0,0 +1,146 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairInner + +/-! +# Pair-content to tuple equivalence + +The set of pair-contents with prescribed row and column margins bijects +with the set of row-wise multisets with matching column margins. +-/ + +@[expose] public section + +namespace RS + +open Finset + +section Helpers + +variable {k : ℕ} + +/-- Sum of counts over a full Fintype equals card. -/ +private theorem sum_count_univ_gen {γ : Type*} [Fintype γ] [DecidableEq γ] + (m : Multiset γ) : ∑ j : γ, m.count j = Multiset.card m := by + rw [← Multiset.toFinset_sum_count_eq m] + exact (Finset.sum_subset (Finset.subset_univ _) + (fun a _ ha => Multiset.count_eq_zero.mpr + (fun hmem => ha (Multiset.mem_toFinset.mpr hmem)))).symm + +/-- Filtering by first component and mapping to second preserves count. -/ +private theorem filter_fst_map_snd_count + (m : Multiset (Fin k × Fin k)) (a b : Fin k) : + ((m.filter (fun c => c.1 = a)).map Prod.snd).count b = m.count (a, b) := by + rw [Multiset.count_map, Multiset.filter_filter] + rw [show Multiset.filter (fun c => b = Prod.snd c ∧ Prod.fst c = a) m = + Multiset.filter (fun c => (a, b) = c) m from + Multiset.filter_congr fun c _ => + ⟨fun ⟨hb, ha⟩ => Prod.ext ha.symm hb, + fun h => ⟨congr_arg Prod.snd h, (congr_arg Prod.fst h).symm⟩⟩] + exact (Multiset.count_eq_card_filter_eq m (a, b)).symm + +/-- Card of filter by first component equals row-margin sum. -/ +private theorem filter_fst_card + (m : Multiset (Fin k × Fin k)) (a : Fin k) : + (m.filter (fun c => c.1 = a)).card = ∑ b : Fin k, m.count (a, b) := by + rw [← Multiset.card_map Prod.snd (m.filter (fun c => c.1 = a))] + rw [← sum_count_univ_gen] + exact Finset.sum_congr rfl fun b _ => filter_fst_map_snd_count m a b + +/-- `Prod.mk a` is injective in the second argument. -/ +private theorem prod_mk_injective (a : Fin k) : + Function.Injective (Prod.mk a : Fin k → Fin k × Fin k) := + fun _ _ h => (Prod.mk.inj h).2 + +/-- Count of `(a₀, b₀)` in the fintype-sum of mapped multisets. -/ +private theorem count_sum_map_mk [DecidableEq (Fin k × Fin k)] + (f : Fin k → Multiset (Fin k)) (a₀ b₀ : Fin k) : + Multiset.count (a₀, b₀) + (∑ a : Fin k, (f a).map (Prod.mk a)) = (f a₀).count b₀ := by + rw [Multiset.count_sum'] + rw [Fintype.sum_eq_single a₀] + · exact Multiset.count_map_eq_count' (Prod.mk a₀) (f a₀) + (prod_mk_injective a₀) b₀ + · intro a ha + rw [Multiset.count_eq_zero.mpr] + intro hmem + rw [Multiset.mem_map] at hmem + obtain ⟨b, _, hab⟩ := hmem + exact ha (congr_arg Prod.fst hab) + +end Helpers + +open scoped Classical in +/-- Pair-contents with prescribed margins biject with row-wise +multisets matching the column margins. -/ +theorem pair_tuple_card {n k : ℕ} (α β : Fin k → ℕ) + (hα : ∑ a : Fin k, α a = n) : + Fintype.card {s : Sym (Fin k × Fin k) n // + (∀ a, (∑ b : Fin k, s.1.count (a, b)) = α a) ∧ + (∀ b, (∑ a : Fin k, s.1.count (a, b)) = β b)} = + Fintype.card {W : ∀ a : Fin k, Sym (Fin k) (α a) // + ∀ b : Fin k, (∑ a : Fin k, (W a).1.count b) = β b} := by + apply Fintype.card_congr + -- Forward map: s ↦ (W, proof) + -- W a = ⟨(s.1.filter (·.1 = a)).map Prod.snd, card_proof⟩ + -- Backward map: W ↦ (s, proof) + -- s = ⟨∑ a, (W a).1.map (Prod.mk a), card_proof⟩ + refine { + toFun := fun ⟨s, hs₁, hs₂⟩ => ?_ + invFun := fun ⟨W, hW⟩ => ?_ + left_inv := fun ⟨s, hs₁, hs₂⟩ => ?_ + right_inv := fun ⟨W, hW⟩ => ?_ + } + · -- Forward map + refine ⟨fun a => ⟨(s.1.filter (fun c => c.1 = a)).map Prod.snd, ?_⟩, fun b + => ?_⟩ + · -- card proof: card = α a + rw [Multiset.card_map, filter_fst_card] + exact hs₁ a + · -- column margin + rw [Finset.sum_congr rfl (fun a _ => filter_fst_map_snd_count s.1 a b)] + exact hs₂ b + · -- Backward map + refine ⟨⟨∑ a : Fin k, (W a).1.map (Prod.mk a), ?_⟩, fun a₀ => ?_, fun b₀ + => ?_⟩ + · -- card proof: card = n + rw [Multiset.card_sum] + rw [Finset.sum_congr rfl (fun a _ => Multiset.card_map (Prod.mk a) (W + a).1)] + conv_rhs => rw [← hα] + exact Finset.sum_congr rfl fun a _ => (W a).2 + · -- row margin + rw [Finset.sum_congr rfl (fun b _ => count_sum_map_mk (fun a => (W a).1) + a₀ b)] + exact sum_count_univ_gen (W a₀).1 |>.trans (W a₀).2 + · -- column margin + rw [Finset.sum_congr rfl (fun a _ => count_sum_map_mk (fun a => (W a).1) a + b₀)] + exact hW b₀ + · -- Left inverse: backward (forward s) = s + apply Subtype.ext + apply Subtype.ext + apply Multiset.ext' + intro ⟨a₀, b₀⟩ + -- count (a₀, b₀) in backward (forward s) = count (a₀, b₀) in s + simp only + rw [count_sum_map_mk] + exact filter_fst_map_snd_count s.1 a₀ b₀ + · -- Right inverse: forward (backward W) = W + apply Subtype.ext + funext a₀ + apply Subtype.ext + apply Multiset.ext' + intro b₀ + -- count b₀ in forward (backward W) a₀ = count b₀ in W a₀ + simp only + rw [filter_fst_map_snd_count] + exact count_sum_map_mk (fun a => (W a).1) a₀ b₀ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairingPos.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairingPos.lean new file mode 100644 index 0000000000..3340546546 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairingPos.lean @@ -0,0 +1,475 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BranchTrace +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedCount +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffSplit +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PieriChain + +/-! +# Positivity of the restriction pairing + +The pairing `restrPairing lam mu` is nonzero whenever `lam ≤ mu`, +bridging the combinatorial Pieri chain to the representation-theoretic +branching sandwich. +-/ + +@[expose] public section + +namespace RS + +open Finset MvPolynomial Equiv + +-- rowLen vanishes beyond colLen 0 +private theorem rowLen_eq_zero_of_ge_colLen (ν : YoungDiagram) {i : ℕ} + (hi : ν.colLen 0 ≤ i) : ν.rowLen i = 0 := by + by_contra h + have hp : 0 < ν.rowLen i := Nat.pos_of_ne_zero h + have : (i, 0) ∈ ν := by + rw [YoungDiagram.mem_iff_lt_rowLen]; omega + have := YoungDiagram.mem_iff_lt_colLen.mp this + omega + +-- Step 1: sum of rowLen over Fin k = card, when k ≥ colLen 0 +private theorem sum_rowLen_fin (ν : YoungDiagram) {k : ℕ} + (hk : ν.colLen 0 ≤ k) : + ∑ i : Fin k, ν.rowLen (i : ℕ) = ν.card := by + classical + rw [card_eq_sum_rowLens] + rw [Fin.sum_univ_eq_sum_range (fun i => ν.rowLen i)] + have hrange : ν.rowLens.sum = + ∑ i ∈ Finset.range (ν.colLen 0), ν.rowLen i := by + rw [show ν.rowLens = (List.range (ν.colLen 0)).map ν.rowLen from rfl] + induction ν.colLen 0 with + | zero => simp + | succ n ih => + rw [List.range_succ, List.map_append, List.sum_append, + Finset.sum_range_succ, ih] + simp + rw [hrange] + exact (Finset.sum_subset (Finset.range_mono hk) + (fun i hi hni => by + rw [Finset.mem_range] at hni; push Not at hni + exact rowLen_eq_zero_of_ge_colLen ν hni)).symm + +-- Step 2: the shifted composition sums to m +private theorem sum_comp_pad {k m : ℕ} (vl : Fin k → ℕ) + (σ' : Equiv.Perm (Fin k)) + (hg : ∀ i : Fin k, 0 ≤ (vl i : ℤ) + ((σ' i : Fin k) : ℕ) - (i : ℕ)) + (hsum : ∑ i : Fin k, vl i = m) : + ∑ i : Fin k, + ((vl i : ℤ) + ((σ' i : Fin k) : ℕ) - (i : ℕ)).toNat = m := by + have h1 : ((∑ i : Fin k, + ((vl i : ℤ) + ((σ' i : Fin k) : ℕ) - (i : ℕ)).toNat : ℕ) : ℤ) = + (m : ℤ) := by + rw [Nat.cast_sum] + rw [Finset.sum_congr rfl + (fun (i : Fin k) (_ : i ∈ Finset.univ) => + show ((((vl i : ℤ) + ((σ' i : Fin k) : ℕ) - (i : ℕ)).toNat : ℕ) : ℤ) = + (vl i : ℤ) + ((σ' i : Fin k) : ℕ) - (i : ℕ) from + Int.toNat_of_nonneg (hg i))] + rw [Finset.sum_sub_distrib, Finset.sum_add_distrib] + rw [show (∑ i : Fin k, (((σ' i : Fin k) : ℕ) : ℤ)) = + ∑ i : Fin k, ((i : ℕ) : ℤ) from + Equiv.sum_comp σ' (fun i : Fin k => ((i : ℕ) : ℤ))] + rw [add_sub_cancel_right, ← Nat.cast_sum, hsum] + exact_mod_cast h1 + +-- The inner sum identity: connects the σ-sum of colourChar products +-- to a polynomial coefficient via pair counting +open scoped Classical in +private theorem inner_sum_eq {m n k : ℕ} (h : m ≤ n) + (α β : Fin k → ℕ) (hα : ∑ i, α i = n) (hβ : ∑ i, β i = m) : + (∑ σ : Equiv.Perm (Fin m), + (colourChar β σ : ℂ) * + (colourChar α + (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ) : ℂ)) = + (m.factorial : ℂ) * + ((∏ i, hSub (Finset.univ : Finset (Fin k)) (β i)) * + (∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ (n - m)).coeff (∑ a, + Finsupp.single a (α a)) := by + set r := n - m + set P := ∏ i, hSub (Finset.univ : Finset (Fin k)) (β i) + set Q := (∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ r + set W := Fintype.piFinset (fun _ : Fin k => Finset.range (n + 1)) + -- ═══════ STAGE 1: EXPAND THE CHARACTER ALONG THE EMBEDDING ═══════ + have hstep1 : ∀ (σ : Equiv.Perm (Fin m)), + (colourChar β σ : ℂ) * + (colourChar α (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ) : ℂ) = + ∑ w ∈ W, + (if ∀ a, w a ≤ α a then + (colourChar β σ : ℂ) * (colourChar (fun a => α a - w a) σ : ℂ) * + ((Finset.univ.filter + (fun t : ({i : Fin n // m ≤ (i : ℕ)} → Fin k) => + ∀ a, (Finset.univ.filter (fun i => t i = a)).card = w a)).card : + ℂ) + else 0) := by + intro σ + have hcve := colourChar_viaEmbedding h σ α + rw [show (colourChar α (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ) : ℂ) + = + (∑ w ∈ W, (if ∀ a, w a ≤ α a then + colourChar (fun a => α a - w a) σ * + (Finset.univ.filter + (fun t : ({i : Fin n // m ≤ (i : ℕ)} → Fin k) => + ∀ a, (Finset.univ.filter (fun i => t i = a)).card = w a)).card + else 0) : ℂ) from by rw [hcve]; push_cast; rfl] + rw [Finset.mul_sum] + refine Finset.sum_congr rfl fun w _ => ?_ + split_ifs with hw + · ring + · simp + rw [Finset.sum_congr rfl fun σ _ => hstep1 σ] + rw [Finset.sum_comm] + -- ═══════ STAGE 2: PULL OUT THE TAIL COUNT, ONE `w` AT A TIME ═══════ + have hstep2 : ∀ w ∈ W, + (∑ σ : Equiv.Perm (Fin m), + (if ∀ a, w a ≤ α a then + (colourChar β σ : ℂ) * (colourChar (fun a => α a - w a) σ : ℂ) * + ((Finset.univ.filter + (fun t : ({i : Fin n // m ≤ (i : ℕ)} → Fin k) => + ∀ a, (Finset.univ.filter (fun i => t i = a)).card = w a)).card : + ℂ) + else 0)) = + (if ∀ a, w a ≤ α a then + (m.factorial : ℂ) * + (Fintype.card {W' : ∀ a : Fin k, Sym (Fin k) (β a) // + ∀ b : Fin k, (∑ a : Fin k, (W' a).1.count b) = + α b - w b} : ℂ) * + ((Finset.univ.filter + (fun t : ({i : Fin n // m ≤ (i : ℕ)} → Fin k) => + ∀ a, (Finset.univ.filter (fun i => t i = a)).card = w a)).card : + ℂ) + else 0) := by + intro w _ + by_cases hw : ∀ a, w a ≤ α a + · rw [Finset.sum_congr rfl fun σ _ => by rw [ite_eq_left hw]] + rw [← Finset.sum_mul] + rw [ite_eq_left hw] + congr 1 + -- ∑_σ cc(β,σ) * cc(α-w,σ) as ℂ = (∑_σ cc(β,σ)*cc(α-w,σ) as ℕ) as ℂ + -- = (∑_σ |pairs|) as ℂ via colourChar_mul + -- = (m! * |Sym pairs|) as ℂ via pair_count_sum + -- = m! as ℂ * |tuples| as ℂ via pair_tuple_card + -- Work in ℕ: ∑ cc*cc = ∑ |pairs| = m! * |Sym| = m! * |tuples| + have hnat : (∑ σ : Equiv.Perm (Fin m), + colourChar β σ * colourChar (fun a => α a - w a) σ) = + m.factorial * Fintype.card {W' : ∀ a : Fin k, Sym (Fin k) (β a) // + ∀ b : Fin k, (∑ a : Fin k, (W' a).1.count b) = α b - w b} := by + rw [Finset.sum_congr rfl fun σ _ => colourChar_mul β _ σ] + rw [pair_count_sum β (fun a => α a - w a)] + rw [pair_tuple_card β (fun a => α a - w a) hβ] + -- Cast to ℂ + exact_mod_cast hnat + · rw [ite_eq_right hw, Finset.sum_eq_zero fun σ _ => by rw [ite_eq_right hw]] + rw [Finset.sum_congr rfl hstep2] + -- ═══════ STAGE 3: FACTOR OUT `m!` ═══════ + rw [show ∑ w ∈ W, + (if ∀ a, w a ≤ α a then + (m.factorial : ℂ) * + (Fintype.card {W' : ∀ a : Fin k, Sym (Fin k) (β a) // + ∀ b : Fin k, (∑ a : Fin k, (W' a).1.count b) = α b - w b} : ℂ) * + ((Finset.univ.filter + (fun t : ({i : Fin n // m ≤ (i : ℕ)} → Fin k) => + ∀ a, (Finset.univ.filter (fun i => t i = a)).card = w a)).card : + ℂ) + else 0) = + (m.factorial : ℂ) * ∑ w ∈ W, + (if ∀ a, w a ≤ α a then + (Fintype.card {W' : ∀ a : Fin k, Sym (Fin k) (β a) // + ∀ b : Fin k, (∑ a : Fin k, (W' a).1.count b) = α b - w b} : ℂ) * + ((Finset.univ.filter + (fun t : ({i : Fin n // m ≤ (i : ℕ)} → Fin k) => + ∀ a, (Finset.univ.filter (fun i => t i = a)).card = w a)).card : ℂ) + else 0) from by + rw [Finset.mul_sum] + refine Finset.sum_congr rfl fun w _ => ?_ + split_ifs <;> ring] + congr 1 + -- ═══════ ASSEMBLY: MATCH EACH `w`-TERM TO `coeff_mul_split` ═══════ + rw [coeff_mul_split P Q α n (fun a => by + have := hα ▸ Finset.single_le_sum (f := α) (fun _ _ => Nat.zero_le _) + (Finset.mem_univ a); exact this)] + refine Finset.sum_congr rfl fun w _ => ?_ + by_cases hw : ∀ a, w a ≤ α a + · rw [ite_eq_left hw, ite_eq_left hw] + -- coeff(α-w)(P) = |tuples| via coeff_hSub_prod + -- coeff(w)(Q) = |tail functions| via coeff_p1_pow + congr 1 + · rw [coeff_hSub_prod] + exact_mod_cast Fintype.card_congr + (Equiv.subtypeEquivRight fun W' => by + constructor + · intro hW j; rw [sum_single_apply]; exact hW j + · intro hW j; have := hW j; rw [sum_single_apply] at this; exact this) + · -- coeff(w)(Q) = |tail functions| via coeff_p1_pow + dsimp only [Q] + rw [show r = Fintype.card {i : Fin n // m ≤ (i : ℕ)} from + (card_tail h).symm, coeff_p1_pow] + simp_rw [sum_single_apply] + norm_cast + convert rfl using 5 + · rw [ite_eq_right hw, ite_eq_right hw] + +-- Coefficient of w in (jtMat v).det * Q: signed guarded sum with extra Q +open scoped Classical in +private theorem coeff_det_jtMat_mul {k : ℕ} + (v : Fin k → ℕ) (Q : MvPolynomial (Fin k) ℂ) (w : Fin k →₀ ℕ) : + ((jtMat v).det * Q).coeff w = + ∑ σ : Equiv.Perm (Fin k), + ((Equiv.Perm.sign σ : ℤ) : ℂ) * + (if ∀ i : Fin k, + 0 ≤ (v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) + then ((∏ i, hSub (Finset.univ : Finset (Fin k)) + (((v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ)).toNat)) * Q).coeff w + else 0) := by + rw [det_jtMat_expand] + rw [Finset.sum_congr rfl + (fun (σ : Equiv.Perm (Fin k)) (_ : σ ∈ Finset.univ) => by + rw [jt_term_guard v σ])] + rw [Finset.sum_mul] + rw [Finset.sum_congr rfl + (fun (σ : Equiv.Perm (Fin k)) (_ : σ ∈ Finset.univ) => by + rw [mul_assoc])] + rw [MvPolynomial.coeff_sum] + refine Finset.sum_congr rfl fun σ _ => ?_ + rw [show ((Equiv.Perm.sign σ : ℤ) : MvPolynomial (Fin k) ℂ) = + MvPolynomial.C ((Equiv.Perm.sign σ : ℤ) : ℂ) from by simp, + MvPolynomial.coeff_C_mul] + by_cases hp : ∀ i : Fin k, + 0 ≤ (v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) + · rw [ite_eq_left hp, ite_eq_left hp] + · rw [ite_eq_right hp, ite_eq_right hp, zero_mul, AddMonoidAlgebra.coeff_zero] + rfl + +-- The main algebraic reduction +open scoped Classical in +private theorem pairing_eq_factorial_coeff + (Hpad : ∀ (μ : YoungDiagram) {k : ℕ} + (_hk : μ.rowLens.length ≤ k) (π : Equiv.Perm (Fin μ.card)), + jtChar μ π = + ∑ σ : Equiv.Perm (Fin k), + ((Equiv.Perm.sign σ : ℤ) : ℂ) * + (if ∀ i : Fin k, + 0 ≤ (μ.rowLen (i : ℕ) : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) + then (colourChar + (fun i : Fin k => + ((μ.rowLen (i : ℕ) : ℤ) + ((σ i : Fin k) : ℕ) - + (i : ℕ)).toNat) π : ℂ) + else 0)) + (lam mu : YoungDiagram) (_hle : lam ≤ mu) + (h : lam.card ≤ mu.card) + {k : ℕ} {m : ℕ} {n : ℕ} {r : ℕ} + (_hk_eq : k = mu.rowLens.length) (hm_eq : m = lam.card) + (hn_eq : n = mu.card) (hr_eq : r = n - m) + (hkl : lam.rowLens.length ≤ k) (hkm : mu.rowLens.length ≤ k) + (_hk_col_lam : lam.colLen 0 ≤ k) (_hk_col_mu : mu.colLen 0 ≤ k) + (hsum_lam : ∑ i : Fin k, lam.rowLen (i : ℕ) = m) + (hsum_mu : ∑ i : Fin k, mu.rowLen (i : ℕ) = n) : + restrPairing lam mu h = + (m.factorial : ℂ) * + ((∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ r * + altDet (eVec lam k)).coeff (∑ i : Fin k, Finsupp.single i (eVec mu k i)) := by + classical + set Q := (∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ r + set vl : Fin k → ℕ := fun i => lam.rowLen (i : ℕ) with hvl_def + set vm : Fin k → ℕ := fun i => mu.rowLen (i : ℕ) with hvm_def + -- ═══════ SETUP: THE SHIFTED COMPOSITIONS AND THEIR GUARDS ═══════ + let β (σ' : Equiv.Perm (Fin k)) (i : Fin k) := + ((vl i : ℤ) + ((σ' i : Fin k) : ℕ) - (i : ℕ)).toNat + let α (τ : Equiv.Perm (Fin k)) (a : Fin k) := + ((vm a : ℤ) + ((τ a : Fin k) : ℕ) - (a : ℕ)).toNat + let guard_lam (σ' : Equiv.Perm (Fin k)) := + ∀ i : Fin k, 0 ≤ (vl i : ℤ) + ((σ' i : Fin k) : ℕ) - (i : ℕ) + let guard_mu (τ : Equiv.Perm (Fin k)) := + ∀ i : Fin k, 0 ≤ (vm i : ℤ) + ((τ i : Fin k) : ℕ) - (i : ℕ) + -- ═══════ STAGE 1: THE COEFFICIENT AS A DOUBLE SUM ═══════ + have rhs_chain : + (Q * altDet (eVec lam k)).coeff (∑ i : Fin k, Finsupp.single i (eVec mu k i)) = + ∑ τ : Equiv.Perm (Fin k), ∑ σ' : Equiv.Perm (Fin k), + ((Equiv.Perm.sign τ : ℤ) : ℂ) * ((Equiv.Perm.sign σ' : ℤ) : ℂ) * + (if guard_mu τ ∧ guard_lam σ' + then ((∏ i, hSub (Finset.univ : Finset (Fin k)) (β σ' i)) * Q).coeff (∑ a, + Finsupp.single a (α τ a)) + else 0) := by + -- eVec finsupp = diagExp vm + have heVec : (∑ i : Fin k, Finsupp.single i (eVec mu k i)) = + diagExp vm := by + ext j; rw [sum_single_apply, diagExp_apply]; rfl + -- altDet = powMat.det + have haltDet : altDet (eVec lam k) = (powMat vl).det := rfl + rw [heVec, show Q * altDet (eVec lam k) = + ((jtMat vl).det * Q) * (powMat (fun _ : Fin k => 0)).det from by + rw [haltDet, bialternant]; ring] + rw [coeff_mul_alternant] + refine Finset.sum_congr rfl fun τ _ => ?_ + by_cases hτ : stairShift τ ≤ diagExp vm + · rw [ite_eq_left hτ, coeff_det_jtMat_mul, Finset.mul_sum] + have hguard_mu : guard_mu τ := (stair_guard_iff vm τ).mp hτ + refine Finset.sum_congr rfl fun σ' _ => ?_ + by_cases hσ : guard_lam σ' + · have hmargin : diagExp vm - stairShift τ = + ∑ a, Finsupp.single a (α τ a) := by + ext j; rw [sum_single_apply]; exact stair_margin_eq vm τ hτ j + rw [mul_assoc, ite_eq_left hσ, ite_eq_left ⟨hguard_mu, hσ⟩, hmargin] + · rw [mul_assoc, ite_eq_right hσ, ite_eq_right (fun ⟨_, h⟩ => hσ h), mul_zero] + · rw [ite_eq_right hτ] + have hguard_mu_neg : ¬ guard_mu τ := fun h => + hτ ((stair_guard_iff vm τ).mpr h) + have hsum_zero : (∑ σ' : Equiv.Perm (Fin k), + ((Equiv.Perm.sign τ : ℤ) : ℂ) * ((Equiv.Perm.sign σ' : ℤ) : ℂ) * + (if guard_mu τ ∧ guard_lam σ' + then ((∏ i, hSub (Finset.univ : Finset (Fin k)) (β σ' i)) * Q).coeff (∑ a, + Finsupp.single a (α τ a)) + else 0)) = 0 := by + apply Finset.sum_eq_zero; intro σ' _ + rw [ite_eq_right (fun ⟨h, _⟩ => hguard_mu_neg h)]; ring + rw [hsum_zero, mul_zero] + -- ═══════ STAGE 2: THE PAIRING AS `m!` TIMES THAT SUM ═══════ + have lhs_chain : + restrPairing lam mu h = + (m.factorial : ℂ) * + ∑ σ' : Equiv.Perm (Fin k), ∑ τ : Equiv.Perm (Fin k), + ((Equiv.Perm.sign σ' : ℤ) : ℂ) * ((Equiv.Perm.sign τ : ℤ) : ℂ) * + (if guard_lam σ' ∧ guard_mu τ + then ((∏ i, hSub (Finset.univ : Finset (Fin k)) (β σ' i)) * Q).coeff (∑ a, + Finsupp.single a (α τ a)) + else 0) := by + -- Expand restrPairing + unfold restrPairing + -- Apply Hpad + rw [Finset.sum_congr rfl fun π _ => by + rw [Hpad lam hkl π, Hpad mu hkm + (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) π)]] + -- Expand products (controlled order: sum_mul first so σ_lam is outer) + conv_lhs => simp only [Finset.sum_mul] + conv_lhs => simp only [Finset.mul_sum] + -- Distribute m! into the sums on the RHS + rw [Finset.mul_sum] + -- Swap LHS: ∑ π σ_lam → ∑ σ_lam π (σ' = λ-perm) + conv_lhs => rw [Finset.sum_comm] + -- Push m! into inner sum + simp_rw [Finset.mul_sum] + refine Finset.sum_congr rfl fun σ' _ => ?_ + -- σ' is the λ permutation; swap inner: ∑ π σ_mu → ∑ σ_mu π (τ = μ-perm) + conv_lhs => rw [Finset.sum_comm] + refine Finset.sum_congr rfl fun τ _ => ?_ + -- Per (σ', τ): show ∑ π, f(π) = m! * g + by_cases hσ : guard_lam σ' + · have hσ_exp : ∀ i : Fin k, + (0 : ℤ) ≤ ↑(lam.rowLen ↑i) + ↑↑(σ' i) - ↑↑i := hσ + by_cases hτ : guard_mu τ + · have hτ_exp : ∀ i : Fin k, + (0 : ℤ) ≤ ↑(mu.rowLen ↑i) + ↑↑(τ i) - ↑↑i := hτ + -- Both guards hold: apply inner_sum_eq + simp_rw [ite_eq_left hσ_exp, ite_eq_left hτ_exp] + rw [ite_eq_left ⟨hσ, hτ⟩] + -- Rearrange: (sign * cc) * (sign * cc') → (sign * sign) * (cc * cc') + conv_lhs => arg 2; ext π; rw [mul_mul_mul_comm] + rw [← Finset.mul_sum] + -- Use h : lam.card ≤ mu.card so inner_sum_eq matches goal's Fin type + have h_inner := inner_sum_eq h (α τ) (β σ') + ((sum_comp_pad vm τ hτ hsum_mu).trans hn_eq) + ((sum_comp_pad vl σ' hσ hsum_lam).trans hm_eq) + -- Align factorial and exponent to match m.factorial and Q + rw [show (lam.card).factorial = m.factorial from by rw [hm_eq]] + at h_inner + rw [show mu.card - lam.card = r from by omega] at h_inner + -- Fold (∑ l, X l) ^ r to Q so it matches goal syntactically + rw [show (∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ r = Q from rfl] + at h_inner + -- h_inner: S = m! * C (with Q, matching goal) + -- goal: a * S = m! * (a * C) where a = sign * sign + exact (congr_arg + (((Equiv.Perm.sign σ' : ℤ) : ℂ) * ((Equiv.Perm.sign τ : ℤ) : ℂ) * ·) + h_inner).trans (by ring) + · -- guard_mu fails + have hτ_exp : ¬ ∀ i : Fin k, + (0 : ℤ) ≤ ↑(mu.rowLen ↑i) + ↑↑(τ i) - ↑↑i := hτ + simp_rw [ite_eq_left hσ_exp, ite_eq_right hτ_exp] + rw [ite_eq_right (fun ⟨_, h⟩ => hτ h)] + simp only [mul_zero, Finset.sum_const_zero] + · -- guard_lam fails + have hσ_exp : ¬ ∀ i : Fin k, + (0 : ℤ) ≤ ↑(lam.rowLen ↑i) + ↑↑(σ' i) - ↑↑i := hσ + simp_rw [ite_eq_right hσ_exp] + rw [ite_eq_right (fun ⟨h, _⟩ => hσ h)] + simp only [mul_zero, zero_mul, Finset.sum_const_zero] + -- ═══════ ASSEMBLY ═══════ + rw [lhs_chain] + congr 1 + rw [rhs_chain] + -- Swap sum order: ∑ σ' τ = ∑ τ σ' + rw [Finset.sum_comm] + refine Finset.sum_congr rfl fun τ _ => ?_ + refine Finset.sum_congr rfl fun σ' _ => ?_ + -- Match: sign order and guard order are commutative + rw [show ((Equiv.Perm.sign σ' : ℤ) : ℂ) * ((Equiv.Perm.sign τ : ℤ) : ℂ) = + ((Equiv.Perm.sign τ : ℤ) : ℂ) * ((Equiv.Perm.sign σ' : ℤ) : ℂ) from mul_comm + _ _] + congr 1 + exact if_congr And.comm rfl rfl + +open scoped Classical in +/-- **The restriction pairing is nonzero** whenever one diagram +contains the other, by the Pieri chain's positivity. -/ +theorem restrPairing_ne_zero + (Hpad : ∀ (μ : YoungDiagram) {k : ℕ} + (_hk : μ.rowLens.length ≤ k) (π : Equiv.Perm (Fin μ.card)), + jtChar μ π = + ∑ σ : Equiv.Perm (Fin k), + ((Equiv.Perm.sign σ : ℤ) : ℂ) * + (if ∀ i : Fin k, + 0 ≤ (μ.rowLen (i : ℕ) : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) + then (colourChar + (fun i : Fin k => + ((μ.rowLen (i : ℕ) : ℤ) + ((σ i : Fin k) : ℕ) - + (i : ℕ)).toNat) π : ℂ) + else 0)) + (lam mu : YoungDiagram) (hle : lam ≤ mu) + (h : lam.card ≤ mu.card) : + restrPairing lam mu h ≠ 0 := by + classical + set k := mu.rowLens.length with hk_def + set m := lam.card with hm_def + set n := mu.card with hn_def + set r := n - m with hr_def + set vl : Fin k → ℕ := fun i => lam.rowLen (i : ℕ) with hvl_def + set vm : Fin k → ℕ := fun i => mu.rowLen (i : ℕ) with hvm_def + have hcol_mono : lam.colLen 0 ≤ mu.colLen 0 := by + by_contra hc + push Not at hc + have hmem : (mu.colLen 0, 0) ∈ lam := by + rw [YoungDiagram.mem_iff_lt_colLen]; omega + have := hle hmem + exact absurd (YoungDiagram.mem_iff_lt_colLen.mp this) (by omega) + have hkl : lam.rowLens.length ≤ k := by + rw [hk_def, YoungDiagram.length_rowLens, YoungDiagram.length_rowLens] + exact hcol_mono + have hkm : mu.rowLens.length ≤ k := le_refl _ + have hk_col_lam : lam.colLen 0 ≤ k := by + rw [hk_def, YoungDiagram.length_rowLens]; exact hcol_mono + have hk_col_mu : mu.colLen 0 ≤ k := by + rw [hk_def, YoungDiagram.length_rowLens] + have hsum_lam : ∑ i : Fin k, vl i = m := sum_rowLen_fin lam hk_col_lam + have hsum_mu : ∑ i : Fin k, vm i = n := sum_rowLen_fin mu hk_col_mu + suffices key : ∃ N : ℕ, 0 < N ∧ + restrPairing lam mu h = (m.factorial : ℂ) * (N : ℂ) by + obtain ⟨N, hN_pos, hN_eq⟩ := key + rw [hN_eq] + exact mul_ne_zero + (Nat.cast_ne_zero.mpr (Nat.factorial_ne_zero m)) + (Nat.cast_ne_zero.mpr (by omega)) + have hchain := coeff_chain_pos lam mu hle r (by omega) hk_col_mu + obtain ⟨N, hN_pos, hN_eq⟩ := hchain + refine ⟨N, hN_pos, ?_⟩ + rw [pairing_eq_factorial_coeff Hpad lam mu hle h + hk_def hm_def hn_def hr_def hkl hkm + hk_col_lam hk_col_mu hsum_lam hsum_mu, hN_eq] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PermModule.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PermModule.lean new file mode 100644 index 0000000000..0e58eb929f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PermModule.lean @@ -0,0 +1,164 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharClass + +/-! +# The permutation module on a colour class + +The symmetric group `Equiv.Perm (Fin n)` acts on the colour class +`{g : Fin n → Fin N // ∀ j, fibreCard g j = α j}` by precomposition +with the inverse. The resulting `ofMulAction` representation has +character equal to `colourChar α`. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv MonoidAlgebra + + + +/-- The colour class: colourings with prescribed fibre sizes. -/ +def colourClass (n : ℕ) {N : ℕ} (α : Fin N → ℕ) : Type := + {g : Fin n → Fin N // ∀ j, fibreCard g j = α j} + +/-- A colour class is finite. -/ +noncomputable instance colourClass.fintype (n : ℕ) {N : ℕ} + (α : Fin N → ℕ) : Fintype (colourClass n α) := + Subtype.fintype _ + +/-- And its members can be compared. -/ +noncomputable instance colourClass.decidableEq (n : ℕ) {N : ℕ} + (α : Fin N → ℕ) : DecidableEq (colourClass n α) := + Classical.decEq _ + +/-- The symmetric group acts on the colour class by precomposition +with the inverse permutation. -/ +instance colourClass.mulAction {n N : ℕ} (α : Fin N → ℕ) : + MulAction (Equiv.Perm (Fin n)) (colourClass n α) where + smul π g := ⟨g.1 ∘ ⇑π⁻¹, fun j => by + rw [fibreCard_comp_perm]; exact g.2 j⟩ + one_smul g := by + apply Subtype.ext + change g.1 ∘ ⇑(1 : Equiv.Perm (Fin n))⁻¹ = g.1 + simp + mul_smul π ρ g := by + apply Subtype.ext + change g.1 ∘ ⇑(π * ρ)⁻¹ = (⟨(g.1 ∘ ⇑ρ⁻¹) ∘ ⇑π⁻¹, _⟩ : colourClass n α).1 + rw [mul_inv_rev] + rfl + +/-- The permutation representation on the colour class. -/ +noncomputable def colourRep {n N : ℕ} (α : Fin N → ℕ) : + Representation ℂ (Equiv.Perm (Fin n)) ℂ[colourClass n α] := + Representation.ofMulAction ℂ _ _ + +private theorem fixed_iff_comp_eq {n N : ℕ} (α : Fin N → ℕ) + (π : Equiv.Perm (Fin n)) (g : colourClass n α) : + π • g = g ↔ g.1 ∘ ⇑π = g.1 := by + constructor + · intro h + have hv := congrArg Subtype.val h + -- hv : g.1 ∘ π⁻¹ = g.1 + funext i + have := congrFun hv (π i) + change g.1 (π⁻¹ (π i)) = g.1 (π i) at this + simp at this + exact this.symm + · intro h + apply Subtype.ext + -- need: g.1 ∘ π⁻¹ = g.1 + funext i + have := congrFun h (π⁻¹ i) + change g.1 (π (π⁻¹ i)) = g.1 (π⁻¹ i) at this + simp at this + exact this.symm + +private theorem fixedPoints_card_eq_colourChar {n N : ℕ} + (α : Fin N → ℕ) (π : Equiv.Perm (Fin n)) : + (Finset.univ.filter + (fun g : colourClass n α => π • g = g)).card = + colourChar α π := by + rw [colourChar] + -- Both sides are cardinalities of filters on Finset.univ + -- LHS: filter over colourClass n α + -- RHS: filter over Fin n → Fin N + -- We show they are equal by an explicit bijection + apply Finset.card_bij (fun (g : colourClass n α) _ => g.1) + · -- Maps to: g in LHS filter implies g.1 in RHS filter + intro g hg + rw [Finset.mem_filter] at hg ⊢ + exact ⟨Finset.mem_univ _, ⟨g.2, (fixed_iff_comp_eq α π g).mp hg.2⟩⟩ + · -- Injective + intro g₁ _ g₂ _ heq + exact Subtype.ext heq + · -- Surjective + intro f hf + rw [Finset.mem_filter] at hf + obtain ⟨_, hcls, hfix⟩ := hf + exact ⟨⟨f, hcls⟩, + Finset.mem_filter.mpr ⟨Finset.mem_univ _, + (fixed_iff_comp_eq α π ⟨f, hcls⟩).mpr hfix⟩, rfl⟩ + +/-- The character of the colour-class permutation representation +equals the combinatorial colour character. -/ +theorem colourRep_character {n N : ℕ} (α : Fin N → ℕ) + (π : Equiv.Perm (Fin n)) : + (colourRep α).character π = (colourChar α π : ℂ) := by + -- character = trace of the linear map + change LinearMap.trace ℂ _ ((colourRep α) π) = _ + -- express trace via MonoidAlgebra basis + set b := MonoidAlgebra.basis (colourClass n α) ℂ with hb_def + rw [LinearMap.trace_eq_matrix_trace ℂ b] + -- Matrix.trace = ∑ g, diagonal entry + change ∑ g : colourClass n α, + LinearMap.toMatrix b b ((colourRep α) π) g g = _ + -- compute each diagonal entry + have hdiag : ∀ g : colourClass n α, + LinearMap.toMatrix b b ((colourRep α) π) g g = + if π • g = g then 1 else 0 := by + intro g + rw [LinearMap.toMatrix_apply] + -- b g = MonoidAlgebra.single g 1 + change (b.repr ((colourRep α) π (MonoidAlgebra.single g 1))) g = + if π • g = g then 1 else 0 + -- (colourRep α) π acts by ofMulAction + rw [show (colourRep α) π (MonoidAlgebra.single g 1) = + MonoidAlgebra.single (π • g) 1 from + Representation.ofMulAction_single π g 1] + -- b.repr = coeffLinearEquiv + change ((coeffLinearEquiv ℂ) + (MonoidAlgebra.single (π • g) (1 : ℂ))) g = + if π • g = g then 1 else 0 + rw [coeffLinearEquiv_apply] + simp [ Finsupp.single_apply, eq_comm] + -- rewrite using the diagonal formula + rw [Finset.sum_congr rfl (fun g _ => hdiag g)] + -- ∑ g, if π • g = g then 1 else 0 = card of fixed points + have hsum : ∑ g : colourClass n α, + (if π • g = g then (1 : ℂ) else 0) = + ((Finset.univ.filter + (fun g : colourClass n α => π • g = g)).card : ℂ) := by + rw [← Finset.sum_filter] + simp + rw [hsum, fixedPoints_card_eq_colourChar] + +/-- The number of orbits equals `cycleType.card + (n - cycleType.sum)`. -/ +theorem card_orbitSpace (n : ℕ) (π : Equiv.Perm (Fin n)) : + Fintype.card (OrbitSpace π) = + π.cycleType.card + (n - π.cycleType.sum) := by + have h := orbCard_multiset π + have h1 : Fintype.card (OrbitSpace π) = + ((Finset.univ : Finset (OrbitSpace π)).val.map + (orbCard π)).card := by + rw [Multiset.card_map]; rfl + rw [h1, h, Multiset.card_add, Multiset.card_replicate] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PowerSurj.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PowerSurj.lean new file mode 100644 index 0000000000..a4c93b4183 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PowerSurj.lean @@ -0,0 +1,234 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.HVal + +/-! +# Surjectivity of the power-sum specialization + +Every finite sequence of prospective power sums is realized by an +actual finite family of complex numbers: Newton-invert the +prescribed values to elementary symmetric values, build the monic +polynomial with those (sign-alternating) coefficients, split it +over ℂ, and read the roots. The roots' elementary values match by +Vieta, and their power sums then agree with the prescription by +the triangular Newton recursion. + +This is the globalization device: symmetric-function +identities are proved for genuine variable families and transferred +to arbitrary prospective power sums. +-/ + +@[expose] public section + +namespace RS + +open Finset Polynomial + +/-- The elementary values prescribed by a sequence of power sums, +via the Newton recursion. -/ +noncomputable def eSeq (t : ℕ → ℂ) : ℕ → ℂ + | 0 => 1 + | k + 1 => + ((k : ℂ) + 1)⁻¹ * (-1) ^ (k + 2) * + ∑ a ∈ ((antidiagonal (k + 1)).filter + (fun a => a.1 < k + 1)).attach, + (-1) ^ a.1.1 * eSeq t a.1.1 * t a.1.2 + decreasing_by + exact (Finset.mem_filter.mp a.2).2 + +/-- The defining relation of `eSeq`, unattached and cleared of the +inverse. -/ +theorem eSeq_mul (t : ℕ → ℂ) (k : ℕ) : + ((k : ℂ) + 1) * eSeq t (k + 1) = + (-1) ^ (k + 2) * + ∑ a ∈ (antidiagonal (k + 1)).filter + (fun a => a.1 < k + 1), + (-1) ^ a.1 * eSeq t a.1 * t a.2 := by + rw [eSeq] + rw [← Finset.sum_attach ((antidiagonal (k + 1)).filter + (fun a => a.1 < k + 1)) + (fun a => (-1 : ℂ) ^ a.1 * eSeq t a.1 * t a.2)] + rw [← mul_assoc, ← mul_assoc, + mul_inv_cancel₀ (Nat.cast_add_one_ne_zero k : ((k : ℂ) + 1) ≠ 0), + one_mul] + +/-- The prescription satisfies the solved form of the Newton +recursion. -/ +theorem t_eq_of_eSeq (t : ℕ → ℂ) (c : ℕ) (hc : 0 < c) : + t c = (-1) ^ (c + 1) * c * eSeq t c - + ∑ a ∈ (antidiagonal c).filter (fun a => a.1 ∈ Set.Ioo 0 c), + (-1) ^ a.1 * eSeq t a.1 * t a.2 := by + obtain ⟨k, rfl⟩ := Nat.exists_eq_add_of_lt hc + rw [zero_add] at * + have h := eSeq_mul t k + -- Split the `a.1 = 0` term off the filtered sum. + have hsplit : ((antidiagonal (k + 1)).filter + (fun a => a.1 < k + 1)) = + insert ((0 : ℕ), k + 1) + ((antidiagonal (k + 1)).filter + (fun a => a.1 ∈ Set.Ioo 0 (k + 1))) := by + ext a + simp only [Finset.mem_filter, Finset.mem_insert, + Finset.mem_antidiagonal, Set.mem_Ioo] + constructor + · rintro ⟨hsum, hlt⟩ + by_cases h0 : a.1 = 0 + · left + obtain ⟨a1, a2⟩ := a + simp only at h0 hsum ⊢ + subst h0 + rw [zero_add] at hsum + rw [hsum] + · right + exact ⟨hsum, Nat.pos_of_ne_zero h0, hlt⟩ + · rintro (rfl | ⟨hsum, h0, hlt⟩) + · exact ⟨by rw [zero_add], by omega⟩ + · exact ⟨hsum, hlt⟩ + rw [hsplit, Finset.sum_insert (by + simp only [Finset.mem_filter, Set.mem_Ioo] + rintro ⟨-, h0, -⟩ + exact absurd rfl (Nat.ne_of_gt h0))] at h + rw [show ((-1 : ℂ)) ^ (0 : ℕ) * eSeq t 0 * t (k + 1) = t (k + 1) from by + rw [pow_zero, eSeq, one_mul, one_mul]] at h + have h2 : (-1 : ℂ) ^ (k + 2) * (((k : ℂ) + 1) * eSeq t (k + 1)) = + t (k + 1) + ∑ a ∈ (antidiagonal (k + 1)).filter + (fun a => a.1 ∈ Set.Ioo 0 (k + 1)), + (-1) ^ a.1 * eSeq t a.1 * t a.2 := by + rw [h, ← mul_assoc, ← pow_add, + show k + 2 + (k + 2) = 2 * (k + 2) from by ring, + pow_mul, neg_one_sq, one_pow, one_mul] + push_cast + linear_combination -h2 + +/-! ### The realizing polynomial and its roots -/ + +/-- The monic polynomial with the prescribed alternating +elementary coefficients. -/ +noncomputable def ePoly (t : ℕ → ℂ) (n : ℕ) : Polynomial ℂ := + ∑ k ∈ range (n + 1), + Polynomial.monomial (n - k) ((-1) ^ k * eSeq t k) + +/-- The polynomial's coefficients are the prescribed elementary +values, alternating in sign. -/ +theorem ePoly_coeff {t : ℕ → ℂ} {n k : ℕ} (hk : k ≤ n) : + (ePoly t n).coeff (n - k) = (-1) ^ k * eSeq t k := by + rw [ePoly, Polynomial.finsetSum_coeff] + rw [Finset.sum_congr rfl (fun j hj => Polynomial.coeff_monomial)] + rw [Finset.sum_congr rfl (fun j hj => show + (if n - j = n - k then ((-1 : ℂ)) ^ j * eSeq t j else 0) = + (if j = k then ((-1 : ℂ)) ^ j * eSeq t j else 0) from + if_congr (by + have := Finset.mem_range.mp hj + omega) rfl rfl)] + rw [Finset.sum_ite_eq' (range (n + 1)) k + (fun j => ((-1 : ℂ)) ^ j * eSeq t j)] + rw [ite_eq_left (Finset.mem_range.mpr (by omega))] + +/-- Its leading coefficient is `1`. -/ +theorem ePoly_coeff_self (t : ℕ → ℂ) (n : ℕ) : + (ePoly t n).coeff n = 1 := by + have h := ePoly_coeff (t := t) (n := n) (k := 0) (Nat.zero_le n) + rw [Nat.sub_zero] at h + rw [h, pow_zero, one_mul, eSeq] + +/-- Its degree is the number of prescribed values. -/ +theorem ePoly_natDegree (t : ℕ → ℂ) (n : ℕ) : + (ePoly t n).natDegree = n := by + refine le_antisymm ?_ ?_ + · refine (Polynomial.natDegree_sum_le _ _).trans ?_ + rw [Finset.fold_max_le] + refine ⟨Nat.zero_le n, fun j _ => ?_⟩ + exact (Polynomial.natDegree_monomial_le _).trans (Nat.sub_le n j) + · refine Polynomial.le_natDegree_of_ne_zero ?_ + rw [ePoly_coeff_self] + exact one_ne_zero + +/-- It is monic. -/ +theorem ePoly_monic (t : ℕ → ℂ) (n : ℕ) : (ePoly t n).Monic := by + rw [Polynomial.Monic, Polynomial.leadingCoeff, ePoly_natDegree, + ePoly_coeff_self] + +/-- Hence it has exactly that many roots over ℂ — the family the +prescription is realized by. -/ +theorem ePoly_card_roots (t : ℕ → ℂ) (n : ℕ) : + Multiset.card (ePoly t n).roots = n := by + have h := Polynomial.splits_iff_card_roots.mp + (IsAlgClosed.splits (k := ℂ) (ePoly t n)) + rw [ePoly_natDegree] at h + exact h + +/-- Vieta: the roots of the realizing polynomial have the +prescribed elementary values. -/ +theorem ePoly_roots_esymm (t : ℕ → ℂ) {n k : ℕ} (hk : k ≤ n) : + (ePoly t n).roots.esymm k = eSeq t k := by + have h := Polynomial.coeff_eq_esymm_roots_of_card + (p := ePoly t n) + (by rw [ePoly_card_roots, ePoly_natDegree]) + (k := n - k) (by rw [ePoly_natDegree]; omega) + rw [ePoly_natDegree, show n - (n - k) = k from by omega, + (ePoly_monic t n).leadingCoeff, one_mul, ePoly_coeff hk] at h + exact (mul_left_cancel₀ + (pow_ne_zero k (neg_ne_zero.mpr (one_ne_zero (α := ℂ)))) h).symm + +/-! ### The surjectivity of the power-sum specialization -/ + +/-- Evaluation of the power-sum polynomial is `pVal`. -/ +theorem aeval_psum {N : ℕ} (x : Fin N → ℂ) (k : ℕ) : + MvPolynomial.aeval x (MvPolynomial.psum (Fin N) ℂ k) = + pVal x k := by + rw [MvPolynomial.psum, map_sum, pVal] + exact Finset.sum_congr rfl fun j _ => by + rw [map_pow, MvPolynomial.aeval_X] + +/-- **Every prospective power-sum sequence is realized** by a +finite family of complex numbers, up to any given degree. -/ +theorem exists_pVal_eq (n : ℕ) (t : ℕ → ℂ) : + ∃ (N : ℕ) (x : Fin N → ℂ), + ∀ c, 1 ≤ c → c ≤ n → pVal x c = t c := by + classical + refine ⟨(ePoly t n).roots.toList.length, + fun i => (ePoly t n).roots.toList.get i, ?_⟩ + set x : Fin (ePoly t n).roots.toList.length → ℂ := + fun i => (ePoly t n).roots.toList.get i with hx + have hmul : (Finset.univ.val.map x) = (ePoly t n).roots := by + rw [hx] + rw [show (Finset.univ.val : Multiset + (Fin (ePoly t n).roots.toList.length)) = + ((List.finRange (ePoly t n).roots.toList.length : List _) : + Multiset _) from rfl] + rw [Multiset.map_coe, List.map_get_finRange, + Multiset.coe_toList] + have hesymm : ∀ k ≤ n, + Multiset.esymm (Finset.univ.val.map x) k = eSeq t k := by + intro k hk + rw [hmul] + exact ePoly_roots_esymm t hk + suffices H : ∀ c, (∀ d, d < c → 1 ≤ d → d ≤ n → pVal x d = t d) → + 1 ≤ c → c ≤ n → pVal x c = t c by + intro c + induction c using Nat.strong_induction_on with + | _ c ih => exact H c (fun d hd => ih d hd) + intro c ih h1 hn + have hps := congrArg (MvPolynomial.aeval x) + (MvPolynomial.psum_eq_mul_esymm_sub_sum + (Fin (ePoly t n).roots.toList.length) ℂ c (by omega)) + simp only [map_sub, map_mul, map_pow, map_neg, map_one, + map_natCast, map_sum, aeval_psum, + MvPolynomial.aeval_esymm_eq_multiset_esymm] at hps + rw [hps] + rw [t_eq_of_eSeq t c (by omega)] + congr 1 + · rw [hesymm c hn] + · refine Finset.sum_congr rfl fun a ha => ?_ + obtain ⟨hmem, hIoo⟩ := Finset.mem_filter.mp ha + have hsum := Finset.mem_antidiagonal.mp hmem + obtain ⟨h0, hlt⟩ := hIoo + rw [hesymm a.1 (by omega), ih a.2 (by omega) (by omega) (by omega)] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/RegularTrace.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/RegularTrace.lean new file mode 100644 index 0000000000..b013633d69 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/RegularTrace.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PowerSurj + +/-! +# The trace of left multiplication on a group algebra + +Left multiplication by `y` on `ℂ[G]` has trace `|G| · y 1` — the +regular character. Combined with rank-equals-trace for +idempotents this computes block dimensions without any +decomposition theory. +-/ + +@[expose] public section + +namespace RS + +open Finset LinearMap Module + +variable {G : Type*} + +/-- **The regular trace**: left multiplication by `y` has trace +`|G| · y 1`. -/ +theorem trace_mulLeft [Group G] [Fintype G] + (y : MonoidAlgebra ℂ G) : + LinearMap.trace ℂ (MonoidAlgebra ℂ G) (mulLeft ℂ y) = + (Fintype.card G : ℂ) * y.coeff 1 := by + classical + rw [trace_eq_matrix_trace ℂ (MonoidAlgebra.basis G ℂ)] + rw [Matrix.trace] + rw [Finset.sum_congr rfl (fun g (_ : g ∈ Finset.univ) => show + (toMatrix (MonoidAlgebra.basis G ℂ) (MonoidAlgebra.basis G ℂ) + (mulLeft ℂ y)).diag g = y.coeff 1 from by + rw [Matrix.diag_apply, toMatrix_apply, mulLeft_apply, + MonoidAlgebra.basis_apply] + rw [show ((MonoidAlgebra.basis G ℂ).repr + (y * MonoidAlgebra.single g 1)) g = + (y * MonoidAlgebra.single g 1).coeff g from rfl] + rw [show (y * MonoidAlgebra.single g (1 : ℂ)).coeff g = + y.coeff (g * g⁻¹) * 1 from + MonoidAlgebra.coeff_mul_single_apply y 1 g g] + rw [mul_inv_cancel, mul_one])] + rw [Finset.sum_const, Finset.card_univ, nsmul_eq_mul] + +/-- Rank of an idempotent multiplication equals the regular +trace: the block dimension formula. -/ +theorem finrank_range_mulLeft [Group G] [Fintype G] + (y : MonoidAlgebra ℂ G) + (hy : y * y = y) : + (Module.finrank ℂ (LinearMap.range (mulLeft ℂ y)) : ℂ) = + (Fintype.card G : ℂ) * y.coeff 1 := by + classical + have hproj : IsProj (LinearMap.range (mulLeft ℂ y)) + (mulLeft ℂ y) := by + constructor + · intro z + exact LinearMap.mem_range_self _ z + · rintro z ⟨w, rfl⟩ + rw [mulLeft_apply, mulLeft_apply, ← mul_assoc, hy] + rw [← hproj.trace, trace_mulLeft] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SameCycleQuot.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SameCycleQuot.lean new file mode 100644 index 0000000000..1dc621f30e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SameCycleQuot.lean @@ -0,0 +1,151 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PowerSurj + +/-! +# The same-cycle quotient of a permutation + +The orbit space of a permutation of `Fin n` under the same-cycle +relation, its fintype structure, orbit sizes, and the +identification of functions fixed by the permutation with +functions on the orbit space. This is the indexing object for the +cycle-sum identity: a permutation's completed cycle-type product +expands as a sum over colourings of its orbits. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv Equiv.Perm + +variable {n : ℕ} (π : Equiv.Perm (Fin n)) + +/-- The same-cycle setoid of a permutation. -/ +def sameCycleSetoid : Setoid (Fin n) where + r a b := π.SameCycle a b + iseqv := ⟨Equiv.Perm.SameCycle.refl π, + Equiv.Perm.SameCycle.symm, Equiv.Perm.SameCycle.trans⟩ + +/-- The orbit space of a permutation. -/ +def OrbitSpace : Type := + Quotient (sameCycleSetoid π) + +/-- The class of a point. -/ +def orbitOf (i : Fin n) : OrbitSpace π := + Quotient.mk (sameCycleSetoid π) i + +/-- Two points have the same class exactly when they are on the same +cycle. -/ +theorem orbitOf_eq_iff {i j : Fin n} : + orbitOf π i = orbitOf π j ↔ π.SameCycle i j := + ⟨Quotient.exact, fun h => Quotient.sound h⟩ + +/-- Every orbit is the class of a point. -/ +theorem orbitOf_surjective : Function.Surjective (orbitOf π) := + Quotient.mk_surjective + +/-- The orbit space is finite, being a quotient of a finite type. -/ +noncomputable instance : Fintype (OrbitSpace π) := by + classical + exact @Quotient.fintype (Fin n) _ (sameCycleSetoid π) + (Classical.decRel _) + +/-- The fibre of an orbit: the points lying in it. -/ +noncomputable def orbFibre (O : OrbitSpace π) : Finset (Fin n) := by + classical + exact Finset.univ.filter (fun i => orbitOf π i = O) + +/-- The size of an orbit. -/ +noncomputable def orbCard (O : OrbitSpace π) : ℕ := + (orbFibre π O).card + +/-- Membership in an orbit's fibre. -/ +theorem mem_orbFibre {O : OrbitSpace π} {i : Fin n} : + i ∈ orbFibre π O ↔ orbitOf π i = O := by + classical + rw [orbFibre] + simp + +/-- Every fibre is nonempty. -/ +theorem orbFibre_nonempty (O : OrbitSpace π) : + (orbFibre π O).Nonempty := by + obtain ⟨i, rfl⟩ := orbitOf_surjective π O + exact ⟨i, (mem_orbFibre π).mpr rfl⟩ + +/-- Hence every orbit has positive size. -/ +theorem orbCard_pos (O : OrbitSpace π) : 0 < orbCard π O := + Finset.card_pos.mpr (orbFibre_nonempty π O) + +/-- A function fixed by `π` is constant along powers. -/ +theorem fixed_comp_zpow {C : Type*} {f : Fin n → C} + (hf : f ∘ π = f) : ∀ k : ℤ, f ∘ (π ^ k : Equiv.Perm (Fin n)) = f := by + have hinv : f ∘ ⇑π⁻¹ = f := by + funext a + have := congrFun hf (π⁻¹ a) + simpa using this.symm + intro k + induction k using Int.induction_on with + | zero => simp + | succ k ih => + funext a + have h1 : (π ^ ((k : ℤ) + 1) : Equiv.Perm (Fin n)) a = + (π ^ (k : ℤ) : Equiv.Perm (Fin n)) (π a) := by + rw [show (π ^ ((k : ℤ) + 1) : Equiv.Perm (Fin n)) = + (π ^ (k : ℤ)) * π from by rw [zpow_add, zpow_one]] + rfl + change f ((π ^ ((k : ℤ) + 1) : Equiv.Perm (Fin n)) a) = f a + rw [h1] + have h2 := congrFun ih (π a) + simp only [Function.comp_apply] at h2 + rw [h2] + exact congrFun hf a + | pred k ih => + funext a + have h1 : (π ^ ((-k : ℤ) - 1) : Equiv.Perm (Fin n)) a = + (π ^ (-k : ℤ) : Equiv.Perm (Fin n)) (π⁻¹ a) := by + rw [show (π ^ ((-k : ℤ) - 1) : Equiv.Perm (Fin n)) = + (π ^ (-k : ℤ)) * π⁻¹ from by + rw [zpow_sub, zpow_one]] + rfl + change f ((π ^ ((-k : ℤ) - 1) : Equiv.Perm (Fin n)) a) = f a + rw [h1] + have h2 := congrFun ih (π⁻¹ a) + simp only [Function.comp_apply] at h2 + rw [h2] + exact congrFun hinv a + +/-- Functions fixed by the permutation are exactly the functions +on the orbit space. -/ +noncomputable def fixedFunEquiv (C : Type*) : + {f : Fin n → C // f ∘ π = f} ≃ (OrbitSpace π → C) where + toFun f := Quotient.lift f.1 (by + intro a b hab + obtain ⟨k, hk⟩ := hab + have := congrFun (fixed_comp_zpow π f.2 k) a + simp only [Function.comp_apply] at this + rw [← hk] + exact this.symm ▸ this.symm ▸ this) + invFun g := ⟨fun i => g (orbitOf π i), by + funext i + change g (orbitOf π (π i)) = g (orbitOf π i) + refine congrArg g ((orbitOf_eq_iff π).mpr ?_) + exact ⟨-1, by simp⟩⟩ + left_inv f := Subtype.ext (funext fun i => rfl) + right_inv g := funext fun O => by + obtain ⟨i, rfl⟩ := orbitOf_surjective π O + rfl + +/-- The identification reads a fixed function's value at any point +of the orbit. -/ +@[simp] theorem fixedFunEquiv_apply_orbitOf {C : Type*} + (f : {f : Fin n → C // f ∘ π = f}) (i : Fin n) : + fixedFunEquiv π C f (orbitOf π i) = f.1 i := rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ScalarTrace.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ScalarTrace.lean new file mode 100644 index 0000000000..2d1c69202d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ScalarTrace.lean @@ -0,0 +1,73 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SchurAction + +/-! +# Identifying the Schur scalar by its trace + +The scalar through which a class-function element acts on an +irreducible representation is determined by the character pairing: +`z · dim V = ∑ g, c g · χ_ρ(g)`. +-/ + +@[expose] public section + +namespace RS + +open Finset LinearMap + +variable {G V : Type*} + +/-- The trace of the action of a class element is the character +pairing. -/ +theorem trace_asAlgebraHom_classElem + [Group G] [Fintype G] [AddCommGroup V] [Module ℂ V] + (ρ : Representation ℂ G V) + (c : G → ℂ) : + LinearMap.trace ℂ V (ρ.asAlgebraHom (classElem c)) = + ∑ g : G, c g * ρ.character g := by + rw [classElem, map_sum] + rw [show (LinearMap.trace ℂ V) + (∑ g : G, ρ.asAlgebraHom (c g • MonoidAlgebra.single g 1)) = + ∑ g : G, LinearMap.trace ℂ V + (ρ.asAlgebraHom (c g • MonoidAlgebra.single g 1)) from + map_sum _ _ _] + refine Finset.sum_congr rfl fun g _ => ?_ + rw [map_smul, map_smul, smul_eq_mul] + congr 1 + rw [show (ρ.asAlgebraHom (MonoidAlgebra.single g 1) : + V →ₗ[ℂ] V) = (ρ g : V →ₗ[ℂ] V) from by + rw [Representation.asAlgebraHom_single, one_smul]] + rfl + +/-- **The identified scalar action**: a class-function element +acts on an irreducible representation as the character-pairing +scalar divided by the dimension. -/ +theorem classElem_scalar_eq + [Group G] [Fintype G] [AddCommGroup V] [Module ℂ V] + [FiniteDimensional ℂ V] + {ρ : Representation ℂ G V} + (hirr : IsIrredRep ρ) (c : G → ℂ) + (hc : ∀ g h : G, c (h * g * h⁻¹) = c g) : + ρ.asAlgebraHom (classElem c) = + ((∑ g : G, c g * ρ.character g) / + (Module.finrank ℂ V : ℂ)) • LinearMap.id := by + classical + obtain ⟨z, hz⟩ := asAlgebraHom_classElem_scalar hirr c hc + have htr := trace_asAlgebraHom_classElem ρ c + rw [hz] at htr ⊢ + rw [map_smul, trace_id, smul_eq_mul] at htr + have : Nontrivial V := hirr.1 + have hdim : (Module.finrank ℂ V : ℂ) ≠ 0 := + Nat.cast_ne_zero.mpr Module.finrank_pos.ne' + congr 1 + rw [eq_div_iff hdim] + linear_combination htr + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SchurAction.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SchurAction.lean new file mode 100644 index 0000000000..159e2c1ff6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SchurAction.lean @@ -0,0 +1,118 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CentralElem + +/-! +# Schur scalarity for commuting endomorphisms + +Over ℂ, an endomorphism of a finite-dimensional irreducible +representation commuting with the group action is scalar: it has +an eigenvalue, and the eigenspace is an invariant subspace. The +image of a class-function element under a representation commutes +with the action, so it acts as a scalar on every irreducible. +-/ + +@[expose] public section + +namespace RS + +open Finset LinearMap + +variable {G V : Type*} + +/-- Irreducibility, spelled invariant-submodule-theoretically. -/ +def IsIrredRep [Group G] [AddCommGroup V] [Module ℂ V] + (ρ : Representation ℂ G V) : Prop := + Nontrivial V ∧ + ∀ p : Submodule ℂ V, + (∀ (g : G) (v : V), v ∈ p → ρ g v ∈ p) → p = ⊥ ∨ p = ⊤ + +/-- **Schur scalarity**: a commuting endomorphism of an +irreducible representation is scalar. -/ +theorem commuting_scalar + [Group G] [AddCommGroup V] [Module ℂ V] [FiniteDimensional ℂ V] + {ρ : Representation ℂ G V} + (hirr : IsIrredRep ρ) (T : Module.End ℂ V) + (hT : ∀ g : G, T ∘ₗ (ρ g : V →ₗ[ℂ] V) = + (ρ g : V →ₗ[ℂ] V) ∘ₗ T) : + ∃ c : ℂ, T = c • LinearMap.id := by + have : Nontrivial V := hirr.1 + obtain ⟨c, hc⟩ := Module.End.exists_eigenvalue T + refine ⟨c, ?_⟩ + have hker : LinearMap.ker (T - c • LinearMap.id) ≠ ⊥ := by + intro hbot + obtain ⟨v, hv⟩ := hc.exists_hasEigenvector + have hmem : v ∈ LinearMap.ker (T - c • LinearMap.id) := by + rw [LinearMap.mem_ker, LinearMap.sub_apply, + LinearMap.smul_apply, LinearMap.id_apply] + rw [hv.apply_eq_smul] + exact sub_self _ + rw [hbot, Submodule.mem_bot] at hmem + exact hv.2 hmem + have hinv : ∀ (g : G) (v : V), + v ∈ LinearMap.ker (T - c • LinearMap.id) → + ρ g v ∈ LinearMap.ker (T - c • LinearMap.id) := by + intro g v hv + rw [LinearMap.mem_ker] at hv ⊢ + rw [LinearMap.sub_apply, LinearMap.smul_apply, + LinearMap.id_apply] at hv ⊢ + have hTg := congrFun (congrArg (fun (f : V →ₗ[ℂ] V) => + (f : V → V)) (hT g)) v + simp only [LinearMap.coe_comp, Function.comp_apply] at hTg + rw [hTg] + rw [show T v = c • v from by + have := hv + linear_combination (norm := module) this] + rw [map_smul] + exact sub_self _ + rcases hirr.2 _ hinv with hbot | htop + · exact absurd hbot hker + · have : T - c • LinearMap.id = 0 := by + apply LinearMap.ext + intro v + have hv : v ∈ LinearMap.ker (T - c • LinearMap.id) := by + rw [htop]; exact Submodule.mem_top + rw [LinearMap.mem_ker] at hv + rw [hv]; rfl + have h2 := congrArg (fun (f : Module.End ℂ V) => + f + c • LinearMap.id) this + simpa using h2 + +/-- The image of a class-function element commutes with the +action. -/ +theorem asAlgebraHom_classElem_comm + [Group G] [Fintype G] [AddCommGroup V] [Module ℂ V] + (ρ : Representation ℂ G V) + (c : G → ℂ) (hc : ∀ g h : G, c (h * g * h⁻¹) = c g) (g : G) : + (ρ.asAlgebraHom (classElem c)) ∘ₗ (ρ g : V →ₗ[ℂ] V) = + (ρ g : V →ₗ[ℂ] V) ∘ₗ ρ.asAlgebraHom (classElem c) := by + classical + have h1 : ρ.asAlgebraHom (classElem c * MonoidAlgebra.single g 1) = + ρ.asAlgebraHom (MonoidAlgebra.single g 1 * classElem c) := by + rw [classElem_mul_comm c hc] + rw [map_mul, map_mul] at h1 + rw [show (ρ.asAlgebraHom (MonoidAlgebra.single g 1) : + V →ₗ[ℂ] V) = (ρ g : V →ₗ[ℂ] V) from by + rw [Representation.asAlgebraHom_single, one_smul]] at h1 + exact h1 + +/-- **Scalar action**: a class-function element acts as a scalar +on every irreducible representation. -/ +theorem asAlgebraHom_classElem_scalar + [Group G] [Fintype G] [AddCommGroup V] [Module ℂ V] + [FiniteDimensional ℂ V] + {ρ : Representation ℂ G V} + (hirr : IsIrredRep ρ) (c : G → ℂ) + (hc : ∀ g h : G, c (h * g * h⁻¹) = c g) : + ∃ z : ℂ, ρ.asAlgebraHom (classElem c) = z • LinearMap.id := by + classical + exact + commuting_scalar hirr _ (asAlgebraHom_classElem_comm ρ c hc) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SigmaCycleType.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SigmaCycleType.lean new file mode 100644 index 0000000000..4a15243a4d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SigmaCycleType.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# The cycle type of a fibrewise permutation + +The cycle type of `Equiv.Perm.sigmaCongrRight` is the sum of the +fibres' cycle types: a fibrewise permutation moves each fibre inside +itself, so its orbits are the fibres' orbits. +-/ + +@[expose] public section + +namespace RS + +open Equiv Equiv.Perm Finset + +variable {I : Type*} + +/-- The equivalence between `β i` and `{x : Σ j, β j // x.1 = i}`. -/ +private def eComp {β : I → Type*} + (i : I) : β i ≃ {x : Σ j, β j // x.1 = i} where + toFun b := ⟨⟨i, b⟩, rfl⟩ + invFun x := cast (congrArg β x.2) x.1.2 + left_inv b := by simp + right_inv := by + rintro ⟨⟨j, b⟩, rfl : j = i⟩ + simp + +private theorem mulSingle_perm_eq_one [DecidableEq I] {β : I → Type*} + {σ : ∀ i, Perm (β i)} {i k : I} (hki : k ≠ + i) : + @Pi.mulSingle I (fun j => Perm (β j)) _ _ i (σ i) k = 1 := + @Pi.mulSingle_eq_of_ne I (fun j => Perm (β j)) _ _ i k hki (σ i) + +/-- `sigmaCongrRight (Pi.mulSingle i (σ i))` equals +`(σ i).extendDomain (eComp i)`. -/ +private theorem sigmaCongrRight_mulSingle_eq_extendDomain + [DecidableEq I] {β : I → Type*} + (σ : ∀ i, Perm (β i)) (i : I) : + Perm.sigmaCongrRight (Pi.mulSingle i (σ i)) = (σ i).extendDomain (eComp i) + := by + apply Equiv.ext + intro ⟨j, b⟩ + by_cases hij : j = i + · subst hij + simp only [Equiv.sigmaCongrRight_apply, Pi.mulSingle_eq_same] + symm + change ((σ j).extendDomain (eComp j (β := β))) ⟨j, b⟩ = ⟨j, (σ j) b⟩ + have : ⟨j, b⟩ = (↑((eComp j (β := β)) b) : Σ k, β k) := rfl + conv_lhs => rw [this, Perm.extendDomain_apply_image] + simp [eComp] + · -- Both sides fix ⟨j, b⟩ since j ≠ i + have lhs : Perm.sigmaCongrRight (Pi.mulSingle i (σ i)) ⟨j, b⟩ = ⟨j, b⟩ := by + simp only [Equiv.sigmaCongrRight_apply] + congr 1 + rw [mulSingle_perm_eq_one hij, Perm.one_apply] + have rhs : ((σ i).extendDomain (eComp i (β := β))) ⟨j, b⟩ = ⟨j, b⟩ := + Perm.extendDomain_apply_not_subtype _ _ hij + rw [lhs, rhs] + +/-- Permutations obtained from `Pi.mulSingle` at different indices are +disjoint. -/ +private theorem disjoint_sigmaCongrRight_mulSingle + [DecidableEq I] {β : I → Type*} + (σ : ∀ i, Perm (β i)) {i j : I} (hij : i ≠ j) : + Perm.Disjoint (Perm.sigmaCongrRight (Pi.mulSingle i (σ i))) + (Perm.sigmaCongrRight (Pi.mulSingle j (σ j))) := by + intro ⟨k, b⟩ + simp only [Equiv.sigmaCongrRight_apply] + by_cases hki : k = i <;> by_cases hkj : k = j + · exact absurd (hki.symm.trans hkj) hij + · right; congr 1; rw [mulSingle_perm_eq_one hkj, Perm.one_apply] + · left; congr 1; rw [mulSingle_perm_eq_one hki, Perm.one_apply] + · left; congr 1; rw [mulSingle_perm_eq_one hki, Perm.one_apply] + +/-- `sigmaCongrRight σ` decomposes as a `noncommProd` over indices. -/ +private theorem sigmaCongrRight_eq_noncommProd + [DecidableEq I] [Fintype I] {β : I → Type*} + (σ : ∀ i, Perm (β i)) : + Perm.sigmaCongrRight σ = + univ.noncommProd (fun i => Perm.sigmaCongrRight (Pi.mulSingle i (σ i))) + (fun _i _ _j _ hij => + (disjoint_sigmaCongrRight_mulSingle σ hij).commute) := by + have h := Finset.noncommProd_mulSingle σ + apply_fun (sigmaCongrRightHom β) at h + erw [Finset.map_noncommProd] at h + exact h.symm + +/-- A fibrewise permutation's cycle type is the sum of the fibres': +no cycle crosses between fibres. -/ +theorem cycleType_sigmaCongrRight {I : Type*} [DecidableEq I] [Fintype I] + {β : I → Type*} [∀ i, DecidableEq (β i)] [∀ i, Fintype (β i)] + (σ : ∀ i, Equiv.Perm (β i)) : + (Equiv.Perm.sigmaCongrRight σ).cycleType = ∑ i, (σ i).cycleType := by + rw [sigmaCongrRight_eq_noncommProd σ] + rw [Equiv.Perm.Disjoint.cycleType_noncommProd + (fun _i _ _j _ hij => disjoint_sigmaCongrRight_mulSingle σ hij)] + congr 1 + ext i + rw [sigmaCongrRight_mulSingle_eq_extendDomain σ i, + Equiv.Perm.cycleType_extendDomain] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignResolve.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignResolve.lean new file mode 100644 index 0000000000..a0664de6e5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignResolve.lean @@ -0,0 +1,118 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.DimFormula +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTSimple + +/-! +# The sign resolution + +The Jacobi–Trudi character degree is a ratio of positive naturals, +so in the `±`-dichotomy of `jtChar_pm_simple` only the positive +sign survives: the Jacobi–Trudi character IS a native character. +-/ + +@[expose] public section + +namespace RS + +open Finset + +/-- The staircase exponents strictly decrease. -/ +theorem eStair_strictAnti (μ : YoungDiagram) + {i j : Fin μ.rowLens.length} (hij : i < j) : + eStair μ j < eStair μ i := by + have hmono : μ.rowLens.get j ≤ μ.rowLens.get i := + (List.sortedGE_iff_antitone_get.mp μ.rowLens_sorted) + (le_of_lt hij) + have hi := i.isLt + have hj := j.isLt + have hij' : (i : ℕ) < (j : ℕ) := hij + rw [eStair, eStair] + omega + +/-- **Positivity of the degree**: a positive natural multiple of +`jtChar μ 1` is a positive natural. -/ +theorem jtChar_one_pos_identity (μ : YoungDiagram) : + ∃ N D : ℕ, 0 < N ∧ 0 < D ∧ + (D : ℂ) * jtChar μ 1 = (N : ℂ) := by + classical + refine ⟨μ.card.factorial * + ∏ i : Fin μ.rowLens.length, ∏ j ∈ Finset.Ioi i, + (eStair μ (Fin.revPerm j) - eStair μ (Fin.revPerm i)), + ∏ i : Fin μ.rowLens.length, (eStair μ i).factorial, + ?_, ?_, ?_⟩ + · refine Nat.mul_pos (Nat.factorial_pos _) + (Finset.prod_pos fun i _ => Finset.prod_pos fun j hj => ?_) + have hij : i < j := Finset.mem_Ioi.mp hj + have hrev : Fin.revPerm j < Fin.revPerm i := by + have hi := i.isLt + have hj' := j.isLt + have h1 : ((Fin.revPerm j : Fin _) : ℕ) = + _ - ((j : ℕ) + 1) := Fin.val_rev j + have h2 : ((Fin.revPerm i : Fin _) : ℕ) = + _ - ((i : ℕ) + 1) := Fin.val_rev i + have hij' : (i : ℕ) < (j : ℕ) := hij + rw [Fin.lt_def, h1, h2] + omega + exact Nat.sub_pos_of_lt (eStair_strictAnti μ hrev) + · exact Finset.prod_pos fun i _ => Nat.factorial_pos _ + · rw [jtChar_one_eq] + have h2 := diagramSchur_delta_mul μ + push_cast + rw [show ((∏ i : Fin μ.rowLens.length, + ((eStair μ i).factorial : ℂ))) * + ((μ.card.factorial : ℂ) * diagramSchur μ deltaSeq) = + (μ.card.factorial : ℂ) * + (diagramSchur μ deltaSeq * + ∏ i : Fin μ.rowLens.length, + ((eStair μ i).factorial : ℂ)) from by ring] + rw [h2] + congr 1 + refine Finset.prod_congr rfl fun i _ => ?_ + refine Finset.prod_congr rfl fun j hj => ?_ + have hij : i < j := Finset.mem_Ioi.mp hj + have hrev : Fin.revPerm j < Fin.revPerm i := by + have hi := i.isLt + have hj' := j.isLt + have h1 : ((Fin.revPerm j : Fin _) : ℕ) = + _ - ((j : ℕ) + 1) := Fin.val_rev j + have h2 : ((Fin.revPerm i : Fin _) : ℕ) = + _ - ((i : ℕ) + 1) := Fin.val_rev i + have hij' : (i : ℕ) < (j : ℕ) := hij + rw [Fin.lt_def, h1, h2] + omega + rw [Nat.cast_sub (le_of_lt (eStair_strictAnti μ hrev))] + +open scoped Classical in +/-- **The Jacobi–Trudi character is a native character.** -/ +theorem jtChar_eq_nChar (μ : YoungDiagram) : + ∃ S₀ : Submodule (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) + (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))), + IsSimpleModule (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) + S₀ ∧ + ∀ π, jtChar μ π = nChar S₀ π := by + obtain ⟨S₀, hS₀, hpm⟩ := jtChar_pm_simple μ + refine ⟨S₀, hS₀, ?_⟩ + rcases hpm with hpos | hneg + · exact hpos + · exfalso + obtain ⟨N, D, hN, hD, hid⟩ := jtChar_one_pos_identity μ + rw [hneg 1] at hid + rw [show nChar S₀ 1 = + ((Module.finrank ℂ (subCarrier S₀) : ℕ) : ℂ) from by + rw [nChar, Representation.char_one]] at hid + have hcast : ((D * Module.finrank ℂ (subCarrier S₀) + N : + ℕ) : ℂ) = 0 := by + push_cast + linear_combination -hid + have h0 : D * Module.finrank ℂ (subCarrier S₀) + N = 0 := by + exact_mod_cast hcast + omega + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignedTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignedTensor.lean new file mode 100644 index 0000000000..b6d39c604c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignedTensor.lean @@ -0,0 +1,127 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorTrace +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialH +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PackageAssembly + +/-! +# Signed tensor identities + +The sign-twisted cycle product for constant sequences, and the +signed Frobenius sum expressing the twisted trace in terms of +Schur values at the negated sequence. +-/ + +@[expose] public section + +namespace RS + +open Finset + +/-! ## Helper: cycleProd at a constant sequence -/ + +/-- `cycleProd` at a constant sequence is a single power. -/ +theorem cycleProd_const {n : ℕ} (c : ℂ) (π : Equiv.Perm (Fin n)) : + cycleProd (fun _ => c) π = + c ^ (Multiset.card π.cycleType + (n - π.cycleType.sum)) := by + unfold cycleProd + rw [Multiset.map_const', Multiset.prod_replicate, pow_add] + +/-! ## Helper: ℤˣ sign cast to ℂ -/ + +/-- The sign of a permutation, cast ℤˣ → ℤ → ℂ, equals `(-1 : ℂ)` raised + to `cycleType.sum + card cycleType`. -/ +theorem sign_cast_complex {n : ℕ} (π : Equiv.Perm (Fin n)) : + ((Equiv.Perm.sign π : ℤ) : ℂ) = + (-1 : ℂ) ^ (π.cycleType.sum + Multiset.card π.cycleType) := by + rw [Equiv.Perm.sign_of_cycleType] + push_cast + ring + +/-! ## Helper: parity identity -/ + +private theorem neg_one_pow_parity {s c n : ℕ} (hsn : s ≤ n) : + (-1 : ℂ) ^ (s + c) = (-1 : ℂ) ^ (n + (c + (n - s))) := by + apply neg_one_pow_congr + constructor + · intro ⟨k, hk⟩; exact ⟨k + (n - s), by omega⟩ + · intro ⟨k, hk⟩; exact ⟨k - (n - s), by omega⟩ + +/-! ## The sign twist of a constant cycle product -/ + +open scoped Classical in +/-- The sign twist of a constant cycle product is the product at the +negated constant. -/ +theorem sign_mul_cycleProd_const {n : ℕ} (m : ℕ) + (π : Equiv.Perm (Fin n)) : + ((Equiv.Perm.sign π : ℤ) : ℂ) * + cycleProd (fun _ => (m : ℂ)) π = + ((-1 : ℂ)) ^ n * cycleProd (fun _ => -(m : ℂ)) π := by + rw [cycleProd_const (m : ℂ) π, cycleProd_const (-(m : ℂ)) π] + rw [sign_cast_complex π] + set s := π.cycleType.sum + set c := Multiset.card π.cycleType + set K := c + (n - s) + have hsn : s ≤ n := by + have := Equiv.Perm.sum_cycleType_le π + simp only [Fintype.card_fin] at this + exact this + -- RHS: (-1)^n * ((-m)^K) = (-1)^n * ((-1)^K * m^K) + have hneg : (-(m : ℂ)) ^ K = (-1 : ℂ) ^ K * (m : ℂ) ^ K := + neg_pow (m : ℂ) K + rw [hneg] + -- LHS = (-1)^(s+c) * m^K, RHS = (-1)^n * ((-1)^K * m^K) + -- Rewrite RHS: (-1)^n * ((-1)^K * m^K) = (-1)^(n+K) * m^K + rw [← mul_assoc, ← pow_add] + -- Now: (-1)^(s+c) * m^K = (-1)^(n+K) * m^K + congr 1 + exact neg_one_pow_parity hsn + +/-! ## The signed Frobenius sum -/ + +open scoped Classical in +/-- **The signed Frobenius sum**: the twisted trace is the Schur +value at the negated sequence, up to the sign and the factorial. -/ +theorem signed_tensor_sum (m : ℕ) (μ : YoungDiagram) : + (∑ π : Equiv.Perm (Fin μ.card), + jtChar μ π * (((Equiv.Perm.sign π : ℤ) : ℂ) * + cycleProd (fun _ => (m : ℂ)) π)) = + ((-1 : ℂ)) ^ μ.card * (μ.card.factorial : ℂ) * + diagramSchur μ (fun _ => -(m : ℂ)) := by + -- Step 1: rewrite each summand using sign_mul_cycleProd_const + have hrew : ∀ π : Equiv.Perm (Fin μ.card), π ∈ Finset.univ → + jtChar μ π * (((Equiv.Perm.sign π : ℤ) : ℂ) * + cycleProd (fun _ => (m : ℂ)) π) = + jtChar μ π * (((-1 : ℂ)) ^ μ.card * + cycleProd (fun _ => -(m : ℂ)) π) := by + intro π _ + rw [sign_mul_cycleProd_const m π] + rw [Finset.sum_congr rfl hrew] + -- Step 2: factor out (-1)^μ.card and reassociate + have hassoc : ∀ π : Equiv.Perm (Fin μ.card), π ∈ Finset.univ → + jtChar μ π * (((-1 : ℂ)) ^ μ.card * + cycleProd (fun _ => -(m : ℂ)) π) = + ((-1 : ℂ)) ^ μ.card * + (jtChar μ π * cycleProd (fun _ => -(m : ℂ)) π) := by + intro π _ + ring + rw [Finset.sum_congr rfl hassoc, ← Finset.mul_sum] + -- Step 3: apply jtChar_frobenius' + have hfrob := jtChar_frobenius' μ (fun _ => -(m : ℂ)) + have hfac : ((μ.card.factorial : ℂ)) ≠ 0 := by + exact_mod_cast Nat.factorial_ne_zero μ.card + have hsum : (∑ π : Equiv.Perm (Fin μ.card), + jtChar μ π * cycleProd (fun _ => -(m : ℂ)) π) = + (μ.card.factorial : ℂ) * + diagramSchur μ (fun _ => -(m : ℂ)) := by + rw [← hfrob, ← mul_assoc, mul_inv_cancel₀ hfac, one_mul] + rw [hsum] + ring + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SimpleEmbed.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SimpleEmbed.lean new file mode 100644 index 0000000000..6b60d0ac41 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SimpleEmbed.lean @@ -0,0 +1,77 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeTable + +/-! +# Every simple module embeds in the regular module + +Every simple `ℂ[G]`-module is isomorphic (as a module) to a simple +submodule of the regular module `MonoidAlgebra ℂ G`. +-/ + +@[expose] public section + +namespace RS + +open LinearMap + +variable {G : Type*} + +/-- Every simple `ℂ[G]`-module is isomorphic to a simple submodule +of the regular module. -/ +theorem exists_simple_submodule_linearEquiv [Group G] [Finite G] + (M : Type*) [AddCommGroup M] [Module (MonoidAlgebra ℂ G) M] + (hM : IsSimpleModule (MonoidAlgebra ℂ G) M) : + ∃ S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G), + IsSimpleModule (MonoidAlgebra ℂ G) S ∧ + Nonempty (S ≃ₗ[MonoidAlgebra ℂ G] M) := by + classical + let := Fintype.ofFinite G + -- Pick a nonzero element m : M. + have := IsSimpleModule.nontrivial (MonoidAlgebra ℂ G) M + obtain ⟨m, hm⟩ := exists_ne (0 : M) + -- The map φ : MonoidAlgebra ℂ G →ₗ[MonoidAlgebra ℂ G] M, x ↦ x • m. + let φ : MonoidAlgebra ℂ G →ₗ[MonoidAlgebra ℂ G] M := + LinearMap.toSpanSingleton (MonoidAlgebra ℂ G) M m + -- φ is surjective: its range is a nonzero submodule of the simple M, hence ⊤. + have hφ_surj : Function.Surjective φ := by + rw [← range_eq_top] + have hne : range φ ≠ ⊥ := by + rw [ne_eq, eq_bot_iff] + intro h + have h1 : φ 1 ∈ range φ := mem_range_self φ 1 + have h1bot := h h1 + rw [Submodule.mem_bot] at h1bot + simp only [toSpanSingleton, smulRight, id_coe, id_eq, coe_mk, AddHom.coe_mk, one_smul, + φ] at h1bot + exact hm h1bot + rcases hM.eq_bot_or_eq_top (range φ) with h | h + · exact absurd h hne + · exact h + -- The kernel K := ker φ. + let K := ker φ + -- By Maschke / semisimplicity, K has a complement S. + have : NeZero ((Nat.card G : ℂ)) := ⟨by + rw [Nat.card_eq_fintype_card] + exact_mod_cast Fintype.card_ne_zero⟩ + have : IsSemisimpleModule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G) + := inferInstance + obtain ⟨S, hcompl⟩ := exists_isCompl K + -- Build the linear equivalence S ≃ₗ M. + let e₁ : (MonoidAlgebra ℂ G ⧸ K) ≃ₗ[MonoidAlgebra ℂ G] M := + φ.quotKerEquivOfSurjective hφ_surj + let e₂ : (MonoidAlgebra ℂ G ⧸ K) ≃ₗ[MonoidAlgebra ℂ G] S := + Submodule.quotientEquivOfIsCompl K S hcompl + let e : S ≃ₗ[MonoidAlgebra ℂ G] M := e₂.symm.trans e₁ + -- S is simple because it is linearly equivalent to the simple module M. + have hS : IsSimpleModule (MonoidAlgebra ℂ G) S := + IsSimpleModule.congr e + exact ⟨S, hS, ⟨e⟩⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareGrowth.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareGrowth.lean new file mode 100644 index 0000000000..caaf180561 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareGrowth.lean @@ -0,0 +1,153 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareStair + +/-! +# The square dimension growth + +Evaluating the natural dimension identity at square diagrams: the +Vandermonde side is the superfactorial, the factorial side is at +most `(2s)^(s²)` times it, so the dimension dominates +`(s²)^(s²) / (6s)^(s²) = (s/6)^(s²)` — beating any `R^(s²)` for +`s = 6(R+1)`. The factorial lower bound `n^n ≤ 3^n·n!` enters as +the hypothesis `H3`, discharged in `FactorialBound.lean`. +-/ + +@[expose] public section + +namespace RS + +open Finset + +/-- The square Vandermonde side is the superfactorial. -/ +theorem square_V_eq (s : ℕ) : + (∏ i : Fin (squareDiagram s).rowLens.length, + ∏ j ∈ Finset.Ioi i, + (eStair (squareDiagram s) (Fin.revPerm j) - + eStair (squareDiagram s) (Fin.revPerm i))) = + ∏ i : Fin (squareDiagram s).rowLens.length, + (((squareDiagram s).rowLens.length - 1) - (i : ℕ)).factorial + := by + classical + refine Finset.prod_congr rfl fun i _ => ?_ + rw [← Ioi_prod_sub i] + refine Finset.prod_congr rfl fun j hj => ?_ + have hL := square_rowLens_length s + have hi := i.isLt + have hj' := j.isLt + have hij : i < j := Finset.mem_Ioi.mp hj + have hij' : (i : ℕ) < (j : ℕ) := hij + have hrj : ((Fin.revPerm j : Fin _) : ℕ) = + _ - ((j : ℕ) + 1) := Fin.val_rev j + have hri : ((Fin.revPerm i : Fin _) : ℕ) = + _ - ((i : ℕ) + 1) := Fin.val_rev i + rw [eStair_square s (Fin.revPerm j), + eStair_square s (Fin.revPerm i), hrj, hri] + omega + +/-- The square factorial side is bounded by `(2s)^(s²)` times the +superfactorial. -/ +theorem square_D_le (s : ℕ) (_hs : 1 ≤ s) : + (∏ i : Fin (squareDiagram s).rowLens.length, + (eStair (squareDiagram s) i).factorial) ≤ + (2 * s) ^ (s ^ 2) * + ∏ i : Fin (squareDiagram s).rowLens.length, + (((squareDiagram s).rowLens.length - 1) - + (i : ℕ)).factorial := by + classical + have hL := square_rowLens_length s + calc (∏ i : Fin (squareDiagram s).rowLens.length, + (eStair (squareDiagram s) i).factorial) ≤ + ∏ i : Fin (squareDiagram s).rowLens.length, + ((2 * s) ^ s * + (((squareDiagram s).rowLens.length - 1) - + (i : ℕ)).factorial) := by + refine Finset.prod_le_prod (fun i _ => ?_) + rw [eStair_square s i] + have hi := i.isLt + rw [show ((squareDiagram s).rowLens.length - 1) - + (i : ℕ) = (s - 1) - (i : ℕ) from by omega] + exact shifted_factorial_le s ((s - 1) - (i : ℕ)) + (by omega) + _ = ((2 * s) ^ s) ^ (squareDiagram s).rowLens.length * + ∏ i : Fin (squareDiagram s).rowLens.length, + (((squareDiagram s).rowLens.length - 1) - + (i : ℕ)).factorial := by + rw [Finset.prod_mul_distrib, Finset.prod_const, + Finset.card_univ, Fintype.card_fin] + _ = (2 * s) ^ (s ^ 2) * + ∏ i : Fin (squareDiagram s).rowLens.length, + (((squareDiagram s).rowLens.length - 1) - + (i : ℕ)).factorial := by + rw [← pow_mul, hL, sq] + +open scoped Classical in +/-- **The square dimension growth**, modulo the factorial lower +bound. -/ +theorem square_growth + (H3 : ∀ n : ℕ, n ^ n ≤ 3 ^ n * n.factorial) (R : ℕ) : + ∃ s : ℕ, ∀ S₀ : Submodule + (MonoidAlgebra ℂ (Equiv.Perm (Fin (squareDiagram s).card))) + (MonoidAlgebra ℂ (Equiv.Perm (Fin (squareDiagram s).card))), + (∀ π, jtChar (squareDiagram s) π = nChar S₀ π) → + R ^ (s ^ 2) < nDim S₀ := by + refine ⟨6 * (R + 1), fun S₀ hchar => ?_⟩ + generalize hgen : 6 * (R + 1) = s at S₀ hchar ⊢ + have hs1 : 1 ≤ s := by omega + have hid := dim_mul_eq (squareDiagram s) S₀ hchar + rw [square_V_eq] at hid + have hn : (squareDiagram s).card = s ^ 2 := squareDiagram_card s + set V := ∏ i : Fin (squareDiagram s).rowLens.length, + (((squareDiagram s).rowLens.length - 1) - (i : ℕ)).factorial + with hV + have hVpos : 0 < V := + Finset.prod_pos fun i _ => Nat.factorial_pos _ + have hD := square_D_le s hs1 + -- dim * (2s)^(s²) * V ≥ dim * D = (s²)! * V + have h1 : (squareDiagram s).card.factorial * V ≤ + nDim S₀ * ((2 * s) ^ (s ^ 2) * V) := by + rw [← hid] + exact Nat.mul_le_mul_left _ hD + have h2 : (s ^ 2).factorial ≤ nDim S₀ * (2 * s) ^ (s ^ 2) := by + have h3 : (squareDiagram s).card.factorial * V ≤ + (nDim S₀ * (2 * s) ^ (s ^ 2)) * V := by + calc (squareDiagram s).card.factorial * V ≤ + nDim S₀ * ((2 * s) ^ (s ^ 2) * V) := h1 + _ = (nDim S₀ * (2 * s) ^ (s ^ 2)) * V := by ring + have h2' := Nat.le_of_mul_le_mul_right h3 hVpos + exact hn ▸ h2' + -- (s²)^(s²) ≤ 3^(s²) (s²)! ≤ dim * (6s)^(s²) + have h4 : (s ^ 2) ^ (s ^ 2) ≤ nDim S₀ * (6 * s) ^ (s ^ 2) := by + calc (s ^ 2) ^ (s ^ 2) ≤ 3 ^ (s ^ 2) * (s ^ 2).factorial := + H3 (s ^ 2) + _ ≤ 3 ^ (s ^ 2) * (nDim S₀ * (2 * s) ^ (s ^ 2)) := + Nat.mul_le_mul_left _ h2 + _ = nDim S₀ * (3 ^ (s ^ 2) * (2 * s) ^ (s ^ 2)) := by ring + _ = nDim S₀ * (6 * s) ^ (s ^ 2) := by + rw [← Nat.mul_pow] + congr 2 + ring + -- (s²)^(s²) > R^(s²) * (6s)^(s²) + have h5 : R ^ (s ^ 2) * (6 * s) ^ (s ^ 2) < + (s ^ 2) ^ (s ^ 2) := by + have h6s : (0 : ℕ) < 6 * s := by omega + have hlt : R * (6 * s) < (R + 1) * (6 * s) := + mul_lt_mul_of_pos_right (by omega) h6s + have heq : (R + 1) * (6 * s) = s ^ 2 := by + rw [← hgen] + ring + have hbase : R * (6 * s) < s ^ 2 := heq ▸ hlt + rw [← Nat.mul_pow] + exact Nat.pow_lt_pow_left hbase + (pow_ne_zero 2 (show s ≠ 0 from by omega)) + have h6 : R ^ (s ^ 2) * (6 * s) ^ (s ^ 2) < + nDim S₀ * (6 * s) ^ (s ^ 2) := lt_of_lt_of_le h5 h4 + exact Nat.lt_of_mul_lt_mul_right h6 + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareGrowthSharp.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareGrowthSharp.lean new file mode 100644 index 0000000000..8fe22a6ae5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareGrowthSharp.lean @@ -0,0 +1,133 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowth + +/-! +# Sharp square dimension growth via the exponential bound + +The sharp form of the square-dimension growth: it runs on the +analytic `n ^ n ≤ e ^ n · n !` (one term of the Taylor series of +`exp`) where `square_growth` runs on the cruder combinatorial +`n ^ n ≤ 3 ^ n · n !`, and it is the sharp constant that yields the +displayed `2e` of the paper. +-/ + +@[expose] public section + +namespace RS + +open Finset + +/-- The key analytic fact: `n ^ n ≤ exp n · n!`, obtained from +`pow_div_factorial_le_exp`. -/ +private theorem pow_le_exp_mul_factorial (n : ℕ) : + ((n : ℝ)) ^ n ≤ Real.exp ((n : ℝ)) * ((n.factorial : ℕ) : ℝ) := by + have hfact_pos : (0 : ℝ) < ((n.factorial : ℕ) : ℝ) := by + exact_mod_cast Nat.factorial_pos n + have hpdf := Real.pow_div_factorial_le_exp (n : ℝ) (Nat.cast_nonneg n) n + calc ((n : ℝ)) ^ n + = ((n : ℝ)) ^ n / ((n.factorial : ℕ) : ℝ) * ((n.factorial : ℕ) : ℝ) := by + rw [div_mul_cancel₀ _ (ne_of_gt hfact_pos)] + _ ≤ Real.exp ((n : ℝ)) * ((n.factorial : ℕ) : ℝ) := + mul_le_mul_of_nonneg_right hpdf hfact_pos.le + +open scoped Classical in +/-- **Sharp square dimension growth.** For a real `R ≥ 0` and any +`s > 2eR`, every submodule of the regular module whose character +equals the JT character of the `s × s` square diagram has dimension +exceeding `R ^ (s²)`. + +This recovers the paper's displayed `2e`: the proof runs on +`n ^ n ≤ e ^ n · n !`, and it is that `e` which appears in the +threshold. The paper makes no claim that `2e` cannot be +improved. -/ +theorem square_growth_sharp (R : ℝ) (hR : 0 ≤ R) (s : ℕ) + (hs : 2 * Real.exp 1 * R < s) : + ∀ S₀ : Submodule + (MonoidAlgebra ℂ (Equiv.Perm (Fin (squareDiagram s).card))) + (MonoidAlgebra ℂ (Equiv.Perm (Fin (squareDiagram s).card))), + (∀ π, jtChar (squareDiagram s) π = nChar S₀ π) → + R ^ (s ^ 2) < (nDim S₀ : ℝ) := by + intro S₀ hchar + -- ═══════ PRELIMINARY: 1 ≤ s ═══════ + -- `2eR` is nonnegative, so a strictly larger natural number is + -- positive. + have hs1 : 1 ≤ s := by + rcases Nat.eq_zero_or_pos s with rfl | hpos + · exact absurd hs (by + simpa using not_lt.2 (mul_nonneg + (mul_nonneg (by norm_num : (0 : ℝ) ≤ 2) (Real.exp_pos 1).le) hR)) + · exact hpos + -- ═══════ STAGE 1: THE ℕ-IDENTITY GIVES (s²)! ≤ dim · (2s)^(s²) ═══════ + have hid := dim_mul_eq (squareDiagram s) S₀ hchar + rw [square_V_eq] at hid + have hn : (squareDiagram s).card = s ^ 2 := squareDiagram_card s + set V := ∏ i : Fin (squareDiagram s).rowLens.length, + (((squareDiagram s).rowLens.length - 1) - (i : ℕ)).factorial + with hV_def + have hVpos : 0 < V := Finset.prod_pos fun i _ => Nat.factorial_pos _ + have hD := square_D_le s hs1 + have h_fact_le : (s ^ 2).factorial ≤ nDim S₀ * (2 * s) ^ (s ^ 2) := by + have h3 : (squareDiagram s).card.factorial * V ≤ + (nDim S₀ * (2 * s) ^ (s ^ 2)) * V := by + calc (squareDiagram s).card.factorial * V + ≤ nDim S₀ * ((2 * s) ^ (s ^ 2) * V) := by + rw [← hid]; exact Nat.mul_le_mul_left _ hD + _ = (nDim S₀ * (2 * s) ^ (s ^ 2)) * V := by ring + have h4 := Nat.le_of_mul_le_mul_right h3 hVpos + exact hn ▸ h4 + -- ═══════ STAGE 2: THE ANALYTIC BOUND, IN ℝ ═══════ + have hs_pos : (0 : ℝ) < (s : ℝ) := Nat.cast_pos.mpr (by omega) + have h_analytic : ((s ^ 2 : ℕ) : ℝ) ^ (s ^ 2) ≤ + Real.exp ((s ^ 2 : ℕ) : ℝ) * (((s ^ 2).factorial : ℕ) : ℝ) := + pow_le_exp_mul_factorial (s ^ 2) + have h_fact_le_R : (((s ^ 2).factorial : ℕ) : ℝ) ≤ + ((nDim S₀ : ℕ) : ℝ) * (((2 * s) ^ (s ^ 2) : ℕ) : ℝ) := by + exact_mod_cast h_fact_le + have hexp_eq : Real.exp ((s ^ 2 : ℕ) : ℝ) = Real.exp 1 ^ (s ^ 2) := + (Real.exp_one_pow (s ^ 2)).symm + have hcast_sq : ((s ^ 2 : ℕ) : ℝ) = (s : ℝ) ^ 2 := by push_cast; ring + have hcast_2s : (((2 * s) ^ (s ^ 2) : ℕ) : ℝ) = (2 * (s : ℝ)) ^ (s ^ 2) := by + push_cast; ring + set C := Real.exp 1 ^ (s ^ 2) * (2 * (s : ℝ)) ^ (s ^ 2) with hC_def + have hC_pos : (0 : ℝ) < C := + mul_pos (pow_pos (Real.exp_pos 1) _) (pow_pos (by linarith) _) + have h_combined : ((s : ℝ) ^ 2) ^ (s ^ 2) ≤ (nDim S₀ : ℝ) * C := by + calc ((s : ℝ) ^ 2) ^ (s ^ 2) + = ((s ^ 2 : ℕ) : ℝ) ^ (s ^ 2) := by rw [hcast_sq] + _ ≤ Real.exp ((s ^ 2 : ℕ) : ℝ) * ((((s ^ 2).factorial : ℕ) : ℝ)) := + h_analytic + _ ≤ Real.exp ((s ^ 2 : ℕ) : ℝ) * + (((nDim S₀ : ℕ) : ℝ) * (((2 * s) ^ (s ^ 2) : ℕ) : ℝ)) := + mul_le_mul_of_nonneg_left h_fact_le_R (Real.exp_nonneg _) + _ = (nDim S₀ : ℝ) * C := by + rw [hexp_eq, hcast_2s, hC_def]; ring + -- ═══════ STAGE 3: THE BASE COMPARISON, AND CANCELLING C ═══════ + -- `R ^ (s²) · C` is exactly `(2eRs) ^ (s²)`, which the hypothesis + -- puts below `(s²) ^ (s²)`. + have hbase : 2 * Real.exp 1 * R * (s : ℝ) < (s : ℝ) ^ 2 := by + calc 2 * Real.exp 1 * R * (s : ℝ) + = (2 * Real.exp 1 * R) * (s : ℝ) := by ring + _ < (s : ℝ) * (s : ℝ) := mul_lt_mul_of_pos_right hs hs_pos + _ = (s : ℝ) ^ 2 := by ring + have h_pow_lt : (2 * Real.exp 1 * R * (s : ℝ)) ^ (s ^ 2) < + ((s : ℝ) ^ 2) ^ (s ^ 2) := + pow_lt_pow_left₀ hbase (by positivity) (pow_ne_zero 2 (by omega)) + have h_lhs_eq : R ^ (s ^ 2) * C = + (2 * Real.exp 1 * R * (s : ℝ)) ^ (s ^ 2) := by + rw [hC_def, ← mul_assoc, ← mul_pow, ← mul_pow] + congr 1; ring + have h_main : R ^ (s ^ 2) * C < (nDim S₀ : ℝ) * C := + calc R ^ (s ^ 2) * C + = (2 * Real.exp 1 * R * (s : ℝ)) ^ (s ^ 2) := h_lhs_eq + _ < ((s : ℝ) ^ 2) ^ (s ^ 2) := h_pow_lt + _ ≤ (nDim S₀ : ℝ) * C := h_combined + exact lt_of_mul_lt_mul_right h_main hC_pos.le + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareStair.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareStair.lean new file mode 100644 index 0000000000..7411eb4be1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareStair.lean @@ -0,0 +1,154 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignResolve + +/-! +# The natural dimension identity and square staircases + +The dimension identity `nDim S₀ · ∏ eᵢ! = n! · ∏∏ diffs` at the +natural-number level, the staircase evaluation for square +diagrams, and the elementary factorial bounds feeding the square +growth estimate. +-/ + +@[expose] public section + +namespace RS + +open Finset + +/-- **The natural dimension identity.** -/ +theorem dim_mul_eq (μ : YoungDiagram) + (S₀ : Submodule (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) + (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card)))) + (hchar : ∀ π, jtChar μ π = nChar S₀ π) : + nDim S₀ * ∏ i : Fin μ.rowLens.length, + (eStair μ i).factorial = + μ.card.factorial * ∏ i : Fin μ.rowLens.length, + ∏ j ∈ Finset.Ioi i, + (eStair μ (Fin.revPerm j) - eStair μ (Fin.revPerm i)) := by + classical + have h1 := jtChar_one_eq μ + have h2 := diagramSchur_delta_mul μ + have h3 : jtChar μ 1 = ((nDim S₀ : ℕ) : ℂ) := by + rw [hchar 1, nChar, Representation.char_one] + rfl + have hkey : ((nDim S₀ : ℕ) : ℂ) * + ∏ i : Fin μ.rowLens.length, + ((eStair μ i).factorial : ℂ) = + (μ.card.factorial : ℂ) * + ∏ i : Fin μ.rowLens.length, ∏ j ∈ Finset.Ioi i, + (((eStair μ (Fin.revPerm j)) : ℂ) - + ((eStair μ (Fin.revPerm i)) : ℂ)) := by + rw [← h3, h1, mul_assoc, h2] + have hdiff : ∀ (i : Fin μ.rowLens.length) + (j : Fin μ.rowLens.length), i < j → + (((eStair μ (Fin.revPerm j)) : ℂ) - + ((eStair μ (Fin.revPerm i)) : ℂ)) = + (((eStair μ (Fin.revPerm j) - + eStair μ (Fin.revPerm i) : ℕ)) : ℂ) := by + intro i j hij + have hrev : Fin.revPerm j < Fin.revPerm i := by + have hi := i.isLt + have hj' := j.isLt + have h1' : ((Fin.revPerm j : Fin _) : ℕ) = + _ - ((j : ℕ) + 1) := Fin.val_rev j + have h2' : ((Fin.revPerm i : Fin _) : ℕ) = + _ - ((i : ℕ) + 1) := Fin.val_rev i + have hij' : (i : ℕ) < (j : ℕ) := hij + rw [Fin.lt_def, h1', h2'] + omega + rw [Nat.cast_sub (le_of_lt (eStair_strictAnti μ hrev))] + rw [Finset.prod_congr rfl (fun i (_ : i ∈ Finset.univ) => + Finset.prod_congr rfl (fun j hj => + hdiff i j (Finset.mem_Ioi.mp hj)))] at hkey + have hcast : ((nDim S₀ * + ∏ i : Fin μ.rowLens.length, (eStair μ i).factorial : ℕ) : + ℂ) = + ((μ.card.factorial * + ∏ i : Fin μ.rowLens.length, ∏ j ∈ Finset.Ioi i, + (eStair μ (Fin.revPerm j) - + eStair μ (Fin.revPerm i)) : ℕ) : ℂ) := by + push_cast + linear_combination hkey + exact_mod_cast hcast + +/-- The square diagram has `s` rows. -/ +theorem square_rowLens_length (s : ℕ) : + (squareDiagram s).rowLens.length = s := by + rw [squareDiagram_rowLens, List.length_replicate] + +/-- The square staircase evaluates to `2s − 1 − i`. -/ +theorem eStair_square (s : ℕ) + (i : Fin (squareDiagram s).rowLens.length) : + eStair (squareDiagram s) i = s + ((s - 1) - (i : ℕ)) := by + have hL := square_rowLens_length s + have hi : (i : ℕ) < s := by + have := i.isLt + omega + rw [eStair, List.get_eq_getElem, YoungDiagram.get_rowLens, + rowLen_squareDiagram hi] + omega + +/-- Interval products are factorials. -/ +theorem Ioi_prod_sub {L : ℕ} (i : Fin L) : + (∏ j ∈ Finset.Ioi i, ((j : ℕ) - (i : ℕ))) = + ((L - 1) - (i : ℕ)).factorial := by + classical + have hi := i.isLt + have himg : (Finset.Ioi i).image (Fin.val) = + Finset.Ico ((i : ℕ) + 1) L := by + ext n + simp only [Finset.mem_image, Finset.mem_Ioi, Finset.mem_Ico] + constructor + · rintro ⟨j, hj, rfl⟩ + exact ⟨hj, j.isLt⟩ + · rintro ⟨h1, h2⟩ + exact ⟨⟨n, h2⟩, h1, rfl⟩ + have h1 : (∏ j ∈ Finset.Ioi i, ((j : ℕ) - (i : ℕ))) = + ∏ n ∈ Finset.Ico ((i : ℕ) + 1) L, (n - (i : ℕ)) := by + rw [← himg] + rw [Finset.prod_image (fun a _ b _ hab => Fin.val_injective hab)] + rw [h1, Finset.prod_Ico_eq_prod_range] + rw [show L - ((i : ℕ) + 1) = (L - 1) - (i : ℕ) from by omega] + rw [Finset.prod_congr rfl (fun t (_ : t ∈ Finset.range + ((L - 1) - (i : ℕ))) => show (i : ℕ) + 1 + t - (i : ℕ) = + t + 1 from by omega)] + exact Finset.prod_range_add_one_eq_factorial _ + +/-- Adding `r` to the argument multiplies the factorial by at most +`(d+r)^r`. -/ +theorem factorial_add_le (d r : ℕ) : + (d + r).factorial ≤ (d + r) ^ r * d.factorial := by + induction r with + | zero => simp + | succ r ih => + rw [show d + (r + 1) = (d + r) + 1 from by omega, + Nat.factorial_succ] + calc (d + r + 1) * (d + r).factorial ≤ + (d + r + 1) * ((d + r) ^ r * d.factorial) := + Nat.mul_le_mul_left _ ih + _ ≤ (d + r + 1) * ((d + r + 1) ^ r * d.factorial) := by + refine Nat.mul_le_mul_left _ (Nat.mul_le_mul_right _ + (Nat.pow_le_pow_left (by omega) r)) + _ = (d + (r + 1)) ^ (r + 1) * d.factorial := by + rw [show d + (r + 1) = d + r + 1 from by omega, pow_succ] + ring + +/-- The shifted factorial bound: `(s+d)! ≤ (2s)^s · d!` for +`d < s`. -/ +theorem shifted_factorial_le (s d : ℕ) (hd : d < s) : + (s + d).factorial ≤ (2 * s) ^ s * d.factorial := by + have h1 := factorial_add_le d s + rw [show s + d = d + s from by omega] + calc (d + s).factorial ≤ (d + s) ^ s * d.factorial := h1 + _ ≤ (2 * s) ^ s * d.factorial := + Nat.mul_le_mul_right _ (Nat.pow_le_pow_left (by omega) s) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/StabCount.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/StabCount.lean new file mode 100644 index 0000000000..5ee8ab95a6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/StabCount.lean @@ -0,0 +1,116 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FibreCard + +/-! +# Stabiliser count for colourings + +For `f : Fin n → Fin N`, the number of permutations `π` with `f ∘ π = f` +equals `∏ j, (fibreCard f j)!`. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv Fintype + +variable {n N : ℕ} + +/-! ### Simp helper for the sigma-fibre equivalence -/ + +private lemma sigmaFiberEquiv_symm_val {α : Type*} {β : Type*} (f : α → β) (x : + α) : + (sigmaFiberEquiv f).symm x = ⟨f x, x, rfl⟩ := rfl + +/-! ### Forward and backward maps -/ + +/-- Forward: a fixing permutation restricts to each fibre. -/ +def toFibrePerms (f : Fin n → Fin N) (π : Perm (Fin n)) + (hπ : f ∘ π = f) (j : Fin N) : Perm {i : Fin n // f i = j} := + π.subtypePerm fun i => by + have key : f (π i) = f i := congr_fun hπ i + exact ⟨fun h => key.symm.trans h, fun h => key.trans h⟩ + +/-- Backward: fibre permutations assemble into a global fixing permutation. -/ +def ofFibrePerms (f : Fin n → Fin N) + (σ : ∀ j : Fin N, Perm {i : Fin n // f i = j}) : Perm (Fin n) := + (sigmaFiberEquiv f).permCongr (Perm.sigmaCongrRight σ) + +/-- Permuting within each fibre fixes the colouring. -/ +theorem ofFibrePerms_fixes (f : Fin n → Fin N) + (σ : ∀ j, Perm {i : Fin n // f i = j}) : f ∘ ofFibrePerms f σ = f := by + funext x + simp only [Function.comp_apply, ofFibrePerms, permCongr_apply, + sigmaFiberEquiv_symm_val, Equiv.sigmaCongrRight_apply, + sigmaFiberEquiv_apply] + exact (σ (f x) ⟨x, rfl⟩).property + +/-! ### The fixing-perms–fibre-perms equivalence -/ + +/-- The bijection between fixing permutations and families of fibre +permutations. -/ +def fixingEquiv (f : Fin n → Fin N) : + {π : Perm (Fin n) // f ∘ π = f} ≃ + (∀ j : Fin N, Perm {i : Fin n // f i = j}) where + toFun πh := toFibrePerms f πh.1 πh.2 + invFun σ := ⟨ofFibrePerms f σ, ofFibrePerms_fixes f σ⟩ + left_inv := by + rintro ⟨π, hπ⟩ + simp only [Subtype.mk.injEq] + refine Equiv.ext fun i => ?_ + simp only [ofFibrePerms, permCongr_apply, sigmaFiberEquiv_symm_val, + Equiv.sigmaCongrRight_apply, toFibrePerms, Perm.subtypePerm_apply, + sigmaFiberEquiv_apply] + right_inv := by + intro σ; funext j + refine Equiv.ext fun ⟨i, hi⟩ => Subtype.ext ?_ + simp only [toFibrePerms, Perm.subtypePerm_apply, Subtype.coe_mk, + ofFibrePerms, permCongr_apply, sigmaFiberEquiv_symm_val, + Equiv.sigmaCongrRight_apply, sigmaFiberEquiv_apply] + subst hi; rfl + +/-- `ofFibrePerms` unfolds to the conjugated sigma-congruence. -/ +theorem ofFibrePerms_def (f : Fin n → Fin N) + (σ : ∀ j : Fin N, Perm {i : Fin n // f i = j}) : + ofFibrePerms f σ = + (sigmaFiberEquiv f).permCongr (Perm.sigmaCongrRight σ) := + rfl + +/-- The inverse of the fixing equivalence is `ofFibrePerms`. -/ +theorem fixingEquiv_symm_apply (f : Fin n → Fin N) + (σ : ∀ j : Fin N, Perm {i : Fin n // f i = j}) : + ((fixingEquiv f).symm σ : {π : Perm (Fin n) // f ∘ π = f}).1 = + ofFibrePerms f σ := + rfl + +/-! ### The cardinality step -/ + +/-- Fibre card equals the Fintype card of the fibre subtype. -/ +lemma fibreCard_eq_card (f : Fin n → Fin N) (j : Fin N) : + fibreCard f j = Fintype.card {i : Fin n // f i = j} := by + classical + rw [fibreCard] + exact (Fintype.card_of_subtype _ fun x => by simp [mem_filter]).symm + +/-- **The stabiliser count**: the permutations fixing a colouring +are exactly those, so there are the product of the fibre +factorials. -/ +theorem card_fixing_perms {n N : ℕ} (f : Fin n → Fin N) : + (Finset.univ.filter + (fun π : Equiv.Perm (Fin n) => f ∘ π = f)).card = + ∏ j : Fin N, (fibreCard f j).factorial := by + classical + rw [show (univ.filter _).card = Fintype.card {π : Perm (Fin n) // f ∘ π = f} + from (Fintype.card_of_subtype _ fun x => by simp [mem_filter]).symm, + Fintype.card_congr (fixingEquiv f), Fintype.card_pi] + congr 1; ext j + rw [Fintype.card_perm, fibreCard_eq_card] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/TensorNonvanishing.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/TensorNonvanishing.lean new file mode 100644 index 0000000000..aed38a4f8a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/TensorNonvanishing.lean @@ -0,0 +1,134 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignedTensor + +/-! +# Nonvanishing of idempotent images from Schur values + +Generic functional evaluations of `charIdempotent`: any linear +functional whose values on permutations are the (plain or signed) +constant cycle products evaluates the idempotent to a multiple of +the Schur value at the (plain or negated) constant sequence. +Consequently a linear map out of the group algebra admitting such +a functional cannot kill the idempotent when the Schur value is +nonzero — the even and odd sectors of the dimension-bound +dichotomy. +-/ + +@[expose] public section + +namespace RS + +open Finset + +open scoped Classical in +/-- Evaluating a linear functional on `charIdempotent` through its +values on permutations. -/ +theorem functional_charIdempotent (μ : YoungDiagram) (d : ℕ) + (L : SymGroupAlgebra μ.card →ₗ[ℂ] ℂ) + (φ : Equiv.Perm (Fin μ.card) → ℂ) + (hL : ∀ π, L (MonoidAlgebra.of ℂ (Equiv.Perm (Fin μ.card)) π) = + φ π) : + L (charIdempotent d (jtChar μ)) = + ((d : ℂ) / (μ.card.factorial : ℂ)) * + ∑ π : Equiv.Perm (Fin μ.card), jtChar μ π * φ π := by + rw [charIdempotent, map_smul, map_sum] + rw [Finset.sum_congr rfl + (fun (π : Equiv.Perm (Fin μ.card)) (_ : π ∈ Finset.univ) => + map_smul L (jtChar μ π) _)] + rw [Finset.sum_congr rfl + (fun (π : Equiv.Perm (Fin μ.card)) (_ : π ∈ Finset.univ) => by + rw [hL π])] + rw [smul_eq_mul] + rw [show (∑ π : Equiv.Perm (Fin μ.card), jtChar μ π • φ π) = + ∑ π : Equiv.Perm (Fin μ.card), jtChar μ π * φ π from + Finset.sum_congr rfl fun π _ => smul_eq_mul _ _] + +open scoped Classical in +/-- **The even evaluation**: a functional whose permutation values +are the constant cycle products evaluates the idempotent to +`d · s_μ(m, m, …)`. -/ +theorem functional_charIdempotent_frobenius (m : ℕ) + (μ : YoungDiagram) (d : ℕ) + (L : SymGroupAlgebra μ.card →ₗ[ℂ] ℂ) + (hL : ∀ π, L (MonoidAlgebra.of ℂ (Equiv.Perm (Fin μ.card)) π) = + cycleProd (fun _ => (m : ℂ)) π) : + L (charIdempotent d (jtChar μ)) = + (d : ℂ) * diagramSchur μ (fun _ => (m : ℂ)) := by + rw [functional_charIdempotent μ d L _ hL] + rw [show ((d : ℂ) / (μ.card.factorial : ℂ)) * + (∑ π : Equiv.Perm (Fin μ.card), + jtChar μ π * cycleProd (fun _ => (m : ℂ)) π) = + (d : ℂ) * (((μ.card.factorial : ℂ))⁻¹ * + ∑ π : Equiv.Perm (Fin μ.card), + jtChar μ π * cycleProd (fun _ => (m : ℂ)) π) from by + ring] + rw [jtChar_frobenius' μ (fun _ => (m : ℂ))] + +open scoped Classical in +/-- **The odd evaluation**: a functional whose permutation values +are the sign-twisted constant cycle products evaluates the +idempotent to `(−1)^n · d · s_μ(−m, −m, …)`. -/ +theorem functional_charIdempotent_signed (m : ℕ) + (μ : YoungDiagram) (d : ℕ) + (L : SymGroupAlgebra μ.card →ₗ[ℂ] ℂ) + (hL : ∀ π, L (MonoidAlgebra.of ℂ (Equiv.Perm (Fin μ.card)) π) = + ((Equiv.Perm.sign π : ℤ) : ℂ) * + cycleProd (fun _ => (m : ℂ)) π) : + L (charIdempotent d (jtChar μ)) = + ((-1 : ℂ)) ^ μ.card * + ((d : ℂ) * diagramSchur μ (fun _ => -(m : ℂ))) := by + rw [functional_charIdempotent μ d L _ hL] + rw [signed_tensor_sum m μ] + have hfac : ((μ.card.factorial : ℂ)) ≠ 0 := by + exact_mod_cast Nat.factorial_ne_zero μ.card + field_simp + +/-- **Even nonvanishing**: a linear map out of the group algebra +admitting a trace functional with constant-cycle-product character +cannot kill `charIdempotent` when the Schur value at the constant +sequence is nonzero. -/ +theorem charIdempotent_image_ne_zero {M : Type*} [AddCommGroup M] + [Module ℂ M] (m : ℕ) (μ : YoungDiagram) (d : ℕ) (hd : 0 < d) + (ρ : SymGroupAlgebra μ.card →ₗ[ℂ] M) (tr : M →ₗ[ℂ] ℂ) + (htr : ∀ π, tr (ρ (MonoidAlgebra.of ℂ (Equiv.Perm (Fin μ.card)) π)) = + cycleProd (fun _ => (m : ℂ)) π) + (hSchur : diagramSchur μ (fun _ => (m : ℂ)) ≠ 0) : + ρ (charIdempotent d (jtChar μ)) ≠ 0 := by + intro h0 + have h := functional_charIdempotent_frobenius m μ d (tr.comp ρ) + (fun π => by rw [LinearMap.comp_apply]; exact htr π) + rw [LinearMap.comp_apply, h0, map_zero] at h + exact hSchur ((mul_eq_zero.mp h.symm).resolve_left + (Nat.cast_ne_zero.mpr hd.ne')) + +/-- **Odd nonvanishing**: a linear map admitting a trace functional +with sign-twisted constant-cycle-product character cannot kill +`charIdempotent` when the Schur value at the negated constant +sequence is nonzero. -/ +theorem charIdempotent_image_ne_zero_signed {M : Type*} + [AddCommGroup M] [Module ℂ M] (m : ℕ) (μ : YoungDiagram) + (d : ℕ) (hd : 0 < d) + (ρ : SymGroupAlgebra μ.card →ₗ[ℂ] M) (tr : M →ₗ[ℂ] ℂ) + (htr : ∀ π, tr (ρ (MonoidAlgebra.of ℂ (Equiv.Perm (Fin μ.card)) π)) = + ((Equiv.Perm.sign π : ℤ) : ℂ) * + cycleProd (fun _ => (m : ℂ)) π) + (hSchur : diagramSchur μ (fun _ => -(m : ℂ)) ≠ 0) : + ρ (charIdempotent d (jtChar μ)) ≠ 0 := by + intro h0 + have h := functional_charIdempotent_signed m μ d (tr.comp ρ) + (fun π => by rw [LinearMap.comp_apply]; exact htr π) + rw [LinearMap.comp_apply, h0, map_zero] at h + have h1 : ((-1 : ℂ)) ^ μ.card ≠ 0 := + pow_ne_zero _ (by norm_num) + have h2 := (mul_eq_zero.mp h.symm).resolve_left h1 + exact hSchur ((mul_eq_zero.mp h2).resolve_left + (Nat.cast_ne_zero.mpr hd.ne')) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/TensorTrace.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/TensorTrace.lean new file mode 100644 index 0000000000..a9e78cd99e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/TensorTrace.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PermModule + +/-! +# The tensor-space permutation representation and its character + +The symmetric group `Equiv.Perm (Fin n)` acts on the full function +space `Fin n → Fin m` by precomposition with the inverse. This is +the tensor space `(ℂ^m)^{⊗n}` in its basis-indexed form. The +character of the induced representation equals the completed +cycle-type product at the constant sequence `fun _ => (m : ℂ)`. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv MonoidAlgebra + + + +/-! ## The permutation action on the full function space -/ + +/-- The symmetric group acts on `Fin n → Fin m` by precomposition +with the inverse permutation. -/ +instance tensorAction (n m : ℕ) : + MulAction (Equiv.Perm (Fin n)) (Fin n → Fin m) where + smul π g := g ∘ ⇑π⁻¹ + one_smul g := by + change g ∘ ⇑(1 : Equiv.Perm (Fin n))⁻¹ = g + simp + mul_smul π ρ g := by + change g ∘ ⇑(π * ρ)⁻¹ = (g ∘ ⇑ρ⁻¹) ∘ ⇑π⁻¹ + rw [mul_inv_rev] + rfl + +/-! ## cycleProd at the constant sequence -/ + +/-- `cycleProd (fun _ => (m : ℂ)) π` equals `(m : ℂ) ^ #orbits`. -/ +private theorem cycleProd_const (n m : ℕ) (π : Equiv.Perm (Fin n)) : + cycleProd (fun _ => (m : ℂ)) π = + (m : ℂ) ^ Fintype.card (OrbitSpace π) := by + rw [cycleProd] + rw [Multiset.map_const', Multiset.prod_replicate] + rw [← pow_add, card_orbitSpace] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/WordCommutant.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/WordCommutant.lean new file mode 100644 index 0000000000..e9b2b3cbeb --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/WordCommutant.lean @@ -0,0 +1,163 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CommutantBound + +/-! +# Polynomial commutant bounds for monomial word actions + +Matrix entries of an intertwiner are determined, up to nonzero +scalars, by the simultaneous permutation orbits of pairs of words. +Such an orbit is determined by its letter-pair counts. Each count +lies between zero and the word length, giving the polynomial bound +`(n + 1) ^ (Fintype.card α ^ 2)`. +-/ + +@[expose] public section + +namespace RS + +open Finset Representation + + +noncomputable section + +variable {α : Type*} {n : ℕ} + +/-- Coordinates of a symmetric-group representation acting on words +by permutation of positions and multiplication by nonzero scalars. -/ +structure MonomialWordAction + (ρ : Representation ℂ (Equiv.Perm (Fin n)) + ((Fin n → α) → ℂ)) where + /-- The scalar attached to a permutation and an output word. -/ + weight : Equiv.Perm (Fin n) → (Fin n → α) → ℂ + /-- Every coordinate scalar is nonzero. -/ + weight_ne_zero : ∀ σ c, weight σ c ≠ 0 + /-- The action reindexes coordinates by the permutation. -/ + apply_eq : ∀ σ v c, ρ σ v c = weight σ c * v (c ∘ σ) + +open scoped Classical in +private def wordPairCounts (p : (Fin n → α) × (Fin n → α)) : + (α × α) → Fin (n + 1) := fun a => + ⟨(univ.filter fun i => (p.1 i, p.2 i) = a).card, + Nat.lt_succ_of_le (by simpa using + (Finset.card_le_univ + (univ.filter fun i => (p.1 i, p.2 i) = a)))⟩ + +open scoped Classical in +private theorem wordPairCounts_eq_imp_perm + (p q : (Fin n → α) × (Fin n → α)) + (h : wordPairCounts p = wordPairCounts q) : + ∃ σ : Equiv.Perm (Fin n), + q.1 = p.1 ∘ σ ∧ q.2 = p.2 ∘ σ := by + classical + have hc (a : α × α) : + Fintype.card {i : Fin n // (q.1 i, q.2 i) = a} = + Fintype.card {i : Fin n // (p.1 i, p.2 i) = a} := by + have ha := congrArg Fin.val (congrFun h a) + simpa [wordPairCounts, Fintype.card_subtype] using ha.symm + let e (a : α × α) := Fintype.equivOfCardEq (hc a) + refine ⟨Equiv.ofFiberEquiv e, ?_, ?_⟩ + · funext i + exact (congrArg Prod.fst (Equiv.ofFiberEquiv_map e i)).symm + · funext i + exact (congrArg Prod.snd (Equiv.ofFiberEquiv_map e i)).symm + +open scoped Classical in +private theorem monomial_intertwining_entry + {ρ : Representation ℂ (Equiv.Perm (Fin n)) + ((Fin n → α) → ℂ)} (M : MonomialWordAction ρ) + (T : IntertwiningMap ρ ρ) (σ : Equiv.Perm (Fin n)) + (a b : Fin n → α) : + M.weight σ b * T (Pi.single b 1) a = + M.weight σ a * T (Pi.single (b ∘ σ) 1) (a ∘ σ) := by + classical + have hdelta : ρ σ (Pi.single (b ∘ σ) 1) = + M.weight σ b • Pi.single b 1 := by + funext c + rw [M.apply_eq] + by_cases hbc : b = c + · subst c + simp + · have hcomp : b ∘ σ ≠ c ∘ σ := by + intro h + apply hbc + funext i + have hi := congrFun h (σ.symm i) + simpa using hi + simp [hbc, hcomp] + have h := LinearMap.congr_fun (T.isIntertwining' σ) + (Pi.single (b ∘ σ) 1) + have ha := congrFun h a + simpa [LinearMap.comp_apply, hdelta, M.apply_eq, map_smul, + smul_eq_mul] using ha + +open scoped Classical in +private def commutantEntries + (ρ : Representation ℂ (Equiv.Perm (Fin n)) + ((Fin n → α) → ℂ)) : + IntertwiningMap ρ ρ →ₗ[ℂ] (((α × α) → Fin (n + 1)) → ℂ) where + toFun T c := if h : ∃ p, wordPairCounts p = c then + T (Pi.single (Classical.choose h).2 1) (Classical.choose h).1 + else 0 + map_add' T U := by + funext c + by_cases h : ∃ p, wordPairCounts p = c + · simp only [dite_eq_left h, Pi.add_apply] + rfl + · simp only [dite_eq_right h, Pi.add_apply, add_zero] + map_smul' z T := by + funext c + by_cases h : ∃ p, wordPairCounts p = c + · simp only [dite_eq_left h, Pi.smul_apply, RingHom.id_apply] + rfl + · simp only [dite_eq_right h, Pi.smul_apply, smul_zero] + +private theorem commutantEntries_injective [Finite α] + {ρ : Representation ℂ (Equiv.Perm (Fin n)) + ((Fin n → α) → ℂ)} (M : MonomialWordAction ρ) : + Function.Injective (commutantEntries ρ) := by + classical + let := Fintype.ofFinite α + rw [← LinearMap.ker_eq_bot, LinearMap.ker_eq_bot'] + intro T hT + have hentry (a b : Fin n → α) : T (Pi.single b 1) a = 0 := by + let c := wordPairCounts (a, b) + have hc : ∃ p, wordPairCounts p = c := ⟨(a, b), rfl⟩ + let p := Classical.choose hc + have hp : wordPairCounts p = wordPairCounts (a, b) := + Classical.choose_spec hc + have hz := congrFun hT c + simp only [commutantEntries, LinearMap.coe_mk, AddHom.coe_mk, + dite_eq_left hc, Pi.zero_apply] at hz + obtain ⟨σ, hrow, hcol⟩ := + wordPairCounts_eq_imp_perm (a, b) p hp.symm + have h := monomial_intertwining_entry M T σ a b + rw [← hrow, ← hcol, hz, mul_zero] at h + exact (mul_eq_zero.mp h).resolve_left (M.weight_ne_zero σ b) + apply IntertwiningMap.toLinearMap_injective + apply (Pi.basisFun ℂ (Fin n → α)).ext + intro b + funext a + simpa using hentry a b + +open scoped Classical in +/-- The commutant of a monomial word action has polynomial dimension, +with one possible coordinate for each table of letter-pair counts. -/ +theorem finrank_commutant_le_word_counts [Fintype α] + {ρ : Representation ℂ (Equiv.Perm (Fin n)) + ((Fin n → α) → ℂ)} (M : MonomialWordAction ρ) : + Module.finrank ℂ (IntertwiningMap ρ ρ) ≤ + (n + 1) ^ (Fintype.card α ^ 2) := by + have h := LinearMap.finrank_le_finrank_of_injective + (commutantEntries_injective M) + simpa [Module.finrank_pi, Fintype.card_fun, sq] using h + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourAction.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourAction.lean new file mode 100644 index 0000000000..c132c9f12f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourAction.lean @@ -0,0 +1,65 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjTop +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjStep + +/-! +# The colour action of the model braidings + +Assembling the three conjugation laws: the adjacent model +braiding acts on the colouring model as the Koszul-signed +adjacent swap, positionwise and wordwise. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +variable {k ℓ : ℕ} + +/-- **The colour action**: conjugating the adjacent braiding into +the colouring model is the Koszul-signed adjacent swap. -/ +theorem toColour_powBraid : + ∀ (n i : ℕ) (h : i + 2 ≤ n), + toColour (k := k) (ℓ := ℓ) n + (powBraid (stdSuperPair k ℓ) n i h) = + colourSwap k ℓ n i h + | 0, _, h => absurd h (by omega) + | 1, _, h => absurd h (by omega) + | n + 2, i, h => by + by_cases hi : i = n + · rw [show powBraid (stdSuperPair k ℓ) (n + 2) i h = + topBraid (stdSuperPair k ℓ) n from dite_eq_left hi] + rw [toColour_topBraid] + subst hi + rfl + · have hle : i + 2 ≤ n + 1 := by omega + rw [show powBraid (stdSuperPair k ℓ) (n + 2) i h = + (powBraid (stdSuperPair k ℓ) (n + 1) i hle) ▷ + stdSuperPair k ℓ from dite_eq_right hi] + rw [toColour_whisker] + rw [toColour_powBraid (n + 1) i hle] + rw [colourExtend_colourSwap] + +/-- **The wordwise colour action.** -/ +theorem toColour_powBraidWord {n : ℕ} (w : List (Fin n)) : + toColour (k := k) (ℓ := ℓ) (n + 1) + (powBraidWord (stdSuperPair k ℓ) w) = + colourSwapWord k ℓ w := by + induction w with + | nil => exact toColour_id (n + 1) + | cons i w ih => + change toColour (n + 1) (powBraidWord (stdSuperPair k ℓ) w ≫ + powBraid (stdSuperPair k ℓ) (n + 1) i.val (by omega)) = _ + rw [toColour_comp, ih, toColour_powBraid] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConj.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConj.lean new file mode 100644 index 0000000000..debd26e91f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConj.lean @@ -0,0 +1,105 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.PowBraid +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourEval + +/-! +# Conjugation into the colouring model + +Endomorphisms of the monoidal power conjugate through +`colourPowerEquiv` into the colouring model; extending along one +step is conjugation of the whisker through `colourPowerStep`. +These are the carriers of the braiding-coordinate computation. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +variable {k ℓ : ℕ} + +/-- Conjugating a power endomorphism into the colouring model. -/ +noncomputable def toColour (n : ℕ) + (g : superPow (stdSuperPair k ℓ) n ⟶ superPow (stdSuperPair k ℓ) n) : + colourPower k ℓ n ⟶ colourPower k ℓ n where + evenMap := (colourPowerEquiv k ℓ n).evenEquiv.toLinearMap ∘ₗ + ((g : SuperVect.Hom _ _).evenMap ∘ₗ + (colourPowerEquiv k ℓ n).evenEquiv.symm.toLinearMap) + oddMap := (colourPowerEquiv k ℓ n).oddEquiv.toLinearMap ∘ₗ + ((g : SuperVect.Hom _ _).oddMap ∘ₗ + (colourPowerEquiv k ℓ n).oddEquiv.symm.toLinearMap) + +/-- Extending a colour-model endomorphism by one position: +conjugation of the whisker through the step equivalence. -/ +noncomputable def colourExtend (n : ℕ) + (T : colourPower k ℓ n ⟶ colourPower k ℓ n) : + colourPower k ℓ (n + 1) ⟶ colourPower k ℓ (n + 1) where + evenMap := (colourPowerStep k ℓ n).evenEquiv.toLinearMap ∘ₗ + (((SuperVect.tensorHom T (SuperVect.Hom.id (stdSuperPair k ℓ)) : + SuperVect.tensorObj (colourPower k ℓ n) + (stdSuperPair k ℓ) ⟶ + SuperVect.tensorObj (colourPower k ℓ n) + (stdSuperPair k ℓ)) : SuperVect.Hom _ _).evenMap ∘ₗ + (colourPowerStep k ℓ n).evenEquiv.symm.toLinearMap) + oddMap := (colourPowerStep k ℓ n).oddEquiv.toLinearMap ∘ₗ + (((SuperVect.tensorHom T (SuperVect.Hom.id (stdSuperPair k ℓ)) : + SuperVect.tensorObj (colourPower k ℓ n) + (stdSuperPair k ℓ) ⟶ + SuperVect.tensorObj (colourPower k ℓ n) + (stdSuperPair k ℓ)) : SuperVect.Hom _ _).oddMap ∘ₗ + (colourPowerStep k ℓ n).oddEquiv.symm.toLinearMap) + +/-- Conjugation preserves composition. -/ +theorem toColour_comp (n : ℕ) + (g₁ g₂ : superPow (stdSuperPair k ℓ) n ⟶ + superPow (stdSuperPair k ℓ) n) : + toColour n (g₁ ≫ g₂) = + toColour n g₁ ≫ toColour n g₂ := by + refine SuperVect.Hom.ext ?_ ?_ + · refine LinearMap.ext (fun x => ?_) + change (colourPowerEquiv k ℓ n).evenEquiv + ((g₂ : SuperVect.Hom _ _).evenMap + ((g₁ : SuperVect.Hom _ _).evenMap + ((colourPowerEquiv k ℓ n).evenEquiv.symm x))) = _ + change _ = (colourPowerEquiv k ℓ n).evenEquiv + ((g₂ : SuperVect.Hom _ _).evenMap + ((colourPowerEquiv k ℓ n).evenEquiv.symm + ((colourPowerEquiv k ℓ n).evenEquiv + ((g₁ : SuperVect.Hom _ _).evenMap + ((colourPowerEquiv k ℓ n).evenEquiv.symm x))))) + rw [(colourPowerEquiv k ℓ n).evenEquiv.symm_apply_apply] + · refine LinearMap.ext (fun x => ?_) + change (colourPowerEquiv k ℓ n).oddEquiv + ((g₂ : SuperVect.Hom _ _).oddMap + ((g₁ : SuperVect.Hom _ _).oddMap + ((colourPowerEquiv k ℓ n).oddEquiv.symm x))) = _ + change _ = (colourPowerEquiv k ℓ n).oddEquiv + ((g₂ : SuperVect.Hom _ _).oddMap + ((colourPowerEquiv k ℓ n).oddEquiv.symm + ((colourPowerEquiv k ℓ n).oddEquiv + ((g₁ : SuperVect.Hom _ _).oddMap + ((colourPowerEquiv k ℓ n).oddEquiv.symm x))))) + rw [(colourPowerEquiv k ℓ n).oddEquiv.symm_apply_apply] + +/-- Conjugation preserves the identity. -/ +theorem toColour_id (n : ℕ) : + toColour (k := k) (ℓ := ℓ) n (𝟙 _) = 𝟙 _ := by + refine SuperVect.Hom.ext ?_ ?_ + · refine LinearMap.ext (fun x => ?_) + change (colourPowerEquiv k ℓ n).evenEquiv + ((colourPowerEquiv k ℓ n).evenEquiv.symm x) = x + rw [(colourPowerEquiv k ℓ n).evenEquiv.apply_symm_apply] + · refine LinearMap.ext (fun x => ?_) + change (colourPowerEquiv k ℓ n).oddEquiv + ((colourPowerEquiv k ℓ n).oddEquiv.symm x) = x + rw [(colourPowerEquiv k ℓ n).oddEquiv.apply_symm_apply] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjStep.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjStep.lean new file mode 100644 index 0000000000..d614b0d4e1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjStep.lean @@ -0,0 +1,107 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConj + +/-! +# Step compatibility of the colouring conjugation + +The conjugation of a whiskered endomorphism into the colouring +model equals the colour-extension of the conjugate: unwinding +`colourPowerEquiv (n + 1)` as `tensorCongr.trans step` and +observing that the `tensorCongr`-conjugation of a whisker is +`tensorHom` of the inner conjugation. +-/ + +@[expose] public section + +open scoped TensorProduct + +namespace RS + +open CategoryTheory MonoidalCategory + +/-- Conjugating `TensorProduct.map f id` by +`TensorProduct.congr E refl` yields +`TensorProduct.map (E . f . E.symm) id`. -/ +private lemma congr_refl_map_id {M₁ M₂ N : Type*} + [AddCommGroup M₁] [Module ℂ M₁] [AddCommGroup M₂] [Module ℂ M₂] + [AddCommGroup N] [Module ℂ N] + (E : M₁ ≃ₗ[ℂ] M₂) (f : M₁ →ₗ[ℂ] M₁) (t : M₂ ⊗[ℂ] N) : + (TensorProduct.congr E (LinearEquiv.refl ℂ N)) + (TensorProduct.map f LinearMap.id + ((TensorProduct.congr E (LinearEquiv.refl ℂ N)).symm t)) = + TensorProduct.map (E.toLinearMap ∘ₗ f ∘ₗ E.symm.toLinearMap) + LinearMap.id t := by + induction t using TensorProduct.inductionOn with + | tmul a b => + simp only [TensorProduct.congr_symm_tmul, TensorProduct.map_tmul, + LinearEquiv.coe_toLinearMap, LinearMap.comp_apply, + LinearMap.id_apply, LinearEquiv.refl_apply, LinearEquiv.refl_symm, + TensorProduct.congr_tmul] + | add x y hx hy => simp only [map_add, hx, hy] + +-- The colouring equivalence at arity `n+1` +-- is expanded through the tensor step on both components, so the +-- elaborated term carries the whole step equivalence twice. +/-- **The step compatibility**: conjugating a whiskered +endomorphism into the colouring model extends the conjugate. -/ +theorem toColour_whisker {k ℓ : ℕ} (n : ℕ) + (g : superPow (stdSuperPair k ℓ) n ⟶ superPow (stdSuperPair k ℓ) n) : + toColour (n + 1) (g ▷ stdSuperPair k ℓ) = + colourExtend n (toColour n g) := by + refine SuperVect.Hom.ext ?_ ?_ + · -- Even component + refine LinearMap.ext (fun x => ?_) + -- Expand colourPowerEquiv (n+1) = (tensorCongr CPE refl).trans step + change ((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ n) + (SuperLinearEquiv.refl (stdSuperPair k ℓ))).evenEquiv.trans + (colourPowerStep k ℓ n).evenEquiv) + ((g ▷ stdSuperPair k ℓ : SuperVect.Hom _ _).evenMap + (((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ n) + (SuperLinearEquiv.refl (stdSuperPair k ℓ))).evenEquiv.trans + (colourPowerStep k ℓ n).evenEquiv).symm x)) = + (colourPowerStep k ℓ n).evenEquiv + ((SuperVect.tensorHom (toColour n g) + (SuperVect.Hom.id (stdSuperPair k ℓ)) : + SuperVect.Hom _ _).evenMap + ((colourPowerStep k ℓ n).evenEquiv.symm x)) + rw [LinearEquiv.trans_apply, LinearEquiv.symm_trans_apply] + congr 1 + -- tc.ee(whisker.ee(tc.ee.symm y)) = tensorHom(toColour g, id).ee y + set y := (colourPowerStep k ℓ n).evenEquiv.symm x + -- Expand prodCongr/prodMap structure and destructure the Prod + obtain ⟨y₁, y₂⟩ := y + dsimp only [SuperLinearEquiv.tensorCongr, SuperLinearEquiv.refl, + SuperVect.Hom.id] + simp only [SuperVect.tensorHom, toColour] + exact Prod.ext (congr_refl_map_id _ _ y₁) (congr_refl_map_id _ _ y₂) + · -- Odd component (symmetric) + refine LinearMap.ext (fun x => ?_) + change ((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ n) + (SuperLinearEquiv.refl (stdSuperPair k ℓ))).oddEquiv.trans + (colourPowerStep k ℓ n).oddEquiv) + ((g ▷ stdSuperPair k ℓ : SuperVect.Hom _ _).oddMap + (((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ n) + (SuperLinearEquiv.refl (stdSuperPair k ℓ))).oddEquiv.trans + (colourPowerStep k ℓ n).oddEquiv).symm x)) = + (colourPowerStep k ℓ n).oddEquiv + ((SuperVect.tensorHom (toColour n g) + (SuperVect.Hom.id (stdSuperPair k ℓ)) : + SuperVect.Hom _ _).oddMap + ((colourPowerStep k ℓ n).oddEquiv.symm x)) + rw [LinearEquiv.trans_apply, LinearEquiv.symm_trans_apply] + congr 1 + set y := (colourPowerStep k ℓ n).oddEquiv.symm x + obtain ⟨y₁, y₂⟩ := y + dsimp only [SuperLinearEquiv.tensorCongr, SuperLinearEquiv.refl, + SuperVect.Hom.id] + simp only [SuperVect.tensorHom, toColour] + exact Prod.ext (congr_refl_map_id _ _ y₁) (congr_refl_map_id _ _ y₂) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjTop.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjTop.lean new file mode 100644 index 0000000000..58d0ff43c4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjTop.lean @@ -0,0 +1,2277 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TwoBasis +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TopBraidMerge + +/-! +# The colour action of the top braiding, base case + +The two-strand braid conjugated into the colouring model is the +Koszul-signed adjacent swap: coordinate evaluation of the braid +on the block structure, one encoding context throughout. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open scoped TensorProduct + +variable {k ℓ : ℕ} + +/-- Subsingleton-module tensors vanish. -/ +private theorem subsingleton_tmul_eq_zero {P M : Type*} + [AddCommGroup P] [Module ℂ P] [Subsingleton P] + [AddCommGroup M] [Module ℂ M] + (t : P ⊗[ℂ] M) : t = 0 := by + induction t using TensorProduct.inductionOn with + | tmul p m => + rw [Subsingleton.elim p 0, TensorProduct.zero_tmul] + | add s t hs ht => rw [hs, ht, add_zero] + +/-! ### Arity-one evaluations on general pads -/ + +private theorem eval1_even_inl (r : ℂ) + (x : (stdSuperPair k ℓ).even) + (c₁ : MixedColouring k ℓ 1) (h₁ : c₁.IsEven) + (i : Fin k) (hi : c₁ (Fin.last 0) = Sum.inl i) : + (colourPowerEquiv k ℓ 1).evenEquiv + (evenPair r x) ⟨c₁, h₁⟩ = r * x i := by + change (colourPowerStep k ℓ 0).evenEquiv + ((TensorProduct.congr + (colourPowerEquiv k ℓ 0).evenEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).even)) + ((r ⊗ₜ[ℂ] x : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).even)), + (TensorProduct.congr + (colourPowerEquiv k ℓ 0).oddEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).odd)) 0) + ⟨c₁, h₁⟩ = r * x i + have hcongr : (TensorProduct.congr + (colourPowerEquiv k ℓ 0).evenEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).even)) + ((r ⊗ₜ[ℂ] x : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).even)) = + ((colourPowerEquiv k ℓ 0).evenEquiv r) ⊗ₜ[ℂ] x := + Eq.trans (TensorProduct.congr_tmul _ _ _ _) (by rfl) + rw [hcongr, map_zero] + change Sum.elim + (fun p => funTensorFun _ _ + (((colourPowerEquiv k ℓ 0).evenEquiv r) ⊗ₜ[ℂ] + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).even x)) p) + (fun q => funTensorFun _ _ + (0 : ({c : MixedColouring k ℓ 0 // ¬ c.IsEven} → ℂ) + ⊗[ℂ] (Fin (2 * ℓ) → ℂ)) q) + (evenSplitEquiv k ℓ 0 ⟨c₁, h₁⟩) = r * x i + rw [evenSplitD_inl c₁ h₁ i hi, Sum.elim_inl] + refine Eq.trans (funTensorFun_tmul _ _ _) ?_ + rw [show ((colourPowerEquiv k ℓ 0).evenEquiv r) + (⟨MixedColouring.tail c₁, + (c₁.isEven_succ_left i hi).mp h₁⟩, + i).1 = r from rfl] + rfl + +private theorem eval1_even_zero (r : ℂ) + (x : (stdSuperPair k ℓ).even) + (c₁ : MixedColouring k ℓ 1) (h₁ : c₁.IsEven) + (b : Fin (2 * ℓ)) (hb : c₁ (Fin.last 0) = Sum.inr b) : + (colourPowerEquiv k ℓ 1).evenEquiv + (evenPair r x) ⟨c₁, h₁⟩ = 0 := by + change (colourPowerStep k ℓ 0).evenEquiv + ((TensorProduct.congr + (colourPowerEquiv k ℓ 0).evenEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).even)) + ((r ⊗ₜ[ℂ] x : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).even)), + (TensorProduct.congr + (colourPowerEquiv k ℓ 0).oddEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).odd)) 0) + ⟨c₁, h₁⟩ = 0 + have hcongr : (TensorProduct.congr + (colourPowerEquiv k ℓ 0).evenEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).even)) + ((r ⊗ₜ[ℂ] x : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).even)) = + ((colourPowerEquiv k ℓ 0).evenEquiv r) ⊗ₜ[ℂ] x := + Eq.trans (TensorProduct.congr_tmul _ _ _ _) (by rfl) + rw [hcongr, map_zero] + change Sum.elim + (fun p => funTensorFun _ _ + (((colourPowerEquiv k ℓ 0).evenEquiv r) ⊗ₜ[ℂ] + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).even x)) p) + (fun q => funTensorFun _ _ + (0 : ({c : MixedColouring k ℓ 0 // ¬ c.IsEven} → ℂ) + ⊗[ℂ] (Fin (2 * ℓ) → ℂ)) q) + (evenSplitEquiv k ℓ 0 ⟨c₁, h₁⟩) = 0 + rw [evenSplitD_inr c₁ h₁ b hb, Sum.elim_inr] + rw [show funTensorFun _ _ + (0 : ({c : MixedColouring k ℓ 0 // ¬ c.IsEven} → ℂ) + ⊗[ℂ] (Fin (2 * ℓ) → ℂ)) _ = 0 from by + rw [map_zero]; rfl] + +private theorem eval1_odd_inr (r : ℂ) + (w : (stdSuperPair k ℓ).odd) + (c₁ : MixedColouring k ℓ 1) (h₁ : ¬ c₁.IsEven) + (a : Fin (2 * ℓ)) (ha : c₁ (Fin.last 0) = Sum.inr a) : + (colourPowerEquiv k ℓ 1).oddEquiv + (((r ⊗ₜ[ℂ] w, 0) : + (superPow (stdSuperPair k ℓ) 1).odd)) ⟨c₁, h₁⟩ = + r * w a := by + change (colourPowerStep k ℓ 0).oddEquiv + ((TensorProduct.congr + (colourPowerEquiv k ℓ 0).evenEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).odd)) + ((r ⊗ₜ[ℂ] w : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).odd)), + (TensorProduct.congr + (colourPowerEquiv k ℓ 0).oddEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).even)) 0) + ⟨c₁, h₁⟩ = r * w a + have hcongr : (TensorProduct.congr + (colourPowerEquiv k ℓ 0).evenEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).odd)) + ((r ⊗ₜ[ℂ] w : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).odd)) = + ((colourPowerEquiv k ℓ 0).evenEquiv r) ⊗ₜ[ℂ] w := + Eq.trans (TensorProduct.congr_tmul _ _ _ _) (by rfl) + rw [hcongr, map_zero] + change Sum.elim + (fun p => funTensorFun _ _ + (((colourPowerEquiv k ℓ 0).evenEquiv r) ⊗ₜ[ℂ] + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).odd w)) p) + (fun q => funTensorFun _ _ + (0 : ({c : MixedColouring k ℓ 0 // ¬ c.IsEven} → ℂ) + ⊗[ℂ] (Fin k → ℂ)) q) + ((Equiv.sumComm _ _).symm (oddSplitEquiv k ℓ 0 ⟨c₁, h₁⟩)) + = r * w a + rw [oddSplitD_inr c₁ h₁ a ha] + rw [show ((Equiv.sumComm + ({c : MixedColouring k ℓ 0 // c.IsEven} × + Fin (2 * ℓ)) + ({c : MixedColouring k ℓ 0 // ¬ c.IsEven} × + Fin k)).symm + (Sum.inr (⟨MixedColouring.tail c₁, by + by_contra hcontra + exact h₁ ((c₁.isEven_succ_right a ha).mpr + hcontra)⟩, a))) = + Sum.inl (⟨MixedColouring.tail c₁, by + by_contra hcontra + exact h₁ ((c₁.isEven_succ_right a ha).mpr + hcontra)⟩, a) from rfl] + rw [Sum.elim_inl] + refine Eq.trans (funTensorFun_tmul _ _ _) ?_ + rw [show ((colourPowerEquiv k ℓ 0).evenEquiv r) + (⟨MixedColouring.tail c₁, by + by_contra hcontra + exact h₁ ((c₁.isEven_succ_right a ha).mpr + hcontra)⟩, a).1 = r from rfl] + rfl + +private theorem eval1_odd_zero (r : ℂ) + (w : (stdSuperPair k ℓ).odd) + (c₁ : MixedColouring k ℓ 1) (h₁ : ¬ c₁.IsEven) + (i : Fin k) (hi : c₁ (Fin.last 0) = Sum.inl i) : + (colourPowerEquiv k ℓ 1).oddEquiv + (((r ⊗ₜ[ℂ] w, 0) : + (superPow (stdSuperPair k ℓ) 1).odd)) ⟨c₁, h₁⟩ = 0 := by + change (colourPowerStep k ℓ 0).oddEquiv + ((TensorProduct.congr + (colourPowerEquiv k ℓ 0).evenEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).odd)) + ((r ⊗ₜ[ℂ] w : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).odd)), + (TensorProduct.congr + (colourPowerEquiv k ℓ 0).oddEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).even)) 0) + ⟨c₁, h₁⟩ = 0 + have hcongr : (TensorProduct.congr + (colourPowerEquiv k ℓ 0).evenEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).odd)) + ((r ⊗ₜ[ℂ] w : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).odd)) = + ((colourPowerEquiv k ℓ 0).evenEquiv r) ⊗ₜ[ℂ] w := + Eq.trans (TensorProduct.congr_tmul _ _ _ _) (by rfl) + rw [hcongr, map_zero] + change Sum.elim + (fun p => funTensorFun _ _ + (((colourPowerEquiv k ℓ 0).evenEquiv r) ⊗ₜ[ℂ] + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).odd w)) p) + (fun q => funTensorFun _ _ + (0 : ({c : MixedColouring k ℓ 0 // ¬ c.IsEven} → ℂ) + ⊗[ℂ] (Fin k → ℂ)) q) + ((Equiv.sumComm _ _).symm (oddSplitEquiv k ℓ 0 ⟨c₁, h₁⟩)) + = 0 + rw [oddSplitD_inl c₁ h₁ i hi] + rw [show ((Equiv.sumComm + ({c : MixedColouring k ℓ 0 // c.IsEven} × + Fin (2 * ℓ)) + ({c : MixedColouring k ℓ 0 // ¬ c.IsEven} × + Fin k)).symm + (Sum.inl (⟨MixedColouring.tail c₁, by + intro hcontra + exact h₁ ((c₁.isEven_succ_left i hi).mpr + hcontra)⟩, i))) = + Sum.inr (⟨MixedColouring.tail c₁, by + intro hcontra + exact h₁ ((c₁.isEven_succ_left i hi).mpr + hcontra)⟩, i) from rfl] + rw [Sum.elim_inr] + rw [show funTensorFun _ _ + (0 : ({c : MixedColouring k ℓ 0 // ¬ c.IsEven} → ℂ) + ⊗[ℂ] (Fin k → ℂ)) _ = 0 from by + rw [map_zero]; rfl] + +/-! ### Arity-two evaluations on general pads, even component -/ + +private theorem eval2_ee (r : ℂ) (x y : (stdSuperPair k ℓ).even) + (c : MixedColouring k ℓ 2) (hc : c.IsEven) : + (colourPowerEquiv k ℓ 2).evenEquiv + (evenPair (evenPair r x) y) ⟨c, hc⟩ = + Sum.elim + (fun p => funTensorFun _ _ + (((colourPowerEquiv k ℓ 1).evenEquiv + (evenPair r x)) ⊗ₜ[ℂ] + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).even y)) p) + (fun q => funTensorFun _ _ + (0 : ({c : MixedColouring k ℓ 1 // ¬ c.IsEven} → ℂ) + ⊗[ℂ] (Fin (2 * ℓ) → ℂ)) q) + (evenSplitEquiv k ℓ 1 ⟨c, hc⟩) := by + change (colourPowerStep k ℓ 1).evenEquiv + ((TensorProduct.congr + (colourPowerEquiv k ℓ 1).evenEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).even)) + (((evenPair r x : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] y : + (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).even)), + (TensorProduct.congr + (colourPowerEquiv k ℓ 1).oddEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).odd)) 0) + ⟨c, hc⟩ = _ + have hcongr : (TensorProduct.congr + (colourPowerEquiv k ℓ 1).evenEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).even)) + (((evenPair r x : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] y : + (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).even)) = + ((colourPowerEquiv k ℓ 1).evenEquiv + (evenPair r x)) ⊗ₜ[ℂ] y := + Eq.trans (TensorProduct.congr_tmul _ _ _ _) (by rfl) + rw [hcongr, map_zero] + rfl + +private theorem eval2_ee_val (r : ℂ) + (x y : (stdSuperPair k ℓ).even) + (c : MixedColouring k ℓ 2) (hc : c.IsEven) + (i j : Fin k) + (h0 : c 0 = Sum.inl i) (h1 : c (Fin.last 1) = Sum.inl j) : + (colourPowerEquiv k ℓ 2).evenEquiv + (evenPair (evenPair r x) y) ⟨c, hc⟩ = + r * x i * y j := by + rw [eval2_ee r x y c hc] + rw [evenSplitD_inl c hc j h1, Sum.elim_inl] + refine Eq.trans (funTensorFun_tmul _ _ _) ?_ + rw [show ((colourPowerEquiv k ℓ 1).evenEquiv + (evenPair r x)) + (⟨MixedColouring.tail c, + (c.isEven_succ_left j h1).mp hc⟩, j).1 = + r * x i from eval1_even_inl r x _ _ i + (show MixedColouring.tail c (Fin.last 0) = + Sum.inl i from h0)] + rfl + +private theorem eval2_ee_zero_right (r : ℂ) + (x y : (stdSuperPair k ℓ).even) + (c : MixedColouring k ℓ 2) (hc : c.IsEven) + (b : Fin (2 * ℓ)) (h1 : c (Fin.last 1) = Sum.inr b) : + (colourPowerEquiv k ℓ 2).evenEquiv + (evenPair (evenPair r x) y) ⟨c, hc⟩ = 0 := by + rw [eval2_ee r x y c hc] + rw [evenSplitD_inr c hc b h1, Sum.elim_inr] + rw [show funTensorFun _ _ + (0 : ({c : MixedColouring k ℓ 1 // ¬ c.IsEven} → ℂ) + ⊗[ℂ] (Fin (2 * ℓ) → ℂ)) _ = 0 from by + rw [map_zero]; rfl] + +private theorem eval2_ee_zero_left (r : ℂ) + (x y : (stdSuperPair k ℓ).even) + (c : MixedColouring k ℓ 2) (hc : c.IsEven) + (j : Fin k) (a : Fin (2 * ℓ)) + (h0 : c 0 = Sum.inr a) (h1 : c (Fin.last 1) = Sum.inl j) : + (colourPowerEquiv k ℓ 2).evenEquiv + (evenPair (evenPair r x) y) ⟨c, hc⟩ = 0 := by + rw [eval2_ee r x y c hc] + rw [evenSplitD_inl c hc j h1, Sum.elim_inl] + refine Eq.trans (funTensorFun_tmul _ _ _) ?_ + rw [show ((colourPowerEquiv k ℓ 1).evenEquiv + (evenPair r x)) + (⟨MixedColouring.tail c, + (c.isEven_succ_left j h1).mp hc⟩, j).1 = + 0 from eval1_even_zero r x _ _ a + (show MixedColouring.tail c (Fin.last 0) = + Sum.inr a from h0)] + exact zero_mul _ + +private theorem eval2_oo (r : ℂ) + (w z : (stdSuperPair k ℓ).odd) + (c : MixedColouring k ℓ 2) (hc : c.IsEven) : + (colourPowerEquiv k ℓ 2).evenEquiv + ((((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).even), + ((r ⊗ₜ[ℂ] w, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z)) : + (superPow (stdSuperPair k ℓ) 2).even) ⟨c, hc⟩ = + Sum.elim + (fun p => funTensorFun _ _ + (0 : ({c : MixedColouring k ℓ 1 // c.IsEven} → ℂ) + ⊗[ℂ] (Fin k → ℂ)) p) + (fun q => funTensorFun _ _ + (((colourPowerEquiv k ℓ 1).oddEquiv + (((r ⊗ₜ[ℂ] w, 0) : + (superPow (stdSuperPair k ℓ) 1).odd))) ⊗ₜ[ℂ] + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).odd z)) q) + (evenSplitEquiv k ℓ 1 ⟨c, hc⟩) := by + change (colourPowerStep k ℓ 1).evenEquiv + ((TensorProduct.congr + (colourPowerEquiv k ℓ 1).evenEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).even)) + (0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).even), + (TensorProduct.congr + (colourPowerEquiv k ℓ 1).oddEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).odd)) + ((((r ⊗ₜ[ℂ] w, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z : + (superPow (stdSuperPair k ℓ) 1).odd ⊗[ℂ] + (stdSuperPair k ℓ).odd))) + ⟨c, hc⟩ = _ + have hcongr : (TensorProduct.congr + (colourPowerEquiv k ℓ 1).oddEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).odd)) + ((((r ⊗ₜ[ℂ] w, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z : + (superPow (stdSuperPair k ℓ) 1).odd ⊗[ℂ] + (stdSuperPair k ℓ).odd)) = + ((colourPowerEquiv k ℓ 1).oddEquiv + (((r ⊗ₜ[ℂ] w, 0) : + (superPow (stdSuperPair k ℓ) 1).odd))) ⊗ₜ[ℂ] z := + Eq.trans (TensorProduct.congr_tmul _ _ _ _) (by rfl) + rw [hcongr, map_zero] + rfl + +private theorem eval2_oo_val (r : ℂ) + (w z : (stdSuperPair k ℓ).odd) + (c : MixedColouring k ℓ 2) (hc : c.IsEven) + (a b : Fin (2 * ℓ)) + (h0 : c 0 = Sum.inr a) (h1 : c (Fin.last 1) = Sum.inr b) : + (colourPowerEquiv k ℓ 2).evenEquiv + ((((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).even), + ((r ⊗ₜ[ℂ] w, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z)) : + (superPow (stdSuperPair k ℓ) 2).even) ⟨c, hc⟩ = + r * w a * z b := by + rw [eval2_oo r w z c hc] + rw [evenSplitD_inr c hc b h1, Sum.elim_inr] + refine Eq.trans (funTensorFun_tmul _ _ _) ?_ + rw [show ((colourPowerEquiv k ℓ 1).oddEquiv + (((r ⊗ₜ[ℂ] w, 0) : + (superPow (stdSuperPair k ℓ) 1).odd))) + (⟨MixedColouring.tail c, by + by_contra hcontra + exact ((c.isEven_succ_right b h1).mp hc) hcontra⟩, + b).1 = + r * w a from eval1_odd_inr r w _ _ a + (show MixedColouring.tail c (Fin.last 0) = + Sum.inr a from h0)] + rfl + +private theorem eval2_oo_zero_right (r : ℂ) + (w z : (stdSuperPair k ℓ).odd) + (c : MixedColouring k ℓ 2) (hc : c.IsEven) + (j : Fin k) (h1 : c (Fin.last 1) = Sum.inl j) : + (colourPowerEquiv k ℓ 2).evenEquiv + ((((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).even), + ((r ⊗ₜ[ℂ] w, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z)) : + (superPow (stdSuperPair k ℓ) 2).even) ⟨c, hc⟩ = 0 := by + rw [eval2_oo r w z c hc] + rw [evenSplitD_inl c hc j h1, Sum.elim_inl] + rw [show funTensorFun _ _ + (0 : ({c : MixedColouring k ℓ 1 // c.IsEven} → ℂ) + ⊗[ℂ] (Fin k → ℂ)) _ = 0 from by + rw [map_zero]; rfl] + +private theorem eval2_oo_zero_left (r : ℂ) + (w z : (stdSuperPair k ℓ).odd) + (c : MixedColouring k ℓ 2) (hc : c.IsEven) + (i : Fin k) (b : Fin (2 * ℓ)) + (h0 : c 0 = Sum.inl i) (h1 : c (Fin.last 1) = Sum.inr b) : + (colourPowerEquiv k ℓ 2).evenEquiv + ((((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).even), + ((r ⊗ₜ[ℂ] w, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z)) : + (superPow (stdSuperPair k ℓ) 2).even) ⟨c, hc⟩ = 0 := by + rw [eval2_oo r w z c hc] + rw [evenSplitD_inr c hc b h1, Sum.elim_inr] + refine Eq.trans (funTensorFun_tmul _ _ _) ?_ + rw [show ((colourPowerEquiv k ℓ 1).oddEquiv + (((r ⊗ₜ[ℂ] w, 0) : + (superPow (stdSuperPair k ℓ) 1).odd))) + (⟨MixedColouring.tail c, by + by_contra hcontra + exact ((c.isEven_succ_right b h1).mp hc) hcontra⟩, + b).1 = + 0 from eval1_odd_zero r w _ _ i + (show MixedColouring.tail c (Fin.last 0) = + Sum.inl i from h0)] + exact zero_mul _ + +/-! ### The braid values, in-file encodings -/ + +private theorem whisker_unit_even' {V W : SuperVect} + (g : SuperVect.Hom V W) (r : ℂ) (z : V.even) : + (SuperVect.tensorHom + (SuperVect.Hom.id SuperVect.tensorUnit) g).evenMap + ((r ⊗ₜ[ℂ] z, (0 : SuperVect.tensorUnit.odd ⊗[ℂ] + V.odd))) = + ((r ⊗ₜ[ℂ] g.evenMap z, + (0 : SuperVect.tensorUnit.odd ⊗[ℂ] W.odd))) := by + change (TensorProduct.map + (SuperVect.Hom.id SuperVect.tensorUnit).evenMap + g.evenMap (r ⊗ₜ[ℂ] z), + TensorProduct.map + (SuperVect.Hom.id SuperVect.tensorUnit).oddMap + g.oddMap 0) = _ + rw [TensorProduct.map_tmul, map_zero] + rfl + +private theorem neg_pack' {V : SuperVect} (r : ℂ) + (t : V.odd ⊗[ℂ] V.odd) : + ((r ⊗ₜ[ℂ] (((0 : V.even ⊗[ℂ] V.even), -t) : + (SuperVect.tensorObj V V).even)), + (0 : SuperVect.tensorUnit.odd ⊗[ℂ] + (SuperVect.tensorObj V V).odd)) = + -((r ⊗ₜ[ℂ] (((0 : V.even ⊗[ℂ] V.even), t) : + (SuperVect.tensorObj V V).even)), + (0 : SuperVect.tensorUnit.odd ⊗[ℂ] + (SuperVect.tensorObj V V).odd)) := by + rw [show (((0 : V.even ⊗[ℂ] V.even), -t) : + (SuperVect.tensorObj V V).even) = + -(((0 : V.even ⊗[ℂ] V.even), t) : + (SuperVect.tensorObj V V).even) from by + rw [Prod.neg_mk, neg_zero]] + rw [TensorProduct.tmul_neg] + rw [Prod.neg_mk, neg_zero] + +private theorem braid_ee (r : ℂ) (x y : (stdSuperPair k ℓ).even) : + ((topBraid (stdSuperPair k ℓ) 0) : + SuperVect.Hom _ _).evenMap + (evenPair (evenPair r x) y) = + evenPair (evenPair r y) x := by + have hfun : ((topBraid (stdSuperPair k ℓ) 0) : + SuperVect.Hom _ _).evenMap + (evenPair (evenPair r x) y) = + (((α_ (superPow (stdSuperPair k ℓ) 0) (stdSuperPair k ℓ) + (stdSuperPair k ℓ)).inv : _ ⟶ _) : + SuperVect.Hom _ _).evenMap + ((((superPow (stdSuperPair k ℓ) 0) ◁ + (β_ (stdSuperPair k ℓ) (stdSuperPair k ℓ)).hom : _ ⟶ _) : + SuperVect.Hom _ _).evenMap + ((((α_ (superPow (stdSuperPair k ℓ) 0) (stdSuperPair k ℓ) + (stdSuperPair k ℓ)).hom : _ ⟶ _) : + SuperVect.Hom _ _).evenMap + (evenPair (evenPair r x) y))) := rfl + rw [hfun] + refine Eq.trans (congrArg (((α_ (superPow (stdSuperPair k ℓ) 0) + (stdSuperPair k ℓ) (stdSuperPair k ℓ)).inv : _ ⟶ _) : + SuperVect.Hom _ _).evenMap + (Eq.trans (congrArg ((((superPow (stdSuperPair k ℓ) 0) ◁ + (β_ (stdSuperPair k ℓ) (stdSuperPair k ℓ)).hom : _ ⟶ _) : + SuperVect.Hom _ _).evenMap) + (SuperVect.assoc_unit_ee r x y)) + (Eq.trans (whisker_unit_even' + (SuperVect.koszulBraiding (stdSuperPair k ℓ) + (stdSuperPair k ℓ)) r _) + (congrArg (fun z => (r ⊗ₜ[ℂ] z, 0)) (SuperVect.koszul_ee x y))))) ?_ + exact SuperVect.assoc_unit_inv_ee r y x + +private theorem braid_oo (r : ℂ) (w z : (stdSuperPair k ℓ).odd) : + ((topBraid (stdSuperPair k ℓ) 0) : + SuperVect.Hom _ _).evenMap + ((((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).even), + ((r ⊗ₜ[ℂ] w, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z)) : + (superPow (stdSuperPair k ℓ) 2).even) = + -((((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).even), + ((r ⊗ₜ[ℂ] z, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] w)) : + (superPow (stdSuperPair k ℓ) 2).even) := by + have hfun : ((topBraid (stdSuperPair k ℓ) 0) : + SuperVect.Hom _ _).evenMap + ((((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).even), + ((r ⊗ₜ[ℂ] w, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z)) : + (superPow (stdSuperPair k ℓ) 2).even) = + (((α_ (superPow (stdSuperPair k ℓ) 0) (stdSuperPair k ℓ) + (stdSuperPair k ℓ)).inv : _ ⟶ _) : + SuperVect.Hom _ _).evenMap + ((((superPow (stdSuperPair k ℓ) 0) ◁ + (β_ (stdSuperPair k ℓ) (stdSuperPair k ℓ)).hom : _ ⟶ _) : + SuperVect.Hom _ _).evenMap + ((((α_ (superPow (stdSuperPair k ℓ) 0) (stdSuperPair k ℓ) + (stdSuperPair k ℓ)).hom : _ ⟶ _) : + SuperVect.Hom _ _).evenMap + ((((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).even), + ((r ⊗ₜ[ℂ] w, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z)) : + (superPow (stdSuperPair k ℓ) 2).even))) := rfl + rw [hfun] + refine Eq.trans (congrArg (((α_ (superPow (stdSuperPair k ℓ) 0) + (stdSuperPair k ℓ) (stdSuperPair k ℓ)).inv : _ ⟶ _) : + SuperVect.Hom _ _).evenMap + (Eq.trans (congrArg ((((superPow (stdSuperPair k ℓ) 0) ◁ + (β_ (stdSuperPair k ℓ) (stdSuperPair k ℓ)).hom : _ ⟶ _) : + SuperVect.Hom _ _).evenMap) + (SuperVect.assoc_unit_oo r w z)) + (Eq.trans + (Eq.trans (whisker_unit_even' + (SuperVect.koszulBraiding (stdSuperPair k ℓ) + (stdSuperPair k ℓ)) r _) + (by rw [SuperVect.koszul_oo]; rfl)) + (neg_pack' r (z ⊗ₜ[ℂ] w))))) ?_ + refine Eq.trans (map_neg _ _) ?_ + exact congrArg Neg.neg + (SuperVect.assoc_unit_inv_oo r z w) + +/-- Pointwise sum on colour functions. -/ +private theorem colourFun_add_apply {n : ℕ} + (F G : (colourPower k ℓ n).even) + (p : {c : MixedColouring k ℓ n // c.IsEven}) : + (F + G) p = F p + G p := rfl + +/-- Pointwise negation on colour functions. -/ +private theorem colourFun_neg_apply {n : ℕ} + (F : (colourPower k ℓ n).even) + (p : {c : MixedColouring k ℓ n // c.IsEven}) : + (-F) p = -(F p) := rfl + +/-! ### The even-component coordinate identity -/ + +-- One coordinate of the Koszul braiding at two +-- strands, elaborated through the colouring equivalence and both +-- tensor decompositions; the term is large, the search is not. +private theorem superPow_two_even_induction + (P : (superPow (stdSuperPair k ℓ) 2).even → Prop) + (hP0 : P 0) + (hPadd : ∀ u₁ u₂, P u₁ → P u₂ → P (u₁ + u₂)) + (hee : ∀ (r : ℂ) (x y : (stdSuperPair k ℓ).even), + P ((((r ⊗ₜ[ℂ] x, 0) : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] y, + (0 : (superPow (stdSuperPair k ℓ) 1).odd ⊗[ℂ] + (stdSuperPair k ℓ).odd)))) + (hoo : ∀ (r : ℂ) (w z : (stdSuperPair k ℓ).odd), + P (((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).even), + ((r ⊗ₜ[ℂ] w, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z))) + (v : (superPow (stdSuperPair k ℓ) 2).even) : P v := by + have : Subsingleton SuperVect.tensorUnit.odd := + inferInstanceAs (Subsingleton PUnit) + have : Subsingleton (superPow (stdSuperPair k ℓ) 0).odd := + inferInstanceAs (Subsingleton PUnit) + obtain ⟨v₁, v₂⟩ := v + rw [show ((v₁, v₂) : (superPow (stdSuperPair k ℓ) 2).even) = + (v₁, 0) + (0, v₂) from by + rw [Prod.mk_add_mk, add_zero, zero_add]] + refine hPadd _ _ ?_ ?_ + · -- The even-even block. + induction v₁ using TensorProduct.inductionOn with + | add s t hs ht => + rw [show ((s + t, 0) : + (superPow (stdSuperPair k ℓ) 2).even) = + (s, 0) + (t, 0) from by + rw [Prod.mk_add_mk, add_zero]] + exact hPadd _ _ hs ht + | tmul a y => + obtain ⟨a₁, a₂⟩ := a + have helem : ((((a₁, a₂) : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] y, + 0) : (superPow (stdSuperPair k ℓ) 2).even) = + (((((a₁, 0) : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] y, 0)) : + (superPow (stdSuperPair k ℓ) 2).even) + + (((((0, a₂) : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] y, 0)) : + (superPow (stdSuperPair k ℓ) 2).even) + := by + refine Eq.trans (congrArg (fun t => + ((t, (0 : (superPow (stdSuperPair k ℓ) 1).odd ⊗[ℂ] + (stdSuperPair k ℓ).odd)) : + (superPow (stdSuperPair k ℓ) 2).even)) + (Eq.trans (congrArg (fun s => + s ⊗ₜ[ℂ] y) + (show ((a₁, a₂) : + (superPow (stdSuperPair k ℓ) 1).even) = + ((a₁, 0) : (superPow (stdSuperPair k ℓ) 1).even) + + ((0, a₂) : (superPow (stdSuperPair k ℓ) 1).even) + from by rw [Prod.mk_add_mk, add_zero, + zero_add])) + (TensorProduct.add_tmul + (((a₁, 0) : + (superPow (stdSuperPair k ℓ) 1).even)) + (((0, a₂) : + (superPow (stdSuperPair k ℓ) 1).even)) y))) ?_ + exact Prod.ext_iff.mpr ⟨rfl, (add_zero 0).symm⟩ + refine Eq.mpr (congrArg P helem) (hPadd _ _ ?_ ?_) + · clear helem + induction a₁ using TensorProduct.inductionOn with + | add s t hs ht => + have helem : (((((s + t : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).even), 0) : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] y, + 0) : (superPow (stdSuperPair k ℓ) 2).even) = + ((((s, 0) : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] y, + 0) : (superPow (stdSuperPair k ℓ) 2).even) + + (((((t, 0) : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] y, + 0)) : (superPow (stdSuperPair k ℓ) 2).even) := by + refine Eq.trans (congrArg (fun u => + ((u, (0 : (superPow (stdSuperPair k ℓ) 1).odd + ⊗[ℂ] (stdSuperPair k ℓ).odd)) : + (superPow (stdSuperPair k ℓ) 2).even)) + (Eq.trans (congrArg (fun w => w ⊗ₜ[ℂ] y) + (show (((s + t : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).even), 0) : + (superPow (stdSuperPair k ℓ) 1).even) = + ((s, 0) : + (superPow (stdSuperPair k ℓ) 1).even) + + ((t, 0) : + (superPow (stdSuperPair k ℓ) 1).even) + from by rw [Prod.mk_add_mk, add_zero])) + (TensorProduct.add_tmul + (((s, 0) : + (superPow (stdSuperPair k ℓ) 1).even)) + (((t, 0) : + (superPow (stdSuperPair k ℓ) 1).even)) + y))) ?_ + exact Prod.ext_iff.mpr ⟨rfl, (add_zero 0).symm⟩ + exact Eq.mpr (congrArg P helem) (hPadd _ _ hs ht) + | tmul r x => exact hee r x y + · have h0elem : (((((0 : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).even), a₂) : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] y, + 0) : (superPow (stdSuperPair k ℓ) 2).even) = + 0 := by + rw [subsingleton_tmul_eq_zero a₂] + change (((0 : (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] y, 0) : + (superPow (stdSuperPair k ℓ) 2).even) = 0 + rw [TensorProduct.zero_tmul] + rfl + exact Eq.mpr (congrArg P h0elem) hP0 + · -- The odd-odd block. + induction v₂ using TensorProduct.inductionOn with + | add s t hs ht => + rw [show ((0, s + t) : + (superPow (stdSuperPair k ℓ) 2).even) = + (0, s) + (0, t) from by + rw [Prod.mk_add_mk, add_zero]] + exact hPadd _ _ hs ht + | tmul b z => + obtain ⟨b₁, b₂⟩ := b + have helem : ((0, (((b₁, b₂) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z)) : + (superPow (stdSuperPair k ℓ) 2).even) = + (((0, (((b₁, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z))) : + (superPow (stdSuperPair k ℓ) 2).even) + + (((0, (((0, b₂) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z))) : + (superPow (stdSuperPair k ℓ) 2).even) + := by + refine Eq.trans (congrArg (fun t => + (((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).even), t) : + (superPow (stdSuperPair k ℓ) 2).even)) + (Eq.trans (congrArg (fun s => + s ⊗ₜ[ℂ] z) + (show ((b₁, b₂) : + (superPow (stdSuperPair k ℓ) 1).odd) = + ((b₁, 0) : (superPow (stdSuperPair k ℓ) 1).odd) + + ((0, b₂) : (superPow (stdSuperPair k ℓ) 1).odd) + from by rw [Prod.mk_add_mk, add_zero, + zero_add])) + (TensorProduct.add_tmul + (((b₁, 0) : + (superPow (stdSuperPair k ℓ) 1).odd)) + (((0, b₂) : + (superPow (stdSuperPair k ℓ) 1).odd)) z))) ?_ + exact Prod.ext_iff.mpr ⟨(add_zero 0).symm, rfl⟩ + refine Eq.mpr (congrArg P helem) (hPadd _ _ ?_ ?_) + · clear helem + induction b₁ using TensorProduct.inductionOn with + | add s t hs ht => + have helem : ((0, ((((s + t : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z)) : + (superPow (stdSuperPair k ℓ) 2).even) = + (((0, (((s, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z))) : + (superPow (stdSuperPair k ℓ) 2).even) + + (((0, (((t, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z))) : + (superPow (stdSuperPair k ℓ) 2).even) + := by + refine Eq.trans (congrArg (fun u => + (((0 : (superPow (stdSuperPair k ℓ) 1).even + ⊗[ℂ] (stdSuperPair k ℓ).even), u) : + (superPow (stdSuperPair k ℓ) 2).even)) + (Eq.trans (congrArg (fun w => + w ⊗ₜ[ℂ] z) + (show (((s + t : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), 0) : + (superPow (stdSuperPair k ℓ) 1).odd) = + ((s, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) + + ((t, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) + from by rw [Prod.mk_add_mk, add_zero])) + (TensorProduct.add_tmul + (((s, 0) : + (superPow (stdSuperPair k ℓ) 1).odd)) + (((t, 0) : + (superPow (stdSuperPair k ℓ) 1).odd)) + z))) ?_ + exact Prod.ext_iff.mpr ⟨(add_zero 0).symm, rfl⟩ + exact Eq.mpr (congrArg P helem) (hPadd _ _ hs ht) + | tmul r w => exact hoo r w z + · have h0elem : ((0, ((((0 : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), b₂) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z)) : + (superPow (stdSuperPair k ℓ) 2).even) = 0 := by + rw [subsingleton_tmul_eq_zero b₂] + change ((0, (0 : (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z) : + (superPow (stdSuperPair k ℓ) 2).even) = 0 + rw [TensorProduct.zero_tmul] + rfl + exact Eq.mpr (congrArg P h0elem) hP0 + +private theorem braid_coord_even + (c' : MixedColouring k ℓ 2) (hc' : c'.IsEven) + (v : (superPow (stdSuperPair k ℓ) 2).even) : + (colourPowerEquiv k ℓ 2).evenEquiv + (((topBraid (stdSuperPair k ℓ) 0) : + SuperVect.Hom _ _).evenMap v) ⟨c', hc'⟩ = + adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ * + (colourPowerEquiv k ℓ 2).evenEquiv v + ⟨c' ∘ _root_.Equiv.swap (⟨0, by omega⟩ : Fin 2) + ⟨1, by omega⟩, hc'.comp _⟩ := by + have : Subsingleton SuperVect.tensorUnit.odd := + inferInstanceAs (Subsingleton PUnit) + have : Subsingleton (superPow (stdSuperPair k ℓ) 0).odd := + inferInstanceAs (Subsingleton PUnit) + -- ═══════ THE PREDICATE, PROVED ADDITIVELY ═══════ + set P : (superPow (stdSuperPair k ℓ) 2).even → Prop := + fun u => + (colourPowerEquiv k ℓ 2).evenEquiv + (((topBraid (stdSuperPair k ℓ) 0) : + SuperVect.Hom _ _).evenMap u) ⟨c', hc'⟩ = + adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ * + (colourPowerEquiv k ℓ 2).evenEquiv u + ⟨c' ∘ _root_.Equiv.swap (⟨0, by omega⟩ : Fin 2) + ⟨1, by omega⟩, hc'.comp _⟩ with hP + change P v + have hswap0 : (c' ∘ _root_.Equiv.swap + (⟨0, by omega⟩ : Fin 2) ⟨1, by omega⟩) 0 = + c' (Fin.last 1) := + congrArg c' (_root_.Equiv.swap_apply_left _ _) + have hswap1 : (c' ∘ _root_.Equiv.swap + (⟨0, by omega⟩ : Fin 2) ⟨1, by omega⟩) (Fin.last 1) = + c' 0 := + congrArg c' (_root_.Equiv.swap_apply_right _ _) + have hP0 : P 0 := by + rw [hP] + beta_reduce + rw [map_zero, map_zero] + change (0 : ℂ) = _ * (0 : {c : MixedColouring k ℓ 2 // + c.IsEven} → ℂ) ⟨c' ∘ _root_.Equiv.swap + (⟨0, by omega⟩ : Fin 2) ⟨1, by omega⟩, hc'.comp _⟩ + rw [show (0 : {c : MixedColouring k ℓ 2 // + c.IsEven} → ℂ) ⟨c' ∘ _root_.Equiv.swap + (⟨0, by omega⟩ : Fin 2) ⟨1, by omega⟩, + hc'.comp _⟩ = 0 from rfl] + rw [mul_zero] + have hPadd : ∀ u₁ u₂, P u₁ → P u₂ → P (u₁ + u₂) := by + intro u₁ u₂ h₁ h₂ + rw [hP] at h₁ h₂ ⊢ + beta_reduce at h₁ h₂ ⊢ + rw [map_add, map_add, colourFun_add_apply, map_add, + colourFun_add_apply, h₁, h₂, mul_add] + -- ═══════ THE EVEN⊗EVEN GENERATORS ═══════ + have hee : ∀ (r : ℂ) (x y : (stdSuperPair k ℓ).even), + P ((((r ⊗ₜ[ℂ] x, 0) : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] y, + (0 : (superPow (stdSuperPair k ℓ) 1).odd ⊗[ℂ] + (stdSuperPair k ℓ).odd))) := by + intro r x y + rw [hP] + beta_reduce + refine Eq.trans (congrArg + (fun t => (colourPowerEquiv k ℓ 2).evenEquiv t + ⟨c', hc'⟩) (braid_ee r x y)) ?_ + rcases hl0 : c' 0 with i | a <;> + rcases hl1 : c' (Fin.last 1) with j | b + · refine Eq.trans (eval2_ee_val r y x c' hc' i j + hl0 hl1) (Eq.trans ?_ (congrArg + (fun t => adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ * t) + (eval2_ee_val r x y _ (hc'.comp _) j i + (hswap0.trans hl1) (hswap1.trans hl0)).symm)) + rw [show adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ = + (1 : ℂ) from ite_eq_right (fun hA => by + rw [show c' ⟨0, by omega⟩ = Sum.inl i from hl0] at hA + exact Bool.noConfusion hA.1)] + ring + · refine Eq.trans (eval2_ee_zero_right r y x c' hc' b + hl1) (Eq.trans ?_ (congrArg + (fun t => adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ * t) + (eval2_ee_zero_left r x y _ (hc'.comp _) i b + (hswap0.trans hl1) (hswap1.trans hl0)).symm)) + exact (mul_zero _).symm + · refine Eq.trans (eval2_ee_zero_left r y x c' hc' j a + hl0 hl1) (Eq.trans ?_ (congrArg + (fun t => adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ * t) + (eval2_ee_zero_right r x y _ (hc'.comp _) a + (hswap1.trans hl0)).symm)) + exact (mul_zero _).symm + · refine Eq.trans (eval2_ee_zero_right r y x c' hc' b + hl1) (Eq.trans ?_ (congrArg + (fun t => adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ * t) + (eval2_ee_zero_right r x y _ (hc'.comp _) a + (hswap1.trans hl0)).symm)) + exact (mul_zero _).symm + -- ═══════ THE ODD⊗ODD GENERATORS ═══════ + have hoo : ∀ (r : ℂ) (w z : (stdSuperPair k ℓ).odd), + P (((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).even), + ((r ⊗ₜ[ℂ] w, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z)) := by + intro r w z + rw [hP] + beta_reduce + refine Eq.trans (congrArg + (fun t => (colourPowerEquiv k ℓ 2).evenEquiv t + ⟨c', hc'⟩) (braid_oo r w z)) ?_ + refine Eq.trans (congrArg (fun F => F ⟨c', hc'⟩) + (map_neg ((colourPowerEquiv k ℓ 2).evenEquiv) _)) ?_ + refine Eq.trans (colourFun_neg_apply _ _) ?_ + rcases hl0 : c' 0 with i | a <;> + rcases hl1 : c' (Fin.last 1) with j | b + · refine Eq.trans (congrArg Neg.neg + (eval2_oo_zero_right r z w c' hc' j hl1)) + (Eq.trans ?_ (congrArg + (fun t => adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ * t) + (eval2_oo_zero_right r w z _ (hc'.comp _) i + (hswap1.trans hl0)).symm)) + rw [mul_zero, neg_zero] + · refine Eq.trans (congrArg Neg.neg + (eval2_oo_zero_left r z w c' hc' i b hl0 hl1)) + (Eq.trans ?_ (congrArg + (fun t => adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ * t) + (eval2_oo_zero_right r w z _ (hc'.comp _) i + (hswap1.trans hl0)).symm)) + rw [mul_zero, neg_zero] + · refine Eq.trans (congrArg Neg.neg + (eval2_oo_zero_right r z w c' hc' j hl1)) + (Eq.trans ?_ (congrArg + (fun t => adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ * t) + (eval2_oo_zero_left r w z _ (hc'.comp _) j a + (hswap0.trans hl1) (hswap1.trans hl0)).symm)) + rw [mul_zero, neg_zero] + · refine Eq.trans (congrArg Neg.neg + (eval2_oo_val r z w c' hc' a b hl0 hl1)) + (Eq.trans ?_ (congrArg + (fun t => adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ * t) + (eval2_oo_val r w z _ (hc'.comp _) b a + (hswap0.trans hl1) (hswap1.trans hl0)).symm)) + rw [show adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ = + (-1 : ℂ) from ite_eq_left ⟨(by + rw [show c' ⟨0, by omega⟩ = Sum.inr a from hl0] + rfl), (by + rw [show c' ⟨1, by omega⟩ = Sum.inr b from hl1] + rfl)⟩] + ring + -- Assemble by block decomposition and tensor induction. + exact superPow_two_even_induction P hP0 hPadd hee hoo v + +/-! ### Arity-two evaluations, odd component -/ + +private theorem eval2_eo (r : ℂ) (x : (stdSuperPair k ℓ).even) + (w : (stdSuperPair k ℓ).odd) + (c : MixedColouring k ℓ 2) (hc : ¬ c.IsEven) : + (colourPowerEquiv k ℓ 2).oddEquiv + ((((evenPair r x : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w, + (0 : (superPow (stdSuperPair k ℓ) 1).odd ⊗[ℂ] + (stdSuperPair k ℓ).even))) : + (superPow (stdSuperPair k ℓ) 2).odd) ⟨c, hc⟩ = + Sum.elim + (fun p => funTensorFun _ _ + (((colourPowerEquiv k ℓ 1).evenEquiv + (evenPair r x)) ⊗ₜ[ℂ] + (LinearEquiv.refl ℂ (Fin (2 * ℓ) → ℂ) w)) p) + (fun q => funTensorFun _ _ + (0 : ({c : MixedColouring k ℓ 1 // ¬ c.IsEven} → ℂ) + ⊗[ℂ] (Fin k → ℂ)) q) + ((Equiv.sumComm _ _).symm + (oddSplitEquiv k ℓ 1 ⟨c, hc⟩)) := by + change (colourPowerStep k ℓ 1).oddEquiv + ((TensorProduct.congr + (colourPowerEquiv k ℓ 1).evenEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).odd)) + (((evenPair r x : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w : + (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).odd)), + (TensorProduct.congr + (colourPowerEquiv k ℓ 1).oddEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).even)) 0) + ⟨c, hc⟩ = _ + have hcongr : (TensorProduct.congr + (colourPowerEquiv k ℓ 1).evenEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).odd)) + (((evenPair r x : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w : + (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).odd)) = + ((colourPowerEquiv k ℓ 1).evenEquiv + (evenPair r x)) ⊗ₜ[ℂ] w := + Eq.trans (TensorProduct.congr_tmul _ _ _ _) (by rfl) + rw [hcongr, map_zero] + rfl + +private theorem eval2_eo_val (r : ℂ) + (x : (stdSuperPair k ℓ).even) (w : (stdSuperPair k ℓ).odd) + (c : MixedColouring k ℓ 2) (hc : ¬ c.IsEven) + (i : Fin k) (b : Fin (2 * ℓ)) + (h0 : c 0 = Sum.inl i) (h1 : c (Fin.last 1) = Sum.inr b) : + (colourPowerEquiv k ℓ 2).oddEquiv + ((((evenPair r x : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w, + (0 : (superPow (stdSuperPair k ℓ) 1).odd ⊗[ℂ] + (stdSuperPair k ℓ).even))) : + (superPow (stdSuperPair k ℓ) 2).odd) ⟨c, hc⟩ = + r * x i * w b := by + rw [eval2_eo r x w c hc] + rw [oddSplitD_inr c hc b h1] + rw [show ((Equiv.sumComm + ({c : MixedColouring k ℓ 1 // c.IsEven} × + Fin (2 * ℓ)) + ({c : MixedColouring k ℓ 1 // ¬ c.IsEven} × + Fin k)).symm + (Sum.inr (⟨MixedColouring.tail c, by + by_contra hcontra + exact hc ((c.isEven_succ_right b h1).mpr + hcontra)⟩, b))) = + Sum.inl (⟨MixedColouring.tail c, by + by_contra hcontra + exact hc ((c.isEven_succ_right b h1).mpr + hcontra)⟩, b) from rfl] + rw [Sum.elim_inl] + refine Eq.trans (funTensorFun_tmul _ _ _) ?_ + rw [show ((colourPowerEquiv k ℓ 1).evenEquiv + (evenPair r x)) + (⟨MixedColouring.tail c, by + by_contra hcontra + exact hc ((c.isEven_succ_right b h1).mpr + hcontra)⟩, b).1 = + r * x i from eval1_even_inl r x _ _ i + (show MixedColouring.tail c (Fin.last 0) = + Sum.inl i from h0)] + rfl + +private theorem eval2_eo_zero_right (r : ℂ) + (x : (stdSuperPair k ℓ).even) (w : (stdSuperPair k ℓ).odd) + (c : MixedColouring k ℓ 2) (hc : ¬ c.IsEven) + (j : Fin k) (h1 : c (Fin.last 1) = Sum.inl j) : + (colourPowerEquiv k ℓ 2).oddEquiv + ((((evenPair r x : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w, + (0 : (superPow (stdSuperPair k ℓ) 1).odd ⊗[ℂ] + (stdSuperPair k ℓ).even))) : + (superPow (stdSuperPair k ℓ) 2).odd) ⟨c, hc⟩ = 0 := by + rw [eval2_eo r x w c hc] + rw [oddSplitD_inl c hc j h1] + rw [show ((Equiv.sumComm + ({c : MixedColouring k ℓ 1 // c.IsEven} × + Fin (2 * ℓ)) + ({c : MixedColouring k ℓ 1 // ¬ c.IsEven} × + Fin k)).symm + (Sum.inl (⟨MixedColouring.tail c, by + intro hcontra + exact hc ((c.isEven_succ_left j h1).mpr + hcontra)⟩, j))) = + Sum.inr (⟨MixedColouring.tail c, by + intro hcontra + exact hc ((c.isEven_succ_left j h1).mpr + hcontra)⟩, j) from rfl] + rw [Sum.elim_inr] + rw [show funTensorFun _ _ + (0 : ({c : MixedColouring k ℓ 1 // ¬ c.IsEven} → ℂ) + ⊗[ℂ] (Fin k → ℂ)) _ = 0 from by + rw [map_zero]; rfl] + +private theorem eval2_eo_zero_left (r : ℂ) + (x : (stdSuperPair k ℓ).even) (w : (stdSuperPair k ℓ).odd) + (c : MixedColouring k ℓ 2) (hc : ¬ c.IsEven) + (a b : Fin (2 * ℓ)) + (h0 : c 0 = Sum.inr a) (h1 : c (Fin.last 1) = Sum.inr b) : + (colourPowerEquiv k ℓ 2).oddEquiv + ((((evenPair r x : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w, + (0 : (superPow (stdSuperPair k ℓ) 1).odd ⊗[ℂ] + (stdSuperPair k ℓ).even))) : + (superPow (stdSuperPair k ℓ) 2).odd) ⟨c, hc⟩ = 0 := by + rw [eval2_eo r x w c hc] + rw [oddSplitD_inr c hc b h1] + rw [show ((Equiv.sumComm + ({c : MixedColouring k ℓ 1 // c.IsEven} × + Fin (2 * ℓ)) + ({c : MixedColouring k ℓ 1 // ¬ c.IsEven} × + Fin k)).symm + (Sum.inr (⟨MixedColouring.tail c, by + by_contra hcontra + exact hc ((c.isEven_succ_right b h1).mpr + hcontra)⟩, b))) = + Sum.inl (⟨MixedColouring.tail c, by + by_contra hcontra + exact hc ((c.isEven_succ_right b h1).mpr + hcontra)⟩, b) from rfl] + rw [Sum.elim_inl] + refine Eq.trans (funTensorFun_tmul _ _ _) ?_ + rw [show ((colourPowerEquiv k ℓ 1).evenEquiv + (evenPair r x)) + (⟨MixedColouring.tail c, by + by_contra hcontra + exact hc ((c.isEven_succ_right b h1).mpr + hcontra)⟩, b).1 = + 0 from eval1_even_zero r x _ _ a + (show MixedColouring.tail c (Fin.last 0) = + Sum.inr a from h0)] + exact zero_mul _ + +private theorem eval2_oe (r : ℂ) (u : (stdSuperPair k ℓ).odd) + (y : (stdSuperPair k ℓ).even) + (c : MixedColouring k ℓ 2) (hc : ¬ c.IsEven) : + (colourPowerEquiv k ℓ 2).oddEquiv + ((((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), + ((r ⊗ₜ[ℂ] u, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y)) : + (superPow (stdSuperPair k ℓ) 2).odd) ⟨c, hc⟩ = + Sum.elim + (fun p => funTensorFun _ _ + (0 : ({c : MixedColouring k ℓ 1 // c.IsEven} → ℂ) + ⊗[ℂ] (Fin (2 * ℓ) → ℂ)) p) + (fun q => funTensorFun _ _ + (((colourPowerEquiv k ℓ 1).oddEquiv + (((r ⊗ₜ[ℂ] u, 0) : + (superPow (stdSuperPair k ℓ) 1).odd))) ⊗ₜ[ℂ] + (LinearEquiv.refl ℂ (Fin k → ℂ) y)) q) + ((Equiv.sumComm _ _).symm + (oddSplitEquiv k ℓ 1 ⟨c, hc⟩)) := by + change (colourPowerStep k ℓ 1).oddEquiv + ((TensorProduct.congr + (colourPowerEquiv k ℓ 1).evenEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).odd)) + (0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), + (TensorProduct.congr + (colourPowerEquiv k ℓ 1).oddEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).even)) + ((((r ⊗ₜ[ℂ] u, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y : + (superPow (stdSuperPair k ℓ) 1).odd ⊗[ℂ] + (stdSuperPair k ℓ).even))) + ⟨c, hc⟩ = _ + have hcongr : (TensorProduct.congr + (colourPowerEquiv k ℓ 1).oddEquiv + (LinearEquiv.refl ℂ (stdSuperPair k ℓ).even)) + ((((r ⊗ₜ[ℂ] u, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y : + (superPow (stdSuperPair k ℓ) 1).odd ⊗[ℂ] + (stdSuperPair k ℓ).even)) = + ((colourPowerEquiv k ℓ 1).oddEquiv + (((r ⊗ₜ[ℂ] u, 0) : + (superPow (stdSuperPair k ℓ) 1).odd))) ⊗ₜ[ℂ] y := + Eq.trans (TensorProduct.congr_tmul _ _ _ _) (by rfl) + rw [hcongr, map_zero] + rfl + +private theorem eval2_oe_val (r : ℂ) + (u : (stdSuperPair k ℓ).odd) (y : (stdSuperPair k ℓ).even) + (c : MixedColouring k ℓ 2) (hc : ¬ c.IsEven) + (a : Fin (2 * ℓ)) (j : Fin k) + (h0 : c 0 = Sum.inr a) (h1 : c (Fin.last 1) = Sum.inl j) : + (colourPowerEquiv k ℓ 2).oddEquiv + ((((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), + ((r ⊗ₜ[ℂ] u, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y)) : + (superPow (stdSuperPair k ℓ) 2).odd) ⟨c, hc⟩ = + r * u a * y j := by + rw [eval2_oe r u y c hc] + rw [oddSplitD_inl c hc j h1] + rw [show ((Equiv.sumComm + ({c : MixedColouring k ℓ 1 // c.IsEven} × + Fin (2 * ℓ)) + ({c : MixedColouring k ℓ 1 // ¬ c.IsEven} × + Fin k)).symm + (Sum.inl (⟨MixedColouring.tail c, by + intro hcontra + exact hc ((c.isEven_succ_left j h1).mpr + hcontra)⟩, j))) = + Sum.inr (⟨MixedColouring.tail c, by + intro hcontra + exact hc ((c.isEven_succ_left j h1).mpr + hcontra)⟩, j) from rfl] + rw [Sum.elim_inr] + refine Eq.trans (funTensorFun_tmul _ _ _) ?_ + rw [show ((colourPowerEquiv k ℓ 1).oddEquiv + (((r ⊗ₜ[ℂ] u, 0) : + (superPow (stdSuperPair k ℓ) 1).odd))) + (⟨MixedColouring.tail c, by + intro hcontra + exact hc ((c.isEven_succ_left j h1).mpr + hcontra)⟩, j).1 = + r * u a from eval1_odd_inr r u _ _ a + (show MixedColouring.tail c (Fin.last 0) = + Sum.inr a from h0)] + rfl + +private theorem eval2_oe_zero_right (r : ℂ) + (u : (stdSuperPair k ℓ).odd) (y : (stdSuperPair k ℓ).even) + (c : MixedColouring k ℓ 2) (hc : ¬ c.IsEven) + (b : Fin (2 * ℓ)) (h1 : c (Fin.last 1) = Sum.inr b) : + (colourPowerEquiv k ℓ 2).oddEquiv + ((((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), + ((r ⊗ₜ[ℂ] u, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y)) : + (superPow (stdSuperPair k ℓ) 2).odd) ⟨c, hc⟩ = 0 := by + rw [eval2_oe r u y c hc] + rw [oddSplitD_inr c hc b h1] + rw [show ((Equiv.sumComm + ({c : MixedColouring k ℓ 1 // c.IsEven} × + Fin (2 * ℓ)) + ({c : MixedColouring k ℓ 1 // ¬ c.IsEven} × + Fin k)).symm + (Sum.inr (⟨MixedColouring.tail c, by + by_contra hcontra + exact hc ((c.isEven_succ_right b h1).mpr + hcontra)⟩, b))) = + Sum.inl (⟨MixedColouring.tail c, by + by_contra hcontra + exact hc ((c.isEven_succ_right b h1).mpr + hcontra)⟩, b) from rfl] + rw [Sum.elim_inl] + rw [show funTensorFun _ _ + (0 : ({c : MixedColouring k ℓ 1 // c.IsEven} → ℂ) + ⊗[ℂ] (Fin (2 * ℓ) → ℂ)) _ = 0 from by + rw [map_zero]; rfl] + +private theorem eval2_oe_zero_left (r : ℂ) + (u : (stdSuperPair k ℓ).odd) (y : (stdSuperPair k ℓ).even) + (c : MixedColouring k ℓ 2) (hc : ¬ c.IsEven) + (i j : Fin k) + (h0 : c 0 = Sum.inl i) (h1 : c (Fin.last 1) = Sum.inl j) : + (colourPowerEquiv k ℓ 2).oddEquiv + ((((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), + ((r ⊗ₜ[ℂ] u, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y)) : + (superPow (stdSuperPair k ℓ) 2).odd) ⟨c, hc⟩ = 0 := by + rw [eval2_oe r u y c hc] + rw [oddSplitD_inl c hc j h1] + rw [show ((Equiv.sumComm + ({c : MixedColouring k ℓ 1 // c.IsEven} × + Fin (2 * ℓ)) + ({c : MixedColouring k ℓ 1 // ¬ c.IsEven} × + Fin k)).symm + (Sum.inl (⟨MixedColouring.tail c, by + intro hcontra + exact hc ((c.isEven_succ_left j h1).mpr + hcontra)⟩, j))) = + Sum.inr (⟨MixedColouring.tail c, by + intro hcontra + exact hc ((c.isEven_succ_left j h1).mpr + hcontra)⟩, j) from rfl] + rw [Sum.elim_inr] + refine Eq.trans (funTensorFun_tmul _ _ _) ?_ + rw [show ((colourPowerEquiv k ℓ 1).oddEquiv + (((r ⊗ₜ[ℂ] u, 0) : + (superPow (stdSuperPair k ℓ) 1).odd))) + (⟨MixedColouring.tail c, by + intro hcontra + exact hc ((c.isEven_succ_left j h1).mpr + hcontra)⟩, j).1 = + 0 from eval1_odd_zero r u _ _ i + (show MixedColouring.tail c (Fin.last 0) = + Sum.inl i from h0)] + exact zero_mul _ + +/-! ### The odd braid values and coordinate identity -/ + +private theorem whisker_unit_odd' {V W : SuperVect} + (g : SuperVect.Hom V W) (r : ℂ) (z : V.odd) : + (SuperVect.tensorHom + (SuperVect.Hom.id SuperVect.tensorUnit) g).oddMap + ((r ⊗ₜ[ℂ] z, (0 : SuperVect.tensorUnit.odd ⊗[ℂ] + V.even))) = + ((r ⊗ₜ[ℂ] g.oddMap z, + (0 : SuperVect.tensorUnit.odd ⊗[ℂ] W.even))) := by + change (TensorProduct.map + (SuperVect.Hom.id SuperVect.tensorUnit).evenMap + g.oddMap (r ⊗ₜ[ℂ] z), + TensorProduct.map + (SuperVect.Hom.id SuperVect.tensorUnit).oddMap + g.evenMap 0) = _ + rw [TensorProduct.map_tmul, map_zero] + rfl + +private theorem braid_eo (r : ℂ) (x : (stdSuperPair k ℓ).even) + (w : (stdSuperPair k ℓ).odd) : + ((topBraid (stdSuperPair k ℓ) 0) : + SuperVect.Hom _ _).oddMap + ((((evenPair r x : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w, + (0 : (superPow (stdSuperPair k ℓ) 1).odd ⊗[ℂ] + (stdSuperPair k ℓ).even))) : + (superPow (stdSuperPair k ℓ) 2).odd) = + ((((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), + ((r ⊗ₜ[ℂ] w, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] x)) : + (superPow (stdSuperPair k ℓ) 2).odd) := by + have hfun : ((topBraid (stdSuperPair k ℓ) 0) : + SuperVect.Hom _ _).oddMap + ((((evenPair r x : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w, + (0 : (superPow (stdSuperPair k ℓ) 1).odd ⊗[ℂ] + (stdSuperPair k ℓ).even))) : + (superPow (stdSuperPair k ℓ) 2).odd) = + (((α_ (superPow (stdSuperPair k ℓ) 0) (stdSuperPair k ℓ) + (stdSuperPair k ℓ)).inv : _ ⟶ _) : + SuperVect.Hom _ _).oddMap + ((((superPow (stdSuperPair k ℓ) 0) ◁ + (β_ (stdSuperPair k ℓ) (stdSuperPair k ℓ)).hom : _ ⟶ _) : + SuperVect.Hom _ _).oddMap + ((((α_ (superPow (stdSuperPair k ℓ) 0) (stdSuperPair k ℓ) + (stdSuperPair k ℓ)).hom : _ ⟶ _) : + SuperVect.Hom _ _).oddMap + ((((evenPair r x : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w, + (0 : (superPow (stdSuperPair k ℓ) 1).odd ⊗[ℂ] + (stdSuperPair k ℓ).even))) : + (superPow (stdSuperPair k ℓ) 2).odd))) := rfl + rw [hfun] + refine Eq.trans (congrArg (((α_ (superPow (stdSuperPair k ℓ) 0) + (stdSuperPair k ℓ) (stdSuperPair k ℓ)).inv : _ ⟶ _) : + SuperVect.Hom _ _).oddMap + (Eq.trans (congrArg ((((superPow (stdSuperPair k ℓ) 0) ◁ + (β_ (stdSuperPair k ℓ) (stdSuperPair k ℓ)).hom : _ ⟶ _) : + SuperVect.Hom _ _).oddMap) + (SuperVect.assoc_unit_eo r x w)) + (Eq.trans (whisker_unit_odd' + (SuperVect.koszulBraiding (stdSuperPair k ℓ) + (stdSuperPair k ℓ)) r _) + (congrArg (fun z => (r ⊗ₜ[ℂ] z, 0)) (SuperVect.koszul_eo x w))))) ?_ + exact SuperVect.assoc_unit_inv_oe r w x + +private theorem braid_oe (r : ℂ) (u : (stdSuperPair k ℓ).odd) + (y : (stdSuperPair k ℓ).even) : + ((topBraid (stdSuperPair k ℓ) 0) : + SuperVect.Hom _ _).oddMap + ((((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), + ((r ⊗ₜ[ℂ] u, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y)) : + (superPow (stdSuperPair k ℓ) 2).odd) = + ((((evenPair r y : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] u, + (0 : (superPow (stdSuperPair k ℓ) 1).odd ⊗[ℂ] + (stdSuperPair k ℓ).even))) : + (superPow (stdSuperPair k ℓ) 2).odd) := by + have hfun : ((topBraid (stdSuperPair k ℓ) 0) : + SuperVect.Hom _ _).oddMap + ((((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), + ((r ⊗ₜ[ℂ] u, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y)) : + (superPow (stdSuperPair k ℓ) 2).odd) = + (((α_ (superPow (stdSuperPair k ℓ) 0) (stdSuperPair k ℓ) + (stdSuperPair k ℓ)).inv : _ ⟶ _) : + SuperVect.Hom _ _).oddMap + ((((superPow (stdSuperPair k ℓ) 0) ◁ + (β_ (stdSuperPair k ℓ) (stdSuperPair k ℓ)).hom : _ ⟶ _) : + SuperVect.Hom _ _).oddMap + ((((α_ (superPow (stdSuperPair k ℓ) 0) (stdSuperPair k ℓ) + (stdSuperPair k ℓ)).hom : _ ⟶ _) : + SuperVect.Hom _ _).oddMap + ((((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), + ((r ⊗ₜ[ℂ] u, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y)) : + (superPow (stdSuperPair k ℓ) 2).odd))) := rfl + rw [hfun] + refine Eq.trans (congrArg (((α_ (superPow (stdSuperPair k ℓ) 0) + (stdSuperPair k ℓ) (stdSuperPair k ℓ)).inv : _ ⟶ _) : + SuperVect.Hom _ _).oddMap + (Eq.trans (congrArg ((((superPow (stdSuperPair k ℓ) 0) ◁ + (β_ (stdSuperPair k ℓ) (stdSuperPair k ℓ)).hom : _ ⟶ _) : + SuperVect.Hom _ _).oddMap) + (SuperVect.assoc_unit_oe r u y)) + (Eq.trans (whisker_unit_odd' + (SuperVect.koszulBraiding (stdSuperPair k ℓ) + (stdSuperPair k ℓ)) r _) + (congrArg (fun z => (r ⊗ₜ[ℂ] z, 0)) (SuperVect.koszul_oe u y))))) ?_ + exact SuperVect.assoc_unit_inv_eo r y u + +/-- Pointwise sum on odd colour functions. -/ +private theorem colourFunO_add_apply {n : ℕ} + (F G : (colourPower k ℓ n).odd) + (p : {c : MixedColouring k ℓ n // ¬ c.IsEven}) : + (F + G) p = F p + G p := rfl + +-- As for the even component: the same two-strand coordinate +-- elaborated through the odd half of the colouring equivalence. +private theorem superPow_two_odd_induction + (P : (superPow (stdSuperPair k ℓ) 2).odd → Prop) + (hP0 : P 0) + (hPadd : ∀ u₁ u₂, P u₁ → P u₂ → P (u₁ + u₂)) + (heo : ∀ (r : ℂ) (x : (stdSuperPair k ℓ).even) + (w : (stdSuperPair k ℓ).odd), + P ((((evenPair r x : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w, + (0 : (superPow (stdSuperPair k ℓ) 1).odd ⊗[ℂ] + (stdSuperPair k ℓ).even))))) + (hoe : ∀ (r : ℂ) (u : (stdSuperPair k ℓ).odd) + (y : (stdSuperPair k ℓ).even), + P ((((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), + ((r ⊗ₜ[ℂ] u, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y)))) + (v : (superPow (stdSuperPair k ℓ) 2).odd) : P v := by + have : Subsingleton SuperVect.tensorUnit.odd := + inferInstanceAs (Subsingleton PUnit) + have : Subsingleton (superPow (stdSuperPair k ℓ) 0).odd := + inferInstanceAs (Subsingleton PUnit) + obtain ⟨v₁, v₂⟩ := v + rw [show ((v₁, v₂) : (superPow (stdSuperPair k ℓ) 2).odd) = + (v₁, 0) + (0, v₂) from by + rw [Prod.mk_add_mk, add_zero, zero_add]] + refine hPadd _ _ ?_ ?_ + · -- The even-odd block. + induction v₁ using TensorProduct.inductionOn with + | add s t hs ht => + rw [show ((s + t, 0) : + (superPow (stdSuperPair k ℓ) 2).odd) = + (s, 0) + (t, 0) from by + rw [Prod.mk_add_mk, add_zero]] + exact hPadd _ _ hs ht + | tmul a w => + obtain ⟨a₁, a₂⟩ := a + have helem : ((((a₁, a₂) : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w, + 0) : (superPow (stdSuperPair k ℓ) 2).odd) = + (((((a₁, 0) : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w, 0)) : + (superPow (stdSuperPair k ℓ) 2).odd) + + (((((0, a₂) : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w, 0)) : + (superPow (stdSuperPair k ℓ) 2).odd) + := by + refine Eq.trans (congrArg (fun t => + ((t, (0 : (superPow (stdSuperPair k ℓ) 1).odd ⊗[ℂ] + (stdSuperPair k ℓ).even)) : + (superPow (stdSuperPair k ℓ) 2).odd)) + (Eq.trans (congrArg (fun s => + s ⊗ₜ[ℂ] w) + (show ((a₁, a₂) : + (superPow (stdSuperPair k ℓ) 1).even) = + ((a₁, 0) : (superPow (stdSuperPair k ℓ) 1).even) + + ((0, a₂) : (superPow (stdSuperPair k ℓ) 1).even) + from by rw [Prod.mk_add_mk, add_zero, + zero_add])) + (TensorProduct.add_tmul + (((a₁, 0) : + (superPow (stdSuperPair k ℓ) 1).even)) + (((0, a₂) : + (superPow (stdSuperPair k ℓ) 1).even)) w))) ?_ + exact Prod.ext_iff.mpr ⟨rfl, (add_zero 0).symm⟩ + refine Eq.mpr (congrArg P helem) (hPadd _ _ ?_ ?_) + · clear helem + induction a₁ using TensorProduct.inductionOn with + | add s t hs ht => + have helem : (((((s + t : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).even), 0) : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w, + 0) : (superPow (stdSuperPair k ℓ) 2).odd) = + ((((s, 0) : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w, + 0) : (superPow (stdSuperPair k ℓ) 2).odd) + + (((((t, 0) : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w, + 0)) : (superPow (stdSuperPair k ℓ) 2).odd) := by + refine Eq.trans (congrArg (fun u => + ((u, (0 : (superPow (stdSuperPair k ℓ) 1).odd + ⊗[ℂ] (stdSuperPair k ℓ).even)) : + (superPow (stdSuperPair k ℓ) 2).odd)) + (Eq.trans (congrArg (fun q => q ⊗ₜ[ℂ] w) + (show (((s + t : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).even), 0) : + (superPow (stdSuperPair k ℓ) 1).even) = + ((s, 0) : + (superPow (stdSuperPair k ℓ) 1).even) + + ((t, 0) : + (superPow (stdSuperPair k ℓ) 1).even) + from by rw [Prod.mk_add_mk, add_zero])) + (TensorProduct.add_tmul + (((s, 0) : + (superPow (stdSuperPair k ℓ) 1).even)) + (((t, 0) : + (superPow (stdSuperPair k ℓ) 1).even)) + w))) ?_ + exact Prod.ext_iff.mpr ⟨rfl, (add_zero 0).symm⟩ + exact Eq.mpr (congrArg P helem) (hPadd _ _ hs ht) + | tmul r x => exact heo r x w + · have h0elem : (((((0 : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).even), a₂) : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w, + 0) : (superPow (stdSuperPair k ℓ) 2).odd) = + 0 := by + rw [subsingleton_tmul_eq_zero a₂] + change (((0 : (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w, 0) : + (superPow (stdSuperPair k ℓ) 2).odd) = 0 + rw [TensorProduct.zero_tmul] + rfl + exact Eq.mpr (congrArg P h0elem) hP0 + · -- The odd-even block. + induction v₂ using TensorProduct.inductionOn with + | add s t hs ht => + rw [show ((0, s + t) : + (superPow (stdSuperPair k ℓ) 2).odd) = + (0, s) + (0, t) from by + rw [Prod.mk_add_mk, add_zero]] + exact hPadd _ _ hs ht + | tmul b y => + obtain ⟨b₁, b₂⟩ := b + have helem : ((0, (((b₁, b₂) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y)) : + (superPow (stdSuperPair k ℓ) 2).odd) = + (((0, (((b₁, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y))) : + (superPow (stdSuperPair k ℓ) 2).odd) + + (((0, (((0, b₂) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y))) : + (superPow (stdSuperPair k ℓ) 2).odd) + := by + refine Eq.trans (congrArg (fun t => + (((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), t) : + (superPow (stdSuperPair k ℓ) 2).odd)) + (Eq.trans (congrArg (fun s => + s ⊗ₜ[ℂ] y) + (show ((b₁, b₂) : + (superPow (stdSuperPair k ℓ) 1).odd) = + ((b₁, 0) : (superPow (stdSuperPair k ℓ) 1).odd) + + ((0, b₂) : (superPow (stdSuperPair k ℓ) 1).odd) + from by rw [Prod.mk_add_mk, add_zero, + zero_add])) + (TensorProduct.add_tmul + (((b₁, 0) : + (superPow (stdSuperPair k ℓ) 1).odd)) + (((0, b₂) : + (superPow (stdSuperPair k ℓ) 1).odd)) y))) ?_ + exact Prod.ext_iff.mpr ⟨(add_zero 0).symm, rfl⟩ + refine Eq.mpr (congrArg P helem) (hPadd _ _ ?_ ?_) + · clear helem + induction b₁ using TensorProduct.inductionOn with + | add s t hs ht => + have helem : ((0, ((((s + t : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y)) : + (superPow (stdSuperPair k ℓ) 2).odd) = + (((0, (((s, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y))) : + (superPow (stdSuperPair k ℓ) 2).odd) + + (((0, (((t, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y))) : + (superPow (stdSuperPair k ℓ) 2).odd) + := by + refine Eq.trans (congrArg (fun u => + (((0 : (superPow (stdSuperPair k ℓ) 1).even + ⊗[ℂ] (stdSuperPair k ℓ).odd), u) : + (superPow (stdSuperPair k ℓ) 2).odd)) + (Eq.trans (congrArg (fun q => q ⊗ₜ[ℂ] y) + (show (((s + t : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), 0) : + (superPow (stdSuperPair k ℓ) 1).odd) = + ((s, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) + + ((t, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) + from by rw [Prod.mk_add_mk, add_zero])) + (TensorProduct.add_tmul + (((s, 0) : + (superPow (stdSuperPair k ℓ) 1).odd)) + (((t, 0) : + (superPow (stdSuperPair k ℓ) 1).odd)) + y))) ?_ + exact Prod.ext_iff.mpr ⟨(add_zero 0).symm, rfl⟩ + exact Eq.mpr (congrArg P helem) (hPadd _ _ hs ht) + | tmul r u => exact hoe r u y + · have h0elem : ((0, ((((0 : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), b₂) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y)) : + (superPow (stdSuperPair k ℓ) 2).odd) = 0 := by + rw [subsingleton_tmul_eq_zero b₂] + change ((0, (0 : (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y) : + (superPow (stdSuperPair k ℓ) 2).odd) = 0 + rw [TensorProduct.zero_tmul] + rfl + exact Eq.mpr (congrArg P h0elem) hP0 + +private theorem braid_coord_odd + (c' : MixedColouring k ℓ 2) (hc' : ¬ c'.IsEven) + (v : (superPow (stdSuperPair k ℓ) 2).odd) : + (colourPowerEquiv k ℓ 2).oddEquiv + (((topBraid (stdSuperPair k ℓ) 0) : + SuperVect.Hom _ _).oddMap v) ⟨c', hc'⟩ = + adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ * + (colourPowerEquiv k ℓ 2).oddEquiv v + ⟨c' ∘ _root_.Equiv.swap (⟨0, by omega⟩ : Fin 2) + ⟨1, by omega⟩, + MixedColouring.not_isEven_comp hc' _⟩ := by + have : Subsingleton SuperVect.tensorUnit.odd := + inferInstanceAs (Subsingleton PUnit) + have : Subsingleton (superPow (stdSuperPair k ℓ) 0).odd := + inferInstanceAs (Subsingleton PUnit) + -- ═══════ THE PREDICATE, PROVED ADDITIVELY ═══════ + set P : (superPow (stdSuperPair k ℓ) 2).odd → Prop := + fun u => + (colourPowerEquiv k ℓ 2).oddEquiv + (((topBraid (stdSuperPair k ℓ) 0) : + SuperVect.Hom _ _).oddMap u) ⟨c', hc'⟩ = + adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ * + (colourPowerEquiv k ℓ 2).oddEquiv u + ⟨c' ∘ _root_.Equiv.swap (⟨0, by omega⟩ : Fin 2) + ⟨1, by omega⟩, + MixedColouring.not_isEven_comp hc' _⟩ with hP + change P v + have hswap0 : (c' ∘ _root_.Equiv.swap + (⟨0, by omega⟩ : Fin 2) ⟨1, by omega⟩) 0 = + c' (Fin.last 1) := + congrArg c' (_root_.Equiv.swap_apply_left _ _) + have hswap1 : (c' ∘ _root_.Equiv.swap + (⟨0, by omega⟩ : Fin 2) ⟨1, by omega⟩) (Fin.last 1) = + c' 0 := + congrArg c' (_root_.Equiv.swap_apply_right _ _) + have hP0 : P 0 := by + rw [hP] + beta_reduce + rw [map_zero, map_zero] + change (0 : ℂ) = _ * (0 : {c : MixedColouring k ℓ 2 // + ¬ c.IsEven} → ℂ) ⟨c' ∘ _root_.Equiv.swap + (⟨0, by omega⟩ : Fin 2) ⟨1, by omega⟩, + MixedColouring.not_isEven_comp hc' _⟩ + rw [show (0 : {c : MixedColouring k ℓ 2 // + ¬ c.IsEven} → ℂ) ⟨c' ∘ _root_.Equiv.swap + (⟨0, by omega⟩ : Fin 2) ⟨1, by omega⟩, + MixedColouring.not_isEven_comp hc' _⟩ = 0 from rfl] + rw [mul_zero] + have hPadd : ∀ u₁ u₂, P u₁ → P u₂ → P (u₁ + u₂) := by + intro u₁ u₂ h₁ h₂ + rw [hP] at h₁ h₂ ⊢ + beta_reduce at h₁ h₂ ⊢ + rw [map_add, map_add, colourFunO_add_apply, map_add, + colourFunO_add_apply, h₁, h₂, mul_add] + -- ═══════ THE EVEN⊗ODD GENERATORS ═══════ + have heo : ∀ (r : ℂ) (x : (stdSuperPair k ℓ).even) + (w : (stdSuperPair k ℓ).odd), + P ((((evenPair r x : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w, + (0 : (superPow (stdSuperPair k ℓ) 1).odd ⊗[ℂ] + (stdSuperPair k ℓ).even)))) := by + intro r x w + rw [hP] + beta_reduce + refine Eq.trans (congrArg + (fun t => (colourPowerEquiv k ℓ 2).oddEquiv t + ⟨c', hc'⟩) (braid_eo r x w)) ?_ + rcases hl0 : c' 0 with i | a <;> + rcases hl1 : c' (Fin.last 1) with j | b + · refine Eq.trans (eval2_oe_zero_left r w x c' hc' i j + hl0 hl1) (Eq.trans ?_ (congrArg + (fun t => adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ * t) + (eval2_eo_zero_right r x w _ + (MixedColouring.not_isEven_comp hc' _) i + (hswap1.trans hl0)).symm)) + exact (mul_zero _).symm + · refine Eq.trans (eval2_oe_zero_right r w x c' hc' b + hl1) (Eq.trans ?_ (congrArg + (fun t => adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ * t) + (eval2_eo_zero_right r x w _ + (MixedColouring.not_isEven_comp hc' _) i + (hswap1.trans hl0)).symm)) + exact (mul_zero _).symm + · refine Eq.trans (eval2_oe_val r w x c' hc' a j + hl0 hl1) (Eq.trans ?_ (congrArg + (fun t => adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ * t) + (eval2_eo_val r x w _ + (MixedColouring.not_isEven_comp hc' _) j a + (hswap0.trans hl1) (hswap1.trans hl0)).symm)) + rw [show adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ = + (1 : ℂ) from ite_eq_right (fun hA => by + rw [show c' ⟨1, by omega⟩ = Sum.inl j from hl1] at hA + exact Bool.noConfusion hA.2)] + ring + · refine Eq.trans (eval2_oe_zero_right r w x c' hc' b + hl1) (Eq.trans ?_ (congrArg + (fun t => adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ * t) + (eval2_eo_zero_left r x w _ + (MixedColouring.not_isEven_comp hc' _) b a + (hswap0.trans hl1) (hswap1.trans hl0)).symm)) + exact (mul_zero _).symm + -- ═══════ THE ODD⊗EVEN GENERATORS ═══════ + have hoe : ∀ (r : ℂ) (u : (stdSuperPair k ℓ).odd) + (y : (stdSuperPair k ℓ).even), + P ((((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), + ((r ⊗ₜ[ℂ] u, 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y))) := by + intro r u y + rw [hP] + beta_reduce + refine Eq.trans (congrArg + (fun t => (colourPowerEquiv k ℓ 2).oddEquiv t + ⟨c', hc'⟩) (braid_oe r u y)) ?_ + rcases hl0 : c' 0 with i | a <;> + rcases hl1 : c' (Fin.last 1) with j | b + · refine Eq.trans (eval2_eo_zero_right r y u c' hc' j + hl1) (Eq.trans ?_ (congrArg + (fun t => adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ * t) + (eval2_oe_zero_left r u y _ + (MixedColouring.not_isEven_comp hc' _) j i + (hswap0.trans hl1) (hswap1.trans hl0)).symm)) + exact (mul_zero _).symm + · refine Eq.trans (eval2_eo_val r y u c' hc' i b + hl0 hl1) (Eq.trans ?_ (congrArg + (fun t => adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ * t) + (eval2_oe_val r u y _ + (MixedColouring.not_isEven_comp hc' _) b i + (hswap0.trans hl1) (hswap1.trans hl0)).symm)) + rw [show adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ = + (1 : ℂ) from ite_eq_right (fun hA => by + rw [show c' ⟨0, by omega⟩ = Sum.inl i from hl0] at hA + exact Bool.noConfusion hA.1)] + ring + · refine Eq.trans (eval2_eo_zero_right r y u c' hc' j + hl1) (Eq.trans ?_ (congrArg + (fun t => adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ * t) + (eval2_oe_zero_right r u y _ + (MixedColouring.not_isEven_comp hc' _) a + (hswap1.trans hl0)).symm)) + exact (mul_zero _).symm + · refine Eq.trans (eval2_eo_zero_left r y u c' hc' a b + hl0 hl1) (Eq.trans ?_ (congrArg + (fun t => adjSign c' ⟨0, by omega⟩ ⟨1, by omega⟩ * t) + (eval2_oe_zero_right r u y _ + (MixedColouring.not_isEven_comp hc' _) a + (hswap1.trans hl0)).symm)) + exact (mul_zero _).symm + -- Assemble by block decomposition and tensor induction. + exact superPow_two_odd_induction P hP0 hPadd heo hoe v + +/-! ### The top swap on halves -/ + +private theorem firstHalf_swapTop (n : ℕ) + (c : MixedColouring k ℓ (n + 2)) : + MixedColouring.firstHalf (a := n) (b := 2) + (c ∘ _root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) ⟨n + 1, by omega⟩) = + MixedColouring.firstHalf (a := n) (b := 2) c := by + funext i + change c (_root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) ⟨n + 1, by omega⟩ + (Fin.castAdd 2 i)) = c (Fin.castAdd 2 i) + refine congrArg c (_root_.Equiv.swap_apply_of_ne_of_ne ?_ ?_) + · exact Fin.ne_of_val_ne (show i.val ≠ n from by + have := i.isLt; omega) + · exact Fin.ne_of_val_ne (show i.val ≠ n + 1 from by + have := i.isLt; omega) + +private theorem secondHalf_swapTop (n : ℕ) + (c : MixedColouring k ℓ (n + 2)) : + MixedColouring.secondHalf (a := n) (b := 2) + (c ∘ _root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) ⟨n + 1, by omega⟩) = + (MixedColouring.secondHalf (a := n) (b := 2) c) ∘ + _root_.Equiv.swap (⟨0, by omega⟩ : Fin 2) + ⟨1, by omega⟩ := by + funext j + change c (_root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) ⟨n + 1, by omega⟩ + (Fin.natAdd n j)) = + c (Fin.natAdd n (_root_.Equiv.swap + (⟨0, by omega⟩ : Fin 2) ⟨1, by omega⟩ j)) + refine congrArg c ?_ + rcases j with ⟨jv, hj⟩ + interval_cases jv + · rw [show Fin.natAdd n (⟨0, hj⟩ : Fin 2) = + (⟨n, by omega⟩ : Fin (n + 2)) from Fin.ext (by + change n + 0 = n; omega)] + rw [_root_.Equiv.swap_apply_left] + rw [show (⟨0, hj⟩ : Fin 2) = ⟨0, by omega⟩ from rfl] + rw [_root_.Equiv.swap_apply_left] + exact Fin.ext (by change n + 1 = n + 1; rfl) + · rw [show Fin.natAdd n (⟨1, hj⟩ : Fin 2) = + (⟨n + 1, by omega⟩ : Fin (n + 2)) from Fin.ext rfl] + rw [_root_.Equiv.swap_apply_right] + rw [show (⟨1, hj⟩ : Fin 2) = ⟨1, by omega⟩ from rfl] + rw [_root_.Equiv.swap_apply_right] + exact Fin.ext (by change n = n + 0; omega) + +private theorem adjSign_secondHalf (n : ℕ) + (c : MixedColouring k ℓ (n + 2)) : + adjSign (MixedColouring.secondHalf (a := n) (b := 2) c) + ⟨0, by omega⟩ ⟨1, by omega⟩ = + adjSign c ⟨n, by omega⟩ ⟨n + 1, by omega⟩ := by + unfold adjSign + rw [show MixedColouring.secondHalf (a := n) (b := 2) c + ⟨0, by omega⟩ = c ⟨n, by omega⟩ from + congrArg c (Fin.ext (by change n + 0 = n; omega))] + rw [show MixedColouring.secondHalf (a := n) (b := 2) c + ⟨1, by omega⟩ = c ⟨n + 1, by omega⟩ from + congrArg c (Fin.ext rfl)] + +/-! ### The general even coordinate identity -/ + +-- The two-strand coordinate transported over `n` +-- leading positions, so the merge equivalence at arity `n` enters +-- the elaborated term alongside the braiding. +private theorem braidN_coord_even (n : ℕ) + (c : MixedColouring k ℓ (n + 2)) (hc : c.IsEven) + (v : (superPow (stdSuperPair k ℓ) (n + 2)).even) : + (colourPowerEquiv k ℓ (n + 2)).evenEquiv + (((topBraid (stdSuperPair k ℓ) n) : + SuperVect.Hom _ _).evenMap v) ⟨c, hc⟩ = + adjSign c ⟨n, by omega⟩ ⟨n + 1, by omega⟩ * + (colourPowerEquiv k ℓ (n + 2)).evenEquiv v + ⟨c ∘ _root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) ⟨n + 1, by omega⟩, + hc.comp _⟩ := by + obtain ⟨w, rfl⟩ := + powMerge_evenMap_surjective (stdSuperPair k ℓ) n 2 v + -- ═══════ THE BRAIDING COMMUTES PAST THE LEADING BLOCK ═══════ + have hcomm := (congrArg (fun z : + (superPow (stdSuperPair k ℓ) n ⊗ + superPow (stdSuperPair k ℓ) 2 ⟶ + superPow (stdSuperPair k ℓ) (n + 2)) => + (z : SuperVect.Hom _ _).evenMap w) + (powMerge_topBraid (stdSuperPair k ℓ) n)).symm + refine Eq.trans (congrArg + (fun t => (colourPowerEquiv k ℓ (n + 2)).evenEquiv t + ⟨c, hc⟩) hcomm) ?_ + clear hcomm + -- ═══════ THE PREDICATE, PROVED ADDITIVELY ═══════ + set P : (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) n) + (superPow (stdSuperPair k ℓ) 2)).even → Prop := fun u => + (colourPowerEquiv k ℓ (n + 2)).evenEquiv + (((powMerge (stdSuperPair k ℓ) n 2) : + SuperVect.Hom _ _).evenMap + ((((superPow (stdSuperPair k ℓ) n) ◁ + topBraid (stdSuperPair k ℓ) 0 : _ ⟶ _) : + SuperVect.Hom _ _).evenMap u)) ⟨c, hc⟩ = + adjSign c ⟨n, by omega⟩ ⟨n + 1, by omega⟩ * + (colourPowerEquiv k ℓ (n + 2)).evenEquiv + (((powMerge (stdSuperPair k ℓ) n 2) : + SuperVect.Hom _ _).evenMap u) + ⟨c ∘ _root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) ⟨n + 1, by omega⟩, + hc.comp _⟩ with hP + change P w + have hP0 : P 0 := by + rw [hP] + beta_reduce + simp only [map_zero] + change (0 : ℂ) = adjSign c ⟨n, by omega⟩ + ⟨n + 1, by omega⟩ * (0 : ℂ) + rw [mul_zero] + have hPadd : ∀ u₁ u₂, P u₁ → P u₂ → P (u₁ + u₂) := by + intro u₁ u₂ h₁ h₂ + rw [hP] at h₁ h₂ ⊢ + beta_reduce at h₁ h₂ ⊢ + rw [map_add, map_add, map_add, colourFun_add_apply, + map_add, map_add, colourFun_add_apply, h₁, h₂, mul_add] + -- ═══════ THE EVEN LEADING BLOCK ═══════ + have hblock1 : ∀ (p : (superPow (stdSuperPair k ℓ) n).even) + (q : (superPow (stdSuperPair k ℓ) 2).even), + P (evenPair p q) := by + intro p q + rw [hP] + beta_reduce + refine Eq.trans (congrArg (fun t => + (colourPowerEquiv k ℓ (n + 2)).evenEquiv + (((powMerge (stdSuperPair k ℓ) n 2) : + SuperVect.Hom _ _).evenMap t) ⟨c, hc⟩) + (tensorHom_evenPair (SuperVect.Hom.id _) + ((topBraid (stdSuperPair k ℓ) 0) : + SuperVect.Hom _ _) p q)) ?_ + refine Eq.trans (colourMerge_coord n 2 p + (((topBraid (stdSuperPair k ℓ) 0) : + SuperVect.Hom _ _).evenMap q) c hc) ?_ + refine Eq.trans ?_ (congrArg + (fun t => adjSign c ⟨n, by omega⟩ ⟨n + 1, by omega⟩ * t) + (colourMerge_coord n 2 p q _ (hc.comp _)).symm) + by_cases hfh : MixedColouring.IsEven + (MixedColouring.firstHalf (a := n) (b := 2) c) + · rw [dite_eq_left hfh] + rw [dite_eq_left (show MixedColouring.IsEven + (MixedColouring.firstHalf (a := n) (b := 2) + (c ∘ _root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) + ⟨n + 1, by omega⟩)) from + (firstHalf_swapTop n c).symm ▸ hfh)] + refine Eq.trans (congrArg + (fun t => (colourPowerEquiv k ℓ n).evenEquiv p + ⟨MixedColouring.firstHalf c, hfh⟩ * t) + (braid_coord_even + (MixedColouring.secondHalf (a := n) (b := 2) c) + (c.secondHalf_isEven hc hfh) q)) ?_ + rw [show (⟨MixedColouring.firstHalf (a := n) (b := 2) + (c ∘ _root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) + ⟨n + 1, by omega⟩), _⟩ : + {c : MixedColouring k ℓ n // c.IsEven}) = + ⟨MixedColouring.firstHalf (a := n) (b := 2) c, + hfh⟩ from Subtype.ext (firstHalf_swapTop n c)] + rw [show (⟨MixedColouring.secondHalf (a := n) (b := 2) + (c ∘ _root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) + ⟨n + 1, by omega⟩), _⟩ : + {c : MixedColouring k ℓ 2 // c.IsEven}) = + ⟨(MixedColouring.secondHalf (a := n) (b := 2) c) ∘ + _root_.Equiv.swap (⟨0, by omega⟩ : Fin 2) + ⟨1, by omega⟩, + (c.secondHalf_isEven hc hfh).comp _⟩ from + Subtype.ext (secondHalf_swapTop n c)] + rw [adjSign_secondHalf n c] + ring + · rw [dite_eq_right hfh] + rw [dite_eq_right (show ¬ MixedColouring.IsEven + (MixedColouring.firstHalf (a := n) (b := 2) + (c ∘ _root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) + ⟨n + 1, by omega⟩)) from + fun h' => hfh ((firstHalf_swapTop n c) ▸ h'))] + rw [mul_zero] + -- ═══════ THE ODD LEADING BLOCK ═══════ + have hblock2 : ∀ (p : (superPow (stdSuperPair k ℓ) n).odd) + (q : (superPow (stdSuperPair k ℓ) 2).odd), + P (((0 : (superPow (stdSuperPair k ℓ) n).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) 2).even), + p ⊗ₜ[ℂ] q)) := by + intro p q + rw [hP] + beta_reduce + refine Eq.trans (congrArg (fun t => + (colourPowerEquiv k ℓ (n + 2)).evenEquiv + (((powMerge (stdSuperPair k ℓ) n 2) : + SuperVect.Hom _ _).evenMap t) ⟨c, hc⟩) + (tensorHom_oddPair (SuperVect.Hom.id _) + ((topBraid (stdSuperPair k ℓ) 0) : + SuperVect.Hom _ _) p q)) ?_ + refine Eq.trans (colourMerge_coord_oddPair n 2 p + (((topBraid (stdSuperPair k ℓ) 0) : + SuperVect.Hom _ _).oddMap q) c hc) ?_ + refine Eq.trans ?_ (congrArg + (fun t => adjSign c ⟨n, by omega⟩ ⟨n + 1, by omega⟩ * t) + (colourMerge_coord_oddPair n 2 p q _ (hc.comp _)).symm) + by_cases hfh : MixedColouring.IsEven + (MixedColouring.firstHalf (a := n) (b := 2) c) + · rw [dite_eq_left hfh] + rw [dite_eq_left (show MixedColouring.IsEven + (MixedColouring.firstHalf (a := n) (b := 2) + (c ∘ _root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) + ⟨n + 1, by omega⟩)) from + (firstHalf_swapTop n c).symm ▸ hfh)] + rw [mul_zero] + · rw [dite_eq_right hfh] + rw [dite_eq_right (show ¬ MixedColouring.IsEven + (MixedColouring.firstHalf (a := n) (b := 2) + (c ∘ _root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) + ⟨n + 1, by omega⟩)) from + fun h' => hfh ((firstHalf_swapTop n c) ▸ h'))] + refine Eq.trans (congrArg + (fun t => (colourPowerEquiv k ℓ n).oddEquiv p + ⟨MixedColouring.firstHalf c, hfh⟩ * t) + (braid_coord_odd + (MixedColouring.secondHalf (a := n) (b := 2) c) + (c.secondHalf_not_isEven' hc hfh) q)) ?_ + rw [show (⟨MixedColouring.firstHalf (a := n) (b := 2) + (c ∘ _root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) + ⟨n + 1, by omega⟩), _⟩ : + {c : MixedColouring k ℓ n // ¬ c.IsEven}) = + ⟨MixedColouring.firstHalf (a := n) (b := 2) c, + hfh⟩ from Subtype.ext (firstHalf_swapTop n c)] + rw [show (⟨MixedColouring.secondHalf (a := n) (b := 2) + (c ∘ _root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) + ⟨n + 1, by omega⟩), _⟩ : + {c : MixedColouring k ℓ 2 // ¬ c.IsEven}) = + ⟨(MixedColouring.secondHalf (a := n) (b := 2) c) ∘ + _root_.Equiv.swap (⟨0, by omega⟩ : Fin 2) + ⟨1, by omega⟩, + MixedColouring.not_isEven_comp + (c.secondHalf_not_isEven' hc hfh) _⟩ from + Subtype.ext (secondHalf_swapTop n c)] + rw [adjSign_secondHalf n c] + ring + obtain ⟨w₁, w₂⟩ := w + rw [show ((w₁, w₂) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) n) + (superPow (stdSuperPair k ℓ) 2)).even) = + (w₁, 0) + (0, w₂) from by + rw [Prod.mk_add_mk, add_zero, zero_add]] + refine hPadd _ _ ?_ ?_ + · induction w₁ using TensorProduct.inductionOn with + | add s t hs ht => + rw [show ((s + t, 0) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) n) + (superPow (stdSuperPair k ℓ) 2)).even) = + (s, 0) + (t, 0) from by + rw [Prod.mk_add_mk, add_zero]] + exact hPadd _ _ hs ht + | tmul p q => exact hblock1 p q + · induction w₂ using TensorProduct.inductionOn with + | add s t hs ht => + rw [show ((0, s + t) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) n) + (superPow (stdSuperPair k ℓ) 2)).even) = + (0, s) + (0, t) from by + rw [Prod.mk_add_mk, add_zero]] + exact hPadd _ _ hs ht + | tmul p q => exact hblock2 p q + +/-! ### The general odd coordinate identity and main theorem -/ + +private theorem tensorHom_oddFst {V₁ V₂ W₁ W₂ : SuperVect} + (e₁ : SuperVect.Hom V₁ W₁) (e₂ : SuperVect.Hom V₂ W₂) + (v : V₁.even) (u : V₂.odd) : + (SuperVect.tensorHom e₁ e₂).oddMap + ((v ⊗ₜ[ℂ] u, (0 : V₁.odd ⊗[ℂ] V₂.even))) = + ((e₁.evenMap v ⊗ₜ[ℂ] e₂.oddMap u, + (0 : W₁.odd ⊗[ℂ] W₂.even))) := by + change (TensorProduct.map e₁.evenMap e₂.oddMap (v ⊗ₜ[ℂ] u), + TensorProduct.map e₁.oddMap e₂.evenMap 0) = _ + rw [TensorProduct.map_tmul, map_zero] + +private theorem tensorHom_oddSnd {V₁ V₂ W₁ W₂ : SuperVect} + (e₁ : SuperVect.Hom V₁ W₁) (e₂ : SuperVect.Hom V₂ W₂) + (v : V₁.odd) (u : V₂.even) : + (SuperVect.tensorHom e₁ e₂).oddMap + (((0 : V₁.even ⊗[ℂ] V₂.odd), v ⊗ₜ[ℂ] u)) = + (((0 : W₁.even ⊗[ℂ] W₂.odd), + e₁.oddMap v ⊗ₜ[ℂ] e₂.evenMap u)) := by + change (TensorProduct.map e₁.evenMap e₂.oddMap 0, + TensorProduct.map e₁.oddMap e₂.evenMap (v ⊗ₜ[ℂ] u)) = _ + rw [TensorProduct.map_tmul, map_zero] + +private theorem secondHalf_even_of_odd_odd {a b : ℕ} + {c : MixedColouring k ℓ (a + b)} (hc : ¬ c.IsEven) + (h : ¬ MixedColouring.IsEven + (MixedColouring.firstHalf (a := a) (b := b) c)) : + MixedColouring.IsEven + (MixedColouring.secondHalf (a := a) (b := b) c) := by + by_contra hsh + refine hc ?_ + rw [MixedColouring.IsEven, MixedColouring.oddSet_card_split] + rw [MixedColouring.IsEven] at h hsh + exact Nat.even_add.mpr ⟨fun hA => absurd hA h, + fun hB => absurd hB hsh⟩ + +-- As for the even component, on the odd half. +private theorem braidN_coord_odd (n : ℕ) + (c : MixedColouring k ℓ (n + 2)) (hc : ¬ c.IsEven) + (v : (superPow (stdSuperPair k ℓ) (n + 2)).odd) : + (colourPowerEquiv k ℓ (n + 2)).oddEquiv + (((topBraid (stdSuperPair k ℓ) n) : + SuperVect.Hom _ _).oddMap v) ⟨c, hc⟩ = + adjSign c ⟨n, by omega⟩ ⟨n + 1, by omega⟩ * + (colourPowerEquiv k ℓ (n + 2)).oddEquiv v + ⟨c ∘ _root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) ⟨n + 1, by omega⟩, + MixedColouring.not_isEven_comp hc _⟩ := by + obtain ⟨w, rfl⟩ := + powMerge_oddMap_surjective (stdSuperPair k ℓ) n 2 v + have hcomm := (congrArg (fun z : + (superPow (stdSuperPair k ℓ) n ⊗ + superPow (stdSuperPair k ℓ) 2 ⟶ + superPow (stdSuperPair k ℓ) (n + 2)) => + (z : SuperVect.Hom _ _).oddMap w) + (powMerge_topBraid (stdSuperPair k ℓ) n)).symm + refine Eq.trans (congrArg + (fun t => (colourPowerEquiv k ℓ (n + 2)).oddEquiv t + ⟨c, hc⟩) hcomm) ?_ + clear hcomm + -- ═══════ THE PREDICATE, PROVED ADDITIVELY ═══════ + set P : (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) n) + (superPow (stdSuperPair k ℓ) 2)).odd → Prop := fun u => + (colourPowerEquiv k ℓ (n + 2)).oddEquiv + (((powMerge (stdSuperPair k ℓ) n 2) : + SuperVect.Hom _ _).oddMap + ((((superPow (stdSuperPair k ℓ) n) ◁ + topBraid (stdSuperPair k ℓ) 0 : _ ⟶ _) : + SuperVect.Hom _ _).oddMap u)) ⟨c, hc⟩ = + adjSign c ⟨n, by omega⟩ ⟨n + 1, by omega⟩ * + (colourPowerEquiv k ℓ (n + 2)).oddEquiv + (((powMerge (stdSuperPair k ℓ) n 2) : + SuperVect.Hom _ _).oddMap u) + ⟨c ∘ _root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) ⟨n + 1, by omega⟩, + MixedColouring.not_isEven_comp hc _⟩ with hP + change P w + have hP0 : P 0 := by + rw [hP] + beta_reduce + simp only [map_zero] + change (0 : ℂ) = adjSign c ⟨n, by omega⟩ + ⟨n + 1, by omega⟩ * (0 : ℂ) + rw [mul_zero] + have hPadd : ∀ u₁ u₂, P u₁ → P u₂ → P (u₁ + u₂) := by + intro u₁ u₂ h₁ h₂ + rw [hP] at h₁ h₂ ⊢ + beta_reduce at h₁ h₂ ⊢ + rw [map_add, map_add, map_add, colourFunO_add_apply, + map_add, map_add, colourFunO_add_apply, h₁, h₂, + mul_add] + -- ═══════ THE EVEN LEADING BLOCK ═══════ + have hblock1 : ∀ (p : (superPow (stdSuperPair k ℓ) n).even) + (q : (superPow (stdSuperPair k ℓ) 2).odd), + P ((p ⊗ₜ[ℂ] q, + (0 : (superPow (stdSuperPair k ℓ) n).odd ⊗[ℂ] + (superPow (stdSuperPair k ℓ) 2).even))) := by + intro p q + rw [hP] + beta_reduce + refine Eq.trans (congrArg (fun t => + (colourPowerEquiv k ℓ (n + 2)).oddEquiv + (((powMerge (stdSuperPair k ℓ) n 2) : + SuperVect.Hom _ _).oddMap t) ⟨c, hc⟩) + (tensorHom_oddFst (SuperVect.Hom.id _) + ((topBraid (stdSuperPair k ℓ) 0) : + SuperVect.Hom _ _) p q)) ?_ + refine Eq.trans (colourMerge_coord_evenOdd n 2 p + (((topBraid (stdSuperPair k ℓ) 0) : + SuperVect.Hom _ _).oddMap q) c hc) ?_ + refine Eq.trans ?_ (congrArg + (fun t => adjSign c ⟨n, by omega⟩ ⟨n + 1, by omega⟩ * t) + (colourMerge_coord_evenOdd n 2 p q _ + (MixedColouring.not_isEven_comp hc _)).symm) + by_cases hfh : MixedColouring.IsEven + (MixedColouring.firstHalf (a := n) (b := 2) c) + · rw [dite_eq_left hfh] + rw [dite_eq_left (show MixedColouring.IsEven + (MixedColouring.firstHalf (a := n) (b := 2) + (c ∘ _root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) + ⟨n + 1, by omega⟩)) from + (firstHalf_swapTop n c).symm ▸ hfh)] + refine Eq.trans (congrArg + (fun t => (colourPowerEquiv k ℓ n).evenEquiv p + ⟨MixedColouring.firstHalf c, hfh⟩ * t) + (braid_coord_odd + (MixedColouring.secondHalf (a := n) (b := 2) c) + (c.secondHalf_not_isEven hc hfh) q)) ?_ + rw [show (⟨MixedColouring.firstHalf (a := n) (b := 2) + (c ∘ _root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) + ⟨n + 1, by omega⟩), _⟩ : + {c : MixedColouring k ℓ n // c.IsEven}) = + ⟨MixedColouring.firstHalf (a := n) (b := 2) c, + hfh⟩ from Subtype.ext (firstHalf_swapTop n c)] + rw [show (⟨MixedColouring.secondHalf (a := n) (b := 2) + (c ∘ _root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) + ⟨n + 1, by omega⟩), _⟩ : + {c : MixedColouring k ℓ 2 // ¬ c.IsEven}) = + ⟨(MixedColouring.secondHalf (a := n) (b := 2) c) ∘ + _root_.Equiv.swap (⟨0, by omega⟩ : Fin 2) + ⟨1, by omega⟩, + MixedColouring.not_isEven_comp + (c.secondHalf_not_isEven hc hfh) _⟩ from + Subtype.ext (secondHalf_swapTop n c)] + rw [adjSign_secondHalf n c] + ring + · rw [dite_eq_right hfh] + rw [dite_eq_right (show ¬ MixedColouring.IsEven + (MixedColouring.firstHalf (a := n) (b := 2) + (c ∘ _root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) + ⟨n + 1, by omega⟩)) from + fun h' => hfh ((firstHalf_swapTop n c) ▸ h'))] + rw [mul_zero] + -- ═══════ THE ODD LEADING BLOCK ═══════ + have hblock2 : ∀ (p : (superPow (stdSuperPair k ℓ) n).odd) + (q : (superPow (stdSuperPair k ℓ) 2).even), + P (((0 : (superPow (stdSuperPair k ℓ) n).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) 2).odd), + p ⊗ₜ[ℂ] q)) := by + intro p q + rw [hP] + beta_reduce + refine Eq.trans (congrArg (fun t => + (colourPowerEquiv k ℓ (n + 2)).oddEquiv + (((powMerge (stdSuperPair k ℓ) n 2) : + SuperVect.Hom _ _).oddMap t) ⟨c, hc⟩) + (tensorHom_oddSnd (SuperVect.Hom.id _) + ((topBraid (stdSuperPair k ℓ) 0) : + SuperVect.Hom _ _) p q)) ?_ + refine Eq.trans (colourMerge_coord_odd n 2 p + (((topBraid (stdSuperPair k ℓ) 0) : + SuperVect.Hom _ _).evenMap q) c hc) ?_ + refine Eq.trans ?_ (congrArg + (fun t => adjSign c ⟨n, by omega⟩ ⟨n + 1, by omega⟩ * t) + (colourMerge_coord_odd n 2 p q _ + (MixedColouring.not_isEven_comp hc _)).symm) + by_cases hfh : MixedColouring.IsEven + (MixedColouring.firstHalf (a := n) (b := 2) c) + · rw [dite_eq_left hfh] + rw [dite_eq_left (show MixedColouring.IsEven + (MixedColouring.firstHalf (a := n) (b := 2) + (c ∘ _root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) + ⟨n + 1, by omega⟩)) from + (firstHalf_swapTop n c).symm ▸ hfh)] + rw [mul_zero] + · rw [dite_eq_right hfh] + rw [dite_eq_right (show ¬ MixedColouring.IsEven + (MixedColouring.firstHalf (a := n) (b := 2) + (c ∘ _root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) + ⟨n + 1, by omega⟩)) from + fun h' => hfh ((firstHalf_swapTop n c) ▸ h'))] + refine Eq.trans (congrArg + (fun t => (colourPowerEquiv k ℓ n).oddEquiv p + ⟨MixedColouring.firstHalf c, hfh⟩ * t) + (braid_coord_even + (MixedColouring.secondHalf (a := n) (b := 2) c) + (secondHalf_even_of_odd_odd hc hfh) q)) ?_ + rw [show (⟨MixedColouring.firstHalf (a := n) (b := 2) + (c ∘ _root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) + ⟨n + 1, by omega⟩), _⟩ : + {c : MixedColouring k ℓ n // ¬ c.IsEven}) = + ⟨MixedColouring.firstHalf (a := n) (b := 2) c, + hfh⟩ from Subtype.ext (firstHalf_swapTop n c)] + rw [show (⟨MixedColouring.secondHalf (a := n) (b := 2) + (c ∘ _root_.Equiv.swap + (⟨n, by omega⟩ : Fin (n + 2)) + ⟨n + 1, by omega⟩), _⟩ : + {c : MixedColouring k ℓ 2 // c.IsEven}) = + ⟨(MixedColouring.secondHalf (a := n) (b := 2) c) ∘ + _root_.Equiv.swap (⟨0, by omega⟩ : Fin 2) + ⟨1, by omega⟩, + (secondHalf_even_of_odd_odd hc hfh).comp _⟩ from + Subtype.ext (secondHalf_swapTop n c)] + rw [adjSign_secondHalf n c] + ring + obtain ⟨w₁, w₂⟩ := w + rw [show ((w₁, w₂) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) n) + (superPow (stdSuperPair k ℓ) 2)).odd) = + (w₁, 0) + (0, w₂) from by + rw [Prod.mk_add_mk, add_zero, zero_add]] + refine hPadd _ _ ?_ ?_ + · induction w₁ using TensorProduct.inductionOn with + | add s t hs ht => + rw [show ((s + t, 0) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) n) + (superPow (stdSuperPair k ℓ) 2)).odd) = + (s, 0) + (t, 0) from by + rw [Prod.mk_add_mk, add_zero]] + exact hPadd _ _ hs ht + | tmul p q => exact hblock1 p q + · induction w₂ using TensorProduct.inductionOn with + | add s t hs ht => + rw [show ((0, s + t) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) n) + (superPow (stdSuperPair k ℓ) 2)).odd) = + (0, s) + (0, t) from by + rw [Prod.mk_add_mk, add_zero]] + exact hPadd _ _ hs ht + | tmul p q => exact hblock2 p q + +-- Assembling the two coordinate formulas into an +-- equality of super morphisms unfolds the colouring equivalence on +-- both components once more. +/-- **The colour action of the top braiding.** -/ +theorem toColour_topBraid (n : ℕ) : + toColour (k := k) (ℓ := ℓ) (n + 2) + (topBraid (stdSuperPair k ℓ) n) = + colourSwap k ℓ (n + 2) n (by omega) := by + refine SuperVect.Hom.ext ?_ ?_ + · refine LinearMap.ext (fun F => ?_) + funext c' + obtain ⟨c', hc'⟩ := c' + refine Eq.trans (braidN_coord_even n c' hc' + ((colourPowerEquiv k ℓ (n + 2)).evenEquiv.symm F)) ?_ + rw [LinearEquiv.apply_symm_apply] + rfl + · refine LinearMap.ext (fun F => ?_) + funext c' + obtain ⟨c', hc'⟩ := c' + refine Eq.trans (braidN_coord_odd n c' hc' + ((colourPowerEquiv k ℓ (n + 2)).oddEquiv.symm F)) ?_ + rw [LinearEquiv.apply_symm_apply] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourEval.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourEval.lean new file mode 100644 index 0000000000..d5c1ee1074 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourEval.lean @@ -0,0 +1,72 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPower + +/-! +# Evaluating a colour tensor + +The function tensor on a pure tensor is the pointwise product, and +the colouring of a product index splits into its two factors — the +computation rules the standard super model's coordinates use. +-/ + +@[expose] public section + +open scoped TensorProduct + +namespace RS + +/-- The function tensor on a pure tensor is the pointwise +product. -/ +theorem funTensorFun_tmul {ι κ : Type} [Fintype ι] [Fintype κ] + (f : ι → ℂ) (g : κ → ℂ) (p : ι × κ) : + funTensorFun ι κ (f ⊗ₜ[ℂ] g) p = f p.1 * g p.2 := by + obtain ⟨a, b⟩ := p + simp [funTensorFun, LinearEquiv.trans_apply] + +/-- Rejoining, at an early slot. -/ +theorem colouringSplit_symm_castSucc {k ℓ d : ℕ} + (c₀ : MixedColouring k ℓ d) (x : Fin k ⊕ Fin (2 * ℓ)) + (i : Fin d) : + (colouringSplit k ℓ d).symm (c₀, x) i.castSucc = c₀ i := by + simp [colouringSplit] + +/-- At the last slot. -/ +theorem colouringSplit_symm_last {k ℓ d : ℕ} + (c₀ : MixedColouring k ℓ d) (x : Fin k ⊕ Fin (2 * ℓ)) : + (colouringSplit k ℓ d).symm (c₀, x) (Fin.last d) = x := by + simp [colouringSplit] + +/-- The inverse even split on an even-tail/even-colour pair. -/ +theorem evenSplitEquiv_symm_inl {k ℓ d : ℕ} + (c₀ : {c : MixedColouring k ℓ d // c.IsEven}) (a : Fin k) : + ((evenSplitEquiv k ℓ d).symm (Sum.inl (c₀, a))).val = + (colouringSplit k ℓ d).symm (c₀.val, Sum.inl a) := rfl + +/-- The inverse even split on an odd-tail/odd-colour pair. -/ +theorem evenSplitEquiv_symm_inr {k ℓ d : ℕ} + (c₀ : {c : MixedColouring k ℓ d // ¬ c.IsEven}) + (b : Fin (2 * ℓ)) : + ((evenSplitEquiv k ℓ d).symm (Sum.inr (c₀, b))).val = + (colouringSplit k ℓ d).symm (c₀.val, Sum.inr b) := rfl + +/-- The inverse odd split on an odd-tail/even-colour pair. -/ +theorem oddSplitEquiv_symm_inl {k ℓ d : ℕ} + (c₀ : {c : MixedColouring k ℓ d // ¬ c.IsEven}) (a : Fin k) : + ((oddSplitEquiv k ℓ d).symm (Sum.inl (c₀, a))).val = + (colouringSplit k ℓ d).symm (c₀.val, Sum.inl a) := rfl + +/-- The inverse odd split on an even-tail/odd-colour pair. -/ +theorem oddSplitEquiv_symm_inr {k ℓ d : ℕ} + (c₀ : {c : MixedColouring k ℓ d // c.IsEven}) + (b : Fin (2 * ℓ)) : + ((oddSplitEquiv k ℓ d).symm (Sum.inr (c₀, b))).val = + (colouringSplit k ℓ d).symm (c₀.val, Sum.inr b) := rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourExtendSwap.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourExtendSwap.lean new file mode 100644 index 0000000000..f4c5f8be75 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourExtendSwap.lean @@ -0,0 +1,461 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConj + +/-! +# Extension commutes with an adjacent colour swap + +Extending a mixed colouring by one slot and swapping two adjacent +colours are independent operations when the swapped pair lies below +the new slot: the swap acts on the tail, the extension prepends, and +the two commute on the nose (`colourExtend_colourSwap`). + +The proof is the corresponding statement for the adjacency sign +(`adjSign_eq_tail`) carried through the word and its permutation. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open scoped TensorProduct + +variable {k ℓ : ℕ} + +private theorem adjSign_eq_tail {n : ℕ} (c : MixedColouring k ℓ (n + 2)) (i : ℕ) + (h : i + 2 ≤ n + 1) : + adjSign c ⟨i, by omega⟩ ⟨i + 1, by omega⟩ = + adjSign (MixedColouring.tail c) ⟨i, by omega⟩ ⟨i + 1, by omega⟩ := by + unfold adjSign MixedColouring.tail; rfl + +private theorem swap_last_eq {n i : ℕ} (h : i + 2 ≤ n + 1) : + Equiv.swap (⟨i, by omega⟩ : Fin (n + 2)) ⟨i + 1, by omega⟩ + (Fin.last (n + 1)) = Fin.last (n + 1) := by + simp only [Equiv.swap_apply_def] + split_ifs with h1 h2 <;> simp_all [Fin.ext_iff, Fin.val_last] <;> omega + +private theorem swap_castSucc_eq {n i : ℕ} (h : i + 2 ≤ n + 1) + (j : Fin (n + 1)) : + Equiv.swap (⟨i, by omega⟩ : Fin (n + 2)) ⟨i + 1, by omega⟩ + (j.castSucc) = + (Equiv.swap (⟨i, by omega⟩ : Fin (n + 1)) ⟨i + 1, by omega⟩ j).castSucc + := by + simp only [Equiv.swap_apply_def] + split_ifs with h1 h2 h3 h4 <;> simp_all [Fin.ext_iff] + +/-- Composition of `funTensorFun`, `TensorProduct.map f id`, for +general tensor elements. -/ +private theorem funTensorFun_map_id {ι κ : Type} [Fintype ι] + [Fintype κ] + (f : (ι → ℂ) →ₗ[ℂ] (ι → ℂ)) + (t : (ι → ℂ) ⊗[ℂ] (κ → ℂ)) (x : ι) (y : κ) : + funTensorFun ι κ (TensorProduct.map f LinearMap.id t) (x, y) = + f (fun x' => funTensorFun ι κ t (x', y)) x := by + induction t using TensorProduct.inductionOn with + | tmul a b => + simp only [TensorProduct.map_tmul, LinearMap.id_apply, funTensorFun_tmul] + have : (fun x' => a x' * b y) = b y • a := by + ext x'; simp [Pi.smul_apply, smul_eq_mul, mul_comm] + rw [this, map_smul, Pi.smul_apply, smul_eq_mul, mul_comm] + | add t₁ t₂ ih₁ ih₂ => + simp only [map_add, Pi.add_apply, ih₁, ih₂] + have : (fun x' => funTensorFun ι κ t₁ (x', y) + + funTensorFun ι κ t₂ (x', y)) = + (fun x' => funTensorFun ι κ t₁ (x', y)) + + (fun x' => funTensorFun ι κ t₂ (x', y)) := rfl + rw [this, map_add, Pi.add_apply] + +/-! ### Computation lemmas for `colourPowerStep` applied at a point -/ + +-- The tensor step equivalence is applied to a +-- `tensorHom` and split over the four graded blocks. +private theorem step_tensorHom_even_apply (d : ℕ) + (T : colourPower k ℓ d ⟶ colourPower k ℓ d) + (P : (SuperVect.tensorObj (colourPower k ℓ d) (stdSuperPair k ℓ)).even) + (c : {c : MixedColouring k ℓ (d + 1) // c.IsEven}) : + (colourPowerStep k ℓ d).evenEquiv + ((SuperVect.tensorHom T (SuperVect.Hom.id (stdSuperPair k ℓ)) : + SuperVect.Hom _ _).evenMap P) c = + Sum.elim + (fun p => funTensorFun _ _ (TensorProduct.map + (T : SuperVect.Hom _ _).evenMap LinearMap.id P.1) p) + (fun p => funTensorFun _ _ (TensorProduct.map + (T : SuperVect.Hom _ _).oddMap LinearMap.id P.2) p) + (evenSplitEquiv k ℓ d c) := by + unfold colourPowerStep SuperVect.tensorHom SuperVect.Hom.id + rfl + +/-- The even step equivalence applied at a point. -/ +private theorem step_even_apply (d : ℕ) + (P : (SuperVect.tensorObj (colourPower k ℓ d) (stdSuperPair k ℓ)).even) + (c : {c : MixedColouring k ℓ (d + 1) // c.IsEven}) : + (colourPowerStep k ℓ d).evenEquiv P c = + Sum.elim (fun p => funTensorFun _ _ P.1 p) + (fun p => funTensorFun _ _ P.2 p) + (evenSplitEquiv k ℓ d c) := by + unfold colourPowerStep + rfl + +-- As for the even component, on the odd half. +private theorem step_tensorHom_odd_apply (d : ℕ) + (T : colourPower k ℓ d ⟶ colourPower k ℓ d) + (P : (SuperVect.tensorObj (colourPower k ℓ d) (stdSuperPair k ℓ)).odd) + (c : {c : MixedColouring k ℓ (d + 1) // ¬ c.IsEven}) : + (colourPowerStep k ℓ d).oddEquiv + ((SuperVect.tensorHom T (SuperVect.Hom.id (stdSuperPair k ℓ)) : + SuperVect.Hom _ _).oddMap P) c = + Sum.elim + (fun p => funTensorFun _ _ (TensorProduct.map + (T : SuperVect.Hom _ _).evenMap LinearMap.id P.1) p) + (fun p => funTensorFun _ _ (TensorProduct.map + (T : SuperVect.Hom _ _).oddMap LinearMap.id P.2) p) + (Equiv.sumComm _ _ (oddSplitEquiv k ℓ d c)) := by + unfold colourPowerStep SuperVect.tensorHom SuperVect.Hom.id + rfl + +/-- The odd step equivalence applied at a point. -/ +private theorem step_odd_apply (d : ℕ) + (P : (SuperVect.tensorObj (colourPower k ℓ d) (stdSuperPair k ℓ)).odd) + (c : {c : MixedColouring k ℓ (d + 1) // ¬ c.IsEven}) : + (colourPowerStep k ℓ d).oddEquiv P c = + Sum.elim (fun p => funTensorFun _ _ P.1 p) + (fun p => funTensorFun _ _ P.2 p) + (Equiv.sumComm _ _ (oddSplitEquiv k ℓ d c)) := by + unfold colourPowerStep + rfl + +/-! ### How `evenSplitEquiv` interacts with swaps -/ + +private theorem tail_of_evenSplitEquiv_inl {d : ℕ} + (c : {c : MixedColouring k ℓ (d + 1) // c.IsEven}) + (c₀ : {c : MixedColouring k ℓ d // c.IsEven}) (α : Fin k) + (heq : evenSplitEquiv k ℓ d c = Sum.inl (c₀, α)) : + MixedColouring.tail c.val = c₀.val := by + have h1 : c = (evenSplitEquiv k ℓ d).symm (Sum.inl (c₀, α)) := by + rw [← heq, Equiv.symm_apply_apply] + ext i + have h2 := congr_arg (fun x => x.val i.castSucc) h1 + simp only [evenSplitEquiv_symm_inl, colouringSplit_symm_castSucc] at h2 + exact h2 + +private theorem last_of_evenSplitEquiv_inl {d : ℕ} + (c : {c : MixedColouring k ℓ (d + 1) // c.IsEven}) + (c₀ : {c : MixedColouring k ℓ d // c.IsEven}) (α : Fin k) + (heq : evenSplitEquiv k ℓ d c = Sum.inl (c₀, α)) : + c.val (Fin.last d) = Sum.inl α := by + have h1 : c = (evenSplitEquiv k ℓ d).symm (Sum.inl (c₀, α)) := by + rw [← heq, Equiv.symm_apply_apply] + have h2 := congr_arg (fun x => x.val (Fin.last d)) h1 + simp only [evenSplitEquiv_symm_inl, colouringSplit_symm_last] at h2 + exact h2 + +private theorem tail_of_evenSplitEquiv_inr {d : ℕ} + (c : {c : MixedColouring k ℓ (d + 1) // c.IsEven}) + (c₀ : {c : MixedColouring k ℓ d // ¬ c.IsEven}) (β : Fin (2 * ℓ)) + (heq : evenSplitEquiv k ℓ d c = Sum.inr (c₀, β)) : + MixedColouring.tail c.val = c₀.val := by + have h1 : c = (evenSplitEquiv k ℓ d).symm (Sum.inr (c₀, β)) := by + rw [← heq, Equiv.symm_apply_apply] + ext i + have h2 := congr_arg (fun x => x.val i.castSucc) h1 + simp only [evenSplitEquiv_symm_inr, colouringSplit_symm_castSucc] at h2 + exact h2 + +private theorem last_of_evenSplitEquiv_inr {d : ℕ} + (c : {c : MixedColouring k ℓ (d + 1) // c.IsEven}) + (c₀ : {c : MixedColouring k ℓ d // ¬ c.IsEven}) (β : Fin (2 * ℓ)) + (heq : evenSplitEquiv k ℓ d c = Sum.inr (c₀, β)) : + c.val (Fin.last d) = Sum.inr β := by + have h1 : c = (evenSplitEquiv k ℓ d).symm (Sum.inr (c₀, β)) := by + rw [← heq, Equiv.symm_apply_apply] + have h2 := congr_arg (fun x => x.val (Fin.last d)) h1 + simp only [evenSplitEquiv_symm_inr, colouringSplit_symm_last] at h2 + exact h2 + +/-- `evenSplitEquiv` applied to a swapped colouring, inl case. -/ +private theorem evenSplitEquiv_swap_inl {n i : ℕ} (h : i + 2 ≤ n + 1) + (c : {c : MixedColouring k ℓ (n + 2) // c.IsEven}) + (c₀ : {c : MixedColouring k ℓ (n + 1) // c.IsEven}) (α : Fin k) + (heq : evenSplitEquiv k ℓ (n + 1) c = Sum.inl (c₀, α)) : + evenSplitEquiv k ℓ (n + 1) + ⟨c.val ∘ Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩, c.prop.comp _⟩ = + Sum.inl (⟨c₀.val ∘ Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩, + c₀.prop.comp _⟩, α) := by + suffices hsuff : (evenSplitEquiv k ℓ (n + 1)).symm + (Sum.inl (⟨c₀.val ∘ Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩, + c₀.prop.comp _⟩, α)) = + ⟨c.val ∘ Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩, c.prop.comp _⟩ by + rw [← hsuff, Equiv.apply_symm_apply] + have htail := tail_of_evenSplitEquiv_inl c c₀ α heq + have hlast := last_of_evenSplitEquiv_inl c c₀ α heq + ext j + simp only [evenSplitEquiv_symm_inl] + refine Fin.lastCases ?_ (fun j' => ?_) j + · simp only [colouringSplit_symm_last, Function.comp_apply, swap_last_eq h, + hlast] + · simp only [colouringSplit_symm_castSucc, Function.comp_apply, + swap_castSucc_eq h] + show c₀.val ((Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩) j') = + c.val (((Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩) j').castSucc) + rw [← htail]; rfl + +/-- `evenSplitEquiv` applied to a swapped colouring, inr case. -/ +private theorem evenSplitEquiv_swap_inr {n i : ℕ} (h : i + 2 ≤ n + 1) + (c : {c : MixedColouring k ℓ (n + 2) // c.IsEven}) + (c₀ : {c : MixedColouring k ℓ (n + 1) // ¬ c.IsEven}) (β : Fin (2 * ℓ)) + (heq : evenSplitEquiv k ℓ (n + 1) c = Sum.inr (c₀, β)) : + evenSplitEquiv k ℓ (n + 1) + ⟨c.val ∘ Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩, c.prop.comp _⟩ = + Sum.inr (⟨c₀.val ∘ Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩, + MixedColouring.not_isEven_comp c₀.prop _⟩, β) := by + suffices hsuff : (evenSplitEquiv k ℓ (n + 1)).symm + (Sum.inr (⟨c₀.val ∘ Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩, + MixedColouring.not_isEven_comp c₀.prop _⟩, β)) = + ⟨c.val ∘ Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩, c.prop.comp _⟩ by + rw [← hsuff, Equiv.apply_symm_apply] + have htail := tail_of_evenSplitEquiv_inr c c₀ β heq + have hlast := last_of_evenSplitEquiv_inr c c₀ β heq + ext j + simp only [evenSplitEquiv_symm_inr] + refine Fin.lastCases ?_ (fun j' => ?_) j + · simp only [colouringSplit_symm_last, Function.comp_apply, swap_last_eq h, + hlast] + · simp only [colouringSplit_symm_castSucc, Function.comp_apply, + swap_castSucc_eq h] + show c₀.val ((Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩) j') = + c.val (((Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩) j').castSucc) + rw [← htail]; rfl + +/-! ### Analogous lemmas for `oddSplitEquiv` -/ + +private theorem tail_of_oddSplitEquiv_inl {d : ℕ} + (c : {c : MixedColouring k ℓ (d + 1) // ¬ c.IsEven}) + (c₀ : {c : MixedColouring k ℓ d // ¬ c.IsEven}) (α : Fin k) + (heq : oddSplitEquiv k ℓ d c = Sum.inl (c₀, α)) : + MixedColouring.tail c.val = c₀.val := by + have h1 : c = (oddSplitEquiv k ℓ d).symm (Sum.inl (c₀, α)) := by + rw [← heq, Equiv.symm_apply_apply] + ext i + have h2 := congr_arg (fun x => x.val i.castSucc) h1 + simp only [oddSplitEquiv_symm_inl, colouringSplit_symm_castSucc] at h2 + exact h2 + +private theorem last_of_oddSplitEquiv_inl {d : ℕ} + (c : {c : MixedColouring k ℓ (d + 1) // ¬ c.IsEven}) + (c₀ : {c : MixedColouring k ℓ d // ¬ c.IsEven}) (α : Fin k) + (heq : oddSplitEquiv k ℓ d c = Sum.inl (c₀, α)) : + c.val (Fin.last d) = Sum.inl α := by + have h1 : c = (oddSplitEquiv k ℓ d).symm (Sum.inl (c₀, α)) := by + rw [← heq, Equiv.symm_apply_apply] + have h2 := congr_arg (fun x => x.val (Fin.last d)) h1 + simp only [oddSplitEquiv_symm_inl, colouringSplit_symm_last] at h2 + exact h2 + +private theorem tail_of_oddSplitEquiv_inr {d : ℕ} + (c : {c : MixedColouring k ℓ (d + 1) // ¬ c.IsEven}) + (c₀ : {c : MixedColouring k ℓ d // c.IsEven}) (β : Fin (2 * ℓ)) + (heq : oddSplitEquiv k ℓ d c = Sum.inr (c₀, β)) : + MixedColouring.tail c.val = c₀.val := by + have h1 : c = (oddSplitEquiv k ℓ d).symm (Sum.inr (c₀, β)) := by + rw [← heq, Equiv.symm_apply_apply] + ext i + have h2 := congr_arg (fun x => x.val i.castSucc) h1 + simp only [oddSplitEquiv_symm_inr, colouringSplit_symm_castSucc] at h2 + exact h2 + +private theorem last_of_oddSplitEquiv_inr {d : ℕ} + (c : {c : MixedColouring k ℓ (d + 1) // ¬ c.IsEven}) + (c₀ : {c : MixedColouring k ℓ d // c.IsEven}) (β : Fin (2 * ℓ)) + (heq : oddSplitEquiv k ℓ d c = Sum.inr (c₀, β)) : + c.val (Fin.last d) = Sum.inr β := by + have h1 : c = (oddSplitEquiv k ℓ d).symm (Sum.inr (c₀, β)) := by + rw [← heq, Equiv.symm_apply_apply] + have h2 := congr_arg (fun x => x.val (Fin.last d)) h1 + simp only [oddSplitEquiv_symm_inr, colouringSplit_symm_last] at h2 + exact h2 + +private theorem oddSplitEquiv_swap_inl {n i : ℕ} (h : i + 2 ≤ n + 1) + (c : {c : MixedColouring k ℓ (n + 2) // ¬ c.IsEven}) + (c₀ : {c : MixedColouring k ℓ (n + 1) // ¬ c.IsEven}) (α : Fin k) + (heq : oddSplitEquiv k ℓ (n + 1) c = Sum.inl (c₀, α)) : + oddSplitEquiv k ℓ (n + 1) + ⟨c.val ∘ Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩, + MixedColouring.not_isEven_comp c.prop _⟩ = + Sum.inl (⟨c₀.val ∘ Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩, + MixedColouring.not_isEven_comp c₀.prop _⟩, α) := by + suffices hsuff : (oddSplitEquiv k ℓ (n + 1)).symm + (Sum.inl (⟨c₀.val ∘ Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩, + MixedColouring.not_isEven_comp c₀.prop _⟩, α)) = + ⟨c.val ∘ Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩, + MixedColouring.not_isEven_comp c.prop _⟩ by + rw [← hsuff, Equiv.apply_symm_apply] + have htail := tail_of_oddSplitEquiv_inl c c₀ α heq + have hlast := last_of_oddSplitEquiv_inl c c₀ α heq + ext j + simp only [oddSplitEquiv_symm_inl] + refine Fin.lastCases ?_ (fun j' => ?_) j + · simp only [colouringSplit_symm_last, Function.comp_apply, swap_last_eq h, + hlast] + · simp only [colouringSplit_symm_castSucc, Function.comp_apply, + swap_castSucc_eq h] + show c₀.val ((Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩) j') = + c.val (((Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩) j').castSucc) + rw [← htail]; rfl + +private theorem oddSplitEquiv_swap_inr {n i : ℕ} (h : i + 2 ≤ n + 1) + (c : {c : MixedColouring k ℓ (n + 2) // ¬ c.IsEven}) + (c₀ : {c : MixedColouring k ℓ (n + 1) // c.IsEven}) (β : Fin (2 * ℓ)) + (heq : oddSplitEquiv k ℓ (n + 1) c = Sum.inr (c₀, β)) : + oddSplitEquiv k ℓ (n + 1) + ⟨c.val ∘ Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩, + MixedColouring.not_isEven_comp c.prop _⟩ = + Sum.inr (⟨c₀.val ∘ Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩, + c₀.prop.comp _⟩, β) := by + suffices hsuff : (oddSplitEquiv k ℓ (n + 1)).symm + (Sum.inr (⟨c₀.val ∘ Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩, + c₀.prop.comp _⟩, β)) = + ⟨c.val ∘ Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩, + MixedColouring.not_isEven_comp c.prop _⟩ by + rw [← hsuff, Equiv.apply_symm_apply] + have htail := tail_of_oddSplitEquiv_inr c c₀ β heq + have hlast := last_of_oddSplitEquiv_inr c c₀ β heq + ext j + simp only [oddSplitEquiv_symm_inr] + refine Fin.lastCases ?_ (fun j' => ?_) j + · simp only [colouringSplit_symm_last, Function.comp_apply, swap_last_eq h, + hlast] + · simp only [colouringSplit_symm_castSucc, Function.comp_apply, + swap_castSucc_eq h] + show c₀.val ((Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩) j') = + c.val (((Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩) j').castSucc) + rw [← htail]; rfl + +/-! ### Main theorem -/ + +-- Both components unfold the step equivalence and +-- the swap at two arities to compare them position by position. +/-- **Extension compatibility of the signed swap**: extending the +adjacent Koszul swap by one position is the adjacent Koszul swap +of the extended power. -/ +theorem colourExtend_colourSwap {k ℓ : ℕ} (n i : ℕ) + (h : i + 2 ≤ n + 1) : + colourExtend (n + 1) (colourSwap k ℓ (n + 1) i h) = + colourSwap k ℓ (n + 2) i (by omega) := by + refine SuperVect.Hom.ext ?_ ?_ + · -- Even component: reduce to step ∘ tensorHom = colourSwap ∘ step + suffices key : ∀ P, + (colourPowerStep k ℓ (n + 1)).evenEquiv + ((SuperVect.tensorHom (colourSwap k ℓ (n + 1) i h) + (SuperVect.Hom.id (stdSuperPair k ℓ)) : + SuperVect.Hom _ _).evenMap P) = + (colourSwap k ℓ (n + 2) i (by omega) : + SuperVect.Hom _ _).evenMap + ((colourPowerStep k ℓ (n + 1)).evenEquiv P) by + ext F + change (colourPowerStep k ℓ (n + 1)).evenEquiv + (((SuperVect.tensorHom (colourSwap k ℓ (n + 1) i h) + (SuperVect.Hom.id (stdSuperPair k ℓ)) : + SuperVect.Hom _ _).evenMap) + ((colourPowerStep k ℓ (n + 1)).evenEquiv.symm F)) = + (colourSwap k ℓ (n + 2) i (by omega) : + SuperVect.Hom _ _).evenMap F + rw [key, (colourPowerStep k ℓ (n + 1)).evenEquiv.apply_symm_apply] + -- Prove key pointwise + intro P + funext ⟨c, hc⟩ + rw [step_tensorHom_even_apply] + change Sum.elim + (fun p => funTensorFun _ _ (TensorProduct.map + (colourSwap k ℓ (n + 1) i h : SuperVect.Hom _ _).evenMap + LinearMap.id P.1) p) + (fun p => funTensorFun _ _ (TensorProduct.map + (colourSwap k ℓ (n + 1) i h : SuperVect.Hom _ _).oddMap + LinearMap.id P.2) p) + (evenSplitEquiv k ℓ (n + 1) ⟨c, hc⟩) = + adjSign c ⟨i, by omega⟩ ⟨i + 1, by omega⟩ * + (colourPowerStep k ℓ (n + 1)).evenEquiv P + ⟨c ∘ Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩, hc.comp _⟩ + rcases heq : evenSplitEquiv k ℓ (n + 1) ⟨c, hc⟩ with ⟨c₀, α⟩ | ⟨c₀, β⟩ + · -- Case inl: last colour even + simp only [Sum.elim_inl] + erw [funTensorFun_map_id + (colourSwap k ℓ (n + 1) i h : SuperVect.Hom _ _).evenMap + P.1 c₀ α, + adjSign_eq_tail c (i := i) h, + tail_of_evenSplitEquiv_inl ⟨c, hc⟩ c₀ α heq, + step_even_apply, + evenSplitEquiv_swap_inl h ⟨c, hc⟩ c₀ α heq, + Sum.elim_inl]; rfl + · -- Case inr: last colour odd + simp only [Sum.elim_inr] + erw [funTensorFun_map_id + (colourSwap k ℓ (n + 1) i h : SuperVect.Hom _ _).oddMap + P.2 c₀ β, + adjSign_eq_tail c (i := i) h, + tail_of_evenSplitEquiv_inr ⟨c, hc⟩ c₀ β heq, + step_even_apply, + evenSplitEquiv_swap_inr h ⟨c, hc⟩ c₀ β heq, + Sum.elim_inr]; rfl + · -- Odd component: analogous + suffices key : ∀ P, + (colourPowerStep k ℓ (n + 1)).oddEquiv + ((SuperVect.tensorHom (colourSwap k ℓ (n + 1) i h) + (SuperVect.Hom.id (stdSuperPair k ℓ)) : + SuperVect.Hom _ _).oddMap P) = + (colourSwap k ℓ (n + 2) i (by omega) : + SuperVect.Hom _ _).oddMap + ((colourPowerStep k ℓ (n + 1)).oddEquiv P) by + ext F + change (colourPowerStep k ℓ (n + 1)).oddEquiv + (((SuperVect.tensorHom (colourSwap k ℓ (n + 1) i h) + (SuperVect.Hom.id (stdSuperPair k ℓ)) : + SuperVect.Hom _ _).oddMap) + ((colourPowerStep k ℓ (n + 1)).oddEquiv.symm F)) = + (colourSwap k ℓ (n + 2) i (by omega) : + SuperVect.Hom _ _).oddMap F + rw [key, (colourPowerStep k ℓ (n + 1)).oddEquiv.apply_symm_apply] + intro P + funext ⟨c, hc⟩ + rw [step_tensorHom_odd_apply] + change Sum.elim + (fun p => funTensorFun _ _ (TensorProduct.map + (colourSwap k ℓ (n + 1) i h : SuperVect.Hom _ _).evenMap + LinearMap.id P.1) p) + (fun p => funTensorFun _ _ (TensorProduct.map + (colourSwap k ℓ (n + 1) i h : SuperVect.Hom _ _).oddMap + LinearMap.id P.2) p) + (Equiv.sumComm _ _ (oddSplitEquiv k ℓ (n + 1) ⟨c, hc⟩)) = + adjSign c ⟨i, by omega⟩ ⟨i + 1, by omega⟩ * + (colourPowerStep k ℓ (n + 1)).oddEquiv P + ⟨c ∘ Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩, + MixedColouring.not_isEven_comp hc _⟩ + rcases heq : oddSplitEquiv k ℓ (n + 1) ⟨c, hc⟩ with ⟨c₀, α⟩ | ⟨c₀, β⟩ + · -- oddSplitEquiv c = inl(c₀, α): c₀ odd, α even colour + simp only [Equiv.sumComm_apply, Sum.swap_inl, Sum.elim_inr] + erw [funTensorFun_map_id + (colourSwap k ℓ (n + 1) i h : SuperVect.Hom _ _).oddMap + P.2 c₀ α, + adjSign_eq_tail c (i := i) h, + tail_of_oddSplitEquiv_inl ⟨c, hc⟩ c₀ α heq, + step_odd_apply, + oddSplitEquiv_swap_inl h ⟨c, hc⟩ c₀ α heq, + Equiv.sumComm_apply, Sum.swap_inl, Sum.elim_inr]; rfl + · -- oddSplitEquiv c = inr(c₀, β): c₀ even, β odd colour + simp only [Equiv.sumComm_apply, Sum.swap_inr, Sum.elim_inl] + erw [funTensorFun_map_id + (colourSwap k ℓ (n + 1) i h : SuperVect.Hom _ _).evenMap + P.1 c₀ β, + adjSign_eq_tail c (i := i) h, + tail_of_oddSplitEquiv_inr ⟨c, hc⟩ c₀ β heq, + step_odd_apply, + oddSplitEquiv_swap_inr h ⟨c, hc⟩ c₀ β heq, + Equiv.sumComm_apply, Sum.swap_inr, Sum.elim_inl]; rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourFormMatch.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourFormMatch.lean new file mode 100644 index 0000000000..fb56550da6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourFormMatch.lean @@ -0,0 +1,69 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairing + +/-! +# The colour form entries are the standard form + +The single-position layer of the accompanying paper's Lemma 5.1(a): +the pinned colour +form entry agrees with the standard super form on the +corresponding basis vectors — the orthonormal pairing on even +colours, the symplectic pairing on odd colours. +-/ + +@[expose] public section + +namespace RS + +/-- On even colours the entry is the orthonormal pairing. -/ +theorem colourFormEntry_even (k ℓ : ℕ) (i j : Fin k) : + colourFormEntry k ℓ (Sum.inl i) (Sum.inl j) = + stdFormEven k (stdE k i) (stdE k j) := by + rw [stdFormEven_stdE] + rfl + +/-- On odd colours it is the symplectic one. -/ +theorem colourFormEntry_odd (k ℓ : ℕ) (a b : Fin (2 * ℓ)) : + colourFormEntry k ℓ (Sum.inr a) (Sum.inr b) = + stdFormOdd ℓ (stdF ℓ a) (stdF ℓ b) := by + rw [stdFormOdd_stdF] + change (if a.val + ℓ = b.val then (1 : ℂ) + else if b.val + ℓ = a.val then -1 else 0) = + if b = oddPartner ℓ a then -(oddPartnerSign ℓ a : ℂ) else 0 + unfold oddPartner oddPartnerSign + by_cases h : a.val < ℓ + · rw [dite_eq_left h, ite_eq_left h] + by_cases hb : a.val + ℓ = b.val + · rw [ite_eq_left hb, + ite_eq_left (show b = ⟨a.val + ℓ, by omega⟩ from + Fin.ext (show b.val = a.val + ℓ by omega))] + norm_num + · rw [ite_eq_right hb, + ite_eq_right (show ¬(b.val + ℓ = a.val) by omega), + ite_eq_right (show ¬(b = ⟨a.val + ℓ, by omega⟩) from + fun he => hb (by + have hv : b.val = a.val + ℓ := congrArg Fin.val he + omega))] + · rw [dite_eq_right h, ite_eq_right h, + ite_eq_right (show ¬(a.val + ℓ = b.val) by + have := b.isLt + omega)] + by_cases hb : b.val + ℓ = a.val + · rw [ite_eq_left hb, + ite_eq_left (show b = ⟨a.val - ℓ, by omega⟩ from + Fin.ext (show b.val = a.val - ℓ by omega))] + norm_num + · rw [ite_eq_right hb, + ite_eq_right (show ¬(b = ⟨a.val - ℓ, by omega⟩) from + fun he => hb (by + have hv : b.val = a.val - ℓ := congrArg Fin.val he + omega))] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMerge.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMerge.lean new file mode 100644 index 0000000000..b9e25b5d0b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMerge.lean @@ -0,0 +1,1215 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PowMerge +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourEval + +/-! +# The merge coordinate product rule + +Coordinates of a merged even pair multiply over the halves, +vanishing when the halves have odd parity. +-/ + +@[expose] public section + +open scoped TensorProduct + +namespace RS + +open CategoryTheory MonoidalCategory + +/-! ### First and second halves of a colouring -/ + +/-- The first half of a colouring of a sum. -/ +def MixedColouring.firstHalf {k ℓ a b : ℕ} + (c : MixedColouring k ℓ (a + b)) : MixedColouring k ℓ a := + fun i => c (Fin.castAdd b i) + +/-- The second half of a colouring of a sum. -/ +def MixedColouring.secondHalf {k ℓ a b : ℕ} + (c : MixedColouring k ℓ (a + b)) : MixedColouring k ℓ b := + fun j => c (Fin.natAdd a j) + +/-- The odd count splits over the halves. -/ +theorem MixedColouring.oddSet_card_split {k ℓ a b : ℕ} + (c : MixedColouring k ℓ (a + b)) : + c.oddSet.card = (MixedColouring.oddSet c.firstHalf).card + + (MixedColouring.oddSet c.secondHalf).card := by + unfold oddSet firstHalf secondHalf + simp only [Finset.card_filter] + exact (Equiv.sum_comp finSumFinEquiv _).symm.trans + (Fintype.sum_sum_type _) + +/-! ### Helper lemmas -/ + +/-- The first half at `b = 0` is the colouring itself. -/ +theorem MixedColouring.firstHalf_zero {k ℓ a : ℕ} + (c : MixedColouring k ℓ (a + 0)) : + c.firstHalf = c := by + funext i; change c (Fin.castAdd 0 i) = c i; congr 1 + +/-- The first half of a tail equals the first half. -/ +theorem MixedColouring.firstHalf_tail {k ℓ a b : ℕ} + (c : MixedColouring k ℓ (a + (b + 1))) : + (MixedColouring.tail c).firstHalf = c.firstHalf := by + funext i + change c (Fin.castAdd b i).castSucc = c (Fin.castAdd (b + 1) i) + congr 1 + +/-- The second half of a tail equals the tail of the second half. -/ +theorem MixedColouring.secondHalf_tail {k ℓ a b : ℕ} + (c : MixedColouring k ℓ (a + (b + 1))) : + (MixedColouring.tail c).secondHalf = + MixedColouring.tail (c.secondHalf) := by + funext j + change c (Fin.natAdd a j).castSucc = c (Fin.natAdd a j.castSucc) + congr 1 + +/-- Parity of the halves is linked when the whole is even. -/ +theorem MixedColouring.isEven_half_iff {k ℓ a b : ℕ} + (c : MixedColouring k ℓ (a + b)) (hc : c.IsEven) : + c.firstHalf.IsEven ↔ c.secondHalf.IsEven := by + unfold IsEven at hc ⊢ + rw [oddSet_card_split] at hc + exact Nat.even_add.mp hc + +/-- When the whole is even and the first half is even, +the second half is even. -/ +theorem MixedColouring.secondHalf_isEven {k ℓ a b : ℕ} + (c : MixedColouring k ℓ (a + b)) (hc : c.IsEven) + (h : c.firstHalf.IsEven) : c.secondHalf.IsEven := + (c.isEven_half_iff hc).mp h + +/-- When the whole is odd and the first half is even, +the second half is odd. -/ +theorem MixedColouring.secondHalf_not_isEven {k ℓ a b : ℕ} + (c : MixedColouring k ℓ (a + b)) (hc : ¬ c.IsEven) + (h : c.firstHalf.IsEven) : ¬ c.secondHalf.IsEven := by + intro hs + unfold IsEven at hc + rw [oddSet_card_split] at hc + exact hc (Nat.even_add.mpr (Iff.intro (fun _ => hs) (fun _ => h))) + +/-- The last colour of `c` equals the last colour of the +second half. -/ +theorem MixedColouring.secondHalf_last {k ℓ a b : ℕ} + (c : MixedColouring k ℓ (a + (b + 1))) : + c.secondHalf (Fin.last b) = c (Fin.last (a + b)) := by + change c (Fin.natAdd a (Fin.last b)) = c (Fin.last (a + b)) + congr 1 + +/-! ### Forward computation of evenSplitEquiv -/ + +/-- Compute `evenSplitEquiv` forward via its inverse, last colour +even. -/ +theorem evenSplitEquiv_inl {k ℓ d : ℕ} + (c : MixedColouring k ℓ (d + 1)) (hc : c.IsEven) + (a' : Fin k) (ha : c (Fin.last d) = Sum.inl a') : + evenSplitEquiv k ℓ d ⟨c, hc⟩ = + Sum.inl (⟨MixedColouring.tail c, + (c.isEven_succ_left a' ha).mp hc⟩, a') := by + have inv : (evenSplitEquiv k ℓ d).symm + (Sum.inl (⟨MixedColouring.tail c, + (c.isEven_succ_left a' ha).mp hc⟩, a')) = ⟨c, hc⟩ := by + apply Subtype.ext; rw [evenSplitEquiv_symm_inl]; funext i + refine Fin.lastCases ?_ (fun j => ?_) i + · exact (colouringSplit_symm_last _ _).trans ha.symm + · exact colouringSplit_symm_castSucc _ _ _ + rw [← inv, Equiv.apply_symm_apply] + +/-- Compute `evenSplitEquiv` forward via its inverse, last colour +odd. -/ +theorem evenSplitEquiv_inr {k ℓ d : ℕ} + (c : MixedColouring k ℓ (d + 1)) (hc : c.IsEven) + (b' : Fin (2 * ℓ)) (hb : c (Fin.last d) = Sum.inr b') : + evenSplitEquiv k ℓ d ⟨c, hc⟩ = + Sum.inr (⟨MixedColouring.tail c, + (c.isEven_succ_right b' hb).mp hc⟩, b') := by + have inv : (evenSplitEquiv k ℓ d).symm + (Sum.inr (⟨MixedColouring.tail c, + (c.isEven_succ_right b' hb).mp hc⟩, b')) = ⟨c, hc⟩ := by + apply Subtype.ext; rw [evenSplitEquiv_symm_inr]; funext i + refine Fin.lastCases ?_ (fun j => ?_) i + · exact (colouringSplit_symm_last _ _).trans hb.symm + · exact colouringSplit_symm_castSucc _ _ _ + rw [← inv, Equiv.apply_symm_apply] + +/-! ### Forward computation of oddSplitEquiv -/ + +/-- Compute `oddSplitEquiv` forward via its inverse, last colour +even. -/ +theorem oddSplitEquiv_inl {k ℓ d : ℕ} + (c : MixedColouring k ℓ (d + 1)) (hc : ¬ c.IsEven) + (a' : Fin k) (ha : c (Fin.last d) = Sum.inl a') : + oddSplitEquiv k ℓ d ⟨c, hc⟩ = + Sum.inl (⟨MixedColouring.tail c, + (c.isEven_succ_left a' ha).not.mp hc⟩, a') := by + have inv : (oddSplitEquiv k ℓ d).symm + (Sum.inl (⟨MixedColouring.tail c, + (c.isEven_succ_left a' ha).not.mp hc⟩, a')) = ⟨c, hc⟩ := by + apply Subtype.ext; rw [oddSplitEquiv_symm_inl]; funext i + refine Fin.lastCases ?_ (fun j => ?_) i + · exact (colouringSplit_symm_last _ _).trans ha.symm + · exact colouringSplit_symm_castSucc _ _ _ + rw [← inv, Equiv.apply_symm_apply] + +/-- Compute `oddSplitEquiv` forward via its inverse, last colour +odd. -/ +theorem oddSplitEquiv_inr {k ℓ d : ℕ} + (c : MixedColouring k ℓ (d + 1)) (hc : ¬ c.IsEven) + (b' : Fin (2 * ℓ)) (hb : c (Fin.last d) = Sum.inr b') : + oddSplitEquiv k ℓ d ⟨c, hc⟩ = + Sum.inr (⟨MixedColouring.tail c, + Decidable.not_not.mp ((c.isEven_succ_right b' hb).not.mp hc)⟩, + b') := by + have inv : (oddSplitEquiv k ℓ d).symm + (Sum.inr (⟨MixedColouring.tail c, + Decidable.not_not.mp ((c.isEven_succ_right b' hb).not.mp hc)⟩, + b')) = ⟨c, hc⟩ := by + apply Subtype.ext; rw [oddSplitEquiv_symm_inr]; funext i + refine Fin.lastCases ?_ (fun j => ?_) i + · exact (colouringSplit_symm_last _ _).trans hb.symm + · exact colouringSplit_symm_castSucc _ _ _ + rw [← inv, Equiv.apply_symm_apply] + +/-! ### ColourPowerStep evaluation -/ + +/-- `colourPowerStep.evenEquiv` at a colouring whose last colour +is even: the value comes from the even-even channel. -/ +theorem cps_even_at_inl {k ℓ d : ℕ} + (z₁ : ({c : MixedColouring k ℓ d // c.IsEven} → ℂ) ⊗[ℂ] + (Fin k → ℂ)) + (z₂ : ({c : MixedColouring k ℓ d // ¬ c.IsEven} → ℂ) ⊗[ℂ] + (Fin (2 * ℓ) → ℂ)) + (c : MixedColouring k ℓ (d + 1)) (hc : c.IsEven) + (a' : Fin k) (ha : c (Fin.last d) = Sum.inl a') : + (colourPowerStep k ℓ d).evenEquiv (z₁, z₂) ⟨c, hc⟩ = + funTensorFun _ _ z₁ + (⟨MixedColouring.tail c, + (c.isEven_succ_left a' ha).mp hc⟩, a') := by + change Sum.elim (fun p => funTensorFun _ _ z₁ p) + (fun q => funTensorFun _ _ z₂ q) + (evenSplitEquiv k ℓ d ⟨c, hc⟩) = _ + simp only [evenSplitEquiv_inl c hc a' ha, Sum.elim_inl] + +/-- `colourPowerStep.evenEquiv` at a colouring whose last colour +is odd: the value comes from the odd-odd channel. -/ +theorem cps_even_at_inr {k ℓ d : ℕ} + (z₁ : ({c : MixedColouring k ℓ d // c.IsEven} → ℂ) ⊗[ℂ] + (Fin k → ℂ)) + (z₂ : ({c : MixedColouring k ℓ d // ¬ c.IsEven} → ℂ) ⊗[ℂ] + (Fin (2 * ℓ) → ℂ)) + (c : MixedColouring k ℓ (d + 1)) (hc : c.IsEven) + (b' : Fin (2 * ℓ)) (hb : c (Fin.last d) = Sum.inr b') : + (colourPowerStep k ℓ d).evenEquiv (z₁, z₂) ⟨c, hc⟩ = + funTensorFun _ _ z₂ + (⟨MixedColouring.tail c, + (c.isEven_succ_right b' hb).mp hc⟩, b') := by + change Sum.elim (fun p => funTensorFun _ _ z₁ p) + (fun q => funTensorFun _ _ z₂ q) + (evenSplitEquiv k ℓ d ⟨c, hc⟩) = _ + simp only [evenSplitEquiv_inr c hc b' hb, Sum.elim_inr] + +/-- `colourPowerStep.oddEquiv` at a colouring whose last colour +is even: the value comes from the odd-even channel. -/ +theorem cps_odd_at_inl {k ℓ d : ℕ} + (z₁ : ({c : MixedColouring k ℓ d // c.IsEven} → ℂ) ⊗[ℂ] + (Fin (2 * ℓ) → ℂ)) + (z₂ : ({c : MixedColouring k ℓ d // ¬ c.IsEven} → ℂ) ⊗[ℂ] + (Fin k → ℂ)) + (c : MixedColouring k ℓ (d + 1)) (hc : ¬ c.IsEven) + (a' : Fin k) (ha : c (Fin.last d) = Sum.inl a') : + (colourPowerStep k ℓ d).oddEquiv (z₁, z₂) ⟨c, hc⟩ = + funTensorFun _ _ z₂ + (⟨MixedColouring.tail c, + (c.isEven_succ_left a' ha).not.mp hc⟩, a') := by + -- cps.oddEquiv = (prodCongr ftf ftf).trans (sumArrow.symm.trans (piCongrLeft' + -- sumComm.trans piCongrLeft' oddSplit.symm)) + -- At oddSplit(c,hc) = inl(⟨tail c, ¬ tail.IsEven⟩, a'): + -- piCongrLeft' oddSplit.symm precomposes with oddSplit, giving oddSplit(c,hc) + -- = inl(...) + -- piCongrLeft' sumComm precomposes with sumComm, so inl -> inr via + -- sumComm.symm + -- Wait no. piCongrLeft' is PRECOMPOSITION. + -- Let f = piCongrLeft' oddSplit.symm, g = piCongrLeft' sumComm. + -- Then (g.trans f) sends φ to φ ∘ oddSplit.symm ∘ sumComm.symm. + -- No: (f.trans g)(x) = g(f(x)). + -- f(x) = x ∘ sumComm.symm + -- g(y) = y ∘ oddSplit.symm + -- So (sumArrow.symm.trans f.trans g)(x) at ⟨c,hc⟩ = (sumArrow.symm x) ∘ + -- sumComm.symm ∘ oddSplit.symm at ⟨c,hc⟩ + -- Wait, let me look at the definition more carefully. + -- The oddEquiv definition is: + -- (prodCongr ftf_eo ftf_oe).trans + -- (sumArrow.symm.trans ((piCongrLeft' sumComm).trans (piCongrLeft' + -- oddSplit.symm))) + -- So for input (z₁, z₂): + -- Step 1: prodCongr ftf_eo ftf_oe (z₁, z₂) = (ftf z₁, ftf z₂) + -- Step 2: sumArrow.symm (ftf z₁, ftf z₂) = Sum.elim (ftf z₁) (ftf z₂) + -- Step 3: piCongrLeft' sumComm: precompose with sumComm.symm + -- At Sum.inl(c₀_odd, a'): sumComm.symm(Sum.inl x) = Sum.inr x + -- so the value is Sum.elim (ftf z₁) (ftf z₂) (Sum.inr(c₀_odd, a')) + -- = ftf z₂ (c₀_odd, a') + -- At Sum.inr(c₀_even, b'): sumComm.symm(Sum.inr x) = Sum.inl x + -- so the value is ftf z₁ (c₀_even, b') + -- Step 4: piCongrLeft' oddSplit.symm: precompose with oddSplit + -- At ⟨c, hc⟩: oddSplit(⟨c, hc⟩) = Sum.inl(⟨tail c, ¬ tail.IsEven⟩, a') + -- so the value from Step 3 is ftf z₂ (⟨tail c, ht⟩, a') + change (Sum.elim (funTensorFun _ _ z₁) (funTensorFun _ _ z₂)) + ((Equiv.sumComm _ _).symm + (oddSplitEquiv k ℓ d ⟨c, hc⟩)) = _ + simp only [oddSplitEquiv_inl c hc a' ha, Equiv.sumComm_symm, + Equiv.sumComm_apply, Sum.swap_inl, Sum.elim_inr] + +/-- `colourPowerStep.oddEquiv` at a colouring whose last colour +is odd: the value comes from the even-odd channel. -/ +theorem cps_odd_at_inr {k ℓ d : ℕ} + (z₁ : ({c : MixedColouring k ℓ d // c.IsEven} → ℂ) ⊗[ℂ] + (Fin (2 * ℓ) → ℂ)) + (z₂ : ({c : MixedColouring k ℓ d // ¬ c.IsEven} → ℂ) ⊗[ℂ] + (Fin k → ℂ)) + (c : MixedColouring k ℓ (d + 1)) (hc : ¬ c.IsEven) + (b' : Fin (2 * ℓ)) (hb : c (Fin.last d) = Sum.inr b') : + (colourPowerStep k ℓ d).oddEquiv (z₁, z₂) ⟨c, hc⟩ = + funTensorFun _ _ z₁ + (⟨MixedColouring.tail c, + Decidable.not_not.mp + ((c.isEven_succ_right b' hb).not.mp hc)⟩, b') := by + change (Sum.elim (funTensorFun _ _ z₁) (funTensorFun _ _ z₂)) + ((Equiv.sumComm _ _).symm + (oddSplitEquiv k ℓ d ⟨c, hc⟩)) = _ + simp only [oddSplitEquiv_inr c hc b' hb, Equiv.sumComm_symm, + Equiv.sumComm_apply, Sum.swap_inr, Sum.elim_inl] + +/-! ### Chain computation helpers -/ + +/-- The associator inverse on a pure ee tensor. -/ +private theorem assoc_inv_ee_tmul {k ℓ a b : ℕ} + (v : (superPow (stdSuperPair k ℓ) a).even) + (w₁ : (superPow (stdSuperPair k ℓ) b).even) + (x₁ : (stdSuperPair k ℓ).even) : + (((α_ (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).inv : SuperVect.Hom _ _).evenMap + (evenPair v ((w₁ ⊗ₜ[ℂ] x₁, + (0 : (superPow (stdSuperPair k ℓ) b).odd ⊗[ℂ] (stdSuperPair k ℓ).odd)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even))) + = + (((evenPair v w₁) ⊗ₜ[ℂ] x₁, + (0 : ((SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).odd ⊗[ℂ] (stdSuperPair k ℓ).odd))) : + (SuperVect.tensorObj (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)) (stdSuperPair k ℓ)).even) := by + change (SuperVect.assocAux _ _ _ _ _ _).symm + ((v ⊗ₜ[ℂ] ((w₁ ⊗ₜ[ℂ] x₁, (0 : _)) : _), (0 : _)) : _) = _ + exact SuperVect.assocAux_symm_ee v w₁ x₁ + +/-- The associator inverse on a pure eo tensor. -/ +private theorem assoc_inv_eo_tmul {k ℓ a b : ℕ} + (v : (superPow (stdSuperPair k ℓ) a).even) + (w₂ : (superPow (stdSuperPair k ℓ) b).odd) + (x₂ : (stdSuperPair k ℓ).odd) : + (((α_ (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).inv : SuperVect.Hom _ _).evenMap + (evenPair v (((0 : (superPow (stdSuperPair k ℓ) b).even ⊗[ℂ] + (stdSuperPair k ℓ).even), w₂ ⊗ₜ[ℂ] x₂) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even))) + = + (((0 : (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).even ⊗[ℂ] (stdSuperPair k ℓ).even), + ((v ⊗ₜ[ℂ] w₂, (0 : (superPow (stdSuperPair k ℓ) a).odd ⊗[ℂ] + (superPow (stdSuperPair k ℓ) b).even)) ⊗ₜ[ℂ] x₂)) : + (SuperVect.tensorObj (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)) (stdSuperPair k ℓ)).even) := by + change (SuperVect.assocAux _ _ _ _ _ _).symm + ((v ⊗ₜ[ℂ] (((0 : _), w₂ ⊗ₜ[ℂ] x₂) : _), (0 : _)) : _) = _ + exact SuperVect.assocAux_symm_eo v w₂ x₂ + +/-- The associator inverse oddMap on a pure eo tensor. -/ +private theorem assoc_inv_odd_eo_tmul {k ℓ a b : ℕ} + (v : (superPow (stdSuperPair k ℓ) a).even) + (w₂ : (superPow (stdSuperPair k ℓ) b).even) + (x₂ : (stdSuperPair k ℓ).odd) : + (((α_ (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).inv : SuperVect.Hom _ _).oddMap + ((v ⊗ₜ[ℂ] ((w₂ ⊗ₜ[ℂ] x₂, + (0 : (superPow (stdSuperPair k ℓ) b).odd ⊗[ℂ] + (stdSuperPair k ℓ).even)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd), + (0 : (superPow (stdSuperPair k ℓ) a).odd ⊗[ℂ] + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even)) + : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ))).odd)) + = + (((evenPair v w₂) ⊗ₜ[ℂ] x₂, + (0 : (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).odd ⊗[ℂ] (stdSuperPair k ℓ).even)) : + (SuperVect.tensorObj (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)) (stdSuperPair k ℓ)).odd) := by + change (SuperVect.assocAux _ _ _ _ _ _).symm + ((v ⊗ₜ[ℂ] ((w₂ ⊗ₜ[ℂ] x₂, (0 : _)) : _), (0 : _)) : _) = _ + exact SuperVect.assocAux_symm_ee v w₂ x₂ + +/-- The associator inverse oddMap on a pure oe tensor. -/ +private theorem assoc_inv_odd_oe_tmul {k ℓ a b : ℕ} + (v : (superPow (stdSuperPair k ℓ) a).even) + (w₁ : (superPow (stdSuperPair k ℓ) b).odd) + (x₁ : (stdSuperPair k ℓ).even) : + (((α_ (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).inv : SuperVect.Hom _ _).oddMap + ((v ⊗ₜ[ℂ] (((0 : (superPow (stdSuperPair k ℓ) b).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), w₁ ⊗ₜ[ℂ] x₁) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd), + (0 : (superPow (stdSuperPair k ℓ) a).odd ⊗[ℂ] + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even)) + : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ))).odd)) + = + (((0 : (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).even ⊗[ℂ] (stdSuperPair k ℓ).odd), + ((v ⊗ₜ[ℂ] w₁, (0 : (superPow (stdSuperPair k ℓ) a).odd ⊗[ℂ] + (superPow (stdSuperPair k ℓ) b).even)) ⊗ₜ[ℂ] x₁)) : + (SuperVect.tensorObj (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)) (stdSuperPair k ℓ)).odd) := by + change (SuperVect.assocAux _ _ _ _ _ _).symm + ((v ⊗ₜ[ℂ] (((0 : _), w₁ ⊗ₜ[ℂ] x₁) : _), (0 : _)) : _) = _ + exact SuperVect.assocAux_symm_eo v w₁ x₁ + +/-! ### Full chain reduction on pure tensor generators -/ + +-- The merge, the colouring equivalence at arity +-- `a + (b+1)` and the tensor step all unfold on a single pure +-- tensor; four such chains, one per parity pattern. +/-- The full chain on a pure ee tensor: the LHS of the inductive +step reduces to `cps` applied to the IH tensor. -/ +private theorem chain_even_ee {k ℓ a b : ℕ} + (v : (superPow (stdSuperPair k ℓ) a).even) + (w₁ : (superPow (stdSuperPair k ℓ) b).even) + (x₁ : (stdSuperPair k ℓ).even) : + (colourPowerEquiv k ℓ (a + (b + 1))).evenEquiv + (((powMerge (stdSuperPair k ℓ) a (b + 1) : + SuperVect.Hom _ _).evenMap + (evenPair v ((w₁ ⊗ₜ[ℂ] x₁, + (0 : (superPow (stdSuperPair k ℓ) b).odd ⊗[ℂ] + (stdSuperPair k ℓ).odd)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even)))) = + (colourPowerStep k ℓ (a + b)).evenEquiv + (((colourPowerEquiv k ℓ (a + b)).evenEquiv + (((powMerge (stdSuperPair k ℓ) a b : + SuperVect.Hom _ _).evenMap + (evenPair v w₁))) ⊗ₜ[ℂ] x₁, + (0 : ({c : MixedColouring k ℓ (a + b) // ¬ c.IsEven} → ℂ) + ⊗[ℂ] (Fin (2 * ℓ) → ℂ)))) := by + -- Unfold cpe(a+(b+1)) = cps ∘ tc and pm(a,b+1) = (pm ▷ V) ∘ α⁻¹ + change (colourPowerStep k ℓ (a + b)).evenEquiv + ((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ (a + b)) + (SuperLinearEquiv.refl (stdSuperPair k ℓ))).evenEquiv + ((powMerge (stdSuperPair k ℓ) a b ▷ stdSuperPair k ℓ : + SuperVect.Hom _ _).evenMap + (((α_ (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).inv : SuperVect.Hom _ _).evenMap + (evenPair v ((w₁ ⊗ₜ[ℂ] x₁, (0 : _)) : _))))) = _ + refine congr_arg (colourPowerStep k ℓ (a + b)).evenEquiv ?_ + rw [assoc_inv_ee_tmul v w₁ x₁] + have hid_e : (SuperVect.Hom.id (stdSuperPair k ℓ)).evenMap = + LinearMap.id := rfl + simp only [MonoidalCategoryStruct.whiskerRight, + SuperVect.tensorHom_evenMap, hid_e] + change LinearEquiv.prodCongr + (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).evenEquiv + (LinearEquiv.refl ℂ _)) + (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).oddEquiv + (LinearEquiv.refl ℂ _)) + (((powMerge (stdSuperPair k ℓ) a b : SuperVect.Hom _ _).evenMap + (evenPair v w₁) ⊗ₜ[ℂ] x₁, (0 : _))) = _ + simp only [LinearEquiv.prodCongr_apply, TensorProduct.congr_tmul, + LinearEquiv.refl_apply, map_zero] + rfl + +-- As for the ee generator, with the odd second factor. +/-- The full chain on a pure eo tensor: the LHS reduces to `cps` +applied to the odd-IH tensor. -/ +private theorem chain_even_eo {k ℓ a b : ℕ} + (v : (superPow (stdSuperPair k ℓ) a).even) + (w₂ : (superPow (stdSuperPair k ℓ) b).odd) + (x₂ : (stdSuperPair k ℓ).odd) : + (colourPowerEquiv k ℓ (a + (b + 1))).evenEquiv + (((powMerge (stdSuperPair k ℓ) a (b + 1) : + SuperVect.Hom _ _).evenMap + (evenPair v (((0 : (superPow (stdSuperPair k ℓ) b).even ⊗[ℂ] + (stdSuperPair k ℓ).even), + w₂ ⊗ₜ[ℂ] x₂) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even)))) = + (colourPowerStep k ℓ (a + b)).evenEquiv + (((0 : ({c : MixedColouring k ℓ (a + b) // c.IsEven} → ℂ) + ⊗[ℂ] (Fin k → ℂ)), + (colourPowerEquiv k ℓ (a + b)).oddEquiv + (((powMerge (stdSuperPair k ℓ) a b : + SuperVect.Hom _ _).oddMap + ((v ⊗ₜ[ℂ] w₂, + (0 : (superPow (stdSuperPair k ℓ) a).odd ⊗[ℂ] + (superPow (stdSuperPair k ℓ) b).even)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).odd)) + ) ⊗ₜ[ℂ] x₂)) := by + -- Unfold cpe(a+(b+1)) = cps ∘ tc and pm(a,b+1) = (pm ▷ V) ∘ α⁻¹ + change (colourPowerStep k ℓ (a + b)).evenEquiv + ((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ (a + b)) + (SuperLinearEquiv.refl (stdSuperPair k ℓ))).evenEquiv + ((powMerge (stdSuperPair k ℓ) a b ▷ stdSuperPair k ℓ : + SuperVect.Hom _ _).evenMap + (((α_ (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).inv : SuperVect.Hom _ _).evenMap + (evenPair v (((0 : _), w₂ ⊗ₜ[ℂ] x₂) : _))))) = _ + refine congr_arg (colourPowerStep k ℓ (a + b)).evenEquiv ?_ + rw [assoc_inv_eo_tmul v w₂ x₂] + have hid_o : (SuperVect.Hom.id (stdSuperPair k ℓ)).oddMap = + LinearMap.id := rfl + simp only [MonoidalCategoryStruct.whiskerRight, + SuperVect.tensorHom_evenMap, hid_o] + change LinearEquiv.prodCongr + (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).evenEquiv + (LinearEquiv.refl ℂ _)) + (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).oddEquiv + (LinearEquiv.refl ℂ _)) + (((0 : _), + ((powMerge (stdSuperPair k ℓ) a b : SuperVect.Hom _ _).oddMap + ((v ⊗ₜ[ℂ] w₂, (0 : _)) : _)) ⊗ₜ[ℂ] x₂)) = _ + simp only [LinearEquiv.prodCongr_apply, TensorProduct.congr_tmul, + LinearEquiv.refl_apply, map_zero] + rfl + +/-- The RHS chain on a pure ee tensor: `cpe(b+1)` on `(t ⊗ₜ x, 0)` +reduces to `cps` applied to the transported tensor. -/ +theorem rhs_even_ee {k ℓ b : ℕ} + (w₁ : (superPow (stdSuperPair k ℓ) b).even) + (x₁ : (stdSuperPair k ℓ).even) : + (colourPowerEquiv k ℓ (b + 1)).evenEquiv + ((w₁ ⊗ₜ[ℂ] x₁, + (0 : (superPow (stdSuperPair k ℓ) b).odd ⊗[ℂ] + (stdSuperPair k ℓ).odd)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even) = + (colourPowerStep k ℓ b).evenEquiv + (((colourPowerEquiv k ℓ b).evenEquiv w₁ ⊗ₜ[ℂ] x₁, + (0 : ({c : MixedColouring k ℓ b // ¬ c.IsEven} → ℂ) + ⊗[ℂ] (Fin (2 * ℓ) → ℂ)))) := by + change (colourPowerStep k ℓ b).evenEquiv + (LinearEquiv.prodCongr + (TensorProduct.congr (colourPowerEquiv k ℓ b).evenEquiv + (LinearEquiv.refl ℂ _)) + (TensorProduct.congr (colourPowerEquiv k ℓ b).oddEquiv + (LinearEquiv.refl ℂ _)) + ((w₁ ⊗ₜ[ℂ] x₁, (0 : _)))) = _ + refine congr_arg (colourPowerStep k ℓ b).evenEquiv ?_ + simp only [LinearEquiv.prodCongr_apply, TensorProduct.congr_tmul, + LinearEquiv.refl_apply, map_zero] + rfl + +/-- The RHS chain on a pure oo tensor: `cpe(b+1)` on `(0, s ⊗ₜ x)` +reduces to `cps` applied to the transported tensor. -/ +theorem rhs_even_oo {k ℓ b : ℕ} + (w₂ : (superPow (stdSuperPair k ℓ) b).odd) + (x₂ : (stdSuperPair k ℓ).odd) : + (colourPowerEquiv k ℓ (b + 1)).evenEquiv + (((0 : (superPow (stdSuperPair k ℓ) b).even ⊗[ℂ] + (stdSuperPair k ℓ).even), + w₂ ⊗ₜ[ℂ] x₂) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even) = + (colourPowerStep k ℓ b).evenEquiv + (((0 : ({c : MixedColouring k ℓ b // c.IsEven} → ℂ) + ⊗[ℂ] (Fin k → ℂ)), + (colourPowerEquiv k ℓ b).oddEquiv w₂ ⊗ₜ[ℂ] x₂)) := by + change (colourPowerStep k ℓ b).evenEquiv + (LinearEquiv.prodCongr + (TensorProduct.congr (colourPowerEquiv k ℓ b).evenEquiv + (LinearEquiv.refl ℂ _)) + (TensorProduct.congr (colourPowerEquiv k ℓ b).oddEquiv + (LinearEquiv.refl ℂ _)) + (((0 : _), w₂ ⊗ₜ[ℂ] x₂))) = _ + refine congr_arg (colourPowerStep k ℓ b).evenEquiv ?_ + simp only [LinearEquiv.prodCongr_apply, TensorProduct.congr_tmul, + LinearEquiv.refl_apply, map_zero] + rfl + +-- As for the even chains, on the odd component. +/-- Full chain (odd, eo generator): the LHS on a pure `(t ⊗ x, 0)` odd tensor +reduces to `cps ∘ cpe ∘ powMerge` on the even pair. -/ +private theorem chain_odd_eo {k ℓ a b : ℕ} + (v : (superPow (stdSuperPair k ℓ) a).even) + (w₂ : (superPow (stdSuperPair k ℓ) b).even) + (x₂ : (stdSuperPair k ℓ).odd) : + (colourPowerEquiv k ℓ (a + (b + 1))).oddEquiv + (((powMerge (stdSuperPair k ℓ) a (b + 1) : + SuperVect.Hom _ _).oddMap + ((v ⊗ₜ[ℂ] ((w₂ ⊗ₜ[ℂ] x₂, + (0 : (superPow (stdSuperPair k ℓ) b).odd ⊗[ℂ] + (stdSuperPair k ℓ).even)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd), + (0 : (superPow (stdSuperPair k ℓ) a).odd ⊗[ℂ] + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) (b + 1))).odd))) = + (colourPowerStep k ℓ (a + b)).oddEquiv + (((colourPowerEquiv k ℓ (a + b)).evenEquiv + (((powMerge (stdSuperPair k ℓ) a b : + SuperVect.Hom _ _).evenMap + (evenPair v w₂))) ⊗ₜ[ℂ] x₂, + (0 : ({c : MixedColouring k ℓ (a + b) // ¬ c.IsEven} → ℂ) + ⊗[ℂ] (Fin k → ℂ)))) := by + change (colourPowerStep k ℓ (a + b)).oddEquiv + ((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ (a + b)) + (SuperLinearEquiv.refl (stdSuperPair k ℓ))).oddEquiv + ((powMerge (stdSuperPair k ℓ) a b ▷ stdSuperPair k ℓ : + SuperVect.Hom _ _).oddMap + (((α_ (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).inv : SuperVect.Hom _ _).oddMap + ((v ⊗ₜ[ℂ] ((w₂ ⊗ₜ[ℂ] x₂, + (0 : (superPow (stdSuperPair k ℓ) b).odd ⊗[ℂ] + (stdSuperPair k ℓ).even)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd), + (0 : (superPow (stdSuperPair k ℓ) a).odd ⊗[ℂ] + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ))).odd)))) = _ + refine congr_arg (colourPowerStep k ℓ (a + b)).oddEquiv ?_ + erw [assoc_inv_odd_eo_tmul v w₂ x₂] + have hid_o : (SuperVect.Hom.id (stdSuperPair k ℓ)).oddMap = + LinearMap.id := rfl + have hid_e : (SuperVect.Hom.id (stdSuperPair k ℓ)).evenMap = + LinearMap.id := rfl + simp only [MonoidalCategoryStruct.whiskerRight, + SuperVect.tensorHom_oddMap, hid_o, hid_e] + change LinearEquiv.prodCongr + (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).evenEquiv + (LinearEquiv.refl ℂ _)) + (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).oddEquiv + (LinearEquiv.refl ℂ _)) + (((powMerge (stdSuperPair k ℓ) a b : SuperVect.Hom _ _).evenMap + (evenPair v w₂) ⊗ₜ[ℂ] x₂, (0 : _))) = _ + simp only [LinearEquiv.prodCongr_apply, TensorProduct.congr_tmul, + LinearEquiv.refl_apply, map_zero] + rfl + +-- As for the even chains, on the odd component. +/-- Full chain (odd, oe generator): the LHS on a pure `(0, s ⊗ x)` odd tensor +reduces to `cps ∘ cpe ∘ powMerge` on the odd pair. -/ +private theorem chain_odd_oe {k ℓ a b : ℕ} + (v : (superPow (stdSuperPair k ℓ) a).even) + (w₁ : (superPow (stdSuperPair k ℓ) b).odd) + (x₁ : (stdSuperPair k ℓ).even) : + (colourPowerEquiv k ℓ (a + (b + 1))).oddEquiv + (((powMerge (stdSuperPair k ℓ) a (b + 1) : + SuperVect.Hom _ _).oddMap + ((v ⊗ₜ[ℂ] (((0 : (superPow (stdSuperPair k ℓ) b).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), + w₁ ⊗ₜ[ℂ] x₁) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd), + (0 : (superPow (stdSuperPair k ℓ) a).odd ⊗[ℂ] + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) (b + 1))).odd))) = + (colourPowerStep k ℓ (a + b)).oddEquiv + (((0 : ({c : MixedColouring k ℓ (a + b) // c.IsEven} → ℂ) + ⊗[ℂ] (Fin (2 * ℓ) → ℂ)), + (colourPowerEquiv k ℓ (a + b)).oddEquiv + (((powMerge (stdSuperPair k ℓ) a b : + SuperVect.Hom _ _).oddMap + ((v ⊗ₜ[ℂ] w₁, + (0 : (superPow (stdSuperPair k ℓ) a).odd ⊗[ℂ] + (superPow (stdSuperPair k ℓ) b).even)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).odd))) + ⊗ₜ[ℂ] x₁)) := by + change (colourPowerStep k ℓ (a + b)).oddEquiv + ((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ (a + b)) + (SuperLinearEquiv.refl (stdSuperPair k ℓ))).oddEquiv + ((powMerge (stdSuperPair k ℓ) a b ▷ stdSuperPair k ℓ : + SuperVect.Hom _ _).oddMap + (((α_ (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).inv : SuperVect.Hom _ _).oddMap + ((v ⊗ₜ[ℂ] (((0 : (superPow (stdSuperPair k ℓ) b).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), + w₁ ⊗ₜ[ℂ] x₁) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd), + (0 : (superPow (stdSuperPair k ℓ) a).odd ⊗[ℂ] + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ))).odd)))) = _ + refine congr_arg (colourPowerStep k ℓ (a + b)).oddEquiv ?_ + erw [assoc_inv_odd_oe_tmul v w₁ x₁] + have hid_o : (SuperVect.Hom.id (stdSuperPair k ℓ)).oddMap = + LinearMap.id := rfl + have hid_e : (SuperVect.Hom.id (stdSuperPair k ℓ)).evenMap = + LinearMap.id := rfl + simp only [MonoidalCategoryStruct.whiskerRight, + SuperVect.tensorHom_oddMap, hid_o, hid_e] + change LinearEquiv.prodCongr + (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).evenEquiv + (LinearEquiv.refl ℂ _)) + (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).oddEquiv + (LinearEquiv.refl ℂ _)) + (((0 : _), + ((powMerge (stdSuperPair k ℓ) a b : SuperVect.Hom _ _).oddMap + ((v ⊗ₜ[ℂ] w₁, (0 : _)) : _)) ⊗ₜ[ℂ] x₁)) = _ + simp only [LinearEquiv.prodCongr_apply, TensorProduct.congr_tmul, + LinearEquiv.refl_apply, map_zero] + rfl + +/-- The RHS chain on a pure eo tensor (odd part): `cpe(b+1)` on +`(t ⊗ₜ x, 0)` reduces to `cps` applied to the transported tensor. -/ +theorem rhs_odd_eo {k ℓ b : ℕ} + (w₂ : (superPow (stdSuperPair k ℓ) b).even) + (x₂ : (stdSuperPair k ℓ).odd) : + (colourPowerEquiv k ℓ (b + 1)).oddEquiv + ((w₂ ⊗ₜ[ℂ] x₂, + (0 : (superPow (stdSuperPair k ℓ) b).odd ⊗[ℂ] + (stdSuperPair k ℓ).even)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd) = + (colourPowerStep k ℓ b).oddEquiv + (((colourPowerEquiv k ℓ b).evenEquiv w₂ ⊗ₜ[ℂ] x₂, + (0 : ({c : MixedColouring k ℓ b // ¬ c.IsEven} → ℂ) + ⊗[ℂ] (Fin k → ℂ)))) := by + change (colourPowerStep k ℓ b).oddEquiv + (LinearEquiv.prodCongr + (TensorProduct.congr (colourPowerEquiv k ℓ b).evenEquiv + (LinearEquiv.refl ℂ _)) + (TensorProduct.congr (colourPowerEquiv k ℓ b).oddEquiv + (LinearEquiv.refl ℂ _)) + ((w₂ ⊗ₜ[ℂ] x₂, (0 : _)))) = _ + refine congr_arg (colourPowerStep k ℓ b).oddEquiv ?_ + simp only [LinearEquiv.prodCongr_apply, TensorProduct.congr_tmul, + LinearEquiv.refl_apply, map_zero] + rfl + +/-- The RHS chain on a pure oe tensor (odd part): `cpe(b+1)` on +`(0, s ⊗ₜ x)` reduces to `cps` applied to the transported tensor. -/ +theorem rhs_odd_oe {k ℓ b : ℕ} + (w₁ : (superPow (stdSuperPair k ℓ) b).odd) + (x₁ : (stdSuperPair k ℓ).even) : + (colourPowerEquiv k ℓ (b + 1)).oddEquiv + (((0 : (superPow (stdSuperPair k ℓ) b).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), + w₁ ⊗ₜ[ℂ] x₁) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd) = + (colourPowerStep k ℓ b).oddEquiv + (((0 : ({c : MixedColouring k ℓ b // c.IsEven} → ℂ) + ⊗[ℂ] (Fin (2 * ℓ) → ℂ)), + (colourPowerEquiv k ℓ b).oddEquiv w₁ ⊗ₜ[ℂ] x₁)) := by + change (colourPowerStep k ℓ b).oddEquiv + (LinearEquiv.prodCongr + (TensorProduct.congr (colourPowerEquiv k ℓ b).evenEquiv + (LinearEquiv.refl ℂ _)) + (TensorProduct.congr (colourPowerEquiv k ℓ b).oddEquiv + (LinearEquiv.refl ℂ _)) + (((0 : _), w₁ ⊗ₜ[ℂ] x₁))) = _ + refine congr_arg (colourPowerStep k ℓ b).oddEquiv ?_ + simp only [LinearEquiv.prodCongr_apply, TensorProduct.congr_tmul, + LinearEquiv.refl_apply, map_zero] + rfl + +/-! ### The merge coordinate product rule -/ + +-- The even and odd coordinate formulas are proved +-- by one mutual induction, so both statements and all four chain +-- lemmas are elaborated in a single declaration. +private theorem colourMerge_pair_even_step {k ℓ : ℕ} (a : ℕ) + (v : (superPow (stdSuperPair k ℓ) a).even) (b : ℕ) + (ih_even : ∀ (w : (superPow (stdSuperPair k ℓ) b).even) + (c : MixedColouring k ℓ (a + b)) (hc : c.IsEven), + (colourPowerEquiv k ℓ (a + b)).evenEquiv + (((powMerge (stdSuperPair k ℓ) a b) : + SuperVect.Hom _ _).evenMap (evenPair v w)) ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then + (colourPowerEquiv k ℓ a).evenEquiv v ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ b).evenEquiv w ⟨c.secondHalf, + c.secondHalf_isEven hc h⟩ + else 0) + (ih_odd : ∀ (u : (superPow (stdSuperPair k ℓ) b).odd) + (c : MixedColouring k ℓ (a + b)) (hc : ¬ c.IsEven), + (colourPowerEquiv k ℓ (a + b)).oddEquiv + (((powMerge (stdSuperPair k ℓ) a b) : + SuperVect.Hom _ _).oddMap + ((v ⊗ₜ[ℂ] u, 0) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).odd)) + ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then + (colourPowerEquiv k ℓ a).evenEquiv v ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ b).oddEquiv u ⟨c.secondHalf, + c.secondHalf_not_isEven hc h⟩ + else 0) : + ∀ (w : (superPow (stdSuperPair k ℓ) (b + 1)).even) + (c : MixedColouring k ℓ (a + (b + 1))) (hc : c.IsEven), + (colourPowerEquiv k ℓ (a + (b + 1))).evenEquiv + (((powMerge (stdSuperPair k ℓ) a (b + 1)) : + SuperVect.Hom _ _).evenMap (evenPair v w)) ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then + (colourPowerEquiv k ℓ a).evenEquiv v ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ (b + 1)).evenEquiv w ⟨c.secondHalf, + c.secondHalf_isEven hc h⟩ + else 0 := by + intro w c hc + obtain ⟨w_ee, w_oo⟩ := w + -- Both sides are additive in w; decompose and reduce to generators. + -- Helper: evenPair distributes over addition + have ep_add : ∀ (w₁ w₂ : (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).even), + evenPair v (w₁ + w₂) = evenPair v w₁ + evenPair v w₂ := + fun w₁ w₂ => Prod.ext (TensorProduct.tmul_add v w₁ w₂) + (add_zero 0).symm + -- Helper for zero pair + have ep_zero : evenPair v (0 : (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).even) = (0 : _) := + Prod.ext (TensorProduct.tmul_zero _ v) rfl + -- Abbreviate the goal predicate for w + set Goal := fun (w : (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).even) => + (colourPowerEquiv k ℓ (a + (b + 1))).evenEquiv + (((powMerge (stdSuperPair k ℓ) a (b + 1) : + SuperVect.Hom _ _).evenMap (evenPair v w))) ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then + (colourPowerEquiv k ℓ a).evenEquiv v ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ (b + 1)).evenEquiv w ⟨c.secondHalf, + c.secondHalf_isEven hc h⟩ + else 0 with hGoal + change Goal (w_ee, w_oo) + -- Additivity: Goal(w₁ + w₂) follows from Goal(w₁) and Goal(w₂) + have Goal_add : ∀ (w₁ w₂ : _), Goal w₁ → Goal w₂ → Goal (w₁ + w₂) := by + intro w₁ w₂ h₁ h₂ + simp only [hGoal] at h₁ h₂ ⊢ + erw [ep_add w₁ w₂, map_add, LinearEquiv.map_add, Pi.add_apply, h₁, h₂] + split_ifs with h + · erw [← mul_add]; congr 1 + erw [LinearEquiv.map_add, Pi.add_apply] + · exact add_zero 0 + -- Prove for (t, 0) by TensorProduct.induction_on + have h_ee : ∀ t, Goal (t, (0 : (superPow (stdSuperPair k ℓ) b).odd ⊗[ℂ] + (stdSuperPair k ℓ).odd)) := by + intro t; induction t using TensorProduct.inductionOn with + | tmul w₁ x₁ => + simp only [hGoal] + -- Case split on the last colour of c + rcases hcl : c (Fin.last (a + b)) with a' | b' + · -- Last colour even: chain + cps_even_at_inl on LHS + erw [(congr_fun (chain_even_ee v w₁ x₁) ⟨c, hc⟩).trans + (cps_even_at_inl _ _ c hc a' hcl), funTensorFun_tmul] + have hcl_sh : c.secondHalf (Fin.last b) = Sum.inl a' := + c.secondHalf_last.symm ▸ hcl + erw [ih_even w₁ (MixedColouring.tail c) + ((c.isEven_succ_left a' hcl).mp hc)] + simp only [MixedColouring.firstHalf_tail, + MixedColouring.secondHalf_tail] + split_ifs with h + · -- c.firstHalf.IsEven: chain + cps_even_at_inl on RHS + erw [(congr_fun (rhs_even_ee w₁ x₁) + ⟨c.secondHalf, c.secondHalf_isEven hc h⟩).trans + (cps_even_at_inl _ _ c.secondHalf + (c.secondHalf_isEven hc h) a' hcl_sh), + funTensorFun_tmul] + ring + · -- ¬ c.firstHalf.IsEven + simp [zero_mul] + · -- Last colour odd: both sides vanish + erw [(congr_fun (chain_even_ee v w₁ x₁) ⟨c, hc⟩).trans + (cps_even_at_inr _ _ c hc b' hcl)] + simp only [map_zero, Pi.zero_apply] + split_ifs with h + · have hcl_sh : c.secondHalf (Fin.last b) = Sum.inr b' := + c.secondHalf_last.symm ▸ hcl + erw [(congr_fun (rhs_even_ee w₁ x₁) + ⟨c.secondHalf, c.secondHalf_isEven hc h⟩).trans + (cps_even_at_inr _ _ c.secondHalf + (c.secondHalf_isEven hc h) b' hcl_sh)] + simp [map_zero, mul_zero] + · rfl + | add t₁ t₂ ih₁ ih₂ => + have : ((t₁ + t₂, (0 : _)) : (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).even) = + ((t₁, (0 : _)) : _) + ((t₂, (0 : _)) : _) := + Prod.ext rfl (add_zero 0).symm + rw [this]; exact Goal_add _ _ ih₁ ih₂ + -- Prove for (0, s) by TensorProduct.induction_on + have h_oo : ∀ s, Goal ((0 : (superPow (stdSuperPair k ℓ) b).even ⊗[ℂ] + (stdSuperPair k ℓ).even), s) := by + intro s; induction s using TensorProduct.inductionOn with + | tmul w₂ x₂ => + simp only [hGoal] + -- Case split on the last colour of c + rcases hcl : c (Fin.last (a + b)) with a' | b' + · -- Last colour even: both sides vanish + erw [(congr_fun (chain_even_eo v w₂ x₂) ⟨c, hc⟩).trans + (cps_even_at_inl _ _ c hc a' hcl)] + simp only [map_zero, Pi.zero_apply] + split_ifs with h + · have hcl_sh : c.secondHalf (Fin.last b) = Sum.inl a' := + c.secondHalf_last.symm ▸ hcl + erw [(congr_fun (rhs_even_oo w₂ x₂) + ⟨c.secondHalf, c.secondHalf_isEven hc h⟩).trans + (cps_even_at_inl _ _ c.secondHalf + (c.secondHalf_isEven hc h) a' hcl_sh)] + simp [map_zero, mul_zero] + · rfl + · -- Last colour odd: chain + cps_even_at_inr on LHS + erw [(congr_fun (chain_even_eo v w₂ x₂) ⟨c, hc⟩).trans + (cps_even_at_inr _ _ c hc b' hcl), funTensorFun_tmul] + have hcl_sh : c.secondHalf (Fin.last b) = Sum.inr b' := + c.secondHalf_last.symm ▸ hcl + erw [ih_odd w₂ (MixedColouring.tail c) + ((c.isEven_succ_right b' hcl).mp hc)] + simp only [MixedColouring.firstHalf_tail, + MixedColouring.secondHalf_tail] + split_ifs with h + · -- c.firstHalf.IsEven: chain + cps_even_at_inr on RHS + erw [(congr_fun (rhs_even_oo w₂ x₂) + ⟨c.secondHalf, c.secondHalf_isEven hc h⟩).trans + (cps_even_at_inr _ _ c.secondHalf + (c.secondHalf_isEven hc h) b' hcl_sh), + funTensorFun_tmul] + ring + · -- ¬ c.firstHalf.IsEven + simp [zero_mul] + | add s₁ s₂ ih₁ ih₂ => + have : (((0 : _), s₁ + s₂) : (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).even) = + (((0 : _), s₁) : _) + (((0 : _), s₂) : _) := + Prod.ext (add_zero 0).symm rfl + rw [this]; exact Goal_add _ _ ih₁ ih₂ + -- Combine: (w_ee, w_oo) = (w_ee, 0) + (0, w_oo) + have hw : ((w_ee, w_oo) : (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).even) = + ((w_ee, (0 : _)) : _) + (((0 : _), w_oo) : _) := + Prod.ext (add_zero w_ee).symm (zero_add w_oo).symm + rw [hw]; exact Goal_add _ _ (h_ee w_ee) (h_oo w_oo) + +private theorem colourMerge_pair_odd_step {k ℓ : ℕ} (a : ℕ) + (v : (superPow (stdSuperPair k ℓ) a).even) (b : ℕ) + (ih_even : ∀ (w : (superPow (stdSuperPair k ℓ) b).even) + (c : MixedColouring k ℓ (a + b)) (hc : c.IsEven), + (colourPowerEquiv k ℓ (a + b)).evenEquiv + (((powMerge (stdSuperPair k ℓ) a b) : + SuperVect.Hom _ _).evenMap (evenPair v w)) ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then + (colourPowerEquiv k ℓ a).evenEquiv v ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ b).evenEquiv w ⟨c.secondHalf, + c.secondHalf_isEven hc h⟩ + else 0) + (ih_odd : ∀ (u : (superPow (stdSuperPair k ℓ) b).odd) + (c : MixedColouring k ℓ (a + b)) (hc : ¬ c.IsEven), + (colourPowerEquiv k ℓ (a + b)).oddEquiv + (((powMerge (stdSuperPair k ℓ) a b) : + SuperVect.Hom _ _).oddMap + ((v ⊗ₜ[ℂ] u, 0) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).odd)) + ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then + (colourPowerEquiv k ℓ a).evenEquiv v ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ b).oddEquiv u ⟨c.secondHalf, + c.secondHalf_not_isEven hc h⟩ + else 0) : + ∀ (u : (superPow (stdSuperPair k ℓ) (b + 1)).odd) + (c : MixedColouring k ℓ (a + (b + 1))) (hc : ¬ c.IsEven), + (colourPowerEquiv k ℓ (a + (b + 1))).oddEquiv + (((powMerge (stdSuperPair k ℓ) a (b + 1)) : + SuperVect.Hom _ _).oddMap + ((v ⊗ₜ[ℂ] u, 0) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) (b + 1))).odd)) + ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then + (colourPowerEquiv k ℓ a).evenEquiv v ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ (b + 1)).oddEquiv u ⟨c.secondHalf, + c.secondHalf_not_isEven hc h⟩ + else 0 := by + intro u c hc + obtain ⟨u_eo, u_oe⟩ := u + -- Both sides are additive in u; decompose and reduce to generators. + -- Helper: (v ⊗ₜ ·, 0) distributes over addition + have op_add : ∀ (u₁ u₂ : (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).odd), + ((v ⊗ₜ[ℂ] (u₁ + u₂), (0 : _)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) (b + 1))).odd) = + ((v ⊗ₜ[ℂ] u₁, (0 : _)) : _) + ((v ⊗ₜ[ℂ] u₂, (0 : _)) : _) := + fun u₁ u₂ => Prod.ext (TensorProduct.tmul_add v u₁ u₂) + (add_zero 0).symm + -- Helper for zero pair + have op_zero : ((v ⊗ₜ[ℂ] (0 : (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).odd), (0 : _)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) (b + 1))).odd) = (0 : _) := + Prod.ext (TensorProduct.tmul_zero _ v) rfl + -- Abbreviate the goal predicate for u + set Goal := fun (u : (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).odd) => + (colourPowerEquiv k ℓ (a + (b + 1))).oddEquiv + (((powMerge (stdSuperPair k ℓ) a (b + 1) : + SuperVect.Hom _ _).oddMap + ((v ⊗ₜ[ℂ] u, 0) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) (b + 1))).odd))) + ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then + (colourPowerEquiv k ℓ a).evenEquiv v ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ (b + 1)).oddEquiv u ⟨c.secondHalf, + c.secondHalf_not_isEven hc h⟩ + else 0 with hGoal + change Goal (u_eo, u_oe) + -- Additivity: Goal(u₁ + u₂) follows from Goal(u₁) and Goal(u₂) + have Goal_add : ∀ (u₁ u₂ : _), Goal u₁ → Goal u₂ → Goal (u₁ + u₂) := by + intro u₁ u₂ h₁ h₂ + simp only [hGoal] at h₁ h₂ ⊢ + erw [op_add u₁ u₂, map_add, LinearEquiv.map_add, Pi.add_apply, h₁, h₂] + split_ifs with h + · erw [← mul_add]; congr 1 + erw [LinearEquiv.map_add, Pi.add_apply] + · exact add_zero 0 + -- Prove for (t, 0) by TensorProduct.induction_on + have h_eo : ∀ t, Goal (t, (0 : (superPow (stdSuperPair k ℓ) b).odd ⊗[ℂ] + (stdSuperPair k ℓ).even)) := by + intro t; induction t using TensorProduct.inductionOn with + | tmul w₂ x₂ => + simp only [hGoal] + rcases hcl : c (Fin.last (a + b)) with a' | b' + · -- Last colour even: both sides vanish + erw [(congr_fun (chain_odd_eo v w₂ x₂) ⟨c, hc⟩).trans + (cps_odd_at_inl _ _ c hc a' hcl)] + simp only [map_zero, Pi.zero_apply] + split_ifs with h + · have hcl_sh : c.secondHalf (Fin.last b) = Sum.inl a' := + c.secondHalf_last.symm ▸ hcl + erw [(congr_fun (rhs_odd_eo w₂ x₂) + ⟨c.secondHalf, c.secondHalf_not_isEven hc h⟩).trans + (cps_odd_at_inl _ _ c.secondHalf + (c.secondHalf_not_isEven hc h) a' hcl_sh)] + simp [map_zero, mul_zero] + · rfl + · -- Last colour odd: chain + cps_odd_at_inr + IH + erw [(congr_fun (chain_odd_eo v w₂ x₂) ⟨c, hc⟩).trans + (cps_odd_at_inr _ _ c hc b' hcl), funTensorFun_tmul] + have hcl_sh : c.secondHalf (Fin.last b) = Sum.inr b' := + c.secondHalf_last.symm ▸ hcl + erw [ih_even w₂ (MixedColouring.tail c) + (Decidable.not_not.mp + ((c.isEven_succ_right b' hcl).not.mp hc))] + simp only [MixedColouring.firstHalf_tail, + MixedColouring.secondHalf_tail] + split_ifs with h + · erw [(congr_fun (rhs_odd_eo w₂ x₂) + ⟨c.secondHalf, c.secondHalf_not_isEven hc h⟩).trans + (cps_odd_at_inr _ _ c.secondHalf + (c.secondHalf_not_isEven hc h) b' hcl_sh), + funTensorFun_tmul] + ring + · simp [zero_mul] + | add t₁ t₂ ih₁ ih₂ => + have : ((t₁ + t₂, (0 : _)) : (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).odd) = + ((t₁, (0 : _)) : _) + ((t₂, (0 : _)) : _) := + Prod.ext rfl (add_zero 0).symm + rw [this]; exact Goal_add _ _ ih₁ ih₂ + -- Prove for (0, s) by TensorProduct.induction_on + have h_oe : ∀ s, Goal ((0 : (superPow (stdSuperPair k ℓ) b).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), s) := by + intro s; induction s using TensorProduct.inductionOn with + | tmul w₁ x₁ => + simp only [hGoal] + rcases hcl : c (Fin.last (a + b)) with a' | b' + · -- Last colour even: chain + cps_odd_at_inl + IH + erw [(congr_fun (chain_odd_oe v w₁ x₁) ⟨c, hc⟩).trans + (cps_odd_at_inl _ _ c hc a' hcl), funTensorFun_tmul] + have hcl_sh : c.secondHalf (Fin.last b) = Sum.inl a' := + c.secondHalf_last.symm ▸ hcl + erw [ih_odd w₁ (MixedColouring.tail c) + ((c.isEven_succ_left a' hcl).not.mp hc)] + simp only [MixedColouring.firstHalf_tail, + MixedColouring.secondHalf_tail] + split_ifs with h + · erw [(congr_fun (rhs_odd_oe w₁ x₁) + ⟨c.secondHalf, c.secondHalf_not_isEven hc h⟩).trans + (cps_odd_at_inl _ _ c.secondHalf + (c.secondHalf_not_isEven hc h) a' hcl_sh), + funTensorFun_tmul] + ring + · simp [zero_mul] + · -- Last colour odd: both sides vanish + erw [(congr_fun (chain_odd_oe v w₁ x₁) ⟨c, hc⟩).trans + (cps_odd_at_inr _ _ c hc b' hcl)] + simp only [map_zero, Pi.zero_apply] + split_ifs with h + · have hcl_sh : c.secondHalf (Fin.last b) = Sum.inr b' := + c.secondHalf_last.symm ▸ hcl + erw [(congr_fun (rhs_odd_oe w₁ x₁) + ⟨c.secondHalf, c.secondHalf_not_isEven hc h⟩).trans + (cps_odd_at_inr _ _ c.secondHalf + (c.secondHalf_not_isEven hc h) b' hcl_sh)] + simp [map_zero, mul_zero] + · rfl + | add s₁ s₂ ih₁ ih₂ => + have : (((0 : _), s₁ + s₂) : (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).odd) = + (((0 : _), s₁) : _) + (((0 : _), s₂) : _) := + Prod.ext (add_zero 0).symm rfl + rw [this]; exact Goal_add _ _ ih₁ ih₂ + -- Combine: (u_eo, u_oe) = (u_eo, 0) + (0, u_oe) + have hu : ((u_eo, u_oe) : (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).odd) = + ((u_eo, (0 : _)) : _) + (((0 : _), u_oe) : _) := + Prod.ext (add_zero u_eo).symm (zero_add u_oe).symm + rw [hu]; exact Goal_add _ _ (h_eo u_eo) (h_oe u_oe) + +/-- Combined even and odd merge coordinate formulas, proved by +mutual induction on `b`. -/ +private theorem colourMerge_pair {k ℓ : ℕ} (a : ℕ) + (v : (superPow (stdSuperPair k ℓ) a).even) : + ∀ (b : ℕ), + (∀ (w : (superPow (stdSuperPair k ℓ) b).even) + (c : MixedColouring k ℓ (a + b)) (hc : c.IsEven), + (colourPowerEquiv k ℓ (a + b)).evenEquiv + (((powMerge (stdSuperPair k ℓ) a b) : + SuperVect.Hom _ _).evenMap (evenPair v w)) ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then + (colourPowerEquiv k ℓ a).evenEquiv v ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ b).evenEquiv w ⟨c.secondHalf, + c.secondHalf_isEven hc h⟩ + else 0) + ∧ + (∀ (u : (superPow (stdSuperPair k ℓ) b).odd) + (c : MixedColouring k ℓ (a + b)) (hc : ¬ c.IsEven), + (colourPowerEquiv k ℓ (a + b)).oddEquiv + (((powMerge (stdSuperPair k ℓ) a b) : + SuperVect.Hom _ _).oddMap + ((v ⊗ₜ[ℂ] u, 0) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).odd)) + ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then + (colourPowerEquiv k ℓ a).evenEquiv v ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ b).oddEquiv u ⟨c.secondHalf, + c.secondHalf_not_isEven hc h⟩ + else 0) + | 0 => by + constructor + · -- ═══════ b = 0, EVEN COMPONENT ═══════ + intro w c hc + set w' : ℂ := w with hw' + have hpow : ((powMerge (stdSuperPair k ℓ) a 0 : + SuperVect.Hom _ _).evenMap (evenPair v w')) = w' • v := by + change ((SuperVect.rightUnitor + (superPow (stdSuperPair k ℓ) a)).hom).evenMap + (v ⊗ₜ[ℂ] w', 0) = _ + rw [SuperVect.rightUnitor_hom_evenMap] + change (TensorProduct.rid ℂ _) (v ⊗ₜ[ℂ] w') = w' • v + exact TensorProduct.rid_tmul v w' + have hfh : c.firstHalf = c := c.firstHalf_zero + have hfe : c.firstHalf.IsEven := hfh ▸ hc + have h0 : (colourPowerEquiv k ℓ 0).evenEquiv w + ⟨c.secondHalf, c.secondHalf_isEven hc hfe⟩ = w' := by + change (LinearEquiv.funUnique + {c : MixedColouring k ℓ 0 // c.IsEven} ℂ ℂ).symm w' _ = w' + rfl + simp only [hpow, LinearEquiv.map_smul, + dite_eq_left hfe, + show (⟨c.firstHalf, hfe⟩ : + {c : MixedColouring k ℓ a // c.IsEven}) = ⟨c, hc⟩ from + Subtype.ext hfh] + change w' * (colourPowerEquiv k ℓ (a + 0)).evenEquiv v ⟨c, hc⟩ = + (colourPowerEquiv k ℓ a).evenEquiv v ⟨c, hc⟩ * + (colourPowerEquiv k ℓ 0).evenEquiv w' ⟨c.secondHalf, + c.secondHalf_isEven hc hfe⟩ + rw [h0, mul_comm]; rfl + · -- ═══════ b = 0, ODD COMPONENT ═══════ + -- The odd component of `superPow _ 0` is `PUnit`, so the whole + -- odd side vanishes. + intro u c hc + have hfe : ¬ c.firstHalf.IsEven := c.firstHalf_zero ▸ hc + simp only [dite_eq_right hfe] + -- pm(a,0) = right unitor; its oddMap sends (v ⊗ₜ u, 0) to 0 + have hzero : ((powMerge (stdSuperPair k ℓ) a 0 : + SuperVect.Hom _ _).oddMap + ((v ⊗ₜ[ℂ] u, 0) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) 0)).odd)) = 0 := by + change ((SuperVect.rightUnitor + (superPow (stdSuperPair k ℓ) a)).hom).oddMap + (v ⊗ₜ[ℂ] u, 0) = 0 + rw [SuperVect.rightUnitor_hom_oddMap]; rfl + rw [hzero, map_zero]; rfl + | b + 1 => by + obtain ⟨ih_even, ih_odd⟩ := colourMerge_pair a v b + constructor + · exact colourMerge_pair_even_step a v b ih_even ih_odd + · exact colourMerge_pair_odd_step a v b ih_even ih_odd + +-- Specializing the mutual induction re-elaborates +-- the paired statement. +/-- **The merge coordinate product rule**: coordinates of a +merged even pair multiply over the halves, vanishing when the +halves are odd. -/ +theorem colourMerge_coord {k ℓ : ℕ} (a b : ℕ) + (v : (superPow (stdSuperPair k ℓ) a).even) + (w : (superPow (stdSuperPair k ℓ) b).even) + (c : MixedColouring k ℓ (a + b)) (hc : c.IsEven) : + (colourPowerEquiv k ℓ (a + b)).evenEquiv + (((powMerge (stdSuperPair k ℓ) a b) : + SuperVect.Hom _ _).evenMap (evenPair v w)) ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then + (colourPowerEquiv k ℓ a).evenEquiv v ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ b).evenEquiv w ⟨c.secondHalf, + c.secondHalf_isEven hc h⟩ + else 0 := + (colourMerge_pair a v b).1 w c hc + +/-- **The even-odd merge coordinate product rule**: odd +coordinates of a merged even-odd pair multiply over the halves, +supported on even first halves. -/ +theorem colourMerge_coord_evenOdd {k ℓ : ℕ} (a b : ℕ) + (v : (superPow (stdSuperPair k ℓ) a).even) + (u : (superPow (stdSuperPair k ℓ) b).odd) + (c : MixedColouring k ℓ (a + b)) (hc : ¬ c.IsEven) : + (colourPowerEquiv k ℓ (a + b)).oddEquiv + (((powMerge (stdSuperPair k ℓ) a b) : + SuperVect.Hom _ _).oddMap + ((v ⊗ₜ[ℂ] u, 0) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).odd)) + ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then + (colourPowerEquiv k ℓ a).evenEquiv v ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ b).oddEquiv u ⟨c.secondHalf, + c.secondHalf_not_isEven hc h⟩ + else 0 := + (colourMerge_pair a v b).2 u c hc + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMergeOdd.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMergeOdd.lean new file mode 100644 index 0000000000..adf3c6aa33 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMergeOdd.lean @@ -0,0 +1,1003 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMerge + +/-! +# The merge coordinate product rule, odd input + +Coordinates of a merged odd-even pair multiply over the halves, +vanishing when the first half has even parity — the odd-input +counterpart of `ColourMerge.lean`, whose split-equivalence, +tensor-step and right-hand-side helpers it shares. + +The four chain reductions run on the four parity patterns of a +pure tensor, and the two parts of `colourMerge_pair_odd` are +proved by one mutual induction on the second arity. +-/ + +@[expose] public section + +open scoped TensorProduct + +namespace RS + +open CategoryTheory MonoidalCategory + +/-! ### Parity helpers for the odd input -/ + +/-- When the whole is even and the first half is odd, +the second half is odd. -/ +theorem MixedColouring.secondHalf_not_isEven' {k ℓ a b : ℕ} + (c : MixedColouring k ℓ (a + b)) (hc : c.IsEven) + (h : ¬ c.firstHalf.IsEven) : ¬ c.secondHalf.IsEven := + mt (c.isEven_half_iff hc).mpr h + +private theorem MixedColouring.secondHalf_isEven_of_not {k ℓ a b : ℕ} + (c : MixedColouring k ℓ (a + b)) (hc : ¬ c.IsEven) + (h : ¬ c.firstHalf.IsEven) : c.secondHalf.IsEven := by + by_contra hs + apply hc + unfold MixedColouring.IsEven + rw [MixedColouring.oddSet_card_split] + exact Nat.even_add.mpr (Iff.intro (fun hf => absurd hf h) (fun hs' => absurd + hs' hs)) + +private theorem assoc_inv_odd_oe_ee_tmul {k ℓ a b : ℕ} + (x : (superPow (stdSuperPair k ℓ) a).odd) + (w₁ : (superPow (stdSuperPair k ℓ) b).even) + (x₁ : (stdSuperPair k ℓ).even) : + (((α_ (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).inv : SuperVect.Hom _ _).oddMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd), + x ⊗ₜ[ℂ] ((w₁ ⊗ₜ[ℂ] x₁, + (0 : (superPow (stdSuperPair k ℓ) b).odd ⊗[ℂ] + (stdSuperPair k ℓ).odd)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) (stdSuperPair k + ℓ)).even)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) (stdSuperPair k + ℓ))).odd)) = + (((0 : (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).even ⊗[ℂ] (stdSuperPair k ℓ).odd), + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) b).odd), + x ⊗ₜ[ℂ] w₁) ⊗ₜ[ℂ] x₁)) : + (SuperVect.tensorObj (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)) (stdSuperPair k ℓ)).odd) := by + change (SuperVect.assocAux _ _ _ _ _ _).symm + (((0 : _), x ⊗ₜ[ℂ] ((w₁ ⊗ₜ[ℂ] x₁, (0 : _)) : _)) : _) = _ + exact SuperVect.assocAux_symm_oe x w₁ x₁ + +/-- The associator inverse oddMap on an oe-oo tensor: +`α⁻¹.oddMap (0, x ⊗ₜ (0, w₂ ⊗ₜ x₂))`. -/ +private theorem assoc_inv_odd_oe_oo_tmul {k ℓ a b : ℕ} + (x : (superPow (stdSuperPair k ℓ) a).odd) + (w₂ : (superPow (stdSuperPair k ℓ) b).odd) + (x₂ : (stdSuperPair k ℓ).odd) : + (((α_ (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).inv : SuperVect.Hom _ _).oddMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd), + x ⊗ₜ[ℂ] (((0 : (superPow (stdSuperPair k ℓ) b).even ⊗[ℂ] + (stdSuperPair k ℓ).even), + w₂ ⊗ₜ[ℂ] x₂) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) (stdSuperPair k + ℓ)).even)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) (stdSuperPair k + ℓ))).odd)) = + ((((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) b).even), + x ⊗ₜ[ℂ] w₂) ⊗ₜ[ℂ] x₂, + (0 : (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).odd ⊗[ℂ] (stdSuperPair k ℓ).even)) : + (SuperVect.tensorObj (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)) (stdSuperPair k ℓ)).odd) := by + change (SuperVect.assocAux _ _ _ _ _ _).symm + (((0 : _), x ⊗ₜ[ℂ] (((0 : _), w₂ ⊗ₜ[ℂ] x₂) : _)) : _) = _ + exact SuperVect.assocAux_symm_oo x w₂ x₂ + +/-- The associator inverse evenMap on an oe-eo tensor: +`α⁻¹.evenMap (0, x ⊗ₜ (w₁ ⊗ₜ x₂, 0))`. -/ +private theorem assoc_inv_even_oe_eo_tmul {k ℓ a b : ℕ} + (x : (superPow (stdSuperPair k ℓ) a).odd) + (w₁ : (superPow (stdSuperPair k ℓ) b).even) + (x₂ : (stdSuperPair k ℓ).odd) : + (((α_ (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).inv : SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) (stdSuperPair k + ℓ)).even), + x ⊗ₜ[ℂ] ((w₁ ⊗ₜ[ℂ] x₂, + (0 : (superPow (stdSuperPair k ℓ) b).odd ⊗[ℂ] + (stdSuperPair k ℓ).even)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd)) + : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) (stdSuperPair k + ℓ))).even)) = + (((0 : (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).even ⊗[ℂ] (stdSuperPair k ℓ).even), + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) b).odd), + x ⊗ₜ[ℂ] w₁) ⊗ₜ[ℂ] x₂)) : + (SuperVect.tensorObj (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)) (stdSuperPair k ℓ)).even) := by + change (SuperVect.assocAux _ _ _ _ _ _).symm + (((0 : _), x ⊗ₜ[ℂ] ((w₁ ⊗ₜ[ℂ] x₂, (0 : _)) : _)) : _) = _ + exact SuperVect.assocAux_symm_oe x w₁ x₂ + +/-- The associator inverse evenMap on an oe-oe tensor: +`α⁻¹.evenMap (0, x ⊗ₜ (0, w₂ ⊗ₜ x₁))`. -/ +private theorem assoc_inv_even_oe_oe_tmul {k ℓ a b : ℕ} + (x : (superPow (stdSuperPair k ℓ) a).odd) + (w₂ : (superPow (stdSuperPair k ℓ) b).odd) + (x₁ : (stdSuperPair k ℓ).even) : + (((α_ (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).inv : SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) (stdSuperPair k + ℓ)).even), + x ⊗ₜ[ℂ] (((0 : (superPow (stdSuperPair k ℓ) b).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), + w₂ ⊗ₜ[ℂ] x₁) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd)) + : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) (stdSuperPair k + ℓ))).even)) = + ((((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) b).even), + x ⊗ₜ[ℂ] w₂) ⊗ₜ[ℂ] x₁, + (0 : (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).odd ⊗[ℂ] (stdSuperPair k ℓ).odd)) : + (SuperVect.tensorObj (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)) (stdSuperPair k ℓ)).even) := by + change (SuperVect.assocAux _ _ _ _ _ _).symm + (((0 : _), x ⊗ₜ[ℂ] (((0 : _), w₂ ⊗ₜ[ℂ] x₁) : _)) : _) = _ + exact SuperVect.assocAux_symm_oo x w₂ x₁ + +/-! ### Full chain reduction on pure tensor generators (odd input) -/ + +-- As in `ColourMerge`, the merge and the colouring +-- equivalence unfold on one pure tensor; four chains, one per +-- parity pattern, now with an odd first factor. +/-- Chain for part 1, ee generator: `cpe(a+(b+1)).oddEquiv` on +`pm.oddMap (0, x ⊗ₜ (w₁⊗ₜx₁, 0))` reduces to +`cps ∘ cpe ∘ pm` on the odd pair. -/ +private theorem chain_odd_oe_ee {k ℓ a b : ℕ} + (x : (superPow (stdSuperPair k ℓ) a).odd) + (w₁ : (superPow (stdSuperPair k ℓ) b).even) + (x₁ : (stdSuperPair k ℓ).even) : + (colourPowerEquiv k ℓ (a + (b + 1))).oddEquiv + (((powMerge (stdSuperPair k ℓ) a (b + 1) : + SuperVect.Hom _ _).oddMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd), + x ⊗ₜ[ℂ] ((w₁ ⊗ₜ[ℂ] x₁, + (0 : (superPow (stdSuperPair k ℓ) b).odd ⊗[ℂ] + (stdSuperPair k ℓ).odd)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) (b + 1))).odd))) = + (colourPowerStep k ℓ (a + b)).oddEquiv + (((0 : ({c : MixedColouring k ℓ (a + b) // c.IsEven} → ℂ) + ⊗[ℂ] (Fin (2 * ℓ) → ℂ)), + (colourPowerEquiv k ℓ (a + b)).oddEquiv + (((powMerge (stdSuperPair k ℓ) a b : + SuperVect.Hom _ _).oddMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) b).odd), + x ⊗ₜ[ℂ] w₁) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).odd))) + ⊗ₜ[ℂ] x₁)) := by + change (colourPowerStep k ℓ (a + b)).oddEquiv + ((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ (a + b)) + (SuperLinearEquiv.refl (stdSuperPair k ℓ))).oddEquiv + ((powMerge (stdSuperPair k ℓ) a b ▷ stdSuperPair k ℓ : + SuperVect.Hom _ _).oddMap + (((α_ (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).inv : SuperVect.Hom _ _).oddMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd), + x ⊗ₜ[ℂ] ((w₁ ⊗ₜ[ℂ] x₁, + (0 : (superPow (stdSuperPair k ℓ) b).odd ⊗[ℂ] + (stdSuperPair k ℓ).odd)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ))).odd)))) = _ + refine congr_arg (colourPowerStep k ℓ (a + b)).oddEquiv ?_ + erw [assoc_inv_odd_oe_ee_tmul x w₁ x₁] + have hid_o : (SuperVect.Hom.id (stdSuperPair k ℓ)).oddMap = + LinearMap.id := rfl + have hid_e : (SuperVect.Hom.id (stdSuperPair k ℓ)).evenMap = + LinearMap.id := rfl + simp only [MonoidalCategoryStruct.whiskerRight, + SuperVect.tensorHom_oddMap, hid_o, hid_e] + change LinearEquiv.prodCongr + (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).evenEquiv + (LinearEquiv.refl ℂ _)) + (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).oddEquiv + (LinearEquiv.refl ℂ _)) + (((0 : _), + ((powMerge (stdSuperPair k ℓ) a b : SuperVect.Hom _ _).oddMap + (((0 : _), x ⊗ₜ[ℂ] w₁) : _)) ⊗ₜ[ℂ] x₁)) = _ + simp only [LinearEquiv.prodCongr_apply, TensorProduct.congr_tmul, + LinearEquiv.refl_apply, map_zero] + rfl + +-- As for the ee generator, with both factors odd. +/-- Chain for part 1, oo generator: `cpe(a+(b+1)).oddEquiv` on +`pm.oddMap (0, x ⊗ₜ (0, w₂⊗ₜx₂))` reduces to +`cps ∘ cpe ∘ pm` on the even pair. -/ +private theorem chain_odd_oe_oo {k ℓ a b : ℕ} + (x : (superPow (stdSuperPair k ℓ) a).odd) + (w₂ : (superPow (stdSuperPair k ℓ) b).odd) + (x₂ : (stdSuperPair k ℓ).odd) : + (colourPowerEquiv k ℓ (a + (b + 1))).oddEquiv + (((powMerge (stdSuperPair k ℓ) a (b + 1) : + SuperVect.Hom _ _).oddMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd), + x ⊗ₜ[ℂ] (((0 : (superPow (stdSuperPair k ℓ) b).even ⊗[ℂ] + (stdSuperPair k ℓ).even), + w₂ ⊗ₜ[ℂ] x₂) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) (b + 1))).odd))) = + (colourPowerStep k ℓ (a + b)).oddEquiv + (((colourPowerEquiv k ℓ (a + b)).evenEquiv + (((powMerge (stdSuperPair k ℓ) a b : + SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) b).even), + x ⊗ₜ[ℂ] w₂) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).even))) + ⊗ₜ[ℂ] x₂, + (0 : ({c : MixedColouring k ℓ (a + b) // ¬ c.IsEven} → ℂ) + ⊗[ℂ] (Fin k → ℂ)))) := by + change (colourPowerStep k ℓ (a + b)).oddEquiv + ((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ (a + b)) + (SuperLinearEquiv.refl (stdSuperPair k ℓ))).oddEquiv + ((powMerge (stdSuperPair k ℓ) a b ▷ stdSuperPair k ℓ : + SuperVect.Hom _ _).oddMap + (((α_ (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).inv : SuperVect.Hom _ _).oddMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd), + x ⊗ₜ[ℂ] (((0 : (superPow (stdSuperPair k ℓ) b).even ⊗[ℂ] + (stdSuperPair k ℓ).even), + w₂ ⊗ₜ[ℂ] x₂) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ))).odd)))) = _ + refine congr_arg (colourPowerStep k ℓ (a + b)).oddEquiv ?_ + erw [assoc_inv_odd_oe_oo_tmul x w₂ x₂] + have hid_o : (SuperVect.Hom.id (stdSuperPair k ℓ)).oddMap = + LinearMap.id := rfl + have hid_e : (SuperVect.Hom.id (stdSuperPair k ℓ)).evenMap = + LinearMap.id := rfl + simp only [MonoidalCategoryStruct.whiskerRight, + SuperVect.tensorHom_oddMap, hid_o, hid_e] + change LinearEquiv.prodCongr + (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).evenEquiv + (LinearEquiv.refl ℂ _)) + (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).oddEquiv + (LinearEquiv.refl ℂ _)) + ((((powMerge (stdSuperPair k ℓ) a b : SuperVect.Hom _ _).evenMap + (((0 : _), x ⊗ₜ[ℂ] w₂) : _)) ⊗ₜ[ℂ] x₂, (0 : _))) = _ + simp only [LinearEquiv.prodCongr_apply, TensorProduct.congr_tmul, + LinearEquiv.refl_apply, map_zero] + rfl + +-- As for part 1, on the even component. +/-- Chain for part 2, eo generator: `cpe(a+(b+1)).evenEquiv` on +`pm.evenMap (0, x ⊗ₜ (w₁⊗ₜx₂, 0))` reduces to +`cps ∘ cpe ∘ pm` on the odd pair. -/ +private theorem chain_even_oe_eo {k ℓ a b : ℕ} + (x : (superPow (stdSuperPair k ℓ) a).odd) + (w₁ : (superPow (stdSuperPair k ℓ) b).even) + (x₂ : (stdSuperPair k ℓ).odd) : + (colourPowerEquiv k ℓ (a + (b + 1))).evenEquiv + (((powMerge (stdSuperPair k ℓ) a (b + 1) : + SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even), + x ⊗ₜ[ℂ] ((w₁ ⊗ₜ[ℂ] x₂, + (0 : (superPow (stdSuperPair k ℓ) b).odd ⊗[ℂ] + (stdSuperPair k ℓ).even)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) (b + 1))).even))) = + (colourPowerStep k ℓ (a + b)).evenEquiv + (((0 : ({c : MixedColouring k ℓ (a + b) // c.IsEven} → ℂ) + ⊗[ℂ] (Fin k → ℂ)), + (colourPowerEquiv k ℓ (a + b)).oddEquiv + (((powMerge (stdSuperPair k ℓ) a b : + SuperVect.Hom _ _).oddMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) b).odd), + x ⊗ₜ[ℂ] w₁) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).odd))) + ⊗ₜ[ℂ] x₂)) := by + change (colourPowerStep k ℓ (a + b)).evenEquiv + ((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ (a + b)) + (SuperLinearEquiv.refl (stdSuperPair k ℓ))).evenEquiv + ((powMerge (stdSuperPair k ℓ) a b ▷ stdSuperPair k ℓ : + SuperVect.Hom _ _).evenMap + (((α_ (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).inv : SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even), + x ⊗ₜ[ℂ] ((w₁ ⊗ₜ[ℂ] x₂, + (0 : (superPow (stdSuperPair k ℓ) b).odd ⊗[ℂ] + (stdSuperPair k ℓ).even)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ))).even)))) = _ + refine congr_arg (colourPowerStep k ℓ (a + b)).evenEquiv ?_ + erw [assoc_inv_even_oe_eo_tmul x w₁ x₂] + have hid_o : (SuperVect.Hom.id (stdSuperPair k ℓ)).oddMap = + LinearMap.id := rfl + simp only [MonoidalCategoryStruct.whiskerRight, + SuperVect.tensorHom_evenMap, hid_o] + change LinearEquiv.prodCongr + (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).evenEquiv + (LinearEquiv.refl ℂ _)) + (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).oddEquiv + (LinearEquiv.refl ℂ _)) + (((0 : _), + ((powMerge (stdSuperPair k ℓ) a b : SuperVect.Hom _ _).oddMap + (((0 : _), x ⊗ₜ[ℂ] w₁) : _)) ⊗ₜ[ℂ] x₂)) = _ + simp only [LinearEquiv.prodCongr_apply, TensorProduct.congr_tmul, + LinearEquiv.refl_apply, map_zero] + rfl + +-- As for part 1, on the even component. +/-- Chain for part 2, oe generator: `cpe(a+(b+1)).evenEquiv` on +`pm.evenMap (0, x ⊗ₜ (0, w₂⊗ₜx₁))` reduces to +`cps ∘ cpe ∘ pm` on the even pair. -/ +private theorem chain_even_oe_oe {k ℓ a b : ℕ} + (x : (superPow (stdSuperPair k ℓ) a).odd) + (w₂ : (superPow (stdSuperPair k ℓ) b).odd) + (x₁ : (stdSuperPair k ℓ).even) : + (colourPowerEquiv k ℓ (a + (b + 1))).evenEquiv + (((powMerge (stdSuperPair k ℓ) a (b + 1) : + SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even), + x ⊗ₜ[ℂ] (((0 : (superPow (stdSuperPair k ℓ) b).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), + w₂ ⊗ₜ[ℂ] x₁) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) (b + 1))).even))) = + (colourPowerStep k ℓ (a + b)).evenEquiv + (((colourPowerEquiv k ℓ (a + b)).evenEquiv + (((powMerge (stdSuperPair k ℓ) a b : + SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) b).even), + x ⊗ₜ[ℂ] w₂) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).even))) + ⊗ₜ[ℂ] x₁, + (0 : ({c : MixedColouring k ℓ (a + b) // ¬ c.IsEven} → ℂ) + ⊗[ℂ] (Fin (2 * ℓ) → ℂ)))) := by + change (colourPowerStep k ℓ (a + b)).evenEquiv + ((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ (a + b)) + (SuperLinearEquiv.refl (stdSuperPair k ℓ))).evenEquiv + ((powMerge (stdSuperPair k ℓ) a b ▷ stdSuperPair k ℓ : + SuperVect.Hom _ _).evenMap + (((α_ (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).inv : SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even), + x ⊗ₜ[ℂ] (((0 : (superPow (stdSuperPair k ℓ) b).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), + w₂ ⊗ₜ[ℂ] x₁) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ))).even)))) = _ + refine congr_arg (colourPowerStep k ℓ (a + b)).evenEquiv ?_ + erw [assoc_inv_even_oe_oe_tmul x w₂ x₁] + have hid_e : (SuperVect.Hom.id (stdSuperPair k ℓ)).evenMap = + LinearMap.id := rfl + simp only [MonoidalCategoryStruct.whiskerRight, + SuperVect.tensorHom_evenMap, hid_e] + change LinearEquiv.prodCongr + (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).evenEquiv + (LinearEquiv.refl ℂ _)) + (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).oddEquiv + (LinearEquiv.refl ℂ _)) + ((((powMerge (stdSuperPair k ℓ) a b : SuperVect.Hom _ _).evenMap + (((0 : _), x ⊗ₜ[ℂ] w₂) : _)) ⊗ₜ[ℂ] x₁, (0 : _))) = _ + simp only [LinearEquiv.prodCongr_apply, TensorProduct.congr_tmul, + LinearEquiv.refl_apply, map_zero] + rfl + +private theorem colourMerge_pair_odd_odd_step {k ℓ : ℕ} (a : ℕ) + (x : (superPow (stdSuperPair k ℓ) a).odd) (b : ℕ) + (ih_odd : ∀ (w : (superPow (stdSuperPair k ℓ) b).even) + (c : MixedColouring k ℓ (a + b)) (hc : ¬ c.IsEven), + (colourPowerEquiv k ℓ (a + b)).oddEquiv + (((powMerge (stdSuperPair k ℓ) a b) : + SuperVect.Hom _ _).oddMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) b).odd), + x ⊗ₜ[ℂ] w) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).odd)) + ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then 0 + else + (colourPowerEquiv k ℓ a).oddEquiv x ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ b).evenEquiv w ⟨c.secondHalf, + c.secondHalf_isEven_of_not hc h⟩) + (ih_even : ∀ (u : (superPow (stdSuperPair k ℓ) b).odd) + (c : MixedColouring k ℓ (a + b)) (hc : c.IsEven), + (colourPowerEquiv k ℓ (a + b)).evenEquiv + (((powMerge (stdSuperPair k ℓ) a b) : + SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) b).even), + x ⊗ₜ[ℂ] u) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).even)) + ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then 0 + else + (colourPowerEquiv k ℓ a).oddEquiv x ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ b).oddEquiv u ⟨c.secondHalf, + c.secondHalf_not_isEven' hc h⟩) : + ∀ (w : (superPow (stdSuperPair k ℓ) (b + 1)).even) + (c : MixedColouring k ℓ (a + (b + 1))) (hc : ¬ c.IsEven), + (colourPowerEquiv k ℓ (a + (b + 1))).oddEquiv + (((powMerge (stdSuperPair k ℓ) a (b + 1)) : + SuperVect.Hom _ _).oddMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) (b + 1)).odd), + x ⊗ₜ[ℂ] w) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) (b + 1))).odd)) + ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then 0 + else + (colourPowerEquiv k ℓ a).oddEquiv x ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ (b + 1)).evenEquiv w ⟨c.secondHalf, + c.secondHalf_isEven_of_not hc h⟩ := by + intro w c hc + obtain ⟨w_ee, w_oo⟩ := w + -- Both sides are additive in w; decompose. + have op_add : ∀ (w₁ w₂ : (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).even), + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd), + x ⊗ₜ[ℂ] (w₁ + w₂)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) (b + 1))).odd) = + (((0 : _), x ⊗ₜ[ℂ] w₁) : _) + (((0 : _), x ⊗ₜ[ℂ] w₂) : _) := + fun w₁ w₂ => Prod.ext (add_zero 0).symm (TensorProduct.tmul_add x w₁ w₂) + have op_zero : (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd), + x ⊗ₜ[ℂ] (0 : (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) (b + 1))).odd) = (0 : _) := + Prod.ext rfl (TensorProduct.tmul_zero _ x) + set Goal := fun (w : (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).even) => + (colourPowerEquiv k ℓ (a + (b + 1))).oddEquiv + (((powMerge (stdSuperPair k ℓ) a (b + 1) : + SuperVect.Hom _ _).oddMap + (((0 : _), x ⊗ₜ[ℂ] w) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) (b + 1))).odd))) + ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then 0 + else + (colourPowerEquiv k ℓ a).oddEquiv x ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ (b + 1)).evenEquiv w ⟨c.secondHalf, + c.secondHalf_isEven_of_not hc h⟩ + with hGoal + change Goal (w_ee, w_oo) + have Goal_add : ∀ (w₁ w₂ : _), Goal w₁ → Goal w₂ → Goal (w₁ + w₂) := by + intro w₁ w₂ h₁ h₂ + simp only [hGoal] at h₁ h₂ ⊢ + erw [op_add w₁ w₂, map_add, LinearEquiv.map_add, Pi.add_apply, h₁, h₂] + split_ifs with h + · exact add_zero 0 + · erw [← mul_add]; congr 1 + erw [LinearEquiv.map_add, Pi.add_apply] + -- Prove for (t, 0) by TensorProduct.induction_on + have h_ee : ∀ t, Goal (t, (0 : (superPow (stdSuperPair k ℓ) b).odd ⊗[ℂ] + (stdSuperPair k ℓ).odd)) := by + intro t; induction t using TensorProduct.inductionOn with + | tmul w₁ x₁ => + simp only [hGoal] + rcases hcl : c (Fin.last (a + b)) with a' | b' + · -- Last colour even: chain + cps_odd_at_inl on LHS + erw [(congr_fun (chain_odd_oe_ee x w₁ x₁) ⟨c, hc⟩).trans + (cps_odd_at_inl _ _ c hc a' hcl), funTensorFun_tmul] + have hcl_sh : c.secondHalf (Fin.last b) = Sum.inl a' := + c.secondHalf_last.symm ▸ hcl + erw [ih_odd w₁ (MixedColouring.tail c) + ((c.isEven_succ_left a' hcl).not.mp hc)] + simp only [MixedColouring.firstHalf_tail, + MixedColouring.secondHalf_tail] + split_ifs with h + · simp [zero_mul] + · erw [(congr_fun (rhs_even_ee w₁ x₁) + ⟨c.secondHalf, c.secondHalf_isEven_of_not hc h⟩).trans + (cps_even_at_inl _ _ c.secondHalf + (c.secondHalf_isEven_of_not hc h) a' hcl_sh), + funTensorFun_tmul] + ring + · -- Last colour odd: both sides vanish + erw [(congr_fun (chain_odd_oe_ee x w₁ x₁) ⟨c, hc⟩).trans + (cps_odd_at_inr _ _ c hc b' hcl)] + simp only [map_zero, Pi.zero_apply] + split_ifs with h + · rfl + · have hcl_sh : c.secondHalf (Fin.last b) = Sum.inr b' := + c.secondHalf_last.symm ▸ hcl + erw [(congr_fun (rhs_even_ee w₁ x₁) + ⟨c.secondHalf, c.secondHalf_isEven_of_not hc h⟩).trans + (cps_even_at_inr _ _ c.secondHalf + (c.secondHalf_isEven_of_not hc h) b' hcl_sh)] + simp [map_zero, mul_zero] + | add t₁ t₂ ih₁ ih₂ => + have : ((t₁ + t₂, (0 : _)) : (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).even) = + ((t₁, (0 : _)) : _) + ((t₂, (0 : _)) : _) := + Prod.ext rfl (add_zero 0).symm + rw [this]; exact Goal_add _ _ ih₁ ih₂ + -- Prove for (0, s) by TensorProduct.induction_on + have h_oo : ∀ s, Goal ((0 : (superPow (stdSuperPair k ℓ) b).even ⊗[ℂ] + (stdSuperPair k ℓ).even), s) := by + intro s; induction s using TensorProduct.inductionOn with + | tmul w₂ x₂ => + simp only [hGoal] + rcases hcl : c (Fin.last (a + b)) with a' | b' + · -- Last colour even: both sides vanish + erw [(congr_fun (chain_odd_oe_oo x w₂ x₂) ⟨c, hc⟩).trans + (cps_odd_at_inl _ _ c hc a' hcl)] + simp only [map_zero, Pi.zero_apply] + split_ifs with h + · rfl + · have hcl_sh : c.secondHalf (Fin.last b) = Sum.inl a' := + c.secondHalf_last.symm ▸ hcl + erw [(congr_fun (rhs_even_oo w₂ x₂) + ⟨c.secondHalf, c.secondHalf_isEven_of_not hc h⟩).trans + (cps_even_at_inl _ _ c.secondHalf + (c.secondHalf_isEven_of_not hc h) a' hcl_sh)] + simp [map_zero, mul_zero] + · -- Last colour odd: chain + cps_odd_at_inr + IH + erw [(congr_fun (chain_odd_oe_oo x w₂ x₂) ⟨c, hc⟩).trans + (cps_odd_at_inr _ _ c hc b' hcl), funTensorFun_tmul] + have hcl_sh : c.secondHalf (Fin.last b) = Sum.inr b' := + c.secondHalf_last.symm ▸ hcl + erw [ih_even w₂ (MixedColouring.tail c) + (Decidable.not_not.mp + ((c.isEven_succ_right b' hcl).not.mp hc))] + simp only [MixedColouring.firstHalf_tail, + MixedColouring.secondHalf_tail] + split_ifs with h + · simp [zero_mul] + · erw [(congr_fun (rhs_even_oo w₂ x₂) + ⟨c.secondHalf, c.secondHalf_isEven_of_not hc h⟩).trans + (cps_even_at_inr _ _ c.secondHalf + (c.secondHalf_isEven_of_not hc h) b' hcl_sh), + funTensorFun_tmul] + ring + | add s₁ s₂ ih₁ ih₂ => + have : (((0 : _), s₁ + s₂) : (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).even) = + (((0 : _), s₁) : _) + (((0 : _), s₂) : _) := + Prod.ext (add_zero 0).symm rfl + rw [this]; exact Goal_add _ _ ih₁ ih₂ + -- Combine + have hw : ((w_ee, w_oo) : (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).even) = + ((w_ee, (0 : _)) : _) + (((0 : _), w_oo) : _) := + Prod.ext (add_zero w_ee).symm (zero_add w_oo).symm + rw [hw]; exact Goal_add _ _ (h_ee w_ee) (h_oo w_oo) + +private theorem colourMerge_pair_odd_even_step {k ℓ : ℕ} (a : ℕ) + (x : (superPow (stdSuperPair k ℓ) a).odd) (b : ℕ) + (ih_odd : ∀ (w : (superPow (stdSuperPair k ℓ) b).even) + (c : MixedColouring k ℓ (a + b)) (hc : ¬ c.IsEven), + (colourPowerEquiv k ℓ (a + b)).oddEquiv + (((powMerge (stdSuperPair k ℓ) a b) : + SuperVect.Hom _ _).oddMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) b).odd), + x ⊗ₜ[ℂ] w) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).odd)) + ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then 0 + else + (colourPowerEquiv k ℓ a).oddEquiv x ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ b).evenEquiv w ⟨c.secondHalf, + c.secondHalf_isEven_of_not hc h⟩) + (ih_even : ∀ (u : (superPow (stdSuperPair k ℓ) b).odd) + (c : MixedColouring k ℓ (a + b)) (hc : c.IsEven), + (colourPowerEquiv k ℓ (a + b)).evenEquiv + (((powMerge (stdSuperPair k ℓ) a b) : + SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) b).even), + x ⊗ₜ[ℂ] u) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).even)) + ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then 0 + else + (colourPowerEquiv k ℓ a).oddEquiv x ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ b).oddEquiv u ⟨c.secondHalf, + c.secondHalf_not_isEven' hc h⟩) : + ∀ (u : (superPow (stdSuperPair k ℓ) (b + 1)).odd) + (c : MixedColouring k ℓ (a + (b + 1))) (hc : c.IsEven), + (colourPowerEquiv k ℓ (a + (b + 1))).evenEquiv + (((powMerge (stdSuperPair k ℓ) a (b + 1)) : + SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) (b + 1)).even), + x ⊗ₜ[ℂ] u) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) (b + 1))).even)) + ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then 0 + else + (colourPowerEquiv k ℓ a).oddEquiv x ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ (b + 1)).oddEquiv u ⟨c.secondHalf, + c.secondHalf_not_isEven' hc h⟩ := by + intro u c hc + obtain ⟨u_eo, u_oe⟩ := u + -- Both sides are additive in u; decompose. + have op_add : ∀ (u₁ u₂ : (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).odd), + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even), + x ⊗ₜ[ℂ] (u₁ + u₂)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) (b + 1))).even) = + (((0 : _), x ⊗ₜ[ℂ] u₁) : _) + (((0 : _), x ⊗ₜ[ℂ] u₂) : _) := + fun u₁ u₂ => Prod.ext (add_zero 0).symm (TensorProduct.tmul_add x u₁ u₂) + have op_zero : (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).even), + x ⊗ₜ[ℂ] (0 : (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) b) + (stdSuperPair k ℓ)).odd)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) (b + 1))).even) = (0 : _) := + Prod.ext rfl (TensorProduct.tmul_zero _ x) + set Goal := fun (u : (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).odd) => + (colourPowerEquiv k ℓ (a + (b + 1))).evenEquiv + (((powMerge (stdSuperPair k ℓ) a (b + 1) : + SuperVect.Hom _ _).evenMap + (((0 : _), x ⊗ₜ[ℂ] u) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) (b + 1))).even))) + ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then 0 + else + (colourPowerEquiv k ℓ a).oddEquiv x ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ (b + 1)).oddEquiv u ⟨c.secondHalf, + c.secondHalf_not_isEven' hc h⟩ + with hGoal + change Goal (u_eo, u_oe) + have Goal_add : ∀ (u₁ u₂ : _), Goal u₁ → Goal u₂ → Goal (u₁ + u₂) := by + intro u₁ u₂ h₁ h₂ + simp only [hGoal] at h₁ h₂ ⊢ + erw [op_add u₁ u₂, map_add, LinearEquiv.map_add, Pi.add_apply, h₁, h₂] + split_ifs with h + · exact add_zero 0 + · erw [← mul_add]; congr 1 + erw [LinearEquiv.map_add, Pi.add_apply] + -- Prove for (t, 0) by TensorProduct.induction_on + have h_eo : ∀ t, Goal (t, (0 : (superPow (stdSuperPair k ℓ) b).odd ⊗[ℂ] + (stdSuperPair k ℓ).even)) := by + intro t; induction t using TensorProduct.inductionOn with + | tmul w₁ x₂ => + simp only [hGoal] + rcases hcl : c (Fin.last (a + b)) with a' | b' + · -- Last colour even: both sides vanish + erw [(congr_fun (chain_even_oe_eo x w₁ x₂) ⟨c, hc⟩).trans + (cps_even_at_inl _ _ c hc a' hcl)] + simp only [map_zero, Pi.zero_apply] + split_ifs with h + · rfl + · have hcl_sh : c.secondHalf (Fin.last b) = Sum.inl a' := + c.secondHalf_last.symm ▸ hcl + erw [(congr_fun (rhs_odd_eo w₁ x₂) + ⟨c.secondHalf, c.secondHalf_not_isEven' hc h⟩).trans + (cps_odd_at_inl _ _ c.secondHalf + (c.secondHalf_not_isEven' hc h) a' hcl_sh)] + simp [map_zero, mul_zero] + · -- Last colour odd: chain + cps_even_at_inr + IH + erw [(congr_fun (chain_even_oe_eo x w₁ x₂) ⟨c, hc⟩).trans + (cps_even_at_inr _ _ c hc b' hcl), funTensorFun_tmul] + have hcl_sh : c.secondHalf (Fin.last b) = Sum.inr b' := + c.secondHalf_last.symm ▸ hcl + erw [ih_odd w₁ (MixedColouring.tail c) + ((c.isEven_succ_right b' hcl).mp hc)] + simp only [MixedColouring.firstHalf_tail, + MixedColouring.secondHalf_tail] + split_ifs with h + · simp [zero_mul] + · erw [(congr_fun (rhs_odd_eo w₁ x₂) + ⟨c.secondHalf, c.secondHalf_not_isEven' hc h⟩).trans + (cps_odd_at_inr _ _ c.secondHalf + (c.secondHalf_not_isEven' hc h) b' hcl_sh), + funTensorFun_tmul] + ring + | add t₁ t₂ ih₁ ih₂ => + have : ((t₁ + t₂, (0 : _)) : (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).odd) = + ((t₁, (0 : _)) : _) + ((t₂, (0 : _)) : _) := + Prod.ext rfl (add_zero 0).symm + rw [this]; exact Goal_add _ _ ih₁ ih₂ + -- Prove for (0, s) by TensorProduct.induction_on + have h_oe : ∀ s, Goal ((0 : (superPow (stdSuperPair k ℓ) b).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), s) := by + intro s; induction s using TensorProduct.inductionOn with + | tmul w₂ x₁ => + simp only [hGoal] + rcases hcl : c (Fin.last (a + b)) with a' | b' + · -- Last colour even: chain + cps_even_at_inl + IH + erw [(congr_fun (chain_even_oe_oe x w₂ x₁) ⟨c, hc⟩).trans + (cps_even_at_inl _ _ c hc a' hcl), funTensorFun_tmul] + have hcl_sh : c.secondHalf (Fin.last b) = Sum.inl a' := + c.secondHalf_last.symm ▸ hcl + erw [ih_even w₂ (MixedColouring.tail c) + ((c.isEven_succ_left a' hcl).mp hc)] + simp only [MixedColouring.firstHalf_tail, + MixedColouring.secondHalf_tail] + split_ifs with h + · simp [zero_mul] + · erw [(congr_fun (rhs_odd_oe w₂ x₁) + ⟨c.secondHalf, c.secondHalf_not_isEven' hc h⟩).trans + (cps_odd_at_inl _ _ c.secondHalf + (c.secondHalf_not_isEven' hc h) a' hcl_sh), + funTensorFun_tmul] + ring + · -- Last colour odd: both sides vanish + erw [(congr_fun (chain_even_oe_oe x w₂ x₁) ⟨c, hc⟩).trans + (cps_even_at_inr _ _ c hc b' hcl)] + simp only [map_zero, Pi.zero_apply] + split_ifs with h + · rfl + · have hcl_sh : c.secondHalf (Fin.last b) = Sum.inr b' := + c.secondHalf_last.symm ▸ hcl + erw [(congr_fun (rhs_odd_oe w₂ x₁) + ⟨c.secondHalf, c.secondHalf_not_isEven' hc h⟩).trans + (cps_odd_at_inr _ _ c.secondHalf + (c.secondHalf_not_isEven' hc h) b' hcl_sh)] + simp [map_zero, mul_zero] + | add s₁ s₂ ih₁ ih₂ => + have : (((0 : _), s₁ + s₂) : (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).odd) = + (((0 : _), s₁) : _) + (((0 : _), s₂) : _) := + Prod.ext (add_zero 0).symm rfl + rw [this]; exact Goal_add _ _ ih₁ ih₂ + -- Combine + have hu : ((u_eo, u_oe) : (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).odd) = + ((u_eo, (0 : _)) : _) + (((0 : _), u_oe) : _) := + Prod.ext (add_zero u_eo).symm (zero_add u_oe).symm + rw [hu]; exact Goal_add _ _ (h_eo u_eo) (h_oe u_oe) + +-- Specializing the mutual induction re-elaborates +-- the paired statement. + +private theorem colourMerge_pair_odd {k ℓ : ℕ} (a : ℕ) + (x : (superPow (stdSuperPair k ℓ) a).odd) : + ∀ (b : ℕ), + -- Part 1: odd coordinates from pm.oddMap (0, x ⊗ₜ w) + (∀ (w : (superPow (stdSuperPair k ℓ) b).even) + (c : MixedColouring k ℓ (a + b)) (hc : ¬ c.IsEven), + (colourPowerEquiv k ℓ (a + b)).oddEquiv + (((powMerge (stdSuperPair k ℓ) a b) : + SuperVect.Hom _ _).oddMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) b).odd), + x ⊗ₜ[ℂ] w) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).odd)) + ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then 0 + else + (colourPowerEquiv k ℓ a).oddEquiv x ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ b).evenEquiv w ⟨c.secondHalf, + c.secondHalf_isEven_of_not hc h⟩) + ∧ + -- Part 2: even coordinates from pm.evenMap (0, x ⊗ₜ u) + (∀ (u : (superPow (stdSuperPair k ℓ) b).odd) + (c : MixedColouring k ℓ (a + b)) (hc : c.IsEven), + (colourPowerEquiv k ℓ (a + b)).evenEquiv + (((powMerge (stdSuperPair k ℓ) a b) : + SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) b).even), + x ⊗ₜ[ℂ] u) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).even)) + ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then 0 + else + (colourPowerEquiv k ℓ a).oddEquiv x ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ b).oddEquiv u ⟨c.secondHalf, + c.secondHalf_not_isEven' hc h⟩) + | 0 => by + constructor + · -- ═══════ b = 0, ODD COORDINATES ═══════ + intro w c hc + -- pm(a,0) = right unitor; its oddMap sends (0, x ⊗ₜ w) to ... + -- Actually w : (superPow _ 0).even = ℂ, and the oddMap of the + -- right unitor acts on the (snd) component. + set w' : ℂ := w with hw' + have hpow : ((powMerge (stdSuperPair k ℓ) a 0 : + SuperVect.Hom _ _).oddMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) 0).odd), + x ⊗ₜ[ℂ] w') : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) 0)).odd)) = w' • x := by + change ((SuperVect.rightUnitor + (superPow (stdSuperPair k ℓ) a)).hom).oddMap + ((0 : _), x ⊗ₜ[ℂ] w') = _ + rw [SuperVect.rightUnitor_hom_oddMap] + change (TensorProduct.rid ℂ _) (x ⊗ₜ[ℂ] w') = w' • x + exact TensorProduct.rid_tmul x w' + have hfh : c.firstHalf = c := c.firstHalf_zero + -- If c.firstHalf.IsEven then c.IsEven, contradicting hc + have hfe : ¬ c.firstHalf.IsEven := hfh ▸ hc + have h0 : (colourPowerEquiv k ℓ 0).evenEquiv w + ⟨c.secondHalf, c.secondHalf_isEven_of_not hc hfe⟩ = w' := by + change (LinearEquiv.funUnique + {c : MixedColouring k ℓ 0 // c.IsEven} ℂ ℂ).symm w' _ = w' + rfl + simp only [hpow, LinearEquiv.map_smul, + dite_eq_right hfe, + show (⟨c.firstHalf, hfe⟩ : + {c : MixedColouring k ℓ a // ¬ c.IsEven}) = ⟨c, hc⟩ from + Subtype.ext hfh] + change w' * (colourPowerEquiv k ℓ (a + 0)).oddEquiv x ⟨c, hc⟩ = + (colourPowerEquiv k ℓ a).oddEquiv x ⟨c, hc⟩ * + (colourPowerEquiv k ℓ 0).evenEquiv w' ⟨c.secondHalf, + c.secondHalf_isEven_of_not hc hfe⟩ + rw [h0, mul_comm]; rfl + · -- ═══════ b = 0, EVEN COORDINATES ═══════ + -- u : (superPow _ 0).odd = PUnit odd part, which is trivial (0-dim) + intro u c hc + have hfe : c.firstHalf.IsEven := c.firstHalf_zero ▸ hc + simp only [dite_eq_left hfe] + -- pm(a,0) = right unitor; its evenMap sends (0, x ⊗ₜ u) to 0 + -- because the even part of the right unitor projects to fst, + -- and fst of (0, x ⊗ₜ u) is 0. + have hzero : ((powMerge (stdSuperPair k ℓ) a 0 : + SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) 0).even), + x ⊗ₜ[ℂ] u) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) 0)).even)) = 0 := by + change ((SuperVect.rightUnitor + (superPow (stdSuperPair k ℓ) a)).hom).evenMap + ((0 : _), x ⊗ₜ[ℂ] u) = 0 + rw [SuperVect.rightUnitor_hom_evenMap]; rfl + rw [hzero, map_zero]; rfl + | b + 1 => by + obtain ⟨ih_odd, ih_even⟩ := colourMerge_pair_odd a x b + constructor + · exact colourMerge_pair_odd_odd_step a x b ih_odd ih_even + · exact colourMerge_pair_odd_even_step a x b ih_odd ih_even + +/-- **The merge coordinate product rule (odd input)**: coordinates +of a merged odd-even pair multiply over the halves, vanishing when +the first half is even. -/ +theorem colourMerge_coord_odd {k ℓ : ℕ} (a b : ℕ) + (x : (superPow (stdSuperPair k ℓ) a).odd) + (w : (superPow (stdSuperPair k ℓ) b).even) + (c : MixedColouring k ℓ (a + b)) (hc : ¬ c.IsEven) : + (colourPowerEquiv k ℓ (a + b)).oddEquiv + (((powMerge (stdSuperPair k ℓ) a b) : + SuperVect.Hom _ _).oddMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) b).odd), + x ⊗ₜ[ℂ] w) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).odd)) + ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then 0 + else + (colourPowerEquiv k ℓ a).oddEquiv x ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ b).evenEquiv w ⟨c.secondHalf, + by exact c.secondHalf_isEven_of_not hc h⟩ := + (colourMerge_pair_odd a x b).1 w c hc + +/-- **The odd-pair merge coordinate product rule**: even +coordinates of a merged pair of odd vectors multiply over the +halves, supported on odd first halves. -/ +theorem colourMerge_coord_oddPair {k ℓ : ℕ} (a b : ℕ) + (x : (superPow (stdSuperPair k ℓ) a).odd) + (u : (superPow (stdSuperPair k ℓ) b).odd) + (c : MixedColouring k ℓ (a + b)) (hc : c.IsEven) : + (colourPowerEquiv k ℓ (a + b)).evenEquiv + (((powMerge (stdSuperPair k ℓ) a b) : + SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) b).even), + x ⊗ₜ[ℂ] u) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).even)) + ⟨c, hc⟩ = + if h : MixedColouring.IsEven c.firstHalf then 0 + else + (colourPowerEquiv k ℓ a).oddEquiv x ⟨c.firstHalf, h⟩ * + (colourPowerEquiv k ℓ b).oddEquiv u ⟨c.secondHalf, + c.secondHalf_not_isEven' hc h⟩ := + (colourMerge_pair_odd a x b).2 u c hc + +/-- Subtype coordinate singles evaluate by values: different. -/ +theorem single_val_ne {n : ℕ} + {p : MixedColouring k ℓ n → Prop} + (x y : {c : MixedColouring k ℓ n // p c}) + (h : y.val ≠ x.val) : + (Pi.single x (1 : ℂ) : + {c : MixedColouring k ℓ n // p c} → ℂ) y = 0 := + Pi.single_eq_of_ne (fun he => h (congrArg Subtype.val he)) 1 + +-- The graded single-basis-vector coordinate is +-- computed through the colouring equivalence. +/-- Subtype coordinate singles evaluate by values: same. -/ +theorem single_val_same {n : ℕ} + {p : MixedColouring k ℓ n → Prop} + (x y : {c : MixedColouring k ℓ n // p c}) + (h : x.val = y.val) : + (Pi.single x (1 : ℂ) : + {c : MixedColouring k ℓ n // p c} → ℂ) y = 1 := by + rw [show y = x from Subtype.ext h.symm] + exact Pi.single_eq_same x 1 + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPairing.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPairing.lean new file mode 100644 index 0000000000..d4b5fb1af5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPairing.lean @@ -0,0 +1,65 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPower + +/-! +# The tensor-power pairing in colouring coordinates + +The accompanying paper's pinned pairing (§5.1): + + β_d(v₁⊗⋯⊗v_d, w₁⊗⋯⊗w_d) + = (−1)^{Σ_{i if i = j then 1 else 0 + | Sum.inr a, Sum.inr b => + if a.val + ℓ = b.val then 1 + else if b.val + ℓ = a.val then -1 else 0 + | Sum.inl _, Sum.inr _ => 0 + | Sum.inr _, Sum.inl _ => 0 + +/-- The Koszul crossing count of a colouring pair: pairs of +positions `i < j` with the second argument odd at `i` and the +first odd at `j`. -/ +def koszulCrossings {k ℓ d : ℕ} + (c c' : MixedColouring k ℓ d) : ℕ := + (Finset.univ.filter (fun p : Fin d × Fin d => + p.1 < p.2 ∧ (c p.2).isRight ∧ (c' p.1).isRight)).card + +/-- **The pinned tensor-power pairing** on colouring basis +vectors. -/ +noncomputable def betaColour {k ℓ d : ℕ} + (c c' : MixedColouring k ℓ d) : ℂ := + (-1 : ℂ) ^ koszulCrossings c c' * + ∏ i : Fin d, colourFormEntry k ℓ (c i) (c' i) + +/-- Mixed positions kill the pairing. -/ +theorem betaColour_eq_zero_of_mixed {k ℓ d : ℕ} + {c c' : MixedColouring k ℓ d} (i : Fin d) + (h : (c i).isRight ≠ (c' i).isRight) : + betaColour c c' = 0 := by + unfold betaColour + rw [Finset.prod_eq_zero (Finset.mem_univ i), mul_zero] + rcases hc : c i with a | a <;> rcases hc' : c' i with b | b <;> + simp [colourFormEntry] <;> + simp [hc, hc'] at h + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPairingSymm.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPairingSymm.lean new file mode 100644 index 0000000000..a7d345f23a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPairingSymm.lean @@ -0,0 +1,244 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairing + +/-! +# S_d-invariance of the pinned pairing (Lemma 5.1(b)) + +The pinned tensor-power pairing `betaColour` is invariant under +simultaneous permutation of both colourings' positions. + +The key combinatorial fact: with matching parities the crossing +count `koszulCrossings c c'` depends only on `c.oddSet.card`, +via the identity `2 * crossings = n * (n - 1)` (upper/lower +triangle of the off-diagonal). Since permutations preserve +`oddSet.card`, the crossing count — hence the Koszul sign — is +invariant. + +The formalization does not consume this lemma: it obtains the +same `S_d`-invariance one level upstream, geometrically, from +`RS.vertexStarClass_perm`, where all legs of a vertex star meet +the same vertex and a permutation bundle map is absorbed before +the fibre functor is applied. The lemma is kept because it is a +numbered lemma of the paper. +-/ + +@[expose] public section + +namespace RS + +namespace MixedColouring + +/-- Permuting a colouring by a permutation of positions. -/ +def perm {k ℓ d : ℕ} (c : MixedColouring k ℓ d) + (π : Equiv.Perm (Fin d)) : MixedColouring k ℓ d := + fun i => c (π i) + +/-- Permuting a colouring's positions. -/ +@[simp] +theorem perm_apply {k ℓ d : ℕ} (c : MixedColouring k ℓ d) + (π : Equiv.Perm (Fin d)) (i : Fin d) : + (c.perm π) i = c (π i) := rfl + +/-- The odd support of a permuted colouring is the image of +the original odd support under `π⁻¹`. -/ +theorem oddSet_perm {k ℓ d : ℕ} (c : MixedColouring k ℓ d) + (π : Equiv.Perm (Fin d)) : + (c.perm π).oddSet = c.oddSet.map π.symm.toEmbedding := by + -- First normalise the decidability instance away from `perm` + have h0 : (c.perm π).oddSet = + Finset.univ.filter (fun i : Fin d => (c (π i)).isRight) := by + unfold oddSet + exact Finset.filter_congr (fun _ _ => Iff.rfl) + rw [h0] + ext i + simp only [Finset.mem_filter, Finset.mem_univ, true_and, + Finset.mem_map, Equiv.toEmbedding_apply] + constructor + · intro h + exact ⟨π i, by simp only [oddSet, Finset.mem_filter, + Finset.mem_univ, true_and]; exact h, π.symm_apply_apply i⟩ + · rintro ⟨j, hj, hji⟩ + simp only [oddSet, Finset.mem_filter, Finset.mem_univ, + true_and] at hj + have : π i = j := by rw [← hji]; exact π.apply_symm_apply j + rwa [this] + +/-- Permuting does not change how many positions are odd. -/ +theorem oddSet_card_perm {k ℓ d : ℕ} (c : MixedColouring k ℓ d) + (π : Equiv.Perm (Fin d)) : + (c.perm π).oddSet.card = c.oddSet.card := by + rw [oddSet_perm]; exact Finset.card_map _ + +end MixedColouring + +/-- The product of position form entries is +permutation-invariant. -/ +theorem prod_colourFormEntry_perm {k ℓ d : ℕ} + (c c' : MixedColouring k ℓ d) (π : Equiv.Perm (Fin d)) : + ∏ i, colourFormEntry k ℓ ((c.perm π) i) ((c'.perm π) i) = + ∏ i, colourFormEntry k ℓ (c i) (c' i) := + Equiv.prod_comp (π : Fin d ≃ Fin d) + (fun i => colourFormEntry k ℓ (c i) (c' i)) + +/-! ### Koszul crossing invariance -/ + +/-- With matching parities, the crossing count uses only the +first colouring's odd positions. -/ +private theorem koszulCrossings_eq_of_parity_match {k ℓ d : ℕ} + {c c' : MixedColouring k ℓ d} + (hpar : ∀ i, (c i).isRight = (c' i).isRight) : + koszulCrossings c c' = koszulCrossings c c := by + unfold koszulCrossings + congr 1; ext ⟨i, j⟩ + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + exact ⟨fun ⟨h1, h2, h3⟩ => ⟨h1, h2, (hpar i) ▸ h3⟩, + fun ⟨h1, h2, h3⟩ => ⟨h1, h2, (hpar i).symm ▸ h3⟩⟩ + +/-- The swap map bijects upper-triangle to lower-triangle pairs +in `S ×ˢ S`, so both halves have the same cardinality. -/ +private theorem card_filter_lt_eq_card_filter_gt + {α : Type*} [LinearOrder α] + (S : Finset α) : + ((S ×ˢ S).filter (fun p : α × α => p.1 < p.2)).card = + ((S ×ˢ S).filter (fun p : α × α => p.2 < p.1)).card := by + classical + have h : (S ×ˢ S).filter (fun p : α × α => p.1 < p.2) = + ((S ×ˢ S).filter (fun p : α × α => p.2 < p.1)).image + Prod.swap := by + ext ⟨a, b⟩ + simp only [Finset.mem_filter, Finset.mem_product, + Finset.mem_image, Prod.swap_prod_mk, Prod.exists, + Prod.mk.injEq] + constructor + · intro ⟨⟨ha, hb⟩, hlt⟩ + exact ⟨b, a, ⟨⟨hb, ha⟩, hlt⟩, rfl, rfl⟩ + · rintro ⟨a', b', ⟨⟨ha', hb'⟩, hlt'⟩, rfl, rfl⟩ + exact ⟨⟨hb', ha'⟩, hlt'⟩ + rw [h, Finset.card_image_of_injective _ Prod.swap_injective] + +/-- `2 * |{(i,j) ∈ S² | i < j}| = |S|² − |S|`: +the strictly-ordered pairs are exactly half the off-diagonal. -/ +private theorem two_mul_strictPairs {α : Type*} + [LinearOrder α] (S : Finset α) : + 2 * ((S ×ˢ S).filter + (fun p : α × α => p.1 < p.2)).card = + S.card * S.card - S.card := by + classical + have hcompl : + (S ×ˢ S).filter (fun p : α × α => ¬ p.1 < p.2) = + (S ×ˢ S).filter (fun p : α × α => p.1 = p.2) ∪ + (S ×ˢ S).filter (fun p : α × α => p.2 < p.1) := by + ext ⟨a, b⟩ + simp only [Finset.mem_filter, Finset.mem_product, + Finset.mem_union, not_lt] + constructor + · intro ⟨⟨ha, hb⟩, hle⟩ + rcases hle.eq_or_lt with heq | hlt + · left; exact ⟨⟨ha, hb⟩, heq.symm⟩ + · right; exact ⟨⟨ha, hb⟩, hlt⟩ + · rintro (⟨⟨ha, hb⟩, heq⟩ | ⟨⟨ha, hb⟩, hlt⟩) + · exact ⟨⟨ha, hb⟩, le_of_eq heq.symm⟩ + · exact ⟨⟨ha, hb⟩, le_of_lt hlt⟩ + have hd : Disjoint + ((S ×ˢ S).filter (fun p : α × α => p.1 = p.2)) + ((S ×ˢ S).filter (fun p : α × α => p.2 < p.1)) := by + rw [Finset.disjoint_filter] + intro ⟨a, _⟩ _ heq hlt + exact absurd hlt (not_lt.mpr (le_of_eq heq)) + have hfilt : + ((S ×ˢ S).filter (fun p : α × α => p.1 < p.2)).card + + ((S ×ˢ S).filter (fun p : α × α => ¬ p.1 < p.2)).card = + (S ×ˢ S).card := + Finset.card_filter_add_card_filter_not + (fun p : α × α => p.1 < p.2) + rw [hcompl, Finset.card_union_of_disjoint hd] at hfilt + have hswap := card_filter_lt_eq_card_filter_gt S + have hdiag : + ((S ×ˢ S).filter + (fun p : α × α => p.1 = p.2)).card = S.card := by + have : (S ×ˢ S).filter (fun p : α × α => p.1 = p.2) = + S.diag := Finset.diag_eq_filter.symm + rw [this, Finset.diag_card] + have hprod : (S ×ˢ S).card = S.card * S.card := + Finset.card_product S S + omega + +/-- Twice the self-crossing count equals `n² − n` where `n` is +the odd-set cardinality. -/ +private theorem two_mul_koszulCrossings_self {k ℓ d : ℕ} + (c : MixedColouring k ℓ d) : + 2 * koszulCrossings c c = + c.oddSet.card * c.oddSet.card - c.oddSet.card := by + have hrel : koszulCrossings c c = + ((c.oddSet ×ˢ c.oddSet).filter + (fun p : Fin d × Fin d => p.1 < p.2)).card := by + unfold koszulCrossings MixedColouring.oddSet + congr 1; ext ⟨i, j⟩ + simp only [Finset.mem_filter, Finset.mem_univ, true_and, + Finset.mem_product] + tauto + rw [hrel] + exact two_mul_strictPairs c.oddSet + +/-- Self-crossings are preserved by permutation. -/ +private theorem koszulCrossings_self_perm {k ℓ d : ℕ} + (c : MixedColouring k ℓ d) (π : Equiv.Perm (Fin d)) : + koszulCrossings (c.perm π) (c.perm π) = + koszulCrossings c c := by + have h1 := two_mul_koszulCrossings_self (c.perm π) + have h2 := two_mul_koszulCrossings_self c + rw [MixedColouring.oddSet_card_perm] at h1 + have h3 := h1.trans h2.symm + omega + +/-- Crossings are preserved by permutation when parities +match. -/ +private theorem koszulCrossings_perm {k ℓ d : ℕ} + (c c' : MixedColouring k ℓ d) + (π : Equiv.Perm (Fin d)) + (hpar : ∀ i, (c i).isRight = (c' i).isRight) : + koszulCrossings (c.perm π) (c'.perm π) = + koszulCrossings c c' := by + rw [koszulCrossings_eq_of_parity_match (fun i => by + simp only [MixedColouring.perm_apply] + exact hpar (π i)), + koszulCrossings_eq_of_parity_match hpar, + koszulCrossings_self_perm] + +/-- **Lemma 5.1(b)**: the pinned pairing is S_d-invariant on +the support (matching parities). -/ +theorem betaColour_perm {k ℓ d : ℕ} (π : Equiv.Perm (Fin d)) + (c c' : MixedColouring k ℓ d) + (hpar : ∀ i, (c i).isRight = (c' i).isRight) : + betaColour (c.perm π) (c'.perm π) = betaColour c c' := by + unfold betaColour + congr 1 + · congr 1; exact koszulCrossings_perm c c' π hpar + · exact prod_colourFormEntry_perm c c' π + +/-- **Lemma 5.1(b), unconditional**: the pinned pairing is +S_d-invariant. Off the support both sides vanish. -/ +theorem betaColour_perm' {k ℓ d : ℕ} (π : Equiv.Perm (Fin d)) + (c c' : MixedColouring k ℓ d) : + betaColour (c.perm π) (c'.perm π) = betaColour c c' := by + by_cases hpar : ∀ i, (c i).isRight = (c' i).isRight + · exact betaColour_perm π c c' hpar + · push Not at hpar + obtain ⟨i, hi⟩ := hpar + have hmix : betaColour c c' = 0 := + betaColour_eq_zero_of_mixed i hi + have hmix' : betaColour (c.perm π) (c'.perm π) = 0 := by + apply betaColour_eq_zero_of_mixed (π.symm i) + simp only [MixedColouring.perm_apply, + Equiv.apply_symm_apply] + exact hi + rw [hmix, hmix'] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPower.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPower.lean new file mode 100644 index 0000000000..54b2aef2ce --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPower.lean @@ -0,0 +1,328 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdSuper + +/-! +# The colouring model of tensor powers + +The `d`-th tensor power of the standard super space +`stdSuperPair k ℓ` in the pair-component model is an exponentially +nested product. The colouring model flattens it: a basis vector +of the power is a *mixed colouring* — each of the `d` positions +carries an even colour in `Fin k` or an odd colour in +`Fin (2ℓ)` — and the power is the space of functions on +colourings, graded by the parity of the odd support. All the +§5–6 network maps become colouring combinatorics in this model, +meshing directly with the mixed partition function's +Definition-5 sum. +-/ + +@[expose] public section + +open scoped TensorProduct + +namespace RS + +/-- A mixed colouring of `d` tensor positions: each position an +even colour or an odd colour. -/ +abbrev MixedColouring (k ℓ d : ℕ) : Type := + Fin d → (Fin k ⊕ Fin (2 * ℓ)) + +namespace MixedColouring + +/-- Colourings of finitely many slots by finitely many colours are +finite in number. -/ +instance (k ℓ d : ℕ) : Fintype (MixedColouring k ℓ d) := + inferInstanceAs (Fintype (Fin d → Fin k ⊕ Fin (2 * ℓ))) + +/-- And can be compared. -/ +instance (k ℓ d : ℕ) : DecidableEq (MixedColouring k ℓ d) := + inferInstanceAs (DecidableEq (Fin d → Fin k ⊕ Fin (2 * ℓ))) + +/-- The odd positions of a colouring. -/ +def oddSet {k ℓ d : ℕ} (c : MixedColouring k ℓ d) : + Finset (Fin d) := + Finset.univ.filter (fun i => (c i).isRight) + +/-- A colouring is even when its odd support has even size. -/ +def IsEven {k ℓ d : ℕ} (c : MixedColouring k ℓ d) : Prop := + Even c.oddSet.card + +/-- Whether a colouring is even is decidable. -/ +instance {k ℓ d : ℕ} (c : MixedColouring k ℓ d) : + Decidable c.IsEven := + inferInstanceAs (Decidable (Even c.oddSet.card)) + +end MixedColouring + +/-- **The colouring model** of the `d`-th tensor power of the +standard super space: functions on mixed colourings, graded by +the parity of the odd support. -/ +noncomputable def colourPower (k ℓ d : ℕ) : SuperVect where + even := {c : MixedColouring k ℓ d // c.IsEven} → ℂ + odd := {c : MixedColouring k ℓ d // ¬ c.IsEven} → ℂ + +/-- A grading-preserving linear equivalence of super vector +spaces. -/ +structure SuperLinearEquiv (V W : SuperVect) where + /-- The even component. -/ + evenEquiv : V.even ≃ₗ[ℂ] W.even + /-- The odd component. -/ + oddEquiv : V.odd ≃ₗ[ℂ] W.odd + +/-- The tensor product of function spaces on finite types is the +function space on the product. -/ +noncomputable def funTensorFun (ι κ : Type) [Fintype ι] + [Fintype κ] : + ((ι → ℂ) ⊗[ℂ] (κ → ℂ)) ≃ₗ[ℂ] (ι × κ → ℂ) := + (TensorProduct.congr + (Finsupp.linearEquivFunOnFinite ℂ ℂ ι).symm + (Finsupp.linearEquivFunOnFinite ℂ ℂ κ).symm).trans + ((finsuppTensorFinsupp' ℂ ι κ).trans + (Finsupp.linearEquivFunOnFinite ℂ ℂ (ι × κ))) + +/-- The iterated monoidal power of a super vector space, new +factors on the right. -/ +noncomputable def superPow (V : SuperVect) : ℕ → SuperVect + | 0 => SuperVect.tensorUnit + | d + 1 => SuperVect.tensorObj (superPow V d) V + +/-! ### Splitting a colouring at its last position -/ + +namespace MixedColouring + +/-- The tail of a colouring: the first `d` positions. -/ +def tail {k ℓ d : ℕ} (c : MixedColouring k ℓ (d + 1)) : + MixedColouring k ℓ d := + fun i => c i.castSucc + +/-- The odd support splits at the last position. -/ +theorem oddSet_card_succ {k ℓ d : ℕ} + (c : MixedColouring k ℓ (d + 1)) : + c.oddSet.card = c.tail.oddSet.card + + (if (c (Fin.last d)).isRight then 1 else 0) := by + unfold oddSet tail + rw [Finset.card_filter, Finset.card_filter, + Fin.sum_univ_castSucc] + +/-- Parity of the extension, last position even. -/ +theorem isEven_succ_left {k ℓ d : ℕ} + (c : MixedColouring k ℓ (d + 1)) (a : Fin k) + (h : c (Fin.last d) = Sum.inl a) : + (c.IsEven ↔ c.tail.IsEven) := by + unfold IsEven + rw [oddSet_card_succ, h] + simp + +/-- Parity of the extension, last position odd. -/ +theorem isEven_succ_right {k ℓ d : ℕ} + (c : MixedColouring k ℓ (d + 1)) (b : Fin (2 * ℓ)) + (h : c (Fin.last d) = Sum.inr b) : + (c.IsEven ↔ ¬ c.tail.IsEven) := by + unfold IsEven + rw [oddSet_card_succ, h] + simp [Nat.even_add_one] + +end MixedColouring + +/-- Splitting a colouring at its last position. -/ +noncomputable def colouringSplit (k ℓ d : ℕ) : + MixedColouring k ℓ (d + 1) ≃ + MixedColouring k ℓ d × (Fin k ⊕ Fin (2 * ℓ)) where + toFun c := (MixedColouring.tail c, c (Fin.last d)) + invFun p := + Fin.snoc (α := fun _ => Fin k ⊕ Fin (2 * ℓ)) p.1 p.2 + left_inv c := by + funext i + refine Fin.lastCases ?_ (fun j => ?_) i <;> + simp [MixedColouring.tail] + right_inv p := by + refine Prod.ext (funext fun i => ?_) ?_ <;> + simp [MixedColouring.tail] + +/-- Parity through the split. -/ +theorem MixedColouring.isEven_split {k ℓ d : ℕ} + (c : MixedColouring k ℓ (d + 1)) : + c.IsEven ↔ Sum.elim + (fun _ : Fin k => c.tail.IsEven) + (fun _ : Fin (2 * ℓ) => ¬ c.tail.IsEven) + (c (Fin.last d)) := by + rcases h : c (Fin.last d) with a | b + · simp only [Sum.elim_inl] + exact c.isEven_succ_left a h + · simp only [Sum.elim_inr] + exact c.isEven_succ_right b h + +/-- A subtype of a product by a condition on the first factor. -/ +def subtypeProdFst {A X : Type} (Q : A → Prop) : + {p : A × X // Q p.1} ≃ {a : A // Q a} × X where + toFun p := (⟨p.val.1, p.prop⟩, p.val.2) + invFun q := ⟨(q.1.val, q.2), q.1.prop⟩ + left_inv _p := rfl + right_inv _q := rfl + +/-- The even colourings of `d + 1` positions split by the last +colour: an even colour on an even tail, or an odd colour on an +odd tail. -/ +noncomputable def evenSplitEquiv (k ℓ d : ℕ) : + {c : MixedColouring k ℓ (d + 1) // c.IsEven} ≃ + ({c : MixedColouring k ℓ d // c.IsEven} × Fin k) ⊕ + ({c : MixedColouring k ℓ d // ¬ c.IsEven} × + Fin (2 * ℓ)) := + (((colouringSplit k ℓ d).subtypeEquiv + (q := fun p => Sum.elim + (fun _ : Fin k => p.1.IsEven) + (fun _ : Fin (2 * ℓ) => ¬ p.1.IsEven) p.2) + (fun c => by + rw [MixedColouring.isEven_split c] + exact Iff.rfl)).trans + (((Equiv.prodSumDistrib (MixedColouring k ℓ d) + (Fin k) (Fin (2 * ℓ))).subtypeEquiv + (q := Sum.elim + (fun ta : MixedColouring k ℓ d × Fin k => ta.1.IsEven) + (fun tb : MixedColouring k ℓ d × Fin (2 * ℓ) => + ¬ tb.1.IsEven)) + (fun p => by + rcases p with ⟨t, a | b⟩ <;> exact Iff.rfl)).trans + ((Equiv.subtypeSum).trans + (Equiv.sumCongr + (subtypeProdFst (fun t : MixedColouring k ℓ d => + t.IsEven)) + (subtypeProdFst (fun t : MixedColouring k ℓ d => + ¬ t.IsEven)))))) + +/-- The odd colourings of `d + 1` positions split by the last +colour: an even colour on an odd tail, or an odd colour on an +even tail. -/ +noncomputable def oddSplitEquiv (k ℓ d : ℕ) : + {c : MixedColouring k ℓ (d + 1) // ¬ c.IsEven} ≃ + ({c : MixedColouring k ℓ d // ¬ c.IsEven} × Fin k) ⊕ + ({c : MixedColouring k ℓ d // c.IsEven} × + Fin (2 * ℓ)) := + (((colouringSplit k ℓ d).subtypeEquiv + (q := fun p => Sum.elim + (fun _ : Fin k => ¬ p.1.IsEven) + (fun _ : Fin (2 * ℓ) => p.1.IsEven) p.2) + (fun c => by + rw [show (¬ c.IsEven) ↔ _ from + not_iff_not.mpr (MixedColouring.isEven_split c)] + rw [show ((colouringSplit k ℓ d) c).2 = + c (Fin.last d) from rfl] + rcases c (Fin.last d) with a | b <;> + simp only [Sum.elim_inl, Sum.elim_inr, not_not] <;> + exact Iff.rfl)).trans + (((Equiv.prodSumDistrib (MixedColouring k ℓ d) + (Fin k) (Fin (2 * ℓ))).subtypeEquiv + (q := Sum.elim + (fun ta : MixedColouring k ℓ d × Fin k => + ¬ ta.1.IsEven) + (fun tb : MixedColouring k ℓ d × Fin (2 * ℓ) => + tb.1.IsEven)) + (fun p => by + rcases p with ⟨t, a | b⟩ <;> exact Iff.rfl)).trans + ((Equiv.subtypeSum).trans + (Equiv.sumCongr + (subtypeProdFst (fun t : MixedColouring k ℓ d => + ¬ t.IsEven)) + (subtypeProdFst (fun t : MixedColouring k ℓ d => + t.IsEven)))))) + +/-! ### The equivalence with the iterated power -/ + +namespace SuperLinearEquiv + +/-- The identity super linear equivalence. -/ +noncomputable def refl (V : SuperVect) : SuperLinearEquiv V V := + ⟨LinearEquiv.refl ℂ _, LinearEquiv.refl ℂ _⟩ + +/-- Composition of super linear equivalences. -/ +noncomputable def trans {U V W : SuperVect} + (e : SuperLinearEquiv U V) (e' : SuperLinearEquiv V W) : + SuperLinearEquiv U W := + ⟨e.evenEquiv.trans e'.evenEquiv, e.oddEquiv.trans e'.oddEquiv⟩ + +/-- The tensor of super linear equivalences. -/ +noncomputable def tensorCongr {V V' W W' : SuperVect} + (e : SuperLinearEquiv V V') (e' : SuperLinearEquiv W W') : + SuperLinearEquiv (SuperVect.tensorObj V W) + (SuperVect.tensorObj V' W') := + ⟨LinearEquiv.prodCongr + (TensorProduct.congr e.evenEquiv e'.evenEquiv) + (TensorProduct.congr e.oddEquiv e'.oddEquiv), + LinearEquiv.prodCongr + (TensorProduct.congr e.evenEquiv e'.oddEquiv) + (TensorProduct.congr e.oddEquiv e'.evenEquiv)⟩ + +end SuperLinearEquiv + +/-- At `d = 0` there is exactly one even colouring, the empty +one. -/ +instance colourZeroEvenUnique (k ℓ : ℕ) : + Unique {c : MixedColouring k ℓ 0 // c.IsEven} where + default := ⟨(default : Fin 0 → Fin k ⊕ Fin (2 * ℓ)), + ⟨0, by simp [MixedColouring.oddSet]⟩⟩ + uniq x := Subtype.ext (Subsingleton.elim _ _) + +/-- And no odd one: the zeroth power is purely even. -/ +instance colourZeroOddEmpty (k ℓ : ℕ) : + IsEmpty {c : MixedColouring k ℓ 0 // ¬ c.IsEven} := + ⟨fun x => x.prop (by + have h : x.val = (default : Fin 0 → Fin k ⊕ Fin (2 * ℓ)) := + Subsingleton.elim _ _ + rw [MixedColouring.IsEven, h] + exact ⟨0, by simp [MixedColouring.oddSet]⟩)⟩ + +/-- The base of the recursion: the zeroth power is the colouring +model of zero positions. -/ +noncomputable def colourPowerZero (k ℓ : ℕ) : + SuperLinearEquiv SuperVect.tensorUnit (colourPower k ℓ 0) := + ⟨(LinearEquiv.funUnique + {c : MixedColouring k ℓ 0 // c.IsEven} ℂ ℂ).symm, + show SuperVect.tensorUnit.odd ≃ₗ[ℂ] + ({c : MixedColouring k ℓ 0 // ¬ c.IsEven} → ℂ) from + LinearEquiv.ofSubsingleton _ _⟩ + +/-- The step of the recursion: tensoring the colouring model with +the standard space extends the colourings by one position. -/ +noncomputable def colourPowerStep (k ℓ d : ℕ) : + SuperLinearEquiv + (SuperVect.tensorObj (colourPower k ℓ d) (stdSuperPair k ℓ)) + (colourPower k ℓ (d + 1)) := + ⟨(LinearEquiv.prodCongr + (funTensorFun {c : MixedColouring k ℓ d // c.IsEven} + (Fin k)) + (funTensorFun {c : MixedColouring k ℓ d // ¬ c.IsEven} + (Fin (2 * ℓ)))).trans + ((LinearEquiv.sumArrowLequivProdArrow _ _ ℂ ℂ).symm.trans + (LinearEquiv.piCongrLeft' ℂ (fun _ => ℂ) + (evenSplitEquiv k ℓ d).symm)), + (LinearEquiv.prodCongr + (funTensorFun {c : MixedColouring k ℓ d // c.IsEven} + (Fin (2 * ℓ))) + (funTensorFun {c : MixedColouring k ℓ d // ¬ c.IsEven} + (Fin k))).trans + ((LinearEquiv.sumArrowLequivProdArrow _ _ ℂ ℂ).symm.trans + ((LinearEquiv.piCongrLeft' ℂ (fun _ => ℂ) + (Equiv.sumComm _ _)).trans + (LinearEquiv.piCongrLeft' ℂ (fun _ => ℂ) + (oddSplitEquiv k ℓ d).symm)))⟩ + +/-- **The colouring model of the iterated power**: the `d`-th +monoidal power of the standard super space is the colouring +model. -/ +noncomputable def colourPowerEquiv (k ℓ : ℕ) : (d : ℕ) → + SuperLinearEquiv (superPow (stdSuperPair k ℓ) d) + (colourPower k ℓ d) + | 0 => colourPowerZero k ℓ + | d + 1 => + (SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ d) + (SuperLinearEquiv.refl (stdSuperPair k ℓ))).trans + (colourPowerStep k ℓ d) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourTotal.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourTotal.lean new file mode 100644 index 0000000000..0a899c2dc2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourTotal.lean @@ -0,0 +1,94 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.TotalSpace +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelPermCoord + +/-! +# The total colouring coordinates + +Combining the even and odd coordinate functions identifies the total +tensor space with all functions on colour words. The model permutation +acts there by reindexing and its odd-inversion sign. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +noncomputable section + +variable {k ℓ n : ℕ} + +/-- Splitting a colour function into its even and odd restrictions. -/ +def colourSplit (k ℓ n : ℕ) : + (MixedColouring k ℓ n → ℂ) ≃ₗ[ℂ] Tot (colourPower k ℓ n) where + __ := Equiv.piEquivPiSubtypeProd MixedColouring.IsEven (fun _ => ℂ) + map_add' _ _ := rfl + map_smul' _ _ := rfl + +/-- The total tensor space in coordinates indexed by all colour words. -/ +def colourTotalEquiv (k ℓ n : ℕ) : + Tot (superPow (stdSuperPair k ℓ) n) ≃ₗ[ℂ] + (MixedColouring k ℓ n → ℂ) := + ((colourPowerEquiv k ℓ n).evenEquiv.prodCongr + (colourPowerEquiv k ℓ n).oddEquiv).trans (colourSplit k ℓ n).symm + +private theorem colourSplit_symm_apply + (v : Tot (colourPower k ℓ n)) (c : MixedColouring k ℓ n) : + (colourSplit k ℓ n).symm v c = + if hc : c.IsEven then v.1 ⟨c, hc⟩ else v.2 ⟨c, hc⟩ := rfl + +private theorem colourTotalEquiv_conj + (g : superPow (stdSuperPair k ℓ) n ⟶ + superPow (stdSuperPair k ℓ) n) + (v : MixedColouring k ℓ n → ℂ) : + colourTotalEquiv k ℓ n + (tot g ((colourTotalEquiv k ℓ n).symm v)) = + (colourSplit k ℓ n).symm + (tot (toColour n g) (colourSplit k ℓ n v)) := rfl + +/-- The total model action has the Koszul monomial coordinates at +every arity, including arity zero. -/ +theorem colourTotalEquiv_modelPermMap + (σ : _root_.Equiv.Perm (Fin n)) + (v : MixedColouring k ℓ n → ℂ) (c : MixedColouring k ℓ n) : + colourTotalEquiv k ℓ n + (tot (modelPermMap σ) ((colourTotalEquiv k ℓ n).symm v)) c = + (-1 : ℂ) ^ oddInversions σ c * v (c ∘ σ) := by + cases n with + | zero => + have hσ : σ = 1 := Subsingleton.elim _ _ + subst σ + rw [show modelPermMap (1 : _root_.Equiv.Perm (Fin 0)) = + 𝟙 (superPow (stdSuperPair k ℓ) 0) from rfl, tot_id] + simp [oddInversions] + | succ n => + rw [colourTotalEquiv_conj] + change (colourSplit k ℓ (n + 1)).symm + (tot (toColour (n + 1) + (powBraidWord (stdSuperPair k ℓ) (adjWord σ))) + (colourSplit k ℓ (n + 1) v)) c = _ + rw [toColour_powBraidWord, colourSplit_symm_apply] + by_cases hc : c.IsEven + · rw [dite_eq_left hc] + change (colourSwapWord k ℓ (adjWord σ)).evenMap + (fun a => v a.val) ⟨c, hc⟩ = _ + erw [colourSwapWord_evenMap, wordSign_eq_oddInversions, + wordPerm_adjWord] + · rw [dite_eq_right hc] + change (colourSwapWord k ℓ (adjWord σ)).oddMap + (fun a => v a.val) ⟨c, hc⟩ = _ + erw [colourSwapWord_oddMap, wordSign_eq_oddInversions, + wordPerm_adjWord] + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourWord.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourWord.lean new file mode 100644 index 0000000000..9af087fa60 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourWord.lean @@ -0,0 +1,132 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourExtendSwap +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BraidWord + +/-! +# The colour-side braiding word + +The word of signed adjacent swaps on the colouring model, with +its evaluation: acting on a coordinate function reindexes the +colouring along the word's permutation and multiplies by the +word's Koszul sign, computed stepwise along the colouring's own +trajectory. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +variable {k ℓ : ℕ} + +/-- The colour-side braiding word. -/ +noncomputable def colourSwapWord (k ℓ : ℕ) {n : ℕ} : + List (Fin n) → + (colourPower k ℓ (n + 1) ⟶ colourPower k ℓ (n + 1)) + | [] => 𝟙 _ + | i :: w => colourSwapWord k ℓ w ≫ + colourSwap k ℓ (n + 1) i.val (by omega) + +/-- The Koszul sign of a word along a colouring's trajectory: +each step contributes the adjacent sign at the colouring reached +so far. -/ +def wordSign {n : ℕ} : + List (Fin n) → MixedColouring k ℓ (n + 1) → ℂ + | [], _ => 1 + | i :: w, c => + adjSign c ⟨i.val, by omega⟩ ⟨i.val + 1, by omega⟩ * + wordSign w (c ∘ _root_.Equiv.swap + (⟨i.val, by omega⟩ : Fin (n + 1)) + ⟨i.val + 1, by omega⟩) + +/-- The permutation of a word of adjacent swaps. -/ +def wordPerm {n : ℕ} : + List (Fin n) → _root_.Equiv.Perm (Fin (n + 1)) + | [] => 1 + | i :: w => _root_.Equiv.swap + (⟨i.val, by omega⟩ : Fin (n + 1)) + ⟨i.val + 1, by omega⟩ * (wordPerm w) + +/-- **The word evaluation**: the colour word acts on even +coordinate functions by the word sign and the word reindex. -/ +theorem colourSwapWord_evenMap {n : ℕ} (w : List (Fin n)) + (F : (colourPower k ℓ (n + 1)).even) + (c : {c : MixedColouring k ℓ (n + 1) // c.IsEven}) : + ((colourSwapWord k ℓ w) : SuperVect.Hom _ _).evenMap F c = + wordSign w c.val * + F ⟨c.val ∘ wordPerm w, c.prop.comp _⟩ := by + induction w generalizing c with + | nil => + change F c = 1 * F ⟨c.val ∘ (1 : _root_.Equiv.Perm + (Fin (n + 1))), c.prop.comp _⟩ + rw [one_mul] + exact congrArg F (Subtype.ext rfl) + | cons i w ih => + change ((colourSwap k ℓ (n + 1) i.val (by omega)) : + SuperVect.Hom _ _).evenMap + (((colourSwapWord k ℓ w) : + SuperVect.Hom _ _).evenMap F) c = _ + change adjSign c.val ⟨i.val, by omega⟩ + ⟨i.val + 1, by omega⟩ * + (((colourSwapWord k ℓ w) : + SuperVect.Hom _ _).evenMap F) + ⟨c.val ∘ _root_.Equiv.swap + (⟨i.val, by omega⟩ : Fin (n + 1)) + ⟨i.val + 1, by omega⟩, c.prop.comp _⟩ = _ + rw [ih] + change adjSign c.val ⟨i.val, by omega⟩ + ⟨i.val + 1, by omega⟩ * + (wordSign w (c.val ∘ _root_.Equiv.swap + (⟨i.val, by omega⟩ : Fin (n + 1)) + ⟨i.val + 1, by omega⟩) * + F ⟨(c.val ∘ _root_.Equiv.swap + (⟨i.val, by omega⟩ : Fin (n + 1)) + ⟨i.val + 1, by omega⟩) ∘ wordPerm w, _⟩) = _ + rw [← mul_assoc] + change (adjSign c.val ⟨i.val, by omega⟩ + ⟨i.val + 1, by omega⟩ * + wordSign w (c.val ∘ _root_.Equiv.swap + (⟨i.val, by omega⟩ : Fin (n + 1)) + ⟨i.val + 1, by omega⟩)) * + F ⟨(c.val ∘ _root_.Equiv.swap + (⟨i.val, by omega⟩ : Fin (n + 1)) + ⟨i.val + 1, by omega⟩) ∘ wordPerm w, _⟩ = + wordSign (i :: w) c.val * + F ⟨c.val ∘ wordPerm (i :: w), c.prop.comp _⟩ + refine congrArg₂ (fun a b => a * b) rfl ?_ + exact congrArg F (Subtype.ext (funext (fun j => rfl))) + +/-- The word evaluation on odd coordinate functions uses the same +word sign and permutation of positions. -/ +theorem colourSwapWord_oddMap {n : ℕ} (w : List (Fin n)) + (F : (colourPower k ℓ (n + 1)).odd) + (c : {c : MixedColouring k ℓ (n + 1) // ¬ c.IsEven}) : + ((colourSwapWord k ℓ w) : SuperVect.Hom _ _).oddMap F c = + wordSign w c.val * + F ⟨c.val ∘ wordPerm w, + MixedColouring.not_isEven_comp c.prop _⟩ := by + induction w generalizing c with + | nil => + change F c = 1 * F ⟨c.val ∘ (1 : _root_.Equiv.Perm + (Fin (n + 1))), MixedColouring.not_isEven_comp c.prop _⟩ + rw [one_mul] + exact congrArg F (Subtype.ext rfl) + | cons i w ih => + change adjSign c.val ⟨i.val, by omega⟩ ⟨i.val + 1, by omega⟩ * + ((colourSwapWord k ℓ w) : SuperVect.Hom _ _).oddMap F + ⟨c.val ∘ _root_.Equiv.swap + (⟨i.val, by omega⟩ : Fin (n + 1)) + ⟨i.val + 1, by omega⟩, + MixedColouring.not_isEven_comp c.prop _⟩ = _ + rw [ih, ← mul_assoc] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/OrthonormalBasis.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/OrthonormalBasis.lean new file mode 100644 index 0000000000..4197d8845a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/OrthonormalBasis.lean @@ -0,0 +1,81 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Orthonormal basis for nondegenerate symmetric bilinear + forms + +For a finite-dimensional complex vector space `V` equipped +with a symmetric nondegenerate bilinear form `B`, there +exists an orthonormal basis — a basis `b` indexed by +`Fin (finrank ℂ V)` such that +`B (b i) (b j) = if i = j then 1 else 0`. + +The proof proceeds by: + +1. Using `exists_orthogonal_basis` (Mathlib) to obtain an + orthogonal basis `b₀` with `B (b₀ i) (b₀ j) = 0` for + `i ≠ j`. +2. Showing each diagonal value `B (b₀ i) (b₀ i) ≠ 0` + via nondegeneracy. +3. Rescaling by inverse square roots (which exist over `ℂ` + since `ℂ` is algebraically closed) to normalise the + diagonal entries to `1`. +-/ + +@[expose] public section + +noncomputable section + +namespace RS + +open LinearMap (BilinForm) +open LinearMap.BilinForm +open Module Submodule FiniteDimensional + +/-- **Orthonormal basis**: a finite-dimensional complex +vector space carrying a symmetric nondegenerate bilinear +form admits a basis `b` such that +`B (b i) (b j) = if i = j then 1 else 0`. -/ +theorem exists_orthonormal_basis + {V : Type*} [AddCommGroup V] [Module ℂ V] + [FiniteDimensional ℂ V] + (B : BilinForm ℂ V) + (hsymm : ∀ x y, B x y = B y x) + (hnd : ∀ x, (∀ y, B x y = 0) → x = 0) : + ∃ b : Basis (Fin (finrank ℂ V)) ℂ V, + ∀ i j, B (b i) (b j) = + if i = j then 1 else 0 := by + -- Orthogonal basis (Invertible 2 via CharZero ℂ) + obtain ⟨b₀, hortho⟩ := + exists_orthogonal_basis + (isSymm_iff.mp ⟨hsymm⟩) + -- Diagonal entries nonzero by nondegeneracy + have hdiag : ∀ i, B (b₀ i) (b₀ i) ≠ 0 := + hortho.not_isOrtho_basis_self_of_separatingLeft + hnd + -- Square roots exist over ℂ (algebraically closed) + choose s hs using fun i => + IsAlgClosed.exists_eq_mul_self + (B (b₀ i) (b₀ i)) + have hs_ne : ∀ i, s i ≠ 0 := fun i hi => + hdiag i (by rw [hs i, hi, mul_zero]) + -- Rescale by inverse square roots + refine ⟨b₀.unitsSMul (fun i => + Units.mk0 (s i)⁻¹ (inv_ne_zero (hs_ne i))), + fun i j => ?_⟩ + simp only [Basis.unitsSMul_apply, + Units.smul_def, Units.val_mk0, + map_smul, LinearMap.smul_apply, smul_eq_mul] + split_ifs with hij + · subst hij; rw [hs i]; field_simp [hs_ne i] + · rw [hortho hij, mul_zero, mul_zero] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/PowBraid.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/PowBraid.lean new file mode 100644 index 0000000000..581b5206c9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/PowBraid.lean @@ -0,0 +1,124 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPower + +/-! +# Adjacent braidings on monoidal powers + +The braiding of two adjacent factors of a monoidal power: the top +case conjugates the braiding through one associator, and lower +positions whisker the smaller power's braiding. On the colouring +model the intended action is the Koszul-signed position swap, +defined here; the identification is the coordinate workhorse of +the extraction. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +/-- The top adjacent braiding on a monoidal power: braid the last +two factors through the associator. -/ +noncomputable def topBraid (V : SuperVect) (m : ℕ) : + superPow V (m + 2) ⟶ superPow V (m + 2) := + (α_ (superPow V m) V V).hom ≫ + (superPow V m ◁ (β_ V V).hom) ≫ + (α_ (superPow V m) V V).inv + +/-- The adjacent braiding at position `i`: swap the factors at +zero-based positions `i` and `i + 1`. -/ +noncomputable def powBraid (V : SuperVect) : + (n : ℕ) → (i : ℕ) → i + 2 ≤ n → + (superPow V n ⟶ superPow V n) + | 0, _, h => absurd h (by omega) + | 1, _, h => absurd h (by omega) + | n + 2, i, h => + if hi : i = n then topBraid V n + else (powBraid V (n + 1) i (by omega)) ▷ V + +/-- Reindexing a colouring along a permutation preserves the odd +count. -/ +theorem MixedColouring.oddSet_comp_card {k ℓ d : ℕ} + (c : MixedColouring k ℓ d) (σ : _root_.Equiv.Perm (Fin d)) : + (MixedColouring.oddSet (c ∘ σ)).card = + c.oddSet.card := by + refine Finset.card_bij (fun i _ => σ i) ?_ ?_ ?_ + · intro i hi + simp only [MixedColouring.oddSet, Finset.mem_filter, + Finset.mem_univ, true_and] at hi ⊢ + exact hi + · intro a _ b _ hab + exact σ.injective hab + · intro j hj + refine ⟨σ.symm j, ?_, σ.apply_symm_apply j⟩ + simp only [MixedColouring.oddSet, Finset.mem_filter, + Finset.mem_univ, true_and, + Function.comp_apply, σ.apply_symm_apply] at hj ⊢ + exact hj + +/-- Reindexing preserves evenness. -/ +theorem MixedColouring.IsEven.comp {k ℓ d : ℕ} + {c : MixedColouring k ℓ d} + (hc : c.IsEven) (σ : _root_.Equiv.Perm (Fin d)) : + MixedColouring.IsEven (c ∘ σ) := by + unfold MixedColouring.IsEven + rw [MixedColouring.oddSet_comp_card c σ] + exact hc + +/-- Reindexing preserves oddness. -/ +theorem MixedColouring.not_isEven_comp {k ℓ d : ℕ} + {c : MixedColouring k ℓ d} + (hc : ¬ c.IsEven) (σ : _root_.Equiv.Perm (Fin d)) : + ¬ MixedColouring.IsEven (c ∘ σ) := by + intro hcontra + apply hc + unfold MixedColouring.IsEven at hcontra ⊢ + rw [MixedColouring.oddSet_comp_card c σ] at hcontra + exact hcontra + +/-- The Koszul sign of swapping two positions of a colouring: +`−1` when both are odd. -/ +def adjSign {k ℓ d : ℕ} (c : MixedColouring k ℓ d) + (a b : Fin d) : ℂ := + if (c a).isRight ∧ (c b).isRight then -1 else 1 + +/-- The Koszul-signed adjacent position swap on the colouring +model. -/ +noncomputable def colourSwap (k ℓ : ℕ) : + (n : ℕ) → (i : ℕ) → i + 2 ≤ n → + (colourPower k ℓ n ⟶ colourPower k ℓ n) := + fun n i h => + { evenMap := + { toFun := fun F c => + adjSign c.val ⟨i, by omega⟩ ⟨i + 1, by omega⟩ * + F ⟨c.val ∘ _root_.Equiv.swap + (⟨i, by omega⟩ : Fin n) ⟨i + 1, by omega⟩, + c.prop.comp _⟩ + map_add' := fun F G => by + funext c + exact mul_add _ (F _) (G _) + map_smul' := fun r F => by + funext c + exact mul_left_comm _ r (F _) } + oddMap := + { toFun := fun F c => + adjSign c.val ⟨i, by omega⟩ ⟨i + 1, by omega⟩ * + F ⟨c.val ∘ _root_.Equiv.swap + (⟨i, by omega⟩ : Fin n) ⟨i + 1, by omega⟩, + MixedColouring.not_isEven_comp c.prop _⟩ + map_add' := fun F G => by + funext c + exact mul_add _ (F _) (G _) + map_smul' := fun r F => by + funext c + exact mul_left_comm _ r (F _) } } + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/SuperVect.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/SuperVect.lean new file mode 100644 index 0000000000..596d746dbf --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/SuperVect.lean @@ -0,0 +1,189 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Definitions + +/-! +# Unit-prefixed associator and braiding values in SuperVect + +The category **SuperVect** — finite-dimensional ℤ/2-graded complex +vector spaces with the graded tensor product and the Koszul +braiding — is defined, with its monoidal, braided, symmetric, +additive and ℂ-linear structure, in `RS/Definitions.lean`. This +module carries the value computations the extraction consumes: the +unit-prefixed associator and inverse associator on the four graded +blocks, and the braiding on the four generator shapes, including +the Koszul sign on odd⊗odd. +-/ + +@[expose] public section + +noncomputable section + +namespace RS + +open CategoryTheory +open scoped TensorProduct + +namespace SuperVect + +/-! ### Unit-prefixed associator and braiding values -/ + +/-- The unit-prefixed associator on the even-even block. -/ +theorem assoc_unit_ee {V : SuperVect} (r : ℂ) (x y : V.even) : + (associator tensorUnit V V).hom.evenMap + (((r ⊗ₜ[ℂ] x, (0 : tensorUnit.odd ⊗[ℂ] V.odd)) ⊗ₜ[ℂ] y, + (0 : ((tensorUnit.even ⊗[ℂ] V.odd) × + (tensorUnit.odd ⊗[ℂ] V.even)) ⊗[ℂ] V.odd))) = + ((r ⊗ₜ[ℂ] ((x ⊗ₜ[ℂ] y, + (0 : V.odd ⊗[ℂ] V.odd)) : + (tensorObj V V).even)), + (0 : tensorUnit.odd ⊗[ℂ] (tensorObj V V).odd)) := by + change assocEvenEquiv tensorUnit V V _ = _ + exact assocAux_ee r x y + +/-- The unit-prefixed associator on the odd-odd block. -/ +theorem assoc_unit_oo {V : SuperVect} (r : ℂ) (u v : V.odd) : + (associator tensorUnit V V).hom.evenMap + (((0 : ((tensorUnit.even ⊗[ℂ] V.even) × + (tensorUnit.odd ⊗[ℂ] V.odd)) ⊗[ℂ] V.even), + (r ⊗ₜ[ℂ] u, (0 : tensorUnit.odd ⊗[ℂ] V.even)) + ⊗ₜ[ℂ] v)) = + ((r ⊗ₜ[ℂ] (((0 : V.even ⊗[ℂ] V.even), + u ⊗ₜ[ℂ] v) : + (tensorObj V V).even)), + (0 : tensorUnit.odd ⊗[ℂ] (tensorObj V V).odd)) := by + change assocEvenEquiv tensorUnit V V _ = _ + exact assocAux_eo r u v + +/-- The unit-prefixed associator on the even-odd block. -/ +theorem assoc_unit_eo {V : SuperVect} (r : ℂ) + (x : V.even) (v : V.odd) : + (associator tensorUnit V V).hom.oddMap + (((r ⊗ₜ[ℂ] x, (0 : tensorUnit.odd ⊗[ℂ] V.odd)) + ⊗ₜ[ℂ] v, + (0 : ((tensorUnit.even ⊗[ℂ] V.odd) × + (tensorUnit.odd ⊗[ℂ] V.even)) ⊗[ℂ] V.even))) = + ((r ⊗ₜ[ℂ] ((x ⊗ₜ[ℂ] v, + (0 : V.odd ⊗[ℂ] V.even)) : + (tensorObj V V).odd)), + (0 : tensorUnit.odd ⊗[ℂ] (tensorObj V V).even)) := by + change assocOddEquiv tensorUnit V V _ = _ + exact assocAux_ee r x v + +/-- The unit-prefixed associator on the odd-even block. -/ +theorem assoc_unit_oe {V : SuperVect} (r : ℂ) + (u : V.odd) (y : V.even) : + (associator tensorUnit V V).hom.oddMap + (((0 : ((tensorUnit.even ⊗[ℂ] V.even) × + (tensorUnit.odd ⊗[ℂ] V.odd)) ⊗[ℂ] V.odd), + (r ⊗ₜ[ℂ] u, (0 : tensorUnit.odd ⊗[ℂ] V.even)) + ⊗ₜ[ℂ] y)) = + ((r ⊗ₜ[ℂ] (((0 : V.even ⊗[ℂ] V.odd), + u ⊗ₜ[ℂ] y) : + (tensorObj V V).odd)), + (0 : tensorUnit.odd ⊗[ℂ] (tensorObj V V).even)) := by + change assocOddEquiv tensorUnit V V _ = _ + exact assocAux_eo r u y + +/-- The braiding on the even-even block. -/ +theorem koszul_ee {V W : SuperVect} (x : V.even) (w : W.even) : + (koszulBraiding V W).evenMap + ((x ⊗ₜ[ℂ] w, (0 : V.odd ⊗[ℂ] W.odd))) = + ((w ⊗ₜ[ℂ] x, (0 : W.odd ⊗[ℂ] V.odd))) := by + change koszulBraidingEven V W _ = _ + simp [koszulBraidingEven, koszulEvenAux] + +/-- The braiding on the odd-odd block: the Koszul sign. -/ +theorem koszul_oo {V W : SuperVect} (u : V.odd) (v : W.odd) : + (koszulBraiding V W).evenMap + (((0 : V.even ⊗[ℂ] W.even), u ⊗ₜ[ℂ] v)) = + (((0 : W.even ⊗[ℂ] V.even), -(v ⊗ₜ[ℂ] u))) := by + change koszulBraidingEven V W _ = _ + simp [koszulBraidingEven, koszulEvenAux] + +/-- The braiding on the even-odd block. -/ +theorem koszul_eo {V W : SuperVect} (x : V.even) (v : W.odd) : + (koszulBraiding V W).oddMap + ((x ⊗ₜ[ℂ] v, (0 : V.odd ⊗[ℂ] W.even))) = + (((0 : W.even ⊗[ℂ] V.odd), v ⊗ₜ[ℂ] x)) := by + change koszulBraidingOdd V W _ = _ + simp [koszulBraidingOdd, koszulOddAux] + +/-- The braiding on the odd-even block. -/ +theorem koszul_oe {V W : SuperVect} (u : V.odd) (w : W.even) : + (koszulBraiding V W).oddMap + (((0 : V.even ⊗[ℂ] W.odd), u ⊗ₜ[ℂ] w)) = + ((w ⊗ₜ[ℂ] u, (0 : W.odd ⊗[ℂ] V.even))) := by + change koszulBraidingOdd V W _ = _ + simp [koszulBraidingOdd, koszulOddAux] + +/-- The unit-prefixed inverse associator on the even-even +block. -/ +theorem assoc_unit_inv_ee {V : SuperVect} (r : ℂ) + (x y : V.even) : + (associator tensorUnit V V).inv.evenMap + ((r ⊗ₜ[ℂ] ((x ⊗ₜ[ℂ] y, + (0 : V.odd ⊗[ℂ] V.odd)) : + (tensorObj V V).even)), + (0 : tensorUnit.odd ⊗[ℂ] (tensorObj V V).odd)) = + (((r ⊗ₜ[ℂ] x, (0 : tensorUnit.odd ⊗[ℂ] V.odd)) + ⊗ₜ[ℂ] y, + (0 : ((tensorUnit.even ⊗[ℂ] V.odd) × + (tensorUnit.odd ⊗[ℂ] V.even)) ⊗[ℂ] V.odd))) := by + change (assocEvenEquiv tensorUnit V V).symm _ = _ + exact (LinearEquiv.symm_apply_eq _).mpr (assocAux_ee r x y).symm + +/-- The unit-prefixed inverse associator on the odd-odd block. -/ +theorem assoc_unit_inv_oo {V : SuperVect} (r : ℂ) + (u v : V.odd) : + (associator tensorUnit V V).inv.evenMap + ((r ⊗ₜ[ℂ] (((0 : V.even ⊗[ℂ] V.even), + u ⊗ₜ[ℂ] v) : + (tensorObj V V).even)), + (0 : tensorUnit.odd ⊗[ℂ] (tensorObj V V).odd)) = + (((0 : ((tensorUnit.even ⊗[ℂ] V.even) × + (tensorUnit.odd ⊗[ℂ] V.odd)) ⊗[ℂ] V.even), + (r ⊗ₜ[ℂ] u, (0 : tensorUnit.odd ⊗[ℂ] V.even)) + ⊗ₜ[ℂ] v)) := by + change (assocEvenEquiv tensorUnit V V).symm _ = _ + exact (LinearEquiv.symm_apply_eq _).mpr (assocAux_eo r u v).symm + +/-- The unit-prefixed inverse associator on the even-odd block. -/ +theorem assoc_unit_inv_eo {V : SuperVect} (r : ℂ) + (x : V.even) (v : V.odd) : + (associator tensorUnit V V).inv.oddMap + ((r ⊗ₜ[ℂ] ((x ⊗ₜ[ℂ] v, + (0 : V.odd ⊗[ℂ] V.even)) : + (tensorObj V V).odd)), + (0 : tensorUnit.odd ⊗[ℂ] (tensorObj V V).even)) = + (((r ⊗ₜ[ℂ] x, (0 : tensorUnit.odd ⊗[ℂ] V.odd)) + ⊗ₜ[ℂ] v, + (0 : ((tensorUnit.even ⊗[ℂ] V.odd) × + (tensorUnit.odd ⊗[ℂ] V.even)) ⊗[ℂ] V.even))) := by + change (assocOddEquiv tensorUnit V V).symm _ = _ + exact (LinearEquiv.symm_apply_eq _).mpr (assocAux_ee r x v).symm + +/-- The unit-prefixed inverse associator on the odd-even block. -/ +theorem assoc_unit_inv_oe {V : SuperVect} (r : ℂ) + (u : V.odd) (y : V.even) : + (associator tensorUnit V V).inv.oddMap + ((r ⊗ₜ[ℂ] (((0 : V.even ⊗[ℂ] V.odd), + u ⊗ₜ[ℂ] y) : + (tensorObj V V).odd)), + (0 : tensorUnit.odd ⊗[ℂ] (tensorObj V V).even)) = + (((0 : ((tensorUnit.even ⊗[ℂ] V.even) × + (tensorUnit.odd ⊗[ℂ] V.odd)) ⊗[ℂ] V.odd), + (r ⊗ₜ[ℂ] u, (0 : tensorUnit.odd ⊗[ℂ] V.even)) + ⊗ₜ[ℂ] y)) := by + change (assocOddEquiv tensorUnit V V).symm _ = _ + exact (LinearEquiv.symm_apply_eq _).mpr (assocAux_eo r u y).symm + +end SuperVect + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/SymplecticBasis.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/SymplecticBasis.lean new file mode 100644 index 0000000000..f8266e3dee --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/SymplecticBasis.lean @@ -0,0 +1,318 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Symplectic structure of alternating nondegenerate bilinear forms + +For a finite-dimensional complex vector space `V` equipped with an +alternating nondegenerate bilinear form `B`: + +* **Symplectic splitting** (`exists_symplectic_splitting`): there + exist `v, w` with `B v w = 1`, `B w v = −1`, spanning a + 2-dimensional nondegenerate plane `U` whose orthogonal complement + `U^⊥` inherits an alternating nondegenerate restriction of `B` + with `finrank ℂ U^⊥ = finrank ℂ V − 2`. + +* **Standard basis** (`exists_symplectic_basis`): iterating the + splitting gives a basis indexed by `Fin (2 * ℓ)` in two blocks — + the first `ℓ` vectors and their partners — carrying the canonical + symplectic pairing matrix. In particular the dimension of `V` is + even. + +The assembly interleaves the plane's basis with the complement's +through `Basis.prod`, `Submodule.prodEquivOfIsCompl` and the +reindexing `symplecticReindexEquiv` on `Fin (2 * ℓ)`. +-/ + +@[expose] public section + +noncomputable section + +namespace RS + +open LinearMap (BilinForm) +open LinearMap.BilinForm +open Module Submodule FiniteDimensional + +/-! ### The symplectic plane -/ + +/-- Vectors `v, w` with `B v w = 1` and `B` alternating are linearly +independent: a dependence would make `B v w` a multiple of the +self-pairing `B w w`, which is zero. -/ +private theorem linearIndependent_pair_of_pairing_one + {V : Type*} [AddCommGroup V] [Module ℂ V] + {B : BilinForm ℂ V} {v w : V} (hAlt : B.IsAlt) (hBvw : B v w = 1) : + LinearIndependent ℂ ![v, w] := by + rw [linearIndependent_fin2] + simp only [Matrix.cons_val_zero, Matrix.cons_val_one] + refine ⟨fun hw_eq => ?_, fun a ha => ?_⟩ + · rw [hw_eq, map_zero] at hBvw; exact one_ne_zero hBvw.symm + · have hc : B v w = a • B w w := by rw [← ha]; simp [map_smul] + rw [hAlt.self_eq_zero, smul_zero] at hc + rw [hc] at hBvw; exact one_ne_zero hBvw.symm + +/-- The range of the pair `![v, w]` is the doubleton `{v, w}`. -/ +private theorem range_pair_eq {V : Type*} (v w : V) : + (Set.range ![v, w] : Set V) = {v, w} := by + ext x + constructor + · rintro ⟨i, rfl⟩; fin_cases i <;> simp [Set.mem_insert_iff] + · rintro (rfl | rfl) + · exact ⟨0, rfl⟩ + · exact ⟨1, rfl⟩ + +/-! ### Disjointness of the symplectic plane and its orthogonal complement -/ + +/-- Given vectors `v, w` with `B v w = 1` and `B` alternating, the +span `{v, w}` is disjoint from its `B`-orthogonal complement. -/ +private theorem disjoint_span_pair_orthogonal + {K : Type*} [Field K] {V : Type*} [AddCommGroup V] [Module K V] + {B : BilinForm K V} (hAlt : B.IsAlt) + {v w : V} (hBvw : B v w = 1) : + Disjoint (span K {v, w}) (orthogonal B (span K {v, w})) := by + have hRefl : B.IsRefl := hAlt.isRefl + have hBwv : B w v = -1 := by + have h := hAlt.neg_eq v w; rw [hBvw] at h; exact h.symm + rw [Submodule.disjoint_def] + intro x hxU hxPerp + rw [mem_orthogonal_iff] at hxPerp + have hxv := hxPerp v (subset_span (Set.mem_insert v {w})) + have hxw := hxPerp w (subset_span (Set.mem_insert_iff.mpr (Or.inr rfl))) + have hBxv : B x v = 0 := hRefl v x hxv + have hBxw : B x w = 0 := hRefl w x hxw + rw [mem_span_pair] at hxU + obtain ⟨a, b, rfl⟩ := hxU + simp only [map_add, map_smul, LinearMap.add_apply, LinearMap.smul_apply, + smul_eq_mul, hAlt.self_eq_zero, hBwv, hBvw, mul_zero, mul_one, mul_neg, + add_zero, zero_add, neg_eq_zero] at hBxv hBxw + rw [hBxw, hBxv, zero_smul, zero_smul, zero_add] + +/-! ### Symplectic splitting -/ + +/-- **Symplectic splitting**: given `V` with an alternating nondegenerate +bilinear form `B` and `finrank ℂ V ≥ 1`, there exist vectors `v, w` +spanning a 2-dimensional symplectic plane `U` such that `B v w = 1`, +`B w v = −1`, and the orthogonal complement `U^⊥` carries an +alternating nondegenerate restriction of `B` with +`finrank ℂ U^⊥ = finrank ℂ V − 2`. -/ +theorem exists_symplectic_splitting + {V : Type*} [AddCommGroup V] [Module ℂ V] [FiniteDimensional ℂ V] + {B : BilinForm ℂ V} (hAlt : B.IsAlt) (hND : B.Nondegenerate) + (hPos : 0 < finrank ℂ V) : + ∃ (v w : V), + B v w = 1 ∧ B w v = -1 ∧ + let U := span ℂ {v, w} + (B.restrict U).Nondegenerate ∧ + IsCompl U (orthogonal B U) ∧ + (B.restrict (orthogonal B U)).IsAlt ∧ + (B.restrict (orthogonal B U)).Nondegenerate ∧ + finrank ℂ (orthogonal B U) = finrank ℂ V - 2 := by + have hRefl : B.IsRefl := hAlt.isRefl + have hV : Nontrivial V := by rwa [← @Module.finrank_pos_iff ℂ V] + obtain ⟨v, hv⟩ := exists_ne (0 : V) + have hBv : ∃ w₀, B v w₀ ≠ 0 := by + by_contra hall; push Not at hall + exact hv (hND.1 v hall) + obtain ⟨w₀, hw₀⟩ := hBv + set w := (B v w₀)⁻¹ • w₀ + have hBvw : B v w = 1 := by simp + [w, map_smul, smul_eq_mul, inv_mul_cancel₀ hw₀] + have hBwv : B w v = -1 := by + have h := hAlt.neg_eq v w; rw [hBvw] at h; exact h.symm + set U := span ℂ {v, w} + have hDisj := disjoint_span_pair_orthogonal hAlt hBvw + have hRestND := nondegenerate_restrict_of_disjoint_orthogonal B hRefl hDisj + have hCompl := isCompl_orthogonal_of_restrict_nondegenerate hRefl hRestND + -- finrank U = 2 + have hLI := linearIndependent_pair_of_pairing_one hAlt hBvw + have hSpanEq := range_pair_eq v w + have hFinrankU : finrank ℂ U = 2 := by + rw [show U = span ℂ (Set.range ![v, w]) from by rw [hSpanEq]] + rw [finrank_span_eq_card hLI]; simp + have hFinrankSum : finrank ℂ V = + finrank ℂ U + finrank ℂ (orthogonal B U) := by + have := finrank_sup_add_finrank_inf_eq U (orthogonal B U) + rw [hCompl.sup_eq_top, hCompl.inf_eq_bot, finrank_top, finrank_bot] at this + omega + have hFinrankPerp : finrank ℂ (orthogonal B U) = finrank ℂ V - 2 := by omega + have hAltPerp : (B.restrict (orthogonal B U)).IsAlt := fun ⟨x, _⟩ => by + simp [restrict_apply, hAlt.self_eq_zero] + have hNDPerp : (B.restrict (orthogonal B U)).Nondegenerate := by + apply nondegenerate_restrict_of_disjoint_orthogonal B hRefl + rw [orthogonal_orthogonal hND hRefl U] + exact hCompl.symm.disjoint + exact ⟨v, w, hBvw, hBwv, hRestND, hCompl, hAltPerp, hNDPerp, hFinrankPerp⟩ + +/-! ### Symplectic basis assembly -/ + +/-- Interleaving reindexing for the symplectic basis assembly: the two +"new" indices (0 and `ℓ' + 1`) map to `Fin 2`, and the remaining +indices thread through `Fin (2 * ℓ')`. -/ +private def symplecticReindexEquiv (ℓ' : ℕ) : + Fin (2 * (ℓ' + 1)) ≃ Fin 2 ⊕ Fin (2 * ℓ') where + toFun i := + if h₁ : i.val = 0 then .inl 0 + else if h₂ : i.val ≤ ℓ' then .inr ⟨i.val - 1, by omega⟩ + else if h₃ : i.val = ℓ' + 1 then .inl 1 + else .inr ⟨i.val - 2, by omega⟩ + invFun + | .inl k => if k.val = 0 then ⟨0, by omega⟩ else ⟨ℓ' + 1, by omega⟩ + | .inr j => if j.val < ℓ' then ⟨j.val + 1, by omega⟩ else ⟨j.val + 2, by + omega⟩ + left_inv i := by + dsimp only [] + split_ifs <;> dsimp only [] <;> split_ifs <;> + (simp only [Fin.ext_iff]; omega) + right_inv x := by + rcases x with k | j + · dsimp only [] + split_ifs <;> (dsimp only [] at *; try split_ifs) <;> + first | rfl | (simp only [Sum.inl.injEq, Fin.ext_iff]; omega) | omega + · dsimp only [] + split_ifs <;> (rw [Fin.val_mk] at *; try split_ifs) <;> + first | rfl | (simp only [Sum.inr.injEq, Fin.ext_iff]; omega) | omega + +/-- **Symplectic standard basis**: a finite-dimensional complex vector +space carrying an alternating nondegenerate bilinear form admits a +basis indexed by `Fin (2 * ℓ)` in two blocks — the first `ℓ` vectors +and their partners — with the canonical symplectic pairing matrix: +`B(eₘ, eₘ₊ℓ) = 1`, `B(eₘ₊ℓ, eₘ) = −1`, and all other pairings +vanish. -/ +theorem exists_symplectic_basis {V : Type} [AddCommGroup V] [Module ℂ V] + [FiniteDimensional ℂ V] (B : BilinForm ℂ V) + (hAlt : B.IsAlt) (hND : B.Nondegenerate) : + ∃ (ℓ : ℕ) (_ : finrank ℂ V = 2 * ℓ) + (f : Basis (Fin (2 * ℓ)) ℂ V), + ∀ i j : Fin (2 * ℓ), + B (f i) (f j) = + if (i : ℕ) + ℓ = j then 1 + else if (j : ℕ) + ℓ = i then -1 else 0 := by + induction h : finrank ℂ V using Nat.strongRecOn generalizing V with + | ind n ih => + by_cases hn : n = 0 + · -- ═══════ Base case: finrank = 0 ═══════ + exact ⟨0, by omega, Module.finBasisOfFinrankEq ℂ V (by omega), fun i => + Fin.elim0 i⟩ + · -- ═══════ Inductive step ═══════ + have hPos : 0 < finrank ℂ V := by omega + obtain ⟨v, w, hBvw, hBwv, _, hCompl, hAltPerp, hNDPerp, hFinrankPerp⟩ := + exists_symplectic_splitting hAlt hND hPos + set U := span ℂ {v, w} + -- ═══════ Linear independence and U-basis ═══════ + have hLI := linearIndependent_pair_of_pairing_one hAlt hBvw + have hSpanEq := range_pair_eq v w + have hSpanRangeEq : span ℂ (Set.range ![v, w]) = U := congr_arg (span ℂ ·) + hSpanEq + set bU : Basis (Fin 2) ℂ ↥U := + (Basis.span hLI).map (LinearEquiv.ofEq _ _ hSpanRangeEq) with hbU_def + have hbU_coe : ∀ i, (bU i : V) = ![v, w] i := fun i => by + simp [hbU_def, Basis.map_apply] + -- ═══════ Finrank of U ═══════ + have hFinrankU : finrank ℂ U = 2 := by + rw [show U = span ℂ (Set.range ![v, w]) from hSpanRangeEq.symm] + rw [finrank_span_eq_card hLI]; simp + have hFinrankSum : finrank ℂ V = + finrank ℂ U + finrank ℂ (orthogonal B U) := by + have := finrank_sup_add_finrank_inf_eq U (orthogonal B U) + rw [hCompl.sup_eq_top, hCompl.inf_eq_bot, finrank_top, + finrank_bot] at this + omega + -- ═══════ Inductive hypothesis on the complement ═══════ + have hLt : n - 2 < n := by omega + obtain ⟨ℓ', hℓ', g, hg⟩ := ih (n - 2) hLt + (B := B.restrict (orthogonal B U)) hAltPerp hNDPerp (by omega) + -- ═══════ Basis assembly ═══════ + set bV := (bU.prod g).map (prodEquivOfIsCompl U (orthogonal B U) hCompl) + with hbV_def + set e := symplecticReindexEquiv ℓ' + set f := bV.reindex e.symm with hf_def + refine ⟨ℓ' + 1, by omega, f, ?_⟩ + -- ═══════ Pairing condition verification ═══════ + have hRefl : B.IsRefl := hAlt.isRefl + -- Helper: bV applied to the two summands + have hbV_inl : ∀ k : Fin 2, bV (.inl k) = ↑(bU k) := by + intro k; simp [hbV_def, Basis.map_apply, coe_prodEquivOfIsCompl'] + have hbV_inr : ∀ k : Fin (2 * ℓ'), bV (.inr k) = ↑(g k) := by + intro k; simp [hbV_def, Basis.map_apply, coe_prodEquivOfIsCompl'] + -- Helper: B-orthogonality between U and its complement + have hBUP : ∀ (x : ↥U) (y : ↥(orthogonal B U)), B ↑x ↑y = 0 := + fun x y => mem_orthogonal_iff.mp y.prop x x.prop + have hBPU : ∀ (x : ↥(orthogonal B U)) (y : ↥U), B ↑x ↑y = 0 := + fun x y => hRefl.eq_zero (mem_orthogonal_iff.mp x.prop y y.prop) + -- Helper: restrict ↔ ambient + have hRestrictPerp : ∀ (x y : ↥(orthogonal B U)), + B.restrict (orthogonal B U) x y = B ↑x ↑y := fun _ _ => rfl + -- The main verification: extract index arithmetic from the equiv inverse + have hinv_inl : ∀ (k : Fin 2), + (e.symm (.inl k)).val = if k.val = 0 then 0 else ℓ' + 1 := by + intro k + simp only [e, symplecticReindexEquiv, Equiv.symm_mk, Equiv.coe_fn_mk] + split_ifs <;> rfl + have hinv_inr : ∀ (k : Fin (2 * ℓ')), + (e.symm (.inr k)).val = if k.val < ℓ' then k.val + 1 else k.val + 2 := + by + intro k + simp only [e, symplecticReindexEquiv, Equiv.symm_mk, Equiv.coe_fn_mk] + split_ifs <;> rfl + intro i j + simp only [hf_def, Basis.reindex_apply, Equiv.symm_symm] + -- Case-split on the image of i and j under the reindexing equivalence + rcases hei : e i with ki | ki <;> rcases hej : e j with kj | kj + · -- ═══════ Case 1: both in U-block ═══════ + rw [hbV_inl ki, hbV_inl kj, hbU_coe ki, hbU_coe kj] + have hival : i.val = if ki.val = 0 then 0 else ℓ' + 1 := by + have hsymm : e.symm (.inl ki) = i := by + rw [← hei]; exact e.symm_apply_apply i + rw [← congr_arg Fin.val hsymm]; exact hinv_inl ki + have hjval : j.val = if kj.val = 0 then 0 else ℓ' + 1 := by + have hsymm : e.symm (.inl kj) = j := by + rw [← hej]; exact e.symm_apply_apply j + rw [← congr_arg Fin.val hsymm]; exact hinv_inl kj + have hM : ∀ (k : Fin 2), ![v, w] k = if k.val = 0 then v else w := by + intro k; fin_cases k <;> rfl + rw [hM ki, hM kj] + split_ifs at hival hjval ⊢ <;> + simp only [hAlt.self_eq_zero, hBvw, hBwv] <;> + first | rfl | (exfalso; omega) + · -- ═══════ Case 2: i in U, j in complement ═══════ + rw [hbV_inl ki, hbV_inr kj, hBUP (bU ki) (g kj)] + have hival : i.val = if ki.val = 0 then 0 else ℓ' + 1 := by + have hsymm : e.symm (.inl ki) = i := by + rw [← hei]; exact e.symm_apply_apply i + rw [← congr_arg Fin.val hsymm]; exact hinv_inl ki + have hjval : j.val = if kj.val < ℓ' then kj.val + 1 else kj.val + 2 := by + have hsymm : e.symm (.inr kj) = j := by + rw [← hej]; exact e.symm_apply_apply j + rw [← congr_arg Fin.val hsymm]; exact hinv_inr kj + split_ifs at hival hjval ⊢ <;> first | rfl | (exfalso; omega) + · -- ═══════ Case 3: i in complement, j in U ═══════ + rw [hbV_inr ki, hbV_inl kj, hBPU (g ki) (bU kj)] + have hival : i.val = if ki.val < ℓ' then ki.val + 1 else ki.val + 2 := by + have hsymm : e.symm (.inr ki) = i := by + rw [← hei]; exact e.symm_apply_apply i + rw [← congr_arg Fin.val hsymm]; exact hinv_inr ki + have hjval : j.val = if kj.val = 0 then 0 else ℓ' + 1 := by + have hsymm : e.symm (.inl kj) = j := by + rw [← hej]; exact e.symm_apply_apply j + rw [← congr_arg Fin.val hsymm]; exact hinv_inl kj + split_ifs at hival hjval ⊢ <;> first | rfl | (exfalso; omega) + · -- ═══════ Case 4: both in complement ═══════ + rw [hbV_inr ki, hbV_inr kj, ← hRestrictPerp, hg] + have hival : i.val = if ki.val < ℓ' then ki.val + 1 else ki.val + 2 := by + have hsymm : e.symm (.inr ki) = i := by + rw [← hei]; exact e.symm_apply_apply i + rw [← congr_arg Fin.val hsymm]; exact hinv_inr ki + have hjval : j.val = if kj.val < ℓ' then kj.val + 1 else kj.val + 2 := by + have hsymm : e.symm (.inr kj) = j := by + rw [← hej]; exact e.symm_apply_apply j + rw [← congr_arg Fin.val hsymm]; exact hinv_inr kj + split_ifs at hival hjval ⊢ <;> first | rfl | (exfalso; omega) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/TotalSpace.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/TotalSpace.lean new file mode 100644 index 0000000000..e706254a53 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/TotalSpace.lean @@ -0,0 +1,93 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.SuperVect + +/-! +# Total spaces of super vector spaces + +Forgetting the grading gives the product of the even and odd +components. Morphisms act componentwise, giving an algebra map on +endomorphisms. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +noncomputable section + +/-- The total space of a super vector space. -/ +abbrev Tot (V : SuperVect) : Type := V.even × V.odd + +/-- The total linear map of a morphism of super vector spaces. -/ +def tot {V W : SuperVect} (f : V ⟶ W) : Tot V →ₗ[ℂ] Tot W := + LinearMap.prodMap (SuperVect.Hom.evenMap f) (SuperVect.Hom.oddMap f) + +/-- The total map of the identity. -/ +@[simp] +theorem tot_id (V : SuperVect) : tot (𝟙 V) = LinearMap.id := by + ext v <;> rfl + +/-- The total map of a composite. -/ +theorem tot_comp {V W X : SuperVect} (f : V ⟶ W) (g : W ⟶ X) : + tot (f ≫ g) = (tot g).comp (tot f) := by + ext v <;> rfl + +/-- The total map is additive in the morphism. -/ +theorem tot_add {V W : SuperVect} (f g : V ⟶ W) : + tot (f + g) = tot f + tot g := by + refine LinearMap.ext fun x => ?_ + change ((f + g).evenMap x.1, (f + g).oddMap x.2) = _ + rw [SuperVect.add_evenMap, SuperVect.add_oddMap] + rfl + +/-- The total map is homogeneous in the morphism. -/ +theorem tot_smul {V W : SuperVect} (c : ℂ) (f : V ⟶ W) : + tot (c • f) = c • tot f := by + refine LinearMap.ext fun x => ?_ + change ((c • f).evenMap x.1, (c • f).oddMap x.2) = _ + rw [SuperVect.smul_evenMap, SuperVect.smul_oddMap] + rfl + +/-- The total map of a zero morphism. -/ +@[simp] +theorem tot_zero (V W : SuperVect) : tot (0 : V ⟶ W) = 0 := by + ext v <;> rfl + +/-- Forgetting the grading preserves the endomorphism algebra. -/ +def totAlgHom (V : SuperVect) : End V →ₐ[ℂ] Module.End ℂ (Tot V) where + toFun := tot + map_one' := tot_id V + map_mul' f g := tot_comp g f + map_zero' := tot_zero V V + map_add' := tot_add + commutes' c := by + change tot (c • 𝟙 V) = c • LinearMap.id + rw [tot_smul, tot_id] + +/-- A super isomorphism induces a linear equivalence of total spaces. -/ +def totIso {V W : SuperVect} (e : V ≅ W) : Tot V ≃ₗ[ℂ] Tot W where + __ := tot e.hom + invFun := tot e.inv + left_inv v := by + have h := LinearMap.congr_fun + ((tot_comp e.hom e.inv).symm.trans + (by rw [e.hom_inv_id, tot_id])) v + exact h + right_inv w := by + have h := LinearMap.congr_fun + ((tot_comp e.inv e.hom).symm.trans + (by rw [e.inv_hom_id, tot_id])) w + exact h + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/WordSignPerm.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/WordSignPerm.lean new file mode 100644 index 0000000000..f01784ab35 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/WordSignPerm.lean @@ -0,0 +1,319 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourWord + +/-! +# Word sign depends only on the word's permutation + +We show that `wordSign w c` depends on `w` only through `wordPerm w`, +by identifying it as `(-1) ^ oddInversions (wordPerm w) c`, where +`oddInversions σ c` counts inversions of `σ` at odd-coloured positions. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {k ℓ : ℕ} + +/-- Count of inversions of `σ` restricted to odd-coloured positions: +pairs `(a, b)` with `a < b`, `σ a > σ b`, and both `c (σ a)` and +`c (σ b)` odd-coloured. -/ +def oddInversions {k ℓ n : ℕ} (σ : _root_.Equiv.Perm (Fin n)) + (c : MixedColouring k ℓ n) : ℕ := + (univ.filter (fun p : Fin n × Fin n => + p.1 < p.2 ∧ σ p.1 > σ p.2 ∧ + (c (σ p.1)).isRight ∧ (c (σ p.2)).isRight)).card + +private theorem oddInversions_one {n : ℕ} + (c : MixedColouring k ℓ n) : + oddInversions (1 : _root_.Equiv.Perm (Fin n)) c = 0 := by + simp only [oddInversions, _root_.Equiv.Perm.one_apply, gt_iff_lt, + Finset.card_eq_zero, Finset.filter_eq_empty_iff, + Finset.mem_univ, forall_true_left] + intro ⟨_, _⟩ + rintro ⟨hlt, hgt, _⟩ + exact absurd (lt_trans hlt hgt) (lt_irrefl _) + +private theorem swap_adj_gt_iff {m : ℕ} {a b : Fin m} + (hadj : b.val = a.val + 1) {x y : Fin m} + (hne : ¬ ((x = a ∧ y = b) ∨ (x = b ∧ y = a))) : + (_root_.Equiv.swap a b x > _root_.Equiv.swap a b y) ↔ + (x > y) := by + simp only [gt_iff_lt, _root_.Equiv.swap_apply_def, Fin.lt_def] + split_ifs <;> simp_all [Fin.ext_iff] <;> omega + +/-- In the ¬both-odd case the two inversion filter sets are equal: +the critical pair fails the `isRight` check, and non-critical pairs +have their ordering preserved by the adjacent swap. -/ +private theorem filter_eq_of_not_bothOdd {n : ℕ} + {a b : Fin (n + 1)} (hadj : b.val = a.val + 1) + (τ : _root_.Equiv.Perm (Fin (n + 1))) + (c : MixedColouring k ℓ (n + 1)) + (hno : ¬ ((c a).isRight ∧ (c b).isRight)) : + (univ.filter (fun p : Fin (n+1) × Fin (n+1) => + p.1 < p.2 ∧ _root_.Equiv.swap a b (τ p.1) > _root_.Equiv.swap a b (τ p.2) + ∧ + (c (_root_.Equiv.swap a b (τ p.1))).isRight ∧ + (c (_root_.Equiv.swap a b (τ p.2))).isRight)) = + (univ.filter (fun p : Fin (n+1) × Fin (n+1) => + p.1 < p.2 ∧ τ p.1 > τ p.2 ∧ + (c (_root_.Equiv.swap a b (τ p.1))).isRight ∧ + (c (_root_.Equiv.swap a b (τ p.2))).isRight)) := by + ext ⟨p₁, p₂⟩ + simp only [mem_filter, mem_univ, true_and] + constructor + · rintro ⟨hlt, hord, hr1, hr2⟩ + refine ⟨hlt, ?_, hr1, hr2⟩ + by_cases hcrit : (τ p₁ = a ∧ τ p₂ = b) ∨ (τ p₁ = b ∧ τ p₂ = a) + · rcases hcrit with ⟨ha, hb⟩ | ⟨hb, ha⟩ + · rw [ha, _root_.Equiv.swap_apply_left] at hr1 + rw [hb, _root_.Equiv.swap_apply_right] at hr2 + exact absurd ⟨hr2, hr1⟩ hno + · rw [hb, _root_.Equiv.swap_apply_right] at hr1 + rw [ha, _root_.Equiv.swap_apply_left] at hr2 + exact absurd ⟨hr1, hr2⟩ hno + · exact (swap_adj_gt_iff hadj hcrit).mp hord + · rintro ⟨hlt, hord, hr1, hr2⟩ + refine ⟨hlt, ?_, hr1, hr2⟩ + by_cases hcrit : (τ p₁ = a ∧ τ p₂ = b) ∨ (τ p₁ = b ∧ τ p₂ = a) + · rcases hcrit with ⟨ha, hb⟩ | ⟨hb, ha⟩ + · rw [ha, _root_.Equiv.swap_apply_left] at hr1 + rw [hb, _root_.Equiv.swap_apply_right] at hr2 + exact absurd ⟨hr2, hr1⟩ hno + · rw [hb, _root_.Equiv.swap_apply_right] at hr1 + rw [ha, _root_.Equiv.swap_apply_left] at hr2 + exact absurd ⟨hr1, hr2⟩ hno + · exact (swap_adj_gt_iff hadj hcrit).mpr hord + +/-- In the both-odd case with `τ⁻¹ a < τ⁻¹ b`, the swap-side +inversion set is the insert of the critical pair into the +plain-ordering set. -/ +private theorem filter_insert_of_bothOdd_fwd {n : ℕ} + {a b : Fin (n + 1)} (hadj : b.val = a.val + 1) + (τ : _root_.Equiv.Perm (Fin (n + 1))) + (c : MixedColouring k ℓ (n + 1)) + (hboth : (c a).isRight ∧ (c b).isRight) + (hord : τ.symm a < τ.symm b) : + (univ.filter (fun p : Fin (n+1) × Fin (n+1) => + p.1 < p.2 ∧ _root_.Equiv.swap a b (τ p.1) > _root_.Equiv.swap a b (τ p.2) + ∧ + (c (_root_.Equiv.swap a b (τ p.1))).isRight ∧ + (c (_root_.Equiv.swap a b (τ p.2))).isRight)) = + insert (τ.symm a, τ.symm b) + (univ.filter (fun p : Fin (n+1) × Fin (n+1) => + p.1 < p.2 ∧ τ p.1 > τ p.2 ∧ + (c (_root_.Equiv.swap a b (τ p.1))).isRight ∧ + (c (_root_.Equiv.swap a b (τ p.2))).isRight)) := by + ext ⟨p₁, p₂⟩ + simp only [mem_filter, mem_univ, true_and, mem_insert, Prod.mk.injEq] + constructor + · rintro ⟨hlt, hord_s, hr1, hr2⟩ + by_cases hcrit : (τ p₁ = a ∧ τ p₂ = b) ∨ (τ p₁ = b ∧ τ p₂ = a) + · rcases hcrit with ⟨ha, hb⟩ | ⟨hb', ha'⟩ + · left + exact ⟨by rw [← ha]; simp [_root_.Equiv.symm_apply_apply], + by rw [← hb]; simp [_root_.Equiv.symm_apply_apply]⟩ + · rw [hb', ha'] at hord_s + simp only [_root_.Equiv.swap_apply_right, + _root_.Equiv.swap_apply_left] at hord_s + exact absurd hord_s (by + simp only [gt_iff_lt, not_lt, Fin.le_def]; omega) + · right + exact ⟨hlt, (swap_adj_gt_iff hadj hcrit).mp hord_s, hr1, hr2⟩ + · rintro (⟨rfl, rfl⟩ | ⟨hlt, hord_t, hr1, hr2⟩) + · refine ⟨hord, ?_, ?_, ?_⟩ + · simp only [_root_.Equiv.apply_symm_apply, + _root_.Equiv.swap_apply_left, + _root_.Equiv.swap_apply_right, gt_iff_lt, Fin.lt_def] + omega + · simp only [_root_.Equiv.apply_symm_apply, + _root_.Equiv.swap_apply_left] + exact hboth.2 + · simp only [_root_.Equiv.apply_symm_apply, + _root_.Equiv.swap_apply_right] + exact hboth.1 + · refine ⟨hlt, ?_, hr1, hr2⟩ + by_cases hcrit : (τ p₁ = a ∧ τ p₂ = b) ∨ (τ p₁ = b ∧ τ p₂ = a) + · rcases hcrit with ⟨ha, hb⟩ | ⟨hb', ha'⟩ + · rw [ha, hb] at hord_t + exact absurd hord_t (by + simp only [gt_iff_lt, not_lt, Fin.le_def]; omega) + · have h1 : p₁ = τ.symm b := by + rw [← hb']; simp [_root_.Equiv.symm_apply_apply] + have h2 : p₂ = τ.symm a := by + rw [← ha']; simp [_root_.Equiv.symm_apply_apply] + rw [h1, h2] at hlt + exact absurd hlt (not_lt.mpr (le_of_lt hord)) + · exact (swap_adj_gt_iff hadj hcrit).mpr hord_t + +/-- In the both-odd case with `τ⁻¹ b < τ⁻¹ a`, the +plain-ordering inversion set is the insert of the critical pair +into the swap-side set. -/ +private theorem filter_insert_of_bothOdd_rev {n : ℕ} + {a b : Fin (n + 1)} (hadj : b.val = a.val + 1) + (τ : _root_.Equiv.Perm (Fin (n + 1))) + (c : MixedColouring k ℓ (n + 1)) + (hboth : (c a).isRight ∧ (c b).isRight) + (hord : τ.symm b < τ.symm a) : + (univ.filter (fun p : Fin (n+1) × Fin (n+1) => + p.1 < p.2 ∧ τ p.1 > τ p.2 ∧ + (c (_root_.Equiv.swap a b (τ p.1))).isRight ∧ + (c (_root_.Equiv.swap a b (τ p.2))).isRight)) = + insert (τ.symm b, τ.symm a) + (univ.filter (fun p : Fin (n+1) × Fin (n+1) => + p.1 < p.2 ∧ _root_.Equiv.swap a b (τ p.1) > _root_.Equiv.swap a b (τ + p.2) ∧ + (c (_root_.Equiv.swap a b (τ p.1))).isRight ∧ + (c (_root_.Equiv.swap a b (τ p.2))).isRight)) := by + ext ⟨p₁, p₂⟩ + simp only [mem_filter, mem_univ, true_and, mem_insert, Prod.mk.injEq] + constructor + · rintro ⟨hlt, hord_t, hr1, hr2⟩ + by_cases hcrit : (τ p₁ = a ∧ τ p₂ = b) ∨ (τ p₁ = b ∧ τ p₂ = a) + · rcases hcrit with ⟨ha, hb⟩ | ⟨hb', ha'⟩ + · have h1 : p₁ = τ.symm a := by + rw [← ha]; simp [_root_.Equiv.symm_apply_apply] + have h2 : p₂ = τ.symm b := by + rw [← hb]; simp [_root_.Equiv.symm_apply_apply] + rw [h1, h2] at hlt + exact absurd hlt (not_lt.mpr (le_of_lt hord)) + · left + exact ⟨by rw [← hb']; simp [_root_.Equiv.symm_apply_apply], + by rw [← ha']; simp [_root_.Equiv.symm_apply_apply]⟩ + · right + exact ⟨hlt, (swap_adj_gt_iff hadj hcrit).mpr hord_t, hr1, hr2⟩ + · rintro (⟨rfl, rfl⟩ | ⟨hlt, hord_s, hr1, hr2⟩) + · refine ⟨hord, ?_, ?_, ?_⟩ + · simp only [_root_.Equiv.apply_symm_apply, gt_iff_lt, Fin.lt_def] + omega + · simp only [_root_.Equiv.apply_symm_apply, + _root_.Equiv.swap_apply_right] + exact hboth.1 + · simp only [_root_.Equiv.apply_symm_apply, + _root_.Equiv.swap_apply_left] + exact hboth.2 + · refine ⟨hlt, ?_, hr1, hr2⟩ + by_cases hcrit : (τ p₁ = a ∧ τ p₂ = b) ∨ (τ p₁ = b ∧ τ p₂ = a) + · rcases hcrit with ⟨ha, hb⟩ | ⟨hb', ha'⟩ + · have h1 : p₁ = τ.symm a := by + rw [← ha]; simp [_root_.Equiv.symm_apply_apply] + have h2 : p₂ = τ.symm b := by + rw [← hb]; simp [_root_.Equiv.symm_apply_apply] + rw [h1, h2] at hlt + exact absurd hlt (not_lt.mpr (le_of_lt hord)) + · rw [hb', ha'] at hord_s + simp only [_root_.Equiv.swap_apply_right, + _root_.Equiv.swap_apply_left] at hord_s + exact absurd hord_s (by + simp only [gt_iff_lt, not_lt, Fin.le_def]; omega) + · exact (swap_adj_gt_iff hadj hcrit).mp hord_s + +/-- The adjacent-swap cocycle: the sign of a swap-composed +permutation absorbs the `adjSign` factor. -/ +private theorem neg_one_pow_oddInversions_swap_mul {n : ℕ} + (a b : Fin (n + 1)) (hadj : b.val = a.val + 1) + (τ : _root_.Equiv.Perm (Fin (n + 1))) + (c : MixedColouring k ℓ (n + 1)) : + adjSign c a b * + (-1 : ℂ) ^ oddInversions τ (c ∘ _root_.Equiv.swap a b) = + (-1 : ℂ) ^ oddInversions (_root_.Equiv.swap a b * τ) c := by + -- The key observation: oddInversions (swap * τ) c and oddInversions τ (c ∘ + -- swap) + -- share the same isRight conditions but differ in the ordering condition. + -- We rewrite oddInversions (swap * τ) c to expose swap ∘ τ. + have hS₁_eq : oddInversions (_root_.Equiv.swap a b * τ) c = + (univ.filter (fun p : Fin (n+1) × Fin (n+1) => + p.1 < p.2 ∧ + _root_.Equiv.swap a b (τ p.1) > _root_.Equiv.swap a b (τ p.2) ∧ + (c (_root_.Equiv.swap a b (τ p.1))).isRight ∧ + (c (_root_.Equiv.swap a b (τ p.2))).isRight)).card := by + unfold oddInversions; congr 1 + have hS₂_eq : oddInversions τ (c ∘ _root_.Equiv.swap a b) = + (univ.filter (fun p : Fin (n+1) × Fin (n+1) => + p.1 < p.2 ∧ τ p.1 > τ p.2 ∧ + (c (_root_.Equiv.swap a b (τ p.1))).isRight ∧ + (c (_root_.Equiv.swap a b (τ p.2))).isRight)).card := by + unfold oddInversions; congr 1 + rw [hS₁_eq, hS₂_eq] + -- Now case-split on whether both positions are odd-coloured. + by_cases hbo : (c a).isRight ∧ (c b).isRight + · -- Both odd: the critical pair causes a difference of 1 in cardinality. + have hab : a ≠ b := by intro h; rw [h] at hadj; omega + have hlt_or_gt : τ.symm a < τ.symm b ∨ τ.symm b < τ.symm a := by + rcases lt_or_gt_of_ne (show τ.symm a ≠ τ.symm b from + fun h => hab (τ.symm.injective h)) with h | h + · exact Or.inl h + · exact Or.inr h + rcases hlt_or_gt with hfwd | hrev + · -- τ⁻¹ a < τ⁻¹ b: S₁ = insert (τ⁻¹ a, τ⁻¹ b) S₂, so |S₁| = |S₂| + 1 + have hins := filter_insert_of_bothOdd_fwd hadj τ c hbo hfwd + have hnotmem : (τ.symm a, τ.symm b) ∉ + univ.filter (fun p : Fin (n+1) × Fin (n+1) => + p.1 < p.2 ∧ τ p.1 > τ p.2 ∧ + (c (_root_.Equiv.swap a b (τ p.1))).isRight ∧ + (c (_root_.Equiv.swap a b (τ p.2))).isRight) := by + simp only [mem_filter, mem_univ, true_and, not_and, + _root_.Equiv.apply_symm_apply] + intro _hlt hgt + exact absurd hgt (by + simp only [gt_iff_lt, not_lt, Fin.le_def]; omega) + rw [hins, Finset.card_insert_of_notMem hnotmem] + change adjSign c a b * (-1 : ℂ) ^ _ = (-1 : ℂ) ^ (_ + 1) + rw [adjSign, ite_eq_left hbo, pow_succ] + ring + · -- τ⁻¹ b < τ⁻¹ a: S₂ = insert (τ⁻¹ b, τ⁻¹ a) S₁, so |S₂| = |S₁| + 1 + have hins := filter_insert_of_bothOdd_rev hadj τ c hbo hrev + have hnotmem : (τ.symm b, τ.symm a) ∉ + univ.filter (fun p : Fin (n+1) × Fin (n+1) => + p.1 < p.2 ∧ + _root_.Equiv.swap a b (τ p.1) > _root_.Equiv.swap a b (τ p.2) ∧ + (c (_root_.Equiv.swap a b (τ p.1))).isRight ∧ + (c (_root_.Equiv.swap a b (τ p.2))).isRight) := by + simp only [mem_filter, mem_univ, true_and, not_and, + _root_.Equiv.apply_symm_apply, + _root_.Equiv.swap_apply_right, _root_.Equiv.swap_apply_left] + intro _hlt hgt + exact absurd hgt (by + simp only [gt_iff_lt, not_lt, Fin.le_def]; omega) + rw [hins, Finset.card_insert_of_notMem hnotmem] + change adjSign c a b * (-1 : ℂ) ^ (_ + 1) = (-1 : ℂ) ^ _ + rw [adjSign, ite_eq_left hbo, pow_succ] + ring + · -- Not both odd: the two filter sets are equal. + have heq := filter_eq_of_not_bothOdd hadj τ c hbo + rw [heq] + change adjSign c a b * (-1 : ℂ) ^ _ = (-1 : ℂ) ^ _ + rw [adjSign, ite_eq_right hbo, one_mul] + +/-- **The word sign is an inversion count**: it is `(−1)` to the +number of inversions of the word's permutation at odd positions. -/ +theorem wordSign_eq_oddInversions {n : ℕ} (w : List (Fin n)) + (c : MixedColouring k ℓ (n + 1)) : + wordSign w c = + (-1 : ℂ) ^ oddInversions (wordPerm w) c := by + induction w generalizing c with + | nil => + simp only [wordSign, wordPerm, oddInversions_one, pow_zero] + | cons i w ih => + change adjSign c ⟨i.val, by omega⟩ ⟨i.val + 1, by omega⟩ * + wordSign w (c ∘ _root_.Equiv.swap + (⟨i.val, by omega⟩ : Fin (n + 1)) + ⟨i.val + 1, by omega⟩) = + (-1 : ℂ) ^ oddInversions + (_root_.Equiv.swap (⟨i.val, by omega⟩ : Fin (n + 1)) + ⟨i.val + 1, by omega⟩ * wordPerm w) c + rw [ih] + exact neg_one_pow_oddInversions_swap_mul + ⟨i.val, by omega⟩ ⟨i.val + 1, by omega⟩ rfl + (wordPerm w) c + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantExpand.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantExpand.lean new file mode 100644 index 0000000000..56a16026ba --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantExpand.lean @@ -0,0 +1,81 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffExtract + +/-! +# Coefficients against the staircase alternant + +Multiplying by the zero-shape alternant `det (powMat 0) = a_δ` +shifts coefficient extraction by the permuted staircase: the +coefficient of `w₀` in `P · a_δ` is the signed sum over +permutations of the guarded shifted coefficients of `P`. +-/ + +@[expose] public section + +namespace RS + +open Finset MvPolynomial Equiv + +variable {k : ℕ} + +/-- The permuted staircase exponent. -/ +noncomputable def stairShift (τ : Equiv.Perm (Fin k)) : + Fin k →₀ ℕ := + ∑ i, Finsupp.single i ((k - 1) - ((τ i : Fin k) : ℕ)) + +/-- The staircase shift at a row, under a permutation. -/ +theorem stairShift_apply (τ : Equiv.Perm (Fin k)) (j : Fin k) : + stairShift τ j = (k - 1) - ((τ j : Fin k) : ℕ) := + sum_single_apply (fun i => (k - 1) - ((τ i : Fin k) : ℕ)) j + +/-- **Coefficient extraction against the staircase alternant.** -/ +theorem coeff_mul_alternant (P : MvPolynomial (Fin k) ℂ) + (w₀ : Fin k →₀ ℕ) : + (P * (powMat (fun _ : Fin k => 0)).det).coeff w₀ = + ∑ τ : Equiv.Perm (Fin k), + ((Equiv.Perm.sign τ : ℤ) : ℂ) * + (if stairShift τ ≤ w₀ + then P.coeff (w₀ - stairShift τ) + else 0) := by + classical + rw [Matrix.det_apply'] + rw [Finset.sum_congr rfl + (fun (τ : Equiv.Perm (Fin k)) (_ : τ ∈ Finset.univ) => + show ((Equiv.Perm.sign τ : ℤ) : MvPolynomial (Fin k) ℂ) * + ∏ i, powMat (fun _ : Fin k => 0) (τ i) i = + ((Equiv.Perm.sign τ : ℤ) : MvPolynomial (Fin k) ℂ) * + monomial (stairShift τ) (1 : ℂ) from by + rw [show (∏ i, powMat (fun _ : Fin k => 0) (τ i) i) = + ∏ i, (X i : MvPolynomial (Fin k) ℂ) ^ + ((k - 1) - ((τ i : Fin k) : ℕ)) from + Finset.prod_congr rfl fun i _ => by + change (X i : MvPolynomial (Fin k) ℂ) ^ + (0 + ((k - 1) - ((τ i : Fin k) : ℕ))) = _ + rw [Nat.zero_add]] + rw [prod_pow_eq_monomial, stairShift])] + rw [Finset.mul_sum] + rw [Finset.sum_congr rfl + (fun (τ : Equiv.Perm (Fin k)) (_ : τ ∈ Finset.univ) => + show P * (((Equiv.Perm.sign τ : ℤ) : + MvPolynomial (Fin k) ℂ) * + monomial (stairShift τ) (1 : ℂ)) = + MvPolynomial.C ((Equiv.Perm.sign τ : ℤ) : ℂ) * + (P * monomial (stairShift τ) (1 : ℂ)) from by + rw [show ((Equiv.Perm.sign τ : ℤ) : MvPolynomial (Fin k) ℂ) = + MvPolynomial.C ((Equiv.Perm.sign τ : ℤ) : ℂ) from by simp] + ring)] + rw [MvPolynomial.coeff_sum] + refine Finset.sum_congr rfl fun τ _ => ?_ + rw [MvPolynomial.coeff_C_mul, coeff_mul_monomial'] + by_cases hle : stairShift τ ≤ w₀ + · rw [ite_eq_left hle, ite_eq_left hle, mul_one] + · rw [ite_eq_right hle, ite_eq_right hle] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantPieri.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantPieri.lean new file mode 100644 index 0000000000..f192b6ec44 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantPieri.lean @@ -0,0 +1,139 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffExtract + +/-! +# Pieri rule for plain alternants + +The power-sum `p₁ = ∑ l, X l` times the plain alternant `a_e` +equals the sum of alternants with one exponent bumped: + + `p₁ · a_e = ∑ i, a_{e + δ_i}`. + +The proof is a signed-monomial reindexing: expand both sides +via `det_apply'`, use the per-term product identity for +`Function.update`, swap/reindex sums via `Equiv.sum_comp`, and +match termwise. +-/ + +@[expose] public section + +namespace RS + +open Finset MvPolynomial Equiv + +variable {k : ℕ} + +/-- The plain power alternant of an exponent vector. -/ +noncomputable def altDet {k : ℕ} (e : Fin k → ℕ) : + MvPolynomial (Fin k) ℂ := + (Matrix.of fun i j : Fin k => + (X j : MvPolynomial (Fin k) ℂ) ^ (e i)).det + +/-- Per-term product identity: bumping exponent `m` in the product +over a permutation pulls out `X (τ.symm m)`. -/ +private theorem prod_update_eq (τ : Equiv.Perm (Fin k)) + (e : Fin k → ℕ) (m : Fin k) : + ∏ i : Fin k, (X i : MvPolynomial (Fin k) ℂ) ^ + (Function.update e m (e m + 1) (τ i)) = + X (τ.symm m) * + ∏ i : Fin k, (X i : MvPolynomial (Fin k) ℂ) ^ (e (τ i)) := by + -- Each factor: X i ^ (update e m (e m+1) (τ i)) + -- = (if i = τ.symm m then X i else 1) * X i ^ (e (τ i)) + have hfact : ∀ i : Fin k, + (X i : MvPolynomial (Fin k) ℂ) ^ + (Function.update e m (e m + 1) (τ i)) = + (if i = τ.symm m then (X i : MvPolynomial (Fin k) ℂ) else 1) * + (X i : MvPolynomial (Fin k) ℂ) ^ (e (τ i)) := by + intro i + by_cases h : i = τ.symm m + · subst h + rw [show (τ : Fin k → Fin k) (τ.symm m) = m + from Equiv.apply_symm_apply τ m] + rw [Function.update_self, ite_eq_left rfl, pow_succ, + mul_comm ((X (τ.symm m) : MvPolynomial (Fin k) ℂ) ^ _)] + · have hne : (τ : Fin k → Fin k) i ≠ m := fun h' => + h (show i = τ.symm m from by + rw [← h', Equiv.symm_apply_apply]) + rw [Function.update_of_ne hne _ _, ite_eq_right h, one_mul] + rw [Finset.prod_congr rfl (fun i _ => hfact i)] + rw [Finset.prod_mul_distrib] + rw [Finset.prod_ite_eq' Finset.univ (τ.symm m) + (fun i => (X i : MvPolynomial (Fin k) ℂ))] + rw [ite_eq_left (Finset.mem_univ _)] + +open scoped Classical in +/-- **The Pieri rule for alternants**: multiplying by the first +power sum bumps one exponent, summed over which. -/ +theorem p1_mul_altDet {k : ℕ} (e : Fin k → ℕ) : + (∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) * altDet e = + ∑ i : Fin k, altDet (Function.update e i (e i + 1)) := by + -- Abbreviations for readability: + -- P τ := ∏ i, X i ^ (e (τ i)) + -- ε τ := ((Equiv.Perm.sign τ : ℤ) : MvPolynomial (Fin k) ℂ) + -- We show both sides equal ∑ τ, ∑ l, ε τ * (X l * P τ). + -- === LHS transformation === + -- Step L1: Expand altDet e via det_apply', reduce Matrix.of + rw [show altDet e = + ∑ τ : Equiv.Perm (Fin k), + ((Equiv.Perm.sign τ : ℤ) : MvPolynomial (Fin k) ℂ) * + ∏ i, (X i : MvPolynomial (Fin k) ℂ) ^ (e (τ i)) + from by + rw [show altDet e = (Matrix.of fun i j : Fin k => + (X j : MvPolynomial (Fin k) ℂ) ^ (e i)).det from rfl] + rw [Matrix.det_apply'] + exact Finset.sum_congr rfl fun τ _ => rfl] + -- Step L2: Distribute (∑ l, X l) * ∑ τ via mul_sum + rw [Finset.mul_sum] + -- Step L3: For each τ, distribute to get ∑ l + rw [Finset.sum_congr rfl fun τ (_ : τ ∈ Finset.univ) => + show (∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) * + (((Equiv.Perm.sign τ : ℤ) : MvPolynomial (Fin k) ℂ) * + ∏ i, (X i : MvPolynomial (Fin k) ℂ) ^ (e (τ i))) = + ∑ l : Fin k, + ((Equiv.Perm.sign τ : ℤ) : MvPolynomial (Fin k) ℂ) * + ((X l : MvPolynomial (Fin k) ℂ) * + ∏ i, (X i : MvPolynomial (Fin k) ℂ) ^ (e (τ i))) + from by + rw [Finset.sum_mul] + exact Finset.sum_congr rfl fun l _ => mul_left_comm _ _ _] + -- === RHS transformation === + -- Step R1: Expand each altDet (update ...) via det_apply' + rw [Finset.sum_congr rfl fun m (_ : m ∈ Finset.univ) => + show altDet (Function.update e m (e m + 1)) = + ∑ τ : Equiv.Perm (Fin k), + ((Equiv.Perm.sign τ : ℤ) : MvPolynomial (Fin k) ℂ) * + ∏ i, (X i : MvPolynomial (Fin k) ℂ) ^ + (Function.update e m (e m + 1) (τ i)) + from by + rw [show altDet (Function.update e m (e m + 1)) = + (Matrix.of fun i j : Fin k => + (X j : MvPolynomial (Fin k) ℂ) ^ + (Function.update e m (e m + 1) i)).det from rfl] + rw [Matrix.det_apply'] + exact Finset.sum_congr rfl fun τ _ => rfl] + -- Step R2: Apply prod_update_eq + rw [Finset.sum_congr rfl fun m (_ : m ∈ Finset.univ) => + show (∑ τ : Equiv.Perm (Fin k), + ((Equiv.Perm.sign τ : ℤ) : MvPolynomial (Fin k) ℂ) * + ∏ i, (X i : MvPolynomial (Fin k) ℂ) ^ + (Function.update e m (e m + 1) (τ i))) = + ∑ τ : Equiv.Perm (Fin k), + ((Equiv.Perm.sign τ : ℤ) : MvPolynomial (Fin k) ℂ) * + (X (τ.symm m) * + ∏ i, (X i : MvPolynomial (Fin k) ℂ) ^ (e (τ i))) + from Finset.sum_congr rfl fun τ _ => by + rw [prod_update_eq]] + -- Step R3: Swap sums on RHS only: ∑ m, ∑ τ → ∑ τ, ∑ m + conv_rhs => rw [Finset.sum_comm] + -- Step R4: Reindex inner sum via τ.symm (reverse direction) + exact Finset.sum_congr rfl fun (τ : Equiv.Perm (Fin k)) _ => + (Equiv.sum_comp τ.symm _).symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantStrict.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantStrict.lean new file mode 100644 index 0000000000..3e5f5bd735 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantStrict.lean @@ -0,0 +1,112 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantPieri + +/-! +# Coefficients of strict alternants + +An alternant with a repeated exponent vanishes; the coefficient of +a strictly decreasing monomial in a strictly decreasing alternant +is the equality indicator — the two facts driving nonnegativity in +the Pieri chain. +-/ + +@[expose] public section + +namespace RS + +open Finset MvPolynomial Equiv + +variable {k : ℕ} + +/-- An alternant with a repeated exponent vanishes. -/ +theorem altDet_eq_zero_of_repeat (e : Fin k → ℕ) {i j : Fin k} + (hij : i ≠ j) (he : e i = e j) : altDet e = 0 := by + rw [altDet] + apply Matrix.det_zero_of_row_eq hij + funext l + change (X l : MvPolynomial (Fin k) ℂ) ^ (e i) = X l ^ (e j) + rw [he] + +/-- Strictly decreasing sequences agreeing after a permutation +agree with the identity permutation. -/ +private theorem perm_eq_one_of_strict (e w : Fin k → ℕ) + (he : ∀ i j : Fin k, i < j → w j < w i) + (hw : ∀ i j : Fin k, i < j → e j < e i) + (τ : Equiv.Perm (Fin k)) (h : ∀ i, e (τ i) = w i) : + e = w := by + have hop : ∀ a b : Fin k, a < b → ¬ (τ b < τ a) := by + intro a b hab hba + have h2 : e (τ a) < e (τ b) := hw (τ b) (τ a) hba + rw [h a, h b] at h2 + exact absurd h2 (not_lt.mpr (le_of_lt (he a b hab))) + have hmono2 : StrictMono (τ : Fin k → Fin k) := by + intro a b hab + rcases lt_trichotomy (τ a) (τ b) with h1 | h1 | h1 + · exact h1 + · exact absurd (τ.injective h1) (ne_of_lt hab) + · exact absurd h1 (hop a b hab) + have happ : ∀ i : Fin k, τ i = i := by + intro i + have h2 := congrFun (StrictMono.coe_orderIsoOfSurjective + (τ : Fin k → Fin k) hmono2 τ.surjective) i + rw [Subsingleton.elim (StrictMono.orderIsoOfSurjective + (τ : Fin k → Fin k) hmono2 τ.surjective) + (OrderIso.refl (Fin k))] at h2 + exact h2.symm + funext i + have := h i + rw [happ i] at this + exact this + +/-- **The strict alternant coefficient dichotomy**: the coefficient +of a strictly decreasing monomial in a strictly decreasing +alternant is the equality indicator. -/ +theorem alternant_coeff_strict (e w : Fin k → ℕ) + (he : ∀ i j : Fin k, i < j → e j < e i) + (hw : ∀ i j : Fin k, i < j → w j < w i) : + (altDet e).coeff (∑ i, Finsupp.single i (w i)) = + if e = w then 1 else 0 := by + classical + by_cases heq : e = w + · subst heq + rw [ite_eq_left rfl, altDet] + exact alternant_coeff e (fun i j hij => by + rcases lt_trichotomy i j with h | h | h + · exact absurd hij (ne_of_gt (he i j h)) + · exact h + · exact absurd hij.symm (ne_of_gt (he j i h))) + · rw [ite_eq_right heq, altDet, Matrix.det_apply'] + rw [Finset.sum_congr rfl + (fun (τ : Equiv.Perm (Fin k)) (_ : τ ∈ Finset.univ) => + show ((Equiv.Perm.sign τ : ℤ) : MvPolynomial (Fin k) ℂ) * + ∏ i, (Matrix.of fun i j : Fin k => + (X j : MvPolynomial (Fin k) ℂ) ^ (e i)) (τ i) i = + ((Equiv.Perm.sign τ : ℤ) : MvPolynomial (Fin k) ℂ) * + monomial (∑ i, Finsupp.single i (e (τ i))) (1 : ℂ) + from by + rw [show (∏ i, (Matrix.of fun i j : Fin k => + (X j : MvPolynomial (Fin k) ℂ) ^ (e i)) (τ i) i) = + ∏ i, (X i : MvPolynomial (Fin k) ℂ) ^ (e (τ i)) + from rfl] + rw [prod_pow_eq_monomial])] + rw [MvPolynomial.coeff_sum] + refine Finset.sum_eq_zero fun τ _ => ?_ + rw [show ((Equiv.Perm.sign τ : ℤ) : MvPolynomial (Fin k) ℂ) = + MvPolynomial.C ((Equiv.Perm.sign τ : ℤ) : ℂ) from by simp, + MvPolynomial.coeff_C_mul, coeff_monomial] + rw [ite_eq_right (fun hc => ?_), mul_zero] + have hpt : ∀ i : Fin k, e (τ i) = w i := by + intro i + have h1 := congrArg (fun f : Fin k →₀ ℕ => f i) hc + rw [sum_single_apply, sum_single_apply] at h1 + exact h1 + exact heq (perm_eq_one_of_strict e w hw he τ hpt) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/Bialternant.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/Bialternant.lean new file mode 100644 index 0000000000..c8461c3a22 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/Bialternant.lean @@ -0,0 +1,138 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.EHDischarge + +/-! +# The bialternant Jacobi–Trudi identity + +The matrix of variable powers `x_j^{v i + (k−1−i)}` factors as the +column-reversed Jacobi–Trudi matrix of complete homogeneous +polynomials times the signed elementary matrix in the +complementary variables — entrywise this is the resolvent. Taking +determinants and anchoring at `v = 0` gives the bialternant form: + + `det (powMat v) = det (jtMat v) * det (powMat 0)`, + +the polynomial Jacobi–Trudi identity `a_{v+δ} = s_v · a_δ`. +-/ + +@[expose] public section + +namespace RS + +open Finset MvPolynomial Equiv + +variable {k : ℕ} + +/-- The alternant matrix of variable powers. -/ +noncomputable def powMat (v : Fin k → ℕ) : + Matrix (Fin k) (Fin k) (MvPolynomial (Fin k) ℂ) := + Matrix.of fun i j => X j ^ (v i + ((k - 1) - (i : ℕ))) + +/-- The column-reversed complete homogeneous matrix. -/ +noncomputable def hMat (v : Fin k → ℕ) : + Matrix (Fin k) (Fin k) (MvPolynomial (Fin k) ℂ) := + Matrix.of fun i r => hSubZ Finset.univ + ((v i : ℤ) + ((k : ℤ) - 1 - (r : ℕ)) - (i : ℕ)) + +/-- The Jacobi–Trudi matrix of complete homogeneous +polynomials. -/ +noncomputable def jtMat (v : Fin k → ℕ) : + Matrix (Fin k) (Fin k) (MvPolynomial (Fin k) ℂ) := + Matrix.of fun i j => hSubZ Finset.univ + ((v i : ℤ) + (j : ℕ) - (i : ℕ)) + +/-- The signed elementary matrix in complementary variables. -/ +noncomputable def eMat (k : ℕ) : + Matrix (Fin k) (Fin k) (MvPolynomial (Fin k) ℂ) := + Matrix.of fun r j => + (-1) ^ (r : ℕ) * eSub (Finset.univ.erase j) r + +/-- **The entrywise factorization** via the resolvent. -/ +theorem powMat_eq_mul (v : Fin k → ℕ) : + powMat v = hMat v * eMat k := by + refine Matrix.ext fun i j => ?_ + rw [Matrix.mul_apply] + have hj : j ∉ Finset.univ.erase j := Finset.notMem_erase j _ + have hcard : (Finset.univ.erase j).card + 1 = k := by + rw [Finset.card_erase_of_mem (Finset.mem_univ j), + Finset.card_univ, Fintype.card_fin] + have hk := j.pos + omega + have hres := sum_fin_resolvent' hj hcard (v i + ((k - 1) - (i : ℕ))) + rw [Finset.insert_erase (Finset.mem_univ j)] at hres + rw [show powMat v i j = X j ^ (v i + ((k - 1) - (i : ℕ))) + from rfl] + rw [← hres] + refine Finset.sum_congr rfl fun r _ => ?_ + rw [show hMat v i r = hSubZ Finset.univ + ((v i : ℤ) + ((k : ℤ) - 1 - (r : ℕ)) - (i : ℕ)) from rfl] + rw [show eMat k r j = + (-1) ^ (r : ℕ) * eSub (Finset.univ.erase j) r from rfl] + rw [show ((v i + ((k - 1) - (i : ℕ)) : ℕ) : ℤ) - (r : ℕ) = + (v i : ℤ) + ((k : ℤ) - 1 - (r : ℕ)) - (i : ℕ) from by + have hi := i.isLt + omega] + ring + +/-- The reversed columns of `hMat` give the Jacobi–Trudi +matrix. -/ +theorem hMat_eq_submatrix (v : Fin k → ℕ) : + hMat v = (jtMat v).submatrix id Fin.revPerm := by + refine Matrix.ext fun i r => ?_ + change hSubZ Finset.univ + ((v i : ℤ) + ((k : ℤ) - 1 - (r : ℕ)) - (i : ℕ)) = + hSubZ Finset.univ + ((v i : ℤ) + ((Fin.revPerm r : Fin k) : ℕ) - (i : ℕ)) + congr 1 + have hr := r.isLt + have hrev : ((Fin.revPerm r : Fin k) : ℕ) = k - ((r : ℕ) + 1) := + Fin.val_rev r + rw [hrev] + omega + +/-- The power matrix's determinant is the Jacobi–Trudi matrix's, up +to the column-reversal sign. -/ +theorem det_hMat (v : Fin k → ℕ) : + (hMat v).det = + ((Equiv.Perm.sign (Fin.revPerm : Equiv.Perm (Fin k)) : ℤ) : + MvPolynomial (Fin k) ℂ) * (jtMat v).det := by + rw [hMat_eq_submatrix, Matrix.det_permute'] + +/-- The zero-shape Jacobi–Trudi matrix is upper triangular with +unit diagonal. -/ +theorem det_jtMat_zero : + (jtMat (fun _ : Fin k => 0)).det = 1 := by + rw [Matrix.det_of_isUpperTriangular] + · refine Finset.prod_eq_one fun i _ => ?_ + change hSubZ Finset.univ + (((0 : ℕ) : ℤ) + (i : ℕ) - (i : ℕ)) = 1 + rw [show (((0 : ℕ) : ℤ) + (i : ℕ) - (i : ℕ)) = + ((0 : ℕ) : ℤ) from by omega] + rw [hSubZ_natCast, hSub_zero] + · intro i j hij + change hSubZ Finset.univ + (((0 : ℕ) : ℤ) + (j : ℕ) - (i : ℕ)) = 0 + have hlt : (j : ℕ) < (i : ℕ) := hij + exact hSubZ_neg _ _ (by omega) + +/-- **The bialternant Jacobi–Trudi identity**: +`a_{v+δ} = s_v · a_δ` over the polynomial ring. -/ +theorem bialternant (v : Fin k → ℕ) : + (powMat v).det = + (jtMat v).det * (powMat (fun _ : Fin k => 0)).det := by + have h1 : (powMat v).det = (hMat v).det * (eMat k).det := by + rw [powMat_eq_mul, Matrix.det_mul] + have h0 : (powMat (fun _ : Fin k => 0)).det = + (hMat (fun _ : Fin k => 0)).det * (eMat k).det := by + rw [powMat_eq_mul, Matrix.det_mul] + rw [h1, det_hMat, h0, det_hMat, det_jtMat_zero] + ring + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/BinomialDet.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/BinomialDet.lean new file mode 100644 index 0000000000..af4248bf92 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/BinomialDet.lean @@ -0,0 +1,317 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialH +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareStair + +/-! +# Nonvanishing of square-diagram Schur values at constant sequences + +The Jacobi–Trudi determinant for the square diagram at constant +power-sum sequences `m` (resp. `−m`) is nonzero. The positive case +is proved here by a row-normalized product identity; the negated +case is stated as `SquareBinomialDetPos` and proved by the +Lindström–Gessel–Viennot argument of `LGVStrict.lean`. +-/ + +@[expose] public section + +namespace RS + +open Finset Matrix + +/-! ## The hard core -/ + +/-- The negated case: the Jacobi–Trudi determinant for +`squareDiagram s` evaluated at the constant negative sequence `−m` +is nonzero whenever `s ≤ m`. + +Equivalently (by sign extraction), the binomial Toeplitz determinant +`det [C(m, s+j−i)]_{0 ≤ i,j < s}` is nonzero for `m ≥ s`. + +Proved as `squareBinomialDetPos` in `LGVStrict.lean`, by a +Lindström–Gessel–Viennot lattice-path count whose +non-intersecting-path formula is manifestly positive. -/ +abbrev SquareBinomialDetPos : Prop := + ∀ (s m : ℕ), 1 ≤ s → s ≤ m → + diagramSchur (squareDiagram s) (fun _ => -(m : ℂ)) ≠ 0 + +/-! ## Combinatorial tools -/ + +private theorem vandermonde_conv (a b n : ℕ) : + Nat.choose (a + b) n = + ∑ k ∈ Finset.range (n + 1), + Nat.choose a (n - k) * Nat.choose b k := by + calc Nat.choose (a + b) n + = Nat.choose (b + a) n := by rw [show a + b = b + a from by omega] + _ = ∑ ij ∈ Finset.antidiagonal n, + Nat.choose b ij.1 * Nat.choose a ij.2 := + Nat.add_choose_eq b a n + _ = ∑ k ∈ Finset.range (n + 1), + Nat.choose b k * Nat.choose a (n - k) := + Finset.Nat.sum_antidiagonal_eq_sum_range_succ + (fun p q => Nat.choose b p * Nat.choose a q) n + _ = _ := Finset.sum_congr rfl (fun k _ => Nat.mul_comm _ _) + +private theorem vandermonde_conv_trunc (s m : ℕ) (hm : s ≤ m) + (a j : ℕ) (hj : j < s) : + Nat.choose (a + j) (m - 1) = + ∑ t ∈ Finset.range s, + Nat.choose a (m - 1 - t) * Nat.choose j t := by + rw [vandermonde_conv a j (m - 1), show m - 1 + 1 = m from by omega] + symm; apply Finset.sum_subset (Finset.range_mono hm) + intro t ht hts + have : s ≤ t := by rw [Finset.mem_range] at hts; omega + rw [Nat.choose_eq_zero_of_lt (show j < t by omega), Nat.mul_zero] + +private theorem det_choose_upper (s : ℕ) : + (Matrix.of fun t j : Fin s => + (Nat.choose (j : ℕ) (t : ℕ) : ℂ)).det = 1 := by + rw [Matrix.det_of_isUpperTriangular (fun t j (htj : id j < id t) => by + rw [Matrix.of_apply] + exact_mod_cast Nat.choose_eq_zero_of_lt htj)] + simp [Matrix.of_apply, Nat.choose_self] + +private theorem diagramSchur_empty (t : ℕ → ℂ) : + diagramSchur (squareDiagram 0) t = 1 := by + rw [diagramSchur, schurDet] + have : (squareDiagram 0).rowLens = [] := + List.eq_nil_of_length_eq_zero (by rw [squareDiagram_rowLens, + List.length_replicate]) + rw [this]; simp + +private theorem descFactorial_add (n k l : ℕ) : + n.descFactorial (k + l) = + n.descFactorial k * (n - k).descFactorial l := by + rw [Nat.descFactorial_eq_prod_range, Nat.descFactorial_eq_prod_range, + Nat.descFactorial_eq_prod_range, Finset.prod_range_add] + congr 1; apply Finset.prod_congr rfl; intro i _; omega + +/-! ## Positive case: the row-normalized product identity -/ + +/-- The core determinantal identity for `diagramSchur (squareDiagram s)` +at the constant sequence `m`. Mirrors `diagramSchur_delta_mul`. -/ +private theorem diagramSchur_square_const_mul (s m : ℕ) (hm : s ≤ m) + (hs : 1 ≤ s) : + diagramSchur (squareDiagram s) (fun _ => (m : ℂ)) * + ∏ j : Fin s, (((m - 1 - (j : ℕ)).factorial : ℕ) : ℂ) = + (∏ i : Fin s, + (((m + s - 1 - (i : ℕ)).descFactorial (m - s) : ℕ) : ℂ)) * + ∏ i : Fin s, ∏ j ∈ Finset.Ioi i, + (((s + (j : ℕ) : ℕ) : ℂ) - ((s + (i : ℕ) : ℕ) : ℂ)) := by + classical + have hm1 : 1 ≤ m := by omega + have hL : (squareDiagram s).rowLens.length = s := + square_rowLens_length s + rw [diagramSchur, schurDet] + set L := (squareDiagram s).rowLens.length with hLdef + -- ═══════ SETUP: TRANSPORT THE PRODUCTS TO THE MATRIX INDEX ═══════ + -- Transport Fin s products to Fin L (matching matrix dimension) + rw [show (∏ j : Fin s, (((m - 1 - (j : ℕ)).factorial : ℕ) : ℂ)) = + (∏ j : Fin L, (((m - 1 - (j : ℕ)).factorial : ℕ) : ℂ)) from hL ▸ rfl, + show (∏ i : Fin s, + (((m + s - 1 - (i : ℕ)).descFactorial (m - s) : ℕ) : ℂ)) = + (∏ i : Fin L, + (((m + s - 1 - (i : ℕ)).descFactorial (m - s) : ℕ) : ℂ)) from hL ▸ rfl, + show (∏ i : Fin s, ∏ j ∈ Finset.Ioi i, + (((s + (j : ℕ) : ℕ) : ℂ) - ((s + (i : ℕ) : ℕ) : ℂ))) = + (∏ i : Fin L, ∏ j ∈ Finset.Ioi i, + (((s + (j : ℕ) : ℕ) : ℂ) - ((s + (i : ℕ) : ℕ) : ℂ))) from hL ▸ rfl] + -- Now all products and the matrix are over Fin L + set L_mat := Matrix.of fun (i t : Fin L) => + (Nat.choose (m + s - 1 - (i : ℕ)) (m - 1 - (t : ℕ)) : ℂ) + with hLmat + set U_mat := Matrix.of fun (t j : Fin L) => + (Nat.choose (j : ℕ) (t : ℕ) : ℂ) with hUmat + -- ═══════ STAGE 1: THE PASCAL FACTORIZATION `A = L · U` ═══════ + have hAeq : (Matrix.of fun i j : Fin L => + newtonHZ (fun _ => (m : ℂ)) + (((squareDiagram s).rowLens.get i : ℤ) + + (j : ℕ) - (i : ℕ))) = L_mat * U_mat := by + refine Matrix.ext fun i j => ?_ + rw [Matrix.of_apply, hLmat, hUmat, Matrix.mul_apply] + simp only [Matrix.of_apply] + have hi : (i : ℕ) < s := by rw [← hL]; exact i.isLt + have hj : (j : ℕ) < s := by rw [← hL]; exact j.isLt + rw [List.get_eq_getElem, YoungDiagram.get_rowLens, + rowLen_squareDiagram hi] + have hpos : 0 ≤ (s : ℤ) + ((j : ℕ) : ℤ) - ((i : ℕ) : ℤ) := by + omega + rw [newtonHZ, ite_eq_left hpos] + have harg : ((s : ℤ) + ↑↑j - ↑↑i).toNat = + s + (j : ℕ) - (i : ℕ) := by omega + rw [harg, newtonH_const] + have hcompl : + Nat.choose (m + (s + (j : ℕ) - (i : ℕ)) - 1) + (s + (j : ℕ) - (i : ℕ)) = + Nat.choose (m + s - 1 - (i : ℕ) + (j : ℕ)) (m - 1) := by + rw [show m + (s + (j : ℕ) - (i : ℕ)) - 1 = + m + s - 1 - (i : ℕ) + (j : ℕ) from by omega, + show s + (j : ℕ) - (i : ℕ) = + (m + s - 1 - (i : ℕ) + (j : ℕ)) - (m - 1) from by omega] + exact Nat.choose_symm (by omega) + -- Prove the full ℕ identity, then cast + have hnat : Nat.choose (m + (s + (j : ℕ) - (i : ℕ)) - 1) + (s + (j : ℕ) - (i : ℕ)) = + ∑ t : Fin L, Nat.choose (m + s - 1 - (i : ℕ)) (m - 1 - (t : ℕ)) * + Nat.choose ((j : ℕ)) (t : ℕ) := by + rw [hcompl, vandermonde_conv_trunc s m hm + (m + s - 1 - (i : ℕ)) ((j : ℕ)) hj, + ← Fin.sum_univ_eq_sum_range] + exact hL ▸ rfl + exact_mod_cast hnat + rw [hAeq, Matrix.det_mul] + have hUdet : U_mat.det = 1 := by + rw [hUmat, show L = s from hL]; exact det_choose_upper s + rw [hUdet, mul_one] + -- ═══════ STAGE 2: ROW-NORMALIZE AND SPLIT THE ENTRIES ═══════ + rw [mul_comm, ← Matrix.det_mul_row + (fun j : Fin L => (((m - 1 - (j : ℕ)).factorial : ℕ) : ℂ))] + have hEntryDF : ∀ (i j : Fin L), + (((m - 1 - (j : ℕ)).factorial : ℕ) : ℂ) * + (Nat.choose (m + s - 1 - (i : ℕ)) (m - 1 - (j : ℕ)) : ℂ) = + ((m + s - 1 - (i : ℕ)).descFactorial (m - 1 - (j : ℕ)) : ℂ) := by + intro i j + have hnat : (m - 1 - (j : ℕ)).factorial * + Nat.choose (m + s - 1 - (i : ℕ)) (m - 1 - (j : ℕ)) = + (m + s - 1 - (i : ℕ)).descFactorial (m - 1 - (j : ℕ)) := by + rw [Nat.choose_eq_descFactorial_div_factorial] + exact Nat.mul_div_cancel' (Nat.factorial_dvd_descFactorial _ _) + exact_mod_cast hnat + have hDFsplit : ∀ (i j : Fin L), + (m + s - 1 - (i : ℕ)).descFactorial (m - 1 - (j : ℕ)) = + (m + s - 1 - (i : ℕ)).descFactorial (m - s) * + (2 * s - 1 - (i : ℕ)).descFactorial (s - 1 - (j : ℕ)) := by + intro i j + have hi : (i : ℕ) < s := by rw [← hL]; exact i.isLt + have hj : (j : ℕ) < s := by rw [← hL]; exact j.isLt + rw [show m - 1 - (j : ℕ) = (m - s) + (s - 1 - (j : ℕ)) + from by omega, descFactorial_add] + congr 1; congr 1; omega + have h1 : + (Matrix.of fun i j : Fin L => + (((m - 1 - (j : ℕ)).factorial : ℕ) : ℂ) * + (Nat.choose (m + s - 1 - (i : ℕ)) (m - 1 - (j : ℕ)) : ℂ)).det = + (∏ i : Fin L, + (((m + s - 1 - (i : ℕ)).descFactorial (m - s) : ℕ) : ℂ)) * + (Matrix.of fun i j : Fin L => + (descPochhammer ℂ (s - 1 - (j : ℕ))).eval + ((2 * s - 1 - (i : ℕ) : ℕ) : ℂ)).det := by + rw [← Matrix.det_mul_column + (fun i : Fin L => + (((m + s - 1 - (i : ℕ)).descFactorial (m - s) : ℕ) : ℂ))] + congr 1 + refine Matrix.ext fun i j => ?_ + simp only [Matrix.of_apply] + rw [hEntryDF i j, descPochhammer_eval_eq_descFactorial] + push_cast [hDFsplit i j]; ring + have h2 : + (Matrix.of fun i j : Fin L => + (descPochhammer ℂ (s - 1 - (j : ℕ))).eval + ((2 * s - 1 - (i : ℕ) : ℕ) : ℂ)).det = + ∏ i : Fin L, ∏ j ∈ Finset.Ioi i, + (((s + (j : ℕ) : ℕ) : ℂ) - + ((s + (i : ℕ) : ℕ) : ℂ)) := by + rw [← Matrix.det_submatrix_equiv_self + (Fin.revPerm : Equiv.Perm (Fin L))] + have hsub : + (Matrix.of fun i j : Fin L => + (descPochhammer ℂ (s - 1 - (j : ℕ))).eval + ((2 * s - 1 - (i : ℕ) : ℕ) : ℂ)).submatrix + (⇑Fin.revPerm) (⇑Fin.revPerm) = + Matrix.of fun i j : Fin L => + (descPochhammer ℂ (j : ℕ)).eval + ((s + (i : ℕ) : ℕ) : ℂ) := by + refine Matrix.ext fun i j => ?_ + rw [Matrix.submatrix_apply, Matrix.of_apply, Matrix.of_apply] + have hri : ((Fin.revPerm i : Fin L) : ℕ) = + L - ((i : ℕ) + 1) := Fin.val_rev i + have hrj : ((Fin.revPerm j : Fin L) : ℕ) = + L - ((j : ℕ) + 1) := Fin.val_rev j + have hi := i.isLt + have hj := j.isLt + have hLs : L = s := hL + rw [hrj, hri] + have hd : s - 1 - (L - ((j : ℕ) + 1)) = (j : ℕ) := by omega + have he : 2 * s - 1 - (L - ((i : ℕ) + 1)) = s + (i : ℕ) := by omega + rw [hd, he] + rw [hsub, det_descPochhammer_eval] + -- ═══════ ASSEMBLY ═══════ + -- Unfold L_mat so the goal matches h1 + simp only [hLmat, Matrix.of_apply] + rw [h1, h2] + +/-! ## Positive case: nonvanishing -/ + +/-- The square-diagram Schur value at the constant sequence `m` is +a positive rational. -/ +theorem diagramSchur_square_const_pos (s m : ℕ) (hm : s ≤ m) : + ∃ N D : ℕ, 0 < N ∧ 0 < D ∧ + (D : ℂ) * diagramSchur (squareDiagram s) (fun _ => (m : ℂ)) = + (N : ℂ) := by + classical + rcases Nat.eq_zero_or_pos s with rfl | hs + · exact ⟨1, 1, Nat.one_pos, Nat.one_pos, by + rw [diagramSchur_empty]; push_cast; ring⟩ + have hid := diagramSchur_square_const_mul s m hm hs + -- Rewrite the ℂ-differences as ℕ casts + have hdiff : ∀ (i : Fin s) (j : Fin s), j ∈ Finset.Ioi i → + (((s + (j : ℕ) : ℕ) : ℂ) - ((s + (i : ℕ) : ℕ) : ℂ)) = + (((j : ℕ) - (i : ℕ) : ℕ) : ℂ) := by + intro i j hj + have hij : i < j := Finset.mem_Ioi.mp hj + have hij' : (i : ℕ) < (j : ℕ) := hij + push_cast [Nat.cast_sub (Nat.le_of_lt hij')] + ring + rw [Finset.prod_congr rfl (fun i _ => + Finset.prod_congr rfl (hdiff i))] at hid + set D := ∏ j : Fin s, (m - 1 - (j : ℕ)).factorial with hD_def + set R := ∏ i : Fin s, + (m + s - 1 - (i : ℕ)).descFactorial (m - s) with hR_def + set V := ∏ i : Fin s, ∏ j ∈ Finset.Ioi i, + ((j : ℕ) - (i : ℕ)) with hV_def + have hD_pos : 0 < D := + Finset.prod_pos fun j _ => Nat.factorial_pos _ + have hR_pos : 0 < R := by + apply Finset.prod_pos; intro i _ + rw [Nat.descFactorial_eq_prod_range] + apply Finset.prod_pos; intro t ht + rw [Finset.mem_range] at ht; have := i.isLt; omega + have hV_pos : 0 < V := by + apply Finset.prod_pos; intro i _ + apply Finset.prod_pos; intro j hj + have : i < j := Finset.mem_Ioi.mp hj + have hij : (i : ℕ) < (j : ℕ) := this + omega + refine ⟨R * V, D, Nat.mul_pos hR_pos hV_pos, hD_pos, ?_⟩ + show (D : ℂ) * diagramSchur (squareDiagram s) + (fun _ => (m : ℂ)) = ((R * V : ℕ) : ℂ) + rw [hD_def, hR_def, hV_def] + push_cast + linear_combination hid + +/-- The square-diagram Schur value at the constant sequence `m` +does not vanish. -/ +theorem diagramSchur_square_const_ne_zero (s m : ℕ) (hm : s ≤ m) : + diagramSchur (squareDiagram s) (fun _ => (m : ℂ)) ≠ 0 := by + obtain ⟨N, D, hN, hD, hDet⟩ := diagramSchur_square_const_pos s m hm + intro h; rw [h, mul_zero] at hDet + exact absurd (show (N : ℕ) = 0 from by exact_mod_cast hDet.symm) (by omega) + +/-! ## Negative case -/ + +/-- The square-diagram Schur value at the negated constant +sequence `−m` does not vanish. -/ +theorem diagramSchur_square_neg_const_ne_zero + (H : SquareBinomialDetPos) (s m : ℕ) (hm : s ≤ m) : + diagramSchur (squareDiagram s) (fun _ => -(m : ℂ)) ≠ 0 := by + rcases Nat.eq_zero_or_pos s with rfl | hs + · rw [diagramSchur_empty]; exact one_ne_zero + · exact H s m hs hm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/BinomialH.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/BinomialH.lean new file mode 100644 index 0000000000..610d90bf38 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/BinomialH.lean @@ -0,0 +1,150 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums + +/-! +# Complete homogeneous values at constant sequences + +At the constant power-sum sequence `m` the complete homogeneous +values are the binomial coefficients `C(m+d−1, d)` (the generating +function `(1−z)^{−m}`); at `−m` they are the signed binomials +`(−1)^d C(m, d)` (the generating function `(1−z)^m`). These feed +the tensor-space traces of the dimension-bound argument. +-/ + +@[expose] public section + +namespace RS + +open Finset + +/-- Partial sums of the positive binomial column (hockey stick). -/ +private theorem sum_choose_partial (m d : ℕ) : + ∑ j ∈ Finset.range (d + 1), (Nat.choose (m + j - 1) j : ℂ) = + (Nat.choose (m + d) d : ℂ) := by + induction d with + | zero => simp + | succ d ih => + rw [Finset.sum_range_succ, ih] + rw [show m + (d + 1) - 1 = m + d from by omega] + rw [show m + (d + 1) = (m + d) + 1 from by omega] + rw [Nat.choose_succ_succ (m + d) d] + push_cast + ring + +/-- Alternating partial sums of a binomial row. -/ +private theorem sum_alt_choose_partial (m d : ℕ) (hm : 1 ≤ m) : + ∑ j ∈ Finset.range (d + 1), + ((-1 : ℂ)) ^ j * (Nat.choose m j : ℂ) = + ((-1 : ℂ)) ^ d * (Nat.choose (m - 1) d : ℂ) := by + induction d with + | zero => simp + | succ d ih => + rw [Finset.sum_range_succ, ih] + have hnat : Nat.choose (m - 1) d + Nat.choose (m - 1) (d + 1) = + Nat.choose m (d + 1) := by + conv_rhs => rw [show m = (m - 1) + 1 from by omega] + rw [Nat.choose_succ_succ (m - 1) d] + have hcast : (Nat.choose (m - 1) d : ℂ) + + (Nat.choose (m - 1) (d + 1) : ℂ) = + (Nat.choose m (d + 1) : ℂ) := by + exact_mod_cast congrArg (Nat.cast (R := ℂ)) hnat + rw [pow_succ] + linear_combination (-((-1 : ℂ) ^ (d + 1))) * hcast + +/-- **Complete homogeneous values at the constant sequence** are +binomial coefficients. -/ +theorem newtonH_const (m : ℕ) (d : ℕ) : + newtonH (fun _ => (m : ℂ)) d = + (Nat.choose (m + d - 1) d : ℂ) := by + induction d using Nat.strong_induction_on with + | _ d ih => + match d with + | 0 => simp [newtonH_zero] + | d + 1 => + rw [newtonH] + rw [Finset.sum_congr rfl (fun i hi => by + rw [ih (d - i) (by + rw [Finset.mem_range] at hi + omega)])] + rw [show (∑ i ∈ Finset.range (d + 1), + (m : ℂ) * (Nat.choose (m + (d - i) - 1) (d - i) : ℂ)) = + (m : ℂ) * ∑ j ∈ Finset.range (d + 1), + (Nat.choose (m + j - 1) j : ℂ) from by + rw [Finset.mul_sum] + exact Finset.sum_nbij' (fun i => d - i) (fun j => d - j) + (fun i hi => Finset.mem_range.mpr (by + rw [Finset.mem_range] at hi; omega)) + (fun j hj => Finset.mem_range.mpr (by + rw [Finset.mem_range] at hj; omega)) + (fun i hi => by rw [Finset.mem_range] at hi; omega) + (fun j hj => by rw [Finset.mem_range] at hj; omega) + (fun i _ => rfl)] + rw [sum_choose_partial m d] + have h2 : Nat.choose (m + d) (d + 1) * (d + 1) = + Nat.choose (m + d) d * m := by + have h3 := Nat.choose_succ_right_eq (m + d) d + rw [show m + d - d = m from by omega] at h3 + exact h3 + have hne : ((d : ℂ) + 1) ≠ 0 := by + exact Nat.cast_add_one_ne_zero d + rw [show m + (d + 1) - 1 = m + d from by omega] + rw [inv_mul_eq_iff_eq_mul₀ hne] + have hcast : (Nat.choose (m + d) (d + 1) : ℂ) * + ((d : ℂ) + 1) = (Nat.choose (m + d) d : ℂ) * (m : ℂ) := by + exact_mod_cast congrArg (Nat.cast (R := ℂ)) h2 + linear_combination -hcast + +/-- **Complete homogeneous values at the negated constant +sequence** are signed binomials. -/ +theorem newtonH_neg_const (m : ℕ) (hm : 1 ≤ m) (d : ℕ) : + newtonH (fun _ => -(m : ℂ)) d = + ((-1 : ℂ)) ^ d * (Nat.choose m d : ℂ) := by + induction d using Nat.strong_induction_on with + | _ d ih => + match d with + | 0 => simp [newtonH_zero] + | d + 1 => + rw [newtonH] + rw [Finset.sum_congr rfl (fun i hi => by + rw [ih (d - i) (by + rw [Finset.mem_range] at hi + omega)])] + rw [show (∑ i ∈ Finset.range (d + 1), + (-(m : ℂ)) * (((-1 : ℂ)) ^ (d - i) * + (Nat.choose m (d - i) : ℂ))) = + (-(m : ℂ)) * ∑ j ∈ Finset.range (d + 1), + ((-1 : ℂ)) ^ j * (Nat.choose m j : ℂ) from by + rw [Finset.mul_sum] + exact Finset.sum_nbij' (fun i => d - i) (fun j => d - j) + (fun i hi => Finset.mem_range.mpr (by + rw [Finset.mem_range] at hi; omega)) + (fun j hj => Finset.mem_range.mpr (by + rw [Finset.mem_range] at hj; omega)) + (fun i hi => by rw [Finset.mem_range] at hi; omega) + (fun j hj => by rw [Finset.mem_range] at hj; omega) + (fun i _ => rfl)] + rw [sum_alt_choose_partial m d hm] + have h2 : m * Nat.choose (m - 1) d = + Nat.choose m (d + 1) * (d + 1) := by + have h3 := Nat.add_one_mul_choose_eq (m - 1) d + rw [show (m - 1) + 1 = m from by omega] at h3 + exact h3 + have hne : ((d : ℂ) + 1) ≠ 0 := by + exact Nat.cast_add_one_ne_zero d + rw [inv_mul_eq_iff_eq_mul₀ hne] + have hcast : (m : ℂ) * (Nat.choose (m - 1) d : ℂ) = + (Nat.choose m (d + 1) : ℂ) * ((d : ℂ) + 1) := by + have := congrArg (Nat.cast (R := ℂ)) h2 + push_cast at this + linear_combination this + rw [pow_succ] + linear_combination (-((-1 : ℂ) ^ d)) * hcast + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffExtract.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffExtract.lean new file mode 100644 index 0000000000..2cf40467e2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffExtract.lean @@ -0,0 +1,92 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.Bialternant + +/-! +# Coefficient extraction from alternants + +The coefficient of the diagonal monomial in a power alternant with +injective exponents is `1`: distinct permutations contribute +distinct monomials, and only the identity hits the diagonal. +-/ + +@[expose] public section + +namespace RS + +open Finset MvPolynomial Equiv + +variable {k : ℕ} + +/-- Evaluation of a sum of single-point Finsupps. -/ +theorem sum_single_apply (c : Fin k → ℕ) (j : Fin k) : + (∑ i, Finsupp.single i (c i)) j = c j := by + classical + rw [Finsupp.finsetSum_apply] + have h := Finset.sum_eq_single (s := Finset.univ) + (f := fun i : Fin k => (Finsupp.single i (c i)) j) j + (fun b _ hb => Finsupp.single_eq_of_ne (Ne.symm hb)) + (fun h => absurd (Finset.mem_univ j) h) + rw [h, Finsupp.single_eq_same] + +/-- Products of variable powers are monomials. -/ +theorem prod_pow_eq_monomial (c : Fin k → ℕ) : + (∏ i, (X i : MvPolynomial (Fin k) ℂ) ^ (c i)) = + monomial (∑ i, Finsupp.single i (c i)) (1 : ℂ) := by + rw [Finset.prod_congr rfl (fun i (_ : i ∈ Finset.univ) => + X_pow_eq_monomial (n := i) (e := c i))] + rw [← monomial_sum_prod] + rw [Finset.prod_const_one] + +/-- **The diagonal coefficient of a power alternant** with +injective exponents is `1`. -/ +theorem alternant_coeff (e : Fin k → ℕ) + (hinj : Function.Injective e) : + ((Matrix.of fun i j : Fin k => + (X j : MvPolynomial (Fin k) ℂ) ^ (e i)).det).coeff + (∑ i, Finsupp.single i (e i)) = 1 := by + classical + rw [Matrix.det_apply'] + rw [Finset.sum_congr rfl + (fun (τ : Equiv.Perm (Fin k)) (_ : τ ∈ Finset.univ) => + show ((Equiv.Perm.sign τ : ℤ) : MvPolynomial (Fin k) ℂ) * + ∏ i, (Matrix.of fun i j : Fin k => + (X j : MvPolynomial (Fin k) ℂ) ^ (e i)) (τ i) i = + ((Equiv.Perm.sign τ : ℤ) : MvPolynomial (Fin k) ℂ) * + monomial (∑ i, Finsupp.single i (e (τ i))) (1 : ℂ) + from by + rw [show (∏ i, (Matrix.of fun i j : Fin k => + (X j : MvPolynomial (Fin k) ℂ) ^ (e i)) (τ i) i) = + ∏ i, (X i : MvPolynomial (Fin k) ℂ) ^ (e (τ i)) + from rfl] + rw [prod_pow_eq_monomial])] + rw [MvPolynomial.coeff_sum] + rw [Finset.sum_eq_single (1 : Equiv.Perm (Fin k)) + (fun τ _ hτ => ?_) (fun h => absurd (Finset.mem_univ _) h)] + · rw [show ((Equiv.Perm.sign (1 : Equiv.Perm (Fin k)) : ℤ) : + MvPolynomial (Fin k) ℂ) = 1 from by + rw [map_one] + exact Int.cast_one] + rw [one_mul, coeff_monomial] + rw [ite_eq_left (Finset.sum_congr rfl fun i _ => by + rw [Equiv.Perm.one_apply])] + · have hne : (∑ i, Finsupp.single i (e (τ i))) ≠ + ∑ i, Finsupp.single i (e i) := by + intro heq + apply hτ + refine Equiv.ext fun j => ?_ + have h1 := congrArg (fun w : Fin k →₀ ℕ => w j) heq + rw [sum_single_apply, sum_single_apply] at h1 + exact hinj h1 + rw [show ((Equiv.Perm.sign τ : ℤ) : MvPolynomial (Fin k) ℂ) = + MvPolynomial.C ((Equiv.Perm.sign τ : ℤ) : ℂ) from by simp, + MvPolynomial.coeff_C_mul, coeff_monomial, ite_eq_right hne, + mul_zero] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffSplit.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffSplit.lean new file mode 100644 index 0000000000..69f8007d1d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffSplit.lean @@ -0,0 +1,119 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowCount + +/-! +# The pointwise convolution form of product coefficients + +`MvPolynomial.coeff` of a product, reindexed from the Finsupp +antidiagonal to guarded pointwise splits over a bounded pi-set — +the shape produced by the colour-character convolution. +-/ + +@[expose] public section + +namespace RS + +open Finset MvPolynomial + +variable {k : ℕ} + +open scoped Classical in +/-- **The guarded pointwise convolution.** -/ +theorem coeff_mul_split (P Q : MvPolynomial (Fin k) ℂ) + (α : Fin k → ℕ) (n : ℕ) (hn : ∀ a, α a ≤ n) : + (P * Q).coeff (∑ a, Finsupp.single a (α a)) = + ∑ w ∈ Fintype.piFinset + (fun _ : Fin k => Finset.range (n + 1)), + (if ∀ a, w a ≤ α a + then P.coeff (∑ a, Finsupp.single a (α a - w a)) * + Q.coeff (∑ a, Finsupp.single a (w a)) + else 0) := by + classical + rw [MvPolynomial.coeff_mul] + rw [← Finset.sum_filter] + refine Finset.sum_nbij' + (fun p => fun a => p.2 a) + (fun w => (∑ a, Finsupp.single a (α a - w a), + ∑ a, Finsupp.single a (w a))) + ?_ ?_ ?_ ?_ ?_ + · -- forward membership + intro p hp + rw [Finset.mem_antidiagonal] at hp + have hpt : ∀ a, p.1 a + p.2 a = α a := by + intro a + have h1 := congrArg (fun f : Fin k →₀ ℕ => f a) hp + rw [Finsupp.add_apply, sum_single_apply] at h1 + exact h1 + rw [Finset.mem_filter] + constructor + · rw [Fintype.mem_piFinset] + intro a + rw [Finset.mem_range] + have := hpt a + have := hn a + omega + · intro a + change p.2 a ≤ α a + have := hpt a + omega + · -- backward membership + intro w hw + rw [Finset.mem_filter] at hw + rw [Finset.mem_antidiagonal] + ext a + rw [show ((∑ b, Finsupp.single b (α b - w b)) + + ∑ b, Finsupp.single b (w b)) a = + (∑ b, Finsupp.single b (α b - w b)) a + + (∑ b, Finsupp.single b (w b)) a from rfl] + rw [sum_single_apply, sum_single_apply, sum_single_apply] + have := hw.2 a + omega + · -- left inverse + intro p hp + rw [Finset.mem_antidiagonal] at hp + have hpt : ∀ a, p.1 a + p.2 a = α a := by + intro a + have h1 := congrArg (fun f : Fin k →₀ ℕ => f a) hp + rw [Finsupp.add_apply, sum_single_apply] at h1 + exact h1 + refine Prod.ext ?_ ?_ + · change (∑ a, Finsupp.single a (α a - p.2 a)) = p.1 + ext a + rw [sum_single_apply] + have := hpt a + omega + · change (∑ a, Finsupp.single a (p.2 a)) = p.2 + ext a + rw [sum_single_apply] + · -- right inverse + intro w hw + funext a + change (∑ b, Finsupp.single b (w b)) a = w a + rw [sum_single_apply] + · -- value transfer + intro p hp + rw [Finset.mem_antidiagonal] at hp + have hpt : ∀ a, p.1 a + p.2 a = α a := by + intro a + have h1 := congrArg (fun f : Fin k →₀ ℕ => f a) hp + rw [Finsupp.add_apply, sum_single_apply] at h1 + exact h1 + congr 1 + · congr 1 + ext a + rw [sum_single_apply] + change p.1 a = α a - p.2 a + have := hpt a + omega + · congr 1 + ext a + rw [sum_single_apply] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/DeltaSeq.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/DeltaSeq.lean new file mode 100644 index 0000000000..64b736694d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/DeltaSeq.lean @@ -0,0 +1,96 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourCycleSum + +/-! +# The delta power-sum sequence + +At the sequence `t₀ = (1, 0, 0, …)` the completed cycle weight is +the identity indicator and the complete homogeneous values are +inverse factorials; the Frobenius formula then evaluates the +Jacobi–Trudi character degree as `n!` times the Jacobi–Trudi +determinant at `t₀`. +-/ + +@[expose] public section + +namespace RS + +open Finset + +/-- The delta power-sum sequence. -/ +noncomputable def deltaSeq : ℕ → ℂ := + fun c => if c = 1 then 1 else 0 + +/-- The delta sequence's first value is `1`. -/ +@[simp] +theorem deltaSeq_one : deltaSeq 1 = 1 := by + rw [deltaSeq, ite_eq_left rfl] + +/-- Complete homogeneous values of the delta sequence are inverse +factorials. -/ +theorem newtonH_deltaSeq (d : ℕ) : + newtonH deltaSeq d = ((d.factorial : ℂ))⁻¹ := by + induction d with + | zero => + rw [newtonH_zero, Nat.factorial_zero, Nat.cast_one, inv_one] + | succ d ih => + rw [newtonH] + rw [Finset.sum_eq_single 0 + (fun i _ hi => by + rw [show deltaSeq (i + 1) = 0 from by + rw [deltaSeq, ite_eq_right (by omega)]] + rw [zero_mul]) + (fun h => absurd (Finset.mem_range.mpr (by omega)) h)] + rw [show deltaSeq (0 + 1) = 1 from by + rw [deltaSeq] + norm_num] + rw [Nat.sub_zero, one_mul, ih] + rw [Nat.factorial_succ] + push_cast + rw [mul_inv] + +/-- The completed cycle weight of the delta sequence is the +identity indicator. -/ +theorem cycleProd_deltaSeq {n : ℕ} (π : Equiv.Perm (Fin n)) : + cycleProd deltaSeq π = if π = 1 then 1 else 0 := by + rw [cycleProd, deltaSeq_one, one_pow, mul_one] + by_cases hπ : π = 1 + · rw [ite_eq_left hπ, hπ, Equiv.Perm.cycleType_one, + Multiset.map_zero, Multiset.prod_zero] + · rw [ite_eq_right hπ] + have hne : π.cycleType ≠ 0 := by + intro hc + exact hπ (Equiv.Perm.cycleType_eq_zero.mp hc) + obtain ⟨c, hc⟩ := Multiset.exists_mem_of_ne_zero hne + refine Multiset.prod_eq_zero ?_ + rw [Multiset.mem_map] + refine ⟨c, hc, ?_⟩ + rw [deltaSeq, ite_eq_right] + have := Equiv.Perm.two_le_of_mem_cycleType hc + omega + +/-- **The degree evaluation**: the Jacobi–Trudi character degree +is `n!` times the Jacobi–Trudi determinant at the delta +sequence. -/ +theorem jtChar_one_eq (μ : YoungDiagram) : + jtChar μ 1 = (μ.card.factorial : ℂ) * diagramSchur μ deltaSeq := by + have h := jtChar_frobenius' μ deltaSeq + rw [Finset.sum_congr rfl (fun π (_ : π ∈ Finset.univ) => by + rw [cycleProd_deltaSeq π])] at h + rw [Finset.sum_eq_single 1 + (fun π _ hπ => by rw [ite_eq_right hπ, mul_zero]) + (fun hmem => absurd (Finset.mem_univ _) hmem)] at h + rw [ite_eq_left rfl, mul_one] at h + have hfac : ((μ.card.factorial : ℂ)) ≠ 0 := by + exact_mod_cast Nat.factorial_ne_zero μ.card + field_simp at h + rw [h] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/DescVandermonde.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/DescVandermonde.lean new file mode 100644 index 0000000000..741add5359 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/DescVandermonde.lean @@ -0,0 +1,42 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Determinant of the descending-Pochhammer evaluation matrix + +The determinant of the matrix whose `(i, j)` entry is +`(descPochhammer ℂ j).eval (y i)` is the Vandermonde product +`∏ i, ∏ j ∈ Ioi i, (y j - y i)`. + +This follows from the Mathlib theorem +`det_eval_matrixOfPolynomials_eq_det_vandermonde` applied to +the descending Pochhammer polynomials (which are monic of the +correct degree) combined with `det_vandermonde`. +-/ + +@[expose] public section + +open Polynomial Matrix Finset + +namespace RS + +/-- The descending-Pochhammer evaluation matrix has the Vandermonde +determinant, the Pochhammers being monic of the right degrees. -/ +theorem det_descPochhammer_eval {k : ℕ} (y : Fin k → ℂ) : + (Matrix.of fun i j : Fin k => + (descPochhammer ℂ (j : ℕ)).eval (y i)).det = + ∏ i : Fin k, ∏ j ∈ Finset.Ioi i, (y j - y i) := by + rw [← det_vandermonde y] + exact (det_eval_matrixOfPolynomials_eq_det_vandermonde y + (fun j => descPochhammer ℂ (j : ℕ)) + (fun i => descPochhammer_natDegree (R := ℂ) (i : ℕ)) + (fun i => monic_descPochhammer (R := ℂ) (i : ℕ))).symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/DimFormula.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/DimFormula.lean new file mode 100644 index 0000000000..60bb291e62 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/DimFormula.lean @@ -0,0 +1,118 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.DeltaSeq +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.DescVandermonde + +/-! +# The exact dimension determinant + +Row-normalizing the Jacobi–Trudi determinant at the delta sequence +by the staircase factorials turns its entries into descending +Pochhammer evaluations; reversing both indices removes all signs +and evaluates the determinant as a manifestly positive Vandermonde +product of staircase differences. +-/ + +@[expose] public section + +namespace RS + +open Finset + +/-- The staircase exponents of a diagram over its own row count. -/ +noncomputable def eStair (μ : YoungDiagram) + (i : Fin μ.rowLens.length) : ℕ := + μ.rowLens.get i + ((μ.rowLens.length - 1) - (i : ℕ)) + +/-- **The row-normalized dimension determinant**: the Jacobi–Trudi +determinant at the delta sequence times the staircase factorials +is the Vandermonde product of the staircase differences. -/ +theorem diagramSchur_delta_mul (μ : YoungDiagram) : + diagramSchur μ deltaSeq * + ∏ i : Fin μ.rowLens.length, ((eStair μ i).factorial : ℂ) = + ∏ i : Fin μ.rowLens.length, ∏ j ∈ Finset.Ioi i, + (((eStair μ (Fin.revPerm j)) : ℂ) - + ((eStair μ (Fin.revPerm i)) : ℂ)) := by + classical + set k := μ.rowLens.length with hk + -- entrywise normalization + have hentry : ∀ i j : Fin k, + ((eStair μ i).factorial : ℂ) * + newtonHZ deltaSeq + ((μ.rowLens.get i : ℤ) + (j : ℕ) - (i : ℕ)) = + (descPochhammer ℂ ((k - 1) - (j : ℕ))).eval + ((eStair μ i : ℕ) : ℂ) := by + intro i j + have hi := i.isLt + have hj := j.isLt + have hE : eStair μ i = + μ.rowLens.get i + ((k - 1) - (i : ℕ)) := rfl + rw [descPochhammer_eval_eq_descFactorial] + by_cases hpos : + 0 ≤ (μ.rowLens.get i : ℤ) + (j : ℕ) - (i : ℕ) + · have harg : ((μ.rowLens.get i : ℤ) + (j : ℕ) - + (i : ℕ)).toNat = + eStair μ i - ((k - 1) - (j : ℕ)) := by + rw [hE] + omega + have hle : (k - 1) - (j : ℕ) ≤ eStair μ i := by + rw [hE] + omega + rw [newtonHZ, ite_eq_left hpos, harg, newtonH_deltaSeq] + have hfac := Nat.factorial_mul_descFactorial hle + have hcast : ((eStair μ i - ((k - 1) - (j : ℕ))).factorial : + ℂ) * ((eStair μ i).descFactorial + ((k - 1) - (j : ℕ)) : ℂ) = + ((eStair μ i).factorial : ℂ) := by + exact_mod_cast congrArg (Nat.cast (R := ℂ)) hfac + have hne : (((eStair μ i - ((k - 1) - (j : ℕ))).factorial : + ℕ) : ℂ) ≠ 0 := by + exact_mod_cast Nat.factorial_ne_zero _ + rw [← div_eq_mul_inv, div_eq_iff hne] + linear_combination -hcast + · rw [newtonHZ, ite_eq_right hpos, mul_zero] + have hlt : eStair μ i < (k - 1) - (j : ℕ) := by + rw [hE] + omega + rw [Nat.descFactorial_eq_zero_iff_lt.mpr hlt] + rw [Nat.cast_zero] + -- normalize the determinant + have h1 : (∏ i : Fin k, ((eStair μ i).factorial : ℂ)) * + diagramSchur μ deltaSeq = + (Matrix.of fun i j : Fin k => + (descPochhammer ℂ ((k - 1) - (j : ℕ))).eval + ((eStair μ i : ℕ) : ℂ)).det := by + rw [diagramSchur, schurDet] + rw [← Matrix.det_mul_column + (fun i => ((eStair μ i).factorial : ℂ))] + congr 1 + refine Matrix.ext fun i j => ?_ + rw [Matrix.of_apply, Matrix.of_apply] + exact hentry i j + -- reverse both indices + have h2 : (Matrix.of fun i j : Fin k => + (descPochhammer ℂ ((k - 1) - (j : ℕ))).eval + ((eStair μ i : ℕ) : ℂ)).det = + (Matrix.of fun i j : Fin k => + (descPochhammer ℂ (j : ℕ)).eval + ((eStair μ (Fin.revPerm i) : ℕ) : ℂ)).det := by + rw [← Matrix.det_submatrix_equiv_self + (Fin.revPerm : Equiv.Perm (Fin k))] + congr 1 + refine Matrix.ext fun i j => ?_ + rw [Matrix.submatrix_apply, Matrix.of_apply, Matrix.of_apply] + congr 2 + have hj := j.isLt + have hrev : ((Fin.revPerm j : Fin k) : ℕ) = + k - ((j : ℕ) + 1) := Fin.val_rev j + omega + rw [mul_comm] at h1 + rw [h1, h2, det_descPochhammer_eval] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/EHConv.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/EHConv.lean new file mode 100644 index 0000000000..94808dac2f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/EHConv.lean @@ -0,0 +1,183 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.SubsetEH + +/-! +# The e–h convolution and the single-variable resolvent + +Over any variable subset `A`, the alternating e–h convolution +vanishes in positive degree, and the mixed convolution with one +extra variable `j` telescopes to `X j ^ m` — the entrywise content +of the bialternant matrix factorization. The `hSub` +add-one-variable recurrence enters as the hypothesis `HSubRec`, +discharged in `HInsert.lean`. +-/ + +@[expose] public section + +namespace RS + +open Finset MvPolynomial + +variable {k : ℕ} + +/-- The `hSub` add-one-variable recurrence, as a hypothesis. -/ +abbrev HSubRec (k : ℕ) : Prop := + ∀ {A : Finset (Fin k)} {j : Fin k}, j ∉ A → ∀ m : ℕ, + hSub (insert j A) (m + 1) = + hSub A (m + 1) + X j * hSub (insert j A) m + +/-- Positive-degree `hSub` of the empty subset vanishes. -/ +theorem hSub_empty (m : ℕ) : + hSub (∅ : Finset (Fin k)) (m + 1) = 0 := by + classical + rw [hSub, Finset.filter_false_of_mem, Finset.sum_empty] + intro w _ hall + obtain ⟨i, hi⟩ := Multiset.card_pos_iff_exists_mem.mp + (by rw [w.2]; omega) + exact absurd (hall i hi) (Finset.notMem_empty i) + +/-- The mixed e–h convolution with one extra variable. -/ +noncomputable def fmix (A : Finset (Fin k)) (j : Fin k) (M : ℕ) : + MvPolynomial (Fin k) ℂ := + ∑ r ∈ Finset.range (M + 1), + (-1 : MvPolynomial (Fin k) ℂ) ^ r * + (eSub A r * hSub (insert j A) (M - r)) + +private theorem conv_insert_eq {A : Finset (Fin k)} {j : Fin k} + (hj : j ∉ A) (m : ℕ) : + (∑ r ∈ Finset.range (m + 2), + (-1 : MvPolynomial (Fin k) ℂ) ^ r * + (eSub (insert j A) r * hSub (insert j A) (m + 1 - r))) = + fmix A j (m + 1) - X j * fmix A j m := by + have e1 : (∑ r ∈ Finset.range (m + 2), + (-1 : MvPolynomial (Fin k) ℂ) ^ r * + (eSub (insert j A) r * hSub (insert j A) (m + 1 - r))) = + (∑ r ∈ Finset.range (m + 1), + ((-1 : MvPolynomial (Fin k) ℂ) ^ (r + 1) * + (eSub A (r + 1) * hSub (insert j A) (m - r)) + + (-1 : MvPolynomial (Fin k) ℂ) ^ (r + 1) * + (X j * (eSub A r * hSub (insert j A) (m - r))))) + + hSub (insert j A) (m + 1) := by + rw [Finset.sum_range_succ'] + rw [Finset.sum_congr rfl + (fun r (_ : r ∈ Finset.range (m + 1)) => + show (-1 : MvPolynomial (Fin k) ℂ) ^ (r + 1) * + (eSub (insert j A) (r + 1) * + hSub (insert j A) (m + 1 - (r + 1))) = + (-1 : MvPolynomial (Fin k) ℂ) ^ (r + 1) * + (eSub A (r + 1) * hSub (insert j A) (m - r)) + + (-1 : MvPolynomial (Fin k) ℂ) ^ (r + 1) * + (X j * (eSub A r * hSub (insert j A) (m - r))) + from by + rw [eSub_insert hj r, Nat.succ_sub_succ] + ring)] + rw [pow_zero, eSub_zero, Nat.sub_zero, one_mul, one_mul] + have e2 : fmix A j (m + 1) = + (∑ r ∈ Finset.range (m + 1), + (-1 : MvPolynomial (Fin k) ℂ) ^ (r + 1) * + (eSub A (r + 1) * hSub (insert j A) (m - r))) + + hSub (insert j A) (m + 1) := by + rw [fmix, Finset.sum_range_succ'] + rw [Finset.sum_congr rfl + (fun r (_ : r ∈ Finset.range (m + 1)) => + show (-1 : MvPolynomial (Fin k) ℂ) ^ (r + 1) * + (eSub A (r + 1) * hSub (insert j A) (m + 1 - (r + 1))) = + (-1 : MvPolynomial (Fin k) ℂ) ^ (r + 1) * + (eSub A (r + 1) * hSub (insert j A) (m - r)) + from by rw [Nat.succ_sub_succ])] + rw [pow_zero, eSub_zero, Nat.sub_zero, one_mul, one_mul] + have e3 : (∑ r ∈ Finset.range (m + 1), + (-1 : MvPolynomial (Fin k) ℂ) ^ (r + 1) * + (X j * (eSub A r * hSub (insert j A) (m - r)))) = + -(X j * fmix A j m) := by + rw [fmix, Finset.mul_sum, ← Finset.sum_neg_distrib] + refine Finset.sum_congr rfl fun r _ => ?_ + ring + rw [e1, Finset.sum_add_distrib, e3, e2] + ring + +private theorem fmix_sub (hrec : HSubRec k) {A : Finset (Fin k)} + {j : Fin k} (hj : j ∉ A) (m : ℕ) : + fmix A j (m + 1) - X j * fmix A j m = + ∑ r ∈ Finset.range (m + 2), + (-1 : MvPolynomial (Fin k) ℂ) ^ r * + (eSub A r * hSub A (m + 1 - r)) := by + have e1 : fmix A j (m + 1) = + (∑ r ∈ Finset.range (m + 1), + (-1 : MvPolynomial (Fin k) ℂ) ^ r * + (eSub A r * hSub (insert j A) (m + 1 - r))) + + (-1 : MvPolynomial (Fin k) ℂ) ^ (m + 1) * + (eSub A (m + 1) * 1) := by + rw [fmix, Finset.sum_range_succ, Nat.sub_self, hSub_zero] + have e2 : (∑ r ∈ Finset.range (m + 2), + (-1 : MvPolynomial (Fin k) ℂ) ^ r * + (eSub A r * hSub A (m + 1 - r))) = + (∑ r ∈ Finset.range (m + 1), + (-1 : MvPolynomial (Fin k) ℂ) ^ r * + (eSub A r * hSub A (m + 1 - r))) + + (-1 : MvPolynomial (Fin k) ℂ) ^ (m + 1) * + (eSub A (m + 1) * 1) := by + rw [Finset.sum_range_succ, Nat.sub_self, hSub_zero] + have e4 : ∀ r ∈ Finset.range (m + 1), + (-1 : MvPolynomial (Fin k) ℂ) ^ r * + (eSub A r * hSub (insert j A) (m + 1 - r)) - + X j * ((-1 : MvPolynomial (Fin k) ℂ) ^ r * + (eSub A r * hSub (insert j A) (m - r))) = + (-1 : MvPolynomial (Fin k) ℂ) ^ r * + (eSub A r * hSub A (m + 1 - r)) := by + intro r hr + rw [Finset.mem_range] at hr + have hd : m + 1 - r = (m - r) + 1 := by omega + rw [hd, hrec hj (m - r)] + ring + rw [e1, e2, fmix, Finset.mul_sum, add_sub_right_comm, + ← Finset.sum_sub_distrib] + rw [Finset.sum_congr rfl e4] + +/-- **The e–h convolution vanishes in positive degree.** -/ +theorem conv_eq_zero (hrec : HSubRec k) (A : Finset (Fin k)) + (m : ℕ) : + ∑ r ∈ Finset.range (m + 2), + (-1 : MvPolynomial (Fin k) ℂ) ^ r * + (eSub A r * hSub A (m + 1 - r)) = 0 := by + classical + induction A using Finset.induction_on with + | empty => + refine Finset.sum_eq_zero fun r _ => ?_ + match r with + | 0 => + rw [pow_zero, one_mul, eSub_zero, one_mul, Nat.sub_zero, + hSub_empty] + | r + 1 => + rw [eSub_eq_zero_of_lt _ _ (by + rw [Finset.card_empty]; omega)] + ring + | insert j A hj ih => + rw [conv_insert_eq hj m, fmix_sub hrec hj m, ih] + +/-- **The single-variable resolvent**: the mixed convolution +telescopes to a power of the extra variable. -/ +theorem fmix_eq_pow (hrec : HSubRec k) {A : Finset (Fin k)} + {j : Fin k} (hj : j ∉ A) (m : ℕ) : + fmix A j m = X j ^ m := by + induction m with + | zero => + rw [fmix, Finset.sum_range_one, pow_zero, + eSub_zero, hSub_zero] + ring + | succ m ih => + have h1 := fmix_sub hrec hj m + rw [conv_eq_zero hrec A m] at h1 + have h2 : fmix A j (m + 1) = X j * fmix A j m := + sub_eq_zero.mp h1 + rw [h2, ih, pow_succ] + ring + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/EHDischarge.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/EHDischarge.lean new file mode 100644 index 0000000000..c8cd8e51ed --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/EHDischarge.lean @@ -0,0 +1,39 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HInsert +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HSubZ + +/-! +# Discharge of the `hSub` recurrence hypothesis + +The bialternant development is stated over a recurrence for the +guarded complete-homogeneous polynomials; `HInsert.lean` proves it, +so the resolvent identity and the shifted forms hold +unconditionally. +-/ + +@[expose] public section + +namespace RS + +/-- The add-one-variable recurrence, discharging the hypothesis the +bialternant development is stated over. -/ +theorem hSubRec (k : ℕ) : HSubRec k := + fun hj m => hSub_insert hj m + +/-- The guarded resolvent, unconditionally. -/ +theorem sum_fin_resolvent' {k : ℕ} {A : Finset (Fin k)} + {j : Fin k} (hj : j ∉ A) (hcard : A.card + 1 = k) (m : ℕ) : + ∑ r : Fin k, + (-1 : MvPolynomial (Fin k) ℂ) ^ (r : ℕ) * + (eSub A r * hSubZ (insert j A) ((m : ℤ) - (r : ℕ))) = + MvPolynomial.X j ^ m := + sum_fin_resolvent (hSubRec k) hj hcard m + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/HInsert.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HInsert.lean new file mode 100644 index 0000000000..6be2c3e6d9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HInsert.lean @@ -0,0 +1,112 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.SubsetEH + +/-! +# The add-one-variable recurrence for `hSub` + +`hSub (insert j A) (m+1) = hSub A (m+1) + X j * hSub (insert j A) m` +-/ + +@[expose] public section + +namespace RS + +open Finset MvPolynomial + +open scoped Classical in +/-- The add-one-variable recurrence: terms either avoid the new +variable or use it at least once. -/ +theorem hSub_insert {k : ℕ} {A : Finset (Fin k)} {j : Fin k} + (hj : j ∉ A) (m : ℕ) : + hSub (insert j A) (m + 1) = hSub A (m + 1) + X j * hSub (insert j A) m := by + classical + -- Rewrite all three hSub into explicit filtered sums over Sym, keeping + -- the Sym type explicit to prevent Sym/Subtype transparency issues. + change ∑ w ∈ Finset.univ.filter + (fun w : Sym (Fin k) (m + 1) => ∀ i ∈ w.1, i ∈ insert j A), + (w.1.map (X : Fin k → MvPolynomial (Fin k) ℂ)).prod = + ∑ w ∈ Finset.univ.filter + (fun w : Sym (Fin k) (m + 1) => ∀ i ∈ w.1, i ∈ A), + (w.1.map X).prod + + X j * ∑ w ∈ Finset.univ.filter + (fun w : Sym (Fin k) m => ∀ i ∈ w.1, i ∈ insert j A), + (w.1.map X).prod + -- Split LHS by predicate j ∈ w.1 + conv_lhs => + rw [← Finset.sum_filter_add_sum_filter_not + (Finset.univ.filter + (fun w : Sym (Fin k) (m + 1) => ∀ i ∈ w.1, i ∈ insert j A)) + (fun w : Sym (Fin k) (m + 1) => j ∈ w.1) + (fun w : Sym (Fin k) (m + 1) => + (w.1.map (X : Fin k → MvPolynomial (Fin k) ℂ)).prod)] + -- Now LHS = ∑(j∈w) + ∑(j∉w); swap to match RHS order + rw [add_comm] + congr 1 + -- Part 1: ∑(j∉w, supp ⊆ insert j A) = ∑(supp ⊆ A) + · apply Finset.sum_congr + · rw [Finset.filter_filter] + apply Finset.filter_congr + intro w _ + constructor + · rintro ⟨hsup, hjnot⟩ i hi + rcases Finset.mem_insert.mp (hsup i hi) with rfl | hmem + · exact absurd hi hjnot + · exact hmem + · intro hsup + exact ⟨fun i hi => Finset.mem_insert.mpr (Or.inr (hsup i hi)), + fun hjw => hj (hsup j hjw)⟩ + · intros; rfl + -- Part 2: ∑(j∈w, supp ⊆ insert j A) = X j * ∑(supp ⊆ insert j A, degree m) + · rw [Finset.mul_sum] + -- Save j under a let-alias; Finset.sum_bij' has a parameter also named j + -- which would shadow the theorem's j inside by-blocks. + let jj := j + exact Finset.sum_bij' + -- forward: w ↦ ⟨w.1.erase j, card_proof⟩ + (fun (w : Sym (Fin k) (m + 1)) (hw) => + (⟨w.1.erase jj, by + have hmem : jj ∈ w.1 := (Finset.mem_filter.mp hw).2 + rw [Multiset.card_erase_of_mem hmem, w.2, Nat.pred_succ]⟩ + : Sym (Fin k) m)) + -- backward: w' ↦ ⟨j ::ₘ w'.1, card_proof⟩ + (fun (w' : Sym (Fin k) m) (_hw') => + (⟨jj ::ₘ w'.1, by rw [Multiset.card_cons, w'.2]⟩ + : Sym (Fin k) (m + 1))) + -- forward membership: erase preserves support ⊆ insert j A + (fun w hw => by + have hmf := Finset.mem_filter.mp hw + have hsup := (Finset.mem_filter.mp hmf.1).2 + exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, fun i hi => + hsup i (Multiset.mem_of_mem_erase hi)⟩) + -- backward membership: cons j preserves support and adds j ∈ w.1 + (fun w' hw' => by + have hsup' := (Finset.mem_filter.mp hw').2 + refine Finset.mem_filter.mpr + ⟨Finset.mem_filter.mpr ⟨Finset.mem_univ _, fun i hi => ?_⟩, + Multiset.mem_cons_self jj w'.1⟩ + rcases Multiset.mem_cons.mp hi with rfl | hmem + · exact Finset.mem_insert_self jj A + · exact hsup' i hmem) + -- left inverse: j ::ₘ (w.1.erase j) = w.1 + (fun w hw => by + ext1 + exact Multiset.cons_erase (Finset.mem_filter.mp hw).2) + -- right inverse: (j ::ₘ w'.1).erase j = w'.1 + (fun w' _ => by + ext1 + exact Multiset.erase_cons_head jj w'.1) + -- weight: (w.1.map X).prod = X j * ((w.1.erase j).map X).prod + (fun w hw => by + have hmem : jj ∈ w.1 := (Finset.mem_filter.mp hw).2 + change (w.1.map X).prod = X jj * ((w.1.erase jj).map X).prod + conv_lhs => rw [(Multiset.cons_erase hmem).symm] + rw [Multiset.map_cons, Multiset.prod_cons]) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/HProdCoeff.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HProdCoeff.lean new file mode 100644 index 0000000000..0c7180702b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HProdCoeff.lean @@ -0,0 +1,99 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffExtract + +/-! +# Coefficient of a product of complete homogeneous polynomials + +The coefficient of a monomial `w` in the product +`∏ i, hSub univ (c i)` counts the number of tuples of +symmetric-function indices whose combined weight equals `w`. +-/ + +@[expose] public section + +namespace RS + +open Finset MvPolynomial + +variable {k : ℕ} + +/-- The product of a multiset mapped through `X` equals the monomial +whose exponent is the multiset's `toFinsupp`. -/ +private theorem map_X_prod_eq_monomial (s : Multiset (Fin k)) : + (s.map X).prod = monomial (Multiset.toFinsupp s) (1 : ℂ) := by + classical + induction s using Multiset.induction_on with + | empty => + rw [Multiset.map_zero, Multiset.prod_zero, + Multiset.toFinsupp_zero, monomial_zero', MvPolynomial.C_1] + | cons a t ih => + rw [Multiset.map_cons, Multiset.prod_cons, ih] + rw [show (X a : MvPolynomial (Fin k) ℂ) = + monomial (Finsupp.single a 1) 1 from rfl] + rw [MvPolynomial.monomial_mul_monomial, one_mul] + congr 1 + rw [← Multiset.singleton_add] + rw [Multiset.toFinsupp_add, Multiset.toFinsupp_singleton] + +open scoped Classical in +/-- A coefficient of a product of complete homogeneous polynomials +counts the tuples of multisets with the prescribed column sums. -/ +theorem coeff_hSub_prod {k : ℕ} (c : Fin k → ℕ) (w : Fin k →₀ ℕ) : + (∏ i, hSub (Finset.univ : Finset (Fin k)) (c i)).coeff w = + (Fintype.card {W : ∀ i : Fin k, Sym (Fin k) (c i) // + ∀ j : Fin k, (∑ i, (W i).1.count j) = w j} : ℂ) := by + -- Step 1: Remove the trivially-true filter in hSub univ + -- and rewrite each summand as a monomial + rw [Finset.prod_congr rfl (fun i (_ : i ∈ Finset.univ) => + show hSub Finset.univ (c i) = + ∑ s : Sym (Fin k) (c i), + monomial (Multiset.toFinsupp s.1) (1 : ℂ) from by + rw [hSub, Finset.filter_true_of_mem + (fun _ _ => fun j _ => Finset.mem_univ j)] + rw [Finset.sum_congr rfl (fun s (_ : s ∈ Finset.univ) => + map_X_prod_eq_monomial s.1)])] + -- Step 2: Expand the product of sums via Fintype.prod_sum + rw [Fintype.prod_sum] + -- Step 3: Each term is a product of monomials = a single monomial + rw [Finset.sum_congr rfl + (fun (W : ∀ i : Fin k, Sym (Fin k) (c i)) (_ : W ∈ Finset.univ) => + show (∏ i, monomial (Multiset.toFinsupp (W i).1) (1 : ℂ)) = + monomial (∑ i, Multiset.toFinsupp (W i).1) (1 : ℂ) from by + rw [← monomial_sum_prod, Finset.prod_const_one])] + -- Step 4: Extract coefficient, rewrite each term + rw [MvPolynomial.coeff_sum] + simp only [coeff_monomial] + -- Step 5: Rewrite the condition from Finsupp equality to pointwise + have cond_iff : ∀ W : (∀ i : Fin k, Sym (Fin k) (c i)), + ((∑ i, Multiset.toFinsupp (W i).1) = w) ↔ + (∀ j : Fin k, (∑ i, (W i).1.count j) = w j) := by + intro W + rw [DFunLike.ext_iff] + constructor + · intro h j + specialize h j + rw [Finsupp.finsetSum_apply] at h + simpa [Multiset.toFinsupp_apply] using h + · intro h j + rw [Finsupp.finsetSum_apply] + simp only [Multiset.toFinsupp_apply] + exact h j + rw [Finset.sum_congr rfl + (fun (W : ∀ i : Fin k, Sym (Fin k) (c i)) (_ : W ∈ Finset.univ) => + show (if (∑ i, Multiset.toFinsupp (W i).1) = w then (1 : ℂ) else 0) = + (if (∀ j : Fin k, (∑ i, (W i).1.count j) = w j) then (1 : ℂ) + else 0) from + if_congr (cond_iff W) rfl rfl)] + -- Step 6: Sum of indicators = cardinality + rw [Finset.sum_boole] + congr 1 + rw [Fintype.card_subtype] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/HSubZ.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HSubZ.lean new file mode 100644 index 0000000000..eefb707bd0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HSubZ.lean @@ -0,0 +1,109 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.EHConv + +/-! +# Integer-indexed complete homogeneous polynomials + +The `ℤ`-indexed extension of `hSub`, vanishing in negative +degrees, and the guarded range-`k` form of the resolvent — the +entry form of the bialternant matrices. +-/ + +@[expose] public section + +namespace RS + +open Finset MvPolynomial + +variable {k : ℕ} + +/-- The `ℤ`-indexed extension of `hSub`, vanishing in negative +degrees. -/ +noncomputable def hSubZ (A : Finset (Fin k)) (d : ℤ) : + MvPolynomial (Fin k) ℂ := + if 0 ≤ d then hSub A d.toNat else 0 + +/-- The integer extension agrees in non-negative degrees. -/ +@[simp] +theorem hSubZ_natCast (A : Finset (Fin k)) (m : ℕ) : + hSubZ A (m : ℤ) = hSub A m := by + rw [hSubZ, ite_eq_left (Int.natCast_nonneg m), Int.toNat_natCast] + +/-- And vanishes in negative ones. -/ +@[simp] +theorem hSubZ_neg (A : Finset (Fin k)) (d : ℤ) (hd : d < 0) : + hSubZ A d = 0 := by + rw [hSubZ, ite_eq_right (not_le.mpr hd)] + +/-- The resolvent in guarded range-`k` form: for `j ∉ A` with +`insert j A` filling all `k` variables, the `r`-sum over `Fin k` +computes `X j ^ m` for every `m`. -/ +theorem sum_fin_resolvent (hrec : HSubRec k) + {A : Finset (Fin k)} {j : Fin k} (hj : j ∉ A) + (hcard : A.card + 1 = k) (m : ℕ) : + ∑ r : Fin k, + (-1 : MvPolynomial (Fin k) ℂ) ^ (r : ℕ) * + (eSub A r * hSubZ (insert j A) ((m : ℤ) - (r : ℕ))) = + X j ^ m := by + classical + have h1 : (∑ r : Fin k, + (-1 : MvPolynomial (Fin k) ℂ) ^ (r : ℕ) * + (eSub A r * hSubZ (insert j A) ((m : ℤ) - (r : ℕ)))) = + ∑ r ∈ Finset.range k, + (-1 : MvPolynomial (Fin k) ℂ) ^ r * + (eSub A r * hSubZ (insert j A) ((m : ℤ) - r)) := + Fin.sum_univ_eq_sum_range + (fun r : ℕ => (-1 : MvPolynomial (Fin k) ℂ) ^ r * + (eSub A r * hSubZ (insert j A) ((m : ℤ) - r))) k + have h2 : (∑ r ∈ Finset.range k, + (-1 : MvPolynomial (Fin k) ℂ) ^ r * + (eSub A r * hSubZ (insert j A) ((m : ℤ) - r))) = + ∑ r ∈ Finset.range (k + (m + 1)), + (-1 : MvPolynomial (Fin k) ℂ) ^ r * + (eSub A r * hSubZ (insert j A) ((m : ℤ) - r)) := by + refine Finset.sum_subset + (fun x hx => ?_) fun r _ hnr => ?_ + · rw [Finset.mem_range] at hx ⊢ + omega + have hr : k ≤ r := by + rw [Finset.mem_range] at hnr + omega + rw [eSub_eq_zero_of_lt A r (by omega)] + ring + have h3 : (∑ r ∈ Finset.range (m + 1), + (-1 : MvPolynomial (Fin k) ℂ) ^ r * + (eSub A r * hSubZ (insert j A) ((m : ℤ) - r))) = + ∑ r ∈ Finset.range (k + (m + 1)), + (-1 : MvPolynomial (Fin k) ℂ) ^ r * + (eSub A r * hSubZ (insert j A) ((m : ℤ) - r)) := by + refine Finset.sum_subset + (fun x hx => ?_) fun r _ hnr => ?_ + · rw [Finset.mem_range] at hx ⊢ + omega + have hr : m + 1 ≤ r := by + rw [Finset.mem_range] at hnr + omega + rw [hSubZ_neg _ _ (by omega)] + ring + have h4 : (∑ r ∈ Finset.range (m + 1), + (-1 : MvPolynomial (Fin k) ℂ) ^ r * + (eSub A r * hSubZ (insert j A) ((m : ℤ) - r))) = + fmix A j m := by + rw [fmix] + refine Finset.sum_congr rfl fun r hr => ?_ + have hrm : r ≤ m := by + rw [Finset.mem_range] at hr + omega + have hc : ((m - r : ℕ) : ℤ) = (m : ℤ) - r := by omega + rw [← hc, hSubZ_natCast] + rw [h1, h2, ← h3, h4] + exact fmix_eq_pow hrec hj m + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/HookVanishing.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HookVanishing.lean new file mode 100644 index 0000000000..705610613b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HookVanishing.lean @@ -0,0 +1,71 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.RecurrenceFromVanishing +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.RationalityFromRecurrence + +/-! +# Super power sums from hook vanishing + +The full symmetric-function lemma (Lemma A.9 of the accompanying +paper): a sequence whose determinant Schur specialization vanishes +on every Young diagram outside the `(a, b)` hook is a +difference of power sums of two disjoint multisets of nonzero +complex numbers, of sizes at most `a` and `b`. + +This is the composition of `exists_recurrence_of_schurDet_vanishing` +(`RecurrenceFromVanishing.lean`) with `superPowerSums_of_recurrence` +(`RationalityFromRecurrence.lean`), through the list↔diagram bridge +of `Common/YoungDiagrams.lean`. +-/ + +@[expose] public section + +namespace RS + +/-- **Lemma A.9**: if the Schur specialization of `t` vanishes on +every diagram outside the `(a, b)` hook, then `t` is a super power +sum: a difference of power sums of disjoint multisets of nonzero +complex numbers of sizes at most `a` and `b`. -/ +theorem superPowerSums_of_hook_vanishing {t : ℕ → ℂ} {a b : ℕ} + (hvan : ∀ μ : YoungDiagram, ¬ IsInHook a b μ → diagramSchur μ t = 0) : + ∃ α β : Multiset ℂ, + α.card ≤ a ∧ β.card ≤ b ∧ + (∀ x ∈ α, x ≠ 0) ∧ (∀ x ∈ β, x ≠ 0) ∧ (∀ x ∈ α, x ∉ β) ∧ + ∀ m : ℕ, 1 ≤ m → + t m = (α.map (· ^ m)).sum - (β.map (· ^ m)).sum := by + have hlist : ∀ w : List ℕ, w.SortedGE → (∀ x ∈ w, 0 < x) → + w.length = a + 1 → b + 1 ≤ w.getD a 0 → schurDet t w = 0 := by + intro w hw hpos hlen hlast + set μ := YoungDiagram.ofRowLens w hw with hμ_def + have hrows : μ.rowLens = w := + YoungDiagram.rowLens_ofRowLens_eq_self hpos + have hout : ¬ IsInHook a b μ := by + rw [not_isInHook_iff, hμ_def, rowLen_ofRowLens_getD] + omega + have := hvan μ hout + rwa [diagramSchur, hrows] at this + obtain ⟨c, hc, hrec⟩ := exists_recurrence_of_schurDet_vanishing hlist + exact superPowerSums_of_recurrence c hc hrec + +/-- The nilpotent-trace engine: a sequence whose Schur +specialization vanishes outside a hook and which is eventually zero +vanishes identically from degree `1` onward. (Lemmas A.9 and A.10 +composed; the categorical nilpotent-trace theorem instantiates +`t m` with the traces of the powers of a nilpotent endomorphism.) -/ +theorem powerSums_zero_of_hook_and_eventually_zero {t : ℕ → ℂ} + {a b : ℕ} + (hvan : ∀ μ : YoungDiagram, ¬ IsInHook a b μ → diagramSchur μ t = 0) + (hev : ∃ N₀ : ℕ, ∀ m, N₀ ≤ m → t m = 0) : + ∀ m, 1 ≤ m → t m = 0 := by + obtain ⟨α, β, _, _, hα, hβ, hdisj, hps⟩ := + superPowerSums_of_hook_vanishing hvan + exact powerSums_zero_of_eventually_zero hα hβ hdisj hps hev + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTDetExpand.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTDetExpand.lean new file mode 100644 index 0000000000..337995f633 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTDetExpand.lean @@ -0,0 +1,90 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantExpand + +/-! +# Leibniz expansion of the Jacobi–Trudi determinant + +The determinant of `jtMat v` in row-normal form: a signed sum over +permutations of complete homogeneous products, with terms +containing a negative degree vanishing. +-/ + +@[expose] public section + +namespace RS + +open Finset MvPolynomial Equiv + +variable {k : ℕ} + +/-- The Leibniz expansion of the Jacobi–Trudi determinant in +row-normal form. -/ +theorem det_jtMat_expand (v : Fin k → ℕ) : + (jtMat v).det = + ∑ σ : Equiv.Perm (Fin k), + ((Equiv.Perm.sign σ : ℤ) : MvPolynomial (Fin k) ℂ) * + ∏ i, hSubZ (Finset.univ : Finset (Fin k)) + ((v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ)) := by + rw [← Matrix.det_transpose, Matrix.det_apply'] + refine Finset.sum_congr rfl fun σ _ => ?_ + congr 1 + +/-- Guarded form: a Leibniz term with all degrees nonnegative is a +complete homogeneous product; otherwise it vanishes. -/ +theorem jt_term_guard (v : Fin k → ℕ) (σ : Equiv.Perm (Fin k)) : + (∏ i, hSubZ (Finset.univ : Finset (Fin k)) + ((v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ))) = + if ∀ i : Fin k, 0 ≤ (v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) + then ∏ i, hSub (Finset.univ : Finset (Fin k)) + (((v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ)).toNat) + else 0 := by + classical + by_cases hp : ∀ i : Fin k, + 0 ≤ (v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) + · rw [ite_eq_left hp] + refine Finset.prod_congr rfl fun i _ => ?_ + rw [show ((v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ)) = + ((((v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ)).toNat : ℕ) : + ℤ) from (Int.toNat_of_nonneg (hp i)).symm] + rw [hSubZ_natCast, Int.toNat_natCast] + · rw [ite_eq_right hp] + rw [not_forall] at hp + obtain ⟨i0, hi0⟩ := hp + exact Finset.prod_eq_zero (Finset.mem_univ i0) + (hSubZ_neg _ _ (not_le.mp hi0)) + +/-- **Coefficient of the Jacobi–Trudi determinant**: signed +guarded sum of coefficients of complete homogeneous products. -/ +theorem coeff_det_jtMat (v : Fin k → ℕ) (w : Fin k →₀ ℕ) : + ((jtMat v).det).coeff w = + ∑ σ : Equiv.Perm (Fin k), + ((Equiv.Perm.sign σ : ℤ) : ℂ) * + (if ∀ i : Fin k, + 0 ≤ (v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) + then (∏ i, hSub (Finset.univ : Finset (Fin k)) + (((v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ)).toNat)).coeff w + else 0) := by + classical + rw [det_jtMat_expand] + rw [Finset.sum_congr rfl + (fun (σ : Equiv.Perm (Fin k)) (_ : σ ∈ Finset.univ) => by + rw [jt_term_guard v σ])] + rw [MvPolynomial.coeff_sum] + refine Finset.sum_congr rfl fun σ _ => ?_ + rw [show ((Equiv.Perm.sign σ : ℤ) : MvPolynomial (Fin k) ℂ) = + MvPolynomial.C ((Equiv.Perm.sign σ : ℤ) : ℂ) from by simp, + MvPolynomial.coeff_C_mul] + by_cases hp : ∀ i : Fin k, + 0 ≤ (v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) + · rw [ite_eq_left hp, ite_eq_left hp] + · rw [ite_eq_right hp, ite_eq_right hp, AddMonoidAlgebra.coeff_zero] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTGuard.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTGuard.lean new file mode 100644 index 0000000000..6fc748222b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTGuard.lean @@ -0,0 +1,84 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.TIdentity + +/-! +# Guard and margin bridges for the double-sum identity + +The staircase guard of the double-sum identity matches the signed +nonnegativity guard of the Jacobi–Trudi character, the shifted +margins match the shifted compositions, and sorted shapes have +injective staircase exponents. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv + +variable {k : ℕ} + +/-- The staircase-shifted exponent at a row. -/ +theorem diagExp_apply (v : Fin k → ℕ) (j : Fin k) : + diagExp v j = v j + ((k - 1) - (j : ℕ)) := + sum_single_apply (fun i => v i + ((k - 1) - (i : ℕ))) j + +/-- The staircase guard is the signed nonnegativity guard. -/ +theorem stair_guard_iff (v : Fin k → ℕ) (τ : Equiv.Perm (Fin k)) : + stairShift τ ≤ diagExp v ↔ + ∀ i : Fin k, 0 ≤ (v i : ℤ) + ((τ i : Fin k) : ℕ) - (i : ℕ) := by + rw [Finsupp.le_def] + constructor + · intro h i + have h1 := h i + rw [stairShift_apply, diagExp_apply] at h1 + have hi := i.isLt + have hti := (τ i).isLt + omega + · intro h i + rw [stairShift_apply, diagExp_apply] + have h1 := h i + have hi := i.isLt + have hti := (τ i).isLt + omega + +/-- The shifted margin is the shifted composition. -/ +theorem stair_margin_eq (v : Fin k → ℕ) (τ : Equiv.Perm (Fin k)) + (h : stairShift τ ≤ diagExp v) (j : Fin k) : + (diagExp v - stairShift τ) j = + ((v j : ℤ) + ((τ j : Fin k) : ℕ) - (j : ℕ)).toNat := by + rw [Finsupp.tsub_apply, stairShift_apply, diagExp_apply] + have h1 := (stair_guard_iff v τ).mp h j + have hj := j.isLt + have htj := (τ j).isLt + omega + +/-- Sorted shapes have injective staircase exponents. -/ +theorem staircase_injective (v : Fin k → ℕ) + (hsort : ∀ i j : Fin k, i ≤ j → v j ≤ v i) : + Function.Injective + (fun i : Fin k => v i + ((k - 1) - (i : ℕ))) := by + intro i j hij + by_contra hne + rcases lt_or_gt_of_ne hne with hlt | hlt + · have h1 := hsort i j (le_of_lt hlt) + have hi := i.isLt + have hj := j.isLt + have hij' : (i : ℕ) < (j : ℕ) := hlt + simp only at hij + omega + · have h1 := hsort j i (le_of_lt hlt) + have hi := i.isLt + have hj := j.isLt + have hij' : (j : ℕ) < (i : ℕ) := hlt + simp only at hij + omega + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/LGVStrict.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/LGVStrict.lean new file mode 100644 index 0000000000..67ea8d8371 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/LGVStrict.lean @@ -0,0 +1,791 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialDet + +/-! +# Nonvanishing of the binomial Toeplitz determinant + +The binomial Toeplitz determinant `det [C(m, s+j−i)]_{s × s}` is +nonzero for `1 ≤ s ≤ m`, discharging `SquareBinomialDetPos` of +`BinomialDet.lean`. + +The proof is the Lindström–Gessel–Viennot involution: the Leibniz +expansion of the determinant is a signed count of tuples +`(σ, F)` where `F i` is an `(s + σ(i) − i)`-subset of `Fin m` +(the E-step heights of a lattice path). Crossing tuples cancel in +pairs under the tail-swap involution at the first crossing; the +noncrossing tuples all have `σ = 1` and count with sign `+1`, and at +least one exists. +-/ + +@[expose] public section + + + +namespace RS + +open Finset Matrix + +/-! ## 1. Sign extraction -/ + +/-- `(-1)^(s+j-i) = (-1)^s * (-1)^i * (-1)^j` when `i ≤ s + j`. -/ +private theorem neg_one_pow_split (s i j : ℕ) (h : i ≤ s + j) : + ((-1 : ℂ)) ^ (s + j - i) = (-1) ^ s * (-1) ^ i * (-1) ^ j := by + suffices ((-1 : ℂ)) ^ (s + j - i) = (-1) ^ (s + i + j) by + rw [this, pow_add, pow_add] + have hmod : (s + j - i) % 2 = (s + i + j) % 2 := by omega + have h1 := (Nat.div_add_mod (s + j - i) 2).symm + have h2 := (Nat.div_add_mod (s + i + j) 2).symm + rw [h1, h2, hmod, pow_add, pow_add, pow_mul, pow_mul, neg_one_sq, + one_pow, one_pow] + +/-- `(-1)^a` only depends on the parity of `a`. -/ +private theorem neg_one_pow_congr (a b : ℕ) (h : a % 2 = b % 2) : + ((-1 : ℂ)) ^ a = (-1) ^ b := by + have h1 := (Nat.div_add_mod a 2).symm + have h2 := (Nat.div_add_mod b 2).symm + rw [h1, h2, h, pow_add, pow_add, pow_mul, pow_mul, neg_one_sq, + one_pow, one_pow] + +/-- The sign product equals `(-1)^s`. Uses `∏ a^f(i) = a^(∑ f(i))`. -/ +private theorem sign_product (s : ℕ) : + (∏ i : Fin s, ((-1 : ℂ)) ^ (s + (i : ℕ))) * + ∏ j : Fin s, ((-1 : ℂ)) ^ (j : ℕ) = (-1) ^ s := by + -- Combine using ∏ a^f = a^(∑f) + simp only [Finset.prod_pow_eq_pow_sum] + rw [← pow_add] + apply neg_one_pow_congr + -- ∑_{i : Fin s} (s + i) = s*s + ∑ i + have hsum1 : ∑ i : Fin s, (s + (i : ℕ)) = + s * s + ∑ i : Fin s, (i : ℕ) := by + rw [Finset.sum_add_distrib, Finset.sum_const, Finset.card_univ, + Fintype.card_fin, smul_eq_mul] + rw [hsum1] + -- (s*s + ∑i + ∑j) % 2 = s % 2 because s*s ≡ s (mod 2) + have hpar : s * s % 2 = s % 2 := by + rcases Nat.mod_two_eq_zero_or_one s with h | h <;> + rw [Nat.mul_mod, h] + omega + +/-- Sign extraction: `diagramSchur(sq_s, -(m)) = (-1)^s * det[C(m, s+j-i)]`. -/ +theorem diagramSchur_neg_eq_sign_mul_binomDet (s m : ℕ) (hs : 1 ≤ s) + (hm : s ≤ m) : + diagramSchur (squareDiagram s) (fun _ => -(m : ℂ)) = + (-1 : ℂ) ^ s * + (Matrix.of fun i j : Fin s => + (Nat.choose m (s + (j : ℕ) - (i : ℕ)) : ℂ)).det := by + have hL : (squareDiagram s).rowLens.length = s := square_rowLens_length s + have hm1 : 1 ≤ m := le_trans hs hm + rw [diagramSchur, schurDet] + -- Entrywise: newtonHZ(-(m), s+j-i) = (-1)^{s+i} * (-1)^j * C(m, s+j-i) + have hmat : (Matrix.of fun (i j : Fin (squareDiagram s).rowLens.length) => + newtonHZ (fun _ => -(m : ℂ)) + (↑((squareDiagram s).rowLens.get i) + ↑↑j - ↑↑i)) = + Matrix.of fun (i j : Fin (squareDiagram s).rowLens.length) => + ((-1 : ℂ)) ^ (s + (i : ℕ)) * + (((-1 : ℂ)) ^ (j : ℕ) * + (Nat.choose m (s + (j : ℕ) - (i : ℕ)) : ℂ)) := by + ext i j; simp only [Matrix.of_apply] + have hi : (i : ℕ) < s := by have := i.isLt; omega + have hj : (j : ℕ) < s := by have := j.isLt; omega + rw [List.get_eq_getElem, YoungDiagram.get_rowLens, rowLen_squareDiagram hi] + rw [newtonHZ, ite_eq_left (show (0 : ℤ) ≤ (s : ℤ) + ↑↑j - ↑↑i by omega)] + rw [show ((s : ℤ) + ↑↑j - ↑↑i).toNat = s + (j : ℕ) - (i : ℕ) from by omega] + rw [newtonH_neg_const m hm1, neg_one_pow_split s (i : ℕ) (j : ℕ) (by omega)] + ring + rw [hmat] + -- Extract row signs via det_mul_column, then column signs via det_mul_row. + have h_det_step : ∀ (n : ℕ) (v : Fin n → ℂ) + (A : Fin n → Fin n → ℂ), + (Matrix.of fun i j => v i * A i j).det = + (∏ i, v i) * (Matrix.of A).det := by + intro n v A; exact det_mul_column v (Matrix.of A) + have h_det_step' : ∀ (n : ℕ) (v : Fin n → ℂ) + (A : Fin n → Fin n → ℂ), + (Matrix.of fun i j => v j * A i j).det = + (∏ j, v j) * (Matrix.of A).det := by + intro n v A; exact det_mul_row v (Matrix.of A) + rw [h_det_step _ (fun i => (-1 : ℂ) ^ (s + (i : ℕ))) + (fun i j => (-1) ^ (j : ℕ) * (Nat.choose m (s + (j : ℕ) - (i : ℕ)) : ℂ))] + rw [h_det_step' _ (fun j => (-1 : ℂ) ^ (j : ℕ)) + (fun i j => (Nat.choose m (s + (j : ℕ) - (i : ℕ)) : ℂ))] + rw [← mul_assoc, hL, sign_product s] + +/-! ## 2. The LGV path model + +For a permutation `σ`, the Leibniz term `∏ i C(m, s+σ(i)−i)` counts +tuples `F : Fin s → Finset (Fin m)` with `(F i).card = s + σ(i) − i`. +Path `i` has x-coordinate `x_i(h) = i + #{a ∈ F i | a < h}` at +height `h`. -/ + +/-- The column degree `s + σ(i) − i` of the Leibniz term. -/ +private def ddeg (s : ℕ) (σ : Equiv.Perm (Fin s)) (i : Fin s) : ℕ := + s + (σ i : ℕ) - (i : ℕ) + +/-- The set of families counted by the Leibniz term of `σ`. -/ +private def famSet (s m : ℕ) (σ : Equiv.Perm (Fin s)) : + Finset (Fin s → Finset (Fin m)) := + Fintype.piFinset fun i => + (Finset.univ : Finset (Fin m)).powersetCard (ddeg s σ i) + +private theorem card_of_mem_famSet {s m : ℕ} {σ : Equiv.Perm (Fin s)} + {F : Fin s → Finset (Fin m)} (hmem : F ∈ famSet s m σ) (i : Fin s) : + (F i).card = ddeg s σ i := + (Finset.mem_powersetCard.mp (Fintype.mem_piFinset.mp hmem i)).2 + +/-- x-coordinate of path `i` at height `h`. -/ +private def xcoord {s m : ℕ} (F : Fin s → Finset (Fin m)) (i : Fin s) + (h : ℕ) : ℕ := + (i : ℕ) + ((F i).filter fun a : Fin m => (a : ℕ) < h).card + +private theorem xcoord_zero {s m : ℕ} (F : Fin s → Finset (Fin m)) + (i : Fin s) : xcoord F i 0 = (i : ℕ) := by + rw [xcoord, Finset.filter_false_of_mem (fun a _ => Nat.not_lt_zero _)] + simp + +private theorem xcoord_top {s m : ℕ} {σ : Equiv.Perm (Fin s)} + {F : Fin s → Finset (Fin m)} (hmem : F ∈ famSet s m σ) (i : Fin s) : + xcoord F i m = s + (σ i : ℕ) := by + rw [xcoord, Finset.filter_true_of_mem (fun a _ => a.isLt), + card_of_mem_famSet hmem i, ddeg] + have := i.isLt + omega + +/-- Each path moves by `0` or `1` per height step. -/ +private theorem xcoord_step {s m : ℕ} (F : Fin s → Finset (Fin m)) + (i : Fin s) (h : ℕ) : + xcoord F i h ≤ xcoord F i (h + 1) ∧ + xcoord F i (h + 1) ≤ xcoord F i h + 1 := by + constructor + · rw [xcoord, xcoord] + have hsub : (F i).filter (fun a : Fin m => (a : ℕ) < h) ⊆ + (F i).filter (fun a : Fin m => (a : ℕ) < h + 1) := by + intro a ha + rw [Finset.mem_filter] at ha ⊢ + exact ⟨ha.1, by omega⟩ + have := Finset.card_le_card hsub + omega + · rw [xcoord, xcoord] + have hsub : (F i).filter (fun a : Fin m => (a : ℕ) < h + 1) ⊆ + (F i).filter (fun a : Fin m => (a : ℕ) < h) ∪ + (F i).filter (fun a : Fin m => (a : ℕ) = h) := by + intro a ha + rw [Finset.mem_filter] at ha + rw [Finset.mem_union, Finset.mem_filter, Finset.mem_filter] + rcases ha with ⟨hmem, hlt⟩ + by_cases hae : (a : ℕ) = h + · exact Or.inr ⟨hmem, hae⟩ + · exact Or.inl ⟨hmem, by omega⟩ + have h1 := Finset.card_le_card hsub + have h2 := Finset.card_union_le + ((F i).filter (fun a : Fin m => (a : ℕ) < h)) + ((F i).filter (fun a : Fin m => (a : ℕ) = h)) + have h3 : ((F i).filter (fun a : Fin m => (a : ℕ) = h)).card ≤ 1 := by + apply Finset.card_le_one.mpr + intro a ha b hb + rw [Finset.mem_filter] at ha hb + exact Fin.ext (by omega) + omega + +/-- Two paths cross at height `h`. -/ +private def CrossingAt {s m : ℕ} (F : Fin s → Finset (Fin m)) + (h : ℕ) : Prop := + ∃ i i' : Fin s, i < i' ∧ xcoord F i h = xcoord F i' h + +/-- Two paths cross somewhere. -/ +private def Crossing {s m : ℕ} (F : Fin s → Finset (Fin m)) : Prop := + ∃ h, CrossingAt F h + +/-! ## 3. Canonical crossing data -/ + +/-- Paths that participate in a crossing at height `h` (as the lower +index). -/ +private def crossSet {s m : ℕ} (F : Fin s → Finset (Fin m)) + (h : ℕ) : Finset (Fin s) := + Finset.univ.filter fun i => + ∃ i', i < i' ∧ xcoord F i h = xcoord F i' h + +/-- Partners of `i0` in a crossing at height `h`. -/ +private def partnerSet {s m : ℕ} (F : Fin s → Finset (Fin m)) + (h : ℕ) (i0 : Fin s) : Finset (Fin s) := + Finset.univ.filter fun i' => + i0 < i' ∧ xcoord F i0 h = xcoord F i' h + +open scoped Classical in +/-- Least crossing height. -/ +private noncomputable def cH {s m : ℕ} (F : Fin s → Finset (Fin m)) + (hc : Crossing F) : ℕ := + Nat.find hc + +open scoped Classical in +private theorem crossSet_nonempty {s m : ℕ} (F : Fin s → Finset (Fin m)) + (hc : Crossing F) : (crossSet F (cH F hc)).Nonempty := by + obtain ⟨i, i', hlt, heq⟩ := Nat.find_spec hc + exact ⟨i, Finset.mem_filter.mpr ⟨Finset.mem_univ _, i', hlt, heq⟩⟩ + +/-- Least lower index of a crossing at the least crossing height. -/ +private noncomputable def cI0 {s m : ℕ} (F : Fin s → Finset (Fin m)) + (hc : Crossing F) : Fin s := + (crossSet F (cH F hc)).min' (crossSet_nonempty F hc) + +private theorem partnerSet_nonempty {s m : ℕ} + (F : Fin s → Finset (Fin m)) (hc : Crossing F) : + (partnerSet F (cH F hc) (cI0 F hc)).Nonempty := by + have hmem := Finset.min'_mem (crossSet F (cH F hc)) + (crossSet_nonempty F hc) + obtain ⟨i', hlt, heq⟩ := (Finset.mem_filter.mp hmem).2 + exact ⟨i', Finset.mem_filter.mpr ⟨Finset.mem_univ _, hlt, heq⟩⟩ + +/-- Least partner index. -/ +private noncomputable def cI1 {s m : ℕ} (F : Fin s → Finset (Fin m)) + (hc : Crossing F) : Fin s := + (partnerSet F (cH F hc) (cI0 F hc)).min' (partnerSet_nonempty F hc) + +private theorem cI1_spec {s m : ℕ} (F : Fin s → Finset (Fin m)) + (hc : Crossing F) : + cI0 F hc < cI1 F hc ∧ + xcoord F (cI0 F hc) (cH F hc) = xcoord F (cI1 F hc) (cH F hc) := + (Finset.mem_filter.mp (Finset.min'_mem _ (partnerSet_nonempty F hc))).2 + +private theorem min'_congr_of_eq {α : Type*} [LinearOrder α] + {S T : Finset α} (h : S = T) (hS : S.Nonempty) (hT : T.Nonempty) : + S.min' hS = T.min' hT := by + subst h; rfl + +/-! ## 4. The tail-swap involution on families -/ + +/-- Swap the tails (elements `≥ h`) of paths `i` and `i'`. -/ +private def swapFam {s m : ℕ} (F : Fin s → Finset (Fin m)) (h : ℕ) + (i i' : Fin s) : Fin s → Finset (Fin m) := + fun j => + if j = i then + ((F i).filter fun a : Fin m => (a : ℕ) < h) ∪ + ((F i').filter fun a : Fin m => ¬ (a : ℕ) < h) + else if j = i' then + ((F i').filter fun a : Fin m => (a : ℕ) < h) ∪ + ((F i).filter fun a : Fin m => ¬ (a : ℕ) < h) + else F j + +private theorem swapFam_apply_other {s m : ℕ} + (F : Fin s → Finset (Fin m)) (h : ℕ) (i i' j : Fin s) + (hj : j ≠ i) (hj' : j ≠ i') : swapFam F h i i' j = F j := by + rw [swapFam, ite_eq_right hj, ite_eq_right hj'] + +/-- Prefixes below `h' ≤ h` are unchanged by the tail swap. -/ +private theorem swapFam_prefix {s m : ℕ} (F : Fin s → Finset (Fin m)) + (h : ℕ) (i i' : Fin s) (hne : i ≠ i') (j : Fin s) (h' : ℕ) + (hh : h' ≤ h) : + ((swapFam F h i i' j).filter fun a : Fin m => (a : ℕ) < h') = + (F j).filter fun a : Fin m => (a : ℕ) < h' := by + have key : ∀ (A B : Finset (Fin m)), + ((A.filter (fun a : Fin m => (a : ℕ) < h) ∪ + B.filter (fun a : Fin m => ¬ (a : ℕ) < h)).filter + fun a : Fin m => (a : ℕ) < h') = + A.filter fun a : Fin m => (a : ℕ) < h' := by + intro A B + rw [Finset.filter_union, Finset.filter_filter, Finset.filter_filter] + have h1 : B.filter (fun a : Fin m => ¬ (a : ℕ) < h ∧ (a : ℕ) < h') = ∅ := + Finset.filter_false_of_mem (fun a _ => by omega) + have h2 : A.filter (fun a : Fin m => (a : ℕ) < h ∧ (a : ℕ) < h') = + A.filter fun a : Fin m => (a : ℕ) < h' := + Finset.filter_congr (fun a _ => by constructor <;> intro <;> omega) + rw [h1, h2, Finset.union_empty] + by_cases hji : j = i + · subst hji; rw [swapFam, ite_eq_left rfl]; exact key _ _ + · by_cases hji' : j = i' + · subst hji'; rw [swapFam, ite_eq_right hji, ite_eq_left rfl]; exact key _ _ + · rw [swapFam_apply_other F h i i' j hji hji'] + +private theorem swapFam_xcoord {s m : ℕ} (F : Fin s → Finset (Fin m)) + (h : ℕ) (i i' : Fin s) (hne : i ≠ i') (j : Fin s) (h' : ℕ) + (hh : h' ≤ h) : + xcoord (swapFam F h i i') j h' = xcoord F j h' := by + rw [xcoord, xcoord, swapFam_prefix F h i i' hne j h' hh] + +/-- Cardinality bookkeeping for the swapped path at `i`. -/ +private theorem swapFam_card_left {s m : ℕ} + (F : Fin s → Finset (Fin m)) (h : ℕ) (i i' : Fin s) : + (swapFam F h i i' i).card + + ((F i').filter fun a : Fin m => (a : ℕ) < h).card = + ((F i).filter fun a : Fin m => (a : ℕ) < h).card + (F i').card := by + rw [swapFam, ite_eq_left rfl, + Finset.card_union_of_disjoint + (Finset.disjoint_filter_filter_not (F i) (F i') + (fun a : Fin m => (a : ℕ) < h))] + have := Finset.card_filter_add_card_filter_not (s := F i') + (fun a : Fin m => (a : ℕ) < h) + omega + +/-- Cardinality bookkeeping for the swapped path at `i'`. -/ +private theorem swapFam_card_right {s m : ℕ} + (F : Fin s → Finset (Fin m)) (h : ℕ) (i i' : Fin s) (hne : i ≠ i') : + (swapFam F h i i' i').card + + ((F i).filter fun a : Fin m => (a : ℕ) < h).card = + ((F i').filter fun a : Fin m => (a : ℕ) < h).card + (F i).card := by + rw [swapFam, ite_eq_right (Ne.symm hne), ite_eq_left rfl, + Finset.card_union_of_disjoint + (Finset.disjoint_filter_filter_not (F i') (F i) + (fun a : Fin m => (a : ℕ) < h))] + have := Finset.card_filter_add_card_filter_not (s := F i) + (fun a : Fin m => (a : ℕ) < h) + omega + +/-- The tail swap is an involution on families. -/ +private theorem swapFam_involutive {s m : ℕ} + (F : Fin s → Finset (Fin m)) (h : ℕ) (i i' : Fin s) (hne : i ≠ i') : + swapFam (swapFam F h i i') h i i' = F := by + funext j + have keyPre : ∀ (A B : Finset (Fin m)), + ((A.filter (fun a : Fin m => (a : ℕ) < h) ∪ + B.filter (fun a : Fin m => ¬ (a : ℕ) < h)).filter + fun a : Fin m => (a : ℕ) < h) = + A.filter fun a : Fin m => (a : ℕ) < h := by + intro A B + rw [Finset.filter_union, Finset.filter_filter, Finset.filter_filter] + have h1 : B.filter (fun a : Fin m => ¬ (a : ℕ) < h ∧ (a : ℕ) < h) = ∅ := + Finset.filter_false_of_mem (fun a _ => by omega) + have h2 : A.filter (fun a : Fin m => (a : ℕ) < h ∧ (a : ℕ) < h) = + A.filter fun a : Fin m => (a : ℕ) < h := + Finset.filter_congr (fun a _ => by constructor <;> intro <;> omega) + rw [h1, h2, Finset.union_empty] + have keySuf : ∀ (A B : Finset (Fin m)), + ((A.filter (fun a : Fin m => (a : ℕ) < h) ∪ + B.filter (fun a : Fin m => ¬ (a : ℕ) < h)).filter + fun a : Fin m => ¬ (a : ℕ) < h) = + B.filter fun a : Fin m => ¬ (a : ℕ) < h := by + intro A B + rw [Finset.filter_union, Finset.filter_filter, Finset.filter_filter] + have h1 : A.filter (fun a : Fin m => (a : ℕ) < h ∧ ¬ (a : ℕ) < h) = ∅ := + Finset.filter_false_of_mem (fun a _ => by omega) + have h2 : B.filter (fun a : Fin m => ¬ (a : ℕ) < h ∧ ¬ (a : ℕ) < h) = + B.filter fun a : Fin m => ¬ (a : ℕ) < h := + Finset.filter_congr (fun a _ => by constructor <;> intro <;> omega) + rw [h1, h2, Finset.empty_union] + have hGi : swapFam F h i i' i = + ((F i).filter fun a : Fin m => (a : ℕ) < h) ∪ + ((F i').filter fun a : Fin m => ¬ (a : ℕ) < h) := by + rw [swapFam, ite_eq_left rfl] + have hGi' : swapFam F h i i' i' = + ((F i').filter fun a : Fin m => (a : ℕ) < h) ∪ + ((F i).filter fun a : Fin m => ¬ (a : ℕ) < h) := by + rw [swapFam, ite_eq_right (Ne.symm hne), ite_eq_left rfl] + by_cases hji : j = i + · rw [hji] + rw [swapFam, ite_eq_left rfl] + rw [hGi, hGi', keyPre, keySuf, Finset.filter_union_filter_not_eq] + · by_cases hji' : j = i' + · rw [hji'] + rw [swapFam, ite_eq_right (Ne.symm hne), ite_eq_left rfl] + rw [hGi, hGi', keyPre, keySuf, Finset.filter_union_filter_not_eq] + · rw [swapFam_apply_other _ h i i' j hji hji', + swapFam_apply_other F h i i' j hji hji'] + +/-! ## 5. Invariance of the canonical crossing data -/ + +open scoped Classical in +/-- If `G` agrees with `F` in all x-coordinates up to the first +crossing height of `F`, then `G` has the same canonical crossing +data. -/ +private theorem choices_eq {s m : ℕ} (F G : Fin s → Finset (Fin m)) + (hcF : Crossing F) (hcG : Crossing G) + (hagree : ∀ (j : Fin s) (h' : ℕ), h' ≤ cH F hcF → + xcoord G j h' = xcoord F j h') : + cH G hcG = cH F hcF ∧ cI0 G hcG = cI0 F hcF ∧ + cI1 G hcG = cI1 F hcF := by + have hcAtF : CrossingAt F (cH F hcF) := Nat.find_spec hcF + have hcAtG : CrossingAt G (cH F hcF) := by + obtain ⟨i, i', hlt, heq⟩ := hcAtF + exact ⟨i, i', hlt, by + rw [hagree i _ le_rfl, hagree i' _ le_rfl]; exact heq⟩ + have hH : cH G hcG = cH F hcF := by + have h1 : cH G hcG ≤ cH F hcF := Nat.find_min' hcG hcAtG + rcases Nat.lt_or_ge (cH G hcG) (cH F hcF) with hlt | hge + · exfalso + obtain ⟨i, i', hlt', heq⟩ := Nat.find_spec hcG + exact Nat.find_min hcF hlt ⟨i, i', hlt', by + rw [← hagree i _ (le_of_lt hlt), ← hagree i' _ (le_of_lt hlt)] + exact heq⟩ + · omega + have hxeq : ∀ j : Fin s, xcoord G j (cH G hcG) = xcoord F j (cH F hcF) := by + intro j; rw [hH]; exact hagree j _ le_rfl + have hset : crossSet G (cH G hcG) = crossSet F (cH F hcF) := by + rw [crossSet, crossSet] + apply Finset.filter_congr + intro x _ + constructor + · rintro ⟨i', hlt, heq⟩ + exact ⟨i', hlt, by rw [← hxeq x, ← hxeq i']; exact heq⟩ + · rintro ⟨i', hlt, heq⟩ + exact ⟨i', hlt, by rw [hxeq x, hxeq i']; exact heq⟩ + have hI0 : cI0 G hcG = cI0 F hcF := + min'_congr_of_eq hset (crossSet_nonempty G hcG) + (crossSet_nonempty F hcF) + have hset' : partnerSet G (cH G hcG) (cI0 G hcG) = + partnerSet F (cH F hcF) (cI0 F hcF) := by + rw [partnerSet, partnerSet, hI0] + apply Finset.filter_congr + intro x _ + constructor + · rintro ⟨hlt, heq⟩ + exact ⟨hlt, by rw [← hxeq (cI0 F hcF), ← hxeq x]; exact heq⟩ + · rintro ⟨hlt, heq⟩ + exact ⟨hlt, by rw [hxeq (cI0 F hcF), hxeq x]; exact heq⟩ + have hI1 : cI1 G hcG = cI1 F hcF := + min'_congr_of_eq hset' (partnerSet_nonempty G hcG) + (partnerSet_nonempty F hcF) + exact ⟨hH, hI0, hI1⟩ + +/-! ## 6. The involution kills the crossing terms -/ + +/-- The swapped family lies in the family set of `σ * swap i₀ i₁`. -/ +private theorem swapFam_mem_famSet {s m : ℕ} {σ : Equiv.Perm (Fin s)} + {F : Fin s → Finset (Fin m)} (hmem : F ∈ famSet s m σ) + (hc : Crossing F) : + swapFam F (cH F hc) (cI0 F hc) (cI1 F hc) ∈ + famSet s m (σ * Equiv.swap (cI0 F hc) (cI1 F hc)) := by + obtain ⟨hlt, hxeq⟩ := cI1_spec F hc + have hne : cI0 F hc ≠ cI1 F hc := ne_of_lt hlt + rw [famSet, Fintype.mem_piFinset] + intro j + rw [Finset.mem_powersetCard] + refine ⟨Finset.subset_univ _, ?_⟩ + by_cases hj0 : j = cI0 F hc + · rw [hj0] + have hcard := swapFam_card_left F (cH F hc) (cI0 F hc) (cI1 F hc) + have hx : (cI0 F hc : ℕ) + + ((F (cI0 F hc)).filter fun a : Fin m => + (a : ℕ) < cH F hc).card = + (cI1 F hc : ℕ) + + ((F (cI1 F hc)).filter fun a : Fin m => + (a : ℕ) < cH F hc).card := hxeq + have hc1 : (F (cI1 F hc)).card = ddeg s σ (cI1 F hc) := + card_of_mem_famSet hmem _ + have hperm : (σ * Equiv.swap (cI0 F hc) (cI1 F hc)) (cI0 F hc) = + σ (cI1 F hc) := by + rw [Equiv.Perm.mul_apply, Equiv.swap_apply_left] + rw [ddeg, hperm] + rw [ddeg] at hc1 + have hb1 := (cI1 F hc).isLt + have hb2 := (σ (cI1 F hc)).isLt + have hb3 := (cI0 F hc).isLt + omega + · by_cases hj1 : j = cI1 F hc + · rw [hj1] + have hcard := swapFam_card_right F (cH F hc) (cI0 F hc) + (cI1 F hc) hne + have hx : (cI0 F hc : ℕ) + + ((F (cI0 F hc)).filter fun a : Fin m => + (a : ℕ) < cH F hc).card = + (cI1 F hc : ℕ) + + ((F (cI1 F hc)).filter fun a : Fin m => + (a : ℕ) < cH F hc).card := hxeq + have hc0 : (F (cI0 F hc)).card = ddeg s σ (cI0 F hc) := + card_of_mem_famSet hmem _ + have hperm : (σ * Equiv.swap (cI0 F hc) (cI1 F hc)) (cI1 F hc) = + σ (cI0 F hc) := by + rw [Equiv.Perm.mul_apply, Equiv.swap_apply_right] + rw [ddeg, hperm] + rw [ddeg] at hc0 + have hb1 := (cI0 F hc).isLt + have hb2 := (σ (cI0 F hc)).isLt + have hb3 := (cI1 F hc).isLt + omega + · rw [swapFam_apply_other F _ _ _ j hj0 hj1] + have hperm : (σ * Equiv.swap (cI0 F hc) (cI1 F hc)) j = σ j := by + rw [Equiv.Perm.mul_apply, Equiv.swap_apply_of_ne_of_ne hj0 hj1] + rw [ddeg, hperm, ← ddeg] + exact card_of_mem_famSet hmem j + +/-- The swapped family still crosses (at the same height). -/ +private theorem swapFam_crossing {s m : ℕ} + (F : Fin s → Finset (Fin m)) (hc : Crossing F) : + Crossing (swapFam F (cH F hc) (cI0 F hc) (cI1 F hc)) := by + obtain ⟨hlt, hxeq⟩ := cI1_spec F hc + have hne : cI0 F hc ≠ cI1 F hc := ne_of_lt hlt + exact ⟨cH F hc, cI0 F hc, cI1 F hc, hlt, by + rw [swapFam_xcoord F _ _ _ hne _ _ le_rfl, + swapFam_xcoord F _ _ _ hne _ _ le_rfl] + exact hxeq⟩ + +/-! ## 7. Noncrossing families force the identity permutation -/ + +/-- A strictly monotone permutation of `Fin s` is the identity. -/ +private theorem perm_eq_one_of_strictMono {s : ℕ} + (σ : Equiv.Perm (Fin s)) + (hmono : ∀ i i' : Fin s, i < i' → σ i < σ i') : σ = 1 := by + have le_apply : ∀ (f : Equiv.Perm (Fin s)), + (∀ i i' : Fin s, i < i' → f i < f i') → + ∀ (k : ℕ) (hk : k < s), k ≤ (f ⟨k, hk⟩ : ℕ) := by + intro f hf k + induction k with + | zero => intro hk; exact Nat.zero_le _ + | succ n ih => + intro hk + have hn : n < s := Nat.lt_of_succ_lt hk + have h1 : f ⟨n, hn⟩ < f ⟨n + 1, hk⟩ := + hf _ _ (by rw [Fin.mk_lt_mk]; omega) + have h2 := ih hn + have h3 : (f ⟨n, hn⟩ : ℕ) < (f ⟨n + 1, hk⟩ : ℕ) := h1 + omega + have hmono' : ∀ a b : Fin s, a < b → σ⁻¹ a < σ⁻¹ b := by + intro a b hab + rcases lt_trichotomy (σ⁻¹ a) (σ⁻¹ b) with h | h | h + · exact h + · exfalso + have : a = b := by + have := congrArg σ h + rwa [Equiv.Perm.inv_def, Equiv.apply_symm_apply, + Equiv.apply_symm_apply] at this + exact absurd this (ne_of_lt hab) + · exfalso + have := hmono _ _ h + rw [Equiv.Perm.inv_def, Equiv.apply_symm_apply, + Equiv.apply_symm_apply] at this + exact absurd hab (lt_asymm this) + apply Equiv.ext + intro i + have h1 : (i : ℕ) ≤ (σ i : ℕ) := by + have := le_apply σ hmono (i : ℕ) i.isLt + rwa [Fin.eta] at this + have h2 : (σ i : ℕ) ≤ (i : ℕ) := by + have := le_apply σ⁻¹ hmono' ((σ i : ℕ)) (σ i).isLt + rwa [Fin.eta, Equiv.Perm.inv_def, Equiv.symm_apply_apply] at this + have : σ i = i := Fin.ext (by omega) + simpa using this + +/-- Discrete intermediate value theorem for ±1-step sequences. -/ +private theorem exists_zero_of_steps (D : ℕ → ℤ) (M : ℕ) + (hstep : ∀ h, D (h + 1) - D h ≤ 1 ∧ D h - D (h + 1) ≤ 1) + (h0 : 0 < D 0) (hM : D M ≤ 0) : ∃ h, D h = 0 := by + have hex : ∃ h, D h ≤ 0 := ⟨M, hM⟩ + have hk : D (Nat.find hex) ≤ 0 := Nat.find_spec hex + have hkpos : Nat.find hex ≠ 0 := by + intro h + rw [h] at hk + omega + have hprev : ¬ D (Nat.find hex - 1) ≤ 0 := + Nat.find_min hex (by omega) + have hs := hstep (Nat.find hex - 1) + rw [show Nat.find hex - 1 + 1 = Nat.find hex from by omega] at hs + exact ⟨Nat.find hex, by omega⟩ + +/-- A noncrossing family forces `σ = 1`. -/ +private theorem noncross_perm_eq_one {s m : ℕ} + {σ : Equiv.Perm (Fin s)} {F : Fin s → Finset (Fin m)} + (hmem : F ∈ famSet s m σ) (hnc : ¬ Crossing F) : σ = 1 := by + apply perm_eq_one_of_strictMono + intro i i' hlt + by_contra hge + -- Then σ i' ≤ σ i; injectivity gives σ i' < σ i: an inversion. + have hne : σ i ≠ σ i' := fun h => + absurd (σ.injective h) (ne_of_lt hlt) + have hinv : (σ i' : ℕ) < (σ i : ℕ) := by + rw [not_lt] at hge + have h1 : (σ i' : ℕ) ≤ (σ i : ℕ) := hge + have h2 : (σ i' : ℕ) ≠ (σ i : ℕ) := fun h => + hne (Fin.ext h.symm) + omega + -- Discrete IVT on D h = x_{i'}(h) − x_i(h). + have hstep : ∀ h : ℕ, + ((xcoord F i' (h + 1) : ℤ) - xcoord F i (h + 1)) - + ((xcoord F i' h : ℤ) - xcoord F i h) ≤ 1 ∧ + ((xcoord F i' h : ℤ) - xcoord F i h) - + ((xcoord F i' (h + 1) : ℤ) - xcoord F i (h + 1)) ≤ 1 := by + intro h + have h1 := xcoord_step F i h + have h2 := xcoord_step F i' h + omega + have h0 : 0 < (xcoord F i' 0 : ℤ) - xcoord F i 0 := by + rw [xcoord_zero, xcoord_zero] + have : (i : ℕ) < (i' : ℕ) := hlt + omega + have hM : (xcoord F i' m : ℤ) - xcoord F i m ≤ 0 := by + rw [xcoord_top hmem, xcoord_top hmem] + omega + obtain ⟨h, hzero⟩ := exists_zero_of_steps + (fun h => (xcoord F i' h : ℤ) - xcoord F i h) m hstep h0 hM + exact hnc ⟨h, i, i', hlt, by omega⟩ + +/-! ## 8. The signed count -/ + +/-- One full involution step returns the original tuple. -/ +private theorem swap_step_involutive {s m : ℕ} (σ : Equiv.Perm (Fin s)) + (F : Fin s → Finset (Fin m)) (hc : Crossing F) + (hcG : Crossing (swapFam F (cH F hc) (cI0 F hc) (cI1 F hc))) : + (⟨σ * Equiv.swap (cI0 F hc) (cI1 F hc) * + Equiv.swap + (cI0 (swapFam F (cH F hc) (cI0 F hc) (cI1 F hc)) hcG) + (cI1 (swapFam F (cH F hc) (cI0 F hc) (cI1 F hc)) hcG), + swapFam (swapFam F (cH F hc) (cI0 F hc) (cI1 F hc)) + (cH (swapFam F (cH F hc) (cI0 F hc) (cI1 F hc)) hcG) + (cI0 (swapFam F (cH F hc) (cI0 F hc) (cI1 F hc)) hcG) + (cI1 (swapFam F (cH F hc) (cI0 F hc) (cI1 F hc)) hcG)⟩ : + (_ : Equiv.Perm (Fin s)) × (Fin s → Finset (Fin m))) = ⟨σ, F⟩ := by + obtain ⟨hlt, hxeq⟩ := cI1_spec F hc + have hne : cI0 F hc ≠ cI1 F hc := ne_of_lt hlt + have hagree : ∀ (j : Fin s) (h' : ℕ), h' ≤ cH F hc → + xcoord (swapFam F (cH F hc) (cI0 F hc) (cI1 F hc)) j h' = + xcoord F j h' := + fun j h' hh => swapFam_xcoord F _ _ _ hne j h' hh + obtain ⟨hH, hI0, hI1⟩ := choices_eq F _ hc hcG hagree + rw [hH, hI0, hI1, mul_assoc, Equiv.swap_mul_self, mul_one, + swapFam_involutive F (cH F hc) (cI0 F hc) (cI1 F hc) hne] + +/-- The determinant as a signed count over `(σ, F)` tuples. -/ +private theorem det_eq_signed_count (s m : ℕ) : + (Matrix.of fun i j : Fin s => + (Nat.choose m (s + (j : ℕ) - (i : ℕ)) : ℂ)).det = + ∑ p ∈ (Finset.univ : Finset (Equiv.Perm (Fin s))).sigma + (famSet s m), + ((Equiv.Perm.sign p.1 : ℤ) : ℂ) := by + rw [← Matrix.det_transpose, Matrix.det_apply'] + rw [← Finset.sum_sigma' Finset.univ (famSet s m) + (fun σ _ => ((Equiv.Perm.sign σ : ℤ) : ℂ))] + apply Finset.sum_congr rfl + intro σ _ + have hprod : (∏ i, (Matrix.of fun i j : Fin s => + (Nat.choose m (s + (j : ℕ) - (i : ℕ)) : ℂ))ᵀ (σ i) i) = + ((famSet s m σ).card : ℂ) := by + have hcard : (famSet s m σ).card = + ∏ i, Nat.choose m (ddeg s σ i) := by + rw [famSet, Fintype.card_piFinset] + apply Finset.prod_congr rfl + intro i _ + rw [Finset.card_powersetCard, Finset.card_univ, Fintype.card_fin] + rw [hcard, Nat.cast_prod] + apply Finset.prod_congr rfl + intro i _ + rw [Matrix.transpose_apply, Matrix.of_apply, ddeg] + rw [hprod, Finset.sum_const, nsmul_eq_mul, mul_comm] + +open scoped Classical in +/-- The crossing terms cancel. -/ +private theorem sum_crossing_zero (s m : ℕ) : + ∑ p ∈ ((Finset.univ : Finset (Equiv.Perm (Fin s))).sigma + (famSet s m)).filter (fun p => Crossing p.2), + ((Equiv.Perm.sign p.1 : ℤ) : ℂ) = 0 := by + have hcross : ∀ (p : (_ : Equiv.Perm (Fin s)) × + (Fin s → Finset (Fin m))), + p ∈ ((Finset.univ : Finset (Equiv.Perm (Fin s))).sigma + (famSet s m)).filter (fun p => Crossing p.2) → + Crossing p.2 := fun p hp => (Finset.mem_filter.mp hp).2 + refine Finset.sum_involution + (fun p hp => + ⟨p.1 * Equiv.swap (cI0 p.2 (hcross p hp)) (cI1 p.2 (hcross p hp)), + swapFam p.2 (cH p.2 (hcross p hp)) (cI0 p.2 (hcross p hp)) + (cI1 p.2 (hcross p hp))⟩) + ?_ ?_ ?_ ?_ + · -- signs cancel + intro p hp + have hne : cI0 p.2 (hcross p hp) ≠ cI1 p.2 (hcross p hp) := + ne_of_lt (cI1_spec p.2 (hcross p hp)).1 + have hsign : Equiv.Perm.sign + (p.1 * Equiv.swap (cI0 p.2 (hcross p hp)) + (cI1 p.2 (hcross p hp))) = - Equiv.Perm.sign p.1 := by + rw [Equiv.Perm.sign_mul, Equiv.Perm.sign_swap hne, mul_neg_one] + rw [hsign] + push_cast + ring + · -- the involution moves every point + intro p hp _ heq + have h1 : p.1 * Equiv.swap (cI0 p.2 (hcross p hp)) + (cI1 p.2 (hcross p hp)) = p.1 := congrArg Sigma.fst heq + have h2 : Equiv.swap (cI0 p.2 (hcross p hp)) + (cI1 p.2 (hcross p hp)) = 1 := by + have := congrArg (fun τ => p.1⁻¹ * τ) h1 + simpa [← mul_assoc] using this + have h3 := congrArg (fun τ => τ (cI0 p.2 (hcross p hp))) h2 + simp only [Equiv.swap_apply_left, Equiv.Perm.one_apply] at h3 + exact absurd h3 (ne_of_gt (cI1_spec p.2 (hcross p hp)).1) + · -- membership + intro p hp + rw [Finset.mem_filter] + constructor + · rw [Finset.mem_sigma] + exact ⟨Finset.mem_univ _, + swapFam_mem_famSet + ((Finset.mem_sigma.mp (Finset.mem_filter.mp hp).1).2) + (hcross p hp)⟩ + · exact swapFam_crossing p.2 (hcross p hp) + · -- involution property + intro p hp + exact swap_step_involutive p.1 p.2 (hcross p hp) _ + +/-- The constant family never crosses. -/ +private theorem const_fam_noncross {s m : ℕ} (S : Finset (Fin m)) : + ¬ Crossing (fun _ : Fin s => S) := by + rintro ⟨h, i, i', hlt, heq⟩ + rw [xcoord, xcoord] at heq + have hval : (i : ℕ) = (i' : ℕ) := by omega + exact absurd (Fin.ext hval) (ne_of_lt hlt) + +open scoped Classical in +/-- The noncrossing terms count a nonempty set with sign `+1`. -/ +private theorem sum_noncrossing_pos (s m : ℕ) (_ : s ≤ m) : + ∑ p ∈ ((Finset.univ : Finset (Equiv.Perm (Fin s))).sigma + (famSet s m)).filter (fun p => ¬ Crossing p.2), + ((Equiv.Perm.sign p.1 : ℤ) : ℂ) = + ((((Finset.univ : Finset (Equiv.Perm (Fin s))).sigma + (famSet s m)).filter (fun p => ¬ Crossing p.2)).card : ℂ) := by + rw [Finset.sum_congr rfl (fun p hp => ?_), Finset.sum_const, + nsmul_eq_mul, mul_one] + have hp' := Finset.mem_filter.mp hp + have hmem := (Finset.mem_sigma.mp hp'.1).2 + have h1 : p.1 = 1 := noncross_perm_eq_one hmem hp'.2 + rw [h1, Equiv.Perm.sign_one] + norm_num + +open scoped Classical in +/-- The constant family: every path uses the same `s`-subset. -/ +private theorem noncross_witness (s m : ℕ) (hm : s ≤ m) : + (⟨1, fun _ => (Finset.univ : Finset (Fin s)).map + (Fin.castLEEmb hm)⟩ : + (_ : Equiv.Perm (Fin s)) × (Fin s → Finset (Fin m))) ∈ + ((Finset.univ : Finset (Equiv.Perm (Fin s))).sigma + (famSet s m)).filter (fun p => ¬ Crossing p.2) := by + rw [Finset.mem_filter] + constructor + · rw [Finset.mem_sigma] + refine ⟨Finset.mem_univ _, ?_⟩ + rw [famSet, Fintype.mem_piFinset] + intro i + rw [Finset.mem_powersetCard] + refine ⟨Finset.subset_univ _, ?_⟩ + rw [Finset.card_map, Finset.card_univ, Fintype.card_fin, ddeg, + Equiv.Perm.one_apply] + omega + · exact const_fam_noncross _ + +/-! ## 9. Core nonvanishing -/ + +open scoped Classical in +/-- The determinant `det[C(m, s+j-i)]` is nonzero for `1 ≤ s ≤ m`. -/ +theorem det_binomial_upper_ne_zero (s m : ℕ) (_ : 1 ≤ s) (hm : s ≤ m) : + (Matrix.of fun i j : Fin s => + (Nat.choose m (s + (j : ℕ) - (i : ℕ)) : ℂ)).det ≠ 0 := by + rw [det_eq_signed_count s m, + ← Finset.sum_filter_add_sum_filter_not + ((Finset.univ : Finset (Equiv.Perm (Fin s))).sigma (famSet s m)) + (fun p => Crossing p.2), + sum_crossing_zero s m, zero_add, sum_noncrossing_pos s m hm] + exact_mod_cast Nat.cast_ne_zero.mpr + (Finset.card_ne_zero_of_mem (noncross_witness s m hm)) + +/-! ## 10. Glue -/ + +/-- The binomial Toeplitz determinant is nonzero, discharging the +hypothesis of the determinant development. -/ +theorem squareBinomialDetPos : SquareBinomialDetPos := by + intro s m hs hm + rw [diagramSchur_neg_eq_sign_mul_binomDet s m hs hm] + exact mul_ne_zero + (pow_ne_zero s (neg_ne_zero.mpr one_ne_zero)) + (det_binomial_upper_ne_zero s m hs hm) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/PieriChain.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/PieriChain.lean new file mode 100644 index 0000000000..14be82d871 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/PieriChain.lean @@ -0,0 +1,199 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantStrict +public import LeanPool.RegtsSevenster.RS.Common.RowLenChain + +/-! +# Pieri chain: positivity of alternant coefficients along diagram chains + +The staircase exponent vector `eVec`, and the positivity of the +coefficient of the target monomial in `p₁ʳ · a_{eVec λ}` when `μ` +extends `λ` by `r` cells. +-/ + +@[expose] public section + +namespace RS + +open Finset MvPolynomial Equiv + +/-- The staircase exponent vector of a diagram in `k` variables. -/ +noncomputable def eVec (nu : YoungDiagram) (k : ℕ) : Fin k → ℕ := + fun i => nu.rowLen i + ((k - 1) - (i : ℕ)) + +/-- The staircase exponent vector is strictly decreasing. -/ +theorem eVec_strict (nu : YoungDiagram) (k : ℕ) : + ∀ i j : Fin k, i < j → eVec nu k j < eVec nu k i := by + intro i j hij + unfold eVec + have hi := i.isLt + have hj := j.isLt + have hrl : nu.rowLen ↑j ≤ nu.rowLen ↑i := nu.rowLen_anti ↑i ↑j (le_of_lt hij) + omega + +open scoped Classical in +/-- Coefficients of a power of the first power sum against an +alternant are natural numbers: no cancellation into negatives. -/ +theorem coeff_pow_p1_altDet_natCast {k : ℕ} (r : ℕ) (w : Fin k → ℕ) + (hw : ∀ i j : Fin k, i < j → w j < w i) : + ∀ e : Fin k → ℕ, (∀ i j : Fin k, i < j → e j < e i) → + ∃ N : ℕ, ((∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ r * altDet e).coeff + (∑ i, Finsupp.single i (w i)) = N := by + induction r with + | zero => + intro e he + rw [pow_zero, one_mul, alternant_coeff_strict e w he hw] + split + · exact ⟨1, Nat.cast_one.symm⟩ + · exact ⟨0, Nat.cast_zero.symm⟩ + | succ r ih => + intro e he + rw [pow_succ, mul_assoc, p1_mul_altDet, Finset.mul_sum, + MvPolynomial.coeff_sum] + -- Each summand is a natural-number cast + have hterm : ∀ i₀ : Fin k, ∃ N : ℕ, + ((∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ r * + altDet (Function.update e i₀ (e i₀ + 1))).coeff (∑ j, Finsupp.single j (w j)) = ↑N := by + intro i₀ + by_cases hrep : ∃ a : Fin k, a ≠ i₀ ∧ e a = e i₀ + 1 + · -- Repeat: altDet vanishes + obtain ⟨a, hai, hae⟩ := hrep + have hzero : altDet (Function.update e i₀ (e i₀ + 1)) = 0 := + altDet_eq_zero_of_repeat _ hai (by + rw [Function.update_of_ne hai _ _, Function.update_self] + exact hae) + rw [hzero, mul_zero, AddMonoidAlgebra.coeff_zero] + exact ⟨0, Nat.cast_zero.symm⟩ + · -- No repeat: the bumped vector is still strictly decreasing + push Not at hrep + apply ih + intro a b hab + by_cases ha : a = i₀ + · subst ha + rw [Function.update_self, Function.update_of_ne (ne_of_gt hab) _ _] + exact Nat.lt_succ_of_lt (he _ b hab) + · rw [Function.update_of_ne ha _ _] + by_cases hb : b = i₀ + · subst hb + rw [Function.update_self] + have h1 := he a _ hab + have h2 := hrep a ha + omega + · rw [Function.update_of_ne hb _ _] + exact he a b hab + choose Nf hNf using hterm + exact ⟨Finset.univ.sum Nf, by + rw [Nat.cast_sum] + exact Finset.sum_congr rfl fun i _ => hNf i⟩ + +open scoped Classical in +/-- **Positivity along a chain**: when one diagram extends another +by `r` cells, the target monomial's coefficient is a positive +natural number. -/ +theorem coeff_chain_pos {k : ℕ} (lam mu : YoungDiagram) + (hle : lam ≤ mu) (r : ℕ) (hcard : mu.card = lam.card + r) + (hk : mu.colLen 0 ≤ k) : + ∃ N : ℕ, 0 < N ∧ + ((∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ r * + altDet (eVec lam k)).coeff (∑ i, Finsupp.single i (eVec mu k i)) = N := by + induction r generalizing lam with + | zero => + have heq : lam = mu := YoungDiagram.ext + (Finset.eq_of_subset_of_card_le + (YoungDiagram.cells_subset_iff.mpr hle) + (show mu.card ≤ lam.card from by omega)) + subst heq + rw [pow_zero, one_mul, + alternant_coeff_strict _ _ (eVec_strict _ _) (eVec_strict _ _), + ite_eq_left rfl] + exact ⟨1, by omega, Nat.cast_one.symm⟩ + | succ r ih => + -- Intermediate diagram + have hlt : lam.card < mu.card := by omega + obtain ⟨nu, hle_nu, hnu_mu, hcard_nu⟩ := + exists_intermediate_diagram hle hlt + -- Bump row + obtain ⟨i₀, hrowLen⟩ := rowLen_of_card_succ hle_nu hcard_nu + -- i₀ < k + have hi₀_mem : (i₀, 0) ∈ nu := by + rw [YoungDiagram.mem_iff_lt_rowLen] + have := hrowLen i₀; rw [ite_eq_left rfl] at this + have := rowLen_mono hle_nu i₀; omega + have hi₀k : i₀ < k := by + have h1 : i₀ < nu.colLen 0 := + YoungDiagram.mem_iff_lt_colLen.mp hi₀_mem + have h2 : nu.colLen 0 ≤ mu.colLen 0 := by + by_contra h + have : (mu.colLen 0, 0) ∈ nu := + YoungDiagram.mem_iff_lt_colLen.mpr (by omega) + have := YoungDiagram.mem_iff_lt_colLen.mp (hnu_mu this) + omega + omega + -- eVec nu k = update (eVec lam k) ⟨i₀, hi₀k⟩ ... + have heVec : eVec nu k = Function.update (eVec lam k) ⟨i₀, hi₀k⟩ + (eVec lam k ⟨i₀, hi₀k⟩ + 1) := by + funext ⟨i, hi⟩ + simp only [eVec, Function.update_apply, Fin.mk.injEq] + have hbump := hrowLen i + split_ifs at hbump ⊢ with heq + · subst heq; omega + · omega + -- Expand via Pieri + rw [pow_succ, mul_assoc, p1_mul_altDet, Finset.mul_sum, + MvPolynomial.coeff_sum] + -- Each summand is a ℕ-cast + have hterm : ∀ i : Fin k, ∃ N : ℕ, + ((∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ r * + altDet (Function.update (eVec lam k) i + (eVec lam k i + 1))).coeff (∑ j, Finsupp.single j (eVec mu k j)) = ↑N := by + intro i + by_cases hrep : ∃ a : Fin k, a ≠ i ∧ + eVec lam k a = eVec lam k i + 1 + · obtain ⟨a, hai, hae⟩ := hrep + rw [altDet_eq_zero_of_repeat _ hai (by + rw [Function.update_of_ne hai _ _, Function.update_self] + exact hae), + mul_zero, AddMonoidAlgebra.coeff_zero] + exact ⟨0, Nat.cast_zero.symm⟩ + · push Not at hrep + exact coeff_pow_p1_altDet_natCast r (eVec mu k) + (eVec_strict mu k) _ (by + intro a b hab + by_cases ha : a = i + · subst ha + rw [Function.update_self, + Function.update_of_ne (ne_of_gt hab) _ _] + exact Nat.lt_succ_of_lt (eVec_strict lam k _ _ hab) + · rw [Function.update_of_ne ha _ _] + by_cases hb : b = i + · subst hb + rw [Function.update_self] + have h1 := eVec_strict lam k a _ hab + have h2 := hrep a ha + omega + · rw [Function.update_of_ne hb _ _] + exact eVec_strict lam k a b hab) + choose Nf hNf using hterm + -- The i₀-th term is positive via IH + have hNf_pos : 0 < Nf ⟨i₀, hi₀k⟩ := by + obtain ⟨N₀, hN₀_pos, hN₀_eq⟩ := ih nu hnu_mu (by omega) + have h1 := hNf ⟨i₀, hi₀k⟩ + rw [← heVec] at h1 + rw [hN₀_eq] at h1 + rw [Nat.cast_inj] at h1 + omega + -- Combine + refine ⟨∑ i : Fin k, Nf i, ?_, ?_⟩ + · exact lt_of_lt_of_le hNf_pos + (Finset.single_le_sum (fun i _ => Nat.zero_le (Nf i)) + (Finset.mem_univ (⟨i₀, hi₀k⟩ : Fin k))) + · rw [Nat.cast_sum] + exact Finset.sum_congr rfl fun i _ => hNf i + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/PowCount.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/PowCount.lean new file mode 100644 index 0000000000..fdd04e2abb --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/PowCount.lean @@ -0,0 +1,79 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HProdCoeff + +/-! +# Coefficient of a power of p₁ + +The coefficient of a monomial `w` in `(∑ l, X l) ^ |T|` counts the +number of functions `T → Fin k` whose fibre sizes match `w`. +-/ + +@[expose] public section + +namespace RS + +open Finset MvPolynomial + +open scoped Classical in +/-- A coefficient of a power of the first power sum counts the +functions with the prescribed fibre sizes. -/ +theorem coeff_p1_pow {k : ℕ} (T : Type) [Fintype T] (w : Fin k →₀ ℕ) : + ((∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ Fintype.card T).coeff w = + ((Finset.univ.filter (fun t : T → Fin k => + ∀ a : Fin k, + (Finset.univ.filter (fun i : T => t i = a)).card = w a)).card : ℂ) := by + -- Step 1: Rewrite the power as a product over T, then expand + -- (∑ l, X l) ^ card T = ∏ _ : T, (∑ l, X l) = ∑ t : T → Fin k, ∏ i, X (t i) + rw [show Fintype.card T = Finset.card (Finset.univ : Finset T) from + Finset.card_univ.symm] + rw [← Finset.prod_const] + rw [Fintype.prod_sum + (fun (_ : T) (j : Fin k) => (X j : MvPolynomial (Fin k) ℂ))] + -- Step 2: Each ∏ i, X (t i) is a monomial + rw [Finset.sum_congr rfl + (fun (t : T → Fin k) (_ : t ∈ Finset.univ) => + show (∏ i : T, (X (t i) : MvPolynomial (Fin k) ℂ)) = + monomial (∑ i : T, Finsupp.single (t i) 1) (1 : ℂ) from by + rw [Finset.prod_congr rfl (fun i (_ : i ∈ Finset.univ) => + show (X (t i) : MvPolynomial (Fin k) ℂ) = + monomial (Finsupp.single (t i) 1) (1 : ℂ) from rfl)] + rw [← monomial_sum_prod] + rw [Finset.prod_const_one])] + -- Step 3: Extract coefficients + rw [MvPolynomial.coeff_sum] + simp only [coeff_monomial] + -- Step 4: Rewrite condition from Finsupp equality to pointwise filter-card + have cond_iff : ∀ t : T → Fin k, + ((∑ i : T, Finsupp.single (t i) 1) = w) ↔ + (∀ a : Fin k, + (Finset.univ.filter (fun i : T => t i = a)).card = w a) := by + intro t + rw [DFunLike.ext_iff] + refine forall_congr' fun a => ?_ + rw [Finsupp.finsetSum_apply] + simp only [Finsupp.single_apply] + constructor + · intro h + rw [← h] + simp [Finset.sum_boole] + · intro h + rw [← h] + simp [Finset.sum_boole] + rw [Finset.sum_congr rfl + (fun (t : T → Fin k) (_ : t ∈ Finset.univ) => + show (if (∑ i : T, Finsupp.single (t i) 1) = w then (1 : ℂ) else 0) = + (if (∀ a : Fin k, + (Finset.univ.filter (fun i : T => t i = a)).card = w a) + then (1 : ℂ) else 0) from + if_congr (cond_iff t) rfl rfl)] + -- Step 5: Sum of indicators = cardinality of filter + rw [Finset.sum_boole] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/PowerSums.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/PowerSums.lean new file mode 100644 index 0000000000..c1eb4ea523 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/PowerSums.lean @@ -0,0 +1,75 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Power sums and the determinant Schur specialization + +Given a sequence `t : ℕ → ℂ` of prospective power sums, this module +defines the complete homogeneous sequence `newtonH t` by the Newton +recursion `(n+1) · h (n+1) = ∑_{i ≤ n} t (i+1) · h (n−i)`, its +integer-indexed extension `newtonHZ` (zero in negative degrees), and +the Schur specialization + + `schurDet t rows = det (newtonHZ t (rows i + j − i))`, + +the Jacobi–Trudi determinant read as a *definition*. All Schur +values in this development are these determinants; the link to the +symmetric-group characters is the `frobenius` field of +`SchurPackage` in `Interfaces/SchurPackage.lean`. +-/ + +@[expose] public section + +namespace RS + +/-- The complete homogeneous sequence attached to a sequence of +power sums, via the Newton recursion +`(n+1) · h (n+1) = ∑_{i ≤ n} t (i+1) · h (n−i)`; `h 0 = 1`. -/ +noncomputable def newtonH (t : ℕ → ℂ) : ℕ → ℂ + | 0 => 1 + | n + 1 => + ((n : ℂ) + 1)⁻¹ * + ∑ i ∈ Finset.range (n + 1), t (i + 1) * newtonH t (n - i) + decreasing_by exact Nat.lt_succ_of_le (Nat.sub_le n i) + +/-- Integer-indexed extension of `newtonH`, vanishing in negative +degrees — the form entering the Jacobi–Trudi determinant. -/ +noncomputable def newtonHZ (t : ℕ → ℂ) (n : ℤ) : ℂ := + if 0 ≤ n then newtonH t n.toNat else 0 + +/-- The Schur specialization of a row-length list `rows`, defined as +the Jacobi–Trudi determinant `det (h_{rows i − i + j})_{i,j}`. -/ +noncomputable def schurDet (t : ℕ → ℂ) (rows : List ℕ) : ℂ := + Matrix.det <| Matrix.of fun i j : Fin rows.length => + newtonHZ t ((rows.get i : ℤ) + (j : ℤ) - (i : ℤ)) + +/-- The Schur specialization of a Young diagram: `schurDet` on its +row-length list. -/ +noncomputable def diagramSchur (μ : YoungDiagram) (t : ℕ → ℂ) : ℂ := + schurDet t μ.rowLens + +/-- The complete homogeneous sequence starts at `1`. -/ +@[simp] +theorem newtonH_zero (t : ℕ → ℂ) : newtonH t 0 = 1 := by + simp [newtonH] + +/-- Its integer extension agrees in non-negative degrees. -/ +@[simp] +theorem newtonHZ_natCast (t : ℕ → ℂ) (n : ℕ) : + newtonHZ t (n : ℤ) = newtonH t n := by + simp [newtonHZ] + +/-- And vanishes in negative ones. -/ +@[simp] +theorem newtonHZ_neg (t : ℕ → ℂ) (n : ℤ) (hn : n < 0) : + newtonHZ t n = 0 := by + simp [newtonHZ, not_le.mpr hn] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/RationalityFromRecurrence.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/RationalityFromRecurrence.lean new file mode 100644 index 0000000000..d63a326ea6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/RationalityFromRecurrence.lean @@ -0,0 +1,516 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums + +/-! +# Rationality from recurrence + +If the complete homogeneous sequence `newtonH t` satisfies a linear +recurrence with constant coefficients from some index onward, then `t` +decomposes as a difference of power sums of two disjoint multisets of +nonzero complex numbers (Lemma A.9 of the accompanying paper). + +The proof passes through the generating series `H = newtonHSeries t`, +builds a polynomial `Q` from the recurrence whose product with `H` +truncates to a polynomial `P`, divides by the GCD to get a coprime +pair, factors both over ℂ, and reads off the power-sum identity +from the logarithmic derivative of `H = P₀/Q₀`. +-/ + +@[expose] public section + +namespace RS + +-- Only scoped notation is opened globally (`ℂ[X]` and `ℂ⟦X⟧`); +-- full `open PowerSeries` would break `ℂ[X]` notation via a GetElem +-- conflict, and `open Polynomial in private theorem` does not parse. +open scoped Polynomial PowerSeries + +/-- Shorthand for the linear factor `(1 - C γ * X)` as a polynomial. -/ +private noncomputable abbrev oneSub (γ : ℂ) : ℂ[X] := + (1 : ℂ[X]) - Polynomial.C γ * Polynomial.X + +/-! ### Tail-sum series -/ + +/-- The tail-sum power series attached to a multiset of complex numbers: +coefficient `m` is `(M.map (· ^ m)).sum` for `m ≥ 1`, and `0` for `m = 0`. -/ +noncomputable def tailSumSeries (M : Multiset ℂ) : ℂ⟦X⟧ := + PowerSeries.mk fun m => if m = 0 then 0 else (M.map (· ^ m)).sum + +@[simp] +private theorem tailSumSeries_zero : tailSumSeries (0 : Multiset ℂ) = 0 := by + ext m; simp [tailSumSeries, PowerSeries.coeff_mk] + +private theorem tailSumSeries_cons (γ : ℂ) (M : Multiset ℂ) : + tailSumSeries (γ ::ₘ M) = + tailSumSeries M + + PowerSeries.mk (fun m => if m = 0 then 0 else γ ^ m) := by + ext m + simp only [tailSumSeries, map_add, PowerSeries.coeff_mk] + split + · simp + · simp [Multiset.map_cons, Multiset.sum_cons, add_comm] + +/-! ### Geometric tail identity -/ + +/-- The geometric tail identity: +`↑(oneSub γ) * mk(γ^m for m ≥ 1) = ↑(C γ * X)` in `ℂ⟦X⟧`. -/ +private theorem one_sub_mul_geometric_tail (γ : ℂ) : + (↑(oneSub γ) : ℂ⟦X⟧) * + PowerSeries.mk (fun m => if m = 0 then 0 else γ ^ m) = + ↑(Polynomial.C γ * Polynomial.X : ℂ[X]) := by + have hcoe : (↑(oneSub γ) : ℂ⟦X⟧) = 1 - PowerSeries.C γ * PowerSeries.X := by + simp [oneSub, Polynomial.coe_sub, Polynomial.coe_one, Polynomial.coe_mul, + Polynomial.coe_C, Polynomial.coe_X] + have hdecomp : PowerSeries.mk (fun m => if m = 0 then 0 else γ ^ m) = + PowerSeries.mk (fun m => γ ^ m) - 1 := by + ext m; simp only [map_sub, PowerSeries.coeff_mk, PowerSeries.coeff_one] + cases m with + | zero => simp + | succ n => simp + have hRHS : (↑(Polynomial.C γ * Polynomial.X : ℂ[X]) : ℂ⟦X⟧) = + PowerSeries.C γ * PowerSeries.X := by + simp [Polynomial.coe_mul, Polynomial.coe_C, Polynomial.coe_X] + rw [hcoe, hdecomp, hRHS] + suffices h : (1 - PowerSeries.C γ * PowerSeries.X) * + PowerSeries.mk (fun m => γ ^ m) = 1 by + have : (1 - PowerSeries.C γ * PowerSeries.X) * + (PowerSeries.mk (fun m => γ ^ m) - 1) = + (1 - PowerSeries.C γ * PowerSeries.X) * + PowerSeries.mk (fun m => γ ^ m) - + (1 - PowerSeries.C γ * PowerSeries.X) := by ring + rw [this, h]; ring + rw [sub_mul, one_mul] + ext n + simp only [map_sub, PowerSeries.coeff_mk, PowerSeries.coeff_one] + cases n with + | zero => + simp [mul_assoc, PowerSeries.coeff_C_mul, PowerSeries.coeff_zero_X_mul] + | succ n => + simp only [Nat.succ_ne_zero, ↓reduceIte, mul_assoc, PowerSeries.coeff_C_mul, + PowerSeries.coeff_succ_X_mul, PowerSeries.coeff_mk, pow_succ] + ring + +/-! ### Log-derivative identity for products -/ + +/-- For `F_M := (M.map oneSub).prod`, +`↑X * ↑(derivative F_M) = -↑F_M * tailSumSeries M` in `ℂ⟦X⟧`. -/ +private theorem X_mul_coe_derivative_prod (M : Multiset ℂ) : + (↑(Polynomial.X : ℂ[X]) : ℂ⟦X⟧) * + (↑(Polynomial.derivative ((M.map oneSub).prod)) : ℂ⟦X⟧) = + -(↑((M.map oneSub).prod) : ℂ⟦X⟧) * tailSumSeries M := by + induction M using Multiset.induction with + | empty => + have h0 : tailSumSeries (0 : Multiset ℂ) = 0 := tailSumSeries_zero + simp [Multiset.map_zero, Multiset.prod_zero, Polynomial.derivative_one, + Polynomial.coe_zero, h0] + | cons γ M' ih => + simp only [Multiset.map_cons, Multiset.prod_cons] + rw [Polynomial.derivative_mul] + have hder : Polynomial.derivative (oneSub γ) = -Polynomial.C γ := by + simp [oneSub, Polynomial.derivative_sub, Polynomial.derivative_one, + Polynomial.derivative_X] + rw [hder] + simp only [Polynomial.coe_add, Polynomial.coe_mul, Polynomial.coe_neg] + rw [mul_add] + have hrearr : (↑(Polynomial.X : ℂ[X]) : ℂ⟦X⟧) * ((↑(oneSub γ) : ℂ⟦X⟧) * + (↑(Polynomial.derivative ((Multiset.map oneSub M').prod)) : ℂ⟦X⟧)) = + (↑(oneSub γ) : ℂ⟦X⟧) * ((↑(Polynomial.X : ℂ[X]) : ℂ⟦X⟧) * + (↑(Polynomial.derivative ((Multiset.map oneSub M').prod)) : + ℂ⟦X⟧)) := by ring + rw [hrearr, ih, tailSumSeries_cons] + have h_geom := one_sub_mul_geometric_tail γ + rw [Polynomial.coe_mul] at h_geom + linear_combination (↑(Multiset.map oneSub M').prod : ℂ⟦X⟧) * h_geom + +/-! ### Factorisation into `(1 - γX)` factors -/ + +section Factorisation +open Polynomial + +/-- Over ℂ, a nonzero polynomial `F` with `F.coeff 0 ≠ 0` factors as +`F = C (F.coeff 0) * (M.map oneSub).prod` where +`M = F.roots.map (· ⁻¹)`, with `M.card = F.natDegree` and every +element of `M` nonzero. -/ +private theorem eq_prod_one_sub_of_coeff_zero_ne_zero (F : ℂ[X]) (_hF : F ≠ 0) + (hF0 : F.coeff 0 ≠ 0) : + F = Polynomial.C (F.coeff 0) * + ((F.roots.map (· ⁻¹)).map oneSub).prod ∧ + (F.roots.map (· ⁻¹)).card = F.natDegree ∧ + ∀ x ∈ F.roots.map (· ⁻¹), x ≠ (0 : ℂ) := by + have hno_zero : ∀ r ∈ F.roots, r ≠ (0 : ℂ) := by + intro r hr heq + subst heq + exact hF0 ((coeff_zero_eq_eval_zero F).trans (isRoot_of_mem_roots hr)) + have hsplit := (IsAlgClosed.splits F).eq_prod_roots + have factor_eq : ∀ r ∈ F.roots, + (Polynomial.X : ℂ[X]) - Polynomial.C r = + -Polynomial.C r * oneSub (r⁻¹) := by + intro r hr + have hr0 := hno_zero r hr + have key : (Polynomial.C r : ℂ[X]) * (Polynomial.C r⁻¹ * Polynomial.X) = + Polynomial.X := by + rw [← mul_assoc, ← Polynomial.C_mul, mul_inv_cancel₀ hr0, map_one, + one_mul] + unfold oneSub + linear_combination -key + have prod_transform : + (F.roots.map (fun r => Polynomial.X - Polynomial.C r)).prod = + (F.roots.map (fun r => -(Polynomial.C r : ℂ[X]))).prod * + ((F.roots.map (· ⁻¹)).map oneSub).prod := by + conv_lhs => + rw [show F.roots.map (fun r => Polynomial.X - Polynomial.C r) = + F.roots.map (fun r => -(Polynomial.C r : ℂ[X]) * oneSub (r⁻¹)) from + Multiset.map_congr rfl factor_eq] + rw [Multiset.prod_map_mul] + congr 1 + simp only [Multiset.map_map, Function.comp_def] + have coeff_prod : + Polynomial.C F.leadingCoeff * + (F.roots.map (fun r => -(Polynomial.C r : ℂ[X]))).prod = + Polynomial.C (F.coeff 0) := by + have h1 : (F.roots.map (fun r => -(Polynomial.C r : ℂ[X]))).prod = + Polynomial.C ((F.roots.map (- ·)).prod) := by + conv_lhs => + rw [show F.roots.map (fun r => -(Polynomial.C r : ℂ[X])) = + (F.roots.map (- ·)).map (Polynomial.C : ℂ →+* ℂ[X]) from by + simp only [Multiset.map_map, Function.comp_def, Polynomial.C_neg]] + exact (map_multiset_prod (Polynomial.C : ℂ →+* ℂ[X]) _).symm + rw [h1, ← Polynomial.C_mul] + apply congr_arg + rw [coeff_zero_eq_eval_zero, (IsAlgClosed.splits F).eval_eq_prod_roots 0] + congr 1; congr 1 + exact Multiset.map_congr rfl fun (r : ℂ) _ => (zero_sub r).symm + refine ⟨?_, ?_, ?_⟩ + · calc F + = Polynomial.C F.leadingCoeff * + (F.roots.map (fun r => Polynomial.X - Polynomial.C r)).prod := + hsplit + _ = Polynomial.C F.leadingCoeff * + ((F.roots.map (fun r => -(Polynomial.C r : ℂ[X]))).prod * + ((F.roots.map (· ⁻¹)).map oneSub).prod) := by + rw [prod_transform] + _ = (Polynomial.C F.leadingCoeff * + (F.roots.map (fun r => -(Polynomial.C r : ℂ[X]))).prod) * + ((F.roots.map (· ⁻¹)).map oneSub).prod := by + rw [mul_assoc] + _ = Polynomial.C (F.coeff 0) * + ((F.roots.map (· ⁻¹)).map oneSub).prod := by + rw [coeff_prod] + · rw [Multiset.card_map]; exact IsAlgClosed.card_roots_eq_natDegree + · intro x hx + obtain ⟨r, hr, rfl⟩ := Multiset.mem_map.mp hx + exact inv_ne_zero (hno_zero r hr) + +end Factorisation + +/-! ### Coprime pair from recurrence + +The construction is split across two lemmas to keep proof terms small +enough for the kernel's `whnf` check. +-/ + +/-- Build the recurrence polynomial `Q` and its truncated product `P` +with the Newton generating series. -/ +theorem truncated_product_from_recurrence {t : ℕ → ℂ} {a b : ℕ} + (c : Fin (a + 1) → ℂ) (hc : c ≠ 0) + (hrec : ∀ ρ : ℤ, (b : ℤ) - a ≤ ρ → + ∑ k : Fin (a + 1), c k * newtonHZ t (ρ + 1 + (k : ℤ)) = 0) : + ∃ Q P : ℂ[X], + Q ≠ 0 ∧ P ≠ 0 ∧ + (↑Q : ℂ⟦X⟧) * newtonHSeries t = ↑P ∧ + Q.natDegree ≤ a ∧ P.natDegree ≤ b := by + classical + let Q : ℂ[X] := ∑ i ∈ Finset.range (a + 1), + Polynomial.C (c ⟨a - i, by omega⟩) * Polynomial.X ^ i + have hQ_def : Q = ∑ i ∈ Finset.range (a + 1), + Polynomial.C (c ⟨a - i, by omega⟩) * Polynomial.X ^ i := rfl + have hQ_ne : Q ≠ 0 := by + intro hQ; apply hc; ext ⟨k, hk⟩ + have h : Q.coeff (a - k) = 0 := by rw [hQ]; simp + simp only [hQ_def, Polynomial.finsetSum_coeff, Polynomial.coeff_C_mul, + Polynomial.coeff_X_pow] at h + rw [Finset.sum_eq_single_of_mem (a - k) + (Finset.mem_range.mpr (by omega))] at h + · simpa [show a - (a - k) = k from by omega] using h + · intro j _ hji + have hne : ¬(a - k = j) := fun h => hji h.symm + simp [hne] + let H := newtonHSeries t + have hH_def : H = newtonHSeries t := rfl + have hQH_ev : ∀ n, b + 1 ≤ n → PowerSeries.coeff n ((↑Q : ℂ⟦X⟧) * H) = 0 := by + intro n hn + rw [PowerSeries.coeff_mul, Finset.Nat.sum_antidiagonal_eq_sum_range_succ_mk] + simp only [Polynomial.coeff_coe, hH_def, newtonHSeries, + PowerSeries.coeff_mk] + have hQ_van : ∀ k, ¬(k < a + 1) → Q.coeff k = 0 := by + intro k hk + simp only [hQ_def, Polynomial.finsetSum_coeff, Polynomial.coeff_C_mul, + Polynomial.coeff_X_pow] + apply Finset.sum_eq_zero + intro j hj; rw [Finset.mem_range] at hj + simp [show k ≠ j by omega] + have hQ_val : ∀ k, k < a + 1 → Q.coeff k = c ⟨a - k, by omega⟩ := by + intro k hk + simp only [hQ_def, Polynomial.finsetSum_coeff, Polynomial.coeff_C_mul, + Polynomial.coeff_X_pow] + rw [Finset.sum_eq_single_of_mem k (Finset.mem_range.mpr hk)] + · simp + · intro j _ hji; simp [Ne.symm hji] + have hnat (k : ℕ) (hk : k < n + 1) : + newtonH t (n - k) = newtonHZ t ((n : ℤ) - k) := by + rw [show (n : ℤ) - k = ((n - k : ℕ) : ℤ) by omega, + newtonHZ_natCast] + have hstep1 : + ∑ k ∈ Finset.range (n + 1), Q.coeff k * newtonH t (n - k) = + ∑ k ∈ Finset.range (a + 1), + c ⟨a - k, by omega⟩ * newtonHZ t ((n : ℤ) - k) := by + calc + _ = ∑ k ∈ Finset.range (n + 1), + Q.coeff k * newtonHZ t ((n : ℤ) - k) := by + apply Finset.sum_congr rfl + intro k hk + rw [hnat k (Finset.mem_range.mp hk)] + _ = ∑ k ∈ Finset.range (a + 1), + Q.coeff k * newtonHZ t ((n : ℤ) - k) := by + by_cases han : a ≤ n + · symm + apply Finset.sum_subset (Finset.range_mono (by omega)) + intro k _ hk + rw [hQ_van k (by simpa only [Finset.mem_range] using hk), + zero_mul] + · apply Finset.sum_subset (Finset.range_mono (by omega)) + intro k _ hk + rw [newtonHZ_neg t _ (by + simp only [Finset.mem_range] at hk + omega), mul_zero] + _ = _ := by + apply Finset.sum_congr rfl + intro k hk + rw [hQ_val k (Finset.mem_range.mp hk)] + rw [hstep1] + let f : ℕ → ℂ := fun j => + if h : j < a + 1 then + c ⟨j, h⟩ * newtonHZ t ((n : ℤ) - a + j) else 0 + suffices hsuff : ∑ k ∈ Finset.range (a + 1), + f ((a + 1) - 1 - k) = 0 by + convert hsuff using 1 + apply Finset.sum_congr rfl + intro k hk + rw [Finset.mem_range] at hk + change c ⟨a - k, _⟩ * newtonHZ t ((n : ℤ) - k) = + if h : a - k < a + 1 then + c ⟨a - k, h⟩ * newtonHZ t ((n : ℤ) - a + (a - k : ℕ)) else 0 + rw [dite_eq_left (show a - k < a + 1 by omega)] + congr 2 + omega + rw [Finset.sum_range_reflect f (a + 1), + ← Fin.sum_univ_eq_sum_range f (a + 1)] + have hf_eq : ∑ i : Fin (a + 1), f ↑i = + ∑ i : Fin (a + 1), + c i * newtonHZ t (((n : ℤ) - a - 1) + 1 + (i : ℤ)) := by + apply Finset.sum_congr rfl + intro i _ + dsimp only [f] + rw [dite_eq_left i.isLt] + congr 2 + omega + rw [hf_eq] + exact hrec ((n : ℤ) - a - 1) (by omega) + let P := PowerSeries.trunc (b + 1) ((↑Q : ℂ⟦X⟧) * H) + have hQH_eq : (↑Q : ℂ⟦X⟧) * H = ↑P := + powerSeries_eq_coe_trunc_of_eventually_zero _ (b + 1) hQH_ev + have hH_ne : H ≠ 0 := by + intro hH + have : PowerSeries.coeff 0 H = 0 := by rw [hH]; simp + simp [hH_def, newtonHSeries, PowerSeries.coeff_mk] at this + have hP_ne : P ≠ 0 := by + intro hP + have : (↑Q : ℂ⟦X⟧) * H ≠ 0 := + mul_ne_zero (Polynomial.coe_eq_zero_iff.not.mpr hQ_ne) hH_ne + rw [hQH_eq, hP, Polynomial.coe_zero] at this + exact this rfl + have hQ_deg : Q.natDegree ≤ a := by + apply Polynomial.natDegree_sum_le_of_forall_le + intro i hi + calc (Polynomial.C (c ⟨a - i, _⟩) * Polynomial.X ^ i).natDegree + ≤ i := Polynomial.natDegree_C_mul_X_pow_le _ _ + _ ≤ a := by rw [Finset.mem_range] at hi; omega + have hP_deg : P.natDegree ≤ b := by + change (PowerSeries.trunc (b + 1) ((↑Q : ℂ⟦X⟧) * H)).natDegree ≤ b + have := PowerSeries.natDegree_trunc_lt ((↑Q : ℂ⟦X⟧) * H) b + omega + exact ⟨Q, P, hQ_ne, hP_ne, hQH_eq, hQ_deg, hP_deg⟩ + +/-- A coprime pair `(Q₀, P₀)` with `↑Q₀ * H = ↑P₀` must have nonzero +constant coefficients, since `X` would otherwise divide a coprime pair. -/ +private theorem nonzero_coeff_of_coprime_product {t : ℕ → ℂ} + (Q₀ P₀ : ℂ[X]) (_hQ0_ne : Q₀ ≠ 0) (_hP0_ne : P₀ ≠ 0) + (hcop : IsCoprime P₀ Q₀) + (hQ0H : (↑Q₀ : ℂ⟦X⟧) * newtonHSeries t = ↑P₀) : + Q₀.coeff 0 ≠ 0 ∧ P₀.coeff 0 ≠ 0 := by + have hQ0_coeff0 : Q₀.coeff 0 ≠ 0 := by + intro hQ0c + have hP0c : P₀.coeff 0 = 0 := by + have := congr_arg PowerSeries.constantCoeff hQ0H + simp only [map_mul, Polynomial.constantCoeff_coe] at this + rw [hQ0c, zero_mul] at this + exact this.symm + exact Polynomial.not_isUnit_X + (hcop.isUnit_of_dvd' (Polynomial.X_dvd_iff.mpr hP0c) + (Polynomial.X_dvd_iff.mpr hQ0c)) + exact ⟨hQ0_coeff0, by + intro hP0c + have := congr_arg PowerSeries.constantCoeff hQ0H + simp only [map_mul, Polynomial.constantCoeff_coe] at this + rw [hP0c] at this + rcases mul_eq_zero.mp this with h | h + · exact hQ0_coeff0 h + · simp [newtonHSeries, ← PowerSeries.coeff_zero_eq_constantCoeff_apply, + PowerSeries.coeff_mk] at h⟩ + +/-- From two nonzero polynomials with `↑Q * H = ↑P`, produce a coprime +pair `(Q₀, P₀)` with `↑Q₀ * H = ↑P₀` via division by the GCD, +with nonzero constant coefficients and the original degree bounds. -/ +theorem coprime_pair_from_product {t : ℕ → ℂ} + (Q P : ℂ[X]) (hQ_ne : Q ≠ 0) (hP_ne : P ≠ 0) + (hQH : (↑Q : ℂ⟦X⟧) * newtonHSeries t = ↑P) : + ∃ Q₀ P₀ : ℂ[X], + Q₀ ≠ 0 ∧ P₀ ≠ 0 ∧ IsCoprime P₀ Q₀ ∧ + (↑Q₀ : ℂ⟦X⟧) * newtonHSeries t = ↑P₀ ∧ + Q₀.coeff 0 ≠ 0 ∧ P₀.coeff 0 ≠ 0 ∧ + Q₀.natDegree ≤ Q.natDegree ∧ P₀.natDegree ≤ P.natDegree := by + -- The Euclidean-domain GCD is not a typeclass `GCDMonoid` instance for + -- `ℂ[X]` by default; introduce it explicitly so the coprimality API + -- (`right_div_gcd_ne_zero`, `isCoprime_div_gcd_div_gcd`, etc.) resolves. + let := EuclideanDomain.gcdMonoid ℂ[X] + have hd_ne : EuclideanDomain.gcd P Q ≠ 0 := gcd_ne_zero_of_right hQ_ne + have hd_coe_ne : (↑(EuclideanDomain.gcd P Q) : ℂ⟦X⟧) ≠ 0 := + Polynomial.coe_eq_zero_iff.not.mpr hd_ne + have hQ_eq : Q = EuclideanDomain.gcd P Q * (Q / EuclideanDomain.gcd P Q) := + (EuclideanDomain.mul_div_cancel' hd_ne (gcd_dvd_right P Q)).symm + have hP_eq : P = EuclideanDomain.gcd P Q * (P / EuclideanDomain.gcd P Q) := + (EuclideanDomain.mul_div_cancel' hd_ne (gcd_dvd_left P Q)).symm + have hid : (↑(Q / EuclideanDomain.gcd P Q) : ℂ⟦X⟧) * newtonHSeries t = + ↑(P / EuclideanDomain.gcd P Q) := by + have h : (↑(EuclideanDomain.gcd P Q) : ℂ⟦X⟧) * + ((↑(Q / EuclideanDomain.gcd P Q) : ℂ⟦X⟧) * newtonHSeries t - + ↑(P / EuclideanDomain.gcd P Q)) = 0 := by + rw [mul_sub, ← mul_assoc, ← Polynomial.coe_mul, ← hQ_eq, + ← Polynomial.coe_mul, ← hP_eq, hQH, sub_self] + exact sub_eq_zero.mp ((mul_eq_zero.mp h).resolve_left hd_coe_ne) + obtain ⟨hc0Q, hc0P⟩ := nonzero_coeff_of_coprime_product _ _ + (right_div_gcd_ne_zero hQ_ne) (left_div_gcd_ne_zero hP_ne) + (isCoprime_div_gcd_div_gcd hQ_ne) hid + exact ⟨Q / EuclideanDomain.gcd P Q, P / EuclideanDomain.gcd P Q, + right_div_gcd_ne_zero hQ_ne, left_div_gcd_ne_zero hP_ne, + isCoprime_div_gcd_div_gcd hQ_ne, hid, hc0Q, hc0P, + Polynomial.natDegree_le_of_dvd ⟨_, by rw [mul_comm]; exact hQ_eq⟩ hQ_ne, + Polynomial.natDegree_le_of_dvd ⟨_, by rw [mul_comm]; exact hP_eq⟩ hP_ne⟩ + +/-! ### Main theorem -/ + +/-- **Lemma A.9 of the accompanying paper.** +If the complete homogeneous sequence `newtonH t` satisfies a nontrivial +linear recurrence with constant coefficients from some index onward, +then `t` decomposes as a difference of power sums of two disjoint +multisets of nonzero complex numbers. -/ +theorem superPowerSums_of_recurrence {t : ℕ → ℂ} {a b : ℕ} + (c : Fin (a + 1) → ℂ) (hc : c ≠ 0) + (hrec : ∀ ρ : ℤ, (b : ℤ) - a ≤ ρ → + ∑ k : Fin (a + 1), c k * newtonHZ t (ρ + 1 + (k : ℤ)) = 0) : + ∃ α β : Multiset ℂ, + α.card ≤ a ∧ β.card ≤ b ∧ + (∀ x ∈ α, x ≠ 0) ∧ (∀ x ∈ β, x ≠ 0) ∧ (∀ x ∈ α, x ∉ β) ∧ + ∀ m : ℕ, 1 ≤ m → + t m = (α.map (· ^ m)).sum - (β.map (· ^ m)).sum := by + -- ═══════ STAGE A: Get the truncated pair ═══════ + obtain ⟨Q, P, hQ_ne, hP_ne, hQH, hQ_deg, hP_deg⟩ := + truncated_product_from_recurrence c hc hrec + -- ═══════ STAGE B: Get the coprime pair ═══════ + obtain ⟨Q₀, P₀, hQ0_ne, hP0_ne, hcop, hQ0H, hQ0_coeff0, hP0_coeff0, + hQ0_deg_le, hP0_deg_le⟩ := coprime_pair_from_product Q P hQ_ne hP_ne hQH + -- ═══════ STAGE C: Factor P₀ and Q₀ ═══════ + obtain ⟨hQ0_fac, hQ0_card, hQ0_nz⟩ := + eq_prod_one_sub_of_coeff_zero_ne_zero Q₀ hQ0_ne hQ0_coeff0 + obtain ⟨hP0_fac, hP0_card, hP0_nz⟩ := + eq_prod_one_sub_of_coeff_zero_ne_zero P₀ hP0_ne hP0_coeff0 + -- ═══════ STAGE D: Define multisets α and β ═══════ + set α := Q₀.roots.map (· ⁻¹) with hα_def + set β := P₀.roots.map (· ⁻¹) with hβ_def + refine ⟨α, β, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · rw [hQ0_card]; exact hQ0_deg_le.trans hQ_deg + · rw [hP0_card]; exact hP0_deg_le.trans hP_deg + · exact hQ0_nz + · exact hP0_nz + -- ═══════ STAGE E: Disjointness ═══════ + · intro x hx hxβ + rw [hα_def, Multiset.mem_map] at hx + rw [hβ_def, Multiset.mem_map] at hxβ + obtain ⟨r, hr, rfl⟩ := hx + obtain ⟨s, hs, hrs⟩ := hxβ + have hrs' : r = s := inv_injective hrs.symm + subst hrs' + obtain ⟨u, v, huv⟩ := hcop + have h1 : P₀.eval r = 0 := Polynomial.isRoot_of_mem_roots hs + have h2 : Q₀.eval r = 0 := Polynomial.isRoot_of_mem_roots hr + apply_fun Polynomial.eval r at huv + simp [h1, h2] at huv + -- ═══════ STAGE F: Power-sum identity ═══════ + · intro m hm + -- Log-derivative identities for the C-scaled products + have hXdQ : (↑(Polynomial.X : ℂ[X]) : ℂ⟦X⟧) * + (↑(Polynomial.derivative Q₀) : ℂ⟦X⟧) = + -(↑Q₀ : ℂ⟦X⟧) * tailSumSeries α := by + rw [hQ0_fac] + simp only [Polynomial.derivative_C_mul, Polynomial.coe_mul, + Polynomial.coe_C] + linear_combination + (PowerSeries.C (Q₀.coeff 0)) * X_mul_coe_derivative_prod α + have hXdP : (↑(Polynomial.X : ℂ[X]) : ℂ⟦X⟧) * + (↑(Polynomial.derivative P₀) : ℂ⟦X⟧) = + -(↑P₀ : ℂ⟦X⟧) * tailSumSeries β := by + rw [hP0_fac] + simp only [Polynomial.derivative_C_mul, Polynomial.coe_mul, + Polynomial.coe_C] + linear_combination + (PowerSeries.C (P₀.coeff 0)) * X_mul_coe_derivative_prod β + -- Leibniz rule applied to ↑Q₀ * H, then rewritten + have hleib := ((PowerSeries.derivative (R := ℂ))).leibniz (a := (↑Q₀ : ℂ⟦X⟧)) (b := + newtonHSeries t) + simp only [smul_eq_mul] at hleib + rw [hQ0H, PowerSeries.derivative_coe, PowerSeries.derivative_coe, + newtonH_derivative] at hleib + -- Multiply the Leibniz identity by ↑X with strategic parenthesisation + have hmul : (↑(Polynomial.X : ℂ[X]) : ℂ⟦X⟧) * + (↑(Polynomial.derivative P₀) : ℂ⟦X⟧) = + (↑(Polynomial.X : ℂ[X]) : ℂ⟦X⟧) * powerSumSeries t * + ((↑Q₀ : ℂ⟦X⟧) * newtonHSeries t) + + newtonHSeries t * + ((↑(Polynomial.X : ℂ[X]) : ℂ⟦X⟧) * + (↑(Polynomial.derivative Q₀) : ℂ⟦X⟧)) := by + linear_combination (↑(Polynomial.X : ℂ[X]) : ℂ⟦X⟧) * hleib + rw [hQ0H, hXdQ, hXdP] at hmul + -- Cancel the unit ↑P₀ + have hP0_unit : IsUnit (↑P₀ : ℂ⟦X⟧) := by + rw [PowerSeries.isUnit_iff_constantCoeff, Polynomial.constantCoeff_coe] + exact isUnit_iff_ne_zero.mpr hP0_coeff0 + have hkey : (↑(Polynomial.X : ℂ[X]) : ℂ⟦X⟧) * powerSumSeries t = + tailSumSeries α - tailSumSeries β := + hP0_unit.mul_left_cancel + (by linear_combination -hmul + tailSumSeries α * hQ0H) + -- Extract coefficient m (where m ≥ 1) + obtain ⟨n, rfl⟩ : ∃ n, m = n + 1 := ⟨m - 1, by omega⟩ + have hcoeff := congr_arg (PowerSeries.coeff (n + 1)) hkey + simp only [Polynomial.coe_X, PowerSeries.coeff_succ_X_mul, map_sub, + tailSumSeries, powerSumSeries, PowerSeries.coeff_mk, + Nat.succ_ne_zero, ↓reduceIte] at hcoeff + exact hcoeff + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/RecurrenceFromVanishing.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/RecurrenceFromVanishing.lean new file mode 100644 index 0000000000..00d02a9294 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/RecurrenceFromVanishing.lean @@ -0,0 +1,299 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums + +/-! +# Recurrence from Schur-determinant vanishing + +Given a power-sum sequence `t` whose determinant Schur specialisation +vanishes on sufficiently wide single-row extensions, the +complete-homogeneous sequence `newtonHZ t` satisfies a nontrivial +linear recurrence. This is the algebraic core of the argument that +hook confinement forces a nilpotent trace. + +The proof proceeds in three stages: + +1. **Determinant vanishing** — the vanishing hypothesis `hvan` yields + `det = 0` for every matrix of the form + `(fun i j : Fin (a+1) => newtonHZ t (ρ i + 1 + j))` whenever the + row-shifts `ρ` take integer values `≥ b − a`. Negative degrees + evaluate to zero. + +2. **Finite rank** — the span of the vectors + `v ρ := (fun k => newtonHZ t (ρ + 1 + k))` for `ρ ≥ b − a` has + `finrank ≤ a` (a proper subspace of `Fin (a+1) → ℂ`). + +3. **Annihilator extraction** — a nonzero linear functional vanishing + on that span is converted to the coefficient vector `c` of the + recurrence. +-/ + +@[expose] public section + +namespace RS + +open Finset Matrix Submodule Module + +/-! ### Stage 1: determinant vanishing from Schur vanishing -/ + +/-- For all `d`, adding `d` to the index of a `StrictAnti` function +on `Fin n` drops the value by at least `d`. -/ +private lemma strictAnti_drop {n : ℕ} {ρ : Fin n → ℤ} + (hρ : StrictAnti ρ) : + ∀ d m (hm : m < n) (hmd : m + d < n), + ρ ⟨m + d, hmd⟩ + (d : ℤ) ≤ ρ ⟨m, hm⟩ := by + intro d; induction d with + | zero => intros; simp + | succ d ih => + intro m hm hmd + have hmd' : m + d < n := by omega + have h_ih := ih m hm hmd' + have h_step := hρ + (show (⟨m + d, hmd'⟩ : Fin n) < ⟨m + d + 1, hmd⟩ by + exact Fin.mk_lt_mk.mpr (by omega)) + change ρ ⟨m + d + 1, hmd⟩ + ((d + 1 : ℕ) : ℤ) ≤ ρ ⟨m, hm⟩ + omega + +/-- For a `StrictAnti` function `ρ` on `Fin n` valued in `ℤ`, the sum +`ρ j + j` is antitone: the strict decrease of `ρ` dominates the +increase of the index. -/ +private lemma antitone_strictAnti_add_val {n : ℕ} {ρ : Fin n → ℤ} + (hρ : StrictAnti ρ) : Antitone (fun j : Fin n => ρ j + (j : ℤ)) := by + intro i j hij + change ρ j + (j.val : ℤ) ≤ ρ i + (i.val : ℤ) + have him : i.val ≤ j.val := hij + have hmd_lt : i.val + (j.val - i.val) < n := by omega + have key := strictAnti_drop hρ (j.val - i.val) i.val i.isLt hmd_lt + have h_fin_eq : (⟨i.val + (j.val - i.val), hmd_lt⟩ : Fin n) = j := by + ext; change i.val + (j.val - i.val) = j.val; omega + suffices h : ρ j + ((j.val - i.val : ℕ) : ℤ) ≤ ρ i by omega + calc ρ j + ((j.val - i.val : ℕ) : ℤ) + = ρ ⟨i.val + (j.val - i.val), hmd_lt⟩ + + ((j.val - i.val : ℕ) : ℤ) := by + rw [congr_arg ρ h_fin_eq] + _ ≤ ρ ⟨i.val, i.isLt⟩ := key + _ = ρ i := rfl + +/-- The determinant `det (fun i j => newtonHZ t (ρ i + 1 + j))` vanishes +whenever `ρ : Fin (a+1) → ℤ` is `StrictAnti` with +`ρ ⟨a, _⟩ ≥ b − a` and the Schur-determinant vanishing hypothesis +holds. -/ +private lemma det_vanishing_of_strictAnti {t : ℕ → ℂ} {a b : ℕ} + (hvan : ∀ w : List ℕ, w.SortedGE → (∀ x ∈ w, 0 < x) → + w.length = a + 1 → b + 1 ≤ w.getD a 0 → schurDet t w = 0) + {ρ : Fin (a + 1) → ℤ} (hρ : StrictAnti ρ) + (hρ_lb : (b : ℤ) - a ≤ ρ (Fin.last a)) : + det (Matrix.of fun i j : Fin (a + 1) => + newtonHZ t (ρ i + 1 + (j : ℤ))) = 0 := by + -- ═══════ Construct the list w ═══════ + set f : Fin (a + 1) → ℕ := fun j => (ρ j + (j : ℤ) + 1).toNat with hf_def + set w := List.ofFn f with hw_def + have hw_len : w.length = a + 1 := List.length_ofFn + have hrow (i : Fin (a + 1)) : + (b : ℤ) + 1 ≤ ρ i + (i : ℤ) + 1 := by + have hdrop := antitone_strictAnti_add_val hρ (Fin.le_last i) + change ρ (Fin.last a) + (a : ℤ) ≤ ρ i + (i : ℤ) at hdrop + omega + have hf_cast (i : Fin (a + 1)) : + (f i : ℤ) = ρ i + (i : ℤ) + 1 := by + exact Int.toNat_of_nonneg (by have := hrow i; omega) + -- ═══════ Verify the hypotheses of hvan ═══════ + have hw_sorted : w.SortedGE := by + rw [hw_def, List.sortedGE_ofFn_iff] + intro i j hij + apply Int.toNat_le_toNat + have hdrop := antitone_strictAnti_add_val hρ hij + change ρ j + (j : ℤ) ≤ ρ i + (i : ℤ) at hdrop + omega + have hw_pos : ∀ x ∈ w, 0 < x := by + intro x hx + rw [hw_def, List.mem_ofFn] at hx + obtain ⟨i, rfl⟩ := hx + have := hrow i + have := hf_cast i + omega + have hw_last : b + 1 ≤ w.getD a 0 := by + change b + 1 ≤ (List.ofFn f).getD a 0 + rw [List.getD_eq_getElem _ _ (by rw [List.length_ofFn]; omega), + List.getElem_ofFn] + have := hrow (Fin.last a) + have := hf_cast (Fin.last a) + simpa only [Fin.last] using (show b + 1 ≤ f (Fin.last a) by omega) + -- ═══════ Apply the vanishing hypothesis ═══════ + have hschur := hvan w hw_sorted hw_pos hw_len hw_last + -- ═══════ Relate schurDet to the target determinant ═══════ + rw [schurDet] at hschur + set target := Matrix.of fun i j : Fin (a + 1) => + newtonHZ t (ρ i + 1 + (j : ℤ)) + set e := finCongr hw_len + suffices h_eq : (Matrix.of fun i j : Fin w.length => + newtonHZ t ((w.get i : ℤ) + (j : ℤ) - (i : ℤ))) = + target.submatrix e e by + rw [h_eq, det_submatrix_equiv_self] at hschur; exact hschur + ext ⟨i, hi⟩ ⟨j, hj⟩ + simp only [Matrix.of_apply, Matrix.submatrix_apply, target, e, + finCongr_apply, Fin.cast_mk] + have hw_get : (w.get ⟨i, hi⟩ : ℕ) = f ⟨i, by omega⟩ := + List.getElem_ofFn hi + have h_cast : (↑(w.get ⟨i, hi⟩) + (j : ℤ) - (i : ℤ)) = + ρ ⟨i, by omega⟩ + 1 + (j : ℤ) := by + rw [hw_get, hf_cast] + change ρ ⟨i, _⟩ + (i : ℤ) + 1 + (j : ℤ) - (i : ℤ) = + ρ ⟨i, _⟩ + 1 + (j : ℤ) + ring + rw [h_cast] + +/-! ### Stage 2: linear dependence and finite-rank bound -/ + +/-- For any function `g : Fin (a+1) → ℤ` with values `≥ b − a`, the +matrix `(fun i j => newtonHZ t (g i + 1 + j))` has determinant zero. -/ +private lemma det_vanishing_of_all_ge {t : ℕ → ℂ} {a b : ℕ} + (hvan : ∀ w : List ℕ, w.SortedGE → (∀ x ∈ w, 0 < x) → + w.length = a + 1 → b + 1 ≤ w.getD a 0 → schurDet t w = 0) + (g : Fin (a + 1) → ℤ) (hg : ∀ i, (b : ℤ) - a ≤ g i) : + det (Matrix.of fun i j : Fin (a + 1) => + newtonHZ t (g i + 1 + (j : ℤ))) = 0 := by + by_cases hInj : Function.Injective g + · -- ═══════ Injective case: sort g and apply Stage 1 ═══════ + set S := Finset.image g Finset.univ + have hS_card : S.card = a + 1 := + (Finset.card_image_of_injective _ hInj).trans (Finset.card_fin _) + set e := S.orderIsoOfFin hS_card + set ρ : Fin (a + 1) → ℤ := fun i => (e (Fin.rev i)).1 + have hρ_anti : StrictAnti ρ := fun i j hij => + Subtype.coe_lt_coe.mpr (e.strictMono (Fin.rev_lt_rev.mpr hij)) + have hρ_lb : (b : ℤ) - a ≤ ρ (Fin.last a) := by + change (b : ℤ) - a ≤ (e (Fin.rev (Fin.last a))).1 + have hrev : Fin.rev ((Fin.last a) : Fin (a + 1)) = + ⟨0, by omega⟩ := Fin.ext (by simp [Fin.rev]) + rw [hrev] + obtain ⟨k, _, hk⟩ := Finset.mem_image.mp (e ⟨0, by omega⟩).2 + rw [← hk]; exact hg k + have h_det_zero := det_vanishing_of_strictAnti hvan hρ_anti hρ_lb + -- Build a permutation σ where g (σ_fun i) = ρ i + have hρ_range : ∀ i, ∃ k, g k = ρ i := by + intro i + obtain ⟨k, _, hk⟩ := Finset.mem_image.mp (e (Fin.rev i)).2 + exact ⟨k, hk⟩ + choose σ_fun hσ using hρ_range + have hσ_inj : Function.Injective σ_fun := fun i j hij => + hρ_anti.injective (by rw [← hσ i, ← hσ j, hij]) + set σ : Equiv.Perm (Fin (a + 1)) := + Equiv.ofBijective σ_fun + ⟨hσ_inj, (Finite.injective_iff_surjective.mp hσ_inj)⟩ + have h_eq : (Matrix.of fun i j : Fin (a + 1) => + newtonHZ t (ρ i + 1 + (j : ℤ))) = + (Matrix.of fun i j : Fin (a + 1) => + newtonHZ t (g i + 1 + (j : ℤ))).submatrix σ id := by + ext i j; simp only [Matrix.of_apply, Matrix.submatrix_apply, id] + change newtonHZ t (ρ i + 1 + (j : ℤ)) = + newtonHZ t (g (σ_fun i) + 1 + (j : ℤ)) + rw [hσ] + rw [h_eq, det_permute, mul_eq_zero, + or_iff_right (by simp [Units.ne_zero])] at h_det_zero + exact h_det_zero + · -- ═══════ Non-injective case: repeated rows ═══════ + simp only [Function.Injective] at hInj + push Not at hInj + obtain ⟨i, j, hgij, hne⟩ := hInj + exact det_zero_of_row_eq hne (by ext k; simp [Matrix.of_apply, hgij]) + +/-! ### Stage 3: extracting the recurrence -/ + +-- One elaboration of the span/annihilator assembly +-- over `Fin (a+1) → ℂ` with its instance searches, no proof search. +/-- Schur-determinant vanishing on wide single-row extensions forces +the complete-homogeneous sequence to satisfy a nontrivial linear +recurrence. -/ +theorem exists_recurrence_of_schurDet_vanishing {t : ℕ → ℂ} {a b : ℕ} + (hvan : ∀ w : List ℕ, w.SortedGE → (∀ x ∈ w, 0 < x) → + w.length = a + 1 → b + 1 ≤ w.getD a 0 → schurDet t w = 0) : + ∃ c : Fin (a + 1) → ℂ, c ≠ 0 ∧ + ∀ ρ : ℤ, (b : ℤ) - a ≤ ρ → + ∑ k : Fin (a + 1), c k * newtonHZ t (ρ + 1 + (k : ℤ)) = 0 := by + -- ═══════ STAGE 2: finite-rank bound ═══════ + set v : ℤ → (Fin (a + 1) → ℂ) := + fun ρ k => newtonHZ t (ρ + 1 + (k : ℤ)) with hv_def + set W := span ℂ (v '' {ρ | (b : ℤ) - a ≤ ρ}) + have h_finrank : finrank ℂ W ≤ a := by + by_contra h_gt + push Not at h_gt + have h_le : finrank ℂ W ≤ a + 1 := + (Submodule.finrank_le W).trans (le_of_eq (finrank_fin_fun ℂ)) + have h_eq : finrank ℂ W = a + 1 := le_antisymm h_le (by omega) + have h_top : W = ⊤ := Submodule.eq_top_of_finrank_eq (by + rw [h_eq, finrank_fin_fun ℂ]) + -- Extract a linearly independent subset B ⊆ S spanning W + obtain ⟨B, hBS, hspan, hLI⟩ := exists_linearIndependent ℂ + (v '' {ρ | (b : ℤ) - a ≤ ρ}) + have hspanB : span ℂ B = ⊤ := hspan.trans h_top + have hBfin : B.Finite := hLI.set_finite_of_isNoetherian + have : Fintype B := hBfin.fintype + have hBcard : Fintype.card B = a + 1 := by + have h1 := finrank_span_eq_card hLI + rw [Subtype.range_coe, hspanB, finrank_top, finrank_fin_fun ℂ] + at h1 + exact h1.symm + -- Index B by Fin (a+1) + set eB : Fin (a + 1) ≃ B := + (finCongr hBcard.symm).trans (Fintype.equivFin B).symm + have hg_LI : LinearIndependent ℂ (Subtype.val ∘ eB) := + hLI.comp _ eB.injective + -- Each basis element is v(ρ_i) for some ρ_i ≥ b-a + have hg_mem : ∀ i, (eB i).val ∈ v '' {ρ | (b : ℤ) - a ≤ ρ} := + fun i => hBS (eB i).2 + choose ρ_vals hρ_ge hρ_eq using + (fun i => (Set.mem_image _ _ _).mp (hg_mem i)) + -- The matrix M has det = 0 by Stage 2, but LI implies det ≠ 0 + set M := Matrix.of fun i j : Fin (a + 1) => + newtonHZ t (ρ_vals i + 1 + (j : ℤ)) + have h_det_zero : M.det = 0 := + det_vanishing_of_all_ge hvan _ hρ_ge + have h_rows_eq : M.row = (Subtype.val ∘ eB) := by + ext i j; simp only [Matrix.row_apply, M, Matrix.of_apply, + Function.comp_apply] + exact congr_fun (hρ_eq i) j + exact absurd h_det_zero + ((Matrix.isUnit_iff_isUnit_det M).mp + (Matrix.linearIndependent_rows_iff_isUnit.mp + (h_rows_eq ▸ hg_LI))).ne_zero + -- ═══════ STAGE 3: extract the nonzero annihilator ═══════ + have h_lt_top : W < ⊤ := by + rw [lt_top_iff_ne_top]; intro heq + rw [heq, finrank_top, finrank_fin_fun ℂ] at h_finrank; omega + obtain ⟨φ, hφ_ne, hφ_van⟩ := + Submodule.exists_dual_map_eq_bot_of_lt_top h_lt_top inferInstance + refine ⟨fun k => φ (Pi.single k 1), ?_, ?_⟩ + · -- c ≠ 0: if all φ(eₖ) = 0 then φ = 0 + intro hc; apply hφ_ne + apply LinearMap.ext; intro x + have hx : x = ∑ k : Fin (a + 1), x k • Pi.single k (1 : ℂ) := by + ext j; simp [Finset.sum_apply, Pi.single_apply] + rw [hx, map_sum, LinearMap.zero_apply] + exact Finset.sum_eq_zero fun k _ => by + have hk := congr_fun hc k + simp only [Pi.zero_apply] at hk + rw [map_smul, smul_eq_mul, hk, mul_zero] + · -- The recurrence ∑ k, c k * h(ρ + 1 + k) = 0 for ρ ≥ b - a + intro ρ hρ + have hv_mem : v ρ ∈ W := subset_span ⟨ρ, hρ, rfl⟩ + have hφ_zero : φ (v ρ) = 0 := by + have hmem : φ (v ρ) ∈ W.map φ := by + rw [Submodule.mem_map]; exact ⟨v ρ, hv_mem, rfl⟩ + rwa [hφ_van, Submodule.mem_bot] at hmem + have hdecomp : v ρ = ∑ k : Fin (a + 1), + v ρ k • Pi.single k (1 : ℂ) := by + ext j; simp [Finset.sum_apply, Pi.single_apply] + rw [show (∑ k, (fun k => φ (Pi.single k 1)) k * + newtonHZ t (ρ + 1 + (k : ℤ))) = φ (v ρ) from by + conv_rhs => rw [hdecomp, map_sum] + congr 1; ext k; rw [map_smul, smul_eq_mul, mul_comm]] + exact hφ_zero + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/SubsetEH.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/SubsetEH.lean new file mode 100644 index 0000000000..8ec075ad4c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/SubsetEH.lean @@ -0,0 +1,96 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Subset-indexed elementary and complete homogeneous polynomials + +For a subset `A` of the variables of `MvPolynomial (Fin k) ℂ`, the +elementary symmetric polynomial `eSub A r` in the variables of `A` +and the complete homogeneous polynomial `hSub A m` supported in +`A`, with the add-one-variable recurrence for `eSub` — the engine +of the e–h convolution and the bialternant Jacobi–Trudi identity. +The `hSub` recurrence is proven in `HInsert.lean`. +-/ + +@[expose] public section + +namespace RS + +open Finset MvPolynomial + +variable {k : ℕ} + +/-- The elementary symmetric polynomial in a subset of the +variables. -/ +noncomputable def eSub (A : Finset (Fin k)) (r : ℕ) : + MvPolynomial (Fin k) ℂ := + (A.val.map X).esymm r + +open scoped Classical in +/-- The complete homogeneous polynomial supported in a subset of +the variables. -/ +noncomputable def hSub (A : Finset (Fin k)) (m : ℕ) : + MvPolynomial (Fin k) ℂ := + ∑ w ∈ Finset.univ.filter + (fun w : Sym (Fin k) m => ∀ i ∈ w.1, i ∈ A), + (w.1.map X).prod + +/-- The empty elementary symmetric polynomial is `1`. -/ +theorem eSub_zero (A : Finset (Fin k)) : eSub A 0 = 1 := by + rw [eSub, Multiset.esymm, Multiset.powersetCard_zero_left, + Multiset.map_singleton, Multiset.prod_zero, + Multiset.sum_singleton] + +/-- And so is the degree-zero complete homogeneous one. -/ +theorem hSub_zero (A : Finset (Fin k)) : hSub A 0 = 1 := by + classical + rw [hSub, Finset.filter_true_of_mem (fun w _ => fun i hi => + absurd ((Multiset.card_eq_zero.mp w.2) ▸ hi) + (Multiset.notMem_zero i))] + let : Unique (Sym (Fin k) 0) := + ⟨⟨Sym.nil⟩, fun s => Sym.eq_nil_of_card_zero s⟩ + rw [Fintype.sum_unique] + rw [show ((default : Sym (Fin k) 0)).1 = 0 from rfl] + rw [Multiset.map_zero, Multiset.prod_zero] + +/-- Vanishing of `eSub` beyond the subset size. -/ +theorem eSub_eq_zero_of_lt (A : Finset (Fin k)) (r : ℕ) + (hr : A.card < r) : eSub A r = 0 := by + rw [eSub, Multiset.esymm] + rw [show Multiset.powersetCard r (A.val.map X) = 0 from + Multiset.powersetCard_eq_empty _ (by + rw [Multiset.card_map] + exact hr)] + rw [Multiset.map_zero, Multiset.sum_zero] + +/-- **The add-one-variable recurrence for `eSub`.** -/ +theorem eSub_insert {A : Finset (Fin k)} {j : Fin k} (hj : j ∉ A) + (r : ℕ) : + eSub (insert j A) (r + 1) = + eSub A (r + 1) + X j * eSub A r := by + rw [eSub, eSub, eSub] + rw [show (insert j A).val = j ::ₘ A.val from + Finset.insert_val_of_notMem hj] + rw [Multiset.map_cons] + rw [Multiset.esymm, Multiset.esymm, Multiset.esymm] + rw [Multiset.powersetCard_cons, + Multiset.map_add, Multiset.sum_add] + congr 1 + rw [Multiset.map_map] + rw [show ((Multiset.powersetCard r (A.val.map X)).map + (Multiset.prod ∘ Multiset.cons (X j))) = + (Multiset.powersetCard r (A.val.map X)).map + (fun t => X j * t.prod) from + Multiset.map_congr rfl (fun t _ => by + change (X j ::ₘ t).prod = X j * t.prod + rw [Multiset.prod_cons])] + exact Multiset.sum_map_mul_left + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/SuperPowerSums.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/SuperPowerSums.lean new file mode 100644 index 0000000000..abf7b546c7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/SuperPowerSums.lean @@ -0,0 +1,218 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums + +/-! +# Super power sums + +The central symmetric-function lemmas for the Regts–Sevenster +development. Given a sequence `t : ℕ → ℂ` whose Schur specialization +vanishes outside a hook, `t` decomposes as a difference of power sums +of two disjoint multisets of nonzero complex numbers (Lemma A.9 of +the accompanying paper); if `t` is eventually zero, then `t` is +identically zero from degree 1 onward (Lemma A.10 there). + +The key technical ingredient is the identity `derivative H = T * H` +where `H` is the generating power series of `newtonH t` and `T` is +the shifted power-sum series; this is immediate from the Newton +recursion that defines `newtonH`. +-/ + +@[expose] public section + +namespace RS + +open Finset PowerSeries + +/-! ### The generating series and its derivative -/ + +/-- The generating power series of the complete homogeneous sequence: +`H = PowerSeries.mk (newtonH t)`. -/ +noncomputable def newtonHSeries (t : ℕ → ℂ) : ℂ⟦X⟧ := + PowerSeries.mk (newtonH t) + +/-- The shifted power-sum series: coefficient `n` is `t (n + 1)`. -/ +noncomputable def powerSumSeries (t : ℕ → ℂ) : ℂ⟦X⟧ := + PowerSeries.mk (fun n => t (n + 1)) + +/-- The Newton recursion at coefficient level: +`newtonH t (n + 1) * (n + 1) = +∑ i ∈ range (n + 1), t (i + 1) * newtonH t (n − i)`. -/ +private theorem newtonH_coeff_identity (t : ℕ → ℂ) (n : ℕ) : + newtonH t (n + 1) * (↑(n + 1) : ℂ) = + ∑ i ∈ Finset.range (n + 1), t (i + 1) * newtonH t (n - i) := by + simp only [newtonH] + rw [show (↑n : ℂ) + 1 = (↑(n + 1) : ℂ) from by push_cast; ring] + have hne : (↑(n + 1) : ℂ) ≠ 0 := Nat.cast_ne_zero.mpr (Nat.succ_ne_zero n) + field_simp + +/-- **The derivative identity for the Newton generating series.** +`d⁄dX (newtonHSeries t) = powerSumSeries t * newtonHSeries t`, +i.e. `H' = T · H` where `H = ∑ h_n X^n` and `T = ∑ t_{n+1} X^n`. +This is a direct restatement of the Newton recursion at the level of +formal power series. -/ +theorem newtonH_derivative (t : ℕ → ℂ) : + d⁄dX (newtonHSeries t) = powerSumSeries t * newtonHSeries t := by + ext n + rw [coeff_derivative] + rw [coeff_mul] + simp only [newtonHSeries, coeff_mk, powerSumSeries] + rw [Nat.sum_antidiagonal_eq_sum_range_succ_mk] + rw [show (↑n : ℂ) + 1 = (↑(n + 1) : ℂ) from by push_cast; ring] + exact newtonH_coeff_identity t n + +/-- The constant coefficient of `newtonHSeries t` is `1`. -/ +@[simp] +theorem newtonH_series_constantCoeff (t : ℕ → ℂ) : + constantCoeff (newtonHSeries t) = 1 := by + simp [newtonHSeries, ← coeff_zero_eq_constantCoeff_apply, coeff_mk] + +/-! ### Power series eventually zero implies polynomial coercion -/ + +/-- A power series whose coefficients vanish from degree `N` onward +equals the coercion of its truncation to a polynomial. -/ +theorem powerSeries_eq_coe_trunc_of_eventually_zero {R : Type*} [CommSemiring R] + (f : PowerSeries R) (N : ℕ) (hf : ∀ m, N ≤ m → coeff m f = 0) : + f = ↑(PowerSeries.trunc N f) := by + ext m + rw [Polynomial.coeff_coe, PowerSeries.coeff_trunc] + split + · rfl + · rename_i h; simp only [not_lt] at h; exact hf m h + +/-! ### Lemma A.10: eventually zero power sums vanish -/ + +/-- A weighted exponential sum over `Fin n` that vanishes at sufficiently many +consecutive exponents must have all weights zero, by the Vandermonde +argument. -/ +private theorem vanishing_exponential_sum + {n : ℕ} {γ : Fin n → ℂ} (hγ : Function.Injective γ) + {w : Fin n → ℂ} {M : ℕ} + (hγnz : ∀ j, γ j ≠ 0) + (hvan : ∀ i : Fin n, ∑ j : Fin n, w j * γ j ^ (M + (i : ℕ)) = 0) : + w = 0 := by + have hvan' : ∀ i : Fin n, + ∑ j : Fin n, (w j * γ j ^ M) * γ j ^ (i : ℕ) = 0 := by + intro i + have := hvan i + simp only [pow_add] at this + convert this using 1 + congr 1; ext j; ring + have hv := Matrix.eq_zero_of_forall_pow_sum_mul_pow_eq_zero hγ hvan' + ext j + have := congr_fun hv j + simp only [Pi.zero_apply] at this + exact (mul_eq_zero.mp this).resolve_right (pow_ne_zero M (hγnz j)) + +/-- The sum of a multiset mapped by `f` equals the finset sum with counts. -/ +private theorem multiset_map_sum_eq + (s : Multiset ℂ) (f : ℂ → ℂ) : + (s.map f).sum = ∑ a ∈ s.toFinset, (s.count a : ℂ) * f a := by + rw [Finset.sum_multiset_map_count] + congr 1; ext a + rw [nsmul_eq_mul] + +/-- Extension of a multiset-weighted sum to a superset. -/ +private theorem multiset_sum_eq_finset_sum + (s : Multiset ℂ) (S : Finset ℂ) (hsS : s.toFinset ⊆ S) (f : ℂ → ℂ) : + (s.map f).sum = ∑ a ∈ S, (s.count a : ℂ) * f a := by + rw [multiset_map_sum_eq] + exact Finset.sum_subset hsS (fun x _ hx => by + rw [Multiset.count_eq_zero.mpr (Multiset.mem_toFinset.not.mp hx), + Nat.cast_zero, zero_mul]) + +/-- **Lemma A.10 of the accompanying paper.** +If `t m = ∑ αᵢ^m − ∑ βⱼ^m` for all `m ≥ 1` with `α` and `β` +multisets of nonzero complex numbers having disjoint supports, and +`t` is eventually zero, then `t m = 0` for all `m ≥ 1`. + +The proof is direct: the power-sum difference is rewritten as a +single weighted exponential sum over the union of supports; +vanishing at sufficiently many consecutive exponents forces all +weights to be zero by a Vandermonde argument; but disjointness +makes every weight nonzero, so the support set must be empty. -/ +theorem powerSums_zero_of_eventually_zero + {t : ℕ → ℂ} {α β : Multiset ℂ} + (hα : ∀ x ∈ α, x ≠ (0 : ℂ)) + (hβ : ∀ x ∈ β, x ≠ (0 : ℂ)) + (hdisj : ∀ x ∈ α, x ∉ β) + (hps : ∀ m, 1 ≤ m → t m = (α.map (· ^ m)).sum - (β.map (· ^ m)).sum) + (hev : ∃ N₀ : ℕ, ∀ m, N₀ ≤ m → t m = 0) : + ∀ m, 1 ≤ m → t m = 0 := by + classical + obtain ⟨N₀, hN₀⟩ := hev + -- ═══════ STAGE 1: rewrite as a single weighted sum ═══════ + set S := α.toFinset ∪ β.toFinset + set c : ℂ → ℂ := fun a => (α.count a : ℂ) - (β.count a : ℂ) + have htS : ∀ m, 1 ≤ m → + t m = ∑ a ∈ S, c a * a ^ m := by + intro m hm + rw [hps m hm, + multiset_sum_eq_finset_sum α S Finset.subset_union_left, + multiset_sum_eq_finset_sum β S Finset.subset_union_right] + simp only [c, sub_mul, Finset.sum_sub_distrib] + -- ═══════ STAGE 2: S must be empty ═══════ + suffices hSe : S = ∅ by + intro m hm + rw [htS m hm, hSe, Finset.sum_empty] + by_contra hSne + have hSne : S.Nonempty := Finset.nonempty_iff_ne_empty.mpr hSne + -- Biject S with Fin n using noncomputable equivFin + set n := S.card + have hn : 0 < n := Finset.card_pos.mpr hSne + -- γ : Fin n → ℂ via the equivalence + set e := S.equivFin with he_def + set γ : Fin n → ℂ := fun i => (e.symm i : ℂ) with hγ_def + have hγ_mem : ∀ i, γ i ∈ S := fun i => (e.symm i).prop + have hγ_inj : Function.Injective γ := by + intro i j hij + exact e.symm.injective (Subtype.val_injective hij) + -- All γ values are nonzero + have hγnz : ∀ i, γ i ≠ 0 := by + intro i + have hi := hγ_mem i + rcases Finset.mem_union.mp hi with h | h + · exact hα _ (Multiset.mem_toFinset.mp h) + · exact hβ _ (Multiset.mem_toFinset.mp h) + -- c (γ i) ≠ 0 for all i (by disjointness) + have hc_ne : ∀ i, c (γ i) ≠ 0 := by + intro i + have hi := hγ_mem i + rcases Finset.mem_union.mp hi with h | h + · have hmem := Multiset.mem_toFinset.mp h + have hni := hdisj _ hmem + simp only [c, Multiset.count_eq_zero.mpr hni, Nat.cast_zero, sub_zero] + exact Nat.cast_ne_zero.mpr (Multiset.count_ne_zero.mpr hmem) + · have hmem := Multiset.mem_toFinset.mp h + have hni : γ i ∉ α := fun hmem' => hdisj _ hmem' hmem + simp only [c, Multiset.count_eq_zero.mpr hni, Nat.cast_zero, + zero_sub, neg_ne_zero] + exact Nat.cast_ne_zero.mpr (Multiset.count_ne_zero.mpr hmem) + -- Convert finset sum to Fin n sum + have hsum_conv : ∀ (f : ℂ → ℂ), ∑ a ∈ S, f a = ∑ i : Fin n, f (γ i) := by + intro f + conv_lhs => rw [← S.sum_coe_sort f] + exact Fintype.sum_equiv e (fun x => f ↑x) (fun i => f (γ i)) + (fun x => by simp [hγ_def]) + -- ═══════ STAGE 3: Vandermonde contradiction ═══════ + set M := max N₀ 1 + set w : Fin n → ℂ := fun i => c (γ i) + have hvan_all : ∀ m, M ≤ m → ∑ i : Fin n, w i * γ i ^ m = 0 := by + intro m hm + change ∑ i : Fin n, c (γ i) * γ i ^ m = 0 + rw [← hsum_conv (fun a => c a * a ^ m)] + have : t m = 0 := hN₀ m (le_trans (le_max_left _ _) hm) + rw [htS m (le_trans (le_max_right _ _) hm)] at this + exact this + have hvan_fin : ∀ i : Fin n, ∑ j : Fin n, w j * γ j ^ (M + (i : ℕ)) = 0 := + fun i => hvan_all _ (Nat.le_add_right M _) + have hw := vanishing_exponential_sum hγ_inj hγnz hvan_fin + exact hc_ne ⟨0, hn⟩ (congr_fun hw ⟨0, hn⟩) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/TCount.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/TCount.lean new file mode 100644 index 0000000000..241b0a0bba --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/TCount.lean @@ -0,0 +1,80 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.JTGuard +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HProdCoeff + +/-! +# The counting form of the double-sum identity + +Substituting the tuple-count coefficients and the guard/margin +bridges into the signed double-sum identity: the signed count of +margin-constrained Sym-tuples over shifted compositions is `1`. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv + +variable {k : ℕ} + +open scoped Classical in +/-- **The counting form of the double-sum identity.** -/ +theorem t_count (v : Fin k → ℕ) + (hsort : ∀ i j : Fin k, i ≤ j → v j ≤ v i) : + (∑ τ : Equiv.Perm (Fin k), ∑ σ : Equiv.Perm (Fin k), + ((Equiv.Perm.sign τ : ℤ) : ℂ) * + ((Equiv.Perm.sign σ : ℤ) : ℂ) * + (if (∀ i : Fin k, + 0 ≤ (v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ)) ∧ + (∀ i : Fin k, + 0 ≤ (v i : ℤ) + ((τ i : Fin k) : ℕ) - (i : ℕ)) + then (Fintype.card {W : ∀ i : Fin k, + Sym (Fin k) + (((v i : ℤ) + ((σ i : Fin k) : ℕ) - + (i : ℕ)).toNat) // + ∀ j : Fin k, (∑ i, (W i).1.count j) = + ((v j : ℤ) + ((τ j : Fin k) : ℕ) - + (j : ℕ)).toNat} : ℂ) + else 0)) = 1 := by + rw [← t_identity v (staircase_injective v hsort)] + refine Finset.sum_congr rfl fun τ _ => ?_ + by_cases hτ : stairShift τ ≤ diagExp v + · have hτ' := (stair_guard_iff v τ).mp hτ + rw [ite_eq_left hτ, Finset.mul_sum] + refine Finset.sum_congr rfl fun σ _ => ?_ + by_cases hσ : ∀ i : Fin k, + 0 ≤ (v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) + · rw [ite_eq_left ⟨hσ, hτ'⟩, ite_eq_left hσ, coeff_hSub_prod] + rw [show (Fintype.card {W : ∀ i : Fin k, + Sym (Fin k) + (((v i : ℤ) + ((σ i : Fin k) : ℕ) - + (i : ℕ)).toNat) // + ∀ j : Fin k, (∑ i, (W i).1.count j) = + (diagExp v - stairShift τ) j}) = + Fintype.card {W : ∀ i : Fin k, + Sym (Fin k) + (((v i : ℤ) + ((σ i : Fin k) : ℕ) - + (i : ℕ)).toNat) // + ∀ j : Fin k, (∑ i, (W i).1.count j) = + ((v j : ℤ) + ((τ j : Fin k) : ℕ) - + (j : ℕ)).toNat} from + Fintype.card_congr (Equiv.subtypeEquivRight fun W => + forall_congr' fun j => by + rw [stair_margin_eq v τ hτ j])] + ring + · rw [ite_eq_right (fun hc => hσ hc.1), ite_eq_right hσ] + ring + · rw [ite_eq_right hτ, mul_zero] + rw [Finset.sum_eq_zero fun σ _ => by + rw [ite_eq_right (fun hc => + hτ ((stair_guard_iff v τ).mpr hc.2)), mul_zero]] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/TIdentity.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/TIdentity.lean new file mode 100644 index 0000000000..d1f385db88 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/TIdentity.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.JTDetExpand + +/-! +# The signed double-sum identity + +Combining the bialternant, the diagonal coefficient, the staircase +expansion, and the Jacobi–Trudi Leibniz expansion: the signed +double sum of guarded coefficients of complete homogeneous +products equals `1`. This is the polynomial form of the +orthonormality `⟨χ_μ, χ_μ⟩ = 1`. +-/ + +@[expose] public section + +namespace RS + +open Finset MvPolynomial Equiv + +variable {k : ℕ} + +/-- The diagonal staircase exponent of a shape. -/ +noncomputable def diagExp (v : Fin k → ℕ) : Fin k →₀ ℕ := + ∑ i, Finsupp.single i (v i + ((k - 1) - (i : ℕ))) + +/-- **The signed double-sum identity.** -/ +theorem t_identity (v : Fin k → ℕ) + (hinj : Function.Injective + (fun i : Fin k => v i + ((k - 1) - (i : ℕ)))) : + (∑ τ : Equiv.Perm (Fin k), + ((Equiv.Perm.sign τ : ℤ) : ℂ) * + (if stairShift τ ≤ diagExp v + then ∑ σ : Equiv.Perm (Fin k), + ((Equiv.Perm.sign σ : ℤ) : ℂ) * + (if ∀ i : Fin k, + 0 ≤ (v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) + then (∏ i, hSub (Finset.univ : Finset (Fin k)) + (((v i : ℤ) + ((σ i : Fin k) : ℕ) - + (i : ℕ)).toNat)).coeff (diagExp v - stairShift τ) + else 0) + else 0)) = 1 := by + classical + have h1 : ((powMat v).det).coeff (diagExp v) = 1 := + alternant_coeff (fun i : Fin k => v i + ((k - 1) - (i : ℕ))) + hinj + have h2 : ((jtMat v).det * (powMat (fun _ : Fin k => 0)).det).coeff (diagExp v) = 1 := by + rw [← bialternant] + exact h1 + rw [coeff_mul_alternant] at h2 + rw [← h2] + refine Finset.sum_congr rfl fun τ _ => ?_ + by_cases hle : stairShift τ ≤ diagExp v + · rw [ite_eq_left hle, ite_eq_left hle, coeff_det_jtMat] + · rw [ite_eq_right hle, ite_eq_right hle] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaExp.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaExp.lean new file mode 100644 index 0000000000..e3ad408657 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaExp.lean @@ -0,0 +1,74 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaSeries + +/-! +# The trace zeta function in exponential form + +`traceZeta t = exp (∑_{m≥1} t m / m · zᵐ)` as a formal power +series, and its identification with the Newton generating series +via the differential characterization — the displayed form of the +trace zeta function. +-/ + +@[expose] public section + +namespace RS + +open PowerSeries + +/-- The power-sum logarithm `∑_{m≥1} t m / m · zᵐ`. -/ +noncomputable def psLog (t : ℕ → ℂ) : PowerSeries ℂ := + PowerSeries.mk (fun m => if m = 0 then 0 else t m / m) + +/-- The log series has no constant term. -/ +theorem constantCoeff_psLog (t : ℕ → ℂ) : + constantCoeff (psLog t) = 0 := by + rw [← coeff_zero_eq_constantCoeff, psLog, coeff_mk, ite_eq_left rfl] + +/-- Hence it can be substituted into the exponential. -/ +theorem hasSubst_psLog (t : ℕ → ℂ) : HasSubst (psLog t) := + HasSubst.of_constantCoeff_zero (constantCoeff_psLog t) + +/-- The derivative of the power-sum logarithm is the power-sum +series. -/ +theorem derivative_psLog (t : ℕ → ℂ) : + (PowerSeries.derivative (R := ℂ)) (psLog t) = powerSumSeries t := by + ext n + rw [coeff_derivative, psLog, coeff_mk, ite_eq_right (by omega)] + rw [show coeff n (powerSumSeries t) = t (n + 1) from by + rw [powerSumSeries, coeff_mk]] + have hne : (((n + 1) : ℕ) : ℂ) ≠ 0 := by + exact_mod_cast Nat.succ_ne_zero n + field_simp + push_cast + ring + +/-- **The trace zeta function** in exponential form. -/ +noncomputable def traceZeta (t : ℕ → ℂ) : PowerSeries ℂ := + (exp ℂ).subst (psLog t) + +/-- **The zeta identification**: the exponential form equals the +Newton generating series. -/ +theorem traceZeta_eq_newtonH_series (t : ℕ → ℂ) : + traceZeta t = newtonHSeries t := by + apply eq_newtonH_series_of_ode + · rw [traceZeta, ← coeff_zero_eq_constantCoeff] + rw [coeff_subst' (hasSubst_psLog t)] + rw [finsum_eq_single _ 0 (fun d hd => ?_)] + · rw [pow_zero, coeff_zero_eq_constantCoeff, map_one, + smul_eq_mul, mul_one] + exact constantCoeff_exp + · rw [coeff_zero_eq_constantCoeff, map_pow, + constantCoeff_psLog, zero_pow hd, smul_zero] + · rw [traceZeta, derivative_subst (hasSubst_psLog t), + derivative_exp, derivative_psLog] + rw [mul_comm] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaRational.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaRational.lean new file mode 100644 index 0000000000..fd34605a23 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaRational.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HookVanishing + +/-! +# Rationality of the Newton generating series + +The Newton generating series of a sequence obeying a nontrivial +linear recurrence is a rational function. +`RationalityFromRecurrence.lean` produces a coprime polynomial pair +from the recurrence; here both constant terms are normalised to 1, +which is the form the trace zeta function is read in, and the +recurrence itself is supplied by hook vanishing. +-/ + +@[expose] public section + +namespace RS + +open scoped Polynomial PowerSeries + +/-! ### Normalising both constant terms to 1 -/ + +-- The rational form is assembled from the +-- recurrence, so the whole truncated product enters the term. +/-- The Newton generating series of a sequence satisfying a nontrivial +linear recurrence is a rational function: there exist coprime +polynomials `P, Q` with constant terms 1, `deg P ≤ b`, `deg Q ≤ a`, +such that `H · ↑Q = ↑P` in `ℂ⟦X⟧`. -/ +theorem newtonH_series_rational {t : ℕ → ℂ} {a b : ℕ} + (c : Fin (a + 1) → ℂ) (hc : c ≠ 0) + (hrec : ∀ ρ : ℤ, (b : ℤ) - a ≤ ρ → + ∑ k : Fin (a + 1), c k * newtonHZ t (ρ + 1 + (k : ℤ)) = 0) : + ∃ P Q : Polynomial ℂ, + P.coeff 0 = 1 ∧ Q.coeff 0 = 1 ∧ + P.natDegree ≤ b ∧ Q.natDegree ≤ a ∧ + IsCoprime P Q ∧ + newtonHSeries t * (↑Q : ℂ⟦X⟧) = ↑P := by + -- Get raw truncated pair + obtain ⟨Q, P, hQ_ne, hP_ne, hQH, hQ_deg, hP_deg⟩ := + truncated_product_from_recurrence c hc hrec + -- Get coprime pair with nonzero constant coefficients + obtain ⟨Q₀, P₀, hQ0_ne, hP0_ne, hcop, hQ0H, hQ0c, hP0c, + hQ0_deg_le, hP0_deg_le⟩ := coprime_pair_from_product Q P hQ_ne hP_ne hQH + -- Constant coefficients are equal (since H has constant coeff 1) + have hcoeff_eq : Q₀.coeff 0 = P₀.coeff 0 := by + have := congr_arg PowerSeries.constantCoeff hQ0H + simp only [map_mul, Polynomial.constantCoeff_coe] at this + rwa [newtonH_series_constantCoeff, mul_one] at this + -- Normalise to constant term 1 + set u := Q₀.coeff 0 with hu_def + have hu_ne : u ≠ 0 := hQ0c + set P' := Polynomial.C u⁻¹ * P₀ with hP'_def + set Q' := Polynomial.C u⁻¹ * Q₀ with hQ'_def + refine ⟨P', Q', ?_, ?_, ?_, ?_, ?_, ?_⟩ + -- P'.coeff 0 = 1 + · rw [hP'_def, Polynomial.coeff_C_mul, ← hcoeff_eq, inv_mul_cancel₀ hu_ne] + -- Q'.coeff 0 = 1 + · rw [hQ'_def, Polynomial.coeff_C_mul, inv_mul_cancel₀ hu_ne] + -- P'.natDegree ≤ b + · calc P'.natDegree ≤ P₀.natDegree := Polynomial.natDegree_C_mul_le _ _ + _ ≤ P.natDegree := hP0_deg_le + _ ≤ b := hP_deg + -- Q'.natDegree ≤ a + · calc Q'.natDegree ≤ Q₀.natDegree := Polynomial.natDegree_C_mul_le _ _ + _ ≤ Q.natDegree := hQ0_deg_le + _ ≤ a := hQ_deg + -- IsCoprime P' Q' + · have hCu : IsUnit (Polynomial.C u⁻¹ : ℂ[X]) := by + rw [Polynomial.isUnit_C] + exact isUnit_iff_ne_zero.mpr (inv_ne_zero hu_ne) + exact (isCoprime_mul_units_left hCu hCu P₀ Q₀).mpr hcop + -- H * ↑Q' = ↑P' + · have : (↑Q' : ℂ⟦X⟧) * newtonHSeries t = ↑P' := by + simp only [hQ'_def, hP'_def, Polynomial.coe_mul, Polynomial.coe_C] + rw [mul_assoc, hQ0H] + rw [mul_comm] at this + exact this + +/-- If the Schur specialization vanishes outside the `(a, b)` hook, +the Newton generating series is a rational function `P / Q` with +coprime numerator/denominator of constant term 1. -/ +theorem newtonH_series_rational_of_hook_vanishing {t : ℕ → ℂ} {a b : ℕ} + (hvan : ∀ μ : YoungDiagram, ¬ IsInHook a b μ → diagramSchur μ t = 0) : + ∃ P Q : Polynomial ℂ, P.coeff 0 = 1 ∧ Q.coeff 0 = 1 ∧ + P.natDegree ≤ b ∧ Q.natDegree ≤ a ∧ IsCoprime P Q ∧ + newtonHSeries t * (↑Q : ℂ⟦X⟧) = (↑P : ℂ⟦X⟧) := by + -- Bridge hook vanishing to the list-form used by the recurrence extractor + have hlist : ∀ w : List ℕ, w.SortedGE → (∀ x ∈ w, 0 < x) → + w.length = a + 1 → b + 1 ≤ w.getD a 0 → schurDet t w = 0 := by + intro w hw hpos hlen hlast + set μ := YoungDiagram.ofRowLens w hw with hμ_def + have hrows : μ.rowLens = w := + YoungDiagram.rowLens_ofRowLens_eq_self hpos + have hout : ¬ IsInHook a b μ := by + rw [not_isInHook_iff, hμ_def, rowLen_ofRowLens_getD] + omega + have := hvan μ hout + rwa [diagramSchur, hrows] at this + -- Extract the recurrence + obtain ⟨c, hc, hrec⟩ := exists_recurrence_of_schurDet_vanishing hlist + -- Apply the rationality theorem + exact newtonH_series_rational c hc hrec + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaSeries.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaSeries.lean new file mode 100644 index 0000000000..3445495454 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaSeries.lean @@ -0,0 +1,89 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums + +/-! +# Zeta series characterization + +The Newton generating series `newtonHSeries t` is the unique power +series with constant term 1 satisfying the trace-zeta differential +equation `H' = S · H`, where `S = powerSumSeries t` is the shifted +power-sum series. This file establishes the ODE-uniqueness principle +for formal power series over ℂ and applies it to characterize the +Newton series. +-/ + +@[expose] public section + +namespace RS + +open Finset PowerSeries + +/-! ### ODE uniqueness for formal power series -/ + +/-- **ODE uniqueness for formal power series over ℂ.** +If two power series `F` and `G` both have constant term `1` and +satisfy the same first-order linear ODE `F' = S · F`, then `F = G`. + +Proof: coefficient induction. The ODE implies +`(n+1) · coeff (n+1) F = ∑_{i+j=n} coeff i S · coeff j F`; +since all coefficients up to `n` agree by the inductive hypothesis, +the sums for `F` and `G` coincide, and `(n+1) ≠ 0` in `ℂ` allows +cancellation. -/ +theorem powerSeries_ode_unique {F G S : PowerSeries ℂ} + (hF0 : constantCoeff F = 1) + (hG0 : constantCoeff G = 1) + (hF : (PowerSeries.derivative (R := ℂ)) F = S * F) + (hG : (PowerSeries.derivative (R := ℂ)) G = S * G) : F = G := by + ext n + induction n using Nat.strongRecOn with + | _ n ih => + match n with + | 0 => + rw [coeff_zero_eq_constantCoeff_apply, hF0, + coeff_zero_eq_constantCoeff_apply, hG0] + | n + 1 => + have hFn : coeff n ((PowerSeries.derivative (R := ℂ)) F) = coeff n (S * F) := + congr_arg (coeff n) hF + have hGn : coeff n ((PowerSeries.derivative (R := ℂ)) G) = coeff n (S * G) := + congr_arg (coeff n) hG + rw [coeff_derivative] at hFn hGn + rw [coeff_mul] at hFn hGn + have heq : ∑ p ∈ antidiagonal n, coeff p.1 S * coeff p.2 F = + ∑ p ∈ antidiagonal n, coeff p.1 S * coeff p.2 G := by + apply Finset.sum_congr rfl + intro ⟨i, j⟩ hij + congr 1 + exact ih j (by have := mem_antidiagonal.mp hij; omega) + have hne : (↑n + 1 : ℂ) ≠ 0 := by + exact_mod_cast Nat.succ_ne_zero n + exact mul_right_cancel₀ hne (hFn.trans (heq.trans hGn.symm)) + +/-! ### The Newton ODE -/ + +/-- The Newton generating series satisfies the trace-zeta ODE: +`d⁄dX (newtonHSeries t) = powerSumSeries t * newtonHSeries t`. +This is a re-export of `newtonH_derivative`. -/ +theorem newtonH_series_ode (t : ℕ → ℂ) : + (PowerSeries.derivative (R := ℂ)) (newtonHSeries t) = powerSumSeries t * newtonHSeries t := + newtonH_derivative t + +/-! ### The zeta characterization -/ + +/-- Any power series with constant term 1 satisfying the trace-zeta +differential equation is the Newton series: the trace zeta function +IS the complete homogeneous generating function. -/ +theorem eq_newtonH_series_of_ode {t : ℕ → ℂ} {F : PowerSeries ℂ} + (hF0 : constantCoeff F = 1) + (hF : (PowerSeries.derivative (R := ℂ)) F = powerSumSeries t * F) : + F = newtonHSeries t := + powerSeries_ode_unique hF0 (newtonH_series_constantCoeff t) hF + (newtonH_series_ode t) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Common.lean b/LeanPool/RegtsSevenster/RS/Common.lean new file mode 100644 index 0000000000..0304daf722 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common.lean @@ -0,0 +1,26 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.NilpotentMap +public import LeanPool.RegtsSevenster.RS.Common.ListPairs +public import LeanPool.RegtsSevenster.RS.Common.FinSlots +public import LeanPool.RegtsSevenster.RS.Common.DiagramChain +public import LeanPool.RegtsSevenster.RS.Common.ExponentialGrowth +public import LeanPool.RegtsSevenster.RS.Common.FactorialBound +public import LeanPool.RegtsSevenster.RS.Common.ListAttach +public import LeanPool.RegtsSevenster.RS.Common.ListSign +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +public import LeanPool.RegtsSevenster.RS.Common.NilpotentPowerTrace +public import LeanPool.RegtsSevenster.RS.Common.PairDisjoint +public import LeanPool.RegtsSevenster.RS.Common.PermCongr +public import LeanPool.RegtsSevenster.RS.Common.PermTopSplit +public import LeanPool.RegtsSevenster.RS.Common.ProdSum +public import LeanPool.RegtsSevenster.RS.Common.RowLenChain +public import LeanPool.RegtsSevenster.RS.Common.RowSpanRank +public import LeanPool.RegtsSevenster.RS.Common.TraceSeparation +public import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams diff --git a/LeanPool/RegtsSevenster/RS/Common/DiagramChain.lean b/LeanPool/RegtsSevenster/RS/Common/DiagramChain.lean new file mode 100644 index 0000000000..09b61ef8c9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/DiagramChain.lean @@ -0,0 +1,81 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams + +/-! +# Single-box interpolation for Young diagrams + +Given `lam ≤ mu` with `lam.card < mu.card`, we produce `nu` satisfying +`lam ≤ nu ≤ mu` and `nu.card = lam.card + 1`. The idea is to pick a +cell in `mu.cells \ lam.cells` that is minimal for the sum of +coordinates, then insert it into `lam`. +-/ + +@[expose] public section + +namespace RS + +open Finset in +/-- **Single-box interpolation**: a strictly larger diagram can be +reached one cell at a time. -/ +theorem exists_intermediate_diagram {lam mu : YoungDiagram} + (hle : lam ≤ mu) (hlt : lam.card < mu.card) : + ∃ nu : YoungDiagram, lam ≤ nu ∧ nu ≤ mu ∧ nu.card = lam.card + 1 := by + -- The difference mu.cells \ lam.cells is nonempty + have hdiff : (mu.cells \ lam.cells).Nonempty := + sdiff_nonempty_of_card_lt_card hlt + -- Pick c in the difference minimizing c.1 + c.2 + obtain ⟨c, hc_mem, hc_min⟩ := + (mu.cells \ lam.cells).exists_min_image (fun c => c.1 + c.2) hdiff + rw [mem_sdiff] at hc_mem + obtain ⟨hc_mu, hc_nlam⟩ := hc_mem + -- Build nu + refine ⟨⟨insert c lam.cells, ?_⟩, ?_, ?_, ?_⟩ + · -- isLowerSet (∀ ⦃a b⦄, b ≤ a → a ∈ s → b ∈ s): insert c lam.cells is a + -- lower set + intro a b hba hmem_a + simp only [Finset.mem_coe, Finset.mem_insert] at hmem_a ⊢ + -- a is in the set, b ≤ a, show b is in the set + rcases hmem_a with rfl | hlam_a + · -- a = c (after rfl, c is replaced by a); show b ∈ insert a lam.cells + -- hba : b ≤ a, hc_mu : a ∈ mu (c was replaced by a) + by_cases heq : b = a + · exact Or.inl heq + · -- b ≠ a, and b ≤ a componentwise + right + -- b ∈ mu by mu's lower-set property + have hb_mu : (b : ℕ × ℕ) ∈ mu := mu.isLowerSet hba hc_mu + -- If b ∉ lam, it would be in the difference with smaller sum, + -- contradicting minimality + by_contra hb_nlam + have hb_diff : b ∈ mu.cells \ lam.cells := + mem_sdiff.mpr ⟨hb_mu, hb_nlam⟩ + -- hc_min (with c replaced by a): a.1 + a.2 ≤ b.1 + b.2 + have hle_sum : a.1 + a.2 ≤ b.1 + b.2 := hc_min b hb_diff + have hb1 : b.1 ≤ a.1 := (Prod.le_def.mp hba).1 + have hb2 : b.2 ≤ a.2 := (Prod.le_def.mp hba).2 + exact heq (Prod.ext (le_antisymm hb1 (by omega)) (le_antisymm hb2 (by + omega))) + · -- a is in lam; use lam's lower-set property + exact Or.inr (lam.isLowerSet hba hlam_a) + · -- lam ≤ nu: lam.cells ⊆ insert c lam.cells + intro x hx + change x ∈ (insert c lam.cells : Finset _) + exact mem_insert.mpr (Or.inr hx) + · -- nu ≤ mu: insert c lam.cells ⊆ mu.cells + intro x hx + have hx' : x ∈ (insert c lam.cells : Finset _) := hx + rcases mem_insert.mp hx' with rfl | hlam + · exact hc_mu + · exact hle hlam + · -- nu.card = lam.card + 1 + change (insert c lam.cells).card = lam.cells.card + 1 + exact card_insert_of_notMem hc_nlam + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Common/ExponentialGrowth.lean b/LeanPool/RegtsSevenster/RS/Common/ExponentialGrowth.lean new file mode 100644 index 0000000000..c555274d77 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/ExponentialGrowth.lean @@ -0,0 +1,108 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Comparing exponential bases with polynomial factors + +A fixed polynomial factor cannot compensate for a larger exponential +base. This form applies directly to tensor-dimension estimates. +-/ + +@[expose] public section + +namespace RS + +/-- An exponential bounded by another exponential times a fixed +polynomial has no larger base. -/ +theorem le_of_pow_le_pow_mul_polynomial (a b d : ℕ) + (h : ∀ n : ℕ, a ^ n ≤ b ^ n * (n + 1) ^ d) : a ≤ b := by + by_contra hab + have hba : b < a := by omega + have ha : (0 : ℝ) < a := by exact_mod_cast (by omega : 0 < a) + by_cases hb : b = 0 + · have h1 := h 1 + simp [hb] at h1 + omega + have hbpos : (0 : ℝ) < b := by + exact_mod_cast Nat.pos_of_ne_zero hb + let r : ℝ := b / a + have hrpos : 0 < r := div_pos hbpos ha + have hrlt : r < 1 := by + rw [div_lt_one ha] + exact_mod_cast hba + have hlim : Filter.Tendsto + (fun n : ℕ => ((n + 1 : ℕ) : ℝ) ^ d * r ^ n) + Filter.atTop (nhds 0) := by + have ht := ((tendsto_pow_const_mul_const_pow_of_lt_one d + hrpos.le hrlt).comp (Filter.tendsto_add_atTop_nat 1)).div_const r + simpa [Function.comp_def, pow_succ, ← mul_assoc, hrpos.ne'] using ht + obtain ⟨n, hn⟩ := (hlim.eventually (gt_mem_nhds + (show (0 : ℝ) < 1 by norm_num))).exists + have hreal : (a : ℝ) ^ n ≤ (b : ℝ) ^ n * (n + 1 : ℝ) ^ d := by + exact_mod_cast h n + have hquot : 1 ≤ (n + 1 : ℝ) ^ d * r ^ n := by + dsimp only [r] + rw [div_pow, ← mul_div_assoc] + apply (le_div_iff₀ (pow_pos ha n)).mpr + simpa [mul_comm] using hreal + exact (not_lt_of_ge hquot) (by exact_mod_cast hn) + +/-- Taking even roots removes a fixed polynomial loss from an +exponential sandwich, including when the exponential base is zero. -/ +theorem tendsto_even_root_of_polynomial_bounds + (a : ℕ → ℕ) (d c : ℕ) + (hlower : ∀ n, d ^ (2 * n) ≤ a n * (n + 1) ^ c) + (hupper : ∀ n, a n ≤ d ^ (2 * n)) : + Filter.Tendsto (fun n => (a n : ℝ) ^ ((2 * n : ℕ) : ℝ)⁻¹) + Filter.atTop (nhds (d : ℝ)) := by + let p : ℕ → ℝ := fun n => + (n + 1 : ℝ) ^ ((c : ℝ) / (2 * n)) + have hpoly : Filter.Tendsto p Filter.atTop (nhds 1) := by + have h := (tendsto_rpow_div_mul_add (c : ℝ) 2 (-2) + (by norm_num)).comp + (tendsto_natCast_atTop_atTop.comp + (Filter.tendsto_add_atTop_nat 1)) + convert h using 1 + funext n + simp only [p, Function.comp_apply, Nat.cast_add, Nat.cast_one] + congr 2 + ring + have hlowerLimit : Filter.Tendsto (fun n => (d : ℝ) / p n) + Filter.atTop (nhds (d : ℝ)) := by + have hlim := (tendsto_const_nhds (x := (d : ℝ))).div hpoly (by norm_num) + change Filter.Tendsto (fun n ↦ (d : ℝ) / p n) Filter.atTop + (nhds ((d : ℝ) / 1)) at hlim + simpa only [div_one] using hlim + apply tendsto_of_tendsto_of_tendsto_of_le_of_le' + hlowerLimit tendsto_const_nhds + · filter_upwards [Filter.eventually_ge_atTop 1] with n hn + have hnzero : 2 * n ≠ 0 := by omega + have hp : 0 < p n := Real.rpow_pos_of_pos (by positivity) _ + apply (div_le_iff₀ hp).mpr + have hreal : (d : ℝ) ^ (2 * n) ≤ + (a n : ℝ) * (n + 1 : ℝ) ^ c := by + exact_mod_cast hlower n + have h := Real.rpow_le_rpow (by positivity) hreal + (show (0 : ℝ) ≤ ((2 * n : ℕ) : ℝ)⁻¹ by positivity) + rw [Real.pow_rpow_inv_natCast (by positivity) hnzero, + Real.mul_rpow (by positivity) (by positivity), + ← Real.rpow_natCast (n + 1 : ℝ) c, + ← Real.rpow_mul (by positivity)] at h + simpa [p, div_eq_mul_inv, Nat.cast_mul] using h + · filter_upwards [Filter.eventually_ge_atTop 1] with n hn + have hnzero : 2 * n ≠ 0 := by omega + have hreal : (a n : ℝ) ≤ (d : ℝ) ^ (2 * n) := by + exact_mod_cast hupper n + have h := Real.rpow_le_rpow (by positivity) hreal + (show (0 : ℝ) ≤ ((2 * n : ℕ) : ℝ)⁻¹ by positivity) + simpa only [Real.pow_rpow_inv_natCast + (show (0 : ℝ) ≤ d by positivity) hnzero] using h + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Common/FactorialBound.lean b/LeanPool/RegtsSevenster/RS/Common/FactorialBound.lean new file mode 100644 index 0000000000..aa37707669 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/FactorialBound.lean @@ -0,0 +1,145 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# `n ^ n ≤ 3 ^ n · n !` + +The crude exponential comparison behind the Schur package's +square-dimension growth, proved over ℕ so that the package's +arithmetic stays integral. + +The route is elementary: expand `(n + 1) ^ n` binomially, observe +that from the second term on each term is at most half the one +before it (the identity `C(n,k+1)·(k+1) = C(n,k)·(n−k)`), and sum a +halving sequence to at most twice its first term. That gives +`(n + 1) ^ n ≤ 3 · n ^ n`, and induction turns it into the stated +bound. + +The constant `3` is deliberate slack: this bound only has to beat +*some* exponential. The sharp comparison `n ^ n ≤ e ^ n · n !`, +which the `⌊2eR⌋` threshold does need, is +`pow_le_exp_mul_factorial` in +`RS/Classical/SchurTheory/SquareGrowthSharp.lean`. +-/ + +@[expose] public section + +namespace RS + +open Finset Nat + +/-! ## Geometric-sum bound + +If a sequence halves at each step, the partial sum is at most twice the +first term. -/ + +/-- If `2 * f(i+1) ≤ f(i)` for all `i`, then +`∑ i in range (m+1), f i ≤ 2 * f 0`. -/ +theorem sum_le_two_mul_first (m : ℕ) : + ∀ (f : ℕ → ℕ), (∀ i, 2 * f (i + 1) ≤ f i) → + ∑ i ∈ Finset.range (m + 1), f i ≤ 2 * f 0 := by + induction m with + | zero => intro f _; simp; omega + | succ m ih => + intro f hf + rw [Finset.sum_range_succ' f (m + 1)] + have ih_shifted := ih (fun j => f (j + 1)) (fun i => hf (i + 1)) + change ∑ i ∈ Finset.range (m + 1), f (i + 1) ≤ 2 * f 1 at ih_shifted + have h2 : 2 * f 1 ≤ f 0 := hf 0 + omega + +/-! ## Ratio bound for binomial-expansion terms + +Each successive term in the expansion of `(N+1)^N` is at most half the previous, +starting from the second term. The proof pivots on the identity +`choose N (k+1) * (k+1) = choose N k * (N - k)`. -/ + +/-- For `k ≥ 1` and `k + 1 ≤ N`, consecutive binomial-expansion terms satisfy +`2 * (C(N,k+1) * N^(N-k-1)) ≤ C(N,k) * N^(N-k)`. -/ +theorem binom_term_ratio (N k : ℕ) (hk : 1 ≤ k) (hkN : k + 1 ≤ N) : + 2 * (N.choose (k + 1) * N ^ (N - (k + 1))) ≤ N.choose k * N ^ (N - k) := by + have h_pow : N - k = N - (k + 1) + 1 := by omega + rw [h_pow, pow_succ] + have h1 : 2 * N.choose (k + 1) ≤ N * N.choose k := by + have h := Nat.choose_succ_right_eq N k + calc 2 * N.choose (k + 1) + ≤ (k + 1) * N.choose (k + 1) := by apply Nat.mul_le_mul_right; omega + _ = N.choose k * (N - k) := by linarith + _ ≤ N.choose k * N := Nat.mul_le_mul_left _ (Nat.sub_le N k) + _ = N * N.choose k := Nat.mul_comm _ _ + calc 2 * (N.choose (k + 1) * N ^ (N - (k + 1))) + = (2 * N.choose (k + 1)) * N ^ (N - (k + 1)) := by ring + _ ≤ (N * N.choose k) * N ^ (N - (k + 1)) := Nat.mul_le_mul_right _ h1 + _ = N.choose k * (N ^ (N - (k + 1)) * N) := by ring + +/-! ## Sub-lemma: `(n+1)^n ≤ 3 * n^n` + +Expand `(n+1)^n` via the binomial theorem; the `m = 0` and `m = 1` terms each +contribute `n^n`, and the remaining terms form a geometrically decaying sum +bounded by `n^n`, for a total of at most `3 * n^n`. -/ + +/-- `(n + 1) ^ n ≤ 3 * n ^ n` for all natural numbers `n`. -/ +theorem succ_pow_le_three_mul_pow (n : ℕ) : (n + 1) ^ n ≤ 3 * n ^ n := by + rcases n with _ | n + · simp + set N := n + 1 with hN_def + -- Binomial expansion: (1 + N)^N = ∑ m in range (N+1), N^(N-m) * C(N,m) + have binom : (N + 1) ^ N = + ∑ m ∈ range (N + 1), N ^ (N - m) * (N.choose m) := by + have := add_pow (1 : ℕ) N N + simp only [one_pow, one_mul, add_comm 1 N] at this + exact this + rw [binom] + -- Peel off the m = 0 term (= N^N) + rw [Finset.sum_range_succ' (fun m => N ^ (N - m) * N.choose m) N] + simp only [Nat.sub_zero, choose_zero_right, Nat.mul_one] + -- Goal: ∑ k in range N, N^(N-(k+1)) * C(N,k+1) + N^N ≤ 3 * N^N + suffices h : ∑ k ∈ range N, N ^ (N - (k + 1)) * N.choose (k + 1) ≤ 2 * N ^ N + by omega + -- The terms halve: 2 * term(i+1) ≤ term(i) + have hf_ratio : ∀ i, 2 * (N ^ (N - (i + 1 + 1)) * N.choose (i + 1 + 1)) ≤ + N ^ (N - (i + 1)) * N.choose (i + 1) := by + intro i + by_cases h : i + 2 ≤ N + · have := binom_term_ratio N (i + 1) (by omega) h + calc 2 * (N ^ (N - (i + 1 + 1)) * N.choose (i + 1 + 1)) + = 2 * (N.choose (i + 1 + 1) * N ^ (N - (i + 1 + 1))) := by ring + _ ≤ N.choose (i + 1) * N ^ (N - (i + 1)) := this + _ = N ^ (N - (i + 1)) * N.choose (i + 1) := by ring + · have : N.choose (i + 2) = 0 := Nat.choose_eq_zero_of_lt (by omega) + simp [show i + 1 + 1 = i + 2 from by ring, this] + -- Apply the geometric-sum bound + have key := sum_le_two_mul_first n + (fun i => N ^ (N - (i + 1)) * N.choose (i + 1)) hf_ratio + -- The first term f(0) = N^(N-1) * C(N,1) = N^(N-1) * N = N^N + have hf0 : N ^ (N - (0 + 1)) * N.choose (0 + 1) = N ^ N := by + rw [Nat.choose_one_right, show N - (0 + 1) = n from by omega] + exact (pow_succ _ _).symm + rw [show n + 1 = N from rfl, hf0] at key + exact key + +/-! ## Main theorem -/ + +/-- `n ^ n ≤ 3 ^ n * n!` for all natural numbers `n`. -/ +theorem three_pow_mul_factorial_ge (n : ℕ) : n ^ n ≤ 3 ^ n * n.factorial := by + induction n with + | zero => simp + | succ n ih => + rw [pow_succ, Nat.factorial_succ, pow_succ] + -- Goal: (n+1)^n * (n+1) ≤ 3^n * 3 * ((n+1) * n!) + calc (n + 1) ^ n * (n + 1) + ≤ 3 * n ^ n * (n + 1) := Nat.mul_le_mul_right _ + (succ_pow_le_three_mul_pow n) + _ = (n + 1) * (3 * n ^ n) := by ring + _ ≤ (n + 1) * (3 * (3 ^ n * n !)) := by + apply Nat.mul_le_mul_left; exact Nat.mul_le_mul_left _ ih + _ = 3 ^ n * 3 * ((n + 1) * n !) := by ring + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Common/FinSlots.lean b/LeanPool/RegtsSevenster/RS/Common/FinSlots.lean new file mode 100644 index 0000000000..d748e16820 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/FinSlots.lean @@ -0,0 +1,30 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Disjoint halves of a finite index set + +The two inclusions of an index into the doubled finite set have +distinct values. +-/ + +@[expose] public section + +namespace RS + +/-- The two inclusions of the same finite index have distinct values. -/ +theorem castAdd_ne_natAdd {n : ℕ} (i : Fin n) : + Fin.castAdd n i ≠ Fin.natAdd n i := by + intro h + have hval := congrArg Fin.val h + simp only [Fin.val_castAdd, Fin.val_natAdd] at hval + omega + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Common/ListAttach.lean b/LeanPool/RegtsSevenster/RS/Common/ListAttach.lean new file mode 100644 index 0000000000..52af24efd8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/ListAttach.lean @@ -0,0 +1,46 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Attached lists and list-to-finset products + +Two facts used wherever a proof enumerates a finite set as a list +and then maps or multiplies over it: mapping a function defined on +the attached subtype agrees with mapping the total function, and a +list product is the finset product of the finset the list +enumerates. +-/ + +@[expose] public section + +namespace RS + +/-- Mapping over an attached list agrees with mapping the total +function, when the two agree pointwise. -/ +theorem attachWith_map_eq {β γ : Type*} {p : β → Prop} + (fsub : {g : β // p g} → γ) (ftot : β → γ) + (hpt : ∀ (g : β) (hg : p g), fsub ⟨g, hg⟩ = ftot g) : + ∀ (l : List β) (H : ∀ g ∈ l, p g), + (l.attachWith p H).map fsub = l.map ftot + | [], _ => rfl + | g :: t, H => by + rw [List.attachWith_cons, List.map_cons, List.map_cons, hpt, + attachWith_map_eq fsub ftot hpt t _] + +/-- A list product is the finset product of the finset the list +enumerates. -/ +theorem list_map_prod_eq_finset_prod {β M : Type*} [CommMonoid M] + (s : Finset β) (l : List β) + (hl : (↑l : Multiset β) = s.val) (f : β → M) : + (l.map f).prod = ∏ g ∈ s, f g := by + rw [← Multiset.prod_coe, ← Multiset.map_coe, hl] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Common/ListPairs.lean b/LeanPool/RegtsSevenster/RS/Common/ListPairs.lean new file mode 100644 index 0000000000..61670ed0c1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/ListPairs.lean @@ -0,0 +1,99 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Length and indexing of concatenated pairs + +Flattening a list of two-element blocks doubles its length and +places the two components at the even and odd positions. +-/ + +@[expose] public section + +namespace RS + +/-- A list of pairs has twice as many entries as its source. -/ +theorem len_flatMap_pair {α β : Type*} (L : List α) (f g : α → β) : + (L.flatMap (fun x => [f x, g x])).length = 2 * L.length := by + induction L with + | nil => simp + | cons a t ih => simp [List.flatMap_cons, ih]; omega + +-- The index arithmetic under the flat-map is +-- carried through a list induction. +/-- Even positions in a list of pairs come from the first component. -/ +theorem getElem?_flatMap_pair_even {α β : Type*} + (L : List α) (f g : α → β) (j : ℕ) : + (L.flatMap (fun x => [f x, g x]))[2 * j]? = L[j]?.map f := by + induction L generalizing j with + | nil => simp + | cons a t ih => + rw [List.flatMap_cons]; cases j with + | zero => simp + | succ j => + rw [show 2 * (j + 1) = 2 + 2 * j from by omega, + List.getElem?_append_right + (show ([f a, g a] : List _).length ≤ 2 + 2 * j from by simp)] + simp only [show ([f a, g a] : List _).length = 2 from rfl, + show 2 + 2 * j - 2 = 2 * j from by omega, + List.getElem?_cons_succ] + exact ih j + +-- As for the even positions. +/-- Odd positions in a list of pairs come from the second component. -/ +theorem getElem?_flatMap_pair_odd {α β : Type*} + (L : List α) (f g : α → β) (j : ℕ) : + (L.flatMap (fun x => [f x, g x]))[2 * j + 1]? = L[j]?.map g := by + induction L generalizing j with + | nil => simp + | cons a t ih => + rw [List.flatMap_cons]; cases j with + | zero => simp + | succ j => + rw [show 2 * (j + 1) + 1 = 2 + (2 * j + 1) from by omega, + List.getElem?_append_right + (show ([f a, g a] : List _).length ≤ 2 + (2 * j + 1) from by simp)] + simp only [show ([f a, g a] : List _).length = 2 from rfl, + show 2 + (2 * j + 1) - 2 = 2 * j + 1 from by omega, + List.getElem?_cons_succ] + exact ih j + +/-- In a flatMap of [x, h x] blocks, element 2j+1 is h applied to element 2j. -/ +theorem getElem?_self_paired {α : Type*} + (L : List α) (h : α → α) (j : ℕ) : + (L.flatMap (fun x => [x, h x]))[2 * j + 1]? = + (L.flatMap (fun x => [x, h x]))[2 * j]?.map h := by + have key : (fun x => ([x, h x] : List α)) = (fun x => [id x, h x]) := by + ext; simp + rw [key, getElem?_flatMap_pair_even L id h j, + getElem?_flatMap_pair_odd L id h j, Option.map_map] + simp + +/-- The entry at an even position is the first component. -/ +theorem getElem_flatMap_pair_even {α β : Type*} + (L : List α) (f g : α → β) (j : ℕ) (hj : j < L.length) : + (L.flatMap (fun x => [f x, g x]))[2 * j]'(by + rw [len_flatMap_pair]; omega) = f L[j] := by + have h := getElem?_flatMap_pair_even L f g j + rw [List.getElem?_eq_getElem (by rw [len_flatMap_pair]; omega), + List.getElem?_eq_getElem hj] at h + exact Option.some.inj h + +/-- The entry at an odd position is the second component. -/ +theorem getElem_flatMap_pair_odd {α β : Type*} + (L : List α) (f g : α → β) (j : ℕ) (hj : j < L.length) : + (L.flatMap (fun x => [f x, g x]))[2 * j + 1]'(by + rw [len_flatMap_pair]; omega) = g L[j] := by + have h := getElem?_flatMap_pair_odd L f g j + rw [List.getElem?_eq_getElem (by rw [len_flatMap_pair]; omega), + List.getElem?_eq_getElem hj] at h + exact Option.some.inj h + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Common/ListSign.lean b/LeanPool/RegtsSevenster/RS/Common/ListSign.lean new file mode 100644 index 0000000000..8e8877aa13 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/ListSign.lean @@ -0,0 +1,131 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Definitions + +/-! +# Inversions and the sorting sign + +The calculus of the sorting sign (`inversions` and `sortSign` are +defined in `RS/Definitions.lean`): the sign is antisymmetric under +adjacent transpositions of distinct elements, which is the +combinatorial engine of the alternating evaluation of mixed vertex +functionals. +-/ + +@[expose] public section + +namespace RS + +/-- Sorting signs square to one over ℂ. -/ +theorem sortSign_sq {α : Type} [LinearOrder α] (l : List α) : + (sortSign l : ℂ) * (sortSign l : ℂ) = 1 := by + rw [sortSign] + push_cast + rw [← pow_add, ← two_mul, pow_mul] + norm_num + +/-- Increasing embeddings preserve inversion counts. -/ +theorem inversions_map_orderEmbedding {α β : Type} + [LinearOrder α] [LinearOrder β] (e : α ↪o β) (l : List α) : + inversions (l.map e) = inversions l := by + induction l with + | nil => rfl + | cons a l ih => + simp only [List.map_cons, inversions, ih, List.filter_map, + List.length_map, Function.comp_def, e.lt_iff_lt] + +/-- Increasing embeddings preserve the sorting sign. -/ +theorem sortSign_map_orderEmbedding {α β : Type} + [LinearOrder α] [LinearOrder β] (e : α ↪o β) (l : List α) : + sortSign (l.map e) = sortSign l := by + rw [sortSign, inversions_map_orderEmbedding, sortSign] + +/-- Sorted lists have no inversions. -/ +theorem inversions_eq_zero_of_sorted {α : Type} [LinearOrder α] : + ∀ (l : List α), List.Pairwise (· ≤ ·) l → inversions l = 0 + | [], _ => rfl + | a :: l, h => by + rw [inversions] + rw [inversions_eq_zero_of_sorted l h.of_cons] + rw [show l.filter (fun b => b < a) = [] from + List.filter_eq_nil_iff.mpr (fun b hb => by + have hab := (List.pairwise_cons.mp h).1 b hb + simp only [decide_eq_true_eq] + exact not_lt.mpr hab)] + rfl + +/-- Sorted lists have sorting sign one. -/ +theorem sortSign_eq_one_of_sorted {α : Type} [LinearOrder α] + (l : List α) (h : List.Pairwise (· ≤ ·) l) : + sortSign l = 1 := by + rw [sortSign, inversions_eq_zero_of_sorted l h] + rfl + +/-- Inversion counts are invariant under permuting the tail past a +fixed head-filter: permuted lists have equal filter lengths. -/ +theorem filter_length_of_perm {α : Type} (p : α → Bool) + {l₁ l₂ : List α} (h : l₁.Perm l₂) : + (l₁.filter p).length = (l₂.filter p).length := + (h.filter p).length_eq + +/-- Swapping two distinct adjacent elements flips the sorting +sign. -/ +theorem sortSign_swap_adjacent {α : Type} [LinearOrder α] + (l₁ l₂ : List α) {a b : α} (hab : a ≠ b) : + sortSign (l₁ ++ b :: a :: l₂) = -sortSign (l₁ ++ a :: b :: l₂) := by + induction l₁ with + | nil => + simp only [List.nil_append, sortSign, inversions] + rcases lt_trichotomy a b with h | h | h + · rw [show (List.filter (fun x => decide (x < b)) (a :: l₂)).length = + (List.filter (fun x => decide (x < b)) l₂).length + 1 from by + simp [h], + show (List.filter (fun x => decide (x < a)) (b :: l₂)).length = + (List.filter (fun x => decide (x < a)) l₂).length from by + simp [not_lt.mpr h.le]] + ring + · exact absurd h hab + · rw [show (List.filter (fun x => decide (x < a)) (b :: l₂)).length = + (List.filter (fun x => decide (x < a)) l₂).length + 1 from by + simp [h], + show (List.filter (fun x => decide (x < b)) (a :: l₂)).length = + (List.filter (fun x => decide (x < b)) l₂).length from by + simp [not_lt.mpr h.le]] + ring + | cons c l₁ ih => + simp only [List.cons_append, sortSign, inversions] at ih ⊢ + have hperm : (l₁ ++ b :: a :: l₂).Perm (l₁ ++ a :: b :: l₂) := + List.Perm.append_left l₁ (List.Perm.swap a b l₂) + rw [filter_length_of_perm _ hperm] + rw [pow_add, pow_add, ih] + ring + +/-- Moving a two-element block past another two-element block +preserves the sorting sign: four adjacent transpositions, an even +number of sign flips. -/ +theorem sortSign_pair_block_swap {α : Type} [LinearOrder α] + (l₁ l₂ : List α) {p₁ p₂ q₁ q₂ : α} + (hp₁q₁ : p₁ ≠ q₁) (hp₁q₂ : p₁ ≠ q₂) + (hp₂q₁ : p₂ ≠ q₁) (hp₂q₂ : p₂ ≠ q₂) : + sortSign (l₁ ++ q₁ :: q₂ :: p₁ :: p₂ :: l₂) = + sortSign (l₁ ++ p₁ :: p₂ :: q₁ :: q₂ :: l₂) := by + have s₁ := sortSign_swap_adjacent (l₁ ++ [p₁]) (q₂ :: l₂) + (a := p₂) (b := q₁) hp₂q₁ + have s₂ := sortSign_swap_adjacent l₁ (p₂ :: q₂ :: l₂) + (a := p₁) (b := q₁) hp₁q₁ + have s₃ := sortSign_swap_adjacent (l₁ ++ [q₁, p₁]) l₂ + (a := p₂) (b := q₂) hp₂q₂ + have s₄ := sortSign_swap_adjacent (l₁ ++ [q₁]) (p₂ :: l₂) + (a := p₁) (b := q₂) hp₁q₂ + simp only [List.append_assoc, List.cons_append, List.nil_append] + at s₁ s₂ s₃ s₄ + rw [s₄, s₃, s₂, s₁] + ring + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Common/MathlibDeps.lean b/LeanPool/RegtsSevenster/RS/Common/MathlibDeps.lean new file mode 100644 index 0000000000..58c95b1cc2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/MathlibDeps.lean @@ -0,0 +1,139 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import Mathlib.Algebra.Algebra.Subalgebra.Lattice +public import Mathlib.Algebra.BigOperators.Fin +public import Mathlib.Algebra.Category.FGModuleCat.Abelian +public import Mathlib.Algebra.Category.ModuleCat.Biproducts +public import Mathlib.Algebra.DirectSum.LinearMap +public import Mathlib.Algebra.Group.Even +public import Mathlib.Algebra.Homology.ShortComplex.ExactFunctor +public import Mathlib.Algebra.Homology.ShortComplex.ShortExact +public import Mathlib.Algebra.Module.PUnit +public import Mathlib.Algebra.MonoidAlgebra.Basic +public import Mathlib.Algebra.MonoidAlgebra.Module +public import Mathlib.Analysis.Complex.Cardinality +public import Mathlib.Analysis.Complex.Polynomial.Basic +public import Mathlib.Analysis.SpecialFunctions.Exp +public import Mathlib.CategoryTheory.Abelian.Basic +public import Mathlib.CategoryTheory.Abelian.FunctorCategory +public import Mathlib.CategoryTheory.Abelian.GrothendieckAxioms.Colim +public import Mathlib.CategoryTheory.Abelian.GrothendieckAxioms.Indization +public import Mathlib.CategoryTheory.Abelian.Indization +public import Mathlib.CategoryTheory.Abelian.Transfer +public import Mathlib.CategoryTheory.Filtered.Connected +public import Mathlib.CategoryTheory.Functor.OfSequence +public import Mathlib.CategoryTheory.Generator.Indization +public import Mathlib.CategoryTheory.Idempotents.Biproducts +public import Mathlib.CategoryTheory.Idempotents.Karoubi +public import Mathlib.CategoryTheory.Limits.Indization.Category +public import Mathlib.CategoryTheory.Limits.Shapes.Biproducts +public import Mathlib.CategoryTheory.Limits.Shapes.End +public import Mathlib.CategoryTheory.Linear.LinearFunctor +public import Mathlib.CategoryTheory.Monoidal.Braided.Basic +public import Mathlib.CategoryTheory.Monoidal.Braided.Opposite +public import Mathlib.CategoryTheory.Monoidal.Braided.Transport +public import Mathlib.CategoryTheory.Monoidal.Category +public import Mathlib.CategoryTheory.Monoidal.Closed.Braided +public import Mathlib.CategoryTheory.Monoidal.Closed.Types +public import Mathlib.CategoryTheory.Monoidal.CommMon_ +public import Mathlib.CategoryTheory.Monoidal.DayConvolution.Braided +public import Mathlib.CategoryTheory.Monoidal.DayConvolution.DayFunctor +public import Mathlib.CategoryTheory.Monoidal.Functor +public import Mathlib.CategoryTheory.Monoidal.Linear +public import Mathlib.CategoryTheory.Monoidal.Mod +public import Mathlib.CategoryTheory.Monoidal.Mon +public import Mathlib.CategoryTheory.Monoidal.Preadditive +public import Mathlib.CategoryTheory.Monoidal.Rigid.Basic +public import Mathlib.CategoryTheory.Monoidal.Rigid.Braided +public import Mathlib.CategoryTheory.Monoidal.Subcategory +public import Mathlib.CategoryTheory.Monoidal.Transport +public import Mathlib.CategoryTheory.Preadditive.Mat +public import Mathlib.CategoryTheory.Preadditive.Schur +public import Mathlib.CategoryTheory.Simple +public import Mathlib.CategoryTheory.Subobject.Lattice +public import Mathlib.CategoryTheory.Subobject.Limits +public import Mathlib.Combinatorics.Enumerative.Partition.Basic +public import Mathlib.Combinatorics.Young.YoungDiagram +public import Mathlib.Basic.Complex.Basic +public import Mathlib.Data.Fin.Embedding +public import Mathlib.Data.Fin.Tuple.Sort +public import Mathlib.Data.Finset.Card +public import Mathlib.Data.Finset.Lattice.Basic +public import Mathlib.Data.Finset.NoncommProd +public import Mathlib.Data.Fintype.EquivFin +public import Mathlib.Data.Fintype.Perm +public import Mathlib.FieldTheory.IsAlgClosed.Basic +public import Mathlib.GroupTheory.Perm.Cycle.Basic +public import Mathlib.GroupTheory.Perm.Cycle.Type +public import Mathlib.GroupTheory.Perm.Fin +public import Mathlib.GroupTheory.Perm.ViaEmbedding +public import Mathlib.LinearAlgebra.Basis.VectorSpace +public import Mathlib.LinearAlgebra.BilinearForm.Basic +public import Mathlib.LinearAlgebra.BilinearForm.Orthogonal +public import Mathlib.LinearAlgebra.BilinearForm.Properties +public import Mathlib.LinearAlgebra.Contraction +public import Mathlib.LinearAlgebra.DFinsupp +public import Mathlib.LinearAlgebra.Dimension.Constructions +public import Mathlib.LinearAlgebra.Dimension.Finrank +public import Mathlib.LinearAlgebra.Dimension.Free +public import Mathlib.LinearAlgebra.Dimension.StrongRankCondition +public import Mathlib.LinearAlgebra.Dual.Lemmas +public import Mathlib.LinearAlgebra.Eigenspace.Basic +public import Mathlib.LinearAlgebra.Eigenspace.Triangularizable +public import Mathlib.LinearAlgebra.FiniteDimensional.Defs +public import Mathlib.LinearAlgebra.FiniteDimensional.Lemmas +public import Mathlib.LinearAlgebra.Isomorphisms +public import Mathlib.LinearAlgebra.LinearIndependent.Lemmas +public import Mathlib.LinearAlgebra.Matrix.Determinant.Basic +public import Mathlib.LinearAlgebra.Matrix.NonsingularInverse +public import Mathlib.LinearAlgebra.Matrix.Rank +public import Mathlib.LinearAlgebra.Matrix.ToLin +public import Mathlib.LinearAlgebra.Prod +public import Mathlib.LinearAlgebra.Projection +public import Mathlib.LinearAlgebra.QuadraticForm.Basic +public import Mathlib.LinearAlgebra.TensorProduct.Associator +public import Mathlib.LinearAlgebra.TensorProduct.Finiteness +public import Mathlib.LinearAlgebra.TensorProduct.Prod +public import Mathlib.LinearAlgebra.Trace +public import Mathlib.LinearAlgebra.Vandermonde +public import Mathlib.Logic.Equiv.Fin.Rotate +public import Mathlib.Order.Zorn +public import Mathlib.RepresentationTheory.Basic +public import Mathlib.RepresentationTheory.Character +public import Mathlib.RepresentationTheory.Irreducible +public import Mathlib.RepresentationTheory.Maschke +public import Mathlib.RingTheory.Algebraic.LinearIndependent +public import Mathlib.RingTheory.Artinian.Module +public import Mathlib.RingTheory.Artinian.Ring +public import Mathlib.RingTheory.EuclideanDomain +public import Mathlib.RingTheory.Finiteness.Prod +public import Mathlib.RingTheory.Ideal.Quotient.Operations +public import Mathlib.RingTheory.Idempotents +public import Mathlib.RingTheory.Jacobson.Ring +public import Mathlib.RingTheory.Jacobson.Semiprimary +public import Mathlib.RingTheory.MvPolynomial.Symmetric.NewtonIdentities +public import Mathlib.RingTheory.Polynomial.Vieta +public import Mathlib.RingTheory.PowerSeries.Derivative +public import Mathlib.RingTheory.PowerSeries.Exp +public import Mathlib.RingTheory.PowerSeries.Inverse +public import Mathlib.RingTheory.PowerSeries.Substitution +public import Mathlib.RingTheory.SimpleModule.Basic +public import Mathlib.RingTheory.SimpleModule.IsAlgClosed +public import Mathlib.RingTheory.TensorProduct.Finite +public import Mathlib.SetTheory.Cardinal.Order +public import Mathlib.Tactic.CategoryTheory.Monoidal.Basic +public import Mathlib.Tactic.CategoryTheory.Slice + +/-! +# Mathlib dependencies + +The single funnel for Mathlib imports: every module of this tree +imports Mathlib through this file only, so the development's Mathlib +footprint is auditable at a glance. +-/ diff --git a/LeanPool/RegtsSevenster/RS/Common/NilpotentMap.lean b/LeanPool/RegtsSevenster/RS/Common/NilpotentMap.lean new file mode 100644 index 0000000000..8c4bee16ef --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/NilpotentMap.lean @@ -0,0 +1,36 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Nilpotence under zero-preserving multiplicative maps + +A positive vanishing exponent transports through a multiplicative +map even when that map does not preserve the identity. +-/ + +@[expose] public section + +namespace RS + +/-- A zero-preserving multiplicative map preserves nilpotence. -/ +theorem isNilpotent_map_of_mul_zero {A B : Type*} + [MonoidWithZero A] [MonoidWithZero B] (F : A → B) + (hzero : F 0 = 0) (hmul : ∀ a b, F (a * b) = F a * F b) + {x : A} (hx : IsNilpotent x) : IsNilpotent (F x) := by + obtain ⟨n, hn⟩ := hx + have hpow : ∀ m : ℕ, F (x ^ (m + 1)) = (F x) ^ (m + 1) := by + intro m + induction m with + | zero => simp + | succ m ih => rw [pow_succ, hmul, ih, ← pow_succ] + refine ⟨n + 1, ?_⟩ + rw [← hpow, pow_succ, hn, zero_mul, hzero] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Common/NilpotentPowerTrace.lean b/LeanPool/RegtsSevenster/RS/Common/NilpotentPowerTrace.lean new file mode 100644 index 0000000000..3e11ae9976 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/NilpotentPowerTrace.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# A last nonzero power trace + +If a linear functional is nonzero on a nilpotent element, some +positive power has nonzero value and every higher power of that +element has value zero. This is the reduction in Schrijver's +factorial-rank proof of nilpotent-trace vanishing +(arXiv:1211.3561, Proposition 4). +-/ + +@[expose] public section + +namespace RS + +/-- A nonzero trace whose powers of degree at least two have zero +trace. No normalization of the nonzero value is required. -/ +structure SinglePowerTrace {A : Type*} [Ring A] [Algebra ℂ A] + (τ : A →ₗ[ℂ] ℂ) (y : A) : Prop where + /-- The first power has nonzero trace. -/ + trace_ne_zero : τ y ≠ 0 + /-- All higher powers have zero trace. -/ + higher_eq_zero : ∀ m : ℕ, 2 ≤ m → τ (y ^ m) = 0 + +/-- A nilpotent element with nonzero trace has a positive power +whose first trace is nonzero and whose higher power traces vanish. -/ +theorem exists_singlePowerTrace_pow {A : Type*} [Ring A] [Algebra ℂ A] + (τ : A →ₗ[ℂ] ℂ) {g : A} (hg : IsNilpotent g) (hτ : τ g ≠ 0) : + ∃ r : ℕ, 1 ≤ r ∧ SinglePowerTrace τ (g ^ r) := by + classical + obtain ⟨N, hN⟩ := hg + have hzero : ∀ m, N ≤ m → τ (g ^ m) = 0 := by + intro m hm + have hpow : g ^ m = 0 := by + rw [show m = N + (m - N) from (Nat.add_sub_of_le hm).symm, + pow_add, hN, zero_mul] + rw [hpow, map_zero] + let s := (Finset.range N).filter (fun m => τ (g ^ m) ≠ 0) + have hmem : 1 ∈ s := by + refine Finset.mem_filter.mpr ⟨Finset.mem_range.mpr ?_, ?_⟩ + · by_contra h + exact hτ (by simpa using hzero 1 (by omega)) + · simpa using hτ + have hs : s.Nonempty := ⟨1, hmem⟩ + let r := s.max' hs + have hrmem : r ∈ s := Finset.max'_mem s hs + have hr : 1 ≤ r := Finset.le_max' s 1 hmem + refine ⟨r, hr, ⟨(Finset.mem_filter.mp hrmem).2, ?_⟩⟩ + intro m hm + rw [← pow_mul] + by_cases hlarge : N ≤ r * m + · exact hzero _ hlarge + · by_contra hnonzero + have hprod : r * m ∈ s := + Finset.mem_filter.mpr ⟨Finset.mem_range.mpr (by omega), hnonzero⟩ + have hle : r * m ≤ r := Finset.le_max' s _ hprod + nlinarith + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Common/PairDisjoint.lean b/LeanPool/RegtsSevenster/RS/Common/PairDisjoint.lean new file mode 100644 index 0000000000..e9163df9c7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/PairDisjoint.lean @@ -0,0 +1,50 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Label pairs sharing no label + +One condition recurs wherever pairs of labels are handled: two pairs +have all four of their labels distinct across the pair. It is what +makes a chord diagram well formed, what lets a fold over a list of +pairs be reordered, and what makes the symmetric-difference fold of +a pair list its plain union. It is stated once here, with named +fields, so that the four inequalities are never read off a nested +conjunction by position. +-/ + +@[expose] public section + +namespace RS + +variable {α : Type*} + +/-- **Two label pairs sharing no label.** -/ +structure PairDisjoint (p q : α × α) : Prop where + /-- The first labels differ. -/ + fst_ne_fst : p.1 ≠ q.1 + /-- The first label of `p` is not the second of `q`. -/ + fst_ne_snd : p.1 ≠ q.2 + /-- The second label of `p` is not the first of `q`. -/ + snd_ne_fst : p.2 ≠ q.1 + /-- The second labels differ. -/ + snd_ne_snd : p.2 ≠ q.2 + +/-- Sharing no label survives swapping the ends of the first pair. -/ +theorem PairDisjoint.swap_left {p q : α × α} (h : PairDisjoint p q) : + PairDisjoint p.swap q := + ⟨h.snd_ne_fst, h.snd_ne_snd, h.fst_ne_fst, h.fst_ne_snd⟩ + +/-- Sharing no label survives swapping the ends of the second pair. -/ +theorem PairDisjoint.swap_right {p q : α × α} (h : PairDisjoint p q) : + PairDisjoint p q.swap := + ⟨h.fst_ne_snd, h.fst_ne_fst, h.snd_ne_snd, h.snd_ne_fst⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Common/PermCongr.lean b/LeanPool/RegtsSevenster/RS/Common/PermCongr.lean new file mode 100644 index 0000000000..13db12575c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/PermCongr.lean @@ -0,0 +1,171 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Cycle data under permutation transport + +Transporting a permutation along an equivalence of finite types +preserves its cycle type and its fixed-point count: `permCongr` is +`extendDomain` over the trivial predicate, and `extendDomain` +preserves cycle types. + +The consequences for a sum of permutations follow: the two factors +`sumCongr σ 1` and `sumCongr 1 τ` are disjoint, so a `sumCongr` has +the sum of the two cycle types and the sum of the two fixed-point +counts. +-/ + +@[expose] public section + +namespace RS + +open Equiv Equiv.Perm + +/-- `permCongr` is `extendDomain` along the trivial subtype. -/ +theorem permCongr_eq_extendDomain {α β : Type} + (e : α ≃ β) (π : Equiv.Perm α) : + e.permCongr π = + π.extendDomain + (e.trans (Equiv.subtypeUnivEquiv + (fun _ => trivial : ∀ x : β, (fun _ => True) x)).symm) := by + ext x + rw [Equiv.permCongr_apply, + Equiv.Perm.extendDomain_apply_subtype _ _ (by trivial)] + rfl + +/-- Transporting a permutation preserves its cycle type. -/ +theorem cycleType_permCongr {α β : Type} [Fintype α] + [DecidableEq α] [Fintype β] [DecidableEq β] + (e : α ≃ β) (π : Equiv.Perm α) : + (e.permCongr π).cycleType = π.cycleType := by + rw [permCongr_eq_extendDomain e π, + Equiv.Perm.cycleType_extendDomain] + +/-- Transporting a permutation preserves its fixed points, up to +equivalence. -/ +noncomputable def fixedPointsPermCongrEquiv {α β : Type} + (e : α ≃ β) (π : Equiv.Perm α) : + Function.fixedPoints (e.permCongr π) ≃ Function.fixedPoints π := + (e.subtypeEquiv (fun x => by + simp only [Function.mem_fixedPoints, Function.IsFixedPt, + Equiv.permCongr_apply, Equiv.symm_apply_apply] + exact ⟨fun h => by rw [h], fun h => e.injective h⟩)).symm + +/-- Transporting a permutation preserves the fixed-point count. -/ +theorem card_fixedPoints_permCongr {α β : Type} + (e : α ≃ β) (π : Equiv.Perm α) + [Fintype (Function.fixedPoints π)] + [Fintype (Function.fixedPoints (e.permCongr π))] : + Fintype.card (Function.fixedPoints (e.permCongr π)) = + Fintype.card (Function.fixedPoints π) := + Fintype.card_congr (fixedPointsPermCongrEquiv e π) + +/-- Left factor in a sum preserves cycle type. -/ +theorem cycleType_sumCongr_left {α β : Type} + [Fintype α] [DecidableEq α] [Fintype β] [DecidableEq β] + (σ : Perm α) : + cycleType (Equiv.sumCongr σ (1 : Perm β)) = σ.cycleType := by + -- Identify sumCongr σ 1 with σ.extendDomain via the left-injection + -- We define the equiv α ≃ {x : α ⊕ β // x ∈ Set.range Sum.inl} + let p : α ⊕ β → Prop := fun x => ∃ a, x = Sum.inl a + have hdec : DecidablePred p := fun x => by + rcases x with a | b + · exact isTrue ⟨a, rfl⟩ + · exact isFalse (fun ⟨_, h⟩ => nomatch h) + let e : α ≃ Subtype p := + { toFun := fun a => ⟨Sum.inl a, ⟨a, rfl⟩⟩ + invFun := fun ⟨x, hx⟩ => hx.choose + left_inv := fun a => by simp + right_inv := fun ⟨x, hx⟩ => by + ext + simp only [p] at hx + exact hx.choose_spec.symm } + suffices hsuff : Equiv.sumCongr σ (1 : Perm β) = @Perm.extendDomain α (α ⊕ β) + σ p hdec e by + rw [hsuff, cycleType_extendDomain] + ext x; rcases x with a | b + · -- inl a: both sides give inl (σ a) + change Sum.inl (σ a) = _ + rw [@Perm.extendDomain_apply_subtype α (α ⊕ β) σ p hdec e (Sum.inl a) ⟨a, + rfl⟩] + simp [e] + · -- inr b: both sides give inr b + change Sum.inr b = _ + have hb : ¬ p (Sum.inr b) := fun ⟨_, h⟩ => nomatch h + rw [@Perm.extendDomain_apply_not_subtype α (α ⊕ β) σ p hdec e (Sum.inr b) + hb] + +/-- `sumCongr 1 τ` equals the permCongr-transport of `sumCongr τ 1` by +`sumComm`. -/ +theorem sumCongr_right_eq_permCongr {α β : Type} + (τ : Perm β) : + Equiv.sumCongr (1 : Perm α) τ = + (Equiv.sumComm β α).permCongr (Equiv.sumCongr τ (1 : Perm α)) := by + ext x + rcases x with a | b <;> simp [Equiv.permCongr_apply, Equiv.sumComm] + +/-- Right factor in a sum preserves cycle type. -/ +theorem cycleType_sumCongr_right {α β : Type} + [Fintype α] [DecidableEq α] [Fintype β] [DecidableEq β] + (τ : Perm β) : + cycleType (Equiv.sumCongr (1 : Perm α) τ) = τ.cycleType := by + rw [sumCongr_right_eq_permCongr, cycleType_permCongr, cycleType_sumCongr_left] + +/-- The factors `sumCongr σ 1` and `sumCongr 1 τ` are disjoint. -/ +theorem disjoint_sumCongr {α β : Type} + (σ : Perm α) (τ : Perm β) : + Disjoint + (Equiv.sumCongr σ (1 : Perm β)) + (Equiv.sumCongr (1 : Perm α) τ) := by + intro x + rcases x with a | b + · right; simp + · left; simp + +/-- A sum of permutations has the sum of the two cycle types. -/ +theorem cycleType_sumCongr {α β : Type} + [Fintype α] [DecidableEq α] [Fintype β] [DecidableEq β] + (σ : Perm α) (τ : Perm β) : + cycleType (Equiv.sumCongr σ τ) = σ.cycleType + τ.cycleType := by + have hfact : Equiv.sumCongr σ τ = + Equiv.sumCongr σ (1 : Perm β) * Equiv.sumCongr (1 : Perm α) τ := by + rw [Perm.sumCongr_mul]; simp + rw [hfact, (disjoint_sumCongr σ τ).cycleType_mul, + cycleType_sumCongr_left, cycleType_sumCongr_right] + +/-- The fixed points of a sum of permutations are the sum of the two +fixed-point sets. -/ +noncomputable def fixedPointsSumCongrEquiv {α β : Type} + (π₁ : Perm α) (π₂ : Perm β) : + Function.fixedPoints (Equiv.sumCongr π₁ π₂) ≃ + (Function.fixedPoints π₁ ⊕ Function.fixedPoints π₂) := + Equiv.subtypeSum.trans + (Equiv.sumCongr + (Equiv.subtypeEquivRight fun a => by + simp only [Function.mem_fixedPoints, Function.IsFixedPt, + Equiv.sumCongr_apply, Sum.map_inl, Sum.inl.injEq]) + (Equiv.subtypeEquivRight fun b => by + simp only [Function.mem_fixedPoints, Function.IsFixedPt, + Equiv.sumCongr_apply, Sum.map_inr, Sum.inr.injEq])) + +/-- A sum of permutations has the sum of the two fixed-point +counts. -/ +theorem card_fixedPoints_sumCongr {α β : Type} + (π₁ : Perm α) (π₂ : Perm β) + [Fintype (Function.fixedPoints (Equiv.sumCongr π₁ π₂))] + [Fintype (Function.fixedPoints π₁)] + [Fintype (Function.fixedPoints π₂)] : + Fintype.card (Function.fixedPoints (Equiv.sumCongr π₁ π₂)) = + Fintype.card (Function.fixedPoints π₁) + + Fintype.card (Function.fixedPoints π₂) := + (Fintype.card_congr (fixedPointsSumCongrEquiv π₁ π₂)).trans + (Fintype.card_sum) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Common/PermTopSplit.lean b/LeanPool/RegtsSevenster/RS/Common/PermTopSplit.lean new file mode 100644 index 0000000000..774339a822 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/PermTopSplit.lean @@ -0,0 +1,464 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Splitting a permutation at the top slot + +A permutation of `Fin (n + 1)` is determined by where it sends the +top slot, `Fin.last n`, together with the permutation it induces on +the remaining slots once both sides are compressed +order-preservingly. This is the decomposition the symmetric-group +action on a tensor power recurses on. + +`Equiv.Perm.decomposeFin` is the analogous splitting at slot `0`, but +it compresses by `swap 0 p` rather than order-preservingly, so its +induced permutation is not the one a tensor power's factors see. The +compression here is `finSuccAboveEquiv`. +-/ + +@[expose] public section + +namespace RS + +open Equiv + +variable {n : ℕ} + +/-- Where a permutation sends the top slot. -/ +def topImage (σ : Perm (Fin (n + 1))) : Fin (n + 1) := σ (Fin.last n) + +/-- The identity leaves the top slot alone. -/ +@[simp] +theorem topImage_one : topImage (1 : Perm (Fin (n + 1))) = Fin.last n := rfl + +/-- A non-top slot has a non-top image, and conversely. -/ +private theorem ne_last_iff (σ : Perm (Fin (n + 1))) (x : Fin (n + 1)) : + x ≠ Fin.last n ↔ σ x ≠ topImage σ := by + simp [topImage, σ.injective.eq_iff] + +/-- **The induced permutation of the remaining slots.** Both the +source slots other than the top one and the target slots other than +`topImage σ` are compressed to `Fin n` order-preservingly, and `σ` +carries one to the other. -/ +def restPerm (σ : Perm (Fin (n + 1))) : Perm (Fin n) := + (finSuccAboveEquiv (Fin.last n)).trans + ((Equiv.subtypeEquiv σ + (show ∀ x, x ≠ Fin.last n ↔ σ x ≠ topImage σ from by exact ne_last_iff σ)).trans + (finSuccAboveEquiv (topImage σ)).symm) + +/-- The defining property of `restPerm`: reinserting the compressed +image at `topImage σ` recovers the action of `σ`. -/ +theorem succAbove_restPerm (σ : Perm (Fin (n + 1))) (j : Fin n) : + (topImage σ).succAbove (restPerm σ j) = σ j.castSucc := by + have h : ((finSuccAboveEquiv (topImage σ)).symm + ⟨σ ((Fin.last n).succAbove j), (ne_last_iff σ _).1 + (Fin.succAbove_ne _ j)⟩ : Fin n) = restPerm σ j := rfl + have h2 := congrArg Subtype.val + ((finSuccAboveEquiv (topImage σ)).apply_symm_apply + ⟨σ ((Fin.last n).succAbove j), (ne_last_iff σ _).1 + (Fin.succAbove_ne _ j)⟩) + rw [finSuccAboveEquiv_apply] at h2 + rw [h] at h2 + simpa [Fin.succAbove_last] using h2 + +/-- The identity induces the identity on the lower slots. -/ +@[simp] +theorem restPerm_one : restPerm (1 : Perm (Fin (n + 1))) = 1 := by + ext j + have h := succAbove_restPerm (1 : Perm (Fin (n + 1))) j + rw [topImage_one, Fin.succAbove_last] at h + simpa using congrArg Fin.val h + +/-! ## Permutations fixing the top slot + +The standard embedding `S_n ↪ S_{n+1}`, extending by the identity on +the top slot. It is the embedding `symCast` uses, so the tower's +compatibility field sees exactly these permutations. +-/ + +/-- A permutation of the lower slots, extended by fixing the top +slot. -/ +noncomputable def extPerm (τ : Perm (Fin n)) : Perm (Fin (n + 1)) := + τ.viaEmbedding Fin.castSuccEmb + +/-- On a lower slot the extension acts by `τ`. -/ +@[simp] +theorem extPerm_castSucc (τ : Perm (Fin n)) (j : Fin n) : + extPerm τ j.castSucc = (τ j).castSucc := + Equiv.Perm.viaEmbedding_apply τ Fin.castSuccEmb j + +/-- The extension fixes the top slot. -/ +@[simp] +theorem extPerm_last (τ : Perm (Fin n)) : + extPerm τ (Fin.last n) = Fin.last n := by + refine Equiv.Perm.viaEmbedding_apply_of_notMem τ Fin.castSuccEmb _ ?_ + rintro ⟨j, hj⟩ + exact absurd hj (Fin.castSucc_lt_last j).ne + +/-- Extending by the top slot is a monoid map. -/ +@[simp] +theorem extPerm_mul (τ ρ : Perm (Fin n)) : + extPerm (τ * ρ) = extPerm τ * extPerm ρ := + (Equiv.Perm.viaEmbeddingHom Fin.castSuccEmb).map_mul τ ρ + +/-- Extending the identity gives the identity. -/ +@[simp] +theorem extPerm_one : extPerm (1 : Perm (Fin n)) = 1 := + (Equiv.Perm.viaEmbeddingHom Fin.castSuccEmb).map_one + +/-- Precomposing with a permutation of the lower slots leaves the top +slot's image alone. -/ +@[simp] +theorem topImage_mul_extPerm (σ : Perm (Fin (n + 1))) (τ : Perm (Fin n)) : + topImage (σ * extPerm τ) = topImage σ := by + change σ (extPerm τ (Fin.last n)) = σ (Fin.last n) + rw [extPerm_last] + +/-- **Precomposing with a permutation of the lower slots** acts on +the induced permutation by precomposition, with no interaction with +the top slot. -/ +theorem restPerm_mul_extPerm (σ : Perm (Fin (n + 1))) (τ : Perm (Fin n)) : + restPerm (σ * extPerm τ) = restPerm σ * τ := by + ext j + have h1 := succAbove_restPerm (σ * extPerm τ) j + rw [topImage_mul_extPerm] at h1 + have h2 : (σ * extPerm τ) j.castSucc = σ (τ j).castSucc := by + change σ (extPerm τ j.castSucc) = σ (τ j).castSucc + rw [extPerm_castSucc] + rw [h2, ← succAbove_restPerm σ (τ j)] at h1 + exact congrArg Fin.val (Fin.succAbove_right_injective h1) + +/-- A top-fixing permutation fixes the top slot. -/ +@[simp] +theorem topImage_extPerm (τ : Perm (Fin n)) : + topImage (extPerm τ) = Fin.last n := extPerm_last τ + +/-- A top-fixing permutation induces itself on the lower slots. -/ +@[simp] +theorem restPerm_extPerm (τ : Perm (Fin n)) : restPerm (extPerm τ) = τ := by + have h := restPerm_mul_extPerm (1 : Perm (Fin (n + 1))) τ + rwa [one_mul, restPerm_one, one_mul] at h + +/-! ## Iterating the standard embedding + +The tower's compatibility field extends a permutation of `Fin m` all +the way to `Fin n` in one step, along `Fin.castLEEmb`. The action +recurses one slot at a time, so the two descriptions have to be +identified: extending along `Fin.castLEEmb` is iterated `extPerm`. +-/ + +/-- **Composing embeddings composes the extensions**: extending a +permutation along `ι` and then along `κ` extends it along the +composite. -/ +theorem viaEmbedding_viaEmbedding {α β γ : Type*} (σ : Perm α) + (ι : α ↪ β) (κ : β ↪ γ) : + (σ.viaEmbedding ι).viaEmbedding κ = σ.viaEmbedding (ι.trans κ) := by + ext x + by_cases hx : x ∈ Set.range κ + · obtain ⟨b, rfl⟩ := hx + rw [Perm.viaEmbedding_apply] + by_cases hb : b ∈ Set.range ι + · obtain ⟨a, rfl⟩ := hb + rw [Perm.viaEmbedding_apply] + exact (Perm.viaEmbedding_apply σ (ι.trans κ) a).symm + · have hbκ : κ b ∉ Set.range (ι.trans κ) := by + rintro ⟨a, ha⟩ + exact hb ⟨a, κ.injective ha⟩ + rw [Perm.viaEmbedding_apply_of_notMem _ _ _ hb, + Perm.viaEmbedding_apply_of_notMem _ _ _ hbκ] + · have hxκ : x ∉ Set.range (ι.trans κ) := fun ⟨a, ha⟩ => hx ⟨ι a, ha⟩ + rw [Perm.viaEmbedding_apply_of_notMem _ _ _ hx, + Perm.viaEmbedding_apply_of_notMem _ _ _ hxκ] + +/-- **One step of the standard embedding**: extending a permutation +of `Fin m` to `Fin (m + k + 1)` is extending it to `Fin (m + k)` and +then fixing the new top slot. -/ +theorem viaEmbedding_castLEEmb_succ {m k : ℕ} (σ : Perm (Fin m)) : + σ.viaEmbedding (Fin.castLEEmb (Nat.le_add_right m (k + 1))) = + extPerm (σ.viaEmbedding (Fin.castLEEmb (Nat.le_add_right m k))) := by + have h : (Fin.castLEEmb (Nat.le_add_right m k)).trans Fin.castSuccEmb = + Fin.castLEEmb (Nat.le_add_right m (k + 1)) := + Function.Embedding.ext fun i => Fin.ext rfl + rw [extPerm, viaEmbedding_viaEmbedding, h] + +/-! ## Reassembling a permutation from its split + +A target for the top slot together with a permutation of the rest +determines a permutation. The cycle carrying the top slot to `p` +is the case of trivial induced permutation, and the action's +functoriality is proved along the factorisation into such a cycle +after a top-fixing permutation. +-/ + +/-- The permutation sending the top slot to `p` and inducing `τ` on +the rest. -/ +noncomputable def ofSplit (p : Fin (n + 1)) (τ : Perm (Fin n)) : + Perm (Fin (n + 1)) := + (finSuccEquiv' (Fin.last n)).trans + ((Equiv.optionCongr τ).trans (finSuccEquiv' p).symm) + +/-- The reassembled permutation sends the top slot to `p`. -/ +@[simp] +theorem ofSplit_last (p : Fin (n + 1)) (τ : Perm (Fin n)) : + ofSplit p τ (Fin.last n) = p := by + change (finSuccEquiv' p).symm ((Equiv.optionCongr τ) + ((finSuccEquiv' (Fin.last n)) (Fin.last n))) = p + rw [finSuccEquiv'_at] + simp + +/-- On a lower slot the reassembled permutation acts by `τ`, +reinserted above `p`. -/ +@[simp] +theorem ofSplit_castSucc (p : Fin (n + 1)) (τ : Perm (Fin n)) (j : Fin n) : + ofSplit p τ j.castSucc = p.succAbove (τ j) := by + change (finSuccEquiv' p).symm ((Equiv.optionCongr τ) + ((finSuccEquiv' (Fin.last n)) j.castSucc)) = p.succAbove (τ j) + rw [finSuccEquiv'_last_apply_castSucc] + simp + +/-- The reassembled permutation has `p` as its top image. -/ +@[simp] +theorem topImage_ofSplit (p : Fin (n + 1)) (τ : Perm (Fin n)) : + topImage (ofSplit p τ) = p := ofSplit_last p τ + +/-- The reassembled permutation induces `τ` on the lower slots. -/ +@[simp] +theorem restPerm_ofSplit (p : Fin (n + 1)) (τ : Perm (Fin n)) : + restPerm (ofSplit p τ) = τ := by + ext j + have h := succAbove_restPerm (ofSplit p τ) j + rw [topImage_ofSplit, ofSplit_castSucc] at h + exact congrArg Fin.val (Fin.succAbove_right_injective h) + +/-- The cycle carrying the top slot down to `p`, shifting the slots +at or above `p` up by one. -/ +noncomputable def topCycle (p : Fin (n + 1)) : Perm (Fin (n + 1)) := + ofSplit p 1 + +/-- The cycle carries the top slot to `p`. -/ +@[simp] +theorem topImage_topCycle (p : Fin (n + 1)) : + topImage (topCycle p) = p := topImage_ofSplit p 1 + +/-- The cycle induces the identity on the lower slots. -/ +@[simp] +theorem restPerm_topCycle (p : Fin (n + 1)) : + restPerm (topCycle p) = 1 := restPerm_ofSplit p 1 + +/-- **The cycle carrying the top slot to the bottom** is Mathlib's +rotation: both send each lower slot one place up and the top slot +to `0`. -/ +theorem topCycle_zero : + topCycle (0 : Fin (n + 1)) = finRotate (n + 1) := by + refine Equiv.ext fun i => ?_ + induction i using Fin.lastCases with + | last => + rw [show topCycle (0 : Fin (n + 1)) (Fin.last n) = 0 from + ofSplit_last 0 1, finRotate_last] + | cast j => + have h : topCycle (0 : Fin (n + 1)) j.castSucc = j.succ := by + change ofSplit (0 : Fin (n + 1)) 1 j.castSucc = j.succ + simp + refine Fin.ext ?_ + rw [h, coe_finRotate_of_ne_last (Fin.castSucc_lt_last j).ne] + rfl + +/-! ## The adjacent transpositions + +`Equiv.Perm.mclosure_swap_castSucc_succ` generates `Perm (Fin (n+1))` +as a submonoid from the transpositions of adjacent slots. Each of +them is either top-fixing — and so an `extPerm` of an adjacent +transposition one arity down — or the transposition of the top two +slots, which is the cycle at the second-highest slot. +-/ + +/-- Extending a transposition of the lower slots. -/ +theorem extPerm_swap (a b : Fin n) : + extPerm (Equiv.swap a b) = + Equiv.swap a.castSucc b.castSucc := + Equiv.ext fun x => by + refine Fin.lastCases ?_ (fun j => ?_) x + · rw [extPerm_last, Equiv.swap_apply_of_ne_of_ne + (Fin.castSucc_lt_last a).ne' (Fin.castSucc_lt_last b).ne'] + · rw [extPerm_castSucc] + rcases eq_or_ne j a with rfl | hja + · rw [Equiv.swap_apply_left, Equiv.swap_apply_left] + · rcases eq_or_ne j b with rfl | hjb + · rw [Equiv.swap_apply_right, Equiv.swap_apply_right] + · rw [Equiv.swap_apply_of_ne_of_ne hja hjb, + Equiv.swap_apply_of_ne_of_ne + (fun h => hja (Fin.castSucc_injective _ h)) + (fun h => hjb (Fin.castSucc_injective _ h))] + +/-- An adjacent transposition below the top is top-fixing. -/ +theorem swap_castSucc_succ_castSucc (i : Fin n) : + Equiv.swap (Fin.castSucc (Fin.castSucc i)) (Fin.castSucc i).succ = + extPerm (Equiv.swap i.castSucc i.succ) := by + rw [extPerm_swap, Fin.succ_castSucc] + +/-- The transposition of the top two slots is the cycle at the +second-highest slot. -/ +theorem topCycle_castSucc_last : + topCycle (Fin.castSucc (Fin.last n)) = + Equiv.swap (Fin.castSucc (Fin.last n)) (Fin.last (n + 1)) := + Equiv.ext fun x => by + refine Fin.lastCases ?_ (fun j => ?_) x + · rw [topCycle, ofSplit_last, Equiv.swap_apply_right] + · rw [topCycle, ofSplit_castSucc, Equiv.Perm.one_apply] + rcases eq_or_ne j (Fin.last n) with rfl | hj + · rw [Fin.succAbove_of_le_castSucc _ _ le_rfl, + Equiv.swap_apply_left, Fin.succ_last] + · have hlt : j.castSucc < Fin.castSucc (Fin.last n) := + Fin.castSucc_lt_castSucc_iff.2 + (lt_of_le_of_ne (Fin.le_last j) hj) + rw [Fin.succAbove_of_castSucc_lt _ _ hlt, + Equiv.swap_apply_of_ne_of_ne hlt.ne + (Fin.castSucc_lt_last _).ne] + +/-! ## Precomposing with the top transposition + +The transposition of the top two slots exchanges the two source slots +the action's recursion peels off first, so it exchanges the two +targets they consume. Everything below them is untouched. +-/ + +/-- The transposition of the top two slots. -/ +noncomputable def topSwap : Perm (Fin (n + 2)) := + Equiv.swap (Fin.castSucc (Fin.last n)) (Fin.last (n + 1)) + +/-- The top transposition is the cycle at the second-highest +slot. -/ +theorem topSwap_eq_topCycle : + (topSwap : Perm (Fin (n + 2))) = topCycle (Fin.castSucc (Fin.last n)) := + topCycle_castSucc_last.symm + +/-- The top transposition carries the top slot one place down. -/ +@[simp] +theorem topSwap_last : (topSwap : Perm (Fin (n + 2))) (Fin.last (n + 1)) = + Fin.castSucc (Fin.last n) := Equiv.swap_apply_right _ _ + +/-- The top transposition carries the slot below the top one +place up. -/ +@[simp] +theorem topSwap_castSucc_last : + (topSwap : Perm (Fin (n + 2))) (Fin.castSucc (Fin.last n)) = + Fin.last (n + 1) := Equiv.swap_apply_left _ _ + +/-- The top transposition fixes every slot below the top two. -/ +@[simp] +theorem topSwap_castSucc_castSucc (j : Fin n) : + (topSwap : Perm (Fin (n + 2))) (Fin.castSucc (Fin.castSucc j)) = + Fin.castSucc (Fin.castSucc j) := by + refine Equiv.swap_apply_of_ne_of_ne (fun h => ?_) (fun h => ?_) + · exact absurd (Fin.castSucc_injective _ h) (Fin.castSucc_lt_last j).ne + · exact absurd h (Fin.castSucc_lt_last _).ne + +/-- **The top slot's new image**: precomposing with the top +transposition sends the top slot where the slot below it went. -/ +theorem topImage_mul_topSwap (σ : Perm (Fin (n + 2))) : + topImage (σ * topSwap) = + (topImage σ).succAbove (topImage (restPerm σ)) := by + change σ (topSwap (Fin.last (n + 1))) = _ + rw [topSwap_last, ← succAbove_restPerm σ (Fin.last n)] + rfl + +/-- **The two consumed targets are exchanged**: reinserting the new +second target recovers the old first one. -/ +theorem succAbove_topImage_restPerm_mul_topSwap (σ : Perm (Fin (n + 2))) : + (topImage (σ * topSwap)).succAbove (topImage (restPerm (σ * topSwap))) + = topImage σ := by + have h := succAbove_restPerm (σ * topSwap) (Fin.last n) + rw [show restPerm (σ * topSwap) (Fin.last n) + = topImage (restPerm (σ * topSwap)) from rfl] at h + rw [h] + change σ (topSwap (Fin.castSucc (Fin.last n))) = σ (Fin.last (n + 1)) + rw [topSwap_castSucc_last] + +/-- **The new second target** is the old first one, compressed. This +is the `Fin` simplicial identity: reinserting `m.predAbove p` at +`p.succAbove m` recovers `p`. -/ +theorem topImage_restPerm_mul_topSwap (σ : Perm (Fin (n + 2))) : + topImage (restPerm (σ * topSwap)) = + (topImage (restPerm σ)).predAbove (topImage σ) := by + have h1 := succAbove_topImage_restPerm_mul_topSwap σ + have h2 := Fin.succAbove_succAbove_predAbove (topImage σ) + (topImage (restPerm σ)) + rw [topImage_mul_topSwap σ] at h1 + exact Fin.succAbove_right_injective (h1.trans h2.symm) + +/-- **Nothing below the top two slots moves.** Precomposing with the +top transposition exchanges the two targets the top two source slots +consume, but the order-preserving embedding of the remaining slots +into their complement is the same either way, so the twice-restricted +permutation is unchanged. -/ +theorem restPerm_restPerm_mul_topSwap (σ : Perm (Fin (n + 2))) : + restPerm (restPerm (σ * topSwap)) = restPerm (restPerm σ) := by + ext x + have key : ∀ ρ : Perm (Fin (n + 2)), + (topImage ρ).succAbove ((topImage (restPerm ρ)).succAbove + (restPerm (restPerm ρ) x)) = ρ (Fin.castSucc (Fin.castSucc x)) := by + intro ρ + rw [succAbove_restPerm (restPerm ρ) x, succAbove_restPerm ρ x.castSucc] + have hL := key (σ * topSwap) + have hR := key σ + rw [topImage_mul_topSwap σ, topImage_restPerm_mul_topSwap σ, + Fin.succAbove_succAbove_succAbove_predAbove] at hL + have hswap : (σ * topSwap : Perm (Fin (n + 2))) + (Fin.castSucc (Fin.castSucc x)) = + σ (Fin.castSucc (Fin.castSucc x)) := by + rw [Equiv.Perm.mul_apply, topSwap_castSucc_castSucc] + rw [hswap, ← hR] at hL + exact congrArg Fin.val + (Fin.succAbove_right_injective (Fin.succAbove_right_injective hL)) + +/-! ### The two consumed targets, by value + +The bubbling distances the action's recursion uses are `n` minus +these values, so the braid identity is fed them in numeric form. The +two cases are whether the top slot's image lies above or below the +image of the slot beneath it. +-/ + +/-- Above the threshold, the top slot's new image is the old inner +one. -/ +theorem topImage_mul_topSwap_val_of_lt (σ : Perm (Fin (n + 2))) + (h : (topImage (restPerm σ)).castSucc < topImage σ) : + ((topImage (σ * topSwap) : Fin (n + 2)) : ℕ) + = ((topImage (restPerm σ) : Fin (n + 1)) : ℕ) := by + rw [topImage_mul_topSwap, Fin.succAbove_of_castSucc_lt _ _ h] + rfl + +/-- Above the threshold, the new inner image is the old top one, +lowered by one. -/ +theorem topImage_restPerm_mul_topSwap_val_of_lt (σ : Perm (Fin (n + 2))) + (h : (topImage (restPerm σ)).castSucc < topImage σ) : + ((topImage (restPerm (σ * topSwap)) : Fin (n + 1)) : ℕ) + = ((topImage σ : Fin (n + 2)) : ℕ) - 1 := by + rw [topImage_restPerm_mul_topSwap, Fin.predAbove_of_castSucc_lt _ _ h] + rfl + +/-- Below the threshold, the top slot's new image is the old inner +one, raised by one. -/ +theorem topImage_mul_topSwap_val_of_le (σ : Perm (Fin (n + 2))) + (h : topImage σ ≤ (topImage (restPerm σ)).castSucc) : + ((topImage (σ * topSwap) : Fin (n + 2)) : ℕ) + = ((topImage (restPerm σ) : Fin (n + 1)) : ℕ) + 1 := by + rw [topImage_mul_topSwap, Fin.succAbove_of_le_castSucc _ _ h] + rfl + +/-- Below the threshold, the new inner image is the old top one. -/ +theorem topImage_restPerm_mul_topSwap_val_of_le (σ : Perm (Fin (n + 2))) + (h : topImage σ ≤ (topImage (restPerm σ)).castSucc) : + ((topImage (restPerm (σ * topSwap)) : Fin (n + 1)) : ℕ) + = ((topImage σ : Fin (n + 2)) : ℕ) := by + rw [topImage_restPerm_mul_topSwap, Fin.predAbove_of_le_castSucc _ _ h] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Common/ProdSum.lean b/LeanPool/RegtsSevenster/RS/Common/ProdSum.lean new file mode 100644 index 0000000000..eb390a586a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/ProdSum.lean @@ -0,0 +1,93 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Sums through linear maps and into a product + +Two small families used wherever a coordinate computation pushes a +finite sum through a bound map and then splits it across the +summands of a product: `map_sum`/`map_zero` at a bound linear map +or equivalence, and the four ways a sum can sit in `A × B`. + +They are stated for bound maps because `simp` will not otherwise +rewrite under a `LinearMap` applied to a `Finset.sum`, and they +live here rather than beside their first user because two files +need them. +-/ + +@[expose] public section + +namespace RS + +variable {M N A B ι κ : Type*} + +section Maps + +/-- `map_sum` for a bound linear equivalence. -/ +lemma equiv_sum [AddCommMonoid M] [Module ℂ M] [AddCommMonoid N] [Module ℂ N] + (e : M ≃ₗ[ℂ] N) (s : Finset ι) (f : ι → M) : + e (∑ i ∈ s, f i) = ∑ i ∈ s, e (f i) := + map_sum e f s + +/-- `map_add` for a bound linear equivalence. -/ +lemma equiv_add [AddCommMonoid M] [Module ℂ M] [AddCommMonoid N] [Module ℂ N] + (e : M ≃ₗ[ℂ] N) (x y : M) : e (x + y) = e x + e y := + map_add e x y + +/-- `map_sum` for a bound linear map. -/ +lemma lmap_sum [AddCommMonoid M] [Module ℂ M] [AddCommMonoid N] [Module ℂ N] + (f : M →ₗ[ℂ] N) (s : Finset ι) (g : ι → M) : + f (∑ i ∈ s, g i) = ∑ i ∈ s, f (g i) := + map_sum f g s + +/-- `map_zero` for a bound linear map. -/ +lemma lmap_zero [AddCommMonoid M] [Module ℂ M] [AddCommMonoid N] [Module ℂ N] + (f : M →ₗ[ℂ] N) : f 0 = 0 := + map_zero f + +end Maps + +section Prod + +/-- Addition in the left summand of a product. -/ +lemma mk_add_left [AddCommMonoid A] [AddCommMonoid B] + (a a' : A) : + ((a + a', (0 : B)) : A × B) = (a, 0) + (a', 0) := by + refine Prod.ext ?_ ?_ <;> simp + +/-- Addition in the right summand. -/ +lemma mk_add_right [AddCommMonoid A] [AddCommMonoid B] + (b b' : B) : + (((0 : A), b + b') : A × B) = (0, b) + (0, b') := by + refine Prod.ext ?_ ?_ <;> simp + +/-- A sum in the left summand. -/ +lemma mk_sum_left [AddCommMonoid A] [AddCommMonoid B] + (s : Finset ι) (f : ι → A) : + ((∑ i ∈ s, f i, (0 : B)) : A × B) = ∑ i ∈ s, ((f i, 0) : A × B) := by + refine Prod.ext ?_ ?_ <;> simp [Prod.fst_sum, Prod.snd_sum] + +/-- A sum in the right summand. -/ +lemma mk_sum_right [AddCommMonoid A] [AddCommMonoid B] + (t : Finset ι) (g : ι → B) : + (((0 : A), ∑ j ∈ t, g j) : A × B) = ∑ j ∈ t, ((0, g j) : A × B) := by + refine Prod.ext ?_ ?_ <;> simp [Prod.fst_sum, Prod.snd_sum] + +/-- A pair of sums splits into the two summands' sums — the shape +the even and odd blocks are computed in. -/ +lemma mk_sum_split [AddCommMonoid A] [AddCommMonoid B] + (s : Finset ι) (t : Finset κ) (f : ι → A) (g : κ → B) : + ((∑ i ∈ s, f i, ∑ j ∈ t, g j) : A × B) = + (∑ i ∈ s, ((f i, 0) : A × B)) + ∑ j ∈ t, ((0, g j) : A × B) := by + refine Prod.ext ?_ ?_ <;> simp [Prod.fst_sum, Prod.snd_sum] + +end Prod + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Common/RowLenChain.lean b/LeanPool/RegtsSevenster/RS/Common/RowLenChain.lean new file mode 100644 index 0000000000..73d2864ed0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/RowLenChain.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.DiagramChain + +/-! +# Row lengths along single-box extensions + +A diagram extending another by a single cell bumps exactly one row +length by one; row lengths are monotone in diagram containment. +-/ + +@[expose] public section + +namespace RS + +open Finset + +/-- Row lengths are monotone in diagram containment. -/ +theorem rowLen_mono {lam mu : YoungDiagram} (hle : lam ≤ mu) + (i : ℕ) : lam.rowLen i ≤ mu.rowLen i := by + by_contra h + have h1 : (i, mu.rowLen i) ∈ lam := by + rw [YoungDiagram.mem_iff_lt_rowLen] + omega + have h2 : (i, mu.rowLen i) ∈ mu := hle h1 + rw [YoungDiagram.mem_iff_lt_rowLen] at h2 + omega + +/-- A single-cell extension bumps exactly one row length. -/ +theorem rowLen_of_card_succ {lam nu : YoungDiagram} + (hle : lam ≤ nu) (hcard : nu.card = lam.card + 1) : + ∃ i₀ : ℕ, ∀ i : ℕ, + nu.rowLen i = (if i = i₀ then lam.rowLen i + 1 + else lam.rowLen i) := by + classical + have hsub : lam.cells ⊆ nu.cells := + YoungDiagram.cells_subset_iff.mpr hle + have hss : lam.cells ⊂ nu.cells := by + refine ⟨hsub, fun hrev => ?_⟩ + have : nu.card = lam.card := + le_antisymm (Finset.card_le_card hrev) + (Finset.card_le_card hsub) + omega + obtain ⟨c, hc_notin, hc_ins⟩ := + Finset.ssubset_iff.mp hss + have hcells : nu.cells = insert c lam.cells := by + refine (Finset.eq_of_subset_of_card_le hc_ins ?_).symm + rw [Finset.card_insert_of_notMem hc_notin] + change nu.card ≤ lam.card + 1 + omega + refine ⟨c.1, fun i => ?_⟩ + by_cases hi : i = c.1 + · subst hi + -- the new cell sits at the end of its row + have hcmem : c ∈ nu := by + rw [← YoungDiagram.mem_cells, hcells] + exact Finset.mem_insert_self c lam.cells + have hlt : c.2 < nu.rowLen c.1 := by + rw [← YoungDiagram.mem_iff_lt_rowLen] + exact (show (c.1, c.2) ∈ nu from hcmem) + have hnotl : ¬ c.2 < lam.rowLen c.1 := by + rw [← YoungDiagram.mem_iff_lt_rowLen] + intro hmem + exact hc_notin ((YoungDiagram.mem_cells _).mpr hmem) + have hup : ∀ j : ℕ, j < nu.rowLen c.1 → j ≠ c.2 → + j < lam.rowLen c.1 := by + intro j hj hne + rw [← YoungDiagram.mem_iff_lt_rowLen] at hj ⊢ + have : (c.1, j) ∈ nu.cells := + (YoungDiagram.mem_cells _).mpr hj + rw [hcells, Finset.mem_insert] at this + rcases this with heq | hmem + · exact absurd (congrArg Prod.snd heq) hne + · exact (YoungDiagram.mem_cells _).mp hmem + rw [ite_eq_left rfl] + -- rowLen nu = c.2 + 1 and rowLen lam = c.2 + have h1 : c.2 + 1 ≤ nu.rowLen c.1 := hlt + have h2 : lam.rowLen c.1 ≤ c.2 := by omega + have h3 : nu.rowLen c.1 ≤ c.2 + 1 := by + by_contra h + have := hup (c.2 + 1) (by omega) (by omega) + omega + have h4 : c.2 ≤ lam.rowLen c.1 := by + by_cases hz : c.2 = 0 + · omega + · have := hup (c.2 - 1) (by omega) (by omega) + omega + omega + · rw [ite_eq_right hi] + apply le_antisymm + · by_contra h + have hmem : (i, lam.rowLen i) ∈ nu := by + rw [YoungDiagram.mem_iff_lt_rowLen] + omega + have : (i, lam.rowLen i) ∈ nu.cells := + (YoungDiagram.mem_cells _).mpr hmem + rw [hcells, Finset.mem_insert] at this + rcases this with heq | hmem' + · exact hi (congrArg Prod.fst heq) + · have := (YoungDiagram.mem_cells _).mp hmem' + rw [YoungDiagram.mem_iff_lt_rowLen] at this + omega + · exact rowLen_mono hle i + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Common/RowSpanRank.lean b/LeanPool/RegtsSevenster/RS/Common/RowSpanRank.lean new file mode 100644 index 0000000000..7c3b23693d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/RowSpanRank.lean @@ -0,0 +1,238 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# The row span of a matrix over arbitrary index types + +A matrix whose rows and columns are indexed by arbitrary types has no +rank in the sense of linear algebra. Two standard substitutes are the +dimension of the span of its rows and the supremum of the ranks of its +finite submatrices; this module proves them interchangeable in the +bounded form that a rank *hypothesis* uses, so that no cardinal +supremum is needed: the row span has dimension at most `n` exactly +when every finite submatrix has rank at most `n` +(`rank_span_rows_le_iff`). The same criterion is restated for the row +span presented as the range of `Finsupp.lift` +(`rank_range_lift_le_iff`), which is how the connection matrices of +`RS/Novel/Skein/ConnectionRank.lean` present theirs. + +The point of substance is that a finite-dimensional space of functions +on `κ` is separated by finitely many coordinates +(`exists_finset_separating`): that is what makes the row rank of an +infinite matrix visible on a single finite submatrix. +-/ + +@[expose] public section + +namespace RS + +variable {K : Type*} + +/-! ## Separating a space of functions on finitely many coordinates -/ + +/-- Restriction of functions on `κ` to a finite set of coordinates. -/ +private def restrictTo [Field K] {κ : Type*} + (T : Finset κ) : (κ → K) →ₗ[K] (T → K) := + LinearMap.funLeft K K ((↑) : T → κ) + +private theorem separating_aux [Field K] {κ : Type*} + (n : ℕ) : + ∀ U : Submodule K (κ → K), FiniteDimensional K U → + Module.finrank K U ≤ n → + ∃ T : Finset κ, ∀ w ∈ U, (∀ j ∈ T, w j = 0) → w = 0 := by + classical + induction n with + | zero => + intro U _ hrank + refine ⟨∅, fun w hw _ => ?_⟩ + by_contra hne + have hbot : (⊥ : Submodule K (κ → K)) < U := + bot_lt_iff_ne_bot.2 fun h => hne (by simpa [h] using hw) + have hlt := Submodule.finrank_lt_finrank_of_lt hbot + rw [finrank_bot] at hlt + omega + | succ n ih => + intro U hU hrank + by_cases hbot : U = ⊥ + · exact ⟨∅, fun w hw _ => by simpa [hbot] using hw⟩ + obtain ⟨w₀, hw₀U, hw₀⟩ := Submodule.exists_mem_ne_zero_of_ne_bot hbot + obtain ⟨j, hj⟩ : ∃ j, w₀ j ≠ 0 := by + by_contra h + exact hw₀ (funext fun j => not_not.1 fun hne => h ⟨j, hne⟩) + -- Cutting `U` down by one coordinate at which some vector of `U` + -- is nonzero drops the dimension, so the recursion terminates. + set U' : Submodule K (κ → K) := U ⊓ LinearMap.ker (LinearMap.proj j) + with hU'def + have hlt : U' < U := by + refine lt_of_le_of_ne inf_le_left fun h => hj ?_ + have hmem : w₀ ∈ U' := by rw [h]; exact hw₀U + exact LinearMap.mem_ker.1 (Submodule.mem_inf.1 hmem).2 + have : FiniteDimensional K U' := + FiniteDimensional.of_injective (Submodule.inclusion (le_of_lt hlt)) + (Submodule.inclusion_injective _) + have hfr : Module.finrank K U' < Module.finrank K U := + Submodule.finrank_lt_finrank_of_lt hlt + obtain ⟨T', hT'⟩ := ih U' inferInstance (by omega) + refine ⟨insert j T', fun w hw hvan => hT' w ?_ ?_⟩ + · exact Submodule.mem_inf.2 + ⟨hw, LinearMap.mem_ker.2 (hvan j (Finset.mem_insert_self _ _))⟩ + · exact fun i hi => hvan i (Finset.mem_insert_of_mem hi) + +/-- A finite-dimensional space of functions on `κ` is separated by +finitely many coordinates: some finite `T` is such that a vector of the +space vanishing throughout `T` is zero. -/ +theorem exists_finset_separating [Field K] {κ : Type*} + (U : Submodule K (κ → K)) + [FiniteDimensional K U] : + ∃ T : Finset κ, ∀ w ∈ U, (∀ j ∈ T, w j = 0) → w = 0 := + separating_aux (Module.finrank K U) U inferInstance le_rfl + +/-! ## Finite submatrices and the row span -/ + +/-- The submatrix of `M` on the rows `S` and the columns `T`. -/ +def submatrixOn {ι : Type*} {κ : Type*} + (M : ι → κ → K) (S : Finset ι) (T : Finset κ) : + Matrix S T K := + (Matrix.of M).submatrix ((↑) : S → ι) ((↑) : T → κ) + +/-- The span of the rows of `M` indexed by a finite set of rows. -/ +private noncomputable def rowsOn + [Field K] {ι : Type*} {κ : Type*} (M : ι → κ → K) + (S : Finset ι) : Submodule K (κ → K) := + Submodule.span K (Set.range fun i : S => M (i : ι)) + +private theorem rowsOn_le [Field K] {ι : Type*} {κ : Type*} (M : ι → κ → K) + (S : Finset ι) : + rowsOn M S ≤ Submodule.span K (Set.range M) := + Submodule.span_mono (by rintro _ ⟨i, rfl⟩; exact ⟨(i : ι), rfl⟩) + +private instance rowsOn_finiteDimensional + [Field K] {ι : Type*} {κ : Type*} (M : ι → κ → K) + (S : Finset ι) : + FiniteDimensional K (rowsOn M S) := + FiniteDimensional.span_of_finite K (Set.finite_range _) + +private theorem span_rows_submatrixOn + [Field K] {ι : Type*} {κ : Type*} (M : ι → κ → K) + (S : Finset ι) (T : Finset κ) : + Submodule.span K (Set.range (submatrixOn M S T).row) + = Submodule.map (restrictTo T) (rowsOn M S) := by + rw [rowsOn, ← Submodule.span_image] + congr 1 + rw [← Set.range_comp] + rfl + +private instance span_rows_finiteDimensional + [Field K] {ι : Type*} {κ : Type*} (M : ι → κ → K) + (S : Finset ι) (T : Finset κ) : + FiniteDimensional K (Submodule.map (restrictTo T) (rowsOn M S)) := by + rw [← span_rows_submatrixOn] + exact FiniteDimensional.span_of_finite K (Set.finite_range _) + +private theorem rank_submatrixOn + [Field K] {ι : Type*} {κ : Type*} (M : ι → κ → K) + (S : Finset ι) (T : Finset κ) : + (submatrixOn M S T).rank + = Module.finrank K (Submodule.map (restrictTo T) (rowsOn M S)) := by + rw [Matrix.rank_eq_finrank_span_row, span_rows_submatrixOn] + +private theorem card_le_of_independent_in_span + [Field K] {ι : Type*} {κ : Type*} (M : ι → κ → K) + {n : ℕ} + (h : ∀ (S : Finset ι) (T : Finset κ), (submatrixOn M S T).rank ≤ n) + {σ : Type*} [Fintype σ] (w : σ → (κ → K)) (hw : LinearIndependent K w) + (hmem : ∀ i, w i ∈ Submodule.span K (Set.range M)) : + Fintype.card σ ≤ n := by + classical + -- The family is written over finitely many rows. + choose c hc using fun i => + Finsupp.mem_span_range_iff_exists_finsupp.mp (hmem i) + set S : Finset ι := Finset.univ.biUnion fun i => (c i).support with hSdef + have hwS : ∀ i, w i ∈ rowsOn M S := by + intro i + rw [← hc i, Finsupp.sum] + refine Submodule.sum_mem _ fun j hj => Submodule.smul_mem _ _ ?_ + exact Submodule.subset_span + ⟨⟨j, Finset.mem_biUnion.2 ⟨i, Finset.mem_univ _, hj⟩⟩, rfl⟩ + -- Finitely many columns already separate its span. + set U := Submodule.span K (Set.range w) with hUdef + have : FiniteDimensional K U := + FiniteDimensional.span_of_finite K (Set.finite_range _) + have hUle : U ≤ rowsOn M S := + Submodule.span_le.2 (by rintro _ ⟨i, rfl⟩; exact hwS i) + obtain ⟨T, hT⟩ := exists_finset_separating U + have hinj : Function.Injective (restrictTo T ∘ₗ U.subtype) := by + intro x y hxy + refine Subtype.ext (sub_eq_zero.1 (hT _ (U.sub_mem x.2 y.2) fun j hj => ?_)) + have hj' := congrFun hxy ⟨j, hj⟩ + simpa [restrictTo, sub_eq_zero] using hj' + have hrange : LinearMap.range (restrictTo T ∘ₗ U.subtype) + = Submodule.map (restrictTo T) U := by + rw [LinearMap.range_comp, Submodule.range_subtype] + -- Those rows and columns cut out a submatrix of at least this rank. + calc Fintype.card σ + = Module.finrank K U := by rw [hUdef, finrank_span_eq_card hw] + _ = Module.finrank K (Submodule.map (restrictTo T) U) := by + rw [← hrange, LinearMap.finrank_range_of_inj hinj] + _ ≤ Module.finrank K (Submodule.map (restrictTo T) (rowsOn M S)) := + Submodule.finrank_mono (Submodule.map_mono hUle) + _ = (submatrixOn M S T).rank := (rank_submatrixOn M S T).symm + _ ≤ n := h S T + +/-- **The row span and the finite submatrices agree in bounded form.** +The span of the rows of `M` has dimension at most `n` exactly when +every finite submatrix of `M` has rank at most `n`. -/ +theorem rank_span_rows_le_iff [Field K] {ι : Type*} {κ : Type*} (M : ι → κ → K) + (n : ℕ) : + Module.rank K (Submodule.span K (Set.range M)) ≤ (n : Cardinal) ↔ + ∀ (S : Finset ι) (T : Finset κ), (submatrixOn M S T).rank ≤ n := by + constructor + · -- A finite submatrix's row space is the image of finitely many + -- rows, so its dimension is at most the whole row span's. + intro h S T + rw [rank_submatrixOn] + refine (Submodule.finrank_map_le _ _).trans ?_ + have hcast : + (Module.finrank K (rowsOn M S) : Cardinal) ≤ (n : Cardinal) := by + rw [Module.finrank_eq_rank] + exact (Submodule.rank_mono (rowsOn_le M S)).trans h + exact_mod_cast hcast + · -- An independent finite family in the row span is bounded by + -- `card_le_of_independent_in_span`. + intro h + refine rank_le fun s hs => ?_ + have hcard := card_le_of_independent_in_span M h + (fun i : ↥s => ((i : ↥(Submodule.span K (Set.range M))) : κ → K)) + (by exact hs.map' _ (Submodule.ker_subtype _)) + (fun i => (i : ↥(Submodule.span K (Set.range M))).2) + rwa [Fintype.card_coe] at hcard + +/-- The range of `Finsupp.lift` at `M` is the span of the rows of +`M`. -/ +theorem range_lift_eq_span_rows + [Field K] {ι : Type*} {κ : Type*} (M : ι → κ → K) : + LinearMap.range (Finsupp.lift (κ → K) K ι M) + = Submodule.span K (Set.range M) := by + have hlift : (Finsupp.lift (κ → K) K ι M) = Finsupp.linearCombination K M := + LinearMap.ext fun g => by + rw [Finsupp.lift_apply, Finsupp.linearCombination_apply] + rw [hlift, Finsupp.range_linearCombination] + +/-- **The bounded row-rank criterion**, for the row span presented as +the range of `Finsupp.lift`. -/ +theorem rank_range_lift_le_iff [Field K] {ι : Type*} {κ : Type*} (M : ι → κ → K) + (n : ℕ) : + Module.rank K (LinearMap.range (Finsupp.lift (κ → K) K ι M)) + ≤ (n : Cardinal) ↔ + ∀ (S : Finset ι) (T : Finset κ), (submatrixOn M S T).rank ≤ n := by + rw [range_lift_eq_span_rows] + exact rank_span_rows_le_iff M n + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Common/TraceSeparation.lean b/LeanPool/RegtsSevenster/RS/Common/TraceSeparation.lean new file mode 100644 index 0000000000..adc7d3ce79 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/TraceSeparation.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Linear independence from a trace supported at the identity + +A linear functional on an algebra that is nonzero at the identity +of a group representation and zero at every other group element +separates the represented elements. Its translates give dual +functionals, so the group elements are linearly independent. +-/ + +@[expose] public section + +namespace RS + +/-- A trace supported at the identity separates every element of +a group representation. -/ +theorem linearIndependent_of_group_trace {G A : Type*} [Group G] + [DecidableEq G] + [Ring A] [Algebra ℂ A] (ρ : G →* A) (τ : A →ₗ[ℂ] ℂ) + {c : ℂ} (hc : c ≠ 0) + (hτ : ∀ σ, τ (ρ σ) = if σ = 1 then c else 0) : + LinearIndependent ℂ (fun σ => ρ σ) := by + classical + let dual : G → Module.Dual ℂ A := fun σ => + c⁻¹ • τ.comp (LinearMap.mulLeft ℂ (ρ σ⁻¹)) + apply LinearIndependent.of_pairwise_dual_eq_zero_one _ dual + · intro σ π hne + change c⁻¹ * τ (ρ σ⁻¹ * ρ π) = 0 + rw [← map_mul, hτ, ite_eq_right (fun h => hne (inv_mul_eq_one.mp h)), + mul_zero] + · intro σ + change c⁻¹ * τ (ρ σ⁻¹ * ρ σ) = 1 + rw [← map_mul, inv_mul_cancel, hτ, ite_eq_left rfl, inv_mul_cancel₀ hc] + +/-- In a finite-dimensional algebra a group representation with +such a trace has at most the dimension many group elements. -/ +theorem card_le_finrank_of_group_trace {G A : Type*} [Group G] + [DecidableEq G] + [Fintype G] [Ring A] [Algebra ℂ A] [Module.Finite ℂ A] + (ρ : G →* A) (τ : A →ₗ[ℂ] ℂ) {c : ℂ} (hc : c ≠ 0) + (hτ : ∀ σ, τ (ρ σ) = if σ = 1 then c else 0) : + Fintype.card G ≤ Module.finrank ℂ A := + (linearIndependent_of_group_trace ρ τ hc hτ).fintype_card_le_finrank + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Common/YoungDiagrams.lean b/LeanPool/RegtsSevenster/RS/Common/YoungDiagrams.lean new file mode 100644 index 0000000000..0203c16dab --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/YoungDiagrams.lean @@ -0,0 +1,150 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Young diagram helpers + +Shared Young-diagram vocabulary: the square diagram and the hook +membership predicate. The hook `IsInHook a b μ` is the confinement +region of the alive shapes in the hook-confinement argument, and the +square diagram is the shape whose dimension growth drives that +confinement. +-/ + +@[expose] public section + +namespace RS + +/-- The `s × s` square Young diagram. -/ +def squareDiagram (s : ℕ) : YoungDiagram := + YoungDiagram.ofRowLens (List.replicate s s) <| by + apply List.Pairwise.sortedGE + exact List.pairwise_replicate.mpr (Or.inr le_rfl) + +/-- Membership in the `(a, b)` hook: every row after the first `a` +has length at most `b` (rows are indexed from `0`, so this reads +`rowLen a ≤ b` by antitonicity of row lengths). -/ +def IsInHook (a b : ℕ) (μ : YoungDiagram) : Prop := + μ.rowLen a ≤ b + +/-! ### Square diagram: row lengths and membership -/ + +/-- The row-length list of the `s × s` square diagram is `s` copies +of `s`. -/ +theorem squareDiagram_rowLens (s : ℕ) : + (squareDiagram s).rowLens = List.replicate s s := + YoungDiagram.rowLens_ofRowLens_eq_self (fun x hx => by + rw [List.mem_replicate] at hx; omega) + +/-- A cell `(i, j)` lies in the `s × s` square diagram precisely when +both coordinates are strictly below `s`. -/ +@[simp] +theorem mem_squareDiagram {s : ℕ} {c : ℕ × ℕ} : + c ∈ squareDiagram s ↔ c.1 < s ∧ c.2 < s := by + simp only [squareDiagram, YoungDiagram.ofRowLens, YoungDiagram.mem_mk, + YoungDiagram.mem_cellsOfRowLens, List.length_replicate, + List.getElem_replicate] + exact ⟨fun ⟨h1, h2⟩ => ⟨h1, h2⟩, fun ⟨h1, h2⟩ => ⟨h1, h2⟩⟩ + +/-- The length of row `a` in the `s × s` square diagram is `s` when +`a < s`. -/ +theorem rowLen_squareDiagram {s a : ℕ} (ha : a < s) : + (squareDiagram s).rowLen a = s := by + apply le_antisymm + · -- rowLen a ≤ s: otherwise (a, s) ∈ squareDiagram s, giving s < s + exact Nat.not_lt.mp fun h => + absurd (mem_squareDiagram.mp (YoungDiagram.mem_iff_lt_rowLen.mpr h)).2 + (lt_irrefl s) + · -- s ≤ rowLen a: otherwise rowLen a < s and (a, rowLen a) ∈ squareDiagram s, + -- giving rowLen a < rowLen a + exact Nat.not_lt.mp fun h => + absurd (YoungDiagram.mem_iff_lt_rowLen.mp + (mem_squareDiagram.mpr ⟨ha, h⟩)) (lt_irrefl _) + +/-- The cardinality (number of cells) of the `s × s` square diagram +is `s²`. -/ +theorem squareDiagram_card (s : ℕ) : (squareDiagram s).card = s ^ 2 := by + have hext : (squareDiagram s).cells = Finset.range s ×ˢ Finset.range s := by + ext c + simp [Finset.mem_product, Finset.mem_range] + simp [YoungDiagram.card, hext, Finset.card_product, sq] + +/-! ### Square diagram containment -/ + +/-- If the `(s − 1)`-th row of `μ` has length at least `s`, the +`s × s` square fits inside `μ`. -/ +theorem squareDiagram_le_of_rowLen {s : ℕ} {μ : YoungDiagram} + (h : s ≤ μ.rowLen (s - 1)) : squareDiagram s ≤ μ := by + intro c hc + rw [mem_squareDiagram] at hc + rw [YoungDiagram.mem_iff_lt_rowLen] + rcases s with _ | s + · exact absurd hc.1 (by omega) + · simp only [Nat.succ_sub_one] at h + calc c.2 < s + 1 := hc.2 + _ ≤ μ.rowLen s := h + _ ≤ μ.rowLen c.1 := μ.rowLen_anti c.1 s (by omega) + +/-! ### Hook predicate -/ + +/-- The negation of the hook predicate is equivalent to the cell +`(a, b)` belonging to the diagram. -/ +theorem not_isInHook_iff {a b : ℕ} {μ : YoungDiagram} : + ¬IsInHook a b μ ↔ b < μ.rowLen a := + Nat.not_le + +/-! ### List-to-diagram bridge -/ + +/-- The row length of the diagram built from `w` at index `i` equals +`w.getD i 0`: the `i`-th entry when `i` is in range, and `0` +otherwise. -/ +theorem rowLen_ofRowLens_getD {w : List ℕ} {hw : w.SortedGE} (i : ℕ) : + (YoungDiagram.ofRowLens w hw).rowLen i = w.getD i 0 := by + rw [List.getD_eq_getElem?_getD] + by_cases hi : i < w.length + · rw [List.getElem?_eq_getElem hi, Option.getD_some] + exact YoungDiagram.rowLen_ofRowLens ⟨i, hi⟩ + · rw [List.getElem?_eq_none (by omega), Option.getD_none] + have : ¬(0 < (YoungDiagram.ofRowLens w hw).rowLen i) := by + rw [← YoungDiagram.mem_iff_lt_rowLen, YoungDiagram.mem_ofRowLens] + exact fun ⟨h, _⟩ => absurd h (not_lt.mpr (by omega)) + omega + +/-- Containment of diagrams is containment of cell sets, so the +cell count is monotone. -/ +theorem YoungDiagram.card_le_card {lam mu : YoungDiagram} + (hle : lam ≤ mu) : lam.card ≤ mu.card := + Finset.card_le_card hle + +/-- Summing a function over `List.range` agrees with summing it over +`Finset.range`. -/ +private theorem sum_map_range (n : ℕ) (f : ℕ → ℕ) : + ((List.range n).map f).sum = ∑ i ∈ Finset.range n, f i := by + rw [Finset.sum_eq_multiset_sum, Finset.range_val, ← Multiset.coe_range, + Multiset.map_coe, Multiset.sum_coe] + +/-- The number of cells of a Young diagram is the sum of its row +lengths. -/ +theorem card_eq_sum_rowLens (μ : YoungDiagram) : + μ.card = μ.rowLens.sum := by + have hmem : ∀ c ∈ μ.cells, c.1 ∈ Finset.range (μ.colLen 0) := by + intro c hc + rw [Finset.mem_range] + exact lt_of_lt_of_le (YoungDiagram.mem_iff_lt_colLen.mp hc) + (μ.colLen_anti 0 c.2 (Nat.zero_le _)) + calc μ.card + = ∑ i ∈ Finset.range (μ.colLen 0), + (μ.cells.filter fun c => c.1 = i).card := + Finset.card_eq_sum_card_fiberwise hmem + _ = ∑ i ∈ Finset.range (μ.colLen 0), μ.rowLen i := + Finset.sum_congr rfl fun i _ => (μ.rowLen_eq_card (i := i)).symm + _ = μ.rowLens.sum := (sum_map_range _ _).symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Definitions.lean b/LeanPool/RegtsSevenster/RS/Definitions.lean new file mode 100644 index 0000000000..7a988aa1a7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Definitions.lean @@ -0,0 +1,2505 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# The statement surface, defined + +Every definition the theorems of record are phrased in, in one self-contained +module: the flag model of multigraph fragments with its gluing, fragment +isomorphism, composition, the connection pairing and the edge-rank hypothesis, +Eulerian edge subsets, the mixed partition function (Regts–Sevenster's +Definition 5), the three named statements, the symmetric monoidal category of +super vector spaces, the vocabulary of Deligne's hypotheses, and Deligne's +theorem, which `RS/Classical/Deligne/` proves. + +This module imports only the Mathlib funnel (`RS/Common/MathlibDeps.lean`, an +import list with no content), so its meaning is determined by this file +against Mathlib alone. It is the trusted surface of the comparator +certification: `Challenge.lean` carries a copy of the sections below, against +Mathlib alone, and states the theorems of record with `sorry`; `Solution.lean` +proves each by the theorem of record of the same name, against the definitions +here. Comparator confirms at the kernel-export level that the two sides prove +identical statements about identical definitions — the definitions below. The +rest of the tree imports them from here rather than restating them, so this +file is the single source of what the theorems mean. + +**How to read it.** Each section names the theory it carries; the rest of the +repository builds on these declarations by import, so what is written here is, +verbatim, what the theorems of record are about. The order is: the sorting +sign; fragments and gluing; fragment isomorphism; composition; connection +pairings and the edge-rank hypothesis; Eulerian edge subsets; the mixed +partition function; the named statements; super vector spaces; the vocabulary +of Deligne's hypotheses; and Deligne's theorem. -/ + +@[expose] public section + +namespace RS + +/-! ## 1. Inversions and the sorting sign + +The sorting sign supplies the antisymmetry of the odd-colour evaluation in +Definition 5: reordering the odd colours multiplies the vertex value by the +sign of the permutation, realized as `(−1)` to the inversion count. -/ + +/-- The number of inversions of a list over a linear order. -/ +def inversions {α : Type} [LinearOrder α] : List α → ℕ + | [] => 0 + | a :: l => (l.filter (fun b => b < a)).length + inversions l + +/-- The sorting sign of a list: `(−1)` to the number of +inversions. -/ +def sortSign {α : Type} [LinearOrder α] (l : List α) : ℤ := + (-1) ^ inversions l + +/-! ## 2. The flag model of multigraph fragments + +A *fragment* is a finite multigraph in half-edge (flag) form: flags attach to +internal vertices or to boundary labels, a fixed-point-free involution pairs +flags into edges, each boundary label carries exactly one flag, and free +circles are counted separately. Gluing two boundary labels either closes an +edge into a free circle (when the two flags bound a common edge) or rewires +the two edges end to end. These are the graphs the main theorems quantify +over; `ClosedFragment` below is the case of no boundary labels. -/ + +/-- A fragment over the boundary-label type `α`: a finite multigraph +in half-edge (flag) form whose dangling flags are labelled +bijectively by `α`, together with a count of free circles. -/ +structure Fragment (α : Type) where + /-- The type of flags (half-edges). -/ + Flag : Type + /-- The type of internal vertices. -/ + Vertex : Type + /-- Flags form a finite type with decidable equality. -/ + [flagFintype : Fintype Flag] + [flagDecEq : DecidableEq Flag] + /-- Vertices form a finite type. -/ + [vertexFintype : Fintype Vertex] + /-- Each flag is attached to an internal vertex or to a boundary + label. -/ + attach : Flag → Vertex ⊕ α + /-- The edge involution: every flag has a partner. -/ + pairing : Flag → Flag + /-- The pairing is an involution. -/ + pairing_invol : ∀ f, pairing (pairing f) = f + /-- The pairing has no fixed points. -/ + pairing_ne : ∀ f, pairing f ≠ f + /-- The flag at each boundary label. -/ + boundaryFlag : α → Flag + /-- The boundary flag of `ℓ` is attached to `ℓ`. -/ + attach_boundaryFlag : ∀ ℓ, attach (boundaryFlag ℓ) = Sum.inr ℓ + /-- Any flag attached to `ℓ` is the boundary flag of `ℓ`. -/ + eq_boundaryFlag : ∀ ℓ f, attach f = Sum.inr ℓ → f = boundaryFlag ℓ + /-- Free circles, counted separately. -/ + circles : ℕ + +attribute [instance] Fragment.flagFintype Fragment.flagDecEq + Fragment.vertexFintype + +namespace Fragment + +variable {α β : Type} + +/-- Boundary flags of distinct labels are distinct. -/ +theorem boundaryFlag_injective (W : Fragment α) : + Function.Injective W.boundaryFlag := by + intro i j hij + have hi := W.attach_boundaryFlag i + have hj := W.attach_boundaryFlag j + rw [hij, hj] at hi + exact (Sum.inr.inj hi).symm + +/-- Bounding a common edge is symmetric in the two labels: if the +flag at `i` pairs to the flag at `j`, then the flag at `j` pairs back +to the flag at `i`. -/ +theorem pairing_boundaryFlag_comm (W : Fragment α) {i j : α} + (h : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) : + W.pairing (W.boundaryFlag j) = W.boundaryFlag i := by + rw [← h, W.pairing_invol] + +/-- The closed fragment with no flags, no vertices, and a given +number of free circles. -/ +def circlesOnly (c : ℕ) : Fragment Empty where + Flag := Empty + Vertex := Empty + attach := Empty.elim + pairing := Empty.elim + pairing_invol := fun f => f.elim + pairing_ne := fun f => f.elim + boundaryFlag := Empty.elim + attach_boundaryFlag := fun ℓ => ℓ.elim + eq_boundaryFlag := fun ℓ => ℓ.elim + circles := c + +/-- Transport a fragment along an equivalence of label types. -/ +def relabel (W : Fragment α) (e : α ≃ β) : Fragment β where + Flag := W.Flag + Vertex := W.Vertex + attach := fun f => (W.attach f).map id e + pairing := W.pairing + pairing_invol := W.pairing_invol + pairing_ne := W.pairing_ne + boundaryFlag := fun ℓ => W.boundaryFlag (e.symm ℓ) + attach_boundaryFlag := fun ℓ => by + simp [W.attach_boundaryFlag (e.symm ℓ)] + eq_boundaryFlag := fun ℓ f h => by + rcases ha : W.attach f with v | ℓ' + · simp [ha] at h + · simp only [ha, Sum.map_inr] at h + obtain rfl : e ℓ' = ℓ := Sum.inr.inj h + rw [Equiv.symm_apply_apply] + exact W.eq_boundaryFlag ℓ' f ha + circles := W.circles + +/-- Disjoint union of fragments, over the sum of the label types. -/ +def disjUnion (W₁ : Fragment α) (W₂ : Fragment β) : + Fragment (α ⊕ β) where + Flag := W₁.Flag ⊕ W₂.Flag + Vertex := W₁.Vertex ⊕ W₂.Vertex + attach := Sum.elim + (fun f => (W₁.attach f).map Sum.inl Sum.inl) + (fun f => (W₂.attach f).map Sum.inr Sum.inr) + pairing := Sum.map W₁.pairing W₂.pairing + pairing_invol := fun f => by + cases f <;> simp [W₁.pairing_invol, W₂.pairing_invol] + pairing_ne := fun f => by + cases f with + | inl g => simpa using fun h => W₁.pairing_ne g h + | inr g => simpa using fun h => W₂.pairing_ne g h + boundaryFlag := Sum.elim + (fun ℓ => Sum.inl (W₁.boundaryFlag ℓ)) + (fun ℓ => Sum.inr (W₂.boundaryFlag ℓ)) + attach_boundaryFlag := fun ℓ => by + cases ℓ <;> simp [W₁.attach_boundaryFlag, W₂.attach_boundaryFlag] + eq_boundaryFlag := fun ℓ f h => by + cases ℓ with + | inl ℓ₁ => + cases f with + | inl g => + rcases ha : W₁.attach g with v | ℓ' <;> simp only [Sum.elim_inl, ha, Sum.map_inl, + reduceCtorEq, Sum.map_inr, Sum.inr.injEq, Sum.inl.injEq] at h + subst h + simp [W₁.eq_boundaryFlag ℓ' g ha] + | inr g => + rcases ha : W₂.attach g with v | ℓ' <;> simp [ha] at h + | inr ℓ₂ => + cases f with + | inl g => + rcases ha : W₁.attach g with v | ℓ' <;> simp [ha] at h + | inr g => + rcases ha : W₂.attach g with v | ℓ' <;> simp only [Sum.elim_inr, ha, Sum.map_inl, + reduceCtorEq, Sum.map_inr, Sum.inr.injEq] at h + subst h + simp [W₂.eq_boundaryFlag ℓ' g ha] + circles := W₁.circles + W₂.circles + +/-! ### Single-pair gluing -/ + +section GluePair + +/-- The labels surviving a glue at `{i, j}`. -/ +abbrev SurvivingLabel (α : Type) (i j : α) : Type := + {x : α // x ≠ i ∧ x ≠ j} + +/-- The flags surviving a glue at `{i, j}`: all but the two glued +boundary flags. -/ +abbrev SurvivingFlag (W : Fragment α) (i j : α) : Type := + {f : W.Flag // f ≠ W.boundaryFlag i ∧ f ≠ W.boundaryFlag j} + +/-- A surviving flag is never attached to a glued label. -/ +theorem survivingFlag_attach_ne {W : Fragment α} {i j : α} + (f : SurvivingFlag W i j) : + W.attach f.val ≠ Sum.inr i ∧ W.attach f.val ≠ Sum.inr j := + ⟨fun h => f.prop.1 (W.eq_boundaryFlag i f.val h), + fun h => f.prop.2 (W.eq_boundaryFlag j f.val h)⟩ + +/-- The attachment map computed at a *given* value of `W.attach`, +which is supplied together with the equation identifying it. Taking +the value as a parameter is what lets every proof below reason by +cases on it, so `glueAttach` itself is never unfolded. -/ +def glueAttachOn (W : Fragment α) (i j : α) (f : SurvivingFlag W i j) : + ∀ s : W.Vertex ⊕ α, W.attach f.val = s → + W.Vertex ⊕ SurvivingLabel α i j + | Sum.inl v, _ => Sum.inl v + | Sum.inr ℓ, ha => Sum.inr ⟨ℓ, + fun h => (survivingFlag_attach_ne f).1 (h ▸ ha), + fun h => (survivingFlag_attach_ne f).2 (h ▸ ha)⟩ + +/-- The attachment map after gluing at `{i, j}`: unchanged, with the +label type restricted to the surviving labels. -/ +def glueAttach (W : Fragment α) (i j : α) (f : SurvivingFlag W i j) : + W.Vertex ⊕ SurvivingLabel α i j := + glueAttachOn W i j f (W.attach f.val) rfl + +/-- `glueAttachOn` returns, under the label inclusion, exactly the +value of `attach` it was handed. -/ +theorem glueAttachOn_spec (W : Fragment α) (i j : α) + (f : SurvivingFlag W i j) (s : W.Vertex ⊕ α) (h : W.attach f.val = s) : + (glueAttachOn W i j f s h).map id Subtype.val = s := by + cases s <;> rfl + +/-- `glueAttach` agrees with `attach` under the label inclusion. -/ +theorem glueAttach_spec (W : Fragment α) (i j : α) + (f : SurvivingFlag W i j) : + (glueAttach W i j f).map id Subtype.val = W.attach f.val := + glueAttachOn_spec W i j f _ rfl + +end GluePair + +section GluePairRewire + +variable {W : Fragment α} {i j : α} + +/-- The rewired pairing for an *open* glue (the two glued flags do +not bound a common edge): the far ends of the two glued edges become +partners; all other flags keep their partners. -/ +def rewire (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (f : SurvivingFlag W i j) : SurvivingFlag W i j := + if hfi : W.pairing f.val = W.boundaryFlag i then + ⟨W.pairing (W.boundaryFlag j), + fun h => hopen (W.pairing_boundaryFlag_comm h), + fun h => W.pairing_ne (W.boundaryFlag j) h⟩ + else if hfj : W.pairing f.val = W.boundaryFlag j then + ⟨W.pairing (W.boundaryFlag i), + fun h => W.pairing_ne (W.boundaryFlag i) h, + fun h => hopen h⟩ + else + ⟨W.pairing f.val, hfi, hfj⟩ + +/-- Rewiring across an open glue is an involution: it is the glued +fragment's edge pairing. -/ +theorem rewire_invol (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (f : SurvivingFlag W i j) : + rewire hopen (rewire hopen f) = f := by + have hbne : W.boundaryFlag i ≠ W.boundaryFlag j := + fun h => hij (W.boundaryFlag_injective h) + unfold rewire + split + · -- f is the far end of i's edge; its rewired partner is the far + -- end of j's edge, whose rewired partner is back at f. + rename_i hfi + rw [dite_eq_right (by + rw [W.pairing_invol] + exact fun h => hbne h.symm)] + rw [dite_eq_left (by rw [W.pairing_invol])] + refine Subtype.ext ?_ + have h2 := congrArg W.pairing hfi + rw [W.pairing_invol] at h2 + exact h2.symm + · split + · rename_i hfi hfj + rw [dite_eq_left (by rw [W.pairing_invol])] + refine Subtype.ext ?_ + have h2 := congrArg W.pairing hfj + rw [W.pairing_invol] at h2 + exact h2.symm + · rename_i hfi hfj + rw [dite_eq_right (by rw [W.pairing_invol]; exact fun h => f.prop.1 h)] + rw [dite_eq_right (by rw [W.pairing_invol]; exact fun h => f.prop.2 h)] + exact Subtype.ext (W.pairing_invol f.val) + +/-- And fixed-point-free, so the glued fragment is again a +fragment. -/ +theorem rewire_ne (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (f : SurvivingFlag W i j) : rewire hopen f ≠ f := by + have hbne : W.boundaryFlag i ≠ W.boundaryFlag j := + fun h => hij (W.boundaryFlag_injective h) + unfold rewire + split + · rename_i hfi + intro h + have hval := congrArg Subtype.val h + have : W.pairing f.val = W.boundaryFlag j := by + rw [← hval, W.pairing_invol] + exact hbne (hfi ▸ this) + · split + · rename_i hfi hfj + intro h + have hval := congrArg Subtype.val h + exact hfi (by rw [← hval, W.pairing_invol]) + · intro h + exact W.pairing_ne f.val (congrArg Subtype.val h) + +end GluePairRewire + +/-! ### The glued fragment -/ + +section Glue + +variable (W : Fragment α) (i j : α) + +/-- The boundary flag of a surviving label survives the glue. -/ +def glueBoundaryFlag (ℓ : SurvivingLabel α i j) : SurvivingFlag W i j := + ⟨W.boundaryFlag ℓ.val, + fun h => ℓ.prop.1 (W.boundaryFlag_injective h), + fun h => ℓ.prop.2 (W.boundaryFlag_injective h)⟩ + +variable {W i j} + +/-- The glued attachment lands on a surviving label exactly when +the original attachment lands on its underlying label. -/ +theorem glueAttach_inr_iff (f : SurvivingFlag W i j) + (ℓ : SurvivingLabel α i j) : + glueAttach W i j f = Sum.inr ℓ ↔ W.attach f.val = Sum.inr ℓ.val := by + constructor + · intro h + have := glueAttach_spec W i j f + rw [h] at this + simpa using this.symm + · intro h + have hs := glueAttach_spec W i j f + rw [h] at hs + cases hg : glueAttach W i j f with + | inl v => rw [hg] at hs; exact absurd hs (by simp) + | inr m => + rw [hg] at hs + simp only [Sum.map_inr, Sum.inr.injEq] at hs + exact congrArg Sum.inr (Subtype.ext hs) + +/-- The glued attachment lands on a vertex exactly when the original +attachment does. With `glueAttach_inr_iff` this characterises +`glueAttach`, so no proof needs to unfold it. -/ +theorem glueAttach_inl_iff (f : SurvivingFlag W i j) (v : W.Vertex) : + glueAttach W i j f = Sum.inl v ↔ W.attach f.val = Sum.inl v := by + have hs := glueAttach_spec W i j f + constructor + · intro h; rw [h] at hs; simpa using hs.symm + · intro h + rw [h] at hs + cases hg : glueAttach W i j f with + | inl v' => rw [hg] at hs; simp only [Sum.map_inl, id_eq, + Sum.inl.injEq] at hs; rw [hs] + | inr m => rw [hg] at hs; exact absurd hs (by simp) + +/-- The surviving label a flag glues onto, with its equation. -/ +theorem exists_glueAttach_inr (f : SurvivingFlag W i j) {ℓ : α} + (ha : W.attach f.val = Sum.inr ℓ) : + ∃ p : SurvivingLabel α i j, + glueAttach W i j f = Sum.inr p ∧ p.val = ℓ := + ⟨⟨ℓ, fun e => (survivingFlag_attach_ne f).1 (e ▸ ha), + fun e => (survivingFlag_attach_ne f).2 (e ▸ ha)⟩, + (glueAttach_inr_iff f _).mpr ha, rfl⟩ + +/-- Case analysis on `glueAttach`, phrased on the value of `attach`. +This is the eliminator every proof below uses: it replaces unfolding +the definition, so `glueAttach` is never unfolded anywhere. -/ +@[elab_as_elim] +theorem glueAttach_cases {motive : W.Vertex ⊕ SurvivingLabel α i j → Prop} + (f : SurvivingFlag W i j) + (hinl : ∀ v, W.attach f.val = Sum.inl v → motive (Sum.inl v)) + (hinr : ∀ p : SurvivingLabel α i j, + W.attach f.val = Sum.inr p.val → motive (Sum.inr p)) : + motive (glueAttach W i j f) := by + cases hg : glueAttach W i j f with + | inl v => exact hinl v ((glueAttach_inl_iff f v).mp hg) + | inr p => exact hinr p ((glueAttach_inr_iff f p).mp hg) + +variable (W i j) + +/-- The glued attachment of a surviving label's flag is that +label. -/ +theorem glue_attach_boundaryFlag (ℓ : SurvivingLabel α i j) : + glueAttach W i j (glueBoundaryFlag W i j ℓ) = Sum.inr ℓ := + (glueAttach_inr_iff _ _).mpr (W.attach_boundaryFlag ℓ.val) + +/-- A surviving flag attached to a surviving label is that label's +boundary flag. -/ +theorem glue_eq_boundaryFlag (ℓ : SurvivingLabel α i j) + (f : SurvivingFlag W i j) (h : glueAttach W i j f = Sum.inr ℓ) : + f = glueBoundaryFlag W i j ℓ := + Subtype.ext (W.eq_boundaryFlag ℓ.val f.val ((glueAttach_inr_iff _ _).mp h)) + +/-- A glue at `{i, j}` with a prescribed pairing and circle count. + +Flags, vertices, attachment and boundary flags of a single-pair glue +are determined by `W` alone; only the pairing and the circle count +tell the closed and open glues apart. Naming that common part gives +the two glues a single shape, so any fact about a glue that does not +mention its pairing is proved once. -/ +def glueWith (p : SurvivingFlag W i j → SurvivingFlag W i j) + (hinvol : ∀ f, p (p f) = f) (hne : ∀ f, p f ≠ f) (c : ℕ) : + Fragment (SurvivingLabel α i j) where + Flag := SurvivingFlag W i j + Vertex := W.Vertex + attach := glueAttach W i j + pairing := p + pairing_invol := hinvol + pairing_ne := hne + boundaryFlag := glueBoundaryFlag W i j + attach_boundaryFlag := glue_attach_boundaryFlag W i j + eq_boundaryFlag := glue_eq_boundaryFlag W i j + circles := c + +/-- Gluing the boundary labels `i ≠ j` when their flags bound a +common edge: the edge closes into a free circle. -/ +def gluePairClosed (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) : + Fragment (SurvivingLabel α i j) := + glueWith W i j + (fun f => + ⟨W.pairing f.val, + fun h => f.prop.2 (by + rw [← W.pairing_invol f.val, h, hclosed]), + fun h => f.prop.1 (by + rw [← W.pairing_invol f.val, h, ← hclosed, W.pairing_invol])⟩) + (fun f => Subtype.ext (W.pairing_invol f.val)) + (fun f h => W.pairing_ne f.val (congrArg Subtype.val h)) + (W.circles + 1) + +/-- Gluing the boundary labels `i ≠ j` when their flags bound +distinct edges: the two edges are unified by rewiring. -/ +def gluePairOpen (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) : + Fragment (SurvivingLabel α i j) := + glueWith W i j (rewire hopen) (rewire_invol hij hopen) + (rewire_ne hij hopen) W.circles + +/-- Gluing a pair of distinct boundary labels: the two half-edges at +`i` and `j` are joined. If they bound a common edge it closes into a +free circle; otherwise their edges are unified end to end. -/ +def gluePair (hij : i ≠ j) : Fragment (SurvivingLabel α i j) := + if hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j then + gluePairClosed W i j hclosed + else + gluePairOpen W i j hij hclosed + +end Glue + +/-! ## 3. Isomorphism of fragments + +The hypothesis class asks parameters to be isomorphism-invariant; this is the +notion of isomorphism. (`RS/Novel/Skein/FragmentEquiv.lean` proves the +equivalences form a groupoid and are congruences for the fragment operations.) +-/ + +/-- An equivalence of fragments: a pair of type equivalences on +flags and vertices commuting with attachment, pairing, and +boundary-flag data, preserving the circle count. -/ +structure Equiv (W₁ W₂ : Fragment α) where + /-- The equivalence of flag types. -/ + flagEquiv : W₁.Flag ≃ W₂.Flag + /-- The equivalence of vertex types. -/ + vertexEquiv : W₁.Vertex ≃ W₂.Vertex + /-- The flag equivalence commutes with attachment. -/ + attach_comm : ∀ f, W₂.attach (flagEquiv f) = + (W₁.attach f).map vertexEquiv id + /-- The flag equivalence commutes with pairing. -/ + pairing_comm : ∀ f, flagEquiv (W₁.pairing f) = + W₂.pairing (flagEquiv f) + /-- The circle counts agree. -/ + circles_eq : W₁.circles = W₂.circles + +end Fragment + +/-! ## 4. Composition of fragments + +An `(s + t)`-fragment and a `(t + u)`-fragment compose by gluing the last `t` +labels of the first to the first `t` of the second, top pair first, through +the single-pair gluing above; the label bookkeeping is by one-point removals +of `Fin` indices. Composition is what the connection pairing evaluates. -/ + +/-! ### Removing a point -/ + +/-- Removing one point from `Fin (n + 1)` leaves `Fin n`. -/ +noncomputable def finRemoveEquiv {n : ℕ} (a : Fin (n + 1)) : + {x : Fin (n + 1) // x ≠ a} ≃ Fin n where + toFun x := ((finSuccEquiv' a) x.val).get (by + rw [Option.isSome_iff_ne_none] + intro h + exact x.prop ((finSuccEquiv' a).injective (h.trans (finSuccEquiv'_at + a).symm))) + invFun y := ⟨(finSuccEquiv' a).symm (some y), by + intro h + have happ := (finSuccEquiv' a).apply_symm_apply (some y) + rw [h, finSuccEquiv'_at] at happ + exact Option.some_ne_none y happ.symm⟩ + left_inv x := Subtype.ext (by simp) + right_inv y := by simp + +/-- Removing `inl a` and `inr b` from a sum splits into the two +one-point removals. -/ +def sumRemoveSplitEquiv {A B : Type} (a : A) (b : B) : + {x : A ⊕ B // x ≠ Sum.inl a ∧ x ≠ Sum.inr b} ≃ + {x : A // x ≠ a} ⊕ {y : B // y ≠ b} where + toFun := fun + | ⟨Sum.inl v, h⟩ => Sum.inl ⟨v, fun he => h.1 (congrArg Sum.inl he)⟩ + | ⟨Sum.inr w, h⟩ => Sum.inr ⟨w, fun he => h.2 (congrArg Sum.inr he)⟩ + invFun := fun + | Sum.inl v => ⟨Sum.inl v.val, + fun h => v.prop (Sum.inl.inj h), fun h => Sum.inl_ne_inr h⟩ + | Sum.inr w => ⟨Sum.inr w.val, + fun h => Sum.inr_ne_inl h, fun h => w.prop (Sum.inr.inj h)⟩ + left_inv := fun + | ⟨Sum.inl _, _⟩ => rfl + | ⟨Sum.inr _, _⟩ => rfl + right_inv := fun + | Sum.inl _ => rfl + | Sum.inr _ => rfl + +/-- Removing label `t` from `Fin (t + 1 + u)` leaves `Fin (t + u)`. -/ +noncomputable def rightRemoveEquiv (t u : ℕ) : + {x : Fin (t + 1 + u) // x ≠ ⟨t, by omega⟩} ≃ Fin (t + u) := + Equiv.trans + (Equiv.subtypeEquiv (finCongr (by omega : t + 1 + u = (t + u) + 1)) + (fun x => by simp [Fin.ext_iff])) + (finRemoveEquiv ⟨t, by omega⟩) + +/-- The label re-indexing after gluing the top interface pair: +removing the last label on the left and label `t` on the right. -/ +noncomputable def interfaceStepEquiv (s t u : ℕ) : + {x : Fin (s + t + 1) ⊕ Fin (t + 1 + u) // + x ≠ Sum.inl ⟨s + t, Nat.lt_succ_self _⟩ ∧ + x ≠ Sum.inr ⟨t, by omega⟩} ≃ Fin (s + t) ⊕ Fin (t + u) := + Equiv.trans (sumRemoveSplitEquiv _ _) + (Equiv.sumCongr (finRemoveEquiv _) (rightRemoveEquiv t u)) + +/-! ### Gluing an interface -/ + +/-- Glue the `t` interface labels of a fragment over +`Fin (s + t) ⊕ Fin (t + u)`: the pairs `(inl (s + k), inr k)` for +`k < t`, glued top pair first. -/ +noncomputable def glueInterface (s : ℕ) : + (t : ℕ) → (u : ℕ) → Fragment (Fin (s + t) ⊕ Fin (t + u)) → + Fragment (Fin s ⊕ Fin u) + | 0, _, W => W.relabel + (Equiv.sumCongr (finCongr (by omega)) (finCongr (by omega))) + | t + 1, u, W => + let W' := W.gluePair (Sum.inl ⟨s + t, by omega⟩) + (Sum.inr ⟨t, by omega⟩) (by simp) + glueInterface s t u (W'.relabel (interfaceStepEquiv s t u)) + +/-- Composition of fragments: glue the last `t` labels of `F` to the +first `t` labels of `G`, in order. -/ +noncomputable def Fragment.compose {s t u : ℕ} + (F : Fragment (Fin (s + t))) (G : Fragment (Fin (t + u))) : + Fragment (Fin (s + u)) := + (glueInterface s t u (F.disjUnion G)).relabel finSumFinEquiv + +/-! ## 5. Connection pairings and the edge-rank hypothesis + +The connection pairing of a parameter at arity `t` closes two `t`-fragments +against each other; the edge-rank hypothesis bounds, for every `t`, the rank +of that pairing by `R ^ t`, phrased as the `Module.rank` of the range of the +curried pairing (`RS/Novel/Skein/ConnectionRank.lean` proves this equivalent +to the finite-submatrix reading of the literature; that equivalence is a +theorem *about* the hypothesis and is not needed to state it). +`EdgeRankParameter` packages the hypothesis class of the forward direction: +normalized at the empty graph, isomorphism-invariant, rank-bounded. -/ + +/-- A closed fragment: no boundary labels. -/ +abbrev ClosedFragment : Type 1 := Fragment (Fin 0) + +/-- The full closure of two `t`-fragments: compose them as a +`(0 + t)`- and a `(t + 0)`-fragment. -/ +noncomputable def pairClose {t : ℕ} (F G : Fragment (Fin t)) : + ClosedFragment := + (F.relabel (finCongr (by omega : t = 0 + t))).compose + (G.relabel (finCongr (by omega : t = t + 0))) + +/-- The connection pairing of a parameter at arity `t`. -/ +noncomputable def connectionPairing (f : ClosedFragment → ℂ) (t : ℕ) + (F G : Fragment (Fin t)) : ℂ := + f (pairClose F G) + +/-- The curried connection pairing as a linear map from the free +module on `t`-fragments to the function space. -/ +noncomputable def connectionMap (f : ClosedFragment → ℂ) (t : ℕ) : + (Fragment (Fin t) →₀ ℂ) →ₗ[ℂ] (Fragment (Fin t) → ℂ) := + Finsupp.lift _ ℂ _ (fun F G => connectionPairing f t F G) + +/-- The edge-rank hypothesis `H2`: the connection pairing at every +arity has rank at most `R ^ t`. -/ +def EdgeRankBounded (f : ClosedFragment → ℂ) (R : ℕ) : Prop := + ∀ t : ℕ, Module.rank ℂ (LinearMap.range (connectionMap f t)) ≤ + (R : Cardinal) ^ t + +/-- The empty closed fragment. -/ +noncomputable def emptyClosedFragment : ClosedFragment := + (Fragment.circlesOnly 0).relabel (Equiv.equivOfIsEmpty Empty (Fin 0)) + +/-- The hypothesis class of the main theorem: a parameter on closed +fragments, normalized on the empty graph, with exponentially +bounded connection rank. -/ +structure EdgeRankParameter (R : ℕ) where + /-- The parameter, on concrete closed fragments. -/ + val : ClosedFragment → ℂ + /-- The parameter takes the value `1` on the empty graph. -/ + val_empty : val emptyClosedFragment = 1 + /-- The parameter is invariant under fragment isomorphism. -/ + iso_invariant : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → val W₁ = val W₂ + /-- The rank bound. -/ + rank_bounded : EdgeRankBounded val R + +/-! ## 6. Eulerian edge subsets and circuit data + +Definition 5 sums over pairing-closed flag subsets in which every vertex has +even degree. A *transition system* is the local pairing `κ` of Definition 5: a +second fixed-point-free involution matching participating flags at common +vertices. Following an edge and then the matching generates the circuit walks; +each geometric circuit of `n` edges appears as two walk-cycles (its two +directions) when `n ≥ 2` and as two walk fixed points when `n = 1`, so the +circuit count is half the number of orbits. -/ + +variable {α : Type} + +/-- An edge subset of a fragment: a flag set closed under the edge +pairing. -/ +structure EdgeSubset (W : Fragment α) where + /-- The participating flags. -/ + flags : Finset W.Flag + /-- The set is closed under the edge pairing. -/ + pairing_mem : ∀ f ∈ flags, W.pairing f ∈ flags + +namespace EdgeSubset + +variable {W : Fragment α} + +/-- The degree of a vertex within an edge subset: the number of +participating flags attached to it. -/ +noncomputable def deg (F : EdgeSubset W) (v : W.Vertex) : ℕ := + letI := Classical.decEq (W.Vertex ⊕ α) + (F.flags.filter (fun f => W.attach f = Sum.inl v)).card + +/-- An edge subset is Eulerian when every vertex has even degree +within it. -/ +def Eulerian (F : EdgeSubset W) : Prop := + ∀ v : W.Vertex, Even (F.deg v) + +/-- A transition system on an edge subset: a fixed-point-free +involution of its flags matching flags at a common internal +vertex. This is the local pairing data `κ` of Definition 5. -/ +structure TransitionSystem (F : EdgeSubset W) where + /-- The matching. -/ + match_ : W.Flag → W.Flag + /-- The matching is an involution on the participating flags. -/ + match_invol : ∀ f ∈ F.flags, match_ (match_ f) = f + /-- The matching has no fixed points on the participating flags. -/ + match_ne : ∀ f ∈ F.flags, match_ f ≠ f + /-- The matching stays within the participating flags. -/ + match_mem : ∀ f ∈ F.flags, match_ f ∈ F.flags + /-- Matched flags share an internal vertex. -/ + match_vertex : ∀ f ∈ F.flags, ∀ v : W.Vertex, + W.attach f = Sum.inl v → W.attach (match_ f) = Sum.inl v + /-- Only internally attached flags participate. -/ + attach_internal : ∀ f ∈ F.flags, ∃ v : W.Vertex, + W.attach f = Sum.inl v + +/-- The walk map of a transition system: follow the edge to the +partner flag, then the matching at its vertex. -/ +def TransitionSystem.walk {F : EdgeSubset W} (κ : TransitionSystem F) + (f : W.Flag) : W.Flag := + κ.match_ (W.pairing f) + +/-- The walk map preserves the participating flags. -/ +theorem TransitionSystem.walk_mem {F : EdgeSubset W} + (κ : TransitionSystem F) {f : W.Flag} (hf : f ∈ F.flags) : + κ.walk f ∈ F.flags := + κ.match_mem _ (F.pairing_mem f hf) + +/-- The walk map is injective on the participating flags. -/ +theorem TransitionSystem.walk_injOn {F : EdgeSubset W} + (κ : TransitionSystem F) {f g : W.Flag} (hf : f ∈ F.flags) + (hg : g ∈ F.flags) (h : κ.walk f = κ.walk g) : f = g := by + have hpf : W.pairing f ∈ F.flags := F.pairing_mem f hf + have hpg : W.pairing g ∈ F.flags := F.pairing_mem g hg + have hm : W.pairing f = W.pairing g := by + have h1 := κ.match_invol _ hpf + have h2 := κ.match_invol _ hpg + have h' : κ.match_ (W.pairing f) = κ.match_ (W.pairing g) := h + calc W.pairing f = κ.match_ (κ.match_ (W.pairing f)) := h1.symm + _ = κ.match_ (κ.match_ (W.pairing g)) := by rw [h'] + _ = W.pairing g := h2 + calc f = W.pairing (W.pairing f) := (W.pairing_invol f).symm + _ = W.pairing (W.pairing g) := by rw [hm] + _ = g := W.pairing_invol g + +/-- The walk permutation of a transition system: the walk map as a +permutation of the participating flags. -/ +noncomputable def TransitionSystem.walkPerm {F : EdgeSubset W} + (κ : TransitionSystem F) : Equiv.Perm {f : W.Flag // f ∈ F.flags} := + Equiv.ofBijective + (fun f => ⟨κ.walk f.val, κ.walk_mem f.prop⟩) + (Finite.injective_iff_bijective.mp + (fun f g h => Subtype.ext + (κ.walk_injOn f.prop g.prop (congrArg Subtype.val h)))) + +/-- The circuit count of a transition system: each geometric circuit +of `n` edges carries two walk-cycles of length `n` when `n ≥ 2` and +two walk fixed points when `n = 1`, so the count is half the total +number of orbits. -/ +noncomputable def TransitionSystem.circuitCount {F : EdgeSubset W} + (κ : TransitionSystem F) : ℕ := + (κ.walkPerm.cycleType.card + + Fintype.card (Function.fixedPoints κ.walkPerm)) / 2 + +end EdgeSubset + +/-! ## 7. The mixed partition function (Definition 5) + +A `(k, 2ℓ)` mixed vertex functional assigns a value to a multiset of even +colours and a *set* of odd colours; the alternating evaluation on an ordered +odd list is recovered through the sorting sign, so antisymmetry is a theorem +of the evaluator rather than a condition on the data. The summand of an +Eulerian subset is its circuit sign times the colouring sum of vertex values, +odd colours contributing through the symplectic pairing (`oddPartner`, +`oddPartnerSign`); the value of the subset is choice-free because the tree +proves it independent of the transition data, and `mixedPartition` is the +free-circle factor `(k − 2ℓ)^circles` times the sum over Eulerian subsets. -/ + +/-- The data of a `(k, 2ℓ)` mixed vertex functional: a value for +each multiset of even colours and set of odd colours. -/ +def MixedFunctional (k ℓ : ℕ) : Type := + Multiset (Fin k) → Finset (Fin (2 * ℓ)) → ℂ + +/-- The alternating evaluation of a mixed functional on an ordered +list of odd colours: zero on repetitions, otherwise the sorting +sign times the value on the underlying set. -/ +def MixedFunctional.evalOdd {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (μ : Multiset (Fin k)) (w : List (Fin (2 * ℓ))) : ℂ := + if w.Nodup then (sortSign w : ℂ) * h μ w.toFinset else 0 + +/-- The odd-colour index pairing of the standard symplectic basis: +the partner of colour `c` is `c + ℓ` when `c < ℓ` and `c − ℓ` +otherwise. -/ +def oddPartner (ℓ : ℕ) (c : Fin (2 * ℓ)) : Fin (2 * ℓ) := + if h : c.val < ℓ then ⟨c.val + ℓ, by omega⟩ + else ⟨c.val - ℓ, by omega⟩ + +/-- The sign of the odd-colour pairing: `g_c = −f_{c+ℓ}` for +`c < ℓ` and `g_c = f_{c−ℓ}` otherwise. -/ +def oddPartnerSign (ℓ : ℕ) (c : Fin (2 * ℓ)) : ℤ := + if c.val < ℓ then -1 else 1 + +/-- An orientation compatible with a transition system: an in/out +designation of the participating flags, flipped both by the vertex +matching and by the edge pairing (so circuits are traversed +consistently). -/ +structure EdgeSubset.TransitionSystem.Orientation {α : Type} + {W : Fragment α} {F : EdgeSubset W} (κ : F.TransitionSystem) where + /-- Whether a flag is an outgoing end. -/ + isOut : W.Flag → Bool + /-- The vertex matching pairs incoming with outgoing flags. -/ + match_flip : ∀ f ∈ F.flags, isOut (κ.match_ f) = !isOut f + /-- Each edge has one outgoing and one incoming end. -/ + pairing_flip : ∀ f ∈ F.flags, isOut (W.pairing f) = !isOut f + +-- Deliberately semireducible: the order is an enumeration artefact, +-- only ever supplied explicitly via `letI`, never by instance search. +/-- An arbitrary but fixed linear order on the flags of a fragment, +transported from an enumeration. Used only to enumerate vertex +pairings; the evaluated summands are independent of the choice +because pair blocks move by even permutations. -/ +@[instance_reducible] +noncomputable def Fragment.flagOrder {α : Type} (W : Fragment α) : + LinearOrder W.Flag := + LinearOrder.lift' (Fintype.equivFin W.Flag) + (Fintype.equivFin W.Flag).injective + +/-- The incoming participating flags at a vertex, in the fixed flag +order. -/ +noncomputable def EdgeSubset.inFlagsAt {α : Type} {W : Fragment α} + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) (v : W.Vertex) : List W.Flag := + letI := W.flagOrder + letI := Classical.dec + (F.flags.filter + (fun f => W.attach f = Sum.inl v ∧ o.isOut f = false)).sort (· ≤ ·) + +section Summand + +variable {α : Type} {W : Fragment α} + +/-- The complement of an edge subset is closed under the pairing. -/ +theorem EdgeSubset.pairing_not_mem (F : EdgeSubset W) {f : W.Flag} + (hf : f ∉ F.flags) : W.pairing f ∉ F.flags := fun hmem => by + have := F.pairing_mem _ hmem + rw [W.pairing_invol] at this + exact hf this + +/-- Even colourings of the non-participating edges: pairing-constant +colours on the flags outside the subset. -/ +def EdgeSubset.EvenColouring (F : EdgeSubset W) (k : ℕ) : Type := + {ψ : {f : W.Flag // f ∉ F.flags} → Fin k // + ∀ f : {f : W.Flag // f ∉ F.flags}, + ψ ⟨W.pairing f.val, F.pairing_not_mem f.prop⟩ = ψ f} + +/-- Odd colourings of the participating edges: pairing-constant +colours on the flags of the subset. -/ +def EdgeSubset.OddColouring (F : EdgeSubset W) (ℓ : ℕ) : Type := + {φ : {f : W.Flag // f ∈ F.flags} → Fin (2 * ℓ) // + ∀ f : {f : W.Flag // f ∈ F.flags}, + φ ⟨W.pairing f.val, F.pairing_mem _ f.prop⟩ = φ f} + +open Classical in +/-- Even colourings are finite in number. -/ +noncomputable instance EdgeSubset.EvenColouring.instFintype + (F : EdgeSubset W) (k : ℕ) : Fintype (F.EvenColouring k) := by + unfold EdgeSubset.EvenColouring + infer_instance + +open Classical in +/-- And so are odd ones, so Definition 5's sum is finite. -/ +noncomputable instance EdgeSubset.OddColouring.instFintype + (F : EdgeSubset W) (ℓ : ℕ) : Fintype (F.OddColouring ℓ) := by + unfold EdgeSubset.OddColouring + infer_instance + +open Classical in +/-- The even-colour multiset at a vertex: the colours of the +non-participating flags attached to it. -/ +noncomputable def EdgeSubset.evenColoursAt (F : EdgeSubset W) {k : ℕ} + (ψ : F.EvenColouring k) (v : W.Vertex) : Multiset (Fin k) := + ((Finset.univ.filter + (fun f : {f : W.Flag // f ∉ F.flags} => + W.attach f.val = Sum.inl v)).val).map ψ.val + +/-- Every in-flag at a vertex participates in the edge subset. -/ +theorem EdgeSubset.mem_of_mem_inFlagsAt {F : EdgeSubset W} + {κ : F.TransitionSystem} {o : κ.Orientation} {v : W.Vertex} + {f : W.Flag} (hf : f ∈ F.inFlagsAt o v) : f ∈ F.flags := by + let := W.flagOrder + let := Classical.dec + unfold EdgeSubset.inFlagsAt at hf + exact (Finset.mem_filter.mp ((Finset.mem_sort _).mp hf)).1 + +open Classical in +/-- The odd pair contributed by an incoming participating flag: its +edge colour followed by the partner index of its matched outgoing +flag's edge colour. -/ +noncomputable def EdgeSubset.oddPairFn (F : EdgeSubset W) {ℓ : ℕ} + (κ : F.TransitionSystem) (φ : F.OddColouring ℓ) + (f : {f : W.Flag // f ∈ F.flags}) : List (Fin (2 * ℓ)) := + [φ.val f, oddPartner ℓ (φ.val ⟨κ.match_ f.val, κ.match_mem _ f.prop⟩)] + +open Classical in +/-- The odd-pairing sign contributed by an incoming participating +flag: the partner sign of its matched outgoing flag's colour. -/ +noncomputable def EdgeSubset.oddSignFn (F : EdgeSubset W) {ℓ : ℕ} + (κ : F.TransitionSystem) (φ : F.OddColouring ℓ) + (f : {f : W.Flag // f ∈ F.flags}) : ℤ := + oddPartnerSign ℓ (φ.val ⟨κ.match_ f.val, κ.match_mem _ f.prop⟩) + +open Classical in +/-- The odd-colour list at a vertex: the odd pairs of the incoming +flags in the fixed order. -/ +noncomputable def EdgeSubset.oddListAt (F : EdgeSubset W) {ℓ : ℕ} + {κ : F.TransitionSystem} (o : κ.Orientation) + (φ : F.OddColouring ℓ) (v : W.Vertex) : List (Fin (2 * ℓ)) := + ((F.inFlagsAt o v).attachWith (· ∈ F.flags) + (fun _ hf => F.mem_of_mem_inFlagsAt hf)).flatMap (F.oddPairFn κ φ) + +open Classical in +/-- The odd-pairing sign at a vertex: the product of the partner +signs of the outgoing colours. -/ +noncomputable def EdgeSubset.oddSignAt (F : EdgeSubset W) {ℓ : ℕ} + {κ : F.TransitionSystem} (o : κ.Orientation) + (φ : F.OddColouring ℓ) (v : W.Vertex) : ℤ := + (((F.inFlagsAt o v).attachWith (· ∈ F.flags) + (fun _ hf => F.mem_of_mem_inFlagsAt hf)).map (F.oddSignFn κ φ)).prod + +open Classical in +/-- The Definition 5 summand of an Eulerian edge subset with chosen +transition system and orientation: the circuit sign times the +colouring sum of the vertex values. -/ +noncomputable def EdgeSubset.mixedSummand (F : EdgeSubset W) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + {κ : F.TransitionSystem} (o : κ.Orientation) : ℂ := + ((-1 : ℂ) ^ κ.circuitCount) * + ∑ ψ : F.EvenColouring k, ∑ φ : F.OddColouring ℓ, + ∏ v : W.Vertex, + ((F.oddSignAt o φ v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) (F.oddListAt o φ v)) + +open Classical in +/-- The Definition 5 value of an edge subset: the summand for a +choice of transition system and orientation, zero when none +exists. (Every Eulerian subset admits one; the value is +independent of the choice by the Eulerian-independence input.) -/ +noncomputable def EdgeSubset.mixedValue (F : EdgeSubset W) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) : ℂ := + if hne : Nonempty ((κ : F.TransitionSystem) × κ.Orientation) then + F.mixedSummand h (Classical.choice hne).2 + else 0 + +end Summand + +open Classical in +/-- **The mixed partition function** (Regts–Sevenster Definition 5) +of a fragment: the free-circle factor times the sum over Eulerian +edge subsets of their circuit-signed colouring sums. -/ +noncomputable def mixedPartition {α : Type} {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (W : Fragment α) : ℂ := + ((k : ℂ) - 2 * ℓ) ^ W.circles * + ∑ s : Finset W.Flag, + if hc : ∀ f ∈ s, W.pairing f ∈ s then + if (EdgeSubset.mk s hc).Eulerian then + (EdgeSubset.mk s hc).mixedValue h + else 0 + else 0 + +/-- A parameter on closed fragments is a mixed partition function +when it is the Definition 5 value of some mixed functional. -/ +def IsMixedPartitionFunction (f : ClosedFragment → ℂ) : Prop := + ∃ (k ℓ : ℕ) (h : MixedFunctional k ℓ), + ∀ W : ClosedFragment, f W = mixedPartition h W + +/-! ## 8. The named statements + +The forward direction, the separate parity bound `⌊2eR⌋`, the sharp total +colour bound `R`, and the converse with its explicit base. -/ + +/-- **THE REGTS–SEVENSTER CONJECTURE.** Every graph parameter with +exponentially bounded edge-connection rank is a mixed partition +function. -/ +def RegtsSevensterStatement : Prop := + ∀ (R : ℕ) (f : EdgeRankParameter R), IsMixedPartitionFunction f.val + +/-- A mixed partition function with explicit dimension bounds: the +functional's even dimension `k` and odd dimension `2ℓ` are both at +most `B`. -/ +def IsMixedPartitionFunctionBounded (f : ClosedFragment → ℂ) + (B : ℕ) : Prop := + ∃ (k ℓ : ℕ) (h : MixedFunctional k ℓ), + k ≤ B ∧ 2 * ℓ ≤ B ∧ + ∀ W : ClosedFragment, f W = mixedPartition h W + +/-- **THE QUANTITATIVE REGTS–SEVENSTER STATEMENT**: every graph +parameter with edge-connection rank at most `R ^ t` is a mixed +partition function of a `(k, 2ℓ)`-functional with +`k, 2ℓ ≤ ⌊2eR⌋`. -/ +def RegtsSevensterStatementQuant : Prop := + ∀ (R : ℕ) (f : EdgeRankParameter R), + IsMixedPartitionFunctionBounded f.val + ⌊2 * Real.exp 1 * (R : ℝ)⌋₊ + +/-- A mixed model with a bound on the sum of its even and odd +dimensions. The named fields retain the functional and its agreement +with the graph parameter as part of the witness. -/ +structure TotalBoundedMixedModel (f : ClosedFragment → ℂ) (B : ℕ) where + /-- The number of even colours. -/ + k : ℕ + /-- Half the number of odd colours. -/ + ℓ : ℕ + /-- The vertex functional of the model. -/ + functional : MixedFunctional k ℓ + /-- The total number of colours is bounded by `B`. -/ + dimension_le : k + 2 * ℓ ≤ B + /-- The model evaluates to the given parameter on every fragment. -/ + partition_eq : ∀ W : ClosedFragment, f W = mixedPartition functional W + +/-- A parameter admits a mixed model with at most `B` colours in +total, counting both the even and odd components. -/ +def IsMixedPartitionFunctionTotalBounded (f : ClosedFragment → ℂ) + (B : ℕ) : Prop := + Nonempty (TotalBoundedMixedModel f B) + +/-- The total-dimension Regts–Sevenster statement: an edge-rank base +`R` bounds the total number of colours of a representing mixed model. -/ +def RegtsSevensterStatementTotal : Prop := + ∀ (R : ℕ) (f : EdgeRankParameter R), + IsMixedPartitionFunctionTotalBounded f.val R + +/-- **THE CONVERSE STATEMENT**: every mixed partition function is +an edge-rank-bounded parameter with base `max 1 (k + 2ℓ)` +(Regts–Sevenster, arXiv:1807.04494, Theorem 6). -/ +def RegtsSevensterConverseStatement : Prop := + ∀ (k ℓ : ℕ) (h : MixedFunctional k ℓ), + ∃ g : EdgeRankParameter (max 1 (k + 2 * ℓ)), + ∀ W : ClosedFragment, g.val W = mixedPartition h W + +/-! ## 9. The symmetric monoidal category of super vector spaces + +The codomain of the fibre functor in Deligne's conclusion: finite-dimensional +ℤ/2-graded complex vector spaces with grading-preserving maps, the graded +tensor product, and the braiding that carries the *Koszul sign* — the odd⊗odd +block acquires a factor of −1 under the swap (`koszulEvenAux`, second +component). This is the longest section; its content is one structure, its +category structure, and the monoidal, braided, symmetric, additive and +ℂ-linear instances, together with the computation lemmas their coherence +proofs run on. An auditor checking what Deligne's theorem *says* should read +the objects, `tensorObj`, `tensorUnit` and the two Koszul blocks; the rest is +coherence. -/ + +noncomputable section + +open CategoryTheory +open scoped TensorProduct + +/-- A *super vector space* over ℂ: a pair of finite-dimensional +complex vector spaces, called the *even* and *odd* components. -/ +structure SuperVect where + /-- The even-graded component. -/ + even : Type + /-- The odd-graded component. -/ + odd : Type + [evenAddCommGroup : AddCommGroup even] + [evenModule : Module ℂ even] + [oddAddCommGroup : AddCommGroup odd] + [oddModule : Module ℂ odd] + [evenFinite : FiniteDimensional ℂ even] + [oddFinite : FiniteDimensional ℂ odd] + +attribute [instance] SuperVect.evenAddCommGroup SuperVect.evenModule + SuperVect.oddAddCommGroup SuperVect.oddModule + SuperVect.evenFinite SuperVect.oddFinite + +namespace SuperVect + +/-- A morphism of super vector spaces: a pair of ℂ-linear maps +preserving the grading. -/ +@[ext] +structure Hom (V W : SuperVect) where + /-- The even component of the morphism. -/ + evenMap : V.even →ₗ[ℂ] W.even + /-- The odd component of the morphism. -/ + oddMap : V.odd →ₗ[ℂ] W.odd + +/-- The identity morphism on a super vector space. -/ +@[simp] +def Hom.id (V : SuperVect) : Hom V V where + evenMap := LinearMap.id + oddMap := LinearMap.id + +/-- Composition of super-vector-space morphisms. -/ +@[simp] +def Hom.comp {V W X : SuperVect} (g : Hom W X) (f : Hom V W) : Hom V X where + evenMap := g.evenMap.comp f.evenMap + oddMap := g.oddMap.comp f.oddMap + +/-- Super vector spaces and grading-preserving maps form a +category. -/ +instance instCategoryStruct : CategoryStruct SuperVect where + Hom := Hom + id := Hom.id + comp f g := Hom.comp g f + +/-- Two morphisms agreeing in both components are equal. -/ +@[ext] +theorem hom_ext {V W : SuperVect} {f g : V ⟶ W} + (he : (f : Hom V W).evenMap = (g : Hom V W).evenMap) + (ho : (f : Hom V W).oddMap = (g : Hom V W).oddMap) : f = g := + Hom.ext he ho + +/-- SuperVect forms a category with grading-preserving linear maps. -/ +instance instCategory : Category SuperVect where + id_comp _ := by ext <;> simp [CategoryStruct.comp, CategoryStruct.id] + comp_id _ := by ext <;> simp [CategoryStruct.comp, CategoryStruct.id] + assoc _ _ _ := by ext <;> simp [CategoryStruct.comp] + +/-! ### Tensor product -/ + +/-- The graded tensor product of two super vector spaces. The even +component is `(V.even ⊗ W.even) × (V.odd ⊗ W.odd)` and the odd +component is `(V.even ⊗ W.odd) × (V.odd ⊗ W.even)`. -/ +def tensorObj (V W : SuperVect) : SuperVect where + even := (V.even ⊗[ℂ] W.even) × (V.odd ⊗[ℂ] W.odd) + odd := (V.even ⊗[ℂ] W.odd) × (V.odd ⊗[ℂ] W.even) + +/-- The tensor product of two grading-preserving maps acts +component-wise on each tensor block. -/ +def tensorHom {V₁ V₂ W₁ W₂ : SuperVect} + (f : Hom V₁ V₂) (g : Hom W₁ W₂) : + Hom (tensorObj V₁ W₁) (tensorObj V₂ W₂) := by + refine ⟨?_, ?_⟩ + · change (V₁.even ⊗[ℂ] W₁.even) × (V₁.odd ⊗[ℂ] W₁.odd) →ₗ[ℂ] + (V₂.even ⊗[ℂ] W₂.even) × (V₂.odd ⊗[ℂ] W₂.odd) + exact LinearMap.prodMap + (TensorProduct.map f.evenMap g.evenMap) + (TensorProduct.map f.oddMap g.oddMap) + · change (V₁.even ⊗[ℂ] W₁.odd) × (V₁.odd ⊗[ℂ] W₁.even) →ₗ[ℂ] + (V₂.even ⊗[ℂ] W₂.odd) × (V₂.odd ⊗[ℂ] W₂.even) + exact LinearMap.prodMap + (TensorProduct.map f.evenMap g.oddMap) + (TensorProduct.map f.oddMap g.evenMap) + +/-- The monoidal unit: ℂ in even degree, the zero module in odd +degree. Marked reducible so that `tensorUnit.odd` reduces to `PUnit` +during type-class synthesis. -/ +@[reducible] +def tensorUnit : SuperVect where + even := ℂ + odd := PUnit + +/-! ### The Koszul braiding -/ + +/-- Module-level even Koszul block: `TensorProduct.comm` on the +first factor and *minus* `TensorProduct.comm` on the second. +Stated over bare modules so that instances of it at compound +objects have syntactically reduced types. -/ +def koszulEvenAux (A B C D : Type*) + [AddCommGroup A] [Module ℂ A] [AddCommGroup B] [Module ℂ B] + [AddCommGroup C] [Module ℂ C] [AddCommGroup D] [Module ℂ D] : + ((A ⊗[ℂ] B) × (C ⊗[ℂ] D)) →ₗ[ℂ] ((B ⊗[ℂ] A) × (D ⊗[ℂ] C)) := + LinearMap.prodMap + (TensorProduct.comm ℂ A B).toLinearMap + (-(TensorProduct.comm ℂ C D).toLinearMap) + +/-- Module-level odd Koszul block: swaps the two summands and +applies `TensorProduct.comm` on each (no sign). -/ +def koszulOddAux (A B C D : Type*) + [AddCommGroup A] [Module ℂ A] [AddCommGroup B] [Module ℂ B] + [AddCommGroup C] [Module ℂ C] [AddCommGroup D] [Module ℂ D] : + ((A ⊗[ℂ] B) × (C ⊗[ℂ] D)) →ₗ[ℂ] ((D ⊗[ℂ] C) × (B ⊗[ℂ] A)) := + LinearMap.prod + ((TensorProduct.comm ℂ C D).toLinearMap.comp (LinearMap.snd ℂ _ _)) + ((TensorProduct.comm ℂ A B).toLinearMap.comp (LinearMap.fst ℂ _ _)) + +/-- The even component of the Koszul braiding: applies +`TensorProduct.comm` on the even⊗even block and +*minus* `TensorProduct.comm` on the odd⊗odd block. -/ +def koszulBraidingEven (V W : SuperVect) : + (V.even ⊗[ℂ] W.even) × (V.odd ⊗[ℂ] W.odd) →ₗ[ℂ] + (W.even ⊗[ℂ] V.even) × (W.odd ⊗[ℂ] V.odd) := + koszulEvenAux V.even W.even V.odd W.odd + +/-- The odd component of the Koszul braiding: swaps the two +blocks and applies `TensorProduct.comm` on each (no sign, +since even⊗odd and odd⊗even contribute (−1)^(0·1) = 1). -/ +def koszulBraidingOdd (V W : SuperVect) : + (V.even ⊗[ℂ] W.odd) × (V.odd ⊗[ℂ] W.even) →ₗ[ℂ] + (W.even ⊗[ℂ] V.odd) × (W.odd ⊗[ℂ] V.even) := + koszulOddAux V.even W.odd V.odd W.even + +/-- The Koszul braiding morphism `V ⊗ W → W ⊗ V` in SuperVect, +carrying the sign (−1)^(p·q) on the swap of homogeneous elements +of parity p and q. -/ +def koszulBraiding (V W : SuperVect) : + Hom (tensorObj V W) (tensorObj W V) := by + refine ⟨?_, ?_⟩ + · change (V.even ⊗[ℂ] W.even) × (V.odd ⊗[ℂ] W.odd) →ₗ[ℂ] + (W.even ⊗[ℂ] V.even) × (W.odd ⊗[ℂ] V.odd) + exact koszulBraidingEven V W + · change (V.even ⊗[ℂ] W.odd) × (V.odd ⊗[ℂ] W.even) →ₗ[ℂ] + (W.even ⊗[ℂ] V.odd) × (W.odd ⊗[ℂ] V.even) + exact koszulBraidingOdd V W + +/-- The Koszul braiding is a self-inverse: the two applications of +the sign on the odd⊗odd block cancel, and the component swaps on +the odd part compose to the identity. -/ +theorem koszulBraiding_self_inverse (V W : SuperVect) : + Hom.comp (koszulBraiding W V) (koszulBraiding V W) = Hom.id (tensorObj V W) + := by + apply Hom.ext + · -- Even component: comm ∘ comm = id, (-comm) ∘ (-comm) = comm ∘ comm = id + change (koszulBraidingEven W V).comp (koszulBraidingEven V W) = LinearMap.id + apply LinearMap.ext; intro ⟨x, y⟩ + simp only [koszulBraidingEven, koszulEvenAux, LinearMap.comp_apply, + LinearMap.prodMap_apply, + LinearMap.neg_apply, LinearMap.id_apply, map_neg, neg_neg, + LinearEquiv.coe_toLinearMap, TensorProduct.comm_comm] + · -- Odd component: swap ∘ swap = id, comm ∘ comm = id + change (koszulBraidingOdd W V).comp (koszulBraidingOdd V W) = LinearMap.id + apply LinearMap.ext; intro ⟨x, y⟩ + simp only [koszulBraidingOdd, koszulOddAux, LinearMap.comp_apply, + LinearMap.prod_apply, + LinearMap.snd_apply, LinearMap.fst_apply, LinearMap.id_apply, + Function.prod, + LinearEquiv.coe_toLinearMap, TensorProduct.comm_comm] + +/-- Application of the Koszul odd braiding to a pair of elements. -/ +@[simp] +theorem koszulBraidingOdd_pair (V W : SuperVect) + (x : V.even ⊗[ℂ] W.odd) (y : V.odd ⊗[ℂ] W.even) : + koszulBraidingOdd V W ⟨x, y⟩ = + ⟨(TensorProduct.comm ℂ V.odd W.even) y, + (TensorProduct.comm ℂ V.even W.odd) x⟩ := rfl + +/-! ### Koszul braiding as a categorical isomorphism -/ + +/-- The Koszul braiding as an isomorphism in SuperVect. -/ +def koszulBraidingIso (V W : SuperVect) : + tensorObj V W ≅ tensorObj W V where + hom := koszulBraiding V W + inv := koszulBraiding W V + hom_inv_id := koszulBraiding_self_inverse V W + inv_hom_id := koszulBraiding_self_inverse W V + +/-! ### Left and right unitors -/ + +/-- The left unitor isomorphism `𝟙_ ⊗ V ≅ V`. -/ +def leftUnitor (V : SuperVect) : + tensorObj tensorUnit V ≅ V where + hom := by + refine ⟨?_, ?_⟩ + · change (ℂ ⊗[ℂ] V.even) × (PUnit ⊗[ℂ] V.odd) →ₗ[ℂ] V.even + exact (TensorProduct.lid ℂ V.even).toLinearMap.comp (LinearMap.fst ℂ _ _) + · change (ℂ ⊗[ℂ] V.odd) × (PUnit ⊗[ℂ] V.even) →ₗ[ℂ] V.odd + exact (TensorProduct.lid ℂ V.odd).toLinearMap.comp (LinearMap.fst ℂ _ _) + inv := by + refine ⟨?_, ?_⟩ + · change V.even →ₗ[ℂ] (ℂ ⊗[ℂ] V.even) × (PUnit ⊗[ℂ] V.odd) + exact LinearMap.inl ℂ _ _ ∘ₗ (TensorProduct.lid ℂ V.even).symm.toLinearMap + · change V.odd →ₗ[ℂ] (ℂ ⊗[ℂ] V.odd) × (PUnit ⊗[ℂ] V.even) + exact LinearMap.inl ℂ _ _ ∘ₗ (TensorProduct.lid ℂ V.odd).symm.toLinearMap + hom_inv_id := by + apply Hom.ext + · change ((LinearMap.inl ℂ _ _ ∘ₗ (TensorProduct.lid ℂ + V.even).symm.toLinearMap).comp + ((TensorProduct.lid ℂ V.even).toLinearMap.comp (LinearMap.fst ℂ _ _))) = + LinearMap.id + apply LinearMap.ext; intro ⟨x, y⟩ + simp [Subsingleton.elim y 0] + · change ((LinearMap.inl ℂ _ _ ∘ₗ (TensorProduct.lid ℂ + V.odd).symm.toLinearMap).comp + ((TensorProduct.lid ℂ V.odd).toLinearMap.comp (LinearMap.fst ℂ _ _))) = + LinearMap.id + apply LinearMap.ext; intro ⟨x, y⟩ + simp [Subsingleton.elim y 0] + inv_hom_id := by + apply Hom.ext + · change ((TensorProduct.lid ℂ V.even).toLinearMap.comp (LinearMap.fst ℂ _ + _)).comp + (LinearMap.inl ℂ _ _ ∘ₗ (TensorProduct.lid ℂ V.even).symm.toLinearMap) = + LinearMap.id + apply LinearMap.ext; intro x; simp + · change ((TensorProduct.lid ℂ V.odd).toLinearMap.comp (LinearMap.fst ℂ _ + _)).comp + (LinearMap.inl ℂ _ _ ∘ₗ (TensorProduct.lid ℂ V.odd).symm.toLinearMap) = + LinearMap.id + apply LinearMap.ext; intro x; simp + +/-- The right unitor isomorphism `V ⊗ 𝟙_ ≅ V`. -/ +def rightUnitor (V : SuperVect) : + tensorObj V tensorUnit ≅ V where + hom := by + refine ⟨?_, ?_⟩ + · change (V.even ⊗[ℂ] ℂ) × (V.odd ⊗[ℂ] PUnit) →ₗ[ℂ] V.even + exact (TensorProduct.rid ℂ V.even).toLinearMap.comp (LinearMap.fst ℂ _ _) + · change (V.even ⊗[ℂ] PUnit) × (V.odd ⊗[ℂ] ℂ) →ₗ[ℂ] V.odd + exact (TensorProduct.rid ℂ V.odd).toLinearMap.comp (LinearMap.snd ℂ _ _) + inv := by + refine ⟨?_, ?_⟩ + · change V.even →ₗ[ℂ] (V.even ⊗[ℂ] ℂ) × (V.odd ⊗[ℂ] PUnit) + exact LinearMap.inl ℂ _ _ ∘ₗ (TensorProduct.rid ℂ V.even).symm.toLinearMap + · change V.odd →ₗ[ℂ] (V.even ⊗[ℂ] PUnit) × (V.odd ⊗[ℂ] ℂ) + exact LinearMap.inr ℂ _ _ ∘ₗ (TensorProduct.rid ℂ V.odd).symm.toLinearMap + hom_inv_id := by + apply Hom.ext + · change ((LinearMap.inl ℂ _ _ ∘ₗ (TensorProduct.rid ℂ + V.even).symm.toLinearMap).comp + ((TensorProduct.rid ℂ V.even).toLinearMap.comp (LinearMap.fst ℂ _ _))) = + LinearMap.id + apply LinearMap.ext; intro ⟨x, y⟩ + simp [Subsingleton.elim y 0] + · change ((LinearMap.inr ℂ _ _ ∘ₗ (TensorProduct.rid ℂ + V.odd).symm.toLinearMap).comp + ((TensorProduct.rid ℂ V.odd).toLinearMap.comp (LinearMap.snd ℂ _ _))) = + LinearMap.id + apply LinearMap.ext; intro ⟨x, y⟩ + simp [Subsingleton.elim x 0] + inv_hom_id := by + apply Hom.ext + · change ((TensorProduct.rid ℂ V.even).toLinearMap.comp (LinearMap.fst ℂ _ + _)).comp + (LinearMap.inl ℂ _ _ ∘ₗ (TensorProduct.rid ℂ V.even).symm.toLinearMap) = + LinearMap.id + apply LinearMap.ext; intro x; simp + · change ((TensorProduct.rid ℂ V.odd).toLinearMap.comp (LinearMap.snd ℂ _ + _)).comp + (LinearMap.inr ℂ _ _ ∘ₗ (TensorProduct.rid ℂ V.odd).symm.toLinearMap) = + LinearMap.id + apply LinearMap.ext; intro x; simp + +/-! ### Associator -/ + +/-- Permutation of product components used in the associator: +`((A × B) × (C × D)) ≃ₗ ((A × C) × (D × B))`. The mapping is +`(a, b, c, d) ↦ (a, c, d, b)`. All field proofs hold by `rfl` +because the permutation is a definitional reshuffling of product +components. -/ +def prod4Perm (A B C D : Type*) + [AddCommGroup A] [Module ℂ A] [AddCommGroup B] [Module ℂ B] + [AddCommGroup C] [Module ℂ C] [AddCommGroup D] [Module ℂ D] : + ((A × B) × (C × D)) ≃ₗ[ℂ] ((A × C) × (D × B)) := + { toFun := fun ⟨⟨a, b⟩, ⟨c, d⟩⟩ => ⟨⟨a, c⟩, ⟨d, b⟩⟩ + map_add' := fun ⟨⟨_, _⟩, ⟨_, _⟩⟩ ⟨⟨_, _⟩, ⟨_, _⟩⟩ => rfl + map_smul' := fun _ ⟨⟨_, _⟩, ⟨_, _⟩⟩ => rfl + invFun := fun ⟨⟨a, c⟩, ⟨d, b⟩⟩ => ⟨⟨a, b⟩, ⟨c, d⟩⟩ + left_inv := fun ⟨⟨_, _⟩, ⟨_, _⟩⟩ => rfl + right_inv := fun ⟨⟨_, _⟩, ⟨_, _⟩⟩ => rfl } + +/-- Module-level associator block. The construction distributes +the tensor over products (via `prodLeft` and `prodRight`), +reassociates each tensor block (via `TensorProduct.assoc`), and +permutes the four summands via `prod4Perm`. Stated over bare +modules so that instances of it at compound objects have +syntactically reduced types; the even and odd components of the +SuperVect associator are its instantiations with the two `C`-slots +in the two orders. -/ +def assocAux (A₁ A₂ B₁ B₂ C₁ C₂ : Type*) + [AddCommGroup A₁] [Module ℂ A₁] [AddCommGroup A₂] [Module ℂ A₂] + [AddCommGroup B₁] [Module ℂ B₁] [AddCommGroup B₂] [Module ℂ B₂] + [AddCommGroup C₁] [Module ℂ C₁] [AddCommGroup C₂] [Module ℂ C₂] : + ((((A₁ ⊗[ℂ] B₁) × (A₂ ⊗[ℂ] B₂)) ⊗[ℂ] C₁) × + (((A₁ ⊗[ℂ] B₂) × (A₂ ⊗[ℂ] B₁)) ⊗[ℂ] C₂)) ≃ₗ[ℂ] + ((A₁ ⊗[ℂ] ((B₁ ⊗[ℂ] C₁) × (B₂ ⊗[ℂ] C₂))) × + (A₂ ⊗[ℂ] ((B₁ ⊗[ℂ] C₂) × (B₂ ⊗[ℂ] C₁)))) := + let s1 := LinearEquiv.prodCongr + (TensorProduct.prodLeft ℂ ℂ (A₁ ⊗[ℂ] B₁) (A₂ ⊗[ℂ] B₂) C₁) + (TensorProduct.prodLeft ℂ ℂ (A₁ ⊗[ℂ] B₂) (A₂ ⊗[ℂ] B₁) C₂) + let s2 := prod4Perm + ((A₁ ⊗[ℂ] B₁) ⊗[ℂ] C₁) ((A₂ ⊗[ℂ] B₂) ⊗[ℂ] C₁) + ((A₁ ⊗[ℂ] B₂) ⊗[ℂ] C₂) ((A₂ ⊗[ℂ] B₁) ⊗[ℂ] C₂) + let s3 := LinearEquiv.prodCongr + (LinearEquiv.prodCongr (TensorProduct.assoc ℂ A₁ B₁ C₁) + (TensorProduct.assoc ℂ A₁ B₂ C₂)) + (LinearEquiv.prodCongr (TensorProduct.assoc ℂ A₂ B₁ C₂) + (TensorProduct.assoc ℂ A₂ B₂ C₁)) + let s4 := LinearEquiv.prodCongr + (LinearEquiv.symm (TensorProduct.prodRight ℂ ℂ A₁ + (B₁ ⊗[ℂ] C₁) (B₂ ⊗[ℂ] C₂))) + (LinearEquiv.symm (TensorProduct.prodRight ℂ ℂ A₂ + (B₁ ⊗[ℂ] C₂) (B₂ ⊗[ℂ] C₁))) + s1 ≪≫ₗ s2 ≪≫ₗ s3 ≪≫ₗ s4 + +/-- The even component of the associator equivalence. -/ +def assocEvenEquiv (V W X : SuperVect) : + ((((V.even ⊗[ℂ] W.even) × (V.odd ⊗[ℂ] W.odd)) ⊗[ℂ] X.even) × + (((V.even ⊗[ℂ] W.odd) × (V.odd ⊗[ℂ] W.even)) ⊗[ℂ] X.odd)) ≃ₗ[ℂ] + ((V.even ⊗[ℂ] ((W.even ⊗[ℂ] X.even) × (W.odd ⊗[ℂ] X.odd))) × + (V.odd ⊗[ℂ] ((W.even ⊗[ℂ] X.odd) × (W.odd ⊗[ℂ] X.even)))) := + assocAux V.even V.odd W.even W.odd X.even X.odd + +/-- The odd component of the associator equivalence: `assocAux` +with the roles of the two `X`-slots swapped. -/ +def assocOddEquiv (V W X : SuperVect) : + ((((V.even ⊗[ℂ] W.even) × (V.odd ⊗[ℂ] W.odd)) ⊗[ℂ] X.odd) × + (((V.even ⊗[ℂ] W.odd) × (V.odd ⊗[ℂ] W.even)) ⊗[ℂ] X.even)) ≃ₗ[ℂ] + ((V.even ⊗[ℂ] ((W.even ⊗[ℂ] X.odd) × (W.odd ⊗[ℂ] X.even))) × + (V.odd ⊗[ℂ] ((W.even ⊗[ℂ] X.even) × (W.odd ⊗[ℂ] X.odd)))) := + assocAux V.even V.odd W.even W.odd X.odd X.even + +/-- The associator isomorphism `(V ⊗ W) ⊗ X ≅ V ⊗ (W ⊗ X)` in SuperVect. +Distributes tensor over products, reassociates each block, and +permutes the summands back into the canonical grading order. -/ +def associator (V W X : SuperVect) : + tensorObj (tensorObj V W) X ≅ tensorObj V (tensorObj W X) where + hom := by + refine ⟨?_, ?_⟩ + · change (((V.even ⊗[ℂ] W.even) × (V.odd ⊗[ℂ] W.odd)) ⊗[ℂ] X.even) × + (((V.even ⊗[ℂ] W.odd) × (V.odd ⊗[ℂ] W.even)) ⊗[ℂ] X.odd) →ₗ[ℂ] + (V.even ⊗[ℂ] ((W.even ⊗[ℂ] X.even) × (W.odd ⊗[ℂ] X.odd))) × + (V.odd ⊗[ℂ] ((W.even ⊗[ℂ] X.odd) × (W.odd ⊗[ℂ] X.even))) + exact LinearEquiv.toLinearMap (assocEvenEquiv V W X) + · change (((V.even ⊗[ℂ] W.even) × (V.odd ⊗[ℂ] W.odd)) ⊗[ℂ] X.odd) × + (((V.even ⊗[ℂ] W.odd) × (V.odd ⊗[ℂ] W.even)) ⊗[ℂ] X.even) →ₗ[ℂ] + (V.even ⊗[ℂ] ((W.even ⊗[ℂ] X.odd) × (W.odd ⊗[ℂ] X.even))) × + (V.odd ⊗[ℂ] ((W.even ⊗[ℂ] X.even) × (W.odd ⊗[ℂ] X.odd))) + exact LinearEquiv.toLinearMap (assocOddEquiv V W X) + inv := by + refine ⟨?_, ?_⟩ + · change (V.even ⊗[ℂ] ((W.even ⊗[ℂ] X.even) × (W.odd ⊗[ℂ] X.odd))) × + (V.odd ⊗[ℂ] ((W.even ⊗[ℂ] X.odd) × (W.odd ⊗[ℂ] X.even))) →ₗ[ℂ] + (((V.even ⊗[ℂ] W.even) × (V.odd ⊗[ℂ] W.odd)) ⊗[ℂ] X.even) × + (((V.even ⊗[ℂ] W.odd) × (V.odd ⊗[ℂ] W.even)) ⊗[ℂ] X.odd) + exact LinearEquiv.toLinearMap (LinearEquiv.symm (assocEvenEquiv V W X)) + · change (V.even ⊗[ℂ] ((W.even ⊗[ℂ] X.odd) × (W.odd ⊗[ℂ] X.even))) × + (V.odd ⊗[ℂ] ((W.even ⊗[ℂ] X.even) × (W.odd ⊗[ℂ] X.odd))) →ₗ[ℂ] + (((V.even ⊗[ℂ] W.even) × (V.odd ⊗[ℂ] W.odd)) ⊗[ℂ] X.odd) × + (((V.even ⊗[ℂ] W.odd) × (V.odd ⊗[ℂ] W.even)) ⊗[ℂ] X.even) + exact LinearEquiv.toLinearMap (LinearEquiv.symm (assocOddEquiv V W X)) + hom_inv_id := by + apply Hom.ext <;> { + apply LinearMap.ext; intro x + simp only [CategoryStruct.comp, CategoryStruct.id, Hom.comp, Hom.id, + LinearMap.comp_apply, LinearMap.id_apply] + exact LinearEquiv.symm_apply_apply _ x } + inv_hom_id := by + apply Hom.ext <;> { + apply LinearMap.ext; intro x + simp only [CategoryStruct.comp, CategoryStruct.id, Hom.comp, Hom.id, + LinearMap.comp_apply, LinearMap.id_apply] + exact LinearEquiv.apply_symm_apply _ x } + +/-! ### Associator computation lemmas -/ + +/-- The first component of the zero pair. -/ +@[simp] +lemma prod_fst_zero {A B : Type*} [Zero A] [Zero B] : + (0 : A × B).1 = 0 := rfl + +/-- The second component of the zero pair. -/ +@[simp] +lemma prod_snd_zero {A B : Type*} [Zero A] [Zero B] : + (0 : A × B).2 = 0 := rfl + +/-- The pair of zeros is the zero pair. -/ +@[simp] +lemma prod_mk_zero {A B : Type*} [Zero A] [Zero B] : + ((0 : A), (0 : B)) = (0 : A × B) := rfl + +/-- `prod4Perm`, applied. -/ +@[simp] +lemma prod4Perm_apply {A B C D : Type*} + [AddCommGroup A] [Module ℂ A] [AddCommGroup B] [Module ℂ B] + [AddCommGroup C] [Module ℂ C] [AddCommGroup D] [Module ℂ D] + (x : (A × B) × (C × D)) : + prod4Perm A B C D x = ((x.1.1, x.2.1), (x.2.2, x.1.2)) := by + obtain ⟨⟨a, b⟩, ⟨c, d⟩⟩ := x; rfl + +/-- The inverse product-distribution on a first-summand pure +tensor. -/ +lemma prodRight_symm_tmul_fst {M₁ M₂ M₃ : Type*} + [AddCommGroup M₁] [Module ℂ M₁] [AddCommGroup M₂] [Module ℂ M₂] + [AddCommGroup M₃] [Module ℂ M₃] (m₁ : M₁) (m₂ : M₂) : + (TensorProduct.prodRight ℂ ℂ M₁ M₂ M₃).symm (m₁ ⊗ₜ m₂, 0) = + m₁ ⊗ₜ[ℂ] ((m₂, 0) : M₂ × M₃) := by + apply (TensorProduct.prodRight ℂ ℂ M₁ M₂ M₃).injective + simp [TensorProduct.prodRight_tmul] + +/-- The inverse product-distribution on a second-summand pure +tensor. -/ +lemma prodRight_symm_tmul_snd {M₁ M₂ M₃ : Type*} + [AddCommGroup M₁] [Module ℂ M₁] [AddCommGroup M₂] [Module ℂ M₂] + [AddCommGroup M₃] [Module ℂ M₃] (m₁ : M₁) (m₃ : M₃) : + (TensorProduct.prodRight ℂ ℂ M₁ M₂ M₃).symm (0, m₁ ⊗ₜ m₃) = + m₁ ⊗ₜ[ℂ] ((0, m₃) : M₂ × M₃) := by + apply (TensorProduct.prodRight ℂ ℂ M₁ M₂ M₃).injective + simp [TensorProduct.prodRight_tmul] + +-- Computation of `assocAux` on the four pure tensor generators. + +/-- The associator block on a pure tensor of the `A₁ ⊗ B₁` summand +with `C₁`. -/ +@[simp] +lemma assocAux_ee {A₁ A₂ B₁ B₂ C₁ C₂ : Type*} + [AddCommGroup A₁] [Module ℂ A₁] [AddCommGroup A₂] [Module ℂ A₂] + [AddCommGroup B₁] [Module ℂ B₁] [AddCommGroup B₂] [Module ℂ B₂] + [AddCommGroup C₁] [Module ℂ C₁] [AddCommGroup C₂] [Module ℂ C₂] + (a : A₁) (b : B₁) (c : C₁) : + assocAux A₁ A₂ B₁ B₂ C₁ C₂ + (((a ⊗ₜ[ℂ] b, 0) ⊗ₜ[ℂ] c, 0) : + ((((A₁ ⊗[ℂ] B₁) × (A₂ ⊗[ℂ] B₂)) ⊗[ℂ] C₁) × + (((A₁ ⊗[ℂ] B₂) × (A₂ ⊗[ℂ] B₁)) ⊗[ℂ] C₂))) = + ((a ⊗ₜ[ℂ] ((b ⊗ₜ[ℂ] c, 0) : (B₁ ⊗[ℂ] C₁) × (B₂ ⊗[ℂ] C₂)), 0) : + ((A₁ ⊗[ℂ] ((B₁ ⊗[ℂ] C₁) × (B₂ ⊗[ℂ] C₂))) × + (A₂ ⊗[ℂ] ((B₁ ⊗[ℂ] C₂) × (B₂ ⊗[ℂ] C₁))))) := by + unfold assocAux + simp only [LinearEquiv.trans_apply, LinearEquiv.prodCongr_apply, + prod_fst_zero, prod_snd_zero, prod_mk_zero, TensorProduct.prodLeft_tmul, + TensorProduct.zero_tmul, map_zero, prod4Perm_apply, + TensorProduct.assoc_tmul, prodRight_symm_tmul_fst] + +/-- The associator block on a pure tensor of the `A₂ ⊗ B₂` summand +with `C₁`. -/ +@[simp] +lemma assocAux_oo {A₁ A₂ B₁ B₂ C₁ C₂ : Type*} + [AddCommGroup A₁] [Module ℂ A₁] [AddCommGroup A₂] [Module ℂ A₂] + [AddCommGroup B₁] [Module ℂ B₁] [AddCommGroup B₂] [Module ℂ B₂] + [AddCommGroup C₁] [Module ℂ C₁] [AddCommGroup C₂] [Module ℂ C₂] + (p : A₂) (q : B₂) (c : C₁) : + assocAux A₁ A₂ B₁ B₂ C₁ C₂ + ((((0 : A₁ ⊗[ℂ] B₁), p ⊗ₜ[ℂ] q) ⊗ₜ[ℂ] c, 0) : + ((((A₁ ⊗[ℂ] B₁) × (A₂ ⊗[ℂ] B₂)) ⊗[ℂ] C₁) × + (((A₁ ⊗[ℂ] B₂) × (A₂ ⊗[ℂ] B₁)) ⊗[ℂ] C₂))) = + (((0 : A₁ ⊗[ℂ] ((B₁ ⊗[ℂ] C₁) × (B₂ ⊗[ℂ] C₂))), + p ⊗ₜ[ℂ] (((0 : B₁ ⊗[ℂ] C₂), q ⊗ₜ[ℂ] c) : + (B₁ ⊗[ℂ] C₂) × (B₂ ⊗[ℂ] C₁))) : + ((A₁ ⊗[ℂ] ((B₁ ⊗[ℂ] C₁) × (B₂ ⊗[ℂ] C₂))) × + (A₂ ⊗[ℂ] ((B₁ ⊗[ℂ] C₂) × (B₂ ⊗[ℂ] C₁))))) := by + unfold assocAux + simp only [LinearEquiv.trans_apply, LinearEquiv.prodCongr_apply, + prod_fst_zero, prod_snd_zero, prod_mk_zero, TensorProduct.prodLeft_tmul, + TensorProduct.zero_tmul, map_zero, prod4Perm_apply, + TensorProduct.assoc_tmul, prodRight_symm_tmul_snd] + +/-- The associator block on a pure tensor of the `A₁ ⊗ B₂` summand +with `C₂`. -/ +@[simp] +lemma assocAux_eo {A₁ A₂ B₁ B₂ C₁ C₂ : Type*} + [AddCommGroup A₁] [Module ℂ A₁] [AddCommGroup A₂] [Module ℂ A₂] + [AddCommGroup B₁] [Module ℂ B₁] [AddCommGroup B₂] [Module ℂ B₂] + [AddCommGroup C₁] [Module ℂ C₁] [AddCommGroup C₂] [Module ℂ C₂] + (a : A₁) (b : B₂) (c : C₂) : + assocAux A₁ A₂ B₁ B₂ C₁ C₂ + (((0 : ((A₁ ⊗[ℂ] B₁) × (A₂ ⊗[ℂ] B₂)) ⊗[ℂ] C₁), (a ⊗ₜ[ℂ] b, 0) ⊗ₜ[ℂ] c) : + ((((A₁ ⊗[ℂ] B₁) × (A₂ ⊗[ℂ] B₂)) ⊗[ℂ] C₁) × + (((A₁ ⊗[ℂ] B₂) × (A₂ ⊗[ℂ] B₁)) ⊗[ℂ] C₂))) = + ((a ⊗ₜ[ℂ] (((0 : B₁ ⊗[ℂ] C₁), b ⊗ₜ[ℂ] c) : (B₁ ⊗[ℂ] C₁) × (B₂ ⊗[ℂ] C₂)), + 0) : + ((A₁ ⊗[ℂ] ((B₁ ⊗[ℂ] C₁) × (B₂ ⊗[ℂ] C₂))) × + (A₂ ⊗[ℂ] ((B₁ ⊗[ℂ] C₂) × (B₂ ⊗[ℂ] C₁))))) := by + unfold assocAux + simp only [LinearEquiv.trans_apply, LinearEquiv.prodCongr_apply, + prod_fst_zero, prod_snd_zero, prod_mk_zero, TensorProduct.prodLeft_tmul, + TensorProduct.zero_tmul, map_zero, prod4Perm_apply, + TensorProduct.assoc_tmul, prodRight_symm_tmul_snd] + +/-- The associator block on a pure tensor of the `A₂ ⊗ B₁` summand +with `C₂`. -/ +@[simp] +lemma assocAux_oe {A₁ A₂ B₁ B₂ C₁ C₂ : Type*} + [AddCommGroup A₁] [Module ℂ A₁] [AddCommGroup A₂] [Module ℂ A₂] + [AddCommGroup B₁] [Module ℂ B₁] [AddCommGroup B₂] [Module ℂ B₂] + [AddCommGroup C₁] [Module ℂ C₁] [AddCommGroup C₂] [Module ℂ C₂] + (p : A₂) (q : B₁) (c : C₂) : + assocAux A₁ A₂ B₁ B₂ C₁ C₂ + (((0 : ((A₁ ⊗[ℂ] B₁) × (A₂ ⊗[ℂ] B₂)) ⊗[ℂ] C₁), ((0 : A₁ ⊗[ℂ] B₂), p + ⊗ₜ[ℂ] q) ⊗ₜ[ℂ] c) : + ((((A₁ ⊗[ℂ] B₁) × (A₂ ⊗[ℂ] B₂)) ⊗[ℂ] C₁) × + (((A₁ ⊗[ℂ] B₂) × (A₂ ⊗[ℂ] B₁)) ⊗[ℂ] C₂))) = + (((0 : A₁ ⊗[ℂ] ((B₁ ⊗[ℂ] C₁) × (B₂ ⊗[ℂ] C₂))), + p ⊗ₜ[ℂ] ((q ⊗ₜ[ℂ] c, 0) : + (B₁ ⊗[ℂ] C₂) × (B₂ ⊗[ℂ] C₁))) : + ((A₁ ⊗[ℂ] ((B₁ ⊗[ℂ] C₁) × (B₂ ⊗[ℂ] C₂))) × + (A₂ ⊗[ℂ] ((B₁ ⊗[ℂ] C₂) × (B₂ ⊗[ℂ] C₁))))) := by + unfold assocAux + simp only [LinearEquiv.trans_apply, LinearEquiv.prodCongr_apply, + prod_fst_zero, prod_snd_zero, prod_mk_zero, TensorProduct.prodLeft_tmul, + TensorProduct.zero_tmul, map_zero, prod4Perm_apply, + TensorProduct.assoc_tmul, prodRight_symm_tmul_fst] + +-- The inverse of `assocAux` on the image generators, by +-- `symm_apply_eq` from the forward lemmas. + +/-- The inverse associator block on a pure tensor of `A₁` with the +`B₁ ⊗ C₁` summand. -/ +@[simp] +lemma assocAux_symm_ee {A₁ A₂ B₁ B₂ C₁ C₂ : Type*} + [AddCommGroup A₁] [Module ℂ A₁] [AddCommGroup A₂] [Module ℂ A₂] + [AddCommGroup B₁] [Module ℂ B₁] [AddCommGroup B₂] [Module ℂ B₂] + [AddCommGroup C₁] [Module ℂ C₁] [AddCommGroup C₂] [Module ℂ C₂] + (a : A₁) (b : B₁) (c : C₁) : + (assocAux A₁ A₂ B₁ B₂ C₁ C₂).symm + ((a ⊗ₜ[ℂ] ((b ⊗ₜ[ℂ] c, 0) : (B₁ ⊗[ℂ] C₁) × (B₂ ⊗[ℂ] C₂)), 0) : + ((A₁ ⊗[ℂ] ((B₁ ⊗[ℂ] C₁) × (B₂ ⊗[ℂ] C₂))) × + (A₂ ⊗[ℂ] ((B₁ ⊗[ℂ] C₂) × (B₂ ⊗[ℂ] C₁))))) = + (((a ⊗ₜ[ℂ] b, 0) ⊗ₜ[ℂ] c, 0) : + ((((A₁ ⊗[ℂ] B₁) × (A₂ ⊗[ℂ] B₂)) ⊗[ℂ] C₁) × + (((A₁ ⊗[ℂ] B₂) × (A₂ ⊗[ℂ] B₁)) ⊗[ℂ] C₂))) := by + rw [LinearEquiv.symm_apply_eq, assocAux_ee] + +/-- The inverse associator block on a pure tensor of `A₂` with the +`B₂ ⊗ C₁` summand. -/ +@[simp] +lemma assocAux_symm_oo {A₁ A₂ B₁ B₂ C₁ C₂ : Type*} + [AddCommGroup A₁] [Module ℂ A₁] [AddCommGroup A₂] [Module ℂ A₂] + [AddCommGroup B₁] [Module ℂ B₁] [AddCommGroup B₂] [Module ℂ B₂] + [AddCommGroup C₁] [Module ℂ C₁] [AddCommGroup C₂] [Module ℂ C₂] + (p : A₂) (q : B₂) (c : C₁) : + (assocAux A₁ A₂ B₁ B₂ C₁ C₂).symm + (((0 : A₁ ⊗[ℂ] ((B₁ ⊗[ℂ] C₁) × (B₂ ⊗[ℂ] C₂))), + p ⊗ₜ[ℂ] (((0 : B₁ ⊗[ℂ] C₂), q ⊗ₜ[ℂ] c) : + (B₁ ⊗[ℂ] C₂) × (B₂ ⊗[ℂ] C₁))) : + ((A₁ ⊗[ℂ] ((B₁ ⊗[ℂ] C₁) × (B₂ ⊗[ℂ] C₂))) × + (A₂ ⊗[ℂ] ((B₁ ⊗[ℂ] C₂) × (B₂ ⊗[ℂ] C₁))))) = + ((((0 : A₁ ⊗[ℂ] B₁), p ⊗ₜ[ℂ] q) ⊗ₜ[ℂ] c, 0) : + ((((A₁ ⊗[ℂ] B₁) × (A₂ ⊗[ℂ] B₂)) ⊗[ℂ] C₁) × + (((A₁ ⊗[ℂ] B₂) × (A₂ ⊗[ℂ] B₁)) ⊗[ℂ] C₂))) := by + rw [LinearEquiv.symm_apply_eq, assocAux_oo] + +/-- The inverse associator block on a pure tensor of `A₁` with the +`B₂ ⊗ C₂` summand. -/ +@[simp] +lemma assocAux_symm_eo {A₁ A₂ B₁ B₂ C₁ C₂ : Type*} + [AddCommGroup A₁] [Module ℂ A₁] [AddCommGroup A₂] [Module ℂ A₂] + [AddCommGroup B₁] [Module ℂ B₁] [AddCommGroup B₂] [Module ℂ B₂] + [AddCommGroup C₁] [Module ℂ C₁] [AddCommGroup C₂] [Module ℂ C₂] + (a : A₁) (b : B₂) (c : C₂) : + (assocAux A₁ A₂ B₁ B₂ C₁ C₂).symm + ((a ⊗ₜ[ℂ] (((0 : B₁ ⊗[ℂ] C₁), b ⊗ₜ[ℂ] c) : (B₁ ⊗[ℂ] C₁) × (B₂ ⊗[ℂ] C₂)), + 0) : + ((A₁ ⊗[ℂ] ((B₁ ⊗[ℂ] C₁) × (B₂ ⊗[ℂ] C₂))) × + (A₂ ⊗[ℂ] ((B₁ ⊗[ℂ] C₂) × (B₂ ⊗[ℂ] C₁))))) = + (((0 : ((A₁ ⊗[ℂ] B₁) × (A₂ ⊗[ℂ] B₂)) ⊗[ℂ] C₁), (a ⊗ₜ[ℂ] b, 0) ⊗ₜ[ℂ] c) : + ((((A₁ ⊗[ℂ] B₁) × (A₂ ⊗[ℂ] B₂)) ⊗[ℂ] C₁) × + (((A₁ ⊗[ℂ] B₂) × (A₂ ⊗[ℂ] B₁)) ⊗[ℂ] C₂))) := by + rw [LinearEquiv.symm_apply_eq, assocAux_eo] + +/-- The inverse associator block on a pure tensor of `A₂` with the +`B₁ ⊗ C₂` summand. -/ +@[simp] +lemma assocAux_symm_oe {A₁ A₂ B₁ B₂ C₁ C₂ : Type*} + [AddCommGroup A₁] [Module ℂ A₁] [AddCommGroup A₂] [Module ℂ A₂] + [AddCommGroup B₁] [Module ℂ B₁] [AddCommGroup B₂] [Module ℂ B₂] + [AddCommGroup C₁] [Module ℂ C₁] [AddCommGroup C₂] [Module ℂ C₂] + (p : A₂) (q : B₁) (c : C₂) : + (assocAux A₁ A₂ B₁ B₂ C₁ C₂).symm + (((0 : A₁ ⊗[ℂ] ((B₁ ⊗[ℂ] C₁) × (B₂ ⊗[ℂ] C₂))), + p ⊗ₜ[ℂ] ((q ⊗ₜ[ℂ] c, 0) : + (B₁ ⊗[ℂ] C₂) × (B₂ ⊗[ℂ] C₁))) : + ((A₁ ⊗[ℂ] ((B₁ ⊗[ℂ] C₁) × (B₂ ⊗[ℂ] C₂))) × + (A₂ ⊗[ℂ] ((B₁ ⊗[ℂ] C₂) × (B₂ ⊗[ℂ] C₁))))) = + (((0 : ((A₁ ⊗[ℂ] B₁) × (A₂ ⊗[ℂ] B₂)) ⊗[ℂ] C₁), ((0 : A₁ ⊗[ℂ] B₂), p ⊗ₜ[ℂ] + q) ⊗ₜ[ℂ] c) : + ((((A₁ ⊗[ℂ] B₁) × (A₂ ⊗[ℂ] B₂)) ⊗[ℂ] C₁) × + (((A₁ ⊗[ℂ] B₂) × (A₂ ⊗[ℂ] B₁)) ⊗[ℂ] C₂))) := by + rw [LinearEquiv.symm_apply_eq, assocAux_oe] + +-- Computation of the Koszul blocks on the two generator shapes; +-- the sign of the even block is emitted outside the pair so the +-- associator computation lemmas can fire beneath it. +/-- The even Koszul block on the first summand: plain +commutation, no sign. -/ +@[simp] +lemma koszulEvenAux_fst {A B C D : Type*} + [AddCommGroup A] [Module ℂ A] [AddCommGroup B] [Module ℂ B] + [AddCommGroup C] [Module ℂ C] [AddCommGroup D] [Module ℂ D] + (a : A) (b : B) : + koszulEvenAux A B C D ((a ⊗ₜ[ℂ] b, 0) : (A ⊗[ℂ] B) × (C ⊗[ℂ] D)) = + ((b ⊗ₜ[ℂ] a, 0) : (B ⊗[ℂ] A) × (D ⊗[ℂ] C)) := by + simp [koszulEvenAux] + +/-- **The Koszul sign**: on the second summand — the odd⊗odd +block — the even block commutes *and* negates. -/ +@[simp] +lemma koszulEvenAux_snd {A B C D : Type*} + [AddCommGroup A] [Module ℂ A] [AddCommGroup B] [Module ℂ B] + [AddCommGroup C] [Module ℂ C] [AddCommGroup D] [Module ℂ D] + (c : C) (d : D) : + koszulEvenAux A B C D ((0, c ⊗ₜ[ℂ] d) : (A ⊗[ℂ] B) × (C ⊗[ℂ] D)) = + -(((0, d ⊗ₜ[ℂ] c)) : (B ⊗[ℂ] A) × (D ⊗[ℂ] C)) := by + simp only [koszulEvenAux, LinearMap.prodMap_apply, map_zero, + LinearMap.neg_apply, LinearEquiv.coe_toLinearMap, + TensorProduct.comm_tmul] + ext <;> simp + +/-- The odd Koszul block on the first summand: commutation into +the other summand, no sign. -/ +@[simp] +lemma koszulOddAux_fst {A B C D : Type*} + [AddCommGroup A] [Module ℂ A] [AddCommGroup B] [Module ℂ B] + [AddCommGroup C] [Module ℂ C] [AddCommGroup D] [Module ℂ D] + (a : A) (b : B) : + koszulOddAux A B C D ((a ⊗ₜ[ℂ] b, 0) : (A ⊗[ℂ] B) × (C ⊗[ℂ] D)) = + ((0, b ⊗ₜ[ℂ] a) : (D ⊗[ℂ] C) × (B ⊗[ℂ] A)) := by + simp [koszulOddAux] + +/-- The odd Koszul block on the second summand: likewise +unsigned — only the odd⊗odd block carries the sign. -/ +@[simp] +lemma koszulOddAux_snd {A B C D : Type*} + [AddCommGroup A] [Module ℂ A] [AddCommGroup B] [Module ℂ B] + [AddCommGroup C] [Module ℂ C] [AddCommGroup D] [Module ℂ D] + (c : C) (d : D) : + koszulOddAux A B C D ((0, c ⊗ₜ[ℂ] d) : (A ⊗[ℂ] B) × (C ⊗[ℂ] D)) = + ((d ⊗ₜ[ℂ] c, 0) : (D ⊗[ℂ] C) × (B ⊗[ℂ] A)) := by + simp [koszulOddAux] + +-- Sign bookkeeping for the hexagon proofs: negations are kept +-- outside pairs (the `Prod.neg_mk` normal form is disabled there), +-- so single-sided negated pairs must re-assemble to negated pairs. +/-- A left-negated pair is a negated pair. -/ +lemma prod_mk_neg_left {A B : Type*} + [AddCommGroup A] [AddCommGroup B] (u : A) : + ((-u, (0 : B)) : A × B) = -(u, 0) := by + ext <;> simp + +/-- A right-negated pair is a negated pair. -/ +lemma prod_mk_neg_right {A B : Type*} + [AddCommGroup A] [AddCommGroup B] (v : B) : + (((0 : A), -v) : A × B) = -((0 : A), v) := by + ext <;> simp + +/-- The triangle coherence of the module-level associator block +against the unit slots `ℂ` (even) and `PUnit` (odd). Both graded +components of the SuperVect triangle are instantiations. -/ +theorem assocAux_triangle (A₁ A₂ B₁ B₂ : Type*) + [AddCommGroup A₁] [Module ℂ A₁] [AddCommGroup A₂] [Module ℂ A₂] + [AddCommGroup B₁] [Module ℂ B₁] [AddCommGroup B₂] [Module ℂ B₂] : + LinearMap.prodMap + (TensorProduct.map LinearMap.id + ((TensorProduct.lid ℂ B₁).toLinearMap ∘ₗ + LinearMap.fst ℂ (ℂ ⊗[ℂ] B₁) (PUnit ⊗[ℂ] B₂))) + (TensorProduct.map LinearMap.id + ((TensorProduct.lid ℂ B₂).toLinearMap ∘ₗ + LinearMap.fst ℂ (ℂ ⊗[ℂ] B₂) (PUnit ⊗[ℂ] B₁))) ∘ₗ + (assocAux A₁ A₂ ℂ PUnit B₁ B₂).toLinearMap = + LinearMap.prodMap + (TensorProduct.map + ((TensorProduct.rid ℂ A₁).toLinearMap ∘ₗ + LinearMap.fst ℂ (A₁ ⊗[ℂ] ℂ) (A₂ ⊗[ℂ] PUnit)) LinearMap.id) + (TensorProduct.map + ((TensorProduct.rid ℂ A₂).toLinearMap ∘ₗ + LinearMap.snd ℂ (A₁ ⊗[ℂ] PUnit) (A₂ ⊗[ℂ] ℂ)) LinearMap.id) := by + ext x + all_goals simp + +/-- The forward hexagon for the even graded component, at the +module level: braiding past a tensor product in two steps agrees +with braiding past its factors. -/ +theorem koszulAux_hexagon_fwd_even (A₁ A₂ B₁ B₂ C₁ C₂ : Type*) + [AddCommGroup A₁] [Module ℂ A₁] [AddCommGroup A₂] [Module ℂ A₂] + [AddCommGroup B₁] [Module ℂ B₁] [AddCommGroup B₂] [Module ℂ B₂] + [AddCommGroup C₁] [Module ℂ C₁] [AddCommGroup C₂] [Module ℂ C₂] : + ((assocAux B₁ B₂ C₁ C₂ A₁ A₂).toLinearMap ∘ₗ + koszulEvenAux A₁ ((B₁ ⊗[ℂ] C₁) × (B₂ ⊗[ℂ] C₂)) A₂ ((B₁ ⊗[ℂ] C₂) × (B₂ ⊗[ℂ] + C₁))) ∘ₗ + (assocAux A₁ A₂ B₁ B₂ C₁ C₂).toLinearMap = + (LinearMap.prodMap + (TensorProduct.map LinearMap.id (koszulEvenAux A₁ C₁ A₂ C₂)) + (TensorProduct.map LinearMap.id (koszulOddAux A₁ C₂ A₂ C₁)) ∘ₗ + (assocAux B₁ B₂ A₁ A₂ C₁ C₂).toLinearMap) ∘ₗ + LinearMap.prodMap + (TensorProduct.map (koszulEvenAux A₁ B₁ A₂ B₂) LinearMap.id) + (TensorProduct.map (koszulOddAux A₁ B₂ A₂ B₁) LinearMap.id) := by + ext x + all_goals simp [-Prod.neg_mk, TensorProduct.neg_tmul, + TensorProduct.tmul_neg, prod_mk_neg_left, prod_mk_neg_right] + +/-- The forward hexagon for the odd graded component. -/ +theorem koszulAux_hexagon_fwd_odd (A₁ A₂ B₁ B₂ C₁ C₂ : Type*) + [AddCommGroup A₁] [Module ℂ A₁] [AddCommGroup A₂] [Module ℂ A₂] + [AddCommGroup B₁] [Module ℂ B₁] [AddCommGroup B₂] [Module ℂ B₂] + [AddCommGroup C₁] [Module ℂ C₁] [AddCommGroup C₂] [Module ℂ C₂] : + ((assocAux B₁ B₂ C₁ C₂ A₂ A₁).toLinearMap ∘ₗ + koszulOddAux A₁ ((B₁ ⊗[ℂ] C₂) × (B₂ ⊗[ℂ] C₁)) A₂ ((B₁ ⊗[ℂ] C₁) × (B₂ ⊗[ℂ] + C₂))) ∘ₗ + (assocAux A₁ A₂ B₁ B₂ C₂ C₁).toLinearMap = + (LinearMap.prodMap + (TensorProduct.map LinearMap.id (koszulOddAux A₁ C₂ A₂ C₁)) + (TensorProduct.map LinearMap.id (koszulEvenAux A₁ C₁ A₂ C₂)) ∘ₗ + (assocAux B₁ B₂ A₁ A₂ C₂ C₁).toLinearMap) ∘ₗ + LinearMap.prodMap + (TensorProduct.map (koszulEvenAux A₁ B₁ A₂ B₂) LinearMap.id) + (TensorProduct.map (koszulOddAux A₁ B₂ A₂ B₁) LinearMap.id) := by + ext x + all_goals simp [-Prod.neg_mk, TensorProduct.neg_tmul, + TensorProduct.tmul_neg, prod_mk_neg_left] + +/-- The reverse hexagon for the even graded component, phrased +through the inverse associator blocks. -/ +theorem koszulAux_hexagon_rev_even (A₁ A₂ B₁ B₂ C₁ C₂ : Type*) + [AddCommGroup A₁] [Module ℂ A₁] [AddCommGroup A₂] [Module ℂ A₂] + [AddCommGroup B₁] [Module ℂ B₁] [AddCommGroup B₂] [Module ℂ B₂] + [AddCommGroup C₁] [Module ℂ C₁] [AddCommGroup C₂] [Module ℂ C₂] : + ((assocAux C₁ C₂ A₁ A₂ B₁ B₂).symm.toLinearMap ∘ₗ + koszulEvenAux ((A₁ ⊗[ℂ] B₁) × (A₂ ⊗[ℂ] B₂)) C₁ ((A₁ ⊗[ℂ] B₂) × (A₂ ⊗[ℂ] + B₁)) C₂) ∘ₗ + (assocAux A₁ A₂ B₁ B₂ C₁ C₂).symm.toLinearMap = + (LinearMap.prodMap + (TensorProduct.map (koszulEvenAux A₁ C₁ A₂ C₂) LinearMap.id) + (TensorProduct.map (koszulOddAux A₁ C₂ A₂ C₁) LinearMap.id) ∘ₗ + (assocAux A₁ A₂ C₁ C₂ B₁ B₂).symm.toLinearMap) ∘ₗ + LinearMap.prodMap + (TensorProduct.map LinearMap.id (koszulEvenAux B₁ C₁ B₂ C₂)) + (TensorProduct.map LinearMap.id (koszulOddAux B₁ C₂ B₂ C₁)) := by + ext x + all_goals simp [-Prod.neg_mk, TensorProduct.neg_tmul, + TensorProduct.tmul_neg, prod_mk_neg_left, prod_mk_neg_right] + +/-- The reverse hexagon for the odd graded component. -/ +theorem koszulAux_hexagon_rev_odd (A₁ A₂ B₁ B₂ C₁ C₂ : Type*) + [AddCommGroup A₁] [Module ℂ A₁] [AddCommGroup A₂] [Module ℂ A₂] + [AddCommGroup B₁] [Module ℂ B₁] [AddCommGroup B₂] [Module ℂ B₂] + [AddCommGroup C₁] [Module ℂ C₁] [AddCommGroup C₂] [Module ℂ C₂] : + ((assocAux C₁ C₂ A₁ A₂ B₂ B₁).symm.toLinearMap ∘ₗ + koszulOddAux ((A₁ ⊗[ℂ] B₁) × (A₂ ⊗[ℂ] B₂)) C₂ ((A₁ ⊗[ℂ] B₂) × (A₂ ⊗[ℂ] + B₁)) C₁) ∘ₗ + (assocAux A₁ A₂ B₁ B₂ C₂ C₁).symm.toLinearMap = + (LinearMap.prodMap + (TensorProduct.map (koszulEvenAux A₁ C₁ A₂ C₂) LinearMap.id) + (TensorProduct.map (koszulOddAux A₁ C₂ A₂ C₁) LinearMap.id) ∘ₗ + (assocAux A₁ A₂ C₁ C₂ B₂ B₁).symm.toLinearMap) ∘ₗ + LinearMap.prodMap + (TensorProduct.map LinearMap.id (koszulOddAux B₁ C₂ B₂ C₁)) + (TensorProduct.map LinearMap.id (koszulEvenAux B₁ C₁ B₂ C₂)) := by + ext x + all_goals simp [-Prod.neg_mk, TensorProduct.neg_tmul, + TensorProduct.tmul_neg, prod_mk_neg_right] + +/-- The pentagon coherence of the module-level associator block: +both routes from a four-fold graded product to its right-nested +form agree. Both graded components of the SuperVect pentagon are +instantiations. -/ +theorem assocAux_pentagon (A₁ A₂ B₁ B₂ C₁ C₂ D₁ D₂ : Type*) + [AddCommGroup A₁] [Module ℂ A₁] [AddCommGroup A₂] [Module ℂ A₂] + [AddCommGroup B₁] [Module ℂ B₁] [AddCommGroup B₂] [Module ℂ B₂] + [AddCommGroup C₁] [Module ℂ C₁] [AddCommGroup C₂] [Module ℂ C₂] + [AddCommGroup D₁] [Module ℂ D₁] [AddCommGroup D₂] [Module ℂ D₂] : + (LinearMap.prodMap + (TensorProduct.map LinearMap.id (assocAux B₁ B₂ C₁ C₂ D₁ + D₂).toLinearMap) + (TensorProduct.map LinearMap.id (assocAux B₁ B₂ C₁ C₂ D₂ + D₁).toLinearMap) ∘ₗ + (assocAux A₁ A₂ ((B₁ ⊗[ℂ] C₁) × (B₂ ⊗[ℂ] C₂)) + ((B₁ ⊗[ℂ] C₂) × (B₂ ⊗[ℂ] C₁)) D₁ D₂).toLinearMap) ∘ₗ + LinearMap.prodMap + (TensorProduct.map (assocAux A₁ A₂ B₁ B₂ C₁ C₂).toLinearMap + LinearMap.id) + (TensorProduct.map (assocAux A₁ A₂ B₁ B₂ C₂ C₁).toLinearMap + LinearMap.id) = + (assocAux A₁ A₂ B₁ B₂ ((C₁ ⊗[ℂ] D₁) × (C₂ ⊗[ℂ] D₂)) + ((C₁ ⊗[ℂ] D₂) × (C₂ ⊗[ℂ] D₁))).toLinearMap ∘ₗ + (assocAux ((A₁ ⊗[ℂ] B₁) × (A₂ ⊗[ℂ] B₂)) + ((A₁ ⊗[ℂ] B₂) × (A₂ ⊗[ℂ] B₁)) C₁ C₂ D₁ D₂).toLinearMap := by + ext x + all_goals simp + +/-! ### Component projection lemmas -/ + +/-- The even component of a categorical composite. -/ +@[simp] +theorem cat_comp_evenMap {V W X : SuperVect} (f : V ⟶ W) (g : W ⟶ X) : + (f ≫ g).evenMap = g.evenMap.comp f.evenMap := rfl + +/-- The odd component of a categorical composite. -/ +@[simp] +theorem cat_comp_oddMap {V W X : SuperVect} (f : V ⟶ W) (g : W ⟶ X) : + (f ≫ g).oddMap = g.oddMap.comp f.oddMap := rfl + +/-- The even component of a categorical identity. -/ +@[simp] +theorem cat_id_evenMap (V : SuperVect) : + (𝟙 V : Hom V V).evenMap = LinearMap.id := rfl + +/-- The odd component of a categorical identity. -/ +@[simp] +theorem cat_id_oddMap (V : SuperVect) : + (𝟙 V : Hom V V).oddMap = LinearMap.id := rfl + +/-- The even component of a tensor of morphisms: even⊗even and +odd⊗odd in parallel. -/ +@[simp] +theorem tensorHom_evenMap {V₁ V₂ W₁ W₂ : SuperVect} + (f : Hom V₁ V₂) (g : Hom W₁ W₂) : + (tensorHom f g).evenMap = LinearMap.prodMap + (TensorProduct.map f.evenMap g.evenMap) + (TensorProduct.map f.oddMap g.oddMap) := rfl + +/-- The odd component of a tensor of morphisms: even⊗odd and +odd⊗even in parallel. -/ +@[simp] +theorem tensorHom_oddMap {V₁ V₂ W₁ W₂ : SuperVect} + (f : Hom V₁ V₂) (g : Hom W₁ W₂) : + (tensorHom f g).oddMap = LinearMap.prodMap + (TensorProduct.map f.evenMap g.oddMap) + (TensorProduct.map f.oddMap g.evenMap) := rfl + +/-- The associator's even component is the even associator +equivalence. -/ +@[simp] +theorem associator_hom_evenMap (V W X : SuperVect) : + ((associator V W X).hom).evenMap = + (assocEvenEquiv V W X).toLinearMap := rfl + +/-- The associator's odd component is the odd associator +equivalence. -/ +@[simp] +theorem associator_hom_oddMap (V W X : SuperVect) : + ((associator V W X).hom).oddMap = + (assocOddEquiv V W X).toLinearMap := rfl + +/-- The inverse associator's even component. -/ +@[simp] +theorem associator_inv_evenMap (V W X : SuperVect) : + ((associator V W X).inv).evenMap = + (assocEvenEquiv V W X).symm.toLinearMap := rfl + +/-- The inverse associator's odd component. -/ +@[simp] +theorem associator_inv_oddMap (V W X : SuperVect) : + ((associator V W X).inv).oddMap = + (assocOddEquiv V W X).symm.toLinearMap := rfl + +/-- The left unitor's even component: the unit's odd part is zero, +so only the first summand survives. -/ +@[simp] +theorem leftUnitor_hom_evenMap (V : SuperVect) : + ((leftUnitor V).hom).evenMap = + (TensorProduct.lid ℂ V.even).toLinearMap.comp (LinearMap.fst ℂ _ _) := rfl + +/-- The left unitor's odd component. -/ +@[simp] +theorem leftUnitor_hom_oddMap (V : SuperVect) : + ((leftUnitor V).hom).oddMap = + (TensorProduct.lid ℂ V.odd).toLinearMap.comp (LinearMap.fst ℂ _ _) := rfl + +/-- The right unitor's even component. -/ +@[simp] +theorem rightUnitor_hom_evenMap (V : SuperVect) : + ((rightUnitor V).hom).evenMap = + (TensorProduct.rid ℂ V.even).toLinearMap.comp (LinearMap.fst ℂ _ _) := rfl + +/-- The right unitor's odd component: here it is the *second* +summand that survives, the unit sitting on the right. -/ +@[simp] +theorem rightUnitor_hom_oddMap (V : SuperVect) : + ((rightUnitor V).hom).oddMap = + (TensorProduct.rid ℂ V.odd).toLinearMap.comp (LinearMap.snd ℂ _ _) := rfl + +/-- The braiding's even component. -/ +@[simp] +theorem koszulBraiding_evenMap (V W : SuperVect) : + (koszulBraiding V W).evenMap = koszulBraidingEven V W := rfl + +/-- The braiding's odd component. -/ +@[simp] +theorem koszulBraiding_oddMap (V W : SuperVect) : + (koszulBraiding V W).oddMap = koszulBraidingOdd V W := rfl + +/-! ### Monoidal structure -/ + +/-- The monoidal category structure on SuperVect: graded tensor +product, ℂ unit, standard associator/unitors. -/ +instance instMonoidalCategoryStruct : MonoidalCategoryStruct SuperVect where + tensorObj := tensorObj + whiskerLeft := fun (X : SuperVect) {Y₁ : SuperVect} {Y₂ : SuperVect} + (f : Y₁ ⟶ Y₂) => + SuperVect.tensorHom (Hom.id X) f + whiskerRight := fun {X₁ : SuperVect} {X₂ : SuperVect} (f : X₁ ⟶ X₂) + (Y : SuperVect) => + SuperVect.tensorHom f (Hom.id Y) + tensorHom := fun f g => SuperVect.tensorHom f g + tensorUnit := tensorUnit + associator := associator + leftUnitor := leftUnitor + rightUnitor := rightUnitor + +/-! ### MonoidalCategory axioms -/ + +/-- `tensorHom id id = id`: the tensor of identity morphisms is +the identity on the tensor product. -/ +theorem tensorHom_id_id (X₁ X₂ : SuperVect) : + SuperVect.tensorHom (Hom.id X₁) (Hom.id X₂) = Hom.id (tensorObj X₁ X₂) := by + apply Hom.ext <;> { + change LinearMap.prodMap + (TensorProduct.map LinearMap.id LinearMap.id) + (TensorProduct.map LinearMap.id LinearMap.id) = LinearMap.id + simp [TensorProduct.map_id] } + +/-- Composition distributes over tensor product of morphisms. -/ +theorem tensorHom_comp (X₁ Y₁ Z₁ X₂ Y₂ Z₂ : SuperVect) + (f₁ : Hom X₁ Y₁) (f₂ : Hom X₂ Y₂) (g₁ : Hom Y₁ Z₁) (g₂ : Hom Y₂ Z₂) : + Hom.comp (SuperVect.tensorHom g₁ g₂) (SuperVect.tensorHom f₁ f₂) = + SuperVect.tensorHom (Hom.comp g₁ f₁) (Hom.comp g₂ f₂) := by + apply Hom.ext <;> { + change LinearMap.comp _ _ = _ + simp only [Hom.comp, SuperVect.tensorHom] + change (LinearMap.prodMap _ _).comp (LinearMap.prodMap _ _) = + LinearMap.prodMap _ _ + simp [LinearMap.prodMap_comp, TensorProduct.map_comp] } + +/-- The full monoidal category structure on SuperVect, constructed +via `ofTensorHom`. -/ +instance instMonoidalCategory : MonoidalCategory SuperVect := + MonoidalCategory.ofTensorHom + (id_tensorHom_id := fun X₁ X₂ => tensorHom_id_id X₁ X₂) + (id_tensorHom := fun _ {_ _} _ => rfl) + (tensorHom_id := fun {_ _} _ _ => rfl) + (tensorHom_comp_tensorHom := fun {_ _ _ _ _ _} f₁ f₂ g₁ g₂ => by + change Hom.comp (SuperVect.tensorHom g₁ g₂) (SuperVect.tensorHom f₁ f₂) = + SuperVect.tensorHom (Hom.comp g₁ f₁) (Hom.comp g₂ f₂) + exact tensorHom_comp _ _ _ _ _ _ f₁ f₂ g₁ g₂) + -- ═══════ ASSOCIATOR NATURALITY ═══════ + (associator_naturality := fun {X₁ X₂ X₃ Y₁ Y₂ Y₃} f₁ f₂ f₃ => by + apply Hom.ext + · change + (assocAux Y₁.even Y₁.odd Y₂.even Y₂.odd Y₃.even Y₃.odd).toLinearMap ∘ₗ + LinearMap.prodMap + (TensorProduct.map + (LinearMap.prodMap (TensorProduct.map f₁.evenMap f₂.evenMap) + (TensorProduct.map f₁.oddMap f₂.oddMap)) f₃.evenMap) + (TensorProduct.map + (LinearMap.prodMap (TensorProduct.map f₁.evenMap f₂.oddMap) + (TensorProduct.map f₁.oddMap f₂.evenMap)) f₃.oddMap) = + LinearMap.prodMap + (TensorProduct.map f₁.evenMap + (LinearMap.prodMap (TensorProduct.map f₂.evenMap f₃.evenMap) + (TensorProduct.map f₂.oddMap f₃.oddMap))) + (TensorProduct.map f₁.oddMap + (LinearMap.prodMap (TensorProduct.map f₂.evenMap f₃.oddMap) + (TensorProduct.map f₂.oddMap f₃.evenMap))) ∘ₗ + (assocAux X₁.even X₁.odd X₂.even X₂.odd X₃.even X₃.odd).toLinearMap + ext x + all_goals simp + · change + (assocAux Y₁.even Y₁.odd Y₂.even Y₂.odd Y₃.odd Y₃.even).toLinearMap ∘ₗ + LinearMap.prodMap + (TensorProduct.map + (LinearMap.prodMap (TensorProduct.map f₁.evenMap f₂.evenMap) + (TensorProduct.map f₁.oddMap f₂.oddMap)) f₃.oddMap) + (TensorProduct.map + (LinearMap.prodMap (TensorProduct.map f₁.evenMap f₂.oddMap) + (TensorProduct.map f₁.oddMap f₂.evenMap)) f₃.evenMap) = + LinearMap.prodMap + (TensorProduct.map f₁.evenMap + (LinearMap.prodMap (TensorProduct.map f₂.evenMap f₃.oddMap) + (TensorProduct.map f₂.oddMap f₃.evenMap))) + (TensorProduct.map f₁.oddMap + (LinearMap.prodMap (TensorProduct.map f₂.evenMap f₃.evenMap) + (TensorProduct.map f₂.oddMap f₃.oddMap))) ∘ₗ + (assocAux X₁.even X₁.odd X₂.even X₂.odd X₃.odd X₃.even).toLinearMap + ext x + all_goals simp) + -- ═══════ LEFT UNITOR NATURALITY ═══════ + (leftUnitor_naturality := fun {X Y} (f : X ⟶ Y) => by + apply Hom.ext + · -- even component + change ((TensorProduct.lid ℂ Y.even).toLinearMap.comp (LinearMap.fst ℂ _ + _)).comp + (LinearMap.prodMap (TensorProduct.map LinearMap.id f.evenMap) + (TensorProduct.map LinearMap.id f.oddMap)) = + f.evenMap.comp + ((TensorProduct.lid ℂ X.even).toLinearMap.comp (LinearMap.fst ℂ _ + _)) + apply LinearMap.ext; intro ⟨x, y⟩ + simp only [LinearMap.comp_apply, LinearMap.fst_apply, + LinearMap.prodMap_apply, + LinearEquiv.coe_toLinearMap] + induction x using TensorProduct.inductionOn with + | tmul r m => simp [TensorProduct.lid_tmul, TensorProduct.map_tmul, + map_smul] + | add x₁ x₂ hx₁ hx₂ => simp only [map_add, hx₁, hx₂] + · -- odd component + change ((TensorProduct.lid ℂ Y.odd).toLinearMap.comp (LinearMap.fst ℂ _ + _)).comp + (LinearMap.prodMap (TensorProduct.map LinearMap.id f.oddMap) + (TensorProduct.map LinearMap.id f.evenMap)) = + f.oddMap.comp + ((TensorProduct.lid ℂ X.odd).toLinearMap.comp (LinearMap.fst ℂ _ _)) + apply LinearMap.ext; intro ⟨x, y⟩ + simp only [LinearMap.comp_apply, LinearMap.fst_apply, + LinearMap.prodMap_apply, + LinearEquiv.coe_toLinearMap] + induction x using TensorProduct.inductionOn with + | tmul r m => simp [TensorProduct.lid_tmul, TensorProduct.map_tmul, + map_smul] + | add x₁ x₂ hx₁ hx₂ => simp only [map_add, hx₁, hx₂]) + -- ═══════ RIGHT UNITOR NATURALITY ═══════ + (rightUnitor_naturality := fun {X Y} (f : X ⟶ Y) => by + apply Hom.ext + · -- even component: (rid ∘ fst) ∘ prodMap (map f.e id) (map f.o id) = f.e + -- ∘ (rid ∘ fst) + change ((TensorProduct.rid ℂ Y.even).toLinearMap.comp (LinearMap.fst ℂ _ + _)).comp + (LinearMap.prodMap (TensorProduct.map f.evenMap LinearMap.id) + (TensorProduct.map f.oddMap LinearMap.id)) = + f.evenMap.comp + ((TensorProduct.rid ℂ X.even).toLinearMap.comp (LinearMap.fst ℂ _ + _)) + apply LinearMap.ext; intro ⟨x, y⟩ + simp only [LinearMap.comp_apply, LinearMap.fst_apply, + LinearMap.prodMap_apply, + LinearEquiv.coe_toLinearMap] + induction x using TensorProduct.inductionOn with + | tmul m r => simp [TensorProduct.rid_tmul, TensorProduct.map_tmul, + map_smul] + | add x₁ x₂ hx₁ hx₂ => simp only [map_add, hx₁, hx₂] + · -- odd component: (rid ∘ snd) ∘ prodMap (map f.e id) (map f.o id) = f.o + -- ∘ (rid ∘ snd) + change ((TensorProduct.rid ℂ Y.odd).toLinearMap.comp (LinearMap.snd ℂ _ + _)).comp + (LinearMap.prodMap (TensorProduct.map f.evenMap LinearMap.id) + (TensorProduct.map f.oddMap LinearMap.id)) = + f.oddMap.comp + ((TensorProduct.rid ℂ X.odd).toLinearMap.comp (LinearMap.snd ℂ _ _)) + apply LinearMap.ext; intro ⟨x, y⟩ + simp only [LinearMap.comp_apply, LinearMap.snd_apply, + LinearMap.prodMap_apply, + LinearEquiv.coe_toLinearMap] + induction y using TensorProduct.inductionOn with + | tmul m r => simp [TensorProduct.rid_tmul, TensorProduct.map_tmul, + map_smul] + | add y₁ y₂ hy₁ hy₂ => simp only [map_add, hy₁, hy₂]) + -- ═══════ PENTAGON AND TRIANGLE ═══════ + (pentagon := fun W X Y Z => by + apply Hom.ext + · exact assocAux_pentagon W.even W.odd X.even X.odd + Y.even Y.odd Z.even Z.odd + · exact assocAux_pentagon W.even W.odd X.even X.odd + Y.even Y.odd Z.odd Z.even) + (triangle := fun X Y => by + apply Hom.ext + · exact assocAux_triangle X.even X.odd Y.even Y.odd + · exact assocAux_triangle X.even X.odd Y.odd Y.even) + +/-! ### Braided and symmetric structure -/ + +private theorem koszulBraiding_naturality_right (X : SuperVect) + {Y Z : SuperVect} (f : Y ⟶ Z) : + MonoidalCategory.whiskerLeft X f ≫ (koszulBraidingIso X Z).hom = + (koszulBraidingIso X Y).hom ≫ MonoidalCategory.whiskerRight f X := by + apply Hom.ext + · -- even component + change (koszulBraidingEven X Z).comp + (LinearMap.prodMap (TensorProduct.map LinearMap.id f.evenMap) + (TensorProduct.map LinearMap.id f.oddMap)) = + (LinearMap.prodMap (TensorProduct.map f.evenMap LinearMap.id) + (TensorProduct.map f.oddMap LinearMap.id)).comp + (koszulBraidingEven X Y) + apply LinearMap.ext; intro ⟨x, y⟩ + simp only [LinearMap.comp_apply, LinearMap.prodMap_apply, + koszulBraidingEven, koszulEvenAux, + LinearMap.neg_apply, LinearEquiv.coe_toLinearMap, Prod.mk.injEq] + refine ⟨?_, ?_⟩ + · induction x using TensorProduct.inductionOn with + | tmul a b => simp [TensorProduct.comm_tmul, TensorProduct.map_tmul] + | add x₁ x₂ hx₁ hx₂ => simp only [map_add, hx₁, hx₂] + · induction y using TensorProduct.inductionOn with + | tmul a b => + simp [TensorProduct.comm_tmul, TensorProduct.map_tmul, map_neg] + | add y₁ y₂ hy₁ hy₂ => + simp only [map_add, neg_add]; exact congr_arg₂ (· + ·) hy₁ hy₂ + · -- odd component + change (koszulBraidingOdd X Z).comp + (LinearMap.prodMap (TensorProduct.map LinearMap.id f.oddMap) + (TensorProduct.map LinearMap.id f.evenMap)) = + (LinearMap.prodMap (TensorProduct.map f.evenMap LinearMap.id) + (TensorProduct.map f.oddMap LinearMap.id)).comp + (koszulBraidingOdd X Y) + apply LinearMap.ext; intro ⟨x, y⟩ + simp only [LinearMap.comp_apply, LinearMap.prodMap_apply, + koszulBraidingOdd_pair, Prod.mk.injEq] + refine ⟨?_, ?_⟩ + · induction y using TensorProduct.inductionOn with + | tmul a b => simp [TensorProduct.comm_tmul, TensorProduct.map_tmul] + | add y₁ y₂ hy₁ hy₂ => simp only [map_add, hy₁, hy₂] + · induction x using TensorProduct.inductionOn with + | tmul a b => simp [TensorProduct.comm_tmul, TensorProduct.map_tmul] + | add x₁ x₂ hx₁ hx₂ => simp only [map_add, hx₁, hx₂] + +/-- SuperVect is a braided monoidal category with the Koszul +braiding: swapping odd ⊗ odd elements picks up a factor of −1. -/ +instance instBraidedCategory : BraidedCategory SuperVect where + braiding := koszulBraidingIso + braiding_naturality_right := fun X {_ _} f => by + exact koszulBraiding_naturality_right X f + braiding_naturality_left := fun {X Y} f Z => by + apply Hom.ext + · -- even component + change (koszulBraidingEven Y Z).comp + (LinearMap.prodMap (TensorProduct.map f.evenMap LinearMap.id) + (TensorProduct.map f.oddMap LinearMap.id)) = + (LinearMap.prodMap (TensorProduct.map LinearMap.id f.evenMap) + (TensorProduct.map LinearMap.id f.oddMap)).comp + (koszulBraidingEven X Z) + apply LinearMap.ext; intro ⟨x, y⟩ + simp only [LinearMap.comp_apply, LinearMap.prodMap_apply, + koszulBraidingEven, koszulEvenAux, + LinearMap.neg_apply, LinearEquiv.coe_toLinearMap, Prod.mk.injEq] + refine ⟨?_, ?_⟩ + · induction x using TensorProduct.inductionOn with + | tmul a b => simp [TensorProduct.comm_tmul, TensorProduct.map_tmul] + | add x₁ x₂ hx₁ hx₂ => simp only [map_add, hx₁, hx₂] + · induction y using TensorProduct.inductionOn with + | tmul a b => + simp [TensorProduct.comm_tmul, TensorProduct.map_tmul, map_neg] + | add y₁ y₂ hy₁ hy₂ => + simp only [map_add, neg_add]; exact congr_arg₂ (· + ·) hy₁ hy₂ + · -- odd component + change (koszulBraidingOdd Y Z).comp + (LinearMap.prodMap (TensorProduct.map f.evenMap LinearMap.id) + (TensorProduct.map f.oddMap LinearMap.id)) = + (LinearMap.prodMap (TensorProduct.map LinearMap.id f.oddMap) + (TensorProduct.map LinearMap.id f.evenMap)).comp + (koszulBraidingOdd X Z) + apply LinearMap.ext; intro ⟨x, y⟩ + simp only [LinearMap.comp_apply, LinearMap.prodMap_apply, + koszulBraidingOdd_pair, Prod.mk.injEq] + refine ⟨?_, ?_⟩ + · induction y using TensorProduct.inductionOn with + | tmul a b => simp [TensorProduct.comm_tmul, TensorProduct.map_tmul] + | add y₁ y₂ hy₁ hy₂ => simp only [map_add, hy₁, hy₂] + · induction x using TensorProduct.inductionOn with + | tmul a b => simp [TensorProduct.comm_tmul, TensorProduct.map_tmul] + | add x₁ x₂ hx₁ hx₂ => simp only [map_add, hx₁, hx₂] + hexagon_forward := fun X Y Z => by + apply Hom.ext + · exact koszulAux_hexagon_fwd_even X.even X.odd Y.even Y.odd + Z.even Z.odd + · exact koszulAux_hexagon_fwd_odd X.even X.odd Y.even Y.odd + Z.even Z.odd + hexagon_reverse := fun X Y Z => by + apply Hom.ext + · exact koszulAux_hexagon_rev_even X.even X.odd Y.even Y.odd + Z.even Z.odd + · exact koszulAux_hexagon_rev_odd X.even X.odd Y.even Y.odd + Z.even Z.odd + +/-- SuperVect is a symmetric monoidal category: applying the +Koszul braiding twice recovers the identity. -/ +instance instSymmetricCategory : SymmetricCategory SuperVect where + symmetry := fun X Y => koszulBraiding_self_inverse X Y + +/-! ### Additive and linear structure -/ + +/-- The zero morphism: zero in both components. -/ +instance {V W : SuperVect} : Zero (V ⟶ W) := + ⟨⟨0, 0⟩⟩ + +/-- Componentwise addition of morphisms. -/ +instance {V W : SuperVect} : Add (V ⟶ W) := + ⟨fun f g => ⟨f.evenMap + g.evenMap, f.oddMap + g.oddMap⟩⟩ + +/-- Componentwise negation. -/ +instance {V W : SuperVect} : Neg (V ⟶ W) := + ⟨fun f => ⟨-f.evenMap, -f.oddMap⟩⟩ + +/-- Componentwise subtraction. -/ +instance {V W : SuperVect} : Sub (V ⟶ W) := + ⟨fun f g => ⟨f.evenMap - g.evenMap, f.oddMap - g.oddMap⟩⟩ + +/-- Componentwise scaling by a complex number. -/ +instance {V W : SuperVect} : SMul ℂ (V ⟶ W) := + ⟨fun c f => ⟨c • f.evenMap, c • f.oddMap⟩⟩ + +/-- Componentwise natural scaling, given definitionally so that the +`AddCommGroup` structure below has no transported `nsmul` field. -/ +instance {V W : SuperVect} : SMul ℕ (V ⟶ W) := + ⟨fun n f => ⟨n • f.evenMap, n • f.oddMap⟩⟩ + +/-- Componentwise integer scaling, likewise definitional. -/ +instance {V W : SuperVect} : SMul ℤ (V ⟶ W) := + ⟨fun n f => ⟨n • f.evenMap, n • f.oddMap⟩⟩ + +/-- The components of a morphism determine it; the additive and +module structures are pulled back componentwise. -/ +def homComponents {V W : SuperVect} (f : V ⟶ W) : + (V.even →ₗ[ℂ] W.even) × (V.odd →ₗ[ℂ] W.odd) := + (f.evenMap, f.oddMap) + +/-- Componentwise equality of morphisms. -/ +theorem homComponents_injective {V W : SuperVect} : + Function.Injective (homComponents (V := V) (W := W)) := + fun _ _ h => Hom.ext (congrArg Prod.fst h) (congrArg Prod.snd h) + +/-- Morphisms form an abelian group, pulled back along the injection +into the pair of component maps. -/ +instance {V W : SuperVect} : AddCommGroup (V ⟶ W) := + homComponents_injective.addCommGroup homComponents + rfl (fun _ _ => rfl) (fun _ => rfl) (fun _ _ => rfl) + (fun _ _ => rfl) (fun _ _ => rfl) + +/-- Morphisms form a ℂ-module, pulled back the same way: SuperVect +is ℂ-linear. -/ +instance {V W : SuperVect} : Module ℂ (V ⟶ W) := + homComponents_injective.module ℂ + { toFun := homComponents + map_zero' := rfl + map_add' := fun _ _ => rfl } + (fun _ _ => rfl) + +/-- Addition of morphisms is componentwise on the even part. -/ +@[simp] +theorem add_evenMap {V W : SuperVect} (f g : V ⟶ W) : + (f + g).evenMap = f.evenMap + g.evenMap := rfl + +/-- Addition of morphisms is componentwise on the odd part. -/ +@[simp] +theorem add_oddMap {V W : SuperVect} (f g : V ⟶ W) : + (f + g).oddMap = f.oddMap + g.oddMap := rfl + +/-- The zero morphism's even component is zero. -/ +@[simp] +theorem zero_evenMap {V W : SuperVect} : + (0 : V ⟶ W).evenMap = 0 := rfl + +/-- The zero morphism's odd component is zero. -/ +@[simp] +theorem zero_oddMap {V W : SuperVect} : + (0 : V ⟶ W).oddMap = 0 := rfl + +/-- Scalar multiplication is componentwise on the even part. -/ +@[simp] +theorem smul_evenMap {V W : SuperVect} (c : ℂ) (f : V ⟶ W) : + (c • f).evenMap = c • f.evenMap := rfl + +/-- Scalar multiplication is componentwise on the odd part. -/ +@[simp] +theorem smul_oddMap {V W : SuperVect} (c : ℂ) (f : V ⟶ W) : + (c • f).oddMap = c • f.oddMap := rfl + +/-- SuperVect is preadditive: composition is bilinear +componentwise. -/ +instance instPreadditive : Preadditive SuperVect where + add_comp _ _ _ f f' g := by + apply Hom.ext + · change g.evenMap ∘ₗ (f.evenMap + f'.evenMap) = _ + exact LinearMap.comp_add _ _ _ + · change g.oddMap ∘ₗ (f.oddMap + f'.oddMap) = _ + exact LinearMap.comp_add _ _ _ + comp_add _ _ _ f g g' := by + apply Hom.ext + · change (g.evenMap + g'.evenMap) ∘ₗ f.evenMap = _ + exact LinearMap.add_comp _ _ _ + · change (g.oddMap + g'.oddMap) ∘ₗ f.oddMap = _ + exact LinearMap.add_comp _ _ _ + +/-- SuperVect is ℂ-linear: composition is ℂ-bilinear +componentwise. -/ +instance instLinear : CategoryTheory.Linear ℂ SuperVect where + smul_comp _ _ _ c f g := by + apply Hom.ext + · change g.evenMap ∘ₗ (c • f.evenMap) = _ + exact LinearMap.comp_smul _ _ _ + · change g.oddMap ∘ₗ (c • f.oddMap) = _ + exact LinearMap.comp_smul _ _ _ + comp_smul _ _ _ f c g := by + apply Hom.ext + · change (c • g.evenMap) ∘ₗ f.evenMap = _ + exact LinearMap.smul_comp _ _ _ + · change (c • g.oddMap) ∘ₗ f.oddMap = _ + exact LinearMap.smul_comp _ _ _ + +end SuperVect + +end + +/-! ## 10. The vocabulary of Deligne's hypotheses + +Subquotients and bounded composition length, scalar unit endomorphisms, +iterated and mixed tensor powers, finite ⊗-generation, and moderate growth: +exactly the predicates in which the hypothesis list of Théorème 0.6 is +phrased. (Their theory continues in `RS/Classical/CatTheory/`.) -/ + +section + +open CategoryTheory CategoryTheory.Limits MonoidalCategory + +universe v u + +section + +variable {C : Type u} + +/-- **`Y` is a subquotient of `Z`**: a quotient of a subobject of +`Z`. This is the relation Deligne's tensor-generation hypothesis is +stated with. -/ +def IsSubquotientOf [Category.{v} C] + (Y Z : C) : Prop := + ∃ (S : C) (i : S ⟶ Z) (p : S ⟶ Y), Mono i ∧ Epi p + +/-- A retract is in particular a subquotient: a splitting makes the +inclusion a mono, and the object is a quotient of itself. -/ +theorem isSubquotientOf_of_retract [Category.{v} C] + {Y Z : C} (i : Y ⟶ Z) (r : Z ⟶ Y) + (h : i ≫ r = 𝟙 Y) : IsSubquotientOf Y Z := by + have : IsSplitMono i := ⟨⟨r, h⟩⟩ + exact ⟨Y, i, 𝟙 Y, inferInstance, inferInstance⟩ + +/-- `LengthLE Y k` states that the subobject order of `Y` contains +no strictly increasing chain of `k + 2` subobjects; equivalently, +every chain `0 = Y₀ < ⋯ < Y_ℓ = Y` has `ℓ ≤ k`, so the composition +length of `Y` is at most `k`. -/ +def LengthLE [Category.{v} C] + (Y : C) (k : ℕ) : Prop := + ∀ f : Fin (k + 2) → Subobject Y, ¬ StrictMono f + +end + +section + +variable (A : Type u) + +/-- The unit's endomorphisms are the scalars. -/ +def HasScalarUnit [Category.{v} A] + [Preadditive A] [Linear ℂ A] [MonoidalCategory A] : Prop := + Function.Bijective + (fun c : ℂ => (c • 𝟙 (𝟙_ A) : 𝟙_ A ⟶ 𝟙_ A)) + +end + +section + +variable (A : Type u) + +/-- Iterated tensor power of an object. -/ +def tensorPow [Category.{v} A] [MonoidalCategory A] + (X : A) : ℕ → A + | 0 => 𝟙_ A + | n + 1 => tensorObj (tensorPow X n) X + +/-- A mixed tensor power of `X`: `X ^ ⊗ a ⊗ (Xᘁ) ^ ⊗ b`. -/ +def mixedPow [Category.{v} A] [MonoidalCategory A] + [RigidCategory A] (X : A) (a b : ℕ) : A := + tensorPow A X a ⊗ tensorPow A (Xᘁ) b + +/-- **Finite tensor generation**, in the sense of Deligne's +hypothesis: every object is a subquotient of a finite biproduct of +mixed tensor powers of `X` — a quotient of a subobject of such a +biproduct. -/ +def TensorGeneratedBy [Category.{v} A] [MonoidalCategory A] + [Preadditive A] [HasFiniteBiproducts A] [RigidCategory A] (X : A) : Prop := + ∀ Y : A, ∃ (k : ℕ) (ab : Fin k → ℕ × ℕ), + IsSubquotientOf Y (⨁ fun t => mixedPow A X (ab t).1 (ab t).2) + +/-- Every object has moderate tensor-power growth, measured by +composition length. -/ +def ModerateLengthGrowth [Category.{v} A] [MonoidalCategory A] : Prop := + ∀ Y : A, ∃ C c : ℕ, ∀ N : ℕ, LengthLE (tensorPow A Y N) (C * c ^ N) + +end + +end + +/-! ## 11. Deligne's theorem + +The correspondence with the published hypotheses, item by item: essentially +small — `[EssentiallySmall.{v} A]`; abelian ℂ-linear with ℂ-bilinear tensor — +`[Abelian A]`, `[Linear ℂ A]`, `[MonoidalPreadditive A]`, `[MonoidalLinear ℂ +A]`; rigid symmetric monoidal — `[MonoidalCategory A]`, `[SymmetricCategory +A]`, `[RigidCategory A]`; `End 𝟙 = ℂ` — `HasScalarUnit A`; finitely +⊗-generated — `∃ X, TensorGeneratedBy A X`; moderate growth — +`ModerateLengthGrowth A`. Exactness of the tensor product needs no separate +hypothesis (rigidity makes `X ⊗ −` a two-sided adjoint), and +`[HasFiniteBiproducts A]` is implied by `[Abelian A]`, named only so the +generation predicate can be stated. The conclusion is taken in fibre-functor +form — weaker than Deligne's ⊗-equivalence with the representations of an +affine supergroup scheme, which yields the functor by composing with the +forgetful functor. + +Reference: Pierre Deligne, *Catégories tensorielles*, Moscow Math. J. **2** +(2002), 227–248, Théorème 0.6 (with §0.1 for the definitions); see also Victor +Ostrik, *Tensor categories (after P. Deligne)*, arXiv:math/0401347, Thm 2.3. +-/ + +section + +open CategoryTheory CategoryTheory.Limits MonoidalCategory + +universe u v + +/-- The conclusion of Deligne's theorem for a candidate tensor +category: an exact faithful ℂ-linear symmetric monoidal functor into +super vector spaces. This extends the consumed interface +(`DelignePackage`) by the conclusions the development does not use: +faithfulness, and exactness in the form of preservation of finite +limits and finite colimits. -/ +structure DeligneFibreFunctor (A : Type*) [Category A] + [MonoidalCategory A] [SymmetricCategory A] [Preadditive A] + [Linear ℂ A] where + /-- The fibre functor. -/ + ω : A ⥤ SuperVect + /-- The fibre functor is symmetric monoidal. -/ + braided : ω.Braided + /-- The fibre functor is additive. -/ + additive : ω.Additive + /-- The fibre functor is ℂ-linear. -/ + linear : ω.Linear ℂ + /-- The fibre functor is faithful. -/ + faithful : ω.Faithful + /-- The fibre functor preserves finite limits: the left half of + exactness. -/ + preservesFiniteLimits : PreservesFiniteLimits ω + /-- The fibre functor preserves finite colimits: the right half of + exactness. -/ + preservesFiniteColimits : PreservesFiniteColimits ω + +/-- **Deligne's theorem** (Catégories tensorielles, Théorème 0.6): +every essentially small abelian ℂ-linear rigid symmetric monoidal +category with ℂ-bilinear tensor product, scalar unit endomorphisms, +a finite tensor generator and moderate growth of the lengths of its +tensor powers admits an exact faithful ℂ-linear symmetric monoidal +fibre functor to finite-dimensional super vector spaces. -/ +def DeligneTheoremStatement : Prop := + ∀ (A : Type u) [Category.{v} A] [Abelian A] [Linear ℂ A] + [MonoidalCategory A] [SymmetricCategory A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] + [HasFiniteBiproducts A] [RigidCategory A] + [EssentiallySmall.{v} A], + HasScalarUnit A → + (∃ X : A, TensorGeneratedBy A X) → + ModerateLengthGrowth A → + Nonempty (DeligneFibreFunctor A) + +end + +end RS diff --git a/LeanPool/RegtsSevenster/RS/DimensionDefinitions.lean b/LeanPool/RegtsSevenster/RS/DimensionDefinitions.lean new file mode 100644 index 0000000000..fcf08ced8f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/DimensionDefinitions.lean @@ -0,0 +1,55 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Definitions + +/-! +# Connection ranks and minimum colour dimension + +The natural-valued connection rank is the dimension of the actual +connection-map range. Under an edge-rank bound this range is finite, +so its natural dimension agrees with its module rank. The minimum +colour dimension is the least total colour bound of a representing +mixed model; it is zero when no representing model exists. +-/ + +@[expose] public section + +namespace RS + +/-- The closed fragment of `c` free circles. -/ +noncomputable def circlesClosed (c : ℕ) : ClosedFragment := + (Fragment.circlesOnly c).relabel + (_root_.Equiv.equivOfIsEmpty Empty (Fin 0)) + +/-- The natural dimension of the connection-map range. It agrees +with connection rank whenever the range is finite-dimensional. -/ +noncomputable def connectionRank (f : ClosedFragment → ℂ) (t : ℕ) : ℕ := + Module.finrank ℂ (LinearMap.range (connectionMap f t)) + +/-- A mixed functional represents the parameter on every closed +fragment, including those with free circles. -/ +def MixedFunctional.Represents {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (f : ClosedFragment → ℂ) : Prop := + ∀ W, f W = mixedPartition h W + +/-- The least total colour bound among representing mixed models, +with value zero when the set of such bounds is empty. -/ +noncomputable def minimumColourDimension (f : ClosedFragment → ℂ) : ℕ := + sInf {d | IsMixedPartitionFunctionTotalBounded f d} + +/-- The rank and free-circle conditions for prescribed even and +odd colour dimensions. -/ +structure PrescribedColourBounds (f : ClosedFragment → ℂ) + (k ℓ : ℕ) : Prop where + /-- The free-circle value is the prescribed superdimension. -/ + circle_eq : f (circlesClosed 1) = (k : ℂ) - 2 * ℓ + /-- Every connection rank is bounded by the total colour count. -/ + rank_bounded : EdgeRankBounded f (k + 2 * ℓ) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Glossary.lean b/LeanPool/RegtsSevenster/RS/Glossary.lean new file mode 100644 index 0000000000..1dcd525567 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Glossary.lean @@ -0,0 +1,218 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Glossary + +Recurring vocabulary of the development, for auditors. + +* **Fragment** — a finite multigraph in half-edge (flag) form over + a boundary-label type, with a fixed-point-free edge involution + (`pairing`), a distinguished flag at each boundary label + (`boundaryFlag`), and a separate free-circle count. +* **Closed fragment** — a fragment over `Fin 0`: a plain + multigraph with free circles. +* **Gluing** (`gluePair`) — joining the half-edges at two boundary + labels: the closing case makes a free circle, the rewiring case + unifies two edges end to end. +* **Composition** (`Fragment.compose`) — gluing the last `t` + labels of an `(s + t)`-fragment to the first `t` of a + `(t + u)`-fragment, top pair first. +* **Strand bundle** (`strandBundle t`) — `t` parallel edges, the + identity fragments. +* **Edge subset** (`EdgeSubset`) — a pairing-closed set of flags; + **Eulerian** when every vertex meets it in an even number of + flags. +* **Transition system** (`TransitionSystem`) — the local pairing + `κ` of Definition 5: a fixed-point-free vertex-preserving + involution of the participating flags. Its **walk permutation** + composes `κ` with the edge pairing; each geometric circuit + carries two walk-orbits (its directions), whence the **circuit + count**. +* **Mixed functional** (`MixedFunctional`) — the `(k, 2ℓ)` vertex + data of a mixed partition function: values on multisets of even + colours and sets of odd colours, with antisymmetry supplied by + the sorting-sign evaluator (`evalOdd`). +* **Mixed partition function** (`mixedPartition`, + `IsMixedPartitionFunction`) — Definition 5 on the flag model: + the sum over Eulerian edge subsets of circuit-signed colouring + sums against a `(k, 2ℓ)` vertex functional, with the + `(k − 2ℓ)^{circles}` free-circle convention. The bounded form + (`IsMixedPartitionFunctionBounded`) additionally pins `k` and + `2ℓ` below a stated bound. +* **Total bound** (`TotalBoundedMixedModel`, + `IsMixedPartitionFunctionTotalBounded`) — a representing functional + whose total number of colours `k + 2ℓ` is bounded. The witness has + named dimension, functional and evaluation fields; + `regts_sevenster_total` gives total bound `R` from edge-rank base `R`. +* **Minimum colour dimension** (`minimumColourDimension`) — the + least total colour bound of a representing mixed model. It is + attained and equals the even connection-rank growth rate. +* **Natural connection rank** (`connectionRank`) — the finrank of + the actual connection-map range. Under an edge-rank bound its + cardinal cast equals the module rank (`connectionRank_cast_eq_rank`). +* **Prescribed colour bounds** (`PrescribedColourBounds`) — the + rank bound with base `k + 2ℓ` and free-circle value `k − 2ℓ`. + `regts_sevenster_prescribed` characterizes models of exactly those + parity dimensions, including the zero-dimensional case. +* **Colour embedding** (`MixedColourEmbedding`) — embeddings of + even and odd colours preserving odd order, symplectic partners + and partner signs. `extendColours` extends a vertex functional by + zero; `padColours` uses the embeddings supplied by dimension + inequalities. Balanced padding preserves the partition function. +* **Total space** (`Tot`, `tot`, `totIso`) — the product of the even + and odd components of a super vector space, its componentwise maps + and its induced linear equivalences. `colourTotalEquiv` identifies + a total tensor power with functions on all colour words. +* **Monomial word action** (`MonomialWordAction`) — a permutation of + positions acting on word coordinates with nonzero scalar weights. + Its commutant consists of the intertwining endomorphisms; the + letter-pair counts give `finrank_commutant_le_word_counts`. +* **Connection pairing / edge rank** — the closure pairing of a + parameter at arity `t`. `EdgeRankBounded f R` says every arity's + pairing has rank at most `R ^ t`, rank being the dimension of the + row span; the literature's reading — the supremum of the ranks of + the finite submatrices of the connection matrix — is the same + condition (`SubmatrixRankBounded`, + `edgeRankBounded_iff_submatrixRank`). The hypothesis class + (`EdgeRankParameter`) packages the bound with normalization at + the empty graph and isomorphism invariance. +* **Relative transition system** (`RelTransitionSystem`) — the + open-fragment analogue: an involution of the *internal* + participating flags; boundary flags start **boundary chains**, + whose end-to-end matching is the **path matching** (`pathMatch`) + and whose label pairs form the **chord diagram** + (`labelChords`, a faithful pairing invariant). +* **Chord sign / path sign** (`pathSign`) — `(−1)` to the number + of interleaving chord pairs of the boundary pairing; a function + of the diagram alone. +* **Canonical frame** (`PathCanonical`) — the orientation class + directing every boundary chain low-label-to-high; the **chain + direction observable** (`chainDir`) equals high-status on it, + and any orientation re-canonicalizes by whole-chain flips + (`exists_recanonicalize`) at the cost of symplectic signs and + odd-partner state relabels (`stateOddFlipSet`). +* **Repair** (`repair`) — the elementary 2-opt re-pairing move; + non-localized repairs transpose the boundary pairing + (`pathMatch_repair_swap`), and the pairing fibre is connected by + π-returning blocks (`pairingConnectivity`). +* **The pairing-fibre ledger** (`pairedLedger`) — open-sector + Proposition 3: across every π-returning repair block the + `pathSign`-weighted canonical summand is preserved, so the + signed canonical value (`signedValueAt`) depends on the boundary + pairing alone. Independence *across* pairings is false + (`not_throughIndependenceC`), which is why the value is + pairing-resolved. +* **The diagram gluing** (`glueChords`) — the Temperley–Lieb + concatenation of a label chord diagram at a cut, whose crossing + parity change is `diagCrossCount_glue_cross`: the chord-sign + ratio the participating-cut splitting carries. +* **The interface lift** (`liftData`, `pushData`, `bitsOf`) — a + family of transition data carried up the gluing interface one + cut at a time and back down again. A closing cut leaves the + lift a free bit, since a glued subset has two lifts; read with + the bits a subset itself determines (`bitsOf`), the round trip + returns the family up to matching equality. +* **The pair family** (`pairFamily`) — a datum at every subset of + the composition's base carrying RS21's (13) and (14) at once: + the pair term as the composition's signed colouring sum, the + pairing flipping along every interface edge, and the alternation + across every interface pair that step 1 asks for. +* **The in-set at a vertex** (`relInSetAt`) — the participating + flags attached to a vertex and marked incoming by a relative + orientation, of which `relInFlagsAt` is the sorted enumeration. + Each carries an **incoming sign** (`inSign`); flipping the + colours on a set negates the sign exactly there, which makes the + flip analysis a product of independent local factors. +* **The cut factor** (`cutFactor`) — the free circles a subset's + own closing cuts contribute: `k` where the subset leaves a + closing cut's edge out and `−2ℓ` where it carries it, the two + sectors of the circle the glue creates + (`edgeTermAt_pushData_colourSum`). +* **Tensor power** (`tensorPow A X n`) — `X ^ ⊗ n`, bracketed to + the left, so that `X ^ ⊗ (n + 1)` is `X ^ ⊗ n ⊗ X` definitionally + and the recursions below step one factor at a time. +* **The permutation action** (`swapTop`, `insertTop`, `permMor`, + `permAlg`) — `swapTop` braids the last two factors, `insertTop` + bubbles the top factor down, `permMor` routes each factor to the + slot its permutation names, and `permAlg` is the resulting + representation of the symmetric-group algebra. +* **The tensor power of an endomorphism** (`powHom X g n`) — `g` + acting on every factor. +* **Cycle-trace tower** (`CycleTraceTower`) — permutation + representations and tensor-power traces satisfying the cycle + formula. This is the common input to the categorical and strand + forms of the factorial obstruction. +* **Single power trace** (`SinglePowerTrace`) — an element with + nonzero trace whose powers of degree at least two have zero trace. + A nilpotent with nonzero trace has a positive power of this form; + its tensor traces separate all permutations, forcing dimension + at least `n!` at each finite-dimensional level. +* **Categorical trace** (`catTrace`, `catDim`, `ptr`) — close a + strand into a loop through the pairing of an object with its dual; + `catDim` is the trace of the identity, and `ptr` closes the last + factor only, leaving the rest open. +* **Karoubi underlying maps** (`karoubiHomAddHom`, + `karoubiHomLinearMap`) — the additive and linear maps sending a + corner morphism to its ambient morphism. `karoubiLinear` supplies + the shared complex linear structure on every Karoubi completion. +* **Trace criterion** (`isSemisimpleRing_of_trace`, + `karoubiEnd_isSemisimpleRing_of_trace`) — a nondegenerate trace + killing nilpotents forces semisimplicity; cyclicity restricts this + criterion to a Karoubi corner. `isNilpotent_map_of_mul_zero` and + `karoubiEnd_isNilpotent` transport nilpotence into the ambient ring. +* **Intertwining** (`intertwine_add`, `intertwine_smul`) — addition + and scalar multiplication preserve an intertwining equation in a + linear category. +* **Central idempotent expansion** (`eq_sum_shape_e_of_mem_span`) — + an element in the central span has an expansion in the shape + idempotents. This supplies both completeness and character splitting. +* **Pair lists** (`edgePairList`, `orientedPairList`) — the endpoint + pairs of the pendant edges, with membership and no-repetition facts + shared by the sorting-sign and regrouping arguments in + `Novel/Coordinates/PairList`. `Common/ListPairs` supplies generic + flattened-pair indexing; `Common/FinSlots` separates the two slots + of a finite sum. `sortSign_sq` is the common sorting-sign identity. +* **The block splitting** (`splitPow`, `blockSum`) — the + reassociation `X ^ ⊗ (p + q) ≅ X ^ ⊗ p ⊗ X ^ ⊗ q` and the + permutation acting on the two blocks independently. +* **Bounded length** (`LengthLE Y k`) — the subobject order of `Y` + has no strictly increasing chain of `k + 2` terms; equivalently + the composition length of `Y` is at most `k`. +* **The odd line** (`OddLine`) — an object squaring to the unit + whose self-braiding is `−1`; `L.mix p q` is the biproduct of `p` + copies of the unit and `q` of the line. +* **The free module and the fibre** (`freeMod`, `fibreFun`, + `gammaAlgebra`) — base change along an algebra object of the + ind-completion, and the pair `(Hom(𝟙, −), Hom(L, −))` on it, + which is the super algebra of scalars and the fibre functor over + it. +* **Splitting** (`IsSplit`, `SplitsOn`) — an object is split by an + algebra when its free module is a mixed sum; `SplitsOn` says every + object in the image of a functor is. +* **Ideals of an algebra object** (`IsIdeal`) — a subobject + absorbing multiplication; an algebra is simple when it has no + others than the two trivial ones. +* **Countably presented** (`CountablyPresented`) — a countable + filtered colimit of embedded objects; the property that bounds the + dimension of the scalars. +* **Statements named as inputs** — `DeligneTheoremStatement` + (Deligne 2002, Théorème 0.6, carrying Deligne's own hypotheses: + essentially small, abelian, ℂ-linear, rigid symmetric, + `End 𝟙 = ℂ`, finitely ⊗-generated, of moderate length growth), of + which the conclusion is taken in fibre-functor form + (`DeligneFibreFunctor`) rather than as the ⊗-equivalence with the + representations of a supergroup, and of that functor only the + symmetric monoidal ℂ-linear part is consumed, as + `DelignePackage`. It is a theorem of this tree + (`deligne_theorem`), as are `SchurPackage` (`schurPackage`) and + `EulerianIndependence` (`eulerianIndependence`); nothing is + assumed. +-/ diff --git a/LeanPool/RegtsSevenster/RS/Novel.lean b/LeanPool/RegtsSevenster/RS/Novel.lean new file mode 100644 index 0000000000..02abea341f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel.lean @@ -0,0 +1,341 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairList +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjSwapBmc +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjacentWord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisCoord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisSplit +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaData +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiag +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiagForm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaFlip +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockAlign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockCanon +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockData +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockOddList +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockParity +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockRestrict +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSigma +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSort +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BraidWord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonColour +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapClosed +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapExpansion +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapFun +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapMatch +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeel +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeelSplit +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapSplit +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapVal +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ChainLists +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleModel +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleScalar +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircuitCount +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ClosedTransition +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ConcatSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordInterface +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordOf +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoreParity +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EdgeSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvForm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvFormOdd +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvLeaf +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FibreParam +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FlagEnum +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.GlobalSlotList +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.HRS +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.IndexPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ListSignPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MasterSum +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelCoord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelPermCoord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelStarVec +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MultiStar +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFDef +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFValue +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddFlip +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddListMultiset +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddPair +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddSignProd +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaCotensor +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaStarVec +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTensor +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTransport +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OneBasis +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OrbitCard +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OutSignEdges +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairEnum +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ParameterModel +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PatternInv +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PowMerge +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RegroupSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.Reindex +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexHeart +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexVanish +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RepFlag +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RiffleSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SignPair +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SkeinPowBraid +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SlotPairing +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortFactor +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarClassFactor +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPeel +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarRepeat +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarSymm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarTensorClass +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StdTransport +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StrandTransport +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauCount +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauKey +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TopBraidMerge +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TwoBasis +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexValue +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.AtomDichotomy +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.AtomicIdempotents +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockAssembly +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockBounds +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockCycle +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactor +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactorialTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockSplice +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockTower +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleNormal +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvAbelian +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDeligne +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDelignePackage +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGenerator +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGrowth +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvInstances +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvSemisimple +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.FactorialTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.Frobenius +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinement +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinementSharp +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiEmbBraided +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiMonoidal +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiRigid +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiSemisimple +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatBraided +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatEmbMonoidal +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatMonoidal +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatRigid +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatSemisimple +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentMatTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.ObjectTower +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.PermTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarPermTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleAll +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleEnd +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinDimBound +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SuperKill +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPerm +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPermCast +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowHom +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowSplit +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZeta +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZetaSharp +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.CircleValue +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.CoordIso +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.Coordinates +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.CopairUnique +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.Nondegenerate +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.SnakeTransport +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdDuality +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdRigid +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdSuper +public import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalAgreement +public import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalIndependence +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedNat +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleClose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleMapClasses +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleTensor +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonExistence +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonTransport +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonicalFrame +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChainAgreement +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordCount +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordLabels +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordParity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordSwapParity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotateLeft +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseUnion +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedAgreement +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedCutDispatch +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedIdentify +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedTopSum +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourGlue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourRecursion +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeNormal +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeRelabel +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Composition +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseAssembly +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseDischarge +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseFamily +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseGram +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseIdentity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseLift +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConversePair +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseTrip +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CrossingDelta +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CutMatching +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CutSubsetSum +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DirMatching +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjSubsetSplit +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.A +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.B +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.C +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionProduct +public import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeColouring +public import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeSum +public import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeTerm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Eulerian +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ExactPairingInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FibreValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FlagGraph +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignForm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignProduct +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FourLabelParity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FragmentEquiv +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GenBoundaryStates +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueAmbient +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChord +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChords +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCircuitDelta +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueComm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCrossDelta +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueFold +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueLedger +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GluePathMatch +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueRelTransport +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplit +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof.A +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof.C +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSubsetBij +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GramRank +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomCompose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomSpaces +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTensor +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceCyclic +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceNondegenerate +public import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLaw +public import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLawRight +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceAlternate +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceContract +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceCut +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceOrderIso +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceShift +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InvolutionCard +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LabelChords +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerCast +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerRecursion +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerSets +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerStage +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopExample +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopVerify +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalNat +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalStruct +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Multiplicativity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.NonSeparatedStep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.OpenCircuits +public import LeanPool.RegtsSevenster.RS.Novel.Skein.OrbitParities +public import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientExistence +public import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientationFlip +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairCloseComm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairedAssembly +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingConnectivity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSignature +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSwap +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialClose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseCompose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseTensor +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathCanon +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathMatch +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PermCompose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PermFragment +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PropThreeOpen +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RSTensor +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelTransition +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelChords +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelInvariance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RepairInvariance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidityClasses +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarClass +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarFunctional +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SeparatedParity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SimpleUnit +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCategory +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdealLeft +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinLinear +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SnakeClasses +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarCompClass +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarDecomposition +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarEnum +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarExplode +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarPrep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarTrace +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StateFlipSet +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StatusSet +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepFrame +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepLedger +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatus +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatusNonsep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StrandBundle +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SumLexOrder +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperGram +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperSpace +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorAssoc +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorComm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorCompClass +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorIdeal +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorInterchange +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorUnit +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughEdgeCut +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughIndCFalse +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Trace +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceNondegenerate +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionMove +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransposeLedger +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathNonSep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathStep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexOddSign +public import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexSum +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourEmbedding +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourPadding +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.RankDimension diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjSwapBmc.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjSwapBmc.lean new file mode 100644 index 0000000000..9b2b8d7f35 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjSwapBmc.lean @@ -0,0 +1,143 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SkeinPowBraid +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjacentWord + +/-! +# The skein braiding as a bundle map + +The skein-side adjacent braiding collapses to the bundle-map +class of the adjacent transposition: the whiskers are block sums +of label equivalences and the one-strand braiding is the +transpose, so the whole recursion lives in the bundle-map +calculus. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +/-- The adjacent swap as a label equivalence. -/ +def adjSwapEquiv (n i : ℕ) (h : i + 2 ≤ n) : Fin n ≃ Fin n := + _root_.Equiv.swap ⟨i, by omega⟩ ⟨i + 1, by omega⟩ + +/-- The value of a swap, on underlying values. -/ +theorem swap_val {m : ℕ} (a b x : Fin m) : + ((_root_.Equiv.swap a b) x).val = + if x.val = a.val then b.val + else if x.val = b.val then a.val else x.val := by + rw [_root_.Equiv.swap_apply_def] + by_cases h1 : x = a + · rw [ite_eq_left h1, ite_eq_left (by rw [h1])] + · rw [ite_eq_right h1, ite_eq_right (fun hv => h1 (Fin.ext hv))] + by_cases h2 : x = b + · rw [ite_eq_left h2, ite_eq_left (by rw [h2])] + · rw [ite_eq_right h2, ite_eq_right (fun hv => h2 (Fin.ext hv))] + +/-- The value of the adjacent swap. -/ +theorem adjSwapEquiv_val (n i : ℕ) (h : i + 2 ≤ n) + (x : Fin n) : + ((adjSwapEquiv n i h) x).val = + if x.val = i then i + 1 + else if x.val = i + 1 then i else x.val := + swap_val _ _ x + +/-- The top block sum is the adjacent swap. -/ +theorem tensorMapEquiv_top (n : ℕ) : + tensorMapEquiv (_root_.Equiv.refl (Fin n)) + (transposeEquiv 1 1) = + adjSwapEquiv (n + 2) n (by omega) := by + refine _root_.Equiv.ext (fun x => Fin.ext ?_) + rw [adjSwapEquiv_val] + rcases Nat.lt_or_ge x.val n with hx | hx + · conv_lhs => rw [show x = Fin.castAdd 2 ⟨x.val, hx⟩ from + Fin.ext rfl, tensorMapEquiv_castAdd] + change x.val = _ + rw [ite_eq_right (show ¬ (x.val = n) by omega), + ite_eq_right (show ¬ (x.val = n + 1) by omega)] + · have hx2 := x.isLt + rcases (show x.val = n ∨ x.val = n + 1 by omega) + with hv | hv + · conv_lhs => rw [show x = Fin.natAdd n ⟨0, by omega⟩ from + Fin.ext (by change x.val = n + 0; omega), + tensorMapEquiv_natAdd, + show transposeEquiv 1 1 ⟨0, by omega⟩ = + ⟨1 + 0, by omega⟩ from + transposeEquiv_low 1 1 0 (by omega) _ _] + change n + (1 + 0) = _ + rw [ite_eq_left hv] + · conv_lhs => rw [show x = Fin.natAdd n ⟨1, by omega⟩ from + Fin.ext (by change x.val = n + 1; omega), + tensorMapEquiv_natAdd, + show transposeEquiv 1 1 ⟨1, by omega⟩ = + ⟨0, by omega⟩ from by + rw [show (⟨1, by omega⟩ : Fin (1 + 1)) = + ⟨1 + 0, by omega⟩ from Fin.ext rfl] + exact transposeEquiv_high 1 1 0 (by omega) _ _] + change n + 0 = _ + rw [ite_eq_right (show ¬ (x.val = n) by omega), ite_eq_left hv] + omega + +/-- The whiskered block sum is the shifted adjacent swap. -/ +theorem tensorMapEquiv_whisker (n i : ℕ) (h : i + 2 ≤ n + 1) : + tensorMapEquiv (adjSwapEquiv (n + 1) i h) + (_root_.Equiv.refl (Fin 1)) = + adjSwapEquiv (n + 2) i (by omega) := by + refine _root_.Equiv.ext (fun x => Fin.ext ?_) + rw [adjSwapEquiv_val] + rcases Nat.lt_or_ge x.val (n + 1) with hx | hx + · conv_lhs => rw [show x = Fin.castAdd 1 ⟨x.val, hx⟩ from + Fin.ext rfl, tensorMapEquiv_castAdd] + change ((adjSwapEquiv (n + 1) i h) ⟨x.val, hx⟩).val = _ + rw [adjSwapEquiv_val] + · have hx2 := x.isLt + have hv : x.val = n + 1 := by omega + conv_lhs => rw [show x = Fin.natAdd (n + 1) ⟨0, by omega⟩ + from Fin.ext (by change x.val = n + 1 + 0; omega), + tensorMapEquiv_natAdd] + change n + 1 + 0 = _ + rw [ite_eq_right (show ¬ (x.val = i) by omega), + ite_eq_right (show ¬ (x.val = i + 1) by omega)] + omega + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- **The skein adjacent braiding is the adjacent-swap bundle +map.** -/ +theorem skeinPowBraid_bmc : + ∀ (n i : ℕ) (h : i + 2 ≤ n), + skeinPowBraid f n i h = + bundleMapClass f (adjSwapEquiv n i h) + | 0, _, h => absurd h (by omega) + | 1, _, h => absurd h (by omega) + | n + 2, i, h => by + by_cases hi : i = n + · rw [show skeinPowBraid f (n + 2) i h = + (SkeinObj.mk n : SkeinObj f) ◁ + (β_ (SkeinObj.mk 1 : SkeinObj f) + (SkeinObj.mk 1)).hom from dite_eq_left hi] + change HomSpace.tensor f n n 2 2 + (HomSpace.ofFragment f.val (strandBundle n)) + (bundleMapClass f (transposeEquiv 1 1)) = _ + rw [bundleMapClass_tensor_id_left, tensorMapEquiv_top] + exact bundleMapClass_congr f (by subst hi; rfl) + · have hle : i + 2 ≤ n + 1 := by omega + rw [show skeinPowBraid f (n + 2) i h = + (skeinPowBraid f (n + 1) i hle) ▷ SkeinObj.mk 1 from + dite_eq_right hi] + rw [skeinPowBraid_bmc (n + 1) i hle] + change HomSpace.tensor f (n + 1) (n + 1) 1 1 + (bundleMapClass f (adjSwapEquiv (n + 1) i hle)) + (HomSpace.ofFragment f.val (strandBundle 1)) = _ + rw [bundleMapClass_tensor_id_right, + tensorMapEquiv_whisker] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjacentWord.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjacentWord.lean new file mode 100644 index 0000000000..9d4d47ee9f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjacentWord.lean @@ -0,0 +1,192 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Adjacent-transposition words for permutations of `Fin n` + +Every permutation of `Fin n` is a product of adjacent transpositions. +We construct this factorisation explicitly as a list of positions +(an "adjacent-transposition word") and prove it correct. + +## Strategy + +We use mathlib's `Equiv.Perm.decomposeFin`, which decomposes +`σ : Perm (Fin (n+1))` into a pair `(p, σ')` with +`σ = swap 0 p * extPerm σ'` where `extPerm σ'` is the permutation +of `Fin (n+1)` that fixes `0` and acts as `σ'` on successors. + +We then express `swap 0 p` as adjacent transpositions by the +conjugation identity +`swap 0 (k+2) = swap 0 (k+1) * swap (k+1) (k+2) * swap 0 (k+1)`, +and lift the recursive word for `σ'` by mapping positions through `Fin.succ`. +-/ + +@[expose] public section + +namespace RS + +open Equiv + +/-- The adjacent transposition at position `i`: swaps `i` and `i + 1`. -/ +def adjTrans {n : ℕ} (i : Fin n) : Equiv.Perm (Fin (n + 1)) := + Equiv.swap i.castSucc i.succ + +/-- Permutations of `Fin 0` and `Fin 1` are trivial. -/ +theorem perm_fin_one (σ : Equiv.Perm (Fin 1)) : σ = 1 := + Subsingleton.elim σ 1 + +/-! ### The 0-fixing extension -/ + +/-- The 0-fixing extension of a permutation: sends `0 ↦ 0` and + `i.succ ↦ (σ i).succ`. -/ +private def extPerm {n : ℕ} (σ : Perm (Fin n)) : Perm (Fin (n + 1)) := + Perm.decomposeFin.symm (0, σ) + +private theorem extPerm_apply_zero {n : ℕ} (σ : Perm (Fin n)) : + extPerm σ 0 = 0 := + Perm.decomposeFin_symm_apply_zero 0 σ + +private theorem extPerm_apply_succ {n : ℕ} (σ : Perm (Fin n)) (x : Fin n) : + extPerm σ x.succ = (σ x).succ := by + simp [extPerm, Perm.decomposeFin_symm_apply_succ] + +private theorem extPerm_one {n : ℕ} : extPerm (1 : Perm (Fin n)) = 1 := by + ext x; refine Fin.cases ?_ (fun i => ?_) x + · simp [extPerm_apply_zero] + · simp [extPerm_apply_succ] + +private theorem extPerm_mul {n : ℕ} (σ τ : Perm (Fin n)) : + extPerm (σ * τ) = extPerm σ * extPerm τ := by + ext x; refine Fin.cases ?_ (fun i => ?_) x + · simp [extPerm_apply_zero, Perm.mul_apply] + · simp [extPerm_apply_succ, Perm.mul_apply] + +private theorem extPerm_adjTrans {n : ℕ} (i : Fin n) : + extPerm (adjTrans i) = adjTrans i.succ := by + ext x; refine Fin.cases ?_ (fun j => ?_) x + · -- x = 0: both sides map 0 to 0 since the swap is between i+1 and i+2 + simp only [extPerm_apply_zero, adjTrans, swap_apply_def, + Fin.ext_iff, Fin.val_zero, Fin.val_castSucc, Fin.val_succ, + apply_ite Fin.val] + split_ifs <;> omega + · -- x = j.succ: (adjTrans i j).succ = adjTrans i.succ j.succ + simp only [extPerm_apply_succ, adjTrans, swap_apply_def, + Fin.ext_iff, Fin.val_succ, Fin.val_castSucc, + apply_ite Fin.val] + split_ifs <;> omega + +/-! ### Adjacent-transposition word for `swap 0 p` -/ + +/-- Auxiliary: adjacent-transposition word for `swap 0 ⟨k, _⟩` in + `Perm (Fin (n+1))`. + Recursion on `k`: + - `k = 0`: identity, word = `[]` + - `k+1`: `swap0WordAux k ++ [k] ++ swap0WordAux k` + (conjugation: `swap 0 (k+1) = swap 0 k * swap k (k+1) * swap 0 k`) -/ +def swap0WordAux (n : ℕ) : (k : ℕ) → k ≤ n → List (Fin n) + | 0, _ => [] + | k + 1, hk => + let w := swap0WordAux n k (by omega) + w ++ [⟨k, by omega⟩] ++ w + +private theorem swap0WordAux_spec (n : ℕ) : + (k : ℕ) → (hk : k ≤ n) → + ((swap0WordAux n k hk).map adjTrans).prod = swap (0 : Fin (n + 1)) ⟨k, + by omega⟩ + | 0, _ => by + simp only [swap0WordAux, List.map_nil, List.prod_nil] + exact (swap_self _).symm + | k + 1, hk => by + unfold swap0WordAux + rw [List.map_append, List.map_append, List.prod_append, List.prod_append, + List.map_cons, List.map_nil, List.prod_cons, List.prod_nil, mul_one, + swap0WordAux_spec n k (by omega)] + -- Goal: swap 0 ⟨k,_⟩ * adjTrans ⟨k,_⟩ * swap 0 ⟨k,_⟩ = swap 0 ⟨k+1,_⟩ + -- Convert adjTrans to swap + have hadj : adjTrans (⟨k, by omega⟩ : Fin n) = + swap (⟨k, by omega⟩ : Fin (n + 1)) ⟨k + 1, by omega⟩ := by + ext ⟨_, _⟩ + simp only [adjTrans, swap_apply_def, Fin.ext_iff, Fin.val_castSucc, + Fin.val_succ, apply_ite Fin.val] + rw [hadj] + -- Now: swap 0 ⟨k,_⟩ * swap ⟨k,_⟩ ⟨k+1,_⟩ * swap 0 ⟨k,_⟩ = swap 0 ⟨k+1,_⟩ + -- Use the algebraic identity: swap y z * swap x y * swap y z = swap z x + -- with y = ⟨k,_⟩, z = 0, x = ⟨k+1,_⟩ + rw [swap_comm (0 : Fin (n + 1)) ⟨k, by omega⟩, + swap_comm (⟨k, by omega⟩ : Fin (n + 1)) ⟨k + 1, by omega⟩] + rw [swap_mul_swap_mul_swap + (show (⟨k + 1, by omega⟩ : Fin (n + 1)) ≠ ⟨k, by omega⟩ from by + simp [Fin.ext_iff]) + (show (⟨k + 1, by omega⟩ : Fin (n + 1)) ≠ 0 from by + simp [Fin.ext_iff]), + swap_comm] + +/-- Adjacent-transposition word for `swap 0 p`. -/ +def swap0Word {n : ℕ} (p : Fin (n + 1)) : List (Fin n) := + swap0WordAux n p.val (by omega) + +private theorem swap0Word_spec {n : ℕ} (p : Fin (n + 1)) : + ((swap0Word p).map adjTrans).prod = swap 0 p := + swap0WordAux_spec n p.val (by omega) + +/-! ### The factorisation -/ + +/-- The factorisation `σ = swap 0 p * extPerm σ'` from `decomposeFin`. -/ +private theorem decomposeFin_eq {n : ℕ} (σ : Perm (Fin (n + 1))) : + σ = swap 0 (Perm.decomposeFin σ).1 * extPerm (Perm.decomposeFin σ).2 := by + set p := (Perm.decomposeFin σ).1 + set σ' := (Perm.decomposeFin σ).2 + have hpair : Perm.decomposeFin σ = (p, σ') := rfl + have h := Perm.decomposeFin.symm_apply_apply σ + rw [hpair] at h + rw [← h] + ext x; refine Fin.cases ?_ (fun i => ?_) x + · simp [Perm.decomposeFin_symm_apply_zero, Perm.mul_apply, extPerm_apply_zero, + swap_apply_left] + · simp only [Perm.decomposeFin_symm_apply_succ, Perm.mul_apply, + extPerm_apply_succ] + +/-- Lifting a word through `Fin.succ` corresponds to extending each +transposition. -/ +private theorem map_succ_adjTrans_prod {n : ℕ} (w : List (Fin n)) : + ((w.map Fin.succ).map adjTrans).prod = extPerm ((w.map adjTrans).prod) := by + induction w with + | nil => simp [extPerm_one] + | cons i w ih => + simp only [List.map_cons, List.prod_cons] + rw [ih, extPerm_mul, extPerm_adjTrans] + +/-! ### The main construction -/ + +/-- An adjacent-transposition word for a permutation. -/ +noncomputable def adjWord {n : ℕ} (σ : Equiv.Perm (Fin (n + 1))) : + List (Fin n) := + match n, σ with + | 0, _ => [] + | _ + 1, σ => + let ⟨p, σ'⟩ := Perm.decomposeFin σ + swap0Word p ++ (adjWord σ').map Fin.succ + +/-- The word composes to the permutation. -/ +theorem adjWord_spec {n : ℕ} (σ : Equiv.Perm (Fin (n + 1))) : + ((adjWord σ).map adjTrans).prod = σ := by + match n, σ with + | 0, σ => + simp only [adjWord, List.map_nil, List.prod_nil] + exact (perm_fin_one σ).symm + | _ + 1, σ => + simp only [adjWord] + set p := (Perm.decomposeFin σ).1 + set σ' := (Perm.decomposeFin σ).2 + rw [List.map_append, List.prod_append, swap0Word_spec p, + map_succ_adjTrans_prod, adjWord_spec σ'] + exact (decomposeFin_eq σ).symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisCoord.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisCoord.lean new file mode 100644 index 0000000000..7b48d9f2c0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisCoord.lean @@ -0,0 +1,65 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordOf +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisSplit + +/-! +# Coordinates of basis vectors + +The coordinate of a colour basis vector is the equality +indicator: the coordinate calculus closes on basis input. +-/ + +@[expose] public section + +namespace RS + +variable {k ℓ : ℕ} + +/-- **The basis coordinate indicator.** -/ +theorem coordOf_evenBasisVec {n : ℕ} + (c : MixedColouring k ℓ n) (hc : c.IsEven) + (c' : MixedColouring k ℓ n) : + coordOf (evenBasisVec (⟨c, hc⟩ : + {c : MixedColouring k ℓ n // c.IsEven})) c' = + if c' = c then 1 else 0 := by + by_cases hc' : c'.IsEven + · rw [show coordOf (evenBasisVec (⟨c, hc⟩ : + {c : MixedColouring k ℓ n // c.IsEven})) c' = + (colourPowerEquiv k ℓ n).evenEquiv + (evenBasisVec ⟨c, hc⟩) ⟨c', hc'⟩ from by + unfold coordOf; rw [dite_eq_left hc']] + rw [show (colourPowerEquiv k ℓ n).evenEquiv + (evenBasisVec (⟨c, hc⟩ : + {c : MixedColouring k ℓ n // c.IsEven})) = + Pi.single ⟨c, hc⟩ 1 from + (colourPowerEquiv k ℓ n).evenEquiv.apply_symm_apply _] + by_cases he : c' = c + · subst he + rw [ite_eq_left rfl] + exact Pi.single_eq_same _ _ + · rw [ite_eq_right he] + exact Pi.single_eq_of_ne + (fun h => he (congrArg Subtype.val h)) _ + · rw [coordOf_odd _ _ hc'] + rw [ite_eq_right (fun he : c' = c => hc' (he ▸ hc))] + +/-- The arity-zero basis vector is the unit scalar. -/ +theorem evenBasisVec_zeroArity + (x : {c : MixedColouring k ℓ 0 // c.IsEven}) : + evenBasisVec x = (1 : ℂ) := by + apply (colourPowerEquiv k ℓ 0).evenEquiv.injective + rw [show (colourPowerEquiv k ℓ 0).evenEquiv + (evenBasisVec x) = Pi.single x 1 from + (colourPowerEquiv k ℓ 0).evenEquiv.apply_symm_apply _] + funext y + rw [Subsingleton.elim y x, Pi.single_eq_same] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisSplit.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisSplit.lean new file mode 100644 index 0000000000..4daa5052a6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisSplit.lean @@ -0,0 +1,195 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMergeOdd + +/-! +# Basis vectors split over the merge + +Coordinate basis vectors of a merged power decompose as merges +of half-basis pairs: even halves through the even pair, odd +halves through the odd pair. The coordinate product rules of +both parities identify the coordinates; injectivity does the +rest. +-/ + +@[expose] public section + +namespace RS + +open scoped TensorProduct + +variable {k ℓ : ℕ} + +/-- The even coordinate basis vector at a colouring. -/ +noncomputable def evenBasisVec {n : ℕ} + (c : {c : MixedColouring k ℓ n // c.IsEven}) : + (superPow (stdSuperPair k ℓ) n).even := + (colourPowerEquiv k ℓ n).evenEquiv.symm (Pi.single c 1) + +/-- The odd coordinate basis vector at a colouring. -/ +noncomputable def oddBasisVec {n : ℕ} + (c : {c : MixedColouring k ℓ n // ¬ c.IsEven}) : + (superPow (stdSuperPair k ℓ) n).odd := + (colourPowerEquiv k ℓ n).oddEquiv.symm (Pi.single c 1) + +/-- Colourings are determined by their halves. -/ +theorem MixedColouring.ext_halves {a b : ℕ} + {c₁ c₂ : MixedColouring k ℓ (a + b)} + (h1 : c₁.firstHalf = c₂.firstHalf) + (h2 : c₁.secondHalf = c₂.secondHalf) : c₁ = c₂ := + funext (fun i => Fin.addCases + (fun j => congrFun h1 j) (fun j => congrFun h2 j) i) + +-- The basis vector is expanded through the merge on +-- both halves, so the colouring equivalence at three arities enters +-- the elaborated term. +/-- **Basis vectors split over the merge.** -/ +theorem evenBasisVec_split {a b : ℕ} + (c : MixedColouring k ℓ (a + b)) (hc : c.IsEven) : + evenBasisVec (⟨c, hc⟩ : + {c : MixedColouring k ℓ (a + b) // c.IsEven}) = + if h : MixedColouring.IsEven c.firstHalf then + ((powMerge (stdSuperPair k ℓ) a b) : + SuperVect.Hom _ _).evenMap + (evenPair (evenBasisVec ⟨c.firstHalf, h⟩) + (evenBasisVec ⟨c.secondHalf, + c.secondHalf_isEven hc h⟩)) + else + ((powMerge (stdSuperPair k ℓ) a b) : + SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) b).even), + oddBasisVec ⟨c.firstHalf, h⟩ ⊗ₜ[ℂ] + oddBasisVec ⟨c.secondHalf, + c.secondHalf_not_isEven' hc h⟩) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).even) := by + apply (colourPowerEquiv k ℓ (a + b)).evenEquiv.injective + rw [show (colourPowerEquiv k ℓ (a + b)).evenEquiv + (evenBasisVec (⟨c, hc⟩ : + {c : MixedColouring k ℓ (a + b) // c.IsEven})) = + Pi.single ⟨c, hc⟩ 1 from + (colourPowerEquiv k ℓ (a + b)).evenEquiv.apply_symm_apply _] + funext ⟨c', hc'⟩ + -- ═══════ THE FIRST HALF'S PARITY ═══════ + -- An even first half puts both halves in the even blocks, an odd + -- one in the odd blocks; each is then checked coordinatewise. + by_cases h : MixedColouring.IsEven c.firstHalf + · rw [dite_eq_left h] + rw [show ((colourPowerEquiv k ℓ (a + b)).evenEquiv + (((powMerge (stdSuperPair k ℓ) a b) : + SuperVect.Hom _ _).evenMap + (evenPair (evenBasisVec ⟨c.firstHalf, h⟩) + (evenBasisVec ⟨c.secondHalf, + c.secondHalf_isEven hc h⟩)))) ⟨c', hc'⟩ = + (if h' : MixedColouring.IsEven c'.firstHalf then + (colourPowerEquiv k ℓ a).evenEquiv + (evenBasisVec ⟨c.firstHalf, h⟩) + ⟨c'.firstHalf, h'⟩ * + (colourPowerEquiv k ℓ b).evenEquiv + (evenBasisVec ⟨c.secondHalf, + c.secondHalf_isEven hc h⟩) + ⟨c'.secondHalf, c'.secondHalf_isEven hc' h'⟩ + else 0) from colourMerge_coord a b _ _ c' hc'] + by_cases h' : MixedColouring.IsEven c'.firstHalf + · rw [dite_eq_left h'] + rw [show (colourPowerEquiv k ℓ a).evenEquiv + (evenBasisVec ⟨c.firstHalf, h⟩) = + Pi.single ⟨c.firstHalf, h⟩ 1 from + (colourPowerEquiv k ℓ a).evenEquiv.apply_symm_apply _] + rw [show (colourPowerEquiv k ℓ b).evenEquiv + (evenBasisVec ⟨c.secondHalf, + c.secondHalf_isEven hc h⟩) = + Pi.single ⟨c.secondHalf, + c.secondHalf_isEven hc h⟩ 1 from + (colourPowerEquiv k ℓ b).evenEquiv.apply_symm_apply _] + by_cases he : c' = c + · subst he + rw [single_val_same ⟨c', hc⟩ ⟨c', hc'⟩ rfl, + single_val_same ⟨c'.firstHalf, h⟩ + ⟨c'.firstHalf, h'⟩ rfl, + single_val_same ⟨c'.secondHalf, + c'.secondHalf_isEven hc h⟩ + ⟨c'.secondHalf, c'.secondHalf_isEven hc' h'⟩ rfl] + norm_num + · rw [single_val_ne ⟨c, hc⟩ ⟨c', hc'⟩ he] + by_cases hf : c'.firstHalf = c.firstHalf + · have hs : c'.secondHalf ≠ c.secondHalf := fun hs2 => + he (MixedColouring.ext_halves hf hs2) + rw [single_val_ne ⟨c.secondHalf, + c.secondHalf_isEven hc h⟩ + ⟨c'.secondHalf, c'.secondHalf_isEven hc' h'⟩ hs] + rw [mul_zero] + · rw [single_val_ne ⟨c.firstHalf, h⟩ + ⟨c'.firstHalf, h'⟩ hf] + rw [zero_mul] + · rw [dite_eq_right h'] + have hne : c' ≠ c := fun he => h' (he ▸ h) + rw [single_val_ne ⟨c, hc⟩ ⟨c', hc'⟩ hne] + · rw [dite_eq_right h] + rw [show ((colourPowerEquiv k ℓ (a + b)).evenEquiv + (((powMerge (stdSuperPair k ℓ) a b) : + SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) a).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) b).even), + oddBasisVec ⟨c.firstHalf, h⟩ ⊗ₜ[ℂ] + oddBasisVec ⟨c.secondHalf, + c.secondHalf_not_isEven' hc h⟩) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b)).even))) ⟨c', hc'⟩ = + (if h' : MixedColouring.IsEven c'.firstHalf then 0 + else + (colourPowerEquiv k ℓ a).oddEquiv + (oddBasisVec ⟨c.firstHalf, h⟩) + ⟨c'.firstHalf, h'⟩ * + (colourPowerEquiv k ℓ b).oddEquiv + (oddBasisVec ⟨c.secondHalf, + c.secondHalf_not_isEven' hc h⟩) + ⟨c'.secondHalf, + c'.secondHalf_not_isEven' hc' h'⟩) from + colourMerge_coord_oddPair a b _ _ c' hc'] + by_cases h' : MixedColouring.IsEven c'.firstHalf + · rw [dite_eq_left h'] + have hne : c' ≠ c := fun he => h (he ▸ h') + rw [single_val_ne ⟨c, hc⟩ ⟨c', hc'⟩ hne] + · rw [dite_eq_right h'] + rw [show (colourPowerEquiv k ℓ a).oddEquiv + (oddBasisVec ⟨c.firstHalf, h⟩) = + Pi.single ⟨c.firstHalf, h⟩ 1 from + (colourPowerEquiv k ℓ a).oddEquiv.apply_symm_apply _] + rw [show (colourPowerEquiv k ℓ b).oddEquiv + (oddBasisVec ⟨c.secondHalf, + c.secondHalf_not_isEven' hc h⟩) = + Pi.single ⟨c.secondHalf, + c.secondHalf_not_isEven' hc h⟩ 1 from + (colourPowerEquiv k ℓ b).oddEquiv.apply_symm_apply _] + by_cases he : c' = c + · subst he + rw [single_val_same ⟨c', hc⟩ ⟨c', hc'⟩ rfl, + single_val_same ⟨c'.firstHalf, h⟩ + ⟨c'.firstHalf, h'⟩ rfl, + single_val_same ⟨c'.secondHalf, + c'.secondHalf_not_isEven' hc h⟩ + ⟨c'.secondHalf, + c'.secondHalf_not_isEven' hc' h'⟩ rfl] + norm_num + · rw [single_val_ne ⟨c, hc⟩ ⟨c', hc'⟩ he] + by_cases hf : c'.firstHalf = c.firstHalf + · have hs : c'.secondHalf ≠ c.secondHalf := fun hs2 => + he (MixedColouring.ext_halves hf hs2) + rw [single_val_ne ⟨c.secondHalf, + c.secondHalf_not_isEven' hc h⟩ + ⟨c'.secondHalf, + c'.secondHalf_not_isEven' hc' h'⟩ hs] + rw [mul_zero] + · rw [single_val_ne ⟨c.firstHalf, h⟩ + ⟨c'.firstHalf, h'⟩ hf] + rw [zero_mul] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaData.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaData.lean new file mode 100644 index 0000000000..ed7ffab7ac --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaData.lean @@ -0,0 +1,160 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij + +/-! +# The `β`-diagonal's colour data + +The colour-form entries at a partner slot, the colouring of a sum +index on either side, and the `β`-diagonal these produce. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {k ℓ : ℕ} + +/-- The colour form entry at an odd colour and its partner equals +minus the partner sign. -/ +theorem colourFormEntry_inr_partner (u : Fin (2 * ℓ)) : + colourFormEntry k ℓ (Sum.inr u) (Sum.inr (oddPartner ℓ u)) = + -(oddPartnerSign ℓ u : ℂ) := by + have hu := u.isLt + unfold oddPartner oddPartnerSign + by_cases h : u.val < ℓ + · rw [dite_eq_left h, ite_eq_left h] + change (if u.val + ℓ = u.val + ℓ then (1 : ℂ) + else if (u.val + ℓ) + ℓ = u.val then -1 else 0) = + -((-1 : ℤ) : ℂ) + rw [ite_eq_left rfl] + simp + · rw [dite_eq_right h, ite_eq_right h] + change (if u.val + ℓ = u.val - ℓ then (1 : ℂ) + else if (u.val - ℓ) + ℓ = u.val then -1 else 0) = + -((1 : ℤ) : ℂ) + have h1 : ¬ (u.val + ℓ = u.val - ℓ) := by omega + rw [ite_eq_right h1, ite_eq_left (by omega)] + simp + +/-- The data colouring at a castAdd slot gives the representative +colour (even or odd). -/ +theorem colouringOf_castAdd (W : ClosedFragment) (F : EdgeSubset W) + (ψ : F.EvenColouring k) (φ : F.OddColouring ℓ) (i : Fin (edgeCount W)) : + colouringOf W F ψ φ (Fin.castAdd (edgeCount W) i) = + (if h : (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i) ∈ F.flags then + Sum.inr (φ.val ⟨(starFlagEnum W).symm (Fin.castAdd (edgeCount W) i), h⟩) + else Sum.inl + (ψ.val ⟨(starFlagEnum W).symm (Fin.castAdd (edgeCount W) i), h⟩)) := by + have key : ∀ (slot : Fin (edgeCount W + edgeCount W)) + (hslot : slot.val < edgeCount W), + colouringOf W F ψ φ slot = + (if h : (starFlagEnum W).symm slot ∈ F.flags then + Sum.inr (φ.val ⟨(starFlagEnum W).symm slot, h⟩) + else Sum.inl (ψ.val ⟨(starFlagEnum W).symm slot, h⟩)) := by + intro slot hslot + rw [colouringOf] + by_cases h : (starFlagEnum W).symm slot ∈ F.flags + · rw [dite_eq_left h, dite_eq_left h, ite_eq_left hslot] + · rw [dite_eq_right h, dite_eq_right h] + exact key (Fin.castAdd (edgeCount W) i) i.isLt + +/-- The data colouring at a natAdd slot gives the partner colour +(even repeat or odd partner). -/ +theorem colouringOf_natAdd (W : ClosedFragment) (F : EdgeSubset W) + (ψ : F.EvenColouring k) (φ : F.OddColouring ℓ) (i : Fin (edgeCount W)) : + colouringOf W F ψ φ (Fin.natAdd (edgeCount W) i) = + (if h : (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i) ∈ F.flags then + Sum.inr (oddPartner ℓ (φ.val ⟨(starFlagEnum W).symm (Fin.castAdd + (edgeCount W) i), h⟩)) + else Sum.inl + (ψ.val ⟨(starFlagEnum W).symm (Fin.castAdd (edgeCount W) i), h⟩)) := by + have hpair : (starFlagEnum W).symm (Fin.natAdd (edgeCount W) i) = + W.pairing ((starFlagEnum W).symm (Fin.castAdd (edgeCount W) i)) := + (pairing_starFlagEnum_symm W i).symm + have key : ∀ (slot : Fin (edgeCount W + edgeCount W)) + (hslot : ¬ slot.val < edgeCount W), + colouringOf W F ψ φ slot = + (if h : (starFlagEnum W).symm slot ∈ F.flags then + Sum.inr (oddPartner ℓ (φ.val ⟨(starFlagEnum W).symm slot, h⟩)) + else Sum.inl (ψ.val ⟨(starFlagEnum W).symm slot, h⟩)) := by + intro slot hslot + rw [colouringOf] + by_cases h : (starFlagEnum W).symm slot ∈ F.flags + · rw [dite_eq_left h, dite_eq_left h, ite_eq_right hslot] + · rw [dite_eq_right h, dite_eq_right h] + rw [key (Fin.natAdd (edgeCount W) i) + (show ¬ (Fin.natAdd (edgeCount W) i).val < edgeCount W from by + change ¬ (edgeCount W + i.val < edgeCount W); omega)] + by_cases h : (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i) ∈ F.flags + · have h' : (starFlagEnum W).symm (Fin.natAdd (edgeCount W) i) ∈ F.flags := by + rw [hpair]; exact F.pairing_mem _ h + rw [dite_eq_left h', dite_eq_left h] + congr 1 + have harg : (⟨(starFlagEnum W).symm (Fin.natAdd (edgeCount W) i), h'⟩ : + {f : W.Flag // f ∈ F.flags}) = + ⟨W.pairing ((starFlagEnum W).symm (Fin.castAdd (edgeCount W) i)), + F.pairing_mem _ h⟩ := Subtype.ext hpair + exact Eq.trans (congrArg (fun x => oddPartner ℓ (φ.val x)) harg) + (congrArg (oddPartner ℓ) (φ.property ⟨_, h⟩)) + · have h' : (starFlagEnum W).symm (Fin.natAdd (edgeCount W) i) ∉ F.flags := by + rw [hpair]; intro hmem + exact h (by + have := F.pairing_mem _ hmem + rw [W.pairing_invol] at this + exact this) + rw [dite_eq_right h', dite_eq_right h] + congr 1 + have harg : (⟨(starFlagEnum W).symm (Fin.natAdd (edgeCount W) i), h'⟩ : + {f : W.Flag // f ∉ F.flags}) = + ⟨W.pairing ((starFlagEnum W).symm (Fin.castAdd (edgeCount W) i)), + F.pairing_not_mem h⟩ := Subtype.ext hpair + exact Eq.trans (congrArg ψ.val harg) (ψ.property ⟨_, h⟩) + +open Classical in +-- The diagonal pairing is expanded position by +-- position over `Fin (edgeCount W)`, each with its membership +-- dichotomy. +/-- **The diagonal cap pairing on the data colouring**: the Koszul +sign times the product of per-position form entries, each evaluated +on the diagonal partner. -/ +theorem betaDiag_colouringOf (W : ClosedFragment) (F : EdgeSubset W) + (ψ : F.EvenColouring k) (φ : F.OddColouring ℓ) : + betaDiag (edgeCount W) (colouringOf W F ψ φ) = + (-1 : ℂ) ^ (Finset.univ.filter + (fun p : Fin (edgeCount W) × Fin (edgeCount W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ p.2 ∈ edgeIndexSet W F)).card * + ∏ i : Fin (edgeCount W), + (if h : (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i) ∈ F.flags + then + -(oddPartnerSign ℓ (φ.val ⟨(starFlagEnum W).symm (Fin.castAdd + (edgeCount W) i), h⟩) : ℂ) + else 1) := by + rw [betaDiag_eq_betaColour (edgeCount W) (colouringOf W F ψ φ)] + unfold betaColour + -- Rewrite the crossing count + rw [koszulCrossings_colouringOf W F ψ φ] + congr 1 + -- Show the products agree entry-by-entry + refine Finset.prod_congr rfl (fun i _ => ?_) + -- Convert firstHalf/secondHalf to castAdd/natAdd + change colourFormEntry k ℓ + (colouringOf W F ψ φ (Fin.castAdd (edgeCount W) i)) + (colouringOf W F ψ φ (Fin.natAdd (edgeCount W) i)) = _ + rw [colouringOf_castAdd, colouringOf_natAdd] + by_cases h : (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i) ∈ F.flags + · rw [dite_eq_left h, dite_eq_left h, dite_eq_left h] + exact colourFormEntry_inr_partner _ + · rw [dite_eq_right h, dite_eq_right h, dite_eq_right h] + change (if (ψ.val ⟨_, h⟩) = (ψ.val ⟨_, h⟩) then (1 : ℂ) else 0) = 1 + rw [ite_eq_left rfl] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiag.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiag.lean new file mode 100644 index 0000000000..d5050916d4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiag.lean @@ -0,0 +1,153 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeelSplit +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisCoord + +/-! +# The diagonal cap pairing + +The colour-side closed form of the cap value, defined by the very +recursion the peel induction produces: the peel coefficient at +the peeled colouring times the split factor — the smaller diagonal +against the two-position form entry, vanishing on odd halves. +-/ + +@[expose] public section + +namespace RS + +variable {k ℓ : ℕ} + +/-- The peeled colouring: the inverse peel reindex. -/ +def peelColour (m : ℕ) + (c : MixedColouring k ℓ ((m + 1) + (m + 1))) : + MixedColouring k ℓ ((m + m) + 2) := fun j => + c ((capPeelPerm m)⁻¹ ((finCongr (capPeelArity m)).symm j)) + +/-- The peeled colouring undoes the peel reindex. -/ +theorem peelColour_spec (m : ℕ) + (c : MixedColouring k ℓ ((m + 1) + (m + 1))) : + (peelColour m c ∘ ⇑(finCongr (capPeelArity m))) ∘ + ⇑(capPeelPerm m) = c := + funext (fun x => congrArg c (by + rw [_root_.Equiv.symm_apply_apply] + exact _root_.Equiv.symm_apply_apply (capPeelPerm m) x)) + +/-- The peeled colouring is the unique solution of the peel +reindex equation. -/ +theorem eq_peelColour_of (m : ℕ) + {c : MixedColouring k ℓ ((m + 1) + (m + 1))} + {c' : MixedColouring k ℓ ((m + m) + 2)} + (hspec : (c' ∘ ⇑(finCongr (capPeelArity m))) ∘ + ⇑(capPeelPerm m) = c) : + c' = peelColour m c := by + subst hspec + apply Eq.symm + funext j + change c' (finCongr (capPeelArity m) ((capPeelPerm m) + ((capPeelPerm m)⁻¹ + ((finCongr (capPeelArity m)).symm j)))) = c' j + rw [show (capPeelPerm m) ((capPeelPerm m)⁻¹ + ((finCongr (capPeelArity m)).symm j)) = + (finCongr (capPeelArity m)).symm j from + _root_.Equiv.apply_symm_apply _ _] + rw [_root_.Equiv.apply_symm_apply] + +/-- The peeled colouring preserves parity. -/ +theorem peelColour_isEven (m : ℕ) + {c : MixedColouring k ℓ ((m + 1) + (m + 1))} + (hc : c.IsEven) : + MixedColouring.IsEven (peelColour m c) := by + have h1 : MixedColouring.IsEven + (c ∘ ⇑((capPeelPerm m)⁻¹)) := hc.comp _ + have h2 : peelColour m c = + (c ∘ ⇑((capPeelPerm m)⁻¹)) ∘ + ⇑(finCongr (capPeelArity m).symm) := by + funext j + change c ((capPeelPerm m)⁻¹ + ((finCongr (capPeelArity m)).symm j)) = _ + rfl + rw [h2] + exact (isEven_comp_finCongr (capPeelArity m).symm _).mpr h1 + +/-- The peeled colouring on values. -/ +theorem peelColour_apply (m : ℕ) + (c : MixedColouring k ℓ ((m + 1) + (m + 1))) + (j : Fin ((m + m) + 2)) : + peelColour m c j = c ⟨capPeelInv m j.val, by + have := j.isLt + unfold capPeelInv + split_ifs <;> omega⟩ := + congrArg c (Fin.ext rfl) + +/-- The peel fixes the low first-half slots. -/ +theorem peelColour_low (m : ℕ) + (c : MixedColouring k ℓ ((m + 1) + (m + 1))) + (j : Fin ((m + m) + 2)) (h : j.val < m) : + peelColour m c j = c ⟨j.val, by omega⟩ := by + rw [peelColour_apply] + refine congrArg c (Fin.ext ?_) + change capPeelInv m j.val = j.val + unfold capPeelInv + rw [ite_eq_left h] + +/-- The second peeled-pair slot carries the last slot. -/ +theorem peelColour_pairSnd (m : ℕ) + (c : MixedColouring k ℓ ((m + 1) + (m + 1))) : + peelColour m c ⟨(m + m) + 1, by omega⟩ = + c ⟨(m + 1) + m, by omega⟩ := by + rw [peelColour_apply] + refine congrArg c (Fin.ext ?_) + change capPeelInv m ((m + m) + 1) = (m + 1) + m + unfold capPeelInv + rw [ite_eq_right (by omega), ite_eq_right (by omega), ite_eq_right (by omega)] + omega + +/-- **The diagonal cap pairing**: the colour-side cap value. -/ +noncomputable def betaDiag : + (m : ℕ) → MixedColouring k ℓ (m + m) → ℂ + | 0, _ => 1 + | m + 1, c => + wordSign (adjWord (capPeelPerm m)) + (peelColour m c ∘ ⇑(finCongr (capPeelArity m))) * + (if _h : MixedColouring.IsEven + (MixedColouring.firstHalf (a := m + m) (b := 2) + (peelColour m c)) then + betaDiag m (MixedColouring.firstHalf + (a := m + m) (b := 2) (peelColour m c)) * + colourFormEntry k ℓ + (MixedColouring.secondHalf + (a := m + m) (b := 2) (peelColour m c) 0) + (MixedColouring.secondHalf + (a := m + m) (b := 2) (peelColour m c) 1) + else 0) + +/-- The base of the diagonal pairing. -/ +theorem betaDiag_zero (c : MixedColouring k ℓ 0) : + betaDiag 0 c = 1 := rfl + +/-- The successor equation of the diagonal pairing. -/ +theorem betaDiag_succ (m : ℕ) + (c : MixedColouring k ℓ ((m + 1) + (m + 1))) : + betaDiag (m + 1) c = + wordSign (adjWord (capPeelPerm m)) + (peelColour m c ∘ ⇑(finCongr (capPeelArity m))) * + (if _h : MixedColouring.IsEven + (MixedColouring.firstHalf (a := m + m) (b := 2) + (peelColour m c)) then + betaDiag m (MixedColouring.firstHalf + (a := m + m) (b := 2) (peelColour m c)) * + colourFormEntry k ℓ + (MixedColouring.secondHalf + (a := m + m) (b := 2) (peelColour m c) 0) + (MixedColouring.secondHalf + (a := m + m) (b := 2) (peelColour m c) 1) + else 0) := rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiagForm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiagForm.lean new file mode 100644 index 0000000000..6952ac857e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiagForm.lean @@ -0,0 +1,541 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiag +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelPermCoord + +/-! +# The diagonal cap pairing equals the colour pairing + +The diagonal cap pairing `betaDiag m c` on a colouring +`c : MixedColouring k ℓ (m + m)` equals the tensor-power +pairing `betaColour` applied to the two halves of `c`. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {k ℓ : ℕ} + +/-! ### Helper lemmas: peelColour and halves -/ + +/-- The first half of the first half of the peeled colouring +agrees with the original colouring on low positions. -/ +private theorem peelFirstHalf_firstHalf (m : ℕ) + (c : MixedColouring k ℓ ((m + 1) + (m + 1))) : + MixedColouring.firstHalf (a := m) (b := m) + (MixedColouring.firstHalf (a := m + m) (b := 2) + (peelColour m c)) = + fun (i : Fin m) => c ⟨i.val, by omega⟩ := by + funext i + change peelColour m c ⟨i.val, by omega⟩ = c ⟨i.val, by omega⟩ + rw [peelColour_low m c ⟨i.val, by omega⟩ i.isLt] + +/-- The second half of the first half of the peeled colouring +agrees with the shifted original colouring. -/ +private theorem peelFirstHalf_secondHalf (m : ℕ) + (c : MixedColouring k ℓ ((m + 1) + (m + 1))) : + MixedColouring.secondHalf (a := m) (b := m) + (MixedColouring.firstHalf (a := m + m) (b := 2) + (peelColour m c)) = + fun (j : Fin m) => c ⟨(m + 1) + j.val, by omega⟩ := by + funext j + change peelColour m c ⟨m + j.val, by omega⟩ = + c ⟨(m + 1) + j.val, by omega⟩ + rw [peelColour_apply] + refine congrArg c (Fin.ext ?_) + change capPeelInv m (m + j.val) = (m + 1) + j.val + unfold capPeelInv; split_ifs <;> omega + +/-- The peeled pair's first entry is c at position m. -/ +private theorem peelSecondHalf_zero (m : ℕ) + (c : MixedColouring k ℓ ((m + 1) + (m + 1))) : + MixedColouring.secondHalf (a := m + m) (b := 2) + (peelColour m c) 0 = c ⟨m, by omega⟩ := by + change peelColour m c ⟨(m + m) + 0, by omega⟩ = c ⟨m, by omega⟩ + rw [peelColour_apply] + refine congrArg c (Fin.ext ?_) + change capPeelInv m ((m + m) + 0) = m + unfold capPeelInv; split_ifs <;> omega + +/-- The peeled pair's second entry is c at position (m+1)+m. -/ +private theorem peelSecondHalf_one (m : ℕ) + (c : MixedColouring k ℓ ((m + 1) + (m + 1))) : + MixedColouring.secondHalf (a := m + m) (b := 2) + (peelColour m c) 1 = c ⟨(m + 1) + m, by omega⟩ := + peelColour_pairSnd m c + +/-! ### Relating halves of c to halves of peeled firstHalf -/ + +/-- The first half of c at `Fin.castSucc i` agrees with the +peeled firstHalf's firstHalf at `i`. -/ +private theorem firstHalf_castSucc_eq (m : ℕ) + (c : MixedColouring k ℓ ((m + 1) + (m + 1))) + (i : Fin m) : + MixedColouring.firstHalf (a := m + 1) (b := m + 1) c + (Fin.castSucc i) = + MixedColouring.firstHalf (a := m) (b := m) + (MixedColouring.firstHalf (a := m + m) (b := 2) + (peelColour m c)) i := by + change c ⟨(Fin.castSucc i).val, by omega⟩ = _ + rw [peelFirstHalf_firstHalf] + exact congrArg c (Fin.ext rfl) + +/-- The second half of c at `Fin.castSucc j` agrees with the +peeled firstHalf's secondHalf at `j`. -/ +private theorem secondHalf_castSucc_eq (m : ℕ) + (c : MixedColouring k ℓ ((m + 1) + (m + 1))) + (j : Fin m) : + MixedColouring.secondHalf (a := m + 1) (b := m + 1) c + (Fin.castSucc j) = + MixedColouring.secondHalf (a := m) (b := m) + (MixedColouring.firstHalf (a := m + m) (b := 2) + (peelColour m c)) j := by + change c ⟨(m + 1) + (Fin.castSucc j).val, by omega⟩ = _ + rw [peelFirstHalf_secondHalf] + exact congrArg c (Fin.ext rfl) + +/-- The first half of c at the last position is c at m. -/ +private theorem firstHalf_last (m : ℕ) + (c : MixedColouring k ℓ ((m + 1) + (m + 1))) : + MixedColouring.firstHalf (a := m + 1) (b := m + 1) c + (Fin.last m) = c ⟨m, by omega⟩ := + congrArg c (Fin.ext rfl) + +/-- The second half of c at the last position. -/ +private theorem secondHalf_last' (m : ℕ) + (c : MixedColouring k ℓ ((m + 1) + (m + 1))) : + MixedColouring.secondHalf (a := m + 1) (b := m + 1) c + (Fin.last m) = c ⟨(m + 1) + m, by omega⟩ := + congrArg c (Fin.ext rfl) + +/-! ### Product splitting -/ + +/-- The entry product over Fin (m+1) splits as the m-product +times the last entry, with the m-product matching the peeled +induction hypothesis. -/ +private theorem prod_entry_split (m : ℕ) + (c : MixedColouring k ℓ ((m + 1) + (m + 1))) : + ∏ i : Fin (m + 1), + colourFormEntry k ℓ + (MixedColouring.firstHalf (a := m + 1) (b := m + 1) c i) + (MixedColouring.secondHalf (a := m + 1) (b := m + 1) c i) = + (∏ i : Fin m, + colourFormEntry k ℓ + (MixedColouring.firstHalf (a := m) (b := m) + (MixedColouring.firstHalf (a := m + m) (b := 2) + (peelColour m c)) i) + (MixedColouring.secondHalf (a := m) (b := m) + (MixedColouring.firstHalf (a := m + m) (b := 2) + (peelColour m c)) i)) * + colourFormEntry k ℓ + (MixedColouring.secondHalf (a := m + m) (b := 2) + (peelColour m c) 0) + (MixedColouring.secondHalf (a := m + m) (b := 2) + (peelColour m c) 1) := by + rw [Fin.prod_univ_castSucc] + congr 1 + · exact Finset.prod_congr rfl (fun i _hi => by + rw [firstHalf_castSucc_eq, secondHalf_castSucc_eq]) + · rw [firstHalf_last, secondHalf_last', + peelSecondHalf_zero, peelSecondHalf_one] + +/-! ### Mixed pair lemmas -/ + +/-- Mixed-type entry is zero. -/ +private theorem colourFormEntry_zero_of_isRight_ne + (a : Fin k ⊕ Fin (2 * ℓ)) (b : Fin k ⊕ Fin (2 * ℓ)) + (h : a.isRight ≠ b.isRight) : + colourFormEntry k ℓ a b = 0 := by + rcases a with _ | _ <;> rcases b with _ | _ <;> + simp [colourFormEntry] <;> simp_all + +/-! ### The dite-false branch: betaDiag vanishes -/ + +/-- If the peeled first half is not even and there exists a mixed +pair, then betaColour is zero. The contrapositive: if all pairs +match, the peeled first half is even. -/ +private theorem peelFirstHalf_isEven_of_matching (m : ℕ) + (c : MixedColouring k ℓ ((m + 1) + (m + 1))) + (hmatch : ∀ i : Fin (m + 1), + (MixedColouring.firstHalf (a := m + 1) (b := m + 1) + c i).isRight = + (MixedColouring.secondHalf (a := m + 1) (b := m + 1) + c i).isRight) : + MixedColouring.IsEven + (MixedColouring.firstHalf (a := m + m) (b := 2) + (peelColour m c)) := by + unfold MixedColouring.IsEven + rw [MixedColouring.oddSet_card_split (a := m) (b := m)] + rw [peelFirstHalf_firstHalf, peelFirstHalf_secondHalf] + apply Nat.even_add.mpr + have hcard : + (MixedColouring.oddSet + (fun i : Fin m => c ⟨i.val, by omega⟩)).card = + (MixedColouring.oddSet + (fun j : Fin m => c ⟨(m + 1) + j.val, by omega⟩)).card := by + have hmatch' : ∀ i : Fin m, + (c ⟨i.val, by omega⟩).isRight = + (c ⟨(m + 1) + i.val, by omega⟩).isRight := by + intro i + have := hmatch (Fin.castSucc i) + -- this : (c.firstHalf (castSucc i)).isRight = + -- (c.secondHalf (castSucc i)).isRight + exact this + refine Finset.card_bij (fun i _hi => i) ?_ ?_ ?_ + · intro i hi + simp only [MixedColouring.oddSet, mem_filter, mem_univ, + true_and] at hi ⊢ + rwa [← hmatch' i] + · intro _ _ _ _ h; exact h + · intro j hj + refine ⟨j, ?_, rfl⟩ + simp only [MixedColouring.oddSet, mem_filter, mem_univ, + true_and] at hj ⊢ + rwa [hmatch' j] + constructor <;> intro h <;> [rwa [hcard] at h; rwa [← hcard] at h] + +/-! ### Sign identity -/ + +/-- The peelColour composed with finCongr and capPeelPerm +recovers the original colouring. -/ +private theorem peelColour_finCongr_capPeelPerm (m : ℕ) + (c : MixedColouring k ℓ ((m + 1) + (m + 1))) + (x : Fin ((m + 1) + (m + 1))) : + (peelColour m c ∘ ⇑(finCongr (capPeelArity m))) + (capPeelPerm m x) = c x := + congr_fun (peelColour_spec m c) x + +/-- The word-sign factor composed with the koszul sign of the +peeled halves gives the koszul sign of the (m+1)-halves. + +Proved via the identity: + oddInversions + koszulCrossings(m) = koszulCrossings(m+1) +both sides counting pairs in Fin((m+1)+(m+1)) weighted by the +inversions of capPeelPerm and the position-parity conditions. -/ +private theorem sign_eq (m : ℕ) + (c : MixedColouring k ℓ ((m + 1) + (m + 1))) + (_hmatch : ∀ i : Fin (m + 1), + (MixedColouring.firstHalf (a := m + 1) (b := m + 1) + c i).isRight = + (MixedColouring.secondHalf (a := m + 1) (b := m + 1) + c i).isRight) : + (-1 : ℂ) ^ oddInversions (capPeelPerm m) + (peelColour m c ∘ ⇑(finCongr (capPeelArity m))) * + ((-1 : ℂ) ^ koszulCrossings + (MixedColouring.firstHalf (a := m) (b := m) + (MixedColouring.firstHalf (a := m + m) (b := 2) + (peelColour m c))) + (MixedColouring.secondHalf (a := m) (b := m) + (MixedColouring.firstHalf (a := m + m) (b := 2) + (peelColour m c)))) = + (-1 : ℂ) ^ koszulCrossings + (MixedColouring.firstHalf (a := m + 1) (b := m + 1) c) + (MixedColouring.secondHalf (a := m + 1) (b := m + 1) c) := by + rw [← pow_add]; congr 1 + -- ═══════ STAGE 1: THE INVERSIONS OF THE PEEL PERMUTATION ═══════ + -- Characterize inversions of capPeelPerm: + -- the only pairs (a,b) with aσ(b) have a.val=m, m+1≤b.val≤m+m. + have hinv : ∀ (a b : Fin ((m + 1) + (m + 1))), + a < b → capPeelPerm m a > capPeelPerm m b → + a.val = m ∧ m + 1 ≤ b.val ∧ b.val ≤ m + m := by + intro a b hab hgt + have ha := a.isLt; have hb := b.isLt + have hva : (capPeelPerm m a).val = capPeelFun m a.val := by + unfold capPeelPerm capPeelRotation + simp [Equiv.trans_apply, capPeelFun, finCongr_apply] + have hvb : (capPeelPerm m b).val = capPeelFun m b.val := by + unfold capPeelPerm capPeelRotation + simp [Equiv.trans_apply, capPeelFun, finCongr_apply] + have hab' : a.val < b.val := hab + have hgt' : (capPeelPerm m b).val < + (capPeelPerm m a).val := hgt + rw [hva, hvb] at hgt' + unfold capPeelFun at hgt' + split_ifs at hgt' <;> refine ⟨?_, ?_, ?_⟩ <;> omega + have hdc := peelColour_finCongr_capPeelPerm m c + -- Precompute σ values at key positions + have hσm : (capPeelPerm m (⟨m, by omega⟩ : + Fin ((m + 1) + (m + 1)))).val = m + m := by + unfold capPeelPerm capPeelRotation + simp [Equiv.trans_apply, capPeelFun, finCongr_apply] + have hσi : ∀ (i : Fin m), + (capPeelPerm m (⟨(m + 1) + i.val, by omega⟩ : + Fin ((m + 1) + (m + 1)))).val = m + i.val := by + intro i + unfold capPeelPerm capPeelRotation + simp [Equiv.trans_apply, capPeelFun, finCongr_apply] + split_ifs <;> omega + -- Abbreviate KC_{m+1} arguments + set fHc := MixedColouring.firstHalf (a := m + 1) + (b := m + 1) c with hfHc_def + set sHc := MixedColouring.secondHalf (a := m + 1) + (b := m + 1) c with hsHc_def + -- ═══════ STAGE 2: SPLIT THE CROSSING SET AT THE PEELED SLOT ═══════ + -- Partition the KC_{m+1} filter by p.2 = last m + set Kbig : Finset (Fin (m + 1) × Fin (m + 1)) := + univ.filter fun p => + p.1 < p.2 ∧ (fHc p.2).isRight ∧ (sHc p.1).isRight + have hKC_eq : koszulCrossings fHc sHc = Kbig.card := rfl + set Kinner := Kbig.filter fun p => p.2 ≠ Fin.last m + set Kbdry := Kbig.filter fun p => p.2 = Fin.last m + have hsplit : Kbig.card = Kinner.card + Kbdry.card := by + rw [← card_union_of_disjoint + (disjoint_filter.mpr fun _ _ h1 h2 => h1 h2)] + congr 1; ext x + simp only [mem_union, mem_filter] + exact ⟨fun hx => if h : x.2 = Fin.last m + then Or.inr ⟨hx, h⟩ else Or.inl ⟨hx, h⟩, + fun h => h.elim (·.1) (·.1)⟩ + -- ═══════ STAGE 3: THE INTERIOR IS THE SMALLER CROSSING SET ═══════ + -- Kinner.card = KC_m via castSucc bijection + have hinner : koszulCrossings + (MixedColouring.firstHalf (a := m) (b := m) + (MixedColouring.firstHalf (a := m + m) (b := 2) + (peelColour m c))) + (MixedColouring.secondHalf (a := m) (b := m) + (MixedColouring.firstHalf (a := m + m) (b := 2) + (peelColour m c))) = Kinner.card := by + unfold koszulCrossings + refine card_bij + (fun p _hp => ((Fin.castSucc p.1, Fin.castSucc p.2) : + Fin (m + 1) × Fin (m + 1))) ?_ ?_ ?_ + · intro ⟨i, j⟩ hp + simp only [mem_filter, mem_univ, true_and] at hp + refine mem_filter.mpr ⟨mem_filter.mpr + ⟨mem_univ _, hp.1, ?_, ?_⟩, ?_⟩ + · rw [hfHc_def, firstHalf_castSucc_eq]; exact hp.2.1 + · rw [hsHc_def, secondHalf_castSucc_eq]; exact hp.2.2 + · intro h; have : j.val = m := congrArg Fin.val h + omega + · intro ⟨a₁, b₁⟩ _ ⟨a₂, b₂⟩ _ h + exact Prod.ext + (Fin.castSucc_injective _ (congrArg Prod.fst h)) + (Fin.castSucc_injective _ (congrArg Prod.snd h)) + · intro ⟨i, j⟩ hp + have hp' := mem_filter.mp hp + have hp'' := (mem_filter.mp hp'.1).2 + have hj_lt : j.val < m := by + rcases Nat.lt_or_eq_of_le + (Nat.lt_succ_iff.mp j.isLt) with h | h + · exact h + · exact absurd (Fin.ext h) hp'.2 + have hi_lt : i.val < m := Nat.lt_trans hp''.1 hj_lt + refine ⟨(⟨i.val, hi_lt⟩, ⟨j.val, hj_lt⟩), ?_, ?_⟩ + · simp only [mem_filter, mem_univ, true_and] + exact ⟨hp''.1, + by rw [← firstHalf_castSucc_eq m c + ⟨j.val, hj_lt⟩, ← hfHc_def]; exact hp''.2.1, + by rw [← secondHalf_castSucc_eq m c + ⟨i.val, hi_lt⟩, ← hsHc_def]; exact hp''.2.2⟩ + · exact Prod.ext (Fin.ext rfl) (Fin.ext rfl) + -- ═══════ STAGE 4: THE BOUNDARY IS THE INVERSION COUNT ═══════ + -- Kbdry.card = OI via inversion bijection + have hbdry : oddInversions (capPeelPerm m) + (peelColour m c ∘ ⇑(finCongr (capPeelArity m))) = + Kbdry.card := by + unfold oddInversions + refine card_bij + (fun p _hp => + ((⟨p.2.val - (m + 1), by have := p.2.isLt; omega⟩ : + Fin (m + 1)), + Fin.last m)) ?_ ?_ ?_ + · intro ⟨a, b⟩ hp + simp only [mem_filter, mem_univ, true_and] at hp + obtain ⟨hab, hgt, hr1, hr2⟩ := hp + obtain ⟨ha_eq, hb_lo, hb_hi⟩ := hinv a b hab hgt + refine mem_filter.mpr ⟨mem_filter.mpr + ⟨mem_univ _, ?_, ?_, ?_⟩, rfl⟩ + · change b.val - (m + 1) < m; omega + · have hca : (c a).isRight := by rw [← hdc]; exact hr1 + have ha_fin : (⟨m, by omega⟩ : + Fin ((m + 1) + (m + 1))) = a := + (Fin.ext ha_eq).symm + rw [hfHc_def, firstHalf_last, ha_fin]; exact hca + · have hcb : (c b).isRight := by rw [← hdc]; exact hr2 + have hb_fin : Fin.natAdd (m + 1) + (⟨b.val - (m + 1), by omega⟩ : Fin (m + 1)) = + b := + Fin.ext (by simp; omega) + rw [hsHc_def]; change (c (Fin.natAdd (m + 1) + ⟨b.val - (m + 1), _⟩)).isRight + rw [hb_fin]; exact hcb + · intro ⟨a₁, b₁⟩ hp₁ ⟨a₂, b₂⟩ hp₂ h + simp only [mem_filter, mem_univ, true_and] at hp₁ hp₂ + obtain ⟨ha₁, hb₁_lo, _⟩ := + hinv a₁ b₁ hp₁.1 hp₁.2.1 + obtain ⟨ha₂, hb₂_lo, _⟩ := + hinv a₂ b₂ hp₂.1 hp₂.2.1 + have h_fst : b₁.val - (m + 1) = b₂.val - (m + 1) := + congrArg Fin.val (congrArg Prod.fst h) + have ha : a₁ = a₂ := Fin.ext (by omega) + have hb : b₁ = b₂ := Fin.ext (by omega) + exact Prod.ext ha hb + · intro ⟨i, j⟩ hp + have hp' := mem_filter.mp hp + have hp'' := (mem_filter.mp hp'.1).2 + have hj_eq : j = Fin.last m := hp'.2 + have hij := hp''.1 + have hrj := hp''.2.1 + have hri := hp''.2.2 + have hi_lt : i.val < m := by + rw [hj_eq] at hij; exact hij + refine ⟨(⟨m, by omega⟩, ⟨(m + 1) + i.val, by omega⟩), + ?_, ?_⟩ + · simp only [mem_filter, mem_univ, true_and] + refine ⟨show m < (m + 1) + i.val by omega, ?_, ?_, ?_⟩ + · change (capPeelPerm m + ⟨(m + 1) + i.val, _⟩).val < + (capPeelPerm m ⟨m, _⟩).val + rw [hσm, hσi ⟨i.val, hi_lt⟩]; omega + · rw [hdc] + rw [show (⟨m, by omega⟩ : + Fin ((m + 1) + (m + 1))) = + Fin.castAdd (m + 1) (Fin.last m) from + Fin.ext rfl] + rw [hj_eq] at hrj; exact hrj + · rw [hdc] + rw [show (⟨(m + 1) + i.val, by omega⟩ : + Fin ((m + 1) + (m + 1))) = + Fin.natAdd (m + 1) i from Fin.ext rfl] + exact hri + · have hv : (m + 1 + i.val) - (m + 1) = i.val := by + omega + exact Prod.ext (Fin.ext hv) + (hj_eq.symm ▸ rfl) + -- Conclude: OI + KC_m = KC_{m+1} + rw [hKC_eq, hsplit, ← hinner, ← hbdry]; omega + +/-! ### The main theorem -/ + +-- The induction on the arity carries the whole +-- Koszul crossing count through each step. +/-- **The diagonal cap pairing equals the colour pairing**: +`betaDiag m c = betaColour (firstHalf c) (secondHalf c)`. -/ +theorem betaDiag_eq_betaColour {k ℓ : ℕ} : + ∀ (m : ℕ) (c : MixedColouring k ℓ (m + m)), + betaDiag m c = + betaColour + (MixedColouring.firstHalf (a := m) (b := m) c) + (MixedColouring.secondHalf (a := m) (b := m) c) := by + intro m + induction m with + | zero => + intro c + rw [betaDiag_zero] + unfold betaColour koszulCrossings + simp + | succ m ih => + intro c + -- Case split: are all position pairs matching in parity type? + by_cases hmatch : ∀ i : Fin (m + 1), + (MixedColouring.firstHalf (a := m + 1) (b := m + 1) + c i).isRight = + (MixedColouring.secondHalf (a := m + 1) (b := m + 1) + c i).isRight + · -- All pairs match: the main computation + have heven := peelFirstHalf_isEven_of_matching m c hmatch + rw [betaDiag_succ] + rw [dite_eq_left heven] + -- Apply the inductive hypothesis + rw [ih] + -- Unfold betaColour on both sides + unfold betaColour + -- Use the product splitting + rw [prod_entry_split] + -- Use the sign identity + rw [wordSign_eq_oddInversions, wordPerm_adjWord] + -- Rearrange: a * (b * (P * E)) = a * b * (P * E) + -- = (a * b) * (P * E) = K' * (P * E) + -- where a * b = K' by sign_eq + set I := oddInversions (capPeelPerm m) + (peelColour m c ∘ ⇑(finCongr (capPeelArity m))) + set K := koszulCrossings + (MixedColouring.firstHalf (a := m) (b := m) + (MixedColouring.firstHalf (a := m + m) (b := 2) + (peelColour m c))) + (MixedColouring.secondHalf (a := m) (b := m) + (MixedColouring.firstHalf (a := m + m) (b := 2) + (peelColour m c))) + set K' := koszulCrossings + (MixedColouring.firstHalf (a := m + 1) (b := m + 1) c) + (MixedColouring.secondHalf (a := m + 1) (b := m + 1) c) + set P := ∏ i : Fin m, + colourFormEntry k ℓ + (MixedColouring.firstHalf (a := m) (b := m) + (MixedColouring.firstHalf (a := m + m) (b := 2) + (peelColour m c)) i) + (MixedColouring.secondHalf (a := m) (b := m) + (MixedColouring.firstHalf (a := m + m) (b := 2) + (peelColour m c)) i) + set E := colourFormEntry k ℓ + (MixedColouring.secondHalf (a := m + m) (b := 2) + (peelColour m c) 0) + (MixedColouring.secondHalf (a := m + m) (b := 2) + (peelColour m c) 1) + have hsign : (-1 : ℂ) ^ I * (-1 : ℂ) ^ K = + (-1 : ℂ) ^ K' := sign_eq m c hmatch + -- The goal is (-1)^I * ((-1)^K * P * E) = (-1)^K' * (P * E) + calc (-1 : ℂ) ^ I * ((-1) ^ K * P * E) + = ((-1) ^ I * (-1) ^ K) * (P * E) := by ring + _ = (-1) ^ K' * (P * E) := by rw [hsign] + · -- Mixed pair: both sides are zero + push Not at hmatch + obtain ⟨i, hi⟩ := hmatch + rw [show betaColour + (MixedColouring.firstHalf (a := m + 1) (b := m + 1) c) + (MixedColouring.secondHalf (a := m + 1) (b := m + 1) + c) = 0 from betaColour_eq_zero_of_mixed i hi] + rw [betaDiag_succ] + -- Determine if mixed pair is at the last position + by_cases hi_last : i = Fin.last m + · -- Mixed at last m: the colourFormEntry is zero + subst hi_last + split_ifs with hev + · -- dite-true + have hentry : colourFormEntry k ℓ + (MixedColouring.secondHalf (a := m + m) (b := 2) + (peelColour m c) 0) + (MixedColouring.secondHalf (a := m + m) (b := 2) + (peelColour m c) 1) = 0 := by + rw [peelSecondHalf_zero, peelSecondHalf_one] + exact colourFormEntry_zero_of_isRight_ne _ _ + (by rwa [firstHalf_last, secondHalf_last'] at hi) + rw [hentry, mul_zero, mul_zero] + · -- dite-false + rw [mul_zero] + · -- Mixed at castSucc i': get i' from i + have ⟨i', hi'⟩ : ∃ i' : Fin m, i = Fin.castSucc i' := by + refine ⟨⟨i.val, ?_⟩, Fin.ext rfl⟩ + have := i.isLt + have : (Fin.last m).val = m := rfl + by_contra h + exact hi_last (Fin.ext (by omega)) + subst hi' + split_ifs with hev + · -- dite-true: IH betaColour is zero + rw [ih] + have hbc : betaColour + (MixedColouring.firstHalf (a := m) (b := m) + (MixedColouring.firstHalf (a := m + m) (b := 2) + (peelColour m c))) + (MixedColouring.secondHalf (a := m) (b := m) + (MixedColouring.firstHalf (a := m + m) (b := 2) + (peelColour m c))) = 0 := by + apply betaColour_eq_zero_of_mixed (i := i') + rw [← firstHalf_castSucc_eq, + ← secondHalf_castSucc_eq] + exact hi + rw [hbc, zero_mul, mul_zero] + · -- dite-false + rw [mul_zero] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaFlip.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaFlip.lean new file mode 100644 index 0000000000..29b7ec69f4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaFlip.lean @@ -0,0 +1,74 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaData +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EdgeSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddSignProd +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OutSignEdges +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockAlign + +/-! +# The cap pairing at the flipped colouring + +Composing the diagonal cap evaluation, the flip's edge signs, the +per-edge collapse, and the vertex odd-sign product: the cap +pairing at the flipped data colouring is the crossing and +representative parities times the Definition 5 odd signs. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {k ℓ : ℕ} + +open Classical in +/-- **The cap pairing at the flipped data colouring**. -/ +theorem betaDiag_colouringOfFlip (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) : + betaDiag (edgeCount W) (colouringOfFlip W F o ψ φ) = + (-1 : ℂ) ^ (Finset.univ.filter + (fun p : Fin (edgeCount W) × Fin (edgeCount W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ + p.2 ∈ edgeIndexSet W F)).card * + (-1 : ℂ) ^ inRepCount W F o * + ∏ v : W.Vertex, ((F.oddSignAt o φ v : ℤ) : ℂ) := by + rw [show colouringOfFlip W F o ψ φ = + colouringOf W F ψ + (EdgeSubset.OddColouring.flip F (outRepSet W F o) + (outRepSet_pairing_mem W F o) φ) from rfl] + rw [betaDiag_colouringOf W F ψ _] + rw [edge_sign_sector W F o φ] + rw [show (∏ i : Fin (edgeCount W), + (if h : (starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i) ∈ F.flags then + ((oddPartnerSign ℓ (φ.val + ⟨(starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i), h⟩) : ℤ) : ℂ) + else 1)) = + ((∏ i : Fin (edgeCount W), + (if h : (starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i) ∈ F.flags then + oddPartnerSign ℓ (φ.val + ⟨(starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i), h⟩) + else 1) : ℤ) : ℂ) from by + rw [Int.cast_prod] + refine Finset.prod_congr rfl (fun i _ => ?_) + rw [apply_dite (fun z : ℤ => (z : ℂ))] + norm_num] + rw [← prod_out_sign_eq_prod_edges W F o φ] + rw [← prod_oddSignAt o φ] + rw [Int.cast_prod] + ring + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockAlign.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockAlign.lean new file mode 100644 index 0000000000..77a27e87bc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockAlign.lean @@ -0,0 +1,127 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockData +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RepFlag +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddFlip + +/-! +# The block alignment + +Flipping the odd colouring on the edges whose representative is +outgoing aligns the block values of the data colouring with the +Definition 5 per-flag values: outgoing flags carry the partner of +their colour, incoming flags the colour itself. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {k ℓ : ℕ} + +/-- The flipped data colouring of an orientation. -/ +noncomputable def colouringOfFlip (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) : + MixedColouring k ℓ (edgeCount W + edgeCount W) := + colouringOf W F ψ + (EdgeSubset.OddColouring.flip F (outRepSet W F o) + (outRepSet_pairing_mem W F o) φ) + +/-- The slot half of a block flag is the slot half of its +embedded slot. -/ +theorem starFlagEnum_blockFlag (W : ClosedFragment) + (v : Fin (ds W).length) (j : Fin ((ds W).get v)) : + starFlagEnum W (blockFlag W v j) = slotEmbed W v j := + _root_.Equiv.apply_symm_apply _ _ + +/-- **The four-case alignment**: the block value of the flipped +data colouring at a participating slot is the Definition 5 +per-flag value of its flag. -/ +theorem blockRestrict_colouringOfFlip_mem (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) (v : Fin (ds W).length) + (j : Fin ((ds W).get v)) + (h : blockFlag W v j ∈ F.flags) : + blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v j = + Sum.inr (if o.isOut (blockFlag W v j) = true + then oddPartner ℓ (φ.val ⟨blockFlag W v j, h⟩) + else φ.val ⟨blockFlag W v j, h⟩) := by + rw [colouringOfFlip, + blockRestrict_colouringOf_mem W F _ _ v j h] + congr 1 + by_cases hlow : (slotEmbed W v j).val < edgeCount W + · rw [ite_eq_left hlow] + have hrep : repFlag W (blockFlag W v j) = + blockFlag W v j := + repFlag_low W _ (by + rw [starFlagEnum_blockFlag] + exact hlow) + by_cases hout : o.isOut (blockFlag W v j) = true + · have hT : blockFlag W v j ∈ outRepSet W F o := + (mem_outRepSet_iff W F o _ h).mpr (by + rw [hrep] + exact hout) + rw [EdgeSubset.OddColouring.flip_val_mem F _ _ φ + ⟨blockFlag W v j, h⟩ hT, ite_eq_left hout] + · have hT : blockFlag W v j ∉ outRepSet W F o := + fun hmem => hout (by + have h2 := (mem_outRepSet_iff W F o _ h).mp hmem + rw [hrep] at h2 + exact h2) + rw [EdgeSubset.OddColouring.flip_val_not_mem F _ _ φ + ⟨blockFlag W v j, h⟩ hT, ite_eq_right hout] + · rw [ite_eq_right hlow] + have hnotlow : + ¬ (starFlagEnum W (blockFlag W v j)).val < + edgeCount W := by + rw [starFlagEnum_blockFlag] + exact hlow + have hrep : repFlag W (blockFlag W v j) = + W.pairing (blockFlag W v j) := + repFlag_high W _ hnotlow + have hpair := o.pairing_flip _ h + by_cases hout : o.isOut (blockFlag W v j) = true + · have hT : blockFlag W v j ∉ outRepSet W F o := + fun hmem => by + have h2 := (mem_outRepSet_iff W F o _ h).mp hmem + rw [hrep, hpair, hout] at h2 + exact Bool.noConfusion h2 + rw [EdgeSubset.OddColouring.flip_val_not_mem F _ _ φ + ⟨blockFlag W v j, h⟩ hT, ite_eq_left hout] + · have hof : o.isOut (blockFlag W v j) = false := by + cases hb : o.isOut (blockFlag W v j) + · rfl + · exact absurd hb hout + have hT : blockFlag W v j ∈ outRepSet W F o := + (mem_outRepSet_iff W F o _ h).mpr (by + rw [hrep, hpair, hof] + rfl) + rw [EdgeSubset.OddColouring.flip_val_mem F _ _ φ + ⟨blockFlag W v j, h⟩ hT, oddPartner_invol, + ite_eq_right hout] + +/-- Non-participating block values are unchanged by the flip. -/ +theorem blockRestrict_colouringOfFlip_not_mem + (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) + (ψ : F.EvenColouring k) (φ : F.OddColouring ℓ) + (v : Fin (ds W).length) (j : Fin ((ds W).get v)) + (h : blockFlag W v j ∉ F.flags) : + blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v j = + Sum.inl (ψ.val ⟨blockFlag W v j, h⟩) := + blockRestrict_colouringOf_not_mem W F ψ _ v j h + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockCanon.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockCanon.lean new file mode 100644 index 0000000000..125c000b88 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockCanon.lean @@ -0,0 +1,295 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockAlign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddListMultiset + +/-! +# The block data in canonical form + +The colour-data extractors evaluated at the blocks of the flipped +data colouring: the even multiset is the Definition 5 even-colour +multiset at the block's vertex, and the odd list carries the +Definition 5 odd values. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {k ℓ : ℕ} + +private theorem getRight_congr' {γ δ : Type*} {x y : γ ⊕ δ} + (h : x = y) (hx : x.isRight = true) + (hy : y.isRight = true) : + x.getRight hx = y.getRight hy := by subst h; rfl + +private theorem getLeft_congr' {γ δ : Type*} {x y : γ ⊕ δ} + (h : x = y) (hx : x.isLeft = true) + (hy : y.isLeft = true) : + x.getLeft hx = y.getLeft hy := by subst h; rfl + +/-- Bind a multiset through an all-`none` function. -/ +private theorem filterMap_eq_zero {γ δ : Type*} + (g : γ → Option δ) (m : Multiset γ) + (h : ∀ x ∈ m, g x = none) : + m.filterMap g = 0 := by + induction m using Multiset.induction_on with + | empty => simp + | cons a s ih => + rw [Multiset.filterMap_cons, + h a (Multiset.mem_cons_self a s), + ih (fun x hx => h x (Multiset.mem_cons_of_mem hx))] + rfl + +/-- Bind a multiset through an all-`some` function. -/ +private theorem filterMap_eq_map_of_some {γ δ : Type*} + (g : γ → Option δ) (g' : γ → δ) (m : Multiset γ) + (h : ∀ x ∈ m, g x = some (g' x)) : + m.filterMap g = m.map g' := by + induction m using Multiset.induction_on with + | empty => simp + | cons a s ih => + rw [Multiset.filterMap_cons, + h a (Multiset.mem_cons_self a s), Multiset.map_cons] + rw [ih (fun x hx => h x (Multiset.mem_cons_of_mem hx))] + rw [show ((Option.map (fun b => ({b} : Multiset δ)) + (some (g' a))).getD 0) = {g' a} from rfl] + rw [Multiset.singleton_add] + +-- The list is rewritten through `filterMap` on the +-- universe multiset and split along the participating finset. +open Classical in +/-- **The odd list of a colouring over its participating slots**, +for any finset enumerating them. -/ +theorem oddListOf_coe_multiset {d : ℕ} + (c : MixedColouring k ℓ d) (s : Finset (Fin d)) + (hs : ∀ j, j ∈ s ↔ (c j).isRight = true) : + (↑(oddListOf c) : Multiset (Fin (2 * ℓ))) = + s.attach.val.map + (fun j : {j : Fin d // j ∈ s} => + Sum.getRight (c j.val) ((hs j.val).mp j.prop)) := by + rw [oddListOf, ← Multiset.filterMap_coe, + ← Fin.univ_val_map, Multiset.filterMap_map] + have hsplit : (Finset.univ : Finset (Fin d)).val = + Multiset.filter (fun j => j ∈ s) + (Finset.univ : Finset (Fin d)).val + + Multiset.filter (fun j => ¬ j ∈ s) + (Finset.univ : Finset (Fin d)).val := + (Multiset.filter_add_not _ _).symm + rw [hsplit, Multiset.filterMap_add] + have hfil : Multiset.filter (fun j => j ∈ s) + (Finset.univ : Finset (Fin d)).val = s.val := by + rw [← Finset.filter_val] + refine congrArg Finset.val ?_ + ext j + rw [Finset.mem_filter] + exact ⟨fun h => h.2, fun h => ⟨Finset.mem_univ _, h⟩⟩ + have hzero : Multiset.filterMap (Sum.getRight? ∘ c) + (Multiset.filter (fun j => ¬ j ∈ s) + (Finset.univ : Finset (Fin d)).val) = 0 := by + refine filterMap_eq_zero _ _ ?_ + intro x hx + have hxs : ¬ x ∈ s := (Multiset.mem_filter.mp hx).2 + have hnr : ¬ (c x).isRight = true := + fun hr => hxs ((hs x).mpr hr) + rcases hy : c x with a | u + · change Sum.getRight? (c x) = none + rw [hy] + rfl + · exact absurd (by rw [hy]; rfl) hnr + rw [hfil, hzero, add_zero] + rw [show s.val = s.attach.val.map Subtype.val from by + rw [Finset.attach_val] + exact (Multiset.attach_map_val _).symm] + rw [Multiset.filterMap_map] + refine filterMap_eq_map_of_some _ _ _ ?_ + intro j _ + have hr := (hs j.val).mp j.prop + obtain ⟨u, hu⟩ : ∃ u, c j.val = Sum.inr u := by + rcases hy : c j.val with a | u + · rw [hy] at hr + exact Bool.noConfusion hr + · exact ⟨u, rfl⟩ + change Sum.getRight? (c j.val) = + some (Sum.getRight (c j.val) hr) + have h2 : Sum.getRight (c j.val) hr = u := + getRight_congr' hu hr rfl + rw [h2, hu] + rfl + +-- As for the odd list, on the even side. +open Classical in +/-- **The even multiset of a colouring over its even slots**, +for any finset enumerating them. -/ +theorem evenMultisetOf_coe {d : ℕ} + (c : MixedColouring k ℓ d) (s : Finset (Fin d)) + (hs : ∀ j, j ∈ s ↔ (c j).isLeft = true) : + evenMultisetOf c = + s.attach.val.map + (fun j : {j : Fin d // j ∈ s} => + Sum.getLeft (c j.val) ((hs j.val).mp j.prop)) := by + rw [evenMultisetOf, ← Multiset.filterMap_coe, + ← Fin.univ_val_map, Multiset.filterMap_map] + have hsplit : (Finset.univ : Finset (Fin d)).val = + Multiset.filter (fun j => j ∈ s) + (Finset.univ : Finset (Fin d)).val + + Multiset.filter (fun j => ¬ j ∈ s) + (Finset.univ : Finset (Fin d)).val := + (Multiset.filter_add_not _ _).symm + rw [hsplit, Multiset.filterMap_add] + have hfil : Multiset.filter (fun j => j ∈ s) + (Finset.univ : Finset (Fin d)).val = s.val := by + rw [← Finset.filter_val] + refine congrArg Finset.val ?_ + ext j + rw [Finset.mem_filter] + exact ⟨fun h => h.2, fun h => ⟨Finset.mem_univ _, h⟩⟩ + have hzero : Multiset.filterMap (Sum.getLeft? ∘ c) + (Multiset.filter (fun j => ¬ j ∈ s) + (Finset.univ : Finset (Fin d)).val) = 0 := by + refine filterMap_eq_zero _ _ ?_ + intro x hx + have hxs : ¬ x ∈ s := (Multiset.mem_filter.mp hx).2 + have hnl : ¬ (c x).isLeft = true := + fun hl => hxs ((hs x).mpr hl) + rcases hy : c x with a | u + · exact absurd (by rw [hy]; rfl) hnl + · change Sum.getLeft? (c x) = none + rw [hy] + rfl + rw [hfil, hzero, add_zero] + rw [show s.val = s.attach.val.map Subtype.val from by + rw [Finset.attach_val] + exact (Multiset.attach_map_val _).symm] + rw [Multiset.filterMap_map] + refine filterMap_eq_map_of_some _ _ _ ?_ + intro j _ + have hl := (hs j.val).mp j.prop + obtain ⟨a, ha⟩ : ∃ a, c j.val = Sum.inl a := by + rcases hy : c j.val with a | u + · exact ⟨a, rfl⟩ + · rw [hy] at hl + exact Bool.noConfusion hl + change Sum.getLeft? (c j.val) = + some (Sum.getLeft (c j.val) hl) + have h2 : Sum.getLeft (c j.val) hl = a := + getLeft_congr' ha hl rfl + rw [h2, ha] + rfl + +/-- Participation of a flipped block slot is participation of its +flag. -/ +theorem blockRestrict_colouringOfFlip_isRight + (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) + (ψ : F.EvenColouring k) (φ : F.OddColouring ℓ) + (v : Fin (ds W).length) (j : Fin ((ds W).get v)) : + (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v j).isRight = + true ↔ blockFlag W v j ∈ F.flags := + blockRestrict_colouringOf_isRight W F ψ _ v j + +open Classical in +/-- **The block odd list is the Definition 5 odd list** (as +multisets). -/ +theorem oddListOf_blockRestrict (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) (v : Fin (ds W).length) : + (↑(oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v)) : + Multiset (Fin (2 * ℓ))) = + ↑(F.oddListAt o φ (blockVertex W v)) := by + rw [oddListOf_coe_multiset _ (oddSlots W F v) + (fun j => (mem_oddSlots j).trans + (blockRestrict_colouringOfFlip_isRight W F o ψ φ v + j).symm)] + rw [oddListAt_coe_multiset o φ (blockVertex W v)] + refine Eq.trans (Multiset.map_congr rfl ?_) + (Eq.trans (map_flagsAt_blockVertex W F v + (fun f => if o.isOut f.val = true + then oddPartner ℓ (φ.val f) else φ.val f)).symm ?_) + · intro j _ + exact (getRight_congr' + (blockRestrict_colouringOfFlip_mem W F o ψ φ v j.val + (oddSlot_mem j)) _ rfl).trans rfl + · refine congrArg (Multiset.map _) ?_ + refine congrArg Finset.val ?_ + ext f + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + +open Classical in +/-- **The block even multiset is the Definition 5 even-colour +multiset.** -/ +theorem evenMultisetOf_blockRestrict (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) (v : Fin (ds W).length) : + evenMultisetOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v) = + F.evenColoursAt ψ (blockVertex W v) := by + rw [evenMultisetOf_coe _ (evenSlots W F v) + (fun j => by + rw [mem_evenSlots] + constructor + · intro h + rw [blockRestrict_colouringOfFlip_not_mem W F o ψ φ + v j h] + rfl + · intro h hmem + rw [blockRestrict_colouringOfFlip_mem W F o ψ φ v j + hmem] at h + exact Bool.noConfusion h)] + rw [evenColoursAt_blockVertex W F ψ v] + refine Multiset.map_congr rfl ?_ + intro j _ + exact (getLeft_congr' + (blockRestrict_colouringOfFlip_not_mem W F o ψ φ v j.val + (blockSlot_not_mem j)) _ rfl).trans rfl + +open Classical in +/-- The block odd finset is the Definition 5 odd set. -/ +theorem oddFinsetOf_blockRestrict (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) (v : Fin (ds W).length) : + oddFinsetOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v) = + (F.oddListAt o φ (blockVertex W v)).toFinset := by + rw [oddFinsetOf, ← List.toFinset_coe, + oddListOf_blockRestrict W F o ψ φ v, List.toFinset_coe] + +open Classical in +/-- The block odd list is duplicate-free iff the Definition 5 +odd list is. -/ +theorem oddListOf_blockRestrict_nodup_iff (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) (v : Fin (ds W).length) : + (oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v)).Nodup ↔ + (F.oddListAt o φ (blockVertex W v)).Nodup := by + rw [← Multiset.coe_nodup, ← Multiset.coe_nodup, + oddListOf_blockRestrict W F o ψ φ v] + +/-- The cast rule for star coordinates. -/ +theorem starCoord_cast {R : ℕ} (f : EdgeRankParameter R) + (P : DelignePackage (SkeinObj f)) + (e' : P.ω.obj (SkeinObj.mk 1) ⟶ stdSuperPair k ℓ) + {d₁ d₂ : ℕ} (h : d₁ = d₂) + (c : MixedColouring k ℓ d₂) : + starCoord f P e' d₁ (c ∘ finCongr h) = + starCoord f P e' d₂ c := by + subst h + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockData.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockData.lean new file mode 100644 index 0000000000..79066f2afc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockData.lean @@ -0,0 +1,348 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij + +/-! +# Block data of the data colouring + +The flags of the v-th block enumerate the fragment's flags at the +block's vertex, and the block values of the data colouring are the +colouring data at those flags: participating flags carry the odd +colour (or its partner on partner slots), the rest the even colour. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {k ℓ : ℕ} + +/-- The flag of the j-th slot in the v-th block. -/ +noncomputable def blockFlag (W : ClosedFragment) + (v : Fin (ds W).length) (j : Fin ((ds W).get v)) : W.Flag := + (starFlagEnum W).symm (slotEmbed W v j) + +/-- Block flags sit at the block's vertex. -/ +theorem vertexOf_blockFlag (W : ClosedFragment) + (v : Fin (ds W).length) (j : Fin ((ds W).get v)) : + ClosedFragment.vertexOf W (blockFlag W v j) = + blockVertex W v := + vertexOf_slotEmbed W v j + +/-- The block-flag enumeration is injective. -/ +theorem blockFlag_injective (W : ClosedFragment) + (v : Fin (ds W).length) : + Function.Injective (blockFlag W v) := + fun _ _ h => slotEmbed_injective W v + ((starFlagEnum W).symm.injective h) + +open scoped Classical in +/-- **Block flags enumerate the vertex's flags**: the image of the +block-flag enumeration is the set of flags at the block's +vertex. -/ +theorem image_blockFlag (W : ClosedFragment) + (v : Fin (ds W).length) : + Finset.univ.image (blockFlag W v) = + Finset.univ.filter (fun g => + ClosedFragment.vertexOf W g = blockVertex W v) := by + ext g + simp only [Finset.mem_image, Finset.mem_filter, + Finset.mem_univ, true_and] + constructor + · rintro ⟨j, -, rfl⟩ + exact vertexOf_blockFlag W v j + · intro hvtx + have hassign : starAssignEnum W (starFlagEnum W g) = + finCongr (degList_length (starAssignEnum W)) v := by + change (Fintype.equivFin W.Vertex) + (starAssign W (starFlagEnum W g)) = _ + have hv : starAssign W (starFlagEnum W g) = + blockVertex W v := by + change ClosedFragment.vertexOf W + ((starFlagEnum W).symm (starFlagEnum W g)) = + blockVertex W v + rw [_root_.Equiv.symm_apply_apply, hvtx] + rw [hv, blockVertex, _root_.Equiv.apply_symm_apply] + have hfst : (sortSigma (starAssignEnum W) + (starFlagEnum W g)).1 = v := by + rw [sortSigma_fst, hassign] + exact Fin.ext rfl + set q := sortSigma (starAssignEnum W) (starFlagEnum W g) + with hq_def + obtain ⟨w, jw⟩ := q + simp only at hfst + rcases hfst with rfl + refine ⟨jw, ?_⟩ + change (starFlagEnum W).symm (slotEmbed W w jw) = g + rw [slotEmbed_recover W w (starFlagEnum W g) jw hq_def, + _root_.Equiv.symm_apply_apply] + +/-- **The block value of the data colouring**: the colouring data +at the block flag, with the odd partner on partner slots. -/ +theorem blockRestrict_colouringOf (W : ClosedFragment) + (F : EdgeSubset W) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) (v : Fin (ds W).length) + (j : Fin ((ds W).get v)) : + blockRestrict (ds W) + (cSorted W (colouringOf W F ψ φ)) v j = + (if h : blockFlag W v j ∈ F.flags then + Sum.inr (if (slotEmbed W v j).val < edgeCount W then + φ.val ⟨blockFlag W v j, h⟩ + else + oddPartner ℓ (φ.val ⟨blockFlag W v j, h⟩)) + else + Sum.inl (ψ.val ⟨blockFlag W v j, h⟩)) := by + rw [blockRestrict_val] + rfl + +/-- Non-participating block flags carry the even colour. -/ +theorem blockRestrict_colouringOf_not_mem (W : ClosedFragment) + (F : EdgeSubset W) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) (v : Fin (ds W).length) + (j : Fin ((ds W).get v)) + (h : blockFlag W v j ∉ F.flags) : + blockRestrict (ds W) + (cSorted W (colouringOf W F ψ φ)) v j = + Sum.inl (ψ.val ⟨blockFlag W v j, h⟩) := by + rw [blockRestrict_colouringOf, dite_eq_right h] + +/-- Participating block flags carry the odd colour or its +partner. -/ +theorem blockRestrict_colouringOf_mem (W : ClosedFragment) + (F : EdgeSubset W) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) (v : Fin (ds W).length) + (j : Fin ((ds W).get v)) + (h : blockFlag W v j ∈ F.flags) : + blockRestrict (ds W) + (cSorted W (colouringOf W F ψ φ)) v j = + Sum.inr (if (slotEmbed W v j).val < edgeCount W then + φ.val ⟨blockFlag W v j, h⟩ + else + oddPartner ℓ (φ.val ⟨blockFlag W v j, h⟩)) := by + rw [blockRestrict_colouringOf, dite_eq_left h] + +open Classical in +/-- The non-participating slots of a block. -/ +noncomputable def evenSlots (W : ClosedFragment) + (F : EdgeSubset W) (v : Fin (ds W).length) : + Finset (Fin ((ds W).get v)) := + Finset.univ.filter (fun j => blockFlag W v j ∉ F.flags) + +open Classical in +/-- Membership in the non-participating slots. -/ +theorem mem_evenSlots {W : ClosedFragment} {F : EdgeSubset W} + {v : Fin (ds W).length} (j : Fin ((ds W).get v)) : + j ∈ evenSlots W F v ↔ blockFlag W v j ∉ F.flags := by + rw [evenSlots, Finset.mem_filter] + exact ⟨fun h => h.2, fun h => ⟨Finset.mem_univ _, h⟩⟩ + +/-- The defining property of a non-participating block slot. -/ +theorem blockSlot_not_mem {W : ClosedFragment} + {F : EdgeSubset W} {v : Fin (ds W).length} + (j : {j : Fin ((ds W).get v) // j ∈ evenSlots W F v}) : + blockFlag W v j.val ∉ F.flags := + (Finset.mem_filter.mp j.prop).2 + +-- A filter over flags is matched against a filter +-- over block slots, so both attach-subtypes are unfolded. +open Classical in +/-- **The even colours at a block's vertex** are the even data at +the non-participating block slots. -/ +theorem evenColoursAt_blockVertex (W : ClosedFragment) + (F : EdgeSubset W) (ψ : F.EvenColouring k) + (v : Fin (ds W).length) : + F.evenColoursAt ψ (blockVertex W v) = + ((evenSlots W F v).attach.val).map + (fun j : {j : Fin ((ds W).get v) // + j ∈ evenSlots W F v} => + ψ.val ⟨blockFlag W v j.val, + blockSlot_not_mem j⟩) := by + set A := evenSlots W F v with hA + set B := Finset.univ.filter + (fun f : {f : W.Flag // f ∉ F.flags} => + W.attach f.val = Sum.inl (blockVertex W v)) with hB + have hforward : ∀ j : {j // j ∈ A}, + (⟨blockFlag W v j.val, blockSlot_not_mem j⟩ : + {f : W.Flag // f ∉ F.flags}) ∈ B := by + intro j + rw [hB, Finset.mem_filter] + refine ⟨Finset.mem_univ _, ?_⟩ + rw [ClosedFragment.attach_eq_vertexOf, vertexOf_blockFlag] + let toB : {j // j ∈ A} → + {f : {f : W.Flag // f ∉ F.flags} // f ∈ B} := + fun j => ⟨⟨blockFlag W v j.val, blockSlot_not_mem j⟩, + hforward j⟩ + have hinj : Function.Injective toB := by + intro j₁ j₂ h + have h1 : blockFlag W v j₁.val = blockFlag W v j₂.val := + congrArg (fun x => x.val.val) h + exact Subtype.ext (blockFlag_injective W v h1) + have hsurj : Function.Surjective toB := by + rintro ⟨⟨g, hg⟩, hgB⟩ + rw [hB, Finset.mem_filter] at hgB + have hvtx : ClosedFragment.vertexOf W g = + blockVertex W v := + Sum.inl.inj + ((ClosedFragment.attach_eq_vertexOf W g).symm.trans + hgB.2) + have hgmem : g ∈ Finset.univ.filter (fun g' => + ClosedFragment.vertexOf W g' = blockVertex W v) := by + rw [Finset.mem_filter] + exact ⟨Finset.mem_univ _, hvtx⟩ + rw [← image_blockFlag, Finset.mem_image] at hgmem + obtain ⟨j, -, hj⟩ := hgmem + have hjA : j ∈ A := by + rw [hA, mem_evenSlots, hj] + exact hg + exact ⟨⟨j, hjA⟩, Subtype.ext (Subtype.ext hj)⟩ + have h2 : B.val.map ψ.val = + B.attach.val.map (fun f => ψ.val f.val) := by + rw [Finset.attach_val] + exact (Multiset.attach_map_val' B.val ψ.val).symm + have h3 : B.attach.val.map (fun f => ψ.val f.val) = + A.attach.val.map + (fun j : {j : Fin ((ds W).get v) // + j ∈ evenSlots W F v} => + ψ.val ⟨blockFlag W v j.val, + blockSlot_not_mem j⟩) := by + rw [← Finset.univ_eq_attach, ← Finset.univ_eq_attach, + ← Finset.map_univ_equiv (Equiv.ofBijective toB + ⟨hinj, hsurj⟩), Finset.map_val, Multiset.map_map] + rfl + have h1 : F.evenColoursAt ψ (blockVertex W v) = + B.val.map ψ.val := by + rw [hB] + unfold EdgeSubset.evenColoursAt + refine congrArg (fun s : Finset {f : W.Flag // f ∉ F.flags} => + Multiset.map ψ.val s.val) ?_ + ext f + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + exact h1.trans (h2.trans h3) + +open Classical in +/-- The participating slots of a block. -/ +noncomputable def oddSlots (W : ClosedFragment) + (F : EdgeSubset W) (v : Fin (ds W).length) : + Finset (Fin ((ds W).get v)) := + Finset.univ.filter (fun j => blockFlag W v j ∈ F.flags) + +open Classical in +/-- Membership in the participating slots. -/ +theorem mem_oddSlots {W : ClosedFragment} {F : EdgeSubset W} + {v : Fin (ds W).length} (j : Fin ((ds W).get v)) : + j ∈ oddSlots W F v ↔ blockFlag W v j ∈ F.flags := by + rw [oddSlots, Finset.mem_filter] + exact ⟨fun h => h.2, fun h => ⟨Finset.mem_univ _, h⟩⟩ + +/-- The defining property of a participating block slot. -/ +theorem oddSlot_mem {W : ClosedFragment} + {F : EdgeSubset W} {v : Fin (ds W).length} + (j : {j : Fin ((ds W).get v) // j ∈ oddSlots W F v}) : + blockFlag W v j.val ∈ F.flags := + (mem_oddSlots j.val).mp j.prop + +-- As for the even colours, for an arbitrary value function. +open Classical in +/-- **Participating flags at a block's vertex reindex over the +participating slots**, for any value function. -/ +theorem map_flagsAt_blockVertex {β : Type} (W : ClosedFragment) + (F : EdgeSubset W) (v : Fin (ds W).length) + (g : {f : W.Flag // f ∈ F.flags} → β) : + ((Finset.univ.filter + (fun f : {f : W.Flag // f ∈ F.flags} => + W.attach f.val = Sum.inl (blockVertex W v))).val).map + g = + ((oddSlots W F v).attach.val).map + (fun j : {j : Fin ((ds W).get v) // + j ∈ oddSlots W F v} => + g ⟨blockFlag W v j.val, oddSlot_mem j⟩) := by + set A := oddSlots W F v with hA + set B := Finset.univ.filter + (fun f : {f : W.Flag // f ∈ F.flags} => + W.attach f.val = Sum.inl (blockVertex W v)) with hB + have hforward : ∀ j : {j // j ∈ A}, + (⟨blockFlag W v j.val, oddSlot_mem j⟩ : + {f : W.Flag // f ∈ F.flags}) ∈ B := by + intro j + rw [hB, Finset.mem_filter] + refine ⟨Finset.mem_univ _, ?_⟩ + rw [ClosedFragment.attach_eq_vertexOf, vertexOf_blockFlag] + let toB : {j // j ∈ A} → + {f : {f : W.Flag // f ∈ F.flags} // f ∈ B} := + fun j => ⟨⟨blockFlag W v j.val, oddSlot_mem j⟩, + hforward j⟩ + have hinj : Function.Injective toB := by + intro j₁ j₂ h + have h1 : blockFlag W v j₁.val = blockFlag W v j₂.val := + congrArg (fun x => x.val.val) h + exact Subtype.ext (blockFlag_injective W v h1) + have hsurj : Function.Surjective toB := by + rintro ⟨⟨g', hg⟩, hgB⟩ + rw [hB, Finset.mem_filter] at hgB + have hvtx : ClosedFragment.vertexOf W g' = + blockVertex W v := + Sum.inl.inj + ((ClosedFragment.attach_eq_vertexOf W g').symm.trans + hgB.2) + have hgmem : g' ∈ Finset.univ.filter (fun g'' => + ClosedFragment.vertexOf W g'' = blockVertex W v) := by + rw [Finset.mem_filter] + exact ⟨Finset.mem_univ _, hvtx⟩ + rw [← image_blockFlag, Finset.mem_image] at hgmem + obtain ⟨j, -, hj⟩ := hgmem + have hjA : j ∈ A := by + rw [hA, mem_oddSlots, hj] + exact hg + exact ⟨⟨j, hjA⟩, Subtype.ext (Subtype.ext hj)⟩ + have h2 : B.val.map g = + B.attach.val.map (fun f => g f.val) := by + rw [Finset.attach_val] + exact (Multiset.attach_map_val' B.val g).symm + have h3 : B.attach.val.map (fun f => g f.val) = + A.attach.val.map + (fun j : {j : Fin ((ds W).get v) // + j ∈ oddSlots W F v} => + g ⟨blockFlag W v j.val, oddSlot_mem j⟩) := by + rw [← Finset.univ_eq_attach, ← Finset.univ_eq_attach, + ← Finset.map_univ_equiv (Equiv.ofBijective toB + ⟨hinj, hsurj⟩), Finset.map_val, Multiset.map_map] + rfl + exact h2.trans h3 + +/-- Vertex products reindex over blocks. -/ +theorem prod_blockVertex {M : Type*} [CommMonoid M] + (W : ClosedFragment) (g : W.Vertex → M) : + (∏ vtx : W.Vertex, g vtx) = + ∏ v : Fin (ds W).length, g (blockVertex W v) := + (Fintype.prod_equiv + ((finCongr (degList_length (starAssignEnum W))).trans + (Fintype.equivFin W.Vertex).symm) + (fun v => g (blockVertex W v)) g (fun _ => rfl)).symm + +/-- Participation of a block slot is participation of its flag. -/ +theorem blockRestrict_colouringOf_isRight (W : ClosedFragment) + (F : EdgeSubset W) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) (v : Fin (ds W).length) + (j : Fin ((ds W).get v)) : + (blockRestrict (ds W) + (cSorted W (colouringOf W F ψ φ)) v j).isRight = true ↔ + blockFlag W v j ∈ F.flags := by + constructor + · intro hr + by_contra hnot + rw [blockRestrict_colouringOf_not_mem W F ψ φ v j hnot] + at hr + exact Bool.noConfusion hr + · intro h + rw [blockRestrict_colouringOf_mem W F ψ φ v j h] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockOddList.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockOddList.lean new file mode 100644 index 0000000000..76fd80ce62 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockOddList.lean @@ -0,0 +1,105 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexValue +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FlagEnum + +/-! +# The block odd list, order-exactly + +The odd list of a block of the flipped data colouring is the +Definition 5 value map over the block-slot flag enumeration, +entry by entry. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {k ℓ : ℕ} + +-- The block's odd list is matched with the sorted +-- slot enumeration order-exactly, so the flip, the sort and the +-- block restriction are all unfolded together. +open Classical in +/-- **The block odd list is the value map of the block +enumeration** (order-exact). -/ +theorem oddListOf_blockRestrict_eq_map (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) (v : Fin (ds W).length) : + oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v) = + (blockOddFlagList W F v).map (defFiveValue o φ) := by + set b := blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v with hb + set L := (oddSlots W F v).sort (· ≤ ·) with hL + have hLmem : ∀ j, j ∈ L ↔ j ∈ oddSlots W F v := by + intro j + rw [hL, Finset.mem_sort] + have hpwlt : List.Pairwise (· < ·) L := by + have h1 : List.Pairwise (· ≤ ·) L := + Finset.pairwise_sort (r := (· ≤ ·)) + (s := oddSlots W F v) + have h2 : L.Nodup := Finset.sort_nodup _ _ + refine List.Pairwise.imp ?_ (List.Pairwise.and h1 h2) + intro a c hac + exact lt_of_le_of_ne hac.1 hac.2 + have hps : StrictMono (fun t : Fin L.length => L.get t) := by + intro t₁ t₂ ht + exact List.pairwise_iff_getElem.mp hpwlt t₁.val t₂.val + t₁.isLt t₂.isLt ht + have hmemflag : ∀ t : Fin L.length, + blockFlag W v (L.get t) ∈ F.flags := by + intro t + exact (mem_oddSlots (L.get t)).mp + ((hLmem (L.get t)).mp (L.get_mem t)) + have hvals : ∀ t : Fin L.length, + Sum.getRight? (b (L.get t)) = + some (defFiveValue o φ ⟨blockFlag W v (L.get t), + hmemflag t⟩) := by + intro t + rw [hb, blockRestrict_colouringOfFlip_mem W F o ψ φ v + (L.get t) (hmemflag t)] + rfl + have hnone : ∀ q : Fin ((ds W).get v), + (∀ t : Fin L.length, L.get t ≠ q) → + Sum.getRight? (b q) = none := by + intro q hq + have hqL : q ∉ L := by + intro hmem + obtain ⟨t, ht⟩ := List.mem_iff_get.mp hmem + exact hq t ht + have hqodd : blockFlag W v q ∉ F.flags := by + intro hmem + exact hqL ((hLmem q).mpr ((mem_oddSlots q).mpr hmem)) + rw [hb, blockRestrict_colouringOfFlip_not_mem W F o ψ φ + v q hqodd] + rfl + have hmain : oddListOf b = List.ofFn + (fun t : Fin L.length => defFiveValue o φ + ⟨blockFlag W v (L.get t), hmemflag t⟩) := by + rw [oddListOf] + exact filterMap_ofFn_sorted hps hvals hnone + rw [hmain] + rw [show blockOddFlagList W F v = L.pmap + (fun j hj => (⟨blockFlag W v j, + (mem_oddSlots j).mp hj⟩ : + {f : W.Flag // f ∈ F.flags})) + (fun _ hj => (Finset.mem_sort _).mp hj) from rfl] + rw [List.map_pmap] + refine List.ext_getElem ?_ ?_ + · rw [List.length_ofFn, List.length_pmap] + · intro i hi₁ hi₂ + rw [List.getElem_ofFn, List.getElem_pmap] + refine congrArg (defFiveValue o φ) (Subtype.ext ?_) + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockParity.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockParity.lean new file mode 100644 index 0000000000..25074d9f20 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockParity.lean @@ -0,0 +1,257 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.Reindex + +/-! +# Block parity dictionary + +The parity bridge between vertex blocks of the sorted colouring +and flag-degrees of the colouring's pattern: the v-th block of the +sorted colouring is even iff the pattern-flags at the +corresponding vertex have even count. Corollary: the master +summand vanishes whenever any block is odd-parity. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {k ℓ : ℕ} + +/-- The vertex corresponding to the v-th block of the sorted +colouring: applying the vertex enumeration to the block index. -/ +noncomputable def blockVertex (W : ClosedFragment) + (v : Fin (degList (starAssignEnum W)).length) : W.Vertex := + (Fintype.equivFin W.Vertex).symm + (finCongr (degList_length (starAssignEnum W)) v) + +/-- The degree list of the star assignment: one entry per vertex, +recording how many slots it carries. -/ +noncomputable abbrev ds (W : ClosedFragment) := + degList (starAssignEnum W) + +/-- A colouring read in block order: slot `j` of block `v` gets the +colour the original colouring gave that vertex's `j`th flag. -/ +noncomputable abbrev cSorted + (W : ClosedFragment) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) : + MixedColouring k ℓ (ds W).sum := + (c ∘ finCongr (degList_sum (starAssignEnum W))) ∘ + sortSplitPerm W + +/-- The slot a block position occupies in the unsorted colouring. -/ +noncomputable def slotEmbed (W : ClosedFragment) + (v : Fin (ds W).length) (j : Fin ((ds W).get v)) : + Fin (edgeCount W + edgeCount W) := + (sortEquiv (starAssignEnum W)).symm + (blockSigmaEquiv (ds W) ⟨v, j⟩) + +/-- The sorted colouring at a block position equals the original +colouring at the unsorted slot. -/ +theorem blockRestrict_val (W : ClosedFragment) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) + (v : Fin (ds W).length) + (j : Fin ((ds W).get v)) : + blockRestrict (ds W) (cSorted W c) v j = + c (slotEmbed W v j) := by + -- Both sides apply c to the same Fin value + apply congrArg c + -- Need: finCongr _ (sortSplitPerm W x) = (sortEquiv _).symm x + -- By sortEquiv_symm_split: (sortEquiv _).symm = (sortSplitPerm W).trans + -- (finCongr _) + -- So (sortEquiv _).symm x = finCongr _ (sortSplitPerm W x) + suffices h : (sortEquiv (starAssignEnum W)).symm + (blockSigmaEquiv (ds W) ⟨v, j⟩) = + finCongr (degList_sum (starAssignEnum W)) + ((sortSplitPerm W) (blockSigmaEquiv (ds W) ⟨v, j⟩)) from + h.symm + exact congrFun (congrArg _root_.Equiv.toFun + (sortEquiv_symm_split W)) _ + +/-- The assignment at an embedded slot equals the block index +(up to `finCongr`). -/ +theorem assign_slotEmbed (W : ClosedFragment) + (v : Fin (ds W).length) (j : Fin ((ds W).get v)) : + starAssignEnum W (slotEmbed W v j) = + finCongr (degList_length (starAssignEnum W)) v := by + have h1 := blockAssign_sortEquiv (starAssignEnum W) + (slotEmbed W v j) + have h2 : sortEquiv (starAssignEnum W) (slotEmbed W v j) = + blockSigmaEquiv (ds W) ⟨v, j⟩ := + _root_.Equiv.apply_symm_apply _ _ + rw [h2, blockAssign_blockSigmaEquiv] at h1 + -- h1 : v = finCongr (degList_length _).symm (starAssignEnum W _) + apply Fin.ext + rw [finCongr_apply_coe] + exact (congrArg Fin.val h1).symm + +/-- The vertex at an embedded slot is the block's vertex. -/ +theorem vertexOf_slotEmbed (W : ClosedFragment) + (v : Fin (ds W).length) (j : Fin ((ds W).get v)) : + ClosedFragment.vertexOf W + ((starFlagEnum W).symm (slotEmbed W v j)) = + blockVertex W v := by + -- vertexOf at (starFlagEnum).symm s is starAssign W s by def + -- starAssign W s = (equivFin).symm (starAssignEnum W s) by def + apply (Fintype.equivFin W.Vertex).injective + -- Goal: equivFin (vertexOf W ((starFlagEnum W).symm (slotEmbed W v j))) + -- = equivFin (blockVertex W v) + change starAssignEnum W (slotEmbed W v j) = + (Fintype.equivFin W.Vertex) (blockVertex W v) + rw [assign_slotEmbed, blockVertex, _root_.Equiv.apply_symm_apply] + +/-- The slot embedding is injective in its block-offset +argument. -/ +theorem slotEmbed_injective (W : ClosedFragment) + (v : Fin (ds W).length) : + Function.Injective (slotEmbed W v) := by + intro j₁ j₂ h + have h1 : blockSigmaEquiv (ds W) ⟨v, j₁⟩ = + blockSigmaEquiv (ds W) ⟨v, j₂⟩ := + _root_.Equiv.injective (sortEquiv (starAssignEnum W)).symm h + have h2 : (⟨v, j₁⟩ : Σ _w : Fin (ds W).length, + Fin ((ds W).get _w)) = ⟨v, j₂⟩ := + _root_.Equiv.injective (blockSigmaEquiv (ds W)) h1 + rw [Sigma.mk.injEq] at h2 + exact eq_of_heq h2.2 + +/-- The slot embedding recovers the original slot from the +sigma decomposition. -/ +theorem slotEmbed_recover (W : ClosedFragment) + (v : Fin (ds W).length) + (s : Fin (edgeCount W + edgeCount W)) + (jw : Fin ((ds W).get v)) + (hq : (⟨v, jw⟩ : Σ _w : Fin (ds W).length, + Fin ((ds W).get _w)) = + sortSigma (starAssignEnum W) s) : + slotEmbed W v jw = s := by + change (sortEquiv (starAssignEnum W)).symm + (blockSigmaEquiv (ds W) ⟨v, jw⟩) = s + have hbe : blockSigmaEquiv (ds W) ⟨v, jw⟩ = + sortEquiv (starAssignEnum W) s := by + change blockSigmaEquiv (ds W) ⟨v, jw⟩ = + ((sortSigma (starAssignEnum W)).trans + (blockSigmaEquiv (ds W))) s + rw [_root_.Equiv.trans_apply, ← hq] + rw [hbe, _root_.Equiv.symm_apply_apply] + +open scoped Classical in +/-- **Block parity**: the v-th block of the sorted colouring has +the same odd-set cardinality as the pattern-flags at the +corresponding vertex. -/ +theorem blockRestrict_oddSet_card (W : ClosedFragment) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) + (v : Fin (ds W).length) : + (blockRestrict (ds W) (cSorted W c) v).oddSet.card = + ((colourFlags W c).filter + (fun g => ClosedFragment.vertexOf W g = + blockVertex W v)).card := by + refine Finset.card_bij + (fun j _hj => (starFlagEnum W).symm (slotEmbed W v j)) + ?mem ?inj ?surj + case mem => + intro j hj + simp only [mem_filter] + constructor + · -- the flag is in colourFlags W c + rw [colourFlags, Finset.mem_image] + refine ⟨slotEmbed W v j, ?_, rfl⟩ + simp only [MixedColouring.oddSet, mem_filter, mem_univ, + true_and] at hj ⊢ + rwa [blockRestrict_val] at hj + · exact vertexOf_slotEmbed W v j + case inj => + intro j₁ _hj₁ j₂ _hj₂ h + exact slotEmbed_injective W v + (_root_.Equiv.injective (starFlagEnum W).symm h) + case surj => + intro g hg + simp only [mem_filter] at hg + obtain ⟨hcf, hvtx⟩ := hg + -- g ∈ colourFlags W c: extract the slot s + rw [colourFlags, Finset.mem_image] at hcf + obtain ⟨s, hs, hsg⟩ := hcf + -- s ∈ oddSet c, and (starFlagEnum W).symm s = g + -- The assignment of s matches block v + have hassign : starAssignEnum W s = + finCongr (degList_length (starAssignEnum W)) v := by + change (Fintype.equivFin W.Vertex) (starAssign W s) = _ + have hv : starAssign W s = blockVertex W v := by + change ClosedFragment.vertexOf W + ((starFlagEnum W).symm s) = blockVertex W v + rw [hsg, hvtx] + rw [hv, blockVertex, _root_.Equiv.apply_symm_apply] + -- sortSigma has first component v + have hfst : (sortSigma (starAssignEnum W) s).1 = v := by + rw [sortSigma_fst, hassign]; exact Fin.ext rfl + -- Decompose the sigma and substitute to get j in the right + -- type + set q := sortSigma (starAssignEnum W) s with hq_def + obtain ⟨w, jw⟩ := q + simp only at hfst + -- hfst : w = v; eliminate w + rcases hfst with rfl + -- After rcases: v is replaced by w throughout + -- jw : Fin ((ds W).get w), hq_def : ⟨w, jw⟩ = sortSigma ... + refine ⟨jw, ?_, ?_⟩ + · -- jw ∈ oddSet (blockRestrict ...) + simp only [MixedColouring.oddSet, mem_filter, mem_univ, + true_and, blockRestrict_val] + rw [slotEmbed_recover W w s jw hq_def] + simp only [MixedColouring.oddSet, mem_filter, mem_univ, + true_and] at hs + exact hs + · -- the map sends jw to g + show (starFlagEnum W).symm (slotEmbed W w jw) = g + rw [slotEmbed_recover W w s jw hq_def, hsg] + +open scoped Classical in +/-- **Block parity dictionary**: the v-th block of the sorted +colouring is even iff the pattern-flags at the corresponding +vertex have even count. -/ +theorem blockRestrict_parity (W : ClosedFragment) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) + (v : Fin (ds W).length) : + MixedColouring.IsEven + (blockRestrict (ds W) (cSorted W c) v) ↔ + Even ((colourFlags W c).filter + (fun g => ClosedFragment.vertexOf W g = + blockVertex W v)).card := by + unfold MixedColouring.IsEven + rw [blockRestrict_oddSet_card] + +/-- **Master summand vanishing**: if any block of the sorted +colouring is odd-parity, the master summand is zero, since the +star coordinate vanishes on odd-parity colourings and the product +absorbs the zero. -/ +theorem masterSummand_vanish_of_block_odd + {R : ℕ} (f : EdgeRankParameter R) + (P : DelignePackage (SkeinObj f)) + (e' : P.ω.obj (SkeinObj.mk 1) ⟶ stdSuperPair k ℓ) + (W : ClosedFragment) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) + (v : Fin (degList (starAssignEnum W)).length) + (hodd : ¬ MixedColouring.IsEven + (blockRestrict (degList (starAssignEnum W)) + ((c ∘ finCongr (degList_sum (starAssignEnum W))) ∘ + sortSplitPerm W) v)) : + masterSummand f P e' W c = 0 := by + unfold masterSummand + have hzero : starCoord f P e' + ((degList (starAssignEnum W)).get v) + (blockRestrict (degList (starAssignEnum W)) + ((c ∘ finCongr (degList_sum (starAssignEnum W))) ∘ + sortSplitPerm W) v) = 0 := + starCoord_odd f P e' _ _ hodd + rw [Finset.prod_eq_zero (Finset.mem_univ v) hzero, mul_zero, + zero_mul] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockRestrict.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockRestrict.lean new file mode 100644 index 0000000000..54bf6cf4d2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockRestrict.lean @@ -0,0 +1,87 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourWord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapVal + +/-! +# Block restrictions of colourings + +Restricting a colouring of a concatenated total to its blocks +through the block enumeration, with the enumeration's value laws +at a cons: the vocabulary in which the assembled star vector's +coordinates factor over the vertices. +-/ + +@[expose] public section + +namespace RS + +/-- The head-block values of the enumeration. -/ +theorem blockSigmaEquiv_cons_zero_val (d : ℕ) (ds : List ℕ) + (j : Fin d) : + ((blockSigmaEquiv (d :: ds)) + ⟨⟨0, by simp⟩, j⟩).val = j.val := rfl + +/-- The tail-block values of the enumeration. -/ +theorem blockSigmaEquiv_cons_succ_val (d : ℕ) (ds : List ℕ) + (v : Fin ds.length) (j : Fin (ds.get v)) : + ((blockSigmaEquiv (d :: ds)) ⟨v.succ, j⟩).val = + d + ((blockSigmaEquiv ds) ⟨v, j⟩).val := rfl + +variable {k ℓ : ℕ} + +/-- The block restriction of a colouring. -/ +noncomputable def blockRestrict (ds : List ℕ) + (c : MixedColouring k ℓ ds.sum) (v : Fin ds.length) : + MixedColouring k ℓ (ds.get v) := fun j => + c (blockSigmaEquiv ds ⟨v, j⟩) + +/-- The sigma position is strictly monotone in the block +offset. -/ +theorem blockSigmaEquiv_strictMono : + ∀ (ds : List ℕ) (v : Fin ds.length), + StrictMono (fun j : Fin (ds.get v) => + blockSigmaEquiv ds ⟨v, j⟩) + | [], v => v.elim0 + | d :: ds, v => by + match v with + | ⟨0, hv⟩ => + intro j₁ j₂ hj + change blockSigmaEquiv (d :: ds) ⟨⟨0, hv⟩, j₁⟩ < + blockSigmaEquiv (d :: ds) ⟨⟨0, hv⟩, j₂⟩ + rw [Fin.lt_def] + have h1 : (blockSigmaEquiv (d :: ds) + ⟨⟨0, hv⟩, j₁⟩).val = j₁.val := rfl + have h2 : (blockSigmaEquiv (d :: ds) + ⟨⟨0, hv⟩, j₂⟩).val = j₂.val := rfl + rw [h1, h2] + exact hj + | ⟨w + 1, hv⟩ => + intro j₁ j₂ hj + have hw : w < ds.length := by + have h := hv + simp only [List.length_cons] at h + omega + have hrec := blockSigmaEquiv_strictMono ds ⟨w, hw⟩ hj + change blockSigmaEquiv (d :: ds) ⟨⟨w + 1, hv⟩, j₁⟩ < + blockSigmaEquiv (d :: ds) ⟨⟨w + 1, hv⟩, j₂⟩ + rw [Fin.lt_def] + have h1 : (blockSigmaEquiv (d :: ds) + ⟨⟨w + 1, hv⟩, j₁⟩).val = + d + ((blockSigmaEquiv ds) ⟨⟨w, hw⟩, j₁⟩).val := rfl + have h2 : (blockSigmaEquiv (d :: ds) + ⟨⟨w + 1, hv⟩, j₂⟩).val = + d + ((blockSigmaEquiv ds) ⟨⟨w, hw⟩, j₂⟩).val := rfl + have hrec' : blockSigmaEquiv ds ⟨⟨w, hw⟩, j₁⟩ < + blockSigmaEquiv ds ⟨⟨w, hw⟩, j₂⟩ := hrec + rw [h1, h2] + rw [Fin.lt_def] at hrec' + omega + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSigma.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSigma.lean new file mode 100644 index 0000000000..ca03f955a2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSigma.lean @@ -0,0 +1,125 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPeel + +/-! +# The block sigma equivalence + +The block enumeration pairs a block index with an offset within the +block to enumerate the concatenated total. +-/ + +@[expose] public section + +namespace RS + +/-- Split the sigma over a cons list into head + tail. -/ +def blockSigmaSplitFun (d : ℕ) (ds : List ℕ) : + (Σ v : Fin (ds.length + 1), Fin ((d :: ds).get v)) → + Fin d ⊕ (Σ w : Fin ds.length, Fin (ds.get w)) + | ⟨⟨0, _⟩, j⟩ => Sum.inl j + | ⟨⟨v + 1, hv⟩, j⟩ => Sum.inr ⟨⟨v, by omega⟩, j⟩ + +/-- Inverse of the split. -/ +def blockSigmaSplitInv (d : ℕ) (ds : List ℕ) : + Fin d ⊕ (Σ w : Fin ds.length, Fin (ds.get w)) → + (Σ v : Fin (ds.length + 1), Fin ((d :: ds).get v)) + | Sum.inl j => ⟨⟨0, by omega⟩, j⟩ + | Sum.inr ⟨w, j⟩ => ⟨w.succ, j⟩ + +/-- The sigma over a cons list splits as head + tail. -/ +def blockSigmaSplit (d : ℕ) (ds : List ℕ) : + (Σ v : Fin (ds.length + 1), Fin ((d :: ds).get v)) ≃ + Fin d ⊕ (Σ w : Fin ds.length, Fin (ds.get w)) where + toFun := blockSigmaSplitFun d ds + invFun := blockSigmaSplitInv d ds + left_inv := by + rintro ⟨⟨v, hv⟩, j⟩ + match v with + | 0 => rfl + | v + 1 => rfl + right_inv := by + rintro (j | ⟨w, j⟩) + · rfl + · rfl + +/-- The block enumeration: a block index and an offset within the +block enumerate the concatenated total. -/ +noncomputable def blockSigmaEquiv : (ds : List ℕ) → + (Σ v : Fin ds.length, Fin (ds.get v)) ≃ Fin ds.sum + | [] => + haveI : IsEmpty (Σ v : Fin ([] : List ℕ).length, + Fin (([] : List ℕ).get v)) := + ⟨fun p => p.1.elim0⟩ + haveI : IsEmpty (Fin ([] : List ℕ).sum) := + ⟨fun i => i.elim0⟩ + Equiv.equivOfIsEmpty _ _ + | d :: ds => + (blockSigmaSplit d ds).trans + ((Equiv.sumCongr (Equiv.refl (Fin d)) (blockSigmaEquiv ds)).trans + (finSumFinEquiv.trans (finCongr (by simp [List.sum_cons])))) + +/-- The block enumeration lands in its own block. -/ +theorem blockAssign_blockSigmaEquiv (ds : List ℕ) + (p : Σ v : Fin ds.length, Fin (ds.get v)) : + blockAssign ds (blockSigmaEquiv ds p) = p.1 := by + induction ds with + | nil => exact p.1.elim0 + | cons d ds ih => + obtain ⟨⟨v, hv⟩, j⟩ := p + match v with + | 0 => + -- p = ⟨⟨0, _⟩, j⟩ where j : Fin d + -- blockSigmaEquiv (d :: ds) ⟨⟨0, _⟩, j⟩ goes through: + -- split → inl j + -- sumCongr → inl j + -- finSumFinEquiv → castAdd ds.sum j + -- finCongr → same val + change blockAssign (d :: ds) (blockSigmaEquiv (d :: ds) ⟨⟨0, hv⟩, j⟩) = + ⟨0, hv⟩ + -- The equiv value has val = j.val < d + have hval : (blockSigmaEquiv (d :: ds) ⟨⟨0, hv⟩, j⟩).val = j.val := rfl + have hlt : (blockSigmaEquiv (d :: ds) ⟨⟨0, hv⟩, j⟩).val < d := by + rw [hval]; exact j.isLt + unfold blockAssign + rw [dite_eq_left hlt] + | v + 1 => + -- p = ⟨⟨v+1, hv⟩, j⟩ where j : Fin (ds.get ⟨v, _⟩) + change blockAssign (d :: ds) (blockSigmaEquiv (d :: ds) ⟨⟨v + 1, hv⟩, j⟩) = + ⟨v + 1, hv⟩ + -- The equiv value has val = d + (blockSigmaEquiv ds ⟨⟨v, _⟩, j⟩).val + have hlc : (d :: ds).length = ds.length + 1 := rfl + have hw : v < ds.length := by omega + have hval : (blockSigmaEquiv (d :: ds) ⟨⟨v + 1, hv⟩, j⟩).val = + d + (blockSigmaEquiv ds ⟨⟨v, hw⟩, j⟩).val := rfl + have hnlt : ¬ (blockSigmaEquiv (d :: ds) ⟨⟨v + 1, hv⟩, j⟩).val < d := by + rw [hval]; omega + unfold blockAssign + rw [dite_eq_right hnlt] + -- Goal: (blockAssign ds ⟨val - d, _⟩).succ = ⟨v + 1, hv⟩ + have hisLt : (blockSigmaEquiv (d :: ds) ⟨⟨v + 1, hv⟩, j⟩).val - d < ds.sum + := by + have := (blockSigmaEquiv (d :: ds) ⟨⟨v + 1, hv⟩, j⟩).isLt + simp only [List.sum_cons] at this + omega + suffices hsuff : blockAssign ds + (⟨(blockSigmaEquiv (d :: ds) ⟨⟨v + 1, hv⟩, j⟩).val - d, + hisLt⟩ : Fin ds.sum) = ⟨v, hw⟩ by + exact congrArg Fin.succ hsuff + have hsub : (blockSigmaEquiv (d :: ds) ⟨⟨v + 1, hv⟩, j⟩).val - d = + (blockSigmaEquiv ds ⟨⟨v, hw⟩, j⟩).val := by + rw [hval]; omega + have harg : (⟨(blockSigmaEquiv (d :: ds) ⟨⟨v + 1, hv⟩, j⟩).val - d, + hisLt⟩ : Fin ds.sum) = + blockSigmaEquiv ds ⟨⟨v, hw⟩, j⟩ := + Fin.ext hsub + rw [congrArg (blockAssign ds) harg] + exact ih ⟨⟨v, hw⟩, j⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSort.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSort.lean new file mode 100644 index 0000000000..22c6dd8074 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSort.lean @@ -0,0 +1,157 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPeel + +/-! +# Sorting a multi-star into blocks + +An arbitrary vertex assignment of a multi-star is sorted into +block form: the degree list records the fibre sizes in vertex +order, and the sort equivalence regroups the slots fibre by +fibre. Relabelling along the sort turns the multi-star into the +block-assigned form, ready for the block factorization. +-/ + +@[expose] public section + +namespace RS + +section Sorting + +variable {n m : ℕ} (assign : Fin n → Fin m) + +/-- The degree list of an assignment: fibre sizes in vertex +order. -/ +noncomputable def degList : List ℕ := + List.ofFn (fun v : Fin m => Fintype.card {i // assign i = v}) + +/-- The degree list has one entry per vertex. -/ +theorem degList_length : (degList assign).length = m := by + simp [degList] + +/-- Each entry is that vertex's fibre size. -/ +theorem degList_get (w : Fin (degList assign).length) : + (degList assign).get w = + Fintype.card {i // assign i = + finCongr (degList_length assign) w} := by + rw [List.get_eq_getElem] + simp only [degList] + rw [List.getElem_ofFn] + exact congrArg (fun v => Fintype.card {i // assign i = v}) + (Fin.ext rfl) + +/-- The fibre sizes sum to the total. -/ +theorem sum_card_fibres : + ∑ v : Fin m, Fintype.card {i // assign i = v} = n := by + rw [← Fintype.card_sigma, + Fintype.card_congr (_root_.Equiv.sigmaFiberEquiv assign), + Fintype.card_fin] + +/-- The degrees sum to the slot count: the fibres partition the +slots. -/ +theorem degList_sum : (degList assign).sum = n := by + rw [degList, List.sum_ofFn] + exact sum_card_fibres assign + +/-- The block-form index space has the right cardinality. -/ +theorem degList_card_sigma : + Fintype.card + (Σ w : Fin (degList assign).length, + Fin ((degList assign).get w)) = n := by + rw [Fintype.card_sigma] + rw [show ∑ w : Fin (degList assign).length, + Fintype.card (Fin ((degList assign).get w)) = + ∑ v : Fin m, Fintype.card {i // assign i = v} from + Fintype.sum_equiv (finCongr (degList_length assign)) _ _ + (fun w => by + rw [Fintype.card_fin, degList_get assign w])] + exact sum_card_fibres assign + +/-- The sort map: a slot goes to its vertex block at its +enumerated offset within the fibre. -/ +noncomputable def sortFun (i : Fin n) : + Σ w : Fin (degList assign).length, + Fin ((degList assign).get w) := + ⟨finCongr (degList_length assign).symm (assign i), + finCongr (degList_get assign _).symm + (Fintype.equivFin _ + ⟨i, (Fin.ext rfl : + assign i = finCongr (degList_length assign) + (finCongr (degList_length assign).symm + (assign i)))⟩)⟩ + +/-- The unsort map: read the fibre element back off. -/ +noncomputable def unsortFun + (p : Σ w : Fin (degList assign).length, + Fin ((degList assign).get w)) : Fin n := + ((Fintype.equivFin + {i // assign i = finCongr (degList_length assign) + p.1}).symm + (finCongr (degList_get assign p.1) p.2)).val + +/-- Unsorting undoes sorting. -/ +theorem unsort_sort (i : Fin n) : + unsortFun assign (sortFun assign i) = i := + congrArg Subtype.val + ((Fintype.equivFin + {j // assign j = finCongr (degList_length assign) + (sortFun assign i).1}).symm_apply_apply + ⟨i, Fin.ext rfl⟩) + +/-- So the sort is a bijection of slots. -/ +theorem sortFun_bijective : Function.Bijective (sortFun assign) := by + have hinj : Function.Injective (sortFun assign) := + Function.LeftInverse.injective (unsort_sort assign) + rw [Fintype.bijective_iff_injective_and_card] + exact ⟨hinj, by rw [Fintype.card_fin, degList_card_sigma]⟩ + +/-- **The sort equivalence** onto the block index space. -/ +noncomputable def sortSigma : + Fin n ≃ Σ w : Fin (degList assign).length, + Fin ((degList assign).get w) := + _root_.Equiv.ofBijective _ (sortFun_bijective assign) + +/-- The sorted slot's block index is its vertex. -/ +theorem sortSigma_fst (i : Fin n) : + (sortSigma assign i).1 = + finCongr (degList_length assign).symm (assign i) := rfl + +end Sorting + +section Relabel + +/-- **Sorting a multi-star**: a slot equivalence intertwining the +assignments (through a vertex identification) relabels one +multi-star onto the other. -/ +noncomputable def multiStarCompRelabel {V V' : Type} + [Fintype V] [Fintype V'] {n N : ℕ} + (assign : Fin n → V) (c : ℕ) (σ : Fin n ≃ Fin N) + (b : Fin N → V') (e : V ≃ V') + (hb : ∀ i, b (σ i) = e (assign i)) : + (multiStar assign c).Equiv + ((multiStar b c).relabel σ.symm) where + flagEquiv := _root_.Equiv.sumCongr σ σ + vertexEquiv := e + attach_comm := fun g => by + rcases g with i | i + · change Sum.inl (b (σ i)) = + (Sum.inl (assign i) : V ⊕ Fin n).map e id + rw [hb i] + rfl + · change Sum.inr (σ.symm (σ i)) = + (Sum.inr i : V ⊕ Fin n).map e id + rw [σ.symm_apply_apply] + rfl + pairing_comm := fun g => by + rcases g with i | i <;> rfl + circles_eq := rfl + +end Relabel + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BraidWord.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BraidWord.lean new file mode 100644 index 0000000000..77a847a90f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BraidWord.lean @@ -0,0 +1,140 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjSwapBmc + +/-! +# Bundle-map permutations through the model transport + +Composing the adjacent-swap collapse with the transport +intertwining along an adjacent-transposition word: the image of +any permutation bundle map conjugates through `stdToOmega` into +the corresponding word of model braidings. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open Functor.LaxMonoidal Functor.OplaxMonoidal + +/-- The adjacent transposition is the adjacent swap. -/ +theorem adjTrans_eq_adjSwap {n : ℕ} (i : Fin n) : + (adjTrans i : Fin (n + 1) ≃ Fin (n + 1)) = + adjSwapEquiv (n + 1) i.val (by omega) := by + unfold adjTrans adjSwapEquiv + rw [show Fin.castSucc i = (⟨i.val, by omega⟩ : Fin (n + 1)) + from Fin.ext rfl, + show Fin.succ i = (⟨i.val + 1, by omega⟩ : Fin (n + 1)) + from Fin.ext rfl] + +/-- The model-side braiding word. -/ +noncomputable def powBraidWord (V : SuperVect) {n : ℕ} : + List (Fin n) → (superPow V (n + 1) ⟶ superPow V (n + 1)) + | [] => 𝟙 _ + | i :: w => powBraidWord V w ≫ + powBraid V (n + 1) i.val (by omega) + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} +variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) + +/-- **The word intertwining**: the image of the word's product +bundle map conjugates into the model braiding word. -/ +theorem stdToOmega_bmc_word {n : ℕ} (w : List (Fin n)) : + letI := P.braided + stdToOmega f P e (n + 1) ≫ P.ω.map (bundleMapClass f + (((w.map adjTrans).prod : _root_.Equiv.Perm + (Fin (n + 1))) : Fin (n + 1) ≃ Fin (n + 1))) = + powBraidWord (stdSuperPair k ℓ) w ≫ + stdToOmega f P e (n + 1) := by + let := P.braided + induction w with + | nil => + rw [List.map_nil, List.prod_nil] + have hone : bundleMapClass f + (((1 : _root_.Equiv.Perm (Fin (n + 1))) : + Fin (n + 1) ≃ Fin (n + 1))) = + 𝟙 (SkeinObj.mk (n + 1) : SkeinObj f) := by + rw [show ((1 : _root_.Equiv.Perm (Fin (n + 1))) : + Fin (n + 1) ≃ Fin (n + 1)) = + _root_.Equiv.refl (Fin (n + 1)) from rfl] + exact bundleMapClass_refl f (n + 1) + rw [hone] + have hmapid : P.ω.map (𝟙 (SkeinObj.mk (n + 1) : + SkeinObj f)) = 𝟙 (P.ω.obj (SkeinObj.mk (n + 1))) := + P.ω.map_id _ + rw [hmapid] + change stdToOmega f P e (n + 1) ≫ 𝟙 _ = + 𝟙 _ ≫ stdToOmega f P e (n + 1) + rw [Category.comp_id, Category.id_comp] + | cons i w ih => + rw [List.map_cons, List.prod_cons] + have hmul : ((adjTrans i * (w.map adjTrans).prod : + _root_.Equiv.Perm (Fin (n + 1))) : + Fin (n + 1) ≃ Fin (n + 1)) = + (((w.map adjTrans).prod : _root_.Equiv.Perm + (Fin (n + 1))) : Fin (n + 1) ≃ Fin (n + 1)).trans + (adjTrans i) := rfl + rw [hmul] + have hbmc : bundleMapClass f + ((((w.map adjTrans).prod : _root_.Equiv.Perm + (Fin (n + 1))) : Fin (n + 1) ≃ Fin (n + 1)).trans + (adjTrans i)) = + HomSpace.comp f (n + 1) (n + 1) (n + 1) + (bundleMapClass f (((w.map adjTrans).prod : + _root_.Equiv.Perm (Fin (n + 1))) : + Fin (n + 1) ≃ Fin (n + 1))) + (bundleMapClass f (adjTrans i)) := + (bundleMapClass_comp f _ _).symm + rw [hbmc] + have hmapcomp : P.ω.map (HomSpace.comp f (n + 1) (n + 1) + (n + 1) + (bundleMapClass f (((w.map adjTrans).prod : + _root_.Equiv.Perm (Fin (n + 1))) : + Fin (n + 1) ≃ Fin (n + 1))) + (bundleMapClass f (adjTrans i))) = + P.ω.map (bundleMapClass f (((w.map adjTrans).prod : + _root_.Equiv.Perm (Fin (n + 1))) : + Fin (n + 1) ≃ Fin (n + 1))) ≫ + P.ω.map (bundleMapClass f (adjTrans i)) := + P.ω.map_comp _ _ + rw [hmapcomp] + have hswap : bundleMapClass f (adjTrans i) = + skeinPowBraid f (n + 1) i.val (by omega) := by + rw [adjTrans_eq_adjSwap] + exact (skeinPowBraid_bmc f (n + 1) i.val (by omega)).symm + rw [hswap] + refine ((Category.assoc _ _ _).symm).trans ?_ + refine (congrArg (fun z => z ≫ P.ω.map + (skeinPowBraid f (n + 1) i.val (by omega))) ih).trans ?_ + refine (Category.assoc _ _ _).trans ?_ + refine (congrArg (fun z => + powBraidWord (stdSuperPair k ℓ) w ≫ z) + (stdToOmega_powBraid f P e (n + 1) i.val + (by omega))).trans ?_ + exact (Category.assoc _ _ _).symm + +/-- **The permutation intertwining**: any permutation bundle map +conjugates into the model braiding word of its +adjacent-transposition word. -/ +theorem stdToOmega_bmc_perm {n : ℕ} + (σ : _root_.Equiv.Perm (Fin (n + 1))) : + letI := P.braided + stdToOmega f P e (n + 1) ≫ P.ω.map (bundleMapClass f + (σ : Fin (n + 1) ≃ Fin (n + 1))) = + powBraidWord (stdSuperPair k ℓ) (adjWord σ) ≫ + stdToOmega f P e (n + 1) := by + let := P.braided + have h := stdToOmega_bmc_word f P e (adjWord σ) + rw [adjWord_spec σ] at h + exact h + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonColour.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonColour.lean new file mode 100644 index 0000000000..61b11bfbb1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonColour.lean @@ -0,0 +1,59 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarSymm + +/-! +# The canonical colouring of multiset data + +A multiset of even colours and a set of odd colours assemble +into a canonical colouring: sorted even colours first, sorted +odd colours after. This is the representative through which the +vertex functional of Definition 5 evaluates the symmetric star +coordinates. +-/ + +@[expose] public section + +namespace RS + +variable {k ℓ : ℕ} + +/-- The canonical colouring: sorted even colours, then sorted +odd colours. -/ +noncomputable def canonColouring (μm : Multiset (Fin k)) + (F : Finset (Fin (2 * ℓ))) : + MixedColouring k ℓ (μm.card + F.card) := fun i => + if h : i.val < μm.card then + Sum.inl ((μm.sort (· ≤ ·)).get ⟨i.val, by + rw [Multiset.length_sort]; exact h⟩) + else + Sum.inr ((F.sort (· ≤ ·)).get ⟨i.val - μm.card, by + rw [Finset.length_sort] + have := i.isLt + omega⟩) + +/-- Low positions are even colours. -/ +theorem canonColouring_isRight_low (μm : Multiset (Fin k)) + (F : Finset (Fin (2 * ℓ))) + (i : Fin (μm.card + F.card)) (h : i.val < μm.card) : + (canonColouring μm F i).isRight = false := by + unfold canonColouring + rw [dite_eq_left h] + rfl + +/-- High positions are odd colours. -/ +theorem canonColouring_isRight_high (μm : Multiset (Fin k)) + (F : Finset (Fin (2 * ℓ))) + (i : Fin (μm.card + F.card)) (h : ¬ i.val < μm.card) : + (canonColouring μm F i).isRight = true := by + unfold canonColouring + rw [dite_eq_right h] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.lean new file mode 100644 index 0000000000..b516ac4be9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.lean @@ -0,0 +1,726 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ListSignPerm + +/-! +# The canonical permutation of colour data + +A mixed colouring of `d` slots splits into its even colours (a +multiset, since they may repeat) and its odd colours (a list, whose +order the summand's sign remembers). When the odd list is +duplicate-free the colouring is a permutation of the *canonical* +colouring at the same data — even colours sorted, odd colours in +increasing order — and the permutation's odd inversion count is the +odd list's own sorting sign. + +That is what lets the mixed summand be read off the data alone: the +functional sees only the multiset and the set, and the sign the +reindexing costs is exactly the one the list carries. +-/ + +@[expose] public section + +namespace RS + +open Equiv Finset + +variable {k ℓ : ℕ} + +/-! ## Colour data extraction -/ + +/-- The even colours of a mixed colouring, as a multiset: even +colours may repeat. -/ +noncomputable def evenMultisetOf {d : ℕ} (c : MixedColouring k ℓ d) + : Multiset (Fin k) := + ↑((List.ofFn c).filterMap Sum.getLeft?) + +/-- The odd colours, in slot order: the list whose sorting sign the +summand carries. -/ +noncomputable def oddListOf {d : ℕ} (c : MixedColouring k ℓ d) + : List (Fin (2 * ℓ)) := + (List.ofFn c).filterMap Sum.getRight? + +/-- The odd colours as a set — the index the functional is +evaluated at. -/ +noncomputable def oddFinsetOf {d : ℕ} (c : MixedColouring k ℓ d) + : Finset (Fin (2 * ℓ)) := + (oddListOf c).toFinset + +/-! ## Card bookkeeping -/ + +private theorem filterMap_sum_length {α β : Type*} (l : List (α ⊕ β)) : + (l.filterMap Sum.getLeft?).length + (l.filterMap Sum.getRight?).length = + l.length := by + induction l with + | nil => simp + | cons x t ih => + cases x with + | inl a => + rw [List.filterMap_cons_some (Sum.getLeft?_inl (β := β)), + List.filterMap_cons_none (Sum.getRight?_inl (α := α))] + simp only [List.length_cons]; omega + | inr b => + rw [List.filterMap_cons_none (Sum.getLeft?_inr (α := α)), + List.filterMap_cons_some (Sum.getRight?_inr (β := β))] + simp only [List.length_cons]; omega + +/-- The two parts account for every slot. -/ +theorem card_data {d : ℕ} (c : MixedColouring k ℓ d) : + d = (evenMultisetOf c).card + (oddListOf c).length := by + have hc : (evenMultisetOf c).card = + ((List.ofFn c).filterMap Sum.getLeft?).length := + Multiset.coe_card _ + have hd : (oddListOf c).length = + ((List.ofFn c).filterMap Sum.getRight?).length := rfl + rw [hc, hd]; have h := filterMap_sum_length (List.ofFn c) + rw [List.length_ofFn] at h; omega + +/-- When the odd list is duplicate-free its set has the same +size. -/ +theorem card_oddFinset {d : ℕ} (c : MixedColouring k ℓ d) + (hnodup : (oddListOf c).Nodup) : + (oddFinsetOf c).card = (oddListOf c).length := + List.toFinset_card_of_nodup hnodup + +/-! ## Colour value rank -/ + +private def colourValueRank (k : ℕ) : Fin k ⊕ Fin (2 * ℓ) → ℕ + | Sum.inl a => a.val + | Sum.inr b => k + b.val + +private theorem colourValueRank_injective : + Function.Injective (colourValueRank (ℓ := ℓ) k) := by + intro x y hxy + cases x with + | inl a => + cases y with + | inl b => simp only [colourValueRank] at hxy; exact congrArg Sum.inl (Fin.ext + hxy) + | inr b => simp [colourValueRank] at hxy; omega + | inr a => + cases y with + | inl b => simp [colourValueRank] at hxy; omega + | inr b => simp [colourValueRank] at hxy; exact congrArg Sum.inr + (Fin.ext (by omega)) + +/-! ## Colour rank for sorting -/ + +private noncomputable def colourRank {d : ℕ} (c : MixedColouring k ℓ d) (i : Fin + d) : ℕ := + match c i with + | Sum.inl a => a.val * d + i.val + | Sum.inr b => k * d + b.val * d + i.val + +private noncomputable def canonSortPerm {d : ℕ} (c : MixedColouring k ℓ d) : + Equiv.Perm (Fin d) := + Tuple.sort (colourRank c) + +/-! ## Monotonicity -/ + +private theorem vr_comp_sigma_mono {d : ℕ} (c : MixedColouring k ℓ d) (_hd : 0 < + d) : + Monotone (colourValueRank k ∘ c ∘ canonSortPerm c) := by + intro i j hij + have hmono : Monotone (colourRank c ∘ canonSortPerm c) := Tuple.monotone_sort + _ + have hm := hmono hij + simp only [Function.comp_apply] at hm ⊢ + set si := canonSortPerm c i + set sj := canonSortPerm c j + cases hci : c si with + | inl ai => + cases hcj : c sj with + | inl aj => + change ai.val ≤ aj.val + have hcri : colourRank c si = ai.val * d + si.val := + by unfold colourRank; rw [hci] + have hcrj : colourRank c sj = aj.val * d + sj.val := + by unfold colourRank; rw [hcj] + rw [hcri, hcrj] at hm + have hsi := si.isLt; have hsj := sj.isLt + nlinarith + | inr bj => + change ai.val ≤ k + bj.val + have hai := ai.isLt; omega + | inr bi => + cases hcj : c sj with + | inl aj => + exfalso + have hcri : colourRank c si = k * d + bi.val * d + si.val := by + unfold colourRank; rw [hci] + have hcrj : colourRank c sj = aj.val * d + sj.val := by + unfold colourRank; rw [hcj] + rw [hcri, hcrj] at hm + have haj := aj.isLt; have hsj := sj.isLt + nlinarith + | inr bj => + change k + bi.val ≤ k + bj.val + have hcri : colourRank c si = k * d + bi.val * d + si.val := by + unfold colourRank; rw [hci] + have hcrj : colourRank c sj = k * d + bj.val * d + sj.val := by + unfold colourRank; rw [hcj] + rw [hcri, hcrj] at hm + have hsi := si.isLt; have hsj := sj.isLt + nlinarith + +-- Monotonicity is checked on all four +-- even/odd cases of the canonical colouring. +private theorem vr_comp_canon_mono (μm : Multiset (Fin k)) (F : Finset (Fin (2 * + ℓ))) : + Monotone (colourValueRank k ∘ canonColouring μm F) := by + intro ⟨i, hi⟩ ⟨j, hj⟩ hij + simp only [Function.comp_apply] + unfold canonColouring + have hij' : i ≤ j := hij + simp only + split_ifs with h1 h2 h2 + · -- both left: sorted even values + change colourValueRank k (Sum.inl _) ≤ colourValueRank k (Sum.inl _) + simp only [colourValueRank] + have hpw := Multiset.pairwise_sort μm (· ≤ ·) + have hlen := show (μm.sort (· ≤ ·)).length = μm.card from by simp + exact hpw.sortedLE.monotone_get (Fin.mk_le_mk.mpr (by omega) : + (⟨i, hlen ▸ h1⟩ : Fin _) ≤ ⟨j, hlen ▸ h2⟩) + · -- left ≤ right + change colourValueRank k (Sum.inl _) ≤ colourValueRank k (Sum.inr _) + simp only [colourValueRank] + have hlen := show (μm.sort (· ≤ ·)).length = μm.card from by simp + have hlt := ((μm.sort (· ≤ ·)).get ⟨i, hlen ▸ h1⟩).isLt + omega + · -- right, left: impossible + exfalso; omega + · -- both right: sorted odd values + change colourValueRank k (Sum.inr _) ≤ colourValueRank k (Sum.inr _) + simp only [colourValueRank] + show k + _ ≤ k + _ + have hpw := Finset.pairwise_sort F (· ≤ ·) + have hlen := show (F.sort (· ≤ ·)).length = F.card from by simp + have hle := hpw.sortedLE.monotone_get (Fin.mk_le_mk.mpr (by omega) : + (⟨i - μm.card, hlen ▸ (by omega)⟩ : Fin _) ≤ + ⟨j - μm.card, hlen ▸ (by omega)⟩) + omega + +/-! ## Multiset decomposition -/ + +private theorem sum_list_perm {α β : Type*} : + ∀ (l : List (α ⊕ β)), + l.Perm ((l.filterMap Sum.getLeft?).map Sum.inl ++ + (l.filterMap Sum.getRight?).map Sum.inr) + | [] => List.Perm.refl _ + | Sum.inl a :: t => by + rw [List.filterMap_cons_some (Sum.getLeft?_inl (β := β)), + List.filterMap_cons_none (Sum.getRight?_inl (α := α)), + List.map_cons, List.cons_append] + exact List.Perm.cons _ (sum_list_perm t) + | Sum.inr b :: t => by + rw [List.filterMap_cons_none (Sum.getLeft?_inr (α := α)), + List.filterMap_cons_some (Sum.getRight?_inr (β := β)), + List.map_cons] + exact (List.Perm.cons _ (sum_list_perm t)).trans List.perm_middle.symm + +/-! ## Canon list structure -/ + +private theorem canon_as_concat (μm : Multiset (Fin k)) (F : Finset (Fin (2 * + ℓ))) + {d : ℕ} (h : d = μm.card + F.card) : + List.ofFn (canonColouring μm F ∘ finCongr h) = + (μm.sort (· ≤ ·)).map Sum.inl ++ (F.sort (· ≤ ·)).map Sum.inr := by + apply List.ext_getElem + · simp [List.length_ofFn, List.length_append, List.length_map, h] + · intro i hi1 hi2 + simp only [List.length_ofFn] at hi1 + rw [List.getElem_ofFn] + simp only [Function.comp_apply, canonColouring] + have hlen_l : (List.map (Sum.inl (β := Fin (2 * ℓ))) + (μm.sort (· ≤ ·))).length = μm.card := by simp + by_cases hlt : i < μm.card + · have hfin : (finCongr h ⟨i, hi1⟩).val < μm.card := by simp [hlt] + rw [dite_eq_left hfin, List.getElem_append_left (by omega)] + simp [List.getElem_map] + · have hfin : ¬ (finCongr h ⟨i, hi1⟩).val < μm.card := by simp [hlt] + rw [dite_eq_right hfin, List.getElem_append_right (by omega)] + simp [hlen_l, List.getElem_map] + +/-! ## Multiset equality between c and canon -/ + +private theorem nodup_toFinset_val {α : Type*} [DecidableEq α] + (l : List α) (hnd : l.Nodup) : l.toFinset.val = ↑l := by + rw [List.toFinset_val]; exact congrArg _ hnd.dedup + +private theorem multiset_perm_vr {d : ℕ} (c : MixedColouring k ℓ d) + (hnodup : (oddListOf c).Nodup) + (h : d = (evenMultisetOf c).card + (oddFinsetOf c).card) : + (List.ofFn (colourValueRank k ∘ c)).Perm + (List.ofFn (colourValueRank k ∘ canonColouring (evenMultisetOf c) + (oddFinsetOf c) ∘ finCongr h)) := by + -- Show list-level permutation, then map + have hcan := canon_as_concat (evenMultisetOf c) (oddFinsetOf c) h + -- hcan : ofFn (canon ∘ finCongr) = sorted_evens.map inl ++ sorted_odds.map + -- inr + -- Show ofFn c ~ ofFn (canon ∘ finCongr h) as lists + have hevens : (Multiset.sort (evenMultisetOf c) (· ≤ ·)).Perm + ((List.ofFn c).filterMap Sum.getLeft?) := + Multiset.coe_eq_coe.mp (Multiset.sort_eq (evenMultisetOf c) (· ≤ ·)) + have hodds : (Finset.sort (oddFinsetOf c) (· ≤ ·)).Perm (oddListOf c) := by + have hsort_eq := Finset.sort_eq (oddFinsetOf c) (· ≤ ·) + have hval : (oddFinsetOf c).val = (↑(oddListOf c) : Multiset _) := + nodup_toFinset_val (oddListOf c) hnodup + exact Multiset.coe_eq_coe.mp (hsort_eq.trans hval) + have hperm_raw : (List.ofFn c).Perm + (List.ofFn (canonColouring (evenMultisetOf c) (oddFinsetOf c) ∘ + finCongr h)) := by + rw [hcan] + exact (sum_list_perm (List.ofFn c)).trans + (List.Perm.append (hevens.symm.map Sum.inl) (hodds.symm.map Sum.inr)) + have := hperm_raw.map (colourValueRank k) + rwa [List.map_ofFn, List.map_ofFn] at this + +/-! ## Pair inversions -/ + +private def pairInv {n : ℕ} {β : Type*} [LinearOrder β] (g : Fin n → β) : ℕ := + (univ.filter (fun p : Fin n × Fin n => p.1 < p.2 ∧ g p.1 > g p.2)).card + +private theorem pairInv_perm_inv {n : ℕ} (f : Perm (Fin n)) : + pairInv (⇑f) = pairInv (⇑f.symm) := by + unfold pairInv + apply Finset.card_bij (fun p (_hp : p ∈ univ.filter _) => (f p.2, f p.1)) + · intro ⟨a, b⟩ hp + simp only [mem_filter, mem_univ, true_and] at hp ⊢ + exact ⟨hp.2, by simp only [Equiv.symm_apply_apply, gt_iff_lt]; exact hp.1⟩ + · intro ⟨a1, b1⟩ _ ⟨a2, b2⟩ _ heq + simp only [Prod.mk.injEq] at heq + exact Prod.ext (f.injective heq.2) (f.injective heq.1) + · intro ⟨i, j⟩ hmem + simp only [mem_filter, mem_univ, true_and] at hmem + refine ⟨(f.symm j, f.symm i), ?_, ?_⟩ + · simp only [mem_filter, mem_univ, true_and] + constructor + · exact hmem.2 + · change f (f.symm j) > f (f.symm i) + simp only [Equiv.apply_symm_apply, gt_iff_lt]; exact hmem.1 + · simp only [Prod.mk.injEq]; exact ⟨Equiv.apply_symm_apply f i, + Equiv.apply_symm_apply f j⟩ + +private theorem pairInv_congr_order {n : ℕ} {β γ : Type*} [LinearOrder β] + [LinearOrder γ] + {g₁ : Fin n → β} {g₂ : Fin n → γ} + (h : ∀ i j : Fin n, g₁ i > g₁ j ↔ g₂ i > g₂ j) : + pairInv g₁ = pairInv g₂ := by + unfold pairInv; congr 1 + exact Finset.filter_congr (fun ⟨i, j⟩ _ => and_congr_right' (h i j)) + +/-! ## Inversions helpers -/ + +private theorem card_filter_sum + {n : ℕ} (P : Fin n × Fin n → Prop) [DecidablePred P] : + (univ.filter P).card = ∑ i : Fin n, ∑ j : Fin n, if P (i, j) then (1 : ℕ) + else 0 := by + have h := (Finset.sum_boole (R := ℕ) P univ).symm + simp only [Nat.cast_id] at h; rw [h, Fintype.sum_prod_type] + +private theorem ofFn_filter_length {β : Type} [LinearOrder β] + {n : ℕ} (g : Fin n → β) (a : β) : + ((List.ofFn g).filter (· < a)).length = + (univ.filter (fun i : Fin n => g i < a)).card := by + have h1 : (List.ofFn g).filter (· < a) = + ((List.finRange n).filter (fun i => decide (g i < a))).map g := by + conv_lhs => rw [show List.ofFn g = (List.finRange n).map g + from List.map_ofFn.symm] + rw [List.filter_map]; rfl + rw [h1, List.length_map] + unfold Finset.card Finset.filter + simp [Finset.univ, Fintype.elems, List.finRange] + +private theorem pairInv_succ {β : Type} [LinearOrder β] + {n : ℕ} (g : Fin (n + 1) → β) : + pairInv g = (univ.filter (fun j : Fin n => g j.succ < g 0)).card + + pairInv (fun i : Fin n => g i.succ) := by + rw [show pairInv g = ∑ i : Fin (n + 1), ∑ j : Fin (n + 1), + if i < j ∧ g i > g j then (1 : ℕ) else 0 from card_filter_sum _] + rw [show pairInv (fun i : Fin n => g i.succ) = ∑ i : Fin n, ∑ j : Fin n, + if i < j ∧ g i.succ > g j.succ then (1 : ℕ) else 0 from card_filter_sum _] + rw [Fin.sum_univ_succ]; congr 1 + · rw [Fin.sum_univ_succ] + simp only [lt_irrefl, false_and, ite_false, zero_add] + simp_rw [show ∀ j : Fin n, ((0 : Fin (n + 1)) < j.succ ∧ g 0 > g j.succ) ↔ + g j.succ < g 0 from fun j => by simp [Fin.succ_pos, gt_iff_lt]] + rw [Finset.sum_boole (R := ℕ)]; simp [Nat.cast_id] + · congr 1; ext i + rw [Fin.sum_univ_succ] + simp only [show ¬(Fin.succ i < (0 : Fin (n + 1))) from not_lt.mpr + (Fin.zero_le _), + false_and, ite_false, zero_add] + congr 1; ext j; simp only [Fin.succ_lt_succ_iff] + +/-- `inversions (List.ofFn g) = pairInv g`. -/ +private theorem inversions_eq_pairInv {β : Type} [LinearOrder β] + {n : ℕ} (g : Fin n → β) : inversions (List.ofFn g) = pairInv g := by + induction n with + | zero => simp [List.ofFn_zero, inversions, pairInv] + | succ n ih => + rw [List.ofFn_succ, inversions, ih (fun i => g i.succ)] + rw [ofFn_filter_length (fun i => g i.succ) (g 0)] + rw [pairInv_succ g] + +/-! ## FilterMap structure lemma -/ + +/-- If `g ∘ f` is `some (vals t)` at positions `ps t` (strictly increasing) + and `none` + elsewhere, then `filterMap g (ofFn f)` equals `ofFn vals`. -/ +theorem filterMap_ofFn_sorted {β γ : Type*} + {d n : ℕ} {f : Fin d → β} {g : β → Option γ} + {ps : Fin n → Fin d} (hps : StrictMono ps) + {vals : Fin n → γ} + (hgfp : ∀ t, g (f (ps t)) = some (vals t)) + (hgfn : ∀ q : Fin d, (∀ t, ps t ≠ q) → g (f q) = none) : + (List.ofFn f).filterMap g = List.ofFn vals := by + induction d generalizing n with + | zero => + have : n = 0 := by + by_contra h; exact (ps ⟨0, Nat.pos_of_ne_zero h⟩).elim0 + subst this; rfl + | succ d ih => + rw [List.ofFn_succ] + cases hg0 : g (f 0) with + | none => + rw [List.filterMap_cons_none hg0] + have hpos : ∀ t, 0 < (ps t).val := by + intro t; by_contra hle; push Not at hle + have h0 : (ps t).val = 0 := Nat.le_zero.mp hle + have h1 := hgfp t + rw [show ps t = (0 : Fin (d + 1)) from Fin.ext h0] at h1 + simp [hg0] at h1 + have hbd : ∀ t, (ps t).val - 1 < d := by + intro t; have := (ps t).isLt; have := hpos t; omega + refine ih + (ps := fun t => ⟨(ps t).val - 1, hbd t⟩) ?_ ?_ ?_ + · intro a b hab + have ha := hpos a + have hlt : (ps a).val < (ps b).val := hps hab + change (ps a).val - 1 < (ps b).val - 1 + omega + · intro t + have heq : (⟨(ps t).val - 1, hbd t⟩ : Fin d).succ = ps t := by + apply Fin.ext; simp only [Fin.val_succ]; have := hpos t; omega + change g (f (⟨(ps t).val - 1, hbd t⟩ : Fin d).succ) = some (vals t) + rw [heq]; exact hgfp t + · intro q hne + show g (f q.succ) = none + apply hgfn q.succ; intro t ht; apply hne t + apply Fin.ext; change (ps t).val - 1 = q.val + have h1 : (ps t).val = q.succ.val := congrArg Fin.val ht + simp only [Fin.val_succ] at h1; omega + | some b => + have hn_pos : 0 < n := by + by_contra hle; push Not at hle + have hn0 : n = 0 := Nat.le_zero.mp hle + have : g (f (0 : Fin (d + 1))) = none := by + apply hgfn; intro ⟨t, ht⟩; exact absurd ht (by omega) + simp [this] at hg0 + have hps0 : ps ⟨0, hn_pos⟩ = (0 : Fin (d + 1)) := by + by_contra hne + have hge : 0 < (ps ⟨0, hn_pos⟩).val := by + by_contra hle; push Not at hle + exact hne (Fin.ext (Nat.le_zero.mp hle)) + have hall : ∀ t, ps t ≠ (0 : Fin (d + 1)) := by + intro t ht + have hle : (ps ⟨0, hn_pos⟩).val ≤ (ps t).val := + hps.monotone (show (⟨0, hn_pos⟩ : Fin n) ≤ t from Nat.zero_le _) + rw [show (ps t).val = 0 from congrArg Fin.val ht] at hle + omega + have := hgfn (0 : Fin (d + 1)) hall + simp [this] at hg0 + have hb : b = vals ⟨0, hn_pos⟩ := by + have h1 := hgfp ⟨0, hn_pos⟩; rw [hps0] at h1; rw [hg0] at h1 + exact Option.some.inj h1 + subst hb + rw [List.filterMap_cons_some hg0] + obtain ⟨n', rfl⟩ : ∃ n', n = n' + 1 := ⟨n - 1, by omega⟩ + conv_rhs => rw [List.ofFn_succ] + congr 1 + have hpos : ∀ t : Fin n', 0 < (ps t.succ).val := by + intro t + have h1 : (ps ⟨0, Nat.zero_lt_succ n'⟩).val < (ps t.succ).val := + hps (show (⟨0, Nat.zero_lt_succ n'⟩ : Fin (n' + 1)) < t.succ from by + change 0 < t.val + 1; omega) + simp only [hps0] at h1; exact h1 + have hbd : ∀ t : Fin n', (ps t.succ).val - 1 < d := by + intro t; have := (ps t.succ).isLt; have := hpos t; omega + refine ih + (ps := fun t : Fin n' => ⟨(ps t.succ).val - 1, hbd t⟩) ?_ ?_ ?_ + · intro a b hab + have ha := hpos a + have hlt : (ps a.succ).val < (ps b.succ).val := + hps (show a.succ < b.succ from by change a.val + 1 < b.val + 1; omega) + change (ps a.succ).val - 1 < (ps b.succ).val - 1 + omega + · intro t + have heq : (⟨(ps t.succ).val - 1, hbd t⟩ : Fin d).succ = ps t.succ := by + apply Fin.ext; simp only [Fin.val_succ]; have := hpos t; omega + change g (f (⟨(ps t.succ).val - 1, hbd t⟩ : Fin d).succ) = some (vals + t.succ) + rw [heq]; exact hgfp t.succ + · intro q hne + show g (f q.succ) = none + apply hgfn q.succ + intro ⟨t, ht⟩ + rcases t with _ | t' + · intro heq; rw [hps0] at heq + exact absurd (show (0 : Fin (d + 1)).val = q.succ.val from congrArg + Fin.val heq) + (by simp [Fin.val_succ]) + · intro heq; apply hne ⟨t', by omega⟩ + apply Fin.ext; change (ps (⟨t' + 1, ht⟩ : Fin (n' + 1))).val - 1 = q.val + have h1 : (ps ⟨t' + 1, ht⟩).val = q.succ.val := congrArg Fin.val heq + simp only [Fin.val_succ] at h1; omega + +/-! ## Sign clause -/ + +/-- The sign clause of `exists_canonPerm`. -/ +private theorem canonSortPerm_sign {d : ℕ} (c : MixedColouring k ℓ d) + (hnodup : (oddListOf c).Nodup) + (h : d = (evenMultisetOf c).card + (oddFinsetOf c).card) + (σ : Equiv.Perm (Fin d)) + (comp : c ∘ σ = canonColouring (evenMultisetOf c) (oddFinsetOf c) ∘ finCongr + h) : + ((-1 : ℂ) ^ oddInversions σ c = (sortSign (oddListOf c) : ℂ)) := by + -- ═══════ SETUP: THE HIGH-INDEX FUNCTION AND ITS SORT ═══════ + -- `g` reads the odd half of `σ`; `π` sorts it; `v` is the sorted + -- odd value sequence. + set m := (evenMultisetOf c).card with hm_def + set F := oddFinsetOf c with hF_def + set n := F.card with hn_def + have hlen : (oddListOf c).length = n := (card_oddFinset c hnodup).symm + have hdn : d = m + n := h + -- g : the high-index function + set g : Fin n → Fin d := fun t => σ ⟨m + t.val, by omega⟩ with hg_def + -- π : sorting permutation of g + set π := Tuple.sort g with hπ_def + -- v : sorted odd values + set v : Fin n → Fin (2 * ℓ) := fun t => + (F.sort (· ≤ ·)).get ⟨t.val, by rw [Finset.length_sort]; exact t.isLt⟩ with + hv_def + -- isRight characterisation from comp + have isRight_comp : ∀ j : Fin d, + (c (σ j)).isRight = decide (m ≤ j.val) := by + intro j + have hcj : c (σ j) = canonColouring (evenMultisetOf c) F (finCongr h j) := + congr_fun comp j + have hjval : (finCongr h j).val = j.val := by simp [finCongr_apply] + by_cases hjm : j.val < m + · rw [hcj, canonColouring_isRight_low _ _ _ (by rwa [hjval])] + simp [Nat.not_le.mpr hjm] + · rw [hcj, canonColouring_isRight_high _ _ _ (by rwa [hjval])] + simp [Nat.le_of_not_lt hjm] + -- g is injective + have g_inj : Function.Injective g := by + intro a b hab + have hinj := σ.injective hab + apply Fin.ext + show a.val = b.val + have := congrArg Fin.val hinj + simp only [Nat.add_left_cancel_iff] at this; exact this + -- g ∘ π is strictly monotone + have gπ_mono : Monotone (g ∘ π) := Tuple.monotone_sort g + have gπ_smono : StrictMono (g ∘ π) := fun a b hab => + lt_of_le_of_ne (gπ_mono hab.le) + (fun heq => hab.ne (π.injective (g_inj heq))) + -- ═══════ STAGE 1: THE INVERSIONS OF σ ARE THOSE OF g ═══════ + have step1 : oddInversions σ c = pairInv g := by + unfold oddInversions pairInv + refine Finset.card_bij + (fun (p : Fin d × Fin d) (hp : p ∈ _) => + ((⟨p.1.val - m, by + simp only [mem_filter, mem_univ, true_and] at hp + obtain ⟨_, _, hr1, _⟩ := hp + rw [isRight_comp] at hr1 + simp only [decide_eq_true_eq] at hr1; omega⟩ : Fin n), + (⟨p.2.val - m, by + simp only [mem_filter, mem_univ, true_and] at hp + obtain ⟨_, _, _, hr2⟩ := hp + rw [isRight_comp] at hr2 + simp only [decide_eq_true_eq] at hr2; omega⟩ : Fin n))) + ?_ ?_ ?_ + · -- image in target + intro ⟨p₁, p₂⟩ hp + simp only [mem_filter, mem_univ, true_and] at hp ⊢ + obtain ⟨hlt, hgt, hr1, hr2⟩ := hp + rw [isRight_comp] at hr1 hr2 + simp only [decide_eq_true_eq] at hr1 hr2 + constructor + · change p₁.val - m < p₂.val - m; omega + · have he1 : g ⟨p₁.val - m, by omega⟩ = σ p₁ := by + change σ ⟨m + (p₁.val - m), _⟩ = σ p₁ + congr 1; apply Fin.ext; change m + (p₁.val - m) = p₁.val; omega + have he2 : g ⟨p₂.val - m, by omega⟩ = σ p₂ := by + change σ ⟨m + (p₂.val - m), _⟩ = σ p₂ + congr 1; apply Fin.ext; change m + (p₂.val - m) = p₂.val; omega + rw [he1, he2]; exact hgt + · -- injective + intro ⟨a₁, b₁⟩ ha ⟨a₂, b₂⟩ hb heq + simp only [Prod.mk.injEq, Fin.mk.injEq] at heq + simp only [mem_filter, mem_univ, true_and] at ha hb + rw [isRight_comp] at ha hb + simp only [decide_eq_true_eq] at ha hb + have ha1 := ha.2.1; have ha2 := ha.2.2 + have hb1 := hb.2.1; have hb2 := hb.2.2 + exact Prod.ext (Fin.ext (by change a₁.val = a₂.val; omega)) + (Fin.ext (by change b₁.val = b₂.val; omega)) + · -- surjective + intro ⟨t₁, t₂⟩ ht + simp only [mem_filter, mem_univ, true_and] at ht + obtain ⟨hlt_t, hgt_t⟩ := ht + refine ⟨(⟨m + t₁.val, by omega⟩, ⟨m + t₂.val, by omega⟩), ?_, ?_⟩ + · simp only [mem_filter, mem_univ, true_and] + refine ⟨by change m + t₁.val < m + t₂.val; omega, hgt_t, ?_, ?_⟩ + · rw [isRight_comp]; simp [show m ≤ m + t₁.val from Nat.le_add_right _ + _] + · rw [isRight_comp]; simp [show m ≤ m + t₂.val from Nat.le_add_right _ + _] + · ext <;> simp + -- ═══════ STAGE 2: g AND ITS SORTING PERMUTATION INVERT ALIKE ═══════ + have step2 : pairInv g = pairInv (⇑π) := by + have h1 : pairInv g = pairInv (⇑π.symm) := pairInv_congr_order fun i j => by + constructor + · intro hij + by_contra hle; push Not at hle + exact absurd (gπ_smono.monotone hle) (by + simp only [Function.comp_apply, Equiv.apply_symm_apply]; + exact not_le.mpr hij) + · intro hij + have := gπ_smono hij + simp only [Function.comp_apply, Equiv.apply_symm_apply] at this + exact this + rw [h1]; exact (pairInv_perm_inv π).symm + -- ═══════ STAGE 3: THE ODD LIST IS `v ∘ π` ═══════ + -- Step 3: getRight? of c at sorted odd positions gives v ∘ π + have step3_some : ∀ t : Fin n, + Sum.getRight? (c (g (π t))) = some (v (π t)) := by + intro t + have hcj : c (σ ⟨m + (π t).val, _⟩) = + canonColouring (evenMultisetOf c) F (finCongr h ⟨m + (π t).val, _⟩) := + congr_fun comp ⟨m + (π t).val, by omega⟩ + simp only [hg_def] at hcj ⊢ + rw [hcj] + unfold canonColouring + have hge : ¬ (finCongr h ⟨m + (π t).val, by omega⟩).val < m := by + simp [finCongr_apply] + rw [dite_eq_right hge] + simp only [Sum.getRight?_inr, Option.some.injEq] + change (F.sort (· ≤ ·)).get + ⟨(finCongr h ⟨m + (π t).val, by omega⟩).val - m, _⟩ = v (π t) + have hval : (finCongr h ⟨m + (π t).val, by omega⟩).val - m = (π t).val := by + simp [finCongr_apply] + congr 1; apply Fin.ext; exact hval + -- Step 3b: getRight? of c at non-odd positions is none + have step3_none : ∀ q : Fin d, + (∀ t : Fin n, g (π t) ≠ q) → Sum.getRight? (c q) = none := by + intro q hne + have hq_low : (σ.symm q).val < m := by + by_contra hge; push Not at hge + have : g ⟨(σ.symm q).val - m, by omega⟩ = q := by + change σ ⟨m + ((σ.symm q).val - m), _⟩ = q + rw [show (⟨m + ((σ.symm q).val - m), _⟩ : Fin d) = σ.symm q from + Fin.ext (by change m + ((σ.symm q).val - m) = (σ.symm q).val; omega)] + exact σ.apply_symm_apply q + have hmem : q ∈ Set.range (g ∘ ⇑π) := by + rw [Set.range_comp] + exact ⟨⟨(σ.symm q).val - m, by omega⟩, Equiv.surjective π _, ‹_›⟩ + obtain ⟨s, hs⟩ := hmem + exact hne s hs + rw [show c q = c (σ (σ.symm q)) from by rw [Equiv.apply_symm_apply], + show c (σ (σ.symm q)) = + canonColouring (evenMultisetOf c) F (finCongr h (σ.symm q)) + from congr_fun comp _] + unfold canonColouring + rw [dite_eq_left (by simp only [finCongr_apply, Fin.val_cast]; exact hq_low)] + exact Sum.getRight?_inl + -- Step 3c: structural claim + have step3 : oddListOf c = List.ofFn (v ∘ π) := by + change (List.ofFn c).filterMap Sum.getRight? = List.ofFn (v ∘ π) + exact filterMap_ofFn_sorted (ps := fun t => g + (π t)) gπ_smono step3_some step3_none + -- ═══════ STAGE 4: v IS STRICTLY MONOTONE ═══════ + have v_smono : StrictMono v := by + intro a b hab + have hpw : List.Pairwise (· ≤ ·) (F.sort (· ≤ ·)) := F.pairwise_sort (· ≤ ·) + have hnd : (F.sort (· ≤ ·)).Nodup := F.sort_nodup (· ≤ ·) + have hslt : (F.sort (· ≤ ·)).SortedLT := hpw.sortedLE.sortedLT_of_nodup hnd + -- SortedLT = StrictMono l.get + exact hslt.strictMono_get (show (⟨a.val, _⟩ : Fin (F.sort (· ≤ ·)).length) < ⟨b.val, _⟩ + from hab) + -- ═══════ STAGE 5: THE ODD LIST'S INVERSIONS ARE π'S ═══════ + have step5 : inversions (oddListOf c) = pairInv (⇑π) := by + rw [step3, inversions_eq_pairInv] + exact pairInv_congr_order fun i j => + ⟨fun h => v_smono.lt_iff_lt.mp h, fun h => v_smono.lt_iff_lt.mpr h⟩ + -- ═══════ ASSEMBLY ═══════ + have key : oddInversions σ c = inversions (oddListOf c) := by + rw [step1, step2]; exact step5.symm + simp only [sortSign, key]; push_cast; ring + +/-! ## Main theorem -/ + +-- The permutation, its arity equality and its sign +-- are produced together, so the sort of the odd list and the +-- inversion count elaborate in one term. +/-- **The canonical permutation**: any colouring with a +duplicate-free odd list is a permutation of the canonical one at +its own data, and the permutation's odd inversion sign is exactly +the odd list's sorting sign. -/ +theorem exists_canonPerm {d : ℕ} (c : MixedColouring k ℓ d) + (hnodup : (oddListOf c).Nodup) : + ∃ (σ : Equiv.Perm (Fin d)) + (h : d = (evenMultisetOf c).card + (oddFinsetOf c).card), + (c ∘ σ = (canonColouring (evenMultisetOf c) (oddFinsetOf c)) ∘ finCongr h) + ∧ + ((-1 : ℂ) ^ oddInversions σ c = (sortSign (oddListOf c) : ℂ)) := by + set m := (evenMultisetOf c).card + have hnodup_card := card_oddFinset c hnodup + have h : d = m + (oddFinsetOf c).card := by + rw [hnodup_card]; exact card_data c + set n := (oddFinsetOf c).card + by_cases hd : d = 0 + · subst hd + refine ⟨1, h, ?_, ?_⟩ + · ext ⟨i, hi⟩; exact absurd hi (by omega) + · have hodd_nil : oddListOf c = [] := by + simp only [oddListOf] + rw [show List.ofFn c = ([] : List (Fin k ⊕ Fin (2 * ℓ))) from + List.eq_nil_of_length_eq_zero (by simp)] + simp + have hinv : oddInversions 1 c = 0 := by + simp only [oddInversions, Perm.one_apply, gt_iff_lt, + card_eq_zero, filter_eq_empty_iff, mem_univ, forall_true_left] + intro ⟨_, _⟩; rintro ⟨hlt, hgt, _⟩ + exact absurd (lt_trans hlt hgt) (lt_irrefl _) + rw [hinv, hodd_nil]; simp [sortSign, inversions] + · have hd' : 0 < d := Nat.pos_of_ne_zero hd + set σ := canonSortPerm c + set vr := colourValueRank (ℓ := ℓ) k + -- Composition proof + have comp : c ∘ σ = + canonColouring (evenMultisetOf c) (oddFinsetOf c) ∘ finCongr h := by + set canon_fn := canonColouring (evenMultisetOf c) (oddFinsetOf c) ∘ + finCongr h + have hmono1 : Monotone (vr ∘ c ∘ σ) := vr_comp_sigma_mono c hd' + have hmono2 : Monotone (vr ∘ canon_fn) := + (vr_comp_canon_mono (evenMultisetOf c) (oddFinsetOf c)).comp (fun _x _y + h => h) + have hs1 : (List.ofFn (vr ∘ c ∘ σ)).SortedLE := hmono1.sortedLE_ofFn + have hs2 : (List.ofFn (vr ∘ canon_fn)).SortedLE := hmono2.sortedLE_ofFn + have hperm : (List.ofFn (vr ∘ c ∘ σ)).Perm (List.ofFn (vr ∘ canon_fn)) := + (σ.ofFn_comp_perm (vr ∘ c)).trans (multiset_perm_vr c hnodup h) + have heq_list := hperm.eq_of_sortedLE hs1 hs2 + have heq_fn : vr ∘ c ∘ σ = vr ∘ canon_fn := List.ofFn_inj.mp heq_list + ext j; exact colourValueRank_injective (congr_fun heq_fn j) + exact ⟨σ, h, comp, canonSortPerm_sign c hnodup h σ comp⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapClosed.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapClosed.lean new file mode 100644 index 0000000000..0d392c2f68 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapClosed.lean @@ -0,0 +1,161 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelPermCoord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiag + +/-! +# The cap closed form + +The peel induction: the cap value on colour basis vectors is the +diagonal cap pairing. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open Functor.LaxMonoidal Functor.OplaxMonoidal +open scoped TensorProduct + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} + +-- The cap value is computed on a basis vector +-- through the fibre transport, which unfolds the tensorator, the +-- evaluation and the standard form together. +/-- **The cap closed form.** -/ +theorem capVal_closed + (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) + (hform : + letI := P.braided + SuperVect.Hom.comp + (μ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1) ≫ + P.ω.map (ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) ≫ η P.ω) + (SuperVect.tensorHom e e) = stdForm k ℓ) + (m : ℕ) : + ∀ (c : MixedColouring k ℓ (m + m)) (hc : c.IsEven), + capVal f P e m (evenBasisVec (⟨c, hc⟩ : + {c : MixedColouring k ℓ (m + m) // c.IsEven})) = + betaDiag m c := by + -- ═══════ INDUCTION ON THE NUMBER OF CAPS ═══════ + -- The zero cap reads off the scalar; each step peels one cap, + -- splits the value, and applies the smaller closed form. + induction m with + | zero => + intro c hc + rw [capVal_zero, evenBasisVec_zeroArity, betaDiag_zero] + | succ m ih => + intro c hc + let := P.braided + rw [capVal_succ, splitCapVal_expansion, betaDiag_succ] + have hterm : ∀ c' : + {c' : MixedColouring k ℓ ((m + m) + 2) // c'.IsEven}, + coordOf (((modelPermMap (capPeelPerm m) ≫ + eqToHom (congrArg (superPow (stdSuperPair k ℓ)) + (capPeelArity m))) : + SuperVect.Hom _ _).evenMap + (evenBasisVec (⟨c, hc⟩ : + {c : MixedColouring k ℓ + ((m + 1) + (m + 1)) // c.IsEven}))) c'.val = + wordSign (adjWord (capPeelPerm m)) + (c'.val ∘ ⇑(finCongr (capPeelArity m))) * + (if (c'.val ∘ ⇑(finCongr (capPeelArity m))) ∘ + ⇑(capPeelPerm m) = c then (1 : ℂ) else 0) := by + intro c' + rw [show (((modelPermMap (capPeelPerm m) ≫ + eqToHom (congrArg (superPow (stdSuperPair k ℓ)) + (capPeelArity m))) : + SuperVect.Hom _ _).evenMap + (evenBasisVec (⟨c, hc⟩ : + {c : MixedColouring k ℓ + ((m + 1) + (m + 1)) // c.IsEven}))) = + (((eqToHom (congrArg (superPow (stdSuperPair k ℓ)) + (capPeelArity m)) : + superPow (stdSuperPair k ℓ) ((m + 1) + (m + 1)) ⟶ + superPow (stdSuperPair k ℓ) ((m + m) + 2)) : + SuperVect.Hom _ _).evenMap + (((modelPermMap (capPeelPerm m)) : + SuperVect.Hom _ _).evenMap + (evenBasisVec ⟨c, hc⟩))) from rfl] + rw [coordOf_cast (capPeelArity m)] + rw [coordOf_modelPermMap] + rw [coordOf_evenBasisVec] + refine Eq.trans (Finset.sum_congr rfl + (fun c' _ => by rw [hterm c'])) ?_ + refine Eq.trans (Finset.sum_eq_single + (⟨peelColour m c, peelColour_isEven m hc⟩ : + {c' : MixedColouring k ℓ + ((m + m) + 2) // c'.IsEven}) ?_ ?_) ?_ + · intro b _ hb + rw [ite_eq_right (fun hspec => hb + (Subtype.ext (eq_peelColour_of m hspec)))] + rw [mul_zero, zero_mul] + · intro habs + exact absurd (Finset.mem_univ _) habs + · rw [ite_eq_left (peelColour_spec m c), mul_one] + congr 1 + rw [show evenBasisVec + (⟨peelColour m c, peelColour_isEven m hc⟩ : + {c' : MixedColouring k ℓ + ((m + m) + 2) // c'.IsEven}) = + evenBasisVec (⟨peelColour m c, + peelColour_isEven m hc⟩ : + {c' : MixedColouring k ℓ + ((m + m) + 2) // c'.IsEven}) from rfl] + by_cases hfh : MixedColouring.IsEven + (MixedColouring.firstHalf (a := m + m) (b := 2) + (peelColour m c)) + · rw [dite_eq_left hfh] + rw [show evenBasisVec + (⟨peelColour m c, peelColour_isEven m hc⟩ : + {c' : MixedColouring k ℓ + ((m + m) + 2) // c'.IsEven}) = + ((powMerge (stdSuperPair k ℓ) (m + m) 2) : + SuperVect.Hom _ _).evenMap + (evenPair + (evenBasisVec ⟨MixedColouring.firstHalf + (peelColour m c), hfh⟩) + (evenBasisVec ⟨MixedColouring.secondHalf + (peelColour m c), + (peelColour m c).secondHalf_isEven + (peelColour_isEven m hc) hfh⟩)) from by + rw [evenBasisVec_split (peelColour m c) + (peelColour_isEven m hc), dite_eq_left hfh]] + rw [splitCapVal_merge] + rw [ih (MixedColouring.firstHalf (peelColour m c)) hfh] + rw [omegaFun_ev_basis f P e hform + (MixedColouring.secondHalf (peelColour m c)) + ((peelColour m c).secondHalf_isEven + (peelColour_isEven m hc) hfh)] + · rw [dite_eq_right hfh] + rw [show evenBasisVec + (⟨peelColour m c, peelColour_isEven m hc⟩ : + {c' : MixedColouring k ℓ + ((m + m) + 2) // c'.IsEven}) = + ((powMerge (stdSuperPair k ℓ) (m + m) 2) : + SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) + (m + m)).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) 2).even), + oddBasisVec ⟨MixedColouring.firstHalf + (peelColour m c), hfh⟩ ⊗ₜ[ℂ] + oddBasisVec ⟨MixedColouring.secondHalf + (peelColour m c), + (peelColour m c).secondHalf_not_isEven' + (peelColour_isEven m hc) hfh⟩) : + (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) (m + m)) + (superPow (stdSuperPair k ℓ) 2)).even) from by + rw [evenBasisVec_split (peelColour m c) + (peelColour_isEven m hc), dite_eq_right hfh]] + rw [splitCapVal_oddMerge] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapExpansion.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapExpansion.lean new file mode 100644 index 0000000000..8d43d44322 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapExpansion.lean @@ -0,0 +1,44 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvLeaf + +/-! +# The cap value in coordinates + +The cap value of an even vector is the coordinate-weighted sum of +the cap values of the colour basis vectors: linearity through the +coordinate expansion. +-/ + +@[expose] public section + +namespace RS + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} +variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) + +/-- **The cap value in coordinates.** -/ +theorem capVal_expansion (m : ℕ) + (v : (superPow (stdSuperPair k ℓ) (m + m)).even) : + capVal f P e m v = + ∑ c : {c : MixedColouring k ℓ (m + m) // c.IsEven}, + coordOf v c.val * capVal f P e m (evenBasisVec c) := by + conv_lhs => rw [coord_expansion v] + rw [capVal_sum] + refine Finset.sum_congr rfl (fun c _ => ?_) + rw [capVal_smul] + rw [show coordOf v c.val = + (colourPowerEquiv k ℓ (m + m)).evenEquiv v c from by + unfold coordOf + rw [dite_eq_left c.prop]] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapFun.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapFun.lean new file mode 100644 index 0000000000..9c0ce3babe --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapFun.lean @@ -0,0 +1,69 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeel +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaCotensor + +/-! +# The cap functional recursion + +The base and successor laws of the cap functional through the +fibre functor: the zero cap is the identity class, and the +successor cap evaluates through the peel rotation and the +tensor split. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open Functor.LaxMonoidal Functor.OplaxMonoidal + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The zero cap is the identity class. -/ +theorem bundleCapClass_zero : + bundleCapClass f 0 = 𝟙 (SkeinObj.mk 0 : SkeinObj f) := + HomSpace.ofFragment_congr f (relabelZeroEquiv _ _) + +variable (P : DelignePackage (SkeinObj f)) + +/-- **The cap functional successor law**: evaluate through the +peel rotation, then the split cap. -/ +theorem omegaFun_cap_succ (m : ℕ) + (v : (P.ω.obj (SkeinObj.mk ((m + 1) + (m + 1)))).even) : + omegaFun f P (bundleCapClass f (m + 1)) v = + omegaFun f P (HomSpace.tensor f (m + m) 0 2 0 + (bundleCapClass f m) (evClass f)) + ((P.ω.map (bundleMapClass f + (capPeelRotation m))).evenMap v) := by + rw [bundleCapClass_peel f m] + exact omegaFun_comp f P + (bundleMapClass f (capPeelRotation m)) + (HomSpace.tensor f (m + m) 0 2 0 + (bundleCapClass f m) (evClass f)) v + +/-- The zero cap functional is the unit evaluation. -/ +theorem omegaFun_cap_zero + (v : (P.ω.obj (SkeinObj.mk 0)).even) : + omegaFun f P (bundleCapClass f 0) v = + letI := P.braided + ((η P.ω : P.ω.obj (SkeinObj.mk 0) ⟶ + SuperVect.tensorUnit) : + SuperVect.Hom _ _).evenMap v := by + let := P.braided + rw [bundleCapClass_zero] + change ((P.ω.map (𝟙 (SkeinObj.mk 0)) ≫ η P.ω : + P.ω.obj (SkeinObj.mk 0) ⟶ SuperVect.tensorUnit) : + SuperVect.Hom _ _).evenMap v = _ + rw [show P.ω.map (𝟙 (SkeinObj.mk 0 : SkeinObj f)) = + 𝟙 (P.ω.obj (SkeinObj.mk 0)) from P.ω.map_id _] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapMatch.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapMatch.lean new file mode 100644 index 0000000000..9935925fc5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapMatch.lean @@ -0,0 +1,41 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BraidWord + +/-! +# Towards the matching cap + +Left composition with a bundle-map class relabels the incoming +boundary: the class-level mirror of `bundleMapCompose`. This is +the absorption step for permuted caps — composing a braiding word +into the strand-bundle cap yields the cap of the permuted +matching. +-/ + +@[expose] public section + +namespace RS + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- Left composition with a bundle-map class relabels the +fragment along the incoming transport. -/ +theorem bundleMapClass_comp_left {n m u : ℕ} + (e : Fin n ≃ Fin m) (X : Fragment (Fin (m + u))) : + HomSpace.comp f n m u (bundleMapClass f e) + (HomSpace.ofFragment f.val X) = + HomSpace.ofFragment f.val (X.relabel + (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr e.symm + (_root_.Equiv.refl (Fin u))).trans + finSumFinEquiv))) := by + rw [bundleMapClass, HomSpace.comp_ofFragment] + exact HomSpace.ofFragment_congr f (bundleMapCompose e X) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeel.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeel.lean new file mode 100644 index 0000000000..5572ba887c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeel.lean @@ -0,0 +1,458 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapMatch + +/-! +# Peeling the bundle cap + +The strand-bundle cap on `m + 1` strands factors as the cap on +`m` strands tensored with a single evaluation, composed with the +rotation that moves the last strand's two ends to the end of the +boundary word. This is the recursion that computes the cap +functional in coordinates. +-/ + +@[expose] public section + +namespace RS + +/-- The peel rotation, on values. -/ +def capPeelFun (m j : ℕ) : ℕ := + if j < m then j + else if j = m then m + m + else if j ≤ m + m then j - 1 else j + +/-- The inverse peel rotation, on values. -/ +def capPeelInv (m j : ℕ) : ℕ := + if j < m then j + else if j = m + m then m + else if j < m + m then j + 1 else j + +/-- The peel rotation: move the last strand's ends to the end. -/ +def capPeelRotation (m : ℕ) : + Fin ((m + 1) + (m + 1)) ≃ Fin ((m + m) + 2) where + toFun i := ⟨capPeelFun m i.val, by + have := i.isLt + unfold capPeelFun + split_ifs <;> omega⟩ + invFun j := ⟨capPeelInv m j.val, by + have := j.isLt + unfold capPeelInv + split_ifs <;> omega⟩ + left_inv i := Fin.ext (by + have := i.isLt + change capPeelInv m (capPeelFun m i.val) = i.val + unfold capPeelFun capPeelInv + split_ifs <;> omega) + right_inv j := Fin.ext (by + have := j.isLt + change capPeelFun m (capPeelInv m j.val) = j.val + unfold capPeelFun capPeelInv + split_ifs <;> omega) + +/-- The incoming transport of the peel evaluates by the inverse +rotation. -/ +theorem capPeel_inTransport_val (m : ℕ) + (ℓ : Fin (((m + m) + 2) + 0)) : + ((finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (capPeelRotation m).symm + (_root_.Equiv.refl (Fin 0))).trans + finSumFinEquiv)) ℓ).val = capPeelInv m ℓ.val := by + rw [show ℓ = Fin.castAdd 0 ⟨ℓ.val, by + have := ℓ.isLt; omega⟩ from Fin.ext rfl] + rw [_root_.Equiv.trans_apply, finSumFinEquiv_symm_apply_castAdd] + rfl + +/-- The peel flag map. -/ +def capPeelFlagFun (m : ℕ) : + Fin (m + 1) × Bool → ((Fin m × Bool) ⊕ Fin 2) := fun g => + if h : g.1.val < m then Sum.inl (⟨g.1.val, h⟩, g.2) + else Sum.inr (if g.2 then 1 else 0) + +/-- The inverse peel flag map. -/ +def capPeelFlagInv (m : ℕ) : + ((Fin m × Bool) ⊕ Fin 2) → Fin (m + 1) × Bool + | Sum.inl (j, b) => (⟨j.val, by omega⟩, b) + | Sum.inr t => (⟨m, by omega⟩, decide (t.val = 1)) + +/-- The peel flag equivalence. -/ +def capPeelFlagEquiv (m : ℕ) : + (Fin (m + 1) × Bool) ≃ ((Fin m × Bool) ⊕ Fin 2) where + toFun := capPeelFlagFun m + invFun := capPeelFlagInv m + left_inv g := by + -- ═══════ ATTACHMENT ═══════ + -- A strand below `m` lands in the smaller bundle; the top strand + -- lands in the two-element strand. + obtain ⟨i, b⟩ := g + unfold capPeelFlagFun + by_cases h : i.val < m + · rw [dite_eq_left h] + change (⟨i.val, _⟩, b) = (i, b) + exact Prod.ext (Fin.ext rfl) rfl + · rw [dite_eq_right h] + have hi : i.val = m := by + have := i.isLt + omega + cases b + · change ((⟨m, _⟩ : Fin (m + 1)), + decide ((0 : Fin 2).val = 1)) = (i, false) + exact Prod.ext (Fin.ext (show m = i.val by omega)) rfl + · change ((⟨m, _⟩ : Fin (m + 1)), + decide ((1 : Fin 2).val = 1)) = (i, true) + exact Prod.ext (Fin.ext (show m = i.val by omega)) rfl + right_inv g := by + rcases g with ⟨j, b⟩ | t + · change capPeelFlagFun m (⟨j.val, _⟩, b) = _ + unfold capPeelFlagFun + rw [dite_eq_left (show (⟨j.val, by omega⟩ : + Fin (m + 1)).val < m from j.isLt)] + · change capPeelFlagFun m (⟨m, _⟩, decide (t.val = 1)) = _ + unfold capPeelFlagFun + rw [dite_eq_right (show ¬ ((⟨m, by omega⟩ : + Fin (m + 1)).val < m) from by + change ¬ (m < m); omega)] + refine congrArg Sum.inr ?_ + have ht := t.isLt + rcases (show t.val = 0 ∨ t.val = 1 by omega) + with hv | hv + · rw [show t = (0 : Fin 2) from Fin.ext hv] + rfl + · rw [show t = (1 : Fin 2) from Fin.ext hv] + rfl + +/-- Interleave value on the cap side. -/ +theorem capPeel_interleave_left_val (m X : ℕ) + (h : X < (m + m) + 0) : + ((interleaveEquiv (m + m) 0 2 0) + (Sum.inl ⟨X, h⟩)).val = X := by + rw [show (⟨X, h⟩ : Fin ((m + m) + 0)) = + Fin.castAdd 0 ⟨X, by omega⟩ from Fin.ext rfl, + interleaveEquiv_inl_low] + rfl + +/-- Interleave value on the evaluation side. -/ +theorem capPeel_interleave_right_val (m X : ℕ) + (h : X < 2 + 0) : + ((interleaveEquiv (m + m) 0 2 0) + (Sum.inr ⟨X, h⟩)).val = (m + m) + X := by + rw [show (⟨X, h⟩ : Fin (2 + 0)) = + Fin.castAdd 0 ⟨X, by omega⟩ from Fin.ext rfl, + interleaveEquiv_inr_low] + rfl + +private theorem capPeelEquiv_attach_comm (m : ℕ) + (g : (((strandBundle (m + 1)).relabel (finCongr + (by omega : (m + 1) + (m + 1) = + ((m + 1) + (m + 1)) + 0)))).Flag) : + (((tensorFragment + ((strandBundle m).relabel (finCongr + (by omega : m + m = (m + m) + 0))) + (Fragment.strand.relabel (finCongr + (by omega : 2 = 2 + 0)))).relabel + (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (capPeelRotation m).symm + (_root_.Equiv.refl (Fin 0))).trans + finSumFinEquiv)))).attach (capPeelFlagEquiv m g) = + ((((strandBundle (m + 1)).relabel (finCongr + (by omega : (m + 1) + (m + 1) = + ((m + 1) + (m + 1)) + 0)))).attach g).map (_root_.Equiv.equivOfIsEmpty Empty (Empty + ⊕ Empty)) id := by + -- ═══════ PAIRING ═══════ + -- The flag map sends a strand's two ends to the same factor, so + -- the pairing is the factor's own. + obtain ⟨i, b⟩ := g + by_cases h : i.val < m + · have hflag : capPeelFlagEquiv m (i, b) = + Sum.inl (⟨i.val, h⟩, b) := dite_eq_left h + refine Eq.trans (congrArg + (fun z : ((Fin m × Bool) ⊕ Fin 2) => + ((tensorFragment + ((strandBundle m).relabel (finCongr + (by omega : m + m = (m + m) + 0))) + (Fragment.strand.relabel (finCongr + (by omega : 2 = 2 + 0)))).relabel + (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (capPeelRotation m).symm + (_root_.Equiv.refl (Fin 0))).trans + finSumFinEquiv))).attach z) hflag) ?_ + cases b + · change Sum.inr ((finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (capPeelRotation m).symm + (_root_.Equiv.refl (Fin 0))).trans + finSumFinEquiv)) + ((interleaveEquiv (m + m) 0 2 0) + (Sum.inl ⟨i.val, by omega⟩))) = + Sum.inr (finCongr + (by omega : (m + 1) + (m + 1) = + ((m + 1) + (m + 1)) + 0) ⟨i.val, by omega⟩) + refine congrArg Sum.inr (Fin.ext ?_) + rw [capPeel_inTransport_val, + capPeel_interleave_left_val] + change capPeelInv m i.val = i.val + unfold capPeelInv + rw [ite_eq_left h] + · change Sum.inr ((finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (capPeelRotation m).symm + (_root_.Equiv.refl (Fin 0))).trans + finSumFinEquiv)) + ((interleaveEquiv (m + m) 0 2 0) + (Sum.inl ⟨m + i.val, by omega⟩))) = + Sum.inr (finCongr + (by omega : (m + 1) + (m + 1) = + ((m + 1) + (m + 1)) + 0) + ⟨(m + 1) + i.val, by omega⟩) + refine congrArg Sum.inr (Fin.ext ?_) + rw [capPeel_inTransport_val, + capPeel_interleave_left_val] + change capPeelInv m (m + i.val) = (m + 1) + i.val + unfold capPeelInv + split_ifs <;> omega + -- ─────── the top strand ─────── + · have hi : i.val = m := by + have := i.isLt + omega + cases b + · have hflag : capPeelFlagEquiv m (i, false) = + Sum.inr 0 := by + change capPeelFlagFun m (i, false) = _ + unfold capPeelFlagFun + rw [dite_eq_right h] + rfl + refine Eq.trans (congrArg + (fun z : ((Fin m × Bool) ⊕ Fin 2) => + ((tensorFragment + ((strandBundle m).relabel (finCongr + (by omega : m + m = (m + m) + 0))) + (Fragment.strand.relabel (finCongr + (by omega : 2 = 2 + 0)))).relabel + (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (capPeelRotation m).symm + (_root_.Equiv.refl (Fin 0))).trans + finSumFinEquiv))).attach z) hflag) ?_ + change Sum.inr ((finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (capPeelRotation m).symm + (_root_.Equiv.refl (Fin 0))).trans + finSumFinEquiv)) + ((interleaveEquiv (m + m) 0 2 0) + (Sum.inr ⟨0, by omega⟩))) = + Sum.inr (finCongr + (by omega : (m + 1) + (m + 1) = + ((m + 1) + (m + 1)) + 0) ⟨i.val, by omega⟩) + refine congrArg Sum.inr (Fin.ext ?_) + rw [capPeel_inTransport_val, + capPeel_interleave_right_val] + change capPeelInv m ((m + m) + 0) = i.val + unfold capPeelInv + split_ifs <;> omega + · have hflag : capPeelFlagEquiv m (i, true) = + Sum.inr 1 := by + change capPeelFlagFun m (i, true) = _ + unfold capPeelFlagFun + rw [dite_eq_right h] + rfl + refine Eq.trans (congrArg + (fun z : ((Fin m × Bool) ⊕ Fin 2) => + ((tensorFragment + ((strandBundle m).relabel (finCongr + (by omega : m + m = (m + m) + 0))) + (Fragment.strand.relabel (finCongr + (by omega : 2 = 2 + 0)))).relabel + (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (capPeelRotation m).symm + (_root_.Equiv.refl (Fin 0))).trans + finSumFinEquiv))).attach z) hflag) ?_ + change Sum.inr ((finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (capPeelRotation m).symm + (_root_.Equiv.refl (Fin 0))).trans + finSumFinEquiv)) + ((interleaveEquiv (m + m) 0 2 0) + (Sum.inr ⟨1, by omega⟩))) = + Sum.inr (finCongr + (by omega : (m + 1) + (m + 1) = + ((m + 1) + (m + 1)) + 0) + ⟨(m + 1) + i.val, by omega⟩) + refine congrArg Sum.inr (Fin.ext ?_) + rw [capPeel_inTransport_val, + capPeel_interleave_right_val] + change capPeelInv m ((m + m) + 1) = (m + 1) + i.val + unfold capPeelInv + split_ifs <;> omega +-- ═══════ PAIRING ═══════ + +private theorem capPeelEquiv_pairing_comm (m : ℕ) + (g : (((strandBundle (m + 1)).relabel (finCongr + (by omega : (m + 1) + (m + 1) = + ((m + 1) + (m + 1)) + 0)))).Flag) : + capPeelFlagEquiv m ((((strandBundle (m + 1)).relabel (finCongr + (by omega : (m + 1) + (m + 1) = + ((m + 1) + (m + 1)) + 0)))).pairing g) = + (((tensorFragment + ((strandBundle m).relabel (finCongr + (by omega : m + m = (m + m) + 0))) + (Fragment.strand.relabel (finCongr + (by omega : 2 = 2 + 0)))).relabel + (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (capPeelRotation m).symm + (_root_.Equiv.refl (Fin 0))).trans + finSumFinEquiv)))).pairing (capPeelFlagEquiv m g) := by + obtain ⟨i, b⟩ := g + change capPeelFlagEquiv m (i, !b) = + ((((tensorFragment + ((strandBundle m).relabel (finCongr + (by omega : m + m = (m + m) + 0))) + (Fragment.strand.relabel (finCongr + (by omega : 2 = 2 + 0)))).relabel + (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (capPeelRotation m).symm + (_root_.Equiv.refl (Fin 0))).trans + finSumFinEquiv))).pairing + (capPeelFlagEquiv m (i, b)) : + ((Fin m × Bool) ⊕ Fin 2))) + by_cases h : i.val < m + · exact ((dite_eq_left h : capPeelFlagEquiv m (i, !b) = + Sum.inl (⟨i.val, h⟩, !b))).trans + (((rfl : (Sum.inl (⟨i.val, h⟩, !b) : + ((Fin m × Bool) ⊕ Fin 2)) = + (((tensorFragment + ((strandBundle m).relabel (finCongr + (by omega : m + m = (m + m) + 0))) + (Fragment.strand.relabel (finCongr + (by omega : 2 = 2 + 0)))).relabel + (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (capPeelRotation m).symm + (_root_.Equiv.refl (Fin 0))).trans + finSumFinEquiv))).pairing + (Sum.inl (⟨i.val, h⟩, b)) : + ((Fin m × Bool) ⊕ Fin 2)))).trans + ((congrArg (fun z : ((Fin m × Bool) ⊕ Fin 2) => + (((tensorFragment + ((strandBundle m).relabel (finCongr + (by omega : m + m = (m + m) + 0))) + (Fragment.strand.relabel (finCongr + (by omega : 2 = 2 + 0)))).relabel + (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (capPeelRotation m).symm + (_root_.Equiv.refl (Fin 0))).trans + finSumFinEquiv))).pairing z : ((Fin m × Bool) ⊕ Fin 2))) + (dite_eq_left h : capPeelFlagEquiv m (i, b) = + Sum.inl (⟨i.val, h⟩, b))).symm)) + -- ─────── the top strand ─────── + · have hf : capPeelFlagEquiv m (i, false) = + Sum.inr (0 : Fin 2) := by + change capPeelFlagFun m (i, false) = _ + unfold capPeelFlagFun + rw [dite_eq_right h] + rfl + have ht : capPeelFlagEquiv m (i, true) = + Sum.inr (1 : Fin 2) := by + change capPeelFlagFun m (i, true) = _ + unfold capPeelFlagFun + rw [dite_eq_right h] + rfl + cases b + · exact ht.trans + (((show (Sum.inr (1 : Fin 2) : + ((Fin m × Bool) ⊕ Fin 2)) = + (((tensorFragment + ((strandBundle m).relabel (finCongr + (by omega : m + m = (m + m) + 0))) + (Fragment.strand.relabel (finCongr + (by omega : 2 = 2 + 0)))).relabel + (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (capPeelRotation m).symm + (_root_.Equiv.refl (Fin 0))).trans + finSumFinEquiv))).pairing + (Sum.inr (0 : Fin 2)) : + ((Fin m × Bool) ⊕ Fin 2)) from + congrArg Sum.inr (Fin.ext rfl))).trans + ((congrArg (fun z : ((Fin m × Bool) ⊕ Fin 2) => + (((tensorFragment + ((strandBundle m).relabel (finCongr + (by omega : m + m = (m + m) + 0))) + (Fragment.strand.relabel (finCongr + (by omega : 2 = 2 + 0)))).relabel + (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (capPeelRotation m).symm + (_root_.Equiv.refl (Fin 0))).trans + finSumFinEquiv))).pairing z : ((Fin m × Bool) ⊕ Fin 2))) hf).symm)) + · exact hf.trans + (((show (Sum.inr (0 : Fin 2) : + ((Fin m × Bool) ⊕ Fin 2)) = + (((tensorFragment + ((strandBundle m).relabel (finCongr + (by omega : m + m = (m + m) + 0))) + (Fragment.strand.relabel (finCongr + (by omega : 2 = 2 + 0)))).relabel + (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (capPeelRotation m).symm + (_root_.Equiv.refl (Fin 0))).trans + finSumFinEquiv))).pairing + (Sum.inr (1 : Fin 2)) : + ((Fin m × Bool) ⊕ Fin 2)) from + congrArg Sum.inr (Fin.ext rfl))).trans + ((congrArg (fun z : ((Fin m × Bool) ⊕ Fin 2) => + (((tensorFragment + ((strandBundle m).relabel (finCongr + (by omega : m + m = (m + m) + 0))) + (Fragment.strand.relabel (finCongr + (by omega : 2 = 2 + 0)))).relabel + (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (capPeelRotation m).symm + (_root_.Equiv.refl (Fin 0))).trans + finSumFinEquiv))).pairing z : ((Fin m × Bool) ⊕ Fin 2))) ht).symm)) + +/-- **The cap peel equivalence**: the padded bundle cap on +`m + 1` strands is the tensor of the cap on `m` strands with one +evaluation, relabelled along the peel rotation. -/ +noncomputable def capPeelEquiv (m : ℕ) : + ((strandBundle (m + 1)).relabel (finCongr + (by omega : (m + 1) + (m + 1) = + ((m + 1) + (m + 1)) + 0))).Equiv + ((tensorFragment + ((strandBundle m).relabel (finCongr + (by omega : m + m = (m + m) + 0))) + (Fragment.strand.relabel (finCongr + (by omega : 2 = 2 + 0)))).relabel + (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (capPeelRotation m).symm + (_root_.Equiv.refl (Fin 0))).trans + finSumFinEquiv))) where + flagEquiv := capPeelFlagEquiv m + vertexEquiv := + show Empty ≃ (Empty ⊕ Empty) from + _root_.Equiv.equivOfIsEmpty _ _ + -- ═══════ ATTACHMENT ═══════ + attach_comm := by exact capPeelEquiv_attach_comm m + pairing_comm := by exact capPeelEquiv_pairing_comm m + circles_eq := rfl + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- **The cap peel**: the bundle cap on `m + 1` strands is the +peel rotation composed with the cap on `m` strands tensored with +one evaluation. -/ +theorem bundleCapClass_peel (m : ℕ) : + bundleCapClass f (m + 1) = + HomSpace.comp f ((m + 1) + (m + 1)) ((m + m) + 2) 0 + (bundleMapClass f (capPeelRotation m)) + (HomSpace.tensor f (m + m) 0 2 0 + (bundleCapClass f m) (evClass f)) := by + rw [show HomSpace.tensor f (m + m) 0 2 0 + (bundleCapClass f m) (evClass f) = + HomSpace.ofFragment f.val (tensorFragment + ((strandBundle m).relabel (finCongr + (by omega : m + m = (m + m) + 0))) + (Fragment.strand.relabel (finCongr + (by omega : 2 = 2 + 0)))) from + HomSpace.tensor_ofFragment f (m + m) 0 2 0 _ _] + rw [bundleMapClass_comp_left] + exact HomSpace.ofFragment_congr f (capPeelEquiv m) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeelSplit.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeelSplit.lean new file mode 100644 index 0000000000..a631143d2a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeelSplit.lean @@ -0,0 +1,198 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapExpansion + +/-! +# The peel step in model form + +The cap value successor law transported to the model: the peel +rotation splits as a same-arity permutation followed by an arity +cast (`CapPerm`), and the cap value at `m + 1` is the split cap +value of the permuted-and-cast vector. The colour action of the +permutation is the only remaining ingredient of the closed form. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open Functor.LaxMonoidal Functor.OplaxMonoidal +open scoped TensorProduct + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} +variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) + +/-- The peel arity identity, pinned. -/ +theorem capPeelArity (m : ℕ) : + (m + 1) + (m + 1) = (m + m) + 2 := by omega + +/-- **The split cap value**: the smaller cap tensored with one +evaluation, on a transported vector. -/ +noncomputable def splitCapVal (m : ℕ) + (w : (superPow (stdSuperPair k ℓ) ((m + m) + 2)).even) : ℂ := + letI := P.braided + omegaFun f P (HomSpace.tensor f (m + m) 0 2 0 + (bundleCapClass f m) (evClass f)) + (((stdToOmega f P e ((m + m) + 2)) : + SuperVect.Hom _ _).evenMap w) + +/-- The split cap value is additive over finite sums. -/ +theorem splitCapVal_sum {ι : Type*} (m : ℕ) (s : Finset ι) + (g : ι → (superPow (stdSuperPair k ℓ) ((m + m) + 2)).even) : + splitCapVal f P e m (∑ i ∈ s, g i) = + ∑ i ∈ s, splitCapVal f P e m (g i) := by + unfold splitCapVal + rw [map_sum, map_sum] + +/-- The split cap value is homogeneous. -/ +theorem splitCapVal_smul (m : ℕ) (r : ℂ) + (w : (superPow (stdSuperPair k ℓ) ((m + m) + 2)).even) : + splitCapVal f P e m (r • w) = + r * splitCapVal f P e m w := by + unfold splitCapVal + rw [map_smul, map_smul, smul_eq_mul] + +/-- **The split cap value in coordinates.** -/ +theorem splitCapVal_expansion (m : ℕ) + (w : (superPow (stdSuperPair k ℓ) ((m + m) + 2)).even) : + splitCapVal f P e m w = + ∑ c : {c : MixedColouring k ℓ ((m + m) + 2) // c.IsEven}, + coordOf w c.val * + splitCapVal f P e m (evenBasisVec c) := by + conv_lhs => rw [coord_expansion w] + rw [splitCapVal_sum] + refine Finset.sum_congr rfl (fun c _ => ?_) + rw [splitCapVal_smul] + rw [show coordOf w c.val = + (colourPowerEquiv k ℓ ((m + m) + 2)).evenEquiv w c from by + unfold coordOf + rw [dite_eq_left c.prop]] + rfl + +/-- The split cap value on merges: `CapSplit` restated. -/ +theorem splitCapVal_merge (m : ℕ) + (x : (superPow (stdSuperPair k ℓ) (m + m)).even) + (y : (superPow (stdSuperPair k ℓ) 2).even) : + letI := P.braided + splitCapVal f P e m + (((powMerge (stdSuperPair k ℓ) (m + m) 2) : + SuperVect.Hom _ _).evenMap (evenPair x y)) = + capVal f P e m x * + omegaFun f P (evClass f) + (((stdToOmega f P e 2) : + SuperVect.Hom _ _).evenMap y) := + omegaFun_capTensor_merge f P e m x y + +-- The merge of an odd pair is pushed through the +-- split cap on every graded block. +/-- **The split cap value vanishes on odd merges.** -/ +theorem splitCapVal_oddMerge (m : ℕ) + (x : (superPow (stdSuperPair k ℓ) (m + m)).odd) + (y : (superPow (stdSuperPair k ℓ) 2).odd) : + splitCapVal f P e m + (((powMerge (stdSuperPair k ℓ) (m + m) 2) : + SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) (m + m)).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) 2).even), + x ⊗ₜ[ℂ] y) : + (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) (m + m)) + (superPow (stdSuperPair k ℓ) 2)).even)) = 0 := by + let := P.braided + have hmerge := congrArg (fun z : + (superPow (stdSuperPair k ℓ) (m + m) ⊗ + superPow (stdSuperPair k ℓ) 2 ⟶ + P.ω.obj (SkeinObj.mk ((m + m) + 2))) => + (z : SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) (m + m)).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) 2).even), + x ⊗ₜ[ℂ] y) : + (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) (m + m)) + (superPow (stdSuperPair k ℓ) 2)).even)) + (stdToOmega_merge f P e (m + m) 2) + refine Eq.trans (congrArg (omegaFun f P + (HomSpace.tensor f (m + m) 0 2 0 + (bundleCapClass f m) (evClass f))) hmerge.symm) ?_ + change omegaFun f P (HomSpace.tensor f (m + m) 0 2 0 + (bundleCapClass f m) (evClass f)) + (((μ P.ω (SkeinObj.mk (m + m)) (SkeinObj.mk 2)) : + SuperVect.Hom _ _).evenMap + (((stdToOmega f P e (m + m) ⊗ₘ stdToOmega f P e 2) : + SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) (m + m)).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) 2).even), + x ⊗ₜ[ℂ] y) : + (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) (m + m)) + (superPow (stdSuperPair k ℓ) 2)).even))) = 0 + rw [show ((stdToOmega f P e (m + m) ⊗ₘ stdToOmega f P e 2) : + SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) (m + m)).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) 2).even), + x ⊗ₜ[ℂ] y) : + (SuperVect.tensorObj + (superPow (stdSuperPair k ℓ) (m + m)) + (superPow (stdSuperPair k ℓ) 2)).even) = + oddPair + ((stdToOmega f P e (m + m) : + SuperVect.Hom _ _).oddMap x) + ((stdToOmega f P e 2 : + SuperVect.Hom _ _).oddMap y) from + tensorHom_oddPair _ _ _ _] + exact omegaFun_tensor_oddPair f P + (bundleCapClass f m) (evClass f) _ _ + +-- Peeling one cap rewrites the transport along a +-- permutation and an arity cast at once. +/-- **The cap value successor law in model form.** -/ +theorem capVal_succ (m : ℕ) + (v : (superPow (stdSuperPair k ℓ) ((m + 1) + (m + 1))).even) : + capVal f P e (m + 1) v = + splitCapVal f P e m + (((modelPermMap (capPeelPerm m) ≫ + eqToHom (congrArg (superPow (stdSuperPair k ℓ)) + (capPeelArity m))) : + SuperVect.Hom _ _).evenMap v) := by + let := P.braided + have hchain : stdToOmega f P e ((m + 1) + (m + 1)) ≫ + P.ω.map (bundleMapClass f (capPeelRotation m)) = + (modelPermMap (capPeelPerm m) ≫ + eqToHom (congrArg (superPow (stdSuperPair k ℓ)) + (capPeelArity m))) ≫ + stdToOmega f P e ((m + m) + 2) := by + have hmap : P.ω.map (bundleMapClass f (capPeelRotation m)) = + P.ω.map ((bundleMapClass f ((capPeelPerm m) : + Fin ((m + 1) + (m + 1)) ≃ + Fin ((m + 1) + (m + 1))) : + (SkeinObj.mk ((m + 1) + (m + 1)) : SkeinObj f) ⟶ + SkeinObj.mk ((m + 1) + (m + 1))) ≫ + bundleMapClass f (finCongr (capPeelArity m))) := + congrArg P.ω.map (bmc_capPeel_split f m) + rw [hmap, P.ω.map_comp, ← Category.assoc, + stdToOmega_bmc_perm_all f P e ((m + 1) + (m + 1)) + (capPeelPerm m), + Category.assoc, + stdToOmega_bmc_cast f P e (capPeelArity m), + ← Category.assoc] + refine Eq.trans (omegaFun_cap_succ f P m + (((stdToOmega f P e ((m + 1) + (m + 1))) : + SuperVect.Hom _ _).evenMap v)) ?_ + have hval := congrArg (fun z : + (superPow (stdSuperPair k ℓ) ((m + 1) + (m + 1)) ⟶ + P.ω.obj (SkeinObj.mk ((m + m) + 2))) => + (z : SuperVect.Hom _ _).evenMap v) hchain + exact congrArg (omegaFun f P + (HomSpace.tensor f (m + m) 0 2 0 + (bundleCapClass f m) (evClass f))) hval + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPerm.lean new file mode 100644 index 0000000000..13b08a0ebf --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPerm.lean @@ -0,0 +1,78 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvForm + +/-! +# The peel rotation as a permutation and a cast + +The peel rotation splits as a same-arity permutation followed by +an arity cast; the permutation feeds the braiding-word transport +and the cast transports as an equality of powers. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open Functor.LaxMonoidal Functor.OplaxMonoidal + +/-- The peel rotation as a permutation of the source arity. -/ +def capPeelPerm (m : ℕ) : + _root_.Equiv.Perm (Fin ((m + 1) + (m + 1))) := + (capPeelRotation m).trans (finCongr + (by omega : (m + m) + 2 = (m + 1) + (m + 1))) + +/-- The peel rotation is its permutation followed by the arity +cast. -/ +theorem capPeelEquiv_split (m : ℕ) : + capPeelRotation m = (capPeelPerm m).trans (finCongr + (by omega : (m + 1) + (m + 1) = (m + m) + 2)) := + _root_.Equiv.ext (fun _ => Fin.ext rfl) + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The peel bundle map splits as permutation then cast. -/ +theorem bmc_capPeel_split (m : ℕ) : + bundleMapClass f (capPeelRotation m) = + HomSpace.comp f ((m + 1) + (m + 1)) ((m + 1) + (m + 1)) + ((m + m) + 2) + (bundleMapClass f ((capPeelPerm m) : + Fin ((m + 1) + (m + 1)) ≃ Fin ((m + 1) + (m + 1)))) + (bundleMapClass f (finCongr + (by omega : (m + 1) + (m + 1) = (m + m) + 2))) := by + rw [bundleMapClass_comp] + exact bundleMapClass_congr f (capPeelEquiv_split m) + +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} +variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) + +/-- **The cast transport**: an arity-cast bundle map conjugates +through the model transport into the equality of powers. -/ +theorem stdToOmega_bmc_cast {n₁ n₂ : ℕ} (h : n₁ = n₂) : + letI := P.braided + stdToOmega f P e n₁ ≫ + P.ω.map (bundleMapClass f (finCongr h)) = + eqToHom (congrArg (superPow (stdSuperPair k ℓ)) h) ≫ + stdToOmega f P e n₂ := by + let := P.braided + subst h + rw [show (finCongr (rfl : n₁ = n₁) : Fin n₁ ≃ Fin n₁) = + _root_.Equiv.refl (Fin n₁) from + _root_.Equiv.ext (fun x => Fin.ext rfl)] + rw [show bundleMapClass f (_root_.Equiv.refl (Fin n₁)) = + 𝟙 (SkeinObj.mk n₁ : SkeinObj f) from + bundleMapClass_refl f n₁] + rw [show P.ω.map (𝟙 (SkeinObj.mk n₁ : SkeinObj f)) = + 𝟙 (P.ω.obj (SkeinObj.mk n₁)) from P.ω.map_id _] + rw [eqToHom_refl] + rw [Category.comp_id, Category.id_comp] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapSplit.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapSplit.lean new file mode 100644 index 0000000000..f2a5756417 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapSplit.lean @@ -0,0 +1,80 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelCoord + +/-! +# The split cap on merged vectors + +The multiplicative midpoint of the cap recursion: the split cap +(smaller cap tensored with one evaluation) evaluated on a +transported merge of model vectors is the product of the smaller +cap value and the strand evaluation. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open Functor.LaxMonoidal Functor.OplaxMonoidal + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} +variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) + +-- Multiplicativity is checked by unfolding the +-- transport, the merge and the tensor of the two functionals. +/-- **The split cap is multiplicative over the merge.** -/ +theorem omegaFun_capTensor_merge (m : ℕ) + (x : (superPow (stdSuperPair k ℓ) (m + m)).even) + (y : (superPow (stdSuperPair k ℓ) 2).even) : + omegaFun f P (HomSpace.tensor f (m + m) 0 2 0 + (bundleCapClass f m) (evClass f)) + (((stdToOmega f P e ((m + m) + 2)) : + SuperVect.Hom _ _).evenMap + (((powMerge (stdSuperPair k ℓ) (m + m) 2) : + SuperVect.Hom _ _).evenMap (evenPair x y))) = + capVal f P e m x * + omegaFun f P (evClass f) + (((stdToOmega f P e 2) : + SuperVect.Hom _ _).evenMap y) := by + let := P.braided + -- The transported merge is the structure-map image of the + -- blockwise transports. + have hmerge := congrArg (fun z : + (superPow (stdSuperPair k ℓ) (m + m) ⊗ + superPow (stdSuperPair k ℓ) 2 ⟶ + P.ω.obj (SkeinObj.mk ((m + m) + 2))) => + (z : SuperVect.Hom _ _).evenMap (evenPair x y)) + (stdToOmega_merge f P e (m + m) 2) + refine Eq.trans (congrArg (omegaFun f P + (HomSpace.tensor f (m + m) 0 2 0 + (bundleCapClass f m) (evClass f))) hmerge.symm) ?_ + change omegaFun f P (HomSpace.tensor f (m + m) 0 2 0 + (bundleCapClass f m) (evClass f)) + (((μ P.ω (SkeinObj.mk (m + m)) (SkeinObj.mk 2)) : + SuperVect.Hom _ _).evenMap + (((stdToOmega f P e (m + m) ⊗ₘ stdToOmega f P e 2) : + SuperVect.Hom _ _).evenMap (evenPair x y))) = _ + -- Evaluate the tensor pair blockwise. + rw [show ((stdToOmega f P e (m + m) ⊗ₘ stdToOmega f P e 2) : + SuperVect.Hom _ _).evenMap (evenPair x y) = + evenPair + ((stdToOmega f P e (m + m) : + SuperVect.Hom _ _).evenMap x) + ((stdToOmega f P e 2 : + SuperVect.Hom _ _).evenMap y) from + tensorHom_evenPair _ _ x y] + -- The tensor functional splits as the product. + exact omegaFun_tensor f P (bundleCapClass f m) (evClass f) + ((stdToOmega f P e (m + m) : SuperVect.Hom _ _).evenMap x) + ((stdToOmega f P e 2 : SuperVect.Hom _ _).evenMap y) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapVal.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapVal.lean new file mode 100644 index 0000000000..66022f9ea1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapVal.lean @@ -0,0 +1,90 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordOf + +/-! +# The cap value on model vectors + +The cap functional pulled back to the model: the scalar the +final computation evaluates. Its base case: the zero cap reads +off the scalar itself. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open Functor.LaxMonoidal Functor.OplaxMonoidal + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} +variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) + +/-- The cap value: the cap functional on the transported model +vector. -/ +noncomputable def capVal (m : ℕ) + (v : (superPow (stdSuperPair k ℓ) (m + m)).even) : ℂ := + omegaFun f P (bundleCapClass f m) + (((stdToOmega f P e (m + m)) : + SuperVect.Hom _ _).evenMap v) + +/-- **The zero cap value is the scalar itself.** -/ +theorem capVal_zero (v : (superPow (stdSuperPair k ℓ) 0).even) : + capVal f P e 0 v = v := by + let := P.braided + unfold capVal + rw [omegaFun_cap_zero] + have hcomp : (ε P.ω ≫ η P.ω : SuperVect.tensorUnit ⟶ + SuperVect.tensorUnit) = 𝟙 SuperVect.tensorUnit := + Functor.Monoidal.ε_η P.ω + exact congrArg (fun z : (SuperVect.tensorUnit ⟶ + SuperVect.tensorUnit) => + (z : SuperVect.Hom _ _).evenMap v) hcomp + +/-- The cap value is additive over finite sums. -/ +theorem capVal_sum {ι : Type*} (m : ℕ) (s : Finset ι) + (g : ι → (superPow (stdSuperPair k ℓ) (m + m)).even) : + capVal f P e m (∑ i ∈ s, g i) = + ∑ i ∈ s, capVal f P e m (g i) := by + unfold capVal + rw [map_sum, map_sum] + +/-- The cap value is homogeneous. -/ +theorem capVal_smul (m : ℕ) (r : ℂ) + (v : (superPow (stdSuperPair k ℓ) (m + m)).even) : + capVal f P e m (r • v) = r * capVal f P e m v := by + unfold capVal + rw [map_smul, map_smul, smul_eq_mul] + +variable (e' : P.ω.obj (SkeinObj.mk 1) ⟶ stdSuperPair k ℓ) + +/-- **The parameter value through the cap value**: the final +scalar shape. -/ +theorem parameter_capVal (W : ClosedFragment) + (hee' : (e' ≫ e : P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk 1)) = 𝟙 _) : + f.val W = circleVal f ^ W.circles * + capVal f P e (edgeCount W) + (((CategoryTheory.eqToHom (congrArg + (superPow (stdSuperPair k ℓ)) + (degList_sum (starAssignEnum W))) : + superPow (stdSuperPair k ℓ) + ((degList (starAssignEnum W)).sum) ⟶ + superPow (stdSuperPair k ℓ) + (edgeCount W + edgeCount W)) : + SuperVect.Hom _ _).evenMap + (((modelPermMap (sortSplitPerm W)) : + SuperVect.Hom _ _).evenMap + (modelStarVec f P e' + (degList (starAssignEnum W))))) := + parameter_model f P e e' W hee' + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ChainLists.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ChainLists.lean new file mode 100644 index 0000000000..a46c461a2f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ChainLists.lean @@ -0,0 +1,143 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.GlobalSlotList + +/-! +# The chain enumerations + +The intermediate flag enumerations of the parity chain: the +edge-interleaved list, the oriented list, the matched list, and +the global pair concatenation. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {k ℓ : ℕ} + +open Classical in +/-- The participating edges in edge order. -/ +noncomputable def partEdges (W : ClosedFragment) + (F : EdgeSubset W) : List (Fin (edgeCount W)) := + (edgeIndexSet W F).sort (· ≤ ·) + +open Classical in +/-- Representative membership from edge participation. -/ +theorem repMem_of_partEdge {W : ClosedFragment} + {F : EdgeSubset W} {i : Fin (edgeCount W)} + (hi : i ∈ edgeIndexSet W F) : + (starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i) ∈ F.flags := by + rw [edgeIndexSet, Finset.mem_filter] at hi + exact hi.2 + +open Classical in +/-- Partner membership from edge participation. -/ +theorem partnerMem_of_partEdge {W : ClosedFragment} + {F : EdgeSubset W} {i : Fin (edgeCount W)} + (hi : i ∈ edgeIndexSet W F) : + (starFlagEnum W).symm + (Fin.natAdd (edgeCount W) i) ∈ F.flags := by + rw [← pairing_starFlagEnum_symm] + exact F.pairing_mem _ (repMem_of_partEdge hi) + +open Classical in +/-- **The edge-interleaved enumeration**: each participating edge +contributes its representative then its partner. -/ +noncomputable def edgePairList (W : ClosedFragment) + (F : EdgeSubset W) : List {f : W.Flag // f ∈ F.flags} := + ((partEdges W F).attachWith (· ∈ edgeIndexSet W F) + (fun _ hi => (Finset.mem_sort _).mp hi)).flatMap + (fun i => [⟨(starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i.val), + repMem_of_partEdge i.prop⟩, + ⟨(starFlagEnum W).symm + (Fin.natAdd (edgeCount W) i.val), + partnerMem_of_partEdge i.prop⟩]) + +open Classical in +/-- **The oriented enumeration**: each participating edge +contributes its incoming then its outgoing flag. -/ +noncomputable def orientedPairList (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) : List {f : W.Flag // f ∈ F.flags} := + ((partEdges W F).attachWith (· ∈ edgeIndexSet W F) + (fun _ hi => (Finset.mem_sort _).mp hi)).flatMap + (fun i => + if o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i.val)) = true then + [⟨(starFlagEnum W).symm + (Fin.natAdd (edgeCount W) i.val), + partnerMem_of_partEdge i.prop⟩, + ⟨(starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i.val), + repMem_of_partEdge i.prop⟩] + else + [⟨(starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i.val), + repMem_of_partEdge i.prop⟩, + ⟨(starFlagEnum W).symm + (Fin.natAdd (edgeCount W) i.val), + partnerMem_of_partEdge i.prop⟩]) + +open Classical in +/-- **The matched enumeration**: each participating edge +contributes its incoming flag then that flag's match. -/ +noncomputable def matchedPairList (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) : List {f : W.Flag // f ∈ F.flags} := + ((partEdges W F).attachWith (· ∈ edgeIndexSet W F) + (fun _ hi => (Finset.mem_sort _).mp hi)).flatMap + (fun i => + if o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i.val)) = true then + [⟨(starFlagEnum W).symm + (Fin.natAdd (edgeCount W) i.val), + partnerMem_of_partEdge i.prop⟩, + ⟨κ.match_ ((starFlagEnum W).symm + (Fin.natAdd (edgeCount W) i.val)), + κ.match_mem _ (partnerMem_of_partEdge i.prop)⟩] + else + [⟨(starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i.val), + repMem_of_partEdge i.prop⟩, + ⟨κ.match_ ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i.val)), + κ.match_mem _ (repMem_of_partEdge i.prop)⟩]) + +open Classical in +/-- **The global pair enumeration**: the vertex pair +enumerations in block order. -/ +noncomputable def globalPairList (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) : List {f : W.Flag // f ∈ F.flags} := + (List.finRange (ds W).length).flatMap + (fun v => pairFlagList (F := F) o (blockVertex W v)) + +/-- `blockVertex W` is injective. -/ +theorem blockVertex_injective' (W : ClosedFragment) : + Function.Injective (blockVertex W) := by + intro v₁ v₂ h + unfold blockVertex at h + have h1 := (Fintype.equivFin W.Vertex).symm.injective h + exact (finCongr (degList_length (starAssignEnum W))).injective h1 + +/-- `blockVertex W` is surjective. -/ +theorem blockVertex_surjective' (W : ClosedFragment) : + Function.Surjective (blockVertex W) := by + intro v₀ + exact ⟨(finCongr (degList_length (starAssignEnum W))).symm + (Fintype.equivFin W.Vertex v₀), by + rw [blockVertex, _root_.Equiv.apply_symm_apply, + _root_.Equiv.symm_apply_apply]⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleModel.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleModel.lean new file mode 100644 index 0000000000..9494dd8b2e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleModel.lean @@ -0,0 +1,194 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StdTransport +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.CircleValue + +/-! +# The circle value in the model + +The composite of the coevaluation and evaluation classes is the +free circle: gluing the two strand ends creates exactly one free +circle, so the categorical scalar of `η_ ≫ ε_` is the circle +value of the parameter. Transporting through the fibre functor +and the standard model identifies it with the superdimension +`k − 2ℓ`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Functor.LaxMonoidal Functor.OplaxMonoidal +open MonoidalCategory + +/-- The circle composite has no flags: both strand ends are +glued. -/ +theorem circleCompose_flag_empty : + IsEmpty (coevFrag.compose evFrag).Flag := by + constructor + intro g + obtain ⟨⟨y, hy1, hy2⟩, hx1, hx2⟩ := g + rcases y with i | i <;> + rcases (show i = ⟨0, Nat.zero_lt_two⟩ ∨ + i = ⟨1, Nat.one_lt_two⟩ from by + have h2 := i.isLt + rcases Nat.lt_or_ge i.val 1 with h | h + · exact Or.inl (Fin.ext (show i.val = 0 by omega)) + · exact Or.inr (Fin.ext (show i.val = 1 by omega))) + with rfl | rfl + · exact hx1 (Subtype.ext rfl) + · exact hy1 rfl + · exact hx2 (Subtype.ext rfl) + · exact hy2 rfl + +/-- **The strand closure is the free circle.** -/ +noncomputable def circleComposeEquiv : + (coevFrag.compose evFrag).Equiv (circlesClosed 1) where + flagEquiv := + haveI := circleCompose_flag_empty + haveI : IsEmpty (circlesClosed 1).Flag := + inferInstanceAs (IsEmpty Empty) + _root_.Equiv.equivOfIsEmpty _ _ + vertexEquiv := + haveI : IsEmpty (coevFrag.compose evFrag).Vertex := + ⟨fun v => by rcases v with w | w <;> exact w.elim⟩ + haveI : IsEmpty (circlesClosed 1).Vertex := + inferInstanceAs (IsEmpty Empty) + _root_.Equiv.equivOfIsEmpty _ _ + attach_comm := fun g => + haveI := circleCompose_flag_empty + isEmptyElim g + pairing_comm := fun g => + haveI := circleCompose_flag_empty + isEmptyElim g + circles_eq := rfl + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- **The categorical circle**: composing coevaluation and +evaluation is the circle value times the identity. -/ +theorem coev_comp_ev : + (η_ (SkeinObj.mk 1 : SkeinObj f) (SkeinObj.mk 1) ≫ + ε_ (SkeinObj.mk 1) (SkeinObj.mk 1) : + (SkeinObj.mk 0 : SkeinObj f) ⟶ SkeinObj.mk 0) = + circleVal f • 𝟙 (SkeinObj.mk 0) := by + change HomSpace.comp f 0 2 0 (coevClass f) (evClass f) = _ + rw [coevClass, evClass, HomSpace.comp_ofFragment] + rw [HomSpace.ofFragment_congr f circleComposeEquiv] + rw [show HomSpace.ofFragment f.val (circlesClosed 1) = + f.val (circlesClosed 1) • + HomSpace.ofFragment f.val emptyClosedFragment from + ofFragment_eq_smul_empty f (circlesClosed 1)] + rw [empty_class_eq_id] + rfl + +variable (P : DelignePackage (SkeinObj f)) + +-- The circle value is read off the standard form +-- and copairing, both of which unfold over the even and odd +-- blocks of the model. +/-- **The circle value is the superdimension** `k − 2ℓ` under any +standard-model identification. -/ +theorem circleVal_model {k ℓ : ℕ} + (e : SuperVect.Hom (stdSuperPair k ℓ) (P.ω.obj (SkeinObj.mk 1))) + (e' : SuperVect.Hom (P.ω.obj (SkeinObj.mk 1)) (stdSuperPair k ℓ)) + (hee' : SuperVect.Hom.comp e e' = + SuperVect.Hom.id (P.ω.obj (SkeinObj.mk 1))) + (hform : + letI := P.braided + SuperVect.Hom.comp + (μ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1) ≫ + P.ω.map (ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) ≫ η P.ω) + (SuperVect.tensorHom e e) = stdForm k ℓ) + (hcopair : + letI := P.braided + SuperVect.Hom.comp (SuperVect.tensorHom e' e') + (ε P.ω ≫ P.ω.map (η_ (SkeinObj.mk 1) (SkeinObj.mk 1)) ≫ + δ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1)) = + stdCopair k ℓ) : + circleVal f = (k : ℂ) - 2 * ℓ := by + let := P.braided + -- The categorical scalar of the circle is the circle value. + have hcirc : ((ε P.ω ≫ P.ω.map + (η_ (SkeinObj.mk 1 : SkeinObj f) (SkeinObj.mk 1) ≫ + ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) ≫ η P.ω : + SuperVect.tensorUnit ⟶ SuperVect.tensorUnit) : + SuperVect.Hom _ _).evenMap 1 = circleVal f := by + rw [coev_comp_ev f] + rw [show P.ω.map (circleVal f • 𝟙 (SkeinObj.mk 0)) = + circleVal f • 𝟙 (P.ω.obj (SkeinObj.mk 0)) from + (P.linear.map_smul _ _).trans + (by rw [CategoryTheory.Functor.map_id])] + rw [CategoryTheory.Linear.smul_comp, + CategoryTheory.Linear.comp_smul] + rw [show (𝟙 (P.ω.obj (SkeinObj.mk 0)) ≫ η P.ω : + P.ω.obj (SkeinObj.mk 0) ⟶ SuperVect.tensorUnit) = + η P.ω from CategoryTheory.Category.id_comp _] + rw [show (ε P.ω ≫ η P.ω : SuperVect.tensorUnit ⟶ + SuperVect.tensorUnit) = 𝟙 _ from + Functor.Monoidal.ε_η P.ω] + change circleVal f * 1 = circleVal f + ring + -- The same scalar through the standard model. + have hsplit : ((ε P.ω ≫ P.ω.map + (η_ (SkeinObj.mk 1 : SkeinObj f) (SkeinObj.mk 1) ≫ + ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) ≫ η P.ω : + SuperVect.tensorUnit ⟶ SuperVect.tensorUnit) : + SuperVect.Hom _ _).evenMap 1 = + (SuperVect.Hom.comp (stdForm k ℓ) (stdCopair k ℓ)).evenMap + 1 := by + have hmap : P.ω.map + (η_ (SkeinObj.mk 1 : SkeinObj f) (SkeinObj.mk 1) ≫ + ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) = + P.ω.map (η_ (SkeinObj.mk 1) (SkeinObj.mk 1)) ≫ + P.ω.map (ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) := + P.ω.map_comp _ _ + have hmid : (δ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1) ≫ + μ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1) : + P.ω.obj (SkeinObj.mk 2) ⟶ P.ω.obj (SkeinObj.mk 2)) = + 𝟙 _ := + Functor.Monoidal.δ_μ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1) + have hins : (δ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1) ≫ + ((e' ⊗ₘ e') ≫ (e ⊗ₘ e)) ≫ + μ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1) : + P.ω.obj (SkeinObj.mk 2) ⟶ P.ω.obj (SkeinObj.mk 2)) = + 𝟙 _ := by + rw [show ((e' ⊗ₘ e') ≫ (e ⊗ₘ e) : + P.ω.obj (SkeinObj.mk 1) ⊗ P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk 1) ⊗ + P.ω.obj (SkeinObj.mk 1)) = 𝟙 _ from by + rw [MonoidalCategory.tensorHom_comp_tensorHom] + rw [show (e' ≫ e : P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk 1)) = 𝟙 _ from hee'] + exact MonoidalCategory.id_tensorHom_id _ _] + rw [CategoryTheory.Category.id_comp] + exact hmid + rw [hmap] + rw [show (P.ω.map (η_ (SkeinObj.mk 1 : SkeinObj f) + (SkeinObj.mk 1)) ≫ + P.ω.map (ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) : + P.ω.obj (SkeinObj.mk 0) ⟶ P.ω.obj (SkeinObj.mk 0)) = + P.ω.map (η_ (SkeinObj.mk 1) (SkeinObj.mk 1)) ≫ + (δ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1) ≫ + ((e' ⊗ₘ e') ≫ (e ⊗ₘ e)) ≫ + μ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1)) ≫ + P.ω.map (ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) from by + rw [hins] + exact (congrArg (fun z : P.ω.obj (SkeinObj.mk 2) ⟶ + P.ω.obj (SkeinObj.mk 0) => + P.ω.map (η_ (SkeinObj.mk 1 : SkeinObj f) + (SkeinObj.mk 1)) ≫ z) + (CategoryTheory.Category.id_comp + (P.ω.map (ε_ (SkeinObj.mk 1) (SkeinObj.mk 1))))).symm] + rw [← hform, ← hcopair] + rfl + rw [← hcirc, hsplit] + exact stdForm_comp_stdCopair k ℓ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleScalar.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleScalar.lean new file mode 100644 index 0000000000..b0db9df29b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleScalar.lean @@ -0,0 +1,177 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MultiStar +public import LeanPool.RegtsSevenster.RS.DimensionDefinitions + +/-! +# Free circles as scalars + +A fragment with extra free circles is the tensor with a +circles-only closed fragment; on Hom classes the circles split +off as the power of the circle value. This is the accompanying paper's +"free circles are carried by multiplicativity" discipline, at +class level. +-/ + +@[expose] public section + +namespace RS + +/-- The circle value of a parameter. -/ +noncomputable def circleVal {R : ℕ} (f : EdgeRankParameter R) : ℂ := + f.val (circlesClosed 1) + +/-- Adding free circles to a fragment. -/ +def addCircles {α : Type} (X : Fragment α) (c : ℕ) : + Fragment α := + { X with circles := X.circles + c } + +/-- Adding circles is tensoring with a circles-only fragment. -/ +noncomputable def addCirclesTensor {s t : ℕ} + (X : Fragment (Fin (s + t))) (c : ℕ) : + (tensorFragment X (circlesClosed c)).Equiv + ((addCircles X c).relabel (finCongr + (by omega : s + t = (s + 0) + (t + 0)))) where + flagEquiv := + show (X.Flag ⊕ Empty) ≃ X.Flag from + _root_.Equiv.sumEmpty X.Flag Empty + vertexEquiv := + show (X.Vertex ⊕ Empty) ≃ X.Vertex from + _root_.Equiv.sumEmpty X.Vertex Empty + attach_comm := fun g => by + rcases g with g | g + · change (X.attach g).map id + (finCongr (by omega : s + t = (s + 0) + (t + 0))) = + Sum.map (show (X.Vertex ⊕ Empty) ≃ X.Vertex from + _root_.Equiv.sumEmpty X.Vertex Empty) id + (Sum.map id (interleaveEquiv s t 0 0) + (Sum.map Sum.inl Sum.inl (X.attach g))) + rcases ha : X.attach g with v | ℓ + · rfl + · exact congrArg Sum.inr (interleave_unit_right s t ℓ).symm + · exact g.elim + pairing_comm := fun g => by + rcases g with g | g + · rfl + · exact g.elim + circles_eq := rfl + +/-- The union of circle fragments adds the counts. -/ +noncomputable def circlesClosedUnion (a b : ℕ) : + (ClosedFragment.union (circlesClosed a) + (circlesClosed b)).Equiv (circlesClosed (a + b)) where + flagEquiv := + haveI h1 : IsEmpty (circlesClosed a).Flag := + inferInstanceAs (IsEmpty Empty) + haveI h2 : IsEmpty (circlesClosed b).Flag := + inferInstanceAs (IsEmpty Empty) + haveI : IsEmpty (ClosedFragment.union (circlesClosed a) + (circlesClosed b)).Flag := + ⟨fun g => g.elim h1.elim h2.elim⟩ + haveI : IsEmpty (circlesClosed (a + b)).Flag := + inferInstanceAs (IsEmpty Empty) + _root_.Equiv.equivOfIsEmpty _ _ + vertexEquiv := + haveI h1 : IsEmpty (circlesClosed a).Vertex := + inferInstanceAs (IsEmpty Empty) + haveI h2 : IsEmpty (circlesClosed b).Vertex := + inferInstanceAs (IsEmpty Empty) + haveI : IsEmpty (ClosedFragment.union (circlesClosed a) + (circlesClosed b)).Vertex := + ⟨fun g => g.elim h1.elim h2.elim⟩ + haveI : IsEmpty (circlesClosed (a + b)).Vertex := + inferInstanceAs (IsEmpty Empty) + _root_.Equiv.equivOfIsEmpty _ _ + attach_comm := fun g => by + have h1 : IsEmpty (circlesClosed a).Flag := + inferInstanceAs (IsEmpty Empty) + have h2 : IsEmpty (circlesClosed b).Flag := + inferInstanceAs (IsEmpty Empty) + exact g.elim h1.elim h2.elim + pairing_comm := fun g => by + have h1 : IsEmpty (circlesClosed a).Flag := + inferInstanceAs (IsEmpty Empty) + have h2 : IsEmpty (circlesClosed b).Flag := + inferInstanceAs (IsEmpty Empty) + exact g.elim h1.elim h2.elim + circles_eq := rfl + +/-- The circle value of `c` circles is the `c`-th power. -/ +theorem circlesClosed_val {R : ℕ} (f : EdgeRankParameter R) + (c : ℕ) : + f.val (circlesClosed c) = circleVal f ^ c := by + induction c with + | zero => + rw [pow_zero] + have h : (circlesClosed 0).Equiv emptyClosedFragment := + { flagEquiv := + haveI : IsEmpty (circlesClosed 0).Flag := + inferInstanceAs (IsEmpty Empty) + haveI : IsEmpty emptyClosedFragment.Flag := + inferInstanceAs (IsEmpty Empty) + _root_.Equiv.equivOfIsEmpty _ _ + vertexEquiv := + haveI : IsEmpty (circlesClosed 0).Vertex := + inferInstanceAs (IsEmpty Empty) + haveI : IsEmpty emptyClosedFragment.Vertex := + inferInstanceAs (IsEmpty Empty) + _root_.Equiv.equivOfIsEmpty _ _ + attach_comm := fun g => by + have : IsEmpty (circlesClosed 0).Flag := + inferInstanceAs (IsEmpty Empty) + exact isEmptyElim g + pairing_comm := fun g => by + have : IsEmpty (circlesClosed 0).Flag := + inferInstanceAs (IsEmpty Empty) + exact isEmptyElim g + circles_eq := rfl } + rw [f.iso_invariant _ _ h] + exact f.val_empty + | succ n ih => + have h : (circlesClosed (n + 1)).Equiv + (ClosedFragment.union (circlesClosed n) + (circlesClosed 1)) := + (circlesClosedUnion n 1).symm + rw [f.iso_invariant _ _ h, EdgeRankParameter.val_union, + ih, pow_succ] + rfl + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- Relabelling by the unit-padding cast fixes the class. -/ +theorem ofFragment_relabel_unitcast {s t : ℕ} + (Y : Fragment (Fin (s + t))) : + HomSpace.ofFragment f.val (Y.relabel (finCongr + (by omega : s + t = (s + 0) + (t + 0)))) = + HomSpace.ofFragment f.val Y := + HomSpace.ofFragment_congr f + ((Fragment.Equiv.relabelEq Y + (_root_.Equiv.ext (fun _ => Fin.ext rfl))).trans + (Fragment.Equiv.relabelRefl Y)) + +/-- **The class-level circle split**, at the padded arity: the +tensor with a circles-only fragment is the circle power times the +padded class. -/ +theorem ofFragment_tensor_circles {s t : ℕ} + (X : Fragment (Fin (s + t))) (c : ℕ) : + HomSpace.ofFragment f.val + (tensorFragment X (circlesClosed c)) = + circleVal f ^ c • + HomSpace.ofFragment f.val (X.relabel (finCongr + (by omega : s + t = (s + 0) + (t + 0)))) := by + rw [← HomSpace.tensor_ofFragment, + show HomSpace.ofFragment f.val (circlesClosed c) = + f.val (circlesClosed c) • + HomSpace.ofFragment f.val emptyClosedFragment from + ofFragment_eq_smul_empty f (circlesClosed c), + map_smul, circlesClosed_val, HomSpace.tensor_ofFragment] + exact congrArg (fun z => circleVal f ^ c • z) + (HomSpace.ofFragment_congr f (tensorFragmentUnitRight X)) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircuitCount.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircuitCount.lean new file mode 100644 index 0000000000..49be34aef9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircuitCount.lean @@ -0,0 +1,270 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists + +/-! +# Circuit count decomposition via orientations + +The orbit count of the walk permutation decomposes into the orbit +counts of its restrictions to out-flags and in-flags (invariant +predicates under the walk). Pairing-conjugation shows these two +restrictions have the same orbit count, whence the circuit count +(half the total orbit count) equals the orbit count of the +out-restriction. +-/ + +@[expose] public section + +namespace RS + +open Equiv + +/-! ### Orbit count of a permutation -/ + +section OrbitCount + +variable {β : Type} + +/-- The orbit count of a permutation: number of non-trivial cycles +plus number of fixed points. -/ +noncomputable def orbitCount [Fintype β] [DecidableEq β] + (π : Perm β) : ℕ := + π.cycleType.card + Fintype.card (Function.fixedPoints π) + +/-- Decomposition of a permutation into ofSubtype parts for an +invariant predicate and its complement. -/ +theorem perm_eq_ofSubtype_mul (π : Perm β) (p : β → Prop) [DecidablePred p] + (hp : ∀ x, p (π x) ↔ p x) : + π = Perm.ofSubtype (π.subtypePerm hp) * + Perm.ofSubtype (π.subtypePerm (p := fun x => ¬p x) (fun x => + (hp x).not)) := by + ext x + simp only [Perm.mul_apply] + by_cases hpx : p x + · have h1 : (Perm.ofSubtype (π.subtypePerm (p := fun x => ¬p x) + (fun x => (hp x).not))) x = x := + Perm.ofSubtype_apply_of_not_mem _ (not_not.mpr hpx) + have h2 : (Perm.ofSubtype (π.subtypePerm hp)) x = π x := + Perm.ofSubtype_subtypePerm_of_mem hp hpx + simp [h1, h2] + · have h1 : (Perm.ofSubtype (π.subtypePerm (p := fun x => ¬p x) + (fun x => (hp x).not))) x = π x := + Perm.ofSubtype_subtypePerm_of_mem (p := fun x => ¬p x) (fun x => + (hp x).not) hpx + have h2 : (Perm.ofSubtype (π.subtypePerm hp)) (π x) = π x := + Perm.ofSubtype_subtypePerm_of_not_mem hp ((hp x).not.mpr hpx) + simp [h1, h2] + +/-- The ofSubtype lifts of the p-restriction and not-p-restriction +are disjoint. -/ +theorem disjoint_ofSubtype_subtypePerm (π : Perm β) (p : β → Prop) + [DecidablePred p] + (hp : ∀ x, p (π x) ↔ p x) : + Perm.Disjoint + (Perm.ofSubtype (π.subtypePerm hp)) + (Perm.ofSubtype (π.subtypePerm (p := fun x => ¬p x) (fun x => + (hp x).not))) := by + intro x + by_cases hpx : p x + · right + exact Perm.ofSubtype_apply_of_not_mem _ (not_not.mpr hpx) + · left + exact Perm.ofSubtype_subtypePerm_of_not_mem hp hpx + +/-- The orbit count of a permutation splits additively over an +invariant predicate. -/ +theorem orbitCount_eq_add [Fintype β] [DecidableEq β] + (π : Perm β) (p : β → Prop) [DecidablePred p] + (hp : ∀ x, p (π x) ↔ p x) : + orbitCount π = orbitCount (π.subtypePerm hp) + + orbitCount (π.subtypePerm (p := fun x => ¬p x) (fun x => + (hp x).not)) := by + unfold orbitCount + have hdecomp := perm_eq_ofSubtype_mul π p hp + have hdisj := disjoint_ofSubtype_subtypePerm π p hp + have hct : π.cycleType = + (π.subtypePerm hp).cycleType + + (π.subtypePerm (p := fun x => ¬p x) (fun x => (hp x).not)).cycleType := by + conv_lhs => rw [hdecomp] + rw [hdisj.cycleType_mul, Perm.cycleType_ofSubtype, Perm.cycleType_ofSubtype] + rw [Perm.card_fixedPoints π, Perm.card_fixedPoints (π.subtypePerm hp), + Perm.card_fixedPoints (π.subtypePerm (p := fun x => ¬p x) (fun x => + (hp x).not)), + hct, Multiset.card_add, Multiset.sum_add] + have hle_p := Perm.sum_cycleType_le (π.subtypePerm hp) + have hle_np := Perm.sum_cycleType_le + (π.subtypePerm (p := fun x => ¬p x) (fun x => (hp x).not)) + have h1 := Fintype.card_subtype_compl p + have h2 := Fintype.card_subtype_le (fun x : β => p x) + omega + +/-- Orbit count is invariant under inversion. -/ +theorem orbitCount_inv [Fintype β] [DecidableEq β] + (π : Perm β) : + orbitCount π⁻¹ = orbitCount π := by + unfold orbitCount + rw [Perm.cycleType_inv, Perm.card_fixedPoints π⁻¹, + Perm.card_fixedPoints π, Perm.cycleType_inv] + +/-- Orbit count is invariant under transport along an +equivalence. -/ +theorem orbitCount_permCongr [Fintype β] [DecidableEq β] + {γ : Type} [Fintype γ] [DecidableEq γ] + (e : β ≃ γ) (π : Perm β) : + orbitCount (e.permCongr π) = orbitCount π := by + unfold orbitCount + rw [cycleType_permCongr, card_fixedPoints_permCongr] + +/-- `(-1)^(a - b) = (-1)^a * (-1)^b` when `b le a`, since +`(-1)^b` is its own inverse. -/ +private theorem neg_one_pow_sub {a b : ℕ} (h : b ≤ a) : + (-1 : ℂ) ^ (a - b) = (-1 : ℂ) ^ a * (-1 : ℂ) ^ b := by + have h1 : (-1 : ℂ) ^ (a - b) * (-1) ^ b = (-1) ^ a := by + rw [← pow_add]; congr 1; omega + have h2 : (-1 : ℂ) ^ b * (-1) ^ b = 1 := by + rw [← pow_add, ← two_mul, pow_mul, neg_one_sq, one_pow] + calc (-1 : ℂ) ^ (a - b) + = (-1) ^ (a - b) * ((-1) ^ b * (-1) ^ b) := by rw [h2, mul_one] + _ = ((-1) ^ (a - b) * (-1) ^ b) * (-1) ^ b := by ring + _ = (-1) ^ a * (-1) ^ b := by rw [h1] + +/-- The sign identity: `(-1)^(orbitCount pi) = (-1)^(card beta) * sign pi`. -/ +theorem neg_one_pow_orbitCount [Fintype β] [DecidableEq β] + (π : Perm β) : + (-1 : ℂ) ^ orbitCount π = + (-1 : ℂ) ^ Fintype.card β * ((Perm.sign π : ℤ) : ℂ) := by + have hsign : ((Perm.sign π : ℤ) : ℂ) = + (-1 : ℂ) ^ (π.cycleType.sum + π.cycleType.card) := by + have h := Perm.sign_of_cycleType π + have hint : (Perm.sign π : ℤ) = + (-1 : ℤ) ^ (π.cycleType.sum + π.cycleType.card) := by + have := congr_arg Units.val h + simp only [Units.val_pow_eq_pow_val, Units.val_neg, Units.val_one] at this + exact this + simp only [hint, Int.cast_pow, Int.cast_neg, Int.cast_one] + unfold orbitCount + rw [Perm.card_fixedPoints, pow_add, + neg_one_pow_sub π.sum_cycleType_le, hsign, pow_add] + ring + +end OrbitCount + +/-! ### Walk-orientation interaction -/ + +variable {α : Type} {W : Fragment α} {F : EdgeSubset W} + +namespace EdgeSubset.TransitionSystem + +/-- The walk preserves the orientation bit: pairing flips it once, +the matching flips it back. -/ +theorem walk_isOut (κ : F.TransitionSystem) (o : κ.Orientation) + (f : W.Flag) (hf : f ∈ F.flags) : + o.isOut (κ.walk f) = o.isOut f := by + unfold TransitionSystem.walk + rw [o.match_flip (W.pairing f) (F.pairing_mem f hf), + o.pairing_flip f hf, Bool.not_not] + +/-- The walk permutation preserves the out-flag predicate. -/ +theorem walkPerm_isOut_iff (κ : F.TransitionSystem) (o : κ.Orientation) + (x : {f : W.Flag // f ∈ F.flags}) : + (o.isOut (κ.walkPerm x).val = true) ↔ (o.isOut x.val = true) := by + rw [κ.walkPerm_val, κ.walk_isOut o x.val x.prop] + +/-- The out-flag restriction of the walk permutation. -/ +noncomputable def outPerm (κ : F.TransitionSystem) (o : κ.Orientation) : + Perm {f : {g : W.Flag // g ∈ F.flags} // o.isOut f.val = true} := + κ.walkPerm.subtypePerm (fun x => κ.walkPerm_isOut_iff o x) + +/-! ### In/out orbit equivalence -/ + +/-- The pairing permutation maps out-flags to in-flags. -/ +private theorem pairingPerm_isOut_flip (κ : F.TransitionSystem) (o : + κ.Orientation) + (a : {f : W.Flag // f ∈ F.flags}) : + (o.isOut a.val = true) ↔ ¬(o.isOut (F.pairingPerm a).val = true) := by + simp only [EdgeSubset.pairingPerm_val, o.pairing_flip a.val a.prop] + cases o.isOut a.val <;> simp + +/-- The equivalence between out-flags and in-flags induced by the +edge pairing. -/ +noncomputable def outToIn (κ : F.TransitionSystem) (o : κ.Orientation) : + {x : {g : W.Flag // g ∈ F.flags} // o.isOut x.val = true} ≃ + {x : {g : W.Flag // g ∈ F.flags} // ¬(o.isOut x.val = true)} := + F.pairingPerm.subtypeEquiv (fun a => by exact κ.pairingPerm_isOut_flip o a) + +/-- The reverse conjugation identity: sigma * walk^{-1} * sigma = walk. -/ +private theorem conj_eq_walkPerm (κ : F.TransitionSystem) : + F.pairingPerm * κ.walkPerm⁻¹ * F.pairingPerm = κ.walkPerm := by + have h := κ.conj_zpow (-1) + simp only [zpow_neg_one, neg_neg, zpow_one] at h + exact h + +/-- Key computation: sigma(walk^{-1}(sigma x)) = walk x. -/ +private theorem pairing_walkInv_pairing (κ : F.TransitionSystem) + (x : {f : W.Flag // f ∈ F.flags}) : + F.pairingPerm (κ.walkPerm⁻¹ (F.pairingPerm x)) = κ.walkPerm x := by + have h := congr_fun (congr_arg DFunLike.coe (κ.conj_eq_walkPerm)) x + simpa [Perm.mul_apply] using h + +/-- The in-restriction of the walk permutation equals the +outToIn-transport of the inverse out-restriction. -/ +theorem inPerm_eq_permCongr_outPerm_inv (κ : F.TransitionSystem) (o : + κ.Orientation) : + κ.walkPerm.subtypePerm (p := fun x => ¬(o.isOut x.val = true)) + (fun x => (κ.walkPerm_isOut_iff o x).not) = + (κ.outToIn o).permCongr (κ.outPerm o)⁻¹ := by + apply Perm.ext + intro ⟨y, hy⟩ + apply Subtype.ext + -- After Subtype.ext, goal is definitionally: + -- walkPerm y = pairingPerm (walkPerm^{-1} (pairingPerm^{-1} y)) + -- We convert to this form, rewrite pairingPerm^{-1} to pairingPerm, then use + -- the key lemma + change κ.walkPerm y = F.pairingPerm (κ.walkPerm⁻¹ (F.pairingPerm⁻¹ y)) + rw [EdgeSubset.pairingPerm_inv] + exact (κ.pairing_walkInv_pairing y).symm + +/-- The in-restriction and out-restriction of the walk permutation +have the same orbit count. -/ +theorem orbitCount_inPerm_eq (κ : F.TransitionSystem) (o : κ.Orientation) : + orbitCount (κ.walkPerm.subtypePerm (p := fun x => ¬(o.isOut x.val = true)) + (fun x => (κ.walkPerm_isOut_iff o x).not)) = + orbitCount (κ.outPerm o) := by + rw [κ.inPerm_eq_permCongr_outPerm_inv o, orbitCount_permCongr, orbitCount_inv] + +/-! ### Main theorems -/ + +/-- The circuit count of a transition system equals the orbit count +of its out-flag restriction. -/ +theorem circuitCount_eq_orbitCount_outPerm (κ : F.TransitionSystem) + (o : κ.Orientation) : + κ.circuitCount = orbitCount (κ.outPerm o) := by + have hsplit := orbitCount_eq_add κ.walkPerm + (fun x => o.isOut x.val = true) (fun x => κ.walkPerm_isOut_iff o x) + have heq := κ.orbitCount_inPerm_eq o + -- The out-part of the split is definitionally outPerm + have hout : orbitCount (κ.walkPerm.subtypePerm + (fun x => κ.walkPerm_isOut_iff o x)) = orbitCount (κ.outPerm o) := rfl + have hdouble : orbitCount κ.walkPerm = 2 * orbitCount (κ.outPerm o) := by + rw [hsplit, heq, hout]; ring + unfold TransitionSystem.circuitCount orbitCount at hdouble ⊢ + omega + +/-- The circuit sign decomposes as `(-1)^(card out-flags) * sign(outPerm)`. -/ +theorem neg_one_pow_circuitCount (κ : F.TransitionSystem) + (o : κ.Orientation) : + ((-1 : ℂ) ^ κ.circuitCount) = + (-1 : ℂ) ^ (Fintype.card + {f : {g : W.Flag // g ∈ F.flags} // o.isOut f.val = true}) * + ((Perm.sign (κ.outPerm o) : ℤ) : ℂ) := by + rw [κ.circuitCount_eq_orbitCount_outPerm o, neg_one_pow_orbitCount] + +end EdgeSubset.TransitionSystem + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ClosedTransition.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ClosedTransition.lean new file mode 100644 index 0000000000..3a3e7b51a7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ClosedTransition.lean @@ -0,0 +1,41 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockRestrict +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists + +/-! +# Transitions on closed fragments + +Closed fragments have no boundary labels, so every flag attaches +internally, and every Eulerian edge subset admits an oriented +transition system: the choice in the Definition 5 value is +always inhabited. +-/ + +@[expose] public section + +namespace RS + +/-- Every flag of a closed fragment attaches to a vertex. -/ +theorem ClosedFragment.attach_internal (W : ClosedFragment) + (f : W.Flag) : ∃ v : W.Vertex, W.attach f = Sum.inl v := by + rcases h : W.attach f with v | ℓ0 + · exact ⟨v, rfl⟩ + · exact ℓ0.elim0 + +/-- Eulerian subsets of closed fragments admit oriented +transition systems. -/ +theorem ClosedFragment.eulerian_transition_nonempty + (W : ClosedFragment) (F : EdgeSubset W) + (hE : F.Eulerian) : + Nonempty ((κ : F.TransitionSystem) × κ.Orientation) := + F.exists_transition_orientation hE + (fun f _ => W.attach_internal f) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ConcatSign.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ConcatSign.lean new file mode 100644 index 0000000000..c1770355cc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ConcatSign.lean @@ -0,0 +1,225 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ChainLists + +/-! +# Concatenation sign factorisation + +The global key-sortSign of the concatenated pair enumeration equals +the product of the per-block key-sortSigns: key ranges of distinct +blocks are disjoint and ordered, so concatenation adds no inversions. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {k ℓ : ℕ} + +/-! ## Cross-block key monotonicity -/ + +/-- Keys from an earlier block are strictly less than keys from a +later block. -/ +theorem blockSigmaEquiv_lt_of_block_lt : + ∀ {ds : List ℕ} {v₁ v₂ : Fin ds.length} + (_ : v₁ < v₂) (j₁ : Fin (ds.get v₁)) (j₂ : Fin (ds.get v₂)), + blockSigmaEquiv ds ⟨v₁, j₁⟩ < blockSigmaEquiv ds ⟨v₂, j₂⟩ + | [], v₁, _, _, _, _ => v₁.elim0 + | d :: ds, v₁, v₂, hlt, j₁, j₂ => by + match v₁, v₂ with + | ⟨0, hv₁⟩, ⟨0, hv₂⟩ => + exact absurd hlt (lt_irrefl _) + | ⟨0, hv₁⟩, ⟨w₂ + 1, hv₂⟩ => + rw [Fin.lt_def] + have h1 : (blockSigmaEquiv (d :: ds) ⟨⟨0, hv₁⟩, j₁⟩).val = + j₁.val := rfl + have hw₂ : w₂ < ds.length := by + simp only [List.length_cons] at hv₂; omega + have h2 : (blockSigmaEquiv (d :: ds) ⟨⟨w₂ + 1, hv₂⟩, j₂⟩).val = + d + (blockSigmaEquiv ds ⟨⟨w₂, hw₂⟩, j₂⟩).val := rfl + rw [h1, h2] + have hj₁ : j₁.val < d := j₁.isLt + omega + | ⟨w₁ + 1, hv₁⟩, ⟨0, hv₂⟩ => + simp only [Fin.lt_def] at hlt + omega + | ⟨w₁ + 1, hv₁⟩, ⟨w₂ + 1, hv₂⟩ => + have hw₁ : w₁ < ds.length := by + simp only [List.length_cons] at hv₁; omega + have hw₂ : w₂ < ds.length := by + simp only [List.length_cons] at hv₂; omega + have hlt' : (⟨w₁, hw₁⟩ : Fin ds.length) < ⟨w₂, hw₂⟩ := by + simp only [Fin.lt_def] at hlt ⊢; omega + have hrec := blockSigmaEquiv_lt_of_block_lt hlt' j₁ j₂ + rw [Fin.lt_def] + have h1 : (blockSigmaEquiv (d :: ds) ⟨⟨w₁ + 1, hv₁⟩, j₁⟩).val = + d + (blockSigmaEquiv ds ⟨⟨w₁, hw₁⟩, j₁⟩).val := rfl + have h2 : (blockSigmaEquiv (d :: ds) ⟨⟨w₂ + 1, hv₂⟩, j₂⟩).val = + d + (blockSigmaEquiv ds ⟨⟨w₂, hw₂⟩, j₂⟩).val := rfl + rw [h1, h2] + rw [Fin.lt_def] at hrec + omega + +/-! ## Inversions under ordered append -/ + +/-- Appending two lists whose elements are in order adds no +inversions. -/ +theorem inversions_append_of_le {α : Type} [LinearOrder α] : + ∀ (l₁ l₂ : List α) + (_ : ∀ x ∈ l₁, ∀ y ∈ l₂, x ≤ y), + inversions (l₁ ++ l₂) = inversions l₁ + inversions l₂ + | [], l₂, _ => by simp [inversions] + | a :: l₁, l₂, h => by + rw [List.cons_append, inversions, inversions] + have hrec := inversions_append_of_le l₁ l₂ (fun x hx y hy => + h x (List.mem_cons_of_mem a hx) y hy) + rw [hrec] + -- the filter over l₁ ++ l₂ splits as filter over l₁ + filter over l₂ + have hfilt : (l₁ ++ l₂).filter (fun b => decide (b < a)) = + l₁.filter (fun b => decide (b < a)) ++ + l₂.filter (fun b => decide (b < a)) := by + exact List.filter_append l₁ l₂ + rw [hfilt, List.length_append] + -- the l₂ part of the filter is empty + have hempty : l₂.filter (fun b => decide (b < a)) = [] := by + rw [List.filter_eq_nil_iff] + intro b hb + simp only [decide_eq_true_eq] + exact not_lt.mpr (h a (List.mem_cons.mpr (Or.inl rfl)) b hb) + rw [hempty, List.length_nil] + omega + +/-- The sortSign is multiplicative under ordered append. -/ +theorem sortSign_append_of_le {α : Type} [LinearOrder α] + (l₁ l₂ : List α) + (h : ∀ x ∈ l₁, ∀ y ∈ l₂, x ≤ y) : + sortSign (l₁ ++ l₂) = sortSign l₁ * sortSign l₂ := by + rw [sortSign, inversions_append_of_le l₁ l₂ h, pow_add] + rfl + +/-! ## Key membership in blocks -/ + +/-- A pair-flag at block v has its key in that block's sigma range. -/ +theorem sortKey_mem_block (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) + (v : Fin (ds W).length) + (f : {f : W.Flag // f ∈ F.flags}) + (hf : f ∈ pairFlagList (F := F) o (blockVertex W v)) : + ∃ j : Fin ((ds W).get v), + sortKey W f.val = blockSigmaEquiv (ds W) ⟨v, j⟩ := by + classical + have hatt := (mem_pairFlagList o (blockVertex W v) f).mp hf + have hvtx : ClosedFragment.vertexOf W f.val = blockVertex W v := + Sum.inl.inj + ((ClosedFragment.attach_eq_vertexOf W f.val).symm.trans hatt) + have hmem : f.val ∈ Finset.univ.filter (fun g => + ClosedFragment.vertexOf W g = blockVertex W v) := by + rw [Finset.mem_filter] + exact ⟨Finset.mem_univ _, hvtx⟩ + rw [← image_blockFlag] at hmem + rw [Finset.mem_image] at hmem + obtain ⟨j, _, hj⟩ := hmem + exact ⟨j, by rw [← hj, sortKey_blockFlag]⟩ + +/-! ## Global list properties -/ + +/-- The global pair list is duplicate-free. -/ +theorem globalPairList_nodup (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) : + (globalPairList W F o).Nodup := by + rw [globalPairList, List.nodup_flatMap] + constructor + · intro v _ + exact pairFlagList_nodup o (blockVertex W v) + · have hpw : (List.finRange (ds W).length).Pairwise (· < ·) := + (List.sortedLT_finRange _).pairwise + exact hpw.imp (fun {v₁ v₂} hlt => by + change List.Disjoint _ _ + intro x hx₁ hx₂ + have h₁ := (mem_pairFlagList o (blockVertex W v₁) x).mp hx₁ + have h₂ := (mem_pairFlagList o (blockVertex W v₂) x).mp hx₂ + have : blockVertex W v₁ = blockVertex W v₂ := + Sum.inl.inj (h₁.symm.trans h₂) + exact absurd (blockVertex_injective' W this) (ne_of_lt hlt)) + +/-- Every participating flag appears in the global pair list. -/ +theorem mem_globalPairList (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) + (x : {f : W.Flag // f ∈ F.flags}) : + x ∈ globalPairList W F o := by + rw [globalPairList, List.mem_flatMap] + have hatt := ClosedFragment.attach_eq_vertexOf W x.val + obtain ⟨v, hv⟩ := blockVertex_surjective' W (ClosedFragment.vertexOf W x.val) + refine ⟨v, List.mem_finRange v, ?_⟩ + rw [mem_pairFlagList] + rw [hatt, hv] + +/-! ## Main theorem -/ + +/-- The sortSign of the flatMap over a pairwise-ordered list of block +indices equals the list product of per-block sortSigns. -/ +private theorem sortSign_flatMap_aux (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) : + ∀ (L : List (Fin (ds W).length)), + L.Pairwise (· < ·) → + (sortSign ((L.flatMap (fun v => + pairFlagList (F := F) o (blockVertex W v))).map + (fun f => sortKey W f.val)) : ℤ) = + (L.map (fun v => + sortSign ((pairFlagList (F := F) o (blockVertex W v)).map + (fun f => sortKey W f.val)))).prod + | [], _ => by simp [sortSign, inversions] + | v₀ :: L, hpw => by + rw [List.flatMap_cons, List.map_append, + sortSign_append_of_le _ _ ?_, List.map_cons, List.prod_cons] + · congr 1 + exact sortSign_flatMap_aux W F o L hpw.of_cons + · intro x hx y hy + rw [List.mem_map] at hx hy + obtain ⟨fx, hfx, rfl⟩ := hx + obtain ⟨fy, hfy, rfl⟩ := hy + -- fy is in the flatMap tail, so it belongs to some block v' with v₀ < v' + rw [List.mem_flatMap] at hfy + obtain ⟨v', hv'L, hfy'⟩ := hfy + obtain ⟨jx, hjx⟩ := sortKey_mem_block W F o v₀ fx hfx + obtain ⟨jy, hjy⟩ := sortKey_mem_block W F o v' fy hfy' + rw [hjx, hjy] + have hlt : v₀ < v' := List.rel_of_pairwise_cons hpw hv'L + exact le_of_lt (blockSigmaEquiv_lt_of_block_lt hlt jx jy) + +/-- **The global key-sortSign is the product of the per-block +key-sortSigns.** -/ +theorem sortSign_globalPairList (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) : + (sortSign ((globalPairList W F o).map (fun f => sortKey W f.val)) : ℂ) = + ∏ v : Fin (ds W).length, + (sortSign ((pairFlagList (F := F) o (blockVertex W v)).map + (fun f => sortKey W f.val)) : ℂ) := by + -- Work in ℤ first, then cast + have hint : (sortSign ((globalPairList W F o).map + (fun f => sortKey W f.val)) : ℤ) = + ∏ v : Fin (ds W).length, + sortSign ((pairFlagList (F := F) o (blockVertex W v)).map + (fun f => sortKey W f.val)) := by + rw [globalPairList] + rw [sortSign_flatMap_aux W F o (List.finRange (ds W).length) + (List.sortedLT_finRange _).pairwise] + rw [Fin.prod_univ_def] + rw [show (sortSign ((globalPairList W F o).map + (fun f => sortKey W f.val)) : ℂ) = + ((sortSign ((globalPairList W F o).map + (fun f => sortKey W f.val)) : ℤ) : ℂ) from rfl] + rw [hint, Int.cast_prod] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordInterface.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordInterface.lean new file mode 100644 index 0000000000..716f0f862f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordInterface.lean @@ -0,0 +1,96 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTransport + +/-! +# The coordinate interface + +A morphism `⟨0⟩ ⟶ ⟨d⟩` of the skein category has an image vector +in the fibre of `⟨d⟩` (evaluate the unit-conjugated image at +`1`), and a morphism `⟨d⟩ ⟶ ⟨0⟩` has an image functional. The +scalar of a composite is the functional applied to the vector — +definitionally. Specialised to the star composite this expresses +the parameter value as a pairing in the fibre, ready for the +standard-model coordinates. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Functor.LaxMonoidal Functor.OplaxMonoidal + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) + +/-- The image vector of a `⟨0⟩ ⟶ ⟨d⟩` morphism. -/ +noncomputable def omegaVec {d : ℕ} + (p : (SkeinObj.mk 0 : SkeinObj f) ⟶ SkeinObj.mk d) : + (P.ω.obj (SkeinObj.mk d)).even := + letI := P.braided + ((ε P.ω ≫ P.ω.map p : SuperVect.tensorUnit ⟶ + P.ω.obj (SkeinObj.mk d)) : + SuperVect.Hom _ _).evenMap 1 + +/-- The image functional of a `⟨d⟩ ⟶ ⟨0⟩` morphism. -/ +noncomputable def omegaFun {d : ℕ} + (q : (SkeinObj.mk d : SkeinObj f) ⟶ SkeinObj.mk 0) : + (P.ω.obj (SkeinObj.mk d)).even →ₗ[ℂ] ℂ := + letI := P.braided + ((P.ω.map q ≫ η P.ω : P.ω.obj (SkeinObj.mk d) ⟶ + SuperVect.tensorUnit) : SuperVect.Hom _ _).evenMap + +/-- **The pairing split**: the scalar of a composite is the +functional applied to the vector. -/ +theorem omega_pairing {d : ℕ} + (p : (SkeinObj.mk 0 : SkeinObj f) ⟶ SkeinObj.mk d) + (q : (SkeinObj.mk d : SkeinObj f) ⟶ SkeinObj.mk 0) : + letI := P.braided + ((ε P.ω ≫ (P.ω.map p ≫ P.ω.map q) ≫ η P.ω : + SuperVect.tensorUnit ⟶ SuperVect.tensorUnit) : + SuperVect.Hom _ _).evenMap 1 = + omegaFun f P q (omegaVec f P p) := rfl + +/-- **The parameter value as a fibre pairing.** -/ +theorem star_pairing (W : ClosedFragment) : + omegaFun f P (bundleCapClass f (edgeCount W)) + (omegaVec f P (starClass f W)) = f.val W := by + let := P.braided + rw [← omega_pairing] + exact omega_star_scalar f P W + +/-- The single-vertex star with `d` legs: one internal vertex, +`d` pendant edges. -/ +def vertexStar (d : ℕ) : Fragment (Fin d) where + Flag := Fin d ⊕ Fin d + Vertex := Unit + attach := fun g => match g with + | Sum.inl _ => Sum.inl () + | Sum.inr i => Sum.inr i + pairing := fun g => match g with + | Sum.inl i => Sum.inr i + | Sum.inr i => Sum.inl i + pairing_invol := fun g => by rcases g with i | i <;> rfl + pairing_ne := fun g => by rcases g with i | i <;> simp + boundaryFlag := Sum.inr + attach_boundaryFlag := fun _ => rfl + eq_boundaryFlag := fun ℓ g h => by + rcases g with i | i + · exact absurd h (by simp) + · exact congrArg Sum.inr (Sum.inr.inj h) + circles := 0 + +/-- The degree-`d` vertex functional data: the image vector of +the vertex star read as a `(0, d)`-morphism. -/ +noncomputable def starVec (d : ℕ) : + (P.ω.obj (SkeinObj.mk d)).even := + omegaVec f P (HomSpace.ofFragment f.val + ((vertexStar d).relabel (finCongr (by omega : d = 0 + d)))) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordOf.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordOf.lean new file mode 100644 index 0000000000..218fe59947 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordOf.lean @@ -0,0 +1,123 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ParameterModel +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConj + +/-! +# Coordinates of model vectors + +The coordinate reading of a power vector at a colouring (zero on +odd parity), the cast rule, the conjugation transfer, and the +basis expansion: the vocabulary in which the final computation +evaluates. +-/ + +@[expose] public section + +namespace RS + +variable {k ℓ : ℕ} + +/-- The coordinate of a model vector at a colouring. -/ +noncomputable def coordOf {n : ℕ} + (v : (superPow (stdSuperPair k ℓ) n).even) + (c : MixedColouring k ℓ n) : ℂ := + if hc : c.IsEven then + (colourPowerEquiv k ℓ n).evenEquiv v ⟨c, hc⟩ else 0 + +/-- Coordinates vanish on odd parity. -/ +theorem coordOf_odd {n : ℕ} + (v : (superPow (stdSuperPair k ℓ) n).even) + (c : MixedColouring k ℓ n) (hc : ¬ c.IsEven) : + coordOf v c = 0 := + dite_eq_right hc + +/-- The cast rule: coordinates of a recast vector read the +recast colouring. -/ +theorem coordOf_cast {n₁ n₂ : ℕ} (h : n₁ = n₂) + (v : (superPow (stdSuperPair k ℓ) n₁).even) + (c : MixedColouring k ℓ n₂) : + coordOf (((CategoryTheory.eqToHom + (congrArg (superPow (stdSuperPair k ℓ)) h) : + superPow (stdSuperPair k ℓ) n₁ ⟶ + superPow (stdSuperPair k ℓ) n₂) : + SuperVect.Hom _ _).evenMap v) c = + coordOf v (c ∘ finCongr h) := by + subst h + rfl + +/-- The conjugation transfer: colour-model conjugates act on +coordinate functions. -/ +theorem toColour_apply {n : ℕ} + (g : superPow (stdSuperPair k ℓ) n ⟶ superPow (stdSuperPair k ℓ) n) + (v : (superPow (stdSuperPair k ℓ) n).even) : + ((toColour n g) : SuperVect.Hom _ _).evenMap + ((colourPowerEquiv k ℓ n).evenEquiv v) = + (colourPowerEquiv k ℓ n).evenEquiv + ((g : SuperVect.Hom _ _).evenMap v) := by + change (colourPowerEquiv k ℓ n).evenEquiv + ((g : SuperVect.Hom _ _).evenMap + ((colourPowerEquiv k ℓ n).evenEquiv.symm + ((colourPowerEquiv k ℓ n).evenEquiv v))) = _ + rw [(colourPowerEquiv k ℓ n).evenEquiv.symm_apply_apply] + +/-- The basis expansion of a model vector by its coordinates. -/ +theorem coord_expansion {n : ℕ} + (v : (superPow (stdSuperPair k ℓ) n).even) : + v = ∑ c : {c : MixedColouring k ℓ n // c.IsEven}, + ((colourPowerEquiv k ℓ n).evenEquiv v c) • + (colourPowerEquiv k ℓ n).evenEquiv.symm + (Pi.single c 1) := by + apply (colourPowerEquiv k ℓ n).evenEquiv.injective + rw [map_sum] + have hterm : ∀ c' : {c : MixedColouring k ℓ n // c.IsEven}, + (colourPowerEquiv k ℓ n).evenEquiv + (((colourPowerEquiv k ℓ n).evenEquiv v c') • + (colourPowerEquiv k ℓ n).evenEquiv.symm + (Pi.single c' 1)) = + Pi.single c' ((colourPowerEquiv k ℓ n).evenEquiv v c') := + fun c' => by + rw [map_smul] + rw [show (colourPowerEquiv k ℓ n).evenEquiv + ((colourPowerEquiv k ℓ n).evenEquiv.symm + (Pi.single c' 1)) = Pi.single c' (1 : ℂ) from + (colourPowerEquiv k ℓ n).evenEquiv.apply_symm_apply _] + funext j + by_cases hj : j = c' + · subst hj + have h1 : (Pi.single j (1 : ℂ) : + {c : MixedColouring k ℓ n // c.IsEven} → ℂ) j = + (1 : ℂ) := Pi.single_eq_same j 1 + have h2 : (Pi.single j + ((colourPowerEquiv k ℓ n).evenEquiv v j) : + {c : MixedColouring k ℓ n // c.IsEven} → ℂ) j = + (colourPowerEquiv k ℓ n).evenEquiv v j := + Pi.single_eq_same j _ + trans ((colourPowerEquiv k ℓ n).evenEquiv v j) + · exact (congrArg (fun z : ℂ => + ((colourPowerEquiv k ℓ n).evenEquiv v j) • z) + h1).trans (mul_one _) + · exact h2.symm + · have h1 : (Pi.single c' (1 : ℂ) : + {c : MixedColouring k ℓ n // c.IsEven} → ℂ) j = + 0 := Pi.single_eq_of_ne hj 1 + have h2 : (Pi.single c' + ((colourPowerEquiv k ℓ n).evenEquiv v c') : + {c : MixedColouring k ℓ n // c.IsEven} → ℂ) j = + 0 := Pi.single_eq_of_ne hj _ + trans (0 : ℂ) + · exact (congrArg (fun z : ℂ => + ((colourPowerEquiv k ℓ n).evenEquiv v c') • z) + h1).trans (smul_zero _) + · exact h2.symm + rw [Finset.sum_congr rfl (fun c' _ => hterm c')] + exact (Finset.univ_sum_single + ((colourPowerEquiv k ℓ n).evenEquiv v)).symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoreParity.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoreParity.lean new file mode 100644 index 0000000000..0d06043924 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoreParity.lean @@ -0,0 +1,370 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaFlip +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauCount +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ConcatSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SignPair +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RiffleSign +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RegroupSign + +/-! +# The core and grand parities + +The two parity counts the extraction's sign bookkeeping rests on: +the parity of the core slots' pairing and the parity of the whole +slot list. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Finset +open Functor.LaxMonoidal Functor.OplaxMonoidal + + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} +variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) +variable (e' : P.ω.obj (SkeinObj.mk 1) ⟶ stdSuperPair k ℓ) + +private theorem core_out_card (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) : + Fintype.card + {f : {g : W.Flag // g ∈ F.flags} // + o.isOut f.val = true} = + (edgeIndexSet W F).card := by + classical + have hcard2 : F.flags.card = + 2 * (edgeIndexSet W F).card := by + have h1 : Fintype.card {f : W.Flag // f ∈ F.flags} = + F.flags.card := Fintype.card_coe _ + have h2 : (Finset.univ : + Finset {f : W.Flag // f ∈ F.flags}) = + (edgePairList W F).toFinset := by + ext x + simp only [Finset.mem_univ, List.mem_toFinset, + true_iff] + exact mem_edgePairList W F x + have h3 : Fintype.card {f : W.Flag // f ∈ F.flags} = + (edgePairList W F).length := by + rw [← Finset.card_univ, h2] + exact List.toFinset_card_of_nodup (edgePairList_nodup W F) + have h4 : (edgePairList W F).length = + 2 * (edgeIndexSet W F).card := by + rw [edgePairList, List.length_flatMap] + have h5 : (((partEdges W F).attachWith + (· ∈ edgeIndexSet W F) + (fun _ hi => (Finset.mem_sort _).mp hi)).map + (fun i => ([⟨(starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i.val), + repMem_of_partEdge i.prop⟩, + ⟨(starFlagEnum W).symm + (Fin.natAdd (edgeCount W) i.val), + partnerMem_of_partEdge i.prop⟩] : + List {f : W.Flag // f ∈ F.flags}).length)) = + List.replicate (((partEdges W F).attachWith + (· ∈ edgeIndexSet W F) + (fun _ hi => (Finset.mem_sort _).mp hi)).length) + 2 := by + refine Eq.trans (List.map_congr_left + (fun i _ => (rfl : _ = 2))) ?_ + exact List.map_const' + rw [h5, List.sum_replicate, smul_eq_mul, + List.length_attachWith] + rw [show (partEdges W F).length = + (edgeIndexSet W F).card from Finset.length_sort (· ≤ ·)] + ring + omega + have hout_card : Fintype.card + {f : {g : W.Flag // g ∈ F.flags} // + o.isOut f.val = true} = + (edgeIndexSet W F).card := by + have h1 := card_out_eq_fintype W F o + have h2 := card_in_eq_card_out W F o + have h3 := Finset.card_filter_add_card_filter_not + (s := F.flags) (p := fun f => o.isOut f = true) + have h4 : F.flags.filter + (fun f => ¬ (o.isOut f = true)) = + F.flags.filter (fun f => o.isOut f = false) := + Finset.filter_congr (fun f _ => by + cases h : o.isOut f <;> simp) + rw [h4] at h3 + omega + exact hout_card + +/-- **The core parity identity**: the pattern, +crossing and representative signs against the pair-enumeration +key signs compose to the circuit and outgoing signs. -/ +theorem core_parity (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) : + ((-1 : ℂ) ^ patternOddInv W F) * + ((-1 : ℂ) ^ (Finset.univ.filter + (fun p : Fin (edgeCount W) × Fin (edgeCount W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ + p.2 ∈ edgeIndexSet W F)).card * + (-1 : ℂ) ^ inRepCount W F o) * + ∏ v : Fin (ds W).length, + (sortSign ((pairFlagList (F := F) o + (blockVertex W v)).map + (fun f => sortKey W f.val)) : ℂ) = + (-1 : ℂ) ^ κ.circuitCount := by + classical + -- ═══════ STAGE 1: THE FIVE LISTS AGREE AS SETS ═══════ + -- Nodup, membership and length for the slot, edge-pair, oriented, + -- matched and global lists, so that the index permutations between + -- consecutive lists are defined and compose. + have nA := globalSlotList_nodup W F + have nB := edgePairList_nodup W F + have nC := orientedPairList_nodup W F o + have nM := matchedPairList_nodup' W F o + have nD := globalPairList_nodup W F o + have mAB : ∀ x, x ∈ globalSlotList W F ↔ + x ∈ edgePairList W F := fun x => + ⟨fun _ => mem_edgePairList W F x, + fun _ => mem_globalSlotList W F x⟩ + have mBC : ∀ x, x ∈ edgePairList W F ↔ + x ∈ orientedPairList W F o := fun x => + ⟨fun _ => mem_orientedPairList W F o x, + fun _ => mem_edgePairList W F x⟩ + have mCM : ∀ x, x ∈ orientedPairList W F o ↔ + x ∈ matchedPairList W F o := fun x => + ⟨fun _ => mem_matchedPairList' W F o x, + fun _ => mem_orientedPairList W F o x⟩ + have mMD : ∀ x, x ∈ matchedPairList W F o ↔ + x ∈ globalPairList W F o := fun x => + ⟨fun _ => mem_globalPairList W F o x, + fun _ => mem_matchedPairList' W F o x⟩ + have mAD : ∀ x, x ∈ globalSlotList W F ↔ + x ∈ globalPairList W F o := fun x => + ⟨fun _ => mem_globalPairList W F o x, + fun _ => mem_globalSlotList W F x⟩ + have lAB := length_eq_of_nodup_mem _ _ nA nB mAB + have lBC := length_eq_of_nodup_mem _ _ nB nC mBC + have lCM := length_eq_of_nodup_mem _ _ nC nM mCM + have lMD := length_eq_of_nodup_mem _ _ nM nD mMD + have lAD := length_eq_of_nodup_mem _ _ nA nD mAD + -- ═══════ STAGE 2: THE CHAIN OF INDEX PERMUTATIONS ═══════ + -- the chained sign + have hchain : + Equiv.Perm.sign (listIndexPerm (globalSlotList W F) + (globalPairList W F o) nA nD mAD lAD) = + Equiv.Perm.sign (listIndexPerm (globalSlotList W F) + (edgePairList W F) nA nB mAB lAB) * + (Equiv.Perm.sign (listIndexPerm (edgePairList W F) + (orientedPairList W F o) nB nC mBC lBC) * + (Equiv.Perm.sign (listIndexPerm + (orientedPairList W F o) + (matchedPairList W F o) nC nM mCM lCM) * + Equiv.Perm.sign (listIndexPerm + (matchedPairList W F o) + (globalPairList W F o) nM nD mMD lMD))) := by + have t1 := sign_listIndexPerm_trans + (globalSlotList W F) (edgePairList W F) + (globalPairList W F o) nA nB nD mAB + (fun x => (mBC x).trans ((mCM x).trans (mMD x))) + lAB (lBC.trans (lCM.trans lMD)) + have t2 := sign_listIndexPerm_trans + (edgePairList W F) (orientedPairList W F o) + (globalPairList W F o) nB nC nD mBC + (fun x => (mCM x).trans (mMD x)) + lBC (lCM.trans lMD) + have t3 := sign_listIndexPerm_trans + (orientedPairList W F o) (matchedPairList W F o) + (globalPairList W F o) nC nM nD mCM mMD lCM lMD + exact t1.trans (by rw [t2, t3]) + -- the four link values + have hAB := sign_listIndexPerm_slot_edge W F + have hBC := sign_listIndexPerm_edge_oriented W F o + have hCM := sign_listIndexPerm_oriented_matched W F o + have hMD := sign_listIndexPerm_matched_global W F o + -- ═══════ STAGE 3: THE FLAG-COUNT BRIDGE ═══════ + -- the flag-count bridge + have hout_card := core_out_card W F o + -- ═══════ STAGE 4: THE TWO ENDPOINTS OF THE CHAIN ═══════ + -- endpoints: the two key sortSigns pair to the chained sign + have hpair := sortSign_key_pair + (fun f : {f : W.Flag // f ∈ F.flags} => + sortKey W f.val) + (fun a b h => Subtype.ext (sortKey_injective W h)) + (globalSlotList W F) (globalPairList W F o) + nA nD mAD lAD + -- the pattern sign is the A-end key sortSign + have hA : ((-1 : ℂ) ^ patternOddInv W F) = + (sortSign ((globalSlotList W F).map + (fun f => sortKey W f.val)) : ℂ) := by + rw [patternOddInv_eq_inversions W F, sortSign] + push_cast + ring + -- the vertex product is the D-end key sortSign + rw [show (∏ v : Fin (ds W).length, + (sortSign ((pairFlagList (F := F) o + (blockVertex W v)).map + (fun f => sortKey W f.val)) : ℂ)) = + (sortSign ((globalPairList W F o).map + (fun f => sortKey W f.val)) : ℂ) from + (sortSign_globalPairList W F o).symm] + rw [hA] + -- ═══════ ASSEMBLY: THE NUMERIC LEDGER ═══════ + -- close over the numeric ledger + have hs := card_out_add_card_in_edges W F o + have hG := κ.neg_one_pow_circuitCount (o := o) + -- assemble in ℂ + have hADval : ((Equiv.Perm.sign (listIndexPerm + (globalSlotList W F) (globalPairList W F o) + nA nD mAD lAD) : ℤ) : ℂ) = + ((-1 : ℂ) ^ (Finset.univ.filter + (fun p : Fin (edgeCount W) × Fin (edgeCount W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ + p.2 ∈ edgeIndexSet W F)).card) * + ((-1 : ℂ) ^ ((edgeIndexSet W F).filter (fun i => + o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = true)).card) * + ((Equiv.Perm.sign (κ.outPerm o) : ℤ) : ℂ) := by + rw [hchain] + rw [hCM, hMD, mul_one] + push_cast [hAB, hBC] + ring + calc (sortSign ((globalSlotList W F).map + (fun f => sortKey W f.val)) : ℂ) * + ((-1 : ℂ) ^ (Finset.univ.filter + (fun p : Fin (edgeCount W) × Fin (edgeCount W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ + p.2 ∈ edgeIndexSet W F)).card * + (-1 : ℂ) ^ inRepCount W F o) * + (sortSign ((globalPairList W F o).map + (fun f => sortKey W f.val)) : ℂ) + = ((sortSign ((globalSlotList W F).map + (fun f => sortKey W f.val)) : ℂ) * + (sortSign ((globalPairList W F o).map + (fun f => sortKey W f.val)) : ℂ)) * + ((-1 : ℂ) ^ (Finset.univ.filter + (fun p : Fin (edgeCount W) × Fin (edgeCount W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ + p.2 ∈ edgeIndexSet W F)).card * + (-1 : ℂ) ^ inRepCount W F o) := by ring + _ = (((-1 : ℂ) ^ (Finset.univ.filter + (fun p : Fin (edgeCount W) × Fin (edgeCount W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ + p.2 ∈ edgeIndexSet W F)).card) * + ((-1 : ℂ) ^ ((edgeIndexSet W F).filter (fun i => + o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = true)).card) * + ((Equiv.Perm.sign (κ.outPerm o) : ℤ) : ℂ)) * + ((-1 : ℂ) ^ (Finset.univ.filter + (fun p : Fin (edgeCount W) × Fin (edgeCount W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ + p.2 ∈ edgeIndexSet W F)).card * + (-1 : ℂ) ^ inRepCount W F o) := by + rw [hpair, hADval] + _ = ((-1 : ℂ) ^ (((edgeIndexSet W F).filter (fun i => + o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = true)).card + + inRepCount W F o)) * + ((Equiv.Perm.sign (κ.outPerm o) : ℤ) : ℂ) := by + have hxx : ((-1 : ℂ) ^ (Finset.univ.filter + (fun p : Fin (edgeCount W) × + Fin (edgeCount W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ + p.2 ∈ edgeIndexSet W F)).card) * + ((-1 : ℂ) ^ (Finset.univ.filter + (fun p : Fin (edgeCount W) × + Fin (edgeCount W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ + p.2 ∈ edgeIndexSet W F)).card) = 1 := by + rw [← pow_add, ← two_mul, pow_mul] + norm_num + rw [pow_add] + calc ((-1 : ℂ) ^ (Finset.univ.filter + (fun p : Fin (edgeCount W) × + Fin (edgeCount W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ + p.2 ∈ edgeIndexSet W F)).card * + (-1 : ℂ) ^ ((edgeIndexSet W F).filter (fun i => + o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = + true)).card * + ((Equiv.Perm.sign (κ.outPerm o) : ℤ) : ℂ)) * + ((-1 : ℂ) ^ (Finset.univ.filter + (fun p : Fin (edgeCount W) × + Fin (edgeCount W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ + p.2 ∈ edgeIndexSet W F)).card * + (-1 : ℂ) ^ inRepCount W F o) + = (((-1 : ℂ) ^ (Finset.univ.filter + (fun p : Fin (edgeCount W) × + Fin (edgeCount W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ + p.2 ∈ edgeIndexSet W F)).card) * + ((-1 : ℂ) ^ (Finset.univ.filter + (fun p : Fin (edgeCount W) × + Fin (edgeCount W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ + p.2 ∈ edgeIndexSet W F)).card)) * + (((-1 : ℂ) ^ ((edgeIndexSet W F).filter + (fun i => o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = + true)).card * + (-1 : ℂ) ^ inRepCount W F o) * + ((Equiv.Perm.sign (κ.outPerm o) : ℤ) : ℂ)) := by + ring + _ = ((-1 : ℂ) ^ ((edgeIndexSet W F).filter + (fun i => o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = + true)).card * + (-1 : ℂ) ^ inRepCount W F o) * + ((Equiv.Perm.sign (κ.outPerm o) : ℤ) : ℂ) := by + rw [hxx, one_mul] + _ = _ := by ring + _ = (-1 : ℂ) ^ κ.circuitCount := by + rw [hs, ← hout_card, hG] + +-- Four sign families — pattern, crossing, +-- representative and per-vertex sorting — are combined in one +-- identity, so all four definitions unfold together. +/-- **The grand parity identity**: the pattern, crossing, +representative and per-vertex sorting signs compose to the +circuit sign. -/ +theorem grand_parity (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) + (hnd : ∀ v : Fin (ds W).length, + (F.oddListAt o φ (blockVertex W v)).Nodup) : + ((-1 : ℂ) ^ patternOddInv W F) * + ((-1 : ℂ) ^ (Finset.univ.filter + (fun p : Fin (edgeCount W) × Fin (edgeCount W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ + p.2 ∈ edgeIndexSet W F)).card * + (-1 : ℂ) ^ inRepCount W F o) * + ∏ v : Fin (ds W).length, + ((sortSign (oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v)) : ℂ) * + (sortSign (F.oddListAt o φ + (blockVertex W v)) : ℂ)) = + (-1 : ℂ) ^ κ.circuitCount := by + have hsplit : (∏ v : Fin (ds W).length, + ((sortSign (oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v)) : ℂ) * + (sortSign (F.oddListAt o φ + (blockVertex W v)) : ℂ))) = + ∏ v : Fin (ds W).length, + (sortSign ((pairFlagList (F := F) o + (blockVertex W v)).map + (fun f => sortKey W f.val)) : ℂ) := + Finset.prod_congr rfl (fun v _ => + vertex_sign_collapse W F o ψ φ v (hnd v)) + rw [hsplit] + exact core_parity W F o + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EdgeSign.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EdgeSign.lean new file mode 100644 index 0000000000..784e86885f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EdgeSign.lean @@ -0,0 +1,132 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RepFlag +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddFlip + +/-! +# The edge-sign sector + +Flipping the odd colouring converts the diagonal cap pairing's +per-edge signs into the Definition 5 orientation signs, up to the +count of edges whose representative is incoming. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {k ℓ : ℕ} + +open Classical in +/-- The participating edges whose representative flag is +incoming. -/ +noncomputable def inRepCount (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) : ℕ := + (Finset.univ.filter (fun i : Fin (edgeCount W) => + (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i) ∈ + F.flags ∧ + o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = false)).card + +/-- Representative slots are their own edge representatives. -/ +theorem repFlag_symm_castAdd (W : ClosedFragment) + (i : Fin (edgeCount W)) : + repFlag W ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = + (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i) := by + refine repFlag_low W _ ?_ + rw [_root_.Equiv.apply_symm_apply] + exact i.isLt + +open Classical in +/-- **The edge-sign sector**: the flipped diagonal signs are the +orientation signs times the incoming-representative parity. -/ +theorem edge_sign_sector (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) (φ : F.OddColouring ℓ) : + (∏ i : Fin (edgeCount W), + (if h : (starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i) ∈ F.flags then + -((oddPartnerSign ℓ + ((EdgeSubset.OddColouring.flip F (outRepSet W F o) + (outRepSet_pairing_mem W F o) φ).val + ⟨(starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i), h⟩) : ℤ) : ℂ) + else 1)) = + (-1 : ℂ) ^ inRepCount W F o * + ∏ i : Fin (edgeCount W), + (if h : (starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i) ∈ F.flags then + ((oddPartnerSign ℓ (φ.val + ⟨(starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i), h⟩) : ℤ) : ℂ) + else 1) := by + have hterm : ∀ i : Fin (edgeCount W), + (if h : (starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i) ∈ F.flags then + -((oddPartnerSign ℓ + ((EdgeSubset.OddColouring.flip F (outRepSet W F o) + (outRepSet_pairing_mem W F o) φ).val + ⟨(starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i), h⟩) : ℤ) : ℂ) + else 1) = + (if ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i) ∈ F.flags ∧ + o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = false) + then (-1 : ℂ) else 1) * + (if h : (starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i) ∈ F.flags then + ((oddPartnerSign ℓ (φ.val + ⟨(starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i), h⟩) : ℤ) : ℂ) + else 1) := by + intro i + set g := (starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i) with hg + by_cases h : g ∈ F.flags + · rw [dite_eq_left h, dite_eq_left h] + by_cases hout : o.isOut g = true + · have hT : g ∈ outRepSet W F o := + (mem_outRepSet_iff W F o g h).mpr (by + rw [repFlag_symm_castAdd] + exact hout) + rw [EdgeSubset.OddColouring.flip_val_mem F _ _ φ + ⟨g, h⟩ hT, oddPartnerSign_oddPartner] + rw [ite_eq_right (by + rintro ⟨-, hfalse⟩ + rw [hout] at hfalse + exact Bool.noConfusion hfalse)] + push_cast + ring + · have hof : o.isOut g = false := by + cases hb : o.isOut g + · rfl + · exact absurd hb hout + have hT : g ∉ outRepSet W F o := fun hmem => by + have h2 := (mem_outRepSet_iff W F o g h).mp hmem + rw [repFlag_symm_castAdd, hof] at h2 + exact Bool.noConfusion h2 + rw [EdgeSubset.OddColouring.flip_val_not_mem F _ _ φ + ⟨g, h⟩ hT] + rw [ite_eq_left ⟨h, hof⟩] + ring + · rw [dite_eq_right h, dite_eq_right h, + ite_eq_right (fun hmem => h hmem.1), one_mul] + rw [Finset.prod_congr rfl (fun i _ => hterm i), + Finset.prod_mul_distrib] + congr 1 + rw [← Finset.prod_filter] + rw [Finset.prod_const] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvForm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvForm.lean new file mode 100644 index 0000000000..8a85966728 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvForm.lean @@ -0,0 +1,67 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapFun + +/-! +# The evaluation functional in standard coordinates + +Under a standard-model identification, the one-strand evaluation +functional composed with the structure map is the standard form: +the pointwise consequence of the model transport equation. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open Functor.LaxMonoidal Functor.OplaxMonoidal + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} + +/-- **The evaluation is the standard form** on transported even +pairs. -/ +theorem evForm + (e : SuperVect.Hom (stdSuperPair k ℓ) (P.ω.obj (SkeinObj.mk 1))) + (hform : + letI := P.braided + SuperVect.Hom.comp + (μ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1) ≫ + P.ω.map (ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) ≫ η P.ω) + (SuperVect.tensorHom e e) = stdForm k ℓ) + (x y : (stdSuperPair k ℓ).even) : + letI := P.braided + omegaFun f P (ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) + (((μ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1)) : + SuperVect.Hom _ _).evenMap + (evenPair (e.evenMap x) (e.evenMap y))) = + (stdForm k ℓ).evenMap (evenPair x y) := by + let := P.braided + have h := congrArg (fun z : SuperVect.Hom + (SuperVect.tensorObj (stdSuperPair k ℓ) (stdSuperPair k ℓ)) + SuperVect.tensorUnit => z.evenMap (evenPair x y)) hform + refine Eq.trans ?_ h + change omegaFun f P (ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) + (((μ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1)) : + SuperVect.Hom _ _).evenMap + (evenPair (e.evenMap x) (e.evenMap y))) = + ((μ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1) ≫ + P.ω.map (ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) ≫ η P.ω : + SuperVect.tensorObj (P.ω.obj (SkeinObj.mk 1)) + (P.ω.obj (SkeinObj.mk 1)) ⟶ SuperVect.tensorUnit) : + SuperVect.Hom _ _).evenMap + ((SuperVect.tensorHom e e).evenMap (evenPair x y)) + rw [show (SuperVect.tensorHom e e).evenMap (evenPair x y) = + evenPair (e.evenMap x) (e.evenMap y) from + tensorHom_evenPair e e x y] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvFormOdd.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvFormOdd.lean new file mode 100644 index 0000000000..0c1474257d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvFormOdd.lean @@ -0,0 +1,70 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisSplit +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddPair + +/-! +# The evaluation functional on odd pairs + +The odd counterpart of the standard-form identification: on +transported odd pairs the one-strand evaluation through the +structure map is the standard form's odd block — the symplectic +entries. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open Functor.LaxMonoidal Functor.OplaxMonoidal +open scoped TensorProduct + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} + +/-- **The evaluation is the standard form on transported odd +pairs.** -/ +theorem evFormOdd + (e : SuperVect.Hom (stdSuperPair k ℓ) (P.ω.obj (SkeinObj.mk 1))) + (hform : + letI := P.braided + SuperVect.Hom.comp + (μ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1) ≫ + P.ω.map (ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) ≫ η P.ω) + (SuperVect.tensorHom e e) = stdForm k ℓ) + (x y : (stdSuperPair k ℓ).odd) : + letI := P.braided + omegaFun f P (ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) + (((μ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1)) : + SuperVect.Hom _ _).evenMap + (oddPair (e.oddMap x) (e.oddMap y))) = + (stdForm k ℓ).evenMap (oddPair x y) := by + let := P.braided + have h := congrArg (fun z : SuperVect.Hom + (SuperVect.tensorObj (stdSuperPair k ℓ) (stdSuperPair k ℓ)) + SuperVect.tensorUnit => z.evenMap (oddPair x y)) hform + refine Eq.trans ?_ h + change omegaFun f P (ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) + (((μ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1)) : + SuperVect.Hom _ _).evenMap + (oddPair (e.oddMap x) (e.oddMap y))) = + ((μ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1) ≫ + P.ω.map (ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) ≫ η P.ω : + SuperVect.tensorObj (P.ω.obj (SkeinObj.mk 1)) + (P.ω.obj (SkeinObj.mk 1)) ⟶ SuperVect.tensorUnit) : + SuperVect.Hom _ _).evenMap + ((SuperVect.tensorHom e e).evenMap (oddPair x y)) + rw [show (SuperVect.tensorHom e e).evenMap (oddPair x y) = + oddPair (e.oddMap x) (e.oddMap y) from + tensorHom_oddPair e e x y] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvLeaf.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvLeaf.lean new file mode 100644 index 0000000000..a10eff0ce8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvLeaf.lean @@ -0,0 +1,223 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OneBasis + +/-! +# The evaluation leaf + +The base of the cap recursion: the strand evaluation on a +transported two-position basis vector is the colour form entry of +the two colours. Both mixed-parity colourings are excluded by +evenness; the pure branches route through the one-position basis +presentations and the standard-form identification. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open Functor.LaxMonoidal Functor.OplaxMonoidal +open scoped TensorProduct + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} + +/-- The standard form on even pairs is the even form. -/ +theorem stdForm_evenPair (x y : (stdSuperPair k ℓ).even) : + (stdForm k ℓ).evenMap (evenPair x y) = stdFormEven k x y := by + change LinearMap.coprod + (TensorProduct.lift (stdFormEvenBilin k)) + (TensorProduct.lift (stdFormOddBilin ℓ)) + (x ⊗ₜ[ℂ] y, 0) = _ + rw [LinearMap.coprod_apply, map_zero, add_zero] + exact TensorProduct.lift.tmul x y + +/-- The standard form on odd pairs is the odd form. -/ +theorem stdForm_oddPair (x y : (stdSuperPair k ℓ).odd) : + (stdForm k ℓ).evenMap (oddPair x y) = stdFormOdd ℓ x y := by + change LinearMap.coprod + (TensorProduct.lift (stdFormEvenBilin k)) + (TensorProduct.lift (stdFormOddBilin ℓ)) + (0, x ⊗ₜ[ℂ] y) = _ + rw [LinearMap.coprod_apply, map_zero, zero_add] + exact TensorProduct.lift.tmul x y + +-- The evaluation is computed on a two-position +-- basis vector through the transport, unfolding the tensorator and +-- the standard form. +/-- **The evaluation leaf**: the strand evaluation on a +transported two-position basis vector is the colour form entry of +the two colours. -/ +theorem omegaFun_ev_basis + (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) + (hform : + letI := P.braided + SuperVect.Hom.comp + (μ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1) ≫ + P.ω.map (ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) ≫ η P.ω) + (SuperVect.tensorHom e e) = stdForm k ℓ) + (c : MixedColouring k ℓ 2) (hc : c.IsEven) : + letI := P.braided + omegaFun f P (evClass f) + (((stdToOmega f P e 2) : SuperVect.Hom _ _).evenMap + (evenBasisVec (⟨c, hc⟩ : + {c : MixedColouring k ℓ 2 // c.IsEven}))) = + colourFormEntry k ℓ (c 0) (c 1) := by + let := P.braided + have hsplit := evenBasisVec_split (a := 1) (b := 1) c hc + -- ═══════ FOUR PARITY PATTERNS AT THE TWO POSITIONS ═══════ + -- Evenness of the colouring excludes the two mixed ones. + rcases h0 : c 0 with i | a <;> rcases h1 : c 1 with j | b + · -- Both even colours. + have hfh : MixedColouring.firstHalf (a := 1) (b := 1) c = + oneColourE k ℓ i := + oneColour_ext (show MixedColouring.firstHalf (a := 1) (b := 1) c 0 = + oneColourE k ℓ i 0 from h0) + have hsh : MixedColouring.secondHalf (a := 1) (b := 1) c = + oneColourE k ℓ j := + oneColour_ext (show MixedColouring.secondHalf (a := 1) (b := 1) c 0 = + oneColourE k ℓ j 0 from h1) + have hfe : MixedColouring.IsEven + (MixedColouring.firstHalf (a := 1) (b := 1) c) := by + rw [hfh]; exact oneColourE_isEven i + rw [hsplit, dite_eq_left hfe] + rw [show (⟨MixedColouring.firstHalf (a := 1) (b := 1) c, hfe⟩ : + {c' : MixedColouring k ℓ 1 // c'.IsEven}) = + ⟨oneColourE k ℓ i, oneColourE_isEven i⟩ from + Subtype.ext hfh] + rw [show (⟨MixedColouring.secondHalf (a := 1) (b := 1) c, + by rw [hsh]; exact oneColourE_isEven j⟩ : + {c' : MixedColouring k ℓ 1 // c'.IsEven}) = + ⟨oneColourE k ℓ j, oneColourE_isEven j⟩ from + Subtype.ext hsh] + rw [evenBasisVec_one, evenBasisVec_one] + refine Eq.trans ?_ (colourFormEntry_even k ℓ i j).symm + refine Eq.trans ?_ (stdForm_evenPair (ℓ := ℓ) (stdE k i) (stdE k j)) + refine Eq.trans ?_ + (evForm f P e hform (stdE k i) (stdE k j)) + have hmerge := congrArg (fun z : + (superPow (stdSuperPair k ℓ) 1 ⊗ + superPow (stdSuperPair k ℓ) 1 ⟶ + P.ω.obj (SkeinObj.mk (1 + 1))) => + (z : SuperVect.Hom _ _).evenMap + (evenPair + ((evenPair (1 : ℂ) (stdE k i) : + (superPow (stdSuperPair k ℓ) 1).even)) + ((evenPair (1 : ℂ) (stdE k j) : + (superPow (stdSuperPair k ℓ) 1).even)))) + (stdToOmega_merge f P e 1 1) + refine Eq.trans (congrArg (omegaFun f P (evClass f)) + hmerge.symm) ?_ + change omegaFun f P (evClass f) + (((μ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1)) : + SuperVect.Hom _ _).evenMap + (((stdToOmega f P e 1 ⊗ₘ stdToOmega f P e 1) : + SuperVect.Hom _ _).evenMap + (evenPair (evenPair (1 : ℂ) (stdE k i)) + (evenPair (1 : ℂ) (stdE k j))))) = _ + rw [show ((stdToOmega f P e 1 ⊗ₘ stdToOmega f P e 1) : + SuperVect.Hom _ _).evenMap + (evenPair (evenPair (1 : ℂ) (stdE k i)) + (evenPair (1 : ℂ) (stdE k j))) = + evenPair + ((stdToOmega f P e 1 : SuperVect.Hom _ _).evenMap + (evenPair (1 : ℂ) (stdE k i))) + ((stdToOmega f P e 1 : SuperVect.Hom _ _).evenMap + (evenPair (1 : ℂ) (stdE k j))) from + tensorHom_evenPair _ _ _ _] + rw [stdToOmega_one_even f P e (stdE k i), + stdToOmega_one_even f P e (stdE k j)] + rfl + · -- Mixed parity: excluded by evenness. + exfalso + refine ((c.isEven_succ_right b + (show c (Fin.last 1) = Sum.inr b from h1)).mp hc) ?_ + rw [show MixedColouring.tail c = oneColourE k ℓ i from + oneColour_ext (show MixedColouring.tail c 0 = + oneColourE k ℓ i 0 from h0)] + exact oneColourE_isEven i + · -- Mixed parity: excluded by evenness. + exfalso + refine oneColourO_not_isEven (k := k) a ?_ + rw [show oneColourO k ℓ a = MixedColouring.tail c from + (oneColour_ext (show MixedColouring.tail c 0 = + oneColourO k ℓ a 0 from h0)).symm] + exact (c.isEven_succ_left j + (show c (Fin.last 1) = Sum.inl j from h1)).mp hc + · -- Both odd colours. + have hfh : MixedColouring.firstHalf (a := 1) (b := 1) c = + oneColourO k ℓ a := + oneColour_ext (show MixedColouring.firstHalf (a := 1) (b := 1) c 0 = + oneColourO k ℓ a 0 from h0) + have hsh : MixedColouring.secondHalf (a := 1) (b := 1) c = + oneColourO k ℓ b := + oneColour_ext (show MixedColouring.secondHalf (a := 1) (b := 1) c 0 = + oneColourO k ℓ b 0 from h1) + have hfo : ¬ MixedColouring.IsEven + (MixedColouring.firstHalf (a := 1) (b := 1) c) := by + rw [hfh]; exact oneColourO_not_isEven a + rw [hsplit, dite_eq_right hfo] + rw [show (⟨MixedColouring.firstHalf (a := 1) (b := 1) c, hfo⟩ : + {c' : MixedColouring k ℓ 1 // ¬ c'.IsEven}) = + ⟨oneColourO k ℓ a, oneColourO_not_isEven a⟩ from + Subtype.ext hfh] + rw [show (⟨MixedColouring.secondHalf (a := 1) (b := 1) c, + by rw [hsh]; exact oneColourO_not_isEven b⟩ : + {c' : MixedColouring k ℓ 1 // ¬ c'.IsEven}) = + ⟨oneColourO k ℓ b, oneColourO_not_isEven b⟩ from + Subtype.ext hsh] + rw [oddBasisVec_one, oddBasisVec_one] + refine Eq.trans ?_ (colourFormEntry_odd k ℓ a b).symm + refine Eq.trans ?_ (stdForm_oddPair (k := k) (stdF ℓ a) (stdF ℓ b)) + refine Eq.trans ?_ + (evFormOdd f P e hform (stdF ℓ a) (stdF ℓ b)) + have hmerge := congrArg (fun z : + (superPow (stdSuperPair k ℓ) 1 ⊗ + superPow (stdSuperPair k ℓ) 1 ⟶ + P.ω.obj (SkeinObj.mk (1 + 1))) => + (z : SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) 1).even), + oddUnitPad (stdF ℓ a) ⊗ₜ[ℂ] oddUnitPad (stdF ℓ b)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) 1) + (superPow (stdSuperPair k ℓ) 1)).even)) + (stdToOmega_merge f P e 1 1) + refine Eq.trans (congrArg (omegaFun f P (evClass f)) + hmerge.symm) ?_ + change omegaFun f P (evClass f) + (((μ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1)) : + SuperVect.Hom _ _).evenMap + (((stdToOmega f P e 1 ⊗ₘ stdToOmega f P e 1) : + SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) 1).even), + oddUnitPad (stdF ℓ a) ⊗ₜ[ℂ] + oddUnitPad (stdF ℓ b)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) 1) + (superPow (stdSuperPair k ℓ) 1)).even))) = _ + rw [show ((stdToOmega f P e 1 ⊗ₘ stdToOmega f P e 1) : + SuperVect.Hom _ _).evenMap + (((0 : (superPow (stdSuperPair k ℓ) 1).even ⊗[ℂ] + (superPow (stdSuperPair k ℓ) 1).even), + oddUnitPad (stdF ℓ a) ⊗ₜ[ℂ] oddUnitPad (stdF ℓ b)) : + (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) 1) + (superPow (stdSuperPair k ℓ) 1)).even) = + oddPair + ((stdToOmega f P e 1 : SuperVect.Hom _ _).oddMap + (oddUnitPad (stdF ℓ a))) + ((stdToOmega f P e 1 : SuperVect.Hom _ _).oddMap + (oddUnitPad (stdF ℓ b))) from + tensorHom_oddPair _ _ _ _] + rw [stdToOmega_one_odd f P e (stdF ℓ a), + stdToOmega_one_odd f P e (stdF ℓ b)] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FibreParam.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FibreParam.lean new file mode 100644 index 0000000000..8727159ec3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FibreParam.lean @@ -0,0 +1,613 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.Reindex + +/-! +# The fibre parametrization + +The colouring of an edge subset with colouring data: participating +flags carry the odd edge colour on the representative slot and its +partner on the partner slot; the rest carry the even colour. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Finset + + +variable {k ℓ : ℕ} + +/-- The colouring of an edge subset with colouring data. -/ +noncomputable def colouringOf (W : ClosedFragment) + (F : EdgeSubset W) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) : + MixedColouring k ℓ (edgeCount W + edgeCount W) := + fun slot => + if h : (starFlagEnum W).symm slot ∈ F.flags then + Sum.inr (if slot.val < edgeCount W then + φ.val ⟨(starFlagEnum W).symm slot, h⟩ + else + oddPartner ℓ (φ.val ⟨(starFlagEnum W).symm slot, h⟩)) + else + Sum.inl (ψ.val ⟨(starFlagEnum W).symm slot, h⟩) + +/-- The pattern of the data colouring is the subset. -/ +theorem colourFlags_colouringOf (W : ClosedFragment) + (F : EdgeSubset W) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) : + colourFlags W (colouringOf W F ψ φ) = F.flags := by + ext g + rw [colourFlags, Finset.mem_image] + constructor + · rintro ⟨s, hs, rfl⟩ + rw [MixedColouring.oddSet, Finset.mem_filter] at hs + obtain ⟨-, hodd⟩ := hs + by_contra hnot + rw [colouringOf] at hodd + rw [dite_eq_right hnot] at hodd + exact Bool.noConfusion hodd + · intro hg + refine ⟨starFlagEnum W g, ?_, ?_⟩ + · rw [MixedColouring.oddSet, Finset.mem_filter] + refine ⟨Finset.mem_univ _, ?_⟩ + rw [colouringOf] + rw [dite_eq_left (show (starFlagEnum W).symm + (starFlagEnum W g) ∈ F.flags from by + rw [Equiv.symm_apply_apply]; exact hg)] + rfl + · exact _root_.Equiv.symm_apply_apply _ _ + +/-- Closed subsets have evenly many flags. -/ +theorem EdgeSubset.card_even {α : Type} {W : Fragment α} + (F : EdgeSubset W) : Even F.flags.card := by + classical + suffices h : ∀ (n : ℕ) (s : Finset W.Flag), s.card = n → + (∀ g ∈ s, W.pairing g ∈ s) → Even s.card from + h F.flags.card F.flags rfl F.pairing_mem + intro n + induction n using Nat.strong_induction_on with + | _ n ih => + intro s hcard hclosed + rcases Finset.eq_empty_or_nonempty s with rfl | ⟨a, ha⟩ + · simp + · have hpa : W.pairing a ∈ s := hclosed a ha + have hne : W.pairing a ≠ a := W.pairing_ne a + have hmem2 : W.pairing a ∈ s.erase a := + Finset.mem_erase.mpr ⟨hne, hpa⟩ + set s' := (s.erase a).erase (W.pairing a) with hs' + have hcard' : s'.card = n - 2 := by + rw [hs', Finset.card_erase_of_mem hmem2, + Finset.card_erase_of_mem ha, hcard] + omega + have hclosed' : ∀ g ∈ s', W.pairing g ∈ s' := by + intro g hg + rw [hs', Finset.mem_erase, Finset.mem_erase] at hg ⊢ + obtain ⟨hgp, hga, hgs⟩ := hg + refine ⟨?_, ?_, hclosed g hgs⟩ + · exact fun h => hga (by + rw [← W.pairing_invol g, h, W.pairing_invol]) + · exact fun h => hgp (by + rw [← W.pairing_invol g, h]) + have h2n : 2 ≤ n := by + rw [← hcard] + exact Finset.one_lt_card.mpr + ⟨a, ha, W.pairing a, hpa, hne.symm⟩ + have hn2 : n - 2 < n := by omega + have heven' := ih (n - 2) hn2 s' hcard' hclosed' + rw [hcard'] at heven' + rw [hcard, show n = (n - 2) + 2 from by omega] + exact heven'.add even_two + +/-- The data colouring is even. -/ +theorem colouringOf_isEven (W : ClosedFragment) + (F : EdgeSubset W) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) : + (colouringOf W F ψ φ).IsEven := by + rw [MixedColouring.IsEven] + have hcardeq : (MixedColouring.oddSet + (colouringOf W F ψ φ)).card = + (colourFlags W (colouringOf W F ψ φ)).card := by + rw [colourFlags] + exact (Finset.card_image_of_injective _ + (Equiv.injective _)).symm + rw [hcardeq, colourFlags_colouringOf] + exact F.card_even + +/-- The diagonal partner of a colour: even colours repeat, odd +colours pair symplectically. -/ +def diagPartner (x : Fin k ⊕ Fin (2 * ℓ)) : + Fin k ⊕ Fin (2 * ℓ) := + match x with + | Sum.inl a => Sum.inl a + | Sum.inr u => Sum.inr (oddPartner ℓ u) + +/-- Diagonal colourings: the partner slot carries the diagonal +partner of the representative slot. -/ +def Diagonal (W : ClosedFragment) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) : + Prop := + ∀ i : Fin (edgeCount W), + c (Fin.natAdd (edgeCount W) i) = + diagPartner (c (Fin.castAdd (edgeCount W) i)) + +/-- The data colouring is diagonal. -/ +theorem colouringOf_diagonal (W : ClosedFragment) + (F : EdgeSubset W) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) : + Diagonal W (colouringOf W F ψ φ) := by + intro i + rw [colouringOf, colouringOf] + have hpair : (starFlagEnum W).symm + (Fin.natAdd (edgeCount W) i) = + W.pairing ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) := + (pairing_starFlagEnum_symm W i).symm + by_cases h : (starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i) ∈ F.flags + · have h' : (starFlagEnum W).symm + (Fin.natAdd (edgeCount W) i) ∈ F.flags := by + rw [hpair] + exact F.pairing_mem _ h + rw [dite_eq_left h, dite_eq_left h'] + rw [ite_eq_left (show (Fin.castAdd (edgeCount W) i).val < + edgeCount W from i.isLt)] + rw [ite_eq_right (show ¬ ((Fin.natAdd (edgeCount W) i).val < + edgeCount W) from by + change ¬ (edgeCount W + i.val < edgeCount W); omega)] + change Sum.inr (oddPartner ℓ (φ.val ⟨_, h'⟩)) = + diagPartner (Sum.inr (φ.val ⟨_, h⟩)) + rw [show φ.val ⟨(starFlagEnum W).symm + (Fin.natAdd (edgeCount W) i), h'⟩ = + φ.val ⟨(starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i), h⟩ from by + rw [show (⟨(starFlagEnum W).symm + (Fin.natAdd (edgeCount W) i), h'⟩ : + {f : W.Flag // f ∈ F.flags}) = + ⟨W.pairing ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)), + F.pairing_mem _ h⟩ from Subtype.ext hpair] + exact φ.property ⟨_, h⟩] + rfl + · have h' : (starFlagEnum W).symm + (Fin.natAdd (edgeCount W) i) ∉ F.flags := by + rw [hpair] + intro hmem + refine h ?_ + have := F.pairing_mem _ hmem + rw [W.pairing_invol] at this + exact this + rw [dite_eq_right h, dite_eq_right h'] + change Sum.inl (ψ.val ⟨_, h'⟩) = + diagPartner (Sum.inl (ψ.val ⟨_, h⟩)) + rw [show ψ.val ⟨(starFlagEnum W).symm + (Fin.natAdd (edgeCount W) i), h'⟩ = + ψ.val ⟨(starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i), h⟩ from by + rw [show (⟨(starFlagEnum W).symm + (Fin.natAdd (edgeCount W) i), h'⟩ : + {f : W.Flag // f ∉ F.flags}) = + ⟨W.pairing ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)), + F.pairing_not_mem h⟩ from Subtype.ext hpair] + exact ψ.property ⟨_, h⟩] + rfl + +/-- Pattern membership is slot oddness. -/ +theorem mem_colourFlags_iff (W : ClosedFragment) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) + (g : W.Flag) : + g ∈ colourFlags W c ↔ + (c (starFlagEnum W g)).isRight = true := by + rw [colourFlags, Finset.mem_image] + constructor + · rintro ⟨s, hs, rfl⟩ + rw [MixedColouring.oddSet, Finset.mem_filter] at hs + rw [show starFlagEnum W ((starFlagEnum W).symm s) = s + from _root_.Equiv.apply_symm_apply _ _] + exact hs.2 + · intro h + exact ⟨starFlagEnum W g, by + rw [MixedColouring.oddSet, Finset.mem_filter] + exact ⟨Finset.mem_univ _, h⟩, + _root_.Equiv.symm_apply_apply _ _⟩ + +/-- The even data of a pattern colouring. -/ +noncomputable def evenDataOf (W : ClosedFragment) + (F : EdgeSubset W) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) + (hfibre : colourFlags W c = F.flags) : + {f : W.Flag // f ∉ F.flags} → Fin k := fun p => + (c (starFlagEnum W p.val)).getLeft (by + obtain ⟨g, hg⟩ := p + have hp : ¬ (g ∈ colourFlags W c) := by + rw [hfibre]; exact hg + rw [mem_colourFlags_iff] at hp + rcases hx : c (starFlagEnum W g) with a | u + · rfl + · exact absurd (by rw [hx]; rfl) hp) + +/-- Slot oddness of a participating flag. -/ +theorem isRight_of_mem (W : ClosedFragment) + (F : EdgeSubset W) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) + (hfibre : colourFlags W c = F.flags) + (g : W.Flag) (hg : g ∈ F.flags) : + (c (starFlagEnum W g)).isRight = true := by + have hp : g ∈ colourFlags W c := by + rw [hfibre]; exact hg + rw [mem_colourFlags_iff] at hp + exact hp + +/-- The odd data of a pattern colouring: the value at the +representative slot of the flag's edge. -/ +noncomputable def oddDataOf (W : ClosedFragment) + (F : EdgeSubset W) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) + (hfibre : colourFlags W c = F.flags) : + {f : W.Flag // f ∈ F.flags} → Fin (2 * ℓ) := fun p => + if (starFlagEnum W p.val).val < edgeCount W then + (c (starFlagEnum W p.val)).getRight + (isRight_of_mem W F c hfibre p.val p.prop) + else + (c (starFlagEnum W (W.pairing p.val))).getRight + (isRight_of_mem W F c hfibre _ + (F.pairing_mem _ p.prop)) + +private theorem getLeft_congr {α β : Type*} {x y : α ⊕ β} + (h : x = y) (hx : x.isLeft = true) (hy : y.isLeft = true) : + x.getLeft hx = y.getLeft hy := by subst h; rfl + +private theorem getRight_congr {α β : Type*} {x y : α ⊕ β} + (h : x = y) (hx : x.isRight = true) + (hy : y.isRight = true) : + x.getRight hx = y.getRight hy := by subst h; rfl + +/-- The pairing flips low slots high. -/ +theorem starFlagEnum_pairing_low (W : ClosedFragment) + (g : W.Flag) (h : (starFlagEnum W g).val < edgeCount W) : + starFlagEnum W (W.pairing g) = + Fin.natAdd (edgeCount W) + ⟨(starFlagEnum W g).val, h⟩ := by + have hg : g = (starFlagEnum W).symm + (Fin.castAdd (edgeCount W) + ⟨(starFlagEnum W g).val, h⟩) := by + rw [show Fin.castAdd (edgeCount W) + ⟨(starFlagEnum W g).val, h⟩ = + starFlagEnum W g from Fin.ext rfl] + exact (_root_.Equiv.symm_apply_apply _ _).symm + refine Eq.trans (congrArg + (fun x => starFlagEnum W (W.pairing x)) hg) ?_ + refine Eq.trans (congrArg (starFlagEnum W) + (pairing_starFlagEnum_symm W + ⟨(starFlagEnum W g).val, h⟩)) ?_ + exact _root_.Equiv.apply_symm_apply _ _ + +/-- The pairing flips high slots low. -/ +theorem starFlagEnum_pairing_high (W : ClosedFragment) + (g : W.Flag) + (h : ¬ (starFlagEnum W g).val < edgeCount W) : + starFlagEnum W (W.pairing g) = + Fin.castAdd (edgeCount W) + ⟨(starFlagEnum W g).val - edgeCount W, by + have := (starFlagEnum W g).isLt; omega⟩ := by + set j : Fin (edgeCount W) := + ⟨(starFlagEnum W g).val - edgeCount W, by + have := (starFlagEnum W g).isLt; omega⟩ with hj + have hg : g = (starFlagEnum W).symm + (Fin.natAdd (edgeCount W) j) := by + rw [show Fin.natAdd (edgeCount W) j = + starFlagEnum W g from Fin.ext (by + change edgeCount W + ((starFlagEnum W g).val - + edgeCount W) = (starFlagEnum W g).val + omega)] + exact (_root_.Equiv.symm_apply_apply _ _).symm + refine Eq.trans (congrArg + (fun x => starFlagEnum W (W.pairing x)) hg) ?_ + refine Eq.trans (congrArg (starFlagEnum W) + (show W.pairing ((starFlagEnum W).symm + (Fin.natAdd (edgeCount W) j)) = + (starFlagEnum W).symm + (Fin.castAdd (edgeCount W) j) from by + rw [← pairing_starFlagEnum_symm W j, + W.pairing_invol])) ?_ + exact _root_.Equiv.apply_symm_apply _ _ + +/-- The odd data is pairing-constant. -/ +theorem oddDataOf_constancy (W : ClosedFragment) + (F : EdgeSubset W) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) + (hfibre : colourFlags W c = F.flags) + (p : {f : W.Flag // f ∈ F.flags}) : + oddDataOf W F c hfibre + ⟨W.pairing p.val, F.pairing_mem _ p.prop⟩ = + oddDataOf W F c hfibre p := by + obtain ⟨g, hg⟩ := p + rw [oddDataOf, oddDataOf] + by_cases hlow : (starFlagEnum W g).val < edgeCount W + · rw [ite_eq_left hlow] + rw [ite_eq_right (show ¬ ((starFlagEnum W + (W.pairing g)).val < edgeCount W) from by + rw [starFlagEnum_pairing_low W g hlow] + change ¬ (edgeCount W + (starFlagEnum W g).val < + edgeCount W) + omega)] + exact getRight_congr (congrArg c (congrArg _ + (W.pairing_invol g))) _ _ + · rw [ite_eq_right hlow] + rw [ite_eq_left (show (starFlagEnum W + (W.pairing g)).val < edgeCount W from by + rw [starFlagEnum_pairing_high W g hlow] + change (starFlagEnum W g).val - edgeCount W < + edgeCount W + have := (starFlagEnum W g).isLt; omega)] + +/-- The even data is pairing-constant on diagonal +colourings. -/ +theorem evenDataOf_constancy (W : ClosedFragment) + (F : EdgeSubset W) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) + (hfibre : colourFlags W c = F.flags) + (hdiag : Diagonal W c) + (p : {f : W.Flag // f ∉ F.flags}) : + evenDataOf W F c hfibre + ⟨W.pairing p.val, F.pairing_not_mem p.prop⟩ = + evenDataOf W F c hfibre p := by + obtain ⟨g, hg⟩ := p + rw [evenDataOf, evenDataOf] + by_cases hlow : (starFlagEnum W g).val < edgeCount W + · have hpart := hdiag ⟨(starFlagEnum W g).val, hlow⟩ + rw [show Fin.castAdd (edgeCount W) + ⟨(starFlagEnum W g).val, hlow⟩ = + starFlagEnum W g from Fin.ext rfl] at hpart + rw [show Fin.natAdd (edgeCount W) + ⟨(starFlagEnum W g).val, hlow⟩ = + starFlagEnum W (W.pairing g) from + (starFlagEnum_pairing_low W g hlow).symm] at hpart + refine getLeft_congr ?_ _ _ + rw [hpart] + rcases hx : c (starFlagEnum W g) with a | u + · rfl + · exfalso + have hp : ¬ (g ∈ colourFlags W c) := by + rw [hfibre]; exact hg + rw [mem_colourFlags_iff, hx] at hp + exact hp rfl + · have hlow' : (starFlagEnum W + (W.pairing g)).val < edgeCount W := by + rw [starFlagEnum_pairing_high W g hlow] + change (starFlagEnum W g).val - edgeCount W < + edgeCount W + have := (starFlagEnum W g).isLt; omega + have hpart := hdiag ⟨(starFlagEnum W + (W.pairing g)).val, hlow'⟩ + rw [show Fin.castAdd (edgeCount W) + ⟨(starFlagEnum W (W.pairing g)).val, hlow'⟩ = + starFlagEnum W (W.pairing g) from Fin.ext rfl] + at hpart + rw [show Fin.natAdd (edgeCount W) + ⟨(starFlagEnum W (W.pairing g)).val, hlow'⟩ = + starFlagEnum W g from by + rw [show starFlagEnum W g = starFlagEnum W + (W.pairing (W.pairing g)) from by + rw [W.pairing_invol]] + exact (starFlagEnum_pairing_low W (W.pairing g) + hlow').symm] at hpart + refine getLeft_congr ?_ _ _ + rw [hpart] + rcases hx : c (starFlagEnum W (W.pairing g)) with a | u + · rfl + · exfalso + have hp : ¬ (W.pairing g ∈ colourFlags W c) := by + rw [hfibre]; exact F.pairing_not_mem hg + rw [mem_colourFlags_iff, hx] at hp + exact hp rfl + +/-- The even colouring of a diagonal pattern colouring. -/ +noncomputable def evenColouringOf (W : ClosedFragment) + (F : EdgeSubset W) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) + (hfibre : colourFlags W c = F.flags) + (hdiag : Diagonal W c) : F.EvenColouring k := + ⟨evenDataOf W F c hfibre, + evenDataOf_constancy W F c hfibre hdiag⟩ + +/-- The odd colouring of a pattern colouring. -/ +noncomputable def oddColouringOf (W : ClosedFragment) + (F : EdgeSubset W) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) + (hfibre : colourFlags W c = F.flags) : + F.OddColouring ℓ := + ⟨oddDataOf W F c hfibre, + oddDataOf_constancy W F c hfibre⟩ + +-- Reconstruction is checked slot by slot, each slot +-- unfolding the star enumeration and the membership dichotomy. +/-- **Reconstruction**: a diagonal pattern colouring is the data +colouring of its extracted data. -/ +theorem colouringOf_reconstruct (W : ClosedFragment) + (F : EdgeSubset W) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) + (hfibre : colourFlags W c = F.flags) + (hdiag : Diagonal W c) : + colouringOf W F (evenColouringOf W F c hfibre hdiag) + (oddColouringOf W F c hfibre) = c := by + funext slot + have henum : starFlagEnum W ((starFlagEnum W).symm slot) = + slot := _root_.Equiv.apply_symm_apply _ _ + rw [colouringOf] + by_cases h : (starFlagEnum W).symm slot ∈ F.flags + · rw [dite_eq_left h] + have hodd : (c slot).isRight = true := by + have hm := isRight_of_mem W F c hfibre _ h + rw [henum] at hm + exact hm + by_cases hrep : slot.val < edgeCount W + · rw [ite_eq_left hrep] + change Sum.inr (oddDataOf W F c hfibre + ⟨(starFlagEnum W).symm slot, h⟩) = c slot + rw [oddDataOf] + rw [ite_eq_left (show (starFlagEnum W + ((starFlagEnum W).symm slot)).val < + edgeCount W from by rw [henum]; exact hrep)] + exact Eq.trans (congrArg Sum.inr + (getRight_congr (congrArg c henum) _ hodd)) + (Sum.inr_getRight _ hodd) + · rw [ite_eq_right hrep] + change Sum.inr (oddPartner ℓ (oddDataOf W F c hfibre + ⟨(starFlagEnum W).symm slot, h⟩)) = c slot + rw [oddDataOf] + rw [ite_eq_right (show ¬ ((starFlagEnum W + ((starFlagEnum W).symm slot)).val < + edgeCount W) from by rw [henum]; exact hrep)] + set i₀ : Fin (edgeCount W) := + ⟨slot.val - edgeCount W, by + have := slot.isLt; omega⟩ with hi₀ + have hpair_enum : starFlagEnum W + (W.pairing ((starFlagEnum W).symm slot)) = + Fin.castAdd (edgeCount W) i₀ := by + refine Eq.trans (starFlagEnum_pairing_high W _ + (by rw [henum]; exact hrep)) ?_ + refine congrArg (Fin.castAdd (edgeCount W)) ?_ + refine Fin.ext ?_ + change (starFlagEnum W + ((starFlagEnum W).symm slot)).val - + edgeCount W = slot.val - edgeCount W + rw [henum] + have hnat : Fin.natAdd (edgeCount W) i₀ = slot := + Fin.ext (by + change edgeCount W + (slot.val - edgeCount W) = + slot.val + omega) + have hd := hdiag i₀ + rw [hnat] at hd + have hrepmem : W.pairing + ((starFlagEnum W).symm slot) ∈ F.flags := + F.pairing_mem _ h + have hrepodd : (c (Fin.castAdd (edgeCount W) + i₀)).isRight = true := by + have hm := isRight_of_mem W F c hfibre _ hrepmem + rw [hpair_enum] at hm + exact hm + rw [show ((c (starFlagEnum W (W.pairing + ((starFlagEnum W).symm slot)))).getRight + (isRight_of_mem W F c hfibre _ + (F.pairing_mem _ h))) = + ((c (Fin.castAdd (edgeCount W) i₀)).getRight + hrepodd) from + getRight_congr (congrArg c hpair_enum) _ _] + obtain ⟨u, hu⟩ : ∃ u, c (Fin.castAdd + (edgeCount W) i₀) = Sum.inr u := + ⟨(c _).getRight hrepodd, + (Sum.inr_getRight _ hrepodd).symm⟩ + rw [show (c (Fin.castAdd (edgeCount W) + i₀)).getRight hrepodd = u from + getRight_congr hu hrepodd rfl] + rw [hd, hu] + rfl + · rw [dite_eq_right h] + have hnotodd : ¬ ((c slot).isRight = true) := by + have hm : ¬ ((starFlagEnum W).symm slot ∈ + colourFlags W c) := by + rw [hfibre]; exact h + rw [mem_colourFlags_iff, henum] at hm + exact hm + have hleft : (c slot).isLeft = true := by + rcases hx : c slot with a | u + · rfl + · exact absurd (by rw [hx]; rfl) hnotodd + change Sum.inl (evenDataOf W F c hfibre + ⟨(starFlagEnum W).symm slot, h⟩) = c slot + exact Eq.trans (congrArg Sum.inl + (getLeft_congr (congrArg c henum) _ hleft)) + (Sum.inl_getLeft _ hleft) + +-- As for reconstruction: the round trip is checked flag by flag. +/-- **Round trip, odd data**: extraction inverts construction. -/ +theorem oddColouringOf_colouringOf (W : ClosedFragment) + (F : EdgeSubset W) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) : + oddColouringOf W F (colouringOf W F ψ φ) + (colourFlags_colouringOf W F ψ φ) = φ := by + refine Subtype.ext (funext (fun p => ?_)) + obtain ⟨g, hg⟩ := p + have hgoal : oddDataOf W F (colouringOf W F ψ φ) + (colourFlags_colouringOf W F ψ φ) ⟨g, hg⟩ = + φ.val ⟨g, hg⟩ := ?_ + · exact hgoal + rw [oddDataOf] + by_cases hlow : (starFlagEnum W g).val < edgeCount W + · rw [ite_eq_left hlow] + have hval : colouringOf W F ψ φ (starFlagEnum W g) = + Sum.inr (φ.val ⟨g, hg⟩) := by + rw [colouringOf] + rw [dite_eq_left (show (starFlagEnum W).symm + (starFlagEnum W g) ∈ F.flags from by + rw [_root_.Equiv.symm_apply_apply]; exact hg)] + rw [ite_eq_left hlow] + refine congrArg Sum.inr ?_ + refine congrArg φ.val (Subtype.ext ?_) + exact _root_.Equiv.symm_apply_apply _ _ + exact Eq.trans (getRight_congr hval _ rfl) rfl + · rw [ite_eq_right hlow] + have hglow : (starFlagEnum W + (W.pairing g)).val < edgeCount W := by + rw [starFlagEnum_pairing_high W g hlow] + change (starFlagEnum W g).val - edgeCount W < + edgeCount W + have := (starFlagEnum W g).isLt; omega + have hval : colouringOf W F ψ φ + (starFlagEnum W (W.pairing g)) = + Sum.inr (φ.val ⟨g, hg⟩) := by + rw [colouringOf] + rw [dite_eq_left (show (starFlagEnum W).symm + (starFlagEnum W (W.pairing g)) ∈ F.flags from by + rw [_root_.Equiv.symm_apply_apply] + exact F.pairing_mem _ hg)] + rw [ite_eq_left hglow] + refine congrArg Sum.inr ?_ + refine Eq.trans (congrArg φ.val + (show (⟨(starFlagEnum W).symm (starFlagEnum W + (W.pairing g)), by + rw [_root_.Equiv.symm_apply_apply] + exact F.pairing_mem _ hg⟩ : + {f : W.Flag // f ∈ F.flags}) = + ⟨W.pairing g, F.pairing_mem _ hg⟩ from + Subtype.ext + (_root_.Equiv.symm_apply_apply _ _))) ?_ + exact φ.property ⟨g, hg⟩ + exact Eq.trans (getRight_congr hval _ rfl) rfl + +/-- **Round trip, even data.** -/ +theorem evenColouringOf_colouringOf (W : ClosedFragment) + (F : EdgeSubset W) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) : + evenColouringOf W F (colouringOf W F ψ φ) + (colourFlags_colouringOf W F ψ φ) + (colouringOf_diagonal W F ψ φ) = ψ := by + refine Subtype.ext (funext (fun p => ?_)) + obtain ⟨g, hg⟩ := p + have hgoal : evenDataOf W F (colouringOf W F ψ φ) + (colourFlags_colouringOf W F ψ φ) ⟨g, hg⟩ = + ψ.val ⟨g, hg⟩ := ?_ + · exact hgoal + rw [evenDataOf] + have hval : colouringOf W F ψ φ (starFlagEnum W g) = + Sum.inl (ψ.val ⟨g, hg⟩) := by + rw [colouringOf] + rw [dite_eq_right (show ¬ ((starFlagEnum W).symm + (starFlagEnum W g) ∈ F.flags) from by + rw [_root_.Equiv.symm_apply_apply]; exact hg)] + refine congrArg Sum.inl ?_ + refine congrArg ψ.val (Subtype.ext ?_) + exact _root_.Equiv.symm_apply_apply _ _ + exact Eq.trans (getLeft_congr hval _ rfl) rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FlagEnum.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FlagEnum.lean new file mode 100644 index 0000000000..ec3bb04182 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FlagEnum.lean @@ -0,0 +1,245 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairEnum +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockData + +/-! +# The two flag enumerations + +The Definition 5 pair enumeration and the block-slot enumeration +are duplicate-free lists of the participating flags at a vertex: +the raw material for the canonical index permutation between them. +-/ + +@[expose] public section + +namespace RS + +open Finset + +section PairSide + +variable {α : Type} {W : Fragment α} {F : EdgeSubset W} + {κ : F.TransitionSystem} + +/-- Members of the pair base are incoming flags. -/ +theorem mem_pairBase {o : κ.Orientation} {v : W.Vertex} + {f : {f : W.Flag // f ∈ F.flags}} + (hf : f ∈ (F.inFlagsAt o v).attachWith (· ∈ F.flags) + (fun _ hf' => F.mem_of_mem_inFlagsAt hf')) : + f.val ∈ F.inFlagsAt o v := by + rw [show (F.inFlagsAt o v).attachWith (· ∈ F.flags) + (fun _ hf' => F.mem_of_mem_inFlagsAt hf') = + (F.inFlagsAt o v).pmap Subtype.mk + (fun _ hf' => F.mem_of_mem_inFlagsAt hf') from rfl] + at hf + obtain ⟨a, ha, hfa⟩ := List.mem_pmap.mp hf + rw [← hfa] + exact ha + +/-- Incoming flags attach to their vertex. -/ +theorem attach_of_mem_inFlagsAt {o : κ.Orientation} + {v : W.Vertex} {f : W.Flag} + (hf : f ∈ F.inFlagsAt o v) : W.attach f = Sum.inl v := by + let := W.flagOrder + let := Classical.dec + unfold EdgeSubset.inFlagsAt at hf + exact (Finset.mem_filter.mp + ((Finset.mem_sort _).mp hf)).2.1 + +/-- **The pair enumeration is duplicate-free.** -/ +theorem pairFlagList_nodup (o : κ.Orientation) (v : W.Vertex) : + (pairFlagList (F := F) o v).Nodup := by + rw [pairFlagList, List.nodup_flatMap] + constructor + · intro f _ + refine List.nodup_cons.mpr ⟨?_, List.nodup_singleton _⟩ + intro hmem + rw [List.mem_singleton] at hmem + have hval : f.val = κ.match_ f.val := + congrArg Subtype.val hmem + exact κ.match_ne f.val f.prop hval.symm + · have hnodup : ((F.inFlagsAt o v).attachWith (· ∈ F.flags) + (fun _ hf' => F.mem_of_mem_inFlagsAt hf')).Nodup := by + refine List.Nodup.pmap (fun a _ b _ h => + congrArg Subtype.val h) ?_ + let := W.flagOrder + let := Classical.dec + exact Finset.sort_nodup _ _ + refine List.Pairwise.imp_of_mem ?_ + (List.Pairwise.imp (fun {a b} h => h) + hnodup) + intro f₁ f₂ h₁ h₂ hne + have hin₁ : o.isOut f₁.val = false := + isOut_of_mem_inFlagsAt o (mem_pairBase h₁) + have hin₂ : o.isOut f₂.val = false := + isOut_of_mem_inFlagsAt o (mem_pairBase h₂) + intro x hx₁ hx₂ + rcases List.mem_cons.mp hx₁ with rfl | hx₁' + · rcases List.mem_cons.mp hx₂ with h | hx₂' + · exact hne h + · rw [List.mem_singleton] at hx₂' + have : o.isOut x.val = true := by + rw [show x.val = κ.match_ f₂.val from + congrArg Subtype.val hx₂'] + rw [o.match_flip f₂.val f₂.prop, hin₂] + rfl + rw [hin₁] at this + exact Bool.noConfusion this + · rw [List.mem_singleton] at hx₁' + rcases List.mem_cons.mp hx₂ with rfl | hx₂' + · have : o.isOut x.val = true := by + rw [show x.val = κ.match_ f₁.val from + congrArg Subtype.val hx₁'] + rw [o.match_flip f₁.val f₁.prop, hin₁] + rfl + rw [hin₂] at this + exact Bool.noConfusion this + · rw [List.mem_singleton] at hx₂' + refine hne (Subtype.ext ?_) + have hmm : κ.match_ f₁.val = κ.match_ f₂.val := + (congrArg Subtype.val hx₁').symm.trans + (congrArg Subtype.val hx₂') + have h1 := κ.match_invol f₁.val f₁.prop + have h2 := κ.match_invol f₂.val f₂.prop + rw [← h1, ← h2, hmm] + +/-- **Membership in the pair enumeration** is attachment at the +vertex. -/ +theorem mem_pairFlagList (o : κ.Orientation) (v : W.Vertex) + (x : {f : W.Flag // f ∈ F.flags}) : + x ∈ pairFlagList (F := F) o v ↔ + W.attach x.val = Sum.inl v := by + rw [pairFlagList, List.mem_flatMap] + constructor + · rintro ⟨f, hf, hx⟩ + have hfin := mem_pairBase hf + rcases List.mem_cons.mp hx with rfl | hx' + · exact attach_of_mem_inFlagsAt hfin + · rw [List.mem_singleton] at hx' + rw [show x.val = κ.match_ f.val from + congrArg Subtype.val hx'] + exact κ.match_vertex f.val f.prop v + (attach_of_mem_inFlagsAt hfin) + · intro hatt + by_cases hout : o.isOut x.val = true + · set f₀ : {f : W.Flag // f ∈ F.flags} := + ⟨κ.match_ x.val, κ.match_mem _ x.prop⟩ with hf₀ + have hin₀ : o.isOut f₀.val = false := by + change o.isOut (κ.match_ x.val) = false + rw [o.match_flip x.val x.prop, hout] + rfl + have hatt₀ : W.attach f₀.val = Sum.inl v := + κ.match_vertex x.val x.prop v hatt + have hmem₀ : f₀.val ∈ F.inFlagsAt o v := + mem_inFlagsAt_of f₀.prop hatt₀ hin₀ + refine ⟨f₀, ?_, ?_⟩ + · rw [show (F.inFlagsAt o v).attachWith (· ∈ F.flags) + (fun _ hf' => F.mem_of_mem_inFlagsAt hf') = + (F.inFlagsAt o v).pmap Subtype.mk + (fun _ hf' => F.mem_of_mem_inFlagsAt hf') + from rfl] + exact List.mem_pmap.mpr ⟨f₀.val, hmem₀, + Subtype.ext rfl⟩ + · refine List.mem_cons.mpr (Or.inr ?_) + rw [List.mem_singleton] + refine Subtype.ext ?_ + change x.val = κ.match_ f₀.val + exact (κ.match_invol x.val x.prop).symm + · have hin : o.isOut x.val = false := by + cases hb : o.isOut x.val + · rfl + · exact absurd hb hout + have hmem : x.val ∈ F.inFlagsAt o v := + mem_inFlagsAt_of x.prop hatt hin + refine ⟨x, ?_, List.mem_cons_self⟩ + rw [show (F.inFlagsAt o v).attachWith (· ∈ F.flags) + (fun _ hf' => F.mem_of_mem_inFlagsAt hf') = + (F.inFlagsAt o v).pmap Subtype.mk + (fun _ hf' => F.mem_of_mem_inFlagsAt hf') + from rfl] + exact List.mem_pmap.mpr ⟨x.val, hmem, Subtype.ext rfl⟩ + +end PairSide + +section BlockSide + +variable {k ℓ : ℕ} + +open Classical in +/-- The block-slot enumeration: the participating slots of a +block in slot order, as flags. -/ +noncomputable def blockOddFlagList (W : ClosedFragment) + (F : EdgeSubset W) (v : Fin (ds W).length) : + List {f : W.Flag // f ∈ F.flags} := + ((oddSlots W F v).sort (· ≤ ·)).pmap + (fun j hj => ⟨blockFlag W v j, (mem_oddSlots j).mp hj⟩) + (fun _ hj => (Finset.mem_sort _).mp hj) + +open Classical in +/-- The block-slot enumeration is duplicate-free. -/ +theorem blockOddFlagList_nodup (W : ClosedFragment) + (F : EdgeSubset W) (v : Fin (ds W).length) : + (blockOddFlagList W F v).Nodup := by + refine List.Nodup.pmap ?_ (Finset.sort_nodup _ _) + intro a _ b _ h + have hv := congrArg + (fun z : {f : W.Flag // f ∈ F.flags} => z.val) h + exact blockFlag_injective W v hv + +open Classical in +/-- Membership in the block-slot enumeration is attachment at +the block's vertex. -/ +theorem mem_blockOddFlagList (W : ClosedFragment) + (F : EdgeSubset W) (v : Fin (ds W).length) + (x : {f : W.Flag // f ∈ F.flags}) : + x ∈ blockOddFlagList W F v ↔ + W.attach x.val = Sum.inl (blockVertex W v) := by + rw [blockOddFlagList] + constructor + · intro hx + obtain ⟨j, _, hjx⟩ := List.mem_pmap.mp hx + rw [show x.val = blockFlag W v j from + (congrArg Subtype.val hjx).symm] + rw [ClosedFragment.attach_eq_vertexOf, vertexOf_blockFlag] + · intro hatt + have hvtx : ClosedFragment.vertexOf W x.val = + blockVertex W v := + Sum.inl.inj + ((ClosedFragment.attach_eq_vertexOf W x.val).symm.trans + hatt) + have hmem : x.val ∈ Finset.univ.filter (fun g => + ClosedFragment.vertexOf W g = blockVertex W v) := by + rw [Finset.mem_filter] + exact ⟨Finset.mem_univ _, hvtx⟩ + rw [← image_blockFlag, Finset.mem_image] at hmem + obtain ⟨j, -, hj⟩ := hmem + have hjodd : j ∈ oddSlots W F v := by + rw [mem_oddSlots, hj] + exact x.prop + refine List.mem_pmap.mpr ⟨j, ?_, ?_⟩ + · rw [Finset.mem_sort] + exact hjodd + · exact Subtype.ext hj + +open Classical in +/-- **The two enumerations list the same flags.** -/ +theorem mem_blockOddFlagList_iff_pairFlagList + (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) + (v : Fin (ds W).length) + (x : {f : W.Flag // f ∈ F.flags}) : + x ∈ blockOddFlagList W F v ↔ + x ∈ pairFlagList (F := F) o (blockVertex W v) := + (mem_blockOddFlagList W F v x).trans + (mem_pairFlagList o (blockVertex W v) x).symm + +end BlockSide + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/GlobalSlotList.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/GlobalSlotList.lean new file mode 100644 index 0000000000..11e4d0b003 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/GlobalSlotList.lean @@ -0,0 +1,530 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauKey +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PatternInv + +/-! +# The global slot list + +The participating flags of an edge subset, enumerated in slot order, +and the link between the pattern inversion count and list inversions. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {k ℓ : ℕ} + +/-- The set of slots whose flags participate in `F`. -/ +noncomputable def partSlots (W : ClosedFragment) (F : EdgeSubset W) : + Finset (Fin (edgeCount W + edgeCount W)) := + Finset.univ.filter (fun q => (starFlagEnum W).symm q ∈ F.flags) + +/-- Membership in `partSlots`. -/ +theorem mem_partSlots {W : ClosedFragment} {F : EdgeSubset W} + (q : Fin (edgeCount W + edgeCount W)) : + q ∈ partSlots W F ↔ (starFlagEnum W).symm q ∈ F.flags := by + rw [partSlots, Finset.mem_filter] + exact ⟨fun h => h.2, fun h => ⟨Finset.mem_univ _, h⟩⟩ + +/-- The global slot list: participating flags in slot order. -/ +noncomputable def globalSlotList (W : ClosedFragment) (F : EdgeSubset W) : + List {f : W.Flag // f ∈ F.flags} := + ((partSlots W F).sort (· ≤ ·)).pmap + (fun q hq => ⟨(starFlagEnum W).symm q, (mem_partSlots q).mp hq⟩) + (fun _ hq => (Finset.mem_sort _).mp hq) + +/-- The global slot list is duplicate-free. -/ +theorem globalSlotList_nodup (W : ClosedFragment) (F : EdgeSubset W) : + (globalSlotList W F).Nodup := by + refine List.Nodup.pmap ?_ (Finset.sort_nodup _ _) + intro a _ b _ h + have hv := congrArg + (fun z : {f : W.Flag // f ∈ F.flags} => z.val) h + exact (starFlagEnum W).symm.injective hv + +/-- Every participating flag appears in the global slot list. -/ +theorem mem_globalSlotList (W : ClosedFragment) (F : EdgeSubset W) + (x : {f : W.Flag // f ∈ F.flags}) : + x ∈ globalSlotList W F := by + rw [globalSlotList] + have hslot : starFlagEnum W x.val ∈ partSlots W F := by + rw [mem_partSlots, _root_.Equiv.symm_apply_apply] + exact x.prop + have hsort : starFlagEnum W x.val ∈ + (partSlots W F).sort (· ≤ ·) := + (Finset.mem_sort _).mpr hslot + exact List.mem_pmap.mpr ⟨starFlagEnum W x.val, hsort, + Subtype.ext (_root_.Equiv.symm_apply_apply _ _)⟩ + +/-- Filter length of `ofFn` matches finset card. -/ +theorem filter_length_ofFn {β : Type} + {n : ℕ} (g : Fin n → β) (p : β → Bool) : + ((List.ofFn g).filter p).length = + (Finset.univ.filter (fun i : Fin n => p (g i) = true)).card := by + rw [List.ofFn_eq_map, List.filter_map, List.length_map] + -- Goal: (List.finRange n |>.filter (p ∘ g)).length = ... + have hperm : ((List.finRange n).filter (p ∘ g)).Perm + (((Finset.univ : Finset (Fin n)).filter + (fun i => p (g i) = true)).sort (· ≤ ·)) := by + rw [List.perm_ext_iff_of_nodup + ((List.nodup_finRange n).filter _) + (Finset.sort_nodup _ _)] + intro x + rw [List.mem_filter, Finset.mem_sort, Finset.mem_filter] + simp [List.mem_finRange, Function.comp] + rw [hperm.length_eq, Finset.length_sort] + +/-- Helper: the head-filter count in the successor step. -/ +private theorem head_filter_card {β : Type} [LinearOrder β] + {n : ℕ} (g : Fin (n + 1) → β) : + ((List.ofFn (fun i : Fin n => g i.succ)).filter + (fun b => decide (b < g 0))).length = + (Finset.univ.filter (fun i : Fin n => + g i.succ < g 0)).card := by + classical + rw [filter_length_ofFn] + congr 1 + ext i + simp [decide_eq_true_eq] + +/-- Helper: partition of pair inversions by first component. -/ +private theorem pair_filter_succ_split {β : Type} [LinearOrder β] + {n : ℕ} (g : Fin (n + 1) → β) : + (Finset.univ.filter (fun p : Fin (n + 1) × Fin (n + 1) => + p.1 < p.2 ∧ g p.2 < g p.1)).card = + (Finset.univ.filter (fun i : Fin n => + g i.succ < g 0)).card + + (Finset.univ.filter (fun p : Fin n × Fin n => + p.1 < p.2 ∧ g p.2.succ < g p.1.succ)).card := by + -- Partition pairs (a, b) with a < b into those with a = 0 and + -- those with a ≠ 0 (i.e. a = i.succ for some i). + have hdisj : Disjoint + (Finset.univ.filter (fun p : Fin (n + 1) × Fin (n + 1) => + p.1 = 0 ∧ p.1 < p.2 ∧ g p.2 < g p.1)) + (Finset.univ.filter (fun p : Fin (n + 1) × Fin (n + 1) => + p.1 ≠ 0 ∧ p.1 < p.2 ∧ g p.2 < g p.1)) := by + rw [Finset.disjoint_filter] + intro _ _ ⟨h0, _⟩ ⟨hn, _⟩ + exact hn h0 + have hunion : Finset.univ.filter (fun p : Fin (n + 1) × Fin (n + 1) => + p.1 < p.2 ∧ g p.2 < g p.1) = + (Finset.univ.filter (fun p : Fin (n + 1) × Fin (n + 1) => + p.1 = 0 ∧ p.1 < p.2 ∧ g p.2 < g p.1)) ∪ + (Finset.univ.filter (fun p : Fin (n + 1) × Fin (n + 1) => + p.1 ≠ 0 ∧ p.1 < p.2 ∧ g p.2 < g p.1)) := by + ext ⟨a, b⟩ + simp only [Finset.mem_filter, Finset.mem_union, Finset.mem_univ, + true_and] + constructor + · intro ⟨hab, hgab⟩ + by_cases h0 : a = 0 + · exact Or.inl ⟨h0, hab, hgab⟩ + · exact Or.inr ⟨h0, hab, hgab⟩ + · rintro (⟨-, h⟩ | ⟨-, h⟩) <;> exact h + rw [hunion, Finset.card_union_of_disjoint hdisj] + congr 1 + · -- Pairs with a = 0 biject with {i : Fin n | g i.succ < g 0} + apply Finset.card_bij + (fun (p : Fin (n + 1) × Fin (n + 1)) (hp : p ∈ _) => + p.2.pred (by + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hp + intro h0; rw [hp.1, h0] at hp; exact lt_irrefl _ hp.2.1)) + · intro ⟨a, b⟩ hmem + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hmem ⊢ + obtain ⟨ha0, _, hgba⟩ := hmem + rw [ha0] at hgba + rwa [Fin.succ_pred] + · intro ⟨a₁, b₁⟩ h₁ ⟨a₂, b₂⟩ h₂ heq + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at h₁ h₂ + have ha1 := h₁.1 + have ha2 := h₂.1 + have hb : b₁ = b₂ := by + rw [Fin.ext_iff] at heq ⊢ + simp only [Fin.val_pred] at heq + omega + exact Prod.ext (ha1.trans ha2.symm) hb + · intro i hmem + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hmem + refine ⟨⟨0, i.succ⟩, ?_, ?_⟩ + · simp only [Finset.mem_filter, Finset.mem_univ, true_and] + exact ⟨Fin.succ_pos _, hmem⟩ + · exact Fin.pred_succ _ + · -- Pairs with a ≠ 0 biject with Fin n × Fin n pairs + apply Finset.card_bij + (fun (p : Fin (n + 1) × Fin (n + 1)) (hp : p ∈ _) => + (p.1.pred (by + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hp + exact hp.1), + p.2.pred (by + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hp + intro h0; rw [h0] at hp + exact Nat.not_lt.mpr (Fin.zero_le _) hp.2.1))) + · intro ⟨a, b⟩ hmem + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hmem ⊢ + obtain ⟨hne, hab, hgba⟩ := hmem + constructor + · exact Fin.pred_lt_pred_iff.mpr hab + · rwa [Fin.succ_pred, Fin.succ_pred] + · intro ⟨a₁, b₁⟩ h₁ ⟨a₂, b₂⟩ h₂ heq + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at h₁ h₂ + have hprod := Prod.ext_iff.mp heq + have ha : a₁ = a₂ := @Fin.pred_inj _ a₁ a₂ h₁.1 h₂.1 |>.mp hprod.1 + have hb : b₁ = b₂ := by + have hb1ne : b₁ ≠ 0 := by + intro h0; rw [h0] at h₁; exact Nat.not_lt.mpr (Fin.zero_le _) h₁.2.1 + have hb2ne : b₂ ≠ 0 := by + intro h0; rw [h0] at h₂; exact Nat.not_lt.mpr (Fin.zero_le _) h₂.2.1 + exact @Fin.pred_inj _ b₁ b₂ hb1ne hb2ne |>.mp hprod.2 + exact Prod.ext ha hb + · intro ⟨i, j⟩ hmem + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hmem + refine ⟨⟨i.succ, j.succ⟩, ?_, ?_⟩ + · simp only [Finset.mem_filter, Finset.mem_univ, true_and] + exact ⟨Fin.succ_ne_zero _, + Fin.succ_lt_succ_iff.mpr hmem.1, hmem.2⟩ + · ext <;> simp [Fin.pred_succ] + +/-- Inversion count of `ofFn g` equals the pair-filter card. -/ +theorem inversions_ofFn_eq_card {β : Type} [LinearOrder β] + {n : ℕ} (g : Fin n → β) : + inversions (List.ofFn g) = + (Finset.univ.filter (fun p : Fin n × Fin n => + p.1 < p.2 ∧ g p.2 < g p.1)).card := by + induction n with + | zero => + rw [List.ofFn_zero, inversions] + simp [Finset.filter_false_of_mem] + | succ n ih => + rw [List.ofFn_succ, inversions, ih] + rw [head_filter_card, pair_filter_succ_split] + +/-- The key of the flag at slot `finCongr ... (sortSplitPerm W x)` + is `x` itself. -/ +theorem sortKey_symm_slot (W : ClosedFragment) + (x : Fin (ds W).sum) : + sortKey W ((starFlagEnum W).symm + (finCongr (degList_sum (starAssignEnum W)) + (sortSplitPerm W x))) = x := by + rw [sortKey] + have hsplit : finCongr (degList_sum (starAssignEnum W)) + (sortSplitPerm W x) = + (sortEquiv (starAssignEnum W)).symm x := by + exact (congrFun (congrArg _root_.Equiv.toFun + (sortEquiv_symm_split W)) x).symm + conv_lhs => rw [hsplit] + rw [show (starFlagEnum W) ((starFlagEnum W).symm + ((sortEquiv (starAssignEnum W)).symm x)) = + (sortEquiv (starAssignEnum W)).symm x from + _root_.Equiv.apply_symm_apply _ _] + exact _root_.Equiv.apply_symm_apply _ _ + +/-- `finCongr` preserves strict order. -/ +private theorem finCongr_lt_iff {m n : ℕ} (h : m = n) + (a b : Fin m) : + finCongr h a < finCongr h b ↔ a < b := by + rw [Fin.lt_def, Fin.lt_def, finCongr_apply_coe, + finCongr_apply_coe] + +/-- The slot of a key equals the original flag position. -/ +private theorem slot_of_sortKey (W : ClosedFragment) + (q : Fin (edgeCount W + edgeCount W)) : + finCongr (degList_sum (starAssignEnum W)) + (sortSplitPerm W + (sortEquiv (starAssignEnum W) q)) = q := by + -- sortEquiv_symm_split says: + -- (sortEquiv _).symm = (sortSplitPerm W).trans (finCongr _) + -- So finCongr _ (sortSplitPerm W x) = (sortEquiv _).symm x + -- Applying at x = sortEquiv _ q: + -- finCongr _ (sortSplitPerm W (sortEquiv _ q)) + -- = (sortEquiv _).symm (sortEquiv _ q) = q + have step : ∀ y : Fin (ds W).sum, + finCongr (degList_sum (starAssignEnum W)) + (sortSplitPerm W y) = + (sortEquiv (starAssignEnum W)).symm y := by + intro y + have h := sortEquiv_symm_split W + exact (congrFun (congrArg _root_.Equiv.toFun h) y).symm + rw [step, _root_.Equiv.symm_apply_apply] + +/-- Length of globalSlotList equals length of sorted partSlots. -/ +private theorem globalSlotList_length (W : ClosedFragment) + (F : EdgeSubset W) : + (globalSlotList W F).length = + ((partSlots W F).sort (· ≤ ·)).length := by + unfold globalSlotList + exact List.length_pmap + +/-- The getElem of the globalSlotList pmap extracts the flag from +the sort. -/ +private theorem globalSlotList_getElem_val (W : ClosedFragment) + (F : EdgeSubset W) + (i : ℕ) (hi : i < (globalSlotList W F).length) : + ((globalSlotList W F)[i]).val = + (starFlagEnum W).symm + (((partSlots W F).sort (· ≤ ·))[i]'(by + rw [globalSlotList_length] at hi; exact hi)) := by + unfold globalSlotList at hi ⊢ + rw [List.getElem_pmap] + +/-- The slot list is strictly sorted. -/ +private theorem sort_pairwise_lt (W : ClosedFragment) (F : EdgeSubset W) : + List.Pairwise (· < ·) ((partSlots W F).sort (· ≤ ·)) := + List.sortedLT_iff_pairwise.mp (Finset.sortedLT_sort (partSlots W F)) + +/-- The intermediate slot-inversion set. -/ +private noncomputable def slotInvPairs (W : ClosedFragment) + (F : EdgeSubset W) : + Finset (Fin (edgeCount W + edgeCount W) × + Fin (edgeCount W + edgeCount W)) := + (partSlots W F ×ˢ partSlots W F).filter + (fun qp => qp.1 < qp.2 ∧ + sortKey W ((starFlagEnum W).symm qp.2) < + sortKey W ((starFlagEnum W).symm qp.1)) + +/-- patternOddInv equals the card of slotInvPairs. -/ +private theorem patternOddInv_eq_slotInvPairs + (W : ClosedFragment) (F : EdgeSubset W) : + patternOddInv W F = (slotInvPairs W F).card := by + unfold patternOddInv slotInvPairs + apply Finset.card_bij + (fun (p : Fin (ds W).sum × Fin (ds W).sum) _ => + (finCongr (degList_sum (starAssignEnum W)) + (sortSplitPerm W p.2), + finCongr (degList_sum (starAssignEnum W)) + (sortSplitPerm W p.1))) + · intro ⟨p₁, p₂⟩ hmem + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hmem + obtain ⟨hlt, hgt, hf1, hf2⟩ := hmem + simp only [Finset.mem_filter, Finset.mem_product] + refine ⟨⟨?_, ?_⟩, ?_, ?_⟩ + · rw [mem_partSlots]; exact hf2 + · rw [mem_partSlots]; exact hf1 + · rw [finCongr_lt_iff]; exact hgt + · rw [sortKey_symm_slot, sortKey_symm_slot]; exact hlt + · intro ⟨p₁, p₂⟩ _ ⟨q₁, q₂⟩ _ heq + have hprod := Prod.ext_iff.mp heq + have h1 : sortSplitPerm W p₂ = sortSplitPerm W q₂ := by + have := hprod.1 + rwa [Fin.ext_iff, finCongr_apply_coe, finCongr_apply_coe, + ← Fin.ext_iff] at this + have h2 : sortSplitPerm W p₁ = sortSplitPerm W q₁ := by + have := hprod.2 + rwa [Fin.ext_iff, finCongr_apply_coe, finCongr_apply_coe, + ← Fin.ext_iff] at this + exact Prod.ext + ((sortSplitPerm W).injective h2) + ((sortSplitPerm W).injective h1) + · intro ⟨q₁, q₂⟩ hmem + simp only [Finset.mem_filter, Finset.mem_product] at hmem + obtain ⟨⟨hq1, hq2⟩, hlt, hkey⟩ := hmem + have hsk : ∀ q, sortKey W ((starFlagEnum W).symm q) = + sortEquiv (starAssignEnum W) q := by + intro q; rw [sortKey, _root_.Equiv.apply_symm_apply] + refine ⟨⟨sortKey W ((starFlagEnum W).symm q₂), + sortKey W ((starFlagEnum W).symm q₁)⟩, ?_, ?_⟩ + · simp only [Finset.mem_filter, Finset.mem_univ, true_and] + refine ⟨hkey, ?_, ?_, ?_⟩ + · rw [show sortSplitPerm W + (sortKey W ((starFlagEnum W).symm q₂)) = + sortSplitPerm W (sortEquiv (starAssignEnum W) q₂) from + congrArg _ (hsk q₂)] + rw [show sortSplitPerm W + (sortKey W ((starFlagEnum W).symm q₁)) = + sortSplitPerm W (sortEquiv (starAssignEnum W) q₁) from + congrArg _ (hsk q₁)] + rw [GT.gt, ← finCongr_lt_iff (degList_sum (starAssignEnum W)), + slot_of_sortKey, slot_of_sortKey] + exact hlt + · rw [show finCongr (degList_sum (starAssignEnum W)) + (sortSplitPerm W + (sortKey W ((starFlagEnum W).symm q₂))) = + q₂ from by rw [hsk, slot_of_sortKey]] + rw [mem_partSlots] at hq2; exact hq2 + · rw [show finCongr (degList_sum (starAssignEnum W)) + (sortSplitPerm W + (sortKey W ((starFlagEnum W).symm q₁))) = + q₁ from by rw [hsk, slot_of_sortKey]] + rw [mem_partSlots] at hq1; exact hq1 + · ext <;> simp only + · rw [hsk, slot_of_sortKey] + · rw [hsk, slot_of_sortKey] + +/-- The sorted slot list's nodup property. -/ +private theorem sort_nodup (W : ClosedFragment) (F : EdgeSubset W) : + ((partSlots W F).sort (· ≤ ·)).Nodup := + Finset.sort_nodup _ _ + +/-- Position lookup: index of element in sorted list. -/ +private noncomputable def slotPos (W : ClosedFragment) + (F : EdgeSubset W) + (q : Fin (edgeCount W + edgeCount W)) + (hq : q ∈ partSlots W F) : + Fin ((partSlots W F).sort (· ≤ ·)).length := + ⟨((partSlots W F).sort (· ≤ ·)).idxOf q, + List.idxOf_lt_length_of_mem ((Finset.mem_sort _).mpr hq)⟩ + +/-- The sort's getElem at slotPos returns the original element. -/ +private theorem sort_getElem_slotPos (W : ClosedFragment) + (F : EdgeSubset W) + (q : Fin (edgeCount W + edgeCount W)) + (hq : q ∈ partSlots W F) : + ((partSlots W F).sort (· ≤ ·))[(slotPos W F q hq).val] = q := by + exact List.getElem_idxOf + (List.idxOf_lt_length_of_mem ((Finset.mem_sort _).mpr hq)) + +/-- getElem is injective on nodup lists. -/ +private theorem nodup_getElem_injective {α : Type} {l : List α} + (hnd : l.Nodup) {i j : ℕ} (hi : i < l.length) (hj : j < l.length) + (h : l[i] = l[j]) : i = j := by + exact (List.Nodup.getElem?_inj hi hnd).mp + (show l[i]? = l[j]? by + rw [List.getElem?_eq_getElem hi, List.getElem?_eq_getElem hj] + exact congrArg _ h) + +/-- slotPos is order-preserving. -/ +private theorem slotPos_lt_of_lt (W : ClosedFragment) + (F : EdgeSubset W) + (q₁ q₂ : Fin (edgeCount W + edgeCount W)) + (hq1 : q₁ ∈ partSlots W F) + (hq2 : q₂ ∈ partSlots W F) + (hlt : q₁ < q₂) : + slotPos W F q₁ hq1 < slotPos W F q₂ hq2 := by + simp only [slotPos, Fin.mk_lt_mk] + by_contra h + push Not at h + have hi1 : List.idxOf q₁ ((partSlots W F).sort (· ≤ ·)) < + ((partSlots W F).sort (· ≤ ·)).length := + List.idxOf_lt_length_of_mem + ((Finset.mem_sort (α := Fin (edgeCount W + edgeCount W)) + (· ≤ ·)).mpr hq1) + have hi2 : List.idxOf q₂ ((partSlots W F).sort (· ≤ ·)) < + ((partSlots W F).sort (· ≤ ·)).length := + List.idxOf_lt_length_of_mem + ((Finset.mem_sort (α := Fin (edgeCount W + edgeCount W)) + (· ≤ ·)).mpr hq2) + rcases Nat.lt_or_eq_of_le h with hgt | heq + · have := List.pairwise_iff_getElem.mp (sort_pairwise_lt W F) + _ _ hi2 hi1 hgt + rw [List.getElem_idxOf hi2, + List.getElem_idxOf hi1] at this + exact lt_irrefl _ (lt_trans hlt this) + · -- idxOf q₁ = idxOf q₂, so by nodup: the elements at those positions are + -- equal + -- but getElem_idxOf says they are q₁ and q₂ respectively + exfalso + have h1 : ((partSlots W F).sort (· ≤ ·))[ + List.idxOf q₁ ((partSlots W F).sort (· ≤ ·))] = q₁ := + List.getElem_idxOf hi1 + have h2 : ((partSlots W F).sort (· ≤ ·))[ + List.idxOf q₂ ((partSlots W F).sort (· ≤ ·))] = q₂ := + List.getElem_idxOf hi2 + have heq' : ((partSlots W F).sort (· ≤ ·))[ + List.idxOf q₁ ((partSlots W F).sort (· ≤ ·))] = + ((partSlots W F).sort (· ≤ ·))[ + List.idxOf q₂ ((partSlots W F).sort (· ≤ ·))]'(by omega) := by + congr 1; omega + rw [h1, h2] at heq' + exact lt_irrefl _ (heq' ▸ hlt) + +/-- inversions of the key-mapped global slot list equals slotInvPairs. -/ +private theorem inversions_eq_slotInvPairs (W : ClosedFragment) + (F : EdgeSubset W) : + inversions ((globalSlotList W F).map + (fun f => sortKey W f.val)) = + (slotInvPairs W F).card := by + set l := globalSlotList W F with hl + set m := l.length with hm + -- Convert map to ofFn + have hofFn : l.map (fun f => sortKey W f.val) = + List.ofFn (fun i : Fin m => sortKey W (l.get i).val) := by + rw [show l.map (fun f => sortKey W f.val) = + (List.ofFn l.get).map (fun f => sortKey W f.val) from + by rw [List.ofFn_get], List.map_ofFn]; rfl + rw [hofFn, inversions_ofFn_eq_card] + -- Now: card of {(i,j) : Fin m × Fin m | i < j ∧ key(l[j]) < key(l[i])} + -- = card of slotInvPairs + set sortL := (partSlots W F).sort (· ≤ ·) with hsortL + have hml : m = sortL.length := globalSlotList_length W F + -- Bijection via getElem: position ↦ slot + apply Finset.card_bij + (fun (p : Fin m × Fin m) (_ : p ∈ _) => + (sortL[p.1.val]'(hml ▸ p.1.isLt), + sortL[p.2.val]'(hml ▸ p.2.isLt))) + · -- mem + intro ⟨i, j⟩ hmem + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hmem + obtain ⟨hij, hkey⟩ := hmem + simp only [slotInvPairs, Finset.mem_filter, Finset.mem_product] + refine ⟨⟨(Finset.mem_sort _).mp (List.getElem_mem _), + (Finset.mem_sort _).mp (List.getElem_mem _)⟩, ?_, ?_⟩ + · exact List.pairwise_iff_getElem.mp (sort_pairwise_lt W F) + i j (hml ▸ i.isLt) (hml ▸ j.isLt) hij + · -- Convert: l.get i's val = (starFlagEnum W).symm sortL[i] + have hvi : (l.get ⟨i.val, i.isLt⟩).val = + (starFlagEnum W).symm (sortL[i.val]'(hml ▸ i.isLt)) := + globalSlotList_getElem_val W F i.val i.isLt + have hvj : (l.get ⟨j.val, j.isLt⟩).val = + (starFlagEnum W).symm (sortL[j.val]'(hml ▸ j.isLt)) := + globalSlotList_getElem_val W F j.val j.isLt + rw [← hvj, ← hvi] + exact hkey + · -- inj + intro ⟨i₁, j₁⟩ _ ⟨i₂, j₂⟩ _ heq + have hprod := Prod.ext_iff.mp heq + have hnd := sort_nodup W F + have hi := nodup_getElem_injective hnd (hml ▸ i₁.isLt) (hml ▸ i₂.isLt) + hprod.1 + have hj := nodup_getElem_injective hnd (hml ▸ j₁.isLt) (hml ▸ j₂.isLt) + hprod.2 + exact Prod.ext (Fin.ext hi) (Fin.ext hj) + · -- surj + intro ⟨q₁, q₂⟩ hmem + simp only [slotInvPairs, Finset.mem_filter, + Finset.mem_product] at hmem + obtain ⟨⟨hq1, hq2⟩, hlt, hkey⟩ := hmem + set i := slotPos W F q₁ hq1 with hi_def + set j := slotPos W F q₂ hq2 with hj_def + have hi_lt : i.val < m := by rw [hml]; exact i.isLt + have hj_lt : j.val < m := by rw [hml]; exact j.isLt + refine ⟨⟨⟨i.val, hi_lt⟩, ⟨j.val, hj_lt⟩⟩, ?_, ?_⟩ + · simp only [Finset.mem_filter, Finset.mem_univ, true_and] + constructor + · exact slotPos_lt_of_lt W F q₁ q₂ hq1 hq2 hlt + · have hvi : (l.get ⟨i.val, hi_lt⟩).val = + (starFlagEnum W).symm q₁ := by + change ((globalSlotList W F)[i.val]'hi_lt).val = _ + rw [globalSlotList_getElem_val] + congr 1 + exact sort_getElem_slotPos W F q₁ hq1 + have hvj : (l.get ⟨j.val, hj_lt⟩).val = + (starFlagEnum W).symm q₂ := by + change ((globalSlotList W F)[j.val]'hj_lt).val = _ + rw [globalSlotList_getElem_val] + congr 1 + exact sort_getElem_slotPos W F q₂ hq2 + rw [hvj, hvi] + exact hkey + · exact Prod.ext + (sort_getElem_slotPos W F q₁ hq1) + (sort_getElem_slotPos W F q₂ hq2) + +/-- **The pattern inversion count equals the key-inversions of the +global slot list.** -/ +theorem patternOddInv_eq_inversions (W : ClosedFragment) + (F : EdgeSubset W) : + patternOddInv W F = + inversions ((globalSlotList W F).map + (fun f => sortKey W f.val)) := by + rw [patternOddInv_eq_slotInvPairs, inversions_eq_slotInvPairs] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/HRS.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/HRS.lean new file mode 100644 index 0000000000..e3d2dcd83c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/HRS.lean @@ -0,0 +1,65 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonColour +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourFormMatch + +/-! +# The Regts–Sevenster functional + +The coordinates of the star vectors in the colouring model, and +the mixed functional at the canonical colouring. The accompanying +paper calls this witness `h^ξ` (§5.4). Its mate-based functional +satisfies `h^RS = h^ξ ∘ Sym_s(Ψ)`, where `Ψ` fixes the even basis +and sends `ξ_i` to `η_i`. Lemma 5.6 gives the coordinate dictionary; +Lemma 5.7 proves the change of basis and the invariance of the +partition function under the isometry `Ψ`. +-/ + +@[expose] public section + +namespace RS + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} +variable (e' : P.ω.obj (SkeinObj.mk 1) ⟶ stdSuperPair k ℓ) + +/-- The star coordinate: the vertex star vector transported to +the colouring model, read at a colouring; zero on odd-parity +colourings. -/ +noncomputable def starCoord (d : ℕ) + (c : MixedColouring k ℓ d) : ℂ := + if hc : c.IsEven then + (colourPowerEquiv k ℓ d).evenEquiv + (((stdFromOmega f P e' d) : + SuperVect.Hom _ _).evenMap (starVec f P d)) ⟨c, hc⟩ + else 0 + +/-- Star coordinates vanish on odd-parity colourings. -/ +theorem starCoord_odd (d : ℕ) (c : MixedColouring k ℓ d) + (hc : ¬ c.IsEven) : starCoord f P e' d c = 0 := + dite_eq_right hc + +/-- **The Regts–Sevenster functional**: the star coordinate at +the canonical colouring, the paper's witness `h^ξ` (§5.4). -/ +noncomputable def hRS : MixedFunctional k ℓ := fun μm F => + starCoord f P e' (μm.card + F.card) (canonColouring μm F) + +/-- The alternating evaluation on a duplicate-free list is the +sorting sign times the star coordinate at the canonical colouring. -/ +theorem evalOdd_hRS_nodup (μm : Multiset (Fin k)) + (w : List (Fin (2 * ℓ))) (hw : w.Nodup) : + (hRS f P e').evalOdd μm w = + (sortSign w : ℂ) * + starCoord f P e' (μm.card + w.toFinset.card) + (canonColouring μm w.toFinset) := by + unfold MixedFunctional.evalOdd hRS + rw [ite_eq_left hw] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/IndexPerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/IndexPerm.lean new file mode 100644 index 0000000000..59c7efd20c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/IndexPerm.lean @@ -0,0 +1,176 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ListSignPerm + +/-! +# The index permutation between two orderings of the same list + +Two duplicate-free lists with the same members are reorderings of +one another, and the reordering is a permutation of positions: the +*index permutation*. Its sign is what a summand pays for being +written in one order rather than the other, so sorting signs along +any injective relabelling differ by exactly it, and the sign is +multiplicative along a chain of reorderings. +-/ + +@[expose] public section + +namespace RS + +open Equiv + +/-! ### Length equality from Nodup + same membership -/ + +/-- Duplicate-free lists with the same members have the same +length. -/ +theorem length_eq_of_nodup_mem {γ : Type*} (l₁ l₂ : List γ) + (h₁ : l₁.Nodup) (h₂ : l₂.Nodup) (hmem : ∀ x, x ∈ l₁ ↔ x ∈ l₂) : + l₁.length = l₂.length := by + have hp : l₁.Perm l₂ := (List.perm_ext_iff_of_nodup h₁ h₂).mpr + (fun x => hmem x) + exact hp.length_eq + +/-! ### The canonical index permutation -/ + +/-- **The index permutation** carrying one list to another with the +same members: the position in the second list of the entry at each +position of the first. -/ +noncomputable def listIndexPerm {γ : Type*} [DecidableEq γ] (l₁ l₂ : List γ) + (h₁ : l₁.Nodup) (h₂ : l₂.Nodup) (hmem : ∀ x, x ∈ l₁ ↔ x ∈ l₂) + (hlen : l₁.length = l₂.length) : + Perm (Fin l₁.length) := + (h₁.getEquiv l₁).trans + ((Equiv.subtypeEquivRight (fun x => hmem x)).trans + ((h₂.getEquiv l₂).symm.trans (finCongr hlen.symm))) + +/-! ### Defining property -/ + +/-- Its defining property: it matches the two lists entrywise. -/ +theorem listIndexPerm_getElem {γ : Type*} [DecidableEq γ] (l₁ l₂ : List γ) + (h₁ : l₁.Nodup) (h₂ : l₂.Nodup) (hmem : ∀ x, x ∈ l₁ ↔ x ∈ l₂) + (hlen : l₁.length = l₂.length) (i : Fin l₁.length) : + l₂[((listIndexPerm l₁ l₂ h₁ h₂ hmem hlen) i).val]'(by + have := ((listIndexPerm l₁ l₂ h₁ h₂ hmem hlen) i).isLt; omega) = + l₁[i.val] := by + simp only [listIndexPerm, Equiv.trans_apply, Equiv.subtypeEquivRight_apply] + simp only [List.Nodup.getEquiv, finCongr] + simp only [Equiv.coe_fn_mk] + exact List.getElem_idxOf _ + +/-! ### Helper: inverse index property -/ + +private theorem listIndexPerm_inv_getElem {γ : Type*} [DecidableEq γ] (l₁ l₂ : + List γ) + (h₁ : l₁.Nodup) (h₂ : l₂.Nodup) (hmem : ∀ x, x ∈ l₁ ↔ x ∈ l₂) + (hlen : l₁.length = l₂.length) (j : Fin l₁.length) : + l₁[((listIndexPerm l₁ l₂ h₁ h₂ hmem hlen).symm j).val] = + l₂[j.val]'(by have := j.isLt; omega) := by + have hfwd := listIndexPerm_getElem l₁ l₂ h₁ h₂ hmem hlen + ((listIndexPerm l₁ l₂ h₁ h₂ hmem hlen).symm j) + simp only [Equiv.apply_symm_apply] at hfwd + exact hfwd.symm + +/-! ### Main transport theorem -/ + +private theorem map_eq_ofFn_comp_inv {γ : Type*} [DecidableEq γ] {β : Type} + (l₁ l₂ : List γ) (h₁ : l₁.Nodup) (h₂ : l₂.Nodup) + (hmem : ∀ x, x ∈ l₁ ↔ x ∈ l₂) (hlen : l₁.length = l₂.length) + (g : γ → β) : + l₂.map g = List.ofFn (fun j : Fin l₁.length => + g (l₁[(listIndexPerm l₁ l₂ h₁ h₂ hmem hlen).symm j])) := by + set τ := listIndexPerm l₁ l₂ h₁ h₂ hmem hlen + have step1 : l₂.map g = List.ofFn (fun i : Fin l₂.length => g l₂[i]) := + (List.ofFn_getElem_eq_map l₂ g).symm + rw [step1, List.ofFn_congr hlen.symm] + congr 1; ext j + have := listIndexPerm_inv_getElem l₁ l₂ h₁ h₂ hmem hlen j + simp only [Fin.cast] at this ⊢ + exact congrArg g this.symm + +/-- Sorting signs differ by the index permutation's sign, along any +injective relabelling of the entries. -/ +theorem sortSign_map_listIndexPerm {γ : Type*} [DecidableEq γ] {β : Type} + [LinearOrder β] + (l₁ l₂ : List γ) (h₁ : l₁.Nodup) (h₂ : l₂.Nodup) + (hmem : ∀ x, x ∈ l₁ ↔ x ∈ l₂) (hlen : l₁.length = l₂.length) + (g : γ → β) (hg : (l₁.map g).Nodup) : + sortSign (l₂.map g) = + (Perm.sign (listIndexPerm l₁ l₂ h₁ h₂ hmem hlen) : ℤ) * + sortSign (l₁.map g) := by + set τ := listIndexPerm l₁ l₂ h₁ h₂ hmem hlen + set v : Fin l₁.length → β := fun i => g l₁[i] with hv_def + -- Injectivity of v from hg + have hinj : Function.Injective v := by + intro a b (hab : g l₁[a.val] = g l₁[b.val]) + have hinjon : Set.InjOn g {x | x ∈ l₁} := (List.nodup_map_iff_inj_on h₁).mp + hg + have heq : l₁[a.val] = l₁[b.val] := + hinjon (List.getElem_mem a.isLt) (List.getElem_mem b.isLt) hab + exact Fin.ext (by exact h₁.getElem_inj_iff.mp heq) + -- Rewrite l₁.map g as ofFn v + have hmap₁ : l₁.map g = List.ofFn v := by + exact (List.ofFn_getElem_eq_map l₁ g).symm + -- Rewrite l₂.map g as ofFn (v ∘ τ.symm) + have hmap₂ : l₂.map g = List.ofFn (fun j => v (τ.symm j)) := + map_eq_ofFn_comp_inv l₁ l₂ h₁ h₂ hmem hlen g + -- Apply the main theorem + rw [hmap₂, sortSign_ofFn_comp_perm v hinj τ.symm, Perm.sign_symm, hmap₁] + +/-! ### Composition triangle (sign level) -/ + +/-- The index permutation composes across three lists, so its sign +is multiplicative along a chain. -/ +theorem sign_listIndexPerm_trans {γ : Type*} [DecidableEq γ] + (l₁ l₂ l₃ : List γ) + (h₁ : l₁.Nodup) (h₂ : l₂.Nodup) (h₃ : l₃.Nodup) + (hmem₁₂ : ∀ x, x ∈ l₁ ↔ x ∈ l₂) + (hmem₂₃ : ∀ x, x ∈ l₂ ↔ x ∈ l₃) + (hlen₁₂ : l₁.length = l₂.length) + (hlen₂₃ : l₂.length = l₃.length) : + Perm.sign (listIndexPerm l₁ l₃ h₁ h₃ + (fun x => (hmem₁₂ x).trans (hmem₂₃ x)) (hlen₁₂.trans hlen₂₃)) = + Perm.sign (listIndexPerm l₁ l₂ h₁ h₂ hmem₁₂ hlen₁₂) * + Perm.sign (listIndexPerm l₂ l₃ h₂ h₃ hmem₂₃ hlen₂₃) := by + set τ₁₂ := listIndexPerm l₁ l₂ h₁ h₂ hmem₁₂ hlen₁₂ + set τ₂₃ := listIndexPerm l₂ l₃ h₂ h₃ hmem₂₃ hlen₂₃ + set τ₁₃ := listIndexPerm l₁ l₃ h₁ h₃ (fun x => (hmem₁₂ x).trans (hmem₂₃ x)) + (hlen₁₂.trans hlen₂₃) + -- Conjugate τ₂₃ into Perm (Fin l₁.length) + set τ₂₃' : Perm (Fin l₁.length) := + (finCongr hlen₁₂).symm.permCongr τ₂₃ + -- Show τ₁₃ = τ₂₃' * τ₁₂ by Equiv.ext + suffices h : τ₁₃ = τ₂₃' * τ₁₂ by + rw [h, Perm.sign_mul] + have : Perm.sign τ₂₃' = Perm.sign τ₂₃ := Equiv.Perm.sign_permCongr _ _ + rw [this, mul_comm] + ext i : 1 + -- Both sides, evaluated at i, give the unique index in l₁ of the + -- element l₁[i] in l₃. + simp only [Perm.mul_apply] + -- Unfold τ₂₃' to finCongr ∘ τ₂₃ ∘ finCongr + change τ₁₃ i = (finCongr hlen₁₂).symm (τ₂₃ ((finCongr hlen₁₂) (τ₁₂ i))) + -- Both sides yield l₃[..] = l₁[i]; use nodup of l₃ to equate indices + apply Fin.ext + simp only [finCongr_symm] + have hτ₁₃ := listIndexPerm_getElem l₁ l₃ h₁ h₃ + (fun x => (hmem₁₂ x).trans (hmem₂₃ x)) (hlen₁₂.trans hlen₂₃) i + have hτ₁₂ := listIndexPerm_getElem l₁ l₂ h₁ h₂ hmem₁₂ hlen₁₂ i + have hτ₂₃ := listIndexPerm_getElem l₂ l₃ h₂ h₃ hmem₂₃ hlen₂₃ + (finCongr hlen₁₂ (τ₁₂ i)) + -- l₃ at both positions = l₁[i] + have h3bound₁ : (τ₁₃ i).val < l₃.length := by + have := (τ₁₃ i).isLt; omega + have h3bound₂ : (τ₂₃ (finCongr hlen₁₂ (τ₁₂ i))).val < l₃.length := by + have := (τ₂₃ (finCongr hlen₁₂ (τ₁₂ i))).isLt; omega + have hrhs : l₃[(τ₂₃ (finCongr hlen₁₂ (τ₁₂ i))).val]'h3bound₂ = l₁[i.val] := by + rw [hτ₂₃]; exact hτ₁₂ + exact (h₃.getElem_inj_iff (hi := h3bound₁) (hj := h3bound₂)).mp + (hτ₁₃.trans hrhs.symm) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ListSignPerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ListSignPerm.lean new file mode 100644 index 0000000000..08d10330a8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ListSignPerm.lean @@ -0,0 +1,174 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjacentWord +public import LeanPool.RegtsSevenster.RS.Common.ListSign + +/-! +# Sorting signs under a permutation of positions + +Reordering a duplicate-free tuple multiplies the sorting sign of the +list it spells by the sign of the reordering. The proof reduces to +adjacent transpositions, where the two lists differ by one swap and +the sorting signs by one factor of `−1`. +-/ + +@[expose] public section + +namespace RS + +open Equiv + +/-! ### Splitting `List.ofFn v` at two adjacent positions -/ + +private theorem ofFn_split {α : Type} {m : ℕ} (v : Fin (m + 1) → α) (i : Fin m) + : + List.ofFn v = + (List.ofFn v).take i.val ++ v i.castSucc :: v i.succ :: + (List.ofFn v).drop (i.val + 2) := by + have hi : i.val < (List.ofFn v).length := by simp [List.length_ofFn] + have hi1 : i.val + 1 < (List.ofFn v).length := by simp [List.length_ofFn] + have hg1 : (List.ofFn v)[i.val] = v i.castSucc := + by rw [List.getElem_ofFn]; congr 1 + have hg2 : (List.ofFn v)[i.val + 1] = v i.succ := + by rw [List.getElem_ofFn]; congr 1 + conv_lhs => rw [show List.ofFn v = (List.ofFn v).take i.val ++ (List.ofFn + v).drop i.val from + (List.take_append_drop i.val (List.ofFn v)).symm] + congr 1 + rw [List.drop_eq_getElem_cons hi, hg1, List.drop_eq_getElem_cons hi1, hg2] + +/-! ### `ofFn (v ∘ adjTrans i)` is the swapped split -/ + +private theorem ofFn_adjTrans_split {α : Type} {m : ℕ} (v : Fin (m + 1) → α) (i + : Fin m) : + List.ofFn (v ∘ ⇑(adjTrans i)) = + (List.ofFn v).take i.val ++ v i.succ :: v i.castSucc :: + (List.ofFn v).drop (i.val + 2) := by + have htlen : ((List.ofFn v).take i.val).length = i.val := by + simp [List.length_take, List.length_ofFn]; omega + have fix {k : ℕ} (hk : k < m + 1) (hki : k ≠ i.val) (hki2 : k ≠ i.val + 1) : + adjTrans i (⟨k, hk⟩ : Fin (m + 1)) = ⟨k, hk⟩ := by + simp only [adjTrans, Equiv.swap_apply_def] + split_ifs <;> simp_all [Fin.ext_iff, Fin.val_castSucc, Fin.val_succ] + have at_i (hk : i.val < m + 1) : + adjTrans i (⟨i.val, hk⟩ : Fin (m + 1)) = i.succ := by + have : (⟨i.val, hk⟩ : Fin (m + 1)) = i.castSucc := Fin.ext + (by simp [Fin.val_castSucc]) + rw [this]; exact show adjTrans i i.castSucc = i.succ from by + simp [adjTrans, Equiv.swap_apply_left] + have at_i1 (hk : i.val + 1 < m + 1) : + adjTrans i (⟨i.val + 1, hk⟩ : Fin (m + 1)) = i.castSucc := by + have : (⟨i.val + 1, hk⟩ : Fin (m + 1)) = i.succ := Fin.ext + (by simp [Fin.val_succ]) + rw [this]; exact show adjTrans i i.succ = i.castSucc from by + simp [adjTrans, Equiv.swap_apply_right] + apply List.ext_getElem + · simp only [List.length_ofFn, List.length_append, List.length_cons, + List.length_take, List.length_drop]; omega + · intro k hk1 hk2 + simp only [List.length_ofFn] at hk1 + rw [List.getElem_ofFn] + simp only [Function.comp] + by_cases hk_lt : k < i.val + · rw [fix hk1 (by omega) (by omega)] + rw [List.getElem_append_left (by rw [htlen]; exact hk_lt)] + rw [List.getElem_take, List.getElem_ofFn] + · by_cases hk_eq : k = i.val + · subst hk_eq + rw [at_i hk1] + rw [List.getElem_append_right (by rw [htlen])] + simp only [htlen, Nat.sub_self]; rfl + · by_cases hk_eq2 : k = i.val + 1 + · subst hk_eq2 + rw [at_i1 hk1] + rw [List.getElem_append_right (by rw [htlen]; omega)] + simp only [htlen, show i.val + 1 - i.val = 1 from by omega]; rfl + · have hk_gt : k > i.val + 1 := by omega + rw [fix hk1 (by omega) hk_eq2] + rw [List.getElem_append_right (by rw [htlen]; omega)] + simp only [htlen] + have h1 : ¬(k - i.val = 0) := by omega + have h2 : ¬(k - i.val - 1 = 0) := by omega + rw [List.getElem_cons] + simp only [h1, ↓reduceDIte] + rw [List.getElem_cons] + simp only [h2, ↓reduceDIte] + rw [List.getElem_drop, List.getElem_ofFn] + have heq : k = i.val + 2 + (k - i.val - 1 - 1) := by omega + congr 1; exact Fin.ext heq + +/-! ### The swap step -/ + +private theorem sortSign_ofFn_adjTrans {α : Type} [LinearOrder α] {m : ℕ} + (i : Fin m) (v : Fin (m + 1) → α) (hinj : Function.Injective v) : + sortSign (List.ofFn (v ∘ ⇑(adjTrans i))) = -sortSign (List.ofFn v) := by + have hab : v i.castSucc ≠ v i.succ := by + intro h; exact absurd (hinj h) (Fin.castSucc_lt_succ.ne) + rw [ofFn_adjTrans_split v i] + conv_rhs => rw [ofFn_split v i] + exact sortSign_swap_adjacent _ _ hab + +/-! ### The word lemma: induction on an adjacent-transposition word -/ + +private theorem word_sortSign {α : Type} [LinearOrder α] {m : ℕ} + (w : List (Fin m)) (v : Fin (m + 1) → α) (hinj : Function.Injective v) : + sortSign (List.ofFn (fun i => v ((w.map adjTrans).prod i))) = + (-1 : ℤ) ^ w.length * sortSign (List.ofFn v) := by + induction w generalizing v with + | nil => + simp only [List.map_nil, List.prod_nil, Perm.one_apply, List.length_nil, + pow_zero, one_mul] + | cons j w ih => + simp only [List.map_cons, List.prod_cons, Perm.mul_apply, List.length_cons] + have hinj' : Function.Injective (v ∘ ⇑(adjTrans j)) := hinj.comp + (adjTrans j).injective + have hfun : (fun i => v ((adjTrans j) ((w.map adjTrans).prod i))) = + (fun i => (v ∘ ⇑(adjTrans j)) ((w.map adjTrans).prod i)) := by + ext; rfl + rw [hfun, ih (v ∘ ⇑(adjTrans j)) hinj', sortSign_ofFn_adjTrans j v hinj, + pow_succ] + ring + +/-! ### Sign of adjacent transposition words -/ + +private theorem sign_adjTrans {m : ℕ} (i : Fin m) : + Perm.sign (adjTrans i) = -1 := by + unfold adjTrans; exact Perm.sign_swap (Fin.castSucc_lt_succ.ne) + +private theorem sign_adjWord_prod {m : ℕ} (w : List (Fin m)) : + (Perm.sign ((w.map adjTrans).prod) : ℤ) = (-1 : ℤ) ^ w.length := by + induction w with + | nil => simp [Perm.sign_one, Units.val_one] + | cons j w ih => + simp only [List.map_cons, List.prod_cons, List.length_cons, + Perm.sign_mul, Units.val_mul, sign_adjTrans, pow_succ] + rw [ih]; simp [Units.val_neg, Units.val_one] + +/-! ### Main theorem -/ + +/-- Permuting a duplicate-free tuple multiplies its sorting sign by +the permutation's sign. -/ +theorem sortSign_ofFn_comp_perm {α : Type} [LinearOrder α] {n : ℕ} + (v : Fin n → α) (hinj : Function.Injective v) + (τ : Perm (Fin n)) : + sortSign (List.ofFn (fun i => v (τ i))) = + (Perm.sign τ : ℤ) * sortSign (List.ofFn v) := by + match n with + | 0 => + have : τ = 1 := Subsingleton.elim τ 1 + simp [this, Perm.sign_one, Units.val_one, sortSign] + | m + 1 => + have hw := adjWord_spec τ + have heq : (fun i => v (τ i)) = + (fun i => v (((adjWord τ).map adjTrans).prod i)) := by + ext x; rw [hw] + rw [heq, word_sortSign (adjWord τ) v hinj, ← sign_adjWord_prod (adjWord τ), + hw] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MasterSum.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MasterSum.lean new file mode 100644 index 0000000000..a80c8f9f7d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MasterSum.lean @@ -0,0 +1,77 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapClosed + +/-! +# The master colour sum + +The parameter value as a pure colour-combinatorial sum: the cap +expansion through the closed form, the permutation and cast +transports, and the star-vector coordinates. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open Functor.LaxMonoidal Functor.OplaxMonoidal + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} +variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) +variable (e' : P.ω.obj (SkeinObj.mk 1) ⟶ stdSuperPair k ℓ) + +-- The parameter is rewritten as a colour sum, which +-- unfolds the star vector, the transport and the diagonal cap +-- pairing in a single term. +/-- **The master colour sum**: the parameter value is the +circle factor times the colour sum of the transported star +coordinates against the diagonal cap pairing. -/ +theorem parameter_colour_sum (W : ClosedFragment) + (hee' : (e' ≫ e : P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk 1)) = 𝟙 _) + (hform : + letI := P.braided + SuperVect.Hom.comp + (μ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1) ≫ + P.ω.map (ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) ≫ η P.ω) + (SuperVect.tensorHom e e) = stdForm k ℓ) : + f.val W = circleVal f ^ W.circles * + ∑ c : {c : MixedColouring k ℓ + (edgeCount W + edgeCount W) // c.IsEven}, + ((-1 : ℂ) ^ oddInversions (sortSplitPerm W) + (c.val ∘ finCongr + (degList_sum (starAssignEnum W))) * + ∏ v, starCoord f P e' + ((degList (starAssignEnum W)).get v) + (blockRestrict (degList (starAssignEnum W)) + ((c.val ∘ finCongr + (degList_sum (starAssignEnum W))) ∘ + sortSplitPerm W) v)) * + betaDiag (edgeCount W) c.val := by + rw [parameter_capVal f P e e' W hee'] + congr 1 + refine Eq.trans (capVal_expansion f P e (edgeCount W) _) ?_ + refine Finset.sum_congr rfl (fun c _ => ?_) + rw [capVal_closed f P e hform (edgeCount W) c.val c.prop] + congr 1 + refine Eq.trans (coordOf_cast + (degList_sum (starAssignEnum W)) _ _) ?_ + refine Eq.trans (coordOf_modelPermMap' + (sortSplitPerm W) _ _) ?_ + congr 1 + exact coordOf_modelStarVec f P e' + (degList (starAssignEnum W)) _ + (((isEven_comp_finCongr + (degList_sum (starAssignEnum W)) c.val).mpr + c.prop).comp (sortSplitPerm W)) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelCoord.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelCoord.lean new file mode 100644 index 0000000000..0d677239fd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelCoord.lean @@ -0,0 +1,162 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMerge +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ClosedTransition +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.HRS + +/-! +# Coordinates of the assembled star vector + +The coordinates of the model star vector factor into star +coordinates over the degree blocks: the merge coordinate product +rule threaded through the sum casts and the block enumeration. +-/ + +@[expose] public section + +namespace RS + +variable {k ℓ : ℕ} + +/-- Parity is invariant under an index cast. -/ +theorem isEven_comp_finCongr {n₁ n₂ : ℕ} (h : n₁ = n₂) + (c : MixedColouring k ℓ n₂) : + MixedColouring.IsEven (c ∘ finCongr h) ↔ c.IsEven := by + subst h + exact Iff.rfl + +/-- The head block is the first half through the sum cast. -/ +theorem blockRestrict_cons_head (d : ℕ) (ds : List ℕ) + (c : MixedColouring k ℓ ((d :: ds).sum)) : + blockRestrict (d :: ds) c ⟨0, by simp⟩ = + MixedColouring.firstHalf ((c ∘ finCongr + (List.sum_cons.symm : d + ds.sum = (d :: ds).sum)) : + MixedColouring k ℓ (d + ds.sum)) := by + funext j + exact congrArg c (Fin.ext + (blockSigmaEquiv_cons_zero_val d ds j)) + +/-- The tail blocks are block restrictions of the second half +through the sum cast. -/ +theorem blockRestrict_cons_tail (d : ℕ) (ds : List ℕ) + (c : MixedColouring k ℓ ((d :: ds).sum)) + (v : Fin ds.length) : + blockRestrict (d :: ds) c v.succ = + blockRestrict ds (MixedColouring.secondHalf + ((c ∘ finCongr (List.sum_cons.symm : + d + ds.sum = (d :: ds).sum)) : + MixedColouring k ℓ (d + ds.sum))) v := by + funext j + exact congrArg c (Fin.ext + (blockSigmaEquiv_cons_succ_val d ds v j)) + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable (e' : P.ω.obj (SkeinObj.mk 1) ⟶ stdSuperPair k ℓ) + +-- The coordinate factorisation is proved by +-- recursion on the degree list, carrying the merge equivalence at +-- every step. +/-- **The assembled coordinates factor over the blocks.** -/ +theorem coordOf_modelStarVec : + ∀ (ds : List ℕ) (c : MixedColouring k ℓ ds.sum) + (_hc : c.IsEven), + coordOf (modelStarVec f P e' ds) c = + ∏ v : Fin ds.length, + starCoord f P e' (ds.get v) (blockRestrict ds c v) + | [], c, hc => by + have : IsEmpty (Fin ([] : List ℕ).length) := + inferInstanceAs (IsEmpty (Fin 0)) + rw [show (∏ v : Fin ([] : List ℕ).length, + starCoord f P e' (([] : List ℕ).get v) + (blockRestrict [] c v)) = 1 from + Finset.prod_of_isEmpty _] + unfold coordOf + rw [dite_eq_left hc] + rfl + | d :: ds, c, hc => by + -- Push through the cast. + have hcast : coordOf (modelStarVec f P e' (d :: ds)) c = + coordOf (((powMerge (stdSuperPair k ℓ) d ds.sum) : + SuperVect.Hom _ _).evenMap + (evenPair + (((stdFromOmega f P e' d) : + SuperVect.Hom _ _).evenMap (starVec f P d)) + (modelStarVec f P e' ds))) + (c ∘ finCongr (List.sum_cons.symm : + d + ds.sum = (d :: ds).sum)) := + coordOf_cast (List.sum_cons.symm : + d + ds.sum = (d :: ds).sum) _ c + rw [hcast] + have hc' : MixedColouring.IsEven (c ∘ finCongr + (List.sum_cons.symm : d + ds.sum = (d :: ds).sum)) := + (isEven_comp_finCongr _ c).mpr hc + unfold coordOf + rw [dite_eq_left hc'] + rw [colourMerge_coord d ds.sum _ _ _ hc'] + have hsucc : (∏ v : Fin ((d :: ds).length), + starCoord f P e' ((d :: ds).get v) + (blockRestrict (d :: ds) c v)) = + starCoord f P e' ((d :: ds).get 0) + (blockRestrict (d :: ds) c 0) * + ∏ v : Fin ds.length, + starCoord f P e' ((d :: ds).get v.succ) + (blockRestrict (d :: ds) c v.succ) := + Fin.prod_univ_succ _ + rw [hsucc] + by_cases hfe : MixedColouring.IsEven + (MixedColouring.firstHalf ((c ∘ finCongr + (List.sum_cons.symm : d + ds.sum = (d :: ds).sum)) : + MixedColouring k ℓ (d + ds.sum))) + · rw [dite_eq_left hfe] + -- Head factor is the star coordinate. + rw [show ((colourPowerEquiv k ℓ d).evenEquiv + (((stdFromOmega f P e' d) : + SuperVect.Hom _ _).evenMap (starVec f P d)) + ⟨MixedColouring.firstHalf ((c ∘ finCongr + (List.sum_cons.symm : + d + ds.sum = (d :: ds).sum)) : + MixedColouring k ℓ (d + ds.sum)), hfe⟩) = + starCoord f P e' d (blockRestrict (d :: ds) c + ⟨0, by simp⟩) from by + rw [blockRestrict_cons_head] + unfold starCoord + rw [dite_eq_left hfe]] + -- Tail factor is the induction. + rw [show ((colourPowerEquiv k ℓ ds.sum).evenEquiv + (modelStarVec f P e' ds) + ⟨MixedColouring.secondHalf ((c ∘ finCongr + (List.sum_cons.symm : + d + ds.sum = (d :: ds).sum)) : + MixedColouring k ℓ (d + ds.sum)), _⟩) = + coordOf (modelStarVec f P e' ds) + (MixedColouring.secondHalf ((c ∘ finCongr + (List.sum_cons.symm : + d + ds.sum = (d :: ds).sum)) : + MixedColouring k ℓ (d + ds.sum))) from by + unfold coordOf + rw [dite_eq_left (MixedColouring.secondHalf_isEven _ + hc' hfe)]] + rw [coordOf_modelStarVec ds _ + (MixedColouring.secondHalf_isEven _ hc' hfe)] + refine congrArg₂ (fun a b => a * b) rfl ?_ + refine Finset.prod_congr rfl (fun v _ => ?_) + rw [blockRestrict_cons_tail] + rfl + · rw [dite_eq_right hfe] + have hzero : starCoord f P e' ((d :: ds).get 0) + (blockRestrict (d :: ds) c 0) = 0 := by + rw [show blockRestrict (d :: ds) c + (0 : Fin (ds.length + 1)) = + blockRestrict (d :: ds) c ⟨0, by simp⟩ from rfl] + rw [blockRestrict_cons_head] + exact starCoord_odd f P e' d _ hfe + rw [hzero, zero_mul] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelPermCoord.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelPermCoord.lean new file mode 100644 index 0000000000..31c050c53f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelPermCoord.lean @@ -0,0 +1,109 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourAction +public import LeanPool.RegtsSevenster.RS.Classical.Super.WordSignPerm + +/-! +# The permutation transport in coordinates + +The model permutation map acts on coordinates by the adjacent-word +sign and the permutation reindex. +-/ + +@[expose] public section + +open CategoryTheory + +namespace RS + +variable {k ℓ : ℕ} + +/-- The word of adjacent transpositions composes to its +permutation. -/ +theorem wordPerm_eq_prod {n : ℕ} (w : List (Fin n)) : + wordPerm w = (w.map adjTrans).prod := by + induction w with + | nil => rfl + | cons i w ih => + change _root_.Equiv.swap _ _ * wordPerm w = _ + rw [List.map_cons, List.prod_cons, ih] + rfl + +/-- The adjacent word composes to its permutation. -/ +theorem wordPerm_adjWord {n : ℕ} + (σ : _root_.Equiv.Perm (Fin (n + 1))) : + wordPerm (adjWord σ) = σ := by + rw [wordPerm_eq_prod] + exact adjWord_spec σ + +/-- **The permutation transport in coordinates.** -/ +theorem coordOf_modelPermMap {n : ℕ} + (σ : _root_.Equiv.Perm (Fin (n + 1))) + (v : (superPow (stdSuperPair k ℓ) (n + 1)).even) + (c : MixedColouring k ℓ (n + 1)) : + coordOf (((modelPermMap σ) : + SuperVect.Hom _ _).evenMap v) c = + wordSign (adjWord σ) c * coordOf v (c ∘ σ) := by + by_cases hc : c.IsEven + · rw [show coordOf (((modelPermMap σ) : + SuperVect.Hom _ _).evenMap v) c = + (colourPowerEquiv k ℓ (n + 1)).evenEquiv + (((modelPermMap σ) : + SuperVect.Hom _ _).evenMap v) ⟨c, hc⟩ from by + unfold coordOf; rw [dite_eq_left hc]] + rw [← toColour_apply] + rw [show modelPermMap σ = + powBraidWord (stdSuperPair k ℓ) (adjWord σ) from rfl] + rw [toColour_powBraidWord] + rw [colourSwapWord_evenMap] + rw [wordPerm_adjWord] + rw [show coordOf v (c ∘ σ) = + (colourPowerEquiv k ℓ (n + 1)).evenEquiv v + ⟨c ∘ σ, hc.comp σ⟩ from by + unfold coordOf; rw [dite_eq_left (hc.comp σ)]] + · rw [coordOf_odd _ _ hc] + have hcσ : ¬ MixedColouring.IsEven (c ∘ σ) := fun he => hc + (by + have hcomp := he.comp σ⁻¹ + rw [show (c ∘ σ) ∘ (σ⁻¹ : + _root_.Equiv.Perm (Fin (n + 1))) = c from + funext (fun x => congrArg c + (_root_.Equiv.apply_symm_apply σ x))] at hcomp + exact hcomp) + rw [coordOf_odd _ _ hcσ, mul_zero] + +/-- **The permutation transport in coordinates, arity-uniform +form**: the sign is the odd-inversion sign, valid at every arity +including zero. -/ +theorem coordOf_modelPermMap' {n : ℕ} + (σ : _root_.Equiv.Perm (Fin n)) + (v : (superPow (stdSuperPair k ℓ) n).even) + (c : MixedColouring k ℓ n) : + coordOf (((modelPermMap σ) : + SuperVect.Hom _ _).evenMap v) c = + (-1 : ℂ) ^ oddInversions σ c * coordOf v (c ∘ σ) := by + match n, σ with + | 0, σ => + rw [show σ = (1 : _root_.Equiv.Perm (Fin 0)) from + Subsingleton.elim _ _] + rw [show modelPermMap (1 : _root_.Equiv.Perm (Fin 0)) = + 𝟙 (superPow (stdSuperPair k ℓ) 0) from rfl] + rw [show (((𝟙 (superPow (stdSuperPair k ℓ) 0) : + superPow (stdSuperPair k ℓ) 0 ⟶ _)) : + SuperVect.Hom _ _).evenMap v = v from rfl] + rw [show oddInversions (1 : _root_.Equiv.Perm (Fin 0)) c = + 0 from by simp [oddInversions]] + rw [pow_zero, one_mul] + exact congrArg (coordOf v) (funext (fun x => x.elim0)) + | n + 1, σ => + rw [coordOf_modelPermMap σ v c] + rw [wordSign_eq_oddInversions] + rw [wordPerm_adjWord] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelStarVec.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelStarVec.lean new file mode 100644 index 0000000000..c1fe0287ed --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelStarVec.lean @@ -0,0 +1,146 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PowMerge + +/-! +# The assembled star vector in the model + +The star vectors pull back along the model transport and +assemble by the block merge entirely inside the monoidal powers +of the standard space; transporting forward recovers the +fibre-side assembled vector. This is the form on which the +colouring coordinates evaluate. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open Functor.LaxMonoidal Functor.OplaxMonoidal + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} +variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) +variable (e' : P.ω.obj (SkeinObj.mk 1) ⟶ stdSuperPair k ℓ) + +/-- The assembled star vector, in the model. -/ +noncomputable def modelStarVec : + (ds : List ℕ) → (superPow (stdSuperPair k ℓ) ds.sum).even + | [] => (1 : ℂ) + | d :: ds => + ((eqToHom (congrArg (superPow (stdSuperPair k ℓ)) + (List.sum_cons.symm : d + ds.sum = (d :: ds).sum)) : + superPow (stdSuperPair k ℓ) (d + ds.sum) ⟶ + superPow (stdSuperPair k ℓ) ((d :: ds).sum)) : + SuperVect.Hom _ _).evenMap + (((powMerge (stdSuperPair k ℓ) d ds.sum) : + SuperVect.Hom _ _).evenMap + (evenPair + (((stdFromOmega f P e' d) : + SuperVect.Hom _ _).evenMap (starVec f P d)) + (modelStarVec ds))) + +-- The transport is compared with the assembled star +-- vector by recursion on the degree list, carrying the tensorator +-- at every step. +/-- **The model star vector transports to the assembled star +vector.** -/ +theorem stdToOmega_modelStarVec + (hee' : (e' ≫ e : P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk 1)) = 𝟙 _) : + ∀ ds : List ℕ, + ((stdToOmega f P e ds.sum) : + SuperVect.Hom _ _).evenMap + (modelStarVec f P e' ds) = + omegaStarVec f P ds + | [] => by + let := P.braided + exact congrArg (fun z : (SuperVect.tensorUnit ⟶ + P.ω.obj (SkeinObj.mk 0)) => + (z : SuperVect.Hom _ _).evenMap (1 : ℂ)) + (((Category.comp_id (ε P.ω)).symm).trans + (congrArg (fun w => ε P.ω ≫ w) + (P.ω.map_id (SkeinObj.mk 0)).symm)) + | d :: ds => by + let := P.braided + -- The cast migrates across the transport. + have hcast := stdToOmega_bmc_cast f P e + (List.sum_cons.symm : d + ds.sum = (d :: ds).sum) + have hcast' := congrArg (fun z : + (superPow (stdSuperPair k ℓ) (d + ds.sum) ⟶ + P.ω.obj (SkeinObj.mk ((d :: ds).sum))) => + (z : SuperVect.Hom _ _).evenMap + (((powMerge (stdSuperPair k ℓ) d ds.sum) : + SuperVect.Hom _ _).evenMap + (evenPair + (((stdFromOmega f P e' d) : + SuperVect.Hom _ _).evenMap (starVec f P d)) + (modelStarVec f P e' ds)))) hcast + refine Eq.trans (Eq.trans ?_ hcast'.symm) ?_ + · rfl + · -- Now push the merge through the block transport. + have hmerge := stdToOmega_merge f P e d ds.sum + have hmerge' := congrArg (fun z : + (superPow (stdSuperPair k ℓ) d ⊗ + superPow (stdSuperPair k ℓ) ds.sum ⟶ + P.ω.obj (SkeinObj.mk (d + ds.sum))) => + (P.ω.map (bundleMapClass f (finCongr + (List.sum_cons.symm : + d + ds.sum = (d :: ds).sum)))).evenMap + ((z : SuperVect.Hom _ _).evenMap + (evenPair + (((stdFromOmega f P e' d) : + SuperVect.Hom _ _).evenMap (starVec f P d)) + (modelStarVec f P e' ds)))) hmerge + refine Eq.trans (Eq.trans ?_ hmerge'.symm) ?_ + · rfl + · -- Evaluate the tensor on the even pair, cancel the + -- strand inverse, and use the induction. + change (P.ω.map (bundleMapClass f (finCongr + (List.sum_cons.symm : + d + ds.sum = (d :: ds).sum)))).evenMap + (((μ P.ω (SkeinObj.mk d) (SkeinObj.mk ds.sum)) : + SuperVect.Hom _ _).evenMap + (((stdToOmega f P e d ⊗ₘ + stdToOmega f P e ds.sum) : + SuperVect.Hom _ _).evenMap + (evenPair + (((stdFromOmega f P e' d) : + SuperVect.Hom _ _).evenMap (starVec f P d)) + (modelStarVec f P e' ds)))) = _ + rw [show ((stdToOmega f P e d ⊗ₘ + stdToOmega f P e ds.sum) : + SuperVect.Hom _ _).evenMap + (evenPair + (((stdFromOmega f P e' d) : + SuperVect.Hom _ _).evenMap (starVec f P d)) + (modelStarVec f P e' ds)) = + evenPair + ((stdToOmega f P e d : SuperVect.Hom _ _).evenMap + (((stdFromOmega f P e' d) : + SuperVect.Hom _ _).evenMap (starVec f P d))) + ((stdToOmega f P e ds.sum : + SuperVect.Hom _ _).evenMap + (modelStarVec f P e' ds)) from + tensorHom_evenPair _ _ _ _] + rw [show (stdToOmega f P e d : + SuperVect.Hom _ _).evenMap + (((stdFromOmega f P e' d) : + SuperVect.Hom _ _).evenMap (starVec f P d)) = + starVec f P d from + congrArg (fun z : (P.ω.obj (SkeinObj.mk d) ⟶ + P.ω.obj (SkeinObj.mk d)) => + (z : SuperVect.Hom _ _).evenMap (starVec f P d)) + (stdFromOmega_stdToOmega f P e e' hee' d)] + rw [stdToOmega_modelStarVec hee' ds] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MultiStar.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MultiStar.lean new file mode 100644 index 0000000000..1780f695c2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MultiStar.lean @@ -0,0 +1,98 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordInterface + +/-! +# The multi-star form of the explosion + +The star union of a closed fragment is a *multi-star*: a family +of pendant edges indexed by `Fin (2m)`, each attached to a vertex +by an assignment map. This is the bridge between the explosion +machinery and the vertex-star factorization. +-/ + +@[expose] public section + +namespace RS + +/-- A multi-star: `n` pendant edges with a vertex assignment and +a free-circle count. -/ +def multiStar {V : Type} [Fintype V] {n : ℕ} + (assign : Fin n → V) (c : ℕ) : Fragment (Fin n) where + Flag := Fin n ⊕ Fin n + Vertex := V + attach := fun g => match g with + | Sum.inl i => Sum.inl (assign i) + | Sum.inr i => Sum.inr i + pairing := fun g => match g with + | Sum.inl i => Sum.inr i + | Sum.inr i => Sum.inl i + pairing_invol := fun g => by rcases g with i | i <;> rfl + pairing_ne := fun g => by rcases g with i | i <;> simp + boundaryFlag := Sum.inr + attach_boundaryFlag := fun _ => rfl + eq_boundaryFlag := fun ℓ g h => by + rcases g with i | i + · exact absurd h (by simp) + · exact congrArg Sum.inr (Sum.inr.inj h) + circles := c + +/-- The inner-flag enumeration of the star union: original flags +through the star enumeration. -/ +noncomputable def starFlagEnum (W : ClosedFragment) : + W.Flag ≃ Fin (edgeCount W + edgeCount W) := + (_root_.Equiv.subtypeUnivEquiv + (fun f => Finset.mem_univ f)).symm.trans (starEnum W) + +/-- The vertex assignment of the star union: each slot's original +flag sits at its vertex. -/ +noncomputable def starAssign (W : ClosedFragment) : + Fin (edgeCount W + edgeCount W) → W.Vertex := + fun i => ClosedFragment.vertexOf W ((starFlagEnum W).symm i) + +/-- **The star union is a multi-star**: the explosion at the full +cut, enumerated, is the family of pendant edges over the original +flags with their vertex assignment. -/ +noncomputable def starUnionMultiStar (W : ClosedFragment) : + (starUnion W).Equiv + (multiStar (starAssign W) W.circles) where + flagEquiv := + _root_.Equiv.sumCongr (starFlagEnum W) (starEnum W) + vertexEquiv := _root_.Equiv.refl W.Vertex + attach_comm := fun g => by + rcases g with fo | fc + · change Sum.inl (starAssign W (starFlagEnum W fo)) = + (Sum.inl (ClosedFragment.vertexOf W fo) : + W.Vertex ⊕ Fin (edgeCount W + edgeCount W)).map + (_root_.Equiv.refl W.Vertex) id + refine congrArg Sum.inl ?_ + change ClosedFragment.vertexOf W + ((starFlagEnum W).symm (starFlagEnum W fo)) = _ + rw [(starFlagEnum W).symm_apply_apply] + rfl + · change Sum.inr (starEnum W fc) = + (Sum.inr (starEnum W fc) : + W.Vertex ⊕ Fin (edgeCount W + edgeCount W)).map + (_root_.Equiv.refl W.Vertex) id + rfl + pairing_comm := fun g => by + rcases g with fo | fc + · have hp : (starUnion W).pairing (Sum.inl fo) = + Sum.inr ⟨fo, Finset.mem_univ fo⟩ := + dite_eq_left (Finset.mem_univ fo) + rw [hp] + change Sum.inr (starEnum W ⟨fo, Finset.mem_univ fo⟩) = + Sum.inr (starFlagEnum W fo) + rfl + · change Sum.inl (starFlagEnum W fc.val) = + Sum.inl ((starFlagEnum W).symm.symm fc.val) + rfl + circles_eq := rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFDef.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFDef.lean new file mode 100644 index 0000000000..385e2b8bfa --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFDef.lean @@ -0,0 +1,163 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockCanon + +/-! +# The h-generic normal form + +The master-sum analogue where an arbitrary mixed functional `h` is +evaluated at the colour-data extractors of the sorted blocks: the +per-vertex factor carries a Nodup guard mirroring `evalOdd`. + +This is the first stage of discharging the Eulerian-independence +interface: the normal form is manifestly independent of the +transition system and orientation. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {k ℓ : ℕ} + +/-! ## The h-generic master summand -/ + +-- The definition names the sorted colouring, its +-- block restrictions and their odd lists, so the whole star +-- enumeration elaborates here. +open Classical in +/-- The h-generic master summand: mirrors `masterSummand` but +replaces `starCoord` with the `h`-evaluation at the block's +colour-data extractors, guarded by the Nodup condition. -/ +noncomputable def hMaster (h : MixedFunctional k ℓ) + (W : ClosedFragment) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) : ℂ := + ((-1 : ℂ) ^ oddInversions (sortSplitPerm W) + (c ∘ finCongr (degList_sum (starAssignEnum W))) * + ∏ v, (if (oddListOf (blockRestrict + (degList (starAssignEnum W)) + (((c ∘ finCongr (degList_sum (starAssignEnum W))) ∘ + sortSplitPerm W)) v)).Nodup then + (sortSign (oddListOf (blockRestrict + (degList (starAssignEnum W)) + (((c ∘ finCongr (degList_sum (starAssignEnum W))) ∘ + sortSplitPerm W)) v)) : ℂ) * + h (evenMultisetOf (blockRestrict + (degList (starAssignEnum W)) + (((c ∘ finCongr (degList_sum (starAssignEnum W))) ∘ + sortSplitPerm W)) v)) + (oddFinsetOf (blockRestrict + (degList (starAssignEnum W)) + (((c ∘ finCongr (degList_sum + (starAssignEnum W))) ∘ sortSplitPerm W)) v)) + else 0)) * + betaDiag (edgeCount W) c + +/-! ## Per-vertex value lemmas -/ + +-- The block factor is matched with the vertex +-- factor, unfolding the sorted colouring and its restriction. +open Classical in +/-- **The per-vertex value** (duplicate-free case): the h-generic +block factor equals the block sorting sign times the +sign-normalised Definition 5 vertex factor. -/ +theorem hMaster_vertex_nodup (h : MixedFunctional k ℓ) + (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) + (ψ : F.EvenColouring k) (φ : F.OddColouring ℓ) + (v : Fin (ds W).length) + (hnd : (F.oddListAt o φ (blockVertex W v)).Nodup) : + (if (oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v)).Nodup then + (sortSign (oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v)) : ℂ) * + h (evenMultisetOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v)) + (oddFinsetOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v)) + else 0) = + (sortSign (oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v)) : ℂ) * + ((sortSign (F.oddListAt o φ (blockVertex W v)) : ℂ) * + h.evalOdd (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v))) := by + have hnd_b : (oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v)).Nodup := + (oddListOf_blockRestrict_nodup_iff W F o ψ φ v).mpr hnd + rw [ite_eq_left hnd_b] + rw [evenMultisetOf_blockRestrict W F o ψ φ v] + rw [oddFinsetOf_blockRestrict W F o ψ φ v] + rw [MixedFunctional.evalOdd, ite_eq_left hnd] + set A := (sortSign (oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v)) : ℂ) + set B := (sortSign (F.oddListAt o φ (blockVertex W v)) : ℂ) + set hval := h (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v)).toFinset + have hB : B * B = 1 := sortSign_sq _ + calc A * hval = A * ((B * B) * hval) := by rw [hB, one_mul] + _ = A * (B * (B * hval)) := by ring + +-- As for the duplicate-free case, on the vanishing branch. +open Classical in +/-- **The per-vertex vanishing** (repeated case): a repeated odd +value kills the h-generic block factor. -/ +theorem hMaster_vertex_not_nodup (h : MixedFunctional k ℓ) + (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) + (ψ : F.EvenColouring k) (φ : F.OddColouring ℓ) + (v : Fin (ds W).length) + (hnd : ¬ (F.oddListAt o φ (blockVertex W v)).Nodup) : + (if (oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v)).Nodup then + (sortSign (oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v)) : ℂ) * + h (evenMultisetOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v)) + (oddFinsetOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v)) + else 0) = 0 := by + have hnd_b : ¬ (oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v)).Nodup := + fun hn => hnd + ((oddListOf_blockRestrict_nodup_iff W F o ψ φ v).mp hn) + exact ite_eq_right hnd_b + +/-! ## The normal form -/ + +open Classical in +/-- The h-generic normal form for the Definition 5 summand: +the sum over even/odd colourings of the h-generic master +summand at the data colouring. -/ +noncomputable def defFiveNF (h : MixedFunctional k ℓ) + (W : ClosedFragment) (F : EdgeSubset W) : ℂ := + ∑ ψ : F.EvenColouring k, ∑ φ : F.OddColouring ℓ, + hMaster h W (colouringOf W F ψ φ) + +open Classical in +/-- **The flip-reindex step**: the normal form equals the sum +over the flipped data colouring at any orientation. -/ +theorem defFiveNF_eq_flip (h : MixedFunctional k ℓ) + (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) : + defFiveNF h W F = ∑ ψ, ∑ φ, + hMaster h W (colouringOfFlip W F o ψ φ) := by + unfold defFiveNF + refine Finset.sum_congr rfl (fun ψ _ => ?_) + set T := outRepSet W F o + set hTc := outRepSet_pairing_mem W F o + have heq : ∀ φ : F.OddColouring ℓ, + hMaster h W (colouringOfFlip W F o ψ φ) = + hMaster h W (colouringOf W F ψ + (EdgeSubset.OddColouring.flip F T hTc φ)) := fun _ => rfl + simp_rw [heq] + exact (EdgeSubset.OddColouring.sum_flip F T hTc _).symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFValue.lean new file mode 100644 index 0000000000..0d4503546d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFValue.lean @@ -0,0 +1,265 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoreParity +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFDef + +/-! +# The h-generic value identity and Definition 5 normal-form theorem + +For a closed fragment, an arbitrary mixed functional's Definition 5 +summand equals the (κ, o)-free normal form — the engine of Eulerian +independence. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {k ℓ : ℕ} + +/-! ## The h-generic value identity -/ + +-- The master summand of the flipped data colouring +-- is expanded to the vertex product, so the sort, the flip and the +-- circuit count all unfold together. +/-- **The h-generic value identity**: the h-generic master summand of +the flipped data colouring equals the circuit sign times the +vertex product of oddSign times evalOdd. -/ +theorem hMaster_colouringOfFlip (h : MixedFunctional k ℓ) + (W : ClosedFragment) (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) (ψ : F.EvenColouring k) (φ : F.OddColouring ℓ) : + hMaster h W (colouringOfFlip W F o ψ φ) = + ((-1 : ℂ) ^ κ.circuitCount) * + ∏ v : W.Vertex, ((F.oddSignAt o φ v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) (F.oddListAt o φ v)) := by + have hmaster : hMaster h W (colouringOfFlip W F o ψ φ) = + ((-1 : ℂ) ^ oddInversions (sortSplitPerm W) + ((colouringOfFlip W F o ψ φ) ∘ + finCongr (degList_sum (starAssignEnum W))) * + ∏ v, (if (oddListOf (blockRestrict + (degList (starAssignEnum W)) + (((colouringOfFlip W F o ψ φ) ∘ finCongr + (degList_sum (starAssignEnum W))) ∘ + sortSplitPerm W) v)).Nodup then + (sortSign (oddListOf (blockRestrict + (degList (starAssignEnum W)) + (((colouringOfFlip W F o ψ φ) ∘ finCongr + (degList_sum (starAssignEnum W))) ∘ + sortSplitPerm W) v)) : ℂ) * + h (evenMultisetOf (blockRestrict + (degList (starAssignEnum W)) + (((colouringOfFlip W F o ψ φ) ∘ finCongr + (degList_sum (starAssignEnum W))) ∘ + sortSplitPerm W) v)) + (oddFinsetOf (blockRestrict + (degList (starAssignEnum W)) + (((colouringOfFlip W F o ψ φ) ∘ finCongr + (degList_sum (starAssignEnum W))) ∘ + sortSplitPerm W) v)) + else 0)) * + betaDiag (edgeCount W) (colouringOfFlip W F o ψ φ) := rfl + rw [hmaster] + rw [show oddInversions (sortSplitPerm W) + ((colouringOfFlip W F o ψ φ) ∘ + finCongr (degList_sum (starAssignEnum W))) = + patternOddInv W F from oddInversions_colouringOf W F ψ _] + rw [betaDiag_colouringOfFlip W F o ψ φ] + rw [prod_blockVertex W (fun vtx => + (F.oddSignAt o φ vtx : ℂ) * + h.evalOdd (F.evenColoursAt ψ vtx) + (F.oddListAt o φ vtx))] + rw [prod_blockVertex W (fun vtx => + ((F.oddSignAt o φ vtx : ℤ) : ℂ))] + -- ═══════ EVERY BLOCK'S ODD LIST IS DUPLICATE-FREE ═══════ + -- Then each block factor is its sorting sign times the vertex + -- factor, and the grand parity collects the four sign families. + by_cases hnd : ∀ v : Fin (ds W).length, + (F.oddListAt o φ (blockVertex W v)).Nodup + · rw [Finset.prod_congr rfl (fun v _ => + hMaster_vertex_nodup h W F o ψ φ v (hnd v))] + have hgp := grand_parity W F o ψ φ hnd + have hsplitL : (∏ v : Fin (ds W).length, + ((sortSign (oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v)) : ℂ) * + ((sortSign (F.oddListAt o φ + (blockVertex W v)) : ℂ) * + h.evalOdd + (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v))))) = + (∏ v : Fin (ds W).length, + ((sortSign (oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v)) : ℂ) * + (sortSign (F.oddListAt o φ + (blockVertex W v)) : ℂ))) * + ∏ v : Fin (ds W).length, + h.evalOdd + (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v)) := by + rw [← Finset.prod_mul_distrib] + exact Finset.prod_congr rfl (fun v _ => by ring) + have hsplitR : (∏ v : Fin (ds W).length, + ((F.oddSignAt o φ (blockVertex W v) : ℂ) * + h.evalOdd + (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v)))) = + (∏ v : Fin (ds W).length, + ((F.oddSignAt o φ (blockVertex W v) : ℤ) : ℂ)) * + ∏ v : Fin (ds W).length, + h.evalOdd + (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v)) := by + rw [← Finset.prod_mul_distrib] + calc ((-1 : ℂ) ^ patternOddInv W F * + (∏ v : Fin (ds W).length, + ((sortSign (oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) + v)) : ℂ) * + ((sortSign (F.oddListAt o φ + (blockVertex W v)) : ℂ) * + h.evalOdd + (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v)))))) * + ((-1 : ℂ) ^ (Finset.univ.filter + (fun p : Fin (edgeCount W) × Fin (edgeCount W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ + p.2 ∈ edgeIndexSet W F)).card * + (-1 : ℂ) ^ inRepCount W F o * + ∏ v : Fin (ds W).length, + ((F.oddSignAt o φ (blockVertex W v) : ℤ) : ℂ)) + = (((-1 : ℂ) ^ patternOddInv W F) * + ((-1 : ℂ) ^ (Finset.univ.filter + (fun p : Fin (edgeCount W) × + Fin (edgeCount W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ + p.2 ∈ edgeIndexSet W F)).card * + (-1 : ℂ) ^ inRepCount W F o) * + ∏ v : Fin (ds W).length, + ((sortSign (oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) + v)) : ℂ) * + (sortSign (F.oddListAt o φ + (blockVertex W v)) : ℂ))) * + ((∏ v : Fin (ds W).length, + ((F.oddSignAt o φ (blockVertex W v) : ℤ) : ℂ)) * + ∏ v : Fin (ds W).length, + h.evalOdd + (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v))) := by + rw [hsplitL] + ring + _ = ((-1 : ℂ) ^ κ.circuitCount) * + ((∏ v : Fin (ds W).length, + ((F.oddSignAt o φ (blockVertex W v) : ℤ) : ℂ)) * + ∏ v : Fin (ds W).length, + h.evalOdd + (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v))) := by + rw [hgp] + _ = ((-1 : ℂ) ^ κ.circuitCount) * + ∏ v : Fin (ds W).length, + ((F.oddSignAt o φ (blockVertex W v) : ℂ) * + h.evalOdd + (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v))) := by + rw [← hsplitR] + -- ═══════ SOME BLOCK REPEATS AN ODD VALUE ═══════ + -- That block's factor is zero, and so is the vertex product. + · simp only [not_forall] at hnd + obtain ⟨v₀, hv₀⟩ := hnd + have hL0 : (∏ v, (if (oddListOf (blockRestrict + (degList (starAssignEnum W)) + (((colouringOfFlip W F o ψ φ ∘ finCongr + (degList_sum (starAssignEnum W))) ∘ + sortSplitPerm W)) v)).Nodup then + (sortSign (oddListOf (blockRestrict + (degList (starAssignEnum W)) + (((colouringOfFlip W F o ψ φ ∘ finCongr + (degList_sum (starAssignEnum W))) ∘ + sortSplitPerm W)) v)) : ℂ) * + h (evenMultisetOf (blockRestrict + (degList (starAssignEnum W)) + (((colouringOfFlip W F o ψ φ ∘ finCongr + (degList_sum (starAssignEnum W))) ∘ + sortSplitPerm W)) v)) + (oddFinsetOf (blockRestrict + (degList (starAssignEnum W)) + (((colouringOfFlip W F o ψ φ ∘ finCongr + (degList_sum (starAssignEnum W))) ∘ + sortSplitPerm W)) v)) + else 0)) = 0 := + Finset.prod_eq_zero (Finset.mem_univ v₀) + (hMaster_vertex_not_nodup h W F o ψ φ v₀ hv₀) + have hR0 : (∏ v : Fin (ds W).length, + ((F.oddSignAt o φ (blockVertex W v) : ℂ) * + h.evalOdd + (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v)))) = 0 := + Finset.prod_eq_zero (Finset.mem_univ v₀) + (by rw [MixedFunctional.evalOdd_of_not_nodup _ _ + hv₀, mul_zero]) + rw [hL0, hR0] + ring + +/-! ## The normal-form theorem -/ + +/-- **The normal-form theorem**: the mixed summand of any transition +data equals the (κ, o)-free normal form `defFiveNF`. -/ +theorem mixedSummand_eq_nf (h : MixedFunctional k ℓ) + (W : ClosedFragment) (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) : + F.mixedSummand h o = defFiveNF h W F := by + unfold EdgeSubset.mixedSummand + rw [defFiveNF_eq_flip h W F o] + rw [Finset.sum_congr rfl (fun ψ _ => + Finset.sum_congr rfl (fun φ _ => + hMaster_colouringOfFlip h W F o ψ φ))] + rw [show (∑ ψ : F.EvenColouring k, + ∑ φ : F.OddColouring ℓ, + ((-1 : ℂ) ^ κ.circuitCount) * + ∏ v : W.Vertex, + ((F.oddSignAt o φ v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) + (F.oddListAt o φ v))) = + ((-1 : ℂ) ^ κ.circuitCount) * + ∑ ψ : F.EvenColouring k, + ∑ φ : F.OddColouring ℓ, + ∏ v : W.Vertex, + ((F.oddSignAt o φ v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) + (F.oddListAt o φ v)) from by + rw [Finset.mul_sum] + exact Finset.sum_congr rfl (fun ψ _ => + (Finset.mul_sum _ _ _).symm)] + +/-! ## Closed-fragment Eulerian independence -/ + +/-- **Closed-fragment Eulerian independence**: the Definition 5 +summand of a closed fragment's edge subset does not depend on the +transition system and orientation. -/ +theorem eulerian_independence_closed + (W : ClosedFragment) (F : EdgeSubset W) (h : MixedFunctional k ℓ) + {κ κ' : F.TransitionSystem} (o : κ.Orientation) (o' : κ'.Orientation) : + F.mixedSummand h o = F.mixedSummand h o' := + (mixedSummand_eq_nf h W F o).trans (mixedSummand_eq_nf h W F o').symm + +/-! ## The choice-free value lemma -/ + +/-- **The choice-free value lemma**: under any concrete transition +data, the choice-based `mixedValue` equals the `mixedSummand`. -/ +theorem mixedValue_eq_summand_closed + (W : ClosedFragment) (F : EdgeSubset W) (h : MixedFunctional k ℓ) + {κ : F.TransitionSystem} (o : κ.Orientation) : + F.mixedValue h = F.mixedSummand h o := by + have hne : Nonempty ((κ' : F.TransitionSystem) × κ'.Orientation) := ⟨⟨κ, o⟩⟩ + rw [EdgeSubset.mixedValue, dite_eq_left hne] + exact eulerian_independence_closed W F h _ o + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddFlip.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddFlip.lean new file mode 100644 index 0000000000..9e4d137516 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddFlip.lean @@ -0,0 +1,100 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition + +/-! +# Flipping an odd colouring + +Reversing the odd colouring at a chosen edge is an involution of the +colourings, so summing a value over the colourings is invariant +under it — the reindexing the circuit-sign computation uses. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {α : Type} {W : Fragment α} (F : EdgeSubset W) {ℓ : ℕ} + +open Classical in +/-- Flip an odd colouring on a pairing-closed set of flags: apply `oddPartner` +to every colour indexed by a flag in `T`, leave the rest unchanged. -/ +noncomputable def EdgeSubset.OddColouring.flip + (T : Finset W.Flag) (hT : ∀ g ∈ T, W.pairing g ∈ T) + (φ : F.OddColouring ℓ) : F.OddColouring ℓ := + ⟨fun f => if f.val ∈ T then oddPartner ℓ (φ.val f) else φ.val f, + fun f => by + by_cases h : f.val ∈ T + · have hpair : W.pairing f.val ∈ T := hT f.val h + simp only [hpair, h, ite_true] + exact congrArg (oddPartner ℓ) (φ.prop f) + · have hpair : W.pairing f.val ∉ T := by + intro hmem + have := hT _ hmem + rw [W.pairing_invol] at this + exact h this + simp only [hpair, h, ite_false] + exact φ.prop f⟩ + +open Classical in +/-- Flipping twice is the identity. -/ +theorem EdgeSubset.OddColouring.flip_flip + (T : Finset W.Flag) (hT : ∀ g ∈ T, W.pairing g ∈ T) + (φ : F.OddColouring ℓ) : + EdgeSubset.OddColouring.flip F T hT (EdgeSubset.OddColouring.flip F T hT φ) + = φ := by + apply Subtype.ext + funext f + simp only [EdgeSubset.OddColouring.flip] + by_cases h : f.val ∈ T + · simp only [h, ite_true, oddPartner_invol] + · simp only [h, ite_false] + +open Classical in +/-- The flip as a self-equivalence on odd colourings. -/ +noncomputable def EdgeSubset.OddColouring.flipEquiv + (T : Finset W.Flag) (hT : ∀ g ∈ T, W.pairing g ∈ T) : + F.OddColouring ℓ ≃ F.OddColouring ℓ where + toFun := EdgeSubset.OddColouring.flip F T hT + invFun := EdgeSubset.OddColouring.flip F T hT + left_inv := EdgeSubset.OddColouring.flip_flip F T hT + right_inv := EdgeSubset.OddColouring.flip_flip F T hT + +open Classical in +/-- Summing over flipped colourings equals summing over the originals. -/ +theorem EdgeSubset.OddColouring.sum_flip + (T : Finset W.Flag) (hT : ∀ g ∈ T, W.pairing g ∈ T) + (g : F.OddColouring ℓ → ℂ) : + (∑ φ : F.OddColouring ℓ, g (EdgeSubset.OddColouring.flip F T hT φ)) = + ∑ φ : F.OddColouring ℓ, g φ := + Equiv.sum_comp (EdgeSubset.OddColouring.flipEquiv F T hT) g + +open Classical in +/-- The value of `flip` at a flag in `T`. -/ +theorem EdgeSubset.OddColouring.flip_val_mem + (T : Finset W.Flag) (hT : ∀ g ∈ T, W.pairing g ∈ T) + (φ : F.OddColouring ℓ) (f : {f : W.Flag // f ∈ F.flags}) + (h : f.val ∈ T) : + (EdgeSubset.OddColouring.flip F T hT φ).val f = oddPartner ℓ (φ.val f) := by + change (if f.val ∈ T then oddPartner ℓ (φ.val f) else φ.val f) = _ + exact ite_eq_left h + +open Classical in +/-- The value of `flip` at a flag not in `T`. -/ +theorem EdgeSubset.OddColouring.flip_val_not_mem + (T : Finset W.Flag) (hT : ∀ g ∈ T, W.pairing g ∈ T) + (φ : F.OddColouring ℓ) (f : {f : W.Flag // f ∈ F.flags}) + (h : f.val ∉ T) : + (EdgeSubset.OddColouring.flip F T hT φ).val f = φ.val f := by + change (if f.val ∈ T then oddPartner ℓ (φ.val f) else φ.val f) = _ + exact ite_eq_right h + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddListMultiset.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddListMultiset.lean new file mode 100644 index 0000000000..c0373f6ba9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddListMultiset.lean @@ -0,0 +1,282 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists + +/-! +# A vertex's odd list, as a multiset + +The odd list at a vertex is built by walking the flags there and +recording each one's per-flag odd value. Read as a multiset it is +simply the image of those flags under that value, with the walking +order forgotten — the form in which two orientations' lists can be +compared, since only the order distinguishes them. +-/ + +@[expose] public section + +namespace RS + +open Finset +variable {α : Type} {W : Fragment α} {F : EdgeSubset W} {ℓ : ℕ} {κ : + F.TransitionSystem} + +/-! ### Helper: bind of a two-element function splits into two maps -/ + +private theorem multiset_bind_pair {β γ : Type} (m : Multiset β) + (a b : β → γ) : + m.bind (fun x => ({a x} : Multiset γ) + {b x}) = + m.map a + m.map b := by + induction m using Multiset.induction_on with + | empty => simp + | cons x s ih => + rw [Multiset.cons_bind, ih, Multiset.map_cons, Multiset.map_cons, + show a x ::ₘ Multiset.map a s = ({a x} : Multiset _) + Multiset.map a s + from + (Multiset.singleton_add _ _).symm, + show b x ::ₘ Multiset.map b s = ({b x} : Multiset _) + Multiset.map b s + from + (Multiset.singleton_add _ _).symm] + ac_rfl + +/-! ### The attachWith–sort multiset equals the finset filter val -/ + +open scoped Classical in +/-- The attachWith of the sorted list of a finset filter, as a multiset, +equals the val of `univ.filter` on the subtype. -/ +theorem attachWith_sort_eq_filter_val + (o : κ.Orientation) (v : W.Vertex) : + (↑((F.inFlagsAt o v).attachWith (· ∈ F.flags) + (fun _ hf => F.mem_of_mem_inFlagsAt hf)) : + Multiset {f : W.Flag // f ∈ F.flags}) = + (Finset.univ.filter (fun f : {f : W.Flag // f ∈ F.flags} => + W.attach f.val = Sum.inl v ∧ o.isOut f.val = false)).val := by + let := W.flagOrder + let := Classical.dec + -- Both sides are nodup multisets with the same members; use Nodup.ext. + have h_nd_r : (Finset.univ.filter (fun f : {f : W.Flag // f ∈ F.flags} => + W.attach f.val = Sum.inl v ∧ o.isOut f.val = false)).val.Nodup := + (Finset.univ.filter _).nodup + have h_nd_l : ((↑((F.inFlagsAt o v).attachWith (· ∈ F.flags) + (fun _ hf => F.mem_of_mem_inFlagsAt hf)) : + Multiset {f : W.Flag // f ∈ F.flags})).Nodup := by + rw [Multiset.coe_nodup] + unfold EdgeSubset.inFlagsAt + apply List.Nodup.pmap (fun _ _ _ _ h => Subtype.mk.inj h) + exact Finset.sort_nodup _ (· ≤ ·) + refine (h_nd_l.ext ?_ |>.mpr ?_) + · convert h_nd_r + · intro ⟨f, hf⟩ + rw [Multiset.mem_coe, List.mem_attachWith] + simp only [Finset.mem_val, Finset.mem_filter, Finset.mem_univ, true_and] + constructor + · intro hfin + have : f ∈ F.flags.filter (fun f => W.attach f = Sum.inl v ∧ o.isOut f = + false) := by + convert (Finset.mem_sort (· ≤ ·)).mp hfin + exact (Finset.mem_filter.mp this).2 + · intro hmem + rw [show F.inFlagsAt o v = (F.flags.filter + (fun f => W.attach f = Sum.inl v ∧ o.isOut f = false)).sort (· ≤ ·) + from rfl] + have hfilt : f ∈ F.flags.filter + (fun f => W.attach f = Sum.inl v ∧ o.isOut f = false) := + Finset.mem_filter.mpr ⟨hf, hmem⟩ + convert (Finset.mem_sort (· ≤ ·)).mpr hfilt + +/-! ### The match bijection between incoming and outgoing flags -/ + +/-- The match embedding on the flag subtype. -/ +private noncomputable def matchEmb (κ : F.TransitionSystem) : + {f : W.Flag // f ∈ F.flags} ↪ {f : W.Flag // f ∈ F.flags} where + toFun f := ⟨κ.match_ f.val, κ.match_mem _ f.prop⟩ + inj' := fun ⟨a, ha⟩ ⟨b, hb⟩ h => by + simp only [Subtype.mk.injEq] at h ⊢ + have h1 := κ.match_invol a ha + have h2 := κ.match_invol b hb + calc a = κ.match_ (κ.match_ a) := h1.symm + _ = κ.match_ (κ.match_ b) := congrArg κ.match_ h + _ = b := h2 + +/-- match maps incoming-at-v flags to outgoing-at-v flags. -/ +private theorem match_maps_in_to_out (o : κ.Orientation) (v : W.Vertex) + (f : {f : W.Flag // f ∈ F.flags}) + (hf : W.attach f.val = Sum.inl v ∧ o.isOut f.val = false) : + W.attach (κ.match_ f.val) = Sum.inl v ∧ + o.isOut (κ.match_ f.val) = true := by + exact ⟨κ.match_vertex f.val f.prop v hf.1, + by rw [o.match_flip f.val f.prop, hf.2]; rfl⟩ + +/-- match maps outgoing-at-v flags to incoming-at-v flags. -/ +private theorem match_maps_out_to_in (o : κ.Orientation) (v : W.Vertex) + (f : {f : W.Flag // f ∈ F.flags}) + (hf : W.attach f.val = Sum.inl v ∧ o.isOut f.val = true) : + W.attach (κ.match_ f.val) = Sum.inl v ∧ + o.isOut (κ.match_ f.val) = false := by + exact ⟨κ.match_vertex f.val f.prop v hf.1, + by rw [o.match_flip f.val f.prop, hf.2]; rfl⟩ + +open scoped Classical in +/-- The match embedding maps the incoming-at-v finset to the outgoing-at-v +finset. -/ +private theorem match_image_in_eq_out (o : κ.Orientation) (v : W.Vertex) : + (Finset.univ.filter (fun f : {f : W.Flag // f ∈ F.flags} => + W.attach f.val = Sum.inl v ∧ o.isOut f.val = false)).map + (matchEmb κ) = + Finset.univ.filter (fun f : {f : W.Flag // f ∈ F.flags} => + W.attach f.val = Sum.inl v ∧ o.isOut f.val = true) := by + ext ⟨g, hg⟩ + simp only [Finset.mem_map, Finset.mem_filter, Finset.mem_univ, true_and] + constructor + · rintro ⟨⟨f, hf⟩, ⟨hatt, hout⟩, heq⟩ + have hval : κ.match_ f = g := congrArg Subtype.val heq + rw [← hval] + exact match_maps_in_to_out o v ⟨f, hf⟩ ⟨hatt, hout⟩ + · intro ⟨hatt, hout⟩ + -- g is outgoing at v; its match is incoming at v + refine ⟨⟨κ.match_ g, κ.match_mem g hg⟩, ?_, ?_⟩ + · exact match_maps_out_to_in o v ⟨g, hg⟩ ⟨hatt, hout⟩ + · exact Subtype.ext (κ.match_invol g hg) + +/-! ### Splitting the all-at-v filter into in and out parts -/ + +open scoped Classical in +private theorem filter_at_v_split (o : κ.Orientation) (v : W.Vertex) : + (Finset.univ.filter (fun f : {f : W.Flag // f ∈ F.flags} => + W.attach f.val = Sum.inl v)).val = + (Finset.univ.filter (fun f : {f : W.Flag // f ∈ F.flags} => + W.attach f.val = Sum.inl v ∧ o.isOut f.val = false)).val + + (Finset.univ.filter (fun f : {f : W.Flag // f ∈ F.flags} => + W.attach f.val = Sum.inl v ∧ o.isOut f.val = true)).val := by + -- Use Multiset.filter_add_not to split by the isOut predicate + set S := (Finset.univ.filter (fun f : {f : W.Flag // f ∈ F.flags} => + W.attach f.val = Sum.inl v)).val + -- filter_add_not gives S = filter p S + filter (¬p) S + have hfan : Multiset.filter (fun f : {f : W.Flag // f ∈ F.flags} => + o.isOut f.val = false) S + + Multiset.filter (fun f => ¬ (o.isOut f.val = false)) S = S := + Multiset.filter_add_not _ S + -- Simplify ¬(isOut f.val = false) to (isOut f.val = true) + have hfilt_in : Multiset.filter (fun f : {f : W.Flag // f ∈ F.flags} => + o.isOut f.val = false) S = + (Finset.univ.filter (fun f : {f : W.Flag // f ∈ F.flags} => + W.attach f.val = Sum.inl v ∧ o.isOut f.val = false)).val := by + simp only [S, Finset.filter_val, Multiset.filter_filter] + congr 1; ext ⟨f, hf⟩ + simp only [and_comm] + have hfilt_out : Multiset.filter (fun f : {f : W.Flag // f ∈ F.flags} => + ¬ (o.isOut f.val = false)) S = + (Finset.univ.filter (fun f : {f : W.Flag // f ∈ F.flags} => + W.attach f.val = Sum.inl v ∧ o.isOut f.val = true)).val := by + simp only [S, Finset.filter_val, Multiset.filter_filter] + congr 1; ext ⟨f, hf⟩ + simp only [Bool.not_eq_false] + exact and_comm + rw [← hfilt_in, ← hfilt_out, hfan] + +/-! ### Main theorem -/ + +open scoped Classical in +/-- A vertex's odd list as a multiset: the per-flag odd values over +the flags at that vertex. -/ +theorem oddListAt_coe_multiset (o : κ.Orientation) (φ : F.OddColouring ℓ) + (v : W.Vertex) : + (↑(F.oddListAt o φ v) : Multiset (Fin (2 * ℓ))) = + (Finset.univ.filter (fun f : {f : W.Flag // f ∈ F.flags} => + W.attach f.val = Sum.inl v)).val.map + (fun f => if o.isOut f.val = true + then oddPartner ℓ (φ.val f) else φ.val f) := by + -- Abbreviations + set S_in := Finset.univ.filter (fun f : {f : W.Flag // f ∈ F.flags} => + W.attach f.val = Sum.inl v ∧ o.isOut f.val = false) + set S_out := Finset.univ.filter (fun f : {f : W.Flag // f ∈ F.flags} => + W.attach f.val = Sum.inl v ∧ o.isOut f.val = true) + set S_all := Finset.univ.filter (fun f : {f : W.Flag // f ∈ F.flags} => + W.attach f.val = Sum.inl v) + set g := fun f : {f : W.Flag // f ∈ F.flags} => + if o.isOut f.val = true then oddPartner ℓ (φ.val f) else φ.val f + -- Step 1: LHS = bind over S_in of pairs + have h_lhs : (↑(F.oddListAt o φ v) : Multiset (Fin (2 * ℓ))) = + S_in.val.bind (fun f => (↑(F.oddPairFn κ φ f) : Multiset _)) := by + unfold EdgeSubset.oddListAt + rw [← Multiset.coe_bind] + congr 1 + exact attachWith_sort_eq_filter_val o v + -- Step 2: Each oddPairFn gives a two-element multiset + have h_pair : ∀ f : {f : W.Flag // f ∈ F.flags}, + (↑(F.oddPairFn κ φ f) : Multiset _) = + ({φ.val f} : Multiset _) + {oddPartner ℓ (φ.val ⟨κ.match_ f.val, + κ.match_mem _ f.prop⟩)} := by + intro ⟨f, hf⟩ + -- oddPairFn produces [φ f, oddPartner (φ (match f))] + -- As multisets: ↑[a, b] = a ::ₘ b ::ₘ 0 = {a} + {b} + let a := φ.val ⟨f, hf⟩ + let b := oddPartner ℓ (φ.val ⟨κ.match_ f, κ.match_mem _ hf⟩) + change (↑(F.oddPairFn κ φ ⟨f, hf⟩) : Multiset _) = ({a} : Multiset _) + {b} + change (↑([a, b] : List _) : Multiset _) = ({a} : Multiset _) + {b} + rfl + -- Step 3: Bind of pairs = map of first + map of second + have h_bind_split : S_in.val.bind (fun f => (↑(F.oddPairFn κ φ f) : Multiset + _)) = + S_in.val.map (fun f => φ.val f) + + S_in.val.map (fun f => oddPartner ℓ (φ.val ⟨κ.match_ f.val, κ.match_mem _ + f.prop⟩)) := by + rw [show S_in.val.bind (fun f => (↑(F.oddPairFn κ φ f) : Multiset _)) = + S_in.val.bind (fun f => + ({φ.val f} : Multiset _) + + {oddPartner ℓ (φ.val ⟨κ.match_ f.val, κ.match_mem _ f.prop⟩)}) from + Multiset.bind_congr (fun f _ => h_pair f)] + exact multiset_bind_pair S_in.val + (fun f => φ.val f) + (fun f => oddPartner ℓ (φ.val ⟨κ.match_ f.val, κ.match_mem _ f.prop⟩)) + -- Step 4: RHS splits into in and out parts + have h_rhs_split : S_all.val.map g = S_in.val.map g + S_out.val.map g := by + rw [filter_at_v_split o v, Multiset.map_add] + -- Step 5: On S_in, g f = φ.val f + have h_g_in : S_in.val.map g = S_in.val.map (fun f => φ.val f) := by + apply Multiset.map_congr rfl + intro f hf + have : o.isOut f.val = false := by + rw [Finset.mem_val, Finset.mem_filter] at hf + exact hf.2.2 + simp [g, this] + -- Step 6: On S_out, g f = oddPartner (φ.val f) + have h_g_out : S_out.val.map g = + S_out.val.map (fun f => oddPartner ℓ (φ.val f)) := by + apply Multiset.map_congr rfl + intro f hf + have : o.isOut f.val = true := by + rw [Finset.mem_val, Finset.mem_filter] at hf + exact hf.2.2 + simp [g, this] + -- Step 7: The match bijection equates the outgoing part with + -- the incoming part mapped via match + have h_out_eq_in_match : + S_out.val.map (fun f => oddPartner ℓ (φ.val f)) = + S_in.val.map (fun f => oddPartner ℓ (φ.val ⟨κ.match_ f.val, κ.match_mem _ + f.prop⟩)) := by + -- S_out = S_in.map (matchEmb κ) + have himg := match_image_in_eq_out o v + have hval : S_out.val = S_in.val.map (matchEmb κ) := by + have := congrArg Finset.val himg + rw [Finset.map_val] at this + exact this.symm + calc S_out.val.map (fun f => oddPartner ℓ (φ.val f)) + = (S_in.val.map (matchEmb κ)).map (fun f => oddPartner ℓ (φ.val f)) + := by + rw [hval] + _ = S_in.val.map ((fun f => oddPartner ℓ (φ.val f)) ∘ (matchEmb κ)) := + Multiset.map_map _ _ _ + _ = S_in.val.map + (fun f => oddPartner ℓ (φ.val ⟨κ.match_ f.val, κ.match_mem _ f.prop⟩)) + := by + rfl + -- Assemble + rw [h_lhs, h_bind_split, h_rhs_split, h_g_in, h_g_out, h_out_eq_in_match] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddPair.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddPair.lean new file mode 100644 index 0000000000..8bd94a7b28 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddPair.lean @@ -0,0 +1,124 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapSplit + +/-! +# Odd pairs and their vanishing under split functionals + +The odd⊗odd block of a tensor lands in the even part; under a +tensor of copoint functionals it vanishes, because copoints kill +odd parts (the unit has no odd part). This disposes of the +cross-split odd basis terms in the cap recursion. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Functor.LaxMonoidal Functor.OplaxMonoidal +open MonoidalCategory +open scoped TensorProduct + +/-- The even element carried by a pair of odd vectors. -/ +def oddPair {V W : SuperVect} (v : V.odd) (w : W.odd) : + (SuperVect.tensorObj V W).even := (0, v ⊗ₜ[ℂ] w) + +/-- Tensors of morphisms act blockwise on odd pairs. -/ +theorem tensorHom_oddPair {V₁ V₂ W₁ W₂ : SuperVect} + (g : V₁ ⟶ V₂) (h : W₁ ⟶ W₂) (v : V₁.odd) (w : W₁.odd) : + ((g ⊗ₘ h : SuperVect.tensorObj V₁ W₁ ⟶ + SuperVect.tensorObj V₂ W₂) : + SuperVect.Hom _ _).evenMap (oddPair v w) = + oddPair ((g : SuperVect.Hom _ _).oddMap v) + ((h : SuperVect.Hom _ _).oddMap w) := by + change (SuperVect.tensorHom g h).evenMap (oddPair v w) = _ + change ((TensorProduct.map (g : SuperVect.Hom _ _).evenMap + (h : SuperVect.Hom _ _).evenMap) 0, + (TensorProduct.map (g : SuperVect.Hom _ _).oddMap + (h : SuperVect.Hom _ _).oddMap) (v ⊗ₜ[ℂ] w)) = _ + rw [TensorProduct.map_tmul, map_zero] + rfl + +/-- The target unitor kills odd pairs of unit vectors. -/ +theorem lambda_oddPair + (v : SuperVect.tensorUnit.odd) + (w : SuperVect.tensorUnit.odd) : + (((λ_ (𝟙_ SuperVect)).hom : + SuperVect.tensorObj SuperVect.tensorUnit + SuperVect.tensorUnit ⟶ SuperVect.tensorUnit) : + SuperVect.Hom _ _).evenMap (oddPair v w) = 0 := by + change (TensorProduct.lid ℂ ℂ).toLinearMap + ((LinearMap.fst ℂ _ _) (oddPair v w)) = 0 + rw [show (LinearMap.fst ℂ _ _) (oddPair v w) = + (0 : ℂ ⊗[ℂ] ℂ) from rfl] + rw [map_zero] + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) + +-- The vanishing is checked through the tensorator +-- on the odd block, unfolding both unitors. +/-- **Split functionals vanish on odd pairs**: the tensor of two +copoint functionals kills a structure-map image of an odd +pair. -/ +theorem omegaFun_tensor_oddPair {a b : ℕ} + (q₁ : (SkeinObj.mk a : SkeinObj f) ⟶ SkeinObj.mk 0) + (q₂ : (SkeinObj.mk b : SkeinObj f) ⟶ SkeinObj.mk 0) + (v : (P.ω.obj (SkeinObj.mk a)).odd) + (w : (P.ω.obj (SkeinObj.mk b)).odd) : + letI := P.braided + omegaFun f P (q₁ ⊗ₘ q₂) + (((μ P.ω (SkeinObj.mk a) (SkeinObj.mk b)) : + SuperVect.Hom _ _).evenMap (oddPair v w)) = 0 := by + let := P.braided + have hhom : (λ_ (𝟙_ (SkeinObj f))).hom = + 𝟙 (𝟙_ (SkeinObj f)) := by + have h1 := Iso.hom_inv_id (λ_ (𝟙_ (SkeinObj f))) + rw [skein_leftUnitor_unit_inv, Category.comp_id] at h1 + exact h1 + have hskein : ((q₁ ⊗ₘ q₂) ≫ + (λ_ (𝟙_ (SkeinObj f))).hom : + SkeinObj.mk a ⊗ SkeinObj.mk b ⟶ 𝟙_ (SkeinObj f)) = + q₁ ⊗ₘ q₂ := by + rw [hhom] + exact Category.comp_id _ + have habs := point_cotensor P.ω q₁ q₂ + rw [hskein] at habs + have hev := congrArg + (fun z : (P.ω.obj (SkeinObj.mk a) ⊗ + P.ω.obj (SkeinObj.mk b) ⟶ 𝟙_ SuperVect) => + (z : SuperVect.Hom _ _).evenMap (oddPair v w)) habs + refine Eq.trans ?_ (Eq.trans hev ?_) + · rfl + · change ((((P.ω.map q₁ ≫ η P.ω) ⊗ₘ (P.ω.map q₂ ≫ η P.ω)) ≫ + (λ_ (𝟙_ SuperVect)).hom : + P.ω.obj (SkeinObj.mk a) ⊗ P.ω.obj (SkeinObj.mk b) ⟶ + SuperVect.tensorUnit) : + SuperVect.Hom _ _).evenMap (oddPair v w) = 0 + change (((λ_ (𝟙_ SuperVect)).hom : + SuperVect.tensorObj SuperVect.tensorUnit + SuperVect.tensorUnit ⟶ SuperVect.tensorUnit) : + SuperVect.Hom _ _).evenMap + ((SuperVect.tensorHom + (P.ω.map q₁ ≫ η P.ω) (P.ω.map q₂ ≫ η P.ω)).evenMap + (oddPair v w)) = 0 + rw [show (SuperVect.tensorHom + (P.ω.map q₁ ≫ η P.ω) + (P.ω.map q₂ ≫ η P.ω)).evenMap (oddPair v w) = + oddPair + (((P.ω.map q₁ ≫ η P.ω : P.ω.obj (SkeinObj.mk a) ⟶ + SuperVect.tensorUnit) : + SuperVect.Hom _ _).oddMap v) + (((P.ω.map q₂ ≫ η P.ω : P.ω.obj (SkeinObj.mk b) ⟶ + SuperVect.tensorUnit) : + SuperVect.Hom _ _).oddMap w) from + tensorHom_oddPair _ _ v w] + exact lambda_oddPair _ _ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddSignProd.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddSignProd.lean new file mode 100644 index 0000000000..8a435f0d4c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddSignProd.lean @@ -0,0 +1,161 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists + +/-! +# Product of odd signs over vertices equals product over outgoing flags +-/ + +@[expose] public section + +namespace RS + +open Finset +variable {α : Type} {W : Fragment α} {F : EdgeSubset W} {ℓ : ℕ} + {κ : F.TransitionSystem} + +/-! ### Helpers -/ + +/-- The oddSignFn lifted to bare flags using classical membership. -/ +private noncomputable def EdgeSubset.oddSignFn' (F : EdgeSubset W) + (κ : F.TransitionSystem) (φ : F.OddColouring ℓ) + (f : W.Flag) : ℤ := + if h : f ∈ F.flags then F.oddSignFn κ φ ⟨f, h⟩ else 1 + +private theorem EdgeSubset.oddSignFn'_eq_of_mem + (φ : F.OddColouring ℓ) {f : W.Flag} (hf : f ∈ F.flags) : + F.oddSignFn' κ φ f = F.oddSignFn κ φ ⟨f, hf⟩ := by + unfold EdgeSubset.oddSignFn'; exact dite_eq_left hf + +/-- The attachWith-map list equals a plain map with classically +lifted function. -/ +private theorem EdgeSubset.attachWith_map_oddSignFn_eq + (φ : F.OddColouring ℓ) (l : List W.Flag) + (H : ∀ x ∈ l, x ∈ F.flags) : + (l.attachWith (· ∈ F.flags) H).map (F.oddSignFn κ φ) = + l.map (F.oddSignFn' κ φ) := by + rw [show l.attachWith (· ∈ F.flags) H = + l.pmap Subtype.mk H from rfl, List.map_pmap] + rw [show List.pmap (fun a (h : a ∈ F.flags) => F.oddSignFn κ φ ⟨a, h⟩) + l H = + List.pmap (fun a (_ : a ∈ F.flags) => F.oddSignFn' κ φ a) l H from + List.pmap_congr_left _ (fun a _ h₁ _ => + (F.oddSignFn'_eq_of_mem φ h₁).symm)] + exact List.pmap_eq_map H + +open scoped Classical in +/-- `inFlagsAt` is a permutation of the filter's `toList`. -/ +private theorem EdgeSubset.inFlagsAt_perm_filter_toList + (o : κ.Orientation) (v : W.Vertex) : + List.Perm (F.inFlagsAt o v) + ((F.flags.filter + (fun f => W.attach f = Sum.inl v ∧ o.isOut f = false)).toList) := by + unfold EdgeSubset.inFlagsAt + let := W.flagOrder + -- The unfolded LHS sort uses `fun a b => dec (a ≤ b)` from the + -- `letI := Classical.dec` inside inFlagsAt, while the ambient + -- instance is `LinearOrder.toDecidableLE`. Similarly, the filter + -- uses `fun a => dec (...)` vs the ambient DecidablePred. + -- Since Decidable is a Subsingleton, convert handles the gap. + convert Finset.sort_perm_toList + (F.flags.filter + (fun f => W.attach f = Sum.inl v ∧ o.isOut f = false)) + (· ≤ ·) using 2 + congr + +/-! ### Step 1: oddSignAt as a Finset product -/ + +open scoped Classical in +/-- The list-based oddSignAt equals the finset product over the +filter of F.flags. -/ +private theorem EdgeSubset.oddSignAt_eq_filter_prod + (o : κ.Orientation) (φ : F.OddColouring ℓ) (v : W.Vertex) : + F.oddSignAt o φ v = + ∏ f ∈ F.flags.filter + (fun f => W.attach f = Sum.inl v ∧ o.isOut f = false), + F.oddSignFn' κ φ f := by + unfold EdgeSubset.oddSignAt + rw [F.attachWith_map_oddSignFn_eq φ _ (fun f hf => + F.mem_of_mem_inFlagsAt hf)] + rw [show (∏ f ∈ F.flags.filter + (fun f => W.attach f = Sum.inl v ∧ o.isOut f = false), + F.oddSignFn' κ φ f) = + ((F.flags.filter + (fun f => W.attach f = Sum.inl v ∧ o.isOut f = false)).toList.map + (F.oddSignFn' κ φ)).prod from + (Finset.prod_map_toList _ _).symm] + exact ((F.inFlagsAt_perm_filter_toList o v).map _).prod_eq + +/-! ### Step 2: product over vertices, then swap and collapse -/ + +/-- The product of oddSignAt over all vertices equals the product +of oddSignFn' over all participating flags with the incoming +condition. -/ +private theorem EdgeSubset.prod_oddSignAt_eq_prod_flags_incoming + (o : κ.Orientation) (φ : F.OddColouring ℓ) : + (∏ v : W.Vertex, F.oddSignAt o φ v) = + ∏ f ∈ F.flags, + (if o.isOut f = false + then F.oddSignFn' κ φ f else 1) := by + classical + simp_rw [F.oddSignAt_eq_filter_prod o φ, Finset.prod_filter] + rw [show (∏ v : W.Vertex, ∏ f ∈ F.flags, + if W.attach f = Sum.inl v ∧ o.isOut f = false then + F.oddSignFn' κ φ f else 1) = + ∏ f ∈ F.flags, ∏ v : W.Vertex, + if W.attach f = Sum.inl v ∧ o.isOut f = false then + F.oddSignFn' κ φ f else 1 from + Finset.prod_comm] + congr 1; ext f + by_cases hf : f ∈ F.flags + · obtain ⟨vf, hvf⟩ := κ.attach_internal f hf + rw [Fintype.prod_eq_single vf] + · simp [hvf] + · intro v hv + have : ¬(W.attach f = Sum.inl v ∧ o.isOut f = false) := by + intro ⟨hatt, _⟩ + exact hv (Sum.inl.inj (hatt ▸ hvf)) + simp [this] + · have hone : F.oddSignFn' κ φ f = 1 := by + unfold EdgeSubset.oddSignFn'; rw [dite_eq_right hf] + simp [hone] + +/-! ### Step 3: incoming to subtype, then reindex -/ + +/-- Main theorem: the product over vertices of the Definition-5 odd +signs is the product of partner signs over the outgoing participating +flags. -/ +theorem prod_oddSignAt (o : κ.Orientation) (φ : F.OddColouring ℓ) : + (∏ v : W.Vertex, F.oddSignAt o φ v) = + ∏ f : {f : W.Flag // f ∈ F.flags}, + (if o.isOut f.val = true then oddPartnerSign ℓ (φ.val f) else 1) := by + rw [F.prod_oddSignAt_eq_prod_flags_incoming o φ] + rw [show (∏ f ∈ F.flags, + (if o.isOut f = false then F.oddSignFn' κ φ f else 1)) = + ∏ f : {f : W.Flag // f ∈ F.flags}, + (if o.isOut f.val = false then F.oddSignFn κ φ f else 1) from by + rw [← Finset.prod_attach] + congr 1; ext ⟨f, hf⟩ + split <;> [exact F.oddSignFn'_eq_of_mem φ hf; rfl]] + let e : {f : W.Flag // f ∈ F.flags} ≃ {f : W.Flag // f ∈ F.flags} := + ⟨fun f => ⟨κ.match_ f.val, κ.match_mem _ f.prop⟩, + fun f => ⟨κ.match_ f.val, κ.match_mem _ f.prop⟩, + fun f => Subtype.ext (κ.match_invol _ f.prop), + fun f => Subtype.ext (κ.match_invol _ f.prop)⟩ + rw [← Equiv.prod_comp e] + congr 1; ext f + simp only [e, Equiv.coe_fn_mk] + rw [o.match_flip _ f.prop] + cases hb : o.isOut f.val <;> simp only [Bool.not_false, Bool.true_eq_false, ↓reduceIte, + Bool.false_eq_true, Bool.not_true] + · unfold EdgeSubset.oddSignFn + congr 1 + exact congrArg φ.val (Subtype.ext (κ.match_invol _ f.prop)) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaCotensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaCotensor.lean new file mode 100644 index 0000000000..cc3a55a9a5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaCotensor.lean @@ -0,0 +1,151 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaStarVec + +/-! +# Image functionals of tensors + +The dual of the point-tensor coherence: the fibre functor sends +tensor products of copoint morphisms to the product of their +image functionals through the structure map. Abstract coherence +first — every rewrite fires over generic instances — then the +strict skein unit and the concrete SuperVect unitor. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Functor.LaxMonoidal Functor.OplaxMonoidal +open MonoidalCategory + +/-- **Copoints are monoidal**: for a monoidal functor, the +structure map followed by the image of a corrected tensor of +copoints and the unit map is the tensor of the copoint images +followed by the target unitor. -/ +theorem point_cotensor {C D : Type*} [Category C] [Category D] + [MonoidalCategory C] [MonoidalCategory D] + (F : C ⥤ D) [F.Monoidal] {A B : C} + (q₁ : A ⟶ 𝟙_ C) (q₂ : B ⟶ 𝟙_ C) : + μ F A B ≫ F.map ((q₁ ⊗ₘ q₂) ≫ (λ_ (𝟙_ C)).hom) ≫ η F = + ((F.map q₁ ≫ η F) ⊗ₘ (F.map q₂ ≫ η F)) ≫ + (λ_ (𝟙_ D)).hom := by + rw [F.map_comp] + rw [show μ F A B ≫ (F.map (q₁ ⊗ₘ q₂) ≫ + F.map (λ_ (𝟙_ C)).hom) ≫ η F = + (μ F A B ≫ F.map (q₁ ⊗ₘ q₂)) ≫ + F.map (λ_ (𝟙_ C)).hom ≫ η F from by + simp only [Category.assoc]] + rw [← Functor.LaxMonoidal.μ_natural] + rw [Functor.Monoidal.map_leftUnitor] + simp only [Category.assoc] + rw [Functor.Monoidal.μ_δ_assoc] + rw [show (λ_ (F.obj (𝟙_ C))).hom ≫ η F = + (𝟙_ D ◁ η F) ≫ (λ_ (𝟙_ D)).hom from + (MonoidalCategory.leftUnitor_naturality (η F)).symm] + rw [← Category.assoc, ← Category.assoc] + refine congrArg (fun z => z ≫ (λ_ (𝟙_ D)).hom) ?_ + rw [← MonoidalCategory.tensorHom_id, + ← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom] + simp only [Category.comp_id] + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) + +/-- The tensor of functionals on an even pair evaluates to the +product. -/ +theorem lambda_evenPair {V W : SuperVect} + (g : V ⟶ SuperVect.tensorUnit) + (h : W ⟶ SuperVect.tensorUnit) (v : V.even) (w : W.even) : + (((g ⊗ₘ h : SuperVect.tensorObj V W ⟶ + SuperVect.tensorObj SuperVect.tensorUnit + SuperVect.tensorUnit) ≫ + (λ_ (𝟙_ SuperVect)).hom : SuperVect.tensorObj V W ⟶ + SuperVect.tensorUnit) : + SuperVect.Hom _ _).evenMap (evenPair v w) = + (g : SuperVect.Hom _ _).evenMap v * + (h : SuperVect.Hom _ _).evenMap w := by + change ((λ_ (𝟙_ SuperVect)).hom : SuperVect.Hom _ _).evenMap + ((SuperVect.tensorHom g h).evenMap (evenPair v w)) = _ + rw [show (SuperVect.tensorHom g h).evenMap (evenPair v w) = + evenPair ((g : SuperVect.Hom _ _).evenMap v) + ((h : SuperVect.Hom _ _).evenMap w) from + tensorHom_evenPair g h v w] + change (TensorProduct.lid ℂ ℂ).toLinearMap + ((LinearMap.fst ℂ _ _) + (evenPair ((g : SuperVect.Hom _ _).evenMap v) + ((h : SuperVect.Hom _ _).evenMap w))) = _ + rw [show (LinearMap.fst ℂ _ _) + (evenPair ((g : SuperVect.Hom _ _).evenMap v) + ((h : SuperVect.Hom _ _).evenMap w)) = + ((g : SuperVect.Hom _ _).evenMap v) ⊗ₜ[ℂ] + ((h : SuperVect.Hom _ _).evenMap w) from rfl] + exact TensorProduct.lid_tmul _ _ + +-- Monoidality of the image functional unfolds the +-- tensorator and both unitors on each block. +/-- **Image functionals are monoidal**: the image functional of a +tensor of copoint morphisms, evaluated on a structure-map image +of an even pair, is the product of the image functionals. -/ +theorem omegaFun_tensor {a b : ℕ} + (q₁ : (SkeinObj.mk a : SkeinObj f) ⟶ SkeinObj.mk 0) + (q₂ : (SkeinObj.mk b : SkeinObj f) ⟶ SkeinObj.mk 0) + (v : (P.ω.obj (SkeinObj.mk a)).even) + (w : (P.ω.obj (SkeinObj.mk b)).even) : + letI := P.braided + omegaFun f P (q₁ ⊗ₘ q₂) + (((μ P.ω (SkeinObj.mk a) (SkeinObj.mk b)) : + SuperVect.Hom _ _).evenMap (evenPair v w)) = + omegaFun f P q₁ v * omegaFun f P q₂ w := by + let := P.braided + have hhom : (λ_ (𝟙_ (SkeinObj f))).hom = + 𝟙 (𝟙_ (SkeinObj f)) := by + have h1 := Iso.hom_inv_id (λ_ (𝟙_ (SkeinObj f))) + rw [skein_leftUnitor_unit_inv, Category.comp_id] at h1 + exact h1 + have hskein : ((q₁ ⊗ₘ q₂) ≫ + (λ_ (𝟙_ (SkeinObj f))).hom : + SkeinObj.mk a ⊗ SkeinObj.mk b ⟶ 𝟙_ (SkeinObj f)) = + q₁ ⊗ₘ q₂ := by + rw [hhom] + exact Category.comp_id _ + have habs := point_cotensor P.ω q₁ q₂ + rw [hskein] at habs + have hev := congrArg + (fun z : (P.ω.obj (SkeinObj.mk a) ⊗ + P.ω.obj (SkeinObj.mk b) ⟶ 𝟙_ SuperVect) => + (z : SuperVect.Hom _ _).evenMap (evenPair v w)) habs + refine Eq.trans ?_ (Eq.trans hev ?_) + · rfl + · change ((((P.ω.map q₁ ≫ η P.ω) ⊗ₘ (P.ω.map q₂ ≫ η P.ω)) ≫ + (λ_ (𝟙_ SuperVect)).hom : + P.ω.obj (SkeinObj.mk a) ⊗ P.ω.obj (SkeinObj.mk b) ⟶ + SuperVect.tensorUnit) : + SuperVect.Hom _ _).evenMap (evenPair v w) = _ + exact lambda_evenPair (P.ω.map q₁ ≫ η P.ω) + (P.ω.map q₂ ≫ η P.ω) v w + +/-- The image functional of a composite: precompose with the +image of the first factor. -/ +theorem omegaFun_comp {a b : ℕ} + (p : (SkeinObj.mk a : SkeinObj f) ⟶ SkeinObj.mk b) + (q : (SkeinObj.mk b : SkeinObj f) ⟶ SkeinObj.mk 0) + (v : (P.ω.obj (SkeinObj.mk a)).even) : + omegaFun f P (p ≫ q) v = + omegaFun f P q ((P.ω.map p).evenMap v) := by + let := P.braided + change ((P.ω.map (p ≫ q) ≫ η P.ω : P.ω.obj (SkeinObj.mk a) ⟶ + SuperVect.tensorUnit) : + SuperVect.Hom _ _).evenMap v = _ + rw [P.ω.map_comp] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaStarVec.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaStarVec.lean new file mode 100644 index 0000000000..e46c350ef1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaStarVec.lean @@ -0,0 +1,113 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTensor + +/-! +# The assembled star vector + +The image vector of the star-tensor class, assembled recursively +through the structure maps: each vertex contributes its star +vector, tensored on through `μ` and recast along the sum. The +parameter value of a closed fragment is then the circle power +times the cap functional evaluated on the sorted assembled +vector — arc (b) of the extraction, complete. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Functor.LaxMonoidal Functor.OplaxMonoidal +open MonoidalCategory + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) + +/-- The assembled star vector of a degree list. -/ +noncomputable def omegaStarVec : + (ds : List ℕ) → (P.ω.obj (SkeinObj.mk ds.sum)).even + | [] => omegaVec f P (𝟙 (SkeinObj.mk 0)) + | d :: ds => + letI := P.braided + (P.ω.map (bundleMapClass f (finCongr + (List.sum_cons.symm : + d + ds.sum = (d :: ds).sum)))).evenMap + (((μ P.ω (SkeinObj.mk d) (SkeinObj.mk ds.sum)) : + SuperVect.Hom _ _).evenMap + (evenPair (starVec f P d) (omegaStarVec ds))) + +/-- **The star-tensor class assembles**: its image vector is the +recursively assembled star vector. -/ +theorem omegaVec_starTensorClass : ∀ (ds : List ℕ), + omegaVec f P (starTensorClass f ds) = omegaStarVec f P ds + | [] => by + rw [starTensorClass_nil, empty_class_eq_id] + rfl + | d :: ds => by + let := P.braided + refine (congrArg (omegaVec f P) + (starTensorClass_cons f d ds)).trans ?_ + refine (omegaVec_comp f P + (HomSpace.tensor f 0 d 0 ds.sum + (vertexStarClass f d) (starTensorClass f ds)) + (bundleMapClass f (finCongr + (List.sum_cons.symm : + d + ds.sum = (d :: ds).sum)))).trans ?_ + refine (congrArg (P.ω.map (bundleMapClass f (finCongr + (List.sum_cons.symm : + d + ds.sum = (d :: ds).sum)))).evenMap + ((omegaVec_tensor f P (vertexStarClass f d) + (starTensorClass f ds)).trans + (congrArg (fun z => + ((μ P.ω (SkeinObj.mk d) (SkeinObj.mk ds.sum)) : + SuperVect.Hom _ _).evenMap + (evenPair (starVec f P d) z)) + (omegaVec_starTensorClass ds)))).trans ?_ + rfl + +/-- **The parameter value, factored** (arc (b) complete): the +value of a closed fragment is the circle power times the cap +functional on the sorted assembled star vector. -/ +theorem parameter_star_factor (W : ClosedFragment) : + f.val W = circleVal f ^ W.circles * + omegaFun f P (bundleCapClass f (edgeCount W)) + ((P.ω.map (bundleMapClass f + (sortEquiv (starAssignEnum W)).symm)).evenMap + (omegaStarVec f P (degList (starAssignEnum W)))) := by + rw [← star_pairing f P W] + rw [starClass_factor' f W] + rw [show omegaVec f P (circleVal f ^ W.circles • + HomSpace.comp f 0 ((degList (starAssignEnum W)).sum) + (edgeCount W + edgeCount W) + (starTensorClass f (degList (starAssignEnum W))) + (bundleMapClass f + (sortEquiv (starAssignEnum W)).symm)) = + circleVal f ^ W.circles • omegaVec f P + (HomSpace.comp f 0 ((degList (starAssignEnum W)).sum) + (edgeCount W + edgeCount W) + (starTensorClass f (degList (starAssignEnum W))) + (bundleMapClass f + (sortEquiv (starAssignEnum W)).symm)) from + omegaVec_smul f P _ _] + rw [show omegaVec f P + (HomSpace.comp f 0 ((degList (starAssignEnum W)).sum) + (edgeCount W + edgeCount W) + (starTensorClass f (degList (starAssignEnum W))) + (bundleMapClass f + (sortEquiv (starAssignEnum W)).symm)) = + (P.ω.map (bundleMapClass f + (sortEquiv (starAssignEnum W)).symm)).evenMap + (omegaVec f P + (starTensorClass f (degList (starAssignEnum W)))) from + omegaVec_comp f P _ _] + rw [omegaVec_starTensorClass] + rw [map_smul] + rw [smul_eq_mul] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTensor.lean new file mode 100644 index 0000000000..cd5bc75279 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTensor.lean @@ -0,0 +1,162 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarTensorClass + +/-! +# Image vectors of tensors + +The fibre functor sends tensor products of point morphisms to +the structure-map image of the tensor of their image vectors. +The coherence is proved abstractly for any monoidal functor — +where every rewrite fires — and the strictness of the skein unit +is exploited only in two small concrete bridging steps. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Functor.LaxMonoidal Functor.OplaxMonoidal +open MonoidalCategory + +/-- The even component of a tensor of even vectors. -/ +def evenPair {V W : SuperVect} (v : V.even) (w : W.even) : + (SuperVect.tensorObj V W).even := (v ⊗ₜ[ℂ] w, 0) + +/-- **Points are monoidal**: for a monoidal functor, the counit +composed with the image of a corrected tensor of points is the +tensor of the point images assembled by the structure map. -/ +theorem point_tensor {C D : Type*} [Category C] [Category D] + [MonoidalCategory C] [MonoidalCategory D] + (F : C ⥤ D) [F.Monoidal] {A B : C} + (p : 𝟙_ C ⟶ A) (q : 𝟙_ C ⟶ B) : + ε F ≫ F.map ((λ_ (𝟙_ C)).inv ≫ (p ⊗ₘ q)) = + (λ_ (𝟙_ D)).inv ≫ + ((ε F ≫ F.map p) ⊗ₘ (ε F ≫ F.map q)) ≫ μ F A B := by + rw [F.map_comp, Functor.Monoidal.map_leftUnitor_inv] + simp only [Category.assoc] + rw [← Functor.LaxMonoidal.μ_natural] + rw [MonoidalCategory.leftUnitor_inv_naturality_assoc] + rw [← MonoidalCategory.tensorHom_def'_assoc] + rw [← MonoidalCategory.tensorHom_comp_tensorHom] + simp only [Category.assoc] + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The inverse left unitor of the skein category at the unit is +the identity. -/ +theorem skein_leftUnitor_unit_inv : + (λ_ (𝟙_ (SkeinObj f))).inv = 𝟙 (𝟙_ (SkeinObj f)) := by + change bundleMapClass f (finCongr _) = _ + rw [show (finCongr (show (0 : ℕ) = 0 + 0 by omega) : + Fin 0 ≃ Fin (0 + 0)) = _root_.Equiv.refl (Fin 0) from + _root_.Equiv.ext (fun x => Fin.ext rfl)] + exact bundleMapClass_refl f 0 + +variable (P : DelignePackage (SkeinObj f)) + +/-- The image vector of a composite: apply the image of the +second factor. -/ +theorem omegaVec_comp {a b : ℕ} + (p : (SkeinObj.mk 0 : SkeinObj f) ⟶ SkeinObj.mk a) + (q : (SkeinObj.mk a : SkeinObj f) ⟶ SkeinObj.mk b) : + omegaVec f P (p ≫ q) = + (P.ω.map q).evenMap (omegaVec f P p) := by + let := P.braided + change ((ε P.ω ≫ P.ω.map (p ≫ q) : SuperVect.tensorUnit ⟶ + P.ω.obj (SkeinObj.mk b)) : + SuperVect.Hom _ _).evenMap 1 = _ + rw [P.ω.map_comp] + rfl + +/-- The image vector is homogeneous in the morphism. -/ +theorem omegaVec_smul {a : ℕ} (r : ℂ) + (p : (SkeinObj.mk 0 : SkeinObj f) ⟶ SkeinObj.mk a) : + omegaVec f P (r • p) = r • omegaVec f P p := by + let := P.braided + change ((ε P.ω ≫ P.ω.map (r • p) : SuperVect.tensorUnit ⟶ + P.ω.obj (SkeinObj.mk a)) : + SuperVect.Hom _ _).evenMap 1 = _ + rw [show P.ω.map (r • p) = r • P.ω.map p from + P.linear.map_smul p r, + CategoryTheory.Linear.comp_smul] + rfl + +/-- The tensor of morphisms on an even pair acts +componentwise. -/ +theorem tensorHom_evenPair {V₁ V₂ W₁ W₂ : SuperVect} + (g : V₁ ⟶ V₂) (h : W₁ ⟶ W₂) (v : V₁.even) (w : W₁.even) : + ((g ⊗ₘ h : SuperVect.tensorObj V₁ W₁ ⟶ + SuperVect.tensorObj V₂ W₂) : + SuperVect.Hom _ _).evenMap (evenPair v w) = + evenPair ((g : SuperVect.Hom _ _).evenMap v) + ((h : SuperVect.Hom _ _).evenMap w) := by + change (SuperVect.tensorHom g h).evenMap (evenPair v w) = _ + change ((TensorProduct.map (g : SuperVect.Hom _ _).evenMap + (h : SuperVect.Hom _ _).evenMap) (v ⊗ₜ[ℂ] w), + (TensorProduct.map (g : SuperVect.Hom _ _).oddMap + (h : SuperVect.Hom _ _).oddMap) 0) = _ + rw [TensorProduct.map_tmul, map_zero] + rfl + +/-- The inverse left unitor of `SuperVect` at the unit sends `1` +to the even pair of units. -/ +theorem superVect_leftUnitor_inv_one : + (((λ_ (𝟙_ SuperVect)).inv : SuperVect.tensorUnit ⟶ + SuperVect.tensorObj SuperVect.tensorUnit + SuperVect.tensorUnit) : + SuperVect.Hom _ _).evenMap (1 : ℂ) = + evenPair (1 : ℂ) (1 : ℂ) := by + change (LinearMap.inl ℂ _ _ ∘ₗ + (TensorProduct.lid ℂ ℂ).symm.toLinearMap) 1 = _ + rw [LinearMap.comp_apply] + rw [show (TensorProduct.lid ℂ ℂ).symm.toLinearMap (1 : ℂ) = + (1 : ℂ) ⊗ₜ[ℂ] (1 : ℂ) from TensorProduct.lid_symm_apply 1] + rfl + +-- Monoidality of the image vector unfolds the +-- tensorator and the left unitor on both sides. +/-- **Image vectors are monoidal**: the image vector of a tensor +of point morphisms is the structure-map image of the even pair +of the image vectors. -/ +theorem omegaVec_tensor {a b : ℕ} + (p : (SkeinObj.mk 0 : SkeinObj f) ⟶ SkeinObj.mk a) + (q : (SkeinObj.mk 0 : SkeinObj f) ⟶ SkeinObj.mk b) : + let _ := P.braided + omegaVec f P (d := a + b) (HomSpace.tensor f 0 a 0 b p q) = + ((μ P.ω (SkeinObj.mk a) (SkeinObj.mk b)) : + SuperVect.Hom _ _).evenMap + (evenPair (omegaVec f P p) (omegaVec f P q)) := by + let _ := P.braided + have hskein : ((λ_ (𝟙_ (SkeinObj f))).inv ≫ (p ⊗ₘ q) : + 𝟙_ (SkeinObj f) ⟶ + SkeinObj.mk a ⊗ SkeinObj.mk b) = p ⊗ₘ q := by + rw [skein_leftUnitor_unit_inv] + exact Category.id_comp _ + have habs := point_tensor P.ω p q + rw [hskein] at habs + have hev := congrArg + (fun z : (𝟙_ SuperVect ⟶ + P.ω.obj (SkeinObj.mk a ⊗ SkeinObj.mk b)) => + (z : SuperVect.Hom _ _).evenMap (1 : ℂ)) habs + refine Eq.trans hev ?_ + change ((μ P.ω (SkeinObj.mk a) (SkeinObj.mk b)) : + SuperVect.Hom _ _).evenMap + ((((ε P.ω ≫ P.ω.map p) ⊗ₘ (ε P.ω ≫ P.ω.map q) : + SuperVect.tensorObj SuperVect.tensorUnit + SuperVect.tensorUnit ⟶ _) : + SuperVect.Hom _ _).evenMap + ((((λ_ (𝟙_ SuperVect)).inv : SuperVect.tensorUnit ⟶ + SuperVect.tensorObj SuperVect.tensorUnit + SuperVect.tensorUnit) : + SuperVect.Hom _ _).evenMap (1 : ℂ))) = _ + rw [superVect_leftUnitor_inv_one, tensorHom_evenPair] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTransport.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTransport.lean new file mode 100644 index 0000000000..d3e1401de5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTransport.lean @@ -0,0 +1,112 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarCompClass +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinLinear +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneBridge +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ExactPairingInstance + +/-! +# Transporting the star identity through the fibre functor + +Applying a Deligne package's fibre functor to the categorical +star identity: the images of the star-union and bundle classes +compose to the parameter value times the identity of the image +of the unit object. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The empty class is the identity of the unit object. -/ +theorem empty_class_eq_id : + HomSpace.ofFragment f.val emptyClosedFragment = + 𝟙 (SkeinObj.mk 0 : SkeinObj f) := + HomSpace.ofFragment_congr f strandBundleZeroEmpty.symm + +variable (P : DelignePackage (SkeinObj f)) + +/-- **The transported star identity**: the fibre functor sends +the star composite to the parameter value times the identity. -/ +theorem omega_star (W : ClosedFragment) : + P.ω.map (X := SkeinObj.mk 0) (Y := SkeinObj.mk + (edgeCount W + edgeCount W)) (starClass f W) ≫ + P.ω.map (bundleCapClass f (edgeCount W)) = + f.val W • 𝟙 (P.ω.obj (SkeinObj.mk 0)) := by + let := P.linear + rw [← Functor.map_comp] + rw [show (starClass f W ≫ bundleCapClass f (edgeCount W) : + (SkeinObj.mk 0 : SkeinObj f) ⟶ SkeinObj.mk 0) = + HomSpace.comp f 0 (edgeCount W + edgeCount W) 0 + (starClass f W) (bundleCapClass f (edgeCount W)) + from rfl] + rw [star_comp_class, empty_class_eq_id] + exact (P.linear.map_smul _ _).trans + (by rw [CategoryTheory.Functor.map_id]) + +open Functor.LaxMonoidal Functor.OplaxMonoidal in +/-- **The transported star identity, as a scalar**: conjugating +by the unit structure maps and evaluating the even part at `1` +recovers the parameter value. -/ +theorem omega_star_scalar (W : ClosedFragment) : + letI := P.braided + ((ε P.ω ≫ (P.ω.map (X := SkeinObj.mk 0) (Y := SkeinObj.mk + (edgeCount W + edgeCount W)) (starClass f W) ≫ + P.ω.map (bundleCapClass f (edgeCount W))) ≫ + η P.ω : SuperVect.tensorUnit ⟶ SuperVect.tensorUnit) + : SuperVect.Hom SuperVect.tensorUnit + SuperVect.tensorUnit).evenMap 1 = f.val W := by + let := P.braided + rw [omega_star f P W] + rw [CategoryTheory.Linear.smul_comp, + CategoryTheory.Linear.comp_smul] + have h1 : (𝟙 (P.ω.obj (SkeinObj.mk 0)) ≫ η P.ω) = η P.ω := + CategoryTheory.Category.id_comp _ + rw [h1] + have h2 : (ε P.ω ≫ η P.ω : SuperVect.tensorUnit ⟶ + SuperVect.tensorUnit) = 𝟙 _ := + Functor.Monoidal.ε_η P.ω + rw [h2] + change f.val W * 1 = f.val W + ring + +open Functor.LaxMonoidal Functor.OplaxMonoidal in +/-- **The standard model of the skein category**: any Deligne +package yields dimensions `k, ℓ` and an isomorphism of the strand +image with the standard super vector space carrying the +evaluation to the standard form and the coevaluation to the +standard copairing. -/ +theorem skein_std_model : + letI := P.braided + ∃ (k ℓ : ℕ) + (e : SuperVect.Hom (stdSuperPair k ℓ) + (P.ω.obj (SkeinObj.mk 1))) + (e' : SuperVect.Hom (P.ω.obj (SkeinObj.mk 1)) + (stdSuperPair k ℓ)), + SuperVect.Hom.comp e' e = + SuperVect.Hom.id (stdSuperPair k ℓ) ∧ + SuperVect.Hom.comp e e' = + SuperVect.Hom.id (P.ω.obj (SkeinObj.mk 1)) ∧ + SuperVect.Hom.comp + (μ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1) ≫ + P.ω.map (ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) ≫ η P.ω) + (SuperVect.tensorHom e e) = stdForm k ℓ ∧ + SuperVect.Hom.comp (SuperVect.tensorHom e' e') + (ε P.ω ≫ P.ω.map (η_ (SkeinObj.mk 1) (SkeinObj.mk 1)) ≫ + δ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1)) = + stdCopair k ℓ := by + let := P.braided + exact braided_std_model P.ω (SkeinObj.mk 1) + (strand_ev_symmetry f) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OneBasis.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OneBasis.lean new file mode 100644 index 0000000000..786237cc8a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OneBasis.lean @@ -0,0 +1,278 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StrandTransport + +/-! +# One-position basis vectors + +The colour-model basis vectors at a single position are the +unit-padded standard basis vectors: the single-layer computation +of `colourPowerEquiv 1` on padded pure tensors. +-/ + +@[expose] public section + +namespace RS + +open scoped TensorProduct + +variable {k ℓ : ℕ} + +/-- The one-position even colouring. -/ +def oneColourE (k ℓ : ℕ) (i : Fin k) : + MixedColouring k ℓ 1 := fun _ => Sum.inl i + +/-- The one-position odd colouring. -/ +def oneColourO (k ℓ : ℕ) (a : Fin (2 * ℓ)) : + MixedColouring k ℓ 1 := fun _ => Sum.inr a + +/-- An even one-position colouring is even. -/ +theorem oneColourE_isEven (i : Fin k) : + MixedColouring.IsEven (oneColourE k ℓ i) := + ⟨0, by simp [MixedColouring.oddSet, oneColourE]⟩ + +/-- And an odd one is not — the grading at a single position. -/ +theorem oneColourO_not_isEven (a : Fin (2 * ℓ)) : + ¬ MixedColouring.IsEven (oneColourO k ℓ a) := by + intro h + have hcard : (MixedColouring.oddSet + (oneColourO k ℓ a)).card = 1 := by + simp [MixedColouring.oddSet, oneColourO] + rw [MixedColouring.IsEven, hcard] at h + exact (Nat.not_even_iff_odd.mpr (by decide)) h + +/-- One-position colourings are determined at zero. -/ +theorem oneColour_ext {c₁ c₂ : MixedColouring k ℓ 1} + (h : c₁ 0 = c₂ 0) : c₁ = c₂ := by + funext j + rw [Subsingleton.elim j 0] + exact h + +/-- The forward even split at one position, even colour. -/ +private theorem evenSplit0_inl (c : MixedColouring k ℓ 1) + (hc : c.IsEven) (i : Fin k) + (hi : c (Fin.last 0) = Sum.inl i) : + evenSplitEquiv k ℓ 0 ⟨c, hc⟩ = + Sum.inl (⟨MixedColouring.tail c, + (c.isEven_succ_left i hi).mp hc⟩, i) := by + have inv : (evenSplitEquiv k ℓ 0).symm + (Sum.inl (⟨MixedColouring.tail c, + (c.isEven_succ_left i hi).mp hc⟩, i)) = ⟨c, hc⟩ := by + apply Subtype.ext + rw [evenSplitEquiv_symm_inl] + funext j + refine Fin.lastCases ?_ (fun j' => j'.elim0) j + exact (colouringSplit_symm_last _ _).trans hi.symm + rw [← inv, Equiv.apply_symm_apply] + +/-- The forward odd split at one position, odd colour. -/ +private theorem oddSplit0_inr (c : MixedColouring k ℓ 1) + (hc : ¬ c.IsEven) (a : Fin (2 * ℓ)) + (ha : c (Fin.last 0) = Sum.inr a) : + oddSplitEquiv k ℓ 0 ⟨c, hc⟩ = + Sum.inr (⟨MixedColouring.tail c, by + by_contra hcontra + exact hc ((c.isEven_succ_right a ha).mpr hcontra)⟩, + a) := by + have inv : (oddSplitEquiv k ℓ 0).symm + (Sum.inr (⟨MixedColouring.tail c, by + by_contra hcontra + exact hc ((c.isEven_succ_right a ha).mpr hcontra)⟩, + a)) = ⟨c, hc⟩ := by + apply Subtype.ext + rw [oddSplitEquiv_symm_inr] + funext j + refine Fin.lastCases ?_ (fun j' => j'.elim0) j + exact (colouringSplit_symm_last _ _).trans ha.symm + rw [← inv, Equiv.apply_symm_apply] + +-- The one-position basis vector is identified +-- coordinate by coordinate through the colouring equivalence. +/-- **The one-position even basis vector is the unit-padded +standard even basis vector.** -/ +theorem evenBasisVec_one (i : Fin k) : + evenBasisVec (⟨oneColourE k ℓ i, oneColourE_isEven i⟩ : + {c : MixedColouring k ℓ 1 // c.IsEven}) = + evenPair (1 : ℂ) (stdE k i) := by + apply (colourPowerEquiv k ℓ 1).evenEquiv.injective + rw [show (colourPowerEquiv k ℓ 1).evenEquiv + (evenBasisVec (⟨oneColourE k ℓ i, + oneColourE_isEven i⟩ : + {c : MixedColouring k ℓ 1 // c.IsEven})) = + Pi.single ⟨oneColourE k ℓ i, oneColourE_isEven i⟩ 1 from + (colourPowerEquiv k ℓ 1).evenEquiv.apply_symm_apply _] + funext ⟨c', hc'⟩ + change _ = ((colourPowerEquiv k ℓ 1).evenEquiv + (evenPair (1 : ℂ) (stdE k i)) ⟨c', hc'⟩) + change _ = (colourPowerStep k ℓ 0).evenEquiv + ((TensorProduct.congr + (colourPowerZero k ℓ).evenEquiv + (LinearEquiv.refl ℂ (Fin k → ℂ))) + ((1 : ℂ) ⊗ₜ[ℂ] stdE k i), + (TensorProduct.congr + (colourPowerZero k ℓ).oddEquiv + (LinearEquiv.refl ℂ (Fin (2 * ℓ) → ℂ))) 0) ⟨c', hc'⟩ + rw [TensorProduct.congr_tmul, map_zero] + change _ = Sum.elim + (fun p => funTensorFun _ _ + (((colourPowerZero k ℓ).evenEquiv (1 : ℂ)) ⊗ₜ[ℂ] + (LinearEquiv.refl ℂ (Fin k → ℂ) (stdE k i))) p) + (fun q => funTensorFun _ _ + (0 : ({c : MixedColouring k ℓ 0 // ¬ c.IsEven} → ℂ) + ⊗[ℂ] (Fin (2 * ℓ) → ℂ)) q) + (evenSplitEquiv k ℓ 0 ⟨c', hc'⟩) + rcases hlast : c' (Fin.last 0) with j | b + · rw [evenSplit0_inl c' hc' j hlast, Sum.elim_inl] + refine Eq.trans ?_ ((funTensorFun_tmul _ _ _).symm) + rw [show ((colourPowerZero k ℓ).evenEquiv (1 : ℂ)) + (⟨MixedColouring.tail c', + (c'.isEven_succ_left j hlast).mp hc'⟩, j).1 = 1 + from rfl] + rw [one_mul] + have hval : (Pi.single (⟨oneColourE k ℓ i, + oneColourE_isEven i⟩ : + {c : MixedColouring k ℓ 1 // c.IsEven}) (1 : ℂ) : + {c : MixedColouring k ℓ 1 // c.IsEven} → ℂ) + ⟨c', hc'⟩ = + (Pi.single i (1 : ℂ) : Fin k → ℂ) j := by + by_cases hij : j = i + · subst hij + rw [single_val_same ⟨oneColourE k ℓ j, + oneColourE_isEven j⟩ ⟨c', hc'⟩ + (oneColour_ext (show oneColourE k ℓ j 0 = + c' 0 from hlast.symm)), + Pi.single_eq_same] + · rw [single_val_ne ⟨oneColourE k ℓ i, + oneColourE_isEven i⟩ ⟨c', hc'⟩ + (fun he => hij (Sum.inl.inj + (show Sum.inl j = Sum.inl i from by + have he' : c' = oneColourE k ℓ i := he + rw [← hlast, he']; rfl))), + Pi.single_eq_of_ne hij] + exact hval.trans rfl + · -- Odd colour at an even one-position colouring: both sides + -- vanish. + rw [single_val_ne ⟨oneColourE k ℓ i, + oneColourE_isEven i⟩ ⟨c', hc'⟩ + (fun he => Sum.inr_ne_inl + (show Sum.inr b = Sum.inl i from by + have he' : c' = oneColourE k ℓ i := he + rw [← hlast, he']; rfl))] + rcases hs : evenSplitEquiv k ℓ 0 ⟨c', hc'⟩ with ⟨cp, j₀⟩ | p + · exfalso + have hval := congrArg + (fun z => ((evenSplitEquiv k ℓ 0).symm z).val + (Fin.last 0)) hs + rw [Equiv.symm_apply_apply] at hval + rw [evenSplitEquiv_symm_inl] at hval + rw [colouringSplit_symm_last] at hval + have hval' : c' (Fin.last 0) = Sum.inl j₀ := hval + exact Sum.inr_ne_inl (hlast.symm.trans hval') + · rw [Sum.elim_inr] + rw [show funTensorFun _ _ + (0 : ({c : MixedColouring k ℓ 0 // ¬ c.IsEven} → ℂ) + ⊗[ℂ] (Fin (2 * ℓ) → ℂ)) p = 0 from by + rw [map_zero] + rfl] + +-- As for the even basis vector, on the odd half. +/-- **The one-position odd basis vector is the unit-padded +standard odd basis vector.** -/ +theorem oddBasisVec_one (a : Fin (2 * ℓ)) : + oddBasisVec (⟨oneColourO k ℓ a, oneColourO_not_isEven a⟩ : + {c : MixedColouring k ℓ 1 // ¬ c.IsEven}) = + oddUnitPad (stdF ℓ a) := by + apply (colourPowerEquiv k ℓ 1).oddEquiv.injective + rw [show (colourPowerEquiv k ℓ 1).oddEquiv + (oddBasisVec (⟨oneColourO k ℓ a, + oneColourO_not_isEven a⟩ : + {c : MixedColouring k ℓ 1 // ¬ c.IsEven})) = + Pi.single ⟨oneColourO k ℓ a, oneColourO_not_isEven a⟩ 1 from + (colourPowerEquiv k ℓ 1).oddEquiv.apply_symm_apply _] + funext ⟨c', hc'⟩ + change _ = ((colourPowerEquiv k ℓ 1).oddEquiv + (oddUnitPad (stdF ℓ a)) ⟨c', hc'⟩) + change _ = (colourPowerStep k ℓ 0).oddEquiv + ((TensorProduct.congr + (colourPowerZero k ℓ).evenEquiv + (LinearEquiv.refl ℂ (Fin (2 * ℓ) → ℂ))) + ((1 : ℂ) ⊗ₜ[ℂ] stdF ℓ a), + (TensorProduct.congr + (colourPowerZero k ℓ).oddEquiv + (LinearEquiv.refl ℂ (Fin k → ℂ))) 0) ⟨c', hc'⟩ + rw [TensorProduct.congr_tmul, map_zero] + change _ = Sum.elim + (fun p => funTensorFun _ _ + (((colourPowerZero k ℓ).evenEquiv (1 : ℂ)) ⊗ₜ[ℂ] + (LinearEquiv.refl ℂ (Fin (2 * ℓ) → ℂ) (stdF ℓ a))) p) + (fun q => funTensorFun _ _ + (0 : ({c : MixedColouring k ℓ 0 // ¬ c.IsEven} → ℂ) + ⊗[ℂ] (Fin k → ℂ)) q) + ((Equiv.sumComm _ _).symm (oddSplitEquiv k ℓ 0 ⟨c', hc'⟩)) + rcases hlast : c' (Fin.last 0) with j | b + · -- Even colour at an odd one-position colouring: vacuous. + exfalso + refine hc' ⟨0, ?_⟩ + have hset : MixedColouring.oddSet c' = ∅ := by + apply Finset.eq_empty_iff_forall_notMem.mpr + intro p hp + rw [MixedColouring.oddSet, Finset.mem_filter] at hp + have hp0 : c' p = Sum.inl j := by + rw [Subsingleton.elim p (Fin.last 0)] + exact hlast + rw [hp0] at hp + exact Bool.noConfusion hp.2 + rw [hset] + rfl + · rw [oddSplit0_inr c' hc' b hlast] + rw [show ((Equiv.sumComm + ({c : MixedColouring k ℓ 0 // c.IsEven} × + Fin (2 * ℓ)) + ({c : MixedColouring k ℓ 0 // ¬ c.IsEven} × + Fin k)).symm + (Sum.inr (⟨MixedColouring.tail c', by + by_contra hcontra + exact hc' ((c'.isEven_succ_right b hlast).mpr + hcontra)⟩, b))) = + Sum.inl (⟨MixedColouring.tail c', by + by_contra hcontra + exact hc' ((c'.isEven_succ_right b hlast).mpr + hcontra)⟩, b) from rfl] + rw [Sum.elim_inl] + refine Eq.trans ?_ ((funTensorFun_tmul _ _ _).symm) + rw [show ((colourPowerZero k ℓ).evenEquiv (1 : ℂ)) + (⟨MixedColouring.tail c', by + by_contra hcontra + exact hc' ((c'.isEven_succ_right b hlast).mpr + hcontra)⟩, b).1 = 1 + from rfl] + rw [one_mul] + have hval : (Pi.single (⟨oneColourO k ℓ a, + oneColourO_not_isEven a⟩ : + {c : MixedColouring k ℓ 1 // ¬ c.IsEven}) (1 : ℂ) : + {c : MixedColouring k ℓ 1 // ¬ c.IsEven} → ℂ) + ⟨c', hc'⟩ = + (Pi.single a (1 : ℂ) : Fin (2 * ℓ) → ℂ) b := by + by_cases hab : b = a + · subst hab + rw [single_val_same ⟨oneColourO k ℓ b, + oneColourO_not_isEven b⟩ ⟨c', hc'⟩ + (oneColour_ext (show oneColourO k ℓ b 0 = + c' 0 from hlast.symm)), + Pi.single_eq_same] + · rw [single_val_ne ⟨oneColourO k ℓ a, + oneColourO_not_isEven a⟩ ⟨c', hc'⟩ + (fun he => hab (Sum.inr.inj + (show Sum.inr b = Sum.inr a from by + have he' : c' = oneColourO k ℓ a := he + rw [← hlast, he']; rfl))), + Pi.single_eq_of_ne hab] + exact hval.trans rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OrbitCard.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OrbitCard.lean new file mode 100644 index 0000000000..58bf861f66 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OrbitCard.lean @@ -0,0 +1,222 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircuitCount + +/-! +# The orbit count is the number of orbits + +`orbitCount` is defined as the number of cycles plus the number of +fixed points, which is convenient for computing signs but says +nothing directly about orbits. This file identifies it with the +cardinality of the quotient by "lies on the same cycle": an orbit is +either the support of one of the permutation's cycles or a single +fixed point, and those two possibilities are exclusive and +exhaustive. + +That identification is what lets two orbit counts be compared when +their underlying sets are different — a walk on flags against a +rotation on labels, say — since a bijection of quotients is then +enough. +-/ + +@[expose] public section + +namespace RS + +open Equiv Equiv.Perm + +variable {β : Type} + +/-- **The orbits of a permutation**, as a quotient of its ground +set. -/ +abbrev Orbits (π : Perm β) : Type := Quotient (SameCycle.setoid π) + +/-- The orbit space of a permutation of a finite type is finite. -/ +instance [Finite β] (π : Perm β) : Finite (Orbits π) := by + classical + let := Fintype.ofFinite β + exact + Quotient.finite _ + +/-- Hence it carries a fintype structure. -/ +noncomputable instance [Fintype β] (π : Perm β) : Fintype (Orbits π) := + Fintype.ofFinite _ + +/-- And orbits can be compared, classically. -/ +noncomputable instance (π : Perm β) : DecidableEq (Orbits π) := + Classical.decEq _ + +/-- Two points give the same orbit exactly when they lie on a common +cycle. -/ +theorem orbit_eq_iff {π : Perm β} {x y : β} : + (Quotient.mk (SameCycle.setoid π) x + = Quotient.mk (SameCycle.setoid π) y) ↔ π.SameCycle x y := + Quotient.eq + +/-! ### A fixed point's orbit is a singleton -/ + +/-- Nothing else lies on a fixed point's cycle. -/ +theorem eq_of_sameCycle_of_fixed {π : Perm β} {x y : β} + (hx : π x = x) (h : π.SameCycle x y) : y = x := by + obtain ⟨i, hi⟩ := h + rw [← hi, zpow_apply_eq_self_of_apply_eq_self hx i] + +/-- A point on the same cycle as a moved point is moved. -/ +theorem apply_ne_of_sameCycle {π : Perm β} {x y : β} + (hx : π x ≠ x) (h : π.SameCycle x y) : π y ≠ y := by + intro hy + exact hx (eq_of_sameCycle_of_fixed hy h.symm ▸ hy) + +/-! ### The orbit map -/ + +/-- The orbit of a point, named by its cycle when the point moves +and by the point itself when it does not. -/ +noncomputable def orbitName [Fintype β] [DecidableEq β] (π : Perm β) + (x : β) : + π.cycleFactorsFinset ⊕ (Function.fixedPoints π) := + if h : π x = x then Sum.inr ⟨x, h⟩ + else Sum.inl ⟨π.cycleOf x, + cycleOf_mem_cycleFactorsFinset_iff.mpr (mem_support.mpr h)⟩ + +/-- Points on the same cycle get the same name, so the naming +descends to orbits. -/ +theorem orbitName_congr [Fintype β] [DecidableEq β] {π : Perm β} {x y : β} + (h : π.SameCycle x y) : orbitName π x = orbitName π y := by + unfold orbitName + by_cases hx : π x = x + · rw [dite_eq_left hx, dite_eq_left (eq_of_sameCycle_of_fixed hx h ▸ hx)] + exact congrArg Sum.inr + (Subtype.ext (eq_of_sameCycle_of_fixed hx h).symm) + · rw [dite_eq_right hx, dite_eq_right (apply_ne_of_sameCycle hx h)] + exact congrArg Sum.inl (Subtype.ext h.cycleOf_eq) + +/-- A chosen point on one of the permutation's cycles. -/ +noncomputable def cycleRep [Fintype β] [DecidableEq β] {π : Perm β} + (c : π.cycleFactorsFinset) : β := + ((mem_cycleFactorsFinset_iff.mp c.prop).1.nonempty_support).choose + +/-- The chosen point of a cycle lies on it. -/ +theorem cycleRep_mem [Fintype β] [DecidableEq β] {π : Perm β} + (c : π.cycleFactorsFinset) : + cycleRep c ∈ c.val.support := + ((mem_cycleFactorsFinset_iff.mp c.prop).1.nonempty_support).choose_spec + +/-- **The orbits are the cycles together with the fixed points.** -/ +noncomputable def orbitsEquiv [Fintype β] [DecidableEq β] (π : Perm β) : + Orbits π ≃ π.cycleFactorsFinset ⊕ (Function.fixedPoints π) where + toFun := Quotient.lift (orbitName π) (fun _ _ h => orbitName_congr h) + invFun := fun + | Sum.inl c => Quotient.mk (SameCycle.setoid π) + (cycleRep c) + | Sum.inr x => Quotient.mk (SameCycle.setoid π) x.val + left_inv := by + refine Quotient.ind (fun x => ?_) + change (match orbitName π x with + | Sum.inl c => Quotient.mk (SameCycle.setoid π) _ + | Sum.inr y => Quotient.mk (SameCycle.setoid π) y.val) + = Quotient.mk (SameCycle.setoid π) x + unfold orbitName + by_cases hx : π x = x + · rw [dite_eq_left hx] + · rw [dite_eq_right hx] + refine Quotient.sound ?_ + have hmem := cycleRep_mem + (⟨π.cycleOf x, cycleOf_mem_cycleFactorsFinset_iff.mpr + (mem_support.mpr hx)⟩ : π.cycleFactorsFinset) + rw [mem_support_cycleOf_iff] at hmem + exact hmem.1.symm + right_inv := by + rintro (⟨c, hc⟩ | ⟨x, hx⟩) + · have hcyc : c.IsCycle := (mem_cycleFactorsFinset_iff.mp hc).1 + have hmem := cycleRep_mem (⟨c, hc⟩ : π.cycleFactorsFinset) + set y := cycleRep (⟨c, hc⟩ : π.cycleFactorsFinset) with hy + have hyc : π.cycleOf y = c := + (cycle_is_cycleOf hmem hc).symm + have hyne : π y ≠ y := by + have : y ∈ π.support := by + rw [← cycleOf_mem_cycleFactorsFinset_iff, hyc] + exact hc + exact mem_support.mp this + change orbitName π y = Sum.inl ⟨c, hc⟩ + unfold orbitName + rw [dite_eq_right hyne] + exact congrArg Sum.inl (Subtype.ext hyc) + · have hx' : π x = x := hx + change orbitName π x = Sum.inr ⟨x, hx⟩ + unfold orbitName + rw [dite_eq_left hx'] + +/-- **The orbit count is the number of orbits.** -/ +theorem orbitCount_eq_card_orbits [Fintype β] [DecidableEq β] + (π : Perm β) : + orbitCount π = Fintype.card (Orbits π) := by + rw [Fintype.card_congr (orbitsEquiv π), Fintype.card_sum] + unfold orbitCount + congr 1 + · rw [Equiv.Perm.cycleType, Multiset.card_map] + exact (Fintype.card_coe _).symm + +/-! ### Transporting orbits along a step-wise map + +A map that moves each point within a single orbit of the target +permutation carries orbits to orbits, whatever it does inside them. +This is how a contracted matching's rotation is compared with the +original's: one step of the contracted rotation is several steps of +the original. +-/ + +/-- A map whose one-step images stay in one orbit respects the orbit +relation. -/ +theorem sameCycle_of_step {γ : Type} {π : Perm β} {ρ : Perm γ} + (f : γ → β) (hstep : ∀ x, π.SameCycle (f x) (f (ρ x))) + {x y : γ} (h : ρ.SameCycle x y) : π.SameCycle (f x) (f y) := by + have hnat : ∀ (z : γ) (m : ℕ), π.SameCycle (f z) (f ((ρ ^ m) z)) := by + intro z m + induction m with + | zero => exact Equiv.Perm.SameCycle.refl π (f z) + | succ m ih => + refine ih.trans ?_ + have hs := hstep ((ρ ^ m) z) + rwa [show ρ ((ρ ^ m) z) = (ρ ^ (m + 1)) z from by + rw [pow_succ']; rfl] at hs + obtain ⟨n, hn⟩ := h + subst hn + obtain ⟨m, hm | hm⟩ := Int.eq_nat_or_neg n + · subst hm + rw [zpow_natCast] + exact hnat x m + · subst hm + have h1 := hnat ((ρ ^ (-(m : ℤ))) x) m + rw [show (ρ ^ (m : ℕ)) ((ρ ^ (-(m : ℤ))) x) = x from by + rw [← zpow_natCast, ← Equiv.Perm.mul_apply, ← zpow_add] + simp] at h1 + exact h1.symm + +/-! ### The orbits partition the ground set + +Grouping the ground set by orbit is what lets a construction be +carried out one orbit at a time — gluing an interface component by +component, say, rather than label by label. +-/ + +/-- **The orbit count does not read the decidability instance.** -/ +theorem orbitCount_congr_decEq [Fintype β] (d₁ d₂ : DecidableEq β) + (π : Perm β) : + @orbitCount β _ d₁ π = @orbitCount β _ d₂ π := by + rw [@orbitCount_eq_card_orbits β _ d₁ π, + @orbitCount_eq_card_orbits β _ d₂ π] + +/-- **Orbit counts agree along a bijection of orbit sets.** -/ +theorem orbitCount_eq_of_orbitsEquiv [Fintype β] [DecidableEq β] + {γ : Type} [Fintype γ] [DecidableEq γ] {π : Perm β} {ρ : Perm γ} + (e : Orbits π ≃ Orbits ρ) : orbitCount π = orbitCount ρ := by + rw [orbitCount_eq_card_orbits, orbitCount_eq_card_orbits, + Fintype.card_congr e] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OutSignEdges.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OutSignEdges.lean new file mode 100644 index 0000000000..bdfb3db833 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OutSignEdges.lean @@ -0,0 +1,120 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RepFlag + +/-! +# Per-edge factoring of the out-sign product + +The subtype product of odd-partner signs over outgoing participating +flags equals the edge-indexed product: each participating edge +contributes the sign of its (pairing-constant) colour exactly once, +and non-participating edges contribute 1 on both sides. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable (W : ClosedFragment) (F : EdgeSubset W) {ℓ : ℕ} + {κ : F.TransitionSystem} (o : κ.Orientation) (φ : F.OddColouring ℓ) + +/-- Totalized per-flag sign contribution: the odd-partner sign for +outgoing participating flags, 1 otherwise. -/ +private noncomputable def outSignFun (x : W.Flag) : ℤ := + if h : x ∈ F.flags then + if o.isOut x = true then oddPartnerSign ℓ (φ.val ⟨x, h⟩) else 1 + else 1 + +private theorem outSignFun_of_mem {x : W.Flag} (hx : x ∈ F.flags) : + outSignFun W F o φ x = + if o.isOut x = true then oddPartnerSign ℓ (φ.val ⟨x, hx⟩) else 1 := + dite_eq_left hx + +private theorem outSignFun_of_not_mem {x : W.Flag} (hx : x ∉ F.flags) : + outSignFun W F o φ x = 1 := + dite_eq_right hx + +/-- The subtype product over F.flags equals the full product of the +totalized function. -/ +private theorem prod_subtype_eq_prod_total : + (∏ f : {f : W.Flag // f ∈ F.flags}, + (if o.isOut f.val = true then oddPartnerSign ℓ (φ.val f) else 1)) = + ∏ x : W.Flag, outSignFun W F o φ x := by + have hbody : ∀ f : {f : W.Flag // f ∈ F.flags}, + (if o.isOut f.val = true then oddPartnerSign ℓ (φ.val f) else 1) = + outSignFun W F o φ f.val := + fun f => (outSignFun_of_mem W F o φ f.prop).symm + simp_rw [hbody] + rw [prod_coe_sort] + exact prod_subset (subset_univ _) (fun x _ hx => + outSignFun_of_not_mem W F o φ hx) + +/-- Per-edge factor collapse: the product of the two half-slot +contributions equals the single representative contribution. -/ +private theorem edge_factor (i : Fin (edgeCount W)) : + outSignFun W F o φ + ((starFlagEnum W).symm (Fin.castAdd (edgeCount W) i)) * + outSignFun W F o φ + ((starFlagEnum W).symm (Fin.natAdd (edgeCount W) i)) = + if h : (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i) ∈ F.flags + then oddPartnerSign ℓ + (φ.val ⟨(starFlagEnum W).symm (Fin.castAdd (edgeCount W) i), h⟩) + else 1 := by + set f₀ := (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i) + set f₁ := (starFlagEnum W).symm (Fin.natAdd (edgeCount W) i) + have hpair : W.pairing f₀ = f₁ := pairing_starFlagEnum_symm W i + by_cases hmem : f₀ ∈ F.flags + · -- Both flags participate + have hmem₁ : f₁ ∈ F.flags := hpair ▸ F.pairing_mem _ hmem + have hsub : (⟨W.pairing f₀, F.pairing_mem _ hmem⟩ : + {f // f ∈ F.flags}) = ⟨f₁, hmem₁⟩ := + Subtype.ext hpair + have hφeq : φ.val ⟨f₁, hmem₁⟩ = φ.val ⟨f₀, hmem⟩ := + (congrArg φ.val hsub).symm.trans (φ.prop ⟨f₀, hmem⟩) + have hflip : o.isOut f₁ = !o.isOut f₀ := + hpair ▸ o.pairing_flip _ hmem + rw [outSignFun_of_mem W F o φ hmem, + outSignFun_of_mem W F o φ hmem₁, dite_eq_left hmem] + by_cases hb : o.isOut f₀ = true + · -- f₀ outgoing, f₁ incoming + have hb₁ : ¬ o.isOut f₁ = true := by + rw [hflip, hb]; decide + rw [ite_eq_left hb, ite_eq_right hb₁, mul_one] + · -- f₀ incoming, f₁ outgoing + have hb₁ : o.isOut f₁ = true := by + have ho : o.isOut f₀ = false := + Bool.eq_false_iff.mpr (by simpa using hb) + rw [hflip, ho]; rfl + rw [ite_eq_right hb, ite_eq_left hb₁, one_mul] + exact congrArg (oddPartnerSign ℓ) hφeq + · -- Neither flag participates + have hmem₁ : f₁ ∉ F.flags := hpair ▸ F.pairing_not_mem hmem + rw [outSignFun_of_not_mem W F o φ hmem, + outSignFun_of_not_mem W F o φ hmem₁, + dite_eq_right hmem, mul_one] + +/-- Each participating edge has exactly one outgoing flag; the +subtype product of odd-partner signs equals the edge-indexed +product. -/ +theorem prod_out_sign_eq_prod_edges : + (∏ f : {f : W.Flag // f ∈ F.flags}, + (if o.isOut f.val = true then oddPartnerSign ℓ (φ.val f) else 1)) = + ∏ i : Fin (edgeCount W), + (if h : (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i) ∈ F.flags + then oddPartnerSign ℓ + (φ.val ⟨(starFlagEnum W).symm (Fin.castAdd (edgeCount W) i), h⟩) + else 1) := by + rw [prod_subtype_eq_prod_total W F o φ, + ← Equiv.prod_comp (starFlagEnum W).symm (outSignFun W F o φ), + Fin.prod_univ_add, ← Finset.prod_mul_distrib] + exact Finset.prod_congr rfl (fun i _ => edge_factor W F o φ i) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairEnum.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairEnum.lean new file mode 100644 index 0000000000..ce0eeb0df9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairEnum.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists + +/-! +# The pair enumeration + +The Definition 5 odd list at a vertex is, order-exactly, the +per-flag value map over an explicit flag list: the incoming flags +in the fixed order, each followed by its match. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {α : Type} {W : Fragment α} {F : EdgeSubset W} {ℓ : ℕ} + {κ : F.TransitionSystem} + +open Classical in +/-- The Definition 5 per-flag odd value: outgoing flags carry the +partner of their colour, incoming flags the colour itself. -/ +noncomputable def defFiveValue (o : κ.Orientation) + (φ : F.OddColouring ℓ) + (f : {f : W.Flag // f ∈ F.flags}) : Fin (2 * ℓ) := + if o.isOut f.val = true then oddPartner ℓ (φ.val f) + else φ.val f + +/-- Incoming flags are incoming. -/ +theorem isOut_of_mem_inFlagsAt (o : κ.Orientation) + {v : W.Vertex} {f : W.Flag} + (hf : f ∈ F.inFlagsAt o v) : o.isOut f = false := by + let := W.flagOrder + let := Classical.dec + unfold EdgeSubset.inFlagsAt at hf + exact (Finset.mem_filter.mp + ((Finset.mem_sort _).mp hf)).2.2 + +private theorem map_flatMap' {γ δ ε : Type*} (l : List γ) + (g : γ → List δ) (h : δ → ε) : + (l.flatMap g).map h = l.flatMap (fun x => (g x).map h) := by + induction l with + | nil => rfl + | cons a t ih => + rw [List.flatMap_cons, List.flatMap_cons, List.map_append, + ih] + +private theorem flatMap_congr' {γ δ : Type*} (l : List γ) + (g₁ g₂ : γ → List δ) (h : ∀ x ∈ l, g₁ x = g₂ x) : + l.flatMap g₁ = l.flatMap g₂ := by + induction l with + | nil => rfl + | cons a t ih => + rw [List.flatMap_cons, List.flatMap_cons, + h a List.mem_cons_self, + ih (fun x hx => h x (List.mem_cons_of_mem a hx))] + +open Classical in +/-- The flag list underlying the odd list at a vertex: the +incoming flags in the fixed order, each followed by its match. -/ +noncomputable def pairFlagList (o : κ.Orientation) + (v : W.Vertex) : List {f : W.Flag // f ∈ F.flags} := + ((F.inFlagsAt o v).attachWith (· ∈ F.flags) + (fun _ hf => F.mem_of_mem_inFlagsAt hf)).flatMap + (fun f => [f, ⟨κ.match_ f.val, κ.match_mem _ f.prop⟩]) + +open Classical in +/-- **The odd list is the value map of the pair enumeration**, +order-exactly. -/ +theorem oddListAt_eq_map (o : κ.Orientation) + (φ : F.OddColouring ℓ) (v : W.Vertex) : + F.oddListAt o φ v = + (pairFlagList (F := F) o v).map (defFiveValue o φ) := by + rw [EdgeSubset.oddListAt, pairFlagList, map_flatMap'] + refine flatMap_congr' _ _ _ ?_ + intro f hf + have hfin : f.val ∈ F.inFlagsAt o v := by + rw [show (F.inFlagsAt o v).attachWith (· ∈ F.flags) + (fun _ hf' => F.mem_of_mem_inFlagsAt hf') = + (F.inFlagsAt o v).pmap Subtype.mk + (fun _ hf' => F.mem_of_mem_inFlagsAt hf') from rfl] + at hf + obtain ⟨a, ha, hfa⟩ := List.mem_pmap.mp hf + rw [← hfa] + exact ha + have hin : o.isOut f.val = false := + isOut_of_mem_inFlagsAt o hfin + have hout : o.isOut (κ.match_ f.val) = true := by + rw [o.match_flip f.val f.prop, hin] + rfl + have h1 : defFiveValue o φ f = φ.val f := by + rw [defFiveValue, hin] + rw [ite_eq_right Bool.false_ne_true] + have h2 : defFiveValue o φ + ⟨κ.match_ f.val, κ.match_mem _ f.prop⟩ = + oddPartner ℓ (φ.val + ⟨κ.match_ f.val, κ.match_mem _ f.prop⟩) := by + rw [defFiveValue, ite_eq_left hout] + change F.oddPairFn κ φ f = _ + rw [EdgeSubset.oddPairFn, List.map_cons, List.map_cons, + List.map_nil, h1, h2] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairList.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairList.lean new file mode 100644 index 0000000000..1762f1b0db --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairList.lean @@ -0,0 +1,261 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ChainLists +public import LeanPool.RegtsSevenster.RS.Common.FinSlots + +/-! +# Membership and uniqueness in the edge and oriented enumerations + +The edge and oriented pair lists enumerate each participating flag +exactly once. The slot helpers identify the two ends of each edge. +-/ + +@[expose] public section + +namespace RS + +open Finset + +/-! ### Edge enumeration -/ + +/-- The attached edge list for edgePairList is duplicate-free. -/ +theorem attachWith_partEdges_nodup (W : ClosedFragment) + (F : EdgeSubset W) : + ((partEdges W F).attachWith (· ∈ edgeIndexSet W F) + (fun _ hi => (Finset.mem_sort _).mp hi)).Nodup := by + refine List.Nodup.pmap (fun a _ b _ h => Subtype.mk.inj h) + (Finset.sort_nodup _ _) + +/-- The two slots of an edge give distinct flags. -/ +theorem castAdd_flag_ne_natAdd_flag (W : ClosedFragment) + (i : Fin (edgeCount W)) : + (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i) ≠ + (starFlagEnum W).symm (Fin.natAdd (edgeCount W) i) := + fun h => castAdd_ne_natAdd i ((starFlagEnum W).symm.injective h) + +open Classical in +/-- **The edge-interleaved enumeration is duplicate-free.** -/ +theorem edgePairList_nodup (W : ClosedFragment) + (F : EdgeSubset W) : + (edgePairList W F).Nodup := by + rw [edgePairList, List.nodup_flatMap] + constructor + · intro i _ + refine List.nodup_cons.mpr ⟨?_, List.nodup_singleton _⟩ + intro hmem + rw [List.mem_singleton] at hmem + have hval : (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i.val) = + (starFlagEnum W).symm (Fin.natAdd (edgeCount W) i.val) := + congrArg (fun z : {f : W.Flag // f ∈ F.flags} => z.val) hmem + exact castAdd_flag_ne_natAdd_flag W i.val hval + · have hnd := attachWith_partEdges_nodup W F + refine List.Pairwise.imp_of_mem ?_ + (List.Pairwise.imp (fun {a b} h => h) hnd) + intro i₁ i₂ _ _ hne x hx₁ hx₂ + -- x appears in [rep i₁, partner i₁] and [rep i₂, partner i₂] + -- Extract which slot x occupies in each list + have slot_of_mem : ∀ (i : {i : Fin (edgeCount W) // i ∈ edgeIndexSet W F}), + x ∈ [⟨(starFlagEnum W).symm (Fin.castAdd (edgeCount W) i.val), + repMem_of_partEdge i.prop⟩, + ⟨(starFlagEnum W).symm (Fin.natAdd (edgeCount W) i.val), + partnerMem_of_partEdge i.prop⟩] → + starFlagEnum W x.val = Fin.castAdd (edgeCount W) i.val ∨ + starFlagEnum W x.val = Fin.natAdd (edgeCount W) i.val := by + intro i hmem + rcases List.mem_cons.mp hmem with h | h + · left; rw [show x.val = (starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i.val) from + congrArg Subtype.val h, _root_.Equiv.apply_symm_apply] + · right + rw [List.mem_singleton] at h + rw [show x.val = (starFlagEnum W).symm + (Fin.natAdd (edgeCount W) i.val) from + congrArg Subtype.val h, _root_.Equiv.apply_symm_apply] + obtain h₁ | h₁ := slot_of_mem i₁ hx₁ <;> + obtain h₂ | h₂ := slot_of_mem i₂ hx₂ + · -- castAdd i₁ = castAdd i₂ + have heq : Fin.castAdd (edgeCount W) i₁.val = + Fin.castAdd (edgeCount W) i₂.val := + h₁.symm.trans h₂ + exact hne (Subtype.ext (Fin.castAdd_injective _ _ heq)) + · -- castAdd i₁ = natAdd i₂ + have h := congrArg Fin.val (h₁.symm.trans h₂) + simp only [Fin.val_castAdd, Fin.val_natAdd] at h; omega + · -- natAdd i₁ = castAdd i₂ + have h := congrArg Fin.val (h₁.symm.trans h₂) + simp only [Fin.val_castAdd, Fin.val_natAdd] at h; omega + · -- natAdd i₁ = natAdd i₂ + have heq : Fin.natAdd (edgeCount W) i₁.val = + Fin.natAdd (edgeCount W) i₂.val := + h₁.symm.trans h₂ + exact hne (Subtype.ext (Fin.natAdd_injective _ _ heq)) + +open Classical in +/-- **Every participating flag appears in the edge-interleaved list.** -/ +theorem mem_edgePairList (W : ClosedFragment) + (F : EdgeSubset W) (x : {f : W.Flag // f ∈ F.flags}) : + x ∈ edgePairList W F := by + rw [edgePairList, List.mem_flatMap] + set q := starFlagEnum W x.val with hq_def + by_cases hlow : q.val < edgeCount W + · -- x is on the low (rep) half + set i : Fin (edgeCount W) := ⟨q.val, hlow⟩ with hi_def + have hslot : Fin.castAdd (edgeCount W) i = q := Fin.ext rfl + have hmem : (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i) = + x.val := by + rw [hslot, hq_def, _root_.Equiv.symm_apply_apply] + have hei : i ∈ edgeIndexSet W F := by + rw [edgeIndexSet, Finset.mem_filter] + exact ⟨Finset.mem_univ _, hmem ▸ x.prop⟩ + have hsort : i ∈ (partEdges W F) := by + rw [partEdges, Finset.mem_sort]; exact hei + refine ⟨⟨i, hei⟩, ?_, ?_⟩ + · rw [show (partEdges W F).attachWith (· ∈ edgeIndexSet W F) + (fun _ hi => (Finset.mem_sort _).mp hi) = + (partEdges W F).pmap Subtype.mk + (fun _ hi => (Finset.mem_sort _).mp hi) from rfl] + exact List.mem_pmap.mpr ⟨i, hsort, Subtype.ext rfl⟩ + · exact List.mem_cons.mpr (Or.inl (Subtype.ext hmem.symm)) + · -- x is on the high (partner) half + have hge : q.val ≥ edgeCount W := Nat.le_of_not_lt hlow + have hlt : q.val - edgeCount W < edgeCount W := by + have := q.isLt; omega + set i : Fin (edgeCount W) := ⟨q.val - edgeCount W, hlt⟩ with hi_def + have hslot : Fin.natAdd (edgeCount W) i = q := + Fin.ext (by change edgeCount W + (q.val - edgeCount W) = q.val; omega) + have hmem : (starFlagEnum W).symm (Fin.natAdd (edgeCount W) i) = x.val := by + rw [hslot, hq_def, _root_.Equiv.symm_apply_apply] + -- The partner of x.val is the rep flag for this edge + have hpair : (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i) = + W.pairing x.val := by + rw [← hmem, ← pairing_starFlagEnum_symm W i, W.pairing_invol] + have hei : i ∈ edgeIndexSet W F := by + rw [edgeIndexSet, Finset.mem_filter] + exact ⟨Finset.mem_univ _, hpair ▸ F.pairing_mem _ x.prop⟩ + have hsort : i ∈ (partEdges W F) := by + rw [partEdges, Finset.mem_sort]; exact hei + refine ⟨⟨i, hei⟩, ?_, ?_⟩ + · rw [show (partEdges W F).attachWith (· ∈ edgeIndexSet W F) + (fun _ hi => (Finset.mem_sort _).mp hi) = + (partEdges W F).pmap Subtype.mk + (fun _ hi => (Finset.mem_sort _).mp hi) from rfl] + exact List.mem_pmap.mpr ⟨i, hsort, Subtype.ext rfl⟩ + · exact List.mem_cons.mpr (Or.inr (List.mem_singleton.mpr (Subtype.ext + hmem.symm))) + +/-! ### Oriented enumeration -/ + +open Classical in +/-- **The oriented enumeration is duplicate-free.** -/ +theorem orientedPairList_nodup (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) : + (orientedPairList W F o).Nodup := by + rw [orientedPairList, List.nodup_flatMap] + constructor + · intro i _ + -- Each block is either [partner, rep] or [rep, partner] + by_cases ho : o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i.val)) = true + · rw [ite_eq_left ho] + refine List.nodup_cons.mpr ⟨?_, List.nodup_singleton _⟩ + intro hmem + rw [List.mem_singleton] at hmem + have hval : (starFlagEnum W).symm (Fin.natAdd (edgeCount W) i.val) = + (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i.val) := + congrArg (fun z : {f : W.Flag // f ∈ F.flags} => z.val) hmem + exact (castAdd_flag_ne_natAdd_flag W i.val hval.symm) + · rw [ite_eq_right ho] + refine List.nodup_cons.mpr ⟨?_, List.nodup_singleton _⟩ + intro hmem + rw [List.mem_singleton] at hmem + have hval : (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i.val) = + (starFlagEnum W).symm (Fin.natAdd (edgeCount W) i.val) := + congrArg (fun z : {f : W.Flag // f ∈ F.flags} => z.val) hmem + exact castAdd_flag_ne_natAdd_flag W i.val hval + · -- Disjoint blocks: same as edgePairList since both blocks contain the same + -- two flags + have hnd := attachWith_partEdges_nodup W F + refine List.Pairwise.imp_of_mem ?_ + (List.Pairwise.imp (fun {a b} h => h) hnd) + intro i₁ i₂ _ _ hne x hx₁ hx₂ + -- Extract slot from membership, regardless of if-branch + have slot_of_mem_oriented : ∀ (i : {i : Fin (edgeCount W) // i ∈ + edgeIndexSet W F}), + x ∈ (if o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i.val)) = true then + [⟨(starFlagEnum W).symm (Fin.natAdd (edgeCount W) i.val), + partnerMem_of_partEdge i.prop⟩, + ⟨(starFlagEnum W).symm (Fin.castAdd (edgeCount W) i.val), + repMem_of_partEdge i.prop⟩] + else + [⟨(starFlagEnum W).symm (Fin.castAdd (edgeCount W) i.val), + repMem_of_partEdge i.prop⟩, + ⟨(starFlagEnum W).symm (Fin.natAdd (edgeCount W) i.val), + partnerMem_of_partEdge i.prop⟩]) → + starFlagEnum W x.val = Fin.castAdd (edgeCount W) i.val ∨ + starFlagEnum W x.val = Fin.natAdd (edgeCount W) i.val := by + intro i hmem + by_cases ho : o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i.val)) = true + · rw [ite_eq_left ho] at hmem + rcases List.mem_cons.mp hmem with h | h + · right + rw [show x.val = (starFlagEnum W).symm + (Fin.natAdd (edgeCount W) i.val) from + congrArg Subtype.val h, _root_.Equiv.apply_symm_apply] + · left + rw [List.mem_singleton] at h + rw [show x.val = (starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i.val) from + congrArg Subtype.val h, _root_.Equiv.apply_symm_apply] + · rw [ite_eq_right ho] at hmem + rcases List.mem_cons.mp hmem with h | h + · left + rw [show x.val = (starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i.val) from + congrArg Subtype.val h, _root_.Equiv.apply_symm_apply] + · right + rw [List.mem_singleton] at h + rw [show x.val = (starFlagEnum W).symm + (Fin.natAdd (edgeCount W) i.val) from + congrArg Subtype.val h, _root_.Equiv.apply_symm_apply] + obtain h₁ | h₁ := slot_of_mem_oriented i₁ hx₁ <;> + obtain h₂ | h₂ := slot_of_mem_oriented i₂ hx₂ + · exact hne (Subtype.ext (Fin.castAdd_injective _ _ (h₁.symm.trans h₂))) + · have h := congrArg Fin.val (h₁.symm.trans h₂) + simp only [Fin.val_castAdd, Fin.val_natAdd] at h; omega + · have h := congrArg Fin.val (h₁.symm.trans h₂) + simp only [Fin.val_castAdd, Fin.val_natAdd] at h; omega + · exact hne (Subtype.ext (Fin.natAdd_injective _ _ (h₁.symm.trans h₂))) + +open Classical in +/-- **Every participating flag appears in the oriented list.** -/ +theorem mem_orientedPairList (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) (x : {f : W.Flag // f ∈ F.flags}) : + x ∈ orientedPairList W F o := by + -- The oriented list contains the same elements as edgePairList + -- (same two flags per edge, just possibly swapped) + rw [orientedPairList, List.mem_flatMap] + have hep := mem_edgePairList W F x + rw [edgePairList, List.mem_flatMap] at hep + obtain ⟨i, hi, hx⟩ := hep + refine ⟨i, hi, ?_⟩ + by_cases ho : o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i.val)) = true + · rw [ite_eq_left ho] + rcases List.mem_cons.mp hx with h | h + · exact List.mem_cons.mpr (Or.inr (List.mem_singleton.mpr h)) + · rw [List.mem_singleton] at h + exact List.mem_cons.mpr (Or.inl h) + · rw [ite_eq_right ho] + exact hx + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ParameterModel.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ParameterModel.lean new file mode 100644 index 0000000000..207ec42a5d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ParameterModel.lean @@ -0,0 +1,156 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortPerm + +/-! +# The parameter value over the model + +Threading the transports through the factored parameter value: the +argument of the cap functional becomes a model-side vector — the +assembled star vector acted on by the sort's model permutation word +and the degree-sum cast — pushed forward once. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open Functor.LaxMonoidal Functor.OplaxMonoidal + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} +variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) +variable (e' : P.ω.obj (SkeinObj.mk 1) ⟶ stdSuperPair k ℓ) + +/-- The model action of a permutation: trivial at arity zero, +the braiding word of the adjacent-transposition word above. -/ +noncomputable def modelPermMap : + {n : ℕ} → (σ : _root_.Equiv.Perm (Fin n)) → + (superPow (stdSuperPair k ℓ) n ⟶ superPow (stdSuperPair k ℓ) n) + | 0, _ => 𝟙 _ + | _ + 1, σ => powBraidWord (stdSuperPair k ℓ) (adjWord σ) + +/-- The permutation intertwining at every arity. -/ +theorem stdToOmega_bmc_perm_all : + ∀ (n : ℕ) (σ : _root_.Equiv.Perm (Fin n)), + letI := P.braided + stdToOmega f P e n ≫ P.ω.map (bundleMapClass f + (σ : Fin n ≃ Fin n)) = + modelPermMap σ ≫ stdToOmega f P e n + | 0, σ => by + let := P.braided + rw [show (σ : Fin 0 ≃ Fin 0) = + _root_.Equiv.refl (Fin 0) from + Subsingleton.elim _ _] + rw [show bundleMapClass f (_root_.Equiv.refl (Fin 0)) = + 𝟙 (SkeinObj.mk 0 : SkeinObj f) from + bundleMapClass_refl f 0] + rw [show P.ω.map (𝟙 (SkeinObj.mk 0 : SkeinObj f)) = + 𝟙 (P.ω.obj (SkeinObj.mk 0)) from P.ω.map_id _] + change stdToOmega f P e 0 ≫ 𝟙 _ = + 𝟙 _ ≫ stdToOmega f P e 0 + rw [Category.comp_id, Category.id_comp] + | n + 1, σ => stdToOmega_bmc_perm f P e σ + +-- The parameter is rewritten over the model, so the +-- star vector, the sort word and the degree-sum recast all unfold +-- in one term. +/-- **The parameter value over the model**: the cap functional +evaluated on the transported model vector — the assembled star +vector, permuted by the sort word and recast along the degree +sum. -/ +theorem parameter_model (W : ClosedFragment) + (hee' : (e' ≫ e : P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk 1)) = 𝟙 _) : + letI := P.braided + f.val W = circleVal f ^ W.circles * + omegaFun f P (bundleCapClass f (edgeCount W)) + (((stdToOmega f P e (edgeCount W + edgeCount W)) : + SuperVect.Hom _ _).evenMap + (((eqToHom (congrArg (superPow (stdSuperPair k ℓ)) + (degList_sum (starAssignEnum W))) : + superPow (stdSuperPair k ℓ) + ((degList (starAssignEnum W)).sum) ⟶ + superPow (stdSuperPair k ℓ) + (edgeCount W + edgeCount W)) : + SuperVect.Hom _ _).evenMap + (((modelPermMap (sortSplitPerm W)) : + SuperVect.Hom _ _).evenMap + (modelStarVec f P e' + (degList (starAssignEnum W)))))) := by + let := P.braided + rw [parameter_star_factor f P W] + refine congrArg (fun z => circleVal f ^ W.circles * + omegaFun f P (bundleCapClass f (edgeCount W)) z) ?_ + -- Replace the assembled vector by its model form. + rw [show omegaStarVec f P (degList (starAssignEnum W)) = + ((stdToOmega f P e + ((degList (starAssignEnum W)).sum)) : + SuperVect.Hom _ _).evenMap + (modelStarVec f P e' (degList (starAssignEnum W))) + from (stdToOmega_modelStarVec f P e e' hee' _).symm] + -- Split the sort bundle map. + have hsplit := (congrArg (fun z : + ((SkeinObj.mk ((degList (starAssignEnum W)).sum) : + SkeinObj f) ⟶ + SkeinObj.mk (edgeCount W + edgeCount W)) => + P.ω.map z) (bmc_sort_split f W)).trans + (P.ω.map_comp + (bundleMapClass f ((sortSplitPerm W) : + Fin ((degList (starAssignEnum W)).sum) ≃ + Fin ((degList (starAssignEnum W)).sum))) + (bundleMapClass f (finCongr + (degList_sum (starAssignEnum W))))) + refine Eq.trans (congrArg (fun z : + (P.ω.obj (SkeinObj.mk + ((degList (starAssignEnum W)).sum)) ⟶ + P.ω.obj (SkeinObj.mk + (edgeCount W + edgeCount W))) => + (z : SuperVect.Hom _ _).evenMap + ((stdToOmega f P e + ((degList (starAssignEnum W)).sum) : + SuperVect.Hom _ _).evenMap + (modelStarVec f P e' + (degList (starAssignEnum W))))) hsplit) ?_ + -- Swap the permutation across the transport. + have hperm := congrArg (fun z : + (superPow (stdSuperPair k ℓ) + ((degList (starAssignEnum W)).sum) ⟶ + P.ω.obj (SkeinObj.mk + ((degList (starAssignEnum W)).sum))) => + (z : SuperVect.Hom _ _).evenMap + (modelStarVec f P e' (degList (starAssignEnum W)))) + (stdToOmega_bmc_perm_all f P e + ((degList (starAssignEnum W)).sum) (sortSplitPerm W)) + -- Swap the cast across the transport. + have hcast := congrArg (fun z : + (superPow (stdSuperPair k ℓ) + ((degList (starAssignEnum W)).sum) ⟶ + P.ω.obj (SkeinObj.mk + (edgeCount W + edgeCount W))) => + (z : SuperVect.Hom _ _).evenMap + (((modelPermMap (sortSplitPerm W)) : + SuperVect.Hom _ _).evenMap + (modelStarVec f P e' + (degList (starAssignEnum W))))) + (stdToOmega_bmc_cast f P e + (degList_sum (starAssignEnum W))) + refine Eq.trans (congrArg (fun y => + ((P.ω.map (bundleMapClass f (finCongr + (degList_sum (starAssignEnum W)))) : + P.ω.obj (SkeinObj.mk + ((degList (starAssignEnum W)).sum)) ⟶ + P.ω.obj (SkeinObj.mk + (edgeCount W + edgeCount W))) : + SuperVect.Hom _ _).evenMap y) hperm) ?_ + exact hcast + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PatternInv.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PatternInv.lean new file mode 100644 index 0000000000..ee79342fa2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PatternInv.lean @@ -0,0 +1,67 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij + +/-! +# The pattern inversion count + +The master sum's global sign at a data colouring depends only on +the pattern: the sort-permutation's odd inversions count pairs of +participating slots, a pure `(W, F)` quantity. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {k ℓ : ℕ} + +open Classical in +/-- The pattern inversion count of an edge subset: inverted sort +pairs of participating slots. -/ +noncomputable def patternOddInv (W : ClosedFragment) + (F : EdgeSubset W) : ℕ := + (Finset.univ.filter + (fun p : Fin (ds W).sum × Fin (ds W).sum => + p.1 < p.2 ∧ sortSplitPerm W p.1 > sortSplitPerm W p.2 ∧ + (starFlagEnum W).symm + (finCongr (degList_sum (starAssignEnum W)) + (sortSplitPerm W p.1)) ∈ F.flags ∧ + (starFlagEnum W).symm + (finCongr (degList_sum (starAssignEnum W)) + (sortSplitPerm W p.2)) ∈ F.flags)).card + +open Classical in +/-- **The master sign at a data colouring is the pattern +inversion count.** -/ +theorem oddInversions_colouringOf (W : ClosedFragment) + (F : EdgeSubset W) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) : + oddInversions (sortSplitPerm W) + ((colouringOf W F ψ φ) ∘ + finCongr (degList_sum (starAssignEnum W))) = + patternOddInv W F := by + unfold oddInversions patternOddInv + refine congrArg Finset.card (Finset.filter_congr + (fun p _ => ?_)) + have hmem : ∀ t : Fin (edgeCount W + edgeCount W), + ((colouringOf W F ψ φ) t).isRight = true ↔ + (starFlagEnum W).symm t ∈ F.flags := by + intro t + rw [← colourFlags_colouringOf W F ψ φ, + mem_colourFlags_iff, _root_.Equiv.apply_symm_apply] + constructor + · rintro ⟨h1, h2, h3, h4⟩ + exact ⟨h1, h2, (hmem _).mp h3, (hmem _).mp h4⟩ + · rintro ⟨h1, h2, h3, h4⟩ + exact ⟨h1, h2, (hmem _).mpr h3, (hmem _).mpr h4⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PowMerge.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PowMerge.lean new file mode 100644 index 0000000000..eea1fe66d5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PowMerge.lean @@ -0,0 +1,192 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonColour + +/-! +# Merging monoidal powers + +The block merge of two monoidal powers into the power of the sum +(right unitor base, associator-threaded step), and its +compatibility with the model transport: transporting blockwise +and merging through the structure map agrees with merging first. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open Functor.LaxMonoidal Functor.OplaxMonoidal + +/-- The block merge of monoidal powers. -/ +noncomputable def powMerge (V : SuperVect) : + (a b : ℕ) → (superPow V a ⊗ superPow V b ⟶ + superPow V (a + b)) + | a, 0 => (ρ_ (superPow V a)).hom + | a, b + 1 => + (α_ (superPow V a) (superPow V b) V).inv ≫ + ((powMerge V a b) ▷ V) + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} +variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) + +-- The block transport is proved by recursion on the +-- second arity, carrying the tensorator and both unitors at every +-- step. +/-- **The block transport**: blockwise transports assembled by +the structure map agree with the merged transport. -/ +theorem stdToOmega_merge : + ∀ (a b : ℕ), + letI := P.braided + ((stdToOmega f P e a ⊗ₘ stdToOmega f P e b) ≫ + μ P.ω (SkeinObj.mk a) (SkeinObj.mk b) : + superPow (stdSuperPair k ℓ) a ⊗ superPow (stdSuperPair k ℓ) b ⟶ + P.ω.obj (SkeinObj.mk (a + b))) = + powMerge (stdSuperPair k ℓ) a b ≫ stdToOmega f P e (a + b) + -- ═══════ b = 0: THE RIGHT UNITOR ═══════ + | a, 0 => by + let := P.braided + -- The skein right unitor at `a` is the identity. + have hρ : (ρ_ (SkeinObj.mk a : SkeinObj f)).hom = + 𝟙 (SkeinObj.mk a) := by + change bundleMapClass f (finCongr _) = _ + rw [show (finCongr (show a + 0 = a by omega) : + Fin a ≃ Fin a) = _root_.Equiv.refl (Fin a) from + _root_.Equiv.ext (fun x => Fin.ext rfl)] + exact bundleMapClass_refl f a + -- Right unitality with the strict unitor eliminated. + have hru : (P.ω.obj (SkeinObj.mk a) ◁ ε P.ω) ≫ + μ P.ω (SkeinObj.mk a) (SkeinObj.mk 0) = + (ρ_ (P.ω.obj (SkeinObj.mk a))).hom := by + have h0 := Functor.LaxMonoidal.right_unitality + (F := P.ω) (SkeinObj.mk a) + rw [hρ] at h0 + rw [show P.ω.map (𝟙 (SkeinObj.mk a : SkeinObj f)) = + 𝟙 (P.ω.obj (SkeinObj.mk a)) from P.ω.map_id _] at h0 + exact h0.symm + change (stdToOmega f P e a ⊗ₘ ε P.ω) ≫ + μ P.ω (SkeinObj.mk a) (SkeinObj.mk 0) = + (ρ_ (superPow (stdSuperPair k ℓ) a)).hom ≫ + stdToOmega f P e a + rw [MonoidalCategory.tensorHom_def] + rw [Category.assoc, hru] + exact MonoidalCategory.rightUnitor_naturality _ + -- ═══════ b + 1: PEEL ONE TENSOR FACTOR ═══════ + | a, b + 1 => by + let := P.braided + -- Expand the right transport one step. + change (stdToOmega f P e a ⊗ₘ + ((stdToOmega f P e b ⊗ₘ e) ≫ + μ P.ω (SkeinObj.mk b) (SkeinObj.mk 1))) ≫ + μ P.ω (SkeinObj.mk a) (SkeinObj.mk (b + 1)) = + ((α_ (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).inv ≫ + ((powMerge (stdSuperPair k ℓ) a b) ▷ stdSuperPair k ℓ)) ≫ + stdToOmega f P e (a + (b + 1)) + -- Split the nested tensor. + rw [show (stdToOmega f P e a ⊗ₘ + ((stdToOmega f P e b ⊗ₘ e) ≫ + μ P.ω (SkeinObj.mk b) (SkeinObj.mk 1))) = + (stdToOmega f P e a ⊗ₘ + (stdToOmega f P e b ⊗ₘ e)) ≫ + (P.ω.obj (SkeinObj.mk a) ◁ + μ P.ω (SkeinObj.mk b) (SkeinObj.mk 1)) from by + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.comp_id]] + -- The associativity square with the strict skein associator. + have hα : P.ω.map ((α_ (SkeinObj.mk a : SkeinObj f) + (SkeinObj.mk b) (SkeinObj.mk 1)).inv) = + 𝟙 (P.ω.obj (SkeinObj.mk (a + (b + 1)))) := by + rw [show (α_ (SkeinObj.mk a : SkeinObj f) + (SkeinObj.mk b) (SkeinObj.mk 1)).inv = + 𝟙 (SkeinObj.mk (a + (b + 1))) from by + change bundleMapClass f (finCongr _) = _ + rw [show (finCongr (show a + (b + 1) = a + b + 1 + by omega) : Fin (a + (b + 1)) ≃ + Fin (a + (b + 1))) = + _root_.Equiv.refl (Fin (a + (b + 1))) from + _root_.Equiv.ext (fun x => Fin.ext rfl)] + exact bundleMapClass_refl f (a + (b + 1))] + exact P.ω.map_id _ + have hassoc : (P.ω.obj (SkeinObj.mk a) ◁ + μ P.ω (SkeinObj.mk b) (SkeinObj.mk 1)) ≫ + μ P.ω (SkeinObj.mk a) (SkeinObj.mk (b + 1)) = + (α_ (P.ω.obj (SkeinObj.mk a)) + (P.ω.obj (SkeinObj.mk b)) + (P.ω.obj (SkeinObj.mk 1))).inv ≫ + (μ P.ω (SkeinObj.mk a) (SkeinObj.mk b) ▷ + P.ω.obj (SkeinObj.mk 1)) ≫ + μ P.ω (SkeinObj.mk (a + b)) (SkeinObj.mk 1) := by + have h0 := Functor.LaxMonoidal.associativity_inv + (F := P.ω) (SkeinObj.mk a) (SkeinObj.mk b) + (SkeinObj.mk 1) + rw [hα] at h0 + exact h0 + rw [Category.assoc, hassoc] + -- Pull the associator across the transports. + rw [show (stdToOmega f P e a ⊗ₘ + (stdToOmega f P e b ⊗ₘ e)) ≫ + ((α_ (P.ω.obj (SkeinObj.mk a)) + (P.ω.obj (SkeinObj.mk b)) + (P.ω.obj (SkeinObj.mk 1))).inv ≫ + (μ P.ω (SkeinObj.mk a) (SkeinObj.mk b) ▷ + P.ω.obj (SkeinObj.mk 1)) ≫ + μ P.ω (SkeinObj.mk (a + b)) (SkeinObj.mk 1)) = + (α_ (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).inv ≫ + (((stdToOmega f P e a ⊗ₘ stdToOmega f P e b) ⊗ₘ e) ≫ + (μ P.ω (SkeinObj.mk a) (SkeinObj.mk b) ▷ + P.ω.obj (SkeinObj.mk 1)) ≫ + μ P.ω (SkeinObj.mk (a + b)) (SkeinObj.mk 1)) from by + rw [← Category.assoc, ← Category.assoc, + MonoidalCategory.associator_inv_naturality, + Category.assoc, Category.assoc]] + -- Collect the whiskered merge through the induction. + have htail : ((stdToOmega f P e a ⊗ₘ stdToOmega f P e b) + ⊗ₘ e) ≫ + (μ P.ω (SkeinObj.mk a) (SkeinObj.mk b) ▷ + P.ω.obj (SkeinObj.mk 1)) ≫ + μ P.ω (SkeinObj.mk (a + b)) (SkeinObj.mk 1) = + (powMerge (stdSuperPair k ℓ) a b ▷ stdSuperPair k ℓ) ≫ + stdToOmega f P e (a + (b + 1)) := by + refine ((Category.assoc _ _ _).symm).trans ?_ + refine (congrArg (fun z => z ≫ + μ P.ω (SkeinObj.mk (a + b)) (SkeinObj.mk 1)) (show + ((stdToOmega f P e a ⊗ₘ stdToOmega f P e b) ⊗ₘ e) ≫ + (μ P.ω (SkeinObj.mk a) (SkeinObj.mk b) ▷ + P.ω.obj (SkeinObj.mk 1)) = + (((stdToOmega f P e a ⊗ₘ stdToOmega f P e b) ≫ + μ P.ω (SkeinObj.mk a) (SkeinObj.mk b)) ⊗ₘ e) + from by + rw [← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.comp_id])).trans ?_ + refine (congrArg (fun z => (z ⊗ₘ e) ≫ + μ P.ω (SkeinObj.mk (a + b)) (SkeinObj.mk 1)) + (stdToOmega_merge a b)).trans ?_ + refine (congrArg (fun z => z ≫ + μ P.ω (SkeinObj.mk (a + b)) (SkeinObj.mk 1)) (show + ((powMerge (stdSuperPair k ℓ) a b ≫ + stdToOmega f P e (a + b)) ⊗ₘ e) = + (powMerge (stdSuperPair k ℓ) a b ▷ stdSuperPair k ℓ) ≫ + (stdToOmega f P e (a + b) ⊗ₘ e) from by + rw [← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.id_comp])).trans ?_ + exact Category.assoc _ _ _ + refine (congrArg (fun z => + (α_ (superPow (stdSuperPair k ℓ) a) + (superPow (stdSuperPair k ℓ) b) (stdSuperPair k ℓ)).inv ≫ z) + htail).trans ?_ + exact (Category.assoc _ _ _).symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean new file mode 100644 index 0000000000..9971aa3d75 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean @@ -0,0 +1,1155 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.ListPairs +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairList +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircuitCount + +/-! +# The regroup sign + +The extraction enumerates a subset's participating flags three +ways: *oriented*, each edge's representative followed by its +pairing partner; *matched*, each incoming flag followed by its +match; and *global*, the per-vertex pair blocks concatenated. The +sign relating them is the regroup sign, and this module computes +it in two halves. + +* **Oriented to matched** (`sign_listIndexPerm_oriented_matched`) + conjugates the out-permutation: the index permutation between + the two enumerations acts on edge indices exactly as the + orientation's out-permutation acts on flags, so the two signs + agree. +* **Matched to global** (`sign_listIndexPerm_matched_global`) is + even: both enumerations list the same incoming flags each + followed by its match, so the index permutation moves whole + two-element blocks and its sign is a square. + +Both run on the flat-map presentations of the three lists and on +the index arithmetic of a list of pairs. +-/ + +@[expose] public section + +namespace RS + +open Finset Equiv + +variable {k ℓ : ℕ} + +/-! ## Slot extraction from block membership -/ + +/-- Extract slot index from oriented block membership. -/ +private theorem slot_of_orientedBlock' {W : ClosedFragment} {F : EdgeSubset W} + {κ : F.TransitionSystem} {o : κ.Orientation} + (i : { x : Fin (edgeCount W) // x ∈ edgeIndexSet W F }) + (x : {f : W.Flag // f ∈ F.flags}) + (hx : x ∈ (if o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i.val)) = true then + [⟨(starFlagEnum W).symm (Fin.natAdd (edgeCount W) i.val), + partnerMem_of_partEdge i.prop⟩, + ⟨(starFlagEnum W).symm (Fin.castAdd (edgeCount W) i.val), + repMem_of_partEdge i.prop⟩] + else + [⟨(starFlagEnum W).symm (Fin.castAdd (edgeCount W) i.val), + repMem_of_partEdge i.prop⟩, + ⟨(starFlagEnum W).symm (Fin.natAdd (edgeCount W) i.val), + partnerMem_of_partEdge i.prop⟩])) : + starFlagEnum W x.val = Fin.castAdd (edgeCount W) i.val ∨ + starFlagEnum W x.val = Fin.natAdd (edgeCount W) i.val := by + by_cases ho : o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i.val)) = true + · rw [ite_eq_left ho] at hx + rcases List.mem_cons.mp hx with h | h + · right + rw [show x.val = (starFlagEnum W).symm + (Fin.natAdd (edgeCount W) i.val) from congrArg Subtype.val h, + _root_.Equiv.apply_symm_apply] + · left + rw [List.mem_singleton] at h + rw [show x.val = (starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i.val) from congrArg Subtype.val h, + _root_.Equiv.apply_symm_apply] + · rw [ite_eq_right ho] at hx + rcases List.mem_cons.mp hx with h | h + · left + rw [show x.val = (starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i.val) from congrArg Subtype.val h, + _root_.Equiv.apply_symm_apply] + · right + rw [List.mem_singleton] at h + rw [show x.val = (starFlagEnum W).symm + (Fin.natAdd (edgeCount W) i.val) from congrArg Subtype.val h, + _root_.Equiv.apply_symm_apply] + +/-- For an element in a matched block, classify it as the in-flag + (with its slot) or as match of the in-flag (outgoing). -/ +private theorem matchedBlock_classify {W : ClosedFragment} {F : EdgeSubset W} + {κ : F.TransitionSystem} {o : κ.Orientation} + (c : { x : Fin (edgeCount W) // x ∈ edgeIndexSet W F }) + (x : {f : W.Flag // f ∈ F.flags}) + (hx : x ∈ (if o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) c.val)) = true then + [⟨(starFlagEnum W).symm (Fin.natAdd (edgeCount W) c.val), + partnerMem_of_partEdge c.prop⟩, + ⟨κ.match_ ((starFlagEnum W).symm (Fin.natAdd (edgeCount W) c.val)), + κ.match_mem _ (partnerMem_of_partEdge c.prop)⟩] + else + [⟨(starFlagEnum W).symm (Fin.castAdd (edgeCount W) c.val), + repMem_of_partEdge c.prop⟩, + ⟨κ.match_ ((starFlagEnum W).symm (Fin.castAdd (edgeCount W) c.val)), + κ.match_mem _ (repMem_of_partEdge c.prop)⟩])) : + -- Either x is the in-flag (incoming, with a known slot) + (o.isOut x.val = false ∧ + (starFlagEnum W x.val = Fin.castAdd (edgeCount W) c.val ∨ + starFlagEnum W x.val = Fin.natAdd (edgeCount W) c.val)) ∨ + -- Or x = match(inFlag) (outgoing) and inFlag has known slot and membership + (o.isOut x.val = true ∧ ∃ inF : W.Flag, inF ∈ F.flags ∧ x.val = κ.match_ inF + ∧ + (starFlagEnum W inF = Fin.castAdd (edgeCount W) c.val ∨ + starFlagEnum W inF = Fin.natAdd (edgeCount W) c.val)) := by + by_cases ho : o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) c.val)) = true + · rw [ite_eq_left ho] at hx + -- block = [partner, match(partner)] + -- partner = symm(natAdd c.val), which is incoming (pairing_flip) + have partner_in : o.isOut ((starFlagEnum W).symm + (Fin.natAdd (edgeCount W) c.val)) = false := by + have := o.pairing_flip _ (repMem_of_partEdge c.prop) + rw [pairing_starFlagEnum_symm] at this; rw [this, ho]; rfl + rcases List.mem_cons.mp hx with h | h + · -- x = partner (incoming) + left + have hxv : x.val = (starFlagEnum W).symm + (Fin.natAdd (edgeCount W) c.val) := + congrArg (fun z : {f : W.Flag // f ∈ F.flags} => z.val) h + exact ⟨by rw [hxv]; exact partner_in, + Or.inr (by rw [hxv, _root_.Equiv.apply_symm_apply])⟩ + · -- x = match(partner) (outgoing) + right + rw [List.mem_singleton] at h + have hxv : x.val = κ.match_ ((starFlagEnum W).symm + (Fin.natAdd (edgeCount W) c.val)) := + congrArg (fun z : {f : W.Flag // f ∈ F.flags} => z.val) h + constructor + · rw [hxv, o.match_flip _ (partnerMem_of_partEdge c.prop), partner_in]; + rfl + · exact ⟨_, partnerMem_of_partEdge c.prop, hxv, + Or.inr (_root_.Equiv.apply_symm_apply _ _)⟩ + · rw [ite_eq_right ho] at hx + -- block = [rep, match(rep)] + -- rep = symm(castAdd c.val), which is incoming (by ho) + have rep_in : o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) c.val)) = false := by + cases hb : o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) c.val)) + · rfl + · exact absurd hb ho + rcases List.mem_cons.mp hx with h | h + · -- x = rep (incoming) + left + have hxv : x.val = (starFlagEnum W).symm + (Fin.castAdd (edgeCount W) c.val) := + congrArg (fun z : {f : W.Flag // f ∈ F.flags} => z.val) h + exact ⟨by rw [hxv]; exact rep_in, + Or.inl (by rw [hxv, _root_.Equiv.apply_symm_apply])⟩ + · -- x = match(rep) (outgoing) + right + rw [List.mem_singleton] at h + have hxv : x.val = κ.match_ ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) c.val)) := + congrArg (fun z : {f : W.Flag // f ∈ F.flags} => z.val) h + constructor + · rw [hxv, o.match_flip _ (repMem_of_partEdge c.prop), rep_in]; rfl + · exact ⟨_, repMem_of_partEdge c.prop, hxv, + Or.inl (_root_.Equiv.apply_symm_apply _ _)⟩ + +/-! ## Slot contradiction helper -/ + +/-- If two edge indices give the same slot (castAdd or natAdd), the edges +are equal. -/ +private theorem edge_eq_of_slot_eq {W : ClosedFragment} + {f : W.Flag} {a b : Fin (edgeCount W)} + (ha : starFlagEnum W f = Fin.castAdd (edgeCount W) a ∨ + starFlagEnum W f = Fin.natAdd (edgeCount W) a) + (hb : starFlagEnum W f = Fin.castAdd (edgeCount W) b ∨ + starFlagEnum W f = Fin.natAdd (edgeCount W) b) : + a = b := by + rcases ha with ha | ha <;> rcases hb with hb | hb + · exact Fin.castAdd_injective _ _ (ha.symm.trans hb) + · have := congrArg Fin.val (ha.symm.trans hb) + simp only [Fin.val_castAdd, Fin.val_natAdd] at this; omega + · have := congrArg Fin.val (ha.symm.trans hb) + simp only [Fin.val_castAdd, Fin.val_natAdd] at this; omega + · exact Fin.natAdd_injective _ _ (ha.symm.trans hb) + +/-! ## Nodup: matched pair list -/ + +-- As for the oriented list: block by block, with the matching in +-- place of the pairing. +/-- The matched pair list has no repeats. -/ +theorem matchedPairList_nodup' (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) : + (matchedPairList W F o).Nodup := by + rw [matchedPairList, List.nodup_flatMap]; constructor + · -- Each block: [inFlag, match(inFlag)] is nodup since match has no fixed + -- points + intro ⟨i, hi⟩ _ + by_cases ho : o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = true + · rw [ite_eq_left ho] + refine List.nodup_cons.mpr ⟨fun hmem => ?_, List.nodup_singleton _⟩ + rw [List.mem_singleton] at hmem + have hval := congrArg (fun z : {f : W.Flag // f ∈ F.flags} => z.val) hmem + exact κ.match_ne _ (partnerMem_of_partEdge hi) hval.symm + · rw [ite_eq_right ho] + refine List.nodup_cons.mpr ⟨fun hmem => ?_, List.nodup_singleton _⟩ + rw [List.mem_singleton] at hmem + have hval := congrArg (fun z : {f : W.Flag // f ∈ F.flags} => z.val) hmem + exact κ.match_ne _ (repMem_of_partEdge hi) hval.symm + · -- Cross-block disjointness + refine List.Pairwise.imp_of_mem (fun {a b} _ _ hab x hxa hxb => ?_) + (List.Pairwise.imp (fun {a b} h => h) (attachWith_partEdges_nodup W F)) + have hne : a.val ≠ b.val := fun h => hab (Subtype.ext h) + obtain ⟨ha_in, ha_slot⟩ | ⟨ha_out, inA, hmemA, hxA, hslotA⟩ := + matchedBlock_classify a x hxa + · -- x is incoming from edge a + obtain ⟨_, hb_slot⟩ | ⟨hb_out, _, _, _, _⟩ := matchedBlock_classify b x + hxb + · -- x also incoming from edge b → slot comparison + exact hne (edge_eq_of_slot_eq ha_slot hb_slot) + · -- x incoming from a, outgoing from b → isOut contradiction + rw [ha_in] at hb_out; exact Bool.noConfusion hb_out + · -- x is outgoing from edge a (x = match(inA)) + obtain ⟨hb_in, _⟩ | ⟨_, inB, hmemB, hxB, hslotB⟩ := + matchedBlock_classify b x hxb + · -- x outgoing from a, incoming from b → isOut contradiction + rw [hb_in] at ha_out; exact Bool.noConfusion ha_out + · -- Both outgoing: match injectivity + have hmatch_eq : κ.match_ inA = κ.match_ inB := hxA.symm.trans hxB + have hinAB : inA = inB := + (κ.match_invol inA hmemA).symm.trans + (congrArg κ.match_ hmatch_eq |>.trans (κ.match_invol inB hmemB)) + exact hne (edge_eq_of_slot_eq (hinAB ▸ hslotA) hslotB) + +/-! ## Membership: matched pair list -/ + +-- As for the oriented list: membership through the star +-- enumeration, using involutivity of the matching. +/-- And lists every participating flag — so it is a reordering of +them, and its sign is the regroup sign. -/ +theorem mem_matchedPairList' (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) + (x : {f : W.Flag // f ∈ F.flags}) : + x ∈ matchedPairList W F o := by + rw [matchedPairList, List.mem_flatMap] + by_cases hout : o.isOut x.val = true + · -- ═══════ x OUTGOING: x = match (inFlag) OF SOME EDGE ═══════ + -- The in-flag is match(x) since match is involutive + set y : {f : W.Flag // f ∈ F.flags} := ⟨κ.match_ x.val, κ.match_mem _ + x.prop⟩ + have hy_in : o.isOut y.val = false := by + change o.isOut (κ.match_ x.val) = false + rw [o.match_flip x.val x.prop, hout]; rfl + -- Find the edge containing y via its slot + set q := starFlagEnum W y.val with hq_def + by_cases hlow : q.val < edgeCount W + · set i : Fin (edgeCount W) := ⟨q.val, hlow⟩ with hi_def + have hslot : Fin.castAdd (edgeCount W) i = q := Fin.ext rfl + have hymem : (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i) = + y.val := by + rw [hslot, hq_def, _root_.Equiv.symm_apply_apply] + have hei : i ∈ edgeIndexSet W F := by + rw [edgeIndexSet, Finset.mem_filter] + exact ⟨Finset.mem_univ _, hymem ▸ y.prop⟩ + have hsort : i ∈ (partEdges W F) := (Finset.mem_sort _).mpr hei + have h_not_out : ¬(o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = true) := by + rw [hymem, hy_in]; exact Bool.false_ne_true + refine ⟨⟨i, hei⟩, ?_, ?_⟩ + · rw [show (partEdges W F).attachWith (· ∈ edgeIndexSet W F) + (fun _ hi => (Finset.mem_sort _).mp hi) = + (partEdges W F).pmap Subtype.mk + (fun _ hi => (Finset.mem_sort _).mp hi) from rfl] + exact List.mem_pmap.mpr ⟨i, hsort, Subtype.ext rfl⟩ + · rw [ite_eq_right h_not_out] + -- block = [rep, match(rep)] where rep = symm(castAdd i) = y + apply List.mem_cons.mpr; right; rw [List.mem_singleton] + apply Subtype.ext + change x.val = κ.match_ ((starFlagEnum W).symm (Fin.castAdd (edgeCount W) + i)) + rw [hymem]; exact (κ.match_invol _ x.prop).symm + · have hge : q.val ≥ edgeCount W := Nat.le_of_not_lt hlow + have hlt : q.val - edgeCount W < edgeCount W := by have := q.isLt; omega + set i : Fin (edgeCount W) := ⟨q.val - edgeCount W, hlt⟩ with hi_def + have hslot : Fin.natAdd (edgeCount W) i = q := + Fin.ext (by change edgeCount W + (q.val - edgeCount W) = q.val; omega) + have hymem : (starFlagEnum W).symm (Fin.natAdd (edgeCount W) i) = + y.val := by + rw [hslot, hq_def, _root_.Equiv.symm_apply_apply] + have hpair : (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i) = + W.pairing y.val := by + rw [← hymem, ← pairing_starFlagEnum_symm W i, W.pairing_invol] + have hei : i ∈ edgeIndexSet W F := by + rw [edgeIndexSet, Finset.mem_filter] + exact ⟨Finset.mem_univ _, hpair ▸ F.pairing_mem _ y.prop⟩ + have hsort : i ∈ (partEdges W F) := (Finset.mem_sort _).mpr hei + have h_out : o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = true := by + have hflip := o.pairing_flip _ (repMem_of_partEdge hei) + rw [pairing_starFlagEnum_symm] at hflip + rw [hymem, hy_in] at hflip + -- hflip : false = !(o.isOut (symm (castAdd i))) + cases hc : o.isOut ((starFlagEnum W).symm (Fin.castAdd (edgeCount W) i)) + · simp [hc] at hflip + · rfl + refine ⟨⟨i, hei⟩, ?_, ?_⟩ + · rw [show (partEdges W F).attachWith (· ∈ edgeIndexSet W F) + (fun _ hi => (Finset.mem_sort _).mp hi) = + (partEdges W F).pmap Subtype.mk + (fun _ hi => (Finset.mem_sort _).mp hi) from rfl] + exact List.mem_pmap.mpr ⟨i, hsort, Subtype.ext rfl⟩ + · rw [ite_eq_left h_out] + -- block = [partner, match(partner)] where partner = symm(natAdd i) = y + apply List.mem_cons.mpr; right; rw [List.mem_singleton] + apply Subtype.ext + change x.val = κ.match_ ((starFlagEnum W).symm (Fin.natAdd (edgeCount W) + i)) + rw [hymem]; exact (κ.match_invol _ x.prop).symm + · -- ═══════ x INCOMING ═══════ + have hin : o.isOut x.val = false := by + cases hb : o.isOut x.val + · rfl + · exact absurd hb hout + set q := (starFlagEnum W) x.val with hq_def + by_cases hlow : q.val < edgeCount W + · set i : Fin (edgeCount W) := ⟨q.val, hlow⟩ with hi_def + have hslot : Fin.castAdd (edgeCount W) i = q := Fin.ext rfl + have hmem : (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i) = + x.val := by + rw [hslot, hq_def, _root_.Equiv.symm_apply_apply] + have hei : i ∈ edgeIndexSet W F := by + rw [edgeIndexSet, Finset.mem_filter] + exact ⟨Finset.mem_univ _, hmem ▸ x.prop⟩ + have hsort : i ∈ (partEdges W F) := (Finset.mem_sort _).mpr hei + have h_not_out : ¬(o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = true) := by + rw [hmem, hin]; exact Bool.false_ne_true + refine ⟨⟨i, hei⟩, ?_, ?_⟩ + · rw [show (partEdges W F).attachWith (· ∈ edgeIndexSet W F) + (fun _ hi => (Finset.mem_sort _).mp hi) = + (partEdges W F).pmap Subtype.mk + (fun _ hi => (Finset.mem_sort _).mp hi) from rfl] + exact List.mem_pmap.mpr ⟨i, hsort, Subtype.ext rfl⟩ + · rw [ite_eq_right h_not_out] + exact List.mem_cons.mpr (Or.inl (Subtype.ext hmem.symm)) + · have hge : q.val ≥ edgeCount W := Nat.le_of_not_lt hlow + have hlt : q.val - edgeCount W < edgeCount W := by have := q.isLt; omega + set i : Fin (edgeCount W) := ⟨q.val - edgeCount W, hlt⟩ with hi_def + have hslot : Fin.natAdd (edgeCount W) i = q := + Fin.ext (by change edgeCount W + (q.val - edgeCount W) = q.val; omega) + have hmem : (starFlagEnum W).symm (Fin.natAdd (edgeCount W) i) = + x.val := by + rw [hslot, hq_def, _root_.Equiv.symm_apply_apply] + have hpair : (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i) = + W.pairing x.val := by + rw [← hmem, ← pairing_starFlagEnum_symm W i, W.pairing_invol] + have hei : i ∈ edgeIndexSet W F := by + rw [edgeIndexSet, Finset.mem_filter] + exact ⟨Finset.mem_univ _, hpair ▸ F.pairing_mem _ x.prop⟩ + have hsort : i ∈ (partEdges W F) := (Finset.mem_sort _).mpr hei + have h_out : o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = true := by + have hflip := o.pairing_flip _ (repMem_of_partEdge hei) + rw [pairing_starFlagEnum_symm] at hflip + rw [hmem, hin] at hflip + cases hc : o.isOut ((starFlagEnum W).symm (Fin.castAdd (edgeCount W) i)) + · simp [hc] at hflip + · rfl + refine ⟨⟨i, hei⟩, ?_, ?_⟩ + · rw [show (partEdges W F).attachWith (· ∈ edgeIndexSet W F) + (fun _ hi => (Finset.mem_sort _).mp hi) = + (partEdges W F).pmap Subtype.mk + (fun _ hi => (Finset.mem_sort _).mp hi) from rfl] + exact List.mem_pmap.mpr ⟨i, hsort, Subtype.ext rfl⟩ + · rw [ite_eq_left h_out] + exact List.mem_cons.mpr (Or.inl (Subtype.ext hmem.symm)) + +/-! ## Nodup and membership: global pair list -/ + +private theorem globalPairList_nodup' (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) : + (globalPairList W F o).Nodup := by + rw [globalPairList, List.nodup_flatMap]; constructor + · intro v _; exact pairFlagList_nodup o (blockVertex W v) + · refine List.Pairwise.imp_of_mem (fun {a b} _ _ hab x hxa hxb => ?_) + (List.Pairwise.imp (fun {a b} h => h) (List.nodup_finRange _)) + exact hab (blockVertex_injective' W + (Sum.inl.inj ((mem_pairFlagList o _ x).mp hxa |>.symm.trans + ((mem_pairFlagList o _ x).mp hxb)))) + +private theorem mem_globalPairList' (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) + (x : {f : W.Flag // f ∈ F.flags}) : + x ∈ globalPairList W F o := by + rw [globalPairList, List.mem_flatMap] + obtain ⟨v, hv⟩ := κ.attach_internal x.val x.prop + obtain ⟨bv, hbv⟩ := blockVertex_surjective' W v + exact ⟨bv, List.mem_finRange _, hbv ▸ (mem_pairFlagList o v x).mpr hv⟩ + +/-! ## Length equalities -/ + +private theorem len_oriented_eq_matched (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) : + (orientedPairList W F o).length = (matchedPairList W F o).length := + length_eq_of_nodup_mem _ _ + (orientedPairList_nodup W F o) (matchedPairList_nodup' W F o) + (fun x => ⟨fun _ => mem_matchedPairList' W F o x, + fun _ => mem_orientedPairList W F o x⟩) + +private theorem len_matched_eq_global (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) : + (matchedPairList W F o).length = (globalPairList W F o).length := + length_eq_of_nodup_mem _ _ + (matchedPairList_nodup' W F o) (globalPairList_nodup' W F o) + (fun x => ⟨fun _ => mem_globalPairList' W F o x, + fun _ => mem_matchedPairList' W F o x⟩) + +/-! ## Match subtype and base lists -/ + +/-- Match as a subtype-preserving function. -/ +private noncomputable def matchSub {W : ClosedFragment} {F : EdgeSubset W} + (κ : F.TransitionSystem) (f : {f : W.Flag // f ∈ F.flags}) : + {f : W.Flag // f ∈ F.flags} := + ⟨κ.match_ f.val, κ.match_mem _ f.prop⟩ + +/-- Incoming flag at each edge (edge-ordered base for matched). -/ +private noncomputable def matchedInFlag {W : ClosedFragment} {F : EdgeSubset W} + {κ : F.TransitionSystem} (o : κ.Orientation) + (e : { x : Fin (edgeCount W) // x ∈ edgeIndexSet W F }) : + {f : W.Flag // f ∈ F.flags} := + if o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) e.val)) = true then + ⟨(starFlagEnum W).symm (Fin.natAdd (edgeCount W) e.val), + partnerMem_of_partEdge e.prop⟩ + else + ⟨(starFlagEnum W).symm (Fin.castAdd (edgeCount W) e.val), + repMem_of_partEdge e.prop⟩ + +/-- Edge-ordered incoming-flag base list. -/ +private noncomputable def matchedBase (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) : + List {f : W.Flag // f ∈ F.flags} := + ((partEdges W F).attachWith (· ∈ edgeIndexSet W F) + (fun _ hi => (Finset.mem_sort _).mp hi)).map (matchedInFlag o) + +/-- Vertex-ordered incoming-flag base list. -/ +private noncomputable def globalBase (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) : + List {f : W.Flag // f ∈ F.flags} := + (List.finRange (ds W).length).flatMap + (fun v => (F.inFlagsAt o (blockVertex W v)).attachWith (· ∈ F.flags) + (fun _ hf => F.mem_of_mem_inFlagsAt hf)) + +/-! ## FlatMap decompositions -/ + +-- The two flat-map presentations are matched edge +-- by edge, each with its orientation dichotomy. +private theorem matchedPairList_eq_flatMap (W : ClosedFragment) (F : EdgeSubset + W) + {κ : F.TransitionSystem} (o : κ.Orientation) : + matchedPairList W F o = + (matchedBase W F o).flatMap (fun f => [f, matchSub κ f]) := by + rw [matchedPairList, matchedBase, List.flatMap_map] + congr 1; ext ⟨e, he⟩ + unfold matchedInFlag matchSub + by_cases ho : o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) e)) = true + · simp [ho] + · simp [ho] + +-- As for the matched list, over the per-vertex blocks. +private theorem globalPairList_eq_flatMap (W : ClosedFragment) (F : EdgeSubset + W) + {κ : F.TransitionSystem} (o : κ.Orientation) : + globalPairList W F o = + (globalBase W F o).flatMap (fun f => [f, matchSub κ f]) := by + rw [globalPairList, globalBase] + simp_rw [show ∀ v, pairFlagList (F := F) o (blockVertex W v) = + ((F.inFlagsAt o (blockVertex W v)).attachWith (· ∈ F.flags) + (fun _ hf => F.mem_of_mem_inFlagsAt hf)).flatMap + (fun f => [f, matchSub κ f]) from fun _ => rfl] + exact List.flatMap_assoc.symm + +/-! ## Pairing properties -/ + +private theorem matchedPairList_paired (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) (j : ℕ) : + (matchedPairList W F o)[2 * j + 1]? = + (matchedPairList W F o)[2 * j]?.map (matchSub κ) := by + rw [matchedPairList_eq_flatMap] + exact getElem?_self_paired (matchedBase W F o) (matchSub κ) j + +private theorem globalPairList_paired (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) (j : ℕ) : + (globalPairList W F o)[2 * j + 1]? = + (globalPairList W F o)[2 * j]?.map (matchSub κ) := by + rw [globalPairList_eq_flatMap] + exact getElem?_self_paired (globalBase W F o) (matchSub κ) j + +/-! ## Orientation properties of base elements -/ + +/-- The incoming flag at each edge is actually incoming. -/ +private theorem matchedInFlag_isIn (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) + (e : { x : Fin (edgeCount W) // x ∈ edgeIndexSet W F }) : + o.isOut (matchedInFlag o e).val = false := by + unfold matchedInFlag + by_cases ho : o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) e.val)) = true + · rw [ite_eq_left ho] + have := o.pairing_flip _ (repMem_of_partEdge e.prop) + rw [pairing_starFlagEnum_symm] at this + rw [this, ho]; rfl + · rw [ite_eq_right ho] + cases hb : o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) e.val)) + · rfl + · exact absurd hb ho + +/-- Elements of globalBase are incoming. -/ +private theorem globalBase_isIn (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) + (f : {f : W.Flag // f ∈ F.flags}) (hf : f ∈ globalBase W F o) : + o.isOut f.val = false := by + rw [globalBase, List.mem_flatMap] at hf + obtain ⟨v, _, hfv⟩ := hf + have : f.val ∈ F.inFlagsAt o (blockVertex W v) := by + rw [show (F.inFlagsAt o (blockVertex W v)).attachWith (· ∈ F.flags) + (fun _ hf => F.mem_of_mem_inFlagsAt hf) = + (F.inFlagsAt o (blockVertex W v)).pmap Subtype.mk + (fun _ hf => F.mem_of_mem_inFlagsAt hf) from rfl] at hfv + obtain ⟨g, hg, hfg⟩ := List.mem_pmap.mp hfv + rw [← congrArg Subtype.val hfg]; exact hg + exact isOut_of_mem_inFlagsAt o this + +/-- matchSub flips the isOut bit. -/ +private theorem matchSub_flip_isOut {W : ClosedFragment} {F : EdgeSubset W} + {κ : F.TransitionSystem} (o : κ.Orientation) + (f : {f : W.Flag // f ∈ F.flags}) : + o.isOut (matchSub κ f).val = !(o.isOut f.val) := by + exact o.match_flip f.val f.prop + +/-! ## Nodup getElem? injection -/ + +/-- If a nodup list satisfies l[i]? = some x and l[j]? = some x, then i = j. -/ +private theorem nodup_getElem?_inj {α : Type*} {l : List α} (hl : l.Nodup) + {i j : ℕ} {x : α} (hi : l[i]? = some x) (hj : l[j]? = some x) : + i = j := by + have hilt : i < l.length := List.getElem?_eq_some_iff.mp hi |>.1 + have hjlt : j < l.length := List.getElem?_eq_some_iff.mp hj |>.1 + have hvi : l[i] = x := Option.some.inj + (List.getElem?_eq_getElem hilt ▸ hi) + have hvj : l[j] = x := Option.some.inj + (List.getElem?_eq_getElem hjlt ▸ hj) + exact hl.getElem_inj_iff.mp (hvi.trans hvj.symm) + +/-! ## pairBlowup and sign -/ + +private def fin2ProdEquiv (n : ℕ) : Fin (2 * n) ≃ Fin 2 × Fin n where + toFun p := (⟨p.val % 2, Nat.mod_lt _ (by omega)⟩, + ⟨p.val / 2, by omega⟩) + invFun q := ⟨2 * q.2.val + q.1.val, by + have := q.1.isLt; have := q.2.isLt; omega⟩ + left_inv p := Fin.ext (by simp; omega) + right_inv q := Prod.ext (Fin.ext (by simp; omega)) + (Fin.ext (by simp; omega)) + +private noncomputable def pairBlowup {n : ℕ} (ρ : Perm (Fin n)) : + Perm (Fin (2 * n)) := + (fin2ProdEquiv n).symm.permCongr + (prodCongrRight (fun _ : Fin 2 => ρ)) + +private theorem sign_pairBlowup {n : ℕ} (ρ : Perm (Fin n)) : + Perm.sign (pairBlowup ρ) = 1 := by + rw [pairBlowup, Perm.sign_permCongr, Perm.sign_prodCongrRight, + Fin.prod_univ_two] + rcases Int.units_eq_one_or (Perm.sign ρ) with h1 | h1 <;> + rw [h1] <;> simp + +/-! ## Half 1 infrastructure -/ + +/-- Pairing as a subtype-preserving function. -/ +private noncomputable def pairingSub {W : ClosedFragment} {F : EdgeSubset W} + (f : {f : W.Flag // f ∈ F.flags}) : + {f : W.Flag // f ∈ F.flags} := + ⟨W.pairing f.val, F.pairing_mem _ f.prop⟩ + +/-- pairingSub of an incoming flag is outgoing. -/ +private theorem pairingSub_isOut {W : ClosedFragment} {F : EdgeSubset W} + {κ : F.TransitionSystem} (o : κ.Orientation) + (f : {f : W.Flag // f ∈ F.flags}) (hf : o.isOut f.val = false) : + o.isOut (pairingSub f).val = true := by + rw [pairingSub, o.pairing_flip f.val f.prop, hf]; rfl + +/-- pairingSub is injective. -/ +private theorem pairingSub_injective {W : ClosedFragment} {F : EdgeSubset W} : + Function.Injective (pairingSub (F := F)) := by + intro ⟨a, ha⟩ ⟨b, hb⟩ h + have hv := congrArg Subtype.val h + simp only [pairingSub] at hv + -- pairing is injective (it's an involution) + have hab : a = b := by + calc a = W.pairing (W.pairing a) := (W.pairing_invol a).symm + _ = W.pairing (W.pairing b) := by rw [hv] + _ = b := W.pairing_invol b + exact Subtype.ext hab + +-- As for the matched list, with the pairing in place of the +-- matching. +/-- The oriented pair list as a flatMap of the incoming-flag base. -/ +private theorem orientedPairList_eq_flatMap (W : ClosedFragment) (F : EdgeSubset + W) + {κ : F.TransitionSystem} (o : κ.Orientation) : + orientedPairList W F o = + (matchedBase W F o).flatMap (fun f => [f, pairingSub f]) := by + rw [orientedPairList, matchedBase, List.flatMap_map] + congr 1 + funext ⟨e, he⟩ + unfold matchedInFlag + by_cases ho : o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) e)) = true + · simp only [ho, ite_true] + -- [partner, rep] = [partner, pairingSub partner] + have hval : (starFlagEnum W).symm (Fin.castAdd (edgeCount W) e) = + W.pairing ((starFlagEnum W).symm (Fin.natAdd (edgeCount W) e)) := by + rw [← pairing_starFlagEnum_symm W e, W.pairing_invol] + exact List.cons_eq_cons.mpr ⟨rfl, + List.cons_eq_cons.mpr ⟨Subtype.ext hval, rfl⟩⟩ + · simp only [show o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) e)) = false from by + cases h : o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) e)) <;> simp_all] + -- [rep, partner] = [rep, pairingSub rep] + exact List.cons_eq_cons.mpr ⟨rfl, + List.cons_eq_cons.mpr ⟨Subtype.ext (pairing_starFlagEnum_symm W e).symm, + rfl⟩⟩ + +/-- matchedBase is nodup. -/ +private theorem matchedBase_nodup (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) : + (matchedBase W F o).Nodup := by + rw [matchedBase] + apply List.Nodup.map _ (attachWith_partEdges_nodup W F) + intro ⟨e₁, he₁⟩ ⟨e₂, he₂⟩ h + apply Subtype.ext + have hv : (matchedInFlag o ⟨e₁, he₁⟩).val = (matchedInFlag o ⟨e₂, he₂⟩).val := + congrArg Subtype.val h + unfold matchedInFlag at hv + by_cases ho₁ : o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) e₁)) = true <;> + by_cases ho₂ : o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) e₂)) = true + · rw [ite_eq_left ho₁, ite_eq_left ho₂] at hv + exact Fin.natAdd_injective _ _ ((starFlagEnum W).symm.injective hv) + · rw [ite_eq_left ho₁, ite_eq_right ho₂] at hv + exact absurd (congrArg Fin.val ((starFlagEnum W).symm.injective hv)) + (by simp [Fin.val_castAdd]; omega) + · rw [ite_eq_right ho₁, ite_eq_left ho₂] at hv + exact absurd (congrArg Fin.val ((starFlagEnum W).symm.injective hv)) + (by simp [Fin.val_castAdd]; omega) + · rw [ite_eq_right ho₁, ite_eq_right ho₂] at hv + exact Fin.castAdd_injective _ _ ((starFlagEnum W).symm.injective hv) + +/-- Two getElem calls at the same index are equal regardless of bound proof. -/ +private theorem getElem_val_irrel {α : Type*} (l : List α) {a b : Nat} + (hab : a = b) (h₁ : a < l.length) (h₂ : b < l.length) : + l[a]'h₁ = l[b]'h₂ := by + subst hab; rfl + +/-! ## Half 1: sign of oriented → matched = sign of outPerm -/ + +-- The index permutation between the two lists is +-- computed position by position, so both flat-map presentations +-- and the out-permutation unfold together. +private theorem walkPerm_pairingSub {W : ClosedFragment} {F : EdgeSubset W} + (κ : F.TransitionSystem) (f : {g : W.Flag // g ∈ F.flags}) : + κ.walkPerm (pairingSub f) = matchSub κ f := by + apply Subtype.ext + rw [EdgeSubset.TransitionSystem.walkPerm_val] + change κ.match_ (W.pairing (W.pairing f.val)) = κ.match_ f.val + rw [W.pairing_invol] + +/-- **Half 1**: the sign of the index permutation from oriented to matched +equals the sign of the out-permutation. -/ +theorem sign_listIndexPerm_oriented_matched (W : ClosedFragment) (F : EdgeSubset + W) + {κ : F.TransitionSystem} (o : κ.Orientation) : + Perm.sign (listIndexPerm (orientedPairList W F o) (matchedPairList W F o) + (orientedPairList_nodup W F o) (matchedPairList_nodup' W F o) + (fun x => ⟨fun _ => mem_matchedPairList' W F o x, + fun _ => mem_orientedPairList W F o x⟩) + (by exact len_oriented_eq_matched W F o)) = + Perm.sign (κ.outPerm o) := by + -- ═══════ SETUP: BOTH LISTS AS FLAT-MAPPED PAIR BLOCKS ═══════ + -- Oriented and matched lists share the base `mB`, each pairing it + -- with a different partner map, so both have length `2 * mB.length` + -- and known entries at even and odd positions. + set O := orientedPairList W F o + set M := matchedPairList W F o + set τ := listIndexPerm O M (orientedPairList_nodup W F o) + (matchedPairList_nodup' W F o) + (fun x => ⟨fun _ => mem_matchedPairList' W F o x, + fun _ => mem_orientedPairList W F o x⟩) + (len_oriented_eq_matched W F o) + set mB := matchedBase W F o + have hO_eq : O = mB.flatMap (fun f => [f, pairingSub f]) := + orientedPairList_eq_flatMap W F o + have hM_eq : M = mB.flatMap (fun f => [f, matchSub κ f]) := + matchedPairList_eq_flatMap W F o + have hOlen : O.length = 2 * mB.length := by rw [hO_eq, len_flatMap_pair] + have hMlen : M.length = 2 * mB.length := by rw [hM_eq, len_flatMap_pair] + have hOMlen : O.length = M.length := by omega + have hτ : ∀ (i : Fin O.length), + M[(τ i).val]'(by have := (τ i).isLt; omega) = O[i.val] := + listIndexPerm_getElem O M _ _ _ _ + -- Helper: O[2k] and O[2k+1] from flatMap + have hO_even : ∀ (k : ℕ) (hk : k < mB.length), + O[2 * k]'(by omega) = mB[k] := by + intro k hk; simp only [O, hO_eq] + exact getElem_flatMap_pair_even mB id pairingSub k hk + have hO_odd : ∀ (k : ℕ) (hk : k < mB.length), + O[2 * k + 1]'(by omega) = pairingSub (mB[k]) := by + intro k hk; simp only [O, hO_eq] + exact getElem_flatMap_pair_odd mB id pairingSub k hk + have hM_even : ∀ (k : ℕ) (hk : k < mB.length), + M[2 * k]'(by omega) = mB[k] := by + intro k hk; simp only [M, hM_eq] + exact getElem_flatMap_pair_even mB id (matchSub κ) k hk + have hM_odd : ∀ (k : ℕ) (hk : k < mB.length), + M[2 * k + 1]'(by omega) = matchSub κ (mB[k]) := by + intro k hk; simp only [M, hM_eq] + exact getElem_flatMap_pair_odd mB id (matchSub κ) k hk + -- ═══════ STAGE 1: τ FIXES THE EVEN POSITIONS ═══════ + have hτ_even : ∀ (k : ℕ) (hk : k < mB.length), (τ ⟨2 * k, by omega⟩).val = + 2 * k := by + intro k hk + have hkey := hτ ⟨2 * k, by omega⟩ + rw [hO_even k hk] at hkey + have hMnd : M.Nodup := matchedPairList_nodup' W F o + have h1 : (τ ⟨2 * k, by omega⟩).val < M.length := by + have := (τ ⟨2 * k, by omega⟩).isLt; omega + have h2 : 2 * k < M.length := by omega + exact hMnd.getElem_inj_iff (hi := h1) (hj := h2) |>.mp + (hkey.trans (hM_even k hk).symm) + -- ═══════ STAGE 2: τ SENDS ODD POSITIONS TO ODD POSITIONS ═══════ + -- `pairingSub (mB[k])` is outgoing while every `mB[j]` is incoming, + -- so the image cannot be an even position. + have hτ_odd : ∀ (k : ℕ) (hk : k < mB.length), (τ ⟨2 * k + 1, by omega⟩).val % + 2 = 1 := by + intro k hk + have hkey := hτ ⟨2 * k + 1, by omega⟩ + rw [hO_odd k hk] at hkey + -- hkey : M[(τ ⟨2*k+1, _⟩).val]'_ = pairingSub(mB[k]) + by_contra h_even + have h_mod0 : (τ ⟨2 * k + 1, by omega⟩).val % 2 = 0 := by omega + have hj_lt : (τ ⟨2 * k + 1, by omega⟩).val / 2 < mB.length := by omega + -- Connect M at equal indices: τ(2k+1) = 2*(τ(2k+1)/2) + have hMeq : M[(τ ⟨2 * k + 1, by omega⟩).val]'(by + have := (τ ⟨2 * k + 1, by omega⟩).isLt; omega) = + M[2 * ((τ ⟨2 * k + 1, by omega⟩).val / 2)]'(by omega) := + getElem_val_irrel M (by omega) _ _ + -- Chain: pairingSub(mB[k]) = M[τ(2k+1)] = M[2j] = mB[j] + have hmatch : pairingSub (mB[k]) = + mB[(τ ⟨2 * k + 1, by omega⟩).val / 2] := + hkey.symm.trans (hMeq.trans (hM_even _ hj_lt)) + -- pairingSub(mB[k]) is outgoing + have hout : o.isOut (pairingSub (mB[k])).val = true := by + apply pairingSub_isOut + simp only [mB, matchedBase, List.getElem_map] + exact matchedInFlag_isIn W F o _ + -- mB[j] is incoming + have hin : o.isOut (mB[(τ ⟨2 * k + 1, by omega⟩).val / 2]).val = false := by + simp only [mB, matchedBase, List.getElem_map] + exact matchedInFlag_isIn W F o _ + rw [hmatch] at hout + simp [hout] at hin + -- ═══════ STAGE 3: THE ODD-BLOCK PERMUTATION ρ ═══════ + -- ρ(k) = τ(2k+1) / 2 + have hmBlen_pos : 0 < mB.length ∨ mB.length = 0 := by omega + let ρ_fn : Fin mB.length → Fin mB.length := fun ⟨k, hk⟩ => + ⟨(τ ⟨2 * k + 1, by omega⟩).val / 2, by + have := (τ ⟨2 * k + 1, by omega⟩).isLt + have := hτ_odd k hk + omega⟩ + have hρ_inj : Function.Injective ρ_fn := by + intro ⟨k₁, hk₁⟩ ⟨k₂, hk₂⟩ h + have hv := congrArg Fin.val h + change (τ ⟨2 * k₁ + 1, by omega⟩).val / 2 = + (τ ⟨2 * k₂ + 1, by omega⟩).val / 2 at hv + have hodd₁ := hτ_odd k₁ hk₁ + have hodd₂ := hτ_odd k₂ hk₂ + have hτ_val_eq : (τ ⟨2 * k₁ + 1, by omega⟩).val = + (τ ⟨2 * k₂ + 1, by omega⟩).val := by omega + have hinj := τ.injective (Fin.ext hτ_val_eq) + have hval : 2 * k₁ + 1 = 2 * k₂ + 1 := congrArg Fin.val hinj + have hk_eq : k₁ = k₂ := by omega + subst hk_eq; rfl + let ρ : Perm (Fin mB.length) := + Equiv.ofBijective ρ_fn (Finite.injective_iff_bijective.mp hρ_inj) + -- ═══════ STAGE 4: τ IS THE PAIR BLOW-UP OF ρ ═══════ + -- τ = permCongr(finCongr)(permCongr(fin2ProdEquiv⁻¹)(prodCongrRight + -- ![1, ρ])) + have hτ_eq : τ = (finCongr hOlen).symm.permCongr + ((fin2ProdEquiv mB.length).symm.permCongr + (prodCongrRight (![(1 : Perm (Fin mB.length)), ρ]))) := by + ext j + -- The permCongr/finCongr/fin2ProdEquiv chain is definitionally transparent + change (τ j).val = 2 * ((![(1 : Perm (Fin mB.length)), ρ] + ⟨j.val % 2, Nat.mod_lt _ (by omega)⟩ + ⟨j.val / 2, by omega⟩).val) + j.val % 2 + rcases Nat.even_or_odd j.val with ⟨k, hk_eq⟩ | ⟨k, hk_eq⟩ + · -- Even: j.val = k + k + have hk_lt : k < mB.length := by omega + have htj : (τ j).val = j.val := by + have hconn : (τ j).val = (τ ⟨2 * k, by omega⟩).val := + Fin.val_eq_of_eq (congrArg τ (Fin.ext (show j.val = 2 * k by omega))) + rw [hconn, hτ_even k hk_lt]; omega + simp only [htj, show j.val % 2 = 0 from by omega] + -- ![1, ρ] ⟨0, _⟩ = 1 and (1 x).val = x.val, all definitional + change j.val = 2 * (j.val / 2) + 0 + omega + · -- Odd: j.val = 2*k + 1 + have hk_lt : k < mB.length := by omega + simp only [show j.val % 2 = 1 from by omega] + -- ![1, ρ] ⟨1, _⟩ = ρ, ρ x = ρ_fn x (all definitional via let) + change (τ j).val = 2 * ((τ ⟨2 * (j.val / 2) + 1, by omega⟩).val / 2) + 1 + have hconn : (τ j).val = (τ ⟨2 * k + 1, by omega⟩).val := + Fin.val_eq_of_eq + (congrArg τ (Fin.ext (show j.val = 2 * k + 1 by omega))) + have hconn2 : (τ ⟨2 * (j.val / 2) + 1, by omega⟩).val = + (τ ⟨2 * k + 1, by omega⟩).val := + Fin.val_eq_of_eq + (congrArg τ (Fin.ext (show 2 * (j.val / 2) + 1 = 2 * k + 1 by omega))) + have hodd := hτ_odd k hk_lt + omega + -- ═══════ STAGE 5: sign τ = sign ρ ═══════ + rw [hτ_eq, Perm.sign_permCongr, Perm.sign_permCongr, + Perm.sign_prodCongrRight, Fin.prod_univ_two] + simp only [Matrix.cons_val_zero, Matrix.cons_val_one, + Perm.sign_one, one_mul] + -- Goal: Perm.sign ρ = Perm.sign (κ.outPerm o) + -- Key relationship: matchSub(mB[ρ(j)]) = pairingSub(mB[j]) + have hρ_rel : ∀ (j : Fin mB.length), + matchSub κ (mB[(ρ j).val]'(ρ j).isLt) = + pairingSub (mB[j.val]'j.isLt) := by + intro ⟨j, hj⟩ + have h1 := hτ ⟨2 * j + 1, by omega⟩ + rw [hO_odd j hj] at h1 + have hodd := hτ_odd j hj + have hτ_val : (τ ⟨2 * j + 1, by omega⟩).val = 2 * (ρ ⟨j, hj⟩).val + 1 := by + change (τ ⟨2 * j + 1, by omega⟩).val = + 2 * ((τ ⟨2 * j + 1, by omega⟩).val / 2) + 1 + omega + have h2 := getElem_val_irrel M hτ_val + (by have := (τ ⟨2 * j + 1, by omega⟩).isLt; omega) + (by omega) + have h3 := hM_odd (ρ ⟨j, hj⟩).val (ρ ⟨j, hj⟩).isLt + exact h3.symm.trans (h2.symm.trans h1) + -- ═══════ STAGE 6: ρ IS CONJUGATE TO THE OUT-PERMUTATION ═══════ + -- Define e : Fin mB.length → {out-flags} + let e_fn : Fin mB.length → + {f : {g : W.Flag // g ∈ F.flags} // o.isOut f.val = true} := + fun ⟨k, hk⟩ => ⟨pairingSub (mB[k]'hk), by + apply pairingSub_isOut + simp only [mB, matchedBase, List.getElem_map] + exact matchedInFlag_isIn W F o _⟩ + have e_inj : Function.Injective e_fn := by + intro ⟨k₁, hk₁⟩ ⟨k₂, hk₂⟩ h + have hv : pairingSub (mB[k₁]) = pairingSub (mB[k₂]) := + congrArg Subtype.val h + have hps := pairingSub_injective hv + exact Fin.ext ((matchedBase_nodup W F o).getElem_inj_iff.mp hps) + have e_surj : Function.Surjective e_fn := by + intro ⟨f, hf_out⟩ + have hf_mem : f ∈ O := mem_orientedPairList W F o f + rw [hO_eq] at hf_mem + simp only [List.mem_flatMap, List.mem_cons, + List.mem_nil_iff, or_false] at hf_mem + obtain ⟨g, hg_mem, rfl | rfl⟩ := hf_mem + · -- g is incoming (in mB), contradiction with hf_out + exfalso + simp only [mB, matchedBase, List.mem_map] at hg_mem + obtain ⟨e, _, rfl⟩ := hg_mem + exact absurd hf_out (by simp [matchedInFlag_isIn W F o e]) + · -- f = pairingSub g, find g's index in mB + obtain ⟨k, hk_lt, hk_eq⟩ := List.getElem_of_mem hg_mem + exact ⟨⟨k, hk_lt⟩, Subtype.ext (congrArg pairingSub hk_eq)⟩ + let e : Fin mB.length ≃ + {f : {g : W.Flag // g ∈ F.flags} // o.isOut f.val = true} := + Equiv.ofBijective e_fn ⟨e_inj, e_surj⟩ + -- Helper: walkPerm ∘ pairingSub = matchSub on matched base + have hwalk_eq : ∀ (k : ℕ) (hk : k < mB.length), + κ.walkPerm (pairingSub (mB[k]'hk)) = matchSub κ (mB[k]'hk) := by + exact fun k hk => walkPerm_pairingSub κ (mB[k]'hk) + -- Pointwise conjugation: outPerm(e_fn(j)) = e_fn(ρ⁻¹(j)) + have hconj_fn : ∀ (j : Fin mB.length), + (κ.outPerm o) (e_fn j) = e_fn (ρ⁻¹ j) := by + intro ⟨k, hk⟩ + apply Subtype.ext + simp only [EdgeSubset.TransitionSystem.outPerm, Perm.subtypePerm_apply] + -- Goal: walkPerm(pairingSub(mB[k])) = pairingSub(mB[(ρ⁻¹ k).val]) + rw [hwalk_eq k hk] + -- Goal: matchSub κ (mB[k]) = pairingSub(mB[(ρ⁻¹ k).val]) + have hrel := hρ_rel (ρ⁻¹ ⟨k, hk⟩) + rwa [show (ρ (ρ⁻¹ ⟨k, hk⟩) : Fin mB.length) = ⟨k, hk⟩ + from ρ.apply_symm_apply _] at hrel + -- Permutation conjugation: e.permCongr ρ⁻¹ = outPerm + have hperm_conj : e.permCongr ρ⁻¹ = κ.outPerm o := by + ext1 x + simp only [Equiv.permCongr_apply] + -- Goal: e (ρ⁻¹ (e.symm x)) = (κ.outPerm o) x + have h := hconj_fn (e.symm x) + rw [show (e_fn (e.symm x) : + {f : {g : W.Flag // g ∈ F.flags} // o.isOut f.val = true}) = x + from e.apply_symm_apply x] at h + exact h.symm + -- sign(ρ) = sign(ρ⁻¹) = sign(e.permCongr ρ⁻¹) = sign(outPerm) + calc Perm.sign ρ + = Perm.sign ρ⁻¹ := (Perm.sign_inv ρ).symm + _ = Perm.sign (e.permCongr ρ⁻¹) := (Perm.sign_permCongr e ρ⁻¹).symm + _ = Perm.sign (κ.outPerm o) := congrArg Perm.sign hperm_conj + +/-! ## Half 2: sign of matched → global = 1 -/ + +-- As for the first half: the index permutation is computed +-- position by position, here to show it is even. +/-- **Half 2**: the sign of the index permutation from matched to +global pair list is +1. -/ +theorem sign_listIndexPerm_matched_global (W : ClosedFragment) (F : EdgeSubset + W) + {κ : F.TransitionSystem} (o : κ.Orientation) : + Perm.sign (listIndexPerm (matchedPairList W F o) (globalPairList W F o) + (matchedPairList_nodup' W F o) (by exact globalPairList_nodup' W F o) + (by + intro x + exact ⟨fun _ => mem_globalPairList' W F o x, + fun _ => mem_matchedPairList' W F o x⟩) + (by exact len_matched_eq_global W F o)) = + 1 := by + -- ═══════ SETUP: BOTH LISTS AS FLAT-MAPPED PAIR BLOCKS ═══════ + -- Matched and global lists pair their own bases with the same + -- partner map, so both split into two-element blocks. + set M := matchedPairList W F o + set G := globalPairList W F o + have hM : M.Nodup := matchedPairList_nodup' W F o + have hG : G.Nodup := globalPairList_nodup' W F o + have hmem : ∀ x, x ∈ M ↔ x ∈ G := fun x => + ⟨fun _ => mem_globalPairList' W F o x, + fun _ => mem_matchedPairList' W F o x⟩ + have hlen : M.length = G.length := len_matched_eq_global W F o + set τ := listIndexPerm M G hM hG hmem hlen + -- Key property of τ: G[(τ i).val] = M[i.val] + have hτ : ∀ i : Fin M.length, + G[(τ i).val]'(by have := (τ i).isLt; omega) = M[i.val] := + listIndexPerm_getElem M G hM hG hmem hlen + -- Abbreviations for base lists + set mB := matchedBase W F o + set gB := globalBase W F o + -- matched = mB.flatMap(fun f => [f, matchSub κ f]) + have hMeq : M = mB.flatMap (fun f => [f, matchSub κ f]) := + matchedPairList_eq_flatMap W F o + -- global = gB.flatMap(fun f => [f, matchSub κ f]) + have hGeq : G = gB.flatMap (fun f => [f, matchSub κ f]) := + globalPairList_eq_flatMap W F o + -- Length facts + have hMlen : M.length = 2 * mB.length := by + rw [hMeq]; exact len_flatMap_pair mB id (matchSub κ) + have hGlen : G.length = 2 * gB.length := by + rw [hGeq]; exact len_flatMap_pair gB id (matchSub κ) + have hBlen : mB.length = gB.length := by omega + -- Pairing: M[2k+1]? = M[2k]?.map matchSub + have hMpair : ∀ j, M[2 * j + 1]? = M[2 * j]?.map (matchSub κ) := + matchedPairList_paired W F o + -- Pairing: G[2j+1]? = G[2j]?.map matchSub + have hGpair : ∀ j, G[2 * j + 1]? = G[2 * j]?.map (matchSub κ) := + globalPairList_paired W F o + -- For each even index 2k in M, the element is from matchedBase (incoming) + -- M[2k] = mB[k], M[2k+1] = matchSub(mB[k]) + -- For each even index 2j in G, the element is from globalBase (incoming) + -- G[2j] = gB[j], G[2j+1] = matchSub(gB[j]) + -- ═══════ STAGE 1: BOTH BASES ARE INCOMING, THE PARTNER FLIPS ═══════ + -- Step 1: matchedBase elements are incoming + have hmB_in : ∀ e : { x // x ∈ edgeIndexSet W F }, + o.isOut (matchedInFlag o e).val = false := + matchedInFlag_isIn W F o + -- Step 2: globalBase elements are incoming + have hgB_in : ∀ f, f ∈ gB → o.isOut f.val = false := + globalBase_isIn W F o + -- Step 3: matchSub flips isOut + have hflip : ∀ f : {f : W.Flag // f ∈ F.flags}, + o.isOut (matchSub κ f).val = !(o.isOut f.val) := + matchSub_flip_isOut o + -- ═══════ STAGE 2: BLOCK STRUCTURE SUFFICES ═══════ + -- Granting that τ carries each two-element block onto a block, the + -- sign is the blow-up of a permutation of blocks, hence even. + suffices hblock : ∀ (k : ℕ) (hk : k < mB.length), + (τ ⟨2 * k, by omega⟩).val % 2 = 0 ∧ + (τ ⟨2 * k + 1, by omega⟩).val = (τ ⟨2 * k, by omega⟩).val + 1 by + -- Extract individual facts + have heven : ∀ (k : ℕ) (hk : k < mB.length), + (τ ⟨2 * k, by omega⟩).val % 2 = 0 := fun k hk => (hblock k hk).1 + have hpair : ∀ (k : ℕ) (hk : k < mB.length), + (τ ⟨2 * k + 1, by omega⟩).val = (τ ⟨2 * k, by omega⟩).val + 1 := + fun k hk => (hblock k hk).2 + -- Define σ(k) = τ(2k) / 2 + have hσ_bound : ∀ (k : ℕ) (hk : k < mB.length), + (τ ⟨2 * k, by omega⟩).val / 2 < mB.length := fun k hk => by + have := (τ ⟨2 * k, by omega⟩).isLt; omega + let σ_fn : Fin mB.length → Fin mB.length := fun ⟨k, hk⟩ => + ⟨(τ ⟨2 * k, by omega⟩).val / 2, hσ_bound k hk⟩ + have hσ_inj : Function.Injective σ_fn := by + intro ⟨k₁, hk₁⟩ ⟨k₂, hk₂⟩ heq + have h₁ := heven k₁ hk₁ + have h₂ := heven k₂ hk₂ + have hveq : (τ ⟨2 * k₁, by omega⟩).val / 2 = + (τ ⟨2 * k₂, by omega⟩).val / 2 := Fin.mk.inj heq + have hτeq : (τ ⟨2 * k₁, by omega⟩).val = + (τ ⟨2 * k₂, by omega⟩).val := by omega + have h2keq := Fin.val_eq_of_eq (τ.injective (Fin.ext hτeq)) + change 2 * k₁ = 2 * k₂ at h2keq + exact Fin.ext (show k₁ = k₂ by omega) + let σ : Perm (Fin mB.length) := + Equiv.ofBijective σ_fn + ⟨hσ_inj, (Finite.injective_iff_surjective.mp hσ_inj)⟩ + -- τ = (finCongr hMlen).symm.permCongr (pairBlowup σ) + have hτ_eq : τ = (finCongr hMlen).symm.permCongr (pairBlowup σ) := by + ext j + -- Unfold permCongr: e.permCongr p x = e (p (e.symm x)) + -- The permCongr_apply simp lemma should fire but may not work here. + -- Instead, compute directly using suffices. + -- The permCongr + finCongr on the RHS is transparent to .val + -- The permCongr/finCongr and σ/σ_fn are all definitionally transparent + change (τ j).val = 2 * ((τ ⟨2 * (j.val / 2), by omega⟩).val / 2) + j.val % + 2 + -- Case split on parity of j.val + rcases Nat.even_or_odd j.val with ⟨k, hk_eq⟩ | ⟨k, hk_eq⟩ + · -- j.val = 2k: τ(j) = τ(⟨2k,_⟩), and 2*(j/2) = 2k + have htj : (τ j).val = (τ ⟨2 * k, by omega⟩).val := + Fin.val_eq_of_eq (congrArg τ (Fin.ext (show j.val = 2 * k by omega))) + have hconn : (τ ⟨2 * (j.val / 2), by omega⟩).val = + (τ ⟨2 * k, by omega⟩).val := + Fin.val_eq_of_eq + (congrArg τ (Fin.ext (show 2 * (j.val / 2) = 2 * k by omega))) + have hev := heven k (by omega) + have hjm : j.val % 2 = 0 := by omega + omega + · -- j.val = 2k+1: use hpair + have htj : (τ j).val = (τ ⟨2 * k + 1, by omega⟩).val := + Fin.val_eq_of_eq + (congrArg τ (Fin.ext (show j.val = 2 * k + 1 by omega))) + have hconn : (τ ⟨2 * (j.val / 2), by omega⟩).val = + (τ ⟨2 * k, by omega⟩).val := + Fin.val_eq_of_eq + (congrArg τ (Fin.ext (show 2 * (j.val / 2) = 2 * k by omega))) + have hev := heven k (by omega) + have hpr := hpair k (by omega) + have hjm : j.val % 2 = 1 := by omega + omega + rw [hτ_eq, Equiv.Perm.sign_permCongr, sign_pairBlowup] + -- ═══════ STAGE 3: THE BLOCK CLAIM ═══════ + -- The image of an even position is even (both entries are incoming, + -- and only even positions carry incoming flags), and the odd + -- position of a block follows its even one. + intro k hk + have h2k_lt : 2 * k < M.length := by omega + have h2k1_lt : 2 * k + 1 < M.length := by omega + set m := (τ ⟨2 * k, h2k_lt⟩).val + set m1 := (τ ⟨2 * k + 1, h2k1_lt⟩).val + have hGm : G[m]'(by have := (τ ⟨2 * k, h2k_lt⟩).isLt; omega) = M[2 * k] := + hτ ⟨2 * k, h2k_lt⟩ + have hGm1 : G[m1]'(by have := (τ ⟨2 * k + 1, h2k1_lt⟩).isLt; omega) = + M[2 * k + 1] := + hτ ⟨2 * k + 1, h2k1_lt⟩ + have hM_pair_k : M[2 * k + 1]? = (M[2 * k]?).map (matchSub κ) := hMpair k + have h2k_bound : 2 * k < M.length := h2k_lt + have h2k1_bound : 2 * k + 1 < M.length := h2k1_lt + rw [List.getElem?_eq_getElem h2k_bound, + List.getElem?_eq_getElem h2k1_bound] at hM_pair_k + have hM2k1_eq : M[2 * k + 1] = matchSub κ (M[2 * k]) := + Option.some.inj hM_pair_k + -- M[2k] = mB[k] (incoming) + have hM2k_even : M[2 * k]? = (mB[k]?).map id := by + have key : (fun x : {f : W.Flag // f ∈ F.flags} => + ([x, matchSub κ x] : List _)) = + fun x => [id x, matchSub κ x] := by ext; simp + rw [hMeq, key]; exact getElem?_flatMap_pair_even mB id (matchSub κ) k + rw [List.getElem?_eq_getElem h2k_bound, List.getElem?_eq_getElem hk] + at hM2k_even + have hM2k_is_mBk : M[2 * k] = mB[k] := by + have := Option.some.inj hM2k_even; simp only [id_eq] at this; exact this + have hmBk_in : o.isOut (mB[k]'hk).val = false := by + simp only [mB, matchedBase, List.getElem_map] + exact matchedInFlag_isIn W F o _ + have hM2k_in : o.isOut (M[2 * k]'h2k_bound).val = false := by + rw [hM2k_is_mBk]; exact hmBk_in + have hGm_in : o.isOut (G[m]'(by have := (τ ⟨2 * k, h2k_lt⟩).isLt; omega)).val + = false := by + rw [hGm, hM2k_in] + -- Evenness: m = τ(2k) is even + have hm_even : m % 2 = 0 := by + by_contra hm_odd + have hm_odd' : m % 2 = 1 := by omega + set j := m / 2 + have hm_eq : m = 2 * j + 1 := by omega + have hj_lt : j < gB.length := by + have : m < M.length := (τ ⟨2 * k, h2k_lt⟩).isLt; omega + have hGm_odd_eq : G[m]? = (gB[j]?).map (matchSub κ) := by + rw [hm_eq, hGeq] + exact getElem?_flatMap_pair_odd gB id (matchSub κ) j + rw [List.getElem?_eq_getElem (by have := (τ ⟨2 * k, h2k_lt⟩).isLt; omega), + List.getElem?_eq_getElem hj_lt] at hGm_odd_eq + have hGm_eq_matchSub : G[m] = matchSub κ (gB[j]) := + Option.some.inj hGm_odd_eq + have : o.isOut (G[m]'(by have := (τ ⟨2 * k, h2k_lt⟩).isLt; omega)).val = + true := by + rw [hGm_eq_matchSub, hflip] + have : o.isOut (gB[j]'hj_lt).val = false := + hgB_in _ (List.getElem_mem hj_lt) + rw [this]; rfl + rw [hGm_in] at this; exact Bool.noConfusion this + -- Pairing: m1 = m + 1 + refine ⟨hm_even, ?_⟩ + set j := m / 2 + have hm_eq : m = 2 * j := by omega + have hm_bound : m < M.length := (τ ⟨2 * k, h2k_lt⟩).isLt + have hj_lt : j < gB.length := by omega + have hGpair_j : G[2 * j + 1]? = G[2 * j]?.map (matchSub κ) := hGpair j + have h2j_lt : 2 * j < G.length := by omega + have h2j1_lt : 2 * j + 1 < G.length := by omega + rw [List.getElem?_eq_getElem h2j_lt, + List.getElem?_eq_getElem h2j1_lt] at hGpair_j + have hG2j1 : G[2 * j + 1] = matchSub κ (G[2 * j]) := + Option.some.inj hGpair_j + have hG2j_eq : G[2 * j]'h2j_lt = M[2 * k] := by + convert hGm using 1; congr 1; omega + have hG2j1_eq : G[2 * j + 1]'h2j1_lt = M[2 * k + 1] := by + rw [hG2j1, hG2j_eq, hM2k1_eq] + have hm1_eq : m1 = 2 * j + 1 := by + have hGm1_opt : G[m1]? = some (M[2 * k + 1]) := by + rw [List.getElem?_eq_getElem + (by have := (τ ⟨2 * k + 1, h2k1_lt⟩).isLt; omega)] + exact congrArg some hGm1 + have hG2j1_opt : G[2 * j + 1]? = some (M[2 * k + 1]) := by + rw [List.getElem?_eq_getElem h2j1_lt] + exact congrArg some hG2j1_eq + exact nodup_getElem?_inj hG hGm1_opt hG2j1_opt + change m1 = m + 1 + rw [hm1_eq, hm_eq] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/Reindex.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/Reindex.lean new file mode 100644 index 0000000000..7f3a09d8ac --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/Reindex.lean @@ -0,0 +1,131 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarRepeat +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SlotPairing +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.EulerianIndependence + +/-! +# The Eulerian reindex + +The master summand, the flag pattern of a colouring, and the +fibrewise partition of the master colour sum over flag patterns. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Finset +open Functor.LaxMonoidal Functor.OplaxMonoidal + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} +variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) +variable (e' : P.ω.obj (SkeinObj.mk 1) ⟶ stdSuperPair k ℓ) + +/-- The master summand of a colouring. -/ +noncomputable def masterSummand (W : ClosedFragment) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) : + ℂ := + ((-1 : ℂ) ^ oddInversions (sortSplitPerm W) + (c ∘ finCongr (degList_sum (starAssignEnum W))) * + ∏ v, starCoord f P e' + ((degList (starAssignEnum W)).get v) + (blockRestrict (degList (starAssignEnum W)) + ((c ∘ finCongr + (degList_sum (starAssignEnum W))) ∘ + sortSplitPerm W) v)) * + betaDiag (edgeCount W) c + +/-- The master colour sum, in summand form. -/ +theorem parameter_masterSummand (W : ClosedFragment) + (hee' : (e' ≫ e : P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk 1)) = 𝟙 _) + (hform : + letI := P.braided + SuperVect.Hom.comp + (μ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1) ≫ + P.ω.map (ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) ≫ + η P.ω) + (SuperVect.tensorHom e e) = stdForm k ℓ) : + f.val W = circleVal f ^ W.circles * + ∑ c : {c : MixedColouring k ℓ + (edgeCount W + edgeCount W) // c.IsEven}, + masterSummand f P e' W c.val := + parameter_colour_sum f P e e' W hee' hform + +open Classical in +/-- The flag pattern of a colouring: the flags at odd slots. -/ +noncomputable def colourFlags (W : ClosedFragment) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) : + Finset W.Flag := + (MixedColouring.oddSet c).image + (fun s => (starFlagEnum W).symm s) + +open Classical in +/-- **The pattern partition of the master sum.** -/ +theorem masterSum_partition (W : ClosedFragment) : + (∑ c : {c : MixedColouring k ℓ + (edgeCount W + edgeCount W) // c.IsEven}, + masterSummand f P e' W c.val) = + ∑ s : Finset W.Flag, + ∑ c ∈ Finset.univ.filter + (fun c : {c : MixedColouring k ℓ + (edgeCount W + edgeCount W) // c.IsEven} => + colourFlags W c.val = s), + masterSummand f P e' W c.val := + (Finset.sum_fiberwise _ _ _).symm + +/-- Parity purity: cap-paired slots share parity. -/ +def PairPure {m : ℕ} (c : MixedColouring k ℓ (m + m)) : + Prop := + ∀ i : Fin m, + (c (Fin.castAdd m i)).isRight = + (c (Fin.natAdd m i)).isRight + +open Classical in +/-- **Pure patterns are pairing-closed.** -/ +theorem colourFlags_pairing_mem (W : ClosedFragment) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) + (hpure : PairPure c) : + ∀ g ∈ colourFlags W c, + W.pairing g ∈ colourFlags W c := by + intro g hg + rw [colourFlags, Finset.mem_image] at hg ⊢ + obtain ⟨s, hs, rfl⟩ := hg + rw [MixedColouring.oddSet, Finset.mem_filter] at hs + obtain ⟨-, hodd⟩ := hs + cases s using Fin.addCases with + | left i => + refine ⟨Fin.natAdd (edgeCount W) i, ?_, ?_⟩ + · rw [MixedColouring.oddSet, Finset.mem_filter] + exact ⟨Finset.mem_univ _, by + rw [show ((c (Fin.natAdd (edgeCount W) i)).isRight : + Prop) = ((c (Fin.castAdd (edgeCount W) + i)).isRight : Prop) from by rw [hpure i]] + exact hodd⟩ + · exact (pairing_starFlagEnum_symm W i).symm + | right i => + refine ⟨Fin.castAdd (edgeCount W) i, ?_, ?_⟩ + · rw [MixedColouring.oddSet, Finset.mem_filter] + exact ⟨Finset.mem_univ _, by + rw [show ((c (Fin.castAdd (edgeCount W) + i)).isRight : Prop) = + ((c (Fin.natAdd (edgeCount W) i)).isRight : + Prop) from by rw [hpure i]] + exact hodd⟩ + · rw [show W.pairing ((starFlagEnum W).symm + (Fin.natAdd (edgeCount W) i)) = + (starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i) from by + rw [← pairing_starFlagEnum_symm W i, + W.pairing_invol]] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexBij.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexBij.lean new file mode 100644 index 0000000000..53f125efe3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexBij.lean @@ -0,0 +1,246 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexVanish + +/-! +# The fibre bijection + +Closed-pattern fibres are pure; their sums reindex over the +colouring data through the diagonal parametrization. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Finset + + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} +variable (e' : P.ω.obj (SkeinObj.mk 1) ⟶ stdSuperPair k ℓ) + +/-- Closed patterns force purity. -/ +theorem pairPure_of_pattern_closed (W : ClosedFragment) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) + (s : Finset W.Flag) + (hfibre : colourFlags W c = s) + (hclosed : ∀ g ∈ s, W.pairing g ∈ s) : + PairPure c := by + intro i + have hmem_iff : ∀ t : Fin (edgeCount W + edgeCount W), + ((starFlagEnum W).symm t ∈ s) ↔ + (c t).isRight = true := by + intro t + rw [← hfibre, mem_colourFlags_iff, + _root_.Equiv.apply_symm_apply] + by_cases h1 : (c (Fin.castAdd (edgeCount W) i)).isRight = + true + · rw [h1] + have hmem := (hmem_iff _).mpr h1 + have hmem2 := hclosed _ hmem + rw [pairing_starFlagEnum_symm W i] at hmem2 + exact ((hmem_iff _).mp hmem2).symm + · rw [Bool.not_eq_true] at h1 + rw [h1] + by_cases h2 : (c (Fin.natAdd (edgeCount W) + i)).isRight = true + · exfalso + have hmem := (hmem_iff _).mpr h2 + have hmem2 := hclosed _ hmem + rw [show W.pairing ((starFlagEnum W).symm + (Fin.natAdd (edgeCount W) i)) = + (starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i) from by + rw [← pairing_starFlagEnum_symm W i, + W.pairing_invol]] at hmem2 + have := (hmem_iff _).mp hmem2 + rw [this] at h1 + exact Bool.noConfusion h1 + · rw [Bool.not_eq_true] at h2 + rw [h2] + +private theorem oddColouringOf_congr (W : ClosedFragment) + (F : EdgeSubset W) + (c₁ c₂ : MixedColouring k ℓ + (edgeCount W + edgeCount W)) + (h : c₁ = c₂) (h₁ : colourFlags W c₁ = F.flags) + (h₂ : colourFlags W c₂ = F.flags) : + oddColouringOf W F c₁ h₁ = oddColouringOf W F c₂ h₂ := by + subst h; rfl + +private theorem evenColouringOf_congr (W : ClosedFragment) + (F : EdgeSubset W) + (c₁ c₂ : MixedColouring k ℓ + (edgeCount W + edgeCount W)) + (h : c₁ = c₂) (h₁ : colourFlags W c₁ = F.flags) + (h₂ : colourFlags W c₂ = F.flags) + (hd₁ : Diagonal W c₁) (hd₂ : Diagonal W c₂) : + evenColouringOf W F c₁ h₁ hd₁ = + evenColouringOf W F c₂ h₂ hd₂ := by + subst h; rfl + +-- The fibre sum is reindexed along the +-- data bijection, which unfolds the colouring construction on +-- both the even and the odd side. +/-- **The fibre sum reindexes over the colouring data.** -/ +theorem fibreSum_eq_dataSum (W : ClosedFragment) + (F : EdgeSubset W) : + (∑ c ∈ Finset.univ.filter + (fun c : {c : MixedColouring k ℓ + (edgeCount W + edgeCount W) // c.IsEven} => + colourFlags W c.val = F.flags), + masterSummand f P e' W c.val) = + ∑ ψ : F.EvenColouring k, ∑ φ : F.OddColouring ℓ, + masterSummand f P e' W (colouringOf W F ψ φ) := by + classical + have hrestrict : (∑ c ∈ Finset.univ.filter + (fun c : {c : MixedColouring k ℓ + (edgeCount W + edgeCount W) // c.IsEven} => + colourFlags W c.val = F.flags), + masterSummand f P e' W c.val) = + ∑ c ∈ Finset.univ.filter + (fun c : {c : MixedColouring k ℓ + (edgeCount W + edgeCount W) // c.IsEven} => + colourFlags W c.val = F.flags ∧ + Diagonal W c.val), + masterSummand f P e' W c.val := by + refine (Finset.sum_subset ?_ ?_).symm + · intro c hc + rw [Finset.mem_filter] at hc ⊢ + exact ⟨hc.1, hc.2.1⟩ + · intro c hcA hcnB + rw [Finset.mem_filter] at hcA + have hdiagfail : ¬ Diagonal W c.val := by + intro hd + exact hcnB (by + rw [Finset.mem_filter] + exact ⟨hcA.1, hcA.2, hd⟩) + exact masterSummand_vanish_of_not_diagonal f P e' W + c.val (pairPure_of_pattern_closed W c.val F.flags + hcA.2 F.pairing_mem) hdiagfail + have hbij : (∑ p : F.EvenColouring k × F.OddColouring ℓ, + masterSummand f P e' W (colouringOf W F p.1 p.2)) = + ∑ c ∈ Finset.univ.filter + (fun c : {c : MixedColouring k ℓ + (edgeCount W + edgeCount W) // c.IsEven} => + colourFlags W c.val = F.flags ∧ + Diagonal W c.val), + masterSummand f P e' W c.val := by + refine Finset.sum_bij + (i := fun p _ => + (⟨colouringOf W F p.1 p.2, + colouringOf_isEven W F p.1 p.2⟩ : + {c : MixedColouring k ℓ + (edgeCount W + edgeCount W) // c.IsEven})) + ?_ ?_ ?_ ?_ + · intro p _ + rw [Finset.mem_filter] + exact ⟨Finset.mem_univ _, + colourFlags_colouringOf W F p.1 p.2, + colouringOf_diagonal W F p.1 p.2⟩ + · intro p _ q _ hpq + have hval := congrArg Subtype.val hpq + have heven : p.1 = q.1 := + (evenColouringOf_colouringOf W F p.1 p.2).symm.trans + ((evenColouringOf_congr W F _ _ hval _ _ _ _).trans + (evenColouringOf_colouringOf W F q.1 q.2)) + have hodd : p.2 = q.2 := + (oddColouringOf_colouringOf W F p.1 p.2).symm.trans + ((oddColouringOf_congr W F _ _ hval _ _).trans + (oddColouringOf_colouringOf W F q.1 q.2)) + exact Prod.ext heven hodd + · intro b hb + rw [Finset.mem_filter] at hb + obtain ⟨-, hfib, hdiag⟩ := hb + refine ⟨(evenColouringOf W F b.val hfib hdiag, + oddColouringOf W F b.val hfib), + Finset.mem_univ _, ?_⟩ + exact Subtype.ext + (colouringOf_reconstruct W F b.val hfib hdiag) + · intro p _ + rfl + refine hrestrict.trans (Eq.trans hbij.symm ?_) + exact Fintype.sum_prod_type + (f := fun p : F.EvenColouring k × F.OddColouring ℓ => + masterSummand f P e' W (colouringOf W F p.1 p.2)) + +open Classical in +/-- The edge set of an edge subset: representative slots whose +flags participate. -/ +noncomputable def edgeIndexSet (W : ClosedFragment) + (F : EdgeSubset W) : Finset (Fin (edgeCount W)) := + Finset.univ.filter (fun i => + (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i) ∈ + F.flags) + +open Classical in +/-- **The crossings of a data colouring**: both-participating +pairs. -/ +theorem koszulCrossings_colouringOf (W : ClosedFragment) + (F : EdgeSubset W) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) : + koszulCrossings + (MixedColouring.firstHalf (a := edgeCount W) + (b := edgeCount W) (colouringOf W F ψ φ)) + (MixedColouring.secondHalf (a := edgeCount W) + (b := edgeCount W) (colouringOf W F ψ φ)) = + (Finset.univ.filter + (fun p : Fin (edgeCount W) × Fin (edgeCount W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ + p.2 ∈ edgeIndexSet W F)).card := by + unfold koszulCrossings + refine congrArg Finset.card (Finset.filter_congr + (fun p _ => ?_)) + have hmem : ∀ t : Fin (edgeCount W + edgeCount W), + ((colouringOf W F ψ φ) t).isRight = true ↔ + (starFlagEnum W).symm t ∈ F.flags := by + intro t + constructor + · intro h + rw [← colourFlags_colouringOf W F ψ φ] + rw [mem_colourFlags_iff, + _root_.Equiv.apply_symm_apply] + exact h + · intro h + rw [← colourFlags_colouringOf W F ψ φ] at h + rw [mem_colourFlags_iff, + _root_.Equiv.apply_symm_apply] at h + exact h + constructor + · rintro ⟨hlt, h2, h1⟩ + refine ⟨hlt, ?_, ?_⟩ + · rw [edgeIndexSet, Finset.mem_filter] + refine ⟨Finset.mem_univ _, ?_⟩ + have := (hmem (Fin.natAdd (edgeCount W) p.1)).mp h1 + rw [show (starFlagEnum W).symm + (Fin.natAdd (edgeCount W) p.1) = + W.pairing ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) p.1)) from + (pairing_starFlagEnum_symm W p.1).symm] at this + have h3 := F.pairing_mem _ this + rw [W.pairing_invol] at h3 + exact h3 + · rw [edgeIndexSet, Finset.mem_filter] + exact ⟨Finset.mem_univ _, + (hmem (Fin.castAdd (edgeCount W) p.2)).mp h2⟩ + · rintro ⟨hlt, h1, h2⟩ + rw [edgeIndexSet, Finset.mem_filter] at h1 h2 + refine ⟨hlt, ?_, ?_⟩ + · exact (hmem (Fin.castAdd (edgeCount W) p.2)).mpr h2.2 + · refine (hmem (Fin.natAdd (edgeCount W) p.1)).mpr ?_ + rw [show (starFlagEnum W).symm + (Fin.natAdd (edgeCount W) p.1) = + W.pairing ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) p.1)) from + (pairing_starFlagEnum_symm W p.1).symm] + exact F.pairing_mem _ h1.2 + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexHeart.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexHeart.lean new file mode 100644 index 0000000000..5640c3190b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexHeart.lean @@ -0,0 +1,320 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFValue +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleModel + +/-! +# The reindexing at the heart of the extraction + +The master summand under a colouring flip, the fibre sum it induces, +and the identification of the parameter with Definition 5's mixed +partition function. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory Finset +open Functor.LaxMonoidal Functor.OplaxMonoidal + + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} +variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) +variable (e' : P.ω.obj (SkeinObj.mk 1) ⟶ stdSuperPair k ℓ) + +-- The termwise identity assembles the star +-- coordinates, the cap pairing and every sign family into one +-- equation. +/-- **The termwise value identity**: the master summand of the +flipped data colouring is the Definition 5 term. -/ +theorem masterSummand_colouringOfFlip + (hee' : (e' ≫ e : P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk 1)) = 𝟙 _) + (he'e : (e ≫ e' : stdSuperPair k ℓ ⟶ stdSuperPair k ℓ) = 𝟙 _) + (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) : + masterSummand f P e' W (colouringOfFlip W F o ψ φ) = + ((-1 : ℂ) ^ κ.circuitCount) * + ∏ v : W.Vertex, + ((F.oddSignAt o φ v : ℂ) * + (hRS f P e').evalOdd (F.evenColoursAt ψ v) + (F.oddListAt o φ v)) := by + have hmaster : masterSummand f P e' W + (colouringOfFlip W F o ψ φ) = + ((-1 : ℂ) ^ oddInversions (sortSplitPerm W) + ((colouringOfFlip W F o ψ φ) ∘ + finCongr (degList_sum (starAssignEnum W))) * + ∏ v, starCoord f P e' + ((degList (starAssignEnum W)).get v) + (blockRestrict (degList (starAssignEnum W)) + (((colouringOfFlip W F o ψ φ) ∘ finCongr + (degList_sum (starAssignEnum W))) ∘ + sortSplitPerm W) v)) * + betaDiag (edgeCount W) (colouringOfFlip W F o ψ φ) := rfl + rw [hmaster] + rw [show oddInversions (sortSplitPerm W) + ((colouringOfFlip W F o ψ φ) ∘ + finCongr (degList_sum (starAssignEnum W))) = + patternOddInv W F from oddInversions_colouringOf W F ψ _] + rw [betaDiag_colouringOfFlip W F o ψ φ] + rw [prod_blockVertex W (fun vtx => + (F.oddSignAt o φ vtx : ℂ) * + (hRS f P e').evalOdd (F.evenColoursAt ψ vtx) + (F.oddListAt o φ vtx))] + rw [prod_blockVertex W (fun vtx => + ((F.oddSignAt o φ vtx : ℤ) : ℂ))] + -- ═══════ EVERY BLOCK'S ODD LIST IS DUPLICATE-FREE ═══════ + -- Then each block factor is its sorting sign times the vertex + -- factor, and the grand parity collects the sign families. + by_cases hnd : ∀ v : Fin (ds W).length, + (F.oddListAt o φ (blockVertex W v)).Nodup + · rw [Finset.prod_congr rfl (fun v _ => + starCoord_block_flip_nodup f P e e' hee' he'e + W F o ψ φ v (hnd v))] + have hgp := grand_parity W F o ψ φ hnd + have hsplitL : (∏ v : Fin (ds W).length, + ((sortSign (oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v)) : ℂ) * + ((sortSign (F.oddListAt o φ + (blockVertex W v)) : ℂ) * + (hRS f P e').evalOdd + (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v))))) = + (∏ v : Fin (ds W).length, + ((sortSign (oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v)) : ℂ) * + (sortSign (F.oddListAt o φ + (blockVertex W v)) : ℂ))) * + ∏ v : Fin (ds W).length, + (hRS f P e').evalOdd + (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v)) := by + rw [← Finset.prod_mul_distrib] + exact Finset.prod_congr rfl (fun v _ => by ring) + have hsplitR : (∏ v : Fin (ds W).length, + ((F.oddSignAt o φ (blockVertex W v) : ℂ) * + (hRS f P e').evalOdd + (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v)))) = + (∏ v : Fin (ds W).length, + ((F.oddSignAt o φ (blockVertex W v) : ℤ) : ℂ)) * + ∏ v : Fin (ds W).length, + (hRS f P e').evalOdd + (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v)) := by + rw [← Finset.prod_mul_distrib] + calc ((-1 : ℂ) ^ patternOddInv W F * + (∏ v : Fin (ds W).length, + ((sortSign (oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) + v)) : ℂ) * + ((sortSign (F.oddListAt o φ + (blockVertex W v)) : ℂ) * + (hRS f P e').evalOdd + (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v)))))) * + ((-1 : ℂ) ^ (Finset.univ.filter + (fun p : Fin (edgeCount W) × Fin (edgeCount W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ + p.2 ∈ edgeIndexSet W F)).card * + (-1 : ℂ) ^ inRepCount W F o * + ∏ v : Fin (ds W).length, + ((F.oddSignAt o φ (blockVertex W v) : ℤ) : ℂ)) + = (((-1 : ℂ) ^ patternOddInv W F) * + ((-1 : ℂ) ^ (Finset.univ.filter + (fun p : Fin (edgeCount W) × + Fin (edgeCount W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ + p.2 ∈ edgeIndexSet W F)).card * + (-1 : ℂ) ^ inRepCount W F o) * + ∏ v : Fin (ds W).length, + ((sortSign (oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) + v)) : ℂ) * + (sortSign (F.oddListAt o φ + (blockVertex W v)) : ℂ))) * + ((∏ v : Fin (ds W).length, + ((F.oddSignAt o φ (blockVertex W v) : ℤ) : ℂ)) * + ∏ v : Fin (ds W).length, + (hRS f P e').evalOdd + (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v))) := by + rw [hsplitL] + ring + _ = ((-1 : ℂ) ^ κ.circuitCount) * + ((∏ v : Fin (ds W).length, + ((F.oddSignAt o φ (blockVertex W v) : ℤ) : ℂ)) * + ∏ v : Fin (ds W).length, + (hRS f P e').evalOdd + (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v))) := by + rw [hgp] + _ = ((-1 : ℂ) ^ κ.circuitCount) * + ∏ v : Fin (ds W).length, + ((F.oddSignAt o φ (blockVertex W v) : ℂ) * + (hRS f P e').evalOdd + (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v))) := by + rw [← hsplitR] + -- ═══════ SOME BLOCK REPEATS AN ODD VALUE ═══════ + -- That block's factor is zero, and so is the vertex product. + · push Not at hnd + obtain ⟨v₀, hv₀⟩ := hnd + have hL0 : (∏ v, starCoord f P e' + ((degList (starAssignEnum W)).get v) + (blockRestrict (degList (starAssignEnum W)) + (((colouringOfFlip W F o ψ φ) ∘ finCongr + (degList_sum (starAssignEnum W))) ∘ + sortSplitPerm W) v)) = 0 := + Finset.prod_eq_zero (Finset.mem_univ v₀) + (starCoord_block_flip_not_nodup f P e e' hee' he'e + W F o ψ φ v₀ hv₀) + have hR0 : (∏ v : Fin (ds W).length, + ((F.oddSignAt o φ (blockVertex W v) : ℂ) * + (hRS f P e').evalOdd + (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v)))) = 0 := + Finset.prod_eq_zero (Finset.mem_univ v₀) + (by rw [MixedFunctional.evalOdd_of_not_nodup _ _ + hv₀, mul_zero]) + rw [hL0, hR0] + ring + +open scoped Classical in +/-- **The fibre identity**, assembled from the vanishing branches +and the termwise value identity. -/ +theorem fibreSum_eq + (hee' : (e' ≫ e : P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk 1)) = 𝟙 _) + (he'e : (e ≫ e' : stdSuperPair k ℓ ⟶ stdSuperPair k ℓ) = 𝟙 _) + (W : ClosedFragment) + (s : Finset W.Flag) : + (∑ c ∈ Finset.univ.filter + (fun c : {c : MixedColouring k ℓ + (edgeCount W + edgeCount W) // c.IsEven} => + colourFlags W c.val = s), + masterSummand f P e' W c.val) = + (if hc : ∀ g ∈ s, W.pairing g ∈ s then + if (EdgeSubset.mk s hc).Eulerian then + (EdgeSubset.mk s hc).mixedValue (hRS f P e') + else 0 + else 0) := by + by_cases hc : ∀ g ∈ s, W.pairing g ∈ s + · rw [dite_eq_left hc] + by_cases hE : (EdgeSubset.mk s hc).Eulerian + · rw [ite_eq_left hE] + set F := EdgeSubset.mk s hc with hF + obtain ⟨⟨κ, o⟩⟩ := + ClosedFragment.eulerian_transition_nonempty W F hE + have hdata := fibreSum_eq_dataSum f P e' W F + rw [show (Finset.univ.filter + (fun c : {c : MixedColouring k ℓ + (edgeCount W + edgeCount W) // c.IsEven} => + colourFlags W c.val = s)) = + (Finset.univ.filter + (fun c : {c : MixedColouring k ℓ + (edgeCount W + edgeCount W) // c.IsEven} => + colourFlags W c.val = F.flags)) from rfl] + rw [hdata] + have hflip : ∀ ψ : F.EvenColouring k, + (∑ φ : F.OddColouring ℓ, + masterSummand f P e' W (colouringOf W F ψ φ)) = + ∑ φ : F.OddColouring ℓ, + masterSummand f P e' W + (colouringOfFlip W F o ψ φ) := by + intro ψ + exact (EdgeSubset.OddColouring.sum_flip F + (outRepSet W F o) (outRepSet_pairing_mem W F o) + (fun φ => masterSummand f P e' W + (colouringOf W F ψ φ))).symm + rw [Finset.sum_congr rfl (fun ψ _ => hflip ψ)] + rw [Finset.sum_congr rfl (fun ψ _ => + Finset.sum_congr rfl (fun φ _ => + masterSummand_colouringOfFlip f P e e' hee' he'e + W F o ψ φ))] + rw [show (∑ ψ : F.EvenColouring k, + ∑ φ : F.OddColouring ℓ, + ((-1 : ℂ) ^ κ.circuitCount) * + ∏ v : W.Vertex, + ((F.oddSignAt o φ v : ℂ) * + (hRS f P e').evalOdd (F.evenColoursAt ψ v) + (F.oddListAt o φ v))) = + ((-1 : ℂ) ^ κ.circuitCount) * + ∑ ψ : F.EvenColouring k, + ∑ φ : F.OddColouring ℓ, + ∏ v : W.Vertex, + ((F.oddSignAt o φ v : ℂ) * + (hRS f P e').evalOdd (F.evenColoursAt ψ v) + (F.oddListAt o φ v)) from by + rw [Finset.mul_sum] + exact Finset.sum_congr rfl (fun ψ _ => + (Finset.mul_sum _ _ _).symm)] + rw [show ((-1 : ℂ) ^ κ.circuitCount) * + (∑ ψ : F.EvenColouring k, + ∑ φ : F.OddColouring ℓ, + ∏ v : W.Vertex, + ((F.oddSignAt o φ v : ℂ) * + (hRS f P e').evalOdd (F.evenColoursAt ψ v) + (F.oddListAt o φ v))) = + F.mixedSummand (hRS f P e') o from rfl] + exact (mixedValue_eq_summand_closed W F + (hRS f P e') o).symm + · rw [ite_eq_right hE] + refine Finset.sum_eq_zero (fun c hcmem => ?_) + rw [Finset.mem_filter] at hcmem + exact masterSummand_vanish_of_not_eulerian f P e' W + c.val s hc hcmem.2 hE + · rw [dite_eq_right hc] + refine Finset.sum_eq_zero (fun c hcmem => ?_) + rw [Finset.mem_filter] at hcmem + exact masterSummand_vanish_of_not_closed f P e' W + c.val s hcmem.2 hc + +/-- **The conditional master identity**. -/ +theorem parameter_eq_mixedPartition (W : ClosedFragment) + (hee' : (e' ≫ e : P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk 1)) = 𝟙 _) + (he'e : (e ≫ e' : stdSuperPair k ℓ ⟶ stdSuperPair k ℓ) = 𝟙 _) + (hform : + letI := P.braided + SuperVect.Hom.comp + (μ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1) ≫ + P.ω.map (ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) ≫ + η P.ω) + (SuperVect.tensorHom e e) = stdForm k ℓ) + (hcopair : + letI := P.braided + SuperVect.Hom.comp (SuperVect.tensorHom e' e') + (ε P.ω ≫ P.ω.map (η_ (SkeinObj.mk 1) + (SkeinObj.mk 1)) ≫ + δ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1)) = + stdCopair k ℓ) : + f.val W = mixedPartition (hRS f P e') W := by + classical + rw [parameter_masterSummand f P e e' W hee' hform] + rw [masterSum_partition] + rw [show mixedPartition (hRS f P e') W = + ((k : ℂ) - 2 * ℓ) ^ W.circles * + ∑ s : Finset W.Flag, + (if hc : ∀ g ∈ s, W.pairing g ∈ s then + if (EdgeSubset.mk s hc).Eulerian then + (EdgeSubset.mk s hc).mixedValue (hRS f P e') + else 0 + else 0) from rfl] + rw [circleVal_model f P e e' hee' hform hcopair] + congr 1 + exact Finset.sum_congr rfl (fun s _ => + fibreSum_eq f P e e' hee' he'e W s) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexVanish.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexVanish.lean new file mode 100644 index 0000000000..9111d0dc50 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexVanish.lean @@ -0,0 +1,162 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockParity +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiagForm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FibreParam + +/-! +# Vanishing branches of the fibre identity + +Non-Eulerian patterns kill every master summand in their fibre: +the odd-degree vertex is a block of odd parity. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Finset + + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} +variable (e' : P.ω.obj (SkeinObj.mk 1) ⟶ stdSuperPair k ℓ) + +/-- **Non-Eulerian vanishing**: a colouring whose pattern is a +closed non-Eulerian subset has vanishing master summand. -/ +theorem masterSummand_vanish_of_not_eulerian + (W : ClosedFragment) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) + (s : Finset W.Flag) + (hclosed : ∀ g ∈ s, W.pairing g ∈ s) + (hfibre : colourFlags W c = s) + (hnotE : ¬ (EdgeSubset.mk s hclosed).Eulerian) : + masterSummand f P e' W c = 0 := by + rw [EdgeSubset.Eulerian] at hnotE + push Not at hnotE + obtain ⟨v₀, hv₀⟩ := hnotE + obtain ⟨v, hv⟩ : ∃ v, blockVertex W v = v₀ := + ⟨(finCongr (degList_length (starAssignEnum W))).symm + (Fintype.equivFin W.Vertex v₀), by + rw [blockVertex, _root_.Equiv.apply_symm_apply, + _root_.Equiv.symm_apply_apply]⟩ + refine masterSummand_vanish_of_block_odd f P e' W c v ?_ + rw [blockRestrict_parity] + intro hEvenFlags + refine hv₀ ?_ + rw [EdgeSubset.deg] + convert hEvenFlags using 2 + ext g + simp only [Finset.mem_filter] + constructor + · rintro ⟨hgs, hga⟩ + refine ⟨hfibre ▸ hgs, ?_⟩ + rw [hv] + have h2 := ClosedFragment.attach_eq_vertexOf W g + rw [hga] at h2 + exact (Sum.inl.inj h2).symm + · rintro ⟨hgc, hgv⟩ + refine ⟨hfibre ▸ hgc, ?_⟩ + rw [ClosedFragment.attach_eq_vertexOf W g, hgv, hv] + +/-- **Impure vanishing**: a colouring with a mixed-parity pair +has vanishing master summand. -/ +theorem masterSummand_vanish_of_impure + (W : ClosedFragment) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) + (himpure : ¬ PairPure c) : + masterSummand f P e' W c = 0 := by + rw [PairPure] at himpure + push Not at himpure + obtain ⟨i, hi⟩ := himpure + rw [masterSummand] + rw [betaDiag_eq_betaColour (edgeCount W) c] + rw [betaColour_eq_zero_of_mixed i (show + ((MixedColouring.firstHalf (a := edgeCount W) + (b := edgeCount W) c) i).isRight ≠ + ((MixedColouring.secondHalf (a := edgeCount W) + (b := edgeCount W) c) i).isRight from hi)] + rw [mul_zero] + +/-- **Non-closed vanishing**: a colouring whose pattern is not +pairing-closed has vanishing master summand. -/ +theorem masterSummand_vanish_of_not_closed + (W : ClosedFragment) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) + (s : Finset W.Flag) + (hfibre : colourFlags W c = s) + (hnc : ¬ ∀ g ∈ s, W.pairing g ∈ s) : + masterSummand f P e' W c = 0 := by + refine masterSummand_vanish_of_impure f P e' W c ?_ + intro hpure + refine hnc ?_ + rw [← hfibre] + exact colourFlags_pairing_mem W c hpure + +/-- The entry of a non-partner odd pair vanishes. -/ +theorem colourFormEntry_inr_ne {u v : Fin (2 * ℓ)} + (h : v ≠ oddPartner ℓ u) : + colourFormEntry k ℓ (Sum.inr u) (Sum.inr v) = 0 := by + rw [colourFormEntry_odd, stdFormOdd_stdF, ite_eq_right h] + +-- The vanishing is located at one off-diagonal +-- slot, but reaching it unfolds the whole summand. +/-- **Off-diagonal vanishing**: a pure non-diagonal colouring +has vanishing master summand. -/ +theorem masterSummand_vanish_of_not_diagonal + {R : ℕ} (f : EdgeRankParameter R) + (P : DelignePackage (SkeinObj f)) + (e' : P.ω.obj (SkeinObj.mk 1) ⟶ stdSuperPair k ℓ) + (W : ClosedFragment) + (c : MixedColouring k ℓ (edgeCount W + edgeCount W)) + (hpure : PairPure c) + (hnd : ¬ Diagonal W c) : + masterSummand f P e' W c = 0 := by + rw [Diagonal] at hnd + push Not at hnd + obtain ⟨i, hi⟩ := hnd + rw [masterSummand] + rw [betaDiag_eq_betaColour (edgeCount W) c] + rw [show betaColour + (MixedColouring.firstHalf (a := edgeCount W) + (b := edgeCount W) c) + (MixedColouring.secondHalf (a := edgeCount W) + (b := edgeCount W) c) = 0 from ?_] + · rw [mul_zero] + unfold betaColour + rw [show (∏ j, colourFormEntry k ℓ + ((MixedColouring.firstHalf (a := edgeCount W) + (b := edgeCount W) c) j) + ((MixedColouring.secondHalf (a := edgeCount W) + (b := edgeCount W) c) j)) = 0 from ?_] + · rw [mul_zero] + refine Finset.prod_eq_zero (Finset.mem_univ i) ?_ + change colourFormEntry k ℓ (c (Fin.castAdd (edgeCount W) i)) + (c (Fin.natAdd (edgeCount W) i)) = 0 + have hp := hpure i + rcases hx : c (Fin.castAdd (edgeCount W) i) with a | u + · rcases hy : c (Fin.natAdd (edgeCount W) i) with b | v + · rw [show colourFormEntry k ℓ (Sum.inl a) + (Sum.inl b) = if a = b then 1 else 0 from rfl] + rw [ite_eq_right (fun hab => hi (by + rw [hy, hx, hab] + rfl))] + · exfalso + rw [hx, hy] at hp + exact Bool.noConfusion hp + · rcases hy : c (Fin.natAdd (edgeCount W) i) with b | v + · exfalso + rw [hx, hy] at hp + exact Bool.noConfusion hp + · refine colourFormEntry_inr_ne (fun hv => hi ?_) + rw [hy, hx, hv] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RepFlag.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RepFlag.lean new file mode 100644 index 0000000000..8ed4ef545e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RepFlag.lean @@ -0,0 +1,92 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij + +/-! +# Representative flags + +Each edge's representative flag is the one enumerated on the low +slot half. The set of participating flags whose edge +representative is outgoing (under an orientation) is closed under +the pairing — it is the flip set aligning the data colouring with +the Definition 5 odd lists. +-/ + +@[expose] public section + +namespace RS + +open Finset + +/-- The representative flag of a flag's edge: the one on the low +slot half. -/ +noncomputable def repFlag (W : ClosedFragment) (g : W.Flag) : + W.Flag := + if (starFlagEnum W g).val < edgeCount W then g + else W.pairing g + +/-- A flag on the low half represents its own edge. -/ +theorem repFlag_low (W : ClosedFragment) (g : W.Flag) + (h : (starFlagEnum W g).val < edgeCount W) : + repFlag W g = g := ite_eq_left h + +/-- A flag on the high half is represented by its partner. -/ +theorem repFlag_high (W : ClosedFragment) (g : W.Flag) + (h : ¬ (starFlagEnum W g).val < edgeCount W) : + repFlag W g = W.pairing g := ite_eq_right h + +/-- The representative flag is pairing-invariant. -/ +theorem repFlag_pairing (W : ClosedFragment) (g : W.Flag) : + repFlag W (W.pairing g) = repFlag W g := by + by_cases h : (starFlagEnum W g).val < edgeCount W + · have hp := starFlagEnum_pairing_low W g h + have hhigh : ¬ (starFlagEnum W (W.pairing g)).val < + edgeCount W := by + rw [hp] + change ¬ edgeCount W + _ < edgeCount W + omega + rw [repFlag, ite_eq_right hhigh, W.pairing_invol, + repFlag_low W g h] + · have hp := starFlagEnum_pairing_high W g h + have hisLt := (starFlagEnum W g).isLt + have hlow : (starFlagEnum W (W.pairing g)).val < + edgeCount W := by + rw [hp] + change (starFlagEnum W g).val - edgeCount W < edgeCount W + omega + rw [repFlag, ite_eq_left hlow, repFlag_high W g h] + +open Classical in +/-- The flip set of an orientation: participating flags whose +edge representative is outgoing. -/ +noncomputable def outRepSet (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) : Finset W.Flag := + F.flags.filter (fun g => o.isOut (repFlag W g) = true) + +/-- The flip set is closed under the pairing. -/ +theorem outRepSet_pairing_mem (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) : + ∀ g ∈ outRepSet W F o, W.pairing g ∈ outRepSet W F o := by + intro g hg + rw [outRepSet, Finset.mem_filter] at hg ⊢ + refine ⟨F.pairing_mem _ hg.1, ?_⟩ + rw [repFlag_pairing] + exact hg.2 + +/-- Membership in the flip set depends only on the edge. -/ +theorem mem_outRepSet_iff (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) (g : W.Flag) (hg : g ∈ F.flags) : + g ∈ outRepSet W F o ↔ o.isOut (repFlag W g) = true := by + rw [outRepSet, Finset.mem_filter] + exact ⟨fun h => h.2, fun h => ⟨hg, h⟩⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RiffleSign.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RiffleSign.lean new file mode 100644 index 0000000000..ff987bcf9e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RiffleSign.lean @@ -0,0 +1,677 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairList +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EdgeSign + +/-! +# The riffle and orientation signs + +The canonical index permutation from slot-order to edge-interleaved +order has sign `(−1)^C(n,2)` (the riffle sign), and the permutation +from edge-interleaved to oriented order has sign `(−1)^s` where `s` +is the number of edges whose representative flag is outgoing. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {k ℓ : ℕ} + +/-! ### Part 1 helpers: slot-map computations -/ + +open Classical in +/-- The slot function applied to globalSlotList recovers sorted partSlots. -/ +private theorem globalSlotList_map_slot (W : ClosedFragment) + (F : EdgeSubset W) : + (globalSlotList W F).map (fun f : {f : W.Flag // f ∈ F.flags} => + starFlagEnum W f.val) = + (partSlots W F).sort (· ≤ ·) := by + apply List.ext_getElem (by rw [List.length_map]; exact List.length_pmap) + intro i hi₁ hi₂ + rw [List.getElem_map] + unfold globalSlotList at hi₁ ⊢ + rw [List.getElem_pmap] + exact _root_.Equiv.apply_symm_apply _ _ + +open Classical in +/-- The slot-mapped global slot list is nodup (needed for sortSign). -/ +private theorem globalSlotList_map_slot_nodup (W : ClosedFragment) + (F : EdgeSubset W) : + ((globalSlotList W F).map (fun f : {f : W.Flag // f ∈ F.flags} => + starFlagEnum W f.val)).Nodup := by + rw [globalSlotList_map_slot] + exact Finset.sort_nodup _ _ + +open Classical in +/-- The slot-mapped global slot list has sortSign 1 (sorted). -/ +private theorem sortSign_globalSlotList_map_slot (W : ClosedFragment) + (F : EdgeSubset W) : + sortSign ((globalSlotList W F).map (fun f : {f : W.Flag // f ∈ F.flags} => + starFlagEnum W f.val)) = 1 := by + rw [globalSlotList_map_slot] + exact sortSign_eq_one_of_sorted _ + (Finset.pairwise_sort (partSlots W F) (· ≤ ·)) + +open Classical in +/-- The slot function maps edgePairList to the interleaved list. -/ +private theorem edgePairList_map_slot (W : ClosedFragment) + (F : EdgeSubset W) : + (edgePairList W F).map (fun f : {f : W.Flag // f ∈ F.flags} => + starFlagEnum W f.val) = + (partEdges W F).flatMap (fun e => + [Fin.castAdd (edgeCount W) e, Fin.natAdd (edgeCount W) e]) := by + rw [edgePairList, List.map_flatMap] + simp only [List.map_cons, List.map_nil, _root_.Equiv.apply_symm_apply] + -- attachWith.flatMap (fun i => [castAdd i.val, natAdd i.val]) + -- = partEdges.flatMap (fun e => [castAdd e, natAdd e]) + -- Prove by a general attachWith-flatMap lemma via induction + suffices h : ∀ (l : List (Fin (edgeCount W))) + (H : ∀ x ∈ l, x ∈ edgeIndexSet W F), + (l.attachWith (· ∈ edgeIndexSet W F) H).flatMap + (fun i : {i : Fin (edgeCount W) // i ∈ edgeIndexSet W F} => + [Fin.castAdd (edgeCount W) i.val, Fin.natAdd (edgeCount W) i.val]) = + l.flatMap (fun e => [Fin.castAdd (edgeCount W) e, + Fin.natAdd (edgeCount W) e]) from h _ _ + intro l H + induction l with + | nil => rfl + | cons e rest ih => + simp only [List.attachWith, List.pmap_cons, List.flatMap_cons] + exact congrArg _ (ih (fun x hx => H x (List.mem_cons_of_mem _ hx))) + +/-! ### Part 1 helpers: inversions of interleaved lists -/ + +/-- All entries of the castAdd-natAdd interleave over a tail strictly + greater than the head are ≥ castAdd of the head. -/ +private theorem filter_lt_castAdd_head_eq_zero {n : ℕ} + (e : Fin n) (rest : List (Fin n)) + (hgt : ∀ x ∈ rest, e < x) : + ((rest.flatMap (fun i => [Fin.castAdd n i, Fin.natAdd n i])).filter + (fun b => decide (b < Fin.castAdd n e))).length = 0 := by + rw [List.length_eq_zero_iff, List.filter_eq_nil_iff] + intro q hq + simp only [decide_eq_true_eq, not_lt] + rw [List.mem_flatMap] at hq + obtain ⟨x, hx, hq⟩ := hq + rcases List.mem_cons.mp hq with rfl | hq + · -- q = castAdd x, x > e + change (Fin.castAdd n e).val ≤ (Fin.castAdd n x).val + simp only [Fin.val_castAdd] + exact Nat.le_of_lt (hgt x hx) + · -- q = natAdd x + rw [List.mem_singleton] at hq; subst hq + change (Fin.castAdd n e).val ≤ (Fin.natAdd n x).val + simp only [Fin.val_castAdd, Fin.val_natAdd] + have := e.isLt; omega + +/-- natAdd e is not less than castAdd e. -/ +private theorem not_natAdd_lt_castAdd {n : ℕ} (e : Fin n) : + ¬ (Fin.natAdd n e < Fin.castAdd n e) := by + intro h + have h1 : (Fin.natAdd n e).val < (Fin.castAdd n e).val := + h + simp only [Fin.val_natAdd, Fin.val_castAdd] at h1 + omega + +/-- The count of tail entries less than natAdd of the head equals + the number of elements in rest (from castAdd entries). -/ +private theorem filter_lt_natAdd_head_eq_length {n : ℕ} + (e : Fin n) (rest : List (Fin n)) + (hgt : ∀ x ∈ rest, e < x) : + ((rest.flatMap (fun i => [Fin.castAdd n i, Fin.natAdd n i])).filter + (fun b => decide (b < Fin.natAdd n e))).length = rest.length := by + -- Each element of rest contributes castAdd x (< natAdd e since x.val < n ≤ n + -- + e.val) + -- and natAdd x (≥ natAdd e since x > e) + -- So exactly one element per rest entry passes the filter + induction rest with + | nil => simp [List.flatMap] + | cons x xs ih => + simp only [List.flatMap_cons, List.filter_append, List.length_append, + List.length_cons] + have hx_gt : e < x := hgt x List.mem_cons_self + have hxs_gt : ∀ y ∈ xs, e < y := fun y hy => hgt y + (List.mem_cons_of_mem _ hy) + rw [ih hxs_gt] + -- Filter of [castAdd x, natAdd x]: castAdd x passes, natAdd x doesn't + change (([Fin.castAdd n x, Fin.natAdd n x].filter + (fun b => decide (b < Fin.natAdd n e)))).length + xs.length = + xs.length + 1 + -- castAdd x < natAdd e: castAdd x = x.val < n ≤ n + e.val = natAdd e + have hcast_lt : Fin.castAdd n x < Fin.natAdd n e := by + change (Fin.castAdd n x).val < (Fin.natAdd n e).val + simp only [Fin.val_castAdd, Fin.val_natAdd] + exact x.isLt.trans_le (Nat.le_add_right _ _) + -- natAdd x ≥ natAdd e: n + x.val > n + e.val + have hnat_ge : ¬ (Fin.natAdd n x < Fin.natAdd n e) := by + intro h + have h1 : (Fin.natAdd n x).val < (Fin.natAdd n e).val := h + simp only [Fin.val_natAdd] at h1; omega + simp only [List.filter_cons, decide_eq_true_eq, hcast_lt, ite_true, + hnat_ge, ite_false, List.filter_nil, List.length_cons, List.length_nil] + omega + +/-- Inversions of the castAdd-natAdd interleave of a strictly sorted + list equal `Nat.choose n 2`. -/ +private theorem inversions_interleave_sorted {n : ℕ} : + ∀ (E : List (Fin n)), List.Pairwise (· < ·) E → + inversions (E.flatMap (fun i => [Fin.castAdd n i, Fin.natAdd n i])) = + Nat.choose E.length 2 + | [], _ => by simp [List.flatMap, inversions] + | e :: rest, hpw => by + have hrest := hpw.of_cons + have hgt : ∀ x ∈ rest, e < x := + (List.pairwise_cons.mp hpw).1 + rw [List.flatMap_cons] + simp only [List.cons_append, List.nil_append] + -- inversions (castAdd e :: natAdd e :: rest_fm) + -- = filter(< castAdd e)(natAdd e :: rest_fm).length + inversions(natAdd e + -- :: rest_fm) + set rest_fm := rest.flatMap (fun i => [Fin.castAdd n i, Fin.natAdd n i]) + -- Unfold inversions for the cons case (definitional equality) + change ((Fin.natAdd n e :: rest_fm).filter + (fun b => decide (b < Fin.castAdd n e))).length + + ((rest_fm.filter (fun b => decide (b < Fin.natAdd n e))).length + + inversions rest_fm) = _ + -- Filter for castAdd e: nothing in (natAdd e :: rest_fm) is < castAdd e + have h_filt_cast : ((Fin.natAdd n e :: rest_fm).filter + (fun b => decide (b < Fin.castAdd n e))).length = 0 := by + rw [List.filter_cons] + simp only [decide_eq_true_eq, not_natAdd_lt_castAdd, ite_false] + exact filter_lt_castAdd_head_eq_zero e rest hgt + rw [h_filt_cast, Nat.zero_add] + -- filter(< natAdd e)(rest_fm).length = rest.length + rw [filter_lt_natAdd_head_eq_length e rest hgt] + -- inversions(rest_fm) = C(rest.length, 2) by IH + rw [inversions_interleave_sorted rest hrest] + -- rest.length + C(rest.length, 2) = C(rest.length + 1, 2) + rw [List.length_cons, Nat.choose_succ_succ, Nat.choose_one_right] + +open Classical in +/-- The interleaved slot list from edgePairList has inversions equal + to `Nat.choose n 2` where `n` = number of participating edges. -/ +private theorem inversions_edgePairList_slots (W : ClosedFragment) + (F : EdgeSubset W) : + inversions ((edgePairList W F).map (fun f : {f : W.Flag // f ∈ F.flags} => + starFlagEnum W f.val)) = + Nat.choose (partEdges W F).length 2 := by + rw [edgePairList_map_slot] + exact inversions_interleave_sorted (partEdges W F) + (List.sortedLT_iff_pairwise.mp (Finset.sortedLT_sort (edgeIndexSet W F))) + +open Classical in +/-- The length of partEdges equals the card of edgeIndexSet. -/ +private theorem partEdges_length (W : ClosedFragment) (F : EdgeSubset W) : + (partEdges W F).length = (edgeIndexSet W F).card := by + exact Finset.length_sort _ + +/-! ### Part 1 helpers: crossings count -/ + +/-- Ordered pairs from a finset biject with choose 2. -/ +private theorem card_ordered_pairs_eq_choose {α : Type*} + [LinearOrder α] (S : Finset α) : + ((S ×ˢ S).filter (fun p => p.1 < p.2)).card = + Nat.choose S.card 2 := by + classical + induction S using Finset.induction_on with + | empty => simp + | insert a s ha ih => + -- Split into pairs involving a and pairs within s + have hfilt_sum : (s.filter (fun x => a < x)).card + + (s.filter (fun x => x < a)).card = s.card := by + have h1 := Finset.card_filter_add_card_filter_not (s := s) + (fun x => a < x) + have h2 : (s.filter (fun x => ¬ a < x)).card = + (s.filter (fun x => x < a)).card := by + congr 1; ext x; simp only [Finset.mem_filter] + constructor + · rintro ⟨hx, hna⟩; exact ⟨hx, lt_of_le_of_ne (not_lt.mp hna) + (fun h => ha (h ▸ hx))⟩ + · rintro ⟨hx, hlt⟩; exact ⟨hx, not_lt.mpr (le_of_lt hlt)⟩ + omega + -- Count pairs: pairs with a on left + pairs with a on right + pairs in s + -- = s.filter(a<·).card + s.filter(· p.1 < p.2)).card = + (s.filter (fun x => a < x)).card + + (s.filter (fun x => x < a)).card + + ((s ×ˢ s).filter (fun p => p.1 < p.2)).card := by + set A := (s.filter (fun x => a < x)).image (Prod.mk a) + set B := (s.filter (fun x => x < a)).image (fun x => (x, a)) + set C := (s ×ˢ s).filter (fun p : α × α => p.1 < p.2) + have hset : (insert a s ×ˢ insert a s).filter + (fun p : α × α => p.1 < p.2) = A ∪ B ∪ C := by + ext ⟨x, y⟩ + simp only [Finset.mem_filter, Finset.mem_product, Finset.mem_insert, + Finset.mem_union, Finset.mem_image, A, B, C] + constructor + · rintro ⟨⟨hx, hy⟩, hlt⟩ + rcases hx with rfl | hxs + · rcases hy with rfl | hys + · exact absurd hlt (lt_irrefl _) + · left; left; exact ⟨y, ⟨hys, hlt⟩, rfl⟩ + · rcases hy with rfl | hys + · left; right; exact ⟨x, ⟨hxs, hlt⟩, rfl⟩ + · right; exact ⟨⟨hxs, hys⟩, hlt⟩ + · rintro ((⟨z, ⟨hzs, hlt⟩, heq⟩ | ⟨z, ⟨hzs, hlt⟩, heq⟩) | ⟨⟨hx, hy⟩, + hlt⟩) + · obtain ⟨rfl, rfl⟩ := Prod.mk.inj heq + exact ⟨⟨Or.inl rfl, Or.inr hzs⟩, hlt⟩ + · obtain ⟨rfl, rfl⟩ := Prod.mk.inj heq + exact ⟨⟨Or.inr hzs, Or.inl rfl⟩, hlt⟩ + · exact ⟨⟨Or.inr hx, Or.inr hy⟩, hlt⟩ + have hAB : Disjoint A B := by + rw [Finset.disjoint_left]; intro ⟨x, y⟩ hA hB + simp only [Finset.mem_image, Finset.mem_filter, A, B] at hA hB + obtain ⟨z₁, _, heq₁⟩ := hA + obtain ⟨z₂, ⟨_, hz₂a⟩, heq₂⟩ := hB + have h1 : a = x := (Prod.mk.inj heq₁).1 + have h2 : z₂ = x := (Prod.mk.inj heq₂).1 + have heq : z₂ = a := h2.trans h1.symm + rw [heq] at hz₂a + exact lt_irrefl a hz₂a + have hABC : Disjoint (A ∪ B) C := by + rw [Finset.disjoint_left]; intro ⟨x, y⟩ hAB' hC + rw [Finset.mem_union] at hAB' + rw [Finset.mem_filter, Finset.mem_product] at hC + rcases hAB' with hA | hB + · simp only [Finset.mem_image, A] at hA + obtain ⟨z, _, heq⟩ := hA + have := (Prod.mk.inj heq).1 + exact ha (this ▸ hC.1.1) + · simp only [Finset.mem_image, B] at hB + obtain ⟨z, _, heq⟩ := hB + have := (Prod.mk.inj heq).2 + exact ha (this ▸ hC.1.2) + rw [hset, Finset.card_union_of_disjoint hABC, + Finset.card_union_of_disjoint hAB] + congr 1; congr 1 + · exact Finset.card_image_of_injective _ + (fun _ _ h => (Prod.mk.inj h).2) + · exact Finset.card_image_of_injective _ + (fun _ _ h => (Prod.mk.inj h).1) + rw [hsplit, ih, hfilt_sum] + rw [Finset.card_insert_of_notMem ha, Nat.choose_succ_succ, + Nat.choose_one_right] + +open Classical in +/-- The crossings card equals Nat.choose of edge count. -/ +private theorem crossings_card_eq_choose (W : ClosedFragment) + (F : EdgeSubset W) : + (Finset.univ.filter (fun p : Fin (edgeCount W) × Fin (edgeCount W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ p.2 ∈ edgeIndexSet W F)).card = + Nat.choose (edgeIndexSet W F).card 2 := by + -- Rewrite as (edgeIndexSet ×ˢ edgeIndexSet).filter (p.1 < p.2) + have : (Finset.univ.filter (fun p : Fin (edgeCount W) × Fin (edgeCount W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ p.2 ∈ edgeIndexSet W F)).card = + ((edgeIndexSet W F ×ˢ edgeIndexSet W F).filter (fun p => p.1 < p.2)).card := + by + congr 1; ext ⟨a, b⟩ + simp only [Finset.mem_filter, Finset.mem_univ, true_and, + Finset.mem_product] + tauto + rw [this] + exact card_ordered_pairs_eq_choose (edgeIndexSet W F) + +/-! ### Part 1: the riffle sign -/ + +open Classical in +/-- **The riffle sign: the permutation from slot order to edge-interleaved + order has sign `(-1)^crossings`.** -/ +theorem sign_listIndexPerm_slot_edge (W : ClosedFragment) + (F : EdgeSubset W) : + (Equiv.Perm.sign (listIndexPerm (globalSlotList W F) (edgePairList W F) + (globalSlotList_nodup W F) (edgePairList_nodup W F) + (fun x => ⟨fun _ => mem_edgePairList W F x, + fun _ => mem_globalSlotList W F x⟩) + (length_eq_of_nodup_mem _ _ + (globalSlotList_nodup W F) (edgePairList_nodup W F) + (fun x => ⟨fun _ => mem_edgePairList W F x, + fun _ => mem_globalSlotList W F x⟩))) : ℤ) = + (-1 : ℤ) ^ (Finset.univ.filter (fun p : Fin (edgeCount W) × Fin (edgeCount + W) => + p.1 < p.2 ∧ p.1 ∈ edgeIndexSet W F ∧ p.2 ∈ edgeIndexSet W F)).card := by + have hmem : ∀ x : {f : W.Flag // f ∈ F.flags}, + x ∈ globalSlotList W F ↔ x ∈ edgePairList W F := + fun x => ⟨fun _ => mem_edgePairList W F x, fun _ => mem_globalSlotList W F + x⟩ + have hlen := length_eq_of_nodup_mem _ _ + (globalSlotList_nodup W F) (edgePairList_nodup W F) hmem + set g : {f : W.Flag // f ∈ F.flags} → Fin (edgeCount W + edgeCount W) := + fun f => starFlagEnum W f.val + have hg : ((globalSlotList W F).map g).Nodup := + globalSlotList_map_slot_nodup W F + -- sortSign_map_listIndexPerm: sortSign(l₂.map g) = sign(τ) * sortSign(l₁.map + -- g) + have hkey := sortSign_map_listIndexPerm + (globalSlotList W F) (edgePairList W F) + (globalSlotList_nodup W F) (edgePairList_nodup W F) + hmem hlen g hg + -- sortSign(l₁.map g) = 1 + have hss1 := sortSign_globalSlotList_map_slot W F + -- sortSign(l₂.map g) = (-1)^inversions = (-1)^C(n,2) + rw [hss1, mul_one] at hkey + -- hkey: sortSign(edgePairList.map g) = sign(τ) + rw [← hkey] + -- Goal: sortSign(edgePairList.map slot) = (-1)^crossings + rw [sortSign] + rw [inversions_edgePairList_slots] + rw [partEdges_length] + rw [crossings_card_eq_choose] + +/-! ### Part 2 helpers: oriented list inversions -/ + +open Classical in +/-- The slot function maps orientedPairList to the conditionally-swapped + interleaved list. -/ +private theorem orientedPairList_map_slot (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) : + (orientedPairList W F o).map (fun f : {f : W.Flag // f ∈ F.flags} => + starFlagEnum W f.val) = + (partEdges W F).flatMap (fun e => + if o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) e)) = true then + [Fin.natAdd (edgeCount W) e, Fin.castAdd (edgeCount W) e] + else + [Fin.castAdd (edgeCount W) e, Fin.natAdd (edgeCount W) e]) := by + rw [orientedPairList, List.map_flatMap] + simp only [apply_ite (List.map (fun f : {f : W.Flag // f ∈ F.flags} + => starFlagEnum W f.val)), + List.map_cons, List.map_nil, _root_.Equiv.apply_symm_apply] + -- attachWith.flatMap (fun i => sw i.val) = partEdges.flatMap sw + suffices h : ∀ (l : List (Fin (edgeCount W))) + (H : ∀ x ∈ l, x ∈ edgeIndexSet W F), + (l.attachWith (· ∈ edgeIndexSet W F) H).flatMap + (fun i : {i : Fin (edgeCount W) // i ∈ edgeIndexSet W F} => + if o.isOut ((starFlagEnum W).symm (Fin.castAdd (edgeCount W) i.val)) = + true then + [Fin.natAdd (edgeCount W) i.val, Fin.castAdd (edgeCount W) i.val] + else + [Fin.castAdd (edgeCount W) i.val, Fin.natAdd (edgeCount W) i.val]) = + l.flatMap (fun e => + if o.isOut ((starFlagEnum W).symm (Fin.castAdd (edgeCount W) e)) = true + then + [Fin.natAdd (edgeCount W) e, Fin.castAdd (edgeCount W) e] + else + [Fin.castAdd (edgeCount W) e, Fin.natAdd (edgeCount W) e]) from h _ _ + intro l H + induction l with + | nil => rfl + | cons e rest ih => + simp only [List.attachWith, List.pmap_cons, List.flatMap_cons] + exact congrArg _ (ih (fun x hx => H x (List.mem_cons_of_mem _ hx))) + +/-- Inversions of the oriented interleave with swap count. -/ +private theorem inversions_oriented_interleave {n : ℕ} + (E : List (Fin n)) (sw : Fin n → Bool) + (hpw : List.Pairwise (· < ·) E) : + inversions (E.flatMap (fun i => + if sw i = true then + [Fin.natAdd n i, Fin.castAdd n i] + else + [Fin.castAdd n i, Fin.natAdd n i])) = + Nat.choose E.length 2 + (E.filter (fun i => sw i)).length := by + induction E with + | nil => simp [List.flatMap, inversions] + | cons e rest ih => + have hrest := hpw.of_cons + have hgt : ∀ x ∈ rest, e < x := + (List.pairwise_cons.mp hpw).1 + rw [List.flatMap_cons] + set rest_fm := rest.flatMap (fun i => + if sw i = true then + [Fin.natAdd n i, Fin.castAdd n i] + else + [Fin.castAdd n i, Fin.natAdd n i]) + -- The cross-tail filter counts don't depend on swap order within pairs, + -- only on which VALUES appear. Both orderings produce the same set of + -- values. + -- Key: filter (< castAdd e) over rest_fm = 0 (same as unswapped) + -- Key: filter (< natAdd e) over rest_fm = rest.length (same as unswapped) + -- These hold because the VALUES in rest_fm are the same regardless of swap + -- order + -- The oriented rest flatmap is a permutation of the unoriented rest flatmap + -- (within each pair, values are just swapped). So filters have same length. + set rest_unsw := rest.flatMap (fun i => [Fin.castAdd n i, Fin.natAdd n i]) + have hperm_rest : rest_fm.Perm rest_unsw := by + change (rest.flatMap (fun i => + if sw i = true then [Fin.natAdd n i, Fin.castAdd n i] + else [Fin.castAdd n i, Fin.natAdd n i])).Perm + (rest.flatMap (fun i => [Fin.castAdd n i, Fin.natAdd n i])) + exact List.Perm.flatMap_left rest (fun x _ => by + by_cases hsw : sw x = true + · rw [ite_eq_left hsw]; exact List.Perm.swap _ _ _ + · rw [ite_eq_right hsw]) + have h_rest_filter_cast : + (rest_fm.filter (fun b => decide (b < Fin.castAdd n e))).length = 0 := + by + rw [(hperm_rest.filter _).length_eq] + exact filter_lt_castAdd_head_eq_zero e rest hgt + have h_rest_filter_nat : + (rest_fm.filter (fun b => decide (b < Fin.natAdd n e))).length = + rest.length := by + rw [(hperm_rest.filter _).length_eq] + exact filter_lt_natAdd_head_eq_length e rest hgt + -- Now handle the head element's contribution + by_cases hsw_e : sw e = true + · -- Swapped: [natAdd e, castAdd e] ++ rest_fm + rw [ite_eq_left hsw_e] + simp only [List.cons_append, List.nil_append] + -- inversions (natAdd :: castAdd :: rest_fm) + change ((Fin.castAdd n e :: rest_fm).filter + (fun b => decide (b < Fin.natAdd n e))).length + + ((rest_fm.filter (fun b => decide (b < Fin.castAdd n e))).length + + inversions rest_fm) = _ + -- filter (< natAdd e) (castAdd e :: rest_fm) = 1 + rest.length + have hcast_lt_nat : Fin.castAdd n e < Fin.natAdd n e := by + change (Fin.castAdd n e).val < (Fin.natAdd n e).val + simp only [Fin.val_castAdd, Fin.val_natAdd]; omega + rw [List.filter_cons, ite_eq_left (show decide (Fin.castAdd n e < Fin.natAdd n + e) = true from + decide_eq_true_eq.mpr hcast_lt_nat), + List.length_cons, h_rest_filter_nat] + rw [h_rest_filter_cast, Nat.zero_add, ih hrest] + rw [List.length_cons, Nat.choose_succ_succ, Nat.choose_one_right] + rw [List.filter_cons, ite_eq_left hsw_e, List.length_cons] + simp only [show Nat.succ 1 = 2 from rfl]; omega + · -- Not swapped: [castAdd e, natAdd e] ++ rest_fm + rw [ite_eq_right hsw_e] + simp only [List.cons_append, List.nil_append] + -- inversions (castAdd :: natAdd :: rest_fm) + change ((Fin.natAdd n e :: rest_fm).filter + (fun b => decide (b < Fin.castAdd n e))).length + + ((rest_fm.filter (fun b => decide (b < Fin.natAdd n e))).length + + inversions rest_fm) = _ + -- filter (< castAdd e) (natAdd e :: rest_fm) = 0 + rw [List.filter_cons, ite_eq_right (show ¬ decide (Fin.natAdd n e < Fin.castAdd + n e) = true from + fun h => not_natAdd_lt_castAdd e (decide_eq_true_eq.mp h))] + rw [h_rest_filter_cast, Nat.zero_add, h_rest_filter_nat, ih hrest] + rw [List.length_cons, Nat.choose_succ_succ, Nat.choose_one_right] + rw [List.filter_cons, ite_eq_right hsw_e] + simp only [show Nat.succ 1 = 2 from rfl]; omega + +open Classical in +/-- The count of swapped edges in partEdges via filter equals the + card of the edge orientation filter. -/ +private theorem filter_swapped_partEdges_card (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) : + ((partEdges W F).filter (fun i => + o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = true)).length = + ((edgeIndexSet W F).filter (fun i => + o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = true)).card := by + rw [partEdges] + set p := fun i : Fin (edgeCount W) => + o.isOut ((starFlagEnum W).symm (Fin.castAdd (edgeCount W) i)) = true + -- (S.sort).filter p has same length as (S.filter p).card + -- because sort is a permutation of the finset elements + have hperm : (((edgeIndexSet W F).sort (· ≤ ·)).filter + (fun i => p i)).Perm (((edgeIndexSet W F).filter (fun i => p i)).sort + (· ≤ ·)) := by + apply (List.perm_ext_iff_of_nodup + ((Finset.sort_nodup _ _).filter _) + (Finset.sort_nodup _ _)).mpr + intro x + simp only [List.mem_filter, Finset.mem_sort, Finset.mem_filter, + decide_eq_true_eq] + rw [hperm.length_eq] + exact Finset.length_sort _ + +/-! ### Part 2: the orientation sign -/ + +open Classical in +/-- **The orientation sign: the permutation from edge-interleaved to + oriented order has sign `(-1)^s` where `s` is the swap count.** -/ +theorem sign_listIndexPerm_edge_oriented (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) : + (Equiv.Perm.sign (listIndexPerm (edgePairList W F) (orientedPairList W F o) + (edgePairList_nodup W F) (orientedPairList_nodup W F o) + (fun x => ⟨fun _ => mem_orientedPairList W F o x, + fun _ => mem_edgePairList W F x⟩) + (length_eq_of_nodup_mem _ _ + (edgePairList_nodup W F) (orientedPairList_nodup W F o) + (fun x => ⟨fun _ => mem_orientedPairList W F o x, + fun _ => mem_edgePairList W F x⟩))) : ℤ) = + (-1 : ℤ) ^ ((edgeIndexSet W F).filter (fun i => + o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = true)).card := by + have hmem : ∀ x : {f : W.Flag // f ∈ F.flags}, + x ∈ edgePairList W F ↔ x ∈ orientedPairList W F o := + fun x => ⟨fun _ => mem_orientedPairList W F o x, + fun _ => mem_edgePairList W F x⟩ + have hlen := length_eq_of_nodup_mem _ _ + (edgePairList_nodup W F) (orientedPairList_nodup W F o) hmem + set g : {f : W.Flag // f ∈ F.flags} → Fin (edgeCount W + edgeCount W) := + fun f => starFlagEnum W f.val + -- edgePairList.map g is nodup (same elements as globalSlotList.map g) + have hg : ((edgePairList W F).map g).Nodup := by + have hperm : ((edgePairList W F).map g).Perm + ((globalSlotList W F).map g) := by + apply List.Perm.map g + exact (List.perm_ext_iff_of_nodup + (edgePairList_nodup W F) (globalSlotList_nodup W F)).mpr + (fun x => ⟨fun _ => mem_globalSlotList W F x, + fun _ => mem_edgePairList W F x⟩) + exact hperm.nodup_iff.mpr (globalSlotList_map_slot_nodup W F) + have hkey := sortSign_map_listIndexPerm + (edgePairList W F) (orientedPairList W F o) + (edgePairList_nodup W F) (orientedPairList_nodup W F o) + hmem hlen g hg + -- sortSign(edgePairList.map g) = (-1)^C(n,2) + have hss_edge : sortSign ((edgePairList W F).map g) = + (-1 : ℤ) ^ Nat.choose (partEdges W F).length 2 := by + rw [sortSign, inversions_edgePairList_slots] + -- sortSign(orientedPairList.map g) = (-1)^(C(n,2) + s) + have hss_oriented : sortSign ((orientedPairList W F o).map g) = + (-1 : ℤ) ^ (Nat.choose (partEdges W F).length 2 + + ((partEdges W F).filter (fun i => + o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = true)).length) := by + rw [sortSign, orientedPairList_map_slot] + simp only [partEdges] + have hfilt_eq : ∀ (l : List (Fin (edgeCount W))), + (l.filter (fun i => o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)))).length = + (l.filter (fun i => decide (o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = true))).length := by + intro l; congr 1; congr 1; ext i; exact (Bool.decide_coe _).symm + rw [inversions_oriented_interleave _ _ + (List.sortedLT_iff_pairwise.mp (Finset.sortedLT_sort (edgeIndexSet W F))), + hfilt_eq] + -- Combine: sign(τ) = sortSign(oriented) / sortSign(edge) = (-1)^s + rw [hss_oriented, hss_edge] at hkey + -- hkey: (-1)^(C + s) = sign(τ) * (-1)^C + set c := Nat.choose (partEdges W F).length 2 + rw [pow_add] at hkey + -- hkey: (-1)^c * (-1)^s = sign(τ) * (-1)^c where s = filter length + have hcc : ((-1 : ℤ) ^ c) * ((-1 : ℤ) ^ c) = 1 := by + rw [← pow_add, show c + c = 2 * c from by omega, + pow_mul, neg_one_sq, one_pow] + -- Cancel (-1)^c to get sign(τ) = (-1)^s + have hsign : (Equiv.Perm.sign (listIndexPerm (edgePairList W F) + (orientedPairList W F o) (edgePairList_nodup W F) + (orientedPairList_nodup W F o) hmem hlen) : ℤ) = + (-1 : ℤ) ^ ((partEdges W F).filter (fun i => + o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = true)).length := by + -- From hkey, multiply both sides by (-1)^c on the right + have h := congr_arg (· * (-1 : ℤ) ^ c) hkey + rw [mul_assoc, mul_assoc] at h + rw [hcc, mul_one] at h + rw [mul_comm ((-1 : ℤ) ^ _) ((-1 : ℤ) ^ c), ← mul_assoc, hcc, one_mul] at h + exact h.symm + rw [hsign, filter_swapped_partEdges_card] + +/-! ### Part 3: swap-count complement -/ + +open Classical in +/-- Every edge's representative is either outgoing or incoming, so +the two counts partition the edges. -/ +theorem card_out_add_card_in_edges (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) : + ((edgeIndexSet W F).filter (fun i => + o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = true)).card + + inRepCount W F o = (edgeIndexSet W F).card := by + rw [inRepCount] + -- inRepCount filters univ for membership AND isOut = false; + -- first show it equals filtering edgeIndexSet for isOut = false + have hinrep : + (Finset.univ.filter (fun i : Fin (edgeCount W) => + (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i) ∈ + F.flags ∧ + o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = false)).card = + ((edgeIndexSet W F).filter (fun i => + o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = false)).card := by + congr 1 + ext i + rw [Finset.mem_filter, Finset.mem_filter] + constructor + · rintro ⟨_, hmem, hout⟩ + exact ⟨by rw [edgeIndexSet, Finset.mem_filter]; exact ⟨Finset.mem_univ _, + hmem⟩, hout⟩ + · rintro ⟨hi, hout⟩ + rw [edgeIndexSet, Finset.mem_filter] at hi + exact ⟨Finset.mem_univ _, hi.2, hout⟩ + rw [hinrep] + have hconv : ((edgeIndexSet W F).filter (fun i => + o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = false)).card = + ((edgeIndexSet W F).filter (fun i => + ¬ (o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = true))).card := by + congr 1; ext i + simp only [Finset.mem_filter] + constructor + · rintro ⟨hi, hf⟩ + exact ⟨hi, by rw [hf]; exact fun h => Bool.noConfusion h⟩ + · rintro ⟨hi, hnt⟩ + refine ⟨hi, ?_⟩ + cases hb : o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) + · rfl + · exact absurd hb hnt + rw [hconv] + exact Finset.card_filter_add_card_filter_not + (fun i => o.isOut ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = true) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SignPair.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SignPair.lean new file mode 100644 index 0000000000..a969ff94ff --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SignPair.lean @@ -0,0 +1,62 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.IndexPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexValue + +/-! +# The sign pairing + +For two duplicate-free same-membership lists, the product of +their mapped sorting signs is the reindexing permutation's sign: +the transport plus a square. +-/ + +@[expose] public section + +namespace RS + + + +/-- **The sign pairing**: mapped sorting signs of two +enumerations multiply to the reindexing sign. -/ +theorem sortSign_key_pair {γ : Type*} [DecidableEq γ] + {β : Type} [LinearOrder β] (g : γ → β) + (hg : Function.Injective g) (l₁ l₂ : List γ) + (h₁ : l₁.Nodup) (h₂ : l₂.Nodup) + (hmem : ∀ x, x ∈ l₁ ↔ x ∈ l₂) + (hlen : l₁.length = l₂.length) : + (sortSign (l₁.map g) : ℂ) * (sortSign (l₂.map g) : ℂ) = + ((Equiv.Perm.sign + (listIndexPerm l₁ l₂ h₁ h₂ hmem hlen) : ℤ) : ℂ) := by + have htrans := sortSign_map_listIndexPerm l₁ l₂ h₁ h₂ + hmem hlen g (List.Nodup.map hg h₁) + have hsq : (sortSign (l₁.map g) : ℂ) * + (sortSign (l₁.map g) : ℂ) = 1 := sortSign_sq _ + calc (sortSign (l₁.map g) : ℂ) * + (sortSign (l₂.map g) : ℂ) + = (sortSign (l₁.map g) : ℂ) * + (((Equiv.Perm.sign (listIndexPerm l₁ l₂ h₁ h₂ hmem + hlen) : ℤ) : ℂ) * + (sortSign (l₁.map g) : ℂ)) := by + rw [show ((sortSign (l₂.map g) : ℤ) : ℂ) = + ((Equiv.Perm.sign (listIndexPerm l₁ l₂ h₁ h₂ hmem + hlen) : ℤ) : ℂ) * + ((sortSign (l₁.map g) : ℤ) : ℂ) from by + rw [htrans] + push_cast + ring] + _ = ((sortSign (l₁.map g) : ℂ) * + (sortSign (l₁.map g) : ℂ)) * + ((Equiv.Perm.sign (listIndexPerm l₁ l₂ h₁ h₂ hmem + hlen) : ℤ) : ℂ) := by ring + _ = ((Equiv.Perm.sign (listIndexPerm l₁ l₂ h₁ h₂ hmem + hlen) : ℤ) : ℂ) := by + rw [hsq, one_mul] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SkeinPowBraid.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SkeinPowBraid.lean new file mode 100644 index 0000000000..5ec2ac8e76 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SkeinPowBraid.lean @@ -0,0 +1,209 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StdTransport +public import LeanPool.RegtsSevenster.RS.Classical.Super.PowBraid + +/-! +# The skein-side adjacent braiding and the transport intertwining + +The adjacent braiding of strands in the skein category, mirroring +`powBraid`'s recursion, and the key intertwining: the model +transport `stdToOmega` conjugates the skein braiding into the +model braiding. The top square is proved abstractly for any +braided monoidal functor — where every rewrite fires — and the +strictness of the skein associator enters only through a small +concrete collapse. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open Functor.LaxMonoidal Functor.OplaxMonoidal + +/-- **The abstract top braiding square**: for a braided monoidal +functor, transporting two point identifications through the +structure maps intertwines the associator-conjugated braiding of +the last two factors. -/ +theorem braid_top_intertwine {C D : Type*} [Category C] + [Category D] [MonoidalCategory C] [MonoidalCategory D] + [BraidedCategory C] [BraidedCategory D] + (F : C ⥤ D) [F.LaxBraided] {PA PX : D} + {A X : C} (tA : PA ⟶ F.obj A) (tx : PX ⟶ F.obj X) : + (((tA ⊗ₘ tx) ≫ μ F A X) ⊗ₘ tx) ≫ μ F (A ⊗ X) X ≫ + F.map ((α_ A X X).hom ≫ (A ◁ (β_ X X).hom) ≫ + (α_ A X X).inv) = + (α_ PA PX PX).hom ≫ (PA ◁ (β_ PX PX).hom) ≫ + (α_ PA PX PX).inv ≫ + (((tA ⊗ₘ tx) ≫ μ F A X) ⊗ₘ tx) ≫ μ F (A ⊗ X) X := by + rw [show (((tA ⊗ₘ tx) ≫ μ F A X) ⊗ₘ tx) = + (((tA ⊗ₘ tx) ⊗ₘ tx) ≫ (μ F A X ▷ F.obj X)) from by + rw [← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.comp_id]] + simp only [Functor.map_comp, Category.assoc] + rw [Functor.LaxMonoidal.associativity_assoc] + rw [← Functor.LaxMonoidal.μ_natural_right_assoc] + rw [← MonoidalCategory.whiskerLeft_comp_assoc] + rw [Functor.LaxBraided.braided] + rw [MonoidalCategory.whiskerLeft_comp_assoc] + rw [MonoidalCategory.associator_naturality_assoc] + have hmove : (tA ⊗ₘ (tx ⊗ₘ tx)) ≫ + (F.obj A ◁ (β_ (F.obj X) (F.obj X)).hom) = + (PA ◁ (β_ PX PX).hom) ≫ (tA ⊗ₘ (tx ⊗ₘ tx)) := by + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.comp_id, + BraidedCategory.braiding_naturality] + rw [show tA ⊗ₘ ((β_ PX PX).hom ≫ (tx ⊗ₘ tx)) = + (𝟙 PA ⊗ₘ (β_ PX PX).hom) ≫ (tA ⊗ₘ (tx ⊗ₘ tx)) from by + rw [MonoidalCategory.tensorHom_comp_tensorHom, + Category.id_comp]] + rw [MonoidalCategory.id_tensorHom] + rw [reassoc_of% hmove] + rw [Functor.LaxMonoidal.associativity_inv] + rw [MonoidalCategory.associator_inv_naturality_assoc] + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The skein-side adjacent braiding at position `i`. -/ +noncomputable def skeinPowBraid : + (n : ℕ) → (i : ℕ) → i + 2 ≤ n → + ((SkeinObj.mk n : SkeinObj f) ⟶ SkeinObj.mk n) + | 0, _, h => absurd h (by omega) + | 1, _, h => absurd h (by omega) + | n + 2, i, h => + if hi : i = n then + (SkeinObj.mk n : SkeinObj f) ◁ + (β_ (SkeinObj.mk 1 : SkeinObj f) (SkeinObj.mk 1)).hom + else (skeinPowBraid (n + 1) i (by omega)) ▷ SkeinObj.mk 1 + +/-- The skein associator at concrete arities collapses to the +identity. -/ +theorem skein_associator_collapse (n : ℕ) : + (α_ (SkeinObj.mk n : SkeinObj f) (SkeinObj.mk 1) + (SkeinObj.mk 1)).hom = 𝟙 (SkeinObj.mk (n + 2)) := by + change bundleMapClass f (finCongr _) = _ + rw [show (finCongr (show n + 1 + 1 = n + (1 + 1) by omega) : + Fin (n + 2) ≃ Fin (n + 2)) = + _root_.Equiv.refl (Fin (n + 2)) from + _root_.Equiv.ext (fun x => Fin.ext rfl)] + exact bundleMapClass_refl f (n + 2) + +/-- The inverse skein associator at concrete arities collapses to +the identity. -/ +theorem skein_associator_inv_collapse (n : ℕ) : + (α_ (SkeinObj.mk n : SkeinObj f) (SkeinObj.mk 1) + (SkeinObj.mk 1)).inv = 𝟙 (SkeinObj.mk (n + 2)) := by + change bundleMapClass f (finCongr _) = _ + rw [show (finCongr (show n + (1 + 1) = n + 1 + 1 by omega) : + Fin (n + 2) ≃ Fin (n + 2)) = + _root_.Equiv.refl (Fin (n + 2)) from + _root_.Equiv.ext (fun x => Fin.ext rfl)] + exact bundleMapClass_refl f (n + 2) + +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} +variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) + +-- The intertwining is proved by recursion on the +-- arity with a top and a lower case, each unfolding the transport +-- and the braiding. +/-- **The transport intertwining**: the model transport carries +the skein-side adjacent braiding to the model-side adjacent +braiding. -/ +theorem stdToOmega_powBraid : + ∀ (n i : ℕ) (h : i + 2 ≤ n), + letI := P.braided + stdToOmega f P e n ≫ P.ω.map (skeinPowBraid f n i h) = + powBraid (stdSuperPair k ℓ) n i h ≫ stdToOmega f P e n + | 0, _, h => absurd h (by omega) + | 1, _, h => absurd h (by omega) + | n + 2, i, h => by + let := P.braided + by_cases hi : i = n + · -- ═══════ Top case ═══════ + rw [show skeinPowBraid f (n + 2) i h = + (SkeinObj.mk n : SkeinObj f) ◁ + (β_ (SkeinObj.mk 1 : SkeinObj f) + (SkeinObj.mk 1)).hom from dite_eq_left hi] + rw [show powBraid (stdSuperPair k ℓ) (n + 2) i h = + topBraid (stdSuperPair k ℓ) n from dite_eq_left hi] + have hcollapse : + ((SkeinObj.mk n : SkeinObj f) ◁ + (β_ (SkeinObj.mk 1 : SkeinObj f) + (SkeinObj.mk 1)).hom) = + (α_ (SkeinObj.mk n : SkeinObj f) (SkeinObj.mk 1) + (SkeinObj.mk 1)).hom ≫ + ((SkeinObj.mk n : SkeinObj f) ◁ + (β_ (SkeinObj.mk 1 : SkeinObj f) + (SkeinObj.mk 1)).hom) ≫ + (α_ (SkeinObj.mk n : SkeinObj f) (SkeinObj.mk 1) + (SkeinObj.mk 1)).inv := by + rw [skein_associator_collapse, + skein_associator_inv_collapse] + exact ((Category.id_comp _).trans + (Category.comp_id _)).symm + have habs := braid_top_intertwine P.ω + (stdToOmega f P e n) e + refine Eq.trans ?_ habs + exact congrArg (fun z => + (((stdToOmega f P e n ⊗ₘ e) ≫ + μ P.ω (SkeinObj.mk n) (SkeinObj.mk 1)) ⊗ₘ e) ≫ + μ P.ω (SkeinObj.mk n ⊗ SkeinObj.mk 1) + (SkeinObj.mk 1) ≫ P.ω.map z) hcollapse + · -- ═══════ Whisker case ═══════ + have hle : i + 2 ≤ n + 1 := by omega + rw [show skeinPowBraid f (n + 2) i h = + (skeinPowBraid f (n + 1) i hle) ▷ SkeinObj.mk 1 from + dite_eq_right hi] + rw [show powBraid (stdSuperPair k ℓ) (n + 2) i h = + (powBraid (stdSuperPair k ℓ) (n + 1) i hle) ▷ + stdSuperPair k ℓ from dite_eq_right hi] + change ((stdToOmega f P e (n + 1) ⊗ₘ e) ≫ + μ P.ω (SkeinObj.mk (n + 1)) (SkeinObj.mk 1)) ≫ + P.ω.map ((skeinPowBraid f (n + 1) i hle) ▷ + SkeinObj.mk 1) = + (powBraid (stdSuperPair k ℓ) (n + 1) i hle ▷ + stdSuperPair k ℓ) ≫ stdToOmega f P e (n + 2) + refine (Category.assoc _ _ _).trans ?_ + refine (congrArg (fun z => + (stdToOmega f P e (n + 1) ⊗ₘ e) ≫ z) + (Functor.LaxMonoidal.μ_natural_left P.ω + (skeinPowBraid f (n + 1) i hle) + (SkeinObj.mk 1)).symm).trans ?_ + refine ((Category.assoc _ _ _).symm).trans ?_ + refine (congrArg (fun z => z ≫ + μ P.ω (SkeinObj.mk (n + 1)) (SkeinObj.mk 1)) (show + (stdToOmega f P e (n + 1) ⊗ₘ e) ≫ + (P.ω.map (skeinPowBraid f (n + 1) i hle) ▷ + P.ω.obj (SkeinObj.mk 1)) = + ((stdToOmega f P e (n + 1) ≫ + P.ω.map (skeinPowBraid f (n + 1) i hle)) ⊗ₘ e) + from by + rw [← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.comp_id])).trans ?_ + refine (congrArg (fun z => (z ⊗ₘ e) ≫ + μ P.ω (SkeinObj.mk (n + 1)) (SkeinObj.mk 1)) + (stdToOmega_powBraid (n + 1) i hle)).trans ?_ + refine (congrArg (fun z => z ≫ + μ P.ω (SkeinObj.mk (n + 1)) (SkeinObj.mk 1)) (show + ((powBraid (stdSuperPair k ℓ) (n + 1) i hle ≫ + stdToOmega f P e (n + 1)) ⊗ₘ e) = + (powBraid (stdSuperPair k ℓ) (n + 1) i hle ▷ + stdSuperPair k ℓ) ≫ (stdToOmega f P e (n + 1) ⊗ₘ e) + from by + rw [← MonoidalCategory.tensorHom_id, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.id_comp])).trans ?_ + exact Category.assoc _ _ _ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SlotPairing.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SlotPairing.lean new file mode 100644 index 0000000000..6379f9742d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SlotPairing.lean @@ -0,0 +1,48 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MultiStar + +/-! +# The slot pairing + +The flag enumeration sends the fragment pairing to the straight +cap matching: the two flags of the `i`-th canonical edge sit at +slots `i` and `edgeCount + i`. The general-flag glue for the +Eulerian reindex. +-/ + +@[expose] public section + +namespace RS + +variable {α : Type} (W : ClosedFragment) + +/-- The rep slot carries the canonical representative. -/ +theorem starFlagEnum_symm_castAdd (i : Fin (edgeCount W)) : + (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i) = + (canonicalReps W)[i.val]'(i.isLt) := by + rw [_root_.Equiv.symm_apply_eq] + exact (starEnum_rep W i.val i.isLt).symm + +/-- The partner slot carries the paired flag. -/ +theorem starFlagEnum_symm_natAdd (i : Fin (edgeCount W)) : + (starFlagEnum W).symm (Fin.natAdd (edgeCount W) i) = + W.pairing ((canonicalReps W)[i.val]'(i.isLt)) := by + rw [_root_.Equiv.symm_apply_eq] + exact (starEnum_partner W i.val i.isLt).symm + +/-- **The slot pairing**: the fragment pairing links slot `i` +to slot `edgeCount + i`. -/ +theorem pairing_starFlagEnum_symm (i : Fin (edgeCount W)) : + W.pairing ((starFlagEnum W).symm + (Fin.castAdd (edgeCount W) i)) = + (starFlagEnum W).symm (Fin.natAdd (edgeCount W) i) := by + rw [starFlagEnum_symm_castAdd, starFlagEnum_symm_natAdd] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SortFactor.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SortFactor.lean new file mode 100644 index 0000000000..1705530cb8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SortFactor.lean @@ -0,0 +1,103 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSigma +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSort + +/-! +# The sorted factorization of a multi-star + +Chaining the sort with the block enumeration and the block +factorization: any multi-star is, up to relabelling along the +sort, the iterated tensor of vertex stars over its degree list +with the free circles split off. Specialised to the star union +this is the fragment-level star factorization. +-/ + +@[expose] public section + +namespace RS + +section SortEquiv + +variable {n m : ℕ} (assign : Fin n → Fin m) + +/-- The full sort: slots to the block-concatenated enumeration. -/ +noncomputable def sortEquiv : Fin n ≃ Fin (degList assign).sum := + (sortSigma assign).trans (blockSigmaEquiv (degList assign)) + +/-- The sort intertwines the assignment with the block +assignment. -/ +theorem blockAssign_sortEquiv (i : Fin n) : + blockAssign (degList assign) (sortEquiv assign i) = + finCongr (degList_length assign).symm (assign i) := by + change blockAssign _ + (blockSigmaEquiv _ (sortSigma assign i)) = _ + rw [blockAssign_blockSigmaEquiv] + exact sortSigma_fst assign i + +/-- Sorting a multi-star into block-assigned form. -/ +noncomputable def multiStarSorted (c : ℕ) : + (multiStar assign c).Equiv + ((multiStar (blockAssign (degList assign)) c).relabel + (sortEquiv assign).symm) := + multiStarCompRelabel assign c (sortEquiv assign) + (blockAssign (degList assign)) + (finCongr (degList_length assign).symm) + (blockAssign_sortEquiv assign) + +/-- **The sorted factorization**: a multi-star is the iterated +tensor of vertex stars over its degree list, with the circles +split off, relabelled along the sort. -/ +noncomputable def multiStarFactor (c : ℕ) : + (multiStar assign c).Equiv + ((addCircles (starTensor (degList assign)) c).relabel + (sortEquiv assign).symm) := + (multiStarSorted assign c).trans + (Fragment.Equiv.relabelCongr + (multiStarBlocks (degList assign) c) _) + +end SortEquiv + +section StarUnionFactor + +/-- Reindexing the vertices of a multi-star. -/ +noncomputable def multiStarVertexMap {V V' : Type} + [Fintype V] [Fintype V'] {n : ℕ} (assign : Fin n → V) + (c : ℕ) (e : V ≃ V') : + (multiStar assign c).Equiv (multiStar (e ∘ assign) c) where + flagEquiv := _root_.Equiv.refl _ + vertexEquiv := e + attach_comm := fun g => by + rcases g with i | i <;> rfl + pairing_comm := fun g => by + rcases g with i | i <;> rfl + circles_eq := rfl + +/-- The star union's assignment, with vertices enumerated. -/ +noncomputable def starAssignEnum (W : ClosedFragment) : + Fin (edgeCount W + edgeCount W) → + Fin (Fintype.card W.Vertex) := + (Fintype.equivFin W.Vertex) ∘ starAssign W + +/-- **The fragment-level star factorization**: the star union of +a closed fragment is the iterated tensor of its vertex stars over +the degree list, with its free circles split off, relabelled +along the sort. -/ +noncomputable def starUnionFactor (W : ClosedFragment) : + (starUnion W).Equiv + ((addCircles (starTensor (degList (starAssignEnum W))) + W.circles).relabel (sortEquiv (starAssignEnum W)).symm) := + (starUnionMultiStar W).trans + ((multiStarVertexMap (starAssign W) W.circles + (Fintype.equivFin W.Vertex)).trans + (multiStarFactor (starAssignEnum W) W.circles)) + +end StarUnionFactor + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SortPerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SortPerm.lean new file mode 100644 index 0000000000..8092039536 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SortPerm.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelStarVec + +/-! +# The sort as a permutation and a cast + +The inverse sort of the star factorization splits as a same-arity +permutation followed by the degree-sum cast, feeding the +braiding-word transport and the cast transport respectively. +-/ + +@[expose] public section + +namespace RS + +/-- The inverse sort as a permutation of the degree-sum arity. -/ +noncomputable def sortSplitPerm (W : ClosedFragment) : + _root_.Equiv.Perm + (Fin ((degList (starAssignEnum W)).sum)) := + (sortEquiv (starAssignEnum W)).symm.trans (finCongr + (degList_sum (starAssignEnum W)).symm) + +/-- The inverse sort is its permutation followed by the arity +cast. -/ +theorem sortEquiv_symm_split (W : ClosedFragment) : + (sortEquiv (starAssignEnum W)).symm = + (sortSplitPerm W).trans (finCongr + (degList_sum (starAssignEnum W))) := + _root_.Equiv.ext (fun _ => Fin.ext rfl) + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The sort bundle map splits as permutation then cast. -/ +theorem bmc_sort_split (W : ClosedFragment) : + bundleMapClass f (sortEquiv (starAssignEnum W)).symm = + HomSpace.comp f ((degList (starAssignEnum W)).sum) + ((degList (starAssignEnum W)).sum) + (edgeCount W + edgeCount W) + (bundleMapClass f ((sortSplitPerm W) : + Fin ((degList (starAssignEnum W)).sum) ≃ + Fin ((degList (starAssignEnum W)).sum))) + (bundleMapClass f (finCongr + (degList_sum (starAssignEnum W)))) := by + rw [bundleMapClass_comp] + exact bundleMapClass_congr f (sortEquiv_symm_split W) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarClassFactor.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarClassFactor.lean new file mode 100644 index 0000000000..a126cc89d0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarClassFactor.lean @@ -0,0 +1,114 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortFactor + +/-! +# The class-level star factorization + +Transporting the fragment-level star factorization to Hom +classes: the star-union class of a closed fragment is the circle +power times the iterated vertex-star tensor class composed with +the bundle map of the sort. +-/ + +@[expose] public section + +namespace RS + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- **Free circles are a scalar on classes**, at any arity. -/ +theorem ofFragment_addCircles {t : ℕ} (Y : Fragment (Fin t)) + (c : ℕ) : + HomSpace.ofFragment f.val (addCircles Y c) = + circleVal f ^ c • HomSpace.ofFragment f.val Y := + ((ofFragment_relabel_unitcast f (s := t) (t := 0) + (addCircles Y c)).symm.trans + ((HomSpace.ofFragment_congr f + (addCirclesTensor (s := t) (t := 0) Y c).symm).trans + (ofFragment_tensor_circles f (s := t) (t := 0) Y c))).trans + (congrArg (fun z => circleVal f ^ c • z) + (ofFragment_relabel_unitcast f (s := t) (t := 0) Y)) + +/-- Composing with a bundle-map class relabels the fragment along +the outgoing transport. -/ +theorem comp_bundleMapClass {s n m : ℕ} (e : Fin n ≃ Fin m) + (X : Fragment (Fin (s + n))) : + HomSpace.comp f s n m (HomSpace.ofFragment f.val X) + (bundleMapClass f e) = + HomSpace.ofFragment f.val (X.relabel + (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin s)) e).trans + finSumFinEquiv))) := by + rw [bundleMapClass, HomSpace.comp_ofFragment] + exact HomSpace.ofFragment_congr f (composeBundleMap e X) + +/-- At source arity zero the outgoing transport is the map +itself, up to padding casts. -/ +theorem sort_transport_eq {N M : ℕ} (σ : Fin N ≃ Fin M) : + ((finCongr (by omega : N = 0 + N)).trans + (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin 0)) σ).trans + finSumFinEquiv)) : Fin N ≃ Fin (0 + M)) = + σ.trans (finCongr (by omega : M = 0 + M)) := by + refine _root_.Equiv.ext (fun x => Fin.ext ?_) + change (finSumFinEquiv ((_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin 0)) σ) + (finSumFinEquiv.symm (finCongr + (by omega : N = 0 + N) x)))).val = _ + rw [show (finCongr (by omega : N = 0 + N) x : + Fin (0 + N)) = Fin.natAdd 0 x from + Fin.ext (show x.val = 0 + x.val by omega), + finSumFinEquiv_symm_apply_natAdd] + change 0 + (σ x).val = (σ x).val + omega + +/-- **The class-level star factorization**: the star-union class +is the circle power times the iterated vertex-star tensor class, +composed with the bundle map of the sort. -/ +theorem starClass_factor (W : ClosedFragment) : + starClass f W = circleVal f ^ W.circles • + HomSpace.comp f 0 ((degList (starAssignEnum W)).sum) + (edgeCount W + edgeCount W) + (HomSpace.ofFragment f.val + ((starTensor (degList (starAssignEnum W))).relabel + (finCongr (by omega : + (degList (starAssignEnum W)).sum = + 0 + (degList (starAssignEnum W)).sum)))) + (bundleMapClass f + (sortEquiv (starAssignEnum W)).symm) := by + rw [comp_bundleMapClass, + HomSpace.ofFragment_congr f + (Fragment.Equiv.relabelTrans + (starTensor (degList (starAssignEnum W))) _ _), + show (finCongr (by omega : + (degList (starAssignEnum W)).sum = + 0 + (degList (starAssignEnum W)).sum)).trans + (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin 0)) + (sortEquiv (starAssignEnum W)).symm).trans + finSumFinEquiv)) = + (sortEquiv (starAssignEnum W)).symm.trans + (finCongr (by omega : edgeCount W + edgeCount W = + 0 + (edgeCount W + edgeCount W))) from + sort_transport_eq _] + rw [starClass, + HomSpace.ofFragment_congr f + ((Fragment.Equiv.relabelCongr (starUnionFactor W) + (finCongr (by omega : edgeCount W + edgeCount W = + 0 + (edgeCount W + edgeCount W)))).trans + (Fragment.Equiv.relabelTrans _ _ _))] + exact ofFragment_addCircles f + ((starTensor (degList (starAssignEnum W))).relabel + ((sortEquiv (starAssignEnum W)).symm.trans + (finCongr (by omega : edgeCount W + edgeCount W = + 0 + (edgeCount W + edgeCount W))))) + W.circles + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPeel.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPeel.lean new file mode 100644 index 0000000000..b33886ef14 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPeel.lean @@ -0,0 +1,420 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleScalar + +/-! +# Peeling the multi-star into vertex stars + +The block-sorted multi-star over a degree list is the iterated +tensor of vertex stars: `blockAssign` sends each slot to its +block, `starTensor` is the iterated tensor, and the peel +induction identifies them. +-/ + +@[expose] public section + +namespace RS + +/-- The block of a slot in a degree list. -/ +def blockAssign : (ds : List ℕ) → Fin ds.sum → Fin ds.length + | [], i => i.elim0 + | d :: ds, i => + if h : i.val < d then ⟨0, by simp⟩ + else (blockAssign ds ⟨i.val - d, by + have := i.isLt + simp only [List.sum_cons] at this + omega⟩).succ + +/-- The iterated tensor of vertex stars over a degree list. -/ +noncomputable def starTensor : (ds : List ℕ) → + Fragment (Fin ds.sum) + | [] => emptyClosedFragment + | d :: ds => + (tensorFragment + ((vertexStar d).relabel (finCongr (by omega : d = 0 + d))) + ((starTensor ds).relabel (finCongr + (by omega : ds.sum = 0 + ds.sum)))).relabel + (finCongr (by + show (0 + 0) + (d + ds.sum) = (d :: ds).sum + simp [List.sum_cons])) + +/-- The empty multi-star is the empty fragment. -/ +noncomputable def multiStarNil (c : ℕ) : + (multiStar (blockAssign []) c).Equiv + (addCircles (starTensor []) c) where + flagEquiv := + haveI h1 : IsEmpty (multiStar (blockAssign []) c).Flag := + ⟨fun g => g.elim (fun i => i.elim0) (fun i => i.elim0)⟩ + haveI h2 : IsEmpty (addCircles (starTensor []) c).Flag := + inferInstanceAs (IsEmpty Empty) + _root_.Equiv.equivOfIsEmpty _ _ + vertexEquiv := + haveI h1 : IsEmpty (multiStar (blockAssign []) c).Vertex := + ⟨fun i => i.elim0⟩ + haveI h2 : IsEmpty (addCircles (starTensor []) c).Vertex := + inferInstanceAs (IsEmpty Empty) + _root_.Equiv.equivOfIsEmpty _ _ + attach_comm := fun g => + g.elim (fun i => i.elim0) (fun i => i.elim0) + pairing_comm := fun g => + g.elim (fun i => i.elim0) (fun i => i.elim0) + circles_eq := by + change c = 0 + c + omega + +/-- The head-vertex splitting map. -/ +def peelVertexFun (n : ℕ) (v : Fin (n + 1)) : Unit ⊕ Fin n := + if h : v.val = 0 then Sum.inl () + else Sum.inr ⟨v.val - 1, by have := v.isLt; omega⟩ + +/-- The head-vertex merging map. -/ +def peelVertexInv (n : ℕ) : Unit ⊕ Fin n → Fin (n + 1) + | Sum.inl _ => ⟨0, Nat.succ_pos n⟩ + | Sum.inr j => ⟨j.val + 1, by have := j.isLt; omega⟩ + +/-- The head-vertex split. -/ +def peelVertexEquiv (n : ℕ) : Fin (n + 1) ≃ Unit ⊕ Fin n where + toFun := peelVertexFun n + invFun := peelVertexInv n + left_inv v := by + by_cases h : v.val = 0 + · have h1 : peelVertexFun n v = Sum.inl () := dite_eq_left h + rw [h1] + exact Fin.ext h.symm + · have h1 : peelVertexFun n v = + Sum.inr ⟨v.val - 1, by have := v.isLt; omega⟩ := + dite_eq_right h + rw [h1] + exact Fin.ext (by + change v.val - 1 + 1 = v.val + omega) + right_inv x := by + rcases x with u | j + · exact dite_eq_left rfl + · have h1 : peelVertexFun n ⟨j.val + 1, by + have := j.isLt + omega⟩ = Sum.inr ⟨j.val + 1 - 1, by + have := j.isLt + omega⟩ := + dite_eq_right (show ¬ (j.val + 1 = 0) by omega) + rw [show peelVertexInv n (Sum.inr j) = + (⟨j.val + 1, by have := j.isLt; omega⟩ : Fin (n + 1)) + from rfl, h1] + exact congrArg Sum.inr (Fin.ext (by + change j.val + 1 - 1 = j.val + omega)) + +/-- The peel splits off the first vertex. -/ +theorem peelVertexEquiv_zero (n : ℕ) (h : 0 < n + 1) : + peelVertexEquiv n ⟨0, h⟩ = Sum.inl () := by + change peelVertexFun n ⟨0, h⟩ = Sum.inl () + exact dite_eq_left rfl + +/-- And leaves the rest in order. -/ +theorem peelVertexEquiv_succ (n : ℕ) (j : Fin n) : + peelVertexEquiv n j.succ = Sum.inr j := by + have h1 : peelVertexFun n j.succ = + Sum.inr ⟨j.succ.val - 1, by + change j.val + 1 - 1 < n + have := j.isLt + omega⟩ := + dite_eq_right (show ¬ (j.succ.val = 0) from by + change ¬ (j.val + 1 = 0) + omega) + change peelVertexFun n j.succ = Sum.inr j + rw [h1] + exact congrArg Sum.inr (Fin.ext (by + change j.val + 1 - 1 = j.val + omega)) + +/-- The slot shuffle of the peel. -/ +def peelFlagEquiv (d S : ℕ) : + (Fin (d + S) ⊕ Fin (d + S)) ≃ + ((Fin d ⊕ Fin d) ⊕ (Fin S ⊕ Fin S)) := + (_root_.Equiv.sumCongr finSumFinEquiv.symm + finSumFinEquiv.symm).trans + (_root_.Equiv.sumSumSumComm (Fin d) (Fin S) (Fin d) (Fin S)) + +/-- On the left side, the first block's flags go to the peeled +star. -/ +theorem peelFlagEquiv_inl_low (d S : ℕ) (i : Fin d) : + peelFlagEquiv d S (Sum.inl (Fin.castAdd S i)) = + Sum.inl (Sum.inl i) := by + unfold peelFlagEquiv + rw [_root_.Equiv.trans_apply, _root_.Equiv.sumCongr_apply, + Sum.map_inl, finSumFinEquiv_symm_apply_castAdd] + rfl + +/-- And the remaining left flags to the rest. -/ +theorem peelFlagEquiv_inl_high (d S : ℕ) (j : Fin S) : + peelFlagEquiv d S (Sum.inl (Fin.natAdd d j)) = + Sum.inr (Sum.inl j) := by + unfold peelFlagEquiv + rw [_root_.Equiv.trans_apply, _root_.Equiv.sumCongr_apply, + Sum.map_inl, finSumFinEquiv_symm_apply_natAdd] + rfl + +/-- On the right side, the first block's flags go to the peeled +star. -/ +theorem peelFlagEquiv_inr_low (d S : ℕ) (i : Fin d) : + peelFlagEquiv d S (Sum.inr (Fin.castAdd S i)) = + Sum.inl (Sum.inr i) := by + unfold peelFlagEquiv + rw [_root_.Equiv.trans_apply, _root_.Equiv.sumCongr_apply, + Sum.map_inr, finSumFinEquiv_symm_apply_castAdd] + rfl + +/-- And the remaining right flags to the rest. -/ +theorem peelFlagEquiv_inr_high (d S : ℕ) (j : Fin S) : + peelFlagEquiv d S (Sum.inr (Fin.natAdd d j)) = + Sum.inr (Sum.inr j) := by + unfold peelFlagEquiv + rw [_root_.Equiv.trans_apply, _root_.Equiv.sumCongr_apply, + Sum.map_inr, finSumFinEquiv_symm_apply_natAdd] + rfl + +private theorem multiStarPeel_attach_comm {n : ℕ} (d S c : ℕ) + (rest : Fin S → Fin n) (a : Fin (d + S) → Fin (n + 1)) + (ha_low : ∀ i : Fin d, + a (Fin.castAdd S i) = ⟨0, Nat.succ_pos n⟩) + (ha_high : ∀ j : Fin S, + a (Fin.natAdd d j) = (rest j).succ) + (g : ((multiStar a c)).Flag) : + (((tensorFragment + ((vertexStar d).relabel (finCongr (by omega : d = 0 + d))) + ((multiStar rest c).relabel (finCongr + (by omega : S = 0 + S)))).relabel + (finCongr (by omega : (0 + 0) + (d + S) = d + S)))).attach (peelFlagEquiv d S g) = + (((multiStar a c)).attach g).map (peelVertexEquiv n) id := by + rcases g with i | i + · rcases Nat.lt_or_ge i.val d with hi | hi + · rw [show i = Fin.castAdd S ⟨i.val, hi⟩ from Fin.ext rfl] + erw [peelFlagEquiv_inl_low d S ⟨i.val, hi⟩] + change (Sum.inl (Sum.inl ()) : + ((Unit ⊕ Fin n) ⊕ Fin (d + S))) = + Sum.map (peelVertexEquiv n) id + (Sum.inl (a (Fin.castAdd S ⟨i.val, hi⟩))) + rw [ha_low] + change Sum.inl (Sum.inl ()) = + Sum.inl (peelVertexEquiv n ⟨0, Nat.succ_pos n⟩) + rw [peelVertexEquiv_zero] + · rw [show i = Fin.natAdd d ⟨i.val - d, by + have := i.isLt + omega⟩ from Fin.ext (by + change i.val = d + (i.val - d) + omega)] + erw [peelFlagEquiv_inl_high d S] + change (Sum.inl (Sum.inr (rest ⟨i.val - d, by + have := i.isLt + omega⟩)) : ((Unit ⊕ Fin n) ⊕ Fin (d + S))) = + Sum.map (peelVertexEquiv n) id + (Sum.inl (a (Fin.natAdd d ⟨i.val - d, by + have := i.isLt + omega⟩))) + rw [ha_high] + change Sum.inl (Sum.inr (rest ⟨i.val - d, _⟩)) = + Sum.inl (peelVertexEquiv n (rest ⟨i.val - d, _⟩).succ) + rw [peelVertexEquiv_succ] + · rcases Nat.lt_or_ge i.val d with hi | hi + · rw [show i = Fin.castAdd S ⟨i.val, hi⟩ from Fin.ext rfl] + erw [peelFlagEquiv_inr_low d S ⟨i.val, hi⟩] + change Sum.inr (finCongr + (by omega : (0 + 0) + (d + S) = d + S) + (interleaveEquiv 0 d 0 S + (Sum.inl (finCongr (by omega : d = 0 + d) + ⟨i.val, hi⟩)))) = + Sum.inr (Fin.castAdd S ⟨i.val, hi⟩) + refine congrArg Sum.inr (Fin.ext ?_) + rw [show (finCongr (by omega : d = 0 + d) + (⟨i.val, hi⟩ : Fin d) : Fin (0 + d)) = + Fin.natAdd 0 ⟨i.val, hi⟩ from Fin.ext (by + change i.val = 0 + i.val + omega), + interleaveEquiv_inl_high] + change (0 + 0) + i.val = i.val + omega + · rw [show i = Fin.natAdd d ⟨i.val - d, by + have := i.isLt + omega⟩ from Fin.ext (by + change i.val = d + (i.val - d) + omega)] + erw [peelFlagEquiv_inr_high d S] + change Sum.inr (finCongr + (by omega : (0 + 0) + (d + S) = d + S) + (interleaveEquiv 0 d 0 S + (Sum.inr (finCongr (by omega : S = 0 + S) + ⟨i.val - d, by have := i.isLt; omega⟩)))) = + Sum.inr (Fin.natAdd d ⟨i.val - d, by + have := i.isLt + omega⟩) + refine congrArg Sum.inr (Fin.ext ?_) + rw [show (finCongr (by omega : S = 0 + S) + (⟨i.val - d, by have := i.isLt; omega⟩ : Fin S) : + Fin (0 + S)) = + Fin.natAdd 0 ⟨i.val - d, by + have := i.isLt + omega⟩ from Fin.ext (by + change i.val - d = 0 + (i.val - d) + omega), + interleaveEquiv_inr_high] + change (0 + 0) + (d + (i.val - d)) = d + (i.val - d) + omega +-- ═══════ PAIRING ═══════ +-- The peel does not move any edge, so both sides read the same +-- partner. + +private theorem multiStarPeel_pairing_comm {n : ℕ} (d S c : ℕ) + (rest : Fin S → Fin n) (a : Fin (d + S) → Fin (n + 1)) + (g : ((multiStar a c)).Flag) : + peelFlagEquiv d S (((multiStar a c)).pairing g) = + (((tensorFragment + ((vertexStar d).relabel (finCongr (by omega : d = 0 + d))) + ((multiStar rest c).relabel (finCongr + (by omega : S = 0 + S)))).relabel + (finCongr (by omega : (0 + 0) + (d + S) = d + S)))).pairing (peelFlagEquiv d S g) := by + rcases g with i | i + · rcases Nat.lt_or_ge i.val d with hi | hi + · rw [show i = Fin.castAdd S ⟨i.val, hi⟩ from Fin.ext rfl, + show (multiStar a c).pairing + (Sum.inl (Fin.castAdd S ⟨i.val, hi⟩)) = + Sum.inr (Fin.castAdd S ⟨i.val, hi⟩) from rfl] + erw [peelFlagEquiv_inr_low d S ⟨i.val, hi⟩, + peelFlagEquiv_inl_low d S ⟨i.val, hi⟩] + rfl + · rw [show i = Fin.natAdd d ⟨i.val - d, by + have := i.isLt + omega⟩ from Fin.ext (by + change i.val = d + (i.val - d) + omega), + show (multiStar a c).pairing + (Sum.inl (Fin.natAdd d ⟨i.val - d, by + have := i.isLt + omega⟩)) = + Sum.inr (Fin.natAdd d ⟨i.val - d, by + have := i.isLt + omega⟩) from rfl] + erw [peelFlagEquiv_inr_high d S, + peelFlagEquiv_inl_high d S] + rfl + · rcases Nat.lt_or_ge i.val d with hi | hi + · rw [show i = Fin.castAdd S ⟨i.val, hi⟩ from Fin.ext rfl, + show (multiStar a c).pairing + (Sum.inr (Fin.castAdd S ⟨i.val, hi⟩)) = + Sum.inl (Fin.castAdd S ⟨i.val, hi⟩) from rfl] + erw [peelFlagEquiv_inl_low d S ⟨i.val, hi⟩, + peelFlagEquiv_inr_low d S ⟨i.val, hi⟩] + rfl + · rw [show i = Fin.natAdd d ⟨i.val - d, by + have := i.isLt + omega⟩ from Fin.ext (by + change i.val = d + (i.val - d) + omega), + show (multiStar a c).pairing + (Sum.inr (Fin.natAdd d ⟨i.val - d, by + have := i.isLt + omega⟩)) = + Sum.inl (Fin.natAdd d ⟨i.val - d, by + have := i.isLt + omega⟩) from rfl] + erw [peelFlagEquiv_inl_high d S, + peelFlagEquiv_inr_high d S] + rfl + +/-- **The peel step**, generically: a multi-star whose assignment +splits blockwise is the head vertex star tensored with the tail +multi-star. -/ +noncomputable def multiStarPeel {n : ℕ} (d S c : ℕ) + (rest : Fin S → Fin n) (a : Fin (d + S) → Fin (n + 1)) + (ha_low : ∀ i : Fin d, + a (Fin.castAdd S i) = ⟨0, Nat.succ_pos n⟩) + (ha_high : ∀ j : Fin S, + a (Fin.natAdd d j) = (rest j).succ) : + (multiStar a c).Equiv + ((tensorFragment + ((vertexStar d).relabel (finCongr (by omega : d = 0 + d))) + ((multiStar rest c).relabel (finCongr + (by omega : S = 0 + S)))).relabel + (finCongr (by omega : (0 + 0) + (d + S) = d + S))) where + flagEquiv := peelFlagEquiv d S + vertexEquiv := peelVertexEquiv n + -- ═══════ ATTACHMENT ═══════ + -- Flags below `d` sit on the peeled star, the rest on the + -- remaining ones; each side keeps its own vertex. + attach_comm := by exact multiStarPeel_attach_comm d S c rest a ha_low ha_high + pairing_comm := by exact multiStarPeel_pairing_comm d S c rest a + circles_eq := by + change c = 0 + c + omega + +/-- Circles migrate out of the second tensor factor. -/ +noncomputable def tensorAddCirclesRight {s t u v : ℕ} + (A : Fragment (Fin (s + t))) (B : Fragment (Fin (u + v))) + (c : ℕ) : + (tensorFragment A (addCircles B c)).Equiv + (addCircles (tensorFragment A B) c) where + flagEquiv := _root_.Equiv.refl _ + vertexEquiv := _root_.Equiv.refl _ + attach_comm := fun g => by + rcases g with g | g + · change ((A.attach g).map Sum.inl Sum.inl).map id _ = + (((A.attach g).map Sum.inl Sum.inl).map id _).map + (_root_.Equiv.refl _) id + rcases A.attach g with x | x <;> rfl + · change ((B.attach g).map Sum.inr Sum.inr).map id _ = + (((B.attach g).map Sum.inr Sum.inr).map id _).map + (_root_.Equiv.refl _) id + rcases B.attach g with x | x <;> rfl + pairing_comm := fun g => by + rcases g with g | g <;> rfl + circles_eq := by + change A.circles + (B.circles + c) = + (A.circles + B.circles) + c + omega + +/-- **The block factorization**: a block-sorted multi-star is the +iterated tensor of vertex stars with the circles split off. -/ +noncomputable def multiStarBlocks : + ∀ (ds : List ℕ) (c : ℕ), + (multiStar (blockAssign ds) c).Equiv + (addCircles (starTensor ds) c) + | [], c => multiStarNil c + | d :: ds, c => by + refine (multiStarPeel d ds.sum c (blockAssign ds) + (blockAssign (d :: ds)) + (fun i => dite_eq_left i.isLt) + (fun j => by + have h1 : ¬ ((Fin.natAdd d j : + Fin (d + ds.sum)).val < d) := by + change ¬ (d + j.val < d) + omega + refine (dite_eq_right h1).trans ?_ + refine congrArg Fin.succ + (congrArg (blockAssign ds) (Fin.ext ?_)) + change d + j.val - d = j.val + omega)).trans ?_ + refine (Fragment.Equiv.relabelCongr + (tensorFragmentCongr (Fragment.Equiv.refl _) + (Fragment.Equiv.relabelCongr + (multiStarBlocks ds c) _)) _).trans ?_ + change ((tensorFragment + ((vertexStar d).relabel (finCongr + (by omega : d = 0 + d))) + (addCircles ((starTensor ds).relabel (finCongr + (by omega : ds.sum = 0 + ds.sum))) c)).relabel + (finCongr (by omega : + (0 + 0) + (d + ds.sum) = d + ds.sum))).Equiv + (addCircles (starTensor (d :: ds)) c) + exact Fragment.Equiv.relabelCongr + (tensorAddCirclesRight + ((vertexStar d).relabel (finCongr + (by omega : d = 0 + d))) + ((starTensor ds).relabel (finCongr + (by omega : ds.sum = 0 + ds.sum))) c) _ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPerm.lean new file mode 100644 index 0000000000..0e45e3e0ac --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPerm.lean @@ -0,0 +1,123 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MasterSum + +/-! +# Star coordinate symmetry + +The star vector is permutation-invariant, the inverse transport +intertwines permutations, and hence the star coordinate at a +permuted colouring is the odd-inversion sign times the original. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open Functor.LaxMonoidal Functor.OplaxMonoidal + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} +variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) +variable (e' : P.ω.obj (SkeinObj.mk 1) ⟶ stdSuperPair k ℓ) + +/-- **The star vector is permutation-invariant.** -/ +theorem starVec_perm (d : ℕ) (σ : _root_.Equiv.Perm (Fin d)) : + ((P.ω.map (bundleMapClass f (σ : Fin d ≃ Fin d))) : + SuperVect.Hom _ _).evenMap (starVec f P d) = + starVec f P d := by + refine Eq.trans (omegaVec_comp f P _ _).symm ?_ + exact congrArg (omegaVec f P) (vertexStarClass_perm f d σ) + +/-- **The inverse transport intertwines permutations.** -/ +theorem stdFromOmega_perm + (hee' : (e' ≫ e : P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk 1)) = 𝟙 _) + (he'e : (e ≫ e' : stdSuperPair k ℓ ⟶ stdSuperPair k ℓ) = 𝟙 _) + (d : ℕ) (σ : _root_.Equiv.Perm (Fin d)) : + letI := P.braided + (stdFromOmega f P e' d ≫ modelPermMap σ : + P.ω.obj (SkeinObj.mk d) ⟶ superPow (stdSuperPair k ℓ) d) = + P.ω.map (bundleMapClass f (σ : Fin d ≃ Fin d)) ≫ + stdFromOmega f P e' d := by + let := P.braided + have h1 : modelPermMap (k := k) (ℓ := ℓ) σ = + stdToOmega f P e d ≫ + P.ω.map (bundleMapClass f (σ : Fin d ≃ Fin d)) ≫ + stdFromOmega f P e' d := by + have h2 := congrArg (fun z : + (superPow (stdSuperPair k ℓ) d ⟶ + P.ω.obj (SkeinObj.mk d)) => + z ≫ stdFromOmega f P e' d) + (stdToOmega_bmc_perm_all f P e d σ) + simp only [Category.assoc] at h2 + rw [stdToOmega_stdFromOmega f P e e' he'e d, + Category.comp_id] at h2 + exact h2.symm + rw [h1] + rw [← Category.assoc] + rw [stdFromOmega_stdToOmega f P e e' hee' d] + rw [Category.id_comp] + +-- `rfl`, but the two sides agree only after the +-- transport and the coordinate extraction are unfolded. +/-- The star coordinate is a model coordinate. -/ +theorem starCoord_eq_coordOf (d : ℕ) + (c : MixedColouring k ℓ d) : + starCoord f P e' d c = + coordOf (((stdFromOmega f P e' d) : + SuperVect.Hom _ _).evenMap (starVec f P d)) c := rfl + +-- The symmetry is read through the transport and +-- the colouring equivalence, so the permutation action unfolds on +-- both. +/-- **The star coordinate symmetry**: permuting the colouring +multiplies by the odd-inversion sign. -/ +theorem starCoord_perm + (hee' : (e' ≫ e : P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk 1)) = 𝟙 _) + (he'e : (e ≫ e' : stdSuperPair k ℓ ⟶ stdSuperPair k ℓ) = 𝟙 _) + (d : ℕ) (σ : _root_.Equiv.Perm (Fin d)) + (c : MixedColouring k ℓ d) : + starCoord f P e' d (c ∘ σ) = + (-1 : ℂ) ^ oddInversions σ c * starCoord f P e' d c := by + let := P.braided + have hfix : ((modelPermMap σ) : SuperVect.Hom _ _).evenMap + (((stdFromOmega f P e' d) : + SuperVect.Hom _ _).evenMap (starVec f P d)) = + ((stdFromOmega f P e' d) : + SuperVect.Hom _ _).evenMap (starVec f P d) := by + have h := congrArg (fun z : + (P.ω.obj (SkeinObj.mk d) ⟶ + superPow (stdSuperPair k ℓ) d) => + (z : SuperVect.Hom _ _).evenMap (starVec f P d)) + (stdFromOmega_perm f P e e' hee' he'e d σ) + refine Eq.trans h ?_ + change ((stdFromOmega f P e' d) : + SuperVect.Hom _ _).evenMap + (((P.ω.map (bundleMapClass f + (σ : Fin d ≃ Fin d))) : + SuperVect.Hom _ _).evenMap (starVec f P d)) = _ + rw [starVec_perm f P d σ] + have hcoord := coordOf_modelPermMap' σ + (((stdFromOmega f P e' d) : + SuperVect.Hom _ _).evenMap (starVec f P d)) c + rw [hfix] at hcoord + rw [starCoord_eq_coordOf, starCoord_eq_coordOf] + rw [hcoord] + rw [← mul_assoc] + rw [show ((-1 : ℂ) ^ oddInversions σ c) * + ((-1 : ℂ) ^ oddInversions σ c) = 1 from by + rw [← pow_add] + exact Even.neg_one_pow ⟨oddInversions σ c, rfl⟩] + rw [one_mul] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarRepeat.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarRepeat.lean new file mode 100644 index 0000000000..df0384aea1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarRepeat.lean @@ -0,0 +1,301 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPerm + +/-! +# Fermionic vanishing of star coordinates + +Repeated odd colours kill the star coordinate: the adjacent-swap +inversion count is the both-odd indicator, so a colouring fixed +by an adjacent swap of equal odd colours equals its own negation. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Finset + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} +variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) +variable (e' : P.ω.obj (SkeinObj.mk 1) ⟶ stdSuperPair k ℓ) + +/-- The adjacent swap has exactly the both-odd inversion. -/ +theorem oddInversions_adjacent {n : ℕ} (i : ℕ) + (h2 : i + 1 < n) (c : MixedColouring k ℓ n) : + oddInversions (_root_.Equiv.swap + (⟨i, by omega⟩ : Fin n) ⟨i + 1, h2⟩) c = + (if (c ⟨i, by omega⟩).isRight ∧ + (c ⟨i + 1, h2⟩).isRight then 1 else 0) := by + unfold oddInversions + -- ═══════ BOTH SWAPPED POSITIONS CARRY ODD COLOURS ═══════ + -- Then the swap is an inversion and the count moves by one; + -- otherwise the pair contributes nothing and the count is fixed. + by_cases hodd : (c ⟨i, by omega⟩).isRight ∧ + (c ⟨i + 1, h2⟩).isRight + · rw [ite_eq_left hodd] + rw [show (univ.filter (fun p : Fin n × Fin n => + p.1 < p.2 ∧ _root_.Equiv.swap + (⟨i, by omega⟩ : Fin n) ⟨i + 1, h2⟩ p.1 > + _root_.Equiv.swap + (⟨i, by omega⟩ : Fin n) ⟨i + 1, h2⟩ p.2 ∧ + (c (_root_.Equiv.swap + (⟨i, by omega⟩ : Fin n) ⟨i + 1, h2⟩ p.1)).isRight ∧ + (c (_root_.Equiv.swap + (⟨i, by omega⟩ : Fin n) ⟨i + 1, h2⟩ + p.2)).isRight)) = + {((⟨i, by omega⟩ : Fin n), (⟨i + 1, h2⟩ : Fin n))} + from ?_] + · exact card_singleton _ + ext p + simp only [mem_filter, mem_univ, true_and, mem_singleton] + constructor + · rintro ⟨hlt, hgt, _, _⟩ + by_cases h1 : p.1 = (⟨i, by omega⟩ : Fin n) + · by_cases h2' : p.2 = (⟨i + 1, h2⟩ : Fin n) + · exact Prod.ext_iff.mpr ⟨h1, h2'⟩ + · exfalso + rw [h1, _root_.Equiv.swap_apply_left] at hgt + rw [_root_.Equiv.swap_apply_of_ne_of_ne + (fun hx => by + rw [h1] at hlt + exact absurd (hx ▸ hlt) (lt_irrefl _)) h2'] + at hgt + have hv1 := (Fin.lt_def.mp hgt) + have hv2 := (Fin.lt_def.mp hlt) + rw [h1] at hv2 + simp only [] at hv1 hv2 + omega + · by_cases h2' : p.2 = (⟨i, by omega⟩ : Fin n) + · exfalso + rw [h2', _root_.Equiv.swap_apply_left] at hgt + by_cases h1' : p.1 = (⟨i + 1, h2⟩ : Fin n) + · rw [h1', _root_.Equiv.swap_apply_right] at hgt + have hv1 := Fin.lt_def.mp hgt + have hv2 := Fin.lt_def.mp hlt + rw [h1', h2'] at hv2 + simp only [] at hv1 hv2 + omega + · rw [_root_.Equiv.swap_apply_of_ne_of_ne h1 h1'] + at hgt + have hv1 := Fin.lt_def.mp hgt + have hv2 := Fin.lt_def.mp hlt + rw [h2'] at hv2 + simp only [] at hv1 hv2 + omega + · by_cases h1' : p.1 = (⟨i + 1, h2⟩ : Fin n) + · exfalso + rw [h1', _root_.Equiv.swap_apply_right] at hgt + by_cases h2'' : p.2 = (⟨i + 1, h2⟩ : Fin n) + · rw [h1', h2''] at hlt + exact absurd hlt (lt_irrefl _) + · rw [_root_.Equiv.swap_apply_of_ne_of_ne h2' + h2''] at hgt + have hv1 := Fin.lt_def.mp hgt + have hv2 := Fin.lt_def.mp hlt + rw [h1'] at hv2 + simp only [] at hv1 hv2 + omega + · exfalso + by_cases h2'' : p.2 = (⟨i + 1, h2⟩ : Fin n) + · rw [h2'', _root_.Equiv.swap_apply_right] at hgt + rw [_root_.Equiv.swap_apply_of_ne_of_ne h1 h1'] + at hgt + have hv1 := Fin.lt_def.mp hgt + have hv2 := Fin.lt_def.mp hlt + rw [h2''] at hv2 + simp only [] at hv1 hv2 + omega + · rw [_root_.Equiv.swap_apply_of_ne_of_ne h1 h1', + _root_.Equiv.swap_apply_of_ne_of_ne h2' + h2''] at hgt + exact absurd hlt (not_lt.mpr (le_of_lt hgt)) + · intro hp + rw [hp] + refine ⟨Fin.lt_def.mpr (by + change i < i + 1; omega), ?_, ?_, ?_⟩ + · rw [_root_.Equiv.swap_apply_left, + _root_.Equiv.swap_apply_right] + exact Fin.lt_def.mpr (by + change i < i + 1; omega) + · rw [_root_.Equiv.swap_apply_left] + exact hodd.2 + · rw [_root_.Equiv.swap_apply_right] + exact hodd.1 + · rw [ite_eq_right hodd] + rw [Finset.card_eq_zero, Finset.filter_eq_empty_iff] + rintro p _ ⟨hlt, hgt, ho1, ho2⟩ + refine hodd ?_ + by_cases h1 : p.1 = (⟨i, by omega⟩ : Fin n) + · by_cases h2' : p.2 = (⟨i + 1, h2⟩ : Fin n) + · rw [h1, _root_.Equiv.swap_apply_left] at ho1 + rw [h2', _root_.Equiv.swap_apply_right] at ho2 + exact ⟨ho2, ho1⟩ + · exfalso + rw [h1, _root_.Equiv.swap_apply_left] at hgt + rw [_root_.Equiv.swap_apply_of_ne_of_ne + (fun hx => by + rw [h1] at hlt + exact absurd (hx ▸ hlt) (lt_irrefl _)) h2'] + at hgt + have hv1 := Fin.lt_def.mp hgt + have hv2 := Fin.lt_def.mp hlt + rw [h1] at hv2 + simp only [] at hv1 hv2 + omega + · exfalso + by_cases h2' : p.2 = (⟨i, by omega⟩ : Fin n) + · rw [h2', _root_.Equiv.swap_apply_left] at hgt + by_cases h1' : p.1 = (⟨i + 1, h2⟩ : Fin n) + · rw [h1', _root_.Equiv.swap_apply_right] at hgt + have hv1 := Fin.lt_def.mp hgt + have hv2 := Fin.lt_def.mp hlt + rw [h1', h2'] at hv2 + simp only [] at hv1 hv2 + omega + · rw [_root_.Equiv.swap_apply_of_ne_of_ne h1 h1'] + at hgt + have hv1 := Fin.lt_def.mp hgt + have hv2 := Fin.lt_def.mp hlt + rw [h2'] at hv2 + simp only [] at hv1 hv2 + omega + · by_cases h1' : p.1 = (⟨i + 1, h2⟩ : Fin n) + · rw [h1', _root_.Equiv.swap_apply_right] at hgt + by_cases h2'' : p.2 = (⟨i + 1, h2⟩ : Fin n) + · rw [h1', h2''] at hlt + exact absurd hlt (lt_irrefl _) + · rw [_root_.Equiv.swap_apply_of_ne_of_ne h2' + h2''] at hgt + have hv1 := Fin.lt_def.mp hgt + have hv2 := Fin.lt_def.mp hlt + rw [h1'] at hv2 + simp only [] at hv1 hv2 + omega + · by_cases h2'' : p.2 = (⟨i + 1, h2⟩ : Fin n) + · rw [h2'', _root_.Equiv.swap_apply_right] at hgt + rw [_root_.Equiv.swap_apply_of_ne_of_ne h1 h1'] + at hgt + have hv1 := Fin.lt_def.mp hgt + have hv2 := Fin.lt_def.mp hlt + rw [h2''] at hv2 + simp only [] at hv1 hv2 + omega + · rw [_root_.Equiv.swap_apply_of_ne_of_ne h1 h1', + _root_.Equiv.swap_apply_of_ne_of_ne h2' h2''] + at hgt + exact absurd hlt (not_lt.mpr (le_of_lt hgt)) + +/-- **Adjacent equal odd colours kill the star coordinate.** -/ +theorem starCoord_adjacent_repeat + (hee' : (e' ≫ e : P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk 1)) = 𝟙 _) + (he'e : (e ≫ e' : stdSuperPair k ℓ ⟶ stdSuperPair k ℓ) = 𝟙 _) + {d : ℕ} (i : ℕ) (h2 : i + 1 < d) + (c : MixedColouring k ℓ d) + (hodd : (c ⟨i, by omega⟩).isRight) + (heq : c ⟨i, by omega⟩ = c ⟨i + 1, h2⟩) : + starCoord f P e' d c = 0 := by + have hfix : c ∘ _root_.Equiv.swap + (⟨i, by omega⟩ : Fin d) ⟨i + 1, h2⟩ = c := by + funext x + change c (_root_.Equiv.swap _ _ x) = c x + by_cases hx1 : x = (⟨i, by omega⟩ : Fin d) + · rw [hx1, _root_.Equiv.swap_apply_left] + exact heq.symm + · by_cases hx2 : x = (⟨i + 1, h2⟩ : Fin d) + · rw [hx2, _root_.Equiv.swap_apply_right] + exact heq + · rw [_root_.Equiv.swap_apply_of_ne_of_ne hx1 hx2] + have hperm := starCoord_perm f P e e' hee' he'e d + (_root_.Equiv.swap (⟨i, by omega⟩ : Fin d) + ⟨i + 1, h2⟩) c + rw [hfix] at hperm + rw [oddInversions_adjacent i h2 c] at hperm + rw [ite_eq_left ⟨hodd, heq ▸ hodd⟩] at hperm + rw [pow_one] at hperm + have h2x : starCoord f P e' d c = + -(starCoord f P e' d c) := by + rw [neg_one_mul] at hperm + exact hperm + exact CharZero.eq_neg_self_iff.mp h2x + +/-- **Repeated odd colours kill the star coordinate.** -/ +theorem starCoord_repeat_zero + (hee' : (e' ≫ e : P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk 1)) = 𝟙 _) + (he'e : (e ≫ e' : stdSuperPair k ℓ ⟶ stdSuperPair k ℓ) = 𝟙 _) + {d : ℕ} (c : MixedColouring k ℓ d) (i j : Fin d) + (hij : i.val < j.val) + (hodd : (c i).isRight) (heq : c i = c j) : + starCoord f P e' d c = 0 := by + obtain ⟨gap, hgap⟩ : ∃ gap, j.val = i.val + 1 + gap := + ⟨j.val - i.val - 1, by omega⟩ + revert hgap + induction gap generalizing c i j with + | zero => + intro hgap + have hb : i.val + 1 < d := by have := j.isLt; omega + have hbj : (⟨i.val + 1, hb⟩ : Fin d) = j := + Fin.ext (by change i.val + 1 = j.val; omega) + refine starCoord_adjacent_repeat f P e e' hee' he'e + i.val hb c + (show (c ⟨i.val, by omega⟩).isRight from by + rw [show (⟨i.val, by omega⟩ : Fin d) = i from + Fin.ext rfl] + exact hodd) ?_ + rw [show (⟨i.val, by omega⟩ : Fin d) = i from + Fin.ext rfl] + rw [hbj] + exact heq + | succ gap ih => + intro hgap + -- Swap positions j-1 and j to shorten the gap. + have hj1 : j.val - 1 + 1 < d := by + have := j.isLt; omega + set σ := _root_.Equiv.swap + (⟨j.val - 1, by omega⟩ : Fin d) ⟨j.val - 1 + 1, hj1⟩ + with hσ + have hperm := starCoord_perm f P e e' hee' he'e d σ c + have hc' : starCoord f P e' d (c ∘ σ) = 0 := by + have hb1 : i.val < j.val - 1 := by omega + have hb2 : j.val - 1 = i.val + 1 + gap := by omega + have hb3 : j.val - 1 < d := by + have := j.isLt; omega + have hbj : (⟨j.val - 1 + 1, hj1⟩ : Fin d) = j := + Fin.ext (by change j.val - 1 + 1 = j.val; omega) + refine ih (c ∘ σ) i ⟨j.val - 1, hb3⟩ hb1 ?_ ?_ hb2 + · change (c (σ i)).isRight + rw [show σ i = i from + _root_.Equiv.swap_apply_of_ne_of_ne + (Fin.ne_of_val_ne (by + change i.val ≠ j.val - 1; omega)) + (Fin.ne_of_val_ne (by + change i.val ≠ j.val - 1 + 1; omega))] + exact hodd + · change c (σ i) = c (σ ⟨j.val - 1, by omega⟩) + rw [show σ i = i from + _root_.Equiv.swap_apply_of_ne_of_ne + (Fin.ne_of_val_ne (by + change i.val ≠ j.val - 1; omega)) + (Fin.ne_of_val_ne (by + change i.val ≠ j.val - 1 + 1; omega))] + rw [show σ ⟨j.val - 1, by + have := j.isLt; omega⟩ = + ⟨j.val - 1 + 1, hj1⟩ from + _root_.Equiv.swap_apply_left _ _] + rw [hbj] + exact heq + rw [hc'] at hperm + exact (mul_eq_zero.mp hperm.symm).resolve_left + (pow_ne_zero _ (by norm_num)) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarSymm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarSymm.lean new file mode 100644 index 0000000000..27134de5cb --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarSymm.lean @@ -0,0 +1,60 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPerm + +/-! +# Symmetry of the vertex star + +All legs of a vertex star meet the same vertex, so any boundary +permutation is absorbed: the star class is symmetric. This is +the S_d-invariance that makes the vertex coordinates well +defined on multiset data. +-/ + +@[expose] public section + +namespace RS + +/-- The vertex star absorbs any boundary relabelling. -/ +noncomputable def vertexStarRelabelEquiv (d : ℕ) + (σ : Fin d ≃ Fin d) : + ((vertexStar d).relabel σ).Equiv (vertexStar d) where + flagEquiv := _root_.Equiv.sumCongr σ σ + vertexEquiv := _root_.Equiv.refl Unit + attach_comm := fun g => by + rcases g with i | i <;> rfl + pairing_comm := fun g => by + rcases g with i | i <;> rfl + circles_eq := rfl + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- **S_d-invariance of the vertex star class**: composing with +any permutation bundle map is absorbed. -/ +theorem vertexStarClass_perm (d : ℕ) (σ : Fin d ≃ Fin d) : + HomSpace.comp f 0 d d (vertexStarClass f d) + (bundleMapClass f σ) = vertexStarClass f d := by + rw [show vertexStarClass f d = HomSpace.ofFragment f.val + ((vertexStar d).relabel (finCongr + (by omega : d = 0 + d))) from rfl, + comp_bundleMapClass] + refine HomSpace.ofFragment_congr f ?_ + refine (Fragment.Equiv.relabelTrans _ _ _).trans ?_ + refine (Fragment.Equiv.relabelEq _ (show + (finCongr (by omega : d = 0 + d)).trans + (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin 0)) + σ).trans finSumFinEquiv)) = + σ.trans (finCongr (by omega : d = 0 + d)) from + sort_transport_eq σ)).trans ?_ + refine ((Fragment.Equiv.relabelTrans _ _ _).symm).trans ?_ + exact Fragment.Equiv.relabelCongr + (vertexStarRelabelEquiv d σ) _ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarTensorClass.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarTensorClass.lean new file mode 100644 index 0000000000..27ce6170ad --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarTensorClass.lean @@ -0,0 +1,75 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarClassFactor + +/-! +# The star-tensor class and its recursion + +The iterated vertex-star tensor as a Hom class, with its +defining recursion at class level: the cons case is the monoidal +tensor of the vertex-star class with the tail, composed with the +sum cast. +-/ + +@[expose] public section + +namespace RS + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The vertex-star class: a `(0, d)`-morphism. -/ +noncomputable def vertexStarClass (d : ℕ) : + HomSpace f.val (0 + d) := + HomSpace.ofFragment f.val + ((vertexStar d).relabel (finCongr (by omega : d = 0 + d))) + +/-- The star-tensor class over a degree list. -/ +noncomputable def starTensorClass (ds : List ℕ) : + HomSpace f.val (0 + ds.sum) := + HomSpace.ofFragment f.val + ((starTensor ds).relabel (finCongr + (by omega : ds.sum = 0 + ds.sum))) + +/-- The empty star tensor is the empty class. -/ +theorem starTensorClass_nil : + starTensorClass f [] = + HomSpace.ofFragment f.val emptyClosedFragment := + HomSpace.ofFragment_congr f + (relabelZeroEquiv (starTensor []) _) + +/-- **The class recursion**: the star tensor over a cons is the +tensor of the head vertex-star class with the tail class, +composed with the sum cast. -/ +theorem starTensorClass_cons (d : ℕ) (ds : List ℕ) : + starTensorClass f (d :: ds) = + HomSpace.comp f 0 (d + ds.sum) ((d :: ds).sum) + (HomSpace.tensor f 0 d 0 ds.sum + (vertexStarClass f d) (starTensorClass f ds)) + (bundleMapClass f (finCongr + (List.sum_cons.symm : d + ds.sum = (d :: ds).sum))) := by + simp only [vertexStarClass, starTensorClass] + rw [HomSpace.tensor_ofFragment, comp_bundleMapClass, + outTransport_finCongr] + exact HomSpace.ofFragment_congr f + ((Fragment.Equiv.relabelTrans _ _ _).trans + (Fragment.Equiv.relabelEq _ + (_root_.Equiv.ext (fun x => Fin.ext rfl)))) + +/-- The class-level star factorization, in terms of the +star-tensor class. -/ +theorem starClass_factor' (W : ClosedFragment) : + starClass f W = circleVal f ^ W.circles • + HomSpace.comp f 0 ((degList (starAssignEnum W)).sum) + (edgeCount W + edgeCount W) + (starTensorClass f (degList (starAssignEnum W))) + (bundleMapClass f + (sortEquiv (starAssignEnum W)).symm) := + starClass_factor f W + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StdTransport.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StdTransport.lean new file mode 100644 index 0000000000..ad2ebda2ef --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StdTransport.lean @@ -0,0 +1,140 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaStarVec +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPower + +/-! +# The model transport + +Given the strand identification of the standard model, the +iterated identification of the monoidal powers: `stdToOmega` +assembles copies of the strand map left-nested through the +structure maps of the fibre functor, `stdFromOmega` disassembles, +and the two are mutually inverse whenever the strand maps are. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Functor.LaxMonoidal Functor.OplaxMonoidal +open MonoidalCategory + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} + +section Transport + +variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) +variable (e' : P.ω.obj (SkeinObj.mk 1) ⟶ stdSuperPair k ℓ) + +/-- The model transport: iterated strand identifications +assembled left-nested through the structure maps. -/ +noncomputable def stdToOmega : + (m : ℕ) → (superPow (stdSuperPair k ℓ) m ⟶ + P.ω.obj (SkeinObj.mk m)) + | 0 => + letI := P.braided + (ε P.ω : SuperVect.tensorUnit ⟶ P.ω.obj (SkeinObj.mk 0)) + | m + 1 => + letI := P.braided + ((stdToOmega m ⊗ₘ e) ≫ + (μ P.ω (SkeinObj.mk m) (SkeinObj.mk 1) : + P.ω.obj (SkeinObj.mk m) ⊗ P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk (m + 1)))) + +/-- The reverse model transport. -/ +noncomputable def stdFromOmega : + (m : ℕ) → (P.ω.obj (SkeinObj.mk m) ⟶ + superPow (stdSuperPair k ℓ) m) + | 0 => + letI := P.braided + (η P.ω : P.ω.obj (SkeinObj.mk 0) ⟶ SuperVect.tensorUnit) + | m + 1 => + letI := P.braided + ((δ P.ω (SkeinObj.mk m) (SkeinObj.mk 1) : + P.ω.obj (SkeinObj.mk (m + 1)) ⟶ + P.ω.obj (SkeinObj.mk m) ⊗ P.ω.obj (SkeinObj.mk 1)) ≫ + (stdFromOmega m ⊗ₘ e')) + +/-- The transports are inverse on the fibre side. -/ +theorem stdFromOmega_stdToOmega + (hee' : (e' ≫ e : P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk 1)) = 𝟙 _) : + ∀ m : ℕ, + (stdFromOmega f P e' m ≫ stdToOmega f P e m : + P.ω.obj (SkeinObj.mk m) ⟶ P.ω.obj (SkeinObj.mk m)) = + 𝟙 (P.ω.obj (SkeinObj.mk m)) + | 0 => by + let := P.braided + change (η P.ω ≫ ε P.ω : P.ω.obj (SkeinObj.mk 0) ⟶ + P.ω.obj (SkeinObj.mk 0)) = 𝟙 _ + exact Functor.Monoidal.η_ε P.ω + | m + 1 => by + let := P.braided + change (δ P.ω (SkeinObj.mk m) (SkeinObj.mk 1) ≫ + (stdFromOmega f P e' m ⊗ₘ e')) ≫ + ((stdToOmega f P e m ⊗ₘ e) ≫ + (μ P.ω (SkeinObj.mk m) (SkeinObj.mk 1) : + P.ω.obj (SkeinObj.mk m) ⊗ P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk (m + 1)))) = 𝟙 _ + simp only [Category.assoc] + rw [← Category.assoc (stdFromOmega f P e' m ⊗ₘ e')] + rw [MonoidalCategory.tensorHom_comp_tensorHom] + rw [stdFromOmega_stdToOmega hee' m, hee'] + rw [MonoidalCategory.id_tensorHom_id] + rw [Category.id_comp] + exact Functor.Monoidal.δ_μ P.ω (SkeinObj.mk m) + (SkeinObj.mk 1) + +/-- The transports are inverse on the model side. -/ +theorem stdToOmega_stdFromOmega + (he'e : (e ≫ e' : stdSuperPair k ℓ ⟶ stdSuperPair k ℓ) = 𝟙 _) : + ∀ m : ℕ, + (stdToOmega f P e m ≫ stdFromOmega f P e' m : + superPow (stdSuperPair k ℓ) m ⟶ + superPow (stdSuperPair k ℓ) m) = + 𝟙 (superPow (stdSuperPair k ℓ) m) + | 0 => by + let := P.braided + change (ε P.ω ≫ η P.ω : SuperVect.tensorUnit ⟶ + SuperVect.tensorUnit) = 𝟙 _ + exact Functor.Monoidal.ε_η P.ω + | m + 1 => by + let := P.braided + change ((stdToOmega f P e m ⊗ₘ e) ≫ + (μ P.ω (SkeinObj.mk m) (SkeinObj.mk 1) : + P.ω.obj (SkeinObj.mk m) ⊗ P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk (m + 1)))) ≫ + (δ P.ω (SkeinObj.mk m) (SkeinObj.mk 1) ≫ + (stdFromOmega f P e' m ⊗ₘ e')) = 𝟙 _ + simp only [Category.assoc] + rw [show (μ P.ω (SkeinObj.mk m) (SkeinObj.mk 1) : + P.ω.obj (SkeinObj.mk m) ⊗ P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk (m + 1))) ≫ + (δ P.ω (SkeinObj.mk m) (SkeinObj.mk 1) ≫ + (stdFromOmega f P e' m ⊗ₘ e')) = + 𝟙 (P.ω.obj (SkeinObj.mk m) ⊗ P.ω.obj (SkeinObj.mk 1)) ≫ + (stdFromOmega f P e' m ⊗ₘ e') from by + rw [← Category.assoc] + rw [show (μ P.ω (SkeinObj.mk m) (SkeinObj.mk 1) : + P.ω.obj (SkeinObj.mk m) ⊗ P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk (m + 1))) ≫ + δ P.ω (SkeinObj.mk m) (SkeinObj.mk 1) = 𝟙 _ from + Functor.Monoidal.μ_δ P.ω (SkeinObj.mk m) + (SkeinObj.mk 1)]] + rw [Category.id_comp] + rw [MonoidalCategory.tensorHom_comp_tensorHom] + rw [stdToOmega_stdFromOmega he'e m, he'e] + exact MonoidalCategory.id_tensorHom_id _ _ + +end Transport + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StrandTransport.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StrandTransport.lean new file mode 100644 index 0000000000..b3a3f9d247 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StrandTransport.lean @@ -0,0 +1,120 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvFormOdd + +/-! +# The one-strand transport collapse + +The transport at one strand is the left-unitor composite of the +strand identification: the counit-tensor coherence with the +strict skein unitor eliminated. Its even and odd evaluations on +unit-padded vectors are the strand identification itself. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory +open Functor.LaxMonoidal Functor.OplaxMonoidal +open scoped TensorProduct + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} +variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) + +/-- **The one-strand transport is the unitor composite.** -/ +theorem stdToOmega_one : + letI := P.braided + stdToOmega f P e 1 = + (SuperVect.tensorUnit ◁ e) ≫ + (λ_ (P.ω.obj (SkeinObj.mk 1))).hom := by + let := P.braided + change (stdToOmega f P e 0 ⊗ₘ e) ≫ + μ P.ω (SkeinObj.mk 0) (SkeinObj.mk 1) = _ + have h := Functor.LaxMonoidal.ε_tensorHom_comp_μ + (F := P.ω) (X := SkeinObj.mk 1) e + rw [show (λ_ (SkeinObj.mk 1 : SkeinObj f)).inv = + 𝟙 (SkeinObj.mk 1) from by + change bundleMapClass f (finCongr _) = _ + rw [show (finCongr (show (1 : ℕ) = 0 + 1 by omega) : + Fin 1 ≃ Fin 1) = _root_.Equiv.refl (Fin 1) from + _root_.Equiv.ext (fun x => Fin.ext rfl)] + exact bundleMapClass_refl f 1] at h + rw [show P.ω.map (𝟙 (SkeinObj.mk 1 : SkeinObj f)) = + 𝟙 (P.ω.obj (SkeinObj.mk 1)) from P.ω.map_id _] at h + rw [Category.comp_id] at h + exact h + +-- The one-strand transport is unfolded through the +-- tensorator and the left unitor. +/-- The even evaluation of the one-strand transport on a +unit-padded even vector. -/ +theorem stdToOmega_one_even (x : (stdSuperPair k ℓ).even) : + letI := P.braided + ((stdToOmega f P e 1) : SuperVect.Hom _ _).evenMap + (evenPair (1 : ℂ) x) = + (e : SuperVect.Hom _ _).evenMap x := by + let := P.braided + rw [stdToOmega_one] + change (((λ_ (P.ω.obj (SkeinObj.mk 1))).hom : + SuperVect.tensorObj SuperVect.tensorUnit + (P.ω.obj (SkeinObj.mk 1)) ⟶ + P.ω.obj (SkeinObj.mk 1)) : SuperVect.Hom _ _).evenMap + ((SuperVect.tensorHom (SuperVect.Hom.id _) e).evenMap + (evenPair (1 : ℂ) x)) = _ + rw [show (SuperVect.tensorHom + (SuperVect.Hom.id (𝟙_ SuperVect)) e).evenMap + (evenPair (1 : ℂ) x) = + evenPair (1 : ℂ) ((e : SuperVect.Hom _ _).evenMap x) from by + change ((TensorProduct.map LinearMap.id + (e : SuperVect.Hom _ _).evenMap) ((1 : ℂ) ⊗ₜ[ℂ] x), + (TensorProduct.map + (SuperVect.Hom.id (𝟙_ SuperVect)).oddMap + (e : SuperVect.Hom _ _).oddMap) 0) = _ + rw [TensorProduct.map_tmul, map_zero] + rfl] + exact (TensorProduct.lid_tmul _ _).trans (one_smul _ _) + +/-- The unit-padded odd element. -/ +def oddUnitPad {V : SuperVect} (y : V.odd) : + (SuperVect.tensorObj SuperVect.tensorUnit V).odd := + ((1 : ℂ) ⊗ₜ[ℂ] y, 0) + +-- As for the even component, on the odd half. +/-- The odd evaluation of the one-strand transport on a +unit-padded odd vector. -/ +theorem stdToOmega_one_odd (y : (stdSuperPair k ℓ).odd) : + letI := P.braided + ((stdToOmega f P e 1) : SuperVect.Hom _ _).oddMap + (oddUnitPad y) = + (e : SuperVect.Hom _ _).oddMap y := by + let := P.braided + rw [stdToOmega_one] + change (((λ_ (P.ω.obj (SkeinObj.mk 1))).hom : + SuperVect.tensorObj SuperVect.tensorUnit + (P.ω.obj (SkeinObj.mk 1)) ⟶ + P.ω.obj (SkeinObj.mk 1)) : SuperVect.Hom _ _).oddMap + ((SuperVect.tensorHom (SuperVect.Hom.id _) e).oddMap + (oddUnitPad y)) = _ + rw [show (SuperVect.tensorHom + (SuperVect.Hom.id (𝟙_ SuperVect)) e).oddMap + (oddUnitPad y) = + oddUnitPad ((e : SuperVect.Hom _ _).oddMap y) from by + change ((TensorProduct.map LinearMap.id + (e : SuperVect.Hom _ _).oddMap) ((1 : ℂ) ⊗ₜ[ℂ] y), + (TensorProduct.map + (SuperVect.Hom.id (𝟙_ SuperVect)).oddMap + (e : SuperVect.Hom _ _).evenMap) 0) = _ + rw [TensorProduct.map_tmul, map_zero] + rfl] + exact (TensorProduct.lid_tmul _ _).trans (one_smul _ _) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauCount.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauCount.lean new file mode 100644 index 0000000000..df5b6599df --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauCount.lean @@ -0,0 +1,81 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockData +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddListMultiset + +/-! +# Tau-sign counting lemmas + +Combinatorial lemmas connecting the tau-sign product over vertices +to the number of outgoing flags, via the incoming/outgoing partition. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {k ℓ : ℕ} (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) (φ : F.OddColouring ℓ) + +/-! ### Incoming and outgoing flags are equinumerous -/ + +/-- The match bijection gives equal cardinalities of incoming +and outgoing flags. -/ +theorem card_in_eq_card_out : + (F.flags.filter (fun f => o.isOut f = false)).card = + (F.flags.filter (fun f => o.isOut f = true)).card := by + apply Finset.card_bij (fun f hf => κ.match_ f) + -- maps into target + · intro f hf + rw [Finset.mem_filter] at hf ⊢ + exact ⟨κ.match_mem f hf.1, + by rw [o.match_flip f hf.1, hf.2]; rfl⟩ + -- injective + · intro f₁ hf₁ f₂ hf₂ heq + have h1 := κ.match_invol f₁ (Finset.mem_filter.mp hf₁).1 + have h2 := κ.match_invol f₂ (Finset.mem_filter.mp hf₂).1 + calc f₁ = κ.match_ (κ.match_ f₁) := h1.symm + _ = κ.match_ (κ.match_ f₂) := by rw [heq] + _ = f₂ := h2 + -- surjective + · intro g hg + rw [Finset.mem_filter] at hg + refine ⟨κ.match_ g, ?_, κ.match_invol g hg.1⟩ + rw [Finset.mem_filter] + exact ⟨κ.match_mem g hg.1, + by rw [o.match_flip g hg.1, hg.2]; rfl⟩ + +/-! ### The out-count as a `Fintype.card` -/ + +/-- The outgoing-flag filter cardinality equals the Fintype.card +of the corresponding subtype. -/ +theorem card_out_eq_fintype : + (F.flags.filter (fun f => o.isOut f = true)).card = + Fintype.card {f : {g : W.Flag // g ∈ F.flags} // o.isOut f.val = true} := by + rw [Fintype.card_subtype] + -- RHS is #(univ.filter (fun f : {g // g ∈ F.flags} => o.isOut f.val = true)) + -- We build a bijection between the two finsets. + apply Finset.card_bij + (fun f (hf : f ∈ F.flags.filter (fun f => o.isOut f = true)) => + (⟨f, (Finset.mem_filter.mp hf).1⟩ : {g : W.Flag // g ∈ F.flags})) + -- maps into + · intro f hf + rw [Finset.mem_filter] + exact ⟨Finset.mem_univ _, (Finset.mem_filter.mp hf).2⟩ + -- injective + · intro f₁ _ f₂ _ h + exact congrArg Subtype.val h + -- surjective + · intro ⟨g, hg⟩ hb + rw [Finset.mem_filter] at hb + exact ⟨g, Finset.mem_filter.mpr ⟨hg, hb.2⟩, rfl⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauKey.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauKey.lean new file mode 100644 index 0000000000..33b17757c1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauKey.lean @@ -0,0 +1,117 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FlagEnum +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.IndexPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockAlign + +/-! +# The sorted-position key + +The block enumeration is sorted under the sigma-position key, so +the canonical index permutation's sign is the key-sortSign of the +pair enumeration alone. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {k ℓ : ℕ} + +/-- The sorted-position key of a flag. -/ +noncomputable def sortKey (W : ClosedFragment) (f : W.Flag) : + Fin (ds W).sum := + sortEquiv (starAssignEnum W) (starFlagEnum W f) + +/-- The key is injective. -/ +theorem sortKey_injective (W : ClosedFragment) : + Function.Injective (sortKey W) := fun _ _ h => + (starFlagEnum W).injective + ((sortEquiv (starAssignEnum W)).injective h) + +/-- The key of a block flag is its sigma position. -/ +theorem sortKey_blockFlag (W : ClosedFragment) + (v : Fin (ds W).length) (j : Fin ((ds W).get v)) : + sortKey W (blockFlag W v j) = + blockSigmaEquiv (ds W) ⟨v, j⟩ := by + rw [sortKey, starFlagEnum_blockFlag] + exact _root_.Equiv.apply_symm_apply _ _ + +open Classical in +/-- The block enumeration is sorted under the key. -/ +theorem blockOddFlagList_key_sorted (W : ClosedFragment) + (F : EdgeSubset W) (v : Fin (ds W).length) : + List.Pairwise (· ≤ ·) + ((blockOddFlagList W F v).map + (fun f => sortKey W f.val)) := by + have hgen : ∀ (l : List (Fin ((ds W).get v))) + (H : ∀ j ∈ l, j ∈ oddSlots W F v), + (l.pmap (fun j hj => (⟨blockFlag W v j, + (mem_oddSlots j).mp hj⟩ : + {f : W.Flag // f ∈ F.flags})) H).map + (fun f => sortKey W f.val) = + l.map (fun j => sortKey W (blockFlag W v j)) := by + intro l + induction l with + | nil => intro H; rfl + | cons a t ih => + intro H + rw [List.pmap_cons, List.map_cons, List.map_cons, ih] + rw [blockOddFlagList, hgen] + have hsorted := Finset.pairwise_sort + (r := (· ≤ ·)) (s := oddSlots W F v) + refine List.Pairwise.map _ ?_ hsorted + intro a b hab + rw [sortKey_blockFlag, sortKey_blockFlag] + rcases lt_or_eq_of_le hab with hlt | heq + · exact le_of_lt (blockSigmaEquiv_strictMono (ds W) v hlt) + · rw [heq] + +open Classical in +/-- The enumerations have equal length. -/ +theorem blockOddFlagList_length_eq (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) (v : Fin (ds W).length) : + (blockOddFlagList W F v).length = + (pairFlagList (F := F) o (blockVertex W v)).length := + length_eq_of_nodup_mem _ _ (blockOddFlagList_nodup W F v) + (pairFlagList_nodup o (blockVertex W v)) + (mem_blockOddFlagList_iff_pairFlagList W F o v) + +open Classical in +/-- **The per-vertex reindexing sign is the key-sortSign of the +pair enumeration.** -/ +theorem sortSign_pairFlagList_key (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) (v : Fin (ds W).length) : + sortSign ((pairFlagList (F := F) o + (blockVertex W v)).map (fun f => sortKey W f.val)) = + (Equiv.Perm.sign (listIndexPerm + (blockOddFlagList W F v) + (pairFlagList (F := F) o (blockVertex W v)) + (blockOddFlagList_nodup W F v) + (pairFlagList_nodup o (blockVertex W v)) + (mem_blockOddFlagList_iff_pairFlagList W F o v) + (blockOddFlagList_length_eq W F o v)) : ℤ) := by + rw [sortSign_map_listIndexPerm (blockOddFlagList W F v) + (pairFlagList (F := F) o (blockVertex W v)) + (blockOddFlagList_nodup W F v) + (pairFlagList_nodup o (blockVertex W v)) + (mem_blockOddFlagList_iff_pairFlagList W F o v) + (blockOddFlagList_length_eq W F o v) + (fun f => sortKey W f.val) + (List.Nodup.map + (fun a b h => Subtype.ext (sortKey_injective W h)) + (blockOddFlagList_nodup W F v))] + rw [sortSign_eq_one_of_sorted _ + (blockOddFlagList_key_sorted W F v), mul_one] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TopBraidMerge.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TopBraidMerge.lean new file mode 100644 index 0000000000..1ca99a9c74 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TopBraidMerge.lean @@ -0,0 +1,149 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PowMerge + +/-! +# The top braiding through the merge + +The braiding of the last two strands commutes with the block +merge: whiskering the two-strand braid inside the last block and +merging equals merging and braiding on top. Abstract braided +coherence first, instantiated to the powers. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +section Abstract + +variable {C : Type*} + +/-- The two-strand top braid over a prefix. -/ +private def topB [Category C] [MonoidalCategory C] [BraidedCategory C] + (X V : C) : (X ⊗ V) ⊗ V ⟶ (X ⊗ V) ⊗ V := + (α_ X V V).hom ≫ (X ◁ (β_ V V).hom) ≫ (α_ X V V).inv + +/-- Braiding the last two strands is natural in the prefix. -/ +private theorem topB_natural + [Category C] [MonoidalCategory C] [BraidedCategory C] + {X Y : C} (V : C) (r : X ⟶ Y) : + ((r ▷ V) ▷ V) ≫ topB Y V = topB X V ≫ ((r ▷ V) ▷ V) := by + unfold topB + simp only [Category.assoc] + rw [associator_naturality_left_assoc, ← whisker_exchange_assoc, + associator_inv_naturality_left] + +-- The exchange is a coherence computation in an +-- arbitrary monoidal category, so both associators are unfolded. +/-- **The abstract merge-braid exchange**: whiskering the braid +inside the last two-strand block and merging equals merging and +braiding on top. -/ +private theorem whisker_topB_merge + [Category C] [MonoidalCategory C] [BraidedCategory C] + (A B V : C) {D : C} + (r : A ⊗ B ⟶ D) : + (A ◁ topB B V) ≫ + (α_ A (B ⊗ V) V).inv ≫ + (((α_ A B V).inv ≫ (r ▷ V)) ▷ V) = + ((α_ A (B ⊗ V) V).inv ≫ + (((α_ A B V).inv ≫ (r ▷ V)) ▷ V)) ≫ topB D V := by + have hβ : A ◁ (B ◁ (β_ V V).hom) = + (α_ A B (V ⊗ V)).inv ≫ ((A ⊗ B) ◁ (β_ V V).hom) ≫ + (α_ A B (V ⊗ V)).hom := by + have h := associator_inv_naturality_right A B (β_ V V).hom + calc A ◁ (B ◁ (β_ V V).hom) + = (A ◁ (B ◁ (β_ V V).hom) ≫ + (α_ A B (V ⊗ V)).inv) ≫ (α_ A B (V ⊗ V)).hom := by + rw [Category.assoc, Iso.inv_hom_id, Category.comp_id] + _ = ((α_ A B (V ⊗ V)).inv ≫ + ((A ⊗ B) ◁ (β_ V V).hom)) ≫ + (α_ A B (V ⊗ V)).hom := by rw [h] + _ = (α_ A B (V ⊗ V)).inv ≫ ((A ⊗ B) ◁ (β_ V V).hom) ≫ + (α_ A B (V ⊗ V)).hom := Category.assoc _ _ _ + have hpre : (A ◁ (α_ B V V).hom) ≫ (α_ A B (V ⊗ V)).inv = + (α_ A (B ⊗ V) V).inv ≫ ((α_ A B V).inv ▷ V) ≫ + (α_ (A ⊗ B) V V).hom := by + monoidal + have hpost : (α_ A B (V ⊗ V)).hom ≫ (A ◁ (α_ B V V).inv) ≫ + (α_ A (B ⊗ V) V).inv ≫ ((α_ A B V).inv ▷ V) = + (α_ (A ⊗ B) V V).inv := by + monoidal + have hnat := topB_natural (X := A ⊗ B) (Y := D) V r + unfold topB at hnat ⊢ + simp only [MonoidalCategory.whiskerLeft_comp, + comp_whiskerRight, Category.assoc] at hnat ⊢ + rw [hβ] + simp only [Category.assoc] + rw [hnat] + slice_lhs 1 2 => rw [hpre] + slice_lhs 5 8 => rw [hpost] + +end Abstract + +/-- **The merge-braid exchange on powers**: braiding inside the +last two-strand block and merging equals merging and braiding on +top. -/ +theorem powMerge_topBraid (V : SuperVect) (a : ℕ) : + (superPow V a ◁ topBraid V 0) ≫ powMerge V a 2 = + powMerge V a 2 ≫ topBraid V a := by + change (superPow V a ◁ topB (superPow V 0) V) ≫ + (α_ (superPow V a) (superPow V 1) V).inv ≫ + (((α_ (superPow V a) (superPow V 0) V).inv ≫ + ((ρ_ (superPow V a)).hom ▷ V)) ▷ V) = + ((α_ (superPow V a) (superPow V 1) V).inv ≫ + (((α_ (superPow V a) (superPow V 0) V).inv ≫ + ((ρ_ (superPow V a)).hom ▷ V)) ▷ V)) ≫ + topB (superPow V a) V + exact whisker_topB_merge (superPow V a) (superPow V 0) V + (ρ_ (superPow V a)).hom + +/-- The block merge is an isomorphism. -/ +theorem powMerge_isIso (V : SuperVect) (a : ℕ) : + ∀ b : ℕ, IsIso (powMerge V a b) + | 0 => inferInstanceAs (IsIso (ρ_ (superPow V a)).hom) + | b + 1 => by + have := powMerge_isIso V a b + exact inferInstanceAs (IsIso + ((α_ (superPow V a) (superPow V b) V).inv ≫ + ((powMerge V a b) ▷ V))) + +/-- Every power element is a merge image. -/ +theorem powMerge_evenMap_surjective (V : SuperVect) + (a b : ℕ) : + Function.Surjective + (((powMerge V a b) : SuperVect.Hom _ _).evenMap) := by + have := powMerge_isIso V a b + intro v + refine ⟨((CategoryTheory.inv (powMerge V a b)) : + SuperVect.Hom _ _).evenMap v, ?_⟩ + have h := congrArg (fun z : (superPow V (a + b) ⟶ + superPow V (a + b)) => + (z : SuperVect.Hom _ _).evenMap v) + (IsIso.inv_hom_id (powMerge V a b)) + exact h + +/-- Every odd power element is a merge image. -/ +theorem powMerge_oddMap_surjective (V : SuperVect) + (a b : ℕ) : + Function.Surjective + (((powMerge V a b) : SuperVect.Hom _ _).oddMap) := by + have := powMerge_isIso V a b + intro v + refine ⟨((CategoryTheory.inv (powMerge V a b)) : + SuperVect.Hom _ _).oddMap v, ?_⟩ + have h := congrArg (fun z : (superPow V (a + b) ⟶ + superPow V (a + b)) => + (z : SuperVect.Hom _ _).oddMap v) + (IsIso.inv_hom_id (powMerge V a b)) + exact h + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TwoBasis.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TwoBasis.lean new file mode 100644 index 0000000000..b6dd3104a3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TwoBasis.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OneBasis + +/-! +# Two-position basis vectors, raw form + +The colour-model basis vectors at two positions in the raw tensor +structure `(superPow V 1) ⊗ V`: nested unit-padded standard basis +vectors, one lemma per parity pattern. +-/ + +@[expose] public section + +namespace RS + +open scoped TensorProduct + +variable {k ℓ : ℕ} + +/-- The forward even split, even last colour. -/ +theorem evenSplitD_inl {d : ℕ} + (c : MixedColouring k ℓ (d + 1)) (hc : c.IsEven) (i : Fin k) + (hi : c (Fin.last d) = Sum.inl i) : + evenSplitEquiv k ℓ d ⟨c, hc⟩ = + Sum.inl (⟨MixedColouring.tail c, + (c.isEven_succ_left i hi).mp hc⟩, i) := by + have inv : (evenSplitEquiv k ℓ d).symm + (Sum.inl (⟨MixedColouring.tail c, + (c.isEven_succ_left i hi).mp hc⟩, i)) = ⟨c, hc⟩ := by + apply Subtype.ext + rw [evenSplitEquiv_symm_inl] + funext j + refine Fin.lastCases ?_ (fun j' => ?_) j + · exact (colouringSplit_symm_last _ _).trans hi.symm + · exact colouringSplit_symm_castSucc _ _ j' + rw [← inv, Equiv.apply_symm_apply] + +/-- The forward even split, odd last colour. -/ +theorem evenSplitD_inr {d : ℕ} + (c : MixedColouring k ℓ (d + 1)) (hc : c.IsEven) + (b : Fin (2 * ℓ)) (hb : c (Fin.last d) = Sum.inr b) : + evenSplitEquiv k ℓ d ⟨c, hc⟩ = + Sum.inr (⟨MixedColouring.tail c, by + by_contra hcontra + exact ((c.isEven_succ_right b hb).mp hc) hcontra⟩, + b) := by + have inv : (evenSplitEquiv k ℓ d).symm + (Sum.inr (⟨MixedColouring.tail c, by + by_contra hcontra + exact ((c.isEven_succ_right b hb).mp hc) hcontra⟩, + b)) = ⟨c, hc⟩ := by + apply Subtype.ext + rw [evenSplitEquiv_symm_inr] + funext j + refine Fin.lastCases ?_ (fun j' => ?_) j + · exact (colouringSplit_symm_last _ _).trans hb.symm + · exact colouringSplit_symm_castSucc _ _ j' + rw [← inv, Equiv.apply_symm_apply] + +/-- The forward odd split, odd last colour. -/ +theorem oddSplitD_inr {d : ℕ} + (c : MixedColouring k ℓ (d + 1)) (hc : ¬ c.IsEven) + (b : Fin (2 * ℓ)) (hb : c (Fin.last d) = Sum.inr b) : + oddSplitEquiv k ℓ d ⟨c, hc⟩ = + Sum.inr (⟨MixedColouring.tail c, by + by_contra hcontra + exact hc ((c.isEven_succ_right b hb).mpr hcontra)⟩, + b) := by + have inv : (oddSplitEquiv k ℓ d).symm + (Sum.inr (⟨MixedColouring.tail c, by + by_contra hcontra + exact hc ((c.isEven_succ_right b hb).mpr hcontra)⟩, + b)) = ⟨c, hc⟩ := by + apply Subtype.ext + rw [oddSplitEquiv_symm_inr] + funext j + refine Fin.lastCases ?_ (fun j' => ?_) j + · exact (colouringSplit_symm_last _ _).trans hb.symm + · exact colouringSplit_symm_castSucc _ _ j' + rw [← inv, Equiv.apply_symm_apply] + +/-- The forward odd split, even last colour. -/ +theorem oddSplitD_inl {d : ℕ} + (c : MixedColouring k ℓ (d + 1)) (hc : ¬ c.IsEven) + (i : Fin k) (hi : c (Fin.last d) = Sum.inl i) : + oddSplitEquiv k ℓ d ⟨c, hc⟩ = + Sum.inl (⟨MixedColouring.tail c, by + intro hcontra + exact hc ((c.isEven_succ_left i hi).mpr hcontra)⟩, + i) := by + have inv : (oddSplitEquiv k ℓ d).symm + (Sum.inl (⟨MixedColouring.tail c, by + intro hcontra + exact hc ((c.isEven_succ_left i hi).mpr hcontra)⟩, + i)) = ⟨c, hc⟩ := by + apply Subtype.ext + rw [oddSplitEquiv_symm_inl] + funext j + refine Fin.lastCases ?_ (fun j' => ?_) j + · exact (colouringSplit_symm_last _ _).trans hi.symm + · exact colouringSplit_symm_castSucc _ _ j' + rw [← inv, Equiv.apply_symm_apply] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexSign.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexSign.lean new file mode 100644 index 0000000000..f18d1c09c0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexSign.lean @@ -0,0 +1,136 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockOddList +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauKey + +/-! +# The per-vertex sign collapse + +The product of the two per-vertex sorting signs is the +key-sortSign of the pair enumeration: both lists are value maps +of the two flag enumerations, so the reindexing sign transports +between them, and the block enumeration is key-sorted. +-/ + +@[expose] public section + +namespace RS + +open Finset + +variable {k ℓ : ℕ} + +-- Two sorting signs are matched with the key sign of +-- the pair enumeration, so all three sorts unfold together. +open Classical in +/-- **The per-vertex sign collapse**: the block and Definition 5 +sorting signs multiply to the key-sortSign of the pair +enumeration. -/ +theorem vertex_sign_collapse (W : ClosedFragment) + (F : EdgeSubset W) {κ : F.TransitionSystem} + (o : κ.Orientation) (ψ : F.EvenColouring k) + (φ : F.OddColouring ℓ) (v : Fin (ds W).length) + (hnd : (F.oddListAt o φ (blockVertex W v)).Nodup) : + (sortSign (oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v)) : ℂ) * + (sortSign (F.oddListAt o φ (blockVertex W v)) : ℂ) = + (sortSign ((pairFlagList (F := F) o + (blockVertex W v)).map + (fun f => sortKey W f.val)) : ℂ) := by + have hblock := oddListOf_blockRestrict_eq_map W F o ψ φ v + have hpair := oddListAt_eq_map (F := F) o φ + (blockVertex W v) + have hnd_map : ((blockOddFlagList W F v).map + (defFiveValue o φ)).Nodup := by + rw [← hblock] + exact (oddListOf_blockRestrict_nodup_iff W F o ψ φ + v).mpr hnd + have htrans := sortSign_map_listIndexPerm + (blockOddFlagList W F v) + (pairFlagList (F := F) o (blockVertex W v)) + (blockOddFlagList_nodup W F v) + (pairFlagList_nodup o (blockVertex W v)) + (mem_blockOddFlagList_iff_pairFlagList W F o v) + (blockOddFlagList_length_eq W F o v) + (defFiveValue o φ) hnd_map + have hkey := sortSign_pairFlagList_key W F o v + -- htrans : sortSign (pairList.map dFV) = + -- sign τ * sortSign (blockList.map dFV) + -- hkey : sortSign (pairList.map key) = (sign τ : ℤ) + rw [hblock, hpair] + have hsq : (sortSign ((blockOddFlagList W F v).map + (defFiveValue o φ)) : ℂ) * + (sortSign ((blockOddFlagList W F v).map + (defFiveValue o φ)) : ℂ) = 1 := sortSign_sq _ + have h1 : (sortSign ((pairFlagList (F := F) o + (blockVertex W v)).map (defFiveValue o φ)) : ℂ) = + ((Equiv.Perm.sign (listIndexPerm + (blockOddFlagList W F v) + (pairFlagList (F := F) o (blockVertex W v)) + (blockOddFlagList_nodup W F v) + (pairFlagList_nodup o (blockVertex W v)) + (mem_blockOddFlagList_iff_pairFlagList W F o v) + (blockOddFlagList_length_eq W F o v)) : ℤ) : ℂ) * + (sortSign ((blockOddFlagList W F v).map + (defFiveValue o φ)) : ℂ) := by + rw [htrans] + push_cast + ring + have h2 : ((Equiv.Perm.sign (listIndexPerm + (blockOddFlagList W F v) + (pairFlagList (F := F) o (blockVertex W v)) + (blockOddFlagList_nodup W F v) + (pairFlagList_nodup o (blockVertex W v)) + (mem_blockOddFlagList_iff_pairFlagList W F o v) + (blockOddFlagList_length_eq W F o v)) : ℤ) : ℂ) = + (sortSign ((pairFlagList (F := F) o + (blockVertex W v)).map + (fun f => sortKey W f.val)) : ℂ) := by + rw [← hkey] + calc (sortSign ((blockOddFlagList W F v).map + (defFiveValue o φ)) : ℂ) * + (sortSign ((pairFlagList (F := F) o + (blockVertex W v)).map (defFiveValue o φ)) : ℂ) + = (sortSign ((blockOddFlagList W F v).map + (defFiveValue o φ)) : ℂ) * + (((Equiv.Perm.sign (listIndexPerm + (blockOddFlagList W F v) + (pairFlagList (F := F) o (blockVertex W v)) + (blockOddFlagList_nodup W F v) + (pairFlagList_nodup o (blockVertex W v)) + (mem_blockOddFlagList_iff_pairFlagList W F o v) + (blockOddFlagList_length_eq W F o v)) : ℤ) : ℂ) * + (sortSign ((blockOddFlagList W F v).map + (defFiveValue o φ)) : ℂ)) := by + rw [← h1] + _ = ((Equiv.Perm.sign (listIndexPerm + (blockOddFlagList W F v) + (pairFlagList (F := F) o (blockVertex W v)) + (blockOddFlagList_nodup W F v) + (pairFlagList_nodup o (blockVertex W v)) + (mem_blockOddFlagList_iff_pairFlagList W F o v) + (blockOddFlagList_length_eq W F o v)) : ℤ) : ℂ) := by + calc _ = (((sortSign ((blockOddFlagList W F v).map + (defFiveValue o φ)) : ℂ) * + (sortSign ((blockOddFlagList W F v).map + (defFiveValue o φ)) : ℂ)) * + ((Equiv.Perm.sign (listIndexPerm + (blockOddFlagList W F v) + (pairFlagList (F := F) o (blockVertex W v)) + (blockOddFlagList_nodup W F v) + (pairFlagList_nodup o (blockVertex W v)) + (mem_blockOddFlagList_iff_pairFlagList W F o v) + (blockOddFlagList_length_eq W F o v)) : ℤ) + : ℂ)) := by ring + _ = _ := by rw [hsq, one_mul] + _ = (sortSign ((pairFlagList (F := F) o + (blockVertex W v)).map + (fun f => sortKey W f.val)) : ℂ) := h2 + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexValue.lean new file mode 100644 index 0000000000..14d91ed49f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexValue.lean @@ -0,0 +1,210 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockCanon + +/-! +# The per-vertex value + +The star coordinate of a block of the flipped data colouring is +the block sorting sign times the Definition 5 vertex factor's +normalised form: the canonical permutation carries the block to +the canonical colouring, whose star coordinate the functional +`hRS` evaluates. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory Finset + + +variable {R : ℕ} (f : EdgeRankParameter R) +variable (P : DelignePackage (SkeinObj f)) +variable {k ℓ : ℕ} +variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) +variable (e' : P.ω.obj (SkeinObj.mk 1) ⟶ stdSuperPair k ℓ) + +-- The block's star coordinate is computed through +-- the transport and matched with the vertex factor. +open Classical in +/-- **The per-vertex value** (duplicate-free case): the star +coordinate of the block is the block sorting sign times the +sign-normalised Definition 5 vertex factor. -/ +theorem starCoord_block_flip_nodup + (hee' : (e' ≫ e : P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk 1)) = 𝟙 _) + (he'e : (e ≫ e' : stdSuperPair k ℓ ⟶ stdSuperPair k ℓ) = 𝟙 _) + (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) + (ψ : F.EvenColouring k) (φ : F.OddColouring ℓ) + (v : Fin (ds W).length) + (hnd : (F.oddListAt o φ (blockVertex W v)).Nodup) : + starCoord f P e' ((ds W).get v) + (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v) = + (sortSign (oddListOf (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v)) : ℂ) * + ((sortSign (F.oddListAt o φ (blockVertex W v)) : ℂ) * + (hRS f P e').evalOdd + (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v))) := by + set b := blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v with hb + have hnd_b : (oddListOf b).Nodup := + (oddListOf_blockRestrict_nodup_iff W F o ψ φ v).mpr hnd + obtain ⟨σ, h, comp, hsign⟩ := exists_canonPerm b hnd_b + have h1 := starCoord_perm f P e e' hee' he'e + ((ds W).get v) σ b + rw [comp] at h1 + rw [starCoord_cast f P e' h] at h1 + rw [hsign] at h1 + -- h1 : starCoord (canon (eM b) (oF b)) = + -- sortSign (oddListOf b) * starCoord b + have hident_e := evenMultisetOf_blockRestrict W F o ψ φ v + have hident_o := oddFinsetOf_blockRestrict W F o ψ φ v + rw [← hb] at hident_e hident_o + have heval := evalOdd_hRS_nodup f P e' + (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v)) hnd + -- rewrite the canonical star coordinate into hRS terms + have htrans : starCoord f P e' + ((evenMultisetOf b).card + (oddFinsetOf b).card) + (canonColouring (evenMultisetOf b) (oddFinsetOf b)) = + starCoord f P e' + ((F.evenColoursAt ψ (blockVertex W v)).card + + (F.oddListAt o φ (blockVertex W v)).toFinset.card) + (canonColouring (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v)).toFinset) := by + exact congrArg (fun p : Multiset (Fin k) × + Finset (Fin (2 * ℓ)) => + starCoord f P e' (p.1.card + p.2.card) + (canonColouring p.1 p.2)) + (show (evenMultisetOf b, oddFinsetOf b) = + (F.evenColoursAt ψ (blockVertex W v), + (F.oddListAt o φ (blockVertex W v)).toFinset) + from Prod.ext_iff.mpr ⟨hident_e, hident_o⟩) + have hcanon : starCoord f P e' + ((evenMultisetOf b).card + (oddFinsetOf b).card) + (canonColouring (evenMultisetOf b) (oddFinsetOf b)) = + (sortSign (F.oddListAt o φ (blockVertex W v)) : ℂ) * + (hRS f P e').evalOdd + (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v)) := by + rw [htrans] + rw [heval] + set A := (sortSign (F.oddListAt o φ + (blockVertex W v)) : ℂ) + set S := starCoord f P e' + ((F.evenColoursAt ψ (blockVertex W v)).card + + (F.oddListAt o φ (blockVertex W v)).toFinset.card) + (canonColouring (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v)).toFinset) + have hA : A * A = 1 := sortSign_sq _ + calc S = (A * A) * S := by + rw [hA, one_mul] + _ = A * (A * S) := by ring + rw [hcanon] at h1 + -- h1 : A*(B*evalOdd-part) = sortSign(oddListOf b) * starCoord b + have hS : (sortSign (oddListOf b) : ℂ) * + (sortSign (oddListOf b) : ℂ) = 1 := sortSign_sq _ + calc starCoord f P e' ((ds W).get v) b + = ((sortSign (oddListOf b) : ℂ) * + (sortSign (oddListOf b) : ℂ)) * + starCoord f P e' ((ds W).get v) b := by + rw [hS, one_mul] + _ = (sortSign (oddListOf b) : ℂ) * + ((sortSign (oddListOf b) : ℂ) * + starCoord f P e' ((ds W).get v) b) := by ring + _ = (sortSign (oddListOf b) : ℂ) * + ((sortSign (F.oddListAt o φ + (blockVertex W v)) : ℂ) * + (hRS f P e').evalOdd + (F.evenColoursAt ψ (blockVertex W v)) + (F.oddListAt o φ (blockVertex W v))) := by + rw [← h1] + +-- As for the duplicate-free case, on the vanishing branch. +open Classical in +/-- **The per-vertex vanishing** (repeated case): a repeated odd +value kills the block's star coordinate. -/ +theorem starCoord_block_flip_not_nodup + (hee' : (e' ≫ e : P.ω.obj (SkeinObj.mk 1) ⟶ + P.ω.obj (SkeinObj.mk 1)) = 𝟙 _) + (he'e : (e ≫ e' : stdSuperPair k ℓ ⟶ stdSuperPair k ℓ) = 𝟙 _) + (W : ClosedFragment) (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) + (ψ : F.EvenColouring k) (φ : F.OddColouring ℓ) + (v : Fin (ds W).length) + (hnd : ¬ (F.oddListAt o φ (blockVertex W v)).Nodup) : + starCoord f P e' ((ds W).get v) + (blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v) = 0 := by + set b := blockRestrict (ds W) + (cSorted W (colouringOfFlip W F o ψ φ)) v with hb + have hnd_b : ¬ (oddListOf b).Nodup := fun hn => + hnd ((oddListOf_blockRestrict_nodup_iff W F o ψ φ v).mp + hn) + have hiff : ∀ j : Fin ((ds W).get v), + j ∈ oddSlots W F v ↔ (b j).isRight = true := fun j => + (mem_oddSlots j).trans + (blockRestrict_colouringOfFlip_isRight W F o ψ φ v + j).symm + rw [← Multiset.coe_nodup] at hnd_b + rw [oddListOf_coe_multiset b (oddSlots W F v) hiff] + at hnd_b + have hattach : ((oddSlots W F v).attach.val).Nodup := by + rw [Finset.attach_val] + exact Multiset.Nodup.attach ((oddSlots W F v).nodup) + have hpair : ¬ (∀ x ∈ (oddSlots W F v).attach.val, + ∀ y ∈ (oddSlots W F v).attach.val, + Sum.getRight (b x.val) ((hiff x.val).mp x.prop) = + Sum.getRight (b y.val) ((hiff y.val).mp y.prop) → + x = y) := by + intro hinj + exact hnd_b (Multiset.Nodup.map_on hinj hattach) + push Not at hpair + obtain ⟨x, -, y, -, hval, hne⟩ := hpair + have hextract : ∀ (z : Fin k ⊕ Fin (2 * ℓ)) + (hz : z.isRight = true) (u₀ : Fin (2 * ℓ)), + z = Sum.inr u₀ → z.getRight hz = u₀ := by + intro z hz u₀ he + subst he + rfl + have hxr : (b x.val).isRight = true := + (hiff x.val).mp x.prop + have hyr : (b y.val).isRight = true := + (hiff y.val).mp y.prop + have hslot_ne : x.val ≠ y.val := fun hxy => + hne (Subtype.ext hxy) + obtain ⟨u, hu⟩ : ∃ u, b x.val = Sum.inr u := by + rcases hz : b x.val with a | u + · rw [hz] at hxr + exact Bool.noConfusion hxr + · exact ⟨u, rfl⟩ + obtain ⟨w, hw⟩ : ∃ w, b y.val = Sum.inr w := by + rcases hz : b y.val with a | w + · rw [hz] at hyr + exact Bool.noConfusion hyr + · exact ⟨w, rfl⟩ + have huw : u = w := by + have h1 := hextract _ ((hiff x.val).mp x.prop) u hu + have h2 := hextract _ ((hiff y.val).mp y.prop) w hw + rw [h1, h2] at hval + exact hval + have hbeq : b x.val = b y.val := by + rw [hu, hw, huw] + rcases lt_or_gt_of_ne (fun h => hslot_ne (Fin.ext h) : + x.val.val ≠ y.val.val) with hlt | hgt + · exact starCoord_repeat_zero f P e e' hee' he'e b + x.val y.val hlt hxr hbeq + · exact starCoord_repeat_zero f P e e' hee' he'e b + y.val x.val hgt hyr hbeq.symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/AtomDichotomy.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/AtomDichotomy.lean new file mode 100644 index 0000000000..b392cbc417 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/AtomDichotomy.lean @@ -0,0 +1,168 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiSemisimple +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.AtomicIdempotents + +/-! +# The Hom-dichotomy between atoms + +An *atom* of the Karoubi envelope is an object whose endomorphisms +are the scalar line of a nonzero identity. Between atoms, the +mixed-trace nondegeneracy forces the dichotomy: every nonzero +morphism composes with a partner to a nonzero scalar, hence is an +isomorphism. This is the engine turning the atomic idempotent +decomposition into a semisimple-category structure. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Idempotents + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- An atom: the endomorphisms are scalars, and the identity is +nonzero. -/ +structure IsAtom (S : Karoubi (SkeinObj f)) : Prop where + scalar : ∀ x : End S, ∃ c : ℂ, x = c • 𝟙 S + id_ne_zero : 𝟙 S ≠ 0 + +/-- Scalars act faithfully on a nonzero identity. -/ +private theorem smul_id_injective {S : Karoubi (SkeinObj f)} + (hS : 𝟙 S ≠ 0) {c d : ℂ} + (h : c • 𝟙 S = d • 𝟙 S) : c = d := by + by_contra hcd + have hsub : (c - d) • 𝟙 S = 0 := by + rw [sub_smul, h, sub_self] + rcases smul_eq_zero.mp hsub with hc | hid + · exact hcd (sub_eq_zero.mp hc) + · exact hS hid + +/-- **The dichotomy**: a nonzero morphism between atoms is an +isomorphism. -/ +theorem atom_iso_of_ne_zero {S T : Karoubi (SkeinObj f)} + (hS : IsAtom f S) (hT : IsAtom f T) + {φ : S ⟶ T} (hφ : φ ≠ 0) : + ∃ ψ : T ⟶ S, φ ≫ ψ = 𝟙 S ∧ ψ ≫ φ = 𝟙 T := by + -- Nondegeneracy: some partner has nonvanishing closure trace. + have hpartner : ∃ b : T ⟶ S, + HomSpace.traceMap f.val S.X.arity (φ.f ≫ b.f) ≠ 0 := by + by_contra hall + push Not at hall + exact hφ (karoubiHom_eq_zero_of_traces_vanish f φ + (fun b => hall b)) + obtain ⟨b, hb⟩ := hpartner + -- The composite is a nonzero scalar on the source atom. + obtain ⟨c, hc⟩ := hS.scalar (φ ≫ b) + have hcne : c ≠ 0 := by + intro hc0 + rw [hc0, zero_smul] at hc + have : (φ ≫ b).f = 0 := by rw [hc]; rfl + rw [show (φ ≫ b).f = φ.f ≫ b.f from rfl] at this + rw [this, map_zero] at hb + exact hb rfl + -- Normalize to a one-sided inverse. + refine ⟨c⁻¹ • b, ?_, ?_⟩ + · rw [CategoryTheory.Linear.comp_smul, hc, smul_smul, + inv_mul_cancel₀ hcne, one_smul] + · -- The reverse composite is an idempotent scalar on the + -- target atom; it cannot be zero, hence is the identity. + obtain ⟨d, hd⟩ := hT.scalar ((c⁻¹ • b) ≫ φ) + have hidem : ((c⁻¹ • b) ≫ φ) ≫ ((c⁻¹ • b) ≫ φ) = + (c⁻¹ • b) ≫ φ := by + rw [show ((c⁻¹ • b) ≫ φ) ≫ ((c⁻¹ • b) ≫ φ) = + (c⁻¹ • b) ≫ (φ ≫ (c⁻¹ • b)) ≫ φ from by + simp only [Category.assoc]] + rw [CategoryTheory.Linear.comp_smul, hc, smul_smul, + inv_mul_cancel₀ hcne, one_smul, Category.id_comp] + rw [hd] at hidem ⊢ + rw [show (d • 𝟙 T) ≫ (d • 𝟙 T) = (d * d) • 𝟙 T from by + rw [CategoryTheory.Linear.smul_comp, + CategoryTheory.Linear.comp_smul, Category.id_comp, + smul_smul]] at hidem + have hdd := smul_id_injective f hT.id_ne_zero hidem + have hcases : d = 0 ∨ d = 1 := by + have h0 : d * (d - 1) = 0 := by + rw [mul_sub, mul_one, hdd, sub_self] + rcases mul_eq_zero.mp h0 with h | h + · exact Or.inl h + · exact Or.inr (sub_eq_zero.mp h) + rcases hcases with hd0 | hd1 + · -- d = 0 would kill φ + exfalso + rw [hd0, zero_smul] at hd + have hφ0 : φ = 0 := by + have h1 : φ ≫ ((c⁻¹ • b) ≫ φ) = φ ≫ 0 := by + rw [hd] + rw [show φ ≫ ((c⁻¹ • b) ≫ φ) = + (φ ≫ (c⁻¹ • b)) ≫ φ from by + simp only [Category.assoc]] at h1 + rw [CategoryTheory.Linear.comp_smul, hc, smul_smul, + inv_mul_cancel₀ hcne, one_smul, + Category.id_comp] at h1 + rw [h1, Limits.comp_zero] + exact hφ hφ0 + · rw [hd1, one_smul] + +/-! ### Atoms from atomic idempotents -/ + +/-- The Karoubi object cut out of `X` by an idempotent of its +endomorphism algebra. -/ +@[reducible] noncomputable def cutBy (X : Karoubi (SkeinObj f)) + {eK : End X} (he : IsIdempotentElem eK) : + Karoubi (SkeinObj f) where + X := X.X + p := eK.f + idem := by + have := congrArg Karoubi.Hom.f (he : eK * eK = eK) + exact this + +/-- The object cut out by an atomic idempotent is an atom. -/ +theorem isAtom_cutBy (X : Karoubi (SkeinObj f)) + {eK : End X} (he : IsAtomicIdempotent eK) : + IsAtom f (cutBy f X he.idem) := by + constructor + · intro x + -- Lift to the ambient endomorphism algebra and use the + -- corner-scalar property. + have habs₁ : eK.f ≫ x.f = x.f := Karoubi.p_comp x + have habs₂ : x.f ≫ eK.f = x.f := Karoubi.comp_p x + have hyc : X.p ≫ x.f ≫ X.p = x.f := by + rw [show X.p ≫ x.f ≫ X.p = + X.p ≫ (eK.f ≫ x.f ≫ eK.f) ≫ X.p from by + rw [show eK.f ≫ x.f ≫ eK.f = x.f from by + rw [habs₂, habs₁]]] + rw [show X.p ≫ (eK.f ≫ x.f ≫ eK.f) ≫ X.p = + (X.p ≫ eK.f) ≫ x.f ≫ (eK.f ≫ X.p) from by + simp only [Category.assoc]] + rw [Karoubi.p_comp, Karoubi.comp_p, habs₂, habs₁] + obtain ⟨c, hc⟩ := he.corner_scalar ⟨x.f, hyc⟩ + refine ⟨c, ?_⟩ + apply Karoubi.hom_ext + have hcf := congrArg Karoubi.Hom.f hc + rw [show (eK * ⟨x.f, hyc⟩ * eK).f = + eK.f ≫ x.f ≫ eK.f from by + show ((eK * ⟨x.f, hyc⟩) * eK).f = _ + rw [show ((eK * ⟨x.f, hyc⟩) * eK).f = + eK.f ≫ (eK * ⟨x.f, hyc⟩).f from rfl] + rw [show (eK * ⟨x.f, hyc⟩).f = x.f ≫ eK.f from rfl]] at hcf + rw [habs₂, habs₁] at hcf + rw [hcf] + rfl + · intro h + apply he.ne_zero + apply Karoubi.hom_ext + have := congrArg Karoubi.Hom.f h + rw [show Karoubi.Hom.f (𝟙 (cutBy f X he.idem)) = eK.f + from rfl] at this + rw [this] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/AtomicIdempotents.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/AtomicIdempotents.lean new file mode 100644 index 0000000000..9478a6aa0e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/AtomicIdempotents.lean @@ -0,0 +1,192 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Atomic idempotents in semisimple complex algebras + +Every finite-dimensional semisimple ℂ-algebra has a complete +orthogonal family of idempotents whose corners are the scalar +lines they span: pull back the diagonal matrix units through +Wedderburn–Artin. These are the atoms along which Karoubi +objects split into simples. +-/ + +@[expose] public section + +namespace RS + +universe u + +variable {A : Type u} + +/-- An idempotent is *atomic* if it is nonzero and its corner is +the scalar line it spans. -/ +structure IsAtomicIdempotent + [Ring A] [Algebra ℂ A] + (e : A) : Prop where + idem : IsIdempotentElem e + ne_zero : e ≠ 0 + corner_scalar : ∀ x : A, ∃ c : ℂ, e * x * e = c • e + +section PiMatrix + +/-- The diagonal matrix-unit family in a product of matrix +algebras. -/ +private noncomputable def matUnit {n : ℕ} {d : Fin n → ℕ} + (p : (i : Fin n) × Fin (d i)) : + Π i, Matrix (Fin (d i)) (Fin (d i)) ℂ := + Pi.single p.1 (Matrix.single p.2 p.2 1) + +private theorem matUnit_mul_matUnit {n : ℕ} {d : Fin n → ℕ} + (p q : (i : Fin n) × Fin (d i)) : + matUnit p * matUnit q = + if p = q then matUnit p else 0 := by + classical + funext k + rw [Pi.mul_apply] + rcases eq_or_ne p.1 q.1 with hij | hij + · obtain ⟨pi, pr⟩ := p + obtain ⟨qi, qr⟩ := q + dsimp at hij + subst hij + rcases eq_or_ne pr qr with rfl | hr + · rw [ite_eq_left rfl] + unfold matUnit + rcases eq_or_ne k pi with rfl | hk + · simp + · simp [Pi.single_eq_of_ne hk] + · rw [ite_eq_right (by + intro h + exact hr (by + have := Sigma.mk.inj_iff.mp h + exact eq_of_heq this.2))] + unfold matUnit + rcases eq_or_ne k pi with rfl | hk + · simp [hr] + · simp [Pi.single_eq_of_ne hk] + · rw [ite_eq_right (fun h => hij (congrArg Sigma.fst h))] + unfold matUnit + rcases eq_or_ne k p.1 with rfl | hk + · rw [Pi.single_eq_same, Pi.single_eq_of_ne hij, + Matrix.mul_zero] + simp + · rw [Pi.single_eq_of_ne hk, Matrix.zero_mul] + simp + +private theorem matUnit_sum {n : ℕ} {d : Fin n → ℕ} : + ∑ p : (i : Fin n) × Fin (d i), matUnit p = 1 := by + classical + funext k + rw [Finset.sum_apply, Pi.one_apply] + rw [← Finset.univ_sigma_univ, Finset.sum_sigma] + rw [show (∑ i : Fin n, ∑ r : Fin (d i), + matUnit ⟨i, r⟩ k) = + ∑ i : Fin n, ∑ r : Fin (d i), + Pi.single (M := fun j => + Matrix (Fin (d j)) (Fin (d j)) ℂ) i + (Matrix.single r r 1) k from rfl] + rw [Finset.sum_eq_single k + (fun i _ hi => by + rw [Finset.sum_eq_zero] + intro r _ + rw [Pi.single_eq_of_ne (Ne.symm hi)]) + (fun h => absurd (Finset.mem_univ k) h)] + rw [show (∑ r : Fin (d k), + Pi.single (M := fun j => + Matrix (Fin (d j)) (Fin (d j)) ℂ) k + (Matrix.single r r 1) k) = + ∑ r : Fin (d k), Matrix.single r r (1 : ℂ) from by + refine Finset.sum_congr rfl fun r _ => ?_ + rw [Pi.single_eq_same]] + ext r s + rw [Matrix.sum_apply] + rcases eq_or_ne r s with rfl | hrs + · rw [Matrix.one_apply_eq] + rw [Finset.sum_eq_single r + (fun b _ hb => by + simp only [Matrix.single, Matrix.of_apply] + rw [ite_eq_right (by simp [hb])]) + (fun h => absurd (Finset.mem_univ r) h)] + simp [Matrix.single] + · rw [Matrix.one_apply_ne hrs] + refine Finset.sum_eq_zero fun b _ => ?_ + simp only [Matrix.single, Matrix.of_apply] + rw [ite_eq_right (by + rintro ⟨hbr, hbs⟩ + exact hrs (hbr ▸ hbs))] + +private theorem matUnit_corner {n : ℕ} {d : Fin n → ℕ} + (p : (i : Fin n) × Fin (d i)) + (x : Π i, Matrix (Fin (d i)) (Fin (d i)) ℂ) : + matUnit p * x * matUnit p = + (x p.1 p.2 p.2) • matUnit p := by + classical + funext k + rw [Pi.mul_apply, Pi.mul_apply, Pi.smul_apply] + unfold matUnit + rcases eq_or_ne k p.1 with rfl | hk + · rw [show (Pi.single (M := fun j => + Matrix (Fin (d j)) (Fin (d j)) ℂ) p.1 + (Matrix.single p.2 p.2 1) p.1) = + Matrix.single p.2 p.2 1 from Pi.single_eq_same _ _] + rw [Matrix.single_mul_mul_single, Matrix.smul_single] + congr 1 + rw [smul_eq_mul] + ring + · simp [Pi.single_eq_of_ne hk] + +private theorem matUnit_ne_zero {n : ℕ} {d : Fin n → ℕ} + (p : (i : Fin n) × Fin (d i)) : matUnit p ≠ 0 := by + intro h + have h2 := congrFun h p.1 + simp only [matUnit, Pi.single_eq_same, Pi.zero_apply] at h2 + have h3 := congrFun (congrFun h2 p.2) p.2 + simp [Matrix.single] at h3 + +end PiMatrix + +/-- **Atomic decomposition** of a finite-dimensional semisimple +complex algebra: the identity splits into a complete orthogonal +family of atomic idempotents. -/ +theorem exists_completeOrthogonal_atomic [Ring A] [Algebra ℂ A] + [FiniteDimensional ℂ A] [IsSemisimpleRing A] : + ∃ (ι : Type) (_ : Fintype ι) (e : ι → A), + CompleteOrthogonalIdempotents e ∧ + ∀ i, IsAtomicIdempotent (e i) := by + classical + obtain ⟨n, d, hd, ⟨Φ⟩⟩ := + IsSemisimpleRing.exists_algEquiv_pi_matrix_of_isAlgClosed + (F := ℂ) (R := A) + refine ⟨(i : Fin n) × Fin (d i), inferInstance, + fun p => Φ.symm (matUnit p), ⟨⟨fun p => ?_, ?_⟩, ?_⟩, ?_⟩ + · show IsIdempotentElem _ + rw [IsIdempotentElem, ← map_mul, matUnit_mul_matUnit, + ite_eq_left rfl] + · intro p q hpq + rw [← map_mul, matUnit_mul_matUnit, ite_eq_right hpq, map_zero] + · rw [← map_sum, matUnit_sum, map_one] + · intro p + refine ⟨?_, ?_, ?_⟩ + · show IsIdempotentElem _ + rw [IsIdempotentElem, ← map_mul, matUnit_mul_matUnit, + ite_eq_left rfl] + · intro h + exact matUnit_ne_zero p (by + have := congrArg Φ h + rw [AlgEquiv.apply_symm_apply, map_zero] at this + exact this) + · intro x + refine ⟨(Φ x) p.1 p.2 p.2, ?_⟩ + rw [show Φ.symm (matUnit p) * x * Φ.symm (matUnit p) = + Φ.symm (matUnit p * Φ x * matUnit p) from by + rw [map_mul, map_mul, AlgEquiv.symm_apply_apply]] + rw [matUnit_corner, map_smul] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockAssembly.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockAssembly.lean new file mode 100644 index 0000000000..977a5677bd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockAssembly.lean @@ -0,0 +1,98 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactor +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentTrace + +/-! +# The block Frobenius tower + +The Frobenius character identity at every ambient arity: the +trace of a Young idempotent (in the block representation of +`S_k`) against the block-diagonal power is the dimension times +the Schur specialization of the block power traces. The +resulting `FrobeniusTower` gives the appendix's nilpotent-trace +proof at every strand arity. The mainline semisimplicity proof +uses the factorial argument in `BlockFactorialTrace`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- **The block Frobenius identity** at ambient arity `n`. -/ +theorem block_frobenius (P : SchurPackage.{1}) (n : ℕ) + (μ : YoungDiagram) (g : skeinEnd f n) : + skeinTrace f (n * μ.card) + (blockRep f n μ.card (P.e μ) * + blockPow f n g μ.card) = + (P.dim μ : ℂ) * + diagramSchur μ (fun c => skeinTrace f n (g ^ c)) := by + classical + have hexp : blockRep f n μ.card (P.e μ) * + blockPow f n g μ.card = + ((P.dim μ : ℂ) / (μ.card.factorial : ℂ)) • + ∑ π : Equiv.Perm (Fin μ.card), P.char μ π • + (permClass f (n * μ.card) (blockPerm n π) * + blockPow f n g μ.card) := by + rw [SchurPackage.e_def, charIdempotent, map_smul, map_sum, + smul_mul_assoc, Finset.sum_mul] + congr 1 + refine Finset.sum_congr rfl fun π _ => ?_ + rw [map_smul, blockRep_of, smul_mul_assoc] + have hlin_smul : ∀ (c : ℂ) (x : skeinEnd f (n * μ.card)), + skeinTrace f (n * μ.card) (c • x) = + c * skeinTrace f (n * μ.card) x := fun c x => + (map_smul (HomSpace.traceMap f.val (n * μ.card)) c x).trans + (smul_eq_mul _ _) + have hlin_sum : ∀ (h : Equiv.Perm (Fin μ.card) → + skeinEnd f (n * μ.card)), + skeinTrace f (n * μ.card) (∑ π, h π) = + ∑ π, skeinTrace f (n * μ.card) (h π) := fun h => + map_sum (HomSpace.traceMap f.val (n * μ.card)) h + Finset.univ + rw [hexp, hlin_smul, hlin_sum] + rw [show (∑ π : Equiv.Perm (Fin μ.card), + skeinTrace f (n * μ.card) (P.char μ π • + (permClass f (n * μ.card) (blockPerm n π) * + blockPow f n g μ.card))) = + ∑ π : Equiv.Perm (Fin μ.card), P.char μ π * + ((π.cycleType.map + (fun c => skeinTrace f n (g ^ c))).prod * + skeinTrace f n (g ^ 1) ^ + (μ.card - π.cycleType.sum)) from + Finset.sum_congr rfl fun π _ => by + rw [hlin_smul, skeinTrace_blockPerm_mul_pow]] + rw [div_eq_mul_inv, mul_assoc] + exact congrArg ((P.dim μ : ℂ) * ·) + (P.frobenius μ (fun c => skeinTrace f n (g ^ c))) + +/-- **The block Frobenius tower** at ambient arity `n`. -/ +noncomputable def blockFrobeniusTower (P : SchurPackage.{1}) + (n : ℕ) : + FrobeniusTower P (fun k => skeinEnd f (n * k)) (((R : ℝ) ^ n) ^ 2) + (skeinEnd f n) where + toPermTower := blockPermTower f n + traceA := HomSpace.traceMap f.val n + trace k := HomSpace.traceMap f.val (n * k) + pow k g := blockPow f n g k + frobenius μ g := block_frobenius f P n μ g + +/-- **Nilpotent-trace vanishing at every arity**: every nilpotent +strand endomorphism, at any arity, has vanishing skein trace. -/ +theorem skeinTrace_eq_zero_of_isNilpotent_all + (P : SchurPackage.{1}) (n : ℕ) {g : skeinEnd f n} + (hg : IsNilpotent g) : + skeinTrace f n g = 0 := + (blockFrobeniusTower f P n).traceA_eq_zero_of_isNilpotent hg + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockBounds.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockBounds.lean new file mode 100644 index 0000000000..004efff5dc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockBounds.lean @@ -0,0 +1,76 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage + +/-! +# Block bounds + +The two abstract consequences of the Schur interface that drive +hook confinement: an algebra morphism that does not kill the +idempotent of shape `μ` transports the full `(dim μ)²`-dimensional +block (`dim_sq_le_finrank`), and killing a shape kills every shape +containing it (`e_killed_of_contained`), by the branching +containment. Both are stated against an arbitrary target algebra; +the skein endomorphism algebras are substituted downstream. +-/ + +@[expose] public section + +namespace RS + +universe u + +namespace SchurPackage + +/-- If an algebra morphism does not kill `e μ`, its target has +dimension at least `(dim μ)²`: the block of `μ` embeds. -/ +theorem dim_sq_le_finrank (P : SchurPackage.{u}) (μ : YoungDiagram) + {B : Type u} [Ring B] [Algebra ℂ B] [Module.Finite ℂ B] + (φ : SymGroupAlgebra μ.card →ₐ[ℂ] B) + (hne : φ (P.e μ) ≠ 0) : + P.dim μ ^ 2 ≤ Module.finrank ℂ B := by + rw [← P.block_rank μ] + set I := LinearMap.range + (LinearMap.mulLeft ℂ (charIdempotent (P.dim μ) (P.char μ))) + have hinj : Function.Injective (φ.toLinearMap.comp I.subtype) := by + rw [← LinearMap.ker_eq_bot, LinearMap.ker_eq_bot'] + rintro ⟨x, hx⟩ hzero + obtain ⟨y, rfl⟩ := hx + have hy : φ (charIdempotent (P.dim μ) (P.char μ) * y) = 0 := by + simpa [LinearMap.mulLeft_apply] using hzero + have := P.block_faithful μ B φ hne y hy + simpa [LinearMap.mulLeft_apply] using this + exact LinearMap.finrank_le_finrank_of_injective hinj + +/-- Killing a shape kills every shape containing it: if `φ` +annihilates `e lam` extended to arity `mu.card`, and `lam ≤ mu`, +then `φ` annihilates `e mu`. -/ +theorem e_killed_of_contained (P : SchurPackage.{u}) + {lam mu : YoungDiagram} (hle : lam ≤ mu) (h : lam.card ≤ mu.card) + {B : Type u} [Ring B] [Algebra ℂ B] + (φ : SymGroupAlgebra mu.card →ₐ[ℂ] B) + (hkill : φ (symCast h (P.e lam)) = 0) : + φ (P.e mu) = 0 := by + by_contra hne + apply P.branching lam mu hle h + have hzero : + φ (charIdempotent (P.dim mu) (P.char mu) * + (symCast h (charIdempotent (P.dim lam) (P.char lam)) * + charIdempotent (P.dim mu) (P.char mu))) = 0 := by + simp only [map_mul] + rw [show φ (symCast h (charIdempotent (P.dim lam) (P.char lam))) = 0 + from hkill] + simp + have := P.block_faithful mu B φ hne _ hzero + rw [← mul_assoc] at this + exact this + +end SchurPackage + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockCycle.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockCycle.lean new file mode 100644 index 0000000000..c57f4db3e8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockCycle.lean @@ -0,0 +1,463 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockSplice +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.Frobenius +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockTower + +/-! +# The block cycle trace + +Closing a block rotation against `c + 1` diagonal copies of `g` +gives the trace of `g ^ (c + 1)`: the rotation carries each copy +onto the next, and after `c + 1` turns the copies have composed. + +The rotation by one block is `blockPerm n (finRotate (c+1))`, which +is `blockRot (n*c) n`; the splice `partialCloseBlockSplice` peels +one block off it, first at fragments and then at trace values. An +induction on the number of blocks then turns the tensor of a tuple +into the tuple's cyclic composite, which for a constant tuple is a +power. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-! ### The rotation by one block -/ + +/-- Forward value of `finRotate`. -/ +private theorem finRotate_val' (c : ℕ) (q : Fin (c + 1)) : + (finRotate (c + 1) q).val = if q.val = c then 0 else q.val + 1 := by + have h := congrArg Fin.val (finRotate_apply q) + rw [Fin.val_add_one] at h + rw [h] + by_cases hq : q.val = c + · rw [ite_eq_left (Fin.ext hq : q = Fin.last c), ite_eq_left hq] + · rw [ite_eq_right (show q ≠ Fin.last c from fun h => + hq (congrArg Fin.val h)), ite_eq_right hq] + +/-- `blockPerm n (finRotate (c+1))` equals `blockRot (n*c) n`: +both rotate strands by n modulo n*(c+1). -/ +theorem blockPerm_finRotate_eq_blockRot (n c : ℕ) : + blockPerm n (finRotate (c + 1)) = blockRot (n * c) n := by + by_cases hn : n = 0 + · subst hn; ext x; exact absurd x.isLt (by omega) + · have hn' : 0 < n := Nat.pos_of_ne_zero hn + ext x : 1 + apply Fin.ext + -- Decompose x = n * q + r + set q := x.val / n + set r := x.val % n + have hx_eq : x.val = n * q + r := (Nat.div_add_mod x.val n).symm + have hq_lt : q < c + 1 := by + apply Nat.div_lt_of_lt_mul + show x.val < n * (c + 1) + exact x.isLt + have hr_lt : r < n := Nat.mod_lt _ hn' + -- LHS: blockPerm_val + have hbp := congrArg Fin.val + (blockPerm_val n (finRotate (c + 1)) ⟨q, hq_lt⟩ ⟨r, hr_lt⟩) + -- RHS: blockRot_val' + have hbr := blockRot_val (n * c) n x + -- Reconstruct x as ⟨n * q + r, _⟩ + have hx_mk : x = ⟨n * q + r, by rw [← hx_eq]; exact x.isLt⟩ := + Fin.ext hx_eq + -- Compute both sides' values + have lhs_val : (blockPerm n (finRotate (c + 1)) x).val = + n * (finRotate (c + 1) ⟨q, hq_lt⟩).val + r := by + conv_lhs => rw [hx_mk] + exact hbp + have rhs_val : (blockRot (n * c) n x).val = + if n * q + r < n * c then n + (n * q + r) + else n * q + r - (n * c) := by + rw [hbr, hx_eq] + rw [lhs_val, rhs_val, finRotate_val' c ⟨q, hq_lt⟩] + by_cases hqc : q = c + · -- q = c: finRotate wraps, blockRot wraps + rw [ite_eq_left hqc, hqc, ite_eq_right (by omega), + show n * (0 : ℕ) = 0 from mul_zero n, zero_add] + omega + · -- q ≠ c: finRotate shifts, blockRot shifts + have hqc' : q + 1 ≤ c := by omega + rw [ite_eq_right hqc, + ite_eq_left (show n * q + r < n * c from + by nlinarith [Nat.mul_le_mul_left n hqc'])] + ring + +/-! ### Trace and interchange for the block tensor -/ + +/-- Trace of a block tensor product. -/ +theorem skeinTrace_blockTensorEnd {a b : ℕ} + (u : skeinEnd f a) (v : skeinEnd f b) : + skeinTrace f (a + b) (blockTensorEnd f u v) = + skeinTrace f a u * skeinTrace f b v := + skeinTrace_tensorHom f u v + +/-- Interchange law for blockTensorEnd multiplication. -/ +theorem blockTensorEnd_mul {a b : ℕ} + (u₁ u₂ : skeinEnd f a) (v₁ v₂ : skeinEnd f b) : + blockTensorEnd f u₁ v₁ * blockTensorEnd f u₂ v₂ = + blockTensorEnd f (u₁ * u₂) (v₁ * v₂) := + MonoidalCategory.tensorHom_comp_tensorHom + (u₂ : SkeinObj.mk (f := f) a ⟶ SkeinObj.mk a) + (v₂ : SkeinObj.mk (f := f) b ⟶ SkeinObj.mk b) + (u₁ : SkeinObj.mk (f := f) a ⟶ SkeinObj.mk a) + (v₁ : SkeinObj.mk (f := f) b ⟶ SkeinObj.mk b) + +/-! ### The rotation step at fragments -/ + +-- Five fragment equivalences are chained on each +-- side of the closure before the splice applies. +/-- Core fragment-level identity for the block rotation step: +the trace of a rotated tensor equals the trace of the spliced +composite at one lower block arity. -/ +private theorem fragTrace_block_rot_step_core (K n : ℕ) + (𝔄 : Fragment (Fin ((K + n) + (K + n)))) + (𝔊 : Fragment (Fin (n + n))) : + fragTrace f.val + ((tensorFragment 𝔄 𝔊).compose + (permFragment (blockRot (K + n) n))) = + fragTrace f.val + ((𝔄.compose (tensorFragment (strandBundle K) 𝔊)).compose + (permFragment (blockRot K n))) := by + -- E_L: decompose the LHS closure + have E1 := pairCloseCongr + (composePermFragment (s := (K + n) + n) (t := (K + n) + n) + (blockRot (K + n) n) + (tensorFragment 𝔄 𝔊)) + (Fragment.Equiv.refl (strandBundle (K + n + n))) + have E2 := pairCloseRelabelPerm + (outPermEquiv (K + n + n) (blockRot (K + n) n)) + (tensorFragment (s := K + n) (t := K + n) (u := n) (v := n) + 𝔄 𝔊) (strandBundle (K + n + n)) + have E3 := pairCloseCongr + (Fragment.Equiv.refl (tensorFragment (s := K + n) (t := K + n) + (u := n) (v := n) 𝔄 𝔊)) + (Fragment.Equiv.relabelEq (strandBundle (K + n + n)) + (outPermEquiv_symm (K + n + n) (blockRot (K + n) n))) + have E4 := pairCloseCongr + (Fragment.Equiv.refl (tensorFragment (s := K + n) (t := K + n) + (u := n) (v := n) 𝔄 𝔊)) + (permFragmentRelabelOutPerm + (blockRot (K + n) n).symm).symm + have E5 := pairCloseTensorAbsorb 𝔄 𝔊 + (permFragment (blockRot (K + n) n).symm) + have E_L : (pairClose + ((tensorFragment 𝔄 𝔊).compose + (permFragment (blockRot (K + n) n))) + (strandBundle (K + n + n))).Equiv + (pairClose 𝔄 + (partialClose 𝔊 + (permFragment (blockRot (K + n) n).symm))) := + E1.trans (E2.trans (E3.trans (E4.trans E5))) + -- E_R: decompose the RHS closure + have E_R : (pairClose + ((𝔄.compose (tensorFragment (strandBundle K) 𝔊)).compose + (permFragment (blockRot K n))) + (strandBundle (K + n))).Equiv + (pairClose 𝔄 + ((permFragment (blockRot K n).symm).compose + ((tensorFragment (strandBundle K) 𝔊).relabel + (transposeEquiv (K + n) (K + n))))) := + (pairCloseCongr + (composePermFragment (blockRot K n) + (𝔄.compose (tensorFragment (strandBundle K) 𝔊))) + (Fragment.Equiv.refl _)).trans + ((pairCloseRelabelPerm + (outPermEquiv (K + n) (blockRot K n)) _ _).trans + ((pairCloseCongr (Fragment.Equiv.refl _) + (Fragment.Equiv.relabelEq _ + (outPermEquiv_symm (K + n) + (blockRot K n)))).trans + ((pairCloseCongr (Fragment.Equiv.refl _) + (permFragmentRelabelOutPerm + (blockRot K n).symm).symm).trans + (pairCloseComposeRotate 𝔄 + (tensorFragment (strandBundle K) 𝔊) + (permFragment (blockRot K n).symm))))) + -- Conclude by iso-invariance and the block splice + exact f.iso_invariant _ _ + (E_L.trans + ((pairCloseCongr (Fragment.Equiv.refl 𝔄) + (partialCloseBlockSplice K n 𝔊)).trans + E_R.symm)) + +/-! ### The rotation step at trace values -/ + +/-- The block rotation step: the trace at `K+n+n` strands +of (blockRot * tensor) equals the trace at `K+n` strands +of (blockRot * pad * accumulated). -/ +theorem skeinTrace_block_rot_step (K n : ℕ) (A : skeinEnd f (K + n)) + (g : skeinEnd f n) : + skeinTrace f (K + n + n) + (permClass f (K + n + n) (blockRot (K + n) n) * + blockTensorEnd f A g) = + skeinTrace f (K + n) + (permClass f (K + n) (blockRot K n) * + (blockTensorEnd f (1 : skeinEnd f K) g * A)) := by + -- Unfold definitions to HomSpace operations + change HomSpace.traceMap f.val (K + n + n) + (HomSpace.comp f (K + n + n) (K + n + n) (K + n + n) + (HomSpace.tensor f (K + n) (K + n) n n A g) + (HomSpace.ofFragment f.val + (permFragment (blockRot (K + n) n)))) = + HomSpace.traceMap f.val (K + n) + (HomSpace.comp f (K + n) (K + n) (K + n) + (HomSpace.comp f (K + n) (K + n) (K + n) A + (HomSpace.tensor f K K n n + (HomSpace.ofFragment f.val (strandBundle K)) g)) + (HomSpace.ofFragment f.val + (permFragment (blockRot K n)))) + -- Lift A and g to free-module representatives + obtain ⟨xa, rfl⟩ := Submodule.Quotient.mk_surjective _ A + obtain ⟨xg, rfl⟩ := Submodule.Quotient.mk_surjective _ g + -- Convert to Finsupp level + change traceFunctional f.val (K + n + n) + (composeFinsupp (K + n + n) (K + n + n) (K + n + n) + (tensorFinsupp (K + n) (K + n) n n xa xg) + (Finsupp.single (permFragment (blockRot (K + n) n)) 1)) = + traceFunctional f.val (K + n) + (composeFinsupp (K + n) (K + n) (K + n) + (composeFinsupp (K + n) (K + n) (K + n) xa + (tensorFinsupp K K n n + (Finsupp.single (strandBundle K) 1) xg)) + (Finsupp.single (permFragment (blockRot K n)) 1)) + -- Helper: traceFunctional on a scaled single fragment + have htr : ∀ (m : ℕ) (H : Fragment (Fin (m + m))) (e : ℂ), + traceFunctional f.val m (Finsupp.single H e) = + e * fragTrace f.val H := by + intro m H e + rw [show (Finsupp.single H e : Fragment (Fin (m + m)) →₀ ℂ) = + e • Finsupp.single H 1 by + rw [Finsupp.smul_single, smul_eq_mul, mul_one], + map_smul, traceFunctional_single, smul_eq_mul] + -- Bilinear induction on xa + induction xa using Finsupp.induction_linear with + | zero => + simp only [map_zero, LinearMap.zero_apply] + | add x₁ x₂ h₁ h₂ => + simp only [map_add, LinearMap.add_apply] + rw [h₁, h₂] + | single 𝔄 c => + -- Inner induction on xg + induction xg using Finsupp.induction_linear with + | zero => + simp only [map_zero, LinearMap.zero_apply] + | add y₁ y₂ h₁ h₂ => + simp only [map_add, LinearMap.add_apply] + rw [h₁, h₂] + | single 𝔊 d => + -- At fragment classes: reduce to fragTrace_block_rot_step_core + rw [tensorFinsupp_single, composeFinsupp_single, + tensorFinsupp_single, composeFinsupp_single, + composeFinsupp_single, htr, htr, + fragTrace_block_rot_step_core f K n 𝔄 𝔊] + ring + +/-! ### The block tuple tensor and the block cycle composite -/ + +/-- The block tuple tensor: tensor product of a tuple of +`n`-strand endomorphisms, as an endomorphism of the `n*k`-strand +object. -/ +noncomputable def blockTupleTensor (n : ℕ) : + ∀ k : ℕ, (Fin k → skeinEnd f n) → skeinEnd f (n * k) + | 0, _ => 1 + | k + 1, G => + blockTensorEnd f + (blockTupleTensor n k (fun i => G i.castSucc)) + (G (Fin.last k)) + +/-- The block cycle composite: `G(k-1) * ⋯ * G(0)` in the +`n`-strand endomorphism algebra. -/ +noncomputable def blockCycleComp (n : ℕ) : + ∀ k : ℕ, (Fin k → skeinEnd f n) → skeinEnd f n + | 0, _ => 1 + | k + 1, G => + G (Fin.last k) * blockCycleComp n k (fun i => G i.castSucc) + +/-! ### Padding and updating the tuple -/ + +/-- The padded product updates the last tuple entry. -/ +theorem blockPadLeft_mul_blockTupleTensor (K n : ℕ) + (H : Fin (K + 1) → skeinEnd f n) (g : skeinEnd f n) : + blockTensorEnd f (1 : skeinEnd f (n * K)) g * + blockTupleTensor f n (K + 1) H = + blockTupleTensor f n (K + 1) + (Function.update H (Fin.last K) + (g * H (Fin.last K))) := by + rw [show blockTupleTensor f n (K + 1) H = + blockTensorEnd f + (blockTupleTensor f n K (fun i => H i.castSucc)) + (H (Fin.last K)) from rfl] + rw [show blockTupleTensor f n (K + 1) + (Function.update H (Fin.last K) + (g * H (Fin.last K))) = + blockTensorEnd f + (blockTupleTensor f n K (fun i => + Function.update H (Fin.last K) + (g * H (Fin.last K)) i.castSucc)) + (Function.update H (Fin.last K) + (g * H (Fin.last K)) (Fin.last K)) + from rfl] + rw [Function.update_self] + have hinit : (fun i : Fin K => + Function.update H (Fin.last K) + (g * H (Fin.last K)) i.castSucc) = + fun i => H i.castSucc := by + funext i + exact Function.update_of_ne + (Fin.castSucc_lt_last i).ne _ _ + rw [hinit] + rw [blockTensorEnd_mul, one_mul] + +/-- The cycle composite of a last-entry update: the padding +factor peels off. -/ +theorem blockCycleComp_update_last (K n : ℕ) + (H : Fin (K + 1) → skeinEnd f n) (g : skeinEnd f n) : + blockCycleComp f n (K + 1) + (Function.update H (Fin.last K) (g * H (Fin.last K))) = + g * blockCycleComp f n (K + 1) H := by + rw [show blockCycleComp f n (K + 1) + (Function.update H (Fin.last K) (g * H (Fin.last K))) = + Function.update H (Fin.last K) (g * H (Fin.last K)) + (Fin.last K) * + blockCycleComp f n K (fun i => + Function.update H (Fin.last K) + (g * H (Fin.last K)) i.castSucc) from rfl] + rw [Function.update_self] + have hinit : (fun i : Fin K => + Function.update H (Fin.last K) + (g * H (Fin.last K)) i.castSucc) = + fun i => H i.castSucc := by + funext i + exact Function.update_of_ne + (Fin.castSucc_lt_last i).ne _ _ + rw [hinit] + rw [show blockCycleComp f n (K + 1) H = H (Fin.last K) * + blockCycleComp f n K (fun i => H i.castSucc) from rfl] + rw [mul_assoc] + +/-! ### The cycle induction -/ + +/-- **The block cycle-trace lemma**: the trace of a block +rotation composed with a block tuple tensor is the trace of the +block cycle composite. -/ +theorem skeinTrace_block_cycle (n k : ℕ) + (G : Fin (k + 1) → skeinEnd f n) : + skeinTrace f (n * (k + 1)) + (permClass f (n * (k + 1)) + (blockPerm n (finRotate (k + 1))) * + blockTupleTensor f n (k + 1) G) = + skeinTrace f n (blockCycleComp f n (k + 1) G) := by + induction k with + | zero => + -- finRotate 1 = 1 + have hrot : finRotate 1 = 1 := Subsingleton.elim _ _ + rw [hrot, blockPerm_one] + rw [show permClass f (n * 1) (1 : Equiv.Perm (Fin (n * 1))) = + (1 : skeinEnd f (n * 1)) from map_one (permToEnd f (n * 1))] + rw [one_mul] + -- blockTupleTensor f n 1 G = blockTensorEnd f 1 (G 0) + rw [show blockTupleTensor f n 1 G = + blockTensorEnd f (1 : skeinEnd f (n * 0)) (G 0) from rfl] + -- Make additive structure visible for skeinTrace_blockTensorEnd + change skeinTrace f (0 + n) (blockTensorEnd f (1 : skeinEnd f 0) (G 0)) = + skeinTrace f n (blockCycleComp f n 1 G) + -- trace splits: skeinTrace f 0 1 * skeinTrace f n (G 0) + rw [skeinTrace_blockTensorEnd] + rw [skeinTrace_zero_one, one_mul] + -- blockCycleComp f n 1 G = G 0 * 1 = G 0 + rw [show blockCycleComp f n 1 G = + G (Fin.last 0) * (1 : skeinEnd f n) from rfl] + rw [show (Fin.last 0 : Fin 1) = (0 : Fin 1) from rfl] + rw [mul_one] + | succ m ih => + -- Unfold blockTupleTensor at m+2 + rw [show blockTupleTensor f n (m + 2) G = + blockTensorEnd f + (blockTupleTensor f n (m + 1) + (fun i => G i.castSucc)) + (G (Fin.last (m + 1))) from rfl] + -- Bridge: blockPerm n (finRotate (m+2)) = blockRot (n*(m+1)) n + rw [blockPerm_finRotate_eq_blockRot] + -- Make additive structure visible for the rot step + change skeinTrace f (n * m + n + n) + (permClass f (n * m + n + n) (blockRot (n * m + n) n) * + blockTensorEnd f + (blockTupleTensor f n (m + 1) (fun i => G i.castSucc)) + (G (Fin.last (m + 1)))) = + skeinTrace f n (blockCycleComp f n (m + 2) G) + -- Apply the block rotation step (K = n*m) + rw [skeinTrace_block_rot_step] + -- Fold the padding into the tuple + rw [blockPadLeft_mul_blockTupleTensor] + -- Bridge back: blockRot (n*m) n = blockPerm n (finRotate (m+1)) + rw [← blockPerm_finRotate_eq_blockRot] + -- Reshape arity for IH: n * m + n ≡ n * (m + 1) + change skeinTrace f (n * (m + 1)) + (permClass f (n * (m + 1)) (blockPerm n (finRotate (m + 1))) * + blockTupleTensor f n (m + 1) + (Function.update (fun i => G i.castSucc) (Fin.last m) + (G (Fin.last (m + 1)) * G (Fin.last m).castSucc))) = + skeinTrace f n (blockCycleComp f n (m + 2) G) + -- Apply IH + rw [ih] + -- Fold the cycle composite + rw [blockCycleComp_update_last] + -- Match the cycle composite definition + rw [show blockCycleComp f n (m + 2) G = + G (Fin.last (m + 1)) * + blockCycleComp f n (m + 1) (fun i => G i.castSucc) + from rfl] + +/-! ### Constant tuples -/ + +/-- The block cycle composite of a constant tuple is the power. -/ +theorem blockCycleComp_const (n k : ℕ) (g : skeinEnd f n) : + blockCycleComp f n k (fun _ => g) = g ^ k := by + induction k with + | zero => + rw [pow_zero] + rfl + | succ k ih => + rw [show blockCycleComp f n (k + 1) (fun _ => g) = + g * blockCycleComp f n k (fun _ => g) from rfl, + ih, ← pow_succ'] + +/-- The block tuple tensor of a constant tuple is the block +power. -/ +theorem blockTupleTensor_const (n k : ℕ) (g : skeinEnd f n) : + blockTupleTensor f n k (fun _ => g) = blockPow f n g k := by + induction k with + | zero => rfl + | succ k ih => + rw [show blockTupleTensor f n (k + 1) (fun _ => g) = + blockTensorEnd f + (blockTupleTensor f n k (fun _ => g)) g from rfl, + ih] + rfl + +/-! ### The block cycle trace -/ + +/-- **The block cycle trace**: closing the block rotation against +`c+1` diagonal blocks yields the trace of the `(c+1)`-th power. -/ +theorem skeinTrace_blockCycle' (n : ℕ) (g : skeinEnd f n) (c : ℕ) : + skeinTrace f (n * (c + 1)) + (permClass f (n * (c + 1)) (blockPerm n (finRotate (c + 1))) * + blockPow f n g (c + 1)) = + skeinTrace f n (g ^ (c + 1)) := by + rw [← blockTupleTensor_const, + skeinTrace_block_cycle, + blockCycleComp_const] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactor.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactor.lean new file mode 100644 index 0000000000..8959e23d4d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactor.lean @@ -0,0 +1,970 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockCycle + +/-! +# The block trace factorization + +The trace of a block permutation against the block-diagonal power +factors into cycle traces of the block endomorphism — the engine +of the Frobenius identity at every ambient arity. + +The `S_k`-level cycle normal form transports through the +block-permutation homomorphism for free; the tensor-splitting +slices carry `finCongr` casts because `n·(a+b) = n·a + n·b` is +propositional, managed by the arity-cast transport `endCast`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-! ### Trace cyclicity -/ + +/-- The skein trace is cyclic. -/ +private theorem skeinTrace_mul_comm' (n : ℕ) + (u v : skeinEnd f n) : + skeinTrace f n (u * v) = skeinTrace f n (v * u) := + HomSpace.traceMap_comp_comm f v u + +/-- The skein trace is conjugation invariant. -/ +private theorem skeinTrace_conj' (n : ℕ) + (σ : Equiv.Perm (Fin n)) (x : skeinEnd f n) : + skeinTrace f n + (permClass f n σ * x * permClass f n σ⁻¹) = + skeinTrace f n x := by + rw [skeinTrace_mul_comm', ← mul_assoc, + show permClass f n σ⁻¹ * permClass f n σ = + permClass f n (σ⁻¹ * σ) from + (map_mul (permToEnd f n) σ⁻¹ σ).symm, + inv_mul_cancel, + show permClass f n (1 : Equiv.Perm (Fin n)) = + (1 : skeinEnd f n) from map_one (permToEnd f n), + one_mul] + +/-! ### Arity-cast transport -/ + +/-- Transport of a strand endomorphism along an arity equality: +conjugation by the boundary cast. -/ +noncomputable def endCast {a b : ℕ} (h : a = b) + (x : skeinEnd f a) : skeinEnd f b := + h ▸ x + +/-- Cast transport preserves the trace. -/ +theorem skeinTrace_endCast {a b : ℕ} (h : a = b) + (x : skeinEnd f a) : + skeinTrace f b (endCast f h x) = skeinTrace f a x := by + cases h + rfl + +/-- Cast transport is multiplicative. -/ +theorem endCast_mul {a b : ℕ} (h : a = b) + (x y : skeinEnd f a) : + endCast f h (x * y) = endCast f h x * endCast f h y := by + cases h + rfl + +/-! ### Block tensor calculus -/ + +/-- Arity cast interacts with `permClass`: transporting a permutation +class along an arity equality gives the permutation class of the +cast permutation. -/ +private theorem endCast_permClass {a b : ℕ} (h : a = b) + (σ : Equiv.Perm (Fin a)) : + endCast f h (permClass f a σ) = + permClass f b ((finCongr h).permCongr σ) := by + subst h + change permClass f a σ = permClass f a _ + congr 1 + +/-- `permClass_sumCongr` stated for `blockTensorEnd`. -/ +private theorem permClass_blockTensorEnd (a b : ℕ) + (σ : Equiv.Perm (Fin a)) (τ : Equiv.Perm (Fin b)) : + permClass f (a + b) + (finSumFinEquiv.permCongr (Equiv.sumCongr σ τ)) = + blockTensorEnd f (permClass f a σ) (permClass f b τ) := + permClass_sumCongr f a b σ τ + +/-- Block-wise commutativity lifts through the block tensor. -/ +private theorem blockTensorEnd_comm {a b : ℕ} + (P G : skeinEnd f a) (Q H : skeinEnd f b) + (hPG : P * G = G * P) (hQH : Q * H = H * Q) : + blockTensorEnd f P Q * blockTensorEnd f G H = + blockTensorEnd f G H * blockTensorEnd f P Q := by + rw [blockTensorEnd_mul, hPG, hQH, ← blockTensorEnd_mul] + +/-- `bundleMapClass` of a self-cast is the identity class. -/ +private theorem bmc_finCongr_self {n : ℕ} (h : n = n) : + bundleMapClass f (finCongr h) = + HomSpace.ofFragment f.val (strandBundle n) := by + rw [show finCongr h = _root_.Equiv.refl (Fin n) from + _root_.Equiv.ext (fun x => Fin.ext rfl)] + exact bundleMapClass_refl f n + +/-- `bundleMapClass` of the symm of a self-cast is the identity. -/ +private theorem bmc_finCongr_symm_self {n : ℕ} (h : n = n) : + bundleMapClass f ((finCongr h).symm) = + HomSpace.ofFragment f.val (strandBundle n) := by + rw [show (finCongr h).symm = _root_.Equiv.refl (Fin n) from + _root_.Equiv.ext (fun x => Fin.ext rfl)] + exact bundleMapClass_refl f n + +/-- `endCast` is conjugation by `bundleMapClass (finCongr h)`. -/ +private theorem endCast_eq_conj {a b : ℕ} (h : a = b) + (x : skeinEnd f a) : + (h ▸ x : skeinEnd f b) = + HomSpace.comp f b a b + (bundleMapClass f ((finCongr h).symm)) + (HomSpace.comp f a a b + (x : SkeinObj.mk (f := f) a ⟶ SkeinObj.mk a) + (bundleMapClass f (finCongr h))) := by + cases h + -- After cases h, b = a, need x = comp(bmc(.symm), comp(x, bmc(.))) + -- Use ∀-quantified key to avoid type-mismatch at implicit transparency + have key : ∀ (p : a = a), + HomSpace.comp f a a a + (bundleMapClass f ((finCongr p).symm)) + (HomSpace.comp f a a a + (show HomSpace f.val (a + a) from x) + (bundleMapClass f (finCongr p))) = + (show HomSpace f.val (a + a) from x) := by + intro p + rw [bmc_finCongr_self f p, bmc_finCongr_symm_self f p, + HomSpace.comp_id_right, HomSpace.comp_id_left] + exact (key _).symm + +/-- Pushing `endCast` through the left argument of `blockTensorEnd`. -/ +private theorem endCast_blockTensorEnd_left {a a' b : ℕ} (h : a = a') + (u : skeinEnd f a) (v : skeinEnd f b) : + blockTensorEnd f (endCast f h u) v = + endCast f (show a + b = a' + b by rw [h]) (blockTensorEnd f u v) := by + cases h; rfl + +/-- Composing two `endCast` transports. -/ +private theorem endCast_trans {a b c : ℕ} (h₁ : a = b) (h₂ : b = c) + (x : skeinEnd f a) : + endCast f h₂ (endCast f h₁ x) = endCast f (h₁.trans h₂) x := by + cases h₂; cases h₁; rfl + +/-- An `endCast` along a self-equality is the identity. -/ +private theorem endCast_rfl (x : skeinEnd f a) (h : a = a) : + endCast f h x = x := by + have : h = Eq.refl a := rfl + subst this; rfl + +/-- Tensor with the zero-arity identity is the identity. -/ +private theorem blockTensorEnd_one_right (x : skeinEnd f a) : + blockTensorEnd f x (1 : skeinEnd f 0) = x := by + have h := rightUnitNat_class f (show HomSpace f.val (a + a) from x) + have hcast : ∀ hp : a + 0 = a, + bundleMapClass f (finCongr hp) = + HomSpace.ofFragment f.val (strandBundle a) := by + intro hp + rw [show finCongr hp = _root_.Equiv.refl (Fin a) from + _root_.Equiv.ext (fun x => Fin.ext rfl)] + exact bundleMapClass_refl f a + simp only [hcast] at h + exact (HomSpace.comp_id_right f a a + (blockTensorEnd f x (1 : skeinEnd f 0))).symm.trans + (h.trans (HomSpace.comp_id_left f a a x)) + +-- Associativity is stated up to an arity cast, so +-- the cast transport is unfolded on both sides. +/-- Tensor associativity for `blockTensorEnd`, up to `endCast`. -/ +private theorem blockTensor_assoc {a b c : ℕ} + (p₁ : skeinEnd f a) (p₂ : skeinEnd f b) (p₃ : skeinEnd f c) : + endCast f (show (a + b) + c = a + (b + c) by omega) + (blockTensorEnd f (blockTensorEnd f p₁ p₂) p₃) = + blockTensorEnd f p₁ (blockTensorEnd f p₂ p₃) := by + set h : (a + b) + c = a + (b + c) := by omega + -- Rewrite endCast as conjugation by the associator + change (h ▸ blockTensorEnd f (blockTensorEnd f p₁ p₂) p₃ : + skeinEnd f (a + (b + c))) = + blockTensorEnd f p₁ (blockTensorEnd f p₂ p₃) + rw [endCast_eq_conj f h] + -- Use associator naturality + have hassoc := assocNat_class f + (show HomSpace f.val (a + a) from p₁) + (show HomSpace f.val (b + b) from p₂) + (show HomSpace f.val (c + c) from p₃) + -- Rewrite the inner composition using hassoc + conv_lhs => + rw [show HomSpace.comp f ((a + b) + c) ((a + b) + c) (a + (b + c)) + (show HomSpace f.val (((a + b) + c) + ((a + b) + c)) from + blockTensorEnd f (blockTensorEnd f p₁ p₂) p₃) + (bundleMapClass f (finCongr h)) = + HomSpace.comp f ((a + b) + c) (a + (b + c)) (a + (b + c)) + (bundleMapClass f (finCongr h)) + (show HomSpace f.val ((a + (b + c)) + (a + (b + c))) from + blockTensorEnd f p₁ (blockTensorEnd f p₂ p₃)) from hassoc] + -- Now: comp(α⁻¹, comp(α, RHS)) = RHS + rw [← HomSpace.comp_assoc] + -- comp(comp(α⁻¹, α), RHS) = RHS + have hcancel : HomSpace.comp f (a + (b + c)) ((a + b) + c) (a + (b + c)) + (bundleMapClass f ((finCongr h).symm)) + (bundleMapClass f (finCongr h)) = + HomSpace.ofFragment f.val (strandBundle (a + (b + c))) := by + rw [bundleMapClass_comp, + show (finCongr h).symm.trans (finCongr h) = + _root_.Equiv.refl (Fin (a + (b + c))) from + _root_.Equiv.ext (fun x => by simp [finCongr])] + exact bundleMapClass_refl f _ + rw [hcancel, HomSpace.comp_id_left] + +/-- `blockPow` splits as a tensor of two parts, modulo arity cast. -/ +private theorem blockPow_split (n : ℕ) (g : skeinEnd f n) (a : ℕ) : + ∀ b : ℕ, + endCast f (Nat.mul_add n a b) (blockPow f n g (a + b)) = + blockTensorEnd f (blockPow f n g a) (blockPow f n g b) := by + intro b + induction b with + | zero => + change blockPow f n g a = + blockTensorEnd f (blockPow f n g a) (1 : skeinEnd f (n * 0)) + exact (blockTensorEnd_one_right f (blockPow f n g a)).symm + | succ k ih => + -- blockPow (a + (k+1)) = blockTensorEnd f (blockPow (a+k)) g + change endCast f (Nat.mul_add n a (k + 1)) + (blockTensorEnd f (blockPow f n g (a + k)) g) = + blockTensorEnd f (blockPow f n g a) + (blockTensorEnd f (blockPow f n g k) g) + -- Substitute blockPow (a+k) using IH + have hih : blockPow f n g (a + k) = + endCast f (Nat.mul_add n a k).symm + (blockTensorEnd f (blockPow f n g a) + (blockPow f n g k)) := by + rw [← ih, endCast_trans, endCast_rfl] + rw [hih, endCast_blockTensorEnd_left, endCast_trans] + -- Now have: endCast f h ((blockPow a ⊗ blockPow k) ⊗ g) + exact blockTensor_assoc f + (blockPow f n g a) (blockPow f n g k) g + +/-- `blockPerm n` distributes over `sumCongr`, modulo arity cast. -/ +private theorem blockPerm_sumCongr (n : ℕ) {a b : ℕ} + (σ : Equiv.Perm (Fin a)) (τ : Equiv.Perm (Fin b)) : + (finCongr (Nat.mul_add n a b)).permCongr + (blockPerm n (finSumFinEquiv.permCongr (Equiv.sumCongr σ τ))) = + finSumFinEquiv.permCongr + (Equiv.sumCongr (blockPerm n σ) (blockPerm n τ)) := by + by_cases hn : n = 0 + · -- ═══════ n = 0: THE INDEX TYPE IS EMPTY ═══════ + subst hn; ext ⟨v, hv⟩; simp at hv + · -- ═══════ 0 < n ═══════ + have hn' : 0 < n := Nat.pos_of_ne_zero hn + ext ⟨v, hv⟩ + -- Goal is a .val equality after ext + -- Decompose v = n * q + r + have hv' : v < n * (a + b) := by + calc v < n * a + n * b := hv + _ = n * (a + b) := (Nat.mul_add n a b).symm + have hqab : v / n < a + b := Nat.div_lt_of_lt_mul hv' + have hrn : v % n < n := Nat.mod_lt v hn' + have hv_eq : v = n * (v / n) + v % n := (Nat.div_add_mod v n).symm + -- Compute LHS via blockPerm_val + set π := finSumFinEquiv.permCongr (Equiv.sumCongr σ τ) with hπ_def + have hbp_lhs := blockPerm_val n π ⟨v / n, hqab⟩ ⟨v % n, hrn⟩ + -- LHS.val = n * (π ⟨v/n, _⟩).val + v%n + have hLHS : ((finCongr (Nat.mul_add n a b)).permCongr + (blockPerm n π) ⟨v, hv⟩).val = + n * (π ⟨v / n, hqab⟩).val + v % n := by + rw [Equiv.permCongr_apply] + rw [show ((finCongr (Nat.mul_add n a b)).symm ⟨v, hv⟩ : + Fin (n * (a + b))) = + ⟨n * (v / n) + v % n, hv_eq ▸ hv'⟩ from Fin.ext hv_eq] + rw [hbp_lhs] + rfl + -- Case split on v / n < a + by_cases hqa : v / n < a + · -- v is in the first a blocks + have hvna : v < n * a := by + have := (Nat.div_lt_iff_lt_mul hn').mp hqa -- v < a * n + calc v < a * n := this + _ = n * a := Nat.mul_comm a n + -- Compute π(v/n) = σ(v/n) + have hπq : (π ⟨v / n, hqab⟩).val = (σ ⟨v / n, hqa⟩).val := by + rw [hπ_def] + change (finSumFinEquiv (Equiv.sumCongr σ τ + (finSumFinEquiv.symm ⟨v / n, hqab⟩))).val = _ + rw [show (⟨v / n, hqab⟩ : Fin (a + b)) = + Fin.castAdd b ⟨v / n, hqa⟩ from Fin.ext rfl, + finSumFinEquiv_symm_apply_castAdd] + simp [Equiv.sumCongr_apply, finSumFinEquiv_apply_left, + Fin.castAdd] + -- Compute RHS: v < n*a, so in left summand + have hRHS : (finSumFinEquiv.permCongr + (Equiv.sumCongr (blockPerm n σ) (blockPerm n τ)) + ⟨v, hv⟩).val = + n * (σ ⟨v / n, hqa⟩).val + v % n := by + change (finSumFinEquiv (Equiv.sumCongr (blockPerm n σ) + (blockPerm n τ) (finSumFinEquiv.symm ⟨v, hv⟩))).val = _ + rw [show (⟨v, hv⟩ : Fin (n * a + n * b)) = + Fin.castAdd (n * b) ⟨v, hvna⟩ from Fin.ext rfl, + finSumFinEquiv_symm_apply_castAdd] + simp only [Equiv.sumCongr_apply] + conv_lhs => + rw [show (⟨v, hvna⟩ : Fin (n * a)) = + ⟨n * (v / n) + v % n, hv_eq ▸ hvna⟩ from Fin.ext hv_eq] + exact congrArg Fin.val + (blockPerm_val n σ ⟨v / n, hqa⟩ ⟨v % n, hrn⟩) + rw [hLHS, hπq, hRHS] + · -- v is in the last b blocks (v / n ≥ a) + have hqa' : a ≤ v / n := Nat.le_of_not_lt hqa + have hvna : n * a ≤ v := by + calc n * a + _ = a * n := Nat.mul_comm n a + _ ≤ (v / n) * n := Nat.mul_le_mul_right n hqa' + _ ≤ v := Nat.div_mul_le_self v n + have hqb : v / n - a < b := by omega + -- Compute π(v/n) = a + τ(v/n - a) + have hπq : (π ⟨v / n, hqab⟩).val = + a + (τ ⟨v / n - a, hqb⟩).val := by + rw [hπ_def] + change (finSumFinEquiv (Equiv.sumCongr σ τ + (finSumFinEquiv.symm ⟨v / n, hqab⟩))).val = _ + rw [show (⟨v / n, hqab⟩ : Fin (a + b)) = + Fin.natAdd a ⟨v / n - a, hqb⟩ from + Fin.ext (show v / n = a + (v / n - a) by omega), + finSumFinEquiv_symm_apply_natAdd] + simp [Equiv.sumCongr_apply, finSumFinEquiv_apply_right, + Fin.natAdd] + -- Shift arithmetic + have h_nsub : n * (v / n - a) + n * a = n * (v / n) := by + rw [← Nat.mul_add, Nat.sub_add_cancel hqa'] + have h_shift : v - n * a = n * (v / n - a) + v % n := by + have := (Nat.div_add_mod v n).symm; omega + have hshift_div : (v - n * a) / n = v / n - a := by + rw [h_shift, Nat.mul_add_div hn', Nat.div_eq_of_lt hrn] + omega + have hshift_mod : (v - n * a) % n = v % n := by + rw [h_shift, Nat.mul_add_mod, Nat.mod_eq_of_lt hrn] + -- Pre-compute blockPerm on the shifted element + have hbp_shifted : (blockPerm n τ + ⟨v - n * a, by omega⟩).val = + n * (τ ⟨v / n - a, hqb⟩).val + v % n := by + have hbound' : n * (v / n - a) + v % n < n * b := by + rw [show n * (v / n - a) + v % n = v - n * a from + h_shift.symm]; omega + conv_lhs => + rw [show (⟨v - n * a, (by omega : v - n * a < n * b)⟩ : + Fin (n * b)) = + ⟨n * (v / n - a) + v % n, hbound'⟩ from + Fin.ext h_shift] + exact congrArg Fin.val + (blockPerm_val n τ ⟨v / n - a, hqb⟩ ⟨v % n, hrn⟩) + -- Compute RHS + have hRHS : (finSumFinEquiv.permCongr + (Equiv.sumCongr (blockPerm n σ) (blockPerm n τ)) + ⟨v, hv⟩).val = + n * a + (n * (τ ⟨v / n - a, hqb⟩).val + v % n) := by + change (finSumFinEquiv (Equiv.sumCongr (blockPerm n σ) + (blockPerm n τ) (finSumFinEquiv.symm ⟨v, hv⟩))).val = _ + rw [show (⟨v, hv⟩ : Fin (n * a + n * b)) = + Fin.natAdd (n * a) ⟨v - n * a, by omega⟩ from + Fin.ext (Nat.add_sub_cancel' hvna).symm, + finSumFinEquiv_symm_apply_natAdd] + simp only [Equiv.sumCongr_apply, Sum.map_inr, + finSumFinEquiv_apply_right, Fin.natAdd, Fin.val_mk] + congr 1 + rw [hLHS, hπq, hRHS]; ring + +/-! ### Braiding commutativity at block arities -/ + +-- The commutation is checked at the HomSpace level, +-- where the tensor and the bundle map both expand. +/-- The braiding `β_{n,n}` commutes with `g ⊗ g` at the HomSpace +level. -/ +private theorem braiding_comm_block (n : ℕ) + (g' : HomSpace f.val (n + n)) : + HomSpace.comp f (n + n) (n + n) (n + n) + (HomSpace.tensor f n n n n g' g') + (bundleMapClass f (transposeEquiv n n)) = + HomSpace.comp f (n + n) (n + n) (n + n) + (bundleMapClass f (transposeEquiv n n)) + (HomSpace.tensor f n n n n g' g') := by + have h1 : HomSpace.tensor f n n n n g' g' = + HomSpace.comp f (n + n) (n + n) (n + n) + (HomSpace.tensor f n n n n g' + (HomSpace.ofFragment f.val (strandBundle n))) + (HomSpace.tensor f n n n n + (HomSpace.ofFragment f.val (strandBundle n)) g') := by + have := HomSpace.tensor_comp f g' + (HomSpace.ofFragment f.val (strandBundle n)) + (HomSpace.ofFragment f.val (strandBundle n)) g' + rw [HomSpace.comp_id_right, HomSpace.comp_id_left] at this + exact this + have h2 : HomSpace.tensor f n n n n g' g' = + HomSpace.comp f (n + n) (n + n) (n + n) + (HomSpace.tensor f n n n n + (HomSpace.ofFragment f.val (strandBundle n)) g') + (HomSpace.tensor f n n n n g' + (HomSpace.ofFragment f.val (strandBundle n))) := by + have := HomSpace.tensor_comp f + (HomSpace.ofFragment f.val (strandBundle n)) g' g' + (HomSpace.ofFragment f.val (strandBundle n)) + rw [HomSpace.comp_id_left, HomSpace.comp_id_right] at this + exact this + conv_lhs => rw [h1] + rw [HomSpace.comp_assoc f (n + n) (n + n) (n + n) (n + n)] + rw [braidNatRight_class f n g'] + rw [← HomSpace.comp_assoc f (n + n) (n + n) (n + n) (n + n)] + rw [braidNatLeft_class f n g'] + rw [HomSpace.comp_assoc f (n + n) (n + n) (n + n) (n + n)] + rw [← h2] + +/-- The braiding at block arities commutes with `g ⊗ g` at the +End level. -/ +private theorem blockSwap01_comm (n : ℕ) (g : skeinEnd f n) : + permClass f (n + n) (transposeEquiv n n) * + blockTensorEnd f g g = + blockTensorEnd f g g * + permClass f (n + n) (transposeEquiv n n) := by + change HomSpace.comp f (n + n) (n + n) (n + n) + (show HomSpace f.val _ from blockTensorEnd f g g) + (show HomSpace f.val _ from + permClass f (n + n) (transposeEquiv n n)) = + HomSpace.comp f (n + n) (n + n) (n + n) + (show HomSpace f.val _ from + permClass f (n + n) (transposeEquiv n n)) + (show HomSpace f.val _ from blockTensorEnd f g g) + rw [permClass_eq_bundleMapClass] + exact braiding_comm_block f n (show HomSpace f.val (n + n) from g) + +/-! ### Swap commutativity at block level -/ + +/-- A swap fixing the last element decomposes as a tensor with + identity on the last position. -/ +private theorem swap_internal_block' {m : ℕ} + (i : ℕ) (hi : i + 2 ≤ m) : + Equiv.swap (⟨i, by omega⟩ : Fin (m + 1)) + (⟨i + 1, by omega⟩ : Fin (m + 1)) = + finSumFinEquiv.permCongr (Equiv.sumCongr + (Equiv.swap (⟨i, by omega⟩ : Fin m) ⟨i + 1, by omega⟩) + (1 : Equiv.Perm (Fin 1))) := by + ext ⟨z, hz⟩ + simp only [Equiv.permCongr_apply] + by_cases hz1 : z < m + · have hsym : finSumFinEquiv.symm ⟨z, hz⟩ = + Sum.inl ⟨z, hz1⟩ := + finSumFinEquiv_symm_apply_castAdd ⟨z, hz1⟩ + rw [hsym] + simp only [Equiv.sumCongr_apply, Sum.map_inl, + Equiv.swap_apply_def] + split_ifs <;> + simp_all [finSumFinEquiv_apply_left, Fin.ext_iff] + · have hzm : z = m := by omega + have hsym : finSumFinEquiv.symm ⟨z, hz⟩ = + Sum.inr (⟨0, by omega⟩ : Fin 1) := by + have : (⟨z, hz⟩ : Fin (m + 1)) = + Fin.natAdd m ⟨0, by omega⟩ := + Fin.ext (by simp [Fin.natAdd]; omega) + rw [this, finSumFinEquiv_symm_apply_natAdd] + rw [hsym] + simp only [Equiv.sumCongr_apply, Sum.map_inr, + Equiv.Perm.one_apply, Equiv.swap_apply_def] + split_ifs <;> + simp_all [finSumFinEquiv_apply_right, Fin.ext_iff, + Fin.natAdd] <;> + omega + +/-- A swap of the last two elements decomposes as identity tensor + swap on the last two positions. -/ +private theorem swap_last_block' (m' : ℕ) : + Equiv.swap (⟨m', by omega⟩ : Fin (m' + 2)) + (⟨m' + 1, by omega⟩ : Fin (m' + 2)) = + finSumFinEquiv.permCongr (Equiv.sumCongr + (1 : Equiv.Perm (Fin m')) + (Equiv.swap (0 : Fin 2) (1 : Fin 2))) := by + ext ⟨z, hz⟩ + simp only [Equiv.permCongr_apply] + by_cases hz1 : z < m' + · have hsym : finSumFinEquiv.symm ⟨z, hz⟩ = + Sum.inl ⟨z, hz1⟩ := + finSumFinEquiv_symm_apply_castAdd ⟨z, hz1⟩ + rw [hsym] + simp only [Equiv.sumCongr_apply, Sum.map_inl, + Equiv.Perm.one_apply, Equiv.swap_apply_def] + split_ifs <;> + simp_all [finSumFinEquiv_apply_left, Fin.ext_iff] <;> + omega + · have hz2 : z - m' < 2 := by omega + have hsym : finSumFinEquiv.symm ⟨z, hz⟩ = + Sum.inr ⟨z - m', hz2⟩ := by + have : (⟨z, hz⟩ : Fin (m' + 2)) = + Fin.natAdd m' ⟨z - m', hz2⟩ := + Fin.ext (by simp [Fin.natAdd]; omega) + rw [this, finSumFinEquiv_symm_apply_natAdd] + rw [hsym] + simp only [Equiv.sumCongr_apply, Sum.map_inr, + Equiv.swap_apply_def] + split_ifs <;> + simp_all [finSumFinEquiv_apply_right, Fin.ext_iff, + Fin.natAdd] <;> + omega + +/-- `blockPerm n (swap 0 1)`, cast from arity `n * 2` to + `n * 1 + n * 1`, equals the transpose equivalence. -/ +private theorem blockPerm_swap01_eq_transposeEquiv (n : ℕ) : + (finCongr (Nat.mul_add n 1 1)).permCongr + (blockPerm n (Equiv.swap (0 : Fin 2) 1)) = + transposeEquiv (n * 1) (n * 1) := by + by_cases hn : n = 0 + · subst hn; ext ⟨v, hv⟩; simp at hv + · have hn' : 0 < n := Nat.pos_of_ne_zero hn + ext ⟨v, hv⟩ : 1 + simp only [Equiv.permCongr_apply] + apply Fin.ext + -- finCongr doesn't change .val, so reduce to blockPerm + have hv2 : v < n * 2 := by omega + change (blockPerm n (Equiv.swap (0 : Fin 2) 1) + ⟨v, hv2⟩).val = + (transposeEquiv (n * 1) (n * 1) ⟨v, hv⟩).val + by_cases hvn : v < n + · -- Block 0 → block 1 + have hlhs : (blockPerm n (Equiv.swap (0 : Fin 2) 1) + ⟨v, hv2⟩).val = n + v := by + have h0 : (⟨v, hv2⟩ : Fin (n * 2)) = + ⟨n * 0 + v, by omega⟩ := + Fin.ext (by simp only []; omega) + rw [h0] + have h1 := congrArg Fin.val (blockPerm_val n + (Equiv.swap (0 : Fin 2) 1) + ⟨0, by omega⟩ ⟨v, hvn⟩) + simp only [] at h1 + rw [h1] + simp [] + rw [hlhs, transposeEquiv_low (n * 1) (n * 1) v + (by omega) hv (by omega)] + simp only []; omega + · -- Block 1 → block 0 + push Not at hvn + have hlhs : (blockPerm n (Equiv.swap (0 : Fin 2) 1) + ⟨v, hv2⟩).val = v - n := by + have h0 : (⟨v, hv2⟩ : Fin (n * 2)) = + ⟨n * 1 + (v - n), by omega⟩ := + Fin.ext (by simp only []; omega) + rw [h0] + have h1 := congrArg Fin.val (blockPerm_val n + (Equiv.swap (0 : Fin 2) 1) + ⟨1, by omega⟩ ⟨v - n, by omega⟩) + simp only [] at h1 + rw [h1] + simp [] + have hrhs_eq : (⟨v, hv⟩ : Fin (n * 1 + n * 1)) = + ⟨n * 1 + (v - n * 1), by omega⟩ := + Fin.ext (by simp only []; omega) + rw [hlhs, hrhs_eq, transposeEquiv_high (n * 1) (n * 1) + (v - n * 1) (by omega) (by omega) (by omega)] + simp only []; omega + +/-- The block swap `blockPerm n (swap 0 1)` commutes with + `blockPow 2`, proved by casting to arity `n * 1 + n * 1` + and applying `blockSwap01_comm`. -/ +private theorem swap01_comm_blockPow2 (g : skeinEnd f n) : + permClass f (n * 2) + (blockPerm n (Equiv.swap (0 : Fin 2) 1)) * + blockPow f n g 2 = + blockPow f n g 2 * + permClass f (n * 2) + (blockPerm n (Equiv.swap (0 : Fin 2) 1)) := by + suffices h : endCast f (Nat.mul_add n 1 1) + (permClass f (n * 2) + (blockPerm n (Equiv.swap (0 : Fin 2) 1)) * + blockPow f n g 2) = + endCast f (Nat.mul_add n 1 1) + (blockPow f n g 2 * + permClass f (n * 2) + (blockPerm n (Equiv.swap (0 : Fin 2) 1))) by + have := congrArg (endCast f (Nat.mul_add n 1 1).symm) h + rwa [endCast_trans, endCast_rfl, + endCast_trans, endCast_rfl] at this + rw [endCast_mul, endCast_mul, + endCast_permClass f (Nat.mul_add n 1 1), + blockPerm_swap01_eq_transposeEquiv, + show endCast f (Nat.mul_add n 1 1) (blockPow f n g 2) = + blockTensorEnd f (blockPow f n g 1) + (blockPow f n g 1) from blockPow_split f n g 1 1] + exact blockSwap01_comm f (n * 1) (blockPow f n g 1) + +-- The induction on the block count carries the +-- permutation class and the block power at every step. +/-- Adjacent swap commutes with blockPow (by induction on k). -/ +private theorem block_adj_swap_comm (k : ℕ) (i : ℕ) + (hi : i + 2 ≤ k) (g : skeinEnd f n) : + permClass f (n * k) (blockPerm n + (Equiv.swap (⟨i, by omega⟩ : Fin k) + ⟨i + 1, by omega⟩)) * + blockPow f n g k = + blockPow f n g k * + permClass f (n * k) (blockPerm n + (Equiv.swap (⟨i, by omega⟩ : Fin k) + ⟨i + 1, by omega⟩)) := by + induction k with + | zero => omega + | succ k' ihk => + cases k' with + | zero => omega + | succ k'' => + -- k = k'' + 2 + by_cases hi' : i + 2 ≤ k'' + 1 + · -- Internal: swap doesn't touch last position + rw [swap_internal_block' i hi'] + set σ' := Equiv.swap + (⟨i, by omega⟩ : Fin (k'' + 1)) + ⟨i + 1, by omega⟩ + -- Decompose at arity n * (k'' + 1) + n * 1 + have hperm : permClass f (n * (k'' + 2)) + (blockPerm n + ((@finSumFinEquiv (k'' + 1) 1).permCongr + (Equiv.sumCongr σ' + (1 : Equiv.Perm (Fin 1))))) = + endCast f (Nat.mul_add n (k'' + 1) 1).symm + (blockTensorEnd f + (permClass f (n * (k'' + 1)) + (blockPerm n σ')) + (1 : skeinEnd f (n * 1))) := by + have h1 := endCast_permClass f + (Nat.mul_add n (k'' + 1) 1) + (blockPerm n + ((@finSumFinEquiv (k'' + 1) 1).permCongr + (Equiv.sumCongr σ' + (1 : Equiv.Perm (Fin 1))))) + rw [blockPerm_sumCongr, blockPerm_one, + permClass_blockTensorEnd, + show permClass f (n * 1) + (1 : Equiv.Perm (Fin (n * 1))) = + (1 : skeinEnd f (n * 1)) from + map_one (permToEnd f (n * 1))] at h1 + have h2 := congrArg + (endCast f + (Nat.mul_add n (k'' + 1) 1).symm) h1 + rw [endCast_trans, endCast_rfl] at h2 + exact h2 + have hpow : blockPow f n g (k'' + 2) = + endCast f (Nat.mul_add n (k'' + 1) 1).symm + (blockTensorEnd f + (blockPow f n g (k'' + 1)) + (blockPow f n g 1)) := by + have h3 := blockPow_split f n g (k'' + 1) 1 + have h4 := congrArg + (endCast f + (Nat.mul_add n (k'' + 1) 1).symm) h3 + rw [endCast_trans, endCast_rfl] at h4 + exact h4 + rw [hperm, hpow, ← endCast_mul, ← endCast_mul] + congr 1 + exact blockTensorEnd_comm f _ _ _ _ + (ihk (by omega)) + ((one_mul _).trans (mul_one _).symm) + · -- Last: i = k'', swap of last two positions + have him : i = k'' := by omega + subst him + -- After subst, k'' is eliminated; use i everywhere + rw [swap_last_block' i] + -- Decompose at arity n * i + n * 2 + have hperm : permClass f (n * (i + 2)) + (blockPerm n (finSumFinEquiv.permCongr + (Equiv.sumCongr 1 + (Equiv.swap (0 : Fin 2) 1)))) = + endCast f (Nat.mul_add n i 2).symm + (blockTensorEnd f + (1 : skeinEnd f (n * i)) + (permClass f (n * 2) + (blockPerm n + (Equiv.swap (0 : Fin 2) 1)))) := by + have h1 := endCast_permClass f + (Nat.mul_add n i 2) + (blockPerm n (finSumFinEquiv.permCongr + (Equiv.sumCongr 1 + (Equiv.swap (0 : Fin 2) 1)))) + rw [blockPerm_sumCongr, blockPerm_one, + permClass_blockTensorEnd, + show permClass f (n * i) + (1 : Equiv.Perm (Fin (n * i))) = + (1 : skeinEnd f (n * i)) from + map_one (permToEnd f _)] at h1 + have h2 := congrArg + (endCast f (Nat.mul_add n i 2).symm) h1 + rw [endCast_trans, endCast_rfl] at h2 + exact h2 + have hpow : blockPow f n g (i + 2) = + endCast f (Nat.mul_add n i 2).symm + (blockTensorEnd f + (blockPow f n g i) + (blockPow f n g 2)) := by + have h3 := blockPow_split f n g i 2 + have h4 := congrArg + (endCast f (Nat.mul_add n i 2).symm) h3 + rw [endCast_trans, endCast_rfl] at h4 + exact h4 + rw [hperm, hpow, ← endCast_mul, ← endCast_mul] + congr 1 + exact blockTensorEnd_comm f _ _ _ _ + ((one_mul _).trans (mul_one _).symm) + (swap01_comm_blockPow2 f g) + +/-- Any transposition commutes with blockPow + (induction on the distance `|y - x|`). -/ +private theorem block_swap_comm (x y : Fin k) + (hxy : x ≠ y) (g : skeinEnd f n) : + permClass f (n * k) (blockPerm n (Equiv.swap x y)) * + blockPow f n g k = + blockPow f n g k * + permClass f (n * k) + (blockPerm n (Equiv.swap x y)) := by + suffices key : ∀ (d : ℕ) (x y : Fin k), + x ≠ y → x.val < y.val → + y.val - x.val = d + 1 → + permClass f (n * k) + (blockPerm n (Equiv.swap x y)) * + blockPow f n g k = + blockPow f n g k * + permClass f (n * k) + (blockPerm n (Equiv.swap x y)) by + rcases Nat.lt_or_gt_of_ne + (Fin.val_ne_of_ne hxy) with hlt | hgt + · exact key (y.val - x.val - 1) x y hxy hlt + (by omega) + · rw [Equiv.swap_comm] + exact key (x.val - y.val - 1) y x (Ne.symm hxy) + hgt (by omega) + have pmul : ∀ (a b : Equiv.Perm (Fin k)), + permClass f (n * k) (blockPerm n (a * b)) = + permClass f (n * k) (blockPerm n a) * + permClass f (n * k) (blockPerm n b) := by + intro a b + rw [blockPerm_mul] + exact map_mul (permToEnd f (n * k)) _ _ + intro d + induction d with + | zero => + intro x y _ hlt hd + have hyk : y.val < k := y.isLt + have heq : y = ⟨x.val + 1, by omega⟩ := + Fin.ext (by simp only []; omega) + rw [heq] + exact block_adj_swap_comm f k x.val (by omega) g + | succ d' ih => + intro x y hxy hlt hd + have hyk : y.val < k := y.isLt + have hx1_lt : x.val + 1 < k := by omega + set x1 : Fin k := ⟨x.val + 1, hx1_lt⟩ + have hx_ne_x1 : x ≠ x1 := + Fin.ne_of_val_ne (by simp only [x1]; omega) + have hx1_ne_y : x1 ≠ y := + Fin.ne_of_val_ne (by simp only [x1]; omega) + have decomp : Equiv.swap x y = + Equiv.swap x x1 * Equiv.swap x1 y * + Equiv.swap x x1 := by + have := Equiv.swap_mul_swap_mul_swap + hx1_ne_y.symm hxy.symm + rw [Equiv.swap_comm x1 x, + Equiv.swap_comm y x1] at this + exact this.symm + have adj : permClass f (n * k) + (blockPerm n (Equiv.swap x x1)) * + blockPow f n g k = + blockPow f n g k * + permClass f (n * k) + (blockPerm n (Equiv.swap x x1)) := + block_adj_swap_comm f k x.val (by omega) g + have inner : permClass f (n * k) + (blockPerm n (Equiv.swap x1 y)) * + blockPow f n g k = + blockPow f n g k * + permClass f (n * k) + (blockPerm n (Equiv.swap x1 y)) := + ih x1 y hx1_ne_y + (by simp only [x1]; omega) + (by simp only [x1]; omega) + rw [decomp, pmul, pmul] + set A := permClass f (n * k) + (blockPerm n (Equiv.swap x x1)) + set B := permClass f (n * k) + (blockPerm n (Equiv.swap x1 y)) + set G := blockPow f n g k + calc ((A * B) * A) * G + = (A * B) * (A * G) := by rw [mul_assoc] + _ = (A * B) * (G * A) := by rw [adj] + _ = A * (B * (G * A)) := by rw [mul_assoc] + _ = A * ((B * G) * A) := by + rw [← mul_assoc B G A] + _ = A * ((G * B) * A) := by rw [inner] + _ = A * (G * (B * A)) := by + rw [mul_assoc G B A] + _ = (A * G) * (B * A) := by + rw [← mul_assoc A G _] + _ = (G * A) * (B * A) := by rw [adj] + _ = G * (A * (B * A)) := by rw [mul_assoc] + _ = G * ((A * B) * A) := by + rw [← mul_assoc A B A] + +/-! ### The block cycle trace -/ + +/-- **The block cycle trace**: closing the block rotation against +`c` diagonal blocks is the trace of the `c`-th power, via the block +splice. -/ +theorem skeinTrace_blockCycle (n : ℕ) (g : skeinEnd f n) + (c : ℕ) : + skeinTrace f (n * (c + 1)) + (permClass f (n * (c + 1)) + (blockPerm n (finRotate (c + 1))) * + blockPow f n g (c + 1)) = + skeinTrace f n (g ^ (c + 1)) := + skeinTrace_blockCycle' f n g c + +/-- Block permutations commute with the block-diagonal power. -/ +theorem blockPerm_mul_blockPow_comm (n : ℕ) {k : ℕ} + (σ : Equiv.Perm (Fin k)) (g : skeinEnd f n) : + permClass f (n * k) (blockPerm n σ) * blockPow f n g k = + blockPow f n g k * + permClass f (n * k) (blockPerm n σ) := by + induction σ using Equiv.Perm.swap_induction_on with + | one => + rw [blockPerm_one, show permClass f (n * k) + (1 : Equiv.Perm (Fin (n * k))) = + (1 : skeinEnd f (n * k)) from map_one (permToEnd f _), + one_mul, mul_one] + | swap_mul τ x y hxy ih => + rw [blockPerm_mul, + show permClass f (n * k) (blockPerm n (Equiv.swap x y) * + blockPerm n τ) = + permClass f (n * k) (blockPerm n (Equiv.swap x y)) * + permClass f (n * k) (blockPerm n τ) from + map_mul (permToEnd f _) _ _, + mul_assoc, ih, ← mul_assoc] + rw [block_swap_comm f x y hxy g, mul_assoc] + +/-- **Block factorization over the block-cycle normal form.** -/ +theorem skeinTrace_blockCycles_mul_pow (n : ℕ) + (l : List ℕ) (hl : ∀ c ∈ l, 1 ≤ c) (g : skeinEnd f n) : + skeinTrace f (n * l.sum) + (permClass f (n * l.sum) + (blockPerm n (blockCycles l)) * + blockPow f n g l.sum) = + (l.map (fun c => skeinTrace f n (g ^ c))).prod := by + induction l with + | nil => + rw [show (blockCycles ([] : List ℕ)) = + (1 : Equiv.Perm (Fin ([] : List ℕ).sum)) from rfl, + blockPerm_one, + show permClass f (n * ([] : List ℕ).sum) + (1 : Equiv.Perm (Fin (n * ([] : List ℕ).sum))) = + (1 : skeinEnd f (n * ([] : List ℕ).sum)) + from map_one (permToEnd f _), + show blockPow f n g ([] : List ℕ).sum = + (1 : skeinEnd f (n * ([] : List ℕ).sum)) from rfl, + one_mul, List.map_nil, List.prod_nil] + exact skeinTrace_zero_one f + | cons c rest ih => + have hc : 1 ≤ c := hl c List.mem_cons_self + have hrest : ∀ x ∈ rest, 1 ≤ x := fun x hx => + hl x (List.mem_cons_of_mem c hx) + set S := rest.sum with hS_def + change skeinTrace f (n * (c + S)) + (permClass f (n * (c + S)) + (blockPerm n (blockCycles (c :: rest))) * + blockPow f n g (c + S)) = + skeinTrace f n (g ^ c) * + (rest.map (fun x => skeinTrace f n (g ^ x))).prod + rw [show (blockCycles (c :: rest) : + Equiv.Perm (Fin (c + S))) = + finSumFinEquiv.permCongr (Equiv.sumCongr + (finRotate c) (blockCycles rest)) from rfl] + -- Decompose permClass via blockPerm_sumCongr + set H := Nat.mul_add n c S with hH_def + have hperm : permClass f (n * (c + S)) + (blockPerm n (finSumFinEquiv.permCongr + (Equiv.sumCongr (finRotate c) + (blockCycles rest)))) = + endCast f H.symm (blockTensorEnd f + (permClass f (n * c) (blockPerm n (finRotate c))) + (permClass f (n * S) + (blockPerm n (blockCycles rest)))) := by + have h1 := endCast_permClass f H + (blockPerm n (finSumFinEquiv.permCongr + (Equiv.sumCongr (finRotate c) + (blockCycles rest)))) + rw [blockPerm_sumCongr, permClass_blockTensorEnd] at h1 + have h2 := congrArg (endCast f H.symm) h1 + rw [endCast_trans, endCast_rfl] at h2 + exact h2 + rw [hperm] + -- Decompose blockPow via blockPow_split + have hpow : blockPow f n g (c + S) = + endCast f H.symm (blockTensorEnd f + (blockPow f n g c) (blockPow f n g S)) := by + have h3 := blockPow_split f n g c S + have h4 := congrArg (endCast f H.symm) h3 + rw [endCast_trans, endCast_rfl] at h4 + exact h4 + rw [hpow, ← endCast_mul, blockTensorEnd_mul, + skeinTrace_endCast, skeinTrace_blockTensorEnd, + ih hrest] + -- First factor is skeinTrace_blockCycle + cases c with + | zero => omega + | succ c' => + rw [skeinTrace_blockCycle] + +/-- **The block trace factorization**: the trace of a block +permutation against the block-diagonal power is the cycle-type +product of block power traces, fixed points included. -/ +theorem skeinTrace_blockPerm_mul_pow (n : ℕ) {k : ℕ} + (π : Equiv.Perm (Fin k)) (g : skeinEnd f n) : + skeinTrace f (n * k) + (permClass f (n * k) (blockPerm n π) * + blockPow f n g k) = + (π.cycleType.map + (fun c => skeinTrace f n (g ^ c))).prod * + (skeinTrace f n (g ^ 1)) ^ (k - π.cycleType.sum) := by + obtain ⟨l, h, σ, hl, hcoe, hσ⟩ := exists_conj_blockCycles π + subst h + have hB : (finCongr (rfl : l.sum = l.sum)).permCongr + (blockCycles l) = blockCycles l := by + ext x + simp + rw [hB] at hσ + have hconj : blockPerm n π = + blockPerm n σ * blockPerm n (blockCycles l) * + blockPerm n σ⁻¹ := by + rw [← blockPerm_mul, ← blockPerm_mul, hσ] + rw [hconj] + have permClass_mul : ∀ a b : Equiv.Perm (Fin (n * l.sum)), + permClass f (n * l.sum) (a * b) = + permClass f (n * l.sum) a * + permClass f (n * l.sum) b := + fun a b => map_mul (permToEnd f (n * l.sum)) a b + conv_lhs => rw [permClass_mul, permClass_mul] + rw [mul_assoc (permClass f (n * l.sum) (blockPerm n σ) * + permClass f (n * l.sum) (blockPerm n (blockCycles l)))] + rw [blockPerm_mul_blockPow_comm] + rw [← mul_assoc, + mul_assoc (permClass f (n * l.sum) (blockPerm n σ))] + have hσinv : permClass f (n * l.sum) (blockPerm n σ⁻¹) = + permClass f (n * l.sum) ((blockPerm n σ)⁻¹) := by + rw [show blockPerm n σ⁻¹ = (blockPerm n σ)⁻¹ from + map_inv (blockPermHom n l.sum) σ] + rw [hσinv, skeinTrace_conj'] + rw [skeinTrace_blockCycles_mul_pow f n l hl] + have hsplit : (l : Multiset ℕ) = π.cycleType + + Multiset.replicate (l.sum - π.cycleType.sum) 1 := by + rw [hcoe, fullCycleType] + calc (l.map (fun c => skeinTrace f n (g ^ c))).prod + = (((l : Multiset ℕ)).map + (fun c => skeinTrace f n (g ^ c))).prod := by + rw [Multiset.map_coe, Multiset.prod_coe] + _ = _ := by + rw [hsplit, Multiset.map_add, Multiset.prod_add, + Multiset.map_replicate, Multiset.prod_replicate] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactorialTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactorialTrace.lean new file mode 100644 index 0000000000..c54edde0ac --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactorialTrace.lean @@ -0,0 +1,65 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Algebra.FactorialTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactor +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleEnd + +/-! +# The factorial proof for strand endomorphisms + +Block permutations and the existing block cycle-trace formula give +a `CycleTraceTower` at every strand arity. The connection-rank +bound then forces nilpotent traces to vanish. Nondegeneracy of the +connection pairing supplies semisimplicity by the trace criterion. +The Schur and trace-zeta proof remains in `BlockAssembly`. +-/ + +@[expose] public section + +namespace RS + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The cycle-trace tower at an arbitrary strand arity. -/ +noncomputable def blockCycleTraceTower (n : ℕ) : + CycleTraceTower (fun k => skeinEnd f (n * k)) (skeinEnd f n) where + traceA := HomSpace.traceMap f.val n + trace k := HomSpace.traceMap f.val (n * k) + rep k := (permToEnd f (n * k)).comp (blockPermHom n k) + pow k g := blockPow f n g k + cycleTrace k π g := by + change skeinTrace f (n * k) + (permClass f (n * k) (blockPerm n π) * blockPow f n g k) = + (π.cycleType.map (fun c => skeinTrace f n (g ^ c))).prod * + skeinTrace f n g ^ (k - π.cycleType.sum) + simpa only [pow_one] using skeinTrace_blockPerm_mul_pow f n π g + +/-- The factorial proof of nilpotent-trace vanishing at every +strand arity, without a Schur package. -/ +theorem skeinTrace_eq_zero_of_isNilpotent_factorial (n : ℕ) + {g : skeinEnd f n} (hg : IsNilpotent g) : skeinTrace f n g = 0 := by + apply (blockCycleTraceTower f n).traceA_eq_zero_of_exponential_bound + (((R : ℝ) ^ n) ^ 2) _ hg + intro k + have h := blockEnd_finrank_le f n k + have hreal : (Module.finrank ℂ (skeinEnd f (n * k)) : ℝ) ≤ + ((R ^ n : ℕ) : ℝ) ^ (2 * k) := by exact_mod_cast h + simpa only [Nat.cast_pow, ← pow_mul, Nat.mul_assoc] using hreal + +/-- Every strand endomorphism algebra is semisimple by the +factorial trace obstruction and the connection pairing. -/ +theorem skeinEnd_isSemisimpleRing_factorial (n : ℕ) : + IsSemisimpleRing (skeinEnd f n) := by + refine isSemisimpleRing_of_trace (HomSpace.traceMap f.val n) + (fun _ hg => skeinTrace_eq_zero_of_isNilpotent_factorial f n hg) ?_ + intro a ha + exact HomSpace.eq_zero_of_traces_vanish f a + (fun G => ha (HomSpace.ofFragment f.val G)) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockSplice.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockSplice.lean new file mode 100644 index 0000000000..11dc97aa49 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockSplice.lean @@ -0,0 +1,1049 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseCompose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseUnion + +/-! +# The block splice + +Partially closing an `(n, n)`-fragment against the block rotation on +`K + 2n` strands splices it into the block rotation on `K + n` +strands: the fragment is absorbed and the rotation drops one block. +This is the geometric step behind the block cycle trace, and the +reason a diagonal power of `g` closes to a power of its trace. + +The proof identifies the two fragments flag by flag. It runs through +the block rotation and its outer boundary permutation, the value +tables of the label maps they induce, and two bridges: the reshuffled +rotation as through-strands tensored with `K` cups, and the same +after the outer relabel is collapsed. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +/-! ### The block rotation -/ + +/-- The block rotation: cyclically permute the first `a` and last `b` +elements of `Fin (a + b)`. Value: `x < a ↦ b + x`, `x ≥ a ↦ x - a`. -/ +noncomputable def blockRot (a b : ℕ) : Equiv.Perm (Fin (a + b)) := + (transposeEquiv a b).trans (finCongr (by omega : b + a = a + b)) + +/-- Forward value of `blockRot`. -/ +theorem blockRot_val (a b : ℕ) (x : Fin (a + b)) : + (blockRot a b x).val = + if x.val < a then b + x.val else x.val - a := by + unfold blockRot + rw [_root_.Equiv.trans_apply, finCongr_apply, Fin.val_cast] + have hb := x.isLt + by_cases h : x.val < a + · conv_lhs => + rw [show x = (⟨x.val, hb⟩ : Fin (a + b)) from Fin.ext rfl] + rw [transposeEquiv_low a b x.val h hb (by omega)] + simp only [ite_eq_left h] + · conv_lhs => + rw [show x = (⟨a + (x.val - a), by omega⟩ : Fin (a + b)) from + Fin.ext (by change x.val = a + (x.val - a); omega)] + rw [transposeEquiv_high a b (x.val - a) (by omega) (by omega) (by omega)] + simp only [ite_eq_right h] + +/-- Inverse value of `blockRot`. -/ +private theorem blockRot_symm_val (a b : ℕ) (x : Fin (a + b)) : + ((blockRot a b).symm x).val = + if x.val < b then a + x.val else x.val - b := by + set y := (blockRot a b).symm x + have hfwd := blockRot_val a b y + rw [Equiv.apply_symm_apply] at hfwd + by_cases hya : y.val < a + · rw [ite_eq_left hya] at hfwd; rw [ite_eq_right (by omega)]; omega + · rw [ite_eq_right hya] at hfwd; rw [ite_eq_left (by omega)]; omega + +/-! ### The outer boundary permutation -/ + +/-- The outer boundary permutation for the block splice: +`w < n ↦ (K+K+n)+w`, `w ≥ n ↦ w-n`. At `K = 0` this is the +reversal `(finRotate (2n)).symm`. -/ +def blockOuterPerm (K n : ℕ) : + Equiv.Perm (Fin ((K + n) + (K + n))) where + toFun w := + if h : w.val < n then ⟨K + K + n + w.val, by have := w.isLt; omega⟩ + else ⟨w.val - n, by have := w.isLt; omega⟩ + invFun w := + if h : w.val < K + K + n then ⟨w.val + n, by omega⟩ + else ⟨w.val - (K + K + n), by have := w.isLt; omega⟩ + left_inv w := by + dsimp only + by_cases h : w.val < n + · simp only [dite_eq_left h, Fin.val_mk] + rw [dite_eq_right (show ¬ K + K + n + w.val < K + K + n by omega)] + refine Fin.ext ?_; simp only []; omega + · simp only [dite_eq_right h, Fin.val_mk] + rw [dite_eq_left (show w.val - n < K + K + n by have := w.isLt; omega)] + refine Fin.ext ?_; simp only []; omega + right_inv w := by + dsimp only + by_cases h : w.val < K + K + n + · simp only [dite_eq_left h, Fin.val_mk] + rw [dite_eq_right (show ¬ w.val + n < n by omega)] + refine Fin.ext ?_; simp only []; omega + · simp only [dite_eq_right h, Fin.val_mk] + rw [dite_eq_left (show w.val - (K + K + n) < n by have := w.isLt; omega)] + refine Fin.ext ?_; simp only []; omega + +/-- Value table of `blockOuterPerm`. -/ +private theorem blockOuterPerm_val (K n : ℕ) + (w : Fin ((K + n) + (K + n))) : + (blockOuterPerm K n w).val = + if w.val < n then K + K + n + w.val else w.val - n := by + simp only [blockOuterPerm, Equiv.coe_fn_mk]; split_ifs <;> rfl + +/-! ### The label map of the reshuffled rotation -/ + +/-- The value table of the reshuffled block rotation's label map, at +tensor arities `(s, t, u, v) = (K+n, K+n, n, n)`. -/ +private theorem block_label_val (K n : ℕ) + (ℓ : Fin ((K + n + n) + (K + n + n))) : + (((permHighEquiv (blockRot (K + n) n).symm).trans + (pcReshuffle (K + n) (K + n) n n)) ℓ).val = + if ℓ.val < K + n then (n + n) + ℓ.val + else if ℓ.val < K + n + n then ℓ.val - (K + n) + else if ℓ.val < (K + n + n) + n then n + (ℓ.val - (K + n + n)) + else ℓ.val := by + rw [_root_.Equiv.trans_apply] + by_cases hlow : ℓ.val < K + n + n + · -- Low half: permHighEquiv fixes + have hfix : permHighEquiv (blockRot (K + n) n).symm ℓ = ℓ := by + unfold permHighEquiv; exact dite_eq_left hlow + rw [hfix] + by_cases h1 : ℓ.val < K + n + · -- x-low block + have hform : ℓ = Fin.castAdd ((K + n) + n) + (Fin.castAdd n (⟨ℓ.val, h1⟩ : Fin (K + n))) := + Fin.ext rfl + rw [hform, pcReshuffle_xlow] + simp only [Fin.val_natAdd, Fin.val_castAdd] + split_ifs; omega + · -- z-low block + have hform : ℓ = Fin.castAdd ((K + n) + n) + (Fin.natAdd (K + n) (⟨ℓ.val - (K + n), + by omega⟩ : Fin n)) := + Fin.ext (by simp []; omega) + rw [hform, pcReshuffle_zlow] + simp only [Fin.val_natAdd, Fin.val_castAdd] + split_ifs <;> omega + · -- High half: permHighEquiv applies π + have hbound := ℓ.isLt + have hk : ℓ.val - (K + n + n) < K + n + n := by omega + have hrot : ((blockRot (K + n) n).symm + (⟨ℓ.val - (K + n + n), hk⟩ : Fin (K + n + n))).val = + if ℓ.val - (K + n + n) < n then (K + n) + (ℓ.val - (K + n + n)) + else ℓ.val - (K + n + n) - n := + blockRot_symm_val (K + n) n _ + have hstep : permHighEquiv (blockRot (K + n) n).symm ℓ = + ⟨(K + n + n) + ((blockRot (K + n) n).symm + (⟨ℓ.val - (K + n + n), hk⟩ : Fin (K + n + n))).val, + by have := ((blockRot (K + n) n).symm + (⟨ℓ.val - (K + n + n), hk⟩ : Fin (K + n + n))).isLt + omega⟩ := by + unfold permHighEquiv; exact dite_eq_right (by omega) + rw [hstep] + by_cases hk0 : ℓ.val - (K + n + n) < n + · -- z-high block (k < n case) + rw [ite_eq_left hk0] at hrot + have hform : (⟨(K + n + n) + ((blockRot (K + n) n).symm + (⟨ℓ.val - (K + n + n), hk⟩ : Fin (K + n + n))).val, + by have := ((blockRot (K + n) n).symm + (⟨ℓ.val - (K + n + n), hk⟩ : Fin (K + n + n))).isLt + omega⟩ : Fin ((K + n + n) + (K + n + n))) = + Fin.natAdd ((K + n) + n) + (Fin.natAdd (K + n) (⟨ℓ.val - (K + n + n), + by omega⟩ : Fin n)) := + Fin.ext (by simp only [Fin.val_natAdd]; omega) + rw [hform, pcReshuffle_zhigh] + simp only [Fin.val_natAdd, Fin.val_castAdd] + split_ifs <;> omega + · -- x-high block (k >= n case) + rw [ite_eq_right hk0] at hrot + have hform : (⟨(K + n + n) + ((blockRot (K + n) n).symm + (⟨ℓ.val - (K + n + n), hk⟩ : Fin (K + n + n))).val, + by have := ((blockRot (K + n) n).symm + (⟨ℓ.val - (K + n + n), hk⟩ : Fin (K + n + n))).isLt + omega⟩ : Fin ((K + n + n) + (K + n + n))) = + Fin.natAdd ((K + n) + n) + (Fin.castAdd n (⟨ℓ.val - (K + n + n) - n, + by omega⟩ : Fin (K + n))) := + Fin.ext (by simp only [Fin.val_natAdd, Fin.val_castAdd]; omega) + rw [hform, pcReshuffle_xhigh] + simp only [Fin.val_natAdd] + split_ifs <;> omega + +/-! ### The splice flag identification -/ + +/-- The flag identification of the block splice: wires 0..n-1 and +K+n..K+2n-1 are the 2n through-strands, wires n..K+n-1 are the K cups. -/ +def blockSpliceFlagEquiv (K n : ℕ) : + (Fin (K + n + n) × Bool) ≃ + ((Fin (n + n) × Bool) ⊕ (Fin K × Bool)) where + toFun p := + if hlo : p.1.val < n then + Sum.inl (⟨n + p.1.val, by omega⟩, !p.2) + else if hhi : p.1.val ≥ K + n then + Sum.inl (⟨p.1.val - (K + n), by have := p.1.isLt; omega⟩, p.2) + else + Sum.inr (⟨p.1.val - n, by omega⟩, p.2) + invFun := Sum.elim + (fun q : Fin (n + n) × Bool => + if h : q.1.val < n then + ((⟨K + n + q.1.val, by have := q.1.isLt; omega⟩ : Fin (K + n + n)), q.2) + else + ((⟨q.1.val - n, by have := q.1.isLt; omega⟩ : Fin (K + n + n)), !q.2)) + (fun q : Fin K × Bool => + (⟨q.1.val + n, by have := q.1.isLt; omega⟩, q.2)) + left_inv := by + rintro ⟨i, b⟩; dsimp only + by_cases hlo : i.val < n + · rw [dite_eq_left hlo, Sum.elim_inl] + rw [dite_eq_right (show ¬ (⟨n + i.val, by omega⟩ : Fin (n + n)).val < n by + simp only []; omega)] + exact Prod.ext (Fin.ext (by simp only []; omega)) (Bool.not_not b) + · by_cases hhi : i.val ≥ K + n + · rw [dite_eq_right hlo, dite_eq_left hhi, Sum.elim_inl] + rw [dite_eq_left (show (⟨i.val - (K + n), by have := i.isLt; omega⟩ : + Fin (n + n)).val < n by simp only []; have := i.isLt; omega)] + exact Prod.ext (Fin.ext (by simp only []; omega)) rfl + · rw [dite_eq_right hlo, dite_eq_right (show ¬ i.val ≥ K + n by omega), Sum.elim_inr] + exact Prod.ext (Fin.ext (by simp only []; omega)) rfl + right_inv := by + rintro (⟨j, c⟩ | ⟨k, c⟩) + · rw [Sum.elim_inl]; dsimp only + by_cases hj : j.val < n + · rw [dite_eq_left hj, dite_eq_right (show ¬ (⟨K + n + j.val, + by have := j.isLt; omega⟩ : Fin (K + n + n)).val < n by + simp only []; omega), + dite_eq_left (show (⟨K + n + j.val, + by have := j.isLt; omega⟩ : Fin (K + n + n)).val ≥ K + n by + simp only []; omega)] + exact congrArg Sum.inl + (Prod.ext (Fin.ext (by simp only []; omega)) rfl) + · rw [dite_eq_right hj, dite_eq_left (show (⟨j.val - n, + by have := j.isLt; omega⟩ : Fin (K + n + n)).val < n by + simp only []; have := j.isLt; omega)] + exact congrArg Sum.inl + (Prod.ext (Fin.ext (by simp only []; omega)) + (Bool.not_not c)) + · rw [Sum.elim_inr]; dsimp only + rw [dite_eq_right (show ¬ (⟨k.val + n, by have := k.isLt; omega⟩ : + Fin (K + n + n)).val < n by simp only []; omega), + dite_eq_right (show ¬ (⟨k.val + n, by have := k.isLt; omega⟩ : + Fin (K + n + n)).val ≥ K + n by + simp only []; have := k.isLt; omega)] + exact congrArg Sum.inr (Prod.ext (Fin.ext (by simp only []; omega)) rfl) + +/-! ### The collapsed outer relabel and the rotated transpose -/ + +/-- Value of the collapsed outer relabel of the splice. -/ +private theorem block_bigE_val (K n : ℕ) + (x : Fin (0 + ((n + n) + (K + K)))) : + ((((finCongr (by omega : + 0 + ((n + n) + (K + K)) = 0 + ((K + n) + (K + n)))).trans + (outPermEquiv 0 + (blockOuterPerm K n))).trans + (finCongr (by omega : + 0 + ((K + n) + (K + n)) = (K + n) + (K + n)))) x).val = + if x.val < n then K + K + n + x.val else x.val - n := by + rw [_root_.Equiv.trans_apply, _root_.Equiv.trans_apply] + have hb := x.isLt + have hform : ((finCongr (by omega : + 0 + ((n + n) + (K + K)) = 0 + ((K + n) + (K + n)))) x) = + Fin.natAdd 0 (⟨x.val, by omega⟩ : + Fin ((K + n) + (K + n))) := + Fin.ext (by simp only [finCongr_apply, Fin.val_cast, + Fin.val_natAdd]; omega) + rw [hform, outPermEquiv_high] + simp only [finCongr_apply, Fin.val_cast, Fin.val_natAdd] + rw [blockOuterPerm_val] + simp only [] + split_ifs <;> omega + +/-- Value of the rotated-transpose relabel on the right side. -/ +private theorem block_ER_val (K n : ℕ) + (x : Fin ((K + n) + (K + n))) : + (((transposeEquiv (K + n) (K + n)).trans + (inPermEquiv + ((blockRot K n).symm).symm (K + n))) x).val = + if x.val < K + n then (K + n) + x.val + else if x.val - (K + n) < K then n + (x.val - (K + n)) + else x.val - (K + n) - K := by + rw [_root_.Equiv.trans_apply] + have hb := x.isLt + by_cases hlow : x.val < K + n + · rw [show x = (⟨x.val, hb⟩ : Fin ((K + n) + (K + n))) from + Fin.ext rfl] + rw [transposeEquiv_low (K + n) (K + n) x.val hlow hb (by omega)] + rw [show (⟨(K + n) + x.val, by omega⟩ : + Fin ((K + n) + (K + n))) = + Fin.natAdd (K + n) (⟨x.val, hlow⟩ : Fin (K + n)) from + Fin.ext rfl] + rw [inPermEquiv_high] + simp only [Fin.val_natAdd] + rw [ite_eq_left hlow] + · rw [show x = (⟨(K + n) + (x.val - (K + n)), by omega⟩ : + Fin ((K + n) + (K + n))) from Fin.ext + (by change x.val = (K + n) + (x.val - (K + n)); omega)] + rw [transposeEquiv_high (K + n) (K + n) (x.val - (K + n)) + (by omega) (by omega) (by omega)] + rw [show (⟨x.val - (K + n), by omega⟩ : + Fin ((K + n) + (K + n))) = + Fin.castAdd (K + n) (⟨x.val - (K + n), by omega⟩ : + Fin (K + n)) from Fin.ext rfl] + rw [inPermEquiv_low] + -- Now we need the value of ((blockRot K n).symm).symm at x.val-(K+n) + rw [_root_.Equiv.symm_symm] + have hσ : (blockRot K n + (⟨x.val - (K + n), by omega⟩ : Fin (K + n))).val = + if x.val - (K + n) < K then n + (x.val - (K + n)) + else x.val - (K + n) - K := by + rw [blockRot_val] + simp only [Fin.val_castAdd, hσ] + split_ifs <;> omega + +/-! ### Collapsing a value-identity recast -/ + +/-- Collapse a value-identity recast. -/ +noncomputable def relabelDefeqCollapse {a : ℕ} + (F : Fragment (Fin a)) (p : a = a) : + (F.relabel (finCongr p)).Equiv F := + (Fragment.Equiv.relabelEq F + (_root_.Equiv.ext (fun _ => Fin.ext rfl))).trans + (Fragment.Equiv.relabelRefl F) + +/-- Composition against an outer-boundary recast. -/ +noncomputable def composeRelabelCastOut + {s t u u' : ℕ} (h : u = u') + (F : Fragment (Fin (s + t))) (G : Fragment (Fin (t + u))) : + (F.compose (G.relabel + (finCongr (by rw [h] : t + u = t + u')))).Equiv + ((F.compose G).relabel + (finCongr (by rw [h] : s + u = s + u'))) := by + cases h + exact (Fragment.composeCongr (Fragment.Equiv.refl F) + (relabelDefeqCollapse G _)).trans + (relabelDefeqCollapse (F.compose G) _).symm + +/-! ### The bridge: the rotation as through-strands and cups -/ + +private theorem block_bridge_attach_low (K n : ℕ) + (f : (((strandBundle (K + n + n)).relabel + ((permHighEquiv (blockRot (K + n) n).symm).trans + (pcReshuffle (K + n) (K + n) n n)))).Flag) + (hlo : f.1.val < n) : + ((((tensorFragment (s := n + n) (t := n + n) (u := 0) (v := K + K) + (strandBundle (n + n)) + ((strandBundle K).relabel + (finCongr (by omega : K + K = 0 + (K + K))))).relabel + (finCongr (by omega : + (n + n + 0) + (n + n + (K + K)) = + (n + n) + ((K + n) + (K + n))))).relabel + (outPermEquiv (n + n) + (blockOuterPerm K n)))).attach (blockSpliceFlagEquiv K n f) = + ((((strandBundle (K + n + n)).relabel + ((permHighEquiv (blockRot (K + n) n).symm).trans + (pcReshuffle (K + n) (K + n) n n)))).attach f).map ( + haveI : IsEmpty ((Empty ⊕ Empty : Type)) := + ⟨fun x => x.elim Empty.elim Empty.elim⟩ + show (Empty : Type) ≃ (Empty ⊕ Empty : Type) from + _root_.Equiv.equivOfIsEmpty _ _) id := by + obtain ⟨w, b⟩ := f + change w.val < n at hlo + change (((tensorFragment (strandBundle (n + n)) + ((strandBundle K).relabel + (finCongr (by omega : K + K = 0 + (K + K))))).relabel + (finCongr (by omega : + (n + n + 0) + (n + n + (K + K)) = + (n + n) + ((K + n) + (K + n))))).relabel + (outPermEquiv (n + n) (blockOuterPerm K n))).attach + (blockSpliceFlagEquiv K n (w, b)) = + Sum.map _ id + (((strandBundle (K + n + n)).relabel + ((permHighEquiv (blockRot (K + n) n).symm).trans + (pcReshuffle (K + n) (K + n) n n))).attach (w, b)) + rw [show blockSpliceFlagEquiv K n (w, b) = + Sum.inl (⟨n + w.val, by omega⟩, !b) from by + simp only [blockSpliceFlagEquiv, Equiv.coe_fn_mk] + exact dite_eq_left hlo] + cases b + · -- in-end (b = false): wire w in-label -> through-strand n+w, out end + dsimp only [tensorFragment, Fragment.relabel, + Fragment.disjUnion, strandBundle, Sum.elim_inl, + Sum.elim_inr, Sum.map_inr, Sum.map_inl, + Bool.not_false] + refine congrArg Sum.inr (Fin.ext ?_) + simp only [Bool.not_false, + Bool.false_eq_true, ite_false, ite_true, id_eq] + rw [show (⟨(n + n) + (n + w.val), by omega⟩ : + Fin ((n + n) + (n + n))) = + Fin.natAdd (n + n) (⟨n + w.val, by omega⟩ : Fin (n + n)) from + Fin.ext rfl] + rw [interleaveEquiv_inl_high] + rw [show ((finCongr (by omega : + (n + n + 0) + (n + n + (K + K)) = + (n + n) + ((K + n) + (K + n)))) + (Fin.natAdd (n + n + 0) + (Fin.castAdd (K + K) (⟨n + w.val, by omega⟩ : Fin (n + n))))) = + Fin.natAdd (n + n) + (⟨n + w.val, by omega⟩ : Fin ((K + n) + (K + n))) from + Fin.ext (by simp)] + rw [outPermEquiv_high] + rw [block_label_val] + simp only [Fin.val_natAdd] + rw [blockOuterPerm_val] + simp only [] + split_ifs <;> omega + · -- out-end (b = true): wire w out-label -> through-strand n+w, in end + dsimp only [tensorFragment, Fragment.relabel, + Fragment.disjUnion, strandBundle, Sum.elim_inl, + Sum.elim_inr, Sum.map_inr, Sum.map_inl, + Bool.not_true] + refine congrArg Sum.inr (Fin.ext ?_) + simp only [ Bool.not_true, + Bool.false_eq_true, ite_false, ite_true, id_eq] + rw [show (⟨(n + w.val), by omega⟩ : Fin ((n + n) + (n + n))) = + Fin.castAdd (n + n) (⟨n + w.val, by omega⟩ : Fin (n + n)) from + Fin.ext rfl] + rw [interleaveEquiv_inl_low] + rw [show ((finCongr (by omega : + (n + n + 0) + (n + n + (K + K)) = + (n + n) + ((K + n) + (K + n)))) + (Fin.castAdd (n + n + (K + K)) + (Fin.castAdd 0 (⟨n + w.val, by omega⟩ : Fin (n + n))))) = + Fin.castAdd ((K + n) + (K + n)) + (⟨n + w.val, by omega⟩ : Fin (n + n)) from + Fin.ext (by simp)] + rw [outPermEquiv_low] + rw [block_label_val] + simp only [Fin.val_castAdd] + split_ifs <;> omega + +private theorem block_bridge_attach_comm (K n : ℕ) + (f : (((strandBundle (K + n + n)).relabel + ((permHighEquiv (blockRot (K + n) n).symm).trans + (pcReshuffle (K + n) (K + n) n n)))).Flag) : + ((((tensorFragment (s := n + n) (t := n + n) (u := 0) (v := K + K) + (strandBundle (n + n)) + ((strandBundle K).relabel + (finCongr (by omega : K + K = 0 + (K + K))))).relabel + (finCongr (by omega : + (n + n + 0) + (n + n + (K + K)) = + (n + n) + ((K + n) + (K + n))))).relabel + (outPermEquiv (n + n) + (blockOuterPerm K n)))).attach (blockSpliceFlagEquiv K n f) = + ((((strandBundle (K + n + n)).relabel + ((permHighEquiv (blockRot (K + n) n).symm).trans + (pcReshuffle (K + n) (K + n) n n)))).attach f).map ( + haveI : IsEmpty ((Empty ⊕ Empty : Type)) := + ⟨fun x => x.elim Empty.elim Empty.elim⟩ + show (Empty : Type) ≃ (Empty ⊕ Empty : Type) from + _root_.Equiv.equivOfIsEmpty _ _) id := by + obtain ⟨w, b⟩ := f + change (((tensorFragment (strandBundle (n + n)) + ((strandBundle K).relabel + (finCongr (by omega : K + K = 0 + (K + K))))).relabel + (finCongr (by omega : + (n + n + 0) + (n + n + (K + K)) = + (n + n) + ((K + n) + (K + n))))).relabel + (outPermEquiv (n + n) (blockOuterPerm K n))).attach + (blockSpliceFlagEquiv K n (w, b)) = + Sum.map _ id + (((strandBundle (K + n + n)).relabel + ((permHighEquiv (blockRot (K + n) n).symm).trans + (pcReshuffle (K + n) (K + n) n n))).attach (w, b)) + by_cases hlo : w.val < n + -- ═══════ THE THROUGH STRANDS ═══════ + -- Wires below `n` and wires from `K+n` up are the two halves of + -- the through-strand bundle; each end maps across unchanged. + · exact block_bridge_attach_low K n (w, b) hlo + · by_cases hhi : w.val ≥ K + n + · -- Through-strand high block (wire w >= K+n) + rw [show blockSpliceFlagEquiv K n (w, b) = + Sum.inl (⟨w.val - (K + n), by have := w.isLt; omega⟩, b) from by + simp only [blockSpliceFlagEquiv, Equiv.coe_fn_mk] + rw [dite_eq_right hlo, dite_eq_left hhi]] + cases b + · -- in-end: wire w in-label -> through-strand w-(K+n), in end + dsimp only [tensorFragment, Fragment.relabel, + Fragment.disjUnion, strandBundle, Sum.elim_inl, + Sum.elim_inr, Sum.map_inr, Sum.map_inl] + refine congrArg Sum.inr (Fin.ext ?_) + simp only [ + Bool.false_eq_true, ite_false, id_eq] + rw [show (⟨w.val - (K + n), by have := w.isLt; omega⟩ : + Fin ((n + n) + (n + n))) = + Fin.castAdd (n + n) + (⟨w.val - (K + n), by have := w.isLt; omega⟩ : + Fin (n + n)) from Fin.ext rfl] + rw [interleaveEquiv_inl_low] + rw [show ((finCongr (by omega : + (n + n + 0) + (n + n + (K + K)) = + (n + n) + ((K + n) + (K + n)))) + (Fin.castAdd (n + n + (K + K)) + (Fin.castAdd 0 (⟨w.val - (K + n), + by have := w.isLt; omega⟩ : Fin (n + n))))) = + Fin.castAdd ((K + n) + (K + n)) + (⟨w.val - (K + n), + by have := w.isLt; omega⟩ : Fin (n + n)) from + Fin.ext (by simp)] + rw [outPermEquiv_low] + rw [block_label_val] + simp only [Fin.val_castAdd] + split_ifs <;> omega + · -- out-end: wire w out-label -> through-strand w-(K+n), out end + dsimp only [tensorFragment, Fragment.relabel, + Fragment.disjUnion, strandBundle, Sum.elim_inl, + Sum.elim_inr, Sum.map_inr, Sum.map_inl] + refine congrArg Sum.inr (Fin.ext ?_) + simp only [ + ite_true, id_eq] + rw [show (⟨(n + n) + (w.val - (K + n)), + by have := w.isLt; omega⟩ : + Fin ((n + n) + (n + n))) = + Fin.natAdd (n + n) + (⟨w.val - (K + n), + by have := w.isLt; omega⟩ : Fin (n + n)) from + Fin.ext rfl] + rw [interleaveEquiv_inl_high] + rw [show ((finCongr (by omega : + (n + n + 0) + (n + n + (K + K)) = + (n + n) + ((K + n) + (K + n)))) + (Fin.natAdd (n + n + 0) + (Fin.castAdd (K + K) + (⟨w.val - (K + n), + by have := w.isLt; omega⟩ : Fin (n + n))))) = + Fin.natAdd (n + n) + (⟨w.val - (K + n), + by have := w.isLt; omega⟩ : + Fin ((K + n) + (K + n))) from + Fin.ext (by simp)] + rw [outPermEquiv_high] + rw [block_label_val] + simp only [Fin.val_natAdd] + rw [blockOuterPerm_val] + simp only [] + split_ifs <;> omega + -- ═══════ THE CUPS ═══════ + -- The remaining wires are the `K` cups, indexed by `w - n`. + · -- Pass wire: cup k := w - n + have hpass : n ≤ w.val ∧ w.val < K + n := by omega + rw [show blockSpliceFlagEquiv K n (w, b) = + Sum.inr (⟨w.val - n, by omega⟩, b) from by + simp only [blockSpliceFlagEquiv, Equiv.coe_fn_mk] + rw [dite_eq_right hlo, dite_eq_right (by omega)]] + cases b + · -- in-end: pass wire -> cup, low end + dsimp only [tensorFragment, Fragment.relabel, + Fragment.disjUnion, strandBundle, Sum.elim_inl, + Sum.elim_inr, Sum.map_inr, Sum.map_inl] + refine congrArg Sum.inr (Fin.ext ?_) + simp only [ + Bool.false_eq_true, ite_false, id_eq] + rw [show ((finCongr (by omega : + K + K = 0 + (K + K))) + (⟨w.val - n, by omega⟩ : Fin (K + K))) = + Fin.natAdd 0 (⟨w.val - n, by omega⟩ : + Fin (K + K)) from + Fin.ext (by simp)] + rw [interleaveEquiv_inr_high] + rw [show ((finCongr (by omega : + (n + n + 0) + (n + n + (K + K)) = + (n + n) + ((K + n) + (K + n)))) + (Fin.natAdd (n + n + 0) + (Fin.natAdd (n + n) (⟨w.val - n, + by omega⟩ : Fin (K + K))))) = + Fin.natAdd (n + n) + (⟨(n + n) + (w.val - n), + by omega⟩ : + Fin ((K + n) + (K + n))) from + Fin.ext (by simp)] + rw [outPermEquiv_high] + rw [block_label_val] + simp only [Fin.val_natAdd] + rw [blockOuterPerm_val] + simp only [] + split_ifs <;> omega + · -- out-end: pass wire -> cup, high end + dsimp only [tensorFragment, Fragment.relabel, + Fragment.disjUnion, strandBundle, Sum.elim_inl, + Sum.elim_inr, Sum.map_inr, Sum.map_inl] + refine congrArg Sum.inr (Fin.ext ?_) + simp only [ + ite_true, id_eq] + rw [show ((finCongr (by omega : + K + K = 0 + (K + K))) + (⟨K + (w.val - n), by omega⟩ : Fin (K + K))) = + Fin.natAdd 0 (⟨K + (w.val - n), by omega⟩ : + Fin (K + K)) from + Fin.ext (by simp)] + rw [interleaveEquiv_inr_high] + rw [show ((finCongr (by omega : + (n + n + 0) + (n + n + (K + K)) = + (n + n) + ((K + n) + (K + n)))) + (Fin.natAdd (n + n + 0) + (Fin.natAdd (n + n) (⟨K + (w.val - n), + by omega⟩ : Fin (K + K))))) = + Fin.natAdd (n + n) + (⟨(n + n) + (K + (w.val - n)), + by omega⟩ : + Fin ((K + n) + (K + n))) from + Fin.ext (by simp)] + rw [outPermEquiv_high] + rw [block_label_val] + simp only [Fin.val_natAdd] + rw [blockOuterPerm_val] + simp only [] + split_ifs <;> omega + +/-- The splice flag map anticommutes with strand flips. -/ +private theorem blockSpliceFlagEquiv_pairing (K n : ℕ) + (w : Fin (K + n + n)) (b : Bool) : + blockSpliceFlagEquiv K n (w, !b) = + Sum.map (fun q : Fin (n + n) × Bool => (q.1, !q.2)) + (fun q : Fin K × Bool => (q.1, !q.2)) + (blockSpliceFlagEquiv K n (w, b)) := by + simp only [blockSpliceFlagEquiv, Equiv.coe_fn_mk] + by_cases hlo : w.val < n + · rw [dite_eq_left hlo, dite_eq_left hlo]; rfl + · by_cases hhi : w.val ≥ K + n + · rw [dite_eq_right hlo, dite_eq_left hhi, dite_eq_right hlo, dite_eq_left hhi]; rfl + · rw [dite_eq_right hlo, dite_eq_right (by omega), dite_eq_right hlo, dite_eq_right (by + omega)]; rfl + +/-- **The bridge**: the reshuffled big block rotation, as a +relabelled bundle, is the through-strands tensored with K cups, +up to the outer boundary permutation. -/ +noncomputable def blockBridge (K n : ℕ) : + ((strandBundle (K + n + n)).relabel + ((permHighEquiv (blockRot (K + n) n).symm).trans + (pcReshuffle (K + n) (K + n) n n))).Equiv + (((tensorFragment (s := n + n) (t := n + n) (u := 0) (v := K + K) + (strandBundle (n + n)) + ((strandBundle K).relabel + (finCongr (by omega : K + K = 0 + (K + K))))).relabel + (finCongr (by omega : + (n + n + 0) + (n + n + (K + K)) = + (n + n) + ((K + n) + (K + n))))).relabel + (outPermEquiv (n + n) + (blockOuterPerm K n))) where + flagEquiv := blockSpliceFlagEquiv K n + vertexEquiv := + haveI : IsEmpty ((Empty ⊕ Empty : Type)) := + ⟨fun x => x.elim Empty.elim Empty.elim⟩ + show (Empty : Type) ≃ (Empty ⊕ Empty : Type) from + _root_.Equiv.equivOfIsEmpty _ _ + attach_comm := by exact block_bridge_attach_comm K n + pairing_comm := fun f => by + exact blockSpliceFlagEquiv_pairing K n f.1 f.2 + circles_eq := rfl + +/-! ### The reshuffle decomposition -/ + +/-- The reshuffle decomposition: the reshuffled big block rotation +is the through-strands tensored with K cups, up to the outer +boundary permutation. -/ +noncomputable def blockReshuffleDecomp (K n : ℕ) : + ((permFragment (blockRot (K + n) n).symm).relabel + (pcReshuffle (K + n) (K + n) n n)).Equiv + (((tensorFragment (s := n + n) (t := n + n) (u := 0) (v := K + K) + (strandBundle (n + n)) + ((strandBundle K).relabel + (finCongr (by omega : K + K = 0 + (K + K))))).relabel + (finCongr (by omega : + (n + n + 0) + (n + n + (K + K)) = + (n + n) + ((K + n) + (K + n))))).relabel + (outPermEquiv (n + n) + (blockOuterPerm K n))) := + (Fragment.Equiv.relabelCongr + (permFragmentRelabelBundle (blockRot (K + n) n).symm) + (pcReshuffle (K + n) (K + n) n n)).trans + ((Fragment.Equiv.relabelTrans (strandBundle (K + n + n)) + (permHighEquiv (blockRot (K + n) n).symm) + (pcReshuffle (K + n) (K + n) n n)).trans + (blockBridge K n)) + +/-! ### The final flag map and bridge -/ + +/-- The flag map of the final comparison: the G-flags cross +sides, the cups flip into through-strands. -/ +def blockFinalFlagEquiv (K n : ℕ) + (𝔊 : Fragment (Fin (n + n))) : + (𝔊.Flag ⊕ (Fin K × Bool)) ≃ ((Fin K × Bool) ⊕ 𝔊.Flag) where + toFun := Sum.elim (fun g : 𝔊.Flag => Sum.inr g) + (fun q : Fin K × Bool => Sum.inl (q.1, !q.2)) + invFun := Sum.elim (fun q : Fin K × Bool => + Sum.inr (q.1, !q.2)) + (fun g : 𝔊.Flag => Sum.inl g) + left_inv := by + rintro (g | ⟨k, c⟩) + · rfl + · rw [Sum.elim_inr, Sum.elim_inl, Bool.not_not] + right_inv := by + rintro (⟨k, c⟩ | g) + · rw [Sum.elim_inl, Sum.elim_inr, Bool.not_not] + · rfl + +private theorem block_splice_bridge_attach_comm (K n : ℕ) + (𝔊 : Fragment (Fin (n + n))) + (f : (((tensorFragment (s := 0) (t := n + n) (u := 0) (v := K + K) + (𝔊.relabel + (finCongr (by omega : n + n = 0 + (n + n)))) + ((strandBundle K).relabel + (finCongr (by omega : K + K = 0 + (K + K))))).relabel + (((finCongr (by omega : + 0 + ((n + n) + (K + K)) = 0 + ((K + n) + (K + n)))).trans + (outPermEquiv 0 + (blockOuterPerm K n))).trans + (finCongr (by omega : + 0 + ((K + n) + (K + n)) = (K + n) + (K + n)))))).Flag) : + (((tensorFragment (strandBundle K) 𝔊).relabel + ((transposeEquiv (K + n) (K + n)).trans + (inPermEquiv + ((blockRot K n).symm).symm (K + n))))).attach (blockFinalFlagEquiv K n 𝔊 f) = + ((((tensorFragment (s := 0) (t := n + n) (u := 0) (v := K + K) + (𝔊.relabel + (finCongr (by omega : n + n = 0 + (n + n)))) + ((strandBundle K).relabel + (finCongr (by omega : K + K = 0 + (K + K))))).relabel + (((finCongr (by omega : + 0 + ((n + n) + (K + K)) = 0 + ((K + n) + (K + n)))).trans + (outPermEquiv 0 + (blockOuterPerm K n))).trans + (finCongr (by omega : + 0 + ((K + n) + (K + n)) = (K + n) + (K + n)))))).attach f).map ( + show (𝔊.Vertex ⊕ (Empty : Type)) ≃ + ((Empty : Type) ⊕ 𝔊.Vertex) from + _root_.Equiv.sumComm _ _) id := by + revert f + rintro (g | ⟨k, c⟩) + -- ═══════ THE FRAGMENT'S OWN FLAGS ═══════ + · -- a G-flag crosses sides + change Sum.map id + (⇑((transposeEquiv (K + n) (K + n)).trans + (inPermEquiv + ((blockRot K n).symm).symm (K + n)))) + (Sum.map id + (⇑(interleaveEquiv K K n n)) + ((𝔊.attach g).map Sum.inr Sum.inr)) = + Sum.map _ id + (Sum.map id + (⇑(((finCongr (by omega : + 0 + ((n + n) + (K + K)) = + 0 + ((K + n) + (K + n)))).trans + (outPermEquiv 0 + (blockOuterPerm K n))).trans + (finCongr (by omega : + 0 + ((K + n) + (K + n)) = + (K + n) + (K + n))))) + (Sum.map id + (⇑(interleaveEquiv 0 (n + n) 0 (K + K))) + (((𝔊.attach g).map id + (⇑(finCongr (by omega : + n + n = 0 + (n + n))))).map + Sum.inl Sum.inl))) + rcases 𝔊.attach g with v | ℓ + · rfl + · simp only [Sum.map_inr] + refine congrArg Sum.inr (Fin.ext ?_) + -- Both sides reduce to value computations + by_cases hv : ℓ.val < n + · -- ℓ is a low label of 𝔊 + rw [show ℓ = Fin.castAdd n + (⟨ℓ.val, hv⟩ : Fin n) from Fin.ext + (by simp only [Fin.val_castAdd])] + rw [interleaveEquiv_inr_low] + rw [show ((finCongr (by omega : + n + n = 0 + (n + n))) + (Fin.castAdd n (⟨ℓ.val, hv⟩ : Fin n))) = + Fin.natAdd 0 (⟨ℓ.val, by omega⟩ : Fin (n + n)) from + Fin.ext (by simp [])] + rw [interleaveEquiv_inl_high] + rw [show (Fin.natAdd (0 + 0) + (Fin.castAdd (K + K) (⟨ℓ.val, by omega⟩ : + Fin (n + n)))) = + (⟨ℓ.val, by omega⟩ : + Fin (0 + ((n + n) + (K + K)))) from + Fin.ext (by simp [ Fin.val_castAdd])] + simp only [id_eq] + rw [block_ER_val, block_bigE_val] + simp only [Fin.val_castAdd, Fin.val_natAdd] + split_ifs <;> omega + · -- ℓ is a high label of 𝔊 + rw [show ℓ = Fin.natAdd n + (⟨ℓ.val - n, by have := ℓ.isLt; omega⟩ : Fin n) from + Fin.ext (by simp only [Fin.val_natAdd]; omega)] + rw [interleaveEquiv_inr_high] + rw [show ((finCongr (by omega : + n + n = 0 + (n + n))) + (Fin.natAdd n (⟨ℓ.val - n, by have := ℓ.isLt; omega⟩ : + Fin n))) = + Fin.natAdd 0 (⟨ℓ.val, by have := ℓ.isLt; omega⟩ : + Fin (n + n)) from + Fin.ext (by simp []; omega)] + rw [interleaveEquiv_inl_high] + rw [show (Fin.natAdd (0 + 0) + (Fin.castAdd (K + K) (⟨ℓ.val, by have := ℓ.isLt; omega⟩ : + Fin (n + n)))) = + (⟨ℓ.val, by have := ℓ.isLt; omega⟩ : + Fin (0 + ((n + n) + (K + K)))) from + Fin.ext (by simp [ Fin.val_castAdd])] + simp only [id_eq] + rw [block_ER_val, block_bigE_val] + simp only [ Fin.val_natAdd] + split_ifs <;> omega + -- ═══════ THE CUP FLAGS ═══════ + · -- a cup flag flips into a through-strand + change Sum.map id + (⇑((transposeEquiv (K + n) (K + n)).trans + (inPermEquiv + ((blockRot K n).symm).symm (K + n)))) + (Sum.map id + (⇑(interleaveEquiv K K n n)) + ((Sum.inr (if !c then + (⟨K + k.val, by have := k.isLt; omega⟩ : + Fin (K + K)) + else ⟨k.val, by have := k.isLt; omega⟩)).map + Sum.inl Sum.inl)) = + Sum.map _ id + (Sum.map id + (⇑(((finCongr (by omega : + 0 + ((n + n) + (K + K)) = + 0 + ((K + n) + (K + n)))).trans + (outPermEquiv 0 + (blockOuterPerm K n))).trans + (finCongr (by omega : + 0 + ((K + n) + (K + n)) = + (K + n) + (K + n))))) + (Sum.map id + (⇑(interleaveEquiv 0 (n + n) 0 (K + K))) + (((Sum.inr ((finCongr (by omega : + K + K = 0 + (K + K))) + (if c then + (⟨K + k.val, by have := k.isLt; omega⟩ : + Fin (K + K)) + else ⟨k.val, + by have := k.isLt; omega⟩))).map + Sum.inr Sum.inr)))) + cases c + · simp only [Bool.not_false, Sum.map_inr, + Bool.false_eq_true, ite_false, ite_true] + refine congrArg Sum.inr (Fin.ext ?_) + rw [show (⟨K + k.val, by have := k.isLt; omega⟩ : + Fin (K + K)) = + Fin.natAdd K (⟨k.val, k.isLt⟩ : Fin K) from + Fin.ext rfl] + rw [interleaveEquiv_inl_high] + rw [show ((finCongr (by omega : K + K = 0 + (K + K))) + (⟨k.val, by have := k.isLt; omega⟩ : + Fin (K + K))) = + Fin.natAdd 0 (⟨k.val, + by have := k.isLt; omega⟩ : Fin (K + K)) from + Fin.ext (by simp [])] + rw [interleaveEquiv_inr_high] + rw [show (Fin.natAdd (0 + 0) (Fin.natAdd (n + n) + (⟨k.val, by have := k.isLt; omega⟩ : + Fin (K + K)))) = + (⟨(n + n) + k.val, by have := k.isLt; omega⟩ : + Fin (0 + ((n + n) + (K + K)))) from + Fin.ext (by simp [])] + simp only [id_eq] + rw [block_ER_val, block_bigE_val] + simp only [Fin.val_castAdd, Fin.val_natAdd] + split_ifs <;> omega + · simp only [Bool.not_true, Sum.map_inr, + Bool.false_eq_true, ite_false, ite_true] + refine congrArg Sum.inr (Fin.ext ?_) + rw [show (⟨k.val, by have := k.isLt; omega⟩ : + Fin (K + K)) = + Fin.castAdd K (⟨k.val, k.isLt⟩ : Fin K) from + Fin.ext rfl] + rw [interleaveEquiv_inl_low] + rw [show ((finCongr (by omega : K + K = 0 + (K + K))) + (⟨K + k.val, by have := k.isLt; omega⟩ : + Fin (K + K))) = + Fin.natAdd 0 (⟨K + k.val, + by have := k.isLt; omega⟩ : Fin (K + K)) from + Fin.ext (by simp [])] + rw [interleaveEquiv_inr_high] + rw [show (Fin.natAdd (0 + 0) (Fin.natAdd (n + n) + (⟨K + k.val, by have := k.isLt; omega⟩ : + Fin (K + K)))) = + (⟨(n + n) + (K + k.val), by have := k.isLt; omega⟩ : + Fin (0 + ((n + n) + (K + K)))) from + Fin.ext (by simp [])] + simp only [id_eq] + rw [block_ER_val, block_bigE_val] + simp only [Fin.val_castAdd] + split_ifs <;> omega + +private theorem block_splice_bridge_circles (K n : ℕ) + (𝔊 : Fragment (Fin (n + n))) : + (((tensorFragment (s := 0) (t := n + n) (u := 0) (v := K + K) + (𝔊.relabel + (finCongr (by omega : n + n = 0 + (n + n)))) + ((strandBundle K).relabel + (finCongr (by omega : K + K = 0 + (K + K))))).relabel + (((finCongr (by omega : + 0 + ((n + n) + (K + K)) = 0 + ((K + n) + (K + n)))).trans + (outPermEquiv 0 + (blockOuterPerm K n))).trans + (finCongr (by omega : + 0 + ((K + n) + (K + n)) = (K + n) + (K + n)))))).circles = (((tensorFragment + (strandBundle K) 𝔊).relabel + ((transposeEquiv (K + n) (K + n)).trans + (inPermEquiv + ((blockRot K n).symm).symm (K + n))))).circles := by + change 𝔊.circles + (strandBundle K).circles = + (strandBundle K).circles + 𝔊.circles + omega + +/-- The last comparison of the block splice: the leg-extended +tensor against the rotated through-tensor. -/ +noncomputable def blockSpliceBridge (K n : ℕ) + (𝔊 : Fragment (Fin (n + n))) : + ((tensorFragment (s := 0) (t := n + n) (u := 0) (v := K + K) + (𝔊.relabel + (finCongr (by omega : n + n = 0 + (n + n)))) + ((strandBundle K).relabel + (finCongr (by omega : K + K = 0 + (K + K))))).relabel + (((finCongr (by omega : + 0 + ((n + n) + (K + K)) = 0 + ((K + n) + (K + n)))).trans + (outPermEquiv 0 + (blockOuterPerm K n))).trans + (finCongr (by omega : + 0 + ((K + n) + (K + n)) = (K + n) + (K + n))))).Equiv + ((tensorFragment (strandBundle K) 𝔊).relabel + ((transposeEquiv (K + n) (K + n)).trans + (inPermEquiv + ((blockRot K n).symm).symm (K + n)))) where + flagEquiv := blockFinalFlagEquiv K n 𝔊 + vertexEquiv := + show (𝔊.Vertex ⊕ (Empty : Type)) ≃ + ((Empty : Type) ⊕ 𝔊.Vertex) from + _root_.Equiv.sumComm _ _ + attach_comm := by exact block_splice_bridge_attach_comm K n 𝔊 + pairing_comm := by + rintro (g | ⟨k, c⟩) + · rfl + · rfl + circles_eq := by exact block_splice_bridge_circles K n 𝔊 + +/-! ### The splice -/ + +/-- **The block splice**: partially closing an `(n,n)`-fragment +against the block rotation on `K + 2n` strands splices it into +the block rotation on `K + n` strands. -/ +noncomputable def partialCloseBlockSplice (K n : ℕ) + (𝔊 : Fragment (Fin (n + n))) : + (partialClose 𝔊 + (permFragment (blockRot (K + n) n).symm)).Equiv + ((permFragment (blockRot K n).symm).compose + ((tensorFragment (strandBundle K) 𝔊).relabel + (transposeEquiv (K + n) (K + n)))) := by + -- Step 1: partial closure to a composition + refine (partialCloseEqCompose 𝔊 + (permFragment (blockRot (K + n) n).symm)).trans ?_ + -- Step 2: reshuffle decomposition + refine (Fragment.Equiv.relabelCongr + (Fragment.composeCongr + (Fragment.Equiv.refl _) + (blockReshuffleDecomp K n)) + (finCongr (by omega : + 0 + ((K + n) + (K + n)) = (K + n) + (K + n)))).trans ?_ + -- Step 3: composeRelabelOut (absorb outer perm into composition) + refine (Fragment.Equiv.relabelCongr + (composeRelabelOut + (blockOuterPerm K n) + (𝔊.relabel (finCongr (by omega : n + n = 0 + (n + n)))) + ((tensorFragment (s := n + n) (t := n + n) (u := 0) (v := K + K) + (strandBundle (n + n)) + ((strandBundle K).relabel + (finCongr (by omega : K + K = 0 + (K + K))))).relabel + (finCongr (by omega : + (n + n + 0) + (n + n + (K + K)) = + (n + n) + ((K + n) + (K + n)))))) + (finCongr (by omega : + 0 + ((K + n) + (K + n)) = (K + n) + (K + n)))).trans ?_ + -- Step 4: composeRelabelCastOut (collapse the recast) + refine (Fragment.Equiv.relabelCongr + (Fragment.Equiv.relabelCongr + (composeRelabelCastOut + (by omega : (n + n) + (K + K) = (K + n) + (K + n)) + (𝔊.relabel (finCongr (by omega : n + n = 0 + (n + n)))) + (tensorFragment (s := n + n) (t := n + n) (u := 0) (v := K + K) + (strandBundle (n + n)) + ((strandBundle K).relabel + (finCongr (by omega : K + K = 0 + (K + K)))))) + (outPermEquiv 0 (blockOuterPerm K n))) + (finCongr (by omega : + 0 + ((K + n) + (K + n)) = (K + n) + (K + n)))).trans ?_ + -- Step 5: tensorComposeInterchange + unit + strandBundle collapse + have E5 : ((𝔊.relabel + (finCongr (by omega : n + n = 0 + (n + n)))).compose + (tensorFragment (s := n + n) (t := n + n) (u := 0) (v := K + K) + (strandBundle (n + n)) + ((strandBundle K).relabel + (finCongr (by omega : K + K = 0 + (K + K)))))).Equiv + (tensorFragment (s := 0) (t := n + n) (u := 0) (v := K + K) + (𝔊.relabel + (finCongr (by omega : n + n = 0 + (n + n)))) + ((strandBundle K).relabel + (finCongr (by omega : K + K = 0 + (K + K))))) := + (Fragment.composeCongr + ((tensorFragmentUnitRight (𝔊.relabel + (finCongr (by omega : n + n = 0 + (n + n))))).trans + (relabelDefeqCollapse _ _)).symm + (Fragment.Equiv.refl _)).trans + ((Fragment.tensorComposeInterchange + (𝔊.relabel + (finCongr (by omega : n + n = 0 + (n + n)))) + (strandBundle (n + n)) + emptyClosedFragment + ((strandBundle K).relabel + (finCongr (by omega : K + K = 0 + (K + K))))).symm.trans + (tensorFragmentCongr + (composeStrandBundleRight 0 (n + n) _) + ((Fragment.composeCongr + strandBundleZeroEmpty.symm + (Fragment.Equiv.refl _)).trans + (composeStrandBundleLeft 0 (K + K) _)))) + refine (Fragment.Equiv.relabelCongr + (Fragment.Equiv.relabelCongr + (Fragment.Equiv.relabelCongr E5 + (finCongr (by omega : + 0 + ((n + n) + (K + K)) = 0 + ((K + n) + (K + n))))) + (outPermEquiv 0 (blockOuterPerm K n))) + (finCongr (by omega : + 0 + ((K + n) + (K + n)) = (K + n) + (K + n)))).trans ?_ + -- Step 6: collapse relabels + refine (Fragment.Equiv.relabelCongr + (Fragment.Equiv.relabelTrans _ _ _) + (finCongr (by omega : + 0 + ((K + n) + (K + n)) = (K + n) + (K + n)))).trans ?_ + refine (Fragment.Equiv.relabelTrans _ _ _).trans ?_ + -- Step 7: bridge to RHS + refine Fragment.Equiv.trans ?_ + ((permFragmentComposeLeft + ((blockRot K n).symm) + ((tensorFragment (strandBundle K) 𝔊).relabel + (transposeEquiv (K + n) (K + n)))).trans + (Fragment.Equiv.relabelTrans _ _ _)).symm + exact blockSpliceBridge K n 𝔊 + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockTower.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockTower.lean new file mode 100644 index 0000000000..7560c42480 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockTower.lean @@ -0,0 +1,321 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance + +/-! +# The block tower + +The symmetric group `S_k` acting by block permutations on `n·k` +strands: the permutation representation, the block-diagonal tensor +power, and the `PermTower` structure at the `n`-strand ambient — +the scaffolding for nilpotent-trace vanishing at every arity. + +The step arithmetic is definitional: `n * (k + 1) ≡ n * k + n`, +so the recursive block constructions live at the same indices as +the tensor structure. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +/-! ### Block permutations -/ + +/-- The block permutation: `σ : S_k` acting on `k` contiguous +blocks of `n` strands. -/ +noncomputable def blockPerm (n : ℕ) {k : ℕ} + (σ : Equiv.Perm (Fin k)) : Equiv.Perm (Fin (n * k)) := + (finCongr (Nat.mul_comm k n)).permCongr + ((finProdFinEquiv (m := k) (n := n)).permCongr + (Equiv.prodCongr σ (Equiv.refl (Fin n)))) + +/-- Block permutation of the identity. -/ +theorem blockPerm_one (n k : ℕ) : + blockPerm n (1 : Equiv.Perm (Fin k)) = 1 := by + ext x + simp [blockPerm, Nat.mod_add_div] + +/-- Block permutations are multiplicative. -/ +theorem blockPerm_mul (n : ℕ) {k : ℕ} + (σ τ : Equiv.Perm (Fin k)) : + blockPerm n (σ * τ) = blockPerm n σ * blockPerm n τ := by + ext x + simp [blockPerm] + +/-- The block-permutation monoid homomorphism. -/ +noncomputable def blockPermHom (n k : ℕ) : + Equiv.Perm (Fin k) →* Equiv.Perm (Fin (n * k)) where + toFun := blockPerm n + map_one' := blockPerm_one n k + map_mul' := blockPerm_mul n + +/-- The value of a block permutation on `n·q + r`. -/ +theorem blockPerm_val (n : ℕ) {k : ℕ} + (σ : Equiv.Perm (Fin k)) (q : Fin k) (r : Fin n) : + blockPerm n σ + ⟨n * q.val + r.val, by + have hq := q.isLt + have hr := r.isLt + calc n * q.val + r.val < n * q.val + n := by omega + _ = n * (q.val + 1) := by ring + _ ≤ n * k := Nat.mul_le_mul_left n (by omega)⟩ = + ⟨n * (σ q).val + r.val, by + have hq := (σ q).isLt + have hr := r.isLt + calc n * (σ q).val + r.val < n * (σ q).val + n := by + omega + _ = n * ((σ q).val + 1) := by ring + _ ≤ n * k := Nat.mul_le_mul_left n (by omega)⟩ := by + have hn : 0 < n := by + have := r.isLt + omega + have hmod : (n * q.val + r.val) % n = r.val := by + rw [Nat.mul_add_mod, Nat.mod_eq_of_lt r.isLt] + have hdiv : (n * q.val + r.val) / n = q.val := by + rw [Nat.mul_add_div hn, Nat.div_eq_of_lt r.isLt] + omega + apply Fin.ext + simp only [blockPerm, Equiv.permCongr_apply, finCongr_apply, + Equiv.prodCongr_apply, finProdFinEquiv, Equiv.coe_fn_mk, + Equiv.coe_fn_symm_mk, Fin.val_cast] + simp [Fin.modNat, Fin.divNat, hmod, hdiv] + ring + +/-! ### The block representation -/ + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The block representation of the group algebra of `S_k` on +`n·k` strands. -/ +noncomputable def blockRep (n k : ℕ) : + SymGroupAlgebra k →ₐ[ℂ] skeinEnd f (n * k) := + MonoidAlgebra.lift ℂ (skeinEnd f (n * k)) + (Equiv.Perm (Fin k)) + ((permToEnd f (n * k)).comp (blockPermHom n k)) + +/-- `blockRep` on a single permutation. -/ +theorem blockRep_of (n k : ℕ) (σ : Equiv.Perm (Fin k)) : + blockRep f n k + (MonoidAlgebra.of ℂ (Equiv.Perm (Fin k)) σ) = + permClass f (n * k) (blockPerm n σ) := + MonoidAlgebra.lift_of _ σ + +/-! ### The block-diagonal power -/ + +/-- The End-typed tensor at block arities. -/ +noncomputable def blockTensorEnd {a b : ℕ} + (u : skeinEnd f a) (v : skeinEnd f b) : + skeinEnd f (a + b) := + (MonoidalCategoryStruct.tensorHom + (X₁ := SkeinObj.mk a) (Y₁ := SkeinObj.mk a) + (X₂ := SkeinObj.mk b) (Y₂ := SkeinObj.mk b) u v : + End (SkeinObj.mk (a + b))) + +/-- The block-diagonal tensor power: `k` copies of an `n`-strand +endomorphism. The index arithmetic is definitional: +`n * (k + 1) ≡ n * k + n`. -/ +noncomputable def blockPow (n : ℕ) (g : skeinEnd f n) : + (k : ℕ) → skeinEnd f (n * k) + | 0 => 1 + | k + 1 => blockTensorEnd f (blockPow n g k) g + +/-! ### The block permutation tower -/ + +/-- The dimension bound at block arities: +`R ^ (2·n·k) = (R ^ n) ^ (2·k)`. -/ +theorem blockEnd_finrank_le (n k : ℕ) : + Module.finrank ℂ (skeinEnd f (n * k)) ≤ + (R ^ n) ^ (2 * k) := by + calc Module.finrank ℂ (skeinEnd f (n * k)) ≤ + R ^ (2 * (n * k)) := skeinEnd_finrank_le f (n * k) + _ = (R ^ n) ^ (2 * k) := by + rw [← pow_mul] + ring_nf + +/-- The block permutation of an extended permutation is the +extension of the block permutation. -/ +private theorem blockPerm_viaEmbedding (n : ℕ) {j k : ℕ} + (h : j ≤ k) (σ : Equiv.Perm (Fin j)) : + blockPerm n + (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ) = + Equiv.Perm.viaEmbeddingHom + (Fin.castLEEmb (Nat.mul_le_mul_left n h)) + (blockPerm n σ) := by + by_cases hn : n = 0 + · subst hn; ext ⟨v, hv⟩; simp at hv + · have hn' : 0 < n := Nat.pos_of_ne_zero hn + ext ⟨v, hv⟩ + -- Decompose v = n * q + r + have hqk : v / n < k := Nat.div_lt_of_lt_mul (by omega) + have hrn : v % n < n := Nat.mod_lt _ hn' + have hv_decomp : v = n * (v / n) + v % n := + (Nat.div_add_mod v n).symm + -- Compute LHS value via blockPerm_val + set τ := Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ + have hLHS := blockPerm_val n τ ⟨v / n, hqk⟩ ⟨v % n, hrn⟩ + have hv_bound : n * (v / n) + v % n < n * k := hv_decomp ▸ hv + have hv_fin : (⟨v, hv⟩ : Fin (n * k)) = + ⟨n * (v / n) + v % n, hv_bound⟩ := Fin.ext hv_decomp + conv_lhs => rw [hv_fin] + rw [hLHS] + by_cases hqj : v / n < j + · -- v / n < j: in-range, both sides apply σ + -- Simplify τ on q + have hτq : (τ ⟨v / n, hqk⟩).val = (σ ⟨v / n, hqj⟩).val := by + change (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ + ⟨v / n, hqk⟩).val = _ + rw [Equiv.Perm.viaEmbeddingHom_apply, + show (⟨v / n, hqk⟩ : Fin k) = + Fin.castLEEmb h ⟨v / n, hqj⟩ from Fin.ext rfl, + Equiv.Perm.viaEmbedding_apply] + simp [Fin.castLEEmb] + -- Simplify RHS via viaEmbedding_apply + blockPerm_val + have hv_lt : v < n * j := by + calc v = n * (v / n) + v % n := hv_decomp + _ < n * (v / n) + n := by omega + _ = n * (v / n + 1) := by ring + _ ≤ n * j := Nat.mul_le_mul_left n (by omega) + conv_rhs => + rw [Equiv.Perm.viaEmbeddingHom_apply, + show (⟨v, hv⟩ : Fin (n * k)) = + Fin.castLEEmb (Nat.mul_le_mul_left n h) + ⟨v, hv_lt⟩ from Fin.ext rfl, + Equiv.Perm.viaEmbedding_apply] + have hbp := blockPerm_val n σ ⟨v / n, hqj⟩ ⟨v % n, hrn⟩ + have hv_bound' : n * (v / n) + v % n < n * j := + hv_decomp ▸ hv_lt + have hv_fin' : (⟨v, hv_lt⟩ : Fin (n * j)) = + ⟨n * (v / n) + v % n, hv_bound'⟩ := Fin.ext hv_decomp + conv_rhs => rw [hv_fin', hbp] + simp only [Fin.castLEEmb, hτq] + rfl + · -- v / n ≥ j: both sides fix the element + push Not at hqj + have hv_ge : n * j ≤ v := by + calc n * j ≤ n * (v / n) := Nat.mul_le_mul_left n hqj + _ ≤ n * (v / n) + v % n := Nat.le_add_right _ _ + _ = v := Nat.div_add_mod v n + -- LHS: τ fixes q + have hτq : (τ ⟨v / n, hqk⟩).val = v / n := by + change (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ + ⟨v / n, hqk⟩).val = _ + rw [Equiv.Perm.viaEmbeddingHom_apply, + Equiv.Perm.viaEmbedding_apply_of_notMem σ + (Fin.castLEEmb h) ⟨v / n, hqk⟩ + (fun ⟨a, ha⟩ => by + have := congrArg Fin.val ha + simp [Fin.castLEEmb] at this; omega)] + -- RHS: viaEmbeddingHom fixes the element + conv_rhs => + rw [Equiv.Perm.viaEmbeddingHom_apply, + Equiv.Perm.viaEmbedding_apply_of_notMem + (blockPerm n σ) + (Fin.castLEEmb (Nat.mul_le_mul_left n h)) + ⟨v, hv⟩ (fun ⟨a, ha⟩ => by + have := congrArg Fin.val ha + simp [Fin.castLEEmb] at this + have := a.isLt; omega)] + have goal_eq : n * (τ ⟨v / n, hqk⟩).val + v % n = v := by + rw [hτq]; exact Nat.div_add_mod v n + exact goal_eq + +/-- Vanishing propagates along the standard embeddings of block +representations. -/ +theorem blockRep_compat (n : ℕ) {j k : ℕ} (h : j ≤ k) + (x : SymGroupAlgebra j) : + blockRep f n j x = 0 → + blockRep f n k (symCast h x) = 0 := by + intro hx + have h' : n * j ≤ n * k := Nat.mul_le_mul_left n h + -- Factor blockRep through skeinRep via blockPermHom + -- blockRep f n m y = skeinRep f (n*m) (mapDomainAlgHom (blockPermHom n m) y) + -- naturality: mapDomain (blockPermHom n k) ∘ symCast = symCast h' ∘ mapDomain + -- (blockPermHom n j) + let bLift := fun m => MonoidAlgebra.mapDomainAlgHom ℂ ℂ + (blockPermHom n m) + -- Step 1: blockRep factors through skeinRep + have hfactor : ∀ (m : ℕ) (y : SymGroupAlgebra m), + blockRep f n m y = + skeinRep f (n * m) (bLift m y) := by + intro m y + apply MonoidAlgebra.induction_on y + · intro σ + rw [blockRep_of] + change permClass f (n * m) (blockPerm n σ) = + skeinRep f (n * m) + (MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockPermHom n m) + (MonoidAlgebra.of ℂ _ σ)) + rw [show MonoidAlgebra.mapDomainAlgHom ℂ ℂ + (blockPermHom n m) + (MonoidAlgebra.of ℂ (Equiv.Perm (Fin m)) σ) = + MonoidAlgebra.of ℂ (Equiv.Perm (Fin (n * m))) + (blockPerm n σ) from by + change MonoidAlgebra.mapDomain (blockPermHom n m) + (MonoidAlgebra.single σ 1) = + MonoidAlgebra.single (blockPerm n σ) 1 + exact MonoidAlgebra.mapDomain_single, + skeinRep_of] + · intro a b ha hb + simp only [map_add, ha, hb] + · intro c z hz + simp only [map_smul, hz] + -- Step 2: bLift commutes with symCast (naturality) + have hnat : ∀ (y : SymGroupAlgebra j), + bLift k (symCast h y) = symCast h' (bLift j y) := by + intro y + apply MonoidAlgebra.induction_on y + · intro σ + show bLift k (symCast h (MonoidAlgebra.of ℂ _ σ)) = + symCast h' (bLift j (MonoidAlgebra.of ℂ _ σ)) + -- LHS: bLift k (of (viaEmbeddingHom (castLEEmb h) σ)) + -- = of (blockPerm n (viaEmbeddingHom (castLEEmb h) σ)) + change MonoidAlgebra.mapDomain (blockPermHom n k) + (MonoidAlgebra.mapDomain + (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h)) + (MonoidAlgebra.single σ 1)) = + MonoidAlgebra.mapDomain + (Equiv.Perm.viaEmbeddingHom + (Fin.castLEEmb h')) + (MonoidAlgebra.mapDomain (blockPermHom n j) + (MonoidAlgebra.single σ 1)) + rw [MonoidAlgebra.mapDomain_single, + MonoidAlgebra.mapDomain_single, + MonoidAlgebra.mapDomain_single, + MonoidAlgebra.mapDomain_single] + congr 1 + exact blockPerm_viaEmbedding n h σ + · intro a b ha hb + simp only [map_add, ha, hb] + · intro c z hz + simp only [map_smul, hz] + -- Conclude + rw [hfactor k (symCast h x), hnat x] + exact skeinRep_compat f h' (bLift j x) (by rwa [← hfactor]) + +/-- **The block permutation tower**: `S_k` acting by block +permutations on the `n·k`-strand endomorphism algebras, of growth +`(R ^ n) ^ 2`. -/ +noncomputable def blockPermTower (n : ℕ) : + PermTower (fun k => skeinEnd f (n * k)) (((R : ℝ) ^ n) ^ 2) where + rep k := blockRep f n k + compat h x hx := blockRep_compat f n h x hx + bound k := by + have h : ((Module.finrank ℂ (skeinEnd f (n * k)) : ℕ) : ℝ) + ≤ (((R ^ n) ^ (2 * k) : ℕ) : ℝ) := by + exact_mod_cast blockEnd_finrank_le f n k + calc ((Module.finrank ℂ (skeinEnd f (n * k)) : ℕ) : ℝ) + ≤ (((R ^ n) ^ (2 * k) : ℕ) : ℝ) := h + _ = (((R : ℝ) ^ n) ^ 2) ^ k := by + push_cast + rw [← pow_mul, ← pow_mul, ← pow_mul] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleNormal.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleNormal.lean new file mode 100644 index 0000000000..8d5a261506 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleNormal.lean @@ -0,0 +1,123 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.PermCongr + +/-! +# The block-cycle normal form + +Every permutation is conjugate to a block sum of rotations whose +block lengths are its full cycle type (fixed points included): +the normal form against which the skein trace of a permutation +factors into cycle loops. +-/ + +@[expose] public section + +namespace RS + +open Equiv Equiv.Perm + +/-- The block sum of rotations prescribed by a list of block +lengths. -/ +noncomputable def blockCycles : (l : List ℕ) → Perm (Fin l.sum) + | [] => 1 + | c :: rest => + (finSumFinEquiv.permCongr + (Equiv.sumCongr (finRotate c) (blockCycles rest)) : + Perm (Fin (c + rest.sum))) + +/-- The full cycle type: the cycle type completed by the fixed +points as one-cycles. -/ +noncomputable def fullCycleType {n : ℕ} (π : Perm (Fin n)) : + Multiset ℕ := + π.cycleType + Multiset.replicate (n - π.cycleType.sum) 1 + +/-- The full cycle type sums to the degree. -/ +theorem fullCycleType_sum {n : ℕ} (π : Perm (Fin n)) : + (fullCycleType π).sum = n := by + rw [fullCycleType, Multiset.sum_add, + Multiset.sum_replicate, smul_eq_mul, mul_one] + have h1 := π.sum_cycleType + have h2 : π.support.card ≤ n := by + have := Finset.card_le_card + (Finset.subset_univ π.support) + rwa [Finset.card_univ, Fintype.card_fin] at this + omega + +/-! ## The cycle type of a block sum -/ + +/-- The block cycles realize a prescribed full cycle type. -/ +theorem cycleType_blockCycles (l : List ℕ) + (hl : ∀ c ∈ l, 1 ≤ c) : + (blockCycles l).cycleType = + (l.filter (fun c => 2 ≤ c) : Multiset ℕ) := by + induction l with + | nil => + simp only [blockCycles, cycleType_one, List.filter_nil] + rfl + | cons c rest ih => + have hc : 1 ≤ c := hl c (List.mem_cons_self ..) + have hrest : ∀ x ∈ rest, 1 ≤ x := fun x hx => hl x + (List.mem_cons_of_mem _ hx) + -- blockCycles (c :: rest) unfolds to finSumFinEquiv.permCongr (sumCongr + -- ...) + have key : (blockCycles (c :: rest)).cycleType = + (finRotate c).cycleType + (blockCycles rest).cycleType := by + change cycleType (finSumFinEquiv.permCongr + (Equiv.sumCongr (finRotate c) (blockCycles rest))) = _ + rw [cycleType_permCongr, cycleType_sumCongr] + rw [key, ih hrest] + -- Handle finRotate c: either c = 1 or c ≥ 2 + rcases eq_or_lt_of_le hc with rfl | hc2 + · -- c = 1: finRotate 1 = 1, filter drops it + rw [show finRotate 1 = (1 : Perm (Fin 1)) from finRotate_one] + rw [cycleType_one, Multiset.zero_add] + simp + · -- c ≥ 2: cycleType = {c}, filter keeps it + rw [cycleType_finRotate_of_le hc2] + simp only [List.filter_cons] + have hd : decide (2 ≤ c) = true := by + rw [decide_eq_true_eq]; omega + simp only [hd, ite_true] + rw [← Multiset.cons_coe, Multiset.singleton_add] + +/-- **The normal form**: every permutation is conjugate to the +block sum of rotations along its full cycle type. -/ +theorem exists_conj_blockCycles {n : ℕ} (π : Perm (Fin n)) : + ∃ (l : List ℕ) (h : l.sum = n) (σ : Perm (Fin n)), + (∀ c ∈ l, 1 ≤ c) ∧ + (l : Multiset ℕ) = fullCycleType π ∧ + σ * (finCongr h).permCongr (blockCycles l) * σ⁻¹ = π := by + set l := (fullCycleType π).toList + have hcoe : (l : Multiset ℕ) = fullCycleType π := Multiset.coe_toList _ + have hsum : l.sum = n := by + have := congr_arg Multiset.sum hcoe + rw [Multiset.sum_coe] at this + rw [this, fullCycleType_sum] + have hmem : ∀ c ∈ l, 1 ≤ c := by + intro c hc + rw [← Multiset.mem_coe, hcoe, fullCycleType] at hc + rcases Multiset.mem_add.mp hc with hct | hrep + · exact le_of_lt (one_lt_of_mem_cycleType hct) + · exact le_of_eq (Multiset.eq_of_mem_replicate hrep).symm + have hct_eq : ((finCongr hsum).permCongr (blockCycles l)).cycleType = + π.cycleType := by + rw [cycleType_permCongr, cycleType_blockCycles _ hmem] + rw [← Multiset.filter_coe, hcoe, fullCycleType] + rw [Multiset.filter_add, + Multiset.filter_eq_self.mpr (fun _ h => two_le_of_mem_cycleType h), + Multiset.filter_eq_nil.mpr (fun a ha => by + rw [Multiset.eq_of_mem_replicate ha]; omega), + Multiset.add_zero] + have hconj : IsConj ((finCongr hsum).permCongr (blockCycles l)) π := + isConj_iff_cycleType_eq.mpr hct_eq + obtain ⟨σ, hσ⟩ := isConj_iff.mp hconj + exact ⟨l, hsum, σ, hmem, hcoe, hσ⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleTrace.lean new file mode 100644 index 0000000000..70b9128377 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleTrace.lean @@ -0,0 +1,185 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowHom +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.PartialTrace + +/-! +# The trace of a cycle against a tensor power + +The trace of the insertion cycle against the tensor power of an +endomorphism: bubbling the top factor down `k` slots and letting +`g` act on every factor traces to `tr(g ^ (k + 1))` times `tr g` on +each of the untouched factors. + +The argument descends one arity at a time. Tracing out the top +factor turns the bubbling at arity `n + 1` into the bubbling at +arity `n` preceded by one more copy of `g` on the new top factor — +the partial trace of the braiding is the identity — and the full +trace is unchanged by the descent (`catTrace_ptr`). Carrying an +arbitrary endomorphism on the top factor through the induction is +what makes the accumulated copies of `g` bookkeepable. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.MonoidalCategory +open CategoryTheory.BraidedCategory + +universe v u + +variable {A : Type u} + +/-! ## The trace of a tensor power -/ + +/-- **The trace of a tensor power** of an endomorphism is the power +of its trace. -/ +theorem catTrace_powHom + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [RigidCategory A] + (X : A) (g : End X) : + ∀ n : ℕ, catTrace (powHom X g n) = catTrace g ^ n + | 0 => by + change catTrace (𝟙 (𝟙_ A)) = catTrace g ^ 0 + rw [catTrace_id, catDim_unit, pow_zero] + | n + 1 => by + change catTrace (powHom X g n ⊗ₘ g) = catTrace g ^ (n + 1) + rw [catTrace_tensorHom, catTrace_powHom X g n, pow_succ] + +/-! ## Bubbling one slot down -/ + +/-- The top factor's endomorphism passes the top braiding onto the +factor below it. -/ +private theorem whiskerLeft_swapTop + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (Q X : A) (h : X ⟶ X) : + ((Q ⊗ X) ◁ h) ≫ + ((α_ Q X X).hom ≫ (Q ◁ (β_ X X).hom) ≫ (α_ Q X X).inv) = + ((α_ Q X X).hom ≫ (Q ◁ (β_ X X).hom) ≫ (α_ Q X X).inv) ≫ + ((Q ◁ h) ▷ X) := by + have hleft : (Q ⊗ X) ◁ h = + (α_ Q X X).hom ≫ (Q ◁ (X ◁ h)) ≫ (α_ Q X X).inv := by + rw [← Category.assoc, ← associator_naturality_right, + Category.assoc, Iso.hom_inv_id, Category.comp_id] + have hright : (Q ◁ h) ▷ X = + (α_ Q X X).hom ≫ (Q ◁ (h ▷ X)) ≫ (α_ Q X X).inv := by + rw [← Category.assoc, whisker_assoc, Category.assoc] + rw [hleft, hright] + simp only [Category.assoc, Iso.inv_hom_id_assoc] + rw [← Category.assoc (Q ◁ (X ◁ h)), ← whiskerLeft_comp, + braiding_naturality_right, whiskerLeft_comp, Category.assoc] + +/-- **One step of the descent**, at general objects. Tracing out +the top factor of a braiding followed by a morphism of the factors +below it and a tensor power leaves the same data one arity down, +with the two endomorphisms of the traced factor composed onto the +factor that remains. -/ +private theorem ptr_cycle_step + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [RigidCategory A] + (Q X : A) (g h : X ⟶ X) + (v a : Q ⊗ X ⟶ Q ⊗ X) : + ptr (((Q ⊗ X) ◁ h) ≫ + ((α_ Q X X).hom ≫ (Q ◁ (β_ X X).hom) ≫ (α_ Q X X).inv) ≫ + (v ▷ X) ≫ (a ⊗ₘ g)) = + (Q ◁ (g ≫ h)) ≫ v ≫ a := by + have hswap := whiskerLeft_swapTop Q X h + have htensor : (a ⊗ₘ g) = ((Q ⊗ X) ◁ g) ≫ (a ▷ X) := + tensorHom_def' a g + rw [← Category.assoc, hswap, htensor] + simp only [Category.assoc] + rw [← Category.assoc ((Q ◁ h) ▷ X), ← comp_whiskerRight, + ← Category.assoc (((Q ◁ h) ≫ v) ▷ X), + ← whisker_exchange, Category.assoc, ← comp_whiskerRight, + ← Category.assoc ((α_ Q X X).hom), ← Category.assoc, + ← Category.assoc, ptr_comp_whiskerRight] + have hbr := ptr_braiding_whiskerLeft Q X g + simp only [Category.assoc] at hbr ⊢ + rw [hbr, ← Category.assoc, ← whiskerLeft_comp] + +/-- The descent step at a tensor power, where the braiding is +`swapTop`. -/ +private theorem ptr_cycle_step_swapTop + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [RigidCategory A] + (X : A) (g h : End X) (m : ℕ) + (v a : tensorPow A X (m + 1) ⟶ tensorPow A X (m + 1)) : + ptr ((tensorPow A X (m + 1) ◁ h) ≫ swapTop X m ≫ (v ▷ X) ≫ + (a ⊗ₘ g)) = + (tensorPow A X m ◁ (g ≫ h)) ≫ v ≫ a := + ptr_cycle_step (tensorPow A X m) X g h v a + +/-- Composing one more copy on the right of a power. -/ +private theorem pow_comp_self [Category.{v} A] + {X : A} (g : End X) (k : ℕ) : + (g ^ (k + 1)) ≫ g = g ^ (k + 2) := by + change (g ^ (k + 1)) ≫ g = g ^ (k + 1 + 1) + rw [pow_succ' g (k + 1)] + exact (End.mul_def g (g ^ (k + 1))).symm + +/-! ## The cycle trace -/ + +/-- **The trace of the insertion cycle against a tensor power.** +Bubbling the top factor down `k` slots and letting `g` act on every +factor, with a further endomorphism `h` on the top factor, traces to +`tr (h ∘ g ^ (k + 1))` times one copy of `tr g` for each factor the +bubbling does not reach. -/ +theorem catTrace_insertTop_powHom + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [RigidCategory A] + (X : A) (g : End X) : + ∀ (k n : ℕ), k ≤ n → ∀ h : End X, + catTrace ((tensorPow A X n ◁ h) ≫ + insertTop X n k ≫ powHom X g (n + 1)) = + catTrace g ^ (n - k) * catTrace (h ≫ (g ^ (k + 1))) + | 0, n, _, h => by + have hz : (tensorPow A X n ◁ h) ≫ + insertTop X n 0 ≫ powHom X g (n + 1) = + powHom X g n ⊗ₘ (h ≫ g) := by + rw [insertTop_zero] + change (tensorPow A X n ◁ h) ≫ 𝟙 _ ≫ (powHom X g n ⊗ₘ g) = _ + rw [Category.id_comp, ← id_tensorHom, + tensorHom_comp_tensorHom, Category.id_comp] + refine (congrArg catTrace hz).trans ?_ + rw [catTrace_tensorHom, catTrace_powHom, Nat.sub_zero, pow_one] + | k + 1, n, hk, h => by + obtain ⟨m, rfl⟩ : ∃ m, n = m + 1 := ⟨n - 1, by omega⟩ + have hkm : k ≤ m := by omega + have hmor : (tensorPow A X (m + 1) ◁ h) ≫ + insertTop X (m + 1) (k + 1) ≫ powHom X g (m + 1 + 1) = + (tensorPow A X (m + 1) ◁ h) ≫ swapTop X m ≫ + (insertTop X m k ▷ X) ≫ (powHom X g (m + 1) ⊗ₘ g) := by + rw [insertTop_succ, powHom_succ] + exact congrArg (fun z => (tensorPow A X (m + 1) ◁ h) ≫ z) + (Category.assoc _ _ _) + refine (catTrace_ptr _).symm.trans ?_ + refine (congrArg (fun z => catTrace (ptr z)) hmor).trans ?_ + rw [ptr_cycle_step_swapTop] + refine (catTrace_insertTop_powHom X g k m hkm (g ≫ h)).trans ?_ + rw [Category.assoc, catTrace_comp_comm g (h ≫ (g ^ (k + 1))), + Category.assoc, pow_comp_self, + show m + 1 - (k + 1) = m - k from by omega] + +/-- **The trace of a cycle against a tensor power**: bubbling the +top factor down `k` slots and letting `g` act on every factor traces +to `tr (g ^ (k + 1))` times one copy of `tr g` for each factor the +bubbling does not reach. -/ +theorem catTrace_insertTop + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [RigidCategory A] + (X : A) (g : End X) {k n : ℕ} + (hk : k ≤ n) : + catTrace (insertTop X n k ≫ powHom X g (n + 1)) = + catTrace g ^ (n - k) * catTrace (g ^ (k + 1)) := by + have h := catTrace_insertTop_powHom X g k n hk (𝟙 X) + rwa [MonoidalCategory.whiskerLeft_id, Category.id_comp, + Category.id_comp] at h + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvAbelian.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvAbelian.lean new file mode 100644 index 0000000000..8377d566ab --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvAbelian.lean @@ -0,0 +1,317 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentMatTrace + +/-! +# The envelope and its regularity + +The envelope of the skein category is the Karoubi completion of +the matrix envelope of its Karoubi completion: +idempotent-complete by construction, with finite biproducts, and +with semisimple endomorphism algebras via the corner-trace +argument one level up. Von Neumann regularity +of every morphism follows from semisimplicity of the biproduct +endomorphism algebra, and kernels are the splittings of the +regular idempotents. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Idempotents CategoryTheory.Limits + +universe u + +/-! ### Regularity in semisimple rings -/ + +/-- Semisimple rings are von Neumann regular. -/ +theorem exists_mul_mul_self {A : Type u} [Ring A] + [IsSemisimpleRing A] (a : A) : ∃ b, a * b * a = a := by + obtain ⟨e, he, hspan⟩ := + IsSemisimpleRing.ideal_eq_span_idempotent + (Ideal.span {a}) + have hae : a ∈ Ideal.span {e} := by + rw [← hspan] + exact Ideal.subset_span rfl + obtain ⟨r, hr⟩ := Ideal.mem_span_singleton'.mp hae + have hea : e ∈ Ideal.span {a} := by + rw [hspan] + exact Ideal.subset_span rfl + obtain ⟨s, hs⟩ := Ideal.mem_span_singleton'.mp hea + refine ⟨s, ?_⟩ + calc a * s * a = a * (s * a) := by rw [mul_assoc] + _ = a * e := by rw [hs] + _ = r * e * e := by rw [hr] + _ = r * (e * e) := by rw [mul_assoc] + _ = r * e := by rw [he] + _ = a := hr + +/-! ### The envelope -/ + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The envelope: the Karoubi completion of the matrix envelope of +the Karoubi completion of the skein category — `Kar(Add(Kar(𝒞_f)))` +where the accompanying paper's Cauchy completion `𝒟_f` (§3.4) is +`Kar(Add(𝒞_f))`. + +The two agree up to equivalence, both being Cauchy completions of +`𝒞_f`, and the inner Karoubi carries its weight in the proofs: an +atom is the image of an atomic idempotent of a skein endomorphism +algebra, so atoms exist only where idempotents split, and the +nilpotent-trace argument for the matrix envelope reads the atomic +decomposition of each matrix entry +(`AtomicIdempotents.lean`, `AtomDichotomy.lean`, +`NilpotentMatTrace.lean`). The outer Karoubi is still needed: +the additive envelope of an idempotent-complete category need not +be idempotent-complete. -/ +@[reducible] def Env := Karoubi (Mat_ (Karoubi (SkeinObj f))) + +/-! ### Semisimplicity of envelope endomorphism algebras -/ + +variable (E : Env f) + +/-- The envelope corner trace. -/ +noncomputable def envTrace : End E →ₗ[ℂ] ℂ where + toFun x := matTrace f E.X x.f + map_add' x y := by + change matTrace f E.X (x + y).f = _ + rw [show (x + y).f = x.f + y.f from rfl] + exact (matTrace f E.X).map_add _ _ + map_smul' c x := by + change matTrace f E.X (c • x).f = _ + rw [show (c • x).f = c • x.f from rfl, RingHom.id_apply] + exact (matTrace f E.X).map_smul _ _ + +/-- **Semisimplicity of envelope endomorphism algebras.** -/ +theorem envEnd_isSemisimpleRing : IsSemisimpleRing (End E) := + karoubiEnd_isSemisimpleRing_of_trace E (matTrace f E.X) + (fun _ hx => matTrace_eq_zero_of_isNilpotent' hx) + (matTrace_comp_comm f) + (matEnd_eq_zero_of_traces_vanish f) + +/-! ### Regularity of envelope morphisms -/ + +/-- Every envelope morphism is von Neumann regular. -/ +theorem env_hom_regular {M N : Env f} (u : M ⟶ N) : + ∃ g : N ⟶ M, u ≫ g ≫ u = u := by + have : HasFiniteBiproducts (Env f) := inferInstance + have : HasBinaryBiproducts (Env f) := + hasBinaryBiproducts_of_finite_biproducts _ + have := envEnd_isSemisimpleRing f (M ⊞ N) + obtain ⟨G, hG⟩ := exists_mul_mul_self + (A := End (M ⊞ N)) + ((biprod.fst ≫ u ≫ biprod.inr : End (M ⊞ N))) + have hG' : (biprod.fst ≫ u ≫ biprod.inr) ≫ G ≫ + (biprod.fst ≫ u ≫ biprod.inr) = + biprod.fst ≫ u ≫ biprod.inr := hG + refine ⟨biprod.inr ≫ G ≫ biprod.fst, ?_⟩ + have h := congrArg + (fun z => (biprod.inl : M ⟶ M ⊞ N) ≫ z ≫ + (biprod.snd : M ⊞ N ⟶ N)) hG' + simpa using h + +/-! ### Kernels -/ + +/-- The kernel idempotent of a regular pair. -/ +private theorem env_ker_idem {M N : Env f} (u : M ⟶ N) + (g : N ⟶ M) (hg : u ≫ g ≫ u = u) : + (𝟙 M - u ≫ g) ≫ (𝟙 M - u ≫ g) = 𝟙 M - u ≫ g := by + have h2 : (u ≫ g) ≫ u ≫ g = u ≫ g := by + rw [show (u ≫ g) ≫ u ≫ g = (u ≫ g ≫ u) ≫ g from by + simp only [Category.assoc]] + rw [hg] + simp only [Preadditive.sub_comp, Preadditive.comp_sub, + Category.id_comp, Category.comp_id, h2] + abel + +/-- Kernels exist in the envelope. -/ +theorem env_hasKernels : + HasKernels (Env f) := by + constructor + intro M N u + obtain ⟨g, hg⟩ := env_hom_regular f u + obtain ⟨K, i, e, hie, hei⟩ := + IsIdempotentComplete.idempotents_split M (𝟙 M - u ≫ g) + (env_ker_idem f u g hg) + have hik : i ≫ (𝟙 M - u ≫ g) = i := by + rw [← hei, + show i ≫ e ≫ i = (i ≫ e) ≫ i from + (Category.assoc _ _ _).symm, + hie, Category.id_comp] + have hku : (𝟙 M - u ≫ g) ≫ u = 0 := by + rw [Preadditive.sub_comp, Category.id_comp, + show (u ≫ g) ≫ u = u from by + rw [Category.assoc, hg], + sub_self] + have hiu : i ≫ u = 0 := by + rw [← hik, Category.assoc, hku, Limits.comp_zero] + exact HasLimit.mk ⟨KernelFork.ofι i hiu, + KernelFork.IsLimit.ofι i hiu + (fun {W'} g' _ => g' ≫ e) + (fun {W'} g' hg' => by + rw [Category.assoc, hei, + Preadditive.comp_sub, Category.comp_id, + show g' ≫ u ≫ g = (g' ≫ u) ≫ g from + (Category.assoc _ _ _).symm, + hg', Limits.zero_comp, sub_zero]) + (fun {W'} g' hg' m hm => by + rw [← hm, Category.assoc, hie, Category.comp_id])⟩ + +/-! ### Cokernels -/ + +/-- Cokernels exist in the envelope. -/ +theorem env_hasCokernels : + HasCokernels (Env f) := by + constructor + intro M N u + obtain ⟨g, hg⟩ := env_hom_regular f u + have hidem : (𝟙 N - g ≫ u) ≫ (𝟙 N - g ≫ u) = + 𝟙 N - g ≫ u := by + have h2 : (g ≫ u) ≫ g ≫ u = g ≫ u := by + rw [show (g ≫ u) ≫ g ≫ u = g ≫ (u ≫ g ≫ u) from by + simp only [Category.assoc]] + rw [hg] + simp only [Preadditive.sub_comp, Preadditive.comp_sub, + Category.id_comp, Category.comp_id, h2] + abel + obtain ⟨K', i', e', hie', hei'⟩ := + IsIdempotentComplete.idempotents_split N (𝟙 N - g ≫ u) + hidem + have hke : (𝟙 N - g ≫ u) ≫ e' = e' := by + rw [← hei', Category.assoc, hie', Category.comp_id] + have huk : u ≫ (𝟙 N - g ≫ u) = 0 := by + rw [Preadditive.comp_sub, Category.comp_id, + show u ≫ g ≫ u = u from hg, sub_self] + have hue : u ≫ e' = 0 := by + rw [← hke, + show u ≫ (𝟙 N - g ≫ u) ≫ e' = + (u ≫ (𝟙 N - g ≫ u)) ≫ e' from + (Category.assoc _ _ _).symm, + huk, Limits.zero_comp] + exact HasColimit.mk ⟨CokernelCofork.ofπ e' hue, + CokernelCofork.IsColimit.ofπ e' hue + (fun {W'} g' _ => i' ≫ g') + (fun {W'} g' hg' => by + rw [show e' ≫ i' ≫ g' = (e' ≫ i') ≫ g' from + (Category.assoc _ _ _).symm, hei', + Preadditive.sub_comp, Category.id_comp, + show (g ≫ u) ≫ g' = g ≫ (u ≫ g') from + Category.assoc _ _ _, + hg', Limits.comp_zero, sub_zero]) + (fun {W'} g' hg' m hm => by + rw [← hm, + show i' ≫ e' ≫ m = (i' ≫ e') ≫ m from + (Category.assoc _ _ _).symm, + hie', Category.id_comp])⟩ + +/-! ### Monomorphisms and epimorphisms split -/ + +/-- Monomorphisms split. -/ +theorem env_mono_split {M N : Env f} (m : M ⟶ N) [Mono m] : + ∃ r : N ⟶ M, m ≫ r = 𝟙 M := by + obtain ⟨g, hg⟩ := env_hom_regular f m + refine ⟨g, ?_⟩ + have h : (m ≫ g) ≫ m = 𝟙 M ≫ m := by + rw [Category.id_comp, Category.assoc, hg] + exact (cancel_mono m).mp h + +/-- Epimorphisms split. -/ +theorem env_epi_split {M N : Env f} (e : M ⟶ N) [Epi e] : + ∃ s : N ⟶ M, s ≫ e = 𝟙 N := by + obtain ⟨g, hg⟩ := env_hom_regular f e + refine ⟨g, ?_⟩ + have h : e ≫ (g ≫ e) = e ≫ 𝟙 N := by + rw [Category.comp_id, hg] + exact (cancel_epi e).mp h + +/-! ### Normality and the abelian structure -/ + +/-- Every mono is a kernel. -/ +@[instance_reducible] +noncomputable def envNormalMono {M N : Env f} (m : M ⟶ N) [Mono m] : + NormalMono m := by + have hex := env_mono_split f m + refine + { Z := N + g := 𝟙 N - hex.choose ≫ m + w := ?_ + isLimit := KernelFork.IsLimit.ofι m ?_ + (fun {W'} t _ => t ≫ hex.choose) + (fun {W'} t ht => ?_) + (fun {W'} t ht m' hm' => ?_) } + · rw [Preadditive.comp_sub, Category.comp_id, + show m ≫ hex.choose ≫ m = (m ≫ hex.choose) ≫ m from + (Category.assoc _ _ _).symm, + hex.choose_spec, Category.id_comp, sub_self] + · rw [Preadditive.comp_sub, Category.comp_id, + show m ≫ hex.choose ≫ m = (m ≫ hex.choose) ≫ m from + (Category.assoc _ _ _).symm, + hex.choose_spec, Category.id_comp, sub_self] + · have ht' : t ≫ hex.choose ≫ m = t := by + have h0 := ht + rw [Preadditive.comp_sub, Category.comp_id, + sub_eq_zero] at h0 + rw [show t ≫ hex.choose ≫ m = + t ≫ (hex.choose ≫ m) from rfl, ← h0] + rw [Category.assoc] + exact ht' + · rw [← hm'] + rw [Category.assoc, + show m ≫ hex.choose = 𝟙 M from hex.choose_spec, + Category.comp_id] + +/-- Every epi is a cokernel. -/ +@[instance_reducible] +noncomputable def envNormalEpi {M N : Env f} (e : M ⟶ N) [Epi e] : + NormalEpi e := by + have hex := env_epi_split f e + refine + { W := M + g := 𝟙 M - e ≫ hex.choose + w := ?_ + isColimit := CokernelCofork.IsColimit.ofπ e ?_ + (fun {W'} t _ => hex.choose ≫ t) + (fun {W'} t ht => ?_) + (fun {W'} t ht m' hm' => ?_) } + · rw [Preadditive.sub_comp, Category.id_comp, + Category.assoc, hex.choose_spec, Category.comp_id, + sub_self] + · rw [Preadditive.sub_comp, Category.id_comp, + Category.assoc, hex.choose_spec, Category.comp_id, + sub_self] + · have ht' : (e ≫ hex.choose) ≫ t = t := by + have h0 := ht + rw [Preadditive.sub_comp, Category.id_comp, + sub_eq_zero] at h0 + exact h0.symm + rw [show e ≫ hex.choose ≫ t = + (e ≫ hex.choose) ≫ t from + (Category.assoc _ _ _).symm] + exact ht' + · rw [← hm'] + rw [show hex.choose ≫ e ≫ m' = + (hex.choose ≫ e) ≫ m' from + (Category.assoc _ _ _).symm, + hex.choose_spec, Category.id_comp] + +/-- **The envelope is abelian**, from the factorial trace +obstruction and the connection pairing. -/ +@[reducible] +noncomputable def envAbelian : + Abelian (Env f) := by + haveI : HasFiniteBiproducts (Env f) := inferInstance + haveI := env_hasKernels f + haveI := env_hasCokernels f + exact + { normalMonoOfMono := fun m => ⟨envNormalMono f m⟩ + normalEpiOfEpi := fun e => ⟨envNormalEpi f e⟩ } + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDeligne.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDeligne.lean new file mode 100644 index 0000000000..3e53b315c9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDeligne.lean @@ -0,0 +1,117 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvInstances +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LinearCategory +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SimpleUnit + +/-! +# The Deligne hypotheses for the envelope + +Two of the five hypothesis fields of the abstract Deligne input, +read off for the envelope: finite-dimensional Hom-spaces, by the +injection chain through the three layers, and scalar unit +endomorphisms, the arity-zero Hom space being the line of the +empty class, which the normalization `f ∅ = 1` keeps nonzero. + +The other three are elsewhere: semisimplicity in +`EnvSemisimple.lean`, the tensor generator in `EnvGenerator.lean`, +and moderate growth in `EnvGrowth.lean`; `EnvDelignePackage.lean` +feeds all five to the cited statement. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Idempotents CategoryTheory.Limits +open MonoidalCategory + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-! ### Finite-dimensional Hom-spaces -/ + +/-- Envelope hom-spaces are finite-dimensional, by the injection +chain through the three layers. -/ +noncomputable instance envHomFinite (P Q : Env f) : + FiniteDimensional ℂ (P ⟶ Q) := + FiniteDimensional.of_injective + (⟨⟨fun (x : P ⟶ Q) => x.f, fun _ _ => rfl⟩, + fun _ _ => rfl⟩ : + (P ⟶ Q) →ₗ[ℂ] (P.X ⟶ Q.X)) + (fun _ _ h => Karoubi.Hom.ext h) + +/-- The envelope has finite-dimensional Hom-spaces. -/ +theorem env_finDimHom : HasFinDimHom (Env f) := + fun P Q => envHomFinite f P Q + +/-! ### Scalar unit endomorphisms -/ + +/-- The extraction of the arity-zero class from a unit +endomorphism. -/ +noncomputable def unitExtract (x : End (𝟙_ (Env f))) : + HomSpace f.val 0 := + ((x.f PUnit.unit PUnit.unit).f : + SkeinObj.mk (f := f) 0 ⟶ SkeinObj.mk 0) + +/-- The unit's endomorphisms inject into the arity-zero hom +space. -/ +theorem unitExtract_injective : + Function.Injective (unitExtract f) := by + intro x y h + apply Karoubi.hom_ext + apply Mat_.hom_ext + intro i j + rcases i with ⟨⟩ + rcases j with ⟨⟩ + exact Karoubi.hom_ext _ _ h + +/-- It sends the identity to the empty class, which the +normalization keeps nonzero — so the unit endomorphisms are the +scalars. -/ +theorem unitExtract_id : + unitExtract f (𝟙 (𝟙_ (Env f))) = + HomSpace.ofFragment f.val (strandBundle 0) := by + change ((Karoubi.Hom.f (𝟙 (𝟙_ (Env f))) PUnit.unit + PUnit.unit).f : SkeinObj.mk (f := f) 0 ⟶ SkeinObj.mk 0) = + _ + rw [show Karoubi.Hom.f (𝟙 (𝟙_ (Env f))) = + 𝟙 ((𝟙_ (Env f)).X) from rfl] + rw [Mat_.id_apply_self] + rfl + +/-- The identity of the unit is the empty class. -/ +theorem unit_id_eq_emptyClass : + HomSpace.ofFragment f.val (strandBundle 0) = + emptyClass f.val := + HomSpace.ofFragment_congr f strandBundleZeroEmpty + +/-- **Scalar unit endomorphisms.** -/ +theorem env_endOne : HasScalarUnit (Env f) := by + constructor + · -- injective + intro c d h + have h2 : c • unitExtract f (𝟙 (𝟙_ (Env f))) = + d • unitExtract f (𝟙 (𝟙_ (Env f))) := congrArg (unitExtract f) h + rw [unitExtract_id, unit_id_eq_emptyClass] at h2 + by_contra hne + have hsub : (c - d) • emptyClass f.val = 0 := by + rw [sub_smul, h2, sub_self] + rcases smul_eq_zero.mp hsub with hc | hz + · exact hne (sub_eq_zero.mp hc) + · exact emptyClass_ne_zero f hz + · -- surjective + intro x + obtain ⟨c, hc⟩ := homSpace_zero_spanned f (unitExtract f x) + refine ⟨c, ?_⟩ + apply unitExtract_injective f + change c • unitExtract f (𝟙 (𝟙_ (Env f))) = unitExtract f x + rw [unitExtract_id, unit_id_eq_emptyClass] + exact hc.symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDelignePackage.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDelignePackage.lean new file mode 100644 index 0000000000..1c8b4368a6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDelignePackage.lean @@ -0,0 +1,101 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvSemisimple +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGrowth +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatRigid +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatEmbMonoidal +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiRigid +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiEmbBraided +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidInstance +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackageRestrict +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneTheorem + +/-! +# The Deligne package for the skein category + +The payoff of the envelope construction: the envelope +satisfies all hypotheses of the abstract Deligne statement, so it +receives a fibre functor; restricting along the braided linear +embedding of the skein category yields the Deligne package that +the extraction consumes — with Deligne's theorem itself as the +only transcendental input, applied to the concretely constructed +envelope. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Idempotents + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The braided linear embedding of the skein category into its +envelope. -/ +noncomputable def skeinToEnv : SkeinObj f ⥤ Env f := + toKaroubi (SkeinObj f) ⋙ + Mat_.embedding (Karoubi (SkeinObj f)) ⋙ + toKaroubi (Mat_ (Karoubi (SkeinObj f))) + +/-- The embedding of the skein category into its envelope is +braided. -/ +noncomputable instance skeinToEnvBraided : + (skeinToEnv f).Braided := by + unfold skeinToEnv + infer_instance + +/-- It is additive. -/ +noncomputable instance skeinToEnvAdditive : + (skeinToEnv f).Additive := by + unfold skeinToEnv + infer_instance + +/-- And ℂ-linear — so restricting the envelope's fibre functor +along it gives a package on the skein category. -/ +noncomputable instance skeinToEnvLinear : + (skeinToEnv f).Linear ℂ := by + unfold skeinToEnv + infer_instance + +/-- **The strand tensor-generates in Deligne's sense.** The +envelope generates more strongly than the theorem asks — every +object is a retract of a finite biproduct of pure tensor powers of +the strand, where a subquotient of a biproduct of mixed powers +would do. -/ +theorem env_deligneGenerated : + TensorGeneratedBy (Env f) (envStrand f 1) := + tensorGeneratedBy_of_retract (Env f) (env_strandRetract f) + +/-- **The Deligne package for the envelope**: Deligne's theorem +applies to the envelope. Its growth hypothesis is stated by +composition length, which the envelope's bound on endomorphism +dimensions supplies through semisimplicity and finite-dimensional +Hom-spaces — properties of the envelope, not hypotheses of the +theorem; and its conclusion carries exactness and faithfulness, +which the package drops. -/ +theorem env_delignePackage + (hD : DeligneTheoremStatement.{1, 1}) : + Nonempty (DelignePackage (Env f)) := by + let := envAbelian f + exact (hD (Env f) (env_endOne f) + ⟨envStrand f 1, env_deligneGenerated f⟩ + (moderateLengthGrowth_of_endGrowth (Env f) (envAbelian f) + (env_deligneSemisimple f) (env_finDimHom f) + (env_deligneModerateGrowth f))).map + DeligneFibreFunctor.toPackage + +/-- **The Deligne package for the skein category**: restrict +the envelope's fibre functor along the embedding. -/ +theorem skein_delignePackage + (hD : DeligneTheoremStatement.{1, 1}) : + Nonempty (DelignePackage (SkeinObj f)) := by + obtain ⟨Q⟩ := env_delignePackage f hD + exact ⟨Q.restrict (skeinToEnv f)⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGenerator.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGenerator.lean new file mode 100644 index 0000000000..64616a8561 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGenerator.lean @@ -0,0 +1,284 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvInstances +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.TensorPow + +/-! +# The strand generator of the envelope + +The embedded strand objects of the envelope and their tensor +calculus: the `n`-strand envelope object is the `n`-th tensor +power of the single strand, up to canonical isomorphism. This is +the spine of the Deligne generator and moderate-growth fields. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Category CategoryTheory.Idempotents +open CategoryTheory.Limits MonoidalCategory + +universe v u + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-! ### Object-level equalities in Karoubi envelopes -/ + +/-- Karoubi objects with equal idempotents are equal. -/ +theorem karoubi_obj_ext {D : Type u} [Category.{v} D] {X : D} + {p q : X ⟶ X} (h : p = q) {hp : p ≫ p = p} {hq : q ≫ q = q} : + (⟨X, p, hp⟩ : Karoubi D) = ⟨X, q, hq⟩ := by + subst h; rfl + +/-! ### The embedded strands -/ + +/-- The embedded `n`-strand object of the corner category. -/ +noncomputable def strandK (n : ℕ) : Karoubi (SkeinObj f) := + (toKaroubi (SkeinObj f)).obj (SkeinObj.mk n) + +/-- The embedded `n`-strand object of the envelope. -/ +noncomputable def envStrand (n : ℕ) : Env f := + (toKaroubi (Mat_ (Karoubi (SkeinObj f)))).obj + ((Mat_.embedding (Karoubi (SkeinObj f))).obj (strandK f n)) + +/-- Strand corner objects multiply arities. -/ +theorem strandK_tensor (a b : ℕ) : + strandK f a ⊗ strandK f b = strandK f (a + b) := + karoubi_obj_ext (skein_tensor_id f (SkeinObj.mk a) (SkeinObj.mk b)) + +/-! ### The matrix embedding is tensor-compatible -/ + +section MatEmb + +variable {D : Type u} + +/-- The diagonal comparison from the tensor of embeddings to the +embedding of the tensor. -/ +noncomputable def matEmbTensorHom + [Category.{v} D] [Preadditive D] [MonoidalCategory D] + (x y : D) : + (Mat_.embedding D).obj x ⊗ (Mat_.embedding D).obj y ⟶ + (Mat_.embedding D).obj (x ⊗ y) := + fun _ _ => 𝟙 (x ⊗ y) + +/-- The diagonal comparison from the embedding of the tensor to +the tensor of embeddings. -/ +noncomputable def matEmbTensorInv + [Category.{v} D] [Preadditive D] [MonoidalCategory D] + (x y : D) : + (Mat_.embedding D).obj (x ⊗ y) ⟶ + (Mat_.embedding D).obj x ⊗ (Mat_.embedding D).obj y := + fun _ _ => 𝟙 (x ⊗ y) + +/-- The diagonal isomorphism between the tensor of embeddings and +the embedding of the tensor. -/ +noncomputable def matEmbTensorIso + [Category.{v} D] [Preadditive D] [MonoidalCategory D] + (x y : D) : + (Mat_.embedding D).obj x ⊗ (Mat_.embedding D).obj y ≅ + (Mat_.embedding D).obj (x ⊗ y) where + hom := matEmbTensorHom x y + inv := matEmbTensorInv x y + hom_inv_id := by + apply Mat_.hom_ext + intro i j + have : Subsingleton (((Mat_.embedding D).obj x ⊗ + (Mat_.embedding D).obj y).ι) := + inferInstanceAs (Subsingleton (PUnit × PUnit)) + obtain rfl : i = j := Subsingleton.elim i j + rw [Mat_.comp_apply, Mat_.id_apply_self] + change ∑ _j : PUnit, 𝟙 (x ⊗ y) ≫ 𝟙 (x ⊗ y) = 𝟙 (x ⊗ y) + simp + inv_hom_id := by + apply Mat_.hom_ext + intro i j + have : Subsingleton + (((Mat_.embedding D).obj (x ⊗ y)).ι) := + inferInstanceAs (Subsingleton PUnit) + obtain rfl : i = j := Subsingleton.elim i j + rw [Mat_.comp_apply, Mat_.id_apply_self] + change ∑ _j : PUnit × PUnit, 𝟙 (x ⊗ y) ≫ 𝟙 (x ⊗ y) = + 𝟙 (x ⊗ y) + simp + +end MatEmb + +/-! ### The Karoubi embedding is tensor-compatible -/ + +/-- The embedding into the Karoubi envelope carries tensor to +tensor, on the nose. -/ +theorem toKaroubi_tensor {D : Type u} [Category.{v} D] + [MonoidalCategory D] (A B : D) : + (toKaroubi D).obj A ⊗ (toKaroubi D).obj B = + (toKaroubi D).obj (A ⊗ B) := + karoubi_obj_ext (by simp) + +/-! ### The strand tensor calculus in the envelope -/ + +/-- The strand objects of the envelope multiply arities. -/ +noncomputable def envStrandTensorIso (a b : ℕ) : + envStrand f a ⊗ envStrand f b ≅ envStrand f (a + b) := + eqToIso (toKaroubi_tensor _ _) ≪≫ + (toKaroubi (Mat_ (Karoubi (SkeinObj f)))).mapIso + (matEmbTensorIso (strandK f a) (strandK f b) ≪≫ + eqToIso (congrArg (Mat_.embedding + (Karoubi (SkeinObj f))).obj (strandK_tensor f a b))) + +/-- The zero strand of the envelope is the unit. -/ +theorem envStrand_zero : envStrand f 0 = 𝟙_ (Env f) := rfl + +/-- **The strand power isomorphism**: the `n`-th tensor power of +the single strand is the `n`-strand object. -/ +noncomputable def envStrandPowIso : + (n : ℕ) → tensorPow (Env f) (envStrand f 1) n ≅ envStrand f n + | 0 => eqToIso (envStrand_zero f).symm + | n + 1 => + tensorIso (envStrandPowIso n) (Iso.refl (envStrand f 1)) ≪≫ + envStrandTensorIso f n 1 + +/-! ### Retracts through the layers -/ + +/-- The ambient section: an envelope object into the full matrix +object it corners. -/ +noncomputable def envAmbientSec (E : Env f) : + E ⟶ (toKaroubi (Mat_ (Karoubi (SkeinObj f)))).obj E.X := + ⟨E.p, by + change E.p ≫ E.p ≫ 𝟙 E.X = E.p + rw [comp_id]; exact E.idem⟩ + +/-- The ambient retraction. -/ +noncomputable def envAmbientRet (E : Env f) : + (toKaroubi (Mat_ (Karoubi (SkeinObj f)))).obj E.X ⟶ E := + ⟨E.p, by + change 𝟙 E.X ≫ E.p ≫ E.p = E.p + rw [id_comp]; exact E.idem⟩ + +/-- The envelope object is a retract of its ambient object. -/ +theorem envAmbientSec_ret (E : Env f) : + envAmbientSec f E ≫ envAmbientRet f E = 𝟙 E := by + apply Karoubi.hom_ext + change E.p ≫ E.p = E.p + exact E.idem + +/-- The corner section: a skein corner into its full strand. -/ +noncomputable def cornerSecK (x : Karoubi (SkeinObj f)) : + x ⟶ strandK f x.X.arity := + ⟨x.p, by + change x.p ≫ x.p ≫ 𝟙 (SkeinObj.mk x.X.arity) = x.p + rw [comp_id]; exact x.idem⟩ + +/-- The corner retraction. -/ +noncomputable def cornerRetK (x : Karoubi (SkeinObj f)) : + strandK f x.X.arity ⟶ x := + ⟨x.p, by + change 𝟙 (SkeinObj.mk x.X.arity) ≫ x.p ≫ x.p = x.p + rw [id_comp]; exact x.idem⟩ + +/-- A Karoubi object is a retract of its corner in the +envelope. -/ +theorem cornerSecK_ret (x : Karoubi (SkeinObj f)) : + cornerSecK f x ≫ cornerRetK f x = 𝟙 x := by + apply Karoubi.hom_ext + change x.p ≫ x.p = x.p + exact x.idem + +/-- The embedded corner object of the envelope. -/ +noncomputable def envEmb (x : Karoubi (SkeinObj f)) : Env f := + (toKaroubi (Mat_ (Karoubi (SkeinObj f)))).obj + ((Mat_.embedding (Karoubi (SkeinObj f))).obj x) + +/-- The embedded corner section into its strand object. -/ +noncomputable def envEmbSec (x : Karoubi (SkeinObj f)) : + envEmb f x ⟶ envStrand f x.X.arity := + (toKaroubi (Mat_ (Karoubi (SkeinObj f)))).map + ((Mat_.embedding (Karoubi (SkeinObj f))).map (cornerSecK f x)) + +/-- The embedded corner retraction. -/ +noncomputable def envEmbRet (x : Karoubi (SkeinObj f)) : + envStrand f x.X.arity ⟶ envEmb f x := + (toKaroubi (Mat_ (Karoubi (SkeinObj f)))).map + ((Mat_.embedding (Karoubi (SkeinObj f))).map (cornerRetK f x)) + +/-- And the embedding of a Karoubi object is a retract of it — +the three sections that make the strand generator work. -/ +theorem envEmbSec_ret (x : Karoubi (SkeinObj f)) : + envEmbSec f x ≫ envEmbRet f x = 𝟙 (envEmb f x) := by + have h := congrArg (fun t => + (toKaroubi (Mat_ (Karoubi (SkeinObj f)))).map + ((Mat_.embedding (Karoubi (SkeinObj f))).map t)) + (cornerSecK_ret f x) + simp only [Functor.map_comp] at h + refine h.trans ?_ + rw [CategoryTheory.Functor.map_id, CategoryTheory.Functor.map_id] + rfl + +/-! ### The biproduct decomposition of a matrix object -/ + +/-- A matrix object of the envelope is the biproduct of its +embedded entries. -/ +noncomputable def envMatDecomp (A : Mat_ (Karoubi (SkeinObj f))) : + (toKaroubi (Mat_ (Karoubi (SkeinObj f)))).obj A ≅ + ⨁ fun i : A.ι => envEmb f (A.X i) := + (toKaroubi (Mat_ (Karoubi (SkeinObj f)))).mapIso + A.isoBiproductEmbedding ≪≫ + Functor.mapBiproduct _ _ + +/-! ### The generator field -/ + +-- The retract is built from a finite biproduct +-- indexed by the object's own index type, so the biproduct +-- structure is unfolded. +/-- **The strand generates the envelope**: every object is a +retract of a finite biproduct of tensor powers of the single +strand. -/ +theorem env_strandRetract : + RetractGeneratedBy (Env f) (envStrand f 1) := by + classical + intro E + set A := E.X with hA + let q : Fin (Fintype.card A.ι) ≃ A.ι := + (Fintype.equivFin A.ι).symm + let ns : Fin (Fintype.card A.ι) → ℕ := + fun i => ((A.X (q i)).X).arity + let L : (⨁ fun i : A.ι => envEmb f (A.X i)) ⟶ + ⨁ fun i => tensorPow (Env f) (envStrand f 1) (ns i) := + biproduct.lift fun i => + biproduct.π (fun i : A.ι => envEmb f (A.X i)) (q i) ≫ + envEmbSec f (A.X (q i)) ≫ (envStrandPowIso f (ns i)).inv + let D : (⨁ fun i => tensorPow (Env f) (envStrand f 1) (ns i)) ⟶ + ⨁ fun i : A.ι => envEmb f (A.X i) := + biproduct.desc fun i => (envStrandPowIso f (ns i)).hom ≫ + envEmbRet f (A.X (q i)) ≫ + biproduct.ι (fun i : A.ι => envEmb f (A.X i)) (q i) + have hLD : L ≫ D = 𝟙 _ := by + rw [biproduct.lift_desc] + rw [Finset.sum_congr rfl fun i _ => show + (biproduct.π (fun i : A.ι => envEmb f (A.X i)) (q i) ≫ + envEmbSec f (A.X (q i)) ≫ + (envStrandPowIso f (ns i)).inv) ≫ + ((envStrandPowIso f (ns i)).hom ≫ + envEmbRet f (A.X (q i)) ≫ + biproduct.ι (fun i : A.ι => envEmb f (A.X i)) (q i)) = + biproduct.π (fun i : A.ι => envEmb f (A.X i)) (q i) ≫ + biproduct.ι (fun i : A.ι => envEmb f (A.X i)) (q i) from by + simp only [assoc, Iso.inv_hom_id_assoc] + rw [reassoc_of% (envEmbSec_ret f (A.X (q i)))]] + rw [Equiv.sum_comp q (fun j => + biproduct.π (fun i : A.ι => envEmb f (A.X i)) j ≫ + biproduct.ι (fun i : A.ι => envEmb f (A.X i)) j)] + exact biproduct.total + refine ⟨Fintype.card A.ι, ns, + envAmbientSec f E ≫ (envMatDecomp f A).hom ≫ L, + D ≫ (envMatDecomp f A).inv ≫ envAmbientRet f E, ?_⟩ + simp only [assoc] + rw [reassoc_of% hLD, Iso.hom_inv_id_assoc] + exact envAmbientSec_ret f E + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGrowth.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGrowth.lean new file mode 100644 index 0000000000..0798074370 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGrowth.lean @@ -0,0 +1,181 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGenerator +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Growth + +/-! +# Moderate growth of the envelope + +The Deligne moderate-growth hypothesis: the endomorphism algebras +of tensor powers grow at most exponentially. The dimension of an +envelope Hom-space is bounded by the underlying matrix Hom-space, +which is a finite product of skein Hom-spaces of dimension at +most `(R+1)^(2m)`; tensor powers multiply index cardinalities and +add arities, so the total bound is exponential in the power. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Category CategoryTheory.Idempotents +open CategoryTheory.Limits MonoidalCategory + +universe v u + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-! ### The envelope Hom bound -/ + +/-- Envelope Hom-spaces are no larger than the underlying matrix +Hom-spaces. -/ +theorem env_hom_finrank_le (P Q : Env f) : + Module.finrank ℂ (P ⟶ Q) ≤ Module.finrank ℂ (P.X ⟶ Q.X) := + LinearMap.finrank_le_finrank_of_injective + (f := ⟨⟨fun (x : P ⟶ Q) => x.f, fun _ _ => rfl⟩, + fun _ _ => rfl⟩) + (fun _ _ h => Karoubi.Hom.ext h) + +/-! ### The matrix Hom bound -/ + +/-- The entrywise reading of a matrix morphism into skein +Hom-spaces. -/ +noncomputable def matHomEntries + (M N : Mat_ (Karoubi (SkeinObj f))) : + (M ⟶ N) →ₗ[ℂ] ((p : M.ι × N.ι) → + HomSpace f.val + ((M.X p.1).X.arity + (N.X p.2).X.arity)) where + toFun φ := fun p => (φ p.1 p.2).f + map_add' _ _ := rfl + map_smul' _ _ := rfl + +/-- A matrix of morphisms is determined by its entries, so the +hom-space dimension is bounded by their total. -/ +theorem matHomEntries_injective + (M N : Mat_ (Karoubi (SkeinObj f))) : + Function.Injective (matHomEntries f M N) := by + intro φ ψ h + apply Mat_.hom_ext + intro i j + apply Karoubi.hom_ext + exact congrFun h (i, j) + +/-- The dimension of a matrix Hom-space, bounded by index counts +and a uniform arity bound. -/ +theorem mat_hom_finrank_le (M N : Mat_ (Karoubi (SkeinObj f))) + (m : ℕ) (hM : ∀ i, (M.X i).X.arity ≤ m) + (hN : ∀ j, (N.X j).X.arity ≤ m) : + Module.finrank ℂ (M ⟶ N) ≤ + Fintype.card M.ι * Fintype.card N.ι * (R + 1) ^ (2 * m) := by + have : ∀ p : M.ι × N.ι, Module.Finite ℂ + (HomSpace f.val + ((M.X p.1).X.arity + (N.X p.2).X.arity)) := + fun p => inferInstance + calc Module.finrank ℂ (M ⟶ N) + ≤ Module.finrank ℂ ((p : M.ι × N.ι) → + HomSpace f.val + ((M.X p.1).X.arity + (N.X p.2).X.arity)) := + LinearMap.finrank_le_finrank_of_injective + (f := matHomEntries f M N) + (matHomEntries_injective f M N) + _ = ∑ p : M.ι × N.ι, Module.finrank ℂ + (HomSpace f.val + ((M.X p.1).X.arity + (N.X p.2).X.arity)) := + Module.finrank_pi_fintype ℂ + _ ≤ ∑ _p : M.ι × N.ι, (R + 1) ^ (2 * m) := by + refine Finset.sum_le_sum fun p _ => ?_ + refine le_trans (homSpace_finrank_le f _) ?_ + refine le_trans + (Nat.pow_le_pow_left (Nat.le_succ R) _) ?_ + refine Nat.pow_le_pow_right (Nat.succ_le_succ (Nat.zero_le R)) ?_ + have h1 := hM p.1 + have h2 := hN p.2 + omega + _ = Fintype.card M.ι * Fintype.card N.ι * + (R + 1) ^ (2 * m) := by + rw [Finset.sum_const, Finset.card_univ, smul_eq_mul, + Fintype.card_prod] + +/-! ### Tensor powers of matrix objects -/ + +/-- The underlying matrix object of an envelope tensor power. -/ +theorem env_pow_X (Y : Env f) : ∀ N : ℕ, + (tensorPow (Env f) Y N).X = + tensorPow (Mat_ (Karoubi (SkeinObj f))) Y.X N + | 0 => rfl + | N + 1 => congrArg (· ⊗ Y.X) (env_pow_X Y N) + +/-- The index cardinality of a matrix tensor power. -/ +theorem mat_pow_card (A : Mat_ (Karoubi (SkeinObj f))) : + ∀ N : ℕ, + Fintype.card + ((tensorPow (Mat_ (Karoubi (SkeinObj f))) A N).ι) = + Fintype.card A.ι ^ N + | 0 => by + rw [pow_zero] + exact (Fintype.card_congr + (Equiv.refl PUnit)).trans Fintype.card_punit + | N + 1 => by + rw [pow_succ, ← mat_pow_card A N] + exact (Fintype.card_congr (Equiv.refl _)).trans + (Fintype.card_prod _ _) + +/-- The arity bound of a matrix tensor power. -/ +theorem mat_pow_arity (A : Mat_ (Karoubi (SkeinObj f))) (m : ℕ) + (hA : ∀ i, ((A.X i).X).arity ≤ m) : ∀ N : ℕ, + ∀ p : (tensorPow (Mat_ (Karoubi (SkeinObj f))) A N).ι, + (((tensorPow (Mat_ (Karoubi (SkeinObj f))) A N).X p).X).arity + ≤ N * m + | 0, p => Nat.le_of_eq (by rw [Nat.zero_mul]; rfl) + | N + 1, p => by + change (((tensorPow (Mat_ (Karoubi (SkeinObj f))) A N).X + p.1).X).arity + ((A.X p.2).X).arity ≤ (N + 1) * m + have h1 := mat_pow_arity A m hA N p.1 + have h2 := hA p.2 + nlinarith + +/-! ### The moderate-growth field -/ + +/-- **Moderate growth of the envelope**: endomorphism algebras of +tensor powers grow at most exponentially. -/ +theorem env_deligneModerateGrowth : + ModerateEndGrowth (Env f) := by + intro Y + classical + set A := Y.X with hA + set mA : ℕ := Finset.univ.sup fun i => ((A.X i).X).arity + with hmA + refine ⟨1, Fintype.card A.ι ^ 2 * (R + 1) ^ (2 * mA), + fun N => ?_⟩ + rw [one_mul] + have harity : ∀ i, ((A.X i).X).arity ≤ mA := fun i => by + rw [hmA] + exact Finset.le_sup (f := fun i => ((A.X i).X).arity) + (Finset.mem_univ i) + calc Module.finrank ℂ + (tensorPow (Env f) Y N ⟶ tensorPow (Env f) Y N) + ≤ Module.finrank ℂ + ((tensorPow (Env f) Y N).X ⟶ + (tensorPow (Env f) Y N).X) := + env_hom_finrank_le f _ _ + _ ≤ Fintype.card + ((tensorPow (Mat_ (Karoubi (SkeinObj f))) A N).ι) * + Fintype.card + ((tensorPow (Mat_ (Karoubi (SkeinObj f))) A N).ι) * + (R + 1) ^ (2 * (N * mA)) := by + rw [env_pow_X f Y N] + exact mat_hom_finrank_le f _ _ (N * mA) + (mat_pow_arity f A mA harity N) + (mat_pow_arity f A mA harity N) + _ = (Fintype.card A.ι ^ 2 * (R + 1) ^ (2 * mA)) ^ N := by + rw [mat_pow_card f A N, mul_pow, ← pow_mul, ← pow_mul, + ← pow_add] + ring_nf + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvInstances.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvInstances.lean new file mode 100644 index 0000000000..1099db8d2b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvInstances.lean @@ -0,0 +1,282 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvAbelian +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiMonoidal +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatMonoidal + +/-! +# Monoidal preadditivity and linearity through the tower + +The skein tensor is a bundled bilinear map, so the skein category +is monoidal-preadditive and monoidal-linear; both properties lift +through the Karoubi and matrix layers entrywise, giving the full +instance chain for the envelope. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Idempotents +open MonoidalCategory + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-! ### The skein base -/ + +/-- The skein tensor is additive in each argument. -/ +instance skeinMonoidalPreadditive : + MonoidalPreadditive (SkeinObj f) where + whiskerLeft_zero := by + intro X Y Z + change (HomSpace.tensor f X.arity X.arity Y.arity Z.arity + (HomSpace.ofFragment f.val (strandBundle X.arity))) 0 = 0 + rw [map_zero] + zero_whiskerRight := by + intro X Y Z + change (HomSpace.tensor f Y.arity Z.arity X.arity X.arity) 0 + (HomSpace.ofFragment f.val (strandBundle X.arity)) = 0 + rw [map_zero] + rfl + whiskerLeft_add := by + intro X Y Z g g' + change (HomSpace.tensor f X.arity X.arity Y.arity Z.arity + (HomSpace.ofFragment f.val (strandBundle X.arity))) + (g + g') = _ + rw [map_add] + rfl + add_whiskerRight := by + intro X Y Z g g' + change (HomSpace.tensor f Y.arity Z.arity X.arity X.arity) + (g + g') + (HomSpace.ofFragment f.val (strandBundle X.arity)) = _ + rw [map_add] + rfl + +/-- And ℂ-linear in each argument, being a bundled bilinear map. -/ +instance skeinMonoidalLinear : + MonoidalLinear ℂ (SkeinObj f) where + whiskerLeft_smul := by + intro X Y Z c g + change (HomSpace.tensor f X.arity X.arity Y.arity Z.arity + (HomSpace.ofFragment f.val (strandBundle X.arity))) + (c • g) = _ + rw [map_smul] + rfl + smul_whiskerRight := by + intro c X Y g Z + change (HomSpace.tensor f X.arity Y.arity Z.arity Z.arity) + (c • g) + (HomSpace.ofFragment f.val (strandBundle Z.arity)) = _ + rw [map_smul] + rfl + +/-! ### The Karoubi lift (general) -/ + +section KaroubiLift + +variable (C : Type*) + +/-- Monoidal preadditivity lifts to the Karoubi envelope, where +tensoring acts on underlying morphisms. -/ +instance karoubiMonoidalPreadditive + [Category C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] : + MonoidalPreadditive (Karoubi C) where + whiskerLeft_zero := by + intro X Y Z + apply Karoubi.hom_ext + change X.p ⊗ₘ (0 : Y.X ⟶ Z.X) = 0 + rw [MonoidalPreadditive.tensor_zero] + zero_whiskerRight := by + intro X Y Z + apply Karoubi.hom_ext + change (0 : Y.X ⟶ Z.X) ⊗ₘ X.p = 0 + rw [MonoidalPreadditive.zero_tensor] + whiskerLeft_add := by + intro X Y Z g g' + apply Karoubi.hom_ext + change X.p ⊗ₘ (g.f + g'.f) = X.p ⊗ₘ g.f + X.p ⊗ₘ g'.f + rw [MonoidalPreadditive.tensor_add] + add_whiskerRight := by + intro X Y Z g g' + apply Karoubi.hom_ext + change (g.f + g'.f) ⊗ₘ X.p = g.f ⊗ₘ X.p + g'.f ⊗ₘ X.p + rw [MonoidalPreadditive.add_tensor] + +/-- And so does monoidal linearity. -/ +instance karoubiMonoidalLinear [Category C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] [CategoryTheory.Linear ℂ C] [MonoidalLinear ℂ C] : + MonoidalLinear ℂ (Karoubi C) where + whiskerLeft_smul := by + intro X Y Z c g + apply Karoubi.hom_ext + change X.p ⊗ₘ (c • g.f) = c • (X.p ⊗ₘ g.f) + rw [tensorHom_def, tensorHom_def, + MonoidalLinear.whiskerLeft_smul, + CategoryTheory.Linear.comp_smul] + smul_whiskerRight := by + intro c X Y g Z + apply Karoubi.hom_ext + change (c • g.f) ⊗ₘ Z.p = c • (g.f ⊗ₘ Z.p) + rw [tensorHom_def, tensorHom_def, + MonoidalLinear.smul_whiskerRight, + CategoryTheory.Linear.smul_comp] + +end KaroubiLift + +/-! ### The matrix lift -/ + +section MatLift + +variable (C : Type*) + +/-- Monoidal preadditivity lifts to the matrix layer entrywise. -/ +instance matMonoidalPreadditive + [Category C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] : + MonoidalPreadditive (Mat_ C) where + whiskerLeft_zero := by + intro X Y Z + apply Mat_.hom_ext + intro ⟨i₁, i₂⟩ ⟨j₁, j₂⟩ + change (𝟙 X : Mat_.Hom X X) i₁ j₁ ⊗ₘ + (0 : Y ⟶ Z) i₂ j₂ = _ + rw [show (0 : Y ⟶ Z) i₂ j₂ = 0 from rfl, + MonoidalPreadditive.tensor_zero] + rfl + zero_whiskerRight := by + intro X Y Z + apply Mat_.hom_ext + intro ⟨i₁, i₂⟩ ⟨j₁, j₂⟩ + change (0 : Y ⟶ Z) i₁ j₁ ⊗ₘ + (𝟙 X : Mat_.Hom X X) i₂ j₂ = _ + rw [show (0 : Y ⟶ Z) i₁ j₁ = 0 from rfl, + MonoidalPreadditive.zero_tensor] + rfl + whiskerLeft_add := by + intro X Y Z g g' + apply Mat_.hom_ext + intro i j + change (𝟙 X : Mat_.Hom X X) i.1 j.1 ⊗ₘ + (g + g' : Mat_.Hom Y Z) i.2 j.2 = _ + rw [show (g + g' : Mat_.Hom Y Z) i.2 j.2 = + g i.2 j.2 + g' i.2 j.2 from rfl, + MonoidalPreadditive.tensor_add] + rfl + add_whiskerRight := by + intro X Y Z g g' + apply Mat_.hom_ext + intro ⟨i₁, i₂⟩ ⟨j₁, j₂⟩ + change (g + g' : Mat_.Hom Y Z) i₁ j₁ ⊗ₘ + (𝟙 X : Mat_.Hom X X) i₂ j₂ = _ + rw [show (g + g' : Mat_.Hom Y Z) i₁ j₁ = + g i₁ j₁ + g' i₁ j₁ from rfl, + MonoidalPreadditive.add_tensor] + rfl + +/-- The entrywise linear structure on matrix Homs (general +base). -/ +noncomputable instance matHomSMul' + [Category C] [Preadditive C] [CategoryTheory.Linear ℂ C] + (M N : Mat_ C) : + SMul ℂ (M ⟶ N) where + smul c φ := fun i j => c • φ i j + +/-- The matrix layer's hom-sets are ℂ-modules, entrywise. -/ +noncomputable instance matHomModule' + [Category C] [Preadditive C] [CategoryTheory.Linear ℂ C] + (M N : Mat_ C) : + Module ℂ (M ⟶ N) where + one_smul φ := by funext i j; exact one_smul ℂ (φ i j) + mul_smul c d φ := by funext i j; exact mul_smul c d (φ i j) + smul_zero c := by funext i j; exact smul_zero c + smul_add c φ ψ := by + funext i j + change c • (φ i j + ψ i j) = c • φ i j + c • ψ i j + exact smul_add c _ _ + add_smul c d φ := by + funext i j + change (c + d) • φ i j = c • φ i j + d • φ i j + exact add_smul c d _ + zero_smul φ := by funext i j; exact zero_smul ℂ (φ i j) + +/-- Hence the matrix layer is ℂ-linear. -/ +noncomputable instance matLinear' + [Category C] [Preadditive C] [CategoryTheory.Linear ℂ C] : + CategoryTheory.Linear ℂ (Mat_ C) where + smul_comp M N K c φ ψ := by + funext i k + change ∑ j, (c • φ i j) ≫ ψ j k = c • ∑ j, φ i j ≫ ψ j k + rw [Finset.smul_sum] + refine Finset.sum_congr rfl fun j _ => ?_ + rw [CategoryTheory.Linear.smul_comp] + comp_smul M N K φ c ψ := by + funext i k + change ∑ j, φ i j ≫ (c • ψ j k) = c • ∑ j, φ i j ≫ ψ j k + rw [Finset.smul_sum] + refine Finset.sum_congr rfl fun j _ => ?_ + rw [CategoryTheory.Linear.comp_smul] + +private theorem base_tensor_smul + [Category C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] [CategoryTheory.Linear ℂ C] [MonoidalLinear ℂ C] + {W X Y Z : C} + (a : W ⟶ X) (c : ℂ) (b : Y ⟶ Z) : + a ⊗ₘ (c • b) = c • (a ⊗ₘ b) := by + rw [tensorHom_def, tensorHom_def, + MonoidalLinear.whiskerLeft_smul, + CategoryTheory.Linear.comp_smul] + +private theorem base_smul_tensor + [Category C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] [CategoryTheory.Linear ℂ C] [MonoidalLinear ℂ C] + {W X Y Z : C} + (c : ℂ) (a : W ⟶ X) (b : Y ⟶ Z) : + (c • a) ⊗ₘ b = c • (a ⊗ₘ b) := by + rw [tensorHom_def, tensorHom_def, + MonoidalLinear.smul_whiskerRight, + CategoryTheory.Linear.smul_comp] + +/-- And monoidal-linear, completing the instance chain for the +envelope. -/ +instance matMonoidalLinear [Category C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] [CategoryTheory.Linear ℂ C] [MonoidalLinear ℂ C] : + MonoidalLinear ℂ (Mat_ C) where + whiskerLeft_smul := by + intro X Y Z c g + apply Mat_.hom_ext + intro i j + change (𝟙 X : Mat_.Hom X X) i.1 j.1 ⊗ₘ + (c • g i.2 j.2) = + c • ((𝟙 X : Mat_.Hom X X) i.1 j.1 ⊗ₘ g i.2 j.2) + exact base_tensor_smul C _ c _ + smul_whiskerRight := by + intro c X Y g Z + apply Mat_.hom_ext + intro i j + change (c • g i.1 j.1) ⊗ₘ + (𝟙 Z : Mat_.Hom Z Z) i.2 j.2 = + c • (g i.1 j.1 ⊗ₘ (𝟙 Z : Mat_.Hom Z Z) i.2 j.2) + exact base_smul_tensor C c _ _ + +end MatLift + +/-! ### The envelope chain -/ + +noncomputable example : MonoidalCategory (Env f) := + inferInstance + +noncomputable example : MonoidalPreadditive (Env f) := + inferInstance + +noncomputable example : MonoidalLinear ℂ (Env f) := + inferInstance + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvSemisimple.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvSemisimple.lean new file mode 100644 index 0000000000..256bb4af29 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvSemisimple.lean @@ -0,0 +1,242 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDeligne + +/-! +# Semisimplicity of the envelope + +The Deligne semisimplicity hypothesis for the envelope: every +object is a finite biproduct of simple objects. The endomorphism +algebra is finite-dimensional and semisimple by the factorial trace +obstruction, so the identity splits into a complete orthogonal +family of atomic idempotents; each cuts out a corner object with +scalar endomorphisms, which is simple because monomorphisms split +in the envelope, and the object is the biproduct of its corners. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Category CategoryTheory.Idempotents +open CategoryTheory.Limits + +universe v u + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-! ### Corner cuts of Karoubi objects (general) -/ + +section GenericCut + +variable {D : Type u} + +/-- The corner object cut out of a Karoubi object by an +idempotent endomorphism. -/ +noncomputable def karoubiCorner + [Category.{v} D] (X : Karoubi D) {e : End X} (he : IsIdempotentElem e) : + Karoubi D := + ⟨X.X, e.f, congrArg Karoubi.Hom.f he⟩ + +/-- The corner inclusion. -/ +noncomputable def cornerIncl + [Category.{v} D] (X : Karoubi D) {e : End X} (he : IsIdempotentElem e) : + karoubiCorner X he ⟶ X := + ⟨e.f, by + change e.f ≫ e.f ≫ X.p = e.f + rw [Karoubi.comp_p] + exact congrArg Karoubi.Hom.f he⟩ + +/-- The corner projection. -/ +noncomputable def cornerProj + [Category.{v} D] (X : Karoubi D) {e : End X} (he : IsIdempotentElem e) : + X ⟶ karoubiCorner X he := + ⟨e.f, by + change X.p ≫ e.f ≫ e.f = e.f + rw [show (e.f ≫ e.f : X.X ⟶ X.X) = e.f from + congrArg Karoubi.Hom.f he, Karoubi.p_comp]⟩ + +/-- The corner is a retract: including then projecting is the +identity on it. -/ +theorem cornerIncl_proj + [Category.{v} D] (X : Karoubi D) {e : End X} (he : IsIdempotentElem e) : + cornerIncl X he ≫ cornerProj X he = 𝟙 (karoubiCorner X he) := by + apply Karoubi.hom_ext + change e.f ≫ e.f = e.f + exact congrArg Karoubi.Hom.f he + +/-- Projecting then including is the idempotent. -/ +theorem cornerProj_incl + [Category.{v} D] (X : Karoubi D) {e : End X} (he : IsIdempotentElem e) : + cornerProj X he ≫ cornerIncl X he = e := by + apply Karoubi.hom_ext + exact congrArg Karoubi.Hom.f he + +/-- The inclusion is absorbed by the idempotent. -/ +theorem cornerIncl_absorb + [Category.{v} D] (X : Karoubi D) {e : End X} (he : IsIdempotentElem e) : + cornerIncl X he ≫ e = cornerIncl X he := by + apply Karoubi.hom_ext + change e.f ≫ e.f = e.f + exact congrArg Karoubi.Hom.f he + +/-- And so is the projection. -/ +theorem cornerProj_absorb + [Category.{v} D] (X : Karoubi D) {e : End X} (he : IsIdempotentElem e) : + e ≫ cornerProj X he = cornerProj X he := by + apply Karoubi.hom_ext + change e.f ≫ e.f = e.f + exact congrArg Karoubi.Hom.f he + +/-- Cross-composites of distinct orthogonal corners vanish. -/ +theorem cornerIncl_proj_orthogonal + [Category.{v} D] [Preadditive D] (X : Karoubi D) {e : End X} + (he : IsIdempotentElem e) + {e' : End X} (he' : IsIdempotentElem e') + (horth : e' * e = 0) : + cornerIncl X he ≫ cornerProj X he' = 0 := by + apply Karoubi.hom_ext + change e.f ≫ e'.f = (0 : X.X ⟶ X.X) + exact congrArg Karoubi.Hom.f horth + +end GenericCut + +/-! ### Scalar corners are simple in the envelope -/ + +/-- An envelope object with scalar endomorphism algebra and +nonzero identity is simple: monomorphisms split, and a split +idempotent scalar is `0` or `1`. -/ +theorem env_simple_of_scalar_end (E : Env f) (hne : 𝟙 E ≠ 0) + (hsc : ∀ x : End E, ∃ c : ℂ, x = c • 𝟙 E) : + Simple E := by + constructor + intro Y g hMono + constructor + · intro hIso hg + obtain ⟨r, _, hr2⟩ := hIso.out + rw [hg, comp_zero] at hr2 + exact hne hr2.symm + · intro hg + obtain ⟨r, hr⟩ := env_mono_split f g + obtain ⟨c, hc⟩ := hsc (r ≫ g) + have hidem : (r ≫ g) ≫ (r ≫ g) = r ≫ g := by + rw [assoc, ← assoc g r g, hr, id_comp] + rw [hc] at hidem + have hcc : (c * c - c) • 𝟙 E = 0 := by + rw [sub_smul, mul_smul] + rw [show (c • c • 𝟙 E : End E) = + (c • 𝟙 E) ≫ (c • 𝟙 E) from by + rw [CategoryTheory.Linear.smul_comp, + CategoryTheory.Linear.comp_smul, comp_id], + hidem, sub_self] + have hc2 : c * c = c := by + rcases smul_eq_zero.mp hcc with h | h + · exact sub_eq_zero.mp h + · exact absurd h hne + have h3 : c * (c - 1) = 0 := by + rw [mul_sub, mul_one, hc2, sub_self] + rcases mul_eq_zero.mp h3 with h0 | h1 + · exfalso + rw [h0, zero_smul] at hc + have : g = 0 := by + rw [show g = (g ≫ r) ≫ g from by rw [hr, id_comp], + assoc, hc, comp_zero] + exact hg this + · rw [sub_eq_zero.mp h1, one_smul] at hc + exact ⟨⟨r, hr, hc⟩⟩ + +/-! ### The atomic corners of an envelope object -/ + +/-- The corner cut by an atomic idempotent has scalar +endomorphisms. -/ +theorem env_corner_scalar (E : Env f) {e : End E} + (he : IsAtomicIdempotent e) + (x : End (karoubiCorner E he.idem)) : + ∃ c : ℂ, x = c • 𝟙 (karoubiCorner E he.idem) := by + set y : End E := + cornerProj E he.idem ≫ x ≫ cornerIncl E he.idem with hy + obtain ⟨c, hc⟩ := he.corner_scalar y + have habs : e ≫ y ≫ e = y := by + rw [hy, ← assoc, ← assoc, cornerProj_absorb, assoc, assoc, + cornerIncl_absorb] + have hyc : y = c • e := by + rw [← habs] + calc e ≫ y ≫ e = e * y * e := rfl + _ = c • e := hc + refine ⟨c, ?_⟩ + have hx : x = cornerIncl E he.idem ≫ y ≫ cornerProj E he.idem := by + rw [hy, ← assoc, ← assoc, cornerIncl_proj, id_comp, assoc, + cornerIncl_proj, comp_id] + rw [hx, hyc] + have h1 : (c • e) ≫ cornerProj E he.idem = + c • (e ≫ cornerProj E he.idem) := + CategoryTheory.Linear.smul_comp (R := ℂ) _ _ _ c e _ + have h2 : cornerIncl E he.idem ≫ (c • (e ≫ cornerProj E he.idem)) = + c • (cornerIncl E he.idem ≫ e ≫ cornerProj E he.idem) := + CategoryTheory.Linear.comp_smul (R := ℂ) _ _ _ _ c _ + rw [h1, h2, cornerProj_absorb, cornerIncl_proj] + +/-- The corner cut by an atomic idempotent has nonzero +identity. -/ +theorem env_corner_id_ne_zero (E : Env f) {e : End E} + (he : IsAtomicIdempotent e) : + 𝟙 (karoubiCorner E he.idem) ≠ 0 := by + intro h + apply he.ne_zero + apply Karoubi.hom_ext + have := congrArg Karoubi.Hom.f h + exact this + +/-! ### The biproduct decomposition -/ + +/-- **Semisimplicity of the envelope**: every object is a finite +biproduct of simple objects. -/ +theorem env_deligneSemisimple : + IsSemisimple (Env f) := by + classical + intro E + have : FiniteDimensional ℂ (End E) := envHomFinite f E E + have := envEnd_isSemisimpleRing f E + obtain ⟨ι, hfin, e, hco, hatom⟩ := + exists_completeOrthogonal_atomic (A := End E) + -- The corners, reindexed over `Fin n`. + let q := (Fintype.equivFin ι).symm + refine ⟨Fintype.card ι, + fun i => karoubiCorner E (hatom (q i)).idem, fun i => ?_, ⟨?_⟩⟩ + · exact env_simple_of_scalar_end f _ + (env_corner_id_ne_zero f E (hatom (q i))) + (env_corner_scalar f E (hatom (q i))) + -- The object is the biproduct of its corners over `ι`; then + -- reindex along `q`. + refine ?_ ≪≫ biproduct.whiskerEquiv (Fintype.equivFin ι) + (fun j => eqToIso (by rw [Equiv.symm_apply_apply])) + · exact + { hom := biproduct.lift fun j => cornerProj E (hatom j).idem + inv := biproduct.desc fun j => cornerIncl E (hatom j).idem + hom_inv_id := by + rw [biproduct.lift_desc] + rw [show ∑ j, cornerProj E (hatom j).idem ≫ + cornerIncl E (hatom j).idem = ∑ j, e j from + Finset.sum_congr rfl fun j _ => cornerProj_incl E _] + exact hco.complete + inv_hom_id := by + apply biproduct.hom_ext + intro j + rw [assoc, biproduct.lift_π, id_comp] + apply biproduct.hom_ext' + intro i + rw [biproduct.ι_desc_assoc, biproduct.ι_π] + by_cases hij : i = j + · subst hij + rw [dite_eq_left rfl, eqToHom_refl, cornerIncl_proj] + · rw [dite_eq_right hij] + exact cornerIncl_proj_orthogonal E _ _ + (hco.ortho (Ne.symm hij)) } + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/FactorialTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/FactorialTrace.lean new file mode 100644 index 0000000000..12e18c63b2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/FactorialTrace.lean @@ -0,0 +1,92 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Algebra.FactorialTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarPermTrace + +/-! +# Nilpotent categorical traces from the factorial obstruction + +The permutation action and scalar cycle-trace formula of an object +form a `CycleTraceTower`. Schrijver's factorial obstruction gives +nilpotent-trace vanishing from a single tensor level of dimension +less than `n!`, and hence from exponential endomorphism growth. +The Frobenius and trace-zeta route is retained in `ObjectTower`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.MonoidalCategory + +universe v u + +variable {A : Type u} + +/-- The cycle-trace tower of an object, with no growth assumption. -/ +noncomputable def objectCycleTraceTower + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] [RigidCategory A] + (hu : HasScalarUnit A) (X : A) : + CycleTraceTower (fun n => End (tensorPow A X n)) (End X) where + traceA := scalarTrace hu X + trace n := scalarTrace hu (tensorPow A X n) + rep n := { + toFun := permMor X n + map_one' := permMor_one X n + map_mul' := permMor_mul X n + } + pow n g := powHom X g n + cycleTrace n π g := by + change scalarTrace hu (tensorPow A X n) + (powHom X g n ≫ permMor X n π) = _ + rw [scalarTrace_comp_comm, scalarTrace_permMor_powHom, + prod_fullCycleType, pow_one] + +/-- A nonzero nilpotent trace forces factorial dimension at every +finite-dimensional tensor level. -/ +theorem factorial_le_finrank_of_nonzero_nilpotent_trace + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] [RigidCategory A] + (hu : HasScalarUnit A) (X : A) {g : End X} (hg : IsNilpotent g) + (hτ : scalarTrace hu X g ≠ 0) (n : ℕ) + [Module.Finite ℂ (End (tensorPow A X n))] : + n.factorial ≤ Module.finrank ℂ (End (tensorPow A X n)) := + (objectCycleTraceTower hu X).factorial_le_finrank hg hτ n + +/-- One tensor level of dimension less than its factorial suffices +for nilpotent categorical traces to vanish. -/ +theorem scalarTrace_eq_zero_of_finrank_lt_factorial + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] [RigidCategory A] + (hu : HasScalarUnit A) (X : A) {n : ℕ} + [Module.Finite ℂ (End (tensorPow A X n))] + (hbound : Module.finrank ℂ (End (tensorPow A X n)) < n.factorial) + {g : End X} (hg : IsNilpotent g) : scalarTrace hu X g = 0 := + (objectCycleTraceTower hu X).traceA_eq_zero_of_finrank_lt_factorial + hbound hg + +/-- The factorial proof of nilpotent categorical trace vanishing +under exponential endomorphism growth. -/ +theorem scalarTrace_eq_zero_of_isNilpotent_factorial + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] [RigidCategory A] + (hu : HasScalarUnit A) (X : A) + [∀ n, Module.Finite ℂ (End (tensorPow A X n))] (B : ℝ) + (hbound : ∀ n, + (Module.finrank ℂ (End (tensorPow A X n)) : ℝ) ≤ B ^ n) + {g : End X} (hg : IsNilpotent g) : scalarTrace hu X g = 0 := + (objectCycleTraceTower hu X).traceA_eq_zero_of_exponential_bound + B hbound hg + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/Frobenius.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/Frobenius.lean new file mode 100644 index 0000000000..f45b1d33ee --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/Frobenius.lean @@ -0,0 +1,112 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleNormal +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceCyclic +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedInstance + +/-! +# The skein Frobenius identity + +The bridge from permutation classes to bundle-map classes, and the +one consequence the trace calculus needs: the class of a block-sum +permutation is the tensor of the two block classes. + +Both are fragment computations. A permutation fragment relabels +the strand bundle by the permutation on the outgoing labels, which +is exactly a bundle map; and conjugating a block sum by +`finSumFinEquiv` is the tensor of the blocks. The trace +factorization these feed is `BlockFactor.lean`, and the Frobenius +identity itself `BlockAssembly.lean`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-! ### Bridge: permutation classes are bundle-map classes -/ + +/-- `permHighEquiv σ = outMapEquiv σ`: both fix the first `t` +labels and permute the last `t` labels by `σ`. -/ +private theorem permHighEquiv_eq_outMapEquiv {t : ℕ} + (σ : Equiv.Perm (Fin t)) : + permHighEquiv σ = outMapEquiv σ := by + refine _root_.Equiv.ext (fun x => Fin.ext ?_) + by_cases hx : x.val < t + · -- Low label: both are the identity + have h1 : (permHighEquiv σ x).val = x.val := by + change (if h : x.val < t then x else _).val = x.val + rw [dite_eq_left hx] + have h2 : (outMapEquiv σ x).val = x.val := by + rw [show x = Fin.castAdd t ⟨x.val, hx⟩ from Fin.ext rfl, + outMapEquiv_castAdd] + exact h1.trans h2.symm + · -- High label: both apply σ + have hxt := x.isLt + have h1 : (permHighEquiv σ x).val = + t + (σ ⟨x.val - t, by omega⟩).val := by + change (if h : x.val < t then x else _).val = _ + rw [dite_eq_right hx] + have hxeq : x = Fin.natAdd t ⟨x.val - t, by omega⟩ := + Fin.ext (by change x.val = t + (x.val - t); omega) + have h2 : (outMapEquiv σ x).val = + t + (σ ⟨x.val - t, by omega⟩).val := by + conv_lhs => rw [hxeq] + rw [outMapEquiv_natAdd]; rfl + exact h1.trans h2.symm + +/-- **Bridge lemma**: `permClass f n σ = bundleMapClass f σ`. -/ +theorem permClass_eq_bundleMapClass (n : ℕ) + (σ : Equiv.Perm (Fin n)) : + permClass f n σ = bundleMapClass f σ := by + change HomSpace.ofFragment f.val (permFragment σ) = + HomSpace.ofFragment f.val (bundleMap σ) + exact HomSpace.ofFragment_congr f + ((permFragmentRelabelBundle σ).trans + (Fragment.Equiv.relabelEq (strandBundle n) + (permHighEquiv_eq_outMapEquiv σ))) + +/-! ### The tensor of block classes -/ + +/-- `finSumFinEquiv.permCongr (sumCongr σ τ) = tensorMapEquiv σ τ`: +both conjugate the block-sum permutation by `finSumFinEquiv`. -/ +private theorem permCongr_sumCongr_eq_tensorMapEquiv + {a b : ℕ} (σ : Equiv.Perm (Fin a)) (τ : Equiv.Perm (Fin b)) : + finSumFinEquiv.permCongr (Equiv.sumCongr σ τ) = + tensorMapEquiv σ τ := by + refine _root_.Equiv.ext (fun x => Fin.ext ?_) + change (finSumFinEquiv ((Equiv.sumCongr σ τ) + (finSumFinEquiv.symm x))).val = + (tensorMapEquiv σ τ x).val + unfold tensorMapEquiv + rfl + +/-- The permutation class of a block-sum permutation is the tensor +of the block classes. -/ +theorem permClass_sumCongr (a b : ℕ) (σ : Equiv.Perm (Fin a)) + (τ : Equiv.Perm (Fin b)) : + permClass f (a + b) + (finSumFinEquiv.permCongr (Equiv.sumCongr σ τ)) = + (MonoidalCategoryStruct.tensorHom + (X₁ := SkeinObj.mk a) (Y₁ := SkeinObj.mk a) + (X₂ := SkeinObj.mk b) (Y₂ := SkeinObj.mk b) + (permClass f a σ) (permClass f b τ) : + End (SkeinObj.mk (a + b))) := by + rw [permClass_eq_bundleMapClass, + permCongr_sumCongr_eq_tensorMapEquiv] + change bundleMapClass f (tensorMapEquiv σ τ) = + HomSpace.tensor f a a b b (permClass f a σ) (permClass f b τ) + rw [permClass_eq_bundleMapClass, permClass_eq_bundleMapClass] + exact (bundleMapClass_tensor f σ τ).symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/HookConfinement.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/HookConfinement.lean new file mode 100644 index 0000000000..369668d3e0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/HookConfinement.lean @@ -0,0 +1,135 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockBounds + +/-! +# Hook confinement + +A `PermTower` over a family of algebras `E n` is a family of +representations of the symmetric-group algebras with exponentially +bounded dimensions (`finrank (E n) ≤ A ^ n`, the accompanying +paper's hypothesis, with `A` a real constant) in which vanishing +propagates along the standard embeddings. The main theorem: +relative to any `SchurPackage`, the shapes alive in a tower are +confined to a hook — there is an `s` with every alive shape +satisfying `IsInHook (s − 1) (s − 1)`. + +The argument: the square shape of side `s`, for `s` given by the +package's `square_dim` growth field at `⌈√A⌉`, has a block too large +for the tower's dimension bound, so it is dead +(`dim_sq_le_finrank`); by `e_killed_of_contained` and vanishing +propagation no shape containing the square is alive; and a shape +outside the hook contains the square. +-/ + +@[expose] public section + +namespace RS + +universe u + +/-- A tower of representations of the symmetric-group algebras on a +family of complex algebras, with vanishing propagating along the +standard embeddings (`symCast`) and exponentially bounded target +dimensions. The skein endomorphism algebras form such a tower. -/ +structure PermTower (E : ℕ → Type u) [∀ n, Ring (E n)] + [∀ n, Algebra ℂ (E n)] (A : ℝ) where + /-- The representations. -/ + rep : ∀ n, SymGroupAlgebra n →ₐ[ℂ] E n + /-- Vanishing propagates along the standard embeddings. -/ + compat : ∀ {m n : ℕ} (h : m ≤ n) (x : SymGroupAlgebra m), + rep m x = 0 → rep n (symCast h x) = 0 + /-- The exponential dimension bound. -/ + bound : ∀ n, ((Module.finrank ℂ (E n) : ℕ) : ℝ) ≤ A ^ n + +namespace PermTower + +variable {E : ℕ → Type u} + +/-- A shape is alive in a tower when its idempotent is not killed. -/ +def Alive [∀ n, Ring (E n)] [∀ n, Algebra ℂ (E n)] {A : ℝ} + (T : PermTower E A) (P : SchurPackage.{u}) + (μ : YoungDiagram) : Prop := + T.rep μ.card (P.e μ) ≠ 0 + +/-- The growth constant of a tower is nonnegative: it dominates the +dimension at one strand. -/ +theorem growth_nonneg [∀ n, Ring (E n)] [∀ n, Algebra ℂ (E n)] {A : ℝ} + (T : PermTower E A) : 0 ≤ A := by + have h := T.bound 1 + rw [pow_one] at h + exact le_trans (Nat.cast_nonneg _) h + +/-- **Square death**: the square of side `s` is not alive as soon as +its block dimension squared exceeds the tower's dimension bound at +`s²` strands. This is the accompanying paper's hypothesis verbatim: +`dim² ≤ finrank ≤ A ^ (s²) < dim²`. -/ +theorem not_alive_square [∀ n, Ring (E n)] [∀ n, Algebra ℂ (E n)] {A : ℝ} + [∀ n, Module.Finite ℂ (E n)] + (T : PermTower E A) (P : SchurPackage.{u}) {s : ℕ} + (hs : A ^ (s ^ 2) < ((P.dim (squareDiagram s) : ℕ) : ℝ) ^ 2) : + ¬ T.Alive P (squareDiagram s) := by + intro halive + have hcard : (squareDiagram s).card = s ^ 2 := squareDiagram_card s + have hle := P.dim_sq_le_finrank (squareDiagram s) + (T.rep (squareDiagram s).card) halive + have hleR : ((P.dim (squareDiagram s) : ℕ) : ℝ) ^ 2 + ≤ ((Module.finrank ℂ (E (squareDiagram s).card) : ℕ) : ℝ) := by + exact_mod_cast hle + have hb := T.bound (squareDiagram s).card + rw [hcard] at hleR hb + linarith + +/-- No shape containing a dead shape is alive. -/ +theorem not_alive_of_le [∀ n, Ring (E n)] [∀ n, Algebra ℂ (E n)] {A : ℝ} + (T : PermTower E A) (P : SchurPackage.{u}) + {lam mu : YoungDiagram} (hle : lam ≤ mu) + (hdead : ¬ T.Alive P lam) : ¬ T.Alive P mu := by + intro halive + have hcard : lam.card ≤ mu.card := + Finset.card_le_card (YoungDiagram.cells_subset_iff.mpr hle) + have hkill : T.rep mu.card (symCast hcard (P.e lam)) = 0 := + T.compat hcard _ (not_not.mp hdead) + exact halive (P.e_killed_of_contained hle hcard (T.rep mu.card) hkill) + +/-- **Hook confinement**: every shape alive in a tower lies in the +hook `IsInHook (s − 1) (s − 1)` for a side `s` given by the +package's growth field at the tower's bound. -/ +theorem hook_confinement [∀ n, Ring (E n)] [∀ n, Algebra ℂ (E n)] {A : ℝ} + [∀ n, Module.Finite ℂ (E n)] + (T : PermTower E A) (P : SchurPackage.{u}) : + ∃ s : ℕ, + ∀ μ : YoungDiagram, T.Alive P μ → IsInHook (s - 1) (s - 1) μ := by + -- The package's growth field is stated at a natural base, so it is + -- fed `⌈√A⌉`, which dominates `√A`. + obtain ⟨s, hs⟩ := P.square_dim ⌈Real.sqrt A⌉₊ + refine ⟨s, fun μ halive => ?_⟩ + by_contra hout + rw [not_isInHook_iff] at hout + have hsq : squareDiagram s ≤ μ := squareDiagram_le_of_rowLen (by omega) + refine T.not_alive_of_le P hsq (T.not_alive_square P ?_) halive + have hA0 : 0 ≤ A := T.growth_nonneg + have hceil : Real.sqrt A ≤ (⌈Real.sqrt A⌉₊ : ℝ) := Nat.le_ceil _ + have hAle : A ≤ ((⌈Real.sqrt A⌉₊ : ℝ)) ^ 2 := by + calc A = Real.sqrt A ^ 2 := (Real.sq_sqrt hA0).symm + _ ≤ ((⌈Real.sqrt A⌉₊ : ℝ)) ^ 2 := + pow_le_pow_left₀ (Real.sqrt_nonneg A) hceil 2 + have hsR : ((⌈Real.sqrt A⌉₊ : ℝ)) ^ (s ^ 2) + < ((P.dim (squareDiagram s) : ℕ) : ℝ) := by exact_mod_cast hs + calc A ^ (s ^ 2) + ≤ (((⌈Real.sqrt A⌉₊ : ℝ)) ^ 2) ^ (s ^ 2) := + pow_le_pow_left₀ hA0 hAle _ + _ = (((⌈Real.sqrt A⌉₊ : ℝ)) ^ (s ^ 2)) ^ 2 := by + rw [← pow_mul, mul_comm, pow_mul] + _ < ((P.dim (squareDiagram s) : ℕ) : ℝ) ^ 2 := + pow_lt_pow_left₀ hsR (by positivity) two_ne_zero + +end PermTower + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/HookConfinementSharp.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/HookConfinementSharp.lean new file mode 100644 index 0000000000..e68b59518a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/HookConfinementSharp.lean @@ -0,0 +1,76 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinement +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowthSharp +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.Package + +/-! +# Sharp hook confinement + +Hook confinement with the displayed constant of the accompanying +paper, and with the threshold quantified as the appendix states it: +relative to the assembled Schur package, *every* side `s > 2e√A` +confines, not merely some side. + +`HookConfinement.lean` proves the existential form over an arbitrary +package. The constant here comes from the block dimensions of the +assembled package, through `square_growth_sharp`. +-/ + +@[expose] public section + +namespace RS + +universe u + +/-- The assembled package's dimension field is the native block +dimension of the chosen simple submodule. -/ +theorem schurPackage_dim (μ : YoungDiagram) : + (schurPackage.{u}).dim μ = nDim (jtSimple μ) := rfl + +namespace PermTower + +variable {E : ℕ → Type u} + +/-- **Sharp square death**: in a tower of growth `A`, the square of +any side `s > 2e√A` is dead relative to the assembled package. Its +block dimension exceeds `√A ^ (s²)` by `square_growth_sharp`, so the +square of that dimension exceeds `A ^ (s²)`, which is what +`not_alive_square` asks for. -/ +theorem not_alive_square_sharp [∀ n, Ring (E n)] [∀ n, Algebra ℂ (E n)] {A : ℝ} + [∀ n, Module.Finite ℂ (E n)] + (T : PermTower E A) {s : ℕ} + (hs : 2 * Real.exp 1 * Real.sqrt A < s) : + ¬ T.Alive schurPackage.{u} (squareDiagram s) := by + refine T.not_alive_square schurPackage.{u} ?_ + have hgrow := square_growth_sharp (Real.sqrt A) (Real.sqrt_nonneg A) s hs + (jtSimple (squareDiagram s)) (jtSimple_char (squareDiagram s)) + have hAeq : (Real.sqrt A ^ (s ^ 2)) ^ 2 = A ^ (s ^ 2) := by + rw [← pow_mul, mul_comm, pow_mul, Real.sq_sqrt T.growth_nonneg] + rw [schurPackage_dim, ← hAeq] + exact pow_lt_pow_left₀ hgrow (pow_nonneg (Real.sqrt_nonneg A) _) two_ne_zero + +/-- **Sharp hook confinement**: in a tower of growth `A`, every alive +shape lies in the `(s − 1, s − 1)` hook, for *every* side +`s > 2e√A`. -/ +theorem hook_confinement_sharp [∀ n, Ring (E n)] [∀ n, Algebra ℂ (E n)] {A : ℝ} + [∀ n, Module.Finite ℂ (E n)] + (T : PermTower E A) {s : ℕ} + (hs : 2 * Real.exp 1 * Real.sqrt A < s) : + ∀ μ : YoungDiagram, T.Alive schurPackage.{u} μ → + IsInHook (s - 1) (s - 1) μ := by + intro μ halive + by_contra hout + rw [not_isInHook_iff] at hout + have hsq : squareDiagram s ≤ μ := squareDiagram_le_of_rowLen (by omega) + exact T.not_alive_of_le _ hsq (T.not_alive_square_sharp hs) halive + +end PermTower + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiEmbBraided.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiEmbBraided.lean new file mode 100644 index 0000000000..8cc029613e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiEmbBraided.lean @@ -0,0 +1,73 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvInstances + +/-! +# The Karoubi embedding is braided and linear + +The canonical functor `toKaroubi C` is a braided monoidal functor +(with respect to the in-tree monoidal and braided structures on +the Karoubi envelope) and is ℂ-linear. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Category CategoryTheory.Idempotents +open CategoryTheory.MonoidalCategory + +universe v u + +variable {C : Type u} + +private theorem tk_mu_f [Category.{v} C] [MonoidalCategory C] + (X Y : C) : + (Functor.LaxMonoidal.μ (toKaroubi C) X Y).f = 𝟙 (X ⊗ Y) := + rfl + +private theorem tk_map_f [Category.{v} C] + {X Y : C} (g : X ⟶ Y) : + ((toKaroubi C).map g).f = g := rfl + +section Braided + +private theorem tk_braiding_f + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] + (X Y : Karoubi C) : + (β_ X Y).hom.f = (X.p ⊗ₘ Y.p) ≫ (β_ X.X Y.X).hom := rfl + +/-- **The Karoubi embedding is braided.** -/ +noncomputable instance toKaroubiBraided + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] : + Functor.Braided (toKaroubi C) where + braided X Y := by + apply Karoubi.hom_ext + change (Functor.LaxMonoidal.μ (toKaroubi C) X Y).f ≫ + ((toKaroubi C).map (β_ X Y).hom).f = + (β_ ((toKaroubi C).obj X) ((toKaroubi C).obj Y)).hom.f ≫ + (Functor.LaxMonoidal.μ (toKaroubi C) Y X).f + rw [tk_mu_f, tk_mu_f, tk_map_f, tk_braiding_f] + change 𝟙 (X ⊗ Y) ≫ (β_ X Y).hom = + ((𝟙 X ⊗ₘ 𝟙 Y) ≫ (β_ X Y).hom) ≫ 𝟙 (Y ⊗ X) + simp + +end Braided + +section LinearEmb + +/-- **The Karoubi embedding is ℂ-linear.** -/ +instance toKaroubiLinear + [Category.{v} C] [Preadditive C] [CategoryTheory.Linear ℂ C] : + (toKaroubi C).Linear ℂ where + map_smul _ _ := rfl + +end LinearEmb + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiMonoidal.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiMonoidal.lean new file mode 100644 index 0000000000..687ee1ee68 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiMonoidal.lean @@ -0,0 +1,840 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Monoidal structure on the Karoubi envelope + +For a monoidal category `C`, the Karoubi envelope `Karoubi C` inherits a +monoidal structure: + +* **Objects**: `(A, p) ⊗ (B, q) = (A ⊗ B, p ⊗ₘ q)`, the tensor of + idempotents being idempotent by the interchange law. +* **Morphisms**: `f ⊗ₘ g` on underlying morphisms. +* **Unit**: `(𝟙_ C, 𝟙 (𝟙_ C))`. +* **Structural isomorphisms**: conjugates of the associators and unitors + of `C` by the idempotents — e.g. the associator has underlying morphism + `((p ⊗ₘ q) ⊗ₘ r) ≫ α_{A,B,C}.hom`. + +The canonical functor `toKaroubi C : C ⥤ Karoubi C` is strong monoidal. + +When `C` is braided (respectively symmetric), so is `Karoubi C`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Category CategoryTheory.Idempotents +open CategoryTheory.MonoidalCategory + +universe v u + +variable {C : Type u} + +/-! ### Auxiliary lemmas for idempotent-conjugated morphisms -/ + +/-- The tensor product of idempotents is idempotent. -/ +private theorem tensorHom_idem [Category.{v} C] [MonoidalCategory C] + {A B : C} {p : A ⟶ A} {q : B ⟶ B} + (hp : p ≫ p = p) (hq : q ≫ q = q) : + (p ⊗ₘ q) ≫ (p ⊗ₘ q) = p ⊗ₘ q := by + rw [tensorHom_comp_tensorHom, hp, hq] + +/-- Comm condition for tensor product morphisms in the Karoubi envelope. -/ +private theorem karoubi_tensorHom_comm [Category.{v} C] [MonoidalCategory C] + {P₁ Q₁ P₂ Q₂ : Karoubi C} (f : P₁ ⟶ Q₁) (g : P₂ ⟶ Q₂) : + (P₁.p ⊗ₘ P₂.p) ≫ (f.f ⊗ₘ g.f) ≫ (Q₁.p ⊗ₘ Q₂.p) = f.f ⊗ₘ g.f := by + simp only [tensorHom_comp_tensorHom, Karoubi.p_comp, Karoubi.comp_p] + +/-- The Karoubi comm condition `p ≫ (p ≫ f) ≫ q = p ≫ f` holds whenever `p, q` +are idempotent and `p ≫ f = f ≫ q` (naturality). -/ +private theorem conj_comm [Category.{v} C] + {A B : C} (p : A ⟶ A) (q : B ⟶ B) + (hp : p ≫ p = p) (hq : q ≫ q = q) (f : A ⟶ B) + (hnat : p ≫ f = f ≫ q) : + p ≫ (p ≫ f) ≫ q = p ≫ f := by + simp only [← assoc, hp] + rw [hnat, assoc, hq] + +/-- If `p ≫ φ.hom = φ.hom ≫ q` and `p` is idempotent, then +`(p ≫ φ.hom) ≫ (q ≫ φ.inv) = p`. -/ +private theorem conj_iso_hom_inv [Category.{v} C] + {A B : C} (p : A ⟶ A) (q : B ⟶ B) + (hp : p ≫ p = p) (φ : A ≅ B) (hnat : p ≫ φ.hom = φ.hom ≫ q) : + (p ≫ φ.hom) ≫ (q ≫ φ.inv) = p := by + have hnat_assoc : ∀ {E : C} (h : B ⟶ E), + p ≫ φ.hom ≫ h = φ.hom ≫ q ≫ h := by + intro E h; rw [← assoc, hnat, assoc] + rw [assoc, ← hnat_assoc, Iso.hom_inv_id, comp_id, hp] + +/-- If `p ≫ φ.hom = φ.hom ≫ q` and `q` is idempotent, then +`(q ≫ φ.inv) ≫ (p ≫ φ.hom) = q`. -/ +private theorem conj_iso_inv_hom [Category.{v} C] + {A B : C} (p : A ⟶ A) (q : B ⟶ B) + (hq : q ≫ q = q) (φ : A ≅ B) (hnat : p ≫ φ.hom = φ.hom ≫ q) : + (q ≫ φ.inv) ≫ (p ≫ φ.hom) = q := by + have inv_nat : q ≫ φ.inv = φ.inv ≫ p := by + rw [← cancel_mono φ.hom, assoc, Iso.inv_hom_id, comp_id, + assoc, hnat, ← assoc, Iso.inv_hom_id, id_comp] + have inv_nat_assoc : ∀ {E : C} (h : A ⟶ E), + q ≫ φ.inv ≫ h = φ.inv ≫ p ≫ h := by + intro E h; rw [← assoc, inv_nat, assoc] + rw [assoc, ← inv_nat_assoc, Iso.inv_hom_id, comp_id, hq] + +/-! ### Decomposition of tensor products with compositions + +When one argument of `⊗ₘ` is idempotent, a composition in the other argument +can be extracted as a composition of tensor products. These lemmas are needed +because `rw` / `simp` cannot rewrite subexpressions *inside* `⊗ₘ` arguments +due to dependent-type motive construction failures. -/ + +/-- Decompose `(f ≫ g) ⊗ₘ q` into `(f ⊗ₘ q) ≫ (g ⊗ₘ q)` when `q` is +idempotent. -/ +private theorem tensorHom_comp_left_idem_right + [Category.{v} C] [MonoidalCategory C] + {A B D : C} + {p : A ⟶ A} (f : A ⟶ B) (q : D ⟶ D) (hq : q ≫ q = q) : + (p ≫ f) ⊗ₘ q = (p ⊗ₘ q) ≫ (f ⊗ₘ q) := by + have : (p ≫ f) ⊗ₘ q = (p ≫ f) ⊗ₘ (q ≫ q) := by congr 1; exact hq.symm + rw [this, ← tensorHom_comp_tensorHom] + +/-- Decompose `p ⊗ₘ (f ≫ g)` into `(p ⊗ₘ f) ≫ (p ⊗ₘ g)` when `p` is +idempotent. -/ +private theorem tensorHom_idem_left_comp_right + [Category.{v} C] [MonoidalCategory C] + {A D E : C} + (p : A ⟶ A) (hp : p ≫ p = p) {q : D ⟶ D} (g : D ⟶ E) : + p ⊗ₘ (q ≫ g) = (p ⊗ₘ q) ≫ (p ⊗ₘ g) := by + have : p ⊗ₘ (q ≫ g) = (p ≫ p) ⊗ₘ (q ≫ g) := by congr 1; exact hp.symm + rw [this, ← tensorHom_comp_tensorHom] + +/-! ### Naturality of structural isomorphisms with idempotents + +These lemmas state the naturality of the associator, left unitor, and +right unitor (and their inverses) applied to the idempotent morphisms of +Karoubi objects. They are proved outside any Karoubi-struct context so +that `rw` with `id_tensorHom`/`tensorHom_id` avoids dependent-type +motive failures. -/ + +private theorem assoc_nat [Category.{v} C] [MonoidalCategory C] + (X Y Z : Karoubi C) : + ((X.p ⊗ₘ Y.p) ⊗ₘ Z.p) ≫ (α_ X.X Y.X Z.X).hom = + (α_ X.X Y.X Z.X).hom ≫ (X.p ⊗ₘ (Y.p ⊗ₘ Z.p)) := + associator_naturality X.p Y.p Z.p + +private theorem assoc_inv_nat [Category.{v} C] [MonoidalCategory C] + (X Y Z : Karoubi C) : + (X.p ⊗ₘ (Y.p ⊗ₘ Z.p)) ≫ (α_ X.X Y.X Z.X).inv = + (α_ X.X Y.X Z.X).inv ≫ ((X.p ⊗ₘ Y.p) ⊗ₘ Z.p) := by + rw [← cancel_mono (α_ X.X Y.X Z.X).hom, assoc, Iso.inv_hom_id, comp_id, + assoc, associator_naturality, ← assoc, Iso.inv_hom_id, id_comp] + +private theorem leftUnit_nat [Category.{v} C] [MonoidalCategory C] + (X : Karoubi C) : + (𝟙 (𝟙_ C) ⊗ₘ X.p) ≫ (λ_ X.X).hom = (λ_ X.X).hom ≫ X.p := by + rw [id_tensorHom]; exact leftUnitor_naturality X.p + +private theorem leftUnit_inv_nat [Category.{v} C] [MonoidalCategory C] + (X : Karoubi C) : + X.p ≫ (λ_ X.X).inv = (λ_ X.X).inv ≫ (𝟙 (𝟙_ C) ⊗ₘ X.p) := by + rw [id_tensorHom]; exact leftUnitor_inv_naturality X.p + +private theorem rightUnit_nat [Category.{v} C] [MonoidalCategory C] + (X : Karoubi C) : + (X.p ⊗ₘ 𝟙 (𝟙_ C)) ≫ (ρ_ X.X).hom = (ρ_ X.X).hom ≫ X.p := by + rw [tensorHom_id]; exact rightUnitor_naturality X.p + +private theorem rightUnit_inv_nat [Category.{v} C] [MonoidalCategory C] + (X : Karoubi C) : + X.p ≫ (ρ_ X.X).inv = (ρ_ X.X).inv ≫ (X.p ⊗ₘ 𝟙 (𝟙_ C)) := by + rw [tensorHom_id]; exact rightUnitor_inv_naturality X.p + +/-! ### Data: `MonoidalCategoryStruct` on `Karoubi C` -/ + +/-- The monoidal data on the Karoubi envelope: tensor of +idempotents, conjugated structural isomorphisms. -/ +instance karoubiMonoidalStruct [Category.{v} C] [MonoidalCategory C] : + MonoidalCategoryStruct (Karoubi C) where + tensorObj X Y := + ⟨X.X ⊗ Y.X, X.p ⊗ₘ Y.p, by exact tensorHom_idem X.idem Y.idem⟩ + whiskerLeft X _ _ f := + ⟨X.p ⊗ₘ f.f, by exact karoubi_tensorHom_comm (⟨X.p, by simp [X.idem]⟩ : X ⟶ X) f⟩ + whiskerRight f Y := + ⟨f.f ⊗ₘ Y.p, by exact karoubi_tensorHom_comm f (⟨Y.p, by simp [Y.idem]⟩ : Y ⟶ Y)⟩ + tensorHom f g := ⟨f.f ⊗ₘ g.f, by exact karoubi_tensorHom_comm f g⟩ + tensorUnit := ⟨𝟙_ C, 𝟙 (𝟙_ C), by simp⟩ + associator X Y Z := + { hom := ⟨((X.p ⊗ₘ Y.p) ⊗ₘ Z.p) ≫ (α_ X.X Y.X Z.X).hom, + by exact (conj_comm _ _ + (tensorHom_idem (tensorHom_idem X.idem Y.idem) Z.idem) + (tensorHom_idem X.idem (tensorHom_idem Y.idem Z.idem)) + _ (assoc_nat X Y Z))⟩ + inv := ⟨(X.p ⊗ₘ (Y.p ⊗ₘ Z.p)) ≫ (α_ X.X Y.X Z.X).inv, + by exact (conj_comm _ _ + (tensorHom_idem X.idem (tensorHom_idem Y.idem Z.idem)) + (tensorHom_idem (tensorHom_idem X.idem Y.idem) Z.idem) + _ (assoc_inv_nat X Y Z))⟩ + hom_inv_id := by + apply Karoubi.hom_ext; simp only [Karoubi.comp_f, Karoubi.id_f] + exact conj_iso_hom_inv _ _ + (tensorHom_idem (tensorHom_idem X.idem Y.idem) Z.idem) + _ (assoc_nat X Y Z) + inv_hom_id := by + apply Karoubi.hom_ext; simp only [Karoubi.comp_f, Karoubi.id_f] + exact conj_iso_inv_hom _ _ + (tensorHom_idem X.idem (tensorHom_idem Y.idem Z.idem)) + _ (assoc_nat X Y Z) } + leftUnitor X := + { hom := ⟨(𝟙 (𝟙_ C) ⊗ₘ X.p) ≫ (λ_ X.X).hom, + by exact (conj_comm _ _ + (tensorHom_idem (by simp) X.idem) X.idem + _ (leftUnit_nat X))⟩ + inv := ⟨X.p ≫ (λ_ X.X).inv, + by exact (conj_comm _ _ X.idem + (tensorHom_idem (by simp) X.idem) + _ (leftUnit_inv_nat X))⟩ + hom_inv_id := by + apply Karoubi.hom_ext; simp only [Karoubi.comp_f, Karoubi.id_f] + exact conj_iso_hom_inv _ _ + (tensorHom_idem (by simp) X.idem) _ (leftUnit_nat X) + inv_hom_id := by + apply Karoubi.hom_ext; simp only [Karoubi.comp_f, Karoubi.id_f] + exact conj_iso_inv_hom _ _ X.idem _ (leftUnit_nat X) } + rightUnitor X := + { hom := ⟨(X.p ⊗ₘ 𝟙 (𝟙_ C)) ≫ (ρ_ X.X).hom, + by exact (conj_comm _ _ + (tensorHom_idem X.idem (by simp)) X.idem + _ (rightUnit_nat X))⟩ + inv := ⟨X.p ≫ (ρ_ X.X).inv, + by exact (conj_comm _ _ X.idem + (tensorHom_idem X.idem (by simp)) + _ (rightUnit_inv_nat X))⟩ + hom_inv_id := by + apply Karoubi.hom_ext; simp only [Karoubi.comp_f, Karoubi.id_f] + exact conj_iso_hom_inv _ _ + (tensorHom_idem X.idem (by simp)) _ (rightUnit_nat X) + inv_hom_id := by + apply Karoubi.hom_ext; simp only [Karoubi.comp_f, Karoubi.id_f] + exact conj_iso_inv_hom _ _ X.idem _ (rightUnit_nat X) } + +/-! ### Simp lemmas for the Karoubi monoidal data + +These unfold the `.f` and `.p` projections of the Karoubi monoidal +structure to morphisms in `C`. They are all definitional equalities. -/ + +@[simp] private theorem karoubiTensorHom_f [Category.{v} C] [MonoidalCategory C] + {P₁ Q₁ P₂ Q₂ : Karoubi C} (f : P₁ ⟶ Q₁) (g : P₂ ⟶ Q₂) : + (f ⊗ₘ g : _ ⟶ _).f = f.f ⊗ₘ g.f := rfl + +@[simp] private theorem karoubiTensorObj_p [Category.{v} C] [MonoidalCategory C] + (X Y : Karoubi C) : + (X ⊗ Y : Karoubi C).p = X.p ⊗ₘ Y.p := rfl + +@[simp] private theorem karoubiTensorObj_X [Category.{v} C] [MonoidalCategory C] + (X Y : Karoubi C) : + (X ⊗ Y : Karoubi C).X = X.X ⊗ Y.X := rfl + +@[simp] private theorem karoubiTensorUnit_p + [Category.{v} C] [MonoidalCategory C] : + (𝟙_ (Karoubi C)).p = 𝟙 (𝟙_ C) := rfl + +@[simp] private theorem karoubiTensorUnit_X + [Category.{v} C] [MonoidalCategory C] : + (𝟙_ (Karoubi C)).X = 𝟙_ C := rfl + +@[simp] private theorem karoubiAssociator_hom_f + [Category.{v} C] [MonoidalCategory C] + (X Y Z : Karoubi C) : + (α_ X Y Z).hom.f = + ((X.p ⊗ₘ Y.p) ⊗ₘ Z.p) ≫ (α_ X.X Y.X Z.X).hom := rfl + +@[simp] private theorem karoubiLeftUnitor_hom_f + [Category.{v} C] [MonoidalCategory C] + (X : Karoubi C) : + (λ_ X).hom.f = (𝟙 (𝟙_ C) ⊗ₘ X.p) ≫ (λ_ X.X).hom := rfl + +@[simp] private theorem karoubiRightUnitor_hom_f + [Category.{v} C] [MonoidalCategory C] + (X : Karoubi C) : + (ρ_ X).hom.f = (X.p ⊗ₘ 𝟙 (𝟙_ C)) ≫ (ρ_ X.X).hom := rfl + +@[simp] private theorem karoubiWhiskerLeft_f + [Category.{v} C] [MonoidalCategory C] + (X : Karoubi C) {Y Z : Karoubi C} (f : Y ⟶ Z) : + (X ◁ f).f = X.p ⊗ₘ f.f := rfl + +@[simp] private theorem karoubiWhiskerRight_f + [Category.{v} C] [MonoidalCategory C] + {X Y : Karoubi C} (f : X ⟶ Y) (Z : Karoubi C) : + (f ▷ Z).f = f.f ⊗ₘ Z.p := rfl + +@[simp] private theorem karoubiAssociator_inv_f + [Category.{v} C] [MonoidalCategory C] + (X Y Z : Karoubi C) : + (α_ X Y Z).inv.f = + (X.p ⊗ₘ (Y.p ⊗ₘ Z.p)) ≫ (α_ X.X Y.X Z.X).inv := rfl + +@[simp] private theorem karoubiLeftUnitor_inv_f + [Category.{v} C] [MonoidalCategory C] + (X : Karoubi C) : + (λ_ X).inv.f = X.p ≫ (λ_ X.X).inv := rfl + +@[simp] private theorem karoubiRightUnitor_inv_f + [Category.{v} C] [MonoidalCategory C] + (X : Karoubi C) : + (ρ_ X).inv.f = X.p ≫ (ρ_ X.X).inv := rfl + +/-! ### Axioms: `MonoidalCategory` on `Karoubi C` + +The monoidal axioms (interchange, naturality, pentagon, triangle) are +proved by reducing to the underlying morphisms in `C` via `hom_ext` and +the Karoubi simp lemmas `p_comp`, `comp_p`, `idem`. -/ + +private theorem karoubi_id_tensorHom_id [Category.{v} C] [MonoidalCategory C] + (X₁ X₂ : Karoubi C) : + tensorHom (𝟙 X₁) (𝟙 X₂) = 𝟙 (tensorObj X₁ X₂) := by + apply Karoubi.hom_ext; simp [Karoubi.id_f] + +private theorem karoubi_id_tensorHom [Category.{v} C] [MonoidalCategory C] + (X : Karoubi C) {Y₁ Y₂ : Karoubi C} + (f : Y₁ ⟶ Y₂) : tensorHom (𝟙 X) f = whiskerLeft X f := + Karoubi.hom_ext _ _ rfl + +private theorem karoubi_tensorHom_id [Category.{v} C] [MonoidalCategory C] + {X₁ X₂ : Karoubi C} (f : X₁ ⟶ X₂) + (Y : Karoubi C) : tensorHom f (𝟙 Y) = whiskerRight f Y := + Karoubi.hom_ext _ _ rfl + +private theorem karoubi_tensorHom_comp [Category.{v} C] [MonoidalCategory C] + {X₁ Y₁ Z₁ X₂ Y₂ Z₂ : Karoubi C} + (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (g₁ : Y₁ ⟶ Z₁) (g₂ : Y₂ ⟶ Z₂) : + (f₁ ⊗ₘ f₂) ≫ (g₁ ⊗ₘ g₂) = (f₁ ≫ g₁) ⊗ₘ (f₂ ≫ g₂) := by + apply Karoubi.hom_ext + simp [Karoubi.comp_f, tensorHom_comp_tensorHom] + +private theorem karoubi_associator_naturality + [Category.{v} C] [MonoidalCategory C] + {X₁ X₂ X₃ Y₁ Y₂ Y₃ : Karoubi C} + (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (f₃ : X₃ ⟶ Y₃) : + tensorHom (tensorHom f₁ f₂) f₃ ≫ (associator Y₁ Y₂ Y₃).hom = + (associator X₁ X₂ X₃).hom ≫ tensorHom f₁ (tensorHom f₂ f₃) := by + apply Karoubi.hom_ext + simp only [Karoubi.comp_f, karoubiTensorHom_f, karoubiAssociator_hom_f] + simp only [← assoc, associator_naturality] + simp only [assoc, tensorHom_comp_tensorHom, Karoubi.comp_p, Karoubi.p_comp] + +/-! ### Bridge lemmas: tensorHom form of C axioms + +The mathlib `MonoidalCategory` axioms for C use `◁` / `▷` (whiskerLeft / +whiskerRight) while `ofTensorHom` expects `𝟙 X ⊗ₘ f` / `f ⊗ₘ 𝟙 Y`. +These helpers restate the relevant C axioms in `tensorHom` form, proved +outside the Karoubi struct context where `rw [id_tensorHom]` is safe. -/ + +private theorem tensorHom_leftUnitor_naturality + [Category.{v} C] [MonoidalCategory C] + {X Y : C} (f : X ⟶ Y) : + (𝟙 (𝟙_ C) ⊗ₘ f) ≫ (λ_ Y).hom = (λ_ X).hom ≫ f := by + rw [id_tensorHom]; exact leftUnitor_naturality f + +private theorem tensorHom_rightUnitor_naturality + [Category.{v} C] [MonoidalCategory C] + {X Y : C} (f : X ⟶ Y) : + (f ⊗ₘ 𝟙 (𝟙_ C)) ≫ (ρ_ Y).hom = (ρ_ X).hom ≫ f := by + rw [tensorHom_id]; exact rightUnitor_naturality f + +@[reassoc] private theorem tensorHom_pentagon_eq + [Category.{v} C] [MonoidalCategory C] + (W X Y Z : C) : + ((α_ W X Y).hom ⊗ₘ 𝟙 Z) ≫ (α_ W (X ⊗ Y) Z).hom ≫ + (𝟙 W ⊗ₘ (α_ X Y Z).hom) = + (α_ (W ⊗ X) Y Z).hom ≫ (α_ W X (Y ⊗ Z)).hom := by + rw [id_tensorHom, tensorHom_id]; exact pentagon W X Y Z + +@[reassoc] private theorem tensorHom_triangle_eq + [Category.{v} C] [MonoidalCategory C] + (X Y : C) : + (α_ X (𝟙_ C) Y).hom ≫ (𝟙 X ⊗ₘ (λ_ Y).hom) = + (ρ_ X).hom ⊗ₘ 𝟙 Y := by + rw [id_tensorHom, tensorHom_id]; exact triangle X Y + +private theorem karoubi_leftUnitor_naturality + [Category.{v} C] [MonoidalCategory C] + {X Y : Karoubi C} (f : X ⟶ Y) : + tensorHom (𝟙 (𝟙_ (Karoubi C))) f ≫ (leftUnitor Y).hom = + (leftUnitor X).hom ≫ f := by + apply Karoubi.hom_ext + simp only [Karoubi.comp_f, Karoubi.id_f, karoubiTensorHom_f, + karoubiLeftUnitor_hom_f, karoubiTensorUnit_p] + rw [← assoc, tensorHom_comp_tensorHom] + have h : (𝟙 (𝟙_ C) ≫ 𝟙 (𝟙_ C)) ⊗ₘ (f.f ≫ Y.p) = 𝟙 (𝟙_ C) ⊗ₘ f.f := by + congr 1 + · exact id_comp _ + · exact Karoubi.comp_p f + rw [h, tensorHom_leftUnitor_naturality, leftUnit_nat, assoc, Karoubi.p_comp] + +private theorem karoubi_rightUnitor_naturality + [Category.{v} C] [MonoidalCategory C] + {X Y : Karoubi C} (f : X ⟶ Y) : + tensorHom f (𝟙 (𝟙_ (Karoubi C))) ≫ (rightUnitor Y).hom = + (rightUnitor X).hom ≫ f := by + apply Karoubi.hom_ext + simp only [Karoubi.comp_f, Karoubi.id_f, karoubiTensorHom_f, + karoubiRightUnitor_hom_f, karoubiTensorUnit_p] + rw [← assoc, tensorHom_comp_tensorHom] + have h : (f.f ≫ Y.p) ⊗ₘ (𝟙 (𝟙_ C) ≫ 𝟙 (𝟙_ C)) = f.f ⊗ₘ 𝟙 (𝟙_ C) := by + congr 1 + · exact Karoubi.comp_p f + · exact id_comp _ + rw [h, tensorHom_rightUnitor_naturality, rightUnit_nat, assoc, Karoubi.p_comp] + +-- Pentagon: the proof strategy is to decompose compositions from inside +-- `⊗ₘ`, use naturality to move intermediate idempotents past associators, +-- absorb duplicate idempotents, then replace `(α ⊗ p)` / `(p ⊗ α)` with +-- `(α ⊗ 𝟙)` / `(𝟙 ⊗ α)` using the merge+congr technique, and finally +-- apply the C pentagon. +private theorem karoubi_pentagon [Category.{v} C] [MonoidalCategory C] + (W X Y Z : Karoubi C) : + tensorHom (associator W X Y).hom (𝟙 Z) ≫ + (associator W (tensorObj X Y) Z).hom ≫ + tensorHom (𝟙 W) (associator X Y Z).hom = + (associator (tensorObj W X) Y Z).hom ≫ + (associator W X (tensorObj Y Z)).hom := by + apply Karoubi.hom_ext + simp only [Karoubi.comp_f, Karoubi.id_f, karoubiTensorHom_f, + karoubiAssociator_hom_f, karoubiTensorObj_p, karoubiTensorObj_X] + -- Extract compositions from inside `⊗ₘ` to the top level. + rw [tensorHom_comp_left_idem_right _ _ Z.idem, + tensorHom_idem_left_comp_right _ W.idem] + simp only [assoc] + -- Move `(pW ⊗ pXY) ⊗ pZ` past `α₂` via associator naturality. + rw [associator_naturality_assoc W.p (X.p ⊗ₘ Y.p) Z.p] + -- Absorb `(pW ⊗ (pXY ⊗ pZ)) ≫ (pW ⊗ (pXY ⊗ pZ))`. + have h_absorb : ∀ {E : C} (h : W.X ⊗ ((X.X ⊗ Y.X) ⊗ Z.X) ⟶ E), + (W.p ⊗ₘ ((X.p ⊗ₘ Y.p) ⊗ₘ Z.p)) ≫ + ((W.p ⊗ₘ ((X.p ⊗ₘ Y.p) ⊗ₘ Z.p)) ≫ h) = + (W.p ⊗ₘ ((X.p ⊗ₘ Y.p) ⊗ₘ Z.p)) ≫ h := by + intro E h + rw [← assoc, tensorHom_idem W.idem + (tensorHom_idem (tensorHom_idem X.idem Y.idem) Z.idem)] + rw [h_absorb] + -- Replace `src₄ ≫ (α₁ ⊗ pZ)` with `src₄ ≫ (α₁ ⊗ 𝟙 Z.X)` by merging + -- the adjacent tensor products and simplifying `pZ ≫ pZ = pZ ≫ 𝟙`. + have h_left : ∀ {E : C} (h : (W.X ⊗ (X.X ⊗ Y.X)) ⊗ Z.X ⟶ E), + (((W.p ⊗ₘ X.p) ⊗ₘ Y.p) ⊗ₘ Z.p) ≫ + (((α_ W.X X.X Y.X).hom ⊗ₘ Z.p) ≫ h) = + (((W.p ⊗ₘ X.p) ⊗ₘ Y.p) ⊗ₘ Z.p) ≫ + (((α_ W.X X.X Y.X).hom ⊗ₘ 𝟙 Z.X) ≫ h) := by + intro E h; simp only [← assoc]; congr 1 + rw [tensorHom_comp_tensorHom, tensorHom_comp_tensorHom] + congr 1; rw [Z.idem, comp_id] + rw [h_left] + -- Replace `(pW ⊗ (pXY ⊗ pZ)) ≫ (pW ⊗ α₃)` with `(𝟙 ⊗ α₃) ≫ tgt₅` + -- by merging and applying associator naturality inside the congr. + have h_right : + (W.p ⊗ₘ ((X.p ⊗ₘ Y.p) ⊗ₘ Z.p)) ≫ (W.p ⊗ₘ (α_ X.X Y.X Z.X).hom) = + (𝟙 W.X ⊗ₘ (α_ X.X Y.X Z.X).hom) ≫ + (W.p ⊗ₘ (X.p ⊗ₘ (Y.p ⊗ₘ Z.p))) := by + rw [tensorHom_comp_tensorHom, tensorHom_comp_tensorHom] + congr 1 + · rw [W.idem, id_comp] + · exact associator_naturality X.p Y.p Z.p + rw [h_right] + -- Apply the C pentagon (reassoc form) and finish with RHS naturality. + rw [tensorHom_pentagon_eq_assoc, associator_naturality W.p X.p (Y.p ⊗ₘ Z.p)] + +-- Triangle: same decomposition + merge+congr strategy as the pentagon. +private theorem karoubi_triangle [Category.{v} C] [MonoidalCategory C] + (X Y : Karoubi C) : + (associator X (𝟙_ (Karoubi C)) Y).hom ≫ + tensorHom (𝟙 X) (leftUnitor Y).hom = + tensorHom (rightUnitor X).hom (𝟙 Y) := by + apply Karoubi.hom_ext + simp only [Karoubi.comp_f, Karoubi.id_f, karoubiTensorHom_f, + karoubiAssociator_hom_f, karoubiLeftUnitor_hom_f, + karoubiRightUnitor_hom_f, + karoubiTensorUnit_p, karoubiTensorUnit_X, karoubiTensorObj_X] + -- Extract compositions from inside `⊗ₘ` to the top level. + rw [tensorHom_comp_left_idem_right _ _ Y.idem, + tensorHom_idem_left_comp_right _ X.idem] + simp only [assoc] + -- Move idempotents past the associator via naturality. + rw [associator_naturality_assoc X.p (𝟙 (𝟙_ C)) Y.p] + -- Absorb `(pX ⊗ (𝟙 ⊗ pY)) ≫ (pX ⊗ (𝟙 ⊗ pY))`. + have h_absorb : ∀ {E : C} (h : X.X ⊗ (𝟙_ C ⊗ Y.X) ⟶ E), + (X.p ⊗ₘ (𝟙 (𝟙_ C) ⊗ₘ Y.p)) ≫ + ((X.p ⊗ₘ (𝟙 (𝟙_ C) ⊗ₘ Y.p)) ≫ h) = + (X.p ⊗ₘ (𝟙 (𝟙_ C) ⊗ₘ Y.p)) ≫ h := by + intro E h + rw [← assoc, tensorHom_idem X.idem (tensorHom_idem (by simp) Y.idem)] + rw [h_absorb] + -- Merge the LHS tensor products and apply left unitor naturality. + have h_merge : + (X.p ⊗ₘ (𝟙 (𝟙_ C) ⊗ₘ Y.p)) ≫ (X.p ⊗ₘ (λ_ Y.X).hom) = + (𝟙 X.X ⊗ₘ (λ_ Y.X).hom) ≫ (X.p ⊗ₘ Y.p) := by + rw [tensorHom_comp_tensorHom, tensorHom_comp_tensorHom] + congr 1 + · rw [X.idem, id_comp] + · exact leftUnit_nat Y + rw [h_merge] + -- Merge the RHS tensor products and apply right unitor naturality. + have h_rhs : + ((X.p ⊗ₘ 𝟙 (𝟙_ C)) ⊗ₘ Y.p) ≫ ((ρ_ X.X).hom ⊗ₘ Y.p) = + ((ρ_ X.X).hom ⊗ₘ 𝟙 Y.X) ≫ (X.p ⊗ₘ Y.p) := by + rw [tensorHom_comp_tensorHom, tensorHom_comp_tensorHom] + congr 1 + · exact rightUnit_nat X + · rw [Y.idem, id_comp] + rw [h_rhs] + -- Apply the C triangle (reassoc form). + rw [tensorHom_triangle_eq_assoc] + +/-- Those data satisfy the monoidal axioms, each inherited from the +ambient category by conjugation. -/ +instance karoubiMonoidal + [Category.{v} C] [MonoidalCategory C] : MonoidalCategory (Karoubi C) := by + exact MonoidalCategory.ofTensorHom + (id_tensorHom_id := by exact karoubi_id_tensorHom_id) + (id_tensorHom := by exact karoubi_id_tensorHom) + (tensorHom_id := by exact karoubi_tensorHom_id) + (tensorHom_comp_tensorHom := by exact karoubi_tensorHom_comp) + (associator_naturality := by exact karoubi_associator_naturality) + (leftUnitor_naturality := by exact karoubi_leftUnitor_naturality) + (rightUnitor_naturality := by exact karoubi_rightUnitor_naturality) + (pentagon := by exact karoubi_pentagon) + (triangle := by exact karoubi_triangle) + +/-! ### The canonical functor `toKaroubi C` is strong monoidal -/ + +/-- The underlying object of `toKaroubi C` on `X`. -/ +@[simp] private theorem toKaroubi_obj_X [Category.{v} C] + (X : C) : + ((toKaroubi C).obj X).X = X := rfl + +/-- The idempotent of `toKaroubi C` on `X` is the identity. -/ +@[simp] private theorem toKaroubi_obj_p [Category.{v} C] + (X : C) : + ((toKaroubi C).obj X).p = 𝟙 X := rfl + +/-- The underlying morphism of `toKaroubi C` on `f`. -/ +@[simp] private theorem toKaroubi_map_f [Category.{v} C] + {X Y : C} (f : X ⟶ Y) : + ((toKaroubi C).map f).f = f := rfl + +/-! ### Strong monoidality + +The functor `toKaroubi C : C ⥤ Karoubi C` sends `X` to `⟨X, 𝟙 X⟩`. It +preserves the tensor unit on the nose and the tensor product up to the +canonical identification `𝟙 X ⊗ₘ 𝟙 Y = 𝟙 (X ⊗ Y)`. -/ + +-- The eight coherence fields of a monoidal functor +-- elaborate together. +/-- The embedding is monoidal. -/ +noncomputable instance toKaroubiMonoidal + [Category.{v} C] [MonoidalCategory C] : Functor.Monoidal (toKaroubi C) where + ε := 𝟙 _ + μ X Y := ⟨𝟙 (X ⊗ Y), by simp [comp_id]⟩ + η := 𝟙 _ + δ X Y := ⟨𝟙 (X ⊗ Y), by simp [comp_id]⟩ + ε_η := by apply Karoubi.hom_ext; simp + η_ε := by apply Karoubi.hom_ext; simp + μ_δ X Y := by apply Karoubi.hom_ext; simp + δ_μ X Y := by apply Karoubi.hom_ext; simp + μ_natural_left f X' := by + apply Karoubi.hom_ext; simp [Karoubi.comp_f, karoubiWhiskerRight_f] + μ_natural_right X' f := by + apply Karoubi.hom_ext; simp [Karoubi.comp_f, karoubiWhiskerLeft_f] + δ_natural_left f X' := by + apply Karoubi.hom_ext; simp [Karoubi.comp_f, karoubiWhiskerRight_f] + δ_natural_right X' f := by + apply Karoubi.hom_ext; simp [Karoubi.comp_f, karoubiWhiskerLeft_f] + associativity X Y Z := by + apply Karoubi.hom_ext + simp [Karoubi.comp_f, karoubiWhiskerRight_f, karoubiWhiskerLeft_f, + karoubiAssociator_hom_f, karoubiTensorObj_X] + oplax_associativity X Y Z := by + apply Karoubi.hom_ext + simp [Karoubi.comp_f, karoubiWhiskerRight_f, karoubiWhiskerLeft_f, + karoubiAssociator_hom_f, karoubiTensorObj_X] + left_unitality X := by + apply Karoubi.hom_ext + simp [Karoubi.comp_f, karoubiLeftUnitor_hom_f, karoubiTensorUnit_X] + right_unitality X := by + apply Karoubi.hom_ext + simp [Karoubi.comp_f, karoubiRightUnitor_hom_f, karoubiTensorUnit_X] + oplax_left_unitality X := by + apply Karoubi.hom_ext + simp [Karoubi.comp_f, karoubiLeftUnitor_inv_f, karoubiTensorUnit_X] + oplax_right_unitality X := by + apply Karoubi.hom_ext + simp [Karoubi.comp_f, karoubiRightUnitor_inv_f, karoubiTensorUnit_X] + +/-! ### Braided and symmetric structure on `Karoubi C` + +When `C` carries a braided (resp. symmetric) monoidal structure, so does +`Karoubi C`. The braiding on `Karoubi C` has underlying morphism +`(p ⊗ₘ q) ≫ (β_ A B).hom`, conjugating the braiding of `C` by the +tensor of idempotents. -/ + +section Braided + +/-- Naturality of the C braiding with respect to the idempotents. -/ +private theorem braid_nat + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] + (X Y : Karoubi C) : + (X.p ⊗ₘ Y.p) ≫ (β_ X.X Y.X).hom = (β_ X.X Y.X).hom ≫ (Y.p ⊗ₘ X.p) := + BraidedCategory.braiding_naturality X.p Y.p + +private theorem braid_inv_nat + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] + (X Y : Karoubi C) : + (Y.p ⊗ₘ X.p) ≫ (β_ X.X Y.X).inv = (β_ X.X Y.X).inv ≫ (X.p ⊗ₘ Y.p) := by + rw [← cancel_mono (β_ X.X Y.X).hom, assoc, Iso.inv_hom_id, comp_id, + assoc, braid_nat, ← assoc, Iso.inv_hom_id, id_comp] + +/-- The braiding isomorphism on Karoubi objects, defined prior to the instance +so that simp lemmas for the `.f` projection are available inside the axiom +proofs. -/ +noncomputable def karoubiBraidingIso + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] + (X Y : Karoubi C) : + tensorObj X Y ≅ tensorObj Y X where + hom := ⟨(X.p ⊗ₘ Y.p) ≫ (β_ X.X Y.X).hom, + by exact (conj_comm _ _ + (tensorHom_idem X.idem Y.idem) + (tensorHom_idem Y.idem X.idem) + _ (braid_nat X Y))⟩ + inv := ⟨(Y.p ⊗ₘ X.p) ≫ (β_ X.X Y.X).inv, + by exact (conj_comm _ _ + (tensorHom_idem Y.idem X.idem) + (tensorHom_idem X.idem Y.idem) + _ (braid_inv_nat X Y))⟩ + hom_inv_id := by + apply Karoubi.hom_ext; simp only [Karoubi.comp_f, Karoubi.id_f] + exact conj_iso_hom_inv _ _ + (tensorHom_idem X.idem Y.idem) _ (braid_nat X Y) + inv_hom_id := by + apply Karoubi.hom_ext; simp only [Karoubi.comp_f, Karoubi.id_f] + exact conj_iso_inv_hom _ _ + (tensorHom_idem Y.idem X.idem) _ (braid_nat X Y) + +@[simp] private theorem karoubiBraidingIso_hom_f + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] + (X Y : Karoubi C) : + (karoubiBraidingIso X Y).hom.f = (X.p ⊗ₘ Y.p) ≫ (β_ X.X Y.X).hom := rfl + +@[simp] private theorem karoubiBraidingIso_inv_f + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] + (X Y : Karoubi C) : + (karoubiBraidingIso X Y).inv.f = (Y.p ⊗ₘ X.p) ≫ (β_ X.X Y.X).inv := rfl + +/-- Bridge lemma: the C hexagon_forward stated in `tensorHom` form. -/ +@[reassoc] private theorem tensorHom_hexagon_forward_eq + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] + (X Y Z : C) : + (α_ X Y Z).hom ≫ (β_ X (Y ⊗ Z)).hom ≫ (α_ Y Z X).hom = + ((β_ X Y).hom ⊗ₘ 𝟙 Z) ≫ (α_ Y X Z).hom ≫ (𝟙 Y ⊗ₘ (β_ X Z).hom) := by + rw [id_tensorHom, tensorHom_id]; exact BraidedCategory.hexagon_forward X Y Z + +/-- Bridge lemma: the C hexagon_reverse stated in `tensorHom` form. -/ +@[reassoc] private theorem tensorHom_hexagon_reverse_eq + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] + (X Y Z : C) : + (α_ X Y Z).inv ≫ (β_ (X ⊗ Y) Z).hom ≫ (α_ Z X Y).inv = + (𝟙 X ⊗ₘ (β_ Y Z).hom) ≫ (α_ X Z Y).inv ≫ ((β_ X Z).hom ⊗ₘ 𝟙 Y) := by + rw [id_tensorHom, tensorHom_id]; exact BraidedCategory.hexagon_reverse X Y Z + +-- Naturality on both sides and both hexagons +-- elaborate together, each conjugating the ambient braiding. +/-- A braiding on the ambient category conjugates to one on the +envelope. -/ +noncomputable instance karoubiBraided + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] : + BraidedCategory (Karoubi C) where + braiding := karoubiBraidingIso + -- ═══════ NATURALITY ═══════ + braiding_naturality_right X {Y Z} f := by + apply Karoubi.hom_ext + simp only [Karoubi.comp_f, karoubiWhiskerLeft_f, karoubiWhiskerRight_f, + karoubiBraidingIso_hom_f] + rw [assoc, ← assoc (X.p ⊗ₘ f.f), tensorHom_comp_tensorHom, X.idem, + Karoubi.comp_p, + BraidedCategory.braiding_naturality, + ← assoc (X.p ⊗ₘ Y.p), braid_nat X Y, assoc] + congr 1 + rw [tensorHom_comp_tensorHom, Karoubi.p_comp, X.idem] + braiding_naturality_left {X Y} f Z := by + apply Karoubi.hom_ext + simp only [Karoubi.comp_f, karoubiWhiskerLeft_f, karoubiWhiskerRight_f, + karoubiBraidingIso_hom_f] + rw [assoc, ← assoc (f.f ⊗ₘ Z.p), tensorHom_comp_tensorHom, Karoubi.comp_p, + Z.idem, + BraidedCategory.braiding_naturality, + ← assoc (X.p ⊗ₘ Z.p), braid_nat X Z, assoc] + congr 1 + rw [tensorHom_comp_tensorHom, Z.idem, Karoubi.p_comp] + -- ═══════ THE FORWARD HEXAGON ═══════ + hexagon_forward X Y Z := by + apply Karoubi.hom_ext + simp only [Karoubi.comp_f, karoubiWhiskerLeft_f, karoubiWhiskerRight_f, + karoubiAssociator_hom_f, karoubiBraidingIso_hom_f, + karoubiTensorObj_p, karoubiTensorObj_X] + -- Decompose compositions inside ⊗ₘ on the RHS. + rw [tensorHom_comp_left_idem_right _ _ Z.idem, + tensorHom_idem_left_comp_right _ Y.idem] + simp only [assoc] + -- LHS: absorb idempotents through structural morphisms. + rw [associator_naturality_assoc X.p Y.p Z.p] + have h1 : ∀ {E : C} (h : X.X ⊗ (Y.X ⊗ Z.X) ⟶ E), + (X.p ⊗ₘ (Y.p ⊗ₘ Z.p)) ≫ ((X.p ⊗ₘ (Y.p ⊗ₘ Z.p)) ≫ h) = + (X.p ⊗ₘ (Y.p ⊗ₘ Z.p)) ≫ h := by + intro E h + rw [← assoc, tensorHom_idem X.idem (tensorHom_idem Y.idem Z.idem)] + rw [h1] + rw [BraidedCategory.braiding_naturality_assoc X.p (Y.p ⊗ₘ Z.p)] + have h2 : ∀ {E : C} (h : (Y.X ⊗ Z.X) ⊗ X.X ⟶ E), + ((Y.p ⊗ₘ Z.p) ⊗ₘ X.p) ≫ (((Y.p ⊗ₘ Z.p) ⊗ₘ X.p) ≫ h) = + ((Y.p ⊗ₘ Z.p) ⊗ₘ X.p) ≫ h := by + intro E h + rw [← assoc, tensorHom_idem (tensorHom_idem Y.idem Z.idem) X.idem] + rw [h2, associator_naturality Y.p Z.p X.p] + -- LHS is now: C_hexagon_LHS ≫ (Y.p ⊗ₘ (Z.p ⊗ₘ X.p)). Apply C hexagon. + rw [tensorHom_hexagon_forward_eq_assoc] + -- Goal: (β ⊗ 𝟙) ≫ α ≫ (𝟙 ⊗ β) ≫ (Y.p ⊗ (Z.p ⊗ X.p)) = + -- (p ⊗ p) ⊗ p ≫ (β ⊗ p) ≫ (p ⊗ p) ⊗ p ≫ α ≫ Y.p ⊗ (p ⊗ p) ≫ Y.p ⊗ β + -- RHS: replace first 2 terms with (β ⊗ 𝟙) ≫ (p ⊗ p) ⊗ p. + have rhs_pre : + ((X.p ⊗ₘ Y.p) ⊗ₘ Z.p) ≫ ((β_ X.X Y.X).hom ⊗ₘ Z.p) = + ((β_ X.X Y.X).hom ⊗ₘ 𝟙 Z.X) ≫ ((Y.p ⊗ₘ X.p) ⊗ₘ Z.p) := by + rw [tensorHom_comp_tensorHom, tensorHom_comp_tensorHom] + congr 1 + · exact braid_nat X Y + · rw [Z.idem, id_comp] + rw [← assoc ((X.p ⊗ₘ Y.p) ⊗ₘ Z.p), rhs_pre, assoc] + -- Absorb duplicate idempotent. + have h3 : ∀ {E : C} (h : (Y.X ⊗ X.X) ⊗ Z.X ⟶ E), + ((Y.p ⊗ₘ X.p) ⊗ₘ Z.p) ≫ (((Y.p ⊗ₘ X.p) ⊗ₘ Z.p) ≫ h) = + ((Y.p ⊗ₘ X.p) ⊗ₘ Z.p) ≫ h := by + intro E h + rw [← assoc, tensorHom_idem (tensorHom_idem Y.idem X.idem) Z.idem] + rw [h3] + -- Move idempotent past associator. + rw [associator_naturality_assoc Y.p X.p Z.p] + -- Absorb duplicate idempotent. + have h4 : ∀ {E : C} (h : Y.X ⊗ (X.X ⊗ Z.X) ⟶ E), + (Y.p ⊗ₘ (X.p ⊗ₘ Z.p)) ≫ ((Y.p ⊗ₘ (X.p ⊗ₘ Z.p)) ≫ h) = + (Y.p ⊗ₘ (X.p ⊗ₘ Z.p)) ≫ h := by + intro E h + rw [← assoc, tensorHom_idem Y.idem (tensorHom_idem X.idem Z.idem)] + rw [h4] + -- Replace last 2 terms with (𝟙 ⊗ β) ≫ (Y.p ⊗ (Z.p ⊗ X.p)). + have rhs_suf : + (Y.p ⊗ₘ (X.p ⊗ₘ Z.p)) ≫ (Y.p ⊗ₘ (β_ X.X Z.X).hom) = + (𝟙 Y.X ⊗ₘ (β_ X.X Z.X).hom) ≫ (Y.p ⊗ₘ (Z.p ⊗ₘ X.p)) := by + rw [tensorHom_comp_tensorHom, tensorHom_comp_tensorHom] + congr 1 + · rw [Y.idem, id_comp] + · exact BraidedCategory.braiding_naturality X.p Z.p + rw [rhs_suf] + -- ═══════ THE REVERSE HEXAGON ═══════ + hexagon_reverse X Y Z := by + apply Karoubi.hom_ext + simp only [Karoubi.comp_f, karoubiWhiskerLeft_f, karoubiWhiskerRight_f, + karoubiAssociator_inv_f, karoubiBraidingIso_hom_f, + karoubiTensorObj_p, karoubiTensorObj_X] + -- Decompose compositions inside ⊗ₘ on the RHS. + rw [tensorHom_idem_left_comp_right _ X.idem, + tensorHom_comp_left_idem_right _ _ Y.idem] + simp only [assoc] + -- LHS: absorb idempotents through structural morphisms. + rw [associator_inv_naturality_assoc X.p Y.p Z.p] + have h1 : ∀ {E : C} (h : (X.X ⊗ Y.X) ⊗ Z.X ⟶ E), + ((X.p ⊗ₘ Y.p) ⊗ₘ Z.p) ≫ (((X.p ⊗ₘ Y.p) ⊗ₘ Z.p) ≫ h) = + ((X.p ⊗ₘ Y.p) ⊗ₘ Z.p) ≫ h := by + intro E h + rw [← assoc, tensorHom_idem (tensorHom_idem X.idem Y.idem) Z.idem] + rw [h1] + rw [BraidedCategory.braiding_naturality_assoc (X.p ⊗ₘ Y.p) Z.p] + have h2 : ∀ {E : C} (h : Z.X ⊗ (X.X ⊗ Y.X) ⟶ E), + (Z.p ⊗ₘ (X.p ⊗ₘ Y.p)) ≫ ((Z.p ⊗ₘ (X.p ⊗ₘ Y.p)) ≫ h) = + (Z.p ⊗ₘ (X.p ⊗ₘ Y.p)) ≫ h := by + intro E h + rw [← assoc, tensorHom_idem Z.idem (tensorHom_idem X.idem Y.idem)] + rw [h2, associator_inv_naturality Z.p X.p Y.p] + -- LHS is now: C_hexagon_reverse_LHS ≫ ((Z.p ⊗ₘ X.p) ⊗ₘ Y.p). Apply C + -- hexagon. + rw [tensorHom_hexagon_reverse_eq_assoc] + -- Goal: (𝟙 ⊗ β) ≫ α.inv ≫ (β ⊗ 𝟙) ≫ ((Z.p ⊗ X.p) ⊗ Y.p) = + -- X.p ⊗ (p ⊗ p) ≫ X.p ⊗ β ≫ X.p ⊗ (p ⊗ p) ≫ α.inv ≫ (p ⊗ p) ⊗ Y.p ≫ β ⊗ Y.p + -- RHS: replace first 2 terms with (𝟙 ⊗ β) ≫ X.p ⊗ (Z.p ⊗ Y.p). + have rhs_pre : + (X.p ⊗ₘ (Y.p ⊗ₘ Z.p)) ≫ (X.p ⊗ₘ (β_ Y.X Z.X).hom) = + (𝟙 X.X ⊗ₘ (β_ Y.X Z.X).hom) ≫ (X.p ⊗ₘ (Z.p ⊗ₘ Y.p)) := by + rw [tensorHom_comp_tensorHom, tensorHom_comp_tensorHom] + congr 1 + · rw [X.idem, id_comp] + · exact BraidedCategory.braiding_naturality Y.p Z.p + rw [← assoc (X.p ⊗ₘ (Y.p ⊗ₘ Z.p)), rhs_pre, assoc] + -- Absorb duplicate idempotent. + have h3 : ∀ {E : C} (h : X.X ⊗ (Z.X ⊗ Y.X) ⟶ E), + (X.p ⊗ₘ (Z.p ⊗ₘ Y.p)) ≫ ((X.p ⊗ₘ (Z.p ⊗ₘ Y.p)) ≫ h) = + (X.p ⊗ₘ (Z.p ⊗ₘ Y.p)) ≫ h := by + intro E h + rw [← assoc, tensorHom_idem X.idem (tensorHom_idem Z.idem Y.idem)] + rw [h3] + -- Move idempotent past associator inverse. + rw [associator_inv_naturality_assoc X.p Z.p Y.p] + -- Absorb duplicate idempotent. + have h4 : ∀ {E : C} (h : (X.X ⊗ Z.X) ⊗ Y.X ⟶ E), + ((X.p ⊗ₘ Z.p) ⊗ₘ Y.p) ≫ (((X.p ⊗ₘ Z.p) ⊗ₘ Y.p) ≫ h) = + ((X.p ⊗ₘ Z.p) ⊗ₘ Y.p) ≫ h := by + intro E h + rw [← assoc, tensorHom_idem (tensorHom_idem X.idem Z.idem) Y.idem] + rw [h4] + -- Replace last 2 terms with (β ⊗ 𝟙) ≫ ((Z.p ⊗ X.p) ⊗ Y.p). + have rhs_suf : + ((X.p ⊗ₘ Z.p) ⊗ₘ Y.p) ≫ ((β_ X.X Z.X).hom ⊗ₘ Y.p) = + ((β_ X.X Z.X).hom ⊗ₘ 𝟙 Y.X) ≫ ((Z.p ⊗ₘ X.p) ⊗ₘ Y.p) := by + rw [tensorHom_comp_tensorHom, tensorHom_comp_tensorHom] + congr 1 + · exact BraidedCategory.braiding_naturality X.p Z.p + · rw [Y.idem, id_comp] + rw [rhs_suf] + +@[simp] private theorem karoubiBraiding_hom_f + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] + (X Y : Karoubi C) : + (β_ X Y).hom.f = (X.p ⊗ₘ Y.p) ≫ (β_ X.X Y.X).hom := rfl + +@[simp] private theorem karoubiBraiding_inv_f + [Category.{v} C] [MonoidalCategory C] [BraidedCategory C] + (X Y : Karoubi C) : + (β_ X Y).inv.f = (Y.p ⊗ₘ X.p) ≫ (β_ X.X Y.X).inv := rfl + +end Braided + +section Symmetric + +/-- And a symmetric one stays symmetric. -/ +noncomputable instance karoubiSymmetric + [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] : + SymmetricCategory (Karoubi C) where + symmetry X Y := by + apply Karoubi.hom_ext + simp only [Karoubi.comp_f, Karoubi.id_f, karoubiBraiding_hom_f, + karoubiTensorObj_p, assoc] + rw [← assoc (X.p ⊗ₘ Y.p), braid_nat X Y, assoc] + have h : ∀ {E : C} (h : Y.X ⊗ X.X ⟶ E), + (Y.p ⊗ₘ X.p) ≫ ((Y.p ⊗ₘ X.p) ≫ h) = (Y.p ⊗ₘ X.p) ≫ h := by + intro E h; rw [← assoc, tensorHom_idem Y.idem X.idem] + rw [h, braid_nat Y X, ← assoc, SymmetricCategory.symmetry, id_comp] + +end Symmetric + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiRigid.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiRigid.lean new file mode 100644 index 0000000000..8eec1c8969 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiRigid.lean @@ -0,0 +1,322 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiMonoidal + +/-! +# Rigidity of the Karoubi envelope + +For a right rigid monoidal category `C`, the Karoubi envelope is +right rigid: the dual of an idempotent `(X, p)` is `(Xᘁ, pᘁ)`, +the adjoint mate of `p` being idempotent by contravariant +functoriality of the mate. The coevaluation and evaluation are +the idempotent-corrected cup and cap; the snake identities reduce +to the base category's by sliding the idempotents around the cup +and cap — the first collapses onto the defining formula of the +adjoint mate, the second onto the base snake identity. + +When `C` is moreover braided, `Karoubi C` is rigid. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Category CategoryTheory.Idempotents +open CategoryTheory.MonoidalCategory + +universe v u + +variable {C : Type u} + +/-! ### Componentwise access to the Karoubi monoidal data -/ + +private theorem kwl_f [Category.{v} C] [MonoidalCategory C] + (P : Karoubi C) {Q R : Karoubi C} + (g : Q ⟶ R) : (P ◁ g).f = P.p ⊗ₘ g.f := rfl + +private theorem kwr_f [Category.{v} C] [MonoidalCategory C] + {Q R : Karoubi C} (g : Q ⟶ R) + (P : Karoubi C) : (g ▷ P).f = g.f ⊗ₘ P.p := rfl + +private theorem kassoc_inv_f [Category.{v} C] [MonoidalCategory C] + (P Q R : Karoubi C) : + (α_ P Q R).inv.f = + (P.p ⊗ₘ (Q.p ⊗ₘ R.p)) ≫ (α_ P.X Q.X R.X).inv := rfl + +private theorem kassoc_hom_f [Category.{v} C] [MonoidalCategory C] + (P Q R : Karoubi C) : + (α_ P Q R).hom.f = + ((P.p ⊗ₘ Q.p) ⊗ₘ R.p) ≫ (α_ P.X Q.X R.X).hom := rfl + +private theorem krho_hom_f [Category.{v} C] [MonoidalCategory C] + (P : Karoubi C) : + (ρ_ P).hom.f = (P.p ⊗ₘ 𝟙 (𝟙_ C)) ≫ (ρ_ P.X).hom := rfl + +private theorem krho_inv_f [Category.{v} C] [MonoidalCategory C] + (P : Karoubi C) : + (ρ_ P).inv.f = P.p ≫ (ρ_ P.X).inv := rfl + +private theorem klam_hom_f [Category.{v} C] [MonoidalCategory C] + (P : Karoubi C) : + (λ_ P).hom.f = (𝟙 (𝟙_ C) ⊗ₘ P.p) ≫ (λ_ P.X).hom := rfl + +private theorem klam_inv_f [Category.{v} C] [MonoidalCategory C] + (P : Karoubi C) : + (λ_ P).inv.f = P.p ≫ (λ_ P.X).inv := rfl + +/-! ### The dual idempotent -/ + +/-- The adjoint mate of an idempotent is idempotent. -/ +theorem mate_idem [Category.{v} C] [MonoidalCategory C] [RightRigidCategory C] + (P : Karoubi C) : + (P.p)ᘁ ≫ (P.p)ᘁ = (P.p)ᘁ := by + rw [← comp_rightAdjointMate, P.idem] + +/-- The right dual object in the Karoubi envelope. -/ +noncomputable def karoubiRightDualObj + [Category.{v} C] [MonoidalCategory C] [RightRigidCategory C] + (P : Karoubi C) : + Karoubi C := + ⟨(P.X)ᘁ, (P.p)ᘁ, mate_idem P⟩ + +/-! ### Cup and cap absorption -/ + +/-- The corrected coevaluation absorbs into a single whisker on +the dual leg. -/ +theorem coev_corr_left + [Category.{v} C] [MonoidalCategory C] [RightRigidCategory C] + (P : Karoubi C) : + η_ P.X (P.X)ᘁ ≫ (P.p ⊗ₘ (P.p)ᘁ) = + η_ P.X (P.X)ᘁ ≫ P.X ◁ (P.p)ᘁ := by + rw [tensorHom_def, ← assoc, ← coevaluation_comp_rightAdjointMate, + assoc, ← MonoidalCategory.whiskerLeft_comp, mate_idem] + +/-- The corrected coevaluation absorbs into a single whisker on +the primal leg. -/ +theorem coev_corr_right + [Category.{v} C] [MonoidalCategory C] [RightRigidCategory C] + (P : Karoubi C) : + η_ P.X (P.X)ᘁ ≫ (P.p ⊗ₘ (P.p)ᘁ) = + η_ P.X (P.X)ᘁ ≫ P.p ▷ (P.X)ᘁ := by + rw [coev_corr_left, coevaluation_comp_rightAdjointMate] + +/-- The corrected evaluation absorbs into a single whisker on the +primal leg. -/ +theorem ev_corr_left + [Category.{v} C] [MonoidalCategory C] [RightRigidCategory C] + (P : Karoubi C) : + ((P.p)ᘁ ⊗ₘ P.p) ≫ ε_ P.X (P.X)ᘁ = + (P.X)ᘁ ◁ P.p ≫ ε_ P.X (P.X)ᘁ := by + rw [tensorHom_def, assoc, ← rightAdjointMate_comp_evaluation, + ← assoc, ← comp_whiskerRight, mate_idem, + rightAdjointMate_comp_evaluation] + +/-- The corrected evaluation absorbs into a single whisker on the +dual leg. -/ +theorem ev_corr_right + [Category.{v} C] [MonoidalCategory C] [RightRigidCategory C] + (P : Karoubi C) : + ((P.p)ᘁ ⊗ₘ P.p) ≫ ε_ P.X (P.X)ᘁ = + (P.p)ᘁ ▷ P.X ≫ ε_ P.X (P.X)ᘁ := by + rw [ev_corr_left, ← rightAdjointMate_comp_evaluation] + +/-- The corrected coevaluation is stable under the correction. -/ +theorem coev_corr_idem + [Category.{v} C] [MonoidalCategory C] [RightRigidCategory C] + (P : Karoubi C) : + (η_ P.X (P.X)ᘁ ≫ (P.p ⊗ₘ (P.p)ᘁ)) ≫ (P.p ⊗ₘ (P.p)ᘁ) = + η_ P.X (P.X)ᘁ ≫ (P.p ⊗ₘ (P.p)ᘁ) := by + rw [assoc, tensorHom_comp_tensorHom, P.idem, mate_idem] + +/-- The corrected evaluation is stable under the correction. -/ +theorem ev_corr_idem + [Category.{v} C] [MonoidalCategory C] [RightRigidCategory C] + (P : Karoubi C) : + ((P.p)ᘁ ⊗ₘ P.p) ≫ (((P.p)ᘁ ⊗ₘ P.p) ≫ ε_ P.X (P.X)ᘁ) = + ((P.p)ᘁ ⊗ₘ P.p) ≫ ε_ P.X (P.X)ᘁ := by + rw [← assoc, tensorHom_comp_tensorHom, P.idem, mate_idem] + +/-! ### The snake identities, componentwise -/ + +/-- **The first snake** in the base category, with corrections: +collapses onto the defining formula of the adjoint mate. -/ +theorem karoubi_snake_one + [Category.{v} C] [MonoidalCategory C] [RightRigidCategory C] + (P : Karoubi C) : + ((P.p)ᘁ ⊗ₘ (η_ P.X (P.X)ᘁ ≫ (P.p ⊗ₘ (P.p)ᘁ))) ≫ + (((P.p)ᘁ ⊗ₘ (P.p ⊗ₘ (P.p)ᘁ)) ≫ + (α_ (P.X)ᘁ P.X (P.X)ᘁ).inv) ≫ + ((((P.p)ᘁ ⊗ₘ P.p) ≫ ε_ P.X (P.X)ᘁ) ⊗ₘ (P.p)ᘁ) = + (((P.p)ᘁ ⊗ₘ 𝟙 (𝟙_ C)) ≫ (ρ_ (P.X)ᘁ).hom) ≫ + ((P.p)ᘁ ≫ (λ_ (P.X)ᘁ).inv) := by + simp only [assoc] + -- Merge the first two factors, absorbing the doubled + -- correction. + slice_lhs 1 2 => + rw [tensorHom_comp_tensorHom, mate_idem, coev_corr_idem] + -- Single-whisker forms of the cup and cap. + rw [coev_corr_left, ev_corr_right] + -- Decompose the tensors into whiskers. + rw [tensorHom_def' ((P.p)ᘁ) + (η_ P.X (P.X)ᘁ ≫ P.X ◁ (P.p)ᘁ), + tensorHom_def ((P.p)ᘁ ▷ P.X ≫ ε_ P.X (P.X)ᘁ) ((P.p)ᘁ), + MonoidalCategory.whiskerLeft_comp, comp_whiskerRight] + simp only [assoc] + -- Chain: Xᘁ◁η ∘ Xᘁ◁(X◁d) ∘ d▷(X⊗Xᘁ) ∘ α⁻¹ ∘ (d▷X)▷Xᘁ + -- ∘ ε▷Xᘁ ∘ 𝟙◁d. + slice_lhs 3 4 => rw [associator_inv_naturality_left] + slice_lhs 4 5 => + rw [← comp_whiskerRight, ← comp_whiskerRight, mate_idem] + slice_lhs 4 5 => + rw [← comp_whiskerRight, rightAdjointMate_comp_evaluation, + comp_whiskerRight] + slice_lhs 2 3 => rw [associator_inv_naturality_right] + slice_lhs 3 4 => rw [whisker_exchange] + slice_lhs 4 5 => rw [whisker_exchange] + slice_lhs 5 6 => + rw [← MonoidalCategory.whiskerLeft_comp, mate_idem] + slice_lhs 2 3 => rw [← associator_inv_naturality_middle] + -- The first four factors are the mate's defining composite. + have hmate : (P.p)ᘁ = + (ρ_ ((P.X)ᘁ)).inv ≫ ((P.X)ᘁ ◁ η_ P.X (P.X)ᘁ) ≫ + ((P.X)ᘁ ◁ P.p ▷ (P.X)ᘁ) ≫ + (α_ ((P.X)ᘁ) P.X ((P.X)ᘁ)).inv ≫ + (ε_ P.X (P.X)ᘁ ▷ (P.X)ᘁ) ≫ (λ_ ((P.X)ᘁ)).hom := rfl + have hS : ((P.X)ᘁ ◁ η_ P.X (P.X)ᘁ) ≫ + ((P.X)ᘁ ◁ P.p ▷ (P.X)ᘁ) ≫ + (α_ ((P.X)ᘁ) P.X ((P.X)ᘁ)).inv ≫ + (ε_ P.X (P.X)ᘁ ▷ (P.X)ᘁ) = + (ρ_ ((P.X)ᘁ)).hom ≫ (P.p)ᘁ ≫ (λ_ ((P.X)ᘁ)).inv := by + conv_rhs => rw [hmate] + simp + simp only [assoc] + rw [reassoc_of% hS] + -- Fold the trailing unit-side whisker into the mate. + rw [← leftUnitor_inv_naturality] + slice_lhs 2 3 => rw [mate_idem] + -- Normalize the right-hand side. + rw [tensorHom_id] + slice_rhs 1 2 => rw [rightUnitor_naturality] + slice_rhs 2 3 => rw [mate_idem] + +/-- **The second snake** in the base category, with corrections: +collapses onto the base snake identity. -/ +theorem karoubi_snake_two + [Category.{v} C] [MonoidalCategory C] [RightRigidCategory C] + (P : Karoubi C) : + ((η_ P.X (P.X)ᘁ ≫ (P.p ⊗ₘ (P.p)ᘁ)) ⊗ₘ P.p) ≫ + (((P.p ⊗ₘ (P.p)ᘁ) ⊗ₘ P.p) ≫ + (α_ P.X (P.X)ᘁ P.X).hom) ≫ + (P.p ⊗ₘ (((P.p)ᘁ ⊗ₘ P.p) ≫ ε_ P.X (P.X)ᘁ)) = + ((𝟙 (𝟙_ C) ⊗ₘ P.p) ≫ (λ_ P.X).hom) ≫ + (P.p ≫ (ρ_ P.X).inv) := by + simp only [assoc] + -- Merge the first two factors, absorbing the doubled + -- correction. + slice_lhs 1 2 => + rw [tensorHom_comp_tensorHom, P.idem, coev_corr_idem] + -- Single-whisker forms of the cup and cap. + rw [coev_corr_right, ev_corr_left] + -- Decompose the tensors into whiskers. + rw [tensorHom_def (η_ P.X (P.X)ᘁ ≫ P.p ▷ (P.X)ᘁ) P.p, + tensorHom_def' P.p + ((P.X)ᘁ ◁ P.p ≫ ε_ P.X (P.X)ᘁ), + comp_whiskerRight, MonoidalCategory.whiskerLeft_comp] + simp only [assoc] + -- Chain: η▷X ∘ (p▷Xᘁ)▷X ∘ (X⊗Xᘁ)◁p ∘ α ∘ p▷(Xᘁ⊗X) + -- ∘ X◁(Xᘁ◁p) ∘ X◁ε. + slice_lhs 3 4 => rw [associator_naturality_right] + slice_lhs 4 5 => + rw [← MonoidalCategory.whiskerLeft_comp, + ← MonoidalCategory.whiskerLeft_comp, P.idem] + -- Trade the cup correction to the dual leg. + slice_lhs 1 2 => + rw [← comp_whiskerRight, ← coev_corr_right, coev_corr_left, + comp_whiskerRight] + slice_lhs 2 3 => rw [associator_naturality_middle] + -- Absorb the doubled mate into the cap. + slice_lhs 4 5 => + rw [← MonoidalCategory.whiskerLeft_comp, + ← rightAdjointMate_comp_evaluation] + slice_lhs 3 4 => + rw [← MonoidalCategory.whiskerLeft_comp, ← assoc, + ← comp_whiskerRight, mate_idem] + rw [rightAdjointMate_comp_evaluation, + MonoidalCategory.whiskerLeft_comp] + simp only [assoc] + -- Slide the cap correction out to the unit edge. + slice_lhs 2 3 => rw [← associator_naturality_right] + slice_lhs 1 2 => rw [← whisker_exchange] + -- The base snake finishes. + slice_lhs 2 4 => rw [ExactPairing.evaluation_coevaluation] + slice_lhs 1 2 => rw [leftUnitor_naturality] + slice_lhs 3 4 => rw [← rightUnitor_inv_naturality] + slice_lhs 2 3 => rw [P.idem] + -- Normalize the right-hand side. + rw [id_tensorHom] + slice_rhs 1 2 => rw [leftUnitor_naturality] + slice_rhs 2 3 => rw [P.idem] + +/-! ### The exact pairing and rigidity -/ + +/-- The exact pairing between an idempotent and its mate dual. -/ +@[instance_reducible] +noncomputable def karoubiExactPairing + [Category.{v} C] [MonoidalCategory C] [RightRigidCategory C] + (P : Karoubi C) : + ExactPairing P (karoubiRightDualObj P) where + coevaluation' := + ⟨η_ P.X (P.X)ᘁ ≫ (P.p ⊗ₘ (P.p)ᘁ), by + change 𝟙 (𝟙_ C) ≫ (η_ P.X (P.X)ᘁ ≫ (P.p ⊗ₘ (P.p)ᘁ)) ≫ + (P.p ⊗ₘ (P.p)ᘁ) = + η_ P.X (P.X)ᘁ ≫ (P.p ⊗ₘ (P.p)ᘁ) + rw [id_comp] + exact coev_corr_idem P⟩ + evaluation' := + ⟨((P.p)ᘁ ⊗ₘ P.p) ≫ ε_ P.X (P.X)ᘁ, by + change ((P.p)ᘁ ⊗ₘ P.p) ≫ + ((((P.p)ᘁ ⊗ₘ P.p) ≫ ε_ P.X (P.X)ᘁ) ≫ 𝟙 (𝟙_ C)) = + ((P.p)ᘁ ⊗ₘ P.p) ≫ ε_ P.X (P.X)ᘁ + rw [comp_id] + exact ev_corr_idem P⟩ + coevaluation_evaluation' := by + apply Karoubi.hom_ext + simp only [Karoubi.comp_f] + rw [kwl_f, kwr_f, kassoc_inv_f, krho_hom_f, klam_inv_f] + exact karoubi_snake_one P + evaluation_coevaluation' := by + apply Karoubi.hom_ext + simp only [Karoubi.comp_f] + rw [kwr_f, kwl_f, kassoc_hom_f, klam_hom_f, krho_inv_f] + exact karoubi_snake_two P + +/-- Every Karoubi object has a right dual: the ambient dual, cut by +the dual idempotent. -/ +noncomputable instance karoubiHasRightDual + [Category.{v} C] [MonoidalCategory C] [RightRigidCategory C] + (P : Karoubi C) : + HasRightDual P where + rightDual := karoubiRightDualObj P + exact := karoubiExactPairing P + +/-- **The Karoubi envelope of a right rigid category is right +rigid.** -/ +noncomputable instance karoubiRightRigid + [Category.{v} C] [MonoidalCategory C] [RightRigidCategory C] : + RightRigidCategory (Karoubi C) where + +/-- **The Karoubi envelope of a braided right rigid category is +rigid.** -/ +noncomputable instance karoubiRigid + [Category.{v} C] [MonoidalCategory C] [RightRigidCategory C] + [BraidedCategory C] : + RigidCategory (Karoubi C) := + BraidedCategory.rigidCategoryOfRightRigidCategory + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiSemisimple.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiSemisimple.lean new file mode 100644 index 0000000000..36118054de --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiSemisimple.lean @@ -0,0 +1,124 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.KaroubiTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleAll +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactorialTrace + +/-! +# Semisimplicity of Karoubi endomorphism algebras + +The endomorphism algebra of any object of the Karoubi envelope of +the skein category is a corner `e·End(n)·e`, and the trace +criterion restricts: corner-nilpotents are ambient-nilpotents, and +cyclicity moves the idempotent across products, so ambient +nondegeneracy restricts to the corner. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Idempotents + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-! ### The endomorphism algebras of Karoubi objects -/ + +variable (X : Karoubi (SkeinObj f)) + +/-- Endomorphisms of a Karoubi object form a ring. -/ +noncomputable instance karoubiEndRing : Ring (End X) := + inferInstance + +/-- And a ℂ-algebra — the corner `e·End(n)·e`. -/ +noncomputable instance karoubiEndAlgebra : Algebra ℂ (End X) := + inferInstance + +/-- Finite-dimensional, as a subspace of the ambient skein +endomorphisms. -/ +noncomputable instance karoubiEndFinite : + FiniteDimensional ℂ (End X) := + FiniteDimensional.of_injective + (show End X →ₗ[ℂ] skeinEnd f X.X.arity from + karoubiHomLinearMap X X) + (fun _ _ h => Karoubi.Hom.ext h) + +/-- The corner trace criterion, given nilpotent-trace vanishing +in the ambient strand algebra. -/ +theorem karoubiEnd_isSemisimpleRing_of_nilpotent_trace + (hnil : ∀ g : skeinEnd f X.X.arity, + IsNilpotent g → skeinTrace f X.X.arity g = 0) : + IsSemisimpleRing (End X) := by + have : FiniteDimensional ℂ (End X.X) := + inferInstanceAs (FiniteDimensional ℂ (skeinEnd f X.X.arity)) + exact karoubiEnd_isSemisimpleRing_of_trace X + (HomSpace.traceMap f.val X.X.arity) hnil + (HomSpace.traceMap_comp_comm f) + (end_eq_zero_of_traces_vanish f X.X) + +/-- **Semisimplicity of Karoubi endomorphism algebras**, by the +factorial trace obstruction. -/ +theorem karoubiEnd_isSemisimpleRing : + IsSemisimpleRing (End X) := + karoubiEnd_isSemisimpleRing_of_nilpotent_trace f X + (fun _ hg => + skeinTrace_eq_zero_of_isNilpotent_factorial f X.X.arity hg) + +/-- The mainline Karoubi semisimplicity theorem, with the +factorial proof method explicit in its name. -/ +theorem karoubiEnd_isSemisimpleRing_factorial : + IsSemisimpleRing (End X) := karoubiEnd_isSemisimpleRing f X + +/-! ### Mixed-Hom nondegeneracy in the Karoubi envelope -/ + +/-- A Karoubi morphism all of whose composite traces against +reverse morphisms vanish is zero: the separation engine for the +simples. -/ +theorem karoubiHom_eq_zero_of_traces_vanish + {X Y : Karoubi (SkeinObj f)} (a : X ⟶ Y) + (ha : ∀ b : Y ⟶ X, + HomSpace.traceMap f.val X.X.arity (a.f ≫ b.f) = 0) : + a = 0 := by + apply Karoubi.hom_ext + change a.f = 0 + apply hom_eq_zero_of_traces_vanish' f X.X Y.X a.f + intro b + have hb : Y.p ≫ (Y.p ≫ b ≫ X.p) ≫ X.p = + Y.p ≫ b ≫ X.p := by + rw [show Y.p ≫ (Y.p ≫ b ≫ X.p) ≫ X.p = + (Y.p ≫ Y.p) ≫ b ≫ (X.p ≫ X.p) from by + simp only [Category.assoc]] + rw [Y.idem, X.idem] + have key := ha (⟨Y.p ≫ b ≫ X.p, hb⟩ : Y ⟶ X) + have hred : a.f ≫ (Y.p ≫ b ≫ X.p) = + (a.f ≫ b) ≫ X.p := by + rw [show a.f ≫ (Y.p ≫ b ≫ X.p) = + (a.f ≫ Y.p) ≫ b ≫ X.p from by + simp only [Category.assoc]] + rw [Karoubi.comp_p] + simp only [Category.assoc] + have hcyc := HomSpace.traceMap_comp_comm f + (t := X.X.arity) (u := X.X.arity) + (a.f ≫ b) X.p + have hfin : HomSpace.traceMap f.val X.X.arity + (X.p ≫ (a.f ≫ b)) = + HomSpace.traceMap f.val X.X.arity (a.f ≫ b) := by + rw [show X.p ≫ (a.f ≫ b) = (X.p ≫ a.f) ≫ b from by + simp only [Category.assoc]] + rw [Karoubi.p_comp] + calc HomSpace.traceMap f.val X.X.arity (a.f ≫ b) + = HomSpace.traceMap f.val X.X.arity + (X.p ≫ (a.f ≫ b)) := hfin.symm + _ = HomSpace.traceMap f.val X.X.arity + ((a.f ≫ b) ≫ X.p) := hcyc.symm + _ = HomSpace.traceMap f.val X.X.arity + (a.f ≫ (Y.p ≫ b ≫ X.p)) := by rw [hred] + _ = 0 := key + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatBraided.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatBraided.lean new file mode 100644 index 0000000000..c1556099dd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatBraided.lean @@ -0,0 +1,481 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatMonoidal + +/-! +# Braided and symmetric structure on the matrix envelope + +When `C` is a braided (resp. symmetric) monoidal preadditive category, so is +`Mat_ C`. The braiding on `Mat_ C` is a "diagonal" matrix carrying the +componentwise braidings of `C`, reindexed by the swap `M.ι × N.ι ↔ N.ι × M.ι`. +-/ + +@[expose] public section + +noncomputable section + +namespace RS + + + +open CategoryTheory CategoryTheory.Category CategoryTheory.MonoidalCategory +open CategoryTheory.Limits CategoryTheory.MonoidalPreadditive + +universe v u + +variable {C : Type u} + +/-! ### Componentwise access to the `Mat_ C` monoidal structure -/ + +@[simp] private theorem mat_whiskerLeft_apply + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (X : Mat_ C) {Y Z : Mat_ C} (f : Y + ⟶ Z) + (ix : X.ι) (iy : Y.ι) (jx : X.ι) (jz : Z.ι) : + (X ◁ f) (ix, iy) (jx, jz) = (𝟙 (X : Mat_ C)) ix jx ⊗ₘ f iy jz := rfl + +@[simp] private theorem mat_whiskerRight_apply + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + {X Y : Mat_ C} (f : X ⟶ Y) (Z : + Mat_ C) + (ix : X.ι) (iz : Z.ι) (jy : Y.ι) (jz : Z.ι) : + (f ▷ Z) (ix, iz) (jy, jz) = f ix jy ⊗ₘ (𝟙 (Z : Mat_ C)) iz jz := rfl + +@[simp] private theorem mat_tensorHom_apply + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + {M₁ N₁ M₂ N₂ : Mat_ C} + (f : M₁ ⟶ N₁) (g : M₂ ⟶ N₂) (i₁ : M₁.ι) (i₂ : M₂.ι) (j₁ : N₁.ι) (j₂ : N₂.ι) + : + (f ⊗ₘ g : M₁ ⊗ M₂ ⟶ N₁ ⊗ N₂) (i₁, i₂) (j₁, j₂) = f i₁ j₁ ⊗ₘ g i₂ j₂ := rfl + +open scoped Classical in +@[simp] private theorem mat_assocHom_apply + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M N K : Mat_ C) + (i : M.ι) (j : N.ι) (k : K.ι) (i' : M.ι) (j' : N.ι) (k' : K.ι) : + (α_ M N K).hom ((i, j), k) (i', (j', k')) = + if hi : i = i' then if hj : j = j' then if hk : k = k' then + eqToHom (by subst hi; subst hj; subst hk; rfl) ≫ (α_ (M.X i') (N.X j') + (K.X k')).hom + else 0 else 0 else 0 := rfl + +open scoped Classical in +@[simp] private theorem mat_assocInv_apply + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M N K : Mat_ C) + (i : M.ι) (j : N.ι) (k : K.ι) (i' : M.ι) (j' : N.ι) (k' : K.ι) : + (α_ M N K).inv (i, (j, k)) ((i', j'), k') = + if hi : i = i' then if hj : j = j' then if hk : k = k' then + eqToHom (by subst hi; subst hj; subst hk; rfl) ≫ (α_ (M.X i') (N.X j') + (K.X k')).inv + else 0 else 0 else 0 := rfl + +/-! ### Braiding data for `Mat_ C` -/ + +section Braided + +open scoped Classical in +/-- The matrix morphism that swaps tensor factors using the component braidings. -/ +def matBraidHom [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [BraidedCategory C] + (M N : Mat_ C) : (M ⊗ N : Mat_ C) ⟶ (N ⊗ M : Mat_ C) := + fun (i₁, i₂) (j₁, j₂) => + if hi : i₂ = j₁ then + if hj : i₁ = j₂ then + eqToHom (by subst hi; subst hj; rfl) ≫ (β_ (M.X j₂) (N.X j₁)).hom + else 0 + else 0 + +open scoped Classical in +/-- The inverse matrix morphism that swaps tensor factors by inverse braidings. -/ +def matBraidInv [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [BraidedCategory C] + (M N : Mat_ C) : (N ⊗ M : Mat_ C) ⟶ (M ⊗ N : Mat_ C) := + fun (j₁, j₂) (i₁, i₂) => + if hj₁ : j₁ = i₂ then + if hj₂ : j₂ = i₁ then + eqToHom (by subst hj₁; subst hj₂; rfl) ≫ (β_ (M.X i₁) (N.X i₂)).inv + else 0 + else 0 + +open scoped Classical in +@[simp] private theorem matBraidHom_apply + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [BraidedCategory C] + (M N : Mat_ C) + (i₁ : M.ι) (i₂ : N.ι) (j₁ : N.ι) (j₂ : M.ι) : + matBraidHom M N (i₁, i₂) (j₁, j₂) = + if hi : i₂ = j₁ then if hj : i₁ = j₂ then + eqToHom (by subst hi; subst hj; rfl) ≫ (β_ (M.X j₂) (N.X j₁)).hom + else 0 else 0 := rfl + +open scoped Classical in +@[simp] private theorem matBraidInv_apply + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [BraidedCategory C] + (M N : Mat_ C) + (j₁ : N.ι) (j₂ : M.ι) (i₁ : M.ι) (i₂ : N.ι) : + matBraidInv M N (j₁, j₂) (i₁, i₂) = + if hj₁ : j₁ = i₂ then if hj₂ : j₂ = i₁ then + eqToHom (by subst hj₁; subst hj₂; rfl) ≫ (β_ (M.X i₁) (N.X i₂)).inv + else 0 else 0 := rfl + +/-! ### Braiding iso -/ + +-- The matrix identity is checked entrywise, and +-- each entry is a sum over the intermediate index. +private theorem matBraid_hom_inv + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [BraidedCategory C] + (M N : Mat_ C) : + matBraidHom M N ≫ matBraidInv M N = 𝟙 _ := by + apply Mat_.hom_ext; intro ⟨i₁, i₂⟩ ⟨i₁', i₂'⟩ + rw [mat_comp_tensor_apply, Mat_.id_apply] + simp only [matBraidHom_apply, matBraidInv_apply] + rw [Finset.sum_eq_single_of_mem i₂ (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem i₁ (Finset.mem_univ _)] + · simp only [dite_true, eqToHom_refl, id_comp] + by_cases h₁ : i₁ = i₁' <;> by_cases h₂ : i₂ = i₂' + · subst h₁; subst h₂; simp [Iso.hom_inv_id] + · have : (i₁, i₂) ≠ (i₁', i₂') := fun h => h₂ (Prod.mk.inj h).2 + simp [h₂, this] + · have : (i₁, i₂) ≠ (i₁', i₂') := fun h => h₁ (Prod.mk.inj h).1 + simp [h₁, this] + · have : (i₁, i₂) ≠ (i₁', i₂') := fun h => h₁ (Prod.mk.inj h).1 + simp [h₂, this] + · intro b _ hb; simp [show ¬(i₁ = b) from Ne.symm hb] + · intro b _ hb; simp [show ¬(i₂ = b) from Ne.symm hb] + +-- As for the other composite. +private theorem matBraid_inv_hom + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [BraidedCategory C] + (M N : Mat_ C) : + matBraidInv M N ≫ matBraidHom M N = 𝟙 _ := by + apply Mat_.hom_ext; intro ⟨j₁, j₂⟩ ⟨j₁', j₂'⟩ + rw [mat_comp_tensor_apply, Mat_.id_apply] + simp only [matBraidInv_apply, matBraidHom_apply] + rw [Finset.sum_eq_single_of_mem j₂ (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem j₁ (Finset.mem_univ _)] + · simp only [dite_true, eqToHom_refl, id_comp] + by_cases h₁ : j₁ = j₁' <;> by_cases h₂ : j₂ = j₂' + · subst h₁; subst h₂; simp [Iso.inv_hom_id] + · have : (j₁, j₂) ≠ (j₁', j₂') := fun h => h₂ (Prod.mk.inj h).2 + simp [h₂, this] + · have : (j₁, j₂) ≠ (j₁', j₂') := fun h => h₁ (Prod.mk.inj h).1 + simp [h₁, this] + · have : (j₁, j₂) ≠ (j₁', j₂') := fun h => h₁ (Prod.mk.inj h).1 + simp [h₂, this] + · intro b _ hb; simp [show ¬(j₁ = b) from Ne.symm hb] + · intro b _ hb; simp [show ¬(j₂ = b) from Ne.symm hb] + +/-- The braiding isomorphism on matrix objects induced by the component braidings. -/ +def matBraidIso [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [BraidedCategory C] + (M N : Mat_ C) : (M ⊗ N : Mat_ C) ≅ (N ⊗ M : Mat_ C) + where + hom := matBraidHom M N + inv := matBraidInv M N + hom_inv_id := by exact matBraid_hom_inv M N + inv_hom_id := by exact matBraid_inv_hom M N + +/-! ### Braiding naturality -/ + +-- Naturality is checked entrywise, each entry a sum +-- over the intermediate index. +private theorem mat_braiding_naturality_right + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] [BraidedCategory C] + (X : Mat_ C) {Y Z : Mat_ C} + (f : Y ⟶ Z) : + X ◁ f ≫ (matBraidIso X Z).hom = (matBraidIso X Y).hom ≫ f ▷ X := by + apply Mat_.hom_ext; intro ⟨ix, iy⟩ ⟨jz, jx⟩ + rw [mat_comp_tensor_apply, mat_comp_tensor_apply] + simp only [mat_whiskerLeft_apply, mat_whiskerRight_apply, Mat_.id_apply, + matBraidIso, matBraidHom_apply] + rw [Finset.sum_eq_single_of_mem jx (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem jz (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem iy (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem ix (Finset.mem_univ _)] + · simp only [dite_true, eqToHom_refl] + by_cases hx : ix = jx + · subst hx; simp only [dite_true, eqToHom_refl, id_comp] + rw [id_tensorHom, tensorHom_id] + exact BraidedCategory.braiding_naturality_right (X.X ix) (f iy jz) + · simp [hx] + · intro b _ hb; simp [show ¬(ix = b) from Ne.symm hb] + · intro b _ hb; simp [show ¬(iy = b) from Ne.symm hb] + · intro b _ hb; simp [hb] + · intro b _ hb; simp [hb] + +-- As for the right-hand naturality. +private theorem mat_braiding_naturality_left + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] [BraidedCategory C] + {X Y : Mat_ C} (f : X ⟶ Y) + (Z : Mat_ C) : + f ▷ Z ≫ (matBraidIso Y Z).hom = (matBraidIso X Z).hom ≫ Z ◁ f := by + apply Mat_.hom_ext; intro ⟨ix, iz⟩ ⟨jz, jy⟩ + rw [mat_comp_tensor_apply, mat_comp_tensor_apply] + simp only [mat_whiskerLeft_apply, mat_whiskerRight_apply, Mat_.id_apply, + matBraidIso, matBraidHom_apply] + rw [Finset.sum_eq_single_of_mem jy (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem jz (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem iz (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem ix (Finset.mem_univ _)] + · simp only [dite_true, eqToHom_refl] + by_cases hz : iz = jz + · subst hz; simp only [dite_true, eqToHom_refl, id_comp] + rw [tensorHom_id, id_tensorHom] + exact BraidedCategory.braiding_naturality_left (f ix jy) (Z.X iz) + · simp [hz] + · intro b _ hb; simp [show ¬(ix = b) from Ne.symm hb] + · intro b _ hb; simp [show ¬(iz = b) from Ne.symm hb] + · intro b _ hb; simp [hb] + · intro b _ hb; simp [hb] + +/-! ### Hexagon identities -/ + +private theorem mat_comp3_fwd_lhs + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (X Y Z : Mat_ C) + {A E : Mat_ C} + (f : A ⟶ X ⊗ (Y ⊗ Z)) (g : X ⊗ (Y ⊗ Z) ⟶ (Y ⊗ Z) ⊗ X) (h : (Y ⊗ Z) ⊗ X ⟶ E) + (i : A.ι) (e : E.ι) : + (f ≫ g ≫ h) i e = + ∑ ax : X.ι, ∑ ay : Y.ι, ∑ az : Z.ι, + ∑ by_ : Y.ι, ∑ bz : Z.ι, ∑ bx : X.ι, + f i (ax, (ay, az)) ≫ g (ax, (ay, az)) ((by_, bz), bx) ≫ h ((by_, bz), + bx) e := by + rw [mat_comp_XYZ_apply X Y Z] + congr 1; ext ax; congr 1; ext ay; congr 1; ext az + rw [mat_comp_XY_Z_apply Y Z X, Preadditive.comp_sum] + congr 1; ext by_; rw [Preadditive.comp_sum] + congr 1; ext bz; rw [Preadditive.comp_sum] + +private theorem mat_comp3_fwd_rhs + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (X Y Z : Mat_ C) + {A E : Mat_ C} + (f : A ⟶ (Y ⊗ X) ⊗ Z) (g : (Y ⊗ X) ⊗ Z ⟶ Y ⊗ (X ⊗ Z)) (h : Y ⊗ (X ⊗ Z) ⟶ E) + (i : A.ι) (e : E.ι) : + (f ≫ g ≫ h) i e = + ∑ cy : Y.ι, ∑ cx : X.ι, ∑ cz : Z.ι, + ∑ dy : Y.ι, ∑ dx : X.ι, ∑ dz : Z.ι, + f i ((cy, cx), cz) ≫ g ((cy, cx), cz) (dy, (dx, dz)) ≫ h (dy, (dx, dz)) + e := by + rw [mat_comp_XY_Z_apply Y X Z] + congr 1; ext cy; congr 1; ext cx; congr 1; ext cz + rw [mat_comp_XYZ_apply Y X Z, Preadditive.comp_sum] + congr 1; ext dy; rw [Preadditive.comp_sum] + congr 1; ext dx; rw [Preadditive.comp_sum] + +private theorem mat_comp3_rev_lhs + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (X Y Z : Mat_ C) + {A E : Mat_ C} + (f : A ⟶ (X ⊗ Y) ⊗ Z) (g : (X ⊗ Y) ⊗ Z ⟶ Z ⊗ (X ⊗ Y)) (h : Z ⊗ (X ⊗ Y) ⟶ E) + (i : A.ι) (e : E.ι) : + (f ≫ g ≫ h) i e = + ∑ ax : X.ι, ∑ ay : Y.ι, ∑ az : Z.ι, + ∑ bz : Z.ι, ∑ bx : X.ι, ∑ by_ : Y.ι, + f i ((ax, ay), az) ≫ g ((ax, ay), az) (bz, (bx, by_)) ≫ h (bz, (bx, + by_)) e := by + rw [mat_comp_XY_Z_apply X Y Z] + congr 1; ext ax; congr 1; ext ay; congr 1; ext az + rw [mat_comp_XYZ_apply Z X Y, Preadditive.comp_sum] + congr 1; ext bz; rw [Preadditive.comp_sum] + congr 1; ext bx; rw [Preadditive.comp_sum] + +private theorem mat_comp3_rev_rhs + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (X Y Z : Mat_ C) + {A E : Mat_ C} + (f : A ⟶ X ⊗ (Z ⊗ Y)) (g : X ⊗ (Z ⊗ Y) ⟶ (X ⊗ Z) ⊗ Y) (h : (X ⊗ Z) ⊗ Y ⟶ E) + (i : A.ι) (e : E.ι) : + (f ≫ g ≫ h) i e = + ∑ cx : X.ι, ∑ cz : Z.ι, ∑ cy : Y.ι, + ∑ dx : X.ι, ∑ dz : Z.ι, ∑ dy : Y.ι, + f i (cx, (cz, cy)) ≫ g (cx, (cz, cy)) ((dx, dz), dy) ≫ h ((dx, dz), dy) + e := by + rw [mat_comp_XYZ_apply X Z Y] + congr 1; ext cx; congr 1; ext cz; congr 1; ext cy + rw [mat_comp_XY_Z_apply X Z Y, Preadditive.comp_sum] + congr 1; ext dx; rw [Preadditive.comp_sum] + congr 1; ext dz; rw [Preadditive.comp_sum] + +-- The hexagon is checked entrywise on a triple +-- index, so three matrix compositions expand. +private theorem mat_hexagon_forward + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] [BraidedCategory C] + (X Y Z : Mat_ C) : + (α_ X Y Z).hom ≫ (matBraidIso X (Y ⊗ Z)).hom ≫ (α_ Y Z X).hom = + (matBraidIso X Y).hom ▷ Z ≫ (α_ Y X Z).hom ≫ Y ◁ (matBraidIso X Z).hom := by + apply Mat_.hom_ext; intro ⟨⟨ix, iy⟩, iz⟩ ⟨jy, ⟨jz, jx⟩⟩ + rw [mat_comp3_fwd_lhs X Y Z, mat_comp3_fwd_rhs X Y Z] + simp only [mat_assocHom_apply, matBraidIso, matBraidHom_apply, + mat_whiskerLeft_apply, mat_whiskerRight_apply, Mat_.id_apply] + -- LHS: collapse ax=ix, ay=iy, az=iz (from α.hom) + rw [Finset.sum_eq_single_of_mem ix (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem iy (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem iz (Finset.mem_univ _)] + · simp only [dite_true, eqToHom_refl, id_comp] + -- Braiding: collapse by_=iy, bz=iz, bx=ix + rw [Finset.sum_eq_single_of_mem iy (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem iz (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem ix (Finset.mem_univ _)] + · simp only [dite_true, eqToHom_refl, id_comp] + -- RHS: collapse cy=iy, cx=ix, cz=iz + rw [Finset.sum_eq_single_of_mem iy (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem ix (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem iz (Finset.mem_univ _)] + · simp only [dite_true, eqToHom_refl, id_comp] + -- α.hom: collapse dy=iy, dx=ix, dz=iz + rw [Finset.sum_eq_single_of_mem iy (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem ix (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem iz (Finset.mem_univ _)] + · simp only [dite_true, eqToHom_refl, id_comp] + by_cases hx : ix = jx <;> by_cases hy : iy = jy <;> + by_cases hz : iz = jz + · subst hx; subst hy; subst hz + simp only [dite_true, eqToHom_refl, id_comp] + rw [id_tensorHom, tensorHom_id] + exact BraidedCategory.hexagon_forward (X.X ix) (Y.X + iy) (Z.X iz) + all_goals simp_all + · intro b _ hb; simp [Ne.symm hb] + · intro b _ hb; simp [Ne.symm hb] + · intro b _ hb; simp [Ne.symm hb] + · intro b _ hb; simp [Ne.symm hb] + · intro b _ hb; simp [Ne.symm hb] + · intro b _ hb; simp [Ne.symm hb] + · intro b _ hb; simp [Ne.symm hb] + · intro b _ hb + have : ¬((iy, iz) = (iy, b)) := fun h => (Ne.symm hb) + (Prod.mk.inj h).2 + simp [this] + · intro b _ hb + apply Finset.sum_eq_zero; intro bz _ + apply Finset.sum_eq_zero; intro bx _ + have : ¬((iy, iz) = (b, bz)) := fun h => (Ne.symm hb) + (Prod.mk.inj h).1 + simp [this] + · intro b _ hb; simp [Ne.symm hb] + · intro b _ hb; simp [Ne.symm hb] + · intro b _ hb; simp [Ne.symm hb] + +-- As for the forward hexagon. +private theorem mat_hexagon_reverse + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] [BraidedCategory C] + (X Y Z : Mat_ C) : + (α_ X Y Z).inv ≫ (matBraidIso (X ⊗ Y) Z).hom ≫ (α_ Z X Y).inv = + X ◁ (matBraidIso Y Z).hom ≫ (α_ X Z Y).inv ≫ (matBraidIso X Z).hom ▷ Y := by + apply Mat_.hom_ext; intro ⟨ix, ⟨iy, iz⟩⟩ ⟨⟨jz, jx⟩, jy⟩ + rw [mat_comp3_rev_lhs X Y Z, mat_comp3_rev_rhs X Y Z] + simp only [mat_assocInv_apply, matBraidIso, matBraidHom_apply, + mat_whiskerLeft_apply, mat_whiskerRight_apply, Mat_.id_apply] + -- LHS: collapse ax=ix, ay=iy, az=iz (from α.inv) + rw [Finset.sum_eq_single_of_mem ix (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem iy (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem iz (Finset.mem_univ _)] + · simp only [dite_true, eqToHom_refl, id_comp] + -- Braiding: collapse bz=iz, bx=ix, by_=iy + rw [Finset.sum_eq_single_of_mem iz (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem ix (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem iy (Finset.mem_univ _)] + · simp only [dite_true, eqToHom_refl, id_comp] + -- RHS: collapse cx=ix, cz=iz, cy=iy + rw [Finset.sum_eq_single_of_mem ix (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem iz (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem iy (Finset.mem_univ _)] + · simp only [dite_true, eqToHom_refl, id_comp] + -- α.inv: collapse dx=ix, dz=iz, dy=iy + rw [Finset.sum_eq_single_of_mem ix (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem iz (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem iy (Finset.mem_univ _)] + · simp only [dite_true, eqToHom_refl, id_comp] + by_cases hx : ix = jx <;> by_cases hy : iy = jy <;> + by_cases hz : iz = jz + · subst hx; subst hy; subst hz + simp only [dite_true, eqToHom_refl, id_comp] + rw [id_tensorHom, tensorHom_id] + exact BraidedCategory.hexagon_reverse (X.X ix) (Y.X + iy) (Z.X iz) + all_goals simp_all + · intro b _ hb; simp [Ne.symm hb] + · intro b _ hb; simp [Ne.symm hb] + · intro b _ hb; simp [Ne.symm hb] + · intro b _ hb; simp [Ne.symm hb] + · intro b _ hb; simp [Ne.symm hb] + · intro b _ hb; simp [Ne.symm hb] + · intro b _ hb + have : ¬((ix, iy) = (ix, b)) := + fun h => (Ne.symm hb) (Prod.mk.inj h).2 + simp [this] + · intro b _ hb + apply Finset.sum_eq_zero; intro by_ _ + have : ¬((ix, iy) = (b, by_)) := + fun h => (Ne.symm hb) (Prod.mk.inj h).1 + simp [this] + · intro b _ hb; simp [Ne.symm hb] + · intro b _ hb; simp [Ne.symm hb] + · intro b _ hb; simp [Ne.symm hb] + · intro b _ hb; simp [Ne.symm hb] + +/-! ### `BraidedCategory` instance -/ + +/-- The matrix category inherits a braiding: the componentwise +braidings, reindexed by the swap of index products. -/ +instance matBraided [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] [BraidedCategory C] : BraidedCategory (Mat_ C) where + braiding := matBraidIso + braiding_naturality_right := by exact mat_braiding_naturality_right + braiding_naturality_left := by exact mat_braiding_naturality_left + hexagon_forward := by exact mat_hexagon_forward + hexagon_reverse := by exact mat_hexagon_reverse + +end Braided + +/-! ### `SymmetricCategory` instance -/ + +section Symmetric + +-- Symmetry is checked entrywise. +/-- And a symmetric one stays symmetric. -/ +instance matSymmetric [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] [SymmetricCategory C] : + SymmetricCategory (Mat_ C) where + symmetry X Y := by + change matBraidHom X Y ≫ matBraidHom Y X = 𝟙 _ + apply Mat_.hom_ext; intro ⟨ix, iy⟩ ⟨jx, jy⟩ + rw [mat_comp_tensor_apply, Mat_.id_apply] + simp only [matBraidHom_apply] + rw [Finset.sum_eq_single_of_mem iy (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem ix (Finset.mem_univ _)] + · simp only [dite_true, eqToHom_refl, id_comp] + by_cases hx : ix = jx <;> by_cases hy : iy = jy + · subst hx; subst hy + simp only [dite_true, eqToHom_refl, id_comp] + exact SymmetricCategory.symmetry (X.X ix) (Y.X iy) + · have : (ix, iy) ≠ (jx, jy) := fun h => hy (Prod.mk.inj h).2 + simp [hy, this] + · have : (ix, iy) ≠ (jx, jy) := fun h => hx (Prod.mk.inj h).1 + simp [hx, this] + · have : (ix, iy) ≠ (jx, jy) := fun h => hx (Prod.mk.inj h).1 + simp [hy, this] + · intro b _ hb; simp [show ¬(ix = b) from Ne.symm hb] + · intro b _ hb; simp [show ¬(iy = b) from Ne.symm hb] + +end Symmetric + +end RS + +end diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean new file mode 100644 index 0000000000..0a3ba43525 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean @@ -0,0 +1,512 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatBraided +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGenerator + +/-! +# Monoidal, braided, additive, and linear structure on `Mat_.embedding C` + +When `C` is a monoidal preadditive category, the embedding functor +`Mat_.embedding C : C ⥤ Mat_ C` is strong monoidal, braided (when `C` is +braided), additive, and `ℂ`-linear (when `C` is linear). + +The key observation is that the embedding sends `X` to the one-by-one +matrix `⟨PUnit, fun _ => X⟩`, so all index types in sight are products of +`PUnit` (hence subsingletons). Every structural morphism is therefore a +single-entry diagonal matrix carrying the identity of the appropriate +tensor product, and all coherence proofs collapse immediately. + +We use `Functor.CoreMonoidal` to avoid manually proving the oplax +coherence conditions: from `εIso`, `μIso`, and the lax axioms, mathlib +automatically derives the full `Functor.Monoidal` structure including +the `OplaxMonoidal` fields. +-/ + +@[expose] public section + +noncomputable section + +namespace RS + + + +open CategoryTheory CategoryTheory.Category CategoryTheory.MonoidalCategory +open CategoryTheory.Limits CategoryTheory.Idempotents + +universe v u + +variable {C : Type u} + +/-! ### The embedding is additive + +Mathlib already provides `(Mat_.embedding C).Additive`. -/ + +example + [Category.{v} C] [Preadditive C] : + (Mat_.embedding C).Additive := inferInstance + +/-! ### The embedding is `ℂ`-linear -/ + +section Linear + +/-- The embedding into the matrix category is ℂ-linear. -/ +instance matEmbeddingLinear + [Category.{v} C] [Preadditive C] [CategoryTheory.Linear ℂ C] : + (Mat_.embedding C).Linear ℂ where + map_smul f r := by ext ⟨⟩ ⟨⟩; rfl + +end Linear + +/-! #### Naturality and coherence lemmas -/ + +private theorem matEmb_μ_natural_left + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + {X Y : C} (f : X ⟶ Y) (X' : C) : + (Mat_.embedding C).map f ▷ (Mat_.embedding C).obj X' ≫ matEmbTensorHom Y X' + = + matEmbTensorHom X X' ≫ (Mat_.embedding C).map (f ▷ X') := by + apply Mat_.hom_ext; intro i j + have hL : ((Mat_.embedding C).map f ▷ (Mat_.embedding C).obj X' ≫ + matEmbTensorHom Y X') i j = + ∑ k, ((Mat_.embedding C).map f ▷ (Mat_.embedding C).obj X') i k ≫ + matEmbTensorHom Y X' k j := rfl + have hR : (matEmbTensorHom X X' ≫ (Mat_.embedding C).map (f ▷ X')) i j = + ∑ k, matEmbTensorHom X X' i k ≫ + (Mat_.embedding C).map (f ▷ X') k j := rfl + rw [hL, hR] + have : Subsingleton ((Mat_.embedding C).obj Y ⊗ (Mat_.embedding C).obj X').ι + := + inferInstanceAs (Subsingleton (PUnit × PUnit)) + have : Subsingleton ((Mat_.embedding C).obj (X ⊗ X')).ι := + inferInstanceAs (Subsingleton PUnit) + set a : ((Mat_.embedding C).obj Y ⊗ (Mat_.embedding C).obj X').ι := + (PUnit.unit, PUnit.unit) + set b : ((Mat_.embedding C).obj (X ⊗ X')).ι := PUnit.unit + rw [Fintype.sum_subsingleton _ a, Fintype.sum_subsingleton _ b] + change (f ⊗ₘ (𝟙 ((Mat_.embedding C).obj X') : Mat_.Hom _ _) i.2 a.2) ≫ 𝟙 (Y ⊗ + X') = + 𝟙 (X ⊗ X') ≫ (f ▷ X') + have : Subsingleton ((Mat_.embedding C).obj X').ι := inferInstanceAs + (Subsingleton PUnit) + rw [show i.2 = a.2 from Subsingleton.elim _ _, Mat_.id_apply_self] + change (f ⊗ₘ 𝟙 X') ≫ 𝟙 (Y ⊗ X') = 𝟙 (X ⊗ X') ≫ (f ▷ X') + rw [tensorHom_id, comp_id, id_comp] + +private theorem matEmb_μ_natural_right + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + {X Y : C} (X' : C) (f : X ⟶ Y) : + (Mat_.embedding C).obj X' ◁ (Mat_.embedding C).map f ≫ matEmbTensorHom X' Y + = + matEmbTensorHom X' X ≫ (Mat_.embedding C).map (X' ◁ f) := by + apply Mat_.hom_ext; intro i j + have hL : ((Mat_.embedding C).obj X' ◁ (Mat_.embedding C).map f ≫ + matEmbTensorHom X' Y) i j = + ∑ k, ((Mat_.embedding C).obj X' ◁ (Mat_.embedding C).map f) i k ≫ + matEmbTensorHom X' Y k j := rfl + have hR : (matEmbTensorHom X' X ≫ (Mat_.embedding C).map (X' ◁ f)) i j = + ∑ k, matEmbTensorHom X' X i k ≫ + (Mat_.embedding C).map (X' ◁ f) k j := rfl + rw [hL, hR] + have : Subsingleton ((Mat_.embedding C).obj X' ⊗ (Mat_.embedding C).obj Y).ι + := + inferInstanceAs (Subsingleton (PUnit × PUnit)) + have : Subsingleton ((Mat_.embedding C).obj (X' ⊗ X)).ι := + inferInstanceAs (Subsingleton PUnit) + set a : ((Mat_.embedding C).obj X' ⊗ (Mat_.embedding C).obj Y).ι := + (PUnit.unit, PUnit.unit) + set b : ((Mat_.embedding C).obj (X' ⊗ X)).ι := PUnit.unit + rw [Fintype.sum_subsingleton _ a, Fintype.sum_subsingleton _ b] + change ((𝟙 ((Mat_.embedding C).obj X') : Mat_.Hom _ _) i.1 a.1 ⊗ₘ f) ≫ 𝟙 (X' ⊗ + Y) = + 𝟙 (X' ⊗ X) ≫ (X' ◁ f) + have : Subsingleton ((Mat_.embedding C).obj X').ι := inferInstanceAs + (Subsingleton PUnit) + rw [show i.1 = a.1 from Subsingleton.elim _ _, Mat_.id_apply_self] + change (𝟙 X' ⊗ₘ f) ≫ 𝟙 (X' ⊗ Y) = 𝟙 (X' ⊗ X) ≫ (X' ◁ f) + rw [id_tensorHom, comp_id, id_comp] + +/-! #### Associativity -/ + +-- Restate the private Mat_ associator lemma +open scoped Classical in +private theorem mat_assocHom_apply' + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M N K : Mat_ C) + (i : M.ι) (j : N.ι) (k : K.ι) (i' : M.ι) (j' : N.ι) (k' : K.ι) : + (α_ M N K).hom ((i, j), k) (i', (j', k')) = + if hi : i = i' then if hj : j = j' then if hk : k = k' then + eqToHom (by subst hi; subst hj; subst hk; rfl) ≫ (α_ (M.X i') (N.X j') + (K.X k')).hom + else 0 else 0 else 0 := rfl + +-- Associativity of the embedding is checked +-- entrywise on a triple index. +private theorem matEmb_associativity + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (X Y Z : C) : + matEmbTensorHom X Y ▷ (Mat_.embedding C).obj Z ≫ + matEmbTensorHom (X ⊗ Y) Z ≫ (Mat_.embedding C).map (α_ X Y Z).hom = + (α_ ((Mat_.embedding C).obj X) ((Mat_.embedding C).obj Y) + ((Mat_.embedding C).obj Z)).hom ≫ + (Mat_.embedding C).obj X ◁ matEmbTensorHom Y Z ≫ + matEmbTensorHom X (Y ⊗ Z) := by + apply Mat_.hom_ext; intro i j + have : Subsingleton ((Mat_.embedding C).obj X).ι := inferInstanceAs + (Subsingleton PUnit) + have : Subsingleton ((Mat_.embedding C).obj Y).ι := inferInstanceAs + (Subsingleton PUnit) + have : Subsingleton ((Mat_.embedding C).obj Z).ι := inferInstanceAs + (Subsingleton PUnit) + -- LHS = (α_ X Y Z).hom + have hLHS : (matEmbTensorHom X Y ▷ (Mat_.embedding C).obj Z ≫ + matEmbTensorHom (X ⊗ Y) Z ≫ (Mat_.embedding C).map (α_ X Y Z).hom) i j = + (α_ X Y Z).hom := by + have h1 : (matEmbTensorHom X Y ▷ (Mat_.embedding C).obj Z ≫ + matEmbTensorHom (X ⊗ Y) Z ≫ (Mat_.embedding C).map (α_ X Y Z).hom) i j = + ∑ k, (matEmbTensorHom X Y ▷ (Mat_.embedding C).obj Z) i k ≫ + (matEmbTensorHom (X ⊗ Y) Z ≫ (Mat_.embedding C).map (α_ X Y Z).hom) k j + := rfl + rw [h1] + have : Subsingleton ((Mat_.embedding C).obj (X ⊗ Y) ⊗ (Mat_.embedding + C).obj Z).ι := + inferInstanceAs (Subsingleton (PUnit × PUnit)) + set a1 : ((Mat_.embedding C).obj (X ⊗ Y) ⊗ (Mat_.embedding C).obj Z).ι := + (PUnit.unit, PUnit.unit) + rw [Fintype.sum_subsingleton _ a1] + have h2 : (matEmbTensorHom (X ⊗ Y) Z ≫ (Mat_.embedding C).map (α_ X Y + Z).hom) a1 j = + ∑ k, matEmbTensorHom (X ⊗ Y) Z a1 k ≫ + (Mat_.embedding C).map (α_ X Y Z).hom k j := rfl + rw [h2] + have : Subsingleton ((Mat_.embedding C).obj ((X ⊗ Y) ⊗ Z)).ι := + inferInstanceAs (Subsingleton PUnit) + set b1 : ((Mat_.embedding C).obj ((X ⊗ Y) ⊗ Z)).ι := PUnit.unit + rw [Fintype.sum_subsingleton _ b1] + change (matEmbTensorHom X Y i.1 a1.1 ⊗ₘ (𝟙 ((Mat_.embedding C).obj Z)) i.2 + a1.2) ≫ + 𝟙 ((X ⊗ Y) ⊗ Z) ≫ (α_ X Y Z).hom = (α_ X Y Z).hom + rw [show i.2 = a1.2 from Subsingleton.elim _ _, Mat_.id_apply_self] + change (𝟙 (X ⊗ Y) ⊗ₘ 𝟙 Z) ≫ 𝟙 ((X ⊗ Y) ⊗ Z) ≫ (α_ X Y Z).hom = (α_ X Y Z).hom + rw [MonoidalCategory.id_tensorHom_id, id_comp, id_comp] + -- RHS = (α_ X Y Z).hom + have hRHS : ((α_ ((Mat_.embedding C).obj X) ((Mat_.embedding C).obj Y) + ((Mat_.embedding C).obj Z)).hom ≫ + (Mat_.embedding C).obj X ◁ matEmbTensorHom Y Z ≫ + matEmbTensorHom X (Y ⊗ Z)) i j = + (α_ X Y Z).hom := by + have h1 : ((α_ ((Mat_.embedding C).obj X) ((Mat_.embedding C).obj Y) + ((Mat_.embedding C).obj Z)).hom ≫ + (Mat_.embedding C).obj X ◁ matEmbTensorHom Y Z ≫ + matEmbTensorHom X (Y ⊗ Z)) i j = + ∑ k, (α_ ((Mat_.embedding C).obj X) ((Mat_.embedding C).obj Y) + ((Mat_.embedding C).obj Z)).hom i k ≫ + ((Mat_.embedding C).obj X ◁ matEmbTensorHom Y Z ≫ + matEmbTensorHom X (Y ⊗ Z)) k j := rfl + rw [h1] + have : Subsingleton ((Mat_.embedding C).obj X ⊗ + ((Mat_.embedding C).obj Y ⊗ (Mat_.embedding C).obj Z)).ι := + inferInstanceAs (Subsingleton (PUnit × (PUnit × PUnit))) + set a2 : ((Mat_.embedding C).obj X ⊗ + ((Mat_.embedding C).obj Y ⊗ (Mat_.embedding C).obj Z)).ι := + (PUnit.unit, (PUnit.unit, PUnit.unit)) + rw [Fintype.sum_subsingleton _ a2] + have h2 : ((Mat_.embedding C).obj X ◁ matEmbTensorHom Y Z ≫ + matEmbTensorHom X (Y ⊗ Z)) a2 j = + ∑ k, ((Mat_.embedding C).obj X ◁ matEmbTensorHom Y Z) a2 k ≫ + matEmbTensorHom X (Y ⊗ Z) k j := rfl + rw [h2] + have : Subsingleton ((Mat_.embedding C).obj X ⊗ + (Mat_.embedding C).obj (Y ⊗ Z)).ι := + inferInstanceAs (Subsingleton (PUnit × PUnit)) + set b2 : ((Mat_.embedding C).obj X ⊗ (Mat_.embedding C).obj (Y ⊗ Z)).ι := + (PUnit.unit, PUnit.unit) + rw [Fintype.sum_subsingleton _ b2] + -- Evaluate associator entry separately + have h_assoc : (α_ ((Mat_.embedding C).obj X) ((Mat_.embedding C).obj Y) + ((Mat_.embedding C).obj Z)).hom i a2 = (α_ X Y Z).hom := by + rw [show i = ((i.1.1, i.1.2), i.2) from rfl, + show a2 = (a2.1, (a2.2.1, a2.2.2)) from rfl, + mat_assocHom_apply', + dite_eq_left (Subsingleton.elim i.1.1 a2.1), + dite_eq_left (Subsingleton.elim i.1.2 a2.2.1), + dite_eq_left (Subsingleton.elim i.2 a2.2.2)] + erw [eqToHom_refl, id_comp]; rfl + rw [h_assoc] + -- Now: (α_ X Y Z).hom ≫ whiskerLeft ≫ matEmbTensorHom = (α_ X Y Z).hom + change (α_ X Y Z).hom ≫ + ((𝟙 ((Mat_.embedding C).obj X)) a2.1 b2.1 ⊗ₘ matEmbTensorHom Y Z a2.2 + b2.2) ≫ + 𝟙 (X ⊗ (Y ⊗ Z)) = (α_ X Y Z).hom + rw [show a2.1 = b2.1 from Subsingleton.elim _ _, Mat_.id_apply_self] + change (α_ X Y Z).hom ≫ (𝟙 X ⊗ₘ 𝟙 (Y ⊗ Z)) ≫ 𝟙 (X ⊗ (Y ⊗ Z)) = (α_ X Y Z).hom + rw [MonoidalCategory.id_tensorHom_id, id_comp, comp_id] + rw [hLHS, hRHS] + +/-! #### Unitality -/ + +-- Component lemmas restated from private defs +open scoped Classical in +private theorem mat_leftUnitorHom_apply' + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M : Mat_ C) (i : PUnit) (j k : M.ι) : + (λ_ M).hom (i, j) k = + if h : j = k then eqToHom (by subst h; rfl) ≫ (λ_ (M.X k)).hom else 0 + := rfl + +open scoped Classical in +private theorem mat_rightUnitorHom_apply' + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M : Mat_ C) (i : M.ι) (j : PUnit) (k + : M.ι) : + (ρ_ M).hom (i, j) k = + if h : i = k then eqToHom (by subst h; rfl) ≫ (ρ_ (M.X k)).hom else 0 + := rfl + +-- Unitality is checked entrywise against the +-- one-object index. +private theorem matEmb_left_unitality + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (X : C) : + (λ_ ((Mat_.embedding C).obj X)).hom = + (𝟙 ((Mat_.embedding C).obj (𝟙_ C)) : + 𝟙_ (Mat_ C) ⟶ (Mat_.embedding C).obj (𝟙_ C)) ▷ + (Mat_.embedding C).obj X ≫ + matEmbTensorHom (𝟙_ C) X ≫ + (Mat_.embedding C).map (λ_ X).hom := by + apply Mat_.hom_ext; intro i j + have : Subsingleton ((Mat_.embedding C).obj (𝟙_ C)).ι := + inferInstanceAs (Subsingleton PUnit) + have : Subsingleton ((Mat_.embedding C).obj X).ι := + inferInstanceAs (Subsingleton PUnit) + have : Subsingleton (𝟙_ (Mat_ C)).ι := + inferInstanceAs (Subsingleton PUnit) + -- LHS = (λ_ X).hom + have hLHS : (λ_ ((Mat_.embedding C).obj X)).hom i j = (λ_ X).hom := by + rw [show i = (i.1, i.2) from rfl, mat_leftUnitorHom_apply', + dite_eq_left (Subsingleton.elim i.2 j)] + erw [eqToHom_refl, id_comp]; rfl + -- RHS = (λ_ X).hom + have hRHS : ((𝟙 ((Mat_.embedding C).obj (𝟙_ C)) : + 𝟙_ (Mat_ C) ⟶ (Mat_.embedding C).obj (𝟙_ C)) ▷ + (Mat_.embedding C).obj X ≫ + matEmbTensorHom (𝟙_ C) X ≫ + (Mat_.embedding C).map (λ_ X).hom) i j = (λ_ X).hom := by + have h1 : ((𝟙 ((Mat_.embedding C).obj (𝟙_ C)) : + 𝟙_ (Mat_ C) ⟶ (Mat_.embedding C).obj (𝟙_ C)) ▷ + (Mat_.embedding C).obj X ≫ + (matEmbTensorHom (𝟙_ C) X ≫ + (Mat_.embedding C).map (λ_ X).hom)) i j = + ∑ k, ((𝟙 ((Mat_.embedding C).obj (𝟙_ C)) : + 𝟙_ (Mat_ C) ⟶ (Mat_.embedding C).obj (𝟙_ C)) ▷ + (Mat_.embedding C).obj X) i k ≫ + (matEmbTensorHom (𝟙_ C) X ≫ (Mat_.embedding C).map (λ_ X).hom) k j + := rfl + rw [h1] + have : Subsingleton ((Mat_.embedding C).obj (𝟙_ C) ⊗ (Mat_.embedding C).obj + X).ι := + inferInstanceAs (Subsingleton (PUnit × PUnit)) + set a : ((Mat_.embedding C).obj (𝟙_ C) ⊗ (Mat_.embedding C).obj X).ι := + (PUnit.unit, PUnit.unit) + rw [Fintype.sum_subsingleton _ a] + have h2 : (matEmbTensorHom (𝟙_ C) X ≫ (Mat_.embedding C).map (λ_ X).hom) a j + = + ∑ k, matEmbTensorHom (𝟙_ C) X a k ≫ + (Mat_.embedding C).map (λ_ X).hom k j := rfl + rw [h2] + have : Subsingleton ((Mat_.embedding C).obj (𝟙_ C ⊗ X)).ι := + inferInstanceAs (Subsingleton PUnit) + set b : ((Mat_.embedding C).obj (𝟙_ C ⊗ X)).ι := PUnit.unit + rw [Fintype.sum_subsingleton _ b] + change ((𝟙 ((Mat_.embedding C).obj (𝟙_ C)) : Mat_.Hom _ _) i.1 a.1 ⊗ₘ + (𝟙 ((Mat_.embedding C).obj X) : Mat_.Hom _ _) i.2 a.2) ≫ + 𝟙 (𝟙_ C ⊗ X) ≫ (λ_ X).hom = (λ_ X).hom + rw [show i.1 = a.1 from Subsingleton.elim _ _, Mat_.id_apply_self, + show i.2 = a.2 from Subsingleton.elim _ _, Mat_.id_apply_self] + change (𝟙 (𝟙_ C) ⊗ₘ 𝟙 X) ≫ 𝟙 (𝟙_ C ⊗ X) ≫ (λ_ X).hom = (λ_ X).hom + rw [MonoidalCategory.id_tensorHom_id, id_comp, id_comp] + rw [hLHS, hRHS] + +-- As for left unitality. +private theorem matEmb_right_unitality + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (X : C) : + (ρ_ ((Mat_.embedding C).obj X)).hom = + (Mat_.embedding C).obj X ◁ + (𝟙 ((Mat_.embedding C).obj (𝟙_ C)) : + 𝟙_ (Mat_ C) ⟶ (Mat_.embedding C).obj (𝟙_ C)) ≫ + matEmbTensorHom X (𝟙_ C) ≫ + (Mat_.embedding C).map (ρ_ X).hom := by + apply Mat_.hom_ext; intro i j + have : Subsingleton ((Mat_.embedding C).obj X).ι := inferInstanceAs + (Subsingleton PUnit) + have : Subsingleton ((Mat_.embedding C).obj (𝟙_ C)).ι := + inferInstanceAs (Subsingleton PUnit) + have : Subsingleton (𝟙_ (Mat_ C)).ι := inferInstanceAs (Subsingleton PUnit) + -- LHS = (ρ_ X).hom + have hLHS : (ρ_ ((Mat_.embedding C).obj X)).hom i j = (ρ_ X).hom := by + rw [show i = (i.1, i.2) from rfl, mat_rightUnitorHom_apply', + dite_eq_left (Subsingleton.elim i.1 j)] + erw [eqToHom_refl, id_comp]; rfl + -- RHS = (ρ_ X).hom + have hRHS : ((Mat_.embedding C).obj X ◁ + (𝟙 ((Mat_.embedding C).obj (𝟙_ C)) : + 𝟙_ (Mat_ C) ⟶ (Mat_.embedding C).obj (𝟙_ C)) ≫ + matEmbTensorHom X (𝟙_ C) ≫ + (Mat_.embedding C).map (ρ_ X).hom) i j = (ρ_ X).hom := by + have h1 : ((Mat_.embedding C).obj X ◁ + (𝟙 ((Mat_.embedding C).obj (𝟙_ C)) : + 𝟙_ (Mat_ C) ⟶ (Mat_.embedding C).obj (𝟙_ C)) ≫ + (matEmbTensorHom X (𝟙_ C) ≫ + (Mat_.embedding C).map (ρ_ X).hom)) i j = + ∑ k, ((Mat_.embedding C).obj X ◁ + (𝟙 ((Mat_.embedding C).obj (𝟙_ C)) : + 𝟙_ (Mat_ C) ⟶ (Mat_.embedding C).obj (𝟙_ C))) i k ≫ + (matEmbTensorHom X (𝟙_ C) ≫ (Mat_.embedding C).map (ρ_ X).hom) k j + := rfl + rw [h1] + have : Subsingleton ((Mat_.embedding C).obj X ⊗ (Mat_.embedding C).obj (𝟙_ + C)).ι := + inferInstanceAs (Subsingleton (PUnit × PUnit)) + set a : ((Mat_.embedding C).obj X ⊗ (Mat_.embedding C).obj (𝟙_ C)).ι := + (PUnit.unit, PUnit.unit) + rw [Fintype.sum_subsingleton _ a] + have h2 : (matEmbTensorHom X (𝟙_ C) ≫ (Mat_.embedding C).map (ρ_ X).hom) a j + = + ∑ k, matEmbTensorHom X (𝟙_ C) a k ≫ + (Mat_.embedding C).map (ρ_ X).hom k j := rfl + rw [h2] + have : Subsingleton ((Mat_.embedding C).obj (X ⊗ 𝟙_ C)).ι := + inferInstanceAs (Subsingleton PUnit) + set b : ((Mat_.embedding C).obj (X ⊗ 𝟙_ C)).ι := PUnit.unit + rw [Fintype.sum_subsingleton _ b] + change ((𝟙 ((Mat_.embedding C).obj X) : Mat_.Hom _ _) i.1 a.1 ⊗ₘ + (𝟙 ((Mat_.embedding C).obj (𝟙_ C)) : Mat_.Hom _ _) i.2 a.2) ≫ + 𝟙 (X ⊗ 𝟙_ C) ≫ (ρ_ X).hom = (ρ_ X).hom + rw [show i.1 = a.1 from Subsingleton.elim _ _, Mat_.id_apply_self, + show i.2 = a.2 from Subsingleton.elim _ _, Mat_.id_apply_self] + change (𝟙 X ⊗ₘ 𝟙 (𝟙_ C)) ≫ 𝟙 (X ⊗ 𝟙_ C) ≫ (ρ_ X).hom = (ρ_ X).hom + rw [MonoidalCategory.id_tensorHom_id, id_comp, id_comp] + rw [hLHS, hRHS] + +/-! #### The CoreMonoidal structure and Monoidal instance -/ + +/-- The `CoreMonoidal` structure on `Mat_.embedding C`, providing isomorphisms +`εIso : 𝟙_ (Mat_ C) ≅ (Mat_.embedding C).obj (𝟙_ C)`, the identity since +these coincide, and `μIso X Y : emb X ⊗ emb Y ≅ emb (X ⊗ Y)` from +`matEmbTensorIso`. -/ +noncomputable def matEmbCoreMonoidal + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] : + (Mat_.embedding C).CoreMonoidal where + εIso := Iso.refl _ + μIso X Y := matEmbTensorIso X Y + μIso_hom_natural_left := by exact matEmb_μ_natural_left + μIso_hom_natural_right := by exact matEmb_μ_natural_right + associativity := by exact matEmb_associativity + left_unitality := by exact matEmb_left_unitality + right_unitality := by exact matEmb_right_unitality + +/-- The embedding `Mat_.embedding C` is strong monoidal. The full `Monoidal` +structure, `OplaxMonoidal` coherence included, comes from `CoreMonoidal`. -/ +noncomputable instance matEmbeddingMonoidal + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] : + Functor.Monoidal (Mat_.embedding C) := + matEmbCoreMonoidal.toMonoidal + +/-! ### The braided structure on `Mat_.embedding C` -/ + +section Braided + +-- Braiding component formula (restated from private def) +open scoped Classical in +private theorem mat_braidHom_apply' + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] [BraidedCategory C] + (M N : Mat_ C) + (i₁ : M.ι) (i₂ : N.ι) (j₁ : N.ι) (j₂ : M.ι) : + (β_ M N).hom (i₁, i₂) (j₁, j₂) = + if hi : i₂ = j₁ then if hj : i₁ = j₂ then + eqToHom (by subst hi; subst hj; rfl) ≫ (β_ (M.X j₂) (N.X j₁)).hom + else 0 else 0 := rfl + +-- The braided axiom is checked entrywise through +-- the tensorator. +private theorem matEmb_braided + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] [BraidedCategory C] + (X Y : C) : + Functor.LaxMonoidal.μ (Mat_.embedding C) X Y ≫ + (Mat_.embedding C).map (β_ X Y).hom = + (β_ ((Mat_.embedding C).obj X) ((Mat_.embedding C).obj Y)).hom ≫ + Functor.LaxMonoidal.μ (Mat_.embedding C) Y X := by + -- μ is matEmbTensorHom by CoreMonoidal construction + change matEmbTensorHom X Y ≫ (Mat_.embedding C).map (β_ X Y).hom = + (β_ ((Mat_.embedding C).obj X) ((Mat_.embedding C).obj Y)).hom ≫ + matEmbTensorHom Y X + apply Mat_.hom_ext; intro i j + have : Subsingleton ((Mat_.embedding C).obj X).ι := inferInstanceAs + (Subsingleton PUnit) + have : Subsingleton ((Mat_.embedding C).obj Y).ι := inferInstanceAs + (Subsingleton PUnit) + -- LHS = (β_ X Y).hom + have hLHS : (matEmbTensorHom X Y ≫ (Mat_.embedding C).map (β_ X Y).hom) i j = + (β_ X Y).hom := by + have h1 : (matEmbTensorHom X Y ≫ (Mat_.embedding C).map (β_ X Y).hom) i j = + ∑ k, matEmbTensorHom X Y i k ≫ + (Mat_.embedding C).map (β_ X Y).hom k j := rfl + rw [h1] + have : Subsingleton ((Mat_.embedding C).obj (X ⊗ Y)).ι := + inferInstanceAs (Subsingleton PUnit) + set a : ((Mat_.embedding C).obj (X ⊗ Y)).ι := PUnit.unit + rw [Fintype.sum_subsingleton _ a] + change 𝟙 (X ⊗ Y) ≫ (β_ X Y).hom = (β_ X Y).hom + rw [id_comp] + -- RHS = (β_ X Y).hom + have hRHS : ((β_ ((Mat_.embedding C).obj X) ((Mat_.embedding C).obj Y)).hom ≫ + matEmbTensorHom Y X) i j = (β_ X Y).hom := by + have h1 : ((β_ ((Mat_.embedding C).obj X) ((Mat_.embedding C).obj Y)).hom ≫ + matEmbTensorHom Y X) i j = + ∑ k, (β_ ((Mat_.embedding C).obj X) ((Mat_.embedding C).obj Y)).hom i k ≫ + matEmbTensorHom Y X k j := rfl + rw [h1] + have : Subsingleton ((Mat_.embedding C).obj Y ⊗ (Mat_.embedding C).obj X).ι + := + inferInstanceAs (Subsingleton (PUnit × PUnit)) + set b : ((Mat_.embedding C).obj Y ⊗ (Mat_.embedding C).obj X).ι := + (PUnit.unit, PUnit.unit) + rw [Fintype.sum_subsingleton _ b] + -- Evaluate braiding entry (erw uses default transparency, avoiding + -- the ill-typed goal issue that occurs with rw at implicit transparency) + have h_braid : (β_ ((Mat_.embedding C).obj X) ((Mat_.embedding C).obj + Y)).hom i b = + (β_ X Y).hom := by + erw [show i = (i.1, i.2) from rfl, + show b = (b.1, b.2) from rfl, + mat_braidHom_apply', + dite_eq_left (Subsingleton.elim i.2 b.1), + dite_eq_left (Subsingleton.elim i.1 b.2)] + erw [eqToHom_refl, id_comp]; rfl + rw [h_braid] + change (β_ X Y).hom ≫ 𝟙 (Y ⊗ X) = (β_ X Y).hom + rw [comp_id] + rw [hLHS, hRHS] + +/-- The embedding `Mat_.embedding C` is braided when `C` is braided. -/ +noncomputable instance matEmbeddingBraided + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] [BraidedCategory C] : + Functor.Braided (Mat_.embedding C) where + braided := by exact matEmb_braided + +end Braided + +end RS + +end diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatMonoidal.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatMonoidal.lean new file mode 100644 index 0000000000..c9ff460ed6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatMonoidal.lean @@ -0,0 +1,562 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# Monoidal structure on the matrix envelope + +When `C` is a monoidal preadditive category (i.e. a preadditive category with a +monoidal structure such that the tensor product is bilinear on morphisms), the +matrix category `Mat_ C` inherits a monoidal structure: + +* **Objects**: `M ⊗ N = (M.ι × N.ι, fun p => M.X p.1 ⊗ N.X p.2)`. +* **Morphisms**: the Kronecker product — entry `(i₁,i₂),(j₁,j₂)` of `f ⊗ₘ g` + is `f i₁ j₁ ⊗ₘ g i₂ j₂`. +* **Unit**: `(PUnit, fun _ => 𝟙_ C)`. +* **Structural isomorphisms**: diagonal matrices carrying the componentwise + associators/unitors of `C`, with index-type reindexing by `Equiv.prodAssoc`, + `Equiv.punitProd`, `Equiv.prodPUnit`. + +The interchange law (`tensorHom_comp_tensorHom`) holds because matrix +multiplication turns into iterated sums that factor via `tensor_sum` and +`sum_tensor` (the `MonoidalPreadditive` hypothesis). The pentagon and triangle +identities reduce componentwise to the corresponding identities in `C`. +-/ + +@[expose] public section + +noncomputable section + +namespace RS + + + +open CategoryTheory CategoryTheory.Category CategoryTheory.MonoidalCategory +open CategoryTheory.Limits CategoryTheory.MonoidalPreadditive + +universe v u + +variable {C : Type u} + +/-! ### Tensor product data on `Mat_ C` -/ + +/-- Tensor product of objects in `Mat_ C`: index by the product, with +componentwise tensor in `C`. -/ +@[reducible] def matTensorObj [Category.{v} C] [MonoidalCategory C] + (M N : Mat_ C) : Mat_ C := + ⟨M.ι × N.ι, fun p => M.X p.1 ⊗ N.X p.2⟩ + +/-- Tensor product of morphisms in `Mat_ C`: the Kronecker product. -/ +def matTensorHom [Category.{v} C] [Preadditive C] [MonoidalCategory C] + {M₁ N₁ M₂ N₂ : Mat_ C} + (f : M₁ ⟶ N₁) (g : M₂ ⟶ N₂) : matTensorObj M₁ M₂ ⟶ matTensorObj N₁ N₂ := + fun (i₁, i₂) (j₁, j₂) => f i₁ j₁ ⊗ₘ g i₂ j₂ + +/-- The tensor unit in `Mat_ C`. -/ +@[reducible] def matTensorUnit + [Category.{v} C] [MonoidalCategory C] : Mat_ C := ⟨PUnit, fun _ => 𝟙_ C⟩ + +/-! ### Structural isomorphisms + +The associator and unitors are "diagonal" morphisms: given an equivalence of +index types, the entry at `(i, e i)` is the corresponding structural morphism +of `C`, and all other entries are zero. -/ + +open scoped Classical in +/-- The associator hom in `Mat_ C`. -/ +def matAssocHom [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M N K : Mat_ C) : + matTensorObj (matTensorObj M N) K ⟶ matTensorObj M (matTensorObj N K) := + fun ((i, j), k) (i', (j', k')) => + if hi : i = i' then + if hj : j = j' then + if hk : k = k' then + eqToHom (by subst hi; subst hj; subst hk; rfl) ≫ + (α_ (M.X i') (N.X j') (K.X k')).hom + else 0 + else 0 + else 0 + +open scoped Classical in +/-- The associator inv in `Mat_ C`. -/ +def matAssocInv [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M N K : Mat_ C) : + matTensorObj M (matTensorObj N K) ⟶ matTensorObj (matTensorObj M N) K := + fun (i, (j, k)) ((i', j'), k') => + if hi : i = i' then + if hj : j = j' then + if hk : k = k' then + eqToHom (by subst hi; subst hj; subst hk; rfl) ≫ + (α_ (M.X i') (N.X j') (K.X k')).inv + else 0 + else 0 + else 0 + +open scoped Classical in +/-- The left unitor hom in `Mat_ C`. -/ +def matLeftUnitorHom + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M : Mat_ C) : + matTensorObj matTensorUnit M ⟶ M := + fun ((), i) j => + if h : i = j then + eqToHom (by subst h; rfl) ≫ (λ_ (M.X j)).hom + else 0 + +open scoped Classical in +/-- The left unitor inv in `Mat_ C`. -/ +def matLeftUnitorInv + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M : Mat_ C) : + M ⟶ matTensorObj matTensorUnit M := + fun i ((), j) => + if h : i = j then + (λ_ (M.X i)).inv ≫ eqToHom (by subst h; rfl) + else 0 + +open scoped Classical in +/-- The right unitor hom in `Mat_ C`. -/ +def matRightUnitorHom + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M : Mat_ C) : + matTensorObj M matTensorUnit ⟶ M := + fun (i, ()) j => + if h : i = j then + eqToHom (by subst h; rfl) ≫ (ρ_ (M.X j)).hom + else 0 + +open scoped Classical in +/-- The right unitor inv in `Mat_ C`. -/ +def matRightUnitorInv + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M : Mat_ C) : + M ⟶ matTensorObj M matTensorUnit := + fun i (j, ()) => + if h : i = j then + (ρ_ (M.X i)).inv ≫ eqToHom (by subst h; rfl) + else 0 + +/-! ### Isomorphism proofs for the structural morphisms + +Diagonal ≫ diagonal collapses to a single summand: all off-diagonal entries +in the intermediate sum vanish. `Finset.sum_eq_single_of_mem` identifies the +unique nonzero term, and the on-diagonal entry then simplifies. -/ + +open scoped Classical in +private theorem matAssoc_hom_inv + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M N K : Mat_ C) : + matAssocHom M N K ≫ matAssocInv M N K = 𝟙 _ := by + apply Mat_.hom_ext + intro ⟨⟨i, j⟩, k⟩ ⟨⟨i', j'⟩, k'⟩ + simp only [Mat_.comp_apply, Mat_.id_apply, matAssocHom, matAssocInv] + rw [Finset.sum_eq_single_of_mem (i, (j, k)) (Finset.mem_univ _)] + · -- ═══ On-diagonal term ═══ + simp only [dite_true, eqToHom_refl, id_comp] + by_cases hi : i = i' <;> by_cases hj : j = j' <;> by_cases hk : k = k' + · subst hi; subst hj; subst hk + simp [eqToHom_refl, id_comp, Iso.hom_inv_id] + all_goals simp_all [Prod.mk.injEq] + · -- ═══ Off-diagonal terms ═══ + intro ⟨a, b, c⟩ _ hne + have h : ¬(i = a ∧ j = b ∧ k = c) := + by rintro ⟨rfl, rfl, rfl⟩; exact hne rfl + rcases not_and_or.mp h with h1 | h1 + · simp [h1, zero_comp] + · rcases not_and_or.mp h1 with h2 | h2 + · simp [h2, zero_comp] + · simp [h2, zero_comp] + +open scoped Classical in +private theorem matAssoc_inv_hom + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M N K : Mat_ C) : + matAssocInv M N K ≫ matAssocHom M N K = 𝟙 _ := by + apply Mat_.hom_ext + intro ⟨i, j, k⟩ ⟨i', j', k'⟩ + simp only [Mat_.comp_apply, Mat_.id_apply, matAssocInv, matAssocHom] + rw [Finset.sum_eq_single_of_mem ((i, j), k) (Finset.mem_univ _)] + · simp only [dite_true, eqToHom_refl, id_comp] + by_cases hi : i = i' <;> by_cases hj : j = j' <;> by_cases hk : k = k' + · subst hi; subst hj; subst hk + simp [eqToHom_refl, id_comp, Iso.inv_hom_id] + all_goals simp_all [Prod.mk.injEq] + · intro ⟨⟨a, b⟩, c⟩ _ hne + have h : ¬(i = a ∧ j = b ∧ k = c) := + by rintro ⟨rfl, rfl, rfl⟩; exact hne rfl + rcases not_and_or.mp h with h1 | h1 + · simp [h1, zero_comp] + · rcases not_and_or.mp h1 with h2 | h2 + · simp [h2, zero_comp] + · simp [h2, zero_comp] + +open scoped Classical in +private theorem matLeftUnitor_hom_inv + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M : Mat_ C) : + matLeftUnitorHom M ≫ matLeftUnitorInv M = 𝟙 _ := by + apply Mat_.hom_ext + intro ⟨⟨⟩, i⟩ ⟨⟨⟩, j⟩ + simp only [Mat_.comp_apply, Mat_.id_apply, matLeftUnitorHom, matLeftUnitorInv] + rw [Finset.sum_eq_single_of_mem i (Finset.mem_univ _)] + · simp only [dite_true, eqToHom_refl, id_comp] + by_cases h : i = j + · subst h; simp [eqToHom_refl, comp_id, Iso.hom_inv_id] + · simp [h, Prod.mk.injEq] + · intro b _ hb + have : ¬(i = b) := fun h => hb h.symm + simp [this, zero_comp] + +open scoped Classical in +private theorem matLeftUnitor_inv_hom + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M : Mat_ C) : + matLeftUnitorInv M ≫ matLeftUnitorHom M = 𝟙 _ := by + apply Mat_.hom_ext + intro i j + simp only [Mat_.comp_apply, Mat_.id_apply, matLeftUnitorInv, matLeftUnitorHom] + rw [Finset.sum_eq_single_of_mem ((), i) (Finset.mem_univ _)] + · simp only [dite_true, eqToHom_refl] + by_cases h : i = j + · subst h; simp [eqToHom_refl, id_comp, comp_id, Iso.inv_hom_id] + · simp [h] + · intro ⟨⟨⟩, b⟩ _ hb + have : ¬(i = b) := fun h => hb (by subst h; rfl) + simp [this, zero_comp] + +open scoped Classical in +private theorem matRightUnitor_hom_inv + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M : Mat_ C) : + matRightUnitorHom M ≫ matRightUnitorInv M = 𝟙 _ := by + apply Mat_.hom_ext + intro ⟨i, ⟨⟩⟩ ⟨j, ⟨⟩⟩ + simp only [Mat_.comp_apply, Mat_.id_apply, matRightUnitorHom, + matRightUnitorInv] + rw [Finset.sum_eq_single_of_mem i (Finset.mem_univ _)] + · simp only [dite_true, eqToHom_refl, id_comp] + by_cases h : i = j + · subst h; simp [eqToHom_refl, comp_id, Iso.hom_inv_id] + · simp [h, Prod.mk.injEq] + · intro b _ hb + have : ¬(i = b) := fun h => hb h.symm + simp [this, zero_comp] + +open scoped Classical in +private theorem matRightUnitor_inv_hom + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M : Mat_ C) : + matRightUnitorInv M ≫ matRightUnitorHom M = 𝟙 _ := by + apply Mat_.hom_ext + intro i j + simp only [Mat_.comp_apply, Mat_.id_apply, matRightUnitorInv, + matRightUnitorHom] + rw [Finset.sum_eq_single_of_mem (i, ()) (Finset.mem_univ _)] + · simp only [dite_true, eqToHom_refl] + by_cases h : i = j + · subst h; simp [eqToHom_refl, id_comp, comp_id, Iso.inv_hom_id] + · simp [h] + · intro ⟨b, ⟨⟩⟩ _ hb + have : ¬(i = b) := fun h => hb (by subst h; rfl) + simp [this, zero_comp] + +/-- The associator isomorphism in `Mat_ C`. -/ +def matAssociator [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M N K : Mat_ C) : + matTensorObj (matTensorObj M N) K ≅ matTensorObj M (matTensorObj N K) where + hom := matAssocHom M N K + inv := matAssocInv M N K + hom_inv_id := by exact matAssoc_hom_inv M N K + inv_hom_id := by exact matAssoc_inv_hom M N K + +/-- The left unitor isomorphism in `Mat_ C`. -/ +def matLeftUnitor [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M : Mat_ C) : + matTensorObj matTensorUnit M ≅ M where + hom := matLeftUnitorHom M + inv := matLeftUnitorInv M + hom_inv_id := by exact matLeftUnitor_hom_inv M + inv_hom_id := by exact matLeftUnitor_inv_hom M + +/-- The right unitor isomorphism in `Mat_ C`. -/ +def matRightUnitor [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M : Mat_ C) : + matTensorObj M matTensorUnit ≅ M where + hom := matRightUnitorHom M + inv := matRightUnitorInv M + hom_inv_id := by exact matRightUnitor_hom_inv M + inv_hom_id := by exact matRightUnitor_inv_hom M + +/-! ### `MonoidalCategoryStruct` instance -/ + +/-- The monoidal data on the matrix category: index products on +objects, Kronecker products on morphisms. -/ +instance matMonoidalStruct + [Category.{v} C] [Preadditive C] [MonoidalCategory C] : + MonoidalCategoryStruct (Mat_ C) where + tensorObj := matTensorObj + whiskerLeft M _ _ f := matTensorHom (𝟙 M) f + whiskerRight f N := matTensorHom f (𝟙 N) + tensorHom := matTensorHom + tensorUnit := matTensorUnit + associator := matAssociator + leftUnitor := matLeftUnitor + rightUnitor := matRightUnitor + +/-! ### `MonoidalCategory` instance + +We use `MonoidalCategory.ofTensorHom` which requires proofs of the interchange +law, naturality of structural isomorphisms, and the pentagon and triangle +coherence identities. Each proof goes pointwise via `Mat_.hom_ext`, collapses +diagonal sums via `Finset.sum_eq_single_of_mem`, and reduces to the +corresponding axiom in `C`. -/ + +private theorem mat_id_tensorHom_id + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] + (M₁ M₂ : Mat_ C) : + matTensorHom (𝟙 M₁) (𝟙 M₂) = 𝟙 (matTensorObj M₁ M₂) := by + apply Mat_.hom_ext; intro ⟨i₁, i₂⟩ ⟨j₁, j₂⟩ + simp only [matTensorHom, Mat_.id_apply] + by_cases h₁ : i₁ = j₁ <;> by_cases h₂ : i₂ = j₂ + · subst h₁; subst h₂ + simp [eqToHom_refl] + · simp [h₂, tensor_zero] + · simp [h₁, MonoidalPreadditive.zero_tensor] + · simp [h₁, MonoidalPreadditive.zero_tensor] + +private theorem mat_tensorHom_comp + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] + {M₁ N₁ K₁ M₂ N₂ K₂ : Mat_ C} + (f₁ : M₁ ⟶ N₁) (f₂ : M₂ ⟶ N₂) (g₁ : N₁ ⟶ K₁) (g₂ : N₂ ⟶ K₂) : + matTensorHom f₁ f₂ ≫ matTensorHom g₁ g₂ = matTensorHom (f₁ ≫ g₁) (f₂ ≫ g₂) + := by + apply Mat_.hom_ext; intro ⟨i₁, i₂⟩ ⟨k₁, k₂⟩ + simp only [Mat_.comp_apply, matTensorHom] + simp_rw [tensorHom_comp_tensorHom] + simp_rw [Fintype.sum_prod_type] + simp_rw [← tensor_sum Finset.univ] + rw [← sum_tensor Finset.univ] + +open scoped Classical in +private theorem mat_associator_naturality + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + {M₁ M₂ M₃ N₁ N₂ N₃ : Mat_ C} + (f₁ : M₁ ⟶ N₁) (f₂ : M₂ ⟶ N₂) (f₃ : M₃ ⟶ N₃) : + matTensorHom (matTensorHom f₁ f₂) f₃ ≫ (matAssociator N₁ N₂ N₃).hom = + (matAssociator M₁ M₂ M₃).hom ≫ matTensorHom f₁ (matTensorHom f₂ f₃) := by + apply Mat_.hom_ext; intro ⟨⟨i₁, i₂⟩, i₃⟩ ⟨j₁, ⟨j₂, j₃⟩⟩ + simp only [Mat_.comp_apply, matTensorHom, matAssociator, matAssocHom] + -- ═══ Collapse LHS sum ═══ + rw [Finset.sum_eq_single_of_mem ((j₁, j₂), j₃) (Finset.mem_univ _)] + · -- ═══ Collapse RHS sum ═══ + rw [Finset.sum_eq_single_of_mem (i₁, (i₂, i₃)) (Finset.mem_univ _)] + · simp only [dite_true, eqToHom_refl, id_comp] + exact MonoidalCategory.associator_naturality (f₁ i₁ j₁) (f₂ i₂ j₂) (f₃ i₃ + j₃) + · intro ⟨a, b, c⟩ _ hne + have h : ¬(i₁ = a ∧ i₂ = b ∧ i₃ = c) := + by rintro ⟨rfl, rfl, rfl⟩; exact hne rfl + rcases not_and_or.mp h with h1 | h1 + · simp [h1, zero_comp] + · rcases not_and_or.mp h1 with h2 | h2 <;> simp [h2, zero_comp] + · intro ⟨⟨a, b⟩, c⟩ _ hne + have h : ¬(a = j₁ ∧ b = j₂ ∧ c = j₃) := + by rintro ⟨rfl, rfl, rfl⟩; exact hne rfl + rcases not_and_or.mp h with h1 | h1 + · simp [h1] + · rcases not_and_or.mp h1 with h2 | h2 <;> simp [h2] + +open scoped Classical in +private theorem mat_leftUnitor_naturality + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + {M N : Mat_ C} (f : M ⟶ N) : + matTensorHom (𝟙 matTensorUnit) f ≫ (matLeftUnitor N).hom = + (matLeftUnitor M).hom ≫ f := by + apply Mat_.hom_ext; intro ⟨⟨⟩, i⟩ j + simp only [Mat_.comp_apply, matTensorHom, matLeftUnitor, matLeftUnitorHom] + -- ═══ Collapse LHS sum over PUnit × N.ι ═══ + rw [Finset.sum_eq_single_of_mem (⟨⟨⟩, j⟩ : PUnit × N.ι) (Finset.mem_univ _)] + · -- ═══ Collapse RHS sum over M.ι ═══ + rw [Finset.sum_eq_single_of_mem i (Finset.mem_univ _)] + · simp only [dite_true, eqToHom_refl, id_comp, Mat_.id_apply_self] + rw [id_tensorHom]; exact leftUnitor_naturality (f i j) + · intro b _ hb; simp [hb.symm] + · intro ⟨⟨⟩, b⟩ _ hne + have : b ≠ j := fun h => hne (by subst h; rfl) + simp [this] + +open scoped Classical in +private theorem mat_rightUnitor_naturality + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + {M N : Mat_ C} (f : M ⟶ N) : + matTensorHom f (𝟙 matTensorUnit) ≫ (matRightUnitor N).hom = + (matRightUnitor M).hom ≫ f := by + apply Mat_.hom_ext; intro ⟨i, ⟨⟩⟩ j + simp only [Mat_.comp_apply, matTensorHom, matRightUnitor, matRightUnitorHom] + -- ═══ Collapse LHS sum over N.ι × PUnit ═══ + rw [Finset.sum_eq_single_of_mem (⟨j, ⟨⟩⟩ : N.ι × PUnit) (Finset.mem_univ _)] + · -- ═══ Collapse RHS sum over M.ι ═══ + rw [Finset.sum_eq_single_of_mem i (Finset.mem_univ _)] + · simp only [dite_true, eqToHom_refl, id_comp, Mat_.id_apply_self] + rw [tensorHom_id]; exact rightUnitor_naturality (f i j) + · intro b _ hb; simp [hb.symm] + · intro ⟨b, ⟨⟩⟩ _ hne + have : b ≠ j := fun h => hne (by subst h; rfl) + simp [this] + +/-! ### Pentagon and triangle coherences + +Both proofs go pointwise via `Mat_.hom_ext`, fully unfold the structural +morphisms to nested `dite` expressions, use `dite_comp`/`comp_dite`/ +`tensor_dite`/`dite_tensor` to push compositions inside the `dite`s, +decompose product sums into iterated sums, and then collapse each sum +via `Finset.sum_dite_irrel` + `Fintype.sum_dite_eq'`. After all sums are +gone both sides reduce to the corresponding coherence in `C`. -/ + +-- The pentagon is checked entrywise on a quadruple +-- index, so four matrix compositions expand. +open scoped Classical in +private theorem mat_pentagon + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] + (M₁ M₂ M₃ M₄ : Mat_ C) : + matTensorHom (matAssociator M₁ M₂ M₃).hom (𝟙 M₄) ≫ + (matAssociator M₁ (matTensorObj M₂ M₃) M₄).hom ≫ + matTensorHom (𝟙 M₁) (matAssociator M₂ M₃ M₄).hom = + (matAssociator (matTensorObj M₁ M₂) M₃ M₄).hom ≫ + (matAssociator M₁ M₂ (matTensorObj M₃ M₄)).hom := by + apply Mat_.hom_ext + intro ⟨⟨⟨i₁, i₂⟩, i₃⟩, i₄⟩ ⟨j₁, ⟨j₂, ⟨j₃, j₄⟩⟩⟩ + simp only [Mat_.comp_apply, matAssociator, matTensorHom, matAssocHom, + Mat_.id_apply] + -- ═══ Collapse LHS outer sum ═══ + rw [Finset.sum_eq_single_of_mem ((i₁, (i₂, i₃)), i₄) (Finset.mem_univ _)] + · -- ═══ Simplify surviving outer term ═══ + simp only [dite_true, eqToHom_refl, id_comp] + -- ═══ Collapse inner LHS sum ═══ + rw [Finset.sum_eq_single_of_mem (i₁, ((i₂, i₃), i₄)) (Finset.mem_univ _)] + · -- ═══ Collapse RHS sum ═══ + simp only [dite_true, eqToHom_refl, id_comp] + rw [Finset.sum_eq_single_of_mem ((i₁, i₂), (i₃, i₄)) (Finset.mem_univ _)] + · -- ═══ On-diagonal: apply C-level pentagon ═══ + simp only [dite_true, eqToHom_refl, id_comp] + by_cases h₁ : i₁ = j₁ <;> by_cases h₂ : i₂ = j₂ <;> + by_cases h₃ : i₃ = j₃ <;> by_cases h₄ : i₄ = j₄ + · subst h₁; subst h₂; subst h₃; subst h₄ + simp only [dite_true, eqToHom_refl, id_comp] + rw [id_tensorHom, tensorHom_id] + exact pentagon (M₁.X i₁) (M₂.X i₂) (M₃.X i₃) (M₄.X i₄) + all_goals simp_all + · -- ═══ Off-diagonal RHS ═══ + intro ⟨⟨a, b⟩, ⟨c, d⟩⟩ _ hne + have h : ¬(i₁ = a ∧ i₂ = b ∧ i₃ = c ∧ i₄ = d) := by + rintro ⟨rfl, rfl, rfl, rfl⟩; exact hne rfl + rcases not_and_or.mp h with h1 | h1 + · simp [h1] + · rcases not_and_or.mp h1 with h2 | h2 + · simp [h2] + · rcases not_and_or.mp h2 with h3 | h3 <;> simp [h3] + · -- ═══ Off-diagonal inner LHS ═══ + intro ⟨a, ⟨⟨b, c⟩, d⟩⟩ _ hne + have : ¬(i₁ = a) ∨ ¬((i₂, i₃) = (b, c)) ∨ ¬(i₄ = d) := by + by_contra hall; push Not at hall + exact hne (Prod.ext hall.1.symm (Prod.ext hall.2.1.symm hall.2.2.symm)) + rcases this with h | h | h <;> simp [h, zero_comp] + · -- ═══ Off-diagonal LHS outer ═══ + intro ⟨⟨a, ⟨b, c⟩⟩, d⟩ _ hne + have h : ¬(i₁ = a ∧ i₂ = b ∧ i₃ = c ∧ i₄ = d) := by + rintro ⟨rfl, rfl, rfl, rfl⟩; exact hne rfl + rcases not_and_or.mp h with h1 | h1 + · simp [h1] + · rcases not_and_or.mp h1 with h2 | h2 + · simp [h2] + · rcases not_and_or.mp h2 with h3 | h3 <;> simp [h3] + +open scoped Classical in +private theorem mat_triangle + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] + (M₁ M₂ : Mat_ C) : + (matAssociator M₁ matTensorUnit M₂).hom ≫ + matTensorHom (𝟙 M₁) (matLeftUnitor M₂).hom = + matTensorHom (matRightUnitor M₁).hom (𝟙 M₂) := by + apply Mat_.hom_ext + intro ⟨⟨i₁, ⟨⟩⟩, i₂⟩ ⟨j₁, j₂⟩ + simp only [Mat_.comp_apply, matAssociator, matTensorHom, matAssocHom, + matTensorUnit, + matLeftUnitor, matLeftUnitorHom, matRightUnitor, matRightUnitorHom, + Mat_.id_apply] + -- ═══ Collapse the single composition sum ═══ + rw [Finset.sum_eq_single_of_mem (i₁, (PUnit.unit, i₂)) (Finset.mem_univ _)] + · -- ═══ On-diagonal: simplify and reduce to C triangle ═══ + simp only [dite_true, eqToHom_refl, id_comp] + by_cases h₁ : i₁ = j₁ <;> by_cases h₂ : i₂ = j₂ + · subst h₁; subst h₂ + simp only [dite_true, eqToHom_refl, id_comp] + rw [id_tensorHom, tensorHom_id] + exact triangle (M₁.X i₁) (M₂.X i₂) + all_goals simp_all + · -- ═══ Off-diagonal ═══ + intro ⟨a, ⟨⟨⟩, b⟩⟩ _ hne + have h : ¬(i₁ = a ∧ i₂ = b) := by rintro ⟨rfl, rfl⟩; exact hne rfl + rcases not_and_or.mp h with h1 | h1 <;> simp [h1, zero_comp] + +/-- The monoidal structure on `Mat_ C` induced by the componentwise tensor +product and Kronecker product of morphisms. -/ +instance matMonoidal [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] : MonoidalCategory (Mat_ C) := by + exact MonoidalCategory.ofTensorHom + (id_tensorHom_id := by exact mat_id_tensorHom_id) + (id_tensorHom := fun _ {_ _} _ => rfl) + (tensorHom_id := fun _ _ => rfl) + (tensorHom_comp_tensorHom := by exact mat_tensorHom_comp) + (associator_naturality := by exact mat_associator_naturality) + (leftUnitor_naturality := by exact mat_leftUnitor_naturality) + (rightUnitor_naturality := by exact mat_rightUnitor_naturality) + (pentagon := by exact mat_pentagon) + (triangle := by exact mat_triangle) + +/-- Composition through a right-associated triple tensor, entry by +entry. -/ +theorem mat_comp_XYZ_apply [Category.{v} C] [Preadditive C] [MonoidalCategory C] + {A D : Mat_ C} (X Y Z : Mat_ C) + (f : A ⟶ X ⊗ (Y ⊗ Z)) (g : X ⊗ (Y ⊗ Z) ⟶ D) + (i : A.ι) (d : D.ι) : + (f ≫ g) i d = ∑ ax : X.ι, ∑ ay : Y.ι, ∑ az : Z.ι, + f i (ax, (ay, az)) ≫ g (ax, (ay, az)) d := + (Mat_.comp_apply f g i d).trans + ((Fintype.sum_prod_type _).trans + (Finset.sum_congr rfl fun _ _ => Fintype.sum_prod_type _)) + +/-- And through a left-associated one — the two sides of the +pentagon. -/ +theorem mat_comp_XY_Z_apply + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + {A D : Mat_ C} (X Y Z : Mat_ C) + (f : A ⟶ (X ⊗ Y) ⊗ Z) (g : (X ⊗ Y) ⊗ Z ⟶ D) + (i : A.ι) (d : D.ι) : + (f ≫ g) i d = ∑ ax : X.ι, ∑ ay : Y.ι, ∑ az : Z.ι, + f i ((ax, ay), az) ≫ g ((ax, ay), az) d := + (Mat_.comp_apply f g i d).trans + ((Fintype.sum_prod_type _).trans (Fintype.sum_prod_type _)) + +/-- Composition through a tensor of two objects, entry by entry. -/ +theorem mat_comp_tensor_apply + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + {A : Mat_ C} {B₁ B₂ : Mat_ C} {D : Mat_ C} + (f : A ⟶ B₁ ⊗ B₂) (g : B₁ ⊗ B₂ ⟶ D) (i : A.ι) (k : D.ι) : + (f ≫ g) i k = ∑ j₁ : B₁.ι, ∑ j₂ : B₂.ι, + f i (j₁, j₂) ≫ g (j₁, j₂) k := + (Mat_.comp_apply f g i k).trans (Fintype.sum_prod_type _) + +end RS + +end diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatRigid.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatRigid.lean new file mode 100644 index 0000000000..1eb73a590a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatRigid.lean @@ -0,0 +1,420 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatBraided + +/-! +# Rigidity of the matrix envelope + +When `C` is a right rigid monoidal preadditive category, the matrix +envelope `Mat_ C` is right rigid: the dual of an object +`M = (ι, X)` is `(ι, fun i => (X i)ᘁ)`, with coevaluation and +evaluation built diagonally from the componentwise cups and caps. +The snake identities reduce to collapsing off-diagonal sums +(all zero by `MonoidalPreadditive`) and applying the base snake +identity at each index. + +When `C` is moreover braided, `Mat_ C` is rigid. +-/ + +@[expose] public section + +noncomputable section + +namespace RS + + + +open CategoryTheory CategoryTheory.Category CategoryTheory.MonoidalCategory +open CategoryTheory.Limits CategoryTheory.MonoidalPreadditive + +universe v u + +variable {C : Type u} + +/-! ### Componentwise access lemmas + +The `private` access lemmas in `MatBraided.lean` are not visible here, +so we restate the ones we need. Each is proved by `rfl`. -/ + +@[simp] private theorem mat_whiskerLeft_apply' + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (X : Mat_ C) {Y Z : Mat_ C} (f : + Y ⟶ Z) + (ix : X.ι) (iy : Y.ι) (jx : X.ι) (jz : Z.ι) : + (X ◁ f) (ix, iy) (jx, jz) = (𝟙 (X : Mat_ C)) ix jx ⊗ₘ f iy jz := rfl + +@[simp] private theorem mat_whiskerRight_apply' + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + {X Y : Mat_ C} (f : X ⟶ Y) (Z : + Mat_ C) + (ix : X.ι) (iz : Z.ι) (jy : Y.ι) (jz : Z.ι) : + (f ▷ Z) (ix, iz) (jy, jz) = f ix jy ⊗ₘ (𝟙 (Z : Mat_ C)) iz jz := rfl + +open scoped Classical in +@[simp] private theorem mat_assocHom_apply' + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M N K : Mat_ C) + (i : M.ι) (j : N.ι) (k : K.ι) (i' : M.ι) (j' : N.ι) (k' : K.ι) : + (α_ M N K).hom ((i, j), k) (i', (j', k')) = + if hi : i = i' then if hj : j = j' then if hk : k = k' then + eqToHom (by subst hi; subst hj; subst hk; rfl) ≫ (α_ (M.X i') (N.X j') + (K.X k')).hom + else 0 else 0 else 0 := rfl + +open scoped Classical in +@[simp] private theorem mat_assocInv_apply' + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M N K : Mat_ C) + (i : M.ι) (j : N.ι) (k : K.ι) (i' : M.ι) (j' : N.ι) (k' : K.ι) : + (α_ M N K).inv (i, (j, k)) ((i', j'), k') = + if hi : i = i' then if hj : j = j' then if hk : k = k' then + eqToHom (by subst hi; subst hj; subst hk; rfl) ≫ (α_ (M.X i') (N.X j') + (K.X k')).inv + else 0 else 0 else 0 := rfl + +open scoped Classical in +@[simp] private theorem mat_rightUnitorHom_apply' + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M : Mat_ C) (i : M.ι) (u : + PUnit) (j : M.ι) : + (ρ_ M).hom (i, u) j = + if h : i = j then eqToHom (by subst h; rfl) ≫ (ρ_ (M.X j)).hom else 0 + := rfl + +open scoped Classical in +@[simp] private theorem mat_rightUnitorInv_apply' + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M : Mat_ C) (i : M.ι) (j : + M.ι) (u : PUnit) : + (ρ_ M).inv i (j, u) = + if h : i = j then (ρ_ (M.X i)).inv ≫ eqToHom (by subst h; rfl) else 0 + := rfl + +open scoped Classical in +@[simp] private theorem mat_leftUnitorHom_apply' + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M : Mat_ C) (u : PUnit) (i : + M.ι) (j : M.ι) : + (λ_ M).hom (u, i) j = + if h : i = j then eqToHom (by subst h; rfl) ≫ (λ_ (M.X j)).hom else 0 + := rfl + +open scoped Classical in +@[simp] private theorem mat_leftUnitorInv_apply' + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + (M : Mat_ C) (i : M.ι) (u : + PUnit) (j : M.ι) : + (λ_ M).inv i (u, j) = + if h : i = j then (λ_ (M.X i)).inv ≫ eqToHom (by subst h; rfl) else 0 + := rfl + +/-! ### The dual object -/ + +/-- The right dual of `M` in `Mat_ C`: same index set, componentwise dual. -/ +@[reducible] noncomputable def matRightDualObj + [Category.{v} C] [MonoidalCategory C] [RightRigidCategory C] + (M : Mat_ C) : Mat_ C := + ⟨M.ι, fun i => (M.X i)ᘁ⟩ + +/-! ### Coevaluation and evaluation -/ + +open scoped Classical in +/-- Componentwise coevaluation: diagonal matrix of cups. -/ +noncomputable def matCoev [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [RightRigidCategory C] + (M : Mat_ C) : 𝟙_ (Mat_ C) ⟶ M ⊗ matRightDualObj M := + fun _ p => if h : p.1 = p.2 then + η_ (M.X p.1) ((M.X p.1)ᘁ) ≫ + eqToHom (congr_arg (M.X p.1 ⊗ ·) (congr_arg (fun i => (M.X i)ᘁ) h)) + else 0 + +open scoped Classical in +/-- Componentwise evaluation: diagonal matrix of caps. -/ +noncomputable def matEv [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [RightRigidCategory C] + (M : Mat_ C) : matRightDualObj M ⊗ M ⟶ 𝟙_ (Mat_ C) := + fun p _ => if h : p.1 = p.2 then + eqToHom (congr_arg (· ⊗ M.X p.2) (congr_arg (fun i => (M.X i)ᘁ) h)) ≫ + ε_ (M.X p.2) ((M.X p.2)ᘁ) + else 0 + +/-! ### Entry lemmas for coev/ev -/ + +private theorem matCoev_apply_diag + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [RightRigidCategory C] + (M : Mat_ C) (u : PUnit) (i : M.ι) : + matCoev M u (i, i) = η_ (M.X i) ((M.X i)ᘁ) := by + simp [matCoev] + +private theorem matCoev_apply_off + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [RightRigidCategory C] + (M : Mat_ C) (u : PUnit) (i j : M.ι) (h : i ≠ + j) : + matCoev M u (i, j) = 0 := + dite_eq_right h + +private theorem matEv_apply_diag + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [RightRigidCategory C] + (M : Mat_ C) (i : M.ι) (u : PUnit) : + matEv M (i, i) u = ε_ (M.X i) ((M.X i)ᘁ) := by + simp [matEv] + +private theorem matEv_apply_off + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [RightRigidCategory C] + (M : Mat_ C) (i j : M.ι) (u : PUnit) (h : i ≠ j) + : + matEv M (i, j) u = 0 := + dite_eq_right h + +/-! ### The snake identities -/ + +-- The snake identity is checked entrywise, and the +-- coevaluation contributes a sum over the dual index. +private theorem mat_snake_one + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] [RightRigidCategory C] + (M : Mat_ C) : + (matRightDualObj M) ◁ matCoev M ≫ (α_ (matRightDualObj M) M (matRightDualObj + M)).inv ≫ + matEv M ▷ (matRightDualObj M) = + (ρ_ (matRightDualObj M)).hom ≫ (λ_ (matRightDualObj M)).inv := by + apply Mat_.hom_ext + intro ⟨a, u⟩ ⟨u', b⟩ + -- Expand the two compositions into iterated sums. + rw [mat_comp_XYZ_apply (matRightDualObj M) M (matRightDualObj M)] + simp_rw [mat_comp_XY_Z_apply (matRightDualObj M) M (matRightDualObj M)] + simp only [Preadditive.comp_sum] + -- Collapse outer sums j=a, k=a, l=a. + rw [Finset.sum_eq_single_of_mem a (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem a (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem a (Finset.mem_univ _)] + · -- On-diagonal: expand whiskerLeft, simplify id and coev. + simp only [mat_whiskerLeft_apply', Mat_.id_apply_self] + rw [matCoev_apply_diag M] + -- Collapse inner sums to (a,a,a). + rw [Finset.sum_eq_single_of_mem a (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem a (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem a (Finset.mem_univ _)] + · simp only [mat_assocInv_apply', mat_whiskerRight_apply', + dite_true, eqToHom_refl, id_comp] + by_cases hab : a = b + · subst hab + rw [Mat_.id_apply_self, matEv_apply_diag M] + simp only [id_tensorHom, tensorHom_id] + rw [Mat_.comp_apply, + Finset.sum_eq_single_of_mem a (Finset.mem_univ _)] + · simp only [mat_rightUnitorHom_apply', + mat_leftUnitorInv_apply', + eqToHom_refl, id_comp, comp_id] + exact ExactPairing.coevaluation_evaluation (M.X a) ((M.X a)ᘁ) + · intro c _ hc + rw [mat_rightUnitorHom_apply', dite_eq_right (Ne.symm hc), + zero_comp] + · rw [Mat_.id_apply_of_ne _ _ _ hab] + simp only [tensor_zero, comp_zero] + rw [Mat_.comp_apply, + Finset.sum_eq_single_of_mem a (Finset.mem_univ _)] + · simp only [mat_rightUnitorHom_apply', + mat_leftUnitorInv_apply'] + simp [hab] + · intro c _ hc + rw [mat_rightUnitorHom_apply', dite_eq_right (Ne.symm hc), + zero_comp] + · intro l' _ hl' + simp [Ne.symm hl', zero_comp] + · intro k' _ hk' + apply Finset.sum_eq_zero; intro l' _ + simp [Ne.symm hk', zero_comp] + · intro j' _ hj' + apply Finset.sum_eq_zero; intro k' _ + apply Finset.sum_eq_zero; intro l' _ + simp [Ne.symm hj', zero_comp] + · -- Off-diagonal: l ≠ a for the matCoev. + intro l _ hl + simp only [mat_whiskerLeft_apply', Mat_.id_apply_self] + rw [matCoev_apply_off M _ _ _ (Ne.symm hl)] + simp [tensor_zero, zero_comp] + · -- Off-diagonal: k ≠ a. + intro k _ hk + apply Finset.sum_eq_zero; intro l _ + simp only [mat_whiskerLeft_apply', Mat_.id_apply_self] + by_cases hkl : k = l + · subst hkl + rw [matCoev_apply_diag M] + -- coev is nonzero, but inner ev at (a,k) is 0 since a ≠ k. + rw [Finset.sum_eq_single_of_mem a (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem k (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem k (Finset.mem_univ _)] + · simp only [mat_assocInv_apply', mat_whiskerRight_apply', + dite_true, eqToHom_refl, id_comp] + rw [matEv_apply_off M _ _ _ (Ne.symm hk)] + simp [MonoidalPreadditive.zero_tensor] + · intro l' _ hl' + simp [Ne.symm hl', zero_comp] + · intro k' _ hk' + apply Finset.sum_eq_zero; intro l' _ + simp [Ne.symm hk', zero_comp] + · intro j' _ hj' + apply Finset.sum_eq_zero; intro k' _ + apply Finset.sum_eq_zero; intro l' _ + simp [Ne.symm hj', zero_comp] + · rw [matCoev_apply_off M _ _ _ hkl] + simp [tensor_zero, zero_comp] + · -- Off-diagonal: j ≠ a. + intro j _ hj + apply Finset.sum_eq_zero; intro k _ + apply Finset.sum_eq_zero; intro l _ + simp only [mat_whiskerLeft_apply'] + rw [Mat_.id_apply_of_ne _ _ _ (Ne.symm hj)] + simp [MonoidalPreadditive.zero_tensor, zero_comp] + +-- As for the first snake identity. +private theorem mat_snake_two + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] [RightRigidCategory C] + (M : Mat_ C) : + matCoev M ▷ M ≫ (α_ M (matRightDualObj M) M).hom ≫ + M ◁ matEv M = + (λ_ M).hom ≫ (ρ_ M).inv := by + apply Mat_.hom_ext + intro ⟨u, a⟩ ⟨b, u'⟩ + rw [mat_comp_XY_Z_apply M (matRightDualObj M) M] + simp_rw [mat_comp_XYZ_apply M (matRightDualObj M) M] + simp only [Preadditive.comp_sum] + -- Collapse outer sums j=a, k=a, l=a. + rw [Finset.sum_eq_single_of_mem a (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem a (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem a (Finset.mem_univ _)] + · -- On-diagonal whiskerRight term. + simp only [mat_whiskerRight_apply', Mat_.id_apply_self] + rw [matCoev_apply_diag M] + -- Collapse inner sum to (a,(a,a)). + rw [Finset.sum_eq_single_of_mem a (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem a (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem a (Finset.mem_univ _)] + · simp only [mat_assocHom_apply', mat_whiskerLeft_apply', + dite_true, eqToHom_refl, id_comp] + by_cases hab : a = b + · subst hab + rw [Mat_.id_apply_self, matEv_apply_diag M] + simp only [id_tensorHom, tensorHom_id] + rw [Mat_.comp_apply, + Finset.sum_eq_single_of_mem a (Finset.mem_univ _)] + · simp only [mat_leftUnitorHom_apply', + mat_rightUnitorInv_apply', + eqToHom_refl, id_comp, comp_id] + exact ExactPairing.evaluation_coevaluation (M.X a) ((M.X a)ᘁ) + · intro c _ hc + rw [mat_leftUnitorHom_apply', dite_eq_right (Ne.symm hc), zero_comp] + · rw [Mat_.id_apply_of_ne _ _ _ hab] + rw [MonoidalPreadditive.zero_tensor, comp_zero, comp_zero] + rw [Mat_.comp_apply, + Finset.sum_eq_single_of_mem a (Finset.mem_univ _)] + · simp only [mat_leftUnitorHom_apply', + mat_rightUnitorInv_apply'] + simp [hab] + · intro c _ hc + rw [mat_leftUnitorHom_apply', dite_eq_right (Ne.symm hc), zero_comp] + · intro l' _ hl' + simp [Ne.symm hl', zero_comp] + · intro k' _ hk' + apply Finset.sum_eq_zero; intro l' _ + simp [Ne.symm hk', zero_comp] + · intro j' _ hj' + apply Finset.sum_eq_zero; intro k' _ + apply Finset.sum_eq_zero; intro l' _ + simp [Ne.symm hj', zero_comp] + · -- Off-diagonal: l ≠ a for matCoev. + intro l _ hl + simp only [mat_whiskerRight_apply'] + rw [Mat_.id_apply_of_ne _ _ _ (Ne.symm hl), + MonoidalPreadditive.tensor_zero] + simp only [zero_comp, Finset.sum_const_zero] + · -- Off-diagonal: k ≠ a. matCoev M u (a, k) = 0. + intro k _ hk + apply Finset.sum_eq_zero; intro l _ + simp only [mat_whiskerRight_apply'] + rw [matCoev_apply_off M _ _ _ (Ne.symm hk)] + simp [MonoidalPreadditive.zero_tensor, zero_comp] + · -- Off-diagonal: j ≠ a. + intro j _ hj + apply Finset.sum_eq_zero; intro k _ + apply Finset.sum_eq_zero; intro l _ + simp only [mat_whiskerRight_apply'] + by_cases hjk : j = k + · subst hjk + by_cases hal : a = l + · subst hal + -- j = k, a = l: both factors nonzero, but matEv vanishes since j ≠ a. + rw [matCoev_apply_diag M, Mat_.id_apply_self] + rw [Finset.sum_eq_single_of_mem j (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem j (Finset.mem_univ _)] + · rw [Finset.sum_eq_single_of_mem a (Finset.mem_univ _)] + · simp only [mat_assocHom_apply', mat_whiskerLeft_apply', + dite_true, eqToHom_refl, id_comp] + rw [matEv_apply_off M _ _ _ hj] + simp [MonoidalPreadditive.tensor_zero, comp_zero] + · intro l' _ hl' + simp [Ne.symm hl', zero_comp] + · intro k' _ hk' + apply Finset.sum_eq_zero; intro l' _ + simp [Ne.symm hk', zero_comp] + · intro j' _ hj' + apply Finset.sum_eq_zero; intro k' _ + apply Finset.sum_eq_zero; intro l' _ + simp [Ne.symm hj', zero_comp] + · -- a ≠ l: (𝟙 M) a l = 0. + rw [Mat_.id_apply_of_ne _ _ _ hal] + simp [MonoidalPreadditive.tensor_zero, zero_comp] + · -- j ≠ k: matCoev is 0. + rw [matCoev_apply_off M _ _ _ hjk] + simp [MonoidalPreadditive.zero_tensor, zero_comp] + +/-! ### The exact pairing and rigidity instances -/ + +/-- The exact pairing between `M` and its componentwise right dual. -/ +@[instance_reducible] +noncomputable def matExactPairing + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] [RightRigidCategory C] + (M : Mat_ C) : + ExactPairing M (matRightDualObj M) where + coevaluation' := matCoev M + evaluation' := matEv M + coevaluation_evaluation' := by exact mat_snake_one M + evaluation_coevaluation' := by exact mat_snake_two M + +/-- Every object in `Mat_ C` has a right dual. -/ +noncomputable instance matHasRightDual + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] [RightRigidCategory C] + (M : Mat_ C) : HasRightDual M where + rightDual := matRightDualObj M + exact := matExactPairing M + +/-- `Mat_ C` is right rigid when `C` is right rigid. -/ +noncomputable instance matRightRigid + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] [RightRigidCategory C] : + RightRigidCategory (Mat_ C) where + +/-- `Mat_ C` is rigid when `C` is right rigid and braided. -/ +noncomputable instance matRigid + [Category.{v} C] [Preadditive C] [MonoidalCategory C] + [MonoidalPreadditive C] [RightRigidCategory C] + [BraidedCategory C] : RigidCategory (Mat_ C) := + BraidedCategory.rigidCategoryOfRightRigidCategory + +end RS + +end diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatSemisimple.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatSemisimple.lean new file mode 100644 index 0000000000..fd4d556aa7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatSemisimple.lean @@ -0,0 +1,256 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.AtomDichotomy + +/-! +# The matrix-envelope trace and semisimplicity + +The diagonal trace on endomorphisms of matrix-envelope objects: +linear, cyclic, and nondegenerate (entrywise, via single-entry +test matrices). Semisimplicity of every `End M` follows from the +trace criterion once nilpotents are known to have vanishing trace, +which the atom decomposition supplies. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Idempotents + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-! ### Linear structure on the matrix envelope -/ + +/-- Scaling a matrix of morphisms entrywise. -/ +noncomputable instance matHomSMul (M N : Mat_ (Karoubi (SkeinObj f))) : + SMul ℂ (M ⟶ N) where + smul c φ := fun i j => c • φ i j + +/-- The matrix layer's hom-sets are ℂ-modules. -/ +noncomputable instance matHomModule + (M N : Mat_ (Karoubi (SkeinObj f))) : Module ℂ (M ⟶ N) where + one_smul φ := by funext i j; exact one_smul ℂ (φ i j) + mul_smul c d φ := by funext i j; exact mul_smul c d (φ i j) + smul_zero c := by funext i j; exact smul_zero c + smul_add c φ ψ := by + funext i j + change c • (φ i j + ψ i j) = c • φ i j + c • ψ i j + exact smul_add c _ _ + add_smul c d φ := by + funext i j + change (c + d) • φ i j = c • φ i j + d • φ i j + exact add_smul c d _ + zero_smul φ := by funext i j; exact zero_smul ℂ (φ i j) + +/-- Hence the matrix layer is ℂ-linear. -/ +noncomputable instance matLinear : + CategoryTheory.Linear ℂ (Mat_ (Karoubi (SkeinObj f))) where + smul_comp M N K c φ ψ := by + funext i k + change ∑ j, (c • φ i j) ≫ ψ j k = c • ∑ j, φ i j ≫ ψ j k + rw [Finset.smul_sum] + refine Finset.sum_congr rfl fun j _ => ?_ + rw [CategoryTheory.Linear.smul_comp] + comp_smul M N K φ c ψ := by + funext i k + change ∑ j, φ i j ≫ (c • ψ j k) = c • ∑ j, φ i j ≫ ψ j k + rw [Finset.smul_sum] + refine Finset.sum_congr rfl fun j _ => ?_ + rw [CategoryTheory.Linear.comp_smul] + +/-! ### The diagonal trace -/ + +/-- The diagonal trace on matrix-envelope endomorphisms. -/ +noncomputable def matTrace (M : Mat_ (Karoubi (SkeinObj f))) : + End M →ₗ[ℂ] ℂ where + toFun φ := ∑ i : M.ι, + HomSpace.traceMap f.val (M.X i).X.arity (φ i i).f + map_add' φ ψ := by + rw [← Finset.sum_add_distrib] + refine Finset.sum_congr rfl fun i _ => ?_ + rw [show ((φ + ψ) i i).f = (φ i i).f + (ψ i i).f from rfl, + map_add] + map_smul' c φ := by + rw [RingHom.id_apply, Finset.smul_sum] + refine Finset.sum_congr rfl fun i _ => ?_ + rw [show ((c • φ) i i).f = c • (φ i i).f from rfl, + map_smul, smul_eq_mul] + +/-- Karoubi-level mixed cyclicity. -/ +private theorem karoubi_trace_comm + {X Y : Karoubi (SkeinObj f)} (a : X ⟶ Y) (b : Y ⟶ X) : + HomSpace.traceMap f.val X.X.arity (a.f ≫ b.f) = + HomSpace.traceMap f.val Y.X.arity (b.f ≫ a.f) := + HomSpace.traceMap_comp_comm f a.f b.f + +/-- **Cyclicity of the diagonal trace.** -/ +theorem matTrace_comp_comm {M N : Mat_ (Karoubi (SkeinObj f))} + (α : M ⟶ N) (β : N ⟶ M) : + matTrace f M (α ≫ β) = matTrace f N (β ≫ α) := by + change (∑ i : M.ι, HomSpace.traceMap f.val (M.X i).X.arity + ((α ≫ β) i i).f) = + ∑ j : N.ι, HomSpace.traceMap f.val (N.X j).X.arity + ((β ≫ α) j j).f + have hM : ∀ i : M.ι, + HomSpace.traceMap f.val (M.X i).X.arity + ((α ≫ β) i i).f = + ∑ j : N.ι, HomSpace.traceMap f.val (M.X i).X.arity + ((α i j).f ≫ (β j i).f) := by + intro i + rw [show ((α ≫ β) i i).f = + ((∑ j : N.ι, α i j ≫ β j i : M.X i ⟶ M.X i)).f from rfl] + rw [show (((∑ j : N.ι, α i j ≫ β j i : + M.X i ⟶ M.X i))).f = + ∑ j : N.ι, ((α i j ≫ β j i : + M.X i ⟶ M.X i)).f from map_sum (karoubiHomAddHom _ _) _ _] + rw [map_sum] + rfl + have hN : ∀ j : N.ι, + HomSpace.traceMap f.val (N.X j).X.arity + ((β ≫ α) j j).f = + ∑ i : M.ι, HomSpace.traceMap f.val (N.X j).X.arity + ((β j i).f ≫ (α i j).f) := by + intro j + rw [show ((β ≫ α) j j).f = + ((∑ i : M.ι, β j i ≫ α i j : N.X j ⟶ N.X j)).f from rfl] + rw [show (((∑ i : M.ι, β j i ≫ α i j : + N.X j ⟶ N.X j))).f = + ∑ i : M.ι, ((β j i ≫ α i j : + N.X j ⟶ N.X j)).f from map_sum (karoubiHomAddHom _ _) _ _] + rw [map_sum] + rfl + rw [Finset.sum_congr rfl fun i _ => hM i, + Finset.sum_congr rfl fun j _ => hN j] + rw [Finset.sum_comm] + refine Finset.sum_congr rfl fun j _ => ?_ + refine Finset.sum_congr rfl fun i _ => ?_ + exact karoubi_trace_comm f (α i j) (β j i) + +/-! ### Single-entry tests and nondegeneracy -/ + +open scoped Classical in +/-- The single-entry endomorphism matrix. -/ +private noncomputable def matSingle + {M : Mat_ (Karoubi (SkeinObj f))} (j i : M.ι) + (b : M.X j ⟶ M.X i) : M ⟶ M := fun l k => + if h : l = j ∧ k = i then + eqToHom (congrArg M.X h.1) ≫ b ≫ + eqToHom (congrArg M.X h.2.symm) + else 0 + +/-- Evaluating the trace against a single-entry test extracts one +entry's closure trace. -/ +private theorem matTrace_matSingle_mul + {M : Mat_ (Karoubi (SkeinObj f))} (i j : M.ι) + (b : M.X j ⟶ M.X i) (φ : End M) : + matTrace f M ((show End M from matSingle f j i b) * φ) = + HomSpace.traceMap f.val (M.X i).X.arity + ((φ i j).f ≫ b.f) := by + classical + change (∑ k : M.ι, HomSpace.traceMap f.val (M.X k).X.arity + ((φ ≫ matSingle f j i b) k k).f) = _ + rw [Finset.sum_eq_single i + (fun k _ hk => by + rw [show ((φ ≫ matSingle f j i b) k k).f = + ((∑ l : M.ι, φ k l ≫ matSingle f j i b l k : + M.X k ⟶ M.X k)).f from rfl] + rw [show (((∑ l : M.ι, φ k l ≫ matSingle f j i b l k : + M.X k ⟶ M.X k))).f = + ∑ l : M.ι, ((φ k l ≫ matSingle f j i b l k : + M.X k ⟶ M.X k)).f from map_sum (karoubiHomAddHom _ _) _ _] + rw [Finset.sum_eq_zero, map_zero] + intro l _ + rw [show matSingle f j i b l k = 0 from + dite_eq_right (fun h => hk h.2)] + rw [show ((φ k l ≫ (0 : M.X l ⟶ M.X k) : + M.X k ⟶ M.X k)).f = 0 from by + rw [Limits.comp_zero] + rfl]) + (fun h => absurd (Finset.mem_univ i) h)] + rw [show ((φ ≫ matSingle f j i b) i i).f = + ((∑ l : M.ι, φ i l ≫ matSingle f j i b l i : + M.X i ⟶ M.X i)).f from rfl] + rw [show (((∑ l : M.ι, φ i l ≫ matSingle f j i b l i : + M.X i ⟶ M.X i))).f = + ∑ l : M.ι, ((φ i l ≫ matSingle f j i b l i : + M.X i ⟶ M.X i)).f from map_sum (karoubiHomAddHom _ _) _ _] + rw [map_sum] + rw [Finset.sum_eq_single j + (fun l _ hl => by + rw [show matSingle f j i b l i = 0 from + dite_eq_right (fun h => hl h.1)] + rw [show ((φ i l ≫ (0 : M.X l ⟶ M.X i) : + M.X i ⟶ M.X i)).f = 0 from by + rw [Limits.comp_zero] + rfl] + rw [map_zero]) + (fun h => absurd (Finset.mem_univ j) h)] + rw [show matSingle f j i b j i = + eqToHom (congrArg M.X rfl) ≫ b ≫ + eqToHom (congrArg M.X rfl) from dite_eq_left ⟨rfl, rfl⟩] + rw [eqToHom_refl, eqToHom_refl, Category.comp_id, + Category.id_comp] + rfl + +/-- **Nondegeneracy of the diagonal trace.** -/ +theorem matEnd_eq_zero_of_traces_vanish + {M : Mat_ (Karoubi (SkeinObj f))} (φ : End M) + (hφ : ∀ ψ : End M, matTrace f M (ψ * φ) = 0) : + φ = 0 := by + apply Mat_.hom_ext + intro i j + change φ i j = 0 + apply karoubiHom_eq_zero_of_traces_vanish f (φ i j) + intro b + have h := hφ (show End M from matSingle f j i b) + rw [matTrace_matSingle_mul] at h + exact h + +/-! ### Finiteness and the semisimplicity criterion -/ + +/-- Karoubi hom-spaces are finite-dimensional, being subspaces of +the skein hom-spaces. -/ +noncomputable instance karoubiHomFinite + (P Q : Karoubi (SkeinObj f)) : + FiniteDimensional ℂ (P ⟶ Q) := by + have : FiniteDimensional ℂ (P.X ⟶ Q.X) := + inferInstanceAs (Module.Finite ℂ + (HomSpace f.val (P.X.arity + Q.X.arity))) + exact FiniteDimensional.of_injective (karoubiHomLinearMap P Q) + (fun _ _ h => Karoubi.Hom.ext h) + +/-- The matrix-envelope Hom underlying map, linearly. -/ +private noncomputable def matHomLin + (M N : Mat_ (Karoubi (SkeinObj f))) : + (M ⟶ N) →ₗ[ℂ] ((i : M.ι) → (j : N.ι) → + (M.X i ⟶ N.X j)) where + toFun φ := fun i j => φ i j + map_add' _ _ := rfl + map_smul' _ _ := rfl + +/-- So are matrix hom-spaces, being finite products of them. -/ +noncomputable instance matHomFinite + (M N : Mat_ (Karoubi (SkeinObj f))) : + FiniteDimensional ℂ (M ⟶ N) := + FiniteDimensional.of_injective (matHomLin f M N) + (fun _ _ h => by + apply Mat_.hom_ext + intro i j + exact congrFun (congrFun h i) j) + +/-- In particular every matrix endomorphism algebra is +finite-dimensional — the standing hypothesis of the trace +criterion. -/ +noncomputable instance matEndFinite + (M : Mat_ (Karoubi (SkeinObj f))) : + FiniteDimensional ℂ (End M) := + matHomFinite f M M + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentMatTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentMatTrace.lean new file mode 100644 index 0000000000..2512c6d9e4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentMatTrace.lean @@ -0,0 +1,765 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatSemisimple + +/-! +# The nilpotent leg of the matrix-envelope trace + +Nilpotent endomorphisms of matrix-envelope objects have vanishing +diagonal trace. The argument stays inside the original +endomorphism algebra: the atomic idempotent decompositions of each +entry algebra split the trace into atom-level diagonal entries; +the scalar matrix extracted through chosen iso-class +representatives multiplies like the endomorphism (idempotent +insertion), is supported on class blocks (the dichotomy), and +inherits nilpotency — so each class block has vanishing complex +trace, and the diagonal trace is the class-weighted sum of those. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.Idempotents + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-! ### Trace splitting along a complete orthogonal family -/ + +/-- The trace splits along a complete orthogonal idempotent +family: `tr x = ∑ₐ tr (eₐ x eₐ)`. -/ +theorem karoubiTrace_split {X : Karoubi (SkeinObj f)} + {ι : Type} [Fintype ι] (e : ι → End X) + (hco : CompleteOrthogonalIdempotents e) (x : End X) : + HomSpace.traceMap f.val X.X.arity x.f = + ∑ a : ι, HomSpace.traceMap f.val X.X.arity + ((e a).f ≫ x.f ≫ (e a).f) := by + have h1 : x.f = (∑ a : ι, (e a).f) ≫ x.f := by + rw [show (∑ a : ι, (e a).f) = X.p from by + calc ∑ a : ι, (e a).f + = ((∑ a : ι, e a : End X)).f := + (map_sum (karoubiHomAddHom X X) _ _).symm + _ = ((1 : End X)).f := by rw [hco.complete] + _ = X.p := rfl] + rw [Karoubi.p_comp] + conv_lhs => rw [h1, + show (∑ a : ι, (e a).f) ≫ x.f = + ∑ a : ι, (e a).f ≫ x.f from + Preadditive.sum_comp _ _ _] + rw [map_sum] + refine Finset.sum_congr rfl fun a _ => ?_ + have h2 : (e a).f ≫ x.f = (e a).f ≫ ((e a).f ≫ x.f) := by + rw [show (e a).f ≫ (e a).f ≫ x.f = + ((e a).f ≫ (e a).f) ≫ x.f from by + simp only [Category.assoc]] + rw [show ((e a).f ≫ (e a).f : X.X ⟶ X.X) = + (e a * e a).f from rfl] + rw [(hco.idem a : e a * e a = e a)] + rw [h2] + exact (HomSpace.traceMap_comp_comm f ((e a).f) + ((e a).f ≫ x.f)).trans + (congrArg (HomSpace.traceMap f.val X.X.arity) + (by + change ((e a).f ≫ x.f) ≫ (e a).f = + (e a).f ≫ x.f ≫ (e a).f + exact Category.assoc _ _ _)) + +/-! ### Atom resolutions -/ + +/-- A choice of atomic idempotent decompositions for every entry +of a matrix-envelope object. -/ +structure AtomResolution (M : Mat_ (Karoubi (SkeinObj f))) where + /-- The atom index of each entry. -/ + idx : M.ι → Type + /-- Finiteness. -/ + fin : ∀ i, Fintype (idx i) + /-- The idempotent families. -/ + e : ∀ i, idx i → End (M.X i) + /-- Complete orthogonality. -/ + complete : ∀ i, CompleteOrthogonalIdempotents (e i) + /-- Atomicity. -/ + atomic : ∀ i a, IsAtomicIdempotent (e i a) + +/-- Atom resolutions exist. -/ +noncomputable def atomResolution + (M : Mat_ (Karoubi (SkeinObj f))) : AtomResolution f M := by + have h : ∀ i : M.ι, ∃ (ι : Type) (_ : Fintype ι) + (e : ι → End (M.X i)), + CompleteOrthogonalIdempotents e ∧ + ∀ a, IsAtomicIdempotent (e a) := fun i => by + have := karoubiEndFinite f (M.X i) + have := karoubiEnd_isSemisimpleRing f (M.X i) + exact exists_completeOrthogonal_atomic + choose idx fin e hco hatom using h + exact ⟨idx, fin, e, hco, hatom⟩ + +attribute [instance] AtomResolution.fin + +/-- The diagonal trace refined along an atom resolution. -/ +theorem matTrace_resolution + {M : Mat_ (Karoubi (SkeinObj f))} + (A : AtomResolution f M) (φ : End M) : + matTrace f M φ = ∑ i : M.ι, ∑ a : A.idx i, + HomSpace.traceMap f.val (M.X i).X.arity + ((A.e i a).f ≫ (φ i i).f ≫ (A.e i a).f) := by + refine Finset.sum_congr rfl fun i _ => ?_ + exact karoubiTrace_split f (A.e i) (A.complete i) (φ i i) + +/-! ### The atoms of a resolution -/ + +variable {f} {M : Mat_ (Karoubi (SkeinObj f))} + +/-- The total atom index. -/ +@[reducible] def AtomResolution.κ (A : AtomResolution f M) := + Σ i : M.ι, A.idx i + +/-- The atom at a total index. -/ +@[reducible] noncomputable def AtomResolution.S + (A : AtomResolution f M) (p : A.κ) : + Karoubi (SkeinObj f) := + cutBy (f := f) (M.X p.1) (A.atomic p.1 p.2).idem + +/-- The atoms are atoms. -/ +theorem AtomResolution.isAtom_S (A : AtomResolution f M) + (p : A.κ) : IsAtom f (A.S p) := + isAtom_cutBy (f := f) (M.X p.1) (A.atomic p.1 p.2) + +/-! ### Scalar extraction on atoms -/ + +/-- The scalar of an atom endomorphism. -/ +noncomputable def atomScalar {S : Karoubi (SkeinObj f)} + (hS : IsAtom f S) (x : End S) : ℂ := + Classical.choose (hS.scalar x) + +/-- The extracted scalar does what it says: the endomorphism is +that multiple of the identity. -/ +theorem atomScalar_spec {S : Karoubi (SkeinObj f)} + (hS : IsAtom f S) (x : End S) : + x = atomScalar hS x • 𝟙 S := + Classical.choose_spec (hS.scalar x) + +/-- The scalar is unique — an atom's identity is nonzero. -/ +theorem atomScalar_unique {S : Karoubi (SkeinObj f)} + (hS : IsAtom f S) {x : End S} {c : ℂ} + (h : x = c • 𝟙 S) : atomScalar hS x = c := by + by_contra hne + have hsub : (c - atomScalar hS x) • 𝟙 S = 0 := by + rw [sub_smul, ← h, ← atomScalar_spec hS x, sub_self] + rcases smul_eq_zero.mp hsub with hc | hid + · exact hne (sub_eq_zero.mp hc).symm + · exact hS.id_ne_zero hid + +/-- Extraction is additive. -/ +theorem atomScalar_add {S : Karoubi (SkeinObj f)} + (hS : IsAtom f S) (x y : End S) : + atomScalar hS (x + y) = + atomScalar hS x + atomScalar hS y := by + refine atomScalar_unique hS ?_ + rw [add_smul, ← atomScalar_spec, ← atomScalar_spec] + +/-- Extraction is multiplicative: composition of atom +endomorphisms is multiplication of scalars. This is what lets the +scalar matrix inherit nilpotency. -/ +theorem atomScalar_comp {S : Karoubi (SkeinObj f)} + (hS : IsAtom f S) (x y : End S) : + atomScalar hS ((x ≫ y : End S)) = + atomScalar hS x * atomScalar hS y := by + refine atomScalar_unique hS ?_ + rw [show (x ≫ y : End S) = + (atomScalar hS x • 𝟙 S) ≫ (atomScalar hS y • 𝟙 S) + from by rw [← atomScalar_spec, ← atomScalar_spec]] + rw [CategoryTheory.Linear.smul_comp, + CategoryTheory.Linear.comp_smul, Category.id_comp, + smul_smul] + +/-! ### The class structure -/ + +open scoped Classical in +/-- Atoms are related when isomorphic. -/ +noncomputable def AtomResolution.rel (A : AtomResolution f M) + (p q : A.κ) : Prop := + Nonempty (A.S p ≅ A.S q) + +/-- Isomorphism of atoms is reflexive. -/ +theorem AtomResolution.rel_refl (A : AtomResolution f M) + (p : A.κ) : A.rel p p := ⟨Iso.refl _⟩ + +/-- It is symmetric. -/ +theorem AtomResolution.rel_symm (A : AtomResolution f M) + {p q : A.κ} (h : A.rel p q) : A.rel q p := + ⟨h.some.symm⟩ + +/-- It is transitive. -/ +theorem AtomResolution.rel_trans (A : AtomResolution f M) + {p q r : A.κ} (h : A.rel p q) (h' : A.rel q r) : + A.rel p r := ⟨h.some.trans h'.some⟩ + +/-- A fixed decidability instance, so all filters elaborate +uniformly. -/ +noncomputable instance AtomResolution.relDec + (A : AtomResolution f M) (p q : A.κ) : + Decidable (A.rel p q) := Classical.dec _ + +/-! ### Representatives and chosen isomorphisms -/ + +/-- The class representative: the enumeration-minimal related +index. -/ +noncomputable def AtomResolution.rep (A : AtomResolution f M) + (p : A.κ) : A.κ := + (Fintype.equivFin A.κ).symm + (((Finset.univ.filter (fun q => A.rel p q)).image + (Fintype.equivFin A.κ)).min' (by + refine Finset.image_nonempty.mpr ⟨p, ?_⟩ + rw [Finset.mem_filter] + exact ⟨Finset.mem_univ p, A.rel_refl p⟩)) + +/-- An atom is isomorphic to its class representative. -/ +theorem AtomResolution.rel_rep (A : AtomResolution f M) + (p : A.κ) : A.rel p (A.rep p) := by + have hmem := Finset.min'_mem + (((Finset.univ.filter (fun q => A.rel p q)).image + (Fintype.equivFin A.κ))) (by + refine Finset.image_nonempty.mpr ⟨p, ?_⟩ + rw [Finset.mem_filter] + exact ⟨Finset.mem_univ p, A.rel_refl p⟩) + obtain ⟨q, hq, hqe⟩ := Finset.mem_image.mp hmem + rw [Finset.mem_filter] at hq + unfold AtomResolution.rep + rw [show ((Finset.univ.filter (fun q => A.rel p q)).image + (Fintype.equivFin A.κ)).min' _ = + (Fintype.equivFin A.κ) q from hqe.symm] + rw [Equiv.symm_apply_apply] + exact hq.2 + +/-- Isomorphic atoms have the same representative. -/ +theorem AtomResolution.rep_eq_of_rel (A : AtomResolution f M) + {p q : A.κ} (h : A.rel p q) : A.rep p = A.rep q := by + have hset : (Finset.univ.filter (fun r => A.rel p r)) = + (Finset.univ.filter (fun r => A.rel q r)) := by + ext r + rw [Finset.mem_filter, Finset.mem_filter] + constructor + · exact fun ⟨hu, hr⟩ => + ⟨hu, A.rel_trans (A.rel_symm h) hr⟩ + · exact fun ⟨hu, hr⟩ => ⟨hu, A.rel_trans h hr⟩ + unfold AtomResolution.rep + simp only [hset] + +/-- The chosen isomorphism from the representative atom. -/ +noncomputable def AtomResolution.w (A : AtomResolution f M) + (p : A.κ) : A.S (A.rep p) ≅ A.S p := + (A.rel_symm (A.rel_rep p)).some + +/-! ### The matrix elements -/ + +/-- The matrix element of an endomorphism at a pair of atoms. -/ +noncomputable def AtomResolution.t (A : AtomResolution f M) + (φ : End M) (p q : A.κ) : A.S p ⟶ A.S q := + ⟨(A.e p.1 p.2).f ≫ (φ p.1 q.1).f ≫ (A.e q.1 q.2).f, by + change (A.e p.1 p.2).f ≫ ((A.e p.1 p.2).f ≫ + (φ p.1 q.1).f ≫ (A.e q.1 q.2).f) ≫ + (A.e q.1 q.2).f = _ + rw [show (A.e p.1 p.2).f ≫ ((A.e p.1 p.2).f ≫ + (φ p.1 q.1).f ≫ (A.e q.1 q.2).f) ≫ + (A.e q.1 q.2).f = + ((A.e p.1 p.2).f ≫ (A.e p.1 p.2).f) ≫ + (φ p.1 q.1).f ≫ + ((A.e q.1 q.2).f ≫ (A.e q.1 q.2).f) from by + simp only [Category.assoc]] + rw [show ((A.e p.1 p.2).f ≫ (A.e p.1 p.2).f : + (M.X p.1).X ⟶ (M.X p.1).X) = + (A.e p.1 p.2 * A.e p.1 p.2).f from rfl] + rw [show ((A.e q.1 q.2).f ≫ (A.e q.1 q.2).f : + (M.X q.1).X ⟶ (M.X q.1).X) = + (A.e q.1 q.2 * A.e q.1 q.2).f from rfl] + rw [((A.complete p.1).idem p.2 : + A.e p.1 p.2 * A.e p.1 p.2 = A.e p.1 p.2)] + rw [((A.complete q.1).idem q.2 : + A.e q.1 q.2 * A.e q.1 q.2 = A.e q.1 q.2)]⟩ + +/-- The matrix element's underlying morphism: the entry cut down by +the two atoms' idempotents. -/ +theorem AtomResolution.t_f (A : AtomResolution f M) + (φ : End M) (p q : A.κ) : + (A.t φ p q).f = (A.e p.1 p.2).f ≫ (φ p.1 q.1).f ≫ + (A.e q.1 q.2).f := rfl + +/-- Cross-class matrix elements vanish (the dichotomy). -/ +theorem AtomResolution.t_eq_zero (A : AtomResolution f M) + (φ : End M) {p q : A.κ} (h : ¬ A.rel p q) : + A.t φ p q = 0 := by + by_contra hne + obtain ⟨ψ, hψ₁, hψ₂⟩ := atom_iso_of_ne_zero f + (A.isAtom_S p) (A.isAtom_S q) hne + exact h ⟨⟨A.t φ p q, ψ, hψ₁, hψ₂⟩⟩ + +/-- **Multiplicativity of the matrix elements**: idempotent +insertion turns the composite's elements into the matrix product +of elements. -/ +theorem AtomResolution.t_comp (A : AtomResolution f M) + (φ ψ : End M) (p r : A.κ) : + A.t ((φ ≫ ψ : End M)) p r = + ∑ q : A.κ, (A.t φ p q ≫ A.t ψ q r : A.S p ⟶ A.S r) := by + apply Karoubi.hom_ext + rw [show ((∑ q : A.κ, (A.t φ p q ≫ A.t ψ q r : + A.S p ⟶ A.S r))).f = + ∑ q : A.κ, ((A.t φ p q ≫ A.t ψ q r : + A.S p ⟶ A.S r)).f from map_sum (karoubiHomAddHom _ _) _ _] + rw [A.t_f] + rw [show ((φ ≫ ψ : End M) p.1 r.1) = + ∑ j : M.ι, φ p.1 j ≫ ψ j r.1 from rfl] + rw [show ((∑ j : M.ι, φ p.1 j ≫ ψ j r.1 : + M.X p.1 ⟶ M.X r.1)).f = + ∑ j : M.ι, ((φ p.1 j ≫ ψ j r.1 : + M.X p.1 ⟶ M.X r.1)).f from map_sum (karoubiHomAddHom _ _) _ _] + rw [Preadditive.sum_comp, Preadditive.comp_sum] + rw [show (∑ q : A.κ, ((A.t φ p q ≫ A.t ψ q r : + A.S p ⟶ A.S r)).f) = + ∑ j : M.ι, ∑ b : A.idx j, + ((A.t φ p ⟨j, b⟩ ≫ A.t ψ ⟨j, b⟩ r : + A.S p ⟶ A.S r)).f from by + rw [← Finset.univ_sigma_univ, Finset.sum_sigma]] + refine Finset.sum_congr rfl fun j _ => ?_ + -- Per middle object: the inner idempotents sum to the + -- identity and absorb. + have hstep : ∀ b : A.idx j, + ((A.t φ p ⟨j, b⟩ ≫ A.t ψ ⟨j, b⟩ r : + A.S p ⟶ A.S r)).f = + (A.e p.1 p.2).f ≫ (φ p.1 j).f ≫ (A.e j b).f ≫ + (ψ j r.1).f ≫ (A.e r.1 r.2).f := by + intro b + rw [show ((A.t φ p ⟨j, b⟩ ≫ A.t ψ ⟨j, b⟩ r : + A.S p ⟶ A.S r)).f = + (A.t φ p ⟨j, b⟩).f ≫ (A.t ψ ⟨j, b⟩ r).f from rfl] + rw [A.t_f, A.t_f] + rw [show ((A.e p.1 p.2).f ≫ (φ p.1 j).f ≫ + (A.e j b).f) ≫ ((A.e j b).f ≫ (ψ j r.1).f ≫ + (A.e r.1 r.2).f) = + (A.e p.1 p.2).f ≫ (φ p.1 j).f ≫ + ((A.e j b).f ≫ (A.e j b).f) ≫ (ψ j r.1).f ≫ + (A.e r.1 r.2).f from by + simp only [Category.assoc]] + rw [show ((A.e j b).f ≫ (A.e j b).f : + (M.X j).X ⟶ (M.X j).X) = + (A.e j b * A.e j b).f from rfl] + rw [((A.complete j).idem b : + A.e j b * A.e j b = A.e j b)] + rw [Finset.sum_congr rfl fun b _ => hstep b] + rw [show (∑ b : A.idx j, (A.e p.1 p.2).f ≫ + (φ p.1 j).f ≫ (A.e j b).f ≫ (ψ j r.1).f ≫ + (A.e r.1 r.2).f) = + (A.e p.1 p.2).f ≫ (φ p.1 j).f ≫ + (∑ b : A.idx j, (A.e j b).f) ≫ (ψ j r.1).f ≫ + (A.e r.1 r.2).f from by + rw [Preadditive.sum_comp, Preadditive.comp_sum, + Preadditive.comp_sum]] + rw [show (∑ b : A.idx j, (A.e j b).f) = (M.X j).p from by + calc ∑ b : A.idx j, (A.e j b).f + = ((∑ b : A.idx j, A.e j b : End (M.X j))).f := + (map_sum (karoubiHomAddHom (M.X j) (M.X j)) _ _).symm + _ = ((1 : End (M.X j))).f := by + rw [(A.complete j).complete] + _ = (M.X j).p := rfl] + suffices h : ((φ p.1 j ≫ ψ j r.1 : + M.X p.1 ⟶ M.X r.1)).f = + (φ p.1 j).f ≫ (M.X j).p ≫ (ψ j r.1).f by + rw [h] + simp only [Category.assoc] + rw [show ((φ p.1 j ≫ ψ j r.1 : + M.X p.1 ⟶ M.X r.1)).f = + (φ p.1 j).f ≫ (ψ j r.1).f from rfl] + rw [show (φ p.1 j).f ≫ (M.X j).p ≫ (ψ j r.1).f = + ((φ p.1 j).f ≫ (M.X j).p) ≫ (ψ j r.1).f from + (Category.assoc _ _ _).symm] + rw [Karoubi.comp_p] + +/-! ### The scalar matrix -/ + +/-- Scalars are invariant under object-equality transport. -/ +theorem atomScalar_eqToHom_conj + {S T : Karoubi (SkeinObj f)} (h : S = T) + (hS : IsAtom f S) (hT : IsAtom f T) (z : End T) : + atomScalar hS + ((eqToHom h ≫ z ≫ eqToHom h.symm : End S)) = + atomScalar hT z := by + subst h + simp only [eqToHom_refl, Category.id_comp, + Category.comp_id] + +variable (A : AtomResolution f M) + +open scoped Classical in +/-- The scalar matrix of an endomorphism over the atoms. -/ +noncomputable def AtomResolution.B (φ : End M) : + Matrix A.κ A.κ ℂ := fun p q => + if h : A.rep p = A.rep q then + atomScalar (A.isAtom_S (A.rep p)) + (((A.w p).hom ≫ A.t φ p q ≫ (A.w q).inv ≫ + eqToHom (congrArg A.S h.symm) : + End (A.S (A.rep p)))) + else 0 + +/-- **The dichotomy**: the scalar matrix vanishes off the class +blocks, there being no isomorphism to transport along. -/ +theorem AtomResolution.B_apply_of_ne (φ : End M) {p q : A.κ} + (h : ¬ A.rep p = A.rep q) : A.B φ p q = 0 := + dite_eq_right h + +/-- The scalar matrix of the zero endomorphism is zero. -/ +theorem AtomResolution.B_zero : A.B (0 : End M) = 0 := by + funext p q + change A.B 0 p q = 0 + unfold AtomResolution.B + split_ifs with h + · rw [show A.t (0 : End M) p q = 0 from by + apply Karoubi.hom_ext + rw [A.t_f] + rw [show ((0 : End M) p.1 q.1) = 0 from rfl] + rw [show ((0 : M.X p.1 ⟶ M.X q.1)).f = 0 from rfl] + rw [Limits.zero_comp, Limits.comp_zero] + rfl] + rw [Limits.zero_comp] + rw [show ((A.w p).hom ≫ (0 : A.S p ⟶ A.S (A.rep p)) : + A.S (A.rep p) ⟶ A.S (A.rep p)) = + ((A.w p).hom ≫ 0 : End (A.S (A.rep p))) from rfl] + rw [Limits.comp_zero] + exact atomScalar_unique _ (by rw [zero_smul]) + · rfl + +/-- **Multiplicativity of the scalar matrix.** -/ +theorem AtomResolution.B_comp (φ ψ : End M) : + A.B ((φ ≫ ψ : End M)) = A.B φ * A.B ψ := by + funext p r + rw [Matrix.mul_apply] + by_cases h : A.rep p = A.rep r + · rw [show A.B ((φ ≫ ψ : End M)) p r = + atomScalar (A.isAtom_S (A.rep p)) + (((A.w p).hom ≫ A.t ((φ ≫ ψ : End M)) p r ≫ + (A.w r).inv ≫ eqToHom (congrArg A.S h.symm) : + End (A.S (A.rep p)))) from dite_eq_left h] + rw [A.t_comp φ ψ p r] + rw [show ((A.w p).hom ≫ + (∑ q : A.κ, (A.t φ p q ≫ A.t ψ q r : + A.S p ⟶ A.S r)) ≫ + (A.w r).inv ≫ eqToHom (congrArg A.S h.symm) : + End (A.S (A.rep p))) = + ∑ q : A.κ, ((A.w p).hom ≫ + (A.t φ p q ≫ A.t ψ q r) ≫ + (A.w r).inv ≫ eqToHom (congrArg A.S h.symm) : + End (A.S (A.rep p))) from by + rw [Preadditive.sum_comp, Preadditive.comp_sum]] + refine Eq.trans (show atomScalar (A.isAtom_S (A.rep p)) + (∑ q : A.κ, ((A.w p).hom ≫ + (A.t φ p q ≫ A.t ψ q r) ≫ + (A.w r).inv ≫ eqToHom (congrArg A.S h.symm) : + End (A.S (A.rep p)))) = + ∑ q : A.κ, atomScalar (A.isAtom_S (A.rep p)) + (((A.w p).hom ≫ (A.t φ p q ≫ A.t ψ q r) ≫ + (A.w r).inv ≫ eqToHom (congrArg A.S h.symm) : + End (A.S (A.rep p)))) from by + classical + induction (Finset.univ : Finset A.κ) using + Finset.induction_on with + | empty => + rw [Finset.sum_empty, Finset.sum_empty] + exact atomScalar_unique _ (by rw [zero_smul]) + | insert a s ha ih => + rw [Finset.sum_insert ha, Finset.sum_insert ha, + atomScalar_add, ih]) ?_ + refine Finset.sum_congr rfl fun q _ => ?_ + by_cases hq : A.rep p = A.rep q + · rw [show A.B φ p q = atomScalar (A.isAtom_S (A.rep p)) + (((A.w p).hom ≫ A.t φ p q ≫ (A.w q).inv ≫ + eqToHom (congrArg A.S hq.symm) : + End (A.S (A.rep p)))) from dite_eq_left hq] + have hqr : A.rep q = A.rep r := hq ▸ h + rw [show A.B ψ q r = atomScalar (A.isAtom_S (A.rep q)) + (((A.w q).hom ≫ A.t ψ q r ≫ (A.w r).inv ≫ + eqToHom (congrArg A.S hqr.symm) : + End (A.S (A.rep q)))) from dite_eq_left hqr] + rw [← atomScalar_eqToHom_conj (congrArg A.S hq) + (A.isAtom_S (A.rep p)) (A.isAtom_S (A.rep q))] + rw [← atomScalar_comp] + congr 1 + -- Pure composition algebra: cancel the middle iso and + -- the transport pair. + rw [show ((A.w p).hom ≫ A.t φ p q ≫ (A.w q).inv ≫ + eqToHom (congrArg A.S hq.symm) : _) ≫ + (eqToHom (congrArg A.S hq) ≫ + ((A.w q).hom ≫ A.t ψ q r ≫ (A.w r).inv ≫ + eqToHom (congrArg A.S hqr.symm)) ≫ + eqToHom (congrArg A.S hq).symm) = + (A.w p).hom ≫ A.t φ p q ≫ + ((A.w q).inv ≫ (A.w q).hom) ≫ A.t ψ q r ≫ + (A.w r).inv ≫ + (eqToHom (congrArg A.S hqr.symm) ≫ + eqToHom (congrArg A.S hq).symm) from by + simp only [Category.assoc, eqToHom_trans, + eqToHom_trans_assoc, eqToHom_refl, + Category.id_comp]] + rw [Iso.inv_hom_id, Category.id_comp] + rw [eqToHom_trans] + simp only [Category.assoc] + · rw [A.B_apply_of_ne φ hq, zero_mul] + rw [A.t_eq_zero φ (fun hrel => hq + (A.rep_eq_of_rel hrel))] + rw [Limits.zero_comp] + rw [show ((A.w p).hom ≫ + ((0 : A.S p ⟶ A.S r) ≫ + (A.w r).inv ≫ eqToHom (congrArg A.S h.symm)) : + End (A.S (A.rep p))) = + 0 from by + rw [Limits.zero_comp, Limits.comp_zero]] + exact atomScalar_unique _ (by rw [zero_smul]) + · rw [A.B_apply_of_ne _ h] + refine (Finset.sum_eq_zero fun q _ => ?_).symm + by_cases hq : A.rep p = A.rep q + · rw [A.B_apply_of_ne ψ (fun hqr => h (hq.trans hqr)), + mul_zero] + · rw [A.B_apply_of_ne φ hq, zero_mul] + +/-- The total atom index has decidable equality, classically. -/ +noncomputable instance AtomResolution.kappaDec : + DecidableEq A.κ := Classical.decEq _ + +/-- Powers transport to matrix powers. -/ +theorem AtomResolution.B_pow (φ : End M) (k : ℕ) : + A.B ((φ ^ (k + 1) : End M)) = (A.B φ) ^ (k + 1) := by + induction k with + | zero => rw [pow_one, pow_one] + | succ j ih => + rw [show (φ ^ (j + 1 + 1) : End M) = + ((φ ≫ φ ^ (j + 1) : End M)) from by + rw [show ((φ ≫ φ ^ (j + 1) : End M)) = + φ ^ (j + 1) * φ from rfl, ← pow_succ]] + rw [A.B_comp, ih, ← pow_succ'] + +/-- The diagonal scalar recovers the diagonal trace entry, up to +the class weight. -/ +theorem AtomResolution.trace_t_diag (φ : End M) (p : A.κ) : + HomSpace.traceMap f.val (M.X p.1).X.arity + (A.t φ p p).f = + A.B φ p p * + HomSpace.traceMap f.val + (M.X (A.rep p).1).X.arity + (Karoubi.Hom.f (𝟙 (A.S (A.rep p)))) := by + have hBpp : A.B φ p p = + atomScalar (A.isAtom_S (A.rep p)) + (((A.w p).hom ≫ A.t φ p p ≫ (A.w p).inv ≫ + eqToHom (congrArg A.S (rfl : A.rep p = A.rep p).symm) : + End (A.S (A.rep p)))) := dite_eq_left rfl + rw [show eqToHom (congrArg A.S + (rfl : A.rep p = A.rep p).symm) = + 𝟙 (A.S (A.rep p)) from eqToHom_refl _ _, + Category.comp_id] at hBpp + -- Recover t from its scalar through the chosen iso. + have hspec := atomScalar_spec (A.isAtom_S (A.rep p)) + (((A.w p).hom ≫ A.t φ p p ≫ (A.w p).inv ≫ + eqToHom (congrArg A.S (rfl : A.rep p = A.rep p).symm) : + End (A.S (A.rep p)))) + rw [show eqToHom (congrArg A.S + (rfl : A.rep p = A.rep p).symm) = + 𝟙 (A.S (A.rep p)) from eqToHom_refl _ _] at hspec + rw [Category.comp_id] at hspec + have ht : A.t φ p p = + A.B φ p p • ((A.w p).inv ≫ (A.w p).hom) := by + have h2 := congrArg + (fun z => (A.w p).inv ≫ z ≫ (A.w p).hom) hspec + rw [show (A.w p).inv ≫ ((A.w p).hom ≫ A.t φ p p ≫ + (A.w p).inv) ≫ (A.w p).hom = + ((A.w p).inv ≫ (A.w p).hom) ≫ A.t φ p p ≫ + ((A.w p).inv ≫ (A.w p).hom) from by + simp only [Category.assoc]] at h2 + rw [Iso.inv_hom_id, Category.id_comp] at h2 + rw [Category.comp_id] at h2 + rw [h2, ← hBpp] + rw [CategoryTheory.Linear.smul_comp, + CategoryTheory.Linear.comp_smul, Category.id_comp] + rw [show (A.t φ p p).f = + (A.B φ p p • ((A.w p).inv ≫ (A.w p).hom : + End (A.S p))).f from by rw [← ht]] + rw [show ((A.B φ p p • ((A.w p).inv ≫ (A.w p).hom : + End (A.S p)))).f = + A.B φ p p • (((A.w p).inv ≫ (A.w p).hom : + End (A.S p))).f from rfl] + rw [map_smul, smul_eq_mul] + congr 1 + -- The weight is class-constant: cyclicity swaps the iso pair. + rw [show (((A.w p).inv ≫ (A.w p).hom : End (A.S p))).f = + ((A.w p).inv).f ≫ ((A.w p).hom).f from rfl] + exact (HomSpace.traceMap_comp_comm f (((A.w p).inv).f) + (((A.w p).hom).f)).trans + (congrArg + (HomSpace.traceMap f.val (M.X (A.rep p).1).X.arity) + (show ((A.w p).hom).f ≫ ((A.w p).inv).f = + Karoubi.Hom.f (𝟙 (A.S (A.rep p))) from by + rw [show ((A.w p).hom).f ≫ ((A.w p).inv).f = + Karoubi.Hom.f ((A.w p).hom ≫ (A.w p).inv) + from rfl] + rw [Iso.hom_inv_id])) + +/-! ### Class-block restriction -/ + +/-- The scalar matrix is supported on class blocks. -/ +theorem AtomResolution.B_support (φ : End M) {p q : A.κ} + (h : A.B φ p q ≠ 0) : A.rep p = A.rep q := by + by_contra hne + exact h (A.B_apply_of_ne φ hne) + +/-- The class-block restriction of a matrix. -/ +noncomputable def AtomResolution.restrict (c : A.κ) + (X : Matrix A.κ A.κ ℂ) : + Matrix {p : A.κ // A.rep p = c} + {p : A.κ // A.rep p = c} ℂ := + fun p q => X p.val q.val + +/-- Products preserve block support. -/ +theorem AtomResolution.support_mul + (X Y : Matrix A.κ A.κ ℂ) + (hX : ∀ p q, X p q ≠ 0 → A.rep p = A.rep q) + (hY : ∀ p q, Y p q ≠ 0 → A.rep p = A.rep q) : + ∀ p q, (X * Y) p q ≠ 0 → A.rep p = A.rep q := by + intro p q h + rw [Matrix.mul_apply] at h + obtain ⟨r, _, hr⟩ := Finset.exists_ne_zero_of_sum_ne_zero h + have hXr : X p r ≠ 0 := fun h0 => hr (by rw [h0, zero_mul]) + have hYr : Y r q ≠ 0 := fun h0 => hr (by rw [h0, mul_zero]) + exact (hX p r hXr).trans (hY r q hYr) + +/-- Restriction respects products of block-supported +matrices. -/ +theorem AtomResolution.restrict_mul (c : A.κ) + (X Y : Matrix A.κ A.κ ℂ) + (hX : ∀ p q, X p q ≠ 0 → A.rep p = A.rep q) : + A.restrict c (X * Y) = + A.restrict c X * A.restrict c Y := by + classical + funext p q + rw [show A.restrict c (X * Y) p q = (X * Y) p.val q.val + from rfl] + rw [Matrix.mul_apply, Matrix.mul_apply] + rw [← Finset.sum_filter_add_sum_filter_not Finset.univ + (fun r => A.rep r = c) _] + rw [show (∑ r ∈ Finset.univ.filter + (fun r => ¬ A.rep r = c), + X p.val r * Y r q.val) = 0 from + Finset.sum_eq_zero fun r hr => by + rw [Finset.mem_filter] at hr + rw [show X p.val r = 0 from by + by_contra h0 + exact hr.2 ((hX p.val r h0).symm.trans p.prop)] + rw [zero_mul]] + rw [add_zero] + exact Finset.sum_subtype (Finset.univ.filter + (fun r => A.rep r = c)) + (fun r => by + rw [Finset.mem_filter] + exact ⟨fun h => h.2, fun h => ⟨Finset.mem_univ r, h⟩⟩) + (fun r => X p.val r * Y r q.val) + +/-- Powers preserve block support. -/ +theorem AtomResolution.support_pow + (X : Matrix A.κ A.κ ℂ) + (hX : ∀ p q, X p q ≠ 0 → A.rep p = A.rep q) (k : ℕ) : + ∀ p q, (X ^ (k + 1)) p q ≠ 0 → A.rep p = A.rep q := by + induction k with + | zero => + rw [pow_one] + exact hX + | succ l ihl => + rw [pow_succ X (l + 1)] + exact A.support_mul _ _ ihl hX + +/-- Restriction respects powers of block-supported matrices. -/ +theorem AtomResolution.restrict_pow (c : A.κ) + (X : Matrix A.κ A.κ ℂ) + (hX : ∀ p q, X p q ≠ 0 → A.rep p = A.rep q) (k : ℕ) : + A.restrict c (X ^ (k + 1)) = + (A.restrict c X) ^ (k + 1) := by + induction k with + | zero => rw [pow_one, pow_one] + | succ j ih => + rw [pow_succ X (j + 1), + pow_succ (A.restrict c X) (j + 1)] + rw [A.restrict_mul c _ _ (A.support_pow X hX j), ih] + +/-! ### The nilpotent leg -/ + +/-- The class weight: the closure trace of an atom identity. -/ +noncomputable def AtomResolution.δ (c : A.κ) : ℂ := + HomSpace.traceMap f.val (M.X c.1).X.arity + (Karoubi.Hom.f (𝟙 (A.S c))) + +/-- **The nilpotent leg**: nilpotent matrix-envelope +endomorphisms have vanishing diagonal trace. -/ +theorem matTrace_eq_zero_of_isNilpotent' + {φ : End M} (hφ : IsNilpotent φ) : + matTrace f M φ = 0 := by + classical + obtain ⟨k, hk⟩ := hφ + cases k with + | zero => + have h10 : (1 : End M) = 0 := by + rw [← pow_zero φ, hk] + have hφ0 : φ = 0 := by + calc φ = φ * 1 := (mul_one φ).symm + _ = φ * 0 := by rw [h10] + _ = 0 := mul_zero φ + rw [hφ0, map_zero] + | succ j => + set A := atomResolution f M with hA + have hBnil : (A.B φ) ^ (j + 1) = 0 := by + rw [← A.B_pow φ j, hk, A.B_zero] + calc matTrace f M φ + = ∑ p : A.κ, + HomSpace.traceMap f.val (M.X p.1).X.arity + ((A.e p.1 p.2).f ≫ (φ p.1 p.1).f ≫ + (A.e p.1 p.2).f) := by + rw [matTrace_resolution f A φ] + rw [← Finset.univ_sigma_univ, Finset.sum_sigma] + _ = ∑ p : A.κ, A.B φ p p * A.δ (A.rep p) := by + refine Finset.sum_congr rfl fun p _ => ?_ + exact A.trace_t_diag φ p + _ = ∑ c : A.κ, ∑ p ∈ Finset.univ.filter + (fun p => A.rep p = c), + A.B φ p p * A.δ (A.rep p) := + (Finset.sum_fiberwise_of_maps_to + (fun p _ => Finset.mem_univ (A.rep p)) _).symm + _ = ∑ c : A.κ, A.δ c * ∑ p ∈ Finset.univ.filter + (fun p => A.rep p = c), A.B φ p p := by + refine Finset.sum_congr rfl fun c _ => ?_ + rw [Finset.mul_sum] + refine Finset.sum_congr rfl fun p hp => ?_ + rw [Finset.mem_filter] at hp + rw [hp.2, mul_comm] + _ = 0 := by + refine Finset.sum_eq_zero fun c _ => ?_ + have htr : (∑ p ∈ Finset.univ.filter + (fun p => A.rep p = c), A.B φ p p) = + Matrix.trace (A.restrict c (A.B φ)) := + Finset.sum_subtype (Finset.univ.filter + (fun r => A.rep r = c)) + (fun r => by + rw [Finset.mem_filter] + exact ⟨fun h => h.2, + fun h => ⟨Finset.mem_univ r, h⟩⟩) + (fun r => A.B φ r r) + rw [htr] + have hnil : IsNilpotent + (A.restrict c (A.B φ)) := by + refine ⟨j + 1, ?_⟩ + rw [← A.restrict_pow c _ + (fun p q h => A.B_support φ h) j, hBnil] + funext p q + rfl + have := Matrix.isNilpotent_trace_of_isNilpotent + hnil + rw [IsNilpotent.eq_zero this, mul_zero] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentTrace.lean new file mode 100644 index 0000000000..21cfaaca25 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentTrace.lean @@ -0,0 +1,118 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinement +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HookVanishing + +/-! +# The nilpotent-trace theorem + +A `FrobeniusTower` is a `PermTower` together with an ambient algebra +`A`, trace functionals, tensor-power maps, and the Frobenius trace +identity `τ (rep (e μ) * pow g) = dim μ · s_μ[tr (g^·)]`. The main +theorem: in such a tower every nilpotent element of `A` has trace +zero. + +The proof composes the pieces already on the page: hook confinement +kills the idempotents of shapes outside a hook, the Frobenius +identity turns each death into vanishing of the Schur specialization +of the power-trace sequence, nilpotency makes that sequence +eventually zero, and the hook-vanishing engine +(`powerSums_zero_of_hook_and_eventually_zero`) then forces every +power trace — in particular the trace itself — to vanish. + +The skein construction discharges the tower fields: `rep` is the +permutation action on strand bundles, `pow` the tensor power of an +endomorphism, and `frobenius` the categorical Frobenius formula. +-/ + +@[expose] public section + +namespace RS + +universe u + +/-- A `PermTower` with an ambient algebra, traces, tensor-power +maps, and the Frobenius trace identity relative to a Schur +package. -/ +structure FrobeniusTower (P : SchurPackage.{u}) (E : ℕ → Type u) + [∀ n, Ring (E n)] [∀ n, Algebra ℂ (E n)] (A : ℝ) + (Alg : Type u) [Ring Alg] [Algebra ℂ Alg] extends PermTower E A where + /-- The trace on the ambient algebra. -/ + traceA : Alg →ₗ[ℂ] ℂ + /-- The traces on the tower algebras. -/ + trace : ∀ n, E n →ₗ[ℂ] ℂ + /-- The tensor-power maps. -/ + pow : ∀ n, Alg → E n + /-- The Frobenius trace identity: the trace of a Young idempotent + against a tensor power is the dimension times the Schur + specialization of the power-trace sequence. -/ + frobenius : ∀ (μ : YoungDiagram) (g : Alg), + trace μ.card (rep μ.card (P.e μ) * pow μ.card g) = + (P.dim μ : ℂ) * diagramSchur μ (fun m => traceA (g ^ m)) + +namespace FrobeniusTower + +variable {P : SchurPackage.{u}} {E : ℕ → Type u} + +/-- **Schur vanishing from hook confinement**: if every shape alive in +the tower lies in the `(s − 1, s − 1)` hook, the Schur specialization +of the power-trace sequence vanishes on every shape outside it. The +Frobenius identity turns a dead idempotent into a vanishing +specialization, and the block dimension is nonzero. -/ +theorem schur_vanishing_of_confinement + [∀ n, Ring (E n)] [∀ n, Algebra ℂ (E n)] {A : ℝ} {Alg : Type u} + [Ring Alg] [Algebra ℂ Alg] + (T : FrobeniusTower P E A Alg) + (g : Alg) {s : ℕ} + (hconf : ∀ μ : YoungDiagram, T.toPermTower.Alive P μ → + IsInHook (s - 1) (s - 1) μ) : + ∀ μ : YoungDiagram, ¬ IsInHook (s - 1) (s - 1) μ → + diagramSchur μ (fun m => T.traceA (g ^ m)) = 0 := by + intro μ hout + have hdead : T.rep μ.card (P.e μ) = 0 := + not_not.mp (fun halive => hout (hconf μ halive)) + have hfrob := T.frobenius μ g + rw [hdead, zero_mul, map_zero] at hfrob + have hdim : (P.dim μ : ℂ) ≠ 0 := + Nat.cast_ne_zero.mpr (P.dim_pos μ).ne' + exact (mul_eq_zero.mp hfrob.symm).resolve_left hdim + +/-- **The nilpotent-trace theorem**: in a Frobenius tower with +finite-dimensional levels, every nilpotent element of the ambient +algebra has trace zero. -/ +theorem traceA_eq_zero_of_isNilpotent + [∀ n, Ring (E n)] [∀ n, Algebra ℂ (E n)] {A : ℝ} {Alg : Type u} + [Ring Alg] [Algebra ℂ Alg] + [∀ n, Module.Finite ℂ (E n)] + (T : FrobeniusTower P E A Alg) {g : Alg} (hg : IsNilpotent g) : + T.traceA g = 0 := by + obtain ⟨s, hconf⟩ := T.toPermTower.hook_confinement P + set t : ℕ → ℂ := fun m => T.traceA (g ^ m) with ht + -- ═══════ Schur vanishing outside the hook ═══════ + have hvan : ∀ μ : YoungDiagram, ¬ IsInHook (s - 1) (s - 1) μ → + diagramSchur μ t = 0 := T.schur_vanishing_of_confinement g hconf + -- ═══════ Eventual vanishing from nilpotency ═══════ + have hev : ∃ N₀ : ℕ, ∀ m, N₀ ≤ m → t m = 0 := by + obtain ⟨N, hN⟩ := hg + refine ⟨N, fun m hm => ?_⟩ + have hzero : g ^ m = 0 := by + calc g ^ m = g ^ N * g ^ (m - N) := by + rw [← pow_add] + congr 1 + omega + _ = 0 := by rw [hN, zero_mul] + simp [ht, hzero] + -- ═══════ The engine ═══════ + have := powerSums_zero_of_hook_and_eventually_zero + hvan hev 1 le_rfl + simpa [ht] using this + +end FrobeniusTower + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/ObjectTower.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/ObjectTower.lean new file mode 100644 index 0000000000..fd77ea01db --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/ObjectTower.lean @@ -0,0 +1,184 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarPermTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPermCast +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZetaSharp + +/-! +# The Frobenius tower of an object + +The tensor powers of a single object in a rigid symmetric ℂ-linear +category, with the symmetric-group action permuting the factors and +the categorical trace, form a Frobenius tower. Everything the tower +asks for has been assembled: the representations are `permAlg`, +vanishing propagates by `permAlg_compat`, the traces are +`scalarTrace`, the tensor-power maps are `powHom`, and the Frobenius +identity comes from the cycle-type formula for the trace of a +permutation against a tensor power. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.MonoidalCategory + +universe v u + +variable {A : Type u} + +/-! ## The Frobenius identity -/ + +/-- **The Frobenius trace identity** for the tensor powers of an +object: the trace of a Young idempotent against a tensor power is +the block dimension times the Schur specialization of the power +traces. Expanding the idempotent turns the left side into a +character-weighted sum of permutation traces, and the cycle-type +formula turns each of those into the cycle product the classical +Frobenius formula sums. -/ +theorem frobenius_powHom + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] [RigidCategory A] + (hu : HasScalarUnit A) (X : A) + (P : SchurPackage.{v}) (μ : YoungDiagram) (g : End X) : + scalarTrace hu (tensorPow A X μ.card) + (permAlg X μ.card (P.e μ) * powHom X g μ.card) = + (P.dim μ : ℂ) * + diagramSchur μ (fun m => scalarTrace hu X (g ^ m)) := by + classical + set t : ℕ → ℂ := fun m => scalarTrace hu X (g ^ m) with ht + have hexp : permAlg X μ.card (P.e μ) * powHom X g μ.card = + ((P.dim μ : ℂ) / (μ.card.factorial : ℂ)) • + ∑ π : Equiv.Perm (Fin μ.card), P.char μ π • + (permAlg X μ.card (MonoidAlgebra.single π (1 : ℂ)) * + powHom X g μ.card) := by + rw [SchurPackage.e_def, charIdempotent, map_smul, map_sum, + smul_mul_assoc, Finset.sum_mul] + refine congrArg _ (Finset.sum_congr rfl fun π _ => ?_) + rw [map_smul, smul_mul_assoc] + rfl + have hterm : ∀ π : Equiv.Perm (Fin μ.card), + scalarTrace hu (tensorPow A X μ.card) + (P.char μ π • + (permAlg X μ.card (MonoidAlgebra.single π (1 : ℂ)) * + powHom X g μ.card)) = + P.char μ π * ((π.cycleType.map t).prod * + t 1 ^ (μ.card - π.cycleType.sum)) := by + intro π + have hmor : permAlg X μ.card (MonoidAlgebra.single π (1 : ℂ)) * + powHom X g μ.card = + powHom X g μ.card ≫ permMor X μ.card π := by + rw [permAlg_single] + rfl + rw [hmor, map_smul, smul_eq_mul] + refine congrArg (P.char μ π * ·) ?_ + rw [scalarTrace_comp_comm, scalarTrace_permMor_powHom, + prod_fullCycleType] + rw [hexp, map_smul, smul_eq_mul, map_sum, + Finset.sum_congr rfl fun π _ => hterm π, div_eq_mul_inv, + mul_assoc] + exact congrArg ((P.dim μ : ℂ) * ·) (P.frobenius μ t) + +/-! ## The tower -/ + +/-- **The Frobenius tower of an object**: the tensor powers of `X`, +with the symmetric-group action permuting the factors, the tensor +powers of an endomorphism, and the categorical trace read as a +complex number. -/ +noncomputable def objectFrobeniusTower + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] [RigidCategory A] + (hu : HasScalarUnit A) (X : A) + (P : SchurPackage.{v}) (A₀ : ℝ) + (hb : ∀ n, ((Module.finrank ℂ (End (tensorPow A X n)) : ℕ) : ℝ) ≤ + A₀ ^ n) : + FrobeniusTower P (fun n => End (tensorPow A X n)) A₀ (End X) where + rep := permAlg X + compat h x hx := permAlg_compat X h x hx + bound := hb + traceA := scalarTrace hu X + trace n := scalarTrace hu (tensorPow A X n) + pow n g := powHom X g n + frobenius μ g := frobenius_powHom hu X P μ g + +/-! ## The theorems of the appendix, for an object -/ + +open scoped Polynomial PowerSeries + +/-- **The nilpotent-trace theorem for an object**: in a rigid +symmetric ℂ-linear category with scalar unit endomorphisms, if the +tensor powers of `X` have finite-dimensional endomorphism algebras +of exponentially bounded dimension, then every nilpotent +endomorphism of `X` has vanishing categorical trace. -/ +theorem scalarTrace_eq_zero_of_isNilpotent + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] [RigidCategory A] + (hu : HasScalarUnit A) + (X : A) [∀ n, Module.Finite ℂ (End (tensorPow A X n))] + (A₀ : ℝ) + (hb : ∀ n, ((Module.finrank ℂ (End (tensorPow A X n)) : ℕ) : ℝ) ≤ + A₀ ^ n) {g : End X} (hg : IsNilpotent g) : + scalarTrace hu X g = 0 := + (objectFrobeniusTower hu X schurPackage.{v} A₀ + hb).traceA_eq_zero_of_isNilpotent hg + +/-- **The trace-zeta theorem for an object** (the accompanying +paper, Corollary A.2): for an object whose tensor powers have +endomorphism dimensions bounded by `A₀ ^ n`, and for every integer +`s > 2e√A₀`, the trace zeta function of every endomorphism is `P/Q` +with `P` and `Q` coprime, of constant term `1`, and of degree at +most `s − 1`. -/ +theorem traceZeta_rational_of_object + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] [RigidCategory A] + (hu : HasScalarUnit A) + (X : A) [∀ n, Module.Finite ℂ (End (tensorPow A X n))] + (A₀ : ℝ) + (hb : ∀ n, ((Module.finrank ℂ (End (tensorPow A X n)) : ℕ) : ℝ) ≤ + A₀ ^ n) (g : End X) {s : ℕ} + (hs : 2 * Real.exp 1 * Real.sqrt A₀ < s) : + ∃ Pp Qp : Polynomial ℂ, + Pp.coeff 0 = 1 ∧ Qp.coeff 0 = 1 ∧ + Pp.natDegree ≤ s - 1 ∧ Qp.natDegree ≤ s - 1 ∧ + IsCoprime Pp Qp ∧ + traceZeta (fun m => scalarTrace hu X (g ^ m)) * ↑Qp = + (↑Pp : PowerSeries ℂ) := by + exact (objectFrobeniusTower hu X schurPackage.{v} A₀ + hb).traceZeta_rational_sharp g hs + +/-- **The reduced super-spectrum form of Corollary A.2 for an object**: for +every integer `s > 2e√A₀` the power traces are a difference of power +sums of two disjoint multisets of nonzero complex numbers, each of +size at most `s − 1`. -/ +theorem traceZeta_superSpectrum_of_object + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] [RigidCategory A] + (hu : HasScalarUnit A) + (X : A) [∀ n, Module.Finite ℂ (End (tensorPow A X n))] + (A₀ : ℝ) + (hb : ∀ n, ((Module.finrank ℂ (End (tensorPow A X n)) : ℕ) : ℝ) ≤ + A₀ ^ n) (g : End X) {s : ℕ} + (hs : 2 * Real.exp 1 * Real.sqrt A₀ < s) : + ∃ alpha beta : Multiset ℂ, + alpha.card ≤ s - 1 ∧ beta.card ≤ s - 1 ∧ + (∀ x ∈ alpha, x ≠ 0) ∧ (∀ x ∈ beta, x ≠ 0) ∧ + (∀ x ∈ alpha, x ∉ beta) ∧ + ∀ m : ℕ, 1 ≤ m → + scalarTrace hu X (g ^ m) = + (alpha.map (· ^ m)).sum - (beta.map (· ^ m)).sum := by + exact (objectFrobeniusTower hu X schurPackage.{v} A₀ + hb).traceZeta_superSpectrum_sharp g hs + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/PermTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/PermTrace.lean new file mode 100644 index 0000000000..c6e3d39357 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/PermTrace.lean @@ -0,0 +1,203 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowSplit +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleTrace + +/-! +# The trace of a permutation against a tensor power + +The trace of `Φ(π) ∘ g ^ ⊗ n` for an arbitrary permutation `π`: it +is the product of `tr (g ^ c)` over the full cycle type of `π`, +fixed points included. + +The three ingredients are conjugation invariance, multiplicativity +over a block sum, and the value on a single cycle. Every +permutation is conjugate to a block sum of rotations whose block +lengths are its full cycle type (`exists_conj_blockCycles`), so the +three combine to give the general formula. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.MonoidalCategory + +universe v u + +variable {A : Type u} + +/-! ## Conjugation invariance -/ + +/-- **The trace is a class function.** Conjugating the permutation +leaves the trace unchanged: the action is functorial and commutes +with the tensor power, so the conjugating factors travel around the +loop and cancel. -/ +theorem catTrace_permMor_conj + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [RigidCategory A] + (X : A) (g : End X) (n : ℕ) + (ρ π : Equiv.Perm (Fin n)) : + catTrace (permMor X n (ρ * π * ρ⁻¹) ≫ powHom X g n) = + catTrace (permMor X n π ≫ powHom X g n) := by + have hsplit : permMor X n (ρ * π * ρ⁻¹) = + permMor X n ρ⁻¹ ≫ permMor X n π ≫ permMor X n ρ := by + rw [permMor_mul, permMor_mul] + have hcancel : permMor X n ρ ≫ permMor X n ρ⁻¹ = + 𝟙 (tensorPow A X n) := by + rw [← permMor_mul, inv_mul_cancel, permMor_one] + calc catTrace (permMor X n (ρ * π * ρ⁻¹) ≫ powHom X g n) + = catTrace (permMor X n ρ⁻¹ ≫ + (permMor X n π ≫ powHom X g n ≫ permMor X n ρ)) := by + rw [hsplit, Category.assoc, Category.assoc, + permMor_comp_powHom] + _ = catTrace ((permMor X n π ≫ powHom X g n ≫ permMor X n ρ) ≫ + permMor X n ρ⁻¹) := + catTrace_comp_comm _ _ + _ = catTrace (permMor X n π ≫ powHom X g n) := by + rw [Category.assoc, Category.assoc, hcancel, Category.comp_id] + +/-! ## Multiplicativity over a block sum -/ + +/-- **The trace is multiplicative over a block sum.** A block sum +of permutations acts blockwise on the splitting of the tensor power, +as does the tensor power of the endomorphism, so the loop factors +into the two blocks' loops. -/ +theorem catTrace_permMor_blockSum + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [RigidCategory A] + (X : A) (g : End X) {p q : ℕ} + (σ : Equiv.Perm (Fin p)) (τ : Equiv.Perm (Fin q)) : + catTrace (permMor X (p + q) (blockSum σ τ) ≫ + powHom X g (p + q)) = + catTrace (permMor X p σ ≫ powHom X g p) * + catTrace (permMor X q τ ≫ powHom X g q) := by + have hu : (permMor X (p + q) (blockSum σ τ) ≫ + powHom X g (p + q)) ≫ (splitPow X p q).hom = + (splitPow X p q).hom ≫ + ((permMor X p σ ≫ powHom X g p) ⊗ₘ + (permMor X q τ ≫ powHom X g q)) := by + calc (permMor X (p + q) (blockSum σ τ) ≫ + powHom X g (p + q)) ≫ (splitPow X p q).hom + = permMor X (p + q) (blockSum σ τ) ≫ + (powHom X g (p + q) ≫ (splitPow X p q).hom) := + Category.assoc _ _ _ + _ = permMor X (p + q) (blockSum σ τ) ≫ + ((splitPow X p q).hom ≫ + (powHom X g p ⊗ₘ powHom X g q)) := + congrArg (fun z => permMor X (p + q) (blockSum σ τ) ≫ z) + (powHom_comp_splitPow X g p q) + _ = (permMor X (p + q) (blockSum σ τ) ≫ + (splitPow X p q).hom) ≫ + (powHom X g p ⊗ₘ powHom X g q) := + (Category.assoc _ _ _).symm + _ = ((splitPow X p q).hom ≫ + (permMor X p σ ⊗ₘ permMor X q τ)) ≫ + (powHom X g p ⊗ₘ powHom X g q) := + congrArg (fun z => z ≫ (powHom X g p ⊗ₘ powHom X g q)) + (permMor_comp_splitPow X σ q τ) + _ = (splitPow X p q).hom ≫ + ((permMor X p σ ⊗ₘ permMor X q τ) ≫ + (powHom X g p ⊗ₘ powHom X g q)) := + Category.assoc _ _ _ + _ = (splitPow X p q).hom ≫ + ((permMor X p σ ≫ powHom X g p) ⊗ₘ + (permMor X q τ ≫ powHom X g q)) := + congrArg (fun z => (splitPow X p q).hom ≫ z) + (tensorHom_comp_tensorHom _ _ _ _) + calc catTrace (permMor X (p + q) (blockSum σ τ) ≫ + powHom X g (p + q)) + = catTrace (((permMor X (p + q) (blockSum σ τ) ≫ + powHom X g (p + q)) ≫ (splitPow X p q).hom) ≫ + (splitPow X p q).inv) := by + rw [Category.assoc, Iso.hom_inv_id, Category.comp_id] + _ = catTrace ((splitPow X p q).inv ≫ + ((permMor X (p + q) (blockSum σ τ) ≫ + powHom X g (p + q)) ≫ (splitPow X p q).hom)) := + catTrace_comp_comm _ _ + _ = catTrace ((splitPow X p q).inv ≫ ((splitPow X p q).hom ≫ + ((permMor X p σ ≫ powHom X g p) ⊗ₘ + (permMor X q τ ≫ powHom X g q)))) := + congrArg (fun z => catTrace ((splitPow X p q).inv ≫ z)) hu + _ = catTrace ((permMor X p σ ≫ powHom X g p) ⊗ₘ + (permMor X q τ ≫ powHom X g q)) := by + rw [← Category.assoc, Iso.inv_hom_id, Category.id_comp] + _ = catTrace (permMor X p σ ≫ powHom X g p) * + catTrace (permMor X q τ ≫ powHom X g q) := + catTrace_tensorHom _ _ + +/-! ## A single cycle -/ + +/-- **The trace of a full rotation**: the rotation of `m + 1` slots +against the tensor power of `g` traces to `tr (g ^ (m + 1))`. -/ +theorem catTrace_permMor_finRotate + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [RigidCategory A] + (X : A) (g : End X) (m : ℕ) : + catTrace (permMor X (m + 1) (finRotate (m + 1)) ≫ + powHom X g (m + 1)) = catTrace (g ^ (m + 1)) := by + rw [← topCycle_zero, permMor_topCycle, + show ((0 : Fin (m + 1)) : ℕ) = 0 from rfl, Nat.sub_zero, + catTrace_insertTop X g (le_refl m), Nat.sub_self, pow_zero, + one_mul] + +/-! ## A block sum of rotations -/ + +/-- **The trace of a block sum of rotations** is the product of the +cycle traces of its block lengths. -/ +theorem catTrace_blockCycles + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [RigidCategory A] + (X : A) (g : End X) : + ∀ l : List ℕ, (∀ c ∈ l, 1 ≤ c) → + catTrace (permMor X l.sum (blockCycles l) ≫ + powHom X g l.sum) = + (l.map (fun c => catTrace (g ^ c))).prod + | [], _ => by + change catTrace (permMor X 0 1 ≫ powHom X g 0) = 1 + rw [permMor_one, powHom_zero] + erw [Category.id_comp] + exact (catTrace_id _).trans catDim_unit + | c :: rest, hmem => by + obtain ⟨m, rfl⟩ : ∃ m, c = m + 1 := + ⟨c - 1, by have := hmem c (by simp); omega⟩ + have hrest : ∀ d ∈ rest, 1 ≤ d := fun d hd => + hmem d (by simp [hd]) + change catTrace (permMor X ((m + 1) + rest.sum) + (blockSum (finRotate (m + 1)) (blockCycles rest)) ≫ + powHom X g ((m + 1) + rest.sum)) = _ + rw [catTrace_permMor_blockSum, catTrace_permMor_finRotate, + catTrace_blockCycles X g rest hrest, List.map_cons, + List.prod_cons] + +/-! ## An arbitrary permutation -/ + +/-- **The trace of a permutation against a tensor power.** It is +the product of `tr (g ^ c)` over the full cycle type of the +permutation, fixed points contributing `tr g`. Every permutation is +conjugate to the block sum of rotations along its full cycle type, +and the trace is a class function. -/ +theorem catTrace_permMor_powHom + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [RigidCategory A] + (X : A) (g : End X) {n : ℕ} + (π : Equiv.Perm (Fin n)) : + catTrace (permMor X n π ≫ powHom X g n) = + ((fullCycleType π).map (fun c => catTrace (g ^ c))).prod := by + obtain ⟨l, hsum, ρ, hmem, hcoe, hconj⟩ := exists_conj_blockCycles π + subst hsum + have hfin : (finCongr (rfl : l.sum = l.sum)).permCongr + (blockCycles l) = blockCycles l := by + simp [show (Equiv.refl (Fin l.sum)) = + (1 : Equiv.Perm (Fin l.sum)) from rfl] + rw [← hcoe, ← hconj, hfin, catTrace_permMor_conj, + catTrace_blockCycles X g l hmem] + simp + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/RankDimension.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/RankDimension.lean new file mode 100644 index 0000000000..70a4c66a84 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/RankDimension.lean @@ -0,0 +1,56 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.DimensionDefinitions +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower + +/-! +# Connection ranks as skein dimensions + +The first isomorphism theorem identifies the connection-map range +with the skein Hom space. At even arity this is the endomorphism +algebra used by the commutant estimate. +-/ + +@[expose] public section + +namespace RS + +/-- The connection rank is the dimension of the corresponding +skein Hom space. -/ +theorem connectionRank_eq_homSpace_finrank + (f : ClosedFragment → ℂ) (t : ℕ) : + connectionRank f t = Module.finrank ℂ (HomSpace f t) := + (HomSpace.equivRange f t).finrank_eq.symm + +/-- At even arity, connection rank is the dimension of the +endomorphism algebra on half as many strands. -/ +theorem connectionRank_eq_skeinEnd_finrank {R : ℕ} + (f : EdgeRankParameter R) (n : ℕ) : + connectionRank f.val (2 * n) = Module.finrank ℂ (skeinEnd f n) := by + rw [connectionRank_eq_homSpace_finrank, two_mul] + rfl + +/-- Under the edge-rank hypothesis, natural connection rank agrees +with the actual module rank of the connection-map range. -/ +theorem connectionRank_cast_eq_rank {R : ℕ} + (f : EdgeRankParameter R) (t : ℕ) : + (connectionRank f.val t : Cardinal) = + Module.rank ℂ (LinearMap.range (connectionMap f.val t)) := by + rw [connectionRank_eq_homSpace_finrank, Module.finrank_eq_rank, + (HomSpace.equivRange f.val t).rank_eq] + +/-- The natural connection ranks satisfy every edge-rank bound +of the parameter, independently of its original packaged base. -/ +theorem connectionRank_le_pow {f : ClosedFragment → ℂ} {B : ℕ} + (h : EdgeRankBounded f B) (t : ℕ) : + connectionRank f t ≤ B ^ t := by + apply Module.finrank_le_of_rank_le + simpa only [Nat.cast_pow] using h t + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarPermTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarPermTrace.lean new file mode 100644 index 0000000000..f3f9a7ad82 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarPermTrace.lean @@ -0,0 +1,56 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.PermTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarTrace + +/-! +# The scalar cycle-trace formula + +The categorical cycle-trace formula read through the scalar unit. +This is the common trace input to the factorial obstruction and to +the Frobenius formula. Fixed points can be recorded separately +from the nontrivial cycles. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory CategoryTheory.MonoidalCategory + +universe v u + +variable {A : Type u} + +/-- The complex trace of a permutation against a tensor power is +the product of the complex cycle traces over the full cycle type. -/ +theorem scalarTrace_permMor_powHom + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] [MonoidalPreadditive A] + [MonoidalLinear ℂ A] [RigidCategory A] + (hu : HasScalarUnit A) (X : A) + (g : End X) {n : ℕ} (π : Equiv.Perm (Fin n)) : + scalarTrace hu (tensorPow A X n) + (permMor X n π ≫ powHom X g n) = + ((fullCycleType π).map + (fun c => scalarTrace hu X (g ^ c))).prod := by + change unitScalar hu (catTrace (permMor X n π ≫ powHom X g n)) = _ + rw [catTrace_permMor_powHom, map_multiset_prod, Multiset.map_map] + rfl + +/-- The full cycle type splits the product into the cycle type and +the fixed points. -/ +theorem prod_fullCycleType {n : ℕ} (π : Equiv.Perm (Fin n)) + (t : ℕ → ℂ) : + ((fullCycleType π).map t).prod = + (π.cycleType.map t).prod * t 1 ^ (n - π.cycleType.sum) := by + rw [fullCycleType, Multiset.map_add, Multiset.prod_add, + Multiset.map_replicate, Multiset.prod_replicate] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarTrace.lean new file mode 100644 index 0000000000..d28788d647 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarTrace.lean @@ -0,0 +1,72 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Trace +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LinearCategory + +/-! +# The trace as a complex number + +The categorical trace lands in `End (𝟙_ C)`, the endomorphisms of +the tensor unit. When those are exactly the scalars — the +hypothesis `HasScalarUnit` — that monoid is ℂ, and the trace becomes +a complex-valued linear functional, which is what a tower's +trace fields ask for. + +Cyclicity carries across the identification unchanged. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +variable {C : Type u} + +/-- **The unit's endomorphisms are the scalars**, as an algebra +isomorphism. This is `HasScalarUnit` read as bijectivity of the +structure map. -/ +noncomputable def unitScalarEquiv + [Category.{v} C] [Preadditive C] [Linear ℂ C] [MonoidalCategory C] + (h : HasScalarUnit C) : + ℂ ≃ₐ[ℂ] End (𝟙_ C) := + AlgEquiv.ofBijective (Algebra.ofId ℂ (End (𝟙_ C))) h + +/-- **The scalar named by an endomorphism of the unit.** -/ +noncomputable def unitScalar + [Category.{v} C] [Preadditive C] [Linear ℂ C] [MonoidalCategory C] + (h : HasScalarUnit C) : + End (𝟙_ C) →ₐ[ℂ] ℂ := + (unitScalarEquiv h).symm + +/-! ## The complex-valued trace -/ + +/-- **The complex-valued categorical trace.** -/ +noncomputable def scalarTrace + [Category.{v} C] [Preadditive C] [Linear ℂ C] [MonoidalCategory C] + [SymmetricCategory C] [MonoidalPreadditive C] [MonoidalLinear ℂ C] + [RigidCategory C] + (h : HasScalarUnit C) (X : C) : + End X →ₗ[ℂ] ℂ := + (unitScalar h).toLinearMap.comp (catTraceLin X) + +/-- The complex-valued trace is cyclic. -/ +theorem scalarTrace_comp_comm + [Category.{v} C] [Preadditive C] [Linear ℂ C] [MonoidalCategory C] + [SymmetricCategory C] [MonoidalPreadditive C] [MonoidalLinear ℂ C] + [RigidCategory C] + (h : HasScalarUnit C) {X Y : C} + (f : X ⟶ Y) (g : Y ⟶ X) : + scalarTrace h X (f ≫ g) = scalarTrace h Y (g ≫ f) := by + change unitScalar h (catTrace (f ≫ g)) = unitScalar h (catTrace (g ≫ f)) + rw [catTrace_comp_comm] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SemisimpleAll.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SemisimpleAll.lean new file mode 100644 index 0000000000..1342bc852d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SemisimpleAll.lean @@ -0,0 +1,56 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactorialTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleEnd + +/-! +# Trace nondegeneracy, in Hom-typed form + +`HomSpace.eq_zero_of_traces_vanish` is stated at the `HomSpace` +level; the Karoubi envelope needs it at morphisms of skein objects, +where the closure partner ranges over morphisms rather than +fragments. Both forms are the same statement read through +`HomSpace.ofFragment`. + +With the nilpotent-trace vanishing of `BlockFactorialTrace`, this is +what `isSemisimpleRing_of_trace` consumes to make every skein +endomorphism algebra semisimple. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- Trace nondegeneracy in the fully Hom-typed form: an +endomorphism of a skein object all of whose composites have +vanishing trace is zero. -/ +theorem end_eq_zero_of_traces_vanish (Y : SkeinObj f) + (a : Y ⟶ Y) + (ha : ∀ b : Y ⟶ Y, + HomSpace.traceMap f.val Y.arity (a ≫ b) = 0) : + a = 0 := + HomSpace.eq_zero_of_traces_vanish f a + (fun G => ha (HomSpace.ofFragment f.val G)) + +/-- Mixed-Hom trace nondegeneracy: a morphism between skein +objects all of whose closures against reverse morphisms have +vanishing trace is zero. -/ +theorem hom_eq_zero_of_traces_vanish' (Y Z : SkeinObj f) + (a : Y ⟶ Z) + (ha : ∀ b : Z ⟶ Y, + HomSpace.traceMap f.val Y.arity (a ≫ b) = 0) : + a = 0 := + HomSpace.eq_zero_of_traces_vanish f a + (fun G => ha (HomSpace.ofFragment f.val G)) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SemisimpleEnd.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SemisimpleEnd.lean new file mode 100644 index 0000000000..f0333747fd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SemisimpleEnd.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Algebra.TraceCriterion + +/-! +# The algebraic trace criterion for envelope endomorphisms + +Re-exports the finite-dimensional semisimplicity criterion used by +the skein and envelope endomorphism algebras. +-/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinDimBound.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinDimBound.lean new file mode 100644 index 0000000000..d779db60e0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinDimBound.lean @@ -0,0 +1,98 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinementSharp +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorNonvanishing + +/-! +# The two halves of the dimension bound + +The tower half is unconditional: at any side `s > 2eR` the skein +representation kills the square block idempotent +(`skeinRep_square_dead`). The model half is parameterized -- any +linear map out of the group algebra that factors the kill and +admits a trace functional with plain or signed +constant-cycle-product character forces the constant below `s` +(`sector_bound_of_dead`, `sector_bound_of_dead_signed`), provided +the square Schur value at that constant is nonzero. + +The two are composed in `Interfaces/SectorDischarge.lean`, against +the sector traces of `SectorIntertwine.lean` and the binomial +determinant of `SymFun/LGVStrict.lean`. +-/ + +@[expose] public section + +namespace RS + +open Finset + +/-- The chosen block dimension is positive. -/ +theorem jtSimple_dim_pos (μ : YoungDiagram) : + 0 < nDim (jtSimple μ) := by + have := jtSimple_simple μ + have := IsSimpleModule.nontrivial + (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) (jtSimple μ) + have : Nontrivial (subCarrier (jtSimple μ)) := + inferInstanceAs (Nontrivial (jtSimple μ)) + exact Module.finrank_pos + +/-- **Square death in the skein tower**: at any side `s > 2eR` the +skein representation kills the square block idempotent. -/ +theorem skeinRep_square_dead {R : ℕ} (f : EdgeRankParameter R) + {s : ℕ} (hs : 2 * Real.exp 1 * R < s) : + skeinRep f (squareDiagram s).card + (charIdempotent (nDim (jtSimple (squareDiagram s))) + (jtChar (squareDiagram s))) = 0 := + not_not.mp ((skeinPermTower f).not_alive_square_sharp + (by rwa [Real.sqrt_sq (Nat.cast_nonneg R)])) + +/-- **The even sector bound**: a linear map with plain +constant-cycle-product character that kills the square idempotent +forces the constant below the side, given the Schur nonvanishing. -/ +theorem sector_bound_of_dead {s m : ℕ} {M : Type*} [AddCommGroup M] + [Module ℂ M] + (ρ : SymGroupAlgebra (squareDiagram s).card →ₗ[ℂ] M) + (tr : M →ₗ[ℂ] ℂ) + (htr : ∀ π, tr (ρ (MonoidAlgebra.of ℂ + (Equiv.Perm (Fin (squareDiagram s).card)) π)) = + cycleProd (fun _ => (m : ℂ)) π) + (hSchur : s ≤ m → + diagramSchur (squareDiagram s) (fun _ => (m : ℂ)) ≠ 0) + (h0 : ρ (charIdempotent (nDim (jtSimple (squareDiagram s))) + (jtChar (squareDiagram s))) = 0) : + m < s := by + by_contra h + push Not at h + exact charIdempotent_image_ne_zero m (squareDiagram s) + (nDim (jtSimple (squareDiagram s))) + (jtSimple_dim_pos (squareDiagram s)) ρ tr htr (hSchur h) h0 + +/-- **The odd sector bound**: the sign-twisted analogue, with the +Schur nonvanishing at the negated constant. -/ +theorem sector_bound_of_dead_signed {s m : ℕ} {M : Type*} + [AddCommGroup M] [Module ℂ M] + (ρ : SymGroupAlgebra (squareDiagram s).card →ₗ[ℂ] M) + (tr : M →ₗ[ℂ] ℂ) + (htr : ∀ π, tr (ρ (MonoidAlgebra.of ℂ + (Equiv.Perm (Fin (squareDiagram s).card)) π)) = + ((Equiv.Perm.sign π : ℤ) : ℂ) * + cycleProd (fun _ => (m : ℂ)) π) + (hSchur : s ≤ m → + diagramSchur (squareDiagram s) (fun _ => -(m : ℂ)) ≠ 0) + (h0 : ρ (charIdempotent (nDim (jtSimple (squareDiagram s))) + (jtChar (squareDiagram s))) = 0) : + m < s := by + by_contra h + push Not at h + exact charIdempotent_image_ne_zero_signed m (squareDiagram s) + (nDim (jtSimple (squareDiagram s))) + (jtSimple_dim_pos (squareDiagram s)) ρ tr htr (hSchur h) h0 + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTower.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTower.lean new file mode 100644 index 0000000000..6bb118f8fc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTower.lean @@ -0,0 +1,296 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinLinear +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PermCompose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTensor +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinement + +/-! +# The skein endomorphism tower + +Instantiation of the abstract `PermTower` at the skein category of +an `EdgeRankParameter R`: the family `skeinEnd f n` of endomorphism +algebras carries the symmetric-group representations given by +permutation fragments, the exponential dimension bound inherited +from the Hom-space rank bound, and vanishing propagation along the +standard embeddings (compatibility with `symCast`). + +## Main definitions + +* `skeinEnd f n` — the endomorphism algebra of the `n`-strand object +* `permToEnd f n` — the monoid hom `Perm (Fin n) →* skeinEnd f n` +* `skeinRep f n` — the representation `SymGroupAlgebra n →ₐ[ℂ] skeinEnd f n` +* `skeinPermTower f` — the `PermTower` instance + +## Implementation notes + +`skeinEnd` is defined as `CategoryTheory.End (SkeinObj.mk n)`, which +is definitionally `HomSpace f.val (n + n)`. This lives in `Type 1` +(since `Fragment` contains `Type`-valued fields); the universe +polymorphism of `PermTower` accommodates this. + +The monoid-hom direction uses `End.mul_def : x * y = y ≫ x`, so the +map `σ ↦ [permFragment σ]` is a genuine `MonoidHom` from +`Perm (Fin n)` to `End (SkeinObj.mk n)` by `permFragmentCompose`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-! ### The endomorphism algebra -/ + +/-- The endomorphism ℂ-algebra of the `n`-strand object of the skein +category. Definitionally `HomSpace f.val (n + n)`. -/ +noncomputable def skeinEnd (n : ℕ) : Type 1 := + End (SkeinObj.mk (f := f) n) + +/-- Each level of the tower is a ring. -/ +noncomputable instance skeinEndRing (n : ℕ) : Ring (skeinEnd f n) := + inferInstanceAs (Ring (End (SkeinObj.mk (f := f) n))) + +/-- And a ℂ-algebra. -/ +noncomputable instance skeinEndAlgebra (n : ℕ) : Algebra ℂ (skeinEnd f n) := + inferInstanceAs (Algebra ℂ (End (SkeinObj.mk (f := f) n))) + +/-- Its additive structure. -/ +noncomputable instance skeinEndAddCommGroup (n : ℕ) : + AddCommGroup (skeinEnd f n) := + inferInstanceAs (AddCommGroup (End (SkeinObj.mk (f := f) n))) + +/-- And its ℂ-module structure. -/ +noncomputable instance skeinEndModule (n : ℕ) : Module ℂ (skeinEnd f n) := + inferInstanceAs (Module ℂ (End (SkeinObj.mk (f := f) n))) + +/-! ### The permutation representation -/ + +/-- The class of a permutation fragment in the endomorphism algebra. -/ +noncomputable def permClass (n : ℕ) (σ : Equiv.Perm (Fin n)) : + skeinEnd f n := + HomSpace.ofFragment f.val (permFragment σ) + +/-- The map `σ ↦ [permFragment σ]` is a monoid homomorphism. +Identity: `permFragment 1 = strandBundle n` is the categorical +identity. Multiplication: `End.mul_def` reverses composition +order, and `permFragmentCompose τ σ` gives +`(permFragment τ).compose (permFragment σ) ≃ permFragment (σ * τ)`, +so `[P_σ] * [P_τ] = [P_τ] ≫ [P_σ] = [compose P_τ P_σ] = [P_{σ*τ}]`. -/ +noncomputable def permToEnd (n : ℕ) : + Equiv.Perm (Fin n) →* skeinEnd f n where + toFun σ := permClass f n σ + map_one' := by + change HomSpace.ofFragment f.val (permFragment 1) = + HomSpace.ofFragment f.val (strandBundle n) + rw [permFragment_one] + map_mul' σ τ := by + -- Goal: permClass f n (σ * τ) = permClass f n σ * permClass f n τ + -- End multiplication: x * y = y ≫ x (definitional) + -- So RHS = (permClass τ) ≫ (permClass σ) = comp (permClass τ) (permClass σ) + -- = ofFragment (compose (permFragment τ) (permFragment σ)) + -- = ofFragment (permFragment (σ * τ)) + change HomSpace.ofFragment f.val (permFragment (σ * τ)) = + HomSpace.comp f n n n + (HomSpace.ofFragment f.val (permFragment τ)) + (HomSpace.ofFragment f.val (permFragment σ)) + rw [HomSpace.comp_ofFragment] + exact (HomSpace.ofFragment_congr f + (permFragmentCompose τ σ)).symm + +/-- The symmetric-group representation on the `n`-strand endomorphism +algebra: the algebra homomorphism `SymGroupAlgebra n →ₐ[ℂ] skeinEnd f n` +obtained by lifting `permToEnd` through the universal property of the +group algebra. -/ +noncomputable def skeinRep (n : ℕ) : + SymGroupAlgebra n →ₐ[ℂ] skeinEnd f n := + MonoidAlgebra.lift ℂ (skeinEnd f n) (Equiv.Perm (Fin n)) + (permToEnd f n) + +/-- `skeinRep` on a single permutation is `permClass`. -/ +theorem skeinRep_of (n : ℕ) (σ : Equiv.Perm (Fin n)) : + skeinRep f n (MonoidAlgebra.of ℂ (Equiv.Perm (Fin n)) σ) = + permClass f n σ := + MonoidAlgebra.lift_of (permToEnd f n) σ + +/-! ### Finite-dimensionality and the rank bound -/ + +/-- The Hom space at arity `t` is a finite ℂ-module: its rank is +bounded by `R ^ t`, a natural number, so `rank < ℵ₀`. -/ +noncomputable instance homSpace_finite (t : ℕ) : + Module.Finite ℂ (HomSpace f.val t) := by + rw [← Module.rank_lt_aleph0_iff] + calc Module.rank ℂ (HomSpace f.val t) + ≤ (R : Cardinal) ^ t := HomSpace.rank_le f t + _ = ↑(R ^ t : ℕ) := (Nat.cast_pow R t).symm + _ < Cardinal.aleph0 := Cardinal.natCast_lt_aleph0 + +/-- The skein endomorphism algebra at level `n` is finite-dimensional. -/ +noncomputable instance skeinEnd_finite (n : ℕ) : + Module.Finite ℂ (skeinEnd f n) := + homSpace_finite f (n + n) + +/-- The finrank of a Hom space is at most `R ^ t`. -/ +theorem homSpace_finrank_le (t : ℕ) : + Module.finrank ℂ (HomSpace f.val t) ≤ R ^ t := by + have hrank := HomSpace.rank_le f t + rw [show (R : Cardinal) ^ t = ↑(R ^ t : ℕ) from (Nat.cast_pow R t).symm] + at hrank + exact Module.finrank_le_of_rank_le hrank + +/-- **The dimension bound**: `finrank ℂ (skeinEnd f n) ≤ R ^ (2 * n)`. +Uses `HomSpace.rank_le` at arity `n + n` and the identity `n + n = 2 * n`. -/ +theorem skeinEnd_finrank_le (n : ℕ) : + Module.finrank ℂ (skeinEnd f n) ≤ R ^ (2 * n) := by + change Module.finrank ℂ (HomSpace f.val (n + n)) ≤ R ^ (2 * n) + rw [show n + n = 2 * n from by omega] + exact homSpace_finrank_le f (2 * n) + +/-! ### Vanishing propagation (compat) + +The geometric content: extending a permutation σ ∈ S_m by identity +strands to get σ' ∈ S_n corresponds to tensoring the permutation +fragment with identity strands: + `permFragment σ' ≃ tensorFragment (permFragment σ) (strandBundle (n-m))`. +The linear factorization: both sides of `skeinRep n ∘ symCast h` +and `L ∘ skeinRep m` (where `L` = tensor-with-identity) agree on +group-algebra generators by the fragment equivalence, hence agree on +all elements by linearity; and linear maps send 0 to 0. +-/ + +/-- The tensor of a permutation fragment with identity strands is +equivalent to the extended permutation fragment. -/ +noncomputable def permFragmentExtendEquiv {m k : ℕ} + (σ : Equiv.Perm (Fin m)) (h : m ≤ m + k) : + (tensorFragment (permFragment σ) (strandBundle k)).Equiv + (permFragment (σ.viaEmbedding (Fin.castLEEmb h))) where + flagEquiv := + (Equiv.sumProdDistrib (Fin m) (Fin k) Bool).symm.trans + (Equiv.prodCongr finSumFinEquiv (Equiv.refl Bool)) + vertexEquiv := @Equiv.equivOfIsEmpty _ _ + (instIsEmptySum (α := Empty) (β := Empty)) Empty.instIsEmpty + attach_comm f := by + set τ := σ.viaEmbedding (Fin.castLEEmb h) + rcases f with ⟨i, b⟩ | ⟨j, b⟩ <;> cases b <;> + apply congrArg Sum.inr <;> apply Fin.ext + · -- Sum.inl (i, false): incoming σ-strand + -- LHS val: i.val RHS val: (interleaveEquiv ... (Sum.inl ...)).val + change i.val = (interleaveEquiv m m k k + (Sum.inl (⟨i.val, by have := i.isLt; omega⟩ : Fin (m + m)))).val + rw [show (⟨i.val, by have := i.isLt; omega⟩ : Fin (m + m)) = + Fin.castAdd m i from Fin.ext rfl, interleaveEquiv_inl_low]; rfl + · -- Sum.inl (i, true): outgoing σ-strand + -- LHS val: (m+k) + (τ (Fin.castAdd k i)).val + -- RHS val: (interleaveEquiv ... (Sum.inl ⟨m + (σ i).val, _⟩)).val + change (m + k) + (τ (Fin.castAdd k i)).val = + (interleaveEquiv m m k k + (Sum.inl (⟨m + (σ i).val, + by have := (σ i).isLt; omega⟩ : Fin (m + m)))).val + have : (τ (Fin.castAdd k i)).val = (σ i).val := by + rw [show (Fin.castAdd k i : Fin (m + k)) = + Fin.castLEEmb h i from Fin.ext rfl, + Equiv.Perm.viaEmbedding_apply]; rfl + rw [this, show (⟨m + (σ i).val, by have := (σ i).isLt; omega⟩ : + Fin (m + m)) = Fin.natAdd m (σ i) from Fin.ext rfl, + interleaveEquiv_inl_high]; rfl + · -- Sum.inr (j, false): incoming identity strand + -- LHS val: m + j.val RHS val: (interleaveEquiv ...).val + change m + j.val = (interleaveEquiv m m k k + (Sum.inr (⟨j.val, by have := j.isLt; omega⟩ : Fin (k + k)))).val + rw [show (⟨j.val, by have := j.isLt; omega⟩ : Fin (k + k)) = + Fin.castAdd k j from Fin.ext rfl, interleaveEquiv_inr_low]; rfl + · -- Sum.inr (j, true): outgoing identity strand + -- LHS val: (m+k) + (τ (Fin.natAdd m j)).val + -- RHS val: (interleaveEquiv ... (Sum.inr ⟨k + j.val, _⟩)).val + change (m + k) + (τ (Fin.natAdd m j)).val = + (interleaveEquiv m m k k + (Sum.inr (⟨k + j.val, + by have := j.isLt; omega⟩ : Fin (k + k)))).val + have : (τ (Fin.natAdd m j)).val = (Fin.natAdd m j).val := + congrArg Fin.val (Equiv.Perm.viaEmbedding_apply_of_notMem σ + (Fin.castLEEmb h) (Fin.natAdd m j) + (fun ⟨a, ha⟩ => absurd (congrArg Fin.val ha) + (by simp [Fin.castLEEmb]; omega))) + rw [this, show (⟨k + j.val, by have := j.isLt; omega⟩ : + Fin (k + k)) = Fin.natAdd k j from Fin.ext rfl, + interleaveEquiv_inr_high]; rfl + pairing_comm f := by + rcases f with ⟨i, b⟩ | ⟨j, b⟩ <;> rfl + circles_eq := rfl + +/-- The per-generator tensor identity: extending a permutation class +by identity strands agrees with tensoring. -/ +theorem permClass_extend (m k : ℕ) (σ : Equiv.Perm (Fin m)) + (h : m ≤ m + k) : + HomSpace.tensor f m m k k (permClass f m σ) + (HomSpace.ofFragment f.val (strandBundle k)) = + permClass f (m + k) + (σ.viaEmbedding (Fin.castLEEmb h)) := by + unfold permClass + rw [HomSpace.tensor_ofFragment] + exact HomSpace.ofFragment_congr f (permFragmentExtendEquiv σ h) + +/-- Vanishing propagation: if `x` is in the kernel of the level-`m` +representation, its image under `symCast` is in the kernel at +level `n`. -/ +theorem skeinRep_compat {m n : ℕ} (h : m ≤ n) (x : SymGroupAlgebra m) + (hx : skeinRep f m x = 0) : + skeinRep f n (symCast h x) = 0 := by + obtain ⟨k, rfl⟩ := Nat.exists_eq_add_of_le h + -- L = tensor-with-identity: the linear map skeinEnd m →ₗ skeinEnd (m+k) + let idClass := HomSpace.ofFragment f.val (strandBundle k) + let L := LinearMap.flip (HomSpace.tensor f m m k k) idClass + -- Factor: skeinRep (m+k) ∘ symCast = L ∘ skeinRep m on generators, + -- hence on all elements by linearity. + suffices hfact : ∀ y : SymGroupAlgebra m, + skeinRep f (m + k) (symCast _ y) = L (skeinRep f m y) by + exact (hfact x).trans ((congrArg L hx).trans (map_zero L)) + intro y + apply MonoidAlgebra.induction_on y + · intro σ + have hsym : symCast h (MonoidAlgebra.of ℂ _ σ) = + MonoidAlgebra.of ℂ _ (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ) + := by + change MonoidAlgebra.mapDomain _ (MonoidAlgebra.single σ 1) = + MonoidAlgebra.single _ 1 + exact MonoidAlgebra.mapDomain_single + conv_lhs => rw [hsym, skeinRep_of] + exact ((congrArg L (skeinRep_of f m σ)).trans (permClass_extend f m k σ + h)).symm + · intro y₁ y₂ ih₁ ih₂ + simp only [map_add, ih₁, ih₂] + exact (map_add L _ _).symm + · intro c z ih + simp only [map_smul, ih] + exact (map_smul L c _).symm + +/-! ### The tower instance -/ + +/-- **The skein endomorphism tower**: the `PermTower` at growth +`R ^ 2` on the family `skeinEnd f`, with the symmetric-group +representation given by permutation fragments, compatibility from +the tensor extension, and the dimension bound from the Hom-space +rank bound. The growth constant is `R ^ 2` because the tower's +bound is `A ^ n` while the Hom-space bound is `R ^ (2n)`; its square +root, which is what the threshold `2e√A` reads, is `R`. -/ +noncomputable def skeinPermTower : + PermTower (skeinEnd f) ((R : ℝ) ^ 2) where + rep := skeinRep f + compat h x hx := skeinRep_compat f h x hx + bound n := by + have h : ((Module.finrank ℂ (skeinEnd f n) : ℕ) : ℝ) + ≤ ((R ^ (2 * n) : ℕ) : ℝ) := by + exact_mod_cast skeinEnd_finrank_le f n + calc ((Module.finrank ℂ (skeinEnd f n) : ℕ) : ℝ) + ≤ ((R ^ (2 * n) : ℕ) : ℝ) := h + _ = ((R : ℝ) ^ 2) ^ n := by push_cast; rw [← pow_mul] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTrace.lean new file mode 100644 index 0000000000..dfd41ef624 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTrace.lean @@ -0,0 +1,87 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseUnion +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarFunctional + +/-! +# The skein trace + +The trace of an `n`-strand endomorphism -- its closure against +the strand bundle -- and the one fact the trace calculus needs of +it: closing a tensor product multiplies the two closures, proved +by bilinear induction down to single fragments. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The trace of an `n`-strand endomorphism: the closure against +the strand bundle. -/ +noncomputable def skeinTrace (n : ℕ) (g : skeinEnd f n) : ℂ := + HomSpace.traceMap f.val n g + +/-- **The trace of a tensor product is the product of traces.** -/ +theorem skeinTrace_tensorHom {a b : ℕ} + (u : skeinEnd f a) (v : skeinEnd f b) : + skeinTrace f (a + b) + (show skeinEnd f (a + b) from + MonoidalCategoryStruct.tensorHom u v) = + skeinTrace f a u * skeinTrace f b v := by + -- Reduce to HomSpace operations + change HomSpace.traceMap f.val (a + b) + (HomSpace.tensor f a a b b u v) = + HomSpace.traceMap f.val a u * HomSpace.traceMap f.val b v + -- Lift u, v to free-module representatives + obtain ⟨xu, rfl⟩ := Submodule.Quotient.mk_surjective _ u + obtain ⟨xv, rfl⟩ := Submodule.Quotient.mk_surjective _ v + -- At the free module level + change traceFunctional f.val (a + b) (tensorFinsupp a a b b xu xv) = + traceFunctional f.val a xu * traceFunctional f.val b xv + -- Helper: traceFunctional on a scaled single fragment + have htr : ∀ (n : ℕ) (H : Fragment (Fin (n + n))) (e : ℂ), + traceFunctional f.val n (Finsupp.single H e) = + e * fragTrace f.val H := by + intro n H e + rw [show (Finsupp.single H e : Fragment (Fin (n + n)) →₀ ℂ) = + e • Finsupp.single H 1 by + rw [Finsupp.smul_single, smul_eq_mul, mul_one], + map_smul, traceFunctional_single, smul_eq_mul] + -- Bilinear induction on xu + induction xu using Finsupp.induction_linear with + | zero => + simp only [map_zero, LinearMap.zero_apply, zero_mul] + | add x₁ x₂ h₁ h₂ => + simp only [map_add, LinearMap.add_apply] + rw [h₁, h₂, add_mul] + | single F c => + induction xv using Finsupp.induction_linear with + | zero => + simp only [map_zero, mul_zero] + | add y₁ y₂ h₁ h₂ => + simp only [map_add] + rw [h₁, h₂, mul_add] + | single G d => + rw [tensorFinsupp_single, htr, htr, htr, fragTrace_tensor] + ring + +/-- The trace of the empty identity is one. -/ +theorem skeinTrace_zero_one : + skeinTrace f 0 (1 : skeinEnd f 0) = 1 := + (traceMap_zero_ofFragment f (strandBundle 0)).trans + ((f.iso_invariant _ _ strandBundleZeroEmpty).trans + f.val_empty) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SuperKill.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SuperKill.lean new file mode 100644 index 0000000000..b3f603e520 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SuperKill.lean @@ -0,0 +1,49 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinDimBound +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaTensorPower + +/-! +# Square death at the super level + +The kill chain: vanishing under the skein representation +propagates through the fibre functor to the conjugated super +permutation action, and in particular the square block idempotent +at any side `s > 2eR` dies at the super level — the unconditional +half of the sector dichotomy. +-/ + +@[expose] public section + +namespace RS + +variable {R : ℕ} (f : EdgeRankParameter R) + (P : DelignePackage (SkeinObj f)) + +/-- **The kill chain**: vanishing under the skein representation +propagates to the super permutation action. -/ +theorem skeinRep_zero_imp_superPermAction_zero (n : ℕ) + (x : SymGroupAlgebra n) (hx : skeinRep f n x = 0) : + superPermAction f P n x = 0 := by + let := P.additive + let := P.linear + rw [superPermAction_eq_zero_iff, omegaSkeinRep_eq, hx] + exact P.ω.map_zero _ _ + +/-- **Square death at the super level**: at any side `s > 2eR` the +super permutation action kills the square block idempotent. -/ +theorem superPermAction_square_dead {s : ℕ} + (hs : 2 * Real.exp 1 * R < s) : + superPermAction f P (squareDiagram s).card + (charIdempotent (nDim (jtSimple (squareDiagram s))) + (jtChar (squareDiagram s))) = 0 := + skeinRep_zero_imp_superPermAction_zero f P _ _ + (skeinRep_square_dead f hs) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPerm.lean new file mode 100644 index 0000000000..d1da7d18cc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPerm.lean @@ -0,0 +1,678 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.TensorPow +public import LeanPool.RegtsSevenster.RS.Common.PermTopSplit +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage + +/-! +# The symmetric-group action on a tensor power + +In a symmetric monoidal category, the tensor power `X ^ ⊗ n` carries +an action of `S_n` permuting its factors. Mathlib has the monoidal +coherence theorem but not the symmetric one, and no presentation of +`S_n`, so the action is built here by an explicit recursion that +makes no choice of word: the factor in the top slot is bubbled down +to its destination by adjacent braidings (`insertTop`), and the rest +is handled by the recursion at one lower arity (`permMor`). + +The two primitives are the adjacent braiding on the top two slots +(`swapTop`) and the insertion cycle (`insertTop`). Functoriality of +the recursion follows from mere generation of `S_n` by the adjacent +transpositions — no presentation is needed — and the linear +structure then turns the action into the algebra map `permAlg` that +a tower's representation field asks for. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +variable {A : Type u} + +/-! ## The adjacent braiding on the top two slots -/ + +/-- **The top transposition**: braid the last two factors of +`X ^ ⊗ (n + 2)`. Reassociating exposes the last two tensorands, the +braiding exchanges them, and the associator is undone. -/ +noncomputable def swapTop + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (n : ℕ) : + tensorPow A X (n + 2) ⟶ tensorPow A X (n + 2) := + (α_ (tensorPow A X n) X X).hom ≫ + (tensorPow A X n ◁ (β_ X X).hom) ≫ + (α_ (tensorPow A X n) X X).inv + +/-- The top transposition is an involution: the braiding of a +symmetric category squares to the identity. -/ +@[simp] +theorem swapTop_swapTop + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (n : ℕ) : + swapTop X n ≫ swapTop X n = 𝟙 (tensorPow A X (n + 2)) := by + change ((α_ (tensorPow A X n) X X).hom ≫ + (tensorPow A X n ◁ (β_ X X).hom) ≫ (α_ (tensorPow A X n) X X).inv) ≫ + ((α_ (tensorPow A X n) X X).hom ≫ + (tensorPow A X n ◁ (β_ X X).hom) ≫ (α_ (tensorPow A X n) X X).inv) = + 𝟙 ((tensorPow A X n ⊗ X) ⊗ X) + simp only [Category.assoc, Iso.inv_hom_id_assoc] + rw [← MonoidalCategory.whiskerLeft_comp_assoc, SymmetricCategory.symmetry, + MonoidalCategory.whiskerLeft_id, Category.id_comp, Iso.hom_inv_id] + +/-! ## Bubbling the top factor down -/ + +/-- **The insertion cycle**: move the factor in the top slot of +`X ^ ⊗ (n + 1)` down to slot `p`, shifting slots `p, …, n − 1` up by +one. It is defined by bubbling one slot at a time, so no word is +chosen: `insertTop X n n` is the identity, and each further step +composes one more top transposition, whiskered by the factors above +it. The recursion is on the gap `n - p`. -/ +noncomputable def insertTop + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) : (n : ℕ) → (k : ℕ) → + (tensorPow A X (n + 1) ⟶ tensorPow A X (n + 1)) + | _, 0 => 𝟙 _ + | 0, _ + 1 => 𝟙 _ + | n + 1, k + 1 => + swapTop X n ≫ (insertTop X n k ▷ X) + +/-- Bubbling by no steps is the identity. -/ +@[simp] +theorem insertTop_zero + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (n : ℕ) : + insertTop (A := A) X n 0 = 𝟙 _ := by + cases n <;> rfl + +/-- At arity one there is nothing to bubble. -/ +@[simp] +theorem insertTop_of_zero + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (k : ℕ) : + insertTop (A := A) X 0 k = 𝟙 _ := by + cases k <;> rfl + +/-- One bubbling step: braid the top factor past the one below it, +then continue bubbling the result inside the lower part. -/ +theorem insertTop_succ + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (n k : ℕ) : + insertTop (A := A) X (n + 1) (k + 1) = + swapTop X n ≫ (insertTop X n k ▷ X) := rfl + +/-- Bubbling down by one step is the top swap. -/ +@[simp] +theorem insertTop_one + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (n : ℕ) : + insertTop (A := A) X (n + 1) 1 = swapTop X n := by + rw [insertTop_succ, insertTop_zero, MonoidalCategory.id_whiskerRight] + exact Category.comp_id _ + +/-! ## Disjoint slots commute + +The top braiding touches only the top two slots, so it commutes with +anything acting on the factors below them. This is what lets the +recursion be reorganised when a transposition and a permutation act +on disjoint parts of a tensor power. +-/ + +/-- **The top braiding commutes with morphisms below it.** The +braiding touches only the top two slots, so a morphism of the factors +below them passes through. The computation is done at a general +object, which keeps the tensor power's arity out of the rewrites. -/ +theorem swapTop_whiskerRight + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (n : ℕ) + (f : tensorPow A X n ⟶ tensorPow A X n) : + ((f ▷ X) ▷ X) ≫ swapTop X n = swapTop X n ≫ ((f ▷ X) ▷ X) := by + have key : ∀ (P : A) (g : P ⟶ P), + ((g ▷ X) ▷ X) ≫ + ((α_ P X X).hom ≫ (P ◁ (β_ X X).hom) ≫ (α_ P X X).inv) = + ((α_ P X X).hom ≫ (P ◁ (β_ X X).hom) ≫ (α_ P X X).inv) ≫ + ((g ▷ X) ▷ X) := by + intro P g + rw [MonoidalCategory.associator_naturality_left_assoc, + ← MonoidalCategory.whisker_exchange_assoc, + MonoidalCategory.associator_inv_naturality_left] + simp only [Category.assoc] + exact key (tensorPow A X n) f + +/-! ### The braid relation + +Two adjacent top braidings satisfy the braid relation. Reassociating +all three tensorands off the base turns both sides into the base +whiskered onto a morphism of `X ⊗ (X ⊗ X)`, where the relation is +Mathlib's `yang_baxter` at three copies of `X`; the reassociation +itself is structural and is discharged by `monoidal`. +-/ + +/-- The full reassociation of three tensorands off a base. -/ +private noncomputable def assoc3 [Category.{v} A] [MonoidalCategory A] + (P X : A) : + ((P ⊗ X) ⊗ X) ⊗ X ≅ P ⊗ (X ⊗ (X ⊗ X)) := + (α_ (P ⊗ X) X X) ≪≫ (α_ P X (X ⊗ X)) + +/-- Braiding the top two tensorands, reassociated off the base. -/ +private theorem braid_upper + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (P X : A) : + ((α_ (P ⊗ X) X X).hom ≫ ((P ⊗ X) ◁ (β_ X X).hom) ≫ + (α_ (P ⊗ X) X X).inv) + = (assoc3 P X).hom ≫ (P ◁ (X ◁ (β_ X X).hom)) ≫ + (assoc3 P X).inv := by + simp only [assoc3, Iso.trans_hom, Iso.trans_inv, Category.assoc] + monoidal + +/-- Braiding the middle two tensorands, reassociated off the base. -/ +private theorem braid_lower + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (P X : A) : + (((α_ P X X).hom ≫ (P ◁ (β_ X X).hom) ≫ (α_ P X X).inv) ▷ X) + = (assoc3 P X).hom ≫ (P ◁ ((α_ X X X).inv ≫ + ((β_ X X).hom ▷ X) ≫ (α_ X X X).hom)) ≫ (assoc3 P X).inv := by + simp only [assoc3, Iso.trans_hom, Iso.trans_inv, Category.assoc] + monoidal + +/-- **The braid relation** for two adjacent top braidings. -/ +theorem swapTop_braid + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (n : ℕ) : + swapTop X (n + 1) ≫ (swapTop X n ▷ X) ≫ swapTop X (n + 1) = + (swapTop X n ▷ X) ≫ swapTop X (n + 1) ≫ (swapTop X n ▷ X) := by + have key : ∀ P : A, + ((α_ (P ⊗ X) X X).hom ≫ ((P ⊗ X) ◁ (β_ X X).hom) ≫ + (α_ (P ⊗ X) X X).inv) ≫ + (((α_ P X X).hom ≫ (P ◁ (β_ X X).hom) ≫ (α_ P X X).inv) ▷ X) ≫ + ((α_ (P ⊗ X) X X).hom ≫ ((P ⊗ X) ◁ (β_ X X).hom) ≫ + (α_ (P ⊗ X) X X).inv) = + (((α_ P X X).hom ≫ (P ◁ (β_ X X).hom) ≫ (α_ P X X).inv) ▷ X) ≫ + ((α_ (P ⊗ X) X X).hom ≫ ((P ⊗ X) ◁ (β_ X X).hom) ≫ + (α_ (P ⊗ X) X X).inv) ≫ + (((α_ P X X).hom ≫ (P ◁ (β_ X X).hom) ≫ + (α_ P X X).inv) ▷ X) := by + intro P + have hbr : (X ◁ (β_ X X).hom) ≫ (α_ X X X).inv ≫ + ((β_ X X).hom ▷ X) ≫ (α_ X X X).hom ≫ (X ◁ (β_ X X).hom) = + (α_ X X X).inv ≫ ((β_ X X).hom ▷ X) ≫ (α_ X X X).hom ≫ + (X ◁ (β_ X X).hom) ≫ (α_ X X X).inv ≫ + ((β_ X X).hom ▷ X) ≫ (α_ X X X).hom := + (BraidedCategory.yang_baxter X X X).symm + rw [braid_upper P X, braid_lower P X] + simp only [Category.assoc, Iso.inv_hom_id_assoc] + congr 1 + rw [← MonoidalCategory.whiskerLeft_comp_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc] + simp only [Category.assoc, hbr, MonoidalCategory.whiskerLeft_comp] + exact key (tensorPow A X n) + +/-! ### The two bubblings and the braiding + +The identity the action's functoriality rests on: precomposing a pair +of bubblings with the top braiding exchanges them. The first case is +an induction on the arity, whose step is the braid relation together +with the fact that the braiding commutes with what lies below it; the +second case follows from the first because the braiding is an +involution. +-/ + +private theorem id_sandwich [Category.{v} A] + {P Q : A} (f : P ⟶ Q) : + f ≫ 𝟙 Q ≫ 𝟙 Q = 𝟙 P ≫ f := by simp + +private theorem comp_id_id_comp [Category.{v} A] + {P Q R : A} (f : P ⟶ Q) (g : Q ⟶ R) : + f ≫ g ≫ 𝟙 R = 𝟙 P ≫ f ≫ g := by simp + +private theorem whisker_comp₂ [Category.{v} A] [MonoidalCategory A] + {P Q R : A} (f : P ⟶ Q) (g : Q ⟶ R) (Y : A) : + (f ≫ g) ▷ Y = (f ▷ Y) ≫ (g ▷ Y) := + MonoidalCategory.comp_whiskerRight f g Y + +private theorem whisker_comp₃ [Category.{v} A] [MonoidalCategory A] + {P Q R S : A} (f : P ⟶ Q) (g : Q ⟶ R) + (h : R ⟶ S) (Y : A) : + (f ≫ g ≫ h) ▷ Y = (f ▷ Y) ≫ (g ▷ Y) ≫ (h ▷ Y) := by + rw [whisker_comp₂, whisker_comp₂] + +private theorem braid_shuffle [Category.{v} A] + {P : A} {s t F G U : P ⟶ P} + (hbr : s ≫ t ≫ s = t ≫ s ≫ t) + (hF : F ≫ s = s ≫ F) (hG : G ≫ s = s ≫ G) + (hih : t ≫ F ≫ U = G ≫ t ≫ F) : + s ≫ (t ≫ F) ≫ (s ≫ U) = (t ≫ G) ≫ (s ≫ t ≫ F) := by + calc s ≫ (t ≫ F) ≫ (s ≫ U) + = s ≫ t ≫ (F ≫ s) ≫ U := by simp only [Category.assoc] + _ = s ≫ t ≫ (s ≫ F) ≫ U := by rw [hF] + _ = (s ≫ t ≫ s) ≫ F ≫ U := by simp only [Category.assoc] + _ = (t ≫ s ≫ t) ≫ F ≫ U := by rw [hbr] + _ = t ≫ s ≫ t ≫ F ≫ U := by simp only [Category.assoc] + _ = t ≫ s ≫ G ≫ t ≫ F := by rw [hih] + _ = t ≫ (s ≫ G) ≫ t ≫ F := by simp only [Category.assoc] + _ = t ≫ (G ≫ s) ≫ t ≫ F := by rw [hG] + _ = (t ≫ G) ≫ (s ≫ t ≫ F) := by simp only [Category.assoc] + +/-- **The braid identity, first case**: when the top factor is +bubbled at least as far as the one below it, the two bubblings and +the braiding rearrange with the destinations shifted by one. -/ +theorem insertTop_braid_le + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) : + ∀ (n a b : ℕ), b ≤ a → a ≤ n → + swapTop X n ≫ (insertTop X n a ▷ X) ≫ insertTop X (n + 1) b = + (insertTop X n b ▷ X) ≫ insertTop X (n + 1) (a + 1) := by + intro n + induction n with + | zero => + intro a b hba han + obtain rfl : a = 0 := Nat.le_zero.mp han + obtain rfl : b = 0 := Nat.le_zero.mp hba + simp only [Nat.zero_add, insertTop_zero, insertTop_one, + MonoidalCategory.id_whiskerRight] + exact id_sandwich (swapTop X 0) + | succ n' ih => + intro a b hba han + match b, a, hba with + | 0, a, _ => + simp only [insertTop_zero, MonoidalCategory.id_whiskerRight, + insertTop_succ] + exact comp_id_id_comp _ _ + | Nat.succ b₀, Nat.succ a', hba => + have hb : b₀ ≤ a' := by omega + have ha : a' ≤ n' := by omega + have e3 : (insertTop X (n' + 1) (a' + 1) ▷ X) + = (swapTop X n' ▷ X) ≫ ((insertTop X n' a' ▷ X) ▷ X) := + whisker_comp₂ _ _ X + have e4 : (insertTop X (n' + 1) (b₀ + 1) ▷ X) + = (swapTop X n' ▷ X) ≫ ((insertTop X n' b₀ ▷ X) ▷ X) := + whisker_comp₂ _ _ X + have hih : (swapTop X n' ▷ X) ≫ + ((insertTop X n' a' ▷ X) ▷ X) ≫ + (insertTop X (n' + 1) b₀ ▷ X) = + ((insertTop X n' b₀ ▷ X) ▷ X) ≫ + ((swapTop X n' ▷ X) ≫ ((insertTop X n' a' ▷ X) ▷ X)) := by + refine (whisker_comp₃ (swapTop X n') (insertTop X n' a' ▷ X) + (insertTop X (n' + 1) b₀) X).symm.trans ?_ + refine (congrArg (fun m => m ▷ X) (ih a' b₀ hb ha)).trans ?_ + refine (whisker_comp₂ (insertTop X n' b₀ ▷ X) + (insertTop X (n' + 1) (a' + 1)) X).trans ?_ + exact congrArg (fun m => ((insertTop X n' b₀ ▷ X) ▷ X) ≫ m) e3 + change swapTop X (n' + 1) ≫ (insertTop X (n' + 1) (a' + 1) ▷ X) ≫ + (swapTop X (n' + 1) ≫ (insertTop X (n' + 1) b₀ ▷ X)) + = (insertTop X (n' + 1) (b₀ + 1) ▷ X) ≫ + (swapTop X (n' + 1) ≫ (insertTop X (n' + 1) (a' + 1) ▷ X)) + rw [e3, e4] + exact braid_shuffle (swapTop_braid X n') + (swapTop_whiskerRight X (n' + 1) (insertTop X n' a')) + (swapTop_whiskerRight X (n' + 1) (insertTop X n' b₀)) hih + +private theorem cancel_invol [Category.{v} A] + {P : A} {s : P ⟶ P} (hs : s ≫ s = 𝟙 P) + {Q : A} (f : P ⟶ Q) : s ≫ s ≫ f = f := by + rw [← Category.assoc, hs, Category.id_comp] + +/-- **The braid identity, second case**: when the top factor is +inserted above the one below it, the two bubblings exchange with the +braiding the other way round. It follows from the first case and the +involutivity of the braiding. -/ +theorem insertTop_braid_lt + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (n a b₀ : ℕ) (hab : a ≤ b₀) + (hb : b₀ ≤ n) : + swapTop X n ≫ (insertTop X n a ▷ X) ≫ insertTop X (n + 1) (b₀ + 1) = + (insertTop X n b₀ ▷ X) ≫ insertTop X (n + 1) a := by + have hA := insertTop_braid_le X n b₀ a hab hb + exact (congrArg (fun m => swapTop X n ≫ m) hA.symm).trans + (cancel_invol (swapTop_swapTop X n) _) + +/-! ## The action + +A permutation acts by routing the factor in each slot to the slot it +names. The recursion splits off the top slot: the lower `n` factors +are permuted by `restPerm σ`, which places them in their compressed +target slots, and the top factor is then bubbled down into slot +`topImage σ`, which shifts the compressed slots at or above it up by +one — exactly recovering the true targets. + +No word in the adjacent transpositions is chosen, so no +word-independence is needed; functoriality instead follows from mere +generation. +-/ + +/-- **The permutation action on a tensor power**: `permMor X σ` +routes the factor in slot `i` to slot `σ i`. -/ +noncomputable def permMor + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) : + (n : ℕ) → Equiv.Perm (Fin n) → (tensorPow A X n ⟶ tensorPow A X n) + | 0, _ => 𝟙 _ + | n + 1, σ => + (permMor X n (restPerm σ) ▷ X) ≫ + insertTop X n (n - (topImage σ : ℕ)) + +/-- The recursion equation. -/ +theorem permMor_succ [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (n : ℕ) (σ : Equiv.Perm (Fin (n + 1))) : + permMor X (n + 1) σ = + (permMor X n (restPerm σ) ▷ X) ≫ + insertTop X n (n - (topImage σ : ℕ)) := rfl + +/-- The identity permutation acts as the identity. -/ +@[simp] +theorem permMor_one [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (n : ℕ) : + permMor X n 1 = 𝟙 (tensorPow A X n) := by + induction n with + | zero => rfl + | succ n ih => + rw [permMor_succ, restPerm_one, ih, topImage_one] + simp [Fin.last, tensorPow] + +/-- **A top-fixing permutation acts on the lower factors alone.** -/ +@[simp] +theorem permMor_extPerm + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (n : ℕ) (τ : Equiv.Perm (Fin n)) : + permMor X (n + 1) (extPerm τ) = permMor X n τ ▷ X := by + rw [permMor_succ, restPerm_extPerm, topImage_extPerm, + show (Fin.last n : Fin (n + 1)).val = n from rfl, Nat.sub_self, + insertTop_zero] + exact Category.comp_id _ + +/-- **Functoriality against a top-fixing permutation**, granted +functoriality one arity down. -/ +theorem permMor_mul_extPerm + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (n : ℕ) + (ih : ∀ ρ τ : Equiv.Perm (Fin n), + permMor X n (ρ * τ) = permMor X n τ ≫ permMor X n ρ) + (σ : Equiv.Perm (Fin (n + 1))) (τ : Equiv.Perm (Fin n)) : + permMor X (n + 1) (σ * extPerm τ) = + permMor X (n + 1) (extPerm τ) ≫ permMor X (n + 1) σ := by + erw [permMor_succ, restPerm_mul_extPerm, topImage_mul_extPerm, + ih (restPerm σ) τ, MonoidalCategory.comp_whiskerRight, + permMor_extPerm, permMor_succ, Category.assoc] + rfl + +/-! ## The cycles + +`topCycle q` is the permutation with trivial induced permutation, so +the recursion evaluates it to a single bubbling — which is what +`insertTop` was defined to be. The top transposition is the cycle at +the second-highest slot, so it acts by the top braiding. +-/ + +/-- **A cycle acts by bubbling.** -/ +@[simp] +theorem permMor_topCycle + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (n : ℕ) (q : Fin (n + 1)) : + permMor X (n + 1) (topCycle q) = insertTop X n (n - (q : ℕ)) := by + erw [permMor_succ, restPerm_topCycle, topImage_topCycle, permMor_one, + MonoidalCategory.id_whiskerRight, Category.id_comp] + +/-- **The top transposition acts by the top braiding.** It is the +cycle at the second-highest slot, one bubbling step. -/ +theorem permMor_topSwap + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (n : ℕ) : + permMor X (n + 2) (topCycle (Fin.castSucc (Fin.last n))) = + swapTop X n := by + rw [permMor_topCycle, + show ((Fin.castSucc (Fin.last n) : Fin (n + 2)) : ℕ) = n from rfl, + show n + 1 - n = 1 from by omega, insertTop_one] + +/-- **The top transposition acts by the top braiding**, in the form +the generating set uses. -/ +@[simp] +theorem permMor_topSwap_eq + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (n : ℕ) : + permMor X (n + 2) (topSwap : Equiv.Perm (Fin (n + 2))) = + swapTop X n := by + rw [topSwap_eq_topCycle] + exact permMor_topSwap X n + +/-- Whiskering the recursion equation by one more factor. -/ +theorem permMor_whiskerRight_succ + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (n : ℕ) + (τ : Equiv.Perm (Fin (n + 1))) : + (permMor X (n + 1) τ ▷ X) = + ((permMor X n (restPerm τ) ▷ X) ▷ X) ≫ + (insertTop X n (n - (topImage τ : ℕ)) ▷ X) := by + rw [permMor_succ] + exact MonoidalCategory.comp_whiskerRight _ _ _ + +/-- Commuting morphisms may be exchanged in front of a third. Stated +at general objects, so that no tensor-power arity enters the +rewriting. -/ +private theorem comm_assoc [Category.{v} A] + {P R : A} {a b : P ⟶ P} (h : a ≫ b = b ≫ a) + (c : P ⟶ R) : a ≫ b ≫ c = b ≫ a ≫ c := by + rw [← Category.assoc, h, Category.assoc] + +/-- **The top braiding passes the lower-lower permutation.** Only +the bubbling of the lower part can interact with the braiding of the +top two slots; the permutation beneath it commutes through. -/ +theorem swapTop_comp_permMor_whiskerRight + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (n : ℕ) + (τ : Equiv.Perm (Fin (n + 1))) : + swapTop X n ≫ (permMor X (n + 1) τ ▷ X) = + ((permMor X n (restPerm τ) ▷ X) ▷ X) ≫ + swapTop X n ≫ (insertTop X n (n - (topImage τ : ℕ)) ▷ X) := by + rw [permMor_whiskerRight_succ] + exact comm_assoc (swapTop_whiskerRight X n + (permMor X n (restPerm τ))).symm _ + +/-! ## The top transposition + +Both sides of the generator identity for the top transposition carry +the same permutation of the factors below the top two: the braiding +commutes past it, and precomposing with the top transposition leaves +the twice-restricted permutation alone. What is left is a relation +between two bubblings and the braiding, with no permutation in it. +-/ + +/-- Congruence on the second factor of a composite. Stated at +general objects, so that no tensor-power arity enters. -/ +private theorem comp_congr_right [Category.{v} A] + {P Q R : A} (a : P ⟶ Q) {b b' : Q ⟶ R} + (h : b = b') : a ≫ b = a ≫ b' := by rw [h] + +/-- Rearranging a commutation in front of a common tail. Stated at a +general object, so that no tensor-power arity enters the rewriting. -/ +private theorem shuffle [Category.{v} A] + {P : A} {s v z v' w : P ⟶ P} + (h : s ≫ v = z ≫ (s ≫ v')) : + s ≫ v ≫ w = z ≫ (s ≫ v' ≫ w) := by + rw [← Category.assoc, h, Category.assoc, Category.assoc] + +/-- **The generator identity for the top transposition, reduced.** +Granted the braid relation between the two bubblings, the action is +functorial against the top transposition. -/ +theorem permMor_mul_topSwap_of_braid + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (n : ℕ) + (σ : Equiv.Perm (Fin (n + 2))) + (hbraid : + swapTop X n ≫ + ((insertTop X n (n - (topImage (restPerm σ) : ℕ)) ▷ X) ≫ + insertTop X (n + 1) (n + 1 - (topImage σ : ℕ))) = + (insertTop X n + (n - (topImage (restPerm (σ * topSwap)) : ℕ)) ▷ X) ≫ + insertTop X (n + 1) + (n + 1 - (topImage (σ * topSwap) : ℕ))) : + permMor X (n + 2) (σ * topSwap) = + swapTop X n ≫ permMor X (n + 2) σ := by + have h1 : permMor X (n + 2) (σ * topSwap) = + ((permMor X n (restPerm (restPerm σ)) ▷ X) ▷ X) ≫ + ((insertTop X n + (n - (topImage (restPerm (σ * topSwap)) : ℕ)) ▷ X) ≫ + insertTop X (n + 1) + (n + 1 - (topImage (σ * topSwap) : ℕ))) := by + rw [permMor_succ, permMor_whiskerRight_succ, + restPerm_restPerm_mul_topSwap] + exact Category.assoc _ _ _ + have h3 : ((permMor X n (restPerm (restPerm σ)) ▷ X) ▷ X) ≫ + (swapTop X n ≫ + ((insertTop X n (n - (topImage (restPerm σ) : ℕ)) ▷ X) ≫ + insertTop X (n + 1) (n + 1 - (topImage σ : ℕ)))) = + swapTop X n ≫ permMor X (n + 2) σ := by + rw [permMor_succ (σ := σ)] + exact (shuffle (swapTop_comp_permMor_whiskerRight X n + (restPerm σ))).symm + exact h1.trans ((comp_congr_right _ hbraid.symm).trans h3) + +/-- **Functoriality against the top transposition.** The two cases +are whether the top slot's image lies above or below the image of the +slot beneath it; each feeds the corresponding braid identity. -/ +theorem permMor_mul_topSwap + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (n : ℕ) + (σ : Equiv.Perm (Fin (n + 2))) : + permMor X (n + 2) (σ * topSwap) = + swapTop X n ≫ permMor X (n + 2) σ := by + refine permMor_mul_topSwap_of_braid X n σ ?_ + have hm : ((topImage (restPerm σ) : Fin (n + 1)) : ℕ) ≤ n := + Nat.lt_succ_iff.mp (topImage (restPerm σ)).isLt + have hp : ((topImage σ : Fin (n + 2)) : ℕ) ≤ n + 1 := + Nat.lt_succ_iff.mp (topImage σ).isLt + rcases Fin.lt_or_le ((topImage (restPerm σ)).castSucc) (topImage σ) with h | h + · have hlt : ((topImage (restPerm σ) : Fin (n + 1)) : ℕ) + < ((topImage σ : Fin (n + 2)) : ℕ) := by + simpa [Fin.lt_def] using h + rw [topImage_mul_topSwap_val_of_lt σ h, + topImage_restPerm_mul_topSwap_val_of_lt σ h, + show n - (((topImage σ : Fin (n + 2)) : ℕ) - 1) + = n + 1 - ((topImage σ : Fin (n + 2)) : ℕ) from by omega, + show n + 1 - ((topImage (restPerm σ) : Fin (n + 1)) : ℕ) + = (n - ((topImage (restPerm σ) : Fin (n + 1)) : ℕ)) + 1 from by + omega] + exact insertTop_braid_le X n _ _ (by omega) (by omega) + · have hle : ((topImage σ : Fin (n + 2)) : ℕ) + ≤ ((topImage (restPerm σ) : Fin (n + 1)) : ℕ) := by + simpa [Fin.le_def] using h + rw [topImage_mul_topSwap_val_of_le σ h, + topImage_restPerm_mul_topSwap_val_of_le σ h, + show n + 1 - (((topImage (restPerm σ) : Fin (n + 1)) : ℕ) + 1) + = n - ((topImage (restPerm σ) : Fin (n + 1)) : ℕ) from by omega, + show n + 1 - ((topImage σ : Fin (n + 2)) : ℕ) + = (n - ((topImage σ : Fin (n + 2)) : ℕ)) + 1 from by omega] + exact insertTop_braid_lt X n _ _ (by omega) (by omega) + +/-! ## Functoriality + +Every permutation is a product of adjacent transpositions, and each of +those is either top-fixing or the top transposition — both already +handled. Since the action was defined canonically rather than through +a chosen word, generation is all that is needed: no presentation of +the symmetric group, and no coherence theorem. +-/ + +/-- **The action is functorial.** Composition of permutations goes to +composition of morphisms, in the order `End` multiplies. -/ +theorem permMor_mul [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) : ∀ (n : ℕ) (σ τ : Equiv.Perm (Fin n)), + permMor X n (σ * τ) = permMor X n τ ≫ permMor X n σ := by + intro n + induction n with + | zero => + intro σ τ + change 𝟙 _ = 𝟙 _ ≫ 𝟙 _ + exact (Category.comp_id _).symm + | succ n' ih => + match n' with + | 0 => + intro σ τ + have h1 : ∀ ρ : Equiv.Perm (Fin (0 + 1)), ρ = 1 := fun ρ => + Equiv.ext fun x => Fin.ext (by omega) + rw [h1 σ, h1 τ, one_mul, permMor_one] + exact (Category.id_comp _).symm + | n'' + 1 => + have hgen : ∀ (i : Fin (n'' + 1)) (ρ : Equiv.Perm (Fin (n'' + 2))), + permMor X (n'' + 2) (ρ * Equiv.swap i.castSucc i.succ) + = permMor X (n'' + 2) (Equiv.swap i.castSucc i.succ) + ≫ permMor X (n'' + 2) ρ := by + intro i + refine Fin.lastCases ?_ (fun j ρ => ?_) i + · intro ρ + rw [show Equiv.swap (Fin.castSucc (Fin.last n'')) + (Fin.last n'').succ = (topSwap : Equiv.Perm (Fin (n'' + 2))) + from by rw [topSwap, Fin.succ_last]] + rw [permMor_topSwap_eq] + exact permMor_mul_topSwap X n'' ρ + · rw [swap_castSucc_succ_castSucc j] + exact permMor_mul_extPerm X (n'' + 1) ih ρ _ + have key : ∀ τ : Equiv.Perm (Fin (n'' + 2)), + τ ∈ Submonoid.closure (Set.range fun i : Fin (n'' + 1) => + Equiv.swap i.castSucc i.succ) → + ∀ σ : Equiv.Perm (Fin (n'' + 2)), + permMor X (n'' + 2) (σ * τ) + = permMor X (n'' + 2) τ ≫ permMor X (n'' + 2) σ := by + intro τ hτ + induction hτ using Submonoid.closure_induction_left with + | one => + intro σ + rw [mul_one, permMor_one] + exact (Category.id_comp _).symm + | mul_left g hg τ' hτ' ihτ' => + obtain ⟨i, rfl⟩ := hg + intro σ + rw [← mul_assoc, ihτ' (σ * _), hgen i σ, ihτ' _, Category.assoc] + intro σ τ + exact key τ (by + rw [Equiv.Perm.mclosure_swap_castSucc_succ]; trivial) σ + +/-! ## The algebra map + +With functoriality in hand the action is a monoid homomorphism into +the endomorphism monoid, and the universal property of the group +algebra turns it into the algebra map a tower's representation field +asks for. Only this last step needs the linear structure. +-/ + +/-- **The action as a monoid homomorphism.** -/ +@[simps] +noncomputable def permHom + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (n : ℕ) : + Equiv.Perm (Fin n) →* End (tensorPow A X n) where + toFun := permMor X n + map_one' := permMor_one X n + map_mul' := permMor_mul X n + +section Linear + +/-- **The symmetric-group algebra acting on a tensor power.** -/ +noncomputable def permAlg + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] + (X : A) (n : ℕ) : + SymGroupAlgebra n →ₐ[ℂ] End (tensorPow A X n) := + MonoidAlgebra.lift ℂ (End (tensorPow A X n)) (Equiv.Perm (Fin n)) + (permHom X n) + +/-- The algebra map sends a group element to its action. -/ +@[simp] +theorem permAlg_single + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + [Preadditive A] [Linear ℂ A] + (X : A) (n : ℕ) (σ : Equiv.Perm (Fin n)) : + permAlg X n (MonoidAlgebra.single σ (1 : ℂ)) = permMor X n σ := by + rw [permAlg, MonoidAlgebra.lift_single, one_smul] + rfl + +end Linear + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPermCast.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPermCast.lean new file mode 100644 index 0000000000..758839de82 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPermCast.lean @@ -0,0 +1,147 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPerm + +/-! +# The action along the standard embeddings + +A tower's compatibility field asks that vanishing propagate along +the standard embeddings `S_m ↪ S_n`: an element of the group algebra +killed at arity `m` stays killed at arity `n`. For the action on a +tensor power this is a factorisation rather than a coincidence. +Extending a permutation by fixed slots tensors its action with the +identity on the new factors, so the level-`n` representation +restricted along `symCast` is the level-`m` representation followed +by repeated whiskering — and whiskering, being an algebra map, sends +zero to zero. + +The whiskering algebra map is where the linear structure of the +category is used: additivity of `▷` is `MonoidalPreadditive` and its +ℂ-homogeneity is `MonoidalLinear`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +variable {A : Type u} + +/-! ## Whiskering as an algebra map -/ + +/-- **Whiskering by a fixed object is an algebra map** on +endomorphisms. Multiplicativity is functoriality of `▷` — note that +`End` multiplies in the order opposite to composition, which is why +no reversal appears. -/ +noncomputable def whiskerAlg + [Category.{v} A] [MonoidalCategory A] [Preadditive A] [Linear ℂ A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] + (P X : A) : End P →ₐ[ℂ] End (P ⊗ X) where + toFun f := f ▷ X + map_one' := MonoidalCategory.id_whiskerRight P X + map_mul' f g := MonoidalCategory.comp_whiskerRight g f X + map_zero' := MonoidalPreadditive.zero_whiskerRight + map_add' f g := MonoidalPreadditive.add_whiskerRight f g + commutes' c := by + change (c • 𝟙 P) ▷ X = c • 𝟙 (P ⊗ X) + rw [MonoidalLinear.smul_whiskerRight, + MonoidalCategory.id_whiskerRight] + +/-- **Repeated whiskering**: the algebra map carrying an +endomorphism of `X ^ ⊗ m` to the endomorphism of `X ^ ⊗ (m + k)` +that acts on the first `m` factors and fixes the last `k`. -/ +noncomputable def whiskerPowAlg + [Category.{v} A] [MonoidalCategory A] [Preadditive A] [Linear ℂ A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] + (X : A) (m : ℕ) : + (k : ℕ) → (End (tensorPow A X m) →ₐ[ℂ] End (tensorPow A X (m + k))) + | 0 => AlgHom.id ℂ _ + | k + 1 => + (whiskerAlg (tensorPow A X (m + k)) X).comp (whiskerPowAlg X m k) + +/-! ## The action factors through whiskering -/ + +/-- Extending along the identity embedding changes nothing. -/ +private theorem viaEmbedding_castLEEmb_self {m : ℕ} + (σ : Equiv.Perm (Fin m)) : + σ.viaEmbedding (Fin.castLEEmb (Nat.le_add_right m 0)) = σ := + Equiv.ext fun x => by + have hx : Fin.castLEEmb (Nat.le_add_right m 0) x = x := Fin.ext rfl + have h := Equiv.Perm.viaEmbedding_apply σ + (Fin.castLEEmb (Nat.le_add_right m 0)) x + rw [hx] at h + rw [h] + exact Fin.ext rfl + +/-- **The action of an extended permutation is the whiskered +action**: a permutation of `Fin m`, extended to `Fin (m + k)` by +fixing the last `k` slots, acts on the first `m` tensor factors and +fixes the last `k`. -/ +theorem permMor_viaEmbedding + [Category.{v} A] [MonoidalCategory A] [Preadditive A] [Linear ℂ A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] + (X : A) (m : ℕ) [SymmetricCategory A] : + ∀ (k : ℕ) (σ : Equiv.Perm (Fin m)), + permMor X (m + k) + (σ.viaEmbedding (Fin.castLEEmb (Nat.le_add_right m k))) = + whiskerPowAlg X m k (permMor X m σ) + | 0, σ => by + rw [viaEmbedding_castLEEmb_self] + rfl + | k + 1, σ => by + -- The `rw` is stated at arity `m + k + 1`; the goal reads it at + -- the definitionally equal `m + (k + 1)`, so `exact` closes it. + have h := permMor_extPerm X (m + k) + (σ.viaEmbedding (Fin.castLEEmb (Nat.le_add_right m k))) + rw [viaEmbedding_castLEEmb_succ] + exact h.trans + (congrArg (· ▷ X) (permMor_viaEmbedding X m k σ)) + +/-- **The representation restricted along the standard embedding** +is the lower representation followed by repeated whiskering. -/ +theorem permAlg_symCast + [Category.{v} A] [MonoidalCategory A] [Preadditive A] [Linear ℂ A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] + (X : A) [SymmetricCategory A] (m k : ℕ) + (x : SymGroupAlgebra m) : + permAlg X (m + k) (symCast (Nat.le_add_right m k) x) = + whiskerPowAlg X m k (permAlg X m x) := by + have hext : (permAlg X (m + k)).comp (symCast (Nat.le_add_right m k)) = + (whiskerPowAlg X m k).comp (permAlg X m) := by + refine MonoidAlgebra.algHom_ext (R := ℂ) (A := ℂ) (M := Equiv.Perm (Fin m)) + (fun σ => ?_) (by ext) + change permAlg X (m + k) (symCast _ (MonoidAlgebra.single σ 1)) = + whiskerPowAlg X m k (permAlg X m (MonoidAlgebra.single σ 1)) + have hsym : symCast (Nat.le_add_right m k) + (MonoidAlgebra.single σ (1 : ℂ)) = + MonoidAlgebra.single + (σ.viaEmbedding (Fin.castLEEmb (Nat.le_add_right m k))) + (1 : ℂ) := by + change MonoidAlgebra.mapDomain _ (MonoidAlgebra.single σ 1) = + MonoidAlgebra.single _ 1 + exact MonoidAlgebra.mapDomain_single + rw [hsym, permAlg_single, permAlg_single] + exact permMor_viaEmbedding X m k σ + exact DFunLike.congr_fun hext x + +/-- **Vanishing propagates along the standard embeddings.** This is +the `compat` field of a tower, for the action on a tensor power. -/ +theorem permAlg_compat + [Category.{v} A] [MonoidalCategory A] [Preadditive A] [Linear ℂ A] + [MonoidalPreadditive A] [MonoidalLinear ℂ A] + (X : A) [SymmetricCategory A] {m n : ℕ} + (h : m ≤ n) (x : SymGroupAlgebra m) (hx : permAlg X m x = 0) : + permAlg X n (symCast h x) = 0 := by + obtain ⟨k, rfl⟩ := Nat.exists_eq_add_of_le h + rw [permAlg_symCast, hx, map_zero] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowHom.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowHom.lean new file mode 100644 index 0000000000..8e457362ac --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowHom.lean @@ -0,0 +1,153 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPerm + +/-! +# The tensor power of an endomorphism + +An endomorphism `g` of `X` induces an endomorphism of the tensor +power `X ^ ⊗ n`, one copy of `g` acting on each factor (`powHom`). +It commutes with the symmetric-group action of `SymPerm.lean`: +every factor carries the same endomorphism, so permuting the factors +and applying `g` to each may be done in either order +(`permMor_comp_powHom`). +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +variable {A : Type u} + +/-! ## The tensor power of an endomorphism -/ + +/-- **The tensor power of an endomorphism**: `powHom X g n` acts by +`g` on each of the `n` factors of `X ^ ⊗ n`. -/ +noncomputable def powHom [Category.{v} A] [MonoidalCategory A] + (X : A) (g : End X) : + (n : ℕ) → End (tensorPow A X n) + | 0 => 𝟙 _ + | n + 1 => powHom X g n ⊗ₘ g + +/-- On the empty tensor power the endomorphism power is the +identity of the unit. -/ +@[simp] +theorem powHom_zero [Category.{v} A] [MonoidalCategory A] + (X : A) (g : End X) : + powHom X g 0 = 𝟙 (𝟙_ A) := rfl + +/-- The recursion equation: the endomorphism power on one more +factor tensors on one more copy of `g`. -/ +@[simp] +theorem powHom_succ [Category.{v} A] [MonoidalCategory A] + (X : A) (g : End X) (n : ℕ) : + powHom X g (n + 1) = powHom X g n ⊗ₘ g := rfl + +/-! ## Commutation with whiskering -/ + +/-- A composite of two morphisms that each commute with a third +commutes with it. Stated at a general object, so that no +tensor-power arity enters the rewriting. -/ +private theorem comp_comm [Category.{v} A] + {P : A} {s t p : P ⟶ P} + (hs : s ≫ p = p ≫ s) (ht : t ≫ p = p ≫ t) : + (s ≫ t) ≫ p = p ≫ s ≫ t := by + rw [Category.assoc, ht, ← Category.assoc, hs, Category.assoc] + +/-- Whiskering against a factorwise endomorphism: a morphism that +commutes with `p` commutes with `p ⊗ₘ a` once whiskered. Stated at +general objects, so that no tensor-power arity enters the +rewriting. -/ +private theorem whisker_tensor_comm [Category.{v} A] [MonoidalCategory A] + {P X : A} {f p : P ⟶ P} + {a : X ⟶ X} (h : f ≫ p = p ≫ f) : + (f ▷ X) ≫ (p ⊗ₘ a) = (p ⊗ₘ a) ≫ (f ▷ X) := by + rw [MonoidalCategory.whiskerRight_comp_tensorHom, h, + ← MonoidalCategory.tensorHom_comp_whiskerRight] + +/-- Adding a factor preserves commutation with the endomorphism +power. -/ +theorem whiskerRight_comp_powHom [Category.{v} A] [MonoidalCategory A] + (X : A) (g : End X) (n : ℕ) + (f : tensorPow A X n ⟶ tensorPow A X n) + (h : f ≫ powHom X g n = powHom X g n ≫ f) : + (f ▷ X) ≫ powHom X g (n + 1) = + powHom X g (n + 1) ≫ (f ▷ X) := + whisker_tensor_comm h + +/-! ## Equivariance -/ + +/-- The braiding of the top two tensorands, conjugated by the +associator, exchanges the top two components of a factorwise +endomorphism. Stated at general objects, so that no tensor-power +arity enters the rewriting. -/ +private theorem tensor_swap_comm + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + {P X Y : A} (p : P ⟶ P) (a : X ⟶ X) + (b : Y ⟶ Y) : + ((p ⊗ₘ a) ⊗ₘ b) ≫ + ((α_ P X Y).hom ≫ (P ◁ (β_ X Y).hom) ≫ (α_ P Y X).inv) = + ((α_ P X Y).hom ≫ (P ◁ (β_ X Y).hom) ≫ (α_ P Y X).inv) ≫ + ((p ⊗ₘ b) ⊗ₘ a) := by + rw [MonoidalCategory.associator_naturality_assoc, + MonoidalCategory.tensorHom_comp_whiskerLeft_assoc, + BraidedCategory.braiding_naturality, + ← MonoidalCategory.whiskerLeft_comp_tensorHom_assoc, + MonoidalCategory.associator_inv_naturality] + simp only [Category.assoc] + +/-- The top braiding commutes with the endomorphism power: the two +braided factors carry the same endomorphism. -/ +theorem swapTop_comp_powHom + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (g : End X) (n : ℕ) : + swapTop X n ≫ powHom X g (n + 2) = + powHom X g (n + 2) ≫ swapTop X n := + (tensor_swap_comm (powHom X g n) g g).symm + +/-- Bubbling the top factor down commutes with the endomorphism +power, one braiding step at a time. -/ +theorem insertTop_comp_powHom + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (g : End X) : + ∀ (n k : ℕ), insertTop X n k ≫ powHom X g (n + 1) = + powHom X g (n + 1) ≫ insertTop X n k + | n, 0 => by + rw [insertTop_zero, Category.id_comp, Category.comp_id] + | 0, _ + 1 => by + rw [insertTop_of_zero, Category.id_comp, Category.comp_id] + | n + 1, k + 1 => by + rw [insertTop_succ] + exact comp_comm (swapTop_comp_powHom X g n) + (whiskerRight_comp_powHom X g (n + 1) (insertTop X n k) + (insertTop_comp_powHom X g n k)) + +/-- **Equivariance of the endomorphism power**: the symmetric-group +action commutes with `g ^ ⊗ n`. Every factor carries the same +endomorphism, so permuting the factors and applying `g` to each may +be done in either order. -/ +theorem permMor_comp_powHom + [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] + (X : A) (g : End X) (n : ℕ) + (σ : Equiv.Perm (Fin n)) : + permMor X n σ ≫ powHom X g n = powHom X g n ≫ permMor X n σ := by + induction n with + | zero => rfl + | succ n ih => + rw [permMor_succ] + exact comp_comm + (whiskerRight_comp_powHom X g n (permMor X n (restPerm σ)) + (ih (restPerm σ))) + (insertTop_comp_powHom X g n (n - (topImage σ : ℕ))) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowSplit.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowSplit.lean new file mode 100644 index 0000000000..d6ecef2c02 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowSplit.lean @@ -0,0 +1,395 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowHom +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleNormal + +/-! +# Splitting a tensor power into two blocks + +The tensor power `X ^ ⊗ (p + q)` is isomorphic to +`X ^ ⊗ p ⊗ X ^ ⊗ q` by reassociation alone (`splitPow`), and the +structure carried by a tensor power respects the splitting: a block +sum of permutations acts as the two permutations acting on the two +blocks (`permMor_blockSum`), and the factorwise endomorphism power +splits factorwise (`powHom_splitPow`). These are the identities +that let the trace of a permutation-and-endomorphism word be +computed block by block. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +universe v u + +variable {A : Type u} + +/-! ## The splitting isomorphism -/ + +/-- **The block splitting**: `X ^ ⊗ (p + q) ≅ X ^ ⊗ p ⊗ X ^ ⊗ q`, +by recursion on the upper block. At `q = 0` it is the right +unitor's inverse; each further factor is carried across by the +associator, so the isomorphism is built from unitors and +associators alone. -/ +noncomputable def splitPow [Category.{v} A] [MonoidalCategory A] + (X : A) : (p q : ℕ) → + (tensorPow A X (p + q) ≅ tensorPow A X p ⊗ tensorPow A X q) + | p, 0 => (ρ_ (tensorPow A X p)).symm + | p, q + 1 => + whiskerRightIso (splitPow X p q) X ≪≫ + α_ (tensorPow A X p) (tensorPow A X q) X + +/-- The empty upper block splits off along the right unitor. -/ +@[simp] +theorem splitPow_zero [Category.{v} A] [MonoidalCategory A] + (X : A) (p : ℕ) : + splitPow (A := A) X p 0 = (ρ_ (tensorPow A X p)).symm := rfl + +/-- The recursion equation: one more factor is carried across by +the associator. -/ +theorem splitPow_succ [Category.{v} A] [MonoidalCategory A] + (X : A) (p q : ℕ) : + splitPow (A := A) X p (q + 1) = + whiskerRightIso (splitPow X p q) X ≪≫ + α_ (tensorPow A X p) (tensorPow A X q) X := rfl + +/-! ## The block sum of two permutations -/ + +/-- The block sum of two permutations: `σ` acts on the lower `p` +slots and `τ` on the upper `q`, with no interaction between the +blocks. -/ +def blockSum {p q : ℕ} (σ : Equiv.Perm (Fin p)) + (τ : Equiv.Perm (Fin q)) : Equiv.Perm (Fin (p + q)) := + finSumFinEquiv.permCongr (Equiv.sumCongr σ τ) + +/-- The block sum acts on the lower block by `σ`. -/ +theorem blockSum_castAdd {p q : ℕ} (σ : Equiv.Perm (Fin p)) + (τ : Equiv.Perm (Fin q)) (i : Fin p) : + blockSum σ τ (Fin.castAdd q i) = Fin.castAdd q (σ i) := by + simp [blockSum] + +/-- The block sum acts on the upper block by `τ`. -/ +theorem blockSum_natAdd {p q : ℕ} (σ : Equiv.Perm (Fin p)) + (τ : Equiv.Perm (Fin q)) (j : Fin q) : + blockSum σ τ (Fin.natAdd p j) = Fin.natAdd p (τ j) := by + simp [blockSum] + +/-- Against an empty upper block the block sum is `σ` alone. -/ +theorem blockSum_of_zero {p : ℕ} (σ : Equiv.Perm (Fin p)) + (τ : Equiv.Perm (Fin 0)) : blockSum σ τ = σ := + Equiv.ext fun x => + (congrArg (blockSum σ τ) + (Fin.ext rfl : x = Fin.castAdd 0 x)).trans + ((blockSum_castAdd σ τ x).trans (Fin.ext rfl)) + +/-- The block sum sends the top slot within the upper block: its +image is `topImage τ`, shifted past the lower block. -/ +theorem topImage_blockSum {p q : ℕ} (σ : Equiv.Perm (Fin p)) + (τ : Equiv.Perm (Fin (q + 1))) : + topImage (n := p + q) (blockSum (p := p) (q := q + 1) σ τ) = + Fin.natAdd p (topImage τ) := + (congrArg (blockSum (p := p) (q := q + 1) σ τ) + (Fin.ext rfl : Fin.last (p + q) = Fin.natAdd p (Fin.last q))).trans + (blockSum_natAdd σ τ (Fin.last q)) + +/-- Reinsertion above a pivot commutes with the shift into the +upper block. -/ +private theorem natAdd_succAbove {p q : ℕ} (a : Fin (q + 1)) + (b : Fin q) : + Fin.natAdd p (a.succAbove b) = + (Fin.natAdd p a).succAbove (Fin.natAdd p b) := by + rcases Fin.lt_or_le b.castSucc a with h | h + · have h' : (Fin.natAdd p b).castSucc < Fin.natAdd p a := by + rw [Fin.lt_def] at h ⊢ + simp only [Fin.val_castSucc, Fin.val_natAdd] at h ⊢ + omega + rw [Fin.succAbove_of_castSucc_lt _ _ h, + Fin.succAbove_of_castSucc_lt _ _ h'] + exact Fin.ext rfl + · have h' : Fin.natAdd p a ≤ (Fin.natAdd p b).castSucc := by + rw [Fin.le_def] at h ⊢ + simp only [Fin.val_castSucc, Fin.val_natAdd] at h ⊢ + omega + rw [Fin.succAbove_of_le_castSucc _ _ h, + Fin.succAbove_of_le_castSucc _ _ h'] + exact Fin.ext rfl + +/-- **Restriction respects the block sum**: peeling the top slot +off the upper block commutes with summing the blocks. -/ +theorem restPerm_blockSum {p q : ℕ} (σ : Equiv.Perm (Fin p)) + (τ : Equiv.Perm (Fin (q + 1))) : + restPerm (n := p + q) (blockSum (p := p) (q := q + 1) σ τ) = + blockSum σ (restPerm τ) := by + refine Equiv.ext fun j => ?_ + refine Fin.succAbove_right_injective + (p := topImage (n := p + q) (blockSum (p := p) (q := q + 1) σ τ)) ?_ + rw [succAbove_restPerm, topImage_blockSum] + induction j using Fin.addCases with + | left i => + have h' : (Fin.castAdd q (σ i)).castSucc < + Fin.natAdd p (topImage τ) := by + rw [Fin.lt_def] + simp only [Fin.val_castSucc, Fin.val_castAdd, Fin.val_natAdd] + have := (σ i).isLt + omega + rw [blockSum_castAdd, + show (Fin.castAdd q i).castSucc = Fin.castAdd (q + 1) i from + Fin.ext rfl, + blockSum_castAdd, Fin.succAbove_of_castSucc_lt _ _ h'] + exact Fin.ext rfl + | right j' => + rw [blockSum_natAdd, + show (Fin.natAdd p j').castSucc = Fin.natAdd p j'.castSucc from + Fin.ext rfl, + blockSum_natAdd, ← succAbove_restPerm τ j'] + exact natAdd_succAbove _ _ + +/-! ## The braiding respects the splitting -/ + +/-- Braiding the last two factors over a general base. -/ +private noncomputable def swapBase [Category.{v} A] [MonoidalCategory A] + (T X : A) [SymmetricCategory A] : + (T ⊗ X) ⊗ X ⟶ (T ⊗ X) ⊗ X := + (α_ T X X).hom ≫ (T ◁ (β_ X X).hom) ≫ (α_ T X X).inv + +/-- **The braiding of the last two factors is natural in the base.** +The braiding touches only those two factors, so a morphism of the +base passes through. -/ +private theorem swapBase_naturality [Category.{v} A] [MonoidalCategory A] + {T T' : A} (X : A) + [SymmetricCategory A] (f : T ⟶ T') : + ((f ▷ X) ▷ X) ≫ swapBase T' X = swapBase T X ≫ ((f ▷ X) ▷ X) := by + change ((f ▷ X) ▷ X) ≫ + ((α_ T' X X).hom ≫ (T' ◁ (β_ X X).hom) ≫ (α_ T' X X).inv) = + ((α_ T X X).hom ≫ (T ◁ (β_ X X).hom) ≫ (α_ T X X).inv) ≫ + ((f ▷ X) ▷ X) + rw [associator_naturality_left_assoc, + ← whisker_exchange_assoc, associator_inv_naturality_left] + simp only [Category.assoc] + +/-- **The braiding of the last two factors passes a left factor of +the base.** Both sides carry the same braiding on the same two +strands; only the bracketing of the base differs. -/ +private theorem swapBase_tensor [Category.{v} A] [MonoidalCategory A] + (P Q X : A) [SymmetricCategory A] : + swapBase (P ⊗ Q) X ≫ ((α_ P Q X).hom ▷ X) ≫ + (α_ P (Q ⊗ X) X).hom = + ((α_ P Q X).hom ▷ X) ≫ (α_ P (Q ⊗ X) X).hom ≫ + (P ◁ swapBase Q X) := by + change swapBase (P ⊗ Q) X ≫ ((α_ P Q X).hom ▷ X) ≫ + (α_ P (Q ⊗ X) X).hom = + ((α_ P Q X).hom ▷ X) ≫ (α_ P (Q ⊗ X) X).hom ≫ + (P ◁ ((α_ Q X X).hom ≫ (Q ◁ (β_ X X).hom) ≫ (α_ Q X X).inv)) + change ((α_ (P ⊗ Q) X X).hom ≫ ((P ⊗ Q) ◁ (β_ X X).hom) ≫ + (α_ (P ⊗ Q) X X).inv) ≫ ((α_ P Q X).hom ▷ X) ≫ + (α_ P (Q ⊗ X) X).hom = _ + simp only [whiskerLeft_comp, Category.assoc] + monoidal + +/-- **The braiding respects the splitting**: braiding the last two +factors of a tensor power is braiding them inside the upper block. -/ +theorem swapTop_comp_splitPow [Category.{v} A] [MonoidalCategory A] + (X : A) [SymmetricCategory A] + (p q : ℕ) : + swapTop X (p + q) ≫ (splitPow X p (q + 1 + 1)).hom = + (splitPow X p (q + 1 + 1)).hom ≫ + (tensorPow A X p ◁ swapTop X q) := by + rw [splitPow_succ, splitPow_succ] + change swapBase (tensorPow A X (p + q)) X ≫ + ((((splitPow X p q).hom ▷ X) ≫ + (α_ (tensorPow A X p) (tensorPow A X q) X).hom) ▷ X) ≫ + (α_ (tensorPow A X p) (tensorPow A X q ⊗ X) X).hom = + (((((splitPow X p q).hom ▷ X) ≫ + (α_ (tensorPow A X p) (tensorPow A X q) X).hom) ▷ X) ≫ + (α_ (tensorPow A X p) (tensorPow A X q ⊗ X) X).hom) ≫ + (tensorPow A X p ◁ swapBase (tensorPow A X q) X) + rw [comp_whiskerRight] + simp only [Category.assoc] + rw [← Category.assoc (swapBase (tensorPow A X (p + q)) X), + ← swapBase_naturality X (splitPow X p q).hom] + simp only [Category.assoc] + rw [swapBase_tensor] + +/-! ## Transferring a splitting to one more factor -/ + +/-- **One more factor**: a morphism that respects the splitting +whiskered by one further factor still respects it. This is the +inductive step every splitting statement below is proved by. -/ +private theorem whiskerRight_comp_splitPow [Category.{v} A] [MonoidalCategory A] + (X : A) (p q : ℕ) + {u : tensorPow A X (p + q) ⟶ tensorPow A X (p + q)} + {v : tensorPow A X q ⟶ tensorPow A X q} + (h : u ≫ (splitPow X p q).hom = + (splitPow X p q).hom ≫ (tensorPow A X p ◁ v)) : + (u ▷ X) ≫ (splitPow X p (q + 1)).hom = + (splitPow X p (q + 1)).hom ≫ + (tensorPow A X p ◁ (v ▷ X)) := by + rw [splitPow_succ] + change (u ▷ X) ≫ (((splitPow X p q).hom ▷ X) ≫ + (α_ (tensorPow A X p) (tensorPow A X q) X).hom) = + ((((splitPow X p q).hom ▷ X) ≫ + (α_ (tensorPow A X p) (tensorPow A X q) X).hom)) ≫ + (tensorPow A X p ◁ (v ▷ X)) + rw [← Category.assoc, ← comp_whiskerRight, h, comp_whiskerRight, + Category.assoc, Category.assoc, + whisker_assoc (tensorPow A X p) v X] + simp only [Category.assoc, Iso.inv_hom_id, Category.comp_id] + +/-! ## Bubbling respects the splitting -/ + +/-- **Bubbling respects the splitting**: bubbling the top factor +down at most `q` slots never reaches the lower block, so it is +bubbling inside the upper block. -/ +theorem insertTop_comp_splitPow [Category.{v} A] [MonoidalCategory A] + (X : A) [SymmetricCategory A] + (p : ℕ) : + ∀ (k q : ℕ), k ≤ q → + insertTop X (p + q) k ≫ (splitPow X p (q + 1)).hom = + (splitPow X p (q + 1)).hom ≫ + (tensorPow A X p ◁ insertTop X q k) + | 0, q, _ => by + rw [insertTop_zero, insertTop_zero, + MonoidalCategory.whiskerLeft_id, Category.id_comp, + Category.comp_id] + | k + 1, q, hk => by + obtain ⟨r, rfl⟩ : ∃ r, q = r + 1 := ⟨q - 1, by omega⟩ + have hkr : k ≤ r := by omega + have hL : insertTop X (p + (r + 1)) (k + 1) = + swapTop X (p + r) ≫ (insertTop X (p + r) k ▷ X) := + insertTop_succ X (p + r) k + have hR : tensorPow A X p ◁ insertTop X (r + 1) (k + 1) = + (tensorPow A X p ◁ swapTop X r) ≫ + (tensorPow A X p ◁ (insertTop X r k ▷ X)) := by + rw [insertTop_succ] + exact MonoidalCategory.whiskerLeft_comp _ _ _ + have hstep := whiskerRight_comp_splitPow X p (r + 1) + (insertTop_comp_splitPow X p k r hkr) + rw [hL, hR] + erw [Category.assoc, hstep, ← Category.assoc, + swapTop_comp_splitPow X p r, Category.assoc] + rfl + +/-! ## Tensor powers respect the splitting -/ + +/-- **One more factor, in tensor form**: a morphism that respects +the splitting, tensored with a morphism of the new factor, still +respects it. -/ +private theorem tensorHom_comp_splitPow [Category.{v} A] [MonoidalCategory A] + (X : A) (p q : ℕ) + {u : tensorPow A X (p + q) ⟶ tensorPow A X (p + q)} + {a : tensorPow A X p ⟶ tensorPow A X p} + {b : tensorPow A X q ⟶ tensorPow A X q} {c : X ⟶ X} + (h : u ≫ (splitPow X p q).hom = + (splitPow X p q).hom ≫ (a ⊗ₘ b)) : + (u ⊗ₘ c) ≫ (splitPow X p (q + 1)).hom = + (splitPow X p (q + 1)).hom ≫ (a ⊗ₘ (b ⊗ₘ c)) := by + rw [splitPow_succ] + change (u ⊗ₘ c) ≫ (((splitPow X p q).hom ▷ X) ≫ + (α_ (tensorPow A X p) (tensorPow A X q) X).hom) = + ((((splitPow X p q).hom ▷ X) ≫ + (α_ (tensorPow A X p) (tensorPow A X q) X).hom)) ≫ + (a ⊗ₘ (b ⊗ₘ c)) + have hst : (u ⊗ₘ c) ≫ ((splitPow X p q).hom ▷ X) = + ((splitPow X p q).hom ▷ X) ≫ ((a ⊗ₘ b) ⊗ₘ c) := by + rw [← tensorHom_id (splitPow X p q).hom X, + tensorHom_comp_tensorHom, tensorHom_comp_tensorHom, h, + Category.comp_id, Category.id_comp] + calc (u ⊗ₘ c) ≫ (((splitPow X p q).hom ▷ X) ≫ + (α_ (tensorPow A X p) (tensorPow A X q) X).hom) + = ((u ⊗ₘ c) ≫ ((splitPow X p q).hom ▷ X)) ≫ + (α_ (tensorPow A X p) (tensorPow A X q) X).hom := + (Category.assoc _ _ _).symm + _ = (((splitPow X p q).hom ▷ X) ≫ ((a ⊗ₘ b) ⊗ₘ c)) ≫ + (α_ (tensorPow A X p) (tensorPow A X q) X).hom := + congrArg (· ≫ (α_ (tensorPow A X p) (tensorPow A X q) X).hom) + hst + _ = ((splitPow X p q).hom ▷ X) ≫ (((a ⊗ₘ b) ⊗ₘ c) ≫ + (α_ (tensorPow A X p) (tensorPow A X q) X).hom) := + Category.assoc _ _ _ + _ = ((splitPow X p q).hom ▷ X) ≫ + ((α_ (tensorPow A X p) (tensorPow A X q) X).hom ≫ + (a ⊗ₘ (b ⊗ₘ c))) := + congrArg (fun z => ((splitPow X p q).hom ▷ X) ≫ z) + (associator_naturality a b c) + _ = (((splitPow X p q).hom ▷ X) ≫ + (α_ (tensorPow A X p) (tensorPow A X q) X).hom) ≫ + (a ⊗ₘ (b ⊗ₘ c)) := (Category.assoc _ _ _).symm + +/-- **The tensor power of an endomorphism respects the splitting.** +-/ +theorem powHom_comp_splitPow [Category.{v} A] [MonoidalCategory A] + (X : A) (g : End X) (p : ℕ) : + ∀ q : ℕ, + powHom X g (p + q) ≫ (splitPow X p q).hom = + (splitPow X p q).hom ≫ (powHom X g p ⊗ₘ powHom X g q) + | 0 => by + rw [splitPow_zero] + change powHom X g p ≫ (ρ_ (tensorPow A X p)).inv = + (ρ_ (tensorPow A X p)).inv ≫ (powHom X g p ⊗ₘ 𝟙 (𝟙_ A)) + rw [tensorHom_id, rightUnitor_inv_naturality] + | q + 1 => by + have h := tensorHom_comp_splitPow X p q (c := g) + (powHom_comp_splitPow X g p q) + exact h + +/-! ## The action respects the splitting -/ + +/-- **The action respects the splitting**: a block sum of +permutations acts as the two permutations acting on the two +blocks. -/ +theorem permMor_comp_splitPow [Category.{v} A] [MonoidalCategory A] + (X : A) [SymmetricCategory A] {p : ℕ} + (σ : Equiv.Perm (Fin p)) : + ∀ (q : ℕ) (τ : Equiv.Perm (Fin q)), + permMor X (p + q) (blockSum σ τ) ≫ (splitPow X p q).hom = + (splitPow X p q).hom ≫ (permMor X p σ ⊗ₘ permMor X q τ) + | 0, τ => by + rw [blockSum_of_zero, splitPow_zero] + change permMor X p σ ≫ (ρ_ (tensorPow A X p)).inv = + (ρ_ (tensorPow A X p)).inv ≫ (permMor X p σ ⊗ₘ 𝟙 (𝟙_ A)) + rw [tensorHom_id, rightUnitor_inv_naturality] + | q + 1, τ => by + have htop : ((topImage τ : ℕ)) ≤ q := Nat.lt_succ_iff.mp + (topImage τ).isLt + have hval : ((topImage (n := p + q) + (blockSum (p := p) (q := q + 1) σ τ) : ℕ)) = + p + (topImage τ : ℕ) := + congrArg Fin.val (topImage_blockSum σ τ) + have hk : p + q - ((topImage (n := p + q) + (blockSum (p := p) (q := q + 1) σ τ) : ℕ)) = + q - (topImage τ : ℕ) := by omega + have hkq : q - (topImage τ : ℕ) ≤ q := by omega + have hL : permMor X (p + (q + 1)) + (blockSum (p := p) (q := q + 1) σ τ) = + (permMor X (p + q) (blockSum σ (restPerm τ)) ▷ X) ≫ + insertTop X (p + q) (q - (topImage τ : ℕ)) := by + change permMor X (p + q + 1) + (blockSum (p := p) (q := q + 1) σ τ) = _ + rw [permMor_succ X (p + q) + (blockSum (p := p) (q := q + 1) σ τ), + restPerm_blockSum, hk] + have hR : permMor X (q + 1) τ = + (permMor X q (restPerm τ) ▷ X) ≫ + insertTop X q (q - (topImage τ : ℕ)) := + permMor_succ X q τ + have hw := tensorHom_comp_splitPow X p q (c := 𝟙 X) + (permMor_comp_splitPow X σ q (restPerm τ)) + have hi := insertTop_comp_splitPow X p (q - (topImage τ : ℕ)) q + hkq + rw [hL, hR] + erw [Category.assoc, hi, ← Category.assoc, + ← tensorHom_id (permMor X (p + q) (blockSum σ (restPerm τ))) X, hw] + erw [Category.assoc, + ← id_tensorHom (tensorPow A X p) (insertTop X q (q - (topImage τ : ℕ))), + tensorHom_comp_tensorHom, Category.comp_id, tensorHom_id] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/TraceZeta.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TraceZeta.lean new file mode 100644 index 0000000000..2ad08e8c6c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TraceZeta.lean @@ -0,0 +1,103 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentTrace +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaRational +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaExp + +/-! +# The quantitative trace-zeta theorem + +In a Frobenius tower, the trace zeta function of every element is +rational with numerator and denominator degrees bounded by the hook +parameter. This combines hook confinement (dead shapes outside a hook) +with the Frobenius identity (turning dead shapes into Schur vanishing) +and the rationality and reduced super-spectrum results from +`ZetaRational` and `HookVanishing`. + +The side is existentially quantified here, and the package is arbitrary. +`TraceZetaSharp.lean` states the same conclusions in the appendix's +own generality: a real dimension bound and every side above +`2e√A`. + +Unlike `NilpotentTrace`, no nilpotency hypothesis is needed: the +hook-vanishing half of the proof uses only the Frobenius identity and +hook confinement, both of which hold for every element. +-/ + +@[expose] public section + +namespace RS + +universe u + +open scoped Polynomial PowerSeries + +namespace FrobeniusTower + +variable {P : SchurPackage.{u}} {E : ℕ → Type u} + +/-- The hook-vanishing lemma for an arbitrary element of a Frobenius +tower: the Schur specialization of the power-trace sequence vanishes +outside the hook `hook_confinement` supplies. -/ +private theorem schur_vanishing_of_frobenius + [∀ n, Ring (E n)] [∀ n, Algebra ℂ (E n)] {A : ℝ} {Alg : Type u} + [Ring Alg] [Algebra ℂ Alg] + [∀ n, Module.Finite ℂ (E n)] + (T : FrobeniusTower P E A Alg) (g : Alg) : + ∃ s : ℕ, ∀ μ : YoungDiagram, ¬ IsInHook (s - 1) (s - 1) μ → + diagramSchur μ (fun m => T.traceA (g ^ m)) = 0 := + let ⟨s, hconf⟩ := T.toPermTower.hook_confinement P + ⟨s, T.schur_vanishing_of_confinement g hconf⟩ + +/-- **The trace-zeta theorem over an arbitrary Schur package**: in a +Frobenius tower, the trace zeta function of every element is rational +with numerator and denominator degrees bounded by the hook parameter +the package's growth field supplies. Corollary A.2 of the accompanying +paper, with its real growth constant and its threshold on every side, is +`traceZeta_rational_sharp` in `TraceZetaSharp.lean`. -/ +theorem traceZeta_rational + [∀ n, Ring (E n)] [∀ n, Algebra ℂ (E n)] {A : ℝ} {Alg : Type u} + [Ring Alg] [Algebra ℂ Alg] + [∀ n, Module.Finite ℂ (E n)] + (T : FrobeniusTower P E A Alg) (g : Alg) : + ∃ (s : ℕ) (Pp Qp : Polynomial ℂ), + Pp.coeff 0 = 1 ∧ Qp.coeff 0 = 1 ∧ + Pp.natDegree ≤ s - 1 ∧ Qp.natDegree ≤ s - 1 ∧ + IsCoprime Pp Qp ∧ + traceZeta (fun m => T.traceA (g ^ m)) * ↑Qp = (↑Pp : PowerSeries ℂ) := by + obtain ⟨s, hvan⟩ := schur_vanishing_of_frobenius T g + obtain ⟨Pp, Qp, hPc, hQc, hPd, hQd, hcop, hid⟩ := + newtonH_series_rational_of_hook_vanishing hvan + exact ⟨s, Pp, Qp, hPc, hQc, hPd, hQd, hcop, + by rw [traceZeta_eq_newtonH_series]; exact hid⟩ + +/-- **The reduced super-spectrum corollary**: the trace sequence of every +element in a Frobenius tower is a difference of power sums of two +disjoint multisets of nonzero complex numbers of sizes at most +`s − 1`. -/ +theorem traceZeta_superSpectrum + [∀ n, Ring (E n)] [∀ n, Algebra ℂ (E n)] {A : ℝ} {Alg : Type u} + [Ring Alg] [Algebra ℂ Alg] + [∀ n, Module.Finite ℂ (E n)] + (T : FrobeniusTower P E A Alg) (g : Alg) : + ∃ (s : ℕ) (alpha beta : Multiset ℂ), + alpha.card ≤ s - 1 ∧ beta.card ≤ s - 1 ∧ + (∀ x ∈ alpha, x ≠ 0) ∧ (∀ x ∈ beta, x ≠ 0) ∧ + (∀ x ∈ alpha, x ∉ beta) ∧ + ∀ m : ℕ, 1 ≤ m → + T.traceA (g ^ m) = + (alpha.map (· ^ m)).sum - (beta.map (· ^ m)).sum := by + obtain ⟨s, hvan⟩ := schur_vanishing_of_frobenius T g + obtain ⟨alpha, beta, ha, hb, hαnz, hβnz, hdisj, hps⟩ := + superPowerSums_of_hook_vanishing hvan + exact ⟨s, alpha, beta, ha, hb, hαnz, hβnz, hdisj, hps⟩ + +end FrobeniusTower + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/TraceZetaSharp.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TraceZetaSharp.lean new file mode 100644 index 0000000000..8bef49510d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TraceZetaSharp.lean @@ -0,0 +1,115 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZeta +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinementSharp + +/-! +# The trace-zeta theorem with the sharp threshold + +The accompanying paper's Corollary A.2 in tower form, with the +appendix's own hypothesis on dimensions and its own threshold: for a +tower whose dimensions satisfy `finrank (E n) ≤ A ^ n`, and for +*every* integer `s > 2e√A`, the trace zeta function of every element +is `P/Q` with `P` and `Q` coprime, of constant term `1`, and of +degree at most `s − 1` (`traceZeta_rational_sharp`); equivalently the +power traces are a difference of power sums of two disjoint multisets +of nonzero complex numbers of sizes at most `s − 1` +(`traceZeta_superSpectrum_sharp`). + +The appendix begins with a rigid symmetric ℂ-linear category and an +object `Z`, and derives the symmetric-group action on `Z ^ ⊗ n`, the +propagation of vanishing, the traces and the Frobenius identity from +the trace calculus. A `FrobeniusTower` assumes exactly those as an +interface, and `ObjectTower.lean` constructs one from an arbitrary +category-and-object pair, so `traceZeta_rational_of_object` is Corollary A.2 +in the appendix's own generality; the skein endomorphism algebras +instantiate the interface directly (`SkeinTower.lean`, +`BlockAssembly.lean`). + +`TraceZeta.lean` proves the same conclusions over an arbitrary Schur +package with the side existentially quantified. The sharpness is in +the quantifier and the constant: every admissible side gives its own +degree bound, +and the threshold is stated in the growth constant itself. +-/ + +@[expose] public section + +namespace RS + +universe u + +open scoped Polynomial PowerSeries + +namespace FrobeniusTower + +variable {E : ℕ → Type u} + +/-- The hook-vanishing lemma at a given side above the threshold: the +Schur specialization of the power-trace sequence vanishes outside the +`(s − 1, s − 1)` hook. This is `schur_vanishing_of_confinement` fed +the sharp confinement in place of the existential one. -/ +private theorem schur_vanishing_sharp + [∀ n, Ring (E n)] [∀ n, Algebra ℂ (E n)] {A : ℝ} {Alg : Type u} + [Ring Alg] [Algebra ℂ Alg] + [∀ n, Module.Finite ℂ (E n)] + (T : FrobeniusTower schurPackage.{u} E A Alg) (g : Alg) {s : ℕ} + (hs : 2 * Real.exp 1 * Real.sqrt A < s) : + ∀ μ : YoungDiagram, ¬ IsInHook (s - 1) (s - 1) μ → + diagramSchur μ (fun m => T.traceA (g ^ m)) = 0 := + T.schur_vanishing_of_confinement g + (T.toPermTower.hook_confinement_sharp hs) + +/-- **The trace-zeta theorem** (the accompanying paper, Corollary A.2, +in tower form). For a tower whose dimensions are bounded by `A ^ n`, +and for every +integer `s > 2e√A`, the trace zeta function of every element of the +ambient algebra is rational, `ζ · Q = P`, with `P` and `Q` coprime +polynomials of constant term `1` and degree at most `s − 1`. -/ +theorem traceZeta_rational_sharp + [∀ n, Ring (E n)] [∀ n, Algebra ℂ (E n)] {A : ℝ} {Alg : Type u} + [Ring Alg] [Algebra ℂ Alg] + [∀ n, Module.Finite ℂ (E n)] + (T : FrobeniusTower schurPackage.{u} E A Alg) (g : Alg) {s : ℕ} + (hs : 2 * Real.exp 1 * Real.sqrt A < s) : + ∃ Pp Qp : Polynomial ℂ, + Pp.coeff 0 = 1 ∧ Qp.coeff 0 = 1 ∧ + Pp.natDegree ≤ s - 1 ∧ Qp.natDegree ≤ s - 1 ∧ + IsCoprime Pp Qp ∧ + traceZeta (fun m => T.traceA (g ^ m)) * ↑Qp = + (↑Pp : PowerSeries ℂ) := by + obtain ⟨Pp, Qp, hPc, hQc, hPd, hQd, hcop, hid⟩ := + newtonH_series_rational_of_hook_vanishing + (schur_vanishing_sharp T g hs) + exact ⟨Pp, Qp, hPc, hQc, hPd, hQd, hcop, + by rw [traceZeta_eq_newtonH_series]; exact hid⟩ + +/-- **The reduced super-spectrum form of Corollary A.2**: for every integer +`s > 2e√A` the power traces are a difference of power sums of two +disjoint multisets of nonzero complex numbers, each of size at most +`s − 1`. -/ +theorem traceZeta_superSpectrum_sharp + [∀ n, Ring (E n)] [∀ n, Algebra ℂ (E n)] {A : ℝ} {Alg : Type u} + [Ring Alg] [Algebra ℂ Alg] + [∀ n, Module.Finite ℂ (E n)] + (T : FrobeniusTower schurPackage.{u} E A Alg) (g : Alg) {s : ℕ} + (hs : 2 * Real.exp 1 * Real.sqrt A < s) : + ∃ alpha beta : Multiset ℂ, + alpha.card ≤ s - 1 ∧ beta.card ≤ s - 1 ∧ + (∀ x ∈ alpha, x ≠ 0) ∧ (∀ x ∈ beta, x ≠ 0) ∧ + (∀ x ∈ alpha, x ∉ beta) ∧ + ∀ m : ℕ, 1 ≤ m → + T.traceA (g ^ m) = + (alpha.map (· ^ m)).sum - (beta.map (· ^ m)).sum := + superPowerSums_of_hook_vanishing + (schur_vanishing_sharp T g hs) + +end FrobeniusTower + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/CircleValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/CircleValue.lean new file mode 100644 index 0000000000..d6dc605c35 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/CircleValue.lean @@ -0,0 +1,56 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdRigid + +/-! +# The circle value + +Closing the standard copairing against the standard form yields +the superdimension `k − 2ℓ`, which is the value Definition 5 gives +a free circle. +-/ + +@[expose] public section + +noncomputable section + +namespace RS + +open scoped TensorProduct + +/-- **The circle value** (accompanying paper §5.2): the standard form +closes +the standard copairing to the superdimension `k − 2ℓ`. -/ +theorem stdForm_comp_stdCopair (k ℓ : ℕ) : + (SuperVect.Hom.comp (stdForm k ℓ) (stdCopair k ℓ)).evenMap 1 = + (k : ℂ) - 2 * ℓ := by + change (LinearMap.coprod (TensorProduct.lift (stdFormEvenBilin k)) + (TensorProduct.lift (stdFormOddBilin ℓ))) + ((LinearMap.toSpanSingleton ℂ _ + (stdCopairEvenElem k, stdCopairOddElem ℓ)) 1) = + (k : ℂ) - 2 * ℓ + rw [LinearMap.toSpanSingleton_apply_one, LinearMap.coprod_apply] + have he : TensorProduct.lift (stdFormEvenBilin k) + (stdCopairEvenElem k) = (k : ℂ) := by + unfold stdCopairEvenElem + rw [map_sum] + rw [Finset.sum_congr rfl fun i _ => TensorProduct.lift.tmul + (f' := stdFormEvenBilin k) (stdE k i) (stdE k i)] + exact sum_stdFormEven_diag k + have ho : TensorProduct.lift (stdFormOddBilin ℓ) + (stdCopairOddElem ℓ) = -(2 * ℓ : ℂ) := by + unfold stdCopairOddElem + rw [map_sum] + rw [Finset.sum_congr rfl fun i _ => TensorProduct.lift.tmul + (f' := stdFormOddBilin ℓ) (stdF ℓ i) (stdG ℓ i)] + exact sum_stdFormOdd_diag ℓ + rw [he, ho] + ring + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/CoordIso.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/CoordIso.lean new file mode 100644 index 0000000000..2eb3017285 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/CoordIso.lean @@ -0,0 +1,142 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.Nondegenerate + +/-! +# The standard-model isomorphism + +The morphism-level packaging of the coordinate identification: a +super vector space carrying a supersymmetric form with a rigid +copairing is isomorphic to a standard model `stdSuperPair k ℓ`, by an +isomorphism pulling the form back to the standard form +(`exists_std_iso`). This is the full statement of the §5.1 +coordinate conventions: every self-dual object of SuperVect *is* +a standard orthosymplectic space, form and all. +-/ + +@[expose] public section + +noncomputable section + +namespace RS + +open CategoryTheory +open scoped TensorProduct + +/-- The graded coordinate equivalences packaged as a morphism of +super vector spaces. -/ +def coordHom {V : SuperVect} {k ℓ : ℕ} + (eE : (Fin k → ℂ) ≃ₗ[ℂ] V.even) + (eO : (Fin (2 * ℓ) → ℂ) ≃ₗ[ℂ] V.odd) : + SuperVect.Hom (stdSuperPair k ℓ) V := by + refine ⟨?_, ?_⟩ + · change (Fin k → ℂ) →ₗ[ℂ] V.even + exact eE.toLinearMap + · change (Fin (2 * ℓ) → ℂ) →ₗ[ℂ] V.odd + exact eO.toLinearMap + +/-- The inverse coordinate morphism. -/ +def coordInv {V : SuperVect} {k ℓ : ℕ} + (eE : (Fin k → ℂ) ≃ₗ[ℂ] V.even) + (eO : (Fin (2 * ℓ) → ℂ) ≃ₗ[ℂ] V.odd) : + SuperVect.Hom V (stdSuperPair k ℓ) := by + refine ⟨?_, ?_⟩ + · change V.even →ₗ[ℂ] (Fin k → ℂ) + exact eE.symm.toLinearMap + · change V.odd →ₗ[ℂ] (Fin (2 * ℓ) → ℂ) + exact eO.symm.toLinearMap + +/-- One round trip of the coordinate identification is the +identity. -/ +theorem coordInv_comp_coordHom {V : SuperVect} {k ℓ : ℕ} + (eE : (Fin k → ℂ) ≃ₗ[ℂ] V.even) + (eO : (Fin (2 * ℓ) → ℂ) ≃ₗ[ℂ] V.odd) : + SuperVect.Hom.comp (coordInv eE eO) (coordHom eE eO) = + SuperVect.Hom.id (stdSuperPair k ℓ) := by + apply SuperVect.Hom.ext + · change eE.symm.toLinearMap.comp eE.toLinearMap = LinearMap.id + exact LinearMap.ext fun z => eE.symm_apply_apply z + · change eO.symm.toLinearMap.comp eO.toLinearMap = LinearMap.id + exact LinearMap.ext fun z => eO.symm_apply_apply z + +/-- And so is the other — the two are mutually inverse. -/ +theorem coordHom_comp_coordInv {V : SuperVect} {k ℓ : ℕ} + (eE : (Fin k → ℂ) ≃ₗ[ℂ] V.even) + (eO : (Fin (2 * ℓ) → ℂ) ≃ₗ[ℂ] V.odd) : + SuperVect.Hom.comp (coordHom eE eO) (coordInv eE eO) = + SuperVect.Hom.id V := by + apply SuperVect.Hom.ext + · change eE.toLinearMap.comp eE.symm.toLinearMap = LinearMap.id + exact LinearMap.ext fun z => eE.apply_symm_apply z + · change eO.toLinearMap.comp eO.symm.toLinearMap = LinearMap.id + exact LinearMap.ext fun z => eO.apply_symm_apply z + +/-- **Pullback of the form along the coordinate morphism**: when +the coordinate equivalences carry the blocks of `b` to the +standard forms, the coordinate morphism pulls `b` back to +`stdForm` as a morphism equation. -/ +theorem coordHom_form {V : SuperVect} {k ℓ : ℕ} + (b : SuperVect.Hom (SuperVect.tensorObj V V) SuperVect.tensorUnit) + (eE : (Fin k → ℂ) ≃ₗ[ℂ] V.even) + (eO : (Fin (2 * ℓ) → ℂ) ≃ₗ[ℂ] V.odd) + (hE : ∀ x y, formEvenBlock b (eE x) (eE y) = stdFormEven k x y) + (hO : ∀ x y, formOddBlock b (eO x) (eO y) = stdFormOdd ℓ x y) : + SuperVect.Hom.comp b + (SuperVect.tensorHom (coordHom eE eO) (coordHom eE eO)) = + stdForm k ℓ := by + apply SuperVect.Hom.ext + · change (formEvenMap b).comp + (LinearMap.prodMap + (TensorProduct.map eE.toLinearMap eE.toLinearMap) + (TensorProduct.map eO.toLinearMap eO.toLinearMap)) = + LinearMap.coprod (TensorProduct.lift (stdFormEvenBilin k)) + (TensorProduct.lift (stdFormOddBilin ℓ)) + refine LinearMap.prod_ext (TensorProduct.ext' fun u v => ?_) + (TensorProduct.ext' fun u v => ?_) + · simp only [LinearMap.comp_apply, LinearMap.inl_apply, + LinearMap.prodMap_apply, TensorProduct.map_tmul, + map_zero, LinearMap.coprod_apply, TensorProduct.lift.tmul, + add_zero, LinearEquiv.coe_coe] + exact hE u v + · simp only [LinearMap.comp_apply, LinearMap.inr_apply, + LinearMap.prodMap_apply, TensorProduct.map_tmul, + map_zero, LinearMap.coprod_apply, TensorProduct.lift.tmul, + zero_add, LinearEquiv.coe_coe] + exact hO u v + · exact LinearMap.ext fun z => Subsingleton.elim _ _ + +open MonoidalCategory in +/-- **The standard-model isomorphism** (accompanying paper §5.1): a super +vector space with a supersymmetric form and a rigid copairing is +isomorphic to a standard model, by an isomorphism carrying the +form to the standard form. -/ +theorem exists_std_iso {V : SuperVect} + (b : SuperVect.Hom (SuperVect.tensorObj V V) SuperVect.tensorUnit) + (C : SuperVect.Hom SuperVect.tensorUnit (SuperVect.tensorObj V V)) + (hb : SuperVect.Hom.comp b (SuperVect.koszulBraiding V V) = b) + (h1 : V ◁ (show 𝟙_ SuperVect ⟶ V ⊗ V from C) ≫ + (α_ V V V).inv ≫ + (show V ⊗ V ⟶ 𝟙_ SuperVect from b) ▷ V = + (ρ_ V).hom ≫ (λ_ V).inv) + (h2 : (show 𝟙_ SuperVect ⟶ V ⊗ V from C) ▷ V ≫ + (α_ V V V).hom ≫ + V ◁ (show V ⊗ V ⟶ 𝟙_ SuperVect from b) = + (λ_ V).hom ≫ (ρ_ V).inv) : + ∃ (k ℓ : ℕ) (e : SuperVect.Hom (stdSuperPair k ℓ) V) + (e' : SuperVect.Hom V (stdSuperPair k ℓ)), + SuperVect.Hom.comp e' e = SuperVect.Hom.id (stdSuperPair k ℓ) ∧ + SuperVect.Hom.comp e e' = SuperVect.Hom.id V ∧ + SuperVect.Hom.comp b (SuperVect.tensorHom e e) = stdForm k ℓ := by + obtain ⟨k, ℓ, eE, eO, hE, hO⟩ := + exists_coordinates_of_snake b C hb h1 h2 + exact ⟨k, ℓ, coordHom eE eO, coordInv eE eO, + coordInv_comp_coordHom eE eO, coordHom_comp_coordInv eE eO, + coordHom_form b eE eO hE hO⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/Coordinates.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/Coordinates.lean new file mode 100644 index 0000000000..e5d87b04a9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/Coordinates.lean @@ -0,0 +1,254 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.OrthonormalBasis +public import LeanPool.RegtsSevenster.RS.Classical.Super.SymplecticBasis +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdDuality + +/-! +# Standard orthosymplectic coordinates + +The coordinate-identification step of §5.1: a super vector space `V` +carrying a supersymmetric nondegenerate form `b : V ⊗ V ⟶ 𝟙` is +isomorphic, as a graded space with form, to the standard model +`stdSuperPair k ℓ` with the standard form. + +The route: + +* `formEvenBlock` / `formOddBlock` extract the two bilinear blocks + of the even component of `b` (the mixed blocks land in the odd + component, which is zero). +* Supersymmetry `b ∘ β = b` makes the even block symmetric and the + odd block alternating (`formEvenBlock_symm`, `formOddBlock_isAlt`) + — the Koszul sign on the odd⊗odd summand is exactly the + antisymmetry. +* `exists_even_coordinates` and `exists_odd_coordinates` convert + the orthonormal- and symplectic-basis theorems into linear + coordinate equivalences carrying each block to `stdFormEven` / + `stdFormOdd`. +* `exists_coordinates` assembles the graded statement. +-/ + +@[expose] public section + +noncomputable section + +namespace RS + +open scoped TensorProduct +open LinearMap (BilinForm) +open Module + +/-! ### The bilinear blocks of a form morphism -/ + +/-- The even component of a form morphism `V ⊗ V ⟶ 𝟙`, with its +domain and codomain presented in reduced form. -/ +def formEvenMap {V : SuperVect} + (b : SuperVect.Hom (SuperVect.tensorObj V V) SuperVect.tensorUnit) : + ((V.even ⊗[ℂ] V.even) × (V.odd ⊗[ℂ] V.odd)) →ₗ[ℂ] ℂ := + b.evenMap + +/-- The even block of a form morphism, as a bilinear form on +`V.even`. -/ +def formEvenBlock {V : SuperVect} + (b : SuperVect.Hom (SuperVect.tensorObj V V) SuperVect.tensorUnit) : + BilinForm ℂ V.even := + TensorProduct.curry ((formEvenMap b).comp (LinearMap.inl ℂ _ _)) + +/-- The odd block of a form morphism, as a bilinear form on +`V.odd`. -/ +def formOddBlock {V : SuperVect} + (b : SuperVect.Hom (SuperVect.tensorObj V V) SuperVect.tensorUnit) : + BilinForm ℂ V.odd := + TensorProduct.curry ((formEvenMap b).comp (LinearMap.inr ℂ _ _)) + +/-- The even block evaluates the even map on the even⊗even +summand. -/ +theorem formEvenBlock_apply {V : SuperVect} + (b : SuperVect.Hom (SuperVect.tensorObj V V) SuperVect.tensorUnit) + (x y : V.even) : + formEvenBlock b x y = formEvenMap b (x ⊗ₜ[ℂ] y, 0) := rfl + +/-- The odd block evaluates the even map on the odd⊗odd summand. -/ +theorem formOddBlock_apply {V : SuperVect} + (b : SuperVect.Hom (SuperVect.tensorObj V V) SuperVect.tensorUnit) + (x y : V.odd) : + formOddBlock b x y = formEvenMap b (0, x ⊗ₜ[ℂ] y) := rfl + +/-! ### Supersymmetry makes the blocks symmetric and alternating -/ + +/-- Supersymmetry restricted to the even block: the even map +absorbs the Koszul braiding, whose even⊗even component is the +plain swap. -/ +theorem formEvenBlock_symm {V : SuperVect} + (b : SuperVect.Hom (SuperVect.tensorObj V V) SuperVect.tensorUnit) + (hb : SuperVect.Hom.comp b (SuperVect.koszulBraiding V V) = b) + (x y : V.even) : + formEvenBlock b x y = formEvenBlock b y x := by + have he : (formEvenMap b).comp + (SuperVect.koszulEvenAux V.even V.even V.odd V.odd) = + formEvenMap b := + congrArg SuperVect.Hom.evenMap hb + have hxy := LinearMap.congr_fun he + ((y ⊗ₜ[ℂ] x, 0) : (V.even ⊗[ℂ] V.even) × (V.odd ⊗[ℂ] V.odd)) + rw [LinearMap.comp_apply, SuperVect.koszulEvenAux_fst] at hxy + rw [formEvenBlock_apply, formEvenBlock_apply, hxy] + +/-- Supersymmetry restricted to the odd block: the Koszul sign on +the odd⊗odd summand makes the block skew-symmetric. -/ +theorem formOddBlock_skew {V : SuperVect} + (b : SuperVect.Hom (SuperVect.tensorObj V V) SuperVect.tensorUnit) + (hb : SuperVect.Hom.comp b (SuperVect.koszulBraiding V V) = b) + (x y : V.odd) : + formOddBlock b x y = -formOddBlock b y x := by + have he : (formEvenMap b).comp + (SuperVect.koszulEvenAux V.even V.even V.odd V.odd) = + formEvenMap b := + congrArg SuperVect.Hom.evenMap hb + have hxy := LinearMap.congr_fun he + ((0, y ⊗ₜ[ℂ] x) : (V.even ⊗[ℂ] V.even) × (V.odd ⊗[ℂ] V.odd)) + rw [LinearMap.comp_apply, SuperVect.koszulEvenAux_snd, map_neg] at hxy + rw [formOddBlock_apply, formOddBlock_apply, ← hxy, neg_neg] + +/-- The odd block of a supersymmetric form is alternating. -/ +theorem formOddBlock_isAlt {V : SuperVect} + (b : SuperVect.Hom (SuperVect.tensorObj V V) SuperVect.tensorUnit) + (hb : SuperVect.Hom.comp b (SuperVect.koszulBraiding V V) = b) : + (formOddBlock b).IsAlt := by + intro x + have h := formOddBlock_skew b hb x x + have h2 : (2 : ℂ) * formOddBlock b x x = 0 := by + rw [two_mul] + nth_rewrite 1 [h] + rw [neg_add_cancel] + rcases mul_eq_zero.mp h2 with h3 | h3 + · exact absurd h3 two_ne_zero + · exact h3 + +/-! ### The symplectic normal form matches the standard odd form -/ + +/-- The symplectic normal-form matrix delivered by +`exists_symplectic_basis` equals the partner/sign matrix of +`stdFormOdd`. -/ +theorem symplecticMatrix_eq_std (ℓ : ℕ) (i j : Fin (2 * ℓ)) : + (if (i : ℕ) + ℓ = (j : ℕ) then (1 : ℂ) + else if (j : ℕ) + ℓ = (i : ℕ) then -1 else 0) = + if j = oddPartner ℓ i then -(oddPartnerSign ℓ i : ℂ) else 0 := by + have hi := i.isLt + have hj := j.isLt + have hpart : (j = oddPartner ℓ i) ↔ + ((i : ℕ) + ℓ = (j : ℕ) ∨ (j : ℕ) + ℓ = (i : ℕ)) := by + unfold oddPartner + rcases Nat.lt_or_ge i.val ℓ with h | h + · rw [dite_eq_left h] + constructor + · intro hh + have h2 : (j : ℕ) = i.val + ℓ := congrArg Fin.val hh + omega + · intro hh + refine Fin.ext ?_ + change (j : ℕ) = i.val + ℓ + omega + · rw [dite_eq_right (Nat.not_lt.mpr h)] + constructor + · intro hh + have h2 : (j : ℕ) = i.val - ℓ := congrArg Fin.val hh + omega + · intro hh + refine Fin.ext ?_ + change (j : ℕ) = i.val - ℓ + omega + by_cases hp : j = oddPartner ℓ i + · rw [ite_eq_left hp] + unfold oddPartnerSign + rcases hpart.mp hp with h1 | h1 + · rw [ite_eq_left h1, ite_eq_left (show i.val < ℓ by omega)] + norm_num + · rw [ite_eq_right (show ¬ (i : ℕ) + ℓ = (j : ℕ) by omega), ite_eq_left h1, + ite_eq_right (show ¬ i.val < ℓ by omega)] + norm_num + · rw [ite_eq_right hp, + ite_eq_right (fun hh => hp (hpart.mpr (Or.inl hh))), + ite_eq_right (fun hh => hp (hpart.mpr (Or.inr hh)))] + +/-! ### Coordinates for the two blocks -/ + +/-- **Even coordinates**: a symmetric nondegenerate bilinear form +is carried to the standard even form by the coordinate +equivalence of an orthonormal basis. -/ +theorem exists_even_coordinates {V : Type} [AddCommGroup V] + [Module ℂ V] [FiniteDimensional ℂ V] (B : BilinForm ℂ V) + (hsymm : ∀ x y, B x y = B y x) + (hnd : ∀ x, (∀ y, B x y = 0) → x = 0) : + ∃ (k : ℕ) (e : (Fin k → ℂ) ≃ₗ[ℂ] V), + ∀ x y, B (e x) (e y) = stdFormEven k x y := by + obtain ⟨bb, hbb⟩ := exists_orthonormal_basis B hsymm hnd + refine ⟨finrank ℂ V, bb.equivFun.symm, fun x y => ?_⟩ + rw [Basis.equivFun_symm_apply, Basis.equivFun_symm_apply] + simp only [map_sum, map_smul, LinearMap.sum_apply, + LinearMap.smul_apply, smul_eq_mul, hbb] + unfold stdFormEven + refine Finset.sum_congr rfl (fun i _ => ?_) + rw [Finset.sum_eq_single i, ite_eq_left rfl, mul_one] + · exact mul_comm _ _ + · intro m _ hm + rw [ite_eq_right hm, mul_zero] + · intro hmem + exact absurd (Finset.mem_univ i) hmem + +/-- **Odd coordinates**: an alternating nondegenerate bilinear +form is carried to the standard odd form by the coordinate +equivalence of a symplectic basis. -/ +theorem exists_odd_coordinates {V : Type} [AddCommGroup V] + [Module ℂ V] [FiniteDimensional ℂ V] (B : BilinForm ℂ V) + (hAlt : B.IsAlt) (hND : B.Nondegenerate) : + ∃ (ℓ : ℕ) (e : (Fin (2 * ℓ) → ℂ) ≃ₗ[ℂ] V), + ∀ x y, B (e x) (e y) = stdFormOdd ℓ x y := by + obtain ⟨ℓ, _, f, hf⟩ := exists_symplectic_basis B hAlt hND + have hfM : ∀ i j, B (f i) (f j) = + if j = oddPartner ℓ i then -(oddPartnerSign ℓ i : ℂ) else 0 := + fun i j => (hf i j).trans (symplecticMatrix_eq_std ℓ i j) + refine ⟨ℓ, f.equivFun.symm, fun x y => ?_⟩ + rw [Basis.equivFun_symm_apply, Basis.equivFun_symm_apply] + simp only [map_sum, map_smul, LinearMap.sum_apply, + LinearMap.smul_apply, smul_eq_mul, hfM] + unfold stdFormOdd + refine Fintype.sum_equiv + ⟨oddPartner ℓ, oddPartner ℓ, oddPartner_invol ℓ, oddPartner_invol ℓ⟩ + _ _ (fun i => ?_) + simp only [Equiv.coe_fn_mk] + rw [Finset.sum_eq_single (oddPartner ℓ i), + ite_eq_left (oddPartner_invol ℓ i).symm, oddPartner_invol] + · ring + · intro m _ hm + rw [ite_eq_right (fun hh => hm (by rw [hh, oddPartner_invol])), mul_zero] + · intro hmem + exact absurd (Finset.mem_univ (oddPartner ℓ i)) hmem + +/-! ### The graded coordinate identification -/ + +/-- **Standard orthosymplectic coordinates** (accompanying paper §5.1): a +super vector space with a supersymmetric form whose blocks are +nondegenerate admits graded coordinates carrying the blocks to +the standard forms of `stdSuperPair k ℓ`. -/ +theorem exists_coordinates {V : SuperVect} + (b : SuperVect.Hom (SuperVect.tensorObj V V) SuperVect.tensorUnit) + (hb : SuperVect.Hom.comp b (SuperVect.koszulBraiding V V) = b) + (hndE : ∀ x, (∀ y, formEvenBlock b x y = 0) → x = 0) + (hndO : (formOddBlock b).Nondegenerate) : + ∃ (k ℓ : ℕ) (eE : (Fin k → ℂ) ≃ₗ[ℂ] V.even) + (eO : (Fin (2 * ℓ) → ℂ) ≃ₗ[ℂ] V.odd), + (∀ x y, formEvenBlock b (eE x) (eE y) = stdFormEven k x y) ∧ + (∀ x y, formOddBlock b (eO x) (eO y) = stdFormOdd ℓ x y) := by + obtain ⟨k, eE, hE⟩ := exists_even_coordinates (formEvenBlock b) + (formEvenBlock_symm b hb) hndE + obtain ⟨ℓ, eO, hO⟩ := exists_odd_coordinates (formOddBlock b) + (formOddBlock_isAlt b hb) hndO + exact ⟨k, ℓ, eE, eO, hE, hO⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/CopairUnique.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/CopairUnique.lean new file mode 100644 index 0000000000..98a0b77733 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/CopairUnique.lean @@ -0,0 +1,284 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.Nondegenerate +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdRigid + +/-! +# Uniqueness of the copairing + +The snake identities determine the copairing (accompanying paper +§5.2): +any copairing for the standard form equals `stdCopair`. + +The engine is the *contraction operator* of a bilinear form, +`contractionMap B : M ⊗ N →ₗ (M →ₗ N)`, sending `m ⊗ n` to +`x ↦ B(x, m) • n`. The contraction identities say exactly that +the copairing's blocks are sent to the identity; the operator is +injective for a nondegenerate form on a finite-dimensional space +(`dualTensorHom` is bijective, and the form identifies the space +with its dual), so the blocks are pinned to the standard +copairing elements, which satisfy the same identities. +-/ + +@[expose] public section + +noncomputable section + +namespace RS + +open CategoryTheory +open scoped TensorProduct +open LinearMap (BilinForm) +open LinearMap.BilinForm +open Module + +/-! ### The contraction operator -/ + +/-- The left contraction operator of a bilinear form: +`m ⊗ n ↦ (x ↦ B(x, m) • n)`. -/ +def contractionMap {M N : Type*} [AddCommGroup M] [Module ℂ M] + [AddCommGroup N] [Module ℂ N] (B : BilinForm ℂ M) : + (M ⊗[ℂ] N) →ₗ[ℂ] (M →ₗ[ℂ] N) := + (dualTensorHom ℂ M N).comp + (TensorProduct.map (LinearMap.flip B) LinearMap.id) + +/-- The contraction operator on a pure tensor. -/ +theorem contractionMap_tmul {M N : Type*} [AddCommGroup M] + [Module ℂ M] [AddCommGroup N] [Module ℂ N] (B : BilinForm ℂ M) + (m : M) (n : N) (x : M) : + contractionMap B (m ⊗ₜ[ℂ] n) x = B x m • n := by + simp [contractionMap, TensorProduct.map_tmul] + +/-- The contraction operator of a nondegenerate form on a +finite-dimensional space is injective: the form identifies the +space with its dual, and `dualTensorHom` is bijective. -/ +theorem contractionMap_injective {M N : Type*} [AddCommGroup M] + [Module ℂ M] [FiniteDimensional ℂ M] [AddCommGroup N] + [Module ℂ N] (B : BilinForm ℂ M) (hB : B.Nondegenerate) : + Function.Injective (contractionMap (N := N) B) := by + have hm : TensorProduct.map (LinearMap.flip B) LinearMap.id = + (TensorProduct.congr (LinearMap.BilinForm.toDual B.flip hB.flip) + (LinearEquiv.refl ℂ N)).toLinearMap := by + apply TensorProduct.ext' + intro m n + rw [TensorProduct.map_tmul, LinearEquiv.coe_coe, + TensorProduct.congr_tmul] + exact congrArg (fun f : Module.Dual ℂ M => f ⊗ₜ[ℂ] n) + (LinearMap.ext fun y => (toDual_def hB.flip).symm) + have hminj : Function.Injective + ⇑(TensorProduct.map (LinearMap.flip B) + (LinearMap.id : N →ₗ[ℂ] N)) := by + rw [hm] + exact (TensorProduct.congr + (LinearMap.BilinForm.toDual B.flip hB.flip) + (LinearEquiv.refl ℂ N)).injective + have hdt : Function.Injective ⇑(dualTensorHom ℂ M N) := by + have hb := (dualTensorHomEquivOfBasis + (R := ℂ) (M := M) (N := N) + (Module.Free.chooseBasis ℂ M)).injective + intro a b hab + exact hb (by + simpa only [dualTensorHomEquivOfBasis_apply] using hab) + intro t t' h + exact hminj (hdt h) + +/-! ### Nondegeneracy of the standard bilinear forms -/ + +/-- The standard even form is nondegenerate, so its contraction +operator is injective. -/ +theorem stdFormEvenBilin_nondegenerate (k : ℕ) : + (stdFormEvenBilin k).Nondegenerate := by + constructor + · intro x hx + funext j + have h := hx (stdE k j) + rw [show stdFormEvenBilin k x (stdE k j) = + stdFormEven k x (stdE k j) from rfl, + stdFormEven_comm, stdFormEven_stdE_left] at h + exact h + · intro x hx + funext j + have h := hx (stdE k j) + rw [show stdFormEvenBilin k (stdE k j) x = + stdFormEven k (stdE k j) x from rfl, + stdFormEven_stdE_left] at h + exact h + +/-- The standard odd form is nondegenerate too. -/ +theorem stdFormOddBilin_nondegenerate (ℓ : ℕ) : + (stdFormOddBilin ℓ).Nondegenerate := by + constructor + · intro x hx + funext j + have h := hx (stdG ℓ j) + rw [show stdFormOddBilin ℓ x (stdG ℓ j) = + stdFormOdd ℓ x (stdG ℓ j) from rfl, + stdFormOdd_antisymm, stdFormOdd_stdG_left] at h + exact neg_eq_zero.mp h + · intro x hx + funext j + have h := hx (stdG ℓ j) + rw [show stdFormOddBilin ℓ (stdG ℓ j) x = + stdFormOdd ℓ (stdG ℓ j) x from rfl, + stdFormOdd_stdG_left] at h + exact h + +/-! ### The standard copairing contracts to the identity -/ + +/-- The standard even copairing element contracts to the identity — +it satisfies the even contraction identity. -/ +theorem contractionMap_stdCopairEvenElem (k : ℕ) (x : Fin k → ℂ) : + contractionMap (stdFormEvenBilin k) (stdCopairEvenElem k) x = x := by + unfold stdCopairEvenElem + rw [map_sum, LinearMap.sum_apply, + Finset.sum_congr rfl fun i _ => + contractionMap_tmul (stdFormEvenBilin k) (stdE k i) (stdE k i) x, + Finset.sum_congr rfl fun i _ => by + rw [show stdFormEvenBilin k x (stdE k i) = + stdFormEven k x (stdE k i) from rfl, stdFormEven_comm]] + exact sum_stdFormEven_smul k x + +/-- The standard odd form against a basis vector on the right: +`b(x, f_m) = s_m · x_{p(m)}`. -/ +theorem stdFormOdd_stdF_right (ℓ : ℕ) (x : Fin (2 * ℓ) → ℂ) + (m : Fin (2 * ℓ)) : + stdFormOdd ℓ x (stdF ℓ m) = + (oddPartnerSign ℓ m : ℂ) * x (oddPartner ℓ m) := by + unfold stdFormOdd stdF + rw [Finset.sum_eq_single (oddPartner ℓ m)] + · rw [oddPartner_invol, Pi.single_eq_same, mul_one, + oddPartnerSign_oddPartner] + push_cast + ring + · intro i _ hi + rw [Pi.single_eq_of_ne (fun hh : oddPartner ℓ i = m => + hi (by rw [← hh, oddPartner_invol])), mul_zero] + · intro hmem + exact absurd (Finset.mem_univ _) hmem + +/-- And the odd element satisfies the odd one. -/ +theorem contractionMap_stdCopairOddElem (ℓ : ℕ) + (x : Fin (2 * ℓ) → ℂ) : + contractionMap (stdFormOddBilin ℓ) (stdCopairOddElem ℓ) x = x := by + unfold stdCopairOddElem + rw [map_sum, LinearMap.sum_apply, + Finset.sum_congr rfl fun i _ => + contractionMap_tmul (stdFormOddBilin ℓ) (stdF ℓ i) (stdG ℓ i) x, + Finset.sum_congr rfl fun i _ => by + rw [show stdFormOddBilin ℓ x (stdF ℓ i) = + stdFormOdd ℓ x (stdF ℓ i) from rfl, stdFormOdd_stdF_right]] + funext j + rw [Finset.sum_apply] + rw [Finset.sum_eq_single (oddPartner ℓ j)] + · unfold stdG stdF + rw [oddPartner_invol, Pi.smul_apply, Pi.smul_apply, + Pi.single_eq_same, oddPartnerSign_oddPartner] + push_cast + rw [smul_eq_mul, smul_eq_mul, mul_one] + rw [show -(oddPartnerSign ℓ j : ℂ) * x j * + -(oddPartnerSign ℓ j : ℂ) = + ((oddPartnerSign ℓ j * oddPartnerSign ℓ j : ℤ) : ℂ) * x j from by + push_cast; ring, oddPartnerSign_mul_self, Int.cast_one, one_mul] + · intro i _ hi + unfold stdG stdF + rw [Pi.smul_apply, Pi.smul_apply, + Pi.single_eq_of_ne (fun hh : j = oddPartner ℓ i => + hi (by rw [hh, oddPartner_invol])), + smul_zero, smul_zero] + · intro hmem + exact absurd (Finset.mem_univ _) hmem + +/-! ### The standard form's blocks -/ + +/-- The standard form's even block is the standard even form. -/ +theorem formEvenBlock_stdForm (k ℓ : ℕ) (x y : Fin k → ℂ) : + formEvenBlock (stdForm k ℓ) x y = stdFormEven k x y := by + change LinearMap.coprod (TensorProduct.lift (stdFormEvenBilin k)) + (TensorProduct.lift (stdFormOddBilin ℓ)) (x ⊗ₜ[ℂ] y, 0) = + stdFormEven k x y + rw [LinearMap.coprod_apply, map_zero, add_zero, + TensorProduct.lift.tmul] + rfl + +/-- And its odd block the standard odd form. -/ +theorem formOddBlock_stdForm (k ℓ : ℕ) (x y : Fin (2 * ℓ) → ℂ) : + formOddBlock (stdForm k ℓ) x y = stdFormOdd ℓ x y := by + change LinearMap.coprod (TensorProduct.lift (stdFormEvenBilin k)) + (TensorProduct.lift (stdFormOddBilin ℓ)) (0, x ⊗ₜ[ℂ] y) = + stdFormOdd ℓ x y + rw [LinearMap.coprod_apply, map_zero, zero_add, + TensorProduct.lift.tmul] + rfl + +/-! ### Uniqueness -/ + +private theorem eq_of_contraction_family {M : Type*} [AddCommGroup M] [Module ℂ M] + [FiniteDimensional ℂ M] (B : BilinForm ℂ M) (hB : B.Nondegenerate) + (t t₀ : M ⊗[ℂ] M) (S : Finset (M × M)) + (hS : t = ∑ i ∈ S, i.1 ⊗ₜ[ℂ] i.2) + (hI : ∀ x, ∑ i ∈ S, B x i.1 • i.2 = x) + (h₀ : ∀ x, contractionMap B t₀ x = x) : t = t₀ := by + apply contractionMap_injective B hB + ext x + rw [hS, map_sum, LinearMap.sum_apply] + simp only [contractionMap_tmul] + exact (hI x).trans (h₀ x).symm + +open MonoidalCategory in +/-- **Uniqueness of the copairing** (accompanying paper §5.2): any +copairing satisfying the snake identities against the standard +form is the standard copairing. -/ +theorem stdCopair_unique (k ℓ : ℕ) + (C' : SuperVect.Hom SuperVect.tensorUnit + (SuperVect.tensorObj (stdSuperPair k ℓ) (stdSuperPair k ℓ))) + (h1 : stdSuperPair k ℓ ◁ + (show 𝟙_ SuperVect ⟶ stdSuperPair k ℓ ⊗ stdSuperPair k ℓ from C') ≫ + (α_ (stdSuperPair k ℓ) (stdSuperPair k ℓ) (stdSuperPair k ℓ)).inv ≫ + (show stdSuperPair k ℓ ⊗ stdSuperPair k ℓ ⟶ 𝟙_ SuperVect from + stdForm k ℓ) ▷ stdSuperPair k ℓ = + (ρ_ (stdSuperPair k ℓ)).hom ≫ (λ_ (stdSuperPair k ℓ)).inv) + (h2 : (show 𝟙_ SuperVect ⟶ stdSuperPair k ℓ ⊗ stdSuperPair k ℓ from C') ▷ + stdSuperPair k ℓ ≫ + (α_ (stdSuperPair k ℓ) (stdSuperPair k ℓ) (stdSuperPair k ℓ)).hom ≫ + stdSuperPair k ℓ ◁ + (show stdSuperPair k ℓ ⊗ stdSuperPair k ℓ ⟶ 𝟙_ SuperVect from + stdForm k ℓ) = + (λ_ (stdSuperPair k ℓ)).hom ≫ (ρ_ (stdSuperPair k ℓ)).inv) : + C' = stdCopair k ℓ := by + obtain ⟨S, T, hS, hT, hi, _, hiii, _⟩ := + exists_contraction_families (stdForm k ℓ) C' h1 h2 + have he : ((formCoevMap C') 1).1 = stdCopairEvenElem k := by + apply eq_of_contraction_family (stdFormEvenBilin k) + (stdFormEvenBilin_nondegenerate k) _ _ S hS + · intro x + refine Eq.trans ?_ (hi x) + apply Finset.sum_congr rfl + intro i _ + exact congrArg (· • i.2) (formEvenBlock_stdForm k ℓ x i.1).symm + · exact contractionMap_stdCopairEvenElem k + have ho : ((formCoevMap C') 1).2 = stdCopairOddElem ℓ := by + apply eq_of_contraction_family (stdFormOddBilin ℓ) + (stdFormOddBilin_nondegenerate ℓ) _ _ T hT + · intro x + refine Eq.trans ?_ (hiii x) + apply Finset.sum_congr rfl + intro i _ + exact congrArg (· • i.2) (formOddBlock_stdForm k ℓ x i.1).symm + · exact contractionMap_stdCopairOddElem ℓ + apply SuperVect.Hom.ext + · have hval : formCoevMap C' = formCoevMap (stdCopair k ℓ) := by + apply LinearMap.ext_ring + refine Prod.ext ?_ ?_ + · exact he.trans (one_smul ℂ (stdCopairEvenElem k)).symm + · exact ho.trans (one_smul ℂ (stdCopairOddElem ℓ)).symm + exact hval + · exact LinearMap.ext fun z => by + rw [show z = 0 from Subsingleton.elim z 0, map_zero, map_zero] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/Nondegenerate.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/Nondegenerate.lean new file mode 100644 index 0000000000..fec8fc42f9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/Nondegenerate.lean @@ -0,0 +1,313 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.Coordinates + +/-! +# Nondegeneracy from the snake identities + +A form `b : V ⊗ V ⟶ 𝟙` admitting a copairing `C : 𝟙 ⟶ V ⊗ V` +with the two snake identities has nondegenerate blocks — the +hypothesis shape produced by rigidity, and the hypothesis shape +consumed by `exists_coordinates`. + +The route: writing the copairing's even element as a pair of +finite sums of pure tensors (`TensorProduct.exists_finset`), the +two snake identities evaluated on generators become four +*contraction identities* (`exists_contraction_families`): + +* `∀ x, Σ_{(m,n)} b(x, m) • n = x` and + `∀ x, Σ_{(m,n)} b(n, x) • m = x` on the even block, +* the same two identities on the odd block. + +Each identity forces the corresponding separation property, so +the even block separates on the left and the odd block is +nondegenerate (`blocks_nondegenerate_of_snake`), and the graded +coordinate identification follows unconditionally +(`exists_coordinates_of_snake`). +-/ + +@[expose] public section + +noncomputable section + +namespace RS + +open CategoryTheory +open scoped TensorProduct +open LinearMap (BilinForm) + +/-! ### Reduced views of the remaining morphism components -/ + +/-- The odd component of a form morphism, with its domain and +codomain presented in reduced form. -/ +def formOddMap {V : SuperVect} + (b : SuperVect.Hom (SuperVect.tensorObj V V) SuperVect.tensorUnit) : + ((V.even ⊗[ℂ] V.odd) × (V.odd ⊗[ℂ] V.even)) →ₗ[ℂ] PUnit := + b.oddMap + +/-- The even component of a copairing morphism `𝟙 ⟶ V ⊗ V`, with +its domain and codomain presented in reduced form. -/ +def formCoevMap {V : SuperVect} + (C : SuperVect.Hom SuperVect.tensorUnit (SuperVect.tensorObj V V)) : + ℂ →ₗ[ℂ] ((V.even ⊗[ℂ] V.even) × (V.odd ⊗[ℂ] V.odd)) := + C.evenMap + +/-- The odd component of a copairing morphism, with its domain and +codomain presented in reduced form. -/ +def formCoevOddMap {V : SuperVect} + (C : SuperVect.Hom SuperVect.tensorUnit (SuperVect.tensorObj V V)) : + PUnit →ₗ[ℂ] ((V.even ⊗[ℂ] V.odd) × (V.odd ⊗[ℂ] V.even)) := + C.oddMap + +/-! ### The contraction identities + +The sum-shuffling these proofs run on -- pushing a finite sum +through a bound map, splitting it across the summands of a +product -- is `Common/ProdSum.lean`; the maps there are bound so +that instance search never meets a metavariable. -/ + +open MonoidalCategory in +/-- **Contraction families from the snake identities** +(accompanying paper §5.2): the even copairing element decomposes as +finite +sums of pure tensors over each graded block, and the two snake +identities become the four contraction identities relating those +families to the blocks of the form. -/ +theorem exists_contraction_families {V : SuperVect} + (b : SuperVect.Hom (SuperVect.tensorObj V V) SuperVect.tensorUnit) + (C : SuperVect.Hom SuperVect.tensorUnit (SuperVect.tensorObj V V)) + (h1 : V ◁ (show 𝟙_ SuperVect ⟶ V ⊗ V from C) ≫ + (α_ V V V).inv ≫ + (show V ⊗ V ⟶ 𝟙_ SuperVect from b) ▷ V = + (ρ_ V).hom ≫ (λ_ V).inv) + (h2 : (show 𝟙_ SuperVect ⟶ V ⊗ V from C) ▷ V ≫ + (α_ V V V).hom ≫ + V ◁ (show V ⊗ V ⟶ 𝟙_ SuperVect from b) = + (λ_ V).hom ≫ (ρ_ V).inv) : + ∃ (S : Finset (V.even × V.even)) (T : Finset (V.odd × V.odd)), + ((formCoevMap C) 1).1 = (∑ i ∈ S, i.1 ⊗ₜ[ℂ] i.2) ∧ + ((formCoevMap C) 1).2 = (∑ i ∈ T, i.1 ⊗ₜ[ℂ] i.2) ∧ + (∀ x, ∑ i ∈ S, formEvenBlock b x i.1 • i.2 = x) ∧ + (∀ x, ∑ i ∈ S, formEvenBlock b i.2 x • i.1 = x) ∧ + (∀ x, ∑ i ∈ T, formOddBlock b x i.1 • i.2 = x) ∧ + (∀ x, ∑ i ∈ T, formOddBlock b i.2 x • i.1 = x) := by + obtain ⟨S, hS⟩ := TensorProduct.exists_finset ((formCoevMap C) 1).1 + obtain ⟨T, hT⟩ := TensorProduct.exists_finset ((formCoevMap C) 1).2 + have htC : formCoevMap C 1 = + (∑ i ∈ S, i.1 ⊗ₜ[ℂ] i.2, ∑ i ∈ T, i.1 ⊗ₜ[ℂ] i.2) := by + rw [← hS, ← hT] + -- ═══════ THE FOUR CONTRACTION IDENTITIES ═══════ + -- Each snake identity, evaluated on a generator of one graded + -- block, gives one of the four. + refine ⟨S, T, hS, hT, fun x => ?_, fun x => ?_, fun x => ?_, fun x => ?_⟩ + · -- (i) even, from h1: Σ b(x, m) • n = x + have h := congrArg SuperVect.Hom.evenMap h1 + have hx := LinearMap.congr_fun h + ((x ⊗ₜ[ℂ] (1 : ℂ), 0) : (V.even ⊗[ℂ] ℂ) × (V.odd ⊗[ℂ] PUnit.{1})) + have hx' : + (LinearMap.prodMap + (TensorProduct.map (formEvenMap b) LinearMap.id) + (TensorProduct.map (formOddMap b) LinearMap.id)) + ((SuperVect.assocAux V.even V.odd V.even V.odd + V.even V.odd).symm + ((LinearMap.prodMap + (TensorProduct.map LinearMap.id (formCoevMap C)) + (TensorProduct.map LinearMap.id (formCoevOddMap C))) + ((x ⊗ₜ[ℂ] (1 : ℂ), 0) : + (V.even ⊗[ℂ] ℂ) × (V.odd ⊗[ℂ] PUnit.{1})))) = + (LinearMap.inl ℂ (ℂ ⊗[ℂ] V.even) (PUnit.{1} ⊗[ℂ] V.odd)) + ((TensorProduct.lid ℂ V.even).symm + ((TensorProduct.rid ℂ V.even) + ((LinearMap.fst ℂ (V.even ⊗[ℂ] ℂ) (V.odd ⊗[ℂ] PUnit.{1})) + (x ⊗ₜ[ℂ] (1 : ℂ), 0)))) := hx + simp only [LinearMap.prodMap_apply, TensorProduct.map_tmul, + LinearMap.id_apply, lmap_zero, LinearMap.fst_apply, + TensorProduct.rid_tmul, one_smul, TensorProduct.lid_symm_apply, + LinearMap.inl_apply] at hx' + rw [htC, mk_sum_split, TensorProduct.tmul_add, + TensorProduct.tmul_sum, TensorProduct.tmul_sum, + mk_add_left, mk_sum_left, mk_sum_left] at hx' + simp only [equiv_add, equiv_sum, SuperVect.assocAux_symm_ee, + SuperVect.assocAux_symm_eo] at hx' + have h1st := congrArg Prod.fst hx' + simp only [Prod.fst_add, Prod.fst_sum, Finset.sum_const_zero, + add_zero, lmap_sum, TensorProduct.map_tmul, + LinearMap.id_apply] at h1st + have hfin := congrArg (TensorProduct.lid ℂ V.even) h1st + simp only [equiv_sum, TensorProduct.lid_tmul, one_smul] at hfin + exact hfin + · -- (ii) even, from h2: Σ b(n, x) • m = x + have h := congrArg SuperVect.Hom.evenMap h2 + have hx := LinearMap.congr_fun h + (((1 : ℂ) ⊗ₜ[ℂ] x, 0) : (ℂ ⊗[ℂ] V.even) × (PUnit.{1} ⊗[ℂ] V.odd)) + have hx' : + (LinearMap.prodMap + (TensorProduct.map LinearMap.id (formEvenMap b)) + (TensorProduct.map LinearMap.id (formOddMap b))) + ((SuperVect.assocAux V.even V.odd V.even V.odd + V.even V.odd) + ((LinearMap.prodMap + (TensorProduct.map (formCoevMap C) LinearMap.id) + (TensorProduct.map (formCoevOddMap C) LinearMap.id)) + (((1 : ℂ) ⊗ₜ[ℂ] x, 0) : + (ℂ ⊗[ℂ] V.even) × (PUnit.{1} ⊗[ℂ] V.odd)))) = + (LinearMap.inl ℂ (V.even ⊗[ℂ] ℂ) (V.odd ⊗[ℂ] PUnit.{1})) + ((TensorProduct.rid ℂ V.even).symm + ((TensorProduct.lid ℂ V.even) + ((LinearMap.fst ℂ (ℂ ⊗[ℂ] V.even) (PUnit.{1} ⊗[ℂ] V.odd)) + ((1 : ℂ) ⊗ₜ[ℂ] x, 0)))) := hx + simp only [LinearMap.prodMap_apply, TensorProduct.map_tmul, + LinearMap.id_apply, lmap_zero, LinearMap.fst_apply, + TensorProduct.lid_tmul, one_smul, TensorProduct.rid_symm_apply, + LinearMap.inl_apply] at hx' + rw [htC, mk_sum_split, TensorProduct.add_tmul, + TensorProduct.sum_tmul, TensorProduct.sum_tmul, + mk_add_left, mk_sum_left, mk_sum_left] at hx' + simp only [equiv_add, equiv_sum, SuperVect.assocAux_ee, + SuperVect.assocAux_oo] at hx' + have h1st := congrArg Prod.fst hx' + simp only [Prod.fst_add, Prod.fst_sum, Finset.sum_const_zero, + add_zero, lmap_sum, TensorProduct.map_tmul, + LinearMap.id_apply] at h1st + have hfin := congrArg (TensorProduct.rid ℂ V.even) h1st + simp only [equiv_sum, TensorProduct.rid_tmul, one_smul] at hfin + exact hfin + · -- (iii) odd, from h1: Σ b(x, p) • q = x + have h := congrArg SuperVect.Hom.oddMap h1 + have hx := LinearMap.congr_fun h + ((0, x ⊗ₜ[ℂ] (1 : ℂ)) : (V.even ⊗[ℂ] PUnit.{1}) × (V.odd ⊗[ℂ] ℂ)) + have hx' : + (LinearMap.prodMap + (TensorProduct.map (formEvenMap b) LinearMap.id) + (TensorProduct.map (formOddMap b) LinearMap.id)) + ((SuperVect.assocAux V.even V.odd V.even V.odd + V.odd V.even).symm + ((LinearMap.prodMap + (TensorProduct.map LinearMap.id (formCoevOddMap C)) + (TensorProduct.map LinearMap.id (formCoevMap C))) + ((0, x ⊗ₜ[ℂ] (1 : ℂ)) : + (V.even ⊗[ℂ] PUnit.{1}) × (V.odd ⊗[ℂ] ℂ)))) = + (LinearMap.inl ℂ (ℂ ⊗[ℂ] V.odd) (PUnit.{1} ⊗[ℂ] V.even)) + ((TensorProduct.lid ℂ V.odd).symm + ((TensorProduct.rid ℂ V.odd) + ((LinearMap.snd ℂ (V.even ⊗[ℂ] PUnit.{1}) (V.odd ⊗[ℂ] ℂ)) + (0, x ⊗ₜ[ℂ] (1 : ℂ))))) := hx + simp only [LinearMap.prodMap_apply, TensorProduct.map_tmul, + LinearMap.id_apply, lmap_zero, LinearMap.snd_apply, + TensorProduct.rid_tmul, one_smul, TensorProduct.lid_symm_apply, + LinearMap.inl_apply] at hx' + rw [htC, mk_sum_split, TensorProduct.tmul_add, + TensorProduct.tmul_sum, TensorProduct.tmul_sum, + mk_add_right, mk_sum_right, mk_sum_right] at hx' + simp only [equiv_add, equiv_sum, SuperVect.assocAux_symm_oe, + SuperVect.assocAux_symm_oo] at hx' + have h1st := congrArg Prod.fst hx' + simp only [Prod.fst_add, Prod.fst_sum, Finset.sum_const_zero, + zero_add, lmap_sum, TensorProduct.map_tmul, + LinearMap.id_apply] at h1st + have hfin := congrArg (TensorProduct.lid ℂ V.odd) h1st + simp only [equiv_sum, TensorProduct.lid_tmul, one_smul] at hfin + exact hfin + · -- (iv) odd, from h2: Σ b(q, x) • p = x + have h := congrArg SuperVect.Hom.oddMap h2 + have hx := LinearMap.congr_fun h + (((1 : ℂ) ⊗ₜ[ℂ] x, 0) : (ℂ ⊗[ℂ] V.odd) × (PUnit.{1} ⊗[ℂ] V.even)) + have hx' : + (LinearMap.prodMap + (TensorProduct.map LinearMap.id (formOddMap b)) + (TensorProduct.map LinearMap.id (formEvenMap b))) + ((SuperVect.assocAux V.even V.odd V.even V.odd + V.odd V.even) + ((LinearMap.prodMap + (TensorProduct.map (formCoevMap C) LinearMap.id) + (TensorProduct.map (formCoevOddMap C) LinearMap.id)) + (((1 : ℂ) ⊗ₜ[ℂ] x, 0) : + (ℂ ⊗[ℂ] V.odd) × (PUnit.{1} ⊗[ℂ] V.even)))) = + (LinearMap.inr ℂ (V.even ⊗[ℂ] PUnit.{1}) (V.odd ⊗[ℂ] ℂ)) + ((TensorProduct.rid ℂ V.odd).symm + ((TensorProduct.lid ℂ V.odd) + ((LinearMap.fst ℂ (ℂ ⊗[ℂ] V.odd) (PUnit.{1} ⊗[ℂ] V.even)) + ((1 : ℂ) ⊗ₜ[ℂ] x, 0)))) := hx + simp only [LinearMap.prodMap_apply, TensorProduct.map_tmul, + LinearMap.id_apply, lmap_zero, LinearMap.fst_apply, + TensorProduct.lid_tmul, one_smul, TensorProduct.rid_symm_apply, + LinearMap.inr_apply] at hx' + rw [htC, mk_sum_split, TensorProduct.add_tmul, + TensorProduct.sum_tmul, TensorProduct.sum_tmul, + mk_add_left, mk_sum_left, mk_sum_left] at hx' + simp only [equiv_add, equiv_sum, SuperVect.assocAux_ee, + SuperVect.assocAux_oo] at hx' + have h2nd := congrArg Prod.snd hx' + simp only [Prod.snd_add, Prod.snd_sum, Finset.sum_const_zero, + zero_add, lmap_sum, TensorProduct.map_tmul, + LinearMap.id_apply] at h2nd + have hfin := congrArg (TensorProduct.rid ℂ V.odd) h2nd + simp only [equiv_sum, TensorProduct.rid_tmul, one_smul] at hfin + exact hfin + +/-! ### Nondegeneracy of the blocks -/ + +open MonoidalCategory in +/-- **Nondegeneracy from the snake identities**: the even block +separates on the left and the odd block is nondegenerate — +exactly the hypotheses of `exists_coordinates`. -/ +theorem blocks_nondegenerate_of_snake {V : SuperVect} + (b : SuperVect.Hom (SuperVect.tensorObj V V) SuperVect.tensorUnit) + (C : SuperVect.Hom SuperVect.tensorUnit (SuperVect.tensorObj V V)) + (h1 : V ◁ (show 𝟙_ SuperVect ⟶ V ⊗ V from C) ≫ + (α_ V V V).inv ≫ + (show V ⊗ V ⟶ 𝟙_ SuperVect from b) ▷ V = + (ρ_ V).hom ≫ (λ_ V).inv) + (h2 : (show 𝟙_ SuperVect ⟶ V ⊗ V from C) ▷ V ≫ + (α_ V V V).hom ≫ + V ◁ (show V ⊗ V ⟶ 𝟙_ SuperVect from b) = + (λ_ V).hom ≫ (ρ_ V).inv) : + (∀ x, (∀ y, formEvenBlock b x y = 0) → x = 0) ∧ + (formOddBlock b).Nondegenerate := by + obtain ⟨S, T, _, _, hi, _, hiii, hiv⟩ := + exists_contraction_families b C h1 h2 + refine ⟨fun x hx => ?_, fun x hx => ?_, fun x hx => ?_⟩ + · have h := hi x + rw [Finset.sum_eq_zero (fun i _ => by rw [hx i.1, zero_smul])] at h + exact h.symm + · have h := hiii x + rw [Finset.sum_eq_zero (fun i _ => by rw [hx i.1, zero_smul])] at h + exact h.symm + · have h := hiv x + rw [Finset.sum_eq_zero (fun i _ => by rw [hx i.2, zero_smul])] at h + exact h.symm + +/-! ### The unconditional coordinate identification -/ + +open MonoidalCategory in +/-- **Standard coordinates from rigidity** (accompanying paper §5.1): a +super +vector space with a supersymmetric form admitting a copairing +with the snake identities carries graded coordinates taking the +form's blocks to the standard forms. -/ +theorem exists_coordinates_of_snake {V : SuperVect} + (b : SuperVect.Hom (SuperVect.tensorObj V V) SuperVect.tensorUnit) + (C : SuperVect.Hom SuperVect.tensorUnit (SuperVect.tensorObj V V)) + (hb : SuperVect.Hom.comp b (SuperVect.koszulBraiding V V) = b) + (h1 : V ◁ (show 𝟙_ SuperVect ⟶ V ⊗ V from C) ≫ + (α_ V V V).inv ≫ + (show V ⊗ V ⟶ 𝟙_ SuperVect from b) ▷ V = + (ρ_ V).hom ≫ (λ_ V).inv) + (h2 : (show 𝟙_ SuperVect ⟶ V ⊗ V from C) ▷ V ≫ + (α_ V V V).hom ≫ + V ◁ (show V ⊗ V ⟶ 𝟙_ SuperVect from b) = + (λ_ V).hom ≫ (ρ_ V).inv) : + ∃ (k ℓ : ℕ) (eE : (Fin k → ℂ) ≃ₗ[ℂ] V.even) + (eO : (Fin (2 * ℓ) → ℂ) ≃ₗ[ℂ] V.odd), + (∀ x y, formEvenBlock b (eE x) (eE y) = stdFormEven k x y) ∧ + (∀ x y, formOddBlock b (eO x) (eO y) = stdFormOdd ℓ x y) := by + obtain ⟨hE, hO⟩ := blocks_nondegenerate_of_snake b C h1 h2 + exact exists_coordinates b hb hE hO + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/SnakeTransport.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/SnakeTransport.lean new file mode 100644 index 0000000000..1f0b18eb3e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/SnakeTransport.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.CoordIso +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.CopairUnique + +/-! +# The complete standard model + +Transporting the snake identities along the standard-model +isomorphism, and the resulting complete §5.1–5.2 package: a super +vector space with a supersymmetric form and a rigid copairing is +isomorphic to a standard model by an isomorphism carrying the form +to `stdForm` *and the copairing to `stdCopair`* +(`exists_std_model`). + +The transport itself is delegated to mathlib's +`exactPairingCongr`; its transported evaluation and coevaluation +are identified with the `tensorHom`-conjugated form and copairing +via `tensorHom_def'`, and the transported copairing is then pinned +by `stdCopair_unique`. +-/ + +@[expose] public section + +noncomputable section + +namespace RS + +open CategoryTheory +open MonoidalCategory + +/-- A form and copairing with the snake identities assemble into +an exact pairing. -/ +@[instance_reducible] +def exactPairingOfSnake {V : SuperVect} + (b : SuperVect.Hom (SuperVect.tensorObj V V) SuperVect.tensorUnit) + (C : SuperVect.Hom SuperVect.tensorUnit (SuperVect.tensorObj V V)) + (h1 : V ◁ (show 𝟙_ SuperVect ⟶ V ⊗ V from C) ≫ + (α_ V V V).inv ≫ + (show V ⊗ V ⟶ 𝟙_ SuperVect from b) ▷ V = + (ρ_ V).hom ≫ (λ_ V).inv) + (h2 : (show 𝟙_ SuperVect ⟶ V ⊗ V from C) ▷ V ≫ + (α_ V V V).hom ≫ + V ◁ (show V ⊗ V ⟶ 𝟙_ SuperVect from b) = + (λ_ V).hom ≫ (ρ_ V).inv) : + ExactPairing V V where + coevaluation' := C + evaluation' := b + coevaluation_evaluation' := h1 + evaluation_coevaluation' := h2 + +/-- **The complete standard model** (accompanying paper §5.1–5.2): a +super vector space with a supersymmetric form and a rigid +copairing is isomorphic to a standard model `stdSuperPair k ℓ`, by an +isomorphism carrying the form to the standard form and the +copairing to the standard copairing. -/ +theorem exists_std_model {V : SuperVect} + (b : SuperVect.Hom (SuperVect.tensorObj V V) SuperVect.tensorUnit) + (C : SuperVect.Hom SuperVect.tensorUnit (SuperVect.tensorObj V V)) + (hb : SuperVect.Hom.comp b (SuperVect.koszulBraiding V V) = b) + (h1 : V ◁ (show 𝟙_ SuperVect ⟶ V ⊗ V from C) ≫ + (α_ V V V).inv ≫ + (show V ⊗ V ⟶ 𝟙_ SuperVect from b) ▷ V = + (ρ_ V).hom ≫ (λ_ V).inv) + (h2 : (show 𝟙_ SuperVect ⟶ V ⊗ V from C) ▷ V ≫ + (α_ V V V).hom ≫ + V ◁ (show V ⊗ V ⟶ 𝟙_ SuperVect from b) = + (λ_ V).hom ≫ (ρ_ V).inv) : + ∃ (k ℓ : ℕ) (e : SuperVect.Hom (stdSuperPair k ℓ) V) + (e' : SuperVect.Hom V (stdSuperPair k ℓ)), + SuperVect.Hom.comp e' e = SuperVect.Hom.id (stdSuperPair k ℓ) ∧ + SuperVect.Hom.comp e e' = SuperVect.Hom.id V ∧ + SuperVect.Hom.comp b (SuperVect.tensorHom e e) = stdForm k ℓ ∧ + SuperVect.Hom.comp (SuperVect.tensorHom e' e') C = + stdCopair k ℓ := by + obtain ⟨k, ℓ, e, e', hinv1, hinv2, hform⟩ := + exists_std_iso b C hb h1 h2 + refine ⟨k, ℓ, e, e', hinv1, hinv2, hform, ?_⟩ + let eIso : stdSuperPair k ℓ ≅ V := + ⟨e, e', hinv1, hinv2⟩ + let EPV : ExactPairing V V := exactPairingOfSnake b C h1 h2 + let EP : ExactPairing (stdSuperPair k ℓ) (stdSuperPair k ℓ) := + exactPairingCongr eIso eIso + have hev : (ε_ (stdSuperPair k ℓ) (stdSuperPair k ℓ)) = + (show stdSuperPair k ℓ ⊗ stdSuperPair k ℓ ⟶ 𝟙_ SuperVect from + stdForm k ℓ) := by + change stdSuperPair k ℓ ◁ eIso.hom ≫ + (eIso.hom ▷ V ≫ (show V ⊗ V ⟶ 𝟙_ SuperVect from b)) = _ + rw [← Category.assoc, ← tensorHom_def' eIso.hom eIso.hom] + exact hform + have hcoev : (η_ (stdSuperPair k ℓ) (stdSuperPair k ℓ)) = + (show 𝟙_ SuperVect ⟶ stdSuperPair k ℓ ⊗ stdSuperPair k ℓ from + SuperVect.Hom.comp (SuperVect.tensorHom e' e') C) := by + change ((show 𝟙_ SuperVect ⟶ V ⊗ V from C) ≫ V ◁ eIso.inv) ≫ + eIso.inv ▷ stdSuperPair k ℓ = _ + rw [Category.assoc, ← tensorHom_def' eIso.inv eIso.inv] + rfl + refine stdCopair_unique k ℓ + (SuperVect.Hom.comp (SuperVect.tensorHom e' e') C) ?_ ?_ + · rw [← hev, ← hcoev] + exact EP.coevaluation_evaluation' + · rw [← hev, ← hcoev] + exact EP.evaluation_coevaluation' + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdDuality.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdDuality.lean new file mode 100644 index 0000000000..b0ecf3a02a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdDuality.lean @@ -0,0 +1,110 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.ProdSum +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdSuper + +/-! +# The standard form as a morphism of super vector spaces + +The §5.1 conventions at the categorical level: the orthosymplectic +form on the standard super space is an even morphism +`stdSuperPair ⊗ stdSuperPair ⟶ 𝟙` in SuperVect, and it is supersymmetric — +composing with the Koszul braiding returns the form. The even +block is symmetric; the odd block is antisymmetric, and the Koszul +sign of the braiding on the odd⊗odd summand exactly compensates. +-/ + +@[expose] public section + +namespace RS + +open scoped TensorProduct + +/-- The even form as a bilinear map. -/ +noncomputable def stdFormEvenBilin (k : ℕ) : + (Fin k → ℂ) →ₗ[ℂ] (Fin k → ℂ) →ₗ[ℂ] ℂ := + LinearMap.mk₂ ℂ (stdFormEven k) + (fun x x' y => by + unfold stdFormEven + rw [← Finset.sum_add_distrib] + exact Finset.sum_congr rfl (fun i _ => by + change (x i + x' i) * y i = _ + ring)) + (fun c x y => by + unfold stdFormEven + rw [smul_eq_mul, Finset.mul_sum] + exact Finset.sum_congr rfl (fun i _ => by + change (c * x i) * y i = _ + ring)) + (fun x y y' => by + unfold stdFormEven + rw [← Finset.sum_add_distrib] + exact Finset.sum_congr rfl (fun i _ => by + change x i * (y i + y' i) = _ + ring)) + (fun c x y => by + unfold stdFormEven + rw [smul_eq_mul, Finset.mul_sum] + exact Finset.sum_congr rfl (fun i _ => by + change x i * (c * y i) = _ + ring)) + +/-- The odd form as a bilinear map. -/ +noncomputable def stdFormOddBilin (ℓ : ℕ) : + (Fin (2 * ℓ) → ℂ) →ₗ[ℂ] (Fin (2 * ℓ) → ℂ) →ₗ[ℂ] ℂ := + LinearMap.mk₂ ℂ (stdFormOdd ℓ) + (fun x x' y => by + unfold stdFormOdd + rw [← Finset.sum_add_distrib] + exact Finset.sum_congr rfl (fun i _ => by + change -(oddPartnerSign ℓ i : ℂ) * (x i + x' i) * y (oddPartner ℓ i) = _ + ring)) + (fun c x y => by + unfold stdFormOdd + rw [smul_eq_mul, Finset.mul_sum] + exact Finset.sum_congr rfl (fun i _ => by + change -(oddPartnerSign ℓ i : ℂ) * (c * x i) * y (oddPartner ℓ i) = _ + ring)) + (fun x y y' => by + unfold stdFormOdd + rw [← Finset.sum_add_distrib] + exact Finset.sum_congr rfl (fun i _ => by + change -(oddPartnerSign ℓ i : ℂ) * x i * + (y (oddPartner ℓ i) + y' (oddPartner ℓ i)) = _ + ring)) + (fun c x y => by + unfold stdFormOdd + rw [smul_eq_mul, Finset.mul_sum] + exact Finset.sum_congr rfl (fun i _ => by + change -(oddPartnerSign ℓ i : ℂ) * x i * + (c * y (oddPartner ℓ i)) = _ + ring)) + +/-- The standard form as an even morphism +`stdSuperPair ⊗ stdSuperPair ⟶ 𝟙` of super vector spaces. -/ +noncomputable def stdForm (k ℓ : ℕ) : + SuperVect.Hom + (SuperVect.tensorObj (stdSuperPair k ℓ) (stdSuperPair k ℓ)) + SuperVect.tensorUnit := by + refine ⟨?_, ?_⟩ + · change ((Fin k → ℂ) ⊗[ℂ] (Fin k → ℂ)) × + ((Fin (2 * ℓ) → ℂ) ⊗[ℂ] (Fin (2 * ℓ) → ℂ)) →ₗ[ℂ] ℂ + exact LinearMap.coprod (TensorProduct.lift (stdFormEvenBilin k)) + (TensorProduct.lift (stdFormOddBilin ℓ)) + · change ((Fin k → ℂ) ⊗[ℂ] (Fin (2 * ℓ) → ℂ)) × + ((Fin (2 * ℓ) → ℂ) ⊗[ℂ] (Fin k → ℂ)) →ₗ[ℂ] PUnit + exact 0 + +/-- The even form is symmetric. -/ +theorem stdFormEven_comm (k : ℕ) (x y : Fin k → ℂ) : + stdFormEven k x y = stdFormEven k y x := by + unfold stdFormEven + exact Finset.sum_congr rfl (fun i _ => mul_comm _ _) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean new file mode 100644 index 0000000000..723669ec5c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean @@ -0,0 +1,303 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdDuality + +/-! +# Self-duality of the standard super space + +The copairing `C = Σ e_i ⊗ e_i + Σ f_i ⊗ g_i` as a morphism +`𝟙 ⟶ stdSuperPair ⊗ stdSuperPair`, and the snake identities pairing it +against the standard form: `stdSuperPair` is exactly self-dual in +SuperVect. This is the categorical form of the §5.2 conventions — +the contraction identities `L_C = id` distributed over the graded +blocks. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory +open scoped TensorProduct + +/-- The even copairing element `Σ e_i ⊗ e_i`. -/ +noncomputable def stdCopairEvenElem (k : ℕ) : + (Fin k → ℂ) ⊗[ℂ] (Fin k → ℂ) := + ∑ i, stdE k i ⊗ₜ[ℂ] stdE k i + +/-- The odd copairing element `Σ f_i ⊗ g_i`. -/ +noncomputable def stdCopairOddElem (ℓ : ℕ) : + (Fin (2 * ℓ) → ℂ) ⊗[ℂ] (Fin (2 * ℓ) → ℂ) := + ∑ i, stdF ℓ i ⊗ₜ[ℂ] stdG ℓ i + +private lemma mk_smul_left {A B : Type*} [AddCommMonoid A] + [AddCommMonoid B] [Module ℂ A] [Module ℂ B] (c : ℂ) (a : A) : + ((c • a, (0 : B)) : A × B) = c • ((a, 0) : A × B) := by + rw [Prod.smul_mk, smul_zero] + +private lemma mk_smul_right {A B : Type*} [AddCommMonoid A] + [AddCommMonoid B] [Module ℂ A] [Module ℂ B] (c : ℂ) (b : B) : + (((0 : A), c • b) : A × B) = c • (((0 : A), b) : A × B) := by + rw [Prod.smul_mk, smul_zero] + +/-- `map_zero` for a bound linear equivalence. -/ +private lemma equiv_zero {M N : Type*} [AddCommMonoid M] [Module ℂ M] + [AddCommMonoid N] [Module ℂ N] (e : M ≃ₗ[ℂ] N) : e 0 = 0 := + map_zero e + +/-- The standard copairing as an even morphism +`𝟙 ⟶ stdSuperPair ⊗ stdSuperPair`. -/ +noncomputable def stdCopair (k ℓ : ℕ) : + SuperVect.Hom SuperVect.tensorUnit + (SuperVect.tensorObj (stdSuperPair k ℓ) (stdSuperPair k ℓ)) := by + refine ⟨?_, ?_⟩ + · change ℂ →ₗ[ℂ] + ((Fin k → ℂ) ⊗[ℂ] (Fin k → ℂ)) × + ((Fin (2 * ℓ) → ℂ) ⊗[ℂ] (Fin (2 * ℓ) → ℂ)) + exact LinearMap.toSpanSingleton ℂ _ + (stdCopairEvenElem k, stdCopairOddElem ℓ) + · change PUnit →ₗ[ℂ] + ((Fin k → ℂ) ⊗[ℂ] (Fin (2 * ℓ) → ℂ)) × + ((Fin (2 * ℓ) → ℂ) ⊗[ℂ] (Fin k → ℂ)) + exact 0 + +-- The snake identities unfold the associator, both unitors and the +-- graded copairing on every block, so the elaborated term is large. +open MonoidalCategory in +/-- The first snake identity for the standard pairing. -/ +private theorem std_coev_ev (k ℓ : ℕ) : + stdSuperPair k ℓ ◁ (show 𝟙_ SuperVect ⟶ stdSuperPair k ℓ ⊗ stdSuperPair k ℓ + from stdCopair k ℓ) ≫ + (α_ (stdSuperPair k ℓ) (stdSuperPair k ℓ) (stdSuperPair k ℓ)).inv ≫ + (show stdSuperPair k ℓ ⊗ stdSuperPair k ℓ ⟶ 𝟙_ SuperVect from + stdForm k ℓ) ▷ + stdSuperPair k ℓ = + (ρ_ (stdSuperPair k ℓ)).hom ≫ (λ_ (stdSuperPair k ℓ)).inv := by + apply SuperVect.Hom.ext + · change + (LinearMap.prodMap + (TensorProduct.map + (LinearMap.coprod (TensorProduct.lift (stdFormEvenBilin k)) + (TensorProduct.lift (stdFormOddBilin ℓ))) + LinearMap.id) + (TensorProduct.map (0 : _ →ₗ[ℂ] PUnit) LinearMap.id) ∘ₗ + (SuperVect.assocAux (Fin k → ℂ) (Fin (2 * ℓ) → ℂ) (Fin k → ℂ) + (Fin (2 * ℓ) → ℂ) (Fin k → ℂ) + (Fin (2 * ℓ) → ℂ)).symm.toLinearMap) ∘ₗ + LinearMap.prodMap + (TensorProduct.map LinearMap.id + (LinearMap.toSpanSingleton ℂ _ + (stdCopairEvenElem k, stdCopairOddElem ℓ))) + (TensorProduct.map LinearMap.id (0 : PUnit →ₗ[ℂ] _)) = + (LinearMap.inl ℂ _ _ ∘ₗ + (TensorProduct.lid ℂ (Fin k → ℂ)).symm.toLinearMap) ∘ₗ + ((TensorProduct.rid ℂ (Fin k → ℂ)).toLinearMap ∘ₗ LinearMap.fst ℂ _ _) + ext x + all_goals simp only [stdFormEvenBilin, stdFormOddBilin, TensorProduct.map_zero_left, + stdCopairEvenElem, stdE, stdCopairOddElem, stdF, stdG, TensorProduct.tmul_smul, + mk_sum_split, mk_smul_right, TensorProduct.map_zero_right, LinearMap.coe_comp, + LinearMap.coe_single, Function.comp_apply, TensorProduct.AlgebraTensorModule.curry_apply, + LinearMap.restrictScalars_self, TensorProduct.curry_apply, LinearEquiv.coe_coe, + LinearMap.coe_inl, LinearMap.prodMap_apply, TensorProduct.map_tmul, LinearMap.id_coe, + id_eq, LinearMap.toSpanSingleton_apply, smul_add, one_smul, TensorProduct.tmul_add, + TensorProduct.tmul_sum, LinearMap.zero_apply, mk_add_left, mk_sum_left, mk_smul_left, + map_add, map_sum, SuperVect.assocAux_symm_ee, map_smul, SuperVect.assocAux_symm_eo, + Prod.fst_sum, smul_zero, Finset.sum_const_zero, add_zero, + LinearMap.coprod_apply, TensorProduct.lift.tmul, LinearMap.mk₂_apply, stdFormEven, + lmap_zero, TensorProduct.sum_tmul, Prod.snd_sum, + LinearMap.coe_fst, TensorProduct.rid_tmul, TensorProduct.lid_symm_apply, LinearMap.coe_inr, + SuperVect.prod_mk_zero, equiv_zero, Prod.fst_zero, Prod.snd_zero, TensorProduct.tmul_zero] + simp only [← TensorProduct.sum_tmul] + have hcollapse : ∀ i : Fin k, + (∑ a, (Pi.single x (1 : ℂ)) a * (Pi.single i (1 : ℂ)) a) = + (if x = i then (1 : ℂ) else 0) := + fun i => stdFormEven_stdE k x i + simp only [hcollapse, TensorProduct.ite_tmul, Finset.sum_ite_eq, + Finset.mem_univ, ite_eq_left] + · change + (LinearMap.prodMap + (TensorProduct.map + (LinearMap.coprod (TensorProduct.lift (stdFormEvenBilin k)) + (TensorProduct.lift (stdFormOddBilin ℓ))) + LinearMap.id) + (TensorProduct.map (0 : _ →ₗ[ℂ] PUnit) LinearMap.id) ∘ₗ + (SuperVect.assocAux (Fin k → ℂ) (Fin (2 * ℓ) → ℂ) (Fin k → ℂ) + (Fin (2 * ℓ) → ℂ) (Fin (2 * ℓ) → ℂ) + (Fin k → ℂ)).symm.toLinearMap) ∘ₗ + LinearMap.prodMap + (TensorProduct.map LinearMap.id (0 : PUnit →ₗ[ℂ] _)) + (TensorProduct.map LinearMap.id + (LinearMap.toSpanSingleton ℂ _ + (stdCopairEvenElem k, stdCopairOddElem ℓ))) = + (LinearMap.inl ℂ _ _ ∘ₗ + (TensorProduct.lid ℂ (Fin (2 * ℓ) → ℂ)).symm.toLinearMap) ∘ₗ + ((TensorProduct.rid ℂ (Fin (2 * ℓ) → ℂ)).toLinearMap ∘ₗ LinearMap.snd ℂ _ + _) + ext x + all_goals simp only [stdFormEvenBilin, stdFormOddBilin, TensorProduct.map_zero_left, + TensorProduct.map_zero_right, stdCopairEvenElem, stdE, stdCopairOddElem, stdF, stdG, + TensorProduct.tmul_smul, mk_sum_split, mk_smul_right, LinearMap.coe_comp, + LinearMap.coe_single, Function.comp_apply, TensorProduct.AlgebraTensorModule.curry_apply, + LinearMap.restrictScalars_self, TensorProduct.curry_apply, LinearEquiv.coe_coe, + LinearMap.coe_inl, LinearMap.prodMap_apply, LinearMap.zero_apply, lmap_zero, + SuperVect.prod_mk_zero, equiv_zero, Prod.fst_zero, Prod.snd_zero, LinearMap.coe_snd, + TensorProduct.lid_symm_apply, TensorProduct.tmul_zero, LinearMap.coe_inr, + TensorProduct.map_tmul, LinearMap.id_coe, id_eq, LinearMap.toSpanSingleton_apply, smul_add, + one_smul, TensorProduct.tmul_add, TensorProduct.tmul_sum, mk_add_right, mk_sum_right, + map_add, map_sum, SuperVect.assocAux_symm_oe, map_smul, SuperVect.assocAux_symm_oo, + Prod.fst_sum, Finset.sum_const_zero, Prod.smul_fst, zero_add, + LinearMap.coprod_apply, TensorProduct.lift.tmul, LinearMap.mk₂_apply, stdFormOdd, neg_mul, + Finset.sum_neg_distrib, Prod.snd_sum, Prod.smul_snd, smul_zero, + TensorProduct.rid_tmul] + have hinner : ∀ m : Fin (2 * ℓ), + (-∑ n, (oddPartnerSign ℓ n : ℂ) * + (Pi.single x (1 : ℂ) : Fin (2 * ℓ) → ℂ) n * + (Pi.single m (1 : ℂ) : Fin (2 * ℓ) → ℂ) (oddPartner ℓ n)) = + stdFormOdd ℓ (stdF ℓ x) (stdF ℓ m) := by + intro m + unfold stdFormOdd stdF + rw [← Finset.sum_neg_distrib] + exact Finset.sum_congr rfl (fun n _ => by ring) + simp only [hinner, stdFormOdd_stdF] + rw [Finset.sum_eq_single (oddPartner ℓ x)] + · rw [ite_eq_left rfl, oddPartner_invol, oddPartnerSign_oddPartner, + TensorProduct.smul_tmul', smul_eq_mul] + push_cast + rw [show (-(oddPartnerSign ℓ x : ℂ)) * -(oddPartnerSign ℓ x : ℂ) = + ((oddPartnerSign ℓ x * oddPartnerSign ℓ x : ℤ) : ℂ) from by + push_cast; ring, oddPartnerSign_mul_self, Int.cast_one] + · intro m _ hm + rw [ite_eq_right (fun hh : m = oddPartner ℓ x => hm hh), + TensorProduct.zero_tmul, smul_zero] + · intro hmem + exact absurd (Finset.mem_univ _) hmem + +-- As for the first identity: the whole graded associator and both +-- unitors are unfolded on each block. +open MonoidalCategory in +/-- The second snake identity for the standard pairing. -/ +private theorem std_ev_coev (k ℓ : ℕ) : + (show 𝟙_ SuperVect ⟶ stdSuperPair k ℓ ⊗ stdSuperPair k ℓ from + stdCopair k ℓ) ▷ + stdSuperPair k ℓ ≫ + (α_ (stdSuperPair k ℓ) (stdSuperPair k ℓ) (stdSuperPair k ℓ)).hom ≫ + stdSuperPair k ℓ ◁ + (show stdSuperPair k ℓ ⊗ stdSuperPair k ℓ ⟶ 𝟙_ SuperVect + from stdForm k ℓ) = + (λ_ (stdSuperPair k ℓ)).hom ≫ (ρ_ (stdSuperPair k ℓ)).inv := by + apply SuperVect.Hom.ext + · change + (LinearMap.prodMap + (TensorProduct.map LinearMap.id + (LinearMap.coprod (TensorProduct.lift (stdFormEvenBilin k)) + (TensorProduct.lift (stdFormOddBilin ℓ)))) + (TensorProduct.map LinearMap.id (0 : _ →ₗ[ℂ] PUnit)) ∘ₗ + (SuperVect.assocAux (Fin k → ℂ) (Fin (2 * ℓ) → ℂ) (Fin k → ℂ) + (Fin (2 * ℓ) → ℂ) (Fin k → ℂ) + (Fin (2 * ℓ) → ℂ)).toLinearMap) ∘ₗ + LinearMap.prodMap + (TensorProduct.map + (LinearMap.toSpanSingleton ℂ _ + (stdCopairEvenElem k, stdCopairOddElem ℓ)) + LinearMap.id) + (TensorProduct.map (0 : PUnit →ₗ[ℂ] _) LinearMap.id) = + (LinearMap.inl ℂ _ _ ∘ₗ + (TensorProduct.rid ℂ (Fin k → ℂ)).symm.toLinearMap) ∘ₗ + ((TensorProduct.lid ℂ (Fin k → ℂ)).toLinearMap ∘ₗ LinearMap.fst ℂ _ _) + ext x + all_goals simp only [stdFormEvenBilin, stdFormOddBilin, TensorProduct.map_zero_right, + stdCopairEvenElem, stdE, stdCopairOddElem, stdF, stdG, TensorProduct.tmul_smul, + mk_sum_split, mk_smul_right, TensorProduct.map_zero_left, + TensorProduct.AlgebraTensorModule.curry_apply, LinearMap.restrictScalars_self, + LinearMap.coe_comp, LinearMap.coe_single, Function.comp_apply, TensorProduct.curry_apply, + LinearEquiv.coe_coe, LinearMap.coe_inl, LinearMap.prodMap_apply, TensorProduct.map_tmul, + LinearMap.toSpanSingleton_apply, smul_add, one_smul, LinearMap.id_coe, id_eq, + TensorProduct.add_tmul, TensorProduct.sum_tmul, TensorProduct.smul_tmul, + LinearMap.zero_apply, mk_add_left, mk_sum_left, mk_smul_left, map_add, map_sum, + SuperVect.assocAux_ee, map_smul, SuperVect.assocAux_oo, Prod.fst_sum, + smul_zero, Finset.sum_const_zero, add_zero, LinearMap.coprod_apply, + TensorProduct.lift.tmul, LinearMap.mk₂_apply, stdFormEven, lmap_zero, + TensorProduct.tmul_sum, Prod.snd_sum, + LinearMap.coe_fst, TensorProduct.lid_tmul, TensorProduct.rid_symm_apply, LinearMap.coe_inr, + SuperVect.prod_mk_zero, equiv_zero, Prod.fst_zero, Prod.snd_zero, TensorProduct.zero_tmul] + simp only [← TensorProduct.tmul_sum] + have hcollapse : ∀ i : Fin k, + (∑ a, (Pi.single i (1 : ℂ)) a * (Pi.single x (1 : ℂ)) a) = + (if i = x then (1 : ℂ) else 0) := + fun i => stdFormEven_stdE k i x + simp only [hcollapse, TensorProduct.tmul_ite, Finset.sum_ite_eq', + Finset.mem_univ, ite_eq_left] + · change + (LinearMap.prodMap + (TensorProduct.map LinearMap.id (0 : _ →ₗ[ℂ] PUnit)) + (TensorProduct.map LinearMap.id + (LinearMap.coprod (TensorProduct.lift (stdFormEvenBilin k)) + (TensorProduct.lift (stdFormOddBilin ℓ)))) ∘ₗ + (SuperVect.assocAux (Fin k → ℂ) (Fin (2 * ℓ) → ℂ) (Fin k → ℂ) + (Fin (2 * ℓ) → ℂ) (Fin (2 * ℓ) → ℂ) + (Fin k → ℂ)).toLinearMap) ∘ₗ + LinearMap.prodMap + (TensorProduct.map + (LinearMap.toSpanSingleton ℂ _ + (stdCopairEvenElem k, stdCopairOddElem ℓ)) + LinearMap.id) + (TensorProduct.map (0 : PUnit →ₗ[ℂ] _) LinearMap.id) = + (LinearMap.inr ℂ _ _ ∘ₗ + (TensorProduct.rid ℂ (Fin (2 * ℓ) → ℂ)).symm.toLinearMap) ∘ₗ + ((TensorProduct.lid ℂ (Fin (2 * ℓ) → ℂ)).toLinearMap ∘ₗ LinearMap.fst ℂ _ + _) + ext x + all_goals simp only [TensorProduct.map_zero_right, stdFormEvenBilin, stdFormOddBilin, + stdCopairEvenElem, stdE, stdCopairOddElem, stdF, stdG, TensorProduct.tmul_smul, + mk_sum_split, mk_smul_right, TensorProduct.map_zero_left, + TensorProduct.AlgebraTensorModule.curry_apply, LinearMap.restrictScalars_self, + LinearMap.coe_comp, LinearMap.coe_single, Function.comp_apply, TensorProduct.curry_apply, + LinearEquiv.coe_coe, LinearMap.coe_inl, LinearMap.prodMap_apply, TensorProduct.map_tmul, + LinearMap.toSpanSingleton_apply, smul_add, one_smul, LinearMap.id_coe, id_eq, + TensorProduct.add_tmul, TensorProduct.sum_tmul, TensorProduct.smul_tmul, + LinearMap.zero_apply, mk_add_left, mk_sum_left, mk_smul_left, map_add, map_sum, + SuperVect.assocAux_ee, map_smul, SuperVect.assocAux_oo, Prod.fst_sum, + Prod.smul_fst, smul_zero, Finset.sum_const_zero, Prod.snd_sum, + Prod.smul_snd, zero_add, LinearMap.coprod_apply, lmap_zero, TensorProduct.lift.tmul, + LinearMap.mk₂_apply, stdFormOdd, neg_mul, Finset.sum_neg_distrib, + LinearMap.coe_inr, LinearMap.coe_fst, TensorProduct.lid_tmul, TensorProduct.rid_symm_apply, + SuperVect.prod_mk_zero, equiv_zero, Prod.fst_zero, Prod.snd_zero, TensorProduct.zero_tmul] + have hinner : ∀ m : Fin (2 * ℓ), + (-∑ n, (oddPartnerSign ℓ n : ℂ) * + (Pi.single (oddPartner ℓ m) (1 : ℂ) : Fin (2 * ℓ) → ℂ) n * + (Pi.single x (1 : ℂ) : Fin (2 * ℓ) → ℂ) (oddPartner ℓ n)) = + stdFormOdd ℓ (stdF ℓ (oddPartner ℓ m)) (stdF ℓ x) := by + intro m + unfold stdFormOdd stdF + rw [← Finset.sum_neg_distrib] + exact Finset.sum_congr rfl (fun n _ => by ring) + simp only [hinner, stdFormOdd_stdF, oddPartner_invol, + oddPartnerSign_oddPartner, Int.cast_neg, neg_neg] + rw [Finset.sum_eq_single x] + · rw [ite_eq_left rfl, ← TensorProduct.tmul_smul, smul_eq_mul, + show (oddPartnerSign ℓ x : ℂ) * (oddPartnerSign ℓ x : ℂ) = + ((oddPartnerSign ℓ x * oddPartnerSign ℓ x : ℤ) : ℂ) from by + push_cast; ring, + oddPartnerSign_mul_self, Int.cast_one] + · intro m _ hm + rw [ite_eq_right (fun hh : x = m => hm hh.symm), + TensorProduct.tmul_zero, smul_zero] + · intro hmem + exact absurd (Finset.mem_univ _) hmem + +/-- **Self-duality of the standard super space**: the standard form +and copairing are an exact pairing. -/ +noncomputable instance stdExactPairing (k ℓ : ℕ) : + ExactPairing (stdSuperPair k ℓ) (stdSuperPair k ℓ) where + coevaluation' := stdCopair k ℓ + evaluation' := stdForm k ℓ + coevaluation_evaluation' := by exact std_coev_ev k ℓ + evaluation_coevaluation' := by exact std_ev_coev k ℓ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdSuper.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdSuper.lean new file mode 100644 index 0000000000..a8fc4890d7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdSuper.lean @@ -0,0 +1,201 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition + +/-! +# The standard orthosymplectic super vector space + +The concrete model of §5.1 of the accompanying paper: the super +vector space with even part `Fin k → ℂ` and odd part +`Fin (2ℓ) → ℂ`, carrying the pinned Regts–Sevenster form — +orthonormal on the even part, and on the odd part the +antisymmetric form with +`b (f m) (f (m + ℓ)) = 1 = −b (f (m + ℓ)) (f m)`. The dual +vectors `g i` and the partner index calculus reuse `oddPartner` +and `oddPartnerSign` from the Definition 5 machinery, so the two +sides of the Contraction–Expansion Lemma speak the same language. + +The odd basis is named as in Regts–Sevenster, `f i` and `g i`; +the accompanying paper writes `ξ i` and `η i` for the same +vectors, `f` being reserved there for the graph parameter. +-/ + +@[expose] public section + +namespace RS + +open scoped BigOperators + +/-- The standard super vector space with even dimension `k` and +odd dimension `2ℓ`. -/ +noncomputable def stdSuperPair (k ℓ : ℕ) : SuperVect where + even := Fin k → ℂ + odd := Fin (2 * ℓ) → ℂ + +/-- The standard even basis vectors `e i`. -/ +noncomputable def stdE (k : ℕ) (i : Fin k) : Fin k → ℂ := + Pi.single i 1 + +/-- The standard odd basis vectors `f i`. -/ +noncomputable def stdF (ℓ : ℕ) (i : Fin (2 * ℓ)) : Fin (2 * ℓ) → ℂ := + Pi.single i 1 + +/-- The even part of the standard form: the orthonormal pairing. -/ +noncomputable def stdFormEven (k : ℕ) (x y : Fin k → ℂ) : ℂ := + ∑ i, x i * y i + +/-- The odd part of the standard form: the antisymmetric pairing +with `b (f m) (f (m + ℓ)) = 1` for `m ≤ ℓ` and all other basis +values forced by antisymmetry. -/ +noncomputable def stdFormOdd (ℓ : ℕ) (x y : Fin (2 * ℓ) → ℂ) : ℂ := + ∑ i, -(oddPartnerSign ℓ i : ℂ) * x i * y (oddPartner ℓ i) + +/-- The Regts–Sevenster dual odd vectors: `g i = −f (i + ℓ)` for +`i < ℓ` and `g i = f (i − ℓ)` otherwise. -/ +noncomputable def stdG (ℓ : ℕ) (i : Fin (2 * ℓ)) : Fin (2 * ℓ) → ℂ := + (oddPartnerSign ℓ i : ℂ) • stdF ℓ (oddPartner ℓ i) + +/-- The even form is orthonormal on the standard basis. -/ +theorem stdFormEven_stdE (k : ℕ) (i j : Fin k) : + stdFormEven k (stdE k i) (stdE k j) = if i = j then 1 else 0 := by + unfold stdFormEven stdE + rw [Finset.sum_eq_single i] + · by_cases h : i = j + · subst h; simp + · rw [Pi.single_eq_same, one_mul, Pi.single_eq_of_ne h, ite_eq_right h] + · intro m _ hm + rw [Pi.single_eq_of_ne hm, zero_mul] + · intro hmem + exact absurd (Finset.mem_univ i) hmem + +/-- The odd form on the standard basis: `−oddPartnerSign` at the +partner index and zero elsewhere. -/ +theorem stdFormOdd_stdF (ℓ : ℕ) (i j : Fin (2 * ℓ)) : + stdFormOdd ℓ (stdF ℓ i) (stdF ℓ j) = + if j = oddPartner ℓ i then -(oddPartnerSign ℓ i : ℂ) else 0 := by + unfold stdFormOdd stdF + rw [Finset.sum_eq_single i] + · rw [Pi.single_eq_same, mul_one] + by_cases h : j = oddPartner ℓ i + · subst h; rw [Pi.single_eq_same, ite_eq_left rfl, mul_one] + · rw [Pi.single_eq_of_ne (fun hh => h hh.symm), ite_eq_right h, + mul_zero] + · intro m _ hm + rw [Pi.single_eq_of_ne hm, mul_zero, zero_mul] + · intro hmem + exact absurd (Finset.mem_univ i) hmem + +/-- The odd form is antisymmetric. -/ +theorem stdFormOdd_antisymm (ℓ : ℕ) (x y : Fin (2 * ℓ) → ℂ) : + stdFormOdd ℓ x y = -stdFormOdd ℓ y x := by + unfold stdFormOdd + rw [← Finset.sum_neg_distrib] + refine Fintype.sum_equiv + ⟨oddPartner ℓ, oddPartner ℓ, oddPartner_invol ℓ, oddPartner_invol ℓ⟩ + _ _ (fun i => ?_) + change -(oddPartnerSign ℓ i : ℂ) * x i * y (oddPartner ℓ i) = + -(-(oddPartnerSign ℓ (oddPartner ℓ i) : ℂ) * y (oddPartner ℓ i) * + x (oddPartner ℓ (oddPartner ℓ i))) + rw [oddPartner_invol, oddPartnerSign_oddPartner] + push_cast + ring + +/-- The companion pairing identity: `b (f i) (g j) = −δ_{ij}`. -/ +theorem stdFormOdd_stdF_stdG (ℓ : ℕ) (i j : Fin (2 * ℓ)) : + stdFormOdd ℓ (stdF ℓ i) (stdG ℓ j) = if i = j then -1 else 0 := by + unfold stdG stdFormOdd + simp only [Pi.smul_apply, smul_eq_mul] + rw [show (∑ m, -(oddPartnerSign ℓ m : ℂ) * stdF ℓ i m * + ((oddPartnerSign ℓ j : ℂ) * stdF ℓ (oddPartner ℓ j) + (oddPartner ℓ m))) = + (oddPartnerSign ℓ j : ℂ) * + ∑ m, -(oddPartnerSign ℓ m : ℂ) * stdF ℓ i m * + stdF ℓ (oddPartner ℓ j) (oddPartner ℓ m) from by + rw [Finset.mul_sum] + exact Finset.sum_congr rfl (fun m _ => by ring), + show (∑ m, -(oddPartnerSign ℓ m : ℂ) * stdF ℓ i m * + stdF ℓ (oddPartner ℓ j) (oddPartner ℓ m)) = + stdFormOdd ℓ (stdF ℓ i) (stdF ℓ (oddPartner ℓ j)) from rfl, + stdFormOdd_stdF] + by_cases h : i = j + · subst h + rw [ite_eq_left rfl, ite_eq_left rfl, mul_neg, ← Int.cast_mul, + oddPartnerSign_mul_self, Int.cast_one] + · rw [ite_eq_right (fun hh : oddPartner ℓ j = oddPartner ℓ i => + h (by + have := congrArg (oddPartner ℓ) hh + rwa [oddPartner_invol, oddPartner_invol, eq_comm] at this)), + mul_zero, ite_eq_right h] + +/-- The even trace of the copairing: `Σ_i b(e_i, e_i) = k`. -/ +theorem sum_stdFormEven_diag (k : ℕ) : + (∑ i, stdFormEven k (stdE k i) (stdE k i)) = (k : ℂ) := by + rw [Finset.sum_congr rfl + (fun i _ => (stdFormEven_stdE k i i).trans (ite_eq_left rfl))] + simp + +/-- The odd trace of the copairing: `Σ_i b(f_i, g_i) = −2ℓ`; +together with the even part this is `b(C) = k − 2ℓ`, the value of +a free circle. -/ +theorem sum_stdFormOdd_diag (ℓ : ℕ) : + (∑ i, stdFormOdd ℓ (stdF ℓ i) (stdG ℓ i)) = -(2 * ℓ : ℂ) := by + rw [Finset.sum_congr rfl + (fun i _ => (stdFormOdd_stdF_stdG ℓ i i).trans (ite_eq_left rfl))] + simp + +/-- The even form against a basis vector reads off the +coordinate. -/ +theorem stdFormEven_stdE_left (k : ℕ) (j : Fin k) (x : Fin k → ℂ) : + stdFormEven k (stdE k j) x = x j := by + unfold stdFormEven stdE + rw [Finset.sum_eq_single j] + · rw [Pi.single_eq_same, one_mul] + · intro m _ hm + rw [Pi.single_eq_of_ne hm, zero_mul] + · intro hmem + exact absurd (Finset.mem_univ j) hmem + +/-- The odd form against a dual basis vector reads off the +coordinate. -/ +theorem stdFormOdd_stdG_left (ℓ : ℕ) (j : Fin (2 * ℓ)) + (x : Fin (2 * ℓ) → ℂ) : + stdFormOdd ℓ (stdG ℓ j) x = x j := by + unfold stdFormOdd stdG stdF + rw [Finset.sum_eq_single (oddPartner ℓ j)] + · rw [Pi.smul_apply, Pi.single_eq_same, smul_eq_mul, mul_one, + oddPartnerSign_oddPartner, oddPartner_invol] + push_cast + rw [show -(-(oddPartnerSign ℓ j : ℂ)) * (oddPartnerSign ℓ j : ℂ) * + x j = ((oddPartnerSign ℓ j * oddPartnerSign ℓ j : ℤ) : ℂ) * + x j from by push_cast; ring, + oddPartnerSign_mul_self, Int.cast_one, one_mul] + · intro m _ hm + rw [Pi.smul_apply, Pi.single_eq_of_ne (fun hh : m = oddPartner ℓ j => + hm hh), smul_zero, mul_zero, zero_mul] + · intro hmem + exact absurd (Finset.mem_univ (oddPartner ℓ j)) hmem + +/-- **The even contraction identity** (accompanying paper, +§5.2): contracting the even copairing through the form is the identity. -/ +theorem sum_stdFormEven_smul (k : ℕ) (x : Fin k → ℂ) : + (∑ i, stdFormEven k (stdE k i) x • stdE k i) = x := by + funext j + rw [Finset.sum_apply] + rw [Finset.sum_eq_single j] + · rw [Pi.smul_apply, stdFormEven_stdE_left] + unfold stdE + rw [Pi.single_eq_same, smul_eq_mul, mul_one] + · intro m _ hm + rw [Pi.smul_apply, smul_eq_mul] + unfold stdE + rw [Pi.single_eq_of_ne (fun hh : j = m => hm hh.symm), mul_zero] + · intro hmem + exact absurd (Finset.mem_univ j) hmem + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalAgreement.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalAgreement.lean new file mode 100644 index 0000000000..3ed227140d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalAgreement.lean @@ -0,0 +1,360 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalIndependence +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.EulerianIndependence + +/-! +# All-internal agreement: Eulerian independence outright + +A standard `TransitionSystem` on an edge subset forces every +participating flag to be internally attached (`attach_internal`), +so the subset is all-internal even inside an open fragment. This +file generalizes the closed-fragment agreement chain of +`ClosedAgreement.lean` from `Fragment (Fin 0)` to arbitrary +fragments under `allInternal`: through-edges vanish, the core +colouring is the full odd colouring, and the open circuit count is +the standard circuit count. + +The genuinely new ingredient is the boundary state. On an open +fragment the even boundary match is *not* vacuous: it pins the even +colouring at the (non-participating) boundary flags. Instead, each +even colouring `ψ` induces the all-even state `evenState ψ` +recording its boundary values; the even boundary match for +`evenState ψ₀` holds exactly on the fibre +`{ψ | evenState ψ = evenState ψ₀}`, and the mixed summand +decomposes fibrewise into through summands over the finitely many +realized states. Applying the unconditional all-internal +independence (`throughSummand_independence_of_allInternal`) fibre +by fibre proves the Eulerian-independence interface outright. No +state is ever chosen — every state used is manufactured from an +existing even colouring — so no `(k, ℓ) = (0, 0)` edge case arises. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} {W : Fragment α} + +namespace EdgeSubset + +variable {F : EdgeSubset W} + +/-! ## Vacuous through-data on all-internal subsets -/ + +/-- On an all-internal subset, every participating flag attaches to +an internal vertex. -/ +theorem attach_inl_of_allInternal (hall : F.allInternal) {f : W.Flag} + (hf : f ∈ F.flags) : ∃ v : W.Vertex, W.attach f = Sum.inl v := + F.attach_internal_of_mem (mem_internalFlags_of_allInternal hall hf) + +open scoped Classical in +/-- On an all-internal subset, there are no through-flags. -/ +theorem throughFlags_eq_empty_of_allInternal (hall : F.allInternal) : + F.throughFlags = ∅ := by + rw [Finset.eq_empty_iff_forall_notMem] + intro f hf + unfold EdgeSubset.throughFlags at hf + rw [Finset.mem_filter] at hf + obtain ⟨hfl, ⟨i, hi⟩, -⟩ := hf + obtain ⟨v, hv⟩ := attach_inl_of_allInternal hall hfl + rw [hv] at hi + cases hi + +/-- On an all-internal subset, the core flags are the full flags. -/ +theorem coreFlags_eq_flags_of_allInternal (hall : F.allInternal) : + F.coreFlags = F.flags := by + ext f + rw [F.mem_coreFlags_iff] + exact ⟨fun hf => hf.1, fun hf => + ⟨hf, Or.inl (attach_inl_of_allInternal hall hf)⟩⟩ + +/-- On an all-internal subset, the through product is `1`. -/ +theorem throughProduct_one_of_allInternal [LinearOrder α] + (hall : F.allInternal) {k ℓ : ℕ} + (st : GenBoundaryState k ℓ α) : + F.throughProduct st = 1 := by + unfold EdgeSubset.throughProduct + apply Finset.prod_eq_one + intro f _ + exact absurd f.prop + (Finset.eq_empty_iff_forall_notMem.mp + (throughFlags_eq_empty_of_allInternal hall) f.val) + +/-- On an all-internal subset, no boundary flag participates. -/ +theorem boundaryFlag_notMem_of_allInternal (hall : F.allInternal) + (i : α) : W.boundaryFlag i ∉ F.flags := by + intro hmem + obtain ⟨v, hv⟩ := attach_inl_of_allInternal hall hmem + rw [W.attach_boundaryFlag i] at hv + cases hv + +/-! ## The boundary state of an even colouring -/ + +/-- The all-even boundary state recording an even colouring's +values at the boundary flags. -/ +noncomputable def evenState (hall : F.allInternal) {k : ℕ} (ℓ : ℕ) + (ψ : F.EvenColouring k) : GenBoundaryState k ℓ α := + fun i => Sum.inl (ψ.val ⟨W.boundaryFlag i, + boundaryFlag_notMem_of_allInternal hall i⟩) + +/-- The state of an even colouring satisfies the boundary subset +matching condition. -/ +theorem evenState_matches (hall : F.allInternal) {k : ℕ} (ℓ : ℕ) + (ψ : F.EvenColouring k) : + genBoundarySubsetMatches W F.flags (evenState hall ℓ ψ) := by + intro i + constructor + · intro hmem + exact absurd hmem (boundaryFlag_notMem_of_allInternal hall i) + · rintro ⟨c, hc⟩ + simp [evenState] at hc + +/-- The core odd boundary match holds vacuously at an even +state. -/ +theorem coreOddBoundaryMatch_evenState (hall : F.allInternal) + {k ℓ : ℕ} (ψ₀ : F.EvenColouring k) + (φ : F.CoreOddColouring ℓ) : + F.coreOddBoundaryMatch (evenState hall ℓ ψ₀) φ := by + intro i c hst _ + simp [evenState] at hst + +/-- The even boundary match at the state of `ψ₀` holds exactly on +the fibre of `ψ₀`. -/ +theorem genEvenBoundaryMatch_evenState_iff (hall : F.allInternal) + {k ℓ : ℕ} (ψ₀ ψ : F.EvenColouring k) : + genEvenBoundaryMatch F (evenState hall ℓ ψ₀) + (evenState_matches hall ℓ ψ₀) ψ ↔ + evenState hall ℓ ψ = evenState hall ℓ ψ₀ := by + constructor + · intro hm + funext i + exact congrArg Sum.inl (hm i (ψ₀.val ⟨W.boundaryFlag i, + boundaryFlag_notMem_of_allInternal hall i⟩) rfl) + · intro he i c hst + exact Sum.inl.inj ((congrFun he i).trans hst) + +/-! ## The colouring equivalence -/ + +/-- On an all-internal subset, the core odd colouring type is +equivalent to the full odd colouring type, via +`coreFlags = flags`. -/ +noncomputable def coreOddEquivAll (hall : F.allInternal) (ℓ : ℕ) : + F.CoreOddColouring ℓ ≃ F.OddColouring ℓ where + toFun φ := + ⟨fun f => φ.val ⟨f.val, + (coreFlags_eq_flags_of_allInternal hall).symm ▸ f.prop⟩, + fun f => (congrArg φ.val (Subtype.ext rfl)).trans + (φ.prop ⟨f.val, + (coreFlags_eq_flags_of_allInternal hall).symm ▸ f.prop⟩)⟩ + invFun φ := + ⟨fun f => φ.val ⟨f.val, + coreFlags_eq_flags_of_allInternal hall ▸ f.prop⟩, + fun f => (congrArg φ.val (Subtype.ext rfl)).trans + (φ.prop ⟨f.val, + coreFlags_eq_flags_of_allInternal hall ▸ f.prop⟩)⟩ + left_inv φ := Subtype.ext (funext fun _ => + congrArg φ.val (Subtype.ext rfl)) + right_inv φ := Subtype.ext (funext fun _ => + congrArg φ.val (Subtype.ext rfl)) + +/-! ## Vertex-local data agreement -/ + +/-- On an all-internal subset, the core odd pairs along a list are +the odd pairs of the transported colouring. -/ +private theorem flatMap_coreOddPairFn_allInternal (hall : F.allInternal) + {ℓ : ℕ} (κ : F.TransitionSystem) + (φ_core : F.CoreOddColouring ℓ) : + ∀ (l : List W.Flag) + (h1 : ∀ f ∈ l, f ∈ F.internalFlags) + (h2 : ∀ f ∈ l, f ∈ F.flags), + (l.attachWith (· ∈ F.internalFlags) h1).flatMap + (F.coreOddPairFn κ.toRelTransitionSystem φ_core) = + (l.attachWith (· ∈ F.flags) h2).flatMap + (F.oddPairFn κ (coreOddEquivAll hall ℓ φ_core)) + | [], _, _ => rfl + | a :: as, h1, h2 => by + rw [List.attachWith_cons, List.attachWith_cons, + List.flatMap_cons, List.flatMap_cons] + rw [flatMap_coreOddPairFn_allInternal hall κ φ_core as + (fun f hf => h1 f (List.mem_cons_of_mem a hf)) + (fun f hf => h2 f (List.mem_cons_of_mem a hf))] + rfl + +/-- On an all-internal subset, the core odd signs along a list are +the odd signs of the transported colouring. -/ +private theorem map_coreOddSignFn_allInternal (hall : F.allInternal) + {ℓ : ℕ} (κ : F.TransitionSystem) + (φ_core : F.CoreOddColouring ℓ) : + ∀ (l : List W.Flag) + (h1 : ∀ f ∈ l, f ∈ F.internalFlags) + (h2 : ∀ f ∈ l, f ∈ F.flags), + (l.attachWith (· ∈ F.internalFlags) h1).map + (F.coreOddSignFn κ.toRelTransitionSystem φ_core) = + (l.attachWith (· ∈ F.flags) h2).map + (F.oddSignFn κ (coreOddEquivAll hall ℓ φ_core)) + | [], _, _ => rfl + | a :: as, h1, h2 => by + rw [List.attachWith_cons, List.attachWith_cons, + List.map_cons, List.map_cons] + rw [map_coreOddSignFn_allInternal hall κ φ_core as + (fun f hf => h1 f (List.mem_cons_of_mem a hf)) + (fun f hf => h2 f (List.mem_cons_of_mem a hf))] + rfl + +/-- `coreOddListAt` at `φ_core` agrees with `oddListAt` at +`coreOddEquivAll φ_core`. -/ +theorem coreOddListAt_eq_of_allInternal (hall : F.allInternal) + {ℓ : ℕ} {κ : F.TransitionSystem} (o : κ.Orientation) + (φ_core : F.CoreOddColouring ℓ) (v : W.Vertex) : + F.coreOddListAt o.toRel φ_core v = + F.oddListAt o (coreOddEquivAll hall ℓ φ_core) v := by + unfold coreOddListAt oddListAt + change ((F.inFlagsAt o v).attachWith (· ∈ F.internalFlags) + _).flatMap _ = + ((F.inFlagsAt o v).attachWith (· ∈ F.flags) _).flatMap _ + exact flatMap_coreOddPairFn_allInternal hall κ φ_core + (F.inFlagsAt o v) _ _ + +/-- `coreOddSignAt` at `φ_core` agrees with `oddSignAt` at +`coreOddEquivAll φ_core`. -/ +theorem coreOddSignAt_eq_of_allInternal (hall : F.allInternal) + {ℓ : ℕ} {κ : F.TransitionSystem} (o : κ.Orientation) + (φ_core : F.CoreOddColouring ℓ) (v : W.Vertex) : + F.coreOddSignAt o.toRel φ_core v = + F.oddSignAt o (coreOddEquivAll hall ℓ φ_core) v := by + unfold coreOddSignAt oddSignAt + change (((F.inFlagsAt o v).attachWith (· ∈ F.internalFlags) + _).map _).prod = + (((F.inFlagsAt o v).attachWith (· ∈ F.flags) _).map _).prod + exact congrArg List.prod + (map_coreOddSignFn_allInternal hall κ φ_core + (F.inFlagsAt o v) _ _) + +/-! ## Circuit count agreement -/ + +/-- The open circuit count of a standard transition system's +relative system equals the standard circuit count. -/ +theorem openCircuitCount_toRel (κ : F.TransitionSystem) : + κ.toRelTransitionSystem.openCircuitCount = κ.circuitCount := by + rw [openCircuitCount_of_allInternal κ.toRelTransitionSystem + (allInternal_of_transition κ), + relTransition_circuitCount_eq κ] + +/-! ## The through summand at an even state -/ + +open scoped Classical in +/-- **Fibre bridge**: the through summand at the state of `ψ₀` +equals the circuit-signed colouring sum over the fibre of `ψ₀`. -/ +theorem throughSummand_evenState [LinearOrder α] + (hall : F.allInternal) {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (ψ₀ : F.EvenColouring k) {κ : F.TransitionSystem} + (o : κ.Orientation) : + F.throughSummand h (evenState hall ℓ ψ₀) + (evenState_matches hall ℓ ψ₀) o.toRel + κ.toRelTransitionSystem.openCircuitCount = + ((-1 : ℂ) ^ κ.circuitCount) * + ∑ ψ : F.EvenColouring k, + if evenState hall ℓ ψ = evenState hall ℓ ψ₀ then + ∑ φ : F.OddColouring ℓ, + ∏ v : W.Vertex, + ((F.oddSignAt o φ v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) + (F.oddListAt o φ v)) + else 0 := by + unfold EdgeSubset.throughSummand + rw [openCircuitCount_toRel κ, + throughProduct_one_of_allInternal hall (evenState hall ℓ ψ₀), + mul_one] + congr 1 + refine Finset.sum_congr rfl fun ψ _ => ?_ + by_cases hm : genEvenBoundaryMatch F (evenState hall ℓ ψ₀) + (evenState_matches hall ℓ ψ₀) ψ + · rw [ite_eq_left hm, + ite_eq_left ((genEvenBoundaryMatch_evenState_iff hall ψ₀ ψ).mp hm)] + refine Fintype.sum_equiv (coreOddEquivAll hall ℓ) + (fun φ_core => + if F.coreOddBoundaryMatch (evenState hall ℓ ψ₀) φ_core then + ∏ v : W.Vertex, + ((F.coreOddSignAt o.toRel φ_core v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) + (F.coreOddListAt o.toRel φ_core v)) + else (0 : ℂ)) + (fun φ => + ∏ v : W.Vertex, + ((F.oddSignAt o φ v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) + (F.oddListAt o φ v))) + (fun φ_core => ?_) + rw [ite_eq_left (coreOddBoundaryMatch_evenState hall ψ₀ φ_core)] + refine Finset.prod_congr rfl fun v _ => ?_ + rw [coreOddSignAt_eq_of_allInternal hall o φ_core v, + coreOddListAt_eq_of_allInternal hall o φ_core v] + · rw [ite_eq_right hm, ite_eq_right (fun he => hm + ((genEvenBoundaryMatch_evenState_iff hall ψ₀ ψ).mpr he))] + +/-! ## The fibre decomposition of the mixed summand -/ + +/-- **Fibre decomposition**: the mixed summand is the sum over the +realized boundary states of the fibre sums. -/ +theorem mixedSummand_eq_fibre_sum (hall : F.allInternal) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + {κ : F.TransitionSystem} (o : κ.Orientation) : + F.mixedSummand h o = + ∑ st ∈ Finset.univ.image (evenState hall ℓ), + ((-1 : ℂ) ^ κ.circuitCount) * + ∑ ψ : F.EvenColouring k, + if evenState hall ℓ ψ = st then + ∑ φ : F.OddColouring ℓ, + ∏ v : W.Vertex, + ((F.oddSignAt o φ v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) + (F.oddListAt o φ v)) + else 0 := by + unfold EdgeSubset.mixedSummand + conv_rhs => rw [← Finset.mul_sum] + congr 1 + rw [← Finset.sum_fiberwise_of_maps_to + (fun ψ _ => Finset.mem_image_of_mem (evenState hall ℓ) + (Finset.mem_univ ψ)) + (fun ψ : F.EvenColouring k => + ∑ φ : F.OddColouring ℓ, + ∏ v : W.Vertex, + ((F.oddSignAt o φ v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) + (F.oddListAt o φ v)))] + exact Finset.sum_congr rfl fun st _ => Finset.sum_filter _ _ + +end EdgeSubset + +/-! ## The Eulerian-independence interface, proved -/ + +/-- **Eulerian independence** (Regts–Sevenster arXiv:1807.04494, +Proposition 3, as a theorem): the Definition 5 mixed summand of an +edge subset does not depend on the choice of transition system and +orientation. -/ +theorem eulerianIndependence : EulerianIndependence := by + intro α W F k ℓ h κ κ' o o' + let : LinearOrder α := IsWellOrder.linearOrder WellOrderingRel + have hall : F.allInternal := EdgeSubset.allInternal_of_transition κ + rw [EdgeSubset.mixedSummand_eq_fibre_sum hall h o, + EdgeSubset.mixedSummand_eq_fibre_sum hall h o'] + refine Finset.sum_congr rfl fun st hst => ?_ + obtain ⟨ψ₀, -, rfl⟩ := Finset.mem_image.mp hst + rw [← EdgeSubset.throughSummand_evenState hall h ψ₀ o, + ← EdgeSubset.throughSummand_evenState hall h ψ₀ o'] + exact EdgeSubset.throughSummand_independence_of_allInternal hall h + (EdgeSubset.evenState hall ℓ ψ₀) + (EdgeSubset.evenState_matches hall ℓ ψ₀) + κ.toRelTransitionSystem κ'.toRelTransitionSystem + o.toRel o'.toRel + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalIndependence.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalIndependence.lean new file mode 100644 index 0000000000..438c4cfec1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalIndependence.lean @@ -0,0 +1,132 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepLedger + +/-! +# Unconditional independence on all-internal subsets + +On an all-internal edge subset every participating flag is +periodic, so every repair square is localized and the single-step +ledger connects any two transition systems: the constrained +summand at the open circuit count is independent of all choices — +Proposition 3 for the boundary-free sector, as a theorem. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} + +namespace EdgeSubset + +/-- On an all-internal subset every repair square is localized: +both principal flags are periodic. -/ +theorem squareLocalized_of_allInternal {W : Fragment α} {F : EdgeSubset W} + (hall : F.allInternal) + {κ : F.RelTransitionSystem} {a b c d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) : + SquareLocalized κ a b c d := + Or.inl ⟨periodic_of_allInternal κ hall hsq.ha, + periodic_of_allInternal κ hall hsq.hc⟩ + +/-- On an all-internal subset every repair step preserves the +(empty) boundary pairing. -/ +theorem matchPreservingStep_of_allInternal {W : Fragment α} {F : EdgeSubset W} + (hall : F.allInternal) + {κ₁ κ₂ : F.RelTransitionSystem} + (h : IsRepairStep κ₁ κ₂) : MatchPreservingStep κ₁ κ₂ := by + obtain ⟨a, b, c, d, v, hsq, heq⟩ := h + exact ⟨a, b, c, d, v, hsq, + RelTransitionSystem.MatchEq.symm heq, + pathMatch_repair_of_localized hsq + (squareLocalized_of_allInternal hall hsq)⟩ + +/-- The single-step value chain on an all-internal subset. -/ +private theorem allInternal_chain + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {k ℓ : ℕ} + (hall : F.allInternal) (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ : F.RelTransitionSystem} (o : κ.Orientation) + {n : ℕ} (chain : Fin (n + 1) → F.RelTransitionSystem) + (h0 : (chain 0).MatchEq κ) + (hstep : ∀ r : Fin n, + IsRepairStep (chain r.castSucc) (chain r.succ)) : + ∀ r : Fin (n + 1), + ∃ (oᵣ : (chain r).Orientation), + pathSign (chain r) * + F.throughSummand hM st hbnd oᵣ + (chain r).openCircuitCount = + pathSign κ * + F.throughSummand hM st hbnd o κ.openCircuitCount := by + intro r + induction r using Fin.induction with + | zero => + obtain ⟨o₀, hval⟩ := signed_summand_matchEq hM st hbnd + (RelTransitionSystem.MatchEq.symm h0) o + exact ⟨o₀, hval⟩ + | succ r ih => + obtain ⟨oprev, hprev⟩ := ih + have hcprev : PathCanonical oprev := + pathCanonical_of_allInternal hall oprev + obtain ⟨o₂, _, hstepval⟩ := stepLedger_single hM st hbnd _ _ + (matchPreservingStep_of_allInternal hall (hstep r)) + oprev hcprev + exact ⟨o₂, hstepval.trans hprev⟩ + +/-- **Unconditional independence on all-internal subsets**: the +constrained summand at the open circuit count is independent of +the transition system and orientation. (Canonicality is vacuous +and the path sign is trivial without boundary flags.) -/ +theorem throughSummand_independence_of_allInternal + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {k ℓ : ℕ} + (hall : F.allInternal) (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (κ κ' : F.RelTransitionSystem) + (o : κ.Orientation) (o' : κ'.Orientation) : + F.throughSummand hM st hbnd o κ.openCircuitCount = + F.throughSummand hM st hbnd o' κ'.openCircuitCount := by + obtain ⟨n, chain, h0, hlast, hstep⟩ := repair_connectivity κ κ' + obtain ⟨olast, hval⟩ := allInternal_chain hall hM st hbnd o + chain h0 hstep (Fin.last n) + obtain ⟨oκ', hvalκ'⟩ := signed_summand_matchEq hM st hbnd + hlast olast + have h1 := hvalκ'.trans hval + have e' : pathSign κ' * + F.throughSummand hM st hbnd oκ' κ'.openCircuitCount = + F.throughSummand hM st hbnd oκ' κ'.openCircuitCount := + (congrArg (fun x => x * + F.throughSummand hM st hbnd oκ' κ'.openCircuitCount) + (pathSign_of_allInternal hall κ')).trans + (one_mul _) + have e : pathSign κ * + F.throughSummand hM st hbnd o κ.openCircuitCount = + F.throughSummand hM st hbnd o κ.openCircuitCount := + (congrArg (fun x => x * + F.throughSummand hM st hbnd o κ.openCircuitCount) + (pathSign_of_allInternal hall κ)).trans + (one_mul _) + have h2 : + F.throughSummand hM st hbnd oκ' κ'.openCircuitCount = + F.throughSummand hM st hbnd o κ.openCircuitCount := + e'.symm.trans (h1.trans e) + exact h2.symm.trans + (throughSummand_pathCanonical hM st hbnd + (pathCanonical_of_allInternal hall oκ') + (pathCanonical_of_allInternal hall o') _) + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedInstance.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedInstance.lean new file mode 100644 index 0000000000..b9760cfc86 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedInstance.lean @@ -0,0 +1,387 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedNat + +/-! +# The symmetric skein category + +Kernel descents of the braiding-naturality squares, the hexagon +label identities, and the `BraidedCategory`/`SymmetricCategory` +instances on `SkeinObj f`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The left braiding-naturality difference lies in the kernel. -/ +theorem mem_ker_braidNatLeft {s t : ℕ} (k : ℕ) + (x : Fragment (Fin (s + t)) →₀ ℂ) : + composeFinsupp (s + k) (t + k) (k + t) + (tensorFinsupp s t k k x + (Finsupp.single (strandBundle k) 1)) + (Finsupp.single (bundleMap (transposeEquiv t k)) 1) - + composeFinsupp (s + k) (k + s) (k + t) + (Finsupp.single (bundleMap (transposeEquiv s k)) 1) + (tensorFinsupp k k s t + (Finsupp.single (strandBundle k) 1) x) ∈ + LinearMap.ker (connectionMap f.val ((s + k) + (k + t))) := by + induction x using Finsupp.induction_linear with + | zero => + simp only [map_zero, LinearMap.zero_apply, sub_zero] + exact Submodule.zero_mem _ + | add a b ha hb => + simp only [map_add, LinearMap.add_apply] at ha hb ⊢ + rw [show ∀ (A B C D : (Fragment (Fin ((s + k) + (k + t))) + →₀ ℂ)), A + B - (C + D) = (A - C) + (B - D) from + fun A B C D => by abel] + exact Submodule.add_mem _ ha hb + | single F c => + rw [tensorFinsupp_single, tensorFinsupp_single, + composeFinsupp_single, composeFinsupp_single, + show (c * 1) * 1 = 1 * (1 * c) from by ring] + exact mem_ker_single_sub_of_equiv_smul f + (braidNatLeftFrag k F) (1 * (1 * c)) + +/-- The right braiding-naturality difference lies in the +kernel. -/ +theorem mem_ker_braidNatRight {s t : ℕ} (k : ℕ) + (x : Fragment (Fin (s + t)) →₀ ℂ) : + composeFinsupp (k + s) (k + t) (t + k) + (tensorFinsupp k k s t + (Finsupp.single (strandBundle k) 1) x) + (Finsupp.single (bundleMap (transposeEquiv k t)) 1) - + composeFinsupp (k + s) (s + k) (t + k) + (Finsupp.single (bundleMap (transposeEquiv k s)) 1) + (tensorFinsupp s t k k x + (Finsupp.single (strandBundle k) 1)) ∈ + LinearMap.ker (connectionMap f.val ((k + s) + (t + k))) := by + induction x using Finsupp.induction_linear with + | zero => + simp only [map_zero, LinearMap.zero_apply, sub_zero] + exact Submodule.zero_mem _ + | add a b ha hb => + simp only [map_add, LinearMap.add_apply] at ha hb ⊢ + rw [show ∀ (A B C D : (Fragment (Fin ((k + s) + (t + k))) + →₀ ℂ)), A + B - (C + D) = (A - C) + (B - D) from + fun A B C D => by abel] + exact Submodule.add_mem _ ha hb + | single F c => + rw [tensorFinsupp_single, tensorFinsupp_single, + composeFinsupp_single, composeFinsupp_single, + show (1 * c) * 1 = 1 * (c * 1) from by ring] + exact mem_ker_single_sub_of_equiv_smul f + (braidNatRightFrag k F) (1 * (c * 1)) + +/-- **Left braiding naturality on Hom classes.** -/ +theorem braidNatLeft_class {s t : ℕ} (k : ℕ) + (p : HomSpace f.val (s + t)) : + HomSpace.comp f (s + k) (t + k) (k + t) + (HomSpace.tensor f s t k k p + (HomSpace.ofFragment f.val (strandBundle k))) + (bundleMapClass f (transposeEquiv t k)) = + HomSpace.comp f (s + k) (k + s) (k + t) + (bundleMapClass f (transposeEquiv s k)) + (HomSpace.tensor f k k s t + (HomSpace.ofFragment f.val (strandBundle k)) p) := by + obtain ⟨x, rfl⟩ := Submodule.Quotient.mk_surjective _ p + exact (Submodule.Quotient.eq _).mpr + (mem_ker_braidNatLeft f k x) + +/-- **Right braiding naturality on Hom classes.** -/ +theorem braidNatRight_class {s t : ℕ} (k : ℕ) + (p : HomSpace f.val (s + t)) : + HomSpace.comp f (k + s) (k + t) (t + k) + (HomSpace.tensor f k k s t + (HomSpace.ofFragment f.val (strandBundle k)) p) + (bundleMapClass f (transposeEquiv k t)) = + HomSpace.comp f (k + s) (s + k) (t + k) + (bundleMapClass f (transposeEquiv k s)) + (HomSpace.tensor f s t k k p + (HomSpace.ofFragment f.val (strandBundle k))) := by + obtain ⟨x, rfl⟩ := Submodule.Quotient.mk_surjective _ p + exact (Submodule.Quotient.eq _).mpr + (mem_ker_braidNatRight f k x) + +/-- The forward hexagon label identity. -/ +theorem hexagonF_label (a b c : ℕ) : + (finCongr (by omega : (a + b) + c = a + (b + c))).trans + ((transposeEquiv a (b + c)).trans + (finCongr (by omega : (b + c) + a = b + (c + a)))) = + (tensorMapEquiv (transposeEquiv a b) + (_root_.Equiv.refl (Fin c))).trans + ((finCongr (by omega : (b + a) + c = b + (a + c))).trans + (tensorMapEquiv (_root_.Equiv.refl (Fin b)) + (transposeEquiv a c))) := by + refine _root_.Equiv.ext (fun x => Fin.ext ?_) + have hx := x.isLt + rcases Nat.lt_or_ge x.val a with h1 | h1 + · conv_lhs => rw [_root_.Equiv.trans_apply, + _root_.Equiv.trans_apply, + show (finCongr (by omega : (a + b) + c = a + (b + c))) x = + ⟨x.val, by omega⟩ from Fin.ext rfl, + transposeEquiv_low a (b + c) x.val h1 (by omega) + (by omega)] + conv_rhs => rw [_root_.Equiv.trans_apply, + _root_.Equiv.trans_apply, + show x = Fin.castAdd c (Fin.castAdd b + ⟨x.val, by omega⟩) from Fin.ext rfl, + tensorMapEquiv_castAdd, + show (transposeEquiv a b) (Fin.castAdd b + ⟨x.val, by omega⟩) = ⟨b + x.val, by omega⟩ from by + rw [show (Fin.castAdd b ⟨x.val, by omega⟩ : + Fin (a + b)) = ⟨x.val, by omega⟩ from Fin.ext rfl] + exact transposeEquiv_low a b x.val h1 (by omega) + (by omega), + show (finCongr (by omega : (b + a) + c = b + (a + c))) + (Fin.castAdd c ⟨b + x.val, by omega⟩) = + Fin.natAdd b ⟨x.val, by omega⟩ from Fin.ext (by + change b + x.val = b + x.val + rfl), + tensorMapEquiv_natAdd, + transposeEquiv_low a c x.val h1 (by omega) (by omega)] + exact (by + change (b + c) + x.val = b + (c + x.val) + omega) + · rcases Nat.lt_or_ge x.val (a + b) with h2 | h2 + · conv_lhs => rw [_root_.Equiv.trans_apply, + _root_.Equiv.trans_apply, + show (finCongr (by omega : (a + b) + c = a + (b + c))) + x = ⟨a + (x.val - a), by omega⟩ from Fin.ext (by + change x.val = a + (x.val - a) + omega), + transposeEquiv_high a (b + c) (x.val - a) (by omega) + (by omega) (by omega)] + conv_rhs => rw [_root_.Equiv.trans_apply, + _root_.Equiv.trans_apply, + show x = Fin.castAdd c (Fin.natAdd a + ⟨x.val - a, by omega⟩) from Fin.ext (by + change x.val = a + (x.val - a) + omega), + tensorMapEquiv_castAdd, + show (transposeEquiv a b) (Fin.natAdd a + ⟨x.val - a, by omega⟩) = ⟨x.val - a, by omega⟩ + from by + rw [show (Fin.natAdd a ⟨x.val - a, by omega⟩ : + Fin (a + b)) = ⟨a + (x.val - a), by omega⟩ from + Fin.ext rfl] + exact transposeEquiv_high a b (x.val - a) (by omega) + (by omega) (by omega), + show (finCongr (by omega : (b + a) + c = b + (a + c))) + (Fin.castAdd c ⟨x.val - a, by omega⟩) = + Fin.castAdd (a + c) ⟨x.val - a, by omega⟩ from + Fin.ext rfl, + tensorMapEquiv_castAdd] + rfl + · conv_lhs => rw [_root_.Equiv.trans_apply, + _root_.Equiv.trans_apply, + show (finCongr (by omega : (a + b) + c = a + (b + c))) + x = ⟨a + (x.val - a), by omega⟩ from Fin.ext (by + change x.val = a + (x.val - a) + omega), + transposeEquiv_high a (b + c) (x.val - a) (by omega) + (by omega) (by omega)] + conv_rhs => rw [_root_.Equiv.trans_apply, + _root_.Equiv.trans_apply, + show x = Fin.natAdd (a + b) + ⟨x.val - (a + b), by omega⟩ from Fin.ext (by + change x.val = (a + b) + (x.val - (a + b)) + omega), + tensorMapEquiv_natAdd, + show ((_root_.Equiv.refl (Fin c)) + (⟨x.val - (a + b), by omega⟩ : Fin c)) = + ⟨x.val - (a + b), by omega⟩ from rfl, + show (finCongr (by omega : (b + a) + c = b + (a + c))) + (Fin.natAdd (b + a) ⟨x.val - (a + b), by omega⟩) = + Fin.natAdd b ⟨a + (x.val - (a + b)), by omega⟩ from + Fin.ext (by + change (b + a) + (x.val - (a + b)) = + b + (a + (x.val - (a + b))) + omega), + tensorMapEquiv_natAdd, + show (transposeEquiv a c) + ⟨a + (x.val - (a + b)), by omega⟩ = + ⟨x.val - (a + b), by omega⟩ from + transposeEquiv_high a c (x.val - (a + b)) (by omega) + (by omega) (by omega)] + exact (by + change x.val - a = b + (x.val - (a + b)) + omega) + +/-- The reverse hexagon label identity. -/ +theorem hexagonR_label (a b c : ℕ) : + (finCongr (by omega : a + (b + c) = (a + b) + c)).trans + ((transposeEquiv (a + b) c).trans + (finCongr (by omega : c + (a + b) = (c + a) + b))) = + (tensorMapEquiv (_root_.Equiv.refl (Fin a)) + (transposeEquiv b c)).trans + ((finCongr (by omega : a + (c + b) = (a + c) + b)).trans + (tensorMapEquiv (transposeEquiv a c) + (_root_.Equiv.refl (Fin b)))) := by + refine _root_.Equiv.ext (fun x => Fin.ext ?_) + have hx := x.isLt + rcases Nat.lt_or_ge x.val a with h1 | h1 + · conv_lhs => rw [_root_.Equiv.trans_apply, + _root_.Equiv.trans_apply, + show (finCongr (by omega : a + (b + c) = (a + b) + c)) x = + ⟨x.val, by omega⟩ from Fin.ext rfl, + transposeEquiv_low (a + b) c x.val (by omega) (by omega) + (by omega)] + conv_rhs => rw [_root_.Equiv.trans_apply, + _root_.Equiv.trans_apply, + show x = Fin.castAdd (b + c) ⟨x.val, h1⟩ from + Fin.ext rfl, + tensorMapEquiv_castAdd, + show (finCongr (by omega : a + (c + b) = (a + c) + b)) + (Fin.castAdd (c + b) + ((_root_.Equiv.refl (Fin a)) ⟨x.val, h1⟩)) = + Fin.castAdd b (Fin.castAdd c ⟨x.val, h1⟩) from + Fin.ext rfl, + tensorMapEquiv_castAdd, + show (transposeEquiv a c) (Fin.castAdd c ⟨x.val, h1⟩) = + ⟨c + x.val, by omega⟩ from by + rw [show (Fin.castAdd c ⟨x.val, h1⟩ : Fin (a + c)) = + ⟨x.val, by omega⟩ from Fin.ext rfl] + exact transposeEquiv_low a c x.val h1 (by omega) + (by omega)] + rfl + · rcases Nat.lt_or_ge x.val (a + b) with h2 | h2 + · conv_lhs => rw [_root_.Equiv.trans_apply, + _root_.Equiv.trans_apply, + show (finCongr (by omega : a + (b + c) = (a + b) + c)) + x = ⟨x.val, by omega⟩ from Fin.ext rfl, + transposeEquiv_low (a + b) c x.val h2 (by omega) + (by omega)] + conv_rhs => rw [_root_.Equiv.trans_apply, + _root_.Equiv.trans_apply, + show x = Fin.natAdd a ⟨x.val - a, by omega⟩ from + Fin.ext (by + change x.val = a + (x.val - a) + omega), + tensorMapEquiv_natAdd, + show (transposeEquiv b c) ⟨x.val - a, by omega⟩ = + ⟨c + (x.val - a), by omega⟩ from + transposeEquiv_low b c (x.val - a) (by omega) + (by omega) (by omega), + show (finCongr (by omega : a + (c + b) = (a + c) + b)) + (Fin.natAdd a ⟨c + (x.val - a), by omega⟩) = + Fin.natAdd (a + c) ⟨x.val - a, by omega⟩ from + Fin.ext (by + change a + (c + (x.val - a)) = (a + c) + (x.val - a) + omega), + tensorMapEquiv_natAdd] + exact (by + change c + x.val = (c + a) + (x.val - a) + omega) + · conv_lhs => rw [_root_.Equiv.trans_apply, + _root_.Equiv.trans_apply, + show (finCongr (by omega : a + (b + c) = (a + b) + c)) + x = ⟨(a + b) + (x.val - (a + b)), by omega⟩ from + Fin.ext (by + change x.val = (a + b) + (x.val - (a + b)) + omega), + transposeEquiv_high (a + b) c (x.val - (a + b)) + (by omega) (by omega) (by omega)] + conv_rhs => rw [_root_.Equiv.trans_apply, + _root_.Equiv.trans_apply, + show x = Fin.natAdd a ⟨x.val - a, by omega⟩ from + Fin.ext (by + change x.val = a + (x.val - a) + omega), + tensorMapEquiv_natAdd, + show (transposeEquiv b c) ⟨x.val - a, by omega⟩ = + ⟨x.val - a - b, by omega⟩ from by + rw [show (⟨x.val - a, by omega⟩ : Fin (b + c)) = + ⟨b + (x.val - a - b), by omega⟩ from Fin.ext (by + change x.val - a = b + (x.val - a - b) + omega)] + exact transposeEquiv_high b c (x.val - a - b) + (by omega) (by omega) (by omega), + show (finCongr (by omega : a + (c + b) = (a + c) + b)) + (Fin.natAdd a ⟨x.val - a - b, by omega⟩) = + Fin.castAdd b (Fin.natAdd a + ⟨x.val - a - b, by omega⟩) from Fin.ext rfl, + tensorMapEquiv_castAdd, + show (transposeEquiv a c) (Fin.natAdd a + ⟨x.val - a - b, by omega⟩) = + ⟨x.val - a - b, by omega⟩ from by + rw [show (Fin.natAdd a ⟨x.val - a - b, by omega⟩ : + Fin (a + c)) = ⟨a + (x.val - a - b), by omega⟩ + from Fin.ext rfl] + exact transposeEquiv_high a c (x.val - a - b) + (by omega) (by omega) (by omega)] + exact (by + change x.val - (a + b) = x.val - a - b + omega) + +/-- **The braided skein category.** -/ +noncomputable instance skeinBraided : + BraidedCategory (SkeinObj f) where + braiding X Y := skeinBraiding f X Y + braiding_naturality_right X {Y Z} p := + braidNatRight_class f X.arity p + braiding_naturality_left {X Y} p Z := + braidNatLeft_class f Z.arity p + hexagon_forward X Y Z := by + change HomSpace.comp f _ _ _ + (bundleMapClass f (finCongr _)) + (HomSpace.comp f _ _ _ + (bundleMapClass f (transposeEquiv X.arity + (Y.arity + Z.arity))) + (bundleMapClass f (finCongr _))) = + HomSpace.comp f _ _ _ + (HomSpace.tensor f _ _ _ _ + (bundleMapClass f (transposeEquiv X.arity Y.arity)) + (HomSpace.ofFragment f.val (strandBundle Z.arity))) + (HomSpace.comp f _ _ _ + (bundleMapClass f (finCongr _)) + (HomSpace.tensor f _ _ _ _ + (HomSpace.ofFragment f.val (strandBundle Y.arity)) + (bundleMapClass f (transposeEquiv X.arity + Z.arity)))) + rw [bundleMapClass_tensor_id_right, + bundleMapClass_tensor_id_left, + bundleMapClass_comp, bundleMapClass_comp, + bundleMapClass_comp, bundleMapClass_comp] + exact bundleMapClass_congr f + (hexagonF_label X.arity Y.arity Z.arity) + hexagon_reverse X Y Z := by + change HomSpace.comp f _ _ _ + (bundleMapClass f (finCongr _)) + (HomSpace.comp f _ _ _ + (bundleMapClass f (transposeEquiv + (X.arity + Y.arity) Z.arity)) + (bundleMapClass f (finCongr _))) = + HomSpace.comp f _ _ _ + (HomSpace.tensor f _ _ _ _ + (HomSpace.ofFragment f.val (strandBundle X.arity)) + (bundleMapClass f (transposeEquiv Y.arity Z.arity))) + (HomSpace.comp f _ _ _ + (bundleMapClass f (finCongr _)) + (HomSpace.tensor f _ _ _ _ + (bundleMapClass f (transposeEquiv X.arity Z.arity)) + (HomSpace.ofFragment f.val + (strandBundle Y.arity)))) + rw [bundleMapClass_tensor_id_left, + bundleMapClass_tensor_id_right, + bundleMapClass_comp, bundleMapClass_comp, + bundleMapClass_comp, bundleMapClass_comp] + exact bundleMapClass_congr f + (hexagonR_label X.arity Y.arity Z.arity) + +/-- **The symmetric skein category.** -/ +noncomputable instance skeinSymmetric : + SymmetricCategory (SkeinObj f) where + symmetry X Y := skeinBraiding_symmetry f X Y + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedNat.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedNat.lean new file mode 100644 index 0000000000..9164f8bf78 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedNat.lean @@ -0,0 +1,363 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance + +/-! +# Braiding naturality, fragment level + +Value lemmas for the tensor swap, the braiding-naturality label +meets, and the fragment-level naturality squares. +-/ + +@[expose] public section + +namespace RS + +/-! ### Values of the tensor swap -/ + +/-- The tensor swap on an incoming label of the left factor. -/ +theorem tensorSwapEquiv_in_left (s t u v : ℕ) (i : Fin u) : + tensorSwapEquiv s t u v + (Fin.castAdd (v + t) (Fin.castAdd s i)) = + Fin.castAdd (t + v) (Fin.natAdd s i) := by + unfold tensorSwapEquiv + rw [_root_.Equiv.trans_apply, _root_.Equiv.trans_apply, + interleaveEquiv_symm_low_left u v s t i] + exact interleaveEquiv_inr_low s t u v i + +/-- On an incoming label of the right factor. -/ +theorem tensorSwapEquiv_in_right (s t u v : ℕ) (j : Fin s) : + tensorSwapEquiv s t u v + (Fin.castAdd (v + t) (Fin.natAdd u j)) = + Fin.castAdd (t + v) (Fin.castAdd u j) := by + unfold tensorSwapEquiv + rw [_root_.Equiv.trans_apply, _root_.Equiv.trans_apply, + interleaveEquiv_symm_low_right u v s t j] + exact interleaveEquiv_inl_low s t u v j + +/-- On an outgoing label of the left factor. -/ +theorem tensorSwapEquiv_out_left (s t u v : ℕ) (l : Fin v) : + tensorSwapEquiv s t u v + (Fin.natAdd (u + s) (Fin.castAdd t l)) = + Fin.natAdd (s + u) (Fin.natAdd t l) := by + unfold tensorSwapEquiv + rw [_root_.Equiv.trans_apply, _root_.Equiv.trans_apply, + interleaveEquiv_symm_high_left u v s t l] + exact interleaveEquiv_inr_high s t u v l + +/-- On an outgoing label of the right factor. -/ +theorem tensorSwapEquiv_out_right (s t u v : ℕ) (m : Fin t) : + tensorSwapEquiv s t u v + (Fin.natAdd (u + s) (Fin.natAdd v m)) = + Fin.natAdd (s + u) (Fin.castAdd v m) := by + unfold tensorSwapEquiv + rw [_root_.Equiv.trans_apply, _root_.Equiv.trans_apply, + interleaveEquiv_symm_high_right u v s t m] + exact interleaveEquiv_inl_high s t u v m + +/-! ### The left naturality label meet -/ + +/-- **The left naturality square meets on labels**: swapping then +braiding the right leg relabels the same way as braiding the left +leg then swapping. -/ +theorem braidNatLeft_label (s t k : ℕ) : + (tensorSwapEquiv s t k k).trans + (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (s + k))) + (transposeEquiv t k)).trans finSumFinEquiv)) = + finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (transposeEquiv s k).symm + (_root_.Equiv.refl (Fin (k + t)))).trans + finSumFinEquiv) := by + refine _root_.Equiv.ext (fun x => Fin.ext ?_) + have hx := x.isLt + -- ═══════ THE FOUR BLOCKS OF THE LABEL RANGE ═══════ + -- The braiding moves the `k`-block past the `s`- and `t`-blocks; + -- each block's labels are computed in turn. + rcases Nat.lt_or_ge x.val k with h1 | h1 + · conv_lhs => rw [show x = Fin.castAdd (k + t) + (Fin.castAdd s ⟨x.val, h1⟩) from Fin.ext rfl, + _root_.Equiv.trans_apply, + tensorSwapEquiv_in_left s t k k ⟨x.val, h1⟩, + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_castAdd, + _root_.Equiv.trans_apply] + conv_rhs => rw [show x = Fin.castAdd (k + t) + (Fin.castAdd s ⟨x.val, h1⟩) from Fin.ext rfl, + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_castAdd, + _root_.Equiv.trans_apply] + change (finSumFinEquiv (Sum.inl (Fin.natAdd s + ⟨x.val, h1⟩))).val = (finSumFinEquiv (Sum.inl + ((transposeEquiv s k).symm (Fin.castAdd s + ⟨x.val, h1⟩)))).val + rw [finSumFinEquiv_apply_left, finSumFinEquiv_apply_left, + transposeEquiv_symm, + show (Fin.castAdd s ⟨x.val, h1⟩ : Fin (k + s)) = + ⟨x.val, by omega⟩ from Fin.ext rfl, + transposeEquiv_low k s x.val h1 (by omega) (by omega)] + rfl + · rcases Nat.lt_or_ge x.val (k + s) with h2 | h2 + · conv_lhs => rw [show x = Fin.castAdd (k + t) + (Fin.natAdd k ⟨x.val - k, by omega⟩) from Fin.ext (by + change x.val = k + (x.val - k) + omega), + _root_.Equiv.trans_apply, + tensorSwapEquiv_in_right s t k k ⟨x.val - k, by omega⟩, + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_castAdd, + _root_.Equiv.trans_apply] + conv_rhs => rw [show x = Fin.castAdd (k + t) + (Fin.natAdd k ⟨x.val - k, by omega⟩) from Fin.ext (by + change x.val = k + (x.val - k) + omega), + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_castAdd, + _root_.Equiv.trans_apply] + change (finSumFinEquiv (Sum.inl (Fin.castAdd k + ⟨x.val - k, by omega⟩))).val = (finSumFinEquiv (Sum.inl + ((transposeEquiv s k).symm (Fin.natAdd k + ⟨x.val - k, by omega⟩)))).val + rw [finSumFinEquiv_apply_left, finSumFinEquiv_apply_left, + transposeEquiv_symm, + show (Fin.natAdd k ⟨x.val - k, by omega⟩ : + Fin (k + s)) = ⟨k + (x.val - k), by omega⟩ from + Fin.ext rfl, + transposeEquiv_high k s (x.val - k) (by omega) + (by omega) (by omega)] + rfl + · rcases Nat.lt_or_ge x.val ((k + s) + k) with h3 | h3 + · conv_lhs => rw [show x = Fin.natAdd (k + s) + (Fin.castAdd t ⟨x.val - (k + s), by omega⟩) from + Fin.ext (by + change x.val = (k + s) + (x.val - (k + s)) + omega), + _root_.Equiv.trans_apply, + tensorSwapEquiv_out_left s t k k + ⟨x.val - (k + s), by omega⟩, + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_natAdd, + _root_.Equiv.trans_apply] + conv_rhs => rw [show x = Fin.natAdd (k + s) + (Fin.castAdd t ⟨x.val - (k + s), by omega⟩) from + Fin.ext (by + change x.val = (k + s) + (x.val - (k + s)) + omega), + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_natAdd, + _root_.Equiv.trans_apply] + change (finSumFinEquiv (Sum.inr ((transposeEquiv t k) + (Fin.natAdd t ⟨x.val - (k + s), by omega⟩)))).val = + (finSumFinEquiv (Sum.inr (Fin.castAdd t + ⟨x.val - (k + s), by omega⟩))).val + rw [finSumFinEquiv_apply_right, + finSumFinEquiv_apply_right, + show (Fin.natAdd t ⟨x.val - (k + s), by omega⟩ : + Fin (t + k)) = ⟨t + (x.val - (k + s)), by omega⟩ + from Fin.ext rfl, + transposeEquiv_high t k (x.val - (k + s)) (by omega) + (by omega) (by omega)] + rfl + · conv_lhs => rw [show x = Fin.natAdd (k + s) + (Fin.natAdd k ⟨x.val - ((k + s) + k), by omega⟩) + from Fin.ext (by + change x.val = (k + s) + (k + (x.val - ((k + s) + k))) + omega), + _root_.Equiv.trans_apply, + tensorSwapEquiv_out_right s t k k + ⟨x.val - ((k + s) + k), by omega⟩, + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_natAdd, + _root_.Equiv.trans_apply] + conv_rhs => rw [show x = Fin.natAdd (k + s) + (Fin.natAdd k ⟨x.val - ((k + s) + k), by omega⟩) + from Fin.ext (by + change x.val = (k + s) + (k + (x.val - ((k + s) + k))) + omega), + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_natAdd, + _root_.Equiv.trans_apply] + change (finSumFinEquiv (Sum.inr ((transposeEquiv t k) + (Fin.castAdd k + ⟨x.val - ((k + s) + k), by omega⟩)))).val = + (finSumFinEquiv (Sum.inr (Fin.natAdd k + ⟨x.val - ((k + s) + k), by omega⟩))).val + rw [finSumFinEquiv_apply_right, + finSumFinEquiv_apply_right, + show (Fin.castAdd k + ⟨x.val - ((k + s) + k), by omega⟩ : + Fin (t + k)) = ⟨x.val - ((k + s) + k), by omega⟩ + from Fin.ext rfl, + transposeEquiv_low t k (x.val - ((k + s) + k)) + (by omega) (by omega) (by omega)] + rfl + +/-- The left braiding-naturality square, fragment level. -/ +noncomputable def braidNatLeftFrag {s t : ℕ} (k : ℕ) + (F : Fragment (Fin (s + t))) : + ((tensorFragment F (strandBundle k)).compose + (bundleMap (transposeEquiv t k))).Equiv + ((bundleMap (transposeEquiv s k)).compose + (tensorFragment (strandBundle k) F)) := by + refine (composeBundleMap _ _).trans ?_ + refine (Fragment.Equiv.relabelCongr + (tensorFragmentComm F (strandBundle k)) _).trans ?_ + refine (Fragment.Equiv.relabelTrans _ _ _).trans ?_ + refine Fragment.Equiv.trans ?_ (bundleMapCompose _ _).symm + exact Fragment.Equiv.relabelEq _ (braidNatLeft_label s t k) + +/-! ### The right naturality label meet -/ + +/-- The mirrored square, braiding on the other side. -/ +theorem braidNatRight_label (s t k : ℕ) : + (tensorSwapEquiv k k s t).trans + (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (k + s))) + (transposeEquiv k t)).trans finSumFinEquiv)) = + finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (transposeEquiv k s).symm + (_root_.Equiv.refl (Fin (t + k)))).trans + finSumFinEquiv) := by + refine _root_.Equiv.ext (fun x => Fin.ext ?_) + have hx := x.isLt + -- ═══════ THE FOUR BLOCKS OF THE LABEL RANGE ═══════ + -- As on the left, with the `k`-block moving the other way. + rcases Nat.lt_or_ge x.val s with h1 | h1 + · conv_lhs => rw [show x = Fin.castAdd (t + k) + (Fin.castAdd k ⟨x.val, h1⟩) from Fin.ext rfl, + _root_.Equiv.trans_apply, + tensorSwapEquiv_in_left k k s t ⟨x.val, h1⟩, + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_castAdd, + _root_.Equiv.trans_apply] + conv_rhs => rw [show x = Fin.castAdd (t + k) + (Fin.castAdd k ⟨x.val, h1⟩) from Fin.ext rfl, + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_castAdd, + _root_.Equiv.trans_apply] + change (finSumFinEquiv (Sum.inl (Fin.natAdd k + ⟨x.val, h1⟩))).val = (finSumFinEquiv (Sum.inl + ((transposeEquiv k s).symm (Fin.castAdd k + ⟨x.val, h1⟩)))).val + rw [finSumFinEquiv_apply_left, finSumFinEquiv_apply_left, + transposeEquiv_symm, + show (Fin.castAdd k ⟨x.val, h1⟩ : Fin (s + k)) = + ⟨x.val, by omega⟩ from Fin.ext rfl, + transposeEquiv_low s k x.val h1 (by omega) (by omega)] + rfl + · rcases Nat.lt_or_ge x.val (s + k) with h2 | h2 + · conv_lhs => rw [show x = Fin.castAdd (t + k) + (Fin.natAdd s ⟨x.val - s, by omega⟩) from Fin.ext (by + change x.val = s + (x.val - s) + omega), + _root_.Equiv.trans_apply, + tensorSwapEquiv_in_right k k s t ⟨x.val - s, by omega⟩, + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_castAdd, + _root_.Equiv.trans_apply] + conv_rhs => rw [show x = Fin.castAdd (t + k) + (Fin.natAdd s ⟨x.val - s, by omega⟩) from Fin.ext (by + change x.val = s + (x.val - s) + omega), + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_castAdd, + _root_.Equiv.trans_apply] + change (finSumFinEquiv (Sum.inl (Fin.castAdd s + ⟨x.val - s, by omega⟩))).val = (finSumFinEquiv (Sum.inl + ((transposeEquiv k s).symm (Fin.natAdd s + ⟨x.val - s, by omega⟩)))).val + rw [finSumFinEquiv_apply_left, finSumFinEquiv_apply_left, + transposeEquiv_symm, + show (Fin.natAdd s ⟨x.val - s, by omega⟩ : + Fin (s + k)) = ⟨s + (x.val - s), by omega⟩ from + Fin.ext rfl, + transposeEquiv_high s k (x.val - s) (by omega) + (by omega) (by omega)] + rfl + · rcases Nat.lt_or_ge x.val ((s + k) + t) with h3 | h3 + · conv_lhs => rw [show x = Fin.natAdd (s + k) + (Fin.castAdd k ⟨x.val - (s + k), by omega⟩) from + Fin.ext (by + change x.val = (s + k) + (x.val - (s + k)) + omega), + _root_.Equiv.trans_apply, + tensorSwapEquiv_out_left k k s t + ⟨x.val - (s + k), by omega⟩, + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_natAdd, + _root_.Equiv.trans_apply] + conv_rhs => rw [show x = Fin.natAdd (s + k) + (Fin.castAdd k ⟨x.val - (s + k), by omega⟩) from + Fin.ext (by + change x.val = (s + k) + (x.val - (s + k)) + omega), + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_natAdd, + _root_.Equiv.trans_apply] + change (finSumFinEquiv (Sum.inr ((transposeEquiv k t) + (Fin.natAdd k ⟨x.val - (s + k), by omega⟩)))).val = + (finSumFinEquiv (Sum.inr (Fin.castAdd k + ⟨x.val - (s + k), by omega⟩))).val + rw [finSumFinEquiv_apply_right, + finSumFinEquiv_apply_right, + show (Fin.natAdd k ⟨x.val - (s + k), by omega⟩ : + Fin (k + t)) = ⟨k + (x.val - (s + k)), by omega⟩ + from Fin.ext rfl, + transposeEquiv_high k t (x.val - (s + k)) (by omega) + (by omega) (by omega)] + rfl + · conv_lhs => rw [show x = Fin.natAdd (s + k) + (Fin.natAdd t ⟨x.val - ((s + k) + t), by omega⟩) + from Fin.ext (by + change x.val = (s + k) + (t + (x.val - ((s + k) + t))) + omega), + _root_.Equiv.trans_apply, + tensorSwapEquiv_out_right k k s t + ⟨x.val - ((s + k) + t), by omega⟩, + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_natAdd, + _root_.Equiv.trans_apply] + conv_rhs => rw [show x = Fin.natAdd (s + k) + (Fin.natAdd t ⟨x.val - ((s + k) + t), by omega⟩) + from Fin.ext (by + change x.val = (s + k) + (t + (x.val - ((s + k) + t))) + omega), + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_natAdd, + _root_.Equiv.trans_apply] + change (finSumFinEquiv (Sum.inr ((transposeEquiv k t) + (Fin.castAdd t + ⟨x.val - ((s + k) + t), by omega⟩)))).val = + (finSumFinEquiv (Sum.inr (Fin.natAdd t + ⟨x.val - ((s + k) + t), by omega⟩))).val + rw [finSumFinEquiv_apply_right, + finSumFinEquiv_apply_right, + show (Fin.castAdd t + ⟨x.val - ((s + k) + t), by omega⟩ : + Fin (k + t)) = ⟨x.val - ((s + k) + t), by omega⟩ + from Fin.ext rfl, + transposeEquiv_low k t (x.val - ((s + k) + t)) + (by omega) (by omega) (by omega)] + rfl + +/-- The right braiding-naturality square, fragment level. -/ +noncomputable def braidNatRightFrag {s t : ℕ} (k : ℕ) + (F : Fragment (Fin (s + t))) : + ((tensorFragment (strandBundle k) F).compose + (bundleMap (transposeEquiv k t))).Equiv + ((bundleMap (transposeEquiv k s)).compose + (tensorFragment F (strandBundle k))) := by + refine (composeBundleMap _ _).trans ?_ + refine (Fragment.Equiv.relabelCongr + (tensorFragmentComm (strandBundle k) F) _).trans ?_ + refine (Fragment.Equiv.relabelTrans _ _ _).trans ?_ + refine Fragment.Equiv.trans ?_ (bundleMapCompose _ _).symm + exact Fragment.Equiv.relabelEq _ (braidNatRight_label s t k) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleClose.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleClose.lean new file mode 100644 index 0000000000..e33a2855af --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleClose.lean @@ -0,0 +1,589 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarPrep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLawRight + +/-! +# The bundle closure is the straight-matching self-glue + +The full closure of an `(m + m)`-fragment against the strand +bundle is the self-glue of its straight matching `i ↔ m + i`. +The proof fuses and splits folds using only established +machinery: the closure's interface fold splits into the +high-block glues followed by the low-block glues +(`interfacePairs_split` and `glueListAppend`); the high-block +stage is itself a composition against the transposed bundle +(`composeNormal` read backwards), which the right identity law +collapses to the fragment; and the lifted low-block pairs are +then exactly the straight matching. +-/ + +@[expose] public section + +namespace RS + +section BundleClose + +variable (m : ℕ) + +/-! ### Flat membership of the two blocks -/ + +/-- The high block's flags are exactly the labels at or above `m` +on either side. -/ +theorem mem_highCross_flat + (z : Fin (0 + (m + m)) ⊕ Fin ((m + m) + 0)) : + z ∈ (highCross m).flatMap (fun p => [p.1, p.2]) ↔ + (∃ a, z = Sum.inl a ∧ m ≤ a.val) ∨ + (∃ b, z = Sum.inr b ∧ m ≤ b.val) := by + unfold highCross + rw [List.flatMap_map] + simp only [List.mem_flatMap, List.mem_reverse, List.mem_finRange, + List.mem_cons, List.not_mem_nil, or_false, true_and] + constructor + · rintro ⟨k, hk | hk⟩ + · exact Or.inl ⟨_, hk, by simp⟩ + · exact Or.inr ⟨_, hk, by simp⟩ + · rintro (⟨a, rfl, ha⟩ | ⟨b, rfl, hb⟩) + · refine ⟨⟨a.val - m, by have := a.isLt; omega⟩, Or.inl ?_⟩ + refine congrArg Sum.inl (Fin.ext ?_) + change a.val = m + (a.val - m) + omega + · refine ⟨⟨b.val - m, by have := b.isLt; omega⟩, Or.inr ?_⟩ + refine congrArg Sum.inr (Fin.ext ?_) + change b.val = m + (b.val - m) + omega + +/-- The high block is a well-formed gluing list. -/ +theorem highCross_wf : Fragment.PairsWF (highCross m) := + (interfacePairs_split m ▸ + interfacePairs_wf 0 (m + m) 0).append_left + +/-- And so is the whole closure list, high block then low. -/ +theorem splitCross_wf : + Fragment.PairsWF (highCross m ++ lowCross m) := + interfacePairs_split m ▸ interfacePairs_wf 0 (m + m) 0 + +/-! ### The surviving labels of the high-block stage -/ + +/-- The forward survivor map: low labels to the surviving left +slots, high labels to the surviving right slots. -/ +noncomputable def bcPhiFun (x : Fin (m + m)) : + Fragment.FoldSurviving + (Fin (0 + (m + m)) ⊕ Fin ((m + m) + 0)) (highCross m) := + if h : x.val < m then + ⟨Sum.inl ⟨x.val, by omega⟩, + (forall_ne_iff_not_mem_flat _ _).mpr (by + rw [mem_highCross_flat] + rintro (⟨a, ha, hm⟩ | ⟨b, hb, _⟩) + · rw [show a = ⟨x.val, by omega⟩ from + (Sum.inl.inj ha).symm] at hm + exact absurd hm (by simpa using h) + · exact Sum.inl_ne_inr hb)⟩ + else + ⟨Sum.inr ⟨x.val - m, by have := x.isLt; omega⟩, + (forall_ne_iff_not_mem_flat _ _).mpr (by + rw [mem_highCross_flat] + rintro (⟨a, ha, _⟩ | ⟨b, hb, hm⟩) + · exact Sum.inr_ne_inl ha + · rw [show b = ⟨x.val - m, by have := x.isLt; omega⟩ from + (Sum.inr.inj hb).symm] at hm + have := x.isLt + simp only [] at hm + omega)⟩ + +/-- The inverse survivor map. -/ +noncomputable def bcPhiInv + (s : Fragment.FoldSurviving + (Fin (0 + (m + m)) ⊕ Fin ((m + m) + 0)) (highCross m)) : + Fin (m + m) := + match hs : s.val with + | Sum.inl a => ⟨a.val, by + have hnot := (forall_ne_iff_not_mem_flat _ _).mp s.prop + by_contra hge + exact hnot ((mem_highCross_flat m s.val).mpr + (Or.inl ⟨a, hs, by omega⟩))⟩ + | Sum.inr b => ⟨m + b.val, by + have hnot := (forall_ne_iff_not_mem_flat _ _).mp s.prop + have hb : b.val < m := by + by_contra hge + exact hnot ((mem_highCross_flat m s.val).mpr + (Or.inr ⟨b, hs, by omega⟩)) + omega⟩ + +/-- The survivor identification of the high-block stage. -/ +noncomputable def bcPhi : Fin (m + m) ≃ + Fragment.FoldSurviving + (Fin (0 + (m + m)) ⊕ Fin ((m + m) + 0)) (highCross m) where + toFun := bcPhiFun m + invFun := bcPhiInv m + left_inv x := by + by_cases h : x.val < m + · have h1 : bcPhiFun m x = ⟨Sum.inl ⟨x.val, by omega⟩, _⟩ := + dite_eq_left h + rw [h1] + change (⟨x.val, _⟩ : Fin (m + m)) = x + exact Fin.ext rfl + · have h1 : bcPhiFun m x = + ⟨Sum.inr ⟨x.val - m, by have := x.isLt; omega⟩, _⟩ := + dite_eq_right h + rw [h1] + change (⟨m + (x.val - m), _⟩ : Fin (m + m)) = x + exact Fin.ext (show m + (x.val - m) = x.val by omega) + right_inv s := by + obtain ⟨sv, hp⟩ := s + rcases sv with a | b + · have ha : a.val < m := by + have hnot := (forall_ne_iff_not_mem_flat _ _).mp hp + by_contra hge + exact hnot ((mem_highCross_flat m _).mpr + (Or.inl ⟨a, rfl, by omega⟩)) + change bcPhiFun m ⟨a.val, by omega⟩ = _ + have h1 : bcPhiFun m ⟨a.val, by omega⟩ = + ⟨Sum.inl ⟨a.val, by omega⟩, _⟩ := dite_eq_left ha + rw [h1] + · have hb : b.val < m := by + have hnot := (forall_ne_iff_not_mem_flat _ _).mp hp + by_contra hge + exact hnot ((mem_highCross_flat m _).mpr + (Or.inr ⟨b, rfl, by omega⟩)) + change bcPhiFun m ⟨m + b.val, by omega⟩ = _ + have h1 : bcPhiFun m ⟨m + b.val, by omega⟩ = + ⟨Sum.inr ⟨m + b.val - m, by omega⟩, _⟩ := + dite_eq_right (show ¬ m + b.val < m by omega) + rw [h1] + exact Subtype.ext (congrArg Sum.inr (Fin.ext (by + change m + b.val - m = b.val + omega))) + +/-! ### The ambient relabelling -/ + +/-- From the `(m,m,m)`-interface ambient to the full-closure +ambient: a cast on the left factor, the block transpose threaded +through a cast on the right. -/ +noncomputable def bcDelta : + (Fin (m + m) ⊕ Fin (m + m)) ≃ + (Fin (0 + (m + m)) ⊕ Fin ((m + m) + 0)) := + _root_.Equiv.sumCongr + (finCongr (by omega : m + m = 0 + (m + m))) + ((transposeEquiv m m).symm.trans + (finCongr (by omega : m + m = (m + m) + 0))) + +/-- The mapped `(m,m,m)`-interface pairs are the high-block +pairs. -/ +theorem mapPairs_bcDelta : + Fragment.mapPairs (bcDelta m) (interfacePairs m m m) = + highCross m := by + apply List.ext_getElem + · simp [Fragment.mapPairs, interfacePairs, highCross] + intro i hi hi' + have him : i < m := by + have h0 : (Fragment.mapPairs (bcDelta m) + (interfacePairs m m m)).length = m := by + simp [Fragment.mapPairs, interfacePairs] + omega + have hip : i < (interfacePairs m m m).length := by + simp only [interfacePairs, List.length_map, + List.length_reverse, List.length_finRange] + omega + rw [mapPairs_getElem (bcDelta m) _ i hi hip] + have hI : (interfacePairs m m m)[i]'hip = + (Sum.inl ⟨m + (m - 1 - i), by omega⟩, + Sum.inr ⟨m - 1 - i, by omega⟩) := by + simp only [interfacePairs, List.getElem_map, + List.getElem_reverse, List.length_finRange, + List.getElem_finRange] + refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) + (congrArg Sum.inr (Fin.ext ?_)) <;> simp + rw [hI] + have hml : i < (highCross m).length := by + simp only [highCross, List.length_map, List.length_reverse, + List.length_finRange] + omega + have hR : (highCross m)[i]'hml = + (Sum.inl ⟨m + (m - 1 - i), by omega⟩, + Sum.inr ⟨m + (m - 1 - i), by omega⟩) := by + simp only [highCross, List.getElem_map, + List.getElem_reverse, List.length_finRange, + List.getElem_finRange] + refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) + (congrArg Sum.inr (Fin.ext ?_)) <;> simp + rw [hR] + refine Prod.ext (congrArg Sum.inl (Fin.ext rfl)) + (congrArg Sum.inr (Fin.ext ?_)) + rw [_root_.Equiv.trans_apply, + show (transposeEquiv m m).symm = transposeEquiv m m from + transposeEquiv_symm m m, + transposeEquiv_low m m (m - 1 - i) (by omega) (by omega) + (by omega)] + rfl + +/-! ### The high-block stage collapses to the fragment -/ + +/-- The full-closure ambient. -/ +noncomputable def bcAmbient (V : Fragment (Fin (m + m))) : + Fragment (Fin (0 + (m + m)) ⊕ Fin ((m + m) + 0)) := + (V.relabel (finCongr (by omega : m + m = 0 + (m + m)))).disjUnion + ((strandBundle m).relabel + (finCongr (by omega : m + m = (m + m) + 0))) + +/-- The `(m,m,m)`-interface ambient: the fragment against the +transposed bundle. -/ +noncomputable def bcAmbient2 (V : Fragment (Fin (m + m))) : + Fragment (Fin (m + m) ⊕ Fin (m + m)) := + V.disjUnion ((strandBundle m).relabel (transposeEquiv m m)) + +/-- The two ambients agree through the ambient relabelling. -/ +noncomputable def bcAmbientEquiv (V : Fragment (Fin (m + m))) : + (bcAmbient m V).Equiv + ((bcAmbient2 m V).relabel (bcDelta m)) := by + have hB : ((strandBundle m).relabel + (finCongr (by omega : m + m = (m + m) + 0))).Equiv + (((strandBundle m).relabel (transposeEquiv m m)).relabel + ((transposeEquiv m m).symm.trans + (finCongr (by omega : m + m = (m + m) + 0)))) := + ((Fragment.Equiv.relabelTrans (strandBundle m) + (transposeEquiv m m) _).trans + (Fragment.Equiv.relabelEq (strandBundle m) + (_root_.Equiv.ext (fun x => by simp)))).symm + refine (Fragment.Equiv.disjUnionCongr + (Fragment.Equiv.refl _) hB).trans ?_ + refine (Fragment.relabelDisjUnionRight _ _ _).trans ?_ + refine (Fragment.Equiv.relabelCongr + (Fragment.relabelDisjUnionLeft V _ _) _).trans ?_ + refine (Fragment.Equiv.relabelTrans _ _ _).trans ?_ + exact Fragment.Equiv.relabelEq _ + (_root_.Equiv.ext (fun x => by rcases x with x | x <;> rfl)) + +/-- The assembled survivor identification equals the direct +one. -/ +theorem bcPhi_eq : + ((((interfaceSurvEquiv m m m).trans finSumFinEquiv).symm.trans + (Fragment.foldSurvivingMapEquiv (bcDelta m) + (interfacePairs m m m))).trans + (Fragment.foldSurvivingPermEquiv + (List.Perm.of_eq (mapPairs_bcDelta m)))) = bcPhi m := by + refine _root_.Equiv.ext (fun x => Subtype.ext ?_) + by_cases hx : x.val < m + · -- low labels: the surviving left slot + have hz : finSumFinEquiv.symm x = + (Sum.inl ⟨x.val, hx⟩ : Fin m ⊕ Fin m) := by + conv_lhs => rw [show x = Fin.castAdd m ⟨x.val, hx⟩ from + Fin.ext rfl] + exact finSumFinEquiv_symm_apply_castAdd _ + have wpf : ∀ p ∈ interfacePairs m m m, + (Sum.inl ⟨x.val, by omega⟩ : + Fin (m + m) ⊕ Fin (m + m)) ≠ p.1 ∧ + (Sum.inl ⟨x.val, by omega⟩ : + Fin (m + m) ⊕ Fin (m + m)) ≠ p.2 := + (forall_ne_iff_not_mem_flat _ _).mpr (by + rw [mem_interfacePairs_flat] + rintro (⟨a, ha, hm⟩ | ⟨b, hb, _⟩) + · rw [show a = ⟨x.val, by omega⟩ from + (Sum.inl.inj ha).symm] at hm + exact absurd hm (by simpa using hx) + · exact Sum.inl_ne_inr hb) + have hw : interfaceSurvEquiv m m m + ⟨Sum.inl ⟨x.val, by omega⟩, wpf⟩ = + (Sum.inl ⟨x.val, hx⟩ : Fin m ⊕ Fin m) := + interfaceSurvEquiv_inl m m m _ _ rfl hx + have hy : (((interfaceSurvEquiv m m m).trans + finSumFinEquiv).symm x) = + ⟨Sum.inl ⟨x.val, by omega⟩, wpf⟩ := by + change (interfaceSurvEquiv m m m).symm + (finSumFinEquiv.symm x) = _ + rw [hz] + exact (_root_.Equiv.symm_apply_eq _).mpr hw.symm + have hval := congrArg Subtype.val hy + have hbc : (bcPhiFun m x).val = + Sum.inl ⟨x.val, by omega⟩ := + congrArg Subtype.val (dite_eq_left hx) + change bcDelta m ((((interfaceSurvEquiv m m m).trans + finSumFinEquiv).symm x)).val = (bcPhiFun m x).val + rw [hval, hbc] + exact congrArg Sum.inl (Fin.ext rfl) + · -- high labels: the surviving right slot + have hz : finSumFinEquiv.symm x = + (Sum.inr ⟨x.val - m, by have := x.isLt; omega⟩ : + Fin m ⊕ Fin m) := by + conv_lhs => rw [show x = Fin.natAdd m + ⟨x.val - m, by have := x.isLt; omega⟩ from + Fin.ext (by change x.val = m + (x.val - m); omega)] + exact finSumFinEquiv_symm_apply_natAdd _ + have wpf : ∀ p ∈ interfacePairs m m m, + (Sum.inr ⟨x.val, x.isLt⟩ : + Fin (m + m) ⊕ Fin (m + m)) ≠ p.1 ∧ + (Sum.inr ⟨x.val, x.isLt⟩ : + Fin (m + m) ⊕ Fin (m + m)) ≠ p.2 := + (forall_ne_iff_not_mem_flat _ _).mpr (by + rw [mem_interfacePairs_flat] + rintro (⟨a, ha, _⟩ | ⟨b, hb, hm⟩) + · exact Sum.inr_ne_inl ha + · rw [show b = ⟨x.val, x.isLt⟩ from + (Sum.inr.inj hb).symm] at hm + simp only [] at hm + omega) + have hw : interfaceSurvEquiv m m m + ⟨Sum.inr ⟨x.val, x.isLt⟩, wpf⟩ = + (Sum.inr ⟨x.val - m, by have := x.isLt; omega⟩ : + Fin m ⊕ Fin m) := + interfaceSurvEquiv_inr m m m _ _ rfl (by omega) + have hy : (((interfaceSurvEquiv m m m).trans + finSumFinEquiv).symm x) = + ⟨Sum.inr ⟨x.val, x.isLt⟩, wpf⟩ := by + change (interfaceSurvEquiv m m m).symm + (finSumFinEquiv.symm x) = _ + rw [hz] + exact (_root_.Equiv.symm_apply_eq _).mpr hw.symm + have hval := congrArg Subtype.val hy + have hbc : (bcPhiFun m x).val = + Sum.inr ⟨x.val - m, by have := x.isLt; omega⟩ := + congrArg Subtype.val (dite_eq_right hx) + change bcDelta m ((((interfaceSurvEquiv m m m).trans + finSumFinEquiv).symm x)).val = (bcPhiFun m x).val + rw [hval, hbc] + refine congrArg Sum.inr (Fin.ext ?_) + change ((transposeEquiv m m).symm.trans + (finCongr (by omega : m + m = (m + m) + 0)) + ⟨x.val, x.isLt⟩).val = x.val - m + rw [_root_.Equiv.trans_apply, + show (transposeEquiv m m).symm = transposeEquiv m m from + transposeEquiv_symm m m, + show (⟨x.val, x.isLt⟩ : Fin (m + m)) = + ⟨m + (x.val - m), by have := x.isLt; omega⟩ from + Fin.ext (by change x.val = m + (x.val - m); omega), + transposeEquiv_high m m (x.val - m) + (by have := x.isLt; omega) (by have := x.isLt; omega) + (by have := x.isLt; omega)] + rfl + +/-- **The high-block stage**: gluing the high-block pairs in the +closure ambient is the identity composition against the bundle, +hence the fragment itself. -/ +noncomputable def bcStageA (V : Fragment (Fin (m + m))) : + (Fragment.glueList (bcAmbient m V) (highCross m) + (highCross_wf m)).Equiv (V.relabel (bcPhi m)) := by + have C1 := Fragment.glueListCongr (bcAmbientEquiv m V) + (highCross m) (highCross_wf m) + have C2 := Fragment.glueListEqEquiv + ((bcAmbient2 m V).relabel (bcDelta m)) + (mapPairs_bcDelta m) + (Fragment.mapPairs_wf (bcDelta m) _ + (interfacePairs_wf m m m)) + (highCross_wf m) + (List.Perm.of_eq (mapPairs_bcDelta m)) + have C3 := Fragment.glueListRelabel (bcAmbient2 m V) + (bcDelta m) (interfacePairs m m m) + (interfacePairs_wf m m m) + have C4 := Fragment.Equiv.relabelFlip + (composeNormal V + ((strandBundle m).relabel (transposeEquiv m m))) + have C5 := Fragment.composeCongr (Fragment.Equiv.refl V) + (strandBundleTranspose m) + have C6 := composeStrandBundleRight m m V + have D1 := C4.trans + (Fragment.Equiv.relabelCongr (C5.trans C6) _) + have D2 := C3.trans + ((Fragment.Equiv.relabelCongr D1 _).trans + (Fragment.Equiv.relabelTrans V _ _)) + have D3 := C2.symm.trans + ((Fragment.Equiv.relabelCongr D2 _).trans + (Fragment.Equiv.relabelTrans V _ _)) + exact C1.trans (D3.trans + (Fragment.Equiv.relabelEq V (bcPhi_eq m))) + +/-! ### The lifted low-block pairs are the straight matching -/ + +/-- Lifting a pair list past an earlier fold keeps its length. -/ +theorem liftPairs_length {α : Type} (ps : List (α × α)) : + ∀ (qs : List (α × α)) (h : Fragment.PairsSepAll ps qs), + (Fragment.liftPairs ps qs h).length = qs.length + | [], _ => rfl + | _ :: qs, _ => congrArg Nat.succ (liftPairs_length ps qs _) + +/-- And keeps each pair's underlying labels. -/ +theorem liftPairs_getElem_val {α : Type} (ps : List (α × α)) : + ∀ (qs : List (α × α)) (h : Fragment.PairsSepAll ps qs) (j : ℕ) + (hj : j < (Fragment.liftPairs ps qs h).length) + (hj' : j < qs.length), + ((Fragment.liftPairs ps qs h)[j]'hj).1.val = + (qs[j]'hj').1 ∧ + ((Fragment.liftPairs ps qs h)[j]'hj).2.val = + (qs[j]'hj').2 + | [], _, j, _, hj' => absurd hj' (by simp) + | _ :: _, _, 0, _, _ => ⟨rfl, rfl⟩ + | _ :: qs, h, j + 1, hj, hj' => + liftPairs_getElem_val ps qs _ j + (by simpa [Fragment.liftPairs] using hj) + (by simpa using hj') + +/-- The inverse survivor identification on left values. -/ +theorem bcPhi_symm_val_inl + (s : Fragment.FoldSurviving + (Fin (0 + (m + m)) ⊕ Fin ((m + m) + 0)) (highCross m)) + (a : Fin (0 + (m + m))) (hs : s.val = Sum.inl a) : + (bcPhi m).symm s = ⟨a.val, by have := a.isLt; omega⟩ := by + obtain ⟨sv, hp⟩ := s + subst hs + exact Fin.ext rfl + +/-- The inverse survivor identification on right values. -/ +theorem bcPhi_symm_val_inr + (s : Fragment.FoldSurviving + (Fin (0 + (m + m)) ⊕ Fin ((m + m) + 0)) (highCross m)) + (b : Fin ((m + m) + 0)) (hs : s.val = Sum.inr b) + (hb : b.val < m) : + (bcPhi m).symm s = ⟨m + b.val, by omega⟩ := by + obtain ⟨sv, hp⟩ := s + subst hs + exact Fin.ext rfl + +/-- Read through the high stage's survivor identification, the +lifted low block is the straight matching reversed. -/ +theorem mapPairs_bcPhi_lift : + Fragment.mapPairs (bcPhi m).symm + (Fragment.liftPairs (highCross m) (lowCross m) + ((splitCross_wf m).append_sep)) = + (matchPairs m).reverse := by + have hlcl : (lowCross m).length = m := by + simp only [lowCross, List.length_map, List.length_reverse, + List.length_finRange] + apply List.ext_getElem + · rw [mapPairs_length, liftPairs_length, List.length_reverse, + matchPairs_length, hlcl] + intro j hj hj' + have hjm : j < m := by + rw [List.length_reverse, matchPairs_length] at hj' + exact hj' + have hjl : j < (lowCross m).length := by omega + have hlift : j < (Fragment.liftPairs (highCross m) + (lowCross m) ((splitCross_wf m).append_sep)).length := by + rw [liftPairs_length] + omega + rw [mapPairs_getElem _ _ j hj hlift] + obtain ⟨h1, h2⟩ := liftPairs_getElem_val (highCross m) + (lowCross m) ((splitCross_wf m).append_sep) j hlift hjl + have hlow : (lowCross m)[j]'hjl = + (Sum.inl ⟨m - 1 - j, by omega⟩, + Sum.inr ⟨m - 1 - j, by omega⟩) := by + simp only [lowCross, List.getElem_map, + List.getElem_reverse, List.length_finRange, + List.getElem_finRange] + refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) + (congrArg Sum.inr (Fin.ext ?_)) <;> simp + have hmrev : (matchPairs m).reverse = + (List.finRange m).reverse.map + (fun k => (Fin.castAdd m k, Fin.natAdd m k)) := by + unfold matchPairs + exact List.map_reverse.symm + have hrev : ((matchPairs m).reverse)[j]'hj' = + (Fin.castAdd m ⟨m - 1 - j, by omega⟩, + Fin.natAdd m ⟨m - 1 - j, by omega⟩) := by + rw [List.getElem_of_eq hmrev] + simp only [List.getElem_map, List.getElem_reverse, + List.length_finRange, List.getElem_finRange] + refine Prod.ext (Fin.ext ?_) (Fin.ext ?_) <;> simp + rw [hrev] + have hs1 := bcPhi_symm_val_inl m _ ⟨m - 1 - j, by omega⟩ + (h1.trans (congrArg Prod.fst hlow)) + have hs2 := bcPhi_symm_val_inr m _ ⟨m - 1 - j, by omega⟩ + (h2.trans (congrArg Prod.snd hlow)) (by + change m - 1 - j < m + omega) + rw [hs1, hs2] + exact Prod.ext (Fin.ext rfl) (Fin.ext rfl) + +/-- Equivalently, the lifted low block is the transported straight +matching — the identification the closure theorem runs on. -/ +theorem lift_eq_mapPairs : + Fragment.liftPairs (highCross m) (lowCross m) + ((splitCross_wf m).append_sep) = + Fragment.mapPairs (bcPhi m) ((matchPairs m).reverse) := by + have h := congrArg (Fragment.mapPairs (bcPhi m)) + (mapPairs_bcPhi_lift m) + rw [mapPairs_symm_cancel (bcPhi m)] at h + exact h + +attribute [instance] matchPairs_surv_isEmpty + +-- The closure is matched with the self-glue along +-- the straight matching, which unfolds the glue list. +/-- **The bundle closure is the straight-matching self-glue**: +the full closure of an `(m + m)`-fragment against the strand +bundle is the self-glue of its straight matching. -/ +noncomputable def pairCloseStrandBundle + (V : Fragment (Fin (m + m))) : + (pairClose V (strandBundle m)).Equiv + ((Fragment.glueList V (matchPairs m) + (matchPairs_wf m)).relabel + (_root_.Equiv.equivOfIsEmpty _ _)) := by + change ((V.relabel + (finCongr (by omega : m + m = 0 + (m + m)))).compose + ((strandBundle m).relabel + (finCongr (by omega : m + m = (m + m) + 0)))).Equiv _ + have wfRev : Fragment.PairsWF ((matchPairs m).reverse) := + (matchPairs_wf m).perm (List.reverse_perm (matchPairs m)).symm + have F1 := Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (bcAmbient m V) + (interfacePairs_split m) + (interfacePairs_wf 0 (m + m) 0) (splitCross_wf m) + (List.Perm.of_eq (interfacePairs_split m))) + have F2 := Fragment.glueListAppend (bcAmbient m V) + (highCross m) (lowCross m) (splitCross_wf m) + have F3 := Fragment.glueListCongr (bcStageA m V) + (Fragment.liftPairs (highCross m) (lowCross m) + ((splitCross_wf m).append_sep)) + (Fragment.liftPairs_wf (highCross m) (lowCross m) + (splitCross_wf m).append_right + (splitCross_wf m).append_sep) + have F4 := Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (V.relabel (bcPhi m)) + (lift_eq_mapPairs m) + (Fragment.liftPairs_wf (highCross m) (lowCross m) + (splitCross_wf m).append_right + (splitCross_wf m).append_sep) + (Fragment.mapPairs_wf (bcPhi m) _ wfRev) + (List.Perm.of_eq (lift_eq_mapPairs m))) + have F5 := Fragment.glueListRelabel V (bcPhi m) + ((matchPairs m).reverse) wfRev + have F6 := Fragment.glueListPerm V + (List.reverse_perm (matchPairs m)) wfRev + -- the low-stage chain, from the appended base to the matching + have G1 := F3.trans (F4.trans + (Fragment.Equiv.relabelCongr + (F5.trans (Fragment.Equiv.relabelCongr + (F6.trans (Fragment.Equiv.relabelCongr + (Fragment.glueListProofIrrel V (matchPairs m) _ + (matchPairs_wf m)) _)) _)) _)) + -- fold the whole tower and collapse the empty relabels + refine (composeNormal _ _).trans ?_ + refine (Fragment.Equiv.relabelCongr + (F1.trans (Fragment.Equiv.relabelCongr + (F2.trans (Fragment.Equiv.relabelCongr G1 _)) _)) _).trans + ?_ + -- now everything is nested relabels of the matching self-glue; + -- merge the six layers innermost-first, then collapse over the + -- empty survivor type + refine (Fragment.Equiv.relabelCongr (Fragment.Equiv.relabelCongr + (Fragment.Equiv.relabelCongr (Fragment.Equiv.relabelCongr + (Fragment.Equiv.relabelTrans _ _ _) _) _) _) _).trans ?_ + refine (Fragment.Equiv.relabelCongr (Fragment.Equiv.relabelCongr + (Fragment.Equiv.relabelCongr + (Fragment.Equiv.relabelTrans _ _ _) _) _) _).trans ?_ + refine (Fragment.Equiv.relabelCongr (Fragment.Equiv.relabelCongr + (Fragment.Equiv.relabelTrans _ _ _) _) _).trans ?_ + refine (Fragment.Equiv.relabelCongr + (Fragment.Equiv.relabelTrans _ _ _) _).trans ?_ + refine (Fragment.Equiv.relabelTrans _ _ _).trans ?_ + exact Fragment.Equiv.relabelEq _ + (_root_.Equiv.ext (fun s => + ((matchPairs_surv_isEmpty m).false s).elim)) + +end BundleClose + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleMapClasses.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleMapClasses.lean new file mode 100644 index 0000000000..b0ce5edf6c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleMapClasses.lean @@ -0,0 +1,342 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleTensor +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeRelabel + +/-! +# The bundle-map calculus + +The strand bundle implementing an arbitrary label equivalence +`e : Fin n ≃ Fin m`: strand `k` runs from input `k` to output +`e k`. These fragments and their Hom classes provide all the +structural morphisms of the monoidal skein category — associators +and unitors (`e` a cast) and the braiding (`e` a block +transpose) — and satisfy a single composition law: composing the +bundle maps of `e₁` and `e₂` is the bundle map of `e₁.trans e₂`. +The proof forces the arities equal (a `Fin`-equivalence fixes the +cardinality), after which everything is permutation-fragment +algebra. Every coherence diagram of the monoidal assembly +collapses through this law into an equality of label +equivalences. +-/ + +@[expose] public section + +namespace RS + +/-- The outgoing label map of a bundle: fix the inputs, apply `e` +to the outputs. -/ +def outMapEquiv {n m : ℕ} (e : Fin n ≃ Fin m) : + Fin (n + n) ≃ Fin (n + m) := + finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin n)) e).trans + finSumFinEquiv) + +/-- The bundle map of a label equivalence: strand `k` joins input +`k` to output `e k`. -/ +noncomputable def bundleMap {n m : ℕ} (e : Fin n ≃ Fin m) : + Fragment (Fin (n + m)) := + (strandBundle n).relabel (outMapEquiv e) + +/-- The bundle map of the identity is the strand bundle. -/ +noncomputable def bundleMapRefl (n : ℕ) : + (bundleMap (_root_.Equiv.refl (Fin n))).Equiv + (strandBundle n) := + (Fragment.Equiv.relabelEq (strandBundle n) + (_root_.Equiv.ext (fun x => by + change finSumFinEquiv + ((_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin n)) + (_root_.Equiv.refl (Fin n))) (finSumFinEquiv.symm x)) = + x + rw [show (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin n)) + (_root_.Equiv.refl (Fin n))) = + _root_.Equiv.refl (Fin n ⊕ Fin n) from + _root_.Equiv.ext (fun y => by + rcases y with y | y <;> rfl)] + exact finSumFinEquiv.apply_symm_apply x))).trans + (Fragment.Equiv.relabelRefl (strandBundle n)) + +/-- **The composition law of bundle maps.** -/ +noncomputable def bundleMapComp {n m p : ℕ} + (e₁ : Fin n ≃ Fin m) (e₂ : Fin m ≃ Fin p) : + ((bundleMap e₁).compose (bundleMap e₂)).Equiv + (bundleMap (e₁.trans e₂)) := by + have hnm : n = m := by + have h := Fintype.card_congr e₁ + simpa using h + subst hnm + have hnp : n = p := by + have h := Fintype.card_congr e₂ + simpa using h + subst hnp + refine Fragment.Equiv.trans + (Fragment.composeCongr + (permFragmentRelabelOutPerm e₁).symm + (permFragmentRelabelOutPerm e₂).symm) ?_ + refine (permFragmentCompose e₁ e₂).trans ?_ + exact (permFragmentRelabelOutPerm (e₂ * e₁)).trans + (Fragment.Equiv.relabelEq _ + (_root_.Equiv.ext (fun x => rfl))) + +/-- Tensoring relabelled fragments is relabelling the tensor by +the interleave-conjugated sum. -/ +noncomputable def tensorFragmentRelabel + {s t u v s' t' u' v' : ℕ} + (X : Fragment (Fin (s + t))) (z : Fragment (Fin (u + v))) + (r₁ : Fin (s + t) ≃ Fin (s' + t')) + (r₂ : Fin (u + v) ≃ Fin (u' + v')) : + (tensorFragment (X.relabel r₁) (z.relabel r₂)).Equiv + ((tensorFragment X z).relabel + ((interleaveEquiv s t u v).symm.trans + ((_root_.Equiv.sumCongr r₁ r₂).trans + (interleaveEquiv s' t' u' v')))) := by + change (((X.relabel r₁).disjUnion (z.relabel r₂)).relabel + (interleaveEquiv s' t' u' v')).Equiv _ + refine (Fragment.Equiv.relabelCongr + ((Fragment.relabelDisjUnionLeft X (z.relabel r₂) r₁).trans + ((Fragment.Equiv.relabelCongr + (Fragment.relabelDisjUnionRight X z r₂) _).trans + (Fragment.Equiv.relabelTrans _ _ _))) _).trans ?_ + refine (Fragment.Equiv.relabelTrans _ _ _).trans ?_ + change ((X.disjUnion z).relabel _).Equiv + (((X.disjUnion z).relabel (interleaveEquiv s t u v)).relabel _) + refine Fragment.Equiv.trans ?_ + (Fragment.Equiv.relabelTrans _ _ _).symm + exact Fragment.Equiv.relabelEq _ + (_root_.Equiv.ext (fun x => by + simp only [_root_.Equiv.trans_apply, + _root_.Equiv.symm_apply_apply] + rcases x with x | x <;> rfl)) + +/-- The outgoing map fixes input slots. -/ +theorem outMapEquiv_castAdd {n m : ℕ} (e : Fin n ≃ Fin m) + (i : Fin n) : + outMapEquiv e (Fin.castAdd n i) = Fin.castAdd m i := by + unfold outMapEquiv + rw [_root_.Equiv.trans_apply, finSumFinEquiv_symm_apply_castAdd] + exact finSumFinEquiv_apply_left i + +/-- The outgoing map acts on output slots. -/ +theorem outMapEquiv_natAdd {n m : ℕ} (e : Fin n ≃ Fin m) + (k : Fin n) : + outMapEquiv e (Fin.natAdd n k) = Fin.natAdd n (e k) := by + unfold outMapEquiv + rw [_root_.Equiv.trans_apply, finSumFinEquiv_symm_apply_natAdd] + exact finSumFinEquiv_apply_right (e k) + +/-- The sum of two label equivalences, on concatenated blocks. -/ +def tensorMapEquiv {n₁ m₁ n₂ m₂ : ℕ} + (e₁ : Fin n₁ ≃ Fin m₁) (e₂ : Fin n₂ ≃ Fin m₂) : + Fin (n₁ + n₂) ≃ Fin (m₁ + m₂) := + finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr e₁ e₂).trans finSumFinEquiv) + +/-- The tensor of two label equivalences on a left label. -/ +theorem tensorMapEquiv_castAdd {n₁ m₁ n₂ m₂ : ℕ} + (e₁ : Fin n₁ ≃ Fin m₁) (e₂ : Fin n₂ ≃ Fin m₂) (i : Fin n₁) : + tensorMapEquiv e₁ e₂ (Fin.castAdd n₂ i) = + Fin.castAdd m₂ (e₁ i) := by + unfold tensorMapEquiv + rw [_root_.Equiv.trans_apply, finSumFinEquiv_symm_apply_castAdd] + exact finSumFinEquiv_apply_left (e₁ i) + +/-- And on a right label. -/ +theorem tensorMapEquiv_natAdd {n₁ m₁ n₂ m₂ : ℕ} + (e₁ : Fin n₁ ≃ Fin m₁) (e₂ : Fin n₂ ≃ Fin m₂) (j : Fin n₂) : + tensorMapEquiv e₁ e₂ (Fin.natAdd n₁ j) = + Fin.natAdd m₁ (e₂ j) := by + unfold tensorMapEquiv + rw [_root_.Equiv.trans_apply, finSumFinEquiv_symm_apply_natAdd] + exact finSumFinEquiv_apply_right (e₂ j) + +/-- **The tensor law of bundle maps**: the tensor of two bundle +maps is the bundle map of the block sum. -/ +noncomputable def bundleMapTensor {n₁ m₁ n₂ m₂ : ℕ} + (e₁ : Fin n₁ ≃ Fin m₁) (e₂ : Fin n₂ ≃ Fin m₂) : + (tensorFragment (bundleMap e₁) (bundleMap e₂)).Equiv + (bundleMap (tensorMapEquiv e₁ e₂)) := by + refine (tensorFragmentRelabel (strandBundle n₁) + (strandBundle n₂) (outMapEquiv e₁) (outMapEquiv e₂)).trans + ?_ + refine (Fragment.Equiv.relabelCongr + (strandBundleTensor n₁ n₂).symm _).trans ?_ + refine Fragment.Equiv.relabelEq _ (_root_.Equiv.ext (fun x => ?_)) + rcases Nat.lt_or_ge x.val (n₁ + n₂) with hx | hx + · rcases Nat.lt_or_ge x.val n₁ with hx1 | hx1 + · rw [show x = Fin.castAdd (n₁ + n₂) + (Fin.castAdd n₂ ⟨x.val, hx1⟩) from Fin.ext rfl, + _root_.Equiv.trans_apply, + interleaveEquiv_symm_low_left n₁ n₁ n₂ n₂ ⟨x.val, hx1⟩, + _root_.Equiv.trans_apply, _root_.Equiv.sumCongr_apply, + Sum.map_inl, outMapEquiv_castAdd e₁, + interleaveEquiv_inl_low n₁ m₁ n₂ m₂ ⟨x.val, hx1⟩, + outMapEquiv_castAdd (tensorMapEquiv e₁ e₂)] + · rw [show x = Fin.castAdd (n₁ + n₂) + (Fin.natAdd n₁ ⟨x.val - n₁, by omega⟩) from + Fin.ext (by change x.val = n₁ + (x.val - n₁); omega), + _root_.Equiv.trans_apply, + interleaveEquiv_symm_low_right n₁ n₁ n₂ n₂ + ⟨x.val - n₁, by omega⟩, + _root_.Equiv.trans_apply, _root_.Equiv.sumCongr_apply, + Sum.map_inr, outMapEquiv_castAdd e₂, + interleaveEquiv_inr_low n₁ m₁ n₂ m₂ + ⟨x.val - n₁, by omega⟩, + outMapEquiv_castAdd (tensorMapEquiv e₁ e₂)] + · rcases Nat.lt_or_ge (x.val - (n₁ + n₂)) n₁ with hx1 | hx1 + · rw [show x = Fin.natAdd (n₁ + n₂) + (Fin.castAdd n₂ ⟨x.val - (n₁ + n₂), hx1⟩) from + Fin.ext (by + change x.val = (n₁ + n₂) + (x.val - (n₁ + n₂)) + omega), + _root_.Equiv.trans_apply, + interleaveEquiv_symm_high_left n₁ n₁ n₂ n₂ + ⟨x.val - (n₁ + n₂), hx1⟩, + _root_.Equiv.trans_apply, _root_.Equiv.sumCongr_apply, + Sum.map_inl, outMapEquiv_natAdd e₁, + interleaveEquiv_inl_high n₁ m₁ n₂ m₂ + (e₁ ⟨x.val - (n₁ + n₂), hx1⟩), + outMapEquiv_natAdd (tensorMapEquiv e₁ e₂), + tensorMapEquiv_castAdd] + · rw [show x = Fin.natAdd (n₁ + n₂) + (Fin.natAdd n₁ ⟨x.val - (n₁ + n₂) - n₁, by + have := x.isLt + omega⟩) from + Fin.ext (by + change x.val = (n₁ + n₂) + (n₁ + (x.val - (n₁ + n₂) - n₁)) + have := x.isLt + omega), + _root_.Equiv.trans_apply, + interleaveEquiv_symm_high_right n₁ n₁ n₂ n₂ + ⟨x.val - (n₁ + n₂) - n₁, by + have := x.isLt + omega⟩, + _root_.Equiv.trans_apply, _root_.Equiv.sumCongr_apply, + Sum.map_inr, outMapEquiv_natAdd e₂, + interleaveEquiv_inr_high n₁ m₁ n₂ m₂ + (e₂ ⟨x.val - (n₁ + n₂) - n₁, by + have := x.isLt + omega⟩), + outMapEquiv_natAdd (tensorMapEquiv e₁ e₂), + tensorMapEquiv_natAdd] + +/-- Composing with a bundle map on the right relabels the +outgoing boundary. -/ +noncomputable def composeBundleMap {s n m : ℕ} + (e : Fin n ≃ Fin m) (F : Fragment (Fin (s + n))) : + (F.compose (bundleMap e)).Equiv + (F.relabel (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin s)) e).trans + finSumFinEquiv))) := by + have hnm : n = m := by + have h := Fintype.card_congr e + simpa using h + subst hnm + refine (Fragment.composeCongr (Fragment.Equiv.refl F) + (permFragmentRelabelOutPerm e).symm).trans ?_ + refine (composePermFragment e F).trans ?_ + exact Fragment.Equiv.relabelEq F + (_root_.Equiv.ext (fun x => rfl)) + +/-- Composing with a bundle map on the left relabels the +incoming boundary by the inverse. -/ +noncomputable def bundleMapCompose {n m u : ℕ} + (e : Fin n ≃ Fin m) (F : Fragment (Fin (m + u))) : + ((bundleMap e).compose F).Equiv + (F.relabel (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr e.symm + (_root_.Equiv.refl (Fin u))).trans finSumFinEquiv))) := by + have hnm : n = m := by + have h := Fintype.card_congr e + simpa using h + subst hnm + refine (Fragment.composeCongr + (permFragmentRelabelOutPerm e).symm + (Fragment.Equiv.refl F)).trans ?_ + refine (permFragmentComposeLeft e F).trans ?_ + exact Fragment.Equiv.relabelEq F + (_root_.Equiv.ext (fun x => rfl)) + +/-- The outgoing transport of a cast is a cast. -/ +theorem outTransport_finCongr {s n m : ℕ} (h : n = m) : + (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin s)) + (finCongr h)).trans finSumFinEquiv) : + Fin (s + n) ≃ Fin (s + m)) = + finCongr (by omega) := by + subst h + refine _root_.Equiv.ext (fun x => Fin.ext ?_) + rcases Nat.lt_or_ge x.val s with hx | hx + · rw [show x = Fin.castAdd n ⟨x.val, hx⟩ from Fin.ext rfl, + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_castAdd] + rfl + · rw [show x = Fin.natAdd s ⟨x.val - s, by + have := x.isLt + omega⟩ from Fin.ext (by + change x.val = s + (x.val - s) + omega), + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_natAdd] + rfl + +/-- The incoming transport of a cast is a cast. -/ +theorem inTransport_finCongr {n m u : ℕ} (h : n = m) : + (finSumFinEquiv.symm.trans + ((_root_.Equiv.sumCongr (finCongr h) + (_root_.Equiv.refl (Fin u))).trans finSumFinEquiv) : + Fin (n + u) ≃ Fin (m + u)) = + finCongr (by omega) := by + subst h + refine _root_.Equiv.ext (fun x => Fin.ext ?_) + rcases Nat.lt_or_ge x.val n with hx | hx + · rw [show x = Fin.castAdd u ⟨x.val, hx⟩ from Fin.ext rfl, + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_castAdd] + rfl + · rw [show x = Fin.natAdd n ⟨x.val - n, by + have := x.isLt + omega⟩ from Fin.ext (by + change x.val = n + (x.val - n) + omega), + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_natAdd] + rfl + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The bundle-map class. -/ +noncomputable def bundleMapClass {n m : ℕ} (e : Fin n ≃ Fin m) : + HomSpace f.val (n + m) := + HomSpace.ofFragment f.val (bundleMap e) + +/-- The class of the identity bundle map is the identity class. -/ +theorem bundleMapClass_refl (n : ℕ) : + bundleMapClass f (_root_.Equiv.refl (Fin n)) = + HomSpace.ofFragment f.val (strandBundle n) := + HomSpace.ofFragment_congr f (bundleMapRefl n) + +/-- **Composition of bundle-map classes.** -/ +theorem bundleMapClass_comp {n m p : ℕ} + (e₁ : Fin n ≃ Fin m) (e₂ : Fin m ≃ Fin p) : + HomSpace.comp f n m p + (bundleMapClass f e₁) (bundleMapClass f e₂) = + bundleMapClass f (e₁.trans e₂) := by + rw [bundleMapClass, bundleMapClass, + HomSpace.comp_ofFragment] + exact HomSpace.ofFragment_congr f (bundleMapComp e₁ e₂) + +/-- Congruent label equivalences give equal classes. -/ +theorem bundleMapClass_congr {n m : ℕ} {e₁ e₂ : Fin n ≃ Fin m} + (h : e₁ = e₂) : + bundleMapClass f e₁ = bundleMapClass f e₂ := by + rw [h] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleTensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleTensor.lean new file mode 100644 index 0000000000..32927df09a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleTensor.lean @@ -0,0 +1,136 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment + +/-! +# The strand bundle is a tensor of strand bundles + +`strandBundle (a + b) ≃ strandBundle a ⊗ strandBundle b`: the +first `a` strands form the first factor, the rest the second. +This is the object-level compatibility of the identity fragments +with the monoidal product, the entry point for the trace +multiplicativity (Lemma 3.5(b)). +-/ + +@[expose] public section + +namespace RS + +/-- The strand split: strands below `a` to the left factor, +strands above to the right. -/ +def bundleFlagEquiv (a b : ℕ) : + (Fin (a + b) × Bool) ≃ ((Fin a × Bool) ⊕ (Fin b × Bool)) where + toFun f := + if h : f.1.val < a then Sum.inl (⟨f.1.val, h⟩, f.2) + else Sum.inr (⟨f.1.val - a, by have := f.1.isLt; omega⟩, f.2) + invFun g := + match g with + | Sum.inl (k, c) => (⟨k.val, by have := k.isLt; omega⟩, c) + | Sum.inr (l, c) => (⟨a + l.val, by have := l.isLt; omega⟩, c) + left_inv f := by + by_cases h : f.1.val < a + · simp only [dite_eq_left h] + · simp only [dite_eq_right h] + exact Prod.ext (Fin.ext (by + change a + (f.1.val - a) = f.1.val + omega)) rfl + right_inv g := by + rcases g with ⟨k, c⟩ | ⟨l, c⟩ + · simp only [dite_eq_left k.isLt] + · simp only [dite_eq_right (show ¬ a + l.val < a by omega)] + refine congrArg Sum.inr (Prod.ext (Fin.ext ?_) rfl) + change a + l.val - a = l.val + omega + +/-- **The bundle splits**: the `(a + b)`-strand bundle is the +tensor of the `a`- and `b`-strand bundles. -/ +noncomputable def strandBundleTensor (a b : ℕ) : + (strandBundle (a + b)).Equiv + (tensorFragment (strandBundle a) (strandBundle b)) where + flagEquiv := bundleFlagEquiv a b + vertexEquiv := + show Empty ≃ (Empty ⊕ Empty) from + _root_.Equiv.equivOfIsEmpty _ _ + attach_comm := fun f => by + obtain ⟨k, c⟩ := f + by_cases h : k.val < a + · have hbfe : bundleFlagEquiv a b (k, c) = + Sum.inl (⟨k.val, h⟩, c) := dite_eq_left h + change (tensorFragment (strandBundle a) + (strandBundle b)).attach (bundleFlagEquiv a b (k, c)) = _ + rw [hbfe] + rcases c with _ | _ + · change Sum.inr (interleaveEquiv a a b b + (Sum.inl ⟨k.val, by omega⟩)) = Sum.inr ⟨k.val, by omega⟩ + rw [show (⟨k.val, by omega⟩ : Fin (a + a)) = + Fin.castAdd a ⟨k.val, h⟩ from Fin.ext rfl, + interleaveEquiv_inl_low] + exact congrArg Sum.inr (Fin.ext rfl) + · change Sum.inr (interleaveEquiv a a b b + (Sum.inl ⟨a + k.val, by omega⟩)) = + Sum.inr ⟨(a + b) + k.val, by have := k.isLt; omega⟩ + rw [show (⟨a + k.val, by omega⟩ : Fin (a + a)) = + Fin.natAdd a ⟨k.val, h⟩ from Fin.ext rfl, + interleaveEquiv_inl_high] + exact congrArg Sum.inr (Fin.ext rfl) + · have hbfe : bundleFlagEquiv a b (k, c) = + Sum.inr (⟨k.val - a, by have := k.isLt; omega⟩, c) := + dite_eq_right h + change (tensorFragment (strandBundle a) + (strandBundle b)).attach (bundleFlagEquiv a b (k, c)) = _ + rw [hbfe] + rcases c with _ | _ + · change Sum.inr (interleaveEquiv a a b b + (Sum.inr ⟨k.val - a, by have := k.isLt; omega⟩)) = + Sum.inr ⟨k.val, by omega⟩ + rw [show (⟨k.val - a, by have := k.isLt; omega⟩ : + Fin (b + b)) = + Fin.castAdd b ⟨k.val - a, by have := k.isLt; omega⟩ + from Fin.ext rfl, interleaveEquiv_inr_low] + exact congrArg Sum.inr (Fin.ext (by + change a + (k.val - a) = k.val + omega)) + · change Sum.inr (interleaveEquiv a a b b + (Sum.inr ⟨b + (k.val - a), by have := k.isLt; omega⟩)) = + Sum.inr ⟨(a + b) + k.val, by have := k.isLt; omega⟩ + rw [show (⟨b + (k.val - a), by have := k.isLt; omega⟩ : + Fin (b + b)) = + Fin.natAdd b ⟨k.val - a, by have := k.isLt; omega⟩ + from Fin.ext rfl, interleaveEquiv_inr_high] + exact congrArg Sum.inr (Fin.ext (by + change (a + b) + (a + (k.val - a)) = (a + b) + k.val + omega)) + pairing_comm := fun f => by + obtain ⟨k, c⟩ := f + by_cases h : k.val < a + · have h1 : bundleFlagEquiv a b (k, !c) = + Sum.inl (⟨k.val, h⟩, !c) := dite_eq_left h + have h2 : bundleFlagEquiv a b (k, c) = + Sum.inl (⟨k.val, h⟩, c) := dite_eq_left h + change bundleFlagEquiv a b (k, !c) = _ + rw [h1] + change _ = (tensorFragment (strandBundle a) + (strandBundle b)).pairing (bundleFlagEquiv a b (k, c)) + rw [h2] + rfl + · have h1 : bundleFlagEquiv a b (k, !c) = + Sum.inr (⟨k.val - a, by have := k.isLt; omega⟩, !c) := + dite_eq_right h + have h2 : bundleFlagEquiv a b (k, c) = + Sum.inr (⟨k.val - a, by have := k.isLt; omega⟩, c) := + dite_eq_right h + change bundleFlagEquiv a b (k, !c) = _ + rw [h1] + change _ = (tensorFragment (strandBundle a) + (strandBundle b)).pairing (bundleFlagEquiv a b (k, c)) + rw [h2] + rfl + circles_eq := rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonExistence.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonExistence.lean new file mode 100644 index 0000000000..566abb3116 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonExistence.lean @@ -0,0 +1,361 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChainAgreement + +/-! +# Existence of path-canonical orientations + +Every orientation of a boundary-relative transition system can be +repaired into a path-canonical one by flipping exactly the internal +flags lying on non-canonically oriented boundary-to-boundary chains. + +## Main results + +* `EdgeSubset.exists_pathCanonical` — from any orientation of a + relative transition system, a path-canonical orientation of the + *same* system exists. +* `EdgeSubset.canonOrientation` — the orientation it produces, + built by flipping every chain whose low end points outwards. + +## Proof route + +1. `BadFlag` marks the pairing-side flags of chains whose low-labelled + boundary end has an outgoing entry edge (`ChainNonCanon`); the + symmetric formulation covers every internal flag of such a chain, + since match-side flags are the pairing-side flags of the reverse + chain (`iterWalk_reverse`). +2. The flip set is closed under the matching (`badFlag_match`) and + under the edge pairing on internal partners (`badFlag_pairing`), + so negating `isOut` on it yields a valid orientation + (`canonOrientation`). +3. Exit steps of a forward walk are unique + (`exit_step_unique`), and a pairing-side flag's forward walk exits + at its chain's base end (`chain_flag_exit`); hence the chain data + witnessing badness of an entry flag are pinned to the entry's own + chain, and the flip decision at each entry flag matches its + chain's canonicality status (`pathCanonical_canonOrientation`). +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} + +namespace EdgeSubset + +/-! ### 1. Exit uniqueness and chain membership -/ + +/-- **Exit uniqueness**: two boundary-exit data for the forward walk +of one flag agree on the exit step. -/ +theorem exit_step_unique {W : Fragment α} {F : EdgeSubset W} + (κ : F.RelTransitionSystem) {f : W.Flag} + {k₁ k₂ : ℕ} + (hc₁ : ∀ t, t < k₁ → + W.pairing (iterWalk κ f t) ∈ F.internalFlags) + (ht₁ : W.pairing (iterWalk κ f k₁) ∈ F.boundaryFlags) + (hc₂ : ∀ t, t < k₂ → + W.pairing (iterWalk κ f t) ∈ F.internalFlags) + (ht₂ : W.pairing (iterWalk κ f k₂) ∈ F.boundaryFlags) : + k₁ = k₂ := by + by_contra hne + rcases Nat.lt_or_gt_of_ne hne with h | h + · exact Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags (hc₂ k₁ h) ht₁ + · exact Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags (hc₁ k₂ h) ht₂ + +/-- **Chain-flag exit data**: the forward walk of the pairing-side +flag at step `m` of a chain from `b` has internal pairings before +step `m` and exits at `b` at step `m`. -/ +theorem chain_flag_exit {W : Fragment α} {F : EdgeSubset W} + (κ : F.RelTransitionSystem) {b : W.Flag} + {k m : ℕ} + (hcont : ∀ t, t < k → + W.pairing (iterWalk κ b t) ∈ F.internalFlags) + (hmk : m < k) : + (∀ t, t < m → + W.pairing (iterWalk κ (W.pairing (iterWalk κ b m)) t) ∈ + F.internalFlags) ∧ + W.pairing (iterWalk κ (W.pairing (iterWalk κ b m)) m) = b := by + have hcont' : ∀ t, t < m → + W.pairing (iterWalk κ b t) ∈ F.internalFlags := + fun t ht => hcont t (by omega) + constructor + · intro t ht + rw [iterWalk_reverse κ hcont' t (by omega), W.pairing_invol] + exact iterWalk_mem_internal κ k (by omega) (by omega) hcont + · rw [iterWalk_reverse κ hcont' m le_rfl, Nat.sub_self, + iterWalk_zero, W.pairing_invol] + +/-- The path match of a boundary end equals the terminal pairing of +any boundary-terminated chain data from it (via exit uniqueness — no +fuel bound required on the given data). -/ +theorem pathMatch_eq_of_chain {W : Fragment α} {F : EdgeSubset W} + (κ : F.RelTransitionSystem) + {b : W.Flag} (hb : b ∈ F.boundaryFlags) {k : ℕ} + (hcont : ∀ t, t < k → + W.pairing (iterWalk κ b t) ∈ F.internalFlags) + (hterm : W.pairing (iterWalk κ b k) ∈ F.boundaryFlags) : + κ.pathMatch b hb = W.pairing (iterWalk κ b k) := by + obtain ⟨k₀, -, hcont₀, hpm₀⟩ := pathMatch_chain_length κ hb + have hterm₀ : W.pairing (iterWalk κ b k₀) ∈ F.boundaryFlags := by + rw [← hpm₀] + exact κ.pathMatch_mem hb + have hk : k = k₀ := exit_step_unique κ hcont hterm hcont₀ hterm₀ + rw [hpm₀, hk] + +open EdgeSubset in +/-- **A flag whose partner is a boundary flag is matched to it.** -/ +theorem pathMatch_eq_pairing_of_boundary {α : Type} + {W : Fragment α} {F : EdgeSubset W} (κ : F.RelTransitionSystem) + {b : W.Flag} (hb : b ∈ F.boundaryFlags) + (hp : W.pairing b ∈ F.boundaryFlags) : + κ.pathMatch b hb = W.pairing b := by + have h := pathMatch_eq_of_chain κ hb (k := 0) + (fun _ ht => absurd ht (by omega)) + (by rw [iterWalk_zero]; exact hp) + rwa [iterWalk_zero] at h + +/-! ### 2. Non-canonical chains and the flip set -/ + +/-- The chain from boundary end `b` is **non-canonically oriented**: +its lower-labelled end — whichever of `b` and its path match that is — +has an outgoing entry edge. -/ +def ChainNonCanon [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + (κ : F.RelTransitionSystem) (o : κ.Orientation) + (b : W.Flag) : Prop := + ∃ (hb : b ∈ F.boundaryFlags) (i j : α), + W.attach b = Sum.inr i ∧ + W.attach (κ.pathMatch b hb) = Sum.inr j ∧ + ((i < j ∧ o.isOut (W.pairing b) = true) ∨ + (j < i ∧ o.isOut (W.pairing (κ.pathMatch b hb)) = true)) + +/-- Non-canonicality passes to the opposite chain end. -/ +theorem chainNonCanon_pathMatch + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + {o : κ.Orientation} {b : W.Flag} (h : ChainNonCanon κ o b) + (hb : b ∈ F.boundaryFlags) : + ChainNonCanon κ o (κ.pathMatch b hb) := by + obtain ⟨hb₂, i, j, hai, haj, hdisj⟩ := h + refine ⟨κ.pathMatch_mem hb, j, i, ?_, ?_, ?_⟩ + · exact haj + · rw [κ.pathMatch_invol hb] + exact hai + · rcases hdisj with ⟨hij, hout⟩ | ⟨hji, hout⟩ + · refine Or.inr ⟨hij, ?_⟩ + rw [κ.pathMatch_invol hb] + exact hout + · exact Or.inl ⟨hji, hout⟩ + +/-- **The flip set**: `f` is a pairing-side flag of a +non-canonically oriented boundary-to-boundary chain. -/ +def BadFlag [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + (κ : F.RelTransitionSystem) (o : κ.Orientation) + (f : W.Flag) : Prop := + ∃ (b : W.Flag) (k m : ℕ), + (∀ t, t < k → + W.pairing (iterWalk κ b t) ∈ F.internalFlags) ∧ + W.pairing (iterWalk κ b k) ∈ F.boundaryFlags ∧ + m < k ∧ f = W.pairing (iterWalk κ b m) ∧ + ChainNonCanon κ o b + +/-- **Match closure**: the flip set is closed under the matching — +the match of a pairing-side flag is a pairing-side flag of the +reverse chain, whose base end is the path match of the original. -/ +theorem badFlag_match [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + {o : κ.Orientation} {f : W.Flag} (h : BadFlag κ o f) : + BadFlag κ o (κ.match_ f) := by + obtain ⟨b, k, m, hcont, hterm, hmk, hfe, hnc⟩ := h + have hb : b ∈ F.boundaryFlags := by + obtain ⟨hb, -⟩ := hnc + exact hb + refine ⟨W.pairing (iterWalk κ b k), k, k - (m + 1), + fun t ht => reverse_chain_continues κ hb hcont t ht, ?_, + by omega, ?_, ?_⟩ + · rw [reverse_chain_terminates κ hcont] + exact hb + · have h2 := iterWalk_reverse κ hcont (k - (m + 1)) (by omega) + rw [show k - (k - (m + 1)) = m + 1 from by omega] at h2 + rw [h2, W.pairing_invol, hfe] + exact (iterWalk_succ κ b m).symm + · have hpm := pathMatch_eq_of_chain κ hb hcont hterm + have htr := chainNonCanon_pathMatch hnc hb + rwa [hpm] at htr + +/-- **Pairing closure**: the flip set is closed under the edge +pairing whenever the partner is internal — the partner is a +match-side flag, i.e. a pairing-side flag of the reverse chain. -/ +theorem badFlag_pairing [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + {o : κ.Orientation} {f : W.Flag} (h : BadFlag κ o f) + (hp : W.pairing f ∈ F.internalFlags) : + BadFlag κ o (W.pairing f) := by + obtain ⟨b, k, m, hcont, hterm, hmk, hfe, hnc⟩ := h + have hb : b ∈ F.boundaryFlags := by + obtain ⟨hb, -⟩ := hnc + exact hb + have hpf : W.pairing f = iterWalk κ b m := by + rw [hfe, W.pairing_invol] + rcases Nat.eq_zero_or_pos m with rfl | hm1 + · rw [iterWalk_zero] at hpf + exact absurd hb (Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags (hpf ▸ hp)) + · refine ⟨W.pairing (iterWalk κ b k), k, k - m, + fun t ht => reverse_chain_continues κ hb hcont t ht, ?_, + by omega, ?_, ?_⟩ + · rw [reverse_chain_terminates κ hcont] + exact hb + · have h2 := iterWalk_reverse κ hcont (k - m) (by omega) + rw [show k - (k - m) = m from by omega] at h2 + rw [hpf, h2, W.pairing_invol] + · have hpm := pathMatch_eq_of_chain κ hb hcont hterm + have htr := chainNonCanon_pathMatch hnc hb + rwa [hpm] at htr + +/-! ### 3. The flipped orientation -/ + +/-- The candidate canonical orientation as a raw flag function: +negate on the flip set. -/ +noncomputable def canonIsOut [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + (κ : F.RelTransitionSystem) + (o : κ.Orientation) (f : W.Flag) : Bool := + open scoped Classical in + if BadFlag κ o f then !o.isOut f else o.isOut f + +/-- On a flag of a badly oriented chain the repair reverses. -/ +theorem canonIsOut_of_bad [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + {o : κ.Orientation} {f : W.Flag} (h : BadFlag κ o f) : + canonIsOut κ o f = !o.isOut f := by + unfold canonIsOut + rw [ite_eq_left h] + +/-- Elsewhere it leaves the orientation alone. -/ +theorem canonIsOut_of_not_bad + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + {o : κ.Orientation} {f : W.Flag} (h : ¬ BadFlag κ o f) : + canonIsOut κ o f = o.isOut f := by + unfold canonIsOut + rw [ite_eq_right h] + +/-- **The flipped orientation**: negate the given orientation on the +flip set. The closure lemmas make the flip commute with both +orientation axioms. -/ +noncomputable def canonOrientation + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + (κ : F.RelTransitionSystem) + (o : κ.Orientation) : κ.Orientation where + isOut := canonIsOut κ o + match_flip := fun f hf => by + by_cases hB : BadFlag κ o f + · rw [canonIsOut_of_bad (badFlag_match hB), canonIsOut_of_bad hB, + o.match_flip f hf] + · have hBm : ¬ BadFlag κ o (κ.match_ f) := fun hc => hB (by + have h2 := badFlag_match hc + rwa [κ.match_invol f hf] at h2) + rw [canonIsOut_of_not_bad hBm, canonIsOut_of_not_bad hB, + o.match_flip f hf] + pairing_flip := fun f hf hp => by + by_cases hB : BadFlag κ o f + · rw [canonIsOut_of_bad (badFlag_pairing hB hp), + canonIsOut_of_bad hB, o.pairing_flip f hf hp] + · have hBp : ¬ BadFlag κ o (W.pairing f) := fun hc => hB (by + have h2 := badFlag_pairing hc (by + rw [W.pairing_invol] + exact hf) + rwa [W.pairing_invol] at h2) + rw [canonIsOut_of_not_bad hBp, canonIsOut_of_not_bad hB, + o.pairing_flip f hf hp] + +/-- The repaired orientation's table is that repair. -/ +theorem canonOrientation_isOut + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + (κ : F.RelTransitionSystem) + (o : κ.Orientation) (f : W.Flag) : + (canonOrientation κ o).isOut f = canonIsOut κ o f := rfl + +/-! ### 4. Canonicality of the flipped orientation -/ + +/-- **The flipped orientation is path-canonical**: at each low-end +entry flag, exit uniqueness pins any badness witness to the entry's +own chain, so the flip decision matches the chain's prior status. -/ +theorem pathCanonical_canonOrientation + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + (κ : F.RelTransitionSystem) + (o : κ.Orientation) : PathCanonical (canonOrientation κ o) := by + intro i j hb hint hpm hij + rw [canonOrientation_isOut] + by_cases hB : BadFlag κ o (W.pairing (W.boundaryFlag i)) + · rw [canonIsOut_of_bad hB] + obtain ⟨bs, ks, ms, hconts, -, hms, hfes, hncs⟩ := hB + obtain ⟨hbs, is', js', hais, hajs, hdisjs⟩ := hncs + obtain ⟨hce, hexit⟩ := chain_flag_exit κ hconts hms + rw [← hfes] at hce hexit + have ht₁ : W.pairing + (iterWalk κ (W.pairing (W.boundaryFlag i)) 0) ∈ + F.boundaryFlags := by + rw [iterWalk_zero, W.pairing_invol] + exact hb + have hms0 : (0 : ℕ) = ms := + exit_step_unique κ (fun t ht => absurd ht (Nat.not_lt_zero t)) + ht₁ hce (by rw [hexit]; exact hbs) + have hbse : bs = W.boundaryFlag i := by + have h0 := hexit + rw [← hms0, iterWalk_zero, W.pairing_invol] at h0 + exact h0.symm + subst hbse + have hi : i = is' := + Sum.inr.inj ((W.attach_boundaryFlag i).symm.trans hais) + rw [κ.pathMatch_congr rfl hbs hb, hpm] at hajs + have hj : j = js' := + Sum.inr.inj ((W.attach_boundaryFlag j).symm.trans hajs) + rcases hdisjs with ⟨-, hout⟩ | ⟨hlt, -⟩ + · rw [hout] + rfl + · rw [← hi, ← hj] at hlt + exact absurd (hlt.trans hij) (lt_irrefl j) + · rw [canonIsOut_of_not_bad hB] + obtain ⟨k, -, hcont, hterm⟩ := chain_terminates_with_data κ hb + have hk1 : 1 ≤ k := by + rcases Nat.eq_zero_or_pos k with rfl | h + · rw [iterWalk_zero] at hterm + exact absurd hterm (Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags hint) + · exact h + cases hout : o.isOut (W.pairing (W.boundaryFlag i)) with + | false => rfl + | true => + exact absurd + (show BadFlag κ o (W.pairing (W.boundaryFlag i)) from + ⟨W.boundaryFlag i, k, 0, hcont, hterm, hk1, + by rw [iterWalk_zero], + ⟨hb, i, j, W.attach_boundaryFlag i, + by rw [hpm]; exact W.attach_boundaryFlag j, + Or.inl ⟨hij, hout⟩⟩⟩) + hB + +/-! ### Existence and its canonical-frame form -/ + +/-- **Existence of path-canonical orientations**: any orientation of +a boundary-relative transition system can be repaired into a +path-canonical orientation of the same system. -/ +theorem exists_pathCanonical [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + (κ : F.RelTransitionSystem) + (o : κ.Orientation) : ∃ o' : κ.Orientation, PathCanonical o' := + ⟨canonOrientation κ o, pathCanonical_canonOrientation κ o⟩ + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonTransport.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonTransport.lean new file mode 100644 index 0000000000..2ea7e87015 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonTransport.lean @@ -0,0 +1,144 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionProduct + +/-! +# Canonical data across a relabel and a glue + +Canonical data — a transition system with a path-canonical +orientation — transport along a relabel, down across either branch +of a single-pair glue, and back up from a closed lift. +-/ + +@[expose] public section + +namespace RS + + + +/-! ## Transport along a relabel -/ + +/-- Canonical-data existence transports along a relabel. -/ +theorem EdgeSubset.nonempty_canonData_relabelUp {α β : Type} + [LinearOrder α] [LinearOrder β] (e : α ≃o β) {W : Fragment α} + (F : EdgeSubset W) : + Nonempty (F.relabelUp e.toEquiv).CanonData ↔ + Nonempty F.CanonData := by + constructor + · rintro ⟨⟨κ, o, -⟩⟩ + obtain ⟨o', hc'⟩ := EdgeSubset.exists_pathCanonical + (relabelTransDown e.toEquiv F κ) + (relabelOrientDown e.toEquiv F o) + exact ⟨⟨_, o', hc'⟩⟩ + · rintro ⟨⟨κ, o, hc⟩⟩ + exact ⟨⟨relabelTransUp e.toEquiv F κ, + relabelOrientUp e.toEquiv F o, + pathCanonical_relabelUp e F hc⟩⟩ + +/-! ## Descent and the glued tower family (open cut) + +The support data transfer across the open glue: Eulerian-ness on +the nose, canonical data downward by unglue-and-repair, and the +glued pinned family built bottom-up from a lifted family. -/ + +section TowerFamilyOpen + +open EdgeSubset Fragment + +variable {α : Type} + +/-- Canonical data descend across the open unglue. -/ +theorem nonempty_canonData_unglueOpen + [LinearOrder α] {W : Fragment α} {i : α} {j : α} (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairOpen i j hij hopen).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetOpen hopen s', W.pairing f ∈ liftSubsetOpen hopen + s') + (hne : Nonempty (EdgeSubset.mk s' hc' : + EdgeSubset (W.gluePairOpen i j hij hopen)).CanonData) : + Nonempty (EdgeSubset.mk (liftSubsetOpen hopen s') hc : + EdgeSubset W).CanonData := by + obtain ⟨⟨κ'', o'', -⟩⟩ := hne + obtain ⟨o₂, hc₂⟩ := EdgeSubset.exists_pathCanonical + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ'') + (unglueOrientationOpen hij hopen s' hc' hc κ'' o'') + exact ⟨⟨_, o₂, hc₂⟩⟩ + +end TowerFamilyOpen + +/-! ## The closed-cut step at the pinned sum + +The mechanical mirror of for the circle-closing cut: support +transfer across either lift, the true-lift tower family, and the +`(k − 2ℓ)`-weighted per-subset split — the extra factor is the +glued fragment's extra circle, absorbed against the prefactor in +the tower. -/ + +section ClosedStep + +open EdgeSubset Fragment + +variable {α : Type} + +/-- Canonical data descend across either closed unglue. -/ +theorem nonempty_canonData_unglueClosed + [LinearOrder α] {W : Fragment α} {i : α} {j : α} + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairClosed i j hclosed).pairing f ∈ s') + (b : Bool) + (hc : ∀ f ∈ liftSubsetClosed s' b, + W.pairing f ∈ liftSubsetClosed s' b) + (hne : Nonempty (EdgeSubset.mk s' hc' : + EdgeSubset (W.gluePairClosed i j hclosed)).CanonData) : + Nonempty (EdgeSubset.mk (liftSubsetClosed s' b) hc : + EdgeSubset W).CanonData := by + obtain ⟨⟨κ'', o'', -⟩⟩ := hne + obtain ⟨o₂, hc₂⟩ := EdgeSubset.exists_pathCanonical + (RelTransitionSystem.unglueClosed hclosed b s' hc' hc κ'') + (unglueOrientationClosed hclosed b s' hc' hc κ'' o'') + exact ⟨⟨_, o₂, hc₂⟩⟩ + +end ClosedStep + +/-! ## Fibrewise absorption and the per-term relabel + +The generic state-fibre regrouping (the `𝒲`-form absorber), and +the relabel transport at the level of a single pinned term. -/ + +section ClosedConverse + +open EdgeSubset Fragment + +variable {α : Type} + +/-- Canonical data ascend from either closed lift to the glued +subset. -/ +theorem nonempty_canonData_glueClosed + [LinearOrder α] {W : Fragment α} {i : α} {j : α} + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairClosed i j hclosed).pairing f ∈ s') + (b : Bool) + (hc : ∀ f ∈ liftSubsetClosed s' b, + W.pairing f ∈ liftSubsetClosed s' b) + (hne : Nonempty (EdgeSubset.mk (liftSubsetClosed s' b) hc : + EdgeSubset W).CanonData) : + Nonempty (EdgeSubset.mk s' hc' : + EdgeSubset (W.gluePairClosed i j hclosed)).CanonData := by + obtain ⟨⟨κ, o, -⟩⟩ := hne + obtain ⟨o₂, hc₂⟩ := EdgeSubset.exists_pathCanonical + (RelTransitionSystem.glueClosed hclosed b s' hc' hc κ) + (glueOrientationClosed hclosed b s' hc' hc κ o) + exact ⟨⟨_, o₂, hc₂⟩⟩ + +end ClosedConverse + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonicalFrame.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonicalFrame.lean new file mode 100644 index 0000000000..c5a4549377 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonicalFrame.lean @@ -0,0 +1,577 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathNonSep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordLabels + +/-! +# The canonical frame: chain directions and re-canonicalization + +Vocabulary for the final `PairedLedger` induction. Every +participating boundary chain of a relative transition system carries +a direction observable — the orientation value at its entry edge +(`chainDir`). Path-canonicality is exactly the vanishing of +`chainDir` at every low-labelled chain end +(`pathCanonical_iff_chainDir`), and `chainDir` is constant along a +chain (`chainDir_eq`), so an arbitrary orientation differs from the +canonical frame exactly on the chains its low ends point out of +(`antiLowSet`, `pathCanonical_iff_antiLowSet_empty`). Flipping one offending +chain (`exists_chainRecanonicalize`) toggles the two end directions, +preserves every other chain, and transforms the constrained summand +by the two end-colour signs at a `∂`-relabelled state; iterating +over the anti-canonical chains re-canonicalizes any orientation +(`exists_recanonicalize`). +-/ + +@[expose] public section + +namespace RS + + + +namespace EdgeSubset + +variable {α : Type} + +/-! ## The chain-direction observable -/ + +/-- **The chain direction** of an orientation at a boundary flag: +the orientation value at the flag's entry edge (the internal partner +of the boundary flag). `false` means the entry edge is incoming — +the chain leaves this end. -/ +def chainDir {W : Fragment α} {F : EdgeSubset W} {κ : F.RelTransitionSystem} + (o : κ.Orientation) (β : W.Flag) : Bool := + o.isOut (W.pairing β) + +/-- A chain's direction is the orientation at its entry edge. -/ +theorem chainDir_eq + {W : Fragment α} {F : EdgeSubset W} {κ : F.RelTransitionSystem} + (o : κ.Orientation) (β : W.Flag) : + chainDir o β = o.isOut (W.pairing β) := rfl + +/-- The entry edge of the far chain end is internal whenever the +near one is: the chain has at least one step, and its last walk flag +is internal. -/ +theorem pathMatch_pairing_internal + {W : Fragment α} {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {β : W.Flag} + (hβ : β ∈ F.boundaryFlags) + (hint : W.pairing β ∈ F.internalFlags) : + W.pairing (κ.pathMatch β hβ) ∈ F.internalFlags := by + obtain ⟨k, hkle, hcont, hterm⟩ := chain_terminates_with_data κ hβ + have hk1 : 1 ≤ k := by + rcases Nat.eq_zero_or_pos k with rfl | h + · rw [iterWalk_zero] at hterm + exact absurd hterm (Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags hint) + · exact h + have hpm : κ.pathMatch β hβ = W.pairing (iterWalk κ β k) := + κ.pathMatch_eq hβ (traceChain_fuel_mono κ (by omega) + (traceChain_forward κ β hcont hterm)) + rw [hpm, W.pairing_invol] + exact iterWalk_mem_internal κ k hk1 le_rfl hcont + +/-- **Chain-direction rigidity**: the chain is coherently directed, +so the two ends' entry flags carry opposite orientation values — for +*any* orientation of the system. -/ +theorem chainDir_pathMatch + {W : Fragment α} {F : EdgeSubset W} {κ : F.RelTransitionSystem} + (o : κ.Orientation) {β : W.Flag} + (hβ : β ∈ F.boundaryFlags) + (hint : W.pairing β ∈ F.internalFlags) : + chainDir o (κ.pathMatch β hβ) = !chainDir o β := by + obtain ⟨k, hkle, hcont, hterm⟩ := chain_terminates_with_data κ hβ + have hk1 : 1 ≤ k := by + rcases Nat.eq_zero_or_pos k with rfl | h + · rw [iterWalk_zero] at hterm + exact absurd hterm (Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags hint) + · exact h + have hpm : κ.pathMatch β hβ = W.pairing (iterWalk κ β k) := + κ.pathMatch_eq hβ (traceChain_fuel_mono κ (by omega) + (traceChain_forward κ β hcont hterm)) + change o.isOut (W.pairing (κ.pathMatch β hβ)) = + !o.isOut (W.pairing β) + rw [hpm, W.pairing_invol] + exact isOut_iterWalk_eq_not_seed o hcont k hk1 le_rfl + +/-! ## Canonicality via the chain direction -/ + +/-- **Path-canonicality is a chain-direction condition**: an +orientation is path-canonical iff its chain direction vanishes at +every participating boundary flag that is the low-labelled end of its +chord. -/ +theorem pathCanonical_iff_chainDir + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + (o : κ.Orientation) : + PathCanonical o ↔ + ∀ (β : W.Flag) (hβ : β ∈ F.boundaryFlags), + W.pairing β ∈ F.internalFlags → + F.boundaryLabel hβ < + F.boundaryLabel (κ.pathMatch_mem hβ) → + chainDir o β = false := by + constructor + · intro hc β hβ hint hlt + have hβeq : β = W.boundaryFlag (F.boundaryLabel hβ) := + W.eq_boundaryFlag _ β (attach_boundaryLabel hβ) + have hbB : W.boundaryFlag (F.boundaryLabel hβ) ∈ + F.boundaryFlags := hβeq ▸ hβ + have hintB : W.pairing (W.boundaryFlag (F.boundaryLabel hβ)) ∈ + F.internalFlags := by + rw [← hβeq] + exact hint + have hpm : κ.pathMatch (W.boundaryFlag (F.boundaryLabel hβ)) + hbB = + W.boundaryFlag (F.boundaryLabel (κ.pathMatch_mem hβ)) := by + rw [κ.pathMatch_congr hβeq.symm hbB hβ] + exact W.eq_boundaryFlag _ _ + (attach_boundaryLabel (κ.pathMatch_mem hβ)) + have hval := hc _ _ hbB hintB hpm hlt + change o.isOut (W.pairing β) = false + rw [hβeq] + exact hval + · intro H i j hb hint hpm hij + have hlab_i : F.boundaryLabel hb = i := + boundaryLabel_eq_of_attach hb (W.attach_boundaryFlag i) + have hlab_j : F.boundaryLabel (κ.pathMatch_mem hb) = j := + boundaryLabel_eq_of_attach _ (by + rw [hpm] + exact W.attach_boundaryFlag j) + exact H _ hb hint (by + rw [hlab_i, hlab_j] + exact hij) + +/-! ## Chain directions under the ported chain flip -/ + +section FlipDir + +/-- Flipping a ported set toggles the chain direction at ends whose +entry edge lies in the set. -/ +theorem chainDir_portFlip_of_mem + {W : Fragment α} {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {S : Finset W.Flag} {p₁ : W.Flag} {p₂ : W.Flag} {i₁ : α} {i₂ : α} + (o : κ.Orientation) + (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) {γ : W.Flag} + (hγ : W.pairing γ ∈ S) : + chainDir (o.portFlip h) γ = !chainDir o γ := + portFlip_isOut_of_mem o h hγ + +/-- Flipping a ported set preserves the chain direction at ends +whose entry edge avoids the set. -/ +theorem chainDir_portFlip_of_notMem + {W : Fragment α} {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {S : Finset W.Flag} {p₁ : W.Flag} {p₂ : W.Flag} {i₁ : α} {i₂ : α} + (o : κ.Orientation) + (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) {γ : W.Flag} + (hγ : W.pairing γ ∉ S) : + chainDir (o.portFlip h) γ = chainDir o γ := + portFlip_isOut_of_notMem o h hγ + +end FlipDir + +/-- **The chain flip set of a participating boundary flag**: the +boundary chain of `β` realizes a ported flip set whose ports are the +entry edges of `β` and of its path match, labelled by the two chain +ends, and whose flip set avoids the entry edge of every other +boundary flag. -/ +theorem exists_chainFlipSet + {W : Fragment α} {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {β : W.Flag} + (hβ : β ∈ F.boundaryFlags) + (hint : W.pairing β ∈ F.internalFlags) : + ∃ S : Finset W.Flag, + PortedFlipSet κ S (W.pairing β) + (W.pairing (κ.pathMatch β hβ)) + (F.boundaryLabel hβ) + (F.boundaryLabel (κ.pathMatch_mem hβ)) ∧ + W.pairing (κ.pathMatch β hβ) ∈ S ∧ + ∀ γ ∈ F.boundaryFlags, γ ≠ β → γ ≠ κ.pathMatch β hβ → + W.pairing γ ∉ S := by + obtain ⟨k, hkle, hcont, hterm⟩ := chain_terminates_with_data κ hβ + have hk1 : 1 ≤ k := by + rcases Nat.eq_zero_or_pos k with rfl | h + · rw [iterWalk_zero] at hterm + exact absurd hterm (Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags hint) + · exact h + have hpm : κ.pathMatch β hβ = W.pairing (iterWalk κ β k) := + κ.pathMatch_eq hβ (traceChain_fuel_mono κ (by omega) + (traceChain_forward κ β hcont hterm)) + have hiβ : W.attach β = Sum.inr (F.boundaryLabel hβ) := + attach_boundaryLabel hβ + have hiγ : W.attach (W.pairing (iterWalk κ β k)) = + Sum.inr (F.boundaryLabel (κ.pathMatch_mem hβ)) := by + rw [← hpm] + exact attach_boundaryLabel (κ.pathMatch_mem hβ) + obtain ⟨S, hS, hSon, -⟩ := + exists_chainPortedFlipSet κ hβ hcont hterm hk1 hiβ hiγ + have hp₂ : iterWalk κ β k = W.pairing (κ.pathMatch β hβ) := by + rw [hpm, W.pairing_invol] + refine ⟨S, ?_, ?_, ?_⟩ + · rw [← hp₂] + exact hS + · rw [← hp₂] + exact hS.hp₂S + · intro γ hγ hγβ hγpm hmem + obtain ⟨k', t, htk, hcont', hterm', hft⟩ := hSon _ hmem + have hkk : k' = k := chain_exit_unique hcont' hterm' hcont hterm + subst hkk + rcases hft with hft | hft + · -- entry edge on the walk side: `γ` is a pairing-side flag + have hγeq : γ = W.pairing (iterWalk κ β t) := by + have h2 := congrArg W.pairing hft + rwa [W.pairing_invol] at h2 + rcases Nat.lt_or_ge t k' with hlt | hge + · refine absurd hγ (Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags ?_) + rw [hγeq] + exact hcont t hlt + · apply hγpm + rw [hγeq, show t = k' from by omega, hpm] + · -- entry edge on the pairing side: `γ` is a walk flag + have hγeq : γ = iterWalk κ β t := by + have h2 := congrArg W.pairing hft + rwa [W.pairing_invol, W.pairing_invol] at h2 + rcases Nat.eq_zero_or_pos t with rfl | ht1 + · rw [iterWalk_zero] at hγeq + exact hγβ hγeq + · refine absurd hγ (Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags ?_) + rw [hγeq] + exact iterWalk_mem_internal κ k' ht1 htk hcont + +/-! ## The re-canonicalization ledger, one chain -/ + +section FlipLedger + +/-- The two-sign cast squares to one. -/ +theorem signPairSq (ℓ : ℕ) (c₁ c₂ : Fin (2 * ℓ)) : + ((oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂ : ℤ) : ℂ) * + ((oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂ : ℤ) : ℂ) = + 1 := by + have h1 := twoPathNonSepFactor_mul_self ℓ c₁ c₂ + rwa [twoPathNonSepFactor_eq, neg_mul_neg] at h1 + +/-- **The inverted chain-flip ledger**: the summand of the original +orientation equals the two chain-end colour signs times the summand +of the *flipped* orientation at the `∂`-relabelled state — the +direction useful for re-canonicalization, obtained from +`throughSummand_portFlip` by involution of the relabel and the +sign. -/ +theorem throughSummand_portFlip_inv + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {S : Finset W.Flag} {p₁ : W.Flag} + {p₂ : W.Flag} {i₁ : α} {i₂ : α} {k : ℕ} {ℓ : ℕ} + (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (o : κ.Orientation) (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + {c₁ c₂ : Fin (2 * ℓ)} (hc₁ : st i₁ = Sum.inr c₁) + (hc₂ : st i₂ = Sum.inr c₂) (n : ℕ) : + F.throughSummand hM st hbnd o n = + ((oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂ : ℤ) : ℂ) * + F.throughSummand hM (stateOddFlip st i₁ i₂) + (genBoundarySubsetMatches_stateOddFlip hbnd i₁ i₂) + (o.portFlip h) n := by + have hc₁' : stateOddFlip st i₁ i₂ i₁ = + Sum.inr (oddPartner ℓ c₁) := stateOddFlip_left_odd hc₁ + have hc₂' : stateOddFlip st i₁ i₂ i₂ = + Sum.inr (oddPartner ℓ c₂) := stateOddFlip_right_odd hc₂ + have hkey := throughSummand_portFlip hM (stateOddFlip st i₁ i₂) + (genBoundarySubsetMatches_stateOddFlip hbnd i₁ i₂) o h + hc₁' hc₂' n + have hback : F.throughSummand hM + (stateOddFlip (stateOddFlip st i₁ i₂) i₁ i₂) + (genBoundarySubsetMatches_stateOddFlip + (genBoundarySubsetMatches_stateOddFlip hbnd i₁ i₂) i₁ i₂) + o n = + F.throughSummand hM st hbnd o n := + throughSummand_state_congr F hM stateOddFlip_stateOddFlip _ + hbnd o n + have hsgn : ((oddPartnerSign ℓ (oddPartner ℓ c₁) * + oddPartnerSign ℓ (oddPartner ℓ c₂) : ℤ) : ℂ) = + ((oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂ : ℤ) : ℂ) := by + rw [oddPartnerSign_oddPartner, oddPartnerSign_oddPartner, + neg_mul_neg] + rw [hback, hsgn] at hkey + calc F.throughSummand hM st hbnd o n + = 1 * F.throughSummand hM st hbnd o n := (one_mul _).symm + _ = ((oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂ : ℤ) : ℂ) * + (((oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂ : ℤ) : ℂ) * + F.throughSummand hM st hbnd o n) := by + rw [← mul_assoc, signPairSq] + _ = ((oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂ : ℤ) : ℂ) * + F.throughSummand hM (stateOddFlip st i₁ i₂) + (genBoundarySubsetMatches_stateOddFlip hbnd i₁ i₂) + (o.portFlip h) n := by + rw [← hkey] + +end FlipLedger + +section ChainRecanon + +/-- **One-chain re-canonicalization**: for any orientation and any +participating boundary flag `β` with internal entry partner, there +is an orientation of the *same* system that toggles the chain +direction at `β` and its path match, preserves the chain direction +of every other boundary flag, and satisfies the inverted value +ledger with the chain's two boundary labels explicit. -/ +theorem exists_chainRecanonicalize + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {k : ℕ} {ℓ : ℕ} + (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (o : κ.Orientation) {β : W.Flag} + (hβ : β ∈ F.boundaryFlags) + (hint : W.pairing β ∈ F.internalFlags) + {c₁ c₂ : Fin (2 * ℓ)} + (hc₁ : st (F.boundaryLabel hβ) = Sum.inr c₁) + (hc₂ : st (F.boundaryLabel (κ.pathMatch_mem hβ)) = + Sum.inr c₂) : + ∃ o₁ : κ.Orientation, + chainDir o₁ β = !chainDir o β ∧ + chainDir o₁ (κ.pathMatch β hβ) = + !chainDir o (κ.pathMatch β hβ) ∧ + (∀ γ ∈ F.boundaryFlags, γ ≠ β → γ ≠ κ.pathMatch β hβ → + chainDir o₁ γ = chainDir o γ) ∧ + ∀ n, F.throughSummand hM st hbnd o n = + ((oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂ : ℤ) : ℂ) * + F.throughSummand hM + (stateOddFlip st (F.boundaryLabel hβ) + (F.boundaryLabel (κ.pathMatch_mem hβ))) + (genBoundarySubsetMatches_stateOddFlip hbnd + (F.boundaryLabel hβ) + (F.boundaryLabel (κ.pathMatch_mem hβ))) o₁ n := by + obtain ⟨S, hS, hp₂S, hdisj⟩ := exists_chainFlipSet hβ hint + refine ⟨o.portFlip hS, ?_, ?_, ?_, ?_⟩ + · exact chainDir_portFlip_of_mem o hS hS.hp₁S + · exact chainDir_portFlip_of_mem o hS hp₂S + · intro γ hγ h1 h2 + exact chainDir_portFlip_of_notMem o hS (hdisj γ hγ h1 h2) + · intro n + exact throughSummand_portFlip_inv hM st hbnd o hS hc₁ hc₂ n + +end ChainRecanon + +/-! ## The anti-canonical chain set and full re-canonicalization -/ + +/-- The set of *low* chain ends whose chain is directed against the +canonical frame: participating boundary flags that are the +low-labelled end of their chord and whose entry edge is outgoing. +Each anti-canonical chain contributes exactly one element — its low +end. -/ +noncomputable def antiLowSet [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + (o : κ.Orientation) : + Finset W.Flag := + F.boundaryFlags.filter (fun β => + ∃ hβ : β ∈ F.boundaryFlags, + W.pairing β ∈ F.internalFlags ∧ + F.boundaryLabel hβ < + F.boundaryLabel (κ.pathMatch_mem hβ) ∧ + chainDir o β = true) + +/-- Membership in the anti-canonical set: the low end of a chain +that runs the wrong way — exactly the chains re-canonicalization +flips. -/ +theorem mem_antiLowSet [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + {o : κ.Orientation} {β : W.Flag} : + β ∈ antiLowSet o ↔ + ∃ hβ : β ∈ F.boundaryFlags, + W.pairing β ∈ F.internalFlags ∧ + F.boundaryLabel hβ < + F.boundaryLabel (κ.pathMatch_mem hβ) ∧ + chainDir o β = true := by + unfold antiLowSet + rw [Finset.mem_filter] + constructor + · rintro ⟨-, h⟩ + exact h + · rintro ⟨hβ, h⟩ + exact ⟨hβ, hβ, h⟩ + +/-- An orientation is path-canonical exactly when its anti-canonical +low-end set is empty. -/ +theorem pathCanonical_iff_antiLowSet_empty + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + (o : κ.Orientation) : + PathCanonical o ↔ antiLowSet o = ∅ := by + rw [pathCanonical_iff_chainDir] + constructor + · intro H + refine Finset.eq_empty_of_forall_notMem (fun β hβmem => ?_) + obtain ⟨hβ, hint, hlow, hdir⟩ := mem_antiLowSet.mp hβmem + rw [H β hβ hint hlow] at hdir + cases hdir + · intro H β hβ hint hlow + cases hdir : chainDir o β + · rfl + · exact absurd + (mem_antiLowSet.mpr ⟨hβ, hint, hlow, hdir⟩) + (by rw [H]; exact Finset.notMem_empty β) + +/-- A low chain end is never the path match of a low chain end: the +path match of a low end is the high end of the same chord. -/ +theorem low_ne_pathMatch_of_low + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + {β γ : W.Flag} + (hβ : β ∈ F.boundaryFlags) (hγ : γ ∈ F.boundaryFlags) + (hlowβ : F.boundaryLabel hβ < + F.boundaryLabel (κ.pathMatch_mem hβ)) + (hlowγ : F.boundaryLabel hγ < + F.boundaryLabel (κ.pathMatch_mem hγ)) : + γ ≠ κ.pathMatch β hβ := by + intro heq + have h1 : F.boundaryLabel hγ = + F.boundaryLabel (κ.pathMatch_mem hβ) := + boundaryLabel_congr hγ (κ.pathMatch_mem hβ) heq + have hinv : κ.pathMatch γ hγ = β := by + rw [κ.pathMatch_congr heq hγ (κ.pathMatch_mem hβ)] + exact κ.pathMatch_invol hβ + have h2 : F.boundaryLabel (κ.pathMatch_mem hγ) = + F.boundaryLabel hβ := + boundaryLabel_congr (κ.pathMatch_mem hγ) hβ hinv + rw [h1, h2] at hlowγ + exact lt_asymm hlowβ hlowγ + +/-- **The flip step shrinks the anti-canonical set by exactly its +chain**: an orientation that toggles the chain direction at an +anti-canonical low end `β` (and possibly at `β`'s path match) and +preserves every other chain direction has anti-canonical set +`antiLowSet o` minus `β`. -/ +theorem antiLowSet_flip [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + {o o₁ : κ.Orientation} {β : W.Flag} + (hβ : β ∈ F.boundaryFlags) (hβmem : β ∈ antiLowSet o) + (hd₁ : chainDir o₁ β = !chainDir o β) + (hpres : ∀ γ ∈ F.boundaryFlags, γ ≠ β → + γ ≠ κ.pathMatch β hβ → chainDir o₁ γ = chainDir o γ) : + antiLowSet o₁ = (antiLowSet o).erase β := by + obtain ⟨hβ', hint, hlow, hdir⟩ := mem_antiLowSet.mp hβmem + apply Finset.ext + intro γ + rw [Finset.mem_erase, mem_antiLowSet, mem_antiLowSet] + constructor + · rintro ⟨hγ, hintγ, hlowγ, hdirγ⟩ + have hγβ : γ ≠ β := by + rintro rfl + rw [hd₁, hdir] at hdirγ + exact Bool.false_ne_true hdirγ + have hγpm : γ ≠ κ.pathMatch β hβ := + low_ne_pathMatch_of_low hβ hγ hlow hlowγ + refine ⟨hγβ, hγ, hintγ, hlowγ, ?_⟩ + rw [← hpres γ hγ hγβ hγpm] + exact hdirγ + · rintro ⟨hγβ, hγ, hintγ, hlowγ, hdirγ⟩ + have hγpm : γ ≠ κ.pathMatch β hβ := + low_ne_pathMatch_of_low hβ hγ hlow hlowγ + refine ⟨hγ, hintγ, hlowγ, ?_⟩ + rw [hpres γ hγ hγβ hγpm] + exact hdirγ + +section Recanonicalize + +/-- **Full re-canonicalization**: any orientation of a relative +transition system is connected to a path-canonical orientation of +the *same* system by a value ledger — the summand at the original +data equals a sign (a product of chain-end colour sign pairs, hence +squaring to `1`) times the summand of the canonical orientation at +an iterated `∂`-relabel of the state. Induction on the number of +anti-canonical chains, flipping one chain per step via +`exists_chainRecanonicalize`. -/ +theorem exists_recanonicalize + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {k : ℕ} {ℓ : ℕ} + (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (o : κ.Orientation) : + ∃ (o₁ : κ.Orientation) (s : ℂ) + (st₁ : GenBoundaryState k ℓ α) + (hbnd₁ : genBoundarySubsetMatches W F.flags st₁), + PathCanonical o₁ ∧ s * s = 1 ∧ + ∀ n, F.throughSummand hM st hbnd o n = + s * F.throughSummand hM st₁ hbnd₁ o₁ n := by + suffices H : ∀ (N : ℕ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (o : κ.Orientation), (antiLowSet o).card = N → + ∃ (o₁ : κ.Orientation) (s : ℂ) + (st₁ : GenBoundaryState k ℓ α) + (hbnd₁ : genBoundarySubsetMatches W F.flags st₁), + PathCanonical o₁ ∧ s * s = 1 ∧ + ∀ n, F.throughSummand hM st hbnd o n = + s * F.throughSummand hM st₁ hbnd₁ o₁ n by + exact H _ st hbnd o rfl + intro N + induction N with + | zero => + intro st hbnd o hcard + refine ⟨o, 1, st, hbnd, ?_, mul_one 1, + fun n => (one_mul _).symm⟩ + rw [pathCanonical_iff_antiLowSet_empty] + exact Finset.card_eq_zero.mp hcard + | succ N ih => + intro st hbnd o hcard + have hne : (antiLowSet o).Nonempty := by + rw [← Finset.card_pos, hcard] + omega + obtain ⟨β, hβmem⟩ := hne + obtain ⟨hβ, hint, hlow, hdir⟩ := mem_antiLowSet.mp hβmem + obtain ⟨c₁, hc₁⟩ : + ∃ c, st (F.boundaryLabel hβ) = Sum.inr c := by + apply (hbnd _).mp + have he : W.boundaryFlag (F.boundaryLabel hβ) = β := + (W.eq_boundaryFlag _ β (attach_boundaryLabel hβ)).symm + rw [he] + exact mem_flags_of_boundaryFlags F hβ + obtain ⟨c₂, hc₂⟩ : + ∃ c, st (F.boundaryLabel (κ.pathMatch_mem hβ)) = + Sum.inr c := by + apply (hbnd _).mp + have he : W.boundaryFlag + (F.boundaryLabel (κ.pathMatch_mem hβ)) = + κ.pathMatch β hβ := + (W.eq_boundaryFlag _ _ + (attach_boundaryLabel (κ.pathMatch_mem hβ))).symm + rw [he] + exact mem_flags_of_boundaryFlags F (κ.pathMatch_mem hβ) + obtain ⟨o₁, hd₁, hd₂, hpres, hled⟩ := + exists_chainRecanonicalize hM st hbnd o hβ hint hc₁ hc₂ + have hset : antiLowSet o₁ = (antiLowSet o).erase β := + antiLowSet_flip hβ hβmem hd₁ hpres + have hcard₁ : (antiLowSet o₁).card = N := by + rw [hset, Finset.card_erase_of_mem hβmem, hcard] + omega + obtain ⟨o₂, s, st₂, hbnd₂, hcanon, hs, hled₂⟩ := + ih (stateOddFlip st (F.boundaryLabel hβ) + (F.boundaryLabel (κ.pathMatch_mem hβ))) + (genBoundarySubsetMatches_stateOddFlip hbnd + (F.boundaryLabel hβ) + (F.boundaryLabel (κ.pathMatch_mem hβ))) o₁ hcard₁ + refine ⟨o₂, + ((oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂ : ℤ) : ℂ) * s, + st₂, hbnd₂, hcanon, ?_, ?_⟩ + · have hmul : ∀ a b : ℂ, a * a = 1 → b * b = 1 → + (a * b) * (a * b) = 1 := by + intro a b ha hb + calc (a * b) * (a * b) = (a * a) * (b * b) := by ring + _ = 1 := by rw [ha, hb, one_mul] + exact hmul _ _ (signPairSq ℓ c₁ c₂) hs + · intro n + rw [hled n, hled₂ n, mul_assoc] + +end Recanonicalize + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChainAgreement.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChainAgreement.lean new file mode 100644 index 0000000000..34ef5d6690 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChainAgreement.lean @@ -0,0 +1,323 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathCanon + +/-! +# Chain agreement of path-canonical orientations + +Two path-canonical orientations of the same boundary-relative +transition system agree on every non-periodic internal flag: a +non-periodic flag lies on the boundary-to-boundary chain of a unique +pair of boundary ends, the low-labelled end's entry value is pinned to +incoming by canonicality, and orientation values propagate rigidly +along a chain (`match_flip` and `pairing_flip` alternate), so the +whole chain's values are determined by the pinned seed. + +## Main results + +* `pathCanonical_agree_nonperiodic` — path-canonical orientations + agree off the periodic flags. +* `pathCanonical_diff_pairing_closed` — hence their difference set is + pairing-closed on internal flags (disagreement forces periodicity, + and periodic flags have internal pairings). +* `throughSummand_pathCanonical` — hence the constrained summand does + not depend on the choice of path-canonical orientation, discharging + the `hchain` hypothesis of `throughSummand_canonical_unique`. + +## Proof route + +1. `traceChain_some_exit` converts a terminating chain into walk + data: an exit step count with internal pairings before it. +2. `isOut_iterWalk_eq_not_seed` / `isOut_pairing_iterWalk_eq_seed` + propagate any orientation's value along a chain: every match-side + flag carries the negated seed value, every pairing-side flag the + seed value, where the seed is the value at the entry edge. +3. `pathCanonical_agree_on_chain` compares the two chain ends by + label; canonicality pins the seed at the low end, and the reverse + walk identities transport the pinned value to the given flag. +4. `pathCanonical_agree_nonperiodic` places an arbitrary + non-periodic internal flag on the chain of the boundary end its + forward walk reaches, as a pairing-side flag of the reverse + chain. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} + +namespace EdgeSubset + +/-! ### 1. From terminating chains to walk exit data -/ + +/-- A terminating chain yields walk data: an exit step `k` whose +earlier pairings are all internal and whose pairing at `k` is the +boundary result. -/ +theorem traceChain_some_exit {W : Fragment α} {F : EdgeSubset W} + (κ : F.RelTransitionSystem) : + ∀ (fuel : ℕ) (f b : W.Flag), traceChain κ fuel f = some b → + ∃ k, (∀ j, j < k → + W.pairing (iterWalk κ f j) ∈ F.internalFlags) ∧ + W.pairing (iterWalk κ f k) = b ∧ b ∈ F.boundaryFlags := by + intro fuel + induction fuel with + | zero => intro f b h; simp [traceChain] at h + | succ n ih => + intro f b h + by_cases hb : W.pairing f ∈ F.boundaryFlags + · rw [traceChain_boundary κ n f hb] at h + refine ⟨0, fun j hj => absurd hj (by omega), ?_, ?_⟩ + · simpa using Option.some.inj h + · rw [← Option.some.inj h]; exact hb + · by_cases hi : W.pairing f ∈ F.internalFlags + · rw [traceChain_internal κ n f hi] at h + obtain ⟨k, hcont, hexit, hbb⟩ := + ih (κ.match_ (W.pairing f)) b h + refine ⟨k + 1, ?_, ?_, hbb⟩ + · intro j hj + cases j with + | zero => simpa using hi + | succ j' => + have hstep := hcont j' (by omega) + rwa [iterWalk_shift] at hstep + · rwa [iterWalk_shift] at hexit + · rw [traceChain_neither κ n f hb hi] at h; cases h + +/-! ### 2. Rigid propagation of orientation values along a chain -/ + +/-- **Match-side propagation**: along a walk with internal pairings +up to step `k`, every visited flag (step `1 ≤ j ≤ k`) carries the +negated seed value, for any orientation. -/ +theorem isOut_iterWalk_eq_not_seed {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + (o : κ.Orientation) {b : W.Flag} {k : ℕ} + (hcont : ∀ t, t < k → + W.pairing (iterWalk κ b t) ∈ F.internalFlags) : + ∀ j, 1 ≤ j → j ≤ k → + o.isOut (iterWalk κ b j) = !o.isOut (W.pairing b) := by + intro j + induction j with + | zero => intro h1 _; exact absurd h1 (by omega) + | succ j ih => + intro _ hjk + rcases Nat.eq_zero_or_pos j with rfl | hj1 + · have h0 : W.pairing (iterWalk κ b 0) ∈ F.internalFlags := + hcont 0 (by omega) + rw [iterWalk_succ, o.match_flip _ h0, iterWalk_zero] + · have hpj : W.pairing (iterWalk κ b j) ∈ F.internalFlags := + hcont j (by omega) + have hwj : iterWalk κ b j ∈ F.internalFlags := + iterWalk_mem_internal κ k hj1 (by omega) hcont + rw [iterWalk_succ, o.match_flip _ hpj, + o.pairing_flip _ hwj hpj, Bool.not_not] + exact ih hj1 (by omega) + +/-- **Pairing-side propagation**: along a walk with internal +pairings up to step `k`, every intermediate pairing (step `j < k`) +carries the seed value, for any orientation. -/ +theorem isOut_pairing_iterWalk_eq_seed {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + (o : κ.Orientation) {b : W.Flag} {k : ℕ} + (hcont : ∀ t, t < k → + W.pairing (iterWalk κ b t) ∈ F.internalFlags) : + ∀ j, j < k → + o.isOut (W.pairing (iterWalk κ b j)) = + o.isOut (W.pairing b) := by + intro j hj + rcases Nat.eq_zero_or_pos j with rfl | hj1 + · rfl + · have hpj : W.pairing (iterWalk κ b j) ∈ F.internalFlags := + hcont j hj + have hwj : iterWalk κ b j ∈ F.internalFlags := + iterWalk_mem_internal κ k hj1 (by omega) hcont + rw [o.pairing_flip _ hwj hpj, + isOut_iterWalk_eq_not_seed o hcont j hj1 (by omega), + Bool.not_not] + +/-! ### 3. Chain agreement from the low-end seed -/ + +/-- **Agreement on a chain**: two path-canonical orientations agree +on every pairing-side flag of a boundary-terminated chain — whichever +end has the lower label, canonicality pins its entry value to +incoming for both orientations, and rigid propagation transports the +pinned seed to the given flag. -/ +theorem pathCanonical_agree_on_chain + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + {o o' : κ.Orientation} + (hc : PathCanonical o) (hc' : PathCanonical o') + {b : W.Flag} (hb : b ∈ F.boundaryFlags) {k : ℕ} + (hcont : ∀ t, t < k → + W.pairing (iterWalk κ b t) ∈ F.internalFlags) + (hterm : W.pairing (iterWalk κ b k) ∈ F.boundaryFlags) + (hkle : k ≤ F.flags.card) {m : ℕ} (hm : m < k) : + o.isOut (W.pairing (iterWalk κ b m)) = + o'.isOut (W.pairing (iterWalk κ b m)) := by + -- the chain's other end is the path match of `b` + have hpm : κ.pathMatch b hb = W.pairing (iterWalk κ b k) := + κ.pathMatch_eq hb (traceChain_fuel_mono κ (by omega) + (traceChain_forward κ b hcont hterm)) + -- name the two boundary labels + obtain ⟨iℓ, hiℓ⟩ := attach_boundary_of_mem F hb + have hbi : b = W.boundaryFlag iℓ := W.eq_boundaryFlag iℓ b hiℓ + obtain ⟨jℓ, hjℓ⟩ := attach_boundary_of_mem F hterm + have hbj : W.pairing (iterWalk κ b k) = W.boundaryFlag jℓ := + W.eq_boundaryFlag jℓ _ hjℓ + have hne_label : iℓ ≠ jℓ := by + intro hEq + apply κ.pathMatch_ne_self hb + rw [hpm, hbj, ← hEq, ← hbi] + rcases lt_or_gt_of_ne hne_label with hij | hji + · -- `b` is the low end: canonicality pins the seed at `pairing b` + have hbB : W.boundaryFlag iℓ ∈ F.boundaryFlags := by + rw [← hbi]; exact hb + have hpair_int : + W.pairing (W.boundaryFlag iℓ) ∈ F.internalFlags := by + rw [← hbi]; exact hcont 0 (by omega) + have hpm' : κ.pathMatch (W.boundaryFlag iℓ) hbB = + W.boundaryFlag jℓ := by + rw [← hbj, ← hpm] + exact κ.pathMatch_congr hbi.symm hbB hb + have seedo : o.isOut (W.pairing b) = false := by + rw [hbi]; exact hc iℓ jℓ hbB hpair_int hpm' hij + have seedo' : o'.isOut (W.pairing b) = false := by + rw [hbi]; exact hc' iℓ jℓ hbB hpair_int hpm' hij + rw [isOut_pairing_iterWalk_eq_seed o hcont m hm, + isOut_pairing_iterWalk_eq_seed o' hcont m hm, seedo, seedo'] + · -- the far end is the low end: pin its seed and walk back + have hb2B : W.boundaryFlag jℓ ∈ F.boundaryFlags := by + rw [← hbj]; exact hterm + have hpair2_int : + W.pairing (W.boundaryFlag jℓ) ∈ F.internalFlags := by + rw [← hbj, W.pairing_invol] + exact iterWalk_mem_internal κ k (by omega) le_rfl hcont + have hpminv : κ.pathMatch (W.boundaryFlag jℓ) hb2B = + W.boundaryFlag iℓ := by + rw [← hbi] + have h1 : κ.pathMatch (W.boundaryFlag jℓ) hb2B = + κ.pathMatch (κ.pathMatch b hb) (κ.pathMatch_mem hb) := by + apply κ.pathMatch_congr + rw [← hbj] + exact hpm.symm + rw [h1, κ.pathMatch_invol hb] + have seedo2 : o.isOut (W.pairing (W.boundaryFlag jℓ)) = false := + hc jℓ iℓ hb2B hpair2_int hpminv hji + have seedo2' : + o'.isOut (W.pairing (W.boundaryFlag jℓ)) = false := + hc' jℓ iℓ hb2B hpair2_int hpminv hji + have hseed : + o.isOut (W.pairing (W.pairing (iterWalk κ b k))) = false := + by rw [hbj]; exact seedo2 + have hseed' : + o'.isOut (W.pairing (W.pairing (iterWalk κ b k))) = false := + by rw [hbj]; exact seedo2' + -- the reverse chain from the far end + have hcont2 : ∀ t, t < k → + W.pairing (iterWalk κ (W.pairing (iterWalk κ b k)) t) ∈ + F.internalFlags := + fun t ht => reverse_chain_continues κ hb hcont t ht + have hfm : iterWalk κ (W.pairing (iterWalk κ b k)) (k - m) = + W.pairing (iterWalk κ b m) := by + have hrev := iterWalk_reverse κ hcont (k - m) (by omega) + rwa [show k - (k - m) = m from by omega] at hrev + have ho := isOut_iterWalk_eq_not_seed o hcont2 (k - m) + (by omega) (by omega) + have ho' := isOut_iterWalk_eq_not_seed o' hcont2 (k - m) + (by omega) (by omega) + rw [hfm, hseed, Bool.not_false] at ho + rw [hfm, hseed', Bool.not_false] at ho' + rw [ho, ho'] + +/-! ### Agreement off the periodic flags -/ + +/-- **Chain agreement of path-canonical orientations**: two +path-canonical orientations of one relative transition system agree +on every non-periodic internal flag. -/ +theorem pathCanonical_agree_nonperiodic + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + {o o' : κ.Orientation} + (hc : PathCanonical o) (hc' : PathCanonical o') : + ∀ f ∈ F.internalFlags, ¬ κ.PeriodicFlag f → + o.isOut f = o'.isOut f := by + intro f hf hnper + -- the forward walk from `f` exits at a boundary flag + obtain ⟨fuel, b0, hchain⟩ := + (internal_periodic_or_terminates κ f hf).resolve_left hnper + obtain ⟨kf, hcontf, hexitf, hb0⟩ := + traceChain_some_exit κ fuel f b0 hchain + have hbf : W.pairing (iterWalk κ f kf) ∈ F.boundaryFlags := by + rw [hexitf]; exact hb0 + -- the reverse chain from that boundary end runs past `f` + have hcontb : ∀ t, t ≤ kf → + W.pairing (iterWalk κ (W.pairing (iterWalk κ f kf)) t) ∈ + F.internalFlags := by + intro t ht + rw [iterWalk_reverse κ hcontf t ht, W.pairing_invol] + rcases Nat.lt_or_ge t kf with h | h + · exact iterWalk_mem_internal κ kf (by omega) (by omega) hcontf + · rw [show kf - t = 0 from by omega, iterWalk_zero] + exact hf + -- the full chain from the boundary end + obtain ⟨k', hk'le, hcont', hterm'⟩ := + chain_terminates_with_data κ hbf + have hk'gt : kf < k' := by + by_contra hle + exact Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags + (hcontb k' (by omega)) hterm' + -- `f` is the pairing-side flag of that chain at step `kf` + have hfeq : + W.pairing (iterWalk κ (W.pairing (iterWalk κ f kf)) kf) = + f := reverse_chain_terminates κ hcontf + have hagree := pathCanonical_agree_on_chain hc hc' hbf hcont' + hterm' hk'le (m := kf) hk'gt + rwa [hfeq] at hagree + +/-! ### 5. Corollaries -/ + +/-- **Pairing-closure of the difference set**: where two +path-canonical orientations disagree, the flag is periodic, so its +pairing is internal — exactly the `hchain` hypothesis of +`throughSummand_canonical_unique`. -/ +theorem pathCanonical_diff_pairing_closed + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + {o o' : κ.Orientation} + (hc : PathCanonical o) (hc' : PathCanonical o') : + ∀ f ∈ F.internalFlags, o.isOut f ≠ o'.isOut f → + W.pairing f ∈ F.internalFlags := by + intro f hf hne + by_cases hper : κ.PeriodicFlag f + · have hp := all_pairings_internal_of_periodic κ hper 0 + simpa using hp + · exact absurd (pathCanonical_agree_nonperiodic hc hc' f hf hper) + hne + +/-- **Well-definedness of the canonical summand**: the constrained +summand agrees across all path-canonical orientations of one +relative transition system, unconditionally. -/ +theorem throughSummand_pathCanonical + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ : F.RelTransitionSystem} {o o' : κ.Orientation} + (hc : PathCanonical o) (hc' : PathCanonical o') (c : ℕ) : + F.throughSummand h st hbnd o c = + F.throughSummand h st hbnd o' c := + throughSummand_canonical_unique h st hbnd hc hc' + (pathCanonical_diff_pairing_closed hc hc') c + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordCount.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordCount.lean new file mode 100644 index 0000000000..fdf6046ac4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordCount.lean @@ -0,0 +1,115 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCrossDelta + +/-! +# The chord diagram has half as many chords as the subset has boundary flags + +Each chord is the sorted pair of a boundary flag's label and its chain +partner's, so the two ends of a chord give the same chord and nothing +else does. The map from boundary flags to chords is therefore two to +one, and the diagram's cardinality is half the boundary's. + +This is what makes "the number of chords" a single notion: it is +`oddLabelCount / 2` read off the state, and `labelChords.card` read off +the diagram, and they agree. +-/ + +@[expose] public section + +namespace RS + + + +namespace EdgeSubset + +variable {α : Type} + +end EdgeSubset + +/-! ### Degenerate chords never cross + +A label outside the subset contributes a chord with both ends at +itself. Crossing asks for a strict interleaving, so such a chord +crosses nothing and counts for nothing — which is why an involution +extended by the identity off a subset has the crossing count of its +genuine chords alone. +-/ + +namespace EdgeSubset + +variable {α : Type} + +/-! ### The involution a subset induces on the interface labels + +Chords pair up the labels a subset uses. Extending by the identity off +those labels gives an involution of the whole interface, whose genuine +chords are the subset's and whose fixed points are the unused labels. +This is the object the restriction transports are applied to. +-/ + +/-- A boundary flag's label is its own index. -/ +theorem boundaryLabel_boundaryFlag {W : Fragment α} + (F : EdgeSubset W) {i : α} + (h : W.boundaryFlag i ∈ F.boundaryFlags) : F.boundaryLabel h = i := + boundaryLabel_eq_of_attach h (W.attach_boundaryFlag i) + +/-- The label a subset's chain carries a used label to; the identity on +unused ones. -/ +noncomputable def chordInv {W : Fragment α} + (F : EdgeSubset W) (κ : F.RelTransitionSystem) + (i : α) : α := + if h : W.boundaryFlag i ∈ F.boundaryFlags then + F.boundaryLabel (κ.pathMatch_mem h) else i + +/-- A used label's image is used. -/ +theorem boundaryFlag_chordInv {W : Fragment α} + (F : EdgeSubset W) + (κ : F.RelTransitionSystem) {i : α} + (h : W.boundaryFlag i ∈ F.boundaryFlags) : + W.boundaryFlag (chordInv F κ i) = κ.pathMatch (W.boundaryFlag i) h := by + unfold chordInv + rw [dite_eq_left h] + exact (W.eq_boundaryFlag _ _ (attach_boundaryLabel (κ.pathMatch_mem h))).symm + +/-- The chord partner of a participating boundary label is itself +participating. -/ +theorem chordInv_mem {W : Fragment α} + (F : EdgeSubset W) (κ : F.RelTransitionSystem) + {i : α} (h : W.boundaryFlag i ∈ F.boundaryFlags) : + W.boundaryFlag (chordInv F κ i) ∈ F.boundaryFlags := by + rw [boundaryFlag_chordInv F κ h] + exact κ.pathMatch_mem h + +/-- **The induced map is an involution.** -/ +theorem chordInv_invol {W : Fragment α} + (F : EdgeSubset W) (κ : F.RelTransitionSystem) + (i : α) : chordInv F κ (chordInv F κ i) = i := by + by_cases h : W.boundaryFlag i ∈ F.boundaryFlags + · have h2 := chordInv_mem F κ h + refine W.boundaryFlag_injective ?_ + rw [boundaryFlag_chordInv F κ h2, + κ.pathMatch_congr (boundaryFlag_chordInv F κ h) h2 + (κ.pathMatch_mem h)] + exact κ.pathMatch_invol h + · unfold chordInv + rw [dite_eq_right h, dite_eq_right h] + +/-- **The induced map is fixed-point-free on the used labels.** -/ +theorem chordInv_ne {W : Fragment α} + (F : EdgeSubset W) (κ : F.RelTransitionSystem) + {i : α} (h : W.boundaryFlag i ∈ F.boundaryFlags) : + chordInv F κ i ≠ i := by + intro hx + refine κ.pathMatch_ne_self h ?_ + rw [← boundaryFlag_chordInv F κ h, hx] + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordLabels.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordLabels.lean new file mode 100644 index 0000000000..c68b4a5055 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordLabels.lean @@ -0,0 +1,127 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSignature +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordSwapParity + +/-! +# Boundary chord labels + +The label of a boundary flag, extraction lemmas, and the crossing +relation rewritten as an order condition on the four labels — the +concrete bridge from `chordCrossingCount` to the abstract chord +parity layer. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} + +namespace EdgeSubset + +/-- The boundary label of a boundary flag. -/ +noncomputable def boundaryLabel {W : Fragment α} + (F : EdgeSubset W) {f : W.Flag} + (hf : f ∈ F.boundaryFlags) : α := + Classical.choose (F.attach_boundary_of_mem hf) + +/-- The defining equation of the boundary label. -/ +theorem attach_boundaryLabel {W : Fragment α} {F : EdgeSubset W} + {f : W.Flag} + (hf : f ∈ F.boundaryFlags) : + W.attach f = Sum.inr (F.boundaryLabel hf) := + Classical.choose_spec (F.attach_boundary_of_mem hf) + +/-- The label determines the attachment. -/ +theorem boundaryLabel_eq_of_attach {W : Fragment α} {F : EdgeSubset W} + {f : W.Flag} {i : α} + (hf : f ∈ F.boundaryFlags) (h : W.attach f = Sum.inr i) : + F.boundaryLabel hf = i := + Sum.inr.inj ((attach_boundaryLabel hf).symm.trans h) + +/-- **A boundary flag is the flag of its own label.** -/ +theorem boundaryFlag_boundaryLabel {W : Fragment α} + {f : W.Flag} {F : EdgeSubset W} + (hf : f ∈ F.boundaryFlags) : + W.boundaryFlag (F.boundaryLabel hf) = f := + (W.eq_boundaryFlag (F.boundaryLabel hf) f + (EdgeSubset.attach_boundaryLabel hf)).symm + +/-- Distinct boundary flags carry distinct labels. -/ +theorem boundaryLabel_inj {W : Fragment α} {F : EdgeSubset W} + {f g : W.Flag} + (hf : f ∈ F.boundaryFlags) (hg : g ∈ F.boundaryFlags) + (h : F.boundaryLabel hf = F.boundaryLabel hg) : f = g := by + have h1 := W.eq_boundaryFlag (F.boundaryLabel hf) f + (attach_boundaryLabel hf) + have h2 := W.eq_boundaryFlag (F.boundaryLabel hg) g + (attach_boundaryLabel hg) + rw [h1, h2, h] + +/-- The boundary label does not depend on the membership proof. -/ +theorem boundaryLabel_congr {W : Fragment α} {F : EdgeSubset W} + {f g : W.Flag} + (hf : f ∈ F.boundaryFlags) (hg : g ∈ F.boundaryFlags) + (h : f = g) : F.boundaryLabel hf = F.boundaryLabel hg := by + subst h + rfl + +/-- **The crossing relation on labels**: `ChordCross` is exactly +the four-label interleaving condition (each chord low-to-high, the +first chord starting first). -/ +theorem chordCross_iff_labels + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + (b b' : {x : W.Flag // x ∈ F.boundaryFlags}) : + ChordCross κ b b' ↔ + (F.boundaryLabel b.prop < + F.boundaryLabel (κ.pathMatch_mem b.prop) ∧ + F.boundaryLabel b'.prop < + F.boundaryLabel (κ.pathMatch_mem b'.prop) ∧ + F.boundaryLabel b.prop < F.boundaryLabel b'.prop ∧ + F.boundaryLabel b'.prop < + F.boundaryLabel (κ.pathMatch_mem b.prop) ∧ + F.boundaryLabel (κ.pathMatch_mem b.prop) < + F.boundaryLabel (κ.pathMatch_mem b'.prop)) := by + unfold ChordCross + constructor + · rintro ⟨i, j, i', j', hbi, hpj, hbi', hpj', h1, h2, h3, h4, h5⟩ + rw [boundaryLabel_eq_of_attach b.prop hbi, + boundaryLabel_eq_of_attach (κ.pathMatch_mem b.prop) hpj, + boundaryLabel_eq_of_attach b'.prop hbi', + boundaryLabel_eq_of_attach (κ.pathMatch_mem b'.prop) hpj'] + exact ⟨h1, h2, h3, h4, h5⟩ + · rintro ⟨h1, h2, h3, h4, h5⟩ + exact ⟨F.boundaryLabel b.prop, + F.boundaryLabel (κ.pathMatch_mem b.prop), + F.boundaryLabel b'.prop, + F.boundaryLabel (κ.pathMatch_mem b'.prop), + attach_boundaryLabel b.prop, + attach_boundaryLabel (κ.pathMatch_mem b.prop), + attach_boundaryLabel b'.prop, + attach_boundaryLabel (κ.pathMatch_mem b'.prop), + h1, h2, h3, h4, h5⟩ + +end EdgeSubset + +/-- Expansion of a sum over a four-element finset literal. -/ +theorem sum_quad {β : Type} [DecidableEq β] {x y z w : β} + (hxy : x ≠ y) (hxz : x ≠ z) (hxw : x ≠ w) + (hyz : y ≠ z) (hyw : y ≠ w) (hzw : z ≠ w) (f : β → ℕ) : + ∑ t ∈ ({x, y, z, w} : Finset β), f t = + f x + (f y + (f z + f w)) := by + rw [Finset.sum_insert (by simp [hxy, hxz, hxw]), + Finset.sum_insert (by simp [hyz, hyw]), + Finset.sum_insert (by simp [hzw]), + Finset.sum_singleton] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordParity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordParity.lean new file mode 100644 index 0000000000..5f62d431c5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordParity.lean @@ -0,0 +1,36 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathCanon +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof + +/-! +# The between-legs parity identity + +The abstract heart of the canonical splitting's cut sign: for any +family of chords, the number of chord ends strictly between the +cut labels has the parity of the number of chords crossing the +cut — a nested chord contributes both ends, a crossing chord +exactly one. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} + +/-- A chord crosses the cut when exactly one endpoint lies +between the cut labels. -/ +def CrossesCut [LinearOrder α] + (i j : α) (p : α × α) : Prop := + Xor (i < p.1 ∧ p.1 < j) (i < p.2 ∧ p.2 < j) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordSwapParity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordSwapParity.lean new file mode 100644 index 0000000000..2f368b52ce --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordSwapParity.lean @@ -0,0 +1,52 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordParity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger + +/-! +# Chord re-pairing parity: the bridge and the crossing table + +Three pieces of pure order-combinatorics glue on top of the two +coexisting crossing predicates: + +* the **bridge** between the cut-style predicate `CrossesCut` + (`ChordParity.lean`) and the chord-style predicate + `ChordPairCross` (`PathLedger.lean`), under the normalization + hypotheses of `chordPairCross_iff_xor`; +* the **mutual-crossing table** for four strictly ordered points in + `ChordPairCross` vocabulary — parallel and nested chords do not + cross, interleaved chords do; +* the **summed transfer**: over a finite family of normalized third + chords avoiding the four points, re-pairing two chords preserves + the total crossing parity (`third_chord_reparity` per element). +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} + +/-! ## The bridge between the two crossing predicates -/ + +/-- **The bridge**: the cut-style crossing predicate of +`ChordParity.lean` agrees with the chord-style crossing predicate +of `PathLedger.lean`, for a chord recorded low-to-high whose ends +avoid the matching ends of the cut. -/ +theorem crossesCut_iff_chordPairCross [LinearOrder α] + {x y u w : α} + (huw : u < w) (hux : u ≠ x) (hwy : w ≠ y) : + CrossesCut x y (u, w) ↔ ChordPairCross x y u w := by + rw [chordPairCross_iff_xor huw hux hwy] + unfold CrossesCut InsideChord + exact Iff.rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotate.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotate.lean new file mode 100644 index 0000000000..1457a7978c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotate.lean @@ -0,0 +1,1382 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc + +/-! +# Rotation of closures + +The closure of a composite equals the closure of the first factor +against the rotated composite (`pairCloseComposeRotate`): for an +`(m,n)`-fragment `F`, an `(n,p)`-fragment `H`, and an +`(m+p)`-fragment `K`, + + (F ∘ H) ∗ K ≃ F ∗ (K ∘ Hᵀ), + +where `Hᵀ` transposes the boundary of `H`. Both sides glue the +same three interface blocks over the common ambient `(F ⊔ H) ⊔ K` +— the `n`-interface between `F` and `H`, the `m`-block between +`F` and `K`, and the `p`-block between `H` and `K` — so the two +closures are equivalent closed fragments. This is the engine of +the ideal lemma and the trace calculus (accompanying paper, +Lemma 3.3(a) and Lemma 3.5(a)). +-/ + +@[expose] public section + +namespace RS + +/-- The boundary transpose: exchange the two sides of an +`(n,p)`-boundary. -/ +noncomputable def transposeEquiv (n p : ℕ) : + Fin (n + p) ≃ Fin (p + n) := + (finSumFinEquiv.symm.trans + (_root_.Equiv.sumComm (Fin n) (Fin p))).trans finSumFinEquiv + +/-- The transpose sends low labels beyond the split. -/ +theorem transposeEquiv_low (n p : ℕ) (j : ℕ) (hj : j < n) + (h1 : j < n + p) (h2 : p + j < p + n) : + transposeEquiv n p ⟨j, h1⟩ = ⟨p + j, h2⟩ := by + unfold transposeEquiv + have h3 : (⟨j, h1⟩ : Fin (n + p)) = Fin.castAdd p ⟨j, hj⟩ := + Fin.ext rfl + rw [_root_.Equiv.trans_apply, _root_.Equiv.trans_apply, h3, + finSumFinEquiv_symm_apply_castAdd] + change finSumFinEquiv (Sum.inr ⟨j, hj⟩) = _ + rw [finSumFinEquiv_apply_right] + exact Fin.ext rfl + +/-- The transpose sends high labels below the split. -/ +theorem transposeEquiv_high (n p : ℕ) (i : ℕ) (hi : i < p) + (h1 : n + i < n + p) (h2 : i < p + n) : + transposeEquiv n p ⟨n + i, h1⟩ = ⟨i, h2⟩ := by + unfold transposeEquiv + have h3 : (⟨n + i, h1⟩ : Fin (n + p)) = Fin.natAdd n ⟨i, hi⟩ := + Fin.ext rfl + rw [_root_.Equiv.trans_apply, _root_.Equiv.trans_apply, h3, + finSumFinEquiv_symm_apply_natAdd] + change finSumFinEquiv (Sum.inl ⟨i, hi⟩) = _ + rw [finSumFinEquiv_apply_left] + exact Fin.ext rfl + +/-- The inverse transpose sends low labels beyond the split. -/ +theorem transposeEquiv_symm_low (n p : ℕ) (l : ℕ) (hl : l < p) + (h1 : l < p + n) (h2 : n + l < n + p) : + (transposeEquiv n p).symm ⟨l, h1⟩ = ⟨n + l, h2⟩ := + (_root_.Equiv.symm_apply_eq _).mpr + (transposeEquiv_high n p l hl h2 h1).symm + +/-- The inverse transpose sends high labels below the split. -/ +theorem transposeEquiv_symm_high (n p : ℕ) (j : ℕ) (hj : j < n) + (h1 : p + j < p + n) (h2 : j < n + p) : + (transposeEquiv n p).symm ⟨p + j, h1⟩ = ⟨j, h2⟩ := + (_root_.Equiv.symm_apply_eq _).mpr + (transposeEquiv_low n p j hj h2 h1).symm + +/-! ### The three interface blocks over the common ambient -/ + +/-- The `m`-block: the low labels of `F` against the low labels +of `K`, top pair first. -/ +def mBlock (m n p : ℕ) : + List (((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p)) × + ((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p))) := + (List.finRange m).reverse.map (fun i => + (Sum.inl (Sum.inl ⟨i.val, by have := i.isLt; omega⟩), + Sum.inr ⟨i.val, by have := i.isLt; omega⟩)) + +/-- The `p`-block: the high labels of `H` against the high labels +of `K`, top pair first. -/ +def pBlock (m n p : ℕ) : + List (((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p)) × + ((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p))) := + (List.finRange p).reverse.map (fun ℓ => + (Sum.inl (Sum.inr ⟨n + ℓ.val, by have := ℓ.isLt; omega⟩), + Sum.inr ⟨m + ℓ.val, by have := ℓ.isLt; omega⟩)) + +/-- The `n`-block: the high labels of `F` against the low labels +of `H`, top pair first — the embedded composition interface. -/ +def nBlock (m n p : ℕ) : + List (((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p)) × + ((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p))) := + (List.finRange n).reverse.map (fun j => + (Sum.inl (Sum.inl ⟨m + j.val, by have := j.isLt; omega⟩), + Sum.inl (Sum.inr ⟨j.val, by have := j.isLt; omega⟩))) + +/-- Membership in the `m`-block. -/ +theorem mem_mBlock (m n p : ℕ) (q) : + q ∈ mBlock m n p ↔ + ∃ i : Fin m, + q = (Sum.inl (Sum.inl ⟨i.val, by have := i.isLt; omega⟩), + Sum.inr ⟨i.val, by have := i.isLt; omega⟩) := by + unfold mBlock + simp only [List.mem_map, List.mem_reverse, List.mem_finRange, + true_and] + exact ⟨fun ⟨k, hk⟩ => ⟨k, hk.symm⟩, fun ⟨k, hk⟩ => ⟨k, hk.symm⟩⟩ + +/-- Membership in the `p`-block. -/ +theorem mem_pBlock (m n p : ℕ) (q) : + q ∈ pBlock m n p ↔ + ∃ ℓ : Fin p, + q = (Sum.inl (Sum.inr ⟨n + ℓ.val, by have := ℓ.isLt; omega⟩), + Sum.inr ⟨m + ℓ.val, by have := ℓ.isLt; omega⟩) := by + unfold pBlock + simp only [List.mem_map, List.mem_reverse, List.mem_finRange, + true_and] + exact ⟨fun ⟨k, hk⟩ => ⟨k, hk.symm⟩, fun ⟨k, hk⟩ => ⟨k, hk.symm⟩⟩ + +/-- Membership in the `n`-block. -/ +theorem mem_nBlock (m n p : ℕ) (q) : + q ∈ nBlock m n p ↔ + ∃ j : Fin n, + q = (Sum.inl (Sum.inl ⟨m + j.val, by have := j.isLt; omega⟩), + Sum.inl (Sum.inr ⟨j.val, by have := j.isLt; omega⟩)) := by + unfold nBlock + simp only [List.mem_map, List.mem_reverse, List.mem_finRange, + true_and] + exact ⟨fun ⟨k, hk⟩ => ⟨k, hk.symm⟩, fun ⟨k, hk⟩ => ⟨k, hk.symm⟩⟩ + +/-- The `m`-block is well-formed. -/ +theorem mBlock_wf (m n p : ℕ) : Fragment.PairsWF (mBlock m n p) := by + unfold Fragment.PairsWF mBlock + rw [List.flatMap_map, List.nodup_flatMap] + refine ⟨fun k _ => by simp, ?_⟩ + rw [List.pairwise_reverse] + refine (List.nodup_finRange m).pairwise_of_forall_ne ?_ + intro k _ j _ hkj x hxj hxk + simp only [List.mem_cons, List.not_mem_nil, or_false] at hxj hxk + rcases hxj with rfl | rfl <;> rcases hxk with h | h <;> + (simp only [Sum.inl.injEq, Sum.inr.injEq, Fin.mk.injEq, + reduceCtorEq] at h <;> + exact hkj (Fin.ext (by omega)).symm) + +/-- The `p`-block is well-formed. -/ +theorem pBlock_wf (m n p : ℕ) : Fragment.PairsWF (pBlock m n p) := by + unfold Fragment.PairsWF pBlock + rw [List.flatMap_map, List.nodup_flatMap] + refine ⟨fun k _ => by simp, ?_⟩ + rw [List.pairwise_reverse] + refine (List.nodup_finRange p).pairwise_of_forall_ne ?_ + intro k _ j _ hkj x hxj hxk + simp only [List.mem_cons, List.not_mem_nil, or_false] at hxj hxk + rcases hxj with rfl | rfl <;> rcases hxk with h | h <;> + (simp only [Sum.inl.injEq, Sum.inr.injEq, Fin.mk.injEq, + reduceCtorEq] at h <;> + exact hkj (Fin.ext (by omega)).symm) + +/-- The `n`-block is well-formed. -/ +theorem nBlock_wf (m n p : ℕ) : Fragment.PairsWF (nBlock m n p) := by + unfold Fragment.PairsWF nBlock + rw [List.flatMap_map, List.nodup_flatMap] + refine ⟨fun k _ => by simp, ?_⟩ + rw [List.pairwise_reverse] + refine (List.nodup_finRange n).pairwise_of_forall_ne ?_ + intro k _ j _ hkj x hxj hxk + simp only [List.mem_cons, List.not_mem_nil, or_false] at hxj hxk + rcases hxj with rfl | rfl <;> rcases hxk with h | h <;> + (simp only [Sum.inl.injEq, Sum.inr.injEq, Fin.mk.injEq, + reduceCtorEq] at h <;> + exact hkj (Fin.ext (by omega)).symm) + +/-- The `n`-block and `p`-block glue disjoint labels. -/ +theorem nBlock_pBlock_disjoint (m n p : ℕ) : + ∀ x ∈ (nBlock m n p).flatMap (fun q => [q.1, q.2]), + x ∉ (pBlock m n p).flatMap (fun q => [q.1, q.2]) := by + intro x hx hy + obtain ⟨q₁, hq₁, hx₁⟩ := List.mem_flatMap.mp hx + obtain ⟨q₂, hq₂, hy₂⟩ := List.mem_flatMap.mp hy + obtain ⟨j, rfl⟩ := (mem_nBlock m n p _).mp hq₁ + obtain ⟨l, rfl⟩ := (mem_pBlock m n p _).mp hq₂ + have hj := j.isLt + have hl := l.isLt + simp only [List.mem_cons, List.not_mem_nil, or_false] at hx₁ hy₂ + rcases hx₁ with rfl | rfl <;> rcases hy₂ with h | h <;> + (simp only [Sum.inl.injEq, Sum.inr.injEq, Fin.mk.injEq, + reduceCtorEq] at h <;> omega) + +/-- The `n`-block and `m`-block glue disjoint labels. -/ +theorem nBlock_mBlock_disjoint (m n p : ℕ) : + ∀ x ∈ (nBlock m n p).flatMap (fun q => [q.1, q.2]), + x ∉ (mBlock m n p).flatMap (fun q => [q.1, q.2]) := by + intro x hx hy + obtain ⟨q₁, hq₁, hx₁⟩ := List.mem_flatMap.mp hx + obtain ⟨q₂, hq₂, hy₂⟩ := List.mem_flatMap.mp hy + obtain ⟨j, rfl⟩ := (mem_nBlock m n p _).mp hq₁ + obtain ⟨i, rfl⟩ := (mem_mBlock m n p _).mp hq₂ + have hj := j.isLt + have hi := i.isLt + simp only [List.mem_cons, List.not_mem_nil, or_false] at hx₁ hy₂ + rcases hx₁ with rfl | rfl <;> rcases hy₂ with h | h <;> + (simp only [Sum.inl.injEq, Fin.mk.injEq, + reduceCtorEq] at h <;> omega) + +/-- The `p`-block and `m`-block glue disjoint labels. -/ +theorem pBlock_mBlock_disjoint (m n p : ℕ) : + ∀ x ∈ (pBlock m n p).flatMap (fun q => [q.1, q.2]), + x ∉ (mBlock m n p).flatMap (fun q => [q.1, q.2]) := by + intro x hx hy + obtain ⟨q₁, hq₁, hx₁⟩ := List.mem_flatMap.mp hx + obtain ⟨q₂, hq₂, hy₂⟩ := List.mem_flatMap.mp hy + obtain ⟨l, rfl⟩ := (mem_pBlock m n p _).mp hq₁ + obtain ⟨i, rfl⟩ := (mem_mBlock m n p _).mp hq₂ + have hl := l.isLt + have hi := i.isLt + simp only [List.mem_cons, List.not_mem_nil, or_false] at hx₁ hy₂ + rcases hx₁ with rfl | rfl <;> rcases hy₂ with h | h <;> + (simp only [Sum.inl.injEq, Sum.inr.injEq, Fin.mk.injEq, + reduceCtorEq] at h <;> omega) + +/-- The combined block list of the left association is +well-formed. -/ +theorem rotatePairsL_wf (m n p : ℕ) : + Fragment.PairsWF + (nBlock m n p ++ (pBlock m n p ++ mBlock m n p)) := by + unfold Fragment.PairsWF + rw [List.flatMap_append, List.flatMap_append] + refine List.Nodup.append (nBlock_wf m n p) + (List.Nodup.append (pBlock_wf m n p) (mBlock_wf m n p) + (pBlock_mBlock_disjoint m n p)) ?_ + intro x hx hy + rcases List.mem_append.mp hy with hy | hy + · exact nBlock_pBlock_disjoint m n p x hx hy + · exact nBlock_mBlock_disjoint m n p x hx hy + +/-- The middle-swap permutation between the two block orders. -/ +theorem rotatePairs_perm (m n p : ℕ) : + (nBlock m n p ++ (pBlock m n p ++ mBlock m n p)).Perm + (pBlock m n p ++ (nBlock m n p ++ mBlock m n p)) := + ((List.perm_append_comm_assoc _ _ _)) + +/-- The combined block list of the right association is +well-formed. -/ +theorem rotatePairsR_wf (m n p : ℕ) : + Fragment.PairsWF + (pBlock m n p ++ (nBlock m n p ++ mBlock m n p)) := + (rotatePairsL_wf m n p).perm (rotatePairs_perm m n p) + +/-! ### Splitting closure lists -/ + +/-- `mapPairs` distributes over appends. -/ +theorem mapPairs_append {α β : Type} (e : α ≃ β) + (ps qs : List (α × α)) : + Fragment.mapPairs e (ps ++ qs) = + Fragment.mapPairs e ps ++ Fragment.mapPairs e qs := + List.map_append .. + +/-- The separation of an append restricts to the left part. -/ +theorem Fragment.PairsSepAll.append_left' {α : Type} + {ps qs₁ qs₂ : List (α × α)} + (h : Fragment.PairsSepAll ps (qs₁ ++ qs₂)) : + Fragment.PairsSepAll ps qs₁ := + fun q hq => h q (List.mem_append.mpr (Or.inl hq)) + +/-- The separation of an append restricts to the right part. -/ +theorem Fragment.PairsSepAll.append_right' {α : Type} + {ps qs₁ qs₂ : List (α × α)} + (h : Fragment.PairsSepAll ps (qs₁ ++ qs₂)) : + Fragment.PairsSepAll ps qs₂ := + fun q hq => h q (List.mem_append.mpr (Or.inr hq)) + +/-- `liftPairs` distributes over appends. -/ +theorem liftPairs_append {α : Type} (ps : List (α × α)) : + ∀ (qs₁ qs₂ : List (α × α)) + (h : Fragment.PairsSepAll ps (qs₁ ++ qs₂)), + Fragment.liftPairs ps (qs₁ ++ qs₂) h = + Fragment.liftPairs ps qs₁ h.append_left' ++ + Fragment.liftPairs ps qs₂ h.append_right' + | [], _, _ => rfl + | q :: qs₁, qs₂, h => by + simp only [List.cons_append, Fragment.liftPairs] + exact congrArg₂ List.cons + (Prod.ext (Subtype.ext rfl) (Subtype.ext rfl)) + (liftPairs_append ps qs₁ qs₂ _) + +/-- The high half of a full-closure interface list. -/ +def ipHigh (m p : ℕ) : + List ((Fin (0 + (m + p)) ⊕ Fin (m + p + 0)) × + (Fin (0 + (m + p)) ⊕ Fin (m + p + 0))) := + (List.finRange p).reverse.map (fun ℓ => + (Sum.inl ⟨m + ℓ.val, by have := ℓ.isLt; omega⟩, + Sum.inr ⟨m + ℓ.val, by have := ℓ.isLt; omega⟩)) + +/-- The low half of a full-closure interface list. -/ +def ipLow (m p : ℕ) : + List ((Fin (0 + (m + p)) ⊕ Fin (m + p + 0)) × + (Fin (0 + (m + p)) ⊕ Fin (m + p + 0))) := + (List.finRange m).reverse.map (fun i => + (Sum.inl ⟨i.val, by have := i.isLt; omega⟩, + Sum.inr ⟨i.val, by have := i.isLt; omega⟩)) + +/-- A full-closure interface list splits into its high and low +halves. -/ +theorem interfacePairs_closure_split (m p : ℕ) : + interfacePairs 0 (m + p) 0 = ipHigh m p ++ ipLow m p := by + unfold interfacePairs ipHigh ipLow + rw [List.map_reverse, List.map_reverse, List.map_reverse, + ← List.reverse_append] + refine congrArg List.reverse ?_ + rw [← List.ofFn_eq_map, List.ofFn_add, List.ofFn_eq_map, + List.ofFn_eq_map] + refine congrArg₂ (· ++ ·) + (List.map_congr_left fun i _ => ?_) + (List.map_congr_left fun ℓ _ => ?_) + · refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) + (congrArg Sum.inr (Fin.ext ?_)) + · change 0 + i.val = i.val + omega + · rfl + · refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) + (congrArg Sum.inr (Fin.ext ?_)) + · change 0 + (m + ℓ.val) = m + ℓ.val + omega + · rfl + +/-- The `n`-block is the embedded composition interface. -/ +theorem nBlock_eq_inlPairs (m n p : ℕ) : + nBlock m n p = + Fragment.inlPairs (β := Fin (m + p)) + (interfacePairs m n p) := by + unfold nBlock Fragment.inlPairs interfacePairs + rw [List.map_map] + rfl + +/-! ### Lifting the closure halves -/ + +/-- The high closure half lifts to the `p`-block, generalized +over any transport with the expected boundary values. -/ +private theorem rotate_lift_high_aux (m n p : ℕ) + (ps₀ : List + (((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p)) × + ((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p)))) + (E : (Fin (0 + (m + p)) ⊕ Fin (m + p + 0)) ≃ + Fragment.FoldSurviving + ((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p)) ps₀) + (hE1 : ∀ (ℓ : ℕ) (_ : ℓ < p) (h1 : m + ℓ < 0 + (m + p)) + (h2 : n + ℓ < n + p), + (E (Sum.inl ⟨m + ℓ, h1⟩)).val = + Sum.inl (Sum.inr ⟨n + ℓ, h2⟩)) + (hE2 : ∀ (ℓ : ℕ) (_ : ℓ < p) (h1 : m + ℓ < m + p + 0) + (h2 : m + ℓ < m + p), + (E (Sum.inr ⟨m + ℓ, h1⟩)).val = Sum.inr ⟨m + ℓ, h2⟩) : + ∀ (l : List (Fin p)) + (hsep : Fragment.PairsSepAll ps₀ + (l.map (fun ℓ => + (Sum.inl (Sum.inr ⟨n + ℓ.val, by have := ℓ.isLt; omega⟩), + Sum.inr ⟨m + ℓ.val, by have := ℓ.isLt; omega⟩)))), + Fragment.mapPairs E + (l.map (fun ℓ => + ((Sum.inl ⟨m + ℓ.val, by have := ℓ.isLt; omega⟩ : + Fin (0 + (m + p)) ⊕ Fin (m + p + 0)), + Sum.inr ⟨m + ℓ.val, by have := ℓ.isLt; omega⟩))) = + Fragment.liftPairs _ _ hsep + | [], _ => rfl + | ℓ :: l, hsep => by + simp only [List.map_cons, Fragment.mapPairs, + Fragment.liftPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext ?_ ?_) + (rotate_lift_high_aux m n p ps₀ E hE1 hE2 l _) + · exact Subtype.ext (hE1 ℓ.val ℓ.isLt + (by have := ℓ.isLt; omega) (by have := ℓ.isLt; omega)) + · exact Subtype.ext (hE2 ℓ.val ℓ.isLt + (by have := ℓ.isLt; omega) (by have := ℓ.isLt; omega)) + +/-- The low closure half lifts to the `m`-block, generalized +over any transport with the expected boundary values and any +closure size. -/ +private theorem rotate_lift_low_aux (m n p T : ℕ) (hT : m ≤ T) + (ps₀ : List + (((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p)) × + ((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p)))) + (E : (Fin (0 + T) ⊕ Fin (T + 0)) ≃ + Fragment.FoldSurviving + ((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p)) ps₀) + (hE1 : ∀ (i : ℕ) (_ : i < m) (h1 : i < 0 + T) + (h2 : i < m + n), + (E (Sum.inl ⟨i, h1⟩)).val = Sum.inl (Sum.inl ⟨i, h2⟩)) + (hE2 : ∀ (i : ℕ) (_ : i < m) (h1 : i < T + 0) + (h2 : i < m + p), + (E (Sum.inr ⟨i, h1⟩)).val = Sum.inr ⟨i, h2⟩) : + ∀ (l : List (Fin m)) + (hsep : Fragment.PairsSepAll ps₀ + (l.map (fun i => + (Sum.inl (Sum.inl ⟨i.val, by have := i.isLt; omega⟩), + Sum.inr ⟨i.val, by have := i.isLt; omega⟩)))), + Fragment.mapPairs E + (l.map (fun i => + ((Sum.inl ⟨i.val, by have := i.isLt; omega⟩ : + Fin (0 + T) ⊕ Fin (T + 0)), + Sum.inr ⟨i.val, by have := i.isLt; omega⟩))) = + Fragment.liftPairs _ _ hsep + | [], _ => rfl + | i :: l, hsep => by + simp only [List.map_cons, Fragment.mapPairs, + Fragment.liftPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext ?_ ?_) + (rotate_lift_low_aux m n p T hT ps₀ E hE1 hE2 l _) + · exact Subtype.ext (hE1 i.val i.isLt + (by have := i.isLt; omega) (by have := i.isLt; omega)) + · exact Subtype.ext (hE2 i.val i.isLt + (by have := i.isLt; omega) (by have := i.isLt; omega)) + +/-- The high closure half of the right side lifts to the +`n`-block, generalized over any transport with the expected +boundary values. -/ +private theorem rotate_lift_nblock_aux (m n p : ℕ) + (ps₀ : List + (((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p)) × + ((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p)))) + (E : (Fin (0 + (m + n)) ⊕ Fin (m + n + 0)) ≃ + Fragment.FoldSurviving + ((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p)) ps₀) + (hE1 : ∀ (i : ℕ) (_ : i < n) (h1 : m + i < 0 + (m + n)) + (h2 : m + i < m + n), + (E (Sum.inl ⟨m + i, h1⟩)).val = + Sum.inl (Sum.inl ⟨m + i, h2⟩)) + (hE2 : ∀ (i : ℕ) (_ : i < n) (h1 : m + i < m + n + 0) + (h2 : i < n + p), + (E (Sum.inr ⟨m + i, h1⟩)).val = + Sum.inl (Sum.inr ⟨i, h2⟩)) : + ∀ (l : List (Fin n)) + (hsep : Fragment.PairsSepAll ps₀ + (l.map (fun i => + (Sum.inl (Sum.inl ⟨m + i.val, by have := i.isLt; omega⟩), + Sum.inl (Sum.inr ⟨i.val, by have := i.isLt; omega⟩))))), + Fragment.mapPairs E + (l.map (fun i => + ((Sum.inl ⟨m + i.val, by have := i.isLt; omega⟩ : + Fin (0 + (m + n)) ⊕ Fin (m + n + 0)), + Sum.inr ⟨m + i.val, by have := i.isLt; omega⟩))) = + Fragment.liftPairs _ _ hsep + | [], _ => rfl + | i :: l, hsep => by + simp only [List.map_cons, Fragment.mapPairs, + Fragment.liftPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext ?_ ?_) + (rotate_lift_nblock_aux m n p ps₀ E hE1 hE2 l _) + · exact Subtype.ext (hE1 i.val i.isLt + (by have := i.isLt; omega) (by have := i.isLt; omega)) + · exact Subtype.ext (hE2 i.val i.isLt + (by have := i.isLt; omega) (by have := i.isLt; omega)) + +/-- The transported closure pairs of the left side are the lifted +`p`- and `m`-blocks. -/ +theorem lhs_close_pairs_eq (m n p : ℕ) + (ps₀ : List + (((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p)) × + ((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p)))) + (E : (Fin (0 + (m + p)) ⊕ Fin (m + p + 0)) ≃ + Fragment.FoldSurviving + ((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p)) ps₀) + (hEhi1 : ∀ (ℓ : ℕ) (_ : ℓ < p) (h1 : m + ℓ < 0 + (m + p)) + (h2 : n + ℓ < n + p), + (E (Sum.inl ⟨m + ℓ, h1⟩)).val = + Sum.inl (Sum.inr ⟨n + ℓ, h2⟩)) + (hEhi2 : ∀ (ℓ : ℕ) (_ : ℓ < p) (h1 : m + ℓ < m + p + 0) + (h2 : m + ℓ < m + p), + (E (Sum.inr ⟨m + ℓ, h1⟩)).val = Sum.inr ⟨m + ℓ, h2⟩) + (hElo1 : ∀ (i : ℕ) (_ : i < m) (h1 : i < 0 + (m + p)) + (h2 : i < m + n), + (E (Sum.inl ⟨i, h1⟩)).val = Sum.inl (Sum.inl ⟨i, h2⟩)) + (hElo2 : ∀ (i : ℕ) (_ : i < m) (h1 : i < m + p + 0) + (h2 : i < m + p), + (E (Sum.inr ⟨i, h1⟩)).val = Sum.inr ⟨i, h2⟩) + (hsep : Fragment.PairsSepAll ps₀ + (pBlock m n p ++ mBlock m n p)) : + Fragment.mapPairs E (interfacePairs 0 (m + p) 0) = + Fragment.liftPairs ps₀ (pBlock m n p ++ mBlock m n p) + hsep := + (congrArg (Fragment.mapPairs E) + (interfacePairs_closure_split m p)).trans + ((mapPairs_append E (ipHigh m p) (ipLow m p)).trans + ((congrArg₂ (· ++ ·) + (rotate_lift_high_aux m n p ps₀ E hEhi1 hEhi2 + (List.finRange p).reverse hsep.append_left') + (rotate_lift_low_aux m n p (m + p) (by omega) ps₀ E + hElo1 hElo2 + (List.finRange m).reverse hsep.append_right')).trans + (liftPairs_append ps₀ (pBlock m n p) (mBlock m n p) + hsep).symm)) + +/-! ### The inner pairs of the right side -/ + +/-- The rotated composition interface over `K ⊔ H`, `K`-first. -/ +def khPairs (m n p : ℕ) : + List ((Fin (m + p) ⊕ Fin (n + p)) × + (Fin (m + p) ⊕ Fin (n + p))) := + (List.finRange p).reverse.map (fun ℓ => + (Sum.inl ⟨m + ℓ.val, by have := ℓ.isLt; omega⟩, + Sum.inr ⟨n + ℓ.val, by have := ℓ.isLt; omega⟩)) + +/-- The rotated composition interface over `K ⊔ H`, `H`-first. -/ +def hkPairs (m n p : ℕ) : + List ((Fin (m + p) ⊕ Fin (n + p)) × + (Fin (m + p) ⊕ Fin (n + p))) := + (List.finRange p).reverse.map (fun ℓ => + (Sum.inr ⟨n + ℓ.val, by have := ℓ.isLt; omega⟩, + Sum.inl ⟨m + ℓ.val, by have := ℓ.isLt; omega⟩)) + +/-- The two orientations are component swaps of each other. -/ +theorem hkPairs_swap (m n p : ℕ) : + (hkPairs m n p).map Prod.swap = khPairs m n p := by + unfold hkPairs khPairs + rw [List.map_map] + rfl + +/-- The `H`-first pairs are well-formed. -/ +theorem hkPairs_wf (m n p : ℕ) : + Fragment.PairsWF (hkPairs m n p) := by + unfold Fragment.PairsWF hkPairs + rw [List.flatMap_map, List.nodup_flatMap] + refine ⟨fun k _ => by simp, ?_⟩ + rw [List.pairwise_reverse] + refine (List.nodup_finRange p).pairwise_of_forall_ne ?_ + intro k _ j _ hkj x hxj hxk + simp only [List.mem_cons, List.not_mem_nil, or_false] at hxj hxk + rcases hxj with rfl | rfl <;> rcases hxk with h | h <;> + (simp only [Sum.inl.injEq, Sum.inr.injEq, Fin.mk.injEq, + reduceCtorEq] at h <;> + exact hkj (Fin.ext (by omega)).symm) + +/-- The transpose-pullback of the rotated interface is the +`K`-first pair list (generalized over the index list). -/ +private theorem kh_pullback_aux (m n p : ℕ) : + ∀ (l : List (Fin p)), + Fragment.mapPairs + (_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (m + p))) + (transposeEquiv n p)).symm + (l.map (fun ℓ => + ((Sum.inl ⟨m + ℓ.val, by have := ℓ.isLt; omega⟩ : + Fin (m + p) ⊕ Fin (p + n)), + Sum.inr ⟨ℓ.val, by have := ℓ.isLt; omega⟩))) = + l.map (fun ℓ => + (Sum.inl ⟨m + ℓ.val, by have := ℓ.isLt; omega⟩, + Sum.inr ⟨n + ℓ.val, by have := ℓ.isLt; omega⟩)) + | [] => rfl + | ℓ :: l => by + simp only [List.map_cons, Fragment.mapPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext rfl ?_) (kh_pullback_aux m n p l) + change Sum.inr ((transposeEquiv n p).symm ⟨ℓ.val, _⟩) = _ + exact congrArg Sum.inr + (transposeEquiv_symm_low n p ℓ.val ℓ.isLt + (by have := ℓ.isLt; omega) (by have := ℓ.isLt; omega)) + +/-- The transpose-pullback of the rotated interface is the +`K`-first pair list. -/ +theorem kh_pullback (m n p : ℕ) : + Fragment.mapPairs + (_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (m + p))) + (transposeEquiv n p)).symm + (interfacePairs m p n) = khPairs m n p := + kh_pullback_aux m n p (List.finRange p).reverse + +/-- The associativity-and-commutativity ambient bridge. -/ +noncomputable def rotBridge (m n p : ℕ) : + (Fin (m + n) ⊕ (Fin (m + p) ⊕ Fin (n + p))) ≃ + ((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p)) := + (_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (m + n))) + (_root_.Equiv.sumComm (Fin (m + p)) (Fin (n + p)))).trans + (_root_.Equiv.sumAssoc (Fin (m + n)) (Fin (n + p)) + (Fin (m + p))).symm + +/-- The bridge-pullback of the embedded `H`-first pairs is the +`p`-block (generalized over the index list). -/ +private theorem rot_ground_aux (m n p : ℕ) : + ∀ (l : List (Fin p)), + Fragment.mapPairs ((rotBridge m n p).symm).symm + ((l.map (fun ℓ => + ((Sum.inr ⟨n + ℓ.val, by have := ℓ.isLt; omega⟩ : + Fin (m + p) ⊕ Fin (n + p)), + Sum.inl ⟨m + ℓ.val, by have := ℓ.isLt; omega⟩))).map + (Prod.map Sum.inr Sum.inr)) = + l.map (fun ℓ => + (Sum.inl (Sum.inr ⟨n + ℓ.val, by have := ℓ.isLt; omega⟩), + Sum.inr ⟨m + ℓ.val, by have := ℓ.isLt; omega⟩)) + | [] => rfl + | ℓ :: l => by + simp only [List.map_cons, Fragment.mapPairs, Prod.map] + exact congrArg₂ List.cons rfl (rot_ground_aux m n p l) + +/-- The bridge-pullback of the embedded `H`-first pairs is the +`p`-block. -/ +theorem rot_ground (m n p : ℕ) : + Fragment.mapPairs ((rotBridge m n p).symm).symm + (Fragment.inrPairs (α := Fin (m + n)) (hkPairs m n p)) = + pBlock m n p := + rot_ground_aux m n p (List.finRange p).reverse + +/-! ### The right side's transport composites -/ + +/-- The inner transport of the right side: from the `H`-first +fold survivors to the boundary of the rotated composition. -/ +noncomputable def rotM2 (m n p : ℕ) : + Fragment.FoldSurviving (Fin (m + p) ⊕ Fin (n + p)) + (hkPairs m n p) ≃ + Fragment.FoldSurviving (Fin (m + p) ⊕ Fin (p + n)) + (interfacePairs m p n) := + (Fragment.swapFoldEquiv (hkPairs m n p)).symm.trans + ((Fragment.foldSurvivingPermEquiv + (show ((hkPairs m n p).map Prod.swap).Perm (khPairs m n p) + from (hkPairs_swap m n p) ▸ List.Perm.refl _)).trans + ((Fragment.foldSurvivingPermEquiv + (show (Fragment.mapPairs + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (m + p))) + (transposeEquiv n p)).symm + (interfacePairs m p n)).Perm (khPairs m n p) + from (kh_pullback m n p) ▸ + List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (m + p))) + (transposeEquiv n p)) + (Fragment.mapPairs + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (m + p))) + (transposeEquiv n p)).symm + (interfacePairs m p n))).trans + (Fragment.foldSurvivingPermEquiv + (show (interfacePairs m p n).Perm + (Fragment.mapPairs + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (m + p))) + (transposeEquiv n p)) + (Fragment.mapPairs + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (m + p))) + (transposeEquiv n p)).symm + (interfacePairs m p n))) + from (mapPairs_symm_cancel + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (m + p))) + (transposeEquiv n p)) + (interfacePairs m p n)).symm ▸ + List.Perm.refl _)).symm))) + +/-- The outer bridge transport of the right side: from the +`p`-block survivors to the embedded `H`-first fold survivors. -/ +noncomputable def rotMR (m n p : ℕ) : + Fragment.FoldSurviving + ((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p)) + (pBlock m n p) ≃ + Fragment.FoldSurviving + (Fin (m + n) ⊕ (Fin (m + p) ⊕ Fin (n + p))) + (Fragment.inrPairs (α := Fin (m + n)) (hkPairs m n p)) := + (Fragment.foldSurvivingPermEquiv + ((rot_ground m n p) ▸ List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv (rotBridge m n p).symm + (Fragment.mapPairs ((rotBridge m n p).symm).symm + (Fragment.inrPairs (α := Fin (m + n)) + (hkPairs m n p)))).trans + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel (rotBridge m n p).symm + (Fragment.inrPairs (α := Fin (m + n)) + (hkPairs m n p))).symm ▸ + List.Perm.refl _)).symm) + +/-- The transported boundary equivalence of the right side. -/ +noncomputable def rotSigma (m n p : ℕ) : + (Fin (m + n) ⊕ + Fragment.FoldSurviving (Fin (m + p) ⊕ Fin (p + n)) + (interfacePairs m p n)) ≃ + (Fin (0 + (m + n)) ⊕ Fin (m + n + 0)) := + (_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (m + n))) + ((interfaceSurvEquiv m p n).trans finSumFinEquiv)).trans + ((_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (m + n))) + (finCongr (by omega : m + n = m + n + 0))).trans + (_root_.Equiv.sumCongr + (finCongr (by omega : m + n = 0 + (m + n))) + (_root_.Equiv.refl (Fin (m + n + 0))))) + +/-- The composed transport of the right side's closure pairs. -/ +noncomputable def rotE (m n p : ℕ) : + (Fin (0 + (m + n)) ⊕ Fin (m + n + 0)) ≃ + Fragment.FoldSurviving + ((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p)) + (pBlock m n p) := + (rotSigma m n p).symm.trans + ((_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (m + n))) + (rotM2 m n p)).symm.trans + ((Fragment.inrFoldEquiv (α := Fin (m + n)) + (hkPairs m n p)).symm.trans + (rotMR m n p).symm)) + +/-- The right side's closure pairs are the lifted blocks. -/ +theorem rot_pairs_lift (m n p : ℕ) : + Fragment.mapPairs (rotE m n p) + (interfacePairs 0 (m + n) 0) = + Fragment.liftPairs _ _ + ((rotatePairsR_wf m n p).append_sep) := + (congrArg (Fragment.mapPairs (rotE m n p)) + (interfacePairs_closure_split m n)).trans + ((mapPairs_append (rotE m n p) (ipHigh m n) (ipLow m n)).trans + ((congrArg₂ (· ++ ·) + (rotate_lift_nblock_aux m n p _ (rotE m n p) + (fun i _ _ _ => + congrArg (fun z => ((rotBridge m n p).symm).symm z) + (Fragment.inrFoldEquiv_symm_inl_val + (hkPairs m n p) _)) + (fun i hi h1 h2 => + congrArg (fun z => ((rotBridge m n p).symm).symm z) + ((Fragment.inrFoldEquiv_symm_inr_val (hkPairs m n p) + ((rotM2 m n p).symm + (((interfaceSurvEquiv m p n).trans + finSumFinEquiv).symm + ⟨m + i, by omega⟩))).trans + (congrArg Sum.inr + ((congrArg (fun w => + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (m + p))) + (transposeEquiv n p)).symm w) + (interfaceEquiv_symm_high m p n i hi + (by omega) (by omega))).trans + (congrArg Sum.inr + (transposeEquiv_symm_high n p i hi + (by omega) h2)))))) + (List.finRange n).reverse + ((rotatePairsR_wf m n p).append_sep).append_left') + (rotate_lift_low_aux m n p (m + n) (by omega) _ + (rotE m n p) + (fun j _ _ _ => + congrArg (fun z => ((rotBridge m n p).symm).symm z) + (Fragment.inrFoldEquiv_symm_inl_val + (hkPairs m n p) _)) + (fun j hj h1 h2 => + congrArg (fun z => ((rotBridge m n p).symm).symm z) + ((Fragment.inrFoldEquiv_symm_inr_val (hkPairs m n p) + ((rotM2 m n p).symm + (((interfaceSurvEquiv m p n).trans + finSumFinEquiv).symm + ⟨j, by omega⟩))).trans + (congrArg Sum.inr + (congrArg (fun w => + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (m + p))) + (transposeEquiv n p)).symm w) + (interfaceEquiv_symm_low m p n j hj + (by omega) (by omega)))))) + (List.finRange m).reverse + ((rotatePairsR_wf m n p).append_sep).append_right')).trans + (liftPairs_append _ (nBlock m n p) (mBlock m n p) + ((rotatePairsR_wf m n p).append_sep)).symm)) + +/-- The right side's closure pairs, boundary stage. -/ +noncomputable def rotQ1 (m n p : ℕ) := + Fragment.mapPairs (rotSigma m n p).symm + (interfacePairs 0 (m + n) 0) + +/-- The right side's closure pairs, inner-transport stage. -/ +noncomputable def rotQ2 (m n p : ℕ) := + Fragment.mapPairs + (_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (m + n))) + (rotM2 m n p)).symm + (rotQ1 m n p) + +/-- The right side's closure pairs, embedded-fold stage. -/ +noncomputable def rotQ3 (m n p : ℕ) := + Fragment.mapPairs + (Fragment.inrFoldEquiv (α := Fin (m + n)) + (hkPairs m n p)).symm + (rotQ2 m n p) + +/-- The right side's closure pairs, ambient stage. -/ +noncomputable def rotQ4 (m n p : ℕ) := + Fragment.mapPairs (rotMR m n p).symm (rotQ3 m n p) + +/-- The fully transported closure pairs are the lifted blocks. -/ +theorem rot_q4_eq (m n p : ℕ) : + rotQ4 m n p = + Fragment.liftPairs _ _ + ((rotatePairsR_wf m n p).append_sep) := by + change Fragment.mapPairs (rotMR m n p).symm + (Fragment.mapPairs + (Fragment.inrFoldEquiv (α := Fin (m + n)) + (hkPairs m n p)).symm + (Fragment.mapPairs + (_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (m + n))) + (rotM2 m n p)).symm + (Fragment.mapPairs (rotSigma m n p).symm + (interfacePairs 0 (m + n) 0)))) = _ + rw [mapPairs_mapPairs, mapPairs_mapPairs, mapPairs_mapPairs] + exact rot_pairs_lift m n p + +/-! ### The left side, normalized -/ + +/-- The combined pair list of the left side, embedded form. -/ +theorem lhsCA_wf (m n p : ℕ) : + Fragment.PairsWF + (Fragment.inlPairs (interfacePairs m n p) ++ + (pBlock m n p ++ mBlock m n p)) := + (congrArg (· ++ (pBlock m n p ++ mBlock m n p)) + (nBlock_eq_inlPairs m n p)) ▸ rotatePairsL_wf m n p + +/-- The transported boundary equivalence of the left side. -/ +noncomputable def lhsSigma (m n p : ℕ) : + (Fragment.FoldSurviving (Fin (m + n) ⊕ Fin (n + p)) + (interfacePairs m n p) ⊕ Fin (m + p)) ≃ + (Fin (0 + (m + p)) ⊕ Fin (m + p + 0)) := + (_root_.Equiv.sumCongr + ((interfaceSurvEquiv m n p).trans finSumFinEquiv) + (_root_.Equiv.refl (Fin (m + p)))).trans + ((_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (m + p))) + (finCongr (by omega : m + p = m + p + 0))).trans + (_root_.Equiv.sumCongr + (finCongr (by omega : m + p = 0 + (m + p))) + (_root_.Equiv.refl (Fin (m + p + 0))))) + +/-- The composed transport of the left side's closure pairs. -/ +noncomputable def lhsE (m n p : ℕ) : + (Fin (0 + (m + p)) ⊕ Fin (m + p + 0)) ≃ + Fragment.FoldSurviving + ((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p)) + (Fragment.inlPairs (interfacePairs m n p)) := + (lhsSigma m n p).symm.trans + (Fragment.inlFoldEquiv (β := Fin (m + p)) + (interfacePairs m n p)).symm + +/-- The left side's closure pairs are the lifted blocks. -/ +theorem lhs_pairs_lift (m n p : ℕ) : + Fragment.mapPairs + (Fragment.inlFoldEquiv (β := Fin (m + p)) + (interfacePairs m n p)).symm + (Fragment.mapPairs (lhsSigma m n p).symm + (interfacePairs 0 (m + p) 0)) = + Fragment.liftPairs _ _ ((lhsCA_wf m n p).append_sep) := + (mapPairs_mapPairs (lhsSigma m n p).symm + (Fragment.inlFoldEquiv (β := Fin (m + p)) + (interfacePairs m n p)).symm + (interfacePairs 0 (m + p) 0)).trans + (lhs_close_pairs_eq m n p _ (lhsE m n p) + (fun ℓ hℓ h1 h2 => + (Fragment.inlFoldEquiv_symm_inl_val _ _).trans + (congrArg Sum.inl + (interfaceEquiv_symm_high m n p ℓ hℓ + (by omega) h2))) + (fun ℓ _ _ _ => + Fragment.inlFoldEquiv_symm_inr_val _ _) + (fun i hi h1 h2 => + (Fragment.inlFoldEquiv_symm_inl_val _ _).trans + (congrArg Sum.inl + (interfaceEquiv_symm_low m n p i hi + (by omega) h2))) + (fun i _ _ _ => + Fragment.inlFoldEquiv_symm_inr_val _ _) + ((lhsCA_wf m n p).append_sep)) + +/-- The left side's transported closure pairs. -/ +noncomputable def lhsQs1 (m n p : ℕ) := + Fragment.mapPairs (lhsSigma m n p).symm + (interfacePairs 0 (m + p) 0) + +/-- The left side's closure pairs in the fold survivors. -/ +noncomputable def lhsQs2 (m n p : ℕ) := + Fragment.mapPairs + (Fragment.inlFoldEquiv (β := Fin (m + p)) + (interfacePairs m n p)).symm + (lhsQs1 m n p) + +/-- The composed label identification of the left side. -/ +noncomputable def rotateLabelL (m n p : ℕ) : + Fragment.FoldSurviving + ((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p)) + (Fragment.inlPairs (interfacePairs m n p) ++ + (pBlock m n p ++ mBlock m n p)) ≃ + Fin (0 + 0) := + ((Fragment.appendFlatten _ _ + ((lhsCA_wf m n p).append_sep)).symm.trans + ((Fragment.foldSurvivingPermEquiv + ((lhs_pairs_lift m n p) ▸ List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv + (Fragment.inlFoldEquiv (β := Fin (m + p)) + (interfacePairs m n p)) + (lhsQs2 m n p)).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel + (Fragment.inlFoldEquiv (β := Fin (m + p)) + (interfacePairs m n p)) + (lhsQs1 m n p)).symm ▸ + List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv (lhsSigma m n p) + (lhsQs1 m n p)).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel (lhsSigma m n p) + (interfacePairs 0 (m + p) 0)).symm ▸ + List.Perm.refl _)).symm.trans + ((interfaceSurvEquiv 0 (m + p) 0).trans + finSumFinEquiv))))))) + +private theorem lhsQs2_wf (m n p : ℕ) : + Fragment.PairsWF (lhsQs2 m n p) := + Fragment.mapPairs_wf _ _ (Fragment.mapPairs_wf _ _ (interfacePairs_wf 0 (m + p) 0)) + +/-- **The left side, normalized**: the closure of a composite +against `K` is iterated gluing of the three interface blocks +over the common ambient. -/ +noncomputable def rotateNormalLeft {m n p : ℕ} + (F : Fragment (Fin (m + n))) (H : Fragment (Fin (n + p))) + (K : Fragment (Fin (m + p))) : + (pairClose (F.compose H) K).Equiv + ((Fragment.glueList ((F.disjUnion H).disjUnion K) + (Fragment.inlPairs (interfacePairs m n p) ++ + (pBlock m n p ++ mBlock m n p)) + (lhsCA_wf m n p)).relabel (rotateLabelL m n p)) := by + -- ═══════ SETUP ═══════ + -- The two intermediate folds (`N`, `X`) over the common ambient, + -- the relabels between them, and their well-formedness data. + let σL := lhsSigma m n p + let iL := Fragment.inlFoldEquiv (β := Fin (m + p)) + (interfacePairs m n p) + let wfqs1 : Fragment.PairsWF (lhsQs1 m n p) := + Fragment.mapPairs_wf σL.symm _ (interfacePairs_wf 0 (m + p) 0) + let wfqs2 : Fragment.PairsWF (lhsQs2 m n p) := by + exact lhsQs2_wf m n p + let A := (F.disjUnion H).disjUnion K + let X := Fragment.glueList A + (Fragment.inlPairs (interfacePairs m n p)) + ((lhsCA_wf m n p).append_left) + let N := Fragment.glueList (F.disjUnion H) + (interfacePairs m n p) (interfacePairs_wf m n p) + -- ═══════ STAGE 1: THE APPEND MERGE ═══════ + -- C8: the append merge. + have C8 := + (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv X (lhs_pairs_lift m n p) + wfqs2 + (Fragment.liftPairs_wf _ _ + ((lhsCA_wf m n p).append_right) + ((lhsCA_wf m n p).append_sep)) + ((lhs_pairs_lift m n p) ▸ List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + (Fragment.Equiv.relabelFlip + (Fragment.glueListAppend A + (Fragment.inlPairs (interfacePairs m n p)) + (pBlock m n p ++ mBlock m n p) + (lhsCA_wf m n p))) + (Fragment.foldSurvivingPermEquiv + ((lhs_pairs_lift m n p) ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- C7: the fold-survivor relabelling stage. + have C7 := (Fragment.glueListRelabel X iL (lhsQs2 m n p) + wfqs2).trans + ((Fragment.Equiv.relabelCongr C8 + (Fragment.foldSurvivingMapEquiv iL (lhsQs2 m n p))).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- C6: bridge the pair list back. + have C6 := (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (X.relabel iL) + (mapPairs_symm_cancel iL (lhsQs1 m n p)).symm + wfqs1 (Fragment.mapPairs_wf iL _ wfqs2) + ((mapPairs_symm_cancel iL (lhsQs1 m n p)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr C7 + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel iL (lhsQs1 m n p)).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- ═══════ STAGE 2: THE EMBEDDED FOLD ═══════ + -- E4: the glued pair is the embedded fold. + have E4 := + (Fragment.Equiv.relabelFlip + (Fragment.glueListDisjUnionLeft (F.disjUnion H) K + (interfacePairs m n p) + (interfacePairs_wf m n p))).trans + ((Fragment.Equiv.relabelEq _ + (_root_.Equiv.symm_symm iL)).trans + (Fragment.Equiv.relabelCongr + (Fragment.glueListProofIrrel A + (Fragment.inlPairs (interfacePairs m n p)) + (Fragment.inlPairs_wf _ (interfacePairs_wf m n p)) + ((lhsCA_wf m n p).append_left)) iL)) + -- C4: transport across E4. + have C4 := (Fragment.glueListCongr E4 (lhsQs1 m n p) + wfqs1).trans C6 + -- C3: the boundary relabelling stage. + have C3 := (Fragment.glueListRelabel (N.disjUnion K) σL + (lhsQs1 m n p) wfqs1).trans + ((Fragment.Equiv.relabelCongr C4 + (Fragment.foldSurvivingMapEquiv σL (lhsQs1 m n p))).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- C2: bridge the closure pairs. + have C2 := (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv ((N.disjUnion K).relabel σL) + (mapPairs_symm_cancel σL + (interfacePairs 0 (m + p) 0)).symm + (interfacePairs_wf 0 (m + p) 0) + (Fragment.mapPairs_wf σL _ wfqs1) + ((mapPairs_symm_cancel σL + (interfacePairs 0 (m + p) 0)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr C3 + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel σL + (interfacePairs 0 (m + p) 0)).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- ═══════ STAGE 3: THE CLOSURE'S OWN INTERFACE ═══════ + -- E1: peel the closure casts and normalize the composite. + have E1 := + (Fragment.relabelDisjUnionLeft (F.compose H) + (K.relabel (finCongr (by omega : m + p = m + p + 0))) + (finCongr (by omega : m + p = 0 + (m + p)))).trans + ((Fragment.Equiv.relabelCongr + (Fragment.relabelDisjUnionRight (F.compose H) K + (finCongr (by omega : m + p = m + p + 0))) + (_root_.Equiv.sumCongr + (finCongr (by omega : m + p = 0 + (m + p))) + (_root_.Equiv.refl _))).trans + ((Fragment.Equiv.relabelTrans _ _ _).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.Equiv.disjUnionCongr (composeNormal F H) + (Fragment.Equiv.refl K)).trans + (Fragment.relabelDisjUnionLeft N K + ((interfaceSurvEquiv m n p).trans finSumFinEquiv))) + ((_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (m + p))) + (finCongr (by omega : m + p = m + p + 0))).trans + (_root_.Equiv.sumCongr + (finCongr (by omega : m + p = 0 + (m + p))) + (_root_.Equiv.refl _)))).trans + (Fragment.Equiv.relabelTrans _ _ _)))) + -- C1: transport the closure gluing across E1. + have C1 := (Fragment.glueListCongr E1 + (interfacePairs 0 (m + p) 0) + (interfacePairs_wf 0 (m + p) 0)).trans C2 + -- ═══════ ASSEMBLY ═══════ + exact (composeNormal + ((F.compose H).relabel + (finCongr (by omega : m + p = 0 + (m + p)))) + (K.relabel + (finCongr (by omega : m + p = m + p + 0)))).trans + ((Fragment.Equiv.relabelCongr C1 + ((interfaceSurvEquiv 0 (m + p) 0).trans + finSumFinEquiv)).trans + (Fragment.Equiv.relabelTrans _ _ _)) + +/-! ### The right side, normalized -/ + +/-- The composed label identification of the right side. -/ +noncomputable def rotateLabelR (m n p : ℕ) : + Fragment.FoldSurviving + ((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p)) + (pBlock m n p ++ (nBlock m n p ++ mBlock m n p)) ≃ + Fin (0 + 0) := + ((Fragment.appendFlatten _ _ + ((rotatePairsR_wf m n p).append_sep)).symm.trans + ((Fragment.foldSurvivingPermEquiv + ((rot_q4_eq m n p) ▸ List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv (rotMR m n p) + (rotQ4 m n p)).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel (rotMR m n p) + (rotQ3 m n p)).symm ▸ + List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv + (Fragment.inrFoldEquiv (α := Fin (m + n)) + (hkPairs m n p)) + (rotQ3 m n p)).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel + (Fragment.inrFoldEquiv (α := Fin (m + n)) + (hkPairs m n p)) + (rotQ2 m n p)).symm ▸ + List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (m + n))) + (rotM2 m n p)) + (rotQ2 m n p)).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (m + n))) + (rotM2 m n p)) + (rotQ1 m n p)).symm ▸ + List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv + (rotSigma m n p) (rotQ1 m n p)).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel (rotSigma m n p) + (interfacePairs 0 (m + n) 0)).symm ▸ + List.Perm.refl _)).symm.trans + ((interfaceSurvEquiv 0 (m + n) 0).trans + finSumFinEquiv))))))))))) + +private theorem rotQ4_wf (m n p : ℕ) : + Fragment.PairsWF (rotQ4 m n p) := + Fragment.mapPairs_wf _ _ (Fragment.mapPairs_wf _ _ + (Fragment.mapPairs_wf _ _ (Fragment.mapPairs_wf _ _ (interfacePairs_wf 0 (m + n) 0)))) + +/-- **The right side, normalized**: the closure of `F` against +the rotated composite is iterated gluing of the three interface +blocks over the common ambient, `p`-block first. -/ +noncomputable def rotateNormalRight {m n p : ℕ} + (F : Fragment (Fin (m + n))) (H : Fragment (Fin (n + p))) + (K : Fragment (Fin (m + p))) : + (pairClose F + (K.compose (H.relabel (transposeEquiv n p)))).Equiv + ((Fragment.glueList ((F.disjUnion H).disjUnion K) + (pBlock m n p ++ (nBlock m n p ++ mBlock m n p)) + (rotatePairsR_wf m n p)).relabel + (rotateLabelR m n p)) := by + -- ═══════ SETUP ═══════ + -- The intermediate folds (`XKH`, `XR`, `N₂`, `UPB`), the relabels + -- between them, and their well-formedness certificates. + let σR := rotSigma m n p + let M₂ := rotM2 m n p + let MR := rotMR m n p + let i' := Fragment.inrFoldEquiv (α := Fin (m + n)) + (hkPairs m n p) + let sτ := _root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (m + p))) + (transposeEquiv n p) + let wfq1 : Fragment.PairsWF (rotQ1 m n p) := + Fragment.mapPairs_wf σR.symm _ (interfacePairs_wf 0 (m + n) 0) + let wfq2 : Fragment.PairsWF (rotQ2 m n p) := + Fragment.mapPairs_wf + (_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (m + n))) + M₂).symm _ wfq1 + let wfq3 : Fragment.PairsWF (rotQ3 m n p) := + Fragment.mapPairs_wf i'.symm _ wfq2 + let wfq4 : Fragment.PairsWF (rotQ4 m n p) := by + exact rotQ4_wf m n p + let A := (F.disjUnion H).disjUnion K + let XKH := Fragment.glueList (K.disjUnion H) (hkPairs m n p) + (hkPairs_wf m n p) + let XR := Fragment.glueList + (F.disjUnion (K.disjUnion H)) + (Fragment.inrPairs (α := Fin (m + n)) (hkPairs m n p)) + (Fragment.inrPairs_wf _ (hkPairs_wf m n p)) + let N₂ := Fragment.glueList + (K.disjUnion (H.relabel (transposeEquiv n p))) + (interfacePairs m p n) (interfacePairs_wf m p n) + let UPB := Fragment.glueList A (pBlock m n p) + ((rotatePairsR_wf m n p).append_left) + let ground := Fragment.mapPairs ((rotBridge m n p).symm).symm + (Fragment.inrPairs (α := Fin (m + n)) (hkPairs m n p)) + let wfground : Fragment.PairsWF ground := + Fragment.mapPairs_wf ((rotBridge m n p).symm).symm _ + (Fragment.inrPairs_wf _ (hkPairs_wf m n p)) + -- ═══════ STAGE 1: THE APPEND MERGE AND THE AMBIENT BRIDGE ═══════ + -- CR-append: the append merge. + have CRapp := + (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv UPB (rot_q4_eq m n p) + wfq4 + (Fragment.liftPairs_wf _ _ + ((rotatePairsR_wf m n p).append_right) + ((rotatePairsR_wf m n p).append_sep)) + ((rot_q4_eq m n p) ▸ List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + (Fragment.Equiv.relabelFlip + (Fragment.glueListAppend A (pBlock m n p) + (nBlock m n p ++ mBlock m n p) + (rotatePairsR_wf m n p))) + (Fragment.foldSurvivingPermEquiv + ((rot_q4_eq m n p) ▸ List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- CRX: the ambient bridge on the p-fold. + have BE := + (Fragment.disjUnionAssoc F H K).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.Equiv.disjUnionCongr (Fragment.Equiv.refl F) + (Fragment.disjUnionComm H K)).trans + (Fragment.relabelDisjUnionRight F (K.disjUnion H) + (_root_.Equiv.sumComm (Fin (m + p)) (Fin (n + p))))) + (_root_.Equiv.sumAssoc (Fin (m + n)) (Fin (n + p)) + (Fin (m + p))).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + have CRX := (Fragment.glueListCongr (Fragment.Equiv.relabelFlip BE) _ _).trans + (glueListPullRelabelTrans A (rotBridge m n p).symm + (Fragment.inrPairs (α := Fin (m + n)) (hkPairs m n p)) + (Fragment.inrPairs_wf _ (hkPairs_wf m n p)) + (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv A (rot_ground m n p) wfground + ((rotatePairsR_wf m n p).append_left) + ((rot_ground m n p) ▸ List.Perm.refl _)))) + -- ═══════ STAGE 2: THE EMBEDDED FOLD ═══════ + -- CR5: transport across the bridge. + have CR5 := (Fragment.glueListCongr CRX (rotQ3 m n p) wfq3).trans + (glueListPullRelabelTrans UPB MR (rotQ3 m n p) wfq3 CRapp) + -- E5: the embedded fold. + have E5 := + (Fragment.Equiv.relabelFlip + (Fragment.glueListDisjUnionRight F (K.disjUnion H) + (hkPairs m n p) (hkPairs_wf m n p))).trans + (Fragment.Equiv.relabelEq XR (_root_.Equiv.symm_symm i')) + -- CR3: the embedded-fold stage. + have CR3 := (Fragment.glueListCongr E5 (rotQ2 m n p) wfq2).trans + (glueListPullRelabelTrans XR i' (rotQ2 m n p) wfq2 CR5) + -- ═══════ STAGE 3: THE TRANSPOSE AND SWAP ON THE INNER FOLD ═══════ + -- E3: the inner fold across the transpose and the swap. + have E3 := (Fragment.glueListCongr + (Fragment.relabelDisjUnionRight K H (transposeEquiv n p)) _ _).trans + (glueListPullRelabelTrans (K.disjUnion H) sτ (interfacePairs m p n) + (interfacePairs_wf m p n) + ((Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (K.disjUnion H) + (kh_pullback m n p) + (Fragment.mapPairs_wf sτ.symm _ + (interfacePairs_wf m p n)) + ((hkPairs_swap m n p) ▸ + Fragment.swapPairs_wf _ (hkPairs_wf m n p)) + ((kh_pullback m n p) ▸ List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (K.disjUnion H) + (hkPairs_swap m n p).symm + ((hkPairs_swap m n p) ▸ + Fragment.swapPairs_wf _ (hkPairs_wf m n p)) + (Fragment.swapPairs_wf _ (hkPairs_wf m n p)) + ((hkPairs_swap m n p).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + (Fragment.glueListSwap (K.disjUnion H) + (hkPairs m n p) (hkPairs_wf m n p)) + (Fragment.foldSurvivingPermEquiv + ((hkPairs_swap m n p).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _))) + (Fragment.foldSurvivingPermEquiv + ((kh_pullback m n p) ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)))) + -- CR2: the inner-transport stage. + have CR2 := (Fragment.glueListCongr + ((Fragment.Equiv.disjUnionCongr (Fragment.Equiv.refl F) E3).trans + (Fragment.relabelDisjUnionRight F XKH M₂)) (rotQ1 m n p) wfq1).trans + (glueListPullRelabelTrans (F.disjUnion XKH) + (_root_.Equiv.sumCongr (_root_.Equiv.refl _) M₂) + (rotQ1 m n p) wfq1 CR3) + -- ═══════ STAGE 4: THE CLOSURE'S OWN INTERFACE ═══════ + -- E1: peel the closure casts and normalize the composite. + have E1 := pairCloseAmbientEquiv F _ (composeNormal K (H.relabel (transposeEquiv n p))) + -- CR1: transport the closure gluing. + have CR1 := (Fragment.glueListCongr E1 + (interfacePairs 0 (m + n) 0) + (interfacePairs_wf 0 (m + n) 0)).trans + (glueListPullRelabelTrans (F.disjUnion N₂) σR + (interfacePairs 0 (m + n) 0) + (interfacePairs_wf 0 (m + n) 0) CR2) + -- ═══════ ASSEMBLY ═══════ + exact (composeNormal + (F.relabel (finCongr (by omega : m + n = 0 + (m + n)))) + ((K.compose (H.relabel (transposeEquiv n p))).relabel + (finCongr (by omega : m + n = m + n + 0)))).trans + ((Fragment.Equiv.relabelCongr CR1 + ((interfaceSurvEquiv 0 (m + n) 0).trans + finSumFinEquiv)).trans + (Fragment.Equiv.relabelTrans _ _ _)) + +/-! ### The meet -/ + +/-- No label survives the full triangle gluing. -/ +theorem rotate_surv_empty (m n p : ℕ) + (x : Fragment.FoldSurviving + ((Fin (m + n) ⊕ Fin (n + p)) ⊕ Fin (m + p)) + (pBlock m n p ++ (nBlock m n p ++ mBlock m n p))) : + False := by + obtain ⟨xv, hxp⟩ := x + rcases xv with (a | g) | b + · rcases Nat.lt_or_ge a.val m with ha | ha + · have hmem : _ ∈ pBlock m n p ++ + (nBlock m n p ++ mBlock m n p) := + List.mem_append.mpr (Or.inr (List.mem_append.mpr (Or.inr + ((mem_mBlock m n p _).mpr ⟨⟨a.val, ha⟩, rfl⟩)))) + exact (hxp _ hmem).1 + (congrArg (fun z => Sum.inl (Sum.inl z)) + (Fin.ext (rfl : a.val = a.val))) + · have hk : a.val - m < n := by have := a.isLt; omega + have hmem : _ ∈ pBlock m n p ++ + (nBlock m n p ++ mBlock m n p) := + List.mem_append.mpr (Or.inr (List.mem_append.mpr (Or.inl + ((mem_nBlock m n p _).mpr ⟨⟨a.val - m, hk⟩, rfl⟩)))) + exact (hxp _ hmem).1 + (congrArg (fun z => Sum.inl (Sum.inl z)) + (Fin.ext (show a.val = m + (a.val - m) by omega))) + · rcases Nat.lt_or_ge g.val n with hg | hg + · have hmem : _ ∈ pBlock m n p ++ + (nBlock m n p ++ mBlock m n p) := + List.mem_append.mpr (Or.inr (List.mem_append.mpr (Or.inl + ((mem_nBlock m n p _).mpr ⟨⟨g.val, hg⟩, rfl⟩)))) + exact (hxp _ hmem).2 + (congrArg (fun z => Sum.inl (Sum.inr z)) + (Fin.ext (rfl : g.val = g.val))) + · have hk : g.val - n < p := by have := g.isLt; omega + have hmem : _ ∈ pBlock m n p ++ + (nBlock m n p ++ mBlock m n p) := + List.mem_append.mpr (Or.inl + ((mem_pBlock m n p _).mpr ⟨⟨g.val - n, hk⟩, rfl⟩)) + exact (hxp _ hmem).1 + (congrArg (fun z => Sum.inl (Sum.inr z)) + (Fin.ext (show g.val = n + (g.val - n) by omega))) + · rcases Nat.lt_or_ge b.val m with hb | hb + · have hmem : _ ∈ pBlock m n p ++ + (nBlock m n p ++ mBlock m n p) := + List.mem_append.mpr (Or.inr (List.mem_append.mpr (Or.inr + ((mem_mBlock m n p _).mpr ⟨⟨b.val, hb⟩, rfl⟩)))) + exact (hxp _ hmem).2 + (congrArg Sum.inr (Fin.ext (rfl : b.val = b.val))) + · have hk : b.val - m < p := by have := b.isLt; omega + have hmem : _ ∈ pBlock m n p ++ + (nBlock m n p ++ mBlock m n p) := + List.mem_append.mpr (Or.inl + ((mem_pBlock m n p _).mpr ⟨⟨b.val - m, hk⟩, rfl⟩)) + exact (hxp _ hmem).2 + (congrArg Sum.inr + (Fin.ext (show b.val = m + (b.val - m) by omega))) + +/-- **Rotation of closures** (accompanying paper, Lemma 3.3(a) and +Lemma 3.5(a)): the closure of a composite equals the closure of +the first factor against the rotated composite. -/ +noncomputable def pairCloseComposeRotate {m n p : ℕ} + (F : Fragment (Fin (m + n))) (H : Fragment (Fin (n + p))) + (K : Fragment (Fin (m + p))) : + (pairClose (F.compose H) K).Equiv + (pairClose F + (K.compose (H.relabel (transposeEquiv n p)))) := by + have hnb := (congrArg (· ++ (pBlock m n p ++ mBlock m n p)) + (nBlock_eq_inlPairs m n p)).symm + have BRIDGE : (Fragment.glueList ((F.disjUnion H).disjUnion K) + (Fragment.inlPairs (interfacePairs m n p) ++ + (pBlock m n p ++ mBlock m n p)) + (lhsCA_wf m n p)).Equiv + ((Fragment.glueList ((F.disjUnion H).disjUnion K) + (pBlock m n p ++ (nBlock m n p ++ mBlock m n p)) + (rotatePairsR_wf m n p)).relabel + ((Fragment.foldSurvivingPermEquiv + (rotatePairs_perm m n p)).symm.trans + (Fragment.foldSurvivingPermEquiv + (hnb ▸ List.Perm.refl _)).symm)) := + (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv + ((F.disjUnion H).disjUnion K) hnb + (lhsCA_wf m n p) (rotatePairsL_wf m n p) + (hnb ▸ List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.glueListPerm ((F.disjUnion H).disjUnion K) + (rotatePairs_perm m n p) + (rotatePairsL_wf m n p)).trans + (Fragment.Equiv.relabelCongr + (Fragment.glueListProofIrrel + ((F.disjUnion H).disjUnion K) + (pBlock m n p ++ (nBlock m n p ++ mBlock m n p)) + ((rotatePairsL_wf m n p).perm + (rotatePairs_perm m n p)) + (rotatePairsR_wf m n p)) + (Fragment.foldSurvivingPermEquiv + (rotatePairs_perm m n p)).symm)) + (Fragment.foldSurvivingPermEquiv + (hnb ▸ List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + refine (rotateNormalLeft F H K).trans ?_ + refine Fragment.Equiv.trans ?_ (rotateNormalRight F H K).symm + refine (Fragment.Equiv.relabelCongr BRIDGE + (rotateLabelL m n p)).trans ?_ + refine (Fragment.Equiv.relabelTrans _ _ _).trans ?_ + exact Fragment.Equiv.relabelEq _ + (_root_.Equiv.ext (fun x => + absurd (rotate_surv_empty m n p x) not_false)) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotateLeft.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotateLeft.lean new file mode 100644 index 0000000000..29fc408ed7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotateLeft.lean @@ -0,0 +1,1183 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate + +/-! +# Mirror rotation of closures + +For an `(s,t)`-fragment `W`, a `(t,u)`-fragment `F`, and an +`(s,u)`-fragment `K`, + + (W ∘ F) ∗ K ≃ F ∗ (Wᵀ ∘ K), + +where `Wᵀ` transposes the boundary of `W`. This is the +left-mirror variant of `pairCloseComposeRotate`. +-/ + +@[expose] public section + +namespace RS + +/-! ### The inner-pair pullback -/ + +/-- The inner composition interface of the left-rotated +side, pairing W-low with K-low. -/ +def wkPairs (s t u : ℕ) : + List ((Fin (s + t) ⊕ Fin (s + u)) × + (Fin (s + t) ⊕ Fin (s + u))) := + (List.finRange s).reverse.map (fun j => + (Sum.inl ⟨j.val, + by have := j.isLt; omega⟩, + Sum.inr ⟨j.val, + by have := j.isLt; omega⟩)) + +/-- wkPairs is well-formed. -/ +theorem wkPairs_wf (s t u : ℕ) : + Fragment.PairsWF (wkPairs s t u) := by + unfold Fragment.PairsWF wkPairs + rw [List.flatMap_map, List.nodup_flatMap] + refine ⟨fun k _ => by simp, ?_⟩ + rw [List.pairwise_reverse] + refine + (List.nodup_finRange s).pairwise_of_forall_ne ?_ + intro k _ j _ hkj x hxj hxk + simp only [List.mem_cons, List.not_mem_nil, + or_false] at hxj hxk + rcases hxj with rfl | rfl <;> + rcases hxk with h | h <;> + (simp only [Sum.inl.injEq, Sum.inr.injEq, + Fin.mk.injEq, reduceCtorEq] at h <;> + exact hkj (Fin.ext (by omega)).symm) + +/-- The transpose-pullback gives wkPairs +(generalized over the index list). -/ +private theorem wk_pullback_aux (s t u : ℕ) : + ∀ (l : List (Fin s)), + Fragment.mapPairs + (_root_.Equiv.sumCongr + (transposeEquiv s t) + (_root_.Equiv.refl + (Fin (s + u)))).symm + (l.map (fun j => + ((Sum.inl ⟨t + j.val, + by have := j.isLt; omega⟩ : + Fin (t + s) ⊕ Fin (s + u)), + Sum.inr ⟨j.val, + by have := j.isLt; omega⟩))) = + l.map (fun j => + (Sum.inl ⟨j.val, + by have := j.isLt; omega⟩, + Sum.inr ⟨j.val, + by have := j.isLt; omega⟩)) + | [] => rfl + | j :: l => by + simp only [List.map_cons, + Fragment.mapPairs, Prod.map] + refine congrArg₂ List.cons + (Prod.ext ?_ rfl) + (wk_pullback_aux s t u l) + change Sum.inl + ((transposeEquiv s t).symm + ⟨t + j.val, _⟩) = _ + exact congrArg Sum.inl + (transposeEquiv_symm_high s t + j.val j.isLt + (by have := j.isLt; omega) + (by have := j.isLt; omega)) + +/-- The transpose-pullback of interfacePairs gives +wkPairs. -/ +theorem wk_pullback (s t u : ℕ) : + Fragment.mapPairs + (_root_.Equiv.sumCongr + (transposeEquiv s t) + (_root_.Equiv.refl + (Fin (s + u)))).symm + (interfacePairs t s u) = + wkPairs s t u := + wk_pullback_aux s t u + (List.finRange s).reverse + +/-! ### The bridge equiv and ground lemma -/ + +/-- The ambient bridge for the left rotation: +`F ⊔ (W ⊔ K) ≃ (W ⊔ F) ⊔ K`. -/ +noncomputable def leftRotBridge (s t u : ℕ) : + (Fin (t + u) ⊕ + (Fin (s + t) ⊕ Fin (s + u))) ≃ + ((Fin (s + t) ⊕ Fin (t + u)) ⊕ + Fin (s + u)) := + (_root_.Equiv.sumAssoc (Fin (t + u)) + (Fin (s + t)) (Fin (s + u))).symm.trans + (_root_.Equiv.sumCongr + (_root_.Equiv.sumComm (Fin (t + u)) + (Fin (s + t))) + (_root_.Equiv.refl (Fin (s + u)))) + +/-- The bridge-pullback of embedded wkPairs is +mBlock (generalized over the index list). -/ +private theorem leftRot_ground_aux + (s t u : ℕ) : + ∀ (l : List (Fin s)), + Fragment.mapPairs + ((leftRotBridge s t u).symm).symm + ((l.map (fun j => + ((Sum.inl ⟨j.val, + by have := j.isLt; omega⟩ : + Fin (s + t) ⊕ Fin (s + u)), + Sum.inr ⟨j.val, + by have := j.isLt; omega⟩))).map + (Prod.map Sum.inr Sum.inr)) = + l.map (fun j => + (Sum.inl (Sum.inl ⟨j.val, + by have := j.isLt; omega⟩), + Sum.inr ⟨j.val, + by have := j.isLt; omega⟩)) + | [] => rfl + | j :: l => by + simp only [List.map_cons, + Fragment.mapPairs, Prod.map] + exact congrArg₂ List.cons rfl + (leftRot_ground_aux s t u l) + +/-- The bridge-pullback of embedded wkPairs is +mBlock. -/ +theorem leftRot_ground (s t u : ℕ) : + Fragment.mapPairs + ((leftRotBridge s t u).symm).symm + (Fragment.inrPairs + (α := Fin (t + u)) + (wkPairs s t u)) = + mBlock s t u := + leftRot_ground_aux s t u + (List.finRange s).reverse + +/-! ### The transport composites -/ + +/-- The inner transport: from `wkPairs` survivors to the +boundary of the rotated composition (no swap needed). -/ +noncomputable def leftRotM2 (s t u : ℕ) : + Fragment.FoldSurviving + (Fin (s + t) ⊕ Fin (s + u)) + (wkPairs s t u) ≃ + Fragment.FoldSurviving + (Fin (t + s) ⊕ Fin (s + u)) + (interfacePairs t s u) := + (Fragment.foldSurvivingPermEquiv + (show (Fragment.mapPairs + (_root_.Equiv.sumCongr + (transposeEquiv s t) + (_root_.Equiv.refl + (Fin (s + u)))).symm + (interfacePairs t s u)).Perm + (wkPairs s t u) + from (wk_pullback s t u) ▸ + List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv + (_root_.Equiv.sumCongr + (transposeEquiv s t) + (_root_.Equiv.refl (Fin (s + u)))) + (Fragment.mapPairs + (_root_.Equiv.sumCongr + (transposeEquiv s t) + (_root_.Equiv.refl + (Fin (s + u)))).symm + (interfacePairs t s u))).trans + (Fragment.foldSurvivingPermEquiv + (show (interfacePairs t s u).Perm + (Fragment.mapPairs + (_root_.Equiv.sumCongr + (transposeEquiv s t) + (_root_.Equiv.refl + (Fin (s + u)))) + (Fragment.mapPairs + (_root_.Equiv.sumCongr + (transposeEquiv s t) + (_root_.Equiv.refl + (Fin (s + u)))).symm + (interfacePairs t s u))) + from (mapPairs_symm_cancel + (_root_.Equiv.sumCongr + (transposeEquiv s t) + (_root_.Equiv.refl + (Fin (s + u)))) + (interfacePairs t s u)).symm ▸ + List.Perm.refl _)).symm) + +/-- The outer bridge transport: from `mBlock` survivors +to the embedded `wkPairs` fold survivors. -/ +noncomputable def leftRotMR (s t u : ℕ) : + Fragment.FoldSurviving + ((Fin (s + t) ⊕ Fin (t + u)) ⊕ + Fin (s + u)) + (mBlock s t u) ≃ + Fragment.FoldSurviving + (Fin (t + u) ⊕ + (Fin (s + t) ⊕ Fin (s + u))) + (Fragment.inrPairs + (α := Fin (t + u)) + (wkPairs s t u)) := + (Fragment.foldSurvivingPermEquiv + ((leftRot_ground s t u) ▸ + List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv + (leftRotBridge s t u).symm + (Fragment.mapPairs + ((leftRotBridge s t u).symm).symm + (Fragment.inrPairs + (α := Fin (t + u)) + (wkPairs s t u)))).trans + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel + (leftRotBridge s t u).symm + (Fragment.inrPairs + (α := Fin (t + u)) + (wkPairs s t u))).symm ▸ + List.Perm.refl _)).symm) + +/-- The composed transport of the right side's closure +pairs. -/ +noncomputable def leftRotE (s t u : ℕ) : + (Fin (0 + (t + u)) ⊕ Fin (t + u + 0)) ≃ + Fragment.FoldSurviving + ((Fin (s + t) ⊕ Fin (t + u)) ⊕ + Fin (s + u)) + (mBlock s t u) := + (rotSigma t u s).symm.trans + ((_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (t + u))) + (leftRotM2 s t u)).symm.trans + ((Fragment.inrFoldEquiv + (α := Fin (t + u)) + (wkPairs s t u)).symm.trans + (leftRotMR s t u).symm)) + +/-! ### Lifting the closure halves -/ + +/-- The high closure half lifts to the `p`-block. -/ +private theorem leftRot_lift_pblock_aux + (s t u : ℕ) + (ps₀ : List + (((Fin (s + t) ⊕ Fin (t + u)) ⊕ + Fin (s + u)) × + ((Fin (s + t) ⊕ Fin (t + u)) ⊕ + Fin (s + u)))) + (E : (Fin (0 + (t + u)) ⊕ Fin (t + u + 0)) ≃ + Fragment.FoldSurviving + ((Fin (s + t) ⊕ Fin (t + u)) ⊕ + Fin (s + u)) ps₀) + (hE1 : ∀ (ℓ : ℕ) (_ : ℓ < u) + (h1 : t + ℓ < 0 + (t + u)) + (h2 : t + ℓ < t + u), + (E (Sum.inl ⟨t + ℓ, h1⟩)).val = + Sum.inl (Sum.inr ⟨t + ℓ, h2⟩)) + (hE2 : ∀ (ℓ : ℕ) (_ : ℓ < u) + (h1 : t + ℓ < t + u + 0) + (h2 : s + ℓ < s + u), + (E (Sum.inr ⟨t + ℓ, h1⟩)).val = + Sum.inr ⟨s + ℓ, h2⟩) : + ∀ (l : List (Fin u)) + (hsep : Fragment.PairsSepAll ps₀ + (l.map (fun ℓ => + (Sum.inl (Sum.inr + ⟨t + ℓ.val, + by have := ℓ.isLt; omega⟩), + Sum.inr + ⟨s + ℓ.val, + by have := ℓ.isLt; omega⟩)))), + Fragment.mapPairs E + (l.map (fun ℓ => + ((Sum.inl ⟨t + ℓ.val, + by have := ℓ.isLt; omega⟩ : + Fin (0 + (t + u)) ⊕ + Fin (t + u + 0)), + Sum.inr ⟨t + ℓ.val, + by have := ℓ.isLt; omega⟩))) = + Fragment.liftPairs _ _ hsep + | [], _ => rfl + | ℓ :: l, hsep => by + simp only [List.map_cons, + Fragment.mapPairs, + Fragment.liftPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext ?_ ?_) + (leftRot_lift_pblock_aux s t u ps₀ E + hE1 hE2 l _) + · exact Subtype.ext (hE1 ℓ.val ℓ.isLt + (by omega) (by omega)) + · exact Subtype.ext (hE2 ℓ.val ℓ.isLt + (by omega) (by omega)) + +/-- The low closure half lifts to `nBlock.map swap`. -/ +private theorem leftRot_lift_nswap_aux + (s t u : ℕ) + (ps₀ : List + (((Fin (s + t) ⊕ Fin (t + u)) ⊕ + Fin (s + u)) × + ((Fin (s + t) ⊕ Fin (t + u)) ⊕ + Fin (s + u)))) + (E : (Fin (0 + (t + u)) ⊕ Fin (t + u + 0)) ≃ + Fragment.FoldSurviving + ((Fin (s + t) ⊕ Fin (t + u)) ⊕ + Fin (s + u)) ps₀) + (hE1 : ∀ (j : ℕ) (_ : j < t) + (h1 : j < 0 + (t + u)) + (h2 : j < t + u), + (E (Sum.inl ⟨j, h1⟩)).val = + Sum.inl (Sum.inr ⟨j, h2⟩)) + (hE2 : ∀ (j : ℕ) (_ : j < t) + (h1 : j < t + u + 0) + (h2 : s + j < s + t), + (E (Sum.inr ⟨j, h1⟩)).val = + Sum.inl (Sum.inl ⟨s + j, h2⟩)) : + ∀ (l : List (Fin t)) + (hsep : Fragment.PairsSepAll ps₀ + (l.map (fun j => + (Sum.inl (Sum.inr + ⟨j.val, + by have := j.isLt; omega⟩), + Sum.inl (Sum.inl + ⟨s + j.val, + by have := j.isLt; omega⟩))))), + Fragment.mapPairs E + (l.map (fun j => + ((Sum.inl ⟨j.val, + by have := j.isLt; omega⟩ : + Fin (0 + (t + u)) ⊕ + Fin (t + u + 0)), + Sum.inr ⟨j.val, + by have := j.isLt; omega⟩))) = + Fragment.liftPairs _ _ hsep + | [], _ => rfl + | j :: l, hsep => by + simp only [List.map_cons, + Fragment.mapPairs, + Fragment.liftPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext ?_ ?_) + (leftRot_lift_nswap_aux s t u ps₀ E + hE1 hE2 l _) + · exact Subtype.ext (hE1 j.val j.isLt + (by omega) (by omega)) + · exact Subtype.ext (hE2 j.val j.isLt + (by omega) (by omega)) + +/-- The `nBlock.map Prod.swap` block list. -/ +abbrev nBlockSwap (s t u : ℕ) := + (nBlock s t u).map Prod.swap + +/-- Membership in `nBlockSwap`. -/ +theorem mem_nBlockSwap (s t u : ℕ) (q) : + q ∈ nBlockSwap s t u ↔ + ∃ j : Fin t, + q = (Sum.inl (Sum.inr ⟨j.val, + by have := j.isLt; omega⟩), + Sum.inl (Sum.inl ⟨s + j.val, + by have := j.isLt; omega⟩)) := by + simp only [nBlockSwap, List.mem_map] + constructor + · rintro ⟨x, hmem, rfl⟩ + obtain ⟨j, rfl⟩ := + (mem_nBlock s t u _).mp hmem + exact ⟨j, rfl⟩ + · rintro ⟨j, rfl⟩ + exact ⟨_, + (mem_nBlock s t u _).mpr ⟨j, rfl⟩, rfl⟩ + +/-- `nBlockSwap` is the map of the nBlock swap. -/ +private theorem nBlockSwap_unfold (s t u : ℕ) : + nBlockSwap s t u = + (List.finRange t).reverse.map (fun j => + ((Sum.inl (Sum.inr ⟨j.val, + by have := j.isLt; omega⟩) : + (Fin (s + t) ⊕ Fin (t + u)) ⊕ + Fin (s + u)), + Sum.inl (Sum.inl ⟨s + j.val, + by have := j.isLt; omega⟩))) := by + unfold nBlockSwap nBlock + rw [List.map_map] + rfl + +/-- The right-side block list for the left rotation. -/ +abbrev leftRotPairsR (s t u : ℕ) := + mBlock s t u ++ + (pBlock s t u ++ nBlockSwap s t u) + +/-- Well-formedness of `leftRotPairsR`. -/ +theorem leftRotPairsR_wf (s t u : ℕ) : + Fragment.PairsWF (leftRotPairsR s t u) := by + unfold Fragment.PairsWF leftRotPairsR nBlockSwap + rw [List.flatMap_append, List.flatMap_append] + refine List.Nodup.append (mBlock_wf s t u) + (List.Nodup.append (pBlock_wf s t u) + (Fragment.swapPairs_wf _ + (nBlock_wf s t u)) ?_) ?_ + · intro x hx hy + obtain ⟨q₁, hq₁, hx₁⟩ := + List.mem_flatMap.mp hx + obtain ⟨q₂, hq₂, hy₁⟩ := + List.mem_flatMap.mp hy + obtain ⟨l, rfl⟩ := + (mem_pBlock s t u _).mp hq₁ + obtain ⟨j, rfl⟩ := + (mem_nBlockSwap s t u _).mp hq₂ + have hl := l.isLt; have hj := j.isLt + simp only [List.mem_cons, + List.not_mem_nil, or_false] at hx₁ hy₁ + rcases hx₁ with rfl | rfl <;> + rcases hy₁ with h | h <;> + (simp only [Sum.inl.injEq, Sum.inr.injEq, + Fin.mk.injEq, reduceCtorEq] at h <;> + omega) + · intro x hx hy + obtain ⟨q₁, hq₁, hx₁⟩ := + List.mem_flatMap.mp hx + obtain ⟨i, rfl⟩ := + (mem_mBlock s t u _).mp hq₁ + have hi := i.isLt + simp only [List.mem_cons, + List.not_mem_nil, or_false] at hx₁ + rcases List.mem_append.mp hy with hy | hy + · obtain ⟨q₂, hq₂, hy₁⟩ := + List.mem_flatMap.mp hy + obtain ⟨l, rfl⟩ := + (mem_pBlock s t u _).mp hq₂ + have hl := l.isLt + simp only [List.mem_cons, + List.not_mem_nil, or_false] at hy₁ + rcases hx₁ with rfl | rfl <;> + rcases hy₁ with h | h <;> + (simp only [Sum.inl.injEq, Sum.inr.injEq, + Fin.mk.injEq, reduceCtorEq] at h <;> + omega) + · obtain ⟨q₂, hq₂, hy₁⟩ := + List.mem_flatMap.mp hy + obtain ⟨j, rfl⟩ := + (mem_nBlockSwap s t u _).mp hq₂ + have hj := j.isLt + simp only [List.mem_cons, + List.not_mem_nil, or_false] at hy₁ + rcases hx₁ with rfl | rfl <;> + rcases hy₁ with h | h <;> + (simp only [Sum.inl.injEq, + Fin.mk.injEq, reduceCtorEq] at h <;> + omega) + +/-- The transported closure pairs are the lifted +right-side blocks. -/ +theorem leftRot_pairs_lift (s t u : ℕ) : + Fragment.mapPairs (leftRotE s t u) + (interfacePairs 0 (t + u) 0) = + Fragment.liftPairs _ _ + ((leftRotPairsR_wf s t u + ).append_sep) := by + rw [interfacePairs_closure_split t u, + mapPairs_append, + liftPairs_append] + apply congrArg₂ (· ++ ·) + · exact leftRot_lift_pblock_aux s t u _ + (leftRotE s t u) + (fun ℓ _ _ _ => + congrArg (fun z => + ((leftRotBridge s t u).symm + ).symm z) + (Fragment.inrFoldEquiv_symm_inl_val + (wkPairs s t u) _)) + (fun ℓ hℓ h1 h2 => + congrArg (fun z => + ((leftRotBridge s t u).symm + ).symm z) + ((Fragment.inrFoldEquiv_symm_inr_val + (wkPairs s t u) + ((leftRotM2 s t u).symm + (((interfaceSurvEquiv t s u + ).trans + finSumFinEquiv).symm + ⟨t + ℓ, by omega⟩))).trans + (congrArg Sum.inr + (congrArg (fun w => + (_root_.Equiv.sumCongr + (transposeEquiv s t) + (_root_.Equiv.refl + (Fin (s + u)))).symm w) + (interfaceEquiv_symm_high + t s u ℓ hℓ + (by omega) + (by omega)))))) + (List.finRange u).reverse _ + · simp only [nBlockSwap_unfold] + exact leftRot_lift_nswap_aux s t u _ + (leftRotE s t u) + (fun j _ _ _ => + congrArg (fun z => + ((leftRotBridge s t u).symm + ).symm z) + (Fragment.inrFoldEquiv_symm_inl_val + (wkPairs s t u) _)) + (fun j hj h1 h2 => + congrArg (fun z => + ((leftRotBridge s t u).symm + ).symm z) + ((Fragment.inrFoldEquiv_symm_inr_val + (wkPairs s t u) + ((leftRotM2 s t u).symm + (((interfaceSurvEquiv t s u + ).trans + finSumFinEquiv).symm + ⟨j, by omega⟩))).trans + (congrArg Sum.inr + ((congrArg (fun w => + (_root_.Equiv.sumCongr + (transposeEquiv s t) + (_root_.Equiv.refl + (Fin (s + u)))).symm w) + (interfaceEquiv_symm_low + t s u j hj + (by omega) + (by omega))).trans + (congrArg Sum.inl + (transposeEquiv_symm_low + s t j hj + (by omega) + (by omega))))))) + (List.finRange t).reverse _ + +/-! ### The Q stages -/ + +/-- The right side's closure pairs, boundary stage. -/ +noncomputable def leftRotQ1 (s t u : ℕ) := + Fragment.mapPairs (rotSigma t u s).symm + (interfacePairs 0 (t + u) 0) + +/-- The right side's closure pairs, inner stage. -/ +noncomputable def leftRotQ2 (s t u : ℕ) := + Fragment.mapPairs + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (t + u))) + (leftRotM2 s t u)).symm + (leftRotQ1 s t u) + +/-- The right side's closure pairs, embedded stage. -/ +noncomputable def leftRotQ3 (s t u : ℕ) := + Fragment.mapPairs + (Fragment.inrFoldEquiv + (α := Fin (t + u)) + (wkPairs s t u)).symm + (leftRotQ2 s t u) + +/-- The right side's closure pairs, ambient stage. -/ +noncomputable def leftRotQ4 (s t u : ℕ) := + Fragment.mapPairs + (leftRotMR s t u).symm + (leftRotQ3 s t u) + +/-- The fully transported closure pairs are the lifted +right-side blocks. -/ +theorem leftRot_q4_eq (s t u : ℕ) : + leftRotQ4 s t u = + Fragment.liftPairs _ _ + ((leftRotPairsR_wf s t u + ).append_sep) := by + change Fragment.mapPairs + (leftRotMR s t u).symm + (Fragment.mapPairs + (Fragment.inrFoldEquiv + (α := Fin (t + u)) + (wkPairs s t u)).symm + (Fragment.mapPairs + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (t + u))) + (leftRotM2 s t u)).symm + (Fragment.mapPairs + (rotSigma t u s).symm + (interfacePairs 0 (t + u) 0)))) = _ + rw [mapPairs_mapPairs, mapPairs_mapPairs, + mapPairs_mapPairs] + exact leftRot_pairs_lift s t u + +/-! ### The label composite -/ + +/-- The label composite for the left-rotated right +side: peels through every Q-stage and finishes at +the empty surviving type. -/ +noncomputable def leftRotLabelR (s t u : ℕ) : + Fragment.FoldSurviving + ((Fin (s + t) ⊕ Fin (t + u)) ⊕ + Fin (s + u)) + (mBlock s t u ++ + (pBlock s t u ++ + nBlockSwap s t u)) ≃ + Fin (0 + 0) := + ((Fragment.appendFlatten _ _ + ((leftRotPairsR_wf s t u + ).append_sep)).symm.trans + ((Fragment.foldSurvivingPermEquiv + ((leftRot_q4_eq s t u) ▸ + List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv + (leftRotMR s t u) + (leftRotQ4 s t u)).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel + (leftRotMR s t u) + (leftRotQ3 s t u)).symm ▸ + List.Perm.refl _ + )).symm.trans + ((Fragment.foldSurvivingMapEquiv + (Fragment.inrFoldEquiv + (α := Fin (t + u)) + (wkPairs s t u)) + (leftRotQ3 s t u)).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel + (Fragment.inrFoldEquiv + (α := Fin (t + u)) + (wkPairs s t u)) + (leftRotQ2 s t u)).symm ▸ + List.Perm.refl _ + )).symm.trans + ((Fragment.foldSurvivingMapEquiv + (_root_.Equiv.sumCongr + (_root_.Equiv.refl + (Fin (t + u))) + (leftRotM2 s t u)) + (leftRotQ2 s t u)).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel + (_root_.Equiv.sumCongr + (_root_.Equiv.refl + (Fin (t + u))) + (leftRotM2 s t u)) + (leftRotQ1 s t u)).symm ▸ + List.Perm.refl _ + )).symm.trans + ((Fragment.foldSurvivingMapEquiv + (rotSigma t u s) + (leftRotQ1 s t u)).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel + (rotSigma t u s) + (interfacePairs 0 + (t + u) 0)).symm ▸ + List.Perm.refl _ + )).symm.trans + ((interfaceSurvEquiv 0 + (t + u) 0).trans + finSumFinEquiv + ))))))))))) + +/-! ### The right side, normalized -/ + +private theorem leftRotQ4_wf (s t u : ℕ) : + Fragment.PairsWF (leftRotQ4 s t u) := + Fragment.mapPairs_wf _ _ (Fragment.mapPairs_wf _ _ + (Fragment.mapPairs_wf _ _ (Fragment.mapPairs_wf _ _ (interfacePairs_wf 0 (t + u) 0)))) + +/-- **The right side, normalized**: the closure of `F` +against the left-rotated composite is iterated gluing +of the three interface blocks over the common ambient, +`m`-block first. -/ +noncomputable def leftRotNormalRight + {s t u : ℕ} + (W : Fragment (Fin (s + t))) + (F : Fragment (Fin (t + u))) + (K : Fragment (Fin (s + u))) : + (pairClose F + ((W.relabel (transposeEquiv s t)).compose + K)).Equiv + ((Fragment.glueList + ((W.disjUnion F).disjUnion K) + (mBlock s t u ++ + (pBlock s t u ++ + nBlockSwap s t u)) + (leftRotPairsR_wf s t u)).relabel + (leftRotLabelR s t u)) := by + -- ═══════ SETUP ═══════ + -- The three intermediate folds (`XWK`, `XR`, `N₂`, `UMB`), the + -- relabels between them, and their well-formedness certificates. + let σR := rotSigma t u s + let M₂ := leftRotM2 s t u + let MR := leftRotMR s t u + let i' := Fragment.inrFoldEquiv + (α := Fin (t + u)) (wkPairs s t u) + let sτ := _root_.Equiv.sumCongr + (transposeEquiv s t) + (_root_.Equiv.refl (Fin (s + u))) + let wfq1 : Fragment.PairsWF + (leftRotQ1 s t u) := + Fragment.mapPairs_wf σR.symm _ + (interfacePairs_wf 0 (t + u) 0) + let wfq2 : Fragment.PairsWF + (leftRotQ2 s t u) := + Fragment.mapPairs_wf + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (t + u))) + M₂).symm _ wfq1 + let wfq3 : Fragment.PairsWF + (leftRotQ3 s t u) := + Fragment.mapPairs_wf i'.symm _ wfq2 + let wfq4 : Fragment.PairsWF + (leftRotQ4 s t u) := by + exact leftRotQ4_wf s t u + let A := (W.disjUnion F).disjUnion K + let XWK := Fragment.glueList + (W.disjUnion K) (wkPairs s t u) + (wkPairs_wf s t u) + let XR := Fragment.glueList + (F.disjUnion (W.disjUnion K)) + (Fragment.inrPairs (α := Fin (t + u)) + (wkPairs s t u)) + (Fragment.inrPairs_wf _ + (wkPairs_wf s t u)) + let N₂ := Fragment.glueList + ((W.relabel + (transposeEquiv s t)).disjUnion K) + (interfacePairs t s u) + (interfacePairs_wf t s u) + let UMB := Fragment.glueList A + (mBlock s t u) + ((leftRotPairsR_wf s t u).append_left) + let ground := + Fragment.mapPairs + ((leftRotBridge s t u).symm).symm + (Fragment.inrPairs (α := Fin (t + u)) + (wkPairs s t u)) + let wfground : Fragment.PairsWF ground := + Fragment.mapPairs_wf + ((leftRotBridge s t u).symm).symm _ + (Fragment.inrPairs_wf _ + (wkPairs_wf s t u)) + -- ═══════ STAGE 1: THE APPEND MERGE AND THE AMBIENT BRIDGE ═══════ + -- `CRapp` merges the appended fold into one glue list; `BE` carries + -- the ambient `(W ⊔ F) ⊔ K` to `F ⊔ (W ⊔ K)`, which is the shape the + -- m-fold is stated over; `CRX` transports the fold along it. + have CRapp := + (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv UMB + (leftRot_q4_eq s t u) + wfq4 + (Fragment.liftPairs_wf _ _ + ((leftRotPairsR_wf s t u + ).append_right) + ((leftRotPairsR_wf s t u + ).append_sep)) + ((leftRot_q4_eq s t u) ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + (Fragment.Equiv.relabelFlip + (Fragment.glueListAppend A + (mBlock s t u) + (pBlock s t u ++ + nBlockSwap s t u) + (leftRotPairsR_wf s t u))) + (Fragment.foldSurvivingPermEquiv + ((leftRot_q4_eq s t u) ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- BE: the ambient bridge. + have BE := + (Fragment.Equiv.disjUnionCongr + (Fragment.disjUnionComm W F) + (Fragment.Equiv.refl K)).trans + ((Fragment.relabelDisjUnionLeft + (F.disjUnion W) K + (_root_.Equiv.sumComm + (Fin (t + u)) + (Fin (s + t)))).trans + ((Fragment.Equiv.relabelCongr + (Fragment.disjUnionAssoc F W K) + (_root_.Equiv.sumCongr + (_root_.Equiv.sumComm + (Fin (t + u)) (Fin (s + t))) + (_root_.Equiv.refl + (Fin (s + u))))).trans + (Fragment.Equiv.relabelTrans _ _ _))) + -- CRX: the ambient bridge on the m-fold. + have CRX := (Fragment.glueListCongr (Fragment.Equiv.relabelFlip BE) _ _).trans + (glueListPullRelabelTrans A (leftRotBridge s t u).symm + (Fragment.inrPairs (α := Fin (t + u)) (wkPairs s t u)) + (Fragment.inrPairs_wf _ (wkPairs_wf s t u)) + (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv A (leftRot_ground s t u) wfground + ((leftRotPairsR_wf s t u).append_left) + ((leftRot_ground s t u) ▸ List.Perm.refl _)))) + -- CR5: transport across the bridge. + -- ═══════ STAGE 2: THE EMBEDDED FOLD ═══════ + -- The fold sitting inside `F ⊔ –`: `CR5` transports along the + -- ambient bridge, `E5` identifies `F ⊔ XWK` with `XR` relabelled, + -- and `CR3` carries the fold across that identification. + have CR5 := (Fragment.glueListCongr CRX (leftRotQ3 s t u) wfq3).trans + (glueListPullRelabelTrans UMB MR (leftRotQ3 s t u) wfq3 CRapp) + -- E5: the embedded fold. + have E5 := + (Fragment.Equiv.relabelFlip + (Fragment.glueListDisjUnionRight + F (W.disjUnion K) (wkPairs s t u) + (wkPairs_wf s t u))).trans + (Fragment.Equiv.relabelEq XR + (_root_.Equiv.symm_symm i')) + -- CR3: the embedded-fold stage. + have CR3 := (Fragment.glueListCongr E5 (leftRotQ2 s t u) wfq2).trans + (glueListPullRelabelTrans XR i' (leftRotQ2 s t u) wfq2 CR5) + -- E3: the inner fold (no swap needed). + -- ═══════ STAGE 3: THE TRANSPOSE ON `W ⊔ K` ═══════ + -- `E3` absorbs the `transposeEquiv` on `W` into the fold's own + -- relabel; `CR2` carries the next block across it. + have E3 := (Fragment.glueListCongr + (Fragment.relabelDisjUnionLeft W K (transposeEquiv s t)) _ _).trans + (glueListPullRelabelTrans (W.disjUnion K) sτ (interfacePairs t s u) + (interfacePairs_wf t s u) + (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (W.disjUnion K) (wk_pullback s t u) + (Fragment.mapPairs_wf sτ.symm _ (interfacePairs_wf t s u)) + (wkPairs_wf s t u) ((wk_pullback s t u) ▸ List.Perm.refl _)))) + -- CR2: the inner-transport stage. + have CR2 := (Fragment.glueListCongr + ((Fragment.Equiv.disjUnionCongr (Fragment.Equiv.refl F) E3).trans + (Fragment.relabelDisjUnionRight F XWK M₂)) (leftRotQ1 s t u) wfq1).trans + (glueListPullRelabelTrans (F.disjUnion XWK) + (_root_.Equiv.sumCongr (_root_.Equiv.refl _) M₂) + (leftRotQ1 s t u) wfq1 CR3) + -- E1: peel closure casts, normalize composite. + -- ═══════ STAGE 4: THE CLOSURE'S OWN INTERFACE ═══════ + -- The outermost `pairClose`, whose interface is the single block of + -- `t + u` labels; `CR1` carries the accumulated fold across it. + have E1 := pairCloseAmbientEquiv F _ (composeNormal (W.relabel (transposeEquiv s t)) K) + -- CR1: transport the closure gluing. + have CR1 := (Fragment.glueListCongr E1 + (interfacePairs 0 (t + u) 0) + (interfacePairs_wf 0 (t + u) 0)).trans + (glueListPullRelabelTrans (F.disjUnion N₂) σR + (interfacePairs 0 (t + u) 0) + (interfacePairs_wf 0 (t + u) 0) CR2) + -- Assemble. + -- ═══════ ASSEMBLY ═══════ + exact (composeNormal + (F.relabel (finCongr + (by omega : t + u = 0 + (t + u)))) + (((W.relabel + (transposeEquiv s t)).compose + K).relabel (finCongr + (by omega : + t + u = t + u + 0)))).trans + ((Fragment.Equiv.relabelCongr CR1 + ((interfaceSurvEquiv 0 + (t + u) 0).trans + finSumFinEquiv)).trans + (Fragment.Equiv.relabelTrans + _ _ _)) + +/-! ### Bridge helpers -/ + +/-- Swapping each pair in a liftPairs list amounts to +lifting the swapped suffix. -/ +theorem leftRotate_liftPairs_map_swap + {α : Type} + (ps : List (α × α)) : + ∀ (qs : List (α × α)) + (h : Fragment.PairsSepAll ps qs) + (h' : Fragment.PairsSepAll ps + (qs.map Prod.swap)), + (Fragment.liftPairs ps qs h).map + Prod.swap = + Fragment.liftPairs ps + (qs.map Prod.swap) h' + | [], _, _ => rfl + | _ :: qs, _, _ => + congrArg₂ List.cons + (Prod.ext (Subtype.ext rfl) + (Subtype.ext rfl)) + (leftRotate_liftPairs_map_swap ps qs _ _) + +/-- Permutation from rotatePairsL to the +intermediate form mBlock ++ (pBlock ++ nBlock). -/ +theorem leftRotatePairs_perm + (s t u : ℕ) : + (nBlock s t u ++ + (pBlock s t u ++ + mBlock s t u)).Perm + (mBlock s t u ++ + (pBlock s t u ++ + nBlock s t u)) := + (List.perm_append_comm_assoc _ _ _).trans + ((List.Perm.append_left _ + List.perm_append_comm).trans + (List.perm_append_comm_assoc _ _ _)) + +/-! ### The meet -/ + +/-- No label survives the full left-rotation +gluing. -/ +theorem leftRot_surv_empty (s t u : ℕ) + (x : Fragment.FoldSurviving + ((Fin (s + t) ⊕ Fin (t + u)) ⊕ + Fin (s + u)) + (mBlock s t u ++ + (pBlock s t u ++ + nBlockSwap s t u))) : + False := by + obtain ⟨xv, hxp⟩ := x + rcases xv with (a | g) | b + · rcases Nat.lt_or_ge a.val s with ha | ha + · have hmem : + _ ∈ mBlock s t u ++ + (pBlock s t u ++ + nBlockSwap s t u) := + List.mem_append.mpr (Or.inl + ((mem_mBlock s t u _).mpr + ⟨⟨a.val, ha⟩, rfl⟩)) + exact (hxp _ hmem).1 + (congrArg (fun z => + Sum.inl (Sum.inl z)) + (Fin.ext rfl)) + · have hj : a.val - s < t := by + have := a.isLt; omega + have hmem : + _ ∈ mBlock s t u ++ + (pBlock s t u ++ + nBlockSwap s t u) := + List.mem_append.mpr (Or.inr + (List.mem_append.mpr (Or.inr + ((mem_nBlockSwap s t u _).mpr + ⟨⟨a.val - s, hj⟩, rfl⟩)))) + exact (hxp _ hmem).2 + (congrArg (fun z => + Sum.inl (Sum.inl z)) + (Fin.ext + (show a.val = + s + (a.val - s) + by omega))) + · rcases Nat.lt_or_ge g.val t with hg | hg + · have hmem : + _ ∈ mBlock s t u ++ + (pBlock s t u ++ + nBlockSwap s t u) := + List.mem_append.mpr (Or.inr + (List.mem_append.mpr (Or.inr + ((mem_nBlockSwap s t u _).mpr + ⟨⟨g.val, hg⟩, rfl⟩)))) + exact (hxp _ hmem).1 + (congrArg (fun z => + Sum.inl (Sum.inr z)) + (Fin.ext rfl)) + · have hk : g.val - t < u := by + have := g.isLt; omega + have hmem : + _ ∈ mBlock s t u ++ + (pBlock s t u ++ + nBlockSwap s t u) := + List.mem_append.mpr (Or.inr + (List.mem_append.mpr (Or.inl + ((mem_pBlock s t u _).mpr + ⟨⟨g.val - t, hk⟩, rfl⟩)))) + exact (hxp _ hmem).1 + (congrArg (fun z => + Sum.inl (Sum.inr z)) + (Fin.ext + (show g.val = + t + (g.val - t) + by omega))) + · rcases Nat.lt_or_ge b.val s with hb | hb + · have hmem : + _ ∈ mBlock s t u ++ + (pBlock s t u ++ + nBlockSwap s t u) := + List.mem_append.mpr (Or.inl + ((mem_mBlock s t u _).mpr + ⟨⟨b.val, hb⟩, rfl⟩)) + exact (hxp _ hmem).2 + (congrArg Sum.inr + (Fin.ext rfl)) + · have hk : b.val - s < u := by + have := b.isLt; omega + have hmem : + _ ∈ mBlock s t u ++ + (pBlock s t u ++ + nBlockSwap s t u) := + List.mem_append.mpr (Or.inr + (List.mem_append.mpr (Or.inl + ((mem_pBlock s t u _).mpr + ⟨⟨b.val - s, hk⟩, rfl⟩)))) + exact (hxp _ hmem).2 + (congrArg Sum.inr + (Fin.ext + (show b.val = + s + (b.val - s) + by omega))) + +/-! ### The final theorem -/ + +/-- The reassociated left-rotation pairs form a well-formed gluing list. -/ +theorem leftRotatePairs_assoc_wf (s t u : ℕ) : + Fragment.PairsWF ((mBlock s t u ++ pBlock s t u) ++ nBlock s t u) := by + simpa only [List.append_assoc] using + (rotatePairsL_wf s t u).perm (leftRotatePairs_perm s t u) + +/-- **Mirror rotation of closures**: the closure of +a composite equals the closure of the second factor +against the left-rotated composite. -/ +noncomputable def pairCloseComposeRotateLeft + {s t u : ℕ} + (W : Fragment (Fin (s + t))) + (F : Fragment (Fin (t + u))) + (K : Fragment (Fin (s + u))) : + (pairClose (W.compose F) K).Equiv + (pairClose F + ((W.relabel + (transposeEquiv s t)).compose + K)) := by + -- ═══════ SETUP: THE AMBIENT AND THE INTERMEDIATE PAIR LISTS ═══════ + set A := (W.disjUnion F).disjUnion K + -- nBlock ↔ inlPairs + have hnb := + (congrArg + (· ++ (pBlock s t u ++ mBlock s t u)) + (nBlock_eq_inlPairs s t u)).symm + -- Intermediate pair lists + set mp := mBlock s t u ++ pBlock s t u + have wf_M : + Fragment.PairsWF + (mBlock s t u ++ + (pBlock s t u ++ + nBlock s t u)) := + (rotatePairsL_wf s t u).perm + (leftRotatePairs_perm s t u) + have hassocM : + mBlock s t u ++ + (pBlock s t u ++ nBlock s t u) = + mp ++ nBlock s t u := + (List.append_assoc _ _ _).symm + have wf_MA : + Fragment.PairsWF + (mp ++ nBlock s t u) := by + exact leftRotatePairs_assoc_wf s t u + have hassocR : + mp ++ nBlockSwap s t u = + mBlock s t u ++ + (pBlock s t u ++ + nBlockSwap s t u) := + List.append_assoc _ _ _ + have wf_RA : + Fragment.PairsWF + (mp ++ nBlockSwap s t u) := + hassocR ▸ leftRotPairsR_wf s t u + -- Abbreviate the inner fragment + set X := Fragment.glueList A mp + wf_MA.append_left + -- Suffix swap intermediates + set lPN := Fragment.liftPairs mp + (nBlock s t u) wf_MA.append_sep + set wfPN := Fragment.liftPairs_wf mp + (nBlock s t u) wf_MA.append_right + wf_MA.append_sep + set lPNS := Fragment.liftPairs mp + (nBlockSwap s t u) wf_RA.append_sep + set wfPNS := Fragment.liftPairs_wf mp + (nBlockSwap s t u) + wf_RA.append_right + wf_RA.append_sep + have lPeq := + leftRotate_liftPairs_map_swap mp (nBlock s t u) + wf_MA.append_sep wf_RA.append_sep + -- ═══════ STAGE 1: THE SUFFIX SWAP, IN SIX STEPS ═══════ + -- h1: GL_M → GL_MA (assoc) + have h1 := + Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv A + hassocM wf_M wf_MA + (hassocM ▸ List.Perm.refl _)) + -- h2: GL_MA → GL(X, lPN) (split) + have h2 := + Fragment.glueListAppend A mp + (nBlock s t u) wf_MA + -- h3: GL(X, lPN) → GL(X, swap) (swap) + have h3 := + Fragment.Equiv.relabelFlip + (Fragment.glueListSwap X lPN wfPN) + -- h4: GL(X, swap) → GL(X, lPNS) (eq) + have h4 := + Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv X lPeq + (Fragment.swapPairs_wf lPN wfPN) + wfPNS + (lPeq ▸ List.Perm.refl _)) + -- h5: GL(X, lPNS) → GL_RA (recombine) + have h5 := + Fragment.Equiv.relabelFlip' + ((Fragment.glueListAppend A mp + (nBlockSwap s t u) + wf_RA).symm) + -- h6: GL_RA → GL_R (assoc back) + have h6 := + Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv A + hassocR wf_RA + (leftRotPairsR_wf s t u) + (hassocR ▸ List.Perm.refl _)) + -- suffix_swap: GL_M ≡ GL_R.relabel(_) + have suffix_swap := + h1.trans + ((Fragment.Equiv.relabelCongr + (h2.trans + ((Fragment.Equiv.relabelCongr + (h3.trans + ((Fragment.Equiv.relabelCongr + (h4.trans + ((Fragment.Equiv.relabelCongr + (h5.trans + ((Fragment.Equiv.relabelCongr + h6 _).trans + (Fragment.Equiv.relabelTrans + _ _ _))) + _).trans + (Fragment.Equiv.relabelTrans + _ _ _))) + _).trans + (Fragment.Equiv.relabelTrans + _ _ _))) + _).trans + (Fragment.Equiv.relabelTrans + _ _ _))) + _).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- ═══════ STAGE 2: THE BRIDGE FROM THE LEFT FORM ═══════ + -- BRIDGE: GL_L ≡ GL_R.relabel(_) + have BRIDGE := + (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv A hnb + (lhsCA_wf s t u) + (rotatePairsL_wf s t u) + (hnb ▸ List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.glueListPerm A + (leftRotatePairs_perm s t u) + (rotatePairsL_wf s t u)).trans + ((Fragment.Equiv.relabelCongr + suffix_swap _).trans + (Fragment.Equiv.relabelTrans + _ _ _))) + _).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- ═══════ ASSEMBLY ═══════ + refine + (rotateNormalLeft W F K).trans ?_ + refine Fragment.Equiv.trans ?_ + (leftRotNormalRight W F K).symm + refine + (Fragment.Equiv.relabelCongr + BRIDGE + (rotateLabelL s t u)).trans ?_ + refine + (Fragment.Equiv.relabelTrans + _ _ _).trans ?_ + exact Fragment.Equiv.relabelEq _ + (_root_.Equiv.ext (fun x => + absurd + (leftRot_surv_empty s t u x) + not_false)) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseUnion.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseUnion.lean new file mode 100644 index 0000000000..5ee3b48983 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseUnion.lean @@ -0,0 +1,286 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseTensor +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Multiplicativity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleTensor + +/-! +# Closure against a fragment with a closed attachment + +A closed component riding along the test fragment falls out of +the closure as a disjoint union: + +`pairClose F ((H ⊔ C) · clean) ≃ (pairClose F H) ∪ C`. + +Combined with `partialCloseTensor`, `strandBundleTensor` and +the multiplicativity of the parameter (Lemma 3.2), this yields the +trace multiplicativity (Lemma 3.5(b)). +-/ + +@[expose] public section + +namespace RS + +/-- The peel of the union closure: the closure casts against the +clean label. -/ +noncomputable def unionPeel (s t : ℕ) : + (Fin (s + t) ⊕ (Fin (s + t) ⊕ Fin (0 + 0))) ≃ + (Fin (0 + (s + t)) ⊕ Fin ((s + t) + 0)) := + _root_.Equiv.sumCongr + (finCongr (by omega : s + t = 0 + (s + t))) + ((pcTensorClose s t).trans + (finCongr (by omega : s + t = (s + t) + 0))) + +/-- The peeled union-closure pairs. -/ +noncomputable def unionQs (s t : ℕ) := + Fragment.mapPairs (unionPeel s t).symm + (interfacePairs 0 (s + t) 0) + +private theorem union_ground_high_aux (s t : ℕ) : + ∀ (l : List (Fin t)), + Fragment.mapPairs (unionPeel s t).symm + (l.map (fun k => + ((Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩ : + Fin (0 + (s + t)) ⊕ Fin ((s + t) + 0)), + Sum.inr ⟨s + k.val, by have := k.isLt; omega⟩))) = + l.map (fun k => + ((Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩ : + Fin (s + t) ⊕ (Fin (s + t) ⊕ Fin (0 + 0))), + Sum.inr (Sum.inl ⟨s + k.val, + by have := k.isLt; omega⟩))) + | [] => rfl + | k :: l => by + simp only [List.map_cons, Fragment.mapPairs, Prod.map] + exact congrArg₂ List.cons (Prod.ext rfl rfl) + (union_ground_high_aux s t l) + +private theorem union_ground_low_aux (s t : ℕ) : + ∀ (l : List (Fin s)), + Fragment.mapPairs (unionPeel s t).symm + (l.map (fun i => + ((Sum.inl ⟨i.val, by have := i.isLt; omega⟩ : + Fin (0 + (s + t)) ⊕ Fin ((s + t) + 0)), + Sum.inr ⟨i.val, by have := i.isLt; omega⟩))) = + l.map (fun i => + ((Sum.inl ⟨i.val, by have := i.isLt; omega⟩ : + Fin (s + t) ⊕ (Fin (s + t) ⊕ Fin (0 + 0))), + Sum.inr (Sum.inl ⟨i.val, by have := i.isLt; omega⟩))) + | [] => rfl + | i :: l => by + simp only [List.map_cons, Fragment.mapPairs, Prod.map] + exact congrArg₂ List.cons (Prod.ext rfl rfl) + (union_ground_low_aux s t l) + +/-- The peeled union-closure pairs are the associated embedding +of the inner closure pairs. -/ +theorem union_ground (s t : ℕ) : + Fragment.mapPairs (unionPeel s t).symm + (interfacePairs 0 (s + t) 0) = + Fragment.mapPairs + (_root_.Equiv.sumAssoc (Fin (s + t)) (Fin (s + t)) + (Fin (0 + 0))).symm.symm + (Fragment.inlPairs (β := Fin (0 + 0)) + (innerClosePairs s t)) := by + rw [interfacePairs_closure_split s t, mapPairs_append] + unfold ipHigh ipLow + rw [union_ground_high_aux s t, union_ground_low_aux s t] + unfold Fragment.mapPairs Fragment.inlPairs innerClosePairs + simp only [List.map_append, List.map_map] + rfl + +/-- The composed label identification of the union closure. -/ +noncomputable def unionLabel (s t : ℕ) : + (Fin (0 + 0) ⊕ Fin (0 + 0)) ≃ Fin (0 + 0) := + (_root_.Equiv.sumCongr (innerLabel s t).symm + (_root_.Equiv.refl (Fin (0 + 0)))).trans + ((Fragment.inlFoldEquiv (β := Fin (0 + 0)) + (innerClosePairs s t)).symm.trans + ((Fragment.foldSurvivingMapEquiv + (_root_.Equiv.sumAssoc (Fin (s + t)) (Fin (s + t)) + (Fin (0 + 0))).symm.symm + (Fragment.inlPairs (β := Fin (0 + 0)) + (innerClosePairs s t))).trans + ((Fragment.foldSurvivingPermEquiv + ((union_ground s t) ▸ List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv (unionPeel s t) + (unionQs s t)).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel (unionPeel s t) + (interfacePairs 0 (s + t) 0)).symm ▸ + List.Perm.refl _)).symm.trans + ((interfaceSurvEquiv 0 (s + t) 0).trans + finSumFinEquiv)))))) + +/-- **The union closure, normalized.** -/ +noncomputable def unionNormal {s t : ℕ} + (F H : Fragment (Fin (s + t))) (C : ClosedFragment) : + (pairClose F ((H.disjUnion C).relabel + (pcTensorClose s t))).Equiv + (((pairClose F H).disjUnion C).relabel + (unionLabel s t)) := by + let σU := unionPeel s t + let qsU := unionQs s t + have wfqsU : Fragment.PairsWF qsU := + Fragment.mapPairs_wf σU.symm _ (interfacePairs_wf 0 (s + t) 0) + let aES := (_root_.Equiv.sumAssoc (Fin (s + t)) (Fin (s + t)) + (Fin (0 + 0))).symm + let ps₃ := Fragment.inlPairs (β := Fin (0 + 0)) + (innerClosePairs s t) + have wfps₃ : Fragment.PairsWF ps₃ := + Fragment.inlPairs_wf _ (innerClosePairs_wf s t) + let AmbS := F.disjUnion (H.disjUnion C) + let AmbT := (F.disjUnion H).disjUnion C + -- M5: the inner closure identified, inside the union. + have M5 : ((( Fragment.glueList (F.disjUnion H) + (innerClosePairs s t) + (innerClosePairs_wf s t)).disjUnion C).relabel + (Fragment.inlFoldEquiv (β := Fin (0 + 0)) + (innerClosePairs s t)).symm).Equiv + ((((pairClose F H).disjUnion C).relabel + (_root_.Equiv.sumCongr (innerLabel s t).symm + (_root_.Equiv.refl (Fin (0 + 0))))).relabel + (Fragment.inlFoldEquiv (β := Fin (0 + 0)) + (innerClosePairs s t)).symm) := + Fragment.Equiv.relabelCongr + ((Fragment.Equiv.disjUnionCongr + (Fragment.Equiv.relabelFlip (innerNormal F H)) + (Fragment.Equiv.refl C)).trans + (Fragment.relabelDisjUnionLeft (pairClose F H) C + (innerLabel s t).symm)) + (Fragment.inlFoldEquiv (β := Fin (0 + 0)) + (innerClosePairs s t)).symm + -- M4: localize the inner pairs to the F, H summands. + have M4 : (Fragment.glueList AmbT ps₃ wfps₃).Equiv + ((((pairClose F H).disjUnion C).relabel + (_root_.Equiv.sumCongr (innerLabel s t).symm + (_root_.Equiv.refl (Fin (0 + 0))))).relabel + (Fragment.inlFoldEquiv (β := Fin (0 + 0)) + (innerClosePairs s t)).symm) := + (Fragment.glueListDisjUnionLeft (F.disjUnion H) C + (innerClosePairs s t) (innerClosePairs_wf s t)).trans M5 + -- M3: the association relabelling stage. + have M3 := (Fragment.glueListRelabel AmbT aES.symm ps₃ + wfps₃).trans + ((Fragment.Equiv.relabelCongr M4 + (Fragment.foldSurvivingMapEquiv aES.symm ps₃)).trans + ((Fragment.Equiv.relabelTrans _ _ _).trans + (Fragment.Equiv.relabelTrans _ _ _))) + -- M2b: bridge the peeled pairs to the associated pairs. + have M2b := (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (AmbT.relabel aES.symm) + (union_ground s t) + wfqsU (Fragment.mapPairs_wf aES.symm _ wfps₃) + ((union_ground s t) ▸ List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr M3 + (Fragment.foldSurvivingPermEquiv + ((union_ground s t) ▸ List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- MA: the association of the ambient. + have MA := (Fragment.glueListCongr + (Fragment.Equiv.relabelFlip + (Fragment.disjUnionAssoc F H C)) qsU wfqsU).trans M2b + -- M2: the peel relabelling stage. + have M2 := (Fragment.glueListRelabel AmbS σU qsU wfqsU).trans + ((Fragment.Equiv.relabelCongr MA + (Fragment.foldSurvivingMapEquiv σU qsU)).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- M1: bridge the closure pairs. + have M1 := (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (AmbS.relabel σU) + (mapPairs_symm_cancel σU + (interfacePairs 0 (s + t) 0)).symm + (interfacePairs_wf 0 (s + t) 0) + (Fragment.mapPairs_wf σU _ wfqsU) + ((mapPairs_symm_cancel σU + (interfacePairs 0 (s + t) 0)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr M2 + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel σU + (interfacePairs 0 (s + t) 0)).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- E1: peel the closure casts. + have E1 : ((F.relabel + (finCongr (by omega : s + t = 0 + (s + t)))).disjUnion + (((H.disjUnion C).relabel + (pcTensorClose s t)).relabel + (finCongr (by omega : s + t = (s + t) + 0)))).Equiv + (AmbS.relabel σU) := + (Fragment.Equiv.disjUnionCongr (Fragment.Equiv.refl _) + (Fragment.Equiv.relabelTrans (H.disjUnion C) + (pcTensorClose s t) + (finCongr (by omega : s + t = (s + t) + 0)))).trans + ((Fragment.relabelDisjUnionLeft F _ + (finCongr (by omega : s + t = 0 + (s + t)))).trans + ((Fragment.Equiv.relabelCongr + (Fragment.relabelDisjUnionRight F (H.disjUnion C) + ((pcTensorClose s t).trans + (finCongr (by omega : s + t = (s + t) + 0)))) + (_root_.Equiv.sumCongr + (finCongr (by omega : s + t = 0 + (s + t))) + (_root_.Equiv.refl _))).trans + ((Fragment.Equiv.relabelTrans _ _ _).trans + (Fragment.Equiv.relabelEq _ + (_root_.Equiv.ext (fun x => by cases x <;> rfl)))))) + -- C1: transport the closure gluing across E1. + have C1 := (Fragment.glueListCongr E1 + (interfacePairs 0 (s + t) 0) + (interfacePairs_wf 0 (s + t) 0)).trans M1 + -- Assemble. + exact (composeNormal + (F.relabel (finCongr (by omega : s + t = 0 + (s + t)))) + (((H.disjUnion C).relabel (pcTensorClose s t)).relabel + (finCongr (by omega : s + t = (s + t) + 0)))).trans + ((Fragment.Equiv.relabelCongr C1 + ((interfaceSurvEquiv 0 (s + t) 0).trans + finSumFinEquiv)).trans + (Fragment.Equiv.relabelTrans _ _ _)) + +/-- **The union closure** (closed components fall out): closing +against a test fragment with a closed attachment is the union of +the closure with the attachment. -/ +noncomputable def pairCloseUnionRight {s t : ℕ} + (F H : Fragment (Fin (s + t))) (C : ClosedFragment) : + (pairClose F ((H.disjUnion C).relabel + (pcTensorClose s t))).Equiv + (ClosedFragment.union (pairClose F H) C) := + (unionNormal F H C).trans + (Fragment.Equiv.relabelEq _ + (_root_.Equiv.ext (fun x => by + rcases x with x0 | x0 <;> + exact absurd x0.isLt (by omega)))) + +/-- **Trace multiplicativity** (accompanying paper, Lemma 3.5(b)): +the trace of a tensor is the product of the traces. -/ +theorem fragTrace_tensor {R : ℕ} (f : EdgeRankParameter R) + {a b : ℕ} (F₁ : Fragment (Fin (a + a))) + (F₂ : Fragment (Fin (b + b))) : + fragTrace f.val (tensorFragment F₁ F₂) = + fragTrace f.val F₁ * fragTrace f.val F₂ := by + have E : (pairClose (tensorFragment F₁ F₂) + (strandBundle (a + b))).Equiv + (ClosedFragment.union (pairClose F₁ (strandBundle a)) + (pairClose F₂ (strandBundle b))) := + (pairCloseCongr (Fragment.Equiv.refl _) + (strandBundleTensor a b)).trans + ((pairCloseTensorAbsorb F₁ F₂ + (tensorFragment (strandBundle a) (strandBundle b))).trans + ((pairCloseCongr (Fragment.Equiv.refl F₁) + (partialCloseTensor F₂ (strandBundle a) + (strandBundle b))).trans + (pairCloseUnionRight F₁ (strandBundle a) + (pairClose F₂ (strandBundle b))))) + change f.val (pairClose (tensorFragment F₁ F₂) + (strandBundle (a + b))) = _ + rw [f.iso_invariant _ _ E, EdgeRankParameter.val_union] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedAgreement.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedAgreement.lean new file mode 100644 index 0000000000..0fd5872013 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedAgreement.lean @@ -0,0 +1,260 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathCanon +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.EulerianIndependence + +/-! +# Closed-fragment agreement: throughMixedPartitionAt = mixedPartition + +For a closed fragment (`Fragment (Fin 0)`), every quantifier +`∀ i : Fin 0, ...` is vacuously true. This makes the through-edge +corrections trivial — there are no boundary flags, so +`throughFlags = ∅`, `coreFlags = flags`, `throughProduct = 1`, and +the boundary-match conditions all hold vacuously. The corrected +constrained partition value therefore equals the unconstrained +Definition 5 value. + +This is the base case of the converse's factorization induction. +-/ + +@[expose] public section + +namespace RS + + + +variable {W : ClosedFragment} + +/-! ## Vacuous boundary conditions on closed fragments -/ + +/-- On a closed fragment, no flag is boundary-attached. -/ +theorem EdgeSubset.allInternal_of_closed (F : EdgeSubset W) : + F.allInternal := by + change F.boundaryFlags = ∅ + rw [Finset.eq_empty_iff_forall_notMem] + intro f hf + exact Fin.elim0 (F.attach_boundary_of_mem hf).choose + +/-- On a closed fragment, the core flags equal the full flags. -/ +theorem EdgeSubset.coreFlags_eq_flags (F : EdgeSubset W) : + F.coreFlags = F.flags := by + ext f + rw [F.mem_coreFlags_iff] + exact ⟨fun ⟨hf, _⟩ => hf, fun hf => ⟨hf, Or.inl (by + rcases ha : W.attach f with v | i + · exact ⟨v, rfl⟩ + · exact Fin.elim0 i)⟩⟩ + +/-- On a closed fragment, the through product is 1: each +through-flag's factor is 1 because `W.attach f` always lands in +`Sum.inl`. -/ +theorem EdgeSubset.throughProduct_one [LinearOrder (Fin 0)] + (F : EdgeSubset W) {k ℓ : ℕ} + (st : GenBoundaryState k ℓ (Fin 0)) : + F.throughProduct st = 1 := by + unfold EdgeSubset.throughProduct + apply Finset.prod_eq_one + intro ⟨f, _⟩ _ + rcases ha : W.attach f with v | i + · rcases hb : W.attach (W.pairing f) with w | j + · rfl + · exact Fin.elim0 j + · exact Fin.elim0 i + +/-- On a closed fragment, every even colouring satisfies the +even boundary match. -/ +theorem genEvenBoundaryMatch_closed (F : EdgeSubset W) + {k ℓ : ℕ} + (st : GenBoundaryState k ℓ (Fin 0)) + (hbnd : genBoundarySubsetMatches W F.flags st) + (ψ : F.EvenColouring k) : + genEvenBoundaryMatch F st hbnd ψ := + fun i => Fin.elim0 i + +/-- On a closed fragment, every core odd colouring satisfies the +core odd boundary match. -/ +theorem EdgeSubset.coreOddBoundaryMatch_closed (F : EdgeSubset W) + {k ℓ : ℕ} + (st : GenBoundaryState k ℓ (Fin 0)) + (φ : F.CoreOddColouring ℓ) : + F.coreOddBoundaryMatch st φ := + fun i => Fin.elim0 i + +/-! ## The colouring equivalence -/ + +/-- On a closed fragment, the core odd colouring type is equivalent +to the full odd colouring type, via `coreFlags = flags`. -/ +noncomputable def EdgeSubset.coreOddEquiv (F : EdgeSubset W) (ℓ : ℕ) : + F.CoreOddColouring ℓ ≃ F.OddColouring ℓ where + toFun φ := + ⟨fun f => φ.val ⟨f.val, + F.coreFlags_eq_flags.symm ▸ f.prop⟩, + fun f => (congrArg φ.val (Subtype.ext rfl)).trans + (φ.prop ⟨f.val, F.coreFlags_eq_flags.symm ▸ f.prop⟩)⟩ + invFun φ := + ⟨fun f => φ.val ⟨f.val, + F.coreFlags_eq_flags ▸ f.prop⟩, + fun f => (congrArg φ.val (Subtype.ext rfl)).trans + (φ.prop ⟨f.val, F.coreFlags_eq_flags ▸ f.prop⟩)⟩ + left_inv φ := Subtype.ext (funext fun _ => + congrArg φ.val (Subtype.ext rfl)) + right_inv φ := Subtype.ext (funext fun _ => + congrArg φ.val (Subtype.ext rfl)) + +/-! ## Vertex-local data agreement -/ + +/-- On a closed fragment, `coreOddPairFn` at `φ_core` agrees with +`oddPairFn` at `coreOddEquiv φ_core`. -/ +theorem EdgeSubset.coreOddPairFn_eq (F : EdgeSubset W) {ℓ : ℕ} + (κ : F.TransitionSystem) + (φ_core : F.CoreOddColouring ℓ) + (f : {f : W.Flag // f ∈ F.internalFlags}) : + F.coreOddPairFn κ.toRelTransitionSystem φ_core f = + F.oddPairFn κ (F.coreOddEquiv ℓ φ_core) + ⟨f.val, mem_flags_of_internalFlags F f.prop⟩ := by + unfold coreOddPairFn oddPairFn coreOddEquiv + rfl + +/-- On a closed fragment, `coreOddSignFn` at `φ_core` agrees with +`oddSignFn` at `coreOddEquiv φ_core`. -/ +theorem EdgeSubset.coreOddSignFn_eq (F : EdgeSubset W) {ℓ : ℕ} + (κ : F.TransitionSystem) + (φ_core : F.CoreOddColouring ℓ) + (f : {f : W.Flag // f ∈ F.internalFlags}) : + F.coreOddSignFn κ.toRelTransitionSystem φ_core f = + F.oddSignFn κ (F.coreOddEquiv ℓ φ_core) + ⟨f.val, mem_flags_of_internalFlags F f.prop⟩ := by + unfold coreOddSignFn oddSignFn coreOddEquiv + rfl + +/-- On a closed fragment, the core odd pairs along a list are the +odd pairs of the transported colouring. -/ +private theorem flatMap_coreOddPairFn_closed + {W : ClosedFragment} {F : EdgeSubset W} {ℓ : ℕ} + (κ : F.TransitionSystem) + (φ_core : F.CoreOddColouring ℓ) : + ∀ (l : List W.Flag) + (h1 : ∀ f ∈ l, f ∈ F.internalFlags) + (h2 : ∀ f ∈ l, f ∈ F.flags), + (l.attachWith (· ∈ F.internalFlags) h1).flatMap + (F.coreOddPairFn κ.toRelTransitionSystem φ_core) = + (l.attachWith (· ∈ F.flags) h2).flatMap + (F.oddPairFn κ (F.coreOddEquiv ℓ φ_core)) + | [], _, _ => rfl + | a :: as, h1, h2 => by + rw [List.attachWith_cons, List.attachWith_cons, + List.flatMap_cons, List.flatMap_cons] + rw [flatMap_coreOddPairFn_closed κ φ_core as + (fun f hf => h1 f (List.mem_cons_of_mem a hf)) + (fun f hf => h2 f (List.mem_cons_of_mem a hf))] + rfl + +/-- On a closed fragment, the core odd signs along a list are the +odd signs of the transported colouring. -/ +private theorem map_coreOddSignFn_closed + {W : ClosedFragment} {F : EdgeSubset W} {ℓ : ℕ} + (κ : F.TransitionSystem) + (φ_core : F.CoreOddColouring ℓ) : + ∀ (l : List W.Flag) + (h1 : ∀ f ∈ l, f ∈ F.internalFlags) + (h2 : ∀ f ∈ l, f ∈ F.flags), + (l.attachWith (· ∈ F.internalFlags) h1).map + (F.coreOddSignFn κ.toRelTransitionSystem φ_core) = + (l.attachWith (· ∈ F.flags) h2).map + (F.oddSignFn κ (F.coreOddEquiv ℓ φ_core)) + | [], _, _ => rfl + | a :: as, h1, h2 => by + rw [List.attachWith_cons, List.attachWith_cons, + List.map_cons, List.map_cons] + rw [map_coreOddSignFn_closed κ φ_core as + (fun f hf => h1 f (List.mem_cons_of_mem a hf)) + (fun f hf => h2 f (List.mem_cons_of_mem a hf))] + rfl + +/-- On a closed fragment, `coreOddListAt` at `φ_core` agrees with +`oddListAt` at `coreOddEquiv φ_core`. -/ +theorem EdgeSubset.coreOddListAt_eq (F : EdgeSubset W) {ℓ : ℕ} + {κ : F.TransitionSystem} (o : κ.Orientation) + (φ_core : F.CoreOddColouring ℓ) (v : W.Vertex) : + F.coreOddListAt o.toRel φ_core v = + F.oddListAt o (F.coreOddEquiv ℓ φ_core) v := by + unfold coreOddListAt oddListAt + -- relInFlagsAt o.toRel v = inFlagsAt o v (by rfl from relInFlagsAt_toRel) + change ((F.inFlagsAt o v).attachWith (· ∈ F.internalFlags) + _).flatMap _ = + ((F.inFlagsAt o v).attachWith (· ∈ F.flags) _).flatMap _ + exact flatMap_coreOddPairFn_closed κ φ_core (F.inFlagsAt o v) _ _ + +/-- On a closed fragment, `coreOddSignAt` at `φ_core` agrees with +`oddSignAt` at `coreOddEquiv φ_core`. -/ +theorem EdgeSubset.coreOddSignAt_eq (F : EdgeSubset W) {ℓ : ℕ} + {κ : F.TransitionSystem} (o : κ.Orientation) + (φ_core : F.CoreOddColouring ℓ) (v : W.Vertex) : + F.coreOddSignAt o.toRel φ_core v = + F.oddSignAt o (F.coreOddEquiv ℓ φ_core) v := by + unfold coreOddSignAt oddSignAt + change (((F.inFlagsAt o v).attachWith (· ∈ F.internalFlags) + _).map _).prod = + (((F.inFlagsAt o v).attachWith (· ∈ F.flags) _).map _).prod + exact congrArg List.prod + (map_coreOddSignFn_closed κ φ_core (F.inFlagsAt o v) _ _) + +/-! ## Circuit count agreement -/ + +/-- On a closed fragment, the open circuit count of the relative +transition system equals the standard circuit count. -/ +theorem EdgeSubset.openCircuitCount_eq_circuitCount (F : EdgeSubset W) + (κ : F.TransitionSystem) : + κ.toRelTransitionSystem.openCircuitCount = κ.circuitCount := by + rw [openCircuitCount_of_allInternal κ.toRelTransitionSystem + F.allInternal_of_closed, + relTransition_circuitCount_eq κ] + +/-! ## The per-subset summand agreement -/ + +/-- On a closed fragment, the through summand at an Eulerian +subset equals the standard mixed summand. -/ +theorem EdgeSubset.throughSummand_eq_mixedSummand + [LinearOrder (Fin 0)] + (F : EdgeSubset W) {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ (Fin 0)) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ : F.TransitionSystem} (o : κ.Orientation) : + F.throughSummand h st hbnd o.toRel + κ.toRelTransitionSystem.openCircuitCount = + F.mixedSummand h o := by + classical + unfold EdgeSubset.throughSummand EdgeSubset.mixedSummand + rw [F.openCircuitCount_eq_circuitCount κ] + rw [F.throughProduct_one st] + rw [mul_one] + congr 1 + refine Finset.sum_congr rfl fun ψ _ => ?_ + rw [ite_eq_left (genEvenBoundaryMatch_closed F st hbnd ψ)] + refine (Fintype.sum_equiv (F.coreOddEquiv ℓ) + (fun φ_core => + if F.coreOddBoundaryMatch st φ_core then + ∏ v : W.Vertex, + ((F.coreOddSignAt o.toRel φ_core v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) + (F.coreOddListAt o.toRel φ_core v)) + else (0 : ℂ)) + (fun φ => + ∏ v : W.Vertex, + ((F.oddSignAt o φ v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) + (F.oddListAt o φ v))) + (fun φ_core => ?_)) + rw [ite_eq_left (F.coreOddBoundaryMatch_closed st φ_core)] + refine Finset.prod_congr rfl fun v _ => ?_ + rw [F.coreOddSignAt_eq o φ_core v, + F.coreOddListAt_eq o φ_core v] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedCutDispatch.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedCutDispatch.lean new file mode 100644 index 0000000000..3139663d54 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedCutDispatch.lean @@ -0,0 +1,276 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GluePathMatch +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCrossDelta +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseDischarge +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PropThreeOpen + +/-! +# Path data across a closed glue + +A closed glue never rewires: the cut edge is the single edge joining +the two boundary flags, so a chain of the glued system transports to +the unglued one on the nose. The three transports here say so — +which flags are boundary after the glue, that the walk agrees step +for step, and that the path matching is carried across unchanged. +-/ + +@[expose] public section + +namespace RS + + +open Fragment + +namespace EdgeSubset + +variable {α : Type} {W : Fragment α} + +/-! ## Generic helpers -/ + +/-- Exit steps of boundary-terminated chain data agree. -/ +private theorem exit_unique_chain {F : EdgeSubset W} + (κ : F.RelTransitionSystem) {g : W.Flag} {n n' : ℕ} + (hcont : ∀ t, t < n → + W.pairing (iterWalk κ g t) ∈ F.internalFlags) + (hterm : W.pairing (iterWalk κ g n) ∈ F.boundaryFlags) + (hcont' : ∀ t, t < n' → + W.pairing (iterWalk κ g t) ∈ F.internalFlags) + (hterm' : W.pairing (iterWalk κ g n') ∈ F.boundaryFlags) : + n = n' := by + rcases Nat.lt_trichotomy n n' with h | h | h + · exact absurd hterm + (Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags (hcont' n h)) + · exact h + · exact absurd hterm' + (Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags (hcont n' h)) + +/-- `pathMatch` equals the terminal pairing of any +boundary-terminated chain data. -/ +private theorem pathMatch_eq_of_chainData {F : EdgeSubset W} + (κ : F.RelTransitionSystem) {g : W.Flag} + (hg : g ∈ F.boundaryFlags) {n : ℕ} + (hcont : ∀ t, t < n → + W.pairing (iterWalk κ g t) ∈ F.internalFlags) + (hterm : W.pairing (iterWalk κ g n) ∈ F.boundaryFlags) : + κ.pathMatch g hg = W.pairing (iterWalk κ g n) := by + obtain ⟨n₀, -, hcont₀, hpm₀⟩ := pathMatch_chain_length κ hg + have hterm₀ : W.pairing (iterWalk κ g n₀) ∈ F.boundaryFlags := by + rw [← hpm₀] + exact κ.pathMatch_mem hg + rw [hpm₀, exit_unique_chain κ hcont hterm hcont₀ hterm₀] + +/-! ## The closed path-data engine (either `b`) -/ + +section ClosedPathData + +variable {i j : α} + (hij : i ≠ j) + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (b : Bool) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairClosed i j hclosed).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetClosed s' b, + W.pairing f ∈ liftSubsetClosed s' b) + (κ' : (EdgeSubset.mk s' hc' : EdgeSubset + (W.gluePairClosed i j hclosed)).RelTransitionSystem) + (o' : κ'.Orientation) + +/-- The glued edge subset. -/ +local notation "Fg" => + (EdgeSubset.mk s' hc' : EdgeSubset (W.gluePairClosed i j hclosed)) + +/-- The lifted edge subset. -/ +local notation "Fl" => + (EdgeSubset.mk (liftSubsetClosed s' b) hc : EdgeSubset W) + +local notation "κW" => + RelTransitionSystem.unglueClosed hclosed b s' hc' hc κ' + +local notation "oW" => + unglueOrientationClosed hclosed b s' hc' hc κ' o' + +/-- **Boundary-flag correspondence (closed case)**: a surviving +flag is glued-boundary iff its value is lifted-boundary. -/ +theorem mem_boundaryFlags_glueClosed {f' : SurvivingFlag W i j} : + f' ∈ (Fg).boundaryFlags ↔ f'.val ∈ (Fl).boundaryFlags := by + constructor + · intro h + have hf : f'.val ∈ (Fl).flags := + (surviving_val_mem_liftClosed_iff s' b f').mpr + (mem_flags_of_boundaryFlags _ h) + rcases mem_internalFlags_or_boundaryFlags (Fl) hf with hint | hbd + · exact absurd h + (Finset.disjoint_left.mp + ((Fg).internalFlags_disjoint_boundaryFlags) + ((mem_internalFlags_glueClosed hclosed b s' hc' hc).mpr + hint)) + · exact hbd + · intro h + have hf : f' ∈ (Fg).flags := + (surviving_val_mem_liftClosed_iff s' b f').mp + (mem_flags_of_boundaryFlags _ h) + rcases mem_internalFlags_or_boundaryFlags (Fg) hf with hint | hbd + · exact absurd h + (Finset.disjoint_left.mp + ((Fl).internalFlags_disjoint_boundaryFlags) + ((mem_internalFlags_glueClosed hclosed b s' hc' hc).mp + hint)) + · exact hbd + +/-- **Unconditional walk agreement (closed case)**: the closed glue +never rewires, so the unglued walk from a surviving flag follows +the glued walk valuewise, with no continuation hypothesis. -/ +theorem iterWalk_unglueClosed_val_all (δ' : SurvivingFlag W i j) : + ∀ t, iterWalk (κW) δ'.val t = (iterWalk κ' δ' t).val := by + intro t + induction t with + | zero => rfl + | succ t ih => + change (κW).match_ (W.pairing (iterWalk (κW) δ'.val t)) = + (κ'.match_ ((W.gluePairClosed i j hclosed).pairing + (iterWalk κ' δ' t))).val + rw [ih] + exact unglueClosed_match_of_surviving hclosed b s' hc' hc κ' + (W.pairing (iterWalk κ' δ' t).val) + (pairing_val_surviving_closed hclosed (iterWalk κ' δ' t)) + +/-- **`pathMatch` transport across the closed unglue**: chains of +surviving boundary flags transport on the nose, for either `b`. -/ +theorem pathMatch_unglueClosed {δ' : SurvivingFlag W i j} + (hδ' : δ' ∈ (Fg).boundaryFlags) + (hδl : δ'.val ∈ (Fl).boundaryFlags) : + (κW).pathMatch δ'.val hδl = (κ'.pathMatch δ' hδ').val := by + -- ═══════ THE GLUED CHAIN IS THE BASE CHAIN ═══════ + -- A closed cut adds a circle and touches no walk, so the chain + -- of a surviving flag runs identically on both sides. + obtain ⟨n, -, hcont, hpm⟩ := pathMatch_chain_length κ' hδ' + have hwalk := iterWalk_unglueClosed_val_all hclosed b s' hc' hc + κ' δ' + have hcontW : ∀ t, t < n → + W.pairing (iterWalk (κW) δ'.val t) ∈ (Fl).internalFlags := by + intro t ht + rw [hwalk t] + exact internal_val_of_glueClosed hclosed b s' hc' hc + (hcont t ht) + have htermW : W.pairing (iterWalk (κW) δ'.val n) ∈ + (Fl).boundaryFlags := by + rw [hwalk n] + have hbg : (W.gluePairClosed i j hclosed).pairing + (iterWalk κ' δ' n) ∈ (Fg).boundaryFlags := by + rw [← hpm] + exact κ'.pathMatch_mem hδ' + exact (mem_boundaryFlags_glueClosed hclosed b s' hc' + hc).mp hbg + rw [pathMatch_eq_of_chainData (κW) hδl hcontW htermW, hwalk n, + hpm] + exact (gluePairClosed_pairing_val hclosed + (iterWalk κ' δ' n)).symm + +end ClosedPathData + +/-! ## The non-participating lift (`b = false`): chord diagram, +path sign, and the signed-value transport -/ + +section ClosedFalse + +variable {i j : α} + (hij : i ≠ j) + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairClosed i j hclosed).pairing f ∈ s') + (hcF : ∀ f ∈ liftSubsetClosed s' false, + W.pairing f ∈ liftSubsetClosed s' false) + (κ' : (EdgeSubset.mk s' hc' : EdgeSubset + (W.gluePairClosed i j hclosed)).RelTransitionSystem) + (o' : κ'.Orientation) + +local notation "Fg" => + (EdgeSubset.mk s' hc' : EdgeSubset (W.gluePairClosed i j hclosed)) + +local notation "FlF" => + (EdgeSubset.mk (liftSubsetClosed s' false) hcF : EdgeSubset W) + +local notation "κWF" => + RelTransitionSystem.unglueClosed hclosed false s' hc' hcF κ' + +local notation "oWF" => + unglueOrientationClosed hclosed false s' hc' hcF κ' o' + +end ClosedFalse + +/-! ## The participating lift (`b = true`): the signed-value +transport with explicit sign weight -/ + +section ClosedTrue + +variable {i j : α} + (hij : i ≠ j) + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairClosed i j hclosed).pairing f ∈ s') + (hcT : ∀ f ∈ liftSubsetClosed s' true, + W.pairing f ∈ liftSubsetClosed s' true) + (κ' : (EdgeSubset.mk s' hc' : EdgeSubset + (W.gluePairClosed i j hclosed)).RelTransitionSystem) + (o' : κ'.Orientation) + +local notation "Fg" => + (EdgeSubset.mk s' hc' : EdgeSubset (W.gluePairClosed i j hclosed)) + +local notation "FlT" => + (EdgeSubset.mk (liftSubsetClosed s' true) hcT : EdgeSubset W) + +local notation "κWT" => + RelTransitionSystem.unglueClosed hclosed true s' hc' hcT κ' + +local notation "oWT" => + unglueOrientationClosed hclosed true s' hc' hcT κ' o' + +end ClosedTrue + +/-! ## The assembled per-subset split -/ + +section ClosedAssembly + +variable {i j : α} + (hij : i ≠ j) + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairClosed i j hclosed).pairing f ∈ s') + (hcF : ∀ f ∈ liftSubsetClosed s' false, + W.pairing f ∈ liftSubsetClosed s' false) + (hcT : ∀ f ∈ liftSubsetClosed s' true, + W.pairing f ∈ liftSubsetClosed s' true) + (κ' : (EdgeSubset.mk s' hc' : EdgeSubset + (W.gluePairClosed i j hclosed)).RelTransitionSystem) + (o' : κ'.Orientation) + +local notation "Fg" => + (EdgeSubset.mk s' hc' : EdgeSubset (W.gluePairClosed i j hclosed)) + +local notation "FlF" => + (EdgeSubset.mk (liftSubsetClosed s' false) hcF : EdgeSubset W) + +local notation "FlT" => + (EdgeSubset.mk (liftSubsetClosed s' true) hcT : EdgeSubset W) + +local notation "κWF" => + RelTransitionSystem.unglueClosed hclosed false s' hc' hcF κ' + +local notation "κWT" => + RelTransitionSystem.unglueClosed hclosed true s' hc' hcT κ' + +end ClosedAssembly + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedIdentify.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedIdentify.lean new file mode 100644 index 0000000000..5d878aea03 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedIdentify.lean @@ -0,0 +1,214 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceCut +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionProduct + +/-! +# The closed identification at an arbitrary empty label type + +The composition of two fragments is built at the label type +`Fin 0 ⊕ Fin 0` and then relabelled to `Fin 0`. The Definition 5 +value lives at the latter, the colouring recursion at the former, so +the two have to be matched across the relabel. + +Both sides are the same sum of RS21 summands. At an empty label type +the chord sign is one and the label chords are empty, so any two +canonical data give the same summand; and the summand itself is +carried across a relabel by `relabel_throughSummand`. Together these +identify the relabelled fragment's Definition 5 value with the +constrained value downstairs, with no independence input. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + +open Fragment +section Indep + +variable {L : Type} + +/-- **At an empty label type the summand does not depend on the +canonical data.** The chord sign is one and the label chords are +empty, so Proposition 3 equates the two signed values. -/ +theorem throughSummand_canon_indep [LinearOrder L] [IsEmpty L] {V : Fragment L} + {k ℓ : ℕ} (F : EdgeSubset V) + (h : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ L) + (hbnd : genBoundarySubsetMatches V F.flags st) + (d₁ d₂ : F.CanonData) : + F.throughSummand h st hbnd d₁.2.val d₁.1.openCircuitCount + = F.throughSummand h st hbnd d₂.2.val d₂.1.openCircuitCount := by + have h1 := signedValueAt_eq (F := F) h st hbnd d₁.2.val d₁.2.prop + have h2 := signedValueAt_eq (F := F) h st hbnd d₂.2.val d₂.2.prop + rw [pathSign_isEmpty F d₁.1, one_mul] at h1 + rw [pathSign_isEmpty F d₂.1, one_mul] at h2 + rw [← h1, ← h2] + exact signedValueAt_of_labelChords_eq_pairing h st hbnd + (by rw [labelChords_of_allInternal (allInternal_isEmpty F) d₁.1, + labelChords_of_allInternal (allInternal_isEmpty F) d₂.1]) + +end Indep + +section Relabel + +variable {L : Type} + +/-- Every flag of a subset at an empty label type is internally +attached. -/ +theorem attach_inl_isEmpty [IsEmpty L] {V : Fragment L} + (F : EdgeSubset V) : + ∀ f ∈ F.flags, ∃ v : V.Vertex, V.attach f = Sum.inl v := by + intro f _ + rcases hv : V.attach f with v | i + · exact ⟨v, rfl⟩ + · exact isEmptyElim i + +open Classical in +/-- **The relabelled fragment's Definition 5 value is the summand +downstairs.** Both are RS21's `s_h(G,H)` for the same subset. -/ +theorem mixedValue_relabelUp_closed [LinearOrder L] {V : Fragment L} + (e : L ≃o Fin 0) + (F : EdgeSubset V) {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ L) + (hbnd : genBoundarySubsetMatches V F.flags st) + (hE : F.Eulerian) (d : F.CanonData) : + (F.relabelUp e.toEquiv).mixedValue h + = F.throughSummand h st hbnd d.2.val d.1.openCircuitCount := by + have hst : (fun a => st (e.symm (e.toEquiv a))) = st := + funext fun a => congrArg st (e.symm_apply_apply a) + have hst2 : (fun a => st (e.symm (e a))) = st := + funext fun a => congrArg st (e.symm_apply_apply a) + have hbnd' : genBoundarySubsetMatches (V.relabel e.toEquiv) + (F.relabelUp e.toEquiv).flags (fun b => st (e.symm b)) := by + refine (relabel_genBoundarySubsetMatches_iff e.toEquiv F.flags + (fun b => st (e.symm b))).mpr ?_ + rw [hst] + exact hbnd + have hE' : (F.relabelUp e.toEquiv).Eulerian := + (relabelUp_eulerian e.toEquiv F).mpr hE + have hcan := pathCanonical_relabelUp e F d.2.prop + have hne' : Nonempty (F.relabelUp e.toEquiv).CanonData := + ⟨⟨relabelTransUp e.toEquiv F d.1, + ⟨relabelOrientUp e.toEquiv F d.2.val, hcan⟩⟩⟩ + rw [← throughValueC_eq_mixedValue (F.relabelUp e.toEquiv) h + (fun b => st (e.symm b)) hbnd' hE' + (attach_inl_isEmpty (F.relabelUp e.toEquiv)), + throughValueC_isEmpty (F.relabelUp e.toEquiv) h _ hbnd' hne', + throughSummand_canon_indep (F.relabelUp e.toEquiv) h _ hbnd' + (Classical.choice hne') + ⟨relabelTransUp e.toEquiv F d.1, + ⟨relabelOrientUp e.toEquiv F d.2.val, hcan⟩⟩] + change (F.relabelUp e.toEquiv).throughSummand h _ hbnd' + (relabelOrientUp e.toEquiv F d.2.val) + (relabelTransUp e.toEquiv F d.1).openCircuitCount = _ + rw [relabel_openCircuitCount e.toEquiv F d.1] + refine Eq.trans (relabel_throughSummand e F h + (fun b => st (e.symm b)) hbnd' ?_ d.2.val + d.1.openCircuitCount) ?_ + · rw [hst2]; exact hbnd + · congr 1 + +/-- At an empty label type every subset matches every state. -/ +theorem genBoundarySubsetMatches_isEmpty [IsEmpty L] {V : Fragment L} + {k ℓ : ℕ} + (s : Finset V.Flag) (st : GenBoundaryState k ℓ L) : + genBoundarySubsetMatches V s st := + fun i => isEmptyElim i + +/-- At an empty label type every bijection to `Fin 0` is monotone. -/ +def emptyOrderIso [LinearOrder L] [IsEmpty L] + (ee : L ≃ Fin 0) : L ≃o Fin 0 where + toEquiv := ee + map_rel_iff' {a} := isEmptyElim a + +open Classical in +/-- **The relabelled fragment's Definition 5 partition value is the +constrained value downstairs**, at a monotone relabel. -/ +theorem mixedPartition_relabel_orderIso + [LinearOrder L] [IsEmpty L] {V : Fragment L} + (e : L ≃o Fin 0) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ L) : + mixedPartition h (V.relabel e.toEquiv) + = throughMixedPartitionC h V st := by + rw [throughMixedPartitionC_isEmpty h st] + unfold mixedPartition + refine congrArg (fun z => ((k : ℂ) - 2 * ℓ) ^ V.circles * z) + (Finset.sum_congr rfl (fun s _ => ?_)) + simp only [relabel_pairing_eq] + by_cases hc : ∀ f ∈ s, V.pairing f ∈ s + · have hbnd := genBoundarySubsetMatches_isEmpty (V := V) s st + refine Eq.trans (dite_eq_left hc) (Eq.trans ?_ (dite_eq_left hc).symm) + refine Eq.trans ?_ (dite_eq_left hbnd).symm + by_cases hE : (EdgeSubset.mk s hc : EdgeSubset V).Eulerian + · have hE' : (EdgeSubset.mk s hc : + EdgeSubset (V.relabel e.toEquiv)).Eulerian := + (relabelUp_eulerian e.toEquiv (EdgeSubset.mk s hc)).mpr hE + obtain ⟨⟨κ, o⟩⟩ := (EdgeSubset.mk s hc : + EdgeSubset V).exists_transition_orientation hE + (attach_inl_isEmpty (V := V) (EdgeSubset.mk s hc)) + have hcan := pathCanonical_of_allInternal + (allInternal_isEmpty (V := V) (EdgeSubset.mk s hc)) + o.toRel + have hne : Nonempty (EdgeSubset.mk s hc : + EdgeSubset V).CanonData := + ⟨⟨κ.toRelTransitionSystem, o.toRel, hcan⟩⟩ + refine Eq.trans (ite_eq_left hE') (Eq.trans ?_ (ite_eq_left hE).symm) + refine Eq.trans ?_ (dite_eq_left hne).symm + rw [throughSummand_canon_indep (V := V) (EdgeSubset.mk s hc) h + st hbnd + (Classical.choice hne) + ⟨κ.toRelTransitionSystem, o.toRel, hcan⟩] + exact mixedValue_relabelUp_closed e (V := V) + (EdgeSubset.mk s hc) h st hbnd hE + ⟨κ.toRelTransitionSystem, o.toRel, hcan⟩ + · have hE' : ¬ (EdgeSubset.mk s hc : + EdgeSubset (V.relabel e.toEquiv)).Eulerian := + fun hx => hE + ((relabelUp_eulerian e.toEquiv (EdgeSubset.mk s hc)).mp hx) + refine Eq.trans (ite_eq_right hE') ?_ + exact (ite_eq_right hE).symm + · refine Eq.trans (dite_eq_right hc) ?_ + symm + exact dite_eq_right hc + +open Classical in +/-- **The relabelled fragment's Definition 5 partition value is the +constrained value downstairs.** Monotonicity is automatic: there is +nothing to compare. -/ +theorem mixedPartition_relabel_closed + [LinearOrder L] [IsEmpty L] {V : Fragment L} + (ee : L ≃ Fin 0) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ L) : + mixedPartition h (V.relabel ee) + = throughMixedPartitionC h V st := by + rw [show ee = (emptyOrderIso ee).toEquiv from rfl] + exact mixedPartition_relabel_orderIso (emptyOrderIso ee) h st + +open Classical in +/-- The same identification, for a fragment presented as a relabel. +Naming the relabelled fragment keeps the elaborator from having to +solve for it under the relabel. -/ +theorem mixedPartition_relabel_closed_of_eq [LinearOrder L] [IsEmpty L] + (V₀ : Fragment L) + (ee : L ≃ Fin 0) {V' : ClosedFragment} + (hV : V' = V₀.relabel ee) {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ L) : + mixedPartition h V' = throughMixedPartitionC h V₀ st := by + subst hV + exact mixedPartition_relabel_closed ee h st + +end Relabel + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedTopSum.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedTopSum.lean new file mode 100644 index 0000000000..9da31b3f55 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedTopSum.lean @@ -0,0 +1,109 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourRecursion + +/-! +# The composition's own sum + +At the composition there are no labels left: the through-edge product +is one and the agreement is vacuous, so the flag model's summand is +RS21's colouring sum times the circuit sign. This file names that +sign as a weight on the composition's subsets and reads the +constrained partition value as the weighted sum the iteration +carries. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + +open Fragment +variable {L : Type} + +open Classical in +/-- **The circuit sign of a subset**, off the family. -/ +noncomputable def circuitWeight [LinearOrder L] {V : Fragment L} + (𝒟 : DataFamily V) + (s : Finset V.Flag) : ℂ := + if hc : ∀ f ∈ s, V.pairing f ∈ s then + if hE : (EdgeSubset.mk s hc).Eulerian then + if hne : Nonempty (EdgeSubset.mk s hc).CanonData then + ((-1 : ℂ) ^ (𝒟 s hc hE hne).1.openCircuitCount) + else 1 + else 1 + else 1 + +open Classical in +/-- At a good subset the circuit weight is the sign of the datum's +own circuit count. -/ +theorem circuitWeight_pos [LinearOrder L] {V : Fragment L} + (𝒟 : DataFamily V) {s : Finset V.Flag} + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) : + circuitWeight 𝒟 s + = ((-1 : ℂ) ^ (𝒟 s hc hE hne).1.openCircuitCount) := by + unfold circuitWeight + rw [dite_eq_left hc, dite_eq_left hE, dite_eq_left hne] + +section ClosedTop + +/-- At the composition the agreement is vacuous: there are no +labelled ends. -/ +theorem throughAgree_isEmpty {V : Fragment L} [IsEmpty L] + {k ℓ : ℕ} (F : EdgeSubset V) + (st : GenBoundaryState k ℓ L) + (hbnd : genBoundarySubsetMatches V F.flags st) : + ThroughAgree F st hbnd := by + classical + intro f hb _ + exact absurd (Finset.mem_filter.mp hb).2 (fun hx => + isEmptyElim hx.choose) + +/-- **At the composition the summand is the colouring sum, signed.** +-/ +theorem throughSummand_eq_edgeSum [LinearOrder L] {V : Fragment L} [IsEmpty L] + {k ℓ : ℕ} (F : EdgeSubset V) + (h : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ L) + (hbnd : genBoundarySubsetMatches V F.flags st) + {κ : F.RelTransitionSystem} (o : κ.Orientation) (C : ℕ) : + F.throughSummand h st hbnd o C + = ((-1 : ℂ) ^ C) * F.edgeSum h st hbnd o := by + rw [throughSummand_eq_vertexSum F h st hbnd o C, + throughProduct_isEmpty F st, mul_one, + ← edgeSum_eq_vertexSum F h st hbnd o + (throughAgree_isEmpty F st hbnd)] + +end ClosedTop + +/-! ## The composition's value, read on the base + +Putting the composition's own sum together with the iteration: the +constrained value of a composition is the base's summands, summed +over its subsets and over the interface colours, with the two +fragments' own free circles in front. The composition's extra +circles — one for each closing cut — are exactly the iteration's +factor. +-/ + +/-- The lexicographic order on the interface's label type. -/ +@[reducible] local instance baseOrder (n : ℕ) : + LinearOrder (Fin (0 + n) ⊕ Fin (n + 0)) := + sumLexLinearOrder _ _ + +/-- The order the composition's own (empty) label type carries. -/ +@[reducible] local instance topOrder : + LinearOrder (Fin 0 ⊕ Fin 0) := + sumLexLinearOrder _ _ + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourEmbedding.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourEmbedding.lean new file mode 100644 index 0000000000..85f3611391 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourEmbedding.lean @@ -0,0 +1,180 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition +public import LeanPool.RegtsSevenster.RS.Common.ListSign + +/-! +# Embeddings of mixed colours + +An embedding preserves the order of odd colours and their +symplectic partners and signs. Extending a functional by zero along +such an embedding preserves its alternating evaluations on the +embedded colours and annihilates inputs using any other colour. +-/ + +@[expose] public section + +namespace RS + +/-- Compatible embeddings of the even and odd colour sets. -/ +structure MixedColourEmbedding (k ℓ K L : ℕ) where + /-- The embedding of even colours. -/ + even : Fin k ↪ Fin K + /-- The increasing embedding of odd colours. -/ + odd : Fin (2 * ℓ) ↪o Fin (2 * L) + /-- Symplectic partners are preserved. -/ + partner_eq : ∀ c, odd (oddPartner ℓ c) = oddPartner L (odd c) + /-- The signs of symplectic partners are preserved. -/ + sign_eq : ∀ c, oddPartnerSign L (odd c) = oddPartnerSign ℓ c + +namespace MixedColourEmbedding + +/-- The embedding of the multiset and set data read by a mixed +functional. -/ +def dataEmbedding {k ℓ K L : ℕ} (e : MixedColourEmbedding k ℓ K L) : + (Multiset (Fin k) × Finset (Fin (2 * ℓ))) ↪ + (Multiset (Fin K) × Finset (Fin (2 * L))) where + toFun p := (p.1.map e.even, p.2.map e.odd.toEmbedding) + inj' := by + intro a b h + exact Prod.ext + (Multiset.map_injective e.even.injective (congrArg Prod.fst h)) + (Finset.map_injective e.odd.toEmbedding (congrArg Prod.snd h)) + +/-- Preserve first-half odd colours and shift their partners to the enlarged second half. -/ +def oddInclusion {ℓ L : ℕ} (h : ℓ ≤ L) + (c : Fin (2 * ℓ)) : Fin (2 * L) := + if hc : c.val < ℓ then ⟨c.val, by omega⟩ + else ⟨c.val - ℓ + L, by omega⟩ + +private theorem oddInclusion_strictMono {ℓ L : ℕ} (h : ℓ ≤ L) : + StrictMono (oddInclusion h) := by + intro a b hab + change (oddInclusion h a).val < (oddInclusion h b).val + simp only [oddInclusion] + split_ifs <;> dsimp only at * <;> + have := a.isLt <;> have := b.isLt <;> + have : a.val < b.val := hab <;> omega + +/-- Embed smaller colour spaces by retaining each first-half odd +colour and moving its partner into the enlarged second half. -/ +def ofLE {k ℓ K L : ℕ} (hk : k ≤ K) (hℓ : ℓ ≤ L) : + MixedColourEmbedding k ℓ K L where + even := Fin.castLEEmb hk + odd := OrderEmbedding.ofStrictMono (oddInclusion hℓ) + (by exact oddInclusion_strictMono hℓ) + partner_eq := by + intro c + change oddInclusion hℓ (oddPartner ℓ c) = + oddPartner L (oddInclusion hℓ c) + apply Fin.ext + have := c.isLt + by_cases hc : c.val < ℓ + · have hcL : c.val < L := by omega + have hnot : ¬ c.val + ℓ < ℓ := by omega + simp [oddInclusion, oddPartner, hc, hcL, hnot] + · have hsub : c.val - ℓ < ℓ := by omega + have hnot : ¬ c.val - ℓ + L < L := by omega + simp [oddInclusion, oddPartner, hc, hsub, hnot] + sign_eq := by + intro c + change oddPartnerSign L (oddInclusion hℓ c) = oddPartnerSign ℓ c + have := c.isLt + by_cases hc : c.val < ℓ + · have hcL : c.val < L := by omega + simp [oddInclusion, oddPartnerSign, hc, hcL] + · have hnot : ¬ c.val - ℓ + L < L := by omega + simp [oddInclusion, oddPartnerSign, hc, hnot] + +end MixedColourEmbedding + +namespace MixedFunctional + +/-- Extension by zero to the embedded colour data. -/ +noncomputable def extendColours {k ℓ K L : ℕ} + (h : MixedFunctional k ℓ) (e : MixedColourEmbedding k ℓ K L) : + MixedFunctional K L := fun μ F => + Function.extend e.dataEmbedding (fun p => h p.1 p.2) (fun _ => 0) (μ, F) + +/-- The extended functional agrees with the original on embedded +multisets and sets. -/ +theorem extendColours_map {k ℓ K L : ℕ} (h : MixedFunctional k ℓ) + (e : MixedColourEmbedding k ℓ K L) + (μ : Multiset (Fin k)) (F : Finset (Fin (2 * ℓ))) : + h.extendColours e (μ.map e.even) (F.map e.odd.toEmbedding) = h μ F := + e.dataEmbedding.injective.extend_apply _ _ (μ, F) + +/-- An even colour outside the embedding makes the extended +functional vanish. -/ +theorem extendColours_eq_zero_of_even {k ℓ K L : ℕ} + (h : MixedFunctional k ℓ) (e : MixedColourEmbedding k ℓ K L) + (μ : Multiset (Fin K)) (F : Finset (Fin (2 * L))) + (c : Fin K) (hc : c ∈ μ) (hout : c ∉ Set.range e.even) : + h.extendColours e μ F = 0 := by + classical + apply Function.extend_apply' + rintro ⟨p, hp⟩ + have hμ : p.1.map e.even = μ := congrArg Prod.fst hp + rw [← hμ] at hc + obtain ⟨a, _, ha⟩ := Multiset.mem_map.mp hc + exact hout ⟨a, ha⟩ + +/-- An odd colour outside the embedding makes the extended +functional vanish. -/ +theorem extendColours_eq_zero_of_odd {k ℓ K L : ℕ} + (h : MixedFunctional k ℓ) (e : MixedColourEmbedding k ℓ K L) + (μ : Multiset (Fin K)) (F : Finset (Fin (2 * L))) + (c : Fin (2 * L)) (hc : c ∈ F) (hout : c ∉ Set.range e.odd) : + h.extendColours e μ F = 0 := by + classical + apply Function.extend_apply' + rintro ⟨p, hp⟩ + have hF : p.2.map e.odd.toEmbedding = F := congrArg Prod.snd hp + rw [← hF] at hc + obtain ⟨a, _, ha⟩ := Finset.mem_map.mp hc + exact hout ⟨a, ha⟩ + +/-- Alternating evaluation commutes with the colour embedding. -/ +theorem evalOdd_extendColours_map {k ℓ K L : ℕ} + (h : MixedFunctional k ℓ) (e : MixedColourEmbedding k ℓ K L) + (μ : Multiset (Fin k)) (w : List (Fin (2 * ℓ))) : + (h.extendColours e).evalOdd (μ.map e.even) (w.map e.odd) = + h.evalOdd μ w := by + classical + have hset : (w.map e.odd).toFinset = w.toFinset.map e.odd.toEmbedding := by + ext c + simp + simp only [evalOdd, List.nodup_map_iff e.odd.injective, + sortSign_map_orderEmbedding, hset, extendColours_map] + +/-- Alternating evaluation vanishes if an even input colour is +outside the embedding. -/ +theorem evalOdd_extendColours_eq_zero_of_even {k ℓ K L : ℕ} + (h : MixedFunctional k ℓ) (e : MixedColourEmbedding k ℓ K L) + (μ : Multiset (Fin K)) (w : List (Fin (2 * L))) + (c : Fin K) (hc : c ∈ μ) (hout : c ∉ Set.range e.even) : + (h.extendColours e).evalOdd μ w = 0 := by + classical + simp only [evalOdd, extendColours_eq_zero_of_even h e μ _ c hc hout, + mul_zero, ite_self] + +/-- Alternating evaluation vanishes if an odd input colour is +outside the embedding. -/ +theorem evalOdd_extendColours_eq_zero_of_odd {k ℓ K L : ℕ} + (h : MixedFunctional k ℓ) (e : MixedColourEmbedding k ℓ K L) + (μ : Multiset (Fin K)) (w : List (Fin (2 * L))) + (c : Fin (2 * L)) (hc : c ∈ w) (hout : c ∉ Set.range e.odd) : + (h.extendColours e).evalOdd μ w = 0 := by + classical + simp only [evalOdd, extendColours_eq_zero_of_odd h e μ _ c + (List.mem_toFinset.mpr hc) hout, mul_zero, ite_self] + +end MixedFunctional + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourGlue.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourGlue.lean new file mode 100644 index 0000000000..9b58591b58 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourGlue.lean @@ -0,0 +1,1974 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughEdgeCut +public import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeSum + +/-! +# The colouring correspondence at one cut + +RS21 glues two open ends by *removing* the two labelled vertices and +joining the two edges into one, so a colouring of the glued graph is +a colouring of the two halves that agrees at the join — and the +colour at the join is exactly the interface state's colour there. +Summing the halves' colouring sums over that colour is therefore the +glued graph's own colouring sum. + +This file proves that, one cut at a time, for RS21's colouring sum +`edgeSum`. The two ends of the cut are either both outside the +subset, when the join carries an even colour, or both inside it, +when it carries an odd one; the sum over the state's colour at the +cut runs over the corresponding block. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + +open Fragment +section OpenCut + +variable {L : Type} {V : Fragment L} {i j : L} + (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + (hct : ∀ f ∈ t, (V.gluePairOpen i j hij hopen).pairing f ∈ t) + (hcL : ∀ f ∈ liftSubsetOpen hopen t, + V.pairing f ∈ liftSubsetOpen hopen t) + +/-! ## The cut the subset misses + +Neither glued flag is in the subset, so the join carries an even +colour and the subset's own flags are the glued fragment's, +unchanged. +-/ + +section Miss + +variable (hni : partnerSurvI hopen ∉ t) + +include hij hopen hni in +/-- The `i`-flag is out of the lift. -/ +theorem boundaryFlagI_notMem_lift_of_miss : + V.boundaryFlag i ∉ liftSubsetOpen hopen t := fun hmem => + hni ((boundaryFlagI_mem_liftOpen_iff hij hopen t).mp hmem) + +include hij hopen hct hni in +/-- The `j`-flag is out of the lift. -/ +theorem boundaryFlagJ_notMem_lift_of_miss : + V.boundaryFlag j ∉ liftSubsetOpen hopen t := fun hmem => + partnerSurvJ_notMem_of hij hopen t hct hni + ((boundaryFlagJ_mem_liftOpen_iff hij hopen t).mp hmem) + +include hij hopen hct hni in +/-- A flag of the lift survives the glue. -/ +theorem surviving_of_mem_lift_of_miss {f : V.Flag} + (hf : f ∈ liftSubsetOpen hopen t) : + f ≠ V.boundaryFlag i ∧ f ≠ V.boundaryFlag j := + ⟨fun hx => boundaryFlagI_notMem_lift_of_miss hij hopen t hni + (hx ▸ hf), + fun hx => boundaryFlagJ_notMem_lift_of_miss hij hopen t hct + hni (hx ▸ hf)⟩ + +/-- A flag of the lift, as a flag of the glued fragment. -/ +noncomputable def survOfLift {f : V.Flag} + (hf : f ∈ liftSubsetOpen hopen t) : SurvivingFlag V i j := + ⟨f, (surviving_of_mem_lift_of_miss hij hopen t hct hni hf).1, + (surviving_of_mem_lift_of_miss hij hopen t hct hni hf).2⟩ + +/-- A flag of the lift, read as a glued flag, lies in the glued +subset. -/ +theorem survOfLift_mem {f : V.Flag} + (hf : f ∈ liftSubsetOpen hopen t) : + survOfLift hij hopen t hct hni hf ∈ t := + (surviving_val_mem_liftOpen_iff hopen t _).mp hf + +/-- Conversely a glued subset flag's underlying flag lies in the +lift. -/ +theorem mem_lift_of_mem {g : SurvivingFlag V i j} (hg : g ∈ t) : + g.val ∈ liftSubsetOpen hopen t := + (surviving_val_mem_liftOpen_iff hopen t g).mpr hg + +/-- **Odd colourings agree across a missed cut.** The cut's own +edge is outside the subset, so the two sides colour the same +edges. -/ +noncomputable def oddColourEquivMiss (ℓ : ℕ) : + (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).EdgeOddColouring ℓ + ≃ (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).EdgeOddColouring + ℓ where + toFun φ := + ⟨fun g => φ.val ⟨g.val.val, mem_lift_of_mem hopen t g.prop⟩, + fun g => + Eq.trans + (congrArg φ.val (Subtype.ext + (gluePairOpen_pairing_val_of_notMem_interface hij hopen t + hct hni g.prop))) + (φ.prop ⟨g.val.val, mem_lift_of_mem hopen t g.prop⟩)⟩ + invFun φ' := + ⟨fun f => φ'.val ⟨survOfLift hij hopen t hct hni f.prop, + survOfLift_mem hij hopen t hct hni f.prop⟩, + fun f => by + have hpv := gluePairOpen_pairing_val_of_notMem_interface hij + hopen t hct hni + (survOfLift_mem hij hopen t hct hni f.prop) + refine Eq.trans ?_ (φ'.prop + ⟨survOfLift hij hopen t hct hni f.prop, + survOfLift_mem hij hopen t hct hni f.prop⟩) + exact congrArg φ'.val (Subtype.ext (Subtype.ext hpv.symm))⟩ + left_inv _ := rfl + right_inv _ := rfl + +include hij hopen hct hcL hni in +/-- **The odd boundary constraint matches across a missed cut.** -/ +theorem edgeOddBoundaryMatch_miss {k ℓ : ℕ} + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) (a : Fin k) + (φ : (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).EdgeOddColouring ℓ) : + edgeOddBoundaryMatch + (EdgeSubset.mk (liftSubsetOpen hopen t) hcL) + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a)) φ + ↔ edgeOddBoundaryMatch (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)) st' + (oddColourEquivMiss hij hopen t hct hcL hni ℓ φ) := by + constructor + · intro hW b' c hst hmem + have hml : V.boundaryFlag b'.val ∈ liftSubsetOpen hopen t := + mem_lift_of_mem hopen t hmem + have hstW : GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a) b'.val = Sum.inr c := by + rw [GenBoundaryState.extendPair_surviving] + exact hst + exact Eq.trans (congrArg φ.val (Subtype.ext rfl)) + (hW b'.val c hstW hml) + · intro hG b c hst hmem + have hbi : b ≠ i := by + intro hx + rw [hx, GenBoundaryState.extendPair_left] at hst + exact absurd hst (by simp) + have hbj : b ≠ j := by + intro hx + rw [hx, GenBoundaryState.extendPair_right hij] at hst + exact absurd hst (by simp) + have hst' : st' ⟨b, hbi, hbj⟩ = Sum.inr c := by + rw [← GenBoundaryState.extendPair_surviving st' (Sum.inl a) + (Sum.inl a) ⟨b, hbi, hbj⟩] + exact hst + have hmg : glueBoundaryFlag V i j ⟨b, hbi, hbj⟩ ∈ t := + (surviving_val_mem_liftOpen_iff hopen t _).mp hmem + exact Eq.trans (congrArg φ.val (Subtype.ext rfl)) + (hG ⟨b, hbi, hbj⟩ c hst' hmg) + +section MissSum + +variable (κ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).RelTransitionSystem) + (o' : κ'.Orientation) + +local notation "Fg" => + (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)) + +local notation "Fl" => + (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : EdgeSubset V) + +local notation "oW" => + unglueOrientationOpen hij hopen t hct hcL κ' o' + +include hij hopen hct hcL hni in +open Classical in +/-- **The odd colouring sum transports across a missed cut.** -/ +theorem sum_odd_miss + [LinearOrder L] + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) (a : Fin k) + (ψ' : (Fg).EvenColouring k) : + (∑ φ : (Fl).EdgeOddColouring ℓ, + if edgeOddBoundaryMatch (Fl) + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a)) φ then + ∏ v : V.Vertex, + (((Fl).coreOddSignAt (oW) φ.core v : ℂ) * + h.evalOdd ((Fl).evenColoursAt + (evenPushOpen hij hopen t hct hcL hni ψ') v) + ((Fl).coreOddListAt (oW) φ.core v)) + else 0) + = ∑ φ' : (Fg).EdgeOddColouring ℓ, + if edgeOddBoundaryMatch (Fg) st' φ' then + ∏ v : V.Vertex, + (((Fg).coreOddSignAt o' φ'.core v : ℂ) * + h.evalOdd ((Fg).evenColoursAt ψ' v) + ((Fg).coreOddListAt o' φ'.core v)) + else 0 := by + refine Fintype.sum_equiv + (oddColourEquivMiss hij hopen t hct hcL hni ℓ) _ _ (fun φ => ?_) + by_cases hm : edgeOddBoundaryMatch (Fl) + (GenBoundaryState.extendPair i j st' (Sum.inl a) (Sum.inl a)) + φ + · rw [ite_eq_left hm, ite_eq_left ((edgeOddBoundaryMatch_miss hij hopen t + hct hcL hni st' a φ).mp hm)] + refine Finset.prod_congr rfl (fun v _ => ?_) + exact vertexFactor_transport_T hij hopen t hct hcL κ' o' h + (evenPushOpen hij hopen t hct hcL hni ψ') ψ' + (evenPushOpen_agrees hij hopen t hct hcL hni ψ') + φ.core (oddColourEquivMiss hij hopen t hct hcL hni ℓ φ).core + (fun g h1 h2 => congrArg φ.val (Subtype.ext rfl)) v + · rw [ite_eq_right hm, ite_eq_right (fun hx => hm + ((edgeOddBoundaryMatch_miss hij hopen t hct hcL hni st' a + φ).mpr hx))] + +include hij hopen hct hcL hni in +open Classical in +/-- **One missed cut, on RS21's colouring sums.** The join carries +an even colour, and that colour is the glued colouring's own at the +far end of the cut — so the sum over it has a single term. -/ +theorem edgeSum_openCut_miss + [LinearOrder L] + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (hbnd' : genBoundarySubsetMatches + (V.gluePairOpen i j hij hopen) t st') + (hbndW : ∀ a : Fin k, genBoundarySubsetMatches V + (liftSubsetOpen hopen t) + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a))) : + (∑ a : Fin k, (Fl).edgeSum h + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a)) (hbndW a) (oW)) + = (Fg).edgeSum h st' hbnd' o' := by + have hL : ∀ a : Fin k, + (Fl).edgeSum h (GenBoundaryState.extendPair i j st' + (Sum.inl a) (Sum.inl a)) (hbndW a) (oW) + = ∑ ψ' : (Fg).EvenColouring k, + if (ψ'.val ⟨partnerSurvI hopen, hni⟩ = a ∧ + genEvenBoundaryMatch (Fg) st' hbnd' ψ') then + (∑ φ' : (Fg).EdgeOddColouring ℓ, + if edgeOddBoundaryMatch (Fg) st' φ' then + ∏ v : V.Vertex, + (((Fg).coreOddSignAt o' φ'.core v : ℂ) * + h.evalOdd ((Fg).evenColoursAt ψ' v) + ((Fg).coreOddListAt o' φ'.core v)) + else 0) + else 0 := by + intro a + unfold edgeSum + rw [sum_even_open hij hopen t hct hcL hni st' a (hbndW a) + (fun ψW => ∑ φ : (Fl).EdgeOddColouring ℓ, + if edgeOddBoundaryMatch (Fl) + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a)) φ then + ∏ v : V.Vertex, + (((Fl).coreOddSignAt (oW) φ.core v : ℂ) * + h.evalOdd ((Fl).evenColoursAt ψW v) + ((Fl).coreOddListAt (oW) φ.core v)) + else 0)] + refine Finset.sum_congr rfl (fun ψ' _ => ?_) + by_cases hg : genEvenBoundaryMatch (Fl) + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a)) (hbndW a) + (evenPushOpen hij hopen t hct hcL hni ψ') + · rw [ite_eq_left hg, ite_eq_left ((genEvenBoundaryMatch_open_iff hij + hopen t hct hcL hni st' a (hbndW a) hbnd' ψ').mp hg)] + exact sum_odd_miss hij hopen t hct hcL hni κ' o' h st' a ψ' + · rw [ite_eq_right hg, ite_eq_right (fun hx => hg + ((genEvenBoundaryMatch_open_iff hij hopen t hct hcL hni st' + a (hbndW a) hbnd' ψ').mpr hx))] + rw [Finset.sum_congr rfl (fun a (_ : a ∈ Finset.univ) => hL a), + Finset.sum_comm] + unfold edgeSum + refine Finset.sum_congr rfl (fun ψ' _ => ?_) + by_cases hg : genEvenBoundaryMatch (Fg) st' hbnd' ψ' + · rw [ite_eq_left hg, Finset.sum_eq_single + (ψ'.val ⟨partnerSurvI hopen, hni⟩) + (fun a _ hne => ite_eq_right (fun hx => hne hx.1.symm)) + (fun hx => absurd (Finset.mem_univ _) hx), ite_eq_left ⟨rfl, hg⟩] + rfl + · rw [ite_eq_right hg] + exact Finset.sum_eq_zero (fun a _ => ite_eq_right (fun hx => hg hx.2)) + +end MissSum + +end Miss + +/-! ## The cut the subset carries + +Both glued flags are in the subset, so the join carries an odd +colour; the even colourings are the same on both sides and the sum +over the join's colour is absorbed by the odd ones. +-/ + +section Hit + +variable (hpi : partnerSurvI hopen ∈ t) + +include hij hopen hpi in +/-- The `i`-flag is in the lift. -/ +theorem boundaryFlagI_mem_lift_of_hit : + V.boundaryFlag i ∈ liftSubsetOpen hopen t := + (boundaryFlagI_mem_liftOpen_iff hij hopen t).mpr hpi + +include hij hopen hct hpi in +/-- The far end of the `j`-edge is in the subset too. -/ +theorem partnerSurvJ_mem_of_hit : partnerSurvJ hopen ∈ t := by + have hp := hct _ hpi + rwa [gluePairOpen_pairing_interface_i hij hopen + (partnerSurvI hopen) + (by rw [partnerSurvI_val hopen, V.pairing_invol])] at hp + +include hij hopen hct hpi in +/-- The `j`-flag is in the lift. -/ +theorem boundaryFlagJ_mem_lift_of_hit : + V.boundaryFlag j ∈ liftSubsetOpen hopen t := + (boundaryFlagJ_mem_liftOpen_iff hij hopen t).mpr + (partnerSurvJ_mem_of_hit hij hopen t hct hpi) + +include hij hopen hct hpi in +/-- A flag outside the lift survives the glue. -/ +theorem surviving_of_notMem_lift_of_hit {f : V.Flag} + (hf : f ∉ liftSubsetOpen hopen t) : + f ≠ V.boundaryFlag i ∧ f ≠ V.boundaryFlag j := + ⟨fun hx => hf (hx ▸ boundaryFlagI_mem_lift_of_hit hij hopen t hpi), + fun hx => hf (hx ▸ boundaryFlagJ_mem_lift_of_hit hij hopen t hct + hpi)⟩ + +/-- A flag outside the lift, as a flag of the glued fragment. -/ +noncomputable def survOfNotLift {f : V.Flag} + (hf : f ∉ liftSubsetOpen hopen t) : SurvivingFlag V i j := + ⟨f, (surviving_of_notMem_lift_of_hit hij hopen t hct hpi hf).1, + (surviving_of_notMem_lift_of_hit hij hopen t hct hpi hf).2⟩ + +/-- A flag outside the lift, read as a glued flag, lies outside the +glued subset. -/ +theorem survOfNotLift_notMem {f : V.Flag} + (hf : f ∉ liftSubsetOpen hopen t) : + survOfNotLift hij hopen t hct hpi hf ∉ t := fun hm => + hf ((surviving_val_mem_liftOpen_iff hopen t _).mpr hm) + +/-- Conversely a flag outside the glued subset has its underlying +flag outside the lift. -/ +theorem notMem_lift_of_notMem {g : SurvivingFlag V i j} + (hg : g ∉ t) : g.val ∉ liftSubsetOpen hopen t := fun hm => + hg ((surviving_val_mem_liftOpen_iff hopen t g).mp hm) + +include hij hopen hct hpi in +/-- Away from the interface the glued pairing is the base's. -/ +theorem pairing_val_hit {g : SurvivingFlag V i j} (hg : g ∉ t) : + ((V.gluePairOpen i j hij hopen).pairing g).val + = V.pairing g.val := by + refine gluePairOpen_pairing_val_of_ne hij hopen g ?_ ?_ + · intro hh + exact hg (eq_partnerSurvI_of_pairing hopen g hh ▸ hpi) + · intro hh + exact hg (eq_partnerSurvJ_of_pairing hopen g hh ▸ + partnerSurvJ_mem_of_hit hij hopen t hct hpi) + +/-- **Even colourings agree across a carried cut.** The cut's own +edge is in the subset, so the two sides colour the same +complement. -/ +noncomputable def evenColourEquivHit (k : ℕ) : + (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).EvenColouring k + ≃ (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).EvenColouring + k where + toFun ψ := + ⟨fun g => ψ.val ⟨g.val.val, + notMem_lift_of_notMem hopen t g.prop⟩, + fun g => + Eq.trans + (congrArg ψ.val (Subtype.ext + (pairing_val_hit hij hopen t hct hpi g.prop))) + (ψ.prop ⟨g.val.val, + notMem_lift_of_notMem hopen t g.prop⟩)⟩ + invFun ψ' := + ⟨fun f => ψ'.val ⟨survOfNotLift hij hopen t hct hpi f.prop, + survOfNotLift_notMem hij hopen t hct hpi f.prop⟩, + fun f => by + have hpv := pairing_val_hit hij hopen t hct hpi + (survOfNotLift_notMem hij hopen t hct hpi f.prop) + refine Eq.trans ?_ (ψ'.prop + ⟨survOfNotLift hij hopen t hct hpi f.prop, + survOfNotLift_notMem hij hopen t hct hpi f.prop⟩) + exact congrArg ψ'.val (Subtype.ext (Subtype.ext hpv.symm))⟩ + left_inv _ := rfl + right_inv _ := rfl + +include hij hopen hct hpi in +/-- **The glued colouring is constant across the join.** -/ +theorem glued_odd_merged {ℓ : ℕ} + (φ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).EdgeOddColouring + ℓ) : + φ'.val ⟨partnerSurvJ hopen, + partnerSurvJ_mem_of_hit hij hopen t hct hpi⟩ + = φ'.val ⟨partnerSurvI hopen, hpi⟩ := by + refine Eq.trans ?_ (φ'.prop ⟨partnerSurvI hopen, hpi⟩) + refine congrArg φ'.val (Subtype.ext ?_) + exact (gluePairOpen_pairing_interface_i hij hopen + (partnerSurvI hopen) + (by rw [partnerSurvI_val hopen, V.pairing_invol])).symm + +/-- The pushed colouring's value at a flag of the lift. -/ +noncomputable def oddPushHitFun {ℓ : ℕ} + (φ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).EdgeOddColouring ℓ) + (f : {g : V.Flag // g ∈ liftSubsetOpen hopen t}) : + Fin (2 * ℓ) := + if hfi : f.val = V.boundaryFlag i then + φ'.val ⟨partnerSurvI hopen, hpi⟩ + else if hfj : f.val = V.boundaryFlag j then + φ'.val ⟨partnerSurvI hopen, hpi⟩ + else φ'.val ⟨⟨f.val, hfi, hfj⟩, + (surviving_val_mem_liftOpen_iff hopen t + ⟨f.val, hfi, hfj⟩).mp f.prop⟩ + +/-- At the first glued boundary flag the pushed colouring takes the +join's colour. -/ +theorem oddPushHitFun_at_i {ℓ : ℕ} + (φ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).EdgeOddColouring ℓ) + (hP : V.boundaryFlag i ∈ liftSubsetOpen hopen t) : + oddPushHitFun hij hopen t hct hpi φ' ⟨V.boundaryFlag i, hP⟩ + = φ'.val ⟨partnerSurvI hopen, hpi⟩ := dite_eq_left rfl + +include hij in +/-- At the second it takes the same colour: the two ends of the +join are one edge after gluing. -/ +theorem oddPushHitFun_at_j {ℓ : ℕ} + (φ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).EdgeOddColouring ℓ) + (hP : V.boundaryFlag j ∈ liftSubsetOpen hopen t) : + oddPushHitFun hij hopen t hct hpi φ' ⟨V.boundaryFlag j, hP⟩ + = φ'.val ⟨partnerSurvI hopen, hpi⟩ := by + unfold oddPushHitFun + rw [dite_eq_right (fun hEq => hij (V.boundaryFlag_injective hEq).symm), + dite_eq_left rfl] + +/-- Away from the two glued flags the pushed colouring is the +colouring it was pushed from. -/ +theorem oddPushHitFun_agrees {ℓ : ℕ} + (φ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).EdgeOddColouring ℓ) + (g : SurvivingFlag V i j) + (h1 : g.val ∈ liftSubsetOpen hopen t) (h2 : g ∈ t) : + oddPushHitFun hij hopen t hct hpi φ' ⟨g.val, h1⟩ + = φ'.val ⟨g, h2⟩ := by + unfold oddPushHitFun + rw [dite_eq_right g.prop.1, dite_eq_right g.prop.2] + +/-- **Push a glued odd colouring up to the lift**, colouring the two +glued flags with the join's own colour. -/ +noncomputable def oddPushHit {ℓ : ℕ} + (φ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).EdgeOddColouring ℓ) : + (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).EdgeOddColouring ℓ := + ⟨oddPushHitFun hij hopen t hct hpi φ', by + intro f + by_cases hfi : f.val = V.boundaryFlag i + · have hpv : V.pairing f.val = (partnerSurvI hopen).val := by + rw [hfi]; rfl + rw [show (⟨V.pairing f.val, _⟩ : + {g : V.Flag // g ∈ liftSubsetOpen hopen t}) + = ⟨(partnerSurvI hopen).val, + mem_lift_of_mem hopen t hpi⟩ from Subtype.ext hpv, + oddPushHitFun_agrees hij hopen t hct hpi φ' + (partnerSurvI hopen) _ hpi] + change _ = oddPushHitFun hij hopen t hct hpi φ' ⟨f.val, f.prop⟩ + rw [show (⟨f.val, f.prop⟩ : + {g : V.Flag // g ∈ liftSubsetOpen hopen t}) + = ⟨V.boundaryFlag i, + boundaryFlagI_mem_lift_of_hit hij hopen t hpi⟩ + from Subtype.ext hfi, + oddPushHitFun_at_i hij hopen t hct hpi φ'] + · by_cases hfj : f.val = V.boundaryFlag j + · have hpv : V.pairing f.val + = (partnerSurvJ hopen).val := by + rw [hfj]; rfl + rw [show (⟨V.pairing f.val, _⟩ : + {g : V.Flag // g ∈ liftSubsetOpen hopen t}) + = ⟨(partnerSurvJ hopen).val, + mem_lift_of_mem hopen t + (partnerSurvJ_mem_of_hit hij hopen t hct hpi)⟩ + from Subtype.ext hpv, + oddPushHitFun_agrees hij hopen t hct hpi φ' + (partnerSurvJ hopen) _ + (partnerSurvJ_mem_of_hit hij hopen t hct hpi), + glued_odd_merged hij hopen t hct hpi φ'] + change _ = oddPushHitFun hij hopen t hct hpi φ' ⟨f.val, f.prop⟩ + rw [show (⟨f.val, f.prop⟩ : + {g : V.Flag // g ∈ liftSubsetOpen hopen t}) + = ⟨V.boundaryFlag j, + boundaryFlagJ_mem_lift_of_hit hij hopen t hct hpi⟩ + from Subtype.ext hfj, + oddPushHitFun_at_j hij hopen t hct hpi φ'] + · have hgt : (⟨f.val, hfi, hfj⟩ : SurvivingFlag V i j) ∈ t := + (surviving_val_mem_liftOpen_iff hopen t _).mp f.prop + have hrhs : oddPushHitFun hij hopen t hct hpi φ' f + = φ'.val ⟨⟨f.val, hfi, hfj⟩, hgt⟩ := + oddPushHitFun_agrees hij hopen t hct hpi φ' + ⟨f.val, hfi, hfj⟩ f.prop hgt + rw [hrhs] + by_cases hpi' : V.pairing f.val = V.boundaryFlag i + · rw [show (⟨V.pairing f.val, _⟩ : + {g : V.Flag // g ∈ liftSubsetOpen hopen t}) + = ⟨V.boundaryFlag i, + boundaryFlagI_mem_lift_of_hit hij hopen t hpi⟩ + from Subtype.ext hpi', + oddPushHitFun_at_i hij hopen t hct hpi φ'] + exact congrArg φ'.val (Subtype.ext + (eq_partnerSurvI_of_pairing hopen _ hpi').symm) + · by_cases hpj' : V.pairing f.val = V.boundaryFlag j + · rw [show (⟨V.pairing f.val, _⟩ : + {g : V.Flag // g ∈ liftSubsetOpen hopen t}) + = ⟨V.boundaryFlag j, + boundaryFlagJ_mem_lift_of_hit hij hopen t hct hpi⟩ + from Subtype.ext hpj', + oddPushHitFun_at_j hij hopen t hct hpi φ', + ← glued_odd_merged hij hopen t hct hpi φ'] + exact congrArg φ'.val (Subtype.ext + (eq_partnerSurvJ_of_pairing hopen _ hpj').symm) + · have hgt' : (⟨V.pairing f.val, hpi', hpj'⟩ : + SurvivingFlag V i j) ∈ t := + (surviving_val_mem_liftOpen_iff hopen t _).mp + (hcL _ f.prop) + rw [show (⟨V.pairing f.val, _⟩ : + {g : V.Flag // g ∈ liftSubsetOpen hopen t}) + = ⟨(⟨V.pairing f.val, hpi', hpj'⟩ : + SurvivingFlag V i j).val, + mem_lift_of_mem hopen t hgt'⟩ from rfl, + oddPushHitFun_agrees hij hopen t hct hpi φ' _ _ hgt'] + refine Eq.trans ?_ (φ'.prop ⟨⟨f.val, hfi, hfj⟩, hgt⟩) + refine congrArg φ'.val (Subtype.ext (Subtype.ext ?_)) + exact (gluePairOpen_pairing_val_of_ne hij hopen + ⟨f.val, hfi, hfj⟩ hpi' hpj').symm⟩ + +include hij hopen hct hcL hpi in +/-- **The odd boundary constraint across a carried cut.** It pins +the join's colour to the state's, and is the glued constraint +otherwise. -/ +theorem edgeOddBoundaryMatch_hit_iff {k ℓ : ℕ} + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (d : Fin (2 * ℓ)) + (φ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).EdgeOddColouring + ℓ) : + edgeOddBoundaryMatch + (EdgeSubset.mk (liftSubsetOpen hopen t) hcL) + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d)) + (oddPushHit hij hopen t hct hcL hpi φ') + ↔ (φ'.val ⟨partnerSurvI hopen, hpi⟩ = d ∧ + edgeOddBoundaryMatch (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)) st' φ') := by + constructor + · intro hW + refine ⟨?_, ?_⟩ + · exact (oddPushHitFun_at_i hij hopen t hct hpi φ' + (boundaryFlagI_mem_lift_of_hit hij hopen t hpi)).symm.trans + (hW i d (GenBoundaryState.extendPair_left st' _ _) + (boundaryFlagI_mem_lift_of_hit hij hopen t hpi)) + · intro b' c hst hmem + have hstW : GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d) b'.val = Sum.inr c := by + rw [GenBoundaryState.extendPair_surviving] + exact hst + exact (oddPushHitFun_agrees hij hopen t hct hpi φ' + (glueBoundaryFlag V i j b') _ hmem).symm.trans + (hW b'.val c hstW (mem_lift_of_mem hopen t hmem)) + · rintro ⟨hx, hG⟩ b c hst hmem + by_cases hbi : b = i + · subst hbi + rw [GenBoundaryState.extendPair_left] at hst + exact (oddPushHitFun_at_i hij hopen t hct hpi φ' hmem).trans + (hx.trans (Sum.inr.inj hst)) + · by_cases hbj : b = j + · subst hbj + rw [GenBoundaryState.extendPair_right hij] at hst + exact (oddPushHitFun_at_j hij hopen t hct hpi φ' hmem).trans + (hx.trans (Sum.inr.inj hst)) + · have hst' : st' ⟨b, hbi, hbj⟩ = Sum.inr c := by + rw [← GenBoundaryState.extendPair_surviving st' + (Sum.inr d) (Sum.inr d) ⟨b, hbi, hbj⟩] + exact hst + have hmg : glueBoundaryFlag V i j ⟨b, hbi, hbj⟩ ∈ t := + (surviving_val_mem_liftOpen_iff hopen t _).mp hmem + exact (oddPushHitFun_agrees hij hopen t hct hpi φ' + (glueBoundaryFlag V i j ⟨b, hbi, hbj⟩) hmem hmg).trans + (hG ⟨b, hbi, hbj⟩ c hst' hmg) + +include hij hopen hct hcL hpi in +/-- The push is injective. -/ +theorem oddPushHit_injective {ℓ : ℕ} : + Function.Injective + (oddPushHit hij hopen t hct hcL hpi (ℓ := ℓ)) := by + intro φ₁ φ₂ hEq + refine Subtype.ext (funext fun x => ?_) + have hv := congrArg (fun φ : + (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).EdgeOddColouring ℓ => + φ.val ⟨x.val.val, mem_lift_of_mem hopen t x.prop⟩) hEq + simp only [] at hv + have h1 : (oddPushHit hij hopen t hct hcL hpi φ₁).val + ⟨x.val.val, mem_lift_of_mem hopen t x.prop⟩ + = φ₁.val ⟨x.val, x.prop⟩ := + oddPushHitFun_agrees hij hopen t hct hpi φ₁ x.val _ x.prop + have h2 : (oddPushHit hij hopen t hct hcL hpi φ₂).val + ⟨x.val.val, mem_lift_of_mem hopen t x.prop⟩ + = φ₂.val ⟨x.val, x.prop⟩ := + oddPushHitFun_agrees hij hopen t hct hpi φ₂ x.val _ x.prop + rw [h1, h2] at hv + exact hv + +include hij hopen hct hcL hpi in +/-- **Every colouring meeting the join's constraint is a push.** -/ +theorem oddPushHit_covers {k ℓ : ℕ} + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (d : Fin (2 * ℓ)) + (φW : (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).EdgeOddColouring ℓ) + (hmatch : edgeOddBoundaryMatch + (EdgeSubset.mk (liftSubsetOpen hopen t) hcL) + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d)) φW) : + ∃ φ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).EdgeOddColouring + ℓ, + oddPushHit hij hopen t hct hcL hpi φ' = φW := by + have hbi := boundaryFlagI_mem_lift_of_hit hij hopen t hpi + have hbj := boundaryFlagJ_mem_lift_of_hit hij hopen t hct hpi + have hvi : φW.val ⟨V.boundaryFlag i, hbi⟩ = d := + hmatch i d (GenBoundaryState.extendPair_left st' _ _) hbi + have hvj : φW.val ⟨V.boundaryFlag j, hbj⟩ = d := + hmatch j d (GenBoundaryState.extendPair_right hij st' _ _) hbj + have hvI : φW.val ⟨(partnerSurvI hopen).val, + mem_lift_of_mem hopen t hpi⟩ = d := by + refine Eq.trans ?_ hvi + exact Eq.trans (congrArg φW.val (Subtype.ext rfl)) + (φW.prop ⟨V.boundaryFlag i, hbi⟩) + have hvJ : φW.val ⟨(partnerSurvJ hopen).val, + mem_lift_of_mem hopen t + (partnerSurvJ_mem_of_hit hij hopen t hct hpi)⟩ = d := by + refine Eq.trans ?_ hvj + exact Eq.trans (congrArg φW.val (Subtype.ext rfl)) + (φW.prop ⟨V.boundaryFlag j, hbj⟩) + -- ═══════ THE GLUED COLOURING, AND THAT IT IS ONE ═══════ + -- Above: the interface colour is `d` at all four of the cut's + -- flags. Below: restricting `φW` to the survivors is a colouring + -- of the glued subset, and it pushes to `φW`. + refine ⟨⟨fun g => φW.val ⟨g.val.val, + mem_lift_of_mem hopen t g.prop⟩, ?_⟩, ?_⟩ + · intro g + dsimp only [] + by_cases hpi' : V.pairing g.val.val = V.boundaryFlag i + · have hg : g.val = partnerSurvI hopen := + eq_partnerSurvI_of_pairing hopen g.val hpi' + have hgl : (V.gluePairOpen i j hij hopen).pairing g.val + = partnerSurvJ hopen := + gluePairOpen_pairing_interface_i hij hopen g.val hpi' + have hx : ((V.gluePairOpen i j hij hopen).pairing g.val).val + = (partnerSurvJ hopen).val := congrArg Subtype.val hgl + have hy : g.val.val = (partnerSurvI hopen).val := + congrArg Subtype.val hg + have hmA : ((V.gluePairOpen i j hij hopen).pairing g.val).val + ∈ liftSubsetOpen hopen t := + mem_lift_of_mem hopen t (hct _ g.prop) + have hmB : (partnerSurvJ hopen).val + ∈ liftSubsetOpen hopen t := + mem_lift_of_mem hopen t + (partnerSurvJ_mem_of_hit hij hopen t hct hpi) + have hmC : g.val.val ∈ liftSubsetOpen hopen t := + mem_lift_of_mem hopen t g.prop + have hmD : (partnerSurvI hopen).val + ∈ liftSubsetOpen hopen t := + mem_lift_of_mem hopen t hpi + have h1 : (⟨_, hmA⟩ : + {f : V.Flag // f ∈ liftSubsetOpen hopen t}) + = ⟨_, hmB⟩ := Subtype.ext hx + have h2 : (⟨_, hmC⟩ : + {f : V.Flag // f ∈ liftSubsetOpen hopen t}) + = ⟨_, hmD⟩ := Subtype.ext hy + rw [h1, h2, hvJ, hvI] + · by_cases hpj' : V.pairing g.val.val = V.boundaryFlag j + · have hg : g.val = partnerSurvJ hopen := + eq_partnerSurvJ_of_pairing hopen g.val hpj' + have hgl : (V.gluePairOpen i j hij hopen).pairing g.val + = partnerSurvI hopen := + gluePairOpen_pairing_interface_j hij hopen g.val hpi' hpj' + have hx : ((V.gluePairOpen i j hij hopen).pairing g.val).val + = (partnerSurvI hopen).val := congrArg Subtype.val hgl + have hy : g.val.val = (partnerSurvJ hopen).val := + congrArg Subtype.val hg + have hmA : ((V.gluePairOpen i j hij hopen).pairing + g.val).val ∈ liftSubsetOpen hopen t := + mem_lift_of_mem hopen t (hct _ g.prop) + have hmB : (partnerSurvI hopen).val + ∈ liftSubsetOpen hopen t := + mem_lift_of_mem hopen t hpi + have hmC : g.val.val ∈ liftSubsetOpen hopen t := + mem_lift_of_mem hopen t g.prop + have hmD : (partnerSurvJ hopen).val + ∈ liftSubsetOpen hopen t := + mem_lift_of_mem hopen t + (partnerSurvJ_mem_of_hit hij hopen t hct hpi) + have h1 : (⟨_, hmA⟩ : + {f : V.Flag // f ∈ liftSubsetOpen hopen t}) + = ⟨_, hmB⟩ := Subtype.ext hx + have h2 : (⟨_, hmC⟩ : + {f : V.Flag // f ∈ liftSubsetOpen hopen t}) + = ⟨_, hmD⟩ := Subtype.ext hy + rw [h1, h2, hvI, hvJ] + · have hx : ((V.gluePairOpen i j hij hopen).pairing g.val).val + = V.pairing g.val.val := + gluePairOpen_pairing_val_of_ne hij hopen g.val hpi' hpj' + have hmA : ((V.gluePairOpen i j hij hopen).pairing + g.val).val ∈ liftSubsetOpen hopen t := + mem_lift_of_mem hopen t (hct _ g.prop) + have hmC : g.val.val ∈ liftSubsetOpen hopen t := + mem_lift_of_mem hopen t g.prop + have hmB : V.pairing g.val.val + ∈ liftSubsetOpen hopen t := hcL _ hmC + have h1 : (⟨_, hmA⟩ : + {f : V.Flag // f ∈ liftSubsetOpen hopen t}) + = ⟨_, hmB⟩ := Subtype.ext hx + rw [h1] + exact φW.prop ⟨g.val.val, hmC⟩ + · refine Subtype.ext (funext fun f => ?_) + change oddPushHitFun hij hopen t hct hpi _ f = φW.val f + by_cases hfi : f.val = V.boundaryFlag i + · have hfe : f = ⟨V.boundaryFlag i, hbi⟩ := Subtype.ext hfi + rw [hfe] + exact (oddPushHitFun_at_i hij hopen t hct hpi _ hbi).trans + (hvI.trans hvi.symm) + · by_cases hfj : f.val = V.boundaryFlag j + · have hfe : f = ⟨V.boundaryFlag j, hbj⟩ := Subtype.ext hfj + rw [hfe] + exact (oddPushHitFun_at_j hij hopen t hct hpi _ hbj).trans + (hvI.trans hvj.symm) + · have hgt : (⟨f.val, hfi, hfj⟩ : SurvivingFlag V i j) ∈ t := + (surviving_val_mem_liftOpen_iff hopen t _).mp f.prop + exact oddPushHitFun_agrees hij hopen t hct hpi _ + ⟨f.val, hfi, hfj⟩ f.prop hgt + +include hij hopen hct hcL hpi in +/-- **The even boundary constraint across a carried cut.** -/ +theorem genEvenBoundaryMatch_hit_iff {k ℓ : ℕ} + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (d : Fin (2 * ℓ)) + (hbndW : genBoundarySubsetMatches V + (liftSubsetOpen hopen t) + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d))) + (hbnd' : genBoundarySubsetMatches + (V.gluePairOpen i j hij hopen) t st') + (ψ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).EvenColouring k) : + genEvenBoundaryMatch + (EdgeSubset.mk (liftSubsetOpen hopen t) hcL) + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d)) hbndW + ((evenColourEquivHit hij hopen t hct hcL hpi k).symm ψ') + ↔ genEvenBoundaryMatch (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)) st' hbnd' + ψ' := by + constructor + · intro hW b' y hst + have hstW : GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d) b'.val = Sum.inl y := by + rw [GenBoundaryState.extendPair_surviving] + exact hst + exact (congrArg ψ'.val (Subtype.ext (Subtype.ext rfl))).symm.trans + (hW b'.val y hstW) + · intro hG b y hst + have hbi : b ≠ i := by + intro hx + rw [hx, GenBoundaryState.extendPair_left] at hst + exact absurd hst (by simp) + have hbj : b ≠ j := by + intro hx + rw [hx, GenBoundaryState.extendPair_right hij] at hst + exact absurd hst (by simp) + have hst' : st' ⟨b, hbi, hbj⟩ = Sum.inl y := by + rw [← GenBoundaryState.extendPair_surviving st' (Sum.inr d) + (Sum.inr d) ⟨b, hbi, hbj⟩] + exact hst + exact (congrArg ψ'.val (Subtype.ext (Subtype.ext rfl))).trans + (hG ⟨b, hbi, hbj⟩ y hst') + +open scoped Classical in +include hij hopen hct hcL hpi in +/-- **The odd colouring sum is a sum over the glued colourings.** -/ +theorem sum_odd_hit {k ℓ : ℕ} + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (d : Fin (2 * ℓ)) + (G : (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).EdgeOddColouring ℓ → ℂ) : + (∑ φW : (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).EdgeOddColouring ℓ, + if edgeOddBoundaryMatch + (EdgeSubset.mk (liftSubsetOpen hopen t) hcL) + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d)) φW then G φW else 0) + = ∑ φ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).EdgeOddColouring + ℓ, + if edgeOddBoundaryMatch + (EdgeSubset.mk (liftSubsetOpen hopen t) hcL) + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d)) + (oddPushHit hij hopen t hct hcL hpi φ') then + G (oddPushHit hij hopen t hct hcL hpi φ') else 0 := by + calc (∑ φW : (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).EdgeOddColouring ℓ, + if edgeOddBoundaryMatch + (EdgeSubset.mk (liftSubsetOpen hopen t) hcL) + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d)) φW then G φW else 0) + = ∑ φW ∈ Finset.univ.image + (oddPushHit hij hopen t hct hcL hpi (ℓ := ℓ)), + (if edgeOddBoundaryMatch + (EdgeSubset.mk (liftSubsetOpen hopen t) hcL) + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d)) φW then G φW else 0) := by + refine (Finset.sum_subset (Finset.subset_univ _) ?_).symm + intro φW _ hnotim + rw [ite_eq_right (fun hmatch => hnotim ?_)] + obtain ⟨φ', hφ'⟩ := oddPushHit_covers hij hopen t hct hcL + hpi st' d φW hmatch + exact Finset.mem_image.mpr ⟨φ', Finset.mem_univ _, hφ'⟩ + _ = _ := Finset.sum_image (fun x _ y _ hxy => + oddPushHit_injective hij hopen t hct hcL hpi hxy) + +section HitSum + +variable (κ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).RelTransitionSystem) + (o' : κ'.Orientation) + +include hij hopen hct hcL hpi in +open Classical in +/-- **One carried cut, on RS21's colouring sums.** The join carries +an odd colour, and that colour is the glued colouring's own there — +so again the sum over it has a single term. -/ +theorem edgeSum_openCut_hit + [LinearOrder L] + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (hbnd' : genBoundarySubsetMatches + (V.gluePairOpen i j hij hopen) t st') + (hbndW : ∀ d : Fin (2 * ℓ), genBoundarySubsetMatches V + (liftSubsetOpen hopen t) + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d))) : + (∑ d : Fin (2 * ℓ), + (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).edgeSum h + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d)) (hbndW d) + (unglueOrientationOpen hij hopen t hct hcL κ' o')) + = (EdgeSubset.mk t hct : EdgeSubset + (V.gluePairOpen i j hij hopen)).edgeSum h st' hbnd' + o' := by + -- ═══════ THE LIFTED SUM, ONE INTERFACE COLOUR AT A TIME ═══════ + have hL : ∀ d : Fin (2 * ℓ), + (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).edgeSum h + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d)) (hbndW d) + (unglueOrientationOpen hij hopen t hct hcL κ' o') + = ∑ ψ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).EvenColouring + k, + if genEvenBoundaryMatch (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)) st' + hbnd' ψ' then + (∑ φ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij + hopen)).EdgeOddColouring ℓ, + if (φ'.val ⟨partnerSurvI hopen, hpi⟩ = d ∧ + edgeOddBoundaryMatch (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)) + st' φ') then + ∏ v : V.Vertex, + (((EdgeSubset.mk t hct : EdgeSubset + (V.gluePairOpen i j hij + hopen)).coreOddSignAt o' φ'.core v : ℂ) * + h.evalOdd ((EdgeSubset.mk t hct : EdgeSubset + (V.gluePairOpen i j hij + hopen)).evenColoursAt ψ' v) + ((EdgeSubset.mk t hct : EdgeSubset + (V.gluePairOpen i j hij + hopen)).coreOddListAt o' φ'.core v)) + else 0) + else 0 := by + intro d + unfold edgeSum + refine (Fintype.sum_equiv + (evenColourEquivHit hij hopen t hct hcL hpi k).symm _ _ + (fun ψ' => ?_)).symm + by_cases hg : genEvenBoundaryMatch (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)) st' hbnd' ψ' + · rw [ite_eq_left hg, ite_eq_left ((genEvenBoundaryMatch_hit_iff hij hopen + t hct hcL hpi st' d (hbndW d) hbnd' ψ').mpr hg), + sum_odd_hit hij hopen t hct hcL hpi st' d + (fun φW => ∏ v : V.Vertex, + (((EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).coreOddSignAt + (unglueOrientationOpen hij hopen t hct hcL κ' o') + φW.core v : ℂ) * + h.evalOdd ((EdgeSubset.mk (liftSubsetOpen hopen t) + hcL : EdgeSubset V).evenColoursAt + ((evenColourEquivHit hij hopen t hct hcL hpi + k).symm ψ') v) + ((EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).coreOddListAt + (unglueOrientationOpen hij hopen t hct hcL κ' o') + φW.core v)))] + refine Finset.sum_congr rfl (fun φ' _ => ?_) + by_cases hp : (φ'.val ⟨partnerSurvI hopen, hpi⟩ = d ∧ + edgeOddBoundaryMatch (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)) st' φ') + · rw [ite_eq_left ((edgeOddBoundaryMatch_hit_iff hij hopen t hct + hcL hpi st' d φ').mpr hp), ite_eq_left hp] + refine Finset.prod_congr rfl (fun v _ => ?_) + exact (vertexFactor_transport_T hij hopen t hct hcL κ' o' h + ((evenColourEquivHit hij hopen t hct hcL hpi k).symm ψ') + ψ' (fun g h1 h2 => + congrArg ψ'.val (Subtype.ext (Subtype.ext rfl))) + (oddPushHit hij hopen t hct hcL hpi φ').core φ'.core + (fun g h1 h2 => oddPushHitFun_agrees hij hopen t hct hpi + φ' g _ _) v).symm + · rw [ite_eq_right (fun hx => hp ((edgeOddBoundaryMatch_hit_iff hij + hopen t hct hcL hpi st' d φ').mp hx)), ite_eq_right hp] + · rw [ite_eq_right hg, ite_eq_right (fun hx => hg + ((genEvenBoundaryMatch_hit_iff hij hopen t hct hcL hpi st' d + (hbndW d) hbnd' ψ').mp hx))] + -- ═══════ SUMMING THE COLOURS BACK UP ═══════ + rw [Finset.sum_congr rfl (fun d (_ : d ∈ Finset.univ) => hL d), + Finset.sum_comm] + unfold edgeSum + refine Finset.sum_congr rfl (fun ψ' _ => ?_) + by_cases hg : genEvenBoundaryMatch (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)) st' hbnd' ψ' + · simp only [ite_eq_left hg] + rw [Finset.sum_comm] + refine Finset.sum_congr rfl (fun φ' _ => ?_) + by_cases hp : edgeOddBoundaryMatch (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)) st' φ' + · rw [ite_eq_left hp, Finset.sum_eq_single + (φ'.val ⟨partnerSurvI hopen, hpi⟩) + (fun d _ hne => ite_eq_right (fun hx => hne hx.1.symm)) + (fun hx => absurd (Finset.mem_univ _) hx), ite_eq_left ⟨rfl, hp⟩] + rfl + · rw [ite_eq_right hp] + exact Finset.sum_eq_zero (fun d _ => ite_eq_right (fun hx => hp hx.2)) + · simp only [ite_eq_right hg] + exact Finset.sum_const_zero + +end HitSum + +end Hit + +end OpenCut + +/-! ## The cut that closes + +Gluing an edge whose two ends are both labelled removes it and +leaves a free circle. RS21 records this explicitly; the colourings +see it as two blocks — the edge outside the subset, carrying an even +colour, and inside it, carrying an odd one — each of which is the +glued fragment's colouring sum over again. +-/ + +section ClosedCut + +variable {L : Type} {V : Fragment L} {i j : L} + (hij : i ≠ j) + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + (hct : ∀ f ∈ t, (V.gluePairClosed i j hclosed).pairing f ∈ t) + +section ClosedFalse + +variable (hcL : ∀ f ∈ liftSubsetClosed t false, + V.pairing f ∈ liftSubsetClosed t false) + +include hij in +/-- The `i`-flag is out of the empty lift. -/ +theorem boundaryFlagI_notMem_liftClosed_false : + V.boundaryFlag i ∉ liftSubsetClosed t false := fun hmem => + Bool.false_ne_true + ((boundaryFlagI_mem_liftClosed_iff hij t false).mp hmem) + +include hij in +/-- The `j`-flag is out of the empty lift. -/ +theorem boundaryFlagJ_notMem_liftClosed_false : + V.boundaryFlag j ∉ liftSubsetClosed t false := fun hmem => + Bool.false_ne_true + ((boundaryFlagJ_mem_liftClosed_iff hij t false).mp hmem) + +include hij in +/-- A flag of the empty lift survives the glue. -/ +theorem surviving_of_mem_liftClosed_false {f : V.Flag} + (hf : f ∈ liftSubsetClosed t false) : + f ≠ V.boundaryFlag i ∧ f ≠ V.boundaryFlag j := + ⟨fun hx => boundaryFlagI_notMem_liftClosed_false hij t (hx ▸ hf), + fun hx => boundaryFlagJ_notMem_liftClosed_false hij t (hx ▸ hf)⟩ + +/-- A flag of the empty lift, as a flag of the glued fragment. -/ +noncomputable def survOfLiftClosedFalse {f : V.Flag} + (hf : f ∈ liftSubsetClosed t false) : SurvivingFlag V i j := + ⟨f, (surviving_of_mem_liftClosed_false hij t hf).1, + (surviving_of_mem_liftClosed_false hij t hf).2⟩ + +/-- A glued subset flag's underlying flag lies in the untaken +closed lift. -/ +theorem mem_liftClosed_false_of_mem {g : SurvivingFlag V i j} + (hg : g ∈ t) : g.val ∈ liftSubsetClosed t false := + (surviving_val_mem_liftClosed_iff t false g).mpr hg + +/-- A flag of the untaken closed lift lies in the glued subset. -/ +theorem survOfLiftClosedFalse_mem {f : V.Flag} + (hf : f ∈ liftSubsetClosed t false) : + survOfLiftClosedFalse hij t hf ∈ t := + (surviving_val_mem_liftClosed_iff t false _).mp hf + +/-- **Odd colourings agree across a closing cut the subset +misses.** -/ +noncomputable def oddColourEquivClosedFalse (ℓ : ℕ) : + (EdgeSubset.mk (liftSubsetClosed t false) hcL : + EdgeSubset V).EdgeOddColouring ℓ + ≃ (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).EdgeOddColouring + ℓ where + toFun φ := + ⟨fun g => φ.val ⟨g.val.val, + mem_liftClosed_false_of_mem t g.prop⟩, + fun g => + Eq.trans + (congrArg φ.val (Subtype.ext + (gluePairClosed_pairing_val hclosed g.val))) + (φ.prop ⟨g.val.val, + mem_liftClosed_false_of_mem t g.prop⟩)⟩ + invFun φ' := + ⟨fun f => φ'.val ⟨survOfLiftClosedFalse hij t f.prop, + survOfLiftClosedFalse_mem hij t f.prop⟩, + fun f => by + refine Eq.trans ?_ (φ'.prop + ⟨survOfLiftClosedFalse hij t f.prop, + survOfLiftClosedFalse_mem hij t f.prop⟩) + exact congrArg φ'.val (Subtype.ext (Subtype.ext + (gluePairClosed_pairing_val hclosed + (survOfLiftClosedFalse hij t f.prop)).symm))⟩ + left_inv _ := rfl + right_inv _ := rfl + +include hij hclosed hct hcL in +/-- **The odd boundary constraint matches across a closing cut the +subset misses.** -/ +theorem edgeOddBoundaryMatch_closedFalse {k ℓ : ℕ} + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) (a : Fin k) + (φ : (EdgeSubset.mk (liftSubsetClosed t false) hcL : + EdgeSubset V).EdgeOddColouring ℓ) : + edgeOddBoundaryMatch + (EdgeSubset.mk (liftSubsetClosed t false) hcL) + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a)) φ + ↔ edgeOddBoundaryMatch (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)) st' + (oddColourEquivClosedFalse hij hclosed t hct hcL ℓ φ) := by + constructor + · intro hW b' c hst hmem + have hstW : GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a) b'.val = Sum.inr c := by + rw [GenBoundaryState.extendPair_surviving] + exact hst + exact Eq.trans (congrArg φ.val (Subtype.ext rfl)) + (hW b'.val c hstW (mem_liftClosed_false_of_mem t hmem)) + · intro hG b c hst hmem + have hbi : b ≠ i := by + intro hx + rw [hx, GenBoundaryState.extendPair_left] at hst + exact absurd hst (by simp) + have hbj : b ≠ j := by + intro hx + rw [hx, GenBoundaryState.extendPair_right hij] at hst + exact absurd hst (by simp) + have hst' : st' ⟨b, hbi, hbj⟩ = Sum.inr c := by + rw [← GenBoundaryState.extendPair_surviving st' (Sum.inl a) + (Sum.inl a) ⟨b, hbi, hbj⟩] + exact hst + exact Eq.trans (congrArg φ.val (Subtype.ext rfl)) + (hG ⟨b, hbi, hbj⟩ c hst' + ((surviving_val_mem_liftClosed_iff t false _).mp hmem)) + +/-- The pushed even colouring's value at a flag outside the +lift. -/ +noncomputable def evenPushClosedFalseFun {k : ℕ} (a : Fin k) + (ψ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).EvenColouring k) + (f : {g : V.Flag // g ∉ liftSubsetClosed t false}) : Fin k := + if hfi : f.val = V.boundaryFlag i then a + else if hfj : f.val = V.boundaryFlag j then a + else ψ'.val ⟨⟨f.val, hfi, hfj⟩, fun hmem => f.prop + ((surviving_val_mem_liftClosed_iff t false + ⟨f.val, hfi, hfj⟩).mpr hmem)⟩ + +/-- At the first glued boundary flag the pushed even colouring +takes the summation colour. -/ +theorem evenPushClosedFalseFun_at_i {k : ℕ} (a : Fin k) + (ψ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).EvenColouring k) + (hP : V.boundaryFlag i ∉ liftSubsetClosed t false) : + evenPushClosedFalseFun hclosed t hct a ψ' + ⟨V.boundaryFlag i, hP⟩ = a := dite_eq_left rfl + +include hij in +/-- At the second it takes the same colour. -/ +theorem evenPushClosedFalseFun_at_j {k : ℕ} (a : Fin k) + (ψ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).EvenColouring k) + (hP : V.boundaryFlag j ∉ liftSubsetClosed t false) : + evenPushClosedFalseFun hclosed t hct a ψ' + ⟨V.boundaryFlag j, hP⟩ = a := by + unfold evenPushClosedFalseFun + rw [dite_eq_right (fun hEq => hij (V.boundaryFlag_injective hEq).symm), + dite_eq_left rfl] + +/-- Away from the two glued flags the pushed even colouring is +unchanged. -/ +theorem evenPushClosedFalseFun_agrees {k : ℕ} (a : Fin k) + (ψ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).EvenColouring k) + (g : SurvivingFlag V i j) + (h1 : g.val ∉ liftSubsetClosed t false) (h2 : g ∉ t) : + evenPushClosedFalseFun hclosed t hct a ψ' ⟨g.val, h1⟩ + = ψ'.val ⟨g, h2⟩ := by + unfold evenPushClosedFalseFun + rw [dite_eq_right g.prop.1, dite_eq_right g.prop.2] + +/-- **Push a glued even colouring up to the lift**, colouring the +closed edge with the join's colour. -/ +noncomputable def evenPushClosedFalse {k : ℕ} (a : Fin k) + (ψ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).EvenColouring k) : + (EdgeSubset.mk (liftSubsetClosed t false) hcL : + EdgeSubset V).EvenColouring k := + ⟨evenPushClosedFalseFun hclosed t hct a ψ', by + intro f + have hbi := boundaryFlagI_notMem_liftClosed_false hij t + have hbj := boundaryFlagJ_notMem_liftClosed_false hij t + have hpn : V.pairing f.val ∉ liftSubsetClosed t false := + (EdgeSubset.mk (liftSubsetClosed t false) + hcL).pairing_not_mem f.prop + by_cases hfi : f.val = V.boundaryFlag i + · have hpv : V.pairing f.val = V.boundaryFlag j := by + rw [hfi]; exact hclosed + have h1 : (⟨V.pairing f.val, hpn⟩ : + {g : V.Flag // g ∉ liftSubsetClosed t false}) + = ⟨V.boundaryFlag j, hbj⟩ := Subtype.ext hpv + have h2 : f = ⟨V.boundaryFlag i, hbi⟩ := Subtype.ext hfi + rw [h1, h2, evenPushClosedFalseFun_at_i hclosed t hct, + evenPushClosedFalseFun_at_j hij hclosed t hct] + · by_cases hfj : f.val = V.boundaryFlag j + · have hpv : V.pairing f.val = V.boundaryFlag i := by + rw [hfj, ← hclosed, V.pairing_invol] + have h1 : (⟨V.pairing f.val, hpn⟩ : + {g : V.Flag // g ∉ liftSubsetClosed t false}) + = ⟨V.boundaryFlag i, hbi⟩ := Subtype.ext hpv + have h2 : f = ⟨V.boundaryFlag j, hbj⟩ := Subtype.ext hfj + rw [h1, h2, evenPushClosedFalseFun_at_i hclosed t hct, + evenPushClosedFalseFun_at_j hij hclosed t hct] + · have hpi' : V.pairing f.val ≠ V.boundaryFlag i := by + intro hx + exact hfj (by rw [← hclosed, ← hx, V.pairing_invol]) + have hpj' : V.pairing f.val ≠ V.boundaryFlag j := by + intro hx + exact hfi (by rw [← V.pairing_invol f.val, hx, ← hclosed, + V.pairing_invol]) + have hgn : (⟨f.val, hfi, hfj⟩ : SurvivingFlag V i j) ∉ t := + fun hmem => f.prop + ((surviving_val_mem_liftClosed_iff t false _).mpr hmem) + have hgn' : ((V.gluePairClosed i j hclosed).pairing + ⟨f.val, hfi, hfj⟩) ∉ t := fun hmem => hgn + ((V.gluePairClosed i j hclosed).pairing_invol + (⟨f.val, hfi, hfj⟩ : SurvivingFlag V i j) ▸ hct _ hmem) + have hval : ((V.gluePairClosed i j hclosed).pairing + ⟨f.val, hfi, hfj⟩).val = V.pairing f.val := + gluePairClosed_pairing_val hclosed ⟨f.val, hfi, hfj⟩ + have h1 : (⟨V.pairing f.val, hpn⟩ : + {g : V.Flag // g ∉ liftSubsetClosed t false}) + = ⟨((V.gluePairClosed i j hclosed).pairing + ⟨f.val, hfi, hfj⟩).val, + fun hmem => hgn' + ((surviving_val_mem_liftClosed_iff t false _).mp + hmem)⟩ := Subtype.ext hval.symm + rw [h1, evenPushClosedFalseFun_agrees hclosed t hct a ψ' _ _ + hgn', + evenPushClosedFalseFun_agrees hclosed t hct a ψ' + ⟨f.val, hfi, hfj⟩ f.prop hgn] + exact ψ'.prop ⟨⟨f.val, hfi, hfj⟩, hgn⟩⟩ + +include hij hclosed hct hcL in +/-- The push is injective. -/ +theorem evenPushClosedFalse_injective {k : ℕ} (a : Fin k) : + Function.Injective + (evenPushClosedFalse hij hclosed t hct hcL a (k := k)) := by + intro ψ₁ ψ₂ hEq + refine Subtype.ext (funext fun x => ?_) + have h1 : x.val.val ∉ liftSubsetClosed t false := fun hmem => + x.prop ((surviving_val_mem_liftClosed_iff t false x.val).mp + hmem) + have hv := congrArg (fun ψ : + (EdgeSubset.mk (liftSubsetClosed t false) hcL : + EdgeSubset V).EvenColouring k => ψ.val ⟨x.val.val, h1⟩) hEq + simp only [] at hv + have e1 : (evenPushClosedFalse hij hclosed t hct hcL a ψ₁).val + ⟨x.val.val, h1⟩ = ψ₁.val ⟨x.val, x.prop⟩ := + evenPushClosedFalseFun_agrees hclosed t hct a ψ₁ x.val h1 x.prop + have e2 : (evenPushClosedFalse hij hclosed t hct hcL a ψ₂).val + ⟨x.val.val, h1⟩ = ψ₂.val ⟨x.val, x.prop⟩ := + evenPushClosedFalseFun_agrees hclosed t hct a ψ₂ x.val h1 x.prop + rw [e1, e2] at hv + exact hv + +include hij hclosed hct hcL in +/-- **The even boundary constraint across a closing cut the subset +misses.** -/ +theorem genEvenBoundaryMatch_closedFalse_iff {k ℓ : ℕ} + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) (a : Fin k) + (hbndW : genBoundarySubsetMatches V (liftSubsetClosed t false) + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a))) + (hbnd' : genBoundarySubsetMatches + (V.gluePairClosed i j hclosed) t st') + (ψ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).EvenColouring k) : + genEvenBoundaryMatch + (EdgeSubset.mk (liftSubsetClosed t false) hcL) + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a)) hbndW + (evenPushClosedFalse hij hclosed t hct hcL a ψ') + ↔ genEvenBoundaryMatch (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)) st' hbnd' + ψ' := by + constructor + · intro hW b' y hst + have hstW : GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a) b'.val = Sum.inl y := by + rw [GenBoundaryState.extendPair_surviving] + exact hst + exact (evenPushClosedFalseFun_agrees hclosed t hct a ψ' + (glueBoundaryFlag V i j b') _ _).symm.trans + (hW b'.val y hstW) + · intro hG b y hst + by_cases hbi : b = i + · subst hbi + have hy : y = a := Sum.inl.inj (hst.symm.trans + (GenBoundaryState.extendPair_left st' (Sum.inl a) + (Sum.inl a))) + subst hy + exact evenPushClosedFalseFun_at_i hclosed t hct _ ψ' _ + · by_cases hbj : b = j + · subst hbj + have hy : y = a := Sum.inl.inj (hst.symm.trans + (GenBoundaryState.extendPair_right hij st' (Sum.inl a) + (Sum.inl a))) + subst hy + exact evenPushClosedFalseFun_at_j hij hclosed t hct _ ψ' _ + · have hst' : st' ⟨b, hbi, hbj⟩ = Sum.inl y := by + rw [← GenBoundaryState.extendPair_surviving st' + (Sum.inl a) (Sum.inl a) ⟨b, hbi, hbj⟩] + exact hst + exact (evenPushClosedFalseFun_agrees hclosed t hct a ψ' + (glueBoundaryFlag V i j ⟨b, hbi, hbj⟩) _ _).trans + (hG ⟨b, hbi, hbj⟩ y hst') + +include hij hclosed hct hcL in +/-- **Every colouring meeting the join's constraint is a push.** -/ +theorem evenPushClosedFalse_covers {k ℓ : ℕ} + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) (a : Fin k) + (hbndW : genBoundarySubsetMatches V (liftSubsetClosed t false) + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a))) + (ψW : (EdgeSubset.mk (liftSubsetClosed t false) hcL : + EdgeSubset V).EvenColouring k) + (hmatch : genEvenBoundaryMatch + (EdgeSubset.mk (liftSubsetClosed t false) hcL) + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a)) hbndW ψW) : + ∃ ψ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).EvenColouring k, + evenPushClosedFalse hij hclosed t hct hcL a ψ' = ψW := by + have hbi := boundaryFlagI_notMem_liftClosed_false hij t + have hbj := boundaryFlagJ_notMem_liftClosed_false hij t + have hvi : ψW.val ⟨V.boundaryFlag i, hbi⟩ = a := + hmatch i a (GenBoundaryState.extendPair_left st' _ _) + have hvj : ψW.val ⟨V.boundaryFlag j, hbj⟩ = a := + hmatch j a (GenBoundaryState.extendPair_right hij st' _ _) + refine ⟨⟨fun g => ψW.val ⟨g.val.val, fun hmem => g.prop + ((surviving_val_mem_liftClosed_iff t false g.val).mp hmem)⟩, + ?_⟩, ?_⟩ + · intro g + dsimp only [] + have hval : ((V.gluePairClosed i j hclosed).pairing g.val).val + = V.pairing g.val.val := + gluePairClosed_pairing_val hclosed g.val + have hmA : ((V.gluePairClosed i j hclosed).pairing g.val).val + ∉ liftSubsetClosed t false := fun hmem => + ((EdgeSubset.mk t hct : EdgeSubset + (V.gluePairClosed i j hclosed)).pairing_not_mem + g.prop) ((surviving_val_mem_liftClosed_iff t false _).mp + hmem) + have hmC : g.val.val ∉ liftSubsetClosed t false := fun hmem => + g.prop ((surviving_val_mem_liftClosed_iff t false _).mp hmem) + have hmB : V.pairing g.val.val ∉ liftSubsetClosed t false := + (EdgeSubset.mk (liftSubsetClosed t false) + hcL).pairing_not_mem hmC + have h1 : (⟨_, hmA⟩ : + {f : V.Flag // f ∉ liftSubsetClosed t false}) + = ⟨_, hmB⟩ := Subtype.ext hval + rw [h1] + exact ψW.prop ⟨g.val.val, hmC⟩ + · refine Subtype.ext (funext fun f => ?_) + change evenPushClosedFalseFun hclosed t hct a _ f = ψW.val f + by_cases hfi : f.val = V.boundaryFlag i + · have hfe : f = ⟨V.boundaryFlag i, hbi⟩ := Subtype.ext hfi + rw [hfe] + exact (evenPushClosedFalseFun_at_i hclosed t hct a _ hbi).trans + hvi.symm + · by_cases hfj : f.val = V.boundaryFlag j + · have hfe : f = ⟨V.boundaryFlag j, hbj⟩ := Subtype.ext hfj + rw [hfe] + exact (evenPushClosedFalseFun_at_j hij hclosed t hct a _ + hbj).trans hvj.symm + · have hgn : (⟨f.val, hfi, hfj⟩ : SurvivingFlag V i j) ∉ t := + fun hmem => f.prop + ((surviving_val_mem_liftClosed_iff t false _).mpr hmem) + exact evenPushClosedFalseFun_agrees hclosed t hct a _ + ⟨f.val, hfi, hfj⟩ f.prop hgn + +section ClosedFalseSum + +variable (κ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).RelTransitionSystem) + (o' : κ'.Orientation) + +include hij hclosed hct hcL in +open Classical in +/-- **The even colouring sum is a sum over the glued +colourings.** -/ +theorem sum_even_closed_false {k ℓ : ℕ} + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) (a : Fin k) + (hbndW : genBoundarySubsetMatches V (liftSubsetClosed t false) + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a))) + (G : (EdgeSubset.mk (liftSubsetClosed t false) hcL : + EdgeSubset V).EvenColouring k → ℂ) : + (∑ ψW : (EdgeSubset.mk (liftSubsetClosed t false) hcL : + EdgeSubset V).EvenColouring k, + if genEvenBoundaryMatch + (EdgeSubset.mk (liftSubsetClosed t false) hcL) + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a)) hbndW ψW then G ψW else 0) + = ∑ ψ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).EvenColouring k, + if genEvenBoundaryMatch + (EdgeSubset.mk (liftSubsetClosed t false) hcL) + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a)) hbndW + (evenPushClosedFalse hij hclosed t hct hcL a ψ') then + G (evenPushClosedFalse hij hclosed t hct hcL a ψ') + else 0 := by + calc (∑ ψW : (EdgeSubset.mk (liftSubsetClosed t false) hcL : + EdgeSubset V).EvenColouring k, + if genEvenBoundaryMatch + (EdgeSubset.mk (liftSubsetClosed t false) hcL) + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a)) hbndW ψW then G ψW else 0) + = ∑ ψW ∈ Finset.univ.image + (evenPushClosedFalse hij hclosed t hct hcL a (k := k)), + (if genEvenBoundaryMatch + (EdgeSubset.mk (liftSubsetClosed t false) hcL) + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a)) hbndW ψW then G ψW else 0) := by + refine (Finset.sum_subset (Finset.subset_univ _) ?_).symm + intro ψW _ hnotim + rw [ite_eq_right (fun hmatch => hnotim ?_)] + obtain ⟨ψ', hψ'⟩ := evenPushClosedFalse_covers hij hclosed t + hct hcL st' a hbndW ψW hmatch + exact Finset.mem_image.mpr ⟨ψ', Finset.mem_univ _, hψ'⟩ + _ = _ := Finset.sum_image (fun x _ y _ hxy => + evenPushClosedFalse_injective hij hclosed t hct hcL a hxy) + +include hij hclosed hct hcL in +open Classical in +/-- **A closing cut the subset misses, on RS21's colouring sums.** +The closed edge carries the join's even colour and nothing else +changes, so each of the `k` colours reproduces the glued sum. -/ +theorem edgeSum_closedCut_false + [LinearOrder L] + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) (a : Fin k) + (hbnd' : genBoundarySubsetMatches + (V.gluePairClosed i j hclosed) t st') + (hbndW : genBoundarySubsetMatches V (liftSubsetClosed t false) + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a))) : + (EdgeSubset.mk (liftSubsetClosed t false) hcL : + EdgeSubset V).edgeSum h + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a)) hbndW + (unglueOrientationClosed hclosed false t hct hcL κ' o') + = (EdgeSubset.mk t hct : EdgeSubset + (V.gluePairClosed i j hclosed)).edgeSum h st' hbnd' + o' := by + unfold edgeSum + rw [sum_even_closed_false hij hclosed t hct hcL st' a hbndW + (fun ψW => ∑ φ : (EdgeSubset.mk (liftSubsetClosed t false) + hcL : EdgeSubset V).EdgeOddColouring ℓ, + if edgeOddBoundaryMatch + (EdgeSubset.mk (liftSubsetClosed t false) hcL) + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a)) φ then + ∏ v : V.Vertex, + (((EdgeSubset.mk (liftSubsetClosed t false) hcL : + EdgeSubset V).coreOddSignAt + (unglueOrientationClosed hclosed false t hct hcL κ' o') + φ.core v : ℂ) * + h.evalOdd ((EdgeSubset.mk (liftSubsetClosed t false) + hcL : EdgeSubset V).evenColoursAt ψW v) + ((EdgeSubset.mk (liftSubsetClosed t false) hcL : + EdgeSubset V).coreOddListAt + (unglueOrientationClosed hclosed false t hct hcL κ' + o') φ.core v)) + else 0)] + refine Finset.sum_congr rfl (fun ψ' _ => ?_) + by_cases hg : genEvenBoundaryMatch (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)) st' hbnd' ψ' + · rw [ite_eq_left ((genEvenBoundaryMatch_closedFalse_iff hij hclosed t + hct hcL st' a hbndW hbnd' ψ').mpr hg), ite_eq_left hg] + refine Fintype.sum_equiv + (oddColourEquivClosedFalse hij hclosed t hct hcL ℓ) _ _ + (fun φ => ?_) + by_cases hm : edgeOddBoundaryMatch + (EdgeSubset.mk (liftSubsetClosed t false) hcL) + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a)) φ + · rw [ite_eq_left hm, ite_eq_left ((edgeOddBoundaryMatch_closedFalse hij + hclosed t hct hcL st' a φ).mp hm)] + refine Finset.prod_congr rfl (fun v _ => ?_) + exact vertexFactor_transport_closed hclosed t false hct hcL + κ' o' h (evenPushClosedFalse hij hclosed t hct hcL a ψ') ψ' + (fun g h1 h2 => evenPushClosedFalseFun_agrees hclosed t hct + a ψ' g h1 h2) + φ.core (oddColourEquivClosedFalse hij hclosed t hct hcL ℓ + φ).core + (fun g h1 h2 => congrArg φ.val (Subtype.ext rfl)) v + · rw [ite_eq_right hm, ite_eq_right (fun hx => hm + ((edgeOddBoundaryMatch_closedFalse hij hclosed t hct hcL st' + a φ).mpr hx))] + · rw [ite_eq_right (fun hx => hg ((genEvenBoundaryMatch_closedFalse_iff + hij hclosed t hct hcL st' a hbndW hbnd' ψ').mp hx)), + ite_eq_right hg] + +end ClosedFalseSum + +end ClosedFalse + +section ClosedTrue + +variable (hcT : ∀ f ∈ liftSubsetClosed t true, + V.pairing f ∈ liftSubsetClosed t true) + +include hij in +/-- The `i`-flag is in the carried lift. -/ +theorem boundaryFlagI_mem_liftClosed_true : + V.boundaryFlag i ∈ liftSubsetClosed t true := + (boundaryFlagI_mem_liftClosed_iff hij t true).mpr rfl + +include hij in +/-- The `j`-flag is in the carried lift. -/ +theorem boundaryFlagJ_mem_liftClosed_true : + V.boundaryFlag j ∈ liftSubsetClosed t true := + (boundaryFlagJ_mem_liftClosed_iff hij t true).mpr rfl + +include hij in +/-- A flag outside the carried lift survives the glue. -/ +theorem surviving_of_notMem_liftClosed_true {f : V.Flag} + (hf : f ∉ liftSubsetClosed t true) : + f ≠ V.boundaryFlag i ∧ f ≠ V.boundaryFlag j := + ⟨fun hx => hf (hx ▸ boundaryFlagI_mem_liftClosed_true hij t), + fun hx => hf (hx ▸ boundaryFlagJ_mem_liftClosed_true hij t)⟩ + +/-- A flag outside the carried lift, as a glued flag. -/ +noncomputable def survOfNotLiftClosedTrue {f : V.Flag} + (hf : f ∉ liftSubsetClosed t true) : SurvivingFlag V i j := + ⟨f, (surviving_of_notMem_liftClosed_true hij t hf).1, + (surviving_of_notMem_liftClosed_true hij t hf).2⟩ + +/-- A flag outside the taken closed lift lies outside the glued +subset. -/ +theorem survOfNotLiftClosedTrue_notMem {f : V.Flag} + (hf : f ∉ liftSubsetClosed t true) : + survOfNotLiftClosedTrue hij t hf ∉ t := fun hm => + hf ((surviving_val_mem_liftClosed_iff t true _).mpr hm) + +/-- A glued subset flag's underlying flag lies in the taken closed +lift. -/ +theorem mem_liftClosed_true_of_mem {g : SurvivingFlag V i j} + (hg : g ∈ t) : g.val ∈ liftSubsetClosed t true := + (surviving_val_mem_liftClosed_iff t true g).mpr hg + +/-- And a flag outside the glued subset lies outside it. -/ +theorem notMem_liftClosed_true_of_notMem {g : SurvivingFlag V i j} + (hg : g ∉ t) : g.val ∉ liftSubsetClosed t true := fun hm => + hg ((surviving_val_mem_liftClosed_iff t true g).mp hm) + +/-- **Even colourings agree across a closing cut the subset +carries.** -/ +noncomputable def evenColourEquivClosedTrue (k : ℕ) : + (EdgeSubset.mk (liftSubsetClosed t true) hcT : + EdgeSubset V).EvenColouring k + ≃ (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).EvenColouring + k where + toFun ψ := + ⟨fun g => ψ.val ⟨g.val.val, + notMem_liftClosed_true_of_notMem t g.prop⟩, + fun g => + Eq.trans + (congrArg ψ.val (Subtype.ext + (gluePairClosed_pairing_val hclosed g.val))) + (ψ.prop ⟨g.val.val, + notMem_liftClosed_true_of_notMem t g.prop⟩)⟩ + invFun ψ' := + ⟨fun f => ψ'.val ⟨survOfNotLiftClosedTrue hij t f.prop, + survOfNotLiftClosedTrue_notMem hij t f.prop⟩, + fun f => by + refine Eq.trans ?_ (ψ'.prop + ⟨survOfNotLiftClosedTrue hij t f.prop, + survOfNotLiftClosedTrue_notMem hij t f.prop⟩) + exact congrArg ψ'.val (Subtype.ext (Subtype.ext + (gluePairClosed_pairing_val hclosed + (survOfNotLiftClosedTrue hij t f.prop)).symm))⟩ + left_inv _ := rfl + right_inv _ := rfl + +include hij hclosed hct hcT in +/-- **The even boundary constraint across a closing cut the subset +carries.** -/ +theorem genEvenBoundaryMatch_closedTrue_iff {k ℓ : ℕ} + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (d : Fin (2 * ℓ)) + (hbndW : genBoundarySubsetMatches V (liftSubsetClosed t true) + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d))) + (hbnd' : genBoundarySubsetMatches + (V.gluePairClosed i j hclosed) t st') + (ψ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).EvenColouring k) : + genEvenBoundaryMatch + (EdgeSubset.mk (liftSubsetClosed t true) hcT) + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d)) hbndW + ((evenColourEquivClosedTrue hij hclosed t hct hcT k).symm + ψ') + ↔ genEvenBoundaryMatch (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)) st' hbnd' + ψ' := by + constructor + · intro hW b' y hst + have hstW : GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d) b'.val = Sum.inl y := by + rw [GenBoundaryState.extendPair_surviving] + exact hst + exact (congrArg ψ'.val (Subtype.ext (Subtype.ext + rfl))).symm.trans (hW b'.val y hstW) + · intro hG b y hst + have hbi : b ≠ i := by + intro hx + rw [hx, GenBoundaryState.extendPair_left] at hst + exact absurd hst (by simp) + have hbj : b ≠ j := by + intro hx + rw [hx, GenBoundaryState.extendPair_right hij] at hst + exact absurd hst (by simp) + have hst' : st' ⟨b, hbi, hbj⟩ = Sum.inl y := by + rw [← GenBoundaryState.extendPair_surviving st' (Sum.inr d) + (Sum.inr d) ⟨b, hbi, hbj⟩] + exact hst + exact (congrArg ψ'.val (Subtype.ext (Subtype.ext rfl))).trans + (hG ⟨b, hbi, hbj⟩ y hst') + +/-- The pushed odd colouring's value at a flag of the carried +lift. -/ +noncomputable def oddPushClosedTrueFun {ℓ : ℕ} (d : Fin (2 * ℓ)) + (φ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).EdgeOddColouring ℓ) + (f : {g : V.Flag // g ∈ liftSubsetClosed t true}) : + Fin (2 * ℓ) := + if hfi : f.val = V.boundaryFlag i then d + else if hfj : f.val = V.boundaryFlag j then d + else φ'.val ⟨⟨f.val, hfi, hfj⟩, + (surviving_val_mem_liftClosed_iff t true + ⟨f.val, hfi, hfj⟩).mp f.prop⟩ + +/-- At the first glued boundary flag the pushed odd colouring takes +the circle's colour. -/ +theorem oddPushClosedTrueFun_at_i {ℓ : ℕ} (d : Fin (2 * ℓ)) + (φ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).EdgeOddColouring ℓ) + (hP : V.boundaryFlag i ∈ liftSubsetClosed t true) : + oddPushClosedTrueFun hclosed t hct d φ' ⟨V.boundaryFlag i, hP⟩ + = d := dite_eq_left rfl + +include hij in +/-- At the second it takes the same colour. -/ +theorem oddPushClosedTrueFun_at_j {ℓ : ℕ} (d : Fin (2 * ℓ)) + (φ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).EdgeOddColouring ℓ) + (hP : V.boundaryFlag j ∈ liftSubsetClosed t true) : + oddPushClosedTrueFun hclosed t hct d φ' ⟨V.boundaryFlag j, hP⟩ + = d := by + unfold oddPushClosedTrueFun + rw [dite_eq_right (fun hEq => hij (V.boundaryFlag_injective hEq).symm), + dite_eq_left rfl] + +/-- Away from the two glued flags the pushed odd colouring is +unchanged. -/ +theorem oddPushClosedTrueFun_agrees {ℓ : ℕ} (d : Fin (2 * ℓ)) + (φ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).EdgeOddColouring ℓ) + (g : SurvivingFlag V i j) + (h1 : g.val ∈ liftSubsetClosed t true) (h2 : g ∈ t) : + oddPushClosedTrueFun hclosed t hct d φ' ⟨g.val, h1⟩ + = φ'.val ⟨g, h2⟩ := by + unfold oddPushClosedTrueFun + rw [dite_eq_right g.prop.1, dite_eq_right g.prop.2] + +/-- **Push a glued odd colouring up to the carried lift**, colouring +the closed edge with the join's colour. -/ +noncomputable def oddPushClosedTrue {ℓ : ℕ} (d : Fin (2 * ℓ)) + (φ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).EdgeOddColouring + ℓ) : + (EdgeSubset.mk (liftSubsetClosed t true) hcT : + EdgeSubset V).EdgeOddColouring ℓ := + ⟨oddPushClosedTrueFun hclosed t hct d φ', by + intro f + have hbi := boundaryFlagI_mem_liftClosed_true hij t + have hbj := boundaryFlagJ_mem_liftClosed_true hij t + have hpm : V.pairing f.val ∈ liftSubsetClosed t true := + hcT _ f.prop + by_cases hfi : f.val = V.boundaryFlag i + · have hpv : V.pairing f.val = V.boundaryFlag j := by + rw [hfi]; exact hclosed + have h1 : (⟨V.pairing f.val, hpm⟩ : + {g : V.Flag // g ∈ liftSubsetClosed t true}) + = ⟨V.boundaryFlag j, hbj⟩ := Subtype.ext hpv + have h2 : f = ⟨V.boundaryFlag i, hbi⟩ := Subtype.ext hfi + rw [h1, h2, oddPushClosedTrueFun_at_i hclosed t hct, + oddPushClosedTrueFun_at_j hij hclosed t hct] + · by_cases hfj : f.val = V.boundaryFlag j + · have hpv : V.pairing f.val = V.boundaryFlag i := by + rw [hfj, ← hclosed, V.pairing_invol] + have h1 : (⟨V.pairing f.val, hpm⟩ : + {g : V.Flag // g ∈ liftSubsetClosed t true}) + = ⟨V.boundaryFlag i, hbi⟩ := Subtype.ext hpv + have h2 : f = ⟨V.boundaryFlag j, hbj⟩ := Subtype.ext hfj + rw [h1, h2, oddPushClosedTrueFun_at_i hclosed t hct, + oddPushClosedTrueFun_at_j hij hclosed t hct] + · have hpi' : V.pairing f.val ≠ V.boundaryFlag i := by + intro hx + exact hfj (by rw [← hclosed, ← hx, V.pairing_invol]) + have hpj' : V.pairing f.val ≠ V.boundaryFlag j := by + intro hx + exact hfi (by rw [← V.pairing_invol f.val, hx, ← hclosed, + V.pairing_invol]) + have hgt : (⟨f.val, hfi, hfj⟩ : SurvivingFlag V i j) ∈ t := + (surviving_val_mem_liftClosed_iff t true _).mp f.prop + have hgt' : ((V.gluePairClosed i j hclosed).pairing + ⟨f.val, hfi, hfj⟩) ∈ t := hct _ hgt + have hval : ((V.gluePairClosed i j hclosed).pairing + ⟨f.val, hfi, hfj⟩).val = V.pairing f.val := + gluePairClosed_pairing_val hclosed ⟨f.val, hfi, hfj⟩ + have h1 : (⟨V.pairing f.val, hpm⟩ : + {g : V.Flag // g ∈ liftSubsetClosed t true}) + = ⟨((V.gluePairClosed i j hclosed).pairing + ⟨f.val, hfi, hfj⟩).val, + mem_liftClosed_true_of_mem t hgt'⟩ := + Subtype.ext hval.symm + rw [h1, oddPushClosedTrueFun_agrees hclosed t hct d φ' _ _ + hgt', + oddPushClosedTrueFun_agrees hclosed t hct d φ' + ⟨f.val, hfi, hfj⟩ f.prop hgt] + exact φ'.prop ⟨⟨f.val, hfi, hfj⟩, hgt⟩⟩ + +include hij hclosed hct hcT in +/-- The push is injective. -/ +theorem oddPushClosedTrue_injective {ℓ : ℕ} (d : Fin (2 * ℓ)) : + Function.Injective + (oddPushClosedTrue hij hclosed t hct hcT d) := by + intro φ₁ φ₂ hEq + refine Subtype.ext (funext fun x => ?_) + have h1 : x.val.val ∈ liftSubsetClosed t true := + mem_liftClosed_true_of_mem t x.prop + have hv := congrArg (fun φ : + (EdgeSubset.mk (liftSubsetClosed t true) hcT : + EdgeSubset V).EdgeOddColouring ℓ => φ.val ⟨x.val.val, h1⟩) hEq + simp only [] at hv + have e1 : (oddPushClosedTrue hij hclosed t hct hcT d φ₁).val + ⟨x.val.val, h1⟩ = φ₁.val ⟨x.val, x.prop⟩ := + oddPushClosedTrueFun_agrees hclosed t hct d φ₁ x.val h1 x.prop + have e2 : (oddPushClosedTrue hij hclosed t hct hcT d φ₂).val + ⟨x.val.val, h1⟩ = φ₂.val ⟨x.val, x.prop⟩ := + oddPushClosedTrueFun_agrees hclosed t hct d φ₂ x.val h1 x.prop + rw [e1, e2] at hv + exact hv + +include hij hclosed hct hcT in +/-- **The odd boundary constraint across a closing cut the subset +carries.** -/ +theorem edgeOddBoundaryMatch_closedTrue_iff {k ℓ : ℕ} + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (d : Fin (2 * ℓ)) + (φ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).EdgeOddColouring + ℓ) : + edgeOddBoundaryMatch + (EdgeSubset.mk (liftSubsetClosed t true) hcT) + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d)) + (oddPushClosedTrue hij hclosed t hct hcT d φ') + ↔ edgeOddBoundaryMatch (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)) st' φ' := by + constructor + · intro hW b' c hst hmem + have hstW : GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d) b'.val = Sum.inr c := by + rw [GenBoundaryState.extendPair_surviving] + exact hst + exact (oddPushClosedTrueFun_agrees hclosed t hct d φ' + (glueBoundaryFlag V i j b') _ hmem).symm.trans + (hW b'.val c hstW (mem_liftClosed_true_of_mem t hmem)) + · intro hG b c hst hmem + by_cases hbi : b = i + · subst hbi + have hc : c = d := Sum.inr.inj (hst.symm.trans + (GenBoundaryState.extendPair_left st' (Sum.inr d) + (Sum.inr d))) + rw [hc] + exact oddPushClosedTrueFun_at_i hclosed t hct d φ' hmem + · by_cases hbj : b = j + · subst hbj + have hc : c = d := Sum.inr.inj (hst.symm.trans + (GenBoundaryState.extendPair_right hij st' (Sum.inr d) + (Sum.inr d))) + rw [hc] + exact oddPushClosedTrueFun_at_j hij hclosed t hct d φ' hmem + · have hst' : st' ⟨b, hbi, hbj⟩ = Sum.inr c := by + rw [← GenBoundaryState.extendPair_surviving st' + (Sum.inr d) (Sum.inr d) ⟨b, hbi, hbj⟩] + exact hst + have hmg : glueBoundaryFlag V i j ⟨b, hbi, hbj⟩ ∈ t := + (surviving_val_mem_liftClosed_iff t true _).mp hmem + exact (oddPushClosedTrueFun_agrees hclosed t hct d φ' + (glueBoundaryFlag V i j ⟨b, hbi, hbj⟩) hmem hmg).trans + (hG ⟨b, hbi, hbj⟩ c hst' hmg) + +include hij hclosed hct hcT in +/-- **Every colouring meeting the join's constraint is a push.** -/ +theorem oddPushClosedTrue_covers {k ℓ : ℕ} + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (d : Fin (2 * ℓ)) + (φW : (EdgeSubset.mk (liftSubsetClosed t true) hcT : + EdgeSubset V).EdgeOddColouring ℓ) + (hmatch : edgeOddBoundaryMatch + (EdgeSubset.mk (liftSubsetClosed t true) hcT) + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d)) φW) : + ∃ φ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).EdgeOddColouring + ℓ, + oddPushClosedTrue hij hclosed t hct hcT d φ' = φW := by + have hbi := boundaryFlagI_mem_liftClosed_true hij t + have hbj := boundaryFlagJ_mem_liftClosed_true hij t + have hvi : φW.val ⟨V.boundaryFlag i, hbi⟩ = d := + hmatch i d (GenBoundaryState.extendPair_left st' _ _) hbi + have hvj : φW.val ⟨V.boundaryFlag j, hbj⟩ = d := + hmatch j d (GenBoundaryState.extendPair_right hij st' _ _) hbj + refine ⟨⟨fun g => φW.val ⟨g.val.val, + mem_liftClosed_true_of_mem t g.prop⟩, ?_⟩, ?_⟩ + · intro g + dsimp only [] + have hval : ((V.gluePairClosed i j hclosed).pairing g.val).val + = V.pairing g.val.val := + gluePairClosed_pairing_val hclosed g.val + have hmA : ((V.gluePairClosed i j hclosed).pairing g.val).val + ∈ liftSubsetClosed t true := + mem_liftClosed_true_of_mem t (hct _ g.prop) + have hmC : g.val.val ∈ liftSubsetClosed t true := + mem_liftClosed_true_of_mem t g.prop + have hmB : V.pairing g.val.val ∈ liftSubsetClosed t true := + hcT _ hmC + have h1 : (⟨_, hmA⟩ : + {f : V.Flag // f ∈ liftSubsetClosed t true}) + = ⟨_, hmB⟩ := Subtype.ext hval + rw [h1] + exact φW.prop ⟨g.val.val, hmC⟩ + · refine Subtype.ext (funext fun f => ?_) + change oddPushClosedTrueFun hclosed t hct d _ f = φW.val f + by_cases hfi : f.val = V.boundaryFlag i + · have hfe : f = ⟨V.boundaryFlag i, hbi⟩ := Subtype.ext hfi + rw [hfe] + exact (oddPushClosedTrueFun_at_i hclosed t hct d _ hbi).trans + hvi.symm + · by_cases hfj : f.val = V.boundaryFlag j + · have hfe : f = ⟨V.boundaryFlag j, hbj⟩ := Subtype.ext hfj + rw [hfe] + exact (oddPushClosedTrueFun_at_j hij hclosed t hct d _ + hbj).trans hvj.symm + · have hgt : (⟨f.val, hfi, hfj⟩ : SurvivingFlag V i j) ∈ t := + (surviving_val_mem_liftClosed_iff t true _).mp f.prop + exact oddPushClosedTrueFun_agrees hclosed t hct d _ + ⟨f.val, hfi, hfj⟩ f.prop hgt + +include hij hclosed hct hcT in +open Classical in +/-- **The odd colouring sum is a sum over the glued +colourings.** -/ +theorem sum_odd_closed_true {k ℓ : ℕ} + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (d : Fin (2 * ℓ)) + (G : (EdgeSubset.mk (liftSubsetClosed t true) hcT : + EdgeSubset V).EdgeOddColouring ℓ → ℂ) : + (∑ φW : (EdgeSubset.mk (liftSubsetClosed t true) hcT : + EdgeSubset V).EdgeOddColouring ℓ, + if edgeOddBoundaryMatch + (EdgeSubset.mk (liftSubsetClosed t true) hcT) + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d)) φW then G φW else 0) + = ∑ φ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j + hclosed)).EdgeOddColouring ℓ, + if edgeOddBoundaryMatch + (EdgeSubset.mk (liftSubsetClosed t true) hcT) + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d)) + (oddPushClosedTrue hij hclosed t hct hcT d φ') then + G (oddPushClosedTrue hij hclosed t hct hcT d φ') + else 0 := by + calc (∑ φW : (EdgeSubset.mk (liftSubsetClosed t true) hcT : + EdgeSubset V).EdgeOddColouring ℓ, + if edgeOddBoundaryMatch + (EdgeSubset.mk (liftSubsetClosed t true) hcT) + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d)) φW then G φW else 0) + = ∑ φW ∈ Finset.univ.image + (oddPushClosedTrue hij hclosed t hct hcT d), + (if edgeOddBoundaryMatch + (EdgeSubset.mk (liftSubsetClosed t true) hcT) + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d)) φW then G φW else 0) := by + refine (Finset.sum_subset (Finset.subset_univ _) ?_).symm + intro φW _ hnotim + rw [ite_eq_right (fun hmatch => hnotim ?_)] + obtain ⟨φ', hφ'⟩ := oddPushClosedTrue_covers hij hclosed t + hct hcT st' d φW hmatch + exact Finset.mem_image.mpr ⟨φ', Finset.mem_univ _, hφ'⟩ + _ = _ := Finset.sum_image (fun x _ y _ hxy => + oddPushClosedTrue_injective hij hclosed t hct hcT d hxy) + +section ClosedTrueSum + +variable (κ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).RelTransitionSystem) + (o' : κ'.Orientation) + +include hij hclosed hct hcT in +open Classical in +/-- **A closing cut the subset carries, on RS21's colouring sums.** +The closed edge carries the join's odd colour and nothing else +changes, so each of the `2ℓ` colours reproduces the glued sum. -/ +theorem edgeSum_closedCut_true + [LinearOrder L] + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (d : Fin (2 * ℓ)) + (hbnd' : genBoundarySubsetMatches + (V.gluePairClosed i j hclosed) t st') + (hbndW : genBoundarySubsetMatches V (liftSubsetClosed t true) + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d))) : + (EdgeSubset.mk (liftSubsetClosed t true) hcT : + EdgeSubset V).edgeSum h + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d)) hbndW + (unglueOrientationClosed hclosed true t hct hcT κ' o') + = (EdgeSubset.mk t hct : EdgeSubset + (V.gluePairClosed i j hclosed)).edgeSum h st' hbnd' + o' := by + unfold edgeSum + refine (Fintype.sum_equiv + (evenColourEquivClosedTrue hij hclosed t hct hcT k).symm _ _ + (fun ψ' => ?_)).symm + by_cases hg : genEvenBoundaryMatch (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)) st' hbnd' ψ' + · rw [ite_eq_left hg, ite_eq_left ((genEvenBoundaryMatch_closedTrue_iff hij + hclosed t hct hcT st' d hbndW hbnd' ψ').mpr hg), + sum_odd_closed_true hij hclosed t hct hcT st' d + (fun φW => ∏ v : V.Vertex, + (((EdgeSubset.mk (liftSubsetClosed t true) hcT : + EdgeSubset V).coreOddSignAt + (unglueOrientationClosed hclosed true t hct hcT κ' o') + φW.core v : ℂ) * + h.evalOdd ((EdgeSubset.mk (liftSubsetClosed t true) + hcT : EdgeSubset V).evenColoursAt + ((evenColourEquivClosedTrue hij hclosed t hct hcT + k).symm ψ') v) + ((EdgeSubset.mk (liftSubsetClosed t true) hcT : + EdgeSubset V).coreOddListAt + (unglueOrientationClosed hclosed true t hct hcT κ' + o') φW.core v)))] + refine Finset.sum_congr rfl (fun φ' _ => ?_) + by_cases hp : edgeOddBoundaryMatch (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)) st' φ' + · rw [ite_eq_left hp, ite_eq_left ((edgeOddBoundaryMatch_closedTrue_iff + hij hclosed t hct hcT st' d φ').mpr hp)] + refine Finset.prod_congr rfl (fun v _ => ?_) + exact (vertexFactor_transport_closed hclosed t true hct hcT + κ' o' h + ((evenColourEquivClosedTrue hij hclosed t hct hcT k).symm + ψ') ψ' + (fun g h1 h2 => + congrArg ψ'.val (Subtype.ext (Subtype.ext rfl))) + (oddPushClosedTrue hij hclosed t hct hcT d φ').core + φ'.core + (fun g h1 h2 => oddPushClosedTrueFun_agrees hclosed t hct d + φ' g _ _) v).symm + · rw [ite_eq_right hp, ite_eq_right (fun hx => hp + ((edgeOddBoundaryMatch_closedTrue_iff hij hclosed t hct hcT + st' d φ').mp hx))] + · rw [ite_eq_right hg, ite_eq_right (fun hx => hg + ((genEvenBoundaryMatch_closedTrue_iff hij hclosed t hct hcT + st' d hbndW hbnd' ψ').mp hx))] + +end ClosedTrueSum + +end ClosedTrue + +end ClosedCut + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean new file mode 100644 index 0000000000..102cc2706c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean @@ -0,0 +1,265 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourEmbedding +public import LeanPool.RegtsSevenster.RS.DimensionDefinitions + +/-! +# Padding a mixed model with unused colours + +Extension by zero preserves the colouring sum: embedded colourings +have the original vertex values, and every other colouring has a +zero vertex factor. Equality of superdimensions then preserves the +free-circle factor as well. +-/ + +@[expose] public section + +namespace RS + + + +namespace MixedColourEmbedding + +variable {k ℓ K L : ℕ} + +/-- The induced embedding of even edge colourings. -/ +def evenColouring (e : MixedColourEmbedding k ℓ K L) + {α : Type} {W : Fragment α} (F : EdgeSubset W) : + F.EvenColouring k ↪ F.EvenColouring K where + toFun ψ := ⟨fun a => e.even (ψ.val a), fun a => congrArg e.even (ψ.prop a)⟩ + inj' := by + intro ψ χ h + apply Subtype.ext + funext a + exact e.even.injective (congrArg (fun ψ => ψ.val a) h) + +/-- The induced embedding of odd edge colourings. -/ +def oddColouring (e : MixedColourEmbedding k ℓ K L) + {α : Type} {W : Fragment α} (F : EdgeSubset W) : + F.OddColouring ℓ ↪ F.OddColouring L where + toFun φ := ⟨fun a => e.odd (φ.val a), fun a => congrArg e.odd (φ.prop a)⟩ + inj' := by + intro φ χ h + apply Subtype.ext + funext a + exact e.odd.injective (congrArg (fun φ => φ.val a) h) + +private theorem exists_evenColouring (e : MixedColourEmbedding k ℓ K L) + {W : ClosedFragment} (F : EdgeSubset W) (ψ : F.EvenColouring K) + (hsupport : ∀ a, ψ.val a ∈ Set.range e.even) : + ∃ χ, e.evenColouring F χ = ψ := by + let χ := fun a => Classical.choose (hsupport a) + have hχ : ∀ a, e.even (χ a) = ψ.val a := fun a => + Classical.choose_spec (hsupport a) + refine ⟨⟨χ, ?_⟩, ?_⟩ + · intro a + apply e.even.injective + rw [hχ, hχ, ψ.prop] + · exact Subtype.ext (funext hχ) + +-- The odd lifting is the even lifting with the participating +-- flags as its domain and the odd embedding as its colour map. +private theorem exists_oddColouring (e : MixedColourEmbedding k ℓ K L) + {W : ClosedFragment} (F : EdgeSubset W) (φ : F.OddColouring L) + (hsupport : ∀ a, φ.val a ∈ Set.range e.odd) : + ∃ χ, e.oddColouring F χ = φ := by + let χ := fun a => Classical.choose (hsupport a) + have hχ : ∀ a, e.odd (χ a) = φ.val a := fun a => + Classical.choose_spec (hsupport a) + refine ⟨⟨χ, ?_⟩, ?_⟩ + · intro a + apply e.odd.injective + rw [hχ, hχ, φ.prop] + · exact Subtype.ext (funext hχ) + +/-- Taking the even multiset commutes with embedding colours. -/ +theorem evenColoursAt_map (e : MixedColourEmbedding k ℓ K L) + {α : Type} {W : Fragment α} (F : EdgeSubset W) + (ψ : F.EvenColouring k) (v : W.Vertex) : + F.evenColoursAt (e.evenColouring F ψ) v = + (F.evenColoursAt ψ v).map e.even := by + simp only [EdgeSubset.evenColoursAt, evenColouring, + Multiset.map_map, Function.comp_def] + rfl + +/-- Taking the odd list commutes with embedding colours because +the odd embedding preserves symplectic partners. -/ +theorem oddListAt_map (e : MixedColourEmbedding k ℓ K L) + {α : Type} {W : Fragment α} (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) + (φ : F.OddColouring ℓ) (v : W.Vertex) : + F.oddListAt o (e.oddColouring F φ) v = + (F.oddListAt o φ v).map e.odd := by + unfold EdgeSubset.oddListAt + rw [List.map_flatMap] + congr 1 + funext a + simp only [EdgeSubset.oddPairFn, oddColouring, List.map_cons, e.partner_eq, List.map_nil, + List.cons.injEq, and_true] + exact ⟨rfl, rfl⟩ + +/-- The odd vertex sign is preserved by embedding colours. -/ +theorem oddSignAt_map (e : MixedColourEmbedding k ℓ K L) + {α : Type} {W : Fragment α} (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) + (φ : F.OddColouring ℓ) (v : W.Vertex) : + F.oddSignAt o (e.oddColouring F φ) v = F.oddSignAt o φ v := by + unfold EdgeSubset.oddSignAt + congr 2 + funext a + exact e.sign_eq _ + +private theorem even_support (e : MixedColourEmbedding k ℓ K L) + {W : ClosedFragment} (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) + (h : MixedFunctional k ℓ) + (ψ : F.EvenColouring K) (φ : F.OddColouring L) + (hne : ∏ v : W.Vertex, (F.oddSignAt o φ v : ℂ) * + (h.extendColours e).evalOdd (F.evenColoursAt ψ v) + (F.oddListAt o φ v) ≠ 0) : + ∀ a, ψ.val a ∈ Set.range e.even := by + intro a + by_contra hout + obtain ⟨v, hv⟩ : ∃ v, W.attach a.val = Sum.inl v := by + cases ha : W.attach a.val with + | inl v => exact ⟨v, rfl⟩ + | inr b => exact isEmptyElim b + have hmem : ψ.val a ∈ F.evenColoursAt ψ v := by + unfold EdgeSubset.evenColoursAt + apply Multiset.mem_map.mpr + refine ⟨a, ?_, rfl⟩ + simpa only [Finset.mem_val, Finset.mem_filter, Finset.mem_univ, + true_and] using hv + apply hne + apply Finset.prod_eq_zero (Finset.mem_univ v) + rw [h.evalOdd_extendColours_eq_zero_of_even e _ _ _ hmem hout, + mul_zero] + +private theorem odd_support (e : MixedColourEmbedding k ℓ K L) + {W : ClosedFragment} (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) + (h : MixedFunctional k ℓ) + (ψ : F.EvenColouring K) (φ : F.OddColouring L) + (hne : ∏ v : W.Vertex, (F.oddSignAt o φ v : ℂ) * + (h.extendColours e).evalOdd (F.evenColoursAt ψ v) + (F.oddListAt o φ v) ≠ 0) : + ∀ a, φ.val a ∈ Set.range e.odd := by + intro a + by_contra hout + obtain ⟨v, hv⟩ := κ.attach_internal a.val a.prop + have hzero (c : Fin (2 * L)) (hc : c ∈ F.oddListAt o φ v) + (hcOut : c ∉ Set.range e.odd) : False := by + apply hne + apply Finset.prod_eq_zero (Finset.mem_univ v) + rw [h.evalOdd_extendColours_eq_zero_of_odd e _ _ c hc hcOut, + mul_zero] + by_cases hin : o.isOut a.val = false + · apply hzero (φ.val a) _ hout + apply List.mem_flatMap.mpr + refine ⟨a, ?_, by simp [EdgeSubset.oddPairFn]⟩ + exact (List.mem_attachWith _ _).mpr (mem_inFlagsAt_of a.prop hv hin) + · have houtFlag : o.isOut a.val = true := Bool.eq_true_of_not_eq_false hin + let b : {f : W.Flag // f ∈ F.flags} := + ⟨κ.match_ a.val, κ.match_mem _ a.prop⟩ + have hbin : o.isOut b.val = false := by + simpa [b, houtFlag] using o.match_flip a.val a.prop + have hbv : W.attach b.val = Sum.inl v := κ.match_vertex _ a.prop v hv + apply hzero (oddPartner L (φ.val a)) + · apply List.mem_flatMap.mpr + refine ⟨b, ?_, ?_⟩ + · exact (List.mem_attachWith _ _).mpr + (mem_inFlagsAt_of b.prop hbv hbin) + · have hmatch : (⟨κ.match_ b.val, κ.match_mem _ b.prop⟩ : + {f : W.Flag // f ∈ F.flags}) = a := + Subtype.ext (κ.match_invol _ a.prop) + simp [EdgeSubset.oddPairFn, hmatch] + · rintro ⟨c, hc⟩ + apply hout + refine ⟨oddPartner ℓ c, ?_⟩ + rw [e.partner_eq, hc, oddPartner_invol] + +/-- Extension by zero preserves each closed Eulerian colouring +sum. Colourings using any additional colour have a zero factor. -/ +theorem mixedSummand_extendColours (e : MixedColourEmbedding k ℓ K L) + {W : ClosedFragment} (F : EdgeSubset W) + {κ : F.TransitionSystem} (o : κ.Orientation) + (h : MixedFunctional k ℓ) : + F.mixedSummand (h.extendColours e) o = F.mixedSummand h o := by + let i := (e.evenColouring F).prodMap (e.oddColouring F) + have hsum := Fintype.sum_of_injective i i.injective + (fun p => ∏ v : W.Vertex, (F.oddSignAt o p.2 v : ℂ) * + h.evalOdd (F.evenColoursAt p.1 v) (F.oddListAt o p.2 v)) + (fun p => ∏ v : W.Vertex, (F.oddSignAt o p.2 v : ℂ) * + (h.extendColours e).evalOdd (F.evenColoursAt p.1 v) + (F.oddListAt o p.2 v)) (fun p hout => ?_) (fun p => ?_) + · simpa only [EdgeSubset.mixedSummand, Fintype.sum_prod_type] using + congrArg (fun z => (-1 : ℂ) ^ κ.circuitCount * z) hsum.symm + · by_contra hne + obtain ⟨ψ, hψ⟩ := exists_evenColouring e F p.1 + (even_support e F o h p.1 p.2 hne) + obtain ⟨φ, hφ⟩ := exists_oddColouring e F p.2 + (odd_support e F o h p.1 p.2 hne) + exact hout ⟨(ψ, φ), Prod.ext hψ hφ⟩ + · apply Finset.prod_congr rfl + intro v _ + change _ = (F.oddSignAt o (e.oddColouring F p.2) v : ℂ) * + (h.extendColours e).evalOdd + (F.evenColoursAt (e.evenColouring F p.1) v) + (F.oddListAt o (e.oddColouring F p.2) v) + rw [evenColoursAt_map, oddListAt_map, oddSignAt_map, + h.evalOdd_extendColours_map] + +/-- The chosen Eulerian value is preserved by extension by zero. -/ +theorem mixedValue_extendColours (e : MixedColourEmbedding k ℓ K L) + {W : ClosedFragment} (F : EdgeSubset W) (h : MixedFunctional k ℓ) : + F.mixedValue (h.extendColours e) = F.mixedValue h := by + unfold EdgeSubset.mixedValue + split_ifs + · exact mixedSummand_extendColours e F _ h + · rfl + +/-- Extension by zero preserves the full partition function when +the source and target have the same superdimension. -/ +theorem mixedPartition_extendColours (e : MixedColourEmbedding k ℓ K L) + (h : MixedFunctional k ℓ) + (hbalance : (K : ℂ) - 2 * L = (k : ℂ) - 2 * ℓ) + (W : ClosedFragment) : + mixedPartition (h.extendColours e) W = mixedPartition h W := by + unfold mixedPartition + rw [hbalance] + apply congrArg (fun z : ℂ => ((k : ℂ) - 2 * ℓ) ^ W.circles * z) + apply Finset.sum_congr rfl + intro s _ + split_ifs + · exact mixedValue_extendColours e _ h + · rfl + · rfl + +end MixedColourEmbedding + +/-- Pad a functional with unused even colours and unused +symplectic pairs of odd colours. -/ +noncomputable def MixedFunctional.padColours {k ℓ K L : ℕ} + (h : MixedFunctional k ℓ) (hk : k ≤ K) (hℓ : ℓ ≤ L) : + MixedFunctional K L := + h.extendColours (MixedColourEmbedding.ofLE hk hℓ) + +/-- Padding with equal numbers of unused even and odd colours +preserves the represented parameter, including free circles. -/ +theorem MixedFunctional.padColours_represents {k ℓ K L : ℕ} + (h : MixedFunctional k ℓ) (hk : k ≤ K) (hℓ : ℓ ≤ L) + (hbalance : (K : ℂ) - 2 * L = (k : ℂ) - 2 * ℓ) + {f : ClosedFragment → ℂ} (hrep : h.Represents f) : + (h.padColours hk hℓ).Represents f := by + intro W + rw [hrep W] + exact (MixedColourEmbedding.mixedPartition_extendColours + (MixedColourEmbedding.ofLE hk hℓ) h hbalance W).symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourRecursion.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourRecursion.lean new file mode 100644 index 0000000000..18e1dac499 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourRecursion.lean @@ -0,0 +1,899 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeTerm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CutSubsetSum + +/-! +# Iterating the glue + +RS21's `∗` glues every interface pair at once; `glueInterface` glues +them one at a time, top pair first, relabelling the survivors at each +stage. This file carries RS21's summand along that iteration: the +per-cut identities of `EdgeTerm` are the step, and the transports +below are the bookkeeping the staging needs — the relabel at each +stage and at the base, and the dispatch on whether the stage's cut +closes. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + +open Fragment +/-! ## The base of the iteration + +At an empty interface the composition still relabels, between two +label types that are both empty. +-/ + +/-- The order isomorphism the base stage relabels along. -/ +noncomputable def baseIso : + @OrderIso (Fin (0 + 0) ⊕ Fin (0 + 0)) (Fin 0 ⊕ Fin 0) + (sumLexLE (Fin (0 + 0)) (Fin (0 + 0))) + (sumLexLE (Fin 0) (Fin 0)) where + toEquiv := + Equiv.sumCongr (finCongr (by omega)) (finCongr (by omega)) + map_rel_iff' := by + rintro (x | x) <;> exact absurd x.isLt (by omega) + +/-! ## Transporting a family along an equality of fragments + +The stage's glue dispatches on whether the cut closes, and each +branch is built over its own fragment; the finished family is carried +back across that identification. +-/ + +/-- Transport a set of flags along an equality of fragments. -/ +noncomputable def flagsOfEq {β : Type} (V₁ V₂ : Fragment β) + (hV : V₁ = V₂) (s : Finset V₁.Flag) : Finset V₂.Flag := by + subst hV; exact s + +section DataEq + +variable {β : Type} + +/-- Transport a data family along an equality of fragments. -/ +noncomputable def dataOfEq + [LinearOrder β] {V₁ : Fragment β} {V₂ : Fragment β} (hV : V₁ = V₂) + (𝒟 : DataFamily V₂) : DataFamily V₁ := by + subst hV; exact 𝒟 + +/-- The summand reads the transported family on the transported +subset. -/ +theorem edgeTermAt_dataOfEq + [LinearOrder β] {V₁ : Fragment β} {V₂ : Fragment β} (hV : V₁ = V₂) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (𝒟 : DataFamily V₂) (st : GenBoundaryState k ℓ β) + (s : Finset V₁.Flag) (C : ℕ) : + edgeTermAt h (dataOfEq hV 𝒟) st s C + = edgeTermAt h 𝒟 st (flagsOfEq V₁ V₂ hV s) C := by + subst hV + rfl + +end DataEq + +/-! ## One stage of the iteration + +The stage glues the top interface pair and relabels the survivors. +Its data family therefore comes back in two moves: pull along the +relabel, then unglue. +-/ + +section Step + +/-- The lexicographic order on the stage's label type. -/ +@[reducible] local instance recOrder (n : ℕ) : + LinearOrder (Fin (0 + n) ⊕ Fin (n + 0)) := + sumLexLinearOrder _ _ + +/-- The same order one stage up. -/ +@[reducible] local instance recOrderSucc (n : ℕ) : + LinearOrder (Fin (0 + n + 1) ⊕ Fin (n + 1 + 0)) := + sumLexLinearOrder _ _ + +/-- The order the surviving labels of a stage carry. -/ +@[reducible] local instance recSurvOrder (n : ℕ) : + LinearOrder (SurvivingLabel (Fin (0 + n + 1) ⊕ Fin (n + 1 + 0)) + (cutL n) (cutR n)) := + sumLexSubtypeLinearOrder (Fin (0 + n + 1)) (Fin (n + 1 + 0)) _ + +variable (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + +/-- The stage's family, pulled back along the relabel. -/ +noncomputable def stepDataGlued (𝒟 : DataFamily (stepFragment n V)) : + DataFamily (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) := + relabelDataDown (stepIso n) 𝒟 + +/-- The stage's glue, at a closing cut. -/ +theorem gluePair_eq_closed (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) : + V.gluePairClosed (cutL n) (cutR n) hcl + = V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n) := by + unfold Fragment.gluePair + rw [dite_eq_left hcl] + +/-- The stage's glue, at an open cut. -/ +theorem gluePair_eq_open (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) : + V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop + = V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n) := by + unfold Fragment.gluePair + rw [dite_eq_right hop] + +/-- **One stage of the composition, on the data.** The family is +chosen at the composition and pushed back: along the relabel, then +across the glue. -/ +noncomputable def stepDataDown (𝒟 : DataFamily (stepFragment n V)) : + DataFamily V := + if hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then + unglueDataClosed (cutL_ne_cutR n) hcl + (dataOfEq (gluePair_eq_closed n V hcl) (stepDataGlued n V 𝒟)) + else + unglueDataOpen (cutL_ne_cutR n) hcl + (dataOfEq (gluePair_eq_open n V hcl) (stepDataGlued n V 𝒟)) + +/-- The stage's state, read back through the relabel. -/ +noncomputable def stageState {k ℓ : ℕ} + (stβ : GenBoundaryState k ℓ (Fin (0 + n) ⊕ Fin (n + 0))) : + GenBoundaryState k ℓ + (SurvivingLabel (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0)) + (cutL n) (cutR n)) := + fun a => stβ (stepIso n a) + +open Classical in +/-- **One open stage, with nothing assumed of the subset.** -/ +theorem edgeTermAt_stepOpen_all {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (𝒟 : DataFamily (stepFragment n V)) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (t : Finset (SurvivingFlag V (cutL n) (cutR n))) + (stβ : GenBoundaryState k ℓ (Fin (0 + n) ⊕ Fin (n + 0))) + (C : ℕ) : + (∑ c : Fin k ⊕ Fin (2 * ℓ), + edgeTermAt h (stepDataDown n V 𝒟) + (GenBoundaryState.extendPair (cutL n) (cutR n) + (stageState n stβ) c c) + (liftSubsetOpen hop t) C) + = edgeTermAt h 𝒟 stβ + (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) t) C := by + have hstep : stepDataDown n V 𝒟 + = unglueDataOpen (cutL_ne_cutR n) hop + (dataOfEq (gluePair_eq_open n V hop) + (stepDataGlued n V 𝒟)) := by + unfold stepDataDown + rw [dite_eq_right hop] + rw [hstep, edgeTermAt_openCut_all (cutL_ne_cutR n) hop t h _ + (stageState n stβ) C, + edgeTermAt_dataOfEq (gluePair_eq_open n V hop) h + (stepDataGlued n V 𝒟) (stageState n stβ) t C] + exact (edgeTermAt_relabel (stepIso n) h 𝒟 stβ + (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) t) C).symm + +open Classical in +/-- **The empty branch of a closing stage weighs `k`**, with nothing +assumed of the subset. -/ +theorem edgeTermAt_stepClosed_false_all {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (𝒟 : DataFamily (stepFragment n V)) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (t : Finset (SurvivingFlag V (cutL n) (cutR n))) + (stβ : GenBoundaryState k ℓ (Fin (0 + n) ⊕ Fin (n + 0))) + (C : ℕ) : + (∑ c : Fin k ⊕ Fin (2 * ℓ), + edgeTermAt h (stepDataDown n V 𝒟) + (GenBoundaryState.extendPair (cutL n) (cutR n) + (stageState n stβ) c c) + (liftSubsetClosed t false) C) + = (k : ℂ) * + edgeTermAt h 𝒟 stβ + (flagsOfEq + (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) t) C := by + have hstep : stepDataDown n V 𝒟 + = unglueDataClosed (cutL_ne_cutR n) hcl + (dataOfEq (gluePair_eq_closed n V hcl) + (stepDataGlued n V 𝒟)) := by + unfold stepDataDown + rw [dite_eq_left hcl] + rw [hstep, edgeTermAt_closedCut_false_row_all (cutL_ne_cutR n) hcl + t h _ (stageState n stβ) C, + edgeTermAt_dataOfEq (gluePair_eq_closed n V hcl) h + (stepDataGlued n V 𝒟) (stageState n stβ) t C] + exact congrArg (fun z => (k : ℂ) * z) + (edgeTermAt_relabel (stepIso n) h 𝒟 stβ + (flagsOfEq + (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) t) C).symm + +open Classical in +/-- **The carried branch of a closing stage weighs `−2ℓ`**, with +nothing assumed of the subset. -/ +theorem edgeTermAt_stepClosed_true_all {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (𝒟 : DataFamily (stepFragment n V)) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (t : Finset (SurvivingFlag V (cutL n) (cutR n))) + (stβ : GenBoundaryState k ℓ (Fin (0 + n) ⊕ Fin (n + 0))) + (C : ℕ) : + (∑ c : Fin k ⊕ Fin (2 * ℓ), + edgeTermAt h (stepDataDown n V 𝒟) + (GenBoundaryState.extendPair (cutL n) (cutR n) + (stageState n stβ) c c) + (liftSubsetClosed t true) (C + 1)) + = (-(2 * ℓ : ℕ) : ℂ) * + edgeTermAt h 𝒟 stβ + (flagsOfEq + (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) t) C := by + have hstep : stepDataDown n V 𝒟 + = unglueDataClosed (cutL_ne_cutR n) hcl + (dataOfEq (gluePair_eq_closed n V hcl) + (stepDataGlued n V 𝒟)) := by + unfold stepDataDown + rw [dite_eq_left hcl] + rw [hstep, edgeTermAt_closedCut_true_row_all (cutL_ne_cutR n) hcl + t h _ (stageState n stβ) C, + edgeTermAt_dataOfEq (gluePair_eq_closed n V hcl) h + (stepDataGlued n V 𝒟) (stageState n stβ) t C] + exact congrArg (fun z => (-(2 * ℓ : ℕ) : ℂ) * z) + (edgeTermAt_relabel (stepIso n) h 𝒟 stβ + (flagsOfEq + (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) t) C).symm + +open Classical in +/-- **One closing stage, with nothing assumed of the subset.** -/ +theorem edgeTermAt_stepClosed_all {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (𝒟 : DataFamily (stepFragment n V)) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (t : Finset (SurvivingFlag V (cutL n) (cutR n))) + (stβ : GenBoundaryState k ℓ (Fin (0 + n) ⊕ Fin (n + 0))) + (C : ℕ) : + (∑ c : Fin k ⊕ Fin (2 * ℓ), + edgeTermAt h (stepDataDown n V 𝒟) + (GenBoundaryState.extendPair (cutL n) (cutR n) + (stageState n stβ) c c) + (liftSubsetClosed t false) C) + + (∑ c : Fin k ⊕ Fin (2 * ℓ), + edgeTermAt h (stepDataDown n V 𝒟) + (GenBoundaryState.extendPair (cutL n) (cutR n) + (stageState n stβ) c c) + (liftSubsetClosed t true) (C + 1)) + = ((k : ℂ) - 2 * ℓ) * + edgeTermAt h 𝒟 stβ + (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) t) C := by + have hstep : stepDataDown n V 𝒟 + = unglueDataClosed (cutL_ne_cutR n) hcl + (dataOfEq (gluePair_eq_closed n V hcl) + (stepDataGlued n V 𝒟)) := by + unfold stepDataDown + rw [dite_eq_left hcl] + rw [hstep, edgeTermAt_closedCut_all (cutL_ne_cutR n) hcl t h _ + (stageState n stβ) C, + edgeTermAt_dataOfEq (gluePair_eq_closed n V hcl) h + (stepDataGlued n V 𝒟) (stageState n stβ) t C] + exact congrArg (fun z => ((k : ℂ) - 2 * ℓ) * z) + (edgeTermAt_relabel (stepIso n) h 𝒟 stβ + (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) t) C).symm + +end Step + +/-! ## The iteration + +The family is chosen at the composition and pushed back stage by +stage; the count the base is read at rises by one at each closing cut +whose edge the subset carries, which is the ledger's `glueCount`. +-/ + +section Iterate + +/-- The lexicographic order on the stage's label type. -/ +@[reducible] local instance iterOrder (n : ℕ) : + LinearOrder (Fin (0 + n) ⊕ Fin (n + 0)) := + sumLexLinearOrder _ _ + +/-- The same order one stage up. -/ +@[reducible] local instance iterOrderSucc (n : ℕ) : + LinearOrder (Fin (0 + n + 1) ⊕ Fin (n + 1 + 0)) := + sumLexLinearOrder _ _ + +/-- The order the composition's own (empty) label type carries. -/ +@[reducible] local instance closureOrder : + LinearOrder (Fin 0 ⊕ Fin 0) := + sumLexLinearOrder _ _ + +/-- **The family, pushed back to the base.** A choice at the +composition determines one at every stage, by ungluing. -/ +noncomputable def pushData : (n : ℕ) → + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) → + DataFamily (glueInterface 0 n 0 V) → DataFamily V + | 0, _, 𝒟 => relabelDataDown baseIso 𝒟 + | n + 1, V, 𝒟 => + stepDataDown n V (pushData n (stepFragment n V) 𝒟) + +open Classical in +/-- **The closing cuts a subset carries.** This is the ledger's +`glueCount`, read on the colouring side: the count the base's summand +is taken at rises by one at each of them. -/ +noncomputable def carried : (n : ℕ) → + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) → + Finset V.Flag → ℕ + | 0, _, _ => 0 + | n + 1, V, s => + if hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then + (if V.boundaryFlag (cutL n) ∈ s then 1 else 0) + + carried n (stepFragment n V) + (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) s)) + else + carried n (stepFragment n V) + (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hcl) + (V.dropSubset (cutL n) (cutR n) s)) + +/-- **The diagonal interface state**: both ends of a cut carry the +colour the composition gives it. -/ +noncomputable def diagOf {k ℓ : ℕ} (n : ℕ) + (x : Fin n → (Fin k ⊕ Fin (2 * ℓ))) : + GenBoundaryState k ℓ (Fin (0 + n) ⊕ Fin (n + 0)) := + Sum.elim (fun a => x (Fin.cast (by omega) a)) + (fun b => x (Fin.cast (by omega) b)) + +/-- **The diagonal state, one stage down.** Its top colour is the +stage's cut colour, and the rest is the next stage's diagonal +state. -/ +theorem diagOf_succ {k ℓ : ℕ} (n : ℕ) + (x : Fin (n + 1) → (Fin k ⊕ Fin (2 * ℓ))) : + diagOf (n + 1) x + = GenBoundaryState.extendPair (cutL n) (cutR n) + (stageState n (diagOf n (fun a => x a.castSucc))) + (x (Fin.last n)) (x (Fin.last n)) := by + funext y + by_cases hL : y = cutL n + · subst hL + rw [GenBoundaryState.extendPair_left] + exact congrArg x (Fin.ext (by simp)) + · by_cases hR : y = cutR n + · subst hR + rw [GenBoundaryState.extendPair_right (cutL_ne_cutR n)] + exact congrArg x (Fin.ext (by simp)) + · rw [GenBoundaryState.extendPair_surviving + (st := stageState n (diagOf n (fun a => x a.castSucc))) + (c := x (Fin.last n)) (c' := x (Fin.last n)) + (a := ⟨y, hL, hR⟩)] + change _ = diagOf n (fun a => x a.castSucc) + (interfaceStepEquiv 0 n 0 ⟨y, hL, hR⟩) + rcases y with v | w + · rw [interfaceStepEquiv_apply_inl 0 n 0 v ⟨hL, hR⟩] + refine congrArg x (Fin.ext ?_) + change (v : ℕ) = _ + rw [Fin.val_castSucc, Fin.val_cast] + exact (finRemoveEquiv_top_val (n := 0 + n) + ⟨v, fun he => hL (congrArg Sum.inl he)⟩).symm + · rw [interfaceStepEquiv_apply_inr 0 n 0 w ⟨hL, hR⟩] + refine congrArg x (Fin.ext ?_) + change (w : ℕ) = _ + rw [Fin.val_castSucc, Fin.val_cast, rightRemoveEquiv_val] + have hw : (w : ℕ) ≠ n := fun hx => hR (congrArg Sum.inr + (Fin.ext hx)) + have hlt : (w : ℕ) < n := by omega + rw [ite_eq_left hlt] + +open Classical in +/-- **The carried count at an open stage** is the next stage's. -/ +theorem carried_liftOpen (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (t : Finset (SurvivingFlag V (cutL n) (cutR n))) : + carried (n + 1) V + (liftSubsetOpen hop t) + = carried n (stepFragment n V) + (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) t) := by + change (if hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then _ else _) = _ + rw [dite_eq_right hop] + exact congrArg (fun z => carried n (stepFragment n V) + (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) z)) + (dropSubset_liftSubsetOpen hop t) + +open Classical in +/-- **The carried count at a closing stage** rises by one exactly +when the subset carries the closed edge. -/ +theorem carried_liftClosed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (t : Finset (SurvivingFlag V (cutL n) (cutR n))) (b : Bool) : + carried (n + 1) V (liftSubsetClosed t b) + = (if b = true then 1 else 0) + + carried n (stepFragment n V) + (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) t) := by + change (if hc : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then _ else _) = _ + rw [dite_eq_left hcl] + refine congrArg₂ (· + ·) ?_ ?_ + · exact if_congr + (boundaryFlagI_mem_liftClosed_iff (cutL_ne_cutR n) t b) rfl + rfl + · exact congrArg (fun z => carried n (stepFragment n V) + (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) z)) + (dropSubset_liftSubsetClosed t b) + +/-- The composition's own state: its label type is empty. -/ +noncomputable def emptyState {k ℓ : ℕ} : + GenBoundaryState k ℓ (Fin 0 ⊕ Fin 0) := fun a => isEmptyElim a + +/-- The interface colours, split off the last cut. -/ +def snocEquiv (n : ℕ) (α : Type) : + ((Fin n → α) × α) ≃ (Fin (n + 1) → α) where + toFun p := Fin.snoc p.1 p.2 + invFun x := (fun a => x a.castSucc, x (Fin.last n)) + left_inv p := by + refine Prod.ext (funext fun a => ?_) ?_ <;> simp + right_inv x := by + funext a + refine Fin.lastCases ?_ ?_ a <;> simp + +/-- **The interface colour sum, one cut at a time.** -/ +theorem sum_snoc {n : ℕ} {α : Type} [Fintype α] + (F : (Fin (n + 1) → α) → ℂ) : + (∑ x : Fin (n + 1) → α, F x) + = ∑ y : Fin n → α, ∑ c : α, F (Fin.snoc y c) := by + rw [← Fintype.sum_equiv (snocEquiv n α) (fun p => F (Fin.snoc p.1 p.2)) + F (fun _ => rfl), Fintype.sum_prod_type] + +open Classical in +/-- **The composition's subset a stage's subset maps to.** -/ +noncomputable def imageOf : (n : ℕ) → + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) → + Finset V.Flag → Finset (glueInterface 0 n 0 V).Flag + | 0, _, s => s + | n + 1, V, s => + if hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then + imageOf n (stepFragment n V) + (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) s)) + else + imageOf n (stepFragment n V) + (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hcl) + (V.dropSubset (cutL n) (cutR n) s)) + +open Classical in +/-- The image, one stage down, at an open cut. -/ +theorem imageOf_succ_open (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) (s : Finset V.Flag) : + imageOf (n + 1) V s + = imageOf n (stepFragment n V) + (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) + (V.dropSubset (cutL n) (cutR n) s)) := by + change (if hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then _ else _) = _ + exact dite_eq_right hop + +open Classical in +/-- The image, one stage down, at a closing cut. -/ +theorem imageOf_succ_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) (s : Finset V.Flag) : + imageOf (n + 1) V s + = imageOf n (stepFragment n V) + (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) s)) := by + change (if hc : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then _ else _) = _ + exact dite_eq_left hcl + +/-- Sums over the flags of identified fragments agree. -/ +theorem sum_flagsOfEq {β : Type} {V₁ V₂ : Fragment β} + (hV : V₁ = V₂) (F : Finset V₂.Flag → ℂ) : + (∑ s : Finset V₂.Flag, F s) + = ∑ s : Finset V₁.Flag, F (flagsOfEq V₁ V₂ hV s) := by + subst hV + rfl + +open Classical in +/-- The stage's sum, with the interface colour split off. -/ +theorem stageSum_snoc {k ℓ : ℕ} (h : MixedFunctional k ℓ) (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (𝒟 : DataFamily (stepFragment n V)) (C : ℕ) + (W : Finset V.Flag → ℂ) : + (∑ s : Finset V.Flag, + ∑ x : Fin (n + 1) → (Fin k ⊕ Fin (2 * ℓ)), + W s * edgeTermAt h (stepDataDown n V 𝒟) + (diagOf (n + 1) x) s (C + carried (n + 1) V s)) + = ∑ y : Fin n → (Fin k ⊕ Fin (2 * ℓ)), + ∑ s : Finset V.Flag, ∑ c : Fin k ⊕ Fin (2 * ℓ), + W s * edgeTermAt h (stepDataDown n V 𝒟) + (GenBoundaryState.extendPair (cutL n) (cutR n) + (stageState n (diagOf n y)) c c) s + (C + carried (n + 1) V s) := by + have hs : ∀ s : Finset V.Flag, + (∑ x : Fin (n + 1) → (Fin k ⊕ Fin (2 * ℓ)), + W s * edgeTermAt h (stepDataDown n V 𝒟) + (diagOf (n + 1) x) s (C + carried (n + 1) V s)) + = ∑ y : Fin n → (Fin k ⊕ Fin (2 * ℓ)), + ∑ c : Fin k ⊕ Fin (2 * ℓ), + W s * edgeTermAt h (stepDataDown n V 𝒟) + (GenBoundaryState.extendPair (cutL n) (cutR n) + (stageState n (diagOf n y)) c c) s + (C + carried (n + 1) V s) := by + intro s + rw [sum_snoc] + refine Finset.sum_congr rfl (fun y _ => + Finset.sum_congr rfl (fun c _ => ?_)) + refine congrArg (fun st => W s * edgeTermAt h + (stepDataDown n V 𝒟) st s (C + carried (n + 1) V s)) ?_ + rw [diagOf_succ] + simp + rw [Finset.sum_congr rfl (fun s (_ : s ∈ Finset.univ) => hs s), + Finset.sum_comm] + +open Classical in +/-- **The free circles a subset's own cuts contribute.** At an open +cut, nothing; at a closing cut, `k` if the subset leaves the cut's +edge out and `−2ℓ` if it carries it — the free circle's two sectors, +read one subset at a time. -/ +noncomputable def cutFactor (k ℓ : ℕ) : (n : ℕ) → + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) → + Finset V.Flag → ℂ + | 0, _, _ => 1 + | n + 1, V, s => + if hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then + (if V.boundaryFlag (cutL n) ∈ s then (-(2 * ℓ : ℕ) : ℂ) + else (k : ℂ)) + * cutFactor k ℓ n (stepFragment n V) + (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) s)) + else + cutFactor k ℓ n (stepFragment n V) + (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hcl) + (V.dropSubset (cutL n) (cutR n) s)) + +open Classical in +/-- The factor at an open cut is the next stage's. -/ +theorem cutFactor_liftOpen (k ℓ : ℕ) (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (t : Finset (SurvivingFlag V (cutL n) (cutR n))) : + cutFactor k ℓ (n + 1) V (liftSubsetOpen hop t) + = cutFactor k ℓ n (stepFragment n V) + (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) t) := by + change (if hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then _ else _) = _ + rw [dite_eq_right hop] + exact congrArg (fun z => cutFactor k ℓ n (stepFragment n V) + (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) z)) + (dropSubset_liftSubsetOpen hop t) + +open Classical in +/-- The factor at a closing cut: `k` on the empty branch and `−2ℓ` +on the carried one. -/ +theorem cutFactor_liftClosed (k ℓ : ℕ) (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (t : Finset (SurvivingFlag V (cutL n) (cutR n))) (b : Bool) : + cutFactor k ℓ (n + 1) V (liftSubsetClosed t b) + = (if b = true then (-(2 * ℓ : ℕ) : ℂ) else (k : ℂ)) + * cutFactor k ℓ n (stepFragment n V) + (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) t) := by + change (if hc : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then _ else _) = _ + rw [dite_eq_left hcl] + refine congrArg₂ (· * ·) ?_ ?_ + · exact if_congr + (boundaryFlagI_mem_liftClosed_iff (cutL_ne_cutR n) t b) rfl + rfl + · exact congrArg (fun z => cutFactor k ℓ n (stepFragment n V) + (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) z)) + (dropSubset_liftSubsetClosed t b) + +open Classical in +/-- **A subset's colour sum, one cut at a time.** -/ +theorem sum_colours_snoc {k ℓ : ℕ} (h : MixedFunctional k ℓ) (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (𝒟 : DataFamily (stepFragment n V)) (s : Finset V.Flag) + (C : ℕ) : + (∑ x : Fin (n + 1) → (Fin k ⊕ Fin (2 * ℓ)), + edgeTermAt h (stepDataDown n V 𝒟) (diagOf (n + 1) x) s C) + = ∑ y : Fin n → (Fin k ⊕ Fin (2 * ℓ)), + ∑ c : Fin k ⊕ Fin (2 * ℓ), + edgeTermAt h (stepDataDown n V 𝒟) + (GenBoundaryState.extendPair (cutL n) (cutR n) + (stageState n (diagOf n y)) c c) s C := by + rw [sum_snoc] + refine Finset.sum_congr rfl (fun y _ => + Finset.sum_congr rfl (fun c _ => ?_)) + refine congrArg (fun st => edgeTermAt h + (stepDataDown n V 𝒟) st s C) ?_ + rw [diagOf_succ] + simp only [Fin.snoc_castSucc, Fin.snoc_last] + +open Classical in +/-- **An open stage, summed against a weight on the composition's +subsets.** -/ +theorem stageSum_open {k ℓ : ℕ} (h : MixedFunctional k ℓ) (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (𝒟 : DataFamily (stepFragment n V)) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) (C : ℕ) + (w : Finset (stepFragment n V).Flag → ℂ) : + (∑ s : Finset V.Flag, + ∑ x : Fin (n + 1) → (Fin k ⊕ Fin (2 * ℓ)), + w (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) + (V.dropSubset (cutL n) (cutR n) s)) + * edgeTermAt h (stepDataDown n V 𝒟) (diagOf (n + 1) x) + s (C + carried (n + 1) V s)) + = ∑ t : Finset (stepFragment n V).Flag, + ∑ y : Fin n → (Fin k ⊕ Fin (2 * ℓ)), + w t * edgeTermAt h 𝒟 (diagOf n y) t + (C + carried n (stepFragment n V) t) := by + rw [stageSum_snoc h n V 𝒟 C _, + show (∑ t : Finset (stepFragment n V).Flag, + ∑ y : Fin n → (Fin k ⊕ Fin (2 * ℓ)), + w t * edgeTermAt h 𝒟 (diagOf n y) t + (C + carried n (stepFragment n V) t)) + = ∑ y : Fin n → (Fin k ⊕ Fin (2 * ℓ)), + ∑ t : Finset (stepFragment n V).Flag, + w t * edgeTermAt h 𝒟 (diagOf n y) t + (C + carried n (stepFragment n V) t) + from Finset.sum_comm] + refine Finset.sum_congr rfl (fun y _ => ?_) + rw [sum_split_open (cutL_ne_cutR n) hop + (fun s => ∑ c : Fin k ⊕ Fin (2 * ℓ), + w (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) + (V.dropSubset (cutL n) (cutR n) s)) + * edgeTermAt h (stepDataDown n V 𝒟) + (GenBoundaryState.extendPair (cutL n) (cutR n) + (stageState n (diagOf n y)) c c) s + (C + carried (n + 1) V s)) + (fun s hs => Finset.sum_eq_zero (fun c _ => by + rw [edgeTermAt_eq_zero_of_not_closed h _ _ hs _, mul_zero]))] + refine Eq.trans ?_ (sum_flagsOfEq (gluePair_eq_open n V hop) + (fun t => w t * edgeTermAt h 𝒟 (diagOf n y) t + (C + carried n (stepFragment n V) t))).symm + refine Finset.sum_congr rfl (fun t _ => ?_) + rw [dropSubset_liftSubsetOpen hop t, + carried_liftOpen n V hop t, ← Finset.mul_sum, + edgeTermAt_stepOpen_all n V h 𝒟 hop t (diagOf n y) _] + +open Classical in +/-- **A closing stage, summed against a weight on the composition's +subsets.** -/ +theorem stageSum_closed {k ℓ : ℕ} (h : MixedFunctional k ℓ) (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (𝒟 : DataFamily (stepFragment n V)) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) (C : ℕ) + (w : Finset (stepFragment n V).Flag → ℂ) : + (∑ s : Finset V.Flag, + ∑ x : Fin (n + 1) → (Fin k ⊕ Fin (2 * ℓ)), + w (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) s)) + * edgeTermAt h (stepDataDown n V 𝒟) (diagOf (n + 1) x) + s (C + carried (n + 1) V s)) + = ((k : ℂ) - 2 * ℓ) * + ∑ t : Finset (stepFragment n V).Flag, + ∑ y : Fin n → (Fin k ⊕ Fin (2 * ℓ)), + w t * edgeTermAt h 𝒟 (diagOf n y) t + (C + carried n (stepFragment n V) t) := by + rw [stageSum_snoc h n V 𝒟 C _, + show (∑ t : Finset (stepFragment n V).Flag, + ∑ y : Fin n → (Fin k ⊕ Fin (2 * ℓ)), + w t * edgeTermAt h 𝒟 (diagOf n y) t + (C + carried n (stepFragment n V) t)) + = ∑ y : Fin n → (Fin k ⊕ Fin (2 * ℓ)), + ∑ t : Finset (stepFragment n V).Flag, + w t * edgeTermAt h 𝒟 (diagOf n y) t + (C + carried n (stepFragment n V) t) + from Finset.sum_comm, Finset.mul_sum] + refine Finset.sum_congr rfl (fun y _ => ?_) + rw [sum_split_closed (cutL_ne_cutR n) hcl + (fun s => ∑ c : Fin k ⊕ Fin (2 * ℓ), + w (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) s)) + * edgeTermAt h (stepDataDown n V 𝒟) + (GenBoundaryState.extendPair (cutL n) (cutR n) + (stageState n (diagOf n y)) c c) s + (C + carried (n + 1) V s)) + (fun s hs => Finset.sum_eq_zero (fun c _ => by + rw [edgeTermAt_eq_zero_of_not_closed h _ _ hs _, mul_zero])), + Finset.mul_sum] + refine Eq.trans ?_ (sum_flagsOfEq (gluePair_eq_closed n V hcl) + (fun t => ((k : ℂ) - 2 * ℓ) * + (w t * edgeTermAt h 𝒟 (diagOf n y) t + (C + carried n (stepFragment n V) t)))).symm + refine Finset.sum_congr rfl (fun t _ => ?_) + have hcF := carried_liftClosed n V hcl t false + have hcT := carried_liftClosed n V hcl t true + rw [Fintype.sum_bool, dropSubset_liftSubsetClosed t false, + dropSubset_liftSubsetClosed t true, hcF, hcT] + have hz : (C + ((if (false : Bool) = true then 1 else 0) + + carried n (stepFragment n V) + (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) t))) + = C + carried n (stepFragment n V) + (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) t) := by + simp + have ho : (C + ((if (true : Bool) = true then 1 else 0) + + carried n (stepFragment n V) + (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) t))) + = (C + carried n (stepFragment n V) + (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) t)) + 1 := by + simp + omega + rw [hz, ho, ← Finset.mul_sum, ← Finset.mul_sum, ← mul_add, + add_comm (∑ c : Fin k ⊕ Fin (2 * ℓ), + edgeTermAt h (stepDataDown n V 𝒟) + (GenBoundaryState.extendPair (cutL n) (cutR n) + (stageState n (diagOf n y)) c c) + (liftSubsetClosed t true) _), + edgeTermAt_stepClosed_all n V h 𝒟 hcl t (diagOf n y) _] + ring + +open Classical in +/-- **The composition's summand, stage by stage.** RS21's `∗` glues +the whole interface at once; iterating the per-cut identity carries +the composition's summand back to the two fragments, with the free +circles' `k − 2ℓ` in front and the ledger's count on the base's +side. The weight rides along on the composition's own subsets. -/ +theorem edgeTermAt_glueInterface {k ℓ : ℕ} + (h : MixedFunctional k ℓ) : + ∀ (n : ℕ) (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) + (𝒟 : DataFamily (glueInterface 0 n 0 V)) (C : ℕ) + (w : Finset (glueInterface 0 n 0 V).Flag → ℂ), + ((k : ℂ) - 2 * ℓ) ^ closedCuts n V * + (∑ s' : Finset (glueInterface 0 n 0 V).Flag, + w s' * edgeTermAt h 𝒟 emptyState s' C) + = ∑ s : Finset V.Flag, + ∑ x : Fin n → (Fin k ⊕ Fin (2 * ℓ)), + w (imageOf n V s) * + edgeTermAt h (pushData n V 𝒟) (diagOf n x) s + (C + carried n V s) + | 0, V, 𝒟, C, w => by + have h0 : closedCuts 0 V = 0 := rfl + rw [h0, pow_zero, one_mul] + refine Finset.sum_congr rfl (fun s _ => ?_) + rw [Fintype.sum_unique] + refine congrArg (fun z => w s * z) ?_ + refine Eq.trans (edgeTermAt_relabel baseIso h 𝒟 emptyState s C) + ?_ + exact congrArg + (fun st => edgeTermAt h (relabelDataDown baseIso 𝒟) st s C) + (funext fun a => isEmptyElim a) + | n + 1, V, 𝒟, C, w => by + have ih := edgeTermAt_glueInterface h n (stepFragment n V) 𝒟 C + w + by_cases hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) + · have hcc : closedCuts (n + 1) V + = 1 + closedCuts n (stepFragment n V) := by + change (if V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then 1 else 0) + + closedCuts n (stepFragment n V) = _ + rw [ite_eq_left hcl] + rw [hcc, pow_add, pow_one, mul_assoc] + refine Eq.trans (congrArg (fun z => ((k : ℂ) - 2 * ℓ) * z) + ih) ?_ + refine Eq.trans (stageSum_closed h n V + (pushData n (stepFragment n V) 𝒟) hcl C + (fun t => w (imageOf n (stepFragment n V) t))).symm ?_ + refine Finset.sum_congr rfl (fun s _ => + Finset.sum_congr rfl (fun x _ => ?_)) + exact congrArg (fun z => z * edgeTermAt h + (pushData (n + 1) V 𝒟) (diagOf (n + 1) x) s + (C + carried (n + 1) V s)) + (congrArg w (imageOf_succ_closed n V hcl s).symm) + · have hcc : closedCuts (n + 1) V + = closedCuts n (stepFragment n V) := by + change (if V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then 1 else 0) + + closedCuts n (stepFragment n V) = _ + rw [ite_eq_right hcl, Nat.zero_add] + rw [hcc] + refine Eq.trans ih ?_ + refine Eq.trans (stageSum_open h n V + (pushData n (stepFragment n V) 𝒟) hcl C + (fun t => w (imageOf n (stepFragment n V) t))).symm ?_ + refine Finset.sum_congr rfl (fun s _ => + Finset.sum_congr rfl (fun x _ => ?_)) + exact congrArg (fun z => z * edgeTermAt h + (pushData (n + 1) V 𝒟) (diagOf (n + 1) x) s + (C + carried (n + 1) V s)) + (congrArg w (imageOf_succ_open n V hcl s).symm) + +end Iterate + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeAssoc.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeAssoc.lean new file mode 100644 index 0000000000..1cdd865faf --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeAssoc.lean @@ -0,0 +1,1191 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeNormal + +/-! +# Associativity of composition + +Both associations of a triple composition normalize to iterated +gluing of the two interface pair lists over the common ambient +disjoint union `(F ⊔ G) ⊔ H`, so composition of fragments is +associative up to fragment equivalence (`composeAssoc`). + +This file builds the associativity infrastructure in stages: +the associativity equivalence of disjoint unions, the embedding +of relabellings into disjoint unions, the normalization of each +association, and the final meet in the middle via two-stage +folding and reordering. +-/ + +@[expose] public section + +namespace RS + +namespace Fragment + +variable {α β γ : Type} + +/-- Disjoint union is associative, up to the sum-associativity +relabelling. -/ +noncomputable def disjUnionAssoc (W₁ : Fragment α) + (W₂ : Fragment β) (W₃ : Fragment γ) : + ((W₁.disjUnion W₂).disjUnion W₃).Equiv + ((W₁.disjUnion (W₂.disjUnion W₃)).relabel + (_root_.Equiv.sumAssoc α β γ).symm) where + flagEquiv := _root_.Equiv.sumAssoc W₁.Flag W₂.Flag W₃.Flag + vertexEquiv := _root_.Equiv.sumAssoc W₁.Vertex W₂.Vertex W₃.Vertex + attach_comm f := by + rcases f with (f | f) | f + · change ((W₁.attach f).map Sum.inl Sum.inl).map id + (_root_.Equiv.sumAssoc α β γ).symm = + (((W₁.attach f).map Sum.inl Sum.inl).map Sum.inl + Sum.inl).map + (_root_.Equiv.sumAssoc W₁.Vertex W₂.Vertex W₃.Vertex) id + rcases W₁.attach f with v | ℓ <;> rfl + · change (((W₂.attach f).map Sum.inl Sum.inl).map Sum.inr + Sum.inr).map id (_root_.Equiv.sumAssoc α β γ).symm = + (((W₂.attach f).map Sum.inr Sum.inr).map Sum.inl + Sum.inl).map + (_root_.Equiv.sumAssoc W₁.Vertex W₂.Vertex W₃.Vertex) id + rcases W₂.attach f with v | ℓ <;> rfl + · change (((W₃.attach f).map Sum.inr Sum.inr).map Sum.inr + Sum.inr).map id (_root_.Equiv.sumAssoc α β γ).symm = + ((W₃.attach f).map Sum.inr Sum.inr).map + (_root_.Equiv.sumAssoc W₁.Vertex W₂.Vertex W₃.Vertex) id + rcases W₃.attach f with v | ℓ <;> rfl + pairing_comm f := by + rcases f with (f | f) | f <;> rfl + circles_eq := by + change W₁.circles + W₂.circles + W₃.circles = + W₁.circles + (W₂.circles + W₃.circles) + omega + +/-- Relabelling the left factor of a disjoint union equals +relabelling the whole union by a sum congruence. -/ +noncomputable def relabelDisjUnionLeft {α' : Type} + (W : Fragment α) (W' : Fragment β) (e : α ≃ α') : + ((W.relabel e).disjUnion W').Equiv + ((W.disjUnion W').relabel + (_root_.Equiv.sumCongr e (_root_.Equiv.refl β))) where + flagEquiv := _root_.Equiv.refl _ + vertexEquiv := _root_.Equiv.refl _ + attach_comm f := by + rcases f with f | f + · change ((W.attach f).map Sum.inl Sum.inl).map id + (_root_.Equiv.sumCongr e (_root_.Equiv.refl β)) = + (((W.attach f).map id e).map Sum.inl Sum.inl).map + (_root_.Equiv.refl _) id + rcases W.attach f with v | ℓ <;> rfl + · change ((W'.attach f).map Sum.inr Sum.inr).map id + (_root_.Equiv.sumCongr e (_root_.Equiv.refl β)) = + ((W'.attach f).map Sum.inr Sum.inr).map + (_root_.Equiv.refl _) id + rcases W'.attach f with v | ℓ <;> rfl + pairing_comm f := by rcases f with f | f <;> rfl + circles_eq := rfl + +/-- Relabelling the right factor of a disjoint union equals +relabelling the whole union by a sum congruence. -/ +noncomputable def relabelDisjUnionRight {β' : Type} + (W : Fragment α) (W' : Fragment β) (e : β ≃ β') : + (W.disjUnion (W'.relabel e)).Equiv + ((W.disjUnion W').relabel + (_root_.Equiv.sumCongr (_root_.Equiv.refl α) e)) where + flagEquiv := _root_.Equiv.refl _ + vertexEquiv := _root_.Equiv.refl _ + attach_comm f := by + rcases f with f | f + · change ((W.attach f).map Sum.inl Sum.inl).map id + (_root_.Equiv.sumCongr (_root_.Equiv.refl α) e) = + ((W.attach f).map Sum.inl Sum.inl).map + (_root_.Equiv.refl _) id + rcases W.attach f with v | ℓ <;> rfl + · change ((W'.attach f).map Sum.inr Sum.inr).map id + (_root_.Equiv.sumCongr (_root_.Equiv.refl α) e) = + (((W'.attach f).map id e).map Sum.inr Sum.inr).map + (_root_.Equiv.refl _) id + rcases W'.attach f with v | ℓ <;> rfl + pairing_comm f := by rcases f with f | f <;> rfl + circles_eq := rfl + +/-- Flip a relabelled equivalence to the other side. -/ +noncomputable def Equiv.relabelFlip {W₁ : Fragment α} + {W₂ : Fragment β} {e : β ≃ α} + (E : W₁.Equiv (W₂.relabel e)) : + W₂.Equiv (W₁.relabel e.symm) := + ((((_root_.Equiv.self_trans_symm e ▸ + Equiv.relabelTrans W₂ e e.symm).trans + (Equiv.relabelRefl W₂)).symm).trans + (Equiv.relabelCongr E.symm e.symm)) + +/-- Relabelling by equal equivalences. -/ +noncomputable def Equiv.relabelEq (W : Fragment α) {e e' : α ≃ β} + (h : e = e') : (W.relabel e).Equiv (W.relabel e') := + h ▸ Equiv.refl _ + +end Fragment + +/-! ### The interface pair lists in the common ambient -/ + +/-- The `u`-interface pairs in the common ambient +`(F ⊔ G) ⊔ H`: the high labels of `G` against the low labels of +`H`, top pair first. -/ +def uPairsAssoc (s t u v : ℕ) : + List (((Fin (s + t) ⊕ Fin (t + u)) ⊕ Fin (u + v)) × + ((Fin (s + t) ⊕ Fin (t + u)) ⊕ Fin (u + v))) := + (List.finRange u).reverse.map (fun k => + (Sum.inl (Sum.inr ⟨t + k.val, by have := k.isLt; omega⟩), + Sum.inr ⟨k.val, by have := k.isLt; omega⟩)) + +/-- The `u`-interface pairs are well-formed. -/ +theorem uPairsAssoc_wf (s t u v : ℕ) : + Fragment.PairsWF (uPairsAssoc s t u v) := by + unfold Fragment.PairsWF uPairsAssoc + rw [List.flatMap_map, List.nodup_flatMap] + refine ⟨fun k _ => by simp, ?_⟩ + rw [List.pairwise_reverse] + refine (List.nodup_finRange u).pairwise_of_forall_ne ?_ + intro k _ m _ hkm x hxm hxk + simp only [List.mem_cons, List.not_mem_nil, or_false] at hxm hxk + rcases hxm with rfl | rfl <;> rcases hxk with h | h + · rw [Sum.inl.injEq, Sum.inr.injEq, Fin.mk.injEq] at h + exact hkm (Fin.ext (by omega)).symm + · exact Sum.inl_ne_inr h + · exact Sum.inr_ne_inl h + · rw [Sum.inr.injEq, Fin.mk.injEq] at h + exact hkm (Fin.ext (by omega)).symm + +/-- Membership in the `u`-interface pairs. -/ +theorem mem_uPairsAssoc (s t u v : ℕ) (p) : + p ∈ uPairsAssoc s t u v ↔ + ∃ k : Fin u, + p = (Sum.inl (Sum.inr ⟨t + k.val, by have := k.isLt; omega⟩), + Sum.inr ⟨k.val, by have := k.isLt; omega⟩) := by + unfold uPairsAssoc + simp only [List.mem_map, List.mem_reverse, List.mem_finRange, + true_and] + exact ⟨fun ⟨k, hk⟩ => ⟨k, hk.symm⟩, fun ⟨k, hk⟩ => ⟨k, hk.symm⟩⟩ + +/-- The `t`-interface pairs in the common ambient, as a direct +index map. -/ +def tPairsAssoc (s t u v : ℕ) : + List (((Fin (s + t) ⊕ Fin (t + u)) ⊕ Fin (u + v)) × + ((Fin (s + t) ⊕ Fin (t + u)) ⊕ Fin (u + v))) := + (List.finRange t).reverse.map (fun k => + (Sum.inl (Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩), + Sum.inl (Sum.inr ⟨k.val, by have := k.isLt; omega⟩))) + +/-- The direct `t`-interface pairs are the embedded interface +pairs. -/ +theorem tPairsAssoc_eq (s t u v : ℕ) : + tPairsAssoc s t u v = + Fragment.inlPairs (β := Fin (u + v)) + (interfacePairs s t u) := by + unfold tPairsAssoc Fragment.inlPairs interfacePairs + rw [List.map_map] + rfl + +/-- Membership in the direct `t`-interface pairs. -/ +theorem mem_tPairsAssoc' (s t u v : ℕ) (p) : + p ∈ tPairsAssoc s t u v ↔ + ∃ k : Fin t, + p = (Sum.inl (Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩), + Sum.inl (Sum.inr ⟨k.val, by have := k.isLt; omega⟩)) := by + unfold tPairsAssoc + simp only [List.mem_map, List.mem_reverse, List.mem_finRange, + true_and] + exact ⟨fun ⟨k, hk⟩ => ⟨k, hk.symm⟩, fun ⟨k, hk⟩ => ⟨k, hk.symm⟩⟩ + +/-- Membership in the embedded `t`-interface pairs. -/ +theorem mem_tPairsAssoc (s t u v : ℕ) (p) : + p ∈ Fragment.inlPairs (β := Fin (u + v)) + (interfacePairs s t u) ↔ + ∃ k : Fin t, + p = (Sum.inl (Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩), + Sum.inl (Sum.inr ⟨k.val, by have := k.isLt; omega⟩)) := by + unfold Fragment.inlPairs interfacePairs + simp only [List.map_map, List.mem_map, List.mem_reverse, + List.mem_finRange, true_and, Function.comp] + constructor + · rintro ⟨k, rfl⟩ + exact ⟨k, rfl⟩ + · rintro ⟨k, rfl⟩ + exact ⟨k, rfl⟩ + +/-- Membership in the interface pairs. -/ +theorem mem_interfacePairs (s t u : ℕ) (p) : + p ∈ interfacePairs s t u ↔ + ∃ k : Fin t, + p = (Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩, + Sum.inr ⟨k.val, by have := k.isLt; omega⟩) := by + unfold interfacePairs + simp only [List.mem_map, List.mem_reverse, List.mem_finRange, + true_and] + exact ⟨fun ⟨k, hk⟩ => ⟨k, hk.symm⟩, fun ⟨k, hk⟩ => ⟨k, hk.symm⟩⟩ + +/-- `mapPairs` composes. -/ +theorem mapPairs_mapPairs {α β γ : Type} (e : α ≃ β) (e' : β ≃ γ) : + ∀ ps, Fragment.mapPairs e' (Fragment.mapPairs e ps) = + Fragment.mapPairs (e.trans e') ps + | [] => rfl + | p :: ps => by + obtain ⟨a, b⟩ := p + exact congrArg₂ List.cons rfl (mapPairs_mapPairs e e' ps) + +/-- High `G`-labels survive the `t`-interface gluing. -/ +theorem highG_surv (s t u : ℕ) (b : Fin (t + u)) (hb : t ≤ b.val) : + ∀ p ∈ interfacePairs s t u, + (Sum.inr b : Fin (s + t) ⊕ Fin (t + u)) ≠ p.1 ∧ + Sum.inr b ≠ p.2 := by + intro p hp + obtain ⟨k, rfl⟩ := (mem_interfacePairs s t u p).mp hp + have hk := k.isLt + refine ⟨Sum.inr_ne_inl, fun h => ?_⟩ + have h2 : b.val = k.val := congrArg Fin.val (Sum.inr.inj h) + omega + +/-- Low `F`-labels survive the `t`-interface gluing. -/ +theorem lowF_surv (s t u : ℕ) (a : Fin (s + t)) (ha : a.val < s) : + ∀ p ∈ interfacePairs s t u, + (Sum.inl a : Fin (s + t) ⊕ Fin (t + u)) ≠ p.1 ∧ + Sum.inl a ≠ p.2 := by + intro p hp + obtain ⟨k, rfl⟩ := (mem_interfacePairs s t u p).mp hp + have hk := k.isLt + refine ⟨fun h => ?_, Sum.inl_ne_inr⟩ + have h2 : a.val = s + k.val := congrArg Fin.val (Sum.inl.inj h) + omega + +/-- The inverse boundary identification sends high output labels +to high `G`-labels. -/ +theorem interfaceEquiv_symm_high (s t u : ℕ) (k : ℕ) (_hk : k < u) + (h1 : s + k < s + u) (h2 : t + k < t + u) : + ((((interfaceSurvEquiv s t u).trans finSumFinEquiv).symm + ⟨s + k, h1⟩) : + Fragment.FoldSurviving (Fin (s + t) ⊕ Fin (t + u)) + (interfacePairs s t u)).val = + Sum.inr (⟨t + k, h2⟩ : Fin (t + u)) := by + have hsurv := highG_surv s t u ⟨t + k, h2⟩ + (by change t ≤ t + k; omega) + have hy : ((interfaceSurvEquiv s t u).trans finSumFinEquiv) + (⟨Sum.inr ⟨t + k, h2⟩, hsurv⟩ : + Fragment.FoldSurviving (Fin (s + t) ⊕ Fin (t + u)) + (interfacePairs s t u)) = ⟨s + k, h1⟩ := by + have h3 := congrArg finSumFinEquiv + (interfaceSurvEquiv_inr s t u + (⟨Sum.inr ⟨t + k, h2⟩, hsurv⟩ : + Fragment.FoldSurviving (Fin (s + t) ⊕ Fin (t + u)) + (interfacePairs s t u)) + ⟨t + k, h2⟩ rfl (by change t ≤ t + k; omega)) + rw [finSumFinEquiv_apply_right] at h3 + exact h3.trans (Fin.ext (by change s + (t + k - t) = s + k; omega)) + exact congrArg Subtype.val + ((_root_.Equiv.symm_apply_eq _).mpr hy.symm) + +/-- The inverse boundary identification sends low output labels +to low `F`-labels. -/ +theorem interfaceEquiv_symm_low (s t u : ℕ) (k : ℕ) (hk : k < s) + (h1 : k < s + u) (h2 : k < s + t) : + ((((interfaceSurvEquiv s t u).trans finSumFinEquiv).symm + ⟨k, h1⟩) : + Fragment.FoldSurviving (Fin (s + t) ⊕ Fin (t + u)) + (interfacePairs s t u)).val = + Sum.inl (⟨k, h2⟩ : Fin (s + t)) := by + have hsurv := lowF_surv s t u ⟨k, h2⟩ hk + have hy : ((interfaceSurvEquiv s t u).trans finSumFinEquiv) + (⟨Sum.inl ⟨k, h2⟩, hsurv⟩ : + Fragment.FoldSurviving (Fin (s + t) ⊕ Fin (t + u)) + (interfacePairs s t u)) = ⟨k, h1⟩ := by + have h3 := congrArg finSumFinEquiv + (interfaceSurvEquiv_inl s t u + (⟨Sum.inl ⟨k, h2⟩, hsurv⟩ : + Fragment.FoldSurviving (Fin (s + t) ⊕ Fin (t + u)) + (interfacePairs s t u)) + ⟨k, h2⟩ rfl hk) + rw [finSumFinEquiv_apply_left] at h3 + exact h3.trans (Fin.ext rfl) + exact congrArg Subtype.val + ((_root_.Equiv.symm_apply_eq _).mpr hy.symm) + +namespace Fragment + +/-- Value of the left-embedding fold equivalence's inverse on an +embedded survivor. -/ +theorem inlFoldEquiv_symm_inl_val {α β : Type} (ps : List (α × α)) + (x : FoldSurviving α ps) : + ((inlFoldEquiv (β := β) ps).symm (Sum.inl x)).val = + Sum.inl x.val := by + obtain ⟨a, ha⟩ := x + rfl + +/-- Value of the left-embedding fold equivalence's inverse on a +right label. -/ +theorem inlFoldEquiv_symm_inr_val {α β : Type} (ps : List (α × α)) + (b : β) : + ((inlFoldEquiv (β := β) ps).symm (Sum.inr b)).val = + Sum.inr b := rfl + +/-- Value of the right-embedding fold equivalence's inverse on an +embedded survivor. -/ +theorem inrFoldEquiv_symm_inr_val {α β : Type} (qs : List (β × β)) + (x : FoldSurviving β qs) : + ((inrFoldEquiv (α := α) qs).symm (Sum.inr x)).val = + Sum.inr x.val := by + obtain ⟨b, hb⟩ := x + rfl + +/-- Value of the right-embedding fold equivalence's inverse on a +left label. -/ +theorem inrFoldEquiv_symm_inl_val {α β : Type} (qs : List (β × β)) + (a : α) : + ((inrFoldEquiv (α := α) qs).symm (Sum.inl a)).val = + Sum.inl a := rfl + +end Fragment + +/-- The mapped-back outer interface pairs of the left association +are the lifted `u`-interface pairs (generalized over the index +list). -/ +private theorem lhs_lift_eq_aux (s t u v : ℕ) : + ∀ (l : List (Fin u)) + (hsep : Fragment.PairsSepAll + (Fragment.inlPairs (β := Fin (u + v)) (interfacePairs s t u)) + (l.map (fun k => + (Sum.inl (Sum.inr ⟨t + k.val, by have := k.isLt; omega⟩), + Sum.inr ⟨k.val, by have := k.isLt; omega⟩)))), + Fragment.mapPairs + ((_root_.Equiv.sumCongr + ((interfaceSurvEquiv s t u).trans finSumFinEquiv) + (_root_.Equiv.refl (Fin (u + v)))).symm.trans + (Fragment.inlFoldEquiv (β := Fin (u + v)) + (interfacePairs s t u)).symm) + (l.map (fun k => + ((Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩ : + Fin (s + u) ⊕ Fin (u + v)), + Sum.inr ⟨k.val, by have := k.isLt; omega⟩))) = + Fragment.liftPairs _ _ hsep + | [], _ => rfl + | k :: l, hsep => by + simp only [List.map_cons, Fragment.mapPairs, + Fragment.liftPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext ?_ ?_) + (lhs_lift_eq_aux s t u v l _) + · refine Subtype.ext ?_ + exact (Fragment.inlFoldEquiv_symm_inl_val + (interfacePairs s t u) _).trans + (congrArg Sum.inl + (interfaceEquiv_symm_high s t u k.val k.isLt + (by have := k.isLt; omega) + (by have := k.isLt; omega))) + · refine Subtype.ext ?_ + exact Fragment.inlFoldEquiv_symm_inr_val + (interfacePairs s t u) _ + +/-- The mapped-back outer interface pairs of the left association +are the lifted `u`-interface pairs. -/ +theorem lhs_pairs_eq (s t u v : ℕ) + (hsep : Fragment.PairsSepAll + (Fragment.inlPairs (β := Fin (u + v)) (interfacePairs s t u)) + (uPairsAssoc s t u v)) : + Fragment.mapPairs + (Fragment.inlFoldEquiv (β := Fin (u + v)) + (interfacePairs s t u)).symm + (Fragment.mapPairs + (_root_.Equiv.sumCongr + ((interfaceSurvEquiv s t u).trans finSumFinEquiv) + (_root_.Equiv.refl (Fin (u + v)))).symm + (interfacePairs s u v)) = + Fragment.liftPairs _ _ hsep := by + rw [mapPairs_mapPairs] + exact lhs_lift_eq_aux s t u v (List.finRange u).reverse hsep + +/-- The combined pair list is well-formed. -/ +theorem assocPairs_wf (s t u v : ℕ) : + Fragment.PairsWF + (Fragment.inlPairs (β := Fin (u + v)) (interfacePairs s t u) ++ + uPairsAssoc s t u v) := by + unfold Fragment.PairsWF + rw [List.flatMap_append] + refine List.Nodup.append + (Fragment.inlPairs_wf _ (interfacePairs_wf s t u)) + (uPairsAssoc_wf s t u v) ?_ + intro x hx hy + obtain ⟨p, hp, hxp⟩ := List.mem_flatMap.mp hx + obtain ⟨q, hq, hyq⟩ := List.mem_flatMap.mp hy + obtain ⟨j, rfl⟩ := (mem_tPairsAssoc s t u v p).mp hp + obtain ⟨k, rfl⟩ := (mem_uPairsAssoc s t u v q).mp hq + simp only [List.mem_cons, List.not_mem_nil, or_false] at hxp hyq + have hj := j.isLt + have hk := k.isLt + rcases hxp with rfl | rfl <;> rcases hyq with h | h <;> + (simp only [Sum.inl.injEq, Sum.inr.injEq, Fin.mk.injEq, + reduceCtorEq] at h <;> omega) + +namespace Fragment + +variable {α β : Type} + +/-- Flip a relabelled equivalence to the other side, relabelled +form on the left. -/ +noncomputable def Equiv.relabelFlip' {W₁ : Fragment α} + {W₂ : Fragment β} {e : α ≃ β} + (E : (W₁.relabel e).Equiv W₂) : + W₁.Equiv (W₂.relabel e.symm) := + Equiv.relabelFlip E.symm + +/-- Iterated gluing does not depend on the well-formedness +proof. -/ +noncomputable def glueListProofIrrel (W : Fragment α) + (ps : List (α × α)) (h1 h2 : PairsWF ps) : + (glueList W ps h1).Equiv (glueList W ps h2) := + Equiv.refl (glueList W ps h1) + +end Fragment + +/-- Pull gluing pairs through a relabelling and compose a normalized inner fold. -/ +noncomputable def glueListPullRelabelTrans {α β γ : Type} (W : Fragment α) + (σ : α ≃ β) (ps : List (β × β)) (hp : Fragment.PairsWF ps) + {V : Fragment γ} + {τ : γ ≃ Fragment.FoldSurviving α (Fragment.mapPairs σ.symm ps)} + (e : (Fragment.glueList W (Fragment.mapPairs σ.symm ps) + (Fragment.mapPairs_wf σ.symm ps hp)).Equiv (V.relabel τ)) := + (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (W.relabel σ) (mapPairs_symm_cancel σ ps).symm + hp (Fragment.mapPairs_wf σ _ (Fragment.mapPairs_wf σ.symm ps hp)) + ((mapPairs_symm_cancel σ ps).symm ▸ List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.glueListRelabel W σ (Fragment.mapPairs σ.symm ps) + (Fragment.mapPairs_wf σ.symm ps hp)).trans + ((Fragment.Equiv.relabelCongr e + (Fragment.foldSurvivingMapEquiv σ (Fragment.mapPairs σ.symm ps))).trans + (Fragment.Equiv.relabelTrans _ _ _))) + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel σ ps).symm ▸ List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + +/-- Transport the two closure casts across a normalized right-hand fragment. -/ +noncomputable def pairCloseAmbientEquiv {n : ℕ} (F G : Fragment (Fin n)) + {α : Type} {N : Fragment α} {e : α ≃ Fin n} (E : G.Equiv (N.relabel e)) := + (Fragment.relabelDisjUnionLeft F + (G.relabel (finCongr (by omega : n = n + 0))) + (finCongr (by omega : n = 0 + n))).trans + ((Fragment.Equiv.relabelCongr + (Fragment.relabelDisjUnionRight F G (finCongr (by omega : n = n + 0))) + (_root_.Equiv.sumCongr (finCongr (by omega : n = 0 + n)) + (_root_.Equiv.refl _))).trans + ((Fragment.Equiv.relabelTrans _ _ _).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.Equiv.disjUnionCongr (Fragment.Equiv.refl F) E).trans + (Fragment.relabelDisjUnionRight F N e)) + ((_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin n)) + (finCongr (by omega : n = n + 0))).trans + (_root_.Equiv.sumCongr (finCongr (by omega : n = 0 + n)) + (_root_.Equiv.refl _)))).trans + (Fragment.Equiv.relabelTrans _ _ _)))) + +/-! ### The left association, normalized -/ + +/-- The composed label identification of the left association: +flatten the two-stage survivors, pass through the embedded and +relabelled fold equivalences, and read off the outer boundary +identification. -/ +noncomputable def lhsLabelEquiv (s t u v : ℕ) : + Fragment.FoldSurviving + ((Fin (s + t) ⊕ Fin (t + u)) ⊕ Fin (u + v)) + (Fragment.inlPairs (interfacePairs s t u) ++ + uPairsAssoc s t u v) ≃ + Fin (s + v) := + ((Fragment.appendFlatten _ _ + ((assocPairs_wf s t u v).append_sep)).symm.trans + ((Fragment.foldSurvivingPermEquiv + ((lhs_pairs_eq s t u v + ((assocPairs_wf s t u v).append_sep)) ▸ + List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv + (Fragment.inlFoldEquiv (β := Fin (u + v)) + (interfacePairs s t u)) + (Fragment.mapPairs + (Fragment.inlFoldEquiv (β := Fin (u + v)) + (interfacePairs s t u)).symm + (Fragment.mapPairs + (_root_.Equiv.sumCongr + ((interfaceSurvEquiv s t u).trans finSumFinEquiv) + (_root_.Equiv.refl (Fin (u + v)))).symm + (interfacePairs s u v)))).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel + (Fragment.inlFoldEquiv (β := Fin (u + v)) + (interfacePairs s t u)) + (Fragment.mapPairs + (_root_.Equiv.sumCongr + ((interfaceSurvEquiv s t u).trans finSumFinEquiv) + (_root_.Equiv.refl (Fin (u + v)))).symm + (interfacePairs s u v))).symm ▸ + List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv + (_root_.Equiv.sumCongr + ((interfaceSurvEquiv s t u).trans finSumFinEquiv) + (_root_.Equiv.refl (Fin (u + v)))) + (Fragment.mapPairs + (_root_.Equiv.sumCongr + ((interfaceSurvEquiv s t u).trans finSumFinEquiv) + (_root_.Equiv.refl (Fin (u + v)))).symm + (interfacePairs s u v))).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel + (_root_.Equiv.sumCongr + ((interfaceSurvEquiv s t u).trans + finSumFinEquiv) + (_root_.Equiv.refl (Fin (u + v)))) + (interfacePairs s u v)).symm ▸ + List.Perm.refl _)).symm.trans + ((interfaceSurvEquiv s u v).trans + finSumFinEquiv))))))) + +/-- The swapped combined pair list is well-formed. -/ +theorem assocPairsR_wf (s t u v : ℕ) : + Fragment.PairsWF + (uPairsAssoc s t u v ++ tPairsAssoc s t u v) := by + unfold Fragment.PairsWF + rw [List.flatMap_append] + refine List.Nodup.append (uPairsAssoc_wf s t u v) + (tPairsAssoc_eq s t u v ▸ + Fragment.inlPairs_wf _ (interfacePairs_wf s t u)) ?_ + intro x hx hy + obtain ⟨p, hp, hxp⟩ := List.mem_flatMap.mp hx + obtain ⟨q, hq, hyq⟩ := List.mem_flatMap.mp hy + obtain ⟨k, rfl⟩ := (mem_uPairsAssoc s t u v p).mp hp + obtain ⟨j, rfl⟩ := (mem_tPairsAssoc' s t u v q).mp hq + simp only [List.mem_cons, List.not_mem_nil, or_false] at hxp hyq + have hj := j.isLt + have hk := k.isLt + rcases hxp with rfl | rfl <;> rcases hyq with h | h <;> + (simp only [Sum.inl.injEq, Sum.inr.injEq, Fin.mk.injEq, + reduceCtorEq] at h <;> omega) + +/-- The associativity-transported right-embedded `u`-interface +pairs are the ambient `u`-interface pairs (generalized over the +index list). -/ +private theorem rhs_ground_eq_aux (s t u v : ℕ) : + ∀ (l : List (Fin u)), + Fragment.mapPairs + ((_root_.Equiv.sumAssoc (Fin (s + t)) (Fin (t + u)) + (Fin (u + v))).symm.symm).symm + ((l.map (fun k => + ((Sum.inl ⟨t + k.val, by have := k.isLt; omega⟩ : + Fin (t + u) ⊕ Fin (u + v)), + Sum.inr ⟨k.val, by have := k.isLt; omega⟩))).map + (Prod.map Sum.inr Sum.inr)) = + l.map (fun k => + (Sum.inl (Sum.inr ⟨t + k.val, by have := k.isLt; omega⟩), + Sum.inr ⟨k.val, by have := k.isLt; omega⟩)) + | [] => rfl + | k :: l => by + simp only [List.map_cons, Fragment.mapPairs, Prod.map] + exact congrArg₂ List.cons rfl (rhs_ground_eq_aux s t u v l) + +/-- The associativity-transported right-embedded `u`-interface +pairs are the ambient `u`-interface pairs. -/ +theorem rhs_ground_eq (s t u v : ℕ) : + Fragment.mapPairs + ((_root_.Equiv.sumAssoc (Fin (s + t)) (Fin (t + u)) + (Fin (u + v))).symm.symm).symm + (Fragment.inrPairs (α := Fin (s + t)) + (interfacePairs t u v)) = + uPairsAssoc s t u v := + rhs_ground_eq_aux s t u v (List.finRange u).reverse + +/-- The associativity bridge: survivors of the ambient +`u`-interface pairs are survivors of the right-embedded pairs in +the right-associated ambient. -/ +noncomputable def rhsBridgeEquiv (s t u v : ℕ) : + Fragment.FoldSurviving + ((Fin (s + t) ⊕ Fin (t + u)) ⊕ Fin (u + v)) + (uPairsAssoc s t u v) ≃ + Fragment.FoldSurviving + (Fin (s + t) ⊕ (Fin (t + u) ⊕ Fin (u + v))) + (Fragment.inrPairs (α := Fin (s + t)) + (interfacePairs t u v)) := + (Fragment.foldSurvivingPermEquiv + ((rhs_ground_eq s t u v) ▸ List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv + ((_root_.Equiv.sumAssoc (Fin (s + t)) (Fin (t + u)) + (Fin (u + v))).symm.symm) + (Fragment.mapPairs + ((_root_.Equiv.sumAssoc (Fin (s + t)) (Fin (t + u)) + (Fin (u + v))).symm.symm).symm + (Fragment.inrPairs (α := Fin (s + t)) + (interfacePairs t u v)))).trans + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel + ((_root_.Equiv.sumAssoc (Fin (s + t)) (Fin (t + u)) + (Fin (u + v))).symm.symm) + (Fragment.inrPairs (α := Fin (s + t)) + (interfacePairs t u v))).symm ▸ + List.Perm.refl _)).symm) + +/-- The lifted `t`-interface identification, generalized over any +transport with the expected boundary values. -/ +private theorem rhs_lift_eq_aux (s t u v : ℕ) + (E : (Fin (s + t) ⊕ Fin (t + v)) ≃ + Fragment.FoldSurviving + ((Fin (s + t) ⊕ Fin (t + u)) ⊕ Fin (u + v)) + (uPairsAssoc s t u v)) + (hEl : ∀ a : Fin (s + t), + (E (Sum.inl a)).val = Sum.inl (Sum.inl a)) + (hEr : ∀ (k : ℕ) (_hk : k < t) (h1 : k < t + v) + (h2 : k < t + u), + (E (Sum.inr ⟨k, h1⟩)).val = Sum.inl (Sum.inr ⟨k, h2⟩)) : + ∀ (l : List (Fin t)) + (hsep : Fragment.PairsSepAll (uPairsAssoc s t u v) + (l.map (fun k => + (Sum.inl (Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩), + Sum.inl (Sum.inr + ⟨k.val, by have := k.isLt; omega⟩))))), + Fragment.mapPairs E + (l.map (fun k => + ((Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩ : + Fin (s + t) ⊕ Fin (t + v)), + Sum.inr ⟨k.val, by have := k.isLt; omega⟩))) = + Fragment.liftPairs _ _ hsep + | [], _ => rfl + | k :: l, hsep => by + simp only [List.map_cons, Fragment.mapPairs, + Fragment.liftPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext ?_ ?_) + (rhs_lift_eq_aux s t u v E hEl hEr l _) + · exact Subtype.ext (hEl ⟨s + k.val, by have := k.isLt; omega⟩) + · exact Subtype.ext (hEr k.val k.isLt + (by have := k.isLt; omega) (by have := k.isLt; omega)) + +/-- The mapped-back outer interface pairs of the right +association are the lifted `t`-interface pairs. -/ +theorem rhs_pairs_eq (s t u v : ℕ) + (hsep : Fragment.PairsSepAll (uPairsAssoc s t u v) + (tPairsAssoc s t u v)) : + Fragment.mapPairs (rhsBridgeEquiv s t u v).symm + (Fragment.mapPairs + (Fragment.inrFoldEquiv (α := Fin (s + t)) + (interfacePairs t u v)).symm + (Fragment.mapPairs + (_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (s + t))) + ((interfaceSurvEquiv t u v).trans + finSumFinEquiv)).symm + (interfacePairs s t v))) = + Fragment.liftPairs _ _ hsep := by + rw [mapPairs_mapPairs, mapPairs_mapPairs] + refine rhs_lift_eq_aux s t u v + ((_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (s + t))) + ((interfaceSurvEquiv t u v).trans finSumFinEquiv)).symm.trans + ((Fragment.inrFoldEquiv (α := Fin (s + t)) + (interfacePairs t u v)).symm.trans + (rhsBridgeEquiv s t u v).symm)) + (fun a => rfl) + (fun k hk h1 h2 => ?_) (List.finRange t).reverse hsep + exact congrArg + (fun z => ((_root_.Equiv.sumAssoc (Fin (s + t)) (Fin (t + u)) + (Fin (u + v))).symm.symm).symm z) + ((Fragment.inrFoldEquiv_symm_inr_val (interfacePairs t u v) + (((interfaceSurvEquiv t u v).trans finSumFinEquiv).symm + ⟨k, h1⟩)).trans + (congrArg Sum.inr + (interfaceEquiv_symm_low t u v k hk h1 h2))) + +private theorem lhsOuterPairs_wf (s t u v : ℕ) : + Fragment.PairsWF + (Fragment.mapPairs (Fragment.inlFoldEquiv (β := Fin (u + v)) + (interfacePairs s t u)).symm + (Fragment.mapPairs (_root_.Equiv.sumCongr + ((interfaceSurvEquiv s t u).trans finSumFinEquiv) + (_root_.Equiv.refl (Fin (u + v)))).symm (interfacePairs s u v))) := + Fragment.mapPairs_wf _ _ (Fragment.mapPairs_wf _ _ (interfacePairs_wf s u v)) + +/-- **The left association, normalized**: composing `F` with `G` +and then with `H` is iterated gluing of the embedded +`t`-interface pairs followed by the `u`-interface pairs over the +common ambient `(F ⊔ G) ⊔ H`. -/ +noncomputable def assocNormalLeft {s t u v : ℕ} + (F : Fragment (Fin (s + t))) (G : Fragment (Fin (t + u))) + (H : Fragment (Fin (u + v))) : + ((F.compose G).compose H).Equiv + ((Fragment.glueList ((F.disjUnion G).disjUnion H) + (Fragment.inlPairs (interfacePairs s t u) ++ + uPairsAssoc s t u v) + (assocPairs_wf s t u v)).relabel + (lhsLabelEquiv s t u v)) := by + let σ := _root_.Equiv.sumCongr + ((interfaceSurvEquiv s t u).trans finSumFinEquiv) + (_root_.Equiv.refl (Fin (u + v))) + let i := Fragment.inlFoldEquiv (β := Fin (u + v)) + (interfacePairs s t u) + let ps' := Fragment.mapPairs σ.symm (interfacePairs s u v) + let ps'' := Fragment.mapPairs i.symm ps' + let wfps' : Fragment.PairsWF ps' := + Fragment.mapPairs_wf σ.symm _ (interfacePairs_wf s u v) + let wfps'' : Fragment.PairsWF ps'' := by + exact lhsOuterPairs_wf s t u v + let A := (F.disjUnion G).disjUnion H + let X := Fragment.glueList A + (Fragment.inlPairs (interfacePairs s t u)) + ((assocPairs_wf s t u v).append_left) + let N₁ := Fragment.glueList (F.disjUnion G) + (interfacePairs s t u) (interfacePairs_wf s t u) + -- C8: the doubly-glued fragment against the two-stage fold. + have C8 := + (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv X + (lhs_pairs_eq s t u v ((assocPairs_wf s t u v).append_sep)) + wfps'' + (Fragment.liftPairs_wf _ _ + ((assocPairs_wf s t u v).append_right) + ((assocPairs_wf s t u v).append_sep)) + ((lhs_pairs_eq s t u v + ((assocPairs_wf s t u v).append_sep)) ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + (Fragment.Equiv.relabelFlip + (Fragment.glueListAppend A + (Fragment.inlPairs (interfacePairs s t u)) + (uPairsAssoc s t u v) + (assocPairs_wf s t u v))) + (Fragment.foldSurvivingPermEquiv + ((lhs_pairs_eq s t u v + ((assocPairs_wf s t u v).append_sep)) ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- C7: unfold the second relabelling stage. + have C7 := (Fragment.glueListRelabel X i ps'' wfps'').trans + ((Fragment.Equiv.relabelCongr C8 + (Fragment.foldSurvivingMapEquiv i ps'')).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- C6: bridge the pair list back to ps'. + have C6 := (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (X.relabel i) + (mapPairs_symm_cancel i ps').symm + wfps' (Fragment.mapPairs_wf i ps'' wfps'') + ((mapPairs_symm_cancel i ps').symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr C7 + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel i ps').symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- E4: the glued left factor is the embedded fold, relabelled. + have E4 := + (Fragment.Equiv.relabelFlip + (Fragment.glueListDisjUnionLeft (F.disjUnion G) H + (interfacePairs s t u) + (interfacePairs_wf s t u))).trans + ((Fragment.Equiv.relabelEq _ (_root_.Equiv.symm_symm i)).trans + (Fragment.Equiv.relabelCongr + (Fragment.glueListProofIrrel A + (Fragment.inlPairs (interfacePairs s t u)) + (Fragment.inlPairs_wf _ (interfacePairs_wf s t u)) + ((assocPairs_wf s t u v).append_left)) i)) + -- C4: transport the outer pairs across E4. + have C4 := (Fragment.glueListCongr E4 ps' wfps').trans C6 + -- C3: unfold the first relabelling stage. + have C3 := (Fragment.glueListRelabel (N₁.disjUnion H) σ ps' + wfps').trans + ((Fragment.Equiv.relabelCongr C4 + (Fragment.foldSurvivingMapEquiv σ ps')).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- C2: bridge the outer interface pairs. + have C2 := (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv ((N₁.disjUnion H).relabel σ) + (mapPairs_symm_cancel σ (interfacePairs s u v)).symm + (interfacePairs_wf s u v) + (Fragment.mapPairs_wf σ ps' wfps') + ((mapPairs_symm_cancel σ (interfacePairs s u v)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr C3 + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel σ (interfacePairs s u v)).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- E1: normalize the inner composition inside the disjoint union. + have E1 := + (Fragment.Equiv.disjUnionCongr (composeNormal F G) + (Fragment.Equiv.refl H)).trans + (Fragment.relabelDisjUnionLeft N₁ H + ((interfaceSurvEquiv s t u).trans finSumFinEquiv)) + -- C1: transport the outer gluing across E1. + have C1 := (Fragment.glueListCongr E1 (interfacePairs s u v) + (interfacePairs_wf s u v)).trans C2 + -- Assemble. + exact (composeNormal (F.compose G) H).trans + ((Fragment.Equiv.relabelCongr C1 + ((interfaceSurvEquiv s u v).trans finSumFinEquiv)).trans + (Fragment.Equiv.relabelTrans _ _ _)) + +/-! ### The right association, normalized -/ + +/-- The outer interface pairs of the right association, pulled +back to the boundary of the inner composition. -/ +noncomputable def rhsQs1 (s t u v : ℕ) : + List ((Fin (s + t) ⊕ + Fragment.FoldSurviving (Fin (t + u) ⊕ Fin (u + v)) + (interfacePairs t u v)) × + (Fin (s + t) ⊕ + Fragment.FoldSurviving (Fin (t + u) ⊕ Fin (u + v)) + (interfacePairs t u v))) := + Fragment.mapPairs + (_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (s + t))) + ((interfaceSurvEquiv t u v).trans finSumFinEquiv)).symm + (interfacePairs s t v) + +private theorem rhsQs1_wf (s t u v : ℕ) : + Fragment.PairsWF (rhsQs1 s t u v) := + Fragment.mapPairs_wf _ _ (interfacePairs_wf s t v) + +/-- The outer interface pairs, pulled into the right-embedded +fold survivors. -/ +noncomputable def rhsQs2 (s t u v : ℕ) := + Fragment.mapPairs + (Fragment.inrFoldEquiv (α := Fin (s + t)) + (interfacePairs t u v)).symm + (rhsQs1 s t u v) + +/-- The outer interface pairs, pulled across the associativity +bridge. -/ +noncomputable def rhsQs3 (s t u v : ℕ) := + Fragment.mapPairs (rhsBridgeEquiv s t u v).symm + (rhsQs2 s t u v) + +/-- The composed label identification of the right +association. -/ +noncomputable def rhsLabelEquiv (s t u v : ℕ) : + Fragment.FoldSurviving + ((Fin (s + t) ⊕ Fin (t + u)) ⊕ Fin (u + v)) + (Fragment.inlPairs (interfacePairs s t u) ++ + uPairsAssoc s t u v) ≃ + Fin (s + v) := + ((Fragment.foldSurvivingPermEquiv + ((congrArg (· ++ uPairsAssoc s t u v) + (tPairsAssoc_eq s t u v)) ▸ + List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingPermEquiv + (List.perm_append_comm + (l₁ := uPairsAssoc s t u v) + (l₂ := tPairsAssoc s t u v))).symm.trans + ((Fragment.appendFlatten _ _ + ((assocPairsR_wf s t u v).append_sep)).symm.trans + ((Fragment.foldSurvivingPermEquiv + ((rhs_pairs_eq s t u v + ((assocPairsR_wf s t u v).append_sep)) ▸ + List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv + (rhsBridgeEquiv s t u v) (rhsQs3 s t u v)).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel (rhsBridgeEquiv s t u v) + (rhsQs2 s t u v)).symm ▸ + List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv + (Fragment.inrFoldEquiv (α := Fin (s + t)) + (interfacePairs t u v)) + (rhsQs2 s t u v)).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel + (Fragment.inrFoldEquiv (α := Fin (s + t)) + (interfacePairs t u v)) + (rhsQs1 s t u v)).symm ▸ + List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (s + t))) + ((interfaceSurvEquiv t u v).trans + finSumFinEquiv)) + (rhsQs1 s t u v)).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (s + t))) + ((interfaceSurvEquiv t u v).trans + finSumFinEquiv)) + (interfacePairs s t v)).symm ▸ + List.Perm.refl _)).symm.trans + ((interfaceSurvEquiv s t v).trans + finSumFinEquiv))))))))))) + +private theorem rhsQs3_wf (s t u v : ℕ) : + Fragment.PairsWF (rhsQs3 s t u v) := + Fragment.mapPairs_wf _ _ (Fragment.mapPairs_wf _ _ (rhsQs1_wf s t u v)) + +/-- **The right association, normalized**: composing `F` with the +composition of `G` and `H` is the same iterated gluing over the +common ambient, through the associativity bridge. -/ +noncomputable def assocNormalRight {s t u v : ℕ} + (F : Fragment (Fin (s + t))) (G : Fragment (Fin (t + u))) + (H : Fragment (Fin (u + v))) : + (F.compose (G.compose H)).Equiv + ((Fragment.glueList ((F.disjUnion G).disjUnion H) + (Fragment.inlPairs (interfacePairs s t u) ++ + uPairsAssoc s t u v) + (assocPairs_wf s t u v)).relabel + (rhsLabelEquiv s t u v)) := by + -- ═══════ SETUP ═══════ + -- The intermediate folds (`XR`, `N₂`, `YR`, `UPA`) over the common + -- ambient, the relabels between them, and their well-formedness data. + let σ' := _root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (s + t))) + ((interfaceSurvEquiv t u v).trans finSumFinEquiv) + let i' := Fragment.inrFoldEquiv (α := Fin (s + t)) + (interfacePairs t u v) + let e2a := (_root_.Equiv.sumAssoc (Fin (s + t)) (Fin (t + u)) + (Fin (u + v))).symm.symm + let wfqs1 : Fragment.PairsWF (rhsQs1 s t u v) := by + exact rhsQs1_wf s t u v + let wfqs2 : Fragment.PairsWF (rhsQs2 s t u v) := + Fragment.mapPairs_wf i'.symm _ wfqs1 + let wfqs3 : Fragment.PairsWF (rhsQs3 s t u v) := by + exact rhsQs3_wf s t u v + let uA' := Fragment.mapPairs e2a.symm + (Fragment.inrPairs (α := Fin (s + t)) (interfacePairs t u v)) + let wfuA' : Fragment.PairsWF uA' := + Fragment.mapPairs_wf e2a.symm _ + (Fragment.inrPairs_wf _ (interfacePairs_wf t u v)) + let A := (F.disjUnion G).disjUnion H + let XR := Fragment.glueList (F.disjUnion (G.disjUnion H)) + (Fragment.inrPairs (α := Fin (s + t)) (interfacePairs t u v)) + (Fragment.inrPairs_wf _ (interfacePairs_wf t u v)) + let N₂ := Fragment.glueList (G.disjUnion H) + (interfacePairs t u v) (interfacePairs_wf t u v) + let YR := Fragment.glueList A + (uPairsAssoc s t u v ++ tPairsAssoc s t u v) + (assocPairsR_wf s t u v) + let UPA := Fragment.glueList A (uPairsAssoc s t u v) + ((assocPairsR_wf s t u v).append_left) + -- ═══════ STAGE 1: THE REORDER AND THE APPEND MERGE ═══════ + -- CP: reorder and rename the pair blocks. + have CP := + (Fragment.glueListPerm A + (List.perm_append_comm + (l₁ := uPairsAssoc s t u v) + (l₂ := tPairsAssoc s t u v)) + (assocPairsR_wf s t u v)).trans + ((Fragment.Equiv.relabelCongr + (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv A + (congrArg (· ++ uPairsAssoc s t u v) + (tPairsAssoc_eq s t u v)) + ((assocPairsR_wf s t u v).perm + (List.perm_append_comm + (l₁ := uPairsAssoc s t u v) + (l₂ := tPairsAssoc s t u v))) + (assocPairs_wf s t u v) + ((congrArg (· ++ uPairsAssoc s t u v) + (tPairsAssoc_eq s t u v)) ▸ + List.Perm.refl _))) + (Fragment.foldSurvivingPermEquiv + (List.perm_append_comm + (l₁ := uPairsAssoc s t u v) + (l₂ := tPairsAssoc s t u v))).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- CR8: the append merge, with the reorder folded in. + have CR8 := + (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv UPA + (rhs_pairs_eq s t u v + ((assocPairsR_wf s t u v).append_sep)) + wfqs3 + (Fragment.liftPairs_wf _ _ + ((assocPairsR_wf s t u v).append_right) + ((assocPairsR_wf s t u v).append_sep)) + ((rhs_pairs_eq s t u v + ((assocPairsR_wf s t u v).append_sep)) ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.Equiv.relabelFlip + (Fragment.glueListAppend A (uPairsAssoc s t u v) + (tPairsAssoc s t u v) + (assocPairsR_wf s t u v))).trans + ((Fragment.Equiv.relabelCongr CP + (Fragment.appendFlatten _ _ + ((assocPairsR_wf s t u v).append_sep)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _))) + (Fragment.foldSurvivingPermEquiv + ((rhs_pairs_eq s t u v + ((assocPairsR_wf s t u v).append_sep)) ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- ═══════ STAGE 2: THE ASSOCIATIVITY BRIDGE ═══════ + -- CRX: the associativity bridge on the inner fold. + have CRX := + (Fragment.glueListCongr + (Fragment.Equiv.relabelFlip (Fragment.disjUnionAssoc F G H)) + _ _).trans + ((Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (A.relabel e2a) + (mapPairs_symm_cancel e2a + (Fragment.inrPairs (α := Fin (s + t)) + (interfacePairs t u v))).symm + (Fragment.inrPairs_wf _ (interfacePairs_wf t u v)) + (Fragment.mapPairs_wf e2a _ wfuA') + ((mapPairs_symm_cancel e2a + (Fragment.inrPairs (α := Fin (s + t)) + (interfacePairs t u v))).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.glueListRelabel A e2a uA' wfuA').trans + ((Fragment.Equiv.relabelCongr + (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv A + (rhs_ground_eq s t u v) + wfuA' + ((assocPairsR_wf s t u v).append_left) + ((rhs_ground_eq s t u v) ▸ List.Perm.refl _))) + (Fragment.foldSurvivingMapEquiv e2a uA')).trans + (Fragment.Equiv.relabelTrans _ _ _))) + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel e2a + (Fragment.inrPairs (α := Fin (s + t)) + (interfacePairs t u v))).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _))) + -- CR5: transport the outer pairs across the bridge. + have CR5 := + (Fragment.glueListCongr CRX _ _).trans + ((Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv + (UPA.relabel (rhsBridgeEquiv s t u v)) + (mapPairs_symm_cancel (rhsBridgeEquiv s t u v) + (rhsQs2 s t u v)).symm + wfqs2 + (Fragment.mapPairs_wf (rhsBridgeEquiv s t u v) _ wfqs3) + ((mapPairs_symm_cancel (rhsBridgeEquiv s t u v) + (rhsQs2 s t u v)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + (Fragment.glueListRelabel UPA (rhsBridgeEquiv s t u v) + (rhsQs3 s t u v) wfqs3) + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel (rhsBridgeEquiv s t u v) + (rhsQs2 s t u v)).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _))) + -- ═══════ STAGE 3: THE EMBEDDED FOLD ═══════ + -- ER4: the inner composition is the embedded fold. + have ER4 := + (Fragment.Equiv.relabelFlip + (Fragment.glueListDisjUnionRight F (G.disjUnion H) + (interfacePairs t u v) + (interfacePairs_wf t u v))).trans + (Fragment.Equiv.relabelEq XR (_root_.Equiv.symm_symm i')) + -- CR3: the i'-relabelling stage. + have CR3 := + (Fragment.glueListCongr ER4 _ _).trans + ((Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (XR.relabel i') + (mapPairs_symm_cancel i' (rhsQs1 s t u v)).symm + wfqs1 + (Fragment.mapPairs_wf i' _ wfqs2) + ((mapPairs_symm_cancel i' (rhsQs1 s t u v)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + (Fragment.glueListRelabel XR i' (rhsQs2 s t u v) wfqs2) + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel i' (rhsQs1 s t u v)).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _))) + -- ═══════ STAGE 4: THE INNER COMPOSITION, NORMALIZED ═══════ + -- ER1: normalize the inner composition. + have ER1 := + (Fragment.Equiv.disjUnionCongr (Fragment.Equiv.refl F) + (composeNormal G H)).trans + (Fragment.relabelDisjUnionRight F N₂ + ((interfaceSurvEquiv t u v).trans finSumFinEquiv)) + -- CR1: the σ'-relabelling stage. + have CR1 := + (Fragment.glueListCongr ER1 _ _).trans + ((Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv ((F.disjUnion N₂).relabel σ') + (mapPairs_symm_cancel σ' (interfacePairs s t v)).symm + (interfacePairs_wf s t v) + (Fragment.mapPairs_wf σ' _ wfqs1) + ((mapPairs_symm_cancel σ' + (interfacePairs s t v)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + (Fragment.glueListRelabel (F.disjUnion N₂) σ' + (rhsQs1 s t u v) wfqs1) + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel σ' + (interfacePairs s t v)).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _))) + -- ═══════ ASSEMBLY ═══════ + exact (composeNormal F (G.compose H)).trans + ((Fragment.Equiv.relabelCongr + (CR1.trans + ((Fragment.Equiv.relabelCongr + (CR3.trans + ((Fragment.Equiv.relabelCongr + (CR5.trans + ((Fragment.Equiv.relabelCongr CR8 _).trans + (Fragment.Equiv.relabelTrans _ _ _))) _).trans + (Fragment.Equiv.relabelTrans _ _ _))) _).trans + (Fragment.Equiv.relabelTrans _ _ _))) + ((interfaceSurvEquiv s t v).trans finSumFinEquiv)).trans + (Fragment.Equiv.relabelTrans _ _ _)) + +/-! ### The meet -/ + +/-- The two label identifications agree: every survivor of the +combined gluing is a low `F`-label or a high `H`-label, and both +composites read off the same boundary position. -/ +theorem label_equiv_meet (s t u v : ℕ) : + lhsLabelEquiv s t u v = rhsLabelEquiv s t u v := by + refine _root_.Equiv.ext fun x => ?_ + obtain ⟨xv, hxp⟩ := x + rcases xv with (a | g) | b + · rcases Nat.lt_or_ge a.val s with ha | ha + · rfl + · exfalso + have hk : a.val - s < t := by have := a.isLt; omega + have hmem : _ ∈ Fragment.inlPairs (interfacePairs s t u) ++ + uPairsAssoc s t u v := List.mem_append.mpr (Or.inl + ((mem_tPairsAssoc s t u v _).mpr ⟨⟨a.val - s, hk⟩, rfl⟩)) + exact (hxp _ hmem).1 + (congrArg (fun z => Sum.inl (Sum.inl z)) + (Fin.ext (show a.val = s + (a.val - s) by omega))) + · exfalso + rcases Nat.lt_or_ge g.val t with hg | hg + · have hmem : _ ∈ Fragment.inlPairs (interfacePairs s t u) ++ + uPairsAssoc s t u v := List.mem_append.mpr (Or.inl + ((mem_tPairsAssoc s t u v _).mpr ⟨⟨g.val, hg⟩, rfl⟩)) + exact (hxp _ hmem).2 + (congrArg (fun z => Sum.inl (Sum.inr z)) + (Fin.ext (rfl : g.val = g.val))) + · have hk : g.val - t < u := by have := g.isLt; omega + have hmem : _ ∈ Fragment.inlPairs (interfacePairs s t u) ++ + uPairsAssoc s t u v := List.mem_append.mpr (Or.inr + ((mem_uPairsAssoc s t u v _).mpr ⟨⟨g.val - t, hk⟩, rfl⟩)) + exact (hxp _ hmem).1 + (congrArg (fun z => Sum.inl (Sum.inr z)) + (Fin.ext (show g.val = t + (g.val - t) by omega))) + · rcases Nat.lt_or_ge b.val u with hb | hb + · exfalso + have hmem : _ ∈ Fragment.inlPairs (interfacePairs s t u) ++ + uPairsAssoc s t u v := List.mem_append.mpr (Or.inr + ((mem_uPairsAssoc s t u v _).mpr ⟨⟨b.val, hb⟩, rfl⟩)) + exact (hxp _ hmem).2 + (congrArg Sum.inr (Fin.ext (rfl : b.val = b.val))) + · exact Fin.ext + (by change s + (b.val - u) = s + (t + (b.val - u) - t); omega) + +/-- **Associativity of composition**: the two associations of a +triple composition are equivalent fragments. -/ +noncomputable def composeAssoc {s t u v : ℕ} + (F : Fragment (Fin (s + t))) (G : Fragment (Fin (t + u))) + (H : Fragment (Fin (u + v))) : + ((F.compose G).compose H).Equiv (F.compose (G.compose H)) := + (assocNormalLeft F G H).trans + ((Fragment.Equiv.relabelEq _ (label_equiv_meet s t u v)).trans + (assocNormalRight F G H).symm) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeNormal.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeNormal.lean new file mode 100644 index 0000000000..5b91123351 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeNormal.lean @@ -0,0 +1,606 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueFold + +/-! +# The interface pair list of a composition + +The pairs glued by `glueInterface`, top pair first, as data for the +iterated-gluing fold: their well-formedness, the membership +characterization of the glued labels, and the identification of the +surviving labels with `Fin s ⊕ Fin u`. The normalization of +`glueInterface` as a `glueList` builds on these. +-/ + +@[expose] public section + +namespace RS + +/-- The interface pairs glued by `glueInterface`, top pair first. -/ +def interfacePairs (s t u : ℕ) : + List ((Fin (s + t) ⊕ Fin (t + u)) × (Fin (s + t) ⊕ Fin (t + u))) := + (List.finRange t).reverse.map (fun k => + (Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩, + Sum.inr ⟨k.val, by have := k.isLt; omega⟩)) + +/-- Membership in the flattened interface pairs. -/ +theorem mem_interfacePairs_flat (s t u : ℕ) + (x : Fin (s + t) ⊕ Fin (t + u)) : + x ∈ (interfacePairs s t u).flatMap (fun p => [p.1, p.2]) ↔ + (∃ a : Fin (s + t), x = Sum.inl a ∧ s ≤ a.val) ∨ + (∃ b : Fin (t + u), x = Sum.inr b ∧ b.val < t) := by + unfold interfacePairs + rw [List.flatMap_map] + simp only [List.mem_flatMap, List.mem_reverse, List.mem_finRange, + List.mem_cons, List.not_mem_nil, or_false, true_and] + constructor + · rintro ⟨k, hk | hk⟩ + · exact Or.inl ⟨_, hk, by simp⟩ + · exact Or.inr ⟨_, hk, by simp⟩ + · rintro (⟨a, rfl, ha⟩ | ⟨b, rfl, hb⟩) + · refine ⟨⟨a.val - s, by have := a.isLt; omega⟩, Or.inl ?_⟩ + congr 1 + exact Fin.ext (by simp; omega) + · refine ⟨⟨b.val, hb⟩, Or.inr ?_⟩ + congr 1 + +/-- The interface pairs are well-formed. -/ +theorem interfacePairs_wf (s t u : ℕ) : + Fragment.PairsWF (interfacePairs s t u) := by + unfold Fragment.PairsWF interfacePairs + rw [List.flatMap_map, List.nodup_flatMap] + refine ⟨fun k _ => by simp, ?_⟩ + rw [List.pairwise_reverse] + refine (List.nodup_finRange t).pairwise_of_forall_ne ?_ + intro k _ m _ hkm x hxm hxk + simp only [List.mem_cons, List.not_mem_nil, or_false] at hxm hxk + rcases hxm with rfl | rfl <;> rcases hxk with h | h + · rw [Sum.inl.injEq, Fin.mk.injEq] at h + exact hkm (Fin.ext (by omega)).symm + · exact Sum.inl_ne_inr h + · exact Sum.inr_ne_inl h + · rw [Sum.inr.injEq, Fin.mk.injEq] at h + exact hkm (Fin.ext (by omega)).symm + +/-- Left labels below the interface. -/ +def finLtEquiv (s t : ℕ) : {a : Fin (s + t) // a.val < s} ≃ Fin s where + toFun a := ⟨a.val.val, a.prop⟩ + invFun a := ⟨⟨a.val, by have := a.isLt; omega⟩, by + change a.val < s + exact a.isLt⟩ + left_inv a := Subtype.ext (Fin.ext rfl) + right_inv a := Fin.ext rfl + +/-- Right labels beyond the interface. -/ +def finGeEquiv (t u : ℕ) : {b : Fin (t + u) // ¬ b.val < t} ≃ Fin u where + toFun b := ⟨b.val.val - t, by + have h1 := b.val.isLt + have h2 := Nat.le_of_not_lt b.prop + omega⟩ + invFun b := ⟨⟨t + b.val, by have := b.isLt; omega⟩, by + change ¬ t + b.val < t + omega⟩ + left_inv b := Subtype.ext (Fin.ext (by + have := Nat.le_of_not_lt b.prop + change t + (b.val.val - t) = b.val.val + omega)) + right_inv b := Fin.ext (by + change t + b.val - t = b.val + omega) + +/-- The survival predicate of the interface gluing. -/ +def interfaceSurvPred (s t u : ℕ) : Fin (s + t) ⊕ Fin (t + u) → Prop := + Sum.elim (fun a => a.val < s) (fun b => ¬ b.val < t) + +/-- Avoiding every pair component is avoiding the flat list. -/ +theorem forall_ne_iff_not_mem_flat {α : Type} (ps : List (α × α)) + (x : α) : + (∀ p ∈ ps, x ≠ p.1 ∧ x ≠ p.2) ↔ + x ∉ ps.flatMap (fun p => [p.1, p.2]) := by + rw [List.mem_flatMap] + constructor + · rintro h ⟨p, hp, hx⟩ + rcases List.mem_cons.mp hx with rfl | hx' + · exact (h p hp).1 rfl + · exact (h p hp).2 (List.mem_singleton.mp hx') + · intro h p hp + exact ⟨fun hx => h ⟨p, hp, by rw [hx]; exact List.mem_cons_self⟩, + fun hx => h ⟨p, hp, by + rw [hx] + exact List.mem_cons.mpr (Or.inr List.mem_cons_self)⟩⟩ + +/-- Survival equals the survival predicate. -/ +theorem interfaceSurv_iff (s t u : ℕ) (x : Fin (s + t) ⊕ Fin (t + u)) : + x ∉ (interfacePairs s t u).flatMap (fun p => [p.1, p.2]) ↔ + interfaceSurvPred s t u x := by + rcases x with a | b + · constructor + · intro hx + rcases Nat.lt_or_ge a.val s with h | h + · exact h + · exact absurd ((mem_interfacePairs_flat s t u _).mpr + (Or.inl ⟨a, rfl, h⟩)) hx + · intro hlt hmem + rcases (mem_interfacePairs_flat s t u _).mp hmem with + ⟨a', ha', hge⟩ | ⟨b', hb', _⟩ + · rw [Sum.inl.injEq] at ha' + subst ha' + have hlt' : a.val < s := hlt + omega + · exact Sum.inl_ne_inr hb' + · constructor + · intro hx h + exact absurd ((mem_interfacePairs_flat s t u _).mpr + (Or.inr ⟨b, rfl, h⟩)) hx + · intro hq hmem + rcases (mem_interfacePairs_flat s t u _).mp hmem with + ⟨a', ha', _⟩ | ⟨b', hb', hlt⟩ + · exact Sum.inr_ne_inl ha' + · rw [Sum.inr.injEq] at hb' + subst hb' + exact hq hlt + +/-- The labels surviving the interface gluing: left labels below +`s` and right labels beyond `t`. -/ +noncomputable def interfaceSurvEquiv (s t u : ℕ) : + Fragment.FoldSurviving (Fin (s + t) ⊕ Fin (t + u)) + (interfacePairs s t u) ≃ Fin s ⊕ Fin u := + ((Equiv.subtypeEquivRight (fun x => + (forall_ne_iff_not_mem_flat _ x).trans (interfaceSurv_iff s t u x))).trans + (Equiv.subtypeSum (p := interfaceSurvPred s t u))).trans + (Equiv.sumCongr (finLtEquiv s t) (finGeEquiv t u)) + +/-! ### The step decomposition of the interface pairs -/ + +/-- The tail pairs of the `(t+1)`-interface: the same pairs one +level down, embedded in the larger index types. -/ +def tailPairs (s t u : ℕ) : + List ((Fin (s + t + 1) ⊕ Fin (t + 1 + u)) × + (Fin (s + t + 1) ⊕ Fin (t + 1 + u))) := + (List.finRange t).reverse.map (fun k => + (Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩, + Sum.inr ⟨k.val, by have := k.isLt; omega⟩)) + +/-- The `(t+1)`-interface pairs decompose as the top pair followed +by the tail pairs. -/ +theorem interfacePairs_succ (s t u : ℕ) : + interfacePairs s (t + 1) u = + (Sum.inl ⟨s + t, by omega⟩, Sum.inr ⟨t, by omega⟩) :: + tailPairs s t u := by + unfold interfacePairs tailPairs + rw [List.finRange_succ_last, List.reverse_append, + List.reverse_singleton, List.singleton_append, List.map_cons, + ← List.map_reverse, List.map_map] + exact congrArg₂ List.cons rfl (List.map_congr_left (fun k _ => rfl)) + +/-- The step re-indexing on surviving left labels: values are +preserved. -/ +theorem interfaceStepEquiv_inl (s t u : ℕ) (a : Fin (s + t + 1)) + (h : (Sum.inl a : Fin (s + t + 1) ⊕ Fin (t + 1 + u)) ≠ + Sum.inl ⟨s + t, Nat.lt_succ_self _⟩ ∧ + (Sum.inl a : Fin (s + t + 1) ⊕ Fin (t + 1 + u)) ≠ + Sum.inr ⟨t, by omega⟩) + (ha : a.val < s + t) : + interfaceStepEquiv s t u ⟨Sum.inl a, h⟩ = Sum.inl ⟨a.val, ha⟩ := by + unfold interfaceStepEquiv + rw [Equiv.trans_apply, + show sumRemoveSplitEquiv (⟨s + t, Nat.lt_succ_self _⟩ : Fin (s + t + 1)) + (⟨t, by omega⟩ : Fin (t + 1 + u)) ⟨Sum.inl a, h⟩ = + Sum.inl ⟨a, fun he => h.1 (congrArg Sum.inl he)⟩ from rfl] + rw [show (Equiv.sumCongr (finRemoveEquiv _) (rightRemoveEquiv t u)) + (Sum.inl ⟨a, fun he => h.1 (congrArg Sum.inl he)⟩) = + Sum.inl (finRemoveEquiv ⟨s + t, Nat.lt_succ_self _⟩ + ⟨a, fun he => h.1 (congrArg Sum.inl he)⟩) from rfl] + refine congrArg Sum.inl (Fin.ext ?_) + rw [finRemoveEquiv_val] + change (if a.val < s + t then a.val else a.val - 1) = a.val + rw [ite_eq_left ha] + +/-- The step re-indexing on surviving right labels below the glued +index: values are preserved. -/ +theorem interfaceStepEquiv_inr_below (s t u : ℕ) (b : Fin (t + 1 + u)) + (h : (Sum.inr b : Fin (s + t + 1) ⊕ Fin (t + 1 + u)) ≠ + Sum.inl ⟨s + t, Nat.lt_succ_self _⟩ ∧ + (Sum.inr b : Fin (s + t + 1) ⊕ Fin (t + 1 + u)) ≠ + Sum.inr ⟨t, by omega⟩) + (hb : b.val < t) : + interfaceStepEquiv s t u ⟨Sum.inr b, h⟩ = + Sum.inr ⟨b.val, by omega⟩ := by + unfold interfaceStepEquiv + rw [Equiv.trans_apply, + show sumRemoveSplitEquiv (⟨s + t, Nat.lt_succ_self _⟩ : Fin (s + t + 1)) + (⟨t, by omega⟩ : Fin (t + 1 + u)) ⟨Sum.inr b, h⟩ = + Sum.inr ⟨b, fun he => h.2 (congrArg Sum.inr he)⟩ from rfl] + rw [show (Equiv.sumCongr (finRemoveEquiv _) (rightRemoveEquiv t u)) + (Sum.inr ⟨b, fun he => h.2 (congrArg Sum.inr he)⟩) = + Sum.inr (rightRemoveEquiv t u + ⟨b, fun he => h.2 (congrArg Sum.inr he)⟩) from rfl] + refine congrArg Sum.inr (Fin.ext ?_) + unfold rightRemoveEquiv + rw [Equiv.trans_apply, finRemoveEquiv_val] + change (if b.val < t then b.val else b.val - 1) = b.val + rw [ite_eq_left hb] + +/-- The step re-indexing on surviving right labels above the glued +index: values drop by one. -/ +theorem interfaceStepEquiv_inr_above (s t u : ℕ) (b : Fin (t + 1 + u)) + (h : (Sum.inr b : Fin (s + t + 1) ⊕ Fin (t + 1 + u)) ≠ + Sum.inl ⟨s + t, Nat.lt_succ_self _⟩ ∧ + (Sum.inr b : Fin (s + t + 1) ⊕ Fin (t + 1 + u)) ≠ + Sum.inr ⟨t, by omega⟩) + (hb : t < b.val) : + interfaceStepEquiv s t u ⟨Sum.inr b, h⟩ = + Sum.inr ⟨b.val - 1, by have := b.isLt; omega⟩ := by + unfold interfaceStepEquiv + rw [Equiv.trans_apply, + show sumRemoveSplitEquiv (⟨s + t, Nat.lt_succ_self _⟩ : Fin (s + t + 1)) + (⟨t, by omega⟩ : Fin (t + 1 + u)) ⟨Sum.inr b, h⟩ = + Sum.inr ⟨b, fun he => h.2 (congrArg Sum.inr he)⟩ from rfl] + rw [show (Equiv.sumCongr (finRemoveEquiv _) (rightRemoveEquiv t u)) + (Sum.inr ⟨b, fun he => h.2 (congrArg Sum.inr he)⟩) = + Sum.inr (rightRemoveEquiv t u + ⟨b, fun he => h.2 (congrArg Sum.inr he)⟩) from rfl] + refine congrArg Sum.inr (Fin.ext ?_) + unfold rightRemoveEquiv + rw [Equiv.trans_apply, finRemoveEquiv_val] + change (if b.val < t then b.val else b.val - 1) = b.val - 1 + rw [ite_eq_right (by omega)] + +/-! ### The coerced tail as a mapped pair list -/ + +/-- The step re-indexing pulls tail-pair left components back to +themselves. -/ +theorem interfaceStepEquiv_symm_inl (s t u : ℕ) (k : ℕ) (hk : k < t) : + (interfaceStepEquiv s t u).symm (Sum.inl ⟨s + k, by omega⟩) = + ⟨Sum.inl ⟨s + k, by omega⟩, + fun he => by + have h2 : s + k = s + t := congrArg Fin.val (Sum.inl.inj he) + omega, + fun he => Sum.inl_ne_inr he⟩ := by + rw [_root_.Equiv.symm_apply_eq] + exact (interfaceStepEquiv_inl s t u ⟨s + k, by omega⟩ _ + (by change s + k < s + t; omega)).symm + +/-- The step re-indexing pulls tail-pair right components back to +themselves. -/ +theorem interfaceStepEquiv_symm_inr (s t u : ℕ) (k : ℕ) (hk : k < t) : + (interfaceStepEquiv s t u).symm (Sum.inr ⟨k, by omega⟩) = + ⟨Sum.inr ⟨k, by omega⟩, + fun he => Sum.inr_ne_inl he, + fun he => by + have h2 : k = t := congrArg Fin.val (Sum.inr.inj he) + omega⟩ := by + rw [_root_.Equiv.symm_apply_eq] + exact (interfaceStepEquiv_inr_below s t u ⟨k, by omega⟩ _ hk).symm + +/-- Mapping back and forth through an equivalence is the identity +on pair lists. -/ +theorem mapPairs_symm_cancel {α β : Type} (e : α ≃ β) : + ∀ ps : List (β × β), + Fragment.mapPairs e (Fragment.mapPairs e.symm ps) = ps + | [] => rfl + | p :: ps => by + simp only [Fragment.mapPairs, List.map_cons, Prod.map] + exact congrArg₂ List.cons + (Prod.ext (e.apply_symm_apply p.1) (e.apply_symm_apply p.2)) + (mapPairs_symm_cancel e ps) + +/-- The mapped-back interface pairs are the coerced tail pairs +(generalized over the index list). -/ +private theorem interface_coerce_eq_aux (s t u : ℕ) : + ∀ (l : List (Fin t)) + (hsep : Fragment.PairsSep + (Sum.inl ⟨s + t, Nat.lt_succ_self _⟩ : + Fin (s + t + 1) ⊕ Fin (t + 1 + u)) + (Sum.inr ⟨t, by omega⟩) + (l.map (fun k => + (Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩, + Sum.inr ⟨k.val, by have := k.isLt; omega⟩)))), + Fragment.mapPairs (interfaceStepEquiv s t u).symm + (l.map (fun k => + ((Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩ : + Fin (s + t) ⊕ Fin (t + u)), + Sum.inr ⟨k.val, by have := k.isLt; omega⟩))) = + Fragment.coercePairsList _ _ _ hsep + | [], _ => rfl + | k :: l, hsep => by + simp only [List.map_cons, Fragment.mapPairs, + Fragment.coercePairsList, Prod.map] + refine congrArg₂ List.cons (Prod.ext ?_ ?_) + (interface_coerce_eq_aux s t u l _) + · exact (interfaceStepEquiv_symm_inl s t u k.val k.isLt).trans + (Subtype.ext rfl) + · exact (interfaceStepEquiv_symm_inr s t u k.val k.isLt).trans + (Subtype.ext rfl) + +/-- The mapped-back interface pairs are the coerced tail pairs. -/ +theorem interface_coerce_eq (s t u : ℕ) + (hsep : Fragment.PairsSep + (Sum.inl ⟨s + t, Nat.lt_succ_self _⟩ : + Fin (s + t + 1) ⊕ Fin (t + 1 + u)) + (Sum.inr ⟨t, by omega⟩) (tailPairs s t u)) : + Fragment.mapPairs (interfaceStepEquiv s t u).symm + (interfacePairs s t u) = + Fragment.coercePairsList _ _ (tailPairs s t u) hsep := + interface_coerce_eq_aux s t u (List.finRange t).reverse hsep + +/-- The surviving-label identification on left labels. -/ +theorem interfaceSurvEquiv_inl (s t u : ℕ) + (x : Fragment.FoldSurviving (Fin (s + t) ⊕ Fin (t + u)) + (interfacePairs s t u)) + (a : Fin (s + t)) (hx : x.val = Sum.inl a) (ha : a.val < s) : + interfaceSurvEquiv s t u x = Sum.inl ⟨a.val, ha⟩ := by + obtain ⟨xv, hxp⟩ := x + subst hx + rfl + +/-- The surviving-label identification on right labels. -/ +theorem interfaceSurvEquiv_inr (s t u : ℕ) + (x : Fragment.FoldSurviving (Fin (s + t) ⊕ Fin (t + u)) + (interfacePairs s t u)) + (b : Fin (t + u)) (hx : x.val = Sum.inr b) (hb : t ≤ b.val) : + interfaceSurvEquiv s t u x = + Sum.inr ⟨b.val - t, by have := b.isLt; omega⟩ := by + obtain ⟨xv, hxp⟩ := x + subst hx + rfl + +/-- Membership of a tail pair. -/ +private theorem mem_tailPairs (s t u : ℕ) (k : ℕ) (hk : k < t) : + ((Sum.inl ⟨s + k, by omega⟩, + (Sum.inr ⟨k, by omega⟩ : Fin (s + t + 1) ⊕ Fin (t + 1 + u)))) ∈ + tailPairs s t u := by + unfold tailPairs + exact List.mem_map.mpr ⟨⟨k, hk⟩, + List.mem_reverse.mpr (List.mem_finRange _), rfl⟩ + +/-! ### The normalization of glueInterface -/ + +/-- `glueInterface` is the iterated gluing along the interface +pairs, relabelled by the surviving-label identification. -/ +noncomputable def glueInterfaceNormal (s u : ℕ) : + (t : ℕ) → (W : Fragment (Fin (s + t) ⊕ Fin (t + u))) → + (glueInterface s t u W).Equiv + ((Fragment.glueList W (interfacePairs s t u) + (interfacePairs_wf s t u)).relabel (interfaceSurvEquiv s t u)) + -- ═══════ t = 0: NOTHING TO GLUE ═══════ + | 0, W => by + change (W.relabel (Equiv.sumCongr (finCongr (by omega)) + (finCongr (by omega)))).Equiv _ + have hnil : Fragment.glueList W (interfacePairs s 0 u) + (interfacePairs_wf s 0 u) = + W.relabel Fragment.foldSurvivingNilEquiv.symm := + Fragment.glueList_nil W _ + rw [hnil] + refine Fragment.Equiv.trans ?_ + (Fragment.Equiv.relabelTrans W _ _).symm + have heq : (Equiv.sumCongr (finCongr (by omega : s + 0 = s)) + (finCongr (by omega : 0 + u = u))) = + Fragment.foldSurvivingNilEquiv.symm.trans + (interfaceSurvEquiv s 0 u) := + Equiv.ext (fun x => by rcases x with a | b <;> rfl) + exact heq ▸ Fragment.Equiv.refl _ + -- ═══════ t + 1: GLUE THE TOP PAIR, RECURSE ═══════ + | t + 1, W => by + change (glueInterface s t u + ((W.gluePair (Sum.inl ⟨s + t, by omega⟩) (Sum.inr ⟨t, by omega⟩) + Sum.inl_ne_inr).relabel + (interfaceStepEquiv s t u))).Equiv _ + have hwf_cons : Fragment.PairsWF + ((Sum.inl ⟨s + t, Nat.lt_succ_self _⟩, + (Sum.inr ⟨t, by omega⟩ : + Fin (s + t + 1) ⊕ Fin (t + 1 + u))) :: tailPairs s t u) := + interfacePairs_succ s t u ▸ interfacePairs_wf s (t + 1) u + have hlist : Fragment.mapPairs (interfaceStepEquiv s t u) + (Fragment.coercePairsList _ _ (tailPairs s t u) hwf_cons.sep) = + interfacePairs s t u := by + rw [← interface_coerce_eq s t u hwf_cons.sep] + exact mapPairs_symm_cancel _ _ + have hwf₀ := Fragment.coercePairsList_wf _ _ (tailPairs s t u) + hwf_cons.tail hwf_cons.sep + refine Fragment.Equiv.trans (glueInterfaceNormal s u t _) ?_ + refine Fragment.Equiv.trans (Fragment.Equiv.relabelCongr + (Fragment.glueListEqEquiv _ hlist + (Fragment.mapPairs_wf _ _ hwf₀) (interfacePairs_wf s t u) + (by rw [hlist])).symm (interfaceSurvEquiv s t u)) ?_ + refine Fragment.Equiv.trans + (Fragment.Equiv.relabelTrans _ _ _) ?_ + refine Fragment.Equiv.trans (Fragment.Equiv.relabelCongr + (Fragment.glueListRelabel + (W.gluePair (Sum.inl ⟨s + t, by omega⟩) (Sum.inr ⟨t, by omega⟩) + Sum.inl_ne_inr) + (interfaceStepEquiv s t u) _ hwf₀) _) ?_ + refine Fragment.Equiv.trans + (Fragment.Equiv.relabelTrans _ _ _) ?_ + -- Both sides are now relabels of the same iterated glue; the + -- composed relabellings agree pointwise. + have heqF : (Fragment.foldSurvivingMapEquiv (interfaceStepEquiv s t u) + (Fragment.coercePairsList _ _ (tailPairs s t u) + hwf_cons.sep)).trans + ((Fragment.foldSurvivingPermEquiv (by rw [hlist])).trans + (interfaceSurvEquiv s t u)) = + (Fragment.foldFlatten _ _ (tailPairs s t u) hwf_cons.sep).trans + ((Fragment.foldSurvivingPermEquiv + (by rw [interfacePairs_succ s t u] : + (interfacePairs s (t + 1) u).Perm _)).symm.trans + (interfaceSurvEquiv s (t + 1) u)) := by + refine Equiv.ext (fun x => ?_) + simp only [Equiv.trans_apply] + rcases hval : x.val.val with a | b + · have ha' : a.val < s + t := by + have h1 := x.val.prop.1 + rw [hval] at h1 + have hne : a ≠ ⟨s + t, Nat.lt_succ_self _⟩ := + fun h => h1 (congrArg Sum.inl h) + have := a.isLt + rcases Nat.lt_or_ge a.val (s + t) with h | h + · exact h + · exact absurd (Fin.ext (show a.val = s + t by omega)) hne + have ha : a.val < s := by + rcases Nat.lt_or_ge a.val s with h | h + · exact h + · obtain ⟨r, hr, hr1, _⟩ := Fragment.coercePairsList_mem _ _ + (tailPairs s t u) hwf_cons.sep + (Sum.inl ⟨s + (a.val - s), by omega⟩, + Sum.inr ⟨a.val - s, by omega⟩) + (by exact mem_tailPairs s t u (a.val - s) (by omega)) + refine absurd (Subtype.ext ?_ : x.val = r.1) (x.prop r hr).1 + rw [hr1, hval] + exact congrArg Sum.inl (Fin.ext + (by change a.val = s + (a.val - s); omega)) + have hxv : x.val = ⟨Sum.inl a, + by rw [← hval]; exact x.val.prop.1, + by rw [← hval]; exact x.val.prop.2⟩ := + Subtype.ext hval + have hstep : interfaceStepEquiv s t u x.val = + Sum.inl ⟨a.val, ha'⟩ := by + rw [hxv] + exact interfaceStepEquiv_inl s t u a _ ha' + have hL := interfaceSurvEquiv_inl s t u + ((Fragment.foldSurvivingPermEquiv (by rw [hlist])) + ((Fragment.foldSurvivingMapEquiv (interfaceStepEquiv s t u) + (Fragment.coercePairsList _ _ (tailPairs s t u) + hwf_cons.sep)) x)) + ⟨a.val, ha'⟩ hstep ha + have hR := interfaceSurvEquiv_inl s (t + 1) u + ((Fragment.foldSurvivingPermEquiv + (by rw [interfacePairs_succ s t u] : + (interfacePairs s (t + 1) u).Perm _)).symm + ((Fragment.foldFlatten _ _ (tailPairs s t u) + hwf_cons.sep) x)) + a hval ha + exact hL.trans hR.symm + · have hbne : b ≠ ⟨t, by omega⟩ := by + have h2 := x.val.prop.2 + rw [hval] at h2 + exact fun h => h2 (congrArg Sum.inr h) + have hbt : t < b.val := by + rcases Nat.lt_or_ge b.val t with h | h + · obtain ⟨r, hr, _, hr2⟩ := Fragment.coercePairsList_mem _ _ + (tailPairs s t u) hwf_cons.sep + (Sum.inl ⟨s + b.val, by omega⟩, + Sum.inr ⟨b.val, by omega⟩) + (by exact mem_tailPairs s t u b.val h) + refine absurd (Subtype.ext ?_ : x.val = r.2) (x.prop r hr).2 + rw [hr2, hval] + · rcases Nat.lt_or_ge t b.val with h' | h' + · exact h' + · exact absurd (Fin.ext (show b.val = t by omega)) hbne + have hxv : x.val = ⟨Sum.inr b, + by rw [← hval]; exact x.val.prop.1, + by rw [← hval]; exact x.val.prop.2⟩ := + Subtype.ext hval + have hstep : interfaceStepEquiv s t u x.val = + Sum.inr ⟨b.val - 1, by have := b.isLt; omega⟩ := by + rw [hxv] + exact interfaceStepEquiv_inr_above s t u b _ hbt + have hL := interfaceSurvEquiv_inr s t u + ((Fragment.foldSurvivingPermEquiv (by rw [hlist])) + ((Fragment.foldSurvivingMapEquiv (interfaceStepEquiv s t u) + (Fragment.coercePairsList _ _ (tailPairs s t u) + hwf_cons.sep)) x)) + ⟨b.val - 1, by have := b.isLt; omega⟩ hstep + (by change t ≤ b.val - 1; omega) + have hR := interfaceSurvEquiv_inr s (t + 1) u + ((Fragment.foldSurvivingPermEquiv + (by rw [interfacePairs_succ s t u] : + (interfacePairs s (t + 1) u).Perm _)).symm + ((Fragment.foldFlatten _ _ (tailPairs s t u) + hwf_cons.sep) x)) + b hval (by omega) + refine hL.trans (Eq.trans ?_ hR.symm) + exact congrArg Sum.inr (Fin.ext (by + change b.val - 1 - t = b.val - (t + 1) + omega)) + rw [heqF] + refine Fragment.Equiv.trans + (Fragment.Equiv.relabelTrans _ _ _).symm ?_ + refine Fragment.Equiv.trans (Fragment.Equiv.relabelCongr + ((Fragment.glueList_cons W _ (tailPairs s t u) hwf_cons ▸ + Fragment.glueListEqEquiv W (interfacePairs_succ s t u) + (interfacePairs_wf s (t + 1) u) hwf_cons + (by rw [interfacePairs_succ s t u])).symm) _) ?_ + refine Fragment.Equiv.trans + (Fragment.Equiv.relabelTrans _ _ _) ?_ + have heqG : (Fragment.foldSurvivingPermEquiv + (by rw [interfacePairs_succ s t u] : + (interfacePairs s (t + 1) u).Perm + ((Sum.inl ⟨s + t, Nat.lt_succ_self _⟩, + Sum.inr ⟨t, Nat.lt_of_lt_of_le (Nat.lt_succ_self t) + (Nat.le_add_right _ _)⟩) :: tailPairs s t u))).trans + ((Fragment.foldSurvivingPermEquiv + (by rw [interfacePairs_succ s t u] : + (interfacePairs s (t + 1) u).Perm + ((Sum.inl ⟨s + t, Nat.lt_succ_self _⟩, + Sum.inr ⟨t, Nat.lt_of_lt_of_le (Nat.lt_succ_self t) + (Nat.le_add_right _ _)⟩) :: tailPairs s t u))).symm.trans + (interfaceSurvEquiv s (t + 1) u)) = + interfaceSurvEquiv s (t + 1) u := + Equiv.ext (fun x => by simp) + rw [heqG] + exact Fragment.Equiv.refl _ + +/-- **Composition as a fold**: composing two fragments is the +iterated gluing of the interface pairs in their disjoint union, +relabelled by the surviving-label identification. -/ +noncomputable def composeNormal {s t u : ℕ} + (F : Fragment (Fin (s + t))) (G : Fragment (Fin (t + u))) : + (F.compose G).Equiv + ((Fragment.glueList (F.disjUnion G) (interfacePairs s t u) + (interfacePairs_wf s t u)).relabel + ((interfaceSurvEquiv s t u).trans finSumFinEquiv)) := by + refine Fragment.Equiv.trans ?_ (Fragment.Equiv.relabelTrans _ _ _) + change ((glueInterface s t u (F.disjUnion G)).relabel + finSumFinEquiv).Equiv _ + exact Fragment.Equiv.relabelCongr + (glueInterfaceNormal s u t (F.disjUnion G)) finSumFinEquiv + +/-! ### Boundary permutations across an interface -/ + +/-- Permuting the last `t` labels of `Fin (s + t)`. -/ +def outPermEquiv (s : ℕ) {t : ℕ} (σ : Equiv.Perm (Fin t)) : + Fin (s + t) ≃ Fin (s + t) := + finSumFinEquiv.symm.trans + ((Equiv.sumCongr (Equiv.refl (Fin s)) σ).trans finSumFinEquiv) + +/-- Permuting the first `t` labels of `Fin (t + u)`. -/ +def inPermEquiv {t : ℕ} (σ : Equiv.Perm (Fin t)) (u : ℕ) : + Fin (t + u) ≃ Fin (t + u) := + finSumFinEquiv.symm.trans + ((Equiv.sumCongr σ (Equiv.refl (Fin u))).trans finSumFinEquiv) + +/-- The outgoing permutation fixes the low labels. -/ +theorem outPermEquiv_low (s : ℕ) {t : ℕ} (σ : Equiv.Perm (Fin t)) + (a : Fin s) : + outPermEquiv s σ (Fin.castAdd t a) = Fin.castAdd t a := by + unfold outPermEquiv + simp [finSumFinEquiv_symm_apply_castAdd] + +/-- The outgoing permutation acts on the high labels. -/ +theorem outPermEquiv_high (s : ℕ) {t : ℕ} (σ : Equiv.Perm (Fin t)) + (k : Fin t) : + outPermEquiv s σ (Fin.natAdd s k) = Fin.natAdd s (σ k) := by + unfold outPermEquiv + simp [finSumFinEquiv_symm_apply_natAdd] + +/-- The incoming permutation acts on the low labels. -/ +theorem inPermEquiv_low {t : ℕ} (σ : Equiv.Perm (Fin t)) (u : ℕ) + (k : Fin t) : + inPermEquiv σ u (Fin.castAdd u k) = Fin.castAdd u (σ k) := by + unfold inPermEquiv + simp [finSumFinEquiv_symm_apply_castAdd] + +/-- The incoming permutation fixes the high labels. -/ +theorem inPermEquiv_high {t : ℕ} (σ : Equiv.Perm (Fin t)) (u : ℕ) + (b : Fin u) : + inPermEquiv σ u (Fin.natAdd t b) = Fin.natAdd t b := by + unfold inPermEquiv + simp [finSumFinEquiv_symm_apply_natAdd] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeRelabel.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeRelabel.lean new file mode 100644 index 0000000000..c9f904bc89 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeRelabel.lean @@ -0,0 +1,252 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PermCompose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLawRight + +/-! +# Free-side relabels pass through composition + +Relabelling the free (non-interface) boundary of a factor +relabels the composite: permuting the outgoing boundary of the +right factor commutes with `compose` (`composeRelabelOut`), +because the interface pairs are untouched. That is the naturality +law of the boundary identifications, and the engine that lets a +permutation fragment be absorbed into a relabel +(`composePermFragment`, `permFragmentComposeLeft`). + +The outgoing relabel's own inverse law (`outPermEquiv_symm`, with +its two halves `outPermEquiv_symm_low` and +`outPermEquiv_symm_high`) lives here too, since it is what lets the +absorption run in either direction. +-/ + +@[expose] public section + +namespace RS + +/-- The inverse outgoing permutation fixes low labels. -/ +theorem outPermEquiv_symm_low (s : ℕ) {t : ℕ} + (σ : Equiv.Perm (Fin t)) (a : Fin s) : + (outPermEquiv s σ).symm (Fin.castAdd t a) = Fin.castAdd t a := + (_root_.Equiv.symm_apply_eq _).mpr + (outPermEquiv_low s σ a).symm + +/-! ### The interface pairs are untouched -/ + +/-- The inverse of an outgoing permutation is the outgoing +inverse permutation. -/ +theorem outPermEquiv_symm (s : ℕ) {t : ℕ} + (σ : Equiv.Perm (Fin t)) : + (outPermEquiv s σ).symm = outPermEquiv s σ.symm := by + apply _root_.Equiv.ext + intro x + by_cases h : x.val < s + · rw [show x = Fin.castAdd t (⟨x.val, h⟩ : Fin s) from + Fin.ext rfl, outPermEquiv_symm_low, outPermEquiv_low] + · have hk : x.val - s < t := by have := x.isLt; omega + rw [show x = Fin.natAdd s (⟨x.val - s, hk⟩ : Fin t) from + Fin.ext (by change x.val = s + (x.val - s); omega), + outPermEquiv_symm_high, outPermEquiv_high] + +private theorem out_ground_aux (s t u : ℕ) + (σ : Equiv.Perm (Fin u)) : + ∀ (l : List (Fin t)), + Fragment.mapPairs + (_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (s + t))) + (outPermEquiv t σ)).symm + (l.map (fun k => + ((Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩ : + Fin (s + t) ⊕ Fin (t + u)), + Sum.inr ⟨k.val, by have := k.isLt; omega⟩))) = + l.map (fun k => + ((Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩ : + Fin (s + t) ⊕ Fin (t + u)), + Sum.inr ⟨k.val, by have := k.isLt; omega⟩)) + | [] => rfl + | k :: l => by + simp only [List.map_cons, Fragment.mapPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext rfl ?_) + (out_ground_aux s t u σ l) + change Sum.inr ((outPermEquiv t σ).symm + ⟨k.val, by have := k.isLt; omega⟩) = _ + refine congrArg Sum.inr ?_ + rw [show (⟨k.val, by have := k.isLt; omega⟩ : Fin (t + u)) = + Fin.castAdd u k from Fin.ext rfl, + outPermEquiv_symm_low] + +/-- Peeling an outgoing permutation of the right factor leaves +the interface pairs untouched. -/ +theorem out_ground (s t u : ℕ) (σ : Equiv.Perm (Fin u)) : + Fragment.mapPairs + (_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (s + t))) + (outPermEquiv t σ)).symm + (interfacePairs s t u) = interfacePairs s t u := by + unfold interfacePairs + exact out_ground_aux s t u σ (List.finRange t).reverse + +/-! ### The outgoing relabel -/ + +/-- The peeled pairs of the outgoing relabel. -/ +noncomputable def outQs (s t u : ℕ) (σ : Equiv.Perm (Fin u)) := + Fragment.mapPairs + (_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (s + t))) + (outPermEquiv t σ)).symm + (interfacePairs s t u) + +/-- The label meet of the outgoing relabel: the survivor chase. -/ +theorem out_label_meet (s t u : ℕ) (σ : Equiv.Perm (Fin u)) : + (Fragment.foldSurvivingPermEquiv + ((out_ground s t u σ) ▸ List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (s + t))) + (outPermEquiv t σ)) + (outQs s t u σ)).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (s + t))) + (outPermEquiv t σ)) + (interfacePairs s t u)).symm ▸ + List.Perm.refl _)).symm.trans + ((interfaceSurvEquiv s t u).trans finSumFinEquiv))) = + ((interfaceSurvEquiv s t u).trans finSumFinEquiv).trans + (outPermEquiv s σ) := by + apply _root_.Equiv.ext + intro x + obtain ⟨xv, hx⟩ := x + have hpred := (interfaceSurv_iff s t u xv).mp + ((forall_ne_iff_not_mem_flat _ xv).mp hx) + rcases xv with a | b + · change finSumFinEquiv (interfaceSurvEquiv s t u + ⟨Sum.inl a, hx⟩) = + outPermEquiv s σ (finSumFinEquiv (interfaceSurvEquiv s t u + ⟨Sum.inl a, hx⟩)) + rw [interfaceSurvEquiv_inl s t u ⟨Sum.inl a, hx⟩ a rfl hpred, + finSumFinEquiv_apply_left, outPermEquiv_low] + · have hb : t ≤ b.val := Nat.le_of_not_lt hpred + have hj : b.val - t < u := by have := b.isLt; omega + have hb2 : b = Fin.natAdd t ⟨b.val - t, hj⟩ := + Fin.ext (by change b.val = t + (b.val - t); omega) + have hbv : outPermEquiv t σ b = + Fin.natAdd t (σ ⟨b.val - t, hj⟩) := by + conv_lhs => rw [hb2] + exact outPermEquiv_high t σ ⟨b.val - t, hj⟩ + have hsurvL : ∀ p ∈ interfacePairs s t u, + (Sum.inr (outPermEquiv t σ b) : + Fin (s + t) ⊕ Fin (t + u)) ≠ p.1 ∧ + (Sum.inr (outPermEquiv t σ b) : + Fin (s + t) ⊕ Fin (t + u)) ≠ p.2 := + (forall_ne_iff_not_mem_flat _ _).mpr + ((interfaceSurv_iff s t u _).mpr + (by change ¬ (outPermEquiv t σ b).val < t + rw [hbv] + change ¬ t + (σ ⟨b.val - t, hj⟩).val < t + omega)) + change finSumFinEquiv (interfaceSurvEquiv s t u + ⟨Sum.inr (outPermEquiv t σ b), hsurvL⟩) = + outPermEquiv s σ (finSumFinEquiv (interfaceSurvEquiv s t u + ⟨Sum.inr b, hx⟩)) + rw [interfaceSurvEquiv_inr s t u + ⟨Sum.inr (outPermEquiv t σ b), hsurvL⟩ _ rfl + (by rw [hbv]; change t ≤ t + _; omega), + interfaceSurvEquiv_inr s t u ⟨Sum.inr b, hx⟩ b rfl hb, + finSumFinEquiv_apply_right, finSumFinEquiv_apply_right, + outPermEquiv_high] + refine congrArg (Fin.natAdd s) ?_ + refine Fin.ext ?_ + change (outPermEquiv t σ b).val - t = (σ ⟨b.val - t, hj⟩).val + rw [hbv] + change t + (σ ⟨b.val - t, hj⟩).val - t = (σ ⟨b.val - t, hj⟩).val + omega + +/-- **Outgoing relabels pass through composition**: permuting the +outgoing boundary of the right factor permutes the outgoing +boundary of the composite. -/ +noncomputable def composeRelabelOut {s t u : ℕ} + (σ : Equiv.Perm (Fin u)) (F : Fragment (Fin (s + t))) + (G : Fragment (Fin (t + u))) : + (F.compose (G.relabel (outPermEquiv t σ))).Equiv + ((F.compose G).relabel (outPermEquiv s σ)) := by + let e := _root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (s + t))) (outPermEquiv t σ) + let qs := outQs s t u σ + have wfqs : Fragment.PairsWF qs := + Fragment.mapPairs_wf e.symm _ (interfacePairs_wf s t u) + let Amb := F.disjUnion G + -- C5: bridge the peeled pairs to the interface pairs. + have C5 : (Fragment.glueList Amb qs wfqs).Equiv + ((Fragment.glueList Amb (interfacePairs s t u) + (interfacePairs_wf s t u)).relabel + (Fragment.foldSurvivingPermEquiv + ((out_ground s t u σ) ▸ List.Perm.refl _)).symm) := + Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv Amb (out_ground s t u σ) + wfqs (interfacePairs_wf s t u) + (List.Perm.of_eq (out_ground s t u σ))) + -- C3: the relabelling stage. + have C3 := (Fragment.glueListRelabel Amb e qs wfqs).trans + ((Fragment.Equiv.relabelCongr C5 + (Fragment.foldSurvivingMapEquiv e qs)).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- C2: bridge the interface pairs. + have C2 := (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (Amb.relabel e) + (mapPairs_symm_cancel e (interfacePairs s t u)).symm + (interfacePairs_wf s t u) + (Fragment.mapPairs_wf e _ wfqs) + (List.Perm.of_eq (mapPairs_symm_cancel e + (interfacePairs s t u)).symm))).trans + ((Fragment.Equiv.relabelCongr C3 + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel e + (interfacePairs s t u)).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- C1: transport across the peel. + have C1 := (Fragment.glueListCongr + (Fragment.relabelDisjUnionRight F G (outPermEquiv t σ)) + (interfacePairs s t u) (interfacePairs_wf s t u)).trans C2 + -- Assemble both sides. + exact (composeNormal F (G.relabel (outPermEquiv t σ))).trans + ((Fragment.Equiv.relabelCongr C1 + ((interfaceSurvEquiv s t u).trans finSumFinEquiv)).trans + ((Fragment.Equiv.relabelTrans _ _ _).trans + ((Fragment.Equiv.relabelEq _ (out_label_meet s t u σ)).trans + ((Fragment.Equiv.relabelTrans _ _ _).symm.trans + (Fragment.Equiv.relabelCongr + (composeNormal F G).symm (outPermEquiv s σ)))))) + +/-! ### Permutation fragments absorb into relabels -/ + +/-- Composing with a permutation fragment on the right relabels +the outgoing boundary. -/ +noncomputable def composePermFragment {s t : ℕ} + (σ : Equiv.Perm (Fin t)) (F : Fragment (Fin (s + t))) : + (F.compose (permFragment σ)).Equiv + (F.relabel (outPermEquiv s σ)) := + (Fragment.composeCongr (Fragment.Equiv.refl F) + (permFragmentRelabelOutPerm σ)).trans + ((composeRelabelOut σ F (strandBundle t)).trans + (Fragment.Equiv.relabelCongr + (composeStrandBundleRight s t F) (outPermEquiv s σ))) + +/-- Composing with a permutation fragment on the left relabels +the incoming boundary by the inverse. -/ +noncomputable def permFragmentComposeLeft {t u : ℕ} + (σ : Equiv.Perm (Fin t)) (F : Fragment (Fin (t + u))) : + ((permFragment σ).compose F).Equiv + (F.relabel (inPermEquiv σ.symm u)) := + (Fragment.composeCongr (permFragmentRelabelOutPerm σ) + (Fragment.Equiv.refl F)).trans + ((interfaceShift σ (strandBundle t) F).trans + (composeStrandBundleLeft t u + (F.relabel (inPermEquiv σ.symm u)))) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/Composition.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/Composition.lean new file mode 100644 index 0000000000..ca667920a5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/Composition.lean @@ -0,0 +1,107 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FlagGraph + +/-! +# Fragment composition + +Composition of fragments (`Fragment.compose`, defined in +`RS/Definitions.lean`) glues the last `t` boundary labels of an +`(s + t)`-fragment to the first `t` of a `(t + u)`-fragment through +the iterated single-pair primitive, re-indexing the surviving +labels by one-point removals. + +This module carries the value computations for those removals: the +gluing chain rewrites boundary states through the re-indexings, so +it needs each surviving label's new index as an explicit natural +number. +-/ + +@[expose] public section + +namespace RS + +/-! ### Value computation for the one-point removals + +A removal is inverted by `Fin.succAbove`, which shifts the indices +at or above the removed point up by one. Reading that off gives +each surviving label's new index as an explicit natural number. -/ + +/-- `Fin.succAbove` shifts the indices at or above `a` up by one. -/ +private theorem succAbove_val_ite {n : ℕ} (a : Fin (n + 1)) (y : Fin n) : + ((a.succAbove y : Fin (n + 1)) : ℕ) = + if (y : ℕ) < (a : ℕ) then (y : ℕ) else (y : ℕ) + 1 := by + by_cases hc : Fin.castSucc y < a + · rw [Fin.succAbove_of_castSucc_lt _ _ hc] + have h1 : (y : ℕ) < (a : ℕ) := hc + rw [ite_eq_left h1] + rfl + · have hc' : a ≤ Fin.castSucc y := not_lt.mp hc + rw [Fin.succAbove_of_le_castSucc _ _ hc'] + have h1 : (a : ℕ) ≤ (y : ℕ) := hc' + rw [ite_eq_right (not_lt.mpr h1)] + rfl + +/-- Inverting that shift: a label above the removed point drops by +one, a label below it keeps its index. -/ +private theorem removed_val_ite {n : ℕ} {a : Fin (n + 1)} {y : Fin n} + {v : ℕ} (h : ((a.succAbove y : Fin (n + 1)) : ℕ) = v) : + (y : ℕ) = if v < (a : ℕ) then v else v - 1 := by + rw [succAbove_val_ite] at h + by_cases hc : (y : ℕ) < (a : ℕ) + · rw [ite_eq_left hc] at h + rw [ite_eq_left (by omega)] + omega + · rw [ite_eq_right hc] at h + rw [ite_eq_right (by omega)] + omega + +/-- `Fin.succAbove` at the removed point inverts `finRemoveEquiv`. -/ +theorem finRemoveEquiv_apply_val {n : ℕ} (a : Fin (n + 1)) + (x : {x : Fin (n + 1) // x ≠ a}) : + a.succAbove (finRemoveEquiv a x) = x.val := + congrArg Subtype.val ((finRemoveEquiv a).symm_apply_apply x) + +/-- The index a surviving label takes after a one-point removal. -/ +theorem finRemoveEquiv_val {n : ℕ} (a : Fin (n + 1)) + (x : {x : Fin (n + 1) // x ≠ a}) : + (finRemoveEquiv a x : ℕ) = + if (x.val : ℕ) < (a : ℕ) then (x.val : ℕ) else (x.val : ℕ) - 1 := + removed_val_ite (congrArg Fin.val (finRemoveEquiv_apply_val a x)) + +/-- Removing the top point leaves every surviving label's index +unchanged. -/ +theorem finRemoveEquiv_top_val {n : ℕ} + (x : {x : Fin (n + 1) // x ≠ ⟨n, Nat.lt_succ_self n⟩}) : + (finRemoveEquiv ⟨n, Nat.lt_succ_self n⟩ x : ℕ) = (x.val : ℕ) := by + have h := finRemoveEquiv_val ⟨n, Nat.lt_succ_self n⟩ x + have hx : (x.val : ℕ) ≠ n := fun hh => x.prop (Fin.ext hh) + have hb : (x.val : ℕ) < n + 1 := x.val.isLt + have ha : ((⟨n, Nat.lt_succ_self n⟩ : Fin (n + 1)) : ℕ) = n := rfl + rw [h, ha, ite_eq_left (by omega)] + +/-- `Fin.succAbove` at `t` inverts `rightRemoveEquiv`. -/ +theorem rightRemoveEquiv_apply_val (t u : ℕ) + (x : {x : Fin (t + 1 + u) // x ≠ ⟨t, by omega⟩}) : + (((⟨t, by omega⟩ : Fin (t + u + 1)).succAbove + (rightRemoveEquiv t u x) : Fin (t + u + 1)) : ℕ) = + (x.val : ℕ) := + congrArg (fun z : {x : Fin (t + 1 + u) // x ≠ ⟨t, by omega⟩} => + (z.val : ℕ)) + ((rightRemoveEquiv t u).symm_apply_apply x) + +/-- The index a surviving label takes after removing label `t` on +the right. -/ +theorem rightRemoveEquiv_val (t u : ℕ) + (x : {x : Fin (t + 1 + u) // x ≠ ⟨t, by omega⟩}) : + (rightRemoveEquiv t u x : ℕ) = + if (x.val : ℕ) < t then (x.val : ℕ) else (x.val : ℕ) - 1 := + removed_val_ite (rightRemoveEquiv_apply_val t u x) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CompositionEquiv.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CompositionEquiv.lean new file mode 100644 index 0000000000..049abf15ea --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CompositionEquiv.lean @@ -0,0 +1,45 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StrandBundle + +/-! +# Composition respects fragment equivalence + +Interface gluing and composition are congruences for the +relabelling equivalence of fragments: equivalent inputs glue to +equivalent outputs. These are the transport lemmas through which +every up-to-isomorphism identity about composition is proved. +-/ + +@[expose] public section + +namespace RS + +/-- Interface gluing respects fragment equivalence. -/ +noncomputable def glueInterfaceCongr (s : ℕ) : + (t : ℕ) → (u : ℕ) → {W₁ W₂ : Fragment (Fin (s + t) ⊕ Fin (t + u))} → + W₁.Equiv W₂ → + (glueInterface s t u W₁).Equiv (glueInterface s t u W₂) + | 0, _, _, _, h => Fragment.Equiv.relabelCongr h _ + | t + 1, u, W₁, W₂, h => + glueInterfaceCongr s t u + (Fragment.Equiv.relabelCongr + (Fragment.Equiv.gluePairCongr h (by simp)) (interfaceStepEquiv s t + u)) + +/-- Composition respects fragment equivalence in both arguments. -/ +noncomputable def Fragment.composeCongr {s t u : ℕ} + {F₁ F₂ : Fragment (Fin (s + t))} {G₁ G₂ : Fragment (Fin (t + u))} + (hF : F₁.Equiv F₂) (hG : G₁.Equiv G₂) : + (F₁.compose G₁).Equiv (F₂.compose G₂) := + Fragment.Equiv.relabelCongr + (glueInterfaceCongr s t u (Fragment.Equiv.disjUnionCongr hF hG)) + finSumFinEquiv + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConnectionRank.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConnectionRank.lean new file mode 100644 index 0000000000..662fa636b0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConnectionRank.lean @@ -0,0 +1,61 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.RowSpanRank +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FragmentEquiv + +/-! +# Connection pairings and the edge-rank hypothesis + +The hypothesis class of the main theorem — `pairClose`, the +connection pairing, `EdgeRankBounded` and `EdgeRankParameter` — is +defined in `RS/Definitions.lean`: ranks of infinite matrices are +avoided by bounding the `Module.rank` of the range of the curried +pairing. + +This module proves the two facts about it: the bound weakens as the +base grows (`EdgeRankBounded.mono` — the literature takes `R ≥ 1` +where the definition admits any natural number, and nothing is +gained or lost), and the row-span reading agrees with the +literature's supremum over finite submatrices +(`edgeRankBounded_iff_submatrixRank`). +-/ + +@[expose] public section + +namespace RS + +/-- Edge-rank boundedness is monotone in the base. -/ +theorem EdgeRankBounded.mono {f : ClosedFragment → ℂ} {R R' : ℕ} + (hf : EdgeRankBounded f R) (hRR : R ≤ R') : + EdgeRankBounded f R' := fun t => + le_trans (hf t) (Cardinal.power_le_power_right + (by exact_mod_cast hRR)) + +/-- The rank condition as the literature states it, at arity `t`: +every finite submatrix of the connection matrix — a finite set `S` of +row fragments against a finite set `T` of column fragments — has rank +at most `n`. -/ +def SubmatrixRankBounded (f : ClosedFragment → ℂ) (t n : ℕ) : Prop := + ∀ S T : Finset (Fragment (Fin t)), + (submatrixOn (connectionPairing f t) S T).rank ≤ n + +/-- **The two readings of the connection rank agree.** Bounding the +dimension of the row span of the connection pairing, as +`EdgeRankBounded` does, is the same condition as bounding the ranks of +all the finite submatrices of the connection matrix, which is how the +rank of that infinite matrix is defined in the literature. -/ +theorem edgeRankBounded_iff_submatrixRank (f : ClosedFragment → ℂ) + (R : ℕ) : + EdgeRankBounded f R ↔ ∀ t : ℕ, SubmatrixRankBounded f t (R ^ t) := by + refine forall_congr' fun t => ?_ + have h := rank_range_lift_le_iff (connectionPairing f t) (R ^ t) + rw [Nat.cast_pow] at h + exact h + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseAssembly.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseAssembly.lean new file mode 100644 index 0000000000..57a37f68c3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseAssembly.lean @@ -0,0 +1,2024 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RSTensor +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedIdentify +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedTopSum + +/-! +# The closure of two fragments, read on the base + +The connection pairing evaluates the mixed partition function at +`pairClose F G`, which is the interface glue of the two fragments' +disjoint union, relabelled to the empty label type. Composing the +closed identification with the colouring recursion writes that value +as the base's summands, summed over its subsets and over the +interface colours. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + +open Fragment +/-- The lexicographic order on the interface's label type. -/ +@[reducible] local instance assemblyBaseOrder (n : ℕ) : + LinearOrder (Fin (0 + n) ⊕ Fin (n + 0)) := + sumLexLinearOrder _ _ + +/-- The same order one stage up. -/ +@[reducible] local instance assemblyOrderSucc (n : ℕ) : + LinearOrder (Fin (0 + n + 1) ⊕ Fin (n + 1 + 0)) := + sumLexLinearOrder _ _ + +/-- The order a stage's surviving labels carry. -/ +@[reducible] local instance assemblySurvOrder (n : ℕ) : + LinearOrder (SurvivingLabel + (Fin (0 + n + 1) ⊕ Fin (n + 1 + 0)) (cutL n) (cutR n)) := + sumLexSubtypeLinearOrder _ _ _ + +/-- The order the composition's own label type carries. -/ +@[reducible] local instance assemblyTopOrder : + LinearOrder (Fin 0 ⊕ Fin 0) := + sumLexLinearOrder _ _ + +/-- The two fragments, moved onto the interface's label type. -/ +noncomputable abbrev closeBase {t : ℕ} (F G : Fragment (Fin t)) : + Fragment (Fin (0 + t) ⊕ Fin (t + 0)) := + (F.relabel (finCongr (by omega : t = 0 + t))).disjUnion + (G.relabel (finCongr (by omega : t = t + 0))) + +/-- The closure is the interface glue, relabelled. -/ +theorem pairClose_eq {t : ℕ} (F G : Fragment (Fin t)) : + pairClose F G + = (glueInterface 0 t 0 (closeBase F G)).relabel + finSumFinEquiv := rfl + +open Classical in +/-- **The closure's value is the interface glue's constrained +value.** -/ +theorem mixedPartition_pairClose {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (t : ℕ) (F G : Fragment (Fin t)) : + mixedPartition h (pairClose F G) + = throughMixedPartitionC h + (glueInterface 0 t 0 (closeBase F G)) emptyState := by + exact mixedPartition_relabel_closed_of_eq + (glueInterface 0 t 0 (closeBase F G)) finSumFinEquiv + (pairClose_eq F G) h emptyState + +/-! ## The tensor side, split over subsets + +The closing display of RS21's Theorem 6 sums the identity (13) +over the Eulerian subsets of the two fragments. Splitting the +fragment tensors into their per-subset terms and exchanging the +four sums puts the pairing in that form. +-/ + +open Classical in +/-- A fragment tensor's term at one subset. -/ +noncomputable def tensorTermAt {α : Type} [LinearOrder α] + [Fintype α] (V : Fragment α) {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (s : Finset V.Flag) (x : GenBoundaryState k ℓ α) : ℂ := + if hc : ∀ f ∈ s, V.pairing f ∈ s then + if _hE : (EdgeSubset.mk s hc).Eulerian then + if hne : Nonempty (EdgeSubset.mk s hc).CanonData then + (EdgeSubset.mk s hc).tFull h (Classical.choice hne).1 + (Classical.choice hne).2.val x + else 0 + else 0 + else 0 + +open Classical in +/-- The fragment tensor is the sum of its terms. -/ +theorem tensorSum_eq_sum {α : Type} [LinearOrder α] [Fintype α] + (V : Fragment α) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (x : GenBoundaryState k ℓ α) : + tensorSum V h x = ∑ s : Finset V.Flag, tensorTermAt V h s x := + rfl + +open Classical in +/-- A tensor term at a good subset is the normalised tensor. -/ +theorem tensorTermAt_pos {α : Type} [LinearOrder α] [Fintype α] + (V : Fragment α) {k ℓ : ℕ} (h : MixedFunctional k ℓ) + {s : Finset V.Flag} (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) + (x : GenBoundaryState k ℓ α) : + tensorTermAt V h s x + = (EdgeSubset.mk s hc).tFull h (Classical.choice hne).1 + (Classical.choice hne).2.val x := by + unfold tensorTermAt + rw [dite_eq_left hc, dite_eq_left hE, dite_eq_left hne] + +open Classical in +/-- **The pair term when the two subsets use the same labels.** This +is RS21's (13), read on the two fragment tensors' per-subset terms: +the pairing is the two circuit-and-matching signs times the colouring +sum of the two subsets' agreement. -/ +theorem exists_sum_sum_superForm_tensorTermAt {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (t : ℕ) (F G : Fragment (Fin t)) + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + (hE₁ : (EdgeSubset.mk s₁ hc₁).Eulerian) + (hn₁ : Nonempty (EdgeSubset.mk s₁ hc₁).CanonData) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (hE₂ : (EdgeSubset.mk s₂ hc₂).Eulerian) + (hn₂ : Nonempty (EdgeSubset.mk s₂ hc₂).CanonData) + (_hused : ∀ i : Fin t, + F.boundaryFlag i ∈ s₁ ↔ G.boundaryFlag i ∈ s₂) + (hb : ∀ i : Fin t, + F.boundaryFlag i ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags + ↔ G.boundaryFlag i ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags) : + ∃ (o₁' : (Classical.choice hn₁).1.Orientation) + (o₂' : (Classical.choice hn₂).1.Orientation) + (M₁ : DirMatching (UsedLab (EdgeSubset.mk s₁ hc₁))) + (M₂ : DirMatching (UsedLab (EdgeSubset.mk s₂ hc₂))), + (∀ a : UsedLab (EdgeSubset.mk s₁ hc₁), (M₁.edge a).val + = chordInv (EdgeSubset.mk s₁ hc₁) + (Classical.choice hn₁).1 a.val) ∧ + (∀ b : UsedLab (EdgeSubset.mk s₂ hc₂), (M₂.edge b).val + = chordInv (EdgeSubset.mk s₂ hc₂) + (Classical.choice hn₂).1 b.val) ∧ + (∀ a : UsedLab (EdgeSubset.mk s₁ hc₁), + M₂.tail (usedLabInterfaceEquiv (EdgeSubset.mk s₁ hc₁) + (EdgeSubset.mk s₂ hc₂) hb a) + = !M₁.tail a) ∧ + (∀ a : UsedLab (EdgeSubset.mk s₁ hc₁), + ¬ IsThroughLabel (EdgeSubset.mk s₁ hc₁) a.val → + M₁.tail a = (cutMatching (EdgeSubset.mk s₁ hc₁) + (Classical.choice hn₁).1 o₁').tail a) ∧ + (∀ b : UsedLab (EdgeSubset.mk s₂ hc₂), + ¬ IsThroughLabel (EdgeSubset.mk s₂ hc₂) b.val → + M₂.tail b = (cutMatching (EdgeSubset.mk s₂ hc₂) + (Classical.choice hn₂).1 o₂').tail b) ∧ + (∀ a : UsedLab (EdgeSubset.mk s₁ hc₁), + ¬ IsThroughLabel (EdgeSubset.mk s₁ hc₁) a.val → + ¬ IsThroughLabel (EdgeSubset.mk s₂ hc₂) + (usedLabInterfaceEquiv (EdgeSubset.mk s₁ hc₁) + (EdgeSubset.mk s₂ hc₂) hb a).val → + (cutMatching (EdgeSubset.mk s₂ hc₂) + (Classical.choice hn₂).1 o₂').tail + (usedLabInterfaceEquiv (EdgeSubset.mk s₁ hc₁) + (EdgeSubset.mk s₂ hc₂) hb a) + = !(cutMatching (EdgeSubset.mk s₁ hc₁) + (Classical.choice hn₁).1 o₁').tail a) ∧ + (∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * tensorTermAt F h s₁ x + * tensorTermAt G h s₂ y) + = (((DirMatching.sgnRel (DirMatching.stdMatching + (card_usedLab_eq (EdgeSubset.mk s₁ hc₁) M₁)) M₁ + : ℤ) : ℂ) + * ((-1 : ℂ) ^ (Classical.choice hn₁).1.openCircuitCount) + * (((DirMatching.sgnRel (DirMatching.stdMatching + (card_usedLab_eq (EdgeSubset.mk s₂ hc₂) M₂)) M₂ + : ℤ) : ℂ) + * ((-1 : ℂ) ^ + (Classical.choice hn₂).1.openCircuitCount))) + * ∑ st : GenBoundaryState k ℓ (Fin t), + pairAgreeValue (EdgeSubset.mk s₁ hc₁) + (EdgeSubset.mk s₂ hc₂) h o₁' o₂' st := by + have hcard : Fintype.card (UsedLab (EdgeSubset.mk s₂ hc₂)) + = Fintype.card (UsedLab (EdgeSubset.mk s₁ hc₁)) := + Fintype.card_congr + (usedLabInterfaceEquiv (EdgeSubset.mk s₁ hc₁) + (EdgeSubset.mk s₂ hc₂) hb).symm + obtain ⟨o₁', o₂', M₁, M₂, hM₁, hM₂, halt, hag₁, hag₂, halt', + hval⟩ := + exists_sum_sum_superForm_tFull (EdgeSubset.mk s₁ hc₁) + (EdgeSubset.mk s₂ hc₂) h (Classical.choice hn₁).1 + (Classical.choice hn₁).2.val (Classical.choice hn₂).1 + (Classical.choice hn₂).2.val + (Fintype.card (UsedLab (EdgeSubset.mk s₁ hc₁)) / 2) + (card_usedLab_eq _ (cutMatching (EdgeSubset.mk s₁ hc₁) _ + (Classical.choice hn₁).2.val)) + (by + rw [hcard] + exact card_usedLab_eq _ (cutMatching (EdgeSubset.mk s₁ hc₁) _ + (Classical.choice hn₁).2.val)) + hb + refine ⟨o₁', o₂', M₁, M₂, hM₁, hM₂, halt, hag₁, hag₂, halt', + ?_⟩ + simp only [tensorTermAt_pos F h hc₁ hE₁ hn₁, + tensorTermAt_pos G h hc₂ hE₂ hn₂] + exact hval + +/-! ## The diagonal state on the two sides + +The interface colours enter the base as one state on the disjoint +union. Restricting it to either summand and pulling back along that +fragment's relabel gives the colours themselves, which is the form +`relabel_edgeSum` and `edgeSum_disjUnion` consume. +-/ + +/-- The diagonal state, restricted to the left fragment. -/ +theorem diagOf_inl_relabel {k ℓ : ℕ} (t : ℕ) + (x : GenBoundaryState k ℓ (Fin t)) : + (fun a : Fin t => diagOf t x + (Sum.inl (finCongr (by omega : t = 0 + t) a))) = x := + funext fun a => congrArg x (Fin.ext (by simp)) + +/-- The diagonal state, restricted to the right fragment. -/ +theorem diagOf_inr_relabel {k ℓ : ℕ} (t : ℕ) + (x : GenBoundaryState k ℓ (Fin t)) : + (fun b : Fin t => diagOf t x + (Sum.inr (finCongr (by omega : t = t + 0) b))) = x := + funext fun b => congrArg x (Fin.ext (by simp)) + +/-! ## The base's colouring sum, split into the two fragments' + +The base is the two fragments' disjoint union, so its colouring sum +factors; each factor then comes down to its own fragment along that +fragment's relabel. +-/ + +open Classical in +/-- **The base's colouring sum factors.** -/ +theorem edgeSum_closeBase {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (t : ℕ) (F G : Fragment (Fin t)) + (B : EdgeSubset (closeBase F G)) + (st : GenBoundaryState k ℓ (Fin (0 + t) ⊕ Fin (t + 0))) + (hbnd : genBoundarySubsetMatches (closeBase F G) B.flags st) + (hbnd₁ : genBoundarySubsetMatches + (F.relabel (finCongr (by omega : t = 0 + t))) + (leftSub B).flags (fun a => st (Sum.inl a))) + (hbnd₂ : genBoundarySubsetMatches + (G.relabel (finCongr (by omega : t = t + 0))) + (rightSub B).flags (fun b => st (Sum.inr b))) + {κ₁ : (leftSub B).RelTransitionSystem} + {κ₂ : (rightSub B).RelTransitionSystem} + (o₁ : κ₁.Orientation) (o₂ : κ₂.Orientation) : + B.edgeSum h st hbnd (prodOrient o₁ o₂) + = (leftSub B).edgeSum h (fun a => st (Sum.inl a)) hbnd₁ o₁ + * (rightSub B).edgeSum h (fun b => st (Sum.inr b)) hbnd₂ + o₂ := + edgeSum_disjUnion B h st hbnd hbnd₁ hbnd₂ o₁ o₂ + +open Classical in +/-- **A half's colouring sum comes down to its own fragment.** -/ +theorem edgeSum_relabelDown {k ℓ : ℕ} (h : MixedFunctional k ℓ) + {t n : ℕ} (F : Fragment (Fin t)) (he : t = n) + (A : EdgeSubset (F.relabel (finCongr he))) + (st : GenBoundaryState k ℓ (Fin n)) + (st' : GenBoundaryState k ℓ (Fin t)) + (hst : (fun a => st (finCongr he a)) = st') + (hbnd : genBoundarySubsetMatches (F.relabel (finCongr he)) + A.flags st) + (hbnd' : genBoundarySubsetMatches F + (EdgeSubset.relabelDown (finCongr he) A).flags st') + {κ : (EdgeSubset.relabelDown (finCongr he) A).RelTransitionSystem} + (o : κ.Orientation) : + A.edgeSum h st hbnd + (relabelOrientUp (finCongr he) + (EdgeSubset.relabelDown (finCongr he) A) o) + = (EdgeSubset.relabelDown (finCongr he) A).edgeSum h st' hbnd' + o := by + subst hst + exact relabel_edgeSum (finCongr he) + (EdgeSubset.relabelDown (finCongr he) A) h st hbnd hbnd' o + +open Classical in +/-- **The base's colouring sum is the pair's agreement value.** This +is the composition's side of RS21's (13): the base subset's colouring +sum at a diagonal state is exactly the object the pairing identity +produces. -/ +theorem edgeSum_closeBase_eq_pairAgreeValue {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (t : ℕ) (F G : Fragment (Fin t)) + (x : GenBoundaryState k ℓ (Fin t)) + (B : EdgeSubset (closeBase F G)) + (hbnd : genBoundarySubsetMatches (closeBase F G) B.flags + (diagOf t x)) + (hbnd₁ : genBoundarySubsetMatches F (leftSub B).flags x) + (hbnd₂ : genBoundarySubsetMatches G (rightSub B).flags x) + {κ₁ : (EdgeSubset.relabelDown + (finCongr (by omega : t = 0 + t)) + (leftSub B)).RelTransitionSystem} + {κ₂ : (EdgeSubset.relabelDown + (finCongr (by omega : t = t + 0)) + (rightSub B)).RelTransitionSystem} + (o₁ : κ₁.Orientation) (o₂ : κ₂.Orientation) : + B.edgeSum h (diagOf t x) hbnd + (prodOrient + (relabelOrientUp (finCongr (by omega : t = 0 + t)) + (EdgeSubset.relabelDown _ (leftSub B)) o₁) + (relabelOrientUp (finCongr (by omega : t = t + 0)) + (EdgeSubset.relabelDown _ (rightSub B)) o₂)) + = pairAgreeValue + (EdgeSubset.relabelDown (finCongr (by omega : t = 0 + t)) + (leftSub B)) + (EdgeSubset.relabelDown (finCongr (by omega : t = t + 0)) + (rightSub B)) h o₁ o₂ x := by + have hb₁ : genBoundarySubsetMatches + (F.relabel (finCongr (by omega : t = 0 + t))) + (leftSub B).flags (fun a => diagOf t x (Sum.inl a)) := by + refine (relabel_genBoundarySubsetMatches_iff + (finCongr (by omega : t = 0 + t)) (leftSub B).flags + (fun a => diagOf t x (Sum.inl a))).mpr ?_ + show genBoundarySubsetMatches F (leftSub B).flags + (fun a => diagOf t x + (Sum.inl (finCongr (by omega : t = 0 + t) a))) + rw [diagOf_inl_relabel] + exact hbnd₁ + have hb₂ : genBoundarySubsetMatches + (G.relabel (finCongr (by omega : t = t + 0))) + (rightSub B).flags (fun b => diagOf t x (Sum.inr b)) := by + refine (relabel_genBoundarySubsetMatches_iff + (finCongr (by omega : t = t + 0)) (rightSub B).flags + (fun b => diagOf t x (Sum.inr b))).mpr ?_ + change genBoundarySubsetMatches G (rightSub B).flags + (fun b => diagOf t x + (Sum.inr (finCongr (by omega : t = t + 0) b))) + rw [diagOf_inr_relabel] + exact hbnd₂ + refine Eq.trans (edgeSum_closeBase h t F G B (diagOf t x) hbnd hb₁ + hb₂ _ _) ?_ + refine Eq.trans (congrArg₂ (· * ·) + (edgeSum_relabelDown h F (by omega : t = 0 + t) (leftSub B) _ x + (diagOf_inl_relabel t x) hb₁ hbnd₁ o₁) + (edgeSum_relabelDown h G (by omega : t = t + 0) (rightSub B) _ x + (diagOf_inr_relabel t x) hb₂ hbnd₂ o₂)) ?_ + exact (pairAgreeValue_eq_edgeSum _ _ h o₁ o₂ x hbnd₁ hbnd₂).symm + +/-! ## Transports of a subset along a relabel + +The colouring recursion and the ledger recursion carry their subsets +along equalities of fragments taken at different points: one before +the stage's relabel, one after. The two agree. +-/ + +/-- **A transport commutes with a relabel.** -/ +theorem flagsOfEq_relabel {L L' : Type} {V₁ V₂ : Fragment L} + (hV : V₁ = V₂) (e : L ≃ L') (t : Finset V₁.Flag) : + flagsOfEq (V₁.relabel e) (V₂.relabel e) + (congrArg (fun X => Fragment.relabel X e) hV) t + = flagsOfEq V₁ V₂ hV t := by + subst hV + rfl + +open Classical in +/-- The transported stage data's subset. -/ +theorem stageDataOfEq_sub_flags {m : ℕ} + {V₁ V₂ : Fragment (Fin (0 + m) ⊕ Fin (m + 0))} (hV : V₁ = V₂) + (Dm : StageData m V₁) : + (stageDataOfEq hV Dm).sub.flags + = flagsOfEq V₁ V₂ hV Dm.sub.flags := by + subst hV + rfl + +open Classical in +/-- **The ledger's step drops the subset**, at a closing cut. -/ +theorem stepData_sub_flags_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (D : StageData (n + 1) V) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) : + (stepData n V D).sub.flags + = flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) D.sub.flags) := by + refine Eq.trans (congrArg (fun X => X.sub.flags) + (show stepData n V D = _ from dite_eq_left hcl)) ?_ + refine Eq.trans (stageDataOfEq_sub_flags _ _) ?_ + exact flagsOfEq_relabel (gluePair_eq_closed n V hcl) + (interfaceStepEquiv 0 n 0) _ + +open Classical in +/-- **The ledger's step drops the subset**, at an open cut. -/ +theorem stepData_sub_flags_open (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (D : StageData (n + 1) V) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) : + (stepData n V D).sub.flags + = flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) + (V.dropSubset (cutL n) (cutR n) D.sub.flags) := by + refine Eq.trans (congrArg (fun X => X.sub.flags) + (show stepData n V D = _ from dite_eq_right hop)) ?_ + refine Eq.trans (stageDataOfEq_sub_flags _ _) ?_ + exact flagsOfEq_relabel (gluePair_eq_open n V hop) + (interfaceStepEquiv 0 n 0) _ + +open Classical in +/-- **The colouring side's carried count is the ledger's.** Both +count the closing cuts whose own edge the subset carries. -/ +theorem carried_eq_glueCount : ∀ (n : ℕ) + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) (D : StageData n V), + carried n V D.sub.flags = glueCount n V D + | 0, _, _ => rfl + | n + 1, V, D => by + have hstep := carried_eq_glueCount n (stepFragment n V) + (stepData n V D) + by_cases hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) + · rw [stepData_sub_flags_closed n V D hcl] at hstep + simp only [carried, glueCount, dite_eq_left hcl, stepBit] + by_cases hm : V.boundaryFlag (cutL n) ∈ D.sub.flags + · have hb : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) + ∧ decide (V.boundaryFlag (cutL n) ∈ D.sub.flags) + = true := ⟨hcl, by simpa using hm⟩ + rw [ite_eq_left hm] + exact congrArg₂ (· + ·) (ite_eq_left hb).symm hstep + · have hb : ¬ (V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) + ∧ decide (V.boundaryFlag (cutL n) ∈ D.sub.flags) + = true) := fun hx => hm (by simpa using hx.2) + rw [ite_eq_right hm] + exact congrArg₂ (· + ·) (ite_eq_right hb).symm hstep + · rw [stepData_sub_flags_open n V D hcl] at hstep + simp only [carried, glueCount, dite_eq_right hcl, stepBit] + have hb : ¬ (V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) + ∧ decide (V.boundaryFlag (cutL n) ∈ D.sub.flags) + = true) := fun hx => hcl hx.1 + exact Eq.trans hstep (Eq.trans (zero_add _).symm + (congrArg₂ (· + ·) (ite_eq_right hb).symm rfl)) + +open Classical in +/-- **The colouring side's image subset is the ledger's.** Both are +the iterated drop of the base subset. -/ +theorem imageOf_eq_glueData_sub : ∀ (n : ℕ) + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) (D : StageData n V), + imageOf n V D.sub.flags = (glueData n V D).sub.flags + | 0, _, _ => rfl + | n + 1, V, D => by + by_cases hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) + · rw [imageOf_succ_closed n V hcl D.sub.flags, + ← stepData_sub_flags_closed n V D hcl] + exact imageOf_eq_glueData_sub n (stepFragment n V) + (stepData n V D) + · rw [imageOf_succ_open n V hcl D.sub.flags, + ← stepData_sub_flags_open n V D hcl] + exact imageOf_eq_glueData_sub n (stepFragment n V) + (stepData n V D) + +/-! ## The base's subsets, split into the two fragments' + +A subset of a disjoint union is a pair of subsets, so the sum over +the base's subsets is the double sum the tensor side carries. +-/ + +section Parts + +variable {α β : Type} {W₁ : Fragment α} {W₂ : Fragment β} + +open Classical in +/-- **A subset of a disjoint union is a pair of subsets.** -/ +noncomputable def partsEquiv (W₁ : Fragment α) (W₂ : Fragment β) : + Finset ((W₁.disjUnion W₂).Flag) + ≃ Finset W₁.Flag × Finset W₂.Flag where + toFun s := (leftPart s, rightPart s) + invFun p := joinParts p.1 p.2 + left_inv s := joinParts_parts s + right_inv p := Prod.ext (leftPart_joinParts p.1 p.2) + (rightPart_joinParts p.1 p.2) + +open Classical in +/-- **The sum over the base's subsets is the double sum.** -/ +theorem sum_subsets_disjUnion {M : Type} [AddCommMonoid M] + (f : Finset ((W₁.disjUnion W₂).Flag) → M) : + (∑ s : Finset ((W₁.disjUnion W₂).Flag), f s) + = ∑ s₁ : Finset W₁.Flag, ∑ s₂ : Finset W₂.Flag, + f (joinParts s₁ s₂) := by + refine Eq.trans (Fintype.sum_equiv (partsEquiv W₁ W₂) _ + (fun p : Finset W₁.Flag × Finset W₂.Flag => + f (joinParts p.1 p.2)) + (fun s => congrArg f (joinParts_parts s).symm)) ?_ + exact Fintype.sum_prod_type _ + +end Parts + +/-- The base subset a pair of subsets makes. -/ +noncomputable abbrev closeJoin {t : ℕ} {F G : Fragment (Fin t)} + (s₁ : Finset F.Flag) (s₂ : Finset G.Flag) : + Finset (closeBase F G).Flag := + joinParts (W₁ := F.relabel (finCongr (by omega : t = 0 + t))) + (W₂ := G.relabel (finCongr (by omega : t = t + 0))) s₁ s₂ + +open Classical in +/-- **The base subset is interface-paired** exactly when the two +fragments' subsets use the same labels. This is (14)'s hypothesis, +read on the pair. -/ +theorem swapPaired_joinParts (t : ℕ) (F G : Fragment (Fin t)) + (s₁ : Finset F.Flag) (s₂ : Finset G.Flag) + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (hused : ∀ i : Fin t, + F.boundaryFlag i ∈ s₁ ↔ G.boundaryFlag i ∈ s₂) : + SwapPaired (EdgeSubset.mk (closeJoin s₁ s₂) hc) + (interfaceSwap (stepIdent t)) := by + refine (swapPaired_iff_interfacePaired + (EdgeSubset.mk (closeJoin s₁ s₂) hc) (stepIdent t)).mpr ?_ + intro a + have hidx : (finCongr (by omega : t = t + 0)).symm (stepIdent t a) + = (finCongr (by omega : t = 0 + t)).symm a := + Fin.ext (by simp [stepIdent]) + constructor + · intro hx + refine boundaryFlag_mem_boundaryFlags ?_ + refine inr_mem_joinParts.mpr ?_ + change G.boundaryFlag ((finCongr (by omega : t = t + 0)).symm + (stepIdent t a)) ∈ s₂ + rw [hidx] + exact (hused _).mp (inl_mem_joinParts.mp + (mem_flags_of_boundaryFlags _ hx)) + · intro hx + refine boundaryFlag_mem_boundaryFlags ?_ + refine inl_mem_joinParts.mpr ?_ + change F.boundaryFlag ((finCongr (by omega : t = 0 + t)).symm a) + ∈ s₁ + refine (hused _).mpr ?_ + rw [← hidx] + exact inr_mem_joinParts.mp (mem_flags_of_boundaryFlags _ hx) + +open Classical in +/-- The base subset a pair makes is closed under the pairing. -/ +theorem closeJoin_pairing_mem {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} {s₂ : Finset G.Flag} + (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) : + ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂ := by + refine (pairing_closed_iff_parts (closeJoin s₁ s₂)).mpr ⟨?_, ?_⟩ + · rw [show leftPart (closeJoin s₁ s₂) = s₁ + from leftPart_joinParts s₁ s₂] + exact hc₁ + · rw [show rightPart (closeJoin s₁ s₂) = s₂ + from rightPart_joinParts s₁ s₂] + exact hc₂ + +open Classical in +/-- **The base subset's left half is the first subset.** -/ +theorem leftSub_closeJoin {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} {s₂ : Finset G.Flag} + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (hc₁ : ∀ f ∈ s₁, + (F.relabel (finCongr (by omega : t = 0 + t))).pairing f + ∈ s₁) : + leftSub (EdgeSubset.mk (closeJoin s₁ s₂) hc) + = (EdgeSubset.mk s₁ hc₁ : EdgeSubset + (F.relabel (finCongr (by omega : t = 0 + t)))) := + EdgeSubset.ext (leftPart_joinParts + (W₁ := F.relabel (finCongr (by omega : t = 0 + t))) + (W₂ := G.relabel (finCongr (by omega : t = t + 0))) s₁ s₂) + +open Classical in +/-- **The base subset's right half is the second subset.** -/ +theorem rightSub_closeJoin {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} {s₂ : Finset G.Flag} + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (hc₂ : ∀ f ∈ s₂, + (G.relabel (finCongr (by omega : t = t + 0))).pairing f + ∈ s₂) : + rightSub (EdgeSubset.mk (closeJoin s₁ s₂) hc) + = (EdgeSubset.mk s₂ hc₂ : EdgeSubset + (G.relabel (finCongr (by omega : t = t + 0)))) := + EdgeSubset.ext (rightPart_joinParts + (W₁ := F.relabel (finCongr (by omega : t = 0 + t))) + (W₂ := G.relabel (finCongr (by omega : t = t + 0))) s₁ s₂) + +/-! ## The matchings under a relabel + +RS21's (13) produces its matchings on the fragments' own subsets; +(14) asks for them on the halves of the base subset, which live one +relabel away. The used labels correspond (`usedLabRelabelEquiv`) and +the chord matching shifts with them (`cutMatching_relabelUp_edge`); +what is left is the sign. +-/ + +open Classical in +/-- **A matching's sign survives a transport.** The two fragments' +matchings may therefore be read on the base subset's halves, where +(14) wants them. -/ +theorem sgnRel_stdMatching_map {α β : Type} [LinearOrder α] + [Fintype α] [LinearOrder β] [Fintype β] (e : α ≃o β) {m : ℕ} + (h : Fintype.card α = 2 * m) (h' : Fintype.card β = 2 * m) + (M : DirMatching α) : + DirMatching.sgnRel (DirMatching.stdMatching h') + (M.map e.toEquiv) + = DirMatching.sgnRel (DirMatching.stdMatching h) M := by + rw [← DirMatching.stdMatching_map e h h', + DirMatching.sgnRel_map e.toEquiv (DirMatching.stdMatching h) M] + +open Classical in +/-- **The interface identification acts by the interface map.** It +is therefore the same identification `exists_eulerianPosition` uses, +read on the two halves. -/ +theorem interfaceSideDisjEquiv_val {γ δ : Type} + {W₁ : Fragment γ} {W₂ : Fragment δ} + (F : EdgeSubset (W₁.disjUnion W₂)) (e : γ ≃ δ) + (hp : InterfacePaired F e) (a : UsedLab (leftSub F)) : + (interfaceSideDisjEquiv F e hp a).val = e a.val := rfl + +/-! ## The pair's transition data, read on the base + +(14) asks for the two systems on the halves of the base subset. The +fragments' own systems get there by the relabel and the half +identification, and neither move changes the open circuit count. +-/ + +open Classical in +/-- The first fragment's system, read on the base subset's left +half. -/ +noncomputable def pairRelLeft {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} {s₂ : Finset G.Flag} + (hc₁ : ∀ f ∈ s₁, + (F.relabel (finCongr (by omega : t = 0 + t))).pairing f ∈ s₁) + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (κ₁ : (EdgeSubset.mk s₁ hc₁ : EdgeSubset + (F.relabel (finCongr (by omega : t = 0 + t)))).RelTransitionSystem) : + (leftSub (EdgeSubset.mk (closeJoin s₁ s₂) hc) + ).RelTransitionSystem := + relOfEq (leftSub_closeJoin hc hc₁).symm κ₁ + +open Classical in +/-- The second fragment's system, read on the base subset's right +half. -/ +noncomputable def pairRelRight {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} {s₂ : Finset G.Flag} + (hc₂ : ∀ f ∈ s₂, + (G.relabel (finCongr (by omega : t = t + 0))).pairing f ∈ s₂) + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (κ₂ : (EdgeSubset.mk s₂ hc₂ : EdgeSubset + (G.relabel (finCongr (by omega : t = t + 0)))).RelTransitionSystem) : + (rightSub (EdgeSubset.mk (closeJoin s₁ s₂) hc) + ).RelTransitionSystem := + relOfEq (rightSub_closeJoin hc hc₂).symm κ₂ + +open Classical in +/-- Reading the first system on the half leaves its circuit count +alone. -/ +theorem openCircuitCount_pairRelLeft {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} {s₂ : Finset G.Flag} + (hc₁ : ∀ f ∈ s₁, + (F.relabel (finCongr (by omega : t = 0 + t))).pairing f ∈ s₁) + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (κ₁ : (EdgeSubset.mk s₁ hc₁ : EdgeSubset + (F.relabel (finCongr (by omega : t = 0 + t)))).RelTransitionSystem) : + (pairRelLeft (s₂ := s₂) hc₁ hc κ₁).openCircuitCount + = κ₁.openCircuitCount := + openCircuitCount_relOfEq _ κ₁ + +open Classical in +/-- Reading the second system on the half leaves its circuit count +alone. -/ +theorem openCircuitCount_pairRelRight {t : ℕ} + {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} {s₂ : Finset G.Flag} + (hc₂ : ∀ f ∈ s₂, + (G.relabel (finCongr (by omega : t = t + 0))).pairing f ∈ s₂) + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (κ₂ : (EdgeSubset.mk s₂ hc₂ : EdgeSubset + (G.relabel (finCongr (by omega : t = t + 0)))).RelTransitionSystem) : + (pairRelRight (s₁ := s₁) hc₂ hc κ₂).openCircuitCount + = κ₂.openCircuitCount := + openCircuitCount_relOfEq _ κ₂ + +open Classical in +/-- **A matching with the chord pairings is the chord matching**, on +pairings. RS21's (13) records its matchings pointwise; (14) wants +them as an equality of pairing maps. -/ +theorem edge_eq_cutMatching {α : Type} [LinearOrder α] + {W : Fragment α} (F : EdgeSubset W) (κ : F.RelTransitionSystem) + (o : κ.Orientation) (M : DirMatching (UsedLab F)) + (hM : ∀ a : UsedLab F, + (M.edge a).val = chordInv F κ a.val) : + M.edge = (cutMatching F κ o).edge := + funext fun a => Subtype.ext (hM a) + +open Classical in +/-- **The used labels are untouched by an equality of subsets**, as +an order isomorphism — the form the sign transport wants. -/ +def usedLabOrderIsoOfEq {α : Type} [LinearOrder α] {W : Fragment α} + {F₁ F₂ : EdgeSubset W} (h : F₁ = F₂) : UsedLab F₁ ≃o UsedLab F₂ + := by + subst h + exact OrderIso.refl _ + +open Classical in +/-- **The used labels shift through a relabel**, as an order +isomorphism. -/ +noncomputable def usedLabRelabelOrderIso {α β : Type} + [LinearOrder α] [LinearOrder β] {W : Fragment α} (e : α ≃o β) + (F : EdgeSubset W) : + UsedLab (F.relabelUp e.toEquiv) ≃o UsedLab F where + toEquiv := usedLabRelabelEquiv e F + map_rel_iff' := e.symm.map_rel_iff + +/-- The left relabel, as an order isomorphism. -/ +def leftIso (t : ℕ) : Fin t ≃o Fin (0 + t) := + Fin.castOrderIso (by omega) + +/-- The right relabel, as an order isomorphism. -/ +def rightIso (t : ℕ) : Fin t ≃o Fin (t + 0) := + Fin.castOrderIso (by omega) + +open Classical in +/-- **The base subset's left half has the first subset's used +labels.** -/ +noncomputable def usedLabLeftCloseJoin {t : ℕ} + {F G : Fragment (Fin t)} {s₁ : Finset F.Flag} + {s₂ : Finset G.Flag} + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) : + UsedLab (leftSub (EdgeSubset.mk (closeJoin s₁ s₂) hc)) + ≃o UsedLab (EdgeSubset.mk s₁ hc₁) := + (usedLabOrderIsoOfEq (leftSub_closeJoin hc hc₁)).trans + (usedLabRelabelOrderIso (leftIso t) (EdgeSubset.mk s₁ hc₁)) + +open Classical in +/-- **The base subset's right half has the second subset's used +labels.** -/ +noncomputable def usedLabRightCloseJoin {t : ℕ} + {F G : Fragment (Fin t)} {s₁ : Finset F.Flag} + {s₂ : Finset G.Flag} + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) : + UsedLab (rightSub (EdgeSubset.mk (closeJoin s₁ s₂) hc)) + ≃o UsedLab (EdgeSubset.mk s₂ hc₂) := + (usedLabOrderIsoOfEq (rightSub_closeJoin hc hc₂)).trans + (usedLabRelabelOrderIso (rightIso t) (EdgeSubset.mk s₂ hc₂)) + +open Classical in +/-- The base subset's left half has as many used labels as the first +subset. -/ +theorem card_usedLab_leftSub_closeJoin {t : ℕ} + {F G : Fragment (Fin t)} {s₁ : Finset F.Flag} + {s₂ : Finset G.Flag} + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) : + Fintype.card + (UsedLab (leftSub (EdgeSubset.mk (closeJoin s₁ s₂) hc))) + = Fintype.card (UsedLab (EdgeSubset.mk s₁ hc₁)) := + Fintype.card_congr (usedLabLeftCloseJoin hc hc₁).toEquiv + +open Classical in +/-- The base subset's right half has as many used labels as the +second subset. -/ +theorem card_usedLab_rightSub_closeJoin {t : ℕ} + {F G : Fragment (Fin t)} {s₁ : Finset F.Flag} + {s₂ : Finset G.Flag} + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) : + Fintype.card + (UsedLab (rightSub (EdgeSubset.mk (closeJoin s₁ s₂) hc))) + = Fintype.card (UsedLab (EdgeSubset.mk s₂ hc₂)) := + Fintype.card_congr (usedLabRightCloseJoin hc hc₂).toEquiv + +open Classical in +/-- **The chord involution on the base subset's left half** is the +first subset's, shifted by the relabel. -/ +theorem chordInv_pairRelLeft {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} {s₂ : Finset G.Flag} + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + (κ₁ : (EdgeSubset.mk s₁ hc₁).RelTransitionSystem) + (a : Fin (0 + t)) : + chordInv (leftSub (EdgeSubset.mk (closeJoin s₁ s₂) hc)) + (pairRelLeft hc₁ hc + (relabelTransUp (leftIso t).toEquiv + (EdgeSubset.mk s₁ hc₁) κ₁)) a + = leftIso t (chordInv (EdgeSubset.mk s₁ hc₁) κ₁ + ((leftIso t).symm a)) := + Eq.trans (chordInv_relOfEq _ _ a) + (chordInv_relabelUp (leftIso t) (EdgeSubset.mk s₁ hc₁) κ₁ a) + +open Classical in +/-- **The chord involution on the base subset's right half** is the +second subset's, shifted by the relabel. -/ +theorem chordInv_pairRelRight {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} {s₂ : Finset G.Flag} + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (κ₂ : (EdgeSubset.mk s₂ hc₂).RelTransitionSystem) + (b : Fin (t + 0)) : + chordInv (rightSub (EdgeSubset.mk (closeJoin s₁ s₂) hc)) + (pairRelRight hc₂ hc + (relabelTransUp (rightIso t).toEquiv + (EdgeSubset.mk s₂ hc₂) κ₂)) b + = rightIso t (chordInv (EdgeSubset.mk s₂ hc₂) κ₂ + ((rightIso t).symm b)) := + Eq.trans (chordInv_relOfEq _ _ b) + (chordInv_relabelUp (rightIso t) (EdgeSubset.mk s₂ hc₂) κ₂ b) + +open Classical in +/-- The subset-equality transport keeps the label. -/ +theorem usedLabOrderIsoOfEq_val {α : Type} [LinearOrder α] + {W : Fragment α} {F₁ F₂ : EdgeSubset W} (h : F₁ = F₂) + (x : UsedLab F₁) : (usedLabOrderIsoOfEq h x).val = x.val := by + subst h + rfl + +open Classical in +/-- The left transport acts by the relabel on labels. -/ +theorem usedLabLeftCloseJoin_val {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} {s₂ : Finset G.Flag} + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + (a : UsedLab (leftSub (EdgeSubset.mk (closeJoin s₁ s₂) hc))) : + (usedLabLeftCloseJoin hc hc₁ a).val + = (leftIso t).symm a.val := by + change (leftIso t).symm + (usedLabOrderIsoOfEq (leftSub_closeJoin hc hc₁) a).val = _ + rw [usedLabOrderIsoOfEq_val] + +open Classical in +/-- The right transport acts by the relabel on labels. -/ +theorem usedLabRightCloseJoin_val {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} {s₂ : Finset G.Flag} + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (b : UsedLab (rightSub (EdgeSubset.mk (closeJoin s₁ s₂) hc))) : + (usedLabRightCloseJoin hc hc₂ b).val + = (rightIso t).symm b.val := by + change (rightIso t).symm + (usedLabOrderIsoOfEq (rightSub_closeJoin hc hc₂) b).val = _ + rw [usedLabOrderIsoOfEq_val] + +open Classical in +/-- The left transport's inverse acts by the relabel. -/ +theorem usedLabLeftCloseJoin_symm_val {t : ℕ} + {F G : Fragment (Fin t)} {s₁ : Finset F.Flag} + {s₂ : Finset G.Flag} + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + (x : UsedLab (EdgeSubset.mk s₁ hc₁)) : + ((usedLabLeftCloseJoin (s₂ := s₂) hc hc₁).symm x).val + = leftIso t x.val := by + have h := usedLabLeftCloseJoin_val (s₂ := s₂) hc hc₁ + ((usedLabLeftCloseJoin (s₂ := s₂) hc hc₁).symm x) + rw [OrderIso.apply_symm_apply] at h + rw [h, OrderIso.apply_symm_apply] + +open Classical in +/-- The right transport's inverse acts by the relabel. -/ +theorem usedLabRightCloseJoin_symm_val {t : ℕ} + {F G : Fragment (Fin t)} {s₁ : Finset F.Flag} + {s₂ : Finset G.Flag} + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (x : UsedLab (EdgeSubset.mk s₂ hc₂)) : + ((usedLabRightCloseJoin (s₁ := s₁) hc hc₂).symm x).val + = rightIso t x.val := by + have h := usedLabRightCloseJoin_val (s₁ := s₁) hc hc₂ + ((usedLabRightCloseJoin (s₁ := s₁) hc hc₂).symm x) + rw [OrderIso.apply_symm_apply] at h + rw [h, OrderIso.apply_symm_apply] + +open Classical in +/-- **The transported matching keeps the chord record**, on the base +subset's left half. -/ +theorem edge_val_map_left {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} {s₂ : Finset G.Flag} + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + (κ₁ : (EdgeSubset.mk s₁ hc₁).RelTransitionSystem) + (M₁ : DirMatching (UsedLab (EdgeSubset.mk s₁ hc₁))) + (hM₁ : ∀ a : UsedLab (EdgeSubset.mk s₁ hc₁), + (M₁.edge a).val = chordInv (EdgeSubset.mk s₁ hc₁) κ₁ a.val) + (a : UsedLab (leftSub (EdgeSubset.mk (closeJoin s₁ s₂) hc))) : + ((M₁.map + (usedLabLeftCloseJoin (s₂ := s₂) hc hc₁).symm.toEquiv).edge + a).val + = chordInv (leftSub (EdgeSubset.mk (closeJoin s₁ s₂) hc)) + (pairRelLeft hc₁ hc (relabelTransUp (leftIso t).toEquiv + (EdgeSubset.mk s₁ hc₁) κ₁)) a.val := by + change ((usedLabLeftCloseJoin (s₂ := s₂) hc hc₁).symm + (M₁.edge (usedLabLeftCloseJoin (s₂ := s₂) hc hc₁ a))).val = _ + rw [usedLabLeftCloseJoin_symm_val, hM₁, + usedLabLeftCloseJoin_val, chordInv_pairRelLeft] + +open Classical in +/-- **The transported matching keeps the chord record**, on the base +subset's right half. -/ +theorem edge_val_map_right {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} {s₂ : Finset G.Flag} + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (κ₂ : (EdgeSubset.mk s₂ hc₂).RelTransitionSystem) + (M₂ : DirMatching (UsedLab (EdgeSubset.mk s₂ hc₂))) + (hM₂ : ∀ b : UsedLab (EdgeSubset.mk s₂ hc₂), + (M₂.edge b).val = chordInv (EdgeSubset.mk s₂ hc₂) κ₂ b.val) + (b : UsedLab (rightSub (EdgeSubset.mk (closeJoin s₁ s₂) hc))) : + ((M₂.map + (usedLabRightCloseJoin (s₁ := s₁) hc hc₂).symm.toEquiv).edge + b).val + = chordInv (rightSub (EdgeSubset.mk (closeJoin s₁ s₂) hc)) + (pairRelRight hc₂ hc (relabelTransUp (rightIso t).toEquiv + (EdgeSubset.mk s₂ hc₂) κ₂)) b.val := by + change ((usedLabRightCloseJoin (s₁ := s₁) hc hc₂).symm + (M₂.edge (usedLabRightCloseJoin (s₁ := s₁) hc hc₂ b))).val = _ + rw [usedLabRightCloseJoin_symm_val, hM₂, + usedLabRightCloseJoin_val, chordInv_pairRelRight] + +open Classical in +/-- **The two interface identifications agree.** (14) states its +alternation against the base subset's halves, (13) against the two +fragments' own subsets; the transports carry one to the other. -/ +theorem usedLabRight_interfaceSideDisj {t : ℕ} + {F G : Fragment (Fin t)} {s₁ : Finset F.Flag} + {s₂ : Finset G.Flag} + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (hp : InterfacePaired (EdgeSubset.mk (closeJoin s₁ s₂) hc) + (stepIdentOrderIso t).toEquiv) + (hb : ∀ i : Fin t, + F.boundaryFlag i ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags + ↔ G.boundaryFlag i ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags) + (a : UsedLab (leftSub (EdgeSubset.mk (closeJoin s₁ s₂) hc))) : + usedLabRightCloseJoin (s₁ := s₁) hc hc₂ + (interfaceSideDisjOrderIso (EdgeSubset.mk (closeJoin s₁ s₂) + hc) (stepIdentOrderIso t) hp a) + = usedLabInterfaceEquiv (EdgeSubset.mk s₁ hc₁) + (EdgeSubset.mk s₂ hc₂) hb + (usedLabLeftCloseJoin (s₂ := s₂) hc hc₁ a) := by + refine Subtype.ext ?_ + rw [usedLabRightCloseJoin_val] + change (rightIso t).symm + ((interfaceSideDisjEquiv (EdgeSubset.mk (closeJoin s₁ s₂) hc) + (stepIdentOrderIso t).toEquiv hp a).val) + = ((usedLabLeftCloseJoin (s₂ := s₂) hc hc₁) a).val + rw [interfaceSideDisjEquiv_val, usedLabLeftCloseJoin_val] + exact Fin.ext (by simp [leftIso, rightIso, stepIdentOrderIso]) + +/-! ## The stage data a pair of subsets makes + +Everything (14) reads off the composition is a function of this one +object: the base subset, its interface pairing, and the two systems +carried over from the fragments. +-/ + +open Classical in +/-- **The stage data a pair of subsets makes.** -/ +noncomputable def pairStage {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} {s₂ : Finset G.Flag} + (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (hused : ∀ i : Fin t, + F.boundaryFlag i ∈ s₁ ↔ G.boundaryFlag i ∈ s₂) + (κ₁ : (EdgeSubset.mk s₁ hc₁).RelTransitionSystem) + (κ₂ : (EdgeSubset.mk s₂ hc₂).RelTransitionSystem) : + StageData t (closeBase F G) where + sub := EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂) + paired := swapPaired_joinParts t F G s₁ s₂ + (closeJoin_pairing_mem hc₁ hc₂) hused + rel := prodRel + (pairRelLeft hc₁ (closeJoin_pairing_mem hc₁ hc₂) + (relabelTransUp (leftIso t).toEquiv + (EdgeSubset.mk s₁ hc₁) κ₁)) + (pairRelRight hc₂ (closeJoin_pairing_mem hc₁ hc₂) + (relabelTransUp (rightIso t).toEquiv + (EdgeSubset.mk s₂ hc₂) κ₂)) + +open Classical in +/-- **RS21's (14), read on a pair of subsets.** The two fragments' +circuit-and-matching signs multiply to the composition's own sign, +with one extra factor for each closing cut the subsets carry. -/ +theorem sign_composition_pair {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} {s₂ : Finset G.Flag} + (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (hused : ∀ i : Fin t, + F.boundaryFlag i ∈ s₁ ↔ G.boundaryFlag i ∈ s₂) + (hb : ∀ i : Fin t, + F.boundaryFlag i ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags + ↔ G.boundaryFlag i ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags) + (κ₁ : (EdgeSubset.mk s₁ hc₁).RelTransitionSystem) + (o₁ : κ₁.Orientation) + (κ₂ : (EdgeSubset.mk s₂ hc₂).RelTransitionSystem) + (o₂ : κ₂.Orientation) + (M₁ : DirMatching (UsedLab (EdgeSubset.mk s₁ hc₁))) + (M₂ : DirMatching (UsedLab (EdgeSubset.mk s₂ hc₂))) {m : ℕ} + (hcard₁ : Fintype.card (UsedLab (EdgeSubset.mk s₁ hc₁)) = 2 * m) + (hcard₂ : Fintype.card (UsedLab (EdgeSubset.mk s₂ hc₂)) = 2 * m) + (hM₁ : ∀ a : UsedLab (EdgeSubset.mk s₁ hc₁), + (M₁.edge a).val = chordInv (EdgeSubset.mk s₁ hc₁) κ₁ a.val) + (hM₂ : ∀ b : UsedLab (EdgeSubset.mk s₂ hc₂), + (M₂.edge b).val = chordInv (EdgeSubset.mk s₂ hc₂) κ₂ b.val) + (halt : ∀ a : UsedLab (EdgeSubset.mk s₁ hc₁), + M₂.tail (usedLabInterfaceEquiv (EdgeSubset.mk s₁ hc₁) + (EdgeSubset.mk s₂ hc₂) hb a) = !M₁.tail a) : + (((DirMatching.sgnRel (DirMatching.stdMatching hcard₁) M₁ + : ℤ) : ℂ) + * ((-1 : ℂ) ^ κ₁.openCircuitCount)) + * (((DirMatching.sgnRel (DirMatching.stdMatching hcard₂) M₂ + : ℤ) : ℂ) + * ((-1 : ℂ) ^ κ₂.openCircuitCount)) + = (-1 : ℂ) ^ ((glueData t (closeBase F G) + (pairStage hc₁ hc₂ hused κ₁ κ₂)).rel.openCircuitCount + + glueCount t (closeBase F G) + (pairStage hc₁ hc₂ hused κ₁ κ₂)) := by + set hc := closeJoin_pairing_mem hc₁ hc₂ with hcdef + set B : EdgeSubset (closeBase F G) := + EdgeSubset.mk (closeJoin s₁ s₂) hc with hBdef + set eL := usedLabLeftCloseJoin (s₂ := s₂) hc hc₁ with heL + set eR := usedLabRightCloseJoin (s₁ := s₁) hc hc₂ with heR + have hcard₁' : Fintype.card (UsedLab (leftSub B)) = 2 * m := + (card_usedLab_leftSub_closeJoin hc hc₁).trans hcard₁ + have hcard₂' : Fintype.card (UsedLab (rightSub B)) = 2 * m := + (card_usedLab_rightSub_closeJoin hc hc₂).trans hcard₂ + have hsgn₁ := sgnRel_stdMatching_map eL.symm hcard₁ hcard₁' M₁ + have hsgn₂ := sgnRel_stdMatching_map eR.symm hcard₂ hcard₂' M₂ + have hcnt₁ : (pairRelLeft hc₁ hc (relabelTransUp + (leftIso t).toEquiv (EdgeSubset.mk s₁ hc₁) κ₁) + ).openCircuitCount = κ₁.openCircuitCount := + (openCircuitCount_pairRelLeft (s₂ := s₂) hc₁ hc _).trans + (relabel_openCircuitCount (leftIso t).toEquiv + (EdgeSubset.mk s₁ hc₁) κ₁) + have hcnt₂ : (pairRelRight hc₂ hc (relabelTransUp + (rightIso t).toEquiv (EdgeSubset.mk s₂ hc₂) κ₂) + ).openCircuitCount = κ₂.openCircuitCount := + (openCircuitCount_pairRelRight (s₁ := s₁) hc₂ hc _).trans + (relabel_openCircuitCount (rightIso t).toEquiv + (EdgeSubset.mk s₂ hc₂) κ₂) + have hmain := sign_composition t B + (swapPaired_joinParts t F G s₁ s₂ hc hused) + (pairRelLeft hc₁ hc (relabelTransUp (leftIso t).toEquiv + (EdgeSubset.mk s₁ hc₁) κ₁)) + (pairRelRight hc₂ hc (relabelTransUp (rightIso t).toEquiv + (EdgeSubset.mk s₂ hc₂) κ₂)) + (orientOfEq (leftSub_closeJoin hc hc₁).symm + (relabelOrientUp (leftIso t).toEquiv + (EdgeSubset.mk s₁ hc₁) o₁)) + (orientOfEq (rightSub_closeJoin hc hc₂).symm + (relabelOrientUp (rightIso t).toEquiv + (EdgeSubset.mk s₂ hc₂) o₂)) + (M₁.map eL.symm.toEquiv) (M₂.map eR.symm.toEquiv) + hcard₁' hcard₂' + (edge_eq_cutMatching _ _ _ _ + (edge_val_map_left hc hc₁ κ₁ M₁ hM₁)) + (edge_eq_cutMatching _ _ _ _ + (edge_val_map_right hc hc₂ κ₂ M₂ hM₂)) + (fun a => by + change M₂.tail (eR _) = !M₁.tail (eL a) + exact Eq.trans (congrArg M₂.tail + (usedLabRight_interfaceSideDisj hc hc₁ hc₂ _ hb a)) + (halt (eL a))) + simp only [hcnt₁, hcnt₂] at hmain + refine Eq.trans ?_ hmain + exact congrArg₂ (· * ·) + (congrArg (fun z : ℤˣ => ((z : ℤ) : ℂ) + * (-1 : ℂ) ^ κ₁.openCircuitCount) hsgn₁.symm) + (congrArg (fun z : ℤˣ => ((z : ℤ) : ℂ) + * (-1 : ℂ) ^ κ₂.openCircuitCount) hsgn₂.symm) + +open Classical in +/-- **The pair term, with its constant named.** RS21's (13) read +against (14): the pairing of the two fragments' terms at a pair of +subsets is the composition's own circuit sign, one factor for each +cut the pair closes, times the colouring sum of their agreement. -/ +theorem exists_pairTerm_eq_glued_sign {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (t : ℕ) (F G : Fragment (Fin t)) + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + (hE₁ : (EdgeSubset.mk s₁ hc₁).Eulerian) + (hn₁ : Nonempty (EdgeSubset.mk s₁ hc₁).CanonData) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (hE₂ : (EdgeSubset.mk s₂ hc₂).Eulerian) + (hn₂ : Nonempty (EdgeSubset.mk s₂ hc₂).CanonData) + (hused : ∀ i : Fin t, + F.boundaryFlag i ∈ s₁ ↔ G.boundaryFlag i ∈ s₂) + (hb : ∀ i : Fin t, + F.boundaryFlag i ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags + ↔ G.boundaryFlag i ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags) : + ∃ (o₁' : (Classical.choice hn₁).1.Orientation) + (o₂' : (Classical.choice hn₂).1.Orientation) + (M₁ : DirMatching (UsedLab (EdgeSubset.mk s₁ hc₁))) + (M₂ : DirMatching (UsedLab (EdgeSubset.mk s₂ hc₂))), + (∀ a : UsedLab (EdgeSubset.mk s₁ hc₁), + (M₁.edge a).val = chordInv (EdgeSubset.mk s₁ hc₁) + (Classical.choice hn₁).1 a.val) ∧ + (∀ b : UsedLab (EdgeSubset.mk s₂ hc₂), + (M₂.edge b).val = chordInv (EdgeSubset.mk s₂ hc₂) + (Classical.choice hn₂).1 b.val) ∧ + (∀ a : UsedLab (EdgeSubset.mk s₁ hc₁), + M₂.tail (usedLabInterfaceEquiv (EdgeSubset.mk s₁ hc₁) + (EdgeSubset.mk s₂ hc₂) hb a) + = !M₁.tail a) ∧ + (∀ a : UsedLab (EdgeSubset.mk s₁ hc₁), + ¬ IsThroughLabel (EdgeSubset.mk s₁ hc₁) a.val → + M₁.tail a = (cutMatching (EdgeSubset.mk s₁ hc₁) + (Classical.choice hn₁).1 o₁').tail a) ∧ + (∀ b : UsedLab (EdgeSubset.mk s₂ hc₂), + ¬ IsThroughLabel (EdgeSubset.mk s₂ hc₂) b.val → + M₂.tail b = (cutMatching (EdgeSubset.mk s₂ hc₂) + (Classical.choice hn₂).1 o₂').tail b) ∧ + (∀ a : UsedLab (EdgeSubset.mk s₁ hc₁), + ¬ IsThroughLabel (EdgeSubset.mk s₁ hc₁) a.val → + ¬ IsThroughLabel (EdgeSubset.mk s₂ hc₂) + (usedLabInterfaceEquiv (EdgeSubset.mk s₁ hc₁) + (EdgeSubset.mk s₂ hc₂) hb a).val → + (cutMatching (EdgeSubset.mk s₂ hc₂) + (Classical.choice hn₂).1 o₂').tail + (usedLabInterfaceEquiv (EdgeSubset.mk s₁ hc₁) + (EdgeSubset.mk s₂ hc₂) hb a) + = !(cutMatching (EdgeSubset.mk s₁ hc₁) + (Classical.choice hn₁).1 o₁').tail a) ∧ + (∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * tensorTermAt F h s₁ x + * tensorTermAt G h s₂ y) + = (-1 : ℂ) ^ ((glueData t (closeBase F G) + (pairStage hc₁ hc₂ hused (Classical.choice hn₁).1 + (Classical.choice hn₂).1)).rel.openCircuitCount + + glueCount t (closeBase F G) + (pairStage hc₁ hc₂ hused (Classical.choice hn₁).1 + (Classical.choice hn₂).1)) + * ∑ st : GenBoundaryState k ℓ (Fin t), + pairAgreeValue (EdgeSubset.mk s₁ hc₁) + (EdgeSubset.mk s₂ hc₂) h o₁' o₂' st := by + obtain ⟨o₁', o₂', M₁, M₂, hM₁, hM₂, halt, hag₁, hag₂, halt', + hval⟩ := + exists_sum_sum_superForm_tensorTermAt h t F G hc₁ hE₁ hn₁ hc₂ + hE₂ hn₂ hused hb + refine ⟨o₁', o₂', M₁, M₂, hM₁, hM₂, halt, hag₁, hag₂, halt', + hval.trans (congrArg₂ (· * ·) ?_ rfl)⟩ + have hcard : Fintype.card (UsedLab (EdgeSubset.mk s₂ hc₂)) + = Fintype.card (UsedLab (EdgeSubset.mk s₁ hc₁)) := + Fintype.card_congr (usedLabInterfaceEquiv (EdgeSubset.mk s₁ hc₁) + (EdgeSubset.mk s₂ hc₂) hb).symm + have hstd : ∀ {m m' : ℕ} + (h1 : Fintype.card (UsedLab (EdgeSubset.mk s₂ hc₂)) = 2 * m) + (h2 : Fintype.card (UsedLab (EdgeSubset.mk s₂ hc₂)) = 2 * m'), + DirMatching.stdMatching h1 = DirMatching.stdMatching h2 := by + intro m m' h1 h2 + have hmm : m = m' := by omega + subst hmm + rfl + rw [hstd (card_usedLab_eq _ M₂) (hcard.trans (card_usedLab_eq _ M₁))] + exact sign_composition_pair hc₁ hc₂ hused hb _ o₁' _ o₂' M₁ M₂ + (card_usedLab_eq _ M₁) (hcard.trans (card_usedLab_eq _ M₁)) hM₁ + hM₂ halt + +open Classical in +/-- The base's free circles are the two fragments'. -/ +theorem circles_closeBase {t : ℕ} (F G : Fragment (Fin t)) : + (closeBase F G).circles = F.circles + G.circles := rfl + +/-! ## Restricting the composition's data to the two fragments + +The base's own transition data restrict to its two halves and descend +to the fragments; these are the data RS21's (13) is applied at, so +that the orientations on the two sides are the composition's own. +-/ + +open Classical in +/-- The base's system, restricted to the first fragment. -/ +noncomputable def pairRelLeftDown {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} {s₂ : Finset G.Flag} + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + (κ : (EdgeSubset.mk (closeJoin s₁ s₂) hc).RelTransitionSystem) : + (EdgeSubset.mk s₁ hc₁ : EdgeSubset F).RelTransitionSystem := + relabelTransDown (leftIso t).toEquiv (EdgeSubset.mk s₁ hc₁) + (relOfEq (leftSub_closeJoin hc hc₁) (leftRel κ)) + +open Classical in +/-- The base's system, restricted to the second fragment. -/ +noncomputable def pairRelRightDown {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} {s₂ : Finset G.Flag} + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (κ : (EdgeSubset.mk (closeJoin s₁ s₂) hc).RelTransitionSystem) : + (EdgeSubset.mk s₂ hc₂ : EdgeSubset G).RelTransitionSystem := + relabelTransDown (rightIso t).toEquiv (EdgeSubset.mk s₂ hc₂) + (relOfEq (rightSub_closeJoin hc hc₂) (rightRel κ)) + +open Classical in +/-- **Replacing an orientation off the internal flags.** The two +laws bind only internal flags, so the directions elsewhere may be +given by any function at all. -/ +noncomputable def orientReplace {α : Type} + {W : Fragment α} {F : EdgeSubset W} {κ : F.RelTransitionSystem} + (o : κ.Orientation) (g : W.Flag → Bool) : κ.Orientation where + isOut f := if f ∈ F.internalFlags then o.isOut f else g f + match_flip f hf := by + rw [ite_eq_left (κ.match_mem f hf), ite_eq_left hf] + exact o.match_flip f hf + pairing_flip f hf hp := by + rw [ite_eq_left hp, ite_eq_left hf] + exact o.pairing_flip f hf hp + +open Classical in +/-- At an internal flag the replacement keeps the direction. -/ +theorem isOut_orientReplace_internal {α : Type} + {W : Fragment α} {F : EdgeSubset W} {κ : F.RelTransitionSystem} + (o : κ.Orientation) (g : W.Flag → Bool) {f : W.Flag} + (hf : f ∈ F.internalFlags) : + (orientReplace o g).isOut f = o.isOut f := ite_eq_left hf + +open Classical in +/-- Off the internal flags the replacement is the given function. -/ +theorem isOut_orientReplace_of_not_internal {α : Type} + {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} (o : κ.Orientation) + (g : W.Flag → Bool) {f : W.Flag} (hf : f ∉ F.internalFlags) : + (orientReplace o g).isOut f = g f := ite_eq_right hf + +/-! ## The colouring sum sees only the internal directions + +RS21's colouring sum is built from the in-flag list at each vertex, +and a flag is on that list only if it is attached to the vertex — +that is, only if it is internal. So the sum does not see how an +orientation directs a labelled end, and in particular is unchanged by +the port flips (13) performs. +-/ + +section OrientCongr + +variable {α : Type} + +private theorem attachWith_map_congr' {δ γ : Type} {P : δ → Prop} + {l₁ l₂ : List δ} (hl : l₁ = l₂) (h₁ : ∀ x ∈ l₁, P x) + (h₂ : ∀ x ∈ l₂, P x) (f : {x // P x} → γ) : + (l₁.attachWith P h₁).map f = (l₂.attachWith P h₂).map f := by + subst hl + rfl + +private theorem attachWith_flatMap_congr' {δ γ : Type} {P : δ → Prop} + {l₁ l₂ : List δ} (hl : l₁ = l₂) (h₁ : ∀ x ∈ l₁, P x) + (h₂ : ∀ x ∈ l₂, P x) (f : {x // P x} → List γ) : + (l₁.attachWith P h₁).flatMap f + = (l₂.attachWith P h₂).flatMap f := by + subst hl + rfl + +open Classical in +/-- **The in-flag list sees only the internal directions.** -/ +theorem relInFlagsAt_congr_internal {W : Fragment α} + (F : EdgeSubset W) + {κ : F.RelTransitionSystem} (o o' : κ.Orientation) + (hio : ∀ f ∈ F.internalFlags, o.isOut f = o'.isOut f) + (v : W.Vertex) : + F.relInFlagsAt o v = F.relInFlagsAt o' v := by + unfold EdgeSubset.relInFlagsAt + congr 1 + ext f + simp only [Finset.mem_filter] + constructor + · rintro ⟨hf, hv, hb⟩ + exact ⟨hf, hv, by + rw [← hio f (EdgeSubset.mem_internalFlags_iff.mpr ⟨hf, v, hv⟩)] + exact hb⟩ + · rintro ⟨hf, hv, hb⟩ + exact ⟨hf, hv, by + rw [hio f (EdgeSubset.mem_internalFlags_iff.mpr ⟨hf, v, hv⟩)] + exact hb⟩ + +open Classical in +/-- The odd sign at a vertex sees only the internal directions. -/ +theorem coreOddSignAt_congr_internal {W : Fragment α} + (F : EdgeSubset W) {ℓ : ℕ} + {κ : F.RelTransitionSystem} (o o' : κ.Orientation) + (hio : ∀ f ∈ F.internalFlags, o.isOut f = o'.isOut f) + (φ : F.CoreOddColouring ℓ) (v : W.Vertex) : + F.coreOddSignAt o φ v = F.coreOddSignAt o' φ v := + congrArg List.prod (attachWith_map_congr' + (relInFlagsAt_congr_internal F o o' hio v) _ _ _) + +open Classical in +/-- The odd list at a vertex sees only the internal directions. -/ +theorem coreOddListAt_congr_internal {W : Fragment α} + (F : EdgeSubset W) {ℓ : ℕ} + {κ : F.RelTransitionSystem} (o o' : κ.Orientation) + (hio : ∀ f ∈ F.internalFlags, o.isOut f = o'.isOut f) + (φ : F.CoreOddColouring ℓ) (v : W.Vertex) : + F.coreOddListAt o φ v = F.coreOddListAt o' φ v := + attachWith_flatMap_congr' + (relInFlagsAt_congr_internal F o o' hio v) _ _ _ + +open Classical in +/-- **RS21's colouring sum sees only the internal directions.** It is +therefore unchanged by a port flip. -/ +theorem edgeSum_congr_orient {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ : F.RelTransitionSystem} (o o' : κ.Orientation) + (hio : ∀ f ∈ F.internalFlags, o.isOut f = o'.isOut f) : + F.edgeSum h st hbnd o = F.edgeSum h st hbnd o' := by + unfold EdgeSubset.edgeSum + refine Finset.sum_congr rfl (fun ψ _ => ?_) + refine if_congr Iff.rfl ?_ rfl + refine Finset.sum_congr rfl (fun φ _ => ?_) + refine if_congr Iff.rfl ?_ rfl + refine Finset.prod_congr rfl (fun v _ => ?_) + rw [coreOddSignAt_congr_internal F o o' hio φ.core v, + coreOddListAt_congr_internal F o o' hio φ.core v] + +open Classical in +/-- **Replacing off the internal flags costs the colouring sum +nothing.** -/ +theorem edgeSum_orientReplace [LinearOrder α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ : F.RelTransitionSystem} (o : κ.Orientation) + (g : W.Flag → Bool) : + F.edgeSum h st hbnd (orientReplace o g) + = F.edgeSum h st hbnd o := + edgeSum_congr_orient F h st hbnd _ o + (fun _f hf => isOut_orientReplace_internal o g hf) + +end OrientCongr + +/-! ## The composition's value at any canonical family + +The composition's constrained value does not depend on which +canonical data compute it, so the colouring recursion may be run from +whichever family is convenient — in particular from one built out of +the two fragments' own data. +-/ + +section AnyCanon + +variable {L : Type} + +open Classical in +/-- **The composition's constrained value at an arbitrary canonical +family.** -/ +theorem throughMixedPartitionC_eq_edgeTermAt_canon + [LinearOrder L] [IsEmpty L] {V : Fragment L} + {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ L) + (𝒟 : DataFamily V) + (hcanon : ∀ (s : Finset V.Flag) (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData), + EdgeSubset.PathCanonical (𝒟 s hc hE hne).2) : + throughMixedPartitionC h V st + = ((k : ℂ) - 2 * ℓ) ^ V.circles * + ∑ s : Finset V.Flag, + circuitWeight 𝒟 s * edgeTermAt h 𝒟 st s 0 := by + rw [throughMixedPartitionC_isEmpty h st] + refine congrArg (fun z => ((k : ℂ) - 2 * ℓ) ^ V.circles * z) + (Finset.sum_congr rfl (fun s _ => ?_)) + by_cases hc : ∀ f ∈ s, V.pairing f ∈ s + · by_cases hbnd : genBoundarySubsetMatches V s st + · by_cases hE : (EdgeSubset.mk s hc).Eulerian + · by_cases hne : Nonempty (EdgeSubset.mk s hc).CanonData + · rw [dite_eq_left hc, dite_eq_left hbnd, ite_eq_left hE, dite_eq_left hne, + circuitWeight_pos 𝒟 hc hE hne, + edgeTermAt_pos h 𝒟 st hc hbnd hE hne 0, pow_zero, + one_mul, + ← throughSummand_eq_edgeSum (EdgeSubset.mk s hc) h st + hbnd _ _] + exact throughSummand_canon_indep (EdgeSubset.mk s hc) h st + hbnd (Classical.choice hne) + ⟨(𝒟 s hc hE hne).1, + ⟨(𝒟 s hc hE hne).2, hcanon s hc hE hne⟩⟩ + · rw [dite_eq_left hc, dite_eq_left hbnd, ite_eq_left hE, dite_eq_right hne, + edgeTermAt_eq_zero_of_not_canon h 𝒟 st hc hne 0, + mul_zero] + · rw [dite_eq_left hc, dite_eq_left hbnd, ite_eq_right hE, + edgeTermAt_eq_zero_of_not_eulerian h 𝒟 st hc hE 0, + mul_zero] + · rw [dite_eq_left hc, dite_eq_right hbnd, + edgeTermAt_eq_zero_of_not_matches h 𝒟 st hbnd 0, mul_zero] + · rw [dite_eq_right hc, edgeTermAt_eq_zero_of_not_closed h 𝒟 st hc 0, + mul_zero] + +open Classical in +/-- **At the composition every orientation is path-canonical.** So +any family of transition data there is a canonical one. -/ +theorem pathCanonical_isEmpty [LinearOrder L] [IsEmpty L] {V : Fragment L} + (F : EdgeSubset V) + {κ : F.RelTransitionSystem} (o : κ.Orientation) : + EdgeSubset.PathCanonical o := + pathCanonical_of_allInternal (allInternal_isEmpty F) o + +open Classical in +/-- **The composition's constrained value at an arbitrary family.** +No canonicality hypothesis is needed: at an empty label type there +are no chords to order. -/ +theorem throughMixedPartitionC_eq_edgeTermAt_any + [LinearOrder L] [IsEmpty L] {V : Fragment L} + {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ L) + (𝒟 : DataFamily V) : + throughMixedPartitionC h V st + = ((k : ℂ) - 2 * ℓ) ^ V.circles * + ∑ s : Finset V.Flag, + circuitWeight 𝒟 s * edgeTermAt h 𝒟 st s 0 := + throughMixedPartitionC_eq_edgeTermAt_canon h st 𝒟 + (fun s hc _hE _hne => pathCanonical_isEmpty (EdgeSubset.mk s hc) + (𝒟 s hc _hE _hne).2) + +end AnyCanon + +/-! ## The alternation, in chain-direction form + +(13) reports its alternation on the chord matchings' tails; the glue +reads it on the chain directions. At a chain label the two are the +same thing, negated. +-/ + +section TailChain + +variable {α : Type} + +open Classical in +/-- **The chord matching's tail at a chain label** is that label's +chain direction, reversed. -/ +theorem cutMatching_tail_of_not_through [LinearOrder α] {W : Fragment α} + (F : EdgeSubset W) + (κ : F.RelTransitionSystem) (o : κ.Orientation) (i : UsedLab F) + (hnt : ¬ IsThroughLabel F i.val) : + (cutMatching F κ o).tail i + = !chainDir o (W.boundaryFlag i.val) := by + change (if IsThroughLabel F i.val then + decide (i.val < chordInv F κ i.val) + else !chainDir o (W.boundaryFlag i.val)) = _ + rw [ite_eq_right hnt] + +end TailChain + +/-! ## Lifting a data family across an open cut + +The downward direction is `unglueDataOpen`; this is its upward +counterpart. Where the family's own orientation directs the two +rewired ends oppositely — which is what RS21's step 1 arranges — the +glue applies; elsewhere the value is junk the identity never reads. +-/ + +open Classical in +/-- **The upward glue of a data family, at an open cut.** -/ +noncomputable def glueDataOpen {α : Type} [LinearOrder α] + {V : Fragment α} {i j : α} (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (𝒟 : DataFamily V) : + DataFamily (V.gluePairOpen i j hij hopen) := + fun t hct hEt hnet => + have hcL := liftSubsetOpen_pairing_closed hij hopen t hct + have hEL := (eulerian_lift_open_iff hij hopen t hct hcL).mpr hEt + have hneL := + nonempty_canonData_unglueOpen hij hopen t hct hcL hnet + if hag : (𝒟 _ hcL hEL hneL).2.isOut + (V.pairing (V.boundaryFlag j)) + = !(𝒟 _ hcL hEL hneL).2.isOut + (V.pairing (V.boundaryFlag i)) then + ⟨RelTransitionSystem.glueOpen hij hopen t hct hcL + (𝒟 _ hcL hEL hneL).1, + glueOrientationOpen hij hopen t hct hcL + (𝒟 _ hcL hEL hneL).1 (𝒟 _ hcL hEL hneL).2 hag⟩ + else + ⟨(Classical.choice hnet).1, (Classical.choice hnet).2.val⟩ + +open Classical in +/-- **The upward glue of a data family, at a closing cut.** A +closing cut rewires no directions, so no compatibility is needed; +what it does need is the lift's bit, since a glued subset has two +lifts and they are different subsets of the base. -/ +noncomputable def glueDataClosed {α : Type} [LinearOrder α] + {V : Fragment α} {i j : α} + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (b : Bool) (𝒟 : DataFamily V) : + DataFamily (V.gluePairClosed i j hclosed) := + fun t hct hEt hnet => + have hcL := liftSubsetClosed_pairing_closed hclosed t b hct + have hEL := + (eulerian_liftClosed_iff' hclosed b t hct hcL).mpr hEt + have hneL := + nonempty_canonData_unglueClosed hclosed t hct b hcL hnet + ⟨RelTransitionSystem.glueClosed hclosed b t hct hcL + (𝒟 _ hcL hEL hneL).1, + glueOrientationClosed hclosed b t hct hcL + (𝒟 _ hcL hEL hneL).1 (𝒟 _ hcL hEL hneL).2⟩ + +open Classical in +/-- **A data family under a relabel, upward.** The counterpart of +`relabelDataDown`. -/ +noncomputable def relabelDataUp {α' β' : Type} [LinearOrder α'] + [LinearOrder β'] (e : α' ≃o β') {W' : Fragment α'} + (𝒟 : DataFamily W') : DataFamily (W'.relabel e.toEquiv) := + fun s hc hE hne => + ⟨relabelTransUp e.toEquiv (EdgeSubset.mk s hc) + (𝒟 s hc + ((relabelUp_eulerian e.toEquiv + (EdgeSubset.mk s hc)).mp hE) + ((nonempty_canonData_relabelUp e + (EdgeSubset.mk s hc)).mp hne)).1, + relabelOrientUp e.toEquiv (EdgeSubset.mk s hc) + (𝒟 s hc + ((relabelUp_eulerian e.toEquiv + (EdgeSubset.mk s hc)).mp hE) + ((nonempty_canonData_relabelUp e + (EdgeSubset.mk s hc)).mp hne)).2⟩ + +open Classical in +/-- **One stage of the upward lift.** The mirror of +`stepDataDown`: dispatch on whether the stage's cut closes, glue the +family across it, and relabel up. -/ +noncomputable def stepDataUp (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (b : Bool) (𝒟 : DataFamily V) : + DataFamily (stepFragment n V) := + relabelDataUp (stepIso n) + (if hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then + dataOfEq (gluePair_eq_closed n V hcl).symm + (glueDataClosed hcl b 𝒟) + else + dataOfEq (gluePair_eq_open n V hcl).symm + (glueDataOpen (cutL_ne_cutR n) hcl 𝒟)) + +open Classical in +/-- **The upward lift over the whole interface.** The mirror of +`pushData`, carrying one bit for each stage — the lift the closing +cuts leave undetermined. -/ +noncomputable def liftData : (n : ℕ) → + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) → + (Fin n → Bool) → DataFamily V → + DataFamily (glueInterface 0 n 0 V) + | 0, _, _, 𝒟 => relabelDataUp baseIso 𝒟 + | n + 1, V, bits, 𝒟 => + liftData n (stepFragment n V) (fun a => bits a.castSucc) + (stepDataUp n V (bits (Fin.last n)) 𝒟) + +/-! ## The colouring sum under a matching-equal system + +The single-cut round trips rebuild the system rather than storing +it, so they hold only up to `MatchEq`. The colouring sum reads the +system only through the partner of an internal flag, so it does not +tell the difference. +-/ + +section MatchEqSum + +variable {α : Type} + +open Classical in +/-- The odd sign function sees only the internal partners. -/ +theorem coreOddSignFn_matchEq {W : Fragment α} {F : EdgeSubset W} + {κ κ' : F.RelTransitionSystem} + (hm : κ.MatchEq κ') {ℓ : ℕ} (φ : F.CoreOddColouring ℓ) + (f : {f : W.Flag // f ∈ F.internalFlags}) : + F.coreOddSignFn κ φ f = F.coreOddSignFn κ' φ f := by + unfold EdgeSubset.coreOddSignFn + exact congrArg (oddPartnerSign ℓ) + (congrArg φ.val (Subtype.ext (hm f.val f.prop))) + +open Classical in +/-- The odd pair function sees only the internal partners. -/ +theorem coreOddPairFn_matchEq {W : Fragment α} {F : EdgeSubset W} + {κ κ' : F.RelTransitionSystem} + (hm : κ.MatchEq κ') {ℓ : ℕ} (φ : F.CoreOddColouring ℓ) + (f : {f : W.Flag // f ∈ F.internalFlags}) : + F.coreOddPairFn κ φ f = F.coreOddPairFn κ' φ f := by + unfold EdgeSubset.coreOddPairFn + refine congrArg (fun z => [φ.val ⟨f.val, _⟩, oddPartner ℓ z]) ?_ + exact congrArg φ.val (Subtype.ext (hm f.val f.prop)) + +open Classical in +/-- **The in-flag list sees only the internal directions**, across +two systems: it is cut out by the directions at the flags attached to +the vertex, and those are internal. -/ +theorem relInFlagsAt_congr_isOut_internal {W : Fragment α} {F : EdgeSubset W} + {κ κ' : F.RelTransitionSystem} + (o : κ.Orientation) (o' : κ'.Orientation) + (hio : ∀ f ∈ F.internalFlags, o.isOut f = o'.isOut f) + (v : W.Vertex) : + F.relInFlagsAt o v = F.relInFlagsAt o' v := by + unfold EdgeSubset.relInFlagsAt + congr 1 + ext f + simp only [Finset.mem_filter] + constructor + · rintro ⟨hf, hv, hb⟩ + exact ⟨hf, hv, by + rw [← hio f (EdgeSubset.mem_internalFlags_iff.mpr ⟨hf, v, hv⟩)] + exact hb⟩ + · rintro ⟨hf, hv, hb⟩ + exact ⟨hf, hv, by + rw [hio f (EdgeSubset.mem_internalFlags_iff.mpr ⟨hf, v, hv⟩)] + exact hb⟩ + +open Classical in +/-- The odd sign at a vertex, under a matching-equal system, from the +internal directions alone. -/ +theorem coreOddSignAt_matchEq_internal {W : Fragment α} {F : EdgeSubset W} + {κ κ' : F.RelTransitionSystem} + (hm : κ.MatchEq κ') {ℓ : ℕ} (o : κ.Orientation) + (o' : κ'.Orientation) + (hio : ∀ f ∈ F.internalFlags, o.isOut f = o'.isOut f) + (φ : F.CoreOddColouring ℓ) (v : W.Vertex) : + F.coreOddSignAt o φ v = F.coreOddSignAt o' φ v := by + unfold EdgeSubset.coreOddSignAt + refine Eq.trans (congrArg List.prod (attachWith_map_congr' + (relInFlagsAt_congr_isOut_internal o o' hio v) _ + (fun _x hf => mem_internal_of_mem_relInFlagsAt hf) _)) ?_ + exact congrArg List.prod + (List.map_congr_left (fun x _ => coreOddSignFn_matchEq hm φ x)) + +open Classical in +/-- The odd list at a vertex, under a matching-equal system, from the +internal directions alone. -/ +theorem coreOddListAt_matchEq_internal {W : Fragment α} {F : EdgeSubset W} + {κ κ' : F.RelTransitionSystem} + (hm : κ.MatchEq κ') {ℓ : ℕ} (o : κ.Orientation) + (o' : κ'.Orientation) + (hio : ∀ f ∈ F.internalFlags, o.isOut f = o'.isOut f) + (φ : F.CoreOddColouring ℓ) (v : W.Vertex) : + F.coreOddListAt o φ v = F.coreOddListAt o' φ v := by + unfold EdgeSubset.coreOddListAt + refine Eq.trans (attachWith_flatMap_congr' + (relInFlagsAt_congr_isOut_internal o o' hio v) _ + (fun _x hf => mem_internal_of_mem_relInFlagsAt hf) _) ?_ + exact List.flatMap_congr (fun x _ => coreOddPairFn_matchEq hm φ x) + +open Classical in +/-- **RS21's colouring sum under a matching-equal system, from the +internal directions alone.** The sum reads the directions only at +the flags attached to a vertex, so two orientations that agree there +compute it alike. -/ +theorem edgeSum_matchEq_internal {W : Fragment α} {F : EdgeSubset W} + {κ κ' : F.RelTransitionSystem} + (hm : κ.MatchEq κ') {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (o : κ.Orientation) (o' : κ'.Orientation) + (hio : ∀ f ∈ F.internalFlags, o.isOut f = o'.isOut f) : + F.edgeSum h st hbnd o = F.edgeSum h st hbnd o' := by + unfold EdgeSubset.edgeSum + refine Finset.sum_congr rfl (fun ψ _ => ?_) + refine if_congr Iff.rfl ?_ rfl + refine Finset.sum_congr rfl (fun φ _ => ?_) + refine if_congr Iff.rfl ?_ rfl + refine Finset.prod_congr rfl (fun v _ => ?_) + rw [coreOddSignAt_matchEq_internal hm o o' hio φ.core v, + coreOddListAt_matchEq_internal hm o o' hio φ.core v] + +end MatchEqSum + +/-! ## The summand under a change of family + +Two families whose data at a subset are matching-equal at the same +directions give that subset the same summand. This is the form in +which the round trip is read. +-/ + +section FamilyCongr + +variable {L : Type} + +/-- A transported system has the same partner map. -/ +theorem match_relOfEq {V : Fragment L} + {F₁ F₂ : EdgeSubset V} (hF : F₁ = F₂) + (κ : F₁.RelTransitionSystem) (f : V.Flag) : + (relOfEq hF κ).match_ f = κ.match_ f := by + subst hF + rfl + +/-- A transported orientation has the same directions. -/ +theorem isOut_orientOfEq {V : Fragment L} + {F₁ F₂ : EdgeSubset V} (hF : F₁ = F₂) + {κ : F₁.RelTransitionSystem} (o : κ.Orientation) (f : V.Flag) : + (orientOfEq hF o).isOut f = o.isOut f := by + subst hF + rfl + +end FamilyCongr + +open Classical in +/-- **The open glue's value where it applies.** Stated with the +lifted subset's own proofs, so that the call site may supply them +rather than reconstruct the definition's. -/ +theorem glueDataOpen_pos {α : Type} [LinearOrder α] + {V : Fragment α} {i j : α} (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (𝒟 : DataFamily V) (t : Finset (SurvivingFlag V i j)) + (hct : ∀ f ∈ t, (V.gluePairOpen i j hij hopen).pairing f ∈ t) + (hEt : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).CanonData) + (hcL : ∀ f ∈ liftSubsetOpen hopen t, + V.pairing f ∈ liftSubsetOpen hopen t) + (hEL : (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).Eulerian) + (hneL : Nonempty (EdgeSubset.mk (liftSubsetOpen hopen t) + hcL : EdgeSubset V).CanonData) + (hag : (𝒟 (liftSubsetOpen hopen t) hcL hEL hneL).2.isOut + (V.pairing (V.boundaryFlag j)) + = !(𝒟 (liftSubsetOpen hopen t) hcL hEL hneL).2.isOut + (V.pairing (V.boundaryFlag i))) : + (glueDataOpen hij hopen 𝒟 t hct hEt hnet).1 + = RelTransitionSystem.glueOpen hij hopen t hct hcL + (𝒟 (liftSubsetOpen hopen t) hcL hEL hneL).1 := by + unfold glueDataOpen + rw [dite_eq_left hag] + +open Classical in +/-- **The closing glue's directions.** A closing cut rewires +nothing, so the glued orientation reads a surviving flag exactly as +the family at the lift does. -/ +theorem isOut_glueDataClosed_pos {α : Type} [LinearOrder α] + {V : Fragment α} {i j : α} + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (b : Bool) (𝒟 : DataFamily V) (t : Finset (SurvivingFlag V i j)) + (hct : ∀ f ∈ t, (V.gluePairClosed i j hclosed).pairing f ∈ t) + (hEt : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).CanonData) + (hcL : ∀ f ∈ liftSubsetClosed t b, + V.pairing f ∈ liftSubsetClosed t b) + (hEL : (EdgeSubset.mk (liftSubsetClosed t b) hcL : + EdgeSubset V).Eulerian) + (hneL : Nonempty (EdgeSubset.mk (liftSubsetClosed t b) hcL : + EdgeSubset V).CanonData) + (f' : SurvivingFlag V i j) : + (glueDataClosed hclosed b 𝒟 t hct hEt hnet).2.isOut f' + = (𝒟 (liftSubsetClosed t b) hcL hEL hneL).2.isOut f'.val := + rfl + +open Classical in +/-- **The open glue's directions where it applies.** -/ +theorem isOut_glueDataOpen_pos {α : Type} [LinearOrder α] + {V : Fragment α} {i j : α} (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (𝒟 : DataFamily V) (t : Finset (SurvivingFlag V i j)) + (hct : ∀ f ∈ t, (V.gluePairOpen i j hij hopen).pairing f ∈ t) + (hEt : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).CanonData) + (hcL : ∀ f ∈ liftSubsetOpen hopen t, + V.pairing f ∈ liftSubsetOpen hopen t) + (hEL : (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).Eulerian) + (hneL : Nonempty (EdgeSubset.mk (liftSubsetOpen hopen t) + hcL : EdgeSubset V).CanonData) + (hag : (𝒟 (liftSubsetOpen hopen t) hcL hEL hneL).2.isOut + (V.pairing (V.boundaryFlag j)) + = !(𝒟 (liftSubsetOpen hopen t) hcL hEL hneL).2.isOut + (V.pairing (V.boundaryFlag i))) + (f' : SurvivingFlag V i j) : + (glueDataOpen hij hopen 𝒟 t hct hEt hnet).2.isOut f' + = (𝒟 (liftSubsetOpen hopen t) hcL hEL hneL).2.isOut + f'.val := by + unfold glueDataOpen + rw [dite_eq_left hag] + rfl + +section FamilySubsetCongr + +variable {L : Type} + +/-- **A family at equal subsets has the same partner map.** The two +values have different types, so the equality is read on the partner +map rather than on the data. -/ +theorem match_dataFamily_congr [LinearOrder L] {V : Fragment L} + (𝒟 : DataFamily V) + {s₁ s₂ : Finset V.Flag} (hs : s₁ = s₂) + (hc₁ : ∀ f ∈ s₁, V.pairing f ∈ s₁) + (hE₁ : (EdgeSubset.mk s₁ hc₁).Eulerian) + (hne₁ : Nonempty (EdgeSubset.mk s₁ hc₁).CanonData) + (hc₂ : ∀ f ∈ s₂, V.pairing f ∈ s₂) + (hE₂ : (EdgeSubset.mk s₂ hc₂).Eulerian) + (hne₂ : Nonempty (EdgeSubset.mk s₂ hc₂).CanonData) + (f : V.Flag) : + (𝒟 s₁ hc₁ hE₁ hne₁).1.match_ f = (𝒟 s₂ hc₂ hE₂ hne₂).1.match_ f + := by + subst hs + rfl + +/-- **A family at equal subsets has the same directions.** -/ +theorem isOut_dataFamily_congr [LinearOrder L] {V : Fragment L} + (𝒟 : DataFamily V) + {s₁ s₂ : Finset V.Flag} (hs : s₁ = s₂) + (hc₁ : ∀ f ∈ s₁, V.pairing f ∈ s₁) + (hE₁ : (EdgeSubset.mk s₁ hc₁).Eulerian) + (hne₁ : Nonempty (EdgeSubset.mk s₁ hc₁).CanonData) + (hc₂ : ∀ f ∈ s₂, V.pairing f ∈ s₂) + (hE₂ : (EdgeSubset.mk s₂ hc₂).Eulerian) + (hne₂ : Nonempty (EdgeSubset.mk s₂ hc₂).CanonData) + (f : V.Flag) : + (𝒟 s₁ hc₁ hE₁ hne₁).2.isOut f = (𝒟 s₂ hc₂ hE₂ hne₂).2.isOut f + := by + subst hs + rfl + +end FamilySubsetCongr + +open Classical in +/-- **The single-cut round trip, at an open cut.** Lifting a family +across the cut and pushing it back returns the system up to +`MatchEq` — the glue rebuilds it rather than storing it. -/ +theorem match_unglue_glueDataOpen {α : Type} [LinearOrder α] + {V : Fragment α} {i j : α} (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (𝒟 : DataFamily V) {s : Finset V.Flag} + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc : EdgeSubset V).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc : EdgeSubset V).CanonData) + (hdc : ∀ f ∈ V.dropSubset i j s, + (V.gluePairOpen i j hij hopen).pairing f + ∈ V.dropSubset i j s) + (hcL : ∀ f ∈ liftSubsetOpen hopen (V.dropSubset i j s), + V.pairing f ∈ liftSubsetOpen hopen (V.dropSubset i j s)) + (hEL : (EdgeSubset.mk + (liftSubsetOpen hopen (V.dropSubset i j s)) hcL : + EdgeSubset V).Eulerian) + (hneL : Nonempty (EdgeSubset.mk + (liftSubsetOpen hopen (V.dropSubset i j s)) hcL : + EdgeSubset V).CanonData) + (hag : (𝒟 (liftSubsetOpen hopen (V.dropSubset i j s)) + hcL hEL hneL).2.isOut (V.pairing (V.boundaryFlag j)) + = !(𝒟 (liftSubsetOpen hopen (V.dropSubset i j s)) + hcL hEL hneL).2.isOut (V.pairing (V.boundaryFlag i))) : + ((unglueDataOpen hij hopen (glueDataOpen hij hopen 𝒟)) s hc hE + hne).1.MatchEq (𝒟 s hc hE hne).1 := by + have hlift : liftSubsetOpen hopen (V.dropSubset i j s) = s := + liftSubsetOpen_dropSubset hij hopen s hc + have hF : (EdgeSubset.mk + (liftSubsetOpen hopen (V.dropSubset i j s)) hcL : + EdgeSubset V) = EdgeSubset.mk s hc := EdgeSubset.ext hlift + intro f hf + have hfL : f ∈ (EdgeSubset.mk + (liftSubsetOpen hopen (V.dropSubset i j s)) hcL : + EdgeSubset V).internalFlags := by + rw [hF] + exact hf + unfold unglueDataOpen + rw [dite_eq_left hdc, match_relOfEq, + glueDataOpen_pos hij hopen 𝒟 (V.dropSubset i j s) hdc _ _ + hcL hEL hneL hag, + unglueOpen_glueOpen_match hij hopen (V.dropSubset i j s) hdc + hcL _ hfL] + exact match_dataFamily_congr 𝒟 hlift hcL hEL hneL hc hE hne f + +open Classical in +/-- **The single-cut round trip on directions, at an open cut.** At +a surviving flag the round trip returns the direction on the nose. -/ +theorem isOut_unglue_glueDataOpen {α : Type} [LinearOrder α] + {V : Fragment α} {i j : α} (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (𝒟 : DataFamily V) {s : Finset V.Flag} + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc : EdgeSubset V).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc : EdgeSubset V).CanonData) + (hdc : ∀ f ∈ V.dropSubset i j s, + (V.gluePairOpen i j hij hopen).pairing f + ∈ V.dropSubset i j s) + (hcL : ∀ f ∈ liftSubsetOpen hopen (V.dropSubset i j s), + V.pairing f ∈ liftSubsetOpen hopen (V.dropSubset i j s)) + (hEL : (EdgeSubset.mk + (liftSubsetOpen hopen (V.dropSubset i j s)) hcL : + EdgeSubset V).Eulerian) + (hneL : Nonempty (EdgeSubset.mk + (liftSubsetOpen hopen (V.dropSubset i j s)) hcL : + EdgeSubset V).CanonData) + (hag : (𝒟 (liftSubsetOpen hopen (V.dropSubset i j s)) + hcL hEL hneL).2.isOut (V.pairing (V.boundaryFlag j)) + = !(𝒟 (liftSubsetOpen hopen (V.dropSubset i j s)) + hcL hEL hneL).2.isOut (V.pairing (V.boundaryFlag i))) + (f : V.Flag) (h1 : f ≠ V.boundaryFlag i) + (h2 : f ≠ V.boundaryFlag j) : + ((unglueDataOpen hij hopen (glueDataOpen hij hopen 𝒟)) s hc hE + hne).2.isOut f = (𝒟 s hc hE hne).2.isOut f := by + have hlift : liftSubsetOpen hopen (V.dropSubset i j s) = s := + liftSubsetOpen_dropSubset hij hopen s hc + unfold unglueDataOpen + rw [dite_eq_left hdc, isOut_orientOfEq] + refine Eq.trans (unglueIsOut_of_surviving _ f ⟨h1, h2⟩) ?_ + rw [isOut_glueDataOpen_pos hij hopen 𝒟 (V.dropSubset i j s) hdc + _ _ hcL hEL hneL hag] + exact isOut_dataFamily_congr 𝒟 hlift hcL hEL hneL hc hE hne f + +open Classical in +/-- **The single-cut round trip, at a closing cut.** With the bit +the subset itself determines, lifting and pushing back returns the +system up to `MatchEq`. -/ +theorem match_unglue_glueDataClosed {α : Type} [LinearOrder α] + {V : Fragment α} {i j : α} (hij : i ≠ j) + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (𝒟 : DataFamily V) {s : Finset V.Flag} + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc : EdgeSubset V).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc : EdgeSubset V).CanonData) + (hcL : ∀ f ∈ liftSubsetClosed (V.dropSubset i j s) + (decide (V.boundaryFlag i ∈ s)), + V.pairing f ∈ liftSubsetClosed (V.dropSubset i j s) + (decide (V.boundaryFlag i ∈ s))) + (hEL : (EdgeSubset.mk (liftSubsetClosed (V.dropSubset i j s) + (decide (V.boundaryFlag i ∈ s))) hcL : + EdgeSubset V).Eulerian) + (hneL : Nonempty (EdgeSubset.mk + (liftSubsetClosed (V.dropSubset i j s) + (decide (V.boundaryFlag i ∈ s))) hcL : + EdgeSubset V).CanonData) : + ((unglueDataClosed hij hclosed (glueDataClosed hclosed + (decide (V.boundaryFlag i ∈ s)) 𝒟)) s hc hE + hne).1.MatchEq (𝒟 s hc hE hne).1 := by + have hlift : liftSubsetClosed (V.dropSubset i j s) + (decide (V.boundaryFlag i ∈ s)) = s := + liftSubsetClosed_dropSubset hij hclosed s hc + have hF : (EdgeSubset.mk (liftSubsetClosed (V.dropSubset i j s) + (decide (V.boundaryFlag i ∈ s))) hcL : + EdgeSubset V) = EdgeSubset.mk s hc := EdgeSubset.ext hlift + intro f hf + have hfL : f ∈ (EdgeSubset.mk + (liftSubsetClosed (V.dropSubset i j s) + (decide (V.boundaryFlag i ∈ s))) hcL : + EdgeSubset V).internalFlags := by + rw [hF] + exact hf + unfold unglueDataClosed + rw [match_relOfEq] + refine Eq.trans (unglueClosed_glueClosed_match hclosed + (decide (V.boundaryFlag i ∈ s)) (V.dropSubset i j s) _ hcL + (𝒟 (liftSubsetClosed (V.dropSubset i j s) + (decide (V.boundaryFlag i ∈ s))) hcL hEL hneL).1 hfL) ?_ + exact match_dataFamily_congr 𝒟 hlift hcL hEL hneL hc hE hne f + +open Classical in +/-- **The single-cut round trip on directions, at a closing cut.** -/ +theorem isOut_unglue_glueDataClosed {α : Type} [LinearOrder α] + {V : Fragment α} {i j : α} (hij : i ≠ j) + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (𝒟 : DataFamily V) {s : Finset V.Flag} + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc : EdgeSubset V).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc : EdgeSubset V).CanonData) + (hcL : ∀ f ∈ liftSubsetClosed (V.dropSubset i j s) + (decide (V.boundaryFlag i ∈ s)), + V.pairing f ∈ liftSubsetClosed (V.dropSubset i j s) + (decide (V.boundaryFlag i ∈ s))) + (hEL : (EdgeSubset.mk (liftSubsetClosed (V.dropSubset i j s) + (decide (V.boundaryFlag i ∈ s))) hcL : + EdgeSubset V).Eulerian) + (hneL : Nonempty (EdgeSubset.mk + (liftSubsetClosed (V.dropSubset i j s) + (decide (V.boundaryFlag i ∈ s))) hcL : + EdgeSubset V).CanonData) + (f : V.Flag) (h1 : f ≠ V.boundaryFlag i) + (h2 : f ≠ V.boundaryFlag j) : + ((unglueDataClosed hij hclosed (glueDataClosed hclosed + (decide (V.boundaryFlag i ∈ s)) 𝒟)) s hc hE hne).2.isOut f + = (𝒟 s hc hE hne).2.isOut f := by + have hlift : liftSubsetClosed (V.dropSubset i j s) + (decide (V.boundaryFlag i ∈ s)) = s := + liftSubsetClosed_dropSubset hij hclosed s hc + unfold unglueDataClosed + rw [isOut_orientOfEq] + refine Eq.trans (unglueIsOut_of_surviving _ f ⟨h1, h2⟩) ?_ + exact isOut_dataFamily_congr 𝒟 hlift hcL hEL hneL hc hE hne f + +section TransportRoundTrip + +variable {L : Type} + +/-- **The relabel round trip is the identity on families.** -/ +theorem relabelData_roundTrip {α' β' : Type} [LinearOrder α'] + [LinearOrder β'] (e : α' ≃o β') {W' : Fragment α'} + (𝒟 : DataFamily W') : + relabelDataDown e (relabelDataUp e 𝒟) = 𝒟 := rfl + +/-- **The transport round trip is the identity on families.** -/ +theorem dataOfEq_roundTrip [LinearOrder L] + {V₁ V₂ : Fragment L} (h : V₁ = V₂) + (𝒟 : DataFamily V₁) : + dataOfEq h (dataOfEq h.symm 𝒟) = 𝒟 := by + subst h + rfl + +end TransportRoundTrip + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseDischarge.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseDischarge.lean new file mode 100644 index 0000000000..789ebbf214 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseDischarge.lean @@ -0,0 +1,32 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalAgreement + +/-! +# Unconditional consequences of Eulerian independence + +`EulerianIndependence` is a theorem (`eulerianIndependence`), so +the choice-free value lemma and equivalence invariance of the +mixed partition value hold unconditionally. +-/ + +@[expose] public section + +namespace RS + +/-- The choice-free value lemma, unconditionally: the choice-based +mixed value equals the summand at any concrete transition data. -/ +theorem EdgeSubset.mixedValue_eq_summand_open + {α : Type} {W : Fragment α} (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) + {κ : F.TransitionSystem} (o : κ.Orientation) : + F.mixedValue h = F.mixedSummand h o := + EdgeSubset.mixedValue_eq_summand eulerianIndependence F h o + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseFamily.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseFamily.lean new file mode 100644 index 0000000000..8e157ca851 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseFamily.lean @@ -0,0 +1,2346 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConversePair + +/-! +# The pair family and the base sum + +A choice of pair datum (`ConversePair.lean`) at every subset of the +composition's base: the family `pairFamily`, its behaviour under +the interface glue, and the sum of the composition's own terms over +the base. The sum is read with the bits each subset itself +determines, and `base_sum_eq_superForm_pairing_bitsOf` writes it as +the super form pairing of the two fragments' tensors — the tensor +side of the Gram identity. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + +open Fragment +/-- The lexicographic order on the interface's label type. -/ +@[reducible] local instance famBaseOrder (n : ℕ) : + LinearOrder (Fin (0 + n) ⊕ Fin (n + 0)) := + sumLexLinearOrder _ _ + +/-- The same order one stage up. -/ +@[reducible] local instance famOrderSucc (n : ℕ) : + LinearOrder (Fin (0 + n + 1) ⊕ Fin (n + 1 + 0)) := + sumLexLinearOrder _ _ + +/-- The order a stage's surviving labels carry. -/ +@[reducible] local instance famSurvOrder (n : ℕ) : + LinearOrder (SurvivingLabel + (Fin (0 + n + 1) ⊕ Fin (n + 1 + 0)) (cutL n) (cutR n)) := + sumLexSubtypeLinearOrder _ _ _ + +/-- The order the composition's own label type carries. -/ +@[reducible] local instance famTopOrder : + LinearOrder (Fin 0 ⊕ Fin 0) := + sumLexLinearOrder _ _ + +open Classical in +/-- **The pair datum, against the total summand.** RS21's (13) and +(14) in the form the composition's sum needs: no state-matching +hypothesis, the mismatched states contributing nothing on both +sides. -/ +theorem exists_pairDatum_total {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (t : ℕ) (F G : Fragment (Fin t)) + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + (hE₁ : (EdgeSubset.mk s₁ hc₁).Eulerian) + (hn₁ : Nonempty (EdgeSubset.mk s₁ hc₁).CanonData) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (hE₂ : (EdgeSubset.mk s₂ hc₂).Eulerian) + (hn₂ : Nonempty (EdgeSubset.mk s₂ hc₂).CanonData) + (hused : ∀ i : Fin t, + F.boundaryFlag i ∈ s₁ ↔ G.boundaryFlag i ∈ s₂) + (hb : ∀ i : Fin t, + F.boundaryFlag i ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags + ↔ G.boundaryFlag i ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags) + : + ∃ (κ : (EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂)).RelTransitionSystem) + (O : κ.Orientation), + ((∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * tensorTermAt F h s₁ x + * tensorTermAt G h s₂ y) + = (-1 : ℂ) ^ (glueData t (closeBase F G) + (pairStage hc₁ hc₂ hused (Classical.choice hn₁).1 + (Classical.choice hn₂).1)).rel.openCircuitCount + * ∑ x : GenBoundaryState k ℓ (Fin t), + edgeTermOf h ⟨κ, O⟩ (diagOf t x) + (glueCount t (closeBase F G) + (pairStage hc₁ hc₂ hused (Classical.choice hn₁).1 + (Classical.choice hn₂).1))) + ∧ (∀ ℓ' : Fin (0 + t) ⊕ Fin (t + 0), + O.isOut ((closeBase F G).pairing + ((closeBase F G).boundaryFlag ℓ')) + = !O.isOut ((closeBase F G).boundaryFlag ℓ')) + ∧ (∀ m : Fin t, + O.isOut ((closeBase F G).boundaryFlag (intR t m)) + = !O.isOut ((closeBase F G).boundaryFlag (intL t m))) + ∧ κ.MatchEq (pairStage hc₁ hc₂ hused (Classical.choice hn₁).1 + (Classical.choice hn₂).1).rel := by + obtain ⟨o₁', o₂', M₁, M₂, hM₁, hM₂, halt, hag₁, hag₂, _halt', + hval⟩ := + exists_pairTerm_eq_glued_sign h t F G hc₁ hE₁ hn₁ hc₂ hE₂ hn₂ + hused hb + obtain ⟨c, hcol, hcut⟩ := + exists_cut_colouring t (closeBase F G) + refine ⟨_, orientReplace + (prodOrient + (relabelOrientUp (finCongr (by omega : t = 0 + t)) + (EdgeSubset.relabelDown + (finCongr (by omega : t = 0 + t)) + (leftSub (EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂)))) + (orientOfEq (relabelDown_leftSub_closeJoin + (closeJoin_pairing_mem hc₁ hc₂) hc₁).symm o₁')) + (relabelOrientUp (finCongr (by omega : t = t + 0)) + (EdgeSubset.relabelDown + (finCongr (by omega : t = t + 0)) + (rightSub (EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂)))) + (orientOfEq (relabelDown_rightSub_closeJoin + (closeJoin_pairing_mem hc₁ hc₂) hc₂).symm o₂'))) + (pairTailFun hc₁ hc₂ M₁ M₂ c), ?_, ?_, ?_, ?_⟩ + · rw [hval, pow_add, mul_assoc, Finset.mul_sum] + refine congrArg (fun z => _ * z) (Finset.sum_congr rfl + (fun st _ => ?_)) + unfold edgeTermOf + split_ifs with hbnd + · obtain ⟨hm₁, hm₂⟩ := (matches_closeJoin_iff s₁ s₂ st).mp hbnd + refine congrArg (fun z => _ * z) ?_ + rw [edgeSum_orientReplace] + refine pairAgreeValue_eq_edgeSum_closeJoin h t F G hc₁ hc₂ o₁' + o₂' st hbnd ?_ ?_ + · rw [show (leftSub (EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂))).flags = s₁ from + leftPart_joinParts s₁ s₂] + exact hm₁ + · rw [show (rightSub (EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂))).flags = s₂ from + rightPart_joinParts s₁ s₂] + exact hm₂ + · by_cases hm₁ : genBoundarySubsetMatches F s₁ st + · by_cases hm₂ : genBoundarySubsetMatches G s₂ st + · exact absurd ((matches_closeJoin_iff s₁ s₂ st).mpr + ⟨hm₁, hm₂⟩) hbnd + · rw [show pairAgreeValue (EdgeSubset.mk s₁ hc₁) + (EdgeSubset.mk s₂ hc₂) h o₁' o₂' st = 0 by + unfold pairAgreeValue + rw [dite_eq_left hm₁, dite_eq_right hm₂]] + ring + · rw [pairAgreeValue_eq_zero (EdgeSubset.mk s₁ hc₁) + (EdgeSubset.mk s₂ hc₂) h o₁' o₂' st hm₁] + ring + · exact orientReplace_pairTailFun_flip hc₁ hc₂ o₁' o₂' M₁ M₂ c + hcol hM₁ hM₂ hag₁ hag₂ _ + (fun x => isOut_orientOfEq _ o₁' x) + (fun y => isOut_orientOfEq _ o₂' y) + · exact orientReplace_pairTailFun_cut hc₁ hc₂ M₁ M₂ c hcut hb halt + _ + · intro f hf + cases f with + | inl g => + change Sum.inl _ = Sum.inl _ + refine congrArg Sum.inl ?_ + exact Eq.trans (match_relOfEq _ (Classical.choice hn₁).1 g) + (match_relOfEq _ (relabelTransUp (leftIso t).toEquiv + (EdgeSubset.mk s₁ hc₁) (Classical.choice hn₁).1) g).symm + | inr g => + change Sum.inr _ = Sum.inr _ + refine congrArg Sum.inr ?_ + exact Eq.trans (match_relOfEq _ (Classical.choice hn₂).1 g) + (match_relOfEq _ (relabelTransUp (rightIso t).toEquiv + (EdgeSubset.mk s₂ hc₂) (Classical.choice hn₂).1) g).symm + +open Classical in +/-- **The pair datum, read at an equal subset.** Everything the +datum says transports along an equality of subsets. -/ +theorem exists_pairDatum_ofEq {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (t : ℕ) (F G : Fragment (Fin t)) + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + (hE₁ : (EdgeSubset.mk s₁ hc₁).Eulerian) + (hn₁ : Nonempty (EdgeSubset.mk s₁ hc₁).CanonData) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (hE₂ : (EdgeSubset.mk s₂ hc₂).Eulerian) + (hn₂ : Nonempty (EdgeSubset.mk s₂ hc₂).CanonData) + (hused : ∀ i : Fin t, + F.boundaryFlag i ∈ s₁ ↔ G.boundaryFlag i ∈ s₂) + (hb : ∀ i : Fin t, + F.boundaryFlag i ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags + ↔ G.boundaryFlag i ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags) + (u : Finset (closeBase F G).Flag) + (hc : ∀ f ∈ u, (closeBase F G).pairing f ∈ u) + (hu : (EdgeSubset.mk u hc : EdgeSubset (closeBase F G)) + = EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂)) : + ∃ (κ : (EdgeSubset.mk u hc).RelTransitionSystem) + (O : κ.Orientation), + ((∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * tensorTermAt F h s₁ x + * tensorTermAt G h s₂ y) + = (-1 : ℂ) ^ (glueData t (closeBase F G) + (pairStage hc₁ hc₂ hused (Classical.choice hn₁).1 + (Classical.choice hn₂).1)).rel.openCircuitCount + * ∑ x : GenBoundaryState k ℓ (Fin t), + edgeTermOf h ⟨κ, O⟩ (diagOf t x) + (glueCount t (closeBase F G) + (pairStage hc₁ hc₂ hused (Classical.choice hn₁).1 + (Classical.choice hn₂).1))) + ∧ (∀ ℓ' : Fin (0 + t) ⊕ Fin (t + 0), + O.isOut ((closeBase F G).pairing + ((closeBase F G).boundaryFlag ℓ')) + = !O.isOut ((closeBase F G).boundaryFlag ℓ')) + ∧ (∀ m : Fin t, + O.isOut ((closeBase F G).boundaryFlag (intR t m)) + = !O.isOut ((closeBase F G).boundaryFlag (intL t m))) + ∧ κ.MatchEq (relOfEq hu.symm + (pairStage hc₁ hc₂ hused (Classical.choice hn₁).1 + (Classical.choice hn₂).1).rel) := by + obtain ⟨κ₀, O₀, hval, hflip, hcut, hmatch⟩ := + exists_pairDatum_total h t F G hc₁ hE₁ hn₁ hc₂ hE₂ hn₂ hused + hb + refine ⟨relOfEq hu.symm κ₀, orientOfEq hu.symm O₀, ?_, + fun ℓ' => ?_, fun m => ?_, ?_⟩ + · refine hval.trans (congrArg (fun z => _ * z) + (Finset.sum_congr rfl (fun x _ => ?_))) + exact (edgeTermOf_ofEq h hu.symm ⟨κ₀, O₀⟩ (diagOf t x) _).symm + · rw [isOut_orientOfEq hu.symm O₀ _, isOut_orientOfEq hu.symm O₀ _] + exact hflip ℓ' + · rw [isOut_orientOfEq hu.symm O₀ _, isOut_orientOfEq hu.symm O₀ _] + exact hcut m + · intro f hf + refine Eq.trans (match_relOfEq hu.symm κ₀ f) (Eq.trans ?_ + (match_relOfEq hu.symm + (pairStage hc₁ hc₂ hused (Classical.choice hn₁).1 + (Classical.choice hn₂).1).rel f).symm) + exact hmatch f (by + rw [congrArg EdgeSubset.internalFlags hu] at hf + exact hf) + +/-- **Matching used labels make the join balanced.** -/ +theorem cutBalanced_closeJoin {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} {s₂ : Finset G.Flag} + (hused : ∀ i : Fin t, + F.boundaryFlag i ∈ s₁ ↔ G.boundaryFlag i ∈ s₂) : + CutBalanced (closeBase F G) (closeJoin s₁ s₂) := fun m => + (inl_mem_joinParts (s₁ := s₁) (s₂ := s₂) + (f := F.boundaryFlag m)).trans + ((hused m).trans (inr_mem_joinParts (s₁ := s₁) (s₂ := s₂) + (f := G.boundaryFlag m)).symm) + +open Classical in +/-- **A datum at every subset**, carrying both the directions and, +at a join of compatible halves, RS21's value. -/ +theorem exists_pairDatum_sigma_full {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (t : ℕ) (F G : Fragment (Fin t)) + (u : Finset (closeBase F G).Flag) + (hc : ∀ f ∈ u, (closeBase F G).pairing f ∈ u) + (hE : (EdgeSubset.mk u hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk u hc).CanonData) : + ∃ d : Σ κ : (EdgeSubset.mk u hc).RelTransitionSystem, + κ.Orientation, + (CutBalanced (closeBase F G) u → + (∀ ℓ' : Fin (0 + t) ⊕ Fin (t + 0), + d.2.isOut ((closeBase F G).pairing + ((closeBase F G).boundaryFlag ℓ')) + = !d.2.isOut ((closeBase F G).boundaryFlag ℓ')) + ∧ (∀ m : Fin t, + d.2.isOut ((closeBase F G).boundaryFlag (intR t m)) + = !d.2.isOut + ((closeBase F G).boundaryFlag (intL t m)))) + ∧ ∀ (s₁ : Finset F.Flag) (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + (_hE₁ : (EdgeSubset.mk s₁ hc₁).Eulerian) + (hn₁ : Nonempty (EdgeSubset.mk s₁ hc₁).CanonData) + (s₂ : Finset G.Flag) (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (_hE₂ : (EdgeSubset.mk s₂ hc₂).Eulerian) + (hn₂ : Nonempty (EdgeSubset.mk s₂ hc₂).CanonData) + (hused : ∀ i : Fin t, + F.boundaryFlag i ∈ s₁ ↔ G.boundaryFlag i ∈ s₂) + (_hb : ∀ i : Fin t, + F.boundaryFlag i ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags + ↔ G.boundaryFlag i + ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags) + (hu : (EdgeSubset.mk u hc : EdgeSubset (closeBase F G)) + = EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂)), + d.1.MatchEq (relOfEq hu.symm + (pairStage hc₁ hc₂ hused (Classical.choice hn₁).1 + (Classical.choice hn₂).1).rel) ∧ + ((∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * tensorTermAt F h s₁ x + * tensorTermAt G h s₂ y) + = (-1 : ℂ) ^ (glueData t (closeBase F G) + (pairStage hc₁ hc₂ hused (Classical.choice hn₁).1 + (Classical.choice hn₂).1)).rel.openCircuitCount + * ∑ x : GenBoundaryState k ℓ (Fin t), + edgeTermOf h d (diagOf t x) + (glueCount t (closeBase F G) + (pairStage hc₁ hc₂ hused + (Classical.choice hn₁).1 + (Classical.choice hn₂).1))) := by + -- ═══════ IS THE SUBSET CUT-BALANCED? ═══════ + -- A balanced subset carries a datum on each side, which join; + -- an unbalanced one contributes nothing. + by_cases hcb : CutBalanced (closeBase F G) u + · obtain ⟨hcL, hEL, hneL⟩ := join_support_left hc hE hne + obtain ⟨hcR, hER, hneR⟩ := join_support_right hc hE hne + have hused : ∀ i : Fin t, F.boundaryFlag i ∈ leftPart u + ↔ G.boundaryFlag i ∈ rightPart u := fun i => + (mem_leftPart (s := u) (f := F.boundaryFlag i)).trans + ((hcb i).trans (mem_rightPart (s := u) + (f := G.boundaryFlag i)).symm) + have hb : ∀ i : Fin t, + F.boundaryFlag i ∈ (EdgeSubset.mk (leftPart u) hcL : + EdgeSubset F).boundaryFlags + ↔ G.boundaryFlag i ∈ (EdgeSubset.mk (rightPart u) hcR : + EdgeSubset G).boundaryFlags := by + intro i + constructor + · intro hx + exact boundaryFlag_mem_boundaryFlags + (F := (EdgeSubset.mk (rightPart u) hcR : EdgeSubset G)) + (a := i) ((hused i).mp (mem_flags_of_boundaryFlags _ hx)) + · intro hx + exact boundaryFlag_mem_boundaryFlags + (F := (EdgeSubset.mk (leftPart u) hcL : EdgeSubset F)) + (a := i) ((hused i).mpr (mem_flags_of_boundaryFlags _ hx)) + have hEL' : (EdgeSubset.mk (leftPart u) hcL : + EdgeSubset F).Eulerian := + (relabelUp_eulerian (finCongr (by omega : t = 0 + t)) + (EdgeSubset.mk (leftPart u) hcL : EdgeSubset F)).mp hEL + have hneL' : Nonempty (EdgeSubset.mk (leftPart u) hcL : + EdgeSubset F).CanonData := + (EdgeSubset.nonempty_canonData_relabelUp + (Fin.castOrderIso (by omega : t = 0 + t)) + (EdgeSubset.mk (leftPart u) hcL : EdgeSubset F)).mp hneL + have hER' : (EdgeSubset.mk (rightPart u) hcR : + EdgeSubset G).Eulerian := + (relabelUp_eulerian (finCongr (by omega : t = t + 0)) + (EdgeSubset.mk (rightPart u) hcR : EdgeSubset G)).mp hER + have hneR' : Nonempty (EdgeSubset.mk (rightPart u) hcR : + EdgeSubset G).CanonData := + (EdgeSubset.nonempty_canonData_relabelUp + (Fin.castOrderIso (by omega : t = t + 0)) + (EdgeSubset.mk (rightPart u) hcR : EdgeSubset G)).mp hneR + have hu0 : (EdgeSubset.mk u hc : EdgeSubset (closeBase F G)) + = (EdgeSubset.mk (closeJoin (leftPart u) (rightPart u)) + (closeJoin_pairing_mem hcL hcR) : + EdgeSubset (closeBase F G)) := + EdgeSubset.ext (joinParts_parts u).symm + obtain ⟨κ₀, O₀, hval, hflip, hcut, hmatch⟩ := + exists_pairDatum_ofEq h t F G hcL hEL' hneL' hcR hER' hneR' + hused hb u hc hu0 + refine ⟨⟨κ₀, O₀⟩, fun _ => ⟨hflip, hcut⟩, ?_⟩ + intro s₁ hc₁ hE₁ hn₁ s₂ hc₂ hE₂ hn₂ hused' hb' hu' + have hflags : u = closeJoin s₁ s₂ := + congrArg EdgeSubset.flags hu' + have h1 : s₁ = leftPart u := by + rw [hflags] + exact (leftPart_joinParts s₁ s₂).symm + have h2 : s₂ = rightPart u := by + rw [hflags] + exact (rightPart_joinParts s₁ s₂).symm + subst h1 + subst h2 + exact ⟨hmatch, hval⟩ + · obtain ⟨κ, o, -⟩ := Classical.choice hne + refine ⟨⟨κ, o⟩, fun hx => absurd hx hcb, ?_⟩ + intro s₁ hc₁ hE₁ hn₁ s₂ hc₂ hE₂ hn₂ hused' hb' hu' + have hflags : u = closeJoin s₁ s₂ := + congrArg EdgeSubset.flags hu' + exact absurd (by + rw [hflags] + exact cutBalanced_closeJoin hused') hcb + +open Classical in +/-- **The pair family.** At every balanced subset of the base it +carries the directions the lift asks for. -/ +noncomputable def pairFamily {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (t : ℕ) (F G : Fragment (Fin t)) : + DataFamily (closeBase F G) := + fun u hc hE hne => + Classical.choose + (exists_pairDatum_sigma_full h t F G u hc hE hne) + +open Classical in +/-- **The pair family has the base's directions.** -/ +theorem baseDirections_pairFamily {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (t : ℕ) (F G : Fragment (Fin t)) : + BaseDirections (closeBase F G) (pairFamily h t F G) := by + intro u hc hE hne hcb + obtain ⟨hflip, hcut⟩ := (Classical.choose_spec + (exists_pairDatum_sigma_full h t F G u hc hE hne)).1 hcb + exact ⟨hflip, fun m => + (isOut_cut_iff_boundary _ hflip m).mpr (hcut m)⟩ + +open Classical in +/-- **The pair family's system is the pair stage's.** The two agree +on the partner map, which is what the circuit count sees. -/ +theorem pairFamily_matchEq {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (t : ℕ) (F G : Fragment (Fin t)) + (u : Finset (closeBase F G).Flag) + (hc : ∀ f ∈ u, (closeBase F G).pairing f ∈ u) + (hE : (EdgeSubset.mk u hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk u hc).CanonData) + (s₁ : Finset F.Flag) (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + (hE₁ : (EdgeSubset.mk s₁ hc₁).Eulerian) + (hn₁ : Nonempty (EdgeSubset.mk s₁ hc₁).CanonData) + (s₂ : Finset G.Flag) (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (hE₂ : (EdgeSubset.mk s₂ hc₂).Eulerian) + (hn₂ : Nonempty (EdgeSubset.mk s₂ hc₂).CanonData) + (hused : ∀ i : Fin t, + F.boundaryFlag i ∈ s₁ ↔ G.boundaryFlag i ∈ s₂) + (hb : ∀ i : Fin t, + F.boundaryFlag i ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags + ↔ G.boundaryFlag i + ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags) + (hu : (EdgeSubset.mk u hc : EdgeSubset (closeBase F G)) + = EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂)) : + (pairFamily h t F G u hc hE hne).1.MatchEq + (relOfEq hu.symm + (pairStage hc₁ hc₂ hused (Classical.choice hn₁).1 + (Classical.choice hn₂).1).rel) := + ((Classical.choose_spec + (exists_pairDatum_sigma_full h t F G u hc hE hne)).2 s₁ hc₁ + hE₁ hn₁ s₂ hc₂ hE₂ hn₂ hused hb hu).1 + +open Classical in +/-- **The pair family computes RS21's pair term.** At a join of +compatible halves, the family's own datum is the one (13) and (14) +speak of. -/ +theorem pairFamily_value {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (t : ℕ) (F G : Fragment (Fin t)) + (u : Finset (closeBase F G).Flag) + (hc : ∀ f ∈ u, (closeBase F G).pairing f ∈ u) + (hE : (EdgeSubset.mk u hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk u hc).CanonData) + (s₁ : Finset F.Flag) (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + (hE₁ : (EdgeSubset.mk s₁ hc₁).Eulerian) + (hn₁ : Nonempty (EdgeSubset.mk s₁ hc₁).CanonData) + (s₂ : Finset G.Flag) (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (hE₂ : (EdgeSubset.mk s₂ hc₂).Eulerian) + (hn₂ : Nonempty (EdgeSubset.mk s₂ hc₂).CanonData) + (hused : ∀ i : Fin t, + F.boundaryFlag i ∈ s₁ ↔ G.boundaryFlag i ∈ s₂) + (hb : ∀ i : Fin t, + F.boundaryFlag i ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags + ↔ G.boundaryFlag i + ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags) + (hu : (EdgeSubset.mk u hc : EdgeSubset (closeBase F G)) + = EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂)) : + (∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * tensorTermAt F h s₁ x + * tensorTermAt G h s₂ y) + = (-1 : ℂ) ^ (glueData t (closeBase F G) + (pairStage hc₁ hc₂ hused (Classical.choice hn₁).1 + (Classical.choice hn₂).1)).rel.openCircuitCount + * ∑ x : GenBoundaryState k ℓ (Fin t), + edgeTermOf h (pairFamily h t F G u hc hE hne) + (diagOf t x) + (glueCount t (closeBase F G) + (pairStage hc₁ hc₂ hused (Classical.choice hn₁).1 + (Classical.choice hn₂).1)) := + ((Classical.choose_spec + (exists_pairDatum_sigma_full h t F G u hc hE hne)).2 s₁ hc₁ + hE₁ hn₁ s₂ hc₂ hE₂ hn₂ hused hb hu).2 + +/-- **The base's directions survive a stage of the lift.** Both +halves of the invariant come back at the stage: the glue neither +moves a direction nor breaks a flip. -/ +theorem baseDirections_stepDataUp (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (b : Bool) (𝒟 : DataFamily V) (hbd : BaseDirections V 𝒟) : + BaseDirections (stepFragment n V) (stepDataUp n V b 𝒟) := by + intro t hct hEt hnet hbal + have ht : t = flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) + (flagsOfEq (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (gluePair_eq_open n V hop).symm t) := + (flagsOfEq_symm (gluePair_eq_open n V hop).symm t).symm + have hcu := flagsOfEq_pairing_mem + (gluePair_eq_open n V hop).symm t hct + have hEg := (relabelUp_eulerian (stepIso n).toEquiv + (EdgeSubset.mk t hct)).mp hEt + have hneg := (nonempty_canonData_relabelUp (stepIso n) + (EdgeSubset.mk t hct)).mp hnet + have hEu := flagsOfEq_eulerian (gluePair_eq_open n V hop).symm t + hct hEg + have hneu := flagsOfEq_canon (gluePair_eq_open n V hop).symm t + hct hneg + have hcL := liftSubsetOpen_pairing_closed (cutL_ne_cutR n) hop _ + hcu + have hEL := (eulerian_lift_open_iff (cutL_ne_cutR n) hop _ hcu + hcL).mpr hEu + have hneL := nonempty_canonData_unglueOpen (cutL_ne_cutR n) hop _ + hcu hcL hneu + have hcbL : CutBalanced V + (liftSubsetOpen hop _) := + cutBalanced_liftSubsetOpen n V hop _ hcu (ht ▸ hbal) + have hag : (𝒟 _ hcL hEL hneL).2.isOut + (V.pairing (V.boundaryFlag (cutR n))) + = !(𝒟 _ hcL hEL hneL).2.isOut + (V.pairing (V.boundaryFlag (cutL n))) := by + have h := (hbd _ hcL hEL hneL hcbL).2 (Fin.last n) + rwa [intR_last, intL_last] at h + refine ⟨fun bl => ?_, fun m => ?_⟩ + · rw [chainDir_stepDataUp_eq n V hop b 𝒟 _ t ht hct hEt hnet hcL + hEL hneL hag (fun ℓ => (hbd _ hcL hEL hneL hcbL).1 ℓ) bl, + isOut_stepDataUp_boundaryFlag n V hop b 𝒟 _ t ht hct hEt hnet + hcL hEL hneL hag bl] + exact (hbd _ hcL hEL hneL hcbL).1 _ + · rw [chainDir_stepDataUp_eq n V hop b 𝒟 _ t ht hct hEt hnet hcL + hEL hneL hag (fun ℓ => (hbd _ hcL hEL hneL hcbL).1 ℓ) (intR n m), + chainDir_stepDataUp_eq n V hop b 𝒟 _ t ht hct hEt hnet hcL + hEL hneL hag (fun ℓ => (hbd _ hcL hEL hneL hcbL).1 ℓ) + (intL n m), + interfaceStepEquiv_symm_intR, interfaceStepEquiv_symm_intL] + exact (hbd _ hcL hEL hneL hcbL).2 _ + +open Classical in +/-- **The base's directions survive a closing glue.** A closing cut +rewires nothing, so the stage's family reads its boundary flags and +their partners exactly as the base family reads the lift's — and the +lift of a balanced subset is balanced. -/ +theorem baseDirections_stepDataUp_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (b : Bool) (𝒟 : DataFamily V) (hbd : BaseDirections V 𝒟) : + BaseDirections (stepFragment n V) (stepDataUp n V b 𝒟) := by + intro t hct hEt hnet hbal + have ht : t = flagsOfEq + (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (flagsOfEq (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (V.gluePairClosed (cutL n) (cutR n) hcl) + (gluePair_eq_closed n V hcl).symm t) := + (flagsOfEq_symm (gluePair_eq_closed n V hcl).symm t).symm + have hcu := flagsOfEq_pairing_mem + (gluePair_eq_closed n V hcl).symm t hct + have hEg := (relabelUp_eulerian (stepIso n).toEquiv + (EdgeSubset.mk t hct)).mp hEt + have hneg := (nonempty_canonData_relabelUp (stepIso n) + (EdgeSubset.mk t hct)).mp hnet + have hEu := flagsOfEq_eulerian (gluePair_eq_closed n V hcl).symm t + hct hEg + have hneu := flagsOfEq_canon (gluePair_eq_closed n V hcl).symm t + hct hneg + have hcL := liftSubsetClosed_pairing_closed hcl _ b hcu + have hEL := (eulerian_liftClosed_iff' hcl b _ hcu hcL).mpr hEu + have hneL := nonempty_canonData_unglueClosed hcl _ hcu b hcL hneu + have hcbL : CutBalanced V (liftSubsetClosed _ b) := + cutBalanced_liftSubsetClosed n V hcl _ b (ht ▸ hbal) + refine ⟨fun bl => ?_, fun m => ?_⟩ + · rw [chainDir_stepDataUp_eq_closed n V hcl b 𝒟 _ t ht hct hEt + hnet hcL hEL hneL bl, + isOut_stepDataUp_boundaryFlag_closed n V hcl b 𝒟 _ t ht hct + hEt hnet hcL hEL hneL bl] + exact (hbd _ hcL hEL hneL hcbL).1 _ + · rw [chainDir_stepDataUp_eq_closed n V hcl b 𝒟 _ t ht hct hEt + hnet hcL hEL hneL (intR n m), + chainDir_stepDataUp_eq_closed n V hcl b 𝒟 _ t ht hct hEt hnet + hcL hEL hneL (intL n m), + interfaceStepEquiv_symm_intR, interfaceStepEquiv_symm_intL] + exact (hbd _ hcL hEL hneL hcbL).2 _ + +open Classical in +/-- **The family alternates at every cut of the interface.** RS21's +step 1, as a condition on the family the lift consumes: at every +stage the data give the cut's two flags opposite directions, which is +what an open cut needs to glue its two arcs into one. -/ +def Aligned : (n : ℕ) → (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) → + (Fin n → Bool) → DataFamily V → Prop + | 0, _, _, _ => True + | n + 1, V, bits, 𝒟 => + (V.pairing (V.boundaryFlag (cutL n)) ≠ V.boundaryFlag (cutR n) → + ∀ (u : Finset V.Flag) (hc : ∀ f ∈ u, V.pairing f ∈ u) + (hE : (EdgeSubset.mk u hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk u hc).CanonData), + CutBalanced V u → + (𝒟 u hc hE hne).2.isOut (V.pairing (V.boundaryFlag (cutR n))) + = !(𝒟 u hc hE hne).2.isOut + (V.pairing (V.boundaryFlag (cutL n)))) + ∧ Aligned n (stepFragment n V) (fun a => bits a.castSucc) + (stepDataUp n V (bits (Fin.last n)) 𝒟) + +open Classical in +/-- **A subset, dropped to the next stage.** -/ +noncomputable def stageSubset (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (s : Finset V.Flag) : Finset (stepFragment n V).Flag := + if hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then + flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) s) + else + flagsOfEq (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hcl) + (V.dropSubset (cutL n) (cutR n) s) + +/-- **The bits a subset determines.** At each stage the bit records +whether the subset carries the cut's own edge; the deeper stages read +the dropped subset. -/ +noncomputable def bitsOf : ∀ (n : ℕ) + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) (_s : Finset V.Flag), + Fin n → Bool + | 0, _, _ => fun i => i.elim0 + | n + 1, V, s => + Fin.snoc + (bitsOf n (stepFragment n V) (stageSubset n V s)) + (decide (V.boundaryFlag (cutL n) ∈ s)) + +/-- The top bit a subset determines is whether it carries the cut. -/ +theorem bitsOf_last (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (s : Finset V.Flag) : + bitsOf (n + 1) V s (Fin.last n) + = decide (V.boundaryFlag (cutL n) ∈ s) := by + unfold bitsOf + exact Fin.snoc_last _ _ + +open Classical in +/-- **A balanced subset's drop is balanced.** -/ +theorem cutBalanced_stageSubset (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) (s : Finset V.Flag) + (hc : ∀ f ∈ s, V.pairing f ∈ s) (hbal : CutBalanced V s) : + CutBalanced (stepFragment n V) (stageSubset n V s) := by + intro b + have hlift : liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s) = s := + liftSubsetOpen_dropSubset (cutL_ne_cutR n) hop s hc + have key := fun bl => mem_stage_boundaryFlag_iff n V hop + (V.dropSubset (cutL n) (cutR n) s) bl + have hss : stageSubset n V s = flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) + (V.dropSubset (cutL n) (cutR n) s) := by + unfold stageSubset + exact dite_eq_right hop + rw [hss] + refine (key (intL n b)).trans (Iff.trans ?_ (key (intR n b)).symm) + rw [hlift, interfaceStepEquiv_symm_intL n b, + interfaceStepEquiv_symm_intR n b] + exact hbal b.castSucc + +/-- **A balanced subset agrees at the top cut.** -/ +theorem agreeingSubset_of_cutBalanced {n : ℕ} + {V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))} + {u : Finset V.Flag} (hc : ∀ f ∈ u, V.pairing f ∈ u) + (hcb : CutBalanced V u) : + AgreeingSubset (cutL n) (cutR n) u := by + refine ⟨hc, ?_⟩ + have h := hcb (Fin.last n) + rwa [intL_last, intR_last] at h + +/-- The lower bits a subset determines are the drop's own. -/ +theorem bitsOf_castSucc (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (s : Finset V.Flag) (a : Fin n) : + bitsOf (n + 1) V s a.castSucc + = bitsOf n (stepFragment n V) (stageSubset n V s) a := by + change (Fin.snoc (bitsOf n (stepFragment n V) (stageSubset n V s)) + (decide (V.boundaryFlag (cutL n) ∈ s)) : Fin (n + 1) → Bool) + a.castSucc + = bitsOf n (stepFragment n V) (stageSubset n V s) a + exact Fin.snoc_castSucc _ _ a + +/-- The stage subset, at a closing cut. -/ +theorem stageSubset_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) (s : Finset V.Flag) : + stageSubset n V s + = flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) s) := by + unfold stageSubset + exact dite_eq_left hcl + +/-- The stage subset, at an open cut. -/ +theorem stageSubset_open (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) (s : Finset V.Flag) : + stageSubset n V s + = flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) + (V.dropSubset (cutL n) (cutR n) s) := by + unfold stageSubset + exact dite_eq_right hop + +open Classical in +/-- **The base's directions give the alignment at every stage.** +With no closing cut, a family whose directions flip at the boundary +flags and alternate at every interface pair is aligned all the way +down the interface. -/ +theorem aligned_of_baseDirections : ∀ (n : ℕ) + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))), + ∀ (bits : Fin n → Bool) + (𝒟 : DataFamily V), BaseDirections V 𝒟 → Aligned n V bits 𝒟 + | 0, _, _, _, _ => trivial + | n + 1, V, bits, 𝒟, hbd => by + refine ⟨fun _ u hc hE hne hcb => ?_, ?_⟩ + · have h := (hbd u hc hE hne hcb).2 (Fin.last n) + rwa [intR_last, intL_last] at h + · by_cases hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) + · exact aligned_of_baseDirections n (stepFragment n V) _ _ + (baseDirections_stepDataUp_closed n V hcl + (bits (Fin.last n)) 𝒟 hbd) + · exact aligned_of_baseDirections n (stepFragment n V) _ _ + (baseDirections_stepDataUp n V hcl (bits (Fin.last n)) 𝒟 + hbd) + +open Classical in +/-- **The drop carries the stage's state, at a closing cut.** -/ +theorem dropSubset_matches_of_matches_closed {k ℓ : ℕ} (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (s : Finset V.Flag) (hc : ∀ f ∈ s, V.pairing f ∈ s) + (x : Fin (n + 1) → (Fin k ⊕ Fin (2 * ℓ))) + (hm : genBoundarySubsetMatches V s (diagOf (n + 1) x)) : + genBoundarySubsetMatches + (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.dropSubset (cutL n) (cutR n) s) + (stageState n (diagOf n (fun a => x a.castSucc))) := by + refine genBoundarySubsetMatches_glued_of_liftClosed hcl + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s)) _ + (x (Fin.last n)) (x (Fin.last n)) ?_ + rw [liftSubsetClosed_dropSubset (cutL_ne_cutR n) hcl s hc, + ← diagOf_succ n x] + exact hm + +open Classical in +/-- **The stage carries the stage's state, at a closing cut.** -/ +theorem stage_matches_of_matches_closed {k ℓ : ℕ} (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (s : Finset V.Flag) (hc : ∀ f ∈ s, V.pairing f ∈ s) + (x : Fin (n + 1) → (Fin k ⊕ Fin (2 * ℓ))) + (hm : genBoundarySubsetMatches V s (diagOf (n + 1) x)) : + genBoundarySubsetMatches (stepFragment n V) + (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) s)) + (diagOf n (fun a => x a.castSucc)) := by + refine (relabel_genBoundarySubsetMatches_iff + (interfaceStepEquiv 0 n 0) _ + (diagOf n (fun a => x a.castSucc))).mpr ?_ + exact genBoundarySubsetMatches_flagsOfEq + (gluePair_eq_closed n V hcl) _ _ + (dropSubset_matches_of_matches_closed n V hcl s hc x hm) + +open Classical in +/-- **The interface round trip at one subset, with the subset's own +bits.** A closing cut's lift needs a bit, and the bit the subset +itself determines is the one that returns it; the open cuts need the +alignment, as before. -/ +theorem match_pushData_liftData_bitsOf {k ℓ : ℕ} : ∀ (n : ℕ) + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) + (𝒟 : DataFamily V) (x : Fin n → (Fin k ⊕ Fin (2 * ℓ))) + (s : Finset V.Flag) (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData), + Aligned n V (bitsOf n V s) 𝒟 → + genBoundarySubsetMatches V s (diagOf n x) → + (pushData n V (liftData n V (bitsOf n V s) 𝒟) s hc hE + hne).1.MatchEq (𝒟 s hc hE hne).1 + | 0, V, 𝒟, _, s, hc, hE, hne, _, _ => + match_pushData_liftData_zero V (bitsOf 0 V s) 𝒟 s hc hE hne + | n + 1, V, 𝒟, x, s, hc, hE, hne, hal, hbm => by + have hbits : (fun a : Fin n => bitsOf (n + 1) V s a.castSucc) + = bitsOf n (stepFragment n V) (stageSubset n V s) := + funext (fun a => bitsOf_castSucc n V s a) + by_cases hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) + · have hct := dropSubset_pairing_closed_of_closed hcl s hc + have hcL := liftSubsetClosed_pairing_closed hcl + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s)) hct + have hlift : liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s)) = s := + liftSubsetClosed_dropSubset (cutL_ne_cutR n) hcl s hc + have hF : (EdgeSubset.mk (liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s))) hcL : + EdgeSubset V) = EdgeSubset.mk s hc := + EdgeSubset.ext hlift + have hEL : (EdgeSubset.mk (liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s))) hcL : + EdgeSubset V).Eulerian := by rw [hF]; exact hE + have hneL : Nonempty (EdgeSubset.mk (liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s))) hcL : + EdgeSubset V).CanonData := by rw [hF]; exact hne + refine match_pushData_liftData_succ_closed_at n V hcl _ 𝒟 hc + hE hne (bitsOf_last n V s) ?_ hcL hEL hneL + intro t ht hct' hEt hnet + subst ht + have hbits' : (fun a : Fin n => bitsOf (n + 1) V s a.castSucc) + = bitsOf n (stepFragment n V) + (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) s)) := by + rw [hbits, stageSubset_closed n V hcl s] + rw [hbits'] + exact match_pushData_liftData_bitsOf n (stepFragment n V) _ + (fun a => x a.castSucc) _ hct' hEt hnet (hbits' ▸ hal.2) + (stage_matches_of_matches_closed n V hcl s hc x hbm) + · have hop := hcl + have hdc := dropSubset_rewire_closed_of_matches n V hcl s hc x + hbm + have hcL := liftSubsetOpen_pairing_closed (cutL_ne_cutR n) hcl + (V.dropSubset (cutL n) (cutR n) s) hdc + have hlift : liftSubsetOpen hcl + (V.dropSubset (cutL n) (cutR n) s) = s := + liftSubsetOpen_dropSubset (cutL_ne_cutR n) hcl s hc + have hF : (EdgeSubset.mk (liftSubsetOpen hcl + (V.dropSubset (cutL n) (cutR n) s)) hcL : EdgeSubset V) + = EdgeSubset.mk s hc := EdgeSubset.ext hlift + have hEL : (EdgeSubset.mk (liftSubsetOpen hcl + (V.dropSubset (cutL n) (cutR n) s)) hcL : + EdgeSubset V).Eulerian := by rw [hF]; exact hE + have hneL : Nonempty (EdgeSubset.mk + (liftSubsetOpen hcl + (V.dropSubset (cutL n) (cutR n) s)) hcL : + EdgeSubset V).CanonData := by rw [hF]; exact hne + refine match_pushData_liftData_succ_open_at n V hcl _ 𝒟 hc hE + hne ?_ hdc hcL hEL hneL (hal.1 hcl _ hcL hEL hneL + (by rw [hlift]; exact cutBalanced_of_matches_diag x hbm)) + intro t ht hct' hEt hnet + subst ht + have hbits' : (fun a : Fin n => bitsOf (n + 1) V s a.castSucc) + = bitsOf n (stepFragment n V) + (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hcl) + (V.dropSubset (cutL n) (cutR n) s)) := by + rw [hbits, stageSubset_open n V hcl s] + rw [hbits'] + exact match_pushData_liftData_bitsOf n (stepFragment n V) _ + (fun a => x a.castSucc) _ hct' hEt hnet (hbits' ▸ hal.2) + (stage_matches_of_matches n V hcl s hc x hbm) + +-- The round trip is followed through one stage of +-- the recursion, so the push, the lift and the closing cut all +-- unfold on the same subset. +open Classical in +/-- **The round trip on directions, one stage on, at a closing cut, +at one subset.** -/ +theorem isOut_pushData_liftData_succ_closed_at (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (bits : Fin (n + 1) → Bool) (𝒟 : DataFamily V) + {s : Finset V.Flag} (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc : EdgeSubset V).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc : EdgeSubset V).CanonData) + (hbit : bits (Fin.last n) + = decide (V.boundaryFlag (cutL n) ∈ s)) + (hIH : ∀ (t : Finset (stepFragment n V).Flag), + t = flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) s) → + ∀ (hct : ∀ f ∈ t, (stepFragment n V).pairing f ∈ t) + (hEt : (EdgeSubset.mk t hct).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct).CanonData) + (g : (stepFragment n V).Flag), + (∀ b, g ≠ (stepFragment n V).boundaryFlag b) → + (pushData n (stepFragment n V) + (liftData n (stepFragment n V) + (fun a => bits a.castSucc) + (stepDataUp n V (bits (Fin.last n)) 𝒟)) + t hct hEt hnet).2.isOut g + = (stepDataUp n V (bits (Fin.last n)) 𝒟 t hct hEt + hnet).2.isOut g) + (hcL : ∀ f ∈ liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s)), + V.pairing f ∈ liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s))) + (hEL : (EdgeSubset.mk (liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s))) hcL : + EdgeSubset V).Eulerian) + (hneL : Nonempty (EdgeSubset.mk (liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s))) hcL : + EdgeSubset V).CanonData) + (f : V.Flag) (hfb : ∀ a, f ≠ V.boundaryFlag a) : + (pushData (n + 1) V (liftData (n + 1) V bits 𝒟) s hc hE + hne).2.isOut f = (𝒟 s hc hE hne).2.isOut f := by + have h1 : f ≠ V.boundaryFlag (cutL n) := hfb _ + have h2 : f ≠ V.boundaryFlag (cutR n) := hfb _ + have h3 := isOut_stepDataDown_congr_at_closed n V hcl + (pushData n (stepFragment n V) + (liftData n (stepFragment n V) (fun a => bits a.castSucc) + (stepDataUp n V (bits (Fin.last n)) 𝒟))) + (stepDataUp n V (bits (Fin.last n)) 𝒟) hIH hc hE hne f hfb + rw [stepData_roundTrip_closed n V hcl (bits (Fin.last n)) 𝒟] at h3 + have h4 := isOut_unglue_glueDataClosed (cutL_ne_cutR n) hcl 𝒟 hc + hE hne hcL hEL hneL f h1 h2 + rw [← hbit] at h4 + exact h3.trans h4 + +open Classical in +/-- **The round trip on directions at one subset, with the subset's +own bits.** -/ +theorem isOut_pushData_liftData_bitsOf {k ℓ : ℕ} : ∀ (n : ℕ) + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) + (𝒟 : DataFamily V) (x : Fin n → (Fin k ⊕ Fin (2 * ℓ))) + (s : Finset V.Flag) (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData), + Aligned n V (bitsOf n V s) 𝒟 → + genBoundarySubsetMatches V s (diagOf n x) → + ∀ (f : V.Flag), (∀ a, f ≠ V.boundaryFlag a) → + (pushData n V (liftData n V (bitsOf n V s) 𝒟) s hc hE + hne).2.isOut f = (𝒟 s hc hE hne).2.isOut f + | 0, V, 𝒟, _, s, hc, hE, hne, _, _, f, _ => + isOut_pushData_liftData_zero V (bitsOf 0 V s) 𝒟 s hc hE hne f + | n + 1, V, 𝒟, x, s, hc, hE, hne, hal, hbm, f, hfb => by + have hbits : (fun a : Fin n => bitsOf (n + 1) V s a.castSucc) + = bitsOf n (stepFragment n V) (stageSubset n V s) := + funext (fun a => bitsOf_castSucc n V s a) + -- ═══════ THE CUT CLOSES ═══════ + -- The dropped subset stays pairing-closed and canonical data + -- migrate across the closed glue; the open branch follows. + by_cases hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) + · have hct := dropSubset_pairing_closed_of_closed hcl s hc + have hcL := liftSubsetClosed_pairing_closed hcl + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s)) hct + have hlift : liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s)) = s := + liftSubsetClosed_dropSubset (cutL_ne_cutR n) hcl s hc + have hF : (EdgeSubset.mk (liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s))) hcL : + EdgeSubset V) = EdgeSubset.mk s hc := + EdgeSubset.ext hlift + have hEL : (EdgeSubset.mk (liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s))) hcL : + EdgeSubset V).Eulerian := by rw [hF]; exact hE + have hneL : Nonempty (EdgeSubset.mk (liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s))) hcL : + EdgeSubset V).CanonData := by rw [hF]; exact hne + refine isOut_pushData_liftData_succ_closed_at n V hcl _ 𝒟 hc + hE hne (bitsOf_last n V s) ?_ hcL hEL hneL f hfb + intro t ht hct' hEt hnet g hgb + subst ht + have hbits' : (fun a : Fin n => bitsOf (n + 1) V s a.castSucc) + = bitsOf n (stepFragment n V) + (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) s)) := by + rw [hbits, stageSubset_closed n V hcl s] + rw [hbits'] + exact isOut_pushData_liftData_bitsOf n (stepFragment n V) _ + (fun a => x a.castSucc) _ hct' hEt hnet (hbits' ▸ hal.2) + (stage_matches_of_matches_closed n V hcl s hc x hbm) g hgb + · have hdc := dropSubset_rewire_closed_of_matches n V hcl s hc x + hbm + have hcL := liftSubsetOpen_pairing_closed (cutL_ne_cutR n) hcl + (V.dropSubset (cutL n) (cutR n) s) hdc + have hlift : liftSubsetOpen hcl + (V.dropSubset (cutL n) (cutR n) s) = s := + liftSubsetOpen_dropSubset (cutL_ne_cutR n) hcl s hc + have hF : (EdgeSubset.mk (liftSubsetOpen hcl + (V.dropSubset (cutL n) (cutR n) s)) hcL : EdgeSubset V) + = EdgeSubset.mk s hc := EdgeSubset.ext hlift + have hEL : (EdgeSubset.mk (liftSubsetOpen hcl + (V.dropSubset (cutL n) (cutR n) s)) hcL : + EdgeSubset V).Eulerian := by rw [hF]; exact hE + have hneL : Nonempty (EdgeSubset.mk + (liftSubsetOpen hcl + (V.dropSubset (cutL n) (cutR n) s)) hcL : + EdgeSubset V).CanonData := by rw [hF]; exact hne + refine isOut_pushData_liftData_succ_open_at n V hcl _ 𝒟 hc hE + hne ?_ hdc hcL hEL hneL (hal.1 hcl _ hcL hEL hneL + (by rw [hlift]; exact cutBalanced_of_matches_diag x hbm)) + f hfb + intro t ht hct' hEt hnet g hgb + subst ht + have hbits' : (fun a : Fin n => bitsOf (n + 1) V s a.castSucc) + = bitsOf n (stepFragment n V) + (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hcl) + (V.dropSubset (cutL n) (cutR n) s)) := by + rw [hbits, stageSubset_open n V hcl s] + rw [hbits'] + exact isOut_pushData_liftData_bitsOf n (stepFragment n V) _ + (fun a => x a.castSucc) _ hct' hEt hnet (hbits' ▸ hal.2) + (stage_matches_of_matches n V hcl s hc x hbm) g hgb + +open Classical in +/-- **A balanced subset's drop is balanced**, at a closing cut. -/ +theorem cutBalanced_stageSubset_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) (s : Finset V.Flag) + (hc : ∀ f ∈ s, V.pairing f ∈ s) (hbal : CutBalanced V s) : + CutBalanced (stepFragment n V) (stageSubset n V s) := by + intro b + have hlift : liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s)) = s := + liftSubsetClosed_dropSubset (cutL_ne_cutR n) hcl s hc + have key := fun bl => mem_stage_boundaryFlag_iff_closed n V hcl + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s)) bl + have hss : stageSubset n V s = flagsOfEq + (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) s) := by + unfold stageSubset + exact dite_eq_left hcl + rw [hss] + refine (key (intL n b)).trans (Iff.trans ?_ (key (intR n b)).symm) + rw [hlift, interfaceStepEquiv_symm_intL n b, + interfaceStepEquiv_symm_intR n b] + exact hbal b.castSucc + +open Classical in +/-- **A base subset's whole colour sum is the composition's own +term.** Summed over the interface colourings, a guarded balanced +subset's summand is the composition's term at the subset's image, +times the free circles the subset's own closing cuts contribute. +Nothing is asked of the family: the identification is stage by stage, +an open cut summing its colour away and a closing one splitting into +the free circle's two sectors. -/ +theorem edgeTermAt_pushData_colourSum {k ℓ : ℕ} + (h : MixedFunctional k ℓ) : + ∀ (n : ℕ) (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) + (𝒢 : DataFamily (glueInterface 0 n 0 V)) (s : Finset V.Flag), + (∀ f ∈ s, V.pairing f ∈ s) → CutBalanced V s → ∀ (C : ℕ), + (∑ x : Fin n → (Fin k ⊕ Fin (2 * ℓ)), + edgeTermAt h (pushData n V 𝒢) (diagOf n x) s + (C + carried n V s)) + = cutFactor k ℓ n V s + * edgeTermAt h 𝒢 emptyState (imageOf n V s) C + | 0, V, 𝒢, s, _, _, C => by + rw [Fintype.sum_unique] + change edgeTermAt h (relabelDataDown baseIso 𝒢) _ s C + = (1 : ℂ) * _ + rw [one_mul] + refine Eq.trans ?_ + (edgeTermAt_relabel baseIso h 𝒢 emptyState s C).symm + exact congrArg + (fun st => edgeTermAt h (relabelDataDown baseIso 𝒢) st s C) + (funext fun a => isEmptyElim a) + | n + 1, V, 𝒢, s, hc, hbal, C => by + change (∑ x : Fin (n + 1) → (Fin k ⊕ Fin (2 * ℓ)), + edgeTermAt h (stepDataDown n V + (pushData n (stepFragment n V) 𝒢)) (diagOf (n + 1) x) s + (C + carried (n + 1) V s)) = _ + rw [sum_colours_snoc h n V (pushData n (stepFragment n V) 𝒢) s + (C + carried (n + 1) V s)] + -- ═══════ THE CUT CLOSES ═══════ + -- The dropped subset stays pairing-closed and the stage's own + -- factor is the closed one; the open branch follows below. + by_cases hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) + · have hct : ∀ f ∈ V.dropSubset (cutL n) (cutR n) s, + (V.gluePairClosed (cutL n) (cutR n) hcl).pairing f + ∈ V.dropSubset (cutL n) (cutR n) s := + dropSubset_pairing_closed_of_closed hcl s hc + have hcs := flagsOfEq_pairing_mem + (gluePair_eq_closed n V hcl) _ hct + have hb2 := cutBalanced_stageSubset_closed n V hcl s hc hbal + rw [stageSubset_closed n V hcl s] at hb2 + have hIH := edgeTermAt_pushData_colourSum h n + (stepFragment n V) 𝒢 + (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) s)) hcs hb2 C + obtain ⟨t, b, hs⟩ : ∃ (t : Finset (SurvivingFlag V (cutL n) + (cutR n))) (b : Bool), liftSubsetClosed t b = s := + ⟨_, _, liftSubsetClosed_dropSubset (cutL_ne_cutR n) hcl s + hc⟩ + subst hs + rw [dropSubset_liftSubsetClosed t b] at hIH + have hinner : ∀ y : Fin n → (Fin k ⊕ Fin (2 * ℓ)), + (∑ c : Fin k ⊕ Fin (2 * ℓ), + edgeTermAt h (stepDataDown n V + (pushData n (stepFragment n V) 𝒢)) + (GenBoundaryState.extendPair (cutL n) (cutR n) + (stageState n (diagOf n y)) c c) + (liftSubsetClosed t b) + (C + ((if b = true then 1 else 0) + + carried n (stepFragment n V) (flagsOfEq (V.gluePairClosed + (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) t)))) + = (if b = true then (-(2 * ℓ : ℕ) : ℂ) else (k : ℂ)) + * edgeTermAt h (pushData n (stepFragment n V) 𝒢) + (diagOf n y) (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) + hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) t) + (C + carried n (stepFragment n V) (flagsOfEq (V.gluePairClosed + (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) t)) := by + intro y + cases b with + | false => + rw [show C + ((if (false : Bool) = true then 1 else 0) + + carried n (stepFragment n V) (flagsOfEq (V.gluePairClosed + (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) t)) + = C + carried n (stepFragment n V) (flagsOfEq + (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) t) + from by simp, ite_eq_right (by simp : ¬ ((false : Bool) + = true))] + exact edgeTermAt_stepClosed_false_all n V h + (pushData n (stepFragment n V) 𝒢) hcl t (diagOf n y) + _ + | true => + rw [show C + ((if (true : Bool) = true then 1 else 0) + + carried n (stepFragment n V) (flagsOfEq (V.gluePairClosed + (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) t)) + = (C + carried n (stepFragment n V) (flagsOfEq + (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) t)) + 1 + from by simp; omega, ite_eq_left rfl] + exact edgeTermAt_stepClosed_true_all n V h + (pushData n (stepFragment n V) 𝒢) hcl t (diagOf n y) + _ + rw [carried_liftClosed n V hcl t b, + cutFactor_liftClosed k ℓ n V hcl t b, + imageOf_succ_closed n V hcl (liftSubsetClosed t b), + dropSubset_liftSubsetClosed t b] + refine Eq.trans (Finset.sum_congr rfl + (fun y (_ : y ∈ Finset.univ) => hinner y)) ?_ + rw [← Finset.mul_sum, mul_assoc] + exact congrArg (fun z => (if b = true then + (-(2 * ℓ : ℕ) : ℂ) else (k : ℂ)) * z) hIH + · have hct : ∀ f ∈ V.dropSubset (cutL n) (cutR n) s, + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hcl).pairing f + ∈ V.dropSubset (cutL n) (cutR n) s := + dropSubset_rewire_closed (hopen := hcl) s + (agreeingSubset_of_cutBalanced hc hbal) + have hcs := flagsOfEq_pairing_mem + (gluePair_eq_open n V hcl) _ hct + have hb2 := cutBalanced_stageSubset n V hcl s hc hbal + rw [stageSubset_open n V hcl s] at hb2 + have hIH := edgeTermAt_pushData_colourSum h n + (stepFragment n V) 𝒢 + (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hcl) + (V.dropSubset (cutL n) (cutR n) s)) hcs hb2 C + obtain ⟨t, hs⟩ : ∃ t : Finset (SurvivingFlag V (cutL n) + (cutR n)), liftSubsetOpen hcl t = s := + ⟨_, liftSubsetOpen_dropSubset (cutL_ne_cutR n) hcl s hc⟩ + subst hs + rw [dropSubset_liftSubsetOpen hcl t] at hIH + have hinner : ∀ y : Fin n → (Fin k ⊕ Fin (2 * ℓ)), + (∑ c : Fin k ⊕ Fin (2 * ℓ), + edgeTermAt h (stepDataDown n V + (pushData n (stepFragment n V) 𝒢)) + (GenBoundaryState.extendPair (cutL n) (cutR n) + (stageState n (diagOf n y)) c c) + (liftSubsetOpen hcl t) + (C + carried n (stepFragment n V) (flagsOfEq (V.gluePairOpen + (cutL n) (cutR n) (cutL_ne_cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hcl) t))) + = edgeTermAt h (pushData n (stepFragment n V) 𝒢) + (diagOf n y) (flagsOfEq (V.gluePairOpen (cutL n) (cutR n) + (cutL_ne_cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hcl) t) + (C + carried n (stepFragment n V) (flagsOfEq (V.gluePairOpen + (cutL n) (cutR n) (cutL_ne_cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hcl) t)) := + fun y => edgeTermAt_stepOpen_all n V h + (pushData n (stepFragment n V) 𝒢) hcl t (diagOf n y) _ + rw [carried_liftOpen n V hcl t, + cutFactor_liftOpen k ℓ n V hcl t, + imageOf_succ_open n V hcl + (liftSubsetOpen hcl t), + dropSubset_liftSubsetOpen hcl t] + refine Eq.trans (Finset.sum_congr rfl + (fun y (_ : y ∈ Finset.univ) => hinner y)) hIH + +open Classical in +/-- **The base sum with the subset's own bits** — the statement the +closing cut needs. The composition's own sum is family-free, so the +left side may be read at any fixed bits; the right side reads each +base subset with the bits that subset itself determines, which is +what the round trip asks for. -/ +def BaseSumBitsOf {k ℓ : ℕ} (h : MixedFunctional k ℓ) (n : ℕ) + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) (𝒟 : DataFamily V) + (C : ℕ) : Prop := + ((k : ℂ) - 2 * ℓ) ^ closedCuts n V + * ∑ u : Finset (glueInterface 0 n 0 V).Flag, + circuitWeight (liftData n V (fun _ => false) 𝒟) u + * edgeTermAt h (liftData n V (fun _ => false) 𝒟) + emptyState u C + = ∑ s : Finset V.Flag, + ∑ x : Fin n → (Fin k ⊕ Fin (2 * ℓ)), + circuitWeight (liftData n V (bitsOf n V s) 𝒟) + (imageOf n V s) + * edgeTermAt h + (pushData n V (liftData n V (bitsOf n V s) 𝒟)) + (diagOf n x) s (C + carried n V s) + +open Classical in +/-- **THE SUMMAND DOES NOT READ THE LIFT'S BITS.** Summed over the +interface colourings, a base subset's weighted summand is the free +circles its own closing cuts contribute, times the composition's own +weighted term at its image — and that product is family-free at the +closed top. So which lift computed it makes no difference. -/ +theorem summandSum_bits_indep {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (n : ℕ) (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) + (𝒟 : DataFamily V) (s : Finset V.Flag) (C : ℕ) + (bits bits' : Fin n → Bool) : + (∑ x : Fin n → (Fin k ⊕ Fin (2 * ℓ)), + circuitWeight (liftData n V bits 𝒟) (imageOf n V s) + * edgeTermAt h (pushData n V (liftData n V bits 𝒟)) + (diagOf n x) s (C + carried n V s)) + = ∑ x : Fin n → (Fin k ⊕ Fin (2 * ℓ)), + circuitWeight (liftData n V bits' 𝒟) (imageOf n V s) + * edgeTermAt h (pushData n V (liftData n V bits' 𝒟)) + (diagOf n x) s (C + carried n V s) := by + by_cases hc : ∀ f ∈ s, V.pairing f ∈ s + · by_cases hbal : CutBalanced V s + · rw [← Finset.mul_sum, ← Finset.mul_sum, + edgeTermAt_pushData_colourSum h n V (liftData n V bits 𝒟) s + hc hbal C, + edgeTermAt_pushData_colourSum h n V (liftData n V bits' 𝒟) s + hc hbal C] + calc circuitWeight (liftData n V bits 𝒟) (imageOf n V s) + * (cutFactor k ℓ n V s + * edgeTermAt h (liftData n V bits 𝒟) emptyState + (imageOf n V s) C) + = cutFactor k ℓ n V s + * (circuitWeight (liftData n V bits 𝒟) + (imageOf n V s) + * edgeTermAt h (liftData n V bits 𝒟) emptyState + (imageOf n V s) C) := by ring + _ = cutFactor k ℓ n V s + * (circuitWeight (liftData n V bits' 𝒟) + (imageOf n V s) + * edgeTermAt h (liftData n V bits' 𝒟) emptyState + (imageOf n V s) C) := + congrArg (fun z => cutFactor k ℓ n V s * z) + (circuitWeight_mul_edgeTermAt_indep h emptyState + (imageOf n V s) C (liftData n V bits 𝒟) + (liftData n V bits' 𝒟)) + _ = circuitWeight (liftData n V bits' 𝒟) (imageOf n V s) + * (cutFactor k ℓ n V s + * edgeTermAt h (liftData n V bits' 𝒟) emptyState + (imageOf n V s) C) := by ring + · rw [Finset.sum_eq_zero (fun x _ => ?_), + Finset.sum_eq_zero (fun x _ => ?_)] + · rw [edgeTermAt_eq_zero_of_not_matches h _ _ + (fun hx => hbal (cutBalanced_of_matches_diag x hx)) _, + mul_zero] + · rw [edgeTermAt_eq_zero_of_not_matches h _ _ + (fun hx => hbal (cutBalanced_of_matches_diag x hx)) _, + mul_zero] + · rw [Finset.sum_eq_zero (fun x _ => ?_), + Finset.sum_eq_zero (fun x _ => ?_)] + · rw [edgeTermAt_eq_zero_of_not_closed h _ _ hc _, mul_zero] + · rw [edgeTermAt_eq_zero_of_not_closed h _ _ hc _, mul_zero] + +open Classical in +/-- **THE BASE SUM, WITH EACH SUBSET'S OWN BITS.** The composition's +own total is the sum over the base's subsets of the summand each +subset's own bits compute — because the summand does not read the +bits at all. -/ +theorem baseSumBitsOf_all {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (n : ℕ) (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) + (𝒟 : DataFamily V) (C : ℕ) : + BaseSumBitsOf h n V 𝒟 C := by + unfold BaseSumBitsOf + refine Eq.trans (edgeTermAt_glueInterface h n V + (liftData n V (fun _ => false) 𝒟) C + (circuitWeight (liftData n V (fun _ => false) 𝒟))) ?_ + exact Finset.sum_congr rfl (fun s _ => + summandSum_bits_indep h n V 𝒟 s C (fun _ => false) + (bitsOf n V s)) + +open Classical in +/-- **The pushed lift computes the family's own term, with the +subset's own bits** — at a closing cut as much as an open one. -/ +theorem edgeTermAt_pushData_liftData_bitsOf {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (n : ℕ) + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) (𝒟 : DataFamily V) + (x : Fin n → (Fin k ⊕ Fin (2 * ℓ))) {s : Finset V.Flag} + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hbnd : genBoundarySubsetMatches V s (diagOf n x)) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) + (hal : Aligned n V (bitsOf n V s) 𝒟) (C : ℕ) : + edgeTermAt h (pushData n V (liftData n V (bitsOf n V s) 𝒟)) + (diagOf n x) s C + = edgeTermAt h 𝒟 (diagOf n x) s C := by + rw [edgeTermAt_eq_signed_edgeSum_internal h + (pushData n V (liftData n V (bitsOf n V s) 𝒟)) (diagOf n x) + hc hbnd hE hne C (𝒟 s hc hE hne).2 + (match_pushData_liftData_bitsOf n V 𝒟 x s hc hE hne hal hbnd) + (fun f hf => isOut_pushData_liftData_bitsOf n V 𝒟 x s hc hE + hne hal hbnd f + (ne_boundaryFlag_of_mem_internalFlags _ hf)), + edgeTermAt_pos h 𝒟 (diagOf n x) hc hbnd hE hne C] + +open Classical in +/-- **The pushed lift computes the family's own term, at every +subset, with the subset's own bits.** Off the matching subsets both +terms vanish, and elsewhere the round trip at the subset's own bits +returns the family — at a closing cut as much as an open one. -/ +theorem edgeTermAt_pushData_liftData_all_bitsOf {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (n : ℕ) + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) + (𝒟 : DataFamily V) + (hal : ∀ s : Finset V.Flag, Aligned n V (bitsOf n V s) 𝒟) + (x : Fin n → (Fin k ⊕ Fin (2 * ℓ))) (s : Finset V.Flag) + (C : ℕ) : + edgeTermAt h (pushData n V (liftData n V (bitsOf n V s) 𝒟)) + (diagOf n x) s C + = edgeTermAt h 𝒟 (diagOf n x) s C := by + by_cases hc : ∀ f ∈ s, V.pairing f ∈ s + · by_cases hbnd : genBoundarySubsetMatches V s (diagOf n x) + · by_cases hE : (EdgeSubset.mk s hc).Eulerian + · by_cases hne : Nonempty (EdgeSubset.mk s hc).CanonData + · exact edgeTermAt_pushData_liftData_bitsOf h n V 𝒟 x hc + hbnd hE hne (hal s) C + · rw [edgeTermAt_eq_zero_of_not_canon h _ _ hc hne C, + edgeTermAt_eq_zero_of_not_canon h 𝒟 _ hc hne C] + · rw [edgeTermAt_eq_zero_of_not_eulerian h _ _ hc hE C, + edgeTermAt_eq_zero_of_not_eulerian h 𝒟 _ hc hE C] + · rw [edgeTermAt_eq_zero_of_not_matches h _ _ hbnd C, + edgeTermAt_eq_zero_of_not_matches h 𝒟 _ hbnd C] + · rw [edgeTermAt_eq_zero_of_not_closed h _ _ hc C, + edgeTermAt_eq_zero_of_not_closed h 𝒟 _ hc C] + +open Classical in +/-- **The stage subset is the ledger's step.** -/ +theorem stageSubset_stepData (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (D : StageData (n + 1) V) : + stageSubset n V D.sub.flags = (stepData n V D).sub.flags := by + by_cases hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) + · rw [stageSubset_closed n V hcl, stepData_sub_flags_closed n V D + hcl] + · rw [stageSubset_open n V hcl, stepData_sub_flags_open n V D hcl] + +open Classical in +/-- **The bits the ledger's subset determines, one stage on.** -/ +theorem bitsOf_stepData (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (D : StageData (n + 1) V) : + (fun a : Fin n => bitsOf (n + 1) V D.sub.flags a.castSucc) + = bitsOf n (stepFragment n V) (stepData n V D).sub.flags := by + refine funext (fun a => ?_) + rw [bitsOf_castSucc n V D.sub.flags a, stageSubset_stepData n V D] + +open Classical in +/-- **The lift is the ledger, at every interface.** Read with the +bits the ledger's own subset determines, the lifted family's system +at the glued subset is the ledger's glued system, up to its partner +map — at a closing cut as much as an open one, because the bit the +subset determines is the bit the ledger's step uses. -/ +theorem match_liftData_glueData_bitsOf : ∀ (n : ℕ) + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) + (𝒟 : DataFamily V) (D : StageData n V), + Aligned n V (bitsOf n V D.sub.flags) 𝒟 → + (∀ hc hE hne, (𝒟 D.sub.flags hc hE hne).1.MatchEq D.rel) → + CutBalanced V D.sub.flags → + ∀ (hc : ∀ f ∈ (glueData n V D).sub.flags, + (glueInterface 0 n 0 V).pairing f ∈ (glueData n V D).sub.flags) + (hE : (EdgeSubset.mk (glueData n V D).sub.flags hc).Eulerian) + (hne : Nonempty + (EdgeSubset.mk (glueData n V D).sub.flags hc).CanonData), + (liftData n V (bitsOf n V D.sub.flags) 𝒟 + (glueData n V D).sub.flags hc hE hne).1.MatchEq + (glueData n V D).rel + | 0, V, 𝒟, D, _, hcompat, _, hc, hE, hne => by + intro f hf + exact hcompat _ _ _ f + ((relabelUp_internalFlags endEquiv D.sub) ▸ hf) + | n + 1, V, 𝒟, D, hal, hcompat, hbal, hc, hE, hne => by + have hal' : (V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n) → ∀ (u : Finset V.Flag) + (hcu : ∀ f ∈ u, V.pairing f ∈ u) + (hEu : (EdgeSubset.mk u hcu).Eulerian) + (hneu : Nonempty (EdgeSubset.mk u hcu).CanonData), + CutBalanced V u → + (𝒟 u hcu hEu hneu).2.isOut + (V.pairing (V.boundaryFlag (cutR n))) + = !(𝒟 u hcu hEu hneu).2.isOut + (V.pairing (V.boundaryFlag (cutL n)))) + ∧ Aligned n (stepFragment n V) + (fun a => bitsOf (n + 1) V D.sub.flags a.castSucc) + (stepDataUp n V + (bitsOf (n + 1) V D.sub.flags (Fin.last n)) 𝒟) := hal + have hbits := bitsOf_stepData n V D + have hlast : bitsOf (n + 1) V D.sub.flags (Fin.last n) + = stepBit n V D := bitsOf_last n V D.sub.flags + change (liftData n (stepFragment n V) + (fun a => bitsOf (n + 1) V D.sub.flags a.castSucc) + (stepDataUp n V + (bitsOf (n + 1) V D.sub.flags (Fin.last n)) 𝒟) + (glueData n (stepFragment n V) (stepData n V D)).sub.flags + hc hE hne).1.MatchEq + (glueData n (stepFragment n V) (stepData n V D)).rel + rw [hbits, hlast] + rw [hbits, hlast] at hal' + by_cases hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) + · exact match_liftData_glueData_bitsOf n (stepFragment n V) + (stepDataUp n V (stepBit n V D) 𝒟) (stepData n V D) hal'.2 + (fun hct hEt hnet => match_stepDataUp_stepData_closed n V + hcl 𝒟 D hcompat hct hEt hnet) + (cutBalanced_stepData_closed n V hcl D hbal) hc hE hne + · exact match_liftData_glueData_bitsOf n (stepFragment n V) + (stepDataUp n V (stepBit n V D) 𝒟) (stepData n V D) hal'.2 + (fun hct hEt hnet => match_stepDataUp_stepData_open n V hcl + (stepBit n V D) 𝒟 D hcompat + (fun hcL hEL hneL => hal'.1 hcl _ hcL hEL hneL + (by + change CutBalanced V (liftSubsetOpen + hcl (V.dropSubset (cutL n) (cutR n) D.sub.flags)) + rw [liftSubsetOpen_dropSubset (cutL_ne_cutR n) hcl + D.sub.flags D.sub.pairing_mem] + exact hbal)) hct hEt hnet) + (cutBalanced_stepData n V hcl D hbal) hc hE hne + +open Classical in +/-- **The composition's weight is the ledger's sign, at every +interface.** Read with the bits the ledger's own subset determines, +the weight the composition's sum carries at the image of a base +subset is exactly the circuit sign the ledger records for it. -/ +theorem circuitWeight_liftData_imageOf_bitsOf (n : ℕ) + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) + (𝒟 : DataFamily V) (D : StageData n V) + (hal : Aligned n V (bitsOf n V D.sub.flags) 𝒟) + (hcompat : ∀ hc hE hne, + (𝒟 D.sub.flags hc hE hne).1.MatchEq D.rel) + (hbal : CutBalanced V D.sub.flags) + (hE : (EdgeSubset.mk (glueData n V D).sub.flags + (glueData n V D).sub.pairing_mem).Eulerian) + (hne : Nonempty (EdgeSubset.mk (glueData n V D).sub.flags + (glueData n V D).sub.pairing_mem).CanonData) : + circuitWeight (liftData n V (bitsOf n V D.sub.flags) 𝒟) + (imageOf n V D.sub.flags) + = (-1 : ℂ) ^ (glueData n V D).rel.openCircuitCount := by + rw [imageOf_eq_glueData_sub n V D, + circuitWeight_pos (liftData n V (bitsOf n V D.sub.flags) 𝒟) + (glueData n V D).sub.pairing_mem hE hne] + exact congrArg (fun m => (-1 : ℂ) ^ m) + (openCircuitCount_matchEq (RelTransitionSystem.MatchEq.symm + (match_liftData_glueData_bitsOf n V 𝒟 D hal hcompat hbal _ + hE hne))) + +open Classical in +/-- **A term of the fragment tensor needs its own labels.** -/ +theorem tensorTermAt_eq_zero_of_not_matches {α : Type} + [LinearOrder α] [Fintype α] (V : Fragment α) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (s : Finset V.Flag) + (x : GenBoundaryState k ℓ α) + (hx : ¬ genBoundarySubsetMatches V s x) : + tensorTermAt V h s x = 0 := by + unfold tensorTermAt + split_ifs with hc hE hne + · exact tFull_eq_zero_of_not_matches (EdgeSubset.mk s hc) h _ _ x + hx + · rfl + · rfl + · rfl + +open Classical in +/-- **An unclosed subset carries no tensor term.** -/ +theorem tensorTermAt_eq_zero_of_not_closed {α : Type} [LinearOrder α] + [Fintype α] (V : Fragment α) {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (s : Finset V.Flag) (x : GenBoundaryState k ℓ α) + (hc : ¬ ∀ f ∈ s, V.pairing f ∈ s) : tensorTermAt V h s x = 0 := by + unfold tensorTermAt + rw [dite_eq_right hc] + +open Classical in +/-- **A non-Eulerian subset carries no tensor term.** -/ +theorem tensorTermAt_eq_zero_of_not_eulerian {α : Type} + [LinearOrder α] [Fintype α] (V : Fragment α) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) {s : Finset V.Flag} + (hc : ∀ f ∈ s, V.pairing f ∈ s) (x : GenBoundaryState k ℓ α) + (hE : ¬ (EdgeSubset.mk s hc).Eulerian) : + tensorTermAt V h s x = 0 := by + unfold tensorTermAt + rw [dite_eq_left hc, dite_eq_right hE] + +open Classical in +/-- **A subset with no canonical data carries no tensor term.** -/ +theorem tensorTermAt_eq_zero_of_not_canon {α : Type} [LinearOrder α] + [Fintype α] (V : Fragment α) {k ℓ : ℕ} (h : MixedFunctional k ℓ) + {s : Finset V.Flag} (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (x : GenBoundaryState k ℓ α) + (hne : ¬ Nonempty (EdgeSubset.mk s hc).CanonData) : + tensorTermAt V h s x = 0 := by + unfold tensorTermAt + rw [dite_eq_left hc, dite_eq_left hE, dite_eq_right hne] + +open Classical in +/-- **Tensors of subsets using different labels are orthogonal.** -/ +theorem pairTerm_eq_zero_of_used_ne {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (t : ℕ) (F G : Fragment (Fin t)) + (s₁ : Finset F.Flag) (s₂ : Finset G.Flag) (i : Fin t) + (h₁ : F.boundaryFlag i ∈ s₁) (h₂ : G.boundaryFlag i ∉ s₂) : + (∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * tensorTermAt F h s₁ x + * tensorTermAt G h s₂ y) = 0 := by + refine Finset.sum_eq_zero (fun x _ => Finset.sum_eq_zero + (fun y _ => ?_)) + by_cases hx : genBoundarySubsetMatches F s₁ x + · by_cases hy : genBoundarySubsetMatches G s₂ y + · obtain ⟨c, hcx⟩ := (hx i).mp h₁ + obtain ⟨a, hay⟩ := exists_left_of_not_right + (fun hr => h₂ ((hy i).mpr hr)) + rw [superForm_eq_zero_of_right_left x y i hcx hay] + ring + · rw [tensorTermAt_eq_zero_of_not_matches G h s₂ y hy] + ring + · rw [tensorTermAt_eq_zero_of_not_matches F h s₁ x hx] + ring + +open Classical in +/-- **The join is Eulerian when its halves are.** -/ +theorem eulerian_closeJoin {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (hE₁ : (EdgeSubset.mk s₁ hc₁).Eulerian) + (hE₂ : (EdgeSubset.mk s₂ hc₂).Eulerian) : + (EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂)).Eulerian := by + refine (eulerian_iff_parts (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂) + (by + rw [show leftPart (closeJoin s₁ s₂) = s₁ from + leftPart_joinParts s₁ s₂] + exact hc₁) + (by + rw [show rightPart (closeJoin s₁ s₂) = s₂ from + rightPart_joinParts s₁ s₂] + exact hc₂)).mpr ⟨?_, ?_⟩ + · have h1 : (EdgeSubset.mk (leftPart (closeJoin s₁ s₂)) + (by + rw [show leftPart (closeJoin s₁ s₂) = s₁ from + leftPart_joinParts s₁ s₂] + exact hc₁) : + EdgeSubset (F.relabel (finCongr (by omega : t = 0 + t)))) + = (EdgeSubset.mk s₁ hc₁ : + EdgeSubset (F.relabel (finCongr (by omega : t = 0 + t)))) := + EdgeSubset.ext (leftPart_joinParts s₁ s₂) + rw [h1] + exact (relabelUp_eulerian (finCongr (by omega : t = 0 + t)) + (EdgeSubset.mk s₁ hc₁ : EdgeSubset F)).mpr hE₁ + · have h2 : (EdgeSubset.mk (rightPart (closeJoin s₁ s₂)) + (by + rw [show rightPart (closeJoin s₁ s₂) = s₂ from + rightPart_joinParts s₁ s₂] + exact hc₂) : + EdgeSubset (G.relabel (finCongr (by omega : t = t + 0)))) + = (EdgeSubset.mk s₂ hc₂ : + EdgeSubset (G.relabel (finCongr (by omega : t = t + 0)))) := + EdgeSubset.ext (rightPart_joinParts s₁ s₂) + rw [h2] + exact (relabelUp_eulerian (finCongr (by omega : t = t + 0)) + (EdgeSubset.mk s₂ hc₂ : EdgeSubset G)).mpr hE₂ + +open Classical in +/-- **The join carries canonical data when its halves do.** -/ +theorem canonData_closeJoin {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (hused : ∀ i : Fin t, + F.boundaryFlag i ∈ s₁ ↔ G.boundaryFlag i ∈ s₂) + (hn₁ : Nonempty (EdgeSubset.mk s₁ hc₁).CanonData) + (hn₂ : Nonempty (EdgeSubset.mk s₂ hc₂).CanonData) : + Nonempty (EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂)).CanonData := + (nonempty_canonData_iff_system _).mpr + ⟨(pairStage hc₁ hc₂ hused (Classical.choice hn₁).1 + (Classical.choice hn₂).1).rel⟩ + +open Classical in +/-- **An unclosed half leaves the join unclosed.** -/ +theorem not_closeJoin_closed_left {t : ℕ} {F G : Fragment (Fin t)} + (s₁ : Finset F.Flag) (s₂ : Finset G.Flag) + (hc₁ : ¬ ∀ f ∈ s₁, F.pairing f ∈ s₁) : + ¬ ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂ := by + intro hc + refine hc₁ (fun f hf => ?_) + have h := hc (Sum.inl f) (inl_mem_joinParts.mpr hf) + exact inl_mem_joinParts.mp h + +open Classical in +/-- **An unclosed half leaves the join unclosed**, on the right. -/ +theorem not_closeJoin_closed_right {t : ℕ} {F G : Fragment (Fin t)} + (s₁ : Finset F.Flag) (s₂ : Finset G.Flag) + (hc₂ : ¬ ∀ f ∈ s₂, G.pairing f ∈ s₂) : + ¬ ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂ := by + intro hc + refine hc₂ (fun f hf => ?_) + have h := hc (Sum.inr f) (inr_mem_joinParts.mpr hf) + exact inr_mem_joinParts.mp h + +open Classical in +/-- **A non-Eulerian half leaves the join non-Eulerian.** -/ +theorem not_eulerian_closeJoin {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (hbad : ¬ ((EdgeSubset.mk s₁ hc₁).Eulerian + ∧ (EdgeSubset.mk s₂ hc₂).Eulerian)) : + ¬ (EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂)).Eulerian := by + intro hE + obtain ⟨hL, hR⟩ := (eulerian_iff_parts (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂) + (by + rw [show leftPart (closeJoin s₁ s₂) = s₁ from + leftPart_joinParts s₁ s₂] + exact hc₁) + (by + rw [show rightPart (closeJoin s₁ s₂) = s₂ from + rightPart_joinParts s₁ s₂] + exact hc₂)).mp hE + refine hbad ⟨?_, ?_⟩ + · refine (relabelUp_eulerian (finCongr (by omega : t = 0 + t)) + (EdgeSubset.mk s₁ hc₁ : EdgeSubset F)).mp ?_ + have hEq : (EdgeSubset.mk (leftPart (closeJoin s₁ s₂)) + (by + rw [show leftPart (closeJoin s₁ s₂) = s₁ from + leftPart_joinParts s₁ s₂] + exact hc₁) : + EdgeSubset (F.relabel (finCongr (by omega : t = 0 + t)))) + = EdgeSubset.relabelUp (finCongr (by omega : t = 0 + t)) + (EdgeSubset.mk s₁ hc₁ : EdgeSubset F) := + EdgeSubset.ext (leftPart_joinParts s₁ s₂) + exact hEq ▸ hL + · refine (relabelUp_eulerian (finCongr (by omega : t = t + 0)) + (EdgeSubset.mk s₂ hc₂ : EdgeSubset G)).mp ?_ + have hEq : (EdgeSubset.mk (rightPart (closeJoin s₁ s₂)) + (by + rw [show rightPart (closeJoin s₁ s₂) = s₂ from + rightPart_joinParts s₁ s₂] + exact hc₂) : + EdgeSubset (G.relabel (finCongr (by omega : t = t + 0)))) + = EdgeSubset.relabelUp (finCongr (by omega : t = t + 0)) + (EdgeSubset.mk s₂ hc₂ : EdgeSubset G) := + EdgeSubset.ext (rightPart_joinParts s₁ s₂) + exact hEq ▸ hR + +open Classical in +/-- **The base's summand vanishes off a matching subset.** -/ +theorem base_term_eq_zero_of_not_matches {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (t : ℕ) (F G : Fragment (Fin t)) + (bits : Fin t → Bool) + (s : Finset (closeBase F G).Flag) (C : ℕ) + (hbad : ∀ x : GenBoundaryState k ℓ (Fin t), + ¬ genBoundarySubsetMatches (closeBase F G) s (diagOf t x)) : + (∑ x : GenBoundaryState k ℓ (Fin t), + circuitWeight (liftData t (closeBase F G) bits + (pairFamily h t F G)) + (imageOf t (closeBase F G) s) + * edgeTermAt h (pairFamily h t F G) (diagOf t x) s C) + = 0 := + Finset.sum_eq_zero (fun x _ => by + rw [edgeTermAt_eq_zero_of_not_matches h + (pairFamily h t F G) (diagOf t x) (hbad x) C] + ring) + +open Classical in +/-- **A mismatched join carries no diagonal state.** -/ +theorem not_matches_of_used_ne {k ℓ : ℕ} {t : ℕ} + {F G : Fragment (Fin t)} {s₁ : Finset F.Flag} + {s₂ : Finset G.Flag} (i : Fin t) + (hne : ¬ (F.boundaryFlag i ∈ s₁ ↔ G.boundaryFlag i ∈ s₂)) + (x : GenBoundaryState k ℓ (Fin t)) : + ¬ genBoundarySubsetMatches (closeBase F G) (closeJoin s₁ s₂) + (diagOf t x) := by + intro hm + obtain ⟨h₁, h₂⟩ := (matches_closeJoin_iff s₁ s₂ x).mp hm + exact hne ((h₁ i).trans (h₂ i).symm) + +open Classical in +/-- **A tensor term needs a closed subset.** -/ +theorem pairTerm_eq_zero_of_not_closed_left {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (t : ℕ) (F G : Fragment (Fin t)) + (s₁ : Finset F.Flag) (s₂ : Finset G.Flag) + (hc₁ : ¬ ∀ f ∈ s₁, F.pairing f ∈ s₁) : + (∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * tensorTermAt F h s₁ x + * tensorTermAt G h s₂ y) = 0 := + Finset.sum_eq_zero (fun x _ => Finset.sum_eq_zero (fun y _ => by + rw [tensorTermAt_eq_zero_of_not_closed F h s₁ x hc₁] + ring)) + +open Classical in +/-- **A tensor term needs a closed subset**, on the right. -/ +theorem pairTerm_eq_zero_of_not_closed_right {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (t : ℕ) (F G : Fragment (Fin t)) + (s₁ : Finset F.Flag) (s₂ : Finset G.Flag) + (hc₂ : ¬ ∀ f ∈ s₂, G.pairing f ∈ s₂) : + (∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * tensorTermAt F h s₁ x + * tensorTermAt G h s₂ y) = 0 := + Finset.sum_eq_zero (fun x _ => Finset.sum_eq_zero (fun y _ => by + rw [tensorTermAt_eq_zero_of_not_closed G h s₂ y hc₂] + ring)) + +open Classical in +/-- **A tensor term needs an Eulerian subset.** -/ +theorem pairTerm_eq_zero_of_not_eulerian {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (t : ℕ) (F G : Fragment (Fin t)) + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (hbad : ¬ ((EdgeSubset.mk s₁ hc₁).Eulerian + ∧ (EdgeSubset.mk s₂ hc₂).Eulerian)) : + (∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * tensorTermAt F h s₁ x + * tensorTermAt G h s₂ y) = 0 := by + by_cases hE₁ : (EdgeSubset.mk s₁ hc₁).Eulerian + · have hE₂ : ¬ (EdgeSubset.mk s₂ hc₂).Eulerian := + fun hx => hbad ⟨hE₁, hx⟩ + exact Finset.sum_eq_zero (fun x _ => Finset.sum_eq_zero + (fun y _ => by + rw [tensorTermAt_eq_zero_of_not_eulerian G h hc₂ y hE₂] + ring)) + · exact Finset.sum_eq_zero (fun x _ => Finset.sum_eq_zero + (fun y _ => by + rw [tensorTermAt_eq_zero_of_not_eulerian F h hc₁ x hE₁] + ring)) + +open Classical in +/-- **A tensor term needs canonical data.** -/ +theorem pairTerm_eq_zero_of_not_canon {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (t : ℕ) (F G : Fragment (Fin t)) + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (hE₁ : (EdgeSubset.mk s₁ hc₁).Eulerian) + (hE₂ : (EdgeSubset.mk s₂ hc₂).Eulerian) + (hbad : ¬ (Nonempty (EdgeSubset.mk s₁ hc₁).CanonData + ∧ Nonempty (EdgeSubset.mk s₂ hc₂).CanonData)) : + (∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * tensorTermAt F h s₁ x + * tensorTermAt G h s₂ y) = 0 := by + by_cases hn₁ : Nonempty (EdgeSubset.mk s₁ hc₁).CanonData + · have hn₂ : ¬ Nonempty (EdgeSubset.mk s₂ hc₂).CanonData := + fun hx => hbad ⟨hn₁, hx⟩ + exact Finset.sum_eq_zero (fun x _ => Finset.sum_eq_zero + (fun y _ => by + rw [tensorTermAt_eq_zero_of_not_canon G h hc₂ hE₂ y hn₂] + ring)) + · exact Finset.sum_eq_zero (fun x _ => Finset.sum_eq_zero + (fun y _ => by + rw [tensorTermAt_eq_zero_of_not_canon F h hc₁ hE₁ x hn₁] + ring)) + +open Classical in +/-- **The base's summand vanishes at an unguarded subset.** -/ +theorem base_term_eq_zero_of_not_guarded {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (t : ℕ) (F G : Fragment (Fin t)) + (bits : Fin t → Bool) + (s : Finset (closeBase F G).Flag) (C : ℕ) + (hbad : ¬ ∃ (hc : ∀ f ∈ s, (closeBase F G).pairing f ∈ s), + (EdgeSubset.mk s hc).Eulerian + ∧ Nonempty (EdgeSubset.mk s hc).CanonData) : + (∑ x : GenBoundaryState k ℓ (Fin t), + circuitWeight (liftData t (closeBase F G) bits + (pairFamily h t F G)) + (imageOf t (closeBase F G) s) + * edgeTermAt h (pairFamily h t F G) (diagOf t x) s C) + = 0 := by + refine Finset.sum_eq_zero (fun x _ => ?_) + by_cases hc : ∀ f ∈ s, (closeBase F G).pairing f ∈ s + · by_cases hE : (EdgeSubset.mk s hc).Eulerian + · have hne : ¬ Nonempty (EdgeSubset.mk s hc).CanonData := + fun hx => hbad ⟨hc, hE, hx⟩ + rw [edgeTermAt_eq_zero_of_not_canon h + (pairFamily h t F G) (diagOf t x) hc hne C] + ring + · rw [edgeTermAt_eq_zero_of_not_eulerian h + (pairFamily h t F G) (diagOf t x) hc hE C] + ring + · rw [edgeTermAt_eq_zero_of_not_closed h + (pairFamily h t F G) (diagOf t x) hc C] + ring + +/-- **The pair sums regroup.** Summing the pair terms over all +subsets of the two fragments is the superform pairing of the two +fragments' vectors. -/ +theorem sum_pairs_regroup {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (t : ℕ) (F G : Fragment (Fin t)) : + (∑ s₁ : Finset F.Flag, ∑ s₂ : Finset G.Flag, + ∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * tensorTermAt F h s₁ x + * tensorTermAt G h s₂ y) + = ∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y + * (∑ s₁ : Finset F.Flag, tensorTermAt F h s₁ x) + * (∑ s₂ : Finset G.Flag, tensorTermAt G h s₂ y) := by + have step : ∀ s₁ : Finset F.Flag, + (∑ s₂ : Finset G.Flag, ∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * tensorTermAt F h s₁ x + * tensorTermAt G h s₂ y) + = ∑ x : GenBoundaryState k ℓ (Fin t), + ∑ s₂ : Finset G.Flag, + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * tensorTermAt F h s₁ x + * tensorTermAt G h s₂ y := fun _ => Finset.sum_comm + rw [Finset.sum_congr rfl (fun s₁ _ => step s₁), Finset.sum_comm] + refine Finset.sum_congr rfl (fun x _ => ?_) + have step2 : ∀ s₁ : Finset F.Flag, + (∑ s₂ : Finset G.Flag, ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * tensorTermAt F h s₁ x + * tensorTermAt G h s₂ y) + = ∑ y : GenBoundaryState k ℓ (Fin t), + ∑ s₂ : Finset G.Flag, + superForm t x y * tensorTermAt F h s₁ x + * tensorTermAt G h s₂ y := fun _ => Finset.sum_comm + rw [Finset.sum_congr rfl (fun s₁ _ => step2 s₁), Finset.sum_comm] + refine Finset.sum_congr rfl (fun y _ => ?_) + refine Eq.trans (Finset.sum_congr rfl + (fun s₁ _ => (Finset.mul_sum _ _ _).symm)) ?_ + rw [← Finset.sum_mul, ← Finset.mul_sum] + +open Classical in +/-- **The glue keeps a balanced subset Eulerian.** At each stage the +drop has the lift's degrees, and the final relabel changes +nothing. -/ +theorem eulerian_glueData : ∀ (n : ℕ) + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))), + ∀ (D : StageData n V), + CutBalanced V D.sub.flags → + (EdgeSubset.mk D.sub.flags D.sub.pairing_mem).Eulerian → + (EdgeSubset.mk (glueData n V D).sub.flags + (glueData n V D).sub.pairing_mem).Eulerian + | 0, _, D, _, hE => (relabelUp_eulerian endEquiv D.sub).mpr hE + | n + 1, V, D, hbal, hE => by + by_cases hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) + · have hct := dropSubset_pairing_closed_of_closed hcl + D.sub.flags D.sub.pairing_mem + have hcL := liftSubsetClosed_pairing_closed hcl _ + (decide (V.boundaryFlag (cutL n) ∈ D.sub.flags)) hct + have hlift : liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) D.sub.flags) + (decide (V.boundaryFlag (cutL n) ∈ D.sub.flags)) + = D.sub.flags := + liftSubsetClosed_dropSubset (cutL_ne_cutR n) hcl + D.sub.flags D.sub.pairing_mem + have hEl : (EdgeSubset.mk (liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) D.sub.flags) + (decide (V.boundaryFlag (cutL n) ∈ D.sub.flags))) hcL : + EdgeSubset V).Eulerian := by + rw [show (EdgeSubset.mk (liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) D.sub.flags) + (decide (V.boundaryFlag (cutL n) ∈ D.sub.flags))) hcL : + EdgeSubset V) + = EdgeSubset.mk D.sub.flags D.sub.pairing_mem from + EdgeSubset.ext hlift] + exact hE + have hdrop := (eulerian_liftClosed_iff' hcl _ + (V.dropSubset (cutL n) (cutR n) D.sub.flags) hct hcL).mp hEl + refine eulerian_glueData n (stepFragment n V) + (stepData n V D) + (cutBalanced_stepData_closed n V hcl D hbal) ?_ + have hstage := flagsOfEq_eulerian (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) D.sub.flags) hct hdrop + have hgoal : (EdgeSubset.mk (flagsOfEq + (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) D.sub.flags)) + (flagsOfEq_pairing_mem (gluePair_eq_closed n V hcl) _ + hct) : + EdgeSubset (stepFragment n V)).Eulerian := + (relabelUp_eulerian (interfaceStepEquiv 0 n 0) _).mpr hstage + have hsub : (EdgeSubset.mk (stepData n V D).sub.flags + (stepData n V D).sub.pairing_mem : + EdgeSubset (stepFragment n V)) + = (EdgeSubset.mk (flagsOfEq + (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) D.sub.flags)) + (flagsOfEq_pairing_mem (gluePair_eq_closed n V hcl) _ + hct) : + EdgeSubset (stepFragment n V)) := + EdgeSubset.ext (stepData_sub_flags_closed n V D hcl) + rw [hsub] + exact hgoal + · have hct := dropSubset_rewire_closed (hopen := hcl) + D.sub.flags + (agreeingSubset_of_cutBalanced D.sub.pairing_mem hbal) + have hcL := liftSubsetOpen_pairing_closed (cutL_ne_cutR n) hcl + _ hct + have hlift : liftSubsetOpen hcl + (V.dropSubset (cutL n) (cutR n) D.sub.flags) + = D.sub.flags := + liftSubsetOpen_dropSubset (cutL_ne_cutR n) hcl D.sub.flags + D.sub.pairing_mem + have hEl : (EdgeSubset.mk (liftSubsetOpen hcl + (V.dropSubset (cutL n) (cutR n) D.sub.flags)) hcL : + EdgeSubset V).Eulerian := by + rw [show (EdgeSubset.mk (liftSubsetOpen hcl + (V.dropSubset (cutL n) (cutR n) D.sub.flags)) hcL : + EdgeSubset V) + = EdgeSubset.mk D.sub.flags D.sub.pairing_mem from + EdgeSubset.ext hlift] + exact hE + have hdrop := (eulerian_lift_open_iff (cutL_ne_cutR n) hcl + (V.dropSubset (cutL n) (cutR n) D.sub.flags) hct hcL).mp hEl + refine eulerian_glueData n (stepFragment n V) + (stepData n V D) + (cutBalanced_stepData n V hcl D hbal) ?_ + have hstage := flagsOfEq_eulerian (gluePair_eq_open n V hcl) + (V.dropSubset (cutL n) (cutR n) D.sub.flags) hct hdrop + have hgoal : (EdgeSubset.mk (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hcl) + (V.dropSubset (cutL n) (cutR n) D.sub.flags)) + (flagsOfEq_pairing_mem (gluePair_eq_open n V hcl) _ hct) : + EdgeSubset (stepFragment n V)).Eulerian := + (relabelUp_eulerian (interfaceStepEquiv 0 n 0) _).mpr hstage + have hsub : (EdgeSubset.mk (stepData n V D).sub.flags + (stepData n V D).sub.pairing_mem : + EdgeSubset (stepFragment n V)) + = (EdgeSubset.mk (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hcl) + (V.dropSubset (cutL n) (cutR n) D.sub.flags)) + (flagsOfEq_pairing_mem (gluePair_eq_open n V hcl) _ + hct) : + EdgeSubset (stepFragment n V)) := + EdgeSubset.ext (stepData_sub_flags_open n V D hcl) + rw [hsub] + exact hgoal + +open Classical in +/-- **The glue keeps a balanced subset's canonical data.** -/ +theorem canonData_glueData : ∀ (n : ℕ) + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))), + ∀ (D : StageData n V), + CutBalanced V D.sub.flags → + Nonempty (EdgeSubset.mk D.sub.flags + D.sub.pairing_mem).CanonData → + Nonempty (EdgeSubset.mk (glueData n V D).sub.flags + (glueData n V D).sub.pairing_mem).CanonData + | 0, _, D, _, hE => by + refine (EdgeSubset.nonempty_canonData_relabelUp + ⟨endEquiv, fun {a b} => ?_⟩ D.sub).mpr hE + exact a.elim (fun x => x.elim0) (fun x => x.elim0) + -- ═══════ ONE CUT AT A TIME ═══════ + -- The recursion glues the top interface pair and hands the rest + -- to the stage below; the cut closes or it does not. + | n + 1, V, D, hbal, hE => by + by_cases hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) + · have hct := dropSubset_pairing_closed_of_closed hcl + D.sub.flags D.sub.pairing_mem + have hcL := liftSubsetClosed_pairing_closed hcl _ + (decide (V.boundaryFlag (cutL n) ∈ D.sub.flags)) hct + have hlift : liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) D.sub.flags) + (decide (V.boundaryFlag (cutL n) ∈ D.sub.flags)) + = D.sub.flags := + liftSubsetClosed_dropSubset (cutL_ne_cutR n) hcl + D.sub.flags D.sub.pairing_mem + have hEl : Nonempty (EdgeSubset.mk (liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) D.sub.flags) + (decide (V.boundaryFlag (cutL n) ∈ D.sub.flags))) hcL : + EdgeSubset V).CanonData := by + rw [show (EdgeSubset.mk (liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) D.sub.flags) + (decide (V.boundaryFlag (cutL n) ∈ D.sub.flags))) hcL : + EdgeSubset V) + = EdgeSubset.mk D.sub.flags D.sub.pairing_mem from + EdgeSubset.ext hlift] + exact hE + have hdrop := nonempty_canonData_glueClosed hcl + (V.dropSubset (cutL n) (cutR n) D.sub.flags) hct _ hcL hEl + refine canonData_glueData n (stepFragment n V) + (stepData n V D) + (cutBalanced_stepData_closed n V hcl D hbal) ?_ + have hstage := flagsOfEq_canon (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) D.sub.flags) hct hdrop + have hgoal : Nonempty (EdgeSubset.mk (flagsOfEq + (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) D.sub.flags)) + (flagsOfEq_pairing_mem (gluePair_eq_closed n V hcl) _ + hct) : + EdgeSubset (stepFragment n V)).CanonData := + (EdgeSubset.nonempty_canonData_relabelUp (stepIso n) _).mpr + hstage + have hsub : (EdgeSubset.mk (stepData n V D).sub.flags + (stepData n V D).sub.pairing_mem : + EdgeSubset (stepFragment n V)) + = (EdgeSubset.mk (flagsOfEq + (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) D.sub.flags)) + (flagsOfEq_pairing_mem (gluePair_eq_closed n V hcl) _ + hct) : + EdgeSubset (stepFragment n V)) := + EdgeSubset.ext (stepData_sub_flags_closed n V D hcl) + rw [hsub] + exact hgoal + · have hct := dropSubset_rewire_closed (hopen := hcl) + D.sub.flags + (agreeingSubset_of_cutBalanced D.sub.pairing_mem hbal) + have hcL := liftSubsetOpen_pairing_closed (cutL_ne_cutR n) hcl + _ hct + have hlift : liftSubsetOpen hcl + (V.dropSubset (cutL n) (cutR n) D.sub.flags) + = D.sub.flags := + liftSubsetOpen_dropSubset (cutL_ne_cutR n) hcl D.sub.flags + D.sub.pairing_mem + have hEl : Nonempty (EdgeSubset.mk + (liftSubsetOpen hcl + (V.dropSubset (cutL n) (cutR n) D.sub.flags)) hcL : + EdgeSubset V).CanonData := by + rw [show (EdgeSubset.mk (liftSubsetOpen hcl + (V.dropSubset (cutL n) (cutR n) D.sub.flags)) hcL : + EdgeSubset V) + = EdgeSubset.mk D.sub.flags D.sub.pairing_mem from + EdgeSubset.ext hlift] + exact hE + have hdrop := nonempty_canonData_glueOpen (cutL_ne_cutR n) hcl + (V.dropSubset (cutL n) (cutR n) D.sub.flags) hct hcL hEl + refine canonData_glueData n (stepFragment n V) + (stepData n V D) + (cutBalanced_stepData n V hcl D hbal) ?_ + have hstage := flagsOfEq_canon (gluePair_eq_open n V hcl) + (V.dropSubset (cutL n) (cutR n) D.sub.flags) hct hdrop + have hgoal : Nonempty (EdgeSubset.mk (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hcl) + (V.dropSubset (cutL n) (cutR n) D.sub.flags)) + (flagsOfEq_pairing_mem (gluePair_eq_open n V hcl) _ hct) : + EdgeSubset (stepFragment n V)).CanonData := + (EdgeSubset.nonempty_canonData_relabelUp (stepIso n) _).mpr + hstage + have hsub : (EdgeSubset.mk (stepData n V D).sub.flags + (stepData n V D).sub.pairing_mem : + EdgeSubset (stepFragment n V)) + = (EdgeSubset.mk (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hcl) + (V.dropSubset (cutL n) (cutR n) D.sub.flags)) + (flagsOfEq_pairing_mem (gluePair_eq_open n V hcl) _ + hct) : + EdgeSubset (stepFragment n V)) := + EdgeSubset.ext (stepData_sub_flags_open n V D hcl) + rw [hsub] + exact hgoal + +/-- At a good pair of subsets the composition's own term is the +pair's term: RS21's (13) and (14) at one subset of the base. -/ +theorem base_term_eq_pairTerm_bitsOf {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (t : ℕ) (F G : Fragment (Fin t)) + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + (hE₁ : (EdgeSubset.mk s₁ hc₁).Eulerian) + (hn₁ : Nonempty (EdgeSubset.mk s₁ hc₁).CanonData) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (hE₂ : (EdgeSubset.mk s₂ hc₂).Eulerian) + (hn₂ : Nonempty (EdgeSubset.mk s₂ hc₂).CanonData) + (hused : ∀ i : Fin t, + F.boundaryFlag i ∈ s₁ ↔ G.boundaryFlag i ∈ s₂) + (hb : ∀ i : Fin t, + F.boundaryFlag i ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags + ↔ G.boundaryFlag i ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags) + (hEJ : (EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂)).Eulerian) + (hneJ : Nonempty (EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂)).CanonData) : + (∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * tensorTermAt F h s₁ x + * tensorTermAt G h s₂ y) + = ∑ x : GenBoundaryState k ℓ (Fin t), + circuitWeight (liftData t (closeBase F G) + (bitsOf t (closeBase F G) (closeJoin s₁ s₂)) + (pairFamily h t F G)) + (imageOf t (closeBase F G) (closeJoin s₁ s₂)) + * edgeTermAt h (pairFamily h t F G) (diagOf t x) + (closeJoin s₁ s₂) + (carried t (closeBase F G) (closeJoin s₁ s₂)) := by + have hal : Aligned t (closeBase F G) + (bitsOf t (closeBase F G) (closeJoin s₁ s₂)) + (pairFamily h t F G) := + aligned_of_baseDirections t (closeBase F G) _ _ + (baseDirections_pairFamily h t F G) + have hcompat : ∀ hc hE hne, + (pairFamily h t F G (pairStage hc₁ hc₂ hused + (Classical.choice hn₁).1 + (Classical.choice hn₂).1).sub.flags hc hE hne).1.MatchEq + (pairStage hc₁ hc₂ hused (Classical.choice hn₁).1 + (Classical.choice hn₂).1).rel := by + intro hc' hE' hne' + exact pairFamily_matchEq h t F G _ hc' hE' hne' s₁ hc₁ hE₁ + hn₁ s₂ hc₂ hE₂ hn₂ hused hb rfl + have hEg := eulerian_glueData t (closeBase F G) + (pairStage hc₁ hc₂ hused (Classical.choice hn₁).1 + (Classical.choice hn₂).1) (cutBalanced_closeJoin hused) hEJ + have hneg := canonData_glueData t (closeBase F G) + (pairStage hc₁ hc₂ hused (Classical.choice hn₁).1 + (Classical.choice hn₂).1) (cutBalanced_closeJoin hused) hneJ + have hw := circuitWeight_liftData_imageOf_bitsOf t (closeBase F G) + (pairFamily h t F G) + (pairStage hc₁ hc₂ hused (Classical.choice hn₁).1 + (Classical.choice hn₂).1) hal hcompat + (cutBalanced_closeJoin hused) hEg hneg + have hw' : circuitWeight (liftData t (closeBase F G) + (bitsOf t (closeBase F G) (closeJoin s₁ s₂)) + (pairFamily h t F G)) + (imageOf t (closeBase F G) (closeJoin s₁ s₂)) + = (-1 : ℂ) ^ (glueData t (closeBase F G) + (pairStage hc₁ hc₂ hused (Classical.choice hn₁).1 + (Classical.choice hn₂).1)).rel.openCircuitCount := hw + have hcar : carried t (closeBase F G) (closeJoin s₁ s₂) + = glueCount t (closeBase F G) + (pairStage hc₁ hc₂ hused (Classical.choice hn₁).1 + (Classical.choice hn₂).1) := + carried_eq_glueCount t (closeBase F G) + (pairStage hc₁ hc₂ hused (Classical.choice hn₁).1 + (Classical.choice hn₂).1) + rw [pairFamily_value h t F G (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂) hEJ hneJ s₁ hc₁ hE₁ hn₁ s₂ hc₂ + hE₂ hn₂ hused hb rfl, Finset.mul_sum] + refine Finset.sum_congr rfl (fun x _ => ?_) + rw [hw', hcar, edgeTermAt_eq_edgeTermOf h (pairFamily h t F G) + (diagOf t x) (closeJoin_pairing_mem hc₁ hc₂) hEJ hneJ _] + +/-- Summed over all boundary states, the form-weighted product of +the two fragments' terms is the composition's base sum — the +identity the converse runs on. -/ +theorem base_term_eq_pairTerm_all_bitsOf {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (t : ℕ) (F G : Fragment (Fin t)) + (s₁ : Finset F.Flag) (s₂ : Finset G.Flag) : + (∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * tensorTermAt F h s₁ x + * tensorTermAt G h s₂ y) + = ∑ x : GenBoundaryState k ℓ (Fin t), + circuitWeight (liftData t (closeBase F G) + (bitsOf t (closeBase F G) (closeJoin s₁ s₂)) + (pairFamily h t F G)) + (imageOf t (closeBase F G) (closeJoin s₁ s₂)) + * edgeTermAt h (pairFamily h t F G) (diagOf t x) + (closeJoin s₁ s₂) + (carried t (closeBase F G) (closeJoin s₁ s₂)) := by + by_cases hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁ + · by_cases hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂ + · by_cases hused : ∀ i : Fin t, + F.boundaryFlag i ∈ s₁ ↔ G.boundaryFlag i ∈ s₂ + · have hb : ∀ i : Fin t, + F.boundaryFlag i ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags + ↔ G.boundaryFlag i + ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags := by + intro i + constructor + · intro hx + exact boundaryFlag_mem_boundaryFlags + (F := EdgeSubset.mk s₂ hc₂) (a := i) + ((hused i).mp (mem_flags_of_boundaryFlags _ hx)) + · intro hx + exact boundaryFlag_mem_boundaryFlags + (F := EdgeSubset.mk s₁ hc₁) (a := i) + ((hused i).mpr (mem_flags_of_boundaryFlags _ hx)) + by_cases hE : (EdgeSubset.mk s₁ hc₁).Eulerian + ∧ (EdgeSubset.mk s₂ hc₂).Eulerian + · by_cases hn : Nonempty (EdgeSubset.mk s₁ hc₁).CanonData + ∧ Nonempty (EdgeSubset.mk s₂ hc₂).CanonData + · exact base_term_eq_pairTerm_bitsOf h t F G hc₁ hE.1 + hn.1 hc₂ hE.2 hn.2 hused hb + (eulerian_closeJoin hc₁ hc₂ hE.1 hE.2) + (canonData_closeJoin hc₁ hc₂ hused hn.1 hn.2) + · have hbad : ¬ ∃ (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂), + (EdgeSubset.mk (closeJoin s₁ s₂) hc).Eulerian + ∧ Nonempty (EdgeSubset.mk (closeJoin s₁ s₂) + hc).CanonData := by + rintro ⟨hcj, -, hnej⟩ + refine hn ⟨?_, ?_⟩ + · exact (nonempty_canonData_iff_system _).mpr + ⟨pairRelLeftDown hcj hc₁ (Classical.choice hnej).1⟩ + · exact (nonempty_canonData_iff_system _).mpr + ⟨pairRelRightDown hcj hc₂ + (Classical.choice hnej).1⟩ + rw [pairTerm_eq_zero_of_not_canon h t F G hc₁ hc₂ hE.1 + hE.2 hn, + base_term_eq_zero_of_not_guarded h t F G _ _ _ + hbad] + · have hbad : ¬ ∃ (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂), + (EdgeSubset.mk (closeJoin s₁ s₂) hc).Eulerian + ∧ Nonempty (EdgeSubset.mk (closeJoin s₁ s₂) + hc).CanonData := by + rintro ⟨hcj, hEj, -⟩ + exact not_eulerian_closeJoin hc₁ hc₂ hE hEj + rw [pairTerm_eq_zero_of_not_eulerian h t F G hc₁ hc₂ hE, + base_term_eq_zero_of_not_guarded h t F G _ _ _ + hbad] + · obtain ⟨i, hi⟩ := not_forall.mp hused + rw [base_term_eq_zero_of_not_matches h t F G _ _ _ + (not_matches_of_used_ne i hi)] + by_cases hL : F.boundaryFlag i ∈ s₁ + · exact pairTerm_eq_zero_of_used_ne h t F G s₁ s₂ i hL + (fun hx => hi ⟨fun _ => hx, fun _ => hL⟩) + · have hR : G.boundaryFlag i ∈ s₂ := by + by_contra hx + exact hi ⟨fun hy => absurd hy hL, fun hy => absurd hy hx⟩ + refine Eq.trans Finset.sum_comm (Finset.sum_eq_zero + (fun y _ => Finset.sum_eq_zero (fun x _ => ?_))) + by_cases hy : genBoundarySubsetMatches G s₂ y + · by_cases hx : genBoundarySubsetMatches F s₁ x + · obtain ⟨c, hcy⟩ := (hy i).mp hR + obtain ⟨a, hax⟩ := exists_left_of_not_right + (fun hr => hL ((hx i).mpr hr)) + rw [superForm_eq_zero_of_left_right x y i hax hcy] + ring + · rw [tensorTermAt_eq_zero_of_not_matches F h s₁ x hx] + ring + · rw [tensorTermAt_eq_zero_of_not_matches G h s₂ y hy] + ring + · have hbad : ¬ ∃ (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂), + (EdgeSubset.mk (closeJoin s₁ s₂) hc).Eulerian + ∧ Nonempty (EdgeSubset.mk (closeJoin s₁ s₂) + hc).CanonData := by + rintro ⟨hcj, -, -⟩ + exact not_closeJoin_closed_right s₁ s₂ hc₂ hcj + rw [pairTerm_eq_zero_of_not_closed_right h t F G s₁ s₂ hc₂, + base_term_eq_zero_of_not_guarded h t F G _ _ _ hbad] + · have hbad : ¬ ∃ (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂), + (EdgeSubset.mk (closeJoin s₁ s₂) hc).Eulerian + ∧ Nonempty (EdgeSubset.mk (closeJoin s₁ s₂) + hc).CanonData := by + rintro ⟨hcj, -, -⟩ + exact not_closeJoin_closed_left s₁ s₂ hc₁ hcj + rw [pairTerm_eq_zero_of_not_closed_left h t F G s₁ s₂ hc₁, + base_term_eq_zero_of_not_guarded h t F G _ _ _ hbad] + +open Classical in +/-- **The composition's base sum is the superform pairing, at every +interface.** Summing each base subset's term — read with the bits +that subset itself determines — over all subsets gives RS21's pairing +of the two fragments' tensors. -/ +theorem base_sum_eq_superForm_pairing_bitsOf {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (t : ℕ) (F G : Fragment (Fin t)) : + (∑ s : Finset (closeBase F G).Flag, + ∑ x : GenBoundaryState k ℓ (Fin t), + circuitWeight (liftData t (closeBase F G) + (bitsOf t (closeBase F G) s) (pairFamily h t F G)) + (imageOf t (closeBase F G) s) + * edgeTermAt h (pairFamily h t F G) (diagOf t x) s + (carried t (closeBase F G) s)) + = ∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y + * (∑ s₁ : Finset F.Flag, tensorTermAt F h s₁ x) + * (∑ s₂ : Finset G.Flag, tensorTermAt G h s₂ y) := by + rw [sum_subsets_disjUnion (W₁ := F.relabel + (finCongr (by omega : t = 0 + t))) + (W₂ := G.relabel (finCongr (by omega : t = t + 0))) + (fun s => ∑ x : GenBoundaryState k ℓ (Fin t), + circuitWeight (liftData t (closeBase F G) + (bitsOf t (closeBase F G) s) (pairFamily h t F G)) + (imageOf t (closeBase F G) s) + * edgeTermAt h (pairFamily h t F G) (diagOf t x) s + (carried t (closeBase F G) s))] + refine Eq.trans (Finset.sum_congr rfl (fun s₁ _ => + Finset.sum_congr rfl (fun s₂ _ => + (base_term_eq_pairTerm_all_bitsOf h t F G s₁ s₂).symm))) ?_ + exact sum_pairs_regroup h t F G + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseGram.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseGram.lean new file mode 100644 index 0000000000..be859368ef --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseGram.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RSTensor +public import LeanPool.RegtsSevenster.RS.StatementConverse + +/-! +# The converse from a super-Gram factorization + +The converse asks every mixed partition function to be an +edge-rank-bounded parameter. The rank bound follows from writing the +connection pairing as the super form evaluated at vectors attached to +the two fragments, so the converse rests on one displayed identity: +the closure of two fragments, evaluated by the mixed partition +function, is the super form of their two tensors. That identity is +`EdgeSubset.superGramIdentity` in `ConverseIdentity.lean`, and +the converse it gives is `regts_sevenster_converse` in +`RS/TheoremConverse.lean`. +-/ + +@[expose] public section + +namespace RS + + + +/-- **THE CONVERSE FROM A SUPER-GRAM FACTORIZATION**: a +state-indexed factorization of the connection pairing through the +super form bounds the edge rank, and with it the converse. -/ +theorem converse_of_superGram + (T : ∀ (k ℓ : ℕ), MixedFunctional k ℓ → ∀ t : ℕ, + Fragment (Fin t) → GenBoundaryState k ℓ (Fin t) → ℂ) + (hgram : ∀ (k ℓ : ℕ) (h : MixedFunctional k ℓ) (t : ℕ) + (F G : Fragment (Fin t)), + connectionPairing (fun W => mixedPartition h W) t F G + = ∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * T k ℓ h t F x * T k ℓ h t G y) : + RegtsSevensterConverseStatement := + converseStatement_of_rank_bounded eulerianIndependence + (fun k ℓ hf => + edgeRankBounded_of_superGram (T k ℓ hf) (hgram k ℓ hf)) + +/-! ### The fragment tensor, and the identity the converse rests on + +A subset's canonical data carry a transition system, so choosing one +at every guarded subset is a pinned family with no further input. +The fragment's tensor is its pinned sum at that family, normalised +by the state's fourth root. With the tensor fixed, the converse +rests on one closed identity. +-/ + +/-- **The fragment tensor**: RS21's `Σ_H t_h(F,H,ω_H,κ_H)`, with +the fragment's own free circles riding along. The flag model +carries vertex-free loops the graph model has no room for, and the +partition function weights each by `k - 2ℓ`; the circles the closure +creates come out of the contraction instead. -/ +noncomputable def fragmentTensor {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (t : ℕ) (F : Fragment (Fin t)) + (x : GenBoundaryState k ℓ (Fin t)) : ℂ := + ((k : ℂ) - 2 * ℓ) ^ F.circles * tensorSum F h x + +/-- **The super-Gram identity** (statement): the closure of two +fragments, evaluated by the mixed partition function, is the super +form of their two tensors. -/ +def SuperGramIdentity : Prop := + ∀ {k ℓ : ℕ} (h : MixedFunctional k ℓ) (t : ℕ) + (F G : Fragment (Fin t)), + connectionPairing (fun W => mixedPartition h W) t F G + = ∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * fragmentTensor h t F x + * fragmentTensor h t G y + +/-- **THE CONVERSE FROM THE SUPER-GRAM IDENTITY.** -/ +theorem converse_of_superGramIdentity (H : SuperGramIdentity) : + RegtsSevensterConverseStatement := + converse_of_superGram (fun _k _ℓ h t => fragmentTensor h t) + (fun _k _ℓ h t F G => H h t F G) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseIdentity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseIdentity.lean new file mode 100644 index 0000000000..184ec55bdb --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseIdentity.lean @@ -0,0 +1,155 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseFamily +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseGram + +/-! +# The super-Gram identity + +The closing display of the proof of RS21's Theorem 6, in the form +the converse consumes: the composition's mixed partition function +is the superform pairing of the two fragments' tensors. The base +sum the composition's own total equals is +`EdgeSubset.baseSumBitsOf_all` of `ConverseFamily.lean`, read with +the bits each subset itself determines, and the tensor side of that +sum is `EdgeSubset.base_sum_eq_superForm_pairing_bitsOf`. +-/ + +@[expose] public section + +namespace RS + + + +namespace EdgeSubset + +/-- The order the base's labels carry. -/ +@[reducible] local instance idBaseOrder (n : ℕ) : + LinearOrder (Fin (0 + n) ⊕ Fin (n + 0)) := + sumLexLinearOrder _ _ + +/-- The order the composition's own label type carries. -/ +@[reducible] local instance idTopOrder : + LinearOrder (Fin 0 ⊕ Fin 0) := + sumLexLinearOrder _ _ + +open Classical in +/-- **The closure, read on the base with each subset's own bits.** +The composition's own value is the sum, over the base's subsets, of +the ledger-weighted term the pair family gives — each subset read +with the bits it itself determines, which is the reading at which a +closing cut's two lifts are each other's. -/ +def BaseSumIsClosure : Prop := + ∀ {k ℓ : ℕ} (h : MixedFunctional k ℓ) (t : ℕ) + (F G : Fragment (Fin t)), + mixedPartition h (pairClose F G) + = ((k : ℂ) - 2 * ℓ) ^ (closeBase F G).circles * + ∑ s : Finset (closeBase F G).Flag, + ∑ x : GenBoundaryState k ℓ (Fin t), + circuitWeight (liftData t (closeBase F G) + (bitsOf t (closeBase F G) s) (pairFamily h t F G)) + (imageOf t (closeBase F G) s) + * edgeTermAt h (pairFamily h t F G) (diagOf t x) s + (carried t (closeBase F G) s) + +open Classical in +/-- **The base sum from the bit-varying sum.** The composition's own +total is the base sum read with each subset's own bits, once that sum +is known; the round trip then replaces the pushed lift by the pair +family itself. -/ +theorem baseSumIsClosure_of_baseSumBitsOf + (H : ∀ {k ℓ : ℕ} (h : MixedFunctional k ℓ) (t : ℕ) + (F G : Fragment (Fin t)), + BaseSumBitsOf h t (closeBase F G) (pairFamily h t F G) 0) : + BaseSumIsClosure := by + intro k ℓ h t F G + rw [mixedPartition_pairClose h t F G, + throughMixedPartitionC_eq_edgeTermAt_any h emptyState + (liftData t (closeBase F G) (fun _ => false) + (pairFamily h t F G)), + circles_glueInterface t (closeBase F G), pow_add, mul_assoc] + refine congrArg (fun z => ((k : ℂ) - 2 * ℓ) ^ + (closeBase F G).circles * z) ?_ + refine (H h t F G).trans (Finset.sum_congr rfl (fun s _ => + Finset.sum_congr rfl (fun x _ => ?_))) + refine congrArg (fun z => circuitWeight (liftData t (closeBase F G) + (bitsOf t (closeBase F G) s) (pairFamily h t F G)) + (imageOf t (closeBase F G) s) * z) ?_ + refine Eq.trans (edgeTermAt_pushData_liftData_all_bitsOf h t + (closeBase F G) (pairFamily h t F G) + (fun s' => aligned_of_baseDirections t (closeBase F G) _ _ + (baseDirections_pairFamily h t F G)) x s + (0 + carried t (closeBase F G) s)) ?_ + exact congrArg (fun c => edgeTermAt h (pairFamily h t F G) + (diagOf t x) s c) (zero_add (carried t (closeBase F G) s)) + +open Classical in +/-- **The closing identity of RS21's Theorem 6, from the base +sum.** The closure's value is the superform pairing of the two +fragment tensors, at every interface. -/ +theorem mixedPartition_pairClose_eq_superForm_of_baseSum + (H : BaseSumIsClosure) {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (t : ℕ) (F G : Fragment (Fin t)) : + mixedPartition h (pairClose F G) + = ((k : ℂ) - 2 * ℓ) ^ (closeBase F G).circles * + ∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y + * (∑ s₁ : Finset F.Flag, tensorTermAt F h s₁ x) + * (∑ s₂ : Finset G.Flag, tensorTermAt G h s₂ y) := + (H h t F G).trans (congrArg (fun z => _ * z) + (base_sum_eq_superForm_pairing_bitsOf h t F G)) + +open Classical in +/-- **THE SUPER-GRAM IDENTITY FROM THE BASE SUM.** With the base +sum, the closing identity of RS21's Theorem 6 holds at every +interface, and with it the converse: +the closure's value is the superform pairing of the two fragments' +tensors. -/ +theorem superGramIdentity_of_baseSum (H : BaseSumIsClosure) : + SuperGramIdentity := by + intro k ℓ h t F G + change mixedPartition h (pairClose F G) = _ + rw [mixedPartition_pairClose_eq_superForm_of_baseSum H h t F G, + circles_closeBase, Finset.mul_sum] + refine Finset.sum_congr rfl (fun x _ => ?_) + rw [Finset.mul_sum] + refine Finset.sum_congr rfl (fun y _ => ?_) + unfold fragmentTensor + rw [tensorSum_eq_sum, tensorSum_eq_sum, pow_add] + ring + +open Classical in +/-- **THE BASE SUM IS THE CLOSURE.** The composition's own value is +the base sum read with each subset's own bits — the reading at which +a closing cut's two lifts are each other's. Nothing is assumed: the +summand does not read the lift's bits at all +(`summandSum_bits_indep`). -/ +theorem baseSumIsClosure_all : BaseSumIsClosure := + baseSumIsClosure_of_baseSumBitsOf + (fun h t F G => baseSumBitsOf_all h t (closeBase F G) + (pairFamily h t F G) 0) + +open Classical in +/-- **THE SUPER-GRAM IDENTITY.** The closing display of the proof +of RS21's Theorem 6: the closure of two fragments, evaluated by +the mixed partition function, is the super form of their two +tensors — at every interface, closing cuts included. -/ +theorem superGramIdentity : SuperGramIdentity := + superGramIdentity_of_baseSum baseSumIsClosure_all + +open Classical in +/-- **THE REGTS–SEVENSTER CONVERSE.** Every mixed partition function +is an edge-rank-bounded parameter. -/ +theorem regtsSevensterConverse : RegtsSevensterConverseStatement := + converse_of_superGramIdentity superGramIdentity + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseLift.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseLift.lean new file mode 100644 index 0000000000..8caa2f7959 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseLift.lean @@ -0,0 +1,727 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseAssembly +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceAlternate + +/-! +# The lift's round trip, and the identity at no cuts + +The second half of the converse assembly: a stage of the lift +followed by a stage of the push, the congruences that let that +iterate over the interface, and the identity when the interface is +empty. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + +open Fragment +/-- The lexicographic order on the interface's label type. -/ +@[reducible] local instance liftBaseOrder (n : ℕ) : + LinearOrder (Fin (0 + n) ⊕ Fin (n + 0)) := + sumLexLinearOrder _ _ + +/-- The same order one stage up. -/ +@[reducible] local instance liftOrderSucc (n : ℕ) : + LinearOrder (Fin (0 + n + 1) ⊕ Fin (n + 1 + 0)) := + sumLexLinearOrder _ _ + +/-- The order a stage's surviving labels carry. -/ +@[reducible] local instance liftSurvOrder (n : ℕ) : + LinearOrder (SurvivingLabel + (Fin (0 + n + 1) ⊕ Fin (n + 1 + 0)) (cutL n) (cutR n)) := + sumLexSubtypeLinearOrder _ _ _ + +/-- The order the composition's own label type carries. -/ +@[reducible] local instance liftTopOrder : + LinearOrder (Fin 0 ⊕ Fin 0) := + sumLexLinearOrder _ _ + +/-! ## The stage round trip + +The relabel and the transport cancel outright at the level of +families, so a stage of the lift followed by a stage of the push is +the single-cut round trip and nothing more. +-/ + +open Classical in +/-- **A stage of the lift, pushed back — at an open cut.** -/ +theorem stepData_roundTrip_open (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) (b : Bool) (𝒟 : DataFamily V) : + stepDataDown n V (stepDataUp n V b 𝒟) + = unglueDataOpen (cutL_ne_cutR n) hop + (glueDataOpen (cutL_ne_cutR n) hop 𝒟) := by + unfold stepDataDown stepDataUp stepDataGlued + rw [dite_eq_right hop, dite_eq_right hop, relabelData_roundTrip, + dataOfEq_roundTrip] + +open Classical in +/-- **A stage of the lift, pushed back — at a closing cut.** -/ +theorem stepData_roundTrip_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) (b : Bool) (𝒟 : DataFamily V) : + stepDataDown n V (stepDataUp n V b 𝒟) + = unglueDataClosed (cutL_ne_cutR n) hcl + (glueDataClosed hcl b 𝒟) := by + unfold stepDataDown stepDataUp stepDataGlued + rw [dite_eq_left hcl, dite_eq_left hcl, relabelData_roundTrip, + dataOfEq_roundTrip] + +/-! ## Ungluing sees the system only through its partners + +So a stage of the push is insensitive to replacing the family it +consumes by a matching-equal one — which is what the round trip +delivers. +-/ + +open Classical in +/-- **Ungluing respects matching equality, at an open cut.** -/ +theorem match_unglueOpen_matchEq {α : Type} [LinearOrder α] + {V : Fragment α} {i j : α} (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (s' : Finset (SurvivingFlag V i j)) + (hc' : ∀ f ∈ s', (V.gluePairOpen i j hij hopen).pairing f ∈ s') + (hcL : ∀ f ∈ liftSubsetOpen hopen s', + V.pairing f ∈ liftSubsetOpen hopen s') + {κ₁ κ₂ : (EdgeSubset.mk s' hc' : + EdgeSubset (V.gluePairOpen i j hij hopen)).RelTransitionSystem} + (hm : κ₁.MatchEq κ₂) {f : V.Flag} + (hf : f ∈ (EdgeSubset.mk (liftSubsetOpen hopen s') hcL : + EdgeSubset V).internalFlags) : + (RelTransitionSystem.unglueOpen hij hopen s' hc' hcL κ₁).match_ f + = (RelTransitionSystem.unglueOpen hij hopen s' hc' hcL + κ₂).match_ f := by + obtain ⟨h1, h2⟩ := internal_surviving i j hf + have hg := internal_mk_of_glueOpen hij hopen s' hc' hcL hf h1 h2 + change unglueMatch κ₁.match_ f = unglueMatch κ₂.match_ f + unfold unglueMatch + rw [dite_eq_left ⟨h1, h2⟩, dite_eq_left ⟨h1, h2⟩, hm _ hg] + +open Classical in +/-- **Ungluing respects matching equality, at a closing cut.** -/ +theorem match_unglueClosed_matchEq {α : Type} [LinearOrder α] + {V : Fragment α} {i j : α} + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (b : Bool) (s' : Finset (SurvivingFlag V i j)) + (hc' : ∀ f ∈ s', (V.gluePairClosed i j hclosed).pairing f ∈ s') + (hcL : ∀ f ∈ liftSubsetClosed s' b, + V.pairing f ∈ liftSubsetClosed s' b) + {κ₁ κ₂ : (EdgeSubset.mk s' hc' : + EdgeSubset (V.gluePairClosed i j hclosed)).RelTransitionSystem} + (hm : κ₁.MatchEq κ₂) {f : V.Flag} + (hf : f ∈ (EdgeSubset.mk (liftSubsetClosed s' b) hcL : + EdgeSubset V).internalFlags) : + (RelTransitionSystem.unglueClosed hclosed b s' hc' hcL + κ₁).match_ f + = (RelTransitionSystem.unglueClosed hclosed b s' hc' hcL + κ₂).match_ f := by + obtain ⟨h1, h2⟩ := internal_surviving i j hf + have hg := (mem_internalFlags_glueClosed hclosed b s' hc' hcL + (f' := ⟨f, h1, h2⟩)).mpr hf + change unglueMatch κ₁.match_ f = unglueMatch κ₂.match_ f + unfold unglueMatch + rw [dite_eq_left ⟨h1, h2⟩, dite_eq_left ⟨h1, h2⟩, hm _ hg] + +open Classical in +/-- **One subset is enough**, at an open cut: the ungluing at `s` +reads the family only at `s`'s own drop. -/ +theorem match_unglueDataOpen_congr_at {α : Type} [LinearOrder α] + {V : Fragment α} {i j : α} (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (𝒟₁ 𝒟₂ : DataFamily (V.gluePairOpen i j hij hopen)) + {s : Finset V.Flag} + (hm : ∀ (hct : ∀ f ∈ V.dropSubset i j s, + (V.gluePairOpen i j hij hopen).pairing f + ∈ V.dropSubset i j s) + (hEt : (EdgeSubset.mk (V.dropSubset i j s) hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).Eulerian) + (hnet : Nonempty (EdgeSubset.mk (V.dropSubset i j s) hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).CanonData), + (𝒟₁ _ hct hEt hnet).1.MatchEq (𝒟₂ _ hct hEt hnet).1) + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc : EdgeSubset V).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc : EdgeSubset V).CanonData) : + (unglueDataOpen hij hopen 𝒟₁ s hc hE hne).1.MatchEq + (unglueDataOpen hij hopen 𝒟₂ s hc hE hne).1 := by + intro f hf + have hlift : liftSubsetOpen hopen (V.dropSubset i j s) = s := + liftSubsetOpen_dropSubset hij hopen s hc + unfold unglueDataOpen + by_cases hag : ∀ f ∈ V.dropSubset i j s, + (V.gluePairOpen i j hij hopen).pairing f + ∈ V.dropSubset i j s + · rw [dite_eq_left hag, dite_eq_left hag, match_relOfEq, match_relOfEq] + have hcL := liftSubsetOpen_pairing_closed hij hopen + (V.dropSubset i j s) hag + refine match_unglueOpen_matchEq hij hopen + (V.dropSubset i j s) hag hcL (hm _ _ _) ?_ + have hF : (EdgeSubset.mk (liftSubsetOpen hopen + (V.dropSubset i j s)) hcL : EdgeSubset V) + = EdgeSubset.mk s hc := EdgeSubset.ext hlift + rw [hF] + exact hf + · rw [dite_eq_right hag, dite_eq_right hag] + +open Classical in +/-- **One subset is enough**, under a transport. -/ +theorem match_dataOfEq_congr_at {L : Type} [LinearOrder L] + {V₁ V₂ : Fragment L} (h : V₁ = V₂) (𝒟₁ 𝒟₂ : DataFamily V₂) + (s : Finset V₁.Flag) + (hm : ∀ (hc' : ∀ f ∈ flagsOfEq V₁ V₂ h s, + V₂.pairing f ∈ flagsOfEq V₁ V₂ h s) + (hE' : (EdgeSubset.mk (flagsOfEq V₁ V₂ h s) hc').Eulerian) + (hne' : Nonempty + (EdgeSubset.mk (flagsOfEq V₁ V₂ h s) hc').CanonData), + (𝒟₁ _ hc' hE' hne').1.MatchEq (𝒟₂ _ hc' hE' hne').1) + (hc : ∀ f ∈ s, V₁.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) : + (dataOfEq h 𝒟₁ s hc hE hne).1.MatchEq + (dataOfEq h 𝒟₂ s hc hE hne).1 := by + subst h + exact hm hc hE hne + +open Classical in +/-- **One subset is enough**, under a relabel. -/ +theorem match_relabelDataDown_congr_at {α' β' : Type} + [LinearOrder α'] [LinearOrder β'] (e : α' ≃o β') + {W' : Fragment α'} (𝒟₁ 𝒟₂ : DataFamily (W'.relabel e.toEquiv)) + (s : Finset W'.Flag) + (hm : ∀ (hc' : ∀ f ∈ s, (W'.relabel e.toEquiv).pairing f ∈ s) + (hE' : (EdgeSubset.mk s hc' : + EdgeSubset (W'.relabel e.toEquiv)).Eulerian) + (hne' : Nonempty (EdgeSubset.mk s hc' : + EdgeSubset (W'.relabel e.toEquiv)).CanonData), + (𝒟₁ s hc' hE' hne').1.MatchEq (𝒟₂ s hc' hE' hne').1) + (hc : ∀ f ∈ s, W'.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) : + (relabelDataDown e 𝒟₁ s hc hE hne).1.MatchEq + (relabelDataDown e 𝒟₂ s hc hE hne).1 := by + intro f hf + refine hm hc _ _ f ?_ + exact (relabelUp_internalFlags e.toEquiv + (EdgeSubset.mk s hc)).symm ▸ hf + +open Classical in +/-- **One subset is enough**, for a whole stage of the push at an +open cut: the stage reads the family only at the stage subset the +drop makes. -/ +theorem match_stepDataDown_congr_at_open (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (𝒟₁ 𝒟₂ : DataFamily (stepFragment n V)) {s : Finset V.Flag} + (hm : ∀ (t : Finset (stepFragment n V).Flag), + t = flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) + (V.dropSubset (cutL n) (cutR n) s) → + ∀ (hct : ∀ f ∈ t, (stepFragment n V).pairing f ∈ t) + (hEt : (EdgeSubset.mk t hct).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct).CanonData), + (𝒟₁ t hct hEt hnet).1.MatchEq (𝒟₂ t hct hEt hnet).1) + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) : + (stepDataDown n V 𝒟₁ s hc hE hne).1.MatchEq + (stepDataDown n V 𝒟₂ s hc hE hne).1 := by + unfold stepDataDown + rw [dite_eq_right hop, dite_eq_right hop] + refine match_unglueDataOpen_congr_at (cutL_ne_cutR n) hop _ _ + ?_ hc hE hne + intro hct hEt hnet + refine match_dataOfEq_congr_at (gluePair_eq_open n V hop) _ _ + (V.dropSubset (cutL n) (cutR n) s) ?_ hct hEt hnet + intro hc' hE' hne' + exact match_relabelDataDown_congr_at (stepIso n) 𝒟₁ 𝒟₂ _ + (hm _ rfl) hc' hE' hne' + +open Classical in +/-- **One subset is enough**, at a closing cut: the push reads the +glued family only at the subset the drop makes. -/ +theorem match_unglueDataClosed_congr_at {α : Type} [LinearOrder α] + {V : Fragment α} {i j : α} (hij : i ≠ j) + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (𝒟₁ 𝒟₂ : DataFamily (V.gluePairClosed i j hclosed)) + {s : Finset V.Flag} + (hm : ∀ (hct : ∀ f ∈ V.dropSubset i j s, + (V.gluePairClosed i j hclosed).pairing f + ∈ V.dropSubset i j s) + (hEt : (EdgeSubset.mk (V.dropSubset i j s) hct : + EdgeSubset (V.gluePairClosed i j hclosed)).Eulerian) + (hnet : Nonempty (EdgeSubset.mk (V.dropSubset i j s) hct : + EdgeSubset (V.gluePairClosed i j hclosed)).CanonData), + (𝒟₁ _ hct hEt hnet).1.MatchEq (𝒟₂ _ hct hEt hnet).1) + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc : EdgeSubset V).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc : EdgeSubset V).CanonData) : + (unglueDataClosed hij hclosed 𝒟₁ s hc hE hne).1.MatchEq + (unglueDataClosed hij hclosed 𝒟₂ s hc hE hne).1 := by + intro f hf + have hlift : liftSubsetClosed (V.dropSubset i j s) + (decide (V.boundaryFlag i ∈ s)) = s := + liftSubsetClosed_dropSubset hij hclosed s hc + have hct := dropSubset_pairing_closed_of_closed hclosed s hc + have hcL := liftSubsetClosed_pairing_closed hclosed + (V.dropSubset i j s) (decide (V.boundaryFlag i ∈ s)) hct + unfold unglueDataClosed + rw [match_relOfEq, match_relOfEq] + refine match_unglueClosed_matchEq hclosed + (decide (V.boundaryFlag i ∈ s)) (V.dropSubset i j s) hct hcL + (hm _ _ _) ?_ + have hF : (EdgeSubset.mk (liftSubsetClosed (V.dropSubset i j s) + (decide (V.boundaryFlag i ∈ s))) hcL : EdgeSubset V) + = EdgeSubset.mk s hc := EdgeSubset.ext hlift + rw [hF] + exact hf + +open Classical in +/-- **One subset is enough**, for a whole stage of the push at a +closing cut. -/ +theorem match_stepDataDown_congr_at_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (𝒟₁ 𝒟₂ : DataFamily (stepFragment n V)) {s : Finset V.Flag} + (hm : ∀ (t : Finset (stepFragment n V).Flag), + t = flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) s) → + ∀ (hct : ∀ f ∈ t, (stepFragment n V).pairing f ∈ t) + (hEt : (EdgeSubset.mk t hct).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct).CanonData), + (𝒟₁ t hct hEt hnet).1.MatchEq (𝒟₂ t hct hEt hnet).1) + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) : + (stepDataDown n V 𝒟₁ s hc hE hne).1.MatchEq + (stepDataDown n V 𝒟₂ s hc hE hne).1 := by + unfold stepDataDown + rw [dite_eq_left hcl, dite_eq_left hcl] + refine match_unglueDataClosed_congr_at (cutL_ne_cutR n) hcl _ _ + ?_ hc hE hne + intro hct hEt hnet + refine match_dataOfEq_congr_at (gluePair_eq_closed n V hcl) _ _ + (V.dropSubset (cutL n) (cutR n) s) ?_ hct hEt hnet + intro hc' hE' hne' + exact match_relabelDataDown_congr_at (stepIso n) 𝒟₁ 𝒟₂ _ + (hm _ rfl) hc' hE' hne' + +open Classical in +/-- **The interface round trip, at no cuts.** The lift and the push +are inverse outright. -/ +theorem match_pushData_liftData_zero (V : Fragment (Fin (0 + 0) ⊕ Fin (0 + 0))) + (bits : Fin 0 → Bool) (𝒟 : DataFamily V) (s : Finset V.Flag) + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) : + (pushData 0 V (liftData 0 V bits 𝒟) s hc hE hne).1.MatchEq + (𝒟 s hc hE hne).1 := by + change (relabelDataDown baseIso (relabelDataUp baseIso 𝒟) s hc hE + hne).1.MatchEq _ + rw [relabelData_roundTrip] + exact fun _f _hf => rfl + +open Classical in +/-- **The interface round trip, one stage on — at an open cut**, +reading the family at the one stage subset the drop makes. -/ +theorem match_pushData_liftData_succ_open_at (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (bits : Fin (n + 1) → Bool) (𝒟 : DataFamily V) + {s : Finset V.Flag} (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc : EdgeSubset V).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc : EdgeSubset V).CanonData) + (hIH : ∀ (t : Finset (stepFragment n V).Flag), + t = flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) + (V.dropSubset (cutL n) (cutR n) s) → + ∀ (hct : ∀ f ∈ t, (stepFragment n V).pairing f ∈ t) + (hEt : (EdgeSubset.mk t hct).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct).CanonData), + (pushData n (stepFragment n V) + (liftData n (stepFragment n V) + (fun a => bits a.castSucc) + (stepDataUp n V (bits (Fin.last n)) 𝒟)) + t hct hEt hnet).1.MatchEq + (stepDataUp n V (bits (Fin.last n)) 𝒟 t hct hEt hnet).1) + (hdc : ∀ f ∈ V.dropSubset (cutL n) (cutR n) s, + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hop).pairing f ∈ V.dropSubset (cutL n) (cutR n) s) + (hcL : ∀ f ∈ liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s), + V.pairing f ∈ liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s)) + (hEL : (EdgeSubset.mk (liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s)) hcL : + EdgeSubset V).Eulerian) + (hneL : Nonempty (EdgeSubset.mk + (liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s)) hcL : + EdgeSubset V).CanonData) + (hag : (𝒟 (liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s)) hcL hEL hneL).2.isOut + (V.pairing (V.boundaryFlag (cutR n))) + = !(𝒟 (liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s)) hcL hEL + hneL).2.isOut (V.pairing (V.boundaryFlag (cutL n)))) : + (pushData (n + 1) V (liftData (n + 1) V bits 𝒟) s hc hE + hne).1.MatchEq (𝒟 s hc hE hne).1 := by + have h1 := match_stepDataDown_congr_at_open n V hop + (pushData n (stepFragment n V) + (liftData n (stepFragment n V) (fun a => bits a.castSucc) + (stepDataUp n V (bits (Fin.last n)) 𝒟))) + (stepDataUp n V (bits (Fin.last n)) 𝒟) hIH hc hE hne + rw [stepData_roundTrip_open n V hop (bits (Fin.last n)) 𝒟] at h1 + exact fun f hf => (h1 f hf).trans + (match_unglue_glueDataOpen (cutL_ne_cutR n) hop 𝒟 hc hE hne + hdc hcL hEL hneL hag f hf) + +-- As for the directions, on the matching. +open Classical in +/-- **The interface round trip, one stage on, at a closing cut, at +one subset.** The stage reads the family only at the subset the +drop makes, and the stage's bit is the one the subset itself +determines. -/ +theorem match_pushData_liftData_succ_closed_at (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (bits : Fin (n + 1) → Bool) (𝒟 : DataFamily V) + {s : Finset V.Flag} (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc : EdgeSubset V).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc : EdgeSubset V).CanonData) + (hbit : bits (Fin.last n) + = decide (V.boundaryFlag (cutL n) ∈ s)) + (hIH : ∀ (t : Finset (stepFragment n V).Flag), + t = flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) s) → + ∀ (hct : ∀ f ∈ t, (stepFragment n V).pairing f ∈ t) + (hEt : (EdgeSubset.mk t hct).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct).CanonData), + (pushData n (stepFragment n V) + (liftData n (stepFragment n V) + (fun a => bits a.castSucc) + (stepDataUp n V (bits (Fin.last n)) 𝒟)) + t hct hEt hnet).1.MatchEq + (stepDataUp n V (bits (Fin.last n)) 𝒟 t hct hEt hnet).1) + (hcL : ∀ f ∈ liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s)), + V.pairing f ∈ liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s))) + (hEL : (EdgeSubset.mk (liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s))) hcL : + EdgeSubset V).Eulerian) + (hneL : Nonempty (EdgeSubset.mk (liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s))) hcL : + EdgeSubset V).CanonData) : + (pushData (n + 1) V (liftData (n + 1) V bits 𝒟) s hc hE + hne).1.MatchEq (𝒟 s hc hE hne).1 := by + have h1 := match_stepDataDown_congr_at_closed n V hcl + (pushData n (stepFragment n V) + (liftData n (stepFragment n V) (fun a => bits a.castSucc) + (stepDataUp n V (bits (Fin.last n)) 𝒟))) + (stepDataUp n V (bits (Fin.last n)) 𝒟) hIH hc hE hne + rw [stepData_roundTrip_closed n V hcl (bits (Fin.last n)) 𝒟] at h1 + have h2 := match_unglue_glueDataClosed (cutL_ne_cutR n) hcl 𝒟 hc + hE hne hcL hEL hneL + rw [← hbit] at h2 + exact fun f hf => (h1 f hf).trans (h2 f hf) + +/-! ## The summand factorizes over a disjoint union of closed +fragments + +At empty label types the chord sign is one and every orientation is +path-canonical, so the pinned disjoint-union factorization reads +directly on the summand. +-/ + +open Classical in +/-- **The base subset's left half, brought down to the first +fragment, is the first subset.** This is the form +`edgeSum_closeBase_eq_pairAgreeValue` reads its data at. -/ +theorem relabelDown_leftSub_closeJoin {t : ℕ} + {F G : Fragment (Fin t)} {s₁ : Finset F.Flag} + {s₂ : Finset G.Flag} + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) : + EdgeSubset.relabelDown (finCongr (by omega : t = 0 + t)) + (leftSub (EdgeSubset.mk (closeJoin s₁ s₂) hc)) + = EdgeSubset.mk s₁ hc₁ := + EdgeSubset.ext (leftPart_joinParts + (W₁ := F.relabel (finCongr (by omega : t = 0 + t))) + (W₂ := G.relabel (finCongr (by omega : t = t + 0))) s₁ s₂) + +open Classical in +/-- **The base subset's right half, brought down to the second +fragment, is the second subset.** -/ +theorem relabelDown_rightSub_closeJoin {t : ℕ} + {F G : Fragment (Fin t)} {s₁ : Finset F.Flag} + {s₂ : Finset G.Flag} + (hc : ∀ f ∈ closeJoin s₁ s₂, + (closeBase F G).pairing f ∈ closeJoin s₁ s₂) + (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) : + EdgeSubset.relabelDown (finCongr (by omega : t = t + 0)) + (rightSub (EdgeSubset.mk (closeJoin s₁ s₂) hc)) + = EdgeSubset.mk s₂ hc₂ := + EdgeSubset.ext (rightPart_joinParts + (W₁ := F.relabel (finCongr (by omega : t = 0 + t))) + (W₂ := G.relabel (finCongr (by omega : t = t + 0))) s₁ s₂) + +open Classical in +/-- **The agreement value transports along equalities of the two +subsets.** This is what lets (13)'s orientations, which live on the +fragments' own subsets, be read on the base subset's halves. -/ +theorem pairAgreeValue_congr_subset {t : ℕ} + {W₁ W₂ : Fragment (Fin t)} {F₁ F₁' : EdgeSubset W₁} + (h₁ : F₁ = F₁') {F₂ F₂' : EdgeSubset W₂} (h₂ : F₂ = F₂') + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + {κ₁ : F₁.RelTransitionSystem} (o₁ : κ₁.Orientation) + {κ₂ : F₂.RelTransitionSystem} (o₂ : κ₂.Orientation) + (st : GenBoundaryState k ℓ (Fin t)) : + pairAgreeValue F₁ F₂ h o₁ o₂ st + = pairAgreeValue F₁' F₂' h (orientOfEq h₁ o₁) + (orientOfEq h₂ o₂) st := by + subst h₁ + subst h₂ + rfl + +open Classical in +/-- **The pair's agreement value is the base subset's colouring +sum.** RS21's (13) produces its orientations on the fragments' own +subsets; this reads the resulting agreement value on the base. -/ +theorem pairAgreeValue_eq_edgeSum_closeJoin {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (t : ℕ) (F G : Fragment (Fin t)) + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + {κ₁ : (EdgeSubset.mk s₁ hc₁).RelTransitionSystem} + (o₁ : κ₁.Orientation) + {κ₂ : (EdgeSubset.mk s₂ hc₂).RelTransitionSystem} + (o₂ : κ₂.Orientation) (x : GenBoundaryState k ℓ (Fin t)) + (hbnd : genBoundarySubsetMatches (closeBase F G) + (closeJoin s₁ s₂) (diagOf t x)) + (hbnd₁ : genBoundarySubsetMatches F + (leftSub (EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂))).flags x) + (hbnd₂ : genBoundarySubsetMatches G + (rightSub (EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂))).flags x) : + pairAgreeValue (EdgeSubset.mk s₁ hc₁) (EdgeSubset.mk s₂ hc₂) h + o₁ o₂ x + = (EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂)).edgeSum h (diagOf t x) + hbnd + (prodOrient + (relabelOrientUp (finCongr (by omega : t = 0 + t)) + (EdgeSubset.relabelDown + (finCongr (by omega : t = 0 + t)) + (leftSub (EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂)))) + (orientOfEq (relabelDown_leftSub_closeJoin + (closeJoin_pairing_mem hc₁ hc₂) hc₁).symm o₁)) + (relabelOrientUp (finCongr (by omega : t = t + 0)) + (EdgeSubset.relabelDown + (finCongr (by omega : t = t + 0)) + (rightSub (EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂)))) + (orientOfEq (relabelDown_rightSub_closeJoin + (closeJoin_pairing_mem hc₁ hc₂) hc₂).symm o₂))) := by + rw [pairAgreeValue_congr_subset + (relabelDown_leftSub_closeJoin + (closeJoin_pairing_mem hc₁ hc₂) hc₁).symm + (relabelDown_rightSub_closeJoin + (closeJoin_pairing_mem hc₁ hc₂) hc₂).symm h o₁ o₂ x] + exact (edgeSum_closeBase_eq_pairAgreeValue h t F G x + (EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂)) hbnd hbnd₁ hbnd₂ _ _).symm + +/-- An internal flag is not a boundary flag: it is attached to a +vertex. -/ +theorem ne_boundaryFlag_of_mem_internalFlags {L : Type} + {V : Fragment L} (F : EdgeSubset V) {f : V.Flag} + (hf : f ∈ F.internalFlags) (a : L) : f ≠ V.boundaryFlag a := by + intro hx + obtain ⟨_, v, hv⟩ := EdgeSubset.mem_internalFlags_iff.mp hf + rw [hx, V.attach_boundaryFlag] at hv + cases hv + +open Classical in +/-- **A subset's term is its colouring sum at any data of the same +shape**, needing the directions only where the sum reads them. -/ +theorem edgeTermAt_eq_signed_edgeSum_internal {k ℓ : ℕ} {L : Type} + [LinearOrder L] {V : Fragment L} (h : MixedFunctional k ℓ) + (𝒟 : DataFamily V) (st : GenBoundaryState k ℓ L) + {s : Finset V.Flag} (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hbnd : genBoundarySubsetMatches V s st) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) (C : ℕ) + {κ : (EdgeSubset.mk s hc).RelTransitionSystem} + (O : κ.Orientation) + (hm : (𝒟 s hc hE hne).1.MatchEq κ) + (hio : ∀ f ∈ (EdgeSubset.mk s hc).internalFlags, + (𝒟 s hc hE hne).2.isOut f = O.isOut f) : + edgeTermAt h 𝒟 st s C + = ((-1 : ℂ) ^ C) + * (EdgeSubset.mk s hc).edgeSum h st hbnd O := by + rw [edgeTermAt_pos h 𝒟 st hc hbnd hE hne C] + exact congrArg (fun z => ((-1 : ℂ) ^ C) * z) + (edgeSum_matchEq_internal hm h st hbnd _ O hio) + +/-- The left interface partner, read on the disjoint union. -/ +theorem pairing_boundaryFlag_intL {t : ℕ} (F G : Fragment (Fin t)) + (m : Fin t) : + (closeBase F G).pairing ((closeBase F G).boundaryFlag + (intL t m)) + = Sum.inl ((F.relabel (finCongr (by omega : t = 0 + t))).pairing + ((F.relabel (finCongr (by omega : t = 0 + t))).boundaryFlag + (Fin.cast (by omega) m))) := rfl + +/-- The right interface partner, read on the disjoint union. -/ +theorem pairing_boundaryFlag_intR {t : ℕ} (F G : Fragment (Fin t)) + (m : Fin t) : + (closeBase F G).pairing ((closeBase F G).boundaryFlag + (intR t m)) + = Sum.inr ((G.relabel (finCongr (by omega : t = t + 0))).pairing + ((G.relabel (finCongr (by omega : t = t + 0))).boundaryFlag + (Fin.cast (by omega) m))) := rfl + +/-- The flag the left half of the `m`-th cut points at. -/ +noncomputable abbrev cutFlagL {t : ℕ} (F G : Fragment (Fin t)) + (m : Fin t) : (closeBase F G).Flag := + (closeBase F G).pairing ((closeBase F G).boundaryFlag (intL t m)) + +/-- The flag the right half of the `m`-th cut points at. -/ +noncomputable abbrev cutFlagR {t : ℕ} (F G : Fragment (Fin t)) + (m : Fin t) : (closeBase F G).Flag := + (closeBase F G).pairing ((closeBase F G).boundaryFlag (intR t m)) + +/-- **A used, non-through left label has an internal cut flag.** -/ +theorem internal_cutFlagL {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (m : Fin t) + (hm : F.boundaryFlag m ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags) + (hnt : ¬ IsThroughLabel (EdgeSubset.mk s₁ hc₁) m) : + cutFlagL F G m ∈ (EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂)).internalFlags := by + refine inl_mem_internal.mpr ?_ + rw [leftSub_closeJoin (closeJoin_pairing_mem hc₁ hc₂) hc₁] + have h := pairing_internal_of_not_through + (EdgeSubset.mk s₁ hc₁) hm hnt + rwa [← relabelUp_internalFlags (finCongr (Nat.zero_add t).symm) + (EdgeSubset.mk s₁ hc₁)] at h + +/-- **A used, non-through right label has an internal cut flag.** -/ +theorem internal_cutFlagR {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (m : Fin t) + (hm : G.boundaryFlag m ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags) + (hnt : ¬ IsThroughLabel (EdgeSubset.mk s₂ hc₂) m) : + cutFlagR F G m ∈ (EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂)).internalFlags := by + refine inr_mem_internal.mpr ?_ + rw [rightSub_closeJoin (closeJoin_pairing_mem hc₁ hc₂) hc₂] + have h := pairing_internal_of_not_through + (EdgeSubset.mk s₂ hc₂) hm hnt + rwa [← relabelUp_internalFlags (finCongr (Nat.add_zero t).symm) + (EdgeSubset.mk s₂ hc₂)] at h + +/-! ## The composition's weighted term is family-free + +At an empty label type the circuit weight times the summand does not +depend on which data compute it. This is what makes the +composition's side of the identity independent of the family, one +subset at a time. +-/ + +section WeightIndep + +variable {L : Type} + +open Classical in +/-- **The weighted summand at the composition is family-free.** -/ +theorem circuitWeight_mul_edgeTermAt_indep + [LinearOrder L] [IsEmpty L] {V : Fragment L} + {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ L) + (u : Finset V.Flag) (C : ℕ) (𝒟 𝒟' : DataFamily V) : + circuitWeight 𝒟 u * edgeTermAt h 𝒟 st u C + = circuitWeight 𝒟' u * edgeTermAt h 𝒟' st u C := by + by_cases hc : ∀ f ∈ u, V.pairing f ∈ u + · by_cases hbnd : genBoundarySubsetMatches V u st + · by_cases hE : (EdgeSubset.mk u hc).Eulerian + · by_cases hne : Nonempty (EdgeSubset.mk u hc).CanonData + · rw [circuitWeight_pos 𝒟 hc hE hne, + circuitWeight_pos 𝒟' hc hE hne, + edgeTermAt_pos h 𝒟 st hc hbnd hE hne C, + edgeTermAt_pos h 𝒟' st hc hbnd hE hne C] + have hkey : ((-1 : ℂ) ^ (𝒟 u hc hE hne).1.openCircuitCount) + * (EdgeSubset.mk u hc).edgeSum h st hbnd + (𝒟 u hc hE hne).2 + = ((-1 : ℂ) ^ (𝒟' u hc hE hne).1.openCircuitCount) + * (EdgeSubset.mk u hc).edgeSum h st hbnd + (𝒟' u hc hE hne).2 := by + rw [← throughSummand_eq_edgeSum (EdgeSubset.mk u hc) h + st hbnd _ _, + ← throughSummand_eq_edgeSum (EdgeSubset.mk u hc) h st + hbnd _ _] + exact throughSummand_canon_indep (EdgeSubset.mk u hc) h + st hbnd ⟨_, _, pathCanonical_isEmpty _ _⟩ + ⟨_, _, pathCanonical_isEmpty _ _⟩ + calc ((-1 : ℂ) ^ (𝒟 u hc hE hne).1.openCircuitCount) + * (((-1 : ℂ) ^ C) * + (EdgeSubset.mk u hc).edgeSum h st hbnd + (𝒟 u hc hE hne).2) + = ((-1 : ℂ) ^ C) * + (((-1 : ℂ) ^ (𝒟 u hc hE hne).1.openCircuitCount) * + (EdgeSubset.mk u hc).edgeSum h st hbnd + (𝒟 u hc hE hne).2) := by ring + _ = ((-1 : ℂ) ^ C) * + (((-1 : ℂ) ^ (𝒟' u hc hE hne).1.openCircuitCount) * + (EdgeSubset.mk u hc).edgeSum h st hbnd + (𝒟' u hc hE hne).2) := by rw [hkey] + _ = _ := by ring + · rw [edgeTermAt_eq_zero_of_not_canon h 𝒟 st hc hne C, + edgeTermAt_eq_zero_of_not_canon h 𝒟' st hc hne C, + mul_zero, mul_zero] + · rw [edgeTermAt_eq_zero_of_not_eulerian h 𝒟 st hc hE C, + edgeTermAt_eq_zero_of_not_eulerian h 𝒟' st hc hE C, + mul_zero, mul_zero] + · rw [edgeTermAt_eq_zero_of_not_matches h 𝒟 st hbnd C, + edgeTermAt_eq_zero_of_not_matches h 𝒟' st hbnd C, + mul_zero, mul_zero] + · rw [edgeTermAt_eq_zero_of_not_closed h 𝒟 st hc C, + edgeTermAt_eq_zero_of_not_closed h 𝒟' st hc C, + mul_zero, mul_zero] + +end WeightIndep + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConversePair.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConversePair.lean new file mode 100644 index 0000000000..60b244e400 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConversePair.lean @@ -0,0 +1,1090 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseTrip + +/-! +# The pair datum at one pair of subsets + +RS21's (13) and (14) at a single pair of subsets of two composable +fragments: the tail function the pair's chords induce on the +interface labels, how it behaves at a through edge, at a cut and +at a pinned end, and the edge term the pair contributes. + +`ConverseFamily.lean` chooses one such datum at every subset of the +composition's base and sums the results; `ConverseTrip.lean` carries +the choice up and down the interface. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + +open Fragment +/-- The lexicographic order on the interface's label type. -/ +@[reducible] local instance pairBaseOrder (n : ℕ) : + LinearOrder (Fin (0 + n) ⊕ Fin (n + 0)) := + sumLexLinearOrder _ _ + +/-- The same order one stage up. -/ +@[reducible] local instance pairOrderSucc (n : ℕ) : + LinearOrder (Fin (0 + n + 1) ⊕ Fin (n + 1 + 0)) := + sumLexLinearOrder _ _ + +/-- The order a stage's surviving labels carry. -/ +@[reducible] local instance pairSurvOrder (n : ℕ) : + LinearOrder (SurvivingLabel + (Fin (0 + n + 1) ⊕ Fin (n + 1 + 0)) (cutL n) (cutR n)) := + sumLexSubtypeLinearOrder _ _ _ + +/-- The order the composition's own label type carries. -/ +@[reducible] local instance pairTopOrder : + LinearOrder (Fin 0 ⊕ Fin 0) := + sumLexLinearOrder _ _ + +open Classical in +/-- **Every interface has a cut colouring**: a two-colouring of its +flags alternating along every edge and across every interface pair. +Each stage extends the next one's colouring. At an open cut the +cut's two flags take the opposite colour to their partners, which +survive the glue, and the top cut's own condition is then the stage's +alternation along the edge the glue creates. At a closing cut both +flags leave with the glue, so their colours are free, and the one +constraint the edge and the pair jointly impose is met by opposing +them. -/ +theorem exists_cut_colouring : ∀ (n : ℕ) + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))), + ∃ c : V.Flag → Bool, (∀ f, c (V.pairing f) = !c f) + ∧ ∀ m : Fin n, c (V.boundaryFlag (intR n m)) + = !c (V.boundaryFlag (intL n m)) + -- ═══════ NO CUTS ═══════ + | 0, V => by + obtain ⟨c, hc⟩ := exists_edge_colouring V + exact ⟨c, hc, fun m => m.elim0⟩ + -- ═══════ ONE MORE CUT ═══════ + | n + 1, V => by + obtain ⟨c', hA', hB'⟩ := exists_cut_colouring n (stepFragment n V) + -- A closing cut extends the colouring across the new circle; an + -- open one extends it along the rewired edge. + by_cases hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) + · -- ═══════ THE CUT CLOSES ═══════ + refine ⟨cutExtendClosed n V hcl c', fun f => ?_, fun m => ?_⟩ + · by_cases h1 : f = V.boundaryFlag (cutL n) + · subst h1 + rw [hcl, cutExtendClosed_cutR, cutExtendClosed_cutL, + Bool.not_true] + · by_cases h2 : f = V.boundaryFlag (cutR n) + · subst h2 + have hcl' : V.pairing (V.boundaryFlag (cutR n)) + = V.boundaryFlag (cutL n) := by + rw [← hcl, V.pairing_invol] + rw [hcl', cutExtendClosed_cutL, cutExtendClosed_cutR, + Bool.not_false] + · have k1 := pairing_ne_cutL_of_closed n V hcl f h2 + have k2 := pairing_ne_cutR_of_closed n V hcl f h1 + rw [cutExtendClosed_of_ne n V hcl c' _ k1 k2, + cutExtendClosed_of_ne n V hcl c' _ h1 h2, + ← pairing_stageFlagClosed n V hcl f h1 h2 k1 k2] + exact hA' _ + · refine Fin.lastCases ?_ (fun b => ?_) m + · rw [intR_last, intL_last, cutExtendClosed_cutR, + cutExtendClosed_cutL, Bool.not_true] + · have hbL := fun (hx : V.boundaryFlag + (intL (n + 1) b.castSucc) = V.boundaryFlag (cutL n)) => + intL_ne_cutL n b (V.boundaryFlag_injective hx) + have hbL2 := fun (hx : V.boundaryFlag + (intL (n + 1) b.castSucc) = V.boundaryFlag (cutR n)) => + intL_ne_cutR n b (V.boundaryFlag_injective hx) + have hbR := fun (hx : V.boundaryFlag + (intR (n + 1) b.castSucc) = V.boundaryFlag (cutL n)) => + intR_ne_cutL n b (V.boundaryFlag_injective hx) + have hbR2 := fun (hx : V.boundaryFlag + (intR (n + 1) b.castSucc) = V.boundaryFlag (cutR n)) => + intR_ne_cutR n b (V.boundaryFlag_injective hx) + rw [cutExtendClosed_of_ne n V hcl c' _ hbR hbR2, + cutExtendClosed_of_ne n V hcl c' _ hbL hbL2, + stageFlagClosed_congr n V hcl + (congrArg V.boundaryFlag + (interfaceStepEquiv_symm_intR n b).symm) _ _ + (fun hx => hbR (by + rw [interfaceStepEquiv_symm_intR n b] at hx + exact hx)) + (fun hx => hbR2 (by + rw [interfaceStepEquiv_symm_intR n b] at hx + exact hx)), + stageFlagClosed_congr n V hcl + (congrArg V.boundaryFlag + (interfaceStepEquiv_symm_intL n b).symm) _ _ + (fun hx => hbL (by + rw [interfaceStepEquiv_symm_intL n b] at hx + exact hx)) + (fun hx => hbL2 (by + rw [interfaceStepEquiv_symm_intL n b] at hx + exact hx)), + stageFlagClosed_boundaryFlag n V hcl (intR n b), + stageFlagClosed_boundaryFlag n V hcl (intL n b)] + exact hB' b + · -- ═══════ THE CUT STAYS OPEN ═══════ + have hop := hcl + have hL1 : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutL n) := V.pairing_ne _ + have hR2 : V.pairing (V.boundaryFlag (cutR n)) + ≠ V.boundaryFlag (cutR n) := V.pairing_ne _ + have hR1 : V.pairing (V.boundaryFlag (cutR n)) + ≠ V.boundaryFlag (cutL n) := fun hx => + hop (by rw [← hx, V.pairing_invol]) + refine ⟨cutExtend n V hop hL1 hR1 hR2 c', fun f => ?_, + fun m => ?_⟩ + · by_cases h1 : f = V.boundaryFlag (cutL n) + · subst h1 + rw [cutExtend_cutL, + cutExtend_of_ne n V hop hL1 hR1 hR2 c' _ hL1 hop, + Bool.not_not] + · by_cases h2 : f = V.boundaryFlag (cutR n) + · subst h2 + rw [cutExtend_cutR, + cutExtend_of_ne n V hop hL1 hR1 hR2 c' _ hR1 hR2, + Bool.not_not] + · by_cases k1 : V.pairing f = V.boundaryFlag (cutL n) + · have hf : f = V.pairing (V.boundaryFlag (cutL n)) := by + rw [← k1, V.pairing_invol] + subst hf + rw [V.pairing_invol, cutExtend_cutL, + cutExtend_of_ne n V hop hL1 hR1 hR2 c' _ h1 h2] + · by_cases k2 : V.pairing f = V.boundaryFlag (cutR n) + · have hf : f = V.pairing (V.boundaryFlag (cutR n)) := by + rw [← k2, V.pairing_invol] + subst hf + rw [V.pairing_invol, cutExtend_cutR, + cutExtend_of_ne n V hop hL1 hR1 hR2 c' _ h1 h2] + · rw [cutExtend_of_ne n V hop hL1 hR1 hR2 c' _ k1 k2, + cutExtend_of_ne n V hop hL1 hR1 hR2 c' _ h1 h2, + ← pairing_stageFlag_of_ne n V hop f h1 h2 k1 k2] + exact hA' _ + · refine Fin.lastCases ?_ (fun b => ?_) m + · rw [intR_last, intL_last, cutExtend_cutR, cutExtend_cutL, + Bool.not_not, + ← pairing_stageFlag_cutR n V hop hR1 hR2 hL1 hop] + exact (hA' _).symm + · have hbL := fun (hx : V.boundaryFlag + (intL (n + 1) b.castSucc) = V.boundaryFlag (cutL n)) => + intL_ne_cutL n b (V.boundaryFlag_injective hx) + have hbL2 := fun (hx : V.boundaryFlag + (intL (n + 1) b.castSucc) = V.boundaryFlag (cutR n)) => + intL_ne_cutR n b (V.boundaryFlag_injective hx) + have hbR := fun (hx : V.boundaryFlag + (intR (n + 1) b.castSucc) = V.boundaryFlag (cutL n)) => + intR_ne_cutL n b (V.boundaryFlag_injective hx) + have hbR2 := fun (hx : V.boundaryFlag + (intR (n + 1) b.castSucc) = V.boundaryFlag (cutR n)) => + intR_ne_cutR n b (V.boundaryFlag_injective hx) + rw [cutExtend_of_ne n V hop hL1 hR1 hR2 c' _ hbR hbR2, + cutExtend_of_ne n V hop hL1 hR1 hR2 c' _ hbL hbL2, + stageFlag_congr n V hop + (congrArg V.boundaryFlag + (interfaceStepEquiv_symm_intR n b).symm) _ _ + (fun hx => hbR (by + rw [interfaceStepEquiv_symm_intR n b] at hx + exact hx)) + (fun hx => hbR2 (by + rw [interfaceStepEquiv_symm_intR n b] at hx + exact hx)), + stageFlag_congr n V hop + (congrArg V.boundaryFlag + (interfaceStepEquiv_symm_intL n b).symm) _ _ + (fun hx => hbL (by + rw [interfaceStepEquiv_symm_intL n b] at hx + exact hx)) + (fun hx => hbL2 (by + rw [interfaceStepEquiv_symm_intL n b] at hx + exact hx)), + stageFlag_boundaryFlag n V hop (intR n b), + stageFlag_boundaryFlag n V hop (intL n b)] + exact hB' b + +/-- Every left label is the left half of its own pair. -/ +theorem intL_cast {n : ℕ} (i : Fin (0 + n)) : + intL n (Fin.cast (by omega) i) = Sum.inl i := + congrArg Sum.inl (Fin.ext rfl) + +/-- Every right label is the right half of its own pair. -/ +theorem intR_cast {n : ℕ} (j : Fin (n + 0)) : + intR n (Fin.cast (by omega) j) = Sum.inr j := + congrArg Sum.inr (Fin.ext rfl) + +open Classical in +/-- **The directions the two matchings prescribe.** At a used +label's boundary flag the matching's tail; elsewhere the given +colouring. -/ +noncomputable def pairTailFun {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (M₁ : DirMatching (UsedLab (EdgeSubset.mk s₁ hc₁))) + (M₂ : DirMatching (UsedLab (EdgeSubset.mk s₂ hc₂))) + (c : (closeBase F G).Flag → Bool) : (closeBase F G).Flag → Bool := + fun f => + if h : ∃ m : Fin t, + f = (closeBase F G).boundaryFlag (intL t m) + ∧ F.boundaryFlag m ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags + then M₁.tail ⟨h.choose, h.choose_spec.2⟩ + else if h' : ∃ m : Fin t, + f = (closeBase F G).boundaryFlag (intR t m) + ∧ G.boundaryFlag m ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags + then M₂.tail ⟨h'.choose, h'.choose_spec.2⟩ + else c f + +open Classical in +/-- At a flag that is no used label's, the prescribed direction is +the colouring's. -/ +theorem pairTailFun_of_not_used {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (M₁ : DirMatching (UsedLab (EdgeSubset.mk s₁ hc₁))) + (M₂ : DirMatching (UsedLab (EdgeSubset.mk s₂ hc₂))) + (c : (closeBase F G).Flag → Bool) (f : (closeBase F G).Flag) + (h : ¬ ∃ m : Fin t, + f = (closeBase F G).boundaryFlag (intL t m) + ∧ F.boundaryFlag m ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags) + (h' : ¬ ∃ m : Fin t, + f = (closeBase F G).boundaryFlag (intR t m) + ∧ G.boundaryFlag m ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags) : + pairTailFun hc₁ hc₂ M₁ M₂ c f = c f := by + unfold pairTailFun + rw [dite_eq_right h, dite_eq_right h'] + +/-- The left labels are distinct. -/ +theorem intL_inj {n : ℕ} {m m' : Fin n} (h : intL n m = intL n m') : + m = m' := by + have h2 : (Fin.cast (by omega) m : Fin (0 + n)) + = Fin.cast (by omega) m' := Sum.inl.inj h + have h3 := congrArg Fin.val h2 + simp only [Fin.val_cast] at h3 + exact Fin.ext h3 + +/-- The right labels are distinct. -/ +theorem intR_inj {n : ℕ} {m m' : Fin n} (h : intR n m = intR n m') : + m = m' := by + have h2 : (Fin.cast (by omega) m : Fin (n + 0)) + = Fin.cast (by omega) m' := Sum.inr.inj h + have h3 := congrArg Fin.val h2 + simp only [Fin.val_cast] at h3 + exact Fin.ext h3 + +open Classical in +/-- At a used left label the prescribed direction is the left +matching's tail. -/ +theorem pairTailFun_intL {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (M₁ : DirMatching (UsedLab (EdgeSubset.mk s₁ hc₁))) + (M₂ : DirMatching (UsedLab (EdgeSubset.mk s₂ hc₂))) + (c : (closeBase F G).Flag → Bool) (m : Fin t) + (hm : F.boundaryFlag m + ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags) : + pairTailFun hc₁ hc₂ M₁ M₂ c + ((closeBase F G).boundaryFlag (intL t m)) + = M₁.tail ⟨m, hm⟩ := by + have h : ∃ m' : Fin t, + (closeBase F G).boundaryFlag (intL t m) + = (closeBase F G).boundaryFlag (intL t m') + ∧ F.boundaryFlag m' + ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags := ⟨m, rfl, hm⟩ + unfold pairTailFun + rw [dite_eq_left h] + refine congrArg M₁.tail (Subtype.ext ?_) + exact (intL_inj ((closeBase F G).boundaryFlag_injective + h.choose_spec.1)).symm + +open Classical in +/-- At a used right label the prescribed direction is the right +matching's tail. -/ +theorem pairTailFun_intR {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (M₁ : DirMatching (UsedLab (EdgeSubset.mk s₁ hc₁))) + (M₂ : DirMatching (UsedLab (EdgeSubset.mk s₂ hc₂))) + (c : (closeBase F G).Flag → Bool) (m : Fin t) + (hm : G.boundaryFlag m + ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags) : + pairTailFun hc₁ hc₂ M₁ M₂ c + ((closeBase F G).boundaryFlag (intR t m)) + = M₂.tail ⟨m, hm⟩ := by + have hno : ¬ ∃ m' : Fin t, + (closeBase F G).boundaryFlag (intR t m) + = (closeBase F G).boundaryFlag (intL t m') + ∧ F.boundaryFlag m' + ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags := by + rintro ⟨m', hx, -⟩ + exact Sum.inr_ne_inl + ((closeBase F G).boundaryFlag_injective hx) + have h : ∃ m' : Fin t, + (closeBase F G).boundaryFlag (intR t m) + = (closeBase F G).boundaryFlag (intR t m') + ∧ G.boundaryFlag m' + ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags := ⟨m, rfl, hm⟩ + unfold pairTailFun + rw [dite_eq_right hno, dite_eq_left h] + refine congrArg M₂.tail (Subtype.ext ?_) + exact (intR_inj ((closeBase F G).boundaryFlag_injective + h.choose_spec.1)).symm + +/-- **At a through label the chord is the edge.** The chain from a +through label's flag is the single edge, so the chord partner's flag +is the pairing partner. -/ +theorem boundaryFlag_chordInv_of_through {α : Type} + {W : Fragment α} (F : EdgeSubset W) (κ : F.RelTransitionSystem) + {i : α} (h : W.boundaryFlag i ∈ F.boundaryFlags) + (hthr : IsThroughLabel F i) : + W.boundaryFlag (chordInv F κ i) + = W.pairing (W.boundaryFlag i) := by + rw [boundaryFlag_chordInv F κ h] + exact κ.pathMatch_eq_pairing h hthr + +open Classical in +/-- **The prescribed directions flip along a through edge on the +left.** The chord is the edge, and a matching's two ends are +oppositely directed. -/ +theorem pairTailFun_flip_through_left {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + {κ₁ : (EdgeSubset.mk s₁ hc₁).RelTransitionSystem} + (M₁ : DirMatching (UsedLab (EdgeSubset.mk s₁ hc₁))) + (M₂ : DirMatching (UsedLab (EdgeSubset.mk s₂ hc₂))) + (c : (closeBase F G).Flag → Bool) + (hM₁ : ∀ a : UsedLab (EdgeSubset.mk s₁ hc₁), + (M₁.edge a).val = chordInv (EdgeSubset.mk s₁ hc₁) κ₁ a.val) + (m : Fin t) + (hm : F.boundaryFlag m ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags) + (hthr : IsThroughLabel (EdgeSubset.mk s₁ hc₁) m) : + pairTailFun hc₁ hc₂ M₁ M₂ c ((closeBase F G).pairing + ((closeBase F G).boundaryFlag (intL t m))) + = !pairTailFun hc₁ hc₂ M₁ M₂ c + ((closeBase F G).boundaryFlag (intL t m)) := by + have hbase : (closeBase F G).pairing + ((closeBase F G).boundaryFlag (intL t m)) + = (closeBase F G).boundaryFlag + (intL t (chordInv (EdgeSubset.mk s₁ hc₁) κ₁ m)) := by + rw [pairing_boundaryFlag_intL] + exact congrArg Sum.inl + (boundaryFlag_chordInv_of_through (EdgeSubset.mk s₁ hc₁) κ₁ hm + hthr).symm + have hedge : M₁.edge ⟨m, hm⟩ + = ⟨chordInv (EdgeSubset.mk s₁ hc₁) κ₁ m, + chordInv_mem (EdgeSubset.mk s₁ hc₁) κ₁ hm⟩ := + Subtype.ext (hM₁ ⟨m, hm⟩) + rw [hbase, pairTailFun_intL hc₁ hc₂ M₁ M₂ c _ + (chordInv_mem (EdgeSubset.mk s₁ hc₁) κ₁ hm), + pairTailFun_intL hc₁ hc₂ M₁ M₂ c m hm, ← hedge, + M₁.tail_flip] + +open Classical in +/-- **The prescribed directions flip along a through edge on the +right.** -/ +theorem pairTailFun_flip_through_right {t : ℕ} + {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + {κ₂ : (EdgeSubset.mk s₂ hc₂).RelTransitionSystem} + (M₁ : DirMatching (UsedLab (EdgeSubset.mk s₁ hc₁))) + (M₂ : DirMatching (UsedLab (EdgeSubset.mk s₂ hc₂))) + (c : (closeBase F G).Flag → Bool) + (hM₂ : ∀ b : UsedLab (EdgeSubset.mk s₂ hc₂), + (M₂.edge b).val = chordInv (EdgeSubset.mk s₂ hc₂) κ₂ b.val) + (m : Fin t) + (hm : G.boundaryFlag m ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags) + (hthr : IsThroughLabel (EdgeSubset.mk s₂ hc₂) m) : + pairTailFun hc₁ hc₂ M₁ M₂ c ((closeBase F G).pairing + ((closeBase F G).boundaryFlag (intR t m))) + = !pairTailFun hc₁ hc₂ M₁ M₂ c + ((closeBase F G).boundaryFlag (intR t m)) := by + have hbase : (closeBase F G).pairing + ((closeBase F G).boundaryFlag (intR t m)) + = (closeBase F G).boundaryFlag + (intR t (chordInv (EdgeSubset.mk s₂ hc₂) κ₂ m)) := by + rw [pairing_boundaryFlag_intR] + exact congrArg Sum.inr + (boundaryFlag_chordInv_of_through (EdgeSubset.mk s₂ hc₂) κ₂ hm + hthr).symm + have hedge : M₂.edge ⟨m, hm⟩ + = ⟨chordInv (EdgeSubset.mk s₂ hc₂) κ₂ m, + chordInv_mem (EdgeSubset.mk s₂ hc₂) κ₂ hm⟩ := + Subtype.ext (hM₂ ⟨m, hm⟩) + rw [hbase, pairTailFun_intR hc₁ hc₂ M₁ M₂ c _ + (chordInv_mem (EdgeSubset.mk s₂ hc₂) κ₂ hm), + pairTailFun_intR hc₁ hc₂ M₁ M₂ c m hm, ← hedge, + M₂.tail_flip] + +open Classical in +/-- **The prescribed directions alternate across a used cut.** This +is RS21's Eulerian position, read at the interface pair: the two +matchings' tails are opposite at every used label. -/ +theorem pairTailFun_cut {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (M₁ : DirMatching (UsedLab (EdgeSubset.mk s₁ hc₁))) + (M₂ : DirMatching (UsedLab (EdgeSubset.mk s₂ hc₂))) + (c : (closeBase F G).Flag → Bool) + (hb : ∀ i : Fin t, + F.boundaryFlag i ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags + ↔ G.boundaryFlag i ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags) + (halt : ∀ a : UsedLab (EdgeSubset.mk s₁ hc₁), + M₂.tail (usedLabInterfaceEquiv (EdgeSubset.mk s₁ hc₁) + (EdgeSubset.mk s₂ hc₂) hb a) + = !M₁.tail a) + (m : Fin t) + (hm : F.boundaryFlag m + ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags) : + pairTailFun hc₁ hc₂ M₁ M₂ c + ((closeBase F G).boundaryFlag (intR t m)) + = !pairTailFun hc₁ hc₂ M₁ M₂ c + ((closeBase F G).boundaryFlag (intL t m)) := by + rw [pairTailFun_intR hc₁ hc₂ M₁ M₂ c m ((hb m).mp hm), + pairTailFun_intL hc₁ hc₂ M₁ M₂ c m hm] + exact halt ⟨m, hm⟩ + +open Classical in +/-- **The flip at a pinned left label.** When the label's partner is +internal its direction is the orientation's own, so the boundary +flag's prescribed direction has only to be the chain direction's +opposite — which is what the matching's tail is. -/ +theorem flip_pinned_left {t : ℕ} {F G : Fragment (Fin t)} + {B : EdgeSubset (closeBase F G)} {κ : B.RelTransitionSystem} + (O : κ.Orientation) (g : (closeBase F G).Flag → Bool) + {A₁ : EdgeSubset F} {κ₁ : A₁.RelTransitionSystem} + (o₁ : κ₁.Orientation) + (hL : ∀ x : F.Flag, O.isOut (Sum.inl x) = o₁.isOut x) + (m : Fin t) (hint : cutFlagL F G m ∈ B.internalFlags) + (hg : g ((closeBase F G).boundaryFlag (intL t m)) + = !chainDir o₁ (F.boundaryFlag m)) : + (orientReplace O g).isOut (cutFlagL F G m) + = !(orientReplace O g).isOut + ((closeBase F G).boundaryFlag (intL t m)) := by + rw [isOut_orientReplace_internal O g hint, + isOut_orientReplace_of_not_internal O g + (boundaryFlag_not_internal B (intL t m)), hg, Bool.not_not] + change O.isOut ((closeBase F G).pairing + ((closeBase F G).boundaryFlag (intL t m))) = _ + rw [pairing_boundaryFlag_intL] + exact hL _ + +open Classical in +/-- **The flip at a pinned right label.** -/ +theorem flip_pinned_right {t : ℕ} {F G : Fragment (Fin t)} + {B : EdgeSubset (closeBase F G)} {κ : B.RelTransitionSystem} + (O : κ.Orientation) (g : (closeBase F G).Flag → Bool) + {A₂ : EdgeSubset G} {κ₂ : A₂.RelTransitionSystem} + (o₂ : κ₂.Orientation) + (hR : ∀ y : G.Flag, O.isOut (Sum.inr y) = o₂.isOut y) + (m : Fin t) (hint : cutFlagR F G m ∈ B.internalFlags) + (hg : g ((closeBase F G).boundaryFlag (intR t m)) + = !chainDir o₂ (G.boundaryFlag m)) : + (orientReplace O g).isOut (cutFlagR F G m) + = !(orientReplace O g).isOut + ((closeBase F G).boundaryFlag (intR t m)) := by + rw [isOut_orientReplace_internal O g hint, + isOut_orientReplace_of_not_internal O g + (boundaryFlag_not_internal B (intR t m)), hg, Bool.not_not] + change O.isOut ((closeBase F G).pairing + ((closeBase F G).boundaryFlag (intR t m))) = _ + rw [pairing_boundaryFlag_intR] + exact hR _ + +open Classical in +/-- **At a pinned left label the tail is the chain direction's +opposite.** -/ +theorem pairTailFun_pinned_left {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + {κ₁ : (EdgeSubset.mk s₁ hc₁).RelTransitionSystem} + (o₁ : κ₁.Orientation) + (M₁ : DirMatching (UsedLab (EdgeSubset.mk s₁ hc₁))) + (M₂ : DirMatching (UsedLab (EdgeSubset.mk s₂ hc₂))) + (c : (closeBase F G).Flag → Bool) + (hag₁ : ∀ a : UsedLab (EdgeSubset.mk s₁ hc₁), + ¬ IsThroughLabel (EdgeSubset.mk s₁ hc₁) a.val → + M₁.tail a = (cutMatching (EdgeSubset.mk s₁ hc₁) κ₁ o₁).tail a) + (m : Fin t) + (hm : F.boundaryFlag m ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags) + (hnt : ¬ IsThroughLabel (EdgeSubset.mk s₁ hc₁) m) : + pairTailFun hc₁ hc₂ M₁ M₂ c + ((closeBase F G).boundaryFlag (intL t m)) + = !chainDir o₁ (F.boundaryFlag m) := by + rw [pairTailFun_intL hc₁ hc₂ M₁ M₂ c m hm, hag₁ ⟨m, hm⟩ hnt] + exact cutMatching_tail_of_not_through (EdgeSubset.mk s₁ hc₁) κ₁ o₁ + ⟨m, hm⟩ hnt + +open Classical in +/-- **At a pinned right label the tail is the chain direction's +opposite.** -/ +theorem pairTailFun_pinned_right {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + {κ₂ : (EdgeSubset.mk s₂ hc₂).RelTransitionSystem} + (o₂ : κ₂.Orientation) + (M₁ : DirMatching (UsedLab (EdgeSubset.mk s₁ hc₁))) + (M₂ : DirMatching (UsedLab (EdgeSubset.mk s₂ hc₂))) + (c : (closeBase F G).Flag → Bool) + (hag₂ : ∀ b : UsedLab (EdgeSubset.mk s₂ hc₂), + ¬ IsThroughLabel (EdgeSubset.mk s₂ hc₂) b.val → + M₂.tail b = (cutMatching (EdgeSubset.mk s₂ hc₂) κ₂ o₂).tail b) + (m : Fin t) + (hm : G.boundaryFlag m ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags) + (hnt : ¬ IsThroughLabel (EdgeSubset.mk s₂ hc₂) m) : + pairTailFun hc₁ hc₂ M₁ M₂ c + ((closeBase F G).boundaryFlag (intR t m)) + = !chainDir o₂ (G.boundaryFlag m) := by + rw [pairTailFun_intR hc₁ hc₂ M₁ M₂ c m hm, hag₂ ⟨m, hm⟩ hnt] + exact cutMatching_tail_of_not_through (EdgeSubset.mk s₂ hc₂) κ₂ o₂ + ⟨m, hm⟩ hnt + +open Classical in +/-- **An unused label's partner label is unused.** The subset is +closed under the pairing, so a used partner would drag the label in +with it. -/ +theorem not_used_of_pairing {α : Type} + {W : Fragment α} {s : Finset W.Flag} + (hc : ∀ f ∈ s, W.pairing f ∈ s) {a b : α} + (h : W.pairing (W.boundaryFlag a) = W.boundaryFlag b) + (hu : W.boundaryFlag a ∉ (EdgeSubset.mk s hc).boundaryFlags) : + W.boundaryFlag b ∉ (EdgeSubset.mk s hc).boundaryFlags := by + intro hb + refine hu (boundaryFlag_mem_boundaryFlags ?_) + have hbs : W.boundaryFlag b ∈ s := + mem_flags_of_boundaryFlags _ hb + have := hc _ hbs + rwa [← h, W.pairing_invol] at this + +open Classical in +/-- **The prescribed directions flip at an unused left label.** Both +ends fall to the colouring, which alternates along every edge. -/ +theorem pairTailFun_flip_unused_left {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (M₁ : DirMatching (UsedLab (EdgeSubset.mk s₁ hc₁))) + (M₂ : DirMatching (UsedLab (EdgeSubset.mk s₂ hc₂))) + (c : (closeBase F G).Flag → Bool) + (hcol : ∀ f, c ((closeBase F G).pairing f) = !c f) (m : Fin t) + (hu : F.boundaryFlag m + ∉ (EdgeSubset.mk s₁ hc₁).boundaryFlags) : + pairTailFun hc₁ hc₂ M₁ M₂ c ((closeBase F G).pairing + ((closeBase F G).boundaryFlag (intL t m))) + = !pairTailFun hc₁ hc₂ M₁ M₂ c + ((closeBase F G).boundaryFlag (intL t m)) := by + rw [pairTailFun_of_not_used hc₁ hc₂ M₁ M₂ c _ + (by + rintro ⟨m', hx, hu'⟩ + rw [pairing_boundaryFlag_intL] at hx + exact not_used_of_pairing hc₁ (Sum.inl.inj hx) hu hu') + (by + rintro ⟨m', hx, -⟩ + rw [pairing_boundaryFlag_intL] at hx + exact Sum.inl_ne_inr hx), + pairTailFun_of_not_used hc₁ hc₂ M₁ M₂ c _ + (by + rintro ⟨m', hx, hu'⟩ + exact hu (by + rwa [intL_inj ((closeBase F G).boundaryFlag_injective hx)])) + (by + rintro ⟨m', hx, -⟩ + exact Sum.inl_ne_inr + ((closeBase F G).boundaryFlag_injective hx))] + exact hcol _ + +open Classical in +/-- **The prescribed directions flip at an unused right label.** -/ +theorem pairTailFun_flip_unused_right {t : ℕ} + {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (M₁ : DirMatching (UsedLab (EdgeSubset.mk s₁ hc₁))) + (M₂ : DirMatching (UsedLab (EdgeSubset.mk s₂ hc₂))) + (c : (closeBase F G).Flag → Bool) + (hcol : ∀ f, c ((closeBase F G).pairing f) = !c f) (m : Fin t) + (hu : G.boundaryFlag m + ∉ (EdgeSubset.mk s₂ hc₂).boundaryFlags) : + pairTailFun hc₁ hc₂ M₁ M₂ c ((closeBase F G).pairing + ((closeBase F G).boundaryFlag (intR t m))) + = !pairTailFun hc₁ hc₂ M₁ M₂ c + ((closeBase F G).boundaryFlag (intR t m)) := by + rw [pairTailFun_of_not_used hc₁ hc₂ M₁ M₂ c _ + (by + rintro ⟨m', hx, -⟩ + rw [pairing_boundaryFlag_intR] at hx + exact Sum.inr_ne_inl hx) + (by + rintro ⟨m', hx, hu'⟩ + rw [pairing_boundaryFlag_intR] at hx + exact not_used_of_pairing hc₂ (Sum.inr.inj hx) hu hu'), + pairTailFun_of_not_used hc₁ hc₂ M₁ M₂ c _ + (by + rintro ⟨m', hx, -⟩ + exact Sum.inr_ne_inl + ((closeBase F G).boundaryFlag_injective hx)) + (by + rintro ⟨m', hx, hu'⟩ + exact hu (by + rwa [intR_inj ((closeBase F G).boundaryFlag_injective hx)]))] + exact hcol _ + +open Classical in +/-- **The prescribed directions alternate across an unused cut.** -/ +theorem pairTailFun_cut_unused {t : ℕ} {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (M₁ : DirMatching (UsedLab (EdgeSubset.mk s₁ hc₁))) + (M₂ : DirMatching (UsedLab (EdgeSubset.mk s₂ hc₂))) + (c : (closeBase F G).Flag → Bool) + (hcut : ∀ m : Fin t, + c ((closeBase F G).boundaryFlag (intR t m)) + = !c ((closeBase F G).boundaryFlag (intL t m))) + (m : Fin t) + (hu₁ : F.boundaryFlag m ∉ (EdgeSubset.mk s₁ hc₁).boundaryFlags) + (hu₂ : G.boundaryFlag m + ∉ (EdgeSubset.mk s₂ hc₂).boundaryFlags) : + pairTailFun hc₁ hc₂ M₁ M₂ c + ((closeBase F G).boundaryFlag (intR t m)) + = !pairTailFun hc₁ hc₂ M₁ M₂ c + ((closeBase F G).boundaryFlag (intL t m)) := by + rw [pairTailFun_of_not_used hc₁ hc₂ M₁ M₂ c _ + (by + rintro ⟨m', hx, -⟩ + exact Sum.inr_ne_inl + ((closeBase F G).boundaryFlag_injective hx)) + (by + rintro ⟨m', hx, hu'⟩ + exact hu₂ (by + rwa [intR_inj ((closeBase F G).boundaryFlag_injective hx)])), + pairTailFun_of_not_used hc₁ hc₂ M₁ M₂ c _ + (by + rintro ⟨m', hx, hu'⟩ + exact hu₁ (by + rwa [intL_inj ((closeBase F G).boundaryFlag_injective hx)])) + (by + rintro ⟨m', hx, -⟩ + exact Sum.inl_ne_inr + ((closeBase F G).boundaryFlag_injective hx))] + exact hcut m + +/-- **An absent flag's partner is not internal.** -/ +theorem pairing_not_internal_of_not_mem {α : Type} + {W : Fragment α} (B : EdgeSubset W) {f : W.Flag} + (hf : f ∉ B.flags) : W.pairing f ∉ B.internalFlags := by + intro hx + exact hf (by + have := B.pairing_mem _ (mem_flags_of_internalFlags B hx) + rwa [W.pairing_invol] at this) + +open Classical in +/-- An unused left label's flag is absent from the joined subset. -/ +theorem inl_boundaryFlag_not_mem_closeJoin {t : ℕ} + {F G : Fragment (Fin t)} {s₁ : Finset F.Flag} + (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) (s₂ : Finset G.Flag) + (m : Fin t) + (hu : F.boundaryFlag m + ∉ (EdgeSubset.mk s₁ hc₁).boundaryFlags) : + (closeBase F G).boundaryFlag (intL t m) ∉ closeJoin s₁ s₂ := + fun hx => hu (boundaryFlag_mem_boundaryFlags + (inl_mem_joinParts.mp hx)) + +open Classical in +/-- An unused right label's flag is absent from the joined +subset. -/ +theorem inr_boundaryFlag_not_mem_closeJoin {t : ℕ} + {F G : Fragment (Fin t)} (s₁ : Finset F.Flag) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (m : Fin t) + (hu : G.boundaryFlag m + ∉ (EdgeSubset.mk s₂ hc₂).boundaryFlags) : + (closeBase F G).boundaryFlag (intR t m) ∉ closeJoin s₁ s₂ := + fun hx => hu (boundaryFlag_mem_boundaryFlags + (inr_mem_joinParts.mp hx)) + +open Classical in +/-- **The pair's prescribed orientation flips along every interface +edge.** Six cases: at a used label the matchings supply the +direction — the chord's two ends by `tail_flip`, the pinned end by +the tail's agreement with the chain — and at an unused label the cut +colouring does. -/ +theorem orientReplace_pairTailFun_flip {t : ℕ} + {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + {κ₁ : (EdgeSubset.mk s₁ hc₁).RelTransitionSystem} + (o₁ : κ₁.Orientation) + {κ₂ : (EdgeSubset.mk s₂ hc₂).RelTransitionSystem} + (o₂ : κ₂.Orientation) + (M₁ : DirMatching (UsedLab (EdgeSubset.mk s₁ hc₁))) + (M₂ : DirMatching (UsedLab (EdgeSubset.mk s₂ hc₂))) + (c : (closeBase F G).Flag → Bool) + (hcol : ∀ f, c ((closeBase F G).pairing f) = !c f) + (hM₁ : ∀ a : UsedLab (EdgeSubset.mk s₁ hc₁), + (M₁.edge a).val = chordInv (EdgeSubset.mk s₁ hc₁) κ₁ a.val) + (hM₂ : ∀ b : UsedLab (EdgeSubset.mk s₂ hc₂), + (M₂.edge b).val = chordInv (EdgeSubset.mk s₂ hc₂) κ₂ b.val) + (hag₁ : ∀ a : UsedLab (EdgeSubset.mk s₁ hc₁), + ¬ IsThroughLabel (EdgeSubset.mk s₁ hc₁) a.val → + M₁.tail a = (cutMatching (EdgeSubset.mk s₁ hc₁) κ₁ o₁).tail a) + (hag₂ : ∀ b : UsedLab (EdgeSubset.mk s₂ hc₂), + ¬ IsThroughLabel (EdgeSubset.mk s₂ hc₂) b.val → + M₂.tail b = (cutMatching (EdgeSubset.mk s₂ hc₂) κ₂ o₂).tail b) + {κ : (EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂)).RelTransitionSystem} + (O : κ.Orientation) + (hL : ∀ x : F.Flag, O.isOut (Sum.inl x) = o₁.isOut x) + (hR : ∀ y : G.Flag, O.isOut (Sum.inr y) = o₂.isOut y) + (ℓ : Fin (0 + t) ⊕ Fin (t + 0)) : + (orientReplace O (pairTailFun hc₁ hc₂ M₁ M₂ c)).isOut + ((closeBase F G).pairing ((closeBase F G).boundaryFlag ℓ)) + = !(orientReplace O (pairTailFun hc₁ hc₂ M₁ M₂ c)).isOut + ((closeBase F G).boundaryFlag ℓ) := by + cases ℓ with + | inl i => + rw [← intL_cast i] + by_cases hm : F.boundaryFlag (Fin.cast (by omega) i) + ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags + · by_cases hthr : IsThroughLabel (EdgeSubset.mk s₁ hc₁) + (Fin.cast (by omega) i) + · have hpart : (closeBase F G).pairing + ((closeBase F G).boundaryFlag + (intL t (Fin.cast (by omega) i))) + = (closeBase F G).boundaryFlag (intL t + (chordInv (EdgeSubset.mk s₁ hc₁) κ₁ + (Fin.cast (by omega) i))) := by + rw [pairing_boundaryFlag_intL] + exact congrArg Sum.inl + (boundaryFlag_chordInv_of_through + (EdgeSubset.mk s₁ hc₁) κ₁ hm hthr).symm + rw [isOut_orientReplace_of_not_internal O _ + (by rw [hpart]; exact boundaryFlag_not_internal _ _), + isOut_orientReplace_of_not_internal O _ + (boundaryFlag_not_internal _ _)] + exact pairTailFun_flip_through_left hc₁ hc₂ M₁ M₂ c hM₁ _ + hm hthr + · exact flip_pinned_left O _ o₁ hL _ + (internal_cutFlagL hc₁ hc₂ _ hm hthr) + (pairTailFun_pinned_left hc₁ hc₂ o₁ M₁ M₂ c hag₁ _ hm + hthr) + · rw [isOut_orientReplace_of_not_internal O _ + (pairing_not_internal_of_not_mem _ + (inl_boundaryFlag_not_mem_closeJoin hc₁ s₂ _ hm)), + isOut_orientReplace_of_not_internal O _ + (boundaryFlag_not_internal _ _)] + exact pairTailFun_flip_unused_left hc₁ hc₂ M₁ M₂ c hcol _ hm + | inr j => + rw [← intR_cast j] + by_cases hm : G.boundaryFlag (Fin.cast (by omega) j) + ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags + · by_cases hthr : IsThroughLabel (EdgeSubset.mk s₂ hc₂) + (Fin.cast (by omega) j) + · have hpart : (closeBase F G).pairing + ((closeBase F G).boundaryFlag + (intR t (Fin.cast (by omega) j))) + = (closeBase F G).boundaryFlag (intR t + (chordInv (EdgeSubset.mk s₂ hc₂) κ₂ + (Fin.cast (by omega) j))) := by + rw [pairing_boundaryFlag_intR] + exact congrArg Sum.inr + (boundaryFlag_chordInv_of_through + (EdgeSubset.mk s₂ hc₂) κ₂ hm hthr).symm + rw [isOut_orientReplace_of_not_internal O _ + (by rw [hpart]; exact boundaryFlag_not_internal _ _), + isOut_orientReplace_of_not_internal O _ + (boundaryFlag_not_internal _ _)] + exact pairTailFun_flip_through_right hc₁ hc₂ M₁ M₂ c hM₂ _ + hm hthr + · exact flip_pinned_right O _ o₂ hR _ + (internal_cutFlagR hc₁ hc₂ _ hm hthr) + (pairTailFun_pinned_right hc₁ hc₂ o₂ M₁ M₂ c hag₂ _ hm + hthr) + · rw [isOut_orientReplace_of_not_internal O _ + (pairing_not_internal_of_not_mem _ + (inr_boundaryFlag_not_mem_closeJoin s₁ hc₂ _ hm)), + isOut_orientReplace_of_not_internal O _ + (boundaryFlag_not_internal _ _)] + exact pairTailFun_flip_unused_right hc₁ hc₂ M₁ M₂ c hcol _ hm + +open Classical in +/-- **The pair's prescribed orientation alternates across every +interface pair.** At a used label this is the Eulerian position of +the two matchings; at an unused one, the cut colouring. -/ +theorem orientReplace_pairTailFun_cut {t : ℕ} + {F G : Fragment (Fin t)} + {s₁ : Finset F.Flag} (hc₁ : ∀ f ∈ s₁, F.pairing f ∈ s₁) + {s₂ : Finset G.Flag} (hc₂ : ∀ f ∈ s₂, G.pairing f ∈ s₂) + (M₁ : DirMatching (UsedLab (EdgeSubset.mk s₁ hc₁))) + (M₂ : DirMatching (UsedLab (EdgeSubset.mk s₂ hc₂))) + (c : (closeBase F G).Flag → Bool) + (hcut : ∀ m : Fin t, + c ((closeBase F G).boundaryFlag (intR t m)) + = !c ((closeBase F G).boundaryFlag (intL t m))) + (hb : ∀ i : Fin t, + F.boundaryFlag i ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags + ↔ G.boundaryFlag i ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags) + (halt : ∀ a : UsedLab (EdgeSubset.mk s₁ hc₁), + M₂.tail (usedLabInterfaceEquiv (EdgeSubset.mk s₁ hc₁) + (EdgeSubset.mk s₂ hc₂) hb a) + = !M₁.tail a) + {κ : (EdgeSubset.mk (closeJoin s₁ s₂) + (closeJoin_pairing_mem hc₁ hc₂)).RelTransitionSystem} + (O : κ.Orientation) (m : Fin t) : + (orientReplace O (pairTailFun hc₁ hc₂ M₁ M₂ c)).isOut + ((closeBase F G).boundaryFlag (intR t m)) + = !(orientReplace O (pairTailFun hc₁ hc₂ M₁ M₂ c)).isOut + ((closeBase F G).boundaryFlag (intL t m)) := by + rw [isOut_orientReplace_of_not_internal O _ + (boundaryFlag_not_internal _ _), + isOut_orientReplace_of_not_internal O _ + (boundaryFlag_not_internal _ _)] + by_cases hm : F.boundaryFlag m + ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags + · exact pairTailFun_cut hc₁ hc₂ M₁ M₂ c hb halt m hm + · exact pairTailFun_cut_unused hc₁ hc₂ M₁ M₂ c hcut m hm + (fun hx => hm ((hb m).mpr hx)) + +/-- **The lift is balanced at the top cut.** The glue joins the two +cut flags' partners into one edge, so a pairing-closed stage subset +takes them together — and the lift then takes both cut flags or +neither. -/ +theorem cutBalanced_top_liftSubsetOpen {t : ℕ} + {V : Fragment (Fin (0 + t) ⊕ Fin (t + 0))} {i j : Fin (0 + t) + ⊕ Fin (t + 0)} (hij : i ≠ j) + (hop : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (s' : Finset (SurvivingFlag V i j)) + (hcs : ∀ f ∈ s', Fragment.rewire hop f ∈ s') : + V.boundaryFlag i ∈ liftSubsetOpen hop s' + ↔ V.boundaryFlag j ∈ liftSubsetOpen hop s' := by + rw [boundaryFlagI_mem_liftOpen_iff hij, boundaryFlagJ_mem_liftOpen_iff hij] + constructor + · intro hI + have h := hcs _ hI + rwa [Fragment.rewire_eq_partnerSurvJ hop _ + (V.pairing_invol _)] at h + · intro hJ + have hne : V.pairing (V.pairing (V.boundaryFlag j)) + ≠ V.boundaryFlag i := by + rw [V.pairing_invol] + exact fun hx => hij (V.boundaryFlag_injective hx).symm + have h := hcs _ hJ + rwa [Fragment.rewire_eq_partnerSurvI hop _ hne + (V.pairing_invol _)] at h + +/-- Membership survives the transport along a fragment equality. -/ +theorem mem_flagsOfEq {L : Type} {V₁ V₂ : Fragment L} (hV : V₁ = V₂) + (s : Finset V₁.Flag) (f : V₁.Flag) : + flagOfEq hV f ∈ flagsOfEq V₁ V₂ hV s ↔ f ∈ s := by + subst hV + exact Iff.rfl + +/-- **A stage boundary flag is in the transported subset exactly +when the base's is in the lift.** -/ +theorem mem_stage_boundaryFlag_iff (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (s' : Finset (SurvivingFlag V (cutL n) (cutR n))) + (bl : Fin (0 + n) ⊕ Fin (n + 0)) : + ((stepFragment n V).boundaryFlag bl ∈ flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) s') + ↔ (V.boundaryFlag ((interfaceStepEquiv 0 n 0).symm bl).val + ∈ liftSubsetOpen hop s') := by + rw [boundaryFlag_stepFragment_open n V hop bl] + exact (mem_flagsOfEq (gluePair_eq_open n V hop) s' _).trans + (surviving_val_mem_liftOpen_iff hop s' _).symm + +/-- **The lift of a balanced stage subset is balanced.** The top cut +is balanced by the glue's own edge, and each lower pair is the +stage's own. -/ +theorem cutBalanced_liftSubsetOpen (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (s' : Finset (SurvivingFlag V (cutL n) (cutR n))) + (hcs : ∀ f ∈ s', Fragment.rewire hop f ∈ s') + (hbal : CutBalanced (stepFragment n V) + (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) s')) : + CutBalanced V (liftSubsetOpen hop s') := by + intro m + refine Fin.lastCases ?_ (fun b => ?_) m + · rw [intL_last, intR_last] + exact cutBalanced_top_liftSubsetOpen (cutL_ne_cutR n) hop s' hcs + · have hb := (mem_stage_boundaryFlag_iff n V hop s' + (intL n b)).symm.trans ((hbal b).trans + (mem_stage_boundaryFlag_iff n V hop s' (intR n b))) + rw [interfaceStepEquiv_symm_intL n b, + interfaceStepEquiv_symm_intR n b] at hb + exact hb + +/-- **A stage boundary flag is in the stage's subset exactly when the +base's is in the lift**, at a closing cut. -/ +theorem mem_stage_boundaryFlag_iff_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (s' : Finset (SurvivingFlag V (cutL n) (cutR n))) (b : Bool) + (bl : Fin (0 + n) ⊕ Fin (n + 0)) : + ((stepFragment n V).boundaryFlag bl ∈ flagsOfEq + (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) s') + ↔ (V.boundaryFlag ((interfaceStepEquiv 0 n 0).symm bl).val + ∈ liftSubsetClosed s' b) := by + rw [boundaryFlag_stepFragment_closed n V hcl bl] + exact (mem_flagsOfEq (gluePair_eq_closed n V hcl) s' _).trans + (surviving_val_mem_liftClosed_iff s' b _).symm + +/-- **The lift of a balanced stage subset is balanced**, at a closing +cut: the cut's own pair is in or out together, by the bit. -/ +theorem cutBalanced_liftSubsetClosed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (s' : Finset (SurvivingFlag V (cutL n) (cutR n))) (b : Bool) + (hbal : CutBalanced (stepFragment n V) + (flagsOfEq + (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) s')) : + CutBalanced V (liftSubsetClosed s' b) := by + intro m + refine Fin.lastCases ?_ (fun c => ?_) m + · rw [intL_last, intR_last, + boundaryFlagI_mem_liftClosed_iff (cutL_ne_cutR n) s' b, + boundaryFlagJ_mem_liftClosed_iff (cutL_ne_cutR n) s' b] + · have hb := (mem_stage_boundaryFlag_iff_closed n V hcl s' b + (intL n c)).symm.trans ((hbal c).trans + (mem_stage_boundaryFlag_iff_closed n V hcl s' b (intR n c))) + rw [interfaceStepEquiv_symm_intL n c, + interfaceStepEquiv_symm_intR n c] at hb + exact hb + +open Classical in +/-- **The ledger's step keeps the balance.** -/ +theorem cutBalanced_stepData (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) (D : StageData (n + 1) V) + (hbal : CutBalanced V D.sub.flags) : + CutBalanced (stepFragment n V) (stepData n V D).sub.flags := by + intro b + have hlift : liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) D.sub.flags) = D.sub.flags := + liftSubsetOpen_dropSubset (cutL_ne_cutR n) hop D.sub.flags + D.sub.pairing_mem + have key := fun bl => mem_stage_boundaryFlag_iff n V hop + (V.dropSubset (cutL n) (cutR n) D.sub.flags) bl + rw [stepData_sub_flags_open n V D hop] + refine (key (intL n b)).trans (Iff.trans ?_ (key (intR n b)).symm) + rw [hlift, interfaceStepEquiv_symm_intL n b, + interfaceStepEquiv_symm_intR n b] + exact hbal b.castSucc + +open Classical in +/-- **The ledger's step keeps the balance**, at a closing cut. -/ +theorem cutBalanced_stepData_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) (D : StageData (n + 1) V) + (hbal : CutBalanced V D.sub.flags) : + CutBalanced (stepFragment n V) (stepData n V D).sub.flags := by + intro c + have hlift : liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) D.sub.flags) + (decide (V.boundaryFlag (cutL n) ∈ D.sub.flags)) + = D.sub.flags := + liftSubsetClosed_dropSubset (cutL_ne_cutR n) hcl D.sub.flags + D.sub.pairing_mem + have key := fun bl => mem_stage_boundaryFlag_iff_closed n V hcl + (V.dropSubset (cutL n) (cutR n) D.sub.flags) + (decide (V.boundaryFlag (cutL n) ∈ D.sub.flags)) bl + rw [stepData_sub_flags_closed n V D hcl] + refine (key (intL n c)).trans (Iff.trans ?_ (key (intR n c)).symm) + rw [hlift, interfaceStepEquiv_symm_intL n c, + interfaceStepEquiv_symm_intR n c] + exact hbal c.castSucc + +open Classical in +/-- **The summand a single datum computes.** The total form of the +colouring sum: zero where the subset does not carry the state. -/ +noncomputable def edgeTermOf {α : Type} + {V : Fragment α} {k ℓ : ℕ} (h : MixedFunctional k ℓ) + {s : Finset V.Flag} {hc : ∀ f ∈ s, V.pairing f ∈ s} + (d : Σ κ : (EdgeSubset.mk s hc).RelTransitionSystem, + κ.Orientation) (st : GenBoundaryState k ℓ α) (C : ℕ) : ℂ := + if hbnd : genBoundarySubsetMatches V s st then + ((-1 : ℂ) ^ C) * (EdgeSubset.mk s hc).edgeSum h st hbnd d.2 + else 0 + +open Classical in +/-- **The family's summand is its datum's.** -/ +theorem edgeTermAt_eq_edgeTermOf {α : Type} [LinearOrder α] + {V : Fragment α} {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (𝒟 : DataFamily V) + (st : GenBoundaryState k ℓ α) {s : Finset V.Flag} + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) (C : ℕ) : + edgeTermAt h 𝒟 st s C = edgeTermOf h (𝒟 s hc hE hne) st C := by + unfold edgeTermOf + split_ifs with hbnd + · exact edgeTermAt_pos h 𝒟 st hc hbnd hE hne C + · exact edgeTermAt_eq_zero_of_not_matches h 𝒟 st hbnd C + +open Classical in +/-- **The datum's summand transports along an equality of +subsets.** -/ +theorem edgeTermOf_ofEq {α : Type} {V : Fragment α} + {k ℓ : ℕ} (h : MixedFunctional k ℓ) {s s' : Finset V.Flag} + {hc : ∀ f ∈ s, V.pairing f ∈ s} + {hc' : ∀ f ∈ s', V.pairing f ∈ s'} + (hu : (EdgeSubset.mk s hc) = EdgeSubset.mk s' hc') + (d : Σ κ : (EdgeSubset.mk s hc).RelTransitionSystem, + κ.Orientation) (st : GenBoundaryState k ℓ α) (C : ℕ) : + edgeTermOf h ⟨relOfEq hu d.1, orientOfEq hu d.2⟩ st C + = edgeTermOf h d st C := by + have hss : s = s' := congrArg EdgeSubset.flags hu + subst hss + rfl + +/-- **The join carries a diagonal state exactly when its halves carry +the state.** -/ +theorem matches_closeJoin_iff {k ℓ : ℕ} {t : ℕ} + {F G : Fragment (Fin t)} (s₁ : Finset F.Flag) + (s₂ : Finset G.Flag) (x : GenBoundaryState k ℓ (Fin t)) : + genBoundarySubsetMatches (closeBase F G) (closeJoin s₁ s₂) + (diagOf t x) + ↔ genBoundarySubsetMatches F s₁ x + ∧ genBoundarySubsetMatches G s₂ x := by + constructor + · intro hm + refine ⟨fun i => ?_, fun i => ?_⟩ + · exact (inl_mem_joinParts (s₁ := s₁) (s₂ := s₂) + (f := F.boundaryFlag i)).symm.trans (hm (intL t i)) + · exact (inr_mem_joinParts (s₁ := s₁) (s₂ := s₂) + (f := G.boundaryFlag i)).symm.trans (hm (intR t i)) + · rintro ⟨h₁, h₂⟩ a + cases a with + | inl i => + exact (inl_mem_joinParts (s₁ := s₁) (s₂ := s₂) + (f := F.boundaryFlag (Fin.cast (by omega) i))).trans + (h₁ (Fin.cast (by omega) i)) + | inr j => + exact (inr_mem_joinParts (s₁ := s₁) (s₂ := s₂) + (f := G.boundaryFlag (Fin.cast (by omega) j))).trans + (h₂ (Fin.cast (by omega) j)) + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseTrip.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseTrip.lean new file mode 100644 index 0000000000..d34df9d51d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseTrip.lean @@ -0,0 +1,1620 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseLift + +/-! +# The interface round trip + +At an open cut the lift is a left inverse of the drop, and the family +pushed back down is the family itself. Iterating over the interface +gives the composition's sum in terms of the base's own subsets. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + +open Fragment +/-- The lexicographic order on the interface's label type. -/ +@[reducible] local instance tripBaseOrder (n : ℕ) : + LinearOrder (Fin (0 + n) ⊕ Fin (n + 0)) := + sumLexLinearOrder _ _ + +/-- The same order one stage up. -/ +@[reducible] local instance tripOrderSucc (n : ℕ) : + LinearOrder (Fin (0 + n + 1) ⊕ Fin (n + 1 + 0)) := + sumLexLinearOrder _ _ + +/-- The order a stage's surviving labels carry. -/ +@[reducible] local instance tripSurvOrder (n : ℕ) : + LinearOrder (SurvivingLabel + (Fin (0 + n + 1) ⊕ Fin (n + 1 + 0)) (cutL n) (cutR n)) := + sumLexSubtypeLinearOrder _ _ _ + +/-- The order the composition's own label type carries. -/ +@[reducible] local instance tripTopOrder : + LinearOrder (Fin 0 ⊕ Fin 0) := + sumLexLinearOrder _ _ + +/-! ## An open cut loses nothing + +At an open cut the lift is a left inverse of the drop, so the drop is +injective on subsets closed under the pairing. This is why a fibre +is a singleton when no cut on the way to it closes. +-/ + +open Classical in +/-- **A closed subset matching a diagonal state has a rewire-closed +drop.** So the terms the identity reads are the reached ones, and +off them everything vanishes. -/ +theorem dropSubset_rewire_closed_of_matches {k ℓ : ℕ} (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (s : Finset V.Flag) (hc : ∀ f ∈ s, V.pairing f ∈ s) + (x : Fin (n + 1) → (Fin k ⊕ Fin (2 * ℓ))) + (hm : genBoundarySubsetMatches V s (diagOf (n + 1) x)) : + ∀ f ∈ V.dropSubset (cutL n) (cutR n) s, + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hop).pairing f + ∈ V.dropSubset (cutL n) (cutR n) s := by + have hlift : liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s) = s := + liftSubsetOpen_dropSubset (cutL_ne_cutR n) hop s hc + have hcl : ∀ f ∈ liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s), + V.pairing f ∈ liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s) := by + rw [hlift]; exact hc + refine rewire_closed_of_liftOpen_closed (cutL_ne_cutR n) hop + (V.dropSubset (cutL n) (cutR n) s) + (stageState n (diagOf n (fun a => x a.castSucc))) + (x (Fin.last n)) hcl ?_ + rw [hlift, ← diagOf_succ n x] + exact hm + +open Classical in +/-- **The drop matches the stage's diagonal state.** So the +boundary constraint descends the interface along with the subset. -/ +theorem dropSubset_matches_of_matches {k ℓ : ℕ} (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (s : Finset V.Flag) (hc : ∀ f ∈ s, V.pairing f ∈ s) + (x : Fin (n + 1) → (Fin k ⊕ Fin (2 * ℓ))) + (hm : genBoundarySubsetMatches V s (diagOf (n + 1) x)) : + genBoundarySubsetMatches + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.dropSubset (cutL n) (cutR n) s) + (stageState n (diagOf n (fun a => x a.castSucc))) := by + refine genBoundarySubsetMatches_glued_of_liftOpen + (cutL_ne_cutR n) hop (V.dropSubset (cutL n) (cutR n) s) _ + (x (Fin.last n)) (x (Fin.last n)) ?_ + rw [liftSubsetOpen_dropSubset (cutL_ne_cutR n) hop s hc, + ← diagOf_succ n x] + exact hm + +/-- The boundary constraint transports along an equality of +fragments. -/ +theorem genBoundarySubsetMatches_flagsOfEq {k ℓ : ℕ} {L : Type} + {V₁ V₂ : Fragment L} (hV : V₁ = V₂) (s : Finset V₁.Flag) + (st : GenBoundaryState k ℓ L) + (h : genBoundarySubsetMatches V₁ s st) : + genBoundarySubsetMatches V₂ (flagsOfEq V₁ V₂ hV s) st := by + subst hV; exact h + +open Classical in +/-- **The stage subset matches the stage's diagonal state.** This is +`dropSubset_matches_of_matches` read at the stage fragment, across the +relabel that renumbers the surviving labels. -/ +theorem stage_matches_of_matches {k ℓ : ℕ} (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (s : Finset V.Flag) (hc : ∀ f ∈ s, V.pairing f ∈ s) + (x : Fin (n + 1) → (Fin k ⊕ Fin (2 * ℓ))) + (hm : genBoundarySubsetMatches V s (diagOf (n + 1) x)) : + genBoundarySubsetMatches (stepFragment n V) + (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) + (V.dropSubset (cutL n) (cutR n) s)) + (diagOf n (fun a => x a.castSucc)) := by + refine (relabel_genBoundarySubsetMatches_iff + (interfaceStepEquiv 0 n 0) _ + (diagOf n (fun a => x a.castSucc))).mpr ?_ + exact genBoundarySubsetMatches_flagsOfEq + (gluePair_eq_open n V hop) _ _ + (dropSubset_matches_of_matches n V hop s hc x hm) + +open Classical in +/-- **One subset is enough for the directions**, at an open cut. -/ +theorem isOut_unglueDataOpen_congr_at {α : Type} [LinearOrder α] + {V : Fragment α} {i j : α} (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (𝒟₁ 𝒟₂ : DataFamily (V.gluePairOpen i j hij hopen)) + {s : Finset V.Flag} + (hm : ∀ (hct : ∀ f ∈ V.dropSubset i j s, + (V.gluePairOpen i j hij hopen).pairing f + ∈ V.dropSubset i j s) + (hEt : (EdgeSubset.mk (V.dropSubset i j s) hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).Eulerian) + (hnet : Nonempty (EdgeSubset.mk (V.dropSubset i j s) hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).CanonData) + (g : SurvivingFlag V i j), + (∀ ℓ, g ≠ (V.gluePairOpen i j hij hopen).boundaryFlag ℓ) → + (𝒟₁ _ hct hEt hnet).2.isOut g = (𝒟₂ _ hct hEt hnet).2.isOut g) + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc : EdgeSubset V).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc : EdgeSubset V).CanonData) + (f : V.Flag) (hfb : ∀ a, f ≠ V.boundaryFlag a) : + (unglueDataOpen hij hopen 𝒟₁ s hc hE hne).2.isOut f + = (unglueDataOpen hij hopen 𝒟₂ s hc hE hne).2.isOut f := by + have h1 : f ≠ V.boundaryFlag i := hfb i + have h2 : f ≠ V.boundaryFlag j := hfb j + unfold unglueDataOpen + by_cases hag : ∀ f ∈ V.dropSubset i j s, + (V.gluePairOpen i j hij hopen).pairing f + ∈ V.dropSubset i j s + · rw [dite_eq_left hag, dite_eq_left hag, isOut_orientOfEq, isOut_orientOfEq] + refine Eq.trans (unglueIsOut_of_surviving _ f ⟨h1, h2⟩) ?_ + refine Eq.trans ?_ (unglueIsOut_of_surviving _ f ⟨h1, h2⟩).symm + exact hm _ _ _ _ (fun ℓ hx => hfb ℓ.val (congrArg Subtype.val hx)) + · rw [dite_eq_right hag, dite_eq_right hag] + +open Classical in +/-- **One subset is enough for the directions**, at a closing +cut. -/ +theorem isOut_unglueDataClosed_congr_at {α : Type} [LinearOrder α] + {V : Fragment α} {i j : α} (hij : i ≠ j) + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (𝒟₁ 𝒟₂ : DataFamily (V.gluePairClosed i j hclosed)) + {s : Finset V.Flag} + (hm : ∀ (hct : ∀ f ∈ V.dropSubset i j s, + (V.gluePairClosed i j hclosed).pairing f + ∈ V.dropSubset i j s) + (hEt : (EdgeSubset.mk (V.dropSubset i j s) hct : + EdgeSubset (V.gluePairClosed i j hclosed)).Eulerian) + (hnet : Nonempty (EdgeSubset.mk (V.dropSubset i j s) hct : + EdgeSubset (V.gluePairClosed i j hclosed)).CanonData) + (g : SurvivingFlag V i j), + (∀ ℓ, g ≠ (V.gluePairClosed i j hclosed).boundaryFlag ℓ) → + (𝒟₁ _ hct hEt hnet).2.isOut g = (𝒟₂ _ hct hEt hnet).2.isOut g) + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc : EdgeSubset V).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc : EdgeSubset V).CanonData) + (f : V.Flag) (hfb : ∀ a, f ≠ V.boundaryFlag a) : + (unglueDataClosed hij hclosed 𝒟₁ s hc hE hne).2.isOut f + = (unglueDataClosed hij hclosed 𝒟₂ s hc hE hne).2.isOut f := by + have h1 : f ≠ V.boundaryFlag i := hfb i + have h2 : f ≠ V.boundaryFlag j := hfb j + unfold unglueDataClosed + rw [isOut_orientOfEq, isOut_orientOfEq] + refine Eq.trans (unglueIsOut_of_surviving _ f ⟨h1, h2⟩) ?_ + refine Eq.trans ?_ (unglueIsOut_of_surviving _ f ⟨h1, h2⟩).symm + exact hm _ _ _ _ (fun ℓ hx => hfb ℓ.val (congrArg Subtype.val hx)) + +open Classical in +/-- **One subset is enough for the directions**, under a +transport. -/ +theorem isOut_dataOfEq_congr_at {L : Type} [LinearOrder L] + {V₁ V₂ : Fragment L} (h : V₁ = V₂) (𝒟₁ 𝒟₂ : DataFamily V₂) + (s : Finset V₁.Flag) + (hm : ∀ (hc' : ∀ f ∈ flagsOfEq V₁ V₂ h s, + V₂.pairing f ∈ flagsOfEq V₁ V₂ h s) + (hE' : (EdgeSubset.mk (flagsOfEq V₁ V₂ h s) hc').Eulerian) + (hne' : Nonempty + (EdgeSubset.mk (flagsOfEq V₁ V₂ h s) hc').CanonData) + (g : V₂.Flag), (∀ ℓ, g ≠ V₂.boundaryFlag ℓ) → + (𝒟₁ _ hc' hE' hne').2.isOut g = (𝒟₂ _ hc' hE' hne').2.isOut g) + (hc : ∀ f ∈ s, V₁.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) (f : V₁.Flag) + (hfb : ∀ ℓ, f ≠ V₁.boundaryFlag ℓ) : + (dataOfEq h 𝒟₁ s hc hE hne).2.isOut f + = (dataOfEq h 𝒟₂ s hc hE hne).2.isOut f := by + subst h + exact hm hc hE hne f hfb + +open Classical in +/-- **One subset is enough for the directions**, under a relabel. -/ +theorem isOut_relabelDataDown_congr_at {α' β' : Type} + [LinearOrder α'] [LinearOrder β'] (e : α' ≃o β') + {W' : Fragment α'} (𝒟₁ 𝒟₂ : DataFamily (W'.relabel e.toEquiv)) + (s : Finset W'.Flag) + (hm : ∀ (hc' : ∀ f ∈ s, (W'.relabel e.toEquiv).pairing f ∈ s) + (hE' : (EdgeSubset.mk s hc' : + EdgeSubset (W'.relabel e.toEquiv)).Eulerian) + (hne' : Nonempty (EdgeSubset.mk s hc' : + EdgeSubset (W'.relabel e.toEquiv)).CanonData) + (g : W'.Flag), + (∀ b, g ≠ (W'.relabel e.toEquiv).boundaryFlag b) → + (𝒟₁ s hc' hE' hne').2.isOut g = (𝒟₂ s hc' hE' hne').2.isOut g) + (hc : ∀ f ∈ s, W'.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) (f : W'.Flag) + (hfb : ∀ a, f ≠ W'.boundaryFlag a) : + (relabelDataDown e 𝒟₁ s hc hE hne).2.isOut f + = (relabelDataDown e 𝒟₂ s hc hE hne).2.isOut f := + hm hc _ _ f (fun b hx => hfb (e.symm b) (by + rw [hx, ← relabel_boundaryFlag_apply e.toEquiv (e.symm b)] + exact congrArg (W'.relabel e.toEquiv).boundaryFlag + (e.apply_symm_apply b).symm)) + +open Classical in +/-- **One subset is enough for the directions**, for a whole stage of +the push at an open cut. -/ +theorem isOut_stepDataDown_congr_at_open (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (𝒟₁ 𝒟₂ : DataFamily (stepFragment n V)) {s : Finset V.Flag} + (hm : ∀ (t : Finset (stepFragment n V).Flag), + t = flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) + (V.dropSubset (cutL n) (cutR n) s) → + ∀ (hct : ∀ f ∈ t, (stepFragment n V).pairing f ∈ t) + (hEt : (EdgeSubset.mk t hct).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct).CanonData) + (g : (stepFragment n V).Flag), + (∀ b, g ≠ (stepFragment n V).boundaryFlag b) → + (𝒟₁ t hct hEt hnet).2.isOut g = (𝒟₂ t hct hEt hnet).2.isOut g) + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) (f : V.Flag) + (hfb : ∀ a, f ≠ V.boundaryFlag a) : + (stepDataDown n V 𝒟₁ s hc hE hne).2.isOut f + = (stepDataDown n V 𝒟₂ s hc hE hne).2.isOut f := by + unfold stepDataDown + rw [dite_eq_right hop, dite_eq_right hop] + refine isOut_unglueDataOpen_congr_at (cutL_ne_cutR n) hop _ _ + ?_ hc hE hne f hfb + intro hct hEt hnet g hgb + refine isOut_dataOfEq_congr_at (gluePair_eq_open n V hop) _ _ + (V.dropSubset (cutL n) (cutR n) s) ?_ hct hEt hnet g hgb + intro hc' hE' hne' g' hgb' + exact isOut_relabelDataDown_congr_at (stepIso n) 𝒟₁ 𝒟₂ _ + (hm _ rfl) hc' hE' hne' g' hgb' + +open Classical in +/-- **One subset is enough for the directions**, for a whole stage of +the push at a closing cut. -/ +theorem isOut_stepDataDown_congr_at_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (𝒟₁ 𝒟₂ : DataFamily (stepFragment n V)) {s : Finset V.Flag} + (hm : ∀ (t : Finset (stepFragment n V).Flag), + t = flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) s) → + ∀ (hct : ∀ f ∈ t, (stepFragment n V).pairing f ∈ t) + (hEt : (EdgeSubset.mk t hct).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct).CanonData) + (g : (stepFragment n V).Flag), + (∀ b, g ≠ (stepFragment n V).boundaryFlag b) → + (𝒟₁ t hct hEt hnet).2.isOut g = (𝒟₂ t hct hEt hnet).2.isOut g) + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) (f : V.Flag) + (hfb : ∀ a, f ≠ V.boundaryFlag a) : + (stepDataDown n V 𝒟₁ s hc hE hne).2.isOut f + = (stepDataDown n V 𝒟₂ s hc hE hne).2.isOut f := by + unfold stepDataDown + rw [dite_eq_left hcl, dite_eq_left hcl] + refine isOut_unglueDataClosed_congr_at (cutL_ne_cutR n) hcl _ _ + ?_ hc hE hne f hfb + intro hct hEt hnet g hgb + refine isOut_dataOfEq_congr_at (gluePair_eq_closed n V hcl) _ _ + (V.dropSubset (cutL n) (cutR n) s) ?_ hct hEt hnet g hgb + intro hc' hE' hne' g' hgb' + exact isOut_relabelDataDown_congr_at (stepIso n) 𝒟₁ 𝒟₂ _ + (hm _ rfl) hc' hE' hne' g' hgb' + +open Classical in +/-- **The interface round trip on directions, at no cuts.** -/ +theorem isOut_pushData_liftData_zero + (V : Fragment (Fin (0 + 0) ⊕ Fin (0 + 0))) + (bits : Fin 0 → Bool) (𝒟 : DataFamily V) (s : Finset V.Flag) + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) (f : V.Flag) : + (pushData 0 V (liftData 0 V bits 𝒟) s hc hE hne).2.isOut f + = (𝒟 s hc hE hne).2.isOut f := rfl + +open Classical in +/-- **The interface round trip on directions, one stage on — at an +open cut.** Away from the cut's own two flags the directions come +back on the nose. -/ +theorem isOut_pushData_liftData_succ_open_at (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (bits : Fin (n + 1) → Bool) (𝒟 : DataFamily V) + {s : Finset V.Flag} (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc : EdgeSubset V).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc : EdgeSubset V).CanonData) + (hIH : ∀ (t : Finset (stepFragment n V).Flag), + t = flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) + (V.dropSubset (cutL n) (cutR n) s) → + ∀ (hct : ∀ f ∈ t, (stepFragment n V).pairing f ∈ t) + (hEt : (EdgeSubset.mk t hct).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct).CanonData) + (g : (stepFragment n V).Flag), + (∀ b, g ≠ (stepFragment n V).boundaryFlag b) → + (pushData n (stepFragment n V) + (liftData n (stepFragment n V) + (fun a => bits a.castSucc) + (stepDataUp n V (bits (Fin.last n)) 𝒟)) + t hct hEt hnet).2.isOut g + = (stepDataUp n V (bits (Fin.last n)) 𝒟 + t hct hEt hnet).2.isOut g) + (hdc : ∀ f ∈ V.dropSubset (cutL n) (cutR n) s, + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hop).pairing f ∈ V.dropSubset (cutL n) (cutR n) s) + (hcL : ∀ f ∈ liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s), + V.pairing f ∈ liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s)) + (hEL : (EdgeSubset.mk (liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s)) hcL : + EdgeSubset V).Eulerian) + (hneL : Nonempty (EdgeSubset.mk + (liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s)) hcL : + EdgeSubset V).CanonData) + (hag : (𝒟 (liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s)) hcL hEL hneL).2.isOut + (V.pairing (V.boundaryFlag (cutR n))) + = !(𝒟 (liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s)) hcL hEL + hneL).2.isOut (V.pairing (V.boundaryFlag (cutL n)))) + (f : V.Flag) (hfb : ∀ a, f ≠ V.boundaryFlag a) : + (pushData (n + 1) V (liftData (n + 1) V bits 𝒟) s hc hE + hne).2.isOut f = (𝒟 s hc hE hne).2.isOut f := by + have h1 : f ≠ V.boundaryFlag (cutL n) := hfb _ + have h2 : f ≠ V.boundaryFlag (cutR n) := hfb _ + have h3 := isOut_stepDataDown_congr_at_open n V hop + (pushData n (stepFragment n V) + (liftData n (stepFragment n V) (fun a => bits a.castSucc) + (stepDataUp n V (bits (Fin.last n)) 𝒟))) + (stepDataUp n V (bits (Fin.last n)) 𝒟) hIH hc hE hne f hfb + rw [stepData_roundTrip_open n V hop (bits (Fin.last n)) 𝒟] at h3 + exact h3.trans (isOut_unglue_glueDataOpen (cutL_ne_cutR n) hop 𝒟 + hc hE hne hdc hcL hEL hneL hag f h1 h2) + +open Classical in +/-- **The upward glue respects matching equality.** At an internal +flag the glued system's partner is the base system's, so two systems +that agree there glue to systems that agree. -/ +theorem glueOpen_matchEq {α : Type} {W : Fragment α} + {i j : α} (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairOpen i j hij hopen).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetOpen hopen s', + W.pairing f ∈ liftSubsetOpen hopen s') + {κ₁ κ₂ : (EdgeSubset.mk (liftSubsetOpen hopen s') hc : + EdgeSubset W).RelTransitionSystem} (hm : κ₁.MatchEq κ₂) : + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ₁).MatchEq + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ₂) := by + intro f' hf' + refine Subtype.ext ?_ + rw [glueOpen_match_val hij hopen s' hc' hc κ₁ hf', + glueOpen_match_val hij hopen s' hc' hc κ₂ hf'] + exact hm f'.val (internal_val_of_glueOpen hij hopen s' hc' hc hf') + +open Classical in +/-- **The closing glue respects matching equality.** It keeps every +internal flag's partner, so two systems that agree there glue to +systems that agree. -/ +theorem glueClosed_matchEq {α : Type} + {W : Fragment α} {i j : α} + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (b : Bool) (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairClosed i j hclosed).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetClosed s' b, + W.pairing f ∈ liftSubsetClosed s' b) + {κ₁ κ₂ : (EdgeSubset.mk (liftSubsetClosed s' b) hc : + EdgeSubset W).RelTransitionSystem} (hm : κ₁.MatchEq κ₂) : + (RelTransitionSystem.glueClosed hclosed b s' hc' hc κ₁).MatchEq + (RelTransitionSystem.glueClosed hclosed b s' hc' hc κ₂) := by + intro f' hf' + refine Subtype.ext ?_ + rw [glueClosed_match_val hclosed b s' hc' hc κ₁ hf', + glueClosed_match_val hclosed b s' hc' hc κ₂ hf'] + exact hm f'.val + (internal_val_of_glueClosed hclosed b s' hc' hc hf') + +/-- **The upward relabel respects matching equality.** It keeps the +partner map and only renames the labels. -/ +theorem relabelTransUp_matchEq {α' β' : Type} + (ee : α' ≃ β') {W' : Fragment α'} + (F : EdgeSubset W') {κ₁ κ₂ : F.RelTransitionSystem} + (hm : κ₁.MatchEq κ₂) : + (relabelTransUp ee F κ₁).MatchEq (relabelTransUp ee F κ₂) := + fun f hf => hm f (by rwa [relabelUp_internalFlags ee F] at hf) + +open Classical in +/-- **The family's upward glue is the ledger's**, at an open cut: a +family whose data at the stage's subset match the stage's system +glues to a system matching the ledger's glue. -/ +theorem match_glueDataOpen_stepDataOpen (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (𝒟 : DataFamily V) (D : StageData (n + 1) V) + (hcompat : ∀ hc hE hne, + (𝒟 D.sub.flags hc hE hne).1.MatchEq D.rel) + (hag : ∀ hcL hEL hneL, + (𝒟 (liftSubsetOpen hop + (stepFlags n V D)) hcL hEL hneL).2.isOut + (V.pairing (V.boundaryFlag (cutR n))) + = !(𝒟 (liftSubsetOpen hop + (stepFlags n V D)) hcL hEL hneL).2.isOut + (V.pairing (V.boundaryFlag (cutL n)))) + (hct : ∀ f ∈ stepFlags n V D, + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hop).pairing f ∈ stepFlags n V D) + (hEt : (EdgeSubset.mk (stepFlags n V D) hct : + EdgeSubset (V.gluePairOpen (cutL n) (cutR n) + (cutL_ne_cutR n) hop)).Eulerian) + (hnet : Nonempty (EdgeSubset.mk (stepFlags n V D) hct : + EdgeSubset (V.gluePairOpen (cutL n) (cutR n) + (cutL_ne_cutR n) hop)).CanonData) : + (glueDataOpen (cutL_ne_cutR n) hop 𝒟 (stepFlags n V D) hct hEt + hnet).1.MatchEq + (RelTransitionSystem.glueOpen (cutL_ne_cutR n) hop + (stepFlags n V D) hct + (liftSubsetOpen_stepFlags_pairing_mem n V D hop) + (relOfEq (sub_eq_liftSubsetOpen n V D hop) D.rel)) := by + unfold glueDataOpen + rw [dite_eq_left (hag _ _ _)] + refine glueOpen_matchEq (cutL_ne_cutR n) hop (stepFlags n V D) hct + (liftSubsetOpen_stepFlags_pairing_mem n V D hop) ?_ + intro f hf + have hEq : (EdgeSubset.mk (liftSubsetOpen hop + (stepFlags n V D)) + (liftSubsetOpen_stepFlags_pairing_mem n V D hop) : + EdgeSubset V) + = EdgeSubset.mk D.sub.flags D.sub.pairing_mem := + EdgeSubset.ext (liftSubsetOpen_stepFlags n V D hop) + have hcL := liftSubsetOpen_pairing_closed (cutL_ne_cutR n) hop + (stepFlags n V D) hct + have hEL := (eulerian_lift_open_iff (cutL_ne_cutR n) hop + (stepFlags n V D) hct hcL).mpr hEt + have hneL := nonempty_canonData_unglueOpen (cutL_ne_cutR n) hop + (stepFlags n V D) hct hcL hnet + have hED : (EdgeSubset.mk D.sub.flags D.sub.pairing_mem : + EdgeSubset V).Eulerian := hEq ▸ hEL + have hneD : Nonempty (EdgeSubset.mk D.sub.flags D.sub.pairing_mem : + EdgeSubset V).CanonData := hEq ▸ hneL + refine Eq.trans ?_ (match_relOfEq (sub_eq_liftSubsetOpen n V D hop) + D.rel f).symm + exact (match_dataFamily_congr 𝒟 + (liftSubsetOpen_stepFlags n V D hop) hcL hEL hneL + D.sub.pairing_mem hED hneD f).trans + (hcompat D.sub.pairing_mem hED hneD f (hEq ▸ hf)) + +/-- The transport of a subset, undone. -/ +theorem flagsOfEq_symm {L : Type} {V₁ V₂ : Fragment L} (h : V₁ = V₂) + (t : Finset V₁.Flag) : + flagsOfEq V₂ V₁ h.symm (flagsOfEq V₁ V₂ h t) = t := by + subst h + rfl + +/-- The upward relabel and a transport commute. -/ +theorem relabelDataUp_dataOfEq {L L' : Type} [LinearOrder L] + [LinearOrder L'] (e : L ≃o L') {W₁ W₂ : Fragment L} + (hW : W₁ = W₂) (𝒳 : DataFamily W₂) : + relabelDataUp e (dataOfEq hW 𝒳) + = dataOfEq (congrArg (fun X => X.relabel e.toEquiv) hW) + (relabelDataUp e 𝒳) := by + subst hW + rfl + +/-- **Both sides transported alike.** A family that matches a stage +datum still matches it after both are carried along an equality of +fragments. -/ +theorem match_dataOfEq_stageDataOfEq {m : ℕ} + {V₁ V₂ : Fragment (Fin (0 + m) ⊕ Fin (m + 0))} (hV : V₁ = V₂) + (Dm : StageData m V₁) (𝒴 : DataFamily V₁) + (hm : ∀ hc hE hne, (𝒴 Dm.sub.flags hc hE hne).1.MatchEq Dm.rel) + (hc : ∀ f ∈ (stageDataOfEq hV Dm).sub.flags, + V₂.pairing f ∈ (stageDataOfEq hV Dm).sub.flags) + (hE : (EdgeSubset.mk (stageDataOfEq hV Dm).sub.flags hc).Eulerian) + (hne : Nonempty + (EdgeSubset.mk (stageDataOfEq hV Dm).sub.flags hc).CanonData) : + (dataOfEq hV.symm 𝒴 (stageDataOfEq hV Dm).sub.flags hc hE + hne).1.MatchEq (stageDataOfEq hV Dm).rel := by + subst hV + exact hm hc hE hne + +open Classical in +/-- **The lifted family matches the ledger's step**, before the +transport that the dispatch on the cut demands. -/ +theorem match_relabelDataUp_stepDataOpen (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (𝒟 : DataFamily V) (D : StageData (n + 1) V) + (hcompat : ∀ hc hE hne, + (𝒟 D.sub.flags hc hE hne).1.MatchEq D.rel) + (hag : ∀ hcL hEL hneL, + (𝒟 (liftSubsetOpen hop + (stepFlags n V D)) hcL hEL hneL).2.isOut + (V.pairing (V.boundaryFlag (cutR n))) + = !(𝒟 (liftSubsetOpen hop + (stepFlags n V D)) hcL hEL hneL).2.isOut + (V.pairing (V.boundaryFlag (cutL n)))) + (hc : ∀ f ∈ (stepDataOpen n V D hop).sub.flags, + ((V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hop).relabel (interfaceStepEquiv 0 n 0)).pairing f + ∈ (stepDataOpen n V D hop).sub.flags) + (hE : (EdgeSubset.mk (stepDataOpen n V D hop).sub.flags + hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk (stepDataOpen n V D hop).sub.flags + hc).CanonData) : + (relabelDataUp (stepIso n) + (glueDataOpen (cutL_ne_cutR n) hop 𝒟) + (stepDataOpen n V D hop).sub.flags hc hE + hne).1.MatchEq (stepDataOpen n V D hop).rel := + relabelTransUp_matchEq (stepIso n).toEquiv _ + (match_glueDataOpen_stepDataOpen n V hop 𝒟 D hcompat hag _ _ _) + +open Classical in +/-- **One stage of the lift matches one stage of the ledger.** At an +open cut the family's glue and the ledger's step are the same system +up to its partner map, transports and relabel included. -/ +theorem match_stepDataUp_stepData_open (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (b : Bool) (𝒟 : DataFamily V) (D : StageData (n + 1) V) + (hcompat : ∀ hc hE hne, + (𝒟 D.sub.flags hc hE hne).1.MatchEq D.rel) + (hag : ∀ hcL hEL hneL, + (𝒟 (liftSubsetOpen hop + (stepFlags n V D)) hcL hEL hneL).2.isOut + (V.pairing (V.boundaryFlag (cutR n))) + = !(𝒟 (liftSubsetOpen hop + (stepFlags n V D)) hcL hEL hneL).2.isOut + (V.pairing (V.boundaryFlag (cutL n)))) + (hct : ∀ f ∈ (stepData n V D).sub.flags, + (stepFragment n V).pairing f ∈ (stepData n V D).sub.flags) + (hEt : (EdgeSubset.mk (stepData n V D).sub.flags hct).Eulerian) + (hnet : Nonempty + (EdgeSubset.mk (stepData n V D).sub.flags hct).CanonData) : + (stepDataUp n V b 𝒟 (stepData n V D).sub.flags hct hEt + hnet).1.MatchEq (stepData n V D).rel := by + have hup : stepDataUp n V b 𝒟 + = dataOfEq (congrArg (fun X => X.relabel + (interfaceStepEquiv 0 n 0)) + (gluePair_eq_open n V hop).symm) + (relabelDataUp (stepIso n) + (glueDataOpen (cutL_ne_cutR n) hop 𝒟)) := by + unfold stepDataUp + rw [dite_eq_right hop, relabelDataUp_dataOfEq] + rfl + revert hct hEt hnet + rw [show stepData n V D = _ from dite_eq_right hop, hup] + intro hct hEt hnet + exact match_dataOfEq_stageDataOfEq + (congrArg (fun X => X.relabel (interfaceStepEquiv 0 n 0)) + (gluePair_eq_open n V hop)) + (stepDataOpen n V D hop) + (relabelDataUp (stepIso n) + (glueDataOpen (cutL_ne_cutR n) hop 𝒟)) + (fun hc hE hne => match_relabelDataUp_stepDataOpen n V hop 𝒟 D + hcompat hag hc hE hne) hct hEt hnet + +open Classical in +/-- **The family's upward glue is the ledger's**, at a closing cut. +The ledger's own bit is the one the subset determines, and with it +the glue reads the family at exactly the ledger's subset. -/ +theorem match_glueDataClosed_stepDataClosed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (𝒟 : DataFamily V) (D : StageData (n + 1) V) + (hcompat : ∀ hc hE hne, + (𝒟 D.sub.flags hc hE hne).1.MatchEq D.rel) + (hct : ∀ f ∈ stepFlags n V D, + (V.gluePairClosed (cutL n) (cutR n) hcl).pairing f + ∈ stepFlags n V D) + (hEt : (EdgeSubset.mk (stepFlags n V D) hct : + EdgeSubset (V.gluePairClosed (cutL n) (cutR n) + hcl)).Eulerian) + (hnet : Nonempty (EdgeSubset.mk (stepFlags n V D) hct : + EdgeSubset (V.gluePairClosed (cutL n) (cutR n) + hcl)).CanonData) : + (glueDataClosed hcl (stepBit n V D) 𝒟 (stepFlags n V D) hct hEt + hnet).1.MatchEq + (RelTransitionSystem.glueClosed hcl (stepBit n V D) + (stepFlags n V D) hct + (liftSubsetClosed_stepFlags_pairing_mem n V D hcl) + (relOfEq (sub_eq_liftSubsetClosed n V D hcl) D.rel)) := by + refine glueClosed_matchEq hcl (stepBit n V D) (stepFlags n V D) + hct (liftSubsetClosed_stepFlags_pairing_mem n V D hcl) ?_ + intro f hf + have hEq : (EdgeSubset.mk (liftSubsetClosed (stepFlags n V D) + (stepBit n V D)) + (liftSubsetClosed_stepFlags_pairing_mem n V D hcl) : + EdgeSubset V) + = EdgeSubset.mk D.sub.flags D.sub.pairing_mem := + EdgeSubset.ext (liftSubsetClosed_stepFlags n V D hcl) + have hcL := liftSubsetClosed_stepFlags_pairing_mem n V D hcl + have hEL := (eulerian_liftClosed_iff' hcl (stepBit n V D) + (stepFlags n V D) hct hcL).mpr hEt + have hneL := nonempty_canonData_unglueClosed hcl + (stepFlags n V D) hct (stepBit n V D) hcL hnet + have hED : (EdgeSubset.mk D.sub.flags D.sub.pairing_mem : + EdgeSubset V).Eulerian := hEq ▸ hEL + have hneD : Nonempty (EdgeSubset.mk D.sub.flags D.sub.pairing_mem : + EdgeSubset V).CanonData := hEq ▸ hneL + refine Eq.trans ?_ (match_relOfEq + (sub_eq_liftSubsetClosed n V D hcl) D.rel f).symm + exact (match_dataFamily_congr 𝒟 + (liftSubsetClosed_stepFlags n V D hcl) hcL hEL hneL + D.sub.pairing_mem hED hneD f).trans + (hcompat D.sub.pairing_mem hED hneD f (hEq ▸ hf)) + +open Classical in +/-- **The lifted family matches the ledger's step**, at a closing +cut, before the transport the dispatch demands. -/ +theorem match_relabelDataUp_stepDataClosed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (𝒟 : DataFamily V) (D : StageData (n + 1) V) + (hcompat : ∀ hc hE hne, + (𝒟 D.sub.flags hc hE hne).1.MatchEq D.rel) + (hc : ∀ f ∈ (stepDataClosed n V D hcl).sub.flags, + ((V.gluePairClosed (cutL n) (cutR n) hcl).relabel + (interfaceStepEquiv 0 n 0)).pairing f + ∈ (stepDataClosed n V D hcl).sub.flags) + (hE : (EdgeSubset.mk (stepDataClosed n V D hcl).sub.flags + hc).Eulerian) + (hne : Nonempty + (EdgeSubset.mk (stepDataClosed n V D hcl).sub.flags + hc).CanonData) : + (relabelDataUp (stepIso n) + (glueDataClosed hcl (stepBit n V D) 𝒟) + (stepDataClosed n V D hcl).sub.flags hc hE + hne).1.MatchEq (stepDataClosed n V D hcl).rel := + relabelTransUp_matchEq (stepIso n).toEquiv _ + (match_glueDataClosed_stepDataClosed n V hcl 𝒟 D hcompat _ _ _) + +open Classical in +/-- **One stage of the lift matches one stage of the ledger**, at a +closing cut: with the subset's own bit the family's glue and the +ledger's step are the same system up to its partner map. -/ +theorem match_stepDataUp_stepData_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (𝒟 : DataFamily V) (D : StageData (n + 1) V) + (hcompat : ∀ hc hE hne, + (𝒟 D.sub.flags hc hE hne).1.MatchEq D.rel) + (hct : ∀ f ∈ (stepData n V D).sub.flags, + (stepFragment n V).pairing f ∈ (stepData n V D).sub.flags) + (hEt : (EdgeSubset.mk (stepData n V D).sub.flags hct).Eulerian) + (hnet : Nonempty + (EdgeSubset.mk (stepData n V D).sub.flags hct).CanonData) : + (stepDataUp n V (stepBit n V D) 𝒟 (stepData n V D).sub.flags + hct hEt hnet).1.MatchEq (stepData n V D).rel := by + have hup : stepDataUp n V (stepBit n V D) 𝒟 + = dataOfEq (congrArg (fun X => X.relabel + (interfaceStepEquiv 0 n 0)) + (gluePair_eq_closed n V hcl).symm) + (relabelDataUp (stepIso n) + (glueDataClosed hcl (stepBit n V D) 𝒟)) := by + unfold stepDataUp + rw [dite_eq_left hcl, relabelDataUp_dataOfEq] + rfl + revert hct hEt hnet + rw [show stepData n V D = _ from dite_eq_left hcl, hup] + intro hct hEt hnet + exact match_dataOfEq_stageDataOfEq + (congrArg (fun X => X.relabel (interfaceStepEquiv 0 n 0)) + (gluePair_eq_closed n V hcl)) + (stepDataClosed n V D hcl) + (relabelDataUp (stepIso n) + (glueDataClosed hcl (stepBit n V D) 𝒟)) + (fun hc hE hne => match_relabelDataUp_stepDataClosed n V hcl 𝒟 D + hcompat hc hE hne) hct hEt hnet + +/-- The transport of a flag, undone. -/ +theorem flagOfEq_symm {L : Type} {V₁ V₂ : Fragment L} (h : V₁ = V₂) + (f : V₁.Flag) : flagOfEq h.symm (flagOfEq h f) = f := by + subst h + rfl + +/-- The transport commutes with the pairing. -/ +theorem flagOfEq_pairing {L : Type} {V₁ V₂ : Fragment L} + (h : V₁ = V₂) (f : V₁.Flag) : + flagOfEq h (V₁.pairing f) = V₂.pairing (flagOfEq h f) := by + subst h + rfl + +/-- A transported family's directions, evaluated. -/ +theorem isOut_dataOfEq_apply {L : Type} [LinearOrder L] + {V₁ V₂ : Fragment L} (h : V₁ = V₂) (𝒟 : DataFamily V₂) + (s : Finset V₁.Flag) (hc : ∀ f ∈ s, V₁.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) + (hc' : ∀ f ∈ flagsOfEq V₁ V₂ h s, + V₂.pairing f ∈ flagsOfEq V₁ V₂ h s) + (hE' : (EdgeSubset.mk (flagsOfEq V₁ V₂ h s) hc').Eulerian) + (hne' : Nonempty + (EdgeSubset.mk (flagsOfEq V₁ V₂ h s) hc').CanonData) + (f : V₁.Flag) : + (dataOfEq h 𝒟 s hc hE hne).2.isOut f + = (𝒟 (flagsOfEq V₁ V₂ h s) hc' hE' hne').2.isOut + (flagOfEq h f) := by + subst h + rfl + +open Classical in +/-- **A stage of the lift keeps the base's directions.** At a +surviving flag the glued family reads the direction the base family +gave it, so the alignment at deeper cuts is the base's own. -/ +theorem isOut_stepDataUp_open (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (b : Bool) (𝒟 : DataFamily V) + (u : Finset (SurvivingFlag V (cutL n) (cutR n))) + (t : Finset (stepFragment n V).Flag) + (ht : t = flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) u) + (hct : ∀ f ∈ t, (stepFragment n V).pairing f ∈ t) + (hEt : (EdgeSubset.mk t hct).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct).CanonData) + (hcL : ∀ f ∈ liftSubsetOpen hop u, + V.pairing f ∈ liftSubsetOpen hop u) + (hEL : (EdgeSubset.mk (liftSubsetOpen hop u) + hcL : EdgeSubset V).Eulerian) + (hneL : Nonempty (EdgeSubset.mk + (liftSubsetOpen hop u) hcL : + EdgeSubset V).CanonData) + (hag : (𝒟 (liftSubsetOpen hop u) hcL hEL + hneL).2.isOut (V.pairing (V.boundaryFlag (cutR n))) + = !(𝒟 (liftSubsetOpen hop u) hcL hEL + hneL).2.isOut (V.pairing (V.boundaryFlag (cutL n)))) + (f' : SurvivingFlag V (cutL n) (cutR n)) + (g : (stepFragment n V).Flag) + (hg : g = flagOfEq (gluePair_eq_open n V hop) f') : + (stepDataUp n V b 𝒟 t hct hEt hnet).2.isOut g + = (𝒟 (liftSubsetOpen hop u) hcL hEL + hneL).2.isOut f'.val := by + subst ht + subst hg + have hup : stepDataUp n V b 𝒟 + = relabelDataUp (stepIso n) + (dataOfEq (gluePair_eq_open n V hop).symm + (glueDataOpen (cutL_ne_cutR n) hop 𝒟)) := by + unfold stepDataUp + rw [dite_eq_right hop] + have hEg : (EdgeSubset.mk (flagsOfEq _ _ + (gluePair_eq_open n V hop) u) hct : + EdgeSubset (V.gluePair (cutL n) (cutR n) + (cutL_ne_cutR n))).Eulerian := + (relabelUp_eulerian (stepIso n).toEquiv + (EdgeSubset.mk _ hct)).mp hEt + have hneg : Nonempty (EdgeSubset.mk (flagsOfEq _ _ + (gluePair_eq_open n V hop) u) hct : + EdgeSubset (V.gluePair (cutL n) (cutR n) + (cutL_ne_cutR n))).CanonData := + (nonempty_canonData_relabelUp (stepIso n) + (EdgeSubset.mk _ hct)).mp hnet + have hc' := flagsOfEq_pairing_mem (gluePair_eq_open n V hop).symm + _ hct + have hE' := flagsOfEq_eulerian (gluePair_eq_open n V hop).symm + _ hct hEg + have hne' := flagsOfEq_canon (gluePair_eq_open n V hop).symm + _ hct hneg + have hsub : (EdgeSubset.mk (flagsOfEq _ _ + (gluePair_eq_open n V hop).symm (flagsOfEq _ _ + (gluePair_eq_open n V hop) u)) hc' : + EdgeSubset (V.gluePairOpen (cutL n) (cutR n) + (cutL_ne_cutR n) hop)) + = EdgeSubset.mk u (flagsOfEq_symm (gluePair_eq_open n V hop) u + ▸ hc') := + EdgeSubset.ext (flagsOfEq_symm (gluePair_eq_open n V hop) u) + rw [hup] + refine Eq.trans (isOut_dataOfEq_apply + (gluePair_eq_open n V hop).symm + (glueDataOpen (cutL_ne_cutR n) hop 𝒟) _ hct hEg hneg hc' hE' + hne' _) ?_ + rw [flagOfEq_symm (gluePair_eq_open n V hop) f'] + refine Eq.trans (isOut_dataFamily_congr + (glueDataOpen (cutL_ne_cutR n) hop 𝒟) + (flagsOfEq_symm (gluePair_eq_open n V hop) u) hc' hE' hne' + (flagsOfEq_symm (gluePair_eq_open n V hop) u ▸ hc') + (hsub ▸ hE') (hsub ▸ hne') f') ?_ + exact isOut_glueDataOpen_pos (cutL_ne_cutR n) hop 𝒟 u _ _ _ hcL + hEL hneL hag f' + +open Classical in +/-- **The stage's directions at a closing cut** are the base +family's, read at the lift with the stage's bit. Nothing is +rewired, so no alternation is asked for. -/ +theorem isOut_stepDataUp_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (b : Bool) (𝒟 : DataFamily V) + (u : Finset (SurvivingFlag V (cutL n) (cutR n))) + (t : Finset (stepFragment n V).Flag) + (ht : t = flagsOfEq + (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) u) + (hct : ∀ f ∈ t, (stepFragment n V).pairing f ∈ t) + (hEt : (EdgeSubset.mk t hct).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct).CanonData) + (hcL : ∀ f ∈ liftSubsetClosed u b, + V.pairing f ∈ liftSubsetClosed u b) + (hEL : (EdgeSubset.mk (liftSubsetClosed u b) + hcL : EdgeSubset V).Eulerian) + (hneL : Nonempty (EdgeSubset.mk (liftSubsetClosed u b) hcL : + EdgeSubset V).CanonData) + (f' : SurvivingFlag V (cutL n) (cutR n)) + (g : (stepFragment n V).Flag) + (hg : g = flagOfEq (gluePair_eq_closed n V hcl) f') : + (stepDataUp n V b 𝒟 t hct hEt hnet).2.isOut g + = (𝒟 (liftSubsetClosed u b) hcL hEL hneL).2.isOut f'.val := by + subst ht + subst hg + have hup : stepDataUp n V b 𝒟 + = relabelDataUp (stepIso n) + (dataOfEq (gluePair_eq_closed n V hcl).symm + (glueDataClosed hcl b 𝒟)) := by + unfold stepDataUp + rw [dite_eq_left hcl] + have hEg : (EdgeSubset.mk (flagsOfEq _ _ + (gluePair_eq_closed n V hcl) u) hct : + EdgeSubset (V.gluePair (cutL n) (cutR n) + (cutL_ne_cutR n))).Eulerian := + (relabelUp_eulerian (stepIso n).toEquiv + (EdgeSubset.mk _ hct)).mp hEt + have hneg : Nonempty (EdgeSubset.mk (flagsOfEq _ _ + (gluePair_eq_closed n V hcl) u) hct : + EdgeSubset (V.gluePair (cutL n) (cutR n) + (cutL_ne_cutR n))).CanonData := + (nonempty_canonData_relabelUp (stepIso n) + (EdgeSubset.mk _ hct)).mp hnet + have hc' := flagsOfEq_pairing_mem (gluePair_eq_closed n V hcl).symm + _ hct + have hE' := flagsOfEq_eulerian (gluePair_eq_closed n V hcl).symm + _ hct hEg + have hne' := flagsOfEq_canon (gluePair_eq_closed n V hcl).symm + _ hct hneg + have hsub : (EdgeSubset.mk (flagsOfEq _ _ + (gluePair_eq_closed n V hcl).symm (flagsOfEq _ _ + (gluePair_eq_closed n V hcl) u)) hc' : + EdgeSubset (V.gluePairClosed (cutL n) (cutR n) hcl)) + = EdgeSubset.mk u (flagsOfEq_symm (gluePair_eq_closed n V hcl) + u ▸ hc') := + EdgeSubset.ext (flagsOfEq_symm (gluePair_eq_closed n V hcl) u) + rw [hup] + refine Eq.trans (isOut_dataOfEq_apply + (gluePair_eq_closed n V hcl).symm + (glueDataClosed hcl b 𝒟) _ hct hEg hneg hc' hE' + hne' _) ?_ + rw [flagOfEq_symm (gluePair_eq_closed n V hcl) f'] + refine Eq.trans (isOut_dataFamily_congr + (glueDataClosed hcl b 𝒟) + (flagsOfEq_symm (gluePair_eq_closed n V hcl) u) hc' hE' hne' + (flagsOfEq_symm (gluePair_eq_closed n V hcl) u ▸ hc') + (hsub ▸ hE') (hsub ▸ hne') f') ?_ + exact isOut_glueDataClosed_pos hcl b 𝒟 u _ _ _ hcL + hEL hneL f' + +/-- **The stage's boundary flag is the base's**, carried across the +transport the dispatch on the cut demands. -/ +theorem boundaryFlag_stepFragment_open (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) (bl : Fin (0 + n) ⊕ Fin (n + 0)) : + (stepFragment n V).boundaryFlag bl + = flagOfEq (gluePair_eq_open n V hop) + ((V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hop).boundaryFlag ((interfaceStepEquiv 0 n 0).symm bl)) := + (stepFragment_boundaryFlag n V bl).trans + (flagOfEq_boundaryFlag (gluePair_eq_open n V hop) _).symm + +/-- **The glue does not move the chain directions.** With the +pairing flipping at every boundary flag and the cut's own two ends +oppositely directed, the rewired partner of a surviving label carries +the direction the base's partner carried: crossing the cut costs two +flips, and two flips are none. -/ +theorem isOut_rewire_eq {α : Type} {W : Fragment α} + {F : EdgeSubset W} {κ : F.RelTransitionSystem} + (o : κ.Orientation) {i j : α} + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hflip : ∀ ℓ : α, o.isOut (W.pairing (W.boundaryFlag ℓ)) + = !o.isOut (W.boundaryFlag ℓ)) + (halign : o.isOut (W.pairing (W.boundaryFlag j)) + = !o.isOut (W.pairing (W.boundaryFlag i))) + (ℓ : α) (h1 : W.boundaryFlag ℓ ≠ W.boundaryFlag i) + (h2 : W.boundaryFlag ℓ ≠ W.boundaryFlag j) : + o.isOut (Fragment.rewire hopen ⟨W.boundaryFlag ℓ, h1, h2⟩).val + = o.isOut (W.pairing (W.boundaryFlag ℓ)) := by + by_cases hi : W.pairing (W.boundaryFlag ℓ) = W.boundaryFlag i + · rw [Fragment.rewire_eq_partnerSurvJ hopen _ hi] + change o.isOut (W.pairing (W.boundaryFlag j)) = _ + rw [halign, hi, hflip i, Bool.not_not] + · by_cases hj : W.pairing (W.boundaryFlag ℓ) = W.boundaryFlag j + · have h3 : o.isOut (W.pairing (W.boundaryFlag i)) + = o.isOut (W.boundaryFlag j) := by + rw [← Bool.not_not (o.isOut (W.pairing (W.boundaryFlag i))), + ← halign, hflip j, Bool.not_not] + rw [Fragment.rewire_eq_partnerSurvI hopen _ hi hj] + change o.isOut (W.pairing (W.boundaryFlag i)) = _ + rw [hj, h3] + · rw [Fragment.rewire_val_of_ne hopen _ hi hj] + +/-- **The stage's boundary partner is the rewired one.** The glue +sends a surviving boundary flag to its rewired partner, which is the +base's partner except across the cut's own edge. -/ +theorem pairing_boundaryFlag_stepFragment (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) (bl : Fin (0 + n) ⊕ Fin (n + 0)) : + (stepFragment n V).pairing ((stepFragment n V).boundaryFlag bl) + = flagOfEq (gluePair_eq_open n V hop) + (Fragment.rewire hop + ⟨V.boundaryFlag ((interfaceStepEquiv 0 n 0).symm bl).val, + fun hx => ((interfaceStepEquiv 0 n 0).symm bl).prop.1 + (V.boundaryFlag_injective hx), + fun hx => ((interfaceStepEquiv 0 n 0).symm bl).prop.2 + (V.boundaryFlag_injective hx)⟩) := by + rw [boundaryFlag_stepFragment_open n V hop bl] + exact (flagOfEq_pairing (gluePair_eq_open n V hop) _).symm + +open Classical in +/-- **A stage of the lift keeps the base's chain directions.** The +stage's boundary partner is the rewired one, the glue does not move +the directions, and the lifted family reads the base's own — so the +alternation the next cut needs is the base's at the same label. -/ +theorem chainDir_stepDataUp_eq (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (b : Bool) (𝒟 : DataFamily V) + (u : Finset (SurvivingFlag V (cutL n) (cutR n))) + (t : Finset (stepFragment n V).Flag) + (ht : t = flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) u) + (hct : ∀ f ∈ t, (stepFragment n V).pairing f ∈ t) + (hEt : (EdgeSubset.mk t hct).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct).CanonData) + (hcL : ∀ f ∈ liftSubsetOpen hop u, + V.pairing f ∈ liftSubsetOpen hop u) + (hEL : (EdgeSubset.mk (liftSubsetOpen hop u) + hcL : EdgeSubset V).Eulerian) + (hneL : Nonempty (EdgeSubset.mk + (liftSubsetOpen hop u) hcL : + EdgeSubset V).CanonData) + (hag : (𝒟 (liftSubsetOpen hop u) hcL hEL + hneL).2.isOut (V.pairing (V.boundaryFlag (cutR n))) + = !(𝒟 (liftSubsetOpen hop u) hcL hEL + hneL).2.isOut (V.pairing (V.boundaryFlag (cutL n)))) + (hflip : ∀ ℓ, (𝒟 (liftSubsetOpen hop u) hcL + hEL hneL).2.isOut (V.pairing (V.boundaryFlag ℓ)) + = !(𝒟 (liftSubsetOpen hop u) hcL hEL + hneL).2.isOut (V.boundaryFlag ℓ)) + (bl : Fin (0 + n) ⊕ Fin (n + 0)) : + (stepDataUp n V b 𝒟 t hct hEt hnet).2.isOut + ((stepFragment n V).pairing + ((stepFragment n V).boundaryFlag bl)) + = (𝒟 (liftSubsetOpen hop u) hcL hEL + hneL).2.isOut (V.pairing (V.boundaryFlag + ((interfaceStepEquiv 0 n 0).symm bl).val)) := by + rw [pairing_boundaryFlag_stepFragment n V hop bl, + isOut_stepDataUp_open n V hop b 𝒟 u t ht hct hEt hnet hcL hEL + hneL hag _ _ rfl] + exact isOut_rewire_eq _ hop hflip hag + ((interfaceStepEquiv 0 n 0).symm bl).val + (fun hx => ((interfaceStepEquiv 0 n 0).symm bl).prop.1 + (V.boundaryFlag_injective hx)) + (fun hx => ((interfaceStepEquiv 0 n 0).symm bl).prop.2 + (V.boundaryFlag_injective hx)) + +/-- The stage's `m`-th left label is the base's. -/ +theorem interfaceStepEquiv_symm_intL (n : ℕ) (m : Fin n) : + ((interfaceStepEquiv 0 n 0).symm (intL n m)).val + = intL (n + 1) m.castSucc := by + have h : intL n m = Sum.inl ⟨0 + m.val, by omega⟩ := + congrArg Sum.inl (Fin.ext (by simp)) + rw [h, interfaceStepEquiv_symm_inl 0 n 0 m.val m.isLt] + exact congrArg Sum.inl (Fin.ext (by simp)) + +/-- The stage's `m`-th right label is the base's. -/ +theorem interfaceStepEquiv_symm_intR (n : ℕ) (m : Fin n) : + ((interfaceStepEquiv 0 n 0).symm (intR n m)).val + = intR (n + 1) m.castSucc := by + have h : intR n m = Sum.inr ⟨m.val, by omega⟩ := + congrArg Sum.inr (Fin.ext (by simp)) + rw [h, interfaceStepEquiv_symm_inr 0 n 0 m.val m.isLt] + exact congrArg Sum.inr (Fin.ext (by simp)) + +open Classical in +/-- **A stage of the lift keeps the base's boundary directions.** -/ +theorem isOut_stepDataUp_boundaryFlag (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (b : Bool) (𝒟 : DataFamily V) + (u : Finset (SurvivingFlag V (cutL n) (cutR n))) + (t : Finset (stepFragment n V).Flag) + (ht : t = flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) u) + (hct : ∀ f ∈ t, (stepFragment n V).pairing f ∈ t) + (hEt : (EdgeSubset.mk t hct).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct).CanonData) + (hcL : ∀ f ∈ liftSubsetOpen hop u, + V.pairing f ∈ liftSubsetOpen hop u) + (hEL : (EdgeSubset.mk (liftSubsetOpen hop u) + hcL : EdgeSubset V).Eulerian) + (hneL : Nonempty (EdgeSubset.mk + (liftSubsetOpen hop u) hcL : + EdgeSubset V).CanonData) + (hag : (𝒟 (liftSubsetOpen hop u) hcL hEL + hneL).2.isOut (V.pairing (V.boundaryFlag (cutR n))) + = !(𝒟 (liftSubsetOpen hop u) hcL hEL + hneL).2.isOut (V.pairing (V.boundaryFlag (cutL n)))) + (bl : Fin (0 + n) ⊕ Fin (n + 0)) : + (stepDataUp n V b 𝒟 t hct hEt hnet).2.isOut + ((stepFragment n V).boundaryFlag bl) + = (𝒟 (liftSubsetOpen hop u) hcL hEL + hneL).2.isOut (V.boundaryFlag + ((interfaceStepEquiv 0 n 0).symm bl).val) := by + rw [boundaryFlag_stepFragment_open n V hop bl] + exact isOut_stepDataUp_open n V hop b 𝒟 u t ht hct hEt hnet hcL + hEL hneL hag + ((V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hop).boundaryFlag ((interfaceStepEquiv 0 n 0).symm bl)) _ rfl + +/-- **The cut alternation, read at the cut's own flags.** Once the +pairing flips at every boundary flag, the two ends of a cut are +oppositely directed exactly when the cut's two boundary flags +are — one flip on each side. -/ +theorem isOut_cut_iff_boundary {n : ℕ} + {V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))} {B : EdgeSubset V} + {κ : B.RelTransitionSystem} (o : κ.Orientation) + (hflip : ∀ ℓ, o.isOut (V.pairing (V.boundaryFlag ℓ)) + = !o.isOut (V.boundaryFlag ℓ)) (m : Fin n) : + (o.isOut (V.pairing (V.boundaryFlag (intR n m))) + = !o.isOut (V.pairing (V.boundaryFlag (intL n m)))) + ↔ (o.isOut (V.boundaryFlag (intR n m)) + = !o.isOut (V.boundaryFlag (intL n m))) := by + rw [hflip, hflip] + constructor + · intro h + exact Bool.not_inj (by rw [h, Bool.not_not]) + · intro h + rw [h, Bool.not_not] + +open Classical in +/-- **A subset is cut-balanced** when it uses the two labels of each +interface pair together. -/ +def CutBalanced {n : ℕ} (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) + (u : Finset V.Flag) : Prop := + ∀ m : Fin n, V.boundaryFlag (intL n m) ∈ u + ↔ V.boundaryFlag (intR n m) ∈ u + +/-- **A subset matching a diagonal state is cut-balanced.** The +diagonal gives a pair's two labels the same colour, so the subset +uses both or neither. -/ +theorem cutBalanced_of_matches_diag {k ℓ : ℕ} {n : ℕ} + {V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))} {u : Finset V.Flag} + (x : Fin n → (Fin k ⊕ Fin (2 * ℓ))) + (hbnd : genBoundarySubsetMatches V u (diagOf n x)) : + CutBalanced V u := by + intro m + rw [hbnd (intL n m), hbnd (intR n m)] + exact Iff.rfl + +/-- **The base's directions, as the lift consumes them.** The +pairing flips at every boundary flag, and the two ends of every +interface pair are oppositely directed. -/ +def BaseDirections {n : ℕ} + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) (𝒟 : DataFamily V) : + Prop := + ∀ (u : Finset V.Flag) (hc : ∀ f ∈ u, V.pairing f ∈ u) + (hE : (EdgeSubset.mk u hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk u hc).CanonData), + CutBalanced V u → + (∀ ℓ, (𝒟 u hc hE hne).2.isOut (V.pairing (V.boundaryFlag ℓ)) + = !(𝒟 u hc hE hne).2.isOut (V.boundaryFlag ℓ)) + ∧ ∀ m : Fin n, + (𝒟 u hc hE hne).2.isOut + (V.pairing (V.boundaryFlag (intR n m))) + = !(𝒟 u hc hE hne).2.isOut + (V.pairing (V.boundaryFlag (intL n m))) + +/-- **Every fragment's edges can be two-coloured.** The pairing is a +fixed-point-free involution, so comparing a flag's index with its +partner's orients every edge. -/ +theorem exists_edge_colouring {α : Type} (V : Fragment α) : + ∃ c : V.Flag → Bool, ∀ f, c (V.pairing f) = !c f := by + classical + refine ⟨fun f => decide (((Fintype.equivFin V.Flag) f : ℕ) + < ((Fintype.equivFin V.Flag) (V.pairing f) : ℕ)), fun f => ?_⟩ + have hne : ((Fintype.equivFin V.Flag) (V.pairing f) : ℕ) + ≠ ((Fintype.equivFin V.Flag) f : ℕ) := by + intro hx + exact V.pairing_ne f + ((Fintype.equivFin V.Flag).injective (Fin.ext hx)) + simp only [V.pairing_invol] + by_cases hlt : ((Fintype.equivFin V.Flag) f : ℕ) + < ((Fintype.equivFin V.Flag) (V.pairing f) : ℕ) + · simp only [decide_eq_true hlt, Bool.not_true, + decide_eq_false_iff_not] + omega + · simp only [decide_eq_false hlt, Bool.not_false, + decide_eq_true_eq] + omega + +/-! ## The stage at a closing cut + +A closing cut rewires nothing: its two flags bound one edge, which +the glue turns into a free circle, and every other flag keeps the +partner it had. So a flag survives the cut exactly when its partner +does, and the stage's pairing is the base's. +-/ + +/-- **A survivor's partner survives**, at the cut's left flag. The +two cut flags are each other's partners, so nothing else can pair to +either. -/ +theorem pairing_ne_cutL_of_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) (f : V.Flag) + (h2 : f ≠ V.boundaryFlag (cutR n)) : + V.pairing f ≠ V.boundaryFlag (cutL n) := by + intro hx + refine h2 ?_ + rw [← hcl, ← hx, V.pairing_invol] + +/-- **A survivor's partner survives**, at the cut's right flag. -/ +theorem pairing_ne_cutR_of_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) (f : V.Flag) + (h1 : f ≠ V.boundaryFlag (cutL n)) : + V.pairing f ≠ V.boundaryFlag (cutR n) := by + intro hx + refine h1 ?_ + rw [← V.pairing_invol f, hx, ← hcl, V.pairing_invol] + +/-- A surviving flag, read at the stage fragment, at a closing +cut. -/ +noncomputable def stageFlagClosed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) (f : V.Flag) + (h1 : f ≠ V.boundaryFlag (cutL n)) + (h2 : f ≠ V.boundaryFlag (cutR n)) : + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)).Flag := + flagOfEq (gluePair_eq_closed n V hcl) + (⟨f, h1, h2⟩ : SurvivingFlag V (cutL n) (cutR n)) + +/-- **At a closing cut the stage's partner is the base's.** -/ +theorem pairing_stageFlagClosed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) (f : V.Flag) + (h1 : f ≠ V.boundaryFlag (cutL n)) + (h2 : f ≠ V.boundaryFlag (cutR n)) + (k1 : V.pairing f ≠ V.boundaryFlag (cutL n)) + (k2 : V.pairing f ≠ V.boundaryFlag (cutR n)) : + (stepFragment n V).pairing (stageFlagClosed n V hcl f h1 h2) + = stageFlagClosed n V hcl (V.pairing f) k1 k2 := + (flagOfEq_pairing (gluePair_eq_closed n V hcl) _).symm + +/-- **The stage's boundary flag is the base's**, at a closing cut. -/ +theorem boundaryFlag_stepFragment_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (bl : Fin (0 + n) ⊕ Fin (n + 0)) : + (stepFragment n V).boundaryFlag bl + = flagOfEq (gluePair_eq_closed n V hcl) + ((V.gluePairClosed (cutL n) (cutR n) hcl).boundaryFlag + ((interfaceStepEquiv 0 n 0).symm bl)) := + (stepFragment_boundaryFlag n V bl).trans + (flagOfEq_boundaryFlag (gluePair_eq_closed n V hcl) _).symm + +/-- **A surviving boundary flag is the stage's own**, at a closing +cut. -/ +theorem stageFlagClosed_boundaryFlag (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) (bl : Fin (0 + n) ⊕ Fin (n + 0)) + (h1 : V.boundaryFlag ((interfaceStepEquiv 0 n 0).symm bl).val + ≠ V.boundaryFlag (cutL n)) + (h2 : V.boundaryFlag ((interfaceStepEquiv 0 n 0).symm bl).val + ≠ V.boundaryFlag (cutR n)) : + stageFlagClosed n V hcl + (V.boundaryFlag ((interfaceStepEquiv 0 n 0).symm bl).val) + h1 h2 + = (stepFragment n V).boundaryFlag bl := + (boundaryFlag_stepFragment_closed n V hcl bl).symm + +/-- A surviving flag, read at the stage fragment. -/ +noncomputable def stageFlag (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) (f : V.Flag) + (h1 : f ≠ V.boundaryFlag (cutL n)) + (h2 : f ≠ V.boundaryFlag (cutR n)) : + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)).Flag := + flagOfEq (gluePair_eq_open n V hop) + (⟨f, h1, h2⟩ : SurvivingFlag V (cutL n) (cutR n)) + +/-- The stage's partner of a surviving flag is its rewired one. -/ +theorem pairing_stageFlag (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) (f : V.Flag) + (h1 : f ≠ V.boundaryFlag (cutL n)) + (h2 : f ≠ V.boundaryFlag (cutR n)) : + (stepFragment n V).pairing (stageFlag n V hop f h1 h2) + = flagOfEq (gluePair_eq_open n V hop) + (Fragment.rewire hop ⟨f, h1, h2⟩) := + (flagOfEq_pairing (gluePair_eq_open n V hop) _).symm + +/-- Away from the cut, the stage's partner is the base's. -/ +theorem pairing_stageFlag_of_ne (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) (f : V.Flag) + (h1 : f ≠ V.boundaryFlag (cutL n)) + (h2 : f ≠ V.boundaryFlag (cutR n)) + (k1 : V.pairing f ≠ V.boundaryFlag (cutL n)) + (k2 : V.pairing f ≠ V.boundaryFlag (cutR n)) : + (stepFragment n V).pairing (stageFlag n V hop f h1 h2) + = stageFlag n V hop (V.pairing f) k1 k2 := by + rw [pairing_stageFlag n V hop f h1 h2] + exact congrArg (flagOfEq (gluePair_eq_open n V hop)) + (Subtype.ext (Fragment.rewire_val_of_ne hop _ k1 k2)) + +/-- At the cut's right edge the stage's partner is the far end of the +left edge. -/ +theorem pairing_stageFlag_cutR (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (k1 : V.pairing (V.boundaryFlag (cutR n)) + ≠ V.boundaryFlag (cutL n)) + (k2 : V.pairing (V.boundaryFlag (cutR n)) + ≠ V.boundaryFlag (cutR n)) + (h1 : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutL n)) + (h2 : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) : + (stepFragment n V).pairing (stageFlag n V hop + (V.pairing (V.boundaryFlag (cutR n))) k1 k2) + = stageFlag n V hop (V.pairing (V.boundaryFlag (cutL n))) + h1 h2 := by + have hne : V.pairing (V.pairing (V.boundaryFlag (cutR n))) + ≠ V.boundaryFlag (cutL n) := by + rw [V.pairing_invol] + exact fun hx => + cutL_ne_cutR n (V.boundaryFlag_injective hx).symm + rw [pairing_stageFlag n V hop _ k1 k2, + Fragment.rewire_eq_partnerSurvI hop _ hne (V.pairing_invol _)] + rfl + +/-- The stage's boundary flag is the base's, read as a stage +flag. -/ +theorem stageFlag_boundaryFlag (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) (bl : Fin (0 + n) ⊕ Fin (n + 0)) + (h1 : V.boundaryFlag ((interfaceStepEquiv 0 n 0).symm bl).val + ≠ V.boundaryFlag (cutL n)) + (h2 : V.boundaryFlag ((interfaceStepEquiv 0 n 0).symm bl).val + ≠ V.boundaryFlag (cutR n)) : + stageFlag n V hop + (V.boundaryFlag ((interfaceStepEquiv 0 n 0).symm bl).val) + h1 h2 + = (stepFragment n V).boundaryFlag bl := + (boundaryFlag_stepFragment_open n V hop bl).symm + +/-- A lower interface pair's left label is not the top cut's. -/ +theorem intL_ne_cutL (n : ℕ) (b : Fin n) : + intL (n + 1) b.castSucc ≠ cutL n := by + intro hx + have h := congrArg Fin.val (Sum.inl.inj hx) + simp only [Fin.val_cast, Fin.val_castSucc] at h + omega + +/-- A lower interface pair's right label is not the top cut's. -/ +theorem intR_ne_cutR (n : ℕ) (b : Fin n) : + intR (n + 1) b.castSucc ≠ cutR n := by + intro hx + have h := congrArg Fin.val (Sum.inr.inj hx) + simp only [Fin.val_cast, Fin.val_castSucc] at h + omega + +/-- A left label is never a right one. -/ +theorem intL_ne_cutR (n : ℕ) (b : Fin n) : + intL (n + 1) b.castSucc ≠ cutR n := Sum.inl_ne_inr + +/-- A right label is never a left one. -/ +theorem intR_ne_cutL (n : ℕ) (b : Fin n) : + intR (n + 1) b.castSucc ≠ cutL n := Sum.inr_ne_inl + +open Classical in +/-- **Extending a colouring across a cut.** The two cut flags take +the opposite colour to their partners, which survive the glue. -/ +noncomputable def cutExtend (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (hL1 : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutL n)) + (hR1 : V.pairing (V.boundaryFlag (cutR n)) + ≠ V.boundaryFlag (cutL n)) + (hR2 : V.pairing (V.boundaryFlag (cutR n)) + ≠ V.boundaryFlag (cutR n)) + (c' : (stepFragment n V).Flag → Bool) : V.Flag → Bool := + fun f => + if h1 : f = V.boundaryFlag (cutL n) then + !c' (stageFlag n V hop + (V.pairing (V.boundaryFlag (cutL n))) hL1 hop) + else if h2 : f = V.boundaryFlag (cutR n) then + !c' (stageFlag n V hop + (V.pairing (V.boundaryFlag (cutR n))) hR1 hR2) + else c' (stageFlag n V hop f h1 h2) + +open Classical in +/-- Away from the cut the extension is the stage's colouring. -/ +theorem cutExtend_of_ne (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (hL1 : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutL n)) + (hR1 : V.pairing (V.boundaryFlag (cutR n)) + ≠ V.boundaryFlag (cutL n)) + (hR2 : V.pairing (V.boundaryFlag (cutR n)) + ≠ V.boundaryFlag (cutR n)) + (c' : (stepFragment n V).Flag → Bool) (f : V.Flag) + (h1 : f ≠ V.boundaryFlag (cutL n)) + (h2 : f ≠ V.boundaryFlag (cutR n)) : + cutExtend n V hop hL1 hR1 hR2 c' f + = c' (stageFlag n V hop f h1 h2) := by + unfold cutExtend + rw [dite_eq_right h1, dite_eq_right h2] + +open Classical in +/-- At the cut's left flag the extension is the opposite of its +partner's colour. -/ +theorem cutExtend_cutL (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (hL1 : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutL n)) + (hR1 : V.pairing (V.boundaryFlag (cutR n)) + ≠ V.boundaryFlag (cutL n)) + (hR2 : V.pairing (V.boundaryFlag (cutR n)) + ≠ V.boundaryFlag (cutR n)) + (c' : (stepFragment n V).Flag → Bool) : + cutExtend n V hop hL1 hR1 hR2 c' (V.boundaryFlag (cutL n)) + = !c' (stageFlag n V hop + (V.pairing (V.boundaryFlag (cutL n))) hL1 hop) := by + unfold cutExtend + rw [dite_eq_left rfl] + +open Classical in +/-- At the cut's right flag the extension is the opposite of its +partner's colour. -/ +theorem cutExtend_cutR (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (hL1 : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutL n)) + (hR1 : V.pairing (V.boundaryFlag (cutR n)) + ≠ V.boundaryFlag (cutL n)) + (hR2 : V.pairing (V.boundaryFlag (cutR n)) + ≠ V.boundaryFlag (cutR n)) + (c' : (stepFragment n V).Flag → Bool) : + cutExtend n V hop hL1 hR1 hR2 c' (V.boundaryFlag (cutR n)) + = !c' (stageFlag n V hop + (V.pairing (V.boundaryFlag (cutR n))) hR1 hR2) := by + unfold cutExtend + rw [dite_eq_right (fun hx => cutL_ne_cutR n + (V.boundaryFlag_injective hx).symm), dite_eq_left rfl] + +/-- Stage flags at equal base flags agree. -/ +theorem stageFlagClosed_congr (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) {f g : V.Flag} (hfg : f = g) + (h1 : f ≠ V.boundaryFlag (cutL n)) + (h2 : f ≠ V.boundaryFlag (cutR n)) + (k1 : g ≠ V.boundaryFlag (cutL n)) + (k2 : g ≠ V.boundaryFlag (cutR n)) : + stageFlagClosed n V hcl f h1 h2 + = stageFlagClosed n V hcl g k1 k2 := by + subst hfg + rfl + +open Classical in +/-- **Extending a colouring across a closing cut.** The cut's two +flags are each other's partners, and the glue takes both away, so +their colours are free: give the left one `true` and the right one +`false` and both the edge and the interface pair alternate at +once. -/ +noncomputable def cutExtendClosed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (c' : (stepFragment n V).Flag → Bool) : V.Flag → Bool := + fun f => + if _h1 : f = V.boundaryFlag (cutL n) then true + else if _h2 : f = V.boundaryFlag (cutR n) then false + else c' (stageFlagClosed n V hcl f _h1 _h2) + +open Classical in +/-- Away from the cut the extension is the stage's colouring. -/ +theorem cutExtendClosed_of_ne (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (c' : (stepFragment n V).Flag → Bool) (f : V.Flag) + (h1 : f ≠ V.boundaryFlag (cutL n)) + (h2 : f ≠ V.boundaryFlag (cutR n)) : + cutExtendClosed n V hcl c' f + = c' (stageFlagClosed n V hcl f h1 h2) := by + unfold cutExtendClosed + rw [dite_eq_right h1, dite_eq_right h2] + +open Classical in +/-- At the cut's left flag the extension is `true`. -/ +theorem cutExtendClosed_cutL (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (c' : (stepFragment n V).Flag → Bool) : + cutExtendClosed n V hcl c' (V.boundaryFlag (cutL n)) = true := by + unfold cutExtendClosed + rw [dite_eq_left rfl] + +open Classical in +/-- At the cut's right flag the extension is `false`. -/ +theorem cutExtendClosed_cutR (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (c' : (stepFragment n V).Flag → Bool) : + cutExtendClosed n V hcl c' (V.boundaryFlag (cutR n)) + = false := by + unfold cutExtendClosed + rw [dite_eq_right (fun hx => cutL_ne_cutR n + (V.boundaryFlag_injective hx).symm), dite_eq_left rfl] + +/-- The stage flag does not depend on which proof of survival it is +given. -/ +theorem stageFlag_congr (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) {f g : V.Flag} (hfg : f = g) + (h1 : f ≠ V.boundaryFlag (cutL n)) + (h2 : f ≠ V.boundaryFlag (cutR n)) + (k1 : g ≠ V.boundaryFlag (cutL n)) + (k2 : g ≠ V.boundaryFlag (cutR n)) : + stageFlag n V hop f h1 h2 = stageFlag n V hop g k1 k2 := by + subst hfg + rfl + +open Classical in +/-- **The stage's boundary direction at a closing cut** is the base +family's at the same label. -/ +theorem isOut_stepDataUp_boundaryFlag_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (b : Bool) (𝒟 : DataFamily V) + (u : Finset (SurvivingFlag V (cutL n) (cutR n))) + (t : Finset (stepFragment n V).Flag) + (ht : t = flagsOfEq + (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) u) + (hct : ∀ f ∈ t, (stepFragment n V).pairing f ∈ t) + (hEt : (EdgeSubset.mk t hct).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct).CanonData) + (hcL : ∀ f ∈ liftSubsetClosed u b, + V.pairing f ∈ liftSubsetClosed u b) + (hEL : (EdgeSubset.mk (liftSubsetClosed u b) + hcL : EdgeSubset V).Eulerian) + (hneL : Nonempty (EdgeSubset.mk (liftSubsetClosed u b) hcL : + EdgeSubset V).CanonData) + (bl : Fin (0 + n) ⊕ Fin (n + 0)) : + (stepDataUp n V b 𝒟 t hct hEt hnet).2.isOut + ((stepFragment n V).boundaryFlag bl) + = (𝒟 (liftSubsetClosed u b) hcL hEL hneL).2.isOut + (V.boundaryFlag ((interfaceStepEquiv 0 n 0).symm bl).val) := + isOut_stepDataUp_closed n V hcl b 𝒟 u t ht hct hEt hnet hcL hEL + hneL _ _ (boundaryFlag_stepFragment_closed n V hcl bl) + +open Classical in +/-- **The stage's boundary partner's direction at a closing cut** is +the base family's at the partner of the same label. Nothing is +rewired, so no alternation is asked for. -/ +theorem chainDir_stepDataUp_eq_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (b : Bool) (𝒟 : DataFamily V) + (u : Finset (SurvivingFlag V (cutL n) (cutR n))) + (t : Finset (stepFragment n V).Flag) + (ht : t = flagsOfEq + (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) u) + (hct : ∀ f ∈ t, (stepFragment n V).pairing f ∈ t) + (hEt : (EdgeSubset.mk t hct).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct).CanonData) + (hcL : ∀ f ∈ liftSubsetClosed u b, + V.pairing f ∈ liftSubsetClosed u b) + (hEL : (EdgeSubset.mk (liftSubsetClosed u b) + hcL : EdgeSubset V).Eulerian) + (hneL : Nonempty (EdgeSubset.mk (liftSubsetClosed u b) hcL : + EdgeSubset V).CanonData) + (bl : Fin (0 + n) ⊕ Fin (n + 0)) : + (stepDataUp n V b 𝒟 t hct hEt hnet).2.isOut + ((stepFragment n V).pairing + ((stepFragment n V).boundaryFlag bl)) + = (𝒟 (liftSubsetClosed u b) hcL hEL hneL).2.isOut + (V.pairing (V.boundaryFlag + ((interfaceStepEquiv 0 n 0).symm bl).val)) := by + have h1 : V.boundaryFlag ((interfaceStepEquiv 0 n 0).symm bl).val + ≠ V.boundaryFlag (cutL n) := fun hx => + ((interfaceStepEquiv 0 n 0).symm bl).prop.1 + (V.boundaryFlag_injective hx) + have h2 : V.boundaryFlag ((interfaceStepEquiv 0 n 0).symm bl).val + ≠ V.boundaryFlag (cutR n) := fun hx => + ((interfaceStepEquiv 0 n 0).symm bl).prop.2 + (V.boundaryFlag_injective hx) + have k1 := pairing_ne_cutL_of_closed n V hcl _ h2 + have k2 := pairing_ne_cutR_of_closed n V hcl _ h1 + refine isOut_stepDataUp_closed n V hcl b 𝒟 u t ht hct hEt hnet + hcL hEL hneL ⟨_, k1, k2⟩ _ ?_ + rw [← stageFlagClosed_boundaryFlag n V hcl bl h1 h2, + pairing_stageFlagClosed n V hcl _ h1 h2 k1 k2] + rfl + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CrossingDelta.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CrossingDelta.lean new file mode 100644 index 0000000000..449f6b686e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CrossingDelta.lean @@ -0,0 +1,728 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordLabels + +/-! +# The per-step crossing-parity decomposition + +The chord-crossing count of a boundary pairing changes, across the +transposition of `pathMatch_repair_swap`, exactly by the +mutual-crossing change of the two re-paired chords: all third-chord +contributions cancel mod 2. The count is a sum of ordered-pair +crossing indicators; splitting the index square by membership in the +four touched ends leaves an untouched block (termwise equal), a +mixed block (per-third-chord parity transfer, `third_chord_reparity`) +and the four-end block (evaluated to the mutual-crossing indicator). +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} + +/-- Symmetrized crossing of two chords given by (unordered) label +pairs: each chord is normalized low-to-high and the two normalized +chords interleave, in either order. -/ +def chordPairCrossSym [LinearOrder α] + (p q : α × α) : Prop := + ChordPairCross (min p.1 p.2) (max p.1 p.2) (min q.1 q.2) + (max q.1 q.2) ∨ + ChordPairCross (min q.1 q.2) (max q.1 q.2) (min p.1 p.2) + (max p.1 p.2) + +/-- The symmetrization is redundant: `ChordPairCross` of normalized +chords is itself symmetric (its two disjuncts swap). -/ +theorem chordPairCrossSym_iff [LinearOrder α] + (p₁ p₂ q₁ q₂ : α) : + chordPairCrossSym (p₁, p₂) (q₁, q₂) ↔ + ChordPairCross (min p₁ p₂) (max p₁ p₂) (min q₁ q₂) + (max q₁ q₂) := + ⟨fun h => h.elim id (fun h => h.elim Or.inr Or.inl), Or.inl⟩ + +open scoped Classical in +/-- The two ordered crossing indicators of one sorted chord `(u, w)` +against a chord recorded as `(x, y)` sum to the interleaving +indicator, gated by `x < y`. -/ +private theorem sorted_pair_sum [LinearOrder α] + {x y u w : α} (huw : u < w) : + ((if u < w ∧ x < y ∧ u < x ∧ x < w ∧ w < y then (1 : ℕ) + else 0) + + (if x < y ∧ u < w ∧ x < u ∧ u < y ∧ y < w then (1 : ℕ) + else 0)) = + if x < y ∧ ChordPairCross x y u w then (1 : ℕ) else 0 := by + by_cases h1 : u < w ∧ x < y ∧ u < x ∧ x < w ∧ w < y + · obtain ⟨-, hxy, hux, hxw, hwy⟩ := h1 + have h2 : ¬ (x < y ∧ u < w ∧ x < u ∧ u < y ∧ y < w) := + fun ⟨_, _, hxu, _, _⟩ => lt_asymm hux hxu + rw [ite_eq_left ⟨huw, hxy, hux, hxw, hwy⟩, ite_eq_right h2, + ite_eq_left ⟨hxy, Or.inr ⟨hux, hxw, hwy⟩⟩] + · by_cases h2 : x < y ∧ u < w ∧ x < u ∧ u < y ∧ y < w + · obtain ⟨hxy, -, hxu, huy, hyw⟩ := h2 + rw [ite_eq_right h1, ite_eq_left ⟨hxy, huw, hxu, huy, hyw⟩, + ite_eq_left ⟨hxy, Or.inl ⟨hxu, huy, hyw⟩⟩] + · have h3 : ¬ (x < y ∧ ChordPairCross x y u w) := by + rintro ⟨hxy, ⟨hxu, huy, hyw⟩ | ⟨hux, hxw, hwy⟩⟩ + · exact h2 ⟨hxy, huw, hxu, huy, hyw⟩ + · exact h1 ⟨huw, hxy, hux, hxw, hwy⟩ + rw [ite_eq_right h1, ite_eq_right h2, ite_eq_right h3] + +open scoped Classical in +/-- The four ordered crossing indicators between one chord with ends +labelled `a`, `b` and a chord recorded as `(x, y)` sum to the gated +interleaving indicator of the normalized chords. -/ +private theorem side_label_sum [LinearOrder α] + {a b x y : α} (hab : a ≠ b) : + (((if a < b ∧ x < y ∧ a < x ∧ x < b ∧ b < y then (1 : ℕ) + else 0) + + (if x < y ∧ a < b ∧ x < a ∧ a < y ∧ y < b then (1 : ℕ) + else 0)) + + ((if b < a ∧ x < y ∧ b < x ∧ x < a ∧ a < y then (1 : ℕ) + else 0) + + (if x < y ∧ b < a ∧ x < b ∧ b < y ∧ y < a then (1 : ℕ) + else 0))) = + if x < y ∧ ChordPairCross x y (min a b) (max a b) + then (1 : ℕ) else 0 := by + rcases lt_or_gt_of_ne hab with h | h + · have e3 : (if b < a ∧ x < y ∧ b < x ∧ x < a ∧ a < y + then (1 : ℕ) else 0) = 0 := + ite_eq_right (fun hc => lt_asymm h hc.1) + have e4 : (if x < y ∧ b < a ∧ x < b ∧ b < y ∧ y < a + then (1 : ℕ) else 0) = 0 := + ite_eq_right (fun hc => lt_asymm h hc.2.1) + rw [e3, e4, add_zero, add_zero, min_eq_left h.le, + max_eq_right h.le] + exact sorted_pair_sum h + · have e1 : (if a < b ∧ x < y ∧ a < x ∧ x < b ∧ b < y + then (1 : ℕ) else 0) = 0 := + ite_eq_right (fun hc => lt_asymm h hc.1) + have e2 : (if x < y ∧ a < b ∧ x < a ∧ a < y ∧ y < b + then (1 : ℕ) else 0) = 0 := + ite_eq_right (fun hc => lt_asymm h hc.2.1) + rw [e1, e2, zero_add, zero_add, min_eq_right h.le, + max_eq_left h.le] + exact sorted_pair_sum h + +open scoped Classical in +/-- **The 16-pair table, cross-chord part**: the eight ordered +crossing indicators between two disjoint chords with end labels +`{a, b}` and `{c, d}` sum to the symmetrized mutual-crossing +indicator. -/ +private theorem eight_label_sum [LinearOrder α] + {a b c d : α} (hab : a ≠ b) + (hcd : c ≠ d) : + (((if a < b ∧ c < d ∧ a < c ∧ c < b ∧ b < d then (1 : ℕ) + else 0) + + (if a < b ∧ d < c ∧ a < d ∧ d < b ∧ b < c then (1 : ℕ) + else 0)) + + (((if b < a ∧ c < d ∧ b < c ∧ c < a ∧ a < d then (1 : ℕ) + else 0) + + (if b < a ∧ d < c ∧ b < d ∧ d < a ∧ a < c then (1 : ℕ) + else 0)) + + (((if c < d ∧ a < b ∧ c < a ∧ a < d ∧ d < b then (1 : ℕ) + else 0) + + (if c < d ∧ b < a ∧ c < b ∧ b < d ∧ d < a then (1 : ℕ) + else 0)) + + ((if d < c ∧ a < b ∧ d < a ∧ a < c ∧ c < b then (1 : ℕ) + else 0) + + (if d < c ∧ b < a ∧ d < b ∧ b < c ∧ c < a then (1 : ℕ) + else 0))))) = + if chordPairCrossSym (a, b) (c, d) then (1 : ℕ) else 0 := by + have h₁ := side_label_sum (x := c) (y := d) hab + have h₂ := side_label_sum (x := d) (y := c) hab + have hsum : + (if c < d ∧ ChordPairCross c d (min a b) (max a b) + then (1 : ℕ) else 0) + + (if d < c ∧ ChordPairCross d c (min a b) (max a b) + then (1 : ℕ) else 0) = + if chordPairCrossSym (a, b) (c, d) then (1 : ℕ) else 0 := by + rw [chordPairCrossSym_iff] + rcases lt_or_gt_of_ne hcd with h | h + · simp [h, lt_asymm h, min_eq_left h.le, max_eq_right h.le, + ChordPairCross, or_comm] + · simp [h, lt_asymm h, min_eq_right h.le, max_eq_left h.le, + ChordPairCross, or_comm] + convert (congrArg₂ (· + ·) h₁ h₂).trans hsum using 1 + ac_rfl + +/-- Sorting a chord in a cons-pair leaves the multiset unchanged. -/ +private theorem minmax_cons [LinearOrder α] + (u v : α) (s : Multiset α) : + (min u v ::ₘ max u v ::ₘ s) = u ::ₘ v ::ₘ s := by + rcases le_total u v with h | h + · rw [min_eq_left h, max_eq_right h] + · rw [min_eq_right h, max_eq_left h] + exact Multiset.cons_swap v u s + +/-- The endpoint multisets of the two normalized re-pairings of four +labels agree. -/ +private theorem minmax_multiset [LinearOrder α] + (a b c d : α) : + ({min a b, max a b, min c d, max c d} : Multiset α) = + {min a c, max a c, min b d, max b d} := by + simp only [Multiset.insert_eq_cons, ← Multiset.cons_zero] + rw [minmax_cons, minmax_cons, minmax_cons, minmax_cons] + exact congrArg (a ::ₘ ·) (Multiset.cons_swap b c _) + +/-- Avoidance transfer to the normalized endpoint multiset. -/ +private theorem minmax_multiset_forall [LinearOrder α] + {a b c d x y : α} + (hax : a ≠ x) (hay : a ≠ y) (hbx : b ≠ x) (hby : b ≠ y) + (hcx : c ≠ x) (hcy : c ≠ y) (hdx : d ≠ x) (hdy : d ≠ y) : + ∀ p ∈ ({min a b, max a b, min c d, max c d} : Multiset α), + p ≠ x ∧ p ≠ y := by + have h : ({min a b, max a b, min c d, max c d} : Multiset α) = + {a, b, c, d} := by + simp only [Multiset.insert_eq_cons, ← Multiset.cons_zero] + rw [minmax_cons, minmax_cons] + rw [h] + intro p hp + simp only [Multiset.insert_eq_cons, Multiset.mem_cons, + Multiset.mem_singleton] at hp + rcases hp with rfl | rfl | rfl | rfl + · exact ⟨hax, hay⟩ + · exact ⟨hbx, hby⟩ + · exact ⟨hcx, hcy⟩ + · exact ⟨hdx, hdy⟩ + +/-- Regrouping of two expanded quads into per-chord blocks. -/ +private theorem add_block (a₁ a₂ a₃ a₄ b₁ b₂ b₃ b₄ : ℕ) : + (a₁ + (a₂ + (a₃ + a₄))) + (b₁ + (b₂ + (b₃ + b₄))) = + ((a₁ + b₁) + (a₂ + b₂)) + ((a₃ + b₃) + (a₄ + b₄)) := by + omega + +/-- Splitting a square-indexed sum by a predicate on each factor. -/ +private theorem sum_split_four {β : Type} (S : Finset β) + (pr : β → Prop) [DecidablePred pr] (g : β → β → ℕ) : + (∑ z ∈ S, ∑ z' ∈ S, g z z') = + ((∑ z ∈ S.filter pr, ∑ z' ∈ S.filter pr, g z z') + + ∑ z ∈ S.filter pr, + ∑ z' ∈ S.filter (fun t => ¬ pr t), g z z') + + ((∑ z ∈ S.filter (fun t => ¬ pr t), + ∑ z' ∈ S.filter pr, g z z') + + ∑ z ∈ S.filter (fun t => ¬ pr t), + ∑ z' ∈ S.filter (fun t => ¬ pr t), g z z') := by + have h1 : ∀ T : Finset β, + (∑ z ∈ T, ∑ z' ∈ S, g z z') = + (∑ z ∈ T, ∑ z' ∈ S.filter pr, g z z') + + ∑ z ∈ T, ∑ z' ∈ S.filter (fun t => ¬ pr t), g z z' := by + intro T + rw [← Finset.sum_add_distrib] + exact Finset.sum_congr rfl (fun z _ => + (Finset.sum_filter_add_sum_filter_not S pr _).symm) + rw [← Finset.sum_filter_add_sum_filter_not S pr + (fun z => ∑ z' ∈ S, g z z'), h1, h1] + +namespace EdgeSubset + +open scoped Classical in +/-- The crossing indicator of two boundary ends, in terms of the +four labels, with designated matching partners. -/ +private theorem chordCross_ite_eq + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + (κ : F.RelTransitionSystem) + {x y mx my : W.Flag} + (hx : x ∈ F.boundaryFlags) (hy : y ∈ F.boundaryFlags) + (hmx : mx ∈ F.boundaryFlags) (hmy : my ∈ F.boundaryFlags) + (hpx : κ.pathMatch x hx = mx) (hpy : κ.pathMatch y hy = my) : + (if ChordCross κ ⟨x, hx⟩ ⟨y, hy⟩ then (1 : ℕ) else 0) = + if (F.boundaryLabel hx < F.boundaryLabel hmx ∧ + F.boundaryLabel hy < F.boundaryLabel hmy ∧ + F.boundaryLabel hx < F.boundaryLabel hy ∧ + F.boundaryLabel hy < F.boundaryLabel hmx ∧ + F.boundaryLabel hmx < F.boundaryLabel hmy) + then (1 : ℕ) else 0 := by + have h1 : F.boundaryLabel (κ.pathMatch_mem (Subtype.prop + (⟨x, hx⟩ : {z : W.Flag // z ∈ F.boundaryFlags}))) = + F.boundaryLabel hmx := boundaryLabel_congr _ hmx hpx + have h2 : F.boundaryLabel (κ.pathMatch_mem (Subtype.prop + (⟨y, hy⟩ : {z : W.Flag // z ∈ F.boundaryFlags}))) = + F.boundaryLabel hmy := boundaryLabel_congr _ hmy hpy + exact if_congr ((chordCross_iff_labels _ _).trans + (by rw [h1, h2])) rfl rfl + +open scoped Classical in +/-- A boundary end never crosses itself. -/ +private theorem chordCross_self_ite + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + (κ : F.RelTransitionSystem) + {x : W.Flag} (hx : x ∈ F.boundaryFlags) : + (if ChordCross κ ⟨x, hx⟩ ⟨x, hx⟩ then (1 : ℕ) else 0) = 0 := + ite_eq_right fun h => by + obtain ⟨-, -, hlt, -, -⟩ := (chordCross_iff_labels _ _).mp h + exact lt_irrefl _ hlt + +open scoped Classical in +/-- The two ends of one chord never cross each other. -/ +private theorem chordCross_partner_ite + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + (κ : F.RelTransitionSystem) + {x y : W.Flag} (hx : x ∈ F.boundaryFlags) + (hy : y ∈ F.boundaryFlags) + (hyx : κ.pathMatch y hy = x) : + (if ChordCross κ ⟨x, hx⟩ ⟨y, hy⟩ then (1 : ℕ) else 0) = 0 := by + refine ite_eq_right (fun h => ?_) + obtain ⟨-, hpartner, hstart, -, -⟩ := (chordCross_iff_labels _ _).mp h + have h2 : F.boundaryLabel (κ.pathMatch_mem (Subtype.prop + (⟨y, hy⟩ : {z : W.Flag // z ∈ F.boundaryFlags}))) = + F.boundaryLabel hx := boundaryLabel_congr _ hx hyx + exact lt_asymm hstart (h2 ▸ hpartner) + +open scoped Classical in +/-- **The four-end block**: the full ordered-pair crossing sum over +the four ends of two disjoint chords is the symmetrized +mutual-crossing indicator of their label chords. -/ +private theorem chordCross_quad_sum + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + (κ : F.RelTransitionSystem) + {u w p q : W.Flag} + (hu : u ∈ F.boundaryFlags) (hw : w ∈ F.boundaryFlags) + (hp : p ∈ F.boundaryFlags) (hq : q ∈ F.boundaryFlags) + (huw : κ.pathMatch u hu = w) (hwu : κ.pathMatch w hw = u) + (hpq : κ.pathMatch p hp = q) (hqp : κ.pathMatch q hq = p) + (huw' : u ≠ w) (hup : u ≠ p) (huq : u ≠ q) + (hwp : w ≠ p) (hwq : w ≠ q) (hpq' : p ≠ q) : + (∑ z ∈ ({⟨u, hu⟩, ⟨w, hw⟩, ⟨p, hp⟩, ⟨q, hq⟩} : + Finset {f : W.Flag // f ∈ F.boundaryFlags}), + ∑ z' ∈ ({⟨u, hu⟩, ⟨w, hw⟩, ⟨p, hp⟩, ⟨q, hq⟩} : + Finset {f : W.Flag // f ∈ F.boundaryFlags}), + (if ChordCross κ z z' then (1 : ℕ) else 0)) = + if chordPairCrossSym + (F.boundaryLabel hu, F.boundaryLabel hw) + (F.boundaryLabel hp, F.boundaryLabel hq) + then (1 : ℕ) else 0 := by + have nuw : (⟨u, hu⟩ : {f : W.Flag // f ∈ F.boundaryFlags}) ≠ + ⟨w, hw⟩ := fun h => huw' (congrArg Subtype.val h) + have nup : (⟨u, hu⟩ : {f : W.Flag // f ∈ F.boundaryFlags}) ≠ + ⟨p, hp⟩ := fun h => hup (congrArg Subtype.val h) + have nuq : (⟨u, hu⟩ : {f : W.Flag // f ∈ F.boundaryFlags}) ≠ + ⟨q, hq⟩ := fun h => huq (congrArg Subtype.val h) + have nwp : (⟨w, hw⟩ : {f : W.Flag // f ∈ F.boundaryFlags}) ≠ + ⟨p, hp⟩ := fun h => hwp (congrArg Subtype.val h) + have nwq : (⟨w, hw⟩ : {f : W.Flag // f ∈ F.boundaryFlags}) ≠ + ⟨q, hq⟩ := fun h => hwq (congrArg Subtype.val h) + have npq : (⟨p, hp⟩ : {f : W.Flag // f ∈ F.boundaryFlags}) ≠ + ⟨q, hq⟩ := fun h => hpq' (congrArg Subtype.val h) + simp only [sum_quad nuw nup nuq nwp nwq npq] + rw [chordCross_self_ite κ hu, chordCross_self_ite κ hw, + chordCross_self_ite κ hp, chordCross_self_ite κ hq, + chordCross_partner_ite κ hu hw hwu, + chordCross_partner_ite κ hw hu huw, + chordCross_partner_ite κ hp hq hqp, + chordCross_partner_ite κ hq hp hpq, + chordCross_ite_eq κ hu hp hw hq huw hpq, + chordCross_ite_eq κ hu hq hw hp huw hqp, + chordCross_ite_eq κ hw hp hu hq hwu hpq, + chordCross_ite_eq κ hw hq hu hp hwu hqp, + chordCross_ite_eq κ hp hu hq hw hpq huw, + chordCross_ite_eq κ hp hw hq hu hpq hwu, + chordCross_ite_eq κ hq hu hp hw hqp huw, + chordCross_ite_eq κ hq hw hp hu hqp hwu] + simp only [add_zero, zero_add] + exact eight_label_sum + (fun h => huw' (boundaryLabel_inj hu hw h)) + (fun h => hpq' (boundaryLabel_inj hp hq h)) + +open scoped Classical in +/-- **One chord against a third end**: the four ordered crossing +indicators between the two ends of one chord and a fixed third end +sum to the gated interleaving indicator. -/ +private theorem chordCross_side_sum + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + (κ : F.RelTransitionSystem) + {u w tv tm : W.Flag} + (hu : u ∈ F.boundaryFlags) (hw : w ∈ F.boundaryFlags) + (ht : tv ∈ F.boundaryFlags) (htmm : tm ∈ F.boundaryFlags) + (huw : κ.pathMatch u hu = w) (hwu : κ.pathMatch w hw = u) + (htm : κ.pathMatch tv ht = tm) (huw' : u ≠ w) : + (((if ChordCross κ ⟨u, hu⟩ ⟨tv, ht⟩ then (1 : ℕ) else 0) + + (if ChordCross κ ⟨tv, ht⟩ ⟨u, hu⟩ then (1 : ℕ) else 0)) + + ((if ChordCross κ ⟨w, hw⟩ ⟨tv, ht⟩ then (1 : ℕ) else 0) + + (if ChordCross κ ⟨tv, ht⟩ ⟨w, hw⟩ then (1 : ℕ) else 0))) = + if (F.boundaryLabel ht < F.boundaryLabel htmm ∧ + ChordPairCross (F.boundaryLabel ht) + (F.boundaryLabel htmm) + (min (F.boundaryLabel hu) (F.boundaryLabel hw)) + (max (F.boundaryLabel hu) (F.boundaryLabel hw))) + then (1 : ℕ) else 0 := by + rw [chordCross_ite_eq κ hu ht hw htmm huw htm, + chordCross_ite_eq κ ht hu htmm hw htm huw, + chordCross_ite_eq κ hw ht hu htmm hwu htm, + chordCross_ite_eq κ ht hw htmm hu htm hwu] + exact side_label_sum (fun h => huw' (boundaryLabel_inj hu hw h)) + +open scoped Classical in +/-- **The mixed block, per third chord**: for a fixed untouched end, +the eight ordered crossing indicators against the four touched ends +have the same parity before and after the transposition +(`third_chord_reparity` on the label chords). -/ +private theorem touched_line_parity + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + (κ κ' : F.RelTransitionSystem) {g₁ g₂ g₃ g₄ tv tm : W.Flag} + (h₁ : g₁ ∈ F.boundaryFlags) (h₂ : g₂ ∈ F.boundaryFlags) + (h₃ : g₃ ∈ F.boundaryFlags) (h₄ : g₄ ∈ F.boundaryFlags) + (ht : tv ∈ F.boundaryFlags) (htmm : tm ∈ F.boundaryFlags) + (k12 : κ.pathMatch g₁ h₁ = g₂) (k21 : κ.pathMatch g₂ h₂ = g₁) + (k34 : κ.pathMatch g₃ h₃ = g₄) (k43 : κ.pathMatch g₄ h₄ = g₃) + (k13 : κ'.pathMatch g₁ h₁ = g₃) (k31 : κ'.pathMatch g₃ h₃ = g₁) + (k24 : κ'.pathMatch g₂ h₂ = g₄) (k42 : κ'.pathMatch g₄ h₄ = g₂) + (htm : κ.pathMatch tv ht = tm) (htm' : κ'.pathMatch tv ht = tm) + (h12 : g₁ ≠ g₂) (h13 : g₁ ≠ g₃) (h14 : g₁ ≠ g₄) + (h23 : g₂ ≠ g₃) (h24 : g₂ ≠ g₄) (h34 : g₃ ≠ g₄) + (n1t : g₁ ≠ tv) (n2t : g₂ ≠ tv) (n3t : g₃ ≠ tv) + (n4t : g₄ ≠ tv) + (n1m : g₁ ≠ tm) (n2m : g₂ ≠ tm) (n3m : g₃ ≠ tm) + (n4m : g₄ ≠ tm) : + ((∑ z ∈ ({⟨g₁, h₁⟩, ⟨g₂, h₂⟩, ⟨g₃, h₃⟩, ⟨g₄, h₄⟩} : + Finset {f : W.Flag // f ∈ F.boundaryFlags}), + (if ChordCross κ z ⟨tv, ht⟩ then (1 : ℕ) else 0)) + + ∑ z ∈ ({⟨g₁, h₁⟩, ⟨g₂, h₂⟩, ⟨g₃, h₃⟩, ⟨g₄, h₄⟩} : + Finset {f : W.Flag // f ∈ F.boundaryFlags}), + (if ChordCross κ ⟨tv, ht⟩ z then (1 : ℕ) else 0)) % 2 = + ((∑ z ∈ ({⟨g₁, h₁⟩, ⟨g₂, h₂⟩, ⟨g₃, h₃⟩, ⟨g₄, h₄⟩} : + Finset {f : W.Flag // f ∈ F.boundaryFlags}), + (if ChordCross κ' z ⟨tv, ht⟩ then (1 : ℕ) else 0)) + + ∑ z ∈ ({⟨g₁, h₁⟩, ⟨g₂, h₂⟩, ⟨g₃, h₃⟩, ⟨g₄, h₄⟩} : + Finset {f : W.Flag // f ∈ F.boundaryFlags}), + (if ChordCross κ' ⟨tv, ht⟩ z then (1 : ℕ) else 0)) % 2 := by + have nz12 : (⟨g₁, h₁⟩ : {f : W.Flag // f ∈ F.boundaryFlags}) ≠ + ⟨g₂, h₂⟩ := fun h => h12 (congrArg Subtype.val h) + have nz13 : (⟨g₁, h₁⟩ : {f : W.Flag // f ∈ F.boundaryFlags}) ≠ + ⟨g₃, h₃⟩ := fun h => h13 (congrArg Subtype.val h) + have nz14 : (⟨g₁, h₁⟩ : {f : W.Flag // f ∈ F.boundaryFlags}) ≠ + ⟨g₄, h₄⟩ := fun h => h14 (congrArg Subtype.val h) + have nz23 : (⟨g₂, h₂⟩ : {f : W.Flag // f ∈ F.boundaryFlags}) ≠ + ⟨g₃, h₃⟩ := fun h => h23 (congrArg Subtype.val h) + have nz24 : (⟨g₂, h₂⟩ : {f : W.Flag // f ∈ F.boundaryFlags}) ≠ + ⟨g₄, h₄⟩ := fun h => h24 (congrArg Subtype.val h) + have nz34 : (⟨g₃, h₃⟩ : {f : W.Flag // f ∈ F.boundaryFlags}) ≠ + ⟨g₄, h₄⟩ := fun h => h34 (congrArg Subtype.val h) + have nz32 : (⟨g₃, h₃⟩ : {f : W.Flag // f ∈ F.boundaryFlags}) ≠ + ⟨g₂, h₂⟩ := fun h => h23 (congrArg Subtype.val h).symm + -- reorder the four ends on the repaired side to pair the chords + -- ═══════ THE FOUR ENDS AS AN EXPLICIT QUADRUPLE ═══════ + -- Above: the four are pairwise distinct. Below: the sum over the + -- touched block expands into its sixteen ordered pairs. + have hQ : ({⟨g₁, h₁⟩, ⟨g₂, h₂⟩, ⟨g₃, h₃⟩, ⟨g₄, h₄⟩} : + Finset {f : W.Flag // f ∈ F.boundaryFlags}) = + ({⟨g₁, h₁⟩, ⟨g₃, h₃⟩, ⟨g₂, h₂⟩, ⟨g₄, h₄⟩} : + Finset {f : W.Flag // f ∈ F.boundaryFlags}) := + congrArg (insert (⟨g₁, h₁⟩ : {f : W.Flag // f ∈ F.boundaryFlags})) + (Finset.insert_comm + (⟨g₂, h₂⟩ : {f : W.Flag // f ∈ F.boundaryFlags}) + ⟨g₃, h₃⟩ {⟨g₄, h₄⟩}) + conv_rhs => rw [hQ] + simp only [sum_quad nz12 nz13 nz14 nz23 nz24 nz34, + sum_quad nz13 nz12 nz14 nz32 nz34 nz24] + rw [add_block, add_block, + chordCross_side_sum κ h₁ h₂ ht htmm k12 k21 htm h12, + chordCross_side_sum κ h₃ h₄ ht htmm k34 k43 htm h34, + chordCross_side_sum κ' h₁ h₃ ht htmm k13 k31 htm' h13, + chordCross_side_sum κ' h₂ h₄ ht htmm k24 k42 htm' h24] + by_cases hxy : F.boundaryLabel ht < F.boundaryLabel htmm + · have r₁ : (if (F.boundaryLabel ht < F.boundaryLabel htmm ∧ + ChordPairCross (F.boundaryLabel ht) (F.boundaryLabel htmm) + (min (F.boundaryLabel h₁) (F.boundaryLabel h₂)) + (max (F.boundaryLabel h₁) (F.boundaryLabel h₂))) + then (1 : ℕ) else 0) = + if ChordPairCross (F.boundaryLabel ht) + (F.boundaryLabel htmm) + (min (F.boundaryLabel h₁) (F.boundaryLabel h₂)) + (max (F.boundaryLabel h₁) (F.boundaryLabel h₂)) + then (1 : ℕ) else 0 := + if_congr (and_iff_right hxy) rfl rfl + have r₂ : (if (F.boundaryLabel ht < F.boundaryLabel htmm ∧ + ChordPairCross (F.boundaryLabel ht) (F.boundaryLabel htmm) + (min (F.boundaryLabel h₃) (F.boundaryLabel h₄)) + (max (F.boundaryLabel h₃) (F.boundaryLabel h₄))) + then (1 : ℕ) else 0) = + if ChordPairCross (F.boundaryLabel ht) + (F.boundaryLabel htmm) + (min (F.boundaryLabel h₃) (F.boundaryLabel h₄)) + (max (F.boundaryLabel h₃) (F.boundaryLabel h₄)) + then (1 : ℕ) else 0 := + if_congr (and_iff_right hxy) rfl rfl + have r₃ : (if (F.boundaryLabel ht < F.boundaryLabel htmm ∧ + ChordPairCross (F.boundaryLabel ht) (F.boundaryLabel htmm) + (min (F.boundaryLabel h₁) (F.boundaryLabel h₃)) + (max (F.boundaryLabel h₁) (F.boundaryLabel h₃))) + then (1 : ℕ) else 0) = + if ChordPairCross (F.boundaryLabel ht) + (F.boundaryLabel htmm) + (min (F.boundaryLabel h₁) (F.boundaryLabel h₃)) + (max (F.boundaryLabel h₁) (F.boundaryLabel h₃)) + then (1 : ℕ) else 0 := + if_congr (and_iff_right hxy) rfl rfl + have r₄ : (if (F.boundaryLabel ht < F.boundaryLabel htmm ∧ + ChordPairCross (F.boundaryLabel ht) (F.boundaryLabel htmm) + (min (F.boundaryLabel h₂) (F.boundaryLabel h₄)) + (max (F.boundaryLabel h₂) (F.boundaryLabel h₄))) + then (1 : ℕ) else 0) = + if ChordPairCross (F.boundaryLabel ht) + (F.boundaryLabel htmm) + (min (F.boundaryLabel h₂) (F.boundaryLabel h₄)) + (max (F.boundaryLabel h₂) (F.boundaryLabel h₄)) + then (1 : ℕ) else 0 := + if_congr (and_iff_right hxy) rfl rfl + rw [r₁, r₂, r₃, r₄] + exact third_chord_reparity + (min_lt_max.mpr (fun h => h12 (boundaryLabel_inj h₁ h₂ h))) + (min_lt_max.mpr (fun h => h34 (boundaryLabel_inj h₃ h₄ h))) + (min_lt_max.mpr (fun h => h13 (boundaryLabel_inj h₁ h₃ h))) + (min_lt_max.mpr (fun h => h24 (boundaryLabel_inj h₂ h₄ h))) + (minmax_multiset _ _ _ _) + (minmax_multiset_forall + (fun h => n1t (boundaryLabel_inj h₁ ht h)) + (fun h => n1m (boundaryLabel_inj h₁ htmm h)) + (fun h => n2t (boundaryLabel_inj h₂ ht h)) + (fun h => n2m (boundaryLabel_inj h₂ htmm h)) + (fun h => n3t (boundaryLabel_inj h₃ ht h)) + (fun h => n3m (boundaryLabel_inj h₃ htmm h)) + (fun h => n4t (boundaryLabel_inj h₄ ht h)) + (fun h => n4m (boundaryLabel_inj h₄ htmm h))) + · have z₁ : (if (F.boundaryLabel ht < F.boundaryLabel htmm ∧ + ChordPairCross (F.boundaryLabel ht) (F.boundaryLabel htmm) + (min (F.boundaryLabel h₁) (F.boundaryLabel h₂)) + (max (F.boundaryLabel h₁) (F.boundaryLabel h₂))) + then (1 : ℕ) else 0) = 0 := + ite_eq_right (fun hc => hxy hc.1) + have z₂ : (if (F.boundaryLabel ht < F.boundaryLabel htmm ∧ + ChordPairCross (F.boundaryLabel ht) (F.boundaryLabel htmm) + (min (F.boundaryLabel h₃) (F.boundaryLabel h₄)) + (max (F.boundaryLabel h₃) (F.boundaryLabel h₄))) + then (1 : ℕ) else 0) = 0 := + ite_eq_right (fun hc => hxy hc.1) + have z₃ : (if (F.boundaryLabel ht < F.boundaryLabel htmm ∧ + ChordPairCross (F.boundaryLabel ht) (F.boundaryLabel htmm) + (min (F.boundaryLabel h₁) (F.boundaryLabel h₃)) + (max (F.boundaryLabel h₁) (F.boundaryLabel h₃))) + then (1 : ℕ) else 0) = 0 := + ite_eq_right (fun hc => hxy hc.1) + have z₄ : (if (F.boundaryLabel ht < F.boundaryLabel htmm ∧ + ChordPairCross (F.boundaryLabel ht) (F.boundaryLabel htmm) + (min (F.boundaryLabel h₂) (F.boundaryLabel h₄)) + (max (F.boundaryLabel h₂) (F.boundaryLabel h₄))) + then (1 : ℕ) else 0) = 0 := + ite_eq_right (fun hc => hxy hc.1) + rw [z₁, z₂, z₃, z₄] + +/-- The touched part of the boundary is exactly the four ends of the +two re-paired chords. -/ +private theorem filter_touched_eq {W : Fragment α} {F : EdgeSubset W} + (κ : F.RelTransitionSystem) + {e₁ e₂ : W.Flag} (he₁ : e₁ ∈ F.boundaryFlags) + (he₂ : e₂ ∈ F.boundaryFlags) : + F.boundaryFlags.attach.filter + (fun t => t.val = e₁ ∨ t.val = κ.pathMatch e₁ he₁ ∨ + t.val = e₂ ∨ t.val = κ.pathMatch e₂ he₂) = + ({⟨e₁, he₁⟩, ⟨κ.pathMatch e₁ he₁, κ.pathMatch_mem he₁⟩, + ⟨e₂, he₂⟩, ⟨κ.pathMatch e₂ he₂, κ.pathMatch_mem he₂⟩} : + Finset {f : W.Flag // f ∈ F.boundaryFlags}) := by + ext b + obtain ⟨v, hv⟩ := b + simp only [Finset.mem_filter, Finset.mem_attach, true_and, + Finset.mem_insert, Finset.mem_singleton, Subtype.mk.injEq] + +open scoped Classical in +/-- **The per-step crossing-parity decomposition**: across a pairing +transposition (two ends of distinct chords re-pair, the far ends +re-pair with each other, everything else is preserved), the crossing +count changes mod 2 exactly by the mutual-crossing change of the two +re-paired chords. -/ +theorem chordCrossingCount_repair_parity + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ κ' : F.RelTransitionSystem} {e₁ e₂ : W.Flag} + (he₁ : e₁ ∈ F.boundaryFlags) (he₂ : e₂ ∈ F.boundaryFlags) + (hne : e₁ ≠ e₂) (hPne : κ.pathMatch e₁ he₁ ≠ e₂) + (hcross : κ'.pathMatch e₁ he₁ = e₂) + (hfar : κ'.pathMatch (κ.pathMatch e₁ he₁) + (κ.pathMatch_mem he₁) = κ.pathMatch e₂ he₂) + (hout : ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + δ ≠ e₁ → δ ≠ e₂ → δ ≠ κ.pathMatch e₁ he₁ → + δ ≠ κ.pathMatch e₂ he₂ → + κ'.pathMatch δ hδ = κ.pathMatch δ hδ) : + (chordCrossingCount κ + chordCrossingCount κ') % 2 = + ((if chordPairCrossSym + (F.boundaryLabel he₁, + F.boundaryLabel (κ.pathMatch_mem he₁)) + (F.boundaryLabel he₂, + F.boundaryLabel (κ.pathMatch_mem he₂)) + then (1 : ℕ) else 0) + + (if chordPairCrossSym + (F.boundaryLabel he₁, F.boundaryLabel he₂) + (F.boundaryLabel (κ.pathMatch_mem he₁), + F.boundaryLabel (κ.pathMatch_mem he₂)) + then (1 : ℕ) else 0)) % 2 := by + -- ═══════ SETUP: THE FOUR TOUCHED ENDS ═══════ + -- involutions of the two pairings on the four ends + have hinv₁ : κ.pathMatch (κ.pathMatch e₁ he₁) + (κ.pathMatch_mem he₁) = e₁ := κ.pathMatch_invol he₁ + have hinv₂ : κ.pathMatch (κ.pathMatch e₂ he₂) + (κ.pathMatch_mem he₂) = e₂ := κ.pathMatch_invol he₂ + have hcross' : κ'.pathMatch e₂ he₂ = e₁ := + (κ'.pathMatch_congr hcross.symm he₂ + (κ'.pathMatch_mem he₁)).trans (κ'.pathMatch_invol he₁) + have hfar' : κ'.pathMatch (κ.pathMatch e₂ he₂) + (κ.pathMatch_mem he₂) = κ.pathMatch e₁ he₁ := + (κ'.pathMatch_congr hfar.symm (κ.pathMatch_mem he₂) + (κ'.pathMatch_mem (κ.pathMatch_mem he₁))).trans + (κ'.pathMatch_invol (κ.pathMatch_mem he₁)) + -- the four touched ends are pairwise distinct + have hd12 : e₁ ≠ κ.pathMatch e₁ he₁ := + fun h => κ.pathMatch_ne_self he₁ h.symm + have hd14 : e₁ ≠ κ.pathMatch e₂ he₂ := fun h => + hPne ((κ.pathMatch_congr h he₁ + (κ.pathMatch_mem he₂)).trans hinv₂) + have hd23 : κ.pathMatch e₁ he₁ ≠ e₂ := hPne + have hd24 : κ.pathMatch e₁ he₁ ≠ κ.pathMatch e₂ he₂ := fun h => + hne (hinv₁.symm.trans ((κ.pathMatch_congr h + (κ.pathMatch_mem he₁) (κ.pathMatch_mem he₂)).trans hinv₂)) + have hd34 : e₂ ≠ κ.pathMatch e₂ he₂ := + fun h => κ.pathMatch_ne_self he₂ h.symm + -- ═══════ STAGE 1: THE COUNT AS AN ORDERED-PAIR SUM ═══════ + have hcard : ∀ κ₀ : F.RelTransitionSystem, + chordCrossingCount κ₀ = + ∑ z ∈ F.boundaryFlags.attach, + ∑ z' ∈ F.boundaryFlags.attach, + (if ChordCross κ₀ z z' then (1 : ℕ) else 0) := by + intro κ₀ + unfold chordCrossingCount + rw [Finset.card_filter, Finset.sum_product] + -- ═══════ STAGE 2: THE FOUR-END BLOCK ═══════ + -- the repaired four-end block, with the ends listed chord-first + have hA' : (∑ z ∈ ({⟨e₁, he₁⟩, + ⟨κ.pathMatch e₁ he₁, κ.pathMatch_mem he₁⟩, ⟨e₂, he₂⟩, + ⟨κ.pathMatch e₂ he₂, κ.pathMatch_mem he₂⟩} : + Finset {f : W.Flag // f ∈ F.boundaryFlags}), + ∑ z' ∈ ({⟨e₁, he₁⟩, + ⟨κ.pathMatch e₁ he₁, κ.pathMatch_mem he₁⟩, ⟨e₂, he₂⟩, + ⟨κ.pathMatch e₂ he₂, κ.pathMatch_mem he₂⟩} : + Finset {f : W.Flag // f ∈ F.boundaryFlags}), + (if ChordCross κ' z z' then (1 : ℕ) else 0)) = + if chordPairCrossSym + (F.boundaryLabel he₁, F.boundaryLabel he₂) + (F.boundaryLabel (κ.pathMatch_mem he₁), + F.boundaryLabel (κ.pathMatch_mem he₂)) + then (1 : ℕ) else 0 := by + have hlit : ({⟨e₁, he₁⟩, + ⟨κ.pathMatch e₁ he₁, κ.pathMatch_mem he₁⟩, ⟨e₂, he₂⟩, + ⟨κ.pathMatch e₂ he₂, κ.pathMatch_mem he₂⟩} : + Finset {f : W.Flag // f ∈ F.boundaryFlags}) = + ({⟨e₁, he₁⟩, ⟨e₂, he₂⟩, + ⟨κ.pathMatch e₁ he₁, κ.pathMatch_mem he₁⟩, + ⟨κ.pathMatch e₂ he₂, κ.pathMatch_mem he₂⟩} : + Finset {f : W.Flag // f ∈ F.boundaryFlags}) := + congrArg + (insert (⟨e₁, he₁⟩ : {f : W.Flag // f ∈ F.boundaryFlags})) + (Finset.insert_comm + (⟨κ.pathMatch e₁ he₁, κ.pathMatch_mem he₁⟩ : + {f : W.Flag // f ∈ F.boundaryFlags}) + ⟨e₂, he₂⟩ {⟨κ.pathMatch e₂ he₂, κ.pathMatch_mem he₂⟩}) + rw [hlit] + exact chordCross_quad_sum κ' he₁ he₂ (κ.pathMatch_mem he₁) + (κ.pathMatch_mem he₂) hcross hcross' hfar hfar' hne hd12 + hd14 (fun h => hd23 h.symm) hd34 hd24 + -- ═══════ STAGE 3: THE UNTOUCHED BLOCK IS TERMWISE EQUAL ═══════ + have hD : (∑ z ∈ F.boundaryFlags.attach.filter + (fun t => ¬ (t.val = e₁ ∨ t.val = κ.pathMatch e₁ he₁ ∨ + t.val = e₂ ∨ t.val = κ.pathMatch e₂ he₂)), + ∑ z' ∈ F.boundaryFlags.attach.filter + (fun t => ¬ (t.val = e₁ ∨ t.val = κ.pathMatch e₁ he₁ ∨ + t.val = e₂ ∨ t.val = κ.pathMatch e₂ he₂)), + (if ChordCross κ' z z' then (1 : ℕ) else 0)) = + ∑ z ∈ F.boundaryFlags.attach.filter + (fun t => ¬ (t.val = e₁ ∨ t.val = κ.pathMatch e₁ he₁ ∨ + t.val = e₂ ∨ t.val = κ.pathMatch e₂ he₂)), + ∑ z' ∈ F.boundaryFlags.attach.filter + (fun t => ¬ (t.val = e₁ ∨ t.val = κ.pathMatch e₁ he₁ ∨ + t.val = e₂ ∨ t.val = κ.pathMatch e₂ he₂)), + (if ChordCross κ z z' then (1 : ℕ) else 0) := by + refine Finset.sum_congr rfl (fun z hz => + Finset.sum_congr rfl (fun z' hz' => ?_)) + have hnz := (Finset.mem_filter.mp hz).2 + have hnz' := (Finset.mem_filter.mp hz').2 + have hzeq : κ'.pathMatch z.val z.prop = + κ.pathMatch z.val z.prop := + hout z.val z.prop (fun h => hnz (Or.inl h)) + (fun h => hnz (Or.inr (Or.inr (Or.inl h)))) + (fun h => hnz (Or.inr (Or.inl h))) + (fun h => hnz (Or.inr (Or.inr (Or.inr h)))) + have hz'eq : κ'.pathMatch z'.val z'.prop = + κ.pathMatch z'.val z'.prop := + hout z'.val z'.prop (fun h => hnz' (Or.inl h)) + (fun h => hnz' (Or.inr (Or.inr (Or.inl h)))) + (fun h => hnz' (Or.inr (Or.inl h))) + (fun h => hnz' (Or.inr (Or.inr (Or.inr h)))) + exact if_congr (by unfold ChordCross; rw [hzeq, hz'eq]) + rfl rfl + -- ═══════ ASSEMBLY: THE MOD-2 BOOKKEEPING ═══════ + have key : ∀ A₁ A₂ B₁ C₁ B₂ C₂ D : ℕ, + (B₁ + C₁) % 2 = (B₂ + C₂) % 2 → + (((A₁ + B₁) + (C₁ + D)) + ((A₂ + B₂) + (C₂ + D))) % 2 = + (A₁ + A₂) % 2 := by + intro A₁ A₂ B₁ C₁ B₂ C₂ D h + omega + rw [hcard κ, hcard κ', + sum_split_four F.boundaryFlags.attach + (fun t => t.val = e₁ ∨ t.val = κ.pathMatch e₁ he₁ ∨ + t.val = e₂ ∨ t.val = κ.pathMatch e₂ he₂), + sum_split_four F.boundaryFlags.attach + (fun t => t.val = e₁ ∨ t.val = κ.pathMatch e₁ he₁ ∨ + t.val = e₂ ∨ t.val = κ.pathMatch e₂ he₂), + filter_touched_eq κ he₁ he₂, + chordCross_quad_sum κ he₁ (κ.pathMatch_mem he₁) he₂ + (κ.pathMatch_mem he₂) rfl hinv₁ rfl hinv₂ hd12 hne hd14 + hd23 hd24 hd34, + hA', hD] + refine key _ _ _ _ _ _ _ ?_ + rw [Finset.sum_comm, ← Finset.sum_add_distrib, + Finset.sum_comm, ← Finset.sum_add_distrib] + refine (Finset.sum_nat_mod _ 2 _).trans + (Eq.trans ?_ (Finset.sum_nat_mod _ 2 _).symm) + refine congrArg (· % 2) + (Finset.sum_congr rfl (fun t htN => ?_)) + have hnt := (Finset.mem_filter.mp htN).2 + have nt1 : t.val ≠ e₁ := fun h => hnt (Or.inl h) + have nt2 : t.val ≠ κ.pathMatch e₁ he₁ := + fun h => hnt (Or.inr (Or.inl h)) + have nt3 : t.val ≠ e₂ := + fun h => hnt (Or.inr (Or.inr (Or.inl h))) + have nt4 : t.val ≠ κ.pathMatch e₂ he₂ := + fun h => hnt (Or.inr (Or.inr (Or.inr h))) + have htm' : κ'.pathMatch t.val t.prop = + κ.pathMatch t.val t.prop := + hout t.val t.prop nt1 nt3 nt2 nt4 + have m1 : e₁ ≠ κ.pathMatch t.val t.prop := fun h => + nt2 (((κ.pathMatch_congr h he₁ + (κ.pathMatch_mem t.prop)).trans + (κ.pathMatch_invol t.prop)).symm) + have m2 : κ.pathMatch e₁ he₁ ≠ κ.pathMatch t.val t.prop := + fun h => nt1 ((hinv₁.symm.trans ((κ.pathMatch_congr h + (κ.pathMatch_mem he₁) (κ.pathMatch_mem t.prop)).trans + (κ.pathMatch_invol t.prop))).symm) + have m3 : e₂ ≠ κ.pathMatch t.val t.prop := fun h => + nt4 (((κ.pathMatch_congr h he₂ + (κ.pathMatch_mem t.prop)).trans + (κ.pathMatch_invol t.prop)).symm) + have m4 : κ.pathMatch e₂ he₂ ≠ κ.pathMatch t.val t.prop := + fun h => nt3 ((hinv₂.symm.trans ((κ.pathMatch_congr h + (κ.pathMatch_mem he₂) (κ.pathMatch_mem t.prop)).trans + (κ.pathMatch_invol t.prop))).symm) + exact touched_line_parity κ κ' he₁ (κ.pathMatch_mem he₁) he₂ + (κ.pathMatch_mem he₂) t.prop (κ.pathMatch_mem t.prop) + rfl hinv₁ rfl hinv₂ hcross hcross' hfar hfar' rfl htm' + hd12 hne hd14 hd23 hd24 hd34 + (fun h => nt1 h.symm) (fun h => nt2 h.symm) + (fun h => nt3 h.symm) (fun h => nt4 h.symm) m1 m2 m3 m4 + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CutMatching.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CutMatching.lean new file mode 100644 index 0000000000..29fc259d5c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CutMatching.lean @@ -0,0 +1,960 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DirMatching +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonicalFrame +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordCount +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperSpace +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelChords + +/-! +# The directed matching a transition system induces on the used labels + +An Eulerian subset with a compatible local pairing decomposes into +circuits and directed trails between labelled ends. The trails +give a directed perfect matching on the labels the subset uses: +partners are the two ends of a trail, and the direction is the one +the trail runs in. + +Two kinds of trail occur. Most have at least one internal step, +and there the orientation's chain direction reads the trail's sense +off the entry edge; the two ends carry opposite values by +chain-direction rigidity. A trail of a single edge — both of whose +ends are labelled — has no internal step, and the orientation's +laws say nothing about it, so its sense is taken from the label +order. That is the same orientation the mixed partition function's +own through-edge product uses. +-/ + +@[expose] public section + +namespace RS + +open EdgeSubset + +variable {α : Type} + +/-- A used label whose trail is a single edge: its entry edge is +another used label's flag. -/ +def IsThroughLabel {W : Fragment α} + (F : EdgeSubset W) (i : α) : Prop := + W.pairing (W.boundaryFlag i) ∈ F.boundaryFlags + +/-- Off the single-edge trails the entry edge is internal. -/ +theorem pairing_internal_of_not_through {W : Fragment α} + (F : EdgeSubset W) {i : α} + (hb : W.boundaryFlag i ∈ F.boundaryFlags) + (hnt : ¬ IsThroughLabel F i) : + W.pairing (W.boundaryFlag i) ∈ F.internalFlags := + (mem_internalFlags_or_boundaryFlags F + (F.pairing_mem _ (mem_flags_of_boundaryFlags F hb))).resolve_right hnt + +/-- The single-edge trails come in pairs. -/ +theorem isThroughLabel_chordInv [LinearOrder α] {W : Fragment α} + (F : EdgeSubset W) + (κ : F.RelTransitionSystem) {i : α} + (hb : W.boundaryFlag i ∈ F.boundaryFlags) + (ht : IsThroughLabel F i) : + IsThroughLabel F (chordInv F κ i) := by + unfold IsThroughLabel at ht ⊢ + rw [boundaryFlag_chordInv F κ hb, + pathMatch_eq_pairing_of_boundary κ hb ht, W.pairing_invol] + exact hb + +/-- Comparing two distinct labels the other way negates. -/ +theorem decide_lt_flip [LinearOrder α] + {i j : α} (h : i ≠ j) : + decide (j < i) = !decide (i < j) := by + rcases lt_trichotomy i j with h1 | h1 | h1 + · rw [decide_eq_false (asymm h1), decide_eq_true h1] + rfl + · exact absurd h1 h + · rw [decide_eq_true h1, decide_eq_false (asymm h1)] + rfl + +open scoped Classical in +/-- **The directed matching a transition system induces on the used +labels** — RS21's `M(ω,κ)`. Partners are the two ends of a trail; +the direction is the trail's own, read from the orientation where +the trail has an internal step and from the label order where it is +a single edge. -/ +noncomputable def cutMatching [LinearOrder α] {W : Fragment α} + (F : EdgeSubset W) + (κ : F.RelTransitionSystem) (o : κ.Orientation) : + DirMatching {i : α // W.boundaryFlag i ∈ F.boundaryFlags} where + edge i := ⟨chordInv F κ i.val, chordInv_mem F κ i.prop⟩ + edge_invol i := Subtype.ext (chordInv_invol F κ i.val) + edge_ne i := fun h => + chordInv_ne F κ i.prop (congrArg Subtype.val h) + tail i := + if IsThroughLabel F i.val then + decide (i.val < chordInv F κ i.val) + else !chainDir o (W.boundaryFlag i.val) + tail_flip i := by + by_cases ht : IsThroughLabel F i.val + · have ht' : IsThroughLabel F (chordInv F κ i.val) := + isThroughLabel_chordInv F κ i.prop ht + change (if IsThroughLabel F (chordInv F κ i.val) then + decide (chordInv F κ i.val + < chordInv F κ (chordInv F κ i.val)) + else _) = !(if IsThroughLabel F i.val then _ else _) + rw [ite_eq_left ht', ite_eq_left ht, chordInv_invol] + exact decide_lt_flip (fun hx => + chordInv_ne F κ i.prop hx.symm) + · have hint := pairing_internal_of_not_through F i.prop ht + have hfar : W.pairing (W.boundaryFlag (chordInv F κ i.val)) + ∈ F.internalFlags := by + rw [boundaryFlag_chordInv F κ i.prop] + exact pathMatch_pairing_internal i.prop hint + have ht' : ¬ IsThroughLabel F (chordInv F κ i.val) := fun hx => + Finset.disjoint_left.mp F.internalFlags_disjoint_boundaryFlags + hfar hx + change (if IsThroughLabel F (chordInv F κ i.val) then _ + else !chainDir o (W.boundaryFlag (chordInv F κ i.val))) + = !(if IsThroughLabel F i.val then _ + else !chainDir o (W.boundaryFlag i.val)) + rw [ite_eq_right ht', ite_eq_right ht, boundaryFlag_chordInv F κ i.prop, + chainDir_pathMatch o i.prop hint] + +/-! ### Undoing the dual basis + +RS21's boundary vector at a used leg is `f_{χ₁(i)}` where the arc +enters and `g_{χ₁(i)}` where it leaves. Written in the basis of +the `f`'s, the leaving legs carry the partner colour and the +partner sign. So a basis coordinate `x` of the tensor determines +`χ₁` by undoing the partner at the legs the trail leaves, and +contributes the product of those legs' signs. + +The two operations below are that change of basis and its weight. +-/ + +section ChordRelabel + +/-- **The chord involution shifts through the relabel.** -/ +theorem chordInv_relabelUp [LinearOrder α] {W : Fragment α} + {β : Type} [LinearOrder β] (e : α ≃o β) + (F : EdgeSubset W) (κ : F.RelTransitionSystem) (b : β) : + chordInv (F.relabelUp e.toEquiv) (relabelTransUp e.toEquiv F κ) b + = e (chordInv F κ (e.symm b)) := by + have hbf : (W.relabel e.toEquiv).boundaryFlag b + = W.boundaryFlag (e.symm b) := rfl + unfold chordInv + by_cases hb : W.boundaryFlag (e.symm b) ∈ F.boundaryFlags + · have hb' : (W.relabel e.toEquiv).boundaryFlag b + ∈ (F.relabelUp e.toEquiv).boundaryFlags := by + rw [hbf, relabelUp_boundaryFlags e F] + exact hb + rw [dite_eq_left hb', dite_eq_left hb] + have hpm := relabel_pathMatch e F κ hb' hb + have hmem' : κ.pathMatch (W.boundaryFlag (e.symm b)) hb + ∈ (F.relabelUp e.toEquiv).boundaryFlags := by + rw [relabelUp_boundaryFlags e F] + exact κ.pathMatch_mem hb + calc (F.relabelUp e.toEquiv).boundaryLabel + ((relabelTransUp e.toEquiv F κ).pathMatch_mem hb') + = (F.relabelUp e.toEquiv).boundaryLabel hmem' := by + congr 1 + _ = e (F.boundaryLabel (κ.pathMatch_mem hb)) := + relabel_boundaryLabel e F hmem' (κ.pathMatch_mem hb) + · have hb' : ¬ ((W.relabel e.toEquiv).boundaryFlag b + ∈ (F.relabelUp e.toEquiv).boundaryFlags) := by + rw [hbf, relabelUp_boundaryFlags e F] + exact hb + rw [dite_eq_right hb', dite_eq_right hb] + exact (e.apply_symm_apply b).symm + +/-- **The used labels shift through the relabel.** -/ +noncomputable def usedLabRelabelEquiv [LinearOrder α] {W : Fragment α} + {β : Type} [LinearOrder β] + (e : α ≃o β) (F : EdgeSubset W) : + {b : β // (W.relabel e.toEquiv).boundaryFlag b + ∈ (F.relabelUp e.toEquiv).boundaryFlags} + ≃ {a : α // W.boundaryFlag a ∈ F.boundaryFlags} where + toFun b := ⟨e.symm b.val, + (relabelUp_boundaryFlags e F) ▸ b.prop⟩ + invFun a := ⟨e a.val, + (relabelUp_boundaryFlags e F).symm ▸ + (show W.boundaryFlag (e.symm (e a.val)) ∈ F.boundaryFlags from + (e.symm_apply_apply a.val).symm ▸ a.prop)⟩ + left_inv b := Subtype.ext (e.apply_symm_apply b.val) + right_inv a := Subtype.ext (e.symm_apply_apply a.val) + +/-- **The chord matching shifts through the relabel**, on +pairings. -/ +theorem cutMatching_relabelUp_edge [LinearOrder α] {W : Fragment α} + {β : Type} [LinearOrder β] + (e : α ≃o β) (F : EdgeSubset W) (κ : F.RelTransitionSystem) + (o' : (relabelTransUp e.toEquiv F κ).Orientation) + (a : {a : α // W.boundaryFlag a ∈ F.boundaryFlags}) : + ((((cutMatching (F.relabelUp e.toEquiv) + (relabelTransUp e.toEquiv F κ) o').map + (usedLabRelabelEquiv e F)).edge a).val) + = chordInv F κ a.val := by + change e.symm (chordInv (F.relabelUp e.toEquiv) + (relabelTransUp e.toEquiv F κ) (e a.val)) + = chordInv F κ a.val + rw [chordInv_relabelUp e F κ (e a.val), e.symm_apply_apply, + e.symm_apply_apply] + +end ChordRelabel + +/-! ### The arcs' directions, as data + +RS21's Eulerian orientation directs every edge of the subset, +including one whose two ends are both labelled. The chain +orientation of a relative transition system directs only the +internal flags, so it fixes the direction of a chain but says +nothing about such an edge. The missing freedom is recorded here: +the directions of the chord matching's arcs are taken as data — any +directed matching on the used labels whose partner map is the chord +involution — and the chain orientation supplies one choice among +them. + +Only the directions enter the change of basis and its weight, so +both are stated against a bare direction function. +-/ + +/-- The used labels of a subset. -/ +abbrev UsedLab {W : Fragment α} + (F : EdgeSubset W) : Type := + {i : α // W.boundaryFlag i ∈ F.boundaryFlags} + +open Classical in +/-- Undo the dual basis against a given set of arc directions. -/ +noncomputable def untwistD {W : Fragment α} + {k ℓ : ℕ} (F : EdgeSubset W) + (tl : UsedLab F → Bool) (x : GenBoundaryState k ℓ α) : + GenBoundaryState k ℓ α := + fun i => + if h : W.boundaryFlag i ∈ F.boundaryFlags then + if tl ⟨i, h⟩ then + match x i with + | Sum.inl a => Sum.inl a + | Sum.inr c => Sum.inr (oddPartner ℓ c) + else x i + else x i + +open Classical in +/-- The dual basis's weight against a given set of arc +directions. -/ +noncomputable def dualWeightD {W : Fragment α} + [Fintype α] {k ℓ : ℕ} + (F : EdgeSubset W) (tl : UsedLab F → Bool) + (x : GenBoundaryState k ℓ α) : ℂ := + ∏ i : α, + if h : W.boundaryFlag i ∈ F.boundaryFlags then + if tl ⟨i, h⟩ then + match x i with + | Sum.inl _ => 1 + | Sum.inr c => dualSign ℓ c + else 1 + else 1 + +open Classical in +/-- Undo the dual basis: partner the colour at each leg the trail +leaves. -/ +noncomputable def untwist [LinearOrder α] {W : Fragment α} + {k ℓ : ℕ} (F : EdgeSubset W) + (κ : F.RelTransitionSystem) (o : κ.Orientation) + (x : GenBoundaryState k ℓ α) : GenBoundaryState k ℓ α := + fun i => + if h : W.boundaryFlag i ∈ F.boundaryFlags then + if (cutMatching F κ o).tail ⟨i, h⟩ then + match x i with + | Sum.inl a => Sum.inl a + | Sum.inr c => Sum.inr (oddPartner ℓ c) + else x i + else x i + +open Classical in +/-- **The dual basis's weight**: the partner signs at the legs the +trail leaves. -/ +noncomputable def dualWeight [LinearOrder α] {W : Fragment α} + [Fintype α] {k ℓ : ℕ} + (F : EdgeSubset W) (κ : F.RelTransitionSystem) + (o : κ.Orientation) (x : GenBoundaryState k ℓ α) : ℂ := + ∏ i : α, + if h : W.boundaryFlag i ∈ F.boundaryFlags then + if (cutMatching F κ o).tail ⟨i, h⟩ then + match x i with + | Sum.inl _ => 1 + | Sum.inr c => dualSign ℓ c + else 1 + else 1 + +/-! ### A chain flip touches only its own two labels + +The flip set of a ported chain consists of internal flags, and its +only exits are the two ports, whose partners are the chain's two +boundary flags. So a used label whose entry flag lies in the flip +set is one of those two. +-/ + +/-- **Only the chain's own two labels have their entry flag in the +flip set.** -/ +theorem label_of_pairing_mem_flipSet {W : Fragment α} + {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {S : Finset W.Flag} {p₁ p₂ : W.Flag} + {i₁ i₂ : α} (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) {i : α} + (hb : W.boundaryFlag i ∈ F.boundaryFlags) + (hmem : W.pairing (W.boundaryFlag i) ∈ S) : i = i₁ ∨ i = i₂ := by + by_cases h1 : W.pairing (W.boundaryFlag i) = p₁ + · refine Or.inl (W.boundaryFlag_injective ?_) + have hp := h.hσ₁ + rw [← h1, W.pairing_invol] at hp + exact hp + · by_cases h2 : W.pairing (W.boundaryFlag i) = p₂ + · refine Or.inr (W.boundaryFlag_injective ?_) + have hp := h.hσ₂ + rw [← h2, W.pairing_invol] at hp + exact hp + · exfalso + have hx := h.pairing_mem _ hmem h1 h2 + rw [W.pairing_invol] at hx + exact Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags (h.int_of_mem _ hx) hb + +/-- The chain's near port is the entry flag of its first label. -/ +theorem pairing_boundaryFlag_eq_port {W : Fragment α} + {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {S : Finset W.Flag} {p₁ p₂ : W.Flag} + {i₁ i₂ : α} (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) : + W.pairing (W.boundaryFlag i₁) = p₁ := by + rw [← h.hσ₁, W.pairing_invol] + +/-- And of its second. -/ +theorem pairing_boundaryFlag_eq_port' {W : Fragment α} + {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {S : Finset W.Flag} {p₁ p₂ : W.Flag} + {i₁ i₂ : α} (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) : + W.pairing (W.boundaryFlag i₂) = p₂ := by + rw [← h.hσ₂, W.pairing_invol] + +/-- A chain's own labels are not through-labels: their entry flags +are internal. -/ +theorem not_isThroughLabel_port {W : Fragment α} + {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {S : Finset W.Flag} {p₁ p₂ : W.Flag} + {i₁ i₂ : α} (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) : + ¬ IsThroughLabel F i₁ := by + intro hx + unfold IsThroughLabel at hx + rw [pairing_boundaryFlag_eq_port h] at hx + exact Finset.disjoint_left.mp F.internalFlags_disjoint_boundaryFlags + (h.int_of_mem _ h.hp₁S) hx + +/-- And the second. -/ +theorem not_isThroughLabel_port' {W : Fragment α} + {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {S : Finset W.Flag} {p₁ p₂ : W.Flag} + {i₁ i₂ : α} (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) : + ¬ IsThroughLabel F i₂ := by + intro hx + unfold IsThroughLabel at hx + rw [pairing_boundaryFlag_eq_port' h] at hx + exact Finset.disjoint_left.mp F.internalFlags_disjoint_boundaryFlags + (h.int_of_mem _ h.hp₂S) hx + +/-! ### A chain flip reverses one arc + +RS21's `M(ω′,κ′)` differs from `M(ω,κ)` by inverting one arc. In +the flag model that is exactly what a chain flip does: the tail +function changes at the chain's two labels and nowhere else, and +those two labels are the ends of one arc. +-/ + +open Classical in +/-- **A chain flip reverses exactly the chain's own arc.** -/ +theorem cutMatching_portFlip [LinearOrder α] {W : Fragment α} + {F : EdgeSubset W} + {κ : F.RelTransitionSystem} (o : κ.Orientation) + {S : Finset W.Flag} {p₁ p₂ : W.Flag} {i₁ i₂ : α} + (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (hb₁ : W.boundaryFlag i₁ ∈ F.boundaryFlags) + (hchord : chordInv F κ i₁ = i₂) : + cutMatching F κ (o.portFlip h) + = (cutMatching F κ o).reverseArc ⟨i₁, hb₁⟩ := by + refine DirMatching.ext rfl (funext fun j => ?_) + have hcond : (j = (⟨i₁, hb₁⟩ : {i : α // W.boundaryFlag i ∈ + F.boundaryFlags}) ∨ + j = (cutMatching F κ o).edge ⟨i₁, hb₁⟩) + ↔ (j.val = i₁ ∨ j.val = i₂) := by + constructor + · rintro (rfl | hx) + · exact Or.inl rfl + · exact Or.inr (by rw [hx]; exact hchord) + · rintro (hx | hx) + · exact Or.inl (Subtype.ext hx) + · exact Or.inr (Subtype.ext (by rw [hx]; exact hchord.symm)) + change (if IsThroughLabel F j.val then + decide (j.val < chordInv F κ j.val) + else !chainDir (o.portFlip h) (W.boundaryFlag j.val)) + = (if j = ⟨i₁, hb₁⟩ ∨ j = (cutMatching F κ o).edge ⟨i₁, hb₁⟩ + then !(cutMatching F κ o).tail j + else (cutMatching F κ o).tail j) + by_cases hnt : IsThroughLabel F j.val + · have hj : ¬ (j.val = i₁ ∨ j.val = i₂) := by + rintro (hx | hx) + · exact (not_isThroughLabel_port h) (hx ▸ hnt) + · exact (not_isThroughLabel_port' h) (hx ▸ hnt) + rw [ite_eq_left hnt, ite_eq_right (fun hx => hj (hcond.mp hx))] + change _ = if IsThroughLabel F j.val then + decide (j.val < chordInv F κ j.val) else _ + rw [ite_eq_left hnt] + · have htail : (cutMatching F κ o).tail j + = !chainDir o (W.boundaryFlag j.val) := by + change (if IsThroughLabel F j.val then + decide (j.val < chordInv F κ j.val) else _) = _ + rw [ite_eq_right hnt] + rw [ite_eq_right hnt, htail, chainDir_eq, chainDir_eq] + by_cases hj : j.val = i₁ ∨ j.val = i₂ + · have hmem : W.pairing (W.boundaryFlag j.val) ∈ S := by + rcases hj with hx | hx <;> rw [hx] + · rw [pairing_boundaryFlag_eq_port h]; exact h.hp₁S + · rw [pairing_boundaryFlag_eq_port' h]; exact h.hp₂S + rw [ite_eq_left (hcond.mpr hj), portFlip_isOut_of_mem o h hmem] + · have hnm : W.pairing (W.boundaryFlag j.val) ∉ S := fun hx => + hj (label_of_pairing_mem_flipSet h j.prop hx) + rw [ite_eq_right (fun hx => hj (hcond.mp hx)), + portFlip_isOut_of_notMem o h hnm] + +open Classical in +/-- **A used label whose chain has an interior admits a chain +flip.** This is the half of RS21's step 1 the chain orientation +provides: the trail through the interior can be inverted, and doing +so reverses exactly that label's arc. -/ +theorem exists_chainFlip [LinearOrder α] {W : Fragment α} + {F : EdgeSubset W} (κ : F.RelTransitionSystem) + (o : κ.Orientation) {i₁ : α} + (hb₁ : W.boundaryFlag i₁ ∈ F.boundaryFlags) + (hnt : ¬ IsThroughLabel F i₁) : + ∃ (S : Finset W.Flag) (p₁ p₂ : W.Flag) + (hp : PortedFlipSet κ S p₁ p₂ i₁ (chordInv F κ i₁)), + cutMatching F κ (o.portFlip hp) + = (cutMatching F κ o).reverseArc ⟨i₁, hb₁⟩ := by + obtain ⟨k, -, hcont, hpm⟩ := pathMatch_chain_length κ hb₁ + have hk : 1 ≤ k := by + by_contra hk0 + have hk' : k = 0 := by omega + subst hk' + refine hnt ?_ + have hmem := κ.pathMatch_mem hb₁ + rwa [hpm, iterWalk_zero] at hmem + have hterm : W.pairing (iterWalk κ (W.boundaryFlag i₁) k) + ∈ F.boundaryFlags := by + rw [← hpm] + exact κ.pathMatch_mem hb₁ + have hiγ : W.attach (W.pairing (iterWalk κ (W.boundaryFlag i₁) k)) + = Sum.inr (chordInv F κ i₁) := by + rw [← hpm, ← boundaryFlag_chordInv F κ hb₁] + exact W.attach_boundaryFlag _ + obtain ⟨S, hp, -, -⟩ := exists_chainPortedFlipSet κ hb₁ hcont hterm + hk (W.attach_boundaryFlag i₁) hiγ + exact ⟨S, _, _, hp, cutMatching_portFlip o hp hb₁ rfl⟩ + +/-! ### Evaluating the change of basis + +Undoing the dual basis acts pointwise: at a used label it partners +the colour exactly when the trail leaves that label, and elsewhere +it does nothing. +-/ + +open Classical in +/-- The change of basis at a used label. -/ +theorem untwist_apply_of_mem [LinearOrder α] {W : Fragment α} + {k ℓ : ℕ} (F : EdgeSubset W) + (κ : F.RelTransitionSystem) (o : κ.Orientation) + (x : GenBoundaryState k ℓ α) {i : α} + (hb : W.boundaryFlag i ∈ F.boundaryFlags) : + untwist F κ o x i + = if (cutMatching F κ o).tail ⟨i, hb⟩ then + (match x i with + | Sum.inl a => Sum.inl a + | Sum.inr c => Sum.inr (oddPartner ℓ c)) + else x i := + dite_eq_left hb + +open Classical in +/-- The change of basis is trivial off the used labels. -/ +theorem untwist_apply_of_not_mem [LinearOrder α] {W : Fragment α} + {k ℓ : ℕ} (F : EdgeSubset W) + (κ : F.RelTransitionSystem) (o : κ.Orientation) + (x : GenBoundaryState k ℓ α) {i : α} + (hb : W.boundaryFlag i ∉ F.boundaryFlags) : + untwist F κ o x i = x i := + dite_eq_right hb + +/-! ### The chain flip's effect on the dual basis + +Reversing a chain exchanges which of its two ends is the tail, so +undoing the dual basis after the flip is undoing it before with the +two ends' colours partnered — which is the state flip the summand's +own chain-flip ledger produces. +-/ + +/-- The dual basis's per-label weight squares to one. -/ +theorem dualFactor_sq {k ℓ : ℕ} (v : Fin k ⊕ Fin (2 * ℓ)) : + (match v with + | Sum.inl _ => (1 : ℂ) + | Sum.inr c => dualSign ℓ c) * + (match v with + | Sum.inl _ => (1 : ℂ) + | Sum.inr c => dualSign ℓ c) = 1 := by + rcases v with a | c + · norm_num + · exact oddPartnerSign_cast_sq ℓ c + +section ChainFlip + +open Classical in +/-- The direction flips at the chain's two labels. -/ +theorem tail_portFlip_of_mem [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} (o : κ.Orientation) {S : Finset W.Flag} + {p₁ : W.Flag} {p₂ : W.Flag} {i₁ : α} {i₂ : α} + (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (hb₁ : W.boundaryFlag i₁ ∈ F.boundaryFlags) + (hchord : chordInv F κ i₁ = i₂) + {i : α} + (hb : W.boundaryFlag i ∈ F.boundaryFlags) + (hj : i = i₁ ∨ i = i₂) : + (cutMatching F κ (o.portFlip h)).tail ⟨i, hb⟩ + = !(cutMatching F κ o).tail ⟨i, hb⟩ := by + rw [show (cutMatching F κ (o.portFlip h)).tail ⟨i, hb⟩ + = ((cutMatching F κ o).reverseArc ⟨i₁, hb₁⟩).tail ⟨i, hb⟩ + from by rw [cutMatching_portFlip o h hb₁ hchord], + DirMatching.reverseArc_tail, ite_eq_left] + rcases hj with hx | hx + · exact Or.inl (Subtype.ext hx) + · exact Or.inr (Subtype.ext (hx.trans hchord.symm)) + +open Classical in +/-- And nowhere else. -/ +theorem tail_portFlip_of_not_mem + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} (o : κ.Orientation) {S : Finset W.Flag} + {p₁ : W.Flag} {p₂ : W.Flag} {i₁ : α} {i₂ : α} + (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (hb₁ : W.boundaryFlag i₁ ∈ F.boundaryFlags) + (hchord : chordInv F κ i₁ = i₂) + {i : α} + (hb : W.boundaryFlag i ∈ F.boundaryFlags) + (hj : ¬ (i = i₁ ∨ i = i₂)) : + (cutMatching F κ (o.portFlip h)).tail ⟨i, hb⟩ + = (cutMatching F κ o).tail ⟨i, hb⟩ := by + rw [show (cutMatching F κ (o.portFlip h)).tail ⟨i, hb⟩ + = ((cutMatching F κ o).reverseArc ⟨i₁, hb₁⟩).tail ⟨i, hb⟩ + from by rw [cutMatching_portFlip o h hb₁ hchord], + DirMatching.reverseArc_tail, ite_eq_right] + rintro (hx | hx) + · exact hj (Or.inl (congrArg Subtype.val hx)) + · refine hj (Or.inr ?_) + exact (congrArg Subtype.val hx).trans hchord + +open Classical in +/-- **A chain flip partners the two chain ends.** -/ +theorem untwist_portFlip [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} (o : κ.Orientation) {S : Finset W.Flag} + {p₁ : W.Flag} {p₂ : W.Flag} {i₁ : α} {i₂ : α} + (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (hb₁ : W.boundaryFlag i₁ ∈ F.boundaryFlags) + (hchord : chordInv F κ i₁ = i₂) + {k ℓ : ℕ} (x : GenBoundaryState k ℓ α) : + untwist F κ (o.portFlip h) x + = stateOddFlip (untwist F κ o x) i₁ i₂ := by + have hb₂ : W.boundaryFlag i₂ ∈ F.boundaryFlags := by + rw [← hchord]; exact chordInv_mem F κ hb₁ + have hflip : ∀ (i : α) (hb : W.boundaryFlag i ∈ F.boundaryFlags), + i = i₁ ∨ i = i₂ → + untwist F κ (o.portFlip h) x i + = Sum.map id (oddPartner ℓ) (untwist F κ o x i) := by + intro i hb hj + rw [untwist_apply_of_mem F κ (o.portFlip h) x hb, + untwist_apply_of_mem F κ o x hb, + tail_portFlip_of_mem o h hb₁ hchord hb hj] + by_cases ht : (cutMatching F κ o).tail ⟨i, hb⟩ = true + · rw [ht, Bool.not_true, ite_eq_right (by simp), ite_eq_left rfl] + rcases hx : x i with a | c + · rfl + · change Sum.inr c + = Sum.map id (oddPartner ℓ) (Sum.inr (oddPartner ℓ c)) + rw [Sum.map_inr, oddPartner_invol] + · rw [Bool.eq_false_iff.mpr ht, Bool.not_false, ite_eq_left rfl, + ite_eq_right (by simp)] + rcases hx : x i with a | c <;> rfl + funext i + by_cases h1 : i = i₁ + · subst h1 + rw [stateOddFlip_left] + exact hflip i hb₁ (Or.inl rfl) + · by_cases h2 : i = i₂ + · subst h2 + rw [stateOddFlip_right] + exact hflip i hb₂ (Or.inr rfl) + · rw [stateOddFlip_of_ne h1 h2] + by_cases hb : W.boundaryFlag i ∈ F.boundaryFlags + · rw [untwist_apply_of_mem F κ (o.portFlip h) x hb, + untwist_apply_of_mem F κ o x hb, + tail_portFlip_of_not_mem o h hb₁ hchord hb + (fun hx => hx.elim h1 h2)] + · rw [untwist_apply_of_not_mem F κ (o.portFlip h) x hb, + untwist_apply_of_not_mem F κ o x hb] + +open Classical in +/-- **The chain flip's weight**: the dual basis's weights before and +after a chain flip multiply to the two chain ends' signs, since they +differ exactly at those two labels and every factor squares to +one. -/ +theorem dualWeight_portFlip_mul + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} (o : κ.Orientation) {S : Finset W.Flag} + {p₁ : W.Flag} {p₂ : W.Flag} {i₁ : α} {i₂ : α} + (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (hb₁ : W.boundaryFlag i₁ ∈ F.boundaryFlags) + (hchord : chordInv F κ i₁ = i₂) + [Fintype α] {k ℓ : ℕ} + (x : GenBoundaryState k ℓ α) {c₁ c₂ : Fin (2 * ℓ)} + (hc₁ : x i₁ = Sum.inr c₁) (hc₂ : x i₂ = Sum.inr c₂) : + dualWeight F κ (o.portFlip h) x * dualWeight F κ o x + = dualSign ℓ c₁ * dualSign ℓ c₂ := by + have hb₂ : W.boundaryFlag i₂ ∈ F.boundaryFlags := by + rw [← hchord]; exact chordInv_mem F κ hb₁ + have hne : i₁ ≠ i₂ := h.hlab + unfold dualWeight + rw [← Finset.prod_mul_distrib] + have hpair : ∀ i ∈ (Finset.univ : Finset α), i ∉ ({i₁, i₂} : + Finset α) → + ((if hb : W.boundaryFlag i ∈ F.boundaryFlags then + (if (cutMatching F κ (o.portFlip h)).tail ⟨i, hb⟩ then + (match x i with + | Sum.inl _ => 1 + | Sum.inr c => dualSign ℓ c) + else 1) else 1) * + (if hb : W.boundaryFlag i ∈ F.boundaryFlags then + (if (cutMatching F κ o).tail ⟨i, hb⟩ then + (match x i with + | Sum.inl _ => 1 + | Sum.inr c => dualSign ℓ c) + else 1) else 1)) = 1 := by + intro i _ hi + have hj : ¬ (i = i₁ ∨ i = i₂) := by + rintro (rfl | rfl) <;> exact hi (by simp) + by_cases hb : W.boundaryFlag i ∈ F.boundaryFlags + · rw [dite_eq_left hb, dite_eq_left hb, + tail_portFlip_of_not_mem o h hb₁ hchord hb hj] + by_cases ht : (cutMatching F κ o).tail ⟨i, hb⟩ = true + · rw [ite_eq_left ht] + exact dualFactor_sq (x i) + · rw [ite_eq_right ht] + norm_num + · rw [dite_eq_right hb, dite_eq_right hb] + norm_num + rw [← Finset.prod_subset (Finset.subset_univ ({i₁, i₂} : + Finset α)) hpair, Finset.prod_pair hne, + dite_eq_left hb₁, dite_eq_left hb₂, dite_eq_left hb₁, dite_eq_left hb₂, + tail_portFlip_of_mem o h hb₁ hchord hb₁ (Or.inl rfl), + tail_portFlip_of_mem o h hb₁ hchord hb₂ (Or.inr rfl), hc₁, hc₂] + by_cases t₁ : (cutMatching F κ o).tail ⟨i₁, hb₁⟩ = true <;> + by_cases t₂ : (cutMatching F κ o).tail ⟨i₂, hb₂⟩ = true <;> + simp [t₁, t₂, Bool.eq_false_iff.mpr] + +end ChainFlip + +open Classical in +/-- The change of basis at an odd used label. -/ +theorem untwist_apply_odd [LinearOrder α] {W : Fragment α} + {k ℓ : ℕ} (F : EdgeSubset W) + (κ : F.RelTransitionSystem) (o : κ.Orientation) + (x : GenBoundaryState k ℓ α) {i : α} + (hb : W.boundaryFlag i ∈ F.boundaryFlags) {c : Fin (2 * ℓ)} + (hc : x i = Sum.inr c) : + untwist F κ o x i + = Sum.inr (if (cutMatching F κ o).tail ⟨i, hb⟩ then + oddPartner ℓ c else c) := by + rw [untwist_apply_of_mem F κ o x hb, hc] + by_cases ht : (cutMatching F κ o).tail ⟨i, hb⟩ = true + · rw [ite_eq_left ht, ite_eq_left ht] + · rw [ite_eq_right ht, ite_eq_right ht] + +/-! ### Reversing one arc's direction + +RS21's (12) inverts a directed trail. When the trail is a single +edge joining two labelled ends there is nothing inside to invert, so +the whole effect is on the dual basis: the leg that carried `g` +carries `f` and the other way about. The two legs' weights are +therefore exchanged, and since the two ends of an arc carry partner +colours, the exchange costs a sign. +-/ + +section OrderFreeArc + +open Classical in +/-- **Reversing an arc exchanges the two legs' weights**, at a cost +of one sign. The hypothesis is the support condition: the two ends +of an arc carry partner colours. -/ +theorem dualWeightD_reverseArc_mul {W : Fragment α} + [Fintype α] [DecidableEq α] + {k ℓ : ℕ} (F : EdgeSubset W) (M : DirMatching (UsedLab F)) + (a : UsedLab F) (x : GenBoundaryState k ℓ α) + {c : Fin (2 * ℓ)} (hta : M.tail a = true) + (hca : x a.val = Sum.inr c) + (hca' : x (M.edge a).val = Sum.inr (oddPartner ℓ c)) : + dualWeightD F (M.reverseArc a).tail x + * dualWeightD F M.tail x = -1 := by + have hane : (M.edge a).val ≠ a.val := fun hx => + M.edge_ne a (Subtype.ext hx) + unfold dualWeightD + rw [← Finset.prod_mul_distrib] + have hfac : ∀ i : α, i ≠ a.val → i ≠ (M.edge a).val → + ((if h : W.boundaryFlag i ∈ F.boundaryFlags then + if (M.reverseArc a).tail ⟨i, h⟩ then + match x i with + | Sum.inl _ => 1 + | Sum.inr d => dualSign ℓ d + else 1 + else 1) * + (if h : W.boundaryFlag i ∈ F.boundaryFlags then + if M.tail ⟨i, h⟩ then + match x i with + | Sum.inl _ => 1 + | Sum.inr d => dualSign ℓ d + else 1 + else 1)) = 1 := by + intro i h1 h2 + by_cases hb : W.boundaryFlag i ∈ F.boundaryFlags + · rw [dite_eq_left hb, dite_eq_left hb, + show (M.reverseArc a).tail ⟨i, hb⟩ = M.tail ⟨i, hb⟩ from by + rw [DirMatching.reverseArc_tail] + exact ite_eq_right (by + rintro (hx | hx) + · exact h1 (congrArg Subtype.val hx) + · exact h2 (congrArg Subtype.val hx))] + by_cases ht : M.tail ⟨i, hb⟩ = true + · rw [ite_eq_left ht] + exact dualFactor_sq (x i) + · rw [ite_eq_right ht] + norm_num + · rw [dite_eq_right hb, dite_eq_right hb] + norm_num + have hpair : ∀ f : α → ℂ, (∀ i, i ≠ a.val → i ≠ (M.edge a).val → + f i = 1) → (∏ i : α, f i) = f a.val * f (M.edge a).val := by + intro f hf + rw [← Finset.prod_subset + (Finset.subset_univ ({a.val, (M.edge a).val} : Finset α)) + (fun i _ hi => by + rw [Finset.mem_insert, Finset.mem_singleton] at hi + push Not at hi + exact hf i hi.1 hi.2), + Finset.prod_pair (Ne.symm hane)] + rw [hpair _ hfac] + have ha : (⟨a.val, a.prop⟩ : UsedLab F) = a := Subtype.ext rfl + have ha' : (⟨(M.edge a).val, (M.edge a).prop⟩ : UsedLab F) + = M.edge a := Subtype.ext rfl + have htb : M.tail (M.edge a) = false := by + rw [M.tail_flip a, hta] + rfl + rw [dite_eq_left a.prop, dite_eq_left a.prop, dite_eq_left (M.edge a).prop, + dite_eq_left (M.edge a).prop] + rw [show (M.reverseArc a).tail ⟨a.val, a.prop⟩ = false from by + rw [ha, DirMatching.reverseArc_tail, ite_eq_left (Or.inl rfl), hta] + rfl, + show M.tail ⟨a.val, a.prop⟩ = true from by rw [ha]; exact hta, + show (M.reverseArc a).tail ⟨(M.edge a).val, (M.edge a).prop⟩ + = true from by + rw [ha', DirMatching.reverseArc_tail, ite_eq_left (Or.inr rfl), htb] + rfl, + show M.tail ⟨(M.edge a).val, (M.edge a).prop⟩ = false from by + rw [ha']; exact htb] + rw [ite_eq_right (by simp), ite_eq_left rfl, ite_eq_left rfl, ite_eq_right (by simp), + hca, hca'] + change (1 * dualSign ℓ c) * (dualSign ℓ (oddPartner ℓ c) * 1) = -1 + rw [dualSign_oddPartner] + have hsq := dualSign_sq ℓ c + linear_combination -hsq + +open Classical in +/-- The change of basis at a used leg. -/ +theorem untwistD_apply_mem {W : Fragment α} + {k ℓ : ℕ} (F : EdgeSubset W) + (tl : UsedLab F → Bool) (x : GenBoundaryState k ℓ α) {i : α} + (hb : W.boundaryFlag i ∈ F.boundaryFlags) : + untwistD F tl x i + = if tl ⟨i, hb⟩ then Sum.map id (oddPartner ℓ) (x i) + else x i := by + unfold untwistD + rw [dite_eq_left hb] + by_cases ht : tl ⟨i, hb⟩ = true + · rw [ite_eq_left ht, ite_eq_left ht] + rcases x i with a | c <;> rfl + · rw [ite_eq_right ht, ite_eq_right ht] + +open Classical in +/-- The change of basis away from the used legs. -/ +theorem untwistD_apply_not_mem {W : Fragment α} + {k ℓ : ℕ} (F : EdgeSubset W) + (tl : UsedLab F → Bool) (x : GenBoundaryState k ℓ α) {i : α} + (hb : W.boundaryFlag i ∉ F.boundaryFlags) : + untwistD F tl x i = x i := dite_eq_right hb + +open Classical in +/-- **Reversing an arc partners the colour at its two legs.** -/ +theorem untwistD_reverseArc {W : Fragment α} + [DecidableEq α] {k ℓ : ℕ} + (F : EdgeSubset W) (M : DirMatching (UsedLab F)) (a : UsedLab F) + (x : GenBoundaryState k ℓ α) : + untwistD F (M.reverseArc a).tail x + = stateOddFlip (untwistD F M.tail x) a.val (M.edge a).val := by + have hinv : ∀ v : Fin k ⊕ Fin (2 * ℓ), + Sum.map id (oddPartner ℓ) (Sum.map id (oddPartner ℓ) v) = v := by + rintro (b | d) + · rfl + · change Sum.inr (oddPartner ℓ (oddPartner ℓ d)) = Sum.inr d + rw [oddPartner_invol] + funext i + by_cases hi₁ : i = a.val + · rw [hi₁, stateOddFlip_left, untwistD_apply_mem F _ x a.prop, + untwistD_apply_mem F _ x a.prop, + show (M.reverseArc a).tail ⟨a.val, a.prop⟩ + = !M.tail ⟨a.val, a.prop⟩ from by + rw [DirMatching.reverseArc_tail] + exact ite_eq_left (Or.inl (Subtype.ext rfl))] + by_cases ht : M.tail ⟨a.val, a.prop⟩ = true + · rw [ht, Bool.not_true, ite_eq_right (by simp), ite_eq_left rfl, hinv] + · have htf : M.tail ⟨a.val, a.prop⟩ = false := by + cases hbb : M.tail ⟨a.val, a.prop⟩ + · rfl + · exact absurd hbb ht + rw [htf, Bool.not_false, ite_eq_left rfl, ite_eq_right (by simp)] + · by_cases hi₂ : i = (M.edge a).val + · rw [hi₂, stateOddFlip_right, + untwistD_apply_mem F _ x (M.edge a).prop, + untwistD_apply_mem F _ x (M.edge a).prop, + show (M.reverseArc a).tail ⟨(M.edge a).val, (M.edge a).prop⟩ + = !M.tail ⟨(M.edge a).val, (M.edge a).prop⟩ from by + rw [DirMatching.reverseArc_tail] + exact ite_eq_left (Or.inr (Subtype.ext rfl))] + by_cases ht : M.tail ⟨(M.edge a).val, (M.edge a).prop⟩ = true + · rw [ht, Bool.not_true, ite_eq_right (by simp), ite_eq_left rfl, hinv] + · have htf : M.tail ⟨(M.edge a).val, (M.edge a).prop⟩ + = false := by + cases hbb : M.tail ⟨(M.edge a).val, (M.edge a).prop⟩ + · rfl + · exact absurd hbb ht + rw [htf, Bool.not_false, ite_eq_left rfl, ite_eq_right (by simp)] + · rw [stateOddFlip_of_ne hi₁ hi₂] + by_cases hb : W.boundaryFlag i ∈ F.boundaryFlags + · rw [untwistD_apply_mem F _ x hb, untwistD_apply_mem F _ x hb, + show (M.reverseArc a).tail ⟨i, hb⟩ = M.tail ⟨i, hb⟩ from by + rw [DirMatching.reverseArc_tail] + exact ite_eq_right (by + rintro (hx | hx) + · exact hi₁ (congrArg Subtype.val hx) + · exact hi₂ (congrArg Subtype.val hx))] + · rw [untwistD_apply_not_mem F _ x hb, + untwistD_apply_not_mem F _ x hb] + +open Classical in +/-- The dual basis's weight at given arc directions squares to +one. -/ +theorem dualWeightD_mul_self {W : Fragment α} + [Fintype α] {k ℓ : ℕ} + (F : EdgeSubset W) (tl : UsedLab F → Bool) + (x : GenBoundaryState k ℓ α) : + dualWeightD F tl x * dualWeightD F tl x = 1 := by + unfold dualWeightD + rw [← Finset.prod_mul_distrib] + refine Finset.prod_eq_one (fun i _ => ?_) + by_cases hb : W.boundaryFlag i ∈ F.boundaryFlags + · rw [dite_eq_left hb] + by_cases ht : tl ⟨i, hb⟩ = true + · rw [ite_eq_left ht] + exact dualFactor_sq (x i) + · rw [ite_eq_right ht] + norm_num + · rw [dite_eq_right hb] + norm_num + +open Classical in +/-- **The change of basis preserves which legs are odd**, so the +subset-matching condition does not see the arc directions. -/ +theorem genBoundarySubsetMatches_untwistD {W : Fragment α} + {k ℓ : ℕ} + (F : EdgeSubset W) (tl : UsedLab F → Bool) + (x : GenBoundaryState k ℓ α) : + genBoundarySubsetMatches W F.flags (untwistD F tl x) + ↔ genBoundarySubsetMatches W F.flags x := by + have hodd : ∀ i : α, (∃ c, untwistD F tl x i = Sum.inr c) + ↔ (∃ c, x i = Sum.inr c) := by + intro i + by_cases hb : W.boundaryFlag i ∈ F.boundaryFlags + · rw [untwistD_apply_mem F tl x hb] + by_cases ht : tl ⟨i, hb⟩ = true + · rw [ite_eq_left ht] + rcases hx : x i with a | c + · exact ⟨fun ⟨d, hd⟩ => absurd hd (by simp), fun ⟨d, hd⟩ => + absurd hd (by simp)⟩ + · exact ⟨fun _ => ⟨c, rfl⟩, + fun _ => ⟨oddPartner ℓ c, rfl⟩⟩ + · rw [ite_eq_right ht] + · rw [untwistD_apply_not_mem F tl x hb] + constructor + · intro hm i + exact (hm i).trans (hodd i) + · intro hm i + exact (hm i).trans (hodd i).symm + +end OrderFreeArc + +open Classical in +/-- The dual basis's weight squares to one. -/ +theorem dualWeight_mul_self [LinearOrder α] {W : Fragment α} + [Fintype α] {k ℓ : ℕ} + (F : EdgeSubset W) (κ : F.RelTransitionSystem) + (o : κ.Orientation) (x : GenBoundaryState k ℓ α) : + dualWeight F κ o x * dualWeight F κ o x = 1 := by + unfold dualWeight + rw [← Finset.prod_mul_distrib] + refine Finset.prod_eq_one (fun i _ => ?_) + by_cases hb : W.boundaryFlag i ∈ F.boundaryFlags + · rw [dite_eq_left hb] + by_cases ht : (cutMatching F κ o).tail ⟨i, hb⟩ = true + · rw [ite_eq_left ht] + exact dualFactor_sq (x i) + · rw [ite_eq_right ht] + norm_num + · rw [dite_eq_right hb] + norm_num + +/-! ### The through-edge product ignores a chain flip + +A chain's two labels are not through-labels, so flipping the state +there leaves every through-edge's two colours alone. +-/ + +open Classical in +/-- A through-flag's own label is a through-label. -/ +theorem isThroughLabel_of_mem_throughFlags {W : Fragment α} + {F : EdgeSubset W} + {f : W.Flag} (hf : f ∈ F.throughFlags) {i : α} + (hi : W.attach f = Sum.inr i) : IsThroughLabel F i := by + obtain ⟨hmem, -, ⟨j, hj⟩⟩ := mem_throughFlags_iff.mp hf + have hfe : f = W.boundaryFlag i := W.eq_boundaryFlag i f hi + unfold IsThroughLabel + rw [← hfe] + exact Finset.mem_filter.mpr ⟨F.pairing_mem f hmem, ⟨j, hj⟩⟩ + +open Classical in +/-- A used through-label's flag is a through-flag. -/ +theorem mem_throughFlags_of_isThroughLabel {W : Fragment α} + {F : EdgeSubset W} {i : α} + (hb : W.boundaryFlag i ∈ F.boundaryFlags) + (hit : IsThroughLabel F i) : + W.boundaryFlag i ∈ F.throughFlags := + mem_throughFlags_iff.mpr ⟨mem_flags_of_boundaryFlags F hb, + ⟨i, W.attach_boundaryFlag i⟩, (Finset.mem_filter.mp hit).2⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CutSubsetSum.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CutSubsetSum.lean new file mode 100644 index 0000000000..60b7c18f40 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CutSubsetSum.lean @@ -0,0 +1,172 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSubsetBij + +/-! +# Subset sums split across a single cut + +A weight that vanishes off the pairing-closed subsets sums the same +over all subsets of `W` as over the lifts of the subsets of the glued +fragment. At a closed cut the lifts are indexed by a `Bool` — whether +the cut edge is taken — and at an open cut there is one lift per glued +subset. + +This is the reindexing half of a one-cut descent: it says that summing +over `W`'s subsets *is* summing over the glued fragment's subsets and +the cut's own data, with nothing left over. Both halves are the round +trips of `GlueSubsetBij`: `dropSubset` recovers the glued subset, +`liftSubsetClosed`/`liftSubsetOpen` recover the original, and a +pairing-closed subset is always a lift. +-/ + +@[expose] public section + +namespace RS + + + +namespace Fragment + +variable {α : Type} {W : Fragment α} {i j : α} + +/-! ### The cut's two ends -/ + +/-- The extension takes the prescribed value at the first cut +label. -/ +theorem extendPair_left {k ℓ : ℕ} {α : Type} (i j : α) + (st : GenBoundaryState k ℓ (SurvivingLabel α i j)) + (c c' : Fin k ⊕ Fin (2 * ℓ)) : + GenBoundaryState.extendPair i j st c c' i = c := by + classical + unfold GenBoundaryState.extendPair + rw [dite_eq_left rfl] + +/-- And at the second, when the two are distinct. -/ +theorem extendPair_right {k ℓ : ℕ} {α : Type} {i j : α} + (hij : i ≠ j) + (st : GenBoundaryState k ℓ (SurvivingLabel α i j)) + (c c' : Fin k ⊕ Fin (2 * ℓ)) : + GenBoundaryState.extendPair i j st c c' j = c' := by + classical + unfold GenBoundaryState.extendPair + rw [dite_eq_right (Ne.symm hij), dite_eq_left rfl] + +/-- And the restriction elsewhere. -/ +theorem extendPair_surviving {k ℓ : ℕ} {α : Type} (i j : α) + (st : GenBoundaryState k ℓ (SurvivingLabel α i j)) + (c c' : Fin k ⊕ Fin (2 * ℓ)) (x : SurvivingLabel α i j) : + GenBoundaryState.extendPair i j st c c' x.val = st x := by + classical + unfold GenBoundaryState.extendPair + rw [dite_eq_right x.prop.1, dite_eq_right x.prop.2] + +/-! ### The closed cut -/ + +/-- At a closed cut the two lifts of distinct glued subsets are +distinct, and a lift determines which of the two it is. -/ +theorem liftSubsetClosed_injective (hij : i ≠ j) : + Function.Injective + (fun p : Finset (SurvivingFlag W i j) × Bool => + liftSubsetClosed p.1 p.2) := by + rintro ⟨s₁, b₁⟩ ⟨s₂, b₂⟩ hst + have hst' : liftSubsetClosed s₁ b₁ = liftSubsetClosed s₂ b₂ := hst + have hs : s₁ = s₂ := by + have h1 := dropSubset_liftSubsetClosed (W := W) (i := i) (j := j) + s₁ b₁ + have h2 := dropSubset_liftSubsetClosed (W := W) (i := i) (j := j) + s₂ b₂ + rw [← h1, ← h2, hst'] + have hb : b₁ = b₂ := by + have h1 := boundaryFlagI_mem_liftClosed_iff (W := W) (i := i) + (j := j) hij s₁ b₁ + have h2 := boundaryFlagI_mem_liftClosed_iff (W := W) (i := i) + (j := j) hij s₂ b₂ + rw [hst'] at h1 + simpa using h1.symm.trans h2 + exact Prod.ext hs hb + +open Finset in +/-- **The subset sum splits at a closed cut.** A weight vanishing off +the pairing-closed subsets sums over all subsets of `W` exactly as it +sums over the glued subsets and the two lifts. -/ +theorem sum_split_closed (hij : i ≠ j) + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (X : Finset W.Flag → ℂ) + (hz : ∀ sb : Finset W.Flag, + ¬ (∀ f ∈ sb, W.pairing f ∈ sb) → X sb = 0) : + (∑ sb : Finset W.Flag, X sb) + = ∑ s' : Finset (SurvivingFlag W i j), ∑ b : Bool, + X (liftSubsetClosed s' b) := by + classical + have himg : ∀ sb ∈ (univ : Finset (Finset W.Flag)), + sb ∉ (univ : Finset (Finset (SurvivingFlag W i j) × Bool)).image + (fun p => liftSubsetClosed p.1 p.2) → X sb = 0 := by + intro sb _ hnot + refine hz sb (fun hcl => hnot ?_) + exact mem_image.mpr + ⟨(W.dropSubset i j sb, decide (W.boundaryFlag i ∈ sb)), + mem_univ _, liftSubsetClosed_dropSubset hij hclosed sb hcl⟩ + calc (∑ sb : Finset W.Flag, X sb) + = ∑ sb ∈ (univ : Finset (Finset (SurvivingFlag W i j) × Bool)).image + (fun p => liftSubsetClosed p.1 p.2), X sb := + (Finset.sum_subset (Finset.subset_univ _) himg).symm + _ = ∑ p : Finset (SurvivingFlag W i j) × Bool, + X (liftSubsetClosed p.1 p.2) := + Finset.sum_image + (fun x _ y _ hxy => liftSubsetClosed_injective hij hxy) + _ = ∑ s' : Finset (SurvivingFlag W i j), ∑ b : Bool, + X (liftSubsetClosed s' b) := Fintype.sum_prod_type _ + +/-! ### The open cut -/ + +/-- At an open cut distinct glued subsets have distinct lifts. -/ +theorem liftSubsetOpen_injective + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) : + Function.Injective + (fun s' : Finset (SurvivingFlag W i j) => + liftSubsetOpen hopen s') := by + intro s₁ s₂ hst + have hst' : liftSubsetOpen hopen s₁ = liftSubsetOpen hopen s₂ := + hst + have h1 := dropSubset_liftSubsetOpen (W := W) (i := i) (j := j) + hopen s₁ + have h2 := dropSubset_liftSubsetOpen (W := W) (i := i) (j := j) + hopen s₂ + rw [← h1, ← h2, hst'] + +open Finset in +/-- **The subset sum splits at an open cut.** -/ +theorem sum_split_open (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (X : Finset W.Flag → ℂ) + (hz : ∀ sb : Finset W.Flag, + ¬ (∀ f ∈ sb, W.pairing f ∈ sb) → X sb = 0) : + (∑ sb : Finset W.Flag, X sb) + = ∑ s' : Finset (SurvivingFlag W i j), + X (liftSubsetOpen hopen s') := by + classical + have himg : ∀ sb ∈ (univ : Finset (Finset W.Flag)), + sb ∉ (univ : Finset (Finset (SurvivingFlag W i j))).image + (fun s' => liftSubsetOpen hopen s') → X sb = 0 := by + intro sb _ hnot + refine hz sb (fun hcl => hnot ?_) + exact mem_image.mpr ⟨W.dropSubset i j sb, mem_univ _, + liftSubsetOpen_dropSubset hij hopen sb hcl⟩ + calc (∑ sb : Finset W.Flag, X sb) + = ∑ sb ∈ (univ : Finset (Finset (SurvivingFlag W i j))).image + (fun s' => liftSubsetOpen hopen s'), X sb := + (Finset.sum_subset (Finset.subset_univ _) himg).symm + _ = ∑ s' : Finset (SurvivingFlag W i j), + X (liftSubsetOpen hopen s') := + Finset.sum_image + (fun x _ y _ hxy => liftSubsetOpen_injective hopen hxy) + +end Fragment + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DirMatching.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DirMatching.lean new file mode 100644 index 0000000000..52ae6e7982 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DirMatching.lean @@ -0,0 +1,2229 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OrbitCard +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InvolutionCard + +/-! +# Directed perfect matchings and the rotation of their union + +A directed perfect matching is a fixed-point-free involution +together with a choice of tail at each edge. Two of them on the +same set have a union in which every point carries one arc of each, +so the union decomposes into alternating cycles. + +When the union is Eulerian — at every point one arc enters and one +leaves — the cycles are coherently directed, and following the arc +that leaves is a permutation whose cycles are exactly the union's +components. That permutation carries the second matching to the +first, direction and all, and its sign is `(-1)` to the number of +components, because every component has even length. + +This is the sign lemma the Gram identity for mixed partition +functions runs on: the product of two matchings' signs is `(-1)` to +the number of components of their union. +-/ + +@[expose] public section + +namespace RS + +open Equiv Function + +/-- A directed perfect matching: a fixed-point-free involution with +a chosen tail at each edge. -/ +structure DirMatching (α : Type) where + /-- The matched partner. -/ + edge : α → α + /-- The partner map is an involution. -/ + edge_invol : ∀ a, edge (edge a) = a + /-- No point is its own partner. -/ + edge_ne : ∀ a, edge a ≠ a + /-- Whether the arc at this point leaves it. -/ + tail : α → Bool + /-- Each arc leaves exactly one of its two ends. -/ + tail_flip : ∀ a, tail (edge a) = !tail a + +namespace DirMatching + +variable {α : Type} + +/-- **The union is Eulerian**: at every point exactly one of the two +matchings' arcs leaves it. -/ +def Alternating (M N : DirMatching α) : Prop := + ∀ a, N.tail a = !M.tail a + +/-- The rotation of an Eulerian union: follow the arc that leaves. -/ +def rot (M N : DirMatching α) (a : α) : α := + if M.tail a then M.edge a else N.edge a + +/-- The step backwards: follow the arc that enters. -/ +def rotInv (M N : DirMatching α) (a : α) : α := + if M.tail a then N.edge a else M.edge a + +variable {M N : DirMatching α} + +/-- Along an Eulerian union the second matching's tails are the +first's, flipped. -/ +theorem tail_edge_alt (h : Alternating M N) (a : α) : + M.tail (N.edge a) = !M.tail a := by + have h1 : N.tail (N.edge a) = !N.tail a := N.tail_flip a + rw [h (N.edge a), h a, Bool.not_not] at h1 + rw [← h1, Bool.not_not] + +/-- The rotation lands on the other end of the arc it followed. -/ +theorem tail_rot (h : Alternating M N) (a : α) : + M.tail (M.rot N a) = !M.tail a := by + unfold rot + by_cases ha : M.tail a = true + · rw [ite_eq_left ha, M.tail_flip a] + · rw [ite_eq_right ha, tail_edge_alt h a] + +/-- The rotation is undone by the backward step. -/ +theorem rotInv_rot (h : Alternating M N) (a : α) : + M.rotInv N (M.rot N a) = a := by + unfold rot rotInv + by_cases ha : M.tail a = true + · rw [ite_eq_left ha, ite_eq_right (by rw [M.tail_flip a, ha]; simp), + M.edge_invol] + · rw [ite_eq_right ha, ite_eq_left (by rw [tail_edge_alt h a]; simp [ha]), + N.edge_invol] + +/-- And undoes it. -/ +theorem rot_rotInv (h : Alternating M N) (a : α) : + M.rot N (M.rotInv N a) = a := by + unfold rot rotInv + by_cases ha : M.tail a = true + · rw [ite_eq_left ha, ite_eq_right (by rw [tail_edge_alt h a, ha]; simp), + N.edge_invol] + · rw [ite_eq_right ha, ite_eq_left (by rw [M.tail_flip a]; simp [ha]), + M.edge_invol] + +/-- **The rotation of an Eulerian union**, as a permutation. -/ +def rotPerm (M N : DirMatching α) (h : Alternating M N) : + Equiv.Perm α where + toFun := M.rot N + invFun := M.rotInv N + left_inv := rotInv_rot h + right_inv := rot_rotInv h + +/-- The rotation permutation acts by following the arc that +leaves. -/ +@[simp] +theorem rotPerm_apply (h : Alternating M N) (a : α) : + M.rotPerm N h a = M.rot N a := rfl + +/-- **The rotation reaches the first matching's partner.** Together +with the next lemma this is the statement that the rotation's orbits +are exactly the connected components of the union: one step of the +rotation, forwards or backwards, crosses each of the two arcs at a +point. -/ +theorem sameCycle_rot_edge (h : Alternating M N) (a : α) : + (M.rotPerm N h).SameCycle a (M.edge a) := by + by_cases ha : M.tail a = true + · exact ⟨1, by + show (M.rotPerm N h ^ (1 : ℤ)) a = M.edge a + rw [zpow_one] + change M.rot N a = M.edge a + rw [rot, ite_eq_left ha]⟩ + · exact ⟨-1, by + show (M.rotPerm N h ^ (-1 : ℤ)) a = M.edge a + rw [zpow_neg, zpow_one] + change (M.rotPerm N h).symm a = M.edge a + change M.rotInv N a = M.edge a + rw [rotInv, ite_eq_right ha]⟩ + +/-- **The rotation reaches the second matching's partner.** -/ +theorem sameCycle_rot_edge' (h : Alternating M N) (a : α) : + (M.rotPerm N h).SameCycle a (N.edge a) := by + by_cases ha : M.tail a = true + · exact ⟨-1, by + show (M.rotPerm N h ^ (-1 : ℤ)) a = N.edge a + rw [zpow_neg, zpow_one] + change (M.rotPerm N h).symm a = N.edge a + change M.rotInv N a = N.edge a + rw [rotInv, ite_eq_left ha]⟩ + · exact ⟨1, by + show (M.rotPerm N h ^ (1 : ℤ)) a = N.edge a + rw [zpow_one] + change M.rot N a = N.edge a + rw [rot, ite_eq_right ha]⟩ + +/-- **A directed perfect matching forces an even ground set**: the +partner map exchanges the tails with the heads. -/ +theorem even_card [Fintype α] (M : DirMatching α) : + Even (Fintype.card α) := by + classical + have hcard : (Finset.univ.filter (fun a : α => M.tail a = true)).card + = (Finset.univ.filter (fun a : α => ¬ (M.tail a = true))).card := by + refine Finset.card_nbij' (i := M.edge) (j := M.edge) ?_ ?_ ?_ ?_ + · intro a ha + simp only [Finset.coe_filter, Set.mem_ofPred_eq, + Finset.mem_univ, true_and] at ha ⊢ + rw [M.tail_flip a, ha] + simp + · intro b hb + simp only [Finset.coe_filter, Set.mem_ofPred_eq, + Finset.mem_univ, true_and] at hb ⊢ + rw [M.tail_flip b] + simpa using hb + · exact fun a _ => M.edge_invol a + · exact fun b _ => M.edge_invol b + have hsum := Finset.card_filter_add_card_filter_not + (s := (Finset.univ : Finset α)) (p := fun a : α => M.tail a = true) + refine ⟨(Finset.univ.filter (fun a : α => M.tail a = true)).card, ?_⟩ + rw [← Finset.card_univ, ← hsum, hcard] + +/-- The tails of a directed matching, as a subtype. -/ +abbrev Tail (M : DirMatching α) : Type := {a : α // M.tail a = true} + +/-- **The partner map exchanges tails and heads.** -/ +noncomputable def tailHeadEquiv (M : DirMatching α) : + {a : α // ¬ (M.tail a = true)} ≃ {a : α // M.tail a = true} where + toFun a := ⟨M.edge a.val, by rw [M.tail_flip]; simpa using a.prop⟩ + invFun a := ⟨M.edge a.val, by rw [M.tail_flip, a.prop]; simp⟩ + left_inv a := Subtype.ext (M.edge_invol a.val) + right_inv a := Subtype.ext (M.edge_invol a.val) + +/-- **The ground set is twice the tails.** -/ +theorem two_mul_card_tail [Fintype α] + (M : DirMatching α) : + 2 * Fintype.card M.Tail = Fintype.card α := by + have h1 : Fintype.card {a : α // ¬ (M.tail a = true)} + = Fintype.card M.Tail := + Fintype.card_congr M.tailHeadEquiv + have h2 := Fintype.card_subtype_compl + (p := fun a : α => M.tail a = true) + have h3 : Fintype.card M.Tail ≤ Fintype.card α := + Fintype.card_subtype_le _ + have h4 : Fintype.card M.Tail + = Fintype.card {x : α // M.tail x = true} := + Fintype.card_congr (Equiv.refl _) + rw [h1, h4] at h2 + rw [h4] at h3 ⊢ + omega + +/-! ### Symmetries of a directed matching are even + +A permutation commuting with the partner map and preserving the +tails is determined by its restriction to the tails, and the +restriction to the heads is that same permutation conjugated by the +partner map. The two restrictions therefore have equal sign, and +their product — the whole permutation — has sign one. +-/ + +/-- A symmetry of a directed matching: it commutes with the partner +map and fixes each point's direction. -/ +structure Stab (M : DirMatching α) (g : Equiv.Perm α) : Prop where + /-- It commutes with the partner map. -/ + edge : ∀ a, g (M.edge a) = M.edge (g a) + /-- It preserves the tails. -/ + tail : ∀ a, M.tail (g a) = M.tail a + +/-- **A symmetry of a directed matching is even.** -/ +theorem sign_of_stab [Fintype α] [DecidableEq α] {M : DirMatching α} + {g : Equiv.Perm α} (h : Stab M g) : Perm.sign g = 1 := by + classical + have hp' : ∀ a, (M.tail (g a) = true) ↔ (M.tail a = true) := + fun a => by rw [h.tail a] + have hdecomp := perm_eq_ofSubtype_mul g (fun a => M.tail a = true) hp' + let e : {a : α // ¬ (M.tail a = true)} ≃ {a : α // M.tail a = true} := + { toFun := fun a => ⟨M.edge a.val, by + rw [M.tail_flip]; simpa using a.prop⟩ + invFun := fun a => ⟨M.edge a.val, by + rw [M.tail_flip, a.prop]; simp⟩ + left_inv := fun a => Subtype.ext (M.edge_invol a.val) + right_inv := fun a => Subtype.ext (M.edge_invol a.val) } + have hconj : g.subtypePerm (p := fun a => M.tail a = true) hp' + = e.permCongr (g.subtypePerm + (p := fun a => ¬ (M.tail a = true)) (fun a => (hp' a).not)) := by + refine Equiv.ext (fun a => Subtype.ext ?_) + change g a.val = M.edge (g (M.edge a.val)) + rw [h.edge a.val, M.edge_invol] + have hsign : Perm.sign + (g.subtypePerm (p := fun a => M.tail a = true) hp') + = Perm.sign (g.subtypePerm + (p := fun a => ¬ (M.tail a = true)) (fun a => (hp' a).not)) := by + rw [hconj, Equiv.Perm.sign_permCongr] + rw [hdecomp, map_mul, Equiv.Perm.sign_ofSubtype, + Equiv.Perm.sign_ofSubtype, ← hsign] + exact Int.units_mul_self _ + +/-! ### The rotation carries one matching to the other -/ + +/-- **The rotation conjugates the second matching into the +first.** -/ +theorem edge_rot (h : Alternating M N) (a : α) : + M.edge (M.rot N a) = M.rot N (N.edge a) := by + unfold rot + by_cases ha : M.tail a = true + · rw [ite_eq_left ha, M.edge_invol, + ite_eq_right (by rw [tail_edge_alt h a, ha]; simp), N.edge_invol] + · rw [ite_eq_right ha, ite_eq_left (by rw [tail_edge_alt h a]; simp [ha])] + +/-- **The rotation carries the second matching's directions to the +first's.** -/ +theorem tail_rot_eq (h : Alternating M N) (a : α) : + M.tail (M.rot N a) = N.tail a := by + rw [tail_rot h a, h a] + +/-! ### Its sign counts the components -/ + +/-- **The rotation's sign is `(-1)` to its number of orbits.** The +orbits are the components of the union, and each has even length, so +this is the sign lemma for a matching pair. -/ +theorem sign_rotPerm [Fintype α] [DecidableEq α] (h : Alternating M N) + (hcard : Even (Fintype.card α)) : + ((Perm.sign (M.rotPerm N h) : ℤ) : ℂ) + = (-1 : ℂ) ^ orbitCount (M.rotPerm N h) := by + rw [neg_one_pow_orbitCount, Even.neg_one_pow hcard, one_mul] + +/-! ### Every carrier has the rotation's sign + +A permutation carrying one directed matching to the other differs +from the rotation by a symmetry of the target, so all carriers share +the rotation's sign — and that sign counts the union's components. +This is the matching-sign lemma the Gram identity uses. +-/ + +/-- A permutation carrying one directed matching onto another. -/ +structure Carries (M N : DirMatching α) (σ : Equiv.Perm α) : Prop where + /-- It intertwines the two partner maps. -/ + edge : ∀ a, σ (N.edge a) = M.edge (σ a) + /-- It matches the directions. -/ + tail : ∀ a, M.tail (σ a) = N.tail a + +/-- A carrier's inverse intertwines the partner maps the other +way. -/ +theorem Carries.edge_symm {σ : Equiv.Perm α} (hσ : Carries M N σ) + (a : α) : σ.symm (M.edge a) = N.edge (σ.symm a) := by + have := hσ.edge (σ.symm a) + rw [Equiv.apply_symm_apply] at this + rw [← this, Equiv.symm_apply_apply] + +/-- **The rotation carries.** -/ +theorem carries_rotPerm (h : Alternating M N) : + Carries M N (M.rotPerm N h) := + ⟨fun a => (edge_rot h a).symm, tail_rot_eq h⟩ + +/-- **Any two carriers have the same sign.** They differ by a +symmetry of the target, and symmetries are even. No Eulerian +hypothesis is needed: this is what makes a directed matching's sign +well defined. -/ +theorem sign_eq_of_carries_pair [Fintype α] [DecidableEq α] + {σ τ : Equiv.Perm α} (hσ : Carries M N σ) (hτ : Carries M N τ) : + Perm.sign σ = Perm.sign τ := by + have hg : Stab M (σ * τ⁻¹) := by + constructor + · intro a + change σ (τ.symm (M.edge a)) = M.edge (σ (τ.symm a)) + rw [hτ.edge_symm a, hσ.edge] + · intro a + change M.tail (σ (τ.symm a)) = M.tail a + rw [hσ.tail] + conv_rhs => rw [← Equiv.apply_symm_apply τ a] + rw [hτ.tail] + have h1 := sign_of_stab hg + rw [map_mul, map_inv] at h1 + exact mul_inv_eq_one.mp h1 + +/-! ### A carrier always exists + +RS21 speaks of "a permutation that sends `M(ω,κ)` to the standard +matching" without exhibiting one. Any bijection between the two +matchings' tails extends over the partner maps to a carrier, and +the tails are half the ground set on both sides, so such a +bijection exists whenever the ground sets agree. +-/ + +/-- The carrier built from a bijection of tails: send a tail where +the bijection does, and a head to the partner of its tail's +image. -/ +noncomputable def ofTailEquiv (M N : DirMatching α) + (b : N.Tail ≃ M.Tail) : Equiv.Perm α where + toFun a := + if h : N.tail a = true then (b ⟨a, h⟩).val + else M.edge (b ⟨N.edge a, by + rw [N.tail_flip]; simpa using h⟩).val + invFun a := + if h : M.tail a = true then (b.symm ⟨a, h⟩).val + else N.edge (b.symm ⟨M.edge a, by + rw [M.tail_flip]; simpa using h⟩).val + left_inv a := by + by_cases h : N.tail a = true + · have hm : M.tail (b ⟨a, h⟩).val = true := (b ⟨a, h⟩).prop + simp only [dite_eq_left h, dite_eq_left hm] + have : (⟨(b ⟨a, h⟩).val, hm⟩ : M.Tail) = b ⟨a, h⟩ := rfl + rw [this, Equiv.symm_apply_apply] + · have hne : N.tail (N.edge a) = true := by + rw [N.tail_flip]; simpa using h + have hm : M.tail (b ⟨N.edge a, hne⟩).val = true := + (b ⟨N.edge a, hne⟩).prop + have hm' : ¬ (M.tail (M.edge (b ⟨N.edge a, hne⟩).val) = true) := by + rw [M.tail_flip, hm]; simp + simp only [dite_eq_right h, dite_eq_right hm', M.edge_invol] + have : (⟨(b ⟨N.edge a, hne⟩).val, hm⟩ : M.Tail) + = b ⟨N.edge a, hne⟩ := rfl + rw [this, Equiv.symm_apply_apply, N.edge_invol] + right_inv a := by + by_cases h : M.tail a = true + · have hn : N.tail (b.symm ⟨a, h⟩).val = true := (b.symm ⟨a, h⟩).prop + simp only [dite_eq_left h, dite_eq_left hn] + have : (⟨(b.symm ⟨a, h⟩).val, hn⟩ : N.Tail) = b.symm ⟨a, h⟩ := rfl + rw [this, Equiv.apply_symm_apply] + · have hme : M.tail (M.edge a) = true := by + rw [M.tail_flip]; simpa using h + have hn : N.tail (b.symm ⟨M.edge a, hme⟩).val = true := + (b.symm ⟨M.edge a, hme⟩).prop + have hn' : ¬ (N.tail (N.edge (b.symm ⟨M.edge a, hme⟩).val) = true) := by + rw [N.tail_flip, hn]; simp + simp only [dite_eq_right h, dite_eq_right hn', N.edge_invol] + have : (⟨(b.symm ⟨M.edge a, hme⟩).val, hn⟩ : N.Tail) + = b.symm ⟨M.edge a, hme⟩ := rfl + rw [this, Equiv.apply_symm_apply, M.edge_invol] + +/-- **The tail bijection's extension carries.** -/ +theorem carries_ofTailEquiv + (M N : DirMatching α) + (b : N.Tail ≃ M.Tail) : Carries M N (ofTailEquiv M N b) := by + constructor + · intro a + by_cases h : N.tail a = true + · have hne : ¬ (N.tail (N.edge a) = true) := by + rw [N.tail_flip, h]; simp + change (if h' : N.tail (N.edge a) = true then _ else _) = _ + rw [dite_eq_right hne] + change M.edge (b ⟨N.edge (N.edge a), _⟩).val + = M.edge (if h' : N.tail a = true then (b ⟨a, h'⟩).val else _) + rw [dite_eq_left h] + exact congrArg (fun z : M.Tail => M.edge z.val) + (congrArg b (Subtype.ext (N.edge_invol a))) + · have hne : N.tail (N.edge a) = true := by + rw [N.tail_flip]; simpa using h + change (if h' : N.tail (N.edge a) = true then (b ⟨N.edge a, h'⟩).val + else _) = _ + rw [dite_eq_left hne] + change _ = M.edge (if h' : N.tail a = true then _ + else M.edge (b ⟨N.edge a, _⟩).val) + rw [dite_eq_right h, M.edge_invol] + · intro a + by_cases h : N.tail a = true + · change M.tail (if h' : N.tail a = true then (b ⟨a, h'⟩).val else _) + = N.tail a + rw [dite_eq_left h, h] + exact (b ⟨a, h⟩).prop + · have hne : N.tail (N.edge a) = true := by + rw [N.tail_flip]; simpa using h + change M.tail (if h' : N.tail a = true then _ + else M.edge (b ⟨N.edge a, _⟩).val) = N.tail a + rw [dite_eq_right h, M.tail_flip, (b ⟨N.edge a, hne⟩).prop] + simpa using (Bool.eq_false_iff.mpr h).symm + +/-- **A carrier exists between any two directed matchings on the +same set.** -/ +theorem exists_carries [Finite α] (M N : DirMatching α) : + ∃ σ : Equiv.Perm α, Carries M N σ := by + classical + let := Fintype.ofFinite α + have hcard : Fintype.card N.Tail = Fintype.card M.Tail := by + have h1 := M.two_mul_card_tail + have h2 := N.two_mul_card_tail + omega + exact ⟨ofTailEquiv M N (Fintype.equivOfCardEq hcard), + carries_ofTailEquiv M N _⟩ + +/-! ### The sign of a directed matching + +RS21 fixes a reference matching — the one with arcs +`(i₁,i₂),…,(i_{|S|−1},i_{|S|})` — and takes a matching's sign to be +that of any permutation carrying it to the reference. Well +definedness is `sign_eq_of_carries_pair`. What the Gram identity +uses is not the sign itself but the product of two of them, and +that product is the sign of a carrier between them — independent of +which reference was fixed. +-/ + +/-- Carriers compose. -/ +theorem Carries.comp {P : DirMatching α} {σ τ : Equiv.Perm α} + (hσ : Carries M N σ) (hτ : Carries N P τ) : + Carries M P (σ * τ) := by + constructor + · intro a + change σ (τ (P.edge a)) = M.edge (σ (τ a)) + rw [hτ.edge a, hσ.edge (τ a)] + · intro a + change M.tail (σ (τ a)) = P.tail a + rw [hσ.tail (τ a), hτ.tail a] + +/-- Carriers invert. -/ +theorem Carries.inv {σ : Equiv.Perm α} (hσ : Carries M N σ) : + Carries N M σ⁻¹ := by + constructor + · intro a + exact hσ.edge_symm a + · intro a + change N.tail (σ.symm a) = M.tail a + conv_rhs => rw [← Equiv.apply_symm_apply σ a] + rw [hσ.tail] + +/-- **The sign of a directed matching against a reference.** -/ +noncomputable def sgnRel [Fintype α] [DecidableEq α] (R M : DirMatching α) : ℤˣ + := + Perm.sign (Classical.choose (exists_carries R M)) + +/-- The sign is that of any carrier to the reference. -/ +theorem sgnRel_eq_of_carries [Fintype α] [DecidableEq α] (R M : DirMatching α) + {σ : Equiv.Perm α} (hσ : Carries R M σ) : + sgnRel R M = Perm.sign σ := + sign_eq_of_carries_pair (Classical.choose_spec (exists_carries R M)) + hσ + +/-- **The product of two matchings' signs is the sign of a carrier +between them**, whatever reference was fixed. -/ +theorem sgnRel_mul_sgnRel [Fintype α] [DecidableEq α] (R M N : DirMatching α) + {σ : Equiv.Perm α} (hσ : Carries M N σ) : + sgnRel R M * sgnRel R N = Perm.sign σ := by + obtain ⟨σM, hσM⟩ := exists_carries R M + have hN : sgnRel R N = Perm.sign σM * Perm.sign σ := by + rw [← map_mul] + exact sgnRel_eq_of_carries R N (hσM.comp hσ) + rw [sgnRel_eq_of_carries R M hσM, hN, ← mul_assoc, + Int.units_mul_self, one_mul] + +/-! ### The interface matching + +Composing two fragments identifies each label of the first with the +same label of the second. On the labels that is a directed perfect +matching in its own right — the one RS21 pairs with the chord +matching to form the union whose components count the circuits the +gluing closes. +-/ + +/-- **The interface matching**: each label of one side paired with +the same label of the other. -/ +def interfaceMatching (γ : Type) : DirMatching (γ ⊕ γ) where + edge := Sum.swap + edge_invol x := by rcases x with a | a <;> rfl + edge_ne x := by rcases x with a | a <;> simp + tail := Sum.isLeft + tail_flip x := by rcases x with a | a <;> rfl + +/-- The interface matching pairs a label with its copy on the other +side. -/ +@[simp] theorem interfaceMatching_edge {γ : Type} (x : γ ⊕ γ) : + (interfaceMatching γ).edge x = x.swap := rfl + +/-- Its arcs are directed out of the left side. -/ +@[simp] theorem interfaceMatching_tail {γ : Type} (x : γ ⊕ γ) : + (interfaceMatching γ).tail x = x.isLeft := rfl + +/-! ### The standard matching + +RS21 fixes the matching with arcs `(i₁,i₂),…,(i_{|S|−1},i_{|S|})` +on `S = {i₁ < ⋯ < i_{|S|}}`. On `Fin (2m)` that is the pairing of +`2j` with `2j+1`, directed upward; on any linearly ordered set of +even size it is that one transported along the order isomorphism. +-/ + +/-- Transport a directed matching along an equivalence. -/ +def map {β : Type} (e : α ≃ β) (M : DirMatching α) : DirMatching β where + edge b := e (M.edge (e.symm b)) + edge_invol b := by simp [M.edge_invol] + edge_ne b := by + intro hx + refine M.edge_ne (e.symm b) ?_ + have h2 := congrArg e.symm hx + rwa [Equiv.symm_apply_apply] at h2 + tail b := M.tail (e.symm b) + tail_flip b := by + simp only [Equiv.symm_apply_apply] + exact M.tail_flip _ + +/-- **The standard directed matching on `Fin (2m)`**: `2j` paired +with `2j+1`, directed upward. -/ +def finStd (m : ℕ) : DirMatching (Fin (2 * m)) where + edge i := ⟨if i.val % 2 = 0 then i.val + 1 else i.val - 1, by + have := i.isLt; split_ifs <;> omega⟩ + edge_invol i := by + have := i.isLt + refine Fin.ext ?_ + by_cases h : i.val % 2 = 0 + · simp only [ite_eq_left h, + ite_eq_right (show ¬ ((i.val + 1) % 2 = 0) by omega)] + omega + · simp only [ite_eq_right h, + ite_eq_left (show (i.val - 1) % 2 = 0 by omega)] + omega + edge_ne i := by + have := i.isLt + intro hx + have h2 := congrArg Fin.val hx + simp only at h2 + split_ifs at h2 <;> omega + tail i := decide (i.val % 2 = 0) + tail_flip i := by + have := i.isLt + by_cases h : i.val % 2 = 0 + · change decide ((⟨if i.val % 2 = 0 then i.val + 1 else i.val - 1, + _⟩ : Fin (2 * m)).val % 2 = 0) = _ + simp only [ite_eq_left h] + rw [decide_eq_false (show ¬ ((i.val + 1) % 2 = 0) by omega), + decide_eq_true h] + rfl + · change decide ((⟨if i.val % 2 = 0 then i.val + 1 else i.val - 1, + _⟩ : Fin (2 * m)).val % 2 = 0) = _ + simp only [ite_eq_right h] + rw [decide_eq_true (show (i.val - 1) % 2 = 0 by omega), + decide_eq_false h] + rfl + +/-- **The standard directed matching** on a linearly ordered set of +even size. -/ +noncomputable def stdMatching [LinearOrder α] [Fintype α] {m : ℕ} + (hcard : Fintype.card α = 2 * m) : DirMatching α := + (finStd m).map (monoEquivOfFin α hcard).toEquiv + +/-! ### Transporting a matching + +The two fragments of a composition carry matchings on their own +used labels. Comparing them means transporting one along the +bijection the shared labelling gives, and the sign against a +transported reference is unchanged. +-/ + +/-- A carrier transports along a bijection. -/ +theorem carries_map {β : Type} (e : α ≃ β) {R M : DirMatching α} + {σ : Equiv.Perm α} (hσ : Carries R M σ) : + Carries (R.map e) (M.map e) (e.permCongr σ) := by + constructor + · intro b + change e (σ (e.symm (e (M.edge (e.symm b))))) + = e (R.edge (e.symm (e (σ (e.symm b))))) + rw [Equiv.symm_apply_apply, Equiv.symm_apply_apply] + exact congrArg e (hσ.edge (e.symm b)) + · intro b + change R.tail (e.symm (e (σ (e.symm b)))) = M.tail (e.symm b) + rw [Equiv.symm_apply_apply] + exact hσ.tail (e.symm b) + +/-- Transport composes. -/ +theorem map_map {β γ : Type} (e : α ≃ β) (f : β ≃ γ) + (M : DirMatching α) : (M.map e).map f = M.map (e.trans f) := rfl + +/-- **The sign is unchanged by transport.** -/ +theorem sgnRel_map [Fintype α] [DecidableEq α] {β : Type} + [Fintype β] [DecidableEq β] (e : α ≃ β) (R M : DirMatching α) : + sgnRel (R.map e) (M.map e) = sgnRel R M := by + obtain ⟨σ, hσ⟩ := exists_carries R M + rw [sgnRel_eq_of_carries R M hσ, + sgnRel_eq_of_carries (R.map e) (M.map e) (carries_map e hσ), + Equiv.Perm.sign_permCongr] + +/-- **The standard matching is natural in the order.** -/ +theorem stdMatching_map [LinearOrder α] [Fintype α] {β : Type} + [LinearOrder β] [Fintype β] (e : α ≃o β) {m : ℕ} + (h : Fintype.card α = 2 * m) (h' : Fintype.card β = 2 * m) : + (stdMatching h).map e.toEquiv = stdMatching h' := by + unfold stdMatching + rw [map_map] + refine congrArg (fun z : Fin (2 * m) ≃ β => (finStd m).map z) ?_ + exact congrArg (fun z : Fin (2 * m) ≃o β => z.toEquiv) + (Subsingleton.elim ((monoEquivOfFin α h).trans e) + (monoEquivOfFin β h')) + +/-- **The two fragments' signs, on a common reference.** With the +second matching transported along an order isomorphism of the two +used-label sets, the product of the two signs is the sign of a +carrier between them — reference-free, as RS21's Lemma 11 needs. -/ +theorem sgnRel_mul_sgnRel_map [LinearOrder α] [Fintype α] + {β : Type} [LinearOrder β] [Fintype β] (e : α ≃o β) {m : ℕ} + (h : Fintype.card α = 2 * m) (h' : Fintype.card β = 2 * m) + (M : DirMatching α) (N : DirMatching β) {σ : Equiv.Perm α} + (hσ : Carries M (N.map e.symm.toEquiv) σ) : + sgnRel (stdMatching h) M * sgnRel (stdMatching h') N + = Perm.sign σ := by + have hN : sgnRel (stdMatching h') N + = sgnRel (stdMatching h) (N.map e.symm.toEquiv) := by + rw [← sgnRel_map e.symm.toEquiv (stdMatching h') N, + stdMatching_map e.symm h' h] + rw [hN] + exact sgnRel_mul_sgnRel (stdMatching h) M + (N.map e.symm.toEquiv) hσ + +/-- **RS21's Lemma 11 for a composition**: with the union of the two +fragments' matchings Eulerian, the product of their signs is `(-1)` +to the number of components of that union. -/ +theorem sgnRel_mul_sgnRel_map_alternating [LinearOrder α] [Fintype α] + {β : Type} [LinearOrder β] [Fintype β] (e : α ≃o β) {m : ℕ} + (h : Fintype.card α = 2 * m) (h' : Fintype.card β = 2 * m) + (M : DirMatching α) (N : DirMatching β) + (halt : Alternating M (N.map e.symm.toEquiv)) : + ((sgnRel (stdMatching h) M * sgnRel (stdMatching h') N : ℤˣ) : ℂ) + = (-1 : ℂ) ^ orbitCount (M.rotPerm (N.map e.symm.toEquiv) halt) + := by + have hs := sgnRel_mul_sgnRel_map e h h' M N (carries_rotPerm halt) + rw [hs] + exact sign_rotPerm halt M.even_card + +/-! ### Reversing one arc + +RS21's invariance (12) turns on the observation that inverting a +directed trail changes `M(ω,κ)` by reversing the direction of one +arc, and that this flips the matching's sign. Reversing an arc +composes any carrier with the transposition of that arc's two ends. +-/ + +/-- **Reverse the direction of one arc**, leaving the pairing +alone. -/ +def reverseArc [DecidableEq α] (M : DirMatching α) (a : α) : + DirMatching α where + edge := M.edge + edge_invol := M.edge_invol + edge_ne := M.edge_ne + tail b := if b = a ∨ b = M.edge a then !M.tail b else M.tail b + tail_flip b := by + by_cases h1 : b = a + · subst h1 + rw [ite_eq_left (Or.inr rfl), ite_eq_left (Or.inl rfl), M.tail_flip, + Bool.not_not] + · by_cases h2 : b = M.edge a + · subst h2 + rw [ite_eq_left (Or.inl (M.edge_invol a)), + ite_eq_left (Or.inr rfl), M.tail_flip, Bool.not_not] + · have h3 : ¬ (M.edge b = a ∨ M.edge b = M.edge a) := by + rintro (hx | hx) + · exact h2 (by rw [← hx, M.edge_invol]) + · exact h1 (by + have := congrArg M.edge hx + rwa [M.edge_invol, M.edge_invol] at this) + rw [ite_eq_right h3, ite_eq_right (fun hx => hx.elim h1 h2), M.tail_flip] + +/-- The reversed matching's directions, pointwise. -/ +theorem reverseArc_tail [DecidableEq α] (M : DirMatching α) (a b : α) : + (M.reverseArc a).tail b + = if b = a ∨ b = M.edge a then !M.tail b else M.tail b := rfl + +/-- The arc-reversing transposition commutes with the pairing. -/ +theorem swap_edge_comm [DecidableEq α] (M : DirMatching α) (a b : α) : + Equiv.swap a (M.edge a) (M.edge b) + = M.edge (Equiv.swap a (M.edge a) b) := by + by_cases h1 : b = a + · subst h1 + rw [Equiv.swap_apply_right, Equiv.swap_apply_left, M.edge_invol] + · by_cases h2 : b = M.edge a + · subst h2 + rw [M.edge_invol, Equiv.swap_apply_left, + Equiv.swap_apply_right] + · have h3 : M.edge b ≠ a := fun hx => + h2 (by rw [← hx, M.edge_invol]) + have h4 : M.edge b ≠ M.edge a := fun hx => + h1 (by + have := congrArg M.edge hx + rwa [M.edge_invol, M.edge_invol] at this) + rw [Equiv.swap_apply_of_ne_of_ne h3 h4, + Equiv.swap_apply_of_ne_of_ne h1 h2] + +/-- **A carrier for the reversed matching**: compose with the +transposition of the reversed arc's two ends. -/ +theorem carries_reverseArc [DecidableEq α] {σ : Equiv.Perm α} + (hσ : Carries R M σ) + (a : α) : + Carries R (M.reverseArc a) (σ * Equiv.swap a (M.edge a)) := by + constructor + · intro b + change σ (Equiv.swap a (M.edge a) (M.edge b)) + = R.edge (σ (Equiv.swap a (M.edge a) b)) + rw [swap_edge_comm M a b, hσ.edge] + · intro b + change R.tail (σ (Equiv.swap a (M.edge a) b)) + = (M.reverseArc a).tail b + rw [hσ.tail] + change M.tail (Equiv.swap a (M.edge a) b) + = if b = a ∨ b = M.edge a then !M.tail b else M.tail b + by_cases h1 : b = a + · subst h1 + rw [Equiv.swap_apply_left, ite_eq_left (Or.inl rfl), M.tail_flip] + · by_cases h2 : b = M.edge a + · subst h2 + rw [Equiv.swap_apply_right, ite_eq_left (Or.inr rfl), + M.tail_flip, Bool.not_not] + · rw [Equiv.swap_apply_of_ne_of_ne h1 h2, + ite_eq_right (fun hx => hx.elim h1 h2)] + +/-- **Reversing an arc flips the sign** — RS21's +`sgn(M(ω,κ)) = -sgn(M(ω′,κ′))`. -/ +theorem sgnRel_reverseArc [Fintype α] [DecidableEq α] (R M : DirMatching α) (a : + α) : + sgnRel R (M.reverseArc a) = -sgnRel R M := by + obtain ⟨σ, hσ⟩ := exists_carries R M + rw [sgnRel_eq_of_carries R M hσ, + sgnRel_eq_of_carries R (M.reverseArc a) (carries_reverseArc hσ a), + map_mul, Equiv.Perm.sign_swap (M.edge_ne a).symm] + simp + +/-- Two directed matchings agreeing on partners and directions are +equal. -/ +theorem ext {M N : DirMatching α} (he : M.edge = N.edge) + (ht : M.tail = N.tail) : M = N := by + cases M + cases N + simp_all + +/-! ### Lemma 11 in general + +RS21's Lemma 11 reads the sign of a permutation carrying one +directed matching to another as `(-1)^{c(M∪N)+o(M∪N)}`, where +`o(M∪N)` is the parity of the number of arcs that must be reversed +to make the union Eulerian. The Eulerian case above is `o = 0`; +RS21 reduces to it by (12), which is available for a directed trail +but not for an edge joining two labels directly, so the general +case is what a fragment's matchings need. + +The general case follows from the Eulerian one by reversing arcs. +Two matchings with the same pairing differ on a set of points +closed under that pairing — a set of whole arcs — and reversing +those arcs one at a time carries one to the other, flipping the +sign each time. +-/ + +/-- The points at which two matchings disagree on direction. -/ +def flipSet [Fintype α] (P P' : DirMatching α) : Finset α := + Finset.univ.filter (fun a => P'.tail a ≠ P.tail a) + +/-- Membership in the disagreement set. -/ +theorem mem_flipSet [Fintype α] {P P' : DirMatching α} {a : α} : + a ∈ flipSet P P' ↔ P'.tail a ≠ P.tail a := by + rw [flipSet, Finset.mem_filter] + exact ⟨fun h => h.2, fun h => ⟨Finset.mem_univ a, h⟩⟩ + +/-- Booleans that differ are negations of one another. -/ +private theorem bool_eq_not_of_ne {x y : Bool} (h : x ≠ y) : + x = !y := by + revert h + revert x y + decide + +/-- **The disagreement set is a set of whole arcs**: matchings with +the same pairing disagree at both ends of an arc or at neither. -/ +theorem edge_mem_flipSet [Fintype α] {P P' : DirMatching α} + (he : P'.edge = P.edge) {a : α} (ha : a ∈ flipSet P P') : + P.edge a ∈ flipSet P P' := by + rw [mem_flipSet] at ha ⊢ + intro hx + refine ha ?_ + have h1 : P'.tail (P.edge a) = !P'.tail a := by + rw [← he]; exact P'.tail_flip a + rw [hx, P.tail_flip a] at h1 + exact (Bool.not_inj h1).symm + +/-- The disagreement set has an even number of points. -/ +theorem even_card_flipSet [Fintype α] + {P P' : DirMatching α} (he : P'.edge = P.edge) : + Even (flipSet P P').card := + even_card_of_involution _ P.edge + (fun _ ha => edge_mem_flipSet he ha) + (fun a _ => P.edge_invol a) (fun a _ => P.edge_ne a) + +/-- Reversing an arc removes it from the disagreement set and +leaves the rest alone. -/ +theorem flipSet_reverseArc [Fintype α] [DecidableEq α] + {P P' : DirMatching α} (he : P'.edge = P.edge) {a : α} + (ha : a ∈ flipSet P P') : + flipSet (P.reverseArc a) P' = (flipSet P P') \ {a, P.edge a} := by + have hea : P.edge a ∈ flipSet P P' := edge_mem_flipSet he ha + refine Finset.ext (fun b => ?_) + rw [mem_flipSet, Finset.mem_sdiff, mem_flipSet, Finset.mem_insert, + Finset.mem_singleton, reverseArc_tail] + by_cases hb : b = a ∨ b = P.edge a + · rw [ite_eq_left hb] + have hbmem : b ∈ flipSet P P' := by + rcases hb with rfl | rfl + · exact ha + · exact hea + rw [mem_flipSet] at hbmem + exact ⟨fun hx => absurd (bool_eq_not_of_ne hbmem) hx, + fun hx => absurd hb hx.2⟩ + · rw [ite_eq_right hb] + exact ⟨fun hx => ⟨hx, hb⟩, fun hx => hx.1⟩ + +/-! ### Repairing a union to Eulerian position + +RS21 puts the union of two matchings into Eulerian position before +applying Lemma 11, by reversing arcs of each. Such a repair always +exists: reversing arcs is free to choose a direction at each point, +subject only to the two arcs at a point pointing opposite ways, so a +repair is exactly a two-colouring of the union — a `T : α → Bool` +flipped by both pairings. + +The union of two fixed-point-free involutions is a disjoint union of +cycles of even length, so it is two-colourable, and the colouring is +built here without decomposing into cycles. Write `p` for the +composite of the two pairings. A colouring is a function constant on +`p`-cycles that the first pairing flips, so it is a choice of one +cycle from each pair `{C, e₁C}` — and those two cycles are always +distinct, by the dihedral relation `e₁ p e₁ = p⁻¹` together with the +fixed-point-freeness of both pairings. +-/ + +/-- The pairing of a matching, as a permutation. -/ +def edgePerm (M : DirMatching α) : Equiv.Perm α where + toFun := M.edge + invFun := M.edge + left_inv := M.edge_invol + right_inv := M.edge_invol + +/-- The pairing permutation acts by the partner map. -/ +@[simp] theorem edgePerm_apply (M : DirMatching α) (a : α) : + M.edgePerm a = M.edge a := rfl + +/-- A pairing is its own inverse. -/ +theorem edgePerm_inv (M : DirMatching α) : M.edgePerm⁻¹ = M.edgePerm := + inv_eq_of_mul_eq_one_left (Equiv.ext (fun x => M.edge_invol x)) + +/-- The composite of two pairings inverts by taking them in the +other order. -/ +theorem inv_edgePerm_mul (M N : DirMatching α) : + (N.edgePerm * M.edgePerm)⁻¹ = M.edgePerm * N.edgePerm := by + rw [mul_inv_rev, edgePerm_inv, edgePerm_inv] + +/-- **The dihedral relation**: conjugating the composite by either +pairing inverts it. -/ +theorem edgePerm_conj (M N : DirMatching α) (i : ℤ) : + M.edgePerm * (N.edgePerm * M.edgePerm) ^ i * M.edgePerm + = (N.edgePerm * M.edgePerm) ^ (-i) := by + have hcc : M.edgePerm * M.edgePerm = 1 := + Equiv.ext (fun x => M.edge_invol x) + have hinv : M.edgePerm⁻¹ = M.edgePerm := edgePerm_inv M + have hbase : (MulAut.conj M.edgePerm) (N.edgePerm * M.edgePerm) + = (N.edgePerm * M.edgePerm)⁻¹ := by + rw [MulAut.conj_apply, hinv, inv_edgePerm_mul] + calc M.edgePerm * (N.edgePerm * M.edgePerm) * M.edgePerm + = M.edgePerm * N.edgePerm * (M.edgePerm * M.edgePerm) := by + group + _ = M.edgePerm * N.edgePerm := by rw [hcc, mul_one] + have h2 := map_zpow (MulAut.conj M.edgePerm) + (N.edgePerm * M.edgePerm) i + rw [hbase, MulAut.conj_apply, hinv, inv_zpow'] at h2 + exact h2 + +/-- **The cycle of a point and the cycle of its partner are +distinct.** Were they the same, the dihedral relation would place a +fixed point of one of the two pairings on that cycle: at the midpoint +of the displacement when it is even, one step further when it is odd. +This is the even length of the union's cycles, in the only form the +repair needs. -/ +theorem not_sameCycle_edge (M N : DirMatching α) (a : α) : + ¬ (N.edgePerm * M.edgePerm).SameCycle a (M.edge a) := by + set p : Equiv.Perm α := N.edgePerm * M.edgePerm with hp + rintro ⟨j, hj⟩ + have hstep : ∀ i : ℤ, M.edge ((p ^ i) a) = (p ^ (j - i)) a := by + intro i + have h1 : M.edge ((p ^ i) a) + = (M.edgePerm * p ^ i * M.edgePerm) (M.edge a) := by + change M.edge ((p ^ i) a) + = M.edge ((p ^ i) (M.edge (M.edge a))) + rw [M.edge_invol] + rw [h1, hp, edgePerm_conj M N i, ← hj, ← hp] + change (p ^ (-i)) ((p ^ j) a) = (p ^ (j - i)) a + rw [← Equiv.Perm.mul_apply, ← zpow_add] + congr 2 + ring + have hNstep : ∀ i : ℤ, N.edge ((p ^ i) a) = (p ^ (j - i + 1)) a := by + intro i + have h2 : N.edge ((p ^ i) a) = p (M.edge ((p ^ i) a)) := by + change N.edge ((p ^ i) a) = N.edge (M.edge (M.edge ((p ^ i) a))) + rw [M.edge_invol] + rw [h2, hstep i] + change p ((p ^ (j - i)) a) = (p ^ (j - i + 1)) a + rw [show j - i + 1 = 1 + (j - i) from by ring, zpow_add, zpow_one] + rfl + rcases Int.even_or_odd j with ⟨i, hi⟩ | ⟨i, hi⟩ + · refine M.edge_ne ((p ^ i) a) ?_ + rw [hstep i, hi, show i + i - i = i from by ring] + · refine N.edge_ne ((p ^ (i + 1)) a) ?_ + rw [hNstep (i + 1), hi, + show 2 * i + 1 - (i + 1) + 1 = i + 1 from by ring] + +/-- The cycle of a point, as a finset. -/ +noncomputable def cycleOf [Fintype α] [DecidableEq α] + (p : Equiv.Perm α) (a : α) : Finset α := + Finset.univ.filter (fun x => p.SameCycle a x) + +/-- Membership in a cycle: being on the same cycle as the base +point. -/ +theorem mem_cycleOf [Fintype α] [DecidableEq α] {p : Equiv.Perm α} + {a x : α} : x ∈ cycleOf p a ↔ p.SameCycle a x := by + rw [cycleOf, Finset.mem_filter] + exact ⟨fun h => h.2, fun h => ⟨Finset.mem_univ x, h⟩⟩ + +/-- A point lies on its own cycle. -/ +theorem self_mem_cycleOf [Fintype α] [DecidableEq α] + (p : Equiv.Perm α) (a : α) : a ∈ cycleOf p a := + mem_cycleOf.mpr (Equiv.Perm.SameCycle.refl p a) + +/-- Points on one cycle have the same cycle. -/ +theorem cycleOf_eq [Fintype α] [DecidableEq α] {p : Equiv.Perm α} + {a b : α} (h : p.SameCycle a b) : cycleOf p a = cycleOf p b := + Finset.ext (fun x => by + rw [mem_cycleOf, mem_cycleOf] + exact ⟨fun hx => h.symm.trans hx, fun hx => h.trans hx⟩) + +/-- **The key of a cycle**: the least index of a point on it. -/ +noncomputable def cycleKey [Fintype α] [DecidableEq α] + (p : Equiv.Perm α) (a : α) : Fin (Fintype.card α) := + ((cycleOf p a).image (Fintype.equivFin α)).min' + ⟨Fintype.equivFin α a, + Finset.mem_image_of_mem _ (self_mem_cycleOf p a)⟩ + +/-- Points on the same cycle have the same key, so the key names +the cycle. -/ +theorem cycleKey_eq [Fintype α] [DecidableEq α] {p : Equiv.Perm α} + {a b : α} (h : p.SameCycle a b) : + cycleKey p a = cycleKey p b := by + unfold cycleKey + congr 1 + rw [cycleOf_eq h] + +/-- Distinct cycles have distinct keys: a key is attained on its own +cycle, and two cycles sharing a point coincide. -/ +theorem sameCycle_of_cycleKey_eq [Fintype α] [DecidableEq α] + {p : Equiv.Perm α} {a b : α} (h : cycleKey p a = cycleKey p b) : + p.SameCycle a b := by + obtain ⟨x, hx, hfx⟩ := Finset.mem_image.mp + (Finset.min'_mem ((cycleOf p a).image (Fintype.equivFin α)) + ⟨Fintype.equivFin α a, + Finset.mem_image_of_mem _ (self_mem_cycleOf p a)⟩) + obtain ⟨y, hy, hfy⟩ := Finset.mem_image.mp + (Finset.min'_mem ((cycleOf p b).image (Fintype.equivFin α)) + ⟨Fintype.equivFin α b, + Finset.mem_image_of_mem _ (self_mem_cycleOf p b)⟩) + have hxy : x = y := (Fintype.equivFin α).injective (by + rw [hfx, hfy]; exact h) + have h1 : p.SameCycle a y := hxy ▸ mem_cycleOf.mp hx + exact h1.trans (mem_cycleOf.mp hy).symm + +/-- **Any two matchings admit a common repair to Eulerian +position** — RS21's `σ₁` and `σ₂`. The repair leaves both pairings +alone and makes the union alternating. -/ +theorem exists_alternating_repair [Finite α] + (M N : DirMatching α) : + ∃ M' N' : DirMatching α, + M'.edge = M.edge ∧ N'.edge = N.edge ∧ Alternating M' N' := by + classical + let := Fintype.ofFinite α + set p : Equiv.Perm α := N.edgePerm * M.edgePerm with hp + set T : α → Bool := + fun a => decide (cycleKey p a < cycleKey p (M.edge a)) with hT + have hne : ∀ a, cycleKey p a ≠ cycleKey p (M.edge a) := fun a hx => + not_sameCycle_edge M N a (sameCycle_of_cycleKey_eq hx) + have hflip : ∀ a : α, ∀ u v : Fin (Fintype.card α), u ≠ v → + decide (v < u) = !decide (u < v) := by + intro _ u v huv + rcases lt_trichotomy u v with h | h | h + · rw [decide_eq_false (not_lt.mpr h.le), decide_eq_true h]; rfl + · exact absurd h huv + · rw [decide_eq_true h, decide_eq_false (not_lt.mpr h.le)]; rfl + have hMflip : ∀ a, T (M.edge a) = !T a := by + intro a + change decide (cycleKey p (M.edge a) + < cycleKey p (M.edge (M.edge a))) + = !decide (cycleKey p a < cycleKey p (M.edge a)) + rw [M.edge_invol] + exact hflip a _ _ (hne a) + have hkeyN : ∀ a, cycleKey p (N.edge a) = cycleKey p (M.edge a) := by + intro a + refine (cycleKey_eq (⟨1, ?_⟩ : p.SameCycle (M.edge a) (N.edge a))).symm + show (p ^ (1 : ℤ)) (M.edge a) = N.edge a + rw [zpow_one, hp] + change N.edge (M.edge (M.edge a)) = N.edge a + rw [M.edge_invol] + have hkeyMN : ∀ a, cycleKey p (M.edge (N.edge a)) = cycleKey p a := by + intro a + refine (cycleKey_eq (⟨-1, ?_⟩ : p.SameCycle a (M.edge (N.edge a)))).symm + show (p ^ (-1 : ℤ)) a = M.edge (N.edge a) + rw [zpow_neg, zpow_one, hp, inv_edgePerm_mul] + rfl + have hNflip : ∀ a, T (N.edge a) = !T a := by + intro a + change decide (cycleKey p (N.edge a) + < cycleKey p (M.edge (N.edge a))) + = !decide (cycleKey p a < cycleKey p (M.edge a)) + rw [hkeyN a, hkeyMN a] + exact hflip a _ _ (hne a) + refine ⟨{ edge := M.edge, edge_invol := M.edge_invol, + edge_ne := M.edge_ne, tail := T, tail_flip := hMflip }, + { edge := N.edge, edge_invol := N.edge_invol, + edge_ne := N.edge_ne, tail := fun a => !T a, + tail_flip := fun a => by rw [hNflip a] }, + rfl, rfl, fun _ => rfl⟩ + +/-- **The direction hypothesis is automatic** along an arc of the +interface matching: the union being Eulerian at the two identified +labels is exactly what the contraction needs. -/ +theorem tail_ne_of_alternating {M N : DirMatching α} + (h : Alternating M N) {i j : α} (hN : N.edge i = j) : + M.tail j = !M.tail i := by + have h1 : N.tail j = !N.tail i := by + rw [← hN] + exact N.tail_flip i + rw [h j, h i, Bool.not_not] at h1 + rw [← h1, Bool.not_not] + +/-! ### Contracting a matching at an identified pair + +Gluing one interface pair identifies two labels. On the chord +matching that is a contraction: the two labels are removed and their +partners are matched to one another, which is the same rewiring the +flag model performs on the edge pairing. + +The contraction is defined when the two identified labels are not +already partners. When they are, gluing closes a circuit instead, +and the two labels simply disappear — that dichotomy is what makes +the circuit count go up by one exactly once per component of the +union. + +Directions contract only when the two identified labels carry +opposite ones, which is RS21's requirement that the two Eulerian +orientations induce an Eulerian orientation of the glued subset. +-/ + +/-- The points surviving the identification of `i` and `j`. -/ +abbrev Surviving (i j : α) : Type := {x : α // x ≠ i ∧ x ≠ j} + +/-- **An excursion through the identified pair has length two.** -/ +theorem rot_rot_of_interface (h : Alternating M N) {i j : α} + (hN : N.edge i = j) (x : Surviving i j) + (hs : M.rot N x.val = i ∨ M.rot N x.val = j) : + M.rot N (M.rot N x.val) = i ∨ M.rot N (M.rot N x.val) = j := by + have hNj : N.edge j = i := by rw [← hN, N.edge_invol] + have hdir := tail_ne_of_alternating h hN + have hx : M.tail x.val = true := by + by_contra hx + have hrot : M.rot N x.val = N.edge x.val := by + unfold rot; rw [ite_eq_right hx] + rcases hs with hs | hs <;> rw [hrot] at hs + · exact x.prop.2 (((N.edge_invol x.val).symm.trans + (congrArg N.edge hs)).trans hN) + · exact x.prop.1 (((N.edge_invol x.val).symm.trans + (congrArg N.edge hs)).trans hNj) + have hrot : M.rot N x.val = M.edge x.val := by + unfold rot; rw [ite_eq_left hx] + rcases hs with hs | hs + · refine Or.inr ?_ + have hti : M.tail i = false := by + have hf := M.tail_flip x.val + rw [← hrot, hs, hx] at hf + exact hf + rw [hs] + unfold rot + rw [ite_eq_right (by rw [hti]; exact Bool.noConfusion), hN] + · refine Or.inl ?_ + have htj : M.tail j = false := by + have hf := M.tail_flip x.val + rw [← hrot, hs, hx] at hf + exact hf + rw [hs] + unfold rot + rw [ite_eq_right (by rw [htj]; exact Bool.noConfusion), hNj] + +/-- The contracted partner map: the partners of the two identified +points are matched to one another. -/ +def contractEdge [DecidableEq α] (M : DirMatching α) (i j : α) + (x : α) : α := + if M.edge x = i then M.edge j + else if M.edge x = j then M.edge i + else M.edge x + +/-- The contracted partner map reads only the pairing. -/ +theorem contractEdge_congr [DecidableEq α] {M M' : DirMatching α} + (h : M'.edge = M.edge) (i j : α) (x : α) : + M'.contractEdge i j x = M.contractEdge i j x := by + unfold contractEdge + rw [h] + +/-- The contracted partner map avoids the two identified points: +they are gone from the contracted set. -/ +theorem contractEdge_ne [DecidableEq α] (M : DirMatching α) {i j : α} + (hopen : M.edge i ≠ j) (x : α) : + M.contractEdge i j x ≠ i ∧ M.contractEdge i j x ≠ j := by + unfold contractEdge + by_cases h1 : M.edge x = i + · rw [ite_eq_left h1] + refine ⟨fun hx => hopen ?_, fun hx => M.edge_ne j hx⟩ + rw [← hx, M.edge_invol] + · by_cases h2 : M.edge x = j + · rw [ite_eq_right h1, ite_eq_left h2] + exact ⟨M.edge_ne i, hopen⟩ + · rw [ite_eq_right h1, ite_eq_right h2] + exact ⟨h1, h2⟩ + +/-- It is an involution on the survivors. -/ +theorem contractEdge_invol [DecidableEq α] (M : DirMatching α) {i j : α} + (hij : i ≠ j) + (x : α) (hx : x ≠ i) (hx' : x ≠ j) : + M.contractEdge i j (M.contractEdge i j x) = x := by + unfold contractEdge + by_cases h1 : M.edge x = i + · rw [ite_eq_left h1, ite_eq_right (by rw [M.edge_invol]; exact Ne.symm hij), + ite_eq_left (by rw [M.edge_invol])] + rw [← h1, M.edge_invol] + · by_cases h2 : M.edge x = j + · rw [ite_eq_right h1, ite_eq_left h2, ite_eq_left (by rw [M.edge_invol])] + rw [← h2, M.edge_invol] + · rw [ite_eq_right h1, ite_eq_right h2, + ite_eq_right (by rw [M.edge_invol]; exact hx), + ite_eq_right (by rw [M.edge_invol]; exact hx'), M.edge_invol] + +/-- And fixed-point-free, so it is again a perfect matching. -/ +theorem contractEdge_ne_self [DecidableEq α] (M : DirMatching α) {i j : α} + (hij : i ≠ j) (x : α) : M.contractEdge i j x ≠ x := by + unfold contractEdge + by_cases h1 : M.edge x = i + · rw [ite_eq_left h1] + intro hx + refine Ne.symm hij ?_ + rw [← hx] at h1 + rwa [M.edge_invol] at h1 + · by_cases h2 : M.edge x = j + · rw [ite_eq_right h1, ite_eq_left h2] + intro hx + refine hij ?_ + rw [← hx] at h2 + rwa [M.edge_invol] at h2 + · rw [ite_eq_right h1, ite_eq_right h2] + exact M.edge_ne x + +/-- **The contraction of a matching at an identified pair.** The +two identified points must carry opposite directions, which is what +makes the contracted directions consistent — RS21's requirement that +the two Eulerian orientations induce an Eulerian orientation of the +glued subset. -/ +def contract [DecidableEq α] (M : DirMatching α) {i j : α} (hij : i ≠ j) + (hopen : M.edge i ≠ j) (hdir : M.tail j = !M.tail i) : + DirMatching (Surviving i j) where + edge x := ⟨M.contractEdge i j x.val, + M.contractEdge_ne hopen x.val⟩ + edge_invol x := Subtype.ext + (M.contractEdge_invol hij x.val x.prop.1 x.prop.2) + edge_ne x hx := M.contractEdge_ne_self hij x.val + (congrArg Subtype.val hx) + tail x := M.tail x.val + tail_flip x := by + change M.tail (M.contractEdge i j x.val) = !M.tail x.val + unfold contractEdge + by_cases h1 : M.edge x.val = i + · rw [ite_eq_left h1, M.tail_flip j, hdir, Bool.not_not] + have hxx := M.tail_flip x.val + rw [h1] at hxx + exact hxx + · by_cases h2 : M.edge x.val = j + · rw [ite_eq_right h1, ite_eq_left h2, M.tail_flip i] + have hxx := M.tail_flip x.val + rw [h2, hdir] at hxx + exact hxx + · rw [ite_eq_right h1, ite_eq_right h2, M.tail_flip x.val] + +/-! ### The interface matching after one identification + +Gluing one interface pair consumes one arc of the interface +matching and contracts the chord matching at its two ends. The +remaining interface arcs restrict to the surviving labels, and the +union of the two matchings stays Eulerian, so the step can be +iterated. +-/ + +/-- The interface matching restricted to the labels surviving the +identification of one of its own arcs. -/ +def restrict (N : DirMatching α) {i j : α} (hN : N.edge i = j) : + DirMatching (Surviving i j) where + edge x := ⟨N.edge x.val, by + have hNj : N.edge j = i := by rw [← hN, N.edge_invol] + refine ⟨fun hx => x.prop.2 ?_, fun hx => x.prop.1 ?_⟩ + · exact ((N.edge_invol x.val).symm.trans + (congrArg N.edge hx)).trans hN + · exact ((N.edge_invol x.val).symm.trans + (congrArg N.edge hx)).trans hNj⟩ + edge_invol x := Subtype.ext (N.edge_invol x.val) + edge_ne x hx := N.edge_ne x.val (congrArg Subtype.val hx) + tail x := N.tail x.val + tail_flip x := N.tail_flip x.val + +/-- **The union stays Eulerian after one identification.** -/ +theorem alternating_contract [DecidableEq α] {M N : DirMatching α} + (h : Alternating M N) {i j : α} (hij : i ≠ j) + (hN : N.edge i = j) (hopen : M.edge i ≠ j) : + Alternating (M.contract hij hopen (tail_ne_of_alternating h hN)) + (N.restrict hN) := + fun x => h x.val + +/-! ### One step of the contracted rotation + +One step of the contracted rotation is one or three steps of the +original: the contraction short-circuits the two identified labels, +so a step that would have landed on one of them instead continues +past both. Either way the step stays inside a single orbit of the +original rotation, which is what carries orbits across the +contraction. +-/ + +/-- **A contracted step stays in one orbit of the original +rotation.** -/ +theorem sameCycle_rot_contract [DecidableEq α] {M N : DirMatching α} + (h : Alternating M N) {i j : α} (hij : i ≠ j) + (hN : N.edge i = j) (hopen : M.edge i ≠ j) + (x : Surviving i j) : + (M.rotPerm N h).SameCycle x.val + (((M.contract hij hopen (tail_ne_of_alternating h hN)).rotPerm + (N.restrict hN) (alternating_contract h hij hN hopen)) x).val := by + have hNj : N.edge j = i := by rw [← hN, N.edge_invol] + have hval : (((M.contract hij hopen + (tail_ne_of_alternating h hN)).rotPerm (N.restrict hN) + (alternating_contract h hij hN hopen)) x).val + = if M.tail x.val then M.contractEdge i j x.val + else N.edge x.val := by + change ((M.contract hij hopen + (tail_ne_of_alternating h hN)).rot (N.restrict hN) x).val = _ + unfold rot + by_cases hx : M.tail x.val = true + · rw [ite_eq_left (show (M.contract hij hopen + (tail_ne_of_alternating h hN)).tail x = true from hx), + ite_eq_left hx] + rfl + · rw [ite_eq_right (show ¬ ((M.contract hij hopen + (tail_ne_of_alternating h hN)).tail x = true) from hx), + ite_eq_right hx] + rfl + rw [hval] + by_cases hx : M.tail x.val = true + · rw [ite_eq_left hx] + unfold contractEdge + by_cases h1 : M.edge x.val = i + · rw [ite_eq_left h1] + refine ((sameCycle_rot_edge h x.val).trans ?_).trans + (sameCycle_rot_edge h j) + rw [h1, ← hN] + exact sameCycle_rot_edge' h i + · by_cases h2 : M.edge x.val = j + · rw [ite_eq_right h1, ite_eq_left h2] + refine ((sameCycle_rot_edge h x.val).trans ?_).trans + (sameCycle_rot_edge h i) + rw [h2, ← hNj] + exact sameCycle_rot_edge' h j + · rw [ite_eq_right h1, ite_eq_right h2] + exact sameCycle_rot_edge h x.val + · rw [ite_eq_right hx] + exact sameCycle_rot_edge' h x.val + +/-- **The contraction's orbits map to the original's.** -/ +theorem sameCycle_of_contract [DecidableEq α] {M N : DirMatching α} + (h : Alternating M N) {i j : α} (hij : i ≠ j) + (hN : N.edge i = j) (hopen : M.edge i ≠ j) + {x y : Surviving i j} + (hxy : ((M.contract hij hopen (tail_ne_of_alternating h hN)).rotPerm + (N.restrict hN) + (alternating_contract h hij hN hopen)).SameCycle x y) : + (M.rotPerm N h).SameCycle x.val y.val := + sameCycle_of_step Subtype.val + (fun z => sameCycle_rot_contract h hij hN hopen z) hxy + +/-! ### The contracted rotation is the original, short-circuited + +A survivor whose rotation step lands on a surviving point takes the +same step in the contraction. A survivor whose step lands on one of +the two identified points is carried three steps instead: through +both of them and out the far side. Those are the only two cases, +and together they say the contracted rotation is the original with +the identified pair skipped. +-/ + +/-- The rotation's step at a survivor, in the contraction. -/ +theorem rot_contract_val [DecidableEq α] (h : Alternating M N) {i j : α} + (hij : i ≠ j) + (hN : N.edge i = j) (hopen : M.edge i ≠ j) (x : Surviving i j) : + (((M.contract hij hopen (tail_ne_of_alternating h hN)).rotPerm + (N.restrict hN) (alternating_contract h hij hN hopen)) x).val + = if M.tail x.val then M.contractEdge i j x.val + else N.edge x.val := by + change ((M.contract hij hopen + (tail_ne_of_alternating h hN)).rot (N.restrict hN) x).val = _ + unfold rot + by_cases hx : M.tail x.val = true + · rw [ite_eq_left (show (M.contract hij hopen + (tail_ne_of_alternating h hN)).tail x = true from hx), + ite_eq_left hx] + rfl + · rw [ite_eq_right (show ¬ ((M.contract hij hopen + (tail_ne_of_alternating h hN)).tail x = true) from hx), + ite_eq_right hx] + rfl + +/-- **A step landing on a survivor is unchanged.** -/ +theorem rot_contract_eq_rot [DecidableEq α] (h : Alternating M N) {i j : α} + (hij : i ≠ j) (hN : N.edge i = j) (hopen : M.edge i ≠ j) + (x : Surviving i j) (hs : M.rot N x.val ≠ i) + (hs' : M.rot N x.val ≠ j) : + (((M.contract hij hopen (tail_ne_of_alternating h hN)).rotPerm + (N.restrict hN) (alternating_contract h hij hN hopen)) x).val + = M.rot N x.val := by + rw [rot_contract_val h hij hN hopen x] + unfold rot at hs hs' ⊢ + by_cases hx : M.tail x.val = true + · rw [ite_eq_left hx] at hs hs' + rw [ite_eq_left hx, ite_eq_left hx] + unfold contractEdge + rw [ite_eq_right hs, ite_eq_right hs'] + · rw [ite_eq_right hx] at hs hs' + rw [ite_eq_right hx, ite_eq_right hx] + +/-- **A step landing on an identified point runs three steps.** -/ +theorem rot_contract_eq_rot_three [DecidableEq α] (h : Alternating M N) + {i j : α} + (hij : i ≠ j) (hN : N.edge i = j) (hopen : M.edge i ≠ j) + (x : Surviving i j) (hs : M.rot N x.val = i ∨ M.rot N x.val = j) : + (((M.contract hij hopen (tail_ne_of_alternating h hN)).rotPerm + (N.restrict hN) (alternating_contract h hij hN hopen)) x).val + = M.rot N (M.rot N (M.rot N x.val)) := by + have hNj : N.edge j = i := by rw [← hN, N.edge_invol] + have hdir := tail_ne_of_alternating h hN + -- the step cannot be along the interface matching + have hx : M.tail x.val = true := by + by_contra hx + have hrot : M.rot N x.val = N.edge x.val := by + unfold rot; rw [ite_eq_right hx] + rcases hs with hs | hs <;> rw [hrot] at hs + · exact x.prop.2 (((N.edge_invol x.val).symm.trans + (congrArg N.edge hs)).trans hN) + · exact x.prop.1 (((N.edge_invol x.val).symm.trans + (congrArg N.edge hs)).trans hNj) + have hrot : M.rot N x.val = M.edge x.val := by + unfold rot; rw [ite_eq_left hx] + rw [rot_contract_val h hij hN hopen x, ite_eq_left hx] + unfold contractEdge + rcases hs with hs | hs <;> rw [hrot] at hs + · -- the step lands on `i`; continue `i → j → M.edge j` + have hti : M.tail i = false := by + have := M.tail_flip x.val + rw [hs, hx] at this + exact this + have htj : M.tail j = true := by + rw [hdir, hti]; rfl + rw [ite_eq_left hs, hrot, hs] + have h1 : M.rot N i = j := by + unfold rot; rw [ite_eq_right (by rw [hti]; exact Bool.noConfusion), hN] + have h2 : M.rot N j = M.edge j := by + unfold rot; rw [ite_eq_left htj] + rw [h1, h2] + · -- the step lands on `j`; continue `j → i → M.edge i` + have htj : M.tail j = false := by + have := M.tail_flip x.val + rw [hs, hx] at this + exact this + have hti : M.tail i = true := by + cases hb : M.tail i + · rw [hb] at hdir + rw [hdir] at htj + exact Bool.noConfusion htj + · rfl + rw [ite_eq_right (fun hxi => hij (hxi.symm.trans hs)), ite_eq_left hs, + hrot, hs] + have h1 : M.rot N j = i := by + unfold rot; rw [ite_eq_right (by rw [htj]; exact Bool.noConfusion), hNj] + have h2 : M.rot N i = M.edge i := by + unfold rot; rw [ite_eq_left hti] + rw [h1, h2] + +/-! ### The converse: the contraction loses no orbits + +A rotation path between two survivors passes through the identified +pair only in excursions of length two, and the contraction takes +each such excursion in a single step. So survivors joined by the +original rotation are joined by the contracted one, and together +with the forward direction the two rotations have the same orbits. +-/ + +/-- The survivor standing for a point: itself where it survives, and +otherwise the partner of the first identified label, which lies on +the same orbit as both of them. -/ +noncomputable def pickSurvivor [DecidableEq α] (M : DirMatching α) + {i j : α} + (hopen : M.edge i ≠ j) (a : α) : Surviving i j := + if ha : a ≠ i ∧ a ≠ j then ⟨a, ha⟩ + else ⟨M.edge i, M.edge_ne i, hopen⟩ + +/-- A point and the survivor standing for it lie on the same cycle +of the rotation, so the choice does not move between components. -/ +theorem sameCycle_pickSurvivor [DecidableEq α] (h : Alternating M N) + {i j : α} + (hN : N.edge i = j) (hopen : M.edge i ≠ j) (a : α) : + (M.rotPerm N h).SameCycle a (M.pickSurvivor hopen a).val := by + have hNj : N.edge j = i := by rw [← hN, N.edge_invol] + unfold pickSurvivor + by_cases ha : a ≠ i ∧ a ≠ j + · rw [dite_eq_left ha] + · rw [dite_eq_right ha] + have ha' : a = i ∨ a = j := by + by_contra hc + exact ha ⟨fun hx => hc (Or.inl hx), fun hx => hc (Or.inr hx)⟩ + rcases ha' with h1 | h1 + · rw [h1] + exact sameCycle_rot_edge h i + · rw [h1] + have h2 : (M.rotPerm N h).SameCycle j i := by + have hj := sameCycle_rot_edge' h j + rwa [hNj] at hj + exact h2.trans (sameCycle_rot_edge h i) + +/-- **Survivors joined by the original rotation are joined by the +contracted one.** -/ +theorem sameCycle_contract_of_sameCycle [Finite α] [DecidableEq α] + (h : Alternating M N) + {i j : α} (hij : i ≠ j) (hN : N.edge i = j) + (hopen : M.edge i ≠ j) {x y : Surviving i j} + (hxy : (M.rotPerm N h).SameCycle x.val y.val) : + ((M.contract hij hopen (tail_ne_of_alternating h hN)).rotPerm + (N.restrict hN) + (alternating_contract h hij hN hopen)).SameCycle x y := by + classical + let := Fintype.ofFinite α + obtain ⟨n, hn⟩ := hxy.exists_nat_pow_eq + clear hxy + induction n using Nat.strong_induction_on generalizing x with + | _ n ih => + match n, hn with + | 0, hn => + have hval : x.val = y.val := hn + exact ⟨0, by rw [zpow_zero]; exact Subtype.ext hval⟩ + | (m + 1), hn => + have hstep : ((M.rotPerm N h) ^ (m + 1)) x.val + = ((M.rotPerm N h) ^ m) (M.rot N x.val) := by + rw [pow_succ] + rfl + rw [hstep] at hn + by_cases hz : M.rot N x.val = i ∨ M.rot N x.val = j + · -- an excursion: three steps of the original, one of the + -- contraction + have hz2 := rot_rot_of_interface h hN x hz + have hm3 : 3 ≤ m + 1 := by + by_contra hlt + have hm2 : m < 2 := by omega + interval_cases m + · have hy : M.rot N x.val = y.val := hn + rcases hz with hz | hz + · exact y.prop.1 (hy.symm.trans hz) + · exact y.prop.2 (hy.symm.trans hz) + · have hy : M.rot N (M.rot N x.val) = y.val := hn + rcases hz2 with hz2 | hz2 + · exact y.prop.1 (hy.symm.trans hz2) + · exact y.prop.2 (hy.symm.trans hz2) + set x' := ((M.contract hij hopen + (tail_ne_of_alternating h hN)).rotPerm (N.restrict hN) + (alternating_contract h hij hN hopen)) x with hx' + have hval : x'.val = M.rot N (M.rot N (M.rot N x.val)) := + rot_contract_eq_rot_three h hij hN hopen x hz + have hrest : ((M.rotPerm N h) ^ (m + 1 - 3)) x'.val = y.val := by + rw [hval] + rw [show m = (m + 1 - 3) + 2 from by omega, pow_add] at hn + exact hn + have hone : ((M.contract hij hopen + (tail_ne_of_alternating h hN)).rotPerm (N.restrict hN) + (alternating_contract h hij hN hopen)).SameCycle x x' := + ⟨1, by rw [zpow_one]⟩ + exact hone.trans (ih (m + 1 - 3) (by omega) (x := x') hrest) + · -- an ordinary step + push Not at hz + set x' : Surviving i j := ⟨M.rot N x.val, hz⟩ with hx' + have hval : (((M.contract hij hopen + (tail_ne_of_alternating h hN)).rotPerm (N.restrict hN) + (alternating_contract h hij hN hopen)) x) = x' := + Subtype.ext (rot_contract_eq_rot h hij hN hopen x hz.1 hz.2) + have hone : ((M.contract hij hopen + (tail_ne_of_alternating h hN)).rotPerm (N.restrict hN) + (alternating_contract h hij hN hopen)).SameCycle x x' := + ⟨1, by rw [zpow_one]; exact hval⟩ + exact hone.trans (ih m (by omega) (x := x') hn) + +/-! ### An open glue step preserves the orbit count + +The two directions together say the contraction's orbits are the +original's, so gluing a pair whose two labels are not already +partners changes neither the components of the union nor their +number. That is the half of RS21's circuit-count bookkeeping in +which no circuit closes. +-/ + +/-- **The contraction has the same orbits.** -/ +noncomputable def orbitsEquivContract [Fintype α] [DecidableEq α] + (h : Alternating M N) + {i j : α} (hij : i ≠ j) (hN : N.edge i = j) + (hopen : M.edge i ≠ j) : + Orbits ((M.contract hij hopen (tail_ne_of_alternating h hN)).rotPerm + (N.restrict hN) (alternating_contract h hij hN hopen)) + ≃ Orbits (M.rotPerm N h) where + toFun := Quotient.lift + (fun x => Quotient.mk (Equiv.Perm.SameCycle.setoid (M.rotPerm N h)) x.val) + (fun _ _ hab => + orbit_eq_iff.mpr (sameCycle_of_contract h hij hN hopen hab)) + invFun := Quotient.lift + (fun a => Quotient.mk + (Equiv.Perm.SameCycle.setoid ((M.contract hij hopen + (tail_ne_of_alternating h hN)).rotPerm (N.restrict hN) + (alternating_contract h hij hN hopen))) + (M.pickSurvivor hopen a)) + (fun a b hab => orbit_eq_iff.mpr + (sameCycle_contract_of_sameCycle h hij hN hopen + (((sameCycle_pickSurvivor h hN hopen a).symm.trans hab).trans + (sameCycle_pickSurvivor h hN hopen b)))) + left_inv := by + refine Quotient.ind (fun x => ?_) + have hpick : M.pickSurvivor hopen x.val = x := by + unfold pickSurvivor + rw [dite_eq_left x.prop] + change Quotient.mk _ (M.pickSurvivor hopen x.val) = Quotient.mk _ x + rw [hpick] + right_inv := by + refine Quotient.ind (fun a => ?_) + exact orbit_eq_iff.mpr + (sameCycle_pickSurvivor h hN hopen a).symm + +/-- **An open glue step preserves the number of components.** -/ +theorem orbitCount_contract [Fintype α] [DecidableEq α] + (h : Alternating M N) {i j : α} + (hij : i ≠ j) (hN : N.edge i = j) (hopen : M.edge i ≠ j) : + orbitCount ((M.contract hij hopen + (tail_ne_of_alternating h hN)).rotPerm (N.restrict hN) + (alternating_contract h hij hN hopen)) + = orbitCount (M.rotPerm N h) := + orbitCount_eq_of_orbitsEquiv (orbitsEquivContract h hij hN hopen) + +/-! ### A closed glue step closes one circuit + +When the two identified labels are already partners in the chord +matching, they form a component of the union by themselves: the +rotation carries each to the other and nothing else meets them. +Gluing that pair closes it into a circuit and removes it, so the +number of components drops by exactly one. This is the other half +of RS21's circuit-count bookkeeping, and the only half in which a +circuit appears. +-/ + +/-- The rotation carries each identified label to the other. -/ +theorem rot_closed {i j : α} + (hM : M.edge i = j) (hN : N.edge i = j) : + M.rot N i = j ∧ M.rot N j = i := by + have hMj : M.edge j = i := by rw [← hM, M.edge_invol] + have hNj : N.edge j = i := by rw [← hN, N.edge_invol] + constructor + · unfold rot + by_cases hb : M.tail i = true + · rw [ite_eq_left hb, hM] + · rw [ite_eq_right hb, hN] + · unfold rot + by_cases hb : M.tail j = true + · rw [ite_eq_left hb, hMj] + · rw [ite_eq_right hb, hNj] + +/-- Nothing outside the identified pair meets it. -/ +theorem rot_survivor_closed {i j : α} (hM : M.edge i = j) + (hN : N.edge i = j) (x : Surviving i j) : + M.rot N x.val ≠ i ∧ M.rot N x.val ≠ j := by + have hMj : M.edge j = i := by rw [← hM, M.edge_invol] + have hNj : N.edge j = i := by rw [← hN, N.edge_invol] + have key : ∀ P : DirMatching α, P.edge i = j → P.edge j = i → + P.edge x.val ≠ i ∧ P.edge x.val ≠ j := by + intro P hPi hPj + refine ⟨fun hx => x.prop.2 ?_, fun hx => x.prop.1 ?_⟩ + · exact ((P.edge_invol x.val).symm.trans + (congrArg P.edge hx)).trans hPi + · exact ((P.edge_invol x.val).symm.trans + (congrArg P.edge hx)).trans hPj + unfold rot + by_cases hb : M.tail x.val = true + · rw [ite_eq_left hb] + exact key M hM hMj + · rw [ite_eq_right hb] + exact key N hN hNj + +/-- **The restricted rotation is the rotation restricted.** -/ +theorem rotPerm_restrict (h : Alternating M N) {i j : α} + (hM : M.edge i = j) (hN : N.edge i = j) (x : Surviving i j) : + (((M.restrict hM).rotPerm (N.restrict hN) + (fun z => h z.val)) x).val = M.rot N x.val := by + change ((M.restrict hM).rot (N.restrict hN) x).val = _ + unfold rot + by_cases hb : M.tail x.val = true + · rw [ite_eq_left (show (M.restrict hM).tail x = true from hb), + ite_eq_left hb] + rfl + · rw [ite_eq_right (show ¬ ((M.restrict hM).tail x = true) from hb), + ite_eq_right hb] + rfl + +/-- The identified pair is invariant under the rotation, and so is +its complement. -/ +theorem rot_surviving_iff (h : Alternating M N) + {i j : α} (hM : M.edge i = j) (hN : N.edge i = j) (x : α) : + ((M.rotPerm N h) x ≠ i ∧ (M.rotPerm N h) x ≠ j) + ↔ (x ≠ i ∧ x ≠ j) := by + obtain ⟨hi, hj⟩ := rot_closed hM hN + constructor + · rintro ⟨h1, h2⟩ + refine ⟨fun hx => h2 ?_, fun hx => h1 ?_⟩ + · change M.rot N x = j + rw [hx]; exact hi + · change M.rot N x = i + rw [hx]; exact hj + · intro hx + exact rot_survivor_closed hM hN ⟨x, hx⟩ + +/-- The rotation restricted to the identified pair has one orbit. -/ +theorem orbitCount_pair [Fintype α] [DecidableEq α] + (h : Alternating M N) {i j : α} + (hM : M.edge i = j) (hN : N.edge i = j) : + orbitCount ((M.rotPerm N h).subtypePerm + (p := fun x => ¬ (x ≠ i ∧ x ≠ j)) + (fun x => (rot_surviving_iff h hM hN x).not)) = 1 := by + classical + obtain ⟨hi, hj⟩ := rot_closed hM hN + set π := (M.rotPerm N h).subtypePerm + (p := fun x => ¬ (x ≠ i ∧ x ≠ j)) + (fun x => (rot_surviving_iff h hM hN x).not) with hπ + have hiMem : ¬ ((i : α) ≠ i ∧ (i : α) ≠ j) := fun hc => hc.1 rfl + rw [orbitCount_eq_card_orbits] + refine Fintype.card_eq_one_iff.mpr + ⟨Quotient.mk (Equiv.Perm.SameCycle.setoid π) ⟨i, hiMem⟩, ?_⟩ + refine Quotient.ind (fun z => ?_) + refine orbit_eq_iff.mpr ?_ + have hz : z.val = i ∨ z.val = j := by + by_contra hc + exact z.prop ⟨fun hx => hc (Or.inl hx), fun hx => hc (Or.inr hx)⟩ + rcases hz with hz | hz + · exact (Equiv.Perm.SameCycle.refl π z).trans + (by rw [show z = ⟨i, hiMem⟩ from Subtype.ext hz]) + · refine ⟨1, ?_⟩ + rw [zpow_one] + refine Subtype.ext ?_ + change M.rot N z.val = i + rw [hz] + exact hj + +/-- **A closed glue step closes exactly one circuit.** -/ +theorem orbitCount_restrict_closed [Fintype α] [DecidableEq α] + (h : Alternating M N) {i j : α} + (hM : M.edge i = j) (hN : N.edge i = j) : + orbitCount ((M.restrict hM).rotPerm (N.restrict hN) + (fun z => h z.val)) + 1 + = orbitCount (M.rotPerm N h) := by + classical + have hsplit := orbitCount_eq_add (M.rotPerm N h) + (fun x => x ≠ i ∧ x ≠ j) (fun x => rot_surviving_iff h hM hN x) + have hpair := orbitCount_pair h hM hN + have hrest : (M.rotPerm N h).subtypePerm + (fun x => rot_surviving_iff h hM hN x) + = (M.restrict hM).rotPerm (N.restrict hN) + (fun z => h z.val) := + Equiv.ext (fun z => Subtype.ext + (rotPerm_restrict h hM hN z).symm) + rw [hsplit, hrest, hpair] + +/-! ### The component count ignores the directions + +The rotation depends on which arc leaves each point, but its orbits +do not: one step of either rotation crosses one of the two arcs at a +point, and both arcs are visible to the other rotation as well. So +the number of components of the union is a function of the two +pairings alone. + +This is what lets a matching be transported across a construction +that changes the directions — a glue, say, which can turn a label +into a through-label and so flip the convention that fixes its +direction — as long as the pairings correspond. +-/ + +/-- **The number of components does not depend on the +directions.** -/ +theorem orbitCount_rotPerm_congr [Fintype α] [DecidableEq α] + {M₁ N₁ M₂ N₂ : DirMatching α} (h₁ : Alternating M₁ N₁) + (h₂ : Alternating M₂ N₂) (heM : M₁.edge = M₂.edge) + (heN : N₁.edge = N₂.edge) : + orbitCount (M₁.rotPerm N₁ h₁) = orbitCount (M₂.rotPerm N₂ h₂) := by + have hstep : ∀ (P₁ Q₁ P₂ Q₂ : DirMatching α) + (k₁ : Alternating P₁ Q₁) (k₂ : Alternating P₂ Q₂), + P₁.edge = P₂.edge → Q₁.edge = Q₂.edge → + ∀ a, (P₂.rotPerm Q₂ k₂).SameCycle a (P₁.rot Q₁ a) := by + intro P₁ Q₁ P₂ Q₂ _ k₂ hP hQ a + unfold rot + by_cases ha : P₁.tail a = true + · rw [ite_eq_left ha, show P₁.edge a = P₂.edge a from by rw [hP]] + exact sameCycle_rot_edge k₂ a + · rw [ite_eq_right ha, show Q₁.edge a = Q₂.edge a from by rw [hQ]] + exact sameCycle_rot_edge' k₂ a + refine orbitCount_eq_of_orbitsEquiv ?_ + refine + { toFun := Quotient.lift + (fun a => Quotient.mk (Equiv.Perm.SameCycle.setoid + (M₂.rotPerm N₂ h₂)) a) + (fun _ _ hab => orbit_eq_iff.mpr + (sameCycle_of_step id (hstep M₁ N₁ M₂ N₂ h₁ h₂ heM heN) hab)) + invFun := Quotient.lift + (fun a => Quotient.mk (Equiv.Perm.SameCycle.setoid + (M₁.rotPerm N₁ h₁)) a) + (fun _ _ hab => orbit_eq_iff.mpr + (sameCycle_of_step id + (hstep M₂ N₂ M₁ N₁ h₂ h₁ heM.symm heN.symm) hab)) + left_inv := ?_ + right_inv := ?_ } + · exact Quotient.ind (fun _ => rfl) + · exact Quotient.ind (fun _ => rfl) + +/-! ### The glue steps, stated on the pairings alone + +The transport from a fragment supplies matchings whose pairings are +the contraction's but whose directions come from whatever convention +the glued object uses. Since the component count ignores the +directions, the two steps can be stated that way, and the transport +then has only the pairings to check. +-/ + +/-- **An open glue step, with arbitrary directions.** -/ +theorem orbitCount_contract_congr [Fintype α] [DecidableEq α] + {M N : DirMatching α} (h : Alternating M N) {i j : α} + (hij : i ≠ j) (hN : N.edge i = j) (hopen : M.edge i ≠ j) + {M' N' : DirMatching (Surviving i j)} (h' : Alternating M' N') + (heM : M'.edge + = (M.contract hij hopen (tail_ne_of_alternating h hN)).edge) + (heN : N'.edge = (N.restrict hN).edge) : + orbitCount (M'.rotPerm N' h') = orbitCount (M.rotPerm N h) := by + rw [orbitCount_rotPerm_congr h' + (alternating_contract h hij hN hopen) heM heN] + exact orbitCount_contract h hij hN hopen + +/-- **A closed glue step, with arbitrary directions.** -/ +theorem orbitCount_restrict_closed_congr [Fintype α] [DecidableEq α] + {M N : DirMatching α} (h : Alternating M N) {i j : α} + (hM : M.edge i = j) (hN : N.edge i = j) + {M' N' : DirMatching (Surviving i j)} (h' : Alternating M' N') + (heM : M'.edge = (M.restrict hM).edge) + (heN : N'.edge = (N.restrict hN).edge) : + orbitCount (M'.rotPerm N' h') + 1 + = orbitCount (M.rotPerm N h) := by + rw [orbitCount_rotPerm_congr h' (fun z => h z.val) heM heN] + exact orbitCount_restrict_closed h hM hN + +/-- **Transporting a pair of matchings along a bijection conjugates +the rotation**, so the component count is unchanged. -/ +theorem orbitCount_map [Fintype α] [DecidableEq α] {β : Type} + [Fintype β] [DecidableEq β] (e : α ≃ β) {M N : DirMatching α} + (h : Alternating M N) (h' : Alternating (M.map e) (N.map e)) : + orbitCount ((M.map e).rotPerm (N.map e) h') + = orbitCount (M.rotPerm N h) := by + have hconj : (M.map e).rotPerm (N.map e) h' + = e.permCongr (M.rotPerm N h) := by + refine Equiv.ext (fun b => ?_) + change (M.map e).rot (N.map e) b = e (M.rot N (e.symm b)) + unfold rot map + by_cases hb : M.tail (e.symm b) = true + · rw [ite_eq_left hb, ite_eq_left hb] + · rw [ite_eq_right hb, ite_eq_right hb] + rw [hconj, orbitCount_permCongr] + +/-- The transported matching's partner map, conjugated by the +equivalence. -/ +theorem map_edge {β : Type} (e : α ≃ β) (M : DirMatching α) (b : β) : + (M.map e).edge b = e (M.edge (e.symm b)) := rfl + +/-- Transported matchings have the same pairing when the originals +do. -/ +theorem map_edge_congr {β : Type} (e : α ≃ β) {M M' : DirMatching α} + (h : M'.edge = M.edge) : (M'.map e).edge = (M.map e).edge := + funext (fun b => congrArg e (congrFun h (e.symm b))) + +/-- Transporting a pair of matchings preserves the Eulerian +condition. -/ +theorem alternating_map {β : Type} (e : α ≃ β) {M N : DirMatching α} + (h : Alternating M N) : Alternating (M.map e) (N.map e) := + fun b => h (e.symm b) + +/-- **At a closed pair the contraction is the plain restriction**: +no surviving point has either identified label as its partner. -/ +theorem contractEdge_of_closed [DecidableEq α] (M : DirMatching α) + {i j : α} (hM : M.edge i = j) (x : α) (hx : x ≠ i) + (hx' : x ≠ j) : M.contractEdge i j x = M.edge x := by + have hMj : M.edge j = i := by rw [← hM, M.edge_invol] + unfold contractEdge + rw [ite_eq_right (fun hc => hx' (((M.edge_invol x).symm.trans + (congrArg M.edge hc)).trans hM)), + ite_eq_right (fun hc => hx (((M.edge_invol x).symm.trans + (congrArg M.edge hc)).trans hMj))] + +/-! ### The component count of a union + +RS21's `c(M ∪ N)` is the number of connected components of the union +of two directed matchings, and the union has those components +whatever the directions are: the repair to Eulerian position exists +and the count does not depend on which one is taken. Naming the +count that way removes the Eulerian position from every statement +that only reads it — and that is most of them, the position mattering +only where the *signs* do. +-/ + +/-- **The number of components of the union of two matchings** — +RS21's `c(M ∪ N)`, read at any repair to Eulerian position. It +carries no decidability instance: on a sum type the ambient one is +the sum's own, which is not the one a linear order supplies, and the +two would not match where the recursion compares them. -/ +noncomputable def unionCount [Fintype α] (M N : DirMatching α) : ℕ := + letI := Classical.decEq α + orbitCount ((exists_alternating_repair M N).choose.rotPerm + (exists_alternating_repair M N).choose_spec.choose + (exists_alternating_repair M N).choose_spec.choose_spec.2.2) + +/-- **The count is what any Eulerian pair with the same pairings +counts.** -/ +theorem unionCount_eq_orbitCount [Fintype α] [DecidableEq α] + {M N M' N' : DirMatching α} (h' : Alternating M' N') + (heM : M'.edge = M.edge) (heN : N'.edge = N.edge) : + unionCount M N = orbitCount (M'.rotPerm N' h') := by + change (letI := Classical.decEq α; orbitCount _) = _ + rw [orbitCount_congr_decEq (Classical.decEq α) (inferInstance)] + refine orbitCount_rotPerm_congr _ h' ?_ ?_ + · rw [(exists_alternating_repair M N).choose_spec.choose_spec.1, + heM] + · rw [(exists_alternating_repair M N).choose_spec.choose_spec.2.1, + heN] + +/-- **The count depends on the pairings alone.** -/ +theorem unionCount_congr [Fintype α] {M₁ N₁ M₂ N₂ : DirMatching α} + (heM : M₁.edge = M₂.edge) (heN : N₁.edge = N₂.edge) : + unionCount M₁ N₁ = unionCount M₂ N₂ := by + classical + refine (unionCount_eq_orbitCount + (M := M₁) (N := N₁) + (exists_alternating_repair M₂ N₂).choose_spec.choose_spec.2.2 + ?_ ?_).trans + (unionCount_eq_orbitCount (M := M₂) (N := N₂) + (exists_alternating_repair M₂ N₂).choose_spec.choose_spec.2.2 + (exists_alternating_repair M₂ N₂).choose_spec.choose_spec.1 + (exists_alternating_repair M₂ + N₂).choose_spec.choose_spec.2.1).symm + · rw [(exists_alternating_repair M₂ N₂).choose_spec.choose_spec.1, + heM] + · rw [(exists_alternating_repair M₂ N₂).choose_spec.choose_spec.2.1, + heN] + +/-- **An empty ground set has no components.** -/ +theorem unionCount_of_isEmpty [Fintype α] [IsEmpty α] + (M N : DirMatching α) : unionCount M N = 0 := by + classical + rw [unionCount_eq_orbitCount + (exists_alternating_repair M N).choose_spec.choose_spec.2.2 + (exists_alternating_repair M N).choose_spec.choose_spec.1 + (exists_alternating_repair M N).choose_spec.choose_spec.2.1, + orbitCount_eq_card_orbits] + refine Fintype.card_eq_zero_iff.mpr ⟨fun o => ?_⟩ + exact Quotient.inductionOn o (fun x => isEmptyElim x) + +/-- **The count survives a relabelling of the ground set.** -/ +theorem unionCount_map [Fintype α] {β : Type} [Fintype β] + (e : α ≃ β) (M N : DirMatching α) : + unionCount (M.map e) (N.map e) = unionCount M N := by + classical + set A := (exists_alternating_repair M N).choose with hA + set B := (exists_alternating_repair M N).choose_spec.choose with hB + have hspec := (exists_alternating_repair M N).choose_spec.choose_spec + have hAB : Alternating A B := hspec.2.2 + rw [unionCount_eq_orbitCount (M := M.map e) (N := N.map e) + (alternating_map e hAB) + (by funext b; exact congrArg e (congrFun hspec.1 (e.symm b))) + (by funext b; exact congrArg e (congrFun hspec.2.1 (e.symm b))), + unionCount_eq_orbitCount (M := M) (N := N) hAB hspec.1 hspec.2.1, + orbitCount_map e hAB (alternating_map e hAB)] + +/-- **Lemma 11 across an identification**: two matchings whose +directions are opposite along an order isomorphism have signs +multiplying to `(-1)` to the number of components of their union. -/ +theorem sgnRel_mul_sgnRel_of_alternating {γ δ : Type} [LinearOrder γ] + [LinearOrder δ] [Fintype γ] [Fintype δ] (E : γ ≃o δ) {m : ℕ} + (hc : Fintype.card γ = 2 * m) (hc' : Fintype.card δ = 2 * m) + (M : DirMatching γ) (N : DirMatching δ) + (halt : ∀ a : γ, N.tail (E a) = !M.tail a) : + ((sgnRel (stdMatching hc) M : ℤ) : ℂ) + * ((sgnRel (stdMatching hc') N : ℤ) : ℂ) + = (-1 : ℂ) ^ unionCount M (N.map E.symm.toEquiv) := by + classical + have halt' : Alternating M (N.map E.symm.toEquiv) := fun a => halt a + rw [unionCount_eq_orbitCount halt' rfl rfl] + have hs := sgnRel_mul_sgnRel_map_alternating E hc hc' M N halt' + push_cast at hs ⊢ + exact hs + +/-! ### The union read across a two-sided interface + +RS21 reads `M(ω₁,κ₁) ∪ M(ω₂,κ₂)` on one copy of the label set `S`, +the two fragments' arcs sharing their ends. The flag model keeps the +two fragments' labels apart, so the same union is read on the sum: +the two chord matchings side by side, against the matching that +identifies the two copies. The two readings count the same +components — one step of the one-copy rotation is one or three steps +of the two-copy one, and the two copies of a label always lie on a +common component. +-/ + +/-- **Two matchings, side by side.** -/ +def sumMatching {γ δ : Type} (M : DirMatching γ) (N : DirMatching δ) : + DirMatching (γ ⊕ δ) where + edge := Sum.map M.edge N.edge + edge_invol x := by + rcases x with a | b + · exact congrArg Sum.inl (M.edge_invol a) + · exact congrArg Sum.inr (N.edge_invol b) + edge_ne x := by + rcases x with a | b + · exact fun h => M.edge_ne a (Sum.inl.inj h) + · exact fun h => N.edge_ne b (Sum.inr.inj h) + tail := Sum.elim M.tail N.tail + tail_flip x := by + rcases x with a | b + · exact M.tail_flip a + · exact N.tail_flip b + +/-- **The interface matching across an identification** of the two +sides' labels. -/ +def interfaceEquivMatching {γ δ : Type} (e : γ ≃ δ) : + DirMatching (γ ⊕ δ) where + edge := Sum.elim (fun a => Sum.inr (e a)) (fun b => Sum.inl (e.symm b)) + edge_invol x := by + rcases x with a | b + · exact congrArg Sum.inl (e.symm_apply_apply a) + · exact congrArg Sum.inr (e.apply_symm_apply b) + edge_ne x := by + rcases x with a | b + · exact fun h => Sum.inr_ne_inl h + · exact fun h => Sum.inl_ne_inr h + tail := Sum.isLeft + tail_flip x := by rcases x with a | b <;> rfl + +section TwoSided + +variable {γ δ : Type} + +/-- The two-copy repair built from a one-copy one. -/ +private def sumRepair (e : γ ≃ δ) + {A₁ B₁ : DirMatching γ} + (_h : Alternating A₁ B₁) : DirMatching (γ ⊕ δ) := + sumMatching A₁ (B₁.map e) + +/-- The interface half of the two-copy repair. -/ +private def interfaceRepair (e : γ ≃ δ) + {A₁ B₁ : DirMatching γ} + (h : Alternating A₁ B₁) : DirMatching (γ ⊕ δ) where + edge := Sum.elim (fun a => Sum.inr (e a)) (fun b => Sum.inl (e.symm b)) + edge_invol x := (interfaceEquivMatching e).edge_invol x + edge_ne x := (interfaceEquivMatching e).edge_ne x + tail := Sum.elim (fun a => !A₁.tail a) (fun b => !B₁.tail (e.symm b)) + tail_flip x := by + rcases x with a | b + · change (!B₁.tail (e.symm (e a))) = !(!A₁.tail a) + rw [e.symm_apply_apply, h a, Bool.not_not] + · change (!A₁.tail (e.symm b)) = !(!B₁.tail (e.symm b)) + rw [h (e.symm b), Bool.not_not] + +private theorem alternating_sumRepair (e : γ ≃ δ) + {A₁ B₁ : DirMatching γ} + (h : Alternating A₁ B₁) : + Alternating (sumRepair (δ := δ) e h) (interfaceRepair e h) := by + rintro (a | b) + · rfl + · rfl + +/-- One step of the one-copy rotation is a walk of the two-copy +one. -/ +private theorem sameCycle_inl (e : γ ≃ δ) + {A₁ B₁ : DirMatching γ} + (h : Alternating A₁ B₁) (a : γ) : + ((sumRepair (δ := δ) e h).rotPerm (interfaceRepair e h) + (alternating_sumRepair e h)).SameCycle (Sum.inl a) + (Sum.inl (A₁.rot B₁ a)) := by + set π := (sumRepair (δ := δ) e h).rotPerm (interfaceRepair e h) + (alternating_sumRepair e h) with hπ + have hstep : ∀ x, π x = (sumRepair (δ := δ) e h).rot + (interfaceRepair e h) x := fun _ => rfl + by_cases ha : A₁.tail a = true + · refine ⟨1, ?_⟩ + rw [zpow_one, hstep, show A₁.rot B₁ a = A₁.edge a from by + rw [rot, ite_eq_left ha]] + change (if A₁.tail a = true then (Sum.inl (A₁.edge a) : γ ⊕ δ) + else Sum.inr (e a)) = Sum.inl (A₁.edge a) + rw [ite_eq_left ha] + · have ha' : A₁.tail a = false := by + cases hb : A₁.tail a + · rfl + · exact absurd hb ha + have hb : B₁.tail a = true := by rw [h a, ha']; rfl + have hb2 : B₁.tail (B₁.edge a) = false := by + rw [B₁.tail_flip a, hb]; rfl + refine ⟨3, ?_⟩ + have h1 : π (Sum.inl a) = Sum.inr (e a) := by + rw [hstep] + change (if A₁.tail a = true then (Sum.inl (A₁.edge a) : γ ⊕ δ) + else Sum.inr (e a)) = Sum.inr (e a) + rw [ite_eq_right ha] + have h2 : π (Sum.inr (e a)) = Sum.inr (e (B₁.edge a)) := by + rw [hstep] + change (if B₁.tail (e.symm (e a)) = true then + (Sum.inr (e (B₁.edge (e.symm (e a)))) : γ ⊕ δ) + else Sum.inl (e.symm (e a))) = Sum.inr (e (B₁.edge a)) + rw [e.symm_apply_apply, ite_eq_left hb] + have h3 : π (Sum.inr (e (B₁.edge a))) = Sum.inl (B₁.edge a) := by + rw [hstep] + change (if B₁.tail (e.symm (e (B₁.edge a))) = true then + (Sum.inr (e (B₁.edge (e.symm (e (B₁.edge a))))) + : γ ⊕ δ) + else Sum.inl (e.symm (e (B₁.edge a)))) + = Sum.inl (B₁.edge a) + rw [e.symm_apply_apply, ite_eq_right (by rw [hb2]; exact Bool.noConfusion)] + have : (π ^ (3 : ℕ)) (Sum.inl a) = Sum.inl (B₁.edge a) := by + change π (π (π (Sum.inl a))) = Sum.inl (B₁.edge a) + rw [h1, h2, h3] + rw [show ((3 : ℤ)) = ((3 : ℕ) : ℤ) from rfl, zpow_natCast, this, + rot, ite_eq_right ha] + +/-- The two-copy rotation projects to the one-copy one. -/ +private theorem sameCycle_proj (e : γ ≃ δ) + {A₁ B₁ : DirMatching γ} + (h : Alternating A₁ B₁) (x : γ ⊕ δ) : + (A₁.rotPerm B₁ h).SameCycle (Sum.elim id (fun b => e.symm b) x) + (Sum.elim id (fun b => e.symm b) + (((sumRepair (δ := δ) e h).rotPerm (interfaceRepair e h) + (alternating_sumRepair e h)) x)) := by + have hstep : ∀ y, ((sumRepair (δ := δ) e h).rotPerm + (interfaceRepair e h) (alternating_sumRepair e h)) y + = (sumRepair (δ := δ) e h).rot (interfaceRepair e h) y := + fun _ => rfl + rcases x with a | b + · by_cases ha : A₁.tail a = true + · refine ⟨1, ?_⟩ + rw [zpow_one, hstep] + change A₁.rot B₁ a = Sum.elim id (fun b => e.symm b) + (if A₁.tail a = true then (Sum.inl (A₁.edge a) : γ ⊕ δ) + else Sum.inr (e a)) + rw [ite_eq_left ha, rot, ite_eq_left ha] + rfl + · refine ⟨0, ?_⟩ + rw [zpow_zero, hstep] + change a = Sum.elim id (fun b => e.symm b) + (if A₁.tail a = true then (Sum.inl (A₁.edge a) : γ ⊕ δ) + else Sum.inr (e a)) + rw [ite_eq_right ha] + exact (e.symm_apply_apply a).symm + · by_cases hb : B₁.tail (e.symm b) = true + · have ha : A₁.tail (e.symm b) ≠ true := by + have := h (e.symm b) + rw [hb] at this + rw [show A₁.tail (e.symm b) = false from by + cases hc : A₁.tail (e.symm b) + · rfl + · rw [hc] at this; exact absurd this.symm (by decide)] + exact Bool.noConfusion + refine ⟨1, ?_⟩ + rw [zpow_one, hstep] + change A₁.rot B₁ (e.symm b) = Sum.elim id (fun c => e.symm c) + (if B₁.tail (e.symm b) = true then + (Sum.inr (e (B₁.edge (e.symm b))) : γ ⊕ δ) + else Sum.inl (e.symm b)) + rw [ite_eq_left hb, rot, ite_eq_right ha] + exact (e.symm_apply_apply _).symm + · refine ⟨0, ?_⟩ + rw [zpow_zero, hstep] + change e.symm b = Sum.elim id (fun c => e.symm c) + (if B₁.tail (e.symm b) = true then + (Sum.inr (e (B₁.edge (e.symm b))) : γ ⊕ δ) + else Sum.inl (e.symm b)) + rw [ite_eq_right hb] + rfl + +/-- The two copies of a label lie on a common component. -/ +private theorem sameCycle_inl_proj (e : γ ≃ δ) + {A₁ B₁ : DirMatching γ} + (h : Alternating A₁ B₁) (x : γ ⊕ δ) : + ((sumRepair (δ := δ) e h).rotPerm (interfaceRepair e h) + (alternating_sumRepair e h)).SameCycle + (Sum.inl (Sum.elim id (fun b => e.symm b) x)) x := by + have hstep : ∀ y, ((sumRepair (δ := δ) e h).rotPerm + (interfaceRepair e h) (alternating_sumRepair e h)) y + = (sumRepair (δ := δ) e h).rot (interfaceRepair e h) y := + fun _ => rfl + rcases x with a | b + · exact ⟨0, rfl⟩ + · by_cases ha : A₁.tail (e.symm b) = true + · have hkey : ((sumRepair (δ := δ) e h).rotPerm + (interfaceRepair e h) (alternating_sumRepair e h)) + (Sum.inr b) = Sum.inl (e.symm b) := by + rw [hstep] + change (if B₁.tail (e.symm b) = true then + (Sum.inr (e (B₁.edge (e.symm b))) : γ ⊕ δ) + else Sum.inl (e.symm b)) = Sum.inl (e.symm b) + rw [ite_eq_right (show ¬ (B₁.tail (e.symm b) = true) from by + rw [h (e.symm b), ha]; decide)] + refine Equiv.Perm.SameCycle.symm ?_ + exact ⟨1, by rw [zpow_one]; exact hkey⟩ + · refine ⟨1, ?_⟩ + rw [zpow_one, hstep] + change (if A₁.tail (e.symm b) = true then + (Sum.inl (A₁.edge (e.symm b)) : γ ⊕ δ) + else Sum.inr (e (e.symm b))) = Sum.inr b + rw [ite_eq_right ha, e.apply_symm_apply] + +/-- **The union on two copies counts what the union on one copy +counts.** -/ +theorem unionCount_sumMatching + [Fintype γ] [Fintype δ] (e : γ ≃ δ) + (M₁ : DirMatching γ) + (M₂ : DirMatching δ) : + unionCount (sumMatching M₁ M₂) (interfaceEquivMatching e) + = unionCount M₁ (M₂.map e.symm) := by + classical + obtain ⟨A₁, B₁, hAe, hBe, hAB⟩ := + exists_alternating_repair M₁ (M₂.map e.symm) + have hsum : (sumRepair (δ := δ) e hAB).edge + = (sumMatching M₁ M₂).edge := by + funext x + rcases x with a | b + · exact congrArg Sum.inl (congrFun hAe a) + · refine congrArg Sum.inr ?_ + change e (B₁.edge (e.symm b)) = M₂.edge b + rw [congrFun hBe (e.symm b)] + change e (e.symm (M₂.edge (e (e.symm b)))) = M₂.edge b + rw [e.apply_symm_apply, e.apply_symm_apply] + rw [unionCount_eq_orbitCount (M := sumMatching M₁ M₂) + (N := interfaceEquivMatching e) + (alternating_sumRepair e hAB) hsum rfl, + unionCount_eq_orbitCount (M := M₁) (N := M₂.map e.symm) hAB hAe + hBe] + refine (orbitCount_eq_of_orbitsEquiv (π := (sumRepair (δ := δ) e hAB).rotPerm + (interfaceRepair e hAB) (alternating_sumRepair e hAB)) + (ρ := A₁.rotPerm B₁ hAB) ?_) + refine + { toFun := Quotient.lift + (fun x => Quotient.mk _ (Sum.elim id (fun b => e.symm b) x)) + (fun _ _ hab => Quotient.sound + (sameCycle_of_step (Sum.elim id (fun b => e.symm b)) + (sameCycle_proj e hAB) hab)) + invFun := Quotient.lift (fun a => Quotient.mk _ (Sum.inl a)) + (fun _ _ hab => Quotient.sound + (sameCycle_of_step Sum.inl (sameCycle_inl e hAB) hab)) + left_inv := ?_ + right_inv := ?_ } + · exact Quotient.ind (fun x => Quotient.sound + (sameCycle_inl_proj e hAB x)) + · exact Quotient.ind (fun _ => rfl) + +end TwoSided + +end DirMatching + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjSubsetSplit.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjSubsetSplit.lean new file mode 100644 index 0000000000..f8d6c3873a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjSubsetSplit.lean @@ -0,0 +1,263 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue + +/-! +# Subset splitting over disjoint unions + +Edge subsets of a disjoint union split componentwise: the +left/right parts, their join, the round trips, and the transport +of pairing-closure, Eulerian-ness, and boundary-state matching — +the first layer of the multiplicativity of the corrected +constrained value over `disjUnion`. +-/ + +@[expose] public section + +namespace RS + +variable {α β : Type} {W₁ : Fragment α} {W₂ : Fragment β} + + + +/-! ## The parts and the join -/ + +/-- The left part of a subset of the disjoint union. -/ +noncomputable def leftPart + (s : Finset ((W₁.disjUnion W₂).Flag)) : Finset W₁.Flag := + Finset.toLeft (α := W₁.Flag) (β := W₂.Flag) s + +/-- The right part of a subset of the disjoint union. -/ +noncomputable def rightPart + (s : Finset ((W₁.disjUnion W₂).Flag)) : Finset W₂.Flag := + Finset.toRight (α := W₁.Flag) (β := W₂.Flag) s + +/-- The join of componentwise subsets. -/ +noncomputable def joinParts (s₁ : Finset W₁.Flag) + (s₂ : Finset W₂.Flag) : Finset ((W₁.disjUnion W₂).Flag) := + Finset.disjSum s₁ s₂ + +/-- Membership in the left part of a flag set. -/ +@[simp] theorem mem_leftPart {s : Finset ((W₁.disjUnion W₂).Flag)} + {f : W₁.Flag} : f ∈ leftPart s ↔ Sum.inl f ∈ s := + Finset.mem_toLeft + +/-- Membership in the right part. -/ +@[simp] theorem mem_rightPart {s : Finset ((W₁.disjUnion W₂).Flag)} + {f : W₂.Flag} : f ∈ rightPart s ↔ Sum.inr f ∈ s := + Finset.mem_toRight + +/-- A left flag is in a join exactly when it is in the left +summand. -/ +@[simp] theorem inl_mem_joinParts {s₁ : Finset W₁.Flag} + {s₂ : Finset W₂.Flag} {f : W₁.Flag} : + (Sum.inl f : (W₁.disjUnion W₂).Flag) ∈ joinParts s₁ s₂ ↔ + f ∈ s₁ := + Finset.inl_mem_disjSum + +/-- The right analogue. -/ +@[simp] theorem inr_mem_joinParts {s₁ : Finset W₁.Flag} + {s₂ : Finset W₂.Flag} {f : W₂.Flag} : + (Sum.inr f : (W₁.disjUnion W₂).Flag) ∈ joinParts s₁ s₂ ↔ + f ∈ s₂ := + Finset.inr_mem_disjSum + +/-- The left part of a join is what was joined on the left. -/ +theorem leftPart_joinParts (s₁ : Finset W₁.Flag) + (s₂ : Finset W₂.Flag) : + leftPart (W₁ := W₁) (W₂ := W₂) (joinParts s₁ s₂) = s₁ := + Finset.toLeft_disjSum + +/-- And likewise on the right. -/ +theorem rightPart_joinParts (s₁ : Finset W₁.Flag) + (s₂ : Finset W₂.Flag) : + rightPart (W₁ := W₁) (W₂ := W₂) (joinParts s₁ s₂) = s₂ := + Finset.toRight_disjSum + +/-- Joining a set's two parts recovers it: the split is a +bijection. -/ +theorem joinParts_parts (s : Finset ((W₁.disjUnion W₂).Flag)) : + joinParts (leftPart s) (rightPart s) = s := + Finset.toLeft_disjSum_toRight + +/-! ## Closure transport -/ + +/-- Edge-closure is componentwise, no edge crossing between the +components. -/ +theorem pairing_closed_iff_parts + (s : Finset ((W₁.disjUnion W₂).Flag)) : + (∀ f ∈ s, (W₁.disjUnion W₂).pairing f ∈ s) ↔ + ((∀ f ∈ leftPart s, W₁.pairing f ∈ leftPart s) ∧ + (∀ f ∈ rightPart s, W₂.pairing f ∈ rightPart s)) := by + constructor + · intro hc + constructor + · intro f hf + exact mem_leftPart.mpr (hc _ (mem_leftPart.mp hf)) + · intro f hf + exact mem_rightPart.mpr (hc _ (mem_rightPart.mp hf)) + · rintro ⟨h₁, h₂⟩ f hf + cases f with + | inl g => + have := h₁ g (mem_leftPart.mpr hf) + exact mem_leftPart.mp this + | inr g => + have := h₂ g (mem_rightPart.mpr hf) + exact mem_rightPart.mp this + +/-! ## Attachment over the union -/ + +/-- A left flag sits at a left vertex exactly as in the left +fragment. -/ +private theorem attach_inl_eq_inl {f : W₁.Flag} {v : W₁.Vertex} : + (W₁.disjUnion W₂).attach (Sum.inl f) = Sum.inl (Sum.inl v) ↔ + W₁.attach f = Sum.inl v := by + change (W₁.attach f).map Sum.inl Sum.inl = Sum.inl (Sum.inl v) ↔ + W₁.attach f = Sum.inl v + constructor + · intro h + rcases hA : W₁.attach f with w | ℓ <;> rw [hA] at h + · simp only [Sum.map_inl, Sum.inl.injEq] at h + rw [h] + · simp only [Sum.map_inr] at h + exact absurd h (by simp) + · intro h + simp [h] + +/-- A right flag sits at a right vertex exactly as in the right +fragment. -/ +private theorem attach_inr_eq_inr {f : W₂.Flag} {v : W₂.Vertex} : + (W₁.disjUnion W₂).attach (Sum.inr f) = Sum.inl (Sum.inr v) ↔ + W₂.attach f = Sum.inl v := by + change (W₂.attach f).map Sum.inr Sum.inr = Sum.inl (Sum.inr v) ↔ + W₂.attach f = Sum.inl v + constructor + · intro h + rcases hA : W₂.attach f with w | ℓ <;> rw [hA] at h + · simp only [Sum.map_inl, Sum.inl.injEq, Sum.inr.injEq] at h + rw [h] + · simp only [Sum.map_inr] at h + exact absurd h (by simp) + · intro h + simp [h] + +/-- A right flag never sits at a left vertex. -/ +private theorem attach_inr_ne_inl {f : W₂.Flag} {v : W₁.Vertex} : + (W₁.disjUnion W₂).attach (Sum.inr f) ≠ Sum.inl (Sum.inl v) := by + change (W₂.attach f).map Sum.inr Sum.inr ≠ Sum.inl (Sum.inl v) + rcases W₂.attach f with w | ℓ <;> simp + +/-- A left flag never sits at a right vertex. -/ +private theorem attach_inl_ne_inr {f : W₁.Flag} {v : W₂.Vertex} : + (W₁.disjUnion W₂).attach (Sum.inl f) ≠ Sum.inl (Sum.inr v) := by + change (W₁.attach f).map Sum.inl Sum.inl ≠ Sum.inl (Sum.inr v) + rcases W₁.attach f with w | ℓ <;> simp + +/-! ## Filtering a disjoint sum -/ + +private theorem filter_disjSum_eq {γ δ : Type} (L : Finset γ) + (R : Finset δ) (P : γ ⊕ δ → Prop) [DecidablePred P] : + (L.disjSum R).filter P = + (L.filter fun x => P (Sum.inl x)).disjSum + (R.filter fun y => P (Sum.inr y)) := by + ext x + cases x <;> simp + +/-- The card of a filter over a disjoint sum whose predicate holds +only on the left, with explicit decidability arguments so that the +instances are picked up by unification. -/ +private theorem card_filter_disjSum_inl {γ δ : Type} (L : Finset γ) + (R : Finset δ) (P : γ ⊕ δ → Prop) (instP : DecidablePred P) + (Q : γ → Prop) (instQ : DecidablePred Q) + (hQ : ∀ x, P (Sum.inl x) ↔ Q x) (hR : ∀ y, ¬ P (Sum.inr y)) : + (@Finset.filter _ P instP (L.disjSum R)).card = + (@Finset.filter _ Q instQ L).card := by + rw [Finset.filter_congr_decidable (L.disjSum R) P instP, + Finset.filter_congr_decidable L Q instQ, + filter_disjSum_eq L R P, Finset.filter_congr (fun x _ => hQ x), + Finset.filter_false_of_mem (fun y _ => hR y), Finset.card_disjSum, + Finset.card_empty, Nat.add_zero] + +/-- The card of a filter over a disjoint sum whose predicate holds +only on the right. -/ +private theorem card_filter_disjSum_inr {γ δ : Type} (L : Finset γ) + (R : Finset δ) (P : γ ⊕ δ → Prop) (instP : DecidablePred P) + (Q : δ → Prop) (instQ : DecidablePred Q) + (hL : ∀ x, ¬ P (Sum.inl x)) (hQ : ∀ y, P (Sum.inr y) ↔ Q y) : + (@Finset.filter _ P instP (L.disjSum R)).card = + (@Finset.filter _ Q instQ R).card := by + rw [Finset.filter_congr_decidable (L.disjSum R) P instP, + Finset.filter_congr_decidable R Q instQ, + filter_disjSum_eq L R P, Finset.filter_congr (fun y _ => hQ y), + Finset.filter_false_of_mem (fun x _ => hL x), Finset.card_disjSum, + Finset.card_empty, Nat.zero_add] + +/-! ## Degree transport -/ + +/-- The degree at a left vertex is computed in the left part. -/ +theorem deg_disjUnion_inl + (s : Finset ((W₁.disjUnion W₂).Flag)) + (hc : ∀ f ∈ s, (W₁.disjUnion W₂).pairing f ∈ s) + (h₁ : ∀ f ∈ leftPart s, W₁.pairing f ∈ leftPart s) + (v : W₁.Vertex) : + (EdgeSubset.mk s hc).deg (Sum.inl v) = + (EdgeSubset.mk (leftPart s) h₁).deg v := by + unfold EdgeSubset.deg + rw [show (EdgeSubset.mk s hc).flags = + joinParts (leftPart s) (rightPart s) from (joinParts_parts s).symm] + unfold joinParts + exact card_filter_disjSum_inl (leftPart s) (rightPart s) _ _ _ _ + (fun x => attach_inl_eq_inl) (fun y => attach_inr_ne_inl) + +/-- The degree at a right vertex is computed in the right part. -/ +theorem deg_disjUnion_inr + (s : Finset ((W₁.disjUnion W₂).Flag)) + (hc : ∀ f ∈ s, (W₁.disjUnion W₂).pairing f ∈ s) + (h₂ : ∀ f ∈ rightPart s, W₂.pairing f ∈ rightPart s) + (v : W₂.Vertex) : + (EdgeSubset.mk s hc).deg (Sum.inr v) = + (EdgeSubset.mk (rightPart s) h₂).deg v := by + unfold EdgeSubset.deg + rw [show (EdgeSubset.mk s hc).flags = + joinParts (leftPart s) (rightPart s) from (joinParts_parts s).symm] + unfold joinParts + exact card_filter_disjSum_inr (leftPart s) (rightPart s) _ _ _ _ + (fun x => attach_inl_ne_inr) (fun y => attach_inr_eq_inr) + +/-! ## Eulerian transport -/ + +/-- Being Eulerian is componentwise. -/ +theorem eulerian_iff_parts + (s : Finset ((W₁.disjUnion W₂).Flag)) + (hc : ∀ f ∈ s, (W₁.disjUnion W₂).pairing f ∈ s) + (h₁ : ∀ f ∈ leftPart s, W₁.pairing f ∈ leftPart s) + (h₂ : ∀ f ∈ rightPart s, W₂.pairing f ∈ rightPart s) : + (EdgeSubset.mk s hc).Eulerian ↔ + ((EdgeSubset.mk (leftPart s) h₁).Eulerian ∧ + (EdgeSubset.mk (rightPart s) h₂).Eulerian) := by + unfold EdgeSubset.Eulerian + constructor + · intro hE + constructor + · intro v + have h := hE (Sum.inl v) + rwa [deg_disjUnion_inl s hc h₁ v] at h + · intro v + have h := hE (Sum.inr v) + rwa [deg_disjUnion_inr s hc h₂ v] at h + · rintro ⟨hE₁, hE₂⟩ v + cases v with + | inl v => + have h := hE₁ v + rwa [← deg_disjUnion_inl s hc h₁ v] at h + | inr v => + have h := hE₂ v + rwa [← deg_disjUnion_inr s hc h₂ v] at h + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor.lean new file mode 100644 index 0000000000..5ad5486911 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.C + +/-! +# Factorization over a disjoint union + +Subsets, parity, product systems, colour splitting and canonical +migration for a union of two fragments, in the three parts below. +-/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/A.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/A.lean new file mode 100644 index 0000000000..5a5a966662 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/A.lean @@ -0,0 +1,787 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SumLexOrder +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InvolutionCard +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjSubsetSplit +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonExistence + +/-! +# The disjoint-union factorization of the corrected value + +The corrected constrained partition value of a disjoint union at a +boundary state factors as the product of the componentwise values +at the restricted states, with the lexicographic label order on +the union. This part supplies the subset and transition-system +half; `B.lean` splits the colourings and the summand, and `C.lean` +migrates canonical data. + +The route reindexes the Eulerian subset sum along the +componentwise splitting of `DisjSubsetSplit`, restricts and +multiplies boundary-relative transition systems componentwise, +adds circuit counts (each component's orbit data is even: the +edge-pairing reversal is a fixed-point-free involution on walk +orbits), and splits the through product and the colouring sums. +-/ + +@[expose] public section + +namespace RS + + + +/-! ## Membership characterizations (any fragment) -/ + +open scoped Classical in +private theorem mem_throughFlags_iff {γ : Type} {W : Fragment γ} + {F : EdgeSubset W} {f : W.Flag} : + f ∈ F.throughFlags ↔ f ∈ F.flags ∧ + ((∃ i : γ, W.attach f = Sum.inr i) ∧ + ∃ j : γ, W.attach (W.pairing f) = Sum.inr j) := + Finset.mem_filter + +section SumToolbox + +variable {α β : Type} {W₁ : Fragment α} {W₂ : Fragment β} + +/-! ## Attachment over the union (mirrors `DisjSubsetSplit`) -/ + +/-- A left flag attaches to a left vertex over the union exactly +when it attaches to that vertex in its own component. -/ +theorem attach_inl_eq_inl {f : W₁.Flag} {v : W₁.Vertex} : + (W₁.disjUnion W₂).attach (Sum.inl f) = Sum.inl (Sum.inl v) ↔ + W₁.attach f = Sum.inl v := by + change (W₁.attach f).map Sum.inl Sum.inl = Sum.inl (Sum.inl v) ↔ + W₁.attach f = Sum.inl v + constructor + · intro h + rcases hA : W₁.attach f with w | ℓ <;> rw [hA] at h + · simp only [Sum.map_inl, Sum.inl.injEq] at h + rw [h] + · simp only [Sum.map_inr] at h + exact absurd h (by simp) + · intro h + simp [h] + +/-- The right analogue. -/ +theorem attach_inr_eq_inr {f : W₂.Flag} {v : W₂.Vertex} : + (W₁.disjUnion W₂).attach (Sum.inr f) = Sum.inl (Sum.inr v) ↔ + W₂.attach f = Sum.inl v := by + change (W₂.attach f).map Sum.inr Sum.inr = Sum.inl (Sum.inr v) ↔ + W₂.attach f = Sum.inl v + constructor + · intro h + rcases hA : W₂.attach f with w | ℓ <;> rw [hA] at h + · simp only [Sum.map_inl, Sum.inl.injEq, Sum.inr.injEq] at h + rw [h] + · simp only [Sum.map_inr] at h + exact absurd h (by simp) + · intro h + simp [h] + +/-- A right flag never attaches to a left vertex. -/ +theorem attach_inr_ne_inl {f : W₂.Flag} {v : W₁.Vertex} : + (W₁.disjUnion W₂).attach (Sum.inr f) ≠ Sum.inl (Sum.inl v) := by + change (W₂.attach f).map Sum.inr Sum.inr ≠ Sum.inl (Sum.inl v) + rcases W₂.attach f with w | ℓ <;> simp + +/-- A left flag never attaches to a right vertex. -/ +theorem attach_inl_ne_inr {f : W₁.Flag} {v : W₂.Vertex} : + (W₁.disjUnion W₂).attach (Sum.inl f) ≠ Sum.inl (Sum.inr v) := by + change (W₁.attach f).map Sum.inl Sum.inl ≠ Sum.inl (Sum.inr v) + rcases W₁.attach f with w | ℓ <;> simp + +/-- A left flag is internally attached in the union exactly when it +is internally attached in the left component. -/ +theorem attach_inl_vertex_iff {g : W₁.Flag} : + (∃ v : (W₁.disjUnion W₂).Vertex, + (W₁.disjUnion W₂).attach (Sum.inl g) = Sum.inl v) ↔ + ∃ w : W₁.Vertex, W₁.attach g = Sum.inl w := by + constructor + · rintro ⟨v, hv⟩ + cases v with + | inl w => exact ⟨w, attach_inl_eq_inl.mp hv⟩ + | inr w => exact absurd hv attach_inl_ne_inr + · rintro ⟨w, hw⟩ + exact ⟨Sum.inl w, attach_inl_eq_inl.mpr hw⟩ + +/-- A right flag is internally attached in the union exactly when it +is internally attached in the right component. -/ +theorem attach_inr_vertex_iff {g : W₂.Flag} : + (∃ v : (W₁.disjUnion W₂).Vertex, + (W₁.disjUnion W₂).attach (Sum.inr g) = Sum.inl v) ↔ + ∃ w : W₂.Vertex, W₂.attach g = Sum.inl w := by + constructor + · rintro ⟨v, hv⟩ + cases v with + | inl w => exact absurd hv attach_inr_ne_inl + | inr w => exact ⟨w, attach_inr_eq_inr.mp hv⟩ + · rintro ⟨w, hw⟩ + exact ⟨Sum.inr w, attach_inr_eq_inr.mpr hw⟩ + +/-- A left flag is boundary over the union exactly when it is +boundary in its own component. -/ +theorem attach_inl_label_iff {g : W₁.Flag} : + (∃ i : α ⊕ β, + (W₁.disjUnion W₂).attach (Sum.inl g) = Sum.inr i) ↔ + ∃ i₀ : α, W₁.attach g = Sum.inr i₀ := by + change (∃ i, (W₁.attach g).map Sum.inl Sum.inl = Sum.inr i) ↔ _ + constructor + · rintro ⟨i, hi⟩ + rcases hA : W₁.attach g with w | i₀ <;> rw [hA] at hi + · simp at hi + · exact ⟨i₀, rfl⟩ + · rintro ⟨i₀, hi⟩ + exact ⟨Sum.inl i₀, by rw [hi]; rfl⟩ + +/-- The right analogue. -/ +theorem attach_inr_label_iff {g : W₂.Flag} : + (∃ i : α ⊕ β, + (W₁.disjUnion W₂).attach (Sum.inr g) = Sum.inr i) ↔ + ∃ i₀ : β, W₂.attach g = Sum.inr i₀ := by + change (∃ i, (W₂.attach g).map Sum.inr Sum.inr = Sum.inr i) ↔ _ + constructor + · rintro ⟨i, hi⟩ + rcases hA : W₂.attach g with w | i₀ <;> rw [hA] at hi + · simp at hi + · exact ⟨i₀, rfl⟩ + · rintro ⟨i₀, hi⟩ + exact ⟨Sum.inr i₀, by rw [hi]; rfl⟩ + +/-- The union's edge pairing on a left flag is the left component's, +injected. -/ +theorem pairing_inl (g : W₁.Flag) : + (W₁.disjUnion W₂).pairing (Sum.inl g) = + Sum.inl (W₁.pairing g) := rfl + +/-- The right analogue. -/ +theorem pairing_inr (g : W₂.Flag) : + (W₁.disjUnion W₂).pairing (Sum.inr g) = + Sum.inr (W₂.pairing g) := rfl + +/-! ## The component edge subsets -/ + +/-- The left component of an edge subset of a disjoint union. -/ +noncomputable def leftSub (F : EdgeSubset (W₁.disjUnion W₂)) : EdgeSubset W₁ := + ⟨leftPart F.flags, fun f hf => mem_leftPart.mpr (by + have h := F.pairing_mem _ (mem_leftPart.mp hf) + rwa [pairing_inl] at h)⟩ + +/-- The right component of an edge subset of a disjoint union. -/ +noncomputable def rightSub (F : EdgeSubset (W₁.disjUnion W₂)) : EdgeSubset W₂ := + ⟨rightPart F.flags, fun f hf => mem_rightPart.mpr (by + have h := F.pairing_mem _ (mem_rightPart.mp hf) + rwa [pairing_inr] at h)⟩ + +/-- Membership in the left component subset. -/ +theorem mem_leftSub_flags {F : EdgeSubset (W₁.disjUnion W₂)} + {g : W₁.Flag} : g ∈ (leftSub F).flags ↔ Sum.inl g ∈ F.flags := + mem_leftPart + +/-- Membership in the right component subset. -/ +theorem mem_rightSub_flags {F : EdgeSubset (W₁.disjUnion W₂)} + {g : W₂.Flag} : g ∈ (rightSub F).flags ↔ Sum.inr g ∈ F.flags := + mem_rightPart + +/-- Internality is componentwise on the left. -/ +theorem inl_mem_internal {F : EdgeSubset (W₁.disjUnion W₂)} + {g : W₁.Flag} : + (Sum.inl g : (W₁.disjUnion W₂).Flag) ∈ F.internalFlags ↔ + g ∈ (leftSub F).internalFlags := by + constructor + · intro h + obtain ⟨hf, hv⟩ := EdgeSubset.mem_internalFlags_iff.mp h + exact EdgeSubset.mem_internalFlags_iff.mpr + ⟨mem_leftSub_flags.mpr hf, attach_inl_vertex_iff.mp hv⟩ + · intro h + obtain ⟨hf, hv⟩ := EdgeSubset.mem_internalFlags_iff.mp h + exact EdgeSubset.mem_internalFlags_iff.mpr + ⟨mem_leftSub_flags.mp hf, attach_inl_vertex_iff.mpr hv⟩ + +/-- Internality is componentwise on the right. -/ +theorem inr_mem_internal {F : EdgeSubset (W₁.disjUnion W₂)} + {g : W₂.Flag} : + (Sum.inr g : (W₁.disjUnion W₂).Flag) ∈ F.internalFlags ↔ + g ∈ (rightSub F).internalFlags := by + constructor + · intro h + obtain ⟨hf, hv⟩ := EdgeSubset.mem_internalFlags_iff.mp h + exact EdgeSubset.mem_internalFlags_iff.mpr + ⟨mem_rightSub_flags.mpr hf, attach_inr_vertex_iff.mp hv⟩ + · intro h + obtain ⟨hf, hv⟩ := EdgeSubset.mem_internalFlags_iff.mp h + exact EdgeSubset.mem_internalFlags_iff.mpr + ⟨mem_rightSub_flags.mp hf, attach_inr_vertex_iff.mpr hv⟩ + +/-- Being a core flag is componentwise on the left. -/ +theorem inl_mem_core {F : EdgeSubset (W₁.disjUnion W₂)} + {g : W₁.Flag} : + (Sum.inl g : (W₁.disjUnion W₂).Flag) ∈ F.coreFlags ↔ + g ∈ (leftSub F).coreFlags := by + constructor + · intro hh + obtain ⟨hf, hor⟩ := F.mem_coreFlags_iff.mp hh + refine (leftSub F).mem_coreFlags_iff.mpr + ⟨mem_leftSub_flags.mpr hf, ?_⟩ + rcases hor with h | h + · exact Or.inl (attach_inl_vertex_iff.mp h) + · rw [pairing_inl] at h + exact Or.inr (attach_inl_vertex_iff.mp h) + · intro hh + obtain ⟨hf, hor⟩ := (leftSub F).mem_coreFlags_iff.mp hh + refine F.mem_coreFlags_iff.mpr ⟨mem_leftSub_flags.mp hf, ?_⟩ + rcases hor with h | h + · exact Or.inl (attach_inl_vertex_iff.mpr h) + · refine Or.inr ?_ + rw [pairing_inl] + exact attach_inl_vertex_iff.mpr h + +/-- Being a core flag is componentwise on the right. -/ +theorem inr_mem_core {F : EdgeSubset (W₁.disjUnion W₂)} + {g : W₂.Flag} : + (Sum.inr g : (W₁.disjUnion W₂).Flag) ∈ F.coreFlags ↔ + g ∈ (rightSub F).coreFlags := by + constructor + · intro hh + obtain ⟨hf, hor⟩ := F.mem_coreFlags_iff.mp hh + refine (rightSub F).mem_coreFlags_iff.mpr + ⟨mem_rightSub_flags.mpr hf, ?_⟩ + rcases hor with h | h + · exact Or.inl (attach_inr_vertex_iff.mp h) + · rw [pairing_inr] at h + exact Or.inr (attach_inr_vertex_iff.mp h) + · intro hh + obtain ⟨hf, hor⟩ := (rightSub F).mem_coreFlags_iff.mp hh + refine F.mem_coreFlags_iff.mpr ⟨mem_rightSub_flags.mp hf, ?_⟩ + rcases hor with h | h + · exact Or.inl (attach_inr_vertex_iff.mpr h) + · refine Or.inr ?_ + rw [pairing_inr] + exact attach_inr_vertex_iff.mpr h + +end SumToolbox + +/-! ## Parity of the open orbit data + +The edge pairing reverses walk orbits: it is a fixed-point-free +involution of the periodic flags conjugating the walk permutation +to its inverse. Consequently both the nontrivial cycles and the +fixed points of the walk permutation pair up, and the orbit total +entering `openCircuitCount` is even. -/ + +section Parity + +open EdgeSubset + +variable {γ : Type} {W : Fragment γ} {F : EdgeSubset W} + +/-- The periodic walk permutation has an even number of fixed points: +the edge-pairing reversal is a fixed-point-free involution on them. -/ +private theorem even_card_fixedPoints (κ : F.RelTransitionSystem) : + Even (Fintype.card + (Function.fixedPoints κ.walkPermPeriodic)) := by + have hfix : ∀ x : Function.fixedPoints κ.walkPermPeriodic, + revPerm κ x.val ∈ Function.fixedPoints κ.walkPermPeriodic := by + intro x + have hx : κ.walkPermPeriodic x.val = x.val := x.prop + change κ.walkPermPeriodic (revPerm κ x.val) = revPerm κ x.val + conv_lhs => rw [← hx] + have h := congrArg (fun q => q x.val) + (walkPerm_revPerm_walkPerm κ) + exact h + refine even_fintypeCard_of_involution + (fun x => ⟨revPerm κ x.val, hfix x⟩) ?_ ?_ + · intro x + refine Subtype.ext (Subtype.ext ?_) + change W.pairing (W.pairing x.val.val) = x.val.val + exact W.pairing_invol x.val.val + · intro x heq + exact W.pairing_ne x.val.val + (congrArg (fun z => z.val.val) heq) + +/-- The periodic walk permutation has an even number of cycles: the +reversal conjugates it to its inverse, pairing its cycle factors off +without fixing one. -/ +private theorem even_card_cycleType (κ : F.RelTransitionSystem) : + Even (Multiset.card κ.walkPermPeriodic.cycleType) := by + classical + -- ═══════ SETUP: THE REVERSAL CONJUGATES THE WALK TO ITS INVERSE ═══════ + set P := κ.walkPermPeriodic with hPdef + set R := revPerm κ with hRdef + have hPRP : P * R * P = R := walkPerm_revPerm_walkPerm κ + have hRR : R * R = 1 := revPerm_mul_self κ + have hRinv : R⁻¹ = R := revPerm_inv κ + have hPR : P * R = R * P⁻¹ := by + have h := congrArg (fun q => q * P⁻¹) hPRP + simpa [mul_assoc] using h + have hRPR : R * P * R = P⁻¹ := by + rw [mul_assoc, hPR, ← mul_assoc, hRR, one_mul] + have hRPiR : R * P⁻¹ * R = P := by + have h := congrArg (fun q => q⁻¹) hRPR + simp only [mul_inv_rev, hRinv, inv_inv] at h + rw [mul_assoc] + exact h + -- ═══════ STAGE 1: `c ↦ R c⁻¹ R` ACTS ON THE CYCLE FACTORS ═══════ + have hRRapp : ∀ x, R (R x) = x := fun x => + congrArg (fun q => q x) hRR + have hmemmap : ∀ c ∈ P.cycleFactorsFinset, + R * c⁻¹ * R ∈ P.cycleFactorsFinset := by + intro c hc + obtain ⟨hcyc, hsupp⟩ := + Equiv.Perm.mem_cycleFactorsFinset_iff.mp hc + refine Equiv.Perm.mem_cycleFactorsFinset_iff.mpr ⟨?_, ?_⟩ + · have h := (hcyc.inv).conj (g := R) + rwa [hRinv] at h + · intro a ha + have hb_ne : c⁻¹ (R a) ≠ R a := by + intro h + apply Equiv.Perm.mem_support.mp ha + calc (R * c⁻¹ * R) a = R (c⁻¹ (R a)) := rfl + _ = R (R a) := by rw [h] + _ = a := hRRapp a + have hcinv_supp : c⁻¹ (R a) ∈ c.support := by + rw [← Equiv.Perm.support_inv] + exact Equiv.Perm.apply_mem_support.mpr + (Equiv.Perm.mem_support.mpr hb_ne) + have h1 := hsupp _ hcinv_supp + have h2 : P (c⁻¹ (R a)) = R a := by + rw [← h1] + exact Equiv.apply_symm_apply c (R a) + have h3 : c⁻¹ (R a) = P⁻¹ (R a) := by + have h := congrArg (fun z => P⁻¹ z) h2 + simpa [Equiv.Perm.inv_def] using h + calc (R * c⁻¹ * R) a = R (c⁻¹ (R a)) := rfl + _ = R (P⁻¹ (R a)) := by rw [h3] + _ = P a := congrArg (fun q => q a) hRPiR + have hinv_i : ∀ c : Equiv.Perm {f : W.Flag // f ∈ κ.periodicFlags}, + R * (R * c⁻¹ * R)⁻¹ * R = c := by + intro c + simp only [mul_inv_rev, hRinv, inv_inv] + calc R * (R * c * R) * R + = (R * R) * c * (R * R) := by + simp only [mul_assoc] + _ = c := by rw [hRR, one_mul, mul_one] + -- ═══════ STAGE 2: THAT INVOLUTION HAS NO FIXED CYCLE ═══════ + have hne_i : ∀ c ∈ P.cycleFactorsFinset, R * c⁻¹ * R ≠ c := by + intro c hc heq + obtain ⟨hcyc, hsupp⟩ := + Equiv.Perm.mem_cycleFactorsFinset_iff.mp hc + have hconj : R * c * R = c⁻¹ := by + have h := congrArg (fun q => q⁻¹) heq + simp only [mul_inv_rev, hRinv, inv_inv] at h + rw [← h, mul_assoc] + -- conjugation sends powers of `c` to inverse powers + have hpow : ∀ (t : ℕ) (x), R ((c ^ t) (R x)) = (c ^ t)⁻¹ x := by + intro t x + have h : R * c ^ t * R = (c ^ t)⁻¹ := by + have h0 : R * c * R⁻¹ = c⁻¹ := by rw [hRinv]; exact hconj + have h1 := congrArg (fun q => q ^ t) h0 + simp only [conj_pow] at h1 + rw [hRinv] at h1 + rw [h1, inv_pow] + exact congrArg (fun q => q x) h + have hcyc' := hcyc + obtain ⟨y₀, hy₀, -⟩ := hcyc + have hRy₀ : c (R y₀) ≠ R y₀ := by + intro h + have happ := congrArg (fun q => q (R y₀)) heq + have happ' : R (c⁻¹ y₀) = c (R y₀) := by + calc R (c⁻¹ y₀) = R (c⁻¹ (R (R y₀))) := by rw [hRRapp] + _ = (R * c⁻¹ * R) (R y₀) := rfl + _ = c (R y₀) := happ + rw [h] at happ' + have hfix : c⁻¹ y₀ = y₀ := by + have := congrArg (fun z => R z) happ' + rwa [hRRapp, hRRapp] at this + have h5 : y₀ = c y₀ := by + have h6 := congrArg (fun z => c z) hfix + simpa using h6 + exact hy₀ h5.symm + obtain ⟨m, hm⟩ := hcyc'.exists_pow_eq hy₀ hRy₀ + rcases Nat.even_or_odd m with ⟨t, ht⟩ | ⟨t, ht⟩ + · -- even period offset: a pairing-fixed flag + have hu : R ((c ^ t) y₀) = (c ^ t) y₀ := by + calc R ((c ^ t) y₀) = R ((c ^ t) (R (R y₀))) := by + rw [hRRapp] + _ = (c ^ t)⁻¹ (R y₀) := hpow t (R y₀) + _ = (c ^ t)⁻¹ ((c ^ m) y₀) := by rw [hm] + _ = (c ^ t)⁻¹ ((c ^ t) ((c ^ t) y₀)) := by + rw [show m = t + t from ht, pow_add, + Equiv.Perm.mul_apply] + _ = (c ^ t) y₀ := Equiv.symm_apply_apply (c ^ t) _ + exact W.pairing_ne ((c ^ t) y₀).val + (congrArg Subtype.val hu) + · -- odd period offset: a matching-fixed flag + have hu : R ((c ^ t) y₀) = (c ^ (t + 1)) y₀ := by + calc R ((c ^ t) y₀) = R ((c ^ t) (R (R y₀))) := by + rw [hRRapp] + _ = (c ^ t)⁻¹ (R y₀) := hpow t (R y₀) + _ = (c ^ t)⁻¹ ((c ^ m) y₀) := by rw [hm] + _ = (c ^ t)⁻¹ ((c ^ t) ((c ^ (t + 1)) y₀)) := by + rw [show m = t + (t + 1) from by omega, pow_add, + Equiv.Perm.mul_apply] + _ = (c ^ (t + 1)) y₀ := Equiv.symm_apply_apply (c ^ t) _ + have husupp : (c ^ t) y₀ ∈ c.support := + Equiv.Perm.pow_apply_mem_support.mpr + (Equiv.Perm.mem_support.mpr hy₀) + have hcu : c ((c ^ t) y₀) = P ((c ^ t) y₀) := hsupp _ husupp + have hRu : R ((c ^ t) y₀) = P ((c ^ t) y₀) := by + rw [hu, ← hcu, pow_succ', Equiv.Perm.mul_apply] + -- vals: the matching fixes the pairing of a periodic flag + have hval := congrArg Subtype.val hRu + have hmatch : κ.match_ (W.pairing ((c ^ t) y₀).val) = + W.pairing ((c ^ t) y₀).val := by + exact hval.symm + have hint : W.pairing ((c ^ t) y₀).val ∈ F.internalFlags := + all_pairings_internal_of_periodic κ + (κ.mem_periodicFlags.mp ((c ^ t) y₀).prop) 0 + exact κ.match_ne _ hint hmatch + -- ═══════ ASSEMBLY: SO THE CYCLES PAIR OFF ═══════ + have heven := even_card_of_involution P.cycleFactorsFinset + (fun c => R * c⁻¹ * R) hmemmap (fun c _ => hinv_i c) hne_i + rw [Equiv.Perm.cycleType_def, Multiset.card_map] + exact heven + +end Parity + +/-! ## Componentwise relative transition systems -/ + +section ProdSystems + +open EdgeSubset + +variable {α β : Type} {W₁ : Fragment α} {W₂ : Fragment β} + {F : EdgeSubset (W₁.disjUnion W₂)} + +/-! ### Restriction to the components -/ + +/-- Restrict a union matching to a left flag, fixing it if the image lies on the right. -/ +noncomputable def leftDescend (κ : F.RelTransitionSystem) + (g : W₁.Flag) : W₁.Flag := + Sum.elim id (fun _ => g) (κ.match_ (Sum.inl g)) + +/-- Restrict a union matching to a right flag, fixing it if the image lies on the left. -/ +noncomputable def rightDescend (κ : F.RelTransitionSystem) + (g : W₂.Flag) : W₂.Flag := + Sum.elim (fun _ => g) id (κ.match_ (Sum.inr g)) + +/-- On an internal left flag, the union system's match is the left +descent, injected. -/ +theorem leftDescend_spec (κ : F.RelTransitionSystem) + {g : W₁.Flag} (hg : g ∈ (leftSub F).internalFlags) : + κ.match_ (Sum.inl g) = Sum.inl (leftDescend κ g) := by + have hgU : (Sum.inl g : (W₁.disjUnion W₂).Flag) ∈ F.internalFlags := + inl_mem_internal.mpr hg + obtain ⟨w, hw⟩ := (leftSub F).attach_internal_of_mem hg + have hvert := κ.match_vertex _ hgU (Sum.inl w) + (attach_inl_eq_inl.mpr hw) + rcases hm : κ.match_ (Sum.inl g) with g' | g' + · unfold leftDescend + rw [hm] + rfl + · rw [hm] at hvert + exact absurd hvert attach_inr_ne_inl + +/-- On an internal right flag, the union system's match is the right +descent, injected. -/ +theorem rightDescend_spec (κ : F.RelTransitionSystem) + {g : W₂.Flag} (hg : g ∈ (rightSub F).internalFlags) : + κ.match_ (Sum.inr g) = Sum.inr (rightDescend κ g) := by + have hgU : (Sum.inr g : (W₁.disjUnion W₂).Flag) ∈ F.internalFlags := + inr_mem_internal.mpr hg + obtain ⟨w, hw⟩ := (rightSub F).attach_internal_of_mem hg + have hvert := κ.match_vertex _ hgU (Sum.inr w) + (attach_inr_eq_inr.mpr hw) + rcases hm : κ.match_ (Sum.inr g) with g' | g' + · rw [hm] at hvert + exact absurd hvert attach_inl_ne_inr + · unfold rightDescend + rw [hm] + rfl + +/-- The left descent of an internal left flag is again internal. -/ +theorem leftDescend_mem (κ : F.RelTransitionSystem) + {g : W₁.Flag} (hg : g ∈ (leftSub F).internalFlags) : + leftDescend κ g ∈ (leftSub F).internalFlags := by + have h := κ.match_mem _ (inl_mem_internal.mpr hg) + rw [leftDescend_spec κ hg] at h + exact inl_mem_internal.mp h + +/-- The right descent of an internal right flag is again internal. -/ +theorem rightDescend_mem (κ : F.RelTransitionSystem) + {g : W₂.Flag} (hg : g ∈ (rightSub F).internalFlags) : + rightDescend κ g ∈ (rightSub F).internalFlags := by + have h := κ.match_mem _ (inr_mem_internal.mpr hg) + rw [rightDescend_spec κ hg] at h + exact inr_mem_internal.mp h + +/-- The restriction of a transition system on the union to its left +component: the matching never crosses between components, so it +restricts. -/ +noncomputable def leftRel (κ : F.RelTransitionSystem) : + (leftSub F).RelTransitionSystem where + match_ := leftDescend κ + match_invol g hg := by + have h := κ.match_invol _ (inl_mem_internal.mpr hg) + rw [leftDescend_spec κ hg, + leftDescend_spec κ (leftDescend_mem κ hg)] at h + exact Sum.inl.inj h + match_ne g hg heq := by + have h := κ.match_ne _ (inl_mem_internal.mpr hg) + rw [leftDescend_spec κ hg, heq] at h + exact h rfl + match_mem g hg := by exact leftDescend_mem κ hg + match_vertex g hg v hv := by + have h := κ.match_vertex _ (inl_mem_internal.mpr hg) + (Sum.inl v) (attach_inl_eq_inl.mpr hv) + rw [leftDescend_spec κ hg] at h + exact attach_inl_eq_inl.mp h + +/-- The restriction to the right component. -/ +noncomputable def rightRel (κ : F.RelTransitionSystem) : + (rightSub F).RelTransitionSystem where + match_ := rightDescend κ + match_invol g hg := by + have h := κ.match_invol _ (inr_mem_internal.mpr hg) + rw [rightDescend_spec κ hg, + rightDescend_spec κ (rightDescend_mem κ hg)] at h + exact Sum.inr.inj h + match_ne g hg heq := by + have h := κ.match_ne _ (inr_mem_internal.mpr hg) + rw [rightDescend_spec κ hg, heq] at h + exact h rfl + match_mem g hg := by exact rightDescend_mem κ hg + match_vertex g hg v hv := by + have h := κ.match_vertex _ (inr_mem_internal.mpr hg) + (Sum.inr v) (attach_inr_eq_inr.mpr hv) + rw [rightDescend_spec κ hg] at h + exact attach_inr_eq_inr.mp h + +/-! ### The product system -/ + +/-- The product of two componentwise transition systems: a system on +the union, inverse to the two restrictions. -/ +noncomputable def prodRel (κ₁ : (leftSub F).RelTransitionSystem) + (κ₂ : (rightSub F).RelTransitionSystem) : + F.RelTransitionSystem where + match_ := Sum.map κ₁.match_ κ₂.match_ + match_invol f hf := by + cases f with + | inl g => + change Sum.inl (κ₁.match_ (κ₁.match_ g)) = Sum.inl g + rw [κ₁.match_invol g (inl_mem_internal.mp hf)] + | inr g => + change Sum.inr (κ₂.match_ (κ₂.match_ g)) = Sum.inr g + rw [κ₂.match_invol g (inr_mem_internal.mp hf)] + match_ne f hf heq := by + cases f with + | inl g => + exact κ₁.match_ne g (inl_mem_internal.mp hf) (Sum.inl.inj heq) + | inr g => + exact κ₂.match_ne g (inr_mem_internal.mp hf) (Sum.inr.inj heq) + match_mem f hf := by + cases f with + | inl g => + exact inl_mem_internal.mpr + (κ₁.match_mem g (inl_mem_internal.mp hf)) + | inr g => + exact inr_mem_internal.mpr + (κ₂.match_mem g (inr_mem_internal.mp hf)) + match_vertex f hf v hv := by + cases f with + | inl g => + cases v with + | inl w => + exact attach_inl_eq_inl.mpr (κ₁.match_vertex g + (inl_mem_internal.mp hf) w (attach_inl_eq_inl.mp hv)) + | inr w => exact absurd hv attach_inl_ne_inr + | inr g => + cases v with + | inl w => exact absurd hv attach_inr_ne_inl + | inr w => + exact attach_inr_eq_inr.mpr (κ₂.match_vertex g + (inr_mem_internal.mp hf) w (attach_inr_eq_inr.mp hv)) + +/-- The product of two componentwise orientations. -/ +noncomputable def prodOrient {κ₁ : (leftSub F).RelTransitionSystem} + {κ₂ : (rightSub F).RelTransitionSystem} + (o₁ : κ₁.Orientation) (o₂ : κ₂.Orientation) : + (prodRel (F := F) κ₁ κ₂).Orientation where + isOut := Sum.elim o₁.isOut o₂.isOut + match_flip f hf := by + cases f with + | inl g => + change o₁.isOut (κ₁.match_ g) = !o₁.isOut g + exact o₁.match_flip g (inl_mem_internal.mp hf) + | inr g => + change o₂.isOut (κ₂.match_ g) = !o₂.isOut g + exact o₂.match_flip g (inr_mem_internal.mp hf) + pairing_flip f hf hp := by + cases f with + | inl g => + change o₁.isOut (W₁.pairing g) = !o₁.isOut g + exact o₁.pairing_flip g (inl_mem_internal.mp hf) + (inl_mem_internal.mp hp) + | inr g => + change o₂.isOut (W₂.pairing g) = !o₂.isOut g + exact o₂.pairing_flip g (inr_mem_internal.mp hf) + (inr_mem_internal.mp hp) + +/-! ### Circuit count additivity -/ + +/-- A walk of the product system started at a left flag stays left +and tracks the left component's walk. -/ +theorem iterWalk_prodRel_inl (κ₁ : (leftSub F).RelTransitionSystem) + (κ₂ : (rightSub F).RelTransitionSystem) + (g : W₁.Flag) (n : ℕ) : + iterWalk (prodRel (F := F) κ₁ κ₂) (Sum.inl g) n = + Sum.inl (iterWalk κ₁ g n) := by + induction n with + | zero => rfl + | succ n ih => + rw [iterWalk_succ (prodRel (F := F) κ₁ κ₂) (Sum.inl g) n, ih, + iterWalk_succ κ₁ g n] + rfl + +/-- The right analogue. -/ +theorem iterWalk_prodRel_inr (κ₁ : (leftSub F).RelTransitionSystem) + (κ₂ : (rightSub F).RelTransitionSystem) + (g : W₂.Flag) (n : ℕ) : + iterWalk (prodRel (F := F) κ₁ κ₂) (Sum.inr g) n = + Sum.inr (iterWalk κ₂ g n) := by + induction n with + | zero => rfl + | succ n ih => + rw [iterWalk_succ (prodRel (F := F) κ₁ κ₂) (Sum.inr g) n, ih, + iterWalk_succ κ₂ g n] + rfl + +/-- A left flag is periodic for the product system exactly when it is +periodic for the left factor: the walk never crosses components. -/ +theorem inl_mem_periodic {κ₁ : (leftSub F).RelTransitionSystem} + {κ₂ : (rightSub F).RelTransitionSystem} {g : W₁.Flag} : + (Sum.inl g : (W₁.disjUnion W₂).Flag) ∈ + (prodRel (F := F) κ₁ κ₂).periodicFlags ↔ + g ∈ κ₁.periodicFlags := by + constructor + · intro h + obtain ⟨hint, n, hn1, hcont, hper⟩ := + (prodRel κ₁ κ₂).mem_periodicFlags.mp h + refine κ₁.mem_periodicFlags.mpr + ⟨inl_mem_internal.mp hint, n, hn1, ?_, ?_⟩ + · intro j hj + have hc := hcont j hj + rw [iterWalk_prodRel_inl κ₁ κ₂ g j, pairing_inl] at hc + exact inl_mem_internal.mp hc + · have hh := hper + rw [iterWalk_prodRel_inl κ₁ κ₂ g n] at hh + exact Sum.inl.inj hh + · intro h + obtain ⟨hint, n, hn1, hcont, hper⟩ := + κ₁.mem_periodicFlags.mp h + refine (prodRel κ₁ κ₂).mem_periodicFlags.mpr + ⟨inl_mem_internal.mpr hint, n, hn1, ?_, ?_⟩ + · intro j hj + rw [iterWalk_prodRel_inl κ₁ κ₂ g j, pairing_inl] + exact inl_mem_internal.mpr (hcont j hj) + · rw [iterWalk_prodRel_inl κ₁ κ₂ g n, hper] + +/-- A right flag is periodic for the product system exactly when it is +periodic for the right factor. -/ +theorem inr_mem_periodic {κ₁ : (leftSub F).RelTransitionSystem} + {κ₂ : (rightSub F).RelTransitionSystem} {g : W₂.Flag} : + (Sum.inr g : (W₁.disjUnion W₂).Flag) ∈ + (prodRel (F := F) κ₁ κ₂).periodicFlags ↔ + g ∈ κ₂.periodicFlags := by + constructor + · intro h + obtain ⟨hint, n, hn1, hcont, hper⟩ := + (prodRel κ₁ κ₂).mem_periodicFlags.mp h + refine κ₂.mem_periodicFlags.mpr + ⟨inr_mem_internal.mp hint, n, hn1, ?_, ?_⟩ + · intro j hj + have hc := hcont j hj + rw [iterWalk_prodRel_inr κ₁ κ₂ g j, pairing_inr] at hc + exact inr_mem_internal.mp hc + · have hh := hper + rw [iterWalk_prodRel_inr κ₁ κ₂ g n] at hh + exact Sum.inr.inj hh + · intro h + obtain ⟨hint, n, hn1, hcont, hper⟩ := + κ₂.mem_periodicFlags.mp h + refine (prodRel κ₁ κ₂).mem_periodicFlags.mpr + ⟨inr_mem_internal.mpr hint, n, hn1, ?_, ?_⟩ + · intro j hj + rw [iterWalk_prodRel_inr κ₁ κ₂ g j, pairing_inr] + exact inr_mem_internal.mpr (hcont j hj) + · rw [iterWalk_prodRel_inr κ₁ κ₂ g n, hper] + +/-- The product system's periodic flags are the disjoint sum of the +two factors' periodic flags. -/ +noncomputable def periodicSumEquiv + (κ₁ : (leftSub F).RelTransitionSystem) + (κ₂ : (rightSub F).RelTransitionSystem) : + {f : (W₁.disjUnion W₂).Flag // + f ∈ (prodRel (F := F) κ₁ κ₂).periodicFlags} ≃ + ({g : W₁.Flag // g ∈ κ₁.periodicFlags} ⊕ + {g : W₂.Flag // g ∈ κ₂.periodicFlags}) where + toFun x := + match x with + | ⟨Sum.inl g, h⟩ => Sum.inl ⟨g, inl_mem_periodic.mp h⟩ + | ⟨Sum.inr g, h⟩ => Sum.inr ⟨g, inr_mem_periodic.mp h⟩ + invFun x := + match x with + | Sum.inl ⟨g, h⟩ => ⟨Sum.inl g, inl_mem_periodic.mpr h⟩ + | Sum.inr ⟨g, h⟩ => ⟨Sum.inr g, inr_mem_periodic.mpr h⟩ + left_inv x := by + rcases x with ⟨f, h⟩ + cases f <;> rfl + right_inv x := by + rcases x with ⟨g, h⟩ | ⟨g, h⟩ <;> rfl + +/-- Under that identification the product system's walk permutation is +the sum of the two factors' walk permutations. -/ +theorem walkPermPeriodic_prodRel (κ₁ : (leftSub F).RelTransitionSystem) + (κ₂ : (rightSub F).RelTransitionSystem) : + (prodRel (F := F) κ₁ κ₂).walkPermPeriodic = + (periodicSumEquiv κ₁ κ₂).symm.permCongr + (Equiv.sumCongr κ₁.walkPermPeriodic κ₂.walkPermPeriodic) := by + ext ⟨f, hf⟩ + cases f with + | inl g => rfl + | inr g => rfl + +/-- **Circuit counts add**: the product system's open circuit count +is the sum of the two components'. Each component's orbit data is +even, so no halving correction survives the split. -/ +theorem openCircuitCount_prodRel (κ₁ : (leftSub F).RelTransitionSystem) + (κ₂ : (rightSub F).RelTransitionSystem) : + (prodRel (F := F) κ₁ κ₂).openCircuitCount = + κ₁.openCircuitCount + κ₂.openCircuitCount := by + classical + obtain ⟨a, ha⟩ := even_card_cycleType κ₁ + obtain ⟨b, hb⟩ := even_card_fixedPoints κ₁ + unfold RelTransitionSystem.openCircuitCount + rw [walkPermPeriodic_prodRel κ₁ κ₂, cycleType_permCongr, + cycleType_sumCongr, Multiset.card_add, + card_fixedPoints_permCongr, card_fixedPoints_sumCongr] + omega + +end ProdSystems + +/-! ## The through-product factorization -/ + +section ThroughSplit + +open EdgeSubset + +variable {α β : Type} + +end ThroughSplit + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/B.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/B.lean new file mode 100644 index 0000000000..fbd33aa534 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/B.lean @@ -0,0 +1,811 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.A + +/-! +# The disjoint union: colour and value splitting + +The colouring sum and the through-summand of a union split into +the two components. +-/ + +@[expose] public section + +namespace RS + + + +section ColourSplit + +open EdgeSubset + +variable {α β : Type} {W₁ : Fragment α} {W₂ : Fragment β} + {F : EdgeSubset (W₁.disjUnion W₂)} + +/-- A left flag outside a union subset is outside its left +restriction. -/ +theorem notmem_left {g : W₁.Flag} + (hg : (Sum.inl g : (W₁.disjUnion W₂).Flag) ∉ F.flags) : + g ∉ (leftSub F).flags := + fun h => hg (mem_leftSub_flags.mp h) + +/-- Conversely, a left flag outside the left restriction is outside the +union subset. -/ +theorem notmem_left' {g : W₁.Flag} + (hg : g ∉ (leftSub F).flags) : + (Sum.inl g : (W₁.disjUnion W₂).Flag) ∉ F.flags := + fun h => hg (mem_leftSub_flags.mpr h) + +/-- A right flag outside a union subset is outside its right +restriction. -/ +theorem notmem_right {g : W₂.Flag} + (hg : (Sum.inr g : (W₁.disjUnion W₂).Flag) ∉ F.flags) : + g ∉ (rightSub F).flags := + fun h => hg (mem_rightSub_flags.mp h) + +/-- Conversely, a right flag outside the right restriction is outside +the union subset. -/ +theorem notmem_right' {g : W₂.Flag} + (hg : g ∉ (rightSub F).flags) : + (Sum.inr g : (W₁.disjUnion W₂).Flag) ∉ F.flags := + fun h => hg (mem_rightSub_flags.mpr h) + +/-! ### Joining even colourings -/ + +/-- The underlying map of the join of two even colourings: each +non-participating flag takes its own component's colour. -/ +noncomputable def joinEvenVal {k : ℕ} + (ψ₁ : (leftSub F).EvenColouring k) + (ψ₂ : (rightSub F).EvenColouring k) : + {f : (W₁.disjUnion W₂).Flag // f ∉ F.flags} → Fin k := + fun f => match f with + | ⟨Sum.inl g, hg⟩ => ψ₁.val ⟨g, notmem_left hg⟩ + | ⟨Sum.inr g, hg⟩ => ψ₂.val ⟨g, notmem_right hg⟩ + +/-- The join reads the left colouring at a left flag. -/ +theorem joinEvenVal_inl {k : ℕ} + (ψ₁ : (leftSub F).EvenColouring k) + (ψ₂ : (rightSub F).EvenColouring k) (g : W₁.Flag) + (hg : (Sum.inl g : (W₁.disjUnion W₂).Flag) ∉ F.flags) + (hg' : g ∉ (leftSub F).flags) : + joinEvenVal ψ₁ ψ₂ ⟨Sum.inl g, hg⟩ = ψ₁.val ⟨g, hg'⟩ := rfl + +/-- The join reads the right colouring at a right flag. -/ +theorem joinEvenVal_inr {k : ℕ} + (ψ₁ : (leftSub F).EvenColouring k) + (ψ₂ : (rightSub F).EvenColouring k) (g : W₂.Flag) + (hg : (Sum.inr g : (W₁.disjUnion W₂).Flag) ∉ F.flags) + (hg' : g ∉ (rightSub F).flags) : + joinEvenVal ψ₁ ψ₂ ⟨Sum.inr g, hg⟩ = ψ₂.val ⟨g, hg'⟩ := rfl + +/-- The join of two component even colourings as an even colouring of +the union subset. -/ +noncomputable def joinEven {k : ℕ} + (ψ₁ : (leftSub F).EvenColouring k) + (ψ₂ : (rightSub F).EvenColouring k) : F.EvenColouring k := + ⟨joinEvenVal ψ₁ ψ₂, by + rintro ⟨f, hf⟩ + cases f with + | inl g => + have hgL : g ∉ (leftSub F).flags := notmem_left hf + exact ((joinEvenVal_inl ψ₁ ψ₂ (W₁.pairing g) + (F.pairing_not_mem hf) + ((leftSub F).pairing_not_mem hgL)).trans + (ψ₁.prop ⟨g, hgL⟩)).trans + (joinEvenVal_inl ψ₁ ψ₂ g hf hgL).symm + | inr g => + have hgR : g ∉ (rightSub F).flags := notmem_right hf + exact ((joinEvenVal_inr ψ₁ ψ₂ (W₂.pairing g) + (F.pairing_not_mem hf) + ((rightSub F).pairing_not_mem hgR)).trans + (ψ₂.prop ⟨g, hgR⟩)).trans + (joinEvenVal_inr ψ₁ ψ₂ g hf hgR).symm⟩ + +/-- Even colourings of a union subset are pairs of even colourings of +the two restrictions. -/ +noncomputable def joinEvenEquiv + (F : EdgeSubset (W₁.disjUnion W₂)) (k : ℕ) : + ((leftSub F).EvenColouring k × (rightSub F).EvenColouring k) ≃ + F.EvenColouring k where + toFun p := joinEven p.1 p.2 + invFun ψ := + (⟨fun g => ψ.val ⟨Sum.inl g.val, notmem_left' g.prop⟩, + fun g => by + exact ψ.prop ⟨Sum.inl g.val, notmem_left' g.prop⟩⟩, + ⟨fun g => ψ.val ⟨Sum.inr g.val, notmem_right' g.prop⟩, + fun g => by + exact ψ.prop ⟨Sum.inr g.val, notmem_right' g.prop⟩⟩) + left_inv p := by + refine Prod.ext ?_ ?_ + · exact Subtype.ext (funext fun g => rfl) + · exact Subtype.ext (funext fun g => rfl) + right_inv ψ := by + refine Subtype.ext (funext fun f => ?_) + rcases f with ⟨f, hf⟩ + cases f <;> rfl + +/-! ### Joining core odd colourings -/ + +/-- The underlying map of the join of two core odd colourings: each +core flag takes its own component's colour. -/ +noncomputable def joinCoreVal {ℓ : ℕ} + (φ₁ : (leftSub F).CoreOddColouring ℓ) + (φ₂ : (rightSub F).CoreOddColouring ℓ) : + {f : (W₁.disjUnion W₂).Flag // f ∈ F.coreFlags} → Fin (2 * ℓ) := + fun f => match f with + | ⟨Sum.inl g, hg⟩ => φ₁.val ⟨g, inl_mem_core.mp hg⟩ + | ⟨Sum.inr g, hg⟩ => φ₂.val ⟨g, inr_mem_core.mp hg⟩ + +/-- The core join reads the left colouring at a left flag. -/ +theorem joinCoreVal_inl {ℓ : ℕ} + (φ₁ : (leftSub F).CoreOddColouring ℓ) + (φ₂ : (rightSub F).CoreOddColouring ℓ) (g : W₁.Flag) + (hg : (Sum.inl g : (W₁.disjUnion W₂).Flag) ∈ F.coreFlags) + (hg' : g ∈ (leftSub F).coreFlags) : + joinCoreVal φ₁ φ₂ ⟨Sum.inl g, hg⟩ = φ₁.val ⟨g, hg'⟩ := rfl + +/-- The core join reads the right colouring at a right flag. -/ +theorem joinCoreVal_inr {ℓ : ℕ} + (φ₁ : (leftSub F).CoreOddColouring ℓ) + (φ₂ : (rightSub F).CoreOddColouring ℓ) (g : W₂.Flag) + (hg : (Sum.inr g : (W₁.disjUnion W₂).Flag) ∈ F.coreFlags) + (hg' : g ∈ (rightSub F).coreFlags) : + joinCoreVal φ₁ φ₂ ⟨Sum.inr g, hg⟩ = φ₂.val ⟨g, hg'⟩ := rfl + +/-- The join of two component core odd colourings as a core odd +colouring of the union subset. -/ +noncomputable def joinCore {ℓ : ℕ} + (φ₁ : (leftSub F).CoreOddColouring ℓ) + (φ₂ : (rightSub F).CoreOddColouring ℓ) : + F.CoreOddColouring ℓ := + ⟨joinCoreVal φ₁ φ₂, by + rintro ⟨f, hf⟩ + cases f with + | inl g => + have hgL : g ∈ (leftSub F).coreFlags := inl_mem_core.mp hf + exact ((joinCoreVal_inl φ₁ φ₂ (W₁.pairing g) + (F.pairing_mem_coreFlags hf) + ((leftSub F).pairing_mem_coreFlags hgL)).trans + (φ₁.prop ⟨g, hgL⟩)).trans + (joinCoreVal_inl φ₁ φ₂ g hf hgL).symm + | inr g => + have hgR : g ∈ (rightSub F).coreFlags := inr_mem_core.mp hf + exact ((joinCoreVal_inr φ₁ φ₂ (W₂.pairing g) + (F.pairing_mem_coreFlags hf) + ((rightSub F).pairing_mem_coreFlags hgR)).trans + (φ₂.prop ⟨g, hgR⟩)).trans + (joinCoreVal_inr φ₁ φ₂ g hf hgR).symm⟩ + +/-- Core odd colourings of a union subset are pairs of core odd +colourings of the two restrictions. -/ +noncomputable def joinCoreEquiv + (F : EdgeSubset (W₁.disjUnion W₂)) (ℓ : ℕ) : + ((leftSub F).CoreOddColouring ℓ × + (rightSub F).CoreOddColouring ℓ) ≃ + F.CoreOddColouring ℓ where + toFun p := joinCore p.1 p.2 + invFun φ := + (⟨fun g => φ.val ⟨Sum.inl g.val, inl_mem_core.mpr g.prop⟩, + fun g => by + exact φ.prop ⟨Sum.inl g.val, inl_mem_core.mpr g.prop⟩⟩, + ⟨fun g => φ.val ⟨Sum.inr g.val, inr_mem_core.mpr g.prop⟩, + fun g => by + exact φ.prop ⟨Sum.inr g.val, inr_mem_core.mpr g.prop⟩⟩) + left_inv p := by + refine Prod.ext ?_ ?_ + · exact Subtype.ext (funext fun g => rfl) + · exact Subtype.ext (funext fun g => rfl) + right_inv φ := by + refine Subtype.ext (funext fun f => ?_) + rcases f with ⟨f, hf⟩ + cases f <;> rfl + +/-! ### Boundary-match transfer -/ + +/-- A join of even colourings meets the union's boundary constraint +exactly when both components meet theirs. -/ +theorem genEvenBoundaryMatch_join {k ℓ : ℕ} + {st : GenBoundaryState k ℓ (α ⊕ β)} + (hbnd : genBoundarySubsetMatches (W₁.disjUnion W₂) F.flags st) + (hbnd₁ : genBoundarySubsetMatches W₁ (leftSub F).flags + (fun a => st (Sum.inl a))) + (hbnd₂ : genBoundarySubsetMatches W₂ (rightSub F).flags + (fun b => st (Sum.inr b))) + (ψ₁ : (leftSub F).EvenColouring k) + (ψ₂ : (rightSub F).EvenColouring k) : + genEvenBoundaryMatch F st hbnd (joinEven ψ₁ ψ₂) ↔ + (genEvenBoundaryMatch (leftSub F) (fun a => st (Sum.inl a)) + hbnd₁ ψ₁ ∧ + genEvenBoundaryMatch (rightSub F) (fun b => st (Sum.inr b)) + hbnd₂ ψ₂) := by + constructor + · intro hm + constructor + · intro a c hst + have h0 := hm (Sum.inl a) c hst + exact (joinEvenVal_inl ψ₁ ψ₂ (W₁.boundaryFlag a) + (genBoundaryFlag_not_mem_of_even hbnd (Sum.inl a) c hst) + (genBoundaryFlag_not_mem_of_even hbnd₁ a c hst)).symm.trans h0 + · intro b c hst + have h0 := hm (Sum.inr b) c hst + exact (joinEvenVal_inr ψ₁ ψ₂ (W₂.boundaryFlag b) + (genBoundaryFlag_not_mem_of_even hbnd (Sum.inr b) c hst) + (genBoundaryFlag_not_mem_of_even hbnd₂ b c hst)).symm.trans h0 + · rintro ⟨h₁, h₂⟩ i c hst + cases i with + | inl a => + exact (joinEvenVal_inl ψ₁ ψ₂ (W₁.boundaryFlag a) + (genBoundaryFlag_not_mem_of_even hbnd (Sum.inl a) c hst) + (genBoundaryFlag_not_mem_of_even hbnd₁ a c hst)).trans + (h₁ a c hst) + | inr b => + exact (joinEvenVal_inr ψ₁ ψ₂ (W₂.boundaryFlag b) + (genBoundaryFlag_not_mem_of_even hbnd (Sum.inr b) c hst) + (genBoundaryFlag_not_mem_of_even hbnd₂ b c hst)).trans + (h₂ b c hst) + +/-- A join of core odd colourings meets the union's boundary +constraint exactly when both components meet theirs. -/ +theorem coreOddBoundaryMatch_join {k ℓ : ℕ} + {st : GenBoundaryState k ℓ (α ⊕ β)} + (φ₁ : (leftSub F).CoreOddColouring ℓ) + (φ₂ : (rightSub F).CoreOddColouring ℓ) : + F.coreOddBoundaryMatch st (joinCore φ₁ φ₂) ↔ + ((leftSub F).coreOddBoundaryMatch (fun a => st (Sum.inl a)) φ₁ ∧ + (rightSub F).coreOddBoundaryMatch (fun b => st (Sum.inr b)) + φ₂) := by + constructor + · intro hm + constructor + · intro a c hst hcore + have h0 := hm (Sum.inl a) c hst (inl_mem_core.mpr hcore) + exact (joinCoreVal_inl φ₁ φ₂ (W₁.boundaryFlag a) + (inl_mem_core.mpr hcore) hcore).symm.trans h0 + · intro b c hst hcore + have h0 := hm (Sum.inr b) c hst (inr_mem_core.mpr hcore) + exact (joinCoreVal_inr φ₁ φ₂ (W₂.boundaryFlag b) + (inr_mem_core.mpr hcore) hcore).symm.trans h0 + · rintro ⟨h₁, h₂⟩ i c hst hcore + cases i with + | inl a => + exact (joinCoreVal_inl φ₁ φ₂ (W₁.boundaryFlag a) hcore + (inl_mem_core.mp hcore)).trans + (h₁ a c hst (inl_mem_core.mp hcore)) + | inr b => + exact (joinCoreVal_inr φ₁ φ₂ (W₂.boundaryFlag b) hcore + (inr_mem_core.mp hcore)).trans + (h₂ b c hst (inr_mem_core.mp hcore)) + +/-! ### Even colour multisets at component vertices -/ + +/-- The left injection embeds the left restriction's +non-participating flags into the union's. -/ +noncomputable def leftComplEmb + (F : EdgeSubset (W₁.disjUnion W₂)) : + {g : W₁.Flag // g ∉ (leftSub F).flags} ↪ + {f : (W₁.disjUnion W₂).Flag // f ∉ F.flags} := + ⟨fun g => ⟨Sum.inl g.val, notmem_left' g.prop⟩, + fun _g _g' h => + Subtype.ext (Sum.inl.inj (congrArg Subtype.val h))⟩ + +/-- The right injection embeds the right restriction's +non-participating flags into the union's. -/ +noncomputable def rightComplEmb + (F : EdgeSubset (W₁.disjUnion W₂)) : + {g : W₂.Flag // g ∉ (rightSub F).flags} ↪ + {f : (W₁.disjUnion W₂).Flag // f ∉ F.flags} := + ⟨fun g => ⟨Sum.inr g.val, notmem_right' g.prop⟩, + fun _g _g' h => + Subtype.ext (Sum.inr.inj (congrArg Subtype.val h))⟩ + +/-- At a left vertex, the join's colour multiset over the flags there +is the left colouring's. -/ +theorem evenColours_aux_inl {k : ℕ} + (ψ₁ : (leftSub F).EvenColouring k) + (ψ₂ : (rightSub F).EvenColouring k) (v : W₁.Vertex) + (S : Finset {f : (W₁.disjUnion W₂).Flag // f ∉ F.flags}) + (T : Finset {g : W₁.Flag // g ∉ (leftSub F).flags}) + (hS : ∀ x, x ∈ S ↔ + (W₁.disjUnion W₂).attach x.val = Sum.inl (Sum.inl v)) + (hT : ∀ y, y ∈ T ↔ W₁.attach y.val = Sum.inl v) : + S.val.map (joinEven ψ₁ ψ₂).val = T.val.map ψ₁.val := by + have hset : S = T.map (leftComplEmb F) := by + ext x + rw [hS x] + constructor + · intro hatt + rcases x with ⟨f, hf⟩ + cases f with + | inl g => + exact Finset.mem_map.mpr ⟨⟨g, notmem_left hf⟩, + (hT _).mpr (attach_inl_eq_inl.mp hatt), Subtype.ext rfl⟩ + | inr g => exact absurd hatt attach_inr_ne_inl + · intro hx + obtain ⟨g, hg, hmap⟩ := Finset.mem_map.mp hx + rw [← hmap] + exact attach_inl_eq_inl.mpr ((hT g).mp hg) + rw [hset, Finset.map_val, Multiset.map_map] + exact Multiset.map_congr rfl fun g hg => + joinEvenVal_inl ψ₁ ψ₂ g.val (notmem_left' g.prop) g.prop + +/-- At a right vertex, the join's colour multiset over the flags there +is the right colouring's. -/ +theorem evenColours_aux_inr {k : ℕ} + (ψ₁ : (leftSub F).EvenColouring k) + (ψ₂ : (rightSub F).EvenColouring k) (v : W₂.Vertex) + (S : Finset {f : (W₁.disjUnion W₂).Flag // f ∉ F.flags}) + (T : Finset {g : W₂.Flag // g ∉ (rightSub F).flags}) + (hS : ∀ x, x ∈ S ↔ + (W₁.disjUnion W₂).attach x.val = Sum.inl (Sum.inr v)) + (hT : ∀ y, y ∈ T ↔ W₂.attach y.val = Sum.inl v) : + S.val.map (joinEven ψ₁ ψ₂).val = T.val.map ψ₂.val := by + have hset : S = T.map (rightComplEmb F) := by + ext x + rw [hS x] + constructor + · intro hatt + rcases x with ⟨f, hf⟩ + cases f with + | inl g => exact absurd hatt attach_inl_ne_inr + | inr g => + exact Finset.mem_map.mpr ⟨⟨g, notmem_right hf⟩, + (hT _).mpr (attach_inr_eq_inr.mp hatt), Subtype.ext rfl⟩ + · intro hx + obtain ⟨g, hg, hmap⟩ := Finset.mem_map.mp hx + rw [← hmap] + exact attach_inr_eq_inr.mpr ((hT g).mp hg) + rw [hset, Finset.map_val, Multiset.map_map] + exact Multiset.map_congr rfl fun g hg => + joinEvenVal_inr ψ₁ ψ₂ g.val (notmem_right' g.prop) g.prop + +/-- The join's even colours at a left vertex are the left +colouring's. -/ +theorem evenColoursAt_join_inl {k : ℕ} + (ψ₁ : (leftSub F).EvenColouring k) + (ψ₂ : (rightSub F).EvenColouring k) (v : W₁.Vertex) : + F.evenColoursAt (joinEven ψ₁ ψ₂) (Sum.inl v) = + (leftSub F).evenColoursAt ψ₁ v := by + unfold EdgeSubset.evenColoursAt + refine evenColours_aux_inl ψ₁ ψ₂ v _ _ ?_ ?_ + · intro x + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + exact Iff.rfl + · intro y + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + +/-- The join's even colours at a right vertex are the right +colouring's. -/ +theorem evenColoursAt_join_inr {k : ℕ} + (ψ₁ : (leftSub F).EvenColouring k) + (ψ₂ : (rightSub F).EvenColouring k) (v : W₂.Vertex) : + F.evenColoursAt (joinEven ψ₁ ψ₂) (Sum.inr v) = + (rightSub F).evenColoursAt ψ₂ v := by + unfold EdgeSubset.evenColoursAt + refine evenColours_aux_inr ψ₁ ψ₂ v _ _ ?_ ?_ + · intro x + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + exact Iff.rfl + · intro y + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + +/-! ### In-flag lists at component vertices -/ + +/-- At a left vertex, the product orientation's in-flags are the left +factor's, injected — up to the enumeration order. -/ +theorem relInFlagsAt_join_perm_inl + {κ₁ : (leftSub F).RelTransitionSystem} + {κ₂ : (rightSub F).RelTransitionSystem} + (o₁ : κ₁.Orientation) (o₂ : κ₂.Orientation) (v : W₁.Vertex) : + (F.relInFlagsAt (prodOrient o₁ o₂) (Sum.inl v)).Perm + (((leftSub F).relInFlagsAt o₁ v).map Sum.inl) := by + let := (W₁.disjUnion W₂).flagOrder + let := W₁.flagOrder + let := Classical.dec + apply Multiset.coe_eq_coe.mp + unfold EdgeSubset.relInFlagsAt + refine Eq.trans (Finset.sort_eq _ _) ?_ + refine Eq.trans ?_ (Multiset.map_coe Sum.inl _) + refine Eq.trans ?_ + (congrArg (Multiset.map Sum.inl) (Finset.sort_eq _ _)).symm + refine (Multiset.Nodup.ext (Finset.nodup _) + (Multiset.Nodup.map Sum.inl_injective (Finset.nodup _))).mpr ?_ + intro f + constructor + · intro hf + have h := Finset.mem_filter.mp (Finset.mem_val.mp hf) + cases f with + | inl g => + refine Multiset.mem_map.mpr ⟨g, ?_, rfl⟩ + exact Finset.mem_val.mpr (Finset.mem_filter.mpr + ⟨mem_leftSub_flags.mpr h.1, + attach_inl_eq_inl.mp h.2.1, h.2.2⟩) + | inr g => + exact absurd h.2.1 attach_inr_ne_inl + · intro hf + obtain ⟨g, hg, rfl⟩ := Multiset.mem_map.mp hf + have h := Finset.mem_filter.mp (Finset.mem_val.mp hg) + exact Finset.mem_val.mpr (Finset.mem_filter.mpr + ⟨mem_leftSub_flags.mp h.1, + attach_inl_eq_inl.mpr h.2.1, h.2.2⟩) + +/-- At a right vertex, the product orientation's in-flags are the +right factor's, injected — up to the enumeration order. -/ +theorem relInFlagsAt_join_perm_inr + {κ₁ : (leftSub F).RelTransitionSystem} + {κ₂ : (rightSub F).RelTransitionSystem} + (o₁ : κ₁.Orientation) (o₂ : κ₂.Orientation) (v : W₂.Vertex) : + (F.relInFlagsAt (prodOrient o₁ o₂) (Sum.inr v)).Perm + (((rightSub F).relInFlagsAt o₂ v).map Sum.inr) := by + let := (W₁.disjUnion W₂).flagOrder + let := W₂.flagOrder + let := Classical.dec + apply Multiset.coe_eq_coe.mp + unfold EdgeSubset.relInFlagsAt + refine Eq.trans (Finset.sort_eq _ _) ?_ + refine Eq.trans ?_ (Multiset.map_coe Sum.inr _) + refine Eq.trans ?_ + (congrArg (Multiset.map Sum.inr) (Finset.sort_eq _ _)).symm + refine (Multiset.Nodup.ext (Finset.nodup _) + (Multiset.Nodup.map Sum.inr_injective (Finset.nodup _))).mpr ?_ + intro f + constructor + · intro hf + have h := Finset.mem_filter.mp (Finset.mem_val.mp hf) + cases f with + | inl g => + exact absurd h.2.1 attach_inl_ne_inr + | inr g => + refine Multiset.mem_map.mpr ⟨g, ?_, rfl⟩ + exact Finset.mem_val.mpr (Finset.mem_filter.mpr + ⟨mem_rightSub_flags.mpr h.1, + attach_inr_eq_inr.mp h.2.1, h.2.2⟩) + · intro hf + obtain ⟨g, hg, rfl⟩ := Multiset.mem_map.mp hf + have h := Finset.mem_filter.mp (Finset.mem_val.mp hg) + exact Finset.mem_val.mpr (Finset.mem_filter.mpr + ⟨mem_rightSub_flags.mp h.1, + attach_inr_eq_inr.mpr h.2.1, h.2.2⟩) + +/-- An injected left in-flag is an internal flag of the union +subset. -/ +theorem mem_internal_of_mem_map_inl + {κ₁ : (leftSub F).RelTransitionSystem} {o₁ : κ₁.Orientation} + {v : W₁.Vertex} {f : (W₁.disjUnion W₂).Flag} + (hf : f ∈ ((leftSub F).relInFlagsAt o₁ v).map Sum.inl) : + f ∈ F.internalFlags := by + obtain ⟨g, hgl, rfl⟩ := List.mem_map.mp hf + exact inl_mem_internal.mpr + ((leftSub F).mem_internal_of_mem_relInFlagsAt hgl) + +/-- An injected right in-flag is an internal flag of the union +subset. -/ +theorem mem_internal_of_mem_map_inr + {κ₂ : (rightSub F).RelTransitionSystem} {o₂ : κ₂.Orientation} + {v : W₂.Vertex} {f : (W₁.disjUnion W₂).Flag} + (hf : f ∈ ((rightSub F).relInFlagsAt o₂ v).map Sum.inr) : + f ∈ F.internalFlags := by + obtain ⟨g, hgl, rfl⟩ := List.mem_map.mp hf + exact inr_mem_internal.mpr + ((rightSub F).mem_internal_of_mem_relInFlagsAt hgl) + +/-! ### `pmap` helpers (mirrors `MixedPartition`) -/ + +/-- `List.pmap` respects permutations. -/ +theorem perm_pmap' {β' γ' : Type*} {p : β' → Prop} + (f : ∀ b, p b → γ') {l₁ l₂ : List β'} (hp : l₁.Perm l₂) : + ∀ (H₁ : ∀ b ∈ l₁, p b) (H₂ : ∀ b ∈ l₂, p b), + (l₁.pmap f H₁).Perm (l₂.pmap f H₂) := by + induction hp with + | nil => exact fun _ _ => List.Perm.refl _ + | cons b _ ih => exact fun _ _ => List.Perm.cons _ (ih _ _) + | swap x y l => exact fun _ _ => List.Perm.swap _ _ _ + | trans hp₁ _ ih₁ ih₂ => + exact fun H₁ H₂ => + (ih₁ H₁ (fun b hb => H₁ b (hp₁.mem_iff.mpr hb))).trans + (ih₂ (fun b hb => H₁ b (hp₁.mem_iff.mpr hb)) H₂) + +/-- Two `pmap`-then-`flatMap` passes over one list agree when they +agree elementwise. -/ +theorem pmap_flatMap_congr' {β' β₁ β₂ γ' : Type*} + {p₁ p₂ : β' → Prop} (f₁ : ∀ b, p₁ b → β₁) (f₂ : ∀ b, p₂ b → β₂) + (G₁ : β₁ → List γ') (G₂ : β₂ → List γ') (l : List β') + (H₁ : ∀ b ∈ l, p₁ b) (H₂ : ∀ b ∈ l, p₂ b) + (hpt : ∀ b ∈ l, ∀ h₁ h₂, G₁ (f₁ b h₁) = G₂ (f₂ b h₂)) : + (l.pmap f₁ H₁).flatMap G₁ = (l.pmap f₂ H₂).flatMap G₂ := by + induction l with + | nil => rfl + | cons a t ih => + simp only [List.pmap, List.flatMap_cons] + rw [hpt a List.mem_cons_self _ _, + ih _ _ (fun b hb => hpt b (List.mem_cons_of_mem _ hb))] + +/-! ### Vertex-local core data at component vertices -/ + +/-- The join's odd sign at a left internal flag is the left +factor's. -/ +theorem coreOddSignFn_join_inl {ℓ : ℕ} + {κ₁ : (leftSub F).RelTransitionSystem} + {κ₂ : (rightSub F).RelTransitionSystem} + (φ₁ : (leftSub F).CoreOddColouring ℓ) + (φ₂ : (rightSub F).CoreOddColouring ℓ) (g : W₁.Flag) + (hg' : (Sum.inl g : (W₁.disjUnion W₂).Flag) ∈ F.internalFlags) + (hg : g ∈ (leftSub F).internalFlags) : + F.coreOddSignFn (prodRel κ₁ κ₂) (joinCore φ₁ φ₂) + ⟨Sum.inl g, hg'⟩ = + (leftSub F).coreOddSignFn κ₁ φ₁ ⟨g, hg⟩ := rfl + +/-- The join's odd sign at a right internal flag is the right +factor's. -/ +theorem coreOddSignFn_join_inr {ℓ : ℕ} + {κ₁ : (leftSub F).RelTransitionSystem} + {κ₂ : (rightSub F).RelTransitionSystem} + (φ₁ : (leftSub F).CoreOddColouring ℓ) + (φ₂ : (rightSub F).CoreOddColouring ℓ) (g : W₂.Flag) + (hg' : (Sum.inr g : (W₁.disjUnion W₂).Flag) ∈ F.internalFlags) + (hg : g ∈ (rightSub F).internalFlags) : + F.coreOddSignFn (prodRel κ₁ κ₂) (joinCore φ₁ φ₂) + ⟨Sum.inr g, hg'⟩ = + (rightSub F).coreOddSignFn κ₂ φ₂ ⟨g, hg⟩ := rfl + +/-- The join's odd pair at a left internal flag is the left factor's, +injected. -/ +theorem coreOddPairFn_join_inl {ℓ : ℕ} + {κ₁ : (leftSub F).RelTransitionSystem} + {κ₂ : (rightSub F).RelTransitionSystem} + (φ₁ : (leftSub F).CoreOddColouring ℓ) + (φ₂ : (rightSub F).CoreOddColouring ℓ) (g : W₁.Flag) + (hg' : (Sum.inl g : (W₁.disjUnion W₂).Flag) ∈ F.internalFlags) + (hg : g ∈ (leftSub F).internalFlags) : + F.coreOddPairFn (prodRel κ₁ κ₂) (joinCore φ₁ φ₂) + ⟨Sum.inl g, hg'⟩ = + (leftSub F).coreOddPairFn κ₁ φ₁ ⟨g, hg⟩ := rfl + +/-- The join's odd pair at a right internal flag is the right +factor's, injected. -/ +theorem coreOddPairFn_join_inr {ℓ : ℕ} + {κ₁ : (leftSub F).RelTransitionSystem} + {κ₂ : (rightSub F).RelTransitionSystem} + (φ₁ : (leftSub F).CoreOddColouring ℓ) + (φ₂ : (rightSub F).CoreOddColouring ℓ) (g : W₂.Flag) + (hg' : (Sum.inr g : (W₁.disjUnion W₂).Flag) ∈ F.internalFlags) + (hg : g ∈ (rightSub F).internalFlags) : + F.coreOddPairFn (prodRel κ₁ κ₂) (joinCore φ₁ φ₂) + ⟨Sum.inr g, hg'⟩ = + (rightSub F).coreOddPairFn κ₂ φ₂ ⟨g, hg⟩ := rfl + +/-- The join's odd-pairing sign at a left vertex is the left +factor's. -/ +theorem coreOddSignAt_join_inl {ℓ : ℕ} + {κ₁ : (leftSub F).RelTransitionSystem} + {κ₂ : (rightSub F).RelTransitionSystem} + (o₁ : κ₁.Orientation) (o₂ : κ₂.Orientation) + (φ₁ : (leftSub F).CoreOddColouring ℓ) + (φ₂ : (rightSub F).CoreOddColouring ℓ) (v : W₁.Vertex) : + F.coreOddSignAt (prodOrient o₁ o₂) (joinCore φ₁ φ₂) + (Sum.inl v) = + (leftSub F).coreOddSignAt o₁ φ₁ v := by + unfold EdgeSubset.coreOddSignAt + have hstep := perm_pmap' Subtype.mk + (relInFlagsAt_join_perm_inl o₁ o₂ v) + (fun _ hf => F.mem_internal_of_mem_relInFlagsAt hf) + (fun _ hg => mem_internal_of_mem_map_inl hg) + refine ((hstep.map (F.coreOddSignFn (prodRel κ₁ κ₂) + (joinCore φ₁ φ₂))).prod_eq).trans (congrArg List.prod ?_) + refine Eq.trans (List.map_pmap _) ?_ + refine Eq.trans (List.pmap_map _) ?_ + exact Eq.trans (List.pmap_congr_left _ + (fun a ha h₁ h₂ => coreOddSignFn_join_inl φ₁ φ₂ a h₁ h₂)) + (List.map_pmap _).symm + +/-- The join's odd-pairing sign at a right vertex is the right +factor's. -/ +theorem coreOddSignAt_join_inr {ℓ : ℕ} + {κ₁ : (leftSub F).RelTransitionSystem} + {κ₂ : (rightSub F).RelTransitionSystem} + (o₁ : κ₁.Orientation) (o₂ : κ₂.Orientation) + (φ₁ : (leftSub F).CoreOddColouring ℓ) + (φ₂ : (rightSub F).CoreOddColouring ℓ) (v : W₂.Vertex) : + F.coreOddSignAt (prodOrient o₁ o₂) (joinCore φ₁ φ₂) + (Sum.inr v) = + (rightSub F).coreOddSignAt o₂ φ₂ v := by + unfold EdgeSubset.coreOddSignAt + have hstep := perm_pmap' Subtype.mk + (relInFlagsAt_join_perm_inr o₁ o₂ v) + (fun _ hf => F.mem_internal_of_mem_relInFlagsAt hf) + (fun _ hg => mem_internal_of_mem_map_inr hg) + refine ((hstep.map (F.coreOddSignFn (prodRel κ₁ κ₂) + (joinCore φ₁ φ₂))).prod_eq).trans (congrArg List.prod ?_) + refine Eq.trans (List.map_pmap _) ?_ + refine Eq.trans (List.pmap_map _) ?_ + exact Eq.trans (List.pmap_congr_left _ + (fun a ha h₁ h₂ => coreOddSignFn_join_inr φ₁ φ₂ a h₁ h₂)) + (List.map_pmap _).symm + +/-- The vertex functional's odd evaluation at a left vertex reads the +left factor's odd list. -/ +theorem evalOdd_coreOddListAt_join_inl {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (μ : Multiset (Fin k)) + {κ₁ : (leftSub F).RelTransitionSystem} + {κ₂ : (rightSub F).RelTransitionSystem} + (o₁ : κ₁.Orientation) (o₂ : κ₂.Orientation) + (φ₁ : (leftSub F).CoreOddColouring ℓ) + (φ₂ : (rightSub F).CoreOddColouring ℓ) (v : W₁.Vertex) : + h.evalOdd μ (F.coreOddListAt (prodOrient o₁ o₂) + (joinCore φ₁ φ₂) (Sum.inl v)) = + h.evalOdd μ ((leftSub F).coreOddListAt o₁ φ₁ v) := by + unfold EdgeSubset.coreOddListAt + have hstep := perm_pmap' Subtype.mk + (relInFlagsAt_join_perm_inl o₁ o₂ v) + (fun _ hf => F.mem_internal_of_mem_relInFlagsAt hf) + (fun _ hg => mem_internal_of_mem_map_inl hg) + have h1 := h.evalOdd_flatMap_perm μ + (F.coreOddPairFn (prodRel κ₁ κ₂) (joinCore φ₁ φ₂)) + (fun _ => rfl) hstep [] + simp only [List.nil_append] at h1 + refine h1.trans (congrArg (h.evalOdd μ) ?_) + refine Eq.trans (congrArg + (fun l' => l'.flatMap + (F.coreOddPairFn (prodRel κ₁ κ₂) (joinCore φ₁ φ₂))) + (List.pmap_map _)) ?_ + exact pmap_flatMap_congr' _ _ _ _ _ _ _ + (fun a ha h₁ h₂ => coreOddPairFn_join_inl φ₁ φ₂ a h₁ h₂) + +/-- The vertex functional's odd evaluation at a right vertex reads the +right factor's odd list. -/ +theorem evalOdd_coreOddListAt_join_inr {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (μ : Multiset (Fin k)) + {κ₁ : (leftSub F).RelTransitionSystem} + {κ₂ : (rightSub F).RelTransitionSystem} + (o₁ : κ₁.Orientation) (o₂ : κ₂.Orientation) + (φ₁ : (leftSub F).CoreOddColouring ℓ) + (φ₂ : (rightSub F).CoreOddColouring ℓ) (v : W₂.Vertex) : + h.evalOdd μ (F.coreOddListAt (prodOrient o₁ o₂) + (joinCore φ₁ φ₂) (Sum.inr v)) = + h.evalOdd μ ((rightSub F).coreOddListAt o₂ φ₂ v) := by + unfold EdgeSubset.coreOddListAt + have hstep := perm_pmap' Subtype.mk + (relInFlagsAt_join_perm_inr o₁ o₂ v) + (fun _ hf => F.mem_internal_of_mem_relInFlagsAt hf) + (fun _ hg => mem_internal_of_mem_map_inr hg) + have h1 := h.evalOdd_flatMap_perm μ + (F.coreOddPairFn (prodRel κ₁ κ₂) (joinCore φ₁ φ₂)) + (fun _ => rfl) hstep [] + simp only [List.nil_append] at h1 + refine h1.trans (congrArg (h.evalOdd μ) ?_) + refine Eq.trans (congrArg + (fun l' => l'.flatMap + (F.coreOddPairFn (prodRel κ₁ κ₂) (joinCore φ₁ φ₂))) + (List.pmap_map _)) ?_ + exact pmap_flatMap_congr' _ _ _ _ _ _ _ + (fun a ha h₁ h₂ => coreOddPairFn_join_inr φ₁ φ₂ a h₁ h₂) + +/-! ### The colouring-sum factorization -/ + +/-- The even-colouring equivalence is the join. -/ +theorem joinEvenEquiv_apply {k : ℕ} + (ψ₁ : (leftSub F).EvenColouring k) + (ψ₂ : (rightSub F).EvenColouring k) : + joinEvenEquiv F k (ψ₁, ψ₂) = joinEven ψ₁ ψ₂ := rfl + +/-- The core-colouring equivalence is the join. -/ +theorem joinCoreEquiv_apply {ℓ : ℕ} + (φ₁ : (leftSub F).CoreOddColouring ℓ) + (φ₂ : (rightSub F).CoreOddColouring ℓ) : + joinCoreEquiv F ℓ (φ₁, φ₂) = joinCore φ₁ φ₂ := rfl + +/-- A product over the union's vertices splits into the two +components' products. -/ +theorem prod_vertex_split + (X : (W₁.disjUnion W₂).Vertex → ℂ) : + ∏ v : (W₁.disjUnion W₂).Vertex, X v = + (∏ v : W₁.Vertex, X (Sum.inl v)) * + ∏ v : W₂.Vertex, X (Sum.inr v) := + Fintype.prod_sum_type X + +open scoped Classical in +/-- **The colouring sum factors**: a colouring of the union is a +pair of componentwise colourings, and the summand is their +product. -/ +theorem colouringSum_split {k ℓ : ℕ} + (h : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ (α ⊕ β)) + (hbnd : genBoundarySubsetMatches (W₁.disjUnion W₂) F.flags st) + (hbnd₁ : genBoundarySubsetMatches W₁ (leftSub F).flags + (fun a => st (Sum.inl a))) + (hbnd₂ : genBoundarySubsetMatches W₂ (rightSub F).flags + (fun b => st (Sum.inr b))) + {κ₁ : (leftSub F).RelTransitionSystem} + {κ₂ : (rightSub F).RelTransitionSystem} + (o₁ : κ₁.Orientation) (o₂ : κ₂.Orientation) : + (∑ ψ : F.EvenColouring k, + if genEvenBoundaryMatch F st hbnd ψ then + (∑ φ : F.CoreOddColouring ℓ, + if F.coreOddBoundaryMatch st φ then + ∏ v : (W₁.disjUnion W₂).Vertex, + ((F.coreOddSignAt (prodOrient o₁ o₂) φ v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) + (F.coreOddListAt (prodOrient o₁ o₂) φ v)) + else 0) + else 0) = + (∑ ψ : (leftSub F).EvenColouring k, + if genEvenBoundaryMatch (leftSub F) (fun a => st (Sum.inl a)) + hbnd₁ ψ then + (∑ φ : (leftSub F).CoreOddColouring ℓ, + if (leftSub F).coreOddBoundaryMatch + (fun a => st (Sum.inl a)) φ then + ∏ v : W₁.Vertex, + (((leftSub F).coreOddSignAt o₁ φ v : ℂ) * + h.evalOdd ((leftSub F).evenColoursAt ψ v) + ((leftSub F).coreOddListAt o₁ φ v)) + else 0) + else 0) * + (∑ ψ : (rightSub F).EvenColouring k, + if genEvenBoundaryMatch (rightSub F) (fun b => st (Sum.inr b)) + hbnd₂ ψ then + (∑ φ : (rightSub F).CoreOddColouring ℓ, + if (rightSub F).coreOddBoundaryMatch + (fun b => st (Sum.inr b)) φ then + ∏ v : W₂.Vertex, + (((rightSub F).coreOddSignAt o₂ φ v : ℂ) * + h.evalOdd ((rightSub F).evenColoursAt ψ v) + ((rightSub F).coreOddListAt o₂ φ v)) + else 0) + else 0) := by + rw [← Equiv.sum_comp (joinEvenEquiv F k), Fintype.sum_prod_type, + Fintype.sum_mul_sum] + refine Finset.sum_congr rfl fun ψ₁ _ => ?_ + refine Finset.sum_congr rfl fun ψ₂ _ => ?_ + rw [joinEvenEquiv_apply] + by_cases hP₁ : genEvenBoundaryMatch (leftSub F) + (fun a => st (Sum.inl a)) hbnd₁ ψ₁ + · by_cases hP₂ : genEvenBoundaryMatch (rightSub F) + (fun b => st (Sum.inr b)) hbnd₂ ψ₂ + · rw [ite_eq_left ((genEvenBoundaryMatch_join hbnd hbnd₁ hbnd₂ + ψ₁ ψ₂).mpr ⟨hP₁, hP₂⟩), ite_eq_left hP₁, ite_eq_left hP₂] + rw [← Equiv.sum_comp (joinCoreEquiv F ℓ), + Fintype.sum_prod_type, Fintype.sum_mul_sum] + refine Finset.sum_congr rfl fun φ₁ _ => ?_ + refine Finset.sum_congr rfl fun φ₂ _ => ?_ + rw [joinCoreEquiv_apply] + by_cases hQ₁ : (leftSub F).coreOddBoundaryMatch + (fun a => st (Sum.inl a)) φ₁ + · by_cases hQ₂ : (rightSub F).coreOddBoundaryMatch + (fun b => st (Sum.inr b)) φ₂ + · rw [ite_eq_left ((coreOddBoundaryMatch_join φ₁ φ₂).mpr + ⟨hQ₁, hQ₂⟩), ite_eq_left hQ₁, ite_eq_left hQ₂] + refine Eq.trans (prod_vertex_split _) ?_ + refine congrArg₂ (· * ·) ?_ ?_ + · refine Finset.prod_congr rfl fun v _ => ?_ + rw [coreOddSignAt_join_inl o₁ o₂ φ₁ φ₂ v, + evenColoursAt_join_inl ψ₁ ψ₂ v, + evalOdd_coreOddListAt_join_inl h _ o₁ o₂ φ₁ φ₂ v] + · refine Finset.prod_congr rfl fun v _ => ?_ + rw [coreOddSignAt_join_inr o₁ o₂ φ₁ φ₂ v, + evenColoursAt_join_inr ψ₁ ψ₂ v, + evalOdd_coreOddListAt_join_inr h _ o₁ o₂ φ₁ φ₂ v] + · rw [ite_eq_right (fun hu => hQ₂ + ((coreOddBoundaryMatch_join φ₁ φ₂).mp hu).2), + ite_eq_right hQ₂, mul_zero] + · rw [ite_eq_right (fun hu => hQ₁ + ((coreOddBoundaryMatch_join φ₁ φ₂).mp hu).1), + ite_eq_right hQ₁, zero_mul] + · rw [ite_eq_right (fun hu => hP₂ + ((genEvenBoundaryMatch_join hbnd hbnd₁ hbnd₂ + ψ₁ ψ₂).mp hu).2), + ite_eq_right hP₂, mul_zero] + · rw [ite_eq_right (fun hu => hP₁ + ((genEvenBoundaryMatch_join hbnd hbnd₁ hbnd₂ + ψ₁ ψ₂).mp hu).1), + ite_eq_right hP₁, zero_mul] + +end ColourSplit + +/-! ## The subset-sum factorization -/ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/C.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/C.lean new file mode 100644 index 0000000000..9d228d19fc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/C.lean @@ -0,0 +1,146 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.B + +/-! +# The disjoint union: canonical migration + +Migrating canonical data between a union and its components. +-/ + +@[expose] public section + +namespace RS + + + +/-! ## The canonical-value migration + +The corrected (canonical) constrained value pins a path-canonical +orientation and weights it by the Pfaffian chord-diagram sign. The +factorization migrates: the product of two path-canonical component +orientations is path-canonical for the union (chains stay +componentwise), and cross-component chords never interleave under +any order placing every left label below every right label, so the +crossing count — hence the path sign — is additive. -/ + +section CanonMigration + +open EdgeSubset + +variable {α β : Type} + +/-! ### Boundary membership over the union -/ + +open scoped Classical in +/-- Being a boundary flag is componentwise on the left. -/ +theorem inl_mem_boundary + {W₁ : Fragment α} {W₂ : Fragment β} {F : EdgeSubset (W₁.disjUnion W₂)} + {g : W₁.Flag} : + (Sum.inl g : (W₁.disjUnion W₂).Flag) ∈ F.boundaryFlags ↔ + g ∈ (leftSub F).boundaryFlags := by + constructor + · intro h + obtain ⟨hf, hl⟩ := Finset.mem_filter.mp h + exact Finset.mem_filter.mpr + ⟨mem_leftSub_flags.mpr hf, attach_inl_label_iff.mp hl⟩ + · intro h + obtain ⟨hf, hl⟩ := Finset.mem_filter.mp h + exact Finset.mem_filter.mpr + ⟨mem_leftSub_flags.mp hf, attach_inl_label_iff.mpr hl⟩ + +open scoped Classical in +/-- And on the right. -/ +theorem inr_mem_boundary + {W₁ : Fragment α} {W₂ : Fragment β} {F : EdgeSubset (W₁.disjUnion W₂)} + {g : W₂.Flag} : + (Sum.inr g : (W₁.disjUnion W₂).Flag) ∈ F.boundaryFlags ↔ + g ∈ (rightSub F).boundaryFlags := by + constructor + · intro h + obtain ⟨hf, hl⟩ := Finset.mem_filter.mp h + exact Finset.mem_filter.mpr + ⟨mem_rightSub_flags.mpr hf, attach_inr_label_iff.mp hl⟩ + · intro h + obtain ⟨hf, hl⟩ := Finset.mem_filter.mp h + exact Finset.mem_filter.mpr + ⟨mem_rightSub_flags.mp hf, attach_inr_label_iff.mpr hl⟩ + +/-! ### The path match of the product system is componentwise -/ + +open scoped Classical in +/-- A left boundary flag's chain stays left, so the product +system's path matching is the left component's. -/ +theorem pathMatch_prodRel_inl + {W₁ : Fragment α} {W₂ : Fragment β} + {F : EdgeSubset (W₁.disjUnion W₂)} + (κ₁ : (leftSub F).RelTransitionSystem) + (κ₂ : (rightSub F).RelTransitionSystem) + {g : W₁.Flag} + (hb : (Sum.inl g : (W₁.disjUnion W₂).Flag) ∈ F.boundaryFlags) + (hb' : g ∈ (leftSub F).boundaryFlags) : + (prodRel (F := F) κ₁ κ₂).pathMatch (Sum.inl g) hb = + Sum.inl (κ₁.pathMatch g hb') := by + obtain ⟨k, -, hcont, hpm⟩ := pathMatch_chain_length κ₁ hb' + have hterm : W₁.pairing (iterWalk κ₁ g k) ∈ + (leftSub F).boundaryFlags := by + rw [← hpm] + exact κ₁.pathMatch_mem hb' + have hcontU : ∀ t, t < k → + (W₁.disjUnion W₂).pairing + (iterWalk (prodRel (F := F) κ₁ κ₂) (Sum.inl g) t) ∈ + F.internalFlags := by + intro t ht + rw [iterWalk_prodRel_inl κ₁ κ₂ g t, pairing_inl] + exact inl_mem_internal.mpr (hcont t ht) + have htermU : (W₁.disjUnion W₂).pairing + (iterWalk (prodRel (F := F) κ₁ κ₂) (Sum.inl g) k) ∈ + F.boundaryFlags := by + rw [iterWalk_prodRel_inl κ₁ κ₂ g k, pairing_inl] + exact inl_mem_boundary.mpr hterm + refine (pathMatch_eq_of_chain (prodRel (F := F) κ₁ κ₂) hb + hcontU htermU).trans ?_ + rw [iterWalk_prodRel_inl κ₁ κ₂ g k, pairing_inl, hpm] + +open scoped Classical in +/-- And likewise on the right. -/ +theorem pathMatch_prodRel_inr + {W₁ : Fragment α} {W₂ : Fragment β} + {F : EdgeSubset (W₁.disjUnion W₂)} + (κ₁ : (leftSub F).RelTransitionSystem) + (κ₂ : (rightSub F).RelTransitionSystem) + {g : W₂.Flag} + (hb : (Sum.inr g : (W₁.disjUnion W₂).Flag) ∈ F.boundaryFlags) + (hb' : g ∈ (rightSub F).boundaryFlags) : + (prodRel (F := F) κ₁ κ₂).pathMatch (Sum.inr g) hb = + Sum.inr (κ₂.pathMatch g hb') := by + obtain ⟨k, -, hcont, hpm⟩ := pathMatch_chain_length κ₂ hb' + have hterm : W₂.pairing (iterWalk κ₂ g k) ∈ + (rightSub F).boundaryFlags := by + rw [← hpm] + exact κ₂.pathMatch_mem hb' + have hcontU : ∀ t, t < k → + (W₁.disjUnion W₂).pairing + (iterWalk (prodRel (F := F) κ₁ κ₂) (Sum.inr g) t) ∈ + F.internalFlags := by + intro t ht + rw [iterWalk_prodRel_inr κ₁ κ₂ g t, pairing_inr] + exact inr_mem_internal.mpr (hcont t ht) + have htermU : (W₁.disjUnion W₂).pairing + (iterWalk (prodRel (F := F) κ₁ κ₂) (Sum.inr g) k) ∈ + F.boundaryFlags := by + rw [iterWalk_prodRel_inr κ₁ κ₂ g k, pairing_inr] + exact inr_mem_boundary.mpr hterm + refine (pathMatch_eq_of_chain (prodRel (F := F) κ₁ κ₂) hb + hcontU htermU).trans ?_ + rw [iterWalk_prodRel_inr κ₁ κ₂ g k, pairing_inr, hpm] + +end CanonMigration + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionProduct.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionProduct.lean new file mode 100644 index 0000000000..74e72784aa --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionProduct.lean @@ -0,0 +1,131 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.TheoremQuant +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceOrderIso +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor +public import LeanPool.RegtsSevenster.RS.StatementConverse +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughEdgeCut +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedCutDispatch +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedAgreement + +/-! +# The final chain: assembling the factorization + +The closing assembly of the converse, built entirely from +unconditional inputs: the **closed identification**. On a closed +fragment every subset is all-internal, so its chord diagram is +empty (`labelChords_of_allInternal`) — one fibre — and the +canonical choice value agrees with the choice-free Definition 5 +value (`EdgeSubset.throughValueC_eq_mixedValue`). Independence +across boundary pairings is not needed, there being no boundary. +-/ + +@[expose] public section + +namespace RS + + + +/-! ## The closed identification, unconditional -/ + +/-- The canonical constrained value agrees with the Definition 5 +value on closed Eulerian subsets — unconditionally: closed chord +diagrams are empty, so all canonical data share one fibre. -/ +theorem EdgeSubset.throughValueC_eq_mixedValue {W : ClosedFragment} + (F : EdgeSubset W) {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ (Fin 0)) + (hbnd : genBoundarySubsetMatches W F.flags st) + (hE : F.Eulerian) + (hint : ∀ f ∈ F.flags, + ∃ v : W.Vertex, W.attach f = Sum.inl v) : + F.throughValueC h st hbnd = F.mixedValue h := by + obtain ⟨⟨κ, o⟩⟩ := F.exists_transition_orientation hE hint + have hcanon : EdgeSubset.PathCanonical o.toRel := + EdgeSubset.pathCanonical_of_allInternal + (F.allInternal_of_closed) _ + have hne : Nonempty F.CanonData := + ⟨⟨κ.toRelTransitionSystem, o.toRel, hcanon⟩⟩ + calc F.throughValueC h st hbnd + = F.signedValueAt h st hbnd (Classical.choice hne).1 := + F.throughValueC_eq_signedValueAt h st hbnd hne + _ = F.signedValueAt h st hbnd κ.toRelTransitionSystem := + F.signedValueAt_of_labelChords_eq_pairing h st hbnd + (by rw [EdgeSubset.labelChords_of_allInternal + (F.allInternal_of_closed), + EdgeSubset.labelChords_of_allInternal + (F.allInternal_of_closed)]) + _ = EdgeSubset.pathSign κ.toRelTransitionSystem * + F.throughSummand h st hbnd o.toRel + κ.toRelTransitionSystem.openCircuitCount := + EdgeSubset.signedValueAt_eq h st hbnd o.toRel hcanon + _ = F.mixedSummand h o := by + rw [EdgeSubset.pathSign_of_allInternal + (F.allInternal_of_closed), one_mul] + exact F.throughSummand_eq_mixedSummand h st hbnd o + _ = F.mixedValue h := + (EdgeSubset.mixedValue_eq_summand_open F h o).symm + +/-! ## Membership characterizations (any fragment) -/ + +/-- Membership in the internal flags, unfolded: a participating flag +attached to a vertex. -/ +theorem mem_internalFlags_iff {γ : Type} {W : Fragment γ} + {F : EdgeSubset W} {f : W.Flag} : + f ∈ F.internalFlags ↔ f ∈ F.flags ∧ + ∃ v : W.Vertex, W.attach f = Sum.inl v := by + classical + exact Finset.mem_filter + +/-! ## The canonical-value migration + +The corrected (canonical) constrained value pins a path-canonical +orientation and weights it by the Pfaffian chord-diagram sign. The +factorization migrates: the product of two path-canonical component +orientations is path-canonical for the union (chains stay +componentwise), and cross-component chords never interleave under +any order placing every left label below every right label, so the +crossing count — hence the path sign — is additive. -/ + +section CanonMigration + +open EdgeSubset + +variable {α β : Type} + +/-! ### The product system's chain matching -/ + +/-- The boundary label of a left-summand boundary flag. -/ +theorem boundaryLabel_inl + {W₁ : Fragment α} {W₂ : Fragment β} {F : EdgeSubset (W₁.disjUnion W₂)} + {g : W₁.Flag} + (hb : (Sum.inl g : (W₁.disjUnion W₂).Flag) ∈ F.boundaryFlags) + (hb' : g ∈ (leftSub F).boundaryFlags) : + F.boundaryLabel hb = Sum.inl ((leftSub F).boundaryLabel hb') := by + refine EdgeSubset.boundaryLabel_eq_of_attach hb ?_ + change ((W₁.attach g).map Sum.inl Sum.inl) = + Sum.inr (Sum.inl ((leftSub F).boundaryLabel hb')) + rw [EdgeSubset.attach_boundaryLabel hb'] + rfl + +/-- The boundary label of a right-summand boundary flag. -/ +theorem boundaryLabel_inr + {W₁ : Fragment α} {W₂ : Fragment β} {F : EdgeSubset (W₁.disjUnion W₂)} + {g : W₂.Flag} + (hb : (Sum.inr g : (W₁.disjUnion W₂).Flag) ∈ F.boundaryFlags) + (hb' : g ∈ (rightSub F).boundaryFlags) : + F.boundaryLabel hb = Sum.inr ((rightSub F).boundaryLabel hb') := by + refine EdgeSubset.boundaryLabel_eq_of_attach hb ?_ + change ((W₂.attach g).map Sum.inr Sum.inr) = + Sum.inr (Sum.inr ((rightSub F).boundaryLabel hb')) + rw [EdgeSubset.attach_boundaryLabel hb'] + rfl + +end CanonMigration + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeColouring.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeColouring.lean new file mode 100644 index 0000000000..7db8d349dc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeColouring.lean @@ -0,0 +1,436 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexSum +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordLabels + +/-! +# Colourings of the whole subset + +RS21 colours every edge of the Eulerian subset: `φ : H → [2ℓ]`. +The edges of `H` with an end at an unlabelled vertex are the ones +the vertex product sees; the edges with both ends labelled are seen +only by the boundary vectors. Both kinds are coloured, and the +colouring is one object. + +This file is that object, and its restriction to the edges the +vertex product sees. The restriction is a map between colouring +types, stated here so that the split the flag model makes is a +theorem about `EdgeOddColouring` rather than a definition in its +own right. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + + + +variable {α : Type} + +/-- **RS21's odd colouring**: a colour on every edge of the subset, +constant on the two flags of an edge. -/ +def EdgeOddColouring {W : Fragment α} + (F : EdgeSubset W) (ℓ : ℕ) : Type := + {φ : {f : W.Flag // f ∈ F.flags} → Fin (2 * ℓ) // + ∀ f : {f : W.Flag // f ∈ F.flags}, + φ ⟨W.pairing f.val, F.pairing_mem f.val f.prop⟩ = φ f} + +open scoped Classical in +/-- Edge odd colourings are finite in number. -/ +noncomputable instance EdgeOddColouring.instFintype {W : Fragment α} + (F : EdgeSubset W) (ℓ : ℕ) : Fintype (F.EdgeOddColouring ℓ) := by + unfold EdgeOddColouring + infer_instance + +/-- The colouring restricted to the edges with an end at a vertex — +the ones the vertex product reads. -/ +noncomputable def EdgeOddColouring.core {W : Fragment α} + {F : EdgeSubset W} {ℓ : ℕ} + (φ : F.EdgeOddColouring ℓ) : F.CoreOddColouring ℓ := + ⟨fun f => φ.val ⟨f.val, coreFlags_subset F f.prop⟩, + fun f => φ.prop ⟨f.val, coreFlags_subset F f.prop⟩⟩ + +/-- **The colour of an edge is the colour of either of its +flags.** -/ +theorem EdgeOddColouring.pairing {W : Fragment α} + {F : EdgeSubset W} {ℓ : ℕ} + (φ : F.EdgeOddColouring ℓ) (f : {f : W.Flag // f ∈ F.flags}) : + φ.val ⟨W.pairing f.val, F.pairing_mem f.val f.prop⟩ = φ.val f := + φ.prop f + +/-- **The boundary constraint** `φ ∼ χ₁`: at a used label the +colouring agrees with the state. -/ +def edgeOddBoundaryMatch {W : Fragment α} + {k ℓ : ℕ} (F : EdgeSubset W) + (st : GenBoundaryState k ℓ α) (φ : F.EdgeOddColouring ℓ) : + Prop := + ∀ (i : α) (c : Fin (2 * ℓ)) (_ : st i = Sum.inr c) + (hmem : W.boundaryFlag i ∈ F.flags), + φ.val ⟨W.boundaryFlag i, hmem⟩ = c + +/-! ### The colour a used flag is pinned to + +On the support of the state every used label is odd, so a boundary +flag of the subset has a colour, and `φ ∼ χ₁` pins the colouring to +it. Naming that colour is what lets a core colouring be extended +back over the through-edges. +-/ + +open Classical in +/-- The odd colour the state carries at a boundary flag of the +subset. -/ +noncomputable def usedColour {W : Fragment α} + {k ℓ : ℕ} (F : EdgeSubset W) + (χ : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags χ) {f : W.Flag} + (hb : f ∈ F.boundaryFlags) : Fin (2 * ℓ) := + Classical.choose ((hbnd (F.boundaryLabel hb)).mp (by + rw [boundaryFlag_boundaryLabel hb] + exact mem_flags_of_boundaryFlags F hb)) + +open Classical in +/-- The named colour is the state's. -/ +theorem usedColour_spec {W : Fragment α} + {k ℓ : ℕ} (F : EdgeSubset W) + (χ : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags χ) {f : W.Flag} + (hb : f ∈ F.boundaryFlags) : + χ (F.boundaryLabel hb) = Sum.inr (usedColour F χ hbnd hb) := + Classical.choose_spec ((hbnd (F.boundaryLabel hb)).mp (by + rw [boundaryFlag_boundaryLabel hb] + exact mem_flags_of_boundaryFlags F hb)) + +open Classical in +/-- **A matching colouring takes the named colour at every used +flag.** -/ +theorem edgeOddColouring_eq_usedColour {W : Fragment α} + {k ℓ : ℕ} {F : EdgeSubset W} + {χ : GenBoundaryState k ℓ α} + (hbnd : genBoundarySubsetMatches W F.flags χ) + {φ : F.EdgeOddColouring ℓ} (hφ : edgeOddBoundaryMatch F χ φ) + {f : W.Flag} (hb : f ∈ F.boundaryFlags) : + φ.val ⟨f, mem_flags_of_boundaryFlags F hb⟩ + = usedColour F χ hbnd hb := by + have hbf := boundaryFlag_boundaryLabel hb + have hmem : W.boundaryFlag (F.boundaryLabel hb) ∈ F.flags := by + rw [hbf] + exact mem_flags_of_boundaryFlags F hb + have h1 := hφ (F.boundaryLabel hb) (usedColour F χ hbnd hb) + (usedColour_spec F χ hbnd hb) hmem + rw [← h1] + exact congrArg φ.val (Subtype.ext hbf.symm) + +/-! ### The restriction is injective on matching colourings + +Every flag of the subset either has an end at a vertex — and is +then read by the restriction — or has both ends labelled, and is +then pinned by `φ ∼ χ₁`. So two matching colourings with the same +restriction agree. +-/ + +/-- A flag the restriction forgets is a boundary flag. -/ +theorem mem_boundaryFlags_of_not_coreFlags {W : Fragment α} + (F : EdgeSubset W) + {f : W.Flag} (hf : f ∈ F.flags) (hc : f ∉ F.coreFlags) : + f ∈ F.boundaryFlags := by + refine (mem_internalFlags_or_boundaryFlags F hf).resolve_left ?_ + intro hint + refine hc (mem_coreFlags_iff F |>.mpr ⟨hf, Or.inl ?_⟩) + obtain ⟨-, v, hv⟩ := EdgeSubset.mem_internalFlags_iff.mp hint + exact ⟨v, hv⟩ + +open Classical in +/-- **Two matching colourings with the same restriction are +equal.** -/ +theorem edgeOddColouring_ext {W : Fragment α} + {k ℓ : ℕ} {F : EdgeSubset W} + {χ : GenBoundaryState k ℓ α} + (hbnd : genBoundarySubsetMatches W F.flags χ) + {φ₁ φ₂ : F.EdgeOddColouring ℓ} + (h₁ : edgeOddBoundaryMatch F χ φ₁) + (h₂ : edgeOddBoundaryMatch F χ φ₂) + (hcore : φ₁.core = φ₂.core) : φ₁ = φ₂ := by + refine Subtype.ext (funext fun f => ?_) + by_cases hc : f.val ∈ F.coreFlags + · have h := congrArg Subtype.val hcore + have hf := congrFun h ⟨f.val, hc⟩ + have he : (⟨f.val, coreFlags_subset F hc⟩ : + {g : W.Flag // g ∈ F.flags}) = f := Subtype.ext rfl + rw [← he] + exact hf + · have hb := mem_boundaryFlags_of_not_coreFlags F f.prop hc + have e₁ := edgeOddColouring_eq_usedColour hbnd h₁ hb + have e₂ := edgeOddColouring_eq_usedColour hbnd h₂ hb + have hfe : (⟨f.val, mem_flags_of_boundaryFlags F hb⟩ : + {g : W.Flag // g ∈ F.flags}) = f := Subtype.ext rfl + rw [hfe] at e₁ e₂ + rw [e₁, e₂] + +/-! ### Extending a core colouring over the through-edges + +A core colouring is extended by giving each through-edge the colour +the state already carries at its two labelled ends. That is well +defined exactly because those two ends agree, which is what `φ ∼ χ₁` +forces of any colouring of the whole subset. +-/ + +/-- The flags the restriction forgets are closed under the +pairing. -/ +theorem not_coreFlags_pairing {W : Fragment α} + (F : EdgeSubset W) {f : W.Flag} + (hf : f ∈ F.flags) (hc : f ∉ F.coreFlags) : + W.pairing f ∉ F.coreFlags := by + intro hx + refine hc ((mem_coreFlags_iff F).mpr ⟨hf, ?_⟩) + obtain ⟨-, hd⟩ := (mem_coreFlags_iff F).mp hx + rcases hd with ⟨v, hv⟩ | ⟨v, hv⟩ + · exact Or.inr ⟨v, hv⟩ + · rw [W.pairing_invol] at hv + exact Or.inl ⟨v, hv⟩ + +/-- **The agreement condition**: at a through-edge the state's two +legs carry one colour. -/ +def ThroughAgree {W : Fragment α} + {k ℓ : ℕ} (F : EdgeSubset W) + (χ : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags χ) : Prop := + ∀ (f : W.Flag) (hb : f ∈ F.boundaryFlags) + (hbp : W.pairing f ∈ F.boundaryFlags), + usedColour F χ hbnd hbp = usedColour F χ hbnd hb + +/-- Agreement reads only the state. -/ +theorem throughAgree_congr {W : Fragment α} + {k ℓ : ℕ} {F : EdgeSubset W} + {χ χ' : GenBoundaryState k ℓ α} (hcc : χ = χ') + (hbnd : genBoundarySubsetMatches W F.flags χ) + (hbnd' : genBoundarySubsetMatches W F.flags χ') : + ThroughAgree F χ hbnd ↔ ThroughAgree F χ' hbnd' := by + subst hcc + exact Iff.rfl + +/-- The named colour reads only the state's value at the label. -/ +theorem usedColour_congr {W : Fragment α} + {k ℓ : ℕ} {F : EdgeSubset W} + {χ χ' : GenBoundaryState k ℓ α} + (hbnd : genBoundarySubsetMatches W F.flags χ) + (hbnd' : genBoundarySubsetMatches W F.flags χ') + {f : W.Flag} (hb : f ∈ F.boundaryFlags) + (heq : χ (F.boundaryLabel hb) = χ' (F.boundaryLabel hb)) : + usedColour F χ hbnd hb = usedColour F χ' hbnd' hb := by + have h1 := usedColour_spec F χ hbnd hb + have h2 := usedColour_spec F χ' hbnd' hb + rw [heq, h2] at h1 + exact (Sum.inr.inj h1).symm + +/-- **Agreement reads only the through-edges' labels.** Two states +that agree there agree on the condition. -/ +theorem throughAgree_of_eq_on_through {W : Fragment α} + {k ℓ : ℕ} {F : EdgeSubset W} + {χ χ' : GenBoundaryState k ℓ α} + (hbnd : genBoundarySubsetMatches W F.flags χ) + (hbnd' : genBoundarySubsetMatches W F.flags χ') + (heq : ∀ (f : W.Flag) (hb : f ∈ F.boundaryFlags), + W.pairing f ∈ F.boundaryFlags → + χ (F.boundaryLabel hb) = χ' (F.boundaryLabel hb)) + (hag : ThroughAgree F χ hbnd) : ThroughAgree F χ' hbnd' := by + intro f hb hbp + have hpp : W.pairing (W.pairing f) ∈ F.boundaryFlags := by + rw [W.pairing_invol]; exact hb + rw [← usedColour_congr hbnd hbnd' hbp (heq _ hbp hpp), + ← usedColour_congr hbnd hbnd' hb (heq f hb hbp)] + exact hag f hb hbp + +/-- **Only agreeing states are coloured at all.** A colouring of +the whole subset carries one colour on each edge, and `φ ∼ χ₁` pins +it at both labelled ends of a through-edge; so a state whose two +legs there disagree admits no colouring. -/ +theorem throughAgree_of_edgeOddBoundaryMatch {W : Fragment α} + {k ℓ : ℕ} + {F : EdgeSubset W} {χ : GenBoundaryState k ℓ α} + (hbnd : genBoundarySubsetMatches W F.flags χ) + {φ : F.EdgeOddColouring ℓ} (hφ : edgeOddBoundaryMatch F χ φ) : + ThroughAgree F χ hbnd := by + intro f hb hbp + have hbf : W.boundaryFlag (F.boundaryLabel hb) = f := + boundaryFlag_boundaryLabel hb + have hbf' : W.boundaryFlag (F.boundaryLabel hbp) = W.pairing f := + boundaryFlag_boundaryLabel hbp + have hmi : W.boundaryFlag (F.boundaryLabel hb) ∈ F.flags := by + rw [hbf]; exact mem_flags_of_boundaryFlags F hb + have hmj : W.boundaryFlag (F.boundaryLabel hbp) ∈ F.flags := by + rw [hbf']; exact mem_flags_of_boundaryFlags F hbp + have h1 : φ.val ⟨W.boundaryFlag (F.boundaryLabel hb), hmi⟩ + = usedColour F χ hbnd hb := + hφ _ _ (usedColour_spec F χ hbnd hb) hmi + have h2 : φ.val ⟨W.boundaryFlag (F.boundaryLabel hbp), hmj⟩ + = usedColour F χ hbnd hbp := + hφ _ _ (usedColour_spec F χ hbnd hbp) hmj + have heq : (⟨W.boundaryFlag (F.boundaryLabel hbp), hmj⟩ : + {g : W.Flag // g ∈ F.flags}) + = ⟨W.pairing (W.boundaryFlag (F.boundaryLabel hb)), + F.pairing_mem _ hmi⟩ := + Subtype.ext (show W.boundaryFlag (F.boundaryLabel hbp) + = W.pairing (W.boundaryFlag (F.boundaryLabel hb)) by + rw [hbf', hbf]) + rw [← h1, ← h2, heq] + exact φ.prop ⟨W.boundaryFlag (F.boundaryLabel hb), hmi⟩ + +open Classical in +/-- The extension's value: the core colouring where it is defined, +and the state's own colour on a through-edge. -/ +noncomputable def extendFun {W : Fragment α} + {k ℓ : ℕ} {F : EdgeSubset W} + {χ : GenBoundaryState k ℓ α} + (hbnd : genBoundarySubsetMatches W F.flags χ) + (φ' : F.CoreOddColouring ℓ) : + {f : W.Flag // f ∈ F.flags} → Fin (2 * ℓ) := + fun f => + if hc : f.val ∈ F.coreFlags then φ'.val ⟨f.val, hc⟩ + else usedColour F χ hbnd + (mem_boundaryFlags_of_not_coreFlags F f.prop hc) + +open Classical in +/-- The extension is constant on the two flags of an edge. -/ +theorem extendFun_pairing {W : Fragment α} + {k ℓ : ℕ} {F : EdgeSubset W} + {χ : GenBoundaryState k ℓ α} + (hbnd : genBoundarySubsetMatches W F.flags χ) + (hag : ThroughAgree F χ hbnd) (φ' : F.CoreOddColouring ℓ) + (f : {f : W.Flag // f ∈ F.flags}) : + extendFun hbnd φ' ⟨W.pairing f.val, F.pairing_mem f.val f.prop⟩ + = extendFun hbnd φ' f := by + unfold extendFun + by_cases hc : f.val ∈ F.coreFlags + · rw [dite_eq_left hc, dite_eq_left (F.pairing_mem_coreFlags hc)] + exact φ'.prop ⟨f.val, hc⟩ + · rw [dite_eq_right hc, dite_eq_right (not_coreFlags_pairing F f.prop hc)] + exact hag f.val _ _ + +open Classical in +/-- **Extend a core colouring over the through-edges.** -/ +noncomputable def CoreOddColouring.extend {W : Fragment α} + {k ℓ : ℕ} + {F : EdgeSubset W} {χ : GenBoundaryState k ℓ α} + (hbnd : genBoundarySubsetMatches W F.flags χ) + (hag : ThroughAgree F χ hbnd) (φ' : F.CoreOddColouring ℓ) : + F.EdgeOddColouring ℓ := + ⟨extendFun hbnd φ', extendFun_pairing hbnd hag φ'⟩ + +open Classical in +/-- **The extension restricts to what it extended.** -/ +theorem CoreOddColouring.core_extend {W : Fragment α} + {k ℓ : ℕ} {F : EdgeSubset W} + {χ : GenBoundaryState k ℓ α} + (hbnd : genBoundarySubsetMatches W F.flags χ) + (hag : ThroughAgree F χ hbnd) (φ' : F.CoreOddColouring ℓ) : + (CoreOddColouring.extend hbnd hag φ').core = φ' := by + refine Subtype.ext (funext fun f => ?_) + change extendFun hbnd φ' ⟨f.val, coreFlags_subset F f.prop⟩ + = φ'.val f + unfold extendFun + rw [dite_eq_left f.prop] + +/-- A matching colouring restricts to a matching core colouring. -/ +theorem coreOddBoundaryMatch_core {W : Fragment α} + {k ℓ : ℕ} {F : EdgeSubset W} + {χ : GenBoundaryState k ℓ α} {φ : F.EdgeOddColouring ℓ} + (hφ : edgeOddBoundaryMatch F χ φ) : + F.coreOddBoundaryMatch χ φ.core := by + intro i c hci hcore + exact hφ i c hci (coreFlags_subset F hcore) + +/-! ### The round trip + +The extension of a matching core colouring matches, and extending +a matching colouring's restriction returns it. With injectivity +this makes the restriction a bijection between the matching +colourings of the whole subset and those of its core. +-/ + +open Classical in +/-- **The extension matches the state.** -/ +theorem edgeOddBoundaryMatch_extend {W : Fragment α} + {k ℓ : ℕ} {F : EdgeSubset W} + {χ : GenBoundaryState k ℓ α} + (hbnd : genBoundarySubsetMatches W F.flags χ) + (hag : ThroughAgree F χ hbnd) {φ' : F.CoreOddColouring ℓ} + (hφ' : F.coreOddBoundaryMatch χ φ') : + edgeOddBoundaryMatch F χ + (CoreOddColouring.extend hbnd hag φ') := by + intro i c hci hmem + change extendFun hbnd φ' ⟨W.boundaryFlag i, hmem⟩ = c + unfold extendFun + by_cases hc : W.boundaryFlag i ∈ F.coreFlags + · rw [dite_eq_left hc] + exact hφ' i c hci hc + · rw [dite_eq_right hc] + have hb := mem_boundaryFlags_of_not_coreFlags F hmem hc + have hli : F.boundaryLabel hb = i := + boundaryLabel_eq_of_attach hb (W.attach_boundaryFlag i) + have hspec := usedColour_spec F χ hbnd hb + rw [hli, hci] at hspec + exact (Sum.inr.inj hspec).symm + +open Classical in +/-- **Extending a matching colouring's restriction returns it.** -/ +theorem extend_core {W : Fragment α} + {k ℓ : ℕ} {F : EdgeSubset W} + {χ : GenBoundaryState k ℓ α} + (hbnd : genBoundarySubsetMatches W F.flags χ) + (hag : ThroughAgree F χ hbnd) {φ : F.EdgeOddColouring ℓ} + (hφ : edgeOddBoundaryMatch F χ φ) : + CoreOddColouring.extend hbnd hag φ.core = φ := by + refine edgeOddColouring_ext hbnd ?_ hφ ?_ + · exact edgeOddBoundaryMatch_extend hbnd hag + (coreOddBoundaryMatch_core hφ) + · exact CoreOddColouring.core_extend hbnd hag φ.core + +/-! ### The sum over colourings of the whole subset + +The restriction being a bijection on the matching colourings, a sum +over RS21's colourings of all of `H` is a sum over the flag model's +colourings of its core. This is the theorem the flag model's split +rests on; nothing above it assumes the split. +-/ + +open Classical in +/-- **The colouring sum over the whole subset is the sum over its +core.** -/ +theorem sum_edgeOddColouring {W : Fragment α} + {k ℓ : ℕ} {F : EdgeSubset W} + {χ : GenBoundaryState k ℓ α} + (hbnd : genBoundarySubsetMatches W F.flags χ) + (hag : ThroughAgree F χ hbnd) (G : F.CoreOddColouring ℓ → ℂ) : + (∑ φ : F.EdgeOddColouring ℓ, + if edgeOddBoundaryMatch F χ φ then G φ.core else 0) + = ∑ φ' : F.CoreOddColouring ℓ, + if F.coreOddBoundaryMatch χ φ' then G φ' else 0 := by + rw [← Finset.sum_filter, ← Finset.sum_filter] + refine Finset.sum_nbij' (fun φ => φ.core) + (fun φ' => CoreOddColouring.extend hbnd hag φ') ?_ ?_ ?_ ?_ + ?_ + · intro φ hφ + exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, + coreOddBoundaryMatch_core (Finset.mem_filter.mp hφ).2⟩ + · intro φ' hφ' + exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, + edgeOddBoundaryMatch_extend hbnd hag + (Finset.mem_filter.mp hφ').2⟩ + · intro φ hφ + exact extend_core hbnd hag (Finset.mem_filter.mp hφ).2 + · intro φ' _ + exact CoreOddColouring.core_extend hbnd hag φ' + · intro φ _ + rfl + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeSum.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeSum.lean new file mode 100644 index 0000000000..460a2ddfde --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeSum.lean @@ -0,0 +1,98 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeColouring + +/-! +# RS21's colouring sum + +RS21 writes the tensor's colouring sum as + + Σ_{ψ ∼ χ₀, φ ∼ χ₁} ∏_{v ∈ V′(F)} h_v( … ), + +where `ψ` colours the edges outside `H` and `φ` colours the edges of +`H` — one colour per edge, both of them constrained at the labelled +ends by `χ`. That is the sum named here. + +The flag model's `vertexSum` instead colours the *core* edges only, +leaving the through-edges to the through-edge product. The two +agree exactly on the states whose two legs at a through-edge carry +one colour, and off those RS21's sum is empty: a colouring gives the +through-edge one colour and `φ ∼ χ₁` pins it at both ends. So +RS21's sum is the flag model's, cut down to the agreeing states — +which is what the pairing of two tensors computes. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + + + +variable {α : Type} + +open scoped Classical in +/-- **RS21's colouring sum** over the colourings of the whole +subset. -/ +noncomputable def edgeSum {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ : F.RelTransitionSystem} (o : κ.Orientation) : ℂ := + ∑ ψ : F.EvenColouring k, + if genEvenBoundaryMatch F st hbnd ψ then + ∑ φ : F.EdgeOddColouring ℓ, + if edgeOddBoundaryMatch F st φ then + ∏ v : W.Vertex, + ((F.coreOddSignAt o φ.core v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) + (F.coreOddListAt o φ.core v)) + else 0 + else 0 + +/-- **On an agreeing state RS21's sum is the flag model's.** -/ +theorem edgeSum_eq_vertexSum {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ : F.RelTransitionSystem} (o : κ.Orientation) + (hag : ThroughAgree F st hbnd) : + F.edgeSum h st hbnd o = F.vertexSum h st hbnd o := by + unfold edgeSum vertexSum + refine Finset.sum_congr rfl (fun ψ _ => ?_) + by_cases hev : genEvenBoundaryMatch F st hbnd ψ + · rw [ite_eq_left hev, ite_eq_left hev] + exact sum_edgeOddColouring hbnd hag + (fun φ' => ∏ v : W.Vertex, + ((F.coreOddSignAt o φ' v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) + (F.coreOddListAt o φ' v))) + · rw [ite_eq_right hev, ite_eq_right hev] + +/-- **A disagreeing state is coloured by nothing.** -/ +theorem edgeSum_eq_zero_of_not_throughAgree {W : Fragment α} + (F : EdgeSubset W) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ : F.RelTransitionSystem} (o : κ.Orientation) + (hag : ¬ ThroughAgree F st hbnd) : + F.edgeSum h st hbnd o = 0 := by + unfold edgeSum + refine Finset.sum_eq_zero (fun ψ _ => ?_) + by_cases hev : genEvenBoundaryMatch F st hbnd ψ + · rw [ite_eq_left hev] + exact Finset.sum_eq_zero (fun φ _ => ite_eq_right (fun hφ => + hag (throughAgree_of_edgeOddBoundaryMatch hbnd hφ))) + · rw [ite_eq_right hev] + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeTerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeTerm.lean new file mode 100644 index 0000000000..3d7dfe2f6f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeTerm.lean @@ -0,0 +1,1327 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourGlue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceContract + +/-! +# RS21's summand, at a prescribed circuit count + +`edgeSum` is RS21's colouring sum; `s_h(F,H,ω,κ)` is that sum with +the circuit sign in front. The composition carries its own count +from stage to stage — an open glue may or may not close a circuit, +and settling that is the ledger's business, not the colouring's — so +the summand is named here with the count as a parameter, extended by +zero off the good subsets, exactly as `termAt` is. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + +open Fragment +variable {L : Type} + +/-- Transporting the colouring sum along an equality of subsets. -/ +theorem edgeSum_relOfEq {V : Fragment L} + {F F' : EdgeSubset V} (hF : F = F') + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ L) + (hbnd : genBoundarySubsetMatches V F.flags st) + (hbnd' : genBoundarySubsetMatches V F'.flags st) + {κ : F.RelTransitionSystem} (o : κ.Orientation) : + F'.edgeSum h st hbnd' (orientOfEq hF o) + = F.edgeSum h st hbnd o := by + subst hF + rfl + +open Classical in +/-- **RS21's summand at a prescribed circuit count.** -/ +noncomputable def edgeTermAt [LinearOrder L] {V : Fragment L} + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (𝒟 : DataFamily V) (st : GenBoundaryState k ℓ L) + (s : Finset V.Flag) (C : ℕ) : ℂ := + if hc : ∀ f ∈ s, V.pairing f ∈ s then + if hbnd : genBoundarySubsetMatches V s st then + if hE : (EdgeSubset.mk s hc).Eulerian then + if hne : Nonempty (EdgeSubset.mk s hc).CanonData then + ((-1 : ℂ) ^ C) * + (EdgeSubset.mk s hc).edgeSum h st hbnd + (𝒟 s hc hE hne).2 + else 0 + else 0 + else 0 + else 0 + +open Classical in +/-- The summand vanishes off edge-closed flag sets. -/ +theorem edgeTermAt_eq_zero_of_not_closed [LinearOrder L] {V : Fragment L} + {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (𝒟 : DataFamily V) + (st : GenBoundaryState k ℓ L) {s : Finset V.Flag} + (hc : ¬ ∀ f ∈ s, V.pairing f ∈ s) (C : ℕ) : + edgeTermAt h 𝒟 st s C = 0 := by + unfold edgeTermAt + rw [dite_eq_right hc] + +open Classical in +/-- And off subsets that do not match the boundary state. -/ +theorem edgeTermAt_eq_zero_of_not_matches [LinearOrder L] {V : Fragment L} + {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (𝒟 : DataFamily V) + (st : GenBoundaryState k ℓ L) {s : Finset V.Flag} + (hbnd : ¬ genBoundarySubsetMatches V s st) (C : ℕ) : + edgeTermAt h 𝒟 st s C = 0 := by + unfold edgeTermAt + by_cases hc : ∀ f ∈ s, V.pairing f ∈ s + · rw [dite_eq_left hc, dite_eq_right hbnd] + · rw [dite_eq_right hc] + +open Classical in +/-- And off non-Eulerian subsets. -/ +theorem edgeTermAt_eq_zero_of_not_eulerian [LinearOrder L] {V : Fragment L} + {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (𝒟 : DataFamily V) + (st : GenBoundaryState k ℓ L) {s : Finset V.Flag} + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : ¬ (EdgeSubset.mk s hc).Eulerian) (C : ℕ) : + edgeTermAt h 𝒟 st s C = 0 := by + unfold edgeTermAt + rw [dite_eq_left hc] + by_cases hbnd : genBoundarySubsetMatches V s st + · rw [dite_eq_left hbnd, dite_eq_right hE] + · rw [dite_eq_right hbnd] + +open Classical in +/-- And off subsets carrying no canonical datum — so the sum runs +over the good subsets only. -/ +theorem edgeTermAt_eq_zero_of_not_canon [LinearOrder L] {V : Fragment L} + {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (𝒟 : DataFamily V) + (st : GenBoundaryState k ℓ L) {s : Finset V.Flag} + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hne : ¬ Nonempty (EdgeSubset.mk s hc).CanonData) (C : ℕ) : + edgeTermAt h 𝒟 st s C = 0 := by + unfold edgeTermAt + rw [dite_eq_left hc] + by_cases hbnd : genBoundarySubsetMatches V s st + · rw [dite_eq_left hbnd] + by_cases hE : (EdgeSubset.mk s hc).Eulerian + · rw [dite_eq_left hE, dite_eq_right hne] + · rw [dite_eq_right hE] + · rw [dite_eq_right hbnd] + +open Classical in +/-- The summand at a good subset. -/ +theorem edgeTermAt_pos [LinearOrder L] {V : Fragment L} + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (𝒟 : DataFamily V) (st : GenBoundaryState k ℓ L) + {s : Finset V.Flag} (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hbnd : genBoundarySubsetMatches V s st) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) (C : ℕ) : + edgeTermAt h 𝒟 st s C + = ((-1 : ℂ) ^ C) * + (EdgeSubset.mk s hc).edgeSum h st hbnd + (𝒟 s hc hE hne).2 := by + unfold edgeTermAt + rw [dite_eq_left hc, dite_eq_left hbnd, dite_eq_left hE, dite_eq_left hne] + +/-! ## One open cut + +The boundary state's colour at the cut is even exactly when the +subset misses it, so the sum over that colour runs over one block +and is the glued fragment's summand. +-/ + +section OpenCut + +/-- A missed cut admits no odd colour at the interface. -/ +theorem not_matches_liftOpen_odd_of_miss + {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + (hni : partnerSurvI hopen ∉ t) {k ℓ : ℕ} + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (d : Fin (2 * ℓ)) (c' : Fin k ⊕ Fin (2 * ℓ)) : + ¬ genBoundarySubsetMatches V (liftSubsetOpen hopen t) + (GenBoundaryState.extendPair i j st' (Sum.inr d) c') := by + intro hm + refine hni ((boundaryFlagI_mem_liftOpen_iff hij hopen t).mp + ((hm i).mpr ⟨d, ?_⟩)) + exact GenBoundaryState.extendPair_left st' _ _ + +/-- A carried cut admits no even colour at the interface. -/ +theorem not_matches_liftOpen_even_of_hit + {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + (hpi : partnerSurvI hopen ∈ t) {k ℓ : ℕ} + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (a : Fin k) (c' : Fin k ⊕ Fin (2 * ℓ)) : + ¬ genBoundarySubsetMatches V (liftSubsetOpen hopen t) + (GenBoundaryState.extendPair i j st' (Sum.inl a) c') := by + intro hm + obtain ⟨e, he⟩ := (hm i).mp + ((boundaryFlagI_mem_liftOpen_iff hij hopen t).mpr hpi) + rw [GenBoundaryState.extendPair_left] at he + exact absurd he (by simp) + +/-- On a missed cut the even extensions all match. -/ +theorem matches_liftOpen_of_miss {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + (hct : ∀ f ∈ t, (V.gluePairOpen i j hij hopen).pairing f ∈ t) + (hni : partnerSurvI hopen ∉ t) + {k ℓ : ℕ} (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (hbnd' : genBoundarySubsetMatches + (V.gluePairOpen i j hij hopen) t st') + (hcL : ∀ f ∈ liftSubsetOpen hopen t, + V.pairing f ∈ liftSubsetOpen hopen t) (a : Fin k) : + genBoundarySubsetMatches V (liftSubsetOpen hopen t) + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a)) := by + intro b + by_cases hbi : b = i + · subst hbi + rw [GenBoundaryState.extendPair_left, + boundaryFlagI_mem_liftOpen_iff hij hopen t] + exact ⟨fun hx => absurd hx hni, fun hx => absurd hx.choose_spec + (by simp)⟩ + · by_cases hbj : b = j + · subst hbj + rw [GenBoundaryState.extendPair_right hij, + boundaryFlagJ_mem_liftOpen_iff hij hopen t] + exact ⟨fun hx => absurd hx (partnerSurvJ_notMem_of hij hopen t + hct hni), + fun hx => absurd hx.choose_spec (by simp)⟩ + · have hst : GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a) b = st' ⟨b, hbi, hbj⟩ := + GenBoundaryState.extendPair_surviving st' _ _ + ⟨b, hbi, hbj⟩ + rw [show V.boundaryFlag b + = (glueBoundaryFlag V i j ⟨b, hbi, hbj⟩).val from rfl, + surviving_val_mem_liftOpen_iff hopen t, hst] + exact hbnd' ⟨b, hbi, hbj⟩ + +/-- On a carried cut the odd extensions all match. -/ +theorem matches_liftOpen_of_hit {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + (hct : ∀ f ∈ t, (V.gluePairOpen i j hij hopen).pairing f ∈ t) + (hpi : partnerSurvI hopen ∈ t) + {k ℓ : ℕ} (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (hbnd' : genBoundarySubsetMatches + (V.gluePairOpen i j hij hopen) t st') (d : Fin (2 * ℓ)) : + genBoundarySubsetMatches V (liftSubsetOpen hopen t) + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d)) := by + intro b + by_cases hbi : b = i + · subst hbi + rw [GenBoundaryState.extendPair_left, + boundaryFlagI_mem_liftOpen_iff hij hopen t] + exact ⟨fun _ => ⟨d, rfl⟩, fun _ => hpi⟩ + · by_cases hbj : b = j + · subst hbj + rw [GenBoundaryState.extendPair_right hij, + boundaryFlagJ_mem_liftOpen_iff hij hopen t] + exact ⟨fun _ => ⟨d, rfl⟩, fun _ => + partnerSurvJ_mem_of_hit hij hopen t hct hpi⟩ + · have hst : GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d) b = st' ⟨b, hbi, hbj⟩ := + GenBoundaryState.extendPair_surviving st' _ _ + ⟨b, hbi, hbj⟩ + rw [show V.boundaryFlag b + = (glueBoundaryFlag V i j ⟨b, hbi, hbj⟩).val from rfl, + surviving_val_mem_liftOpen_iff hopen t, hst] + exact hbnd' ⟨b, hbi, hbj⟩ + +open Classical in +/-- **The base's summand at an open lift** is the glued fragment's +data, unglued. -/ +theorem edgeTermAt_liftOpen + [LinearOrder L] {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + (hct : ∀ f ∈ t, (V.gluePairOpen i j hij hopen).pairing f ∈ t) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (𝒟' : DataFamily (V.gluePairOpen i j hij hopen)) + (hcL : ∀ f ∈ liftSubsetOpen hopen t, + V.pairing f ∈ liftSubsetOpen hopen t) + (st : GenBoundaryState k ℓ L) + (hbnd : genBoundarySubsetMatches V (liftSubsetOpen hopen t) + st) + (hE : (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).Eulerian) + (hne : Nonempty (EdgeSubset.mk (liftSubsetOpen hopen t) + hcL : EdgeSubset V).CanonData) + (hEt : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).CanonData) + (C : ℕ) : + edgeTermAt h (unglueDataOpen hij hopen 𝒟') st + (liftSubsetOpen hopen t) C + = ((-1 : ℂ) ^ C) * + (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).edgeSum h st hbnd + (unglueOrientationOpen hij hopen t hct hcL + (𝒟' t hct hEt hnet).1 (𝒟' t hct hEt hnet).2) := by + rw [edgeTermAt_pos h (unglueDataOpen hij hopen 𝒟') st hcL hbnd hE + hne C, + unglueDataOpen_apply hij hopen 𝒟' _ hcL hE hne t + (dropSubset_liftSubsetOpen hopen t) hct hcL rfl hEt hnet] + exact congrArg (fun z => ((-1 : ℂ) ^ C) * z) + (edgeSum_relOfEq rfl h st hbnd hbnd _) + +open Classical in +/-- **One open cut, on RS21's summands.** The interface colour is +even exactly when the subset misses the cut, so the sum over it is +the glued fragment's summand. -/ +theorem edgeTermAt_openCut + [LinearOrder L] {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + (hct : ∀ f ∈ t, (V.gluePairOpen i j hij hopen).pairing f ∈ t) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (𝒟' : DataFamily (V.gluePairOpen i j hij hopen)) + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (hbnd' : genBoundarySubsetMatches + (V.gluePairOpen i j hij hopen) t st') + (hEt : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).CanonData) + (C : ℕ) : + (∑ c : Fin k ⊕ Fin (2 * ℓ), + edgeTermAt h (unglueDataOpen hij hopen 𝒟') + (GenBoundaryState.extendPair i j st' c c) + (liftSubsetOpen hopen t) C) + = edgeTermAt h 𝒟' st' t C := by + have hcL := liftSubsetOpen_pairing_closed hij hopen t hct + have hE : (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).Eulerian := + (eulerian_lift_open_iff hij hopen t hct hcL).mpr hEt + have hne : Nonempty (EdgeSubset.mk (liftSubsetOpen hopen t) + hcL : EdgeSubset V).CanonData := + nonempty_canonData_unglueOpen hij hopen t hct hcL hnet + rw [edgeTermAt_pos h 𝒟' st' hct hbnd' hEt hnet C, + Fintype.sum_sum_type] + by_cases hni : partnerSurvI hopen ∈ t + · have hz : ∀ a : Fin k, + edgeTermAt h (unglueDataOpen hij hopen 𝒟') + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a)) (liftSubsetOpen hopen t) C = 0 := + fun a => edgeTermAt_eq_zero_of_not_matches h _ _ + (not_matches_liftOpen_even_of_hit hij hopen t hni st' a _) C + rw [Finset.sum_congr rfl (fun a (_ : a ∈ Finset.univ) => hz a), + Finset.sum_const_zero, zero_add, + Finset.sum_congr rfl (fun d (_ : d ∈ Finset.univ) => + edgeTermAt_liftOpen hij hopen t hct h 𝒟' hcL _ + (matches_liftOpen_of_hit hij hopen t hct hni st' hbnd' d) + hE hne hEt hnet C), + ← Finset.mul_sum, + edgeSum_openCut_hit hij hopen t hct hcL hni + (𝒟' t hct hEt hnet).1 (𝒟' t hct hEt hnet).2 h st' hbnd' + (matches_liftOpen_of_hit hij hopen t hct hni st' hbnd')] + · have hz : ∀ d : Fin (2 * ℓ), + edgeTermAt h (unglueDataOpen hij hopen 𝒟') + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d)) (liftSubsetOpen hopen t) C = 0 := + fun d => edgeTermAt_eq_zero_of_not_matches h _ _ + (not_matches_liftOpen_odd_of_miss hij hopen t hni st' d _) C + rw [Finset.sum_congr rfl (fun d (_ : d ∈ Finset.univ) => hz d), + Finset.sum_const_zero, add_zero, + Finset.sum_congr rfl (fun a (_ : a ∈ Finset.univ) => + edgeTermAt_liftOpen hij hopen t hct h 𝒟' hcL _ + (matches_liftOpen_of_miss hij hopen t hct hni st' hbnd' + hcL a) hE hne hEt hnet C), + ← Finset.mul_sum, + edgeSum_openCut_miss hij hopen t hct hcL hni + (𝒟' t hct hEt hnet).1 (𝒟' t hct hEt hnet).2 h st' hbnd' + (matches_liftOpen_of_miss hij hopen t hct hni st' hbnd' + hcL)] + +end OpenCut + +/-! ## One open cut, with nothing assumed of the subset + +The iteration sums over every subset of the glued fragment, so the +cut's identity is needed with no hypothesis on it. Off the good +subsets both sides vanish — and where the glue's closure fails, what +kills the lift is the interface state's own diagonality: the lift +would hold one glued flag and not the other, and so want the state +odd at one label and even at the other. +-/ + +section OpenCutAll + +/-- **A diagonal state forces the glue's closure.** -/ +theorem rewire_closed_of_liftOpen_closed + {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + {k ℓ : ℕ} + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (c : Fin k ⊕ Fin (2 * ℓ)) + (hcl : ∀ f ∈ liftSubsetOpen hopen t, + V.pairing f ∈ liftSubsetOpen hopen t) + (hm : genBoundarySubsetMatches V (liftSubsetOpen hopen t) + (GenBoundaryState.extendPair i j st' c c)) : + ∀ f ∈ t, (V.gluePairOpen i j hij hopen).pairing f ∈ t := by + have hi := hm i + have hj := hm j + rw [GenBoundaryState.extendPair_left, + boundaryFlagI_mem_liftOpen_iff hij hopen t] at hi + rw [GenBoundaryState.extendPair_right hij, + boundaryFlagJ_mem_liftOpen_iff hij hopen t] at hj + have hIJ : partnerSurvI hopen ∈ t ↔ partnerSurvJ hopen ∈ t := + hi.trans hj.symm + intro g hg + by_cases hpi : V.pairing g.val = V.boundaryFlag i + · rw [gluePairOpen_pairing_interface_i hij hopen g hpi] + exact hIJ.mp (eq_partnerSurvI_of_pairing hopen g hpi ▸ hg) + · by_cases hpj : V.pairing g.val = V.boundaryFlag j + · rw [gluePairOpen_pairing_interface_j hij hopen g hpi hpj] + exact hIJ.mpr + (eq_partnerSurvJ_of_pairing hopen g hpj ▸ hg) + · refine (surviving_val_mem_liftOpen_iff hopen t _).mp ?_ + rw [gluePairOpen_pairing_val_of_ne hij hopen g hpi hpj] + exact hcl _ ((surviving_val_mem_liftOpen_iff hopen t + g).mpr hg) + +open Classical in +/-- **One open cut, with nothing assumed of the subset.** -/ +theorem edgeTermAt_openCut_all + [LinearOrder L] {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (𝒟' : DataFamily (V.gluePairOpen i j hij hopen)) + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) (C : ℕ) : + (∑ c : Fin k ⊕ Fin (2 * ℓ), + edgeTermAt h (unglueDataOpen hij hopen 𝒟') + (GenBoundaryState.extendPair i j st' c c) + (liftSubsetOpen hopen t) C) + = edgeTermAt h 𝒟' st' t C := by + by_cases hct : ∀ f ∈ t, + (V.gluePairOpen i j hij hopen).pairing f ∈ t + · have hcL := liftSubsetOpen_pairing_closed hij hopen t hct + by_cases hbnd' : genBoundarySubsetMatches + (V.gluePairOpen i j hij hopen) t st' + · by_cases hEt : (EdgeSubset.mk t hct : EdgeSubset + (V.gluePairOpen i j hij hopen)).Eulerian + · by_cases hnet : Nonempty (EdgeSubset.mk t hct : EdgeSubset + (V.gluePairOpen i j hij hopen)).CanonData + · exact edgeTermAt_openCut hij hopen t hct h 𝒟' st' hbnd' + hEt hnet C + · rw [edgeTermAt_eq_zero_of_not_canon h 𝒟' st' hct hnet C] + exact Finset.sum_eq_zero (fun c _ => + edgeTermAt_eq_zero_of_not_canon h _ _ hcL + (fun hx => hnet (nonempty_canonData_glueOpen hij hopen + t hct hcL hx)) C) + · rw [edgeTermAt_eq_zero_of_not_eulerian h 𝒟' st' hct hEt C] + exact Finset.sum_eq_zero (fun c _ => + edgeTermAt_eq_zero_of_not_eulerian h _ _ hcL + (fun hx => hEt ((eulerian_lift_open_iff hij hopen t hct + hcL).mp hx)) C) + · rw [edgeTermAt_eq_zero_of_not_matches h 𝒟' st' hbnd' C] + exact Finset.sum_eq_zero (fun c _ => + edgeTermAt_eq_zero_of_not_matches h _ _ + (fun hx => hbnd' + (genBoundarySubsetMatches_glued_of_liftOpen hij hopen t + st' c c hx)) C) + · rw [edgeTermAt_eq_zero_of_not_closed h 𝒟' st' hct C] + refine Finset.sum_eq_zero (fun c _ => ?_) + by_cases hcL : ∀ f ∈ liftSubsetOpen hopen t, + V.pairing f ∈ liftSubsetOpen hopen t + · exact edgeTermAt_eq_zero_of_not_matches h _ _ + (fun hx => hct (rewire_closed_of_liftOpen_closed hij hopen t + st' c hcL hx)) C + · exact edgeTermAt_eq_zero_of_not_closed h _ _ hcL C + +end OpenCutAll + +/-! ## One closing cut + +Gluing an edge with both ends labelled leaves a free circle. On the +base the edge is a trail from one label to the other and carries no +circuit; in the composition it is a circuit, and the ledger records +that as the extra count the carried branch is taken at. The two +branches then weigh `k` and `−2ℓ`, which is the circle's own value. +-/ + +section ClosedCut + +/-- The empty branch admits no odd colour at the cut. -/ +theorem not_matches_liftClosed_odd_false + {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (t : Finset (SurvivingFlag V i j)) + {k ℓ : ℕ} + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (d : Fin (2 * ℓ)) (c' : Fin k ⊕ Fin (2 * ℓ)) : + ¬ genBoundarySubsetMatches V (liftSubsetClosed t false) + (GenBoundaryState.extendPair i j st' (Sum.inr d) c') := by + intro hm + refine Bool.false_ne_true + ((boundaryFlagI_mem_liftClosed_iff hij t false).mp + ((hm i).mpr ⟨d, ?_⟩)) + exact GenBoundaryState.extendPair_left st' _ _ + +/-- The carried branch admits no even colour at the cut. -/ +theorem not_matches_liftClosed_even_true + {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (t : Finset (SurvivingFlag V i j)) + {k ℓ : ℕ} + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (a : Fin k) (c' : Fin k ⊕ Fin (2 * ℓ)) : + ¬ genBoundarySubsetMatches V (liftSubsetClosed t true) + (GenBoundaryState.extendPair i j st' (Sum.inl a) c') := by + intro hm + obtain ⟨e, he⟩ := (hm i).mp + ((boundaryFlagI_mem_liftClosed_iff hij t true).mpr rfl) + rw [GenBoundaryState.extendPair_left] at he + exact absurd he (by simp) + +/-- On the empty branch the even extensions all match. -/ +theorem matches_liftClosed_false {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + {k ℓ : ℕ} + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (hbnd' : genBoundarySubsetMatches + (V.gluePairClosed i j hclosed) t st') (a : Fin k) : + genBoundarySubsetMatches V (liftSubsetClosed t false) + (GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a)) := by + intro b + by_cases hbi : b = i + · subst hbi + rw [GenBoundaryState.extendPair_left, + boundaryFlagI_mem_liftClosed_iff hij t false] + exact ⟨fun hx => absurd hx Bool.false_ne_true, + fun hx => absurd hx.choose_spec (by simp)⟩ + · by_cases hbj : b = j + · subst hbj + rw [GenBoundaryState.extendPair_right hij, + boundaryFlagJ_mem_liftClosed_iff hij t false] + exact ⟨fun hx => absurd hx Bool.false_ne_true, + fun hx => absurd hx.choose_spec (by simp)⟩ + · have hst : GenBoundaryState.extendPair i j st' (Sum.inl a) + (Sum.inl a) b = st' ⟨b, hbi, hbj⟩ := + GenBoundaryState.extendPair_surviving st' _ _ + ⟨b, hbi, hbj⟩ + rw [show V.boundaryFlag b + = (glueBoundaryFlag V i j ⟨b, hbi, hbj⟩).val from rfl, + surviving_val_mem_liftClosed_iff t false, hst] + exact hbnd' ⟨b, hbi, hbj⟩ + +/-- On the carried branch the odd extensions all match. -/ +theorem matches_liftClosed_true {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + {k ℓ : ℕ} + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (hbnd' : genBoundarySubsetMatches + (V.gluePairClosed i j hclosed) t st') (d : Fin (2 * ℓ)) : + genBoundarySubsetMatches V (liftSubsetClosed t true) + (GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d)) := by + intro b + by_cases hbi : b = i + · subst hbi + rw [GenBoundaryState.extendPair_left, + boundaryFlagI_mem_liftClosed_iff hij t true] + exact ⟨fun _ => ⟨d, rfl⟩, fun _ => rfl⟩ + · by_cases hbj : b = j + · subst hbj + rw [GenBoundaryState.extendPair_right hij, + boundaryFlagJ_mem_liftClosed_iff hij t true] + exact ⟨fun _ => ⟨d, rfl⟩, fun _ => rfl⟩ + · have hst : GenBoundaryState.extendPair i j st' (Sum.inr d) + (Sum.inr d) b = st' ⟨b, hbi, hbj⟩ := + GenBoundaryState.extendPair_surviving st' _ _ + ⟨b, hbi, hbj⟩ + rw [show V.boundaryFlag b + = (glueBoundaryFlag V i j ⟨b, hbi, hbj⟩).val from rfl, + surviving_val_mem_liftClosed_iff t true, hst] + exact hbnd' ⟨b, hbi, hbj⟩ + +open Classical in +/-- **The base's summand at a closed lift** is the glued fragment's +data, unglued. -/ +theorem edgeTermAt_liftClosed + [LinearOrder L] {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + (hct : ∀ f ∈ t, (V.gluePairClosed i j hclosed).pairing f ∈ t) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (𝒟' : DataFamily (V.gluePairClosed i j hclosed)) (b : Bool) + (hcL : ∀ f ∈ liftSubsetClosed t b, + V.pairing f ∈ liftSubsetClosed t b) + (st : GenBoundaryState k ℓ L) + (hbnd : genBoundarySubsetMatches V (liftSubsetClosed t b) st) + (hE : (EdgeSubset.mk (liftSubsetClosed t b) hcL : + EdgeSubset V).Eulerian) + (hne : Nonempty (EdgeSubset.mk (liftSubsetClosed t b) hcL : + EdgeSubset V).CanonData) + (hEt : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).CanonData) + (C : ℕ) : + edgeTermAt h (unglueDataClosed hij hclosed 𝒟') st + (liftSubsetClosed t b) C + = ((-1 : ℂ) ^ C) * + (EdgeSubset.mk (liftSubsetClosed t b) hcL : + EdgeSubset V).edgeSum h st hbnd + (unglueOrientationClosed hclosed b t hct hcL + (𝒟' t hct hEt hnet).1 (𝒟' t hct hEt hnet).2) := by + rw [edgeTermAt_pos h (unglueDataClosed hij hclosed 𝒟') st hcL hbnd + hE hne C, + unglueDataClosed_apply hij hclosed 𝒟' _ hcL hE hne t b + (dropSubset_liftSubsetClosed t b) + (by simp [boundaryFlagI_mem_liftClosed_iff hij]) hct hcL rfl + hEt hnet] + exact congrArg (fun z => ((-1 : ℂ) ^ C) * z) + (edgeSum_relOfEq rfl h st hbnd hbnd _) + +open Classical in +/-- **The empty branch of a closing cut weighs `k`.** Only the even +colours reach it — the odd ones would ask for the cut's own edge — +and each of them gives the glued term back. -/ +theorem edgeTermAt_closedCut_false_row + [LinearOrder L] {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + (hct : ∀ f ∈ t, (V.gluePairClosed i j hclosed).pairing f ∈ t) + {k ℓ : ℕ} + (h : MixedFunctional k ℓ) + (𝒟' : DataFamily (V.gluePairClosed i j hclosed)) + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (hbnd' : genBoundarySubsetMatches + (V.gluePairClosed i j hclosed) t st') + (hEt : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).CanonData) + (C : ℕ) : + (∑ c : Fin k ⊕ Fin (2 * ℓ), + edgeTermAt h (unglueDataClosed hij hclosed 𝒟') + (GenBoundaryState.extendPair i j st' c c) + (liftSubsetClosed t false) C) + = (k : ℂ) * edgeTermAt h 𝒟' st' t C := by + have hcF := liftSubsetClosed_pairing_closed hclosed t false hct + have hEf := (eulerian_liftClosed_iff' hclosed false t hct + hcF).mpr hEt + have hnef := nonempty_canonData_unglueClosed hclosed t hct false + hcF hnet + rw [Fintype.sum_sum_type, + Finset.sum_congr rfl (fun d (_ : d ∈ Finset.univ) => + edgeTermAt_eq_zero_of_not_matches h _ _ + (not_matches_liftClosed_odd_false hij t st' d _) C), + Finset.sum_const_zero, add_zero, + Finset.sum_congr rfl (fun a (_ : a ∈ Finset.univ) => + (edgeTermAt_liftClosed hij hclosed t hct h 𝒟' false hcF _ + (matches_liftClosed_false hij hclosed t st' hbnd' a) + hEf hnef hEt hnet C).trans + (congrArg (fun z => ((-1 : ℂ) ^ C) * z) + (edgeSum_closedCut_false hij hclosed t hct hcF + (𝒟' t hct hEt hnet).1 (𝒟' t hct hEt hnet).2 h st' a + hbnd' _))), + Finset.sum_const, Finset.card_univ, Fintype.card_fin, + nsmul_eq_mul, edgeTermAt_pos h 𝒟' st' hct hbnd' hEt hnet C] + +open Classical in +/-- **The carried branch of a closing cut weighs `−2ℓ`.** Only the +odd colours reach it, and each of them gives the glued term back with +the sign the extra carried cut supplies. -/ +theorem edgeTermAt_closedCut_true_row + [LinearOrder L] {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + (hct : ∀ f ∈ t, (V.gluePairClosed i j hclosed).pairing f ∈ t) + {k ℓ : ℕ} + (h : MixedFunctional k ℓ) + (𝒟' : DataFamily (V.gluePairClosed i j hclosed)) + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (hbnd' : genBoundarySubsetMatches + (V.gluePairClosed i j hclosed) t st') + (hEt : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).CanonData) + (C : ℕ) : + (∑ c : Fin k ⊕ Fin (2 * ℓ), + edgeTermAt h (unglueDataClosed hij hclosed 𝒟') + (GenBoundaryState.extendPair i j st' c c) + (liftSubsetClosed t true) (C + 1)) + = (-(2 * ℓ : ℕ) : ℂ) * edgeTermAt h 𝒟' st' t C := by + have hcT := liftSubsetClosed_pairing_closed hclosed t true hct + have hEr := (eulerian_liftClosed_iff' hclosed true t hct + hcT).mpr hEt + have hner := nonempty_canonData_unglueClosed hclosed t hct true + hcT hnet + rw [Fintype.sum_sum_type, + Finset.sum_congr rfl (fun a (_ : a ∈ Finset.univ) => + edgeTermAt_eq_zero_of_not_matches h _ _ + (not_matches_liftClosed_even_true hij t st' a _) (C + 1)), + Finset.sum_const_zero, zero_add, + Finset.sum_congr rfl (fun d (_ : d ∈ Finset.univ) => + (edgeTermAt_liftClosed hij hclosed t hct h 𝒟' true hcT _ + (matches_liftClosed_true hij hclosed t st' hbnd' d) + hEr hner hEt hnet (C + 1)).trans + (congrArg (fun z => ((-1 : ℂ) ^ (C + 1)) * z) + (edgeSum_closedCut_true hij hclosed t hct hcT + (𝒟' t hct hEt hnet).1 (𝒟' t hct hEt hnet).2 h st' d + hbnd' _))), + Finset.sum_const, Finset.card_univ, Fintype.card_fin, + nsmul_eq_mul, edgeTermAt_pos h 𝒟' st' hct hbnd' hEt hnet C, + pow_succ] + push_cast + ring + +open Classical in +/-- **One closing cut, on RS21's summands.** The two branches of the +closed edge weigh `k` and `−2ℓ`, the free circle's own value. -/ +theorem edgeTermAt_closedCut + [LinearOrder L] {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + (hct : ∀ f ∈ t, (V.gluePairClosed i j hclosed).pairing f ∈ t) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (𝒟' : DataFamily (V.gluePairClosed i j hclosed)) + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (hbnd' : genBoundarySubsetMatches + (V.gluePairClosed i j hclosed) t st') + (hEt : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).CanonData) + (C : ℕ) : + (∑ c : Fin k ⊕ Fin (2 * ℓ), + edgeTermAt h (unglueDataClosed hij hclosed 𝒟') + (GenBoundaryState.extendPair i j st' c c) + (liftSubsetClosed t false) C) + + (∑ c : Fin k ⊕ Fin (2 * ℓ), + edgeTermAt h (unglueDataClosed hij hclosed 𝒟') + (GenBoundaryState.extendPair i j st' c c) + (liftSubsetClosed t true) (C + 1)) + = ((k : ℂ) - 2 * ℓ) * edgeTermAt h 𝒟' st' t C := by + have hcF := liftSubsetClosed_pairing_closed hclosed t false hct + have hcT := liftSubsetClosed_pairing_closed hclosed t true hct + have hEf := (eulerian_liftClosed_iff' hclosed false t hct + hcF).mpr hEt + have hnef := nonempty_canonData_unglueClosed hclosed t hct false + hcF hnet + have hEr := (eulerian_liftClosed_iff' hclosed true t hct + hcT).mpr hEt + have hner := nonempty_canonData_unglueClosed hclosed t hct true + hcT hnet + have h1 : (∑ c : Fin k ⊕ Fin (2 * ℓ), + edgeTermAt h (unglueDataClosed hij hclosed 𝒟') + (GenBoundaryState.extendPair i j st' c c) + (liftSubsetClosed t false) C) + = (k : ℂ) * (((-1 : ℂ) ^ C) * + (EdgeSubset.mk t hct : EdgeSubset + (V.gluePairClosed i j hclosed)).edgeSum h st' hbnd' + (𝒟' t hct hEt hnet).2) := by + rw [Fintype.sum_sum_type, + Finset.sum_congr rfl (fun d (_ : d ∈ Finset.univ) => + edgeTermAt_eq_zero_of_not_matches h _ _ + (not_matches_liftClosed_odd_false hij t st' d _) C), + Finset.sum_const_zero, add_zero, + Finset.sum_congr rfl (fun a (_ : a ∈ Finset.univ) => + (edgeTermAt_liftClosed hij hclosed t hct h 𝒟' false hcF _ + (matches_liftClosed_false hij hclosed t st' hbnd' a) + hEf hnef hEt hnet C).trans + (congrArg (fun z => ((-1 : ℂ) ^ C) * z) + (edgeSum_closedCut_false hij hclosed t hct hcF + (𝒟' t hct hEt hnet).1 (𝒟' t hct hEt hnet).2 h st' a + hbnd' _))), + Finset.sum_const, Finset.card_univ, Fintype.card_fin, + nsmul_eq_mul] + have h2 : (∑ c : Fin k ⊕ Fin (2 * ℓ), + edgeTermAt h (unglueDataClosed hij hclosed 𝒟') + (GenBoundaryState.extendPair i j st' c c) + (liftSubsetClosed t true) (C + 1)) + = ((2 * ℓ : ℕ) : ℂ) * (((-1 : ℂ) ^ (C + 1)) * + (EdgeSubset.mk t hct : EdgeSubset + (V.gluePairClosed i j hclosed)).edgeSum h st' hbnd' + (𝒟' t hct hEt hnet).2) := by + rw [Fintype.sum_sum_type, + Finset.sum_congr rfl (fun a (_ : a ∈ Finset.univ) => + edgeTermAt_eq_zero_of_not_matches h _ _ + (not_matches_liftClosed_even_true hij t st' a _) (C + 1)), + Finset.sum_const_zero, zero_add, + Finset.sum_congr rfl (fun d (_ : d ∈ Finset.univ) => + (edgeTermAt_liftClosed hij hclosed t hct h 𝒟' true hcT _ + (matches_liftClosed_true hij hclosed t st' hbnd' d) + hEr hner hEt hnet (C + 1)).trans + (congrArg (fun z => ((-1 : ℂ) ^ (C + 1)) * z) + (edgeSum_closedCut_true hij hclosed t hct hcT + (𝒟' t hct hEt hnet).1 (𝒟' t hct hEt hnet).2 h st' d + hbnd' _))), + Finset.sum_const, Finset.card_univ, Fintype.card_fin, + nsmul_eq_mul] + rw [h1, h2, edgeTermAt_pos h 𝒟' st' hct hbnd' hEt hnet C, pow_succ] + push_cast + ring + +end ClosedCut + +/-! ## One closing cut, with nothing assumed of the subset -/ + +section ClosedCutAll + +/-- **The glued boundary constraint from the lift's.** -/ +theorem genBoundarySubsetMatches_glued_of_liftClosed + {V : Fragment L} {i : L} {j : L} + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + {k ℓ : ℕ} + (b : Bool) (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) + (c c' : Fin k ⊕ Fin (2 * ℓ)) + (hm : genBoundarySubsetMatches V (liftSubsetClosed t b) + (GenBoundaryState.extendPair i j st' c c')) : + genBoundarySubsetMatches (V.gluePairClosed i j hclosed) t st' := + by + intro a + have hval := hm a.val + rw [GenBoundaryState.extendPair_surviving st' c c' a] at hval + exact (surviving_val_mem_liftClosed_iff t b + (glueBoundaryFlag V i j a)).symm.trans hval + +/-- **A closed lift's closure is the glue's.** -/ +theorem glued_closed_of_liftClosed_closed {V : Fragment L} {i : L} {j : L} + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + (b : Bool) + (hcl : ∀ f ∈ liftSubsetClosed t b, + V.pairing f ∈ liftSubsetClosed t b) : + ∀ f ∈ t, (V.gluePairClosed i j hclosed).pairing f ∈ t := by + have h := dropSubset_pairing_closed_of_closed hclosed + (liftSubsetClosed t b) hcl + rwa [dropSubset_liftSubsetClosed t b] at h + +open Classical in +/-- **One closing cut, with nothing assumed of the subset.** -/ +theorem edgeTermAt_closedCut_all + [LinearOrder L] {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + {k ℓ : ℕ} + (h : MixedFunctional k ℓ) + (𝒟' : DataFamily (V.gluePairClosed i j hclosed)) + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) (C : ℕ) : + (∑ c : Fin k ⊕ Fin (2 * ℓ), + edgeTermAt h (unglueDataClosed hij hclosed 𝒟') + (GenBoundaryState.extendPair i j st' c c) + (liftSubsetClosed t false) C) + + (∑ c : Fin k ⊕ Fin (2 * ℓ), + edgeTermAt h (unglueDataClosed hij hclosed 𝒟') + (GenBoundaryState.extendPair i j st' c c) + (liftSubsetClosed t true) (C + 1)) + = ((k : ℂ) - 2 * ℓ) * edgeTermAt h 𝒟' st' t C := by + by_cases hct : ∀ f ∈ t, + (V.gluePairClosed i j hclosed).pairing f ∈ t + · have hcF := liftSubsetClosed_pairing_closed hclosed t false hct + have hcT := liftSubsetClosed_pairing_closed hclosed t true hct + by_cases hbnd' : genBoundarySubsetMatches + (V.gluePairClosed i j hclosed) t st' + · by_cases hEt : (EdgeSubset.mk t hct : EdgeSubset + (V.gluePairClosed i j hclosed)).Eulerian + · by_cases hnet : Nonempty (EdgeSubset.mk t hct : EdgeSubset + (V.gluePairClosed i j hclosed)).CanonData + · exact edgeTermAt_closedCut hij hclosed t hct h 𝒟' st' + hbnd' hEt hnet C + · rw [edgeTermAt_eq_zero_of_not_canon h 𝒟' st' hct hnet C, + Finset.sum_eq_zero (fun c _ => + edgeTermAt_eq_zero_of_not_canon h _ _ hcF + (fun hx => hnet (nonempty_canonData_glueClosed + hclosed t hct false hcF hx)) C), + Finset.sum_eq_zero (fun c _ => + edgeTermAt_eq_zero_of_not_canon h _ _ hcT + (fun hx => hnet (nonempty_canonData_glueClosed + hclosed t hct true hcT hx)) (C + 1))] + ring + · rw [edgeTermAt_eq_zero_of_not_eulerian h 𝒟' st' hct hEt C, + Finset.sum_eq_zero (fun c _ => + edgeTermAt_eq_zero_of_not_eulerian h _ _ hcF + (fun hx => hEt ((eulerian_liftClosed_iff' hclosed + false t hct hcF).mp hx)) C), + Finset.sum_eq_zero (fun c _ => + edgeTermAt_eq_zero_of_not_eulerian h _ _ hcT + (fun hx => hEt ((eulerian_liftClosed_iff' hclosed + true t hct hcT).mp hx)) (C + 1))] + ring + · rw [edgeTermAt_eq_zero_of_not_matches h 𝒟' st' hbnd' C, + Finset.sum_eq_zero (fun c _ => + edgeTermAt_eq_zero_of_not_matches h _ _ + (fun hx => hbnd' + (genBoundarySubsetMatches_glued_of_liftClosed hclosed t + false st' c c hx)) C), + Finset.sum_eq_zero (fun c _ => + edgeTermAt_eq_zero_of_not_matches h _ _ + (fun hx => hbnd' + (genBoundarySubsetMatches_glued_of_liftClosed hclosed t + true st' c c hx)) (C + 1))] + ring + · rw [edgeTermAt_eq_zero_of_not_closed h 𝒟' st' hct C, + Finset.sum_eq_zero (fun c _ => by + by_cases hcF : ∀ f ∈ liftSubsetClosed t false, + V.pairing f ∈ liftSubsetClosed t false + · exact absurd (glued_closed_of_liftClosed_closed hclosed t + false hcF) hct + · exact edgeTermAt_eq_zero_of_not_closed h _ _ hcF C), + Finset.sum_eq_zero (fun c _ => by + by_cases hcT : ∀ f ∈ liftSubsetClosed t true, + V.pairing f ∈ liftSubsetClosed t true + · exact absurd (glued_closed_of_liftClosed_closed hclosed t + true hcT) hct + · exact edgeTermAt_eq_zero_of_not_closed h _ _ hcT (C + 1))] + ring + +open Classical in +/-- **The empty branch of a closing cut weighs `k`**, with nothing +assumed of the subset. -/ +theorem edgeTermAt_closedCut_false_row_all + [LinearOrder L] {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + {k ℓ : ℕ} + (h : MixedFunctional k ℓ) + (𝒟' : DataFamily (V.gluePairClosed i j hclosed)) + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) (C : ℕ) : + (∑ c : Fin k ⊕ Fin (2 * ℓ), + edgeTermAt h (unglueDataClosed hij hclosed 𝒟') + (GenBoundaryState.extendPair i j st' c c) + (liftSubsetClosed t false) C) + = (k : ℂ) * edgeTermAt h 𝒟' st' t C := by + by_cases hct : ∀ f ∈ t, + (V.gluePairClosed i j hclosed).pairing f ∈ t + · have hcF := liftSubsetClosed_pairing_closed hclosed t false hct + by_cases hbnd' : genBoundarySubsetMatches + (V.gluePairClosed i j hclosed) t st' + · by_cases hEt : (EdgeSubset.mk t hct : EdgeSubset + (V.gluePairClosed i j hclosed)).Eulerian + · by_cases hnet : Nonempty (EdgeSubset.mk t hct : EdgeSubset + (V.gluePairClosed i j hclosed)).CanonData + · exact edgeTermAt_closedCut_false_row hij hclosed t hct h + 𝒟' st' hbnd' hEt hnet C + · rw [edgeTermAt_eq_zero_of_not_canon h 𝒟' st' hct hnet C, + Finset.sum_eq_zero (fun c _ => + edgeTermAt_eq_zero_of_not_canon h _ _ hcF + (fun hx => hnet (nonempty_canonData_glueClosed + hclosed t hct false hcF hx)) C)] + ring + · rw [edgeTermAt_eq_zero_of_not_eulerian h 𝒟' st' hct hEt C, + Finset.sum_eq_zero (fun c _ => + edgeTermAt_eq_zero_of_not_eulerian h _ _ hcF + (fun hx => hEt ((eulerian_liftClosed_iff' hclosed + false t hct hcF).mp hx)) C)] + ring + · rw [edgeTermAt_eq_zero_of_not_matches h 𝒟' st' hbnd' C, + Finset.sum_eq_zero (fun c _ => + edgeTermAt_eq_zero_of_not_matches h _ _ + (fun hx => hbnd' + (genBoundarySubsetMatches_glued_of_liftClosed hclosed t + false st' c c hx)) C)] + ring + · rw [edgeTermAt_eq_zero_of_not_closed h 𝒟' st' hct C, + Finset.sum_eq_zero (fun c _ => by + by_cases hcF : ∀ f ∈ liftSubsetClosed t false, + V.pairing f ∈ liftSubsetClosed t false + · exact absurd (glued_closed_of_liftClosed_closed hclosed t + false hcF) hct + · exact edgeTermAt_eq_zero_of_not_closed h _ _ hcF C)] + ring + +open Classical in +/-- **The carried branch of a closing cut weighs `−2ℓ`**, with +nothing assumed of the subset. -/ +theorem edgeTermAt_closedCut_true_row_all + [LinearOrder L] {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + {k ℓ : ℕ} + (h : MixedFunctional k ℓ) + (𝒟' : DataFamily (V.gluePairClosed i j hclosed)) + (st' : GenBoundaryState k ℓ (SurvivingLabel L i j)) (C : ℕ) : + (∑ c : Fin k ⊕ Fin (2 * ℓ), + edgeTermAt h (unglueDataClosed hij hclosed 𝒟') + (GenBoundaryState.extendPair i j st' c c) + (liftSubsetClosed t true) (C + 1)) + = (-(2 * ℓ : ℕ) : ℂ) * edgeTermAt h 𝒟' st' t C := by + by_cases hct : ∀ f ∈ t, + (V.gluePairClosed i j hclosed).pairing f ∈ t + · have hcT := liftSubsetClosed_pairing_closed hclosed t true hct + by_cases hbnd' : genBoundarySubsetMatches + (V.gluePairClosed i j hclosed) t st' + · by_cases hEt : (EdgeSubset.mk t hct : EdgeSubset + (V.gluePairClosed i j hclosed)).Eulerian + · by_cases hnet : Nonempty (EdgeSubset.mk t hct : EdgeSubset + (V.gluePairClosed i j hclosed)).CanonData + · exact edgeTermAt_closedCut_true_row hij hclosed t hct h + 𝒟' st' hbnd' hEt hnet C + · rw [edgeTermAt_eq_zero_of_not_canon h 𝒟' st' hct hnet C, + Finset.sum_eq_zero (fun c _ => + edgeTermAt_eq_zero_of_not_canon h _ _ hcT + (fun hx => hnet (nonempty_canonData_glueClosed + hclosed t hct true hcT hx)) (C + 1))] + ring + · rw [edgeTermAt_eq_zero_of_not_eulerian h 𝒟' st' hct hEt C, + Finset.sum_eq_zero (fun c _ => + edgeTermAt_eq_zero_of_not_eulerian h _ _ hcT + (fun hx => hEt ((eulerian_liftClosed_iff' hclosed + true t hct hcT).mp hx)) (C + 1))] + ring + · rw [edgeTermAt_eq_zero_of_not_matches h 𝒟' st' hbnd' C, + Finset.sum_eq_zero (fun c _ => + edgeTermAt_eq_zero_of_not_matches h _ _ + (fun hx => hbnd' + (genBoundarySubsetMatches_glued_of_liftClosed hclosed t + true st' c c hx)) (C + 1))] + ring + · rw [edgeTermAt_eq_zero_of_not_closed h 𝒟' st' hct C, + Finset.sum_eq_zero (fun c _ => by + by_cases hcT : ∀ f ∈ liftSubsetClosed t true, + V.pairing f ∈ liftSubsetClosed t true + · exact absurd (glued_closed_of_liftClosed_closed hclosed t + true hcT) hct + · exact edgeTermAt_eq_zero_of_not_closed h _ _ hcT (C + 1))] + ring + +end ClosedCutAll + +/-! ## RS21's sum over a disjoint union + +The two halves of a composition colour their own edges, and a +through-edge of the union is a through-edge of one of them, so the +agreement splits with the sum. +-/ + +section DisjUnion + +/-- The named colour of a left flag is the left half's. -/ +theorem usedColour_inl + {α : Type} {β : Type} [LinearOrder (α ⊕ β)] {W₁ : Fragment α} + {W₂ : Fragment β} (F : EdgeSubset (W₁.disjUnion W₂)) + {k ℓ : ℕ} (st : GenBoundaryState k ℓ (α ⊕ β)) + (hbnd : genBoundarySubsetMatches (W₁.disjUnion W₂) F.flags st) + (hbnd₁ : genBoundarySubsetMatches W₁ (leftSub F).flags + (fun a => st (Sum.inl a))) + {g : W₁.Flag} + (hbD : (Sum.inl g : (W₁.disjUnion W₂).Flag) ∈ F.boundaryFlags) + (hb : g ∈ (leftSub F).boundaryFlags) : + usedColour F st hbnd hbD + = usedColour (leftSub F) (fun a => st (Sum.inl a)) hbnd₁ hb := + by + have h1 := usedColour_spec F st hbnd hbD + have h2 := usedColour_spec (leftSub F) (fun a => st (Sum.inl a)) + hbnd₁ hb + rw [boundaryLabel_inl hbD hb] at h1 + exact Sum.inr.inj (h1.symm.trans h2) + +/-- The named colour of a right flag is the right half's. -/ +theorem usedColour_inr + {α : Type} {β : Type} [LinearOrder (α ⊕ β)] {W₁ : Fragment α} + {W₂ : Fragment β} (F : EdgeSubset (W₁.disjUnion W₂)) + {k ℓ : ℕ} (st : GenBoundaryState k ℓ (α ⊕ β)) + (hbnd : genBoundarySubsetMatches (W₁.disjUnion W₂) F.flags st) + (hbnd₂ : genBoundarySubsetMatches W₂ (rightSub F).flags + (fun b => st (Sum.inr b))) + {g : W₂.Flag} + (hbD : (Sum.inr g : (W₁.disjUnion W₂).Flag) ∈ F.boundaryFlags) + (hb : g ∈ (rightSub F).boundaryFlags) : + usedColour F st hbnd hbD + = usedColour (rightSub F) (fun b => st (Sum.inr b)) hbnd₂ hb := + by + have h1 := usedColour_spec F st hbnd hbD + have h2 := usedColour_spec (rightSub F) (fun b => st (Sum.inr b)) + hbnd₂ hb + rw [boundaryLabel_inr hbD hb] at h1 + exact Sum.inr.inj (h1.symm.trans h2) + +/-- **Agreement restricts to the left half.** -/ +theorem throughAgree_left + {α : Type} {β : Type} [LinearOrder (α ⊕ β)] {W₁ : Fragment α} + {W₂ : Fragment β} (F : EdgeSubset (W₁.disjUnion W₂)) + {k ℓ : ℕ} + (st : GenBoundaryState k ℓ (α ⊕ β)) + (hbnd : genBoundarySubsetMatches (W₁.disjUnion W₂) F.flags st) + (hbnd₁ : genBoundarySubsetMatches W₁ (leftSub F).flags + (fun a => st (Sum.inl a))) + (hag : ThroughAgree F st hbnd) : + ThroughAgree (leftSub F) (fun a => st (Sum.inl a)) hbnd₁ := by + intro g hb hbp + have hbD : (Sum.inl g : (W₁.disjUnion W₂).Flag) ∈ F.boundaryFlags := + inl_mem_boundary.mpr hb + have hbpD : (W₁.disjUnion W₂).pairing (Sum.inl g) + ∈ F.boundaryFlags := inl_mem_boundary.mpr hbp + rw [← usedColour_inl F st hbnd hbnd₁ hbpD hbp, + ← usedColour_inl F st hbnd hbnd₁ hbD hb] + exact hag (Sum.inl g) hbD hbpD + +/-- **Agreement restricts to the right half.** -/ +theorem throughAgree_right + {α : Type} {β : Type} [LinearOrder (α ⊕ β)] {W₁ : Fragment α} + {W₂ : Fragment β} (F : EdgeSubset (W₁.disjUnion W₂)) + {k ℓ : ℕ} + (st : GenBoundaryState k ℓ (α ⊕ β)) + (hbnd : genBoundarySubsetMatches (W₁.disjUnion W₂) F.flags st) + (hbnd₂ : genBoundarySubsetMatches W₂ (rightSub F).flags + (fun b => st (Sum.inr b))) + (hag : ThroughAgree F st hbnd) : + ThroughAgree (rightSub F) (fun b => st (Sum.inr b)) hbnd₂ := by + intro g hb hbp + have hbD : (Sum.inr g : (W₁.disjUnion W₂).Flag) ∈ F.boundaryFlags := + inr_mem_boundary.mpr hb + have hbpD : (W₁.disjUnion W₂).pairing (Sum.inr g) + ∈ F.boundaryFlags := inr_mem_boundary.mpr hbp + rw [← usedColour_inr F st hbnd hbnd₂ hbpD hbp, + ← usedColour_inr F st hbnd hbnd₂ hbD hb] + exact hag (Sum.inr g) hbD hbpD + +/-- **Agreement on both halves is agreement.** -/ +theorem throughAgree_of_parts + {α : Type} {β : Type} [LinearOrder (α ⊕ β)] {W₁ : Fragment α} + {W₂ : Fragment β} (F : EdgeSubset (W₁.disjUnion W₂)) + {k ℓ : ℕ} + (st : GenBoundaryState k ℓ (α ⊕ β)) + (hbnd : genBoundarySubsetMatches (W₁.disjUnion W₂) F.flags st) + (hbnd₁ : genBoundarySubsetMatches W₁ (leftSub F).flags + (fun a => st (Sum.inl a))) + (hbnd₂ : genBoundarySubsetMatches W₂ (rightSub F).flags + (fun b => st (Sum.inr b))) + (hag₁ : ThroughAgree (leftSub F) (fun a => st (Sum.inl a)) + hbnd₁) + (hag₂ : ThroughAgree (rightSub F) (fun b => st (Sum.inr b)) + hbnd₂) : + ThroughAgree F st hbnd := by + rintro (g | g) hb hbp + · have hb' : g ∈ (leftSub F).boundaryFlags := inl_mem_boundary.mp hb + have hbp' : W₁.pairing g ∈ (leftSub F).boundaryFlags := + inl_mem_boundary.mp hbp + have e1 : usedColour F st hbnd hbp + = usedColour (leftSub F) (fun a => st (Sum.inl a)) hbnd₁ + hbp' := usedColour_inl F st hbnd hbnd₁ hbp hbp' + have e2 : usedColour F st hbnd hb + = usedColour (leftSub F) (fun a => st (Sum.inl a)) hbnd₁ + hb' := usedColour_inl F st hbnd hbnd₁ hb hb' + rw [e1, e2] + exact hag₁ g hb' hbp' + · have hb' : g ∈ (rightSub F).boundaryFlags := + inr_mem_boundary.mp hb + have hbp' : W₂.pairing g ∈ (rightSub F).boundaryFlags := + inr_mem_boundary.mp hbp + have e1 : usedColour F st hbnd hbp + = usedColour (rightSub F) (fun b => st (Sum.inr b)) hbnd₂ + hbp' := usedColour_inr F st hbnd hbnd₂ hbp hbp' + have e2 : usedColour F st hbnd hb + = usedColour (rightSub F) (fun b => st (Sum.inr b)) hbnd₂ + hb' := usedColour_inr F st hbnd hbnd₂ hb hb' + rw [e1, e2] + exact hag₂ g hb' hbp' + +/-- **RS21's colouring sum splits over a disjoint union.** -/ +theorem edgeSum_disjUnion + {α : Type} {β : Type} [LinearOrder (α ⊕ β)] {W₁ : Fragment α} + {W₂ : Fragment β} (F : EdgeSubset (W₁.disjUnion W₂)) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ (α ⊕ β)) + (hbnd : genBoundarySubsetMatches (W₁.disjUnion W₂) F.flags st) + (hbnd₁ : genBoundarySubsetMatches W₁ (leftSub F).flags + (fun a => st (Sum.inl a))) + (hbnd₂ : genBoundarySubsetMatches W₂ (rightSub F).flags + (fun b => st (Sum.inr b))) + {κ₁ : (leftSub F).RelTransitionSystem} + {κ₂ : (rightSub F).RelTransitionSystem} + (o₁ : κ₁.Orientation) (o₂ : κ₂.Orientation) : + F.edgeSum h st hbnd (prodOrient o₁ o₂) + = (leftSub F).edgeSum h (fun a => st (Sum.inl a)) hbnd₁ o₁ + * (rightSub F).edgeSum h (fun b => st (Sum.inr b)) hbnd₂ + o₂ := by + by_cases hag : ThroughAgree F st hbnd + · rw [edgeSum_eq_vertexSum F h st hbnd _ hag, + edgeSum_eq_vertexSum (leftSub F) h _ hbnd₁ o₁ + (throughAgree_left F st hbnd hbnd₁ hag), + edgeSum_eq_vertexSum (rightSub F) h _ hbnd₂ o₂ + (throughAgree_right F st hbnd hbnd₂ hag)] + exact vertexSum_disjUnion F h st hbnd hbnd₁ hbnd₂ o₁ o₂ + · rw [edgeSum_eq_zero_of_not_throughAgree F h st hbnd _ hag] + by_cases hag₁ : ThroughAgree (leftSub F) + (fun a => st (Sum.inl a)) hbnd₁ + · by_cases hag₂ : ThroughAgree (rightSub F) + (fun b => st (Sum.inr b)) hbnd₂ + · exact absurd (throughAgree_of_parts F st hbnd hbnd₁ hbnd₂ + hag₁ hag₂) hag + · rw [edgeSum_eq_zero_of_not_throughAgree (rightSub F) h _ + hbnd₂ o₂ hag₂, mul_zero] + · rw [edgeSum_eq_zero_of_not_throughAgree (leftSub F) h _ hbnd₁ + o₁ hag₁, zero_mul] + +end DisjUnion + +/-! ## RS21's sum under a relabel + +The composition's stages relabel the surviving interface, and the +colouring sum does not see the labels beyond the boundary match. +-/ + +section Relabel + +/-- The odd boundary constraint reindexes through the relabel. -/ +theorem relabel_edgeOddBoundaryMatch_iff + {α : Type} {β : Type} {W : Fragment α} (ee : α ≃ β) + (F : EdgeSubset W) + {k ℓ : ℕ} (st : GenBoundaryState k ℓ β) + (φ : (F.relabelUp ee).EdgeOddColouring ℓ) : + edgeOddBoundaryMatch (F.relabelUp ee) st φ ↔ + edgeOddBoundaryMatch F (fun a => st (ee a)) φ := by + constructor + · intro hm a c hst hmem + have hmem' : (W.relabel ee).boundaryFlag (ee a) + ∈ (F.relabelUp ee).flags := by + rw [relabel_boundaryFlag_apply ee a] + exact hmem + have hval := hm (ee a) c hst hmem' + exact (congrArg φ.val (Subtype.ext + (relabel_boundaryFlag_apply ee a).symm)).trans hval + · intro hm b c hst hmem + have hmem' : W.boundaryFlag (ee.symm b) ∈ F.flags := by + rw [show W.boundaryFlag (ee.symm b) + = (W.relabel ee).boundaryFlag b from rfl] + exact hmem + have hval := hm (ee.symm b) c + (by simp only [Equiv.apply_symm_apply]; exact hst) hmem' + exact (congrArg φ.val (Subtype.ext rfl)).trans hval + +/-- The odd colourings are the same on both sides of a relabel: the +flags and the pairing are untouched. -/ +def edgeOddRelabelEquiv {α : Type} {β : Type} {W : Fragment α} (ee : α ≃ β) + (F : EdgeSubset W) (ℓ : ℕ) : + (F.relabelUp ee).EdgeOddColouring ℓ ≃ F.EdgeOddColouring ℓ := + Equiv.refl _ + +/-- The core of a relabelled colouring is the relabelled core. -/ +theorem core_relabel_eq {α : Type} {β : Type} {W : Fragment α} (ee : α ≃ β) + (F : EdgeSubset W) {ℓ : ℕ} + (φ : (F.relabelUp ee).EdgeOddColouring ℓ) : + coreOddRelabelEquiv ee F ℓ φ.core + = (edgeOddRelabelEquiv ee F ℓ φ).core := + Subtype.ext (funext fun _ => congrArg φ.val (Subtype.ext rfl)) + +/-- **RS21's colouring sum is untouched by a relabel.** -/ +theorem relabel_edgeSum {α : Type} {β : Type} {W : Fragment α} (ee : α ≃ β) + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ β) + (hbnd : genBoundarySubsetMatches (W.relabel ee) + (F.relabelUp ee).flags st) + (hbnd' : genBoundarySubsetMatches W F.flags + (fun a => st (ee a))) + {κ : F.RelTransitionSystem} (o : κ.Orientation) : + (F.relabelUp ee).edgeSum h st hbnd (relabelOrientUp ee F o) + = F.edgeSum h (fun a => st (ee a)) hbnd' o := by + classical + unfold edgeSum + refine Fintype.sum_equiv + (Equiv.refl ((F.relabelUp ee).EvenColouring k) : + (F.relabelUp ee).EvenColouring k ≃ F.EvenColouring k) _ _ + fun ψ => ?_ + simp only [Equiv.refl_apply] + refine if_congr + (relabel_genEvenBoundaryMatch_iff ee F st hbnd hbnd' ψ) ?_ rfl + refine Fintype.sum_equiv (edgeOddRelabelEquiv ee F ℓ) _ _ + fun φ => ?_ + refine if_congr (relabel_edgeOddBoundaryMatch_iff ee F st φ) ?_ rfl + refine Finset.prod_congr rfl fun v _ => ?_ + rw [relabel_coreOddSignAt ee F o φ.core v, + relabel_coreOddListAt ee F o φ.core v, + relabel_evenColoursAt ee F ψ v, core_relabel_eq ee F φ] + +/-- **The data family pulled back along a relabel.** -/ +noncomputable def relabelDataDown {α' β' : Type} [LinearOrder α'] + [LinearOrder β'] (e : α' ≃o β') {W' : Fragment α'} + (𝒟 : DataFamily (W'.relabel e.toEquiv)) : DataFamily W' := + fun s hc hE hne => + ⟨relabelTransDown e.toEquiv (EdgeSubset.mk s hc) + (𝒟 s hc + ((relabelUp_eulerian e.toEquiv + (EdgeSubset.mk s hc)).mpr hE) + ((nonempty_canonData_relabelUp e + (EdgeSubset.mk s hc)).mpr hne)).1, + relabelOrientDown e.toEquiv (EdgeSubset.mk s hc) + (𝒟 s hc + ((relabelUp_eulerian e.toEquiv + (EdgeSubset.mk s hc)).mpr hE) + ((nonempty_canonData_relabelUp e + (EdgeSubset.mk s hc)).mpr hne)).2⟩ + +open Classical in +/-- **RS21's summand is untouched by a relabel.** -/ +theorem edgeTermAt_relabel {α' β' : Type} [LinearOrder α'] + [LinearOrder β'] (e : α' ≃o β') {W' : Fragment α'} {k ℓ : ℕ} + (h : MixedFunctional k ℓ) + (𝒟 : DataFamily (W'.relabel e.toEquiv)) + (st : GenBoundaryState k ℓ β') (s : Finset W'.Flag) (C : ℕ) : + edgeTermAt h 𝒟 st s C + = edgeTermAt h (relabelDataDown e 𝒟) (fun a => st (e a)) s + C := by + by_cases hc : ∀ f ∈ s, W'.pairing f ∈ s + · have hcU : ∀ f ∈ s, (W'.relabel e.toEquiv).pairing f ∈ s := hc + by_cases hbnd : genBoundarySubsetMatches W' s (fun a => st (e a)) + · have hbndU : genBoundarySubsetMatches (W'.relabel e.toEquiv) s + st := + (relabel_genBoundarySubsetMatches_iff e.toEquiv s st).mpr + hbnd + by_cases hE : (EdgeSubset.mk s hc : EdgeSubset W').Eulerian + · have hEU : (EdgeSubset.mk s hcU : + EdgeSubset (W'.relabel e.toEquiv)).Eulerian := + (relabelUp_eulerian e.toEquiv (EdgeSubset.mk s hc)).mpr hE + by_cases hne : Nonempty (EdgeSubset.mk s hc : + EdgeSubset W').CanonData + · have hneU : Nonempty (EdgeSubset.mk s hcU : + EdgeSubset (W'.relabel e.toEquiv)).CanonData := + (nonempty_canonData_relabelUp e + (EdgeSubset.mk s hc)).mpr hne + rw [edgeTermAt_pos h 𝒟 st hcU hbndU hEU hneU C, + edgeTermAt_pos h (relabelDataDown e 𝒟) _ hc hbnd hE hne + C] + exact congrArg (fun z => ((-1 : ℂ) ^ C) * z) + (relabel_edgeSum e.toEquiv (EdgeSubset.mk s hc) h st + hbndU hbnd + (relabelOrientDown e.toEquiv (EdgeSubset.mk s hc) + (𝒟 s hc hEU hneU).2)) + · rw [edgeTermAt_eq_zero_of_not_canon h 𝒟 st hcU + (fun hx => hne ((nonempty_canonData_relabelUp e + (EdgeSubset.mk s hc)).mp hx)) C, + edgeTermAt_eq_zero_of_not_canon h (relabelDataDown e 𝒟) + (fun a => st (e a)) hc hne C] + · rw [edgeTermAt_eq_zero_of_not_eulerian h 𝒟 st hcU + (fun hx => hE ((relabelUp_eulerian e.toEquiv + (EdgeSubset.mk s hc)).mp hx)) C, + edgeTermAt_eq_zero_of_not_eulerian h (relabelDataDown e 𝒟) + (fun a => st (e a)) hc hE C] + · rw [edgeTermAt_eq_zero_of_not_matches h 𝒟 st + (fun hx => hbnd ((relabel_genBoundarySubsetMatches_iff + e.toEquiv s st).mp hx)) C, + edgeTermAt_eq_zero_of_not_matches h (relabelDataDown e 𝒟) _ + hbnd C] + · rw [edgeTermAt_eq_zero_of_not_closed h 𝒟 st hc C, + edgeTermAt_eq_zero_of_not_closed h (relabelDataDown e 𝒟) + (fun a => st (e a)) hc C] + +end Relabel + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/Eulerian.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/Eulerian.lean new file mode 100644 index 0000000000..e618d7f6e5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/Eulerian.lean @@ -0,0 +1,219 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.PermCongr +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank + +/-! +# Eulerian edge subsets and circuit data + +The combinatorial substrate of the mixed partition function — +edge subsets, vertex degrees, the Eulerian condition, transition +systems and the circuit count — is defined in +`RS/Definitions.lean`. This module carries its transport theory: +edge subsets, the Eulerian condition, transition systems and the +circuit count all transport along fragment equivalences. +-/ + +@[expose] public section + +namespace RS + +variable {α : Type} + +namespace EdgeSubset + +variable {W : Fragment α} + +/-- Edge subsets are determined by their flag sets. -/ +@[ext] +theorem ext {F₁ F₂ : EdgeSubset W} (h : F₁.flags = F₂.flags) : + F₁ = F₂ := by + cases F₁; cases F₂; simpa using h + +/-- Transport of edge subsets along a fragment equivalence. -/ +noncomputable def transport {W₁ W₂ : Fragment α} (e : W₁.Equiv W₂) : + EdgeSubset W₁ ≃ EdgeSubset W₂ where + toFun F := + ⟨F.flags.map e.flagEquiv.toEmbedding, fun f hf => by + rw [Finset.mem_map_equiv] at hf ⊢ + rw [show e.flagEquiv.symm (W₂.pairing f) = + W₁.pairing (e.flagEquiv.symm f) from by + apply e.flagEquiv.injective + rw [Equiv.apply_symm_apply, e.pairing_comm, + Equiv.apply_symm_apply]] + exact F.pairing_mem _ hf⟩ + invFun F := + ⟨F.flags.map e.flagEquiv.symm.toEmbedding, fun f hf => by + rw [Finset.mem_map_equiv] at hf ⊢ + rw [Equiv.symm_symm, show e.flagEquiv (W₁.pairing f) = + W₂.pairing (e.flagEquiv f) from e.pairing_comm f] + exact F.pairing_mem _ hf⟩ + left_inv F := by + apply ext + ext f + simp [Finset.mem_map_equiv] + right_inv F := by + apply ext + ext f + simp [Finset.mem_map_equiv] + +/-- Transport preserves degrees at transported vertices. -/ +theorem transport_deg {W₁ W₂ : Fragment α} (e : W₁.Equiv W₂) + (F : EdgeSubset W₁) (v : W₁.Vertex) : + (transport e F).deg (e.vertexEquiv v) = F.deg v := by + let := Classical.decEq (W₂.Vertex ⊕ α) + let := Classical.decEq (W₁.Vertex ⊕ α) + unfold deg + rw [show (transport e F).flags = F.flags.map e.flagEquiv.toEmbedding + from rfl, + Finset.filter_map, Finset.card_map] + congr 1 + apply Finset.filter_congr + intro f _ + rw [Function.comp_apply, Equiv.coe_toEmbedding, e.attach_comm] + rcases W₁.attach f with w | ℓ + · simp [Sum.map, e.vertexEquiv.apply_eq_iff_eq] + · simp [Sum.map] + +/-- Transport preserves the Eulerian condition. -/ +theorem transport_eulerian {W₁ W₂ : Fragment α} (e : W₁.Equiv W₂) + (F : EdgeSubset W₁) : + (transport e F).Eulerian ↔ F.Eulerian := by + constructor <;> intro h v + · have hv := h (e.vertexEquiv v) + rwa [transport_deg] at hv + · have hv := h (e.vertexEquiv.symm v) + rw [← transport_deg e F (e.vertexEquiv.symm v), + Equiv.apply_symm_apply] at hv + exact hv + +/-- Membership in a transported edge subset. -/ +theorem mem_transport_iff {W₁ W₂ : Fragment α} (e : W₁.Equiv W₂) + (F : EdgeSubset W₁) (f : W₂.Flag) : + f ∈ (transport e F).flags ↔ e.flagEquiv.symm f ∈ F.flags := by + rw [show (transport e F).flags = F.flags.map e.flagEquiv.toEmbedding + from rfl] + exact Finset.mem_map_equiv + +/-- Transporting there and back along an equivalence is the +identity on edge subsets. -/ +theorem transport_symm_transport {W₁ W₂ : Fragment α} + (e : W₁.Equiv W₂) (F : EdgeSubset W₁) : + transport e.symm (transport e F) = F := by + ext f + rw [mem_transport_iff, mem_transport_iff] + change e.flagEquiv.symm (e.flagEquiv.symm.symm f) ∈ F.flags ↔ _ + rw [Equiv.symm_symm, Equiv.symm_apply_apply] + +/-- Transport of a transition system along a fragment +equivalence: the conjugated matching. -/ +noncomputable def TransitionSystem.transport {W₁ W₂ : Fragment α} + (e : W₁.Equiv W₂) {F : EdgeSubset W₁} (κ : F.TransitionSystem) : + (EdgeSubset.transport e F).TransitionSystem where + match_ := fun f => e.flagEquiv (κ.match_ (e.flagEquiv.symm f)) + match_invol := fun f hf => by + rw [Equiv.symm_apply_apply, + κ.match_invol _ ((mem_transport_iff e F f).mp hf), + Equiv.apply_symm_apply] + match_ne := fun f hf h => by + have := κ.match_ne _ ((mem_transport_iff e F f).mp hf) + apply this + have h2 := congrArg e.flagEquiv.symm h + rwa [Equiv.symm_apply_apply] at h2 + match_mem := fun f hf => by + rw [mem_transport_iff, Equiv.symm_apply_apply] + exact κ.match_mem _ ((mem_transport_iff e F f).mp hf) + match_vertex := fun f hf v hv => by + have hmem := (mem_transport_iff e F f).mp hf + obtain ⟨w, hw⟩ := κ.attach_internal _ hmem + have hcomm := e.attach_comm (e.flagEquiv.symm f) + rw [Equiv.apply_symm_apply, hw] at hcomm + rw [hcomm] at hv + have hwv : e.vertexEquiv w = v := by + simpa using Sum.inl.inj hv + have hmv := κ.match_vertex _ hmem w hw + have hcomm2 := e.attach_comm (κ.match_ (e.flagEquiv.symm f)) + rw [hmv] at hcomm2 + rw [hcomm2] + simp [hwv] + attach_internal := fun f hf => by + have hmem := (mem_transport_iff e F f).mp hf + obtain ⟨w, hw⟩ := κ.attach_internal _ hmem + refine ⟨e.vertexEquiv w, ?_⟩ + have hcomm := e.attach_comm (e.flagEquiv.symm f) + rw [Equiv.apply_symm_apply, hw] at hcomm + simpa using hcomm + +/-- The flag equivalence restricted to a transported edge +subset. -/ +noncomputable def transportFlagsEquiv {W₁ W₂ : Fragment α} + (e : W₁.Equiv W₂) (F : EdgeSubset W₁) : + {f : W₁.Flag // f ∈ F.flags} ≃ + {f : W₂.Flag // f ∈ (transport e F).flags} := + e.flagEquiv.subtypeEquiv (fun f => by + rw [mem_transport_iff, Equiv.symm_apply_apply]) + +/-- The transported walk permutation is the transported walk. -/ +theorem TransitionSystem.transport_walkPerm {W₁ W₂ : Fragment α} + (e : W₁.Equiv W₂) {F : EdgeSubset W₁} (κ : F.TransitionSystem) : + (κ.transport e).walkPerm = + (transportFlagsEquiv e F).permCongr κ.walkPerm := by + ext x + change e.flagEquiv (κ.match_ (e.flagEquiv.symm (W₂.pairing x.val))) = _ + rw [show ((transportFlagsEquiv e F).permCongr κ.walkPerm x).val = + e.flagEquiv (κ.match_ (W₁.pairing + (e.flagEquiv.symm x.val))) from by + simp only [Equiv.permCongr_apply, transportFlagsEquiv, + Equiv.subtypeEquiv_apply, Equiv.subtypeEquiv_symm] + rfl] + refine congrArg e.flagEquiv (congrArg κ.match_ ?_) + have hp := e.pairing_comm (e.flagEquiv.symm x.val) + rw [Equiv.apply_symm_apply] at hp + rw [← hp, Equiv.symm_apply_apply] + +/-- Transport preserves the circuit count. -/ +theorem TransitionSystem.transport_circuitCount {W₁ W₂ : Fragment α} + (e : W₁.Equiv W₂) {F : EdgeSubset W₁} (κ : F.TransitionSystem) : + (κ.transport e).circuitCount = κ.circuitCount := by + unfold TransitionSystem.circuitCount + rw [TransitionSystem.transport_walkPerm, cycleType_permCongr, + card_fixedPoints_permCongr] + +end EdgeSubset + +/-- `pmap` respects permutations of the underlying list. -/ +theorem perm_pmap {β γ : Type*} {p : β → Prop} + (f : ∀ b, p b → γ) {l₁ l₂ : List β} (hp : l₁.Perm l₂) : + ∀ (H₁ : ∀ b ∈ l₁, p b) (H₂ : ∀ b ∈ l₂, p b), + (l₁.pmap f H₁).Perm (l₂.pmap f H₂) := by + induction hp with + | nil => exact fun _ _ => List.Perm.refl _ + | cons b _ ih => exact fun _ _ => List.Perm.cons _ (ih _ _) + | swap x y l => exact fun _ _ => List.Perm.swap _ _ _ + | trans hp₁ _ ih₁ ih₂ => + exact fun H₁ H₂ => + (ih₁ H₁ (fun b hb => H₁ b (hp₁.mem_iff.mpr hb))).trans + (ih₂ (fun b hb => H₁ b (hp₁.mem_iff.mpr hb)) H₂) + +/-- Congruent proof-carrying maps followed by list-valued functions +give equal flattenings. -/ +theorem pmap_flatMap_congr {β β₁ β₂ γ : Type*} + {p₁ p₂ : β → Prop} (f₁ : ∀ b, p₁ b → β₁) (f₂ : ∀ b, p₂ b → β₂) + (G₁ : β₁ → List γ) (G₂ : β₂ → List γ) (l : List β) + (H₁ : ∀ b ∈ l, p₁ b) (H₂ : ∀ b ∈ l, p₂ b) + (hpt : ∀ b ∈ l, ∀ h₁ h₂, G₁ (f₁ b h₁) = G₂ (f₂ b h₂)) : + (l.pmap f₁ H₁).flatMap G₁ = (l.pmap f₂ H₂).flatMap G₂ := by + induction l with + | nil => rfl + | cons a t ih => + simp only [List.pmap, List.flatMap_cons] + rw [hpt a List.mem_cons_self _ _, + ih _ _ (fun b hb => hpt b (List.mem_cons_of_mem _ hb))] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ExactPairingInstance.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ExactPairingInstance.lean new file mode 100644 index 0000000000..8502843370 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ExactPairingInstance.lean @@ -0,0 +1,123 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SnakeClasses + +/-! +# The exact pairing on the strand object + +`ExactPairing ⟨1⟩ ⟨1⟩` in the skein category: coevaluation and +evaluation are the strand classes, and the zig-zag laws are the +snake identities — every structural cast in the categorical +formulation lives at equal numeral arities and collapses to the +identity class. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- Bundle maps of self-casts are the identity class. -/ +theorem bmc_finCongr_refl {n : ℕ} (h : n = n) : + bundleMapClass f (finCongr h) = + HomSpace.ofFragment f.val (strandBundle n) := by + rw [show finCongr h = _root_.Equiv.refl (Fin n) from + _root_.Equiv.ext (fun x => Fin.ext rfl)] + exact bundleMapClass_refl f n + +private instance : IsEmpty (bundleMap + (transposeEquiv 1 1)).Vertex := + inferInstanceAs (IsEmpty Empty) + +private instance : IsEmpty (permFragment + (_root_.Equiv.swap (0 : Fin 2) 1)).Vertex := + inferInstanceAs (IsEmpty Empty) + +private instance : DecidableEq (bundleMap + (transposeEquiv 1 1)).Vertex := + fun a _ => isEmptyElim a + +private instance : DecidableEq (permFragment + (_root_.Equiv.swap (0 : Fin 2) 1)).Vertex := + fun a _ => isEmptyElim a + +/-- The braiding class at one strand is the permutation-fragment +braid class. -/ +theorem braidClass_eq_bmc : + braidClass f = bundleMapClass f (transposeEquiv 1 1) := by + refine HomSpace.ofFragment_congr f ?_ + refine + { flagEquiv := _root_.Equiv.refl _ + vertexEquiv := _root_.Equiv.refl _ + attach_comm := fun g => ?_ + pairing_comm := fun g => ?_ + circles_eq := rfl } + · obtain ⟨i, b⟩ := g + have hi : i = (⟨0, Nat.zero_lt_two⟩ : Fin 2) ∨ + i = (⟨1, Nat.one_lt_two⟩ : Fin 2) := by + have h2 : i.val < 2 := i.isLt + rcases Nat.lt_or_ge i.val 1 with h | h + · exact Or.inl (Fin.ext (show i.val = 0 by omega)) + · exact Or.inr (Fin.ext (show i.val = 1 by omega)) + rcases hi with rfl | rfl <;> cases b <;> decide + · obtain ⟨i, b⟩ := g + have hi : i = (⟨0, Nat.zero_lt_two⟩ : Fin 2) ∨ + i = (⟨1, Nat.one_lt_two⟩ : Fin 2) := by + have h2 : i.val < 2 := i.isLt + rcases Nat.lt_or_ge i.val 1 with h | h + · exact Or.inl (Fin.ext (show i.val = 0 by omega)) + · exact Or.inr (Fin.ext (show i.val = 1 by omega)) + rcases hi with rfl | rfl <;> cases b <;> decide + +/-- **The exact pairing on the strand object.** -/ +noncomputable instance strandExactPairing : + ExactPairing (SkeinObj.mk 1 : SkeinObj f) (SkeinObj.mk 1) where + coevaluation' := coevClass f + evaluation' := evClass f + coevaluation_evaluation' := by + change HomSpace.comp f 1 3 1 + (HomSpace.tensor f 1 1 0 2 (idClass f) (coevClass f)) + (HomSpace.comp f 3 3 1 + (bundleMapClass f (finCongr _)) + (HomSpace.tensor f 2 0 1 1 (evClass f) (idClass f))) = + HomSpace.comp f 1 1 1 + (bundleMapClass f (finCongr _)) + (bundleMapClass f (finCongr _)) + rw [bmc_finCongr_refl, bmc_finCongr_refl, + HomSpace.comp_id_left, HomSpace.comp_id_left] + exact snake_right f + evaluation_coevaluation' := by + change HomSpace.comp f 1 3 1 + (HomSpace.tensor f 0 2 1 1 (coevClass f) (idClass f)) + (HomSpace.comp f 3 3 1 + (bundleMapClass f (finCongr _)) + (HomSpace.tensor f 1 1 2 0 (idClass f) (evClass f))) = + HomSpace.comp f 1 1 1 + (bundleMapClass f (finCongr _)) + (bundleMapClass f (finCongr _)) + rw [bmc_finCongr_refl, bmc_finCongr_refl, + HomSpace.comp_id_left, HomSpace.comp_id_left] + exact snake_left f + +/-- **Supersymmetry of the evaluation, categorical form.** -/ +theorem strand_ev_symmetry : + (β_ (SkeinObj.mk 1 : SkeinObj f) (SkeinObj.mk 1)).hom ≫ + ε_ (SkeinObj.mk 1) (SkeinObj.mk 1) = + ε_ (SkeinObj.mk 1) (SkeinObj.mk 1) := by + change HomSpace.comp f 2 2 0 + (bundleMapClass f (transposeEquiv 1 1)) (evClass f) = + evClass f + rw [← braidClass_eq_bmc] + exact braid_comp_evClass f + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FibreValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FibreValue.lean new file mode 100644 index 0000000000..4a942e4330 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FibreValue.lean @@ -0,0 +1,69 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LabelChords +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerValue + +/-! +# The fibre value: the open-sector value indexed by chord diagrams + +The signed canonical value as a function of the boundary pairing's +chord diagram: choose any system realizing the diagram (with a +path-canonical orientation) and take its signed value. Given the +paired step in value form, the choice is immaterial +(`signedValueAt_samePairing_of_value` through the faithfulness of +the diagram), and the fibre value evaluates at every realizing +system. Independence holds *within* a chord diagram, not across +diagrams: `not_throughIndependenceC` exhibits two path-canonical +data with different boundary pairings whose signed values differ. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} + +namespace EdgeSubset + +/-- Two realizing systems of one diagram share the signed value +(the fibre form of the within-pairing independence). -/ +theorem signedValueAt_of_labelChords_eq + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + (HPaired : PairedValueLedger) {k ℓ : ℕ} + (hM : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ κ' : F.RelTransitionSystem} + (h : labelChords κ = labelChords κ') : + F.signedValueAt hM st hbnd κ = + F.signedValueAt hM st hbnd κ' := + signedValueAt_samePairing_of_value HPaired hM st hbnd + (samePairing_of_labelChords h) + +open Classical in +/-- **The instantiation bridge**: the canonical choice value is the +signed value at the chosen system — the factorization interfaces +over choice values follow from their universal concrete-data forms +by instantiation. -/ +theorem throughValueC_eq_signedValueAt + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {k ℓ : ℕ} + (hM : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (hne : Nonempty F.CanonData) : + F.throughValueC hM st hbnd = + F.signedValueAt hM st hbnd (Classical.choice hne).1 := by + rw [throughValueC, dite_eq_left hne, + signedValueAt_eq hM st hbnd (Classical.choice hne).2.val + (Classical.choice hne).2.prop] + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FlagGraph.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlagGraph.lean new file mode 100644 index 0000000000..745096bce2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlagGraph.lean @@ -0,0 +1,78 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Definitions + +/-! +# The strand, and the two branches of a glue + +The flag model itself — fragments, relabelling, disjoint union, and +the single-pair gluing primitive — is defined in +`RS/Definitions.lean`. This module carries the strand (the identity +2-fragment), the two branch equations of `gluePair`, and the sanity +checks that closing the strand onto itself yields one free circle +and no flags. +-/ + +@[expose] public section + +namespace RS + +namespace Fragment + +variable {α β : Type} + +/-! ### The strand -/ + +/-- The strand: a single edge with two boundary flags and no internal +vertices. The identity 2-fragment. -/ +def strand : Fragment (Fin 2) where + Flag := Fin 2 + Vertex := Empty + attach := fun f => Sum.inr f + pairing := fun f => ⟨1 - f.val, by omega⟩ + pairing_invol := fun f => by ext; simp; omega + pairing_ne := fun f => by + intro h + have := congr_arg Fin.val h + simp at this + omega + boundaryFlag := id + attach_boundaryFlag := fun ℓ => rfl + eq_boundaryFlag := fun ℓ f h => Sum.inr.inj h + circles := 0 + +/-! ### The two branches of a glue -/ + +/-- The closed branch of `gluePair`. -/ +theorem gluePair_eq_closed {W : Fragment α} {i j : α} (hij : i ≠ j) + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) : + W.gluePair i j hij = W.gluePairClosed i j hclosed := + dite_eq_left hclosed + +/-- The open branch of `gluePair`. -/ +theorem gluePair_eq_open {W : Fragment α} {i j : α} (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) : + W.gluePair i j hij = W.gluePairOpen i j hij hopen := + dite_eq_right hopen + +/-! ### Sanity checks -/ + +/-- Closing the strand onto itself yields one free circle. -/ +example : + (strand.gluePair 0 1 (by decide)).circles = 1 := by + rw [gluePair, dite_eq_left (by decide)] + rfl + +/-- Closing the strand onto itself leaves no flags. -/ +example : (strand.gluePair 0 1 (by decide)).Flag → False := by + decide + +end Fragment + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignForm.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignForm.lean new file mode 100644 index 0000000000..63cbb7da7d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignForm.lean @@ -0,0 +1,224 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignProduct + +/-! +# The closed form of the flip-sign product + +Each label `a` with `n` instances in `flipLabels L` contributes +`(oddPartnerSign ℓ (f a))^n * (-1)^(n*(n-1)/2)` to the sign +product of the flip sequence, so a sequence in which every label +occurs evenly contributes exactly `(−1)^length`. That is the sign +bookkeeping the paired step of Proposition 3 runs on. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} {ℓ : ℕ} + +/-- The empty flip sequence contributes no sign. -/ +theorem flipSignProd_nil (f : α → Fin (2 * ℓ)) : + flipSignProd f ([] : List (α × α)) = 1 := rfl + +/-- One more flip contributes its two port signs, at the colours +reached so far. -/ +theorem flipSignProd_cons (f : α → Fin (2 * ℓ)) (p : α × α) + (L : List (α × α)) : + flipSignProd f (p :: L) = + oddPartnerSign ℓ (f p.1) * oddPartnerSign ℓ (f p.2) * + flipSignProd (flipColours f p) L := rfl + +/-- The flipped colour of a participating label has the opposite +sign. -/ +theorem oddPartnerSign_flipColours_of_mem (f : α → Fin (2 * ℓ)) + (p : α × α) {a : α} (ha : a = p.1 ∨ a = p.2) : + oddPartnerSign ℓ (flipColours f p a) = -oddPartnerSign ℓ (f a) := by + simp only [flipColours, ite_eq_left ha] + exact oddPartnerSign_oddPartner ℓ (f a) + +/-- A non-participating label keeps its colour. -/ +theorem flipColours_of_not_mem (f : α → Fin (2 * ℓ)) + (p : α × α) {a : α} (ha : ¬(a = p.1 ∨ a = p.2)) : + flipColours f p a = f a := by + simp only [flipColours, ite_eq_right ha] + +/-- The triangular-number increment `T (n+1) = T n + n`. -/ +private theorem tri_succ (n : ℕ) : + (n + 1) * n / 2 = n * (n - 1) / 2 + n := by + rcases n with _ | m + · rfl + · obtain ⟨k, hk⟩ := Nat.even_mul_succ_self m + have h1 : (m + 1 + 1) * (m + 1) = m * (m + 1) + 2 * (m + 1) := by + ring + have h2 : m + 1 - 1 = m := by omega + rw [h2, h1, mul_comm (m + 1) m, hk] + omega + +/-- For even `n` the triangular number `n*(n-1)/2` has the parity +of `n/2`. -/ +private theorem tri_mod_two {n : ℕ} (hn : n % 2 = 0) : + n * (n - 1) / 2 % 2 = n / 2 % 2 := by + obtain ⟨k, hk⟩ : ∃ k, n = 2 * k := ⟨n / 2, by omega⟩ + subst hk + rcases k with _ | m + · rfl + · have h0 : 2 * (m + 1) - 1 = 2 * m + 1 := by omega + have h1 : 2 * (m + 1) * (2 * (m + 1) - 1) + = 2 * ((m + 1) * (2 * m + 1)) := by + rw [h0]; ring + rw [h1, Nat.mul_div_cancel_left _ (by norm_num : (0:ℕ) < 2)] + have h2 : 2 * (m + 1) / 2 = m + 1 := by omega + rw [h2, Nat.mul_mod] + have h3 : (2 * m + 1) % 2 = 1 := by omega + rw [h3, mul_one] + omega + +/-- Each flip contributes two label instances. -/ +theorem flipLabels_length (L : List (α × α)) : + (flipLabels L).length = 2 * L.length := by + induction L with + | nil => rfl + | cons p L ih => + rw [flipLabels_cons, List.length_cons, List.length_cons, ih, + List.length_cons] + omega + +/-- The per-label algebra of one flip step. -/ +private theorem step_algebra (x : ℤ) (n : ℕ) : + x ^ (n + 1) * (-1 : ℤ) ^ ((n + 1) * n / 2) = + x * ((-x) ^ n * (-1) ^ (n * (n - 1) / 2)) := by + rw [tri_succ, neg_pow, pow_add, pow_succ] + ring + +open scoped Classical in +/-- **The closed form of the flip-sign product**: each label `a` +with `n` instances in `flipLabels L` contributes the initial sign +to the `n`-th power times the triangular-number sign. -/ +theorem flipSignProd_formula (f : α → Fin (2 * ℓ)) + (L : List (α × α)) (hd : ∀ p ∈ L, p.1 ≠ p.2) : + flipSignProd f L = + ∏ a ∈ (flipLabels L).toFinset, + (oddPartnerSign ℓ (f a)) ^ ((flipLabels L).count a) * + (-1) ^ (((flipLabels L).count a) * + ((flipLabels L).count a - 1) / 2) := by + induction L generalizing f with + | nil => simp [flipSignProd_nil, flipLabels_nil] + | cons p L ih => + have hij : p.1 ≠ p.2 := hd p (by simp) + have hd' : ∀ q ∈ L, q.1 ≠ q.2 := fun q hq => hd q (by simp [hq]) + rw [flipSignProd_cons, ih (flipColours f p) hd', flipLabels_cons, + List.toFinset_cons, List.toFinset_cons] + have hsub : (flipLabels L).toFinset ⊆ + insert p.1 (insert p.2 (flipLabels L).toFinset) := fun a ha => + Finset.mem_insert_of_mem (Finset.mem_insert_of_mem ha) + have hone : ∀ a ∈ insert p.1 (insert p.2 (flipLabels L).toFinset), + a ∉ (flipLabels L).toFinset → + oddPartnerSign ℓ (flipColours f p a) ^ ((flipLabels L).count a) * + (-1 : ℤ) ^ ((flipLabels L).count a * + ((flipLabels L).count a - 1) / 2) = 1 := by + intro a _ ha + have hz : (flipLabels L).count a = 0 := + List.count_eq_zero.mpr fun hmem => ha (List.mem_toFinset.mpr hmem) + rw [hz] + norm_num + rw [Finset.prod_subset hsub hone] + have hfac : ∀ a ∈ insert p.1 (insert p.2 (flipLabels L).toFinset), + oddPartnerSign ℓ (f a) ^ ((p.1 :: p.2 :: flipLabels L).count a) * + (-1 : ℤ) ^ ((p.1 :: p.2 :: flipLabels L).count a * + ((p.1 :: p.2 :: flipLabels L).count a - 1) / 2) = + (if a = p.1 then oddPartnerSign ℓ (f p.1) else 1) * + ((if a = p.2 then oddPartnerSign ℓ (f p.2) else 1) * + (oddPartnerSign ℓ (flipColours f p a) ^ + ((flipLabels L).count a) * + (-1 : ℤ) ^ ((flipLabels L).count a * + ((flipLabels L).count a - 1) / 2))) := by + intro a _ + by_cases h1 : a = p.1 + · subst h1 + have hc : (p.1 :: p.2 :: flipLabels L).count p.1 + = (flipLabels L).count p.1 + 1 := by + rw [List.count_cons_self, List.count_cons_of_ne (Ne.symm hij)] + rw [hc, ite_eq_left rfl, ite_eq_right hij, + oddPartnerSign_flipColours_of_mem f p (Or.inl rfl), one_mul, + Nat.add_sub_cancel] + exact step_algebra _ _ + · by_cases h2 : a = p.2 + · subst h2 + have hc : (p.1 :: p.2 :: flipLabels L).count p.2 + = (flipLabels L).count p.2 + 1 := by + rw [List.count_cons_of_ne hij, List.count_cons_self] + rw [hc, ite_eq_right h1, ite_eq_left rfl, + oddPartnerSign_flipColours_of_mem f p (Or.inr rfl), one_mul, + Nat.add_sub_cancel] + exact step_algebra _ _ + · have hc : (p.1 :: p.2 :: flipLabels L).count a + = (flipLabels L).count a := by + rw [List.count_cons_of_ne (Ne.symm h1), + List.count_cons_of_ne (Ne.symm h2)] + rw [hc, ite_eq_right h1, ite_eq_right h2, + flipColours_of_not_mem f p (not_or.mpr ⟨h1, h2⟩), one_mul, + one_mul] + refine Eq.trans ?_ (Finset.prod_congr rfl hfac).symm + conv_rhs => rw [Finset.prod_mul_distrib, Finset.prod_mul_distrib, + Finset.prod_ite_eq', Finset.prod_ite_eq'] + rw [ite_eq_left (Finset.mem_insert_self p.1 _), + ite_eq_left (Finset.mem_insert_of_mem (Finset.mem_insert_self p.2 _))] + ring + +open scoped Classical in +/-- **The even corollary**: a flip sequence in which every label +occurs an even number of times has sign product `(−1)^length`. -/ +theorem flipSignProd_of_even (f : α → Fin (2 * ℓ)) + (L : List (α × α)) (hd : ∀ p ∈ L, p.1 ≠ p.2) + (heven : ∀ a, (flipLabels L).count a % 2 = 0) : + flipSignProd f L = (-1) ^ L.length := by + rw [flipSignProd_formula f L hd] + have h1 : ∀ a ∈ (flipLabels L).toFinset, + oddPartnerSign ℓ (f a) ^ ((flipLabels L).count a) * + (-1 : ℤ) ^ ((flipLabels L).count a * + ((flipLabels L).count a - 1) / 2) + = (-1 : ℤ) ^ ((flipLabels L).count a * + ((flipLabels L).count a - 1) / 2) := by + intro a _ + have he := heven a + obtain ⟨k, hk⟩ : ∃ k, (flipLabels L).count a = 2 * k := + ⟨(flipLabels L).count a / 2, by omega⟩ + rw [hk, pow_mul, pow_two, oddPartnerSign_mul_self, one_pow, one_mul, + ← hk] + rw [Finset.prod_congr rfl h1, Finset.prod_pow_eq_pow_sum] + have hcard : ∑ a ∈ (flipLabels L).toFinset, (flipLabels L).count a + = (flipLabels L).length := by + simp + have hsum2 : ∑ a ∈ (flipLabels L).toFinset, + ((flipLabels L).count a / 2) = L.length := by + have h2 : ∑ a ∈ (flipLabels L).toFinset, (flipLabels L).count a + = 2 * ∑ a ∈ (flipLabels L).toFinset, + ((flipLabels L).count a / 2) := by + rw [Finset.mul_sum] + refine Finset.sum_congr rfl fun a _ => ?_ + have he := heven a + omega + have hlen := flipLabels_length L + omega + have hmod : (∑ a ∈ (flipLabels L).toFinset, + ((flipLabels L).count a * ((flipLabels L).count a - 1) / 2)) % 2 + = L.length % 2 := by + rw [Finset.sum_nat_mod] + have h3 : ∀ a ∈ (flipLabels L).toFinset, + ((flipLabels L).count a * ((flipLabels L).count a - 1) / 2) % 2 + = ((flipLabels L).count a / 2) % 2 := + fun a _ => tri_mod_two (heven a) + rw [Finset.sum_congr rfl h3, ← Finset.sum_nat_mod, hsum2] + rw [neg_one_pow_eq_pow_mod_two, hmod, ← neg_one_pow_eq_pow_mod_two] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignProduct.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignProduct.lean new file mode 100644 index 0000000000..053b8859e0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignProduct.lean @@ -0,0 +1,79 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StateFlipSet + +/-! +# The sign product of a flip sequence + +The port signs of a sequence of chain flips, at the evolving +colours: the closed form is a per-label product of the initial +sign to the instance count times a triangular-number sign, so a +sequence in which every label occurs evenly contributes exactly +`(−1)^length`. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} {ℓ : ℕ} + +open scoped Classical in +/-- The colour relabel of one flip. -/ +noncomputable def flipColours (f : α → Fin (2 * ℓ)) + (p : α × α) : α → Fin (2 * ℓ) := + fun a => if a = p.1 ∨ a = p.2 then oddPartner ℓ (f a) else f a + +/-- The accumulated port-sign product of a flip sequence, at the +evolving colours. -/ +noncomputable def flipSignProd (f : α → Fin (2 * ℓ)) : + List (α × α) → ℤ + | [] => 1 + | p :: L => + oddPartnerSign ℓ (f p.1) * oddPartnerSign ℓ (f p.2) * + flipSignProd (flipColours f p) L + +/-- The label instances of a flip sequence. -/ +def flipLabels (L : List (α × α)) : List α := + L.flatMap (fun p => [p.1, p.2]) + +/-- No flips list no labels. -/ +theorem flipLabels_nil : flipLabels ([] : List (α × α)) = [] := rfl + +/-- One more flip lists its two labels first. -/ +theorem flipLabels_cons (p : α × α) (L : List (α × α)) : + flipLabels (p :: L) = p.1 :: p.2 :: flipLabels L := rfl + +variable {k : ℕ} + +open Classical in +/-- The labels with odd instance count. -/ +noncomputable def oddCountLabels (L : List (α × α)) : Finset α := + (flipLabels L).toFinset.filter + (fun a => (flipLabels L).count a % 2 = 1) + +open Classical in +/-- A label counts as odd exactly when it occurs an odd number of +times — the labels the fold has actually moved. -/ +theorem mem_oddCountLabels {L : List (α × α)} {a : α} : + a ∈ oddCountLabels L ↔ (flipLabels L).count a % 2 = 1 := by + unfold oddCountLabels + rw [Finset.mem_filter] + constructor + · rintro ⟨-, h⟩ + exact h + · intro h + refine ⟨List.mem_toFinset.mpr ?_, h⟩ + by_contra hmem + rw [List.count_eq_zero_of_not_mem hmem] at h + cases h + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FourLabelParity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FourLabelParity.lean new file mode 100644 index 0000000000..b18504ee93 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FourLabelParity.lean @@ -0,0 +1,125 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CrossingDelta + +/-! +# The four-label parity identities + +The per-step sign parity of the canonical-route ledger reduces to two +pure order-combinatorics identities on four distinct labels: `x`, `xb` +(old partners) and `y`, `yb` (old partners), the step re-pairing to +the new chords `{x, y}` and `{xb, yb}`. The canonical direction at a +`u`-end is "`u`'s old partner `< u`", and the step is separated +exactly when the directions at the `x`-end and the `y`-end differ. +In the separated case the two anti-canonicality indicators of the new +chords (each read at its recorded end) plus the step's intrinsic sign +match the crossing change mod 2; in the non-separated case the +`y`-side directions are toggled by the anchor flip, whose own flip +cancels the intrinsic sign, leaving the bare toggled count. + +Both identities are pure order case-bashes: six `Ne.lt_or_lt` splits, +transitivity pruning of the intransitive tournaments (a tournament on +four vertices is transitive iff it has no directed triangle), and a +uniform decision of all indicators from the six resolved comparisons. +-/ + +@[expose] public section + +/- the closing `simp` argument list is shared by all 64 order +branches, and each branch uses a different subset of it -/ + +namespace RS + + + +variable {α : Type} + +open scoped Classical in +/-- **The separated four-label parity identity**: when the canonical +directions at the `x`-end and the `y`-end differ, the two +anti-canonicality indicators of the new chords plus the intrinsic +sign of the step match, mod 2, the crossing change of the re-paired +chords. -/ +theorem fourLabel_parity_sep [LinearOrder α] + {x xb y yb : α} + (hxxb : x ≠ xb) (hyyb : y ≠ yb) (hxy : x ≠ y) (hxyb : x ≠ yb) + (hxby : xb ≠ y) (hxbyb : xb ≠ yb) + (hsep : (xb < x) ≠ (yb < y)) : + ((if (if x < y then xb < x else yb < y) then 1 else 0) + + (if (if xb < yb then x < xb else y < yb) then 1 else 0) + + 1) % 2 = + ((if chordPairCrossSym (x, xb) (y, yb) then 1 else 0) + + (if chordPairCrossSym (x, y) (xb, yb) then 1 else 0)) % 2 := by + rcases lt_or_gt_of_ne hxxb with h1 | h1 <;> + rcases lt_or_gt_of_ne hyyb with h2 | h2 <;> + rcases lt_or_gt_of_ne hxy with h3 | h3 <;> + rcases lt_or_gt_of_ne hxyb with h4 | h4 <;> + rcases lt_or_gt_of_ne hxby with h5 | h5 <;> + rcases lt_or_gt_of_ne hxbyb with h6 | h6 <;> + first + | exact absurd (lt_trans h1 h5) (lt_asymm h3) + | exact absurd (lt_trans h3 h5) (lt_asymm h1) + | exact absurd (lt_trans h1 h6) (lt_asymm h4) + | exact absurd (lt_trans h4 h6) (lt_asymm h1) + | exact absurd (lt_trans h3 h2) (lt_asymm h4) + | exact absurd (lt_trans h4 h2) (lt_asymm h3) + | exact absurd (lt_trans h5 h2) (lt_asymm h6) + | exact absurd (lt_trans h6 h2) (lt_asymm h5) + | exact absurd (propext (iff_of_false (lt_asymm h1) (lt_asymm h2))) + hsep + | exact absurd (propext (iff_of_true h1 h2)) hsep + | simp [chordPairCrossSym, ChordPairCross, + gt_iff_lt.mp h1, gt_iff_lt.mp h2, gt_iff_lt.mp h3, + gt_iff_lt.mp h4, gt_iff_lt.mp h5, gt_iff_lt.mp h6, + le_of_lt h1, le_of_lt h2, le_of_lt h3, + le_of_lt h6, + lt_asymm h1, lt_asymm h2, lt_asymm h3, lt_asymm h4, + lt_asymm h5, lt_asymm h6] + +open scoped Classical in +/-- **The non-separated four-label parity identity**: when the +canonical directions at the `x`-end and the `y`-end agree, the +anchor flip toggles the `y`-side directions and cancels the +intrinsic sign, so the bare toggled anti-canonicality count matches, +mod 2, the crossing change of the re-paired chords. -/ +theorem fourLabel_parity_nonsep [LinearOrder α] + {x xb y yb : α} + (hxxb : x ≠ xb) (hyyb : y ≠ yb) (hxy : x ≠ y) (hxyb : x ≠ yb) + (hxby : xb ≠ y) (hxbyb : xb ≠ yb) + (hsame : (xb < x) = (yb < y)) : + ((if (if x < y then xb < x else ¬ (yb < y)) then 1 else 0) + + (if (if xb < yb then x < xb else ¬ (y < yb)) then 1 else 0)) % 2 = + ((if chordPairCrossSym (x, xb) (y, yb) then 1 else 0) + + (if chordPairCrossSym (x, y) (xb, yb) then 1 else 0)) % 2 := by + rcases lt_or_gt_of_ne hxxb with h1 | h1 <;> + rcases lt_or_gt_of_ne hyyb with h2 | h2 <;> + rcases lt_or_gt_of_ne hxy with h3 | h3 <;> + rcases lt_or_gt_of_ne hxyb with h4 | h4 <;> + rcases lt_or_gt_of_ne hxby with h5 | h5 <;> + rcases lt_or_gt_of_ne hxbyb with h6 | h6 <;> + first + | exact absurd (lt_trans h1 h5) (lt_asymm h3) + | exact absurd (lt_trans h3 h5) (lt_asymm h1) + | exact absurd (lt_trans h1 h6) (lt_asymm h4) + | exact absurd (lt_trans h4 h6) (lt_asymm h1) + | exact absurd (lt_trans h3 h2) (lt_asymm h4) + | exact absurd (lt_trans h4 h2) (lt_asymm h3) + | exact absurd (lt_trans h5 h2) (lt_asymm h6) + | exact absurd (lt_trans h6 h2) (lt_asymm h5) + | exact absurd (cast hsame.symm h2) (lt_asymm h1) + | exact absurd (cast hsame h1) (lt_asymm h2) + | simp [chordPairCrossSym, ChordPairCross, + gt_iff_lt.mp h1, gt_iff_lt.mp h2, gt_iff_lt.mp h3, + gt_iff_lt.mp h4, gt_iff_lt.mp h5, gt_iff_lt.mp h6, + le_of_lt h1, le_of_lt h2, le_of_lt h3, + le_of_lt h6, + lt_asymm h1, lt_asymm h2, lt_asymm h3, lt_asymm h4, + lt_asymm h5, lt_asymm h6] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean new file mode 100644 index 0000000000..7d44341cac --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean @@ -0,0 +1,387 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Composition + +/-! +# Isomorphism theory of fragments + +An equivalence of fragments `Fragment.Equiv W₁ W₂` (defined in +`RS/Definitions.lean`) is a pair of type equivalences on flags and +vertices commuting with attachment, pairing, and boundary-flag +data, preserving the circle count. This module proves the +equivalences form a groupoid (refl, symm, trans) and are +congruences for the fragment operations: relabelling, disjoint +union, and single-pair gluing. +-/ + +@[expose] public section + +namespace RS + +namespace Fragment + +variable {α β : Type} + +namespace Equiv + +variable {W₁ W₂ W₃ : Fragment α} + +/-- The flag equivalence sends boundary flags to boundary flags. -/ +theorem boundaryFlag_comm (e : Equiv W₁ W₂) (ℓ : α) : + e.flagEquiv (W₁.boundaryFlag ℓ) = W₂.boundaryFlag ℓ := by + apply W₂.eq_boundaryFlag ℓ + rw [e.attach_comm] + simp [W₁.attach_boundaryFlag] + +/-- The identity equivalence. -/ +def refl (W : Fragment α) : Equiv W W where + flagEquiv := _root_.Equiv.refl _ + vertexEquiv := _root_.Equiv.refl _ + attach_comm := fun f => by + change W.attach f = (W.attach f).map (_root_.Equiv.refl _) id + rcases W.attach f with v | ℓ <;> simp + pairing_comm := fun _ => rfl + circles_eq := rfl + +/-- The inverse equivalence. -/ +def symm (e : Equiv W₁ W₂) : Equiv W₂ W₁ where + flagEquiv := e.flagEquiv.symm + vertexEquiv := e.vertexEquiv.symm + attach_comm := fun f => by + have h := e.attach_comm (e.flagEquiv.symm f) + simp only [Equiv.apply_symm_apply] at h + rw [h] + rcases W₁.attach (e.flagEquiv.symm f) with v | ℓ <;> simp + pairing_comm := fun f => by + have h := e.pairing_comm (e.flagEquiv.symm f) + simp only [Equiv.apply_symm_apply] at h + rw [← h] + simp + circles_eq := e.circles_eq.symm + +/-- The composite equivalence. -/ +def trans (e₁ : Equiv W₁ W₂) (e₂ : Equiv W₂ W₃) : Equiv W₁ W₃ where + flagEquiv := e₁.flagEquiv.trans e₂.flagEquiv + vertexEquiv := e₁.vertexEquiv.trans e₂.vertexEquiv + attach_comm := fun f => by + simp only [Equiv.trans_apply, Equiv.coe_trans] + rw [e₂.attach_comm, e₁.attach_comm] + rcases W₁.attach f with v | ℓ <;> simp + pairing_comm := fun f => by + simp only [Equiv.trans_apply] + rw [e₁.pairing_comm, e₂.pairing_comm] + circles_eq := e₁.circles_eq.trans e₂.circles_eq + +/-! ### Congruences -/ + +/-- Relabelling commutes with fragment equivalence. -/ +def relabelCongr (e : Equiv W₁ W₂) (σ : α ≃ β) : + Equiv (W₁.relabel σ) (W₂.relabel σ) where + flagEquiv := e.flagEquiv + vertexEquiv := e.vertexEquiv + attach_comm := fun f => by + -- The goal involves `(W.relabel σ).attach` which unfolds to + -- `(W.attach f).map id σ`. Abstracting over the Sum value + -- avoids type-level transparency mismatches with `rw`. + have h := e.attach_comm f + suffices key : ∀ (a : W₂.Vertex ⊕ α) (b : W₁.Vertex ⊕ α), + a = b.map e.vertexEquiv id → + a.map id σ = (b.map id σ).map e.vertexEquiv id from + key _ _ h + intro a b hab + subst hab + rcases b with v | ℓ <;> rfl + pairing_comm := fun f => e.pairing_comm f + circles_eq := e.circles_eq + +variable {V₁ V₂ : Fragment β} + +/-- Disjoint union commutes with fragment equivalence. -/ +def disjUnionCongr (e₁ : Equiv W₁ W₂) (e₂ : Equiv V₁ V₂) : + Equiv (W₁.disjUnion V₁) (W₂.disjUnion V₂) where + flagEquiv := _root_.Equiv.sumCongr e₁.flagEquiv e₂.flagEquiv + vertexEquiv := _root_.Equiv.sumCongr e₁.vertexEquiv e₂.vertexEquiv + attach_comm := fun f => by + cases f with + | inl g => + have h := e₁.attach_comm g + suffices key : ∀ (a : W₂.Vertex ⊕ α) (b : W₁.Vertex ⊕ α), + a = b.map e₁.vertexEquiv id → + a.map Sum.inl Sum.inl = + (b.map Sum.inl Sum.inl).map + (_root_.Equiv.sumCongr e₁.vertexEquiv e₂.vertexEquiv) + id from + key _ _ h + intro a b hab + subst hab + rcases b with v | ℓ <;> rfl + | inr g => + have h := e₂.attach_comm g + suffices key : ∀ (a : V₂.Vertex ⊕ β) (b : V₁.Vertex ⊕ β), + a = b.map e₂.vertexEquiv id → + a.map Sum.inr Sum.inr = + (b.map Sum.inr Sum.inr).map + (_root_.Equiv.sumCongr e₁.vertexEquiv e₂.vertexEquiv) + id from + key _ _ h + intro a b hab + subst hab + rcases b with v | ℓ <;> rfl + pairing_comm := fun f => by + cases f with + | inl g => + change Sum.inl (e₁.flagEquiv (W₁.pairing g)) = + Sum.inl (W₂.pairing (e₁.flagEquiv g)) + rw [e₁.pairing_comm] + | inr g => + change Sum.inr (e₂.flagEquiv (V₁.pairing g)) = + Sum.inr (V₂.pairing (e₂.flagEquiv g)) + rw [e₂.pairing_comm] + circles_eq := by + change W₁.circles + V₁.circles = W₂.circles + V₂.circles + rw [e₁.circles_eq, e₂.circles_eq] + +/-! ### Glue-pair congruence -/ + +section GluePairCongr + +variable {i j : α} (e : Equiv W₁ W₂) + +/-- The flag equivalence restricts to surviving flags. -/ +def survivingFlagEquiv (e : Equiv W₁ W₂) (i j : α) : + SurvivingFlag W₁ i j ≃ SurvivingFlag W₂ i j where + toFun f := ⟨e.flagEquiv f.val, by + refine ⟨fun h => f.prop.1 ?_, fun h => f.prop.2 ?_⟩ + · exact e.flagEquiv.injective (h.trans (e.boundaryFlag_comm i).symm) + · exact e.flagEquiv.injective (h.trans (e.boundaryFlag_comm j).symm)⟩ + invFun f := ⟨e.flagEquiv.symm f.val, by + refine ⟨fun h => f.prop.1 ?_, fun h => f.prop.2 ?_⟩ + · have h1 := congrArg e.flagEquiv h + simp only [ne_eq, Equiv.apply_symm_apply] at h1 + rw [e.boundaryFlag_comm i] at h1 + exact h1 + · have h1 := congrArg e.flagEquiv h + simp only [ne_eq, Equiv.apply_symm_apply] at h1 + rw [e.boundaryFlag_comm j] at h1 + exact h1⟩ + left_inv f := Subtype.ext (by simp) + right_inv f := Subtype.ext (by simp) + +/-- The glue case (closed vs open) is preserved by the equivalence. -/ +theorem gluePair_case_preserved (e : Equiv W₁ W₂) (i j : α) : + W₁.pairing (W₁.boundaryFlag i) = W₁.boundaryFlag j ↔ + W₂.pairing (W₂.boundaryFlag i) = W₂.boundaryFlag j := by + constructor + · intro h + have h1 := e.pairing_comm (W₁.boundaryFlag i) + rw [h, e.boundaryFlag_comm i, e.boundaryFlag_comm j] at h1 + exact h1.symm + · intro h + have h1 := e.pairing_comm (W₁.boundaryFlag i) + rw [e.boundaryFlag_comm i, h, ← e.boundaryFlag_comm j] at h1 + exact e.flagEquiv.injective h1 + +/-- The surviving-flag equivalence commutes with `glueAttachOn`. Both +scrutinees are variables, so each of the four cases reduces. -/ +private theorem survivingFlagEquiv_glueAttachOn (e : Equiv W₁ W₂) + (i j : α) (f : SurvivingFlag W₁ i j) + (s₁ : W₁.Vertex ⊕ α) (h₁ : W₁.attach f.val = s₁) + (s₂ : W₂.Vertex ⊕ α) + (h₂ : W₂.attach (e.survivingFlagEquiv i j f).val = s₂) : + glueAttachOn W₂ i j (e.survivingFlagEquiv i j f) s₂ h₂ = + (glueAttachOn W₁ i j f s₁ h₁).map e.vertexEquiv id := by + have hatt := e.attach_comm f.val + change W₂.attach (e.flagEquiv f.val) = s₂ at h₂ + rw [h₁] at hatt + rw [h₂] at hatt + cases s₁ <;> cases s₂ <;> simp_all [glueAttachOn] + +/-- The surviving-flag equivalence commutes with glueAttach. -/ +private theorem survivingFlagEquiv_glueAttach (e : Equiv W₁ W₂) + (i j : α) (f : SurvivingFlag W₁ i j) : + glueAttach W₂ i j (e.survivingFlagEquiv i j f) = + (glueAttach W₁ i j f).map e.vertexEquiv id := + e.survivingFlagEquiv_glueAttachOn i j f _ rfl _ rfl + +/-- The closed case: the flag equivalence restricts to a +`gluePairClosed` congruence. -/ +def gluePairClosedCongr + (h₁ : W₁.pairing (W₁.boundaryFlag i) = W₁.boundaryFlag j) + (h₂ : W₂.pairing (W₂.boundaryFlag i) = W₂.boundaryFlag j) : + Equiv (W₁.gluePairClosed i j h₁) (W₂.gluePairClosed i j h₂) where + flagEquiv := e.survivingFlagEquiv i j + vertexEquiv := e.vertexEquiv + attach_comm := fun f => by exact e.survivingFlagEquiv_glueAttach i j f + pairing_comm := fun f => by + apply Subtype.ext + change e.flagEquiv (W₁.pairing f.val) = W₂.pairing (e.flagEquiv f.val) + exact e.pairing_comm f.val + circles_eq := by + change W₁.circles + 1 = W₂.circles + 1 + rw [e.circles_eq] + +/-! #### Rewire commutation -/ + +/-- The `.val` of a `rewire` in the first branch (partner is `i`'s +boundary flag). -/ +private theorem rewire_val_of_eq_left {W : Fragment α} {i j : α} + {hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j} + {f : SurvivingFlag W i j} + (hfi : W.pairing f.val = W.boundaryFlag i) : + (rewire hopen f).val = W.pairing (W.boundaryFlag j) := by + unfold rewire; simp [dite_eq_left hfi] + +/-- The `.val` of a `rewire` in the second branch (partner is `j`'s +boundary flag). -/ +private theorem rewire_val_of_eq_right {W : Fragment α} {i j : α} + {hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j} + {f : SurvivingFlag W i j} + (hfi : W.pairing f.val ≠ W.boundaryFlag i) + (hfj : W.pairing f.val = W.boundaryFlag j) : + (rewire hopen f).val = W.pairing (W.boundaryFlag i) := by + unfold rewire; simp [dite_eq_right hfi, dite_eq_left hfj] + +/-- The `.val` of a `rewire` in the third branch (partner is +neither boundary flag). -/ +private theorem rewire_val_of_ne {W : Fragment α} {i j : α} + {hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j} + {f : SurvivingFlag W i j} + (hfi : W.pairing f.val ≠ W.boundaryFlag i) + (hfj : W.pairing f.val ≠ W.boundaryFlag j) : + (rewire hopen f).val = W.pairing f.val := by + unfold rewire; simp [dite_eq_right hfi, dite_eq_right hfj] + +/-- The open case: the flag equivalence commutes with rewiring. -/ +private theorem survivingFlagEquiv_rewire + (hopen₁ : W₁.pairing (W₁.boundaryFlag i) ≠ W₁.boundaryFlag j) + (hopen₂ : W₂.pairing (W₂.boundaryFlag i) ≠ W₂.boundaryFlag j) + (f : SurvivingFlag W₁ i j) : + e.survivingFlagEquiv i j (rewire hopen₁ f) = + rewire hopen₂ (e.survivingFlagEquiv i j f) := by + apply Subtype.ext + set g := e.survivingFlagEquiv i j f + have hgval : g.val = e.flagEquiv f.val := rfl + -- ═══════ CASE: f's partner is the boundary flag of i ═══════ + by_cases hfi : W₁.pairing f.val = W₁.boundaryFlag i + · have hfi₂ : W₂.pairing g.val = W₂.boundaryFlag i := by + rw [hgval, ← e.pairing_comm, hfi, e.boundaryFlag_comm] + change e.flagEquiv (rewire hopen₁ f).val = (rewire hopen₂ g).val + rw [rewire_val_of_eq_left hfi, rewire_val_of_eq_left hfi₂] + rw [e.pairing_comm, e.boundaryFlag_comm] + -- ═══════ CASE: f's partner is the boundary flag of j ═══════ + · by_cases hfj : W₁.pairing f.val = W₁.boundaryFlag j + · have hfi₂ : W₂.pairing g.val ≠ W₂.boundaryFlag i := by + rw [hgval]; intro h + apply hfi + rw [← e.boundaryFlag_comm i, ← e.pairing_comm] at h + exact e.flagEquiv.injective h + have hfj₂ : W₂.pairing g.val = W₂.boundaryFlag j := by + rw [hgval, ← e.pairing_comm, hfj, e.boundaryFlag_comm] + change e.flagEquiv (rewire hopen₁ f).val = (rewire hopen₂ g).val + rw [rewire_val_of_eq_right hfi hfj, + rewire_val_of_eq_right hfi₂ hfj₂] + rw [e.pairing_comm, e.boundaryFlag_comm] + -- ═══════ CASE: f's partner is neither boundary flag ═══════ + · have hfi₂ : W₂.pairing g.val ≠ W₂.boundaryFlag i := by + rw [hgval]; intro h + apply hfi + rw [← e.boundaryFlag_comm i, ← e.pairing_comm] at h + exact e.flagEquiv.injective h + have hfj₂ : W₂.pairing g.val ≠ W₂.boundaryFlag j := by + rw [hgval]; intro h + apply hfj + rw [← e.boundaryFlag_comm j, ← e.pairing_comm] at h + exact e.flagEquiv.injective h + change e.flagEquiv (rewire hopen₁ f).val = (rewire hopen₂ g).val + rw [rewire_val_of_ne hfi hfj, rewire_val_of_ne hfi₂ hfj₂, + hgval, e.pairing_comm] + +/-- The open case: the flag equivalence restricts to a +`gluePairOpen` congruence. -/ +def gluePairOpenCongr + (hopen₁ : W₁.pairing (W₁.boundaryFlag i) ≠ W₁.boundaryFlag j) + (hopen₂ : W₂.pairing (W₂.boundaryFlag i) ≠ W₂.boundaryFlag j) + (hij : i ≠ j) : + Equiv (W₁.gluePairOpen i j hij hopen₁) + (W₂.gluePairOpen i j hij hopen₂) where + flagEquiv := e.survivingFlagEquiv i j + vertexEquiv := e.vertexEquiv + attach_comm := fun f => by exact e.survivingFlagEquiv_glueAttach i j f + pairing_comm := fun f => by + exact e.survivingFlagEquiv_rewire hopen₁ hopen₂ f + circles_eq := e.circles_eq + +/-- Single-pair gluing commutes with fragment equivalence. -/ +def gluePairCongr (hij : i ≠ j) : + Equiv (W₁.gluePair i j hij) (W₂.gluePair i j hij) := by + unfold gluePair + split + · rename_i h₁ + rw [dite_eq_left ((e.gluePair_case_preserved i j).mp h₁)] + exact e.gluePairClosedCongr h₁ + ((e.gluePair_case_preserved i j).mp h₁) + · rename_i h₁ + rw [dite_eq_right (mt (e.gluePair_case_preserved i j).mpr h₁)] + exact e.gluePairOpenCongr h₁ + (mt (e.gluePair_case_preserved i j).mpr h₁) hij + +end GluePairCongr + +/-! ### Relabel algebra -/ + +/-- Helper: the identity map commutes with `Sum.map id (Equiv.refl α)` +composed with `Sum.map (Equiv.refl _) id`. -/ +private theorem relabel_refl_attach_aux (W : Fragment α) + (f : W.Flag) : + W.attach f = ((W.attach f).map id (_root_.Equiv.refl α)).map + (_root_.Equiv.refl _) id := by + rcases W.attach f with v | ℓ <;> simp + +/-- Relabelling by the identity is the identity on fragments, +up to equivalence. -/ +def relabelRefl (W : Fragment α) : + Equiv (W.relabel (_root_.Equiv.refl α)) W where + flagEquiv := _root_.Equiv.refl _ + vertexEquiv := _root_.Equiv.refl _ + attach_comm f := by exact relabel_refl_attach_aux W f + pairing_comm := fun _ => rfl + circles_eq := rfl + +/-- Helper: double relabelling commutes with single transitive +relabelling, as a `Sum` equation. -/ +private theorem relabel_trans_attach_aux (W : Fragment α) + (e₁ : α ≃ β) {γ : Type} (e₂ : β ≃ γ) (f : W.Flag) : + (W.attach f).map id (e₁.trans e₂) = + (((W.attach f).map id e₁).map id e₂).map + (_root_.Equiv.refl _) id := by + rcases W.attach f with v | ℓ <;> simp + +/-- Relabelling twice composes, up to equivalence. -/ +def relabelTrans (W : Fragment α) (e₁ : α ≃ β) {γ : Type} + (e₂ : β ≃ γ) : + Equiv ((W.relabel e₁).relabel e₂) (W.relabel (e₁.trans e₂)) where + flagEquiv := _root_.Equiv.refl _ + vertexEquiv := _root_.Equiv.refl _ + attach_comm f := by exact relabel_trans_attach_aux W e₁ e₂ f + pairing_comm := fun _ => rfl + circles_eq := rfl + +/-! ### Sanity checks -/ + +/-- The identity equivalence on the strand. -/ +example : Equiv strand strand := refl strand + +/-- Symmetry of an equivalence round-trips. -/ +example (e : Equiv W₁ W₂) : Equiv W₂ W₁ := e.symm + +end Equiv + +end Fragment + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GenBoundaryStates.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GenBoundaryStates.lean new file mode 100644 index 0000000000..e274920e5c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GenBoundaryStates.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition + +/-! +# Boundary states over general label types + +A boundary state gives one colour per boundary label: even when +the boundary edge is outside the Eulerian subset, odd when it +participates. The labels are an arbitrary type, because the +single-pair gluing decomposition works label-locally and its +states are indexed by the surviving labels of a `gluePair` rather +than by an initial segment of ℕ. +-/ + +@[expose] public section + +namespace RS + +/-- A boundary state over an arbitrary label type: one colour per +label, even (`Sum.inl`) when the boundary edge is outside the +Eulerian subset and odd (`Sum.inr`) when it participates. -/ +def GenBoundaryState (k ℓ : ℕ) (α : Type) : Type := + α → (Fin k ⊕ Fin (2 * ℓ)) + +/-- Boundary states over a finite label type are finite in +number. -/ +instance {k ℓ : ℕ} {α : Type} [Fintype α] [DecidableEq α] : + Fintype (GenBoundaryState k ℓ α) := + inferInstanceAs (Fintype (α → (Fin k ⊕ Fin (2 * ℓ)))) + +/-- And can be compared, classically. -/ +noncomputable instance {k ℓ : ℕ} {α : Type} : + DecidableEq (GenBoundaryState k ℓ α) := + Classical.decEq _ + +/-- There are `(k + 2ℓ)` colours per label, so that many states to +the number of labels. -/ +theorem card_genBoundaryState (k ℓ : ℕ) (α : Type) [Fintype α] + [DecidableEq α] : + Fintype.card (GenBoundaryState k ℓ α) = + (k + 2 * ℓ) ^ Fintype.card α := by + change Fintype.card (α → (Fin k ⊕ Fin (2 * ℓ))) = _ + rw [Fintype.card_fun, Fintype.card_sum, Fintype.card_fin, + Fintype.card_fin] + +/-- The boundary-membership constraint over a general label type. -/ +def genBoundarySubsetMatches {k ℓ : ℕ} {α : Type} + (W : Fragment α) (s : Finset W.Flag) + (st : GenBoundaryState k ℓ α) : Prop := + ∀ i : α, W.boundaryFlag i ∈ s ↔ ∃ c, st i = Sum.inr c + +section GenHelpers + +variable {k ℓ : ℕ} {α : Type} {W : Fragment α} {s : Finset W.Flag} + {st : GenBoundaryState k ℓ α} + +/-- An even-coloured label's boundary flag is outside matching +subsets. -/ +theorem genBoundaryFlag_not_mem_of_even + (hbnd : genBoundarySubsetMatches W s st) + (i : α) (c : Fin k) (hst : st i = Sum.inl c) : + W.boundaryFlag i ∉ s := by + intro hmem + obtain ⟨d, hd⟩ := (hbnd i).mp hmem + simp [hst] at hd + +end GenHelpers + +/-- The even-colouring boundary constraint over a general label +type. -/ +def genEvenBoundaryMatch {k ℓ : ℕ} {α : Type} {W : Fragment α} + (F : EdgeSubset W) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (ψ : F.EvenColouring k) : Prop := + ∀ (i : α) (c : Fin k) (hst : st i = Sum.inl c), + ψ.val ⟨W.boundaryFlag i, + genBoundaryFlag_not_mem_of_even hbnd i c hst⟩ = c + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueAmbient.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueAmbient.lean new file mode 100644 index 0000000000..1ca20ab559 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueAmbient.lean @@ -0,0 +1,581 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueComm + +/-! +# Gluing in an ambient union + +The two normalization equivalences behind associativity of +composition: disjoint union of fragments is associative up to +equivalence (with the label re-bracketing), and a single-pair glue +commutes with extending the ambient fragment by a disjoint union. +-/ + +@[expose] public section + +namespace RS + +variable {α β γ : Type} + +/-! ### Glue-in-ambient equivalence -/ + +namespace Fragment + +variable {α β : Type} + +/-- The label equivalence for gluing inside an ambient union: +surviving labels of the sum at an inl-pair decompose as +the surviving labels of the left factor plus the right labels. -/ +def ambientLabelEquiv (i j : α) : + SurvivingLabel (α ⊕ β) (Sum.inl i) (Sum.inl j) ≃ + (SurvivingLabel α i j ⊕ β) where + toFun x := + match hx : x.val with + | Sum.inl a => Sum.inl ⟨a, + fun h => x.prop.1 (hx ▸ congrArg Sum.inl h), + fun h => x.prop.2 (hx ▸ congrArg Sum.inl h)⟩ + | Sum.inr b => Sum.inr b + invFun y := + match y with + | Sum.inl ⟨a, ha⟩ => ⟨Sum.inl a, + fun h => ha.1 (Sum.inl.inj h), + fun h => ha.2 (Sum.inl.inj h)⟩ + | Sum.inr b => ⟨Sum.inr b, + Sum.inr_ne_inl, Sum.inr_ne_inl⟩ + left_inv x := by + rcases x with ⟨a | b, hx⟩ <;> simp + right_inv y := by + rcases y with ⟨a, ha⟩ | b <;> simp + +/-- The flag equivalence for gluing inside an ambient union: +surviving flags of the union at the inl-pair are the surviving +flags of the left factor plus the right flags. -/ +def ambientFlagEquiv (W : Fragment α) (V : Fragment β) (i j : α) : + SurvivingFlag W i j ⊕ V.Flag ≃ + SurvivingFlag (W.disjUnion V) (Sum.inl i) (Sum.inl j) where + toFun f := + match f with + | Sum.inl ⟨g, hg⟩ => ⟨Sum.inl g, + fun h => hg.1 (Sum.inl.inj h), + fun h => hg.2 (Sum.inl.inj h)⟩ + | Sum.inr g => ⟨Sum.inr g, + fun (h : Sum.inr g = Sum.inl (W.boundaryFlag i)) => + absurd h Sum.inr_ne_inl, + fun (h : Sum.inr g = Sum.inl (W.boundaryFlag j)) => + absurd h Sum.inr_ne_inl⟩ + invFun f := + match hf : f.val with + | Sum.inl g => Sum.inl ⟨g, + fun h => f.prop.1 (show f.val = Sum.inl (W.boundaryFlag i) + from hf ▸ congrArg Sum.inl h), + fun h => f.prop.2 (show f.val = Sum.inl (W.boundaryFlag j) + from hf ▸ congrArg Sum.inl h)⟩ + | Sum.inr g => Sum.inr g + left_inv f := by + rcases f with ⟨g, hg⟩ | g <;> simp + right_inv f := by + rcases f with ⟨g | g, hf⟩ <;> simp + +/-- `glueAttach` at a flag attached to a vertex. -/ +private theorem glueAttach_of_vertex {W : Fragment α} {i j : α} + (f : SurvivingFlag W i j) {v : W.Vertex} + (ha : W.attach f.val = Sum.inl v) : + glueAttach W i j f = Sum.inl v := + (glueAttach_inl_iff f v).mpr ha + +/-- `glueAttach` at a flag attached to a label. -/ +private theorem glueAttach_of_label {W : Fragment α} {i j : α} + (f : SurvivingFlag W i j) {ℓ : α} + (ha : W.attach f.val = Sum.inr ℓ) + (hℓi : ℓ ≠ i) (hℓj : ℓ ≠ j) : + glueAttach W i j f = Sum.inr ⟨ℓ, hℓi, hℓj⟩ := + (glueAttach_inr_iff f ⟨ℓ, hℓi, hℓj⟩).mpr ha + +private theorem gluePairClosed_disjUnion_attach_comm (W : Fragment α) (V : + Fragment β) + {i j : α} + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (f : (((W.gluePairClosed i j hclosed).disjUnion V)).Flag) : + ((((W.disjUnion V).gluePairClosed (Sum.inl i) (Sum.inl j) + (congrArg Sum.inl hclosed)).relabel + (ambientLabelEquiv i j))).attach (ambientFlagEquiv W V i j f) = + ((((W.gluePairClosed i j hclosed).disjUnion V)).attach f).map (_root_.Equiv.refl + (W.Vertex ⊕ V.Vertex)) id := by + rcases f with ⟨g, hg⟩ | g + · -- W-side survivor: flagEquiv maps Sum.inl ⟨g, hg⟩ to ⟨Sum.inl g, ...⟩ + -- The union's attach at Sum.inl g = (W.attach g).map Sum.inl Sum.inl + have hunion : (W.disjUnion V).attach (Sum.inl g) = + (W.attach g).map Sum.inl Sum.inl := rfl + set f' : SurvivingFlag (W.disjUnion V) (Sum.inl i) (Sum.inl j) := + ⟨Sum.inl g, fun h => hg.1 (Sum.inl.inj h), + fun h => hg.2 (Sum.inl.inj h)⟩ + -- Change the goal to an explicit form + change (glueAttach (W.disjUnion V) (Sum.inl i) (Sum.inl j) f').map id + (ambientLabelEquiv i j) = + Sum.map (⇑(_root_.Equiv.refl (W.Vertex ⊕ V.Vertex))) id + ((glueAttach W i j ⟨g, hg⟩).map Sum.inl Sum.inl) + rcases ha : W.attach g with v | ℓ + · -- vertex case + have hf' : (W.disjUnion V).attach f'.val = Sum.inl (Sum.inl v) := by + change (W.attach g).map Sum.inl Sum.inl = _; rw [ha]; rfl + rw [glueAttach_of_vertex f' hf', + glueAttach_of_vertex ⟨g, hg⟩ ha] + rfl + · -- label case + have hℓi : ℓ ≠ i := fun h => hg.1 (W.eq_boundaryFlag i g (h ▸ ha)) + have hℓj : ℓ ≠ j := fun h => hg.2 (W.eq_boundaryFlag j g (h ▸ ha)) + have hf' : (W.disjUnion V).attach f'.val = Sum.inr (Sum.inl ℓ) := by + change (W.attach g).map Sum.inl Sum.inl = _; rw [ha]; rfl + have hℓi' : (Sum.inl ℓ : α ⊕ β) ≠ Sum.inl i := + fun h => hℓi (Sum.inl.inj h) + have hℓj' : (Sum.inl ℓ : α ⊕ β) ≠ Sum.inl j := + fun h => hℓj (Sum.inl.inj h) + rw [glueAttach_of_label f' hf' hℓi' hℓj', + glueAttach_of_label ⟨g, hg⟩ ha hℓi hℓj] + rfl + · -- V-side flag + set f' : SurvivingFlag (W.disjUnion V) (Sum.inl i) (Sum.inl j) := + ⟨Sum.inr g, fun (h : Sum.inr g = Sum.inl (W.boundaryFlag i)) => + absurd h Sum.inr_ne_inl, + fun (h : Sum.inr g = Sum.inl (W.boundaryFlag j)) => + absurd h Sum.inr_ne_inl⟩ + change (glueAttach (W.disjUnion V) (Sum.inl i) (Sum.inl j) f').map id + (ambientLabelEquiv i j) = + Sum.map (⇑(_root_.Equiv.refl (W.Vertex ⊕ V.Vertex))) id + ((V.attach g).map Sum.inr Sum.inr) + rcases ha : V.attach g with v | ℓ + · have hf' : (W.disjUnion V).attach f'.val = Sum.inl (Sum.inr v) := by + change (V.attach g).map Sum.inr Sum.inr = _; rw [ha]; rfl + rw [glueAttach_of_vertex f' hf'] + rfl + · have hf' : (W.disjUnion V).attach f'.val = Sum.inr (Sum.inr ℓ) := by + change (V.attach g).map Sum.inr Sum.inr = _; rw [ha]; rfl + have hℓi : (Sum.inr ℓ : α ⊕ β) ≠ Sum.inl i := Sum.inr_ne_inl + have hℓj : (Sum.inr ℓ : α ⊕ β) ≠ Sum.inl j := Sum.inr_ne_inl + rw [glueAttach_of_label f' hf' hℓi hℓj] + rfl + +private theorem gluePairClosed_disjUnion_pairing_comm (W : Fragment α) (V : + Fragment β) + {i j : α} + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (f : (((W.gluePairClosed i j hclosed).disjUnion V)).Flag) : + ambientFlagEquiv W V i j ((((W.gluePairClosed i j hclosed).disjUnion V)).pairing f) = + ((((W.disjUnion V).gluePairClosed (Sum.inl i) (Sum.inl j) + (congrArg Sum.inl hclosed)).relabel + (ambientLabelEquiv i j))).pairing (ambientFlagEquiv W V i j f) := by + rcases f with ⟨g, hg⟩ | g + · apply Subtype.ext + change Sum.inl (W.pairing g) = (W.disjUnion V).pairing (Sum.inl g) + rfl + · apply Subtype.ext + change Sum.inr (V.pairing g) = (W.disjUnion V).pairing (Sum.inr g) + rfl + +/-- The closed case of glue-in-ambient: when the two boundary flags +bound a common edge in W, the LHS and RHS produce equivalent +fragments. -/ +noncomputable def gluePairClosedDisjUnion (W : Fragment α) (V : + Fragment β) + {i j : α} + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) : + ((W.gluePairClosed i j hclosed).disjUnion V).Equiv + (((W.disjUnion V).gluePairClosed (Sum.inl i) (Sum.inl j) + (congrArg Sum.inl hclosed)).relabel + (ambientLabelEquiv i j)) where + flagEquiv := ambientFlagEquiv W V i j + vertexEquiv := _root_.Equiv.refl (W.Vertex ⊕ V.Vertex) + attach_comm := by exact gluePairClosed_disjUnion_attach_comm W V hclosed + pairing_comm := by exact gluePairClosed_disjUnion_pairing_comm W V hclosed + circles_eq := by + change (W.circles + 1) + V.circles = (W.circles + V.circles) + 1 + omega + +private theorem gluePairOpen_disjUnion_attach_comm (W : Fragment α) (V : Fragment + β) + {i j : α} (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (f : (((W.gluePairOpen i j hij hopen).disjUnion V)).Flag) : + ((((W.disjUnion V).gluePairOpen (Sum.inl i) (Sum.inl j) + (fun h => hij (Sum.inl.inj h)) + (fun h => hopen (Sum.inl.inj h))).relabel + (ambientLabelEquiv i j))).attach (ambientFlagEquiv W V i j f) = + ((((W.gluePairOpen i j hij hopen).disjUnion V)).attach f).map (_root_.Equiv.refl + (W.Vertex ⊕ V.Vertex)) id := by + -- The attach proof is identical to the closed case: glueAttach is + -- the same function in both gluePairClosed and gluePairOpen. + rcases f with ⟨g, hg⟩ | g + · set f' : SurvivingFlag (W.disjUnion V) (Sum.inl i) (Sum.inl j) := + ⟨Sum.inl g, fun h => hg.1 (Sum.inl.inj h), + fun h => hg.2 (Sum.inl.inj h)⟩ + change (glueAttach (W.disjUnion V) (Sum.inl i) (Sum.inl j) f').map id + (ambientLabelEquiv i j) = + Sum.map (⇑(_root_.Equiv.refl (W.Vertex ⊕ V.Vertex))) id + ((glueAttach W i j ⟨g, hg⟩).map Sum.inl Sum.inl) + rcases ha : W.attach g with v | ℓ + · have hf' : (W.disjUnion V).attach f'.val = Sum.inl (Sum.inl v) := by + change (W.attach g).map Sum.inl Sum.inl = _; rw [ha]; rfl + rw [glueAttach_of_vertex f' hf', + glueAttach_of_vertex ⟨g, hg⟩ ha] + rfl + · have hℓi : ℓ ≠ i := fun h => hg.1 (W.eq_boundaryFlag i g (h ▸ ha)) + have hℓj : ℓ ≠ j := fun h => hg.2 (W.eq_boundaryFlag j g (h ▸ ha)) + have hf' : (W.disjUnion V).attach f'.val = Sum.inr (Sum.inl ℓ) := by + change (W.attach g).map Sum.inl Sum.inl = _; rw [ha]; rfl + rw [glueAttach_of_label f' hf' + (fun h => hℓi (Sum.inl.inj h)) (fun h => hℓj (Sum.inl.inj h)), + glueAttach_of_label ⟨g, hg⟩ ha hℓi hℓj] + rfl + · set f' : SurvivingFlag (W.disjUnion V) (Sum.inl i) (Sum.inl j) := + ⟨Sum.inr g, fun (h : Sum.inr g = Sum.inl (W.boundaryFlag i)) => + absurd h Sum.inr_ne_inl, + fun (h : Sum.inr g = Sum.inl (W.boundaryFlag j)) => + absurd h Sum.inr_ne_inl⟩ + change (glueAttach (W.disjUnion V) (Sum.inl i) (Sum.inl j) f').map id + (ambientLabelEquiv i j) = + Sum.map (⇑(_root_.Equiv.refl (W.Vertex ⊕ V.Vertex))) id + ((V.attach g).map Sum.inr Sum.inr) + rcases ha : V.attach g with v | ℓ + · have hf' : (W.disjUnion V).attach f'.val = Sum.inl (Sum.inr v) := by + change (V.attach g).map Sum.inr Sum.inr = _; rw [ha]; rfl + rw [glueAttach_of_vertex f' hf'] + rfl + · have hf' : (W.disjUnion V).attach f'.val = Sum.inr (Sum.inr ℓ) := by + change (V.attach g).map Sum.inr Sum.inr = _; rw [ha]; rfl + rw [glueAttach_of_label f' hf' Sum.inr_ne_inl Sum.inr_ne_inl] + rfl + +private theorem gluePairOpen_disjUnion_pairing_comm (W : Fragment α) (V : Fragment + β) + {i j : α} (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (f : (((W.gluePairOpen i j hij hopen).disjUnion V)).Flag) : + ambientFlagEquiv W V i j ((((W.gluePairOpen i j hij hopen).disjUnion V)).pairing f) = + ((((W.disjUnion V).gluePairOpen (Sum.inl i) (Sum.inl j) + (fun h => hij (Sum.inl.inj h)) + (fun h => hopen (Sum.inl.inj h))).relabel + (ambientLabelEquiv i j))).pairing (ambientFlagEquiv W V i j f) := by + -- ═══════ REWIRE COMMUTATION ═══════ + rcases f with ⟨g, hg⟩ | g + · -- W-side survivor: three dite branches of rewire align + apply Subtype.ext + -- After Subtype.ext, goal is about .val in W.Flag ⊕ V.Flag + -- LHS: Sum.inl (rewire hopen ⟨g, hg⟩).val + -- RHS: (rewire hopen_union ⟨Sum.inl g, ...⟩).val + change Sum.inl (rewire hopen ⟨g, hg⟩).val = + (rewire (show (W.disjUnion V).pairing + ((W.disjUnion V).boundaryFlag (Sum.inl i)) ≠ + (W.disjUnion V).boundaryFlag (Sum.inl j) from + fun h => hopen (Sum.inl.inj h)) + (⟨Sum.inl g, fun h => hg.1 (Sum.inl.inj h), + fun h => hg.2 (Sum.inl.inj h)⟩ : + SurvivingFlag (W.disjUnion V) (Sum.inl i) (Sum.inl j))).val + unfold rewire + split + · rename_i hfi + rw [dite_eq_left (show (W.disjUnion V).pairing (Sum.inl g) = + (W.disjUnion V).boundaryFlag (Sum.inl i) from + congrArg Sum.inl hfi)] + rfl + · split + · rename_i hfi hfj + rw [dite_eq_right (show (W.disjUnion V).pairing (Sum.inl g) ≠ + (W.disjUnion V).boundaryFlag (Sum.inl i) from + fun h => hfi (Sum.inl.inj h)), + dite_eq_left (show (W.disjUnion V).pairing (Sum.inl g) = + (W.disjUnion V).boundaryFlag (Sum.inl j) from + congrArg Sum.inl hfj)] + rfl + · rename_i hfi hfj + rw [dite_eq_right (show (W.disjUnion V).pairing (Sum.inl g) ≠ + (W.disjUnion V).boundaryFlag (Sum.inl i) from + fun h => hfi (Sum.inl.inj h)), + dite_eq_right (show (W.disjUnion V).pairing (Sum.inl g) ≠ + (W.disjUnion V).boundaryFlag (Sum.inl j) from + fun h => hfj (Sum.inl.inj h))] + rfl + · -- V-side flag: both dite conditions false since Sum.inr ≠ Sum.inl + apply Subtype.ext + change Sum.inr (V.pairing g) = + (rewire (show (W.disjUnion V).pairing + ((W.disjUnion V).boundaryFlag (Sum.inl i)) ≠ + (W.disjUnion V).boundaryFlag (Sum.inl j) from + fun h => hopen (Sum.inl.inj h)) + (⟨Sum.inr g, fun (h : Sum.inr g = + (W.disjUnion V).boundaryFlag (Sum.inl i)) => + absurd h Sum.inr_ne_inl, + fun (h : Sum.inr g = + (W.disjUnion V).boundaryFlag (Sum.inl j)) => + absurd h Sum.inr_ne_inl⟩ : + SurvivingFlag (W.disjUnion V) (Sum.inl i) (Sum.inl j))).val + unfold rewire + rw [dite_eq_right (show (W.disjUnion V).pairing (Sum.inr g) ≠ + (W.disjUnion V).boundaryFlag (Sum.inl i) from + Sum.inr_ne_inl), + dite_eq_right (show (W.disjUnion V).pairing (Sum.inr g) ≠ + (W.disjUnion V).boundaryFlag (Sum.inl j) from + Sum.inr_ne_inl)] + rfl + +/-- The open case of glue-in-ambient: when the two boundary flags +bound distinct edges in W, the LHS and RHS produce equivalent +fragments. -/ +noncomputable def gluePairOpenDisjUnion (W : Fragment α) (V : Fragment + β) + {i j : α} (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) : + ((W.gluePairOpen i j hij hopen).disjUnion V).Equiv + (((W.disjUnion V).gluePairOpen (Sum.inl i) (Sum.inl j) + (fun h => hij (Sum.inl.inj h)) + (fun h => hopen (Sum.inl.inj h))).relabel + (ambientLabelEquiv i j)) where + flagEquiv := ambientFlagEquiv W V i j + vertexEquiv := _root_.Equiv.refl (W.Vertex ⊕ V.Vertex) + attach_comm := by exact gluePairOpen_disjUnion_attach_comm W V hij hopen + pairing_comm := by exact gluePairOpen_disjUnion_pairing_comm W V hij hopen + circles_eq := by + change W.circles + V.circles = (W.circles + V.circles) + rfl + +/-- A single-pair glue commutes with extending the ambient +fragment by a disjoint union: gluing `{i, j}` in `W` and then +forming the union with `V` is equivalent to forming the union first +and gluing the inl-wrapped pair. -/ +noncomputable def gluePairDisjUnion (W : Fragment α) (V : Fragment β) + {i j : α} (hij : i ≠ j) : + ((W.gluePair i j hij).disjUnion V).Equiv + (((W.disjUnion V).gluePair (Sum.inl i) (Sum.inl j) + (fun h => hij (Sum.inl.inj h))).relabel + (ambientLabelEquiv i j)) := by + unfold gluePair + split + · -- closed case: W's pair is closed, so union's pair is closed + rename_i hclosed + have hunion : (W.disjUnion V).pairing + ((W.disjUnion V).boundaryFlag (Sum.inl i)) = + (W.disjUnion V).boundaryFlag (Sum.inl j) := + congrArg Sum.inl hclosed + rw [dite_eq_left hunion] + exact gluePairClosedDisjUnion W V hclosed + · -- open case: W's pair is open, so union's pair is open + rename_i hopen + have hunion : (W.disjUnion V).pairing + ((W.disjUnion V).boundaryFlag (Sum.inl i)) ≠ + (W.disjUnion V).boundaryFlag (Sum.inl j) := + fun h => hopen (Sum.inl.inj h) + rw [dite_eq_right hunion] + exact gluePairOpenDisjUnion W V hij hopen + +/-- The label condition transported along a relabelling. -/ +private theorem relabelSurvIff (e : α ≃ β) (i j : β) (x : α) : + (x ≠ e.symm i ∧ x ≠ e.symm j) ↔ (e x ≠ i ∧ e x ≠ j) := by + constructor + · intro hx + exact ⟨fun h => hx.1 (by rw [← h, e.symm_apply_apply]), + fun h => hx.2 (by rw [← h, e.symm_apply_apply])⟩ + · intro hx + exact ⟨fun h => hx.1 (by rw [h, e.apply_symm_apply]), + fun h => hx.2 (by rw [h, e.apply_symm_apply])⟩ + +private theorem relabelGlueAttach_aux (W : Fragment α) (e : α ≃ β) + {i j : β} (f : SurvivingFlag (W.relabel e) i j) : + (glueAttach W (e.symm i) (e.symm j) f).map id + (e.subtypeEquiv (relabelSurvIff e i j)) = + Sum.map id id (glueAttach (W.relabel e) i j f) := by + rcases ha : W.attach f.val with v | ℓ + · rw [glueAttach_of_vertex (W := W) (i := e.symm i) (j := e.symm j) f ha, + glueAttach_of_vertex f + (show (W.relabel e).attach f.val = Sum.inl v from by + change (W.attach f.val).map id e = _ + rw [ha]; rfl)] + rfl + · have h1 : ℓ ≠ e.symm i := + fun h => (survivingFlag_attach_ne + (W := W) (i := e.symm i) (j := e.symm j) f).1 (by rw [ha, h]) + have h2 : ℓ ≠ e.symm j := + fun h => (survivingFlag_attach_ne + (W := W) (i := e.symm i) (j := e.symm j) f).2 (by rw [ha, h]) + have h1' : e ℓ ≠ i := fun h => h1 (by rw [← h, e.symm_apply_apply]) + have h2' : e ℓ ≠ j := fun h => h2 (by rw [← h, e.symm_apply_apply]) + rw [glueAttach_of_label (W := W) (i := e.symm i) (j := e.symm j) + f ha h1 h2, + glueAttach_of_label f + (show (W.relabel e).attach f.val = Sum.inr (e ℓ) from by + change (W.attach f.val).map id e = _ + rw [ha]; rfl) h1' h2'] + rfl + +/-- Gluing commutes with relabelling: gluing two labels of a +relabelled fragment is the relabelled gluing of their preimages. -/ +noncomputable def gluePairRelabel (W : Fragment α) (e : α ≃ β) + {i j : β} (hij : i ≠ j) : + ((W.relabel e).gluePair i j hij).Equiv + ((W.gluePair (e.symm i) (e.symm j) + (fun h => hij (by rw [← e.apply_symm_apply i, + ← e.apply_symm_apply j, h]))).relabel + (e.subtypeEquiv (by exact relabelSurvIff e i j))) + := by + by_cases hclosed : + W.pairing (W.boundaryFlag (e.symm i)) = W.boundaryFlag (e.symm j) + · have hc' : (W.relabel e).pairing ((W.relabel e).boundaryFlag i) = + (W.relabel e).boundaryFlag j := hclosed + rw [gluePair_eq_closed hij hc', gluePair_eq_closed _ hclosed] + exact + { flagEquiv := by + exact _root_.Equiv.refl (((W.relabel e).gluePairClosed i j hc').Flag) + vertexEquiv := by + exact _root_.Equiv.refl (((W.relabel e).gluePairClosed i j + hc').Vertex) + attach_comm := fun f => by exact relabelGlueAttach_aux W e f + pairing_comm := fun f => rfl + circles_eq := rfl } + · have ho' : ¬ ((W.relabel e).pairing ((W.relabel e).boundaryFlag i) = + (W.relabel e).boundaryFlag j) := hclosed + rw [gluePair_eq_open hij ho', gluePair_eq_open _ hclosed] + exact + { flagEquiv := by + exact _root_.Equiv.refl (((W.relabel e).gluePairOpen i j hij + ho').Flag) + vertexEquiv := by + exact _root_.Equiv.refl (((W.relabel e).gluePairOpen i j hij + ho').Vertex) + attach_comm := fun f => by exact relabelGlueAttach_aux W e f + pairing_comm := fun f => rfl + circles_eq := rfl } + +/-! ### Component swap of a single glue -/ + +/-- Swapping the two removed labels. -/ +def survLabelSwapEquiv (α : Type) (i j : α) : + SurvivingLabel α j i ≃ SurvivingLabel α i j where + toFun x := ⟨x.val, x.prop.2, x.prop.1⟩ + invFun x := ⟨x.val, x.prop.2, x.prop.1⟩ + left_inv _ := Subtype.ext rfl + right_inv _ := Subtype.ext rfl + +/-- Gluing a pair is symmetric in its two labels, up to the swap +relabelling. -/ +noncomputable def gluePairSwap (W : Fragment α) {i j : α} + (hij : i ≠ j) : + (W.gluePair i j hij).Equiv + ((W.gluePair j i (Ne.symm hij)).relabel + (survLabelSwapEquiv α i j)) := by + have hbne : W.boundaryFlag i ≠ W.boundaryFlag j := + fun h => hij (W.boundaryFlag_injective h) + set flagE : SurvivingFlag W j i ≃ SurvivingFlag W i j := + ⟨fun f => ⟨f.val, f.prop.2, f.prop.1⟩, + fun f => ⟨f.val, f.prop.2, f.prop.1⟩, + fun _ => Subtype.ext rfl, fun _ => Subtype.ext rfl⟩ + by_cases hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j + · have hclosed' : W.pairing (W.boundaryFlag j) = W.boundaryFlag i := by + rw [← hclosed, W.pairing_invol] + rw [gluePair_eq_closed hij hclosed, + gluePair_eq_closed (Ne.symm hij) hclosed'] + refine ⟨flagE.symm, _root_.Equiv.refl _, fun f => ?_, fun f => ?_, + rfl⟩ + · change (glueAttach W j i (flagE.symm f)).map id + (survLabelSwapEquiv α i j) = + (glueAttach W i j f).map (_root_.Equiv.refl _) id + rcases ha : W.attach f.val with v | ℓ + · have h1 : glueAttach W j i (flagE.symm f) = Sum.inl v := by + exact (glueAttach_inl_iff _ v).mpr ha + have h2 : glueAttach W i j f = Sum.inl v := by + exact (glueAttach_inl_iff _ v).mpr ha + rw [h1, h2] + rfl + · have h1 : ∃ p : SurvivingLabel α j i, + glueAttach W j i (flagE.symm f) = Sum.inr p ∧ p.val = ℓ := by + exact exists_glueAttach_inr _ ha + have h2 : ∃ p : SurvivingLabel α i j, + glueAttach W i j f = Sum.inr p ∧ p.val = ℓ := by + exact exists_glueAttach_inr _ ha + obtain ⟨p1, hp1, hv1⟩ := h1 + obtain ⟨p2, hp2, hv2⟩ := h2 + rw [hp1, hp2] + exact congrArg Sum.inr (Subtype.ext (hv1.trans hv2.symm)) + · exact Subtype.ext rfl + · have hopen' : W.pairing (W.boundaryFlag j) ≠ W.boundaryFlag i := by + intro h + exact hclosed (by rw [← h, W.pairing_invol]) + rw [gluePair_eq_open hij hclosed, + gluePair_eq_open (Ne.symm hij) hopen'] + refine ⟨flagE.symm, _root_.Equiv.refl _, fun f => ?_, fun f => ?_, + rfl⟩ + · change (glueAttach W j i (flagE.symm f)).map id + (survLabelSwapEquiv α i j) = + (glueAttach W i j f).map (_root_.Equiv.refl _) id + rcases ha : W.attach f.val with v | ℓ + · have h1 : glueAttach W j i (flagE.symm f) = Sum.inl v := by + exact (glueAttach_inl_iff _ v).mpr ha + have h2 : glueAttach W i j f = Sum.inl v := by + exact (glueAttach_inl_iff _ v).mpr ha + rw [h1, h2] + rfl + · have h1 : ∃ p : SurvivingLabel α j i, + glueAttach W j i (flagE.symm f) = Sum.inr p ∧ p.val = ℓ := by + exact exists_glueAttach_inr _ ha + have h2 : ∃ p : SurvivingLabel α i j, + glueAttach W i j f = Sum.inr p ∧ p.val = ℓ := by + exact exists_glueAttach_inr _ ha + obtain ⟨p1, hp1, hv1⟩ := h1 + obtain ⟨p2, hp2, hv2⟩ := h2 + rw [hp1, hp2] + exact congrArg Sum.inr (Subtype.ext (hv1.trans hv2.symm)) + · change flagE.symm (rewire hclosed f) = rewire hopen' (flagE.symm f) + unfold rewire + by_cases hfi : W.pairing f.val = W.boundaryFlag i + · have hfj : ¬ W.pairing f.val = W.boundaryFlag j := + fun h => hbne (hfi.symm.trans h) + rw [dite_eq_left hfi, + dite_eq_right (show ¬ W.pairing ((flagE.symm f).val) = + W.boundaryFlag j from hfj), + dite_eq_left (show W.pairing ((flagE.symm f).val) = + W.boundaryFlag i from hfi)] + exact Subtype.ext rfl + · by_cases hfj : W.pairing f.val = W.boundaryFlag j + · rw [dite_eq_right hfi, dite_eq_left hfj, + dite_eq_left (show W.pairing ((flagE.symm f).val) = + W.boundaryFlag j from hfj)] + exact Subtype.ext rfl + · rw [dite_eq_right hfi, dite_eq_right hfj, + dite_eq_right (show ¬ W.pairing ((flagE.symm f).val) = + W.boundaryFlag j from hfj), + dite_eq_right (show ¬ W.pairing ((flagE.symm f).val) = + W.boundaryFlag i from hfi)] + exact Subtype.ext rfl + +/-- Disjoint union is commutative, up to the sum-swap +relabelling. -/ +noncomputable def disjUnionComm (W₁ : Fragment α) (W₂ : Fragment β) : + (W₁.disjUnion W₂).Equiv + ((W₂.disjUnion W₁).relabel (Equiv.sumComm β α)) where + flagEquiv := Equiv.sumComm W₁.Flag W₂.Flag + vertexEquiv := Equiv.sumComm W₁.Vertex W₂.Vertex + attach_comm := fun f => by + rcases f with f | f + · change ((W₁.attach f).map Sum.inr Sum.inr).map id + (Equiv.sumComm β α) = + ((W₁.attach f).map Sum.inl Sum.inl).map + (Equiv.sumComm W₁.Vertex W₂.Vertex) id + rcases W₁.attach f with v | ℓ <;> rfl + · change ((W₂.attach f).map Sum.inl Sum.inl).map id + (Equiv.sumComm β α) = + ((W₂.attach f).map Sum.inr Sum.inr).map + (Equiv.sumComm W₁.Vertex W₂.Vertex) id + rcases W₂.attach f with v | ℓ <;> rfl + pairing_comm := fun f => by + rcases f with f | f <;> rfl + circles_eq := by + change W₁.circles + W₂.circles = W₂.circles + W₁.circles + omega + +end Fragment + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChord.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChord.lean new file mode 100644 index 0000000000..d34cd7d454 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChord.lean @@ -0,0 +1,689 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CutMatching +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedCutDispatch + +/-! +# The chord matching across one glue + +Gluing an interface pair identifies two labels. On the subset's +chord matching — the involution carrying a used label to the far end +of its chain — that identification is a contraction: the two labels +are removed and the far ends of their chains become each other's +partners. + +This file carries the label bookkeeping across the glue. The used +labels of the glued subset are the used labels of the lifted one +with the two glued labels removed, and the glued chord matching is +the contraction of the lifted one at those two labels. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + +open Fragment Equiv +/-! ## The relabel step + +`glueInterface` relabels after every glue, so the invariant has to +survive a relabel. It does: the circuit count is unchanged, and the +chord matching's pairing shifts along the relabel, so the number of +components is unchanged too. +-/ + +section RelabelStep + +variable {α β : Type} + {W : Fragment α} + +/-- **The relabel preserves the circuit count and the number of +components.** -/ +theorem openCircuitCount_add_unionCount_relabel + [LinearOrder α] [LinearOrder β] [Fintype α] [Fintype β] + (e : α ≃o β) + (F : EdgeSubset W) (κ : F.RelTransitionSystem) + {M N : DirMatching {a : α // W.boundaryFlag a ∈ F.boundaryFlags}} + {M' N' : DirMatching {b : β // + (W.relabel e.toEquiv).boundaryFlag b + ∈ (F.relabelUp e.toEquiv).boundaryFlags}} + (heM : (M'.map (usedLabRelabelEquiv e F)).edge = M.edge) + (heN : (N'.map (usedLabRelabelEquiv e F)).edge = N.edge) : + (relabelTransUp e.toEquiv F κ).openCircuitCount + + DirMatching.unionCount M' N' + = κ.openCircuitCount + DirMatching.unionCount M N := by + rw [relabel_openCircuitCount e.toEquiv F κ, + ← DirMatching.unionCount_map (usedLabRelabelEquiv e F) M' N', + DirMatching.unionCount_congr heM heN] + +end RelabelStep + +section GlueChord + +variable {α : Type} {W : Fragment α} {i j : α} + (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', + (W.gluePairOpen i j hij hopen).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetOpen hopen s', + W.pairing f ∈ liftSubsetOpen hopen s') + +local notation "Fg" => + (EdgeSubset.mk s' hc' : + EdgeSubset (W.gluePairOpen i j hij hopen)) + +local notation "Fl" => + (EdgeSubset.mk (liftSubsetOpen hopen s') hc : + EdgeSubset W) + +/-- **The glued subset's used labels** are the lifted subset's, less +the two glued ones. -/ +noncomputable def usedLabelGlueEquiv + [LinearOrder α] + (hbi : W.boundaryFlag i ∈ (Fl).boundaryFlags) + (hbj : W.boundaryFlag j ∈ (Fl).boundaryFlags) : + {l : SurvivingLabel α i j // + (W.gluePairOpen i j hij hopen).boundaryFlag l ∈ + (Fg).boundaryFlags} + ≃ DirMatching.Surviving + (⟨i, hbi⟩ : {a : α // W.boundaryFlag a ∈ (Fl).boundaryFlags}) + ⟨j, hbj⟩ where + toFun x := + ⟨⟨x.val.val, + (glued_participation_iff hij hopen s' hc' hc x.val).mp x.prop⟩, + fun hx => x.val.prop.1 (congrArg Subtype.val hx), + fun hx => x.val.prop.2 (congrArg Subtype.val hx)⟩ + invFun y := + ⟨⟨y.val.val, + fun hx => y.prop.1 (Subtype.ext hx), + fun hx => y.prop.2 (Subtype.ext hx)⟩, + (glued_participation_iff hij hopen s' hc' hc _).mpr y.val.prop⟩ + left_inv _ := rfl + right_inv _ := rfl + +/-- **The glued chord matching is the lifted one, contracted.** A +chain of the glued subset that avoids the cut is a chain of the +lifted subset; one that reaches the cut continues out of the other +glued label. -/ +theorem chordInv_glueOpen + [LinearOrder α] + (κ : (Fl).RelTransitionSystem) + (l : SurvivingLabel α i j) + (hlg : (W.gluePairOpen i j hij hopen).boundaryFlag l ∈ + (Fg).boundaryFlags) + (hbi : W.boundaryFlag i ∈ (Fl).boundaryFlags) + (hbj : W.boundaryFlag j ∈ (Fl).boundaryFlags) : + (chordInv (Fg) (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + l).val + = if chordInv (Fl) κ l.val = i then chordInv (Fl) κ j + else if chordInv (Fl) κ l.val = j then chordInv (Fl) κ i + else chordInv (Fl) κ l.val := by + have hll : W.boundaryFlag l.val ∈ (Fl).boundaryFlags := + (glued_participation_iff hij hopen s' hc' hc l).mp hlg + -- the glued chord, read as a flag + have hgf := boundaryFlag_chordInv (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) hlg + have hlf := boundaryFlag_chordInv (Fl) κ hll + have hLHS : W.boundaryFlag + (chordInv (Fg) (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + l).val + = ((RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).pathMatch + ((W.gluePairOpen i j hij hopen).boundaryFlag l) hlg).val := + congrArg Subtype.val hgf + by_cases h1 : chordInv (Fl) κ l.val = i + · rw [ite_eq_left h1] + have hhit : κ.pathMatch (W.boundaryFlag l.val) hll + = W.boundaryFlag i := by rw [← hlf, h1] + have hpm := pathMatch_glueOpen_hit_i hij hopen s' hc' hc κ + hlg hll hbj hhit + refine W.boundaryFlag_injective ?_ + rw [hLHS, hpm] + exact (boundaryFlag_chordInv (Fl) κ hbj).symm + · by_cases h2 : chordInv (Fl) κ l.val = j + · rw [ite_eq_right h1, ite_eq_left h2] + have hhit : κ.pathMatch (W.boundaryFlag l.val) hll + = W.boundaryFlag j := by rw [← hlf, h2] + have hpm := pathMatch_glueOpen_hit_j hij hopen s' hc' hc κ + hlg hll hbi hhit + refine W.boundaryFlag_injective ?_ + rw [hLHS, hpm] + exact (boundaryFlag_chordInv (Fl) κ hbi).symm + · rw [ite_eq_right h1, ite_eq_right h2] + have hni : κ.pathMatch (W.boundaryFlag l.val) hll + ≠ W.boundaryFlag i := by + rw [← hlf] + exact fun hx => h1 (W.boundaryFlag_injective hx) + have hnj : κ.pathMatch (W.boundaryFlag l.val) hll + ≠ W.boundaryFlag j := by + rw [← hlf] + exact fun hx => h2 (W.boundaryFlag_injective hx) + have hpm := pathMatch_glueOpen_of_ne hij hopen s' hc' hc κ + hlg hll hni hnj + refine W.boundaryFlag_injective ?_ + rw [hLHS, hpm] + exact hlf.symm + +/-- **The glued cut matching's pairing is the lifted one's, +contracted.** Only the pairing is compared: the glued object fixes +its own directions, and the number of components does not see them. -/ +theorem cutMatching_glueOpen_edge + [LinearOrder α] + (κ : (Fl).RelTransitionSystem) + (o : κ.Orientation) + (o' : (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ).Orientation) + (hbi : W.boundaryFlag i ∈ (Fl).boundaryFlags) + (hbj : W.boundaryFlag j ∈ (Fl).boundaryFlags) + (y : DirMatching.Surviving + (⟨i, hbi⟩ : {a : α // W.boundaryFlag a ∈ (Fl).boundaryFlags}) + ⟨j, hbj⟩) : + ((((cutMatching (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) o').map + (usedLabelGlueEquiv hij hopen s' hc' hc hbi hbj)).edge + y).val).val + = (((cutMatching (Fl) κ o).contractEdge ⟨i, hbi⟩ ⟨j, hbj⟩ + y.val)).val := by + have hlg : (W.gluePairOpen i j hij hopen).boundaryFlag + ⟨y.val.val, fun hx => y.prop.1 (Subtype.ext hx), + fun hx => y.prop.2 (Subtype.ext hx)⟩ + ∈ (Fg).boundaryFlags := + (glued_participation_iff hij hopen s' hc' hc _).mpr y.val.prop + have hkey := chordInv_glueOpen hij hopen s' hc' hc κ + ⟨y.val.val, fun hx => y.prop.1 (Subtype.ext hx), + fun hx => y.prop.2 (Subtype.ext hx)⟩ + hlg hbi hbj + change (chordInv (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + ⟨y.val.val, _⟩).val = _ + rw [hkey] + change _ = ((if (cutMatching (Fl) κ o).edge y.val = ⟨i, hbi⟩ then + (cutMatching (Fl) κ o).edge ⟨j, hbj⟩ + else if (cutMatching (Fl) κ o).edge y.val = ⟨j, hbj⟩ then + (cutMatching (Fl) κ o).edge ⟨i, hbi⟩ + else (cutMatching (Fl) κ o).edge y.val) : {a : α // _}).val + by_cases h1 : chordInv (Fl) κ y.val.val = i + · rw [ite_eq_left h1, ite_eq_left (Subtype.ext h1 : + (cutMatching (Fl) κ o).edge y.val = ⟨i, hbi⟩)] + rfl + · by_cases h2 : chordInv (Fl) κ y.val.val = j + · rw [ite_eq_right h1, ite_eq_left h2, + ite_eq_right (fun hx => h1 (congrArg Subtype.val hx)), + ite_eq_left (Subtype.ext h2 : + (cutMatching (Fl) κ o).edge y.val = ⟨j, hbj⟩)] + rfl + · rw [ite_eq_right h1, ite_eq_right h2, + ite_eq_right (fun hx => h1 (congrArg Subtype.val hx)), + ite_eq_right (fun hx => h2 (congrArg Subtype.val hx))] + rfl + +/-- **The interface is linked exactly when the two glued labels are +chord partners.** This is the case split of the glue: linked means +the chain from one glued label ends at the other, so gluing closes +it into a circuit. -/ +theorem interfaceLinked_iff_chordInv (κ : (Fl).RelTransitionSystem) + (hpi : partnerSurvI hopen ∈ s') + (hbi : W.boundaryFlag i ∈ (Fl).boundaryFlags) : + InterfaceLinked hij hopen s' hc' hc + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) hpi + ↔ chordInv (Fl) κ i = j := by + have hmeq : (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ)).MatchEq κ := + fun f hf => (unglueOpen_glueOpen_match hij hopen s' hc' hc κ hf) + have hpm := pathMatch_matchEq hmeq + (δ := W.boundaryFlag i) hbi + rw [interfaceLinked_iff_pathMatch hij hopen s' hc' hc _ hpi] + constructor + · intro hL + refine W.boundaryFlag_injective ?_ + rw [boundaryFlag_chordInv (Fl) κ hbi, hpm] + exact hL + · intro hC + rw [← hpm, ← boundaryFlag_chordInv (Fl) κ hbi, hC] + +/-! ### The invariant across one glue + +The circuit count and the number of components of the union move +together: the interface is linked exactly when the two glued labels +are chord partners, and in that case gluing closes a circuit and +merges nothing, while otherwise it merges two chains and closes +nothing. So their sum is unchanged. +-/ + +/-- **One glue step preserves `ĉ + c`** — RS21's circuit-count +bookkeeping, in the form that needs neither an ordering of the +interface nor the Eulerian position: only the two pairings. -/ +theorem openCircuitCount_add_unionCount_glueOpen + [LinearOrder α] + [Fintype α] + (κ : (Fl).RelTransitionSystem) (o : κ.Orientation) + (o' : (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ).Orientation) + (hpi : partnerSurvI hopen ∈ s') + (hbi : W.boundaryFlag i ∈ (Fl).boundaryFlags) + (hbj : W.boundaryFlag j ∈ (Fl).boundaryFlags) + {N : DirMatching + {a : α // W.boundaryFlag a ∈ (Fl).boundaryFlags}} + (hNij : N.edge ⟨i, hbi⟩ = ⟨j, hbj⟩) + {Ng : DirMatching + {l : SurvivingLabel α i j // + (W.gluePairOpen i j hij hopen).boundaryFlag l ∈ + (Fg).boundaryFlags}} + (hNg : (Ng.map + (usedLabelGlueEquiv hij hopen s' hc' hc hbi hbj)).edge + = (N.restrict hNij).edge) : + (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ).openCircuitCount + + DirMatching.unionCount (cutMatching (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) o') Ng + = κ.openCircuitCount + + DirMatching.unionCount (cutMatching (Fl) κ o) N := by + classical + obtain ⟨A, B, hAe, hBe, hAB⟩ := DirMatching.exists_alternating_repair + (cutMatching (Fl) κ o) N + obtain ⟨Ag, Bg, hAge, hBge, hABg⟩ := + DirMatching.exists_alternating_repair + (cutMatching (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) o') Ng + rw [DirMatching.unionCount_eq_orbitCount hAB hAe hBe, + DirMatching.unionCount_eq_orbitCount hABg hAge hBge, + ← DirMatching.orbitCount_map + (usedLabelGlueEquiv hij hopen s' hc' hc hbi hbj) hABg + (DirMatching.alternating_map _ hABg)] + have hδ := openCircuitCount_glueOpen_participating hij hopen s' + hc' hc (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) hpi + have hun : (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ)).openCircuitCount = κ.openCircuitCount := + openCircuitCount_matchEq + (fun f hf => + (unglueOpen_glueOpen_match hij hopen s' hc' hc κ hf).symm) + have hlink := interfaceLinked_iff_chordInv hij hopen s' hc' hc κ + hpi hbi + have hedge : ∀ y, ((Ag.map + (usedLabelGlueEquiv hij hopen s' hc' hc hbi hbj)).edge + y).val.val + = ((cutMatching (Fl) κ o).contractEdge ⟨i, hbi⟩ ⟨j, hbj⟩ + y.val).val := by + intro y + rw [DirMatching.map_edge_congr _ hAge] + exact cutMatching_glueOpen_edge hij hopen s' hc' hc κ o o' + hbi hbj y + have hBij : B.edge ⟨i, hbi⟩ = ⟨j, hbj⟩ := by rw [hBe]; exact hNij + have heN : (Bg.map + (usedLabelGlueEquiv hij hopen s' hc' hc hbi hbj)).edge + = (B.restrict hBij).edge := by + rw [DirMatching.map_edge_congr _ hBge, hNg] + funext y + exact Subtype.ext (Subtype.ext (congrArg Subtype.val + (congrFun hBe y.val)).symm) + by_cases hcl : chordInv (Fl) κ i = j + · have hMij : (cutMatching (Fl) κ o).edge ⟨i, hbi⟩ = ⟨j, hbj⟩ := + Subtype.ext hcl + have hAij : A.edge ⟨i, hbi⟩ = ⟨j, hbj⟩ := by rw [hAe]; exact hMij + have heM : (Ag.map + (usedLabelGlueEquiv hij hopen s' hc' hc hbi hbj)).edge + = (A.restrict hAij).edge := by + funext y + refine Subtype.ext (Subtype.ext ?_) + rw [hedge y] + refine Eq.trans (congrArg Subtype.val + ((cutMatching (Fl) κ o).contractEdge_of_closed hMij y.val + y.prop.1 y.prop.2)) ?_ + exact congrArg Subtype.val (congrFun hAe y.val).symm + have hstep := DirMatching.orbitCount_restrict_closed_congr hAB + hAij hBij (DirMatching.alternating_map _ hABg) heM heN + have hc1 : (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ).openCircuitCount = κ.openCircuitCount + 1 := by + rw [hδ, hun, ite_eq_left (hlink.mpr hcl)] + rw [hc1] + omega + · have hMij : (cutMatching (Fl) κ o).edge ⟨i, hbi⟩ ≠ ⟨j, hbj⟩ := + fun hx => hcl (congrArg Subtype.val hx) + have hAij : A.edge ⟨i, hbi⟩ ≠ ⟨j, hbj⟩ := by rw [hAe]; exact hMij + have hne : (⟨i, hbi⟩ : + {a : α // W.boundaryFlag a ∈ (Fl).boundaryFlags}) + ≠ ⟨j, hbj⟩ := fun hx => hij (congrArg Subtype.val hx) + have heM : (Ag.map + (usedLabelGlueEquiv hij hopen s' hc' hc hbi hbj)).edge + = (A.contract hne hAij + (DirMatching.tail_ne_of_alternating hAB hBij)).edge := by + funext y + refine Subtype.ext (Subtype.ext ?_) + rw [hedge y] + exact congrArg Subtype.val + (DirMatching.contractEdge_congr hAe ⟨i, hbi⟩ ⟨j, hbj⟩ + y.val).symm + have hstep := DirMatching.orbitCount_contract_congr hAB hne + hBij hAij (DirMatching.alternating_map _ hABg) heM heN + have hc0 : (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ).openCircuitCount = κ.openCircuitCount := by + rw [hδ, hun, ite_eq_right (fun hL => hcl (hlink.mp hL)), add_zero] + rw [hc0] + omega + +/-! ### One stage of the interface recursion + +`glueInterface` glues the top pair and then relabels. Composing the +two steps gives the recursion's stage: the circuit count plus the +number of components is unchanged across it. +-/ + +/-- **One stage of the interface recursion preserves `ĉ + c`.** -/ +theorem openCircuitCount_add_unionCount_stage + [LinearOrder α] + [Fintype α] + {γ : Type} [LinearOrder γ] [Fintype γ] + (e : SurvivingLabel α i j ≃o γ) + (κ : (Fl).RelTransitionSystem) (o : κ.Orientation) + (o' : (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ).Orientation) + (hpi : partnerSurvI hopen ∈ s') + (hbi : W.boundaryFlag i ∈ (Fl).boundaryFlags) + (hbj : W.boundaryFlag j ∈ (Fl).boundaryFlags) + {N : DirMatching + {a : α // W.boundaryFlag a ∈ (Fl).boundaryFlags}} + (hNij : N.edge ⟨i, hbi⟩ = ⟨j, hbj⟩) + {Ng : DirMatching + {l : SurvivingLabel α i j // + (W.gluePairOpen i j hij hopen).boundaryFlag l ∈ + (Fg).boundaryFlags}} + (hNg : (Ng.map + (usedLabelGlueEquiv hij hopen s' hc' hc hbi hbj)).edge + = (N.restrict hNij).edge) + {Mr Nr : DirMatching {b : γ // + ((W.gluePairOpen i j hij hopen).relabel e.toEquiv).boundaryFlag b + ∈ ((Fg).relabelUp e.toEquiv).boundaryFlags}} + (heM : (Mr.map (usedLabRelabelEquiv e (Fg))).edge + = (cutMatching (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + o').edge) + (heN : (Nr.map (usedLabRelabelEquiv e (Fg))).edge = Ng.edge) : + (relabelTransUp e.toEquiv (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ)).openCircuitCount + + DirMatching.unionCount Mr Nr + = κ.openCircuitCount + + DirMatching.unionCount (cutMatching (Fl) κ o) N := by + rw [openCircuitCount_add_unionCount_relabel e (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) heM heN] + exact openCircuitCount_add_unionCount_glueOpen hij hopen s' hc' hc + κ o o' hpi hbi hbj hNij hNg + +/-! ### Which of the base's subsets the glue reaches + +The lift and the drop are mutually inverse where they are used, but +the two closure conditions do not match: the drop of a +pairing-closed subset need not be closed under the rewire. It is +closed exactly when the two glued boundary flags are used together, +which is the condition that the glued edge is either in the subset +or out of it. So the glued fragment's subsets correspond to that +subfamily of the base's, not to all of them. +-/ + +/-- **The base's subsets the glue reaches**: pairing-closed, and +using the two glued boundary flags together. -/ +def AgreeingSubset (i j : α) (s : Finset W.Flag) : Prop := + (∀ f ∈ s, W.pairing f ∈ s) + ∧ (W.boundaryFlag i ∈ s ↔ W.boundaryFlag j ∈ s) + +/-- **The drop of a subfamily member is closed under the +rewire.** -/ +theorem dropSubset_rewire_closed (s : Finset W.Flag) + (hs : AgreeingSubset i j s) : + ∀ f ∈ W.dropSubset i j s, rewire hopen f ∈ W.dropSubset i j s := by + intro f hf + rw [mem_dropSubset] at hf ⊢ + by_cases h1 : W.pairing f.val = W.boundaryFlag i + · have hbi : W.boundaryFlag i ∈ s := h1 ▸ hs.1 _ hf + have hbj : W.boundaryFlag j ∈ s := hs.2.mp hbi + change (rewire hopen f).val ∈ s + rw [show (rewire hopen f).val = W.pairing (W.boundaryFlag j) + from by unfold rewire; rw [dite_eq_left h1]] + exact hs.1 _ hbj + · by_cases h2 : W.pairing f.val = W.boundaryFlag j + · have hbj : W.boundaryFlag j ∈ s := h2 ▸ hs.1 _ hf + have hbi : W.boundaryFlag i ∈ s := hs.2.mpr hbj + change (rewire hopen f).val ∈ s + rw [show (rewire hopen f).val = W.pairing (W.boundaryFlag i) + from by unfold rewire; rw [dite_eq_right h1, dite_eq_left h2]] + exact hs.1 _ hbi + · show (rewire hopen f).val ∈ s + rw [show (rewire hopen f).val = W.pairing f.val from by + unfold rewire; rw [dite_eq_right h1, dite_eq_right h2]] + exact hs.1 _ hf + +end GlueChord + +/-! ## The closed glue + +When the two glued labels bound a common edge, gluing closes that +edge into a free circle. No chain of a surviving label reaches the +cut, so the chord matching simply restricts; and when the closed-off +edge is in the subset, its two labels were chord partners, so a +component of the union disappears — into the free circle rather than +into a circuit. +-/ + +section GlueChordClosed + +variable {α : Type} {W : Fragment α} {i j : α} + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (b : Bool) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairClosed i j hclosed).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetClosed s' b, + W.pairing f ∈ liftSubsetClosed s' b) + +local notation "Fgc" => + (EdgeSubset.mk s' hc' : EdgeSubset (W.gluePairClosed i j hclosed)) + +local notation "Flc" => + (EdgeSubset.mk (liftSubsetClosed s' b) hc : EdgeSubset W) + +/-- **The chord matching restricts across a closed glue.** -/ +theorem chordInv_glueClosed + (κ' : (Fgc).RelTransitionSystem) (l : SurvivingLabel α i j) + (hlg : (W.gluePairClosed i j hclosed).boundaryFlag l ∈ + (Fgc).boundaryFlags) : + (chordInv (Fgc) κ' l).val + = chordInv (Flc) + (RelTransitionSystem.unglueClosed hclosed b s' hc' hc κ') + l.val := by + have hll : W.boundaryFlag l.val ∈ (Flc).boundaryFlags := + (mem_boundaryFlags_glueClosed hclosed b s' hc' hc).mp hlg + have hgf := boundaryFlag_chordInv (Fgc) κ' hlg + have hlf := boundaryFlag_chordInv (Flc) + (RelTransitionSystem.unglueClosed hclosed b s' hc' hc κ') hll + have hpm := pathMatch_unglueClosed hclosed b s' hc' hc κ' hlg hll + refine W.boundaryFlag_injective ?_ + calc W.boundaryFlag (chordInv (Fgc) κ' l).val + = ((W.gluePairClosed i j hclosed).boundaryFlag + (chordInv (Fgc) κ' l)).val := rfl + _ = (κ'.pathMatch + ((W.gluePairClosed i j hclosed).boundaryFlag l) hlg).val := + congrArg Subtype.val hgf + _ = (RelTransitionSystem.unglueClosed hclosed b s' hc' + hc κ').pathMatch (W.boundaryFlag l.val) hll := hpm.symm + _ = W.boundaryFlag (chordInv (Flc) + (RelTransitionSystem.unglueClosed hclosed b s' hc' + hc κ') l.val) := hlf.symm + +end GlueChordClosed + +section GlueChordClosedPair + +variable {α : Type} {W : Fragment α} {i j : α} + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairClosed i j hclosed).pairing f ∈ s') + (hcT : ∀ f ∈ liftSubsetClosed s' true, + W.pairing f ∈ liftSubsetClosed s' true) + +local notation "FgT" => + (EdgeSubset.mk s' hc' : EdgeSubset (W.gluePairClosed i j hclosed)) + +local notation "FlT" => + (EdgeSubset.mk (liftSubsetClosed s' true) hcT : EdgeSubset W) + +include hclosed in +/-- **The two glued labels are chord partners** when the closed-off +edge lies in the subset: the chain from one is the edge itself. -/ +theorem chordInv_closed_pair + [LinearOrder α] + (κ : (EdgeSubset.mk (liftSubsetClosed s' true) hcT : + EdgeSubset W).RelTransitionSystem) + (hbi : W.boundaryFlag i ∈ (EdgeSubset.mk + (liftSubsetClosed s' true) hcT : EdgeSubset W).boundaryFlags) : + chordInv (EdgeSubset.mk (liftSubsetClosed s' true) hcT : + EdgeSubset W) κ i = j := by + classical + have hbj : W.pairing (W.boundaryFlag i) ∈ (EdgeSubset.mk + (liftSubsetClosed s' true) hcT : + EdgeSubset W).boundaryFlags := by + rw [hclosed] + refine Finset.mem_filter.mpr ⟨?_, ⟨j, W.attach_boundaryFlag j⟩⟩ + refine Finset.mem_union_right _ ?_ + exact Finset.mem_insert_of_mem (Finset.mem_singleton_self _) + have hpm : κ.pathMatch (W.boundaryFlag i) hbi + = W.pairing (W.boundaryFlag i) := + pathMatch_exit_unique κ hbi 0 (fun t ht => absurd ht (by omega)) + hbj + refine W.boundaryFlag_injective ?_ + rw [boundaryFlag_chordInv _ κ hbi, hpm, hclosed] + +/-- **The glued subset's used labels** across a closed glue whose +edge lies in the subset: the lifted ones, less the two glued. -/ +noncomputable def usedLabelGlueClosedEquiv + (hbi : W.boundaryFlag i ∈ (FlT).boundaryFlags) + (hbj : W.boundaryFlag j ∈ (FlT).boundaryFlags) : + {l : SurvivingLabel α i j // + (W.gluePairClosed i j hclosed).boundaryFlag l ∈ + (FgT).boundaryFlags} + ≃ DirMatching.Surviving + (⟨i, hbi⟩ : {a : α // W.boundaryFlag a ∈ (FlT).boundaryFlags}) + ⟨j, hbj⟩ where + toFun x := + ⟨⟨x.val.val, + (mem_boundaryFlags_glueClosed hclosed true s' hc' hcT).mp + x.prop⟩, + fun hx => x.val.prop.1 (congrArg Subtype.val hx), + fun hx => x.val.prop.2 (congrArg Subtype.val hx)⟩ + invFun y := + ⟨⟨y.val.val, + fun hx => y.prop.1 (Subtype.ext hx), + fun hx => y.prop.2 (Subtype.ext hx)⟩, + (mem_boundaryFlags_glueClosed hclosed true s' hc' hcT).mpr + y.val.prop⟩ + left_inv _ := rfl + right_inv _ := rfl + +/-- **A closed glue drops one component.** The chord matching +restricts, and the two glued labels were partners, so the component +they formed disappears — into the free circle the glue creates. -/ +theorem unionCount_glueClosed + [LinearOrder α] + [Fintype α] + (κ' : (FgT).RelTransitionSystem) (o' : κ'.Orientation) + (o : (RelTransitionSystem.unglueClosed hclosed true s' hc' + hcT κ').Orientation) + (hbi : W.boundaryFlag i ∈ (FlT).boundaryFlags) + (hbj : W.boundaryFlag j ∈ (FlT).boundaryFlags) + {N : DirMatching + {a : α // W.boundaryFlag a ∈ (FlT).boundaryFlags}} + (hNij : N.edge ⟨i, hbi⟩ = ⟨j, hbj⟩) + {Ng : DirMatching + {l : SurvivingLabel α i j // + (W.gluePairClosed i j hclosed).boundaryFlag l ∈ + (FgT).boundaryFlags}} + (hNg : (Ng.map (usedLabelGlueClosedEquiv hclosed s' hc' hcT + hbi hbj)).edge = (N.restrict hNij).edge) : + DirMatching.unionCount (cutMatching (FgT) κ' o') Ng + 1 + = DirMatching.unionCount (cutMatching (FlT) + (RelTransitionSystem.unglueClosed hclosed true s' hc' + hcT κ') o) N := by + classical + obtain ⟨A, B, hAe, hBe, hAB⟩ := DirMatching.exists_alternating_repair + (cutMatching (FlT) + (RelTransitionSystem.unglueClosed hclosed true s' hc' hcT κ') o) + N + obtain ⟨Ag, Bg, hAge, hBge, hABg⟩ := + DirMatching.exists_alternating_repair (cutMatching (FgT) κ' o') Ng + rw [DirMatching.unionCount_eq_orbitCount hAB hAe hBe, + DirMatching.unionCount_eq_orbitCount hABg hAge hBge, + ← DirMatching.orbitCount_map + (usedLabelGlueClosedEquiv hclosed s' hc' hcT hbi hbj) hABg + (DirMatching.alternating_map _ hABg)] + have hMij : (cutMatching (FlT) + (RelTransitionSystem.unglueClosed hclosed true s' hc' hcT κ') + o).edge ⟨i, hbi⟩ = ⟨j, hbj⟩ := + Subtype.ext (chordInv_closed_pair hclosed s' hcT _ hbi) + have hAij : A.edge ⟨i, hbi⟩ = ⟨j, hbj⟩ := by rw [hAe]; exact hMij + have hBij : B.edge ⟨i, hbi⟩ = ⟨j, hbj⟩ := by rw [hBe]; exact hNij + have heM : (Ag.map + (usedLabelGlueClosedEquiv hclosed s' hc' hcT hbi hbj)).edge + = (A.restrict hAij).edge := by + rw [DirMatching.map_edge_congr _ hAge] + funext y + refine Subtype.ext (Subtype.ext ?_) + refine Eq.trans (chordInv_glueClosed hclosed true s' hc' hcT κ' + ((usedLabelGlueClosedEquiv hclosed s' hc' hcT hbi hbj).symm + y).val + ((usedLabelGlueClosedEquiv hclosed s' hc' hcT hbi hbj).symm + y).prop) ?_ + exact congrArg Subtype.val (congrFun hAe y.val).symm + have heN : (Bg.map + (usedLabelGlueClosedEquiv hclosed s' hc' hcT hbi hbj)).edge + = (B.restrict hBij).edge := by + rw [DirMatching.map_edge_congr _ hBge, hNg] + funext y + exact Subtype.ext (Subtype.ext (congrArg Subtype.val + (congrFun hBe y.val)).symm) + exact DirMatching.orbitCount_restrict_closed_congr hAB hAij hBij + (DirMatching.alternating_map _ hABg) heM heN + +/-- **The closed glue's ledger**: the circuit count is unchanged and +one component disappears, the free circle the glue creates taking +its place. -/ +theorem openCircuitCount_add_unionCount_glueClosed + [LinearOrder α] + [Fintype α] + (κ' : (FgT).RelTransitionSystem) (o' : κ'.Orientation) + (o : (RelTransitionSystem.unglueClosed hclosed true s' hc' + hcT κ').Orientation) + (hbi : W.boundaryFlag i ∈ (FlT).boundaryFlags) + (hbj : W.boundaryFlag j ∈ (FlT).boundaryFlags) + {N : DirMatching + {a : α // W.boundaryFlag a ∈ (FlT).boundaryFlags}} + (hNij : N.edge ⟨i, hbi⟩ = ⟨j, hbj⟩) + {Ng : DirMatching + {l : SurvivingLabel α i j // + (W.gluePairClosed i j hclosed).boundaryFlag l ∈ + (FgT).boundaryFlags}} + (hNg : (Ng.map (usedLabelGlueClosedEquiv hclosed s' hc' hcT + hbi hbj)).edge = (N.restrict hNij).edge) : + κ'.openCircuitCount + + DirMatching.unionCount (cutMatching (FgT) κ' o') Ng + + 1 + = (RelTransitionSystem.unglueClosed hclosed true s' hc' + hcT κ').openCircuitCount + + DirMatching.unionCount (cutMatching (FlT) + (RelTransitionSystem.unglueClosed hclosed true s' hc' + hcT κ') o) N := by + have hc1 := openCircuitCount_unglueClosed hclosed true s' hc' hcT κ' + have hc2 := unionCount_glueClosed hclosed s' hc' hcT κ' o' o hbi + hbj hNij hNg + omega + +end GlueChordClosedPair + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChords.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChords.lean new file mode 100644 index 0000000000..86ce084177 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChords.lean @@ -0,0 +1,123 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LabelChords + +/-! +# The gluing action on chord diagrams + +Gluing the cut `{i, j}` acts on label chord diagrams: the chord +`(i, j)` closes into a loop; otherwise the chords at `i` and at `j` +concatenate into one chord joining their far ends; chords avoiding +the cut pass through. This is the combinatorial (Temperley–Lieb) +composition over which the pairing-resolved gluing decomposition +lives. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} + +open Classical in +/-- The far end of the chord at `x`, when one exists. -/ +noncomputable def cutPartner [LinearOrder α] + (P : Finset (α × α)) (x : α) : + Option α := + if h : ∃ y, (min x y, max x y) ∈ P then + some (Classical.choose h) + else none + +open Classical in +/-- The glued diagram. -/ +noncomputable def glueChords [LinearOrder α] + (i j : α) (P : Finset (α × α)) : + Finset (α × α) := + match cutPartner P i, cutPartner P j with + | some x, some y => + if x = j then P.erase (min i j, max i j) + else ((P.erase (min i x, max i x)).erase + (min j y, max j y)) ∪ {(min x y, max x y)} + | _, _ => P + +/-- In a well-formed diagram a chord end determines its far end. -/ +theorem cutPartner_eq_some [LinearOrder α] + {P : Finset (α × α)} + (hP : IsChordDiagram P) {x y : α} + (h : (min x y, max x y) ∈ P) : cutPartner P x = some y := by + have hex : ∃ z, (min x z, max x z) ∈ P := ⟨y, h⟩ + rw [cutPartner, dite_eq_left hex] + have hch := Classical.choose_spec hex + have hxy : x ≠ y := by + intro he + subst he + have h1 := hP.ordered _ h + simp only [min_self, max_self] at h1 + exact lt_irrefl x h1 + have hxz : x ≠ Classical.choose hex := by + intro he + have h1 := hP.ordered _ hch + rw [← he] at h1 + simp only [min_self, max_self] at h1 + exact lt_irrefl x h1 + by_cases heq : (min x y, max x y) = + (min x (Classical.choose hex), max x (Classical.choose hex)) + · -- equal sorted pairs with a common member force equal partners + have h1 : min x y = min x (Classical.choose hex) := + congrArg Prod.fst heq + have h2 : max x y = max x (Classical.choose hex) := + congrArg Prod.snd heq + have hz : y = Classical.choose hex := by + rcases le_total x y with hle | hle <;> + rcases le_total x (Classical.choose hex) with hle' | hle' + · exact (max_eq_right hle).symm.trans + (h2.trans (max_eq_right hle')) + · exact absurd ((min_eq_left hle).symm.trans + (h1.trans (min_eq_right hle'))) hxz + · exact absurd (((min_eq_right hle).symm.trans + (h1.trans (min_eq_left hle'))).symm) hxy + · exact (min_eq_right hle).symm.trans + (h1.trans (min_eq_right hle')) + exact congrArg some hz.symm + · exfalso + have hdisj := hP.disjoint _ h _ hch heq + rcases le_total x y with hle | hle <;> + rcases le_total x (Classical.choose hex) with hle' | hle' + · exact hdisj.fst_ne_fst + ((min_eq_left hle).trans (min_eq_left hle').symm) + · exact hdisj.fst_ne_snd + ((min_eq_left hle).trans (max_eq_left hle').symm) + · exact hdisj.snd_ne_fst + ((max_eq_left hle).trans (min_eq_left hle').symm) + · exact hdisj.snd_ne_snd + ((max_eq_left hle).trans (max_eq_left hle').symm) + +/-- Well-formedness is inherited by subdiagrams. -/ +theorem IsChordDiagram.mono [LinearOrder α] + {P Q : Finset (α × α)} + (hQP : Q ⊆ P) (hP : IsChordDiagram P) : IsChordDiagram Q := + ⟨fun p hp => hP.ordered p (hQP hp), + fun p hp q hq hne => hP.disjoint p (hQP hp) q (hQP hq) hne⟩ + +/-- The glued diagram of a crossing cut: the chords at the two cut +labels concatenate. -/ +theorem glueChords_cross [LinearOrder α] + {P : Finset (α × α)} + (hP : IsChordDiagram P) {i j x y : α} (hxj : x ≠ j) + (hi : (min i x, max i x) ∈ P) (hj : (min j y, max j y) ∈ P) : + glueChords i j P = + ((P.erase (min i x, max i x)).erase (min j y, max j y)) ∪ + {(min x y, max x y)} := by + rw [glueChords, cutPartner_eq_some hP hi, + cutPartner_eq_some hP hj] + simp only [ite_eq_right hxj] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCircuitDelta.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCircuitDelta.lean new file mode 100644 index 0000000000..90afe4df56 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCircuitDelta.lean @@ -0,0 +1,1402 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueRelTransport + +/-! +# Circuit-count delta across a participating glued interface + +`GlueRelTransport` proved `openCircuitCount` stability for the open +single-pair glue when the glued edge's flags do **not** participate +in the edge subset. This file treats the participating case: the +lifted subset contains both boundary flags `bf_i, bf_j` of `W`, +which are boundary flags of the lifted edge subset, so the `W`-side +walks terminate there, while the glued walk continues through the +rewire. + +## Main results + +* `pairing_iterWalk_ne` — the master collision lemma: along any + walk with internal pairings, `W.pairing (iterWalk κ b m)` never + equals `iterWalk κ b l` (a parity argument on the alternating + chain); specialised to `pathMatch_ne_self` (the path matching has + no fixed points). +* `InterfaceLinked` — the two interface chains splice into a closed + circuit: `pathMatch` of `bf_i` is `bf_j`. +* `openCircuitCount_linked_chain`, + `openCircuitCount_glueOpen_participating` — the circuit-count + delta: gluing adds exactly one circuit when the interface is + linked and none otherwise. +-/ + +@[expose] public section + +namespace RS + + + +/-! ### Permutation counting helpers: `sumCongr` -/ + +section PermHelpers + +open Equiv + +variable {γ δ : Type} + +/-- A rotation of length `k ≥ 1` contributes exactly one orbit: +one nontrivial cycle when `k ≥ 2`, one fixed point when `k = 1`. -/ +theorem finRotate_orbit_count (k : ℕ) (hk : 1 ≤ k) : + (finRotate k).cycleType.card + + Fintype.card (Function.fixedPoints (finRotate k)) = 1 := by + match k, hk with + | 1, _ => + rw [finRotate_one] + have h1 : (Equiv.refl (Fin 1)) = (1 : Perm (Fin 1)) := rfl + rw [h1, Perm.cycleType_one] + have hall : ∀ x : Fin 1, + x ∈ Function.fixedPoints (⇑(1 : Perm (Fin 1))) := + fun x => rfl + have hcard := Fintype.card_congr (Equiv.subtypeUnivEquiv hall) + rw [Fintype.card_fin] at hcard + rw [hcard] + simp + | (n + 2), _ => + rw [cycleType_finRotate] + have hempty : + IsEmpty (Function.fixedPoints (finRotate (n + 2))) := by + refine ⟨fun x => ?_⟩ + obtain ⟨x, hx⟩ := x + have hx' : finRotate (n + 2) x = x := hx + rw [finRotate_apply] at hx' + have h1 : (1 : Fin (n + 2)) = 0 := by + have := add_left_cancel (a := x) (b := (1 : Fin (n + 2))) + (c := 0) (by rw [add_zero]; exact hx') + exact this + simp [] at h1 + rw [Fintype.card_eq_zero_iff.mpr hempty] + simp + +end PermHelpers + +namespace EdgeSubset + +variable {α : Type} {W : Fragment α} + +/-! ### Generic walk lemmas -/ + +section GenericWalk + +variable {F : EdgeSubset W} + +/-- Iterates of a periodic flag are periodic. -/ +theorem periodicFlag_iterWalk (κ : F.RelTransitionSystem) + {f : W.Flag} (hf : κ.PeriodicFlag f) (m : ℕ) : + κ.PeriodicFlag (iterWalk κ f m) := by + induction m with + | zero => exact hf + | succ m ih => + have h := RelTransitionSystem.periodicFlag_step ih + rwa [← iterWalk_add κ f m 1] at h + +/-- Reduce a walk index modulo a period. -/ +theorem iterWalk_mod (κ : F.RelTransitionSystem) {f : W.Flag} + {n : ℕ} + (hper : iterWalk κ f n = f) (a : ℕ) : + iterWalk κ f a = iterWalk κ f (a % n) := by + have hmod : ∀ q r, iterWalk κ f (n * q + r) = iterWalk κ f r := by + intro q + induction q with + | zero => intro r; simp + | succ q ih => + intro r + rw [show n * (q + 1) + r = n + (n * q + r) from by ring, + iterWalk_add_period κ f n (n * q + r) hper] + exact ih r + conv_lhs => + rw [show a = n * (a / n) + a % n from (Nat.div_add_mod a n).symm] + exact hmod (a / n) (a % n) + +/-- **Master collision lemma**: along a walk whose pairings up to +step `k` are internal, the pairing of an iterate never equals an +iterate (parity argument on the alternating chain: a collision +would force a fixed point of the edge pairing or of the +matching). -/ +theorem pairing_iterWalk_ne (κ : F.RelTransitionSystem) + {b : W.Flag} {k : ℕ} + (hcont : ∀ t, t < k → + W.pairing (iterWalk κ b t) ∈ F.internalFlags) + {m l : ℕ} (hm : m ≤ k) (hl : l ≤ k) : + W.pairing (iterWalk κ b m) ≠ iterWalk κ b l := by + have haux : ∀ d m l, l - m = d → m ≤ l → l ≤ k → + W.pairing (iterWalk κ b m) = iterWalk κ b l → False := by + intro d + induction d using Nat.strong_induction_on with + | _ d ih => + intro m l hd hml hlk heq + rcases d with _ | (_ | d) + · -- m = l: a fixed point of the edge pairing + have hml' : m = l := by omega + subst hml' + exact W.pairing_ne _ heq + · -- l = m + 1: a fixed point of the matching + have hlm : l = m + 1 := by omega + subst hlm + rw [iterWalk_succ] at heq + exact κ.match_ne _ (hcont m (by omega)) heq.symm + · -- propagate the collision inward + obtain ⟨l', rfl⟩ : ∃ l', l = l' + 1 := ⟨l - 1, by omega⟩ + have hstep : iterWalk κ b (m + 1) = + W.pairing (iterWalk κ b l') := by + rw [iterWalk_succ, heq, iterWalk_succ, + κ.match_invol _ (hcont l' (by omega))] + have heq' : W.pairing (iterWalk κ b (m + 1)) = + iterWalk κ b l' := by + rw [hstep, W.pairing_invol] + exact ih d (by omega) (m + 1) l' (by omega) + (by omega) (by omega) heq' + intro heq + rcases Nat.le_total m l with h | h + · exact haux (l - m) m l rfl h hl heq + · have heq' : W.pairing (iterWalk κ b l) = iterWalk κ b m := by + rw [← heq, W.pairing_invol] + exact haux (m - l) l m rfl h hm heq' + +/-- The path matching has no fixed points. -/ +theorem RelTransitionSystem.pathMatch_ne_self + (κ : F.RelTransitionSystem) {b : W.Flag} + (hb : b ∈ F.boundaryFlags) : + κ.pathMatch b hb ≠ b := by + obtain ⟨k, _, hcont, hpm⟩ := pathMatch_chain_length κ hb + rw [hpm] + intro h + exact pairing_iterWalk_ne κ hcont le_rfl (Nat.zero_le k) + (h.trans (iterWalk_zero κ b).symm) + +/-- Congruence for `pathMatch` in its base point. -/ +theorem RelTransitionSystem.pathMatch_congr + (κ : F.RelTransitionSystem) {b b' : W.Flag} (h : b = b') + (hb : b ∈ F.boundaryFlags) (hb' : b' ∈ F.boundaryFlags) : + κ.pathMatch b hb = κ.pathMatch b' hb' := by + subst h; rfl + +/-- Flags along a boundary-terminated chain segment are not periodic. -/ +theorem not_periodic_of_chain_segment (κ : F.RelTransitionSystem) + {b : W.Flag} {k : ℕ} + (hcont : ∀ t, t < k → + W.pairing (iterWalk κ b t) ∈ F.internalFlags) + (hterm : W.pairing (iterWalk κ b k) ∈ F.boundaryFlags) + {m : ℕ} (hmk : m ≤ k) : + ¬ κ.PeriodicFlag (iterWalk κ b m) := by + apply not_periodic_of_boundary_chain κ _ + refine ⟨(k - m) + 1, + W.pairing (iterWalk κ (iterWalk κ b m) (k - m)), ?_⟩ + apply traceChain_forward κ (iterWalk κ b m) (k := k - m) + · intro t ht + rw [← iterWalk_add] + exact hcont (m + t) (by omega) + · rw [← iterWalk_add, show m + (k - m) = k from by omega] + exact hterm + +end GenericWalk + +/-! ### The participating open glue -/ + +open Fragment + +variable {i j : α} + +section OpenGlueParticipating + +variable (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairOpen i j hij hopen).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetOpen hopen s', + W.pairing f ∈ liftSubsetOpen hopen s') + +/-- The glued edge subset. -/ +local notation "Fg" => + (EdgeSubset.mk s' hc' : EdgeSubset (W.gluePairOpen i j hij hopen)) + +/-- The lifted edge subset. -/ +local notation "Fl" => + (EdgeSubset.mk (liftSubsetOpen hopen s') hc : EdgeSubset W) + +include hc' hc + +/-! #### Interface membership -/ + +omit hc in +include hij in +/-- Participation propagates to the far end of the `j`-edge. -/ +theorem partnerSurvJ_mem_of_mem (hpi : partnerSurvI hopen ∈ s') : + partnerSurvJ hopen ∈ s' := by + have h := hc' _ hpi + rwa [gluePairOpen_pairing_interface_i hij hopen _ (by + rw [partnerSurvI_val hopen, W.pairing_invol])] at h + +omit hc' in +include hij in +/-- With participation, `bf_i` is a boundary flag of the lift. -/ +theorem boundaryFlagI_mem_boundaryFlags (hpi : partnerSurvI hopen ∈ s') : + W.boundaryFlag i ∈ (Fl).boundaryFlags := by + have hmem : W.boundaryFlag i ∈ liftSubsetOpen hopen s' := + (boundaryFlagI_mem_liftOpen_iff hij hopen s').mpr hpi + rcases mem_internalFlags_or_boundaryFlags (Fl) hmem with hint | hbd + · obtain ⟨v, hv⟩ := attach_internal_of_mem _ hint + rw [W.attach_boundaryFlag i] at hv + cases hv + · exact hbd + +/-- With participation, `bf_j` is a boundary flag of the lift. -/ +theorem boundaryFlagJ_mem_boundaryFlags (hpi : partnerSurvI hopen ∈ s') : + W.boundaryFlag j ∈ (Fl).boundaryFlags := by + have hmem : W.boundaryFlag j ∈ liftSubsetOpen hopen s' := + (boundaryFlagJ_mem_liftOpen_iff hij hopen s').mpr + (partnerSurvJ_mem_of_mem hij hopen s' hc' hpi) + rcases mem_internalFlags_or_boundaryFlags (Fl) hmem with hint | hbd + · obtain ⟨v, hv⟩ := attach_internal_of_mem _ hint + rw [W.attach_boundaryFlag j] at hv + cases hv + · exact hbd + +/-! #### Walk correspondence -/ + +/-- Walk correspondence from glued-side interface avoidance. -/ +theorem iterWalk_val_of_glued_avoids + (κ' : (Fg).RelTransitionSystem) (g : SurvivingFlag W i j) + (n : ℕ) + (hav : ∀ t, t < n → + iterWalk κ' g t ≠ partnerSurvI hopen ∧ + iterWalk κ' g t ≠ partnerSurvJ hopen) : + ∀ m, m ≤ n → + iterWalk (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ') g.val m = (iterWalk κ' g m).val := by + intro m + induction m with + | zero => exact fun _ => rfl + | succ m ih => + intro hm + have hval := ih (by omega) + obtain ⟨havI, havJ⟩ := hav m (by omega) + have h1 : W.pairing (iterWalk κ' g m).val ≠ W.boundaryFlag i := + fun hh => havI (eq_partnerSurvI_of_pairing hopen _ hh) + have h2 : W.pairing (iterWalk κ' g m).val ≠ W.boundaryFlag j := + fun hh => havJ (eq_partnerSurvJ_of_pairing hopen _ hh) + change (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').match_ (W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + g.val m)) = + (κ'.match_ ((W.gluePairOpen i j hij hopen).pairing + (iterWalk κ' g m))).val + rw [hval] + have hag : W.pairing (iterWalk κ' g m).val = + ((W.gluePairOpen i j hij hopen).pairing + (iterWalk κ' g m)).val := + (gluePairOpen_pairing_val_of_ne hij hopen _ h1 h2).symm + rw [hag, unglueOpen_match_val hij hopen s' hc' hc κ' + ((W.gluePairOpen i j hij hopen).pairing (iterWalk κ' g m))] + +/-- Walk correspondence from lifted-side internality data. -/ +theorem iterWalk_val_of_internal + (κ' : (Fg).RelTransitionSystem) (g : SurvivingFlag W i j) + (n : ℕ) + (hcontW : ∀ t, t < n → + W.pairing (iterWalk (RelTransitionSystem.unglueOpen hij hopen + s' hc' hc κ') g.val t) ∈ (Fl).internalFlags) : + ∀ m, m ≤ n → + iterWalk (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ') g.val m = (iterWalk κ' g m).val := by + intro m + induction m with + | zero => exact fun _ => rfl + | succ m ih => + intro hm + have hval := ih (by omega) + have hp := hcontW m (by omega) + rw [hval] at hp + obtain ⟨h1, h2⟩ := internal_surviving i j hp + change (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').match_ (W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + g.val m)) = + (κ'.match_ ((W.gluePairOpen i j hij hopen).pairing + (iterWalk κ' g m))).val + rw [hval] + have hag : W.pairing (iterWalk κ' g m).val = + ((W.gluePairOpen i j hij hopen).pairing + (iterWalk κ' g m)).val := + (gluePairOpen_pairing_val_of_ne hij hopen _ h1 h2).symm + rw [hag, unglueOpen_match_val hij hopen s' hc' hc κ' + ((W.gluePairOpen i j hij hopen).pairing (iterWalk κ' g m))] + +/-- Under lifted-side internality, the glued pairings along the +walk are internal. -/ +theorem gluedPairing_internal_of_internal + (κ' : (Fg).RelTransitionSystem) (g : SurvivingFlag W i j) + (n : ℕ) + (hcontW : ∀ t, t < n → + W.pairing (iterWalk (RelTransitionSystem.unglueOpen hij hopen + s' hc' hc κ') g.val t) ∈ (Fl).internalFlags) : + ∀ m, m < n → (W.gluePairOpen i j hij hopen).pairing + (iterWalk κ' g m) ∈ (Fg).internalFlags := by + intro m hm + have hp := hcontW m hm + rw [iterWalk_val_of_internal hij hopen s' hc' hc κ' g n hcontW m + (le_of_lt hm)] at hp + obtain ⟨h1, h2⟩ := internal_surviving i j hp + have hrw : (W.gluePairOpen i j hij hopen).pairing + (iterWalk κ' g m) = + (⟨W.pairing (iterWalk κ' g m).val, h1, h2⟩ : + SurvivingFlag W i j) := + Subtype.ext (gluePairOpen_pairing_val_of_ne hij hopen _ h1 h2) + rw [hrw] + exact internal_mk_of_glueOpen hij hopen s' hc' hc hp h1 h2 + +/-! #### Periodic-flag transport -/ + +/-- Periodic flags lift backward along the unglue transport +(participating case: internality of the lifted-side pairings keeps +the walk away from the interface). -/ +theorem mem_periodicFlags_glued_of_val + (κ' : (Fg).RelTransitionSystem) {g : SurvivingFlag W i j} + (hg : g.val ∈ (RelTransitionSystem.unglueOpen hij hopen s' hc' + hc κ').periodicFlags) : + g ∈ κ'.periodicFlags := by + obtain ⟨hint, n, hn1, hcontW, hper⟩ := + ((RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').mem_periodicFlags).mp hg + refine (κ'.mem_periodicFlags).mpr + ⟨(mem_internalFlags_glueOpen hij hopen s' hc' hc).mpr hint, + n, hn1, ?_, ?_⟩ + · intro m hm + exact gluedPairing_internal_of_internal hij hopen s' hc' hc κ' + g n hcontW m hm + · refine Subtype.ext ?_ + rw [← iterWalk_val_of_internal hij hopen s' hc' hc κ' g n + hcontW n le_rfl] + exact hper + +/-- Classification of glued periodic flags: either the value is +periodic on the lifted side, or the flag lies on the orbit of one +of the two interface far ends. -/ +theorem periodicFlag_val_or_orbit + (κ' : (Fg).RelTransitionSystem) {g : SurvivingFlag W i j} + (hg : g ∈ κ'.periodicFlags) : + g.val ∈ (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').periodicFlags ∨ + ((κ'.PeriodicFlag (partnerSurvI hopen) ∧ + ∃ c, iterWalk κ' (partnerSurvI hopen) c = g) ∨ + (κ'.PeriodicFlag (partnerSurvJ hopen) ∧ + ∃ c, iterWalk κ' (partnerSurvJ hopen) c = g)) := by + obtain ⟨hint, n, hn1, hcont', hper⟩ := (κ'.mem_periodicFlags).mp hg + have hgper' : κ'.PeriodicFlag g := ⟨hint, n, hn1, hcont', hper⟩ + by_cases hhit : ∃ m, m < n ∧ + (iterWalk κ' g m = partnerSurvI hopen ∨ + iterWalk κ' g m = partnerSurvJ hopen) + · obtain ⟨m, hm, hor⟩ := hhit + right + have hback : iterWalk κ' (iterWalk κ' g m) (n - m) = g := by + have h := iterWalk_add κ' g m (n - m) + rw [show m + (n - m) = n from by omega, hper] at h + exact h.symm + have hperm := periodicFlag_iterWalk κ' hgper' m + rcases hor with h | h + · rw [h] at hback hperm + exact Or.inl ⟨hperm, n - m, hback⟩ + · rw [h] at hback hperm + exact Or.inr ⟨hperm, n - m, hback⟩ + · left + have hav : ∀ t, t < n → + iterWalk κ' g t ≠ partnerSurvI hopen ∧ + iterWalk κ' g t ≠ partnerSurvJ hopen := by + intro t ht + exact ⟨fun h => hhit ⟨t, ht, Or.inl h⟩, + fun h => hhit ⟨t, ht, Or.inr h⟩⟩ + have hcorr := iterWalk_val_of_glued_avoids hij hopen s' hc' hc + κ' g n hav + refine ((RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').mem_periodicFlags).mpr + ⟨(mem_internalFlags_glueOpen hij hopen s' hc' hc).mp hint, + n, hn1, ?_, ?_⟩ + · intro m hm + rw [hcorr m (le_of_lt hm)] + obtain ⟨havI, havJ⟩ := hav m hm + have h1 : W.pairing (iterWalk κ' g m).val ≠ + W.boundaryFlag i := + fun hh => havI (eq_partnerSurvI_of_pairing hopen _ hh) + have h2 : W.pairing (iterWalk κ' g m).val ≠ + W.boundaryFlag j := + fun hh => havJ (eq_partnerSurvJ_of_pairing hopen _ hh) + have hag : W.pairing (iterWalk κ' g m).val = + ((W.gluePairOpen i j hij hopen).pairing + (iterWalk κ' g m)).val := + (gluePairOpen_pairing_val_of_ne hij hopen _ h1 h2).symm + rw [hag] + exact (mem_internalFlags_glueOpen hij hopen s' hc' hc).mp + (hcont' m hm) + · rw [hcorr n le_rfl] + exact congrArg Subtype.val hper + +/-! #### Exit forced to the interface -/ + +/-- If the glued walk entering the chain of a boundary flag `b` +has all its pairings internal, the `W`-side chain from `b` must +exit at the glued interface. -/ +theorem pathMatch_mem_interface_of_glued_internal + (κ' : (Fg).RelTransitionSystem) {b : W.Flag} + (hb : b ∈ (Fl).boundaryFlags) + (h1 : W.pairing b ≠ W.boundaryFlag i) + (h2 : W.pairing b ≠ W.boundaryFlag j) + (h0 : (⟨W.pairing b, h1, h2⟩ : SurvivingFlag W i j) ∈ + (Fg).internalFlags) + (hz : ∀ t, (W.gluePairOpen i j hij hopen).pairing + (iterWalk κ' (κ'.match_ ⟨W.pairing b, h1, h2⟩) t) ∈ + (Fg).internalFlags) : + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').pathMatch b hb = W.boundaryFlag i ∨ + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').pathMatch b hb = W.boundaryFlag j := by + set κW := RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ' + with hκW + obtain ⟨k, hk_le, hcont, hpm⟩ := pathMatch_chain_length κW hb + have hpmb : W.pairing (iterWalk κW b k) ∈ (Fl).boundaryFlags := by + rw [← hpm] + exact κW.pathMatch_mem hb + rcases Nat.eq_zero_or_pos k with rfl | hk1 + · -- k = 0: the partner of b would be both internal and boundary + rw [iterWalk_zero] at hpmb + have hintFl : W.pairing b ∈ (Fl).internalFlags := + (mem_internalFlags_glueOpen hij hopen s' hc' hc).mp h0 + exact absurd hpmb + (Finset.disjoint_left.mp + ((Fl).internalFlags_disjoint_boundaryFlags) hintFl) + · by_cases hne1 : κW.pathMatch b hb = W.boundaryFlag i + · exact Or.inl hne1 + by_cases hne2 : κW.pathMatch b hb = W.boundaryFlag j + · exact Or.inr hne2 + exfalso + rw [hpm] at hne1 hne2 + -- track the chain through the glued walk up to the exit + have hzval : (κ'.match_ (⟨W.pairing b, h1, h2⟩ : + SurvivingFlag W i j)).val = κW.match_ (W.pairing b) := + (unglueOpen_match_val hij hopen s' hc' hc κ' + ⟨W.pairing b, h1, h2⟩).symm + have hzwalk : ∀ t, iterWalk κW + (κ'.match_ (⟨W.pairing b, h1, h2⟩ : + SurvivingFlag W i j)).val t = iterWalk κW b (t + 1) := by + intro t + rw [hzval] + exact iterWalk_shift κW b t + have hcontW : ∀ t, t < k - 1 → + W.pairing (iterWalk κW + (κ'.match_ (⟨W.pairing b, h1, h2⟩ : + SurvivingFlag W i j)).val t) ∈ (Fl).internalFlags := by + intro t ht + rw [hzwalk t] + exact hcont (t + 1) (by omega) + have hyval : (iterWalk κ' + (κ'.match_ (⟨W.pairing b, h1, h2⟩ : SurvivingFlag W i j)) + (k - 1)).val = iterWalk κW b k := by + rw [← iterWalk_val_of_internal hij hopen s' hc' hc κ' _ + (k - 1) hcontW (k - 1) le_rfl, hzwalk, + show k - 1 + 1 = k from by omega] + have hexit1 : W.pairing (iterWalk κ' + (κ'.match_ (⟨W.pairing b, h1, h2⟩ : SurvivingFlag W i j)) + (k - 1)).val ≠ W.boundaryFlag i := by + rw [hyval]; exact hne1 + have hexit2 : W.pairing (iterWalk κ' + (κ'.match_ (⟨W.pairing b, h1, h2⟩ : SurvivingFlag W i j)) + (k - 1)).val ≠ W.boundaryFlag j := by + rw [hyval]; exact hne2 + have hyint := hz (k - 1) + have hagy : ((W.gluePairOpen i j hij hopen).pairing + (iterWalk κ' (κ'.match_ (⟨W.pairing b, h1, h2⟩ : + SurvivingFlag W i j)) (k - 1))).val = + W.pairing (iterWalk κW b k) := by + rw [gluePairOpen_pairing_val_of_ne hij hopen _ hexit1 hexit2, + hyval] + have hintFl : W.pairing (iterWalk κW b k) ∈ + (Fl).internalFlags := by + rw [← hagy] + exact (mem_internalFlags_glueOpen hij hopen s' hc' hc).mp + hyint + exact Finset.disjoint_left.mp + ((Fl).internalFlags_disjoint_boundaryFlags) hintFl hpmb + +/-! #### The link condition -/ + +/-- **The interface link condition**: the `W`-side chain from +`bf_i` (under the unglued transition data) exits at `bf_j`. When +it holds, gluing splices the two interface chains into one new +closed circuit; otherwise it concatenates two boundary paths. -/ +def InterfaceLinked (κ' : (Fg).RelTransitionSystem) + (hpi : partnerSurvI hopen ∈ s') : Prop := + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ').pathMatch + (W.boundaryFlag i) + (boundaryFlagI_mem_boundaryFlags hij hopen s' hc hpi) = + W.boundaryFlag j + +/-- **Feed-forward form of the link condition**: it is literally +the `pathMatch` pairing of the two interface boundary flags. -/ +theorem interfaceLinked_iff_pathMatch (κ' : (Fg).RelTransitionSystem) + (hpi : partnerSurvI hopen ∈ s') : + InterfaceLinked hij hopen s' hc' hc κ' hpi ↔ + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').pathMatch (W.boundaryFlag i) + (boundaryFlagI_mem_boundaryFlags hij hopen s' hc hpi) = + W.boundaryFlag j := + Iff.rfl + +/-- If the far end of the `i`-edge is periodic in the glued +system, the interface is linked. -/ +theorem interfaceLinked_of_periodicI (κ' : (Fg).RelTransitionSystem) + (hpi : partnerSurvI hopen ∈ s') + (hper : κ'.PeriodicFlag (partnerSurvI hopen)) : + InterfaceLinked hij hopen s' hc' hc κ' hpi := by + have hbj := boundaryFlagJ_mem_boundaryFlags hij hopen s' hc' hc + hpi + have h1 : W.pairing (W.boundaryFlag j) ≠ W.boundaryFlag i := + fun h => hopen (W.pairing_boundaryFlag_comm h) + have h2 : W.pairing (W.boundaryFlag j) ≠ W.boundaryFlag j := + W.pairing_ne _ + have hmk : (⟨W.pairing (W.boundaryFlag j), h1, h2⟩ : + SurvivingFlag W i j) = partnerSurvJ hopen := rfl + have hrw : (W.gluePairOpen i j hij hopen).pairing + (partnerSurvI hopen) = partnerSurvJ hopen := + gluePairOpen_pairing_interface_i hij hopen _ + (by rw [partnerSurvI_val hopen, W.pairing_invol]) + have h0 : (⟨W.pairing (W.boundaryFlag j), h1, h2⟩ : + SurvivingFlag W i j) ∈ (Fg).internalFlags := by + rw [hmk] + have h := all_pairings_internal_of_periodic κ' hper 0 + have h' : (W.gluePairOpen i j hij hopen).pairing + (partnerSurvI hopen) ∈ (Fg).internalFlags := h + rw [hrw] at h' + exact h' + have hz : ∀ t, (W.gluePairOpen i j hij hopen).pairing + (iterWalk κ' (κ'.match_ + ⟨W.pairing (W.boundaryFlag j), h1, h2⟩) t) ∈ + (Fg).internalFlags := by + intro t + have hshift := iterWalk_shift κ' (partnerSurvI hopen) t + rw [hrw] at hshift + rw [hmk, hshift] + exact all_pairings_internal_of_periodic κ' hper (t + 1) + rcases pathMatch_mem_interface_of_glued_internal hij hopen s' + hc' hc κ' hbj h1 h2 h0 hz with h | h + · unfold InterfaceLinked + calc (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').pathMatch (W.boundaryFlag i) + (boundaryFlagI_mem_boundaryFlags hij hopen s' hc hpi) + = (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').pathMatch + ((RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').pathMatch (W.boundaryFlag j) hbj) + ((RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').pathMatch_mem hbj) := + RelTransitionSystem.pathMatch_congr _ h.symm _ _ + _ = W.boundaryFlag j := + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').pathMatch_invol hbj + · exact absurd h + ((RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').pathMatch_ne_self hbj) + +/-- If the far end of the `j`-edge is periodic in the glued +system, the interface is linked. -/ +theorem interfaceLinked_of_periodicJ (κ' : (Fg).RelTransitionSystem) + (hpi : partnerSurvI hopen ∈ s') + (hper : κ'.PeriodicFlag (partnerSurvJ hopen)) : + InterfaceLinked hij hopen s' hc' hc κ' hpi := by + have hbi := boundaryFlagI_mem_boundaryFlags hij hopen s' hc + hpi + have h1 : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag i := + W.pairing_ne _ + have h2 : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j := + hopen + have hmk : (⟨W.pairing (W.boundaryFlag i), h1, h2⟩ : + SurvivingFlag W i j) = partnerSurvI hopen := rfl + have hrw : (W.gluePairOpen i j hij hopen).pairing + (partnerSurvJ hopen) = partnerSurvI hopen := + gluePairOpen_pairing_interface_j hij hopen _ + (by + rw [partnerSurvJ_val hopen, W.pairing_invol] + exact fun hh => hij (W.boundaryFlag_injective hh).symm) + (by rw [partnerSurvJ_val hopen, W.pairing_invol]) + have h0 : (⟨W.pairing (W.boundaryFlag i), h1, h2⟩ : + SurvivingFlag W i j) ∈ (Fg).internalFlags := by + rw [hmk] + have h := all_pairings_internal_of_periodic κ' hper 0 + have h' : (W.gluePairOpen i j hij hopen).pairing + (partnerSurvJ hopen) ∈ (Fg).internalFlags := h + rw [hrw] at h' + exact h' + have hz : ∀ t, (W.gluePairOpen i j hij hopen).pairing + (iterWalk κ' (κ'.match_ + ⟨W.pairing (W.boundaryFlag i), h1, h2⟩) t) ∈ + (Fg).internalFlags := by + intro t + have hshift := iterWalk_shift κ' (partnerSurvJ hopen) t + rw [hrw] at hshift + rw [hmk, hshift] + exact all_pairings_internal_of_periodic κ' hper (t + 1) + rcases pathMatch_mem_interface_of_glued_internal hij hopen s' + hc' hc κ' hbi h1 h2 h0 hz with h | h + · exact absurd h + ((RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').pathMatch_ne_self hbi) + · exact h + +/-! #### The unlinked case: counts agree -/ + +/-- The periodic-flag bijection in the unlinked participating +case. -/ +noncomputable def periodicEquivNotLinked (κ' : (Fg).RelTransitionSystem) + (hpi : partnerSurvI hopen ∈ s') + (hnl : ¬ InterfaceLinked hij hopen s' hc' hc κ' hpi) : + {f : W.Flag // f ∈ (RelTransitionSystem.unglueOpen hij hopen + s' hc' hc κ').periodicFlags} ≃ + {g : (W.gluePairOpen i j hij hopen).Flag // + g ∈ κ'.periodicFlags} where + toFun f := ⟨(⟨f.val, + (internal_surviving i j ((RelTransitionSystem.unglueOpen hij + hopen s' hc' hc κ').periodicFlags_sub f.prop)).1, + (internal_surviving i j ((RelTransitionSystem.unglueOpen hij + hopen s' hc' hc κ').periodicFlags_sub f.prop)).2⟩ : + SurvivingFlag W i j), + mem_periodicFlags_glued_of_val hij hopen s' hc' hc κ' f.prop⟩ + invFun g := ⟨g.val.val, by + rcases periodicFlag_val_or_orbit hij hopen s' hc' hc κ' g.prop + with h | (⟨hperI, _⟩ | ⟨hperJ, _⟩) + · exact h + · exact absurd (interfaceLinked_of_periodicI hij hopen s' hc' + hc κ' hpi hperI) hnl + · exact absurd (interfaceLinked_of_periodicJ hij hopen s' hc' + hc κ' hpi hperJ) hnl⟩ + left_inv _f := Subtype.ext rfl + right_inv _g := Subtype.ext (Subtype.ext rfl) + +/-- The walk permutations agree under the bijection (unlinked +case). -/ +theorem walkPermPeriodic_notLinked (κ' : (Fg).RelTransitionSystem) + (hpi : partnerSurvI hopen ∈ s') + (hnl : ¬ InterfaceLinked hij hopen s' hc' hc κ' hpi) : + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').walkPermPeriodic = + (periodicEquivNotLinked hij hopen s' hc' hc κ' hpi + hnl).symm.permCongr κ'.walkPermPeriodic := by + apply Equiv.ext + rintro ⟨f, hf⟩ + obtain ⟨h1, h2⟩ := internal_surviving i j + ((RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').periodicFlags_sub hf) + apply Subtype.ext + change (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').match_ (W.pairing f) = + (κ'.match_ ((W.gluePairOpen i j hij hopen).pairing + ⟨f, h1, h2⟩)).val + have hpf := all_pairings_internal_of_periodic + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (((RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').mem_periodicFlags).mp hf) 0 + rw [iterWalk_zero] at hpf + obtain ⟨hp1, hp2⟩ := internal_surviving i j hpf + have hag : W.pairing f = + ((W.gluePairOpen i j hij hopen).pairing ⟨f, h1, h2⟩).val := + (gluePairOpen_pairing_val_of_ne hij hopen ⟨f, h1, h2⟩ hp1 + hp2).symm + rw [hag, unglueOpen_match_val hij hopen s' hc' hc κ' + ((W.gluePairOpen i j hij hopen).pairing ⟨f, h1, h2⟩)] + +/-- **Count stability in the unlinked case.** -/ +theorem openCircuitCount_notLinked (κ' : (Fg).RelTransitionSystem) + (hpi : partnerSurvI hopen ∈ s') + (hnl : ¬ InterfaceLinked hij hopen s' hc' hc κ' hpi) : + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').openCircuitCount = κ'.openCircuitCount := by + unfold RelTransitionSystem.openCircuitCount + rw [walkPermPeriodic_notLinked hij hopen s' hc' hc κ' hpi hnl, + cycleType_permCongr, card_fixedPoints_permCongr] + +/-! #### The spliced interface cycle -/ + +section SpliceSide + +variable (κ' : (EdgeSubset.mk s' hc' : + EdgeSubset (W.gluePairOpen i j hij hopen)).RelTransitionSystem) + (x y : SurvivingFlag W i j) (b bo : W.Flag) + (hb : b ∈ (EdgeSubset.mk (liftSubsetOpen hopen s') hc : + EdgeSubset W).boundaryFlags) + (hbo : bo ∈ (EdgeSubset.mk (liftSubsetOpen hopen s') hc : + EdgeSubset W).boundaryFlags) + (hxb : x.val = W.pairing b) (hyo : y.val = W.pairing bo) + (hryx : (W.gluePairOpen i j hij hopen).pairing y = x) + (k : ℕ) (hk1 : 1 ≤ k) + (hcont : ∀ t, t < k → W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') b t) ∈ + (EdgeSubset.mk (liftSubsetOpen hopen s') hc : + EdgeSubset W).internalFlags) + (hterm : W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') b k) = + bo) + +include hb hbo hxb hyo hryx hk1 hcont hterm + +omit hb hbo hyo hryx hterm in +/-- The near end of the entry edge is internal in the glued +subset. -/ +theorem splice_x_internal : x ∈ (Fg).internalFlags := by + refine (mem_internalFlags_glueOpen hij hopen s' hc' hc).mpr ?_ + rw [hxb] + exact hcont 0 (by omega) + +omit hb hbo hyo hryx hk1 hcont hterm in +/-- The entry value of the spliced walk. -/ +theorem splice_entry_val : (κ'.match_ x).val = + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ').match_ + (W.pairing b) := by + rw [← hxb] + exact (unglueOpen_match_val hij hopen s' hc' hc κ' x).symm + +omit hb hbo hyo hryx hk1 hcont hterm in +/-- The lifted walk from the entry point is the shifted chain. -/ +theorem splice_walk_valW : ∀ t, + iterWalk (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ') (κ'.match_ x).val t = + iterWalk (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ') b (t + 1) := by + intro t + rw [splice_entry_val hij hopen s' hc' hc κ' x b hxb] + exact iterWalk_shift + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') b t + +omit hb hbo hyo hryx hk1 hterm in +/-- The lifted pairings along the shifted chain stay internal. -/ +theorem splice_contW : ∀ t, t < k - 1 → + W.pairing (iterWalk (RelTransitionSystem.unglueOpen hij hopen + s' hc' hc κ') (κ'.match_ x).val t) ∈ (Fl).internalFlags := by + intro t ht + rw [splice_walk_valW hij hopen s' hc' hc κ' x b hxb t] + exact hcont (t + 1) (by omega) + +omit hb hbo hyo hryx hterm in +/-- **Cycle values**: the glued walk from the entry point follows +the `W`-side chain from `b`. -/ +theorem splice_walk_val : ∀ t, t < k → + (iterWalk κ' (κ'.match_ x) t).val = + iterWalk (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ') b (t + 1) := by + intro t ht + rw [← iterWalk_val_of_internal hij hopen s' hc' hc κ' + (κ'.match_ x) (k - 1) + (splice_contW hij hopen s' hc' hc κ' x b hxb k hcont) t (by omega), + splice_walk_valW hij hopen s' hc' hc κ' x b hxb t] + +omit hb hbo hryx in +/-- **Exit flag**: at step `k - 1` the glued walk sits at the far +end of the exit edge. -/ +theorem splice_last : iterWalk κ' (κ'.match_ x) (k - 1) = y := by + refine Subtype.ext ?_ + rw [splice_walk_val hij hopen s' hc' hc κ' x b hxb k hk1 hcont (k - 1) (by + omega), + show k - 1 + 1 = k from by omega, hyo] + have h := congrArg W.pairing hterm + rwa [W.pairing_invol] at h + +omit hb hbo in +/-- **The wrap**: the glued walk closes up with period `k`. -/ +theorem splice_period : iterWalk κ' (κ'.match_ x) k = κ'.match_ x + := by + obtain ⟨k0, rfl⟩ : ∃ k0, k = k0 + 1 := ⟨k - 1, by omega⟩ + change κ'.match_ ((W.gluePairOpen i j hij hopen).pairing + (iterWalk κ' (κ'.match_ x) k0)) = κ'.match_ x + have hlast := splice_last hij hopen s' hc' hc κ' x y b bo + hxb hyo (k0 + 1) hk1 hcont hterm + rw [show (k0 + 1) - 1 = k0 from rfl] at hlast + rw [hlast, hryx] + +omit hb hbo in +/-- The glued pairings along the spliced cycle are internal. -/ +theorem splice_pairing_internal : ∀ t, t < k → + (W.gluePairOpen i j hij hopen).pairing + (iterWalk κ' (κ'.match_ x) t) ∈ (Fg).internalFlags := by + intro t ht + rcases Nat.lt_or_ge t (k - 1) with h | h + · exact gluedPairing_internal_of_internal hij hopen s' hc' hc κ' + (κ'.match_ x) (k - 1) + (splice_contW hij hopen s' hc' hc κ' x b hxb k hcont) t h + · have ht' : t = k - 1 := by omega + subst ht' + rw [splice_last hij hopen s' hc' hc κ' x y b bo hxb hyo + k hk1 hcont hterm, hryx] + exact splice_x_internal hij hopen s' hc' hc κ' x b + hxb k hk1 hcont + +omit hb hbo in +/-- **The spliced cycle is periodic** in the glued system. -/ +theorem splice_periodicFlag : κ'.PeriodicFlag (κ'.match_ x) := + ⟨κ'.match_mem x + (splice_x_internal hij hopen s' hc' hc κ' x b hxb + k hk1 hcont), + k, hk1, + splice_pairing_internal hij hopen s' hc' hc κ' x y b bo + hxb hyo hryx k hk1 hcont hterm, + splice_period hij hopen s' hc' hc κ' x y b bo hxb hyo + hryx k hk1 hcont hterm⟩ + +omit hb hyo hryx in +/-- Cycle values are not periodic on the lifted side. -/ +theorem splice_val_not_periodic : ∀ t, t < k → + (iterWalk κ' (κ'.match_ x) t).val ∉ + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').periodicFlags := by + intro t ht hmem + have hper := ((RelTransitionSystem.unglueOpen hij hopen s' hc' + hc κ').mem_periodicFlags).mp hmem + rw [splice_walk_val hij hopen s' hc' hc κ' x b hxb k hk1 hcont t ht] at hper + exact not_periodic_of_chain_segment + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') hcont + (by rw [hterm]; exact hbo) + (by omega : t + 1 ≤ k) hper + +omit hbo hyo hryx hterm in +/-- Distinctness along the spliced cycle. -/ +theorem splice_inj : ∀ t₁ t₂, t₁ < k → t₂ < k → + iterWalk κ' (κ'.match_ x) t₁ = iterWalk κ' (κ'.match_ x) t₂ → + t₁ = t₂ := by + intro t₁ t₂ ht₁ ht₂ hEq + have hval := congrArg Subtype.val hEq + rw [splice_walk_val hij hopen s' hc' hc κ' x b hxb k hk1 hcont t₁ ht₁, + splice_walk_val hij hopen s' hc' hc κ' x b hxb k hk1 hcont t₂ ht₂] at hval + rcases Nat.lt_trichotomy t₁ t₂ with h | h | h + · exfalso + refine iterWalk_no_repeat + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') hb k + hcont (t₁ + 1) (t₂ - t₁) (by omega) (by omega) ?_ + rw [show t₁ + 1 + (t₂ - t₁) = t₂ + 1 from by omega] + exact hval + · exact h + · exfalso + refine iterWalk_no_repeat + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') hb k + hcont (t₂ + 1) (t₁ - t₂) (by omega) (by omega) ?_ + rw [show t₂ + 1 + (t₁ - t₂) = t₁ + 1 from by omega] + exact hval.symm + +omit hb hbo in +/-- Index reduction along the spliced cycle. -/ +theorem splice_mod : ∀ c, + iterWalk κ' (κ'.match_ x) c = iterWalk κ' (κ'.match_ x) (c % k) + := by + intro c + exact iterWalk_mod κ' + (splice_period hij hopen s' hc' hc κ' x y b bo hxb hyo + hryx k hk1 hcont hterm) c + +end SpliceSide + +/-! #### The linked case: the counting bijection -/ + +/-- Forward-map component: a lifted periodic flag, as a glued +periodic flag. -/ +noncomputable def liftPeriodic (κ' : (Fg).RelTransitionSystem) + (f : {f : W.Flag // f ∈ (RelTransitionSystem.unglueOpen hij + hopen s' hc' hc κ').periodicFlags}) : + {g : (W.gluePairOpen i j hij hopen).Flag // + g ∈ κ'.periodicFlags} := + ⟨(⟨f.val, + (internal_surviving i j ((RelTransitionSystem.unglueOpen hij + hopen s' hc' hc κ').periodicFlags_sub f.prop)).1, + (internal_surviving i j ((RelTransitionSystem.unglueOpen hij + hopen s' hc' hc κ').periodicFlags_sub f.prop)).2⟩ : + SurvivingFlag W i j), + mem_periodicFlags_glued_of_val hij hopen s' hc' hc κ' f.prop⟩ + +/-- Forward-map component: a flag on a spliced cycle. -/ +noncomputable def spliceFlag (κ' : (Fg).RelTransitionSystem) + (x : SurvivingFlag W i j) + (hper : κ'.PeriodicFlag (κ'.match_ x)) (t : ℕ) : + {g : (W.gluePairOpen i j hij hopen).Flag // + g ∈ κ'.periodicFlags} := + ⟨iterWalk κ' (κ'.match_ x) t, + (κ'.mem_periodicFlags).mpr (periodicFlag_iterWalk κ' hper t)⟩ + +private theorem linked_walkMap_injective (κ' : (Fg).RelTransitionSystem) + (hbi : W.boundaryFlag i ∈ (Fl).boundaryFlags) + (hbj : W.boundaryFlag j ∈ (Fl).boundaryFlags) + (k : ℕ) (hk1 : 1 ≤ k) + (hcontA : ∀ t, t < k → W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (W.boundaryFlag i) t) ∈ (Fl).internalFlags) + (htermA : W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (W.boundaryFlag i) k) = W.boundaryFlag j) + (hperA : κ'.PeriodicFlag (κ'.match_ (partnerSurvI hopen))) + (hperB : κ'.PeriodicFlag (κ'.match_ (partnerSurvJ hopen))) : + Function.Injective + (Sum.elim (liftPeriodic hij hopen s' hc' hc κ') + (Sum.elim + (fun t : Fin k => spliceFlag hij hopen s' hc' κ' + (partnerSurvI hopen) hperA t.val) + (fun t : Fin k => spliceFlag hij hopen s' hc' κ' + (partnerSurvJ hopen) hperB t.val))) := by + have hbfj_eq : W.boundaryFlag j = W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (W.boundaryFlag i) k) := htermA.symm + have hcontB : ∀ t, t < k → W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (W.boundaryFlag j) t) ∈ (Fl).internalFlags := by + intro t ht + rw [hbfj_eq] + exact reverse_chain_continues + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + hbi hcontA t ht + have htermB : W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (W.boundaryFlag j) k) = W.boundaryFlag i := by + rw [hbfj_eq] + exact reverse_chain_terminates + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + hcontA + -- the two spliced cycles + have hSA_val := splice_walk_val hij hopen s' hc' hc κ' + (partnerSurvI hopen) (W.boundaryFlag i) rfl k hk1 hcontA + have hSB_val := splice_walk_val hij hopen s' hc' hc κ' + (partnerSurvJ hopen) (W.boundaryFlag j) rfl k hk1 hcontB + have hSA_inj := splice_inj hij hopen s' hc' hc κ' + (partnerSurvI hopen) (W.boundaryFlag i) hbi rfl + k hk1 hcontA + have hSB_inj := splice_inj hij hopen s' hc' hc κ' + (partnerSurvJ hopen) (W.boundaryFlag j) hbj rfl + k hk1 hcontB + have hSA_notper := splice_val_not_periodic hij hopen s' hc' hc κ' + (partnerSurvI hopen) (W.boundaryFlag i) (W.boundaryFlag j) + hbj rfl k hk1 hcontA htermA + have hSB_notper := splice_val_not_periodic hij hopen s' hc' hc κ' + (partnerSurvJ hopen) (W.boundaryFlag j) (W.boundaryFlag i) + hbi rfl k hk1 hcontB htermB + have hcross : ∀ t₁ t₂ : ℕ, t₁ < k → t₂ < k → + (iterWalk κ' (κ'.match_ (partnerSurvI hopen)) t₁).val ≠ + (iterWalk κ' (κ'.match_ (partnerSurvJ hopen)) t₂).val + := by + intro t₁ t₂ h₁ h₂ hEq + rw [hSA_val t₁ h₁, hSB_val t₂ h₂] at hEq + have hrev : iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (W.boundaryFlag j) (t₂ + 1) = + W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (W.boundaryFlag i) (k - (t₂ + 1))) := by + rw [hbfj_eq] + exact iterWalk_reverse + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + hcontA (t₂ + 1) (by omega) + rw [hrev] at hEq + exact pairing_iterWalk_ne + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + hcontA (by omega : k - (t₂ + 1) ≤ k) (by omega : t₁ + 1 ≤ k) + hEq.symm + -- ═══════ STAGE 1: THE FORWARD MAP IS INJECTIVE ═══════ + -- injectivity of the forward map + rintro (f₁ | (t₁ | t₁)) (f₂ | (t₂ | t₂)) hEq + · exact congrArg Sum.inl (Subtype.ext + (congrArg (fun z => z.val.val) hEq : f₁.val = f₂.val)) + · exfalso + have h1 : f₁.val = (iterWalk κ' + (κ'.match_ (partnerSurvI hopen)) t₂.val).val := + congrArg (fun z => z.val.val) hEq + have hf := f₁.prop + rw [h1] at hf + exact hSA_notper t₂.val t₂.isLt hf + · exfalso + have h1 : f₁.val = (iterWalk κ' + (κ'.match_ (partnerSurvJ hopen)) t₂.val).val := + congrArg (fun z => z.val.val) hEq + have hf := f₁.prop + rw [h1] at hf + exact hSB_notper t₂.val t₂.isLt hf + · exfalso + have h1 : (iterWalk κ' (κ'.match_ (partnerSurvI hopen)) + t₁.val).val = f₂.val := + congrArg (fun z => z.val.val) hEq + have hf := f₂.prop + rw [← h1] at hf + exact hSA_notper t₁.val t₁.isLt hf + · have h1 : iterWalk κ' (κ'.match_ (partnerSurvI hopen)) + t₁.val = + iterWalk κ' (κ'.match_ (partnerSurvI hopen)) t₂.val := + congrArg Subtype.val hEq + exact congrArg (fun t => Sum.inr (Sum.inl t)) + (Fin.ext (hSA_inj t₁.val t₂.val t₁.isLt t₂.isLt h1)) + · exfalso + have h1 : (iterWalk κ' (κ'.match_ (partnerSurvI hopen)) + t₁.val).val = + (iterWalk κ' (κ'.match_ (partnerSurvJ hopen)) + t₂.val).val := + congrArg (fun z => z.val.val) hEq + exact hcross t₁.val t₂.val t₁.isLt t₂.isLt h1 + · exfalso + have h1 : (iterWalk κ' (κ'.match_ (partnerSurvJ hopen)) + t₁.val).val = f₂.val := + congrArg (fun z => z.val.val) hEq + have hf := f₂.prop + rw [← h1] at hf + exact hSB_notper t₁.val t₁.isLt hf + · exfalso + have h1 : (iterWalk κ' (κ'.match_ (partnerSurvI hopen)) + t₂.val).val = + (iterWalk κ' (κ'.match_ (partnerSurvJ hopen)) + t₁.val).val := + (congrArg (fun z => z.val.val) hEq).symm + exact hcross t₂.val t₁.val t₂.isLt t₁.isLt h1 + · have h1 : iterWalk κ' (κ'.match_ (partnerSurvJ hopen)) + t₁.val = + iterWalk κ' (κ'.match_ (partnerSurvJ hopen)) t₂.val + := + congrArg Subtype.val hEq + exact congrArg (fun t => Sum.inr (Sum.inr t)) + (Fin.ext (hSB_inj t₁.val t₂.val t₁.isLt t₂.isLt h1)) +-- ═══════ STAGE 2: THE FORWARD MAP IS SURJECTIVE ═══════ +-- surjectivity of the forward map + +private theorem linked_walkMap_equivariant (κ' : (Fg).RelTransitionSystem) + (hbi : W.boundaryFlag i ∈ (Fl).boundaryFlags) + (k : ℕ) (hk1 : 1 ≤ k) + (hcontA : ∀ t, t < k → W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (W.boundaryFlag i) t) ∈ (Fl).internalFlags) + (htermA : W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (W.boundaryFlag i) k) = W.boundaryFlag j) + (hperA : κ'.PeriodicFlag (κ'.match_ (partnerSurvI hopen))) + (hperB : κ'.PeriodicFlag (κ'.match_ (partnerSurvJ hopen))) : + ∀ z, κ'.walkPermPeriodic + ((Sum.elim (liftPeriodic hij hopen s' hc' hc κ') + (Sum.elim + (fun t : Fin k => spliceFlag hij hopen s' hc' κ' + (partnerSurvI hopen) hperA t.val) + (fun t : Fin k => spliceFlag hij hopen s' hc' κ' + (partnerSurvJ hopen) hperB t.val))) z) = + (Sum.elim (liftPeriodic hij hopen s' hc' hc κ') + (Sum.elim + (fun t : Fin k => spliceFlag hij hopen s' hc' κ' + (partnerSurvI hopen) hperA t.val) + (fun t : Fin k => spliceFlag hij hopen s' hc' κ' + (partnerSurvJ hopen) hperB t.val))) + ((Equiv.sumCongr (RelTransitionSystem.unglueOpen hij hopen + s' hc' hc κ').walkPermPeriodic + (Equiv.sumCongr (finRotate k) (finRotate k))) z) := by + have hpIpJ : (W.gluePairOpen i j hij hopen).pairing + (partnerSurvI hopen) = partnerSurvJ hopen := + gluePairOpen_pairing_interface_i hij hopen _ + (by rw [partnerSurvI_val hopen, W.pairing_invol]) + have hpJpI : (W.gluePairOpen i j hij hopen).pairing + (partnerSurvJ hopen) = partnerSurvI hopen := + gluePairOpen_pairing_interface_j hij hopen _ + (by + rw [partnerSurvJ_val hopen, W.pairing_invol] + exact fun hh => hij (W.boundaryFlag_injective hh).symm) + (by rw [partnerSurvJ_val hopen, W.pairing_invol]) + -- the reversed chain from bf_j + have hbfj_eq : W.boundaryFlag j = W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (W.boundaryFlag i) k) := htermA.symm + have hcontB : ∀ t, t < k → W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (W.boundaryFlag j) t) ∈ (Fl).internalFlags := by + intro t ht + rw [hbfj_eq] + exact reverse_chain_continues + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + hbi hcontA t ht + have htermB : W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (W.boundaryFlag j) k) = W.boundaryFlag i := by + rw [hbfj_eq] + exact reverse_chain_terminates + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + hcontA + -- the two spliced cycles + have hSA_per := splice_period hij hopen s' hc' hc κ' + (partnerSurvI hopen) (partnerSurvJ hopen) + (W.boundaryFlag i) (W.boundaryFlag j) rfl rfl hpJpI + k hk1 hcontA htermA + have hSB_per := splice_period hij hopen s' hc' hc κ' + (partnerSurvJ hopen) (partnerSurvI hopen) + (W.boundaryFlag j) (W.boundaryFlag i) rfl rfl hpIpJ + k hk1 hcontB htermB + -- cross-cycle disjointness at the value level + intro z + rcases z with f | (t | t) + · -- lifted periodic flags: the walk corresponds valuewise + obtain ⟨h1, h2⟩ := internal_surviving i j + ((RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').periodicFlags_sub f.prop) + refine Subtype.ext (Subtype.ext ?_) + change (κ'.match_ ((W.gluePairOpen i j hij hopen).pairing + ⟨f.val, h1, h2⟩)).val = + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').match_ (W.pairing f.val) + have hpf : W.pairing f.val ∈ (Fl).internalFlags := + all_pairings_internal_of_periodic + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (((RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').mem_periodicFlags).mp f.prop) 0 + obtain ⟨hp1, hp2⟩ := internal_surviving i j hpf + have hag : W.pairing f.val = + ((W.gluePairOpen i j hij hopen).pairing + ⟨f.val, h1, h2⟩).val := + (gluePairOpen_pairing_val_of_ne hij hopen ⟨f.val, h1, h2⟩ + hp1 hp2).symm + rw [hag, unglueOpen_match_val hij hopen s' hc' hc κ' + ((W.gluePairOpen i j hij hopen).pairing ⟨f.val, h1, h2⟩)] + · -- the A-cycle rotates + refine Subtype.ext ?_ + change iterWalk κ' (κ'.match_ (partnerSurvI hopen)) + (t.val + 1) = + iterWalk κ' (κ'.match_ (partnerSurvI hopen)) + (((finRotate k) t).val) + obtain ⟨k0, rfl⟩ : ∃ k0, k = k0 + 1 := ⟨k - 1, by omega⟩ + rcases eq_or_ne t (Fin.last k0) with rfl | hne + · rw [finRotate_last, Fin.val_zero, Fin.val_last] + exact hSA_per + · have hne' : t.val ≠ k0 := by + intro h + exact hne (Fin.ext (by rw [h, Fin.val_last])) + have hlt : t.val < k0 := by + have := t.isLt + omega + have hrot : ((finRotate (k0 + 1)) t).val = t.val + 1 := by + rw [finRotate_apply] + exact Fin.val_add_one_of_lt' (by omega) + rw [hrot] + · -- the B-cycle rotates + refine Subtype.ext ?_ + change iterWalk κ' (κ'.match_ (partnerSurvJ hopen)) + (t.val + 1) = + iterWalk κ' (κ'.match_ (partnerSurvJ hopen)) + (((finRotate k) t).val) + obtain ⟨k0, rfl⟩ : ∃ k0, k = k0 + 1 := ⟨k - 1, by omega⟩ + rcases eq_or_ne t (Fin.last k0) with rfl | hne + · rw [finRotate_last, Fin.val_zero, Fin.val_last] + exact hSB_per + · have hne' : t.val ≠ k0 := by + intro h + exact hne (Fin.ext (by rw [h, Fin.val_last])) + have hlt : t.val < k0 := by + have := t.isLt + omega + have hrot : ((finRotate (k0 + 1)) t).val = t.val + 1 := by + rw [finRotate_apply] + exact Fin.val_add_one_of_lt' (by omega) + rw [hrot] + +/-- **The linked-case conjugation**: when the chain from `bf_i` +exits at `bf_j`, the glued walk permutation is, up to a bijection, +the lifted walk permutation plus two `k`-rotations (the two +directions of the spliced circuit). -/ +theorem exists_walkPerm_linked (κ' : (Fg).RelTransitionSystem) + (hbi : W.boundaryFlag i ∈ (Fl).boundaryFlags) + (hbj : W.boundaryFlag j ∈ (Fl).boundaryFlags) + (k : ℕ) (hk1 : 1 ≤ k) + (hcontA : ∀ t, t < k → W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (W.boundaryFlag i) t) ∈ (Fl).internalFlags) + (htermA : W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (W.boundaryFlag i) k) = W.boundaryFlag j) : + ∃ e : ({f : W.Flag // f ∈ (RelTransitionSystem.unglueOpen hij + hopen s' hc' hc κ').periodicFlags} ⊕ (Fin k ⊕ Fin k)) ≃ + {g : (W.gluePairOpen i j hij hopen).Flag // + g ∈ κ'.periodicFlags}, + κ'.walkPermPeriodic = e.permCongr + (Equiv.sumCongr (RelTransitionSystem.unglueOpen hij hopen + s' hc' hc κ').walkPermPeriodic + (Equiv.sumCongr (finRotate k) (finRotate k))) := by + have hpIpJ : (W.gluePairOpen i j hij hopen).pairing + (partnerSurvI hopen) = partnerSurvJ hopen := + gluePairOpen_pairing_interface_i hij hopen _ + (by rw [partnerSurvI_val hopen, W.pairing_invol]) + have hpJpI : (W.gluePairOpen i j hij hopen).pairing + (partnerSurvJ hopen) = partnerSurvI hopen := + gluePairOpen_pairing_interface_j hij hopen _ + (by + rw [partnerSurvJ_val hopen, W.pairing_invol] + exact fun hh => hij (W.boundaryFlag_injective hh).symm) + (by rw [partnerSurvJ_val hopen, W.pairing_invol]) + -- the reversed chain from bf_j + have hbfj_eq : W.boundaryFlag j = W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (W.boundaryFlag i) k) := htermA.symm + have hcontB : ∀ t, t < k → W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (W.boundaryFlag j) t) ∈ (Fl).internalFlags := by + intro t ht + rw [hbfj_eq] + exact reverse_chain_continues + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + hbi hcontA t ht + have htermB : W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (W.boundaryFlag j) k) = W.boundaryFlag i := by + rw [hbfj_eq] + exact reverse_chain_terminates + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + hcontA + -- the two spliced cycles + have hperA := splice_periodicFlag hij hopen s' hc' hc κ' + (partnerSurvI hopen) (partnerSurvJ hopen) + (W.boundaryFlag i) (W.boundaryFlag j) rfl rfl hpJpI + k hk1 hcontA htermA + have hperB := splice_periodicFlag hij hopen s' hc' hc κ' + (partnerSurvJ hopen) (partnerSurvI hopen) + (W.boundaryFlag j) (W.boundaryFlag i) rfl rfl hpIpJ + k hk1 hcontB htermB + have hSA_last := splice_last hij hopen s' hc' hc κ' + (partnerSurvI hopen) (partnerSurvJ hopen) + (W.boundaryFlag i) (W.boundaryFlag j) rfl rfl k hk1 hcontA htermA + have hSB_last := splice_last hij hopen s' hc' hc κ' + (partnerSurvJ hopen) (partnerSurvI hopen) + (W.boundaryFlag j) (W.boundaryFlag i) rfl rfl k hk1 hcontB htermB + have hSA_mod := splice_mod hij hopen s' hc' hc κ' + (partnerSurvI hopen) (partnerSurvJ hopen) + (W.boundaryFlag i) (W.boundaryFlag j) rfl rfl hpJpI + k hk1 hcontA htermA + have hSB_mod := splice_mod hij hopen s' hc' hc κ' + (partnerSurvJ hopen) (partnerSurvI hopen) + (W.boundaryFlag j) (W.boundaryFlag i) rfl rfl hpIpJ + k hk1 hcontB htermB + have hinj := linked_walkMap_injective hij hopen s' hc' hc κ' hbi hbj + k hk1 hcontA htermA hperA hperB + have hsurj : Function.Surjective + (Sum.elim (liftPeriodic hij hopen s' hc' hc κ') + (Sum.elim + (fun t : Fin k => spliceFlag hij hopen s' hc' κ' + (partnerSurvI hopen) hperA t.val) + (fun t : Fin k => spliceFlag hij hopen s' hc' κ' + (partnerSurvJ hopen) hperB t.val))) := by + rintro ⟨g, hg⟩ + rcases periodicFlag_val_or_orbit hij hopen s' hc' hc κ' hg with + hval | (⟨hperI', c, hcEq⟩ | ⟨hperJ', c, hcEq⟩) + · exact ⟨Sum.inl ⟨g.val, hval⟩, Subtype.ext (Subtype.ext rfl)⟩ + · -- g lies on the orbit of the i-side far end (the B-cycle) + have hstep : iterWalk κ' + (κ'.match_ (partnerSurvJ hopen)) ((k - 1) + c) = g + := by + have h := iterWalk_add κ' + (κ'.match_ (partnerSurvJ hopen)) (k - 1) c + rw [hSB_last] at h + rw [h] + exact hcEq + refine ⟨Sum.inr (Sum.inr ⟨((k - 1) + c) % k, + Nat.mod_lt _ (by omega)⟩), Subtype.ext ?_⟩ + change iterWalk κ' (κ'.match_ (partnerSurvJ hopen)) + (((k - 1) + c) % k) = g + rw [← hSB_mod ((k - 1) + c)] + exact hstep + · -- g lies on the orbit of the j-side far end (the A-cycle) + have hstep : iterWalk κ' + (κ'.match_ (partnerSurvI hopen)) ((k - 1) + c) = g := by + have h := iterWalk_add κ' + (κ'.match_ (partnerSurvI hopen)) (k - 1) c + rw [hSA_last] at h + rw [h] + exact hcEq + refine ⟨Sum.inr (Sum.inl ⟨((k - 1) + c) % k, + Nat.mod_lt _ (by omega)⟩), Subtype.ext ?_⟩ + change iterWalk κ' (κ'.match_ (partnerSurvI hopen)) + (((k - 1) + c) % k) = g + rw [← hSA_mod ((k - 1) + c)] + exact hstep + refine ⟨Equiv.ofBijective _ ⟨hinj, hsurj⟩, ?_⟩ + -- ═══════ STAGE 3: THE BIJECTION IS WALK-EQUIVARIANT ═══════ + -- the walk equivariance of the forward map + have key := linked_walkMap_equivariant hij hopen s' hc' hc κ' hbi + k hk1 hcontA htermA hperA hperB + apply Equiv.ext + intro xg + obtain ⟨z, rfl⟩ := hsurj xg + rw [Equiv.permCongr_apply] + have hsymm : (Equiv.ofBijective _ ⟨hinj, hsurj⟩).symm + ((Sum.elim (liftPeriodic hij hopen s' hc' hc κ') + (Sum.elim + (fun t : Fin k => spliceFlag hij hopen s' hc' κ' + (partnerSurvI hopen) hperA t.val) + (fun t : Fin k => spliceFlag hij hopen s' hc' κ' + (partnerSurvJ hopen) hperB t.val))) z) = z := + Equiv.symm_apply_apply _ z + rw [hsymm] + exact key z + +/-! #### The circuit-count delta -/ + +/-- **Count delta in the linked case**: the splice closes exactly +one new circuit (two new walk orbits). -/ +theorem openCircuitCount_linked_chain (κ' : (Fg).RelTransitionSystem) + (hbi : W.boundaryFlag i ∈ (Fl).boundaryFlags) + (hbj : W.boundaryFlag j ∈ (Fl).boundaryFlags) + (k : ℕ) (hk1 : 1 ≤ k) + (hcontA : ∀ t, t < k → W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (W.boundaryFlag i) t) ∈ (Fl).internalFlags) + (htermA : W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (W.boundaryFlag i) k) = W.boundaryFlag j) : + κ'.openCircuitCount = + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').openCircuitCount + 1 := by + obtain ⟨e, he⟩ := exists_walkPerm_linked hij hopen s' hc' hc κ' + hbi hbj k hk1 hcontA htermA + unfold RelTransitionSystem.openCircuitCount + rw [he, cycleType_permCongr, card_fixedPoints_permCongr, + cycleType_sumCongr, cycleType_sumCongr, + card_fixedPoints_sumCongr, card_fixedPoints_sumCongr, + Multiset.card_add, Multiset.card_add] + have hrot := finRotate_orbit_count k hk1 + omega + +open scoped Classical in +/-- **The circuit-count delta of a participating open glue**: the +glued count exceeds the unglued count by `1` exactly when the +interface is linked. -/ +theorem openCircuitCount_glueOpen_participating (κ' : (Fg).RelTransitionSystem) + (hpi : partnerSurvI hopen ∈ s') : + κ'.openCircuitCount = + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').openCircuitCount + + (if InterfaceLinked hij hopen s' hc' hc κ' hpi then 1 + else 0) := by + by_cases hL : InterfaceLinked hij hopen s' hc' hc κ' hpi + · rw [ite_eq_left hL] + obtain ⟨k, hk_le, hcontA, hpm⟩ := pathMatch_chain_length + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (boundaryFlagI_mem_boundaryFlags hij hopen s' hc hpi) + have htermA : W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + (W.boundaryFlag i) k) = W.boundaryFlag j := by + rw [← hpm] + exact hL + have hk1 : 1 ≤ k := by + by_contra hk0 + have hk0' : k = 0 := by omega + subst hk0' + exact hopen htermA + exact openCircuitCount_linked_chain hij hopen s' hc' hc κ' + (boundaryFlagI_mem_boundaryFlags hij hopen s' hc hpi) + (boundaryFlagJ_mem_boundaryFlags hij hopen s' hc' hc hpi) + k hk1 hcontA htermA + · rw [ite_eq_right hL, add_zero] + exact (openCircuitCount_notLinked hij hopen s' hc' hc κ' hpi + hL).symm + +end OpenGlueParticipating + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueComm.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueComm.lean new file mode 100644 index 0000000000..a8737aba45 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueComm.lean @@ -0,0 +1,2398 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FragmentEquiv + +/-! +# Commutation of disjoint single-pair glues + +Two single-pair glues at disjoint label pairs commute up to fragment +equivalence: gluing `{i, j}` then `{k, l}` yields an equivalent +fragment to gluing `{k, l}` then `{i, j}`, provided the four labels +are pairwise distinct. This is the engine of associativity for the +skein category. + +The proof proceeds by classifying the involution structure of +`W.pairing` on the four boundary flags: whether the pairs `{i, j}` +and `{k, l}` are edges determines the open/closed status of each +glue and thus the circle count and rewiring behaviour. +-/ + +@[expose] public section + +namespace RS + +namespace Fragment + +variable {α : Type} + +/-! ### Label plumbing -/ + +/-- The swap equivalence between nested surviving-label subtypes: +removing `{i, j}` then `{k, l}` is the same as removing `{k, l}` +then `{i, j}`. -/ +def swapLabelEquiv {i j k l : α} + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) : + SurvivingLabel (SurvivingLabel α i j) ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, + hjl.symm⟩ ≃ + SurvivingLabel (SurvivingLabel α k l) ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ where + toFun x := + let val := x.val.val + have hxk : val ≠ k := fun h => x.prop.1 (Subtype.ext h) + have hxl : val ≠ l := fun h => x.prop.2 (Subtype.ext h) + have hxi : val ≠ i := x.val.prop.1 + have hxj : val ≠ j := x.val.prop.2 + ⟨⟨val, hxk, hxl⟩, fun h => hxi (congrArg Subtype.val h), + fun h => hxj (congrArg Subtype.val h)⟩ + invFun x := + let val := x.val.val + have hxi : val ≠ i := fun h => x.prop.1 (Subtype.ext h) + have hxj : val ≠ j := fun h => x.prop.2 (Subtype.ext h) + have hxk : val ≠ k := x.val.prop.1 + have hxl : val ≠ l := x.val.prop.2 + ⟨⟨val, hxi, hxj⟩, fun h => hxk (congrArg Subtype.val h), + fun h => hxl (congrArg Subtype.val h)⟩ + left_inv _ := Subtype.ext (Subtype.ext rfl) + right_inv _ := Subtype.ext (Subtype.ext rfl) + +/-! ### What the two orders share + +Neither the surviving flags nor the attachment map of a double glue +depends on the order the two pairs are glued in: either order leaves +the flags of `W` that are none of the four glued boundary flags, and +either order reads attachment off `W.attach`. Only the pairing and +the circle count tell the configurations below apart, so the pairing +is all each of them has to compute. +-/ + +/-- The flags surviving both glues, read in either order: removing +`{i, j}` and then `{k, l}` nests the four exclusions one way, and +removing `{k, l}` first nests them the other way. The swap is the +identity on the underlying flag of `W`. -/ +def doubleSurvivingSwap (W : Fragment α) {i j k l : α} + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) : + {f : SurvivingFlag W i j // + f ≠ glueBoundaryFlag W i j ⟨k, hik.symm, hjk.symm⟩ ∧ + f ≠ glueBoundaryFlag W i j ⟨l, hil.symm, hjl.symm⟩} ≃ + {f : SurvivingFlag W k l // + f ≠ glueBoundaryFlag W k l ⟨i, hik, hil⟩ ∧ + f ≠ glueBoundaryFlag W k l ⟨j, hjk, hjl⟩} where + toFun f := + ⟨⟨f.val.val, fun h => f.prop.1 (Subtype.ext h), + fun h => f.prop.2 (Subtype.ext h)⟩, + fun h => f.val.prop.1 (congrArg Subtype.val h), + fun h => f.val.prop.2 (congrArg Subtype.val h)⟩ + invFun f := + ⟨⟨f.val.val, fun h => f.prop.1 (Subtype.ext h), + fun h => f.prop.2 (Subtype.ext h)⟩, + fun h => f.val.prop.1 (congrArg Subtype.val h), + fun h => f.val.prop.2 (congrArg Subtype.val h)⟩ + left_inv _ := Subtype.ext (Subtype.ext rfl) + right_inv _ := Subtype.ext (Subtype.ext rfl) + +/-- The partner of a flag can be the boundary flag of at most one +label, so testing four labels in turn gives five cases: a match at +one of them, carrying the failures before it, or no match at all. -/ +private theorem partner_cases (W : Fragment α) (f : W.Flag) (a b c d : α) : + W.pairing f = W.boundaryFlag a ∨ + (W.pairing f ≠ W.boundaryFlag a ∧ W.pairing f = W.boundaryFlag b) ∨ + (W.pairing f ≠ W.boundaryFlag a ∧ W.pairing f ≠ W.boundaryFlag b ∧ + W.pairing f = W.boundaryFlag c) ∨ + (W.pairing f ≠ W.boundaryFlag a ∧ W.pairing f ≠ W.boundaryFlag b ∧ + W.pairing f ≠ W.boundaryFlag c ∧ W.pairing f = W.boundaryFlag d) ∨ + (W.pairing f ≠ W.boundaryFlag a ∧ W.pairing f ≠ W.boundaryFlag b ∧ + W.pairing f ≠ W.boundaryFlag c ∧ W.pairing f ≠ W.boundaryFlag d) := by + classical + by_cases ha : W.pairing f = W.boundaryFlag a + · exact Or.inl ha + by_cases hb : W.pairing f = W.boundaryFlag b + · exact Or.inr (Or.inl ⟨ha, hb⟩) + by_cases hc : W.pairing f = W.boundaryFlag c + · exact Or.inr (Or.inr (Or.inl ⟨ha, hb, hc⟩)) + by_cases hd : W.pairing f = W.boundaryFlag d + · exact Or.inr (Or.inr (Or.inr (Or.inl ⟨ha, hb, hc, hd⟩))) + exact Or.inr (Or.inr (Or.inr (Or.inr ⟨ha, hb, hc, hd⟩))) + +/-- The swap intertwines the two attachment maps. Both sides trace +the same flag of `W` down to `W.attach`: outer glue to inner glue to +`W`, and back up the other order. The vertex types are all `W.Vertex` +and are spelled out so the chain of rewrites stays at one type. -/ +private theorem doubleGlueAttach_comm (W : Fragment α) {i j k l : α} + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + {p : SurvivingFlag W i j → SurvivingFlag W i j} + {hp : ∀ f, p (p f) = f} {hp' : ∀ f, p f ≠ f} {c : ℕ} + {q : SurvivingFlag W k l → SurvivingFlag W k l} + {hq : ∀ f, q (q f) = f} {hq' : ∀ f, q f ≠ f} {d : ℕ} + (f : SurvivingFlag (W.glueWith i j p hp hp' c) + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩) : + Sum.map (id : W.Vertex → W.Vertex) + ((swapLabelEquiv hik hil hjk hjl).symm) + (glueAttach (W.glueWith k l q hq hq' d) + ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ + (doubleSurvivingSwap W hik hil hjk hjl f)) = + Sum.map (id : W.Vertex → W.Vertex) id + (glueAttach (W.glueWith i j p hp hp' c) + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ f) := by + set g := doubleSurvivingSwap W hik hil hjk hjl f + rcases h_r : glueAttach (W.glueWith i j p hp hp' c) + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ f with v_r | ℓ_r + · -- An internal vertex: the same one at every stage. + have h_ir : glueAttach W i j f.val = Sum.inl v_r := + (glueAttach_inl_iff f v_r).mp h_r + have h_base : W.attach f.val.val = Sum.inl v_r := + (glueAttach_inl_iff f.val v_r).mp h_ir + have h_il : glueAttach W k l g.val = Sum.inl v_r := + (glueAttach_inl_iff g.val v_r).mpr h_base + have h_l : glueAttach (W.glueWith k l q hq hq' d) + ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ g = Sum.inl v_r := + (glueAttach_inl_iff (W := W.glueWith k l q hq hq' d) + (i := ⟨i, hik, hil⟩) (j := ⟨j, hjk, hjl⟩) g v_r).mpr h_il + exact congrArg (Sum.map (id : W.Vertex → W.Vertex) + ((swapLabelEquiv hik hil hjk hjl).symm)) h_l + · -- A surviving label: the same one, carried across the swap. + have h_ir : glueAttach W i j f.val = Sum.inr ℓ_r.val := + (glueAttach_inr_iff f ℓ_r).mp h_r + have h_base : W.attach f.val.val = Sum.inr ℓ_r.val.val := + (glueAttach_inr_iff f.val ℓ_r.val).mp h_ir + have hℓk : ℓ_r.val.val ≠ k := fun h => + (survivingFlag_attach_ne g.val).1 (h_base.trans (congrArg Sum.inr h)) + have hℓl : ℓ_r.val.val ≠ l := fun h => + (survivingFlag_attach_ne g.val).2 (h_base.trans (congrArg Sum.inr h)) + have h_il : glueAttach W k l g.val = Sum.inr ⟨ℓ_r.val.val, hℓk, hℓl⟩ := + (glueAttach_inr_iff g.val ⟨ℓ_r.val.val, hℓk, hℓl⟩).mpr h_base + have hℓi : (⟨ℓ_r.val.val, hℓk, hℓl⟩ : SurvivingLabel α k l) ≠ + ⟨i, hik, hil⟩ := fun h => ℓ_r.val.prop.1 (congrArg Subtype.val h) + have hℓj : (⟨ℓ_r.val.val, hℓk, hℓl⟩ : SurvivingLabel α k l) ≠ + ⟨j, hjk, hjl⟩ := fun h => ℓ_r.val.prop.2 (congrArg Subtype.val h) + have h_l : glueAttach (W.glueWith k l q hq hq' d) + ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ g = + Sum.inr ⟨⟨ℓ_r.val.val, hℓk, hℓl⟩, hℓi, hℓj⟩ := + (glueAttach_inr_iff (W := W.glueWith k l q hq hq' d) + (i := ⟨i, hik, hil⟩) (j := ⟨j, hjk, hjl⟩) g + ⟨⟨ℓ_r.val.val, hℓk, hℓl⟩, hℓi, hℓj⟩).mpr h_il + exact (congrArg (Sum.map (id : W.Vertex → W.Vertex) + ((swapLabelEquiv hik hil hjk hjl).symm)) h_l).trans + (congrArg Sum.inr (Subtype.ext (Subtype.ext rfl))) + +/-! ### Configuration (4): both pairs are edges (closed-closed) -/ + +-- The restricted pairing sends k's boundary flag to l's in the +-- closed ij fragment. +private theorem closedClosed_second_ij + (W : Fragment α) {i j k l : α} + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hclosed_ij : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (hclosed_kl : W.pairing (W.boundaryFlag k) = W.boundaryFlag l) : + (W.gluePairClosed i j hclosed_ij).pairing + (glueBoundaryFlag W i j ⟨k, hik.symm, hjk.symm⟩) = + glueBoundaryFlag W i j ⟨l, hil.symm, hjl.symm⟩ := + Subtype.ext hclosed_kl + +-- The restricted pairing sends i's boundary flag to j's in the +-- closed kl fragment. +private theorem closedClosed_second_kl + (W : Fragment α) {i j k l : α} + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hclosed_ij : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (hclosed_kl : W.pairing (W.boundaryFlag k) = W.boundaryFlag l) : + (W.gluePairClosed k l hclosed_kl).pairing + (glueBoundaryFlag W k l ⟨i, hik, hil⟩) = + glueBoundaryFlag W k l ⟨j, hjk, hjl⟩ := + Subtype.ext hclosed_ij + +/-- Configuration (4): commutativity when both `{i, j}` and +`{k, l}` are edges of `W`. Both glues are closed in both orders, +giving circles `W.circles + 2` with the pairing restricted. -/ +def closedClosedEquiv [DecidableEq α] + (W : Fragment α) {i j k l : α} + (_hij : i ≠ j) (_hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hclosed_ij : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (hclosed_kl : W.pairing (W.boundaryFlag k) = W.boundaryFlag l) : + ((W.gluePairClosed i j hclosed_ij).gluePairClosed + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (by exact (closedClosed_second_ij W hik hil hjk hjl hclosed_ij hclosed_kl))).Equiv + (((W.gluePairClosed k l hclosed_kl).gluePairClosed + ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ + (by exact (closedClosed_second_kl W hik hil hjk hjl hclosed_ij hclosed_kl))).relabel + (swapLabelEquiv hik hil hjk hjl).symm) where + flagEquiv := by exact doubleSurvivingSwap W hik hil hjk hjl + vertexEquiv := _root_.Equiv.refl W.Vertex + attach_comm f := by + exact doubleGlueAttach_comm W hik hil hjk hjl f + pairing_comm f := by + -- The pairing in gluePairClosed is just W.pairing restricted + -- Both sides apply W.pairing to the underlying flag value + apply Subtype.ext + apply Subtype.ext + -- Goal: W.pairing f.val.val = W.pairing f.val.val + rfl + circles_eq := rfl + +/-! ### Configuration (0): both pairs are open and disjoint (open-open) -/ + +/-- Local helper: value of rewire in the "else" branch. -/ +private theorem rewire_val_ne' {W : Fragment α} {i j : α} + {hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j} + {f : SurvivingFlag W i j} + (hfi : W.pairing f.val ≠ W.boundaryFlag i) + (hfj : W.pairing f.val ≠ W.boundaryFlag j) : + (rewire hopen f).val = W.pairing f.val := by + unfold rewire; simp [dite_eq_right hfi, dite_eq_right hfj] + +/-- Local helper: value of rewire in the first branch (partner is bFi). -/ +private theorem rewire_val_left' {W : Fragment α} {i j : α} + {hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j} + {f : SurvivingFlag W i j} + (hfi : W.pairing f.val = W.boundaryFlag i) : + (rewire hopen f).val = W.pairing (W.boundaryFlag j) := by + unfold rewire; simp [dite_eq_left hfi] + +/-- Local helper: value of rewire in the second branch (partner is bFj). -/ +private theorem rewire_val_right' {W : Fragment α} {i j : α} + {hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j} + {f : SurvivingFlag W i j} + (hfi : W.pairing f.val ≠ W.boundaryFlag i) + (hfj : W.pairing f.val = W.boundaryFlag j) : + (rewire hopen f).val = W.pairing (W.boundaryFlag i) := by + unfold rewire; simp [dite_eq_right hfi, dite_eq_left hfj] + +-- The kl glue is open in the ij-first fragment. +private theorem openOpen_second_open_ij + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hfar_ik : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag k) + (hfar_jk : W.pairing (W.boundaryFlag j) ≠ W.boundaryFlag k) : + (W.gluePairOpen i j hij hopen_ij).pairing + ((W.gluePairOpen i j hij hopen_ij).boundaryFlag ⟨k, hik.symm, hjk.symm⟩) ≠ + (W.gluePairOpen i j hij hopen_ij).boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := by + change (W.gluePairOpen i j hij hopen_ij).pairing + (glueBoundaryFlag W i j ⟨k, hik.symm, hjk.symm⟩) ≠ + glueBoundaryFlag W i j ⟨l, hil.symm, hjl.symm⟩ + intro heq + have h_ne_i : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag i := fun h => + hfar_ik (W.pairing_boundaryFlag_comm h) + have h_ne_j : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag j := fun h => + hfar_jk (W.pairing_boundaryFlag_comm h) + have hval : (rewire hopen_ij (glueBoundaryFlag W i j + ⟨k, hik.symm, hjk.symm⟩)).val = W.pairing (W.boundaryFlag k) := + rewire_val_ne' h_ne_i h_ne_j + exact hopen_kl (hval.symm ▸ congrArg Subtype.val heq) + +-- The ij glue is open in the kl-first fragment. +private theorem openOpen_second_open_kl + (W : Fragment α) {i j k l : α} + (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hfar_ik : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag k) + (hfar_il : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag l) : + (W.gluePairOpen k l hkl hopen_kl).pairing + ((W.gluePairOpen k l hkl hopen_kl).boundaryFlag ⟨i, hik, hil⟩) ≠ + (W.gluePairOpen k l hkl hopen_kl).boundaryFlag ⟨j, hjk, hjl⟩ := by + change (W.gluePairOpen k l hkl hopen_kl).pairing + (glueBoundaryFlag W k l ⟨i, hik, hil⟩) ≠ + glueBoundaryFlag W k l ⟨j, hjk, hjl⟩ + intro heq + have h_ne_k : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag k := hfar_ik + have h_ne_l : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag l := hfar_il + have hval : (rewire hopen_kl (glueBoundaryFlag W k l + ⟨i, hik, hil⟩)).val = W.pairing (W.boundaryFlag i) := + rewire_val_ne' h_ne_k h_ne_l + exact hopen_ij (hval.symm ▸ congrArg Subtype.val heq) + +private theorem openOpen_disjoint_equiv_pairing_first + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hfar_ik : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag k) + (hfar_il : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag l) + (hfar_jk : W.pairing (W.boundaryFlag j) ≠ W.boundaryFlag k) + (hfar_jl : W.pairing (W.boundaryFlag j) ≠ W.boundaryFlag l) + (f : (((W.gluePairOpen i j hij hopen_ij).gluePairOpen + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (fun h => hkl (congrArg Subtype.val h)) + (openOpen_second_open_ij W hij hik hil hjk hjl + hopen_ij hopen_kl hfar_ik hfar_jk))).Flag) + (hpi : W.pairing f.val.val = W.boundaryFlag i) : + ((((W.gluePairOpen i j hij hopen_ij).gluePairOpen + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (fun h => hkl (congrArg Subtype.val h)) + (openOpen_second_open_ij W hij hik hil hjk hjl + hopen_ij hopen_kl hfar_ik hfar_jk))).pairing f).val.val = + (((((W.gluePairOpen k l hkl hopen_kl).gluePairOpen + ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ + (fun h => hij (congrArg Subtype.val h)) + (openOpen_second_open_kl W hkl hik hil hjk hjl + hopen_ij hopen_kl hfar_ik hfar_il)).relabel + (swapLabelEquiv hik hil hjk hjl).symm)).pairing (doubleSurvivingSwap W hik hil hjk + hjl f)).val.val := by + classical + -- Reduce to equality of underlying W.Flag values + -- Name the two single glues; every transport below is + -- read at one of them. + let Wij := W.gluePairOpen i j hij hopen_ij + let Wkl := W.gluePairOpen k l hkl hopen_kl + -- Two `Subtype.ext` steps put both sides at the underlying + -- `W.Flag` value, where each is a nested `rewire` of `f.val.val`; + -- `show` spells that goal out. + let g := doubleSurvivingSwap W hik hil hjk hjl f + change (rewire (openOpen_second_open_ij W hij hik hil hjk hjl + hopen_ij hopen_kl hfar_ik hfar_jk) f).val.val = + (rewire (openOpen_second_open_kl W hkl hik hil hjk hjl + hopen_ij hopen_kl hfar_ik hfar_il) g).val.val + -- Key "far by involution" facts + -- Abbreviation for the hopen_second arguments + let hopen_ij_kl := openOpen_second_open_ij W hij hik hil hjk hjl + hopen_ij hopen_kl hfar_ik hfar_jk + let hopen_kl_ij := openOpen_second_open_kl W hkl hik hil hjk hjl + hopen_ij hopen_kl hfar_ik hfar_il + -- 5-way case split on W.pairing f.val.val + -- LHS: rewire(ij) takes its first branch, giving W.pairing bFj; + -- rewire(kl) then takes its else branch, leaving it there. + have lhs_inner : (rewire hopen_ij f.val).val = + W.pairing (W.boundaryFlag j) := + rewire_val_left' hpi + have lhs_inner_ne_k : (rewire hopen_ij f.val).val ≠ W.boundaryFlag k := by + rw [lhs_inner]; exact hfar_jk + have lhs_inner_ne_l : (rewire hopen_ij f.val).val ≠ W.boundaryFlag l := by + rw [lhs_inner]; exact hfar_jl + have lhs_outer_ne_k : Wij.pairing f.val ≠ + Wij.boundaryFlag ⟨k, hik.symm, hjk.symm⟩ := fun h => + lhs_inner_ne_k (congrArg Subtype.val h) + have lhs_outer_ne_l : Wij.pairing f.val ≠ + Wij.boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := fun h => + lhs_inner_ne_l (congrArg Subtype.val h) + have lhs_val : (rewire hopen_ij_kl f).val.val = + W.pairing (W.boundaryFlag j) := by + have h := rewire_val_ne' (hopen := hopen_ij_kl) lhs_outer_ne_k + lhs_outer_ne_l + exact congrArg Subtype.val h ▸ lhs_inner + -- RHS: rewire(kl) takes its else branch, bFi being neither bFk + -- nor bFl, leaving bFi; rewire(ij) then takes its first + -- branch, giving rewire(kl) at bFj, which is W.pairing bFj. + have rhs_inner_ne_k : W.pairing g.val.val ≠ W.boundaryFlag k := by + change W.pairing f.val.val ≠ W.boundaryFlag k + rw [hpi]; exact fun h => hik (W.boundaryFlag_injective h) + have rhs_inner_ne_l : W.pairing g.val.val ≠ W.boundaryFlag l := by + change W.pairing f.val.val ≠ W.boundaryFlag l + rw [hpi]; exact fun h => hil (W.boundaryFlag_injective h) + have rhs_inner : (rewire hopen_kl g.val).val = W.boundaryFlag i := by + have h := @rewire_val_ne' _ W k l hopen_kl g.val rhs_inner_ne_k + rhs_inner_ne_l + rw [h]; exact hpi + have rhs_outer_eq_i : Wkl.pairing g.val = + Wkl.boundaryFlag ⟨i, hik, hil⟩ := + Subtype.ext rhs_inner + have rhs_j_rewire : (rewire hopen_kl (glueBoundaryFlag W k l + ⟨j, hjk, hjl⟩)).val = W.pairing (W.boundaryFlag j) := + rewire_val_ne' hfar_jk hfar_jl + have rhs_val : (rewire hopen_kl_ij g).val.val = + W.pairing (W.boundaryFlag j) := by + have h := rewire_val_left' (hopen := hopen_kl_ij) rhs_outer_eq_i + exact congrArg Subtype.val h ▸ rhs_j_rewire + rw [lhs_val, rhs_val] + +private theorem openOpen_disjoint_equiv_pairing_comm + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hfar_ik : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag k) + (hfar_il : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag l) + (hfar_jk : W.pairing (W.boundaryFlag j) ≠ W.boundaryFlag k) + (hfar_jl : W.pairing (W.boundaryFlag j) ≠ W.boundaryFlag l) + (f : (((W.gluePairOpen i j hij hopen_ij).gluePairOpen + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (fun h => hkl (congrArg Subtype.val h)) + (openOpen_second_open_ij W hij hik hil hjk hjl + hopen_ij hopen_kl hfar_ik hfar_jk))).Flag) : + doubleSurvivingSwap W hik hil hjk hjl ((((W.gluePairOpen i j hij hopen_ij).gluePairOpen + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (fun h => hkl (congrArg Subtype.val h)) + (openOpen_second_open_ij W hij hik hil hjk hjl + hopen_ij hopen_kl hfar_ik hfar_jk))).pairing f) = + ((((W.gluePairOpen k l hkl hopen_kl).gluePairOpen + ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ + (fun h => hij (congrArg Subtype.val h)) + (openOpen_second_open_kl W hkl hik hil hjk hjl + hopen_ij hopen_kl hfar_ik hfar_il)).relabel + (swapLabelEquiv hik hil hjk hjl).symm)).pairing (doubleSurvivingSwap W hik hil hjk + hjl f) := by + classical + -- Reduce to equality of underlying W.Flag values + apply Subtype.ext + apply Subtype.ext + -- Name the two single glues; every transport below is + -- read at one of them. + let Wij := W.gluePairOpen i j hij hopen_ij + let Wkl := W.gluePairOpen k l hkl hopen_kl + -- Two `Subtype.ext` steps put both sides at the underlying + -- `W.Flag` value, where each is a nested `rewire` of `f.val.val`; + -- `show` spells that goal out. + let g := doubleSurvivingSwap W hik hil hjk hjl f + change (rewire (openOpen_second_open_ij W hij hik hil hjk hjl + hopen_ij hopen_kl hfar_ik hfar_jk) f).val.val = + (rewire (openOpen_second_open_kl W hkl hik hil hjk hjl + hopen_ij hopen_kl hfar_ik hfar_il) g).val.val + -- Key "far by involution" facts + have hfar_ki : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag i := fun h => + hfar_ik (W.pairing_boundaryFlag_comm h) + have hfar_kj : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag j := fun h => + hfar_jk (W.pairing_boundaryFlag_comm h) + have hfar_li : W.pairing (W.boundaryFlag l) ≠ W.boundaryFlag i := fun h => + hfar_il (W.pairing_boundaryFlag_comm h) + have hfar_lj : W.pairing (W.boundaryFlag l) ≠ W.boundaryFlag j := fun h => + hfar_jl (W.pairing_boundaryFlag_comm h) + -- g.val.val = f.val.val by definition of the swap + have hgval : g.val.val = f.val.val := rfl + -- Abbreviation for the hopen_second arguments + let hopen_ij_kl := openOpen_second_open_ij W hij hik hil hjk hjl + hopen_ij hopen_kl hfar_ik hfar_jk + let hopen_kl_ij := openOpen_second_open_kl W hkl hik hil hjk hjl + hopen_ij hopen_kl hfar_ik hfar_il + -- 5-way case split on W.pairing f.val.val + rcases partner_cases W f.val.val i j k l with + hpi | ⟨hpi, hpj⟩ | ⟨hpi, hpj, hpk⟩ | ⟨hpi, hpj, hpk, hpl⟩ | + ⟨hpi, hpj, hpk, hpl⟩ + · exact openOpen_disjoint_equiv_pairing_first W hij hkl hik hil hjk hjl hopen_ij hopen_kl + hfar_ik hfar_il hfar_jk hfar_jl f hpi + · -- ═══════ PARTNER IS bF j ═══════ + have lhs_inner : (rewire hopen_ij f.val).val = + W.pairing (W.boundaryFlag i) := + rewire_val_right' hpi hpj + have lhs_inner_ne_k : (rewire hopen_ij f.val).val ≠ W.boundaryFlag k := by + rw [lhs_inner]; exact hfar_ik + have lhs_inner_ne_l : (rewire hopen_ij f.val).val ≠ W.boundaryFlag l := by + rw [lhs_inner]; exact hfar_il + have lhs_outer_ne_k : Wij.pairing f.val ≠ + Wij.boundaryFlag ⟨k, hik.symm, hjk.symm⟩ := fun h => + lhs_inner_ne_k (congrArg Subtype.val h) + have lhs_outer_ne_l : Wij.pairing f.val ≠ + Wij.boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := fun h => + lhs_inner_ne_l (congrArg Subtype.val h) + have lhs_val : (rewire hopen_ij_kl f).val.val = + W.pairing (W.boundaryFlag i) := by + have h := rewire_val_ne' (hopen := hopen_ij_kl) lhs_outer_ne_k + lhs_outer_ne_l + exact congrArg Subtype.val h ▸ lhs_inner + -- RHS: rewire(kl) takes its else branch, leaving bFj; rewire(ij) + -- then takes its second branch, giving rewire(kl) at bFi, + -- which is W.pairing bFi. + have rhs_inner_ne_k : W.pairing g.val.val ≠ W.boundaryFlag k := by + change W.pairing f.val.val ≠ W.boundaryFlag k + rw [hpj]; exact fun h => hjk (W.boundaryFlag_injective h) + have rhs_inner_ne_l : W.pairing g.val.val ≠ W.boundaryFlag l := by + change W.pairing f.val.val ≠ W.boundaryFlag l + rw [hpj]; exact fun h => hjl (W.boundaryFlag_injective h) + have rhs_inner : (rewire hopen_kl g.val).val = W.boundaryFlag j := by + have h := @rewire_val_ne' _ W k l hopen_kl g.val rhs_inner_ne_k + rhs_inner_ne_l + rw [h]; exact hpj + have rhs_inner_ne_i : (rewire hopen_kl g.val).val ≠ W.boundaryFlag i := by + rw [rhs_inner]; exact fun h => hij.symm (W.boundaryFlag_injective h) + have rhs_outer_ne_i : Wkl.pairing g.val ≠ + Wkl.boundaryFlag ⟨i, hik, hil⟩ := fun h => + rhs_inner_ne_i (congrArg Subtype.val h) + have rhs_outer_eq_j : Wkl.pairing g.val = + Wkl.boundaryFlag ⟨j, hjk, hjl⟩ := + Subtype.ext rhs_inner + have rhs_i_rewire : (rewire hopen_kl (glueBoundaryFlag W k l + ⟨i, hik, hil⟩)).val = W.pairing (W.boundaryFlag i) := + rewire_val_ne' hfar_ik hfar_il + have rhs_val : (rewire hopen_kl_ij g).val.val = + W.pairing (W.boundaryFlag i) := by + have h := rewire_val_right' (hopen := hopen_kl_ij) rhs_outer_ne_i + rhs_outer_eq_j + exact congrArg Subtype.val h ▸ rhs_i_rewire + rw [lhs_val, rhs_val] + · -- ═══════ PARTNER IS bF k ═══════ + have lhs_inner : (rewire hopen_ij f.val).val = W.pairing f.val.val := + rewire_val_ne' hpi hpj + have lhs_inner_eq_k : (rewire hopen_ij f.val).val = W.boundaryFlag k := by + rw [lhs_inner, hpk] + have lhs_outer_eq_k : Wij.pairing f.val = + Wij.boundaryFlag ⟨k, hik.symm, hjk.symm⟩ := + Subtype.ext lhs_inner_eq_k + have lhs_l_rewire : (rewire hopen_ij (glueBoundaryFlag W i j + ⟨l, hil.symm, hjl.symm⟩)).val = W.pairing (W.boundaryFlag l) := + rewire_val_ne' hfar_li hfar_lj + have lhs_val : (rewire hopen_ij_kl f).val.val = + W.pairing (W.boundaryFlag l) := by + have h := rewire_val_left' (hopen := hopen_ij_kl) lhs_outer_eq_k + exact congrArg Subtype.val h ▸ lhs_l_rewire + -- RHS: rewire(kl) takes its first branch, giving W.pairing bFl; + -- rewire(ij) then takes its else branch, leaving it there. + have rhs_inner_eq_k : W.pairing g.val.val = W.boundaryFlag k := by + change W.pairing f.val.val = W.boundaryFlag k; exact hpk + have rhs_inner : (rewire hopen_kl g.val).val = + W.pairing (W.boundaryFlag l) := + @rewire_val_left' _ W k l hopen_kl g.val rhs_inner_eq_k + have rhs_inner_ne_i : (rewire hopen_kl g.val).val ≠ W.boundaryFlag i := by + rw [rhs_inner]; exact hfar_li + have rhs_inner_ne_j : (rewire hopen_kl g.val).val ≠ W.boundaryFlag j := by + rw [rhs_inner]; exact hfar_lj + have rhs_outer_ne_i : Wkl.pairing g.val ≠ + Wkl.boundaryFlag ⟨i, hik, hil⟩ := fun h => + rhs_inner_ne_i (congrArg Subtype.val h) + have rhs_outer_ne_j : Wkl.pairing g.val ≠ + Wkl.boundaryFlag ⟨j, hjk, hjl⟩ := fun h => + rhs_inner_ne_j (congrArg Subtype.val h) + have rhs_val : (rewire hopen_kl_ij g).val.val = + W.pairing (W.boundaryFlag l) := by + have h := rewire_val_ne' (hopen := hopen_kl_ij) rhs_outer_ne_i + rhs_outer_ne_j + exact congrArg Subtype.val h ▸ rhs_inner + rw [lhs_val, rhs_val] + · -- ═══════ PARTNER IS bF l ═══════ + have lhs_inner : (rewire hopen_ij f.val).val = W.pairing f.val.val := + rewire_val_ne' hpi hpj + have lhs_inner_eq_l : (rewire hopen_ij f.val).val = W.boundaryFlag l := by + rw [lhs_inner, hpl] + have lhs_inner_ne_k : (rewire hopen_ij f.val).val ≠ W.boundaryFlag k := by + rw [lhs_inner_eq_l] + exact fun h => hkl.symm (W.boundaryFlag_injective h) + have lhs_outer_ne_k : Wij.pairing f.val ≠ + Wij.boundaryFlag ⟨k, hik.symm, hjk.symm⟩ := + fun h => lhs_inner_ne_k (congrArg Subtype.val h) + have lhs_outer_eq_l : Wij.pairing f.val = + Wij.boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := + Subtype.ext lhs_inner_eq_l + have lhs_k_rewire : (rewire hopen_ij (glueBoundaryFlag W i j + ⟨k, hik.symm, hjk.symm⟩)).val = W.pairing (W.boundaryFlag k) := + rewire_val_ne' hfar_ki hfar_kj + have lhs_val : (rewire hopen_ij_kl f).val.val = + W.pairing (W.boundaryFlag k) := by + have h := rewire_val_right' (hopen := hopen_ij_kl) lhs_outer_ne_k + lhs_outer_eq_l + exact congrArg Subtype.val h ▸ lhs_k_rewire + -- RHS: rewire(kl) takes its second branch, giving W.pairing bFk; + -- rewire(ij) then takes its else branch, leaving it there. + have rhs_inner_ne_k : W.pairing g.val.val ≠ W.boundaryFlag k := by + change W.pairing f.val.val ≠ W.boundaryFlag k; exact hpk + have rhs_inner_eq_l : W.pairing g.val.val = W.boundaryFlag l := by + change W.pairing f.val.val = W.boundaryFlag l; exact hpl + have rhs_inner : (rewire hopen_kl g.val).val = + W.pairing (W.boundaryFlag k) := + @rewire_val_right' _ W k l hopen_kl g.val rhs_inner_ne_k rhs_inner_eq_l + have rhs_inner_ne_i : (rewire hopen_kl g.val).val ≠ W.boundaryFlag i := by + rw [rhs_inner]; exact hfar_ki + have rhs_inner_ne_j : (rewire hopen_kl g.val).val ≠ W.boundaryFlag j := by + rw [rhs_inner]; exact hfar_kj + have rhs_outer_ne_i : Wkl.pairing g.val ≠ + Wkl.boundaryFlag ⟨i, hik, hil⟩ := fun h => + rhs_inner_ne_i (congrArg Subtype.val h) + have rhs_outer_ne_j : Wkl.pairing g.val ≠ + Wkl.boundaryFlag ⟨j, hjk, hjl⟩ := fun h => + rhs_inner_ne_j (congrArg Subtype.val h) + have rhs_val : (rewire hopen_kl_ij g).val.val = + W.pairing (W.boundaryFlag k) := by + have h := rewire_val_ne' (hopen := hopen_kl_ij) rhs_outer_ne_i + rhs_outer_ne_j + exact congrArg Subtype.val h ▸ rhs_inner + rw [lhs_val, rhs_val] + · -- ═══════ PARTNER IS NONE OF THE FOUR ═══════ + have lhs_inner : (rewire hopen_ij f.val).val = W.pairing f.val.val := + rewire_val_ne' hpi hpj + have lhs_inner_ne_k : (rewire hopen_ij f.val).val ≠ W.boundaryFlag k := by + rw [lhs_inner]; exact hpk + have lhs_inner_ne_l : (rewire hopen_ij f.val).val ≠ W.boundaryFlag l := by + rw [lhs_inner]; exact hpl + have lhs_outer_ne_k : Wij.pairing f.val ≠ + Wij.boundaryFlag ⟨k, hik.symm, hjk.symm⟩ := + fun h => lhs_inner_ne_k (congrArg Subtype.val h) + have lhs_outer_ne_l : Wij.pairing f.val ≠ + Wij.boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := + fun h => lhs_inner_ne_l (congrArg Subtype.val h) + have lhs_val : (rewire hopen_ij_kl f).val.val = W.pairing f.val.val := by + have h := rewire_val_ne' (hopen := hopen_ij_kl) lhs_outer_ne_k + lhs_outer_ne_l + exact congrArg Subtype.val h ▸ lhs_inner + -- RHS: inner rewire(kl) else → W.pairing f.val.val + -- outer rewire(ij) else → W.pairing f.val.val + have rhs_inner_ne_k : W.pairing g.val.val ≠ W.boundaryFlag k := by + change W.pairing f.val.val ≠ W.boundaryFlag k; exact hpk + have rhs_inner_ne_l : W.pairing g.val.val ≠ W.boundaryFlag l := by + change W.pairing f.val.val ≠ W.boundaryFlag l; exact hpl + have rhs_inner : (rewire hopen_kl g.val).val = W.pairing f.val.val := by + have h := @rewire_val_ne' _ W k l hopen_kl g.val rhs_inner_ne_k + rhs_inner_ne_l + exact h + have rhs_inner_ne_i : (rewire hopen_kl g.val).val ≠ W.boundaryFlag i := by + rw [rhs_inner]; exact hpi + have rhs_inner_ne_j : (rewire hopen_kl g.val).val ≠ W.boundaryFlag j := by + rw [rhs_inner]; exact hpj + have rhs_outer_ne_i : Wkl.pairing g.val ≠ + Wkl.boundaryFlag ⟨i, hik, hil⟩ := fun h => + rhs_inner_ne_i (congrArg Subtype.val h) + have rhs_outer_ne_j : Wkl.pairing g.val ≠ + Wkl.boundaryFlag ⟨j, hjk, hjl⟩ := fun h => + rhs_inner_ne_j (congrArg Subtype.val h) + have rhs_val : (rewire hopen_kl_ij g).val.val = W.pairing f.val.val := by + have h := rewire_val_ne' (hopen := hopen_kl_ij) rhs_outer_ne_i + rhs_outer_ne_j + exact congrArg Subtype.val h ▸ rhs_inner + rw [lhs_val, rhs_val] + +private theorem openOpen_disjoint_equiv_attach_comm + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hfar_ik : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag k) + (hfar_il : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag l) + (hfar_jk : W.pairing (W.boundaryFlag j) ≠ W.boundaryFlag k) + (f : (((W.gluePairOpen i j hij hopen_ij).gluePairOpen + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (fun h => hkl (congrArg Subtype.val h)) + (openOpen_second_open_ij W hij hik hil hjk hjl + hopen_ij hopen_kl hfar_ik hfar_jk))).Flag) : + ((((W.gluePairOpen k l hkl hopen_kl).gluePairOpen + ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ + (fun h => hij (congrArg Subtype.val h)) + (openOpen_second_open_kl W hkl hik hil hjk hjl + hopen_ij hopen_kl hfar_ik hfar_il)).relabel + (swapLabelEquiv hik hil hjk hjl).symm)).attach (doubleSurvivingSwap W hik hil hjk hjl f) = + ((((W.gluePairOpen i j hij hopen_ij).gluePairOpen + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (fun h => hkl (congrArg Subtype.val h)) + (openOpen_second_open_ij W hij hik hil hjk hjl + hopen_ij hopen_kl hfar_ik hfar_jk))).attach f).map (_root_.Equiv.refl W.Vertex) id := by + classical + exact doubleGlueAttach_comm W hik hil hjk hjl f + +/-- Configuration (0): commutativity when both `{i, j}` and `{k, l}` +are open (not edges) and disjoint (no cross-edges between the two +pairs). Both glues are open in both orders, giving circles `W.circles` +with a double-rewire that commutes. -/ +def openOpenDisjointEquiv [DecidableEq α] + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hfar_ik : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag k) + (hfar_il : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag l) + (hfar_jk : W.pairing (W.boundaryFlag j) ≠ W.boundaryFlag k) + (hfar_jl : W.pairing (W.boundaryFlag j) ≠ W.boundaryFlag l) : + ((W.gluePairOpen i j hij hopen_ij).gluePairOpen + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (fun h => hkl (congrArg Subtype.val h)) + (by exact (openOpen_second_open_ij W hij hik hil hjk hjl + hopen_ij hopen_kl hfar_ik hfar_jk))).Equiv + (((W.gluePairOpen k l hkl hopen_kl).gluePairOpen + ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ + (fun h => hij (congrArg Subtype.val h)) + (by exact (openOpen_second_open_kl W hkl hik hil hjk hjl + hopen_ij hopen_kl hfar_ik hfar_il))).relabel + (swapLabelEquiv hik hil hjk hjl).symm) where + flagEquiv := by exact doubleSurvivingSwap W hik hil hjk hjl + vertexEquiv := _root_.Equiv.refl W.Vertex + attach_comm := by + exact openOpen_disjoint_equiv_attach_comm W hij hkl hik hil hjk hjl hopen_ij + hopen_kl hfar_ik hfar_il hfar_jk + pairing_comm := by + exact openOpen_disjoint_equiv_pairing_comm W hij hkl hik hil hjk hjl hopen_ij + hopen_kl hfar_ik hfar_il hfar_jk hfar_jl + circles_eq := rfl + +/-! ### Configuration (1): {i,j} closed, {k,l} open (closed-open mixed) -/ + +-- The kl glue is open after a closed ij glue. +private theorem closedOpen_second_open + (W : Fragment α) {i j k l : α} + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hclosed_ij : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) : + (W.gluePairClosed i j hclosed_ij).pairing + ((W.gluePairClosed i j hclosed_ij).boundaryFlag ⟨k, hik.symm, hjk.symm⟩) ≠ + (W.gluePairClosed i j hclosed_ij).boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := by + intro heq + exact hopen_kl (congrArg Subtype.val heq) + +-- The ij glue is closed after an open kl glue. +private theorem closedOpen_second_closed + (W : Fragment α) {i j k l : α} + (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hclosed_ij : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) : + (W.gluePairOpen k l hkl hopen_kl).pairing + ((W.gluePairOpen k l hkl hopen_kl).boundaryFlag ⟨i, hik, hil⟩) = + (W.gluePairOpen k l hkl hopen_kl).boundaryFlag ⟨j, hjk, hjl⟩ := by + -- Need to show: rewire hopen_kl (glueBF i') = glueBF j' + -- W.pairing(bFi) = bFj, and bFj ≠ bFk (j≠k), bFj ≠ bFl (j≠l) + -- So rewire hits else branch: val = W.pairing(bFi) = bFj = (glueBF j').val + apply Subtype.ext + have hne_k : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag k := by + rw [hclosed_ij]; exact fun h => hjk (W.boundaryFlag_injective h) + have hne_l : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag l := by + rw [hclosed_ij]; exact fun h => hjl (W.boundaryFlag_injective h) + have hval := @rewire_val_ne' _ W k l hopen_kl + (glueBoundaryFlag W k l ⟨i, hik, hil⟩) hne_k hne_l + exact hval.trans hclosed_ij + +/-- Configuration (1): commutativity when `{i, j}` is an edge and +`{k, l}` is not. The ij-first order is closed then open; the kl-first +order is open then closed; both give circles `W.circles + 1`. -/ +def closedOpenEquiv [DecidableEq α] + (W : Fragment α) {i j k l : α} + (_hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hclosed_ij : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) : + ((W.gluePairClosed i j hclosed_ij).gluePairOpen + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (fun h => hkl (congrArg Subtype.val h)) + (by exact (closedOpen_second_open W hik hil hjk hjl hclosed_ij hopen_kl))).Equiv + (((W.gluePairOpen k l hkl hopen_kl).gluePairClosed + ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ + (by exact (closedOpen_second_closed W hkl hik hil hjk hjl hclosed_ij + hopen_kl))).relabel + (swapLabelEquiv hik hil hjk hjl).symm) where + flagEquiv := by exact doubleSurvivingSwap W hik hil hjk hjl + vertexEquiv := _root_.Equiv.refl W.Vertex + attach_comm f := by + exact doubleGlueAttach_comm W hik hil hjk hjl f + pairing_comm f := by + -- Both sides compute the same underlying W.Flag value. + -- LHS: rewire on gluePairClosed(ij) checking partner vs bFk/bFl + -- RHS: restricted (rewire on W checking partner vs bFk/bFl) + apply Subtype.ext + apply Subtype.ext + -- Name the two single glues; every transport below is + -- read at one of them. + let Wij := W.gluePairClosed i j hclosed_ij + let g := doubleSurvivingSwap W hik hil hjk hjl f + let hopen_ij_kl := closedOpen_second_open W hik hil hjk hjl + hclosed_ij hopen_kl + -- Both sides test the partner of `f.val.val` against `bFk` and + -- `bFl`: on the left after the ij-glue, on the right before it. + change (rewire hopen_ij_kl f).val.val = + (rewire hopen_kl g.val).val + have hgval : g.val.val = f.val.val := rfl + by_cases hpk : W.pairing f.val.val = W.boundaryFlag k + · -- Partner is bFk: both sides give W.pairing(bFl) + -- LHS: the ij-glue's pairing of f has underlying value bFk, so + -- it is the glued flag at k' and rewire takes its first + -- branch, giving the glued flag at l', that is W.pairing bFl. + have lhs_eq_k : Wij.pairing f.val = + Wij.boundaryFlag ⟨k, hik.symm, hjk.symm⟩ := + Subtype.ext hpk + have lhs_val : (rewire hopen_ij_kl f).val.val = + W.pairing (W.boundaryFlag l) := by + have h := rewire_val_left' (hopen := hopen_ij_kl) lhs_eq_k + exact congrArg Subtype.val h + -- RHS: W.pairing g.val.val = bFk → rewire first branch → W.pairing(bFl) + have rhs_eq_k : W.pairing g.val.val = W.boundaryFlag k := by + change W.pairing f.val.val = W.boundaryFlag k; exact hpk + have rhs_val : (rewire hopen_kl g.val).val = + W.pairing (W.boundaryFlag l) := + @rewire_val_left' _ W k l hopen_kl g.val rhs_eq_k + rw [lhs_val, rhs_val] + · by_cases hpl : W.pairing f.val.val = W.boundaryFlag l + · -- Partner is bFl: both sides give W.pairing(bFk) + have lhs_ne_k : Wij.pairing f.val ≠ + Wij.boundaryFlag ⟨k, hik.symm, hjk.symm⟩ := + fun h => hpk (congrArg Subtype.val h) + have lhs_eq_l : Wij.pairing f.val = + Wij.boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := + Subtype.ext hpl + have lhs_val : (rewire hopen_ij_kl f).val.val = + W.pairing (W.boundaryFlag k) := by + have h := rewire_val_right' (hopen := hopen_ij_kl) lhs_ne_k lhs_eq_l + exact congrArg Subtype.val h + have rhs_ne_k : W.pairing g.val.val ≠ W.boundaryFlag k := by + change W.pairing f.val.val ≠ W.boundaryFlag k; exact hpk + have rhs_eq_l : W.pairing g.val.val = W.boundaryFlag l := by + change W.pairing f.val.val = W.boundaryFlag l; exact hpl + have rhs_val : (rewire hopen_kl g.val).val = + W.pairing (W.boundaryFlag k) := + @rewire_val_right' _ W k l hopen_kl g.val rhs_ne_k rhs_eq_l + rw [lhs_val, rhs_val] + · -- Partner is neither bFk nor bFl: both sides give W.pairing f.val.val + have lhs_ne_k : Wij.pairing f.val ≠ + Wij.boundaryFlag ⟨k, hik.symm, hjk.symm⟩ := + fun h => hpk (congrArg Subtype.val h) + have lhs_ne_l : Wij.pairing f.val ≠ + Wij.boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := + fun h => hpl (congrArg Subtype.val h) + have lhs_val : (rewire hopen_ij_kl f).val.val = + W.pairing f.val.val := by + have h := rewire_val_ne' (hopen := hopen_ij_kl) lhs_ne_k lhs_ne_l + exact congrArg Subtype.val h + have rhs_ne_k : W.pairing g.val.val ≠ W.boundaryFlag k := by + change W.pairing f.val.val ≠ W.boundaryFlag k; exact hpk + have rhs_ne_l : W.pairing g.val.val ≠ W.boundaryFlag l := by + change W.pairing f.val.val ≠ W.boundaryFlag l; exact hpl + have rhs_val : (rewire hopen_kl g.val).val = W.pairing f.val.val := + @rewire_val_ne' _ W k l hopen_kl g.val rhs_ne_k rhs_ne_l + rw [lhs_val, rhs_val] + circles_eq := rfl + +/-! ### Configuration (1'): {k,l} closed, {i,j} open (open-closed mixed) -/ + +-- The ij glue is open after a closed kl glue. +private theorem openClosed_second_open + (W : Fragment α) {i j k l : α} + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hclosed_kl : W.pairing (W.boundaryFlag k) = W.boundaryFlag l) : + (W.gluePairClosed k l hclosed_kl).pairing + ((W.gluePairClosed k l hclosed_kl).boundaryFlag ⟨i, hik, hil⟩) ≠ + (W.gluePairClosed k l hclosed_kl).boundaryFlag ⟨j, hjk, hjl⟩ := by + intro heq + exact hopen_ij (congrArg Subtype.val heq) + +-- The kl glue is closed after an open ij glue. +private theorem openClosed_second_closed + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hclosed_kl : W.pairing (W.boundaryFlag k) = W.boundaryFlag l) : + (W.gluePairOpen i j hij hopen_ij).pairing + ((W.gluePairOpen i j hij hopen_ij).boundaryFlag ⟨k, hik.symm, hjk.symm⟩) = + (W.gluePairOpen i j hij hopen_ij).boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := by + apply Subtype.ext + have hne_i : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag i := by + rw [hclosed_kl]; exact fun h => hil.symm (W.boundaryFlag_injective h) + have hne_j : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag j := by + rw [hclosed_kl]; exact fun h => hjl.symm (W.boundaryFlag_injective h) + have hval := @rewire_val_ne' _ W i j hopen_ij + (glueBoundaryFlag W i j ⟨k, hik.symm, hjk.symm⟩) + hne_i hne_j + exact hval.trans hclosed_kl + +/-- Configuration (1'): commutativity when `{k, l}` is an edge and +`{i, j}` is not. The ij-first order is open then closed; the kl-first +order is closed then open; both give circles `W.circles + 1`. -/ +def openClosedEquiv [DecidableEq α] + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (_hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hclosed_kl : W.pairing (W.boundaryFlag k) = W.boundaryFlag l) : + ((W.gluePairOpen i j hij hopen_ij).gluePairClosed + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (by exact (openClosed_second_closed W hij hik hil hjk hjl hopen_ij + hclosed_kl))).Equiv + (((W.gluePairClosed k l hclosed_kl).gluePairOpen + ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ + (fun h => hij (congrArg Subtype.val h)) + (by exact (openClosed_second_open W hik hil hjk hjl hopen_ij hclosed_kl))).relabel + (swapLabelEquiv hik hil hjk hjl).symm) where + flagEquiv := by exact doubleSurvivingSwap W hik hil hjk hjl + vertexEquiv := _root_.Equiv.refl W.Vertex + attach_comm f := by + exact doubleGlueAttach_comm W hik hil hjk hjl f + pairing_comm f := by + -- LHS: restricted pairing of gluePairOpen(ij) = rewire(ij) restricted + -- RHS: rewire on gluePairClosed(kl) checking partner vs bFi/bFj + -- Both reduce to the same 3-case split on W.pairing f.val.val vs bFi/bFj + apply Subtype.ext + apply Subtype.ext + -- Name the two single glues; every transport below is + -- read at one of them. + let Wkl := W.gluePairClosed k l hclosed_kl + let g := doubleSurvivingSwap W hik hil hjk hjl f + let hopen_kl_ij := openClosed_second_open W hik hil hjk hjl + hopen_ij hclosed_kl + -- Both sides test the partner of `f.val.val` against `bFi` and + -- `bFj`: on the left before the kl-glue, on the right after it. + change (rewire hopen_ij f.val).val = + (rewire hopen_kl_ij g).val.val + have hgval : g.val.val = f.val.val := rfl + by_cases hpi : W.pairing f.val.val = W.boundaryFlag i + · -- Partner is bFi: both sides give W.pairing(bFj) + -- LHS: rewire(ij) first branch → W.pairing(bFj) + have lhs_val : (rewire hopen_ij f.val).val = + W.pairing (W.boundaryFlag j) := + rewire_val_left' hpi + -- RHS: inner pairing is ⟨W.pairing g.val.val,...⟩ = ⟨bFi,...⟩ = glueBF i' + have rhs_eq_i : Wkl.pairing g.val = + Wkl.boundaryFlag ⟨i, hik, hil⟩ := + Subtype.ext (show W.pairing g.val.val = W.boundaryFlag i from hpi) + have rhs_val : (rewire hopen_kl_ij g).val.val = + W.pairing (W.boundaryFlag j) := by + have h := rewire_val_left' (hopen := hopen_kl_ij) rhs_eq_i + exact congrArg Subtype.val h + rw [lhs_val, rhs_val] + · by_cases hpj : W.pairing f.val.val = W.boundaryFlag j + · -- Partner is bFj: both sides give W.pairing(bFi) + have lhs_val : (rewire hopen_ij f.val).val = + W.pairing (W.boundaryFlag i) := + rewire_val_right' hpi hpj + have rhs_ne_i : Wkl.pairing g.val ≠ + Wkl.boundaryFlag ⟨i, hik, hil⟩ := + fun h => hpi (congrArg Subtype.val h) + have rhs_eq_j : Wkl.pairing g.val = + Wkl.boundaryFlag ⟨j, hjk, hjl⟩ := + Subtype.ext (show W.pairing g.val.val = W.boundaryFlag j from hpj) + have rhs_val : (rewire hopen_kl_ij g).val.val = + W.pairing (W.boundaryFlag i) := by + have h := rewire_val_right' (hopen := hopen_kl_ij) rhs_ne_i rhs_eq_j + exact congrArg Subtype.val h + rw [lhs_val, rhs_val] + · -- Partner is neither bFi nor bFj: both sides give W.pairing f.val.val + have lhs_val : (rewire hopen_ij f.val).val = W.pairing f.val.val := + rewire_val_ne' hpi hpj + have rhs_ne_i : Wkl.pairing g.val ≠ + Wkl.boundaryFlag ⟨i, hik, hil⟩ := + fun h => hpi (congrArg Subtype.val h) + have rhs_ne_j : Wkl.pairing g.val ≠ + Wkl.boundaryFlag ⟨j, hjk, hjl⟩ := + fun h => hpj (congrArg Subtype.val h) + have rhs_val : (rewire hopen_kl_ij g).val.val = + W.pairing f.val.val := by + have h := rewire_val_ne' (hopen := hopen_kl_ij) rhs_ne_i rhs_ne_j + exact congrArg Subtype.val h + rw [lhs_val, rhs_val] + circles_eq := rfl + +/-! ### Configuration (2): one cross-edge, variant {ik} -/ + +-- Second kl-glue is open after ij-glue (cross ik variant). +private theorem oneCross_ik_second_open_kl + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (_hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hcross : W.pairing (W.boundaryFlag i) = W.boundaryFlag k) + (hfar_jl : W.pairing (W.boundaryFlag j) ≠ W.boundaryFlag l) : + (W.gluePairOpen i j hij hopen_ij).pairing + ((W.gluePairOpen i j hij hopen_ij).boundaryFlag ⟨k, hik.symm, hjk.symm⟩) ≠ + (W.gluePairOpen i j hij hopen_ij).boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := by + intro heq + have hki : W.pairing (W.boundaryFlag k) = W.boundaryFlag i := + W.pairing_boundaryFlag_comm hcross + have lhs_val : (rewire hopen_ij (glueBoundaryFlag W i j ⟨k, hik.symm, + hjk.symm⟩)).val = + W.pairing (W.boundaryFlag j) := rewire_val_left' hki + exact hfar_jl (lhs_val.symm ▸ congrArg Subtype.val heq) + +-- Second ij-glue is open after kl-glue (cross ik variant). +private theorem oneCross_ik_second_open_ij + (W : Fragment α) {i j k l : α} + (_hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hcross : W.pairing (W.boundaryFlag i) = W.boundaryFlag k) + (hfar_jl : W.pairing (W.boundaryFlag j) ≠ W.boundaryFlag l) : + (W.gluePairOpen k l hkl hopen_kl).pairing + ((W.gluePairOpen k l hkl hopen_kl).boundaryFlag ⟨i, hik, hil⟩) ≠ + (W.gluePairOpen k l hkl hopen_kl).boundaryFlag ⟨j, hjk, hjl⟩ := by + intro heq + have lhs_val : (rewire hopen_kl (glueBoundaryFlag W k l ⟨i, hik, hil⟩)).val = + W.pairing (W.boundaryFlag l) := rewire_val_left' hcross + have hfar_lj : W.pairing (W.boundaryFlag l) ≠ W.boundaryFlag j := + fun h => hfar_jl (W.pairing_boundaryFlag_comm h) + exact hfar_lj (lhs_val.symm ▸ congrArg Subtype.val heq) + +private theorem oneCross_ik_equiv_pairing_comm + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hcross : W.pairing (W.boundaryFlag i) = W.boundaryFlag k) + (hfar_jl : W.pairing (W.boundaryFlag j) ≠ W.boundaryFlag l) + (f : (((W.gluePairOpen i j hij hopen_ij).gluePairOpen + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (fun h => hkl (congrArg Subtype.val h)) + (oneCross_ik_second_open_kl W hij hkl hik hil hjk hjl hopen_ij hcross + hfar_jl))).Flag) : + doubleSurvivingSwap W hik hil hjk hjl ((((W.gluePairOpen i j hij hopen_ij).gluePairOpen + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (fun h => hkl (congrArg Subtype.val h)) + (oneCross_ik_second_open_kl W hij hkl hik hil hjk hjl hopen_ij hcross + hfar_jl))).pairing f) = + ((((W.gluePairOpen k l hkl hopen_kl).gluePairOpen + ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ + (fun h => hij (congrArg Subtype.val h)) + (oneCross_ik_second_open_ij W hij hkl hik hil hjk hjl hopen_kl hcross + hfar_jl)).relabel + (swapLabelEquiv hik hil hjk hjl).symm)).pairing (doubleSurvivingSwap W hik hil hjk + hjl f) := by + classical + apply Subtype.ext; apply Subtype.ext + -- Name the two single glues; every transport below is + -- read at one of them. + let Wij := W.gluePairOpen i j hij hopen_ij + let Wkl := W.gluePairOpen k l hkl hopen_kl + let g := doubleSurvivingSwap W hik hil hjk hjl f + change (rewire (oneCross_ik_second_open_kl W hij hkl hik hil hjk hjl hopen_ij + hcross hfar_jl) + f).val.val = + (rewire (oneCross_ik_second_open_ij W hij hkl hik hil hjk hjl hopen_kl + hcross hfar_jl) + g).val.val + have hgval : g.val.val = f.val.val := rfl + have hki : W.pairing (W.boundaryFlag k) = W.boundaryFlag i := + W.pairing_boundaryFlag_comm hcross + have hfar_jk : W.pairing (W.boundaryFlag j) ≠ W.boundaryFlag k := fun h => + hij (W.boundaryFlag_injective (hki.symm.trans (W.pairing_boundaryFlag_comm + h))) + have hfar_lj : W.pairing (W.boundaryFlag l) ≠ W.boundaryFlag j := + fun h => hfar_jl (W.pairing_boundaryFlag_comm h) + have hfar_li : W.pairing (W.boundaryFlag l) ≠ W.boundaryFlag i := fun h => + hkl (W.boundaryFlag_injective (hcross.symm.trans + (W.pairing_boundaryFlag_comm h))) + let hopen_ij_kl := oneCross_ik_second_open_kl W hij hkl hik hil hjk hjl + hopen_ij hcross hfar_jl + let hopen_kl_ij := oneCross_ik_second_open_ij W hij hkl hik hil hjk hjl + hopen_kl hcross hfar_jl + -- Case split: partner = bFj, bFl, or none (bFi and bFk are impossible) + by_cases hpj : W.pairing f.val.val = W.boundaryFlag j + · -- ═══════ PARTNER IS bF j: BOTH ORDERS GIVE W.pairing (bF l) ═══════ + have hpi : W.pairing f.val.val ≠ W.boundaryFlag i := by + intro h + have hfk : f.val.val = W.boundaryFlag k := by + have := congrArg W.pairing h + rw [W.pairing_invol, hcross] at this + exact this + exact absurd (Subtype.ext hfk) f.prop.1 + -- LHS: inner ij right branch → val = W.pairing(bFi) = bFk + have lhs_inner : (rewire hopen_ij f.val).val = + W.pairing (W.boundaryFlag i) := + rewire_val_right' hpi hpj + have lhs_inner_eq_k : (rewire hopen_ij f.val).val = W.boundaryFlag k := by + rw [lhs_inner, hcross] + have lhs_outer_eq_k : Wij.pairing f.val = + Wij.boundaryFlag ⟨k, hik.symm, hjk.symm⟩ := + Subtype.ext lhs_inner_eq_k + -- Outer: first branch, giving the ij-glue's pairing at l'; and + -- rewire(ij) at bFl takes its else branch, so that is + -- W.pairing bFl. + have lhs_l_rewire : (rewire hopen_ij (glueBoundaryFlag W i j + ⟨l, hil.symm, hjl.symm⟩)).val = W.pairing (W.boundaryFlag l) := + rewire_val_ne' hfar_li hfar_lj + have lhs_val : (rewire hopen_ij_kl f).val.val = + W.pairing (W.boundaryFlag l) := by + have h := rewire_val_left' (hopen := hopen_ij_kl) lhs_outer_eq_k + exact congrArg Subtype.val h ▸ lhs_l_rewire + -- RHS: inner kl else (bFj ≠ bFk, ≠ bFl) → val = bFj + have rhs_ne_k : W.pairing g.val.val ≠ W.boundaryFlag k := by + change W.pairing f.val.val ≠ _; rw [hpj] + exact fun h => hjk (W.boundaryFlag_injective h) + have rhs_ne_l : W.pairing g.val.val ≠ W.boundaryFlag l := by + change W.pairing f.val.val ≠ _; rw [hpj] + exact fun h => hjl (W.boundaryFlag_injective h) + have rhs_inner : (rewire hopen_kl g.val).val = W.boundaryFlag j := by + have h := @rewire_val_ne' _ W k l hopen_kl g.val rhs_ne_k rhs_ne_l + rw [h]; exact hpj + -- outer ij: = bFj → second branch → (gluePairOpen kl).pairing(bFi') + have rhs_ne_i : (rewire hopen_kl g.val).val ≠ W.boundaryFlag i := by + rw [rhs_inner]; exact fun h => hij.symm (W.boundaryFlag_injective h) + have rhs_outer_ne_i : Wkl.pairing g.val ≠ + Wkl.boundaryFlag ⟨i, hik, hil⟩ := fun h => + rhs_ne_i (congrArg Subtype.val h) + have rhs_outer_eq_j : Wkl.pairing g.val = + Wkl.boundaryFlag ⟨j, hjk, hjl⟩ := + Subtype.ext rhs_inner + -- rewire(kl) at bFi takes its first branch, W.pairing bFi being + -- bFk, giving W.pairing bFl. + have rhs_i_rewire : (rewire hopen_kl (glueBoundaryFlag W k l + ⟨i, hik, hil⟩)).val = W.pairing (W.boundaryFlag l) := + rewire_val_left' hcross + have rhs_val : (rewire hopen_kl_ij g).val.val = + W.pairing (W.boundaryFlag l) := by + have h := rewire_val_right' (hopen := hopen_kl_ij) rhs_outer_ne_i + rhs_outer_eq_j + exact congrArg Subtype.val h ▸ rhs_i_rewire + rw [lhs_val, rhs_val] + · by_cases hpl : W.pairing f.val.val = W.boundaryFlag l + · -- Case D: partner = bFl → both give W.pairing(bFj) + have hpi : W.pairing f.val.val ≠ W.boundaryFlag i := by + intro h + have hfk : f.val.val = W.boundaryFlag k := by + have := congrArg W.pairing h + rw [W.pairing_invol, hcross] at this + exact this + exact absurd (Subtype.ext hfk) f.prop.1 + -- LHS: inner ij else (≠bFi, ≠bFj) → val = bFl + have lhs_inner : (rewire hopen_ij f.val).val = W.pairing f.val.val := + rewire_val_ne' hpi hpj + have lhs_inner_eq_l : (rewire hopen_ij f.val).val = + W.boundaryFlag l := by + rw [lhs_inner, hpl] + have lhs_ne_k : (rewire hopen_ij f.val).val ≠ W.boundaryFlag k := by + rw [lhs_inner_eq_l] + exact fun h => hkl.symm (W.boundaryFlag_injective h) + have lhs_outer_ne_k : Wij.pairing f.val ≠ + Wij.boundaryFlag ⟨k, hik.symm, hjk.symm⟩ := + fun h => lhs_ne_k (congrArg Subtype.val h) + have lhs_outer_eq_l : Wij.pairing f.val = + Wij.boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := + Subtype.ext lhs_inner_eq_l + -- Outer: second branch, giving the ij-glue's pairing at k'; + -- and rewire(ij) at bFk takes its first branch, W.pairing + -- bFk being bFi, giving W.pairing bFj. + have lhs_k_rewire : (rewire hopen_ij (glueBoundaryFlag W i j + ⟨k, hik.symm, hjk.symm⟩)).val = W.pairing (W.boundaryFlag j) := + rewire_val_left' hki + have lhs_val : (rewire hopen_ij_kl f).val.val = + W.pairing (W.boundaryFlag j) := by + have h := rewire_val_right' (hopen := hopen_ij_kl) lhs_outer_ne_k + lhs_outer_eq_l + exact congrArg Subtype.val h ▸ lhs_k_rewire + -- RHS: inner kl second branch (≠bFk, =bFl) → val = W.pairing(bFk) = bFi + have rhs_ne_k : W.pairing g.val.val ≠ W.boundaryFlag k := by + intro h + change W.pairing f.val.val = _ at h + have hfi : f.val.val = W.boundaryFlag i := by + have := congrArg W.pairing h + rw [W.pairing_invol, hki] at this + exact this + exact f.val.prop.1 hfi + have rhs_eq_l : W.pairing g.val.val = W.boundaryFlag l := by + change W.pairing f.val.val = _; exact hpl + have rhs_inner : (rewire hopen_kl g.val).val = + W.pairing (W.boundaryFlag k) := + @rewire_val_right' _ W k l hopen_kl g.val rhs_ne_k rhs_eq_l + have rhs_inner_eq_i : (rewire hopen_kl g.val).val = + W.boundaryFlag i := by + rw [rhs_inner, hki] + -- outer ij: = bFi → first branch → (gluePairOpen kl).pairing(bFj') + have rhs_outer_eq_i : Wkl.pairing g.val = + Wkl.boundaryFlag ⟨i, hik, hil⟩ := + Subtype.ext rhs_inner_eq_i + -- rewire(kl) at bFj takes its else branch, W.pairing bFj being + -- neither bFk nor bFl, leaving W.pairing bFj. + have rhs_j_rewire : (rewire hopen_kl (glueBoundaryFlag W k l + ⟨j, hjk, hjl⟩)).val = W.pairing (W.boundaryFlag j) := + rewire_val_ne' hfar_jk hfar_jl + have rhs_val : (rewire hopen_kl_ij g).val.val = + W.pairing (W.boundaryFlag j) := by + have h := rewire_val_left' (hopen := hopen_kl_ij) rhs_outer_eq_i + exact congrArg Subtype.val h ▸ rhs_j_rewire + rw [lhs_val, rhs_val] + · -- Case E: none of bFi,bFj,bFk,bFl → both give W.pairing(f.val.val) + have hpi : W.pairing f.val.val ≠ W.boundaryFlag i := by + intro h + have hfk : f.val.val = W.boundaryFlag k := by + have := congrArg W.pairing h + rw [W.pairing_invol, hcross] at this + exact this + exact absurd (Subtype.ext hfk) f.prop.1 + have hpk : W.pairing f.val.val ≠ W.boundaryFlag k := by + intro h + have hfi : f.val.val = W.boundaryFlag i := by + have := congrArg W.pairing h + rw [W.pairing_invol, hki] at this + exact this + exact f.val.prop.1 hfi + -- LHS: inner ij else → val = W.pairing(f.val.val); outer kl else + have lhs_inner : (rewire hopen_ij f.val).val = W.pairing f.val.val := + rewire_val_ne' hpi hpj + have lhs_ne_k : (rewire hopen_ij f.val).val ≠ W.boundaryFlag k := by + rw [lhs_inner]; exact hpk + have lhs_ne_l : (rewire hopen_ij f.val).val ≠ W.boundaryFlag l := by + rw [lhs_inner]; exact hpl + have lhs_outer_ne_k : Wij.pairing f.val ≠ + Wij.boundaryFlag ⟨k, hik.symm, hjk.symm⟩ := fun h => + lhs_ne_k (congrArg Subtype.val h) + have lhs_outer_ne_l : Wij.pairing f.val ≠ + Wij.boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := fun h => + lhs_ne_l (congrArg Subtype.val h) + have lhs_val : (rewire hopen_ij_kl f).val.val = + W.pairing f.val.val := by + have h := rewire_val_ne' (hopen := hopen_ij_kl) lhs_outer_ne_k + lhs_outer_ne_l + exact congrArg Subtype.val h ▸ lhs_inner + -- RHS: inner kl else → val = W.pairing(f.val.val); outer ij else + have rhs_ne_k : W.pairing g.val.val ≠ W.boundaryFlag k := by + change W.pairing f.val.val ≠ _; exact hpk + have rhs_ne_l : W.pairing g.val.val ≠ W.boundaryFlag l := by + change W.pairing f.val.val ≠ _; exact hpl + have rhs_inner : (rewire hopen_kl g.val).val = W.pairing f.val.val := by + exact @rewire_val_ne' _ W k l hopen_kl g.val rhs_ne_k rhs_ne_l + have rhs_ne_i : (rewire hopen_kl g.val).val ≠ W.boundaryFlag i := by + rw [rhs_inner]; exact hpi + have rhs_ne_j : (rewire hopen_kl g.val).val ≠ W.boundaryFlag j := by + rw [rhs_inner]; exact hpj + have rhs_outer_ne_i : Wkl.pairing g.val ≠ + Wkl.boundaryFlag ⟨i, hik, hil⟩ := fun h => + rhs_ne_i (congrArg Subtype.val h) + have rhs_outer_ne_j : Wkl.pairing g.val ≠ + Wkl.boundaryFlag ⟨j, hjk, hjl⟩ := fun h => + rhs_ne_j (congrArg Subtype.val h) + have rhs_val : (rewire hopen_kl_ij g).val.val = + W.pairing f.val.val := by + have h := rewire_val_ne' (hopen := hopen_kl_ij) rhs_outer_ne_i + rhs_outer_ne_j + exact congrArg Subtype.val h ▸ rhs_inner + rw [lhs_val, rhs_val] + +private theorem oneCross_ik_equiv_attach_comm + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hcross : W.pairing (W.boundaryFlag i) = W.boundaryFlag k) + (hfar_jl : W.pairing (W.boundaryFlag j) ≠ W.boundaryFlag l) + (f : (((W.gluePairOpen i j hij hopen_ij).gluePairOpen + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (fun h => hkl (congrArg Subtype.val h)) + (oneCross_ik_second_open_kl W hij hkl hik hil hjk hjl hopen_ij hcross + hfar_jl))).Flag) : + ((((W.gluePairOpen k l hkl hopen_kl).gluePairOpen + ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ + (fun h => hij (congrArg Subtype.val h)) + (oneCross_ik_second_open_ij W hij hkl hik hil hjk hjl hopen_kl hcross + hfar_jl)).relabel + (swapLabelEquiv hik hil hjk hjl).symm)).attach (doubleSurvivingSwap W hik hil hjk hjl f) = + ((((W.gluePairOpen i j hij hopen_ij).gluePairOpen + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (fun h => hkl (congrArg Subtype.val h)) + (oneCross_ik_second_open_kl W hij hkl hik hil hjk hjl hopen_ij hcross + hfar_jl))).attach f).map (_root_.Equiv.refl W.Vertex) id := by + classical + exact doubleGlueAttach_comm W hik hil hjk hjl f + +/-- Configuration (2), variant {ik}: one cross-edge `W.pairing(bFi) = bFk`. +Both glues are open in both orders; circles = `W.circles`. -/ +def oneCrossIkEquiv [DecidableEq α] + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hcross : W.pairing (W.boundaryFlag i) = W.boundaryFlag k) + (hfar_jl : W.pairing (W.boundaryFlag j) ≠ W.boundaryFlag l) : + ((W.gluePairOpen i j hij hopen_ij).gluePairOpen + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (fun h => hkl (congrArg Subtype.val h)) + (by exact (oneCross_ik_second_open_kl W hij hkl hik hil hjk hjl hopen_ij hcross + hfar_jl))).Equiv + (((W.gluePairOpen k l hkl hopen_kl).gluePairOpen + ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ + (fun h => hij (congrArg Subtype.val h)) + (by exact (oneCross_ik_second_open_ij W hij hkl hik hil hjk hjl hopen_kl hcross + hfar_jl))).relabel + (swapLabelEquiv hik hil hjk hjl).symm) where + flagEquiv := by exact doubleSurvivingSwap W hik hil hjk hjl + vertexEquiv := _root_.Equiv.refl W.Vertex + attach_comm := by + exact oneCross_ik_equiv_attach_comm W hij hkl hik hil hjk hjl hopen_ij hopen_kl + hcross hfar_jl + pairing_comm := by + exact oneCross_ik_equiv_pairing_comm W hij hkl hik hil hjk hjl hopen_ij + hopen_kl hcross hfar_jl + circles_eq := rfl + +/-! ### Configuration (2): one cross-edge, variant {il} -/ + +-- Second kl-glue is open after ij-glue (cross il variant). +private theorem oneCross_il_second_open_kl + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hcross : W.pairing (W.boundaryFlag i) = W.boundaryFlag l) + (hfar_jk : W.pairing (W.boundaryFlag j) ≠ W.boundaryFlag k) : + (W.gluePairOpen i j hij hopen_ij).pairing + ((W.gluePairOpen i j hij hopen_ij).boundaryFlag ⟨k, hik.symm, hjk.symm⟩) ≠ + (W.gluePairOpen i j hij hopen_ij).boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := by + intro heq + have h_ne_i : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag i := fun h => + hkl (W.boundaryFlag_injective ((W.pairing_boundaryFlag_comm h).symm.trans + hcross)) + have h_ne_j : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag j := fun h => + hfar_jk (W.pairing_boundaryFlag_comm h) + have hval : (rewire hopen_ij (glueBoundaryFlag W i j ⟨k, hik.symm, + hjk.symm⟩)).val = + W.pairing (W.boundaryFlag k) := rewire_val_ne' h_ne_i h_ne_j + exact hopen_kl (hval.symm ▸ congrArg Subtype.val heq) + +-- Second ij-glue is open after kl-glue (cross il variant). +private theorem oneCross_il_second_open_ij + (W : Fragment α) {i j k l : α} + (_hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (_hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hcross : W.pairing (W.boundaryFlag i) = W.boundaryFlag l) + (hfar_jk : W.pairing (W.boundaryFlag j) ≠ W.boundaryFlag k) : + (W.gluePairOpen k l hkl hopen_kl).pairing + ((W.gluePairOpen k l hkl hopen_kl).boundaryFlag ⟨i, hik, hil⟩) ≠ + (W.gluePairOpen k l hkl hopen_kl).boundaryFlag ⟨j, hjk, hjl⟩ := by + intro heq + have h_ne_k : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag k := fun h => + hkl (W.boundaryFlag_injective (h.symm.trans hcross)) + have hval : (rewire hopen_kl (glueBoundaryFlag W k l ⟨i, hik, hil⟩)).val = + W.pairing (W.boundaryFlag k) := + rewire_val_right' h_ne_k hcross + have hfar_kj : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag j := fun h => + hfar_jk (W.pairing_boundaryFlag_comm h) + exact hfar_kj (hval.symm ▸ congrArg Subtype.val heq) + +/-- Configuration (2), variant {il}: one cross-edge `W.pairing(bFi) = bFl`. +Both glues are open in both orders; circles = `W.circles`. -/ +def oneCrossIlEquiv [DecidableEq α] + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hcross : W.pairing (W.boundaryFlag i) = W.boundaryFlag l) + (hfar_jk : W.pairing (W.boundaryFlag j) ≠ W.boundaryFlag k) : + ((W.gluePairOpen i j hij hopen_ij).gluePairOpen + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (fun h => hkl (congrArg Subtype.val h)) + (by exact (oneCross_il_second_open_kl W hij hkl hik hil hjk hjl + hopen_ij hopen_kl hcross hfar_jk))).Equiv + (((W.gluePairOpen k l hkl hopen_kl).gluePairOpen + ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ + (fun h => hij (congrArg Subtype.val h)) + (by exact (oneCross_il_second_open_ij W hij hkl hik hil hjk hjl + hopen_ij hopen_kl hcross hfar_jk))).relabel + (swapLabelEquiv hik hil hjk hjl).symm) where + flagEquiv := by exact doubleSurvivingSwap W hik hil hjk hjl + vertexEquiv := _root_.Equiv.refl W.Vertex + attach_comm f := by + exact doubleGlueAttach_comm W hik hil hjk hjl f + pairing_comm f := by + apply Subtype.ext; apply Subtype.ext + -- ═══════ THE ATTACHMENT AND FLAG SIDES ARE SHARED ═══════ + -- Only the pairing distinguishes this configuration, so what + -- follows is the five-way case analysis on the partner of the + -- flag, at the cross-edge this configuration carries. + -- Name the two single glues; every transport below is + -- read at one of them. + let Wij := W.gluePairOpen i j hij hopen_ij + let Wkl := W.gluePairOpen k l hkl hopen_kl + let g := doubleSurvivingSwap W hik hil hjk hjl f + change (rewire (oneCross_il_second_open_kl W hij hkl hik hil hjk hjl + hopen_ij hopen_kl hcross hfar_jk) f).val.val = + (rewire (oneCross_il_second_open_ij W hij hkl hik hil hjk hjl + hopen_ij hopen_kl hcross hfar_jk) g).val.val + have hli : W.pairing (W.boundaryFlag l) = W.boundaryFlag i := + W.pairing_boundaryFlag_comm hcross + have hfar_kj : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag j := fun h => + hfar_jk (W.pairing_boundaryFlag_comm h) + have hfar_ki : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag i := fun h => + hkl (W.boundaryFlag_injective ((W.pairing_boundaryFlag_comm h).symm.trans + hcross)) + have hfar_jl : W.pairing (W.boundaryFlag j) ≠ W.boundaryFlag l := fun h => + hij (W.boundaryFlag_injective (hli.symm.trans (W.pairing_boundaryFlag_comm + h))) + let hopen_ij_kl := oneCross_il_second_open_kl W hij hkl hik hil hjk hjl + hopen_ij hopen_kl hcross hfar_jk + let hopen_kl_ij := oneCross_il_second_open_ij W hij hkl hik hil hjk hjl + hopen_ij hopen_kl hcross hfar_jk + rcases partner_cases W f.val.val i l j k with + hpi | ⟨hpi, hpl⟩ | ⟨hpi, hpl, hpj⟩ | ⟨hpi, hpl, hpj, hpk⟩ | + ⟨hpi, hpl, hpj, hpk⟩ + · -- Impossible: f.val.val = bFl + have hfl : f.val.val = W.boundaryFlag l := by + have h := congrArg W.pairing hpi + rw [W.pairing_invol] at h + exact h.trans hcross + exact absurd (Subtype.ext hfl) f.prop.2 + · -- Impossible: f.val.val = bFi + have hfi : f.val.val = W.boundaryFlag i := by + have h := congrArg W.pairing hpl + rw [W.pairing_invol] at h + exact h.trans hli + exact absurd hfi f.val.prop.1 + · -- Case: partner = bFj → both give W.pairing(bFk) + have lhs_inner : (rewire hopen_ij f.val).val = + W.pairing (W.boundaryFlag i) := + rewire_val_right' hpi hpj + have lhs_inner_eq_l : (rewire hopen_ij f.val).val = W.boundaryFlag l := by + rw [lhs_inner, hcross] + have lhs_outer_ne_k : Wij.pairing f.val ≠ + Wij.boundaryFlag ⟨k, hik.symm, hjk.symm⟩ := fun h => + (fun h' => hkl.symm (W.boundaryFlag_injective h')) + (lhs_inner_eq_l ▸ congrArg Subtype.val h) + have lhs_outer_eq_l : Wij.pairing f.val = + Wij.boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := + Subtype.ext lhs_inner_eq_l + have lhs_k_rewire : (rewire hopen_ij (glueBoundaryFlag W i j + ⟨k, hik.symm, hjk.symm⟩)).val = W.pairing (W.boundaryFlag k) := + rewire_val_ne' hfar_ki hfar_kj + have lhs_val : (rewire hopen_ij_kl f).val.val = + W.pairing (W.boundaryFlag k) := by + have h := rewire_val_right' (hopen := hopen_ij_kl) lhs_outer_ne_k + lhs_outer_eq_l + exact congrArg Subtype.val h ▸ lhs_k_rewire + have rhs_ne_k : W.pairing g.val.val ≠ W.boundaryFlag k := by + change W.pairing f.val.val ≠ _; rw [hpj] + exact fun h => hjk (W.boundaryFlag_injective h) + have rhs_ne_l : W.pairing g.val.val ≠ W.boundaryFlag l := by + change W.pairing f.val.val ≠ _; rw [hpj] + exact fun h => hjl (W.boundaryFlag_injective h) + have rhs_inner : (rewire hopen_kl g.val).val = W.boundaryFlag j := by + have h := @rewire_val_ne' _ W k l hopen_kl g.val rhs_ne_k rhs_ne_l + rw [h]; exact hpj + have rhs_ne_i : (rewire hopen_kl g.val).val ≠ W.boundaryFlag i := by + rw [rhs_inner]; exact fun h => hij.symm (W.boundaryFlag_injective h) + have rhs_outer_ne_i : Wkl.pairing g.val ≠ + Wkl.boundaryFlag ⟨i, hik, hil⟩ := fun h => + rhs_ne_i (congrArg Subtype.val h) + have rhs_outer_eq_j : Wkl.pairing g.val = + Wkl.boundaryFlag ⟨j, hjk, hjl⟩ := + Subtype.ext rhs_inner + have rhs_i_ne_k : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag k := fun h + => + hkl (W.boundaryFlag_injective (h.symm.trans hcross)) + have rhs_i_rewire : (rewire hopen_kl (glueBoundaryFlag W k l + ⟨i, hik, hil⟩)).val = W.pairing (W.boundaryFlag k) := + rewire_val_right' rhs_i_ne_k hcross + have rhs_val : (rewire hopen_kl_ij g).val.val = + W.pairing (W.boundaryFlag k) := by + have h := rewire_val_right' (hopen := hopen_kl_ij) rhs_outer_ne_i + rhs_outer_eq_j + exact congrArg Subtype.val h ▸ rhs_i_rewire + rw [lhs_val, rhs_val] + · -- Case: partner = bFk → both give W.pairing(bFj) + have lhs_inner : (rewire hopen_ij f.val).val = W.pairing f.val.val := + rewire_val_ne' hpi hpj + have lhs_inner_eq_k : (rewire hopen_ij f.val).val = W.boundaryFlag k := by + rw [lhs_inner, hpk] + have lhs_outer_eq_k : Wij.pairing f.val = + Wij.boundaryFlag ⟨k, hik.symm, hjk.symm⟩ := + Subtype.ext lhs_inner_eq_k + have lhs_l_rewire : (rewire hopen_ij (glueBoundaryFlag W i j + ⟨l, hil.symm, hjl.symm⟩)).val = W.pairing (W.boundaryFlag j) := + rewire_val_left' hli + have lhs_val : (rewire hopen_ij_kl f).val.val = + W.pairing (W.boundaryFlag j) := by + have h := rewire_val_left' (hopen := hopen_ij_kl) lhs_outer_eq_k + exact congrArg Subtype.val h ▸ lhs_l_rewire + have rhs_eq_k : W.pairing g.val.val = W.boundaryFlag k := by + change W.pairing f.val.val = _; exact hpk + have rhs_inner : (rewire hopen_kl g.val).val = + W.pairing (W.boundaryFlag l) := + @rewire_val_left' _ W k l hopen_kl g.val rhs_eq_k + have rhs_inner_eq_i : (rewire hopen_kl g.val).val = W.boundaryFlag i := by + rw [rhs_inner, hli] + have rhs_outer_eq_i : Wkl.pairing g.val = + Wkl.boundaryFlag ⟨i, hik, hil⟩ := + Subtype.ext rhs_inner_eq_i + have rhs_j_rewire : (rewire hopen_kl (glueBoundaryFlag W k l + ⟨j, hjk, hjl⟩)).val = W.pairing (W.boundaryFlag j) := + rewire_val_ne' hfar_jk hfar_jl + have rhs_val : (rewire hopen_kl_ij g).val.val = + W.pairing (W.boundaryFlag j) := by + have h := rewire_val_left' (hopen := hopen_kl_ij) rhs_outer_eq_i + exact congrArg Subtype.val h ▸ rhs_j_rewire + rw [lhs_val, rhs_val] + · -- Case: none → both give W.pairing(f.val.val) + have lhs_inner : (rewire hopen_ij f.val).val = W.pairing f.val.val := + rewire_val_ne' hpi hpj + have lhs_ne_k : (rewire hopen_ij f.val).val ≠ W.boundaryFlag k := by + rw [lhs_inner]; exact hpk + have lhs_ne_l : (rewire hopen_ij f.val).val ≠ W.boundaryFlag l := by + rw [lhs_inner]; exact hpl + have lhs_outer_ne_k : Wij.pairing f.val ≠ + Wij.boundaryFlag ⟨k, hik.symm, hjk.symm⟩ := fun h => + lhs_ne_k (congrArg Subtype.val h) + have lhs_outer_ne_l : Wij.pairing f.val ≠ + Wij.boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := fun h => + lhs_ne_l (congrArg Subtype.val h) + have lhs_val : (rewire hopen_ij_kl f).val.val = W.pairing f.val.val := by + have h := rewire_val_ne' (hopen := hopen_ij_kl) lhs_outer_ne_k + lhs_outer_ne_l + exact congrArg Subtype.val h ▸ lhs_inner + have rhs_ne_k : W.pairing g.val.val ≠ W.boundaryFlag k := by + change W.pairing f.val.val ≠ _; exact hpk + have rhs_ne_l : W.pairing g.val.val ≠ W.boundaryFlag l := by + change W.pairing f.val.val ≠ _; exact hpl + have rhs_inner : (rewire hopen_kl g.val).val = W.pairing f.val.val := by + exact @rewire_val_ne' _ W k l hopen_kl g.val rhs_ne_k rhs_ne_l + have rhs_ne_i : (rewire hopen_kl g.val).val ≠ W.boundaryFlag i := by + rw [rhs_inner]; exact hpi + have rhs_ne_j : (rewire hopen_kl g.val).val ≠ W.boundaryFlag j := by + rw [rhs_inner]; exact hpj + have rhs_outer_ne_i : Wkl.pairing g.val ≠ + Wkl.boundaryFlag ⟨i, hik, hil⟩ := fun h => + rhs_ne_i (congrArg Subtype.val h) + have rhs_outer_ne_j : Wkl.pairing g.val ≠ + Wkl.boundaryFlag ⟨j, hjk, hjl⟩ := fun h => + rhs_ne_j (congrArg Subtype.val h) + have rhs_val : (rewire hopen_kl_ij g).val.val = W.pairing f.val.val := by + have h := rewire_val_ne' (hopen := hopen_kl_ij) rhs_outer_ne_i + rhs_outer_ne_j + exact congrArg Subtype.val h ▸ rhs_inner + rw [lhs_val, rhs_val] + circles_eq := rfl + +/-! ### Configuration (2): one cross-edge, variant {jk} -/ + +-- Second kl-glue is open after ij-glue (cross jk variant). +private theorem oneCross_jk_second_open_kl + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (_hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hcross : W.pairing (W.boundaryFlag j) = W.boundaryFlag k) + (hfar_il : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag l) : + (W.gluePairOpen i j hij hopen_ij).pairing + ((W.gluePairOpen i j hij hopen_ij).boundaryFlag ⟨k, hik.symm, hjk.symm⟩) ≠ + (W.gluePairOpen i j hij hopen_ij).boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := by + intro heq + have hkj : W.pairing (W.boundaryFlag k) = W.boundaryFlag j := + W.pairing_boundaryFlag_comm hcross + have hval : (rewire hopen_ij (glueBoundaryFlag W i j ⟨k, hik.symm, + hjk.symm⟩)).val = + W.pairing (W.boundaryFlag i) := rewire_val_right' + (fun h => hij.symm (W.boundaryFlag_injective (hkj ▸ h))) hkj + exact hfar_il (hval.symm ▸ congrArg Subtype.val heq) + +-- Second ij-glue is open after kl-glue (cross jk variant). +private theorem oneCross_jk_second_open_ij + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hcross : W.pairing (W.boundaryFlag j) = W.boundaryFlag k) + (hfar_il : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag l) : + (W.gluePairOpen k l hkl hopen_kl).pairing + ((W.gluePairOpen k l hkl hopen_kl).boundaryFlag ⟨i, hik, hil⟩) ≠ + (W.gluePairOpen k l hkl hopen_kl).boundaryFlag ⟨j, hjk, hjl⟩ := by + intro heq + have h_ne_k : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag k := fun h => + hij (W.boundaryFlag_injective ((W.pairing_boundaryFlag_comm h).symm.trans + (W.pairing_boundaryFlag_comm hcross))) + have h_ne_l : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag l := hfar_il + have hval : (rewire hopen_kl (glueBoundaryFlag W k l ⟨i, hik, hil⟩)).val = + W.pairing (W.boundaryFlag i) := rewire_val_ne' h_ne_k h_ne_l + have hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j := fun h => + hik (W.boundaryFlag_injective ((W.pairing_boundaryFlag_comm h).symm.trans + hcross)) + exact hopen_ij (hval.symm ▸ congrArg Subtype.val heq) + +/-- Configuration (2), variant {jk}: one cross-edge `W.pairing(bFj) = bFk`. +Both glues are open in both orders; circles = `W.circles`. -/ +def oneCrossJkEquiv [DecidableEq α] + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hcross : W.pairing (W.boundaryFlag j) = W.boundaryFlag k) + (hfar_il : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag l) : + ((W.gluePairOpen i j hij hopen_ij).gluePairOpen + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (fun h => hkl (congrArg Subtype.val h)) + (by exact (oneCross_jk_second_open_kl W hij hkl hik hil hjk hjl + hopen_ij hcross hfar_il))).Equiv + (((W.gluePairOpen k l hkl hopen_kl).gluePairOpen + ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ + (fun h => hij (congrArg Subtype.val h)) + (by exact (oneCross_jk_second_open_ij W hij hkl hik hil hjk hjl + hopen_kl hcross hfar_il))).relabel + (swapLabelEquiv hik hil hjk hjl).symm) where + flagEquiv := by exact doubleSurvivingSwap W hik hil hjk hjl + vertexEquiv := _root_.Equiv.refl W.Vertex + attach_comm f := by + exact doubleGlueAttach_comm W hik hil hjk hjl f + pairing_comm f := by + apply Subtype.ext; apply Subtype.ext + -- ═══════ THE ATTACHMENT AND FLAG SIDES ARE SHARED ═══════ + -- Only the pairing distinguishes this configuration, so what + -- follows is the five-way case analysis on the partner of the + -- flag, at the cross-edge this configuration carries. + -- Name the two single glues; every transport below is + -- read at one of them. + let Wij := W.gluePairOpen i j hij hopen_ij + let Wkl := W.gluePairOpen k l hkl hopen_kl + let g := doubleSurvivingSwap W hik hil hjk hjl f + change (rewire (oneCross_jk_second_open_kl W hij hkl hik hil hjk hjl + hopen_ij hcross hfar_il) f).val.val = + (rewire (oneCross_jk_second_open_ij W hij hkl hik hil hjk hjl + hopen_kl hcross hfar_il) g).val.val + have hkj : W.pairing (W.boundaryFlag k) = W.boundaryFlag j := + W.pairing_boundaryFlag_comm hcross + have hfar_li : W.pairing (W.boundaryFlag l) ≠ W.boundaryFlag i := fun h => + hfar_il (W.pairing_boundaryFlag_comm h) + have hfar_lj : W.pairing (W.boundaryFlag l) ≠ W.boundaryFlag j := fun h => + hkl.symm (W.boundaryFlag_injective ((W.pairing_boundaryFlag_comm + h).symm.trans hcross)) + have hfar_ik : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag k := fun h => + hij (W.boundaryFlag_injective ((W.pairing_boundaryFlag_comm h).symm.trans + hkj)) + let hopen_ij_kl := oneCross_jk_second_open_kl W hij hkl hik hil hjk hjl + hopen_ij hcross hfar_il + let hopen_kl_ij := oneCross_jk_second_open_ij W hij hkl hik hil hjk hjl + hopen_kl hcross hfar_il + rcases partner_cases W f.val.val j k i l with + hpj | ⟨hpj, hpk⟩ | ⟨hpj, hpk, hpi⟩ | ⟨hpj, hpk, hpi, hpl⟩ | + ⟨hpj, hpk, hpi, hpl⟩ + · -- Impossible: f.val.val = bFk + have hfk : f.val.val = W.boundaryFlag k := by + have h := congrArg W.pairing hpj + rw [W.pairing_invol] at h + exact h.trans hcross + exact absurd (Subtype.ext hfk) f.prop.1 + · -- Impossible: f.val.val = bFj + have hfj : f.val.val = W.boundaryFlag j := by + have h := congrArg W.pairing hpk + rw [W.pairing_invol] at h + exact h.trans hkj + exact absurd hfj f.val.prop.2 + · -- Case: partner = bFi → both give W.pairing(bFl) + have lhs_inner : (rewire hopen_ij f.val).val = + W.pairing (W.boundaryFlag j) := + rewire_val_left' hpi + have lhs_inner_eq_k : (rewire hopen_ij f.val).val = W.boundaryFlag k := by + rw [lhs_inner, hcross] + have lhs_outer_eq_k : Wij.pairing f.val = + Wij.boundaryFlag ⟨k, hik.symm, hjk.symm⟩ := + Subtype.ext lhs_inner_eq_k + have lhs_l_rewire : (rewire hopen_ij (glueBoundaryFlag W i j + ⟨l, hil.symm, hjl.symm⟩)).val = W.pairing (W.boundaryFlag l) := + rewire_val_ne' hfar_li hfar_lj + have lhs_val : (rewire hopen_ij_kl f).val.val = + W.pairing (W.boundaryFlag l) := by + have h := rewire_val_left' (hopen := hopen_ij_kl) lhs_outer_eq_k + exact congrArg Subtype.val h ▸ lhs_l_rewire + have rhs_ne_k : W.pairing g.val.val ≠ W.boundaryFlag k := by + change W.pairing f.val.val ≠ _; rw [hpi] + exact fun h => hik (W.boundaryFlag_injective h) + have rhs_ne_l : W.pairing g.val.val ≠ W.boundaryFlag l := by + change W.pairing f.val.val ≠ _; rw [hpi] + exact fun h => hil (W.boundaryFlag_injective h) + have rhs_inner : (rewire hopen_kl g.val).val = W.boundaryFlag i := by + have h := @rewire_val_ne' _ W k l hopen_kl g.val rhs_ne_k rhs_ne_l + rw [h]; exact hpi + have rhs_outer_eq_i : Wkl.pairing g.val = + Wkl.boundaryFlag ⟨i, hik, hil⟩ := + Subtype.ext rhs_inner + have rhs_j_rewire : (rewire hopen_kl (glueBoundaryFlag W k l + ⟨j, hjk, hjl⟩)).val = W.pairing (W.boundaryFlag l) := + rewire_val_left' hcross + have rhs_val : (rewire hopen_kl_ij g).val.val = + W.pairing (W.boundaryFlag l) := by + have h := rewire_val_left' (hopen := hopen_kl_ij) rhs_outer_eq_i + exact congrArg Subtype.val h ▸ rhs_j_rewire + rw [lhs_val, rhs_val] + · -- Case: partner = bFl → both give W.pairing(bFi) + have lhs_inner : (rewire hopen_ij f.val).val = W.pairing f.val.val := + rewire_val_ne' hpi hpj + have lhs_inner_eq_l : (rewire hopen_ij f.val).val = W.boundaryFlag l := by + rw [lhs_inner, hpl] + have lhs_ne_k : (rewire hopen_ij f.val).val ≠ W.boundaryFlag k := by + rw [lhs_inner_eq_l] + exact fun h => hkl.symm (W.boundaryFlag_injective h) + have lhs_outer_ne_k : Wij.pairing f.val ≠ + Wij.boundaryFlag ⟨k, hik.symm, hjk.symm⟩ := fun h => + lhs_ne_k (congrArg Subtype.val h) + have lhs_outer_eq_l : Wij.pairing f.val = + Wij.boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := + Subtype.ext lhs_inner_eq_l + have lhs_k_rewire : (rewire hopen_ij (glueBoundaryFlag W i j + ⟨k, hik.symm, hjk.symm⟩)).val = W.pairing (W.boundaryFlag i) := + rewire_val_right' (fun h => hij.symm (W.boundaryFlag_injective (hkj ▸ + h))) hkj + have lhs_val : (rewire hopen_ij_kl f).val.val = + W.pairing (W.boundaryFlag i) := by + have h := rewire_val_right' (hopen := hopen_ij_kl) lhs_outer_ne_k + lhs_outer_eq_l + exact congrArg Subtype.val h ▸ lhs_k_rewire + have rhs_ne_k : W.pairing g.val.val ≠ W.boundaryFlag k := by + change W.pairing f.val.val ≠ _; exact hpk + have rhs_eq_l : W.pairing g.val.val = W.boundaryFlag l := by + change W.pairing f.val.val = _; exact hpl + have rhs_inner : (rewire hopen_kl g.val).val = + W.pairing (W.boundaryFlag k) := + @rewire_val_right' _ W k l hopen_kl g.val rhs_ne_k rhs_eq_l + have rhs_inner_eq_j : (rewire hopen_kl g.val).val = W.boundaryFlag j := by + rw [rhs_inner, hkj] + have rhs_ne_i : (rewire hopen_kl g.val).val ≠ W.boundaryFlag i := by + rw [rhs_inner_eq_j] + exact fun h => hij.symm (W.boundaryFlag_injective h) + have rhs_outer_ne_i : Wkl.pairing g.val ≠ + Wkl.boundaryFlag ⟨i, hik, hil⟩ := fun h => + rhs_ne_i (congrArg Subtype.val h) + have rhs_outer_eq_j : Wkl.pairing g.val = + Wkl.boundaryFlag ⟨j, hjk, hjl⟩ := + Subtype.ext rhs_inner_eq_j + have rhs_i_rewire : (rewire hopen_kl (glueBoundaryFlag W k l + ⟨i, hik, hil⟩)).val = W.pairing (W.boundaryFlag i) := + rewire_val_ne' hfar_ik hfar_il + have rhs_val : (rewire hopen_kl_ij g).val.val = + W.pairing (W.boundaryFlag i) := by + have h := rewire_val_right' (hopen := hopen_kl_ij) rhs_outer_ne_i + rhs_outer_eq_j + exact congrArg Subtype.val h ▸ rhs_i_rewire + rw [lhs_val, rhs_val] + · -- Case: none → both give W.pairing(f.val.val) + have lhs_inner : (rewire hopen_ij f.val).val = W.pairing f.val.val := + rewire_val_ne' hpi hpj + have lhs_ne_k : (rewire hopen_ij f.val).val ≠ W.boundaryFlag k := by + rw [lhs_inner]; exact hpk + have lhs_ne_l : (rewire hopen_ij f.val).val ≠ W.boundaryFlag l := by + rw [lhs_inner]; exact hpl + have lhs_outer_ne_k : Wij.pairing f.val ≠ + Wij.boundaryFlag ⟨k, hik.symm, hjk.symm⟩ := fun h => + lhs_ne_k (congrArg Subtype.val h) + have lhs_outer_ne_l : Wij.pairing f.val ≠ + Wij.boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := fun h => + lhs_ne_l (congrArg Subtype.val h) + have lhs_val : (rewire hopen_ij_kl f).val.val = W.pairing f.val.val := by + have h := rewire_val_ne' (hopen := hopen_ij_kl) lhs_outer_ne_k + lhs_outer_ne_l + exact congrArg Subtype.val h ▸ lhs_inner + have rhs_ne_k : W.pairing g.val.val ≠ W.boundaryFlag k := by + change W.pairing f.val.val ≠ _; exact hpk + have rhs_ne_l : W.pairing g.val.val ≠ W.boundaryFlag l := by + change W.pairing f.val.val ≠ _; exact hpl + have rhs_inner : (rewire hopen_kl g.val).val = W.pairing f.val.val := by + exact @rewire_val_ne' _ W k l hopen_kl g.val rhs_ne_k rhs_ne_l + have rhs_ne_i : (rewire hopen_kl g.val).val ≠ W.boundaryFlag i := by + rw [rhs_inner]; exact hpi + have rhs_ne_j : (rewire hopen_kl g.val).val ≠ W.boundaryFlag j := by + rw [rhs_inner]; exact hpj + have rhs_outer_ne_i : Wkl.pairing g.val ≠ + Wkl.boundaryFlag ⟨i, hik, hil⟩ := fun h => + rhs_ne_i (congrArg Subtype.val h) + have rhs_outer_ne_j : Wkl.pairing g.val ≠ + Wkl.boundaryFlag ⟨j, hjk, hjl⟩ := fun h => + rhs_ne_j (congrArg Subtype.val h) + have rhs_val : (rewire hopen_kl_ij g).val.val = W.pairing f.val.val := by + have h := rewire_val_ne' (hopen := hopen_kl_ij) rhs_outer_ne_i + rhs_outer_ne_j + exact congrArg Subtype.val h ▸ rhs_inner + rw [lhs_val, rhs_val] + circles_eq := rfl + +/-! ### Configuration (2): one cross-edge, variant {jl} -/ + +-- Second kl-glue is open after ij-glue (cross jl variant). +private theorem oneCross_jl_second_open_kl + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hcross : W.pairing (W.boundaryFlag j) = W.boundaryFlag l) + (hfar_ik : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag k) : + (W.gluePairOpen i j hij hopen_ij).pairing + ((W.gluePairOpen i j hij hopen_ij).boundaryFlag ⟨k, hik.symm, hjk.symm⟩) ≠ + (W.gluePairOpen i j hij hopen_ij).boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := by + intro heq + have h_ne_i : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag i := fun h => + hfar_ik (W.pairing_boundaryFlag_comm h) + have h_ne_j : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag j := fun h => + hkl (W.boundaryFlag_injective ((W.pairing_boundaryFlag_comm h).symm.trans + hcross)) + have hval : (rewire hopen_ij (glueBoundaryFlag W i j ⟨k, hik.symm, + hjk.symm⟩)).val = + W.pairing (W.boundaryFlag k) := rewire_val_ne' h_ne_i h_ne_j + exact hopen_kl (hval.symm ▸ congrArg Subtype.val heq) + +-- Second ij-glue is open after kl-glue (cross jl variant). +private theorem oneCross_jl_second_open_ij + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (_hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hcross : W.pairing (W.boundaryFlag j) = W.boundaryFlag l) + (hfar_ik : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag k) : + (W.gluePairOpen k l hkl hopen_kl).pairing + ((W.gluePairOpen k l hkl hopen_kl).boundaryFlag ⟨i, hik, hil⟩) ≠ + (W.gluePairOpen k l hkl hopen_kl).boundaryFlag ⟨j, hjk, hjl⟩ := by + intro heq + have h_ne_k : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag k := hfar_ik + have h_ne_l : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag l := fun h => + hij (W.boundaryFlag_injective + ((W.pairing_boundaryFlag_comm h).symm.trans (W.pairing_boundaryFlag_comm + hcross))) + have hval : (rewire hopen_kl (glueBoundaryFlag W k l ⟨i, hik, hil⟩)).val = + W.pairing (W.boundaryFlag i) := rewire_val_ne' h_ne_k h_ne_l + have hopen_ij' : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j := fun h => + hil (W.boundaryFlag_injective ((W.pairing_boundaryFlag_comm h).symm.trans + hcross)) + exact hopen_ij' (hval.symm ▸ congrArg Subtype.val heq) + +private theorem oneCross_jl_equiv_pairing_comm + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hcross : W.pairing (W.boundaryFlag j) = W.boundaryFlag l) + (hfar_ik : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag k) + (f : (((W.gluePairOpen i j hij hopen_ij).gluePairOpen + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (fun h => hkl (congrArg Subtype.val h)) + (oneCross_jl_second_open_kl W hij hkl hik hil hjk hjl + hopen_ij hopen_kl hcross hfar_ik))).Flag) : + doubleSurvivingSwap W hik hil hjk hjl ((((W.gluePairOpen i j hij hopen_ij).gluePairOpen + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (fun h => hkl (congrArg Subtype.val h)) + (oneCross_jl_second_open_kl W hij hkl hik hil hjk hjl + hopen_ij hopen_kl hcross hfar_ik))).pairing f) = + ((((W.gluePairOpen k l hkl hopen_kl).gluePairOpen + ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ + (fun h => hij (congrArg Subtype.val h)) + (oneCross_jl_second_open_ij W hij hkl hik hil hjk hjl + hopen_ij hopen_kl hcross hfar_ik)).relabel + (swapLabelEquiv hik hil hjk hjl).symm)).pairing (doubleSurvivingSwap W hik hil hjk + hjl f) := by + classical + apply Subtype.ext; apply Subtype.ext + -- ═══════ THE ATTACHMENT AND FLAG SIDES ARE SHARED ═══════ + -- Only the pairing distinguishes this configuration, so what + -- follows is the five-way case analysis on the partner of the + -- flag, at the cross-edge this configuration carries. + -- Name the two single glues; every transport below is + -- read at one of them. + let Wij := W.gluePairOpen i j hij hopen_ij + let Wkl := W.gluePairOpen k l hkl hopen_kl + let g := doubleSurvivingSwap W hik hil hjk hjl f + change (rewire (oneCross_jl_second_open_kl W hij hkl hik hil hjk hjl + hopen_ij hopen_kl hcross hfar_ik) f).val.val = + (rewire (oneCross_jl_second_open_ij W hij hkl hik hil hjk hjl + hopen_ij hopen_kl hcross hfar_ik) g).val.val + have hlj : W.pairing (W.boundaryFlag l) = W.boundaryFlag j := + W.pairing_boundaryFlag_comm hcross + have hfar_ki : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag i := fun h => + hfar_ik (W.pairing_boundaryFlag_comm h) + have hfar_kj : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag j := fun h => + hkl (W.boundaryFlag_injective ((W.pairing_boundaryFlag_comm h).symm.trans + hcross)) + have hfar_il : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag l := fun h => + hij (W.boundaryFlag_injective ((W.pairing_boundaryFlag_comm h).symm.trans + hlj)) + let hopen_ij_kl := oneCross_jl_second_open_kl W hij hkl hik hil hjk hjl + hopen_ij hopen_kl hcross hfar_ik + let hopen_kl_ij := oneCross_jl_second_open_ij W hij hkl hik hil hjk hjl + hopen_ij hopen_kl hcross hfar_ik + rcases partner_cases W f.val.val j l i k with + hpj | ⟨hpj, hpl⟩ | ⟨hpj, hpl, hpi⟩ | ⟨hpj, hpl, hpi, hpk⟩ | + ⟨hpj, hpl, hpi, hpk⟩ + · -- Impossible: f.val.val = bFl + have hfl : f.val.val = W.boundaryFlag l := by + have h := congrArg W.pairing hpj + rw [W.pairing_invol] at h + exact h.trans hcross + exact absurd (Subtype.ext hfl) f.prop.2 + · -- Impossible: f.val.val = bFj + have hfj : f.val.val = W.boundaryFlag j := by + have h := congrArg W.pairing hpl + rw [W.pairing_invol] at h + exact h.trans hlj + exact absurd hfj f.val.prop.2 + · -- Case: partner = bFi → both give W.pairing(bFk) + have lhs_inner : (rewire hopen_ij f.val).val = + W.pairing (W.boundaryFlag j) := + rewire_val_left' hpi + have lhs_inner_eq_l : (rewire hopen_ij f.val).val = W.boundaryFlag l := by + rw [lhs_inner, hcross] + have lhs_ne_k : (rewire hopen_ij f.val).val ≠ W.boundaryFlag k := by + rw [lhs_inner_eq_l] + exact fun h => hkl.symm (W.boundaryFlag_injective h) + have lhs_outer_ne_k : Wij.pairing f.val ≠ + Wij.boundaryFlag ⟨k, hik.symm, hjk.symm⟩ := fun h => + lhs_ne_k (congrArg Subtype.val h) + have lhs_outer_eq_l : Wij.pairing f.val = + Wij.boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := + Subtype.ext lhs_inner_eq_l + have lhs_k_rewire : (rewire hopen_ij (glueBoundaryFlag W i j + ⟨k, hik.symm, hjk.symm⟩)).val = W.pairing (W.boundaryFlag k) := + rewire_val_ne' hfar_ki hfar_kj + have lhs_val : (rewire hopen_ij_kl f).val.val = + W.pairing (W.boundaryFlag k) := by + have h := rewire_val_right' (hopen := hopen_ij_kl) lhs_outer_ne_k + lhs_outer_eq_l + exact congrArg Subtype.val h ▸ lhs_k_rewire + have rhs_ne_k : W.pairing g.val.val ≠ W.boundaryFlag k := by + change W.pairing f.val.val ≠ _; rw [hpi] + exact fun h => hik (W.boundaryFlag_injective h) + have rhs_ne_l : W.pairing g.val.val ≠ W.boundaryFlag l := by + change W.pairing f.val.val ≠ _; rw [hpi] + exact fun h => hil (W.boundaryFlag_injective h) + have rhs_inner : (rewire hopen_kl g.val).val = W.boundaryFlag i := by + have h := @rewire_val_ne' _ W k l hopen_kl g.val rhs_ne_k rhs_ne_l + rw [h]; exact hpi + have rhs_outer_eq_i : Wkl.pairing g.val = + Wkl.boundaryFlag ⟨i, hik, hil⟩ := + Subtype.ext rhs_inner + have rhs_j_ne_k : W.pairing (W.boundaryFlag j) ≠ W.boundaryFlag k := fun h + => + hkl (W.boundaryFlag_injective (h.symm.trans hcross)) + have rhs_j_rewire : (rewire hopen_kl (glueBoundaryFlag W k l + ⟨j, hjk, hjl⟩)).val = W.pairing (W.boundaryFlag k) := + rewire_val_right' rhs_j_ne_k hcross + have rhs_val : (rewire hopen_kl_ij g).val.val = + W.pairing (W.boundaryFlag k) := by + have h := rewire_val_left' (hopen := hopen_kl_ij) rhs_outer_eq_i + exact congrArg Subtype.val h ▸ rhs_j_rewire + rw [lhs_val, rhs_val] + · -- Case: partner = bFk → both give W.pairing(bFi) + have lhs_inner : (rewire hopen_ij f.val).val = W.pairing f.val.val := + rewire_val_ne' hpi hpj + have lhs_inner_eq_k : (rewire hopen_ij f.val).val = W.boundaryFlag k := by + rw [lhs_inner, hpk] + have lhs_outer_eq_k : Wij.pairing f.val = + Wij.boundaryFlag ⟨k, hik.symm, hjk.symm⟩ := + Subtype.ext lhs_inner_eq_k + have lhs_l_ne_i : W.pairing (W.boundaryFlag l) ≠ W.boundaryFlag i := fun h + => + hfar_il (W.pairing_boundaryFlag_comm h) + have lhs_l_rewire : (rewire hopen_ij (glueBoundaryFlag W i j + ⟨l, hil.symm, hjl.symm⟩)).val = W.pairing (W.boundaryFlag i) := + rewire_val_right' lhs_l_ne_i hlj + have lhs_val : (rewire hopen_ij_kl f).val.val = + W.pairing (W.boundaryFlag i) := by + have h := rewire_val_left' (hopen := hopen_ij_kl) lhs_outer_eq_k + exact congrArg Subtype.val h ▸ lhs_l_rewire + have rhs_eq_k : W.pairing g.val.val = W.boundaryFlag k := by + change W.pairing f.val.val = _; exact hpk + have rhs_inner : (rewire hopen_kl g.val).val = + W.pairing (W.boundaryFlag l) := + @rewire_val_left' _ W k l hopen_kl g.val rhs_eq_k + have rhs_inner_eq_j : (rewire hopen_kl g.val).val = W.boundaryFlag j := by + rw [rhs_inner, hlj] + have rhs_ne_i : (rewire hopen_kl g.val).val ≠ W.boundaryFlag i := by + rw [rhs_inner_eq_j] + exact fun h => hij.symm (W.boundaryFlag_injective h) + have rhs_outer_ne_i : Wkl.pairing g.val ≠ + Wkl.boundaryFlag ⟨i, hik, hil⟩ := fun h => + rhs_ne_i (congrArg Subtype.val h) + have rhs_outer_eq_j : Wkl.pairing g.val = + Wkl.boundaryFlag ⟨j, hjk, hjl⟩ := + Subtype.ext rhs_inner_eq_j + have rhs_i_rewire : (rewire hopen_kl (glueBoundaryFlag W k l + ⟨i, hik, hil⟩)).val = W.pairing (W.boundaryFlag i) := + rewire_val_ne' hfar_ik hfar_il + have rhs_val : (rewire hopen_kl_ij g).val.val = + W.pairing (W.boundaryFlag i) := by + have h := rewire_val_right' (hopen := hopen_kl_ij) rhs_outer_ne_i + rhs_outer_eq_j + exact congrArg Subtype.val h ▸ rhs_i_rewire + rw [lhs_val, rhs_val] + · -- Case: none → both give W.pairing(f.val.val) + have lhs_inner : (rewire hopen_ij f.val).val = W.pairing f.val.val := + rewire_val_ne' hpi hpj + have lhs_ne_k : (rewire hopen_ij f.val).val ≠ W.boundaryFlag k := by + rw [lhs_inner]; exact hpk + have lhs_ne_l : (rewire hopen_ij f.val).val ≠ W.boundaryFlag l := by + rw [lhs_inner]; exact hpl + have lhs_outer_ne_k : Wij.pairing f.val ≠ + Wij.boundaryFlag ⟨k, hik.symm, hjk.symm⟩ := fun h => + lhs_ne_k (congrArg Subtype.val h) + have lhs_outer_ne_l : Wij.pairing f.val ≠ + Wij.boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := fun h => + lhs_ne_l (congrArg Subtype.val h) + have lhs_val : (rewire hopen_ij_kl f).val.val = W.pairing f.val.val := by + have h := rewire_val_ne' (hopen := hopen_ij_kl) lhs_outer_ne_k + lhs_outer_ne_l + exact congrArg Subtype.val h ▸ lhs_inner + have rhs_ne_k : W.pairing g.val.val ≠ W.boundaryFlag k := by + change W.pairing f.val.val ≠ _; exact hpk + have rhs_ne_l : W.pairing g.val.val ≠ W.boundaryFlag l := by + change W.pairing f.val.val ≠ _; exact hpl + have rhs_inner : (rewire hopen_kl g.val).val = W.pairing f.val.val := by + exact @rewire_val_ne' _ W k l hopen_kl g.val rhs_ne_k rhs_ne_l + have rhs_ne_i : (rewire hopen_kl g.val).val ≠ W.boundaryFlag i := by + rw [rhs_inner]; exact hpi + have rhs_ne_j : (rewire hopen_kl g.val).val ≠ W.boundaryFlag j := by + rw [rhs_inner]; exact hpj + have rhs_outer_ne_i : Wkl.pairing g.val ≠ + Wkl.boundaryFlag ⟨i, hik, hil⟩ := fun h => + rhs_ne_i (congrArg Subtype.val h) + have rhs_outer_ne_j : Wkl.pairing g.val ≠ + Wkl.boundaryFlag ⟨j, hjk, hjl⟩ := fun h => + rhs_ne_j (congrArg Subtype.val h) + have rhs_val : (rewire hopen_kl_ij g).val.val = W.pairing f.val.val := by + have h := rewire_val_ne' (hopen := hopen_kl_ij) rhs_outer_ne_i + rhs_outer_ne_j + exact congrArg Subtype.val h ▸ rhs_inner + rw [lhs_val, rhs_val] + +private theorem oneCross_jl_equiv_attach_comm + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hcross : W.pairing (W.boundaryFlag j) = W.boundaryFlag l) + (hfar_ik : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag k) + (f : (((W.gluePairOpen i j hij hopen_ij).gluePairOpen + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (fun h => hkl (congrArg Subtype.val h)) + (oneCross_jl_second_open_kl W hij hkl hik hil hjk hjl + hopen_ij hopen_kl hcross hfar_ik))).Flag) : + ((((W.gluePairOpen k l hkl hopen_kl).gluePairOpen + ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ + (fun h => hij (congrArg Subtype.val h)) + (oneCross_jl_second_open_ij W hij hkl hik hil hjk hjl + hopen_ij hopen_kl hcross hfar_ik)).relabel + (swapLabelEquiv hik hil hjk hjl).symm)).attach (doubleSurvivingSwap W hik hil hjk hjl f) = + ((((W.gluePairOpen i j hij hopen_ij).gluePairOpen + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (fun h => hkl (congrArg Subtype.val h)) + (oneCross_jl_second_open_kl W hij hkl hik hil hjk hjl + hopen_ij hopen_kl hcross hfar_ik))).attach f).map (_root_.Equiv.refl W.Vertex) id := by + classical + exact doubleGlueAttach_comm W hik hil hjk hjl f + +/-- Configuration (2), variant {jl}: one cross-edge `W.pairing(bFj) = bFl`. +Both glues are open in both orders; circles = `W.circles`. -/ +def oneCrossJlEquiv [DecidableEq α] + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hcross : W.pairing (W.boundaryFlag j) = W.boundaryFlag l) + (hfar_ik : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag k) : + ((W.gluePairOpen i j hij hopen_ij).gluePairOpen + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (fun h => hkl (congrArg Subtype.val h)) + (by exact (oneCross_jl_second_open_kl W hij hkl hik hil hjk hjl + hopen_ij hopen_kl hcross hfar_ik))).Equiv + (((W.gluePairOpen k l hkl hopen_kl).gluePairOpen + ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ + (fun h => hij (congrArg Subtype.val h)) + (by exact (oneCross_jl_second_open_ij W hij hkl hik hil hjk hjl + hopen_ij hopen_kl hcross hfar_ik))).relabel + (swapLabelEquiv hik hil hjk hjl).symm) where + flagEquiv := by exact doubleSurvivingSwap W hik hil hjk hjl + vertexEquiv := _root_.Equiv.refl W.Vertex + attach_comm := by + exact oneCross_jl_equiv_attach_comm W hij hkl hik hil hjk hjl hopen_ij hopen_kl + hcross hfar_ik + pairing_comm := by + exact oneCross_jl_equiv_pairing_comm W hij hkl hik hil hjk hjl hopen_ij + hopen_kl hcross hfar_ik + circles_eq := rfl + +/-! ### Configuration (3): two cross-edges (open then closed) -/ + +-- Second kl-glue is CLOSED after ij-glue (two crosses, ik+jl variant). +private theorem twoCross_ikjl_second_closed_kl + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (_hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hcross_ik : W.pairing (W.boundaryFlag i) = W.boundaryFlag k) + (hcross_jl : W.pairing (W.boundaryFlag j) = W.boundaryFlag l) : + (W.gluePairOpen i j hij hopen_ij).pairing + ((W.gluePairOpen i j hij hopen_ij).boundaryFlag ⟨k, hik.symm, hjk.symm⟩) = + (W.gluePairOpen i j hij hopen_ij).boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := by + apply Subtype.ext + have hki : W.pairing (W.boundaryFlag k) = W.boundaryFlag i := + W.pairing_boundaryFlag_comm hcross_ik + have hval : (rewire hopen_ij (glueBoundaryFlag W i j ⟨k, hik.symm, + hjk.symm⟩)).val = + W.pairing (W.boundaryFlag j) := rewire_val_left' hki + exact hval.trans hcross_jl + +-- Second ij-glue is CLOSED after kl-glue (two crosses, ik+jl variant). +private theorem twoCross_ikjl_second_closed_ij + (W : Fragment α) {i j k l : α} + (_hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hcross_ik : W.pairing (W.boundaryFlag i) = W.boundaryFlag k) + (hcross_jl : W.pairing (W.boundaryFlag j) = W.boundaryFlag l) : + (W.gluePairOpen k l hkl hopen_kl).pairing + ((W.gluePairOpen k l hkl hopen_kl).boundaryFlag ⟨i, hik, hil⟩) = + (W.gluePairOpen k l hkl hopen_kl).boundaryFlag ⟨j, hjk, hjl⟩ := by + apply Subtype.ext + have hlj : W.pairing (W.boundaryFlag l) = W.boundaryFlag j := + W.pairing_boundaryFlag_comm hcross_jl + have hval : (rewire hopen_kl (glueBoundaryFlag W k l ⟨i, hik, hil⟩)).val = + W.pairing (W.boundaryFlag l) := rewire_val_left' hcross_ik + exact hval.trans hlj + +/-- Configuration (3), variant {ik,jl}: two cross-edges. +First glue is open, second is closed; circles = `W.circles + 1`. -/ +def twoCrossIkjlEquiv [DecidableEq α] + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hcross_ik : W.pairing (W.boundaryFlag i) = W.boundaryFlag k) + (hcross_jl : W.pairing (W.boundaryFlag j) = W.boundaryFlag l) : + ((W.gluePairOpen i j hij hopen_ij).gluePairClosed + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (by exact (twoCross_ikjl_second_closed_kl W hij hkl hik hil hjk hjl + hopen_ij hcross_ik hcross_jl))).Equiv + (((W.gluePairOpen k l hkl hopen_kl).gluePairClosed + ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ + (by exact (twoCross_ikjl_second_closed_ij W hij hkl hik hil hjk hjl + hopen_kl hcross_ik hcross_jl))).relabel + (swapLabelEquiv hik hil hjk hjl).symm) where + flagEquiv := by exact doubleSurvivingSwap W hik hil hjk hjl + vertexEquiv := _root_.Equiv.refl W.Vertex + attach_comm f := by + exact doubleGlueAttach_comm W hik hil hjk hjl f + pairing_comm f := by + apply Subtype.ext; apply Subtype.ext + change (rewire hopen_ij f.val).val = (rewire hopen_kl + (doubleSurvivingSwap W hik hil hjk hjl f).val).val + have hki : W.pairing (W.boundaryFlag k) = W.boundaryFlag i := + W.pairing_boundaryFlag_comm hcross_ik + have hlj : W.pairing (W.boundaryFlag l) = W.boundaryFlag j := + W.pairing_boundaryFlag_comm hcross_jl + have hpi : W.pairing f.val.val ≠ W.boundaryFlag i := fun h => + (fun hfk : f.val.val = W.boundaryFlag k => f.prop.1 (Subtype.ext hfk)) + (by have := congrArg W.pairing h; rw [W.pairing_invol] at this; exact + this.trans hcross_ik) + have hpj : W.pairing f.val.val ≠ W.boundaryFlag j := fun h => + (fun hfl : f.val.val = W.boundaryFlag l => f.prop.2 (Subtype.ext hfl)) + (by have := congrArg W.pairing h; rw [W.pairing_invol] at this; exact + this.trans hcross_jl) + have hpk : W.pairing f.val.val ≠ W.boundaryFlag k := fun h => + f.val.prop.1 (by + have := congrArg W.pairing h + rw [W.pairing_invol] at this + exact this.trans hki) + have hpl : W.pairing f.val.val ≠ W.boundaryFlag l := fun h => + f.val.prop.2 (by + have := congrArg W.pairing h + rw [W.pairing_invol] at this + exact this.trans hlj) + have lhs_val : (rewire hopen_ij f.val).val = W.pairing f.val.val := + rewire_val_ne' hpi hpj + have rhs_val : (rewire hopen_kl + (doubleSurvivingSwap W hik hil hjk hjl f).val).val = + W.pairing f.val.val := + @rewire_val_ne' _ W k l hopen_kl + (doubleSurvivingSwap W hik hil hjk hjl f).val hpk hpl + rw [lhs_val, rhs_val] + circles_eq := rfl + +-- Second kl-glue is CLOSED after ij-glue (two crosses, il+jk variant). +private theorem twoCross_iljk_second_closed_kl + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (_hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hcross_il : W.pairing (W.boundaryFlag i) = W.boundaryFlag l) + (hcross_jk : W.pairing (W.boundaryFlag j) = W.boundaryFlag k) : + (W.gluePairOpen i j hij hopen_ij).pairing + ((W.gluePairOpen i j hij hopen_ij).boundaryFlag ⟨k, hik.symm, hjk.symm⟩) = + (W.gluePairOpen i j hij hopen_ij).boundaryFlag ⟨l, hil.symm, hjl.symm⟩ := by + apply Subtype.ext + have hkj : W.pairing (W.boundaryFlag k) = W.boundaryFlag j := + W.pairing_boundaryFlag_comm hcross_jk + have hval : (rewire hopen_ij (glueBoundaryFlag W i j ⟨k, hik.symm, + hjk.symm⟩)).val = + W.pairing (W.boundaryFlag i) := + rewire_val_right' (fun h => hij.symm (W.boundaryFlag_injective (hkj ▸ h))) + hkj + exact hval.trans hcross_il + +-- Second ij-glue is CLOSED after kl-glue (two crosses, il+jk variant). +private theorem twoCross_iljk_second_closed_ij + (W : Fragment α) {i j k l : α} + (_hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hcross_il : W.pairing (W.boundaryFlag i) = W.boundaryFlag l) + (hcross_jk : W.pairing (W.boundaryFlag j) = W.boundaryFlag k) : + (W.gluePairOpen k l hkl hopen_kl).pairing + ((W.gluePairOpen k l hkl hopen_kl).boundaryFlag ⟨i, hik, hil⟩) = + (W.gluePairOpen k l hkl hopen_kl).boundaryFlag ⟨j, hjk, hjl⟩ := by + apply Subtype.ext + have hkj : W.pairing (W.boundaryFlag k) = W.boundaryFlag j := + W.pairing_boundaryFlag_comm hcross_jk + have h_ne_k : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag k := fun h => + hkl (W.boundaryFlag_injective (h.symm.trans hcross_il)) + have hval : (rewire hopen_kl (glueBoundaryFlag W k l ⟨i, hik, hil⟩)).val = + W.pairing (W.boundaryFlag k) := + rewire_val_right' h_ne_k hcross_il + exact hval.trans hkj + +/-- Configuration (3), variant {il,jk}: two cross-edges. +First glue is open, second is closed; circles = `W.circles + 1`. -/ +def twoCrossIljkEquiv [DecidableEq α] + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) + (hopen_ij : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (hopen_kl : W.pairing (W.boundaryFlag k) ≠ W.boundaryFlag l) + (hcross_il : W.pairing (W.boundaryFlag i) = W.boundaryFlag l) + (hcross_jk : W.pairing (W.boundaryFlag j) = W.boundaryFlag k) : + ((W.gluePairOpen i j hij hopen_ij).gluePairClosed + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (by exact (twoCross_iljk_second_closed_kl W hij hkl hik hil hjk hjl + hopen_ij hcross_il hcross_jk))).Equiv + (((W.gluePairOpen k l hkl hopen_kl).gluePairClosed + ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ + (by exact (twoCross_iljk_second_closed_ij W hij hkl hik hil hjk hjl + hopen_kl hcross_il hcross_jk))).relabel + (swapLabelEquiv hik hil hjk hjl).symm) where + flagEquiv := by exact doubleSurvivingSwap W hik hil hjk hjl + vertexEquiv := _root_.Equiv.refl W.Vertex + attach_comm f := by + exact doubleGlueAttach_comm W hik hil hjk hjl f + pairing_comm f := by + apply Subtype.ext; apply Subtype.ext + change (rewire hopen_ij f.val).val = (rewire hopen_kl + (doubleSurvivingSwap W hik hil hjk hjl f).val).val + have hli : W.pairing (W.boundaryFlag l) = W.boundaryFlag i := + W.pairing_boundaryFlag_comm hcross_il + have hkj : W.pairing (W.boundaryFlag k) = W.boundaryFlag j := + W.pairing_boundaryFlag_comm hcross_jk + have hpi : W.pairing f.val.val ≠ W.boundaryFlag i := fun h => + (fun hfl : f.val.val = W.boundaryFlag l => f.prop.2 (Subtype.ext hfl)) + (by have := congrArg W.pairing h; rw [W.pairing_invol] at this; exact + this.trans hcross_il) + have hpj : W.pairing f.val.val ≠ W.boundaryFlag j := fun h => + (fun hfk : f.val.val = W.boundaryFlag k => f.prop.1 (Subtype.ext hfk)) + (by have := congrArg W.pairing h; rw [W.pairing_invol] at this; exact + this.trans hcross_jk) + have hpk : W.pairing f.val.val ≠ W.boundaryFlag k := fun h => + f.val.prop.2 (by + have := congrArg W.pairing h + rw [W.pairing_invol] at this + exact this.trans hkj) + have hpl : W.pairing f.val.val ≠ W.boundaryFlag l := fun h => + f.val.prop.1 (by + have := congrArg W.pairing h + rw [W.pairing_invol] at this + exact this.trans hli) + have lhs_val : (rewire hopen_ij f.val).val = W.pairing f.val.val := + rewire_val_ne' hpi hpj + have rhs_val : (rewire hopen_kl + (doubleSurvivingSwap W hik hil hjk hjl f).val).val = + W.pairing f.val.val := + @rewire_val_ne' _ W k l hopen_kl + (doubleSurvivingSwap W hik hil hjk hjl f).val hpk hpl + rw [lhs_val, rhs_val] + circles_eq := rfl + +/-! ### Main dispatch: `gluePairComm` -/ + +/-- Two single-pair glues at disjoint label pairs commute up to +fragment equivalence. -/ +def gluePairComm [DecidableEq α] + (W : Fragment α) {i j k l : α} + (hij : i ≠ j) (hkl : k ≠ l) + (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) : + ((W.gluePair i j hij).gluePair + ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (fun h => hkl (congrArg Subtype.val h))).Equiv + (((W.gluePair k l hkl).gluePair + ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ + (fun h => hij (congrArg Subtype.val h))).relabel + (swapLabelEquiv hik hil hjk hjl).symm) := by + by_cases h_ij : W.pairing (W.boundaryFlag i) = W.boundaryFlag j + · -- {i,j} is a closed pair + rw [gluePair_eq_closed hij h_ij] + by_cases h_kl : W.pairing (W.boundaryFlag k) = W.boundaryFlag l + · -- Config (4): both closed + rw [gluePair_eq_closed hkl h_kl] + rw [gluePair_eq_closed _ (by exact (closedClosed_second_ij W hik hil hjk hjl h_ij + h_kl))] + rw [gluePair_eq_closed _ (by exact (closedClosed_second_kl W hik hil hjk hjl h_ij + h_kl))] + exact closedClosedEquiv W hij hkl hik hil hjk hjl h_ij h_kl + · -- Config (1): ij closed, kl open + rw [gluePair_eq_open hkl h_kl] + rw [gluePair_eq_open _ (by exact (closedOpen_second_open W hik hil hjk hjl h_ij + h_kl))] + rw [gluePair_eq_closed _ (by exact (closedOpen_second_closed W hkl hik hil hjk hjl + h_ij h_kl))] + exact closedOpenEquiv W hij hkl hik hil hjk hjl h_ij h_kl + · -- {i,j} is an open pair + rw [gluePair_eq_open hij h_ij] + by_cases h_kl : W.pairing (W.boundaryFlag k) = W.boundaryFlag l + · -- Config (1'): ij open, kl closed + rw [gluePair_eq_closed hkl h_kl] + rw [gluePair_eq_closed _ (by exact (openClosed_second_closed W hij hik hil hjk hjl + h_ij h_kl))] + rw [gluePair_eq_open _ (by exact (openClosed_second_open W hik hil hjk hjl h_ij + h_kl))] + exact openClosedEquiv W hij hkl hik hil hjk hjl h_ij h_kl + · -- Both open: dispatch on cross-edges + rw [gluePair_eq_open hkl h_kl] + by_cases hcross_ik : W.pairing (W.boundaryFlag i) = W.boundaryFlag k + · by_cases hcross_jl : W.pairing (W.boundaryFlag j) = W.boundaryFlag l + · -- Config (3): two crosses {ik, jl} + rw [gluePair_eq_closed _ (by exact (twoCross_ikjl_second_closed_kl W hij hkl hik + hil hjk hjl + h_ij hcross_ik hcross_jl))] + rw [gluePair_eq_closed _ (by exact (twoCross_ikjl_second_closed_ij W hij hkl hik + hil hjk hjl + h_kl hcross_ik hcross_jl))] + exact twoCrossIkjlEquiv W hij hkl hik hil hjk hjl h_ij h_kl + hcross_ik hcross_jl + · -- Config (2) variant {ik} + rw [gluePair_eq_open _ (by exact (oneCross_ik_second_open_kl W hij hkl hik hil + hjk hjl + h_ij hcross_ik hcross_jl))] + rw [gluePair_eq_open _ (by exact (oneCross_ik_second_open_ij W hij hkl hik hil + hjk hjl + h_kl hcross_ik hcross_jl))] + exact oneCrossIkEquiv W hij hkl hik hil hjk hjl h_ij h_kl + hcross_ik hcross_jl + · by_cases hcross_il : W.pairing (W.boundaryFlag i) = W.boundaryFlag l + · by_cases hcross_jk : W.pairing (W.boundaryFlag j) = W.boundaryFlag k + · -- Config (3): two crosses {il, jk} + rw [gluePair_eq_closed _ (by exact (twoCross_iljk_second_closed_kl W hij hkl + hik hil hjk hjl + h_ij hcross_il hcross_jk))] + rw [gluePair_eq_closed _ (by exact (twoCross_iljk_second_closed_ij W hij hkl + hik hil hjk hjl + h_kl hcross_il hcross_jk))] + exact twoCrossIljkEquiv W hij hkl hik hil hjk hjl h_ij h_kl + hcross_il hcross_jk + · -- Config (2) variant {il} + rw [gluePair_eq_open _ (by exact (oneCross_il_second_open_kl W hij hkl hik hil + hjk hjl + h_ij h_kl hcross_il hcross_jk))] + rw [gluePair_eq_open _ (by exact (oneCross_il_second_open_ij W hij hkl hik hil + hjk hjl + h_ij h_kl hcross_il hcross_jk))] + exact oneCrossIlEquiv W hij hkl hik hil hjk hjl h_ij h_kl + hcross_il hcross_jk + · by_cases hcross_jk : W.pairing (W.boundaryFlag j) = W.boundaryFlag k + · -- Config (2) variant {jk} + rw [gluePair_eq_open _ (by exact (oneCross_jk_second_open_kl W hij hkl hik hil + hjk hjl + h_ij hcross_jk hcross_il))] + rw [gluePair_eq_open _ (by exact (oneCross_jk_second_open_ij W hij hkl hik hil + hjk hjl + h_kl hcross_jk hcross_il))] + exact oneCrossJkEquiv W hij hkl hik hil hjk hjl h_ij h_kl + hcross_jk hcross_il + · by_cases hcross_jl : W.pairing (W.boundaryFlag j) = W.boundaryFlag l + · -- Config (2) variant {jl} + rw [gluePair_eq_open _ (by exact (oneCross_jl_second_open_kl W hij hkl hik + hil hjk hjl + h_ij h_kl hcross_jl hcross_ik))] + rw [gluePair_eq_open _ (by exact (oneCross_jl_second_open_ij W hij hkl hik + hil hjk hjl + h_ij h_kl hcross_jl hcross_ik))] + exact oneCrossJlEquiv W hij hkl hik hil hjk hjl h_ij h_kl + hcross_jl hcross_ik + · -- Config (0): all boundary pairs disjoint + rw [gluePair_eq_open _ (by exact (openOpen_second_open_ij W hij hik hil hjk + hjl + h_ij h_kl hcross_ik hcross_jk))] + rw [gluePair_eq_open _ (by exact (openOpen_second_open_kl W hkl hik hil hjk + hjl + h_ij h_kl hcross_ik hcross_il))] + exact openOpenDisjointEquiv W hij hkl hik hil hjk hjl h_ij h_kl + hcross_ik hcross_il hcross_jk hcross_jl + +end Fragment + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCrossDelta.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCrossDelta.lean new file mode 100644 index 0000000000..54e147e8f3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCrossDelta.lean @@ -0,0 +1,387 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChords + +/-! +# The crossing-parity delta of the diagram gluing + +The crossing-count parity change of a label chord diagram across +the Temperley–Lieb gluing `glueChords i j` — the chord-sign ratio +the converse's per-cut splitting carries. + +* `diagCrossCount` — the abstract crossing count of a chord + diagram: ordered pairs of chords, gated so that the first-starting + chord is listed first; for a well-formed diagram each crossing + unordered pair contributes exactly one element. +* `diagCrossCount_glue_cross` — **the glue delta**: gluing the cut + `{i, j}` (chords `(i,x)`, `(j,y)` concatenating into `(x,y)`) + changes the crossing parity by the number of surviving chords + crossing the cut, plus the mutual-crossing indicator of the two + cut chords. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} + +/-- `ChordPairCross` is symmetric in its two chords: the two +disjuncts swap. -/ +theorem chordPairCross_comm [LinearOrder α] + {x y u w : α} : + ChordPairCross x y u w ↔ ChordPairCross u w x y := + or_comm + +open Classical in +/-- **The abstract diagram crossing count**: ordered pairs of +chords that interleave, gated so the first-starting chord is listed +first. On a well-formed diagram (`IsChordDiagram`) every crossing +unordered pair of chords contributes exactly one ordered pair, so +this is the plain crossing number. -/ +noncomputable def diagCrossCount [LinearOrder α] + (P : Finset (α × α)) : ℕ := + ((P ×ˢ P).filter (fun pq => pq.1.1 < pq.2.1 ∧ + ChordPairCross pq.1.1 pq.1.2 pq.2.1 pq.2.2)).card + +open Classical in +/-- The gated ordered crossing indicator of two chords. -/ +private noncomputable def xInd [LinearOrder α] + (p q : α × α) : ℕ := + if p.1 < q.1 ∧ ChordPairCross p.1 p.2 q.1 q.2 then 1 else 0 + +private theorem diagCrossCount_eq_sum [LinearOrder α] + (P : Finset (α × α)) : + diagCrossCount P = ∑ p ∈ P, ∑ q ∈ P, xInd p q := by + unfold diagCrossCount xInd + rw [Finset.card_filter, Finset.sum_product] + +private theorem xInd_self [LinearOrder α] + (p : α × α) : xInd p p = 0 := + ite_eq_right (fun h => lt_irrefl _ h.1) + +open scoped Classical in +/-- The two ordered indicators of a chord pair with distinct starts +sum to the plain crossing indicator. -/ +private theorem xInd_pair [LinearOrder α] + {p q : α × α} (h : p.1 ≠ q.1) : + xInd p q + xInd q p = + if ChordPairCross p.1 p.2 q.1 q.2 then 1 else 0 := by + rcases lt_or_gt_of_ne h with hlt | hgt + · have e0 : xInd q p = 0 := by + unfold xInd + exact ite_eq_right (fun hc => lt_asymm hlt hc.1) + rw [e0, add_zero] + unfold xInd + exact if_congr (and_iff_right hlt) rfl rfl + · have e0 : xInd p q = 0 := by + unfold xInd + exact ite_eq_right (fun hc => lt_asymm hgt hc.1) + rw [e0, zero_add] + unfold xInd + exact if_congr ((and_iff_right hgt).trans chordPairCross_comm) + rfl rfl + +/-- Inserting a fresh chord adds its ordered indicators against the +old diagram. -/ +private theorem diagCrossCount_insert [LinearOrder α] + {P : Finset (α × α)} + {c : α × α} (hc : c ∉ P) : + diagCrossCount (insert c P) = diagCrossCount P + + ∑ p ∈ P, (xInd c p + xInd p c) := by + rw [diagCrossCount_eq_sum, diagCrossCount_eq_sum, + Finset.sum_insert hc, Finset.sum_insert hc, xInd_self, + zero_add] + rw [show (∑ p ∈ P, ∑ q ∈ insert c P, xInd p q) = + ∑ p ∈ P, (xInd p c + ∑ q ∈ P, xInd p q) from + Finset.sum_congr rfl (fun p _ => Finset.sum_insert hc), + Finset.sum_add_distrib] + rw [show (∑ p ∈ P, (xInd c p + xInd p c)) = + (∑ p ∈ P, xInd c p) + ∑ p ∈ P, xInd p c from + Finset.sum_add_distrib] + omega + +/-! ## Order helpers -/ + +/-- A point distinct from both sorted ends is distinct from both +raw ends. -/ +private theorem ne_ends_raw [LinearOrder α] + {z a b : α} (h1 : z ≠ min a b) + (h2 : z ≠ max a b) : z ≠ a ∧ z ≠ b := by + rcases le_total a b with h | h + · rw [min_eq_left h] at h1 + rw [max_eq_right h] at h2 + exact ⟨h1, h2⟩ + · rw [min_eq_right h] at h1 + rw [max_eq_left h] at h2 + exact ⟨h2, h1⟩ + +/-- The ends of any other chord of a well-formed diagram avoid the +raw ends of a sorted chord. -/ +private theorem ends_ne [LinearOrder α] + {P : Finset (α × α)} (hP : IsChordDiagram P) + {a b : α} {q : α × α} (hab : (min a b, max a b) ∈ P) + (hq : q ∈ P) (hne : q ≠ (min a b, max a b)) : + (q.1 ≠ a ∧ q.1 ≠ b) ∧ (q.2 ≠ a ∧ q.2 ≠ b) := by + have hd := hP.disjoint q hq _ hab hne + exact ⟨ne_ends_raw hd.fst_ne_fst hd.fst_ne_snd, + ne_ends_raw hd.snd_ne_fst hd.snd_ne_snd⟩ + +private theorem min_ne_of_ne [LinearOrder α] + {a b z : α} (h1 : a ≠ z) (h2 : b ≠ z) : + min a b ≠ z := by + rcases min_choice a b with h | h <;> rw [h] <;> assumption + +private theorem max_ne_of_ne [LinearOrder α] + {a b z : α} (h1 : a ≠ z) (h2 : b ≠ z) : + max a b ≠ z := by + rcases max_choice a b with h | h <;> rw [h] <;> assumption + +open scoped Classical in +/-- Sorting the two probed points leaves the inside-indicator sum +unchanged. -/ +private theorem inside_sorted_sum [LinearOrder α] + (l r a b : α) : + ((if InsideChord l r (min a b) then (1 : ℕ) else 0) + + (if InsideChord l r (max a b) then 1 else 0)) = + ((if InsideChord l r a then (1 : ℕ) else 0) + + (if InsideChord l r b then 1 else 0)) := by + rcases le_total a b with h | h + · rw [min_eq_left h, max_eq_right h] + · rw [min_eq_right h, max_eq_left h, add_comm] + +open scoped Classical in +/-- The crossing indicator of a raw chord `{a, b}` against a third +chord `p` has the parity of the number of its raw ends inside +`p`. -/ +private theorem cross_parity_raw [LinearOrder α] + {p : α × α} {a b : α} + (hab : a ≠ b) (h1a : a ≠ p.1) (h1b : b ≠ p.1) + (h2a : a ≠ p.2) (h2b : b ≠ p.2) : + (if ChordPairCross (min a b) (max a b) p.1 p.2 then (1 : ℕ) + else 0) % 2 = + ((if InsideChord p.1 p.2 a then (1 : ℕ) else 0) + + (if InsideChord p.1 p.2 b then 1 else 0)) % 2 := by + have h1 : (if ChordPairCross (min a b) (max a b) p.1 p.2 + then (1 : ℕ) else 0) = + if ChordPairCross p.1 p.2 (min a b) (max a b) then 1 + else 0 := + if_congr chordPairCross_comm rfl rfl + have h2 := chordPairCross_parity (x := p.1) (y := p.2) + (min_lt_max.mpr hab) (min_ne_of_ne h1a h1b) + (max_ne_of_ne h2a h2b) + rw [h1, h2, inside_sorted_sum] + +open scoped Classical in +/-- The two cut-label inside-indicators against a chord avoiding +both cut labels sum (mod 2) to the crossing-the-cut indicator. -/ +private theorem pair_cut_parity [LinearOrder α] + {i j : α} (hij : i < j) {p : α × α} + (hp12 : p.1 < p.2) (h1i : p.1 ≠ i) (h2j : p.2 ≠ j) : + ((if InsideChord p.1 p.2 i then (1 : ℕ) else 0) + + (if InsideChord p.1 p.2 j then 1 else 0)) % 2 = + if CrossesCut i j p then 1 else 0 := by + have hxor : CrossesCut i j p ↔ + Xor (InsideChord p.1 p.2 i) (InsideChord p.1 p.2 j) := by + have e1 : CrossesCut i j (p.1, p.2) ↔ + ChordPairCross i j p.1 p.2 := + crossesCut_iff_chordPairCross hp12 h1i h2j + have e2 : ChordPairCross p.1 p.2 i j ↔ + Xor (InsideChord p.1 p.2 i) (InsideChord p.1 p.2 j) := + chordPairCross_iff_xor hij (Ne.symm h1i) (Ne.symm h2j) + exact e1.trans (chordPairCross_comm.trans e2) + by_cases hI : InsideChord p.1 p.2 i <;> + by_cases hJ : InsideChord p.1 p.2 j + · rw [ite_eq_left hI, ite_eq_left hJ, ite_eq_right (fun hc => + ((hxor.mp hc).elim (fun h => h.2 hJ) (fun h => h.2 hI)))] + · rw [ite_eq_left hI, ite_eq_right hJ, + ite_eq_left (hxor.mpr (Or.inl ⟨hI, hJ⟩))] + · rw [ite_eq_right hI, ite_eq_left hJ, + ite_eq_left (hxor.mpr (Or.inr ⟨hJ, hI⟩))] + · rw [ite_eq_right hI, ite_eq_right hJ, ite_eq_right (fun hc => + ((hxor.mp hc).elim (fun h => hI h.1) (fun h => hJ h.1)))] + +/-- An entry of a sorted pair is one of the sorted values. -/ +private theorem sorted_eq_cases [LinearOrder α] + {a b c d : α} + (he : (min a b, max a b) = (min c d, max c d)) : + a = c ∨ a = d := by + have h1 : min a b = min c d := congrArg Prod.fst he + have h2 : max a b = max c d := congrArg Prod.snd he + rcases le_total a b with hle | hle + · rcases min_choice c d with h | h + · exact Or.inl ((min_eq_left hle).symm.trans (h1.trans h)) + · exact Or.inr ((min_eq_left hle).symm.trans (h1.trans h)) + · rcases max_choice c d with h | h + · exact Or.inl ((max_eq_left hle).symm.trans (h2.trans h)) + · exact Or.inr ((max_eq_left hle).symm.trans (h2.trans h)) + +/-! ## The system bridge -/ + +namespace EdgeSubset + +end EdgeSubset + +/-! ## The glue delta, crossing case -/ + +open scoped Classical in +/-- **The glue delta, crossing case**: gluing the cut `{i, j}` +(`i < j`, chord `(i,x)` and chord `(j,y)` concatenating into +`(x,y)`, non-linked: `x ≠ j`) changes the diagram crossing count, +mod 2, by the number of surviving third chords crossing the cut +plus the mutual-crossing indicator of the two cut chords. -/ +theorem diagCrossCount_glue_cross [LinearOrder α] + {P : Finset (α × α)} + (hP : IsChordDiagram P) {i j x y : α} (hij : i < j) + (hxj : x ≠ j) + (hi : (min i x, max i x) ∈ P) (hj : (min j y, max j y) ∈ P) : + (diagCrossCount (glueChords i j P) + diagCrossCount P) % 2 = + ((((P.erase (min i x, max i x)).erase + (min j y, max j y)).filter (CrossesCut i j)).card + + (if ChordPairCross (min i x) (max i x) (min j y) (max j y) + then 1 else 0)) % 2 := by + have hix : i ≠ x := min_lt_max.mp (hP.ordered _ hi) + have hjy : j ≠ y := min_lt_max.mp (hP.ordered _ hj) + have hCC : (min i x, max i x) ≠ (min j y, max j y) := by + intro he + rcases sorted_eq_cases he with h | h + · exact ne_of_lt hij h + · have he' : (min x i, max x i) = (min j y, max j y) := by + rw [min_comm, max_comm] + exact he + rcases sorted_eq_cases he' with h' | h' + · exact hxj h' + · exact hix (h.trans h'.symm) + have hrCi := ends_ne hP hj hi hCC + have h1y : y ≠ min i x := Ne.symm hrCi.1.2 + have h2y : y ≠ max i x := Ne.symm hrCi.2.2 + have hxy : x ≠ y := Ne.symm (ne_ends_raw h1y h2y).2 + -- ═══════ PEELING THE TWO CUT CHORDS OFF THE DIAGRAM ═══════ + -- Above: the four ends are distinct and the two chords are two + -- elements of the diagram. Below: the count splits into their + -- mutual crossing, their crossings with the rest, and the rest. + have hCjE : (min j y, max j y) ∈ P.erase (min i x, max i x) := + Finset.mem_erase.mpr ⟨Ne.symm hCC, hj⟩ + have hCiQ : (min i x, max i x) ∉ + (P.erase (min i x, max i x)).erase (min j y, max j y) := + fun hm => + (Finset.mem_erase.mp (Finset.mem_of_mem_erase hm)).1 rfl + have hCjQ : (min j y, max j y) ∉ + (P.erase (min i x, max i x)).erase (min j y, max j y) := + fun hm => (Finset.mem_erase.mp hm).1 rfl + have hCiIns : (min i x, max i x) ∉ insert (min j y, max j y) + ((P.erase (min i x, max i x)).erase (min j y, max j y)) := by + intro hm + rcases Finset.mem_insert.mp hm with h | h + · exact hCC h + · exact hCiQ h + have hPdec : insert (min i x, max i x) (insert (min j y, max j y) + ((P.erase (min i x, max i x)).erase (min j y, max j y))) = + P := by + rw [Finset.insert_erase hCjE, Finset.insert_erase hi] + have hnQ : (min x y, max x y) ∉ + (P.erase (min i x, max i x)).erase (min j y, max j y) := by + intro hm + have hmP : (min x y, max x y) ∈ P := + Finset.mem_of_mem_erase (Finset.mem_of_mem_erase hm) + have hmne : (min x y, max x y) ≠ (min i x, max i x) := + Finset.ne_of_mem_erase (Finset.mem_of_mem_erase hm) + have hr := ends_ne hP hi hmP hmne + rcases le_total x y with h | h + · exact hr.1.2 (min_eq_left h) + · exact hr.2.2 (max_eq_left h) + have hdG : diagCrossCount (glueChords i j P) = + diagCrossCount + ((P.erase (min i x, max i x)).erase (min j y, max j y)) + + ∑ p ∈ (P.erase (min i x, max i x)).erase (min j y, max j y), + (xInd (min x y, max x y) p + xInd p (min x y, max x y)) := by + rw [glueChords_cross hP hxj hi hj, Finset.union_singleton, + diagCrossCount_insert hnQ] + have hdP : diagCrossCount (insert (min i x, max i x) + (insert (min j y, max j y) + ((P.erase (min i x, max i x)).erase (min j y, max j y)))) = + diagCrossCount + ((P.erase (min i x, max i x)).erase (min j y, max j y)) + + (∑ p ∈ (P.erase (min i x, max i x)).erase (min j y, max j y), + (xInd (min j y, max j y) p + xInd p (min j y, max j y))) + + ((xInd (min i x, max i x) (min j y, max j y) + + xInd (min j y, max j y) (min i x, max i x)) + + ∑ p ∈ (P.erase (min i x, max i x)).erase (min j y, max j y), + (xInd (min i x, max i x) p + xInd p (min i x, max i x))) := by + rw [diagCrossCount_insert hCiIns, diagCrossCount_insert hCjQ, + Finset.sum_insert hCjQ] + rw [hPdec] at hdP + have hd := hP.disjoint _ hi _ hj hCC + have hM : xInd (min i x, max i x) (min j y, max j y) + + xInd (min j y, max j y) (min i x, max i x) = + if ChordPairCross (min i x) (max i x) (min j y) (max j y) + then 1 else 0 := + xInd_pair hd.fst_ne_fst + have hthird : (∑ p ∈ (P.erase (min i x, max i x)).erase + (min j y, max j y), + ((xInd (min x y, max x y) p + xInd p (min x y, max x y)) + + ((xInd (min j y, max j y) p + xInd p (min j y, max j y)) + + (xInd (min i x, max i x) p + + xInd p (min i x, max i x))))) % 2 = + (((P.erase (min i x, max i x)).erase + (min j y, max j y)).filter (CrossesCut i j)).card % 2 := by + rw [Finset.sum_nat_mod, Finset.card_filter] + refine congrArg (· % 2) (Finset.sum_congr rfl fun p hp => ?_) + have hpP : p ∈ P := + Finset.mem_of_mem_erase (Finset.mem_of_mem_erase hp) + have hpCj : p ≠ (min j y, max j y) := Finset.ne_of_mem_erase hp + have hpCi : p ≠ (min i x, max i x) := + Finset.ne_of_mem_erase (Finset.mem_of_mem_erase hp) + have hri := ends_ne hP hi hpP hpCi + have hrj := ends_ne hP hj hpP hpCj + have hp12 : p.1 < p.2 := hP.ordered p hpP + have e_n : xInd (min x y, max x y) p + + xInd p (min x y, max x y) = + if ChordPairCross (min x y) (max x y) p.1 p.2 then 1 + else 0 := + xInd_pair (min_ne_of_ne (Ne.symm hri.1.2) (Ne.symm hrj.1.2)) + have e_j : xInd (min j y, max j y) p + + xInd p (min j y, max j y) = + if ChordPairCross (min j y) (max j y) p.1 p.2 then 1 + else 0 := + xInd_pair (min_ne_of_ne (Ne.symm hrj.1.1) (Ne.symm hrj.1.2)) + have e_i : xInd (min i x, max i x) p + + xInd p (min i x, max i x) = + if ChordPairCross (min i x) (max i x) p.1 p.2 then 1 + else 0 := + xInd_pair (min_ne_of_ne (Ne.symm hri.1.1) (Ne.symm hri.1.2)) + rw [e_n, e_j, e_i] + have h_i := cross_parity_raw hix (Ne.symm hri.1.1) + (Ne.symm hri.1.2) (Ne.symm hri.2.1) (Ne.symm hri.2.2) + have h_j := cross_parity_raw hjy (Ne.symm hrj.1.1) + (Ne.symm hrj.1.2) (Ne.symm hrj.2.1) (Ne.symm hrj.2.2) + have h_n := cross_parity_raw hxy (Ne.symm hri.1.2) + (Ne.symm hrj.1.2) (Ne.symm hri.2.2) (Ne.symm hrj.2.2) + have h_cut := pair_cut_parity hij hp12 hri.1.1 hrj.2.1 + omega + have hsplit : (∑ p ∈ (P.erase (min i x, max i x)).erase + (min j y, max j y), + ((xInd (min x y, max x y) p + xInd p (min x y, max x y)) + + ((xInd (min j y, max j y) p + xInd p (min j y, max j y)) + + (xInd (min i x, max i x) p + + xInd p (min i x, max i x))))) = + (∑ p ∈ (P.erase (min i x, max i x)).erase (min j y, max j y), + (xInd (min x y, max x y) p + xInd p (min x y, max x y))) + + ((∑ p ∈ (P.erase (min i x, max i x)).erase (min j y, max j y), + (xInd (min j y, max j y) p + xInd p (min j y, max j y))) + + (∑ p ∈ (P.erase (min i x, max i x)).erase (min j y, max j y), + (xInd (min i x, max i x) p + xInd p (min i x, max i x)))) := by + simp only [Finset.sum_add_distrib] + rw [hsplit] at hthird + rw [hdG, hdP] + omega + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueFold.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueFold.lean new file mode 100644 index 0000000000..29445b503e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueFold.lean @@ -0,0 +1,2343 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.PairDisjoint +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueAmbient + +/-! +# Fold-and-reorder theory for iterated single-pair gluing + +Iterated single-pair gluing over a list of pairs, with a +well-formedness predicate (all 2n components pairwise distinct) and +a reorder theorem: the result is invariant under permutation of the +pair list, up to fragment equivalence composed with the canonical +relabelling. +-/ + +@[expose] public section + +namespace RS + +namespace Fragment + +variable {α : Type} + +/-! ### Well-formedness of pair lists -/ + +/-- All 2n components of a list of pairs are pairwise distinct. -/ +def PairsWF (ps : List (α × α)) : Prop := + (ps.flatMap (fun p => [p.1, p.2])).Nodup + +/-- The empty list is trivially well-formed. -/ +theorem PairsWF.nil : PairsWF (α := α) [] := List.nodup_nil + +/-- The components of the head pair are distinct. -/ +theorem PairsWF.head_ne {p : α × α} {ps : List (α × α)} + (h : PairsWF (p :: ps)) : p.1 ≠ p.2 := by + unfold PairsWF at h + rw [List.flatMap_cons] at h + have h1 := (List.nodup_append.mp h).1 + rw [List.nodup_cons] at h1 + intro heq + exact h1.1 (heq ▸ List.mem_cons_self) + +/-- The tail of a well-formed pair list is well-formed. -/ +theorem PairsWF.tail {p : α × α} {ps : List (α × α)} + (h : PairsWF (p :: ps)) : PairsWF ps := by + unfold PairsWF at h ⊢ + rw [List.flatMap_cons] at h + exact (List.nodup_append.mp h).2.1 + +/-- The head pair of a well-formed list shares no label with any +pair of the tail. -/ +theorem PairsWF.head_disjoint_of {i j : α} {ps : List (α × α)} + (h : PairsWF ((i, j) :: ps)) (q : α × α) (hq : q ∈ ps) : + PairDisjoint q (i, j) := by + unfold PairsWF at h + rw [List.flatMap_cons] at h + have hnd := List.nodup_append.mp h + have hmem1 : q.1 ∈ ps.flatMap (fun r => [r.1, r.2]) := + List.mem_flatMap.mpr ⟨q, hq, List.mem_cons_self⟩ + have hmem2 : q.2 ∈ ps.flatMap (fun r => [r.1, r.2]) := + List.mem_flatMap.mpr ⟨q, hq, List.mem_cons.mpr (Or.inr List.mem_cons_self)⟩ + refine ⟨fun heq => ?_, fun heq => ?_, fun heq => ?_, fun heq => ?_⟩ + · exact (hnd.2.2 i List.mem_cons_self q.1 (heq ▸ hmem1)).symm heq + · exact (hnd.2.2 j (List.mem_cons.mpr (Or.inr List.mem_cons_self)) q.1 (heq ▸ + hmem1)).symm heq + · exact (hnd.2.2 i List.mem_cons_self q.2 (heq ▸ hmem2)).symm heq + · exact (hnd.2.2 j (List.mem_cons.mpr (Or.inr List.mem_cons_self)) q.2 (heq ▸ + hmem2)).symm heq + +/-- Well-formedness is preserved by permutation of the pair list. -/ +theorem PairsWF.perm {ps qs : List (α × α)} (h : PairsWF ps) + (hperm : ps.Perm qs) : PairsWF qs := by + unfold PairsWF at h ⊢ + exact (hperm.flatMap (fun _ _ => List.Perm.refl _)).nodup_iff.mp h + +/-! ### The flat surviving subtype -/ + +/-- The labels surviving all glues in a pair list: those not +appearing as any component of any pair. -/ +def FoldSurviving (α : Type) (ps : List (α × α)) : Type := + {x : α // ∀ p ∈ ps, x ≠ p.1 ∧ x ≠ p.2} + +/-- The vacuous surviving equivalence for the empty list. -/ +def foldSurvivingNilEquiv : FoldSurviving α [] ≃ α where + toFun x := x.val + invFun x := ⟨x, fun _ h => absurd h List.not_mem_nil⟩ + left_inv _ := Subtype.ext rfl + right_inv _ := rfl + +/-- The surviving-set equivalence induced by a permutation of pairs: +the membership condition is ∀-quantified over ∈, so a permutation +preserving membership gives an equivalence. -/ +def foldSurvivingPermEquiv {ps qs : List (α × α)} + (hperm : ps.Perm qs) : + FoldSurviving α ps ≃ FoldSurviving α qs where + toFun x := ⟨x.val, fun p hp => x.prop p (hperm.mem_iff.mpr hp)⟩ + invFun x := ⟨x.val, fun p hp => x.prop p (hperm.mem_iff.mp hp)⟩ + left_inv _ := Subtype.ext rfl + right_inv _ := rfl + +/-! ### Coercing tail pairs into the surviving-label subtype -/ + +/-- The separation hypothesis for coercing pairs. -/ +abbrev PairsSep (i j : α) (ps : List (α × α)) : Prop := + ∀ q ∈ ps, PairDisjoint q (i, j) + +/-- Extract the separation hypothesis from PairsWF. -/ +theorem PairsWF.sep {i j : α} {ps : List (α × α)} + (h : PairsWF ((i, j) :: ps)) : PairsSep i j ps := + h.head_disjoint_of + +/-- Coerce a well-formed tail into pairs of surviving labels. -/ +def coercePairsList (i j : α) : + (ps : List (α × α)) → + PairsSep i j ps → + List (SurvivingLabel α i j × SurvivingLabel α i j) + | [], _ => [] + | q :: ps, h => + let hq := h q List.mem_cons_self + (⟨q.1, hq.fst_ne_fst, hq.fst_ne_snd⟩, + ⟨q.2, hq.snd_ne_fst, hq.snd_ne_snd⟩) :: + coercePairsList i j ps (fun r hr => h r (List.mem_cons.mpr (Or.inr hr))) + +/-- Length of `coercePairsList` equals the original list length. -/ +theorem coercePairsList_length (i j : α) : + ∀ (ps : List (α × α)) (h : PairsSep i j ps), + (coercePairsList i j ps h).length = ps.length + | [], _ => rfl + | _ :: ps, _ => congrArg Nat.succ (coercePairsList_length i j ps _) + +/-- The val-projection of the flattened coerced list equals the +original flattened list. -/ +theorem coercePairsList_flatMap_map_val (i j : α) : + ∀ (ps : List (α × α)) (h : PairsSep i j ps), + ((coercePairsList i j ps h).flatMap (fun r => [r.1, r.2])).map Subtype.val = + ps.flatMap (fun q => [q.1, q.2]) + | [], _ => rfl + | _ :: ps, h => by + simp only [coercePairsList, List.flatMap_cons, List.map_append] + exact congrArg ([_, _] ++ ·) (coercePairsList_flatMap_map_val i j ps _) + +/-- Well-formedness of the coerced pairs. -/ +theorem coercePairsList_wf (i j : α) (ps : List (α × α)) + (hwf : PairsWF ps) (h : PairsSep i j ps) : + PairsWF (coercePairsList i j ps h) := by + unfold PairsWF + apply List.Nodup.of_map Subtype.val + unfold PairsWF at hwf + rw [coercePairsList_flatMap_map_val] + exact hwf + +/-- Each element of coercePairsList comes from an element of ps. -/ +theorem coercePairsList_mem_of (i j : α) : + ∀ (ps : List (α × α)) (h : PairsSep i j ps) + (r : SurvivingLabel α i j × SurvivingLabel α i j) + (_ : r ∈ coercePairsList i j ps h), + ∃ q ∈ ps, r.1.val = q.1 ∧ r.2.val = q.2 + | q :: ps, h, r, hr => by + simp only [coercePairsList] at hr + rcases List.mem_cons.mp hr with heq | htail + · subst heq + exact ⟨q, List.mem_cons_self, rfl, rfl⟩ + · obtain ⟨q', hq', h1, h2⟩ := coercePairsList_mem_of i j ps _ r htail + exact ⟨q', List.mem_cons.mpr (Or.inr hq'), h1, h2⟩ + +/-- Membership in coercePairsList: if q ∈ ps then the coerced version +is in coercePairsList. -/ +theorem coercePairsList_mem (i j : α) : + ∀ (ps : List (α × α)) (h : PairsSep i j ps) + (q : α × α) (_ : q ∈ ps), + ∃ r ∈ coercePairsList i j ps h, r.1.val = q.1 ∧ r.2.val = q.2 + | q' :: ps, h, q, hq => by + rcases List.mem_cons.mp hq with rfl | htail + · exact ⟨_, List.mem_cons_self, rfl, rfl⟩ + · obtain ⟨r, hr, h1, h2⟩ := coercePairsList_mem i j ps _ q htail + exact ⟨r, List.mem_cons.mpr (Or.inr hr), h1, h2⟩ + +/-! ### The flattening equivalence -/ + +/-- The canonical equivalence between the nested surviving type +(first remove i, j from α to get SurvivingLabel; then remove +the coerced tail pairs) and the flat surviving type (remove +(i, j) :: ps at once). -/ +def foldFlatten (i j : α) (ps : List (α × α)) + (h : PairsSep i j ps) : + FoldSurviving (SurvivingLabel α i j) (coercePairsList i j ps h) ≃ + FoldSurviving α ((i, j) :: ps) where + toFun x := + ⟨x.val.val, fun p hp => by + rcases List.mem_cons.mp hp with rfl | hmem + · exact ⟨x.val.prop.1, x.val.prop.2⟩ + · obtain ⟨r, hr, h1, h2⟩ := coercePairsList_mem i j ps h p hmem + have hxr := x.prop r hr + exact ⟨fun heq => hxr.1 (Subtype.ext (h1 ▸ heq)), + fun heq => hxr.2 (Subtype.ext (h2 ▸ heq))⟩⟩ + invFun x := + ⟨⟨x.val, by + have := x.prop (i, j) List.mem_cons_self + exact ⟨this.1, this.2⟩⟩, + fun r hr => by + obtain ⟨q, hq, h1, h2⟩ := coercePairsList_mem_of i j ps h r hr + have hxq := x.prop q (List.mem_cons.mpr (Or.inr hq)) + exact ⟨fun heq => hxq.1 (h1 ▸ congrArg Subtype.val heq), + fun heq => hxq.2 (h2 ▸ congrArg Subtype.val heq)⟩⟩ + left_inv _ := Subtype.ext (Subtype.ext rfl) + right_inv _ := Subtype.ext rfl + +/-! ### The fold: iterated single-pair gluing -/ + +/-- Fold a well-formed pair list using a bound on its length as structural fuel. -/ +noncomputable def glueListAux : + (n : ℕ) → {α : Type} → (W : Fragment α) → + (ps : List (α × α)) → PairsWF ps → + ps.length ≤ n → Fragment (FoldSurviving α ps) + | _, _, W, [], _, _ => W.relabel foldSurvivingNilEquiv.symm + | n + 1, _, W, (i, j) :: ps, h, hlen => + have hlen' : (coercePairsList i j ps h.sep).length ≤ n := by + rw [coercePairsList_length] + simp only [List.length_cons] at hlen + omega + (glueListAux n (W.gluePair i j h.head_ne) + (coercePairsList i j ps h.sep) + (coercePairsList_wf i j ps h.tail h.sep) + hlen').relabel + (foldFlatten i j ps h.sep) + +/-- Iterated single-pair gluing along a list of distinct pairs. +Glues each pair in order; the result is labelled by the elements of +α not appearing in any pair. -/ +noncomputable def glueList {α : Type} (W : Fragment α) + (ps : List (α × α)) (h : PairsWF ps) : + Fragment (FoldSurviving α ps) := + glueListAux ps.length W ps h le_rfl + +private theorem glueListAux_irrel : + ∀ (n m : ℕ) {α : Type} (W : Fragment α) + (ps : List (α × α)) (h : PairsWF ps) + (hn : ps.length ≤ n) (hm : ps.length ≤ m), + glueListAux n W ps h hn = glueListAux m W ps h hm + | 0, 0, _, _, [], _, _, _ => rfl + | 0, _ + 1, _, _, [], _, _, _ => rfl + | _ + 1, 0, _, _, [], _, _, _ => rfl + | _ + 1, _ + 1, _, _, [], _, _, _ => rfl + | n + 1, m + 1, _, W, (i, j) :: ps, h, hn, hm => by + simp only [glueListAux] + congr 1 + exact glueListAux_irrel n m _ _ _ _ _ + +/-- Unfolding `glueList` at the empty list. -/ +theorem glueList_nil {α : Type} (W : Fragment α) (h : PairsWF (α := α) []) : + glueList W [] h = W.relabel foldSurvivingNilEquiv.symm := rfl + +/-- Unfolding `glueList` at a cons. -/ +theorem glueList_cons {α : Type} (W : Fragment α) + (p : α × α) (ps : List (α × α)) (hp : PairsWF (p :: ps)) : + glueList W (p :: ps) hp = + (glueList (W.gluePair p.1 p.2 hp.head_ne) + (coercePairsList p.1 p.2 ps hp.sep) + (coercePairsList_wf p.1 p.2 ps hp.tail hp.sep)).relabel + (foldFlatten p.1 p.2 ps hp.sep) := by + change glueListAux ((p :: ps).length) W (p :: ps) hp le_rfl = + (glueListAux ((coercePairsList p.1 p.2 ps hp.sep).length) + (W.gluePair p.1 p.2 hp.head_ne) + (coercePairsList p.1 p.2 ps hp.sep) + (coercePairsList_wf p.1 p.2 ps hp.tail hp.sep) le_rfl).relabel _ + simp only [List.length_cons, glueListAux] + congr 1 + exact glueListAux_irrel _ _ _ _ _ _ _ + +/-! ### Congruence: glueList respects fragment equivalence -/ + +/-- Transport a bounded pair-list fold along an equivalence of input fragments. -/ +noncomputable def glueListCongrAux + (n : ℕ) {α : Type} {W₁ W₂ : Fragment α} + (he : W₁.Equiv W₂) + (ps : List (α × α)) (h : PairsWF ps) + (hn : ps.length ≤ n) : + (glueListAux n W₁ ps h hn).Equiv (glueListAux n W₂ ps h hn) := by + induction n generalizing α with + | zero => + match ps, h, hn with + | [], _, _ => exact Equiv.relabelCongr he _ + | succ n ih => + match ps, h, hn with + | [], _, _ => exact Equiv.relabelCongr he _ + | (i, j) :: ps, h, hlen => + change ((glueListAux n _ _ _ _).relabel _).Equiv + ((glueListAux n _ _ _ _).relabel _) + exact Equiv.relabelCongr + (ih (Equiv.gluePairCongr he h.head_ne) + (coercePairsList i j ps h.sep) + (coercePairsList_wf i j ps h.tail h.sep) _) + (foldFlatten i j ps h.sep) + +/-- `glueList` respects fragment equivalence: equivalent inputs +produce equivalent outputs. -/ +noncomputable def glueListCongr {α : Type} + {W₁ W₂ : Fragment α} + (he : W₁.Equiv W₂) + (ps : List (α × α)) (h : PairsWF ps) : + (glueList W₁ ps h).Equiv (glueList W₂ ps h) := + glueListCongrAux ps.length he ps h le_rfl + +/-! ### Relabelling commutes with the fold -/ + +/-- Map a pair list through an equivalence. -/ +def mapPairs (e : α ≃ β) (ps : List (α × α)) : List (β × β) := + ps.map (Prod.map e e) + +private theorem mapPairs_flatMap (e : α ≃ β) : + ∀ (ps : List (α × α)), + (mapPairs e ps).flatMap (fun p => [p.1, p.2]) = + (ps.flatMap (fun q => [q.1, q.2])).map e + | [] => rfl + | _ :: ps => by + simp only [mapPairs, List.map_cons, List.flatMap_cons, List.map_append, + Prod.map, List.map_cons, List.map_nil] + exact congrArg _ (mapPairs_flatMap e ps) + +/-- Well-formedness is preserved by mapping through an equivalence. -/ +theorem mapPairs_wf (e : α ≃ β) (ps : List (α × α)) + (hp : PairsWF ps) : PairsWF (mapPairs e ps) := by + unfold PairsWF + rw [mapPairs_flatMap] + exact hp.map e.injective + +/-- The canonical equivalence on FoldSurviving induced by a +label equivalence. -/ +def foldSurvivingMapEquiv (e : α ≃ β) (ps : List (α × α)) : + FoldSurviving α ps ≃ FoldSurviving β (mapPairs e ps) where + toFun x := ⟨e x.val, fun p hp => by + obtain ⟨q, hq, rfl⟩ := List.mem_map.mp hp + exact ⟨fun h => (x.prop q hq).1 (e.injective (show e x.val = e q.1 from h)), + fun h => (x.prop q hq).2 (e.injective (show e x.val = e q.2 + from h))⟩⟩ + invFun y := ⟨e.symm y.val, fun p hp => by + have h := y.prop (Prod.map e e p) (List.mem_map.mpr ⟨p, hp, rfl⟩) + simp only [Prod.map] at h + exact ⟨fun heq => h.1 ((e.apply_symm_apply y.val).symm.trans (congrArg e + heq)), + fun heq => h.2 ((e.apply_symm_apply y.val).symm.trans (congrArg e + heq))⟩⟩ + left_inv x := Subtype.ext (e.symm_apply_apply x.val) + right_inv y := Subtype.ext (e.apply_symm_apply y.val) + +/-- PairsSep is preserved by mapping. -/ +private theorem mapPairs_sep (e : α ≃ β) (i j : α) (ps : List (α × α)) + (h : PairsSep i j ps) : PairsSep (e i) (e j) (mapPairs e ps) := by + intro q hq + obtain ⟨r, hr, rfl⟩ := List.mem_map.mp hq + simp only [Prod.map] + have := h r hr + exact ⟨fun h' => this.fst_ne_fst (e.injective h'), + fun h' => this.fst_ne_snd (e.injective h'), + fun h' => this.snd_ne_fst (e.injective h'), + fun h' => this.snd_ne_snd (e.injective h')⟩ + +/-- The surviving-label equivalence induced by a label equiv. -/ +def survLabelMapEquiv (e : α ≃ β) (i j : α) : + SurvivingLabel α i j ≃ SurvivingLabel β (e i) (e j) where + toFun x := ⟨e x.val, fun h => x.prop.1 (e.injective h), + fun h => x.prop.2 (e.injective h)⟩ + invFun y := ⟨e.symm y.val, + fun h => y.prop.1 ((e.apply_symm_apply y.val).symm.trans (congrArg e h)), + fun h => y.prop.2 ((e.apply_symm_apply y.val).symm.trans (congrArg e h))⟩ + left_inv x := Subtype.ext (e.symm_apply_apply x.val) + right_inv y := Subtype.ext (e.apply_symm_apply y.val) + +/-- The coerced mapped pairs equal the mapped coerced pairs. -/ +private theorem coercePairsList_mapPairs_comm (e : α ≃ β) (i j : α) : + ∀ (ps : List (α × α)) (hsep : PairsSep i j ps) + (hsep' : PairsSep (e i) (e j) (mapPairs e ps)), + coercePairsList (e i) (e j) (mapPairs e ps) hsep' = + mapPairs (survLabelMapEquiv e i j) (coercePairsList i j ps hsep) + | [], _, _ => rfl + | _ :: ps, _, _ => + congrArg₂ List.cons + (Prod.ext (Subtype.ext rfl) (Subtype.ext rfl)) + (coercePairsList_mapPairs_comm e i j ps _ _) + +/-- The cast equivalence between surviving-label types differing only +by propositionally-equal indices. Identity on the underlying value. -/ +private def survLabelCastEquiv (e : α ≃ β) (i j : α) : + SurvivingLabel α (e.symm (e i)) (e.symm (e j)) ≃ SurvivingLabel α i j where + toFun x := ⟨x.val, + fun h => x.prop.1 (h.trans (e.symm_apply_apply i).symm), + fun h => x.prop.2 (h.trans (e.symm_apply_apply j).symm)⟩ + invFun x := ⟨x.val, + fun h => x.prop.1 (h.trans (e.symm_apply_apply i)), + fun h => x.prop.2 (h.trans (e.symm_apply_apply j))⟩ + left_inv _ := Subtype.ext rfl + right_inv _ := Subtype.ext rfl + +/-- The coerced pairs after casting equal the directly coerced pairs. -/ +private theorem coercePairsList_cast_eq (e : α ≃ β) (i j : α) : + ∀ (ps : List (α × α)) + (hsep : PairsSep (e.symm (e i)) (e.symm (e j)) ps) (hsep' : PairsSep i j + ps), + mapPairs (survLabelCastEquiv e i j) + (coercePairsList (e.symm (e i)) (e.symm (e j)) ps hsep) = + coercePairsList i j ps hsep' + | [], _, _ => rfl + | _ :: ps, _, _ => + congrArg₂ List.cons + (Prod.ext (Subtype.ext rfl) (Subtype.ext rfl)) + (coercePairsList_cast_eq e i j ps _ _) + +/-- Composition of mapPairs. -/ +private theorem mapPairs_mapPairs (f : β ≃ γ) (g : α ≃ β) : + ∀ (xs : List (α × α)), + mapPairs f (mapPairs g xs) = mapPairs (g.trans f) xs + | [] => rfl + | _ :: xs => congrArg₂ List.cons rfl (mapPairs_mapPairs f g xs) + +/-- Two equivs that agree pointwise give the same mapPairs result. -/ +private theorem mapPairs_congr {f g : α ≃ β} + (h : ∀ x, f x = g x) : + ∀ (xs : List (α × α)), + mapPairs f xs = mapPairs g xs + | [] => rfl + | _ :: xs => congrArg₂ List.cons (Prod.ext (h _) (h _)) (mapPairs_congr h xs) + +/-- Gluing at propositionally-equal indices and then relabelling by the +cast equivalence yields an equivalent fragment. -/ +private noncomputable def gluePair_cast_equiv (W : Fragment α) (e : α ≃ β) + (i j : α) (hij : i ≠ j) : + let hij' : e.symm (e i) ≠ e.symm (e j) := fun h => + hij (e.injective (by rw [← e.apply_symm_apply (e i), + ← e.apply_symm_apply (e j), h])) + ((W.gluePair (e.symm (e i)) (e.symm (e j)) hij').relabel + (survLabelCastEquiv e i j)).Equiv (W.gluePair i j hij) := by + intro hij' + have hbi : W.boundaryFlag (e.symm (e i)) = W.boundaryFlag i := + congrArg W.boundaryFlag (e.symm_apply_apply i) + have hbj : W.boundaryFlag (e.symm (e j)) = W.boundaryFlag j := + congrArg W.boundaryFlag (e.symm_apply_apply j) + -- The flag types are SurvivingFlag W (e.symm(ei))(e.symm(ej)) on both sides + -- (relabel does not change Flag). We bridge to SurvivingFlag W i j. + set flagE : SurvivingFlag W (e.symm (e i)) (e.symm (e j)) ≃ SurvivingFlag W i + j := + ⟨fun f => ⟨f.val, + fun h => f.prop.1 (h.trans hbi.symm), + fun h => f.prop.2 (h.trans hbj.symm)⟩, + fun f => ⟨f.val, + fun h => f.prop.1 (h.trans hbi), + fun h => f.prop.2 (h.trans hbj)⟩, + fun _ => Subtype.ext rfl, fun _ => Subtype.ext rfl⟩ + -- Build the Equiv by cases on closed/open + by_cases hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j + · -- ═══════ THE PAIR IS CLOSED ═══════ + have hclosed' : W.pairing (W.boundaryFlag (e.symm (e i))) = + W.boundaryFlag (e.symm (e j)) := + (congrArg W.pairing hbi).trans (hclosed.trans hbj.symm) + -- After gluePair_eq_closed, both sides are gluePairClosed + -- LHS fragment = (gluePairClosed W (e.symm(ei)) (e.symm(ej)) + -- hclosed').relabel castE + -- RHS fragment = gluePairClosed W i j hclosed + -- Both have Flag = SurvivingFlag W ... and Vertex = W.Vertex + have hlhs_eq := gluePair_eq_closed hij' hclosed' + have hrhs_eq := gluePair_eq_closed hij hclosed + rw [hlhs_eq, hrhs_eq] + refine ⟨flagE, _root_.Equiv.refl _, fun f => ?_, fun f => ?_, rfl⟩ + · -- attach_comm: both sides depend on W.attach f.val + change glueAttach W i j (flagE f) = + ((glueAttach W (e.symm (e i)) (e.symm (e j)) f).map id + (survLabelCastEquiv e i j)).map (_root_.Equiv.refl _) id + rcases ha : W.attach f.val with v | ℓ + · have h1 : glueAttach W i j (flagE f) = Sum.inl v := by + exact (glueAttach_inl_iff _ v).mpr ha + have h2 : glueAttach W (e.symm (e i)) (e.symm (e j)) f = Sum.inl v := by + exact (glueAttach_inl_iff _ v).mpr ha + rw [h1, h2]; rfl + · have h1 : ∃ p : SurvivingLabel α i j, + glueAttach W i j (flagE f) = Sum.inr p ∧ p.val = ℓ := by + exact exists_glueAttach_inr _ ha + have h2 : ∃ p : SurvivingLabel α (e.symm (e i)) (e.symm (e j)), + glueAttach W (e.symm (e i)) (e.symm (e j)) f = Sum.inr p ∧ p.val = ℓ + := by + exact exists_glueAttach_inr _ ha + obtain ⟨p1, hp1, hv1⟩ := h1 + obtain ⟨p2, hp2, hv2⟩ := h2 + rw [hp1, hp2] + exact congrArg Sum.inr (Subtype.ext (hv1.trans hv2.symm)) + · -- pairing_comm + exact Subtype.ext rfl + · -- ═══════ THE PAIR IS OPEN ═══════ + have hopen' : W.pairing (W.boundaryFlag (e.symm (e i))) ≠ + W.boundaryFlag (e.symm (e j)) := + fun h => hclosed ((congrArg W.pairing hbi).symm.trans (h.trans hbj)) + have hlhs_eq := gluePair_eq_open hij' hopen' + have hrhs_eq := gluePair_eq_open hij hclosed + rw [hlhs_eq, hrhs_eq] + refine ⟨flagE, _root_.Equiv.refl _, fun f => ?_, fun f => ?_, rfl⟩ + · -- attach_comm (same as closed case) + change glueAttach W i j (flagE f) = + ((glueAttach W (e.symm (e i)) (e.symm (e j)) f).map id + (survLabelCastEquiv e i j)).map (_root_.Equiv.refl _) id + rcases ha : W.attach f.val with v | ℓ + · have h1 : glueAttach W i j (flagE f) = Sum.inl v := by + exact (glueAttach_inl_iff _ v).mpr ha + have h2 : glueAttach W (e.symm (e i)) (e.symm (e j)) f = Sum.inl v := by + exact (glueAttach_inl_iff _ v).mpr ha + rw [h1, h2]; rfl + · have h1 : ∃ p : SurvivingLabel α i j, + glueAttach W i j (flagE f) = Sum.inr p ∧ p.val = ℓ := by + exact exists_glueAttach_inr _ ha + have h2 : ∃ p : SurvivingLabel α (e.symm (e i)) (e.symm (e j)), + glueAttach W (e.symm (e i)) (e.symm (e j)) f = Sum.inr p ∧ p.val = ℓ + := by + exact exists_glueAttach_inr _ ha + obtain ⟨p1, hp1, hv1⟩ := h1 + obtain ⟨p2, hp2, hv2⟩ := h2 + rw [hp1, hp2] + exact congrArg Sum.inr (Subtype.ext (hv1.trans hv2.symm)) + · -- pairing_comm for open case (rewire) + change flagE (rewire hopen' f) = rewire hclosed (flagE f) + unfold rewire + split + · rename_i hfi + have hfi' : W.pairing (flagE f).val = W.boundaryFlag i := by + change W.pairing f.val = W.boundaryFlag i; rw [← hbi]; exact hfi + rw [dite_eq_left hfi'] + exact Subtype.ext (congrArg W.pairing hbj) + · rename_i hfi + have hfi' : ¬(W.pairing (flagE f).val = W.boundaryFlag i) := by + change ¬(W.pairing f.val = W.boundaryFlag i); rw [← hbi]; exact hfi + rw [dite_eq_right hfi'] + split + · rename_i hfj + have hfj' : W.pairing (flagE f).val = W.boundaryFlag j := by + change W.pairing f.val = W.boundaryFlag j; rw [← hbj]; exact hfj + rw [dite_eq_left hfj'] + exact Subtype.ext (congrArg W.pairing hbi) + · rename_i hfj + have hfj' : ¬(W.pairing (flagE f).val = W.boundaryFlag j) := by + change ¬(W.pairing f.val = W.boundaryFlag j); rw [← hbj]; exact hfj + rw [dite_eq_right hfj'] + exact Subtype.ext rfl + +/-- Casting a `glueList` result along a list equality: relabelling +by the induced `foldSurvivingPermEquiv` bridges the type change. -/ +noncomputable def glueListEqEquiv {α : Type} (W : Fragment α) + {ps qs : List (α × α)} (h : ps = qs) (hp : PairsWF ps) (hq : PairsWF qs) + (hperm : ps.Perm qs) : + ((glueList W ps hp).relabel (foldSurvivingPermEquiv hperm)).Equiv + (glueList W qs hq) := by + subst h; exact Equiv.relabelRefl _ + +/-- Iterated gluing commutes with relabelling (existence). -/ +private theorem nonempty_glueList_relabel_aux (n : ℕ) : + ∀ {α β : Type} (W : Fragment α) (e : α ≃ β) + (ps : List (α × α)) (hp : PairsWF ps) + (_ : ps.length ≤ n), + Nonempty ((glueList (W.relabel e) (mapPairs e ps) (mapPairs_wf e ps + hp)).Equiv + ((glueList W ps hp).relabel (foldSurvivingMapEquiv e ps))) := by + induction n with + -- ═══════ n = 0: NO PAIRS LEFT TO GLUE ═══════ + | zero => + intro α β W e ps hp hlen + have hnil : ps = [] := List.eq_nil_of_length_eq_zero (Nat.le_zero.mp hlen) + subst hnil + change Nonempty (((W.relabel e).relabel (foldSurvivingNilEquiv (α + := β)).symm).Equiv + ((W.relabel (foldSurvivingNilEquiv (α := α)).symm).relabel + (foldSurvivingMapEquiv e []))) + have heq : e.trans (foldSurvivingNilEquiv (α := β)).symm = + (foldSurvivingNilEquiv (α := α)).symm.trans (foldSurvivingMapEquiv e []) + := + _root_.Equiv.ext (fun _ => Subtype.ext rfl) + exact ⟨(Equiv.relabelTrans W e (foldSurvivingNilEquiv (α := β)).symm).trans + (heq ▸ (Equiv.relabelTrans W (foldSurvivingNilEquiv (α := α)).symm + (foldSurvivingMapEquiv e [])).symm)⟩ + -- ═══════ n + 1: PEEL THE HEAD PAIR ═══════ + | succ n ih => + intro α β W e ps hp hlen + match ps, hp, hlen with + -- ═══════ The list is empty anyway ═══════ + | [], _, _ => + change Nonempty (((W.relabel e).relabel (foldSurvivingNilEquiv (α + := β)).symm).Equiv + ((W.relabel (foldSurvivingNilEquiv (α := α)).symm).relabel + (foldSurvivingMapEquiv e []))) + have heq : e.trans (foldSurvivingNilEquiv (α := β)).symm = + (foldSurvivingNilEquiv (α := α)).symm.trans (foldSurvivingMapEquiv e + []) := + _root_.Equiv.ext (fun _ => Subtype.ext rfl) + exact ⟨(Equiv.relabelTrans W e (foldSurvivingNilEquiv (α + := β)).symm).trans + (heq ▸ (Equiv.relabelTrans W (foldSurvivingNilEquiv (α := α)).symm + (foldSurvivingMapEquiv e [])).symm)⟩ + -- ═══════ Glue the head, recurse on the tail at the + -- surviving-label type ═══════ + | (i, j) :: ps, hp, hlen => + have hij' := hp.head_ne + -- Inner type bookkeeping + have hij_inner : e.symm (e i) ≠ e.symm (e j) := fun h => + hij' (e.injective (by rw [← e.apply_symm_apply (e i), + ← e.apply_symm_apply (e j), h])) + have hsep' : PairsSep (e.symm (e i)) (e.symm (e j)) ps := by + intro q hq; have := hp.sep q hq + exact ⟨fun h => this.fst_ne_fst (h.trans (e.symm_apply_apply i)), + fun h => this.fst_ne_snd (h.trans (e.symm_apply_apply j)), + fun h => this.snd_ne_fst (h.trans (e.symm_apply_apply i)), + fun h => this.snd_ne_snd (h.trans (e.symm_apply_apply j))⟩ + set L' := coercePairsList (e.symm (e i)) (e.symm (e j)) ps hsep' + set L₂ := coercePairsList i j ps hp.sep + have hlen' : L'.length ≤ n := by + simp only [L']; rw [coercePairsList_length] + simp only [List.length_cons] at hlen; omega + have hwf' : PairsWF L' := coercePairsList_wf _ _ ps hp.tail hsep' + have hwf₂ : PairsWF L₂ := coercePairsList_wf _ _ ps hp.tail hp.sep + -- The inner relabelling (sends val x to e x) + set σ : SurvivingLabel α (e.symm (e i)) (e.symm (e j)) ≃ + SurvivingLabel β (e i) (e j) := + _root_.Equiv.subtypeEquiv e (fun x => ⟨ + fun ⟨h1, h2⟩ => ⟨fun h => h1 (e.injective + (show e x = e (e.symm (e i)) from by + rw [e.apply_symm_apply]; exact h)), + fun h => h2 (e.injective + (show e x = e (e.symm (e j)) from by + rw [e.apply_symm_apply]; exact h))⟩, + fun ⟨h1, h2⟩ => ⟨fun h => h1 + (show e x = e i from by + rw [← e.apply_symm_apply (e i)]; exact congrArg e h), + fun h => h2 + (show e x = e j from by + rw [← e.apply_symm_apply (e j)]; exact congrArg e h)⟩⟩) + set castE := survLabelCastEquiv e i j + -- First IH: main relabelling at the inner type + obtain ⟨e_ih⟩ := ih (W.gluePair (e.symm (e i)) (e.symm (e j)) hij_inner) + σ L' hwf' hlen' + -- Second IH: cast relabelling + have hlen₂ : L'.length ≤ n := hlen' + obtain ⟨e_cast⟩ := ih (W.gluePair (e.symm (e i)) (e.symm (e j)) hij_inner) + castE L' hwf' hlen₂ + -- Pair list equalities + have hL_eq : coercePairsList (e i) (e j) (mapPairs e ps) + (mapPairs_sep e i j ps hp.sep) = + mapPairs σ L' := by + -- Use coercePairsList_mapPairs_comm + coercePairsList_cast_eq + + -- composition + have h1 := coercePairsList_mapPairs_comm e i j ps hp.sep + (mapPairs_sep e i j ps hp.sep) + have h2 := (coercePairsList_cast_eq e i j ps hsep' hp.sep).symm + rw [h1, h2, mapPairs_mapPairs] + exact mapPairs_congr (fun x => Subtype.ext rfl) L' + have hL_cast : mapPairs castE L' = L₂ := + coercePairsList_cast_eq e i j ps hsep' hp.sep + -- Core equiv bridges + have hgpr := gluePairRelabel W e + (show e i ≠ e j from e.injective.ne hij') + have hgpc := gluePair_cast_equiv W e i j hij' + have hwf₁ := coercePairsList_wf (e i) (e j) (mapPairs e ps) + (mapPairs_wf e ps hp.tail) (mapPairs_sep e i j ps hp.sep) + -- Perm bridges for the list equalities + have list_perm_fwd : (coercePairsList (e i) (e j) (mapPairs e ps) + (mapPairs_sep e i j ps hp.sep)).Perm (mapPairs σ L') := by rw [hL_eq] + have list_perm_cast : (mapPairs castE L').Perm L₂ := by rw [hL_cast] + -- Key relabelling equivs to the final type + let flattenMapEquiv : FoldSurviving (SurvivingLabel β (e i) (e j)) + (mapPairs σ L') ≃ + FoldSurviving β ((e i, e j) :: mapPairs e ps) := + (foldSurvivingPermEquiv list_perm_fwd).symm.trans + (foldFlatten (e i) (e j) (mapPairs e ps) (mapPairs_sep e i j ps + hp.sep)) + let castFlatten : FoldSurviving (SurvivingLabel α i j) (mapPairs castE L') + ≃ + FoldSurviving β ((e i, e j) :: mapPairs e ps) := + (foldSurvivingPermEquiv list_perm_cast).trans + ((foldFlatten i j ps hp.sep).trans (foldSurvivingMapEquiv e ((i, j) :: + ps))) + -- All composed relabellings agree on values (send ⟨⟨x,_⟩,_⟩ ↦ ⟨e x,_⟩) + have hequivs : (foldSurvivingMapEquiv σ L').trans flattenMapEquiv = + (foldSurvivingMapEquiv castE L').trans castFlatten := + _root_.Equiv.ext (fun ⟨⟨_, _⟩, _⟩ => by + simp only [foldSurvivingMapEquiv, flattenMapEquiv, + castFlatten, foldSurvivingPermEquiv, foldFlatten] + exact Subtype.ext rfl) + -- Compose the first IH + congruence at the mapPairs σ L' type + have composed₂ := (glueListCongr hgpr (mapPairs σ L') + (mapPairs_wf σ L' hwf')).trans e_ih + -- Bridge from cPL label type to mapPairs σ L' label type (via + -- glueListEqEquiv) + have bridge_lhs := glueListEqEquiv + ((W.relabel e).gluePair (e i) (e j) (show e i ≠ e j from e.injective.ne + hij')) + hL_eq hwf₁ (mapPairs_wf σ L' hwf') list_perm_fwd + -- Bridge from mapPairs castE L' to L₂ label type + have bridge_cast := glueListEqEquiv + ((W.gluePair (e.symm (e i)) (e.symm (e j)) hij_inner).relabel castE) + hL_cast (mapPairs_wf castE L' hwf') hwf₂ list_perm_cast + -- Assemble the full equiv at the final type + have hlhs := glueList_cons (W.relabel e) (e i, e j) (mapPairs e ps) + (mapPairs_wf e ((i, j) :: ps) hp) + have hrhs := glueList_cons W (i, j) ps hp + -- The key equalities on composed equivs + have ff_eq : (foldSurvivingPermEquiv list_perm_fwd).trans flattenMapEquiv + = + foldFlatten (e i) (e j) (mapPairs e ps) (mapPairs_sep e i j ps hp.sep) + := + _root_.Equiv.ext (fun _ => by + simp only [flattenMapEquiv, _root_.Equiv.trans_apply, + _root_.Equiv.symm_apply_apply]) + -- Build the chain from the composed LHS form to the RHS + have final : + ((glueList ((W.relabel e).gluePair (e i) (e j) (e.injective.ne hij')) + (coercePairsList (e i) (e j) (mapPairs e ps) + (mapPairs_sep e i j ps hp.sep)) hwf₁).relabel + (foldFlatten (e i) (e j) (mapPairs e ps) (mapPairs_sep e i j ps + hp.sep))).Equiv + ((glueList (W.gluePair i j hij') L₂ hwf₂).relabel + ((foldFlatten i j ps hp.sep).trans + (foldSurvivingMapEquiv e ((i, j) :: ps)))) := by + -- Rewrite the LHS relabelling to its composed form + suffices h : + ((glueList ((W.relabel e).gluePair (e i) (e j) (e.injective.ne hij')) + (coercePairsList (e i) (e j) (mapPairs e ps) + (mapPairs_sep e i j ps hp.sep)) hwf₁).relabel + ((foldSurvivingPermEquiv list_perm_fwd).trans + flattenMapEquiv)).Equiv + ((glueList (W.gluePair i j hij') L₂ hwf₂).relabel + ((foldFlatten i j ps hp.sep).trans + (foldSurvivingMapEquiv e ((i, j) :: ps)))) by + exact ff_eq ▸ h + -- Bridge via hequivs at the inner glueList level + have mid_equiv : + ((glueList (W.gluePair (e.symm (e i)) (e.symm (e j)) hij_inner) L' + hwf').relabel + ((foldSurvivingMapEquiv σ L').trans flattenMapEquiv)).Equiv + ((glueList (W.gluePair (e.symm (e i)) (e.symm (e j)) hij_inner) L' + hwf').relabel + ((foldSurvivingMapEquiv castE L').trans castFlatten)) := by + rw [hequivs]; exact Equiv.refl _ + -- LHS chain: decompose relabelling, apply bridges and IH + have lhs_chain := + ((Equiv.relabelTrans (glueList _ _ hwf₁) + (foldSurvivingPermEquiv list_perm_fwd) flattenMapEquiv).symm.trans + (Equiv.relabelCongr (bridge_lhs.trans composed₂) + flattenMapEquiv)).trans + (Equiv.relabelTrans (glueList _ L' hwf') + (foldSurvivingMapEquiv σ L') flattenMapEquiv) + -- RHS chain: decompose through e_cast, bridge, and gluePair_cast_equiv + have rhs_chain := + ((Equiv.relabelTrans (glueList _ L' hwf') + (foldSurvivingMapEquiv castE L') castFlatten).symm.trans + (Equiv.relabelCongr e_cast.symm castFlatten)).trans + (((Equiv.relabelTrans (glueList _ (mapPairs castE L') (mapPairs_wf + castE L' hwf')) + (foldSurvivingPermEquiv list_perm_cast) + ((foldFlatten i j ps hp.sep).trans + (foldSurvivingMapEquiv e ((i, j) :: ps)))).symm.trans + (Equiv.relabelCongr bridge_cast + ((foldFlatten i j ps hp.sep).trans + (foldSurvivingMapEquiv e ((i, j) :: ps))))).trans + (Equiv.relabelCongr (glueListCongr hgpc L₂ hwf₂) + ((foldFlatten i j ps hp.sep).trans + (foldSurvivingMapEquiv e ((i, j) :: ps))))) + exact lhs_chain.trans (mid_equiv.trans rhs_chain) + -- Fold back using glueList_cons + have rhs_fold := (Equiv.relabelTrans + (glueList (W.gluePair i j hij') L₂ hwf₂) + (foldFlatten i j ps hp.sep) (foldSurvivingMapEquiv e ((i, j) :: + ps))).symm + exact ⟨(hlhs ▸ final).trans (rhs_fold.trans (hrhs ▸ Equiv.refl _))⟩ + +/-- Iterated gluing commutes with relabelling: gluing the mapped +pairs in the relabelled fragment is the original fold, relabelled +by the induced surviving-label equivalence. -/ +noncomputable def glueListRelabel {α β : Type} (W : Fragment α) + (e : α ≃ β) (ps : List (α × α)) (hp : PairsWF ps) : + (glueList (W.relabel e) (mapPairs e ps) (mapPairs_wf e ps hp)).Equiv + ((glueList W ps hp).relabel (foldSurvivingMapEquiv e ps)) := + (show Nonempty _ from by exact nonempty_glueList_relabel_aux ps.length W e ps hp le_rfl).some + +/-! ### Concatenation: folding in two stages -/ + +/-- The separation of the second block from the first. -/ +abbrev PairsSepAll (ps qs : List (α × α)) : Prop := + ∀ q ∈ qs, ∀ p ∈ ps, PairDisjoint q p + +/-- Pairs avoiding an earlier pair list lift into its surviving +labels. -/ +def liftPairs (ps : List (α × α)) : + (qs : List (α × α)) → PairsSepAll ps qs → + List (FoldSurviving α ps × FoldSurviving α ps) + | [], _ => [] + | q :: qs, h => + (⟨q.1, fun p hp => ⟨(h q List.mem_cons_self p hp).fst_ne_fst, + (h q List.mem_cons_self p hp).fst_ne_snd⟩⟩, + ⟨q.2, fun p hp => ⟨(h q List.mem_cons_self p hp).snd_ne_fst, + (h q List.mem_cons_self p hp).snd_ne_snd⟩⟩) :: + liftPairs ps qs + (fun r hr => h r (List.mem_cons.mpr (Or.inr hr))) + +/-- The separation hypothesis of a well-formed concatenation. -/ +theorem PairsWF.append_sep {ps qs : List (α × α)} + (h : PairsWF (ps ++ qs)) : PairsSepAll ps qs := by + intro q hq p hp + unfold PairsWF at h + rw [List.flatMap_append] at h + have hd := List.disjoint_of_nodup_append h + have hq1 : q.1 ∈ qs.flatMap (fun r => [r.1, r.2]) := + List.mem_flatMap.mpr ⟨q, hq, List.mem_cons_self⟩ + have hq2 : q.2 ∈ qs.flatMap (fun r => [r.1, r.2]) := + List.mem_flatMap.mpr ⟨q, hq, + List.mem_cons.mpr (Or.inr List.mem_cons_self)⟩ + have hp1 : p.1 ∈ ps.flatMap (fun r => [r.1, r.2]) := + List.mem_flatMap.mpr ⟨p, hp, List.mem_cons_self⟩ + have hp2 : p.2 ∈ ps.flatMap (fun r => [r.1, r.2]) := + List.mem_flatMap.mpr ⟨p, hp, + List.mem_cons.mpr (Or.inr List.mem_cons_self)⟩ + exact ⟨fun he => hd hp1 (he ▸ hq1), fun he => hd hp2 (he ▸ hq1), + fun he => hd hp1 (he ▸ hq2), fun he => hd hp2 (he ▸ hq2)⟩ + +/-- The first block of a well-formed concatenation. -/ +theorem PairsWF.append_left {ps qs : List (α × α)} + (h : PairsWF (ps ++ qs)) : PairsWF ps := by + unfold PairsWF at h ⊢ + rw [List.flatMap_append] at h + exact (List.nodup_append.mp h).1 + +/-- The second block of a well-formed concatenation. -/ +theorem PairsWF.append_right {ps qs : List (α × α)} + (h : PairsWF (ps ++ qs)) : PairsWF qs := by + unfold PairsWF at h ⊢ + rw [List.flatMap_append] at h + exact (List.nodup_append.mp h).2.1 + +/-- The val-projection of the flattened lifted list is the original +flattened list. -/ +theorem liftPairs_flatMap_map_val (ps : List (α × α)) : + ∀ (qs : List (α × α)) (h : PairsSepAll ps qs), + ((liftPairs ps qs h).flatMap (fun r => [r.1, r.2])).map + Subtype.val = + qs.flatMap (fun q => [q.1, q.2]) + | [], _ => rfl + | _ :: qs, h => by + simp only [liftPairs, List.flatMap_cons, List.map_append] + exact congrArg ([_, _] ++ ·) (liftPairs_flatMap_map_val ps qs _) + +/-- The lifted second block is well-formed. -/ +theorem liftPairs_wf (ps qs : List (α × α)) + (hwf : PairsWF qs) (h : PairsSepAll ps qs) : + PairsWF (liftPairs ps qs h) := by + have hnodup : (((liftPairs ps qs h).flatMap + (fun r => [r.1, r.2])).map Subtype.val).Nodup := by + rw [liftPairs_flatMap_map_val] + exact hwf + exact List.Nodup.of_map Subtype.val hnodup + +/-- Each lifted pair comes from an original pair. -/ +theorem liftPairs_mem_of (ps : List (α × α)) : + ∀ (qs : List (α × α)) (h : PairsSepAll ps qs) + (r : FoldSurviving α ps × FoldSurviving α ps) + (_ : r ∈ liftPairs ps qs h), + ∃ q ∈ qs, r.1.val = q.1 ∧ r.2.val = q.2 + | q :: qs, h, r, hr => by + simp only [liftPairs] at hr + rcases List.mem_cons.mp hr with heq | htail + · subst heq + exact ⟨q, List.mem_cons_self, rfl, rfl⟩ + · obtain ⟨q', hq', h1, h2⟩ := liftPairs_mem_of ps qs _ r htail + exact ⟨q', List.mem_cons.mpr (Or.inr hq'), h1, h2⟩ + +/-- Each original pair lifts to a member. -/ +theorem liftPairs_mem (ps : List (α × α)) : + ∀ (qs : List (α × α)) (h : PairsSepAll ps qs) + (q : α × α) (_ : q ∈ qs), + ∃ r ∈ liftPairs ps qs h, r.1.val = q.1 ∧ r.2.val = q.2 + | q' :: qs, h, q, hq => by + rcases List.mem_cons.mp hq with rfl | htail + · exact ⟨_, List.mem_cons_self, rfl, rfl⟩ + · obtain ⟨r, hr, h1, h2⟩ := liftPairs_mem ps qs _ q htail + exact ⟨r, List.mem_cons.mpr (Or.inr hr), h1, h2⟩ + +/-- The two-stage surviving labels flatten to the concatenation's +surviving labels. -/ +def appendFlatten (ps qs : List (α × α)) (h : PairsSepAll ps qs) : + FoldSurviving (FoldSurviving α ps) (liftPairs ps qs h) ≃ + FoldSurviving α (ps ++ qs) where + toFun x := ⟨x.val.val, fun p hp => by + rcases List.mem_append.mp hp with hps | hqs + · exact x.val.prop p hps + · obtain ⟨r, hr, h1, h2⟩ := liftPairs_mem ps qs h p hqs + have hxr := x.prop r hr + exact ⟨fun he => hxr.1 (Subtype.ext (h1 ▸ he)), + fun he => hxr.2 (Subtype.ext (h2 ▸ he))⟩⟩ + invFun x := ⟨⟨x.val, fun p hp => + x.prop p (List.mem_append.mpr (Or.inl hp))⟩, + fun r hr => by + obtain ⟨q, hq, h1, h2⟩ := liftPairs_mem_of ps qs h r hr + have hx := x.prop q (List.mem_append.mpr (Or.inr hq)) + exact ⟨fun he => hx.1 (h1 ▸ congrArg Subtype.val he), + fun he => hx.2 (h2 ▸ congrArg Subtype.val he)⟩⟩ + left_inv _ := Subtype.ext (Subtype.ext rfl) + right_inv _ := Subtype.ext rfl + +/-- Coercing a concatenation coerces blockwise. -/ +theorem coercePairsList_append (i j : α) : + ∀ (ps qs : List (α × α)) (h : PairsSep i j (ps ++ qs)), + coercePairsList i j (ps ++ qs) h = + coercePairsList i j ps + (fun r hr => h r (List.mem_append.mpr (Or.inl hr))) ++ + coercePairsList i j qs + (fun r hr => h r (List.mem_append.mpr (Or.inr hr))) + | [], _, _ => rfl + | p :: ps, qs, h => by + simp only [List.cons_append, coercePairsList] + exact congrArg₂ List.cons rfl (coercePairsList_append i j ps qs _) + +/-- Lifting over the empty first block is mapping through the nil +equivalence. -/ +private theorem liftPairs_nil_eq : + ∀ (qs : List (α × α)) (h : PairsSepAll [] qs), + liftPairs [] qs h = mapPairs foldSurvivingNilEquiv.symm qs + | [], _ => rfl + | _ :: qs, _h => + congrArg₂ List.cons + (Prod.ext (Subtype.ext rfl) (Subtype.ext rfl)) + (liftPairs_nil_eq qs _) + +/-- Lifting over a cons factors through the flattening of the +head glue. -/ +private theorem liftPairs_cons_eq (i j : α) (ps : List (α × α)) + (hsep : PairsSep i j ps) : + ∀ (qs : List (α × α)) (h : PairsSepAll ((i, j) :: ps) qs) + (hq : PairsSep i j qs) + (h'' : PairsSepAll (coercePairsList i j ps hsep) + (coercePairsList i j qs hq)), + mapPairs (foldFlatten i j ps hsep).symm + (liftPairs ((i, j) :: ps) qs h) = + liftPairs (coercePairsList i j ps hsep) + (coercePairsList i j qs hq) h'' + | [], _, _, _ => rfl + | q :: qs, _, hq, h'' => by + simp only [liftPairs, coercePairsList, mapPairs, List.map_cons, + Prod.map] + exact congrArg₂ List.cons + (Prod.ext (Subtype.ext (Subtype.ext rfl)) + (Subtype.ext (Subtype.ext rfl))) + (liftPairs_cons_eq i j ps hsep qs _ _ _) + +/-- Mapping back and forth through an equivalence cancels. -/ +private theorem mapPairs_cancel {α β : Type} (e : α ≃ β) : + ∀ ps : List (β × β), mapPairs e (mapPairs e.symm ps) = ps + | [] => rfl + | p :: ps => by + simp only [mapPairs, List.map_cons, Prod.map] + exact congrArg₂ List.cons + (Prod.ext (e.apply_symm_apply p.1) (e.apply_symm_apply p.2)) + (mapPairs_cancel e ps) + +/-- The nil case of two-stage folding. -/ +private theorem nonempty_glueList_append_nil {α : Type} + (W : Fragment α) (qs : List (α × α)) + (h : PairsWF (([] : List (α × α)) ++ qs)) : + Nonempty ((glueList W ([] ++ qs) h).Equiv + ((glueList (glueList W [] h.append_left) + (liftPairs [] qs h.append_sep) + (liftPairs_wf [] qs h.append_right h.append_sep)).relabel + (appendFlatten [] qs h.append_sep))) := by + have hperm : (liftPairs [] qs h.append_sep).Perm + (mapPairs foldSurvivingNilEquiv.symm qs) := by + rw [liftPairs_nil_eq] + have b1 := glueListEqEquiv (glueList W [] h.append_left) + (liftPairs_nil_eq qs h.append_sep) + (liftPairs_wf [] qs h.append_right h.append_sep) + (mapPairs_wf _ qs h.append_right) hperm + have hEq : glueList (glueList W [] h.append_left) + (mapPairs foldSurvivingNilEquiv.symm qs) + (mapPairs_wf _ qs h.append_right) = + glueList (W.relabel foldSurvivingNilEquiv.symm) + (mapPairs foldSurvivingNilEquiv.symm qs) + (mapPairs_wf _ qs h.append_right) := by + rw [glueList_nil] + have b3 := glueListRelabel W foldSurvivingNilEquiv.symm qs + h.append_right + -- assemble + have hcomp : (foldSurvivingPermEquiv hperm).trans + ((foldSurvivingPermEquiv hperm).symm.trans + (appendFlatten [] qs h.append_sep)) = + appendFlatten [] qs h.append_sep := + _root_.Equiv.ext (fun x => + congrArg _ ((foldSurvivingPermEquiv hperm).symm_apply_apply x)) + refine ⟨Fragment.Equiv.symm ?_⟩ + refine Fragment.Equiv.trans + (hcomp ▸ (Equiv.relabelTrans _ + (foldSurvivingPermEquiv hperm) + ((foldSurvivingPermEquiv hperm).symm.trans + (appendFlatten [] qs h.append_sep))).symm) ?_ + refine Fragment.Equiv.trans + (Equiv.relabelCongr (hEq ▸ b1) _) ?_ + refine Fragment.Equiv.trans + (Equiv.relabelCongr b3 _) ?_ + refine Fragment.Equiv.trans (Equiv.relabelTrans _ _ _) ?_ + have hfinal : (foldSurvivingMapEquiv foldSurvivingNilEquiv.symm + qs).trans + ((foldSurvivingPermEquiv hperm).symm.trans + (appendFlatten [] qs h.append_sep)) = + _root_.Equiv.refl _ := + _root_.Equiv.ext (fun _ => Subtype.ext rfl) + rw [hfinal] + exact Equiv.relabelRefl _ + +/-- Two-stage folding (existence): gluing a concatenation is +gluing the first block, then the lifted second block. -/ +private theorem nonempty_glueList_append_aux (n : ℕ) : + ∀ {α : Type} (W : Fragment α) (ps qs : List (α × α)) + (h : PairsWF (ps ++ qs)) (_ : ps.length ≤ n), + Nonempty ((glueList W (ps ++ qs) h).Equiv + ((glueList (glueList W ps h.append_left) + (liftPairs ps qs h.append_sep) + (liftPairs_wf ps qs h.append_right h.append_sep)).relabel + (appendFlatten ps qs h.append_sep))) := by + induction n with + | zero => + intro α W ps qs h hlen + obtain rfl : ps = [] := + List.eq_nil_of_length_eq_zero (Nat.le_zero.mp hlen) + exact nonempty_glueList_append_nil W qs h + | succ n ih => + intro α W ps qs h hlen + match ps, h, hlen with + | [], h, _ => + exact nonempty_glueList_append_nil W qs h + | (i, j) :: ps, h, hlen => + have hne : i ≠ j := h.append_left.head_ne + have hsep : PairsSep i j (ps ++ qs) := h.sep + have happend := coercePairsList_append i j ps qs hsep + have hwf_c : PairsWF + (coercePairsList i j ps + (fun r hr => hsep r (List.mem_append.mpr (Or.inl hr))) ++ + coercePairsList i j qs + (fun r hr => hsep r (List.mem_append.mpr (Or.inr hr)))) := + happend ▸ coercePairsList_wf i j (ps ++ qs) h.tail hsep + have hlen' : (coercePairsList i j ps + (fun r hr => hsep r (List.mem_append.mpr (Or.inl hr)))).length + ≤ n := by + rw [coercePairsList_length] + simp only [List.length_cons] at hlen + omega + obtain ⟨e_ih⟩ := ih (W.gluePair i j hne) _ _ hwf_c hlen' + -- list bridge on the left + have b1 := glueListEqEquiv (W.gluePair i j hne) happend + (coercePairsList_wf i j (ps ++ qs) h.tail hsep) hwf_c + (by rw [happend]) + -- lifted-pairs bridge on the right + have hlift : mapPairs (foldFlatten i j ps h.append_left.sep) + (liftPairs + (coercePairsList i j ps h.append_left.sep) + (coercePairsList i j qs + (fun r hr => hsep r (List.mem_append.mpr (Or.inr hr)))) + (hwf_c.append_sep)) = + liftPairs ((i, j) :: ps) qs h.append_sep := by + rw [← liftPairs_cons_eq i j ps h.append_left.sep qs + h.append_sep + (fun r hr => hsep r (List.mem_append.mpr (Or.inr hr))) + hwf_c.append_sep] + exact mapPairs_cancel _ _ + -- outer-relabel commutation on the right + have e_rel := glueListRelabel + (glueList (W.gluePair i j hne) + (coercePairsList i j ps h.append_left.sep) + (coercePairsList_wf i j ps h.append_left.tail + h.append_left.sep)) + (foldFlatten i j ps h.append_left.sep) + (liftPairs _ _ hwf_c.append_sep) + (liftPairs_wf _ _ hwf_c.append_right hwf_c.append_sep) + have b2 := glueListEqEquiv + ((glueList (W.gluePair i j hne) + (coercePairsList i j ps h.append_left.sep) + (coercePairsList_wf i j ps h.append_left.tail + h.append_left.sep)).relabel + (foldFlatten i j ps h.append_left.sep)) + hlift + (mapPairs_wf _ _ + (liftPairs_wf _ _ hwf_c.append_right hwf_c.append_sep)) + (liftPairs_wf _ _ h.append_right h.append_sep) + (by rw [hlift]) + refine ⟨?_⟩ + change ((glueList W ((i, j) :: (ps ++ qs)) h).Equiv _) + rw [glueList_cons W (i, j) (ps ++ qs) h] + -- move the left side to the two-stage form + have hcompL : (foldSurvivingPermEquiv (by rw [happend] : + (coercePairsList i j (ps ++ qs) h.sep).Perm _)).trans + ((foldSurvivingPermEquiv (by rw [happend])).symm.trans + (foldFlatten i j (ps ++ qs) h.sep)) = + foldFlatten i j (ps ++ qs) h.sep := + _root_.Equiv.ext (fun x => by simp) + refine Fragment.Equiv.trans + (hcompL ▸ (Equiv.relabelTrans _ + (foldSurvivingPermEquiv (by rw [happend])) + ((foldSurvivingPermEquiv (by rw [happend])).symm.trans + (foldFlatten i j (ps ++ qs) h.sep))).symm) ?_ + refine Fragment.Equiv.trans + (Equiv.relabelCongr (b1.trans e_ih) _) ?_ + refine Fragment.Equiv.trans (Equiv.relabelTrans _ _ _) ?_ + -- move the right side to the two-stage form + refine Fragment.Equiv.symm ?_ + have hconsR := glueList_cons W (i, j) ps h.append_left + rw [hconsR] + refine Fragment.Equiv.trans + (Equiv.relabelCongr b2.symm _) ?_ + refine Fragment.Equiv.trans (Equiv.relabelTrans _ _ _) ?_ + refine Fragment.Equiv.trans + (Equiv.relabelCongr e_rel _) ?_ + refine Fragment.Equiv.trans (Equiv.relabelTrans _ _ _) ?_ + have heqF : (foldSurvivingMapEquiv + (foldFlatten i j ps h.append_left.sep) + (liftPairs _ _ hwf_c.append_sep)).trans + ((foldSurvivingPermEquiv (by rw [hlift])).trans + (appendFlatten ((i, j) :: ps) qs h.append_sep)) = + (appendFlatten _ _ hwf_c.append_sep).trans + ((foldSurvivingPermEquiv (by rw [happend])).symm.trans + (foldFlatten i j (ps ++ qs) h.sep)) := + _root_.Equiv.ext (fun _ => Subtype.ext rfl) + exact heqF ▸ Fragment.Equiv.refl _ + +/-- **Two-stage folding**: gluing a concatenation of pair lists is +gluing the first block, then the lifted second block, up to the +flattening of survivors. -/ +noncomputable def glueListAppend (W : Fragment α) + (ps qs : List (α × α)) (h : PairsWF (ps ++ qs)) : + (glueList W (ps ++ qs) h).Equiv + ((glueList (glueList W ps h.append_left) + (liftPairs ps qs h.append_sep) + (liftPairs_wf ps qs h.append_right h.append_sep)).relabel + (appendFlatten ps qs h.append_sep)) := + (show Nonempty _ from by + exact nonempty_glueList_append_aux ps.length W ps qs h le_rfl).some + +/-! ### Disjoint-union embedding: left -/ + +/-- Embed a pair list into the left summand of a disjoint +union. -/ +def inlPairs (ps : List (α × α)) : + List ((α ⊕ β) × (α ⊕ β)) := + ps.map (Prod.map Sum.inl Sum.inl) + +private theorem inlPairs_flatMap : + ∀ (ps : List (α × α)), + (inlPairs (β := β) ps).flatMap + (fun p => [p.1, p.2]) = + (ps.flatMap (fun q => [q.1, q.2])).map Sum.inl + | [] => rfl + | _ :: ps => by + simp only [inlPairs, List.map_cons, + List.flatMap_cons, List.map_append, Prod.map, + List.map_cons, List.map_nil] + exact congrArg _ (inlPairs_flatMap ps) + +/-- `inlPairs` preserves well-formedness. -/ +theorem inlPairs_wf (ps : List (α × α)) + (hp : PairsWF ps) : + PairsWF (inlPairs (β := β) ps) := by + unfold PairsWF; rw [inlPairs_flatMap] + exact hp.map Sum.inl_injective + +/-- The surviving-label equivalence for left-embedded +pairs: inl-labels survive iff they survive the original +list; all inr-labels survive. -/ +def inlFoldEquiv (ps : List (α × α)) : + FoldSurviving (α ⊕ β) + (inlPairs (β := β) ps) ≃ + (FoldSurviving α ps) ⊕ β where + toFun := fun ⟨x, hx⟩ => + match x, hx with + | Sum.inl a, hx => Sum.inl ⟨a, + fun p hp => by + have := hx + (Prod.map Sum.inl Sum.inl p) + (List.mem_map.mpr ⟨p, hp, rfl⟩) + simp only [Prod.map] at this + exact + ⟨fun h => this.1 + (congrArg Sum.inl h), + fun h => this.2 + (congrArg Sum.inl h)⟩⟩ + | Sum.inr b, _ => Sum.inr b + invFun := fun y => + match y with + | Sum.inl ⟨a, ha⟩ => ⟨Sum.inl a, + fun p hp => by + obtain ⟨q, hq, rfl⟩ := + List.mem_map.mp hp + simp only [Prod.map] + exact + ⟨fun h => (ha q hq).1 + (Sum.inl.inj h), + fun h => (ha q hq).2 + (Sum.inl.inj h)⟩⟩ + | Sum.inr b => ⟨Sum.inr b, + fun p hp => by + obtain ⟨_, _, rfl⟩ := + List.mem_map.mp hp + exact ⟨Sum.inr_ne_inl, + Sum.inr_ne_inl⟩⟩ + left_inv := fun ⟨x, _⟩ => by + cases x with + | inl => exact Subtype.ext rfl + | inr => exact Subtype.ext rfl + right_inv := fun y => by + cases y with + | inl a => + exact congrArg Sum.inl (Subtype.ext rfl) + | inr => rfl + +/-! ### Disjoint-union embedding: right -/ + +/-- Embed a pair list into the right summand of a disjoint +union. -/ +def inrPairs (qs : List (β × β)) : + List ((α ⊕ β) × (α ⊕ β)) := + qs.map (Prod.map Sum.inr Sum.inr) + +private theorem inrPairs_flatMap : + ∀ (qs : List (β × β)), + (inrPairs (α := α) qs).flatMap + (fun p => [p.1, p.2]) = + (qs.flatMap (fun q => [q.1, q.2])).map Sum.inr + | [] => rfl + | _ :: qs => by + simp only [inrPairs, List.map_cons, + List.flatMap_cons, List.map_append, Prod.map, + List.map_cons, List.map_nil] + exact congrArg _ (inrPairs_flatMap qs) + +/-- `inrPairs` preserves well-formedness. -/ +theorem inrPairs_wf (qs : List (β × β)) + (hq : PairsWF qs) : + PairsWF (inrPairs (α := α) qs) := by + unfold PairsWF; rw [inrPairs_flatMap] + exact hq.map Sum.inr_injective + +/-- The surviving-label equivalence for right-embedded +pairs: inr-labels survive iff they survive the original +list; all inl-labels survive. -/ +def inrFoldEquiv (qs : List (β × β)) : + FoldSurviving (α ⊕ β) + (inrPairs (α := α) qs) ≃ + α ⊕ (FoldSurviving β qs) where + toFun := fun ⟨x, hx⟩ => + match x, hx with + | Sum.inl a, _ => Sum.inl a + | Sum.inr b, hx => Sum.inr ⟨b, + fun p hp => by + have := hx + (Prod.map Sum.inr Sum.inr p) + (List.mem_map.mpr ⟨p, hp, rfl⟩) + simp only [Prod.map] at this + exact + ⟨fun h => this.1 + (congrArg Sum.inr h), + fun h => this.2 + (congrArg Sum.inr h)⟩⟩ + invFun := fun y => + match y with + | Sum.inl a => ⟨Sum.inl a, + fun p hp => by + obtain ⟨_, _, rfl⟩ := + List.mem_map.mp hp + exact ⟨Sum.inl_ne_inr, + Sum.inl_ne_inr⟩⟩ + | Sum.inr ⟨b, hb⟩ => ⟨Sum.inr b, + fun p hp => by + obtain ⟨q, hq, rfl⟩ := + List.mem_map.mp hp + simp only [Prod.map] + exact + ⟨fun h => (hb q hq).1 + (Sum.inr.inj h), + fun h => (hb q hq).2 + (Sum.inr.inj h)⟩⟩ + left_inv := fun ⟨x, _⟩ => by + cases x with + | inl => exact Subtype.ext rfl + | inr => exact Subtype.ext rfl + right_inv := fun y => by + cases y with + | inl => rfl + | inr b => + exact congrArg Sum.inr (Subtype.ext rfl) + +/-! ### Helpers for disjoint-union embedding proofs -/ + +/-- Relabelling the left factor of a disjoint union equals +relabelling the whole union by `Equiv.sumCongr`. -/ +private noncomputable def relabelDisjUnionLeft + {α' : Type} + (W : Fragment α) (W' : Fragment β) + (e : α ≃ α') : + ((W.relabel e).disjUnion W').Equiv + ((W.disjUnion W').relabel + (_root_.Equiv.sumCongr e + (_root_.Equiv.refl β))) where + flagEquiv := _root_.Equiv.refl _ + vertexEquiv := _root_.Equiv.refl _ + attach_comm f := by + rcases f with f | f + · change ((W.attach f).map Sum.inl Sum.inl).map + id (_root_.Equiv.sumCongr e + (_root_.Equiv.refl β)) = + (((W.attach f).map id e).map Sum.inl + Sum.inl).map (_root_.Equiv.refl _) id + rcases W.attach f with v | ℓ <;> rfl + · change ((W'.attach f).map Sum.inr Sum.inr).map + id (_root_.Equiv.sumCongr e + (_root_.Equiv.refl β)) = + ((W'.attach f).map Sum.inr Sum.inr).map + (_root_.Equiv.refl _) id + rcases W'.attach f with v | ℓ <;> rfl + pairing_comm f := by rcases f with f | f <;> rfl + circles_eq := rfl + +/-- Relabelling the right factor of a disjoint union equals +relabelling the whole union by `Equiv.sumCongr`. -/ +private noncomputable def relabelDisjUnionRight + {β' : Type} + (W : Fragment α) (W' : Fragment β) + (e : β ≃ β') : + (W.disjUnion (W'.relabel e)).Equiv + ((W.disjUnion W').relabel + (_root_.Equiv.sumCongr (_root_.Equiv.refl α) + e)) where + flagEquiv := _root_.Equiv.refl _ + vertexEquiv := _root_.Equiv.refl _ + attach_comm f := by + rcases f with f | f + · change ((W.attach f).map Sum.inl Sum.inl).map + id (_root_.Equiv.sumCongr + (_root_.Equiv.refl α) e) = + ((W.attach f).map Sum.inl Sum.inl).map + (_root_.Equiv.refl _) id + rcases W.attach f with v | ℓ <;> rfl + · change ((W'.attach f).map Sum.inr Sum.inr).map + id (_root_.Equiv.sumCongr + (_root_.Equiv.refl α) e) = + (((W'.attach f).map id e).map Sum.inr + Sum.inr).map (_root_.Equiv.refl _) id + rcases W'.attach f with v | ℓ <;> rfl + pairing_comm f := by rcases f with f | f <;> rfl + circles_eq := rfl + +/-- The coerced inl-pairs equal the mapped inl-pairs of the +coerced original pairs. -/ +private theorem coercePairsList_inlPairs_comm + (i j : α) (hij : i ≠ j) : + ∀ (ps : List (α × α)) + (hsep : PairsSep (Sum.inl i : α ⊕ β) + (Sum.inl j) (inlPairs (β := β) ps)) + (hsep' : PairsSep i j ps), + coercePairsList (Sum.inl i : α ⊕ β) + (Sum.inl j) (inlPairs (β := β) ps) hsep = + mapPairs (ambientLabelEquiv i j).symm + (inlPairs (β := β) + (coercePairsList i j ps hsep')) + | [], _, _ => rfl + | _ :: ps, _, _ => + congrArg₂ List.cons + (Prod.ext (Subtype.ext rfl) + (Subtype.ext rfl)) + (coercePairsList_inlPairs_comm + i j hij ps _ _) + +/-! ### Disjoint-union left: main induction -/ + +private theorem nonempty_glueList_disjUnion_left_cons + (n : ℕ) + (ih : ∀ {α β : Type} (W₁ : Fragment α) + (W₂ : Fragment β) + (ps : List (α × α)) (hp : PairsWF ps) + (_ : ps.length ≤ n), + Nonempty + ((glueList (W₁.disjUnion W₂) + (inlPairs ps) (inlPairs_wf ps hp)).Equiv + (((glueList W₁ ps hp).disjUnion + W₂).relabel + (inlFoldEquiv ps).symm))) + {α β : Type} (W₁ : Fragment α) (W₂ : Fragment β) + (i j : α) (ps : List (α × α)) (hp : PairsWF ((i, j) :: ps)) + (hlen : ((i, j) :: ps).length ≤ n + 1) : + Nonempty + ((glueList (W₁.disjUnion W₂) + (inlPairs ((i, j) :: ps)) (inlPairs_wf ((i, j) :: ps) hp)).Equiv + (((glueList W₁ ((i, j) :: ps) hp).disjUnion W₂).relabel + (inlFoldEquiv ((i, j) :: ps)).symm)) := by + have hij := hp.head_ne + have hij' : (Sum.inl i : α ⊕ β) ≠ + Sum.inl j := + fun h => hij (Sum.inl.inj h) + have hp_inl := + inlPairs_wf (β := β) + ((i, j) :: ps) hp + have hwf_cp := + coercePairsList_wf i j ps + hp.tail hp.sep + have hwf_scp := + coercePairsList_wf (Sum.inl i) + (Sum.inl j) (inlPairs (β := β) ps) + hp_inl.tail hp_inl.sep + have hlen' : + (coercePairsList i j ps + hp.sep).length ≤ n := by + rw [coercePairsList_length] + simp only [List.length_cons] at hlen + omega + -- Abbreviations + let amb := + ambientLabelEquiv (β := β) i j + let cp := + coercePairsList i j ps hp.sep + let scp := + coercePairsList (Sum.inl i) + (Sum.inl j) + (inlPairs (β := β) ps) + hp_inl.sep + -- Tail list bridge + have h_cpc := + coercePairsList_inlPairs_comm + i j hij ps hp_inl.sep hp.sep + -- mapPairs cancellation + have h_mp : + mapPairs amb scp = + inlPairs (β := β) cp := by + change mapPairs + (ambientLabelEquiv i j) + (coercePairsList (Sum.inl i) + (Sum.inl j) + (inlPairs (β := β) ps) + hp_inl.sep) = + inlPairs (β := β) + (coercePairsList i j ps hp.sep) + rw [h_cpc, mapPairs_mapPairs, + show (ambientLabelEquiv + (β := β) i j).symm.trans + (ambientLabelEquiv i j) = + _root_.Equiv.refl _ from + _root_.Equiv.ext + (ambientLabelEquiv i j).apply_symm_apply] + exact List.map_id _ + -- IH + obtain ⟨e_ih⟩ := ih + (W₁.gluePair i j hij) W₂ + cp hwf_cp hlen' + -- gluePairDisjUnion + have e_gp := + gluePairDisjUnion W₁ W₂ hij + -- glueListRelabel + have e_rel := glueListRelabel + ((W₁.disjUnion W₂).gluePair + (Sum.inl i) (Sum.inl j) hij') + amb scp hwf_scp + -- glueListEqEquiv + have e_eq := glueListEqEquiv + (((W₁.disjUnion W₂).gluePair + (Sum.inl i) (Sum.inl j) + hij').relabel amb) + h_mp + (mapPairs_wf amb scp hwf_scp) + (inlPairs_wf cp hwf_cp) + (h_mp ▸ List.Perm.refl _) + -- glueListCongr + have e_congr := glueListCongr + (Fragment.Equiv.symm e_gp) + (inlPairs (β := β) cp) + (inlPairs_wf cp hwf_cp) + -- Inner chain + have inner := + ((Equiv.relabelCongr e_rel.symm + (foldSurvivingPermEquiv + (h_mp ▸ List.Perm.refl + _))).trans + e_eq).trans + (e_congr.trans e_ih) + -- Outer relabelling bridge + let σ := + (inlFoldEquiv (β := β) cp).trans + ((_root_.Equiv.sumCongr + (foldFlatten i j ps hp.sep) + (_root_.Equiv.refl β)).trans + (inlFoldEquiv (β := β) + ((i, j) :: ps)).symm) + -- LHS equiv equality + have hLHS : + (foldSurvivingMapEquiv amb + scp).trans + ((foldSurvivingPermEquiv + (h_mp ▸ List.Perm.refl + _)).trans σ) = + foldFlatten (Sum.inl i) + (Sum.inl j) + (inlPairs (β := β) ps) + hp_inl.sep := + _root_.Equiv.ext (fun x => by + obtain ⟨⟨a | b, -, -⟩, -⟩ := x + · exact Subtype.ext rfl + · exact Subtype.ext rfl) + -- RHS equiv equality + have hRHS : + (inlFoldEquiv (β := β) + cp).symm.trans σ = + (_root_.Equiv.sumCongr + (foldFlatten i j ps hp.sep) + (_root_.Equiv.refl β)).trans + (inlFoldEquiv (β := β) + ((i, j) :: ps)).symm := + _root_.Equiv.ext (fun y => by + rcases y with ⟨⟨a, -⟩, -⟩ | b + · exact Subtype.ext rfl + · exact Subtype.ext rfl) + -- RHS chain + have rhs_chain : + (((glueList + (W₁.gluePair i j hij) + cp hwf_cp).disjUnion + W₂).relabel + ((inlFoldEquiv (β := β) + cp).symm.trans σ)).Equiv + ((((glueList + (W₁.gluePair i j hij) + cp hwf_cp).relabel + (foldFlatten i j ps + hp.sep)).disjUnion + W₂).relabel + (inlFoldEquiv (β := β) + ((i, j) :: ps)).symm) := by + rw [hRHS] + exact + (Equiv.relabelTrans _ _ _).symm.trans + (Equiv.relabelCongr + (relabelDisjUnionLeft _ W₂ + _).symm _) + -- Main proof + refine ⟨?_⟩ + change ((W₁.disjUnion W₂).glueList + ((Sum.inl i, Sum.inl j) :: + inlPairs (β := β) ps) + hp_inl).Equiv + (((W₁.glueList ((i, j) :: ps) + hp).disjUnion + W₂).relabel + (inlFoldEquiv (β := β) + ((i, j) :: ps)).symm) + rw [glueList_cons (W₁.disjUnion W₂) + (Sum.inl i, Sum.inl j) + (inlPairs (β := β) ps) hp_inl, + glueList_cons W₁ (i, j) ps hp] + rw [← hLHS] + exact + ((Equiv.relabelTrans _ + (foldSurvivingMapEquiv amb scp) + ((foldSurvivingPermEquiv + _).trans σ)).symm.trans + ((Equiv.relabelTrans _ + (foldSurvivingPermEquiv _) + σ).symm.trans + (Equiv.relabelCongr inner + σ))).trans + ((Equiv.relabelTrans _ + (inlFoldEquiv (β := β) + cp).symm σ).trans + rhs_chain) + +private theorem nonempty_glueList_disjUnion_left_aux + (n : ℕ) : + ∀ {α β : Type} (W₁ : Fragment α) + (W₂ : Fragment β) + (ps : List (α × α)) (hp : PairsWF ps) + (_ : ps.length ≤ n), + Nonempty + ((glueList (W₁.disjUnion W₂) + (inlPairs ps) (inlPairs_wf ps hp)).Equiv + (((glueList W₁ ps hp).disjUnion + W₂).relabel + (inlFoldEquiv ps).symm)) := by + induction n with + -- ═══════ n = 0: NO PAIRS LEFT TO GLUE ═══════ + | zero => + intro α β W₁ W₂ ps hp hlen + have hnil : ps = [] := + List.eq_nil_of_length_eq_zero + (Nat.le_zero.mp hlen) + subst hnil + have heq : + (foldSurvivingNilEquiv + (α := α ⊕ β)).symm = + (_root_.Equiv.sumCongr + (foldSurvivingNilEquiv + (α := α)).symm + (_root_.Equiv.refl β)).trans + (inlFoldEquiv (β := β) []).symm := + _root_.Equiv.ext (fun x => by + cases x <;> exact Subtype.ext rfl) + exact ⟨(heq ▸ (Equiv.relabelTrans + (W₁.disjUnion W₂) + (_root_.Equiv.sumCongr + (foldSurvivingNilEquiv + (α := α)).symm + (_root_.Equiv.refl β)) + (inlFoldEquiv (β := β) + []).symm).symm).trans + (Equiv.relabelCongr + (relabelDisjUnionLeft W₁ W₂ + (foldSurvivingNilEquiv + (α := α)).symm).symm + (inlFoldEquiv (β := β) []).symm)⟩ + -- ═══════ n + 1: PEEL THE HEAD PAIR ═══════ + | succ n ih => + intro α β W₁ W₂ ps hp hlen + match ps, hp, hlen with + -- ═══════ The list is empty anyway ═══════ + | [], _, _ => + have heq : + (foldSurvivingNilEquiv + (α := α ⊕ β)).symm = + (_root_.Equiv.sumCongr + (foldSurvivingNilEquiv + (α := α)).symm + (_root_.Equiv.refl β)).trans + (inlFoldEquiv (β := β) []).symm := + _root_.Equiv.ext (fun x => by + cases x <;> exact Subtype.ext rfl) + exact ⟨(heq ▸ (Equiv.relabelTrans + (W₁.disjUnion W₂) + (_root_.Equiv.sumCongr + (foldSurvivingNilEquiv + (α := α)).symm + (_root_.Equiv.refl β)) + (inlFoldEquiv (β := β) + []).symm).symm).trans + (Equiv.relabelCongr + (relabelDisjUnionLeft W₁ W₂ + (foldSurvivingNilEquiv + (α := α)).symm).symm + (inlFoldEquiv (β := β) []).symm)⟩ + -- ═══════ Glue the head on the left component, recurse ═══════ + | (i, j) :: ps, hp, hlen => + exact nonempty_glueList_disjUnion_left_cons n ih W₁ W₂ i j ps hp hlen + +/-- Iterated left-side gluing commutes with disjoint +union: gluing the `inlPairs`-embedded pair list in the +disjoint union is equivalent to gluing `W₁` alone and +then taking the disjoint union with `W₂`, up to the +canonical label isomorphism `inlFoldEquiv`. -/ +noncomputable def glueListDisjUnionLeft + {α β : Type} + (W₁ : Fragment α) (W₂ : Fragment β) + (ps : List (α × α)) (hp : PairsWF ps) : + (glueList (W₁.disjUnion W₂) + (inlPairs ps) + (inlPairs_wf ps hp)).Equiv + (((glueList W₁ ps hp).disjUnion + W₂).relabel + (inlFoldEquiv ps).symm) := + (show Nonempty _ from by + exact nonempty_glueList_disjUnion_left_aux + ps.length W₁ W₂ ps hp le_rfl).some + +/-- Iterated right-side gluing commutes with disjoint +union: gluing the `inrPairs`-embedded pair list in the +disjoint union is equivalent to gluing `W₂` alone and +then taking the disjoint union with `W₁`, up to the +canonical label isomorphism `inrFoldEquiv`. -/ +noncomputable def glueListDisjUnionRight + {α β : Type} + (W₁ : Fragment α) (W₂ : Fragment β) + (qs : List (β × β)) (hq : PairsWF qs) : + (glueList (W₁.disjUnion W₂) + (inrPairs qs) + (inrPairs_wf qs hq)).Equiv + (((W₁.disjUnion + (glueList W₂ qs hq)).relabel + (inrFoldEquiv qs).symm)) := by + -- Derive from glueListDisjUnionLeft via + -- disjUnionComm and glueListRelabel + let sc := _root_.Equiv.sumComm β α + -- mapPairs sc (inlPairs qs) = inrPairs qs + have h_mp : + mapPairs sc + (inlPairs (α := β) (β := α) qs) = + inrPairs (α := α) (β := β) qs := by + simp only [mapPairs, inlPairs, inrPairs, + List.map_map]; rfl + -- Abbreviations + have h_perm : + (mapPairs sc + (inlPairs (α := β) (β := α) qs)).Perm + (inrPairs (α := α) (β := β) qs) := + h_mp ▸ List.Perm.refl _ + let fSPE_e := + foldSurvivingPermEquiv h_perm + let fSME_e := + foldSurvivingMapEquiv sc + (inlPairs (α := β) (β := α) qs) + let ife := + inlFoldEquiv (α := β) (β := α) qs + let sc' := _root_.Equiv.sumComm α + (FoldSurviving β qs) + -- Step 1: swap W₁, W₂ + have e1 := + glueListCongr + (disjUnionComm W₁ W₂) + (inrPairs qs) (inrPairs_wf qs hq) + -- Step 2: bridge pair lists + have e2 := + (glueListEqEquiv + ((W₂.disjUnion W₁).relabel sc) + h_mp + (mapPairs_wf sc _ + (inlPairs_wf (β := α) qs hq)) + (inrPairs_wf qs hq) + (h_mp ▸ List.Perm.refl _)).symm + -- Step 3: pull relabel through glueList + have e3 := + glueListRelabel (W₂.disjUnion W₁) sc + (inlPairs (β := α) qs) + (inlPairs_wf (β := α) qs hq) + -- Step 4: left embedding theorem + have e4 := + glueListDisjUnionLeft W₂ W₁ qs hq + -- Step 5: swap result back + have e5 := + disjUnionComm (glueList W₂ qs hq) W₁ + -- Composed equiv equation + have h_eq : + sc'.trans (ife.symm.trans + (fSME_e.trans fSPE_e)) = + (inrFoldEquiv (α := α) qs).symm := + _root_.Equiv.ext (fun x => by + rcases x with a | ⟨b, -⟩ + · exact Subtype.ext rfl + · exact Subtype.ext rfl) + -- Chain the equivalences + exact + (e1.trans e2).trans + ((Equiv.relabelCongr e3 fSPE_e).trans + ((Equiv.relabelTrans _ fSME_e + fSPE_e).trans + ((Equiv.relabelCongr e4 + (fSME_e.trans fSPE_e)).trans + ((Equiv.relabelTrans _ + ife.symm + (fSME_e.trans fSPE_e)).trans + ((Equiv.relabelCongr e5 + (ife.symm.trans + (fSME_e.trans fSPE_e))).trans + ((Equiv.relabelTrans _ + sc' + (ife.symm.trans + (fSME_e.trans fSPE_e))).trans + (h_eq ▸ Equiv.refl _))))))) + +/-! ### The swap-components fold lemma -/ + +/-- The flatMap of a pair-swapped list is a permutation +of the original flatMap. -/ +private theorem swap_flatMap_perm : + ∀ (ps : List (α × α)), + ((ps.map Prod.swap).flatMap + (fun p => [p.1, p.2])).Perm + (ps.flatMap (fun p => [p.1, p.2])) + | [] => List.Perm.refl [] + | (a, b) :: ps => by + simp only [List.map_cons, Prod.swap, + List.flatMap_cons] + exact (List.Perm.append_left [b, a] + (swap_flatMap_perm ps)).trans + (List.Perm.swap a b _) + +/-- Swapping every pair preserves well-formedness. -/ +theorem swapPairs_wf (ps : List (α × α)) + (hp : PairsWF ps) : + PairsWF (ps.map Prod.swap) := + (swap_flatMap_perm ps).nodup_iff.mpr hp + +/-- Surviving labels are invariant under swapping pair +components: `x ≠ p.1 ∧ x ≠ p.2` iff +`x ≠ p.2 ∧ x ≠ p.1`. -/ +def swapFoldEquiv (ps : List (α × α)) : + FoldSurviving α (ps.map Prod.swap) ≃ + FoldSurviving α ps where + toFun x := + ⟨x.val, fun p hp => by + have := x.prop p.swap + (List.mem_map.mpr ⟨p, hp, rfl⟩) + exact ⟨this.2, this.1⟩⟩ + invFun x := + ⟨x.val, fun p hp => by + obtain ⟨q, hq, rfl⟩ := + List.mem_map.mp hp + exact ⟨(x.prop q hq).2, + (x.prop q hq).1⟩⟩ + left_inv _ := Subtype.ext rfl + right_inv _ := Subtype.ext rfl + +/-- PairsSep is symmetric in the removed labels and +invariant under swapping pair components. -/ +private theorem pairsSep_swap (i j : α) + (ps : List (α × α)) + (h : PairsSep i j ps) : + PairsSep j i (ps.map Prod.swap) := by + intro q hq + obtain ⟨r, hr, rfl⟩ := List.mem_map.mp hq + have := h r hr + exact this.swap_left.swap_right + +/-- Coercing a swapped pair list relates to +mapping `survLabelSwapEquiv` over the swap of the +original coerced list. -/ +private theorem coercePairsList_swap + (i j : α) : + ∀ (ps : List (α × α)) + (h : PairsSep i j ps) + (h' : PairsSep j i (ps.map Prod.swap)), + coercePairsList j i + (ps.map Prod.swap) h' = + mapPairs (survLabelSwapEquiv α i j).symm + ((coercePairsList i j ps h).map + Prod.swap) + | [], _, _ => rfl + | _ :: ps, h, h' => by + simp only [List.map_cons, Prod.swap, + coercePairsList, mapPairs, Prod.map] + exact congrArg₂ List.cons + (Prod.ext (Subtype.ext rfl) + (Subtype.ext rfl)) + (coercePairsList_swap i j ps _ _) + +private theorem nonempty_glueList_swap_aux + (n : ℕ) : + ∀ {α : Type} (W : Fragment α) + (ps : List (α × α)) (hp : PairsWF ps) + (_ : ps.length ≤ n), + Nonempty + ((glueList W (ps.map Prod.swap) + (swapPairs_wf ps hp)).Equiv + ((glueList W ps hp).relabel + (swapFoldEquiv ps).symm)) := by + induction n with + -- ═══════ n = 0: NO PAIRS LEFT TO GLUE ═══════ + | zero => + intro α W ps hp hlen + have hnil : ps = [] := + List.eq_nil_of_length_eq_zero + (Nat.le_zero.mp hlen) + subst hnil + change Nonempty + ((W.relabel + foldSurvivingNilEquiv.symm).Equiv + ((W.relabel + foldSurvivingNilEquiv.symm).relabel + (swapFoldEquiv []).symm)) + have heq : + foldSurvivingNilEquiv (α := α).symm = + foldSurvivingNilEquiv.symm.trans + (swapFoldEquiv (α := α) []).symm := + _root_.Equiv.ext + (fun _ => Subtype.ext rfl) + exact ⟨(Equiv.relabelTrans W + foldSurvivingNilEquiv.symm + (swapFoldEquiv []).symm).symm.trans + (heq ▸ Equiv.refl _)⟩ + -- ═══════ n + 1: PEEL THE HEAD PAIR ═══════ + | succ n ih => + intro α W ps hp hlen + match ps, hp, hlen with + -- ═══════ The list is empty anyway ═══════ + | [], _, _ => + change Nonempty + ((W.relabel + foldSurvivingNilEquiv.symm).Equiv + ((W.relabel + foldSurvivingNilEquiv.symm).relabel + (swapFoldEquiv []).symm)) + have heq : + foldSurvivingNilEquiv + (α := α).symm = + foldSurvivingNilEquiv.symm.trans + (swapFoldEquiv (α := α) []).symm := + _root_.Equiv.ext + (fun _ => Subtype.ext rfl) + exact ⟨(Equiv.relabelTrans W + foldSurvivingNilEquiv.symm + (swapFoldEquiv []).symm).symm.trans + (heq ▸ Equiv.refl _)⟩ + -- ═══════ Glue the head with its ends swapped, recurse ═══════ + | (i, j) :: ps, hp, hlen => + have hij := hp.head_ne + have hji : j ≠ i := Ne.symm hij + -- Swapped well-formedness + have hp_swap := + swapPairs_wf ((i, j) :: ps) hp + have sep_ij := hp.sep + have sep_ji_swap := + pairsSep_swap i j ps sep_ij + -- Coerced pair lists + let cpl_ij := + coercePairsList i j ps sep_ij + let cpl_swap := + coercePairsList j i + (ps.map Prod.swap) + sep_ji_swap + have hwf_ij := + coercePairsList_wf i j ps + hp.tail sep_ij + have hwf_swap := + coercePairsList_wf j i + (ps.map Prod.swap) + (swapPairs_wf ps hp.tail) + sep_ji_swap + -- Length bound for IH + have hlen' : cpl_ij.length ≤ n := by + simp only [cpl_ij] + rw [coercePairsList_length] + simp only [List.length_cons] + at hlen + omega + -- Swap equiv abbreviations + let sle_ij := + survLabelSwapEquiv α i j + let sle_ji := sle_ij.symm + -- Commutation: cpl_swap relates to + -- mapPairs sle_ji (cpl_ij.map swap) + have h_cps := + coercePairsList_swap i j ps + sep_ij sep_ji_swap + have h_mp : + mapPairs sle_ji + (cpl_ij.map Prod.swap) = + cpl_swap := + h_cps.symm + -- Perm witness (shared between + -- e_eq and fSPE) + have hperm : + (mapPairs sle_ji + (cpl_ij.map Prod.swap)).Perm + cpl_swap := + h_mp ▸ List.Perm.refl _ + -- Step 1: gluePairSwap + have e_swap := + gluePairSwap W hji + -- Step 2: glueListCongr + have e_congr := + glueListCongr e_swap + cpl_swap hwf_swap + -- Step 3: glueListRelabel + have hwf_swap_ij := + swapPairs_wf cpl_ij hwf_ij + have e_rel := + glueListRelabel + (W.gluePair i j hij) sle_ji + (cpl_ij.map Prod.swap) + hwf_swap_ij + -- Step 4: glueListEqEquiv bridge + have e_eq := + glueListEqEquiv + ((W.gluePair i j hij).relabel + sle_ji) + h_mp + (mapPairs_wf sle_ji _ + hwf_swap_ij) + hwf_swap hperm + -- Step 5: IH + obtain ⟨e_ih⟩ := + ih (W.gluePair i j hij) + cpl_ij hwf_ij hlen' + -- Abbreviations for equivs + let fSPE := + foldSurvivingPermEquiv hperm + let fSME := + foldSurvivingMapEquiv sle_ji + (cpl_ij.map Prod.swap) + let ff_ji := + foldFlatten j i + (ps.map Prod.swap) + sep_ji_swap + let ff_ij := + foldFlatten i j ps sep_ij + -- Inner chain: + -- glueList (gp j i) cpl_swap + -- ≡ glueList (gp i j) cpl_ij + -- |>.relabel composed + have inner := + (e_congr.trans + (e_eq.symm.trans + (Equiv.relabelCongr e_rel + fSPE))).trans + ((Equiv.relabelTrans _ + fSME fSPE).trans + (Equiv.relabelCongr e_ih + (fSME.trans fSPE))) + -- Composed equiv equation + have h_eq : + (((swapFoldEquiv cpl_ij).symm.trans + (fSME.trans fSPE)).trans + ff_ji) = + ff_ij.trans + (swapFoldEquiv + ((i, j) :: ps)).symm := + _root_.Equiv.ext + (fun _ => Subtype.ext rfl) + -- Bridge: h_eq lifts to fragment equiv + let glW := + glueList (W.gluePair i j hij) + cpl_ij hwf_ij + have bridge : + (glW.relabel + (((swapFoldEquiv + cpl_ij).symm.trans + (fSME.trans fSPE)).trans + ff_ji)).Equiv + (glW.relabel + (ff_ij.trans + (swapFoldEquiv + ((i, j) :: ps)).symm)) + := by rw [h_eq]; exact Equiv.refl _ + -- Assemble via glueList_cons + refine ⟨?_⟩ + change (glueList W + ((j, i) :: ps.map Prod.swap) + hp_swap).Equiv + ((glueList W ((i, j) :: ps) + hp).relabel + (swapFoldEquiv + ((i, j) :: ps)).symm) + rw [glueList_cons W (j, i) + (ps.map Prod.swap) hp_swap, + glueList_cons W (i, j) ps hp] + let sfe_cons := + (swapFoldEquiv + ((i, j) :: ps)).symm + exact + (Equiv.relabelCongr inner + ff_ji).trans + ((Equiv.relabelTrans + (glW.relabel + (swapFoldEquiv cpl_ij).symm) + (fSME.trans fSPE) ff_ji).trans + ((Equiv.relabelTrans glW + (swapFoldEquiv cpl_ij).symm + ((fSME.trans fSPE).trans + ff_ji)).trans + (bridge.trans + (Equiv.relabelTrans glW + ff_ij sfe_cons).symm))) + +/-- Gluing a pair list is symmetric in each pair's +components: swapping every `(i,j)` to `(j,i)` yields +an equivalent fold, up to the canonical +`swapFoldEquiv`. -/ +noncomputable def glueListSwap + {α : Type} + (W : Fragment α) + (ps : List (α × α)) + (hp : PairsWF ps) : + (glueList W (ps.map Prod.swap) + (swapPairs_wf ps hp)).Equiv + ((glueList W ps hp).relabel + (swapFoldEquiv ps).symm) := + (show Nonempty _ from by + exact nonempty_glueList_swap_aux ps.length + W ps hp le_rfl).some + +/-! ### The reorder theorem -/ + +/-- The doubly-coerced tail list in q-then-p order equals +`mapPairs swapLabelEquiv.symm` of the doubly-coerced tail in p-then-q order. -/ +private theorem doubly_coerced_swap_eq + {i j k l : α} (hik : i ≠ k) (hil : i ≠ l) (hjk : j ≠ k) (hjl : j ≠ l) : + ∀ (ps : List (α × α)) + (hsep_ij : PairsSep i j ps) (hsep_kl : PairsSep k l ps) + (hsep_inner_ij : PairsSep (⟨k, hik.symm, hjk.symm⟩ : SurvivingLabel α i j) + ⟨l, hil.symm, hjl.symm⟩ (coercePairsList i j ps hsep_ij)) + (hsep_inner_kl : PairsSep (⟨i, hik, hil⟩ : SurvivingLabel α k l) + ⟨j, hjk, hjl⟩ (coercePairsList k l ps hsep_kl)), + coercePairsList ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ + (coercePairsList i j ps hsep_ij) hsep_inner_ij = + mapPairs (swapLabelEquiv hik hil hjk hjl).symm + (coercePairsList ⟨i, hik, hil⟩ ⟨j, hjk, hjl⟩ + (coercePairsList k l ps hsep_kl) hsep_inner_kl) + | [], _, _, _, _ => rfl + | _ :: ps, hsep_ij, hsep_kl, hsep_inner_ij, hsep_inner_kl => by + simp only [coercePairsList, mapPairs, List.map_cons, Prod.map] + exact congrArg₂ List.cons + (Prod.ext (Subtype.ext (Subtype.ext rfl)) (Subtype.ext (Subtype.ext rfl))) + (doubly_coerced_swap_eq hik hil hjk hjl ps _ _ _ _) + +/-- The coerced pair list permutes when the original does. -/ +private theorem coercePairsList_perm (i j : α) + {ps qs : List (α × α)} (hperm : ps.Perm qs) + (hp : PairsSep i j ps) (hq : PairsSep i j qs) : + (coercePairsList i j ps hp).Perm (coercePairsList i j qs hq) := by + classical + induction hperm with + | nil => exact List.Perm.nil + | @cons x _ _ _ ih => + exact List.Perm.cons _ (ih _ _) + | @swap x y _ => + exact List.Perm.swap _ _ _ + | @trans l₁ l₂ l₃ h₁ h₂ ih₁ ih₂ => + have hmid : PairsSep i j l₂ := + fun q hq => hp q (h₁.mem_iff.mpr hq) + exact (ih₁ _ hmid).trans (ih₂ hmid _) + +/-- Auxiliary: the reorder theorem by induction on list length +(needed because the cons case recurses at a different type). -/ +private theorem nonempty_glueList_perm_aux (n : ℕ) : + ∀ {α : Type} (W : Fragment α) + {ps qs : List (α × α)} + (hperm : ps.Perm qs) (hp : PairsWF ps) + (_ : ps.length ≤ n), + Nonempty ((glueList W ps hp).Equiv + ((glueList W qs (hp.perm hperm)).relabel + (foldSurvivingPermEquiv hperm).symm)) := by + induction n with + -- ═══════ n = 0: BOTH LISTS ARE EMPTY ═══════ + | zero => + intro α W ps qs hperm hp hlen + have hnil : ps = [] := List.eq_nil_of_length_eq_zero (Nat.le_zero.mp hlen) + subst hnil + have hqs : qs = [] := hperm.symm.eq_nil + subst hqs + have hid : (foldSurvivingPermEquiv hperm).symm = + _root_.Equiv.refl _ := + _root_.Equiv.ext (fun ⟨_, _⟩ => Subtype.ext rfl) + exact ⟨hid ▸ (Equiv.relabelRefl _).symm⟩ + -- ═══════ n + 1: INDUCT ON THE PERMUTATION ═══════ + | succ n ih => + intro α W ps qs hperm hp hlen + induction hperm generalizing W with + -- ═══════ nil: nothing to reorder ═══════ + | nil => + have hid : (foldSurvivingPermEquiv + (List.Perm.nil (α := α × α))).symm = + _root_.Equiv.refl _ := + _root_.Equiv.ext (fun ⟨_, _⟩ => Subtype.ext rfl) + exact ⟨hid ▸ (Equiv.relabelRefl _).symm⟩ + -- ═══════ cons: a shared head, reorder the tails ═══════ + | @cons p ps' qs' hperm _ih_unused => + -- Both sides glue p first; use the outer IH on the coerced tails. + have hlen_tail : (coercePairsList p.1 p.2 ps' hp.sep).length ≤ n := by + rw [coercePairsList_length]; simp only [List.length_cons] at hlen; omega + have hp' : PairsWF (p :: qs') := hp.perm (List.Perm.cons p hperm) + have hwf_cps := coercePairsList_wf p.1 p.2 ps' hp.tail hp.sep + have hwf_cqs := coercePairsList_wf p.1 p.2 qs' hp'.tail hp'.sep + have hperm_c := coercePairsList_perm p.1 p.2 hperm hp.sep hp'.sep + -- Apply the outer IH at type SurvivingLabel α p.1 p.2 + obtain ⟨e_sub⟩ := ih (W.gluePair p.1 p.2 hp.head_ne) hperm_c hwf_cps + hlen_tail + -- e_sub relates the inner glues; now compose relabellings + set B := glueList (W.gluePair p.1 p.2 hp.head_ne) + (coercePairsList p.1 p.2 qs' hp'.sep) hwf_cqs + have step₁ := (Equiv.relabelCongr e_sub (foldFlatten p.1 p.2 ps' hp.sep)) + have step₂ := step₁.trans (Equiv.relabelTrans B _ _) + have step₃ := (Equiv.relabelTrans B (foldFlatten p.1 p.2 qs' hp'.sep) + (foldSurvivingPermEquiv (List.Perm.cons p hperm)).symm).symm + have hequivs : + (foldSurvivingPermEquiv hperm_c).symm.trans (foldFlatten p.1 p.2 ps' + hp.sep) = + (foldFlatten p.1 p.2 qs' hp'.sep).trans + (foldSurvivingPermEquiv (List.Perm.cons p hperm)).symm := + _root_.Equiv.ext (fun ⟨⟨_, _⟩, _⟩ => Subtype.ext rfl) + exact ⟨(glueList_cons W p ps' hp ▸ (glueList_cons W p qs' hp' ▸ + (hequivs ▸ step₂).trans step₃))⟩ + -- ═══════ swap: the two heads exchange ═══════ + | @swap p q ps' => + -- swap p q ps' : (q :: p :: ps').Perm (p :: q :: ps') + -- hp : PairsWF (q :: p :: ps') + let := Classical.typeDecidableEq α + have hp' : PairsWF (p :: q :: ps') := hp.perm (List.Perm.swap p q ps') + have hq12 := hp.head_ne + have hp12 := hp.tail.head_ne + have h_pq := hp.head_disjoint_of p List.mem_cons_self + have hik : q.1 ≠ p.1 := h_pq.fst_ne_fst.symm + have hil : q.1 ≠ p.2 := h_pq.snd_ne_fst.symm + have hjk : q.2 ≠ p.1 := h_pq.fst_ne_snd.symm + have hjl : q.2 ≠ p.2 := h_pq.snd_ne_snd.symm + have hsep_q_ps' : PairsSep q.1 q.2 ps' := + fun r hr => hp.sep r (List.mem_cons.mpr (Or.inr hr)) + have hsep_p_ps' : PairsSep p.1 p.2 ps' := + fun r hr => hp'.sep r (List.mem_cons.mpr (Or.inr hr)) + have hwf_q := coercePairsList_wf q.1 q.2 (p :: ps') hp.tail hp.sep + have hwf_p := coercePairsList_wf p.1 p.2 (q :: ps') hp'.tail hp'.sep + have hwf_dbl_qp := coercePairsList_wf _ _ _ hwf_q.tail hwf_q.sep + have hwf_dbl_pq := coercePairsList_wf _ _ _ hwf_p.tail hwf_p.sep + -- List equality: doubly-coerced in q-then-p order = mapPairs swapLE.symm + -- of p-then-q order + have hlist_eq := doubly_coerced_swap_eq hik hil hjk hjl ps' + hsep_q_ps' hsep_p_ps' hwf_q.sep hwf_p.sep + -- gluePairComm: (W.gp q).gp p' ≃ ((W.gp p).gp q').relabel swapLE.symm + have hcomm := gluePairComm W hq12 hp12 hik hil hjk hjl + -- Relabelling theorem for the tail + have hlen_dbl : (coercePairsList (⟨q.1, hik, hil⟩ : SurvivingLabel α p.1 + p.2) + ⟨q.2, hjk, hjl⟩ (coercePairsList p.1 p.2 ps' hsep_p_ps') + hwf_p.sep).length ≤ n := by + rw [coercePairsList_length, coercePairsList_length] + simp only [List.length_cons] at hlen; omega + obtain ⟨e_relabel⟩ := nonempty_glueList_relabel_aux n + ((W.gluePair p.1 p.2 hp12).gluePair + (⟨q.1, hik, hil⟩ : SurvivingLabel α p.1 p.2) ⟨q.2, hjk, hjl⟩ + (fun h => hq12 (congrArg Subtype.val h))) + (swapLabelEquiv hik hil hjk hjl).symm _ hwf_dbl_pq hlen_dbl + -- Core equivalence at the doubly-coerced level + have core := (glueListCongr hcomm _ + (mapPairs_wf (swapLabelEquiv hik hil hjk hjl).symm _ hwf_dbl_pq)).trans + e_relabel + -- Bridge: use glueListEqEquiv to relate dbl_qp and mapPairs forms + have list_perm : (coercePairsList (⟨p.1, hik.symm, hjk.symm⟩ : + SurvivingLabel α q.1 q.2) + ⟨p.2, hil.symm, hjl.symm⟩ (coercePairsList q.1 q.2 ps' hsep_q_ps') + hwf_q.sep).Perm + (mapPairs (swapLabelEquiv hik hil hjk hjl).symm + (coercePairsList (⟨q.1, hik, hil⟩ : SurvivingLabel α p.1 p.2) + ⟨q.2, hjk, hjl⟩ (coercePairsList p.1 p.2 ps' hsep_p_ps') + hwf_p.sep)) := by + rw [hlist_eq] + let inner_qp := (W.gluePair q.1 q.2 hq12).gluePair + ⟨p.1, hik.symm, hjk.symm⟩ ⟨p.2, hil.symm, hjl.symm⟩ + (fun h => hp12 (congrArg Subtype.val h)) + have bridge := glueListEqEquiv inner_qp hlist_eq hwf_dbl_qp + (mapPairs_wf (swapLabelEquiv hik hil hjk hjl).symm _ hwf_dbl_pq) + list_perm + -- bridge : (glueList inner_qp dbl_qp _).relabel (fSPE list_perm) ≃ + -- glueList inner_qp (mapPairs swapLE.symm dbl_pq) _ + -- core : glueList inner_qp (mapPairs..) _ ≃ (glueList inner_pq dbl_pq + -- _).relabel (fSME..) + -- Compose to get: (glueList inner_qp dbl_qp _).relabel (fSPE list_perm) ≃ + -- RHS + have bridged := bridge.trans core + -- Composed foldFlattens + let ff_qp := (foldFlatten (⟨p.1, hik.symm, hjk.symm⟩ : SurvivingLabel α + q.1 q.2) + ⟨p.2, hil.symm, hjl.symm⟩ (coercePairsList q.1 q.2 ps' hsep_q_ps') + hwf_q.sep).trans + (foldFlatten q.1 q.2 (p :: ps') hp.sep) + let ff_pq := (foldFlatten (⟨q.1, hik, hil⟩ : SurvivingLabel α p.1 p.2) + ⟨q.2, hjk, hjl⟩ (coercePairsList p.1 p.2 ps' hsep_p_ps') + hwf_p.sep).trans + (foldFlatten p.1 p.2 (q :: ps') hp'.sep) + -- toTarget maps from FS..(mapPairs..) to FS α (q::p::ps') + let toTarget := (foldSurvivingPermEquiv list_perm).symm.trans ff_qp + -- Relabel both sides of bridged by toTarget + have lifted := Equiv.relabelCongr bridged toTarget + -- Merge both relabellings using relabelTrans + have combined := + (Equiv.relabelTrans _ (foldSurvivingPermEquiv list_perm) + toTarget).symm.trans + (lifted.trans + (Equiv.relabelTrans _ + (foldSurvivingMapEquiv (swapLabelEquiv hik hil hjk hjl).symm _) + toTarget)) + -- combined : (glueList inner_qp dbl_qp _).relabel ((fSPE list_perm).trans + -- toTarget) ≃ + -- (glueList inner_pq dbl_pq _).relabel ((fSME..).trans toTarget) + -- Show the composed relabellings simplify + have lhs_eq : (foldSurvivingPermEquiv list_perm).trans toTarget = ff_qp := + _root_.Equiv.ext (fun _ => Subtype.ext rfl) + have rhs_eq : + (foldSurvivingMapEquiv (swapLabelEquiv hik hil hjk hjl).symm _).trans + toTarget = + ff_pq.trans (foldSurvivingPermEquiv (List.Perm.swap p q ps')).symm := + _root_.Equiv.ext (fun _ => Subtype.ext rfl) + -- Rewrite to get the desired relabellings + have step := rhs_eq ▸ lhs_eq ▸ combined + -- step : (glueList inner_qp dbl_qp _).relabel ff_qp ≃ + -- (glueList inner_pq dbl_pq _).relabel (ff_pq.trans (fSPE swap).symm) + -- Decompose the RHS double relabelling + have decomposed := step.trans (Equiv.relabelTrans _ ff_pq + (foldSurvivingPermEquiv (List.Perm.swap p q ps')).symm).symm + -- Fold back using glueList_cons + have hlhs₁ := glueList_cons W q (p :: ps') hp + have hlhs₂ := glueList_cons (W.gluePair q.1 q.2 hq12) + (⟨p.1, hik.symm, hjk.symm⟩, ⟨p.2, hil.symm, hjl.symm⟩) + (coercePairsList q.1 q.2 ps' hsep_q_ps') hwf_q + have hrhs₁ := glueList_cons W p (q :: ps') hp' + have hrhs₂ := glueList_cons (W.gluePair p.1 p.2 hp12) + (⟨q.1, hik, hil⟩, ⟨q.2, hjk, hjl⟩) + (coercePairsList p.1 p.2 ps' hsep_p_ps') hwf_p + -- LHS: fold back two levels + let ff_inner_qp := foldFlatten + (⟨p.1, hik.symm, hjk.symm⟩ : SurvivingLabel α q.1 q.2) + ⟨p.2, hil.symm, hjl.symm⟩ (coercePairsList q.1 q.2 ps' hsep_q_ps') + hwf_q.sep + let ff_outer_q := foldFlatten q.1 q.2 (p :: ps') hp.sep + have lhs_fold := (Equiv.relabelTrans + (glueList inner_qp _ hwf_dbl_qp) ff_inner_qp ff_outer_q).symm + -- RHS: fold back two levels + let inner_pq := (W.gluePair p.1 p.2 hp12).gluePair + (⟨q.1, hik, hil⟩ : SurvivingLabel α p.1 p.2) ⟨q.2, hjk, hjl⟩ + (fun h => hq12 (congrArg Subtype.val h)) + let ff_inner_pq := foldFlatten + (⟨q.1, hik, hil⟩ : SurvivingLabel α p.1 p.2) + ⟨q.2, hjk, hjl⟩ (coercePairsList p.1 p.2 ps' hsep_p_ps') hwf_p.sep + let ff_outer_p := foldFlatten p.1 p.2 (q :: ps') hp'.sep + have rhs_fold := (Equiv.relabelTrans + (glueList inner_pq _ hwf_dbl_pq) ff_inner_pq ff_outer_p).symm + exact ⟨(hlhs₁ ▸ hlhs₂ ▸ lhs_fold.symm).trans + (decomposed.trans (Equiv.relabelCongr (hrhs₁ ▸ hrhs₂ ▸ rhs_fold) + (foldSurvivingPermEquiv (List.Perm.swap p q ps')).symm))⟩ + -- ═══════ trans: compose two reorderings ═══════ + | @trans l₁ l₂ l₃ h₁ h₂ ih₁ ih₂ => + have hlen₂ : l₂.length ≤ n + 1 := h₁.length_eq ▸ hlen + have e₁ := (ih₁ W hp hlen).some + have e₂ := (ih₂ W (hp.perm h₁) hlen₂).some + have step₁ := e₁.trans + (Equiv.relabelCongr e₂ (foldSurvivingPermEquiv h₁).symm) + have step₂ := step₁.trans (Equiv.relabelTrans _ _ _) + have hcomp : (foldSurvivingPermEquiv h₂).symm.trans + (foldSurvivingPermEquiv h₁).symm = + (foldSurvivingPermEquiv (h₁.trans h₂)).symm := + _root_.Equiv.ext (fun ⟨_, _⟩ => Subtype.ext rfl) + exact ⟨hcomp ▸ step₂⟩ + +private theorem nonempty_glueList_perm {α : Type} (W : Fragment α) + {ps qs : List (α × α)} + (hperm : ps.Perm qs) (hp : PairsWF ps) : + Nonempty ((glueList W ps hp).Equiv + ((glueList W qs (hp.perm hperm)).relabel + (foldSurvivingPermEquiv hperm).symm)) := + nonempty_glueList_perm_aux ps.length W hperm hp le_rfl + +/-- The reorder theorem: gluing along a permuted pair list yields an +equivalent fragment (up to the canonical relabelling of survivors). +-/ +noncomputable def glueListPerm (W : Fragment α) {ps qs : List (α × α)} + (hperm : ps.Perm qs) (hp : PairsWF ps) : + (glueList W ps hp).Equiv + ((glueList W qs (hp.perm hperm)).relabel + (foldSurvivingPermEquiv hperm).symm) := + (show Nonempty _ from by + exact nonempty_glueList_perm W hperm hp).some + +end Fragment + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueLedger.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueLedger.lean new file mode 100644 index 0000000000..995795c3ae --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueLedger.lean @@ -0,0 +1,661 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChord + +/-! +# The glue ledger at a cut the subset misses + +RS21's bookkeeping (14) compares the circuit count of the composed +graph with the two fragments' counts and the number of components of +the union of their matchings. In the flag model the composition is +built one interface pair at a time, and each step moves those +quantities together: the circuit count and the number of components +of the union. + +`GlueChord` carries that ledger across a glue whose edge the subset +uses. This file carries it across the glues the subset misses — +where the interface edge is not in the subset, and where a closed cut +is left out of it. There nothing moves at all: the used labels are +the same on both sides, the chord matching is unchanged, and so is +the circuit count. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + +open Fragment Equiv +/-! ## The ledger reads only the matching + +Both quantities the ledger tracks — the circuit count and the chord +matching's pairing — are read off the transition system's matching +alone, so two systems that match alike carry the same ledger. That +is what lets the ledger be stated in whichever direction a glue +happens to construct its system. +-/ + +section MatchEqTransport + +variable {α : Type} {W : Fragment α} {F : EdgeSubset W} + +/-- **The chord matching reads only the matching.** -/ +theorem chordInv_congr_matchEq {κ₁ κ₂ : F.RelTransitionSystem} + (h : κ₁.MatchEq κ₂) (a : α) : + chordInv F κ₂ a = chordInv F κ₁ a := by + by_cases hb : W.boundaryFlag a ∈ F.boundaryFlags + · refine W.boundaryFlag_injective ?_ + rw [boundaryFlag_chordInv F κ₂ hb, boundaryFlag_chordInv F κ₁ hb, + pathMatch_matchEq h hb] + · unfold chordInv + rw [dite_eq_right hb, dite_eq_right hb] + +/-- **The cut matching's pairing reads only the matching.** -/ +theorem cutMatching_congr_matchEq + [LinearOrder α] + {κ₁ κ₂ : F.RelTransitionSystem} + (h : κ₁.MatchEq κ₂) (o₁ : κ₁.Orientation) (o₂ : κ₂.Orientation) : + (cutMatching F κ₂ o₂).edge = (cutMatching F κ₁ o₁).edge := + funext (fun a => Subtype.ext (chordInv_congr_matchEq h a.val)) + +/-- **The ledger reads only the matching.** -/ +theorem openCircuitCount_add_unionCount_congr_matchEq + [LinearOrder α] + [Fintype α] + {κ₁ κ₂ : F.RelTransitionSystem} (h : κ₁.MatchEq κ₂) + (o₁ : κ₁.Orientation) (o₂ : κ₂.Orientation) + (N : DirMatching {a : α // W.boundaryFlag a ∈ F.boundaryFlags}) : + κ₂.openCircuitCount + + DirMatching.unionCount (cutMatching F κ₂ o₂) N + = κ₁.openCircuitCount + + DirMatching.unionCount (cutMatching F κ₁ o₁) N := by + rw [openCircuitCount_matchEq h, + DirMatching.unionCount_congr (cutMatching_congr_matchEq h o₁ o₂) + (rfl : N.edge = N.edge)] + +end MatchEqTransport + +/-! ## An open glue whose edge the subset misses -/ + +section GlueOpenMiss + +variable {α : Type} {W : Fragment α} {i j : α} + (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', + (W.gluePairOpen i j hij hopen).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetOpen hopen s', + W.pairing f ∈ liftSubsetOpen hopen s') + (hni : partnerSurvI hopen ∉ s') + +local notation "Fg" => + (EdgeSubset.mk s' hc' : + EdgeSubset (W.gluePairOpen i j hij hopen)) + +local notation "Fl" => + (EdgeSubset.mk (liftSubsetOpen hopen s') hc : + EdgeSubset W) + +include hij hni in +/-- Neither glued label is used when the interface edge is out of the +subset. -/ +theorem boundaryFlagI_not_mem_of_miss : + W.boundaryFlag i ∉ (Fl).boundaryFlags := fun hmem => + hni ((boundaryFlagI_mem_liftOpen_iff hij hopen s').mp + (mem_flags_of_boundaryFlags _ hmem)) + +include hc' hc hni in +/-- At a cut the subset misses, the second glued flag is not a +boundary flag of the lift. -/ +theorem boundaryFlagJ_not_mem_of_miss : + W.boundaryFlag j ∉ (Fl).boundaryFlags := fun hmem => + partnerSurvJ_notMem_of hij hopen s' hc' hni + ((boundaryFlagJ_mem_liftOpen_iff hij hopen s').mp + (mem_flags_of_boundaryFlags _ hmem)) + +include hni in +/-- **The chord matching is unchanged** across a glue whose edge the +subset misses: no chain reaches the cut, so no chain is rerouted. -/ +theorem chordInv_glueOpen_miss + [LinearOrder α] + (κ : (Fl).RelTransitionSystem) + (l : SurvivingLabel α i j) + (hlg : (W.gluePairOpen i j hij hopen).boundaryFlag l ∈ + (Fg).boundaryFlags) : + (chordInv (Fg) (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + l).val + = chordInv (Fl) κ l.val := by + have hll : W.boundaryFlag l.val ∈ (Fl).boundaryFlags := + (glued_participation_iff hij hopen s' hc' hc l).mp hlg + have hgf := boundaryFlag_chordInv (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) hlg + have hlf := boundaryFlag_chordInv (Fl) κ hll + have hI : κ.pathMatch (W.boundaryFlag l.val) hll + ≠ W.boundaryFlag i := fun hx => + boundaryFlagI_not_mem_of_miss hij hopen s' hc hni + (hx ▸ κ.pathMatch_mem hll) + have hJ : κ.pathMatch (W.boundaryFlag l.val) hll + ≠ W.boundaryFlag j := fun hx => + boundaryFlagJ_not_mem_of_miss hij hopen s' hc' hc hni + (hx ▸ κ.pathMatch_mem hll) + have hpm := pathMatch_glueOpen_of_ne hij hopen s' hc' hc κ + hlg hll hI hJ + refine W.boundaryFlag_injective ?_ + calc W.boundaryFlag (chordInv (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) l).val + = ((W.gluePairOpen i j hij hopen).boundaryFlag + (chordInv (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + l)).val := rfl + _ = ((RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ).pathMatch + ((W.gluePairOpen i j hij hopen).boundaryFlag l) hlg).val := + congrArg Subtype.val hgf + _ = κ.pathMatch (W.boundaryFlag l.val) hll := hpm + _ = W.boundaryFlag (chordInv (Fl) κ l.val) := hlf.symm + +include hc' hc hni in +/-- **The used labels are the same** across a glue whose edge the +subset misses. -/ +noncomputable def usedLabelGlueMissEquiv + [LinearOrder α] + : + {l : SurvivingLabel α i j // + (W.gluePairOpen i j hij hopen).boundaryFlag l ∈ + (Fg).boundaryFlags} + ≃ {a : α // W.boundaryFlag a ∈ (Fl).boundaryFlags} where + toFun x := ⟨x.val.val, + (glued_participation_iff hij hopen s' hc' hc x.val).mp x.prop⟩ + invFun y := + ⟨⟨y.val, + fun hx => boundaryFlagI_not_mem_of_miss hij hopen s' hc hni + (by have h := y.prop; rwa [hx] at h), + fun hx => boundaryFlagJ_not_mem_of_miss hij hopen s' hc' hc + hni (by have h := y.prop; rwa [hx] at h)⟩, + (glued_participation_iff hij hopen s' hc' hc _).mpr y.prop⟩ + left_inv _ := rfl + right_inv _ := rfl + +include hni in +/-- **The glued cut matching's pairing is the lifted one's** across a +glue whose edge the subset misses. -/ +theorem cutMatching_glueOpen_miss_edge + [LinearOrder α] + (κ : (Fl).RelTransitionSystem) + (o : κ.Orientation) + (o' : (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ).Orientation) : + (((cutMatching (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) o').map + (usedLabelGlueMissEquiv hij hopen s' hc' hc hni)).edge) + = (cutMatching (Fl) κ o).edge := by + funext y + refine Subtype.ext ?_ + exact chordInv_glueOpen_miss hij hopen s' hc' hc hni κ + ((usedLabelGlueMissEquiv hij hopen s' hc' hc hni).symm y).val + ((usedLabelGlueMissEquiv hij hopen s' hc' hc hni).symm y).prop + +include hni in +/-- **A glue whose edge the subset misses moves nothing.** The +circuit count and the number of components of the union are both +unchanged. -/ +theorem openCircuitCount_add_unionCount_glueOpen_miss + [LinearOrder α] + [Fintype α] + (κ : (Fl).RelTransitionSystem) (o : κ.Orientation) + (o' : (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ).Orientation) + {N : DirMatching + {a : α // W.boundaryFlag a ∈ (Fl).boundaryFlags}} + {Ng : DirMatching + {l : SurvivingLabel α i j // + (W.gluePairOpen i j hij hopen).boundaryFlag l ∈ + (Fg).boundaryFlags}} + (hNg : (Ng.map + (usedLabelGlueMissEquiv hij hopen s' hc' hc hni)).edge + = N.edge) : + (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ).openCircuitCount + + DirMatching.unionCount (cutMatching (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) o') Ng + = κ.openCircuitCount + + DirMatching.unionCount (cutMatching (Fl) κ o) N := by + have hun : (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ)).openCircuitCount = κ.openCircuitCount := + openCircuitCount_matchEq + (fun f hf => + (unglueOpen_glueOpen_match hij hopen s' hc' hc κ hf).symm) + have hcount : (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ).openCircuitCount = κ.openCircuitCount := by + rw [← hun] + exact (openCircuitCount_unglueOpen hij hopen s' hc' hc hni _).symm + rw [hcount, ← DirMatching.unionCount_map + (usedLabelGlueMissEquiv hij hopen s' hc' hc hni) + (cutMatching (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) o') Ng, + DirMatching.unionCount_congr + (cutMatching_glueOpen_miss_edge hij hopen s' hc' hc hni κ o o') + hNg] + +include hni in +/-- **One stage of the interface recursion at an open cut the subset +misses.** -/ +theorem openCircuitCount_add_unionCount_stage_miss + [LinearOrder α] + [Fintype α] + {γ : Type} [LinearOrder γ] [Fintype γ] + (E : SurvivingLabel α i j ≃o γ) + (κ : (Fl).RelTransitionSystem) (o : κ.Orientation) + (o' : (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ).Orientation) + {N : DirMatching + {a : α // W.boundaryFlag a ∈ (Fl).boundaryFlags}} + {Ng : DirMatching + {l : SurvivingLabel α i j // + (W.gluePairOpen i j hij hopen).boundaryFlag l ∈ + (Fg).boundaryFlags}} + (hNg : (Ng.map + (usedLabelGlueMissEquiv hij hopen s' hc' hc hni)).edge + = N.edge) + {Mr Nr : DirMatching {b : γ // + ((W.gluePairOpen i j hij hopen).relabel E.toEquiv).boundaryFlag b + ∈ ((Fg).relabelUp E.toEquiv).boundaryFlags}} + (heM : (Mr.map (usedLabRelabelEquiv E (Fg))).edge + = (cutMatching (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + o').edge) + (heN : (Nr.map (usedLabRelabelEquiv E (Fg))).edge = Ng.edge) : + (relabelTransUp E.toEquiv (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ)).openCircuitCount + + DirMatching.unionCount Mr Nr + = κ.openCircuitCount + + DirMatching.unionCount (cutMatching (Fl) κ o) N := by + rw [openCircuitCount_add_unionCount_relabel E (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) heM heN] + exact openCircuitCount_add_unionCount_glueOpen_miss hij hopen s' + hc' hc hni κ o o' hNg + +end GlueOpenMiss + +/-! ## A closed glue whose edge the subset leaves out + +At a closed cut the subset has a free choice: the closed-off edge is +in it or not. When it is not, the two glued labels are unused, the +chord matching simply transports, and the circuit count is +unchanged — so nothing moves here either. (When it is, one component +disappears; that is `GlueChord`'s closed ledger.) +-/ + +section GlueClosedMiss + +variable {α : Type} {W : Fragment α} {i j : α} + (hij : i ≠ j) + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairClosed i j hclosed).pairing f ∈ s') + (hcF : ∀ f ∈ liftSubsetClosed s' false, + W.pairing f ∈ liftSubsetClosed s' false) + +local notation "FgF" => + (EdgeSubset.mk s' hc' : EdgeSubset (W.gluePairClosed i j hclosed)) + +local notation "FlF" => + (EdgeSubset.mk (liftSubsetClosed s' false) hcF : EdgeSubset W) + +omit hclosed in +include hij in +/-- Neither glued label is used when the closed-off edge is left out +of the subset. -/ +theorem boundaryFlagI_not_mem_of_closed_miss : + W.boundaryFlag i ∉ (FlF).boundaryFlags := fun hmem => + Bool.noConfusion + ((boundaryFlagI_mem_liftClosed_iff hij s' false).mp + (mem_flags_of_boundaryFlags _ hmem)) + +omit hclosed in +include hij in +/-- The same at a closed cut the subset misses. -/ +theorem boundaryFlagJ_not_mem_of_closed_miss : + W.boundaryFlag j ∉ (FlF).boundaryFlags := fun hmem => + Bool.noConfusion + ((boundaryFlagJ_mem_liftClosed_iff hij s' false).mp + (mem_flags_of_boundaryFlags _ hmem)) + +include hij hc' hcF in +/-- **The used labels are the same** across a closed glue whose edge +the subset leaves out. -/ +noncomputable def usedLabelGlueClosedMissEquiv : + {l : SurvivingLabel α i j // + (W.gluePairClosed i j hclosed).boundaryFlag l ∈ + (FgF).boundaryFlags} + ≃ {a : α // W.boundaryFlag a ∈ (FlF).boundaryFlags} where + toFun x := ⟨x.val.val, + (mem_boundaryFlags_glueClosed hclosed false s' hc' hcF).mp + x.prop⟩ + invFun y := + ⟨⟨y.val, + fun hx => boundaryFlagI_not_mem_of_closed_miss hij s' hcF + (by have h := y.prop; rwa [hx] at h), + fun hx => boundaryFlagJ_not_mem_of_closed_miss hij s' hcF + (by have h := y.prop; rwa [hx] at h)⟩, + (mem_boundaryFlags_glueClosed hclosed false s' hc' hcF).mpr + y.prop⟩ + left_inv _ := rfl + right_inv _ := rfl + +include hij in +/-- **The glued cut matching's pairing is the lifted one's** across a +closed glue whose edge the subset leaves out. -/ +theorem cutMatching_glueClosedMiss_edge + [LinearOrder α] + (κ' : (FgF).RelTransitionSystem) (o' : κ'.Orientation) + (o : (RelTransitionSystem.unglueClosed hclosed false s' hc' + hcF κ').Orientation) : + (((cutMatching (FgF) κ' o').map + (usedLabelGlueClosedMissEquiv hij hclosed s' hc' hcF)).edge) + = (cutMatching (FlF) + (RelTransitionSystem.unglueClosed hclosed false s' hc' + hcF κ') o).edge := by + funext y + refine Subtype.ext ?_ + exact chordInv_glueClosed hclosed false s' hc' hcF κ' + ((usedLabelGlueClosedMissEquiv hij hclosed s' hc' hcF).symm y).val + ((usedLabelGlueClosedMissEquiv hij hclosed s' hc' hcF).symm y).prop + +include hij in +/-- **A closed glue whose edge the subset leaves out moves nothing.** +The circuit count and the number of components of the union are both +unchanged. -/ +theorem openCircuitCount_add_unionCount_glueClosed_miss + [LinearOrder α] + [Fintype α] + (κ' : (FgF).RelTransitionSystem) (o' : κ'.Orientation) + (o : (RelTransitionSystem.unglueClosed hclosed false s' hc' + hcF κ').Orientation) + {N : DirMatching + {a : α // W.boundaryFlag a ∈ (FlF).boundaryFlags}} + {Ng : DirMatching + {l : SurvivingLabel α i j // + (W.gluePairClosed i j hclosed).boundaryFlag l ∈ + (FgF).boundaryFlags}} + (hNg : (Ng.map + (usedLabelGlueClosedMissEquiv hij hclosed s' hc' hcF)).edge + = N.edge) : + κ'.openCircuitCount + + DirMatching.unionCount (cutMatching (FgF) κ' o') Ng + = (RelTransitionSystem.unglueClosed hclosed false s' hc' + hcF κ').openCircuitCount + + DirMatching.unionCount (cutMatching (FlF) + (RelTransitionSystem.unglueClosed hclosed false s' hc' + hcF κ') o) N := by + rw [openCircuitCount_unglueClosed hclosed false s' hc' hcF κ', + ← DirMatching.unionCount_map + (usedLabelGlueClosedMissEquiv hij hclosed s' hc' hcF) + (cutMatching (FgF) κ' o') Ng, + DirMatching.unionCount_congr + (cutMatching_glueClosedMiss_edge hij hclosed s' hc' hcF κ' o' o) + hNg] + +end GlueClosedMiss + +/-! ## The closed glue, in the direction the recursion runs + +The interface recursion is given the fragment before the glue and +builds the one after it, so it wants its transition system built the +same way round. `RelTransitionSystem.glueClosed` does that, and the +ledger transports to it because the round trip leaves the matching +alone. +-/ + +section GlueClosedForward + +variable {α : Type} {W : Fragment α} {i j : α} + (hij : i ≠ j) + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (b : Bool) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairClosed i j hclosed).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetClosed s' b, + W.pairing f ∈ liftSubsetClosed s' b) + +local notation "Fgb" => + (EdgeSubset.mk s' hc' : EdgeSubset (W.gluePairClosed i j hclosed)) + +local notation "Flb" => + (EdgeSubset.mk (liftSubsetClosed s' b) hc : EdgeSubset W) + +include hc' hc in +/-- **The ledger transports to the forward glue.** Ungluing the +forward glue returns a system matching like the original, so the two +carry the same ledger. -/ +theorem openCircuitCount_add_unionCount_unglue_glueClosed + [LinearOrder α] + [Fintype α] + (κ : (Flb).RelTransitionSystem) (o : κ.Orientation) + (o₀ : (RelTransitionSystem.unglueClosed hclosed b s' hc' hc + (RelTransitionSystem.glueClosed hclosed b s' hc' + hc κ)).Orientation) + (N : DirMatching + {a : α // W.boundaryFlag a ∈ (Flb).boundaryFlags}) : + (RelTransitionSystem.unglueClosed hclosed b s' hc' hc + (RelTransitionSystem.glueClosed hclosed b s' hc' + hc κ)).openCircuitCount + + DirMatching.unionCount (cutMatching (Flb) + (RelTransitionSystem.unglueClosed hclosed b s' hc' hc + (RelTransitionSystem.glueClosed hclosed b s' hc' + hc κ)) o₀) N + = κ.openCircuitCount + + DirMatching.unionCount (cutMatching (Flb) κ o) N := + openCircuitCount_add_unionCount_congr_matchEq + (fun _ hf => + (unglueClosed_glueClosed_match hclosed b s' hc' hc κ hf).symm) + o o₀ N + +end GlueClosedForward + +section GlueClosedForwardTrue + +variable {α : Type} {W : Fragment α} {i j : α} + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairClosed i j hclosed).pairing f ∈ s') + (hcT : ∀ f ∈ liftSubsetClosed s' true, + W.pairing f ∈ liftSubsetClosed s' true) + +local notation "FgT" => + (EdgeSubset.mk s' hc' : EdgeSubset (W.gluePairClosed i j hclosed)) + +local notation "FlT" => + (EdgeSubset.mk (liftSubsetClosed s' true) hcT : EdgeSubset W) + +include hc' hcT in +/-- **A closed glue whose edge the subset carries drops one +component**, stated at the forward glue. -/ +theorem openCircuitCount_add_unionCount_glueClosed_forward + [LinearOrder α] + [Fintype α] + (κ : (FlT).RelTransitionSystem) (o : κ.Orientation) + (o' : (RelTransitionSystem.glueClosed hclosed true s' hc' + hcT κ).Orientation) + (o₀ : (RelTransitionSystem.unglueClosed hclosed true s' hc' hcT + (RelTransitionSystem.glueClosed hclosed true s' hc' + hcT κ)).Orientation) + (hbi : W.boundaryFlag i ∈ (FlT).boundaryFlags) + (hbj : W.boundaryFlag j ∈ (FlT).boundaryFlags) + {N : DirMatching + {a : α // W.boundaryFlag a ∈ (FlT).boundaryFlags}} + (hNij : N.edge ⟨i, hbi⟩ = ⟨j, hbj⟩) + {Ng : DirMatching + {l : SurvivingLabel α i j // + (W.gluePairClosed i j hclosed).boundaryFlag l ∈ + (FgT).boundaryFlags}} + (hNg : (Ng.map (usedLabelGlueClosedEquiv hclosed s' hc' hcT + hbi hbj)).edge = (N.restrict hNij).edge) : + (RelTransitionSystem.glueClosed hclosed true s' hc' + hcT κ).openCircuitCount + + DirMatching.unionCount + (cutMatching (FgT) + (RelTransitionSystem.glueClosed hclosed true s' hc' + hcT κ) o') Ng + + 1 + = κ.openCircuitCount + + DirMatching.unionCount (cutMatching (FlT) κ o) N := by + rw [← openCircuitCount_add_unionCount_unglue_glueClosed hclosed + true s' hc' hcT κ o o₀ N] + exact openCircuitCount_add_unionCount_glueClosed hclosed s' hc' hcT + (RelTransitionSystem.glueClosed hclosed true s' hc' hcT κ) o' o₀ + hbi hbj hNij hNg + +include hc' hcT in +/-- **One stage of the interface recursion at a closed cut the subset +carries**, stated at the forward glue. -/ +theorem openCircuitCount_add_unionCount_stage_closed_forward + [LinearOrder α] + [Fintype α] {γ : Type} [LinearOrder γ] [Fintype γ] + (E : SurvivingLabel α i j ≃o γ) + (κ : (FlT).RelTransitionSystem) (o : κ.Orientation) + (o' : (RelTransitionSystem.glueClosed hclosed true s' hc' + hcT κ).Orientation) + (o₀ : (RelTransitionSystem.unglueClosed hclosed true s' hc' hcT + (RelTransitionSystem.glueClosed hclosed true s' hc' + hcT κ)).Orientation) + (hbi : W.boundaryFlag i ∈ (FlT).boundaryFlags) + (hbj : W.boundaryFlag j ∈ (FlT).boundaryFlags) + {N : DirMatching + {a : α // W.boundaryFlag a ∈ (FlT).boundaryFlags}} + (hNij : N.edge ⟨i, hbi⟩ = ⟨j, hbj⟩) + {Ng : DirMatching + {l : SurvivingLabel α i j // + (W.gluePairClosed i j hclosed).boundaryFlag l ∈ + (FgT).boundaryFlags}} + (hNg : (Ng.map (usedLabelGlueClosedEquiv hclosed s' hc' hcT + hbi hbj)).edge = (N.restrict hNij).edge) + {Mr Nr : DirMatching {b : γ // + ((W.gluePairClosed i j hclosed).relabel E.toEquiv).boundaryFlag b + ∈ ((FgT).relabelUp E.toEquiv).boundaryFlags}} + (heM : (Mr.map (usedLabRelabelEquiv E (FgT))).edge + = (cutMatching (FgT) + (RelTransitionSystem.glueClosed hclosed true s' hc' + hcT κ) o').edge) + (heN : (Nr.map (usedLabRelabelEquiv E (FgT))).edge = Ng.edge) : + (relabelTransUp E.toEquiv (FgT) + (RelTransitionSystem.glueClosed hclosed true s' hc' + hcT κ)).openCircuitCount + + DirMatching.unionCount Mr Nr + 1 + = κ.openCircuitCount + + DirMatching.unionCount (cutMatching (FlT) κ o) N := by + rw [openCircuitCount_add_unionCount_relabel E (FgT) + (RelTransitionSystem.glueClosed hclosed true s' hc' hcT κ) + heM heN] + exact openCircuitCount_add_unionCount_glueClosed_forward hclosed s' + hc' hcT κ o o' o₀ hbi hbj hNij hNg + +end GlueClosedForwardTrue + +section GlueClosedForwardFalse + +variable {α : Type} {W : Fragment α} {i j : α} + (hij : i ≠ j) + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairClosed i j hclosed).pairing f ∈ s') + (hcF : ∀ f ∈ liftSubsetClosed s' false, + W.pairing f ∈ liftSubsetClosed s' false) + +local notation "FgF" => + (EdgeSubset.mk s' hc' : EdgeSubset (W.gluePairClosed i j hclosed)) + +local notation "FlF" => + (EdgeSubset.mk (liftSubsetClosed s' false) hcF : EdgeSubset W) + +include hij hc' hcF in +/-- **A closed glue whose edge the subset leaves out moves +nothing**, stated at the forward glue. -/ +theorem openCircuitCount_add_unionCount_glueClosed_miss_forward + [LinearOrder α] + [Fintype α] (κ : (FlF).RelTransitionSystem) (o : κ.Orientation) + (o' : (RelTransitionSystem.glueClosed hclosed false s' hc' + hcF κ).Orientation) + (o₀ : (RelTransitionSystem.unglueClosed hclosed false s' hc' hcF + (RelTransitionSystem.glueClosed hclosed false s' hc' + hcF κ)).Orientation) + {N : DirMatching + {a : α // W.boundaryFlag a ∈ (FlF).boundaryFlags}} + {Ng : DirMatching + {l : SurvivingLabel α i j // + (W.gluePairClosed i j hclosed).boundaryFlag l ∈ + (FgF).boundaryFlags}} + (hNg : (Ng.map + (usedLabelGlueClosedMissEquiv hij hclosed s' hc' hcF)).edge + = N.edge) : + (RelTransitionSystem.glueClosed hclosed false s' hc' + hcF κ).openCircuitCount + + DirMatching.unionCount + (cutMatching (FgF) + (RelTransitionSystem.glueClosed hclosed false s' hc' + hcF κ) o') Ng + = κ.openCircuitCount + + DirMatching.unionCount (cutMatching (FlF) κ o) N := by + rw [← openCircuitCount_add_unionCount_unglue_glueClosed hclosed + false s' hc' hcF κ o o₀ N] + exact openCircuitCount_add_unionCount_glueClosed_miss hij hclosed s' + hc' hcF (RelTransitionSystem.glueClosed hclosed false s' hc' + hcF κ) o' o₀ hNg + +include hij hc' hcF in +/-- **One stage of the interface recursion at a closed cut the subset +leaves out**, stated at the forward glue. -/ +theorem openCircuitCount_add_unionCount_stage_closed_miss_forward + [LinearOrder α] + [Fintype α] {γ : Type} [LinearOrder γ] [Fintype γ] + (E : SurvivingLabel α i j ≃o γ) + (κ : (FlF).RelTransitionSystem) (o : κ.Orientation) + (o' : (RelTransitionSystem.glueClosed hclosed false s' hc' + hcF κ).Orientation) + (o₀ : (RelTransitionSystem.unglueClosed hclosed false s' hc' hcF + (RelTransitionSystem.glueClosed hclosed false s' hc' + hcF κ)).Orientation) + {N : DirMatching + {a : α // W.boundaryFlag a ∈ (FlF).boundaryFlags}} + {Ng : DirMatching + {l : SurvivingLabel α i j // + (W.gluePairClosed i j hclosed).boundaryFlag l ∈ + (FgF).boundaryFlags}} + (hNg : (Ng.map + (usedLabelGlueClosedMissEquiv hij hclosed s' hc' hcF)).edge + = N.edge) + {Mr Nr : DirMatching {b : γ // + ((W.gluePairClosed i j hclosed).relabel E.toEquiv).boundaryFlag b + ∈ ((FgF).relabelUp E.toEquiv).boundaryFlags}} + (heM : (Mr.map (usedLabRelabelEquiv E (FgF))).edge + = (cutMatching (FgF) + (RelTransitionSystem.glueClosed hclosed false s' hc' + hcF κ) o').edge) + (heN : (Nr.map (usedLabRelabelEquiv E (FgF))).edge = Ng.edge) : + (relabelTransUp E.toEquiv (FgF) + (RelTransitionSystem.glueClosed hclosed false s' hc' + hcF κ)).openCircuitCount + + DirMatching.unionCount Mr Nr + = κ.openCircuitCount + + DirMatching.unionCount (cutMatching (FlF) κ o) N := by + rw [openCircuitCount_add_unionCount_relabel E (FgF) + (RelTransitionSystem.glueClosed hclosed false s' hc' hcF κ) + heM heN] + exact openCircuitCount_add_unionCount_glueClosed_miss_forward hij + hclosed s' hc' hcF κ o o' o₀ hNg + +end GlueClosedForwardFalse + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GluePathMatch.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GluePathMatch.lean new file mode 100644 index 0000000000..10b2149037 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GluePathMatch.lean @@ -0,0 +1,793 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChords + +/-! +# The boundary pairing of a glued system by chain following + +For an open single-pair glue `W' = W.gluePairOpen i j hij hopen` +and a transition system `κ` on the lifted edge subset, this file +computes the `pathMatch` of the glued system +`RelTransitionSystem.glueOpen … κ` on the glued boundary flags in +terms of the `pathMatch` of `κ`: + +* `mem_boundaryFlags_glueOpen` — a surviving flag is a boundary + flag of the glued subset iff its value is a boundary flag of the + lifted subset (the two cut flags are excluded automatically, + being non-surviving). +* `pathMatch_glueOpen_of_ne` — when the `κ`-chain of `δ'` exits + away from the two cut flags, the glued chain follows it exactly. +* `pathMatch_glueOpen_hit_i` / `pathMatch_glueOpen_hit_j` — when + the `κ`-chain of `δ'` exits at a cut flag, the glued chain + crosses the rewired interface and continues along the other cut + flag's chain to its exit. +* `glued_participation_iff` — a glued boundary flag participates + in the glued subset exactly when its value participates in the + lifted one. +-/ + +@[expose] public section + +namespace RS + + + +namespace EdgeSubset + +open Fragment + +variable {α : Type} {W : Fragment α} + +/-! ### The open-gluing context -/ + +variable {i j : α} + +section OpenGluePathMatch + +variable (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairOpen i j hij hopen).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetOpen hopen s', + W.pairing f ∈ liftSubsetOpen hopen s') + +/-- The glued edge subset. -/ +local notation "Fg" => + (EdgeSubset.mk s' hc' : EdgeSubset (W.gluePairOpen i j hij hopen)) + +/-- The lifted edge subset. -/ +local notation "Fl" => + (EdgeSubset.mk (liftSubsetOpen hopen s') hc : EdgeSubset W) + +/-! #### Boundary-flag correspondence -/ + +/-- **Boundary-flag correspondence (open case)**: a surviving flag +is a boundary flag of the glued subset iff its value is a boundary +flag of the lifted subset. (The two cut flags are not surviving, +so this is the lifted boundary minus the cut flags.) -/ +theorem mem_boundaryFlags_glueOpen {δ' : SurvivingFlag W i j} : + δ' ∈ (Fg).boundaryFlags ↔ δ'.val ∈ (Fl).boundaryFlags := by + constructor + · intro h + have hf : δ'.val ∈ (Fl).flags := + (surviving_val_mem_liftOpen_iff hopen s' δ').mpr + (mem_flags_of_boundaryFlags _ h) + rcases mem_internalFlags_or_boundaryFlags (Fl) hf with hint | hbd + · exact absurd h + (Finset.disjoint_left.mp + ((Fg).internalFlags_disjoint_boundaryFlags) + ((mem_internalFlags_glueOpen hij hopen s' hc' hc).mpr + hint)) + · exact hbd + · intro h + have hf : δ' ∈ (Fg).flags := + (surviving_val_mem_liftOpen_iff hopen s' δ').mp + (mem_flags_of_boundaryFlags _ h) + rcases mem_internalFlags_or_boundaryFlags (Fg) hf with hint | hbd + · exact absurd h + (Finset.disjoint_left.mp + ((Fl).internalFlags_disjoint_boundaryFlags) + ((mem_internalFlags_glueOpen hij hopen s' hc' hc).mp + hint)) + · exact hbd + +/-- Forward direction of the correspondence, `val` form. -/ +theorem boundary_val_of_glueOpen {δ' : SurvivingFlag W i j} + (hδ' : δ' ∈ (Fg).boundaryFlags) : + δ'.val ∈ (Fl).boundaryFlags := + (mem_boundaryFlags_glueOpen hij hopen s' hc' hc).mp hδ' + +/-- Backward direction of the correspondence, `mk` form. -/ +theorem boundary_mk_of_glueOpen {f : W.Flag} + (hf : f ∈ (Fl).boundaryFlags) + (h1 : f ≠ W.boundaryFlag i) (h2 : f ≠ W.boundaryFlag j) : + (⟨f, h1, h2⟩ : SurvivingFlag W i j) ∈ (Fg).boundaryFlags := + (mem_boundaryFlags_glueOpen hij hopen s' hc' hc).mpr hf + +/-! #### The chord-diagram corollary -/ + +end OpenGluePathMatch + +end EdgeSubset + +/-! ## The pathMatch glue transport + +The boundary-chain matching of a glued (open-cut) system at a +surviving boundary flag: the original chain when it avoids the +cut, and the through-composition with the far side's chain when +it hits either cut end — the tower-side engine of the joint- +matching invariant. -/ + +section PathMatchGlue + +open EdgeSubset Fragment + +variable {α : Type} {W : Fragment α} {i j : α} + (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', + (W.gluePairOpen i j hij hopen).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetOpen hopen s', + W.pairing f ∈ liftSubsetOpen hopen s') + +local notation "Fg" => + (EdgeSubset.mk s' hc' : + EdgeSubset (W.gluePairOpen i j hij hopen)) + +local notation "Fl" => + (EdgeSubset.mk (liftSubsetOpen hopen s') hc : + EdgeSubset W) + +/-- Walk agreement from a corresponding pair of starting flags: +while the base walk's pairings stay internal, the glued walk +projects to it and stays in the subset. -/ +theorem iterWalk_glueOpen_from + (κ : (Fl).RelTransitionSystem) + {g' : SurvivingFlag W i j} {g : W.Flag} + (hg : g'.val = g) (hgs : g' ∈ s') (n : ℕ) + (hcont : ∀ m, m < n → + W.pairing (iterWalk κ g m) ∈ (Fl).internalFlags) : + ∀ k, k ≤ n → + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ) g' k).val = iterWalk κ g k ∧ + iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ) g' k ∈ s' := by + intro k + induction k with + | zero => exact fun _ => ⟨hg, hgs⟩ + | succ k ih => + intro hk + obtain ⟨hval, hmem⟩ := ih (by omega) + have hint : W.pairing (iterWalk κ g k) ∈ + (Fl).internalFlags := hcont k (by omega) + have hintv : W.pairing ((iterWalk + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + g' k)).val ∈ (Fl).internalFlags := by + rw [hval]; exact hint + have hstep := glueOpen_step_agrees hij hopen s' hc' hc κ + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' + hc' hc κ) g' k) hintv + have hpair : (W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' + hc' hc κ) g' k) ∈ (Fg).internalFlags := by + refine (mem_internalFlags_glueOpen hij hopen s' hc' + hc).mpr ?_ + have h12 := internal_surviving i j hintv + have hrw : ((W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen + s' hc' hc κ) g' k)).val = + W.pairing (iterWalk + (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ) g' k).val := + rewire_val_of_ne hopen _ h12.1 h12.2 + rw [hrw] + exact hintv + refine ⟨?_, ?_⟩ + · change ((RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).match_ + ((W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) g' + k))).val = + κ.match_ (W.pairing (iterWalk κ g k)) + exact hstep.trans (by rw [hval]) + · change (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).match_ + ((W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) g' + k)) ∈ s' + exact mem_flags_of_internalFlags _ + ((RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).match_mem _ + hpair) + +open scoped Classical in +/-- A surviving flag over a lifted boundary flag is a glued +boundary flag. -/ +theorem boundary_mk_of_glueOpen + {f' : SurvivingFlag W i j} (hfs : f' ∈ s') + (hbd : f'.val ∈ (Fl).boundaryFlags) : + f' ∈ (Fg).boundaryFlags := by + refine Finset.mem_filter.mpr ⟨hfs, ?_⟩ + obtain ⟨lbl, hat⟩ := (Finset.mem_filter.mp hbd).2 + rcases hga : glueAttach W i j f' with v | lb + · have hspec := glueAttach_spec W i j f' + rw [hga, hat] at hspec + cases hspec + · exact ⟨lb, hga⟩ + +open scoped Classical in +/-- A glued boundary flag lies over a lifted boundary flag. -/ +theorem boundary_val_of_glueOpen + {f' : SurvivingFlag W i j} + (hbd : f' ∈ (Fg).boundaryFlags) : + f'.val ∈ (Fl).boundaryFlags := by + refine Finset.mem_filter.mpr ⟨?_, ?_⟩ + · exact (surviving_val_mem_liftOpen_iff hopen s' + f').mpr (Finset.mem_filter.mp hbd).1 + · obtain ⟨lb, hga⟩ := (Finset.mem_filter.mp hbd).2 + have hspec := glueAttach_spec W i j f' + rw [show (W.gluePairOpen i j hij hopen).attach f' = + glueAttach W i j f' from rfl] at hga + rw [hga] at hspec + exact ⟨lb.val, hspec.symm⟩ + +/-- **Exit-time uniqueness**: any explicitly exhibited chain walk +computes the path matching — the chain's exit step is unique, so +no fuel bookkeeping is needed. -/ +theorem pathMatch_exit_unique {α' : Type} + {W' : Fragment α'} {F : EdgeSubset W'} + (κ : F.RelTransitionSystem) {b : W'.Flag} + (hb : b ∈ F.boundaryFlags) (N : ℕ) + (hcontN : ∀ m, m < N → + W'.pairing (iterWalk κ b m) ∈ F.internalFlags) + (htermN : W'.pairing (iterWalk κ b N) ∈ F.boundaryFlags) : + κ.pathMatch b hb = W'.pairing (iterWalk κ b N) := by + obtain ⟨k₂, hkle₂, hcont₂, hterm₂⟩ := + chain_terminates_with_data κ hb + have hN : k₂ = N := by + rcases lt_trichotomy k₂ N with hlt | heq | hgt + · exact absurd (hcontN k₂ hlt) + (fun hint => (Finset.disjoint_left.mp + (internalFlags_disjoint_boundaryFlags _) hint) + hterm₂) + · exact heq + · exact absurd (hcont₂ N hgt) + (fun hint => (Finset.disjoint_left.mp + (internalFlags_disjoint_boundaryFlags _) hint) + htermN) + subst hN + exact κ.pathMatch_eq hb + (traceChain_fuel_mono κ (by omega) + (traceChain_forward κ b hcont₂ hterm₂)) + +open scoped Classical in +/-- **pathMatch through an open glue, no cut hit**: when the +original chain's endpoint avoids both cut flags, the glued chain +has the same endpoint. -/ +theorem pathMatch_glueOpen_of_ne + [LinearOrder α] + (κ : (Fl).RelTransitionSystem) + {b' : SurvivingFlag W i j} + (hbg : b' ∈ (Fg).boundaryFlags) + (hbl : b'.val ∈ (Fl).boundaryFlags) + (hni : κ.pathMatch b'.val hbl ≠ W.boundaryFlag i) + (hnj : κ.pathMatch b'.val hbl ≠ W.boundaryFlag j) : + ((RelTransitionSystem.glueOpen hij hopen s' hc' hc + κ).pathMatch b' hbg).val = κ.pathMatch b'.val hbl := by + obtain ⟨k, hkle, hcont, hterm⟩ := + chain_terminates_with_data κ hbl + have hpm : κ.pathMatch b'.val hbl = + W.pairing (iterWalk κ b'.val k) := + pathMatch_exit_unique κ hbl k hcont hterm + have hbs : b' ∈ s' := (Finset.mem_filter.mp hbg).1 + -- ═══════ THE GLUED WALK FOLLOWS THE BASE WALK ═══════ + have hw := iterWalk_glueOpen_from hij hopen s' hc' hc κ + (g := b'.val) rfl hbs k hcont + have hcontg : ∀ m, m < k → + (W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' + hc' hc κ) b' m) ∈ (Fg).internalFlags := by + intro m hm + obtain ⟨hval, _⟩ := hw m (by omega) + have hint := hcont m hm + have hnecut := internal_surviving i j hint + have hrw : ((W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' + hc' hc κ) b' m)).val = + W.pairing (iterWalk (RelTransitionSystem.glueOpen + hij hopen s' hc' hc κ) b' m).val := by + refine rewire_val_of_ne hopen _ ?_ ?_ + · rw [hval]; exact hnecut.1 + · rw [hval]; exact hnecut.2 + refine (mem_internalFlags_glueOpen hij hopen s' hc' + hc).mpr ?_ + rw [hrw, hval] + exact hint + obtain ⟨hval, hmem⟩ := hw k (le_refl k) + have hrw : ((W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' + hc' hc κ) b' k)).val = + W.pairing (iterWalk (RelTransitionSystem.glueOpen hij + hopen s' hc' hc κ) b' k).val := by + refine rewire_val_of_ne hopen _ ?_ ?_ + · rw [hval]; exact fun hcon => hni (hpm.trans hcon) + · rw [hval]; exact fun hcon => hnj (hpm.trans hcon) + have htermg : (W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' + hc' hc κ) b' k) ∈ (Fg).boundaryFlags := by + refine boundary_mk_of_glueOpen hij hopen s' hc' hc + (hc' _ hmem) ?_ + rw [hrw, hval] + exact hterm + have hpmg := pathMatch_exit_unique + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + hbg k hcontg htermg + rw [hpmg, hrw, hval, hpm] + +private theorem pathMatch_reverse_eq {F : EdgeSubset W} + (κ : F.RelTransitionSystem) {b x : W.Flag} + (hb : b ∈ F.boundaryFlags) (hx : x ∈ F.boundaryFlags) + (he : κ.pathMatch b hb = x) : κ.pathMatch x hx = b := by + subst he + exact κ.pathMatch_invol hb + +private theorem iterWalk_glueOpen_internal + (κ : (Fl).RelTransitionSystem) {b' : SurvivingFlag W i j} + (hbs : b' ∈ s') (k : ℕ) + (hcont : ∀ m, m < k → + W.pairing (iterWalk κ b'.val m) ∈ (Fl).internalFlags) : ∀ m, m < k → + (W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' m) ∈ + (Fg).internalFlags := by + have hw := iterWalk_glueOpen_from hij hopen s' hc' hc κ + (g := b'.val) rfl hbs k hcont + intro m hm + obtain ⟨hval, _⟩ := hw m (by omega) + have hint := hcont m hm + have hnecut := internal_surviving i j hint + have hrw : ((W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' + m)).val = + W.pairing (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + b' m).val := by + refine rewire_val_of_ne hopen _ ?_ ?_ + · rw [hval]; exact hnecut.1 + · rw [hval]; exact hnecut.2 + refine (mem_internalFlags_glueOpen hij hopen s' hc' + hc).mpr ?_ + rw [hrw, hval] + exact hint + +open scoped Classical in +/-- **pathMatch through an open glue, `i`-cut hit**: when the +original chain from a surviving boundary flag ends at the `i`-cut +flag, the glued chain continues through the cut and ends at the +`j`-side chain's endpoint. -/ +theorem pathMatch_glueOpen_hit_i + [LinearOrder α] + (κ : (Fl).RelTransitionSystem) + {b' : SurvivingFlag W i j} + (hbg : b' ∈ (Fg).boundaryFlags) + (hbl : b'.val ∈ (Fl).boundaryFlags) + (hbfj : W.boundaryFlag j ∈ (Fl).boundaryFlags) + (hhit : κ.pathMatch b'.val hbl = W.boundaryFlag i) : + ((RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).pathMatch b' hbg).val + = + κ.pathMatch (W.boundaryFlag j) hbfj := by + obtain ⟨k, hkle, hcont, hterm⟩ := + chain_terminates_with_data κ hbl + have hpm : κ.pathMatch b'.val hbl = + W.pairing (iterWalk κ b'.val k) := + pathMatch_exit_unique κ hbl k hcont hterm + have hbs : b' ∈ s' := (Finset.mem_filter.mp hbg).1 + -- ═══════ THE GLUED WALK FOLLOWS THE BASE WALK ═══════ + have hw := iterWalk_glueOpen_from hij hopen s' hc' hc κ + (g := b'.val) rfl hbs k hcont + have hcontg := iterWalk_glueOpen_internal hij hopen s' hc' hc κ hbs k hcont + have hhitk : W.pairing (iterWalk κ b'.val k) = + W.boundaryFlag i := hpm.symm.trans hhit + -- ═══════ CROSSING THE REWIRED INTERFACE ═══════ + have hcross : (W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' k) = + partnerSurvJ hopen := + gluePairOpen_pairing_interface_i hij hopen _ + (by rw [(hw k (le_refl k)).1]; exact hhitk) + have hpsj : partnerSurvJ hopen ∈ s' := by + rw [← hcross] + exact hc' _ (hw k (le_refl k)).2 + -- ═══════ CONTINUING ALONG THE OTHER CUT FLAG'S CHAIN ═══════ + obtain ⟨k₃, hkle₃, hcont₃, hterm₃⟩ := + chain_terminates_with_data κ hbfj + have hpm₃ : κ.pathMatch (W.boundaryFlag j) hbfj = + W.pairing (iterWalk κ (W.boundaryFlag j) k₃) := + pathMatch_exit_unique κ hbfj k₃ hcont₃ hterm₃ + have hbfi : W.boundaryFlag i ∈ (Fl).boundaryFlags := by + have := κ.pathMatch_mem hbl + rw [hhit] at this + exact this + have hne₂j : κ.pathMatch (W.boundaryFlag j) hbfj ≠ + W.boundaryFlag j := κ.pathMatch_ne_self hbfj + have hne₂i : κ.pathMatch (W.boundaryFlag j) hbfj ≠ + W.boundaryFlag i := by + intro hcon + have h2 := pathMatch_reverse_eq κ hbfj hbfi hcon + have h3 := pathMatch_reverse_eq κ hbl hbfi hhit + exact b'.prop.2 (h3.symm.trans h2) + rcases mem_internalFlags_or_boundaryFlags (Fl) + (hc _ ((Finset.mem_filter.mp hbfj).1)) with hint₂ | hb₂ + · -- continuing: the j-edge enters the interior + have hk₃pos : 1 ≤ k₃ := by + by_contra hz + have hz0 : k₃ = 0 := by omega + rw [hz0] at hterm₃ + exact (Finset.disjoint_left.mp + (internalFlags_disjoint_boundaryFlags _) hint₂) + (by simpa using hterm₃) + have hpsjint : partnerSurvJ hopen ∈ + (Fg).internalFlags := + (mem_internalFlags_glueOpen hij hopen s' hc' hc).mpr + (by rw [partnerSurvJ_val]; exact hint₂) + have hb2v : (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + b' (k + 1)).val = + κ.match_ (W.pairing (W.boundaryFlag j)) := by + change ((RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).match_ + ((W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' + k))).val = _ + rw [hcross] + exact (glueOpen_match_val hij hopen s' hc' hc κ + hpsjint).trans (by rw [partnerSurvJ_val]) + have hmem2 : iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + b' (k + 1) ∈ s' := by + change (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).match_ + ((W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' + k)) ∈ s' + rw [hcross] + exact mem_flags_of_internalFlags _ + ((RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).match_mem _ + hpsjint) + have hcontsh : ∀ m, m < k₃ - 1 → + W.pairing (iterWalk κ + (κ.match_ (W.pairing (W.boundaryFlag j))) m) ∈ + (Fl).internalFlags := by + intro m hm + rw [iterWalk_shift] + exact hcont₃ (m + 1) (by omega) + have hw₂ := iterWalk_glueOpen_from hij hopen s' hc' hc κ + (g' := iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' + (k + 1)) hb2v hmem2 + (k₃ - 1) hcontsh + have hadd := fun m => + (iterWalk_add (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' + (k + 1) m).symm + have hcontN : ∀ m, m < k + k₃ → + (W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' m) ∈ + (Fg).internalFlags := by + intro m hm + rcases lt_trichotomy m k with hmk | hmk | hmk + · exact hcontg m hmk + · subst hmk + rw [hcross] + exact hpsjint + · obtain ⟨m', rfl⟩ : ∃ m', m = k + 1 + m' := + ⟨m - (k + 1), by omega⟩ + obtain ⟨hval, _⟩ := hw₂ m' (by omega) + rw [hadd] at hval + have hint := by + have := hcontsh m' (by omega) + exact this + have hintsh : W.pairing (iterWalk κ + (W.boundaryFlag j) (m' + 1)) ∈ + (Fl).internalFlags := by + rw [← iterWalk_shift] + exact hint + have hnecut := internal_surviving i j hintsh + have hrw : ((W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' (k + + 1 + m'))).val = + W.pairing (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ) b' + (k + 1 + m')).val := by + refine rewire_val_of_ne hopen _ ?_ ?_ + · rw [hval, iterWalk_shift]; exact hnecut.1 + · rw [hval, iterWalk_shift]; exact hnecut.2 + refine (mem_internalFlags_glueOpen hij hopen s' hc' + hc).mpr ?_ + rw [hrw, hval, iterWalk_shift] + exact hintsh + have hNval : (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + b' (k + k₃)).val = + iterWalk κ (W.boundaryFlag j) k₃ := by + have hidx : k + k₃ = k + 1 + (k₃ - 1) := by omega + rw [hidx, ← hadd] + obtain ⟨hval, _⟩ := hw₂ (k₃ - 1) (le_refl _) + rw [hval, iterWalk_shift, + show k₃ - 1 + 1 = k₃ from by omega] + have hNmem : iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + b' (k + k₃) ∈ s' := by + have hidx : k + k₃ = k + 1 + (k₃ - 1) := by omega + rw [hidx, ← hadd] + exact (hw₂ (k₃ - 1) (le_refl _)).2 + have hnecutN : W.pairing (iterWalk (RelTransitionSystem.glueOpen hij hopen + s' hc' hc κ) b' + (k + k₃)).val ≠ W.boundaryFlag i ∧ + W.pairing (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + b' + (k + k₃)).val ≠ W.boundaryFlag j := by + rw [hNval] + exact ⟨fun hcon => hne₂i (hpm₃.trans hcon), + fun hcon => hne₂j (hpm₃.trans hcon)⟩ + have hrwN : ((W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' (k + + k₃))).val = + W.pairing (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + b' (k + k₃)).val := + rewire_val_of_ne hopen _ hnecutN.1 hnecutN.2 + have htermN : (W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' (k + + k₃)) ∈ + (Fg).boundaryFlags := by + refine boundary_mk_of_glueOpen hij hopen s' hc' hc + (hc' _ hNmem) ?_ + rw [hrwN, hNval] + exact hterm₃ + have hpmg := pathMatch_exit_unique + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) hbg (k + k₃) + hcontN htermN + rw [hpmg, hrwN, hNval, hpm₃] + · -- terminal: the j-edge is boundary-to-boundary + have hpmT : κ.pathMatch (W.boundaryFlag j) hbfj = + W.pairing (W.boundaryFlag j) := + κ.pathMatch_eq_pairing hbfj hb₂ + have htermg : (W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' k) ∈ + (Fg).boundaryFlags := by + rw [hcross] + refine boundary_mk_of_glueOpen hij hopen s' hc' hc + hpsj ?_ + rw [partnerSurvJ_val] + exact hb₂ + have hpmg := pathMatch_exit_unique + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) hbg k + hcontg htermg + rw [hpmg, hcross, partnerSurvJ_val, hpmT] + +open scoped Classical in +/-- **pathMatch through an open glue, `j`-cut hit**: when the +original chain from a surviving boundary flag ends at the `j`-cut +flag, the glued chain continues through the cut and ends at the +`i`-side chain's endpoint. -/ +theorem pathMatch_glueOpen_hit_j + [LinearOrder α] + (κ : (Fl).RelTransitionSystem) + {b' : SurvivingFlag W i j} + (hbg : b' ∈ (Fg).boundaryFlags) + (hbl : b'.val ∈ (Fl).boundaryFlags) + (hbfi : W.boundaryFlag i ∈ (Fl).boundaryFlags) + (hhit : κ.pathMatch b'.val hbl = W.boundaryFlag j) : + ((RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).pathMatch b' hbg).val + = + κ.pathMatch (W.boundaryFlag i) hbfi := by + obtain ⟨k, hkle, hcont, hterm⟩ := + chain_terminates_with_data κ hbl + have hpm : κ.pathMatch b'.val hbl = + W.pairing (iterWalk κ b'.val k) := + pathMatch_exit_unique κ hbl k hcont hterm + have hbs : b' ∈ s' := (Finset.mem_filter.mp hbg).1 + have hw := iterWalk_glueOpen_from hij hopen s' hc' hc κ + (g := b'.val) rfl hbs k hcont + have hcontg := iterWalk_glueOpen_internal hij hopen s' hc' hc κ hbs k hcont + have hhitk : W.pairing (iterWalk κ b'.val k) = + W.boundaryFlag j := hpm.symm.trans hhit + have hhitne : W.pairing (iterWalk κ b'.val k) ≠ + W.boundaryFlag i := by + rw [hhitk] + exact fun hcon => hij (boundaryFlag_injective W hcon.symm) + -- ═══════ CROSSING THE REWIRED INTERFACE ═══════ + have hcross : (W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' k) = + partnerSurvI hopen := + gluePairOpen_pairing_interface_j hij hopen _ + (by rw [(hw k (le_refl k)).1]; exact hhitne) + (by rw [(hw k (le_refl k)).1]; exact hhitk) + have hpsj : partnerSurvI hopen ∈ s' := by + rw [← hcross] + exact hc' _ (hw k (le_refl k)).2 + obtain ⟨k₃, hkle₃, hcont₃, hterm₃⟩ := + chain_terminates_with_data κ hbfi + have hpm₃ : κ.pathMatch (W.boundaryFlag i) hbfi = + W.pairing (iterWalk κ (W.boundaryFlag i) k₃) := + pathMatch_exit_unique κ hbfi k₃ hcont₃ hterm₃ + have hbfj : W.boundaryFlag j ∈ (Fl).boundaryFlags := by + have := κ.pathMatch_mem hbl + rw [hhit] at this + exact this + have hne₂i : κ.pathMatch (W.boundaryFlag i) hbfi ≠ + W.boundaryFlag i := κ.pathMatch_ne_self hbfi + have hne₂j : κ.pathMatch (W.boundaryFlag i) hbfi ≠ + W.boundaryFlag j := by + intro hcon + have h2 := pathMatch_reverse_eq κ hbfi hbfj hcon + have h3 := pathMatch_reverse_eq κ hbl hbfj hhit + exact b'.prop.1 (h3.symm.trans h2) + rcases mem_internalFlags_or_boundaryFlags (Fl) + (hc _ ((Finset.mem_filter.mp hbfi).1)) with hint₂ | hb₂ + · -- continuing: the j-edge enters the interior + have hk₃pos : 1 ≤ k₃ := by + by_contra hz + have hz0 : k₃ = 0 := by omega + rw [hz0] at hterm₃ + exact (Finset.disjoint_left.mp + (internalFlags_disjoint_boundaryFlags _) hint₂) + (by simpa using hterm₃) + have hpsiint : partnerSurvI hopen ∈ + (Fg).internalFlags := + (mem_internalFlags_glueOpen hij hopen s' hc' hc).mpr + (by rw [partnerSurvI_val]; exact hint₂) + have hb2v : (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + b' (k + 1)).val = + κ.match_ (W.pairing (W.boundaryFlag i)) := by + change ((RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).match_ + ((W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' + k))).val = _ + rw [hcross] + exact (glueOpen_match_val hij hopen s' hc' hc κ + hpsiint).trans (by rw [partnerSurvI_val]) + have hmem2 : iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + b' (k + 1) ∈ s' := by + change (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).match_ + ((W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' + k)) ∈ s' + rw [hcross] + exact mem_flags_of_internalFlags _ + ((RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).match_mem _ + hpsiint) + have hcontsh : ∀ m, m < k₃ - 1 → + W.pairing (iterWalk κ + (κ.match_ (W.pairing (W.boundaryFlag i))) m) ∈ + (Fl).internalFlags := by + intro m hm + rw [iterWalk_shift] + exact hcont₃ (m + 1) (by omega) + have hw₂ := iterWalk_glueOpen_from hij hopen s' hc' hc κ + (g' := iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' + (k + 1)) hb2v hmem2 + (k₃ - 1) hcontsh + have hadd := fun m => + (iterWalk_add (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' + (k + 1) m).symm + have hcontN : ∀ m, m < k + k₃ → + (W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' m) ∈ + (Fg).internalFlags := by + intro m hm + rcases lt_trichotomy m k with hmk | hmk | hmk + · exact hcontg m hmk + · subst hmk + rw [hcross] + exact hpsiint + · obtain ⟨m', rfl⟩ : ∃ m', m = k + 1 + m' := + ⟨m - (k + 1), by omega⟩ + obtain ⟨hval, _⟩ := hw₂ m' (by omega) + rw [hadd] at hval + have hint := by + have := hcontsh m' (by omega) + exact this + have hintsh : W.pairing (iterWalk κ + (W.boundaryFlag i) (m' + 1)) ∈ + (Fl).internalFlags := by + rw [← iterWalk_shift] + exact hint + have hnecut := internal_surviving i j hintsh + have hrw : ((W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' (k + + 1 + m'))).val = + W.pairing (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ) b' + (k + 1 + m')).val := by + refine rewire_val_of_ne hopen _ ?_ ?_ + · rw [hval, iterWalk_shift]; exact hnecut.1 + · rw [hval, iterWalk_shift]; exact hnecut.2 + refine (mem_internalFlags_glueOpen hij hopen s' hc' + hc).mpr ?_ + rw [hrw, hval, iterWalk_shift] + exact hintsh + have hNval : (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + b' (k + k₃)).val = + iterWalk κ (W.boundaryFlag i) k₃ := by + have hidx : k + k₃ = k + 1 + (k₃ - 1) := by omega + rw [hidx, ← hadd] + obtain ⟨hval, _⟩ := hw₂ (k₃ - 1) (le_refl _) + rw [hval, iterWalk_shift, + show k₃ - 1 + 1 = k₃ from by omega] + have hNmem : iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + b' (k + k₃) ∈ s' := by + have hidx : k + k₃ = k + 1 + (k₃ - 1) := by omega + rw [hidx, ← hadd] + exact (hw₂ (k₃ - 1) (le_refl _)).2 + have hnecutN : W.pairing (iterWalk (RelTransitionSystem.glueOpen hij hopen + s' hc' hc κ) b' + (k + k₃)).val ≠ W.boundaryFlag i ∧ + W.pairing (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + b' + (k + k₃)).val ≠ W.boundaryFlag j := by + rw [hNval] + exact ⟨fun hcon => hne₂i (hpm₃.trans hcon), + fun hcon => hne₂j (hpm₃.trans hcon)⟩ + have hrwN : ((W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' (k + + k₃))).val = + W.pairing (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + b' (k + k₃)).val := + rewire_val_of_ne hopen _ hnecutN.1 hnecutN.2 + have htermN : (W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' (k + + k₃)) ∈ + (Fg).boundaryFlags := by + refine boundary_mk_of_glueOpen hij hopen s' hc' hc + (hc' _ hNmem) ?_ + rw [hrwN, hNval] + exact hterm₃ + have hpmg := pathMatch_exit_unique + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) hbg (k + k₃) + hcontN htermN + rw [hpmg, hrwN, hNval, hpm₃] + · -- terminal: the j-edge is boundary-to-boundary + have hpmT : κ.pathMatch (W.boundaryFlag i) hbfi = + W.pairing (W.boundaryFlag i) := + κ.pathMatch_eq_pairing hbfi hb₂ + have htermg : (W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' k) ∈ + (Fg).boundaryFlags := by + rw [hcross] + refine boundary_mk_of_glueOpen hij hopen s' hc' hc + hpsj ?_ + rw [partnerSurvI_val] + exact hb₂ + have hpmg := pathMatch_exit_unique + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) hbg k + hcontg htermg + rw [hpmg, hcross, partnerSurvI_val, hpmT] + +end PathMatchGlue + +open EdgeSubset Fragment in +open scoped Classical in +/-- Participation transports through the open glue at label +level. -/ +theorem glued_participation_iff + {α : Type} {W : Fragment α} {i j : α} + (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', + (W.gluePairOpen i j hij hopen).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetOpen hopen s', + W.pairing f ∈ liftSubsetOpen hopen s') + (l : SurvivingLabel α i j) : + (W.gluePairOpen i j hij hopen).boundaryFlag l ∈ + (EdgeSubset.mk s' hc' : + EdgeSubset (W.gluePairOpen i j hij hopen)).boundaryFlags + ↔ W.boundaryFlag l.val ∈ + (EdgeSubset.mk (liftSubsetOpen hopen s') hc : + EdgeSubset W).boundaryFlags := by + constructor + · intro h + have := boundary_val_of_glueOpen hij hopen s' hc' hc h + rwa [show ((W.gluePairOpen i j hij hopen).boundaryFlag + l).val = W.boundaryFlag l.val from rfl] at this + · intro h + refine boundary_mk_of_glueOpen hij hopen s' hc' hc ?_ ?_ + · exact (surviving_val_mem_liftOpen_iff hopen s' + _).mp (Finset.mem_filter.mp h).1 + · exact h + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueRelTransport.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueRelTransport.lean new file mode 100644 index 0000000000..ea017646df --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueRelTransport.lean @@ -0,0 +1,1253 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSubsetBij + +/-! +# Transport of transition data across a single-pair glue + +For `W' := W.gluePair i j hij` (in either the open or the closed +case) the internal flags of a glued edge subset `EdgeSubset.mk s'` +correspond to the internal flags of the lifted edge subset +(`liftSubsetOpen` / `liftSubsetClosed`) via `Subtype.val`: gluing +touches only the two boundary flags, and internal flags are +attached to vertices. + +Along this correspondence we transport boundary-relative +transition systems (`RelTransitionSystem.unglueOpen/glueOpen`, +`unglueClosed/glueClosed`) and their orientations in both +directions, prove the round trips on `match_` pointwise at +internal flags, relate the walk steps (`iterWalk`-style +`match_ ∘ pairing`) away from the glued interface, record the +exact rewired step at the interface (what the circuit-count delta +of `GlueCircuitDelta.lean` reads), and prove that +`openCircuitCount` is stable under the transport when the glued +edge's flags do not participate. +-/ + +@[expose] public section + +namespace RS + + + +namespace Fragment + +variable {α : Type} {W : Fragment α} {i j : α} + +/-! ### Rewire evaluation lemmas -/ + +/-- Away from the glued interface, `rewire` agrees with the +original pairing. -/ +theorem rewire_val_of_ne + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (f : SurvivingFlag W i j) + (h1 : W.pairing f.val ≠ W.boundaryFlag i) + (h2 : W.pairing f.val ≠ W.boundaryFlag j) : + (rewire hopen f).val = W.pairing f.val := by + unfold rewire + rw [dite_eq_right h1, dite_eq_right h2] + +/-- At the `i`-side of the interface, `rewire` jumps to the far +end of the `j`-edge. -/ +theorem rewire_eq_partnerSurvJ + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (f : SurvivingFlag W i j) + (h : W.pairing f.val = W.boundaryFlag i) : + rewire hopen f = partnerSurvJ hopen := by + unfold rewire + rw [dite_eq_left h] + rfl + +/-- At the `j`-side of the interface, `rewire` jumps to the far +end of the `i`-edge. -/ +theorem rewire_eq_partnerSurvI + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (f : SurvivingFlag W i j) + (hne : W.pairing f.val ≠ W.boundaryFlag i) + (h : W.pairing f.val = W.boundaryFlag j) : + rewire hopen f = partnerSurvI hopen := by + unfold rewire + rw [dite_eq_right hne, dite_eq_left h] + rfl + +/-- A surviving flag whose pairing is the `i`-boundary flag is the +far end of the `i`-edge. -/ +theorem eq_partnerSurvI_of_pairing + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (f : SurvivingFlag W i j) + (h : W.pairing f.val = W.boundaryFlag i) : + f = partnerSurvI hopen := by + refine Subtype.ext ?_ + have h' := congrArg W.pairing h + rwa [W.pairing_invol] at h' + +/-- A surviving flag whose pairing is the `j`-boundary flag is the +far end of the `j`-edge. -/ +theorem eq_partnerSurvJ_of_pairing + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (f : SurvivingFlag W i j) + (h : W.pairing f.val = W.boundaryFlag j) : + f = partnerSurvJ hopen := by + refine Subtype.ext ?_ + have h' := congrArg W.pairing h + rwa [W.pairing_invol] at h' + +end Fragment + +namespace EdgeSubset + +open Fragment + +variable {α : Type} {W : Fragment α} {i j : α} + +/-! ### Generic transport helpers -/ + +/-- An internal flag of any edge subset of `W` survives a glue at +`{i, j}`: it is attached to a vertex, hence is no boundary flag. -/ +theorem internal_surviving (i j : α) {F : EdgeSubset W} + {f : W.Flag} (hf : f ∈ F.internalFlags) : + f ≠ W.boundaryFlag i ∧ f ≠ W.boundaryFlag j := by + obtain ⟨v, hv⟩ := attach_internal_of_mem F hf + exact vertex_flag_surviving f v hv + +/-- Extend a surviving-flag self-map to all of `W.Flag`: +apply it through the subtype on surviving flags, identity +elsewhere. -/ +noncomputable def unglueMatch + (m : SurvivingFlag W i j → SurvivingFlag W i j) + (f : W.Flag) : W.Flag := + if h : f ≠ W.boundaryFlag i ∧ f ≠ W.boundaryFlag j then + (m ⟨f, h⟩).val + else f + +/-- The unglued matching at a surviving flag is the glued matching +read through `Subtype.val`. -/ +theorem unglueMatch_of_surviving + (m : SurvivingFlag W i j → SurvivingFlag W i j) + (f : W.Flag) + (h : f ≠ W.boundaryFlag i ∧ f ≠ W.boundaryFlag j) : + unglueMatch m f = (m ⟨f, h⟩).val := by + unfold unglueMatch + rw [dite_eq_left h] + +/-- The same, stated on a surviving flag's underlying flag. -/ +theorem unglueMatch_val + (m : SurvivingFlag W i j → SurvivingFlag W i j) + (g : SurvivingFlag W i j) : + unglueMatch m g.val = (m g).val := by + unfold unglueMatch + rw [dite_eq_left g.prop] + +/-- Restrict a flag self-map of `W` to the surviving flags on a +given internal-flag set: apply it through `Subtype.val` there +(with a supplied surviving-ness certificate), identity +elsewhere. -/ +noncomputable def glueMatch (m : W.Flag → W.Flag) + (P : Finset (SurvivingFlag W i j)) + (hP : ∀ f' ∈ P, m f'.val ≠ W.boundaryFlag i ∧ + m f'.val ≠ W.boundaryFlag j) + (f' : SurvivingFlag W i j) : SurvivingFlag W i j := + if h : f' ∈ P then ⟨m f'.val, hP f' h⟩ else f' + +/-- The glued matching on the flags it is defined at agrees with the +matching it came from. -/ +theorem glueMatch_val_of_mem (m : W.Flag → W.Flag) + (P : Finset (SurvivingFlag W i j)) + (hP : ∀ f' ∈ P, m f'.val ≠ W.boundaryFlag i ∧ + m f'.val ≠ W.boundaryFlag j) + {f' : SurvivingFlag W i j} (h : f' ∈ P) : + (glueMatch m P hP f').val = m f'.val := by + unfold glueMatch + rw [dite_eq_left h] + +/-- Extend a surviving-flag orientation to all of `W.Flag`: +through the subtype on surviving flags, `false` elsewhere. -/ +noncomputable def unglueIsOut + (b : SurvivingFlag W i j → Bool) (f : W.Flag) : Bool := + if h : f ≠ W.boundaryFlag i ∧ f ≠ W.boundaryFlag j then + b ⟨f, h⟩ + else false + +/-- The unglued orientation at a surviving flag. -/ +theorem unglueIsOut_of_surviving + (b : SurvivingFlag W i j → Bool) (f : W.Flag) + (h : f ≠ W.boundaryFlag i ∧ f ≠ W.boundaryFlag j) : + unglueIsOut b f = b ⟨f, h⟩ := by + unfold unglueIsOut + rw [dite_eq_left h] + +/-- The same, stated on a surviving flag's underlying flag. -/ +theorem unglueIsOut_val + (b : SurvivingFlag W i j → Bool) (g : SurvivingFlag W i j) : + unglueIsOut b g.val = b g := by + unfold unglueIsOut + rw [dite_eq_left g.prop] + +/-! ### The open case -/ + +section OpenGlue + +variable (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairOpen i j hij hopen).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetOpen hopen s', + W.pairing f ∈ liftSubsetOpen hopen s') + +/-- The glued edge subset (with the fragment ascribed, since the +constructor cannot infer it from `s'` alone). -/ +local notation "Fg" => + (EdgeSubset.mk s' hc' : EdgeSubset (W.gluePairOpen i j hij hopen)) + +/-- The lifted edge subset. -/ +local notation "Fl" => + (EdgeSubset.mk (liftSubsetOpen hopen s') hc : EdgeSubset W) + +/-! #### Internal-flag correspondence (open case) -/ + +/-- **Internal-flag correspondence (open case)**: the internal +flags of the glued subset and of the lifted subset correspond via +`Subtype.val`. -/ +theorem mem_internalFlags_glueOpen {f' : SurvivingFlag W i j} : + f' ∈ (Fg).internalFlags ↔ + f'.val ∈ (Fl).internalFlags := by + constructor + · intro h + obtain ⟨v, hv⟩ := attach_internal_of_mem _ h + refine mem_internalFlags_of ?_ ⟨v, (glueAttach_inl_iff f' v).mp hv⟩ + exact (surviving_val_mem_liftOpen_iff hopen s' f').mpr + (mem_flags_of_internalFlags _ h) + · intro h + obtain ⟨v, hv⟩ := attach_internal_of_mem _ h + refine mem_internalFlags_of ?_ ⟨v, (glueAttach_inl_iff f' v).mpr hv⟩ + exact (surviving_val_mem_liftOpen_iff hopen s' f').mp + (mem_flags_of_internalFlags _ h) + +/-- Forward direction of the correspondence, `val` form. -/ +theorem internal_val_of_glueOpen {f' : SurvivingFlag W i j} + (hf' : f' ∈ (Fg).internalFlags) : + f'.val ∈ (Fl).internalFlags := + (mem_internalFlags_glueOpen hij hopen s' hc' hc).mp hf' + +/-- Backward direction of the correspondence, `mk` form. -/ +theorem internal_mk_of_glueOpen {f : W.Flag} + (hf : f ∈ (Fl).internalFlags) + (h1 : f ≠ W.boundaryFlag i) (h2 : f ≠ W.boundaryFlag j) : + (⟨f, h1, h2⟩ : SurvivingFlag W i j) ∈ (Fg).internalFlags := + (mem_internalFlags_glueOpen hij hopen s' hc' hc).mpr hf + +/-! #### Transition transport (open case) -/ + +/-- **Unglue (open case)**: transport a transition system on the +glued subset to the lifted subset. The matching acts through the +surviving-flag subtype; identity junk at the two glued boundary +flags. -/ +noncomputable def RelTransitionSystem.unglueOpen + (κ' : (Fg).RelTransitionSystem) : + (Fl).RelTransitionSystem where + match_ := unglueMatch κ'.match_ + match_invol := by + intro f hf + obtain ⟨h1, h2⟩ := internal_surviving i j hf + have hg := internal_mk_of_glueOpen hij hopen s' hc' hc hf h1 h2 + calc unglueMatch κ'.match_ (unglueMatch κ'.match_ f) + = unglueMatch κ'.match_ (κ'.match_ ⟨f, h1, h2⟩).val := by + rw [unglueMatch_of_surviving κ'.match_ f ⟨h1, h2⟩] + _ = (κ'.match_ (κ'.match_ ⟨f, h1, h2⟩)).val := + unglueMatch_val κ'.match_ _ + _ = f := by rw [κ'.match_invol _ hg] + match_ne := by + intro f hf heq + obtain ⟨h1, h2⟩ := internal_surviving i j hf + have hg := internal_mk_of_glueOpen hij hopen s' hc' hc hf h1 h2 + rw [unglueMatch_of_surviving κ'.match_ f ⟨h1, h2⟩] at heq + exact κ'.match_ne _ hg (Subtype.ext heq) + match_mem := by + intro f hf + obtain ⟨h1, h2⟩ := internal_surviving i j hf + have hg := internal_mk_of_glueOpen hij hopen s' hc' hc hf h1 h2 + rw [unglueMatch_of_surviving κ'.match_ f ⟨h1, h2⟩] + exact internal_val_of_glueOpen hij hopen s' hc' hc + (κ'.match_mem _ hg) + match_vertex := by + intro f hf v hv + obtain ⟨h1, h2⟩ := internal_surviving i j hf + have hg := internal_mk_of_glueOpen hij hopen s' hc' hc hf h1 h2 + rw [unglueMatch_of_surviving κ'.match_ f ⟨h1, h2⟩] + exact (glueAttach_inl_iff (κ'.match_ ⟨f, h1, h2⟩) v).mp + (κ'.match_vertex _ hg v + ((glueAttach_inl_iff (⟨f, h1, h2⟩ : SurvivingFlag W i j) + v).mpr hv)) + +/-- The open ungluing's matching at a surviving flag. -/ +theorem unglueOpen_match_of_surviving + (κ' : (Fg).RelTransitionSystem) (f : W.Flag) + (h : f ≠ W.boundaryFlag i ∧ f ≠ W.boundaryFlag j) : + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ').match_ + f = (κ'.match_ ⟨f, h⟩).val := + unglueMatch_of_surviving κ'.match_ f h + +/-- The same on a surviving flag's underlying flag. -/ +theorem unglueOpen_match_val + (κ' : (Fg).RelTransitionSystem) (g : SurvivingFlag W i j) : + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ').match_ + g.val = (κ'.match_ g).val := + unglueMatch_val κ'.match_ g + +/-- The surviving-ness certificate for restricting a lifted-side +matching to the glued subset. -/ +theorem glueOpen_cert + (κ : (Fl).RelTransitionSystem) : + ∀ f' ∈ (Fg).internalFlags, + κ.match_ f'.val ≠ W.boundaryFlag i ∧ + κ.match_ f'.val ≠ W.boundaryFlag j := + fun _ h => internal_surviving i j (κ.match_mem _ + (internal_val_of_glueOpen hij hopen s' hc' hc h)) + +/-- **Glue (open case)**: restrict a transition system on the +lifted subset to the glued subset. -/ +noncomputable def RelTransitionSystem.glueOpen + (κ : (Fl).RelTransitionSystem) : + (Fg).RelTransitionSystem where + match_ := glueMatch κ.match_ (Fg).internalFlags + (glueOpen_cert hij hopen s' hc' hc κ) + match_invol := by + intro f' hf' + have hval := glueMatch_val_of_mem κ.match_ (Fg).internalFlags + (glueOpen_cert hij hopen s' hc' hc κ) hf' + have hm2 : glueMatch κ.match_ (Fg).internalFlags + (glueOpen_cert hij hopen s' hc' hc κ) f' ∈ + (Fg).internalFlags := by + refine (mem_internalFlags_glueOpen hij hopen s' hc' hc).mpr ?_ + rw [hval] + exact κ.match_mem _ + (internal_val_of_glueOpen hij hopen s' hc' hc hf') + refine Subtype.ext ?_ + rw [glueMatch_val_of_mem κ.match_ (Fg).internalFlags + (glueOpen_cert hij hopen s' hc' hc κ) hm2, hval] + exact κ.match_invol _ + (internal_val_of_glueOpen hij hopen s' hc' hc hf') + match_ne := by + intro f' hf' heq + refine κ.match_ne f'.val + (internal_val_of_glueOpen hij hopen s' hc' hc hf') ?_ + have h2 := congrArg Subtype.val heq + rwa [glueMatch_val_of_mem κ.match_ (Fg).internalFlags + (glueOpen_cert hij hopen s' hc' hc κ) hf'] at h2 + match_mem := by + intro f' hf' + refine (mem_internalFlags_glueOpen hij hopen s' hc' hc).mpr ?_ + rw [glueMatch_val_of_mem κ.match_ (Fg).internalFlags + (glueOpen_cert hij hopen s' hc' hc κ) hf'] + exact κ.match_mem _ + (internal_val_of_glueOpen hij hopen s' hc' hc hf') + match_vertex := by + intro f' hf' v hv + refine (glueAttach_inl_iff + (glueMatch κ.match_ (Fg).internalFlags + (glueOpen_cert hij hopen s' hc' hc κ) f') v).mpr ?_ + rw [glueMatch_val_of_mem κ.match_ (Fg).internalFlags + (glueOpen_cert hij hopen s' hc' hc κ) hf'] + exact κ.match_vertex f'.val + (internal_val_of_glueOpen hij hopen s' hc' hc hf') v + ((glueAttach_inl_iff f' v).mp hv) + +/-- The open gluing's matching at an internal flag: the round trip +agrees with the system it started from. -/ +theorem glueOpen_match_val + (κ : (Fl).RelTransitionSystem) + {f' : SurvivingFlag W i j} + (hf' : f' ∈ (Fg).internalFlags) : + ((RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).match_ + f').val = κ.match_ f'.val := + glueMatch_val_of_mem κ.match_ (Fg).internalFlags + (glueOpen_cert hij hopen s' hc' hc κ) hf' + +/-! #### Round trips (open case) -/ + +/-- Round trip lifted → glued → lifted: `match_` agrees pointwise +at internal flags. -/ +theorem unglueOpen_glueOpen_match + (κ : (Fl).RelTransitionSystem) + {f : W.Flag} + (hf : f ∈ (Fl).internalFlags) : + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ)).match_ + f = κ.match_ f := by + obtain ⟨h1, h2⟩ := internal_surviving i j hf + have hg := internal_mk_of_glueOpen hij hopen s' hc' hc hf h1 h2 + rw [unglueOpen_match_of_surviving hij hopen s' hc' hc _ f + ⟨h1, h2⟩] + exact glueOpen_match_val hij hopen s' hc' hc κ hg + +/-! #### Orientation transport (open case) -/ + +/-- **Unglue an orientation (open case)**: through the subtype on +surviving flags, `false` junk at the two glued boundary flags +(which are never internal, so the structure fields do not +constrain them). -/ +noncomputable def unglueOrientationOpen + (κ' : (Fg).RelTransitionSystem) (o' : κ'.Orientation) : + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').Orientation where + isOut := unglueIsOut o'.isOut + match_flip := by + intro f hf + obtain ⟨h1, h2⟩ := internal_surviving i j hf + have hg := internal_mk_of_glueOpen hij hopen s' hc' hc hf h1 h2 + rw [unglueOpen_match_of_surviving hij hopen s' hc' hc κ' f + ⟨h1, h2⟩, + unglueIsOut_val o'.isOut (κ'.match_ ⟨f, h1, h2⟩), + unglueIsOut_of_surviving o'.isOut f ⟨h1, h2⟩] + exact o'.match_flip _ hg + pairing_flip := by + intro f hf hpf + obtain ⟨h1, h2⟩ := internal_surviving i j hf + obtain ⟨hp1, hp2⟩ := internal_surviving i j hpf + have hg := internal_mk_of_glueOpen hij hopen s' hc' hc hf h1 h2 + have hpg := internal_mk_of_glueOpen hij hopen s' hc' hc hpf + hp1 hp2 + have hrw : (W.gluePairOpen i j hij hopen).pairing ⟨f, h1, h2⟩ = + (⟨W.pairing f, hp1, hp2⟩ : SurvivingFlag W i j) := + Subtype.ext (rewire_val_of_ne hopen ⟨f, h1, h2⟩ hp1 hp2) + rw [unglueIsOut_of_surviving o'.isOut (W.pairing f) ⟨hp1, hp2⟩, + unglueIsOut_of_surviving o'.isOut f ⟨h1, h2⟩] + have hflip := o'.pairing_flip ⟨f, h1, h2⟩ hg + (by rw [hrw]; exact hpg) + rwa [hrw] at hflip + +/-- **Glue an orientation (open case)**: through `Subtype.val`. +The rewired pairing crosses the interface, so a flip-compatibility +hypothesis between the two far ends is required (it is vacuous +when the interface edges do not participate). -/ +noncomputable def glueOrientationOpen + (κ : (Fl).RelTransitionSystem) (o : κ.Orientation) + (hcompat : o.isOut (W.pairing (W.boundaryFlag j)) = + !o.isOut (W.pairing (W.boundaryFlag i))) : + (RelTransitionSystem.glueOpen hij hopen s' hc' hc + κ).Orientation where + isOut := fun f' => o.isOut f'.val + match_flip := by + intro f' hf' + rw [glueOpen_match_val hij hopen s' hc' hc κ hf'] + exact o.match_flip f'.val + (internal_val_of_glueOpen hij hopen s' hc' hc hf') + pairing_flip := by + intro f' hf' hpf' + by_cases hi' : W.pairing f'.val = W.boundaryFlag i + · have hrw : (W.gluePairOpen i j hij hopen).pairing f' = + partnerSurvJ hopen := + rewire_eq_partnerSurvJ hopen f' hi' + have hfv : f'.val = W.pairing (W.boundaryFlag i) := by + have h' := congrArg W.pairing hi' + rwa [W.pairing_invol] at h' + rw [hrw, partnerSurvJ_val hopen, hfv] + exact hcompat + · by_cases hj' : W.pairing f'.val = W.boundaryFlag j + · have hrw : (W.gluePairOpen i j hij hopen).pairing f' = + partnerSurvI hopen := + rewire_eq_partnerSurvI hopen f' hi' hj' + have hfv : f'.val = W.pairing (W.boundaryFlag j) := by + have h' := congrArg W.pairing hj' + rwa [W.pairing_invol] at h' + rw [hrw, partnerSurvI_val hopen, hfv, hcompat, + Bool.not_not] + · have hrw : (W.gluePairOpen i j hij hopen).pairing f' = + (⟨W.pairing f'.val, hi', hj'⟩ : SurvivingFlag W i j) := + Subtype.ext (rewire_val_of_ne hopen f' hi' hj') + rw [hrw] + refine o.pairing_flip f'.val + (internal_val_of_glueOpen hij hopen s' hc' hc hf') ?_ + have h2 := internal_val_of_glueOpen hij hopen s' hc' hc + hpf' + rw [hrw] at h2 + exact h2 + +/-! #### Walk-step agreement (open case) -/ + +/-- The glued pairing at projection level, away from the +interface. -/ +theorem gluePairOpen_pairing_val_of_ne (f' : SurvivingFlag W i j) + (h1 : W.pairing f'.val ≠ W.boundaryFlag i) + (h2 : W.pairing f'.val ≠ W.boundaryFlag j) : + ((W.gluePairOpen i j hij hopen).pairing f').val = + W.pairing f'.val := + rewire_val_of_ne hopen f' h1 h2 + +/-- **Walk-step agreement (open case, glue direction)**: when the +lifted pairing target is internal, the glued walk step projects to +the lifted walk step. -/ +theorem glueOpen_step_agrees + (κ : (Fl).RelTransitionSystem) (f' : SurvivingFlag W i j) + (hp : W.pairing f'.val ∈ (Fl).internalFlags) : + ((RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).match_ + ((W.gluePairOpen i j hij hopen).pairing f')).val = + κ.match_ (W.pairing f'.val) := by + obtain ⟨hp1, hp2⟩ := internal_surviving i j hp + have hrw : (W.gluePairOpen i j hij hopen).pairing f' = + (⟨W.pairing f'.val, hp1, hp2⟩ : SurvivingFlag W i j) := + Subtype.ext (rewire_val_of_ne hopen f' hp1 hp2) + rw [hrw, glueOpen_match_val hij hopen s' hc' hc κ + (internal_mk_of_glueOpen hij hopen s' hc' hc hp hp1 hp2)] + +/-! #### The interface (open case): the rewired step -/ + +/-- The glued pairing at the `i`-side of the interface, projection +level. -/ +theorem gluePairOpen_pairing_interface_i (f' : SurvivingFlag W i j) + (h : W.pairing f'.val = W.boundaryFlag i) : + (W.gluePairOpen i j hij hopen).pairing f' = + partnerSurvJ hopen := + rewire_eq_partnerSurvJ hopen f' h + +/-- The glued pairing at the `j`-side of the interface, projection +level. -/ +theorem gluePairOpen_pairing_interface_j (f' : SurvivingFlag W i j) + (hne : W.pairing f'.val ≠ W.boundaryFlag i) + (h : W.pairing f'.val = W.boundaryFlag j) : + (W.gluePairOpen i j hij hopen).pairing f' = + partnerSurvI hopen := + rewire_eq_partnerSurvI hopen f' hne h + +/-! #### `openCircuitCount` stability (open case, interface not in +the subset) -/ + +include hc' in +/-- When the far end of the `i`-edge is absent, so is the far end +of the `j`-edge (by closure under the glued pairing). -/ +theorem partnerSurvJ_notMem_of + (hni : partnerSurvI hopen ∉ s') : + partnerSurvJ hopen ∉ s' := by + intro hmem + apply hni + have h := hc' _ hmem + have hrw : (W.gluePairOpen i j hij hopen).pairing + (partnerSurvJ hopen) = partnerSurvI hopen := by + refine gluePairOpen_pairing_interface_j hij hopen _ ?_ ?_ + · rw [partnerSurvJ_val hopen, W.pairing_invol] + exact fun hh => hij (W.boundaryFlag_injective hh).symm + · rw [partnerSurvJ_val hopen, W.pairing_invol] + rwa [hrw] at h + +include hc' in +/-- When the interface is not in the subset, the glued pairing +agrees with the `W`-pairing on all subset flags. -/ +theorem gluePairOpen_pairing_val_of_notMem_interface + (hni : partnerSurvI hopen ∉ s') + {g : SurvivingFlag W i j} (hg : g ∈ s') : + ((W.gluePairOpen i j hij hopen).pairing g).val = + W.pairing g.val := by + refine gluePairOpen_pairing_val_of_ne hij hopen g ?_ ?_ + · intro hh + exact hni (eq_partnerSurvI_of_pairing hopen g hh ▸ hg) + · intro hh + exact partnerSurvJ_notMem_of hij hopen s' hc' hni + (eq_partnerSurvJ_of_pairing hopen g hh ▸ hg) + +/-- Walk correspondence (glued-side continuation data): the lifted +walk is the projection of the glued walk, and the glued iterates +stay internal. -/ +theorem iterWalk_unglueOpen + (hni : partnerSurvI hopen ∉ s') + (κ' : (Fg).RelTransitionSystem) {g : SurvivingFlag W i j} + (hg : g ∈ (Fg).internalFlags) (n : ℕ) + (hcont : ∀ m, m < n → (W.gluePairOpen i j hij hopen).pairing + (iterWalk κ' g m) ∈ (Fg).internalFlags) : + ∀ k, k ≤ n → + iterWalk (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ') g.val k = (iterWalk κ' g k).val ∧ + iterWalk κ' g k ∈ (Fg).internalFlags := by + intro k + induction k with + | zero => exact fun _ => ⟨rfl, hg⟩ + | succ k ih => + intro hk + obtain ⟨hval, hmem⟩ := ih (by omega) + have hp := hcont k (by omega) + refine ⟨?_, ?_⟩ + · change (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').match_ (W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ') g.val k)) = + (κ'.match_ ((W.gluePairOpen i j hij hopen).pairing + (iterWalk κ' g k))).val + rw [hval] + have hag : W.pairing (iterWalk κ' g k).val = + ((W.gluePairOpen i j hij hopen).pairing + (iterWalk κ' g k)).val := + (gluePairOpen_pairing_val_of_notMem_interface hij hopen s' + hc' hni (mem_flags_of_internalFlags _ hmem)).symm + rw [hag, unglueOpen_match_val hij hopen s' hc' hc κ' + ((W.gluePairOpen i j hij hopen).pairing (iterWalk κ' g k))] + · exact κ'.match_mem _ hp + +/-- Walk correspondence (lifted-side continuation data): the +converse bookkeeping, with the glued pairing-internality +reconstructed step by step. -/ +theorem iterWalk_unglueOpen_rev + (hni : partnerSurvI hopen ∉ s') + (κ' : (Fg).RelTransitionSystem) {g : SurvivingFlag W i j} + (hg : g ∈ (Fg).internalFlags) (n : ℕ) + (hcontW : ∀ m, m < n → W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') + g.val m) ∈ (Fl).internalFlags) : + ∀ k, k ≤ n → + iterWalk (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ') g.val k = (iterWalk κ' g k).val ∧ + iterWalk κ' g k ∈ (Fg).internalFlags ∧ + (k < n → (W.gluePairOpen i j hij hopen).pairing + (iterWalk κ' g k) ∈ (Fg).internalFlags) := by + intro k + induction k with + | zero => + intro _ + refine ⟨rfl, hg, ?_⟩ + intro h0 + have hpW := hcontW 0 h0 + rw [iterWalk_zero] at hpW + have hag : ((W.gluePairOpen i j hij hopen).pairing g).val = + W.pairing g.val := + gluePairOpen_pairing_val_of_notMem_interface hij hopen s' + hc' hni (mem_flags_of_internalFlags _ hg) + change (W.gluePairOpen i j hij hopen).pairing g ∈ + (Fg).internalFlags + refine (mem_internalFlags_glueOpen hij hopen s' hc' hc).mpr ?_ + rw [hag] + exact hpW + | succ k ih => + intro hk + obtain ⟨hval, hmem, hpair⟩ := ih (by omega) + have hpG : (W.gluePairOpen i j hij hopen).pairing + (iterWalk κ' g k) ∈ (Fg).internalFlags := + hpair (by omega) + have hmem1 : iterWalk κ' g (k + 1) ∈ (Fg).internalFlags := + κ'.match_mem _ hpG + have hstep : iterWalk (RelTransitionSystem.unglueOpen hij + hopen s' hc' hc κ') g.val (k + 1) = + (iterWalk κ' g (k + 1)).val := by + change (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').match_ (W.pairing (iterWalk + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ') g.val k)) = + (κ'.match_ ((W.gluePairOpen i j hij hopen).pairing + (iterWalk κ' g k))).val + rw [hval] + have hag : W.pairing (iterWalk κ' g k).val = + ((W.gluePairOpen i j hij hopen).pairing + (iterWalk κ' g k)).val := + (gluePairOpen_pairing_val_of_notMem_interface hij hopen s' + hc' hni (mem_flags_of_internalFlags _ hmem)).symm + rw [hag, unglueOpen_match_val hij hopen s' hc' hc κ' + ((W.gluePairOpen i j hij hopen).pairing (iterWalk κ' g k))] + refine ⟨hstep, hmem1, ?_⟩ + intro hk1 + have hpW := hcontW (k + 1) hk1 + rw [hstep] at hpW + have hag : ((W.gluePairOpen i j hij hopen).pairing + (iterWalk κ' g (k + 1))).val = + W.pairing (iterWalk κ' g (k + 1)).val := + gluePairOpen_pairing_val_of_notMem_interface hij hopen s' + hc' hni (mem_flags_of_internalFlags _ hmem1) + refine (mem_internalFlags_glueOpen hij hopen s' hc' hc).mpr ?_ + rw [hag] + exact hpW + +/-- Periodic flags project forward along the unglue transport. -/ +theorem periodicFlags_val_of_glueOpen + (hni : partnerSurvI hopen ∉ s') + (κ' : (Fg).RelTransitionSystem) {g : SurvivingFlag W i j} + (hg : g ∈ κ'.periodicFlags) : + g.val ∈ (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').periodicFlags := by + obtain ⟨hint, n, hn1, hcont, hperiod⟩ := + (κ'.mem_periodicFlags).mp hg + refine ((RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').mem_periodicFlags).mpr + ⟨internal_val_of_glueOpen hij hopen s' hc' hc hint, + n, hn1, ?_, ?_⟩ + · intro m hm + have hcorr := iterWalk_unglueOpen hij hopen s' hc' hc hni κ' + hint n hcont m (le_of_lt hm) + rw [hcorr.1] + have hag : W.pairing (iterWalk κ' g m).val = + ((W.gluePairOpen i j hij hopen).pairing + (iterWalk κ' g m)).val := + (gluePairOpen_pairing_val_of_notMem_interface hij hopen s' + hc' hni (mem_flags_of_internalFlags _ hcorr.2)).symm + rw [hag] + exact internal_val_of_glueOpen hij hopen s' hc' hc + (hcont m hm) + · have hcorr := iterWalk_unglueOpen hij hopen s' hc' hc hni κ' + hint n hcont n le_rfl + rw [hcorr.1, hperiod] + +/-- Periodic flags lift backward along the unglue transport. -/ +theorem periodicFlags_of_val_glueOpen + (hni : partnerSurvI hopen ∉ s') + (κ' : (Fg).RelTransitionSystem) {g : SurvivingFlag W i j} + (hf : g.val ∈ (RelTransitionSystem.unglueOpen hij hopen s' hc' + hc κ').periodicFlags) : + g ∈ κ'.periodicFlags := by + obtain ⟨hint, n, hn1, hcontW, hperiod⟩ := + ((RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').mem_periodicFlags).mp hf + have hg : g ∈ (Fg).internalFlags := + internal_mk_of_glueOpen hij hopen s' hc' hc hint g.prop.1 + g.prop.2 + refine (κ'.mem_periodicFlags).mpr ⟨hg, n, hn1, ?_, ?_⟩ + · intro m hm + exact (iterWalk_unglueOpen_rev hij hopen s' hc' hc hni κ' hg + n hcontW m (le_of_lt hm)).2.2 hm + · refine Subtype.ext ?_ + have hcorr := iterWalk_unglueOpen_rev hij hopen s' hc' hc hni + κ' hg n hcontW n le_rfl + rw [← hcorr.1] + exact hperiod + +/-- The `val`-bijection between the periodic flags of the two +sides. -/ +noncomputable def periodicEquivGlueOpen + (hni : partnerSurvI hopen ∉ s') + (κ' : (Fg).RelTransitionSystem) : + {f : W.Flag // f ∈ (RelTransitionSystem.unglueOpen hij hopen + s' hc' hc κ').periodicFlags} ≃ + {g : (W.gluePairOpen i j hij hopen).Flag // + g ∈ κ'.periodicFlags} where + toFun f := ⟨(⟨f.val, + (internal_surviving i j ((RelTransitionSystem.unglueOpen hij + hopen s' hc' hc κ').periodicFlags_sub f.prop)).1, + (internal_surviving i j ((RelTransitionSystem.unglueOpen hij + hopen s' hc' hc κ').periodicFlags_sub f.prop)).2⟩ : + SurvivingFlag W i j), + periodicFlags_of_val_glueOpen hij hopen s' hc' hc hni κ' + f.prop⟩ + invFun g := ⟨g.val.val, + periodicFlags_val_of_glueOpen hij hopen s' hc' hc hni κ' + g.prop⟩ + left_inv _f := Subtype.ext rfl + right_inv _g := Subtype.ext (Subtype.ext rfl) + +/-- The walk permutations on periodic flags agree under the +`val`-bijection. -/ +theorem walkPermPeriodic_unglueOpen + (hni : partnerSurvI hopen ∉ s') + (κ' : (Fg).RelTransitionSystem) : + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').walkPermPeriodic = + (periodicEquivGlueOpen hij hopen s' hc' hc hni + κ').symm.permCongr κ'.walkPermPeriodic := by + apply Equiv.ext + rintro ⟨f, hf⟩ + obtain ⟨h1, h2⟩ := internal_surviving i j + ((RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').periodicFlags_sub hf) + apply Subtype.ext + change (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').match_ (W.pairing f) = + (κ'.match_ ((W.gluePairOpen i j hij hopen).pairing + ⟨f, h1, h2⟩)).val + have hs : (⟨f, h1, h2⟩ : SurvivingFlag W i j) ∈ s' := + mem_flags_of_internalFlags _ + (internal_mk_of_glueOpen hij hopen s' hc' hc + ((RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').periodicFlags_sub hf) h1 h2) + have hag : W.pairing f = + ((W.gluePairOpen i j hij hopen).pairing ⟨f, h1, h2⟩).val := + (gluePairOpen_pairing_val_of_notMem_interface hij hopen s' hc' hni hs).symm + rw [hag, unglueOpen_match_val hij hopen s' hc' hc κ' + ((W.gluePairOpen i j hij hopen).pairing ⟨f, h1, h2⟩)] + +/-- **`openCircuitCount` stability (open case)**: when the glued +edge's flags are not in the subset, the open circuit count is +unchanged by the unglue transport. -/ +theorem openCircuitCount_unglueOpen + (hni : partnerSurvI hopen ∉ s') + (κ' : (Fg).RelTransitionSystem) : + (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + κ').openCircuitCount = κ'.openCircuitCount := by + unfold RelTransitionSystem.openCircuitCount + rw [walkPermPeriodic_unglueOpen hij hopen s' hc' hc hni κ', + cycleType_permCongr, card_fixedPoints_permCongr] + +end OpenGlue + +/-! ### The closed case -/ + +section ClosedGlue + +variable (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (b : Bool) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairClosed i j hclosed).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetClosed s' b, + W.pairing f ∈ liftSubsetClosed s' b) + +/-- The glued edge subset (closed case). -/ +local notation "Fg" => + (EdgeSubset.mk s' hc' : EdgeSubset (W.gluePairClosed i j hclosed)) + +/-- The lifted edge subset (closed case). -/ +local notation "Fl" => + (EdgeSubset.mk (liftSubsetClosed s' b) hc : EdgeSubset W) + +include hclosed in +/-- In the closed case the pairing of a surviving flag is itself +surviving: the closed-off edge pairs its two boundary flags with +each other. -/ +theorem pairing_val_surviving_closed (f' : SurvivingFlag W i j) : + W.pairing f'.val ≠ W.boundaryFlag i ∧ + W.pairing f'.val ≠ W.boundaryFlag j := by + constructor + · intro h + apply f'.prop.2 + have h' := congrArg W.pairing h + rwa [W.pairing_invol, hclosed] at h' + · intro h + apply f'.prop.1 + have h' := congrArg W.pairing h + rwa [W.pairing_invol, W.pairing_boundaryFlag_comm hclosed] + at h' + +/-- In the closed case the glued pairing agrees with the +`W`-pairing on all surviving flags, at projection level. -/ +theorem gluePairClosed_pairing_val (f' : SurvivingFlag W i j) : + ((W.gluePairClosed i j hclosed).pairing f').val = + W.pairing f'.val := rfl + +/-! #### Internal-flag correspondence (closed case) -/ + +/-- **Internal-flag correspondence (closed case)**. -/ +theorem mem_internalFlags_glueClosed {f' : SurvivingFlag W i j} : + f' ∈ (Fg).internalFlags ↔ + f'.val ∈ (Fl).internalFlags := by + constructor + · intro h + obtain ⟨v, hv⟩ := attach_internal_of_mem _ h + refine mem_internalFlags_of ?_ + ⟨v, (glueAttach_inl_iff f' v).mp hv⟩ + exact (surviving_val_mem_liftClosed_iff s' b f').mpr + (mem_flags_of_internalFlags _ h) + · intro h + obtain ⟨v, hv⟩ := attach_internal_of_mem _ h + refine mem_internalFlags_of ?_ + ⟨v, (glueAttach_inl_iff f' v).mpr hv⟩ + exact (surviving_val_mem_liftClosed_iff s' b f').mp + (mem_flags_of_internalFlags _ h) + +/-- Forward direction of the correspondence, `val` form. -/ +theorem internal_val_of_glueClosed {f' : SurvivingFlag W i j} + (hf' : f' ∈ (Fg).internalFlags) : + f'.val ∈ (Fl).internalFlags := + (mem_internalFlags_glueClosed hclosed b s' hc' hc).mp hf' + +/-- Backward direction of the correspondence, `mk` form. -/ +theorem internal_mk_of_glueClosed {f : W.Flag} + (hf : f ∈ (Fl).internalFlags) + (h1 : f ≠ W.boundaryFlag i) (h2 : f ≠ W.boundaryFlag j) : + (⟨f, h1, h2⟩ : SurvivingFlag W i j) ∈ (Fg).internalFlags := + (mem_internalFlags_glueClosed hclosed b s' hc' hc).mpr hf + +/-! #### Transition transport (closed case) -/ + +/-- **Unglue (closed case)**: transport a transition system on the +glued subset to the lifted subset. -/ +noncomputable def RelTransitionSystem.unglueClosed + (κ' : (Fg).RelTransitionSystem) : + (Fl).RelTransitionSystem where + match_ := unglueMatch κ'.match_ + match_invol := by + intro f hf + obtain ⟨h1, h2⟩ := internal_surviving i j hf + have hg := internal_mk_of_glueClosed hclosed b s' hc' hc hf + h1 h2 + calc unglueMatch κ'.match_ (unglueMatch κ'.match_ f) + = unglueMatch κ'.match_ (κ'.match_ ⟨f, h1, h2⟩).val := by + rw [unglueMatch_of_surviving κ'.match_ f ⟨h1, h2⟩] + _ = (κ'.match_ (κ'.match_ ⟨f, h1, h2⟩)).val := + unglueMatch_val κ'.match_ _ + _ = f := by rw [κ'.match_invol _ hg] + match_ne := by + intro f hf heq + obtain ⟨h1, h2⟩ := internal_surviving i j hf + have hg := internal_mk_of_glueClosed hclosed b s' hc' hc hf + h1 h2 + rw [unglueMatch_of_surviving κ'.match_ f ⟨h1, h2⟩] at heq + exact κ'.match_ne _ hg (Subtype.ext heq) + match_mem := by + intro f hf + obtain ⟨h1, h2⟩ := internal_surviving i j hf + have hg := internal_mk_of_glueClosed hclosed b s' hc' hc hf + h1 h2 + rw [unglueMatch_of_surviving κ'.match_ f ⟨h1, h2⟩] + exact internal_val_of_glueClosed hclosed b s' hc' hc + (κ'.match_mem _ hg) + match_vertex := by + intro f hf v hv + obtain ⟨h1, h2⟩ := internal_surviving i j hf + have hg := internal_mk_of_glueClosed hclosed b s' hc' hc hf + h1 h2 + rw [unglueMatch_of_surviving κ'.match_ f ⟨h1, h2⟩] + exact (glueAttach_inl_iff (κ'.match_ ⟨f, h1, h2⟩) v).mp + (κ'.match_vertex _ hg v + ((glueAttach_inl_iff (⟨f, h1, h2⟩ : SurvivingFlag W i j) + v).mpr hv)) + +/-- The closed ungluing's matching at a surviving flag. -/ +theorem unglueClosed_match_of_surviving + (κ' : (Fg).RelTransitionSystem) (f : W.Flag) + (h : f ≠ W.boundaryFlag i ∧ f ≠ W.boundaryFlag j) : + (RelTransitionSystem.unglueClosed hclosed b s' hc' hc + κ').match_ f = (κ'.match_ ⟨f, h⟩).val := + unglueMatch_of_surviving κ'.match_ f h + +/-- The same on a surviving flag's underlying flag. -/ +theorem unglueClosed_match_val + (κ' : (Fg).RelTransitionSystem) (g : SurvivingFlag W i j) : + (RelTransitionSystem.unglueClosed hclosed b s' hc' hc + κ').match_ g.val = (κ'.match_ g).val := + unglueMatch_val κ'.match_ g + +/-- The surviving-ness certificate for restricting a lifted-side +matching to the glued subset (closed case). -/ +theorem glueClosed_cert + (κ : (Fl).RelTransitionSystem) : + ∀ f' ∈ (Fg).internalFlags, + κ.match_ f'.val ≠ W.boundaryFlag i ∧ + κ.match_ f'.val ≠ W.boundaryFlag j := + fun _ h => internal_surviving i j (κ.match_mem _ + (internal_val_of_glueClosed hclosed b s' hc' hc h)) + +/-- **Glue (closed case)**: restrict a transition system on the +lifted subset to the glued subset. -/ +noncomputable def RelTransitionSystem.glueClosed + (κ : (Fl).RelTransitionSystem) : + (Fg).RelTransitionSystem where + match_ := glueMatch κ.match_ (Fg).internalFlags + (glueClosed_cert hclosed b s' hc' hc κ) + match_invol := by + intro f' hf' + have hval := glueMatch_val_of_mem κ.match_ (Fg).internalFlags + (glueClosed_cert hclosed b s' hc' hc κ) hf' + have hm2 : glueMatch κ.match_ (Fg).internalFlags + (glueClosed_cert hclosed b s' hc' hc κ) f' ∈ + (Fg).internalFlags := by + refine (mem_internalFlags_glueClosed hclosed b s' hc' + hc).mpr ?_ + rw [hval] + exact κ.match_mem _ + (internal_val_of_glueClosed hclosed b s' hc' hc hf') + refine Subtype.ext ?_ + rw [glueMatch_val_of_mem κ.match_ (Fg).internalFlags + (glueClosed_cert hclosed b s' hc' hc κ) hm2, hval] + exact κ.match_invol _ + (internal_val_of_glueClosed hclosed b s' hc' hc hf') + match_ne := by + intro f' hf' heq + refine κ.match_ne f'.val + (internal_val_of_glueClosed hclosed b s' hc' hc hf') ?_ + have h2 := congrArg Subtype.val heq + rwa [glueMatch_val_of_mem κ.match_ (Fg).internalFlags + (glueClosed_cert hclosed b s' hc' hc κ) hf'] at h2 + match_mem := by + intro f' hf' + refine (mem_internalFlags_glueClosed hclosed b s' hc' hc).mpr + ?_ + rw [glueMatch_val_of_mem κ.match_ (Fg).internalFlags + (glueClosed_cert hclosed b s' hc' hc κ) hf'] + exact κ.match_mem _ + (internal_val_of_glueClosed hclosed b s' hc' hc hf') + match_vertex := by + intro f' hf' v hv + refine (glueAttach_inl_iff + (glueMatch κ.match_ (Fg).internalFlags + (glueClosed_cert hclosed b s' hc' hc κ) f') v).mpr ?_ + rw [glueMatch_val_of_mem κ.match_ (Fg).internalFlags + (glueClosed_cert hclosed b s' hc' hc κ) hf'] + exact κ.match_vertex f'.val + (internal_val_of_glueClosed hclosed b s' hc' hc hf') v + ((glueAttach_inl_iff f' v).mp hv) + +/-- The closed gluing's matching at an internal flag: the round trip +again agrees. -/ +theorem glueClosed_match_val + (κ : (Fl).RelTransitionSystem) + {f' : SurvivingFlag W i j} + (hf' : f' ∈ (Fg).internalFlags) : + ((RelTransitionSystem.glueClosed hclosed b s' hc' hc + κ).match_ f').val = κ.match_ f'.val := + glueMatch_val_of_mem κ.match_ (Fg).internalFlags + (glueClosed_cert hclosed b s' hc' hc κ) hf' + +/-! #### Round trips (closed case) -/ + +/-- Round trip lifted → glued → lifted: `match_` agrees pointwise +at internal flags. -/ +theorem unglueClosed_glueClosed_match + (κ : (Fl).RelTransitionSystem) + {f : W.Flag} + (hf : f ∈ (Fl).internalFlags) : + (RelTransitionSystem.unglueClosed hclosed b s' hc' hc + (RelTransitionSystem.glueClosed hclosed b s' hc' hc + κ)).match_ f = κ.match_ f := by + obtain ⟨h1, h2⟩ := internal_surviving i j hf + have hg := internal_mk_of_glueClosed hclosed b s' hc' hc hf + h1 h2 + rw [unglueClosed_match_of_surviving hclosed b s' hc' hc _ f + ⟨h1, h2⟩] + exact glueClosed_match_val hclosed b s' hc' hc κ hg + +/-! #### Orientation transport (closed case) -/ + +/-- **Unglue an orientation (closed case)**: through the subtype, +`false` junk at the two glued boundary flags. -/ +noncomputable def unglueOrientationClosed + (κ' : (Fg).RelTransitionSystem) (o' : κ'.Orientation) : + (RelTransitionSystem.unglueClosed hclosed b s' hc' hc + κ').Orientation where + isOut := unglueIsOut o'.isOut + match_flip := by + intro f hf + obtain ⟨h1, h2⟩ := internal_surviving i j hf + have hg := internal_mk_of_glueClosed hclosed b s' hc' hc hf + h1 h2 + rw [unglueClosed_match_of_surviving hclosed b s' hc' hc κ' f + ⟨h1, h2⟩, + unglueIsOut_val o'.isOut (κ'.match_ ⟨f, h1, h2⟩), + unglueIsOut_of_surviving o'.isOut f ⟨h1, h2⟩] + exact o'.match_flip _ hg + pairing_flip := by + intro f hf hpf + obtain ⟨h1, h2⟩ := internal_surviving i j hf + obtain ⟨hp1, hp2⟩ := internal_surviving i j hpf + have hg := internal_mk_of_glueClosed hclosed b s' hc' hc hf + h1 h2 + have hpg := internal_mk_of_glueClosed hclosed b s' hc' hc hpf + hp1 hp2 + have hrw : (W.gluePairClosed i j hclosed).pairing ⟨f, h1, h2⟩ = + (⟨W.pairing f, hp1, hp2⟩ : SurvivingFlag W i j) := rfl + rw [unglueIsOut_of_surviving o'.isOut (W.pairing f) + ⟨hp1, hp2⟩, + unglueIsOut_of_surviving o'.isOut f ⟨h1, h2⟩] + have hflip := o'.pairing_flip ⟨f, h1, h2⟩ hg + (by rw [hrw]; exact hpg) + rwa [hrw] at hflip + +/-- **Glue an orientation (closed case)**: through `Subtype.val`. +Unconditional: the closed glued pairing agrees with the +`W`-pairing on surviving flags. -/ +noncomputable def glueOrientationClosed + (κ : (Fl).RelTransitionSystem) (o : κ.Orientation) : + (RelTransitionSystem.glueClosed hclosed b s' hc' hc + κ).Orientation where + isOut := fun f' => o.isOut f'.val + match_flip := by + intro f' hf' + rw [glueClosed_match_val hclosed b s' hc' hc κ hf'] + exact o.match_flip f'.val + (internal_val_of_glueClosed hclosed b s' hc' hc hf') + pairing_flip := by + intro f' hf' hpf' + exact o.pairing_flip f'.val + (internal_val_of_glueClosed hclosed b s' hc' hc hf') + (internal_val_of_glueClosed hclosed b s' hc' hc hpf') + +/-! #### `openCircuitCount` stability (closed case) -/ + +/-- Walk correspondence (glued-side continuation data), closed +case. -/ +theorem iterWalk_unglueClosed + (κ' : (Fg).RelTransitionSystem) {g : SurvivingFlag W i j} + (hg : g ∈ (Fg).internalFlags) (n : ℕ) + (hcont : ∀ m, m < n → (W.gluePairClosed i j hclosed).pairing + (iterWalk κ' g m) ∈ (Fg).internalFlags) : + ∀ k, k ≤ n → + iterWalk (RelTransitionSystem.unglueClosed hclosed b s' hc' + hc κ') g.val k = (iterWalk κ' g k).val ∧ + iterWalk κ' g k ∈ (Fg).internalFlags := by + intro k + induction k with + | zero => exact fun _ => ⟨rfl, hg⟩ + | succ k ih => + intro hk + obtain ⟨hval, hmem⟩ := ih (by omega) + have hp := hcont k (by omega) + refine ⟨?_, ?_⟩ + · change (RelTransitionSystem.unglueClosed hclosed b s' hc' hc + κ').match_ (W.pairing (iterWalk + (RelTransitionSystem.unglueClosed hclosed b s' hc' hc + κ') g.val k)) = + (κ'.match_ ((W.gluePairClosed i j hclosed).pairing + (iterWalk κ' g k))).val + rw [hval] + exact unglueClosed_match_of_surviving hclosed b s' hc' hc κ' + (W.pairing (iterWalk κ' g k).val) + (pairing_val_surviving_closed hclosed (iterWalk κ' g k)) + · exact κ'.match_mem _ hp + +/-- Walk correspondence (lifted-side continuation data), closed +case. -/ +theorem iterWalk_unglueClosed_rev + (κ' : (Fg).RelTransitionSystem) {g : SurvivingFlag W i j} + (hg : g ∈ (Fg).internalFlags) (n : ℕ) + (hcontW : ∀ m, m < n → W.pairing (iterWalk + (RelTransitionSystem.unglueClosed hclosed b s' hc' hc κ') + g.val m) ∈ (Fl).internalFlags) : + ∀ k, k ≤ n → + iterWalk (RelTransitionSystem.unglueClosed hclosed b s' hc' + hc κ') g.val k = (iterWalk κ' g k).val ∧ + iterWalk κ' g k ∈ (Fg).internalFlags ∧ + (k < n → (W.gluePairClosed i j hclosed).pairing + (iterWalk κ' g k) ∈ (Fg).internalFlags) := by + intro k + induction k with + | zero => + intro _ + refine ⟨rfl, hg, ?_⟩ + intro h0 + have hpW := hcontW 0 h0 + rw [iterWalk_zero] at hpW + change (W.gluePairClosed i j hclosed).pairing g ∈ + (Fg).internalFlags + exact (mem_internalFlags_glueClosed hclosed b s' hc' hc).mpr + hpW + | succ k ih => + intro hk + obtain ⟨hval, hmem, hpair⟩ := ih (by omega) + have hpG : (W.gluePairClosed i j hclosed).pairing + (iterWalk κ' g k) ∈ (Fg).internalFlags := + hpair (by omega) + have hmem1 : iterWalk κ' g (k + 1) ∈ (Fg).internalFlags := + κ'.match_mem _ hpG + have hstep : iterWalk (RelTransitionSystem.unglueClosed + hclosed b s' hc' hc κ') g.val (k + 1) = + (iterWalk κ' g (k + 1)).val := by + change (RelTransitionSystem.unglueClosed hclosed b s' hc' hc + κ').match_ (W.pairing (iterWalk + (RelTransitionSystem.unglueClosed hclosed b s' hc' hc + κ') g.val k)) = + (κ'.match_ ((W.gluePairClosed i j hclosed).pairing + (iterWalk κ' g k))).val + rw [hval] + exact unglueClosed_match_of_surviving hclosed b s' hc' hc κ' + (W.pairing (iterWalk κ' g k).val) + (pairing_val_surviving_closed hclosed (iterWalk κ' g k)) + refine ⟨hstep, hmem1, ?_⟩ + intro hk1 + have hpW := hcontW (k + 1) hk1 + rw [hstep] at hpW + exact (mem_internalFlags_glueClosed hclosed b s' hc' hc).mpr + hpW + +/-- Periodic flags project forward along the unglue transport +(closed case). -/ +theorem periodicFlags_val_of_glueClosed + (κ' : (Fg).RelTransitionSystem) {g : SurvivingFlag W i j} + (hg : g ∈ κ'.periodicFlags) : + g.val ∈ (RelTransitionSystem.unglueClosed hclosed b s' hc' hc + κ').periodicFlags := by + obtain ⟨hint, n, hn1, hcont, hperiod⟩ := + (κ'.mem_periodicFlags).mp hg + refine ((RelTransitionSystem.unglueClosed hclosed b s' hc' hc + κ').mem_periodicFlags).mpr + ⟨internal_val_of_glueClosed hclosed b s' hc' hc hint, + n, hn1, ?_, ?_⟩ + · intro m hm + have hcorr := iterWalk_unglueClosed hclosed b s' hc' hc κ' + hint n hcont m (le_of_lt hm) + rw [hcorr.1] + exact internal_val_of_glueClosed hclosed b s' hc' hc + (hcont m hm) + · have hcorr := iterWalk_unglueClosed hclosed b s' hc' hc κ' + hint n hcont n le_rfl + rw [hcorr.1, hperiod] + +/-- Periodic flags lift backward along the unglue transport +(closed case). -/ +theorem periodicFlags_of_val_glueClosed + (κ' : (Fg).RelTransitionSystem) {g : SurvivingFlag W i j} + (hf : g.val ∈ (RelTransitionSystem.unglueClosed hclosed b s' + hc' hc κ').periodicFlags) : + g ∈ κ'.periodicFlags := by + obtain ⟨hint, n, hn1, hcontW, hperiod⟩ := + ((RelTransitionSystem.unglueClosed hclosed b s' hc' hc + κ').mem_periodicFlags).mp hf + have hg : g ∈ (Fg).internalFlags := + internal_mk_of_glueClosed hclosed b s' hc' hc hint g.prop.1 + g.prop.2 + refine (κ'.mem_periodicFlags).mpr ⟨hg, n, hn1, ?_, ?_⟩ + · intro m hm + exact (iterWalk_unglueClosed_rev hclosed b s' hc' hc κ' hg + n hcontW m (le_of_lt hm)).2.2 hm + · refine Subtype.ext ?_ + have hcorr := iterWalk_unglueClosed_rev hclosed b s' hc' hc + κ' hg n hcontW n le_rfl + rw [← hcorr.1] + exact hperiod + +/-- The `val`-bijection between the periodic flags of the two +sides (closed case). -/ +noncomputable def periodicEquivGlueClosed + (κ' : (Fg).RelTransitionSystem) : + {f : W.Flag // f ∈ (RelTransitionSystem.unglueClosed hclosed + b s' hc' hc κ').periodicFlags} ≃ + {g : (W.gluePairClosed i j hclosed).Flag // + g ∈ κ'.periodicFlags} where + toFun f := ⟨(⟨f.val, + (internal_surviving i j ((RelTransitionSystem.unglueClosed + hclosed b s' hc' hc κ').periodicFlags_sub f.prop)).1, + (internal_surviving i j ((RelTransitionSystem.unglueClosed + hclosed b s' hc' hc κ').periodicFlags_sub f.prop)).2⟩ : + SurvivingFlag W i j), + periodicFlags_of_val_glueClosed hclosed b s' hc' hc κ' + f.prop⟩ + invFun g := ⟨g.val.val, + periodicFlags_val_of_glueClosed hclosed b s' hc' hc κ' + g.prop⟩ + left_inv _f := Subtype.ext rfl + right_inv _g := Subtype.ext (Subtype.ext rfl) + +/-- The walk permutations on periodic flags agree under the +`val`-bijection (closed case). -/ +theorem walkPermPeriodic_unglueClosed + (κ' : (Fg).RelTransitionSystem) : + (RelTransitionSystem.unglueClosed hclosed b s' hc' hc + κ').walkPermPeriodic = + (periodicEquivGlueClosed hclosed b s' hc' hc + κ').symm.permCongr κ'.walkPermPeriodic := by + apply Equiv.ext + rintro ⟨f, hf⟩ + obtain ⟨h1, h2⟩ := internal_surviving i j + ((RelTransitionSystem.unglueClosed hclosed b s' hc' hc + κ').periodicFlags_sub hf) + apply Subtype.ext + change (RelTransitionSystem.unglueClosed hclosed b s' hc' hc + κ').match_ (W.pairing f) = + (κ'.match_ ((W.gluePairClosed i j hclosed).pairing + ⟨f, h1, h2⟩)).val + exact unglueClosed_match_of_surviving hclosed b s' hc' hc κ' + (W.pairing f) + (pairing_val_surviving_closed hclosed ⟨f, h1, h2⟩) + +/-- **`openCircuitCount` stability (closed case)**: the open +circuit count is unchanged by the unglue transport, for either +value of `b` (the closed-off circle-edge is boundary-attached in +`W` and never periodic). -/ +theorem openCircuitCount_unglueClosed + (κ' : (Fg).RelTransitionSystem) : + (RelTransitionSystem.unglueClosed hclosed b s' hc' hc + κ').openCircuitCount = κ'.openCircuitCount := by + unfold RelTransitionSystem.openCircuitCount + rw [walkPermPeriodic_unglueClosed hclosed b s' hc' hc κ', + cycleType_permCongr, card_fixedPoints_permCongr] + +end ClosedGlue + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplit.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplit.lean new file mode 100644 index 0000000000..07baaa0c84 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplit.lean @@ -0,0 +1,42 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue + +/-! +# The gluing-splitting interface + +The through-independence input (choice elimination for the +corrected constrained value) and the single-pair gluing +decomposition, stated as named interfaces: gluing two boundary +labels decomposes the corrected state-constrained value as a state +sum over the glued interface, weighted by the through-state factor. +The unsigned through-independence is refuted in +`ThroughIndCFalse.lean`; what the development uses in its place is +the signed path-canonical value of `PathCanon.lean`, whose +within-pairing independence is `PropThreeOpen.lean`. +-/ + +@[expose] public section + +namespace RS + +/-- Extension of a boundary state on the surviving labels to the +full label type, prescribing the two glued ends. -/ +noncomputable def GenBoundaryState.extendPair {k ℓ : ℕ} {α : Type} + (i j : α) + (st : GenBoundaryState k ℓ (Fragment.SurvivingLabel α i j)) + (c c' : Fin k ⊕ Fin (2 * ℓ)) : GenBoundaryState k ℓ α := + fun a => + letI := Classical.dec (a = i) + letI := Classical.dec (a = j) + if hi : a = i then c + else if hj : a = j then c' + else st ⟨a, hi, hj⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof.lean new file mode 100644 index 0000000000..b563670a21 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof.C + +/-! +# The single-pair gluing decomposition + +The closed and open per-cut engines and the master splitting +identities, in the two parts below. +-/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/A.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/A.lean new file mode 100644 index 0000000000..d8bf8db547 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/A.lean @@ -0,0 +1,470 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCircuitDelta + +/-! +# The single-pair gluing infrastructure + +The infrastructure of the single-pair gluing analysis: the +extended-state evaluation (`extendPair_left`, `extendPair_right`, +`extendPair_surviving`), the `glueAttach` correspondence, the +through-flag membership characterization, and the through-factor +arithmetic (`oddPartnerSign_sq`, `oddPartnerSign_cast_sq`). + +Why every cut in the development is ordered: the naive +transposed-factor weighting is order-sensitive — the `W`-side +through-product of a closed-off edge reads +`throughStateFactor (st (min i j)) (st (max i j))`, so for +`i < j` the ε pairs with its transpose and the odd block sums to +`−2ℓ` (as required by the circle prefactor `(k − 2ℓ)`), while for +`j < i` it pairs with itself and sums to `+2ℓ`; gluing a strand's +two ends with `i = 1, j = 0` gives `k + 2ℓ` instead of `k − 2ℓ`. +All cuts in the development are therefore ordered. +-/ + +@[expose] public section + +namespace RS + + + +/-! ## Evaluation of the extended state -/ + +namespace GenBoundaryState + +variable {k ℓ : ℕ} {α : Type} {i j : α} + +/-- The extended state's value at the first glued label. -/ +theorem extendPair_left + (st : GenBoundaryState k ℓ (Fragment.SurvivingLabel α i j)) + (c c' : Fin k ⊕ Fin (2 * ℓ)) : + extendPair i j st c c' i = c := by + unfold extendPair + exact dite_eq_left rfl + +/-- At the second glued label. -/ +theorem extendPair_right (hij : i ≠ j) + (st : GenBoundaryState k ℓ (Fragment.SurvivingLabel α i j)) + (c c' : Fin k ⊕ Fin (2 * ℓ)) : + extendPair i j st c c' j = c' := by + unfold extendPair + rw [dite_eq_right (Ne.symm hij), dite_eq_left rfl] + +/-- And at a surviving label, where it is the state extended. -/ +theorem extendPair_surviving + (st : GenBoundaryState k ℓ (Fragment.SurvivingLabel α i j)) + (c c' : Fin k ⊕ Fin (2 * ℓ)) + (a : Fragment.SurvivingLabel α i j) : + extendPair i j st c c' a.val = st a := by + unfold extendPair + rw [dite_eq_right a.prop.1, dite_eq_right a.prop.2] + +end GenBoundaryState + +/-! ## The ledger sums -/ + +/-- The square of the odd partner sign is one. -/ +theorem oddPartnerSign_sq (ℓ : ℕ) (c : Fin (2 * ℓ)) : + (oddPartnerSign ℓ c : ℂ) * (oddPartnerSign ℓ c : ℂ) = 1 := by + unfold oddPartnerSign + by_cases h : c.val < ℓ <;> simp [h] + +/-- The square of the odd partner sign is one, read through the +integer cast. -/ +theorem oddPartnerSign_cast_sq (ℓ : ℕ) (c : Fin (2 * ℓ)) : + ((oddPartnerSign ℓ c : ℤ) : ℂ) * + ((oddPartnerSign ℓ c : ℤ) : ℂ) = 1 := + oddPartnerSign_sq ℓ c + +/-! ## The closed-case correspondence engine -/ + +namespace EdgeSubset + +open Fragment + +open scoped Classical in +/-- Unfolded membership in the through-flags (stated generically to +avoid reducibility friction at glued fragments). -/ +theorem mem_throughFlags_iff {β : Type} {V : Fragment β} + {F : EdgeSubset V} {f : V.Flag} : + f ∈ F.throughFlags ↔ f ∈ F.flags ∧ + (∃ i : β, V.attach f = Sum.inr i) ∧ + (∃ j : β, V.attach (V.pairing f) = Sum.inr j) := by + unfold EdgeSubset.throughFlags + exact Finset.mem_filter + +/-! ### List and membership helpers -/ + +/-- `attachWith` respects permutations. -/ +theorem perm_attachWith {γ : Type _} {p : γ → Prop} : + ∀ {l₁ l₂ : List γ}, l₁.Perm l₂ → + ∀ (H₁ : ∀ x ∈ l₁, p x) (H₂ : ∀ x ∈ l₂, p x), + (l₁.attachWith p H₁).Perm (l₂.attachWith p H₂) := by + intro l₁ l₂ hperm + induction hperm with + | nil => intro _ _; exact List.Perm.refl _ + | cons a _ ih => + intro H₁ H₂ + rw [List.attachWith_cons, List.attachWith_cons] + exact List.Perm.cons _ (ih _ _) + | swap a b l => + intro H₁ H₂ + rw [List.attachWith_cons, List.attachWith_cons, + List.attachWith_cons, List.attachWith_cons] + exact List.Perm.swap _ _ _ + | trans h₁ _ ih₁ ih₂ => + intro H₁ H₂ + exact (ih₁ H₁ (fun x hx => H₁ x (h₁.symm.subset hx))).trans + (ih₂ (fun x hx => H₁ x (h₁.symm.subset hx)) H₂) + +/-- Finset-supported multisets map equally along a bijection of +their supports (stated without decidability data so that it +applies by unification against glued-fragment goals). -/ +theorem multiset_map_eq_of_bij {γ δ X : Type _} + (s : Finset γ) (t : Finset δ) + (e : δ → γ) (hinj : Function.Injective e) + (hmem : ∀ y, y ∈ t ↔ e y ∈ s) + (hsurj : ∀ x ∈ s, ∃ y, e y = x) + (g : γ → X) (g' : δ → X) + (hg : ∀ y ∈ t, g (e y) = g' y) : + s.val.map g = t.val.map g' := by + have hset : s = t.map ⟨e, hinj⟩ := by + ext x + rw [Finset.mem_map] + constructor + · intro hx + obtain ⟨y, rfl⟩ := hsurj x hx + exact ⟨y, (hmem y).mpr hx, rfl⟩ + · rintro ⟨y, hy, rfl⟩ + exact (hmem y).mp hy + rw [hset, + show (t.map ⟨e, hinj⟩).val = t.val.map e from rfl, + Multiset.map_map] + refine Multiset.map_congr rfl ?_ + intro y hy + exact hg y (Finset.mem_val.mp hy) + +section ClosedEngine + +variable {α : Type} {W : Fragment α} {i j : α} + (hij : i ≠ j) + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (b : Bool) + (hc' : ∀ f ∈ s', (W.gluePairClosed i j hclosed).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetClosed s' b, + W.pairing f ∈ liftSubsetClosed s' b) + +local notation "Fg" => + (EdgeSubset.mk s' hc' : EdgeSubset (W.gluePairClosed i j hclosed)) + +local notation "Fl" => + (EdgeSubset.mk (liftSubsetClosed s' b) hc : EdgeSubset W) + +variable + (κ' : (EdgeSubset.mk s' hc' : + EdgeSubset (W.gluePairClosed i j hclosed)).RelTransitionSystem) + (o' : κ'.Orientation) + +/-- The unglued transition system on the lift. -/ +local notation "κW" => + RelTransitionSystem.unglueClosed hclosed b s' hc' hc κ' + +/-- The unglued orientation on the lift. -/ +local notation "oW" => + unglueOrientationClosed hclosed b s' hc' hc κ' o' + +/-! ### The in-flag lists across the closed glue -/ + +/-- The lifted in-flag list is a permutation of the projected +glued in-flag list. -/ +theorem relInFlagsAt_perm_closed (v : W.Vertex) : + ((Fl).relInFlagsAt (oW) v).Perm + (((Fg).relInFlagsAt o' v).map Subtype.val) := by + refine List.perm_of_nodup_nodup_toFinset_eq + (relInFlagsAt_nodup _ _) + (List.Nodup.map (fun x y h => Subtype.ext h) + (relInFlagsAt_nodup _ _)) ?_ + ext f + simp only [List.mem_toFinset] + constructor + · intro hf + obtain ⟨hmem, hv, hout⟩ := mem_relInFlagsAt_iff.mp hf + have hsurv := vertex_flag_surviving (i := i) (j := j) f v hv + refine List.mem_map.mpr ⟨⟨f, hsurv.1, hsurv.2⟩, + mem_relInFlagsAt_iff.mpr ⟨?_, ?_, ?_⟩, rfl⟩ + · exact (surviving_val_mem_liftClosed_iff s' b + ⟨f, hsurv.1, hsurv.2⟩).mp hmem + · exact (glueAttach_inl_iff ⟨f, hsurv.1, hsurv.2⟩ v).mpr hv + · exact (unglueIsOut_val o'.isOut + ⟨f, hsurv.1, hsurv.2⟩).symm.trans hout + · intro hf + obtain ⟨f₀, hf₀, rfl⟩ := List.mem_map.mp hf + obtain ⟨hmem, hv, hout⟩ := mem_relInFlagsAt_iff.mp hf₀ + refine mem_relInFlagsAt_iff.mpr + ⟨(surviving_val_mem_liftClosed_iff s' b f₀).mpr hmem, + (glueAttach_inl_iff f₀ v).mp hv, + (unglueIsOut_val o'.isOut f₀).trans hout⟩ + +/-- Members of the projected glued in-flag list are internal in +the lift. -/ +theorem mem_map_relInFlagsAt_internal {v : W.Vertex} : + ∀ f ∈ ((Fg).relInFlagsAt o' v).map Subtype.val, + f ∈ (Fl).internalFlags := by + intro f hf + obtain ⟨f₀, hf₀, rfl⟩ := List.mem_map.mp hf + exact internal_val_of_glueClosed hclosed b s' hc' hc + (mem_internal_of_mem_relInFlagsAt hf₀) + +/-! ### Pointwise core data agreement -/ + +/-- The core-colour entry at the matched flag agrees. -/ +private theorem coreOdd_match_entry_closed {ℓ : ℕ} + (φW : (Fl).CoreOddColouring ℓ) (φ' : (Fg).CoreOddColouring ℓ) + (hφ : ∀ (g : SurvivingFlag W i j) + (h1 : g.val ∈ (Fl).coreFlags) (h2 : g ∈ (Fg).coreFlags), + φW.val ⟨g.val, h1⟩ = φ'.val ⟨g, h2⟩) + (f' : SurvivingFlag W i j) (_hint : f' ∈ (Fg).internalFlags) + (h1 : (κW).match_ f'.val ∈ (Fl).coreFlags) + (h2 : κ'.match_ f' ∈ (Fg).coreFlags) : + φW.val ⟨(κW).match_ f'.val, h1⟩ = + φ'.val ⟨κ'.match_ f', h2⟩ := by + have hmv : (κW).match_ f'.val = (κ'.match_ f').val := + unglueClosed_match_val hclosed b s' hc' hc κ' f' + have hmcoreW : (κ'.match_ f').val ∈ (Fl).coreFlags := by + rw [← hmv]; exact h1 + exact (congrArg φW.val (Subtype.ext hmv)).trans + (hφ (κ'.match_ f') hmcoreW h2) + +/-- The core odd pair function agrees across the closed glue. -/ +private theorem coreOddPairFn_lift_closed {ℓ : ℕ} + (φW : (Fl).CoreOddColouring ℓ) (φ' : (Fg).CoreOddColouring ℓ) + (hφ : ∀ (g : SurvivingFlag W i j) + (h1 : g.val ∈ (Fl).coreFlags) (h2 : g ∈ (Fg).coreFlags), + φW.val ⟨g.val, h1⟩ = φ'.val ⟨g, h2⟩) + (f' : SurvivingFlag W i j) (hint : f' ∈ (Fg).internalFlags) + (hintW : f'.val ∈ (Fl).internalFlags) : + (Fl).coreOddPairFn (κW) φW ⟨f'.val, hintW⟩ = + (Fg).coreOddPairFn κ' φ' ⟨f', hint⟩ := by + unfold EdgeSubset.coreOddPairFn + refine congrArg₂ (fun x y => [x, oddPartner ℓ y]) ?_ ?_ + · exact hφ f' + (internalFlags_subset_coreFlags _ hintW) + (internalFlags_subset_coreFlags _ hint) + · exact coreOdd_match_entry_closed hclosed s' b hc' hc κ' φW φ' + hφ f' hint + (internalFlags_subset_coreFlags _ ((κW).match_mem _ hintW)) + (internalFlags_subset_coreFlags _ (κ'.match_mem _ hint)) + +/-- The core odd sign function agrees across the closed glue. -/ +private theorem coreOddSignFn_lift_closed {ℓ : ℕ} + (φW : (Fl).CoreOddColouring ℓ) (φ' : (Fg).CoreOddColouring ℓ) + (hφ : ∀ (g : SurvivingFlag W i j) + (h1 : g.val ∈ (Fl).coreFlags) (h2 : g ∈ (Fg).coreFlags), + φW.val ⟨g.val, h1⟩ = φ'.val ⟨g, h2⟩) + (f' : SurvivingFlag W i j) (hint : f' ∈ (Fg).internalFlags) + (hintW : f'.val ∈ (Fl).internalFlags) : + (Fl).coreOddSignFn (κW) φW ⟨f'.val, hintW⟩ = + (Fg).coreOddSignFn κ' φ' ⟨f', hint⟩ := by + unfold EdgeSubset.coreOddSignFn + refine congrArg (oddPartnerSign ℓ) ?_ + exact coreOdd_match_entry_closed hclosed s' b hc' hc κ' φW φ' + hφ f' hint + (internalFlags_subset_coreFlags _ ((κW).match_mem _ hintW)) + (internalFlags_subset_coreFlags _ (κ'.match_mem _ hint)) + +/-! ### The list conversions -/ + +/-- Converting the flat-mapped pair list along the projection. -/ +private theorem flatMap_pair_map_val {ℓ : ℕ} + (φW : (Fl).CoreOddColouring ℓ) (φ' : (Fg).CoreOddColouring ℓ) + (hφ : ∀ (g : SurvivingFlag W i j) + (h1 : g.val ∈ (Fl).coreFlags) (h2 : g ∈ (Fg).coreFlags), + φW.val ⟨g.val, h1⟩ = φ'.val ⟨g, h2⟩) + (l : List (SurvivingFlag W i j)) : + ∀ (H1 : ∀ f ∈ l.map Subtype.val, f ∈ (Fl).internalFlags) + (H2 : ∀ f' ∈ l, f' ∈ (Fg).internalFlags), + ((l.map Subtype.val).attachWith + (· ∈ (Fl).internalFlags) H1).flatMap + ((Fl).coreOddPairFn (κW) φW) = + (l.attachWith (· ∈ (Fg).internalFlags) H2).flatMap + ((Fg).coreOddPairFn κ' φ') := by + induction l with + | nil => intro _ _; rfl + | cons f' t ih => + intro H1 H2 + change ((f'.val :: t.map Subtype.val).attachWith + (· ∈ (Fl).internalFlags) H1).flatMap + ((Fl).coreOddPairFn (κW) φW) = + ((f' :: t).attachWith (· ∈ (Fg).internalFlags) H2).flatMap + ((Fg).coreOddPairFn κ' φ') + rw [List.attachWith_cons, List.attachWith_cons] + refine congrArg₂ (· ++ ·) ?_ (ih _ _) + exact coreOddPairFn_lift_closed hclosed s' b hc' hc κ' φW φ' + hφ f' (H2 f' (List.mem_cons_self)) + (H1 f'.val (List.mem_map.mpr + ⟨f', List.mem_cons_self, rfl⟩)) + +/-- Converting the mapped sign list along the projection. -/ +private theorem map_sign_map_val {ℓ : ℕ} + (φW : (Fl).CoreOddColouring ℓ) (φ' : (Fg).CoreOddColouring ℓ) + (hφ : ∀ (g : SurvivingFlag W i j) + (h1 : g.val ∈ (Fl).coreFlags) (h2 : g ∈ (Fg).coreFlags), + φW.val ⟨g.val, h1⟩ = φ'.val ⟨g, h2⟩) + (l : List (SurvivingFlag W i j)) : + ∀ (H1 : ∀ f ∈ l.map Subtype.val, f ∈ (Fl).internalFlags) + (H2 : ∀ f' ∈ l, f' ∈ (Fg).internalFlags), + ((l.map Subtype.val).attachWith + (· ∈ (Fl).internalFlags) H1).map + ((Fl).coreOddSignFn (κW) φW) = + (l.attachWith (· ∈ (Fg).internalFlags) H2).map + ((Fg).coreOddSignFn κ' φ') := by + induction l with + | nil => intro _ _; rfl + | cons f' t ih => + intro H1 H2 + change ((f'.val :: t.map Subtype.val).attachWith + (· ∈ (Fl).internalFlags) H1).map + ((Fl).coreOddSignFn (κW) φW) = + ((f' :: t).attachWith (· ∈ (Fg).internalFlags) H2).map + ((Fg).coreOddSignFn κ' φ') + rw [List.attachWith_cons, List.attachWith_cons] + refine congrArg₂ (· :: ·) ?_ (ih _ _) + exact coreOddSignFn_lift_closed hclosed s' b hc' hc κ' φW φ' + hφ f' (H2 f' (List.mem_cons_self)) + (H1 f'.val (List.mem_map.mpr + ⟨f', List.mem_cons_self, rfl⟩)) + +/-! ### The vertex data transports -/ + +/-- The even colour multiset agrees across the closed glue. -/ +theorem evenColoursAt_transport_closed [LinearOrder α] {k : ℕ} + (ψW : (Fl).EvenColouring k) (ψ' : (Fg).EvenColouring k) + (hψ : ∀ (g : SurvivingFlag W i j) + (h1 : g.val ∉ liftSubsetClosed s' b) (h2 : g ∉ s'), + ψW.val ⟨g.val, h1⟩ = ψ'.val ⟨g, h2⟩) + (v : W.Vertex) : + (Fl).evenColoursAt ψW v = (Fg).evenColoursAt ψ' v := by + have hemb : ∀ x : {f' : (W.gluePairClosed i j hclosed).Flag // + f' ∉ (Fg).flags}, + x.val.val ∉ (Fl).flags := by + intro x hmem + exact x.prop ((surviving_val_mem_liftClosed_iff s' b + x.val).mp hmem) + have hinj : Function.Injective + (fun x : {f' : (W.gluePairClosed i j hclosed).Flag // + f' ∉ (Fg).flags} => + (⟨x.val.val, hemb x⟩ : {f : W.Flag // f ∉ (Fl).flags})) + := by + intro x y hxy + have hxy' : (⟨x.val.val, hemb x⟩ : + {f : W.Flag // f ∉ (Fl).flags}) = ⟨y.val.val, hemb y⟩ := + hxy + have hval : x.val.val = y.val.val := congrArg + (fun z : {f : W.Flag // f ∉ (Fl).flags} => z.val) hxy' + exact Subtype.ext (Subtype.ext hval) + unfold EdgeSubset.evenColoursAt + refine multiset_map_eq_of_bij _ _ + (fun x => ⟨x.val.val, hemb x⟩) hinj ?_ ?_ ψW.val ψ'.val ?_ + · intro y + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + exact glueAttach_inl_iff y.val v + · intro x hx + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hx + have hsurv := vertex_flag_surviving (i := i) (j := j) + x.val v hx + have hnot : (⟨x.val, hsurv.1, hsurv.2⟩ : + SurvivingFlag W i j) ∉ s' := by + intro hmem + exact x.prop ((surviving_val_mem_liftClosed_iff s' b + ⟨x.val, hsurv.1, hsurv.2⟩).mpr hmem) + exact ⟨⟨⟨x.val, hsurv.1, hsurv.2⟩, hnot⟩, Subtype.ext rfl⟩ + · intro y _ + exact hψ y.val (hemb y) y.prop + +/-- The core odd sign at a vertex agrees across the closed +glue. -/ +theorem coreOddSignAt_transport_closed {ℓ : ℕ} + (φW : (Fl).CoreOddColouring ℓ) (φ' : (Fg).CoreOddColouring ℓ) + (hφ : ∀ (g : SurvivingFlag W i j) + (h1 : g.val ∈ (Fl).coreFlags) (h2 : g ∈ (Fg).coreFlags), + φW.val ⟨g.val, h1⟩ = φ'.val ⟨g, h2⟩) + (v : W.Vertex) : + (Fl).coreOddSignAt (oW) φW v = (Fg).coreOddSignAt o' φ' v + := by + unfold EdgeSubset.coreOddSignAt + have hperm := perm_attachWith + (relInFlagsAt_perm_closed hclosed s' b hc' hc κ' o' v) + (fun _ hf => mem_internal_of_mem_relInFlagsAt hf) + (mem_map_relInFlagsAt_internal hclosed s' b hc' hc κ' o' + (v := v)) + rw [List.Perm.prod_eq (hperm.map ((Fl).coreOddSignFn (κW) φW))] + rw [map_sign_map_val hclosed s' b hc' hc κ' φW φ' hφ + ((Fg).relInFlagsAt o' v) _ + (fun _ hf => mem_internal_of_mem_relInFlagsAt hf)] + rfl + +/-- The evaluated core odd list at a vertex agrees across the +closed glue. -/ +theorem evalOdd_coreOddListAt_transport_closed {k ℓ : ℕ} + (h : MixedFunctional k ℓ) + (φW : (Fl).CoreOddColouring ℓ) (φ' : (Fg).CoreOddColouring ℓ) + (hφ : ∀ (g : SurvivingFlag W i j) + (h1 : g.val ∈ (Fl).coreFlags) (h2 : g ∈ (Fg).coreFlags), + φW.val ⟨g.val, h1⟩ = φ'.val ⟨g, h2⟩) + (μ : Multiset (Fin k)) (v : W.Vertex) : + h.evalOdd μ ((Fl).coreOddListAt (oW) φW v) = + h.evalOdd μ ((Fg).coreOddListAt o' φ' v) := by + unfold EdgeSubset.coreOddListAt + have hperm := perm_attachWith + (relInFlagsAt_perm_closed hclosed s' b hc' hc κ' o' v) + (fun _ hf => mem_internal_of_mem_relInFlagsAt hf) + (mem_map_relInFlagsAt_internal hclosed s' b hc' hc κ' o' + (v := v)) + have hstep := h.evalOdd_flatMap_perm μ + ((Fl).coreOddPairFn (κW) φW) (fun _ => rfl) hperm [] + simp only [List.nil_append] at hstep + rw [hstep, + flatMap_pair_map_val hclosed s' b hc' hc κ' φW φ' hφ + ((Fg).relInFlagsAt o' v) _ + (fun _ hf => mem_internal_of_mem_relInFlagsAt hf)] + rfl + +/-! ### Boundary-match transports -/ + +/-- **The vertex factor transport across the closed glue.** -/ +theorem vertexFactor_transport_closed [LinearOrder α] {k ℓ : ℕ} + (h : MixedFunctional k ℓ) + (ψW : (Fl).EvenColouring k) (ψ' : (Fg).EvenColouring k) + (hψ : ∀ (g : SurvivingFlag W i j) + (h1 : g.val ∉ liftSubsetClosed s' b) (h2 : g ∉ s'), + ψW.val ⟨g.val, h1⟩ = ψ'.val ⟨g, h2⟩) + (φW : (Fl).CoreOddColouring ℓ) (φ' : (Fg).CoreOddColouring ℓ) + (hφ : ∀ (g : SurvivingFlag W i j) + (h1 : g.val ∈ (Fl).coreFlags) (h2 : g ∈ (Fg).coreFlags), + φW.val ⟨g.val, h1⟩ = φ'.val ⟨g, h2⟩) + (v : W.Vertex) : + ((Fl).coreOddSignAt (oW) φW v : ℂ) * + h.evalOdd ((Fl).evenColoursAt ψW v) + ((Fl).coreOddListAt (oW) φW v) = + ((Fg).coreOddSignAt o' φ' v : ℂ) * + h.evalOdd ((Fg).evenColoursAt ψ' v) + ((Fg).coreOddListAt o' φ' v) := by + rw [coreOddSignAt_transport_closed hclosed s' b hc' hc κ' o' + φW φ' hφ v, + evenColoursAt_transport_closed hclosed s' b hc' hc ψW ψ' + hψ v, + evalOdd_coreOddListAt_transport_closed hclosed s' b hc' hc + κ' o' h φW φ' hφ ((Fg).evenColoursAt ψ' v) v] + +end ClosedEngine + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/C.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/C.lean new file mode 100644 index 0000000000..5a16946af8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/C.lean @@ -0,0 +1,688 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof.A + +/-! +# The closed and open masters + +The per-subset ledgers and the open-cut engine, assembled into the +master splitting identities. +-/ + +@[expose] public section + +namespace RS + + + +namespace EdgeSubset + +open Fragment + +/-! ### The open engine: non-participating correspondences -/ + +section OpenEngine + +variable {α : Type} {W : Fragment α} {i j : α} + (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairOpen i j hij hopen).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetOpen hopen s', + W.pairing f ∈ liftSubsetOpen hopen s') + (hni : partnerSurvI hopen ∉ s') + +local notation "Fg" => + (EdgeSubset.mk s' hc' : + EdgeSubset (W.gluePairOpen i j hij hopen)) + +local notation "Fl" => + (EdgeSubset.mk (liftSubsetOpen hopen s') hc : EdgeSubset W) + +include hc' hc hni in +omit hc in +/-- The far end of the `j`-edge is also absent. -/ +theorem hnj_of : partnerSurvJ hopen ∉ s' := + partnerSurvJ_notMem_of hij hopen s' hc' hni + +include hij hni in +private theorem bfi_not_mem_lift : + W.boundaryFlag i ∉ liftSubsetOpen hopen s' := fun hmem => + hni ((boundaryFlagI_mem_liftOpen_iff hij hopen s').mp hmem) + +include hc' hc hni in +omit hc in +private theorem bfj_not_mem_lift : + W.boundaryFlag j ∉ liftSubsetOpen hopen s' := fun hmem => + hnj_of hij hopen s' hc' hni + ((boundaryFlagJ_mem_liftOpen_iff hij hopen s').mp hmem) + +/-- Eulerian transport across the open lift. -/ +theorem eulerian_lift_open_iff : + (Fl).Eulerian ↔ (Fg).Eulerian := by + have hdeg : ∀ v : W.Vertex, (Fl).deg v = (Fg).deg v := by + intro v + exact deg_liftSubsetOpen_eq hopen s' v + constructor <;> intro hE v + · rw [← hdeg v]; exact hE v + · rw [hdeg v]; exact hE v + +/-- The glued boundary-state constraint follows from the lifted +one (open case). -/ +theorem genBoundarySubsetMatches_glued_of_liftOpen {k ℓ : ℕ} + (st : GenBoundaryState k ℓ (SurvivingLabel α i j)) + (c c' : Fin k ⊕ Fin (2 * ℓ)) + (hbndW : genBoundarySubsetMatches W + (liftSubsetOpen hopen s') + (GenBoundaryState.extendPair i j st c c')) : + genBoundarySubsetMatches (W.gluePairOpen i j hij hopen) s' st + := by + intro a + have h := hbndW a.val + rw [GenBoundaryState.extendPair_surviving st c c' a] at h + exact Iff.trans + (surviving_val_mem_liftOpen_iff hopen s' + (glueBoundaryFlag W i j a)).symm h + +/-! #### Through product (open, non-participating) -/ + +variable + (κ' : (EdgeSubset.mk s' hc' : + EdgeSubset (W.gluePairOpen i j hij hopen)).RelTransitionSystem) + (o' : κ'.Orientation) + +local notation "κW" => + RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ' + +local notation "oW" => + unglueOrientationOpen hij hopen s' hc' hc κ' o' + +/-! #### In-flag lists (open) -/ + +/-- The lifted in-flag list is a permutation of the projected +glued in-flag list (open case). -/ +theorem relInFlagsAt_perm_open (v : W.Vertex) : + ((Fl).relInFlagsAt (oW) v).Perm + (((Fg).relInFlagsAt o' v).map Subtype.val) := by + refine List.perm_of_nodup_nodup_toFinset_eq + (relInFlagsAt_nodup _ _) + (List.Nodup.map (fun x y hxy => Subtype.ext hxy) + (relInFlagsAt_nodup _ _)) ?_ + ext f + simp only [List.mem_toFinset] + constructor + · intro hf + obtain ⟨hmem, hv, hout⟩ := mem_relInFlagsAt_iff.mp hf + have hsurv := vertex_flag_surviving (i := i) (j := j) f v hv + refine List.mem_map.mpr ⟨⟨f, hsurv.1, hsurv.2⟩, + mem_relInFlagsAt_iff.mpr ⟨?_, ?_, ?_⟩, rfl⟩ + · exact (surviving_val_mem_liftOpen_iff hopen s' + ⟨f, hsurv.1, hsurv.2⟩).mp hmem + · exact (glueAttach_inl_iff ⟨f, hsurv.1, hsurv.2⟩ v).mpr hv + · exact (unglueIsOut_val o'.isOut + ⟨f, hsurv.1, hsurv.2⟩).symm.trans hout + · intro hf + obtain ⟨f₀, hf₀, rfl⟩ := List.mem_map.mp hf + obtain ⟨hmem, hv, hout⟩ := mem_relInFlagsAt_iff.mp hf₀ + refine mem_relInFlagsAt_iff.mpr + ⟨(surviving_val_mem_liftOpen_iff hopen s' f₀).mpr hmem, + (glueAttach_inl_iff f₀ v).mp hv, + (unglueIsOut_val o'.isOut f₀).trans hout⟩ + +/-- Members of the projected glued in-flag list are internal in +the open lift. -/ +theorem mem_map_relInFlagsAt_internal_open {v : W.Vertex} : + ∀ f ∈ ((Fg).relInFlagsAt o' v).map Subtype.val, + f ∈ (Fl).internalFlags := by + intro f hf + obtain ⟨f₀, hf₀, rfl⟩ := List.mem_map.mp hf + exact internal_val_of_glueOpen hij hopen s' hc' hc + (mem_internal_of_mem_relInFlagsAt hf₀) + +/-! #### Pointwise core data agreement (open) -/ + +/-- The core-colour entry at the matched flag agrees (open). -/ +private theorem coreOdd_match_entry_open {ℓ : ℕ} + (φW : (Fl).CoreOddColouring ℓ) (φ' : (Fg).CoreOddColouring ℓ) + (hφ : ∀ (g : SurvivingFlag W i j) + (h1 : g.val ∈ (Fl).coreFlags) (h2 : g ∈ (Fg).coreFlags), + φW.val ⟨g.val, h1⟩ = φ'.val ⟨g, h2⟩) + (f' : SurvivingFlag W i j) (_hint : f' ∈ (Fg).internalFlags) + (h1 : (κW).match_ f'.val ∈ (Fl).coreFlags) + (h2 : κ'.match_ f' ∈ (Fg).coreFlags) : + φW.val ⟨(κW).match_ f'.val, h1⟩ = + φ'.val ⟨κ'.match_ f', h2⟩ := by + have hmv : (κW).match_ f'.val = (κ'.match_ f').val := + unglueOpen_match_val hij hopen s' hc' hc κ' f' + have hmcoreW : (κ'.match_ f').val ∈ (Fl).coreFlags := by + rw [← hmv]; exact h1 + exact (congrArg φW.val (Subtype.ext hmv)).trans + (hφ (κ'.match_ f') hmcoreW h2) + +/-- The core odd pair function agrees (open). -/ +private theorem coreOddPairFn_lift_open {ℓ : ℕ} + (φW : (Fl).CoreOddColouring ℓ) (φ' : (Fg).CoreOddColouring ℓ) + (hφ : ∀ (g : SurvivingFlag W i j) + (h1 : g.val ∈ (Fl).coreFlags) (h2 : g ∈ (Fg).coreFlags), + φW.val ⟨g.val, h1⟩ = φ'.val ⟨g, h2⟩) + (f' : SurvivingFlag W i j) (hint : f' ∈ (Fg).internalFlags) + (hintW : f'.val ∈ (Fl).internalFlags) : + (Fl).coreOddPairFn (κW) φW ⟨f'.val, hintW⟩ = + (Fg).coreOddPairFn κ' φ' ⟨f', hint⟩ := by + unfold EdgeSubset.coreOddPairFn + refine congrArg₂ (fun x y => [x, oddPartner ℓ y]) ?_ ?_ + · exact hφ f' + (internalFlags_subset_coreFlags _ hintW) + (internalFlags_subset_coreFlags _ hint) + · exact coreOdd_match_entry_open hij hopen s' hc' hc κ' φW φ' + hφ f' hint + (internalFlags_subset_coreFlags _ ((κW).match_mem _ hintW)) + (internalFlags_subset_coreFlags _ (κ'.match_mem _ hint)) + +/-- The core odd sign function agrees (open). -/ +private theorem coreOddSignFn_lift_open {ℓ : ℕ} + (φW : (Fl).CoreOddColouring ℓ) (φ' : (Fg).CoreOddColouring ℓ) + (hφ : ∀ (g : SurvivingFlag W i j) + (h1 : g.val ∈ (Fl).coreFlags) (h2 : g ∈ (Fg).coreFlags), + φW.val ⟨g.val, h1⟩ = φ'.val ⟨g, h2⟩) + (f' : SurvivingFlag W i j) (hint : f' ∈ (Fg).internalFlags) + (hintW : f'.val ∈ (Fl).internalFlags) : + (Fl).coreOddSignFn (κW) φW ⟨f'.val, hintW⟩ = + (Fg).coreOddSignFn κ' φ' ⟨f', hint⟩ := by + unfold EdgeSubset.coreOddSignFn + refine congrArg (oddPartnerSign ℓ) ?_ + exact coreOdd_match_entry_open hij hopen s' hc' hc κ' φW φ' + hφ f' hint + (internalFlags_subset_coreFlags _ ((κW).match_mem _ hintW)) + (internalFlags_subset_coreFlags _ (κ'.match_mem _ hint)) + +/-! #### List conversions (open) -/ + +private theorem flatMap_pair_map_val_open {ℓ : ℕ} + (φW : (Fl).CoreOddColouring ℓ) (φ' : (Fg).CoreOddColouring ℓ) + (hφ : ∀ (g : SurvivingFlag W i j) + (h1 : g.val ∈ (Fl).coreFlags) (h2 : g ∈ (Fg).coreFlags), + φW.val ⟨g.val, h1⟩ = φ'.val ⟨g, h2⟩) + (l : List (SurvivingFlag W i j)) : + ∀ (H1 : ∀ f ∈ l.map Subtype.val, f ∈ (Fl).internalFlags) + (H2 : ∀ f' ∈ l, f' ∈ (Fg).internalFlags), + ((l.map Subtype.val).attachWith + (· ∈ (Fl).internalFlags) H1).flatMap + ((Fl).coreOddPairFn (κW) φW) = + (l.attachWith (· ∈ (Fg).internalFlags) H2).flatMap + ((Fg).coreOddPairFn κ' φ') := by + induction l with + | nil => intro _ _; rfl + | cons f' t ih => + intro H1 H2 + change ((f'.val :: t.map Subtype.val).attachWith + (· ∈ (Fl).internalFlags) H1).flatMap + ((Fl).coreOddPairFn (κW) φW) = + ((f' :: t).attachWith (· ∈ (Fg).internalFlags) H2).flatMap + ((Fg).coreOddPairFn κ' φ') + rw [List.attachWith_cons, List.attachWith_cons] + refine congrArg₂ (· ++ ·) ?_ (ih _ _) + exact coreOddPairFn_lift_open hij hopen s' hc' hc κ' φW φ' + hφ f' (H2 f' (List.mem_cons_self)) + (H1 f'.val (List.mem_map.mpr + ⟨f', List.mem_cons_self, rfl⟩)) + +private theorem map_sign_map_val_open {ℓ : ℕ} + (φW : (Fl).CoreOddColouring ℓ) (φ' : (Fg).CoreOddColouring ℓ) + (hφ : ∀ (g : SurvivingFlag W i j) + (h1 : g.val ∈ (Fl).coreFlags) (h2 : g ∈ (Fg).coreFlags), + φW.val ⟨g.val, h1⟩ = φ'.val ⟨g, h2⟩) + (l : List (SurvivingFlag W i j)) : + ∀ (H1 : ∀ f ∈ l.map Subtype.val, f ∈ (Fl).internalFlags) + (H2 : ∀ f' ∈ l, f' ∈ (Fg).internalFlags), + ((l.map Subtype.val).attachWith + (· ∈ (Fl).internalFlags) H1).map + ((Fl).coreOddSignFn (κW) φW) = + (l.attachWith (· ∈ (Fg).internalFlags) H2).map + ((Fg).coreOddSignFn κ' φ') := by + induction l with + | nil => intro _ _; rfl + | cons f' t ih => + intro H1 H2 + change ((f'.val :: t.map Subtype.val).attachWith + (· ∈ (Fl).internalFlags) H1).map + ((Fl).coreOddSignFn (κW) φW) = + ((f' :: t).attachWith (· ∈ (Fg).internalFlags) H2).map + ((Fg).coreOddSignFn κ' φ') + rw [List.attachWith_cons, List.attachWith_cons] + refine congrArg₂ (· :: ·) ?_ (ih _ _) + exact coreOddSignFn_lift_open hij hopen s' hc' hc κ' φW φ' + hφ f' (H2 f' (List.mem_cons_self)) + (H1 f'.val (List.mem_map.mpr + ⟨f', List.mem_cons_self, rfl⟩)) + +/-! #### Vertex data transports (open) -/ + +/-- The core odd sign at a vertex agrees (open). -/ +theorem coreOddSignAt_transport_open {ℓ : ℕ} + (φW : (Fl).CoreOddColouring ℓ) (φ' : (Fg).CoreOddColouring ℓ) + (hφ : ∀ (g : SurvivingFlag W i j) + (h1 : g.val ∈ (Fl).coreFlags) (h2 : g ∈ (Fg).coreFlags), + φW.val ⟨g.val, h1⟩ = φ'.val ⟨g, h2⟩) + (v : W.Vertex) : + (Fl).coreOddSignAt (oW) φW v = (Fg).coreOddSignAt o' φ' v + := by + unfold EdgeSubset.coreOddSignAt + have hperm := perm_attachWith + (relInFlagsAt_perm_open hij hopen s' hc' hc κ' o' v) + (fun _ hf => mem_internal_of_mem_relInFlagsAt hf) + (mem_map_relInFlagsAt_internal_open hij hopen s' hc' hc κ' o' + (v := v)) + rw [List.Perm.prod_eq (hperm.map ((Fl).coreOddSignFn (κW) φW))] + rw [map_sign_map_val_open hij hopen s' hc' hc κ' φW φ' hφ + ((Fg).relInFlagsAt o' v) _ + (fun _ hf => mem_internal_of_mem_relInFlagsAt hf)] + rfl + +/-- The evaluated core odd list at a vertex agrees (open). -/ +theorem evalOdd_coreOddListAt_transport_open {k ℓ : ℕ} + (h : MixedFunctional k ℓ) + (φW : (Fl).CoreOddColouring ℓ) (φ' : (Fg).CoreOddColouring ℓ) + (hφ : ∀ (g : SurvivingFlag W i j) + (h1 : g.val ∈ (Fl).coreFlags) (h2 : g ∈ (Fg).coreFlags), + φW.val ⟨g.val, h1⟩ = φ'.val ⟨g, h2⟩) + (μ : Multiset (Fin k)) (v : W.Vertex) : + h.evalOdd μ ((Fl).coreOddListAt (oW) φW v) = + h.evalOdd μ ((Fg).coreOddListAt o' φ' v) := by + unfold EdgeSubset.coreOddListAt + have hperm := perm_attachWith + (relInFlagsAt_perm_open hij hopen s' hc' hc κ' o' v) + (fun _ hf => mem_internal_of_mem_relInFlagsAt hf) + (mem_map_relInFlagsAt_internal_open hij hopen s' hc' hc κ' o' + (v := v)) + have hstep := h.evalOdd_flatMap_perm μ + ((Fl).coreOddPairFn (κW) φW) (fun _ => rfl) hperm [] + simp only [List.nil_append] at hstep + rw [hstep, + flatMap_pair_map_val_open hij hopen s' hc' hc κ' φW φ' hφ + ((Fg).relInFlagsAt o' v) _ + (fun _ hf => mem_internal_of_mem_relInFlagsAt hf)] + rfl + +/-! #### The even colouring correspondence (open) -/ + +/-- Push a glued even colouring to the open lift: the two glued +half-edges inherit the merged edge's colour. -/ +noncomputable def evenPushOpen {k : ℕ} + (ψ' : (Fg).EvenColouring k) : (Fl).EvenColouring k := + ⟨fun f => + if hfi : f.val = W.boundaryFlag i then + ψ'.val ⟨partnerSurvI hopen, hni⟩ + else if hfj : f.val = W.boundaryFlag j then + ψ'.val ⟨partnerSurvJ hopen, + hnj_of hij hopen s' hc' hni⟩ + else ψ'.val ⟨⟨f.val, hfi, hfj⟩, + fun hmem => f.prop ((surviving_val_mem_liftOpen_iff + hopen s' ⟨f.val, hfi, hfj⟩).mpr hmem)⟩, by + intro f + dsimp only [] + by_cases hfi : f.val = W.boundaryFlag i + · -- pairing f.val = partnerI.val + have hpv : W.pairing f.val = + (partnerSurvI hopen).val := by + rw [hfi]; rfl + have hp1 : W.pairing f.val ≠ W.boundaryFlag i := by + rw [hpv]; exact (partnerSurvI hopen).prop.1 + have hp2 : W.pairing f.val ≠ W.boundaryFlag j := by + rw [hpv]; exact (partnerSurvI hopen).prop.2 + rw [dite_eq_right hp1, dite_eq_right hp2, dite_eq_left hfi] + refine congrArg ψ'.val (Subtype.ext (Subtype.ext ?_)) + exact hpv + · by_cases hfj : f.val = W.boundaryFlag j + · have hpv : W.pairing f.val = + (partnerSurvJ hopen).val := by + rw [hfj]; rfl + have hp1 : W.pairing f.val ≠ W.boundaryFlag i := by + rw [hpv]; exact (partnerSurvJ hopen).prop.1 + have hp2 : W.pairing f.val ≠ W.boundaryFlag j := by + rw [hpv]; exact (partnerSurvJ hopen).prop.2 + rw [dite_eq_right hp1, dite_eq_right hp2, dite_eq_right hfi, dite_eq_left hfj] + refine congrArg ψ'.val (Subtype.ext (Subtype.ext ?_)) + exact hpv + · by_cases hpi' : W.pairing f.val = W.boundaryFlag i + · -- f is the far end of the i-edge + have hfeq : (⟨f.val, hfi, hfj⟩ : SurvivingFlag W i j) = + partnerSurvI hopen := + eq_partnerSurvI_of_pairing hopen ⟨f.val, hfi, hfj⟩ + hpi' + rw [dite_eq_left hpi', dite_eq_right hfi, dite_eq_right hfj] + exact congrArg ψ'.val (Subtype.ext hfeq).symm + · by_cases hpj' : W.pairing f.val = W.boundaryFlag j + · have hfeq : (⟨f.val, hfi, hfj⟩ : + SurvivingFlag W i j) = partnerSurvJ hopen := + eq_partnerSurvJ_of_pairing hopen + ⟨f.val, hfi, hfj⟩ hpj' + rw [dite_eq_right hpi', dite_eq_left hpj', dite_eq_right hfi, + dite_eq_right hfj] + exact congrArg ψ'.val (Subtype.ext hfeq).symm + · rw [dite_eq_right hpi', dite_eq_right hpj', dite_eq_right hfi, + dite_eq_right hfj] + have hnotmem : (⟨f.val, hfi, hfj⟩ : + SurvivingFlag W i j) ∉ s' := fun hmem => + f.prop ((surviving_val_mem_liftOpen_iff hopen + s' ⟨f.val, hfi, hfj⟩).mpr hmem) + have hrw : (W.gluePairOpen i j hij hopen).pairing + ⟨f.val, hfi, hfj⟩ = + (⟨W.pairing f.val, hpi', hpj'⟩ : + SurvivingFlag W i j) := + Subtype.ext (rewire_val_of_ne hopen + ⟨f.val, hfi, hfj⟩ hpi' hpj') + have hp := ψ'.prop ⟨⟨f.val, hfi, hfj⟩, hnotmem⟩ + refine Eq.trans ?_ hp + refine congrArg ψ'.val (Subtype.ext ?_) + exact hrw.symm⟩ + +/-- Pointwise agreement of the open even push at subset-avoiding +surviving flags. -/ +theorem evenPushOpen_agrees {k : ℕ} + (ψ' : (Fg).EvenColouring k) : + ∀ (g : SurvivingFlag W i j) + (h1 : g.val ∉ liftSubsetOpen hopen s') (h2 : g ∉ s'), + (evenPushOpen hij hopen s' hc' hc hni ψ').val ⟨g.val, h1⟩ = + ψ'.val ⟨g, h2⟩ := by + intro g h1 h2 + change (if hfi : g.val = W.boundaryFlag i then _ + else if hfj : g.val = W.boundaryFlag j then _ + else ψ'.val ⟨⟨g.val, hfi, hfj⟩, _⟩) = ψ'.val ⟨g, h2⟩ + rw [dite_eq_right g.prop.1, dite_eq_right g.prop.2] + +/-- The open even push at the two glued boundary flags. -/ +theorem evenPushOpen_at_i {k : ℕ} + (ψ' : (Fg).EvenColouring k) + (hP : W.boundaryFlag i ∉ liftSubsetOpen hopen s') : + (evenPushOpen hij hopen s' hc' hc hni ψ').val + ⟨W.boundaryFlag i, hP⟩ = + ψ'.val ⟨partnerSurvI hopen, hni⟩ := dite_eq_left rfl + +/-- The pushed even colouring at the second glued boundary flag. -/ +theorem evenPushOpen_at_j {k : ℕ} + (ψ' : (Fg).EvenColouring k) + (hP : W.boundaryFlag j ∉ liftSubsetOpen hopen s') : + (evenPushOpen hij hopen s' hc' hc hni ψ').val + ⟨W.boundaryFlag j, hP⟩ = + ψ'.val ⟨partnerSurvJ hopen, + hnj_of hij hopen s' hc' hni⟩ := by + change (if hfi : W.boundaryFlag j = W.boundaryFlag i then _ + else if hfj : W.boundaryFlag j = W.boundaryFlag j then _ + else _) = _ + rw [dite_eq_right (fun hEq => + hij (W.boundaryFlag_injective hEq).symm), dite_eq_left rfl] + +/-- The open even push is injective. -/ +theorem evenPushOpen_injective {k : ℕ} : + Function.Injective + (evenPushOpen hij hopen s' hc' hc hni (k := k)) := by + intro ψ₁ ψ₂ hEq + refine Subtype.ext (funext fun x => ?_) + have h1 : x.val.val ∉ liftSubsetOpen hopen s' := fun hmem => + x.prop ((surviving_val_mem_liftOpen_iff hopen s' + x.val).mp hmem) + have hv := congrArg (fun ψ : (Fl).EvenColouring k => + ψ.val ⟨x.val.val, h1⟩) hEq + simp only [] at hv + rw [evenPushOpen_agrees hij hopen s' hc' hc hni ψ₁ x.val h1 + x.prop, + evenPushOpen_agrees hij hopen s' hc' hc hni ψ₂ x.val h1 + x.prop] at hv + exact (congrArg ψ₁.val (Subtype.ext rfl)).symm.trans + (hv.trans (congrArg ψ₂.val (Subtype.ext rfl))) + +/-- The glued constancy across the merged edge. -/ +theorem glued_even_merged {k : ℕ} + (ψ' : (Fg).EvenColouring k) : + ψ'.val ⟨partnerSurvJ hopen, + hnj_of hij hopen s' hc' hni⟩ = + ψ'.val ⟨partnerSurvI hopen, hni⟩ := by + have hp := ψ'.prop ⟨partnerSurvI hopen, hni⟩ + refine Eq.trans ?_ hp + refine congrArg ψ'.val (Subtype.ext ?_) + exact (gluePairOpen_pairing_interface_i hij hopen + (partnerSurvI hopen) + (by rw [partnerSurvI_val hopen, W.pairing_invol])).symm + +/-! #### The even boundary match across the open glue -/ + +include hc' hc in +/-- Even boundary matching transfers across an open cut: matching +the extended state upstairs is matching the state downstairs. -/ +theorem genEvenBoundaryMatch_open_iff [LinearOrder α] {k ℓ : ℕ} + (st : GenBoundaryState k ℓ (SurvivingLabel α i j)) + (a₀ : Fin k) + (hbndW : genBoundarySubsetMatches W + (liftSubsetOpen hopen s') + (GenBoundaryState.extendPair i j st (Sum.inl a₀) + (Sum.inl a₀))) + (hbnd' : genBoundarySubsetMatches + (W.gluePairOpen i j hij hopen) s' st) + (ψ' : (Fg).EvenColouring k) : + genEvenBoundaryMatch (Fl) + (GenBoundaryState.extendPair i j st (Sum.inl a₀) + (Sum.inl a₀)) hbndW + (evenPushOpen hij hopen s' hc' hc hni ψ') ↔ + (ψ'.val ⟨partnerSurvI hopen, hni⟩ = a₀ ∧ + genEvenBoundaryMatch (Fg) st hbnd' ψ') := by + constructor + · intro hW + constructor + · have hsti : GenBoundaryState.extendPair i j st (Sum.inl a₀) + (Sum.inl a₀) i = Sum.inl a₀ := + GenBoundaryState.extendPair_left st _ _ + have hval := hW i a₀ hsti + exact (evenPushOpen_at_i hij hopen s' hc' hc hni ψ' + _).symm.trans hval + · intro a y hst + have hstW : GenBoundaryState.extendPair i j st (Sum.inl a₀) + (Sum.inl a₀) a.val = Sum.inl y := by + rw [GenBoundaryState.extendPair_surviving] + exact hst + have hval := hW a.val y hstW + exact (evenPushOpen_agrees hij hopen s' hc' hc hni ψ' + (glueBoundaryFlag W i j a) _ _).symm.trans hval + · rintro ⟨hx, hG⟩ + intro a₀' y hst + by_cases hai : a₀' = i + · subst hai + rw [GenBoundaryState.extendPair_left] at hst + have hy : y = a₀ := (Sum.inl.inj hst).symm + rw [evenPushOpen_at_i hij hopen s' hc' hc hni ψ', hx, hy] + · by_cases haj : a₀' = j + · subst haj + rw [GenBoundaryState.extendPair_right hij] at hst + have hy : y = a₀ := (Sum.inl.inj hst).symm + rw [evenPushOpen_at_j hij hopen s' hc' hc hni ψ', + glued_even_merged hij hopen s' hc' hni ψ', hx, hy] + · have hst' : st ⟨a₀', hai, haj⟩ = Sum.inl y := by + rw [← GenBoundaryState.extendPair_surviving st + (Sum.inl a₀) (Sum.inl a₀) ⟨a₀', hai, haj⟩] + exact hst + have hval := hG ⟨a₀', hai, haj⟩ y hst' + exact (evenPushOpen_agrees hij hopen s' hc' hc hni ψ' + (glueBoundaryFlag W i j ⟨a₀', hai, haj⟩) _ _).trans hval + +include hij hc' hc hni in +/-- Every colouring satisfying the diagonal lifted match lies in +the image of the open push. -/ +theorem evenPushOpen_covers {k ℓ : ℕ} + (st : GenBoundaryState k ℓ (SurvivingLabel α i j)) + (a₀ : Fin k) + (hbndW : genBoundarySubsetMatches W + (liftSubsetOpen hopen s') + (GenBoundaryState.extendPair i j st (Sum.inl a₀) + (Sum.inl a₀))) + (ψW : (Fl).EvenColouring k) + (hmatch : genEvenBoundaryMatch (Fl) + (GenBoundaryState.extendPair i j st (Sum.inl a₀) + (Sum.inl a₀)) hbndW ψW) : + ∃ ψ' : (Fg).EvenColouring k, + evenPushOpen hij hopen s' hc' hc hni ψ' = ψW := by + have hnl : ∀ g : SurvivingFlag W i j, g ∉ s' → + g.val ∉ liftSubsetOpen hopen s' := fun g hg hmem => + hg ((surviving_val_mem_liftOpen_iff hopen s' g).mp hmem) + -- boundary values of ψW are pinned to a₀ + have hbi : ∀ hP : W.boundaryFlag i ∉ liftSubsetOpen hopen + s', ψW.val ⟨W.boundaryFlag i, hP⟩ = a₀ := by + intro hP + have := hmatch i a₀ (GenBoundaryState.extendPair_left st _ _) + exact (congrArg ψW.val (Subtype.ext rfl)).trans this + have hbj : ∀ hP : W.boundaryFlag j ∉ liftSubsetOpen hopen + s', ψW.val ⟨W.boundaryFlag j, hP⟩ = a₀ := by + intro hP + have := hmatch j a₀ + (GenBoundaryState.extendPair_right hij st _ _) + exact (congrArg ψW.val (Subtype.ext rfl)).trans this + have hbfiP : W.boundaryFlag i ∉ liftSubsetOpen hopen s' := + bfi_not_mem_lift hij hopen s' hni + have hbfjP : W.boundaryFlag j ∉ liftSubsetOpen hopen s' := + bfj_not_mem_lift hij hopen s' hc' hni + have hpI : ∀ (hP : (partnerSurvI hopen).val ∉ liftSubsetOpen hopen s'), + ψW.val ⟨(partnerSurvI hopen).val, hP⟩ = a₀ + := by + intro hP + have hp := ψW.prop ⟨W.boundaryFlag i, hbfiP⟩ + exact ((congrArg ψW.val (Subtype.ext rfl)).trans hp).trans + (hbi hbfiP) + have hpJ : ∀ (hP : (partnerSurvJ hopen).val ∉ + liftSubsetOpen hopen s'), + ψW.val ⟨(partnerSurvJ hopen).val, hP⟩ = a₀ := by + intro hP + have hp := ψW.prop ⟨W.boundaryFlag j, hbfjP⟩ + exact ((congrArg ψW.val (Subtype.ext rfl)).trans hp).trans + (hbj hbfjP) + have hrwI : ((W.gluePairOpen i j hij hopen).pairing + (partnerSurvI hopen)).val = (partnerSurvJ hopen).val := + congrArg Subtype.val (gluePairOpen_pairing_interface_i hij + hopen (partnerSurvI hopen) + (by rw [partnerSurvI_val hopen, W.pairing_invol])) + have hrwJ : ((W.gluePairOpen i j hij hopen).pairing + (partnerSurvJ hopen)).val = (partnerSurvI hopen).val := + congrArg Subtype.val (gluePairOpen_pairing_interface_j hij + hopen (partnerSurvJ hopen) + (by + rw [partnerSurvJ_val hopen, W.pairing_invol] + exact fun hh => hij (W.boundaryFlag_injective hh).symm) + (by rw [partnerSurvJ_val hopen, W.pairing_invol])) + refine ⟨⟨fun x => ψW.val ⟨x.val.val, hnl x.val x.prop⟩, ?_⟩, ?_⟩ + · intro x + by_cases hxi : x.val = partnerSurvI hopen + · have h₁ : ((W.gluePairOpen i j hij hopen).pairing + x.val).val = (partnerSurvJ hopen).val := by + rw [hxi]; exact hrwI + refine ((congrArg ψW.val (Subtype.ext h₁)).trans + (hpJ (hnl _ (hnj_of hij hopen s' hc' hni)))).trans ?_ + refine ((hpI (hnl _ hni)).symm.trans + (congrArg ψW.val (Subtype.ext ?_))) + change (partnerSurvI hopen).val = x.val.val + rw [hxi] + · by_cases hxj : x.val = partnerSurvJ hopen + · have h₁ : ((W.gluePairOpen i j hij hopen).pairing + x.val).val = (partnerSurvI hopen).val := by + rw [hxj]; exact hrwJ + refine ((congrArg ψW.val (Subtype.ext h₁)).trans + (hpI (hnl _ hni))).trans ?_ + refine ((hpJ (hnl _ + (hnj_of hij hopen s' hc' hni))).symm.trans + (congrArg ψW.val (Subtype.ext ?_))) + change (partnerSurvJ hopen).val = x.val.val + rw [hxj] + · have hp1 : W.pairing x.val.val ≠ W.boundaryFlag i := + fun hh => hxi (eq_partnerSurvI_of_pairing hopen x.val hh) + have hp2 : W.pairing x.val.val ≠ W.boundaryFlag j := + fun hh => hxj + (eq_partnerSurvJ_of_pairing hopen x.val hh) + have h₁ : ((W.gluePairOpen i j hij hopen).pairing + x.val).val = W.pairing x.val.val := + rewire_val_of_ne hopen x.val hp1 hp2 + have hp := ψW.prop ⟨x.val.val, hnl x.val x.prop⟩ + exact ((congrArg ψW.val (Subtype.ext h₁)).trans hp) + · refine Subtype.ext (funext fun f => ?_) + change (if hfi : f.val = W.boundaryFlag i then _ + else if hfj : f.val = W.boundaryFlag j then _ + else _) = ψW.val f + by_cases hfi : f.val = W.boundaryFlag i + · rw [dite_eq_left hfi] + refine (hpI (hnl _ hni)).trans ?_ + refine ((hbi hbfiP).symm.trans + (congrArg ψW.val (Subtype.ext ?_))) + exact hfi.symm + · by_cases hfj : f.val = W.boundaryFlag j + · rw [dite_eq_right hfi, dite_eq_left hfj] + refine (hpJ (hnl _ + (hnj_of hij hopen s' hc' hni))).trans ?_ + refine ((hbj hbfjP).symm.trans + (congrArg ψW.val (Subtype.ext ?_))) + exact hfj.symm + · rw [dite_eq_right hfi, dite_eq_right hfj] + +open scoped Classical in +include hij hc' hc hni in +/-- The constrained lifted even sum reindexes along the open +push. -/ +theorem sum_even_open {k ℓ : ℕ} + (st : GenBoundaryState k ℓ (SurvivingLabel α i j)) + (a₀ : Fin k) + (hbndW : genBoundarySubsetMatches W + (liftSubsetOpen hopen s') + (GenBoundaryState.extendPair i j st (Sum.inl a₀) + (Sum.inl a₀))) + (G : (Fl).EvenColouring k → ℂ) : + (∑ ψW : (Fl).EvenColouring k, + if genEvenBoundaryMatch (Fl) + (GenBoundaryState.extendPair i j st (Sum.inl a₀) + (Sum.inl a₀)) hbndW ψW then G ψW else 0) = + ∑ ψ' : (Fg).EvenColouring k, + if genEvenBoundaryMatch (Fl) + (GenBoundaryState.extendPair i j st (Sum.inl a₀) + (Sum.inl a₀)) hbndW + (evenPushOpen hij hopen s' hc' hc hni ψ') then + G (evenPushOpen hij hopen s' hc' hc hni ψ') else 0 := by + calc (∑ ψW : (Fl).EvenColouring k, + if genEvenBoundaryMatch (Fl) + (GenBoundaryState.extendPair i j st (Sum.inl a₀) + (Sum.inl a₀)) hbndW ψW then G ψW else 0) + = ∑ ψW ∈ Finset.univ.image + (evenPushOpen hij hopen s' hc' hc hni (k := k)), + (if genEvenBoundaryMatch (Fl) + (GenBoundaryState.extendPair i j st (Sum.inl a₀) + (Sum.inl a₀)) hbndW ψW then G ψW else 0) := by + refine (Finset.sum_subset (Finset.subset_univ _) ?_).symm + intro ψW _ hnotim + rw [ite_eq_right (fun hmatch => hnotim ?_)] + obtain ⟨ψ', hψ'⟩ := evenPushOpen_covers hij hopen s' hc' + hc hni st a₀ hbndW ψW hmatch + exact Finset.mem_image.mpr ⟨ψ', Finset.mem_univ _, hψ'⟩ + _ = ∑ ψ' : (Fg).EvenColouring k, + (if genEvenBoundaryMatch (Fl) + (GenBoundaryState.extendPair i j st (Sum.inl a₀) + (Sum.inl a₀)) hbndW + (evenPushOpen hij hopen s' hc' hc hni ψ') then + G (evenPushOpen hij hopen s' hc' hc hni ψ') else 0) + := Finset.sum_image (fun x _ y _ hxy => + evenPushOpen_injective hij hopen s' hc' hc hni hxy) + +end OpenEngine + +/-! ### The open per-subset master -/ + +section OpenMaster + +variable {α : Type} {W : Fragment α} {i j : α} + (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + +end OpenMaster + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSubsetBij.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSubsetBij.lean new file mode 100644 index 0000000000..8af489c533 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSubsetBij.lean @@ -0,0 +1,571 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplit + +/-! +# Subset correspondence for single-pair gluing + +The subset-level maps underlying the single-pair gluing +decomposition: lift and drop maps between flag subsets of a glued +fragment `W' = W.gluePair i j hij` and flag subsets of the +original fragment `W`. Separate definitions and lemma sets for +the open case (the two glued boundary flags bound distinct edges, +unified by rewiring) and the closed case (they bound a common +edge, which closes into a free circle parameterized by a Bool). +-/ + +@[expose] public section + +namespace RS + + + +namespace Fragment + +variable {α : Type} + +/-! ### Drop map (common to both cases) -/ + +/-- Drop a flag set from `W` to the surviving flags of a glue at +`{i, j}`: keep only those flags distinct from both boundary +flags. -/ +noncomputable def dropSubset (W : Fragment α) (i j : α) + (s : Finset W.Flag) : Finset (SurvivingFlag W i j) := + s.subtype (fun f => f ≠ W.boundaryFlag i ∧ f ≠ W.boundaryFlag j) + +/-- Membership in a dropped set is membership of the underlying +flag. -/ +theorem mem_dropSubset {W : Fragment α} {i j : α} + {s : Finset W.Flag} {f : SurvivingFlag W i j} : + f ∈ W.dropSubset i j s ↔ f.val ∈ s := + Finset.mem_subtype + +/-! ### Partner surviving flags (open case) -/ + +section OpenCase + +variable {W : Fragment α} {i j : α} + +/-- In the open case, the W-partner of boundary flag `i` is a +surviving flag (it is neither `boundaryFlag i` nor +`boundaryFlag j`). -/ +def partnerSurvI + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) : + SurvivingFlag W i j := + ⟨W.pairing (W.boundaryFlag i), + fun h => W.pairing_ne _ h, + hopen⟩ + +/-- In the open case, the W-partner of boundary flag `j` is a +surviving flag. -/ +def partnerSurvJ + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) : + SurvivingFlag W i j := + ⟨W.pairing (W.boundaryFlag j), + fun h => hopen (W.pairing_boundaryFlag_comm h), + fun h => W.pairing_ne _ h⟩ + +/-- The underlying flag of the first partner. -/ +@[simp] +theorem partnerSurvI_val + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) : + (partnerSurvI hopen).val = W.pairing (W.boundaryFlag i) := rfl + +/-- The underlying flag of the second partner. -/ +@[simp] +theorem partnerSurvJ_val + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) : + (partnerSurvJ hopen).val = W.pairing (W.boundaryFlag j) := + rfl + +/-- Lift a surviving-flag set to `W` in the open case: the image +under `Subtype.val`, together with boundary flag `i` iff its +W-partner participates, and boundary flag `j` iff its W-partner +participates. -/ +noncomputable def liftSubsetOpen + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) : Finset W.Flag := + s'.image Subtype.val + ∪ (if partnerSurvI hopen ∈ s' then {W.boundaryFlag i} else ∅) + ∪ (if partnerSurvJ hopen ∈ s' + then {W.boundaryFlag j} else ∅) + +/-! #### Membership in the open-case lift -/ + +/-- The first glued boundary flag is not the image of any surviving +flag. -/ +theorem boundaryFlagI_not_mem_image + (s' : Finset (SurvivingFlag W i j)) : + W.boundaryFlag i ∉ s'.image (Subtype.val) := by + intro h + obtain ⟨f, _, hf⟩ := Finset.mem_image.mp h + exact f.prop.1 hf + +/-- Nor is the second. -/ +theorem boundaryFlagJ_not_mem_image + (s' : Finset (SurvivingFlag W i j)) : + W.boundaryFlag j ∉ s'.image (Subtype.val) := by + intro h + obtain ⟨f, _, hf⟩ := Finset.mem_image.mp h + exact f.prop.2 hf + +/-- On surviving flags an open lift is membership in the set it +lifts. -/ +theorem surviving_val_mem_liftOpen_iff + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (f : SurvivingFlag W i j) : + f.val ∈ liftSubsetOpen hopen s' ↔ f ∈ s' := by + constructor + · intro h + rw [liftSubsetOpen, Finset.mem_union, Finset.mem_union] at h + rcases h with (h | h) | h + · rw [Finset.mem_image] at h + obtain ⟨g, hg, hgv⟩ := h + exact Subtype.ext hgv.symm ▸ hg + · split_ifs at h with hp + · exact absurd (Finset.mem_singleton.mp h) f.prop.1 + · simp at h + · split_ifs at h with hp + · exact absurd (Finset.mem_singleton.mp h) f.prop.2 + · simp at h + · intro h + rw [liftSubsetOpen] + exact Finset.mem_union_left _ (Finset.mem_union_left _ + (Finset.mem_image_of_mem _ h)) + +/-- The open lift carries the first glued boundary flag exactly +when the set carries its partner: rewiring joins the two edges into +one, so their flags stand or fall together. -/ +theorem boundaryFlagI_mem_liftOpen_iff + (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) : + W.boundaryFlag i ∈ liftSubsetOpen hopen s' ↔ + partnerSurvI hopen ∈ s' := by + constructor + · intro h + rw [liftSubsetOpen, Finset.mem_union, Finset.mem_union] at h + rcases h with (h | h) | h + · exact absurd h (boundaryFlagI_not_mem_image s') + · split_ifs at h with hp + · exact hp + · simp at h + · split_ifs at h with hp + · exact absurd (Finset.mem_singleton.mp h) + (fun hh => hij (W.boundaryFlag_injective hh)) + · simp at h + · intro h + rw [liftSubsetOpen] + apply Finset.mem_union_left + apply Finset.mem_union_right + rw [ite_eq_left h] + exact Finset.mem_singleton_self _ + +/-- The same at the second glued boundary flag. -/ +theorem boundaryFlagJ_mem_liftOpen_iff + (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) : + W.boundaryFlag j ∈ liftSubsetOpen hopen s' ↔ + partnerSurvJ hopen ∈ s' := by + constructor + · intro h + rw [liftSubsetOpen, Finset.mem_union, Finset.mem_union] at h + rcases h with (h | h) | h + · exact absurd h (boundaryFlagJ_not_mem_image s') + · split_ifs at h with hp + · exact absurd (Finset.mem_singleton.mp h).symm + (fun hh => hij (W.boundaryFlag_injective hh)) + · simp at h + · split_ifs at h with hp + · exact hp + · simp at h + · intro h + rw [liftSubsetOpen] + apply Finset.mem_union_right + rw [ite_eq_left h] + exact Finset.mem_singleton_self _ + +/-! #### Round trips (open case) -/ + +/-- Dropping an open lift is the identity. -/ +theorem dropSubset_liftSubsetOpen + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) : + W.dropSubset i j (liftSubsetOpen hopen s') = s' := by + ext f + rw [mem_dropSubset, surviving_val_mem_liftOpen_iff] + +/-- Lifting the drop of an edge-closed set is the identity: nothing +is lost across an open glue. -/ +theorem liftSubsetOpen_dropSubset + (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s : Finset W.Flag) + (hcl : ∀ f ∈ s, W.pairing f ∈ s) : + liftSubsetOpen hopen (W.dropSubset i j s) = s := by + ext f + by_cases hfi : f = W.boundaryFlag i + · subst hfi + rw [boundaryFlagI_mem_liftOpen_iff hij, mem_dropSubset, + partnerSurvI_val] + constructor + · intro h + have := hcl _ h; rwa [W.pairing_invol] at this + · exact hcl _ + · by_cases hfj : f = W.boundaryFlag j + · subst hfj + rw [boundaryFlagJ_mem_liftOpen_iff hij, mem_dropSubset, + partnerSurvJ_val] + constructor + · intro h + have := hcl _ h; rwa [W.pairing_invol] at this + · exact hcl _ + · rw [show f = (⟨f, hfi, hfj⟩ : SurvivingFlag W i j).val + from rfl, + surviving_val_mem_liftOpen_iff, mem_dropSubset] + +/-! #### Forward closure transport (open case) -/ + +/-- The open lift of a rewire-closed set is edge-closed. -/ +theorem liftSubsetOpen_pairing_closed + (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hcl : ∀ f ∈ s', rewire hopen f ∈ s') : + ∀ f ∈ liftSubsetOpen hopen s', + W.pairing f ∈ liftSubsetOpen hopen s' := by + intro f hf + by_cases hfi : f = W.boundaryFlag i + · subst hfi + rw [boundaryFlagI_mem_liftOpen_iff hij] at hf + rw [show W.pairing (W.boundaryFlag i) = + (partnerSurvI hopen).val from rfl, + surviving_val_mem_liftOpen_iff] + exact hf + · by_cases hfj : f = W.boundaryFlag j + · subst hfj + rw [boundaryFlagJ_mem_liftOpen_iff hij] at hf + rw [show W.pairing (W.boundaryFlag j) = + (partnerSurvJ hopen).val from rfl, + surviving_val_mem_liftOpen_iff] + exact hf + · set g : SurvivingFlag W i j := ⟨f, hfi, hfj⟩ + rw [show f = g.val from rfl, surviving_val_mem_liftOpen_iff] + at hf + have hg := hcl g hf + unfold rewire at hg + split_ifs at hg with h1 h2 + · -- W.pairing g.val = bf_i + rw [show W.pairing f = W.boundaryFlag i from h1, + boundaryFlagI_mem_liftOpen_iff hij] + have hge : g = partnerSurvI hopen := Subtype.ext (by + have h' := congrArg W.pairing h1 + rw [W.pairing_invol] at h' + exact h') + rwa [hge] at hf + · -- W.pairing g.val = bf_j + rw [show W.pairing f = W.boundaryFlag j from h2, + boundaryFlagJ_mem_liftOpen_iff hij] + have hge : g = partnerSurvJ hopen := Subtype.ext (by + have h' := congrArg W.pairing h2 + rw [W.pairing_invol] at h' + exact h') + rwa [hge] at hf + · -- W.pairing g.val is a surviving flag + rw [show W.pairing f = + (⟨W.pairing g.val, h1, h2⟩ : + SurvivingFlag W i j).val from rfl, + surviving_val_mem_liftOpen_iff] + exact hg + +end OpenCase + +/-! ### Closed case -/ + +section ClosedCase + +variable {W : Fragment α} {i j : α} + +/-- Lift a surviving-flag set to `W` in the closed case: the +image under `Subtype.val`, together with both boundary flags `i` +and `j` iff the Bool `b` is true (the closed-off circle-edge +participates). -/ +noncomputable def liftSubsetClosed + (s' : Finset (SurvivingFlag W i j)) (b : Bool) : + Finset W.Flag := + s'.image Subtype.val + ∪ (if b then {W.boundaryFlag i, W.boundaryFlag j} else ∅) + +/-! #### Membership in the closed-case lift -/ + +/-- On surviving flags a closed lift is membership in the set it +lifts, whatever the circle bit. -/ +theorem surviving_val_mem_liftClosed_iff + (s' : Finset (SurvivingFlag W i j)) (b : Bool) + (f : SurvivingFlag W i j) : + f.val ∈ liftSubsetClosed s' b ↔ f ∈ s' := by + constructor + · intro h + rw [liftSubsetClosed, Finset.mem_union] at h + rcases h with h | h + · rw [Finset.mem_image] at h + obtain ⟨g, hg, hgv⟩ := h + exact Subtype.ext hgv.symm ▸ hg + · split_ifs at h with hb + · simp only [Finset.mem_insert, Finset.mem_singleton] at h + rcases h with h | h + · exact absurd h f.prop.1 + · exact absurd h f.prop.2 + · simp at h + · intro h + rw [liftSubsetClosed] + exact Finset.mem_union_left _ + (Finset.mem_image_of_mem _ h) + +/-- The closed lift carries the first glued boundary flag exactly +when the circle bit is set: the closed cut's own edge is either +taken whole or not at all. -/ +theorem boundaryFlagI_mem_liftClosed_iff + (_hij : i ≠ j) + (s' : Finset (SurvivingFlag W i j)) (b : Bool) : + W.boundaryFlag i ∈ liftSubsetClosed s' b ↔ b = true := by + constructor + · intro h + rw [liftSubsetClosed, Finset.mem_union] at h + rcases h with h | h + · exact absurd h (boundaryFlagI_not_mem_image s') + · split_ifs at h with hb + · exact hb + · simp at h + · intro h + rw [liftSubsetClosed, Finset.mem_union] + right; rw [ite_eq_left h] + exact Finset.mem_insert_self _ _ + +/-- The same at the second glued boundary flag, on the same bit. -/ +theorem boundaryFlagJ_mem_liftClosed_iff + (_hij : i ≠ j) + (s' : Finset (SurvivingFlag W i j)) (b : Bool) : + W.boundaryFlag j ∈ liftSubsetClosed s' b ↔ b = true := by + constructor + · intro h + rw [liftSubsetClosed, Finset.mem_union] at h + rcases h with h | h + · exact absurd h (boundaryFlagJ_not_mem_image s') + · split_ifs at h with hb + · exact hb + · simp at h + · intro h + rw [liftSubsetClosed, Finset.mem_union] + right; rw [ite_eq_left h] + simp [Finset.mem_insert, Finset.mem_singleton] + +/-! #### Round trips (closed case) -/ + +/-- Dropping a closed lift is the identity. -/ +theorem dropSubset_liftSubsetClosed + (s' : Finset (SurvivingFlag W i j)) (b : Bool) : + W.dropSubset i j (liftSubsetClosed s' b) = s' := by + ext f + rw [mem_dropSubset, surviving_val_mem_liftClosed_iff] + +/-- Lifting the drop of an edge-closed set, at the bit recording +whether the set took the closed edge, is the identity. -/ +theorem liftSubsetClosed_dropSubset + (hij : i ≠ j) + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (s : Finset W.Flag) + (hcl : ∀ f ∈ s, W.pairing f ∈ s) : + liftSubsetClosed (W.dropSubset i j s) + (decide (W.boundaryFlag i ∈ s)) = s := by + ext f + by_cases hfi : f = W.boundaryFlag i + · subst hfi + rw [boundaryFlagI_mem_liftClosed_iff hij] + simp [decide_eq_true_eq] + · by_cases hfj : f = W.boundaryFlag j + · subst hfj + rw [boundaryFlagJ_mem_liftClosed_iff hij] + simp only [decide_eq_true_eq] + constructor + · intro h + have := hcl _ h; rw [hclosed] at this; exact this + · intro h + have hpj : W.pairing (W.boundaryFlag j) = + W.boundaryFlag i := by + rw [← hclosed, W.pairing_invol] + have := hcl _ h; rw [hpj] at this; exact this + · rw [show f = (⟨f, hfi, hfj⟩ : SurvivingFlag W i j).val + from rfl, + surviving_val_mem_liftClosed_iff, mem_dropSubset] + +/-! #### Closure transport (closed case) -/ + +/-- The pairing of the closed glued fragment, as an explicit +surviving-flag function. -/ +noncomputable def closedPairingSubtype + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (f : SurvivingFlag W i j) : SurvivingFlag W i j := + ⟨W.pairing f.val, + fun h => f.prop.2 (by + rw [← W.pairing_invol f.val, h, hclosed]), + fun h => f.prop.1 (by + rw [← W.pairing_invol f.val, h, ← hclosed, + W.pairing_invol])⟩ + +/-- The closed lift of a pairing-closed set is edge-closed. -/ +@[simp] +theorem liftSubsetClosed_pairing_closed + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) (b : Bool) + (hcl : ∀ f ∈ s', closedPairingSubtype hclosed f ∈ s') : + ∀ g ∈ liftSubsetClosed s' b, + W.pairing g ∈ liftSubsetClosed s' b := by + intro g hg + by_cases hgi : g = W.boundaryFlag i + · subst hgi; rw [hclosed] + rw [liftSubsetClosed, Finset.mem_union] at hg + rcases hg with hg | hg + · exact absurd hg (boundaryFlagI_not_mem_image s') + · split_ifs at hg with hb + · rw [liftSubsetClosed, Finset.mem_union]; right + rw [ite_eq_left hb] + simp [Finset.mem_insert, Finset.mem_singleton] + · simp at hg + · by_cases hgj : g = W.boundaryFlag j + · subst hgj + have hpj : W.pairing (W.boundaryFlag j) = W.boundaryFlag i := + by rw [← hclosed, W.pairing_invol] + rw [hpj] + rw [liftSubsetClosed, Finset.mem_union] at hg + rcases hg with hg | hg + · exact absurd hg (boundaryFlagJ_not_mem_image s') + · split_ifs at hg with hb + · rw [liftSubsetClosed, Finset.mem_union]; right + rw [ite_eq_left hb] + exact Finset.mem_insert_self _ _ + · simp at hg + · set gs : SurvivingFlag W i j := ⟨g, hgi, hgj⟩ + rw [show g = gs.val from rfl, surviving_val_mem_liftClosed_iff] + at hg + rw [show W.pairing g = (closedPairingSubtype hclosed gs).val + from rfl, + surviving_val_mem_liftClosed_iff] + exact hcl gs hg + +/-- The drop of an edge-closed set is closed under the glued +fragment's pairing. -/ +theorem dropSubset_pairing_closed_of_closed + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (s : Finset W.Flag) + (hcl : ∀ f ∈ s, W.pairing f ∈ s) : + ∀ f ∈ W.dropSubset i j s, + closedPairingSubtype hclosed f ∈ W.dropSubset i j s := by + intro f hf + rw [mem_dropSubset] at hf ⊢ + exact hcl _ hf + +end ClosedCase + +/-! ### Eulerian transport -/ + +section EulerianTransport + +variable {W : Fragment α} {i j : α} + +/-- Vertex-attached flags are surviving flags: a flag attached to +an internal vertex cannot be a boundary flag. -/ +theorem vertex_flag_surviving + (f : W.Flag) (v : W.Vertex) + (hv : W.attach f = Sum.inl v) : + f ≠ W.boundaryFlag i ∧ f ≠ W.boundaryFlag j := by + refine ⟨fun h => ?_, fun h => ?_⟩ + · rw [h, W.attach_boundaryFlag] at hv; cases hv + · rw [h, W.attach_boundaryFlag] at hv; cases hv + +/-- Vertex degrees are preserved by the open-case lift. -/ +theorem deg_liftSubsetOpen_eq + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (v : W.Vertex) : + letI := Classical.decEq (W.Vertex ⊕ α) + letI := Classical.decEq (W.Vertex ⊕ SurvivingLabel α i j) + ((liftSubsetOpen hopen s').filter + (fun f => W.attach f = Sum.inl v)).card = + (s'.filter + (fun f => glueAttach W i j f = Sum.inl v)).card := by + let := Classical.decEq (W.Vertex ⊕ α) + let := Classical.decEq (W.Vertex ⊕ SurvivingLabel α i j) + have hset : (liftSubsetOpen hopen s').filter + (fun f => W.attach f = Sum.inl v) = + (s'.filter (fun f => glueAttach W i j f = Sum.inl v)).image + Subtype.val := by + ext f + rw [Finset.mem_filter, Finset.mem_image] + constructor + · intro ⟨hf, hv⟩ + have hsurv := vertex_flag_surviving (i := i) (j := j) f v hv + have hf' : (⟨f, hsurv.1, hsurv.2⟩ : + SurvivingFlag W i j) ∈ s' := by + rwa [← surviving_val_mem_liftOpen_iff hopen s' + ⟨f, hsurv.1, hsurv.2⟩] + exact ⟨⟨f, hsurv.1, hsurv.2⟩, Finset.mem_filter.mpr + ⟨hf', (glueAttach_inl_iff _ v).mpr hv⟩, rfl⟩ + · intro ⟨g, hg, hgv⟩ + subst hgv + have hg' := Finset.mem_filter.mp hg + exact ⟨(surviving_val_mem_liftOpen_iff hopen s' g).mpr + hg'.1, (glueAttach_inl_iff g v).mp hg'.2⟩ + rw [hset, Finset.card_image_of_injective _ + (fun a b h => Subtype.ext h)] + +/-- Vertex degrees are preserved by the closed-case lift. -/ +theorem deg_liftSubsetClosed_eq + (s' : Finset (SurvivingFlag W i j)) (b : Bool) + (v : W.Vertex) : + letI := Classical.decEq (W.Vertex ⊕ α) + letI := Classical.decEq (W.Vertex ⊕ SurvivingLabel α i j) + ((liftSubsetClosed s' b).filter + (fun f => W.attach f = Sum.inl v)).card = + (s'.filter + (fun f => glueAttach W i j f = Sum.inl v)).card := by + let := Classical.decEq (W.Vertex ⊕ α) + let := Classical.decEq (W.Vertex ⊕ SurvivingLabel α i j) + have hset : (liftSubsetClosed s' b).filter + (fun f => W.attach f = Sum.inl v) = + (s'.filter (fun f => glueAttach W i j f = Sum.inl v)).image + Subtype.val := by + ext f + rw [Finset.mem_filter, Finset.mem_image] + constructor + · intro ⟨hf, hv⟩ + have hsurv := vertex_flag_surviving (i := i) (j := j) f v hv + have hf' : (⟨f, hsurv.1, hsurv.2⟩ : + SurvivingFlag W i j) ∈ s' := by + rwa [← surviving_val_mem_liftClosed_iff s' b + ⟨f, hsurv.1, hsurv.2⟩] + exact ⟨⟨f, hsurv.1, hsurv.2⟩, Finset.mem_filter.mpr + ⟨hf', (glueAttach_inl_iff _ v).mpr hv⟩, rfl⟩ + · intro ⟨g, hg, hgv⟩ + subst hgv + have hg' := Finset.mem_filter.mp hg + exact ⟨(surviving_val_mem_liftClosed_iff s' b g).mpr + hg'.1, (glueAttach_inl_iff g v).mp hg'.2⟩ + rw [hset, Finset.card_image_of_injective _ + (fun a b h => Subtype.ext h)] + +end EulerianTransport + +/-! ### State compatibility -/ + +end Fragment + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GramRank.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GramRank.lean new file mode 100644 index 0000000000..9cbc4f6256 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GramRank.lean @@ -0,0 +1,110 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank + +/-! +# A factored connection pairing has bounded rank + +The edge-rank hypothesis asks for the rank of the connection map to +be bounded. A pairing that factors through a finite index set — +each row a combination of a fixed finite family of columns — has its +whole range inside the span of that family, so the rank is at most +the family's size. + +This is the linear algebra behind writing a connection matrix as a +Gram matrix: a Gram factorization exhibits each row as a combination +of the columns indexed by the ambient space's coordinates. +-/ + +@[expose] public section + +namespace RS + + + +/-- **A pairing whose rows lie in a span has rank at most that +span's generating set.** -/ +theorem rank_connectionMap_le_of_mem_span {f : ClosedFragment → ℂ} + {t : ℕ} (s : Set (Fragment (Fin t) → ℂ)) + (hmem : ∀ F : Fragment (Fin t), + (fun G => connectionPairing f t F G) ∈ Submodule.span ℂ s) : + Module.rank ℂ (LinearMap.range (connectionMap f t)) + ≤ Cardinal.mk s := by + refine le_trans (Submodule.rank_mono ?_) (rank_span_le s) + rintro _ ⟨l, rfl⟩ + rw [connectionMap, Finsupp.lift_apply] + exact Submodule.sum_mem _ + (fun F _ => Submodule.smul_mem _ _ (hmem F)) + +/-- **A pairing that factors through a finite index set has rank at +most that set's size.** The row at `F` is the combination of the +columns `w x` with coefficients `u F x`. -/ +theorem rank_connectionMap_le_of_factor {f : ClosedFragment → ℂ} + {t : ℕ} {χ : Type} [Fintype χ] + (u : Fragment (Fin t) → χ → ℂ) + (w : χ → Fragment (Fin t) → ℂ) + (hfac : ∀ (F G : Fragment (Fin t)), + connectionPairing f t F G = ∑ x : χ, u F x * w x G) : + Module.rank ℂ (LinearMap.range (connectionMap f t)) + ≤ (Fintype.card χ : Cardinal) := by + refine le_trans (rank_connectionMap_le_of_mem_span + (Set.range w) (fun F => ?_)) ?_ + · have hrow : (fun G => connectionPairing f t F G) + = ∑ x : χ, u F x • w x := by + funext G + rw [hfac F G, Finset.sum_apply] + exact Finset.sum_congr rfl (fun x _ => rfl) + rw [hrow] + exact Submodule.sum_mem _ (fun x _ => Submodule.smul_mem _ _ + (Submodule.subset_span ⟨x, rfl⟩)) + · have hsurj : Function.Surjective + (fun x : ULift.{1} χ => (⟨w x.down, ⟨x.down, rfl⟩⟩ : + Set.range w)) := by + rintro ⟨-, x, rfl⟩ + exact ⟨ULift.up x, rfl⟩ + refine le_trans (Cardinal.mk_le_of_surjective hsurj) ?_ + rw [Cardinal.mk_uLift, Cardinal.mk_fintype] + simp + +/-- **A factored pairing at every arity gives the edge-rank +bound.** -/ +theorem edgeRankBounded_of_factor {f : ClosedFragment → ℂ} {R : ℕ} + (χ : ℕ → Type) [∀ t, Fintype (χ t)] + (hcard : ∀ t, Fintype.card (χ t) = R ^ t) + (u : ∀ t, Fragment (Fin t) → χ t → ℂ) + (w : ∀ t, χ t → Fragment (Fin t) → ℂ) + (hfac : ∀ (t : ℕ) (F G : Fragment (Fin t)), + connectionPairing f t F G = ∑ x : χ t, u t F x * w t x G) : + EdgeRankBounded f R := by + intro t + refine le_trans + (rank_connectionMap_le_of_factor (u t) (w t) (hfac t)) ?_ + rw [hcard t, Nat.cast_pow] + +/-- **A Gram factorization gives the edge-rank bound.** If the +connection pairing is the bilinear form `B` evaluated at vectors +attached to the two fragments, its rank is bounded by the ambient +space's dimension. -/ +theorem edgeRankBounded_of_gram {f : ClosedFragment → ℂ} {R : ℕ} + (χ : ℕ → Type) [∀ t, Fintype (χ t)] + (hcard : ∀ t, Fintype.card (χ t) = R ^ t) + (B : ∀ t, χ t → χ t → ℂ) + (T : ∀ t, Fragment (Fin t) → χ t → ℂ) + (hgram : ∀ (t : ℕ) (F G : Fragment (Fin t)), + connectionPairing f t F G + = ∑ x : χ t, ∑ y : χ t, B t x y * T t F x * T t G y) : + EdgeRankBounded f R := by + refine edgeRankBounded_of_factor χ hcard (fun t F x => T t F x) + (fun t x G => ∑ y : χ t, B t x y * T t G y) (fun t F G => ?_) + rw [hgram t F G] + refine Finset.sum_congr rfl (fun x _ => ?_) + rw [Finset.mul_sum] + exact Finset.sum_congr rfl (fun y _ => by ring) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomCompose.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomCompose.lean new file mode 100644 index 0000000000..23c7ea90b0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomCompose.lean @@ -0,0 +1,110 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdealLeft + +/-! +# Composition descends to the Hom spaces + +With the pairing kernel a two-sided ideal (Lemma 3.3(a), both +halves), the bilinear composition of free modules descends to a +bilinear composition of Hom spaces — the composition of the skein +category. On fragment classes it is composition of fragments. +-/ + +@[expose] public section + +namespace RS + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The composition into the quotient, for a fixed left factor. -/ +noncomputable def homComposeAux (s t u : ℕ) + (x : Fragment (Fin (s + t)) →₀ ℂ) : + HomSpace f.val (t + u) →ₗ[ℂ] HomSpace f.val (s + u) := + Submodule.liftQ _ + ((LinearMap.ker (connectionMap f.val (s + u))).mkQ.comp + (composeFinsupp s t u x)) + (fun y hy => by + refine LinearMap.mem_ker.mpr ?_ + change (LinearMap.ker (connectionMap f.val (s + u))).mkQ + (composeFinsupp s t u x y) = 0 + rw [Submodule.mkQ_apply, Submodule.Quotient.mk_eq_zero] + exact composeFinsupp_ker_right f.val f.iso_invariant x hy) + +/-- The auxiliary composition on a fragment class. -/ +theorem homComposeAux_mk (s t u : ℕ) + (x : Fragment (Fin (s + t)) →₀ ℂ) + (y : Fragment (Fin (t + u)) →₀ ℂ) : + homComposeAux f s t u x + ((LinearMap.ker (connectionMap f.val (t + u))).mkQ y) = + (LinearMap.ker (connectionMap f.val (s + u))).mkQ + (composeFinsupp s t u x y) := rfl + +/-- **The descended composition** of the skein category: the +bilinear composition of Hom spaces. -/ +noncomputable def HomSpace.comp (s t u : ℕ) : + HomSpace f.val (s + t) →ₗ[ℂ] + HomSpace f.val (t + u) →ₗ[ℂ] HomSpace f.val (s + u) := + Submodule.liftQ _ + { toFun := homComposeAux f s t u + map_add' := fun x₁ x₂ => by + refine LinearMap.ext fun q => ?_ + obtain ⟨y, rfl⟩ := Submodule.Quotient.mk_surjective _ q + change homComposeAux f s t u (x₁ + x₂) + ((LinearMap.ker (connectionMap f.val (t + u))).mkQ + y) = _ + rw [homComposeAux_mk, map_add, LinearMap.add_apply, + map_add] + rfl + map_smul' := fun c x => by + refine LinearMap.ext fun q => ?_ + obtain ⟨y, rfl⟩ := Submodule.Quotient.mk_surjective _ q + change homComposeAux f s t u (c • x) + ((LinearMap.ker (connectionMap f.val (t + u))).mkQ + y) = _ + rw [homComposeAux_mk, map_smul, LinearMap.smul_apply, + map_smul] + rfl } + (fun x hx => by + rw [LinearMap.mem_ker] + refine LinearMap.ext fun q => ?_ + obtain ⟨y, rfl⟩ := Submodule.Quotient.mk_surjective _ q + change homComposeAux f s t u x + ((LinearMap.ker (connectionMap f.val (t + u))).mkQ + y) = 0 + rw [homComposeAux_mk] + exact (Submodule.Quotient.mk_eq_zero _).mpr + (composeFinsupp_ker_left f.val f.iso_invariant hx y)) + +/-- The descended composition on quotient classes. -/ +theorem HomSpace.comp_mk (s t u : ℕ) + (x : Fragment (Fin (s + t)) →₀ ℂ) + (y : Fragment (Fin (t + u)) →₀ ℂ) : + HomSpace.comp f s t u + ((LinearMap.ker (connectionMap f.val (s + t))).mkQ x) + ((LinearMap.ker (connectionMap f.val (t + u))).mkQ y) = + (LinearMap.ker (connectionMap f.val (s + u))).mkQ + (composeFinsupp s t u x y) := rfl + +/-- **Composition of fragment classes is the class of the +composition.** -/ +theorem HomSpace.comp_ofFragment (s t u : ℕ) + (F : Fragment (Fin (s + t))) (G : Fragment (Fin (t + u))) : + HomSpace.comp f s t u (HomSpace.ofFragment f.val F) + (HomSpace.ofFragment f.val G) = + HomSpace.ofFragment f.val (F.compose G) := by + change HomSpace.comp f s t u + ((LinearMap.ker (connectionMap f.val (s + t))).mkQ + (Finsupp.single F 1)) + ((LinearMap.ker (connectionMap f.val (t + u))).mkQ + (Finsupp.single G 1)) = _ + rw [HomSpace.comp_mk, composeFinsupp_single, mul_one] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomSpaces.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomSpaces.lean new file mode 100644 index 0000000000..9c71b745bb --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomSpaces.lean @@ -0,0 +1,60 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank + +/-! +# Hom spaces of the skein category + +The morphism spaces of the skein category of a graph parameter: the +free complex module on the `t`-fragments, quotiented by the kernel +of the full-closure pairing. The edge-rank hypothesis bounds their +rank through the first isomorphism theorem: the quotient by the +kernel is equivalent to the range of the pairing map. +-/ + +@[expose] public section + +namespace RS + +/-- The Hom space of the skein category at arity `t`: the free +module on `t`-fragments modulo the kernel of the connection +pairing. -/ +noncomputable def HomSpace (f : ClosedFragment → ℂ) (t : ℕ) : Type 1 := + (Fragment (Fin t) →₀ ℂ) ⧸ LinearMap.ker (connectionMap f t) + +/-- Hom spaces are abelian groups, being quotients of free +modules. -/ +noncomputable instance (f : ClosedFragment → ℂ) (t : ℕ) : + AddCommGroup (HomSpace f t) := + Submodule.Quotient.addCommGroup _ + +/-- And ℂ-modules. -/ +noncomputable instance (f : ClosedFragment → ℂ) (t : ℕ) : + Module ℂ (HomSpace f t) := + Submodule.Quotient.module _ + +/-- The class of a single fragment in the Hom space. -/ +noncomputable def HomSpace.ofFragment (f : ClosedFragment → ℂ) + {t : ℕ} (F : Fragment (Fin t)) : HomSpace f t := + Submodule.Quotient.mk (Finsupp.single F 1) + +/-- The Hom space embeds in the range of the connection pairing. -/ +noncomputable def HomSpace.equivRange (f : ClosedFragment → ℂ) + (t : ℕ) : + HomSpace f t ≃ₗ[ℂ] LinearMap.range (connectionMap f t) := + LinearMap.quotKerEquivRange (connectionMap f t) + +/-- **The Hom-space dimension bound**: the edge-rank hypothesis +caps the rank of every Hom space at `R ^ t`. -/ +theorem HomSpace.rank_le {R : ℕ} (f : EdgeRankParameter R) (t : ℕ) : + Module.rank ℂ (HomSpace f.val t) ≤ (R : Cardinal) ^ t := by + rw [(HomSpace.equivRange f.val t).rank_eq] + exact f.rank_bounded t + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTensor.lean new file mode 100644 index 0000000000..8a0dd047e8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTensor.lean @@ -0,0 +1,114 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorComm + +/-! +# The monoidal product descends to the Hom spaces + +With the tensor ideal two-sided (Lemma 3.3(b), both slots), the +bilinear tensor of free modules descends to a bilinear tensor of +Hom spaces — the monoidal product of the skein category. On +fragment classes it is the tensor of fragments. +-/ + +@[expose] public section + +namespace RS + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The tensor into the quotient, for a fixed left factor. -/ +noncomputable def homTensorAux (s t u v : ℕ) + (x : Fragment (Fin (s + t)) →₀ ℂ) : + HomSpace f.val (u + v) →ₗ[ℂ] + HomSpace f.val ((s + u) + (t + v)) := + Submodule.liftQ _ + ((LinearMap.ker (connectionMap f.val + ((s + u) + (t + v)))).mkQ.comp + (tensorFinsupp s t u v x)) + (fun y hy => by + refine LinearMap.mem_ker.mpr ?_ + change (LinearMap.ker (connectionMap f.val + ((s + u) + (t + v)))).mkQ + (tensorFinsupp s t u v x y) = 0 + rw [Submodule.mkQ_apply, Submodule.Quotient.mk_eq_zero] + exact tensorFinsupp_ker_right f.val f.iso_invariant x hy) + +/-- The auxiliary tensor on a fragment class. -/ +theorem homTensorAux_mk (s t u v : ℕ) + (x : Fragment (Fin (s + t)) →₀ ℂ) + (y : Fragment (Fin (u + v)) →₀ ℂ) : + homTensorAux f s t u v x + ((LinearMap.ker (connectionMap f.val (u + v))).mkQ y) = + (LinearMap.ker (connectionMap f.val + ((s + u) + (t + v)))).mkQ + (tensorFinsupp s t u v x y) := rfl + +/-- **The descended monoidal product** of the skein category. -/ +noncomputable def HomSpace.tensor (s t u v : ℕ) : + HomSpace f.val (s + t) →ₗ[ℂ] + HomSpace f.val (u + v) →ₗ[ℂ] + HomSpace f.val ((s + u) + (t + v)) := + Submodule.liftQ _ + { toFun := homTensorAux f s t u v + map_add' := fun x₁ x₂ => by + refine LinearMap.ext fun q => ?_ + obtain ⟨y, rfl⟩ := Submodule.Quotient.mk_surjective _ q + change homTensorAux f s t u v (x₁ + x₂) + ((LinearMap.ker (connectionMap f.val (u + v))).mkQ + y) = _ + rw [homTensorAux_mk, map_add, LinearMap.add_apply, + map_add] + rfl + map_smul' := fun c x => by + refine LinearMap.ext fun q => ?_ + obtain ⟨y, rfl⟩ := Submodule.Quotient.mk_surjective _ q + change homTensorAux f s t u v (c • x) + ((LinearMap.ker (connectionMap f.val (u + v))).mkQ + y) = _ + rw [homTensorAux_mk, map_smul, LinearMap.smul_apply, + map_smul] + rfl } + (fun x hx => by + rw [LinearMap.mem_ker] + refine LinearMap.ext fun q => ?_ + obtain ⟨y, rfl⟩ := Submodule.Quotient.mk_surjective _ q + change homTensorAux f s t u v x + ((LinearMap.ker (connectionMap f.val (u + v))).mkQ + y) = 0 + rw [homTensorAux_mk] + exact (Submodule.Quotient.mk_eq_zero _).mpr + (tensorFinsupp_ker_left f.val f.iso_invariant hx y)) + +/-- The descended tensor on quotient classes. -/ +theorem HomSpace.tensor_mk (s t u v : ℕ) + (x : Fragment (Fin (s + t)) →₀ ℂ) + (y : Fragment (Fin (u + v)) →₀ ℂ) : + HomSpace.tensor f s t u v + ((LinearMap.ker (connectionMap f.val (s + t))).mkQ x) + ((LinearMap.ker (connectionMap f.val (u + v))).mkQ y) = + (LinearMap.ker (connectionMap f.val + ((s + u) + (t + v)))).mkQ + (tensorFinsupp s t u v x y) := rfl + +/-- **Tensor of fragment classes is the class of the tensor.** -/ +theorem HomSpace.tensor_ofFragment (s t u v : ℕ) + (F : Fragment (Fin (s + t))) (G : Fragment (Fin (u + v))) : + HomSpace.tensor f s t u v (HomSpace.ofFragment f.val F) + (HomSpace.ofFragment f.val G) = + HomSpace.ofFragment f.val (tensorFragment F G) := by + change HomSpace.tensor f s t u v + ((LinearMap.ker (connectionMap f.val (s + t))).mkQ + (Finsupp.single F 1)) + ((LinearMap.ker (connectionMap f.val (u + v))).mkQ + (Finsupp.single G 1)) = _ + rw [HomSpace.tensor_mk, tensorFinsupp_single, mul_one] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceCyclic.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceCyclic.lean new file mode 100644 index 0000000000..db399aeaf8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceCyclic.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceNondegenerate + +/-! +# Trace cyclicity on Hom classes + +The accompanying paper's Lemma 3.5(a) on the category: the +descended trace of a composition is independent of the +order. Bilinear induction +with `fragTrace_comm` at the singles. +-/ + +@[expose] public section + +namespace RS + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The descended trace is cyclic. -/ +theorem HomSpace.traceMap_comp_comm {t u : ℕ} + (p : HomSpace f.val (t + u)) (q : HomSpace f.val (u + t)) : + HomSpace.traceMap f.val t + (HomSpace.comp f t u t p q) = + HomSpace.traceMap f.val u + (HomSpace.comp f u t u q p) := by + obtain ⟨x, rfl⟩ := Submodule.Quotient.mk_surjective _ p + obtain ⟨y, rfl⟩ := Submodule.Quotient.mk_surjective _ q + change traceFunctional f.val t (composeFinsupp t u t x y) = + traceFunctional f.val u (composeFinsupp u t u y x) + induction x using Finsupp.induction_linear with + | zero => simp only [map_zero, LinearMap.zero_apply] + | add x₁ x₂ h₁ h₂ => + simp only [map_add, LinearMap.add_apply] + rw [h₁, h₂] + | single F c => + induction y using Finsupp.induction_linear with + | zero => simp only [map_zero, LinearMap.zero_apply] + | add y₁ y₂ h₁ h₂ => + simp only [map_add, LinearMap.add_apply] + rw [h₁, h₂] + | single G c' => + rw [composeFinsupp_single, composeFinsupp_single] + have h1 : ∀ (a b : ℕ) (H : Fragment (Fin (a + a))) + (d : ℂ), traceFunctional f.val a + (Finsupp.single H d) = d * fragTrace f.val H := by + intro a b H d + rw [show (Finsupp.single H d : + Fragment (Fin (a + a)) →₀ ℂ) = + d • Finsupp.single H 1 by + rw [Finsupp.smul_single, smul_eq_mul, mul_one], + map_smul, traceFunctional_single, smul_eq_mul] + rw [h1 t u _ (c * c'), h1 u t _ (c' * c), + fragTrace_comm f.val f.iso_invariant F G] + ring + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceNondegenerate.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceNondegenerate.lean new file mode 100644 index 0000000000..4e01a22e02 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceNondegenerate.lean @@ -0,0 +1,46 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCategory +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceNondegenerate + +/-! +# Trace nondegeneracy on Hom classes + +The accompanying paper's Lemma 3.6, categorified: a Hom-space +class all of whose composition traces vanish is zero. This is +the input to the semisimplicity of the End algebras (Theorem 4.4) +and the atom dichotomy (Lemma 4.5). +-/ + +@[expose] public section + +namespace RS + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- **Zero negligibles on classes** (accompanying paper, +Lemma 3.6): a class all of whose composition traces vanish is +zero. -/ +theorem HomSpace.eq_zero_of_traces_vanish {t u : ℕ} + (q : HomSpace f.val (t + u)) + (hq : ∀ G : Fragment (Fin (u + t)), + HomSpace.traceMap f.val t + (HomSpace.comp f t u t q + (HomSpace.ofFragment f.val G)) = 0) : + q = 0 := by + obtain ⟨x, rfl⟩ := Submodule.Quotient.mk_surjective _ q + have hker : x ∈ LinearMap.ker (connectionMap f.val (t + u)) := by + refine mem_ker_of_traces_vanish f.val f.iso_invariant x ?_ + intro G + exact hq G + change (LinearMap.ker (connectionMap f.val (t + u))).mkQ x = 0 + rw [Submodule.mkQ_apply] + exact (Submodule.Quotient.mk_eq_zero _).mpr hker + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean new file mode 100644 index 0000000000..7d91b02691 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean @@ -0,0 +1,1105 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv + +/-! +# The identity law: stage equivalences + +Composing with a strand bundle is the identity up to fragment +equivalence. The proof runs by descending induction through +`glueInterface` with the invariant that the stage-`t'` fragment is +equivalent to `(strandBundle t').disjUnion F` relabelled along a +stage equivalence relocating the not-yet-glued interface labels of +`F` into the left label block. + +The stage equivalence is assembled from block decompositions: the +five blocks are the strand-in labels `A`, the strand-out labels +`A'`, the already-glued interface labels `B`, the not-yet-glued +interface labels `C`, and the outer labels `D`; the shuffle +`(A ⊕ A') ⊕ ((B ⊕ C) ⊕ D) ≃ ((A ⊕ C) ⊕ A') ⊕ (B ⊕ D)` is a plain +constructor permutation with definitional inverses. +-/ + +@[expose] public section + +namespace RS + +/-- The five-block shuffle underlying the stage equivalence. -/ +def stageShuffle (A A' B C D : Type) : + (A ⊕ A') ⊕ ((B ⊕ C) ⊕ D) ≃ ((A ⊕ C) ⊕ A') ⊕ (B ⊕ D) where + toFun x := match x with + | Sum.inl (Sum.inl a) => Sum.inl (Sum.inl (Sum.inl a)) + | Sum.inl (Sum.inr a') => Sum.inl (Sum.inr a') + | Sum.inr (Sum.inl (Sum.inl b)) => Sum.inr (Sum.inl b) + | Sum.inr (Sum.inl (Sum.inr c)) => Sum.inl (Sum.inl (Sum.inr c)) + | Sum.inr (Sum.inr d) => Sum.inr (Sum.inr d) + invFun y := match y with + | Sum.inl (Sum.inl (Sum.inl a)) => Sum.inl (Sum.inl a) + | Sum.inl (Sum.inl (Sum.inr c)) => Sum.inr (Sum.inl (Sum.inr c)) + | Sum.inl (Sum.inr a') => Sum.inl (Sum.inr a') + | Sum.inr (Sum.inl b) => Sum.inr (Sum.inl (Sum.inl b)) + | Sum.inr (Sum.inr d) => Sum.inr (Sum.inr d) + left_inv x := by + rcases x with (a | a') | ((b | c) | d) <;> rfl + right_inv y := by + rcases y with ((a | c) | a') | (b | d) <;> rfl + +/-- The stage relabelling for the identity law: on the left, the +`t'` strand-in labels, then the `t - t'` not-yet-glued interface +labels of `F`, then the `t'` strand-out labels; on the right, the +`t'` already-glued interface labels, then the `u` outer labels. -/ +def stageEquiv (t t' u : ℕ) (ht : t' ≤ t) : + (Fin (t' + t') ⊕ Fin (t + u)) ≃ (Fin (t + t') ⊕ Fin (t' + u)) := + (Equiv.sumCongr finSumFinEquiv.symm + (((finCongr (by omega : t + u = (t' + (t - t')) + u)).trans + finSumFinEquiv.symm).trans + (Equiv.sumCongr finSumFinEquiv.symm (Equiv.refl (Fin u))))).trans + ((stageShuffle (Fin t') (Fin t') (Fin t') (Fin (t - t')) + (Fin u)).trans + (Equiv.sumCongr + ((Equiv.sumCongr finSumFinEquiv (Equiv.refl (Fin t'))).trans + ((Equiv.sumCongr (finCongr (by omega : t' + (t - t') = t)) + (Equiv.refl (Fin t'))).trans finSumFinEquiv)) + finSumFinEquiv)) + +/-! ### Label evaluations -/ + +/-- Evaluation of the stage equivalence on a right label: an +already-glued interface label stays right, a not-yet-glued interface +label relocates to the left block, and an outer label stays right +with an offset. -/ +theorem stageEquiv_inr (t t' u : ℕ) (ht : t' ≤ t) (ℓ : Fin (t + u)) : + stageEquiv t t' u ht (Sum.inr ℓ) = + if h₁ : ℓ.val < t' then Sum.inr ⟨ℓ.val, by omega⟩ + else if h₂ : ℓ.val < t then Sum.inl ⟨ℓ.val, by omega⟩ + else Sum.inr ⟨t' + (ℓ.val - t), by omega⟩ := by + by_cases h₁ : ℓ.val < t' + · -- ═══════ CASE: already-glued interface label ═══════ + rw [dite_eq_left h₁] + simp only [stageEquiv, stageShuffle, Equiv.trans_apply, + Equiv.sumCongr_apply, Sum.map_inr, finCongr_apply] + rw [show finSumFinEquiv.symm + (Fin.cast (by omega : t + u = (t' + (t - t')) + u) ℓ) = + Sum.inl ⟨ℓ.val, by omega⟩ from by + rw [Equiv.symm_apply_eq]; exact Fin.ext (by simp)] + simp only [Sum.map_inl] + rw [show (finSumFinEquiv.symm ⟨ℓ.val, by omega⟩ : + Fin t' ⊕ Fin (t - t')) = Sum.inl ⟨ℓ.val, h₁⟩ from by + rw [Equiv.symm_apply_eq]; exact Fin.ext (by simp)] + simp only [Equiv.coe_fn_mk, Sum.map_inr] + exact congrArg Sum.inr (Fin.ext (by simp [finSumFinEquiv_apply_left])) + · rw [dite_eq_right h₁] + by_cases h₂ : ℓ.val < t + · -- ═══════ CASE: not-yet-glued interface label ═══════ + rw [dite_eq_left h₂] + simp only [stageEquiv, stageShuffle, Equiv.trans_apply, + Equiv.sumCongr_apply, Sum.map_inr, finCongr_apply] + rw [show finSumFinEquiv.symm + (Fin.cast (by omega : t + u = (t' + (t - t')) + u) ℓ) = + Sum.inl ⟨ℓ.val, by omega⟩ from by + rw [Equiv.symm_apply_eq]; exact Fin.ext (by simp)] + simp only [Sum.map_inl] + rw [show (finSumFinEquiv.symm ⟨ℓ.val, by omega⟩ : + Fin t' ⊕ Fin (t - t')) = Sum.inr ⟨ℓ.val - t', by omega⟩ from by + rw [Equiv.symm_apply_eq]; exact Fin.ext (by simp; omega)] + simp only [Equiv.coe_fn_mk, Sum.map_inl] + exact congrArg Sum.inl (Fin.ext (by + simp [finSumFinEquiv_apply_right, finCongr_apply]; omega)) + · -- ═══════ CASE: outer label ═══════ + rw [dite_eq_right h₂] + simp only [stageEquiv, stageShuffle, Equiv.trans_apply, + Equiv.sumCongr_apply, Sum.map_inr, finCongr_apply] + rw [show finSumFinEquiv.symm + (Fin.cast (by omega : t + u = (t' + (t - t')) + u) ℓ) = + Sum.inr ⟨ℓ.val - (t' + (t - t')), by omega⟩ from by + rw [Equiv.symm_apply_eq]; exact Fin.ext (by simp; omega)] + simp only [Equiv.coe_fn_mk, Sum.map_inr] + exact congrArg Sum.inr + (Fin.ext (by simp [finSumFinEquiv_apply_right]; omega)) + +/-- Evaluation of the stage equivalence on a left (strand) label: +a strand-in label stays left with its index, a strand-out label +goes left with an offset past the interface block. -/ +theorem stageEquiv_inl (t t' u : ℕ) (ht : t' ≤ t) (a : Fin (t' + t')) : + stageEquiv t t' u ht (Sum.inl a) = + if h : a.val < t' then Sum.inl ⟨a.val, by omega⟩ + else Sum.inl ⟨t + (a.val - t'), by omega⟩ := by + by_cases h : a.val < t' + · -- ═══════ CASE: strand-in label ═══════ + rw [dite_eq_left h] + simp only [stageEquiv, stageShuffle, Equiv.trans_apply, + Equiv.sumCongr_apply, Sum.map_inl] + rw [show (finSumFinEquiv.symm a : Fin t' ⊕ Fin t') = + Sum.inl ⟨a.val, h⟩ from by + rw [Equiv.symm_apply_eq]; exact Fin.ext (by simp)] + simp only [Equiv.coe_fn_mk, Sum.map_inl] + exact congrArg Sum.inl (Fin.ext (by + simp [finSumFinEquiv_apply_left, finCongr_apply])) + · -- ═══════ CASE: strand-out label ═══════ + rw [dite_eq_right h] + simp only [stageEquiv, stageShuffle, Equiv.trans_apply, + Equiv.sumCongr_apply, Sum.map_inl] + rw [show (finSumFinEquiv.symm a : Fin t' ⊕ Fin t') = + Sum.inr ⟨a.val - t', by omega⟩ from by + rw [Equiv.symm_apply_eq]; exact Fin.ext (by simp; omega)] + simp only [Equiv.coe_fn_mk] + exact congrArg Sum.inl (Fin.ext (by simp [finSumFinEquiv_apply_right])) + +/-! ### The base case -/ + +/-- Evaluation of the stage-zero equivalence on a right label: an +interface label relocates to the left block, an outer label stays +right. -/ +theorem stageEquiv_zero_inr (t u : ℕ) (ℓ : Fin (t + u)) : + stageEquiv t 0 u (Nat.zero_le t) (Sum.inr ℓ) = + if h : ℓ.val < t then Sum.inl ⟨ℓ.val, by omega⟩ + else Sum.inr ⟨ℓ.val - t, by omega⟩ := by + rw [stageEquiv_inr] + simp only [Nat.not_lt_zero, dite_false] + split + · exact congrArg Sum.inl (Fin.ext rfl) + · exact congrArg Sum.inr (Fin.ext (by simp)) + +/-- The empty bundle has no flags. -/ +instance strandBundleZero_flag_isEmpty : IsEmpty (strandBundle 0).Flag := + ⟨fun ⟨k, _⟩ => k.elim0⟩ + +/-- Nor any vertices — it is the empty fragment. -/ +instance strandBundleZero_vertex_isEmpty : IsEmpty (strandBundle 0).Vertex := + ⟨fun x => x.elim⟩ + +/-- The base case of the identity law: after zero interface gluings, +the triply-relabelled strand-0/F union is equivalent to F. -/ +noncomputable def stageZeroEquiv (t u : ℕ) (F : Fragment (Fin (t + u))) : + ((glueInterface t 0 u (((strandBundle 0).disjUnion F).relabel + (stageEquiv t 0 u (Nat.zero_le t)))).relabel finSumFinEquiv).Equiv F where + flagEquiv := Equiv.emptySum _ _ + vertexEquiv := Equiv.emptySum _ _ + attach_comm := fun f => by + change F.attach ((Equiv.emptySum _ _) f) = + (((glueInterface t 0 u (((strandBundle 0).disjUnion F).relabel + (stageEquiv t 0 u (Nat.zero_le t)))).relabel finSumFinEquiv).attach + f).map + (Equiv.emptySum _ _) id + cases f with + | inl x => exact (IsEmpty.false x).elim + | inr g => + simp only [Equiv.emptySum_apply_inr] + change F.attach g = + (((((F.attach g).map Sum.inr Sum.inr).map id + (stageEquiv t 0 u (Nat.zero_le t))).map id + (Equiv.sumCongr (finCongr (by omega : t + 0 = t)) + (finCongr (by omega : 0 + u = u)))).map id finSumFinEquiv).map + (Equiv.emptySum _ _) id + rcases ha : F.attach g with v | ℓ + · simp + · simp only [Sum.map_inr] + congr 1 + rw [stageEquiv_zero_inr] + split + · rename_i h + simp [finSumFinEquiv_apply_left] + · rename_i h + simp [finSumFinEquiv_apply_right, finCongr_apply, Fin.ext_iff] + omega + pairing_comm := fun f => by + cases f with + | inl x => exact (IsEmpty.false x).elim + | inr g => rfl + circles_eq := Nat.zero_add _ + +/-! ### The descent step -/ + +/-- The boundary flag at the left interface label in the relabelled +disjoint union: it is the outgoing end of strand `t'`. -/ +theorem stageStep_leftBoundary (t t' u : ℕ) (ht : t' + 1 ≤ t) + (F : Fragment (Fin (t + u))) : + (((strandBundle (t' + 1)).disjUnion F).relabel + (stageEquiv t (t' + 1) u ht)).boundaryFlag + (Sum.inl ⟨t + t', by omega⟩) = + Sum.inl (⟨t', by omega⟩, true) := by + change ((strandBundle (t' + 1)).disjUnion F).boundaryFlag + ((stageEquiv t (t' + 1) u ht).symm (Sum.inl ⟨t + t', by omega⟩)) = + Sum.inl (⟨t', by omega⟩, true) + have hsymm : (stageEquiv t (t' + 1) u ht).symm (Sum.inl ⟨t + t', by omega⟩) = + Sum.inl ⟨(t' + 1) + t', by omega⟩ := by + rw [Equiv.symm_apply_eq, stageEquiv_inl] + split + · next h => + exact absurd h + (show ¬ ((t' + 1) + t' : ℕ) < t' + 1 from by omega) + · exact congrArg Sum.inl + (Fin.ext (show t + t' = t + ((t' + 1) + t' - (t' + 1)) from by omega)) + rw [hsymm] + change Sum.inl + ((strandBundle (t' + 1)).boundaryFlag ⟨(t' + 1) + t', by omega⟩) = + Sum.inl (⟨t', by omega⟩, true) + rw [strandBundle_boundaryFlag_high (t' + 1) ⟨(t' + 1) + t', by omega⟩ + (show ¬ ((t' + 1) + t' : ℕ) < t' + 1 from by omega)] + exact congrArg Sum.inl + (Prod.ext (Fin.ext (show (t' + 1) + t' - (t' + 1) = t' from by omega)) rfl) + +/-- The boundary flag at the right interface label in the relabelled +disjoint union: it is F's boundary flag at label `t'`. -/ +theorem stageStep_rightBoundary (t t' u : ℕ) (ht : t' + 1 ≤ t) + (F : Fragment (Fin (t + u))) : + (((strandBundle (t' + 1)).disjUnion F).relabel + (stageEquiv t (t' + 1) u ht)).boundaryFlag + (Sum.inr ⟨t', by omega⟩) = + Sum.inr (F.boundaryFlag ⟨t', by omega⟩) := by + change ((strandBundle (t' + 1)).disjUnion F).boundaryFlag + ((stageEquiv t (t' + 1) u ht).symm (Sum.inr ⟨t', by omega⟩)) = + Sum.inr (F.boundaryFlag ⟨t', by omega⟩) + have hsymm : (stageEquiv t (t' + 1) u ht).symm (Sum.inr ⟨t', by omega⟩) = + Sum.inr ⟨t', by omega⟩ := by + rw [Equiv.symm_apply_eq, stageEquiv_inr] + split + · exact congrArg Sum.inr (Fin.ext rfl) + · next h => exact absurd (show (t' : ℕ) < t' + 1 from by omega) h + rw [hsymm] + rfl + +/-- The glue in the descent step is always the open case. -/ +theorem stageStep_hopen (t t' u : ℕ) (ht : t' + 1 ≤ t) + (F : Fragment (Fin (t + u))) : + (((strandBundle (t' + 1)).disjUnion F).relabel + (stageEquiv t (t' + 1) u ht)).pairing + ((((strandBundle (t' + 1)).disjUnion F).relabel + (stageEquiv t (t' + 1) u ht)).boundaryFlag + (Sum.inl ⟨t + t', by omega⟩)) ≠ + (((strandBundle (t' + 1)).disjUnion F).relabel + (stageEquiv t (t' + 1) u ht)).boundaryFlag + (Sum.inr ⟨t', by omega⟩) := by + rw [stageStep_leftBoundary, stageStep_rightBoundary] + simp [Fragment.relabel, Fragment.disjUnion, strandBundle] + +/-- The pairing partner of the left boundary flag in the relabelled +fragment: it is (t', false), the incoming end of strand t'. -/ +theorem stageStep_leftPairing (t t' u : ℕ) (ht : t' + 1 ≤ t) + (F : Fragment (Fin (t + u))) : + (((strandBundle (t' + 1)).disjUnion F).relabel + (stageEquiv t (t' + 1) u ht)).pairing + (Sum.inl (⟨t', by omega⟩, true)) = + Sum.inl (⟨t', by omega⟩, false) := by + rfl + +/-- The flag equivalence for the descent step: surviving flags of the +open glue at stage `t' + 1` correspond to flags of the stage-`t'` +disjoint union `(strandBundle t').disjUnion F`. -/ +noncomputable def stageStepFlagEquiv (t t' u : ℕ) (ht : t' + 1 ≤ t) + (F : Fragment (Fin (t + u))) : + Fragment.SurvivingFlag + (((strandBundle (t' + 1)).disjUnion F).relabel (stageEquiv t (t' + 1) u + ht)) + (Sum.inl ⟨t + t', by omega⟩) (Sum.inr ⟨t', by omega⟩) ≃ + (Fin t' × Bool) ⊕ F.Flag where + toFun x := + match x.val with + | Sum.inl (⟨k, _⟩, b) => + if hlt : k < t' then Sum.inl (⟨k, hlt⟩, b) + else Sum.inr (F.boundaryFlag ⟨t', by omega⟩) + | Sum.inr g => Sum.inr g + invFun y := + match y with + | Sum.inl (⟨k, hk⟩, b) => + ⟨Sum.inl (⟨k, by omega⟩, b), by + refine ⟨fun h => ?_, fun h => ?_⟩ + · rw [stageStep_leftBoundary] at h + have hkeq : k = t' := congrArg Fin.val + (congrArg Prod.fst (Sum.inl.inj h)) + omega + · rw [stageStep_rightBoundary] at h; simp at h⟩ + | Sum.inr g => + if hg : g = F.boundaryFlag ⟨t', by omega⟩ then + ⟨Sum.inl (⟨t', by omega⟩, false), by + refine ⟨fun h => ?_, fun h => ?_⟩ + · rw [stageStep_leftBoundary] at h + have hbeq : (false : Bool) = true := + congrArg Prod.snd (Sum.inl.inj h) + exact absurd hbeq (by decide) + · rw [stageStep_rightBoundary] at h; simp at h⟩ + else + ⟨Sum.inr g, by + refine ⟨fun h => ?_, fun h => ?_⟩ + · rw [stageStep_leftBoundary] at h; simp at h + · rw [stageStep_rightBoundary] at h + exact hg (Sum.inr.inj h)⟩ + left_inv x := by + obtain ⟨f, hne⟩ := x + rcases f with ⟨⟨k, hk⟩, b⟩ | g + · -- f = Sum.inl (⟨k, hk⟩, b) + dsimp only + by_cases hlt : k < t' + · simp only [dite_eq_left hlt] + · have hk_eq : k = t' := by omega + simp only [dite_eq_right hlt] + have hb : b = false := by + by_contra hbt + have hbtrue : b = true := by cases b <;> simp_all + exact hne.1 (by + rw [stageStep_leftBoundary] + exact hk_eq ▸ hbtrue ▸ congrArg Sum.inl (Prod.ext (Fin.ext rfl) + rfl)) + exact Subtype.ext (hk_eq ▸ hb ▸ congrArg Sum.inl (Prod.ext (Fin.ext rfl) + rfl)) + · -- f = Sum.inr g + dsimp only + have hg : g ≠ F.boundaryFlag ⟨t', by omega⟩ := by + intro heq + exact hne.2 (by + rw [stageStep_rightBoundary] + exact congrArg Sum.inr heq) + simp only [dite_eq_right hg] + right_inv y := by + match y with + | Sum.inl (⟨k, hk⟩, b) => + dsimp only + simp only [dite_eq_left hk] + | Sum.inr g => + dsimp only + by_cases hg : g = F.boundaryFlag ⟨t', by omega⟩ + · simp only [dite_eq_left hg, dite_eq_right (show ¬ (t' : ℕ) < t' from Nat.lt_irrefl + t')] + exact congrArg Sum.inr hg.symm + · simp only [dite_eq_right hg] + +/-! ### interfaceStepEquiv evaluation lemmas -/ + +private theorem interfaceStepEquiv_symm_inl (s t u : ℕ) (j : Fin (s + t)) : + ((interfaceStepEquiv s t u).symm (Sum.inl j)).val = + Sum.inl ⟨j.val, by omega⟩ := by + simp only [interfaceStepEquiv, Equiv.symm_trans_apply, Equiv.sumCongr_symm, + Equiv.sumCongr_apply, Sum.map_inl] + have key : ((finRemoveEquiv (⟨s + t, Nat.lt_succ_self _⟩ : Fin (s + t + + 1))).symm j).val = + ⟨j.val, by omega⟩ := by + simp only [finRemoveEquiv, Equiv.coe_fn_symm_mk] + rw [finSuccEquiv'_symm_some_below] + · rfl + · exact Fin.mk_lt_mk.mpr j.isLt + change ((sumRemoveSplitEquiv _ _).symm (Sum.inl _)).val = _ + simp only [sumRemoveSplitEquiv] + exact congrArg Sum.inl key + +private theorem interfaceStepEquiv_symm_inr_below (s t u : ℕ) (j : Fin (t + u)) + (hj : j.val < t) : + ((interfaceStepEquiv s t u).symm (Sum.inr j)).val = + Sum.inr ⟨j.val, by omega⟩ := by + simp only [interfaceStepEquiv, Equiv.symm_trans_apply, Equiv.sumCongr_symm, + Equiv.sumCongr_apply, Sum.map_inr] + change ((sumRemoveSplitEquiv _ _).symm (Sum.inr _)).val = _ + simp only [sumRemoveSplitEquiv] + apply congrArg Sum.inr; ext + simp only [rightRemoveEquiv, Equiv.symm_trans_apply, + Equiv.subtypeEquiv_symm, Equiv.subtypeEquiv_apply, + finCongr_symm, finCongr_apply] + simp only [finRemoveEquiv, Equiv.coe_fn_symm_mk] + rw [finSuccEquiv'_symm_some_below] + · simp [Fin.castSucc] + · simp only [Fin.castSucc, Fin.lt_def, Fin.val_castAdd]; exact hj + +private theorem interfaceStepEquiv_symm_inr_above (s t u : ℕ) (j : Fin (t + u)) + (hj : ¬ j.val < t) : + ((interfaceStepEquiv s t u).symm (Sum.inr j)).val = + Sum.inr ⟨j.val + 1, by omega⟩ := by + simp only [interfaceStepEquiv, Equiv.symm_trans_apply, Equiv.sumCongr_symm, + Equiv.sumCongr_apply, Sum.map_inr] + change ((sumRemoveSplitEquiv _ _).symm (Sum.inr _)).val = _ + simp only [sumRemoveSplitEquiv] + apply congrArg Sum.inr; ext + simp only [rightRemoveEquiv, Equiv.symm_trans_apply, + Equiv.subtypeEquiv_symm, Equiv.subtypeEquiv_apply, + finCongr_symm, finCongr_apply] + simp only [finRemoveEquiv, Equiv.coe_fn_symm_mk] + rw [finSuccEquiv'_symm_some_above] + · simp [Fin.succ] + · simp [Fin.le_iff_val_le_val, Fin.castSucc]; omega + +/-- Evaluation of `interfaceStepEquiv` on a left surviving label. -/ +theorem interfaceStepEquiv_eval_inl (s t u : ℕ) (j : ℕ) (hj : j < s + t) : + (interfaceStepEquiv s t u) + ⟨Sum.inl ⟨j, by omega⟩, + fun h => by simp [Fin.ext_iff] at h; omega, + fun h => by simp at h⟩ = + Sum.inl ⟨j, hj⟩ := by + apply (Equiv.eq_symm_apply _).mp + exact Subtype.ext (interfaceStepEquiv_symm_inl s t u ⟨j, hj⟩).symm + +/-- Evaluation of `interfaceStepEquiv` on a right surviving label +below the cut. -/ +theorem interfaceStepEquiv_eval_inr_below (s t u : ℕ) (j : ℕ) (hj : j < t) : + (interfaceStepEquiv s t u) + ⟨Sum.inr ⟨j, by omega⟩, + fun h => by simp at h, + fun h => by simp [Fin.ext_iff] at h; omega⟩ = + Sum.inr ⟨j, by omega⟩ := by + apply (Equiv.eq_symm_apply _).mp + exact Subtype.ext + (interfaceStepEquiv_symm_inr_below s t u ⟨j, by omega⟩ hj).symm + +/-- Evaluation of `interfaceStepEquiv` on a right surviving label +above the cut. -/ +theorem interfaceStepEquiv_eval_inr_above (s t u : ℕ) (j : ℕ) + (hj : t < j) (hj' : j < t + 1 + u) : + (interfaceStepEquiv s t u) + ⟨Sum.inr ⟨j, hj'⟩, + fun h => by simp at h, + fun h => by simp [Fin.ext_iff] at h; omega⟩ = + Sum.inr ⟨j - 1, by omega⟩ := by + have key : (interfaceStepEquiv s t u).symm (Sum.inr ⟨j - 1, by omega⟩) = + ⟨Sum.inr ⟨j, hj'⟩, + fun h => by simp at h, + fun h => by simp [Fin.ext_iff] at h; omega⟩ := by + apply Subtype.ext + rw [interfaceStepEquiv_symm_inr_above s t u ⟨j - 1, by omega⟩ + (show ¬ (j - 1 : ℕ) < t from by omega)] + exact congrArg Sum.inr (Fin.ext (show j - 1 + 1 = j from by omega)) + exact (Equiv.eq_symm_apply _).mp key.symm + +/-! ### The stage step equivalence -/ + +/-- The relabelled strand-fragment union before the next left identity glue. -/ +abbrev baseFragment (t t' u : ℕ) (ht : t' + 1 ≤ t) + (F : Fragment (Fin (t + u))) := + ((strandBundle (t' + 1)).disjUnion F).relabel (stageEquiv t (t' + 1) u ht) + +/-- The relabelled strand-fragment union at the target stage of identity descent. -/ +abbrev targetFragment (t t' u : ℕ) (ht' : t' ≤ t) + (F : Fragment (Fin (t + u))) := + ((strandBundle t').disjUnion F).relabel (stageEquiv t t' u ht') + +/-- The source fragment obtained by one open glue in the left identity descent. -/ +noncomputable abbrev sourceFragment (t t' u : ℕ) (ht : t' + 1 ≤ t) + (F : Fragment (Fin (t + u))) := + ((baseFragment t t' u ht F).gluePairOpen + (Sum.inl ⟨t + t', by omega⟩) (Sum.inr ⟨t', by omega⟩) + (by simp) (by exact stageStep_hopen t t' u ht F)).relabel (interfaceStepEquiv t t' u) + +-- The four equivalence fields are checked against +-- the glued fragment at once, each on both label halves. +private theorem stageStep_attach_inl (t t' u : ℕ) (ht : t' + 1 ≤ t) + (F : Fragment (Fin (t + u))) + (k : ℕ) (hk : k < t' + 1) (b : Bool) + (hne : (Sum.inl (⟨k, hk⟩, b) : (baseFragment t t' u ht F).Flag) ≠ + (baseFragment t t' u ht F).boundaryFlag (Sum.inl ⟨t + t', by omega⟩) ∧ + (Sum.inl (⟨k, hk⟩, b) : (baseFragment t t' u ht F).Flag) ≠ + (baseFragment t t' u ht F).boundaryFlag (Sum.inr ⟨t', by omega⟩)) : + (targetFragment t t' u (by omega) F).attach + (stageStepFlagEquiv t t' u ht F ⟨Sum.inl (⟨k, hk⟩, b), hne⟩) = + ((sourceFragment t t' u ht F).attach ⟨Sum.inl (⟨k, hk⟩, b), hne⟩).map (Equiv.refl _) id := by + by_cases hlt : k < t' + · -- Case 1: k < t' + have hflag : (stageStepFlagEquiv t t' u ht F) ⟨Sum.inl (⟨k, hk⟩, b), + hne⟩ = + Sum.inl (⟨k, hlt⟩, b) := by + have key : (stageStepFlagEquiv t t' u ht F) ⟨Sum.inl (⟨k, hk⟩, b), + hne⟩ = + if hlt' : k < t' then Sum.inl (⟨k, hlt'⟩, b) + else Sum.inr (F.boundaryFlag ⟨t', by omega⟩) := rfl + rw [key, dite_eq_left hlt] + set common : (targetFragment t t' u (by omega) F).Vertex ⊕ + (Fin (t + t') ⊕ Fin (t' + u)) := + Sum.inr (Sum.inl ⟨if b then t + k else k, by split <;> omega⟩) + have hLHS : (targetFragment t t' u (by omega) F).attach + (Sum.inl (⟨k, hlt⟩, b)) = + common := by + change (((strandBundle t').disjUnion F).attach (Sum.inl (⟨k, hlt⟩, + b))).map id + (stageEquiv t t' u _) = _ + change (((strandBundle t').attach (⟨k, hlt⟩, b)).map Sum.inl + Sum.inl).map id + (stageEquiv t t' u _) = _ + simp only [strandBundle, Sum.map, Sum.elim, Function.comp] + apply congrArg Sum.inr; cases b + · simp only [ite_false, Bool.false_eq_true] + rw [stageEquiv_inl t t' u (by omega) ⟨k, by omega⟩, dite_eq_left hlt] + · simp only [ite_true] + rw [stageEquiv_inl t t' u (by omega) ⟨t' + k, by omega⟩, + dite_eq_right (show ¬ (t' + k : ℕ) < t' from by omega)] + exact congrArg Sum.inl (Fin.ext (by simp)) + have hRHS : (sourceFragment t t' u ht F).attach ⟨Sum.inl (⟨k, hk⟩, b), + hne⟩ = + common := by + change ((Fragment.glueAttach (baseFragment t t' u ht F) + (Sum.inl ⟨t + t', by omega⟩) (Sum.inr ⟨t', by omega⟩) + ⟨Sum.inl (⟨k, hk⟩, b), hne⟩).map id (interfaceStepEquiv t t' u)) = + _ + have hba : (baseFragment t t' u ht F).attach (Sum.inl (⟨k, hk⟩, b)) = + Sum.inr (Sum.inl ⟨if b then t + k else k, by split <;> omega⟩) := + by + change (((strandBundle (t' + 1)).disjUnion F).attach + (Sum.inl (⟨k, hk⟩, b))).map id (stageEquiv t (t' + 1) u ht) = _ + change (((strandBundle (t' + 1)).attach (⟨k, hk⟩, b)).map Sum.inl + Sum.inl).map id + (stageEquiv t (t' + 1) u ht) = _ + simp only [strandBundle, Sum.map, Sum.elim, Function.comp] + apply congrArg Sum.inr; cases b + · simp only [ite_false, Bool.false_eq_true] + rw [stageEquiv_inl t (t' + 1) u ht ⟨k, by omega⟩, + dite_eq_left (show (k : ℕ) < t' + 1 from by omega)] + · simp only [ite_true] + rw [stageEquiv_inl t (t' + 1) u ht ⟨(t' + 1) + k, by omega⟩, + dite_eq_right (show ¬ ((t' + 1) + k : ℕ) < t' + 1 from by omega)] + exact congrArg Sum.inl (Fin.ext (by simp)) + refine Fragment.glueAttach_cases _ (fun v hv => ?_) + (fun ℓ hℓ => ?_) + · exact absurd (hv.symm.trans hba) (nomatch ·) + · obtain ⟨ℓ, _hs₁, _hs₂⟩ := ℓ + simp only [Sum.map_inr] + have hℓ_eq : ℓ = + Sum.inl ⟨if b then t + k else k, by split <;> omega⟩ := + Sum.inr.inj (hℓ.symm.trans hba) + subst hℓ_eq; refine congrArg Sum.inr ?_ + cases b + · exact interfaceStepEquiv_eval_inl t t' u k (by omega) + · exact interfaceStepEquiv_eval_inl t t' u (t + k) (by omega) + exact (hflag ▸ hLHS).trans + (by rw [hRHS]; rfl : ((sourceFragment t t' u ht F).attach + ⟨Sum.inl (⟨k, hk⟩, b), hne⟩).map (Equiv.refl _) id = common).symm + · -- Case 2: k ≥ t' (must be k = t', b = false) + have hk_eq : k = t' := by omega + have hb : b = false := by + by_contra hbt + have hbtrue : b = true := by cases b <;> simp_all + exact hne.1 (by + rw [stageStep_leftBoundary] + exact congrArg Sum.inl (Prod.ext (Fin.ext hk_eq) hbtrue)) + have hflag : (stageStepFlagEquiv t t' u ht F) ⟨Sum.inl (⟨k, hk⟩, b), + hne⟩ = + Sum.inr (F.boundaryFlag ⟨t', by omega⟩) := by + have key : (stageStepFlagEquiv t t' u ht F) ⟨Sum.inl (⟨k, hk⟩, b), + hne⟩ = + if hlt' : k < t' then Sum.inl (⟨k, hlt'⟩, b) + else Sum.inr (F.boundaryFlag ⟨t', by omega⟩) := rfl + rw [key, dite_eq_right hlt] + set common : (targetFragment t t' u (by omega) F).Vertex ⊕ + (Fin (t + t') ⊕ Fin (t' + u)) := Sum.inr (Sum.inl ⟨t', by omega⟩) + have hLHS : (targetFragment t t' u (by omega) F).attach + (Sum.inr (F.boundaryFlag ⟨t', by omega⟩)) = common := by + change (((strandBundle t').disjUnion F).attach + (Sum.inr (F.boundaryFlag ⟨t', by omega⟩))).map id (stageEquiv t t' u + _) = _ + change + ((F.attach (F.boundaryFlag ⟨t', by omega⟩)).map Sum.inr Sum.inr).map + id + (stageEquiv t t' u _) = _ + rw [F.attach_boundaryFlag]; simp only [Sum.map_inr]; refine congrArg + Sum.inr ?_ + rw [stageEquiv_inr t t' u (by omega) ⟨t', by omega⟩, + dite_eq_right (show ¬ (t' : ℕ) < t' from Nat.lt_irrefl t'), + dite_eq_left (show (t' : ℕ) < t from by omega)] + have hRHS : (sourceFragment t t' u ht F).attach + ⟨Sum.inl (⟨k, hk⟩, b), hne⟩ = common := by + change ((Fragment.glueAttach (baseFragment t t' u ht F) + (Sum.inl ⟨t + t', by omega⟩) (Sum.inr ⟨t', by omega⟩) + ⟨Sum.inl (⟨k, hk⟩, b), hne⟩).map id (interfaceStepEquiv t t' u)) = + _ + have hba : (baseFragment t t' u ht F).attach (Sum.inl (⟨k, hk⟩, b)) = + Sum.inr (Sum.inl ⟨t', by omega⟩) := by + change (((strandBundle (t' + 1)).disjUnion F).attach + (Sum.inl (⟨k, hk⟩, b))).map id (stageEquiv t (t' + 1) u ht) = _ + change (((strandBundle (t' + 1)).attach (⟨k, hk⟩, b)).map Sum.inl + Sum.inl).map id + (stageEquiv t (t' + 1) u ht) = _ + simp only [strandBundle, Sum.map, Sum.elim, Function.comp] + refine congrArg Sum.inr ?_ + rw [show (if (b : Bool) = true then + (⟨(t' + 1) + k, by omega⟩ : Fin ((t' + 1) + (t' + 1))) + else ⟨k, by omega⟩) = + (⟨k, by omega⟩ : Fin ((t' + 1) + (t' + 1))) from + by rw [hb]; rfl] + rw [stageEquiv_inl t (t' + 1) u ht ⟨k, by omega⟩, + dite_eq_left (show (k : ℕ) < t' + 1 from by omega)] + exact congrArg Sum.inl (Fin.ext (by omega)) + refine Fragment.glueAttach_cases _ (fun v hv => ?_) + (fun ℓ hℓ => ?_) + · exact absurd (hv.symm.trans hba) (nomatch ·) + · obtain ⟨ℓ, _hs₁, _hs₂⟩ := ℓ + simp only [Sum.map_inr] + have hℓ_eq : ℓ = Sum.inl ⟨t', by omega⟩ := Sum.inr.inj + (hℓ.symm.trans hba) + subst hℓ_eq; refine congrArg Sum.inr ?_ + exact interfaceStepEquiv_eval_inl t t' u t' (by omega) + exact (hflag ▸ hLHS).trans + (by rw [hRHS]; rfl : ((sourceFragment t t' u ht F).attach + ⟨Sum.inl (⟨k, hk⟩, b), hne⟩).map (Equiv.refl _) id = common).symm + +private theorem stageStep_attach_inr (t t' u : ℕ) (ht : t' + 1 ≤ t) + (F : Fragment (Fin (t + u))) + (g : F.Flag) + (hne : (Sum.inr g : (baseFragment t t' u ht F).Flag) ≠ + (baseFragment t t' u ht F).boundaryFlag (Sum.inl ⟨t + t', by omega⟩) ∧ + (Sum.inr g : (baseFragment t t' u ht F).Flag) ≠ + (baseFragment t t' u ht F).boundaryFlag (Sum.inr ⟨t', by omega⟩)) : + (targetFragment t t' u (by omega) F).attach + (stageStepFlagEquiv t t' u ht F ⟨Sum.inr g, hne⟩) = + ((sourceFragment t t' u ht F).attach ⟨Sum.inr g, hne⟩).map (Equiv.refl _) id := by + have hflag : (stageStepFlagEquiv t t' u ht F) ⟨Sum.inr g, hne⟩ = Sum.inr g + := rfl + have hg_ne : g ≠ F.boundaryFlag ⟨t', by omega⟩ := by + intro heq + exact hne.2 + (by rw [stageStep_rightBoundary]; exact congrArg Sum.inr heq) + rcases ha : F.attach g with v | ℓ + · -- F.attach g = Sum.inl v (vertex) + set common : (targetFragment t t' u (by omega) F).Vertex ⊕ + (Fin (t + t') ⊕ Fin (t' + u)) := Sum.inl (Sum.inr v) + have hLHS : (targetFragment t t' u (by omega) F).attach (Sum.inr g) = + common := by + change (((strandBundle t').disjUnion F).attach (Sum.inr g)).map id + (stageEquiv t t' u _) = _ + change ((F.attach g).map Sum.inr Sum.inr).map id (stageEquiv t t' u _) + = _ + rw [ha]; rfl + have hRHS : (sourceFragment t t' u ht F).attach ⟨Sum.inr g, hne⟩ = + common := by + change ((Fragment.glueAttach (baseFragment t t' u ht F) + (Sum.inl ⟨t + t', by omega⟩) (Sum.inr ⟨t', by omega⟩) + ⟨Sum.inr g, hne⟩).map id (interfaceStepEquiv t t' u)) = _ + have hba : (baseFragment t t' u ht F).attach (Sum.inr g) = + Sum.inl (Sum.inr v) := by + change (((strandBundle (t' + 1)).disjUnion F).attach (Sum.inr + g)).map id + (stageEquiv t (t' + 1) u ht) = _ + change ((F.attach g).map Sum.inr Sum.inr).map id (stageEquiv t (t' + + 1) u ht) = _ + rw [ha]; rfl + refine Fragment.glueAttach_cases _ (fun v' hv' => ?_) + (fun ℓ' hℓ' => ?_) + · simp only [Sum.map_inl, id_eq] + exact congrArg Sum.inl (Sum.inl.inj (hv'.symm.trans hba)) + · obtain ⟨ℓ', _hs₁, _hs₂⟩ := ℓ' + exact absurd (hℓ'.symm.trans hba) (nomatch ·) + exact (hflag ▸ hLHS).trans + (by rw [hRHS]; rfl : ((sourceFragment t t' u ht F).attach + ⟨Sum.inr g, hne⟩).map (Equiv.refl _) id = common).symm + · -- F.attach g = Sum.inr ℓ (label) + have hℓ_ne_t' : ℓ.val ≠ t' := by + intro heq + have hatt : F.attach g = Sum.inr ⟨t', by omega⟩ := by + exact ha.trans (congrArg Sum.inr (Fin.ext heq)) + exact hg_ne (F.eq_boundaryFlag ⟨t', by omega⟩ g hatt) + by_cases hℓ_lt_t' : ℓ.val < t' + · -- Case 3b: ℓ.val < t' + set common : (targetFragment t t' u (by omega) F).Vertex ⊕ + (Fin (t + t') ⊕ Fin (t' + u)) := Sum.inr + (Sum.inr ⟨ℓ.val, by omega⟩) + have hLHS : (targetFragment t t' u (by omega) F).attach (Sum.inr g) = + common := by + change (((strandBundle t').disjUnion F).attach (Sum.inr g)).map id + (stageEquiv t t' u _) = _ + change ((F.attach g).map Sum.inr Sum.inr).map id (stageEquiv t t' u + _) = _ + rw [ha]; simp only [Sum.map_inr]; refine congrArg Sum.inr ?_ + rw [stageEquiv_inr t t' u (by omega) ℓ, dite_eq_left hℓ_lt_t'] + have hRHS : (sourceFragment t t' u ht F).attach ⟨Sum.inr g, hne⟩ = + common := by + change ((Fragment.glueAttach (baseFragment t t' u ht F) + (Sum.inl ⟨t + t', by omega⟩) (Sum.inr ⟨t', by omega⟩) + ⟨Sum.inr g, hne⟩).map id (interfaceStepEquiv t t' u)) = _ + have hba : (baseFragment t t' u ht F).attach (Sum.inr g) = + Sum.inr (Sum.inr ⟨ℓ.val, by omega⟩) := by + change (((strandBundle (t' + 1)).disjUnion F).attach (Sum.inr + g)).map id + (stageEquiv t (t' + 1) u ht) = _ + change ((F.attach g).map Sum.inr Sum.inr).map id (stageEquiv t (t' + + 1) u ht) = _ + rw [ha]; simp only [Sum.map_inr]; refine congrArg Sum.inr ?_ + rw [stageEquiv_inr t (t' + 1) u ht ℓ, + dite_eq_left (show ℓ.val < t' + 1 from by omega)] + refine Fragment.glueAttach_cases _ (fun v' hv' => ?_) + (fun ℓ' hℓ' => ?_) + · exact absurd (hv'.symm.trans hba) (nomatch ·) + · obtain ⟨ℓ', _hs₁, _hs₂⟩ := ℓ' + simp only [Sum.map_inr] + have hℓ'_eq : ℓ' = Sum.inr ⟨ℓ.val, by omega⟩ := + Sum.inr.inj (hℓ'.symm.trans hba) + subst hℓ'_eq; refine congrArg Sum.inr ?_ + exact interfaceStepEquiv_eval_inr_below t t' u ℓ.val hℓ_lt_t' + exact (hflag ▸ hLHS).trans + (by rw [hRHS]; rfl : ((sourceFragment t t' u ht F).attach + ⟨Sum.inr g, hne⟩).map (Equiv.refl _) id = common).symm + · by_cases hℓ_lt_t : ℓ.val < t + · -- Case 3c: t' < ℓ.val < t + set common : (targetFragment t t' u (by omega) F).Vertex ⊕ + (Fin (t + t') ⊕ Fin (t' + u)) := Sum.inr + (Sum.inl ⟨ℓ.val, by omega⟩) + have hLHS : (targetFragment t t' u (by omega) F).attach (Sum.inr g) + = + common := by + change (((strandBundle t').disjUnion F).attach (Sum.inr g)).map id + (stageEquiv t t' u _) = _ + change ((F.attach g).map Sum.inr Sum.inr).map id (stageEquiv t t' + u _) = _ + rw [ha]; simp only [Sum.map_inr]; refine congrArg Sum.inr ?_ + rw [stageEquiv_inr t t' u (by omega) ℓ, + dite_eq_right (show ¬ ℓ.val < t' from hℓ_lt_t'), dite_eq_left hℓ_lt_t] + have hRHS : (sourceFragment t t' u ht F).attach ⟨Sum.inr g, hne⟩ = + common := by + change ((Fragment.glueAttach (baseFragment t t' u ht F) + (Sum.inl ⟨t + t', by omega⟩) (Sum.inr ⟨t', by omega⟩) + ⟨Sum.inr g, hne⟩).map id (interfaceStepEquiv t t' u)) = _ + have hba : (baseFragment t t' u ht F).attach (Sum.inr g) = + Sum.inr (Sum.inl ⟨ℓ.val, by omega⟩) := by + change (((strandBundle (t' + 1)).disjUnion F).attach (Sum.inr + g)).map id + (stageEquiv t (t' + 1) u ht) = _ + change ((F.attach g).map Sum.inr Sum.inr).map id + (stageEquiv t (t' + 1) u ht) = _ + rw [ha]; simp only [Sum.map_inr]; refine congrArg Sum.inr ?_ + rw [stageEquiv_inr t (t' + 1) u ht ℓ, + dite_eq_right (show ¬ ℓ.val < t' + 1 from by omega), dite_eq_left + hℓ_lt_t] + refine Fragment.glueAttach_cases _ (fun v' hv' => ?_) + (fun ℓ' hℓ' => ?_) + · exact absurd (hv'.symm.trans hba) (nomatch ·) + · obtain ⟨ℓ', _hs₁, _hs₂⟩ := ℓ' + simp only [Sum.map_inr] + have hℓ'_eq : ℓ' = Sum.inl ⟨ℓ.val, by omega⟩ := + Sum.inr.inj (hℓ'.symm.trans hba) + subst hℓ'_eq; refine congrArg Sum.inr ?_ + exact interfaceStepEquiv_eval_inl t t' u ℓ.val (by omega) + exact (hflag ▸ hLHS).trans (by rw [hRHS]; rfl : + ((sourceFragment t t' u ht F).attach + ⟨Sum.inr g, hne⟩).map (Equiv.refl _) id = common).symm + · -- Case 3d: ℓ.val ≥ t + set common : (targetFragment t t' u (by omega) F).Vertex ⊕ + (Fin (t + t') ⊕ Fin (t' + u)) := + Sum.inr (Sum.inr ⟨t' + (ℓ.val - t), by omega⟩) + have hLHS : (targetFragment t t' u (by omega) F).attach (Sum.inr g) + = + common := by + change (((strandBundle t').disjUnion F).attach (Sum.inr g)).map id + (stageEquiv t t' u _) = _ + change ((F.attach g).map Sum.inr Sum.inr).map id (stageEquiv t t' + u _) = _ + rw [ha]; simp only [Sum.map_inr]; refine congrArg Sum.inr ?_ + rw [stageEquiv_inr t t' u (by omega) ℓ, + dite_eq_right (show ¬ ℓ.val < t' from hℓ_lt_t'), dite_eq_right hℓ_lt_t] + have hRHS : (sourceFragment t t' u ht F).attach ⟨Sum.inr g, hne⟩ = + common := by + change ((Fragment.glueAttach (baseFragment t t' u ht F) + (Sum.inl ⟨t + t', by omega⟩) (Sum.inr ⟨t', by omega⟩) + ⟨Sum.inr g, hne⟩).map id (interfaceStepEquiv t t' u)) = _ + have hba : (baseFragment t t' u ht F).attach (Sum.inr g) = + Sum.inr (Sum.inr ⟨(t' + 1) + (ℓ.val - t), by omega⟩) := by + change (((strandBundle (t' + 1)).disjUnion F).attach (Sum.inr + g)).map id + (stageEquiv t (t' + 1) u ht) = _ + change ((F.attach g).map Sum.inr Sum.inr).map id + (stageEquiv t (t' + 1) u ht) = _ + rw [ha]; simp only [Sum.map_inr]; refine congrArg Sum.inr ?_ + rw [stageEquiv_inr t (t' + 1) u ht ℓ, + dite_eq_right (show ¬ ℓ.val < t' + 1 from by omega), dite_eq_right + hℓ_lt_t] + refine Fragment.glueAttach_cases _ (fun v' hv' => ?_) + (fun ℓ' hℓ' => ?_) + · exact absurd (hv'.symm.trans hba) (nomatch ·) + · obtain ⟨ℓ', _hs₁, _hs₂⟩ := ℓ' + have hℓ'_eq : ℓ' = Sum.inr ⟨(t' + 1) + (ℓ.val - t), by omega⟩ := + Sum.inr.inj (hℓ'.symm.trans hba) + subst hℓ'_eq + simp only [Sum.map_inr] + exact congrArg Sum.inr ((interfaceStepEquiv_eval_inr_above t t' + u + ((t' + 1) + (ℓ.val - t)) (by omega) (by omega)).trans + (congrArg Sum.inr (Fin.ext (by simp)))) + exact hLHS.trans + (by rw [hRHS]; rfl : ((sourceFragment t t' u ht F).attach + ⟨Sum.inr g, hne⟩).map (Equiv.refl _) id = common).symm + +private theorem stageStep_pairing (t t' u : ℕ) (ht : t' + 1 ≤ t) + (F : Fragment (Fin (t + u))) + (f : (sourceFragment t t' u ht F).Flag) : + stageStepFlagEquiv t t' u ht F ((sourceFragment t t' u ht F).pairing f) = + (targetFragment t t' u (by omega) F).pairing (stageStepFlagEquiv t t' u ht F f) := by + obtain ⟨fval, hne⟩ := f + change (stageStepFlagEquiv t t' u ht F) + (Fragment.rewire (stageStep_hopen t t' u ht F) ⟨fval, hne⟩) = + (targetFragment t t' u (by omega) F).pairing + ((stageStepFlagEquiv t t' u ht F) ⟨fval, hne⟩) + rcases fval with ⟨⟨k, hk⟩, b⟩ | g + · -- ═══════ CASE: strand flag (⟨k, hk⟩, b) ═══════ + by_cases hlt : k < t' + · -- Case 1: k < t', rewire "neither" branch + have hni : (baseFragment t t' u ht F).pairing (Sum.inl (⟨k, hk⟩, b)) ≠ + (baseFragment t t' u ht F).boundaryFlag (Sum.inl ⟨t + t', by omega⟩) + := by + change Sum.inl (⟨k, hk⟩, !b) ≠ + (baseFragment t t' u ht F).boundaryFlag (Sum.inl ⟨t + t', by omega⟩) + rw [stageStep_leftBoundary]; intro h + have := congrArg Prod.fst (Sum.inl.inj h) + exact absurd (Fin.ext_iff.mp this) (Nat.ne_of_lt hlt) + have hnj : (baseFragment t t' u ht F).pairing (Sum.inl (⟨k, hk⟩, b)) ≠ + (baseFragment t t' u ht F).boundaryFlag (Sum.inr ⟨t', by omega⟩) := + by + change Sum.inl (⟨k, hk⟩, !b) ≠ + (baseFragment t t' u ht F).boundaryFlag (Sum.inr ⟨t', by omega⟩) + rw [stageStep_rightBoundary]; exact (nomatch ·) + have hrewire_val : (Fragment.rewire (stageStep_hopen t t' u ht F) + ⟨Sum.inl (⟨k, hk⟩, b), hne⟩).val = Sum.inl (⟨k, hk⟩, !b) := by + unfold Fragment.rewire + simp only [show (baseFragment t t' u ht F).pairing (Sum.inl (⟨k, hk⟩, + b)) = + Sum.inl (⟨k, hk⟩, !b) from rfl] + rw [dite_eq_right hni, dite_eq_right hnj] + have heq_rw : Fragment.rewire (stageStep_hopen t t' u ht F) + ⟨Sum.inl (⟨k, hk⟩, b), hne⟩ = ⟨Sum.inl (⟨k, hk⟩, !b), ⟨hni, hnj⟩⟩ := + Subtype.ext hrewire_val + have hflag_rw : (stageStepFlagEquiv t t' u ht F) + (Fragment.rewire (stageStep_hopen t t' u ht F) ⟨Sum.inl (⟨k, hk⟩, + b), hne⟩) = + Sum.inl (⟨k, hlt⟩, !b) := by + rw [heq_rw] + have key : (stageStepFlagEquiv t t' u ht F) ⟨Sum.inl (⟨k, hk⟩, !b), + ⟨hni, hnj⟩⟩ = + if hlt' : k < t' then Sum.inl (⟨k, hlt'⟩, !b) + else Sum.inr (F.boundaryFlag ⟨t', by omega⟩) := rfl + rw [key, dite_eq_left hlt] + have hflag_f : (stageStepFlagEquiv t t' u ht F) ⟨Sum.inl (⟨k, hk⟩, b), + hne⟩ = + Sum.inl (⟨k, hlt⟩, b) := by + have key : (stageStepFlagEquiv t t' u ht F) ⟨Sum.inl (⟨k, hk⟩, b), + hne⟩ = + if hlt' : k < t' then Sum.inl (⟨k, hlt'⟩, b) + else Sum.inr (F.boundaryFlag ⟨t', by omega⟩) := rfl + rw [key, dite_eq_left hlt] + rw [hflag_rw, hflag_f] + rfl + · -- Case 2: k ≥ t' (must be k = t', b = false) + have hk_eq : k = t' := by omega + have hb : b = false := by + by_contra hbt + have hbtrue : b = true := by cases b <;> simp_all + exact hne.1 (by + rw [stageStep_leftBoundary] + exact congrArg Sum.inl (Prod.ext (Fin.ext hk_eq) hbtrue)) + have hpair_eq_bdy : (baseFragment t t' u ht F).pairing (Sum.inl (⟨k, + hk⟩, b)) = + (baseFragment t t' u ht F).boundaryFlag (Sum.inl ⟨t + t', by omega⟩) + := by + change Sum.inl (⟨k, hk⟩, !b) = + (baseFragment t t' u ht F).boundaryFlag (Sum.inl ⟨t + t', by omega⟩) + rw [stageStep_leftBoundary]; subst hk_eq; subst hb; rfl + have hrewire_val : (Fragment.rewire (stageStep_hopen t t' u ht F) + ⟨Sum.inl (⟨k, hk⟩, b), hne⟩).val = + Sum.inr (F.pairing (F.boundaryFlag ⟨t', by omega⟩)) := by + simp only [Fragment.rewire, dite_eq_left hpair_eq_bdy] + rw [stageStep_rightBoundary]; rfl + have hflag_rw : (stageStepFlagEquiv t t' u ht F) + (Fragment.rewire (stageStep_hopen t t' u ht F) ⟨Sum.inl (⟨k, hk⟩, + b), hne⟩) = + Sum.inr (F.pairing (F.boundaryFlag ⟨t', by omega⟩)) := by + have hprop : Sum.inr (F.pairing (F.boundaryFlag ⟨t', by omega⟩)) ≠ + (baseFragment t t' u ht F).boundaryFlag + (Sum.inl ⟨t + t', by omega⟩) ∧ + Sum.inr (F.pairing (F.boundaryFlag ⟨t', by omega⟩)) ≠ + (baseFragment t t' u ht F).boundaryFlag (Sum.inr ⟨t', by omega⟩) + := by + refine ⟨?_, ?_⟩ + · rw [stageStep_leftBoundary]; exact (nomatch ·) + · rw [stageStep_rightBoundary]; intro h + exact F.pairing_ne (F.boundaryFlag ⟨t', by omega⟩) (Sum.inr.inj h) + have heq : Fragment.rewire (stageStep_hopen t t' u ht F) + ⟨Sum.inl (⟨k, hk⟩, b), hne⟩ = + ⟨Sum.inr (F.pairing (F.boundaryFlag ⟨t', by omega⟩)), hprop⟩ := + Subtype.ext hrewire_val + rw [heq]; rfl + have hflag_f : (stageStepFlagEquiv t t' u ht F) ⟨Sum.inl (⟨k, hk⟩, b), + hne⟩ = + Sum.inr (F.boundaryFlag ⟨t', by omega⟩) := by + have key : (stageStepFlagEquiv t t' u ht F) ⟨Sum.inl (⟨k, hk⟩, b), + hne⟩ = + if hlt' : k < t' then Sum.inl (⟨k, hlt'⟩, b) + else Sum.inr (F.boundaryFlag ⟨t', by omega⟩) := rfl + rw [key, dite_eq_right hlt] + rw [hflag_rw, hflag_f] + rfl + · -- ═══════ CASE: F-flag g ═══════ + have hg_ne : g ≠ F.boundaryFlag ⟨t', by omega⟩ := by + intro heq + exact hne.2 + (by rw [stageStep_rightBoundary]; exact congrArg Sum.inr heq) + have hni : (baseFragment t t' u ht F).pairing (Sum.inr g) ≠ + (baseFragment t t' u ht F).boundaryFlag (Sum.inl ⟨t + t', by omega⟩) + := by + intro h; rw [stageStep_leftBoundary] at h; exact nomatch h + have hflag_f : (stageStepFlagEquiv t t' u ht F) ⟨Sum.inr g, hne⟩ = Sum.inr + g := rfl + by_cases hpg : F.pairing g = F.boundaryFlag ⟨t', by omega⟩ + · -- Sub-case: F.pairing g = F.boundaryFlag ⟨t', _⟩ + have hnj : (baseFragment t t' u ht F).pairing (Sum.inr g) = + (baseFragment t t' u ht F).boundaryFlag (Sum.inr ⟨t', by omega⟩) := + by + rw [show (baseFragment t t' u ht F).pairing (Sum.inr g) = + Sum.inr (F.pairing g) from rfl, stageStep_rightBoundary, hpg] + have hrewire_val : (Fragment.rewire (stageStep_hopen t t' u ht F) + ⟨Sum.inr g, hne⟩).val = Sum.inl (⟨t', by omega⟩, false) := by + unfold Fragment.rewire + rw [dite_eq_right hni, dite_eq_left hnj] + change (baseFragment t t' u ht F).pairing + ((baseFragment t t' u ht F).boundaryFlag + (Sum.inl ⟨t + t', by omega⟩)) = _ + rw [stageStep_leftBoundary] + exact stageStep_leftPairing t t' u ht F + have hne_rw : Sum.inl (⟨t', by omega⟩, false) ≠ + (baseFragment t t' u ht F).boundaryFlag (Sum.inl ⟨t + t', by omega⟩) + ∧ + Sum.inl (⟨t', by omega⟩, false) ≠ + (baseFragment t t' u ht F).boundaryFlag (Sum.inr ⟨t', by omega⟩) := + by + refine ⟨?_, ?_⟩ + · rw [stageStep_leftBoundary]; intro h + exact absurd (congrArg Prod.snd (Sum.inl.inj h)) Bool.false_ne_true + · rw [stageStep_rightBoundary]; exact (nomatch ·) + have heq_rw : Fragment.rewire (stageStep_hopen t t' u ht F) + ⟨Sum.inr g, hne⟩ = ⟨Sum.inl (⟨t', by omega⟩, false), hne_rw⟩ := + Subtype.ext hrewire_val + have hflag_rw : (stageStepFlagEquiv t t' u ht F) + (Fragment.rewire (stageStep_hopen t t' u ht F) ⟨Sum.inr g, hne⟩) = + Sum.inr (F.boundaryFlag ⟨t', by omega⟩) := by + rw [heq_rw] + have key : (stageStepFlagEquiv t t' u ht F) + ⟨Sum.inl (⟨t', by omega⟩, false), hne_rw⟩ = + if hlt' : t' < t' then Sum.inl (⟨t', hlt'⟩, false) + else Sum.inr (F.boundaryFlag ⟨t', by omega⟩) := rfl + rw [key, dite_eq_right (Nat.lt_irrefl t')] + rw [hflag_rw, hflag_f] + change Sum.inr (F.boundaryFlag ⟨t', _⟩) = Sum.inr (F.pairing g) + exact congrArg Sum.inr hpg.symm + · -- Sub-case: F.pairing g ≠ F.boundaryFlag ⟨t', _⟩ + have hnj : (baseFragment t t' u ht F).pairing (Sum.inr g) ≠ + (baseFragment t t' u ht F).boundaryFlag (Sum.inr ⟨t', by omega⟩) := + by + intro h; rw [stageStep_rightBoundary] at h; exact hpg (Sum.inr.inj h) + have hrewire_val : (Fragment.rewire (stageStep_hopen t t' u ht F) + ⟨Sum.inr g, hne⟩).val = Sum.inr (F.pairing g) := by + unfold Fragment.rewire + simp only [show (baseFragment t t' u ht F).pairing (Sum.inr g) = + Sum.inr (F.pairing g) from rfl] + rw [dite_eq_right hni, dite_eq_right hnj] + have heq_rw : Fragment.rewire (stageStep_hopen t t' u ht F) + ⟨Sum.inr g, hne⟩ = ⟨Sum.inr (F.pairing g), ⟨hni, hnj⟩⟩ := + Subtype.ext hrewire_val + have hflag_rw : (stageStepFlagEquiv t t' u ht F) + (Fragment.rewire (stageStep_hopen t t' u ht F) ⟨Sum.inr g, hne⟩) = + Sum.inr (F.pairing g) := by + rw [heq_rw]; rfl + rw [hflag_rw, hflag_f] + rfl + +/-! ### Assembly: the left identity law -/ + +/-- The descent step: after one open glue (at the `t'`-th interface +pair), the resulting fragment is equivalent to the stage-`t'` +disjoint union relabelled by the stage-`t'` equivalence. -/ +noncomputable def stageStepEquiv (t t' u : ℕ) (ht : t' + 1 ≤ t) + (F : Fragment (Fin (t + u))) : + (sourceFragment t t' u ht F).Equiv (targetFragment t t' u (by omega) F) + where + flagEquiv := stageStepFlagEquiv t t' u ht F + vertexEquiv := Equiv.refl _ + circles_eq := rfl + attach_comm := fun f => by + obtain ⟨fval, hne⟩ := f + rcases fval with ⟨⟨k, hk⟩, b⟩ | g + · exact stageStep_attach_inl t t' u ht F k hk b hne + · exact stageStep_attach_inr t t' u ht F g hne + pairing_comm := by exact stageStep_pairing t t' u ht F + +/-- The stage equivalence at `t' = t` acts as the identity: every +element is mapped to itself. -/ +theorem stageEquiv_self (t u : ℕ) (x : Fin (t + t) ⊕ Fin (t + u)) : + stageEquiv t t u (le_refl t) x = x := by + rcases x with a | ℓ + · rw [stageEquiv_inl] + split + · next h => exact congrArg Sum.inl (Fin.ext rfl) + · next h => + have ha_ge : t ≤ a.val := Nat.not_lt.mp h + exact congrArg Sum.inl + (Fin.ext (show t + (a.val - t) = a.val from by omega)) + · rw [stageEquiv_inr] + split + · next h => exact congrArg Sum.inr (Fin.ext rfl) + · next h₁ => + exact congrArg Sum.inr + (Fin.ext (show t + (ℓ.val - t) = ℓ.val from by omega)) + +/-- Relabelling by a pointwise-identity equivalence yields an +equivalent fragment. -/ +def Fragment.Equiv.relabelPointwiseId (W : Fragment α) (e : α ≃ α) + (h : ∀ x, e x = x) : + (W.relabel e).Equiv W where + flagEquiv := _root_.Equiv.refl _ + vertexEquiv := _root_.Equiv.refl _ + attach_comm := fun f => by + change W.attach f = ((W.attach f).map id e).map (_root_.Equiv.refl _) id + rcases W.attach f with v | ℓ + · simp + · simp [h ℓ] + pairing_comm := fun _ => rfl + circles_eq := rfl + +/-- In the base fragment, the glue is always open, so `gluePair` +coincides with `gluePairOpen`. -/ +theorem baseFragment_gluePair_eq (t t' u : ℕ) (ht : t' + 1 ≤ t) + (F : Fragment (Fin (t + u))) : + (baseFragment t t' u ht F).gluePair (Sum.inl ⟨t + t', by omega⟩) + (Sum.inr ⟨t', by omega⟩) (by simp) = + (baseFragment t t' u ht F).gluePairOpen (Sum.inl ⟨t + t', by omega⟩) + (Sum.inr ⟨t', by omega⟩) (by simp) (by exact stageStep_hopen t t' u ht F) := by + unfold Fragment.gluePair + exact dite_eq_right (stageStep_hopen t t' u ht F) + +/-- Descending induction: iterating `glueInterface` from stage `t'` +down to zero, with the stage-`t'` fragment, yields a result +equivalent to iterating from stage `t` on the original strand/F +union. -/ +noncomputable def glueInterfaceStrandBundleDescent + (t u : ℕ) (F : Fragment (Fin (t + u))) : + ∀ (t' : ℕ) (ht' : t' ≤ t), + (glueInterface t t u ((strandBundle t).disjUnion F)).Equiv + (glueInterface t t' u (((strandBundle t').disjUnion F).relabel + (stageEquiv t t' u ht'))) + | t', ht' => by + by_cases htop : t' = t + · -- Base: t' = t, the stageEquiv is pointwise identity + cases htop + exact glueInterfaceCongr _ _ u + ((Fragment.Equiv.relabelPointwiseId _ _ + (stageEquiv_self _ u)).symm) + · -- Step: t' < t, use stageStepEquiv to descend one level + have ht'_lt : t' + 1 ≤ t := by omega + have ih := glueInterfaceStrandBundleDescent t u F (t' + 1) ht'_lt + -- The IH gives equivalence to glueInterface at stage t' + 1. + -- Unfolding glueInterface at t'+1 applies one gluePair + relabel. + -- stageStepEquiv shows the result is equivalent to stage t'. + have step : ((baseFragment t t' u ht'_lt F).gluePair + (Sum.inl ⟨t + t', by omega⟩) (Sum.inr ⟨t', by omega⟩) + (by simp)).relabel (interfaceStepEquiv t t' u) = + sourceFragment t t' u ht'_lt F := by + unfold sourceFragment + rw [← baseFragment_gluePair_eq] + exact ih.trans (glueInterfaceCongr t t' u + (step ▸ (stageStepEquiv t t' u ht'_lt F))) +termination_by t' _ => t - t' +decreasing_by omega + +/-- The left identity law for fragment composition: composing with +the strand bundle on the left yields an equivalent fragment. -/ +noncomputable def composeStrandBundleLeft (t u : ℕ) + (F : Fragment (Fin (t + u))) : + ((strandBundle t).compose F).Equiv F := + (Fragment.Equiv.relabelCongr + (glueInterfaceStrandBundleDescent t u F 0 (Nat.zero_le t)) + finSumFinEquiv).trans + (stageZeroEquiv t u F) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLawRight.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLawRight.lean new file mode 100644 index 0000000000..d3b1b1bfcc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLawRight.lean @@ -0,0 +1,889 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLaw + +/-! +# The right identity law: stage equivalences + +Mirror of `RS.Novel.Skein.IdentityLaw` (the left identity law). Composing +with a strand bundle on the right is the identity up to fragment +equivalence. The proof runs by descending induction through +`glueInterface` with the invariant that the stage-`t'` fragment is +equivalent to `F.disjUnion (strandBundle t')` relabelled along a +stage equivalence relocating the not-yet-glued interface labels and +the strand labels into the two output blocks. + +The transformation: where the left law places the strand bundle in +the left factor (its outgoing ends glued to F's leading interface +labels), the right law places F in the left factor and the strand +bundle in the right (interface pairs `(Sum.inl (s + k), Sum.inr k)` +hit F's trailing labels and the bundle's incoming labels; the +bundle's outgoing labels survive and become the output's trailing +labels). + +The stage equivalence maps `Fin (s + u) ⊕ Fin (t' + t')` to +`Fin (s + t') ⊕ Fin (t' + u)`. Block decomposition: + D = Fin s (F's leading/outer labels) + C = Fin t' (F's not-yet-glued trailing interface labels) + B = Fin (u - t') (F's already-glued trailing labels) + A = Fin t' (strand-bundle incoming ends) + A' = Fin t' (strand-bundle outgoing ends) +The shuffle: `((D ⊕ C) ⊕ B) ⊕ (A ⊕ A') ≃ (D ⊕ C) ⊕ ((A ⊕ A') ⊕ B)`. +-/ + +@[expose] public section + +namespace RS + +/-- The stage relabelling for the right identity law. On the left +output, F's outer labels and the not-yet-glued interface labels; on +the right output, the strand-bundle labels followed by F's +already-glued trailing labels. -/ +def stageEquivR (s t' u : ℕ) (ht : t' ≤ u) : + Fin (s + u) ⊕ Fin (t' + t') ≃ Fin (s + t') ⊕ Fin (t' + u) where + toFun x := match x with + | Sum.inl ℓ => + if h : ℓ.val < s + t' then Sum.inl ⟨ℓ.val, h⟩ + else Sum.inr ⟨t' + (ℓ.val - s), by omega⟩ + | Sum.inr a => Sum.inr ⟨a.val, by omega⟩ + invFun y := match y with + | Sum.inl j => Sum.inl ⟨j.val, by omega⟩ + | Sum.inr k => + if h : k.val < t' + t' then Sum.inr ⟨k.val, h⟩ + else Sum.inl ⟨s + (k.val - t'), by omega⟩ + left_inv x := by + rcases x with ℓ | a + · -- Sum.inl ℓ + simp only + by_cases h : ℓ.val < s + t' + · rw [dite_eq_left h] + · simp only + [dite_eq_right h, dite_eq_right (show ¬ (t' + (ℓ.val - s) < t' + t') from by omega)] + exact congrArg Sum.inl (Fin.ext (by simp; omega)) + · -- Sum.inr a + simp only + rw [dite_eq_left a.isLt] + right_inv y := by + rcases y with j | k + · -- Sum.inl j + simp only + rw [dite_eq_left j.isLt] + · -- Sum.inr k + simp only + by_cases h : k.val < t' + t' + · rw [dite_eq_left h] + · simp only + [dite_eq_right h, dite_eq_right (show ¬ (s + (k.val - t') < s + t') from by omega)] + exact congrArg Sum.inr (Fin.ext (by simp; omega)) + +/-! ### Label evaluations -/ + +/-- Evaluation of the right stage equivalence on a left label (F's +labels): a label below `s + t'` stays left; a label at or above +`s + t'` relocates to the right block. -/ +theorem stageEquivR_inl (s t' u : ℕ) (ht : t' ≤ u) (ℓ : Fin (s + u)) : + stageEquivR s t' u ht (Sum.inl ℓ) = + if h : ℓ.val < s + t' then Sum.inl ⟨ℓ.val, h⟩ + else Sum.inr ⟨t' + (ℓ.val - s), by omega⟩ := rfl + +/-- Evaluation of the right stage equivalence on a right label +(strand-bundle labels): it maps to the right output block at the +same index. -/ +theorem stageEquivR_inr (s t' u : ℕ) (ht : t' ≤ u) (a : Fin (t' + t')) : + stageEquivR s t' u ht (Sum.inr a) = + Sum.inr ⟨a.val, by omega⟩ := rfl + +/-! ### The base case -/ + +/-- Evaluation of the stage-zero right equivalence on a left label: +a leading label stays left; a trailing label relocates to the right +block. -/ +theorem stageEquivR_zero_inl (s u : ℕ) (ℓ : Fin (s + u)) : + stageEquivR s 0 u (Nat.zero_le u) (Sum.inl ℓ) = + if h : ℓ.val < s then Sum.inl ⟨ℓ.val, by omega⟩ + else Sum.inr ⟨ℓ.val - s, by omega⟩ := by + rw [stageEquivR_inl] + by_cases h : ℓ.val < s + · rw [dite_eq_left (show ℓ.val < s + 0 from by omega), dite_eq_left h] + · rw [dite_eq_right (show ¬ ℓ.val < s + 0 from by omega), dite_eq_right h] + exact congrArg Sum.inr (Fin.ext (by simp)) + +/-- The base case of the right identity law: after zero interface +gluings, the triply-relabelled F/(strand-0) union is equivalent to +F. -/ +noncomputable def stageZeroEquivR (s u : ℕ) (F : Fragment (Fin (s + u))) : + ((glueInterface s 0 u ((F.disjUnion (strandBundle 0)).relabel + (stageEquivR s 0 u (Nat.zero_le u)))).relabel finSumFinEquiv).Equiv F + where + flagEquiv := Equiv.sumEmpty _ _ + vertexEquiv := Equiv.sumEmpty _ _ + attach_comm f := by + rcases f with g | ⟨⟨k, hk⟩, _⟩ + · -- inl g (F-flag) + change F.attach ((Equiv.sumEmpty _ _) (Sum.inl g)) = + (((glueInterface s 0 u ((F.disjUnion (strandBundle 0)).relabel + (stageEquivR s 0 u (Nat.zero_le u)))).relabel finSumFinEquiv).attach + (Sum.inl g)).map (Equiv.sumEmpty _ _) id + simp only [Equiv.sumEmpty_apply_inl] + change F.attach g = + (((((F.attach g).map Sum.inl Sum.inl).map id + (stageEquivR s 0 u (Nat.zero_le u))).map id + (Equiv.sumCongr (finCongr (by omega : s + 0 = s)) + (finCongr (by omega : 0 + u = u)))).map id finSumFinEquiv).map + (Equiv.sumEmpty _ _) id + rcases ha : F.attach g with v | ℓ + · simp + · simp only [Sum.map_inr] + congr 1 + rw [stageEquivR_zero_inl] + split + · rename_i h + simp [finSumFinEquiv_apply_left] + · rename_i h + simp [finSumFinEquiv_apply_right, Fin.ext_iff] + omega + · -- inr (strand-0 flag) — impossible + exact absurd hk (Nat.not_lt_zero k) + pairing_comm f := by + rcases f with g | x + · rfl + · exact (IsEmpty.false x).elim + circles_eq := rfl + +/-! ### The descent step -/ + +/-- The boundary flag at the left interface label in the relabelled +disjoint union: it is F's boundary flag at `s + t'`. -/ +theorem stageStepR_leftBoundary (s t' u : ℕ) (ht : t' + 1 ≤ u) + (F : Fragment (Fin (s + u))) : + ((F.disjUnion (strandBundle (t' + 1))).relabel + (stageEquivR s (t' + 1) u ht)).boundaryFlag + (Sum.inl ⟨s + t', by omega⟩) = + Sum.inl (F.boundaryFlag ⟨s + t', by omega⟩) := by + change (F.disjUnion (strandBundle (t' + 1))).boundaryFlag + ((stageEquivR s (t' + 1) u ht).symm (Sum.inl ⟨s + t', by omega⟩)) = + Sum.inl (F.boundaryFlag ⟨s + t', by omega⟩) + have hsymm : (stageEquivR s (t' + 1) u ht).symm (Sum.inl ⟨s + t', by omega⟩) = + Sum.inl ⟨s + t', by omega⟩ := by + rw [Equiv.symm_apply_eq, stageEquivR_inl] + rw [dite_eq_left (show (s + t' : ℕ) < s + (t' + 1) from by omega)] + rw [hsymm] + rfl + +/-- The boundary flag at the right interface label in the relabelled +disjoint union: it is the incoming end of strand `t'`. -/ +theorem stageStepR_rightBoundary (s t' u : ℕ) (ht : t' + 1 ≤ u) + (F : Fragment (Fin (s + u))) : + ((F.disjUnion (strandBundle (t' + 1))).relabel + (stageEquivR s (t' + 1) u ht)).boundaryFlag + (Sum.inr ⟨t', by omega⟩) = + Sum.inr (⟨t', by omega⟩, false) := by + change (F.disjUnion (strandBundle (t' + 1))).boundaryFlag + ((stageEquivR s (t' + 1) u ht).symm (Sum.inr ⟨t', by omega⟩)) = + Sum.inr (⟨t', by omega⟩, false) + have hsymm : (stageEquivR s (t' + 1) u ht).symm (Sum.inr ⟨t', by omega⟩) = + Sum.inr ⟨t', by omega⟩ := by + rw [Equiv.symm_apply_eq, stageEquivR_inr] + rw [hsymm] + exact congrArg Sum.inr (strandBundle_boundaryFlag_low (t' + 1) ⟨t', by omega⟩ + (Nat.lt_add_one t')) + +/-- The glue in the descent step is always the open case. -/ +theorem stageStepR_hopen (s t' u : ℕ) (ht : t' + 1 ≤ u) + (F : Fragment (Fin (s + u))) : + ((F.disjUnion (strandBundle (t' + 1))).relabel + (stageEquivR s (t' + 1) u ht)).pairing + (((F.disjUnion (strandBundle (t' + 1))).relabel + (stageEquivR s (t' + 1) u ht)).boundaryFlag + (Sum.inl ⟨s + t', by omega⟩)) ≠ + ((F.disjUnion (strandBundle (t' + 1))).relabel + (stageEquivR s (t' + 1) u ht)).boundaryFlag + (Sum.inr ⟨t', by omega⟩) := by + rw [stageStepR_leftBoundary, stageStepR_rightBoundary] + exact (nomatch ·) + +/-- The pairing partner of the right boundary flag in the relabelled +fragment: it is `(t', true)`, the outgoing end of strand `t'`. -/ +theorem stageStepR_rightPairing (s t' u : ℕ) (ht : t' + 1 ≤ u) + (F : Fragment (Fin (s + u))) : + ((F.disjUnion (strandBundle (t' + 1))).relabel + (stageEquivR s (t' + 1) u ht)).pairing + (Sum.inr (⟨t', by omega⟩, false)) = + Sum.inr (⟨t', by omega⟩, true) := rfl + +/-- The flag equivalence for the descent step: surviving flags of the +open glue at stage `t' + 1` correspond to flags of the stage-`t'` +disjoint union `F.disjUnion (strandBundle t')`. -/ +noncomputable def stageStepFlagEquivR (s t' u : ℕ) (ht : t' + 1 ≤ u) + (F : Fragment (Fin (s + u))) : + Fragment.SurvivingFlag + ((F.disjUnion (strandBundle (t' + 1))).relabel (stageEquivR s (t' + 1) u + ht)) + (Sum.inl ⟨s + t', by omega⟩) (Sum.inr ⟨t', by omega⟩) ≃ + F.Flag ⊕ (Fin t' × Bool) where + toFun x := + match x.val with + | Sum.inl g => Sum.inl g + | Sum.inr (⟨k, _⟩, b) => + if hlt : k < t' then Sum.inr (⟨k, hlt⟩, b) + else Sum.inl (F.boundaryFlag ⟨s + t', by omega⟩) + invFun y := + match y with + | Sum.inl g => + if hg : g = F.boundaryFlag ⟨s + t', by omega⟩ then + ⟨Sum.inr (⟨t', by omega⟩, true), by + refine ⟨fun h => ?_, fun h => ?_⟩ + · rw [stageStepR_leftBoundary] at h; simp at h + · rw [stageStepR_rightBoundary] at h + have hbeq : (true : Bool) = false := + congrArg Prod.snd (Sum.inr.inj h) + exact absurd hbeq (Ne.symm Bool.false_ne_true)⟩ + else + ⟨Sum.inl g, by + refine ⟨fun h => ?_, fun h => ?_⟩ + · rw [stageStepR_leftBoundary] at h + exact hg (Sum.inl.inj h) + · rw [stageStepR_rightBoundary] at h; simp at h⟩ + | Sum.inr (⟨k, hk⟩, b) => + ⟨Sum.inr (⟨k, by omega⟩, b), by + refine ⟨fun h => ?_, fun h => ?_⟩ + · rw [stageStepR_leftBoundary] at h; simp at h + · rw [stageStepR_rightBoundary] at h + have hkeq : k = t' := congrArg Fin.val + (congrArg Prod.fst (Sum.inr.inj h)) + omega⟩ + left_inv x := by + obtain ⟨f, hne⟩ := x + rcases f with g | ⟨⟨k, hk⟩, b⟩ + · -- f = Sum.inl g + dsimp only + have hg : g ≠ F.boundaryFlag ⟨s + t', by omega⟩ := by + intro heq + exact hne.1 (by + rw [stageStepR_leftBoundary] + exact congrArg Sum.inl heq) + simp only [dite_eq_right hg] + · -- f = Sum.inr (⟨k, hk⟩, b) + by_cases hlt : k < t' + · simp only [dite_eq_left hlt] + · have hk_eq : k = t' := by omega + have hb : b = true := by + by_contra hbf + have hbfalse : b = false := by cases b <;> simp_all + exact hne.2 (by + rw [stageStepR_rightBoundary] + exact hk_eq ▸ hbfalse ▸ congrArg Sum.inr (Prod.ext (Fin.ext rfl) + rfl)) + simp only [dite_eq_right hlt, dite_true] + exact Subtype.ext (hk_eq ▸ hb ▸ congrArg Sum.inr (Prod.ext (Fin.ext rfl) + rfl)) + right_inv y := by + match y with + | Sum.inl g => + dsimp only + by_cases hg : g = F.boundaryFlag ⟨s + t', by omega⟩ + · simp only [dite_eq_left hg, dite_eq_right (show ¬ (t' : ℕ) < t' from Nat.lt_irrefl + t')] + exact congrArg Sum.inl hg.symm + · simp only [dite_eq_right hg] + | Sum.inr (⟨k, hk⟩, b) => + simp only [dite_eq_left hk] + +/-! ### The stage step equivalence -/ + +/-- The relabelled fragment-strand union before the next right identity glue. -/ +abbrev baseFragmentR (s t' u : ℕ) (ht : t' + 1 ≤ u) + (F : Fragment (Fin (s + u))) := + (F.disjUnion (strandBundle (t' + 1))).relabel (stageEquivR s (t' + 1) u ht) + +/-- The relabelled fragment-strand union at the target stage of right identity descent. -/ +abbrev targetFragmentR (s t' u : ℕ) (ht' : t' ≤ u) + (F : Fragment (Fin (s + u))) := + (F.disjUnion (strandBundle t')).relabel (stageEquivR s t' u ht') + +/-- The source fragment obtained by one open glue in the right identity descent. -/ +noncomputable abbrev sourceFragmentR (s t' u : ℕ) (ht : t' + 1 ≤ u) + (F : Fragment (Fin (s + u))) := + ((baseFragmentR s t' u ht F).gluePairOpen + (Sum.inl ⟨s + t', by omega⟩) (Sum.inr ⟨t', by omega⟩) + (by simp) (by exact stageStepR_hopen s t' u ht F)).relabel (interfaceStepEquiv s t' + u) + +private theorem stageStepR_attach_inl (s t' u : ℕ) (ht : t' + 1 ≤ u) + (F : Fragment (Fin (s + u))) + (g : F.Flag) + (hne : (Sum.inl g : (baseFragmentR s t' u ht F).Flag) ≠ + (baseFragmentR s t' u ht F).boundaryFlag (Sum.inl ⟨s + t', by omega⟩) ∧ + (Sum.inl g : (baseFragmentR s t' u ht F).Flag) ≠ + (baseFragmentR s t' u ht F).boundaryFlag (Sum.inr ⟨t', by omega⟩)) : + (targetFragmentR s t' u (by omega) F).attach + (stageStepFlagEquivR s t' u ht F ⟨Sum.inl g, hne⟩) = + ((sourceFragmentR s t' u ht F).attach ⟨Sum.inl g, hne⟩).map (Equiv.refl _) id := by + have hg_ne : g ≠ F.boundaryFlag ⟨s + t', by omega⟩ := by + intro heq + exact hne.1 + (by rw [stageStepR_leftBoundary]; exact congrArg Sum.inl heq) + have hflag : (stageStepFlagEquivR s t' u ht F) ⟨Sum.inl g, hne⟩ = Sum.inl + g := rfl + rcases ha : F.attach g with v | ℓ + · -- F.attach g = Sum.inl v (vertex) + set common : (targetFragmentR s t' u (by omega) F).Vertex ⊕ + (Fin (s + t') ⊕ Fin (t' + u)) := Sum.inl (Sum.inl v) + have hLHS : (targetFragmentR s t' u (by omega) F).attach (Sum.inl g) = + common := by + change ((F.disjUnion (strandBundle t')).attach (Sum.inl g)).map id + (stageEquivR s t' u _) = _ + change ((F.attach g).map Sum.inl Sum.inl).map id (stageEquivR s t' u + _) = _ + rw [ha]; rfl + have hRHS : (sourceFragmentR s t' u ht F).attach ⟨Sum.inl g, hne⟩ = + common := by + change ((Fragment.glueAttach (baseFragmentR s t' u ht F) + (Sum.inl ⟨s + t', by omega⟩) (Sum.inr ⟨t', by omega⟩) + ⟨Sum.inl g, hne⟩).map id (interfaceStepEquiv s t' u)) = _ + have hba : (baseFragmentR s t' u ht F).attach (Sum.inl g) = + Sum.inl (Sum.inl v) := by + change ((F.disjUnion (strandBundle (t' + 1))).attach (Sum.inl + g)).map id + (stageEquivR s (t' + 1) u ht) = _ + change ((F.attach g).map Sum.inl Sum.inl).map id (stageEquivR s (t' + + 1) u ht) = _ + rw [ha]; rfl + refine Fragment.glueAttach_cases _ (fun v' hv' => ?_) + (fun ℓ' hℓ' => ?_) + · simp only [Sum.map_inl, id_eq] + exact congrArg Sum.inl (Sum.inl.inj (hv'.symm.trans hba)) + · obtain ⟨ℓ', _hs₁, _hs₂⟩ := ℓ' + exact absurd (hℓ'.symm.trans hba) (nomatch ·) + exact (hflag ▸ hLHS).trans + (by rw [hRHS]; rfl : ((sourceFragmentR s t' u ht F).attach + ⟨Sum.inl g, hne⟩).map (Equiv.refl _) id = common).symm + · -- F.attach g = Sum.inr ℓ (label) + have hℓ_ne_st' : ℓ.val ≠ s + t' := by + intro heq + have hatt : F.attach g = Sum.inr ⟨s + t', by omega⟩ := by + exact ha.trans (congrArg Sum.inr (Fin.ext heq)) + exact hg_ne (F.eq_boundaryFlag ⟨s + t', by omega⟩ g hatt) + by_cases hℓ_lt : ℓ.val < s + t' + · -- ℓ.val < s + t' + set common : (targetFragmentR s t' u (by omega) F).Vertex ⊕ + (Fin (s + t') ⊕ Fin (t' + u)) := Sum.inr + (Sum.inl ⟨ℓ.val, by omega⟩) + have hLHS : (targetFragmentR s t' u (by omega) F).attach (Sum.inl g) = + common := by + change ((F.disjUnion (strandBundle t')).attach (Sum.inl g)).map id + (stageEquivR s t' u _) = _ + change ((F.attach g).map Sum.inl Sum.inl).map id (stageEquivR s t' u + _) = _ + rw [ha]; simp only [Sum.map_inr]; refine congrArg Sum.inr ?_ + rw [stageEquivR_inl, dite_eq_left hℓ_lt] + have hRHS : (sourceFragmentR s t' u ht F).attach ⟨Sum.inl g, hne⟩ = + common := by + change ((Fragment.glueAttach (baseFragmentR s t' u ht F) + (Sum.inl ⟨s + t', by omega⟩) (Sum.inr ⟨t', by omega⟩) + ⟨Sum.inl g, hne⟩).map id (interfaceStepEquiv s t' u)) = _ + have hba : (baseFragmentR s t' u ht F).attach (Sum.inl g) = + Sum.inr (Sum.inl ⟨ℓ.val, by omega⟩) := by + change ((F.disjUnion (strandBundle (t' + 1))).attach (Sum.inl + g)).map id + (stageEquivR s (t' + 1) u ht) = _ + change ((F.attach g).map Sum.inl Sum.inl).map id + (stageEquivR s (t' + 1) u ht) = _ + rw [ha]; simp only [Sum.map_inr]; refine congrArg Sum.inr ?_ + rw [stageEquivR_inl, + dite_eq_left (show ℓ.val < s + (t' + 1) from by omega)] + refine Fragment.glueAttach_cases _ (fun v' hv' => ?_) + (fun ℓ' hℓ' => ?_) + · exact absurd (hv'.symm.trans hba) (nomatch ·) + · obtain ⟨ℓ', _hs₁, _hs₂⟩ := ℓ' + simp only [Sum.map_inr] + have hℓ'_eq : ℓ' = Sum.inl ⟨ℓ.val, by omega⟩ := + Sum.inr.inj (hℓ'.symm.trans hba) + subst hℓ'_eq; refine congrArg Sum.inr ?_ + exact interfaceStepEquiv_eval_inl s t' u ℓ.val (by omega) + exact (hflag ▸ hLHS).trans + (by rw [hRHS]; rfl : ((sourceFragmentR s t' u ht F).attach + ⟨Sum.inl g, hne⟩).map (Equiv.refl _) id = common).symm + · -- ℓ.val > s + t' + have hℓ_gt : s + t' < ℓ.val := by omega + set common : (targetFragmentR s t' u (by omega) F).Vertex ⊕ + (Fin (s + t') ⊕ Fin (t' + u)) := + Sum.inr (Sum.inr ⟨t' + (ℓ.val - s), by omega⟩) + have hLHS : (targetFragmentR s t' u (by omega) F).attach (Sum.inl g) = + common := by + change ((F.disjUnion (strandBundle t')).attach (Sum.inl g)).map id + (stageEquivR s t' u _) = _ + change ((F.attach g).map Sum.inl Sum.inl).map id (stageEquivR s t' u + _) = _ + rw [ha]; simp only [Sum.map_inr]; refine congrArg Sum.inr ?_ + rw [stageEquivR_inl, dite_eq_right (show ¬ ℓ.val < s + t' from by omega)] + have hRHS : (sourceFragmentR s t' u ht F).attach ⟨Sum.inl g, hne⟩ = + common := by + change ((Fragment.glueAttach (baseFragmentR s t' u ht F) + (Sum.inl ⟨s + t', by omega⟩) (Sum.inr ⟨t', by omega⟩) + ⟨Sum.inl g, hne⟩).map id (interfaceStepEquiv s t' u)) = _ + have hba : (baseFragmentR s t' u ht F).attach (Sum.inl g) = + Sum.inr (Sum.inr ⟨(t' + 1) + (ℓ.val - s), by omega⟩) := by + change ((F.disjUnion (strandBundle (t' + 1))).attach (Sum.inl + g)).map id + (stageEquivR s (t' + 1) u ht) = _ + change ((F.attach g).map Sum.inl Sum.inl).map id + (stageEquivR s (t' + 1) u ht) = _ + rw [ha]; simp only [Sum.map_inr]; refine congrArg Sum.inr ?_ + rw [stageEquivR_inl, + dite_eq_right (show ¬ ℓ.val < s + (t' + 1) from by omega)] + refine Fragment.glueAttach_cases _ (fun v' hv' => ?_) + (fun ℓ' hℓ' => ?_) + · exact absurd (hv'.symm.trans hba) (nomatch ·) + · obtain ⟨ℓ', _hs₁, _hs₂⟩ := ℓ' + have hℓ'_eq : ℓ' = Sum.inr ⟨(t' + 1) + (ℓ.val - s), by omega⟩ := + Sum.inr.inj (hℓ'.symm.trans hba) + subst hℓ'_eq + simp only [Sum.map_inr] + exact congrArg Sum.inr ((interfaceStepEquiv_eval_inr_above s t' u + ((t' + 1) + (ℓ.val - s)) (by omega) (by omega)).trans + (congrArg Sum.inr (Fin.ext (by simp)))) + exact (hflag ▸ hLHS).trans + (by rw [hRHS]; rfl : ((sourceFragmentR s t' u ht F).attach + ⟨Sum.inl g, hne⟩).map (Equiv.refl _) id = common).symm + +private theorem stageStepR_attach_inr (s t' u : ℕ) (ht : t' + 1 ≤ u) + (F : Fragment (Fin (s + u))) + (k : ℕ) (hk : k < t' + 1) (b : Bool) + (hne : (Sum.inr (⟨k, hk⟩, b) : (baseFragmentR s t' u ht F).Flag) ≠ + (baseFragmentR s t' u ht F).boundaryFlag (Sum.inl ⟨s + t', by omega⟩) ∧ + (Sum.inr (⟨k, hk⟩, b) : (baseFragmentR s t' u ht F).Flag) ≠ + (baseFragmentR s t' u ht F).boundaryFlag (Sum.inr ⟨t', by omega⟩)) : + (targetFragmentR s t' u (by omega) F).attach + (stageStepFlagEquivR s t' u ht F ⟨Sum.inr (⟨k, hk⟩, b), hne⟩) = + ((sourceFragmentR s t' u ht F).attach ⟨Sum.inr (⟨k, hk⟩, b), hne⟩).map (Equiv.refl _) id := by + by_cases hlt : k < t' + · -- Sub-case: k < t' + have hflag : (stageStepFlagEquivR s t' u ht F) + ⟨Sum.inr (⟨k, hk⟩, b), hne⟩ = Sum.inr (⟨k, hlt⟩, b) := by + have key : (stageStepFlagEquivR s t' u ht F) + ⟨Sum.inr (⟨k, hk⟩, b), hne⟩ = + if hlt' : k < t' then Sum.inr (⟨k, hlt'⟩, b) + else Sum.inl (F.boundaryFlag ⟨s + t', by omega⟩) := rfl + rw [key, dite_eq_left hlt] + set common : (targetFragmentR s t' u (by omega) F).Vertex ⊕ + (Fin (s + t') ⊕ Fin (t' + u)) := + Sum.inr (Sum.inr ⟨if b then t' + k else k, by split <;> omega⟩) + have hLHS : (targetFragmentR s t' u (by omega) F).attach + (Sum.inr (⟨k, hlt⟩, b)) = common := by + change ((F.disjUnion (strandBundle t')).attach + (Sum.inr (⟨k, hlt⟩, b))).map id (stageEquivR s t' u _) = _ + change (((strandBundle t').attach (⟨k, hlt⟩, b)).map Sum.inr + Sum.inr).map id + (stageEquivR s t' u _) = _ + simp only [strandBundle, Sum.map, Sum.elim, Function.comp] + apply congrArg Sum.inr; cases b + · simp only [ite_false, Bool.false_eq_true] + rw [stageEquivR_inr] + · simp only [ite_true] + rw [stageEquivR_inr] + have hRHS : (sourceFragmentR s t' u ht F).attach + ⟨Sum.inr (⟨k, hk⟩, b), hne⟩ = common := by + change ((Fragment.glueAttach (baseFragmentR s t' u ht F) + (Sum.inl ⟨s + t', by omega⟩) (Sum.inr ⟨t', by omega⟩) + ⟨Sum.inr (⟨k, hk⟩, b), hne⟩).map id (interfaceStepEquiv s t' u)) = + _ + have hba : (baseFragmentR s t' u ht F).attach (Sum.inr (⟨k, hk⟩, b)) = + Sum.inr + (Sum.inr ⟨if b then (t' + 1) + k else k, by split <;> omega⟩) := + by + change ((F.disjUnion (strandBundle (t' + 1))).attach + (Sum.inr (⟨k, hk⟩, b))).map id (stageEquivR s (t' + 1) u ht) = _ + change (((strandBundle (t' + 1)).attach (⟨k, hk⟩, b)).map + Sum.inr Sum.inr).map id (stageEquivR s (t' + 1) u ht) = _ + simp only [strandBundle, Sum.map, Sum.elim, Function.comp] + apply congrArg Sum.inr; cases b + · simp only [ite_false, Bool.false_eq_true] + rw [stageEquivR_inr] + · simp only [ite_true] + rw [stageEquivR_inr] + refine Fragment.glueAttach_cases _ (fun v' hv' => ?_) + (fun ℓ' hℓ' => ?_) + · exact absurd (hv'.symm.trans hba) (nomatch ·) + · obtain ⟨ℓ', _hs₁, _hs₂⟩ := ℓ' + simp only [Sum.map_inr] + have hℓ'_eq : ℓ' = Sum.inr ⟨if b then (t' + 1) + k else k, + by split <;> omega⟩ := + Sum.inr.inj (hℓ'.symm.trans hba) + subst hℓ'_eq; refine congrArg Sum.inr ?_ + cases b + · exact interfaceStepEquiv_eval_inr_below s t' u k hlt + · exact (interfaceStepEquiv_eval_inr_above s t' u + ((t' + 1) + k) (by omega) (by omega)).trans + (congrArg Sum.inr (Fin.ext (by simp only [ite_true]; omega))) + exact (hflag ▸ hLHS).trans + (by rw [hRHS]; rfl : ((sourceFragmentR s t' u ht F).attach + ⟨Sum.inr (⟨k, hk⟩, b), hne⟩).map (Equiv.refl _) id = common).symm + · -- Sub-case: k ≥ t' (must be k = t', b = true) + have hk_eq : k = t' := by omega + have hb : b = true := by + by_contra hbf + have hbfalse : b = false := by cases b <;> simp_all + exact hne.2 (by + rw [stageStepR_rightBoundary] + exact hk_eq ▸ hbfalse ▸ congrArg Sum.inr (Prod.ext (Fin.ext rfl) + rfl)) + have hflag : (stageStepFlagEquivR s t' u ht F) + ⟨Sum.inr (⟨k, hk⟩, b), hne⟩ = + Sum.inl (F.boundaryFlag ⟨s + t', by omega⟩) := by + have key : (stageStepFlagEquivR s t' u ht F) + ⟨Sum.inr (⟨k, hk⟩, b), hne⟩ = + if hlt' : k < t' then Sum.inr (⟨k, hlt'⟩, b) + else Sum.inl (F.boundaryFlag ⟨s + t', by omega⟩) := rfl + rw [key, dite_eq_right hlt] + set common : (targetFragmentR s t' u (by omega) F).Vertex ⊕ + (Fin (s + t') ⊕ Fin (t' + u)) := Sum.inr + (Sum.inr ⟨t' + t', by omega⟩) + have hLHS : (targetFragmentR s t' u (by omega) F).attach + (Sum.inl (F.boundaryFlag ⟨s + t', by omega⟩)) = common := by + change ((F.disjUnion (strandBundle t')).attach + (Sum.inl (F.boundaryFlag ⟨s + t', by omega⟩))).map id + (stageEquivR s t' u _) = _ + change ((F.attach (F.boundaryFlag ⟨s + t', by omega⟩)).map + Sum.inl Sum.inl).map id (stageEquivR s t' u _) = _ + rw [F.attach_boundaryFlag]; simp only [Sum.map_inr]; refine congrArg + Sum.inr ?_ + rw [stageEquivR_inl, + dite_eq_right (show ¬ (s + t' : ℕ) < s + t' from by omega)] + exact congrArg Sum.inr (Fin.ext (by simp)) + have hRHS : (sourceFragmentR s t' u ht F).attach + ⟨Sum.inr (⟨k, hk⟩, b), hne⟩ = common := by + change ((Fragment.glueAttach (baseFragmentR s t' u ht F) + (Sum.inl ⟨s + t', by omega⟩) (Sum.inr ⟨t', by omega⟩) + ⟨Sum.inr (⟨k, hk⟩, b), hne⟩).map id (interfaceStepEquiv s t' u)) = + _ + have hba : (baseFragmentR s t' u ht F).attach (Sum.inr (⟨k, hk⟩, b)) = + Sum.inr (Sum.inr ⟨(t' + 1) + t', by omega⟩) := by + change ((F.disjUnion (strandBundle (t' + 1))).attach + (Sum.inr (⟨k, hk⟩, b))).map id (stageEquivR s (t' + 1) u ht) = _ + change (((strandBundle (t' + 1)).attach (⟨k, hk⟩, b)).map + Sum.inr Sum.inr).map id (stageEquivR s (t' + 1) u ht) = _ + simp only [strandBundle, Sum.map, Sum.elim, Function.comp] + refine congrArg Sum.inr ?_ + rw [show (if (b : Bool) = true then + (⟨(t' + 1) + k, by omega⟩ : Fin ((t' + 1) + (t' + 1))) + else ⟨k, by omega⟩) = + (⟨(t' + 1) + k, by omega⟩ : Fin ((t' + 1) + (t' + 1))) from + by rw [hb]; rfl] + rw [stageEquivR_inr] + exact congrArg Sum.inr (Fin.ext (by simp; omega)) + refine Fragment.glueAttach_cases _ (fun v' hv' => ?_) + (fun ℓ' hℓ' => ?_) + · exact absurd (hv'.symm.trans hba) (nomatch ·) + · obtain ⟨ℓ', _hs₁, _hs₂⟩ := ℓ' + simp only [Sum.map_inr] + have hℓ'_eq : ℓ' = Sum.inr ⟨(t' + 1) + t', by omega⟩ := + Sum.inr.inj (hℓ'.symm.trans hba) + subst hℓ'_eq; refine congrArg Sum.inr ?_ + exact (interfaceStepEquiv_eval_inr_above s t' u + ((t' + 1) + t') (by omega) (by omega)).trans + (congrArg Sum.inr (Fin.ext (by simp))) + exact (hflag ▸ hLHS).trans + (by rw [hRHS]; rfl : ((sourceFragmentR s t' u ht F).attach + ⟨Sum.inr (⟨k, hk⟩, b), hne⟩).map (Equiv.refl _) id = common).symm + +private theorem stageStepR_pairing_inl (s t' u : ℕ) (ht : t' + 1 ≤ u) + (F : Fragment (Fin (s + u))) + (g : F.Flag) + (hne : (Sum.inl g : (baseFragmentR s t' u ht F).Flag) ≠ + (baseFragmentR s t' u ht F).boundaryFlag (Sum.inl ⟨s + t', by omega⟩) ∧ + (Sum.inl g : (baseFragmentR s t' u ht F).Flag) ≠ + (baseFragmentR s t' u ht F).boundaryFlag (Sum.inr ⟨t', by omega⟩)) : + stageStepFlagEquivR s t' u ht F + (Fragment.rewire (stageStepR_hopen s t' u ht F) ⟨Sum.inl g, hne⟩) = + (targetFragmentR s t' u (by omega) F).pairing + (stageStepFlagEquivR s t' u ht F ⟨Sum.inl g, hne⟩) := by + have hg_ne : g ≠ F.boundaryFlag ⟨s + t', by omega⟩ := by + intro heq + exact hne.1 + (by rw [stageStepR_leftBoundary]; exact congrArg Sum.inl heq) + have hnj : (baseFragmentR s t' u ht F).pairing (Sum.inl g) ≠ + (baseFragmentR s t' u ht F).boundaryFlag (Sum.inr ⟨t', by omega⟩) := + by + change Sum.inl (F.pairing g) ≠ + (baseFragmentR s t' u ht F).boundaryFlag (Sum.inr ⟨t', by omega⟩) + rw [stageStepR_rightBoundary]; exact (nomatch ·) + have hflag_f : (stageStepFlagEquivR s t' u ht F) ⟨Sum.inl g, hne⟩ = + Sum.inl g := rfl + by_cases hpg : F.pairing g = F.boundaryFlag ⟨s + t', by omega⟩ + · -- Sub-case: F.pairing g = F.boundaryFlag ⟨s + t', _⟩ + -- rewire branch 1: pairing(g) = boundaryFlag(left) + have hpi : (baseFragmentR s t' u ht F).pairing (Sum.inl g) = + (baseFragmentR s t' u ht F).boundaryFlag + (Sum.inl ⟨s + t', by omega⟩) := by + change Sum.inl (F.pairing g) = _ + rw [stageStepR_leftBoundary, hpg] + have hrewire_val : (Fragment.rewire (stageStepR_hopen s t' u ht F) + ⟨Sum.inl g, hne⟩).val = + Sum.inr (⟨t', by omega⟩, true) := by + simp only [Fragment.rewire, dite_eq_left hpi] + change (baseFragmentR s t' u ht F).pairing + ((baseFragmentR s t' u ht F).boundaryFlag (Sum.inr ⟨t', by omega⟩)) + = _ + rw [stageStepR_rightBoundary] + exact stageStepR_rightPairing s t' u ht F + have hne_rw : Sum.inr (⟨t', by omega⟩, true) ≠ + (baseFragmentR s t' u ht F).boundaryFlag + (Sum.inl ⟨s + t', by omega⟩) ∧ + Sum.inr (⟨t', by omega⟩, true) ≠ + (baseFragmentR s t' u ht F).boundaryFlag (Sum.inr ⟨t', by omega⟩) := + by + refine ⟨?_, ?_⟩ + · rw [stageStepR_leftBoundary]; exact (nomatch ·) + · rw [stageStepR_rightBoundary]; intro h + exact absurd (congrArg Prod.snd (Sum.inr.inj h)) (Ne.symm + Bool.false_ne_true) + have heq_rw : Fragment.rewire (stageStepR_hopen s t' u ht F) + ⟨Sum.inl g, hne⟩ = ⟨Sum.inr (⟨t', by omega⟩, true), hne_rw⟩ := + Subtype.ext hrewire_val + have hflag_rw : (stageStepFlagEquivR s t' u ht F) + (Fragment.rewire (stageStepR_hopen s t' u ht F) ⟨Sum.inl g, hne⟩) = + Sum.inl (F.boundaryFlag ⟨s + t', by omega⟩) := by + rw [heq_rw] + have key : (stageStepFlagEquivR s t' u ht F) + ⟨Sum.inr (⟨t', by omega⟩, true), hne_rw⟩ = + if hlt' : t' < t' then Sum.inr (⟨t', hlt'⟩, true) + else Sum.inl (F.boundaryFlag ⟨s + t', by omega⟩) := rfl + rw [key, dite_eq_right (Nat.lt_irrefl t')] + rw [hflag_rw, hflag_f] + change Sum.inl (F.boundaryFlag ⟨s + t', _⟩) = Sum.inl (F.pairing g) + exact congrArg Sum.inl hpg.symm + · -- Sub-case: F.pairing g ≠ F.boundaryFlag ⟨s + t', _⟩ + -- rewire branch 3: neither + have hni : (baseFragmentR s t' u ht F).pairing (Sum.inl g) ≠ + (baseFragmentR s t' u ht F).boundaryFlag + (Sum.inl ⟨s + t', by omega⟩) := by + change Sum.inl (F.pairing g) ≠ _ + rw [stageStepR_leftBoundary] + exact fun h => hpg (Sum.inl.inj h) + have hrewire_val : (Fragment.rewire (stageStepR_hopen s t' u ht F) + ⟨Sum.inl g, hne⟩).val = Sum.inl (F.pairing g) := by + unfold Fragment.rewire + simp only [show (baseFragmentR s t' u ht F).pairing (Sum.inl g) = + Sum.inl (F.pairing g) from rfl] + rw [dite_eq_right hni, dite_eq_right hnj] + have heq_rw : Fragment.rewire (stageStepR_hopen s t' u ht F) + ⟨Sum.inl g, hne⟩ = ⟨Sum.inl (F.pairing g), ⟨hni, hnj⟩⟩ := + Subtype.ext hrewire_val + have hflag_rw : (stageStepFlagEquivR s t' u ht F) + (Fragment.rewire (stageStepR_hopen s t' u ht F) ⟨Sum.inl g, hne⟩) = + Sum.inl (F.pairing g) := by + rw [heq_rw]; rfl + rw [hflag_rw, hflag_f] + rfl + +private theorem stageStepR_pairing_inr (s t' u : ℕ) (ht : t' + 1 ≤ u) + (F : Fragment (Fin (s + u))) + (k : ℕ) (hk : k < t' + 1) (b : Bool) + (hne : (Sum.inr (⟨k, hk⟩, b) : (baseFragmentR s t' u ht F).Flag) ≠ + (baseFragmentR s t' u ht F).boundaryFlag (Sum.inl ⟨s + t', by omega⟩) ∧ + (Sum.inr (⟨k, hk⟩, b) : (baseFragmentR s t' u ht F).Flag) ≠ + (baseFragmentR s t' u ht F).boundaryFlag (Sum.inr ⟨t', by omega⟩)) : + stageStepFlagEquivR s t' u ht F + (Fragment.rewire (stageStepR_hopen s t' u ht F) ⟨Sum.inr (⟨k, hk⟩, b), hne⟩) = + (targetFragmentR s t' u (by omega) F).pairing + (stageStepFlagEquivR s t' u ht F ⟨Sum.inr (⟨k, hk⟩, b), hne⟩) := by + by_cases hlt : k < t' + · -- Sub-case: k < t', rewire "neither" branch + have hni : (baseFragmentR s t' u ht F).pairing (Sum.inr (⟨k, hk⟩, b)) ≠ + (baseFragmentR s t' u ht F).boundaryFlag + (Sum.inl ⟨s + t', by omega⟩) := by + change Sum.inr (⟨k, hk⟩, !b) ≠ + (baseFragmentR s t' u ht F).boundaryFlag + (Sum.inl ⟨s + t', by omega⟩) + rw [stageStepR_leftBoundary]; exact (nomatch ·) + have hnj : (baseFragmentR s t' u ht F).pairing (Sum.inr (⟨k, hk⟩, b)) ≠ + (baseFragmentR s t' u ht F).boundaryFlag (Sum.inr ⟨t', by omega⟩) := + by + change Sum.inr (⟨k, hk⟩, !b) ≠ + (baseFragmentR s t' u ht F).boundaryFlag (Sum.inr ⟨t', by omega⟩) + rw [stageStepR_rightBoundary]; intro h + have := congrArg Prod.fst (Sum.inr.inj h) + exact absurd (Fin.ext_iff.mp this) (Nat.ne_of_lt hlt) + have hrewire_val : (Fragment.rewire (stageStepR_hopen s t' u ht F) + ⟨Sum.inr (⟨k, hk⟩, b), hne⟩).val = Sum.inr (⟨k, hk⟩, !b) := by + unfold Fragment.rewire + simp only [show (baseFragmentR s t' u ht F).pairing (Sum.inr (⟨k, hk⟩, + b)) = + Sum.inr (⟨k, hk⟩, !b) from rfl] + rw [dite_eq_right hni, dite_eq_right hnj] + have heq_rw : Fragment.rewire (stageStepR_hopen s t' u ht F) + ⟨Sum.inr (⟨k, hk⟩, b), hne⟩ = ⟨Sum.inr (⟨k, hk⟩, !b), ⟨hni, hnj⟩⟩ := + Subtype.ext hrewire_val + have hflag_rw : (stageStepFlagEquivR s t' u ht F) + (Fragment.rewire (stageStepR_hopen s t' u ht F) + ⟨Sum.inr (⟨k, hk⟩, b), hne⟩) = + Sum.inr (⟨k, hlt⟩, !b) := by + rw [heq_rw] + have key : (stageStepFlagEquivR s t' u ht F) + ⟨Sum.inr (⟨k, hk⟩, !b), ⟨hni, hnj⟩⟩ = + if hlt' : k < t' then Sum.inr (⟨k, hlt'⟩, !b) + else Sum.inl (F.boundaryFlag ⟨s + t', by omega⟩) := rfl + rw [key, dite_eq_left hlt] + have hflag_f : (stageStepFlagEquivR s t' u ht F) ⟨Sum.inr (⟨k, hk⟩, b), + hne⟩ = + Sum.inr (⟨k, hlt⟩, b) := by + have key : (stageStepFlagEquivR s t' u ht F) + ⟨Sum.inr (⟨k, hk⟩, b), hne⟩ = + if hlt' : k < t' then Sum.inr (⟨k, hlt'⟩, b) + else Sum.inl (F.boundaryFlag ⟨s + t', by omega⟩) := rfl + rw [key, dite_eq_left hlt] + rw [hflag_rw, hflag_f] + rfl + · -- Sub-case: k = t', b = true + have hk_eq : k = t' := by omega + have hb : b = true := by + by_contra hbf + have hbfalse : b = false := by cases b <;> simp_all + exact hne.2 (by + rw [stageStepR_rightBoundary] + exact hk_eq ▸ hbfalse ▸ congrArg Sum.inr (Prod.ext (Fin.ext rfl) + rfl)) + -- rewire branch 2: pairing(strand t' true) = (t', false) = + -- boundaryFlag(right) + have hpair_eq_bdy : (baseFragmentR s t' u ht F).pairing (Sum.inr (⟨k, + hk⟩, b)) = + (baseFragmentR s t' u ht F).boundaryFlag (Sum.inr ⟨t', by omega⟩) := + by + change Sum.inr (⟨k, hk⟩, !b) = + (baseFragmentR s t' u ht F).boundaryFlag (Sum.inr ⟨t', by omega⟩) + rw [stageStepR_rightBoundary]; subst hk_eq; subst hb; rfl + have hni : (baseFragmentR s t' u ht F).pairing (Sum.inr (⟨k, hk⟩, b)) ≠ + (baseFragmentR s t' u ht F).boundaryFlag + (Sum.inl ⟨s + t', by omega⟩) := by + change Sum.inr (⟨k, hk⟩, !b) ≠ + (baseFragmentR s t' u ht F).boundaryFlag + (Sum.inl ⟨s + t', by omega⟩) + rw [stageStepR_leftBoundary]; exact (nomatch ·) + have hrewire_val : (Fragment.rewire (stageStepR_hopen s t' u ht F) + ⟨Sum.inr (⟨k, hk⟩, b), hne⟩).val = + Sum.inl (F.pairing (F.boundaryFlag ⟨s + t', by omega⟩)) := by + simp only [Fragment.rewire, dite_eq_right hni, dite_eq_left hpair_eq_bdy] + change (baseFragmentR s t' u ht F).pairing + ((baseFragmentR s t' u ht F).boundaryFlag + (Sum.inl ⟨s + t', by omega⟩)) = _ + rw [stageStepR_leftBoundary]; rfl + have hprop : Sum.inl (F.pairing (F.boundaryFlag ⟨s + t', by omega⟩)) ≠ + (baseFragmentR s t' u ht F).boundaryFlag + (Sum.inl ⟨s + t', by omega⟩) ∧ + Sum.inl (F.pairing (F.boundaryFlag ⟨s + t', by omega⟩)) ≠ + (baseFragmentR s t' u ht F).boundaryFlag (Sum.inr ⟨t', by omega⟩) := + by + refine ⟨?_, ?_⟩ + · rw [stageStepR_leftBoundary]; intro h + exact F.pairing_ne (F.boundaryFlag ⟨s + t', by omega⟩) + (Sum.inl.inj h) + · rw [stageStepR_rightBoundary]; exact (nomatch ·) + have heq_rw : Fragment.rewire (stageStepR_hopen s t' u ht F) + ⟨Sum.inr (⟨k, hk⟩, b), hne⟩ = + ⟨Sum.inl (F.pairing (F.boundaryFlag ⟨s + t', by omega⟩)), hprop⟩ := + Subtype.ext hrewire_val + have hflag_rw : (stageStepFlagEquivR s t' u ht F) + (Fragment.rewire (stageStepR_hopen s t' u ht F) + ⟨Sum.inr (⟨k, hk⟩, b), hne⟩) = + Sum.inl (F.pairing (F.boundaryFlag ⟨s + t', by omega⟩)) := by + rw [heq_rw]; rfl + have hflag_f : (stageStepFlagEquivR s t' u ht F) ⟨Sum.inr (⟨k, hk⟩, b), + hne⟩ = + Sum.inl (F.boundaryFlag ⟨s + t', by omega⟩) := by + have key : (stageStepFlagEquivR s t' u ht F) + ⟨Sum.inr (⟨k, hk⟩, b), hne⟩ = + if hlt' : k < t' then Sum.inr (⟨k, hlt'⟩, b) + else Sum.inl (F.boundaryFlag ⟨s + t', by omega⟩) := rfl + rw [key, dite_eq_right hlt] + rw [hflag_rw, hflag_f] + rfl + +/-- The descent step: after one open glue (at the `t'`-th interface +pair), the resulting fragment is equivalent to the stage-`t'` +disjoint union relabelled by the stage-`t'` equivalence. -/ +noncomputable def stageStepEquivR (s t' u : ℕ) (ht : t' + 1 ≤ u) + (F : Fragment (Fin (s + u))) : + (sourceFragmentR s t' u ht F).Equiv (targetFragmentR s t' u (by omega) F) + where + flagEquiv := stageStepFlagEquivR s t' u ht F + vertexEquiv := Equiv.refl _ + circles_eq := rfl + attach_comm f := by + obtain ⟨fval, hne⟩ := f + rcases fval with g | ⟨⟨k, hk⟩, b⟩ + · exact stageStepR_attach_inl s t' u ht F g hne + · exact stageStepR_attach_inr s t' u ht F k hk b hne + pairing_comm f := by + obtain ⟨fval, hne⟩ := f + rcases fval with g | ⟨⟨k, hk⟩, b⟩ + · exact stageStepR_pairing_inl s t' u ht F g hne + · exact stageStepR_pairing_inr s t' u ht F k hk b hne + +/-! ### Assembly: the right identity law -/ + +/-- The stage equivalence at `t' = u` acts as the identity: every +element is mapped to itself. -/ +theorem stageEquivR_self (s u : ℕ) (x : Fin (s + u) ⊕ Fin (u + u)) : + stageEquivR s u u (le_refl u) x = x := by + rcases x with ℓ | a + · rw [stageEquivR_inl, dite_eq_left ℓ.isLt] + · rw [stageEquivR_inr] + +/-- In the base fragment, the glue is always open, so `gluePair` +coincides with `gluePairOpen`. -/ +theorem baseFragmentR_gluePair_eq (s t' u : ℕ) (ht : t' + 1 ≤ u) + (F : Fragment (Fin (s + u))) : + (baseFragmentR s t' u ht F).gluePair (Sum.inl ⟨s + t', by omega⟩) + (Sum.inr ⟨t', by omega⟩) (by simp) = + (baseFragmentR s t' u ht F).gluePairOpen (Sum.inl ⟨s + t', by omega⟩) + (Sum.inr ⟨t', by omega⟩) (by simp) (by exact stageStepR_hopen s t' u ht F) := by + unfold Fragment.gluePair + exact dite_eq_right (stageStepR_hopen s t' u ht F) + +/-- Descending induction: iterating `glueInterface` from stage `t'` +down to zero, with the stage-`t'` fragment, yields a result +equivalent to iterating from stage `u` on the original F/strand +union. -/ +noncomputable def glueInterfaceStrandBundleDescentRight + (s u : ℕ) (F : Fragment (Fin (s + u))) : + ∀ (t' : ℕ) (ht' : t' ≤ u), + (glueInterface s u u (F.disjUnion (strandBundle u))).Equiv + (glueInterface s t' u ((F.disjUnion (strandBundle t')).relabel + (stageEquivR s t' u ht'))) + | t', ht' => by + by_cases htop : t' = u + · cases htop + exact glueInterfaceCongr _ _ u + ((Fragment.Equiv.relabelPointwiseId _ _ + (stageEquivR_self _ u)).symm) + · have ht'_lt : t' + 1 ≤ u := by omega + have ih := glueInterfaceStrandBundleDescentRight s u F (t' + 1) ht'_lt + have step : ((baseFragmentR s t' u ht'_lt F).gluePair + (Sum.inl ⟨s + t', by omega⟩) (Sum.inr ⟨t', by omega⟩) + (by simp)).relabel (interfaceStepEquiv s t' u) = + sourceFragmentR s t' u ht'_lt F := by + unfold sourceFragmentR + rw [← baseFragmentR_gluePair_eq] + exact ih.trans (glueInterfaceCongr s t' u + (step ▸ (stageStepEquivR s t' u ht'_lt F))) +termination_by t' _ => u - t' +decreasing_by omega + +/-- **The right identity law for fragment composition**: composing +with the strand bundle on the right yields an equivalent fragment. -/ +noncomputable def composeStrandBundleRight (s u : ℕ) + (F : Fragment (Fin (s + u))) : + (F.compose (strandBundle u)).Equiv F := + (Fragment.Equiv.relabelCongr + (glueInterfaceStrandBundleDescentRight s u F 0 (Nat.zero_le u)) + finSumFinEquiv).trans + (stageZeroEquivR s u F) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceAlternate.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceAlternate.lean new file mode 100644 index 0000000000..17b01a8240 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceAlternate.lean @@ -0,0 +1,1152 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedTopSum + +/-! +# The interface alternates + +RS21's step 1 puts the two fragments' arc directions in Eulerian +position: at every used interface label one side's arc comes in and +the other's goes out. For data the composition itself provides that +is automatic — the glued chain passes through the interface, so the +glued orientation makes one end incoming and the other outgoing, and +ungluing keeps both values. + +The statement below is that fact at one cut: where both entry edges +are internal — that is, where the label is a chain label on both +sides — the unglued orientation's chain directions at the two glued +labels are opposite. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + +open Fragment +section OpenCut + +variable {L : Type} + +/-- The glued fragment pairs the two glued flags' partners. -/ +theorem gluePairOpen_partnerSurvI {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) : + (V.gluePairOpen i j hij hopen).pairing (partnerSurvI hopen) + = partnerSurvJ hopen := + gluePairOpen_pairing_interface_i hij hopen (partnerSurvI hopen) + (by rw [partnerSurvI_val hopen, V.pairing_invol]) + +/-- **The interface alternates.** At a label whose entry edges are +internal on both sides, the unglued orientation's chain directions +are opposite. -/ +theorem chainDir_unglueOpen_alternates + {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + (hct : ∀ f ∈ t, (V.gluePairOpen i j hij hopen).pairing f ∈ t) + (hcL : ∀ f ∈ liftSubsetOpen hopen t, V.pairing f ∈ liftSubsetOpen hopen + t) + (κ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).RelTransitionSystem) + (o' : κ'.Orientation) + (hI : (partnerSurvI hopen).val + ∈ (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).internalFlags) + (hJ : (partnerSurvJ hopen).val + ∈ (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).internalFlags) : + chainDir (unglueOrientationOpen hij hopen t hct hcL κ' o') + (V.boundaryFlag j) + = !chainDir (unglueOrientationOpen hij hopen t hct hcL κ' o') + (V.boundaryFlag i) := by + have hIg : partnerSurvI hopen ∈ (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).internalFlags := + internal_mk_of_glueOpen hij hopen t hct hcL hI + (partnerSurvI hopen).prop.1 (partnerSurvI hopen).prop.2 + have hJg : (V.gluePairOpen i j hij hopen).pairing + (partnerSurvI hopen) ∈ (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).internalFlags := by + rw [gluePairOpen_partnerSurvI hij hopen] + exact internal_mk_of_glueOpen hij hopen t hct hcL hJ + (partnerSurvJ hopen).prop.1 + (partnerSurvJ hopen).prop.2 + have hflip := o'.pairing_flip (partnerSurvI hopen) hIg hJg + rw [gluePairOpen_partnerSurvI hij hopen] at hflip + change unglueIsOut o'.isOut (V.pairing (V.boundaryFlag j)) + = !unglueIsOut o'.isOut (V.pairing (V.boundaryFlag i)) + rw [show V.pairing (V.boundaryFlag j) + = (partnerSurvJ hopen).val from rfl, + show V.pairing (V.boundaryFlag i) + = (partnerSurvI hopen).val from rfl, + unglueIsOut_val o'.isOut (partnerSurvJ hopen), + unglueIsOut_val o'.isOut (partnerSurvI hopen)] + exact hflip + +/-- An internal flag is not a glued boundary flag. -/ +theorem internal_ne_boundaryFlag {V : Fragment L} {i : L} {j : L} + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + (hcL : ∀ f ∈ liftSubsetOpen hopen t, V.pairing f ∈ liftSubsetOpen hopen + t) + {f : V.Flag} {b : L} + (hint : f ∈ (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).internalFlags) : + f ≠ V.boundaryFlag b := by + obtain ⟨-, v, hv⟩ := EdgeSubset.mem_internalFlags_iff.mp hint + intro hx + rw [hx, V.attach_boundaryFlag] at hv + exact absurd hv (by simp) + +/-- **The chain direction survives the glue.** At a surviving label +whose entry edge is internal, the unglued orientation reads what the +glued one does. -/ +theorem chainDir_unglueOpen_surviving + {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + (hct : ∀ f ∈ t, (V.gluePairOpen i j hij hopen).pairing f ∈ t) + (hcL : ∀ f ∈ liftSubsetOpen hopen t, V.pairing f ∈ liftSubsetOpen hopen + t) + (κ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).RelTransitionSystem) + (o' : κ'.Orientation) (b : SurvivingLabel L i j) + (hint : V.pairing (V.boundaryFlag b.val) + ∈ (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).internalFlags) : + chainDir (unglueOrientationOpen hij hopen t hct hcL κ' o') + (V.boundaryFlag b.val) + = chainDir o' + ((V.gluePairOpen i j hij hopen).boundaryFlag b) := by + have hne1 : V.pairing (V.boundaryFlag b.val) ≠ V.boundaryFlag i := + internal_ne_boundaryFlag hopen t hcL hint + have hne2 : V.pairing (V.boundaryFlag b.val) ≠ V.boundaryFlag j := + internal_ne_boundaryFlag hopen t hcL hint + have hval : ((V.gluePairOpen i j hij hopen).pairing + (glueBoundaryFlag V i j b)).val + = V.pairing (V.boundaryFlag b.val) := + gluePairOpen_pairing_val_of_ne hij hopen + (glueBoundaryFlag V i j b) hne1 hne2 + change unglueIsOut o'.isOut (V.pairing (V.boundaryFlag b.val)) + = o'.isOut ((V.gluePairOpen i j hij hopen).pairing + (glueBoundaryFlag V i j b)) + rw [show V.pairing (V.boundaryFlag b.val) + = ((V.gluePairOpen i j hij hopen).pairing + (glueBoundaryFlag V i j b)).val from hval.symm, + unglueIsOut_val o'.isOut ((V.gluePairOpen i j hij hopen).pairing + (glueBoundaryFlag V i j b))] + +/-- **The alternation passes down an open glue.** At a pair of +surviving labels whose entry edges are internal, the base inherits +the glued fragment's alternation. -/ +theorem chainDir_alternates_unglueOpen + {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + (hct : ∀ f ∈ t, (V.gluePairOpen i j hij hopen).pairing f ∈ t) + (hcL : ∀ f ∈ liftSubsetOpen hopen t, V.pairing f ∈ liftSubsetOpen hopen + t) + (κ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).RelTransitionSystem) + (o' : κ'.Orientation) (bl br : SurvivingLabel L i j) + (hIl : V.pairing (V.boundaryFlag bl.val) + ∈ (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).internalFlags) + (hIr : V.pairing (V.boundaryFlag br.val) + ∈ (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V).internalFlags) + (halt : chainDir o' + ((V.gluePairOpen i j hij hopen).boundaryFlag br) + = !chainDir o' + ((V.gluePairOpen i j hij hopen).boundaryFlag bl)) : + chainDir (unglueOrientationOpen hij hopen t hct hcL κ' o') + (V.boundaryFlag br.val) + = !chainDir (unglueOrientationOpen hij hopen t hct hcL κ' o') + (V.boundaryFlag bl.val) := by + rw [chainDir_unglueOpen_surviving hij hopen t hct hcL κ' o' br hIr, + chainDir_unglueOpen_surviving hij hopen t hct hcL κ' o' bl hIl] + exact halt + +/-! ## Across a through-edge into the cut + +Where the entry edge at a surviving label is the cut's own flag — +that is, where the label is joined to the cut by a single edge — the +glue absorbs that edge and the label's new entry edge is the *other* +side's. The chain direction there is therefore the base's at the +other glued label, and this is what carries the interface's +alternation along a chain of through-edges. +-/ + +end OpenCut + +/-! ## The closing cut + +A closing cut takes its own edge away and touches nothing else: no +surviving label's entry edge is one of its flags, and every direction +reads through unchanged. +-/ + +section ClosedCut + +variable {L : Type} + +/-- **The chain direction survives a closing glue.** -/ +theorem chainDir_unglueClosed_surviving {V : Fragment L} {i : L} {j : L} + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + (hct : ∀ f ∈ t, (V.gluePairClosed i j hclosed).pairing f ∈ t) (b : Bool) + (hcL : ∀ f ∈ liftSubsetClosed t b, V.pairing f ∈ liftSubsetClosed t b) + (κ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).RelTransitionSystem) + (o' : κ'.Orientation) (bl : SurvivingLabel L i j) : + chainDir (unglueOrientationClosed hclosed b t hct hcL κ' o') + (V.boundaryFlag bl.val) + = chainDir o' + ((V.gluePairClosed i j hclosed).boundaryFlag bl) := by + change unglueIsOut o'.isOut (V.pairing (V.boundaryFlag bl.val)) + = o'.isOut ((V.gluePairClosed i j hclosed).pairing + (glueBoundaryFlag V i j bl)) + rw [show V.pairing (V.boundaryFlag bl.val) + = ((V.gluePairClosed i j hclosed).pairing + (glueBoundaryFlag V i j bl)).val + from (gluePairClosed_pairing_val hclosed + (glueBoundaryFlag V i j bl)).symm, + unglueIsOut_val o'.isOut ((V.gluePairClosed i j hclosed).pairing + (glueBoundaryFlag V i j bl))] + +/-- **The alternation passes down a closing glue.** -/ +theorem chainDir_alternates_unglueClosed {V : Fragment L} {i : L} {j : L} + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (t : Finset (SurvivingFlag V i j)) + (hct : ∀ f ∈ t, (V.gluePairClosed i j hclosed).pairing f ∈ t) (b : Bool) + (hcL : ∀ f ∈ liftSubsetClosed t b, V.pairing f ∈ liftSubsetClosed t b) + (κ' : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).RelTransitionSystem) + (o' : κ'.Orientation) (bl br : SurvivingLabel L i j) + (halt : chainDir o' + ((V.gluePairClosed i j hclosed).boundaryFlag br) + = !chainDir o' + ((V.gluePairClosed i j hclosed).boundaryFlag bl)) : + chainDir (unglueOrientationClosed hclosed b t hct hcL κ' o') + (V.boundaryFlag br.val) + = !chainDir (unglueOrientationClosed hclosed b t hct hcL κ' o') + (V.boundaryFlag bl.val) := by + rw [chainDir_unglueClosed_surviving hclosed t hct b hcL κ' o' br, + chainDir_unglueClosed_surviving hclosed t hct b hcL κ' o' bl] + exact halt + +end ClosedCut + +/-! ## Reading the direction through the transports + +The stage's data reaches the base through a relabel and, at the +`gluePair` dispatch, an equality of fragments. Neither touches the +orientation's values, so neither touches the chain direction. +-/ + +section Transports + +variable {L : Type} + +/-- Transporting a subset does not move a direction. -/ +theorem chainDir_orientOfEq {V : Fragment L} + {F F' : EdgeSubset V} (hF : F = F') + {κ : F.RelTransitionSystem} (o : κ.Orientation) (f : V.Flag) : + chainDir (orientOfEq hF o) f = chainDir o f := by + subst hF + rfl + +/-- Transport a flag along an equality of fragments. -/ +noncomputable def flagOfEq {V₁ V₂ : Fragment L} (hV : V₁ = V₂) + (f : V₁.Flag) : V₂.Flag := by + subst hV; exact f + +/-- The direction reads through a transport of the family along an +equality of fragments. -/ +theorem chainDir_dataOfEq [LinearOrder L] + {V₁ V₂ : Fragment L} (hV : V₁ = V₂) + (𝒟 : DataFamily V₂) (s : Finset V₁.Flag) + (hc : ∀ f ∈ s, V₁.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) + (hc' : ∀ f ∈ flagsOfEq V₁ V₂ hV s, + V₂.pairing f ∈ flagsOfEq V₁ V₂ hV s) + (hE' : (EdgeSubset.mk (flagsOfEq V₁ V₂ hV s) hc').Eulerian) + (hne' : Nonempty + (EdgeSubset.mk (flagsOfEq V₁ V₂ hV s) hc').CanonData) + (f : V₁.Flag) : + chainDir (dataOfEq hV 𝒟 s hc hE hne).2 f + = chainDir (𝒟 (flagsOfEq V₁ V₂ hV s) hc' hE' hne').2 + (flagOfEq hV f) := by + subst hV + rfl + +/-- The direction reads through a transport of the family along a +relabel. -/ +theorem chainDir_relabelDataDown [LinearOrder L] {V : Fragment L} + {β : Type} [LinearOrder β] + (e : L ≃o β) (𝒟 : DataFamily (V.relabel e.toEquiv)) + (s : Finset V.Flag) (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) + (hc' : ∀ f ∈ s, (V.relabel e.toEquiv).pairing f ∈ s) + (hE' : (EdgeSubset.mk s hc' : + EdgeSubset (V.relabel e.toEquiv)).Eulerian) + (hne' : Nonempty (EdgeSubset.mk s hc' : + EdgeSubset (V.relabel e.toEquiv)).CanonData) + (f : V.Flag) : + chainDir (relabelDataDown e 𝒟 s hc hE hne).2 f + = chainDir (𝒟 s hc' hE' hne').2 f := rfl + +end Transports + +/-! ## The interface pairs of a stage + +The composition glues the pair `(inl a, inr a)` at each `a`. Naming +those labels lets the alternation be stated for a whole stage, and +the two lemmas below are the identifications the iteration needs: the +top pair is the stage's own cut, and a lower pair survives it +unchanged. +-/ + +section InterfacePairs + +/-- The left label of the `a`-th interface pair. -/ +def intL (n : ℕ) (a : Fin n) : Fin (0 + n) ⊕ Fin (n + 0) := + Sum.inl (Fin.cast (by omega) a) + +/-- The right label of the `a`-th interface pair. -/ +def intR (n : ℕ) (a : Fin n) : Fin (0 + n) ⊕ Fin (n + 0) := + Sum.inr (Fin.cast (by omega) a) + +/-- The top pair is the stage's own cut. -/ +theorem intL_last (n : ℕ) : intL (n + 1) (Fin.last n) = cutL n := + congrArg Sum.inl (Fin.ext (by simp)) + +/-- The top pair is the stage's own cut. -/ +theorem intR_last (n : ℕ) : intR (n + 1) (Fin.last n) = cutR n := + congrArg Sum.inr (Fin.ext (by simp)) + +/-- A lower pair survives the stage's cut. -/ +theorem intL_castSucc_ne (n : ℕ) (b : Fin n) : + intL (n + 1) b.castSucc ≠ cutL n ∧ + intL (n + 1) b.castSucc ≠ cutR n := by + refine ⟨fun hx => ?_, fun hx => absurd hx (by simp [intL, cutR])⟩ + have hv := congrArg Fin.val (Sum.inl.inj hx) + have := b.isLt + simp only [Fin.val_cast, Fin.val_castSucc] at hv + omega + +/-- A lower pair survives the stage's cut. -/ +theorem intR_castSucc_ne (n : ℕ) (b : Fin n) : + intR (n + 1) b.castSucc ≠ cutL n ∧ + intR (n + 1) b.castSucc ≠ cutR n := by + refine ⟨fun hx => absurd hx (by simp [intR, cutL]), fun hx => ?_⟩ + have hv := congrArg Fin.val (Sum.inr.inj hx) + have := b.isLt + simp only [Fin.val_cast, Fin.val_castSucc] at hv + omega + +/-- The step reads a lower left label as the next stage's. -/ +theorem interfaceStepEquiv_intL (n : ℕ) (b : Fin n) : + interfaceStepEquiv 0 n 0 + ⟨intL (n + 1) b.castSucc, intL_castSucc_ne n b⟩ + = intL n b := by + change interfaceStepEquiv 0 n 0 + ⟨Sum.inl (Fin.cast (by omega) b.castSucc), + intL_castSucc_ne n b⟩ = _ + rw [interfaceStepEquiv_apply_inl 0 n 0 _ (intL_castSucc_ne n b)] + refine congrArg Sum.inl (Fin.ext ?_) + rw [finRemoveEquiv_top_val (n := 0 + n)] + simp + +/-- The step reads a lower right label as the next stage's. -/ +theorem interfaceStepEquiv_intR (n : ℕ) (b : Fin n) : + interfaceStepEquiv 0 n 0 + ⟨intR (n + 1) b.castSucc, intR_castSucc_ne n b⟩ + = intR n b := by + change interfaceStepEquiv 0 n 0 + ⟨Sum.inr (Fin.cast (by omega) b.castSucc), + intR_castSucc_ne n b⟩ = _ + rw [interfaceStepEquiv_apply_inr 0 n 0 _ (intR_castSucc_ne n b)] + refine congrArg Sum.inr (Fin.ext ?_) + rw [rightRemoveEquiv_val] + have := b.isLt + simp only [Fin.val_cast, Fin.val_castSucc] + rw [ite_eq_left (by omega)] + +/-! ## The subsets the composition reaches + +The glue's own subsets are the base's whose drop is closed under the +rewire at every stage. Off those the base's summand vanishes on a +diagonal state (`rewire_closed_of_liftOpen_closed`), so the +alternation is only ever wanted on them. +-/ + +/-- The lexicographic order on the stage's label type. -/ +@[reducible] local instance reachOrder (n : ℕ) : + LinearOrder (Fin (0 + n) ⊕ Fin (n + 0)) := + sumLexLinearOrder _ _ + +/-- The order the composition's own (empty) label type carries. -/ +@[reducible] local instance reachOrderTop : + LinearOrder (Fin 0 ⊕ Fin 0) := + sumLexLinearOrder _ _ + +/-- The same order one stage up. -/ +@[reducible] local instance reachOrderSucc (n : ℕ) : + LinearOrder (Fin (0 + n + 1) ⊕ Fin (n + 1 + 0)) := + sumLexLinearOrder _ _ + +open Classical in +/-- **The subsets the composition reaches.** -/ +def Reachable : (n : ℕ) → + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) → + Finset V.Flag → Prop + | 0, _, _ => True + | n + 1, V, s => + if hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then + Reachable n (stepFragment n V) + (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) s)) + else + (∀ f ∈ V.dropSubset (cutL n) (cutR n) s, + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hcl).pairing f + ∈ V.dropSubset (cutL n) (cutR n) s) + ∧ Reachable n (stepFragment n V) + (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hcl) + (V.dropSubset (cutL n) (cutR n) s)) + +open Classical in +/-- The reach, one stage down, at an open cut. -/ +theorem reachable_succ_open (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) (s : Finset V.Flag) + (hr : Reachable (n + 1) V s) : + (∀ f ∈ V.dropSubset (cutL n) (cutR n) s, + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hop).pairing f ∈ V.dropSubset (cutL n) (cutR n) s) + ∧ Reachable n (stepFragment n V) + (flagsOfEq + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_open n V hop) + (V.dropSubset (cutL n) (cutR n) s)) := by + have hr' : (if hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then _ else _) := hr + rwa [dite_eq_right hop] at hr' + +open Classical in +/-- The reach, one stage down, at a closing cut. -/ +theorem reachable_succ_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) (s : Finset V.Flag) + (hr : Reachable (n + 1) V s) : + Reachable n (stepFragment n V) + (flagsOfEq (V.gluePairClosed (cutL n) (cutR n) hcl) + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (gluePair_eq_closed n V hcl) + (V.dropSubset (cutL n) (cutR n) s)) := by + have hr' : (if hc : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then _ else _) := hr + rwa [dite_eq_left hcl] at hr' + +open Classical in +/-- **The stage's own cut alternates.** For a reached subset the +pushed-back data is the glued fragment's, unglued, and there the two +glued labels' directions are opposite. -/ +theorem chainDir_stepDataDown_top (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (𝒟step : DataFamily (stepFragment n V)) (s : Finset V.Flag) + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (hdc : ∀ f ∈ V.dropSubset (cutL n) (cutR n) s, + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hop).pairing f ∈ V.dropSubset (cutL n) (cutR n) s) + (hIl : V.pairing (V.boundaryFlag (cutL n)) + ∈ (EdgeSubset.mk s hc).internalFlags) + (hIr : V.pairing (V.boundaryFlag (cutR n)) + ∈ (EdgeSubset.mk s hc).internalFlags) : + chainDir (stepDataDown n V 𝒟step s hc hE hne).2 + (V.boundaryFlag (cutR n)) + = !chainDir (stepDataDown n V 𝒟step s hc hE hne).2 + (V.boundaryFlag (cutL n)) := by + have hlift : liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s) = s := + liftSubsetOpen_dropSubset (cutL_ne_cutR n) hop s hc + have hcL : ∀ f ∈ liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s), + V.pairing f ∈ liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s) := by + rw [hlift]; exact hc + have hF : (EdgeSubset.mk (liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s)) hcL : EdgeSubset V) + = EdgeSubset.mk s hc := EdgeSubset.ext hlift + have hEt : (EdgeSubset.mk (V.dropSubset (cutL n) (cutR n) s) hdc : + EdgeSubset (V.gluePairOpen (cutL n) (cutR n) + (cutL_ne_cutR n) hop)).Eulerian := + (eulerian_lift_open_iff (cutL_ne_cutR n) hop _ hdc hcL).mp + (by rw [hF]; exact hE) + have hnet : Nonempty (EdgeSubset.mk + (V.dropSubset (cutL n) (cutR n) s) hdc : + EdgeSubset (V.gluePairOpen (cutL n) (cutR n) + (cutL_ne_cutR n) hop)).CanonData := + nonempty_canonData_glueOpen (cutL_ne_cutR n) hop _ hdc hcL + (by rw [hF]; exact hne) + have hstep : stepDataDown n V 𝒟step + = unglueDataOpen (cutL_ne_cutR n) hop + (dataOfEq (gluePair_eq_open n V hop) + (stepDataGlued n V 𝒟step)) := by + unfold stepDataDown + rw [dite_eq_right hop] + have hIl' : (partnerSurvI hop).val + ∈ (EdgeSubset.mk (liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s)) hcL : + EdgeSubset V).internalFlags := by + rw [hF]; exact hIl + have hIr' : (partnerSurvJ hop).val + ∈ (EdgeSubset.mk (liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s)) hcL : + EdgeSubset V).internalFlags := by + rw [hF]; exact hIr + rw [hstep, unglueDataOpen_apply (cutL_ne_cutR n) hop _ s hc hE hne + (V.dropSubset (cutL n) (cutR n) s) rfl hdc hcL hF hEt hnet, + chainDir_orientOfEq, chainDir_orientOfEq] + exact chainDir_unglueOpen_alternates (cutL_ne_cutR n) hop _ hdc + hcL _ _ hIl' hIr' + +open Classical in +/-- **A lower pair's alternation passes down an open stage.** -/ +theorem chainDir_stepDataDown_lower_open (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (𝒟step : DataFamily (stepFragment n V)) (s : Finset V.Flag) + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (hdc : ∀ f ∈ V.dropSubset (cutL n) (cutR n) s, + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hop).pairing f ∈ V.dropSubset (cutL n) (cutR n) s) + (bl br : SurvivingLabel + (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0)) (cutL n) (cutR n)) + (hIl : V.pairing (V.boundaryFlag bl.val) + ∈ (EdgeSubset.mk s hc).internalFlags) + (hIr : V.pairing (V.boundaryFlag br.val) + ∈ (EdgeSubset.mk s hc).internalFlags) + (hEt : (EdgeSubset.mk (V.dropSubset (cutL n) (cutR n) s) hdc : + EdgeSubset (V.gluePairOpen (cutL n) (cutR n) + (cutL_ne_cutR n) hop)).Eulerian) + (hnet : Nonempty (EdgeSubset.mk + (V.dropSubset (cutL n) (cutR n) s) hdc : + EdgeSubset (V.gluePairOpen (cutL n) (cutR n) + (cutL_ne_cutR n) hop)).CanonData) + (halt : chainDir + ((dataOfEq (gluePair_eq_open n V hop) + (stepDataGlued n V 𝒟step)) + (V.dropSubset (cutL n) (cutR n) s) hdc hEt hnet).2 + ((V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hop).boundaryFlag br) + = !chainDir + ((dataOfEq (gluePair_eq_open n V hop) + (stepDataGlued n V 𝒟step)) + (V.dropSubset (cutL n) (cutR n) s) hdc hEt hnet).2 + ((V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hop).boundaryFlag bl)) : + chainDir (stepDataDown n V 𝒟step s hc hE hne).2 + (V.boundaryFlag br.val) + = !chainDir (stepDataDown n V 𝒟step s hc hE hne).2 + (V.boundaryFlag bl.val) := by + have hlift : liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s) = s := + liftSubsetOpen_dropSubset (cutL_ne_cutR n) hop s hc + have hcL : ∀ f ∈ liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s), + V.pairing f ∈ liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s) := by + rw [hlift]; exact hc + have hF : (EdgeSubset.mk (liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s)) hcL : EdgeSubset V) + = EdgeSubset.mk s hc := EdgeSubset.ext hlift + have hIl' : V.pairing (V.boundaryFlag bl.val) + ∈ (EdgeSubset.mk (liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s)) hcL : + EdgeSubset V).internalFlags := by + rw [hF]; exact hIl + have hIr' : V.pairing (V.boundaryFlag br.val) + ∈ (EdgeSubset.mk (liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s)) hcL : + EdgeSubset V).internalFlags := by + rw [hF]; exact hIr + have hstep : stepDataDown n V 𝒟step + = unglueDataOpen (cutL_ne_cutR n) hop + (dataOfEq (gluePair_eq_open n V hop) + (stepDataGlued n V 𝒟step)) := by + unfold stepDataDown + rw [dite_eq_right hop] + rw [hstep, unglueDataOpen_apply (cutL_ne_cutR n) hop _ s hc hE hne + (V.dropSubset (cutL n) (cutR n) s) rfl hdc hcL hF hEt hnet, + chainDir_orientOfEq, chainDir_orientOfEq] + exact chainDir_alternates_unglueOpen (cutL_ne_cutR n) hop _ hdc + hcL _ _ bl br hIl' hIr' halt + +open Classical in +/-- **A pair's alternation passes down a closing stage.** -/ +theorem chainDir_stepDataDown_lower_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (𝒟step : DataFamily (stepFragment n V)) (s : Finset V.Flag) + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (bl br : SurvivingLabel + (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0)) (cutL n) (cutR n)) + (hEt : (EdgeSubset.mk (V.dropSubset (cutL n) (cutR n) s) + (dropSubset_pairing_closed_of_closed hcl s hc) : + EdgeSubset (V.gluePairClosed (cutL n) (cutR n) + hcl)).Eulerian) + (hnet : Nonempty (EdgeSubset.mk + (V.dropSubset (cutL n) (cutR n) s) + (dropSubset_pairing_closed_of_closed hcl s hc) : + EdgeSubset (V.gluePairClosed (cutL n) (cutR n) + hcl)).CanonData) + (halt : chainDir + ((dataOfEq (gluePair_eq_closed n V hcl) + (stepDataGlued n V 𝒟step)) + (V.dropSubset (cutL n) (cutR n) s) + (dropSubset_pairing_closed_of_closed hcl s hc) hEt + hnet).2 + ((V.gluePairClosed (cutL n) (cutR n) hcl).boundaryFlag br) + = !chainDir + ((dataOfEq (gluePair_eq_closed n V hcl) + (stepDataGlued n V 𝒟step)) + (V.dropSubset (cutL n) (cutR n) s) + (dropSubset_pairing_closed_of_closed hcl s hc) hEt + hnet).2 + ((V.gluePairClosed (cutL n) (cutR n) hcl).boundaryFlag bl)) : + chainDir (stepDataDown n V 𝒟step s hc hE hne).2 + (V.boundaryFlag br.val) + = !chainDir (stepDataDown n V 𝒟step s hc hE hne).2 + (V.boundaryFlag bl.val) := by + have hct := dropSubset_pairing_closed_of_closed hcl s hc + have hlift : liftSubsetClosed (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s)) = s := + liftSubsetClosed_dropSubset (cutL_ne_cutR n) hcl s hc + have hcL : ∀ f ∈ liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s)), + V.pairing f ∈ liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s)) := by + rw [hlift]; exact hc + have hF : (EdgeSubset.mk (liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s))) hcL : + EdgeSubset V) = EdgeSubset.mk s hc := EdgeSubset.ext hlift + have hstep : stepDataDown n V 𝒟step + = unglueDataClosed (cutL_ne_cutR n) hcl + (dataOfEq (gluePair_eq_closed n V hcl) + (stepDataGlued n V 𝒟step)) := by + unfold stepDataDown + rw [dite_eq_left hcl] + rw [hstep, unglueDataClosed_apply (cutL_ne_cutR n) hcl _ s hc hE + hne (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s)) rfl rfl hct hcL hF hEt + hnet, + chainDir_orientOfEq, chainDir_orientOfEq] + exact chainDir_alternates_unglueClosed hcl _ hct _ hcL _ _ bl br + halt + +/-- A boundary flag is never internal. -/ +theorem boundaryFlag_not_internal {L' : Type} + {W : Fragment L'} (F : EdgeSubset W) (b : L') : + W.boundaryFlag b ∉ F.internalFlags := by + intro hx + obtain ⟨-, v, hv⟩ := EdgeSubset.mem_internalFlags_iff.mp hx + rw [W.attach_boundaryFlag] at hv + exact absurd hv (by simp) + +/-- Transporting a boundary flag along an equality of fragments. -/ +theorem flagOfEq_boundaryFlag {L' : Type} {V₁ V₂ : Fragment L'} + (hV : V₁ = V₂) (b : L') : + flagOfEq hV (V₁.boundaryFlag b) = V₂.boundaryFlag b := by + subst hV + rfl + +/-- Closure transports along an equality of fragments. -/ +theorem flagsOfEq_pairing_mem {L : Type} {V₁ V₂ : Fragment L} + (hV : V₁ = V₂) + (t : Finset V₁.Flag) (h : ∀ f ∈ t, V₁.pairing f ∈ t) : + ∀ f ∈ flagsOfEq V₁ V₂ hV t, + V₂.pairing f ∈ flagsOfEq V₁ V₂ hV t := by + subst hV + exact h + +/-- Being Eulerian transports along an equality of fragments. -/ +theorem flagsOfEq_eulerian {L : Type} {V₁ V₂ : Fragment L} + (hV : V₁ = V₂) + (t : Finset V₁.Flag) (h : ∀ f ∈ t, V₁.pairing f ∈ t) + (hEt : (EdgeSubset.mk t h).Eulerian) : + (EdgeSubset.mk (flagsOfEq V₁ V₂ hV t) + (flagsOfEq_pairing_mem hV t h)).Eulerian := by + subst hV + exact hEt + +/-- Canonical data transport along an equality of fragments. -/ +theorem flagsOfEq_canon {L : Type} [LinearOrder L] + {V₁ V₂ : Fragment L} (hV : V₁ = V₂) + (t : Finset V₁.Flag) (h : ∀ f ∈ t, V₁.pairing f ∈ t) + (hnet : Nonempty (EdgeSubset.mk t h).CanonData) : + Nonempty (EdgeSubset.mk (flagsOfEq V₁ V₂ hV t) + (flagsOfEq_pairing_mem hV t h)).CanonData := by + subst hV + exact hnet + +/-- The stage's boundary flag, read on the glued fragment. -/ +theorem stepFragment_boundaryFlag (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (b : Fin (0 + n) ⊕ Fin (n + 0)) : + (stepFragment n V).boundaryFlag b + = (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)).boundaryFlag + ((interfaceStepEquiv 0 n 0).symm b) := rfl + +open Classical in +/-- The dropped subset is Eulerian at an open stage. -/ +theorem eulerian_drop_open (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (s : Finset V.Flag) (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (hdc : ∀ f ∈ V.dropSubset (cutL n) (cutR n) s, + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hop).pairing f ∈ V.dropSubset (cutL n) (cutR n) s) : + (EdgeSubset.mk (V.dropSubset (cutL n) (cutR n) s) hdc : + EdgeSubset (V.gluePairOpen (cutL n) (cutR n) + (cutL_ne_cutR n) hop)).Eulerian := by + have hlift := liftSubsetOpen_dropSubset (cutL_ne_cutR n) hop s hc + have hcL : ∀ f ∈ liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s), + V.pairing f ∈ liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s) := by + rw [hlift]; exact hc + refine (eulerian_lift_open_iff (cutL_ne_cutR n) hop _ hdc hcL).mp + ?_ + rw [show (EdgeSubset.mk (liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s)) hcL : EdgeSubset V) + = EdgeSubset.mk s hc from EdgeSubset.ext hlift] + exact hE + +open Classical in +/-- The dropped subset carries canonical data at an open stage. -/ +theorem canon_drop_open (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (s : Finset V.Flag) (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (hdc : ∀ f ∈ V.dropSubset (cutL n) (cutR n) s, + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hop).pairing f ∈ V.dropSubset (cutL n) (cutR n) s) : + Nonempty (EdgeSubset.mk (V.dropSubset (cutL n) (cutR n) s) hdc : + EdgeSubset (V.gluePairOpen (cutL n) (cutR n) + (cutL_ne_cutR n) hop)).CanonData := by + have hlift := liftSubsetOpen_dropSubset (cutL_ne_cutR n) hop s hc + have hcL : ∀ f ∈ liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s), + V.pairing f ∈ liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s) := by + rw [hlift]; exact hc + refine nonempty_canonData_glueOpen (cutL_ne_cutR n) hop _ hdc hcL + ?_ + rw [show (EdgeSubset.mk (liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s)) hcL : EdgeSubset V) + = EdgeSubset.mk s hc from EdgeSubset.ext hlift] + exact hne + +open Classical in +/-- The dropped subset is Eulerian at a closing stage. -/ +theorem eulerian_drop_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (s : Finset V.Flag) (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) : + (EdgeSubset.mk (V.dropSubset (cutL n) (cutR n) s) + (dropSubset_pairing_closed_of_closed hcl s hc) : + EdgeSubset (V.gluePairClosed (cutL n) (cutR n) + hcl)).Eulerian := by + have hlift := liftSubsetClosed_dropSubset (cutL_ne_cutR n) hcl s hc + have hcL : ∀ f ∈ liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s)), + V.pairing f ∈ liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s)) := by + rw [hlift]; exact hc + refine (eulerian_liftClosed_iff' hcl + (decide (V.boundaryFlag (cutL n) ∈ s)) _ + (dropSubset_pairing_closed_of_closed hcl s hc) hcL).mp ?_ + rw [show (EdgeSubset.mk (liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s))) hcL : + EdgeSubset V) = EdgeSubset.mk s hc from EdgeSubset.ext hlift] + exact hE + +open Classical in +/-- The dropped subset carries canonical data at a closing stage. -/ +theorem canon_drop_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (s : Finset V.Flag) (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) : + Nonempty (EdgeSubset.mk (V.dropSubset (cutL n) (cutR n) s) + (dropSubset_pairing_closed_of_closed hcl s hc) : + EdgeSubset (V.gluePairClosed (cutL n) (cutR n) + hcl)).CanonData := by + have hlift := liftSubsetClosed_dropSubset (cutL_ne_cutR n) hcl s hc + have hcL : ∀ f ∈ liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s)), + V.pairing f ∈ liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s)) := by + rw [hlift]; exact hc + refine nonempty_canonData_glueClosed hcl _ + (dropSubset_pairing_closed_of_closed hcl s hc) + (decide (V.boundaryFlag (cutL n) ∈ s)) hcL ?_ + rw [show (EdgeSubset.mk (liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s))) hcL : + EdgeSubset V) = EdgeSubset.mk s hc from EdgeSubset.ext hlift] + exact hne + +open Classical in +/-- The stage's subset, from the glued fragment's. -/ +theorem stage_pairing_mem (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + {Vg : Fragment (SurvivingLabel + (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0)) (cutL n) (cutR n))} + (hV : Vg = V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (t : Finset Vg.Flag) (hct : ∀ f ∈ t, Vg.pairing f ∈ t) : + ∀ f ∈ flagsOfEq Vg _ hV t, + (stepFragment n V).pairing f ∈ flagsOfEq Vg _ hV t := + flagsOfEq_pairing_mem hV t hct + +open Classical in +/-- **The stage's data, read on the glued fragment.** The dispatch's +identification and the stage's relabel both leave the direction +alone, so a direction at the glued fragment is the stage's at the +relabelled label. -/ +theorem chainDir_stepDataGlued (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (𝒟step : DataFamily (stepFragment n V)) + {Vg : Fragment (SurvivingLabel + (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0)) (cutL n) (cutR n))} + (hV : Vg = V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (t : Finset Vg.Flag) (hct : ∀ f ∈ t, Vg.pairing f ∈ t) + (hEt : (EdgeSubset.mk t hct).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct).CanonData) + (hES : (EdgeSubset.mk (flagsOfEq Vg _ hV t) + (stage_pairing_mem n V hV t hct) : + EdgeSubset (stepFragment n V)).Eulerian) + (hneS : Nonempty (EdgeSubset.mk (flagsOfEq Vg _ hV t) + (stage_pairing_mem n V hV t hct) : + EdgeSubset (stepFragment n V)).CanonData) + (bl : SurvivingLabel + (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0)) (cutL n) (cutR n)) : + chainDir ((dataOfEq hV (stepDataGlued n V 𝒟step)) t hct hEt + hnet).2 (Vg.boundaryFlag bl) + = chainDir (𝒟step (flagsOfEq Vg _ hV t) + (stage_pairing_mem n V hV t hct) hES hneS).2 + ((stepFragment n V).boundaryFlag + (interfaceStepEquiv 0 n 0 bl)) := by + rw [chainDir_dataOfEq hV (stepDataGlued n V 𝒟step) t hct hEt hnet + (flagsOfEq_pairing_mem hV t hct) + (flagsOfEq_eulerian hV t hct hEt) + (flagsOfEq_canon hV t hct hnet) (Vg.boundaryFlag bl), + flagOfEq_boundaryFlag hV bl] + unfold stepDataGlued + rw [chainDir_relabelDataDown (stepIso n) 𝒟step + (flagsOfEq Vg _ hV t) + (flagsOfEq_pairing_mem hV t hct) + (flagsOfEq_eulerian hV t hct hEt) + (flagsOfEq_canon hV t hct hnet) + (stage_pairing_mem n V hV t hct) hES hneS _, + stepFragment_boundaryFlag n V (interfaceStepEquiv 0 n 0 bl), + Equiv.symm_apply_apply] + rfl + +open Classical in +/-- Internality passes from the base to the stage, at a closing +cut. -/ +theorem internal_stage_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + (s : Finset V.Flag) (hc : ∀ f ∈ s, V.pairing f ∈ s) + (bl : SurvivingLabel + (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0)) (cutL n) (cutR n)) + (hI : V.pairing (V.boundaryFlag bl.val) + ∈ (EdgeSubset.mk s hc).internalFlags) : + (V.gluePairClosed (cutL n) (cutR n) hcl).pairing + ((V.gluePairClosed (cutL n) (cutR n) hcl).boundaryFlag bl) + ∈ (EdgeSubset.mk (V.dropSubset (cutL n) (cutR n) s) + (dropSubset_pairing_closed_of_closed hcl s hc) : + EdgeSubset (V.gluePairClosed (cutL n) (cutR n) + hcl)).internalFlags := by + have hlift := liftSubsetClosed_dropSubset (cutL_ne_cutR n) hcl s hc + have hcL : ∀ f ∈ liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s)), + V.pairing f ∈ liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s)) := by + rw [hlift]; exact hc + refine (mem_internalFlags_glueClosed hcl + (decide (V.boundaryFlag (cutL n) ∈ s)) _ + (dropSubset_pairing_closed_of_closed hcl s hc) hcL).mpr ?_ + rw [show ((V.gluePairClosed (cutL n) (cutR n) hcl).pairing + ((V.gluePairClosed (cutL n) (cutR n) hcl).boundaryFlag + bl)).val = V.pairing (V.boundaryFlag bl.val) + from gluePairClosed_pairing_val hcl _, + show (EdgeSubset.mk (liftSubsetClosed + (V.dropSubset (cutL n) (cutR n) s) + (decide (V.boundaryFlag (cutL n) ∈ s))) hcL : + EdgeSubset V) = EdgeSubset.mk s hc from EdgeSubset.ext hlift] + exact hI + +open Classical in +/-- Internality passes from the base to the stage, at an open +cut. -/ +theorem internal_stage_open (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + (s : Finset V.Flag) (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hdc : ∀ f ∈ V.dropSubset (cutL n) (cutR n) s, + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hop).pairing f ∈ V.dropSubset (cutL n) (cutR n) s) + (bl : SurvivingLabel + (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0)) (cutL n) (cutR n)) + (hI : V.pairing (V.boundaryFlag bl.val) + ∈ (EdgeSubset.mk s hc).internalFlags) : + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hop).pairing + ((V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hop).boundaryFlag bl) + ∈ (EdgeSubset.mk (V.dropSubset (cutL n) (cutR n) s) hdc : + EdgeSubset (V.gluePairOpen (cutL n) (cutR n) + (cutL_ne_cutR n) hop)).internalFlags := by + have hlift := liftSubsetOpen_dropSubset (cutL_ne_cutR n) hop s hc + have hcL : ∀ f ∈ liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s), + V.pairing f ∈ liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s) := by + rw [hlift]; exact hc + have hne1 : V.pairing (V.boundaryFlag bl.val) + ≠ V.boundaryFlag (cutL n) := + internal_ne_boundaryFlag hop _ hcL + (by + rw [show (EdgeSubset.mk (liftSubsetOpen + hop (V.dropSubset (cutL n) (cutR n) s)) hcL : + EdgeSubset V) = EdgeSubset.mk s hc + from EdgeSubset.ext hlift] + exact hI) + have hne2 : V.pairing (V.boundaryFlag bl.val) + ≠ V.boundaryFlag (cutR n) := + internal_ne_boundaryFlag hop _ hcL + (by + rw [show (EdgeSubset.mk (liftSubsetOpen + hop (V.dropSubset (cutL n) (cutR n) s)) hcL : + EdgeSubset V) = EdgeSubset.mk s hc + from EdgeSubset.ext hlift] + exact hI) + have hval : ((V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) + hop).pairing ((V.gluePairOpen (cutL n) (cutR n) + (cutL_ne_cutR n) hop).boundaryFlag bl)).val + = V.pairing (V.boundaryFlag bl.val) := + gluePairOpen_pairing_val_of_ne (cutL_ne_cutR n) hop _ hne1 hne2 + refine (mem_internalFlags_glueOpen (cutL_ne_cutR n) hop _ hdc + hcL).mpr ?_ + rw [hval, + show (EdgeSubset.mk (liftSubsetOpen hop + (V.dropSubset (cutL n) (cutR n) s)) hcL : EdgeSubset V) + = EdgeSubset.mk s hc from EdgeSubset.ext hlift] + exact hI + +open Classical in +/-- Being Eulerian passes to the stage. -/ +theorem stage_eulerian (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + {Vg : Fragment (SurvivingLabel + (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0)) (cutL n) (cutR n))} + (hV : Vg = V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (t : Finset Vg.Flag) (hct : ∀ f ∈ t, Vg.pairing f ∈ t) + (hEt : (EdgeSubset.mk t hct).Eulerian) : + (EdgeSubset.mk (flagsOfEq Vg _ hV t) + (stage_pairing_mem n V hV t hct) : + EdgeSubset (stepFragment n V)).Eulerian := by + subst hV + exact (relabelUp_eulerian (stepIso n).toEquiv + (EdgeSubset.mk t hct)).mpr hEt + +open Classical in +/-- Canonical data passes to the stage. -/ +theorem stage_canon (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + {Vg : Fragment (SurvivingLabel + (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0)) (cutL n) (cutR n))} + (hV : Vg = V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (t : Finset Vg.Flag) (hct : ∀ f ∈ t, Vg.pairing f ∈ t) + (hnet : Nonempty (EdgeSubset.mk t hct).CanonData) : + Nonempty (EdgeSubset.mk (flagsOfEq Vg _ hV t) + (stage_pairing_mem n V hV t hct) : + EdgeSubset (stepFragment n V)).CanonData := by + subst hV + exact (nonempty_canonData_relabelUp (stepIso n) + (EdgeSubset.mk t hct)).mpr hnet + +open Classical in +/-- Internality passes to the stage. -/ +theorem stage_internal (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + {Vg : Fragment (SurvivingLabel + (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0)) (cutL n) (cutR n))} + (hV : Vg = V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) + (t : Finset Vg.Flag) (hct : ∀ f ∈ t, Vg.pairing f ∈ t) + (bl : SurvivingLabel + (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0)) (cutL n) (cutR n)) + (hf : Vg.pairing (Vg.boundaryFlag bl) + ∈ (EdgeSubset.mk t hct).internalFlags) : + (stepFragment n V).pairing ((stepFragment n V).boundaryFlag + (interfaceStepEquiv 0 n 0 bl)) + ∈ (EdgeSubset.mk (flagsOfEq Vg _ hV t) + (stage_pairing_mem n V hV t hct) : + EdgeSubset (stepFragment n V)).internalFlags := by + subst hV + rw [stepFragment_boundaryFlag n V (interfaceStepEquiv 0 n 0 bl), + Equiv.symm_apply_apply] + exact (relabelUp_internalFlags (stepIso n).toEquiv + (EdgeSubset.mk t hct)).symm ▸ hf + +open Classical in +/-- **The interface alternates.** At a reached subset, the data the +composition pushes back to the base gives opposite directions at the +two ends of every interface pair whose partners are both internal. + +This is RS21's step 1: the composition's Eulerian orientation, read +on the base, enters at one end of each glued pair and leaves at the +other. -/ +theorem chainDir_pushData_alternates : ∀ (n : ℕ) + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) + (𝒟 : DataFamily (glueInterface 0 n 0 V)) (s : Finset V.Flag) + (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) + (_hr : Reachable n V s) (a : Fin n), + V.pairing (V.boundaryFlag (intL n a)) + ∈ (EdgeSubset.mk s hc).internalFlags → + V.pairing (V.boundaryFlag (intR n a)) + ∈ (EdgeSubset.mk s hc).internalFlags → + chainDir (pushData n V 𝒟 s hc hE hne).2 + (V.boundaryFlag (intR n a)) + = !chainDir (pushData n V 𝒟 s hc hE hne).2 + (V.boundaryFlag (intL n a)) + | 0, _, _, _, _, _, _, _, a => a.elim0 + | n + 1, V, 𝒟, s, hc, hE, hne, hr, a => by + refine Fin.lastCases ?_ ?_ a + · intro hIl hIr + rw [intL_last] at hIl + rw [intR_last] at hIr + rw [intL_last, intR_last] + by_cases hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) + · exact absurd (hcl ▸ hIl) + (boundaryFlag_not_internal (EdgeSubset.mk s hc) (cutR n)) + · exact chainDir_stepDataDown_top n V + (pushData n (stepFragment n V) 𝒟) s hc hE hne hcl + (reachable_succ_open n V hcl s hr).1 hIl hIr + · intro b hIl hIr + by_cases hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) + · have hct := dropSubset_pairing_closed_of_closed hcl s hc + have hEt := eulerian_drop_closed n V s hc hE hcl + have hnet := canon_drop_closed n V s hc hne hcl + have hES := stage_eulerian n V (gluePair_eq_closed n V hcl) + _ hct hEt + have hneS := stage_canon n V (gluePair_eq_closed n V hcl) + _ hct hnet + refine chainDir_stepDataDown_lower_closed n V + (pushData n (stepFragment n V) 𝒟) s hc hE hne hcl + ⟨intL (n + 1) b.castSucc, intL_castSucc_ne n b⟩ + ⟨intR (n + 1) b.castSucc, intR_castSucc_ne n b⟩ hEt hnet + ?_ + rw [chainDir_stepDataGlued n V + (pushData n (stepFragment n V) 𝒟) + (gluePair_eq_closed n V hcl) _ hct hEt hnet hES hneS _, + chainDir_stepDataGlued n V + (pushData n (stepFragment n V) 𝒟) + (gluePair_eq_closed n V hcl) _ hct hEt hnet hES hneS _, + interfaceStepEquiv_intL, interfaceStepEquiv_intR] + refine chainDir_pushData_alternates n (stepFragment n V) 𝒟 + _ _ hES hneS (reachable_succ_closed n V hcl s hr) b ?_ ?_ + · rw [← interfaceStepEquiv_intL n b] + exact stage_internal n V (gluePair_eq_closed n V hcl) _ + hct _ (internal_stage_closed n V hcl s hc _ hIl) + · rw [← interfaceStepEquiv_intR n b] + exact stage_internal n V (gluePair_eq_closed n V hcl) _ + hct _ (internal_stage_closed n V hcl s hc _ hIr) + · obtain ⟨hdc, hrs⟩ := reachable_succ_open n V hcl s hr + have hEt := eulerian_drop_open n V s hc hE hcl hdc + have hnet := canon_drop_open n V s hc hne hcl hdc + have hES := stage_eulerian n V (gluePair_eq_open n V hcl) + _ hdc hEt + have hneS := stage_canon n V (gluePair_eq_open n V hcl) + _ hdc hnet + refine chainDir_stepDataDown_lower_open n V + (pushData n (stepFragment n V) 𝒟) s hc hE hne hcl hdc + ⟨intL (n + 1) b.castSucc, intL_castSucc_ne n b⟩ + ⟨intR (n + 1) b.castSucc, intR_castSucc_ne n b⟩ hIl hIr + hEt hnet ?_ + rw [chainDir_stepDataGlued n V + (pushData n (stepFragment n V) 𝒟) + (gluePair_eq_open n V hcl) _ hdc hEt hnet hES hneS _, + chainDir_stepDataGlued n V + (pushData n (stepFragment n V) 𝒟) + (gluePair_eq_open n V hcl) _ hdc hEt hnet hES hneS _, + interfaceStepEquiv_intL, interfaceStepEquiv_intR] + refine chainDir_pushData_alternates n (stepFragment n V) 𝒟 + _ _ hES hneS hrs b ?_ ?_ + · rw [← interfaceStepEquiv_intL n b] + exact stage_internal n V (gluePair_eq_open n V hcl) _ + hdc _ (internal_stage_open n V hcl s hc hdc _ hIl) + · rw [← interfaceStepEquiv_intR n b] + exact stage_internal n V (gluePair_eq_open n V hcl) _ + hdc _ (internal_stage_open n V hcl s hc hdc _ hIr) + +end InterfacePairs + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceContract.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceContract.lean new file mode 100644 index 0000000000..3fb7a3d154 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceContract.lean @@ -0,0 +1,282 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerRecursion + +/-! +# Contracting the interface + +RS21's (13) contracts the two fragments' tensors with the super +form one leg at a time, and the closing display of Theorem 6's +proof sums the result over the Eulerian subsets. In the flag +model the composition glues one interface pair at a time, and +each glue is exactly such a contraction: the glued +fragment's summand is the base's summed over the two glued labels' +colours against the cut's own kernel. + +This file names the data that contraction carries — the fragment, the +subset and the state at each stage — and the accumulated weight. The +per-cut kernels are the ones the dispatches deliver: the super form +at a closed cut, and at an open one the configuration's own kernel, +which is the same form read in the basis the tensor twists into. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + +open Fragment Equiv +/-- The lexicographic order on the recursion's label type. -/ +@[reducible] local instance contractOrder (n : ℕ) : + LinearOrder (Fin (0 + n) ⊕ Fin (n + 0)) := + sumLexLinearOrder _ _ + +/-- The same order one stage up. -/ +@[reducible] local instance contractOrderSucc (n : ℕ) : + LinearOrder (Fin (0 + n + 1) ⊕ Fin (n + 1 + 0)) := + sumLexLinearOrder _ _ + +/-! ## The stage's fragment and state -/ + +/-- The fragment one stage down: glue the top interface pair, then +relabel. -/ +noncomputable def stepFragment (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) : + Fragment (Fin (0 + n) ⊕ Fin (n + 0)) := + (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)).relabel + (interfaceStepEquiv 0 n 0) + +/-! ## The data a subset carries, and its summand + +RS21 chooses an Eulerian orientation and a compatible local pairing +for each Eulerian subset; the flag model's counterpart is a +transition system with an orientation. A family of those — one per +good subset — is what the interface recursion pushes forward, and the +summand it names is RS21's `s_h`, with no chord sign in it. +-/ + +section DataFamily + +variable {L : Type} + +/-- **A choice of transition system and orientation at every good +subset.** -/ +def DataFamily [LinearOrder L] (V : Fragment L) : Type := + ∀ (s : Finset V.Flag) (hc : ∀ f ∈ s, V.pairing f ∈ s), + (EdgeSubset.mk s hc).Eulerian → + Nonempty (EdgeSubset.mk s hc).CanonData → + Σ κ : (EdgeSubset.mk s hc).RelTransitionSystem, κ.Orientation + +end DataFamily + +/-! ## The data pushed back across one glue + +The dispatch reads the base's summand at the *unglued* data, and an +orientation only ever ungloues — building one across a glue is step 1 +again. So the choice is made at the glued fragment and pushed back, +which is the direction this construction runs. +-/ + +section UnglueData + +variable {L : Type} + +open Classical in +/-- **The glued fragment's data, read on the base.** At a subset +whose drop is closed under the rewire the base's data are the unglue +of the glued fragment's; elsewhere any choice serves, the summand +vanishing there. -/ +noncomputable def unglueDataOpen + [LinearOrder L] {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (𝒟' : DataFamily (V.gluePairOpen i j hij hopen)) : DataFamily V := + fun s hc hE hne => + if hag : ∀ f ∈ V.dropSubset i j s, + (V.gluePairOpen i j hij hopen).pairing f + ∈ V.dropSubset i j s then + have hlift : liftSubsetOpen hopen (V.dropSubset i j s) = s := + liftSubsetOpen_dropSubset hij hopen s hc + have hcL : ∀ f ∈ liftSubsetOpen hopen + (V.dropSubset i j s), + V.pairing f ∈ liftSubsetOpen hopen + (V.dropSubset i j s) := by + rw [hlift]; exact hc + have hF : (EdgeSubset.mk (liftSubsetOpen hopen + (V.dropSubset i j s)) hcL : EdgeSubset V) + = EdgeSubset.mk s hc := EdgeSubset.ext hlift + have hEL : (EdgeSubset.mk (liftSubsetOpen hopen + (V.dropSubset i j s)) hcL : EdgeSubset V).Eulerian := by + rw [hF]; exact hE + have hneL : Nonempty (EdgeSubset.mk (liftSubsetOpen hopen + (V.dropSubset i j s)) hcL : EdgeSubset V).CanonData := by + rw [hF]; exact hne + have hE' : (EdgeSubset.mk (V.dropSubset i j s) hag : + EdgeSubset (V.gluePairOpen i j hij hopen)).Eulerian := + (eulerian_lift_open_iff hij hopen (V.dropSubset i j s) hag + hcL).mp hEL + have hne' : Nonempty (EdgeSubset.mk (V.dropSubset i j s) hag : + EdgeSubset (V.gluePairOpen i j hij hopen)).CanonData := + nonempty_canonData_glueOpen hij hopen (V.dropSubset i j s) + hag hcL hneL + ⟨relOfEq hF (RelTransitionSystem.unglueOpen hij hopen + (V.dropSubset i j s) hag hcL + (𝒟' (V.dropSubset i j s) hag hE' hne').1), + orientOfEq hF (unglueOrientationOpen hij hopen + (V.dropSubset i j s) hag hcL + (𝒟' (V.dropSubset i j s) hag hE' hne').1 + (𝒟' (V.dropSubset i j s) hag hE' hne').2)⟩ + else ⟨(Classical.choice hne).1, (Classical.choice hne).2.val⟩ + +open Classical in +/-- **The unglued data at an open cut, evaluated.** As in the closed +case the drop is abstracted, so that the dependent proofs the +definition carries can be substituted rather than rewritten. -/ +theorem unglueDataOpen_apply + [LinearOrder L] {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hopen : V.pairing (V.boundaryFlag i) ≠ V.boundaryFlag j) + (𝒟' : DataFamily (V.gluePairOpen i j hij hopen)) + (s : Finset V.Flag) (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc : EdgeSubset V).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc : EdgeSubset V).CanonData) + (t : Finset (SurvivingFlag V i j)) + (hdrop : V.dropSubset i j s = t) + (hct : ∀ f ∈ t, (V.gluePairOpen i j hij hopen).pairing f ∈ t) + (hcL : ∀ f ∈ liftSubsetOpen hopen t, + V.pairing f ∈ liftSubsetOpen hopen t) + (hF : (EdgeSubset.mk (liftSubsetOpen hopen t) hcL : + EdgeSubset V) = EdgeSubset.mk s hc) + (hEt : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairOpen i j hij hopen)).CanonData) : + unglueDataOpen hij hopen 𝒟' s hc hE hne + = ⟨relOfEq hF (RelTransitionSystem.unglueOpen hij hopen t hct + hcL (𝒟' t hct hEt hnet).1), + orientOfEq hF (unglueOrientationOpen hij hopen t hct hcL + (𝒟' t hct hEt hnet).1 (𝒟' t hct hEt hnet).2)⟩ := by + subst hdrop + unfold unglueDataOpen + rw [dite_eq_left hct] + +end UnglueData + +section UnglueDataClosed + +variable {L : Type} + +/-- A closed glue does not change any vertex's degree, so the lift is +Eulerian exactly when the glued subset is. -/ +theorem eulerian_liftClosed_iff' {V : Fragment L} {i : L} {j : L} + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (b : Bool) + (s' : Finset (SurvivingFlag V i j)) + (hc' : ∀ f ∈ s', (V.gluePairClosed i j hclosed).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetClosed s' b, + V.pairing f ∈ liftSubsetClosed s' b) : + (EdgeSubset.mk (liftSubsetClosed s' b) hc : EdgeSubset V).Eulerian + ↔ (EdgeSubset.mk s' hc' : + EdgeSubset (V.gluePairClosed i j hclosed)).Eulerian := by + have hdeg : ∀ v : V.Vertex, + (EdgeSubset.mk (liftSubsetClosed s' b) hc : + EdgeSubset V).deg v + = (EdgeSubset.mk s' hc' : + EdgeSubset (V.gluePairClosed i j hclosed)).deg v := + fun v => deg_liftSubsetClosed_eq s' b v + constructor <;> intro hE v + · rw [← hdeg v]; exact hE v + · rw [hdeg v]; exact hE v + +open Classical in +/-- **The glued fragment's data at a closed cut, read on the base.** +Here no agreement is needed: a closed subset's drop is always closed +under the glued pairing, the two cut flags being partners. -/ +noncomputable def unglueDataClosed + [LinearOrder L] {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (𝒟' : DataFamily (V.gluePairClosed i j hclosed)) : DataFamily V := + fun s hc hE hne => + have hc' : ∀ f ∈ V.dropSubset i j s, + (V.gluePairClosed i j hclosed).pairing f + ∈ V.dropSubset i j s := + dropSubset_pairing_closed_of_closed hclosed s hc + have hlift : liftSubsetClosed (V.dropSubset i j s) + (decide (V.boundaryFlag i ∈ s)) = s := + liftSubsetClosed_dropSubset hij hclosed s hc + have hcL : ∀ f ∈ liftSubsetClosed (V.dropSubset i j s) + (decide (V.boundaryFlag i ∈ s)), + V.pairing f ∈ liftSubsetClosed (V.dropSubset i j s) + (decide (V.boundaryFlag i ∈ s)) := by + rw [hlift]; exact hc + have hF : (EdgeSubset.mk (liftSubsetClosed (V.dropSubset i j s) + (decide (V.boundaryFlag i ∈ s))) hcL : EdgeSubset V) + = EdgeSubset.mk s hc := EdgeSubset.ext hlift + have hEL : (EdgeSubset.mk (liftSubsetClosed (V.dropSubset i j s) + (decide (V.boundaryFlag i ∈ s))) hcL : + EdgeSubset V).Eulerian := by + rw [hF]; exact hE + have hneL : Nonempty (EdgeSubset.mk + (liftSubsetClosed (V.dropSubset i j s) + (decide (V.boundaryFlag i ∈ s))) hcL : + EdgeSubset V).CanonData := by + rw [hF]; exact hne + have hE' : (EdgeSubset.mk (V.dropSubset i j s) hc' : + EdgeSubset (V.gluePairClosed i j hclosed)).Eulerian := + (eulerian_liftClosed_iff' hclosed _ (V.dropSubset i j s) hc' + hcL).mp hEL + have hne' : Nonempty (EdgeSubset.mk (V.dropSubset i j s) hc' : + EdgeSubset (V.gluePairClosed i j hclosed)).CanonData := + nonempty_canonData_glueClosed hclosed (V.dropSubset i j s) hc' _ + hcL hneL + ⟨relOfEq hF (RelTransitionSystem.unglueClosed hclosed _ + (V.dropSubset i j s) hc' hcL + (𝒟' (V.dropSubset i j s) hc' hE' hne').1), + orientOfEq hF (unglueOrientationClosed hclosed _ + (V.dropSubset i j s) hc' hcL + (𝒟' (V.dropSubset i j s) hc' hE' hne').1 + (𝒟' (V.dropSubset i j s) hc' hE' hne').2)⟩ + +open Classical in +/-- **The unglued data, evaluated.** The drop and the bit are +abstracted so that the dependent proofs the definition carries can be +substituted rather than rewritten: rewriting them in place is not +type correct, every one of them mentioning the drop. -/ +theorem unglueDataClosed_apply + [LinearOrder L] {V : Fragment L} {i : L} {j : L} (hij : i ≠ j) + (hclosed : V.pairing (V.boundaryFlag i) = V.boundaryFlag j) + (𝒟' : DataFamily (V.gluePairClosed i j hclosed)) + (s : Finset V.Flag) (hc : ∀ f ∈ s, V.pairing f ∈ s) + (hE : (EdgeSubset.mk s hc : EdgeSubset V).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc : EdgeSubset V).CanonData) + (t : Finset (SurvivingFlag V i j)) (b : Bool) + (hdrop : V.dropSubset i j s = t) + (hb : decide (V.boundaryFlag i ∈ s) = b) + (hct : ∀ f ∈ t, (V.gluePairClosed i j hclosed).pairing f ∈ t) + (hcL : ∀ f ∈ liftSubsetClosed t b, + V.pairing f ∈ liftSubsetClosed t b) + (hF : (EdgeSubset.mk (liftSubsetClosed t b) hcL : EdgeSubset V) + = EdgeSubset.mk s hc) + (hEt : (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).Eulerian) + (hnet : Nonempty (EdgeSubset.mk t hct : + EdgeSubset (V.gluePairClosed i j hclosed)).CanonData) : + unglueDataClosed hij hclosed 𝒟' s hc hE hne + = ⟨relOfEq hF (RelTransitionSystem.unglueClosed hclosed b t hct + hcL (𝒟' t hct hEt hnet).1), + orientOfEq hF (unglueOrientationClosed hclosed b t hct hcL + (𝒟' t hct hEt hnet).1 (𝒟' t hct hEt hnet).2)⟩ := by + subst hdrop + subst hb + rfl + +end UnglueDataClosed + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceCut.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceCut.lean new file mode 100644 index 0000000000..8e6c5f8ba4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceCut.lean @@ -0,0 +1,688 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueLedger +public import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexSum +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperGram +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceOrderIso +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor + +/-! +# The interface matching on a fragment's used labels + +RS21 pairs the chord matching `M(ω,κ)` with the matching that +identifies the two fragments' labels, and counts the components of +their union. In the flag model that second matching lives on the +labels of a single fragment whose boundary index is a sum: the left +half is one side's labels, the right half the other's, and an +identification of the two halves says which label is glued to which. + +Only the labels the subset uses carry chords, so the interface +matching has to be read there — which asks that the subset use the +two halves of every interface pair together. That is exactly the +condition under which a glued edge is in the Eulerian subset or out +of it, and it is what the boundary state pins. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + +open Fragment Equiv +section InterfaceCut + +variable {γ δ : Type} + +/-- **The subset uses the two halves of every interface pair +together.** -/ +def InterfacePaired + {V : Fragment (γ ⊕ δ)} (F : EdgeSubset V) (e : γ ≃ δ) : Prop := + ∀ a : γ, V.boundaryFlag (Sum.inl a) ∈ F.boundaryFlags + ↔ V.boundaryFlag (Sum.inr (e a)) ∈ F.boundaryFlags + +/-- The used labels, split by side. -/ +def usedSideEquiv {V : Fragment (γ ⊕ δ)} (F : EdgeSubset V) : + UsedLab F + ≃ {a : γ // V.boundaryFlag (Sum.inl a) ∈ F.boundaryFlags} + ⊕ {b : δ // V.boundaryFlag (Sum.inr b) ∈ F.boundaryFlags} where + toFun x := + match x with + | ⟨Sum.inl a, h⟩ => Sum.inl ⟨a, h⟩ + | ⟨Sum.inr b, h⟩ => Sum.inr ⟨b, h⟩ + invFun := fun + | Sum.inl a => ⟨Sum.inl a.val, a.prop⟩ + | Sum.inr b => ⟨Sum.inr b.val, b.prop⟩ + left_inv := fun x => by + obtain ⟨y, hy⟩ := x + cases y <;> rfl + right_inv := fun x => by cases x <;> rfl + +/-- The identification of the two sides' used labels. -/ +def interfaceSideEquiv {V : Fragment (γ ⊕ δ)} (F : EdgeSubset V) (e : γ ≃ δ) + (hp : InterfacePaired F e) : + {a : γ // V.boundaryFlag (Sum.inl a) ∈ F.boundaryFlags} + ≃ {b : δ // V.boundaryFlag (Sum.inr b) ∈ F.boundaryFlags} := + e.subtypeEquiv (fun a => hp a) + +/-- **The interface matching on the used labels**: each used label of +one side paired with the label it is glued to. -/ +noncomputable def interfaceCut + {V : Fragment (γ ⊕ δ)} (F : EdgeSubset V) (e : γ ≃ δ) + (hp : InterfacePaired F e) : + DirMatching (UsedLab F) := + (DirMatching.interfaceEquivMatching + (interfaceSideEquiv F e hp)).map (usedSideEquiv F).symm + +/-- **The label involution the interface matching realises**: swap +sides along the identification. -/ +def interfaceSwap (e : γ ≃ δ) : γ ⊕ δ → γ ⊕ δ := + Sum.elim (fun a => Sum.inr (e a)) (fun b => Sum.inl (e.symm b)) + +/-- **The interface matching pairs by the swap.** -/ +theorem interfaceCut_edge_val + {V : Fragment (γ ⊕ δ)} (F : EdgeSubset V) (e : γ ≃ δ) + (hp : InterfacePaired F e) + (x : UsedLab F) : + ((interfaceCut F e hp).edge x).val = interfaceSwap e x.val := by + obtain ⟨y, hy⟩ := x + cases y <;> rfl + +end InterfaceCut + +/-! ## Pairing, read on the swap + +`InterfacePaired` is about the two halves of a sum; the constructions +the recursion applies — a glue, then a relabel — do not preserve that +shape, the glued fragment's labels being a subtype rather than a sum. +Reading the condition on the swap instead removes the shape from it, +and then both constructions transport it by a single equation between +label maps. +-/ + +section SwapPaired + +variable {L : Type} {V : Fragment L} (F : EdgeSubset V) (ι : L → L) + +/-- **The subset uses a label exactly when it uses its partner.** -/ +def SwapPaired : Prop := + ∀ x : L, V.boundaryFlag x ∈ F.boundaryFlags + ↔ V.boundaryFlag (ι x) ∈ F.boundaryFlags + +end SwapPaired + +section SwapPairedSum + +variable {γ δ : Type} + +/-- **Pairing on the swap is pairing across the interface.** -/ +theorem swapPaired_iff_interfacePaired + {V : Fragment (γ ⊕ δ)} (F : EdgeSubset V) (e : γ ≃ δ) : + SwapPaired F (interfaceSwap e) ↔ InterfacePaired F e := by + constructor + · exact fun h a => h (Sum.inl a) + · intro h x + cases x with + | inl a => exact h a + | inr b => + have := (h (e.symm b)).symm + rwa [e.apply_symm_apply] at this + +end SwapPairedSum + +section SwapPairedTransport + +/-- **Pairing transports along any reading of one subset's used +labels in another's.** Both constructions the recursion applies are +of this shape: a glue reads a surviving label as a label, a relabel +reads a new index as an old one. -/ +theorem swapPaired_of_mem_iff {L L' : Type} {V : Fragment L} + {V' : Fragment L'} (F : EdgeSubset V) (F' : EdgeSubset V') + (ι : L → L) (ι' : L' → L') (φ : L' → L) + (hmem : ∀ x : L', V'.boundaryFlag x ∈ F'.boundaryFlags + ↔ V.boundaryFlag (φ x) ∈ F.boundaryFlags) + (hcomp : ∀ x : L', φ (ι' x) = ι (φ x)) + (h : SwapPaired F ι) : SwapPaired F' ι' := by + intro x + rw [hmem x, hmem (ι' x), hcomp x] + exact h (φ x) + +variable {α β : Type} + +/-- **Pairing shifts through a relabel.** -/ +theorem swapPaired_relabelUp [LinearOrder α] [LinearOrder β] {W : Fragment α} + (E : α ≃o β) (F : EdgeSubset W) + (ι : α → α) (ι' : β → β) + (hcomp : ∀ x : α, E.symm (ι' (E x)) = ι x) + (h : SwapPaired F ι) : + SwapPaired (F.relabelUp E.toEquiv) ι' := + swapPaired_of_mem_iff F (F.relabelUp E.toEquiv) ι ι' + (fun b => E.symm b) + (fun b => by rw [relabelUp_boundaryFlags E F]; exact Iff.rfl) + (fun b => by + have := hcomp (E.symm b) + rwa [E.apply_symm_apply] at this) + h + +section SwapPairedCut + +/-- **A paired subset reaches the glue.** The glue only sees the +base's subsets that use its two labels together, and a subset paired +by the swap uses them together whenever the swap pairs them. -/ +theorem agreeingSubset_of_swapPaired + {L : Type} {V : Fragment L} (F : EdgeSubset V) (ι : L → L) + (h : SwapPaired F ι) {i j : L} + (hij : ι i = j) : AgreeingSubset i j F.flags := by + refine ⟨F.pairing_mem, ⟨fun hi => ?_, fun hj => ?_⟩⟩ + · have hb := (h i).mp (boundaryFlag_mem_boundaryFlags hi) + rw [hij] at hb + exact mem_flags_of_boundaryFlags F hb + · refine mem_flags_of_boundaryFlags F ((h i).mpr ?_) + rw [hij] + exact boundaryFlag_mem_boundaryFlags hj + +/-- **The glued pair are partners of the interface matching**, which +is what makes the glue contract it. -/ +theorem edge_eq_of_swap + {L : Type} {V : Fragment L} (F : EdgeSubset V) (ι : L → L) + {N : DirMatching (UsedLab F)} + (hN : ∀ x : UsedLab F, ((N.edge x).val : L) = ι x.val) {i j : L} + (hbi : V.boundaryFlag i ∈ F.boundaryFlags) + (hbj : V.boundaryFlag j ∈ F.boundaryFlags) (hij : ι i = j) : + N.edge ⟨i, hbi⟩ = ⟨j, hbj⟩ := + Subtype.ext ((hN ⟨i, hbi⟩).trans hij) + +end SwapPairedCut + +end SwapPairedTransport + +/-! ## The interface matching through a relabel + +The interface recursion relabels after every glue, and the relabel +carries the interface identification with it. Since the matching's +pairing is the swap, all the transport has to check is that the swap +commutes with the relabel — one equation between label maps, with no +subsets, systems or orientations in it. +-/ + +section InterfaceRelabel + +variable {α γ' δ' : Type} + +/-- **The relabelled interface matching pairs by the transported +swap.** -/ +theorem interfaceCut_relabelUp_edge + [LinearOrder α] [LinearOrder (γ' ⊕ δ')] {W : Fragment α} + (F : EdgeSubset W) (E : α ≃o (γ' ⊕ δ')) (e' : γ' ≃ δ') + (hp' : InterfacePaired (F.relabelUp E.toEquiv) e') + (x : UsedLab F) : + (((interfaceCut (F.relabelUp E.toEquiv) e' hp').map + (usedLabRelabelEquiv E F)).edge x).val + = E.symm (interfaceSwap e' (E x.val)) := by + change E.symm ((interfaceCut (F.relabelUp E.toEquiv) e' hp').edge + ⟨E x.val, _⟩).val = _ + rw [interfaceCut_edge_val] + +end InterfaceRelabel + +/-! ## One stage of the interface matching + +At a stage the fragment is glued and then relabelled, and the +interface matching of the result has to be the base's, contracted at +the glued pair. All four kinds of cut read a surviving label as a +label, so the whole comparison is one equation between label maps: +the transported swap on surviving labels is the base's swap. +-/ + +section InterfaceStage + +variable {L Lg γ' δ' : Type} + +/-- **A glue restricts a matching that pairs by an involution of the +labels.** Both sides pair by the same involution, so reading the +glued fragment's matching on the base's used labels gives the base's, +restricted at the glued pair. -/ +theorem restrict_edge_of_swap + {V : Fragment L} {Vg : Fragment Lg} (Fl : EdgeSubset V) + (Fg : EdgeSubset Vg) (φ : Lg → L) (ι : L → L) + {N : DirMatching (UsedLab Fl)} + (hN : ∀ x : UsedLab Fl, ((N.edge x).val : L) = ι x.val) + {Ng : DirMatching (UsedLab Fg)} + (hNg : ∀ z : UsedLab Fg, φ ((Ng.edge z).val) = ι (φ z.val)) + {i j : UsedLab Fl} (hNij : N.edge i = j) + (G : UsedLab Fg ≃ DirMatching.Surviving i j) + (hG : ∀ w : UsedLab Fg, ((G w).val.val : L) = φ w.val) : + (Ng.map G).edge = (N.restrict hNij).edge := by + funext y + have hGs : ∀ z : DirMatching.Surviving i j, + φ ((G.symm z).val) = z.val.val := by + intro z + have := hG (G.symm z) + rw [G.apply_symm_apply] at this + exact this.symm + refine Subtype.ext (Subtype.ext ?_) + rw [DirMatching.map_edge G, hG, hNg, hGs y] + exact (hN y.val).symm + +end InterfaceStage + +/-! ## The swap through the interface step + +The recursion's relabel is `interfaceStepEquiv`, which deletes the +glued label from each half and re-indexes. The interface swap +commutes with it: on either side the deletion is at the top of the +half, so it leaves every surviving label's index alone, and the swap +is the identity on indices. +-/ + +section InterfaceStep + +/-- The identification of the two halves at interface size `n`. -/ +def stepIdent (n : ℕ) : Fin (0 + n) ≃ Fin (n + 0) := + finCongr (by omega) + +/-- The interface identification keeps a label's index. -/ +theorem stepIdent_val {n : ℕ} (v : Fin (0 + n)) : + ((stepIdent n v : Fin (n + 0)) : ℕ) = (v : ℕ) := rfl + +/-- **The interface swap commutes with the recursion's relabel.** -/ +theorem interfaceSwap_interfaceStep (n : ℕ) + (x : {x : Fin (0 + n + 1) ⊕ Fin (n + 1 + 0) // + x ≠ Sum.inl ⟨0 + n, Nat.lt_succ_self _⟩ ∧ + x ≠ Sum.inr ⟨n, by omega⟩}) : + ((interfaceStepEquiv 0 n 0).symm + (interfaceSwap (stepIdent n) + (interfaceStepEquiv 0 n 0 x))).val + = interfaceSwap (stepIdent (n + 1)) x.val := by + obtain ⟨y, hy⟩ := x + cases y with + | inl v => + have hv : (v : ℕ) < n := by + have h1 : (v : ℕ) ≠ 0 + n := fun hh => + hy.1 (congrArg Sum.inl (Fin.ext hh)) + have h2 : (v : ℕ) < 0 + n + 1 := v.isLt + omega + change Sum.inr (((rightRemoveEquiv n 0).symm + (stepIdent n (finRemoveEquiv ⟨0 + n, Nat.lt_succ_self _⟩ + ⟨v, fun he => hy.1 (congrArg Sum.inl he)⟩))).val) + = Sum.inr (stepIdent (n + 1) v) + refine congrArg Sum.inr (Fin.ext ?_) + set d : Fin (n + 0) := stepIdent n + (finRemoveEquiv ⟨0 + n, Nat.lt_succ_self _⟩ + ⟨v, fun he => hy.1 (congrArg Sum.inl he)⟩) with hd + have hdv : (d : ℕ) = (v : ℕ) := by + rw [hd, stepIdent_val] + exact finRemoveEquiv_top_val (n := 0 + n) _ + set z := (rightRemoveEquiv n 0).symm d with hz + have hzd : (rightRemoveEquiv n 0 z : ℕ) = (d : ℕ) := by + rw [hz, Equiv.apply_symm_apply] + have hzne : (z.val : ℕ) ≠ n := fun hh => z.prop (Fin.ext hh) + have hval := rightRemoveEquiv_val n 0 z + rw [hzd] at hval + have : ((stepIdent (n + 1) v : Fin (n + 1 + 0)) : ℕ) = (v : ℕ) := rfl + rw [this] + split_ifs at hval with hlt + · omega + · omega + | inr w => + have hw : (w : ℕ) < n := by + have h1 : (w : ℕ) ≠ n := fun hh => + hy.2 (congrArg Sum.inr (Fin.ext hh)) + have h2 : (w : ℕ) < n + 1 + 0 := w.isLt + omega + change Sum.inl (((finRemoveEquiv ⟨0 + n, Nat.lt_succ_self _⟩).symm + ((stepIdent n).symm (rightRemoveEquiv n 0 + ⟨w, fun he => hy.2 (congrArg Sum.inr he)⟩))).val) + = Sum.inl ((stepIdent (n + 1)).symm w) + refine congrArg Sum.inl (Fin.ext ?_) + set c : Fin (0 + n) := (stepIdent n).symm (rightRemoveEquiv n 0 + ⟨w, fun he => hy.2 (congrArg Sum.inr he)⟩) with hc + have hcw : (c : ℕ) = (w : ℕ) := by + have h := rightRemoveEquiv_val n 0 + ⟨w, fun he => hy.2 (congrArg Sum.inr he)⟩ + rw [ite_eq_left hw] at h + change ((rightRemoveEquiv n 0 + ⟨w, fun he => hy.2 (congrArg Sum.inr he)⟩ : Fin (n + 0)) : ℕ) + = (w : ℕ) + exact h + set z := (finRemoveEquiv + (⟨0 + n, Nat.lt_succ_self _⟩ : Fin (0 + n + 1))).symm c with hz + have hzc : (finRemoveEquiv + (⟨0 + n, Nat.lt_succ_self _⟩ : Fin (0 + n + 1)) z : ℕ) + = (c : ℕ) := by rw [hz, Equiv.apply_symm_apply] + have hval := finRemoveEquiv_top_val (n := 0 + n) z + rw [hzc] at hval + have : (((stepIdent (n + 1)).symm w : Fin (0 + n + 1)) : ℕ) + = (w : ℕ) := rfl + rw [this] + omega + +/-- **The recursion's cut pair are interface partners**, which is +what makes the glue contract the interface matching rather than +merge two of its arcs. -/ +theorem interfaceSwap_cut (n : ℕ) : + interfaceSwap (stepIdent (n + 1)) + (Sum.inl ⟨0 + n, Nat.lt_succ_self _⟩) + = Sum.inr (⟨n, by omega⟩ : Fin (n + 1 + 0)) := by + refine congrArg Sum.inr (Fin.ext ?_) + change (0 + n : ℕ) = n + omega + +end InterfaceStep + +/-! ## The closed top + +At the empty interface there are no labels, hence no through edges, +and the through-edge product the flag model carries is one. That is +where RS21's `s_h(G,H)` and the flag model's summand meet. +-/ + +section ClosedTop + +variable {L : Type} + +/-- A closed fragment has no through flags: every flag meets a +vertex. -/ +theorem throughFlags_isEmpty [IsEmpty L] {V : Fragment L} + (F : EdgeSubset V) : + F.throughFlags = ∅ := by + refine Finset.eq_empty_of_forall_notMem (fun f hf => ?_) + obtain ⟨-, ⟨i, -⟩, -⟩ := mem_throughFlags_iff.mp hf + exact isEmptyElim i + +/-- At the closed top every flag is internal: there are no labels to +attach to. -/ +theorem allInternal_isEmpty [IsEmpty L] {V : Fragment L} + (F : EdgeSubset V) : F.allInternal := by + classical + refine Finset.eq_empty_of_forall_notMem (fun f hf => ?_) + obtain ⟨-, i, -⟩ := Finset.mem_filter.mp hf + exact isEmptyElim i + +/-- **The chord sign is trivial at the closed top.** There are no +labels, hence no chords to cross. -/ +theorem pathSign_isEmpty [LinearOrder L] [IsEmpty L] {V : Fragment L} + (F : EdgeSubset V) + (κ : F.RelTransitionSystem) : pathSign κ = 1 := + pathSign_of_allInternal (allInternal_isEmpty F) κ + +open Classical in +/-- **The closed top's value is RS21's `s_h(G,H)`**: the circuit sign +times the colouring sum, with no chord sign and no through-edge +product. -/ +theorem throughValueC_isEmpty [LinearOrder L] [IsEmpty L] {V : Fragment L} + {k ℓ : ℕ} (F : EdgeSubset V) + (h : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ L) + (hbnd : genBoundarySubsetMatches V F.flags st) + (hne : Nonempty F.CanonData) : + F.throughValueC h st hbnd + = F.throughSummand h st hbnd (Classical.choice hne).2.val + ((Classical.choice hne).1.openCircuitCount) := by + unfold EdgeSubset.throughValueC + rw [dite_eq_left hne, pathSign_isEmpty, one_mul] + +open Classical in +/-- **The closed top's partition value is a sum of RS21's +summands.** With no labels the chord sign is one and the +through-edge product is one, so each Eulerian subset contributes its +circuit sign times its colouring sum — RS21's `s_h(G,H)`. -/ +theorem throughMixedPartitionC_isEmpty + [LinearOrder L] [IsEmpty L] {V : Fragment L} + {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ L) : + throughMixedPartitionC h V st + = ((k : ℂ) - 2 * ℓ) ^ V.circles * + ∑ s : Finset V.Flag, + if hc : ∀ f ∈ s, V.pairing f ∈ s then + if hbnd : genBoundarySubsetMatches V s st then + if (EdgeSubset.mk s hc).Eulerian then + if hne : Nonempty (EdgeSubset.mk s hc).CanonData then + (EdgeSubset.mk s hc).throughSummand h st hbnd + (Classical.choice hne).2.val + ((Classical.choice hne).1.openCircuitCount) + else 0 + else 0 + else 0 + else 0 := by + unfold throughMixedPartitionC + refine congrArg₂ (· * ·) rfl (Finset.sum_congr rfl (fun s _ => ?_)) + by_cases hc : ∀ f ∈ s, V.pairing f ∈ s + · rw [dite_eq_left hc, dite_eq_left hc] + by_cases hbnd : genBoundarySubsetMatches V s st + · rw [dite_eq_left hbnd, dite_eq_left hbnd] + by_cases hE : (EdgeSubset.mk s hc).Eulerian + · rw [ite_eq_left hE, ite_eq_left hE] + by_cases hne : Nonempty (EdgeSubset.mk s hc).CanonData + · rw [dite_eq_left hne] + exact throughValueC_isEmpty _ h st hbnd hne + · rw [dite_eq_right hne] + unfold EdgeSubset.throughValueC + rw [dite_eq_right hne] + · rw [ite_eq_right hE, ite_eq_right hE] + · rw [dite_eq_right hbnd, dite_eq_right hbnd] + · rw [dite_eq_right hc, dite_eq_right hc] + +/-- **The through-edge product is one at the closed top.** -/ +theorem throughProduct_isEmpty [LinearOrder L] [IsEmpty L] {V : Fragment L} + {k ℓ : ℕ} (F : EdgeSubset V) + (st : GenBoundaryState k ℓ L) : F.throughProduct st = 1 := by + unfold EdgeSubset.throughProduct + rw [throughFlags_isEmpty F] + rfl + +end ClosedTop + +/-! ## The union at a disjoint union + +At the start of the interface recursion the fragment is a disjoint +union, its two boundary halves are the two fragments' own labels, and +its chord matching is the two fragments' chord matchings side by +side. So the union of the chord matching with the interface matching +is RS21's own union `M(ω₁,κ₁) ∪ M(ω₂,κ₂)`, read on one copy of the +label set through the interface identification — which is the form +Lemma 11 for a composition consumes. +-/ + +section DisjUnionCut + +variable {α β : Type} + +/-- The used labels of the left half. -/ +def usedLeftEquiv + {W₁ : Fragment α} {W₂ : Fragment β} (F : EdgeSubset (W₁.disjUnion W₂)) : + {a : α // + (W₁.disjUnion W₂).boundaryFlag (Sum.inl a) ∈ F.boundaryFlags} + ≃ UsedLab (leftSub F) := + Equiv.subtypeEquivRight (fun _ => inl_mem_boundary) + +/-- The used labels of the right half. -/ +def usedRightEquiv + {W₁ : Fragment α} {W₂ : Fragment β} (F : EdgeSubset (W₁.disjUnion W₂)) : + {b : β // + (W₁.disjUnion W₂).boundaryFlag (Sum.inr b) ∈ F.boundaryFlags} + ≃ UsedLab (rightSub F) := + Equiv.subtypeEquivRight (fun _ => inr_mem_boundary) + +/-- The used labels of a disjoint union, split into the two sides' +own. -/ +def usedDisjUnionEquiv + {W₁ : Fragment α} {W₂ : Fragment β} (F : EdgeSubset (W₁.disjUnion W₂)) : + UsedLab F ≃ UsedLab (leftSub F) ⊕ UsedLab (rightSub F) := + (usedSideEquiv F).trans + (Equiv.sumCongr (usedLeftEquiv F) (usedRightEquiv F)) + +/-- **The chord of a left label is the left side's chord.** -/ +theorem chordInv_prodRel_inl + [LinearOrder α] [LinearOrder β] {W₁ : Fragment α} {W₂ : Fragment β} + (F : EdgeSubset (W₁.disjUnion W₂)) + (κ₁ : (leftSub F).RelTransitionSystem) + (κ₂ : (rightSub F).RelTransitionSystem) {a : α} + (hb : (W₁.disjUnion W₂).boundaryFlag (Sum.inl a) + ∈ F.boundaryFlags) : + chordInv F (prodRel κ₁ κ₂) (Sum.inl a) + = Sum.inl (chordInv (leftSub F) κ₁ a) := by + have hb' : W₁.boundaryFlag a ∈ (leftSub F).boundaryFlags := + inl_mem_boundary.mp hb + refine (W₁.disjUnion W₂).boundaryFlag_injective ?_ + rw [boundaryFlag_chordInv F (prodRel κ₁ κ₂) hb] + change (prodRel κ₁ κ₂).pathMatch (Sum.inl (W₁.boundaryFlag a)) hb + = Sum.inl (W₁.boundaryFlag (chordInv (leftSub F) κ₁ a)) + rw [pathMatch_prodRel_inl κ₁ κ₂ hb hb', + boundaryFlag_chordInv (leftSub F) κ₁ hb'] + +/-- **The chord of a right label is the right side's chord.** -/ +theorem chordInv_prodRel_inr + [LinearOrder α] [LinearOrder β] {W₁ : Fragment α} {W₂ : Fragment β} + (F : EdgeSubset (W₁.disjUnion W₂)) + (κ₁ : (leftSub F).RelTransitionSystem) + (κ₂ : (rightSub F).RelTransitionSystem) {b : β} + (hb : (W₁.disjUnion W₂).boundaryFlag (Sum.inr b) + ∈ F.boundaryFlags) : + chordInv F (prodRel κ₁ κ₂) (Sum.inr b) + = Sum.inr (chordInv (rightSub F) κ₂ b) := by + have hb' : W₂.boundaryFlag b ∈ (rightSub F).boundaryFlags := + inr_mem_boundary.mp hb + refine (W₁.disjUnion W₂).boundaryFlag_injective ?_ + rw [boundaryFlag_chordInv F (prodRel κ₁ κ₂) hb] + change (prodRel κ₁ κ₂).pathMatch (Sum.inr (W₂.boundaryFlag b)) hb + = Sum.inr (W₂.boundaryFlag (chordInv (rightSub F) κ₂ b)) + rw [pathMatch_prodRel_inr κ₁ κ₂ hb hb', + boundaryFlag_chordInv (rightSub F) κ₂ hb'] + +/-- **The chord matching of a disjoint union is the two sides' chord +matchings, side by side.** -/ +theorem cutMatching_disjUnion_edge + [LinearOrder α] [LinearOrder β] [LinearOrder (α ⊕ β)] {W₁ : Fragment α} + {W₂ : Fragment β} (F : EdgeSubset (W₁.disjUnion W₂)) + (κ₁ : (leftSub F).RelTransitionSystem) + (κ₂ : (rightSub F).RelTransitionSystem) + (o₁ : κ₁.Orientation) (o₂ : κ₂.Orientation) : + ((cutMatching F (prodRel κ₁ κ₂) (prodOrient o₁ o₂)).map + (usedDisjUnionEquiv F)).edge + = (DirMatching.sumMatching (cutMatching (leftSub F) κ₁ o₁) + (cutMatching (rightSub F) κ₂ o₂)).edge := by + funext x + rcases x with a | b + · have hb : (W₁.disjUnion W₂).boundaryFlag (Sum.inl a.val) + ∈ F.boundaryFlags := inl_mem_boundary.mpr a.prop + have hy : (cutMatching F (prodRel κ₁ κ₂) + (prodOrient o₁ o₂)).edge + ((usedDisjUnionEquiv F).symm (Sum.inl a)) + = ⟨Sum.inl (chordInv (leftSub F) κ₁ a.val), by + rw [← chordInv_prodRel_inl F κ₁ κ₂ hb] + exact chordInv_mem F (prodRel κ₁ κ₂) hb⟩ := + Subtype.ext (chordInv_prodRel_inl F κ₁ κ₂ hb) + change usedDisjUnionEquiv F ((cutMatching F (prodRel κ₁ κ₂) + (prodOrient o₁ o₂)).edge + ((usedDisjUnionEquiv F).symm (Sum.inl a))) = _ + rw [hy] + rfl + · have hb : (W₁.disjUnion W₂).boundaryFlag (Sum.inr b.val) + ∈ F.boundaryFlags := inr_mem_boundary.mpr b.prop + have hy : (cutMatching F (prodRel κ₁ κ₂) + (prodOrient o₁ o₂)).edge + ((usedDisjUnionEquiv F).symm (Sum.inr b)) + = ⟨Sum.inr (chordInv (rightSub F) κ₂ b.val), by + rw [← chordInv_prodRel_inr F κ₁ κ₂ hb] + exact chordInv_mem F (prodRel κ₁ κ₂) hb⟩ := + Subtype.ext (chordInv_prodRel_inr F κ₁ κ₂ hb) + change usedDisjUnionEquiv F ((cutMatching F (prodRel κ₁ κ₂) + (prodOrient o₁ o₂)).edge + ((usedDisjUnionEquiv F).symm (Sum.inr b))) = _ + rw [hy] + rfl + +/-- The interface identification, read on the two sides' own used +labels. -/ +def interfaceSideDisjEquiv + {W₁ : Fragment α} {W₂ : Fragment β} (F : EdgeSubset (W₁.disjUnion W₂)) + (e : α ≃ β) + (hp : InterfacePaired F e) : + UsedLab (leftSub F) ≃ UsedLab (rightSub F) := + (usedLeftEquiv F).symm.trans + ((interfaceSideEquiv F e hp).trans (usedRightEquiv F)) + +/-- The interface identification on the two sides' used labels, as +an order isomorphism when the identification is one. -/ +def interfaceSideDisjOrderIso + [LinearOrder α] [LinearOrder β] {W₁ : Fragment α} {W₂ : Fragment β} + (F : EdgeSubset (W₁.disjUnion W₂)) + (E : α ≃o β) + (hp : InterfacePaired F E.toEquiv) : + UsedLab (leftSub F) ≃o UsedLab (rightSub F) where + toEquiv := interfaceSideDisjEquiv F E.toEquiv hp + map_rel_iff' := E.map_rel_iff + +/-- **The interface matching of a disjoint union is the interface +identification, read on the two sides' used labels.** -/ +theorem interfaceCut_disjUnion_edge + {W₁ : Fragment α} {W₂ : Fragment β} (F : EdgeSubset (W₁.disjUnion W₂)) + (e : α ≃ β) + (hp : InterfacePaired F e) : + ((interfaceCut F e hp).map (usedDisjUnionEquiv F)).edge + = (DirMatching.interfaceEquivMatching + (interfaceSideDisjEquiv F e hp)).edge := by + funext x + rcases x with a | b + · rfl + · rfl + +/-- **The colouring sum splits over a disjoint union.** RS21's +`∏_{v ∈ V′(F₁∗F₂)}` is `∏_{v ∈ V′(F₁)} ∏_{v ∈ V′(F₂)}`, and at a +fixed interface colouring the two sides' sums are independent. -/ +theorem vertexSum_disjUnion {W₁ : Fragment α} {W₂ : Fragment β} + (F : EdgeSubset (W₁.disjUnion W₂)) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ (α ⊕ β)) + (hbnd : genBoundarySubsetMatches (W₁.disjUnion W₂) F.flags st) + (hbnd₁ : genBoundarySubsetMatches W₁ (leftSub F).flags + (fun a => st (Sum.inl a))) + (hbnd₂ : genBoundarySubsetMatches W₂ (rightSub F).flags + (fun b => st (Sum.inr b))) + {κ₁ : (leftSub F).RelTransitionSystem} + {κ₂ : (rightSub F).RelTransitionSystem} + (o₁ : κ₁.Orientation) (o₂ : κ₂.Orientation) : + F.vertexSum h st hbnd (prodOrient o₁ o₂) + = (leftSub F).vertexSum h (fun a => st (Sum.inl a)) hbnd₁ o₁ + * (rightSub F).vertexSum h (fun b => st (Sum.inr b)) hbnd₂ + o₂ := + colouringSum_split h st hbnd hbnd₁ hbnd₂ o₁ o₂ + +/-- **RS21's union, at the start of the recursion.** The union of a +disjoint union's chord matching with its interface matching counts +what the two fragments' own chord matchings count, identified along +the interface. -/ +theorem unionCount_cutMatching_disjUnion + [LinearOrder α] [LinearOrder β] [Fintype α] [Fintype β] + [LinearOrder (α ⊕ β)] {W₁ : Fragment α} {W₂ : Fragment β} + (F : EdgeSubset (W₁.disjUnion W₂)) (e : α ≃ β) + (κ₁ : (leftSub F).RelTransitionSystem) + (κ₂ : (rightSub F).RelTransitionSystem) + (o₁ : κ₁.Orientation) (o₂ : κ₂.Orientation) + (hp : InterfacePaired F e) : + DirMatching.unionCount + (cutMatching F (prodRel κ₁ κ₂) (prodOrient o₁ o₂)) + (interfaceCut F e hp) + = DirMatching.unionCount (cutMatching (leftSub F) κ₁ o₁) + ((cutMatching (rightSub F) κ₂ o₂).map + (interfaceSideDisjEquiv F e hp).symm) := by + classical + rw [← DirMatching.unionCount_map (usedDisjUnionEquiv F) + (cutMatching F (prodRel κ₁ κ₂) (prodOrient o₁ o₂)) + (interfaceCut F e hp), + DirMatching.unionCount_congr + (cutMatching_disjUnion_edge F κ₁ κ₂ o₁ o₂) + (interfaceCut_disjUnion_edge F e hp), + DirMatching.unionCount_sumMatching (interfaceSideDisjEquiv F e hp)] + +end DisjUnionCut + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceOrderIso.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceOrderIso.lean new file mode 100644 index 0000000000..81d0075e30 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceOrderIso.lean @@ -0,0 +1,276 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SumLexOrder + +/-! +# Monotonicity of the interface re-indexing equivalences + +The gluing chain transports corrected constrained values along +label re-indexings; the through-factor is orientation-antisymmetric, +so only monotone relabelings preserve the corrected value. This +file certifies the chain's equivalences as order isomorphisms for +the lexicographic order on sums: + +* `finSumFinOrderIso`: `finSumFinEquiv` as an order isomorphism; +* `interfaceStepOrderIso`: the label re-indexing after gluing the + top interface pair, as an order isomorphism; +* application lemmas (`interfaceStepEquiv_apply_inl`, + `interfaceStepEquiv_apply_inr`) letting the chain rewrite states + through the isos concretely, on top of the removals' value + computations in `Composition.lean`. + +**Instance discipline.** Mathlib carries a global `Preorder (α ⊕ β)` +(the disjoint order, where `inl` and `inr` are incomparable), so a +`letI := sumLexLinearOrder α β` does *not* reliably route `<`/`≤` +notation to the lexicographic order — instance search can still pick +the global disjoint order. Every statement here therefore pins the +sum orders explicitly through the reducible aliases +`sumLexPreorder`/`sumLexLE`/`sumLexSubtypeLinearOrder`/… below, +which are definitionally the projections of `sumLexLinearOrder`. +-/ + +@[expose] public section + +namespace RS + +/-! ### Pinned instances for the lexicographic sum order -/ + +section InstanceAliases + +variable (α β : Type) + +/-- The lexicographic preorder on a plain sum, as an explicit term +(never registered as an instance): pin it with `@` in statements. -/ +abbrev sumLexPreorder [LinearOrder α] [LinearOrder β] : Preorder (α ⊕ β) := + (sumLexLinearOrder α β).toPartialOrder.toPreorder + +/-- The lexicographic `≤` on a plain sum, as an explicit term. -/ +abbrev sumLexLE [LinearOrder α] [LinearOrder β] : LE (α ⊕ β) := + (sumLexPreorder α β).toLE + +/-- The linear order induced on a subtype of the lexicographically +ordered sum. -/ +abbrev sumLexSubtypeLinearOrder [LinearOrder α] [LinearOrder β] + (p : α ⊕ β → Prop) : + LinearOrder (Subtype p) := + @Subtype.instLinearOrder _ (sumLexLinearOrder α β) p + +/-- The preorder induced on a subtype of the lexicographically +ordered sum. -/ +abbrev sumLexSubtypePreorder [LinearOrder α] [LinearOrder β] + (p : α ⊕ β → Prop) : + Preorder (Subtype p) := + (sumLexSubtypeLinearOrder α β p).toPartialOrder.toPreorder + +/-- The `≤` induced on a subtype of the lexicographically ordered +sum. -/ +abbrev sumLexSubtypeLE [LinearOrder α] [LinearOrder β] + (p : α ⊕ β → Prop) : LE (Subtype p) := + (sumLexSubtypePreorder α β p).toLE + +end InstanceAliases + +/-! ### Strictly monotone equivalences of linear orders -/ + +section StrictMonoEquiv + +variable {α β : Type} + +/-- The inverse of a strictly monotone equivalence between linear +orders is strictly monotone. -/ +theorem strictMono_equiv_symm [LinearOrder α] [LinearOrder β] + (e : α ≃ β) (h : StrictMono e) : + StrictMono e.symm := by + intro b b' hbb + rcases lt_trichotomy (e.symm b) (e.symm b') with h1 | h1 | h1 + · exact h1 + · exfalso + have h2 : b = b' := by + have h3 := congrArg e h1 + rwa [e.apply_symm_apply, e.apply_symm_apply] at h3 + exact absurd h2 (ne_of_lt hbb) + · exfalso + have h2 := h h1 + rw [e.apply_symm_apply, e.apply_symm_apply] at h2 + exact lt_asymm hbb h2 + +/-- A strictly monotone equivalence between linear orders, as an +order isomorphism (keeping the underlying equivalence on the +nose). -/ +def orderIsoOfStrictMonoEquiv [LinearOrder α] [LinearOrder β] + (e : α ≃ β) (h : StrictMono e) : + α ≃o β := + e.toOrderIso h.monotone (strictMono_equiv_symm e h).monotone + +/-- The order isomorphism built from a strictly monotone equivalence +acts as that equivalence. -/ +@[simp] theorem orderIsoOfStrictMonoEquiv_apply [LinearOrder α] [LinearOrder β] + (e : α ≃ β) + (h : StrictMono e) (x : α) : + orderIsoOfStrictMonoEquiv e h x = e x := rfl + +/-- And carries it as its underlying equivalence. -/ +@[simp] theorem orderIsoOfStrictMonoEquiv_toEquiv + [LinearOrder α] [LinearOrder β] + (e : α ≃ β) + (h : StrictMono e) : + (orderIsoOfStrictMonoEquiv e h).toEquiv = e := rfl + +end StrictMonoEquiv + +/-! ### `finSumFinEquiv` is monotone for the lexicographic order -/ + +/-- `finSumFinEquiv` is strictly monotone for the lexicographic sum +order: it lays the left block below the right. -/ +theorem finSumFinEquiv_strictMono (m n : ℕ) : + @StrictMono _ _ (sumLexPreorder (Fin m) (Fin n)) _ + (finSumFinEquiv : Fin m ⊕ Fin n → Fin (m + n)) := by + intro x y hxy + cases x with + | inl a => + cases y with + | inl a' => + have ha : a < a' := sumLex_inl_lt_inl_iff.mp hxy + rw [finSumFinEquiv_apply_left, finSumFinEquiv_apply_left] + exact Fin.strictMono_castAdd n ha + | inr b => + rw [finSumFinEquiv_apply_left, finSumFinEquiv_apply_right] + have ha : (a : ℕ) < m := a.isLt + change (a : ℕ) < m + (b : ℕ) + omega + | inr b => + cases y with + | inl a' => exact absurd hxy (sumLex_not_inr_lt_inl a' b) + | inr b' => + have hb : b < b' := sumLex_inr_lt_inr_iff.mp hxy + rw [finSumFinEquiv_apply_right, finSumFinEquiv_apply_right] + exact Fin.strictMono_natAdd m hb + +/-- `finSumFinEquiv` as an order isomorphism for the lexicographic +order on `Fin m ⊕ Fin n`. -/ +def finSumFinOrderIso (m n : ℕ) : + @OrderIso (Fin m ⊕ Fin n) (Fin (m + n)) + (sumLexLE (Fin m) (Fin n)) _ := + @orderIsoOfStrictMonoEquiv _ _ (sumLexLinearOrder (Fin m) (Fin n)) _ + finSumFinEquiv (finSumFinEquiv_strictMono m n) + +/-- The order isomorphism acts as `finSumFinEquiv`. -/ +@[simp] theorem finSumFinOrderIso_apply (m n : ℕ) (x : Fin m ⊕ Fin n) : + finSumFinOrderIso m n x = finSumFinEquiv x := rfl + +/-- And carries it as its underlying equivalence. -/ +@[simp] theorem finSumFinOrderIso_toEquiv (m n : ℕ) : + (finSumFinOrderIso m n).toEquiv = finSumFinEquiv := rfl + +/-! ### The removal equivalences are strictly monotone -/ + +/-- Reinstating a removed point is strictly monotone: `succAbove` +shifts indices up without reordering them. -/ +theorem finRemoveEquiv_symm_strictMono {n : ℕ} (a : Fin (n + 1)) : + StrictMono (finRemoveEquiv a).symm := by + intro y y' h + change a.succAbove y < a.succAbove y' + exact Fin.strictMono_succAbove a h + +/-- Hence removing a point is too. -/ +theorem finRemoveEquiv_strictMono {n : ℕ} (a : Fin (n + 1)) : + StrictMono (finRemoveEquiv a) := + strictMono_equiv_symm (finRemoveEquiv a).symm + (finRemoveEquiv_symm_strictMono a) + +/-- Removing label `t` on the right is strictly monotone. -/ +theorem rightRemoveEquiv_strictMono (t u : ℕ) : + StrictMono (rightRemoveEquiv t u) := by + intro x y hxy + exact finRemoveEquiv_strictMono _ hxy + +/-! ### The interface step is an order isomorphism -/ + +/-- The step re-indexing on a surviving left label: the left +removal, injected. -/ +theorem interfaceStepEquiv_apply_inl (s t u : ℕ) (v : Fin (s + t + 1)) + (h : (Sum.inl v : Fin (s + t + 1) ⊕ Fin (t + 1 + u)) ≠ + Sum.inl ⟨s + t, Nat.lt_succ_self _⟩ ∧ + (Sum.inl v : Fin (s + t + 1) ⊕ Fin (t + 1 + u)) ≠ + Sum.inr ⟨t, by omega⟩) : + interfaceStepEquiv s t u ⟨Sum.inl v, h⟩ = + Sum.inl (finRemoveEquiv ⟨s + t, Nat.lt_succ_self _⟩ + ⟨v, fun he => h.1 (congrArg Sum.inl he)⟩) := rfl + +/-- The step re-indexing on a surviving right label: the right +removal, injected. -/ +theorem interfaceStepEquiv_apply_inr (s t u : ℕ) (w : Fin (t + 1 + u)) + (h : (Sum.inr w : Fin (s + t + 1) ⊕ Fin (t + 1 + u)) ≠ + Sum.inl ⟨s + t, Nat.lt_succ_self _⟩ ∧ + (Sum.inr w : Fin (s + t + 1) ⊕ Fin (t + 1 + u)) ≠ + Sum.inr ⟨t, by omega⟩) : + interfaceStepEquiv s t u ⟨Sum.inr w, h⟩ = + Sum.inr (rightRemoveEquiv t u + ⟨w, fun he => h.2 (congrArg Sum.inr he)⟩) := rfl + +/-- **The step re-indexing is strictly monotone** for the +lexicographic order: left labels stay below right ones and each +block's removal preserves order. This is what lets the gluing chain +carry corrected values, the through-factor being +orientation-antisymmetric. -/ +theorem interfaceStepEquiv_strictMono (s t u : ℕ) : + @StrictMono _ _ + (sumLexSubtypePreorder (Fin (s + t + 1)) (Fin (t + 1 + u)) + (fun x => x ≠ Sum.inl ⟨s + t, Nat.lt_succ_self _⟩ ∧ + x ≠ Sum.inr ⟨t, by omega⟩)) + (sumLexPreorder (Fin (s + t)) (Fin (t + u))) + (interfaceStepEquiv s t u) := by + rintro ⟨xv, hx⟩ ⟨yv, hy⟩ hxy + cases xv with + | inl v => + cases yv with + | inl v' => + have hv : v < v' := sumLex_inl_lt_inl_iff.mp hxy + rw [interfaceStepEquiv_apply_inl, interfaceStepEquiv_apply_inl] + exact sumLex_inl_lt_inl_iff.mpr (finRemoveEquiv_strictMono _ hv) + | inr w' => + rw [interfaceStepEquiv_apply_inl, interfaceStepEquiv_apply_inr] + exact sumLex_inl_lt_inr _ _ + | inr w => + cases yv with + | inl v' => exact absurd hxy (sumLex_not_inr_lt_inl v' w) + | inr w' => + have hw : w < w' := sumLex_inr_lt_inr_iff.mp hxy + rw [interfaceStepEquiv_apply_inr, interfaceStepEquiv_apply_inr] + exact sumLex_inr_lt_inr_iff.mpr + (rightRemoveEquiv_strictMono t u hw) + +/-- The interface-step re-indexing (`interfaceStepEquiv`) as an +order isomorphism for the lexicographic orders. -/ +noncomputable def interfaceStepOrderIso (s t u : ℕ) : + @OrderIso + {x : Fin (s + t + 1) ⊕ Fin (t + 1 + u) // + x ≠ Sum.inl ⟨s + t, Nat.lt_succ_self _⟩ ∧ + x ≠ Sum.inr ⟨t, by omega⟩} + (Fin (s + t) ⊕ Fin (t + u)) + (sumLexSubtypeLE (Fin (s + t + 1)) (Fin (t + 1 + u)) _) + (sumLexLE (Fin (s + t)) (Fin (t + u))) := + @orderIsoOfStrictMonoEquiv _ _ + (sumLexSubtypeLinearOrder (Fin (s + t + 1)) (Fin (t + 1 + u)) _) + (sumLexLinearOrder (Fin (s + t)) (Fin (t + u))) + (interfaceStepEquiv s t u) (interfaceStepEquiv_strictMono s t u) + +/-- The step order isomorphism acts as the step equivalence. -/ +@[simp] theorem interfaceStepOrderIso_apply (s t u : ℕ) + (x : {x : Fin (s + t + 1) ⊕ Fin (t + 1 + u) // + x ≠ Sum.inl ⟨s + t, Nat.lt_succ_self _⟩ ∧ + x ≠ Sum.inr ⟨t, by omega⟩}) : + interfaceStepOrderIso s t u x = interfaceStepEquiv s t u x := rfl + +/-- And carries it as its underlying equivalence. -/ +@[simp] theorem interfaceStepOrderIso_toEquiv (s t u : ℕ) : + (interfaceStepOrderIso s t u).toEquiv = interfaceStepEquiv s t u := + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceShift.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceShift.lean new file mode 100644 index 0000000000..a074bbe504 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceShift.lean @@ -0,0 +1,451 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc + +/-! +# The interface shift + +Permuting the outgoing boundary of the left factor of a +composition is the same as permuting the incoming boundary of the +right factor by the inverse (`interfaceShift`): both sides glue +`F`'s high label `s + j` to `G`'s low label `σ j`, merely +enumerating the interface in different orders. This is the +engine of the permutation calculus of §3.1: strand fragments +compose by composing their permutations. +-/ + +@[expose] public section + +namespace RS + +/-- The permuted interface pairs: `F`'s high label `s + j` +against `G`'s low label `σ j`, top pair first. -/ +noncomputable def shiftPairs (s : ℕ) {t : ℕ} + (σ : Equiv.Perm (Fin t)) (u : ℕ) : + List ((Fin (s + t) ⊕ Fin (t + u)) × + (Fin (s + t) ⊕ Fin (t + u))) := + (List.finRange t).reverse.map (fun k => + (Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩, + Sum.inr ⟨(σ k).val, by have := (σ k).isLt; omega⟩)) + +/-- The permuted interface pairs are a permutation of the +`σ`-precomposed enumeration. -/ +theorem shiftPairs_perm (s : ℕ) {t : ℕ} + (σ τ : Equiv.Perm (Fin t)) (u : ℕ) : + ((List.finRange t).reverse.map (fun k => + ((Sum.inl ⟨s + (τ k).val, by have := (τ k).isLt; omega⟩ : + Fin (s + t) ⊕ Fin (t + u)), + Sum.inr ⟨(σ (τ k)).val, + by have := (σ (τ k)).isLt; omega⟩))).Perm + (shiftPairs s σ u) := by + unfold shiftPairs + have h1 : ((List.finRange t).reverse.map τ).Perm + (List.finRange t).reverse := + ((List.reverse_perm (List.finRange t)).map τ).trans + ((Equiv.Perm.map_finRange_perm τ).trans + (List.reverse_perm _).symm) + have h2 := h1.map (fun k : Fin t => + ((Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩ : + Fin (s + t) ⊕ Fin (t + u)), + (Sum.inr ⟨(σ k).val, by have := (σ k).isLt; omega⟩ : + Fin (s + t) ⊕ Fin (t + u)))) + rw [List.map_map] at h2 + exact h2 + +/-- The inverse outgoing permutation on high labels. -/ +theorem outPermEquiv_symm_high (s : ℕ) {t : ℕ} + (σ : Equiv.Perm (Fin t)) (k : Fin t) : + (outPermEquiv s σ).symm (Fin.natAdd s k) = + Fin.natAdd s (σ.symm k) := + (_root_.Equiv.symm_apply_eq _).mpr + ((outPermEquiv_high s σ (σ.symm k)).trans + (congrArg (Fin.natAdd s) (σ.apply_symm_apply k))).symm + +/-- The inverse incoming permutation on low labels. -/ +theorem inPermEquiv_symm_low {t : ℕ} (σ : Equiv.Perm (Fin t)) + (u : ℕ) (k : Fin t) : + (inPermEquiv σ u).symm (Fin.castAdd u k) = + Fin.castAdd u (σ.symm k) := + (_root_.Equiv.symm_apply_eq _).mpr + ((inPermEquiv_low σ u (σ.symm k)).trans + (congrArg (Fin.castAdd u) (σ.apply_symm_apply k))).symm + +/-- The left ground list: pulling the outgoing permutation out +of the interface pairs (generalized over the index list). -/ +private theorem shift_ground_left_aux (s : ℕ) {t : ℕ} + (σ : Equiv.Perm (Fin t)) (u : ℕ) : + ∀ (l : List (Fin t)), + Fragment.mapPairs + (_root_.Equiv.sumCongr (outPermEquiv s σ) + (_root_.Equiv.refl (Fin (t + u)))).symm + (l.map (fun k => + ((Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩ : + Fin (s + t) ⊕ Fin (t + u)), + Sum.inr ⟨k.val, by have := k.isLt; omega⟩))) = + l.map (fun k => + ((Sum.inl ⟨s + (σ.symm k).val, + by have := (σ.symm k).isLt; omega⟩ : + Fin (s + t) ⊕ Fin (t + u)), + Sum.inr ⟨k.val, by have := k.isLt; omega⟩)) + | [] => rfl + | k :: l => by + simp only [List.map_cons, Fragment.mapPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext ?_ rfl) + (shift_ground_left_aux s σ u l) + change Sum.inl ((outPermEquiv s σ).symm ⟨s + k.val, _⟩) = _ + exact congrArg Sum.inl + ((congrArg (outPermEquiv s σ).symm + (show (⟨s + k.val, _⟩ : Fin (s + t)) = + Fin.natAdd s k from Fin.ext rfl)).trans + ((outPermEquiv_symm_high s σ k).trans (Fin.ext rfl))) + +/-- The right ground list: pulling the incoming permutation out +of the interface pairs (generalized over the index list). -/ +private theorem shift_ground_right_aux (s : ℕ) {t : ℕ} + (σ : Equiv.Perm (Fin t)) (u : ℕ) : + ∀ (l : List (Fin t)), + Fragment.mapPairs + (_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (s + t))) + (inPermEquiv σ.symm u)).symm + (l.map (fun k => + ((Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩ : + Fin (s + t) ⊕ Fin (t + u)), + Sum.inr ⟨k.val, by have := k.isLt; omega⟩))) = + l.map (fun k => + ((Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩ : + Fin (s + t) ⊕ Fin (t + u)), + Sum.inr ⟨(σ k).val, by have := (σ k).isLt; omega⟩)) + | [] => rfl + | k :: l => by + simp only [List.map_cons, Fragment.mapPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext rfl ?_) + (shift_ground_right_aux s σ u l) + change Sum.inr ((inPermEquiv σ.symm u).symm ⟨k.val, _⟩) = _ + exact congrArg Sum.inr + ((congrArg (inPermEquiv σ.symm u).symm + (show (⟨k.val, _⟩ : Fin (t + u)) = + Fin.castAdd u k from Fin.ext rfl)).trans + ((inPermEquiv_symm_low σ.symm u k).trans + ((congrArg (Fin.castAdd u) + (rfl : σ.symm.symm k = σ.symm.symm k)).trans + (Fin.ext rfl)))) + +/-- The right ground list is the permuted interface. -/ +theorem shift_ground_right (s : ℕ) {t : ℕ} + (σ : Equiv.Perm (Fin t)) (u : ℕ) : + Fragment.mapPairs + (_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (s + t))) + (inPermEquiv σ.symm u)).symm + (interfacePairs s t u) = shiftPairs s σ u := + shift_ground_right_aux s σ u (List.finRange t).reverse + +/-- The left ground list, in enumerated form. -/ +theorem shift_ground_left (s : ℕ) {t : ℕ} + (σ : Equiv.Perm (Fin t)) (u : ℕ) : + Fragment.mapPairs + (_root_.Equiv.sumCongr (outPermEquiv s σ) + (_root_.Equiv.refl (Fin (t + u)))).symm + (interfacePairs s t u) = + (List.finRange t).reverse.map (fun k => + ((Sum.inl ⟨s + (σ.symm k).val, + by have := (σ.symm k).isLt; omega⟩ : + Fin (s + t) ⊕ Fin (t + u)), + Sum.inr ⟨k.val, by have := k.isLt; omega⟩)) := + shift_ground_left_aux s σ u (List.finRange t).reverse + +/-- The left ground list is a permutation of the permuted +interface. -/ +theorem shift_ground_left_perm (s : ℕ) {t : ℕ} + (σ : Equiv.Perm (Fin t)) (u : ℕ) : + ((List.finRange t).reverse.map (fun k => + ((Sum.inl ⟨s + (σ.symm k).val, + by have := (σ.symm k).isLt; omega⟩ : + Fin (s + t) ⊕ Fin (t + u)), + Sum.inr ⟨k.val, by have := k.isLt; omega⟩))).Perm + (shiftPairs s σ u) := by + have heq : ((List.finRange t).reverse.map (fun k => + ((Sum.inl ⟨s + (σ.symm k).val, + by have := (σ.symm k).isLt; omega⟩ : + Fin (s + t) ⊕ Fin (t + u)), + Sum.inr ⟨k.val, by have := k.isLt; omega⟩))) = + ((List.finRange t).reverse.map (fun k => + ((Sum.inl ⟨s + (σ.symm k).val, + by have := (σ.symm k).isLt; omega⟩ : + Fin (s + t) ⊕ Fin (t + u)), + (Sum.inr ⟨(σ (σ.symm k)).val, + by have := (σ (σ.symm k)).isLt; omega⟩ : + Fin (s + t) ⊕ Fin (t + u))))) := + List.map_congr_left (fun k _ => + Prod.ext rfl (congrArg (fun z : Fin t => + (Sum.inr (⟨z.val, by have := z.isLt; omega⟩ : + Fin (t + u)) : Fin (s + t) ⊕ Fin (t + u))) + (σ.apply_symm_apply k).symm)) + exact heq ▸ shiftPairs_perm s σ σ.symm u + +/-- Membership in the permuted interface pairs. -/ +theorem mem_shiftPairs (s : ℕ) {t : ℕ} (σ : Equiv.Perm (Fin t)) + (u : ℕ) (q) : + q ∈ shiftPairs s σ u ↔ + ∃ k : Fin t, + q = (Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩, + Sum.inr ⟨(σ k).val, by have := (σ k).isLt; omega⟩) := by + unfold shiftPairs + simp only [List.mem_map, List.mem_reverse, List.mem_finRange, + true_and] + exact ⟨fun ⟨k, hk⟩ => ⟨k, hk.symm⟩, fun ⟨k, hk⟩ => ⟨k, hk.symm⟩⟩ + +/-- The permuted interface pairs are well-formed. -/ +theorem shiftPairs_wf (s : ℕ) {t : ℕ} (σ : Equiv.Perm (Fin t)) + (u : ℕ) : Fragment.PairsWF (shiftPairs s σ u) := by + unfold Fragment.PairsWF shiftPairs + rw [List.flatMap_map, List.nodup_flatMap] + refine ⟨fun k _ => by simp, ?_⟩ + rw [List.pairwise_reverse] + refine (List.nodup_finRange t).pairwise_of_forall_ne ?_ + intro k _ j _ hkj x hxj hxk + simp only [List.mem_cons, List.not_mem_nil, or_false] at hxj hxk + rcases hxj with rfl | rfl <;> rcases hxk with h | h + · rw [Sum.inl.injEq, Fin.mk.injEq] at h + exact hkj (Fin.ext (by omega)).symm + · exact Sum.inl_ne_inr h + · exact Sum.inr_ne_inl h + · rw [Sum.inr.injEq, Fin.mk.injEq] at h + exact hkj (σ.injective (Fin.ext h)).symm + +/-- The composed label identification of the shifted left +side. -/ +noncomputable def shiftLabelL (s : ℕ) {t : ℕ} + (σ : Equiv.Perm (Fin t)) (u : ℕ) : + Fragment.FoldSurviving (Fin (s + t) ⊕ Fin (t + u)) + (shiftPairs s σ u) ≃ Fin (s + u) := + ((Fragment.foldSurvivingPermEquiv + (shift_ground_left_perm s σ u)).symm.trans + ((Fragment.foldSurvivingPermEquiv + ((shift_ground_left s σ u) ▸ List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv + (_root_.Equiv.sumCongr (outPermEquiv s σ) + (_root_.Equiv.refl (Fin (t + u)))) + (Fragment.mapPairs + (_root_.Equiv.sumCongr (outPermEquiv s σ) + (_root_.Equiv.refl (Fin (t + u)))).symm + (interfacePairs s t u))).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel + (_root_.Equiv.sumCongr (outPermEquiv s σ) + (_root_.Equiv.refl (Fin (t + u)))) + (interfacePairs s t u)).symm ▸ + List.Perm.refl _)).symm.trans + ((interfaceSurvEquiv s t u).trans finSumFinEquiv))))) + +/-- The composed label identification of the shifted right +side. -/ +noncomputable def shiftLabelR (s : ℕ) {t : ℕ} + (σ : Equiv.Perm (Fin t)) (u : ℕ) : + Fragment.FoldSurviving (Fin (s + t) ⊕ Fin (t + u)) + (shiftPairs s σ u) ≃ Fin (s + u) := + ((Fragment.foldSurvivingPermEquiv + ((shift_ground_right s σ u) ▸ List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv + (_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (s + t))) + (inPermEquiv σ.symm u)) + (Fragment.mapPairs + (_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (s + t))) + (inPermEquiv σ.symm u)).symm + (interfacePairs s t u))).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel + (_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (s + t))) + (inPermEquiv σ.symm u)) + (interfacePairs s t u)).symm ▸ + List.Perm.refl _)).symm.trans + ((interfaceSurvEquiv s t u).trans finSumFinEquiv)))) + +-- Normalising the shifted side chains the glue-list +-- presentation with two relabels. +/-- The shifted left side, normalized. -/ +noncomputable def shiftNormalLeft {s t u : ℕ} + (σ : Equiv.Perm (Fin t)) (F : Fragment (Fin (s + t))) + (G : Fragment (Fin (t + u))) : + ((F.relabel (outPermEquiv s σ)).compose G).Equiv + ((Fragment.glueList (F.disjUnion G) (shiftPairs s σ u) + (shiftPairs_wf s σ u)).relabel (shiftLabelL s σ u)) := by + let scO := _root_.Equiv.sumCongr (outPermEquiv s σ) + (_root_.Equiv.refl (Fin (t + u))) + let gL := Fragment.mapPairs scO.symm (interfacePairs s t u) + let wfgL : Fragment.PairsWF gL := + Fragment.mapPairs_wf scO.symm _ (interfacePairs_wf s t u) + have C2 : (Fragment.glueList (F.disjUnion G) gL wfgL).Equiv + ((Fragment.glueList (F.disjUnion G) (shiftPairs s σ u) + (shiftPairs_wf s σ u)).relabel + ((Fragment.foldSurvivingPermEquiv + (shift_ground_left_perm s σ u)).symm.trans + (Fragment.foldSurvivingPermEquiv + ((shift_ground_left s σ u) ▸ + List.Perm.refl _)).symm)) := + (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (F.disjUnion G) + (shift_ground_left s σ u) wfgL + ((shiftPairs_wf s σ u).perm + (shift_ground_left_perm s σ u).symm) + ((shift_ground_left s σ u) ▸ List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.glueListPerm (F.disjUnion G) + (shift_ground_left_perm s σ u) + ((shiftPairs_wf s σ u).perm + (shift_ground_left_perm s σ u).symm)).trans + (Fragment.Equiv.relabelCongr + (Fragment.glueListProofIrrel (F.disjUnion G) + (shiftPairs s σ u) + (((shiftPairs_wf s σ u).perm + (shift_ground_left_perm s σ u).symm).perm + (shift_ground_left_perm s σ u)) + (shiftPairs_wf s σ u)) + (Fragment.foldSurvivingPermEquiv + (shift_ground_left_perm s σ u)).symm)) + (Fragment.foldSurvivingPermEquiv + ((shift_ground_left s σ u) ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + have CIN := (Fragment.glueListCongr + (Fragment.relabelDisjUnionLeft F G (outPermEquiv s σ)) + (interfacePairs s t u) (interfacePairs_wf s t u)).trans + ((Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv ((F.disjUnion G).relabel scO) + (mapPairs_symm_cancel scO (interfacePairs s t u)).symm + (interfacePairs_wf s t u) + (Fragment.mapPairs_wf scO _ wfgL) + ((mapPairs_symm_cancel scO + (interfacePairs s t u)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.glueListRelabel (F.disjUnion G) scO gL + wfgL).trans + ((Fragment.Equiv.relabelCongr C2 + (Fragment.foldSurvivingMapEquiv scO gL)).trans + (Fragment.Equiv.relabelTrans _ _ _))) + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel scO + (interfacePairs s t u)).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _))) + exact (composeNormal (F.relabel (outPermEquiv s σ)) G).trans + ((Fragment.Equiv.relabelCongr CIN + ((interfaceSurvEquiv s t u).trans finSumFinEquiv)).trans + (Fragment.Equiv.relabelTrans _ _ _)) + +-- As for the left side. +/-- The shifted right side, normalized. -/ +noncomputable def shiftNormalRight {s t u : ℕ} + (σ : Equiv.Perm (Fin t)) (F : Fragment (Fin (s + t))) + (G : Fragment (Fin (t + u))) : + (F.compose (G.relabel (inPermEquiv σ.symm u))).Equiv + ((Fragment.glueList (F.disjUnion G) (shiftPairs s σ u) + (shiftPairs_wf s σ u)).relabel (shiftLabelR s σ u)) := by + let scI := _root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (s + t))) + (inPermEquiv σ.symm u) + let gR := Fragment.mapPairs scI.symm (interfacePairs s t u) + let wfgR : Fragment.PairsWF gR := + Fragment.mapPairs_wf scI.symm _ (interfacePairs_wf s t u) + have C2 : (Fragment.glueList (F.disjUnion G) gR wfgR).Equiv + ((Fragment.glueList (F.disjUnion G) (shiftPairs s σ u) + (shiftPairs_wf s σ u)).relabel + (Fragment.foldSurvivingPermEquiv + ((shift_ground_right s σ u) ▸ + List.Perm.refl _)).symm) := + Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (F.disjUnion G) + (shift_ground_right s σ u) wfgR (shiftPairs_wf s σ u) + ((shift_ground_right s σ u) ▸ List.Perm.refl _)) + have CIN := (Fragment.glueListCongr + (Fragment.relabelDisjUnionRight F G (inPermEquiv σ.symm u)) + (interfacePairs s t u) (interfacePairs_wf s t u)).trans + ((Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv ((F.disjUnion G).relabel scI) + (mapPairs_symm_cancel scI (interfacePairs s t u)).symm + (interfacePairs_wf s t u) + (Fragment.mapPairs_wf scI _ wfgR) + ((mapPairs_symm_cancel scI + (interfacePairs s t u)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.glueListRelabel (F.disjUnion G) scI gR + wfgR).trans + ((Fragment.Equiv.relabelCongr C2 + (Fragment.foldSurvivingMapEquiv scI gR)).trans + (Fragment.Equiv.relabelTrans _ _ _))) + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel scI + (interfacePairs s t u)).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _))) + exact (composeNormal F + (G.relabel (inPermEquiv σ.symm u))).trans + ((Fragment.Equiv.relabelCongr CIN + ((interfaceSurvEquiv s t u).trans finSumFinEquiv)).trans + (Fragment.Equiv.relabelTrans _ _ _)) + +/-- The two shifted label identifications agree: the boundary +permutation only touches interface labels, which do not +survive. -/ +theorem shiftLabel_meet (s : ℕ) {t : ℕ} (σ : Equiv.Perm (Fin t)) + (u : ℕ) : shiftLabelL s σ u = shiftLabelR s σ u := by + refine _root_.Equiv.ext fun x => ?_ + obtain ⟨xv, hxp⟩ := x + rcases xv with a | b + · rcases Nat.lt_or_ge a.val s with ha | ha + · refine Fin.ext ?_ + change ((outPermEquiv s σ) a).val = a.val + exact congrArg Fin.val + ((congrArg (outPermEquiv s σ) + (Fin.ext rfl : a = Fin.castAdd t ⟨a.val, ha⟩)).trans + (outPermEquiv_low s σ ⟨a.val, ha⟩)) + · exfalso + have hk : a.val - s < t := by have := a.isLt; omega + have hmem : _ ∈ shiftPairs s σ u := + (mem_shiftPairs s σ u _).mpr ⟨⟨a.val - s, hk⟩, rfl⟩ + exact (hxp _ hmem).1 + (congrArg Sum.inl + (Fin.ext (show a.val = s + (a.val - s) by omega))) + · rcases Nat.lt_or_ge b.val t with hb | hb + · exfalso + have hmem : _ ∈ shiftPairs s σ u := + (mem_shiftPairs s σ u _).mpr ⟨σ.symm ⟨b.val, hb⟩, rfl⟩ + exact (hxp _ hmem).2 + (congrArg Sum.inr + (Fin.ext (show b.val = + (σ (σ.symm ⟨b.val, hb⟩)).val from + congrArg Fin.val + (σ.apply_symm_apply ⟨b.val, hb⟩).symm))) + · have hk : b.val - t < u := by have := b.isLt; omega + have hv : (inPermEquiv σ.symm u) b = b := + ((congrArg (inPermEquiv σ.symm u) + (Fin.ext (show b.val = t + (b.val - t) by omega) : + b = Fin.natAdd t ⟨b.val - t, hk⟩)).trans + ((inPermEquiv_high σ.symm u ⟨b.val - t, hk⟩).trans + (Fin.ext (show t + (b.val - t) = b.val by omega)))) + refine Fin.ext ?_ + change s + (b.val - t) = + s + (((inPermEquiv σ.symm u) b).val - t) + have := congrArg Fin.val hv + omega + +/-- **The interface shift** (accompanying paper §3.1): permuting the +outgoing +boundary of the left factor is permuting the incoming boundary of +the right factor by the inverse. -/ +noncomputable def interfaceShift {s t u : ℕ} + (σ : Equiv.Perm (Fin t)) (F : Fragment (Fin (s + t))) + (G : Fragment (Fin (t + u))) : + ((F.relabel (outPermEquiv s σ)).compose G).Equiv + (F.compose (G.relabel (inPermEquiv σ.symm u))) := + (shiftNormalLeft σ F G).trans + ((Fragment.Equiv.relabelEq _ (shiftLabel_meet s σ u)).trans + (shiftNormalRight σ F G).symm) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/InvolutionCard.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/InvolutionCard.lean new file mode 100644 index 0000000000..f4b75b2a2a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InvolutionCard.lean @@ -0,0 +1,82 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps + +/-! +# A fixed-point-free involution halves a finset + +A finset carrying a fixed-point-free involution is the disjoint +union of two-element orbits, so its cardinality is even, and the +same holds of a finite type (`even_fintypeCard_of_involution`). This +is the counting behind every parity statement about matched flags: +edges match flags in pairs, chords match labels in pairs, and a +directed matching matches its points in pairs. +-/ + +@[expose] public section + +namespace RS + +/-- **A fixed-point-free involution halves a finset.** -/ +theorem even_card_of_involution {γ : Type} (t : Finset γ) : + ∀ i : γ → γ, (∀ x ∈ t, i x ∈ t) → (∀ x ∈ t, i (i x) = x) → + (∀ x ∈ t, i x ≠ x) → Even t.card := by + classical + induction t using Finset.strongInduction with + | _ t ih => + intro i hmem hinv hne + rcases Finset.eq_empty_or_nonempty t with rfl | ⟨x, hx⟩ + · rw [Finset.card_empty] + exact ⟨0, rfl⟩ + · have hix := hmem x hx + have hxne : x ≠ i x := fun h => hne x hx h.symm + have hsub : {x, i x} ⊆ t := by + intro y hy + rcases Finset.mem_insert.mp hy with rfl | hy + · exact hx + · rw [Finset.mem_singleton.mp hy]; exact hix + have hssub : t \ {x, i x} ⊂ t := + Finset.sdiff_ssubset hsub (by simp) + have hmem' : ∀ y ∈ t \ {x, i x}, i y ∈ t \ {x, i x} := by + intro y hy + rw [Finset.mem_sdiff, Finset.mem_insert, + Finset.mem_singleton] at hy ⊢ + push Not at hy ⊢ + obtain ⟨hyt, hyx, hyix⟩ := hy + refine ⟨hmem y hyt, ?_, ?_⟩ + · intro h + exact hyix (by rw [← hinv y hyt, h]) + · intro h + have := hinv y hyt + rw [h, hinv x hx] at this + exact hyx this.symm + have hinv' : ∀ y ∈ t \ {x, i x}, i (i y) = y := fun y hy => + hinv y (Finset.mem_sdiff.mp hy).1 + have hne' : ∀ y ∈ t \ {x, i x}, i y ≠ y := fun y hy => + hne y (Finset.mem_sdiff.mp hy).1 + have heven := ih _ hssub i hmem' hinv' hne' + have hcard : t.card = (t \ {x, i x}).card + 2 := by + have hh := Finset.card_sdiff_add_card_eq_card hsub + rw [Finset.card_pair hxne] at hh + omega + obtain ⟨r, hr⟩ := heven + exact ⟨r + 1, by omega⟩ + +/-- **The `Fintype` form**: a type carrying a fixed-point-free +involution has even cardinality. -/ +theorem even_fintypeCard_of_involution {X : Type} [Fintype X] + (i : X → X) (hinv : ∀ x, i (i x) = x) (hne : ∀ x, i x ≠ x) : + Even (Fintype.card X) := by + classical + have := even_card_of_involution (Finset.univ : Finset X) i + (fun x _ => Finset.mem_univ _) (fun x _ => hinv x) + (fun x _ => hne x) + rwa [Finset.card_univ] at this + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LabelChords.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LabelChords.lean new file mode 100644 index 0000000000..58badba453 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LabelChords.lean @@ -0,0 +1,150 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.PairDisjoint +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordLabels + +/-! +# The label chord diagram of a transition system + +The boundary pairing of a relative transition system, recorded as +a finite set of label chords (each low-to-high): the combinatorial +index over which the pairing-resolved open-sector values live. +`SamePairing` is exactly equality of chord diagrams. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} + +namespace EdgeSubset + +open Classical in +/-- The chord diagram of a system: for each participating boundary +flag, the sorted pair of its label and its path match's label. -/ +noncomputable def labelChords + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + (κ : F.RelTransitionSystem) : Finset (α × α) := + F.boundaryFlags.attach.image (fun b => + (min (F.boundaryLabel b.prop) + (F.boundaryLabel (κ.pathMatch_mem b.prop)), + max (F.boundaryLabel b.prop) + (F.boundaryLabel (κ.pathMatch_mem b.prop)))) + +/-- Membership: a pair is a chord exactly when it is the sorted +label pair of some participating boundary flag. -/ +theorem mem_labelChords [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + {p : α × α} : + p ∈ labelChords κ ↔ + ∃ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + p = (min (F.boundaryLabel hδ) + (F.boundaryLabel (κ.pathMatch_mem hδ)), + max (F.boundaryLabel hδ) + (F.boundaryLabel (κ.pathMatch_mem hδ))) := by + unfold labelChords + rw [Finset.mem_image] + constructor + · rintro ⟨⟨δ, hδ⟩, -, h⟩ + exact ⟨δ, hδ, h.symm⟩ + · rintro ⟨δ, hδ, h⟩ + exact ⟨⟨δ, hδ⟩, Finset.mem_attach _ _, h.symm⟩ + +/-- The converse: equal chord diagrams force the same pairing. The +chord of `δ` in `κ'` is the chord of `δ` in `κ` (the only `κ'` +chord containing `δ`'s label, by label injectivity), and the +partner's label determines the partner. -/ +theorem samePairing_of_labelChords + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ κ' : F.RelTransitionSystem} + (h : labelChords κ = labelChords κ') : SamePairing κ κ' := by + intro δ hδ + -- the κ'-chord of δ appears in the κ-diagram + have hmem : (min (F.boundaryLabel hδ) + (F.boundaryLabel (κ'.pathMatch_mem hδ)), + max (F.boundaryLabel hδ) + (F.boundaryLabel (κ'.pathMatch_mem hδ))) ∈ + labelChords κ := by + rw [h] + exact mem_labelChords.mpr ⟨δ, hδ, rfl⟩ + obtain ⟨γ, hγ, hp⟩ := mem_labelChords.mp hmem + -- the two sorted pairs share the label of δ, so δ ∈ {γ, π γ}; + -- in either case the partners' labels agree + have hpair := Prod.ext_iff.mp hp + rcases le_total (F.boundaryLabel hδ) + (F.boundaryLabel (κ'.pathMatch_mem hδ)) with hle | hle <;> + rcases le_total (F.boundaryLabel hγ) + (F.boundaryLabel (κ.pathMatch_mem hγ)) with hle' | hle' + · -- δ low in κ', γ low in κ: labels of δ, γ agree ⟹ δ = γ + rw [min_eq_left hle, max_eq_right hle, + min_eq_left hle', max_eq_right hle'] at hpair + have hδγ : δ = γ := boundaryLabel_inj hδ hγ hpair.1 + subst hδγ + exact (boundaryLabel_inj (κ'.pathMatch_mem hδ) + (κ.pathMatch_mem hδ) hpair.2).symm + · -- δ low in κ', γ high in κ: δ = π γ, partner label = label γ + rw [min_eq_left hle, max_eq_right hle, + min_eq_right hle', max_eq_left hle'] at hpair + have hδπγ : δ = κ.pathMatch γ hγ := + boundaryLabel_inj hδ (κ.pathMatch_mem hγ) hpair.1 + have h2 : κ.pathMatch δ hδ = γ := by + have := κ.pathMatch_congr hδπγ hδ (κ.pathMatch_mem hγ) + exact this.trans (κ.pathMatch_invol hγ) + have h3 : κ'.pathMatch δ hδ = γ := + boundaryLabel_inj (κ'.pathMatch_mem hδ) hγ hpair.2 + exact h2.trans h3.symm + · -- δ high in κ', γ low in κ: symmetric + rw [min_eq_right hle, max_eq_left hle, + min_eq_left hle', max_eq_right hle'] at hpair + have hπδγ : κ'.pathMatch δ hδ = γ := + boundaryLabel_inj (κ'.pathMatch_mem hδ) hγ hpair.1 + have hδπγ : δ = κ.pathMatch γ hγ := + boundaryLabel_inj hδ (κ.pathMatch_mem hγ) hpair.2 + have h2 : κ.pathMatch δ hδ = γ := by + have := κ.pathMatch_congr hδπγ hδ (κ.pathMatch_mem hγ) + exact this.trans (κ.pathMatch_invol hγ) + exact h2.trans hπδγ.symm + · -- both high: δ = π γ in both readings ⟹ partners agree + rw [min_eq_right hle, max_eq_left hle, + min_eq_right hle', max_eq_left hle'] at hpair + have hδγ : δ = γ := boundaryLabel_inj hδ hγ hpair.2 + subst hδγ + exact (boundaryLabel_inj (κ'.pathMatch_mem hδ) + (κ.pathMatch_mem hδ) hpair.1).symm + +end EdgeSubset + +/-- A well-formed chord diagram. -/ +structure IsChordDiagram + [LinearOrder α] + (P : Finset (α × α)) : Prop where + /-- Every chord is recorded low end first. -/ + ordered : ∀ p ∈ P, p.1 < p.2 + /-- Distinct chords share no end. -/ + disjoint : ∀ p ∈ P, ∀ q ∈ P, p ≠ q → PairDisjoint p q + +namespace EdgeSubset + +/-- On an all-internal subset the chord diagram is empty: there are +no participating boundary flags. -/ +theorem labelChords_of_allInternal + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + (hall : F.allInternal) + (κ : F.RelTransitionSystem) : labelChords κ = ∅ := + Finset.eq_empty_of_forall_notMem fun p hp => by + obtain ⟨δ, hδ, -⟩ := mem_labelChords.mp hp + rw [show F.boundaryFlags = ∅ from hall] at hδ + exact Finset.notMem_empty δ hδ + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerCast.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerCast.lean new file mode 100644 index 0000000000..907feea55e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerCast.lean @@ -0,0 +1,75 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerStage + +/-! +# Transporting a subset's data along an equality + +The interface recursion glues with `Fragment.gluePair`, which +dispatches on whether the two glued flags already bound a common +edge. Each branch identifies the glued fragment with the one the +per-glue lemmas are stated for, and the subset, the transition system +and the ledger's two counts have to be carried across that +identification. + +Nothing here is more than `subst`: the transports exist so the +recursion can name them rather than unfold them. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + +open Fragment Equiv +section SubsetEq + +variable {β : Type} + +/-- Transport a transition system along an equality of subsets. -/ +def relOfEq + {V : Fragment β} {F : EdgeSubset V} {F' : EdgeSubset V} (hF : F = F') + (κ : F.RelTransitionSystem) : F'.RelTransitionSystem := by + subst hF; exact κ + +/-- Transport an orientation along an equality of subsets. -/ +def orientOfEq + {V : Fragment β} {F : EdgeSubset V} {F' : EdgeSubset V} (hF : F = F') + {κ : F.RelTransitionSystem} (o : κ.Orientation) : + (relOfEq hF κ).Orientation := by + subst hF; exact o + +/-- Transporting a system along an equality of subsets does not +change its circuit count. -/ +theorem openCircuitCount_relOfEq + {V : Fragment β} {F : EdgeSubset V} {F' : EdgeSubset V} (hF : F = F') + (κ : F.RelTransitionSystem) : + (relOfEq hF κ).openCircuitCount = κ.openCircuitCount := by + subst hF; rfl + +/-- Nor its boundary pairing. -/ +theorem chordInv_relOfEq + {V : Fragment β} {F : EdgeSubset V} {F' : EdgeSubset V} (hF : F = F') + (κ : F.RelTransitionSystem) (a : β) : + chordInv F' (relOfEq hF κ) a = chordInv F κ a := by + subst hF; rfl + +/-- Nor whether the subset uses interface pairs together. -/ +theorem swapPaired_of_eq + {V : Fragment β} {F : EdgeSubset V} {F' : EdgeSubset V} (hF : F = F') + (ι : β → β) (h : SwapPaired F ι) : + SwapPaired F' ι := by + subst hF; exact h + +end SubsetEq + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean new file mode 100644 index 0000000000..a72b35cb19 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean @@ -0,0 +1,722 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerCast +public import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientExistence + +/-! +# The data the interface recursion carries + +RS21 composes two fragments in one step; the flag model glues the +interface one pair at a time, so the ledger (14) is proved by a +recursion over `glueInterface`. What the recursion carries is a +subset of the current fragment, a transition system on it, and the +record that the subset uses the two halves of every remaining +interface pair together — the condition that makes the interface +matching exist and that a glue preserves. + +This file names that data and the step that advances it. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + +open Fragment Equiv +/-- The lexicographic order on the recursion's label type, as the +ambient instance. It has to outrank the sum's own `≤`, which +otherwise wins on a sum type and does not agree with it. -/ +@[reducible] local instance stageOrder (n : ℕ) : + LinearOrder (Fin (0 + n) ⊕ Fin (n + 0)) := + sumLexLinearOrder _ _ + +/-- The same order one stage up, where the index shape differs. -/ +@[reducible] local instance stageOrderSucc (n : ℕ) : + LinearOrder (Fin (0 + n + 1) ⊕ Fin (n + 1 + 0)) := + sumLexLinearOrder _ _ + +/-- The left label of the pair the recursion glues at size `n+1`. -/ +abbrev cutL (n : ℕ) : Fin (0 + n + 1) ⊕ Fin (n + 1 + 0) := + Sum.inl ⟨0 + n, Nat.lt_succ_self _⟩ + +/-- The right label of the pair the recursion glues at size `n+1`. -/ +abbrev cutR (n : ℕ) : Fin (0 + n + 1) ⊕ Fin (n + 1 + 0) := + Sum.inr ⟨n, by omega⟩ + +/-- The two labels of the pair being glued are distinct. -/ +theorem cutL_ne_cutR (n : ℕ) : cutL n ≠ cutR n := Sum.inl_ne_inr + +/-- The relabel the recursion performs after a glue. The order has +to be pinned: on a sum type the ambient `≤` is the sum's own, which +is not the lexicographic one the interface uses. -/ +@[reducible] noncomputable def stepIso (n : ℕ) : + @OrderIso + (SurvivingLabel (Fin (0 + n + 1) ⊕ Fin (n + 1 + 0)) (cutL n) + (cutR n)) + (Fin (0 + n) ⊕ Fin (n + 0)) + (sumLexSubtypeLE (Fin (0 + n + 1)) (Fin (n + 1 + 0)) + (fun x => x ≠ cutL n ∧ x ≠ cutR n)) + (sumLexLE (Fin (0 + n)) (Fin (n + 0))) := + interfaceStepOrderIso 0 n 0 + +/-- The swap on the labels surviving the glue: the next stage's +swap, read back through the relabel. -/ +noncomputable def stepSwap (n : ℕ) : + SurvivingLabel (Fin (0 + n + 1) ⊕ Fin (n + 1 + 0)) (cutL n) + (cutR n) + → SurvivingLabel (Fin (0 + n + 1) ⊕ Fin (n + 1 + 0)) (cutL n) + (cutR n) := + fun x => (interfaceStepEquiv 0 n 0).symm + (interfaceSwap (stepIdent n) (interfaceStepEquiv 0 n 0 x)) + +/-- The surviving-label swap agrees with the current stage's +interface swap on underlying labels. -/ +theorem stepSwap_val (n : ℕ) + (x : SurvivingLabel (Fin (0 + n + 1) ⊕ Fin (n + 1 + 0)) (cutL n) + (cutR n)) : + ((stepSwap n x).val + : Fin (0 + n + 1) ⊕ Fin (n + 1 + 0)) + = interfaceSwap (stepIdent (n + 1)) x.val := + interfaceSwap_interfaceStep n x + +/-- The interface swap exchanges the pair the recursion glues. -/ +theorem interfaceSwap_cutL (n : ℕ) : + interfaceSwap (stepIdent (n + 1)) (cutL n) = cutR n := + interfaceSwap_cut n + +/-- **The data one stage of the recursion carries.** -/ +structure StageData (n : ℕ) + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) where + /-- The subset of the current fragment. -/ + sub : EdgeSubset V + /-- It uses the two halves of every remaining interface pair + together. -/ + paired : SwapPaired sub (interfaceSwap (stepIdent n)) + /-- A transition system on it. -/ + rel : sub.RelTransitionSystem + +/-! ## One step + +Gluing the top interface pair takes the subset to its drop, the +system to its glue, and the pairing record along with them; the +relabel that follows carries all three. The subset's own pairing +record is what makes the step total: it is exactly the condition +under which the drop is closed under the glued pairing. + +The two branches are built over the fragment each glue actually +produces, and the dispatch `Fragment.gluePair` performs is undone +once, on the finished data. +-/ + +section Step + +variable (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (D : StageData (n + 1) V) + +/-- The flags the glue passes down: the subset's, less the two +glued ones. -/ +noncomputable def stepFlags : + Finset (SurvivingFlag V (cutL n) (cutR n)) := + V.dropSubset (cutL n) (cutR n) D.sub.flags + +/-- Whether the subset carries the closed cut's own edge. -/ +noncomputable def stepBit : Bool := + decide (V.boundaryFlag (cutL n) ∈ D.sub.flags) + +/-- Transport the stage data along an equality of fragments. -/ +noncomputable def stageDataOfEq {m : ℕ} + {V₁ V₂ : Fragment (Fin (0 + m) ⊕ Fin (m + 0))} (h : V₁ = V₂) + (Dm : StageData m V₁) : StageData m V₂ := by + subst h; exact Dm + +section Closed + +variable (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) + +/-- On a closed cut the passed-down flags are edge-closed in the +glued fragment. -/ +theorem stepFlags_closed_pairing_mem : + ∀ f ∈ stepFlags n V D, + (V.gluePairClosed (cutL n) (cutR n) hcl).pairing f + ∈ stepFlags n V D := + dropSubset_pairing_closed_of_closed hcl D.sub.flags D.sub.pairing_mem + +include hcl in +/-- Lifting the passed-down flags back through a closed glue +recovers the subset's flags. -/ +theorem liftSubsetClosed_stepFlags : + liftSubsetClosed (stepFlags n V D) (stepBit n V D) + = D.sub.flags := + liftSubsetClosed_dropSubset (cutL_ne_cutR n) hcl D.sub.flags + D.sub.pairing_mem + +include hcl in +/-- The lifted flags are edge-closed in the unglued fragment. -/ +theorem liftSubsetClosed_stepFlags_pairing_mem : + ∀ f ∈ liftSubsetClosed (stepFlags n V D) (stepBit n V D), + V.pairing f + ∈ liftSubsetClosed (stepFlags n V D) (stepBit n V D) := by + rw [liftSubsetClosed_stepFlags n V D hcl] + exact D.sub.pairing_mem + +include hcl in +/-- The stage's subset is the lift of what the closed glue passes +down: nothing is lost across the step. -/ +theorem sub_eq_liftSubsetClosed : + D.sub = EdgeSubset.mk _ + (liftSubsetClosed_stepFlags_pairing_mem n V D hcl) := + EdgeSubset.ext (liftSubsetClosed_stepFlags n V D hcl).symm + +include hcl in +/-- The glued subset at a closed cut. -/ +@[reducible] noncomputable def stepSubClosed : + EdgeSubset (V.gluePairClosed (cutL n) (cutR n) hcl) := + EdgeSubset.mk (stepFlags n V D) + (stepFlags_closed_pairing_mem n V D hcl) + +open Fragment in +/-- One step at a closed cut. -/ +noncomputable def stepDataClosed : + StageData n + ((V.gluePairClosed (cutL n) (cutR n) hcl).relabel + (interfaceStepEquiv 0 n 0)) where + sub := (stepSubClosed n V D hcl).relabelUp (stepIso n).toEquiv + paired := swapPaired_relabelUp (stepIso n) (stepSubClosed n V D hcl) + (stepSwap n) (interfaceSwap (stepIdent n)) (fun _ => rfl) + (swapPaired_glueClosed hcl (stepBit n V D) (stepFlags n V D) + (stepFlags_closed_pairing_mem n V D hcl) + (liftSubsetClosed_stepFlags_pairing_mem n V D hcl) + (interfaceSwap (stepIdent (n + 1))) (stepSwap n) + (stepSwap_val n) + (swapPaired_of_eq (sub_eq_liftSubsetClosed n V D hcl) _ + D.paired)) + rel := relabelTransUp (stepIso n).toEquiv (stepSubClosed n V D hcl) + (RelTransitionSystem.glueClosed hcl (stepBit n V D) + (stepFlags n V D) (stepFlags_closed_pairing_mem n V D hcl) + (liftSubsetClosed_stepFlags_pairing_mem n V D hcl) + (relOfEq (sub_eq_liftSubsetClosed n V D hcl) D.rel)) + +end Closed + +section Open + +variable (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) + +/-- The stage's subset uses the two halves of the glued pair +together — the record the recursion carries. -/ +theorem agreeingSubset_sub : + AgreeingSubset (cutL n) (cutR n) D.sub.flags := + agreeingSubset_of_swapPaired D.sub _ D.paired (interfaceSwap_cutL n) + +/-- On an open cut the passed-down flags are edge-closed in the +glued fragment. -/ +theorem stepFlags_open_pairing_mem : + ∀ f ∈ stepFlags n V D, + (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop).pairing f + ∈ stepFlags n V D := + dropSubset_rewire_closed hop D.sub.flags (agreeingSubset_sub n V D) + +include hop in +/-- Lifting the passed-down flags back through an open glue +recovers the subset's flags. -/ +theorem liftSubsetOpen_stepFlags : + liftSubsetOpen hop (stepFlags n V D) + = D.sub.flags := + liftSubsetOpen_dropSubset (cutL_ne_cutR n) hop D.sub.flags + D.sub.pairing_mem + +include hop in +/-- The lifted flags are edge-closed in the unglued fragment. -/ +theorem liftSubsetOpen_stepFlags_pairing_mem : + ∀ f ∈ liftSubsetOpen hop (stepFlags n V D), + V.pairing f + ∈ liftSubsetOpen hop (stepFlags n V D) := by + rw [liftSubsetOpen_stepFlags n V D hop] + exact D.sub.pairing_mem + +include hop in +/-- The open-cut analogue: the stage's subset is the lift. -/ +theorem sub_eq_liftSubsetOpen : + D.sub = EdgeSubset.mk _ + (liftSubsetOpen_stepFlags_pairing_mem n V D hop) := + EdgeSubset.ext (liftSubsetOpen_stepFlags n V D hop).symm + +include hop in +/-- The glued subset at an open cut. -/ +@[reducible] noncomputable def stepSubOpen : + EdgeSubset (V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop) := + EdgeSubset.mk (stepFlags n V D) + (stepFlags_open_pairing_mem n V D hop) + +open Fragment in +/-- One step at an open cut. -/ +noncomputable def stepDataOpen : + StageData n + ((V.gluePairOpen (cutL n) (cutR n) (cutL_ne_cutR n) hop).relabel + (interfaceStepEquiv 0 n 0)) where + sub := (stepSubOpen n V D hop).relabelUp (stepIso n).toEquiv + paired := swapPaired_relabelUp (stepIso n) (stepSubOpen n V D hop) + (stepSwap n) (interfaceSwap (stepIdent n)) (fun _ => rfl) + (swapPaired_glueOpen (cutL_ne_cutR n) hop (stepFlags n V D) + (stepFlags_open_pairing_mem n V D hop) + (liftSubsetOpen_stepFlags_pairing_mem n V D hop) + (interfaceSwap (stepIdent (n + 1))) (stepSwap n) + (stepSwap_val n) + (swapPaired_of_eq (sub_eq_liftSubsetOpen n V D hop) _ D.paired)) + rel := relabelTransUp (stepIso n).toEquiv (stepSubOpen n V D hop) + (RelTransitionSystem.glueOpen (cutL_ne_cutR n) hop + (stepFlags n V D) (stepFlags_open_pairing_mem n V D hop) + (liftSubsetOpen_stepFlags_pairing_mem n V D hop) + (relOfEq (sub_eq_liftSubsetOpen n V D hop) D.rel)) + +end Open + +open Fragment Classical in +/-- **One step of the recursion**: glue the top interface pair and +relabel. -/ +noncomputable def stepData : + StageData n + ((V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)).relabel + (interfaceStepEquiv 0 n 0)) := + if hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then + stageDataOfEq + (congrArg (fun X => X.relabel (interfaceStepEquiv 0 n 0)) + (gluePair_eq_closed (cutL_ne_cutR n) hcl).symm) + (stepDataClosed n V D hcl) + else + stageDataOfEq + (congrArg (fun X => X.relabel (interfaceStepEquiv 0 n 0)) + (gluePair_eq_open (cutL_ne_cutR n) hcl).symm) + (stepDataOpen n V D hcl) + +end Step + +/-! ## The recursion + +Iterating the step over the whole interface carries the data to the +composed fragment, and the accumulator records the cuts at which a +component of the union disappears: the closed ones whose edge the +subset carries. +-/ + +/-- The relabel that closes the recursion at the empty interface. -/ +noncomputable def endEquiv : + (Fin (0 + 0) ⊕ Fin (0 + 0)) ≃ (Fin 0 ⊕ Fin 0) := + Equiv.sumCongr (finCongr (by omega)) (finCongr (by omega)) + +/-- **The data carried to the composed fragment.** -/ +noncomputable def glueData : (n : ℕ) → + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) → StageData n V → + StageData 0 (glueInterface 0 n 0 V) + | 0, _, D => + { sub := D.sub.relabelUp endEquiv + paired := fun x => + match x with + | Sum.inl a => a.elim0 + | Sum.inr b => b.elim0 + rel := relabelTransUp endEquiv D.sub D.rel } + | n + 1, V, D => glueData n _ (stepData n V D) + +open Classical in +/-- **The cuts at which a component disappears**: the closed ones +whose edge the subset carries. -/ +noncomputable def glueCount : (n : ℕ) → + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) → StageData n V → ℕ + | 0, _, _ => 0 + | n + 1, V, D => + (if V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) ∧ stepBit n V D = true then 1 + else 0) + + glueCount n _ (stepData n V D) + +/-! ## The ledger the recursion transports + +RS21's (14) compares the composed system's circuit count with the two +fragments' counts and the number of components of the union. In the +recursion that quantity is read at every stage, of the current +fragment's own system and the interface matching still to be glued. +-/ + +/-- **The ledger at one stage**: the circuit count plus the number of +components of the union with the interface matching. -/ +noncomputable def ledgerOf {n : ℕ} + {V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))} (F : EdgeSubset V) + (hp : SwapPaired F (interfaceSwap (stepIdent n))) + (κ : F.RelTransitionSystem) : ℕ := + κ.openCircuitCount + + DirMatching.unionCount (cutMatching F κ (relBuildOrientation κ)) + (interfaceCut F (stepIdent n) + ((swapPaired_iff_interfacePaired F (stepIdent n)).mp hp)) + +/-- The ledger of a stage's data. -/ +noncomputable def stageLedger (n : ℕ) + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) (D : StageData n V) : + ℕ := ledgerOf D.sub D.paired D.rel + +/-- The ledger does not see which of two equal subsets it is +stated at. -/ +theorem ledgerOf_congr {n : ℕ} + {V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))} {F F' : EdgeSubset V} + (hF : F = F') (hp : SwapPaired F (interfaceSwap (stepIdent n))) + (hp' : SwapPaired F' (interfaceSwap (stepIdent n))) + (κ : F.RelTransitionSystem) : + ledgerOf F' hp' (relOfEq hF κ) = ledgerOf F hp κ := by + subst hF; rfl + +/-- Transporting the stage data along an equality of fragments does +not change its ledger. -/ +theorem stageLedger_stageDataOfEq {m : ℕ} + {V₁ V₂ : Fragment (Fin (0 + m) ⊕ Fin (m + 0))} (h : V₁ = V₂) + (D : StageData m V₁) : + stageLedger m V₂ (stageDataOfEq h D) = stageLedger m V₁ D := by + subst h; rfl + +open Classical in +/-- On a closed cut the step is the closed branch, transported. -/ +theorem stepData_eq_closed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (D : StageData (n + 1) V) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) : + stepData n V D + = stageDataOfEq + (congrArg (fun X => X.relabel (interfaceStepEquiv 0 n 0)) + (gluePair_eq_closed (cutL_ne_cutR n) hcl).symm) + (stepDataClosed n V D hcl) := by + unfold stepData + rw [dite_eq_left hcl] + +open Classical in +/-- On an open cut the step is the open branch, transported. -/ +theorem stepData_eq_open (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (D : StageData (n + 1) V) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) : + stepData n V D + = stageDataOfEq + (congrArg (fun X => X.relabel (interfaceStepEquiv 0 n 0)) + (gluePair_eq_open (cutL_ne_cutR n) hop).symm) + (stepDataOpen n V D hop) := by + unfold stepData + rw [dite_eq_right hop] + +/-! ## One stage of the ledger + +Each branch of the step is discharged by the stage theorem for its +kind of cut, at the interface matching and any orientation — the +ledger reads neither the orientation nor which proof of the pairing +record is supplied. +-/ + +-- The ledger of the stepped data is computed, so +-- the stage data and its glue all unfold. +/-- **The closed-cut step of the ledger**: gluing a closed pair the +subset carries closes one more circuit, so the ledger drops by the +step bit. -/ +theorem stageLedger_stepDataClosed (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (D : StageData (n + 1) V) + (hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n)) : + stageLedger n _ (stepDataClosed n V D hcl) + + (if stepBit n V D = true then 1 else 0) + = stageLedger (n + 1) V D := by + have hpl := swapPaired_of_eq (sub_eq_liftSubsetClosed n V D hcl) _ + D.paired + have hpg := (stepDataClosed n V D hcl).paired + rw [stageLedger, stageLedger, ← + ledgerOf_congr (sub_eq_liftSubsetClosed n V D hcl) D.paired hpl + D.rel] + simp only [ledgerOf] + exact ledgerStage_closed_bit (cutL_ne_cutR n) hcl (stepFlags n V D) + (stepBit n V D) (stepFlags_closed_pairing_mem n V D hcl) + (liftSubsetClosed_stepFlags_pairing_mem n V D hcl) (stepIso n) + (relOfEq (sub_eq_liftSubsetClosed n V D hcl) D.rel) + (relBuildOrientation _) (relBuildOrientation _) + (relBuildOrientation _) (relBuildOrientation _) + (interfaceSwap (stepIdent (n + 1))) (interfaceSwap_cutL n) + (interfaceCut_edge_val _ (stepIdent (n + 1)) + ((swapPaired_iff_interfacePaired _ (stepIdent (n + 1))).mp hpl)) + (fun z => + (congrArg Subtype.val (interfaceCut_relabelUp_edge + (stepSubClosed n V D hcl) (stepIso n) (stepIdent n) + ((swapPaired_iff_interfacePaired _ (stepIdent n)).mp hpg) + z)).trans (stepSwap_val n z.val)) + +-- As for the closed cut. +/-- **The open-cut step of the ledger**: gluing an open pair closes +nothing, so the ledger is unchanged. -/ +theorem stageLedger_stepDataOpen (n : ℕ) + (V : Fragment (Fin (0 + (n + 1)) ⊕ Fin ((n + 1) + 0))) + (D : StageData (n + 1) V) + (hop : V.pairing (V.boundaryFlag (cutL n)) + ≠ V.boundaryFlag (cutR n)) : + stageLedger n _ (stepDataOpen n V D hop) + = stageLedger (n + 1) V D := by + have hpl := swapPaired_of_eq (sub_eq_liftSubsetOpen n V D hop) _ + D.paired + have hpg := (stepDataOpen n V D hop).paired + rw [stageLedger, stageLedger, ← + ledgerOf_congr (sub_eq_liftSubsetOpen n V D hop) D.paired hpl + D.rel] + simp only [ledgerOf] + exact ledgerStage_open_any (cutL_ne_cutR n) hop (stepFlags n V D) + (stepFlags_open_pairing_mem n V D hop) + (liftSubsetOpen_stepFlags_pairing_mem n V D hop) (stepIso n) + (relOfEq (sub_eq_liftSubsetOpen n V D hop) D.rel) + (relBuildOrientation _) (relBuildOrientation _) + (relBuildOrientation _) + (interfaceSwap (stepIdent (n + 1))) (interfaceSwap_cutL n) + (interfaceCut_edge_val _ (stepIdent (n + 1)) + ((swapPaired_iff_interfacePaired _ (stepIdent (n + 1))).mp hpl)) + (fun z => + (congrArg Subtype.val (interfaceCut_relabelUp_edge + (stepSubOpen n V D hop) (stepIso n) (stepIdent n) + ((swapPaired_iff_interfacePaired _ (stepIdent n)).mp hpg) + z)).trans (stepSwap_val n z.val)) + +/-! ## RS21's (14) + +The ledger is transported by the whole recursion: the composed +system's circuit count, plus one for each closed cut whose edge the +subset carries, is the starting system's circuit count plus the +number of components of the union with the interface matching. +-/ + +/-- At stage zero there are no labels left: the recursion's base. -/ +instance stageEmpty : IsEmpty (Fin (0 + 0) ⊕ Fin (0 + 0)) := + ⟨fun x => + match x with + | Sum.inl a => a.elim0 + | Sum.inr b => b.elim0⟩ + +/-- At the empty interface the ledger is the circuit count: there +are no used labels, hence no components to count. -/ +theorem ledgerOf_isEmpty {V : Fragment (Fin (0 + 0) ⊕ Fin (0 + 0))} + (F : EdgeSubset V) + (hp : SwapPaired F (interfaceSwap (stepIdent 0))) + (κ : F.RelTransitionSystem) : + ledgerOf F hp κ = κ.openCircuitCount := by + have : IsEmpty (UsedLab F) := ⟨fun x => isEmptyElim x.val⟩ + rw [ledgerOf, DirMatching.unionCount_of_isEmpty, Nat.add_zero] + +-- The recursion on the cut count carries the whole +-- stage data at every step. +/-- **RS21's (14), transported by the recursion.** -/ +theorem ledger_glueData : ∀ (n : ℕ) + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) (D : StageData n V), + stageLedger 0 _ (glueData n V D) + glueCount n V D + = stageLedger n V D + | 0, V, D => by + simp only [glueCount, stageLedger, ledgerOf_isEmpty, Nat.add_zero] + exact relabel_openCircuitCount endEquiv D.sub D.rel + | n + 1, V, D => by + have ih := ledger_glueData n _ (stepData n V D) + have hgd : glueData (n + 1) V D + = glueData n _ (stepData n V D) := rfl + have hgc : glueCount (n + 1) V D + = (if V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) ∧ stepBit n V D = true then 1 + else 0) + + glueCount n _ (stepData n V D) := rfl + have hstep : stageLedger n _ (stepData n V D) + + (if V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) ∧ stepBit n V D = true then 1 + else 0) + = stageLedger (n + 1) V D := by + by_cases hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) + · rw [stepData_eq_closed n V D hcl, stageLedger_stageDataOfEq, + show (if V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) ∧ stepBit n V D = true then 1 + else 0) = (if stepBit n V D = true then 1 else 0) from by + by_cases hb : stepBit n V D = true + · rw [ite_eq_left ⟨hcl, hb⟩, ite_eq_left hb] + · rw [ite_eq_right (fun h => hb h.2), ite_eq_right hb]] + exact stageLedger_stepDataClosed n V D hcl + · rw [stepData_eq_open n V D hcl, stageLedger_stageDataOfEq, + ite_eq_right (fun h => hcl h.1), Nat.add_zero] + exact stageLedger_stepDataOpen n V D hcl + rw [show stageLedger 0 _ (glueData (n + 1) V D) + + glueCount (n + 1) V D + = stageLedger 0 _ (glueData n _ (stepData n V D)) + + ((if V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) ∧ stepBit n V D = true then 1 + else 0) + + glueCount n _ (stepData n V D)) from by + rw [hgc] + exact congrArg (fun X => stageLedger 0 _ X + _) hgd] + omega + +/-- **RS21's (14).** The composed system's circuit count, plus one +for each closed cut whose edge the subset carries, is the starting +system's circuit count plus the number of components of its union +with the interface matching. -/ +theorem openCircuitCount_glueData (n : ℕ) + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) (D : StageData n V) : + (glueData n V D).rel.openCircuitCount + glueCount n V D + = stageLedger n V D := by + rw [← ledger_glueData n V D, stageLedger, ledgerOf_isEmpty] + +/-! ## The circles the composition creates + +A closed cut turns its edge into a free circle, and the partition +function weights each by `k - 2ℓ`. RS21's graph model has no room +for a vertex-free circle, so this is bookkeeping the flag model has +to carry on its own; it depends only on the fragment, not on the +subset. +-/ + +open Classical in +/-- **The cuts the composition closes.** -/ +noncomputable def closedCuts : (n : ℕ) → + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))) → ℕ + | 0, _ => 0 + | n + 1, V => + (if V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then 1 else 0) + + closedCuts n ((V.gluePair (cutL n) (cutR n) + (cutL_ne_cutR n)).relabel (interfaceStepEquiv 0 n 0)) + +open Classical in +/-- **The composition's free circles.** -/ +theorem circles_glueInterface : ∀ (n : ℕ) + (V : Fragment (Fin (0 + n) ⊕ Fin (n + 0))), + (glueInterface 0 n 0 V).circles = V.circles + closedCuts n V + | 0, V => by + change V.circles = V.circles + 0 + omega + | n + 1, V => by + have ih := circles_glueInterface n + ((V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)).relabel + (interfaceStepEquiv 0 n 0)) + have hstep : ((V.gluePair (cutL n) (cutR n) + (cutL_ne_cutR n)).relabel + (interfaceStepEquiv 0 n 0)).circles + = V.circles + (if V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then 1 else 0) := by + change (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)).circles = _ + unfold Fragment.gluePair + by_cases hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) + · rw [dite_eq_left hcl, ite_eq_left hcl] + rfl + · rw [dite_eq_right hcl, ite_eq_right hcl] + change V.circles = V.circles + 0 + omega + change (glueInterface 0 n 0 _).circles = _ + rw [ih, hstep] + change _ = V.circles + ((if V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then 1 else 0) + _) + omega + +/-! ## The ledger at the start of the recursion + +The recursion starts at the disjoint union of the two fragments, and +there the ledger splits into RS21's own terms: the two circuit counts +and the number of components of the union of the two chord matchings, +read on one copy of the label set. +-/ + +/-- **The ledger at a disjoint union.** -/ +theorem stageLedger_disjUnion (n : ℕ) + {W₁ : Fragment (Fin (0 + n))} {W₂ : Fragment (Fin (n + 0))} + (F : EdgeSubset (W₁.disjUnion W₂)) + (hp : SwapPaired F (interfaceSwap (stepIdent n))) + (κ₁ : (leftSub F).RelTransitionSystem) + (κ₂ : (rightSub F).RelTransitionSystem) + (o₁ : κ₁.Orientation) (o₂ : κ₂.Orientation) : + stageLedger n (W₁.disjUnion W₂) + ⟨F, hp, prodRel κ₁ κ₂⟩ + = κ₁.openCircuitCount + κ₂.openCircuitCount + + DirMatching.unionCount (cutMatching (leftSub F) κ₁ o₁) + ((cutMatching (rightSub F) κ₂ o₂).map + (interfaceSideDisjEquiv F (stepIdent n) + ((swapPaired_iff_interfacePaired F + (stepIdent n)).mp hp)).symm) := by + rw [stageLedger, ledgerOf, openCircuitCount_prodRel κ₁ κ₂, + DirMatching.unionCount_congr + (cutMatching_congr_matchEq (RelTransitionSystem.MatchEq.refl _) + (prodOrient o₁ o₂) (relBuildOrientation (prodRel κ₁ κ₂))) + (rfl : (interfaceCut F (stepIdent n) + ((swapPaired_iff_interfacePaired F (stepIdent n)).mp hp)).edge + = _), + unionCount_cutMatching_disjUnion F (stepIdent n) κ₁ κ₂ o₁ o₂] + +/-- The interface identification at size `n`, as an order +isomorphism. -/ +def stepIdentOrderIso (n : ℕ) : Fin (0 + n) ≃o Fin (n + 0) := + Fin.castOrderIso (by omega) + +open Classical in +/-- **RS21's (14), as the sign identity it is used as.** The two +fragments' matching signs and circuit signs multiply to the composed +system's circuit sign, together with the sign of the cuts at which a +component disappears. -/ +theorem sign_composition (n : ℕ) {W₁ : Fragment (Fin (0 + n))} + {W₂ : Fragment (Fin (n + 0))} + (F : EdgeSubset (W₁.disjUnion W₂)) + (hp : SwapPaired F (interfaceSwap (stepIdent n))) + (κ₁ : (leftSub F).RelTransitionSystem) + (κ₂ : (rightSub F).RelTransitionSystem) + (o₁ : κ₁.Orientation) (o₂ : κ₂.Orientation) + (M₁ : DirMatching (UsedLab (leftSub F))) + (M₂ : DirMatching (UsedLab (rightSub F))) {m : ℕ} + (hc₁ : Fintype.card (UsedLab (leftSub F)) = 2 * m) + (hc₂ : Fintype.card (UsedLab (rightSub F)) = 2 * m) + (hM₁ : M₁.edge = (cutMatching (leftSub F) κ₁ o₁).edge) + (hM₂ : M₂.edge = (cutMatching (rightSub F) κ₂ o₂).edge) + (halt : ∀ a : UsedLab (leftSub F), + M₂.tail (interfaceSideDisjOrderIso F (stepIdentOrderIso n) + ((swapPaired_iff_interfacePaired F (stepIdent n)).mp hp) a) + = !M₁.tail a) : + ((DirMatching.sgnRel (DirMatching.stdMatching hc₁) M₁ : ℤ) : ℂ) + * ((-1 : ℂ) ^ κ₁.openCircuitCount) + * (((DirMatching.sgnRel (DirMatching.stdMatching hc₂) M₂ + : ℤ) : ℂ) * ((-1 : ℂ) ^ κ₂.openCircuitCount)) + = (-1 : ℂ) ^ ((glueData n (W₁.disjUnion W₂) + ⟨F, hp, prodRel κ₁ κ₂⟩).rel.openCircuitCount + + glueCount n (W₁.disjUnion W₂) ⟨F, hp, prodRel κ₁ κ₂⟩) := by + have hEs : (interfaceSideDisjOrderIso F (stepIdentOrderIso n) + ((swapPaired_iff_interfacePaired F + (stepIdent n)).mp hp)).symm.toEquiv + = (interfaceSideDisjEquiv F (stepIdent n) + ((swapPaired_iff_interfacePaired F + (stepIdent n)).mp hp)).symm := rfl + have hsgn := DirMatching.sgnRel_mul_sgnRel_of_alternating + (interfaceSideDisjOrderIso F (stepIdentOrderIso n) + ((swapPaired_iff_interfacePaired F (stepIdent n)).mp hp)) + hc₁ hc₂ M₁ M₂ halt + rw [hEs] at hsgn + have hcnt : DirMatching.unionCount M₁ + (M₂.map (interfaceSideDisjEquiv F (stepIdent n) + ((swapPaired_iff_interfacePaired F + (stepIdent n)).mp hp)).symm) + = DirMatching.unionCount (cutMatching (leftSub F) κ₁ o₁) + ((cutMatching (rightSub F) κ₂ o₂).map + (interfaceSideDisjEquiv F (stepIdent n) + ((swapPaired_iff_interfacePaired F + (stepIdent n)).mp hp)).symm) := + DirMatching.unionCount_congr hM₁ + (DirMatching.map_edge_congr _ hM₂) + rw [openCircuitCount_glueData n (W₁.disjUnion W₂) + ⟨F, hp, prodRel κ₁ κ₂⟩, + stageLedger_disjUnion n F hp κ₁ κ₂ o₁ o₂, pow_add, pow_add, + ← hcnt, ← hsgn, mul_mul_mul_comm] + exact mul_comm _ _ + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerSets.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerSets.lean new file mode 100644 index 0000000000..eb321acb50 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerSets.lean @@ -0,0 +1,314 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StateFlipSet +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StatusSet + +/-! +# Relabel sets for the canonical ledgers + +A canonical ledger reports the state it lands in as +`stateOddFlipSet st E`. This module is the arithmetic of the set +`E`: it is a symmetric-difference fold (`pairFold`) of label pairs, +one pair per flipped chain, each pair the two end labels of a chord +of the stage system. Within one recanonicalization the flipped +chains are distinct anti-canonical chains (`AntiLowPair`), so the +pairs are pairwise disjoint (`PairDisjoint`) and the fold is a +disjoint union (`mem_pairFold_of_pairwise`). + +The accumulated relabel of a whole route is the status difference +`statusDiff`, which telescopes along chains (`statusDiff_trans`) +and vanishes on a pairing-preserving one +(`statusDiff_of_samePairing`). +-/ + +@[expose] public section + +namespace RS + + + +section PairSets + +variable {k ℓ : ℕ} {α : Type} + +open scoped Classical in +/-- Symmetric difference of two finite sets — the composition law +of `stateOddFlipSet` (`stateOddFlipSet_symmU`). -/ +noncomputable def symmU (E₁ E₂ : Finset α) : Finset α := + (E₁ \ E₂) ∪ (E₂ \ E₁) + +/-- Membership in a symmetric difference: in exactly one of the +two sets. -/ +theorem mem_symmU {E₁ E₂ : Finset α} {i : α} : + i ∈ symmU E₁ E₂ ↔ + (i ∈ E₁ ∧ i ∉ E₂) ∨ (i ∈ E₂ ∧ i ∉ E₁) := by + classical + unfold symmU + rw [Finset.mem_union, Finset.mem_sdiff, Finset.mem_sdiff] + +/-- The symmetric difference of a set with itself is empty. -/ +theorem symmU_self (A : Finset α) : symmU A A = ∅ := by + apply Finset.ext + intro i + rw [mem_symmU] + constructor + · rintro (⟨h1, h2⟩ | ⟨h1, h2⟩) <;> exact absurd h1 h2 + · intro h + exact absurd h (Finset.notMem_empty i) + +/-- **Telescoping**: symmetric differences against a common middle +compose. -/ +theorem symmU_trans (A B C : Finset α) : + symmU (symmU A B) (symmU B C) = symmU A C := by + apply Finset.ext + intro i + rw [mem_symmU, mem_symmU, mem_symmU, mem_symmU] + by_cases hA : i ∈ A <;> by_cases hB : i ∈ B <;> + by_cases hC : i ∈ C <;> tauto + +/-- The empty set is a left unit. -/ +theorem symmU_empty_left (E : Finset α) : symmU ∅ E = E := by + apply Finset.ext + intro i + rw [mem_symmU] + constructor + · rintro (⟨h, -⟩ | ⟨h, -⟩) + · exact absurd h (Finset.notMem_empty i) + · exact h + · intro h + exact Or.inr ⟨h, Finset.notMem_empty i⟩ + +/-- Symmetric difference is associative, so a fold over a list is +well-behaved. -/ +theorem symmU_assoc (E₁ E₂ E₃ : Finset α) : + symmU (symmU E₁ E₂) E₃ = symmU E₁ (symmU E₂ E₃) := by + apply Finset.ext + intro i + rw [mem_symmU, mem_symmU, mem_symmU, mem_symmU] + tauto + +open scoped Classical in +/-- The two-element label set of a label pair. -/ +noncomputable def pairSet (p : α × α) : Finset α := {p.1, p.2} + +/-- Membership in a pair's label set. -/ +theorem mem_pairSet {p : α × α} {i : α} : + i ∈ pairSet p ↔ i = p.1 ∨ i = p.2 := by + classical + unfold pairSet + rw [Finset.mem_insert, Finset.mem_singleton] + +/-- The symmetric-difference fold of a list of label pairs. -/ +noncomputable def pairFold (L : List (α × α)) : Finset α := + L.foldr (fun p E => symmU (pairSet p) E) ∅ + +/-- The fold over no pairs is empty: nothing relabelled. -/ +theorem pairFold_nil : pairFold ([] : List (α × α)) = ∅ := rfl + +/-- One more pair contributes its two labels, cancelling any that +the rest of the fold already carries. -/ +theorem pairFold_cons (p : α × α) (L : List (α × α)) : + pairFold (p :: L) = symmU (pairSet p) (pairFold L) := rfl + +/-- The fold turns concatenation into symmetric difference — the +composition law the accumulated relabel needs. -/ +theorem pairFold_append (L₁ L₂ : List (α × α)) : + pairFold (L₁ ++ L₂) = symmU (pairFold L₁) (pairFold L₂) := by + induction L₁ with + | nil => + rw [List.nil_append, pairFold_nil, symmU_empty_left] + | cons p L ih => + rw [List.cons_append, pairFold_cons, pairFold_cons, ih, + symmU_assoc] + +/-- **The fold of pairwise disjoint pairs is their union**: under +`PairDisjoint` no cancellation occurs, so membership in the fold is +membership in some pair. -/ +theorem mem_pairFold_of_pairwise {L : List (α × α)} + (hL : L.Pairwise PairDisjoint) {i : α} : + i ∈ pairFold L ↔ ∃ p ∈ L, i = p.1 ∨ i = p.2 := by + induction L with + | nil => + rw [pairFold_nil] + constructor + · intro h + exact absurd h (Finset.notMem_empty i) + · rintro ⟨p, hp, -⟩ + cases hp + | cons p L ih => + obtain ⟨hd, htl⟩ := List.pairwise_cons.mp hL + rw [pairFold_cons, mem_symmU, mem_pairSet, ih htl] + constructor + · rintro (⟨h1, -⟩ | ⟨⟨q, hq, hiq⟩, -⟩) + · exact ⟨p, List.mem_cons.mpr (Or.inl rfl), h1⟩ + · exact ⟨q, List.mem_cons.mpr (Or.inr hq), hiq⟩ + · rintro ⟨q, hq, hiq⟩ + rcases List.mem_cons.mp hq with rfl | hq' + · refine Or.inl ⟨hiq, ?_⟩ + rintro ⟨q', hq', hiq'⟩ + have hdisj := hd q' hq' + rcases hiq with h1 | h1 <;> rcases hiq' with h2 | h2 + · exact hdisj.fst_ne_fst (h1.symm.trans h2) + · exact hdisj.fst_ne_snd (h1.symm.trans h2) + · exact hdisj.snd_ne_fst (h1.symm.trans h2) + · exact hdisj.snd_ne_snd (h1.symm.trans h2) + · refine Or.inr ⟨⟨q, hq', hiq⟩, ?_⟩ + have hdisj := hd q hq' + rintro (h1 | h1) <;> rcases hiq with h2 | h2 + · exact hdisj.fst_ne_fst (h1.symm.trans h2) + · exact hdisj.fst_ne_snd (h1.symm.trans h2) + · exact hdisj.snd_ne_fst (h1.symm.trans h2) + · exact hdisj.snd_ne_snd (h1.symm.trans h2) + +/-! ## Set relabels: boundary matching and composition -/ + +/-- Composition of set relabels is the `symmU` of the sets. -/ +theorem stateOddFlipSet_symmU {st : GenBoundaryState k ℓ α} + (E₁ E₂ : Finset α) : + stateOddFlipSet (stateOddFlipSet st E₁) E₂ = + stateOddFlipSet st (symmU E₁ E₂) := + stateOddFlipSet_flipSet E₁ E₂ + +end PairSets + +namespace EdgeSubset + +variable {α : Type} + +/-! ## Anti-canonical chain pairs -/ + +/-- A chord pair whose low end is anti-canonical for `o`: the label +pair of a chain flipped by the recanonicalization of `o`. -/ +def AntiLowPair [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} (o : κ.Orientation) + (p : α × α) : Prop := + ∃ (β : W.Flag) (hβ : β ∈ F.boundaryFlags), + β ∈ antiLowSet o ∧ + p.1 = F.boundaryLabel hβ ∧ + p.2 = F.boundaryLabel (κ.pathMatch_mem hβ) + +/-- An anti-low pair is ordered: low label first. -/ +theorem AntiLowPair.lt [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + {o : κ.Orientation} {p : α × α} (h : AntiLowPair o p) : + p.1 < p.2 := by + obtain ⟨β, hβ, hm, h1, h2⟩ := h + obtain ⟨hβ', -, hlow, -⟩ := mem_antiLowSet.mp hm + rw [h1, h2] + exact hlow + +/-- Anti-canonical pairs survive enlarging the anti-canonical +set. -/ +theorem AntiLowPair.mono [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + {o o' : κ.Orientation} + (hsub : antiLowSet o' ⊆ antiLowSet o) {p : α × α} + (h : AntiLowPair o' p) : AntiLowPair o p := by + obtain ⟨β, hβ, hm, h1, h2⟩ := h + exact ⟨β, hβ, hsub hm, h1, h2⟩ + +/-- **Distinct anti-canonical chains have disjoint label pairs**: +the low ends are distinct low ends, so no end of one chord can be +an end of the other. -/ +theorem antiLowPair_disjoint [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + {o : κ.Orientation} {β γ : W.Flag} + (hβ : β ∈ F.boundaryFlags) (hγ : γ ∈ F.boundaryFlags) + (hβm : β ∈ antiLowSet o) (hγm : γ ∈ antiLowSet o) + (hne : β ≠ γ) : + PairDisjoint + (F.boundaryLabel hβ, F.boundaryLabel (κ.pathMatch_mem hβ)) + (F.boundaryLabel hγ, F.boundaryLabel (κ.pathMatch_mem hγ)) := by + obtain ⟨hβ', hintβ, hlowβ, -⟩ := mem_antiLowSet.mp hβm + obtain ⟨hγ', hintγ, hlowγ, -⟩ := mem_antiLowSet.mp hγm + refine ⟨?_, ?_, ?_, ?_⟩ + · intro he + exact hne (boundaryLabel_inj hβ hγ he) + · intro he + exact low_ne_pathMatch_of_low hγ hβ hlowγ hlowβ + (boundaryLabel_inj hβ (κ.pathMatch_mem hγ) he) + · intro he + exact low_ne_pathMatch_of_low hβ hγ hlowβ hlowγ + (boundaryLabel_inj (κ.pathMatch_mem hβ) hγ he).symm + · intro he + have h1 : κ.pathMatch β hβ = κ.pathMatch γ hγ := + boundaryLabel_inj (κ.pathMatch_mem hβ) + (κ.pathMatch_mem hγ) he + apply hne + calc β = κ.pathMatch (κ.pathMatch β hβ) + (κ.pathMatch_mem hβ) := (κ.pathMatch_invol hβ).symm + _ = κ.pathMatch (κ.pathMatch γ hγ) + (κ.pathMatch_mem hγ) := + κ.pathMatch_congr h1 (κ.pathMatch_mem hβ) + (κ.pathMatch_mem hγ) + _ = γ := κ.pathMatch_invol hγ + +end EdgeSubset + +namespace EdgeSubset + +variable {W : Fragment α} {F : EdgeSubset W} + +/-- The status difference of two systems: the labels whose +high-status differs — the potential of the canonical route's +accumulated relabel. -/ +noncomputable def statusDiff [LinearOrder α] + (κ κ' : F.RelTransitionSystem) : Finset α := + symmU (highSet κ) (highSet κ') + +/-- A system differs from itself nowhere: the relabel accumulated +along a trivial route is empty. -/ +theorem statusDiff_self [LinearOrder α] + (κ : F.RelTransitionSystem) : statusDiff κ κ = ∅ := + symmU_self _ + +/-- The status difference telescopes along chains. -/ +theorem statusDiff_trans [LinearOrder α] + (κ₁ κ₂ κ₃ : F.RelTransitionSystem) : + symmU (statusDiff κ₁ κ₂) (statusDiff κ₂ κ₃) = + statusDiff κ₁ κ₃ := + symmU_trans _ _ _ + +/-- Same-pairing endpoints have empty status difference. -/ +theorem statusDiff_of_samePairing [LinearOrder α] + {κ κ' : F.RelTransitionSystem} (h : SamePairing κ κ') : + statusDiff κ κ' = ∅ := by + unfold statusDiff + rw [highSet_of_samePairing h] + exact symmU_self _ + +end EdgeSubset + +/-- Propositional inequality as an exclusive disjunction, in the +`symmU` component order. -/ +theorem prop_ne_cases {P Q : Prop} (h : P ≠ Q) : + (P ∧ ¬Q) ∨ (¬P ∧ Q) := by + by_cases hP : P + · by_cases hQ : Q + · exact absurd (propext (iff_of_true hP hQ)) h + · exact Or.inl ⟨hP, hQ⟩ + · by_cases hQ : Q + · exact Or.inr ⟨hP, hQ⟩ + · exact absurd (propext (iff_of_false hP hQ)) h + +/-- One holds and the other does not, so they differ. -/ +theorem prop_ne_of_left {P Q : Prop} (hP : P) (hQ : ¬Q) : + P ≠ Q := by + intro h + rw [h] at hP + exact hQ hP + +/-- The mirrored case. -/ +theorem prop_ne_of_right {P Q : Prop} (hP : ¬P) (hQ : Q) : + P ≠ Q := by + intro h + rw [← h] at hQ + exact hP hQ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerStage.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerStage.lean new file mode 100644 index 0000000000..be632e510a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerStage.lean @@ -0,0 +1,436 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceCut + +/-! +# One stage of the interface recursion, with the matchings supplied + +The per-glue ledgers ask for two matchings and a handful of equations +between their pairings. In the recursion both matchings pair by an +involution of the labels — the chord matching by the subset's chords, +the interface matching by the swap — and the equations are then +automatic. This file states each stage with the interface matching +given that way, so that a stage consumes only the involution and the +one equation saying the glued labels are partners. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + +open Fragment Equiv +section StageOpen + +variable {α : Type} {W : Fragment α} + {i j : α} (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairOpen i j hij hopen).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetOpen hopen s', + W.pairing f ∈ liftSubsetOpen hopen s') + +local notation "Fg" => + (EdgeSubset.mk s' hc' : + EdgeSubset (W.gluePairOpen i j hij hopen)) + +local notation "Fl" => + (EdgeSubset.mk (liftSubsetOpen hopen s') hc : + EdgeSubset W) + +/-- **One stage at an open cut the subset uses.** The circuit count +and the number of components of the union move together. -/ +theorem ledgerStage_open + [LinearOrder α] [Fintype α] + {γ : Type} [LinearOrder γ] [Fintype γ] + (E : SurvivingLabel α i j ≃o γ) + (κ : (Fl).RelTransitionSystem) (o : κ.Orientation) + (o' : (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ).Orientation) + (o'' : (relabelTransUp E.toEquiv (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ)).Orientation) + (hpi : partnerSurvI hopen ∈ s') + (hbi : W.boundaryFlag i ∈ (Fl).boundaryFlags) + (hbj : W.boundaryFlag j ∈ (Fl).boundaryFlags) + (ι : α → α) (hcut : ι i = j) + {N : DirMatching (UsedLab (Fl))} + (hN : ∀ x : UsedLab (Fl), ((N.edge x).val : α) = ι x.val) + {Nr : DirMatching (UsedLab ((Fg).relabelUp E.toEquiv))} + (hNr : ∀ z : UsedLab (Fg), + (((Nr.map (usedLabRelabelEquiv E (Fg))).edge z).val.val : α) + = ι z.val.val) : + (relabelTransUp E.toEquiv (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ)).openCircuitCount + + DirMatching.unionCount + (cutMatching ((Fg).relabelUp E.toEquiv) + (relabelTransUp E.toEquiv (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ)) o'') Nr + = κ.openCircuitCount + + DirMatching.unionCount (cutMatching (Fl) κ o) N := by + have hNij : N.edge ⟨i, hbi⟩ = ⟨j, hbj⟩ := + edge_eq_of_swap (Fl) ι hN hbi hbj hcut + refine openCircuitCount_add_unionCount_stage hij hopen s' hc' hc E + κ o o' hpi hbi hbj hNij ?_ ?_ rfl + · exact restrict_edge_of_swap (Fl) (Fg) Subtype.val ι hN hNr hNij + (usedLabelGlueEquiv hij hopen s' hc' hc hbi hbj) (fun _ => rfl) + · exact funext (fun a => Subtype.ext + (cutMatching_relabelUp_edge E (Fg) _ o'' a)) + +/-- **One stage at an open cut the subset misses.** Nothing moves: +the two glued labels are unused, so the chord matching and the +interface matching both simply transport. -/ +theorem ledgerStage_open_miss + [LinearOrder α] [Fintype α] + {γ : Type} [LinearOrder γ] [Fintype γ] + (hni : partnerSurvI hopen ∉ s') + (E : SurvivingLabel α i j ≃o γ) + (κ : (Fl).RelTransitionSystem) (o : κ.Orientation) + (o' : (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ).Orientation) + (o'' : (relabelTransUp E.toEquiv (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ)).Orientation) + (ι : α → α) + {N : DirMatching (UsedLab (Fl))} + (hN : ∀ x : UsedLab (Fl), ((N.edge x).val : α) = ι x.val) + {Nr : DirMatching (UsedLab ((Fg).relabelUp E.toEquiv))} + (hNr : ∀ z : UsedLab (Fg), + (((Nr.map (usedLabRelabelEquiv E (Fg))).edge z).val.val : α) + = ι z.val.val) : + (relabelTransUp E.toEquiv (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ)).openCircuitCount + + DirMatching.unionCount + (cutMatching ((Fg).relabelUp E.toEquiv) + (relabelTransUp E.toEquiv (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ)) o'') Nr + = κ.openCircuitCount + + DirMatching.unionCount (cutMatching (Fl) κ o) N := by + refine openCircuitCount_add_unionCount_stage_miss hij hopen s' hc' + hc hni E κ o o' ?_ ?_ rfl + · funext y + refine Subtype.ext ?_ + exact (hNr ((usedLabelGlueMissEquiv hij hopen s' hc' hc + hni).symm y)).trans (hN y).symm + · exact funext (fun a => Subtype.ext + (cutMatching_relabelUp_edge E (Fg) _ o'' a)) + +end StageOpen + +section StageClosed + +variable {α : Type} {W : Fragment α} + {i j : α} + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairClosed i j hclosed).pairing f ∈ s') + (hcT : ∀ f ∈ liftSubsetClosed s' true, + W.pairing f ∈ liftSubsetClosed s' true) + +local notation "FgT" => + (EdgeSubset.mk s' hc' : EdgeSubset (W.gluePairClosed i j hclosed)) + +local notation "FlT" => + (EdgeSubset.mk (liftSubsetClosed s' true) hcT : EdgeSubset W) + +/-- **One stage at a closed cut the subset carries.** One component +of the union disappears, into the free circle the glue creates. -/ +theorem ledgerStage_closed + [LinearOrder α] [Fintype α] + {γ : Type} [LinearOrder γ] [Fintype γ] + (E : SurvivingLabel α i j ≃o γ) + (κ : (FlT).RelTransitionSystem) (o : κ.Orientation) + (o' : (RelTransitionSystem.glueClosed hclosed true s' hc' + hcT κ).Orientation) + (o₀ : (RelTransitionSystem.unglueClosed hclosed true s' hc' hcT + (RelTransitionSystem.glueClosed hclosed true s' hc' + hcT κ)).Orientation) + (o'' : (relabelTransUp E.toEquiv (FgT) + (RelTransitionSystem.glueClosed hclosed true s' hc' + hcT κ)).Orientation) + (hbi : W.boundaryFlag i ∈ (FlT).boundaryFlags) + (hbj : W.boundaryFlag j ∈ (FlT).boundaryFlags) + (ι : α → α) (hcut : ι i = j) + {N : DirMatching (UsedLab (FlT))} + (hN : ∀ x : UsedLab (FlT), ((N.edge x).val : α) = ι x.val) + {Nr : DirMatching (UsedLab ((FgT).relabelUp E.toEquiv))} + (hNr : ∀ z : UsedLab (FgT), + (((Nr.map (usedLabRelabelEquiv E (FgT))).edge z).val.val : α) + = ι z.val.val) : + (relabelTransUp E.toEquiv (FgT) + (RelTransitionSystem.glueClosed hclosed true s' hc' + hcT κ)).openCircuitCount + + DirMatching.unionCount + (cutMatching ((FgT).relabelUp E.toEquiv) + (relabelTransUp E.toEquiv (FgT) + (RelTransitionSystem.glueClosed hclosed true s' hc' + hcT κ)) o'') Nr + + 1 + = κ.openCircuitCount + + DirMatching.unionCount (cutMatching (FlT) κ o) N := by + have hNij : N.edge ⟨i, hbi⟩ = ⟨j, hbj⟩ := + edge_eq_of_swap (FlT) ι hN hbi hbj hcut + refine openCircuitCount_add_unionCount_stage_closed_forward hclosed + s' hc' hcT E κ o o' o₀ hbi hbj hNij ?_ ?_ rfl + · exact restrict_edge_of_swap (FlT) (FgT) Subtype.val ι hN hNr hNij + (usedLabelGlueClosedEquiv hclosed s' hc' hcT hbi hbj) + (fun _ => rfl) + · exact funext (fun a => Subtype.ext + (cutMatching_relabelUp_edge E (FgT) _ o'' a)) + +end StageClosed + +section StageClosedMiss + +variable {α : Type} {W : Fragment α} + {i j : α} (hij : i ≠ j) + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairClosed i j hclosed).pairing f ∈ s') + (hcF : ∀ f ∈ liftSubsetClosed s' false, + W.pairing f ∈ liftSubsetClosed s' false) + +local notation "FgF" => + (EdgeSubset.mk s' hc' : EdgeSubset (W.gluePairClosed i j hclosed)) + +local notation "FlF" => + (EdgeSubset.mk (liftSubsetClosed s' false) hcF : EdgeSubset W) + +include hij in +/-- **One stage at a closed cut the subset leaves out.** Nothing +moves; the free circle the glue creates carries no chord. -/ +theorem ledgerStage_closed_miss + [LinearOrder α] [Fintype α] + {γ : Type} [LinearOrder γ] + [Fintype γ] (E : SurvivingLabel α i j ≃o γ) + (κ : (FlF).RelTransitionSystem) (o : κ.Orientation) + (o' : (RelTransitionSystem.glueClosed hclosed false s' hc' + hcF κ).Orientation) + (o₀ : (RelTransitionSystem.unglueClosed hclosed false s' hc' hcF + (RelTransitionSystem.glueClosed hclosed false s' hc' + hcF κ)).Orientation) + (o'' : (relabelTransUp E.toEquiv (FgF) + (RelTransitionSystem.glueClosed hclosed false s' hc' + hcF κ)).Orientation) + (ι : α → α) + {N : DirMatching (UsedLab (FlF))} + (hN : ∀ x : UsedLab (FlF), ((N.edge x).val : α) = ι x.val) + {Nr : DirMatching (UsedLab ((FgF).relabelUp E.toEquiv))} + (hNr : ∀ z : UsedLab (FgF), + (((Nr.map (usedLabRelabelEquiv E (FgF))).edge z).val.val : α) + = ι z.val.val) : + (relabelTransUp E.toEquiv (FgF) + (RelTransitionSystem.glueClosed hclosed false s' hc' + hcF κ)).openCircuitCount + + DirMatching.unionCount + (cutMatching ((FgF).relabelUp E.toEquiv) + (relabelTransUp E.toEquiv (FgF) + (RelTransitionSystem.glueClosed hclosed false s' hc' + hcF κ)) o'') Nr + = κ.openCircuitCount + + DirMatching.unionCount (cutMatching (FlF) κ o) N := by + refine openCircuitCount_add_unionCount_stage_closed_miss_forward + hij hclosed s' hc' hcF E κ o o' o₀ ?_ ?_ rfl + · funext y + refine Subtype.ext ?_ + exact (hNr ((usedLabelGlueClosedMissEquiv hij hclosed s' hc' + hcF).symm y)).trans (hN y).symm + · exact funext (fun a => Subtype.ext + (cutMatching_relabelUp_edge E (FgF) _ o'' a)) + +end StageClosedMiss + +/-! ## The two cut kinds, each in one statement + +Whether the subset uses a cut is decided by the data, not by the +caller, so each kind of cut is better stated once: an open cut moves +nothing either way, and a closed one drops a component exactly when +the subset carries its edge. +-/ + +section StageOpenAny + +variable {α : Type} {W : Fragment α} + {i j : α} (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairOpen i j hij hopen).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetOpen hopen s', + W.pairing f ∈ liftSubsetOpen hopen s') + +local notation "Fg" => + (EdgeSubset.mk s' hc' : + EdgeSubset (W.gluePairOpen i j hij hopen)) + +local notation "Fl" => + (EdgeSubset.mk (liftSubsetOpen hopen s') hc : + EdgeSubset W) + +/-- **One stage at an open cut.** Nothing moves, whether or not the +subset uses the cut. -/ +theorem ledgerStage_open_any + [LinearOrder α] [Fintype α] + {γ : Type} [LinearOrder γ] [Fintype γ] + (E : SurvivingLabel α i j ≃o γ) + (κ : (Fl).RelTransitionSystem) (o : κ.Orientation) + (o' : (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ).Orientation) + (o'' : (relabelTransUp E.toEquiv (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ)).Orientation) + (ι : α → α) (hcut : ι i = j) + {N : DirMatching (UsedLab (Fl))} + (hN : ∀ x : UsedLab (Fl), ((N.edge x).val : α) = ι x.val) + {Nr : DirMatching (UsedLab ((Fg).relabelUp E.toEquiv))} + (hNr : ∀ z : UsedLab (Fg), + (((Nr.map (usedLabRelabelEquiv E (Fg))).edge z).val.val : α) + = ι z.val.val) : + (relabelTransUp E.toEquiv (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ)).openCircuitCount + + DirMatching.unionCount + (cutMatching ((Fg).relabelUp E.toEquiv) + (relabelTransUp E.toEquiv (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' + hc κ)) o'') Nr + = κ.openCircuitCount + + DirMatching.unionCount (cutMatching (Fl) κ o) N := by + by_cases hpi : partnerSurvI hopen ∈ s' + · exact ledgerStage_open hij hopen s' hc' hc E κ o o' o'' hpi + (boundaryFlagI_mem_boundaryFlags hij hopen s' hc hpi) + (boundaryFlagJ_mem_boundaryFlags hij hopen s' hc' hc hpi) + ι hcut hN hNr + · exact ledgerStage_open_miss hij hopen s' hc' hc hpi E κ o o' o'' ι + hN hNr + +end StageOpenAny + +section StageClosedBit + +variable {α : Type} {W : Fragment α} + {i j : α} (hij : i ≠ j) + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) (b : Bool) + (hc' : ∀ f ∈ s', (W.gluePairClosed i j hclosed).pairing f ∈ s') + (hcb : ∀ f ∈ liftSubsetClosed s' b, + W.pairing f ∈ liftSubsetClosed s' b) + +local notation "Fgb" => + (EdgeSubset.mk s' hc' : EdgeSubset (W.gluePairClosed i j hclosed)) + +local notation "Flb" => + (EdgeSubset.mk (liftSubsetClosed s' b) hcb : EdgeSubset W) + +include hij in +/-- **One stage at a closed cut.** A component of the union +disappears exactly when the subset carries the cut's own edge. -/ +theorem ledgerStage_closed_bit + [LinearOrder α] [Fintype α] + {γ : Type} [LinearOrder γ] [Fintype γ] + (E : SurvivingLabel α i j ≃o γ) + (κ : (Flb).RelTransitionSystem) (o : κ.Orientation) + (o' : (RelTransitionSystem.glueClosed hclosed b s' hc' + hcb κ).Orientation) + (o₀ : (RelTransitionSystem.unglueClosed hclosed b s' hc' hcb + (RelTransitionSystem.glueClosed hclosed b s' hc' + hcb κ)).Orientation) + (o'' : (relabelTransUp E.toEquiv (Fgb) + (RelTransitionSystem.glueClosed hclosed b s' hc' + hcb κ)).Orientation) + (ι : α → α) (hcut : ι i = j) + {N : DirMatching (UsedLab (Flb))} + (hN : ∀ x : UsedLab (Flb), ((N.edge x).val : α) = ι x.val) + {Nr : DirMatching (UsedLab ((Fgb).relabelUp E.toEquiv))} + (hNr : ∀ z : UsedLab (Fgb), + (((Nr.map (usedLabRelabelEquiv E (Fgb))).edge z).val.val : α) + = ι z.val.val) : + (relabelTransUp E.toEquiv (Fgb) + (RelTransitionSystem.glueClosed hclosed b s' hc' + hcb κ)).openCircuitCount + + DirMatching.unionCount + (cutMatching ((Fgb).relabelUp E.toEquiv) + (relabelTransUp E.toEquiv (Fgb) + (RelTransitionSystem.glueClosed hclosed b s' hc' + hcb κ)) o'') Nr + + (if b = true then 1 else 0) + = κ.openCircuitCount + + DirMatching.unionCount (cutMatching (Flb) κ o) N := by + cases b with + | false => + rw [ite_eq_right (by decide : ¬ (false = true)), Nat.add_zero] + exact ledgerStage_closed_miss hij hclosed s' hc' hcb E κ o o' o₀ + o'' ι hN hNr + | true => + rw [ite_eq_left rfl] + exact ledgerStage_closed hclosed s' hc' hcb E κ o o' o₀ o'' + (boundaryFlag_mem_boundaryFlags + ((boundaryFlagI_mem_liftClosed_iff hij s' true).mpr rfl)) + (boundaryFlag_mem_boundaryFlags + ((boundaryFlagJ_mem_liftClosed_iff hij s' true).mpr rfl)) + ι hcut hN hNr + +end StageClosedBit + +/-! ## Pairing across a glue + +Both glues read a surviving label as a label, so the pairing record +transports as soon as the glued swap does — one equation between +label maps, with the subset's own data nowhere in it. +-/ + +section PairedGlue + +variable {α : Type} {W : Fragment α} {i j : α} + +/-- **Pairing across a closed glue.** -/ +theorem swapPaired_glueClosed + (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) + (b : Bool) (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairClosed i j hclosed).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetClosed s' b, + W.pairing f ∈ liftSubsetClosed s' b) + (ι : α → α) (ιg : SurvivingLabel α i j → SurvivingLabel α i j) + (hcomp : ∀ x, ((ιg x).val : α) = ι x.val) + (hp : SwapPaired + (EdgeSubset.mk (liftSubsetClosed s' b) hc) ι) : + SwapPaired (EdgeSubset.mk s' hc' : + EdgeSubset (W.gluePairClosed i j hclosed)) ιg := + swapPaired_of_mem_iff _ _ ι ιg Subtype.val + (fun _ => mem_boundaryFlags_glueClosed hclosed b s' hc' hc) + hcomp hp + +/-- **Pairing across an open glue.** -/ +theorem swapPaired_glueOpen + [LinearOrder α] + (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairOpen i j hij hopen).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetOpen hopen s', + W.pairing f ∈ liftSubsetOpen hopen s') + (ι : α → α) (ιg : SurvivingLabel α i j → SurvivingLabel α i j) + (hcomp : ∀ x, ((ιg x).val : α) = ι x.val) + (hp : SwapPaired + (EdgeSubset.mk (liftSubsetOpen hopen s') hc) ι) : + SwapPaired (EdgeSubset.mk s' hc' : + EdgeSubset (W.gluePairOpen i j hij hopen)) ιg := + swapPaired_of_mem_iff _ _ ι ιg Subtype.val + (fun x => glued_participation_iff hij hopen s' hc' hc x) + hcomp hp + +end PairedGlue + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerValue.lean new file mode 100644 index 0000000000..f383ee4605 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerValue.lean @@ -0,0 +1,84 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepLedger + +/-! +# The ledgers in value form + +The pairing-preserving ledgers restated for the pairing-resolved +signed value: existence of a matching canonical orientation plus +equality of signed summands is exactly preservation of +`signedValueAt` together with transfer of canonical-orientation +existence. The single-step disjunct is a theorem +(`stepLedger_single`), so the move ledger in value form reduces to +the paired step in value form. +-/ + +@[expose] public section + +namespace RS + + + +/-- **The paired step, value form**: across a π-returning +repair block, canonical-orientation existence transfers and the +pairing-resolved signed value is preserved. -/ +def PairedValueLedger : Prop := + ∀ {α : Type} [LinearOrder α] {W : Fragment α} + {F : EdgeSubset W} {k ℓ : ℕ} (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (κ₁ κ₂ : F.RelTransitionSystem), + EdgeSubset.PairedStep κ₁ κ₂ → + Nonempty {o : κ₁.Orientation // EdgeSubset.PathCanonical o} → + Nonempty {o : κ₂.Orientation // EdgeSubset.PathCanonical o} ∧ + F.signedValueAt hM st hbnd κ₁ = F.signedValueAt hM st hbnd κ₂ + +namespace EdgeSubset + +variable {α : Type} + +/-- The paired step and its value form are equivalent. -/ +theorem pairedLedger_iff_value : + EdgeSubset.PairedLedger ↔ PairedValueLedger := by + constructor + · intro H α _ W F k ℓ hM st hbnd κ₁ κ₂ hps h₁ + obtain ⟨⟨o₁, hc₁⟩⟩ := h₁ + obtain ⟨o₂, hc₂, hval⟩ := H hM st hbnd κ₁ κ₂ hps o₁ hc₁ + refine ⟨⟨⟨o₂, hc₂⟩⟩, ?_⟩ + rw [signedValueAt_eq hM st hbnd o₁ hc₁, + signedValueAt_eq hM st hbnd o₂ hc₂] + exact hval.symm + · intro H α _ W F k ℓ hM st hbnd κ₁ κ₂ hps o₁ hc₁ + obtain ⟨⟨⟨o₂, hc₂⟩⟩, hval⟩ := + H hM st hbnd κ₁ κ₂ hps ⟨⟨o₁, hc₁⟩⟩ + refine ⟨o₂, hc₂, ?_⟩ + rw [← signedValueAt_eq hM st hbnd o₁ hc₁, + ← signedValueAt_eq hM st hbnd o₂ hc₂] + exact hval.symm + +/-- **Same-pairing invariance of the signed value from the value +step**: the full well-definedness with the paired input in +value form. -/ +theorem signedValueAt_samePairing_of_value + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + (HPaired : PairedValueLedger) {k ℓ : ℕ} + (hM : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ κ' : F.RelTransitionSystem} (hsp : SamePairing κ κ') : + F.signedValueAt hM st hbnd κ = + F.signedValueAt hM st hbnd κ' := + signedValueAt_samePairing + (matchPreservingLedger_of (pairedLedger_iff_value.mpr HPaired)) + hM st hbnd hsp + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopExample.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopExample.lean new file mode 100644 index 0000000000..569eded70b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopExample.lean @@ -0,0 +1,492 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseDischarge + +/-! +# The loop graph, evaluated + +The accompanying paper's worked example of Definition 2.1 (§2.4), +carried out in the flag model. With `k = 2` and `ℓ = 1`, the +functional +`h(θ)` of `charPolyFunctional` has `p_{h(θ)}` equal to the +characteristic polynomial `G ↦ det(θ I − A_G)` on graphs without +free circles (Regts–Sevenster, arXiv:1807.04494, Proposition 10), +and the graph `L` with one vertex and one loop has `A_L = (2)`. +So `p_{h(θ)}(L)` must be `θ − 2`, and +`mixedPartition_loopGraph` is that evaluation. + +The example is a convention check. Reaching `θ − 2` exercises, in +one number, the two incidences of a loop at its vertex, the +Eulerian condition, the circuit sign, the distinction between a +loop and a free circle, and the `η`-convention that makes the two +odd colourings contribute through a common basis vector. A sign +error in any one of them changes the answer. +-/ + +@[expose] public section + +namespace RS + +/-! ### The graph -/ + +/-- **The loop graph** `L`: one vertex, one edge, both of whose +flags are attached to that vertex. No boundary labels, and no free +circles — the loop is an edge, not a circle. -/ +def loopGraph : ClosedFragment where + Flag := Bool + Vertex := Unit + attach := fun _ => Sum.inl () + pairing := not + pairing_invol := Bool.not_not + pairing_ne := by decide + boundaryFlag := fun i => i.elim0 + attach_boundaryFlag := fun i => i.elim0 + eq_boundaryFlag := fun i => i.elim0 + circles := 0 + +/-! ### The functional -/ + +/-- **The paper's example functional** `h(θ)`, with `k = 2` and +`ℓ = 1`. On the paper's basis it is +`h(e₁^⊙i) = θ`, `h(e₁^⊙i ⊙ e₂) = √-1`, +`h(e₁^⊙i ⊗ ξ₁ ∧ η₁) = 1`, and zero elsewhere. + +The odd value carried here is the coefficient on the *sorted* wedge +`ξ₁ ∧ ξ₂`, which is `−1`: the symplectic partner of `ξ₁` is +`η₁ = −ξ₂`, so `ξ₁ ∧ η₁ = −ξ₁ ∧ ξ₂`. These are the partner +conventions of the paper's §2.4, and the two odd colourings each +contribute `−1` below. -/ +def charPolyFunctional (θ : ℂ) : MixedFunctional 2 1 := fun μ w => + if μ.count 1 = 0 then + (if w = ∅ then θ else if w = Finset.univ then -1 else 0) + else if μ.count 1 = 1 ∧ w = ∅ then Complex.I + else 0 + +/-! ### The two Eulerian subsets + +The loop has two half-edges at its vertex, so both the empty subset +and the whole loop are Eulerian, and no other flag set is closed +under the edge pairing. -/ + +/-- The empty flag set is closed under the edge pairing. -/ +private theorem loopEmpty_closed : + ∀ f ∈ (∅ : Finset loopGraph.Flag), + loopGraph.pairing f ∈ (∅ : Finset loopGraph.Flag) := + fun f hf => absurd hf (Finset.notMem_empty f) + +/-- So is the whole flag set. -/ +private theorem loopFull_closed : + ∀ f ∈ (Finset.univ : Finset loopGraph.Flag), + loopGraph.pairing f ∈ (Finset.univ : Finset loopGraph.Flag) := + fun _ _ => Finset.mem_univ _ + +/-- The empty edge subset. -/ +private def loopEmpty : EdgeSubset loopGraph := ⟨∅, loopEmpty_closed⟩ + +/-- The edge subset in which the loop participates. -/ +private def loopFull : EdgeSubset loopGraph := + ⟨Finset.univ, loopFull_closed⟩ + +/-- The vacuous transition system on the empty subset. -/ +private def loopEmptyTransition : loopEmpty.TransitionSystem where + match_ := id + match_invol := fun f hf => absurd hf (Finset.notMem_empty f) + match_ne := fun f hf => absurd hf (Finset.notMem_empty f) + match_mem := fun f hf => absurd hf (Finset.notMem_empty f) + match_vertex := fun f hf => absurd hf (Finset.notMem_empty f) + attach_internal := fun f hf => absurd hf (Finset.notMem_empty f) + +/-- The vacuous orientation on the empty subset. -/ +private def loopEmptyOrientation : loopEmptyTransition.Orientation where + isOut := fun _ => false + match_flip := fun f hf => absurd hf (Finset.notMem_empty f) + pairing_flip := fun f hf => absurd hf (Finset.notMem_empty f) + +/-- The transition system `κ_v` on the participating loop: the two +half-edges at the vertex are matched to each other. -/ +private def loopFullTransition : loopFull.TransitionSystem where + match_ := not + match_invol := fun f _ => Bool.not_not f + match_ne := fun f _ => by cases f <;> intro h <;> cases h + match_mem := fun f _ => Finset.mem_univ _ + match_vertex := fun _ _ _ hv => hv + attach_internal := fun _ _ => ⟨(), rfl⟩ + +/-- The orientation with `false` the incoming end of the loop. -/ +private def loopFullOrientation : loopFullTransition.Orientation where + isOut := id + match_flip := fun _ _ => rfl + pairing_flip := fun _ _ => rfl + +/-! ### Circuit counts -/ + +/-- Nothing participates, so there are no circuits. -/ +private theorem circuitCount_loopEmpty : + loopEmptyTransition.circuitCount = 0 := by + have : IsEmpty {f : loopGraph.Flag // f ∈ loopEmpty.flags} := + ⟨fun f => absurd f.prop (Finset.notMem_empty f.val)⟩ + unfold EdgeSubset.TransitionSystem.circuitCount + rw [Subsingleton.elim loopEmptyTransition.walkPerm 1, + Equiv.Perm.cycleType_one] + simp + +/-- The participating loop is a single circuit. Its walk map +`f ↦ κ(σ(f))` is the identity, because the edge pairing and the +vertex matching are the same involution here; a one-edge circuit +therefore appears as two walk fixed points, which is what the +halving in `circuitCount` is for. -/ +private theorem circuitCount_loopFull : + loopFullTransition.circuitCount = 1 := by + have hwalk : loopFullTransition.walkPerm = 1 := + Equiv.ext fun f => Subtype.ext (Bool.not_not f.val) + have hcard : + Fintype.card {f : loopGraph.Flag // f ∈ loopFull.flags} = 2 := + (Fintype.card_congr + (Equiv.subtypeUnivEquiv fun f => Finset.mem_univ f)).trans + (Fintype.card_bool) + have hfix : Fintype.card + ↥(Function.fixedPoints + (⇑(1 : Equiv.Perm + {f : loopGraph.Flag // f ∈ loopFull.flags}))) = 2 := + (Fintype.card_congr (Equiv.subtypeUnivEquiv fun _ => rfl)).trans hcard + unfold EdgeSubset.TransitionSystem.circuitCount + rw [hwalk, Equiv.Perm.cycleType_one, hfix] + simp + +/-! ### The colourings -/ + +/-- Even colourings of the loop, when nothing participates: a +single colour, constant along the edge. -/ +private def loopEmptyEvenEquiv : loopEmpty.EvenColouring 2 ≃ Fin 2 where + toFun ψ := ψ.val ⟨false, Finset.notMem_empty _⟩ + invFun c := ⟨fun _ => c, fun _ => rfl⟩ + left_inv ψ := Subtype.ext (funext fun f => by + obtain ⟨f, hf⟩ := f + cases f with + | false => rfl + | true => exact (ψ.prop ⟨false, Finset.notMem_empty _⟩).symm) + right_inv _ := rfl + +/-- Odd colourings of the participating loop: a single odd colour, +constant along the edge. -/ +private def loopFullOddEquiv : loopFull.OddColouring 1 ≃ Fin 2 where + toFun φ := φ.val ⟨false, Finset.mem_univ _⟩ + invFun c := ⟨fun _ => c, fun _ => rfl⟩ + left_inv φ := Subtype.ext (funext fun f => by + obtain ⟨f, hf⟩ := f + cases f with + | false => rfl + | true => exact (φ.prop ⟨false, Finset.mem_univ _⟩).symm) + right_inv _ := rfl + +/-- No flag participates, so the odd colouring is unique. -/ +private instance : Subsingleton (loopEmpty.OddColouring 1) := + ⟨fun _ _ => Subtype.ext (funext fun f => + absurd f.prop (Finset.notMem_empty f.val))⟩ + +/-- Every flag participates, so the even colouring is unique. -/ +private instance : Subsingleton (loopFull.EvenColouring 2) := + ⟨fun _ _ => Subtype.ext (funext fun f => + absurd (Finset.mem_univ f.val) f.prop)⟩ + +/-- An even colouring of the unparticipating loop takes one value. -/ +private theorem loopEmptyEven_const (ψ : loopEmpty.EvenColouring 2) + (f : {f : loopGraph.Flag // f ∉ loopEmpty.flags}) : + ψ.val f = loopEmptyEvenEquiv ψ := + (congrFun (congrArg Subtype.val + (loopEmptyEvenEquiv.symm_apply_apply ψ)) f).symm + +/-- An odd colouring of the participating loop takes one value. -/ +private theorem loopFullOdd_const (φ : loopFull.OddColouring 1) + (f : {f : loopGraph.Flag // f ∈ loopFull.flags}) : + φ.val f = loopFullOddEquiv φ := + (congrFun (congrArg Subtype.val + (loopFullOddEquiv.symm_apply_apply φ)) f).symm + +/-! ### Small facts about the graph -/ + +/-- The loop has a single vertex. -/ +private instance : Unique loopGraph.Vertex := + inferInstanceAs (Unique Unit) + +/-- Every flag of the loop is attached to its vertex. -/ +private theorem loopGraph_attach (f : loopGraph.Flag) + (v : loopGraph.Vertex) : loopGraph.attach f = Sum.inl v := + congrArg Sum.inl (Subsingleton.elim _ _) + +/-- The unique odd colouring when nothing participates. -/ +private def loopEmptyOdd : loopEmpty.OddColouring 1 := + ⟨fun f => absurd f.prop (Finset.notMem_empty f.val), + fun f => absurd f.prop (Finset.notMem_empty f.val)⟩ + +/-- The unique even colouring when the whole loop participates. -/ +private def loopFullEven : loopFull.EvenColouring 2 := + ⟨fun f => absurd (Finset.mem_univ f.val) f.prop, + fun f => absurd (Finset.mem_univ f.val) f.prop⟩ + +/-- The half-edge of the loop that the orientation makes +incoming. -/ +private def loopIn : loopGraph.Flag := false + +/-! ### The Eulerian condition -/ + +/-- The empty subset is Eulerian: every vertex has degree zero. -/ +private theorem eulerian_loopEmpty : loopEmpty.Eulerian := by + intro v + have hdeg : loopEmpty.deg v = 0 := by + unfold EdgeSubset.deg + rw [show loopEmpty.flags = ∅ from rfl, Finset.filter_empty, + Finset.card_empty] + rw [hdeg] + exact ⟨0, rfl⟩ + +/-- The whole loop is Eulerian: its two half-edges meet the single +vertex, which therefore has degree two. -/ +private theorem eulerian_loopFull : loopFull.Eulerian := by + intro v + let := Classical.decEq (loopGraph.Vertex ⊕ Fin 0) + have hdeg : loopFull.deg v = 2 := by + unfold EdgeSubset.deg + rw [Finset.filter_true_of_mem (fun f _ => loopGraph_attach f v), + show loopFull.flags = Finset.univ from rfl, Finset.card_univ] + exact Fintype.card_bool + rw [hdeg] + exact ⟨1, rfl⟩ + +/-! ### The value of the empty subset + +Nothing participates, so there is no odd sector and no circuit +sign. The loop's two colourings contribute `h(e₁ ⊙ e₁) = θ` and +`h(e₂ ⊙ e₂) = 0`. -/ + +open Classical in +/-- The even colours at the vertex are the colour of the loop, +counted once for each of its two incidences. -/ +private theorem evenColoursAt_loopEmpty (ψ : loopEmpty.EvenColouring 2) + (v : loopGraph.Vertex) : + loopEmpty.evenColoursAt ψ v = + Multiset.replicate 2 (loopEmptyEvenEquiv ψ) := by + have hcard : + Fintype.card {f : loopGraph.Flag // f ∉ loopEmpty.flags} = 2 := + (Fintype.card_congr (Equiv.subtypeUnivEquiv + fun f => Finset.notMem_empty f)).trans Fintype.card_bool + unfold EdgeSubset.evenColoursAt + rw [Finset.filter_true_of_mem (fun f _ => loopGraph_attach f.val v), + Multiset.map_congr rfl (fun f _ => loopEmptyEven_const ψ f), + Multiset.map_const', + show Multiset.card (Finset.univ : + Finset {f : loopGraph.Flag // f ∉ loopEmpty.flags}).val = + Fintype.card {f : loopGraph.Flag // f ∉ loopEmpty.flags} from rfl, + hcard] + +/-- No flag participates, so no flag is incoming. -/ +private theorem inFlagsAt_loopEmpty (v : loopGraph.Vertex) : + loopEmpty.inFlagsAt loopEmptyOrientation v = [] := by + let := loopGraph.flagOrder + let := Classical.dec + unfold EdgeSubset.inFlagsAt + rw [show loopEmpty.flags = ∅ from rfl, Finset.filter_empty, + Finset.sort_empty] + +/-- With nothing incoming there is no odd list. -/ +private theorem oddListAt_loopEmpty (φ : loopEmpty.OddColouring 1) + (v : loopGraph.Vertex) : + loopEmpty.oddListAt loopEmptyOrientation φ v = [] := by + unfold EdgeSubset.oddListAt + simp [inFlagsAt_loopEmpty] + +/-- With nothing incoming there is no odd sign. -/ +private theorem oddSignAt_loopEmpty (φ : loopEmpty.OddColouring 1) + (v : loopGraph.Vertex) : + loopEmpty.oddSignAt loopEmptyOrientation φ v = 1 := by + unfold EdgeSubset.oddSignAt + simp [inFlagsAt_loopEmpty] + +/-- The vertex value at a colouring of the unparticipating loop. -/ +private noncomputable def loopEmptyTerm (θ : ℂ) (c : Fin 2) : ℂ := + charPolyFunctional θ (Multiset.replicate 2 c) ∅ + +/-- Colouring the loop `e₁` gives `h(e₁ ⊙ e₁) = θ`. -/ +private theorem loopEmptyTerm_zero (θ : ℂ) : loopEmptyTerm θ 0 = θ := by + unfold loopEmptyTerm charPolyFunctional + norm_num [Multiset.count_replicate] + +/-- Colouring the loop `e₂` gives `h(e₂ ⊙ e₂) = 0`. -/ +private theorem loopEmptyTerm_one (θ : ℂ) : loopEmptyTerm θ 1 = 0 := by + unfold loopEmptyTerm charPolyFunctional + norm_num [Multiset.count_replicate] + +/-- **The empty subset contributes `θ`.** -/ +private theorem mixedValue_loopEmpty (θ : ℂ) : + loopEmpty.mixedValue (charPolyFunctional θ) = θ := by + rw [EdgeSubset.mixedValue_eq_summand_open loopEmpty _ + loopEmptyOrientation] + unfold EdgeSubset.mixedSummand + rw [circuitCount_loopEmpty, pow_zero, one_mul, + Fintype.sum_equiv loopEmptyEvenEquiv _ (loopEmptyTerm θ) + (fun ψ => ?_)] + · rw [Fin.sum_univ_two, loopEmptyTerm_zero, loopEmptyTerm_one, add_zero] + · rw [Fintype.sum_subsingleton _ loopEmptyOdd, Fintype.prod_unique, + oddSignAt_loopEmpty, oddListAt_loopEmpty, evenColoursAt_loopEmpty] + simp [MixedFunctional.evalOdd, loopEmptyTerm, sortSign, inversions] + +/-! ### The value of the participating loop + +The loop's two half-edges are matched to each other, so they form a +single κ-circuit and the summand carries the sign `(−1)¹`. There +are no even colours left, and the two odd colourings contribute +through the same basis vector of `Λ²V₁`. -/ + +/-- Exactly one half-edge of the loop is the incoming end. -/ +private theorem inFlagsAt_loopFull (v : loopGraph.Vertex) : + loopFull.inFlagsAt loopFullOrientation v = [loopIn] := by + let := loopGraph.flagOrder + let := Classical.dec + have hfilter : Finset.filter + (fun f => loopGraph.attach f = Sum.inl v ∧ + loopFullOrientation.isOut f = false) loopFull.flags = + {loopIn} := by + ext f + simp only [Finset.mem_filter, Finset.mem_singleton, + show loopFull.flags = Finset.univ from rfl, Finset.mem_univ, + true_and] + change (loopGraph.attach f = Sum.inl v ∧ f = loopIn) ↔ f = loopIn + exact ⟨fun h => h.2, fun h => ⟨loopGraph_attach f v, h⟩⟩ + unfold EdgeSubset.inFlagsAt + rw [hfilter, Finset.sort_singleton] + +/-- The odd list at the vertex: the incoming colour followed by the +partner index of the outgoing colour. -/ +private theorem oddListAt_loopFull (φ : loopFull.OddColouring 1) + (v : loopGraph.Vertex) : + loopFull.oddListAt loopFullOrientation φ v = + [loopFullOddEquiv φ, oddPartner 1 (loopFullOddEquiv φ)] := by + unfold EdgeSubset.oddListAt + simp [inFlagsAt_loopFull, EdgeSubset.oddPairFn, loopFullOdd_const, + List.flatMap_cons, List.flatMap_nil] + +/-- The odd sign at the vertex is the partner sign of the outgoing +colour. -/ +private theorem oddSignAt_loopFull (φ : loopFull.OddColouring 1) + (v : loopGraph.Vertex) : + loopFull.oddSignAt loopFullOrientation φ v = + oddPartnerSign 1 (loopFullOddEquiv φ) := by + unfold EdgeSubset.oddSignAt + simp [inFlagsAt_loopFull, EdgeSubset.oddSignFn, loopFullOdd_const] + +open Classical in +/-- Both half-edges participate, so no even colour survives. -/ +private theorem evenColoursAt_loopFull (ψ : loopFull.EvenColouring 2) + (v : loopGraph.Vertex) : loopFull.evenColoursAt ψ v = 0 := by + have : IsEmpty {f : loopGraph.Flag // f ∉ loopFull.flags} := + ⟨fun f => absurd (Finset.mem_univ f.val) f.prop⟩ + unfold EdgeSubset.evenColoursAt + rw [Finset.univ_eq_empty, Finset.filter_empty] + rfl + +/-- The vertex value at an odd colouring of the participating +loop. -/ +private noncomputable def loopFullTerm (θ : ℂ) (c : Fin 2) : ℂ := + (oddPartnerSign 1 c : ℂ) * + (charPolyFunctional θ).evalOdd 0 [c, oddPartner 1 c] + +/-- The colouring `ξ₁` contributes `1`: the partner sign is `−1` +and the wedge is already sorted, so the functional's `−1` is +recovered. -/ +private theorem loopFullTerm_zero (θ : ℂ) : loopFullTerm θ 0 = 1 := by + have huniv : (Finset.univ : Finset (Fin 2)) ≠ ∅ := by decide + unfold loopFullTerm charPolyFunctional MixedFunctional.evalOdd + norm_num [oddPartner, oddPartnerSign, sortSign, inversions, huniv, + show ([0, 1] : List (Fin 2)).toFinset = Finset.univ from by decide] + +/-- The colouring `ξ₂` contributes `1` as well: the partner sign is +`+1` and the wedge is reversed, so the two odd colourings agree. -/ +private theorem loopFullTerm_one (θ : ℂ) : loopFullTerm θ 1 = 1 := by + have huniv : (Finset.univ : Finset (Fin 2)) ≠ ∅ := by decide + unfold loopFullTerm charPolyFunctional MixedFunctional.evalOdd + norm_num [oddPartner, oddPartnerSign, sortSign, inversions, huniv, + show ([1, 0] : List (Fin 2)).toFinset = Finset.univ from by decide] + +/-- **The participating loop contributes `−2`**: two odd colourings, +each worth `1`, against the sign of the single κ-circuit. -/ +private theorem mixedValue_loopFull (θ : ℂ) : + loopFull.mixedValue (charPolyFunctional θ) = -2 := by + rw [EdgeSubset.mixedValue_eq_summand_open loopFull _ loopFullOrientation] + unfold EdgeSubset.mixedSummand + rw [circuitCount_loopFull, pow_one, + Fintype.sum_subsingleton _ loopFullEven, + Fintype.sum_equiv loopFullOddEquiv _ (loopFullTerm θ) (fun φ => ?_)] + · rw [Fin.sum_univ_two, loopFullTerm_zero, loopFullTerm_one] + norm_num + · rw [Fintype.prod_unique, oddSignAt_loopFull, oddListAt_loopFull, + evenColoursAt_loopFull] + rfl + +/-! ### The evaluation -/ + +/-- No other flag set is closed under the edge pairing: the loop's +two half-edges are each other's partners, so a subset containing one +contains the other. -/ +private theorem loop_pairing_not_closed : + ∀ s : Finset loopGraph.Flag, s ≠ ∅ → s ≠ Finset.univ → + ¬ ∀ f ∈ s, loopGraph.pairing f ∈ s := by + decide + +/-- The two Eulerian subsets are distinct. -/ +private theorem loop_empty_ne_univ : + (∅ : Finset loopGraph.Flag) ≠ Finset.univ := by + decide + +open Classical in +/-- **The paper's worked example**: the mixed partition function of +the functional `h(θ)` evaluates on the loop graph `L` to `θ − 2`, +the characteristic polynomial `det(θ I − A_L)` of its adjacency +matrix `A_L = (2)`. + +The two Eulerian subsets contribute `θ` and `−2` respectively. The +free-circle factor `(k − 2ℓ)^circles` is `0 ^ 0 = 1`: the loop is an +edge, not a free circle, and had it been one the value would have +been `0`. -/ +theorem mixedPartition_loopGraph (θ : ℂ) : + mixedPartition (charPolyFunctional θ) loopGraph = θ - 2 := by + unfold mixedPartition + rw [show loopGraph.circles = 0 from rfl, pow_zero, one_mul, + ← Finset.sum_subset (Finset.subset_univ + ({∅, Finset.univ} : Finset (Finset loopGraph.Flag))) + (fun x _ hx => dite_eq_right (loop_pairing_not_closed x + (fun h => hx (by rw [h]; exact Finset.mem_insert_self _ _)) + (fun h => hx (by + rw [h] + exact Finset.mem_insert_of_mem (Finset.mem_singleton_self _))))), + Finset.sum_pair loop_empty_ne_univ, + dite_eq_left loopEmpty_closed, dite_eq_left loopFull_closed] + change (if loopEmpty.Eulerian then + loopEmpty.mixedValue (charPolyFunctional θ) else 0) + + (if loopFull.Eulerian then + loopFull.mixedValue (charPolyFunctional θ) else 0) = θ - 2 + rw [ite_eq_left eulerian_loopEmpty, ite_eq_left eulerian_loopFull, + mixedValue_loopEmpty, mixedValue_loopFull] + ring + +/-- The loop graph with a free circle adjoined. -/ +def loopGraphCircle : ClosedFragment := { loopGraph with circles := 1 } + +/-- **A free circle annihilates.** Here `k − 2ℓ = 0`, so the paper's +`(k − 2ℓ)^circles` convention makes `p_{h(θ)}` vanish on every graph +carrying a free circle. Set beside `mixedPartition_loopGraph`, this +is the loop/free-circle distinction as a pair of numbers: the same +one-vertex graph is worth `θ − 2` when its edge is a loop and `0` +when a circle rides alongside. -/ +theorem mixedPartition_loopGraphCircle (θ : ℂ) : + mixedPartition (charPolyFunctional θ) loopGraphCircle = 0 := by + unfold mixedPartition + rw [show loopGraphCircle.circles = 1 from rfl] + norm_num + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopVerify.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopVerify.lean new file mode 100644 index 0000000000..4559e23649 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopVerify.lean @@ -0,0 +1,148 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransposeLedger + +/-! +# A repaired system carrying a path-canonical orientation + +The worked one-vertex fragment `TransposeVerify` (internal flags +`0–3`, boundary flags `4–7`) has three perfect matchings of its +internal flags. This module builds the second of them as a repair +of the first, `lvKappa₂R = cKappa.repair 0 1 2 3`, together with an +orientation `lvO₂flip` of it: the one obtained from `cO` by +flipping the boundary chain `5–1–3–6`. + +Against the fixed functional `cFunctional`, supported on the colour +set `{0, 5, 2, 7}` adapted to `cO`, that orientation's constrained +summand is `0` (`lvSummand₂flip`): the flipped in-list carries the +colours `{0, 7, 1, 6}` instead. The summand is computed through +`lvThroughSummand`, which is `cThroughSummand` with the functional +freed so that each orientation can be evaluated against its own +delta. + +`ThroughIndCFalse` uses exactly this: `cKappa` and `lvKappa₂R` both +carry path-canonical orientations with trivial chord sign, yet the +summands are `−1` and `0`, so the canonical value depends on the +boundary pairing and independence can only be asserted within one. +-/ + +@[expose] public section + +namespace RS + +namespace TransposeVerify + +open EdgeSubset + +/-! ## The repaired system -/ + +/-- `cKappa` repaired along `cSquare` (`0 1 2 3`): the matching +`0 ↔ 2`, `1 ↔ 3`, with chords `(4,7)` and `(5,6)`. -/ +def lvKappa₂R : cSubset.RelTransitionSystem := + cKappa.repair 0 1 2 3 cV cSquare + +/-! ## The flipped orientation -/ + +/-- `cO` with the boundary chain `5–1–3–6` (flags `1, 3`) +reversed — the chain carrying the colour `3`. -/ +def lvO₂flip : lvKappa₂R.Orientation where + isOut := ![false, false, true, true, false, false, false, false] + match_flip := fun f hf => by + rcases cInternal_cases hf with rfl | rfl | rfl | rfl <;> rfl + pairing_flip := fun f hf hp => by + rcases cInternal_cases hf with rfl | rfl | rfl | rfl <;> + · rcases cInternal_cases hp with h | h | h | h <;> + exact absurd h (by decide) + +/-! ## The generalized two-in-flag summand + +`cThroughSummand`, restated for an arbitrary functional (the +original is pinned to `cFunctional`); the proof is identical. -/ + +open Classical in +/-- The summand over a two-element in-list at an arbitrary +functional: `cThroughSummand` with the functional freed, so each +stage can be evaluated against its own adapted delta. -/ +theorem lvThroughSummand (hM : MixedFunctional 0 4) + (κ : cSubset.RelTransitionSystem) + (o : κ.Orientation) (g₁ g₂ : Fin 8) + (hglist : cSubset.relInFlagsAt o cV = [g₁, g₂]) : + cSubset.throughSummand hM cState cBnd o 0 = + ((oddPartnerSign 4 (cColour (κ.match_ g₁)) * + oddPartnerSign 4 (cColour (κ.match_ g₂)) : ℤ) : ℂ) * + MixedFunctional.evalOdd hM + (cSubset.evenColoursAt cPsi cV) + [cColour g₁, oddPartner 4 (cColour (κ.match_ g₁)), + cColour g₂, oddPartner 4 (cColour (κ.match_ g₂))] := by + unfold EdgeSubset.throughSummand + rw [cThroughProduct, pow_zero, one_mul, one_mul] + rw [Fintype.sum_subsingleton _ cPsi] + rw [ite_eq_left cEvenMatch] + have hzero : ∀ φ : cSubset.CoreOddColouring 4, φ ≠ cPhi → + (if cSubset.coreOddBoundaryMatch cState φ then + ∏ v : cFragment.Vertex, + ((cSubset.coreOddSignAt o φ v : ℂ) * + MixedFunctional.evalOdd hM + (cSubset.evenColoursAt cPsi v) + (cSubset.coreOddListAt o φ v)) + else 0) = 0 := by + intro φ hφ + rcases Classical.em (cSubset.coreOddBoundaryMatch cState φ) with + hb | hb + · exact absurd (cPhi_unique φ hb) hφ + · rw [ite_eq_right hb] + rw [Fintype.sum_eq_single cPhi hzero] + rw [ite_eq_left cOddMatch] + rw [Fintype.prod_subsingleton _ cV] + rw [cCoreOddSignAt κ o g₁ g₂ hglist, cCoreOddListAt κ o g₁ g₂ + hglist] + +/-! ## The summand against the fixed functional -/ + +open Classical in +/-- The flip kills the summand: the in-list colour set is +`{0, 7, 1, 6}`, outside the support `{0, 5, 2, 7}` of +`cFunctional`. -/ +theorem lvSummand₂flip : + cSubset.throughSummand cFunctional cState cBnd lvO₂flip 0 = + 0 := by + rcases cRelIn_pair (κ := lvKappa₂R) lvO₂flip rfl rfl rfl rfl 0 1 + (by decide) (by decide) with h | h + · rw [lvThroughSummand cFunctional lvKappa₂R lvO₂flip 0 1 h, + show lvKappa₂R.match_ 0 = 2 from by decide, + show lvKappa₂R.match_ 1 = 3 from by decide, + show [cColour 0, oddPartner 4 (cColour 2), cColour 1, + oddPartner 4 (cColour 3)] = + ([0, 7, 1, 6] : List (Fin (2 * 4))) from by decide, + MixedFunctional.evalOdd, + ite_eq_left (by decide : ([0, 7, 1, 6] : List (Fin (2 * 4))).Nodup), + show ([0, 7, 1, 6] : List (Fin (2 * 4))).toFinset = + ({0, 7, 1, 6} : Finset (Fin (2 * 4))) from by decide, + cFunctional_apply, + ite_eq_right (by decide : ¬ ({0, 7, 1, 6} : Finset (Fin (2 * 4))) = + ({0, 5, 2, 7} : Finset (Fin (2 * 4)))), + mul_zero, mul_zero] + · rw [lvThroughSummand cFunctional lvKappa₂R lvO₂flip 1 0 h, + show lvKappa₂R.match_ 0 = 2 from by decide, + show lvKappa₂R.match_ 1 = 3 from by decide, + show [cColour 1, oddPartner 4 (cColour 3), cColour 0, + oddPartner 4 (cColour 2)] = + ([1, 6, 0, 7] : List (Fin (2 * 4))) from by decide, + MixedFunctional.evalOdd, + ite_eq_left (by decide : ([1, 6, 0, 7] : List (Fin (2 * 4))).Nodup), + show ([1, 6, 0, 7] : List (Fin (2 * 4))).toFinset = + ({0, 7, 1, 6} : Finset (Fin (2 * 4))) from by decide, + cFunctional_apply, + ite_eq_right (by decide : ¬ ({0, 7, 1, 6} : Finset (Fin (2 * 4))) = + ({0, 5, 2, 7} : Finset (Fin (2 * 4)))), + mul_zero, mul_zero] + +end TransposeVerify + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/MixedPartition.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/MixedPartition.lean new file mode 100644 index 0000000000..ef7c9ee9ce --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/MixedPartition.lean @@ -0,0 +1,534 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.ListSign +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Eulerian + +/-! +# Mixed partition functions: the vertex functional + +The mixed partition function (Regts–Sevenster arXiv:1807.04494, +Definition 5) is defined in `RS/Definitions.lean`. This module +proves the evaluator's antisymmetry — reordering an odd list +changes `evalOdd` by the sign of the permutation, and lists with +repeated colours evaluate to zero — and the transport of the +Definition 5 summand along fragment equivalences. +-/ + +@[expose] public section + +namespace RS + +/-- Evaluation on a list with a repetition vanishes. -/ +theorem MixedFunctional.evalOdd_of_not_nodup {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (μ : Multiset (Fin k)) + {w : List (Fin (2 * ℓ))} (hw : ¬ w.Nodup) : + h.evalOdd μ w = 0 := by + simp [MixedFunctional.evalOdd, hw] + +/-- Swapping distinct adjacent odd colours flips the alternating +evaluation. -/ +theorem MixedFunctional.evalOdd_swap_adjacent {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (μ : Multiset (Fin k)) + (l₁ l₂ : List (Fin (2 * ℓ))) {a b : Fin (2 * ℓ)} (hab : a ≠ b) : + h.evalOdd μ (l₁ ++ b :: a :: l₂) = + -h.evalOdd μ (l₁ ++ a :: b :: l₂) := by + unfold MixedFunctional.evalOdd + have hperm : (l₁ ++ b :: a :: l₂).Perm (l₁ ++ a :: b :: l₂) := + List.Perm.append_left l₁ (List.Perm.swap a b l₂) + by_cases hnd : (l₁ ++ a :: b :: l₂).Nodup + · have hnd' : (l₁ ++ b :: a :: l₂).Nodup := hperm.nodup_iff.mpr hnd + rw [ite_eq_left hnd', ite_eq_left hnd, sortSign_swap_adjacent l₁ l₂ hab, + show (l₁ ++ b :: a :: l₂).toFinset = + (l₁ ++ a :: b :: l₂).toFinset from + Finset.ext fun x => by + simp only [List.mem_toFinset] + exact hperm.mem_iff] + push_cast + ring + · rw [ite_eq_right (fun hh => hnd (hperm.nodup_iff.mp hh)), ite_eq_right hnd, + neg_zero] + +/-- Moving a two-element block of odd colours past another preserves +the alternating evaluation. -/ +theorem MixedFunctional.evalOdd_pair_block_swap {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (μ : Multiset (Fin k)) + (l₁ l₂ : List (Fin (2 * ℓ))) {p₁ p₂ q₁ q₂ : Fin (2 * ℓ)} + (hp₁q₁ : p₁ ≠ q₁) (hp₁q₂ : p₁ ≠ q₂) + (hp₂q₁ : p₂ ≠ q₁) (hp₂q₂ : p₂ ≠ q₂) : + h.evalOdd μ (l₁ ++ q₁ :: q₂ :: p₁ :: p₂ :: l₂) = + h.evalOdd μ (l₁ ++ p₁ :: p₂ :: q₁ :: q₂ :: l₂) := by + unfold MixedFunctional.evalOdd + have hperm : (l₁ ++ q₁ :: q₂ :: p₁ :: p₂ :: l₂).Perm + (l₁ ++ p₁ :: p₂ :: q₁ :: q₂ :: l₂) := by + refine List.Perm.append_left l₁ ?_ + have hblocks : ([q₁, q₂] ++ [p₁, p₂]).Perm ([p₁, p₂] ++ [q₁, q₂]) := + List.perm_append_comm + simpa using hblocks.append_right l₂ + by_cases hnd : (l₁ ++ p₁ :: p₂ :: q₁ :: q₂ :: l₂).Nodup + · have hnd' := hperm.nodup_iff.mpr hnd + rw [ite_eq_left hnd', ite_eq_left hnd, + sortSign_pair_block_swap l₁ l₂ hp₁q₁ hp₁q₂ hp₂q₁ hp₂q₂, + show (l₁ ++ q₁ :: q₂ :: p₁ :: p₂ :: l₂).toFinset = + (l₁ ++ p₁ :: p₂ :: q₁ :: q₂ :: l₂).toFinset from + Finset.ext fun x => by + simp only [List.mem_toFinset] + exact hperm.mem_iff] + · rw [ite_eq_right (fun hh => hnd (hperm.nodup_iff.mp hh)), ite_eq_right hnd] + +/-- The alternating evaluation is invariant under permuting a list +of length-two blocks: each transposition of adjacent blocks moves +an even number of elements. -/ +theorem MixedFunctional.evalOdd_flatMap_perm {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (μ : Multiset (Fin k)) {β : Type} + (pairFn : β → List (Fin (2 * ℓ))) + (hlen : ∀ b, (pairFn b).length = 2) + {l₁ l₂ : List β} (hperm : l₁.Perm l₂) : + ∀ pre : List (Fin (2 * ℓ)), + h.evalOdd μ (pre ++ l₁.flatMap pairFn) = + h.evalOdd μ (pre ++ l₂.flatMap pairFn) := by + induction hperm with + | nil => intro pre; rfl + | cons b _ ih => + intro pre + simp only [List.flatMap_cons, ← List.append_assoc] + exact ih (pre ++ pairFn b) + | swap p q rest => + intro pre + obtain ⟨q₁, q₂, hq⟩ := List.length_eq_two.mp (hlen q) + obtain ⟨p₁, p₂, hp⟩ := List.length_eq_two.mp (hlen p) + simp only [List.flatMap_cons, hp, hq, List.cons_append, + List.nil_append] + by_cases hnd : + (pre ++ p₁ :: p₂ :: q₁ :: q₂ :: rest.flatMap pairFn).Nodup + · have hnd4 := hnd + rw [List.nodup_append] at hnd4 + have hfour := hnd4.2.1 + simp only [List.nodup_cons, List.mem_cons] at hfour + exact h.evalOdd_pair_block_swap μ pre (rest.flatMap pairFn) + (fun he => hfour.1 (Or.inr (Or.inl he))) + (fun he => hfour.1 (Or.inr (Or.inr (Or.inl he)))) + (fun he => hfour.2.1 (Or.inl he)) + (fun he => hfour.2.1 (Or.inr (Or.inl he))) + · have hperm2 : + (pre ++ q₁ :: q₂ :: p₁ :: p₂ :: rest.flatMap pairFn).Perm + (pre ++ p₁ :: p₂ :: q₁ :: q₂ :: rest.flatMap pairFn) := by + refine List.Perm.append_left pre ?_ + have hblocks : ([q₁, q₂] ++ [p₁, p₂]).Perm + ([p₁, p₂] ++ [q₁, q₂]) := List.perm_append_comm + simpa using hblocks.append_right (rest.flatMap pairFn) + rw [h.evalOdd_of_not_nodup μ + (fun hh => hnd (hperm2.nodup_iff.mp hh)), + h.evalOdd_of_not_nodup μ hnd] + | trans _ _ ih₁ ih₂ => + intro pre + exact (ih₁ pre).trans (ih₂ pre) + +/-- The odd-colour pairing is an involution. -/ +theorem oddPartner_invol (ℓ : ℕ) (c : Fin (2 * ℓ)) : + oddPartner ℓ (oddPartner ℓ c) = c := by + unfold oddPartner + by_cases h : c.val < ℓ + · rw [dite_eq_left h, dite_eq_right (show ¬ c.val + ℓ < ℓ by omega)] + exact Fin.ext (by change c.val + ℓ - ℓ = c.val; omega) + · have hc : c.val < 2 * ℓ := c.isLt + rw [dite_eq_right h, dite_eq_left (show c.val - ℓ < ℓ by omega)] + exact Fin.ext (by change c.val - ℓ + ℓ = c.val; omega) + +/-- Flags attached at the vertex and incoming are in the incoming +list. -/ +theorem mem_inFlagsAt_of {α : Type} {W : Fragment α} + {F : EdgeSubset W} {κ : F.TransitionSystem} {o : κ.Orientation} + {v : W.Vertex} + {f : W.Flag} (hmem : f ∈ F.flags) + (hatt : W.attach f = Sum.inl v) + (hin : o.isOut f = false) : f ∈ F.inFlagsAt o v := by + let := W.flagOrder + let := Classical.dec + unfold EdgeSubset.inFlagsAt + rw [Finset.mem_sort, Finset.mem_filter] + exact ⟨hmem, hatt, hin⟩ + +section Transport + +variable {α : Type} {W : Fragment α} + +/-- Transport of an orientation along a fragment equivalence. -/ +noncomputable def EdgeSubset.TransitionSystem.Orientation.transport + {W₁ W₂ : Fragment α} (e : W₁.Equiv W₂) {F : EdgeSubset W₁} + {κ : F.TransitionSystem} (o : κ.Orientation) : + (κ.transport e).Orientation where + isOut := fun f => o.isOut (e.flagEquiv.symm f) + match_flip := fun f hf => by + change o.isOut (e.flagEquiv.symm + (e.flagEquiv (κ.match_ (e.flagEquiv.symm f)))) = _ + rw [Equiv.symm_apply_apply] + exact o.match_flip _ ((EdgeSubset.mem_transport_iff e F f).mp hf) + pairing_flip := fun f hf => by + show o.isOut (e.flagEquiv.symm (W₂.pairing f)) = _ + have hp := e.pairing_comm (e.flagEquiv.symm f) + rw [Equiv.apply_symm_apply] at hp + rw [← hp, Equiv.symm_apply_apply] + exact o.pairing_flip _ ((EdgeSubset.mem_transport_iff e F f).mp hf) + +/-- The complement flag equivalence of a transported edge +subset. -/ +noncomputable def EdgeSubset.transportComplEquiv {W₁ W₂ : Fragment α} + (e : W₁.Equiv W₂) (F : EdgeSubset W₁) : + {f : W₁.Flag // f ∉ F.flags} ≃ + {f : W₂.Flag // f ∉ (EdgeSubset.transport e F).flags} := + e.flagEquiv.subtypeEquiv (fun f => by + rw [EdgeSubset.mem_transport_iff, Equiv.symm_apply_apply]) + +/-- Transport of even colourings along a fragment equivalence. -/ +noncomputable def EdgeSubset.EvenColouring.transport + {W₁ W₂ : Fragment α} (e : W₁.Equiv W₂) {F : EdgeSubset W₁} + {k : ℕ} (ψ : F.EvenColouring k) : + (EdgeSubset.transport e F).EvenColouring k := + ⟨fun f => ψ.val ((EdgeSubset.transportComplEquiv e F).symm f), + fun f => by + have harg : e.flagEquiv.symm (W₂.pairing f.val) = + W₁.pairing (e.flagEquiv.symm f.val) := by + have hp := e.pairing_comm (e.flagEquiv.symm f.val) + rw [Equiv.apply_symm_apply] at hp + rw [← hp, Equiv.symm_apply_apply] + exact (congrArg ψ.val (Subtype.ext harg)).trans (ψ.prop _)⟩ + +/-- Transport of odd colourings along a fragment equivalence. -/ +noncomputable def EdgeSubset.OddColouring.transport + {W₁ W₂ : Fragment α} (e : W₁.Equiv W₂) {F : EdgeSubset W₁} + {ℓ : ℕ} (φ : F.OddColouring ℓ) : + (EdgeSubset.transport e F).OddColouring ℓ := + ⟨fun f => φ.val ((EdgeSubset.transportFlagsEquiv e F).symm f), + fun f => by + have harg : e.flagEquiv.symm (W₂.pairing f.val) = + W₁.pairing (e.flagEquiv.symm f.val) := by + have hp := e.pairing_comm (e.flagEquiv.symm f.val) + rw [Equiv.apply_symm_apply] at hp + rw [← hp, Equiv.symm_apply_apply] + exact (congrArg φ.val (Subtype.ext harg)).trans (φ.prop _)⟩ + +open Classical in +/-- The even-colour multiset is preserved by transport. -/ +theorem EdgeSubset.evenColoursAt_transport {W₁ W₂ : Fragment α} + (e : W₁.Equiv W₂) {F : EdgeSubset W₁} {k : ℕ} + (ψ : F.EvenColouring k) (v : W₁.Vertex) : + (EdgeSubset.transport e F).evenColoursAt + (EdgeSubset.EvenColouring.transport e ψ) (e.vertexEquiv v) = + F.evenColoursAt ψ v := by + unfold EdgeSubset.evenColoursAt + rw [show (Finset.univ : + Finset {f : W₂.Flag // f ∉ (EdgeSubset.transport e F).flags}) = + Finset.univ.map (EdgeSubset.transportComplEquiv e F).toEmbedding + from (Finset.map_univ_equiv _).symm] + rw [Finset.filter_map] + rw [show ((Finset.filter _ Finset.univ).map + (EdgeSubset.transportComplEquiv e F).toEmbedding).val = + (Finset.filter _ Finset.univ).val.map + (EdgeSubset.transportComplEquiv e F) from rfl] + rw [Multiset.map_map] + congr 1 + · funext x + change ψ.val ((EdgeSubset.transportComplEquiv e F).symm + ((EdgeSubset.transportComplEquiv e F) x)) = ψ.val x + rw [Equiv.symm_apply_apply] + · have hfilter : Finset.filter + ((fun f => W₂.attach f.val = Sum.inl (e.vertexEquiv v)) ∘ + (EdgeSubset.transportComplEquiv e F).toEmbedding) + Finset.univ = + Finset.filter + (fun f : {f : W₁.Flag // f ∉ F.flags} => + W₁.attach f.val = Sum.inl v) Finset.univ := by + apply Finset.filter_congr + intro f _ + rw [Function.comp_apply, Equiv.coe_toEmbedding] + constructor + · intro hf + have hcomm := e.attach_comm f.val + rw [show ((EdgeSubset.transportComplEquiv e F) f).val = + e.flagEquiv f.val from rfl] at hf + rw [hf] at hcomm + rcases ha : W₁.attach f.val with w | ℓ + · rw [ha] at hcomm + simp only [Sum.map_inl] at hcomm + exact congrArg Sum.inl + (e.vertexEquiv.injective (Sum.inl.inj hcomm.symm)) + · rw [ha] at hcomm + simp at hcomm + · intro hf + have hcomm := e.attach_comm f.val + rw [hf] at hcomm + rw [show ((EdgeSubset.transportComplEquiv e F) f).val = + e.flagEquiv f.val from rfl] + simpa using hcomm + rw [hfilter] + +open Classical in +/-- The transported in-flag list is a permutation of the image of +the original: both enumerate the same transported filter set. -/ +theorem EdgeSubset.inFlagsAt_transport_perm {W₁ W₂ : Fragment α} + (e : W₁.Equiv W₂) {F : EdgeSubset W₁} + {κ : F.TransitionSystem} (o : κ.Orientation) (v : W₁.Vertex) : + ((EdgeSubset.transport e F).inFlagsAt + (EdgeSubset.TransitionSystem.Orientation.transport e o) + (e.vertexEquiv v)).Perm + ((F.inFlagsAt o v).map e.flagEquiv) := by + rw [← Multiset.coe_eq_coe] + unfold EdgeSubset.inFlagsAt + rw [Finset.sort_eq, ← Multiset.map_coe, Finset.sort_eq] + refine (Multiset.Nodup.ext ?_ ?_).mpr ?_ + · exact Finset.nodup _ + · exact Multiset.Nodup.map e.flagEquiv.injective (Finset.nodup _) + · intro g + simp only [Finset.mem_val, Multiset.mem_map, Finset.mem_filter, + EdgeSubset.mem_transport_iff] + constructor + · rintro ⟨hmem, hatt, hout⟩ + refine ⟨e.flagEquiv.symm g, ⟨hmem, ?_, ?_⟩, ?_⟩ + · have hcomm := e.attach_comm (e.flagEquiv.symm g) + rw [Equiv.apply_symm_apply, hatt] at hcomm + rcases ha : W₁.attach (e.flagEquiv.symm g) with w | ℓ + · rw [ha] at hcomm + simp only [Sum.map_inl] at hcomm + exact congrArg Sum.inl + (e.vertexEquiv.injective (Sum.inl.inj hcomm)).symm + · rw [ha] at hcomm + simp at hcomm + · exact hout + · exact Equiv.apply_symm_apply _ _ + · rintro ⟨x, ⟨hmem, hatt, hout⟩, rfl⟩ + refine ⟨?_, ?_, ?_⟩ + · rwa [Equiv.symm_apply_apply] + · have hcomm := e.attach_comm x + rw [hatt] at hcomm + simpa using hcomm + · change o.isOut (e.flagEquiv.symm (e.flagEquiv x)) = false + rwa [Equiv.symm_apply_apply] + +/-- A transported odd colouring evaluated at a transported flag is +the original colour. -/ +theorem EdgeSubset.OddColouring.transport_apply {W₁ W₂ : Fragment α} + (e : W₁.Equiv W₂) {F : EdgeSubset W₁} {ℓ : ℕ} + (φ : F.OddColouring ℓ) (g : W₁.Flag) (hg : g ∈ F.flags) + (hg' : e.flagEquiv g ∈ (EdgeSubset.transport e F).flags) : + (EdgeSubset.OddColouring.transport e φ).val ⟨e.flagEquiv g, hg'⟩ = + φ.val ⟨g, hg⟩ := by + change φ.val + ((EdgeSubset.transportFlagsEquiv e F).symm ⟨e.flagEquiv g, hg'⟩) = _ + exact congrArg φ.val (Subtype.ext (Equiv.symm_apply_apply _ _)) + +/-- The transported matching at a transported flag is the +transported matched flag. -/ +theorem EdgeSubset.TransitionSystem.transport_match + {W₁ W₂ : Fragment α} (e : W₁.Equiv W₂) {F : EdgeSubset W₁} + (κ : F.TransitionSystem) (g : W₁.Flag) : + (κ.transport e).match_ (e.flagEquiv g) = + e.flagEquiv (κ.match_ g) := by + change e.flagEquiv (κ.match_ (e.flagEquiv.symm (e.flagEquiv g))) = _ + rw [Equiv.symm_apply_apply] + +open Classical in +/-- The odd pair at a transported flag under transported data is +the original odd pair. -/ +theorem EdgeSubset.oddPairFn_transport {W₁ W₂ : Fragment α} + (e : W₁.Equiv W₂) {F : EdgeSubset W₁} {ℓ : ℕ} + (κ : F.TransitionSystem) (φ : F.OddColouring ℓ) + (f : {f : W₁.Flag // f ∈ F.flags}) + (hf : e.flagEquiv f.val ∈ (EdgeSubset.transport e F).flags) : + (EdgeSubset.transport e F).oddPairFn (κ.transport e) + (EdgeSubset.OddColouring.transport e φ) + ⟨e.flagEquiv f.val, hf⟩ = + F.oddPairFn κ φ f := by + unfold EdgeSubset.oddPairFn + simp only [EdgeSubset.TransitionSystem.transport_match] + rw [EdgeSubset.OddColouring.transport_apply e φ f.val f.prop, + EdgeSubset.OddColouring.transport_apply e φ (κ.match_ f.val) + (κ.match_mem _ f.prop)] + +open Classical in +/-- The odd sign at a transported flag under transported data is +the original odd sign. -/ +theorem EdgeSubset.oddSignFn_transport {W₁ W₂ : Fragment α} + (e : W₁.Equiv W₂) {F : EdgeSubset W₁} {ℓ : ℕ} + (κ : F.TransitionSystem) (φ : F.OddColouring ℓ) + (f : {f : W₁.Flag // f ∈ F.flags}) + (hf : e.flagEquiv f.val ∈ (EdgeSubset.transport e F).flags) : + (EdgeSubset.transport e F).oddSignFn (κ.transport e) + (EdgeSubset.OddColouring.transport e φ) + ⟨e.flagEquiv f.val, hf⟩ = + F.oddSignFn κ φ f := by + unfold EdgeSubset.oddSignFn + simp only [EdgeSubset.TransitionSystem.transport_match] + rw [EdgeSubset.OddColouring.transport_apply e φ (κ.match_ f.val) + (κ.match_mem _ f.prop)] + +open Classical in +/-- Membership of the flags of a mapped in-flag list. -/ +private theorem mem_transport_of_mem_map_inFlagsAt {W₁ W₂ : Fragment α} + (e : W₁.Equiv W₂) {F : EdgeSubset W₁} {κ : F.TransitionSystem} + {o : κ.Orientation} {v : W₁.Vertex} {g : W₂.Flag} + (hg : g ∈ (F.inFlagsAt o v).map e.flagEquiv) : + g ∈ (EdgeSubset.transport e F).flags := by + obtain ⟨f, hfl, rfl⟩ := List.mem_map.mp hg + rw [EdgeSubset.mem_transport_iff, Equiv.symm_apply_apply] + exact F.mem_of_mem_inFlagsAt hfl + +open Classical in +/-- The odd sign at a vertex is preserved by transport. -/ +theorem EdgeSubset.oddSignAt_transport {W₁ W₂ : Fragment α} + (e : W₁.Equiv W₂) {F : EdgeSubset W₁} {ℓ : ℕ} + {κ : F.TransitionSystem} (o : κ.Orientation) + (φ : F.OddColouring ℓ) (v : W₁.Vertex) : + (EdgeSubset.transport e F).oddSignAt + (EdgeSubset.TransitionSystem.Orientation.transport e o) + (EdgeSubset.OddColouring.transport e φ) (e.vertexEquiv v) = + F.oddSignAt o φ v := by + unfold EdgeSubset.oddSignAt + have hstep := perm_pmap Subtype.mk (F.inFlagsAt_transport_perm e o v) + (fun _ hf => EdgeSubset.mem_of_mem_inFlagsAt hf) + (fun _ hg => mem_transport_of_mem_map_inFlagsAt e hg) + refine ((hstep.map ((EdgeSubset.transport e F).oddSignFn + (κ.transport e) (EdgeSubset.OddColouring.transport e φ))).prod_eq).trans + ?_ + rw [List.map_pmap, List.pmap_map, List.attachWith, List.map_pmap] + exact congrArg List.prod (List.pmap_congr_left _ (fun a ha h₁ h₂ => + EdgeSubset.oddSignFn_transport e κ φ ⟨a, h₂⟩ h₁)) + +open Classical in +/-- The alternating evaluation of the odd list at a vertex is +preserved by transport: the in-flag order changes only by moving +whole pairs, and pair blocks move evenly. -/ +theorem EdgeSubset.evalOdd_oddListAt_transport {W₁ W₂ : Fragment α} + (e : W₁.Equiv W₂) {F : EdgeSubset W₁} {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (μ : Multiset (Fin k)) + {κ : F.TransitionSystem} (o : κ.Orientation) + (φ : F.OddColouring ℓ) (v : W₁.Vertex) : + h.evalOdd μ ((EdgeSubset.transport e F).oddListAt + (EdgeSubset.TransitionSystem.Orientation.transport e o) + (EdgeSubset.OddColouring.transport e φ) (e.vertexEquiv v)) = + h.evalOdd μ (F.oddListAt o φ v) := by + unfold EdgeSubset.oddListAt + have hstep := perm_pmap Subtype.mk (F.inFlagsAt_transport_perm e o v) + (fun _ hf => EdgeSubset.mem_of_mem_inFlagsAt hf) + (fun _ hg => mem_transport_of_mem_map_inFlagsAt e hg) + have h1 := h.evalOdd_flatMap_perm μ + ((EdgeSubset.transport e F).oddPairFn (κ.transport e) + (EdgeSubset.OddColouring.transport e φ)) + (fun _ => rfl) hstep [] + simp only [List.nil_append] at h1 + refine h1.trans ?_ + rw [List.pmap_map, List.attachWith] + exact congrArg (h.evalOdd μ) (pmap_flatMap_congr _ _ _ _ _ _ _ + (fun a ha h₁ h₂ => EdgeSubset.oddPairFn_transport e κ φ ⟨a, h₂⟩ h₁)) + +/-- Transport of even colourings as an equivalence. -/ +noncomputable def EdgeSubset.EvenColouring.transportEquiv + {W₁ W₂ : Fragment α} (e : W₁.Equiv W₂) (F : EdgeSubset W₁) + (k : ℕ) : + F.EvenColouring k ≃ (EdgeSubset.transport e F).EvenColouring k where + toFun := EdgeSubset.EvenColouring.transport e + invFun ψ := ⟨fun f => ψ.val (EdgeSubset.transportComplEquiv e F f), + fun f => by + have harg : (EdgeSubset.transportComplEquiv e F + ⟨W₁.pairing f.val, F.pairing_not_mem f.prop⟩).val = + W₂.pairing (EdgeSubset.transportComplEquiv e F f).val := by + change e.flagEquiv (W₁.pairing f.val) = W₂.pairing (e.flagEquiv f.val) + exact e.pairing_comm f.val + exact (congrArg ψ.val (Subtype.ext harg)).trans (ψ.prop _)⟩ + left_inv ψ := Subtype.ext (funext fun f => congrArg ψ.val + (Equiv.symm_apply_apply _ _)) + right_inv ψ := Subtype.ext (funext fun f => congrArg ψ.val + (Equiv.apply_symm_apply _ _)) + +/-- Transport of odd colourings as an equivalence. -/ +noncomputable def EdgeSubset.OddColouring.transportEquiv + {W₁ W₂ : Fragment α} (e : W₁.Equiv W₂) (F : EdgeSubset W₁) + (ℓ : ℕ) : + F.OddColouring ℓ ≃ (EdgeSubset.transport e F).OddColouring ℓ where + toFun := EdgeSubset.OddColouring.transport e + invFun φ := ⟨fun f => φ.val (EdgeSubset.transportFlagsEquiv e F f), + fun f => by + have harg : (EdgeSubset.transportFlagsEquiv e F + ⟨W₁.pairing f.val, F.pairing_mem _ f.prop⟩).val = + W₂.pairing (EdgeSubset.transportFlagsEquiv e F f).val := by + change e.flagEquiv (W₁.pairing f.val) = W₂.pairing (e.flagEquiv f.val) + exact e.pairing_comm f.val + exact (congrArg φ.val (Subtype.ext harg)).trans (φ.prop _)⟩ + left_inv φ := Subtype.ext (funext fun f => congrArg φ.val + (Equiv.symm_apply_apply _ _)) + right_inv φ := Subtype.ext (funext fun f => congrArg φ.val + (Equiv.apply_symm_apply _ _)) + +open Classical in +/-- **Transport invariance of the Definition 5 summand**: the +summand of a transported edge subset with transported transition +system and orientation is the original summand. -/ +theorem EdgeSubset.mixedSummand_transport {W₁ W₂ : Fragment α} + (e : W₁.Equiv W₂) {F : EdgeSubset W₁} {k ℓ : ℕ} + (h : MixedFunctional k ℓ) {κ : F.TransitionSystem} + (o : κ.Orientation) : + (EdgeSubset.transport e F).mixedSummand h + (EdgeSubset.TransitionSystem.Orientation.transport e o) = + F.mixedSummand h o := by + unfold EdgeSubset.mixedSummand + rw [EdgeSubset.TransitionSystem.transport_circuitCount] + congr 1 + refine Fintype.sum_equiv + (EdgeSubset.EvenColouring.transportEquiv e F k).symm _ _ (fun ψ => ?_) + refine Fintype.sum_equiv + (EdgeSubset.OddColouring.transportEquiv e F ℓ).symm _ _ (fun φ => ?_) + refine Fintype.prod_equiv e.vertexEquiv.symm _ _ (fun v => ?_) + obtain ⟨ψ₀, rfl⟩ : ∃ ψ₀, + ψ = EdgeSubset.EvenColouring.transportEquiv e F k ψ₀ := + ⟨_, ((EdgeSubset.EvenColouring.transportEquiv e F k).apply_symm_apply + ψ).symm⟩ + obtain ⟨φ₀, rfl⟩ : ∃ φ₀, + φ = EdgeSubset.OddColouring.transportEquiv e F ℓ φ₀ := + ⟨_, ((EdgeSubset.OddColouring.transportEquiv e F ℓ).apply_symm_apply + φ).symm⟩ + obtain ⟨v₀, rfl⟩ : ∃ v₀, v = e.vertexEquiv v₀ := + ⟨_, (Equiv.apply_symm_apply _ _).symm⟩ + simp only [Equiv.symm_apply_apply] + rw [show EdgeSubset.EvenColouring.transportEquiv e F k ψ₀ = + EdgeSubset.EvenColouring.transport e ψ₀ from rfl, + show EdgeSubset.OddColouring.transportEquiv e F ℓ φ₀ = + EdgeSubset.OddColouring.transport e φ₀ from rfl, + EdgeSubset.oddSignAt_transport, EdgeSubset.evenColoursAt_transport, + EdgeSubset.evalOdd_oddListAt_transport] + +end Transport + +section CirclesOnly + +private instance (c : ℕ) : IsEmpty (Fragment.circlesOnly c).Flag := + inferInstanceAs (IsEmpty Empty) + +private instance (c : ℕ) : IsEmpty (Fragment.circlesOnly c).Vertex := + inferInstanceAs (IsEmpty Empty) + +end CirclesOnly + +/-- The partner sign flips across the pairing. -/ +theorem oddPartnerSign_oddPartner (ℓ : ℕ) (i : Fin (2 * ℓ)) : + oddPartnerSign ℓ (oddPartner ℓ i) = -oddPartnerSign ℓ i := by + unfold oddPartner oddPartnerSign + by_cases h : i.val < ℓ + · rw [dite_eq_left h, ite_eq_left h, + ite_eq_right (show ¬ i.val + ℓ < ℓ by omega)] + norm_num + · have hi : i.val < 2 * ℓ := i.isLt + rw [dite_eq_right h, ite_eq_right h, + ite_eq_left (show i.val - ℓ < ℓ by omega)] + +/-- The partner sign squares to one. -/ +theorem oddPartnerSign_mul_self (ℓ : ℕ) (i : Fin (2 * ℓ)) : + oddPartnerSign ℓ i * oddPartnerSign ℓ i = 1 := by + unfold oddPartnerSign + by_cases h : i.val < ℓ <;> simp [h] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalInstance.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalInstance.lean new file mode 100644 index 0000000000..3396549842 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalInstance.lean @@ -0,0 +1,126 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalNat +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalStruct + +/-! +# The monoidal skein category + +The `MonoidalCategory` instance on `SkeinObj f`: the interchange +on classes, the identity-strand tensor, the naturality squares, +and the coherence diagrams, all collapsing through the bundle-map +calculus. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +/-- Block sums of casts are casts. -/ +theorem tensorMapEquiv_finCongr {n₁ m₁ n₂ m₂ : ℕ} + (h₁ : n₁ = m₁) (h₂ : n₂ = m₂) : + tensorMapEquiv (finCongr h₁) (finCongr h₂) = + finCongr (by omega) := by + subst h₁ + subst h₂ + refine _root_.Equiv.ext (fun x => Fin.ext ?_) + rcases Nat.lt_or_ge x.val n₁ with hx | hx + · rw [show x = Fin.castAdd n₂ ⟨x.val, hx⟩ from Fin.ext rfl, + tensorMapEquiv_castAdd] + rfl + · rw [show x = Fin.natAdd n₁ ⟨x.val - n₁, by + have := x.isLt + omega⟩ from Fin.ext (by + change x.val = n₁ + (x.val - n₁) + omega), + tensorMapEquiv_natAdd] + rfl + +/-- Tensoring an arity cast with the identity is again a cast. -/ +theorem tensorMapEquiv_finCongr_refl_right {n₁ m₁ : ℕ} + (h₁ : n₁ = m₁) (k : ℕ) : + tensorMapEquiv (finCongr h₁) (_root_.Equiv.refl (Fin k)) = + finCongr (by omega) := by + rw [show (_root_.Equiv.refl (Fin k)) = finCongr rfl from + _root_.Equiv.ext (fun _ => rfl), tensorMapEquiv_finCongr] + +/-- And so is tensoring the identity with one. -/ +theorem tensorMapEquiv_refl_finCongr_left (k : ℕ) {n₂ m₂ : ℕ} + (h₂ : n₂ = m₂) : + tensorMapEquiv (_root_.Equiv.refl (Fin k)) (finCongr h₂) = + finCongr (by omega) := by + rw [show (_root_.Equiv.refl (Fin k)) = finCongr rfl from + _root_.Equiv.ext (fun _ => rfl), tensorMapEquiv_finCongr] + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- **The monoidal skein category.** -/ +noncomputable instance skeinMonoidal : + MonoidalCategory (SkeinObj f) where + tensorHom_def {X₁ Y₁ X₂ Y₂} p q := by + change HomSpace.tensor f X₁.arity Y₁.arity X₂.arity Y₂.arity + p q = + HomSpace.comp f (X₁.arity + X₂.arity) + (Y₁.arity + X₂.arity) (Y₁.arity + Y₂.arity) + (HomSpace.tensor f X₁.arity Y₁.arity X₂.arity X₂.arity + p (HomSpace.ofFragment f.val (strandBundle X₂.arity))) + (HomSpace.tensor f Y₁.arity Y₁.arity X₂.arity Y₂.arity + (HomSpace.ofFragment f.val (strandBundle Y₁.arity)) q) + rw [← HomSpace.tensor_comp, HomSpace.comp_id_right, + HomSpace.comp_id_left] + id_tensorHom_id X₁ X₂ := skein_tensor_id f X₁ X₂ + tensorHom_comp_tensorHom {X₁ Y₁ Z₁ X₂ Y₂ Z₂} p₁ p₂ q₁ q₂ := + (HomSpace.tensor_comp f p₁ q₁ p₂ q₂).symm + whiskerLeft_id X Y := skein_tensor_id f X Y + id_whiskerRight X Y := skein_tensor_id f X Y + associator_naturality {X₁ X₂ X₃ Y₁ Y₂ Y₃} p₁ p₂ p₃ := + assocNat_class f p₁ p₂ p₃ + leftUnitor_naturality {X Y} p := leftUnitNat_class f p + rightUnitor_naturality {X Y} p := rightUnitNat_class f p + pentagon W X Y Z := by + change HomSpace.comp f _ _ _ + (HomSpace.tensor f _ _ _ _ + (bundleMapClass f (finCongr _)) + (HomSpace.ofFragment f.val (strandBundle Z.arity))) + (HomSpace.comp f _ _ _ + (bundleMapClass f (finCongr _)) + (HomSpace.tensor f _ _ _ _ + (HomSpace.ofFragment f.val (strandBundle W.arity)) + (bundleMapClass f (finCongr _)))) = + HomSpace.comp f _ _ _ + (bundleMapClass f (finCongr _)) + (bundleMapClass f (finCongr _)) + rw [bundleMapClass_tensor_id_right, + tensorMapEquiv_finCongr_refl_right, + bundleMapClass_tensor_id_left, + tensorMapEquiv_refl_finCongr_left, + bundleMapClass_comp, bundleMapClass_comp, + bundleMapClass_comp] + exact bundleMapClass_congr f + (_root_.Equiv.ext (fun x => Fin.ext rfl)) + triangle X Y := by + change HomSpace.comp f _ _ _ + (bundleMapClass f (finCongr _)) + (HomSpace.tensor f _ _ _ _ + (HomSpace.ofFragment f.val (strandBundle X.arity)) + (bundleMapClass f (finCongr _))) = + HomSpace.tensor f _ _ _ _ + (bundleMapClass f (finCongr _)) + (HomSpace.ofFragment f.val (strandBundle Y.arity)) + rw [bundleMapClass_tensor_id_left, + tensorMapEquiv_refl_finCongr_left, + bundleMapClass_tensor_id_right, + tensorMapEquiv_finCongr_refl_right, + bundleMapClass_comp] + exact bundleMapClass_congr f + (_root_.Equiv.ext (fun x => Fin.ext rfl)) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalNat.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalNat.lean new file mode 100644 index 0000000000..f70dcfeda8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalNat.lean @@ -0,0 +1,282 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleMapClasses +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorAssoc +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorUnit +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorCompClass + +/-! +# Naturality of the structural morphisms, fragment level + +The associator and unitor naturality squares of the monoidal +skein category, at the fragment level: composing with a cast +bundle map on either side is a boundary cast, the tensor +associativity and unit laws are relabellings by casts, and all +casts collapse through the transport lemmas. +-/ + +@[expose] public section + +namespace RS + +/-- The associator naturality square, fragment level. -/ +noncomputable def assocNatFrag {s₁ t₁ s₂ t₂ s₃ t₃ : ℕ} + (F₁ : Fragment (Fin (s₁ + t₁))) (F₂ : Fragment (Fin (s₂ + t₂))) + (F₃ : Fragment (Fin (s₃ + t₃))) : + ((tensorFragment (tensorFragment F₁ F₂) F₃).compose + (bundleMap (finCongr + (by omega : (t₁ + t₂) + t₃ = t₁ + (t₂ + t₃))))).Equiv + ((bundleMap (finCongr + (by omega : (s₁ + s₂) + s₃ = s₁ + (s₂ + s₃)))).compose + (tensorFragment F₁ (tensorFragment F₂ F₃))) := by + refine (composeBundleMap _ _).trans ?_ + refine (Fragment.Equiv.relabelCongr + (tensorFragmentAssoc s₁ t₁ s₂ t₂ s₃ t₃ F₁ F₂ F₃) _).trans ?_ + refine (Fragment.Equiv.relabelTrans _ _ _).trans ?_ + refine Fragment.Equiv.trans ?_ (bundleMapCompose _ _).symm + refine Fragment.Equiv.relabelEq _ ?_ + rw [outTransport_finCongr, finCongr_symm, inTransport_finCongr] + exact _root_.Equiv.ext (fun x => Fin.ext rfl) + +/-- The zero-strand bundle is the empty closed fragment. -/ +noncomputable def strandBundleZeroEmpty : + (strandBundle 0).Equiv + (emptyClosedFragment : Fragment (Fin 0)) where + flagEquiv := + haveI : IsEmpty (Fin 0 × Bool) := + ⟨fun p => p.1.elim0⟩ + haveI : IsEmpty (emptyClosedFragment : + Fragment (Fin 0)).Flag := + inferInstanceAs (IsEmpty Empty) + show (Fin 0 × Bool) ≃ (emptyClosedFragment : + Fragment (Fin 0)).Flag from + _root_.Equiv.equivOfIsEmpty _ _ + vertexEquiv := + haveI : IsEmpty (emptyClosedFragment : + Fragment (Fin 0)).Vertex := + inferInstanceAs (IsEmpty Empty) + haveI : IsEmpty (strandBundle 0).Vertex := + inferInstanceAs (IsEmpty Empty) + _root_.Equiv.equivOfIsEmpty _ _ + attach_comm := fun g => g.1.elim0 + pairing_comm := fun g => g.1.elim0 + circles_eq := rfl + +/-- The left-unitor naturality square, fragment level. -/ +noncomputable def leftUnitNatFrag {s t : ℕ} + (F : Fragment (Fin (s + t))) : + ((tensorFragment (strandBundle 0) F).compose + (bundleMap (finCongr (by omega : 0 + t = t)))).Equiv + ((bundleMap (finCongr + (by omega : 0 + s = s))).compose F) := by + refine (Fragment.composeCongr + (tensorFragmentCongr strandBundleZeroEmpty + (Fragment.Equiv.refl F)) + (Fragment.Equiv.refl _)).trans ?_ + refine (Fragment.composeCongr (tensorFragmentUnitLeft F) + (Fragment.Equiv.refl _)).trans ?_ + refine (composeBundleMap _ _).trans ?_ + refine (Fragment.Equiv.relabelTrans _ _ _).trans ?_ + refine Fragment.Equiv.trans ?_ (bundleMapCompose _ _).symm + refine Fragment.Equiv.relabelEq _ ?_ + rw [outTransport_finCongr, finCongr_symm, inTransport_finCongr] + exact _root_.Equiv.ext (fun x => Fin.ext rfl) + +/-- The right-unitor naturality square, fragment level. -/ +noncomputable def rightUnitNatFrag {s t : ℕ} + (F : Fragment (Fin (s + t))) : + ((tensorFragment F (strandBundle 0)).compose + (bundleMap (finCongr (by omega : t + 0 = t)))).Equiv + ((bundleMap (finCongr + (by omega : s + 0 = s))).compose F) := by + refine (Fragment.composeCongr + (tensorFragmentCongr (Fragment.Equiv.refl F) + strandBundleZeroEmpty) + (Fragment.Equiv.refl _)).trans ?_ + refine (Fragment.composeCongr (tensorFragmentUnitRight F) + (Fragment.Equiv.refl _)).trans ?_ + refine (composeBundleMap _ _).trans ?_ + refine (Fragment.Equiv.relabelTrans _ _ _).trans ?_ + refine Fragment.Equiv.trans ?_ (bundleMapCompose _ _).symm + refine Fragment.Equiv.relabelEq _ ?_ + rw [outTransport_finCongr, finCongr_symm, inTransport_finCongr] + exact _root_.Equiv.ext (fun x => Fin.ext rfl) + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The associator-naturality difference lies in the kernel. -/ +theorem mem_ker_assocNat {s₁ t₁ s₂ t₂ s₃ t₃ : ℕ} + (x₁ : Fragment (Fin (s₁ + t₁)) →₀ ℂ) + (x₂ : Fragment (Fin (s₂ + t₂)) →₀ ℂ) + (x₃ : Fragment (Fin (s₃ + t₃)) →₀ ℂ) : + composeFinsupp ((s₁ + s₂) + s₃) ((t₁ + t₂) + t₃) + (t₁ + (t₂ + t₃)) + (tensorFinsupp (s₁ + s₂) (t₁ + t₂) s₃ t₃ + (tensorFinsupp s₁ t₁ s₂ t₂ x₁ x₂) x₃) + (Finsupp.single (bundleMap (finCongr + (by omega : (t₁ + t₂) + t₃ = t₁ + (t₂ + t₃)))) 1) - + composeFinsupp ((s₁ + s₂) + s₃) (s₁ + (s₂ + s₃)) + (t₁ + (t₂ + t₃)) + (Finsupp.single (bundleMap (finCongr + (by omega : (s₁ + s₂) + s₃ = s₁ + (s₂ + s₃)))) 1) + (tensorFinsupp s₁ t₁ (s₂ + s₃) (t₂ + t₃) x₁ + (tensorFinsupp s₂ t₂ s₃ t₃ x₂ x₃)) ∈ + LinearMap.ker (connectionMap f.val + (((s₁ + s₂) + s₃) + (t₁ + (t₂ + t₃)))) := by + induction x₁ using Finsupp.induction_linear with + | zero => + simp only [map_zero, LinearMap.zero_apply, sub_zero] + exact Submodule.zero_mem _ + | add a b ha hb => + simp only [map_add, LinearMap.add_apply] at ha hb ⊢ + rw [show ∀ (A B C D : (Fragment (Fin (((s₁ + s₂) + s₃) + + (t₁ + (t₂ + t₃)))) →₀ ℂ)), + A + B - (C + D) = (A - C) + (B - D) from + fun A B C D => by abel] + exact Submodule.add_mem _ ha hb + | single F₁ c₁ => + induction x₂ using Finsupp.induction_linear with + | zero => + simp only [map_zero, LinearMap.zero_apply, sub_zero] + exact Submodule.zero_mem _ + | add a b ha hb => + simp only [map_add, LinearMap.add_apply] at ha hb ⊢ + rw [show ∀ (A B C D : (Fragment (Fin (((s₁ + s₂) + s₃) + + (t₁ + (t₂ + t₃)))) →₀ ℂ)), + A + B - (C + D) = (A - C) + (B - D) from + fun A B C D => by abel] + exact Submodule.add_mem _ ha hb + | single F₂ c₂ => + induction x₃ using Finsupp.induction_linear with + | zero => + simp only [map_zero, LinearMap.zero_apply, sub_zero] + exact Submodule.zero_mem _ + | add a b ha hb => + simp only [map_add, LinearMap.add_apply] at ha hb ⊢ + rw [show ∀ (A B C D : (Fragment (Fin (((s₁ + s₂) + s₃) + + (t₁ + (t₂ + t₃)))) →₀ ℂ)), + A + B - (C + D) = (A - C) + (B - D) from + fun A B C D => by abel] + exact Submodule.add_mem _ ha hb + | single F₃ c₃ => + rw [tensorFinsupp_single, tensorFinsupp_single, + tensorFinsupp_single, tensorFinsupp_single, + composeFinsupp_single, composeFinsupp_single, + show ((c₁ * c₂) * c₃) * 1 = 1 * (c₁ * (c₂ * c₃)) + from by ring] + exact mem_ker_single_sub_of_equiv_smul f + (assocNatFrag F₁ F₂ F₃) (1 * (c₁ * (c₂ * c₃))) + +/-- The left-unitor-naturality difference lies in the kernel. -/ +theorem mem_ker_leftUnitNat {s t : ℕ} + (x : Fragment (Fin (s + t)) →₀ ℂ) : + composeFinsupp (0 + s) (0 + t) t + (tensorFinsupp 0 0 s t + (Finsupp.single (strandBundle 0) 1) x) + (Finsupp.single (bundleMap (finCongr + (by omega : 0 + t = t))) 1) - + composeFinsupp (0 + s) s t + (Finsupp.single (bundleMap (finCongr + (by omega : 0 + s = s))) 1) x ∈ + LinearMap.ker (connectionMap f.val ((0 + s) + t)) := by + induction x using Finsupp.induction_linear with + | zero => + simp only [map_zero, LinearMap.zero_apply, sub_zero] + exact Submodule.zero_mem _ + | add a b ha hb => + simp only [map_add, LinearMap.add_apply] at ha hb ⊢ + rw [show ∀ (A B C D : (Fragment (Fin ((0 + s) + t)) →₀ ℂ)), + A + B - (C + D) = (A - C) + (B - D) from + fun A B C D => by abel] + exact Submodule.add_mem _ ha hb + | single F c => + rw [tensorFinsupp_single, composeFinsupp_single, + composeFinsupp_single, + show (1 * c) * 1 = 1 * c from by ring] + exact mem_ker_single_sub_of_equiv_smul f + (leftUnitNatFrag F) (1 * c) + +/-- The right-unitor-naturality difference lies in the kernel. -/ +theorem mem_ker_rightUnitNat {s t : ℕ} + (x : Fragment (Fin (s + t)) →₀ ℂ) : + composeFinsupp (s + 0) (t + 0) t + (tensorFinsupp s t 0 0 x + (Finsupp.single (strandBundle 0) 1)) + (Finsupp.single (bundleMap (finCongr + (by omega : t + 0 = t))) 1) - + composeFinsupp (s + 0) s t + (Finsupp.single (bundleMap (finCongr + (by omega : s + 0 = s))) 1) x ∈ + LinearMap.ker (connectionMap f.val ((s + 0) + t)) := by + induction x using Finsupp.induction_linear with + | zero => + simp only [map_zero, LinearMap.zero_apply, sub_zero] + exact Submodule.zero_mem _ + | add a b ha hb => + simp only [map_add, LinearMap.add_apply] at ha hb ⊢ + rw [show ∀ (A B C D : (Fragment (Fin ((s + 0) + t)) →₀ ℂ)), + A + B - (C + D) = (A - C) + (B - D) from + fun A B C D => by abel] + exact Submodule.add_mem _ ha hb + | single F c => + rw [tensorFinsupp_single, composeFinsupp_single, + composeFinsupp_single, + show (c * 1) * 1 = 1 * c from by ring] + exact mem_ker_single_sub_of_equiv_smul f + (rightUnitNatFrag F) (1 * c) + +/-- **Associator naturality on Hom classes.** -/ +theorem assocNat_class {s₁ t₁ s₂ t₂ s₃ t₃ : ℕ} + (p₁ : HomSpace f.val (s₁ + t₁)) (p₂ : HomSpace f.val (s₂ + t₂)) + (p₃ : HomSpace f.val (s₃ + t₃)) : + HomSpace.comp f ((s₁ + s₂) + s₃) ((t₁ + t₂) + t₃) + (t₁ + (t₂ + t₃)) + (HomSpace.tensor f (s₁ + s₂) (t₁ + t₂) s₃ t₃ + (HomSpace.tensor f s₁ t₁ s₂ t₂ p₁ p₂) p₃) + (bundleMapClass f (finCongr + (by omega : (t₁ + t₂) + t₃ = t₁ + (t₂ + t₃)))) = + HomSpace.comp f ((s₁ + s₂) + s₃) (s₁ + (s₂ + s₃)) + (t₁ + (t₂ + t₃)) + (bundleMapClass f (finCongr + (by omega : (s₁ + s₂) + s₃ = s₁ + (s₂ + s₃)))) + (HomSpace.tensor f s₁ t₁ (s₂ + s₃) (t₂ + t₃) p₁ + (HomSpace.tensor f s₂ t₂ s₃ t₃ p₂ p₃)) := by + obtain ⟨x₁, rfl⟩ := Submodule.Quotient.mk_surjective _ p₁ + obtain ⟨x₂, rfl⟩ := Submodule.Quotient.mk_surjective _ p₂ + obtain ⟨x₃, rfl⟩ := Submodule.Quotient.mk_surjective _ p₃ + exact (Submodule.Quotient.eq _).mpr + (mem_ker_assocNat f x₁ x₂ x₃) + +/-- **Left-unitor naturality on Hom classes.** -/ +theorem leftUnitNat_class {s t : ℕ} + (p : HomSpace f.val (s + t)) : + HomSpace.comp f (0 + s) (0 + t) t + (HomSpace.tensor f 0 0 s t + (HomSpace.ofFragment f.val (strandBundle 0)) p) + (bundleMapClass f (finCongr (by omega : 0 + t = t))) = + HomSpace.comp f (0 + s) s t + (bundleMapClass f (finCongr (by omega : 0 + s = s))) + p := by + obtain ⟨x, rfl⟩ := Submodule.Quotient.mk_surjective _ p + exact (Submodule.Quotient.eq _).mpr (mem_ker_leftUnitNat f x) + +/-- **Right-unitor naturality on Hom classes.** -/ +theorem rightUnitNat_class {s t : ℕ} + (p : HomSpace f.val (s + t)) : + HomSpace.comp f (s + 0) (t + 0) t + (HomSpace.tensor f s t 0 0 p + (HomSpace.ofFragment f.val (strandBundle 0))) + (bundleMapClass f (finCongr (by omega : t + 0 = t))) = + HomSpace.comp f (s + 0) s t + (bundleMapClass f (finCongr (by omega : s + 0 = s))) + p := by + obtain ⟨x, rfl⟩ := Submodule.Quotient.mk_surjective _ p + exact (Submodule.Quotient.eq _).mpr (mem_ker_rightUnitNat f x) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalStruct.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalStruct.lean new file mode 100644 index 0000000000..da12455d59 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalStruct.lean @@ -0,0 +1,189 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleMapClasses +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTensor + +/-! +# The monoidal structure data of the skein category + +Tensor on objects is arity addition, tensor on morphisms is the +descended tensor, and every structural isomorphism — associator, +unitors — is the class of a cast bundle map. The iso laws and +the coherence lemmas provable without the interchange law +(identity tensoring, pentagon, triangle) all collapse through the +bundle-map calculus. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The cast isomorphism between equal-arity objects. -/ +noncomputable def castIso {n m : ℕ} (h : n = m) : + (SkeinObj.mk n : SkeinObj f) ≅ SkeinObj.mk m where + hom := bundleMapClass f (finCongr h) + inv := bundleMapClass f (finCongr h.symm) + hom_inv_id := by + change HomSpace.comp f n m n + (bundleMapClass f (finCongr h)) + (bundleMapClass f (finCongr h.symm)) = + HomSpace.ofFragment f.val (strandBundle n) + rw [bundleMapClass_comp, + show (finCongr h).trans (finCongr h.symm) = + _root_.Equiv.refl (Fin n) from + _root_.Equiv.ext (fun x => Fin.ext rfl)] + exact bundleMapClass_refl f n + inv_hom_id := by + change HomSpace.comp f m n m + (bundleMapClass f (finCongr h.symm)) + (bundleMapClass f (finCongr h)) = + HomSpace.ofFragment f.val (strandBundle m) + rw [bundleMapClass_comp, + show (finCongr h.symm).trans (finCongr h) = + _root_.Equiv.refl (Fin m) from + _root_.Equiv.ext (fun x => Fin.ext rfl)] + exact bundleMapClass_refl f m + +/-- **The monoidal structure** of the skein category. -/ +noncomputable instance skeinMonoidalStruct : + MonoidalCategoryStruct (SkeinObj f) where + tensorObj X Y := ⟨X.arity + Y.arity⟩ + whiskerLeft X {Y₁ Y₂} p := + HomSpace.tensor f X.arity X.arity Y₁.arity Y₂.arity + (HomSpace.ofFragment f.val (strandBundle X.arity)) p + whiskerRight {X₁ X₂} p Y := + HomSpace.tensor f X₁.arity X₂.arity Y.arity Y.arity p + (HomSpace.ofFragment f.val (strandBundle Y.arity)) + tensorHom {X₁ Y₁ X₂ Y₂} p q := + HomSpace.tensor f X₁.arity Y₁.arity X₂.arity Y₂.arity p q + tensorUnit := ⟨0⟩ + associator X Y Z := castIso f + (show (X.arity + Y.arity) + Z.arity = + X.arity + (Y.arity + Z.arity) by omega) + leftUnitor X := castIso f + (show 0 + X.arity = X.arity by omega) + rightUnitor X := castIso f + (show X.arity + 0 = X.arity by omega) + +/-- Tensoring bundle-map classes is the class of the block +sum. -/ +theorem bundleMapClass_tensor {n₁ m₁ n₂ m₂ : ℕ} + (e₁ : Fin n₁ ≃ Fin m₁) (e₂ : Fin n₂ ≃ Fin m₂) : + HomSpace.tensor f n₁ m₁ n₂ m₂ + (bundleMapClass f e₁) (bundleMapClass f e₂) = + bundleMapClass f (tensorMapEquiv e₁ e₂) := by + rw [bundleMapClass, bundleMapClass, + HomSpace.tensor_ofFragment] + exact HomSpace.ofFragment_congr f (bundleMapTensor e₁ e₂) + +/-- Tensoring identities is the identity (`tensor_id`). -/ +theorem skein_tensor_id (X Y : SkeinObj f) : + MonoidalCategoryStruct.tensorHom (𝟙 X) (𝟙 Y) = + 𝟙 (MonoidalCategoryStruct.tensorObj X Y) := by + change HomSpace.tensor f X.arity X.arity Y.arity Y.arity + (HomSpace.ofFragment f.val (strandBundle X.arity)) + (HomSpace.ofFragment f.val (strandBundle Y.arity)) = + HomSpace.ofFragment f.val (strandBundle (X.arity + Y.arity)) + rw [HomSpace.tensor_ofFragment] + exact HomSpace.ofFragment_congr f + (strandBundleTensor X.arity Y.arity).symm + +/-- The identity class is a bundle-map class. -/ +theorem id_eq_bundleMapClass (n : ℕ) : + HomSpace.ofFragment f.val (strandBundle n) = + bundleMapClass f (_root_.Equiv.refl (Fin n)) := + (bundleMapClass_refl f n).symm + +/-- Tensoring a bundle-map class with an identity strand on the +right. -/ +theorem bundleMapClass_tensor_id_right {n₁ m₁ : ℕ} (k : ℕ) + (e₁ : Fin n₁ ≃ Fin m₁) : + HomSpace.tensor f n₁ m₁ k k (bundleMapClass f e₁) + (HomSpace.ofFragment f.val (strandBundle k)) = + bundleMapClass f + (tensorMapEquiv e₁ (_root_.Equiv.refl (Fin k))) := by + rw [id_eq_bundleMapClass, bundleMapClass_tensor] + +/-- Tensoring a bundle-map class with an identity strand on the +left. -/ +theorem bundleMapClass_tensor_id_left (k : ℕ) {n₂ m₂ : ℕ} + (e₂ : Fin n₂ ≃ Fin m₂) : + HomSpace.tensor f k k n₂ m₂ + (HomSpace.ofFragment f.val (strandBundle k)) + (bundleMapClass f e₂) = + bundleMapClass f + (tensorMapEquiv (_root_.Equiv.refl (Fin k)) e₂) := by + rw [id_eq_bundleMapClass, bundleMapClass_tensor] + +/-- The block transposes compose to the identity. -/ +theorem transposeEquiv_trans_self (a b : ℕ) : + (transposeEquiv a b).trans (transposeEquiv b a) = + _root_.Equiv.refl (Fin (a + b)) := by + refine _root_.Equiv.ext (fun x => Fin.ext ?_) + rcases Nat.lt_or_ge x.val a with hx | hx + · rw [_root_.Equiv.trans_apply, + show x = (⟨x.val, by omega⟩ : Fin (a + b)) from + Fin.ext rfl, + transposeEquiv_low a b x.val hx (by omega) (by omega), + transposeEquiv_high b a x.val hx (by omega) (by omega)] + rfl + · rw [_root_.Equiv.trans_apply, + show x = (⟨a + (x.val - a), by have := x.isLt; omega⟩ : + Fin (a + b)) from Fin.ext (by + change x.val = a + (x.val - a) + omega), + transposeEquiv_high a b (x.val - a) + (by have := x.isLt; omega) (by have := x.isLt; omega) + (by have := x.isLt; omega), + transposeEquiv_low b a (x.val - a) + (by have := x.isLt; omega) (by have := x.isLt; omega) + (by have := x.isLt; omega)] + rfl + +/-- **The braiding isomorphism** of the skein category: the +block-transpose bundle map. -/ +noncomputable def skeinBraiding (X Y : SkeinObj f) : + MonoidalCategoryStruct.tensorObj X Y ≅ + MonoidalCategoryStruct.tensorObj Y X where + hom := bundleMapClass f (transposeEquiv X.arity Y.arity) + inv := bundleMapClass f (transposeEquiv Y.arity X.arity) + hom_inv_id := by + change HomSpace.comp f _ _ _ + (bundleMapClass f (transposeEquiv X.arity Y.arity)) + (bundleMapClass f (transposeEquiv Y.arity X.arity)) = + HomSpace.ofFragment f.val + (strandBundle (X.arity + Y.arity)) + rw [bundleMapClass_comp, transposeEquiv_trans_self] + exact bundleMapClass_refl f _ + inv_hom_id := by + change HomSpace.comp f _ _ _ + (bundleMapClass f (transposeEquiv Y.arity X.arity)) + (bundleMapClass f (transposeEquiv X.arity Y.arity)) = + HomSpace.ofFragment f.val + (strandBundle (Y.arity + X.arity)) + rw [bundleMapClass_comp, transposeEquiv_trans_self] + exact bundleMapClass_refl f _ + +/-- The braiding is symmetric: swapping twice is the identity +(the `symmetry` axiom, at class level). -/ +theorem skeinBraiding_symmetry (X Y : SkeinObj f) : + (skeinBraiding f X Y).hom ≫ (skeinBraiding f Y X).hom = + 𝟙 (MonoidalCategoryStruct.tensorObj X Y) := by + change HomSpace.comp f _ _ _ + (bundleMapClass f (transposeEquiv X.arity Y.arity)) + (bundleMapClass f (transposeEquiv Y.arity X.arity)) = + HomSpace.ofFragment f.val (strandBundle (X.arity + Y.arity)) + rw [bundleMapClass_comp, transposeEquiv_trans_self] + exact bundleMapClass_refl f _ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/Multiplicativity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/Multiplicativity.lean new file mode 100644 index 0000000000..77c0934d8e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/Multiplicativity.lean @@ -0,0 +1,190 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv + +/-! +# Multiplicativity from the rank bound at arity zero + +An edge-rank-bounded parameter is automatically multiplicative over +disjoint unions: the arity-zero connection pairing has rank at most +one, its row at the empty graph is nonzero (the parameter is +normalized there), so every row is a scalar multiple of it, and +evaluating at the empty graph identifies the scalar. +-/ + +@[expose] public section + +namespace RS + +/-- Disjoint union of closed fragments. -/ +noncomputable def ClosedFragment.union (W₁ W₂ : ClosedFragment) : + ClosedFragment := + (W₁.disjUnion W₂).relabel (Equiv.equivOfIsEmpty _ _) + +/-- The row of the arity-zero connection pairing at a fragment. -/ +noncomputable def connectionRow (f : ClosedFragment → ℂ) + (F : Fragment (Fin (0 + 0))) : Fragment (Fin (0 + 0)) → ℂ := + connectionMap f 0 (Finsupp.single F 1) + +/-- The row at `F` evaluates to the pairing values. -/ +theorem connectionRow_apply (f : ClosedFragment → ℂ) + (F G : Fragment (Fin (0 + 0))) : + connectionRow f F G = f (pairClose F G) := by + simp [connectionRow, connectionMap, connectionPairing] + +/-- Relabelling a closed fragment along any equivalence of empty +label types is trivial. -/ +noncomputable def relabelZeroEquiv (W : Fragment (Fin 0)) + (e : Fin 0 ≃ Fin 0) : (W.relabel e).Equiv W where + flagEquiv := Equiv.refl _ + vertexEquiv := Equiv.refl _ + attach_comm := fun f => by + rcases ha : W.attach f with v | ℓ + · have hval : (W.relabel e).attach f = (W.attach f).map id e := rfl + change W.attach f = _ + rw [hval, ha] + rfl + · exact ℓ.elim0 + pairing_comm := fun _ => rfl + circles_eq := rfl + +/-- Composition at arity zero is the disjoint union, up to +equivalence: with no interface labels, no gluing happens, and any +two relabellings into the empty label type coincide. -/ +noncomputable def composeZeroEquiv (F G : ClosedFragment) : + ((F.compose (t := 0) (u := 0) G)).Equiv (F.union G) := by + haveI : IsEmpty (Fin ((0:ℕ) + 0)) := ⟨fun x => absurd x.isLt (by omega)⟩ + have he : ((Equiv.sumCongr (finCongr (by omega : (0:ℕ) + 0 = 0)) + (finCongr (by omega : (0:ℕ) + 0 = 0))).trans finSumFinEquiv) = + Equiv.equivOfIsEmpty (Fin (0 + 0) ⊕ Fin (0 + 0)) (Fin (0 + 0)) := + Equiv.ext (fun x => isEmptyElim x) + have hobj : (F.disjUnion G).relabel + ((Equiv.sumCongr (finCongr (by omega : (0:ℕ) + 0 = 0)) + (finCongr (by omega : (0:ℕ) + 0 = 0))).trans finSumFinEquiv) = + F.union G := by + have : Subsingleton ((Fin ((0:ℕ) + 0) ⊕ Fin ((0:ℕ) + 0)) ≃ Fin ((0:ℕ) + 0)) + := + ⟨fun a b => Equiv.ext fun x => isEmptyElim x⟩ + rw [he] + exact congrArg _ (Subsingleton.elim _ _) + exact (Fragment.Equiv.relabelTrans (F.disjUnion G) _ _).trans + (hobj ▸ Fragment.Equiv.refl _) + +/-- Union with the empty fragment on the left. -/ +noncomputable def unionEmptyLeftEquiv (G : ClosedFragment) : + (emptyClosedFragment.union G).Equiv G where + flagEquiv := Equiv.emptySum Empty G.Flag + vertexEquiv := Equiv.emptySum Empty G.Vertex + attach_comm := fun f => by + rcases f with e | g + · exact e.elim + · rcases ha : G.attach g with v | ℓ + · have hval : (emptyClosedFragment.union G).attach (Sum.inr g) = + ((G.attach g).map Sum.inr Sum.inr).map id + (Equiv.equivOfIsEmpty (Fin 0 ⊕ Fin 0) (Fin 0)) := rfl + change G.attach g = _ + rw [hval, ha] + rfl + · exact ℓ.elim0 + pairing_comm := fun f => by + rcases f with e | g + · exact e.elim + · rfl + circles_eq := Nat.zero_add _ + +/-- Union with the empty fragment on the right. -/ +noncomputable def unionEmptyRightEquiv (W : ClosedFragment) : + (W.union emptyClosedFragment).Equiv W where + flagEquiv := Equiv.sumEmpty W.Flag Empty + vertexEquiv := Equiv.sumEmpty W.Vertex Empty + attach_comm := fun f => by + rcases f with g | e + · rcases ha : W.attach g with v | ℓ + · have hval : (W.union emptyClosedFragment).attach (Sum.inl g) = + ((W.attach g).map Sum.inl Sum.inl).map id + (Equiv.equivOfIsEmpty (Fin 0 ⊕ Fin 0) (Fin 0)) := rfl + change W.attach g = _ + rw [hval, ha] + rfl + · exact ℓ.elim0 + · exact e.elim + pairing_comm := fun f => by + rcases f with g | e + · rfl + · exact e.elim + circles_eq := rfl + +/-- **Multiplicativity from the rank bound** (Lemma 3.2): an +edge-rank-bounded parameter is multiplicative over disjoint +unions of closed fragments. -/ +theorem EdgeRankParameter.val_union {R : ℕ} (f : EdgeRankParameter R) + (W₁ W₂ : ClosedFragment) : + f.val (W₁.union W₂) = f.val W₁ * f.val W₂ := by + classical + -- ═══════ The two rows ═══════ + set r₀ := connectionRow f.val emptyClosedFragment with hr₀ + set r₁ := connectionRow f.val W₁ with hr₁ + have hval : ∀ (F G : Fragment (Fin (0 + 0))), + connectionRow f.val F G = f.val (ClosedFragment.union F G) := fun F G => + by + rw [connectionRow_apply] + exact f.iso_invariant _ _ + ((Fragment.composeCongr (relabelZeroEquiv F _) + (relabelZeroEquiv G _)).trans (composeZeroEquiv F G)) + -- row values through the empty-union equivalences + have h₀ : ∀ G, r₀ G = f.val G := fun G => by + rw [hr₀, hval] + exact f.iso_invariant _ _ (unionEmptyLeftEquiv G) + have h₁empty : r₁ emptyClosedFragment = f.val W₁ := by + rw [hr₁, hval] + exact f.iso_invariant _ _ (unionEmptyRightEquiv W₁) + have h₀ne : r₀ ≠ 0 := fun hzero => by + have := h₀ emptyClosedFragment + rw [hzero] at this + simp only [Pi.zero_apply] at this + rw [f.val_empty] at this + exact one_ne_zero this.symm + -- ═══════ Rank one forces dependence ═══════ + have hrank := f.rank_bounded 0 + rw [pow_zero] at hrank + have hdep : ¬ LinearIndependent ℂ ![r₀, r₁] := by + intro hind + have hmem₀ : r₀ ∈ LinearMap.range (connectionMap f.val 0) := + ⟨Finsupp.single emptyClosedFragment 1, rfl⟩ + have hmem₁ : r₁ ∈ LinearMap.range (connectionMap f.val 0) := + ⟨Finsupp.single W₁ 1, rfl⟩ + have hsub : LinearIndependent ℂ + (![⟨r₀, hmem₀⟩, ⟨r₁, hmem₁⟩] : + Fin 2 → LinearMap.range (connectionMap f.val 0)) := by + apply LinearIndependent.of_comp + (LinearMap.range (connectionMap f.val 0)).subtype + convert hind using 1 + ext i + fin_cases i <;> rfl + have htwo := hsub.cardinal_lift_le_rank + rw [Cardinal.mk_fintype, Fintype.card_fin] at htwo + have hle := htwo.trans (Cardinal.lift_le.mpr hrank) + simp only [Cardinal.lift_one] at hle + norm_num at hle + -- ═══════ Extract the scalar ═══════ + rw [LinearIndependent.pair_iff' h₀ne] at hdep + push Not at hdep + obtain ⟨a, ha⟩ := hdep + have hascalar : a = f.val W₁ := by + have := congrFun ha emptyClosedFragment + simp only [Pi.smul_apply, smul_eq_mul] at this + rw [h₀ emptyClosedFragment, f.val_empty, mul_one] at this + rw [this, h₁empty] + have := congrFun ha W₂ + simp only [Pi.smul_apply, smul_eq_mul] at this + rw [h₀ W₂, hascalar] at this + rw [hr₁, hval] at this + exact this.symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/NonSeparatedStep.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/NonSeparatedStep.lean new file mode 100644 index 0000000000..e7ba9c6515 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/NonSeparatedStep.lean @@ -0,0 +1,1942 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger + +/-! +# The non-separated repair move: the flipped-segment ledger + +The non-separated case of the per-move path ledger: a repair square +whose two re-paired edges are traversed coherently +(`o.isOut c = o.isOut a`). The repaired walk reverses the segment +between the two match-pairs, and the transported orientation must +flip `isOut` exactly on the reversed segment. + +## Main results + +* `EdgeSubset.RepairSegment` — the abstract reversal-segment + package: a pairing-closed set of internal flags containing `b` + and `c`, avoiding `a` and `d`, and closed under the matching + except at the two cut points `b`, `c`. +* `EdgeSubset.RelTransitionSystem.Orientation.segFlip` — the + flipped-segment orientation of the repaired system (valid exactly + because the flip meets the non-separated condition at the cuts). +* `EdgeSubset.throughSummand_segFlip` — **the flipped-segment + ledger**: the constrained summand over the repaired system with + the flipped-segment orientation equals the old summand at every + fixed circuit exponent (total `+1`: the vertex transposition's + `−1` cancels against the cut-block `∂`-sign, and the reversed + segment telescopes to `∏_{f ∈ S} sign(φ f) = 1`). +* `EdgeSubset.WalkReach` / `EdgeSubset.exists_repairSegment` — the + same-component configuration (the walk from `c` reaches `a`) and + the construction of the reversal segment from it; covers both the + same-circuit and the same-path (chain) reversal sub-cases. +* `EdgeSubset.squareLocalized_of_walkReach` — a same-component + square is localized, so the path sign is untouched (committed + `pathMatch_repair_of_localized`). +* `EdgeSubset.RepairSquare.swap` and `repair_swap_matchEq` — the + square with the roles of the two re-paired edges exchanged + produces the same repaired system. + +## The two counting inputs + +The ledger needs the circuit-count parity of the move, which is a +separate, orbit-counting question. It is named here and proved in +the parity files: + +* `NonSeparatedSegmentParity` — a same-component square preserves + the circuit-count parity (the segment reversal maps the two + traversal orbits of the affected component to two orbits, Δ = 0); +* `NonSeparatedMergeParity` — a square whose `c`-edge lies on a + circuit not carrying `a` flips the count parity (the splice + merges the circuit into `a`'s component, Δ = −1). +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} {W : Fragment α} + +namespace EdgeSubset + +/-! ## The abstract reversal-segment package -/ + +section SegmentPackage + +variable {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {a b c d : W.Flag} {v : W.Vertex} {S : Finset W.Flag} + +/-- The reversal-segment data for a repair square: a pairing-closed +set of internal flags containing the two cut flags `b`, `c`, +avoiding `a`, `d`, and closed under the matching away from the +cuts. The repaired matching sends the cuts outside (`b ↦ d`, +`c ↦ a`), so the set is exactly the flag support of the walk +segment the repair reverses. -/ +structure RepairSegment (κ : F.RelTransitionSystem) + (a b c d : W.Flag) (S : Finset W.Flag) : Prop where + hbS : b ∈ S + hcS : c ∈ S + haS : a ∉ S + hdS : d ∉ S + int_of_mem : ∀ f ∈ S, f ∈ F.internalFlags + pairing_mem : ∀ f ∈ S, W.pairing f ∈ S + match_mem : ∀ f ∈ S, f ≠ b → f ≠ c → κ.match_ f ∈ S + +namespace RepairSegment + +/-- The complement is closed under the pairing. -/ +theorem pairing_notMem (h : RepairSegment κ a b c d S) {f : W.Flag} + (hf : f ∉ S) : W.pairing f ∉ S := by + intro hmem + have h2 := h.pairing_mem _ hmem + rw [W.pairing_invol] at h2 + exact hf h2 + +/-- The complement is closed under the matching away from `a`, `d`. -/ +theorem match_notMem (h : RepairSegment κ a b c d S) + (hsq : RepairSquare κ a b c d v) {f : W.Flag} + (hf : f ∈ F.internalFlags) (hfS : f ∉ S) + (h1 : f ≠ a) (h4 : f ≠ d) : κ.match_ f ∉ S := by + intro hmem + by_cases hb2 : κ.match_ f = b + · refine h1 ?_ + have h3 := congrArg κ.match_ hb2 + rwa [κ.match_invol f hf, hsq.hmb] at h3 + by_cases hc2 : κ.match_ f = c + · refine h4 ?_ + have h3 := congrArg κ.match_ hc2 + rwa [κ.match_invol f hf, hsq.hcd] at h3 + · have h3 := h.match_mem _ hmem hb2 hc2 + rw [κ.match_invol f hf] at h3 + exact hfS h3 + +/-- Boundary flags are never on the segment. -/ +theorem notMem_boundaryFlag (h : RepairSegment κ a b c d S) + (i : α) : W.boundaryFlag i ∉ S := by + intro hmem + obtain ⟨w, hw⟩ := F.attach_internal_of_mem (h.int_of_mem _ hmem) + rw [W.attach_boundaryFlag] at hw + cases hw + +end RepairSegment + +end SegmentPackage + +/-! ## The flipped-segment orientation of the repaired system -/ + +/-- **The flipped-segment orientation**: flip `isOut` exactly on +the reversal segment. The result is an orientation of the +*repaired* system: at the cuts the new matches `a ↔ c`, `b ↔ d` +flip orientation exactly because the move is non-separated +(`isOut c = isOut a`). -/ +noncomputable def RelTransitionSystem.Orientation.segFlip + {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {a b c d : W.Flag} {v : W.Vertex} {S : Finset W.Flag} + (hsq : RepairSquare κ a b c d v) (o : κ.Orientation) + (hsame : o.isOut c = o.isOut a) + (hseg : RepairSegment κ a b c d S) : + (κ.repair a b c d v hsq).Orientation where + isOut f := if f ∈ S then !o.isOut f else o.isOut f + match_flip := by + have hbflip : o.isOut b = !o.isOut a := by + rw [← hsq.hab]; exact o.match_flip a hsq.ha + have hdflip : o.isOut d = !o.isOut c := by + rw [← hsq.hcd]; exact o.match_flip c hsq.hc + intro f hf + show (if (κ.repair a b c d v hsq).match_ f ∈ S then + !o.isOut ((κ.repair a b c d v hsq).match_ f) + else o.isOut ((κ.repair a b c d v hsq).match_ f)) = + !(if f ∈ S then !o.isOut f else o.isOut f) + by_cases h1 : f = a + · subst h1 + rw [RelTransitionSystem.repair_match_a hsq, + ite_eq_left hseg.hcS, ite_eq_right hseg.haS, hsame] + by_cases h3 : f = c + · subst h3 + rw [RelTransitionSystem.repair_match_c hsq, + ite_eq_right hseg.haS, ite_eq_left hseg.hcS, Bool.not_not, hsame] + by_cases h2 : f = b + · subst h2 + rw [RelTransitionSystem.repair_match_b hsq, + ite_eq_right hseg.hdS, ite_eq_left hseg.hbS, Bool.not_not, + hdflip, hbflip, hsame] + by_cases h4 : f = d + · subst h4 + rw [RelTransitionSystem.repair_match_d hsq, + ite_eq_left hseg.hbS, ite_eq_right hseg.hdS, hbflip, hdflip, hsame] + · rw [RelTransitionSystem.repair_match_of_ne hsq h1 h2 h3 h4] + by_cases hfS : f ∈ S + · rw [ite_eq_left (hseg.match_mem f hfS h2 h3), ite_eq_left hfS, + o.match_flip f hf] + · rw [ite_eq_right (hseg.match_notMem hsq hf hfS h1 h4), ite_eq_right hfS] + exact o.match_flip f hf + pairing_flip := by + intro f hf hp + show (if W.pairing f ∈ S then !o.isOut (W.pairing f) + else o.isOut (W.pairing f)) = + !(if f ∈ S then !o.isOut f else o.isOut f) + by_cases hfS : f ∈ S + · rw [ite_eq_left (hseg.pairing_mem f hfS), ite_eq_left hfS, + o.pairing_flip f hf hp] + · rw [ite_eq_right (hseg.pairing_notMem hfS), ite_eq_right hfS] + exact o.pairing_flip f hf hp + +section SegFlipEval + +variable {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {a b c d : W.Flag} {v : W.Vertex} {S : Finset W.Flag} + +/-- Off the segment it is unchanged. -/ +theorem segFlip_isOut_of_notMem (hsq : RepairSquare κ a b c d v) + (o : κ.Orientation) (hsame : o.isOut c = o.isOut a) + (hseg : RepairSegment κ a b c d S) {f : W.Flag} (hf : f ∉ S) : + (RelTransitionSystem.Orientation.segFlip hsq o hsame + hseg).isOut f = o.isOut f := ite_eq_right hf + +end SegFlipEval + +/-! ## The `∂`-flip of the colouring on the segment -/ + +section SegColouring + +variable {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {a b c d : W.Flag} {S : Finset W.Flag} + +/-- The `∂`-flip of a core odd colouring on the segment edges. -/ +noncomputable def segFlipColouring (hSpair : ∀ f ∈ S, W.pairing f ∈ S) {ℓ : ℕ} + (φ : F.CoreOddColouring ℓ) : F.CoreOddColouring ℓ := + ⟨fun g => if g.val ∈ S then oddPartner ℓ (φ.val g) else φ.val g, + fun g => by + have hnot : ∀ f : W.Flag, f ∉ S → W.pairing f ∉ S := by + intro f hf hmem + have h2 := hSpair _ hmem + rw [W.pairing_invol] at h2 + exact hf h2 + have hbeta : (if W.pairing g.val ∈ S then + oddPartner ℓ (φ.val + ⟨W.pairing g.val, F.pairing_mem_coreFlags g.prop⟩) + else φ.val + ⟨W.pairing g.val, F.pairing_mem_coreFlags g.prop⟩) = + (if g.val ∈ S then oddPartner ℓ (φ.val g) else φ.val g) := by + by_cases hg : g.val ∈ S + · rw [ite_eq_left (hSpair _ hg), ite_eq_left hg, φ.prop g] + · rw [ite_eq_right (hnot _ hg), ite_eq_right hg, φ.prop g] + exact hbeta⟩ + +/-- The segment-flipped colouring, unfolded. -/ +theorem segFlipColouring_val (hSpair : ∀ f ∈ S, W.pairing f ∈ S) {ℓ : ℕ} + (φ : F.CoreOddColouring ℓ) + (g : {g : W.Flag // g ∈ F.coreFlags}) : + (segFlipColouring hSpair φ).val g = + if g.val ∈ S then oddPartner ℓ (φ.val g) else φ.val g := + rfl + +/-- It is an involution, so it is a bijection of the colouring +sum. -/ +theorem segFlipColouring_involutive + (hSpair : ∀ f ∈ S, W.pairing f ∈ S) {ℓ : ℕ} : + Function.Involutive + (segFlipColouring hSpair (F := F) (ℓ := ℓ)) := by + intro φ + apply Subtype.ext + funext g + change (if g.val ∈ S then + oddPartner ℓ ((segFlipColouring hSpair φ).val g) + else (segFlipColouring hSpair φ).val g) = φ.val g + by_cases hg : g.val ∈ S + · rw [ite_eq_left hg, segFlipColouring_val hSpair φ g, ite_eq_left hg, + oddPartner_invol] + · rw [ite_eq_right hg, segFlipColouring_val hSpair φ g, ite_eq_right hg] + +/-- The `∂`-flip preserves the odd boundary constraint when the +segment carries no boundary flags. -/ +theorem coreOddBoundaryMatch_segFlipColouring {k ℓ : ℕ} + (st : GenBoundaryState k ℓ α) + (hSpair : ∀ f ∈ S, W.pairing f ∈ S) + (hSb : ∀ i : α, W.boundaryFlag i ∉ S) + (φ : F.CoreOddColouring ℓ) : + F.coreOddBoundaryMatch st (segFlipColouring hSpair φ) ↔ + F.coreOddBoundaryMatch st φ := by + have hval : ∀ (i : α) (hcore : W.boundaryFlag i ∈ F.coreFlags), + (segFlipColouring hSpair φ).val ⟨W.boundaryFlag i, hcore⟩ = + φ.val ⟨W.boundaryFlag i, hcore⟩ := by + intro i hcore + rw [segFlipColouring_val hSpair φ _, ite_eq_right (hSb i)] + unfold coreOddBoundaryMatch + constructor + · intro H i cc hst hcore + rw [← hval i hcore] + exact H i cc hst hcore + · intro H i cc hst hcore + rw [hval i hcore] + exact H i cc hst hcore + +end SegColouring + +/-! ## The flipped-segment ledger -/ + +section SegLedger + +variable {F : EdgeSubset W} {k ℓ : ℕ} {κ : F.RelTransitionSystem} + {a b c d : W.Flag} {v : W.Vertex} {S : Finset W.Flag} + +/-! ### The pairing sign as a total function -/ + +private theorem flipVal_of_mem {φ φ' : F.CoreOddColouring ℓ} + (hφ' : ∀ g, φ'.val g = + if g.val ∈ S then oddPartner ℓ (φ.val g) else φ.val g) + (g : {g : W.Flag // g ∈ F.coreFlags}) (hg : g.val ∈ S) : + φ'.val g = oddPartner ℓ (φ.val g) := by + rw [hφ' g, ite_eq_left hg] + +private theorem flipVal_of_notMem {φ φ' : F.CoreOddColouring ℓ} + (hφ' : ∀ g, φ'.val g = + if g.val ∈ S then oddPartner ℓ (φ.val g) else φ.val g) + (g : {g : W.Flag // g ∈ F.coreFlags}) (hg : g.val ∉ S) : + φ'.val g = φ.val g := by + rw [hφ' g, ite_eq_right hg] + +/-! ### Vertex-local in-sets -/ + +/-- The in-flags at a vertex whose colours the flip on `S` leaves +alone. -/ +noncomputable def keepS (S : Finset W.Flag) + {κ₀ : F.RelTransitionSystem} (o₀ : κ₀.Orientation) + (vv : W.Vertex) : Finset W.Flag := + (relInSetAt o₀ vv).filter (fun g => g ∉ S) + +/-- The in-flags at a vertex whose colours the flip on `S` +reverses. -/ +noncomputable def flipS (S : Finset W.Flag) + {κ₀ : F.RelTransitionSystem} (o₀ : κ₀.Orientation) + (vv : W.Vertex) : Finset W.Flag := + (relInSetAt o₀ vv).filter (fun g => g ∈ S) + +open scoped Classical in +private noncomputable def outbS (S : Finset W.Flag) + {κ₀ : F.RelTransitionSystem} (o₀ : κ₀.Orientation) + (vv : W.Vertex) : Finset W.Flag := + F.flags.filter + (fun f => W.attach f = Sum.inl vv ∧ o₀.isOut f = true ∧ f ∈ S) + +open scoped Classical in +private noncomputable def diffAtS (S : Finset W.Flag) + (vv : W.Vertex) : Finset W.Flag := + S.filter (fun g => W.attach g = Sum.inl vv) + +/-- Membership in the kept part of a vertex's in-set. -/ +theorem mem_keepS {κ₀ : F.RelTransitionSystem} + {o₀ : κ₀.Orientation} {vv : W.Vertex} {g : W.Flag} : + g ∈ keepS S o₀ vv ↔ g ∈ relInSetAt o₀ vv ∧ g ∉ S := by + classical + exact Finset.mem_filter + +/-- Membership in the flipped part of a vertex's in-set. -/ +theorem mem_flipS {κ₀ : F.RelTransitionSystem} + {o₀ : κ₀.Orientation} {vv : W.Vertex} {g : W.Flag} : + g ∈ flipS S o₀ vv ↔ g ∈ relInSetAt o₀ vv ∧ g ∈ S := by + classical + exact Finset.mem_filter + +/-- The flip on `S` splits a vertex's in-set into the kept and the +flipped part. -/ +theorem relInSetAt_val_split {κ₀ : F.RelTransitionSystem} + (o₀ : κ₀.Orientation) (vv : W.Vertex) : + (relInSetAt o₀ vv).val = + (keepS S o₀ vv).val + (flipS S o₀ vv).val := by + unfold keepS flipS + rw [Finset.filter_val, Finset.filter_val, add_comm] + exact (Multiset.filter_add_not (fun g => g ∈ S) + (relInSetAt o₀ vv).val).symm + +/-- A product over a vertex's in-set splits along that partition. -/ +theorem prod_relInSetAt_split {M : Type*} [CommMonoid M] + {κ₀ : F.RelTransitionSystem} (o₀ : κ₀.Orientation) + (vv : W.Vertex) (f : W.Flag → M) : + ∏ g ∈ relInSetAt o₀ vv, f g = + (∏ g ∈ flipS S o₀ vv, f g) * ∏ g ∈ keepS S o₀ vv, f g := by + unfold flipS keepS + exact (Finset.prod_filter_mul_prod_filter_not + (relInSetAt o₀ vv) _ f).symm + +private theorem mem_outbS {κ₀ : F.RelTransitionSystem} + {o₀ : κ₀.Orientation} {vv : W.Vertex} {g : W.Flag} : + g ∈ outbS S o₀ vv ↔ + g ∈ F.flags ∧ W.attach g = Sum.inl vv ∧ + o₀.isOut g = true ∧ g ∈ S := by + classical + exact Finset.mem_filter + +private theorem mem_diffAtS {vv : W.Vertex} {g : W.Flag} : + g ∈ diffAtS S vv ↔ g ∈ S ∧ W.attach g = Sum.inl vv := by + classical + exact Finset.mem_filter + +private theorem keepS_disjoint_outbS {κ₀ : F.RelTransitionSystem} + (o₀ : κ₀.Orientation) (vv : W.Vertex) : + Disjoint (keepS S o₀ vv) (outbS S o₀ vv) := by + rw [Finset.disjoint_left] + intro g hg1 hg2 + obtain ⟨-, -, -, hgS⟩ := mem_outbS.mp hg2 + exact (mem_keepS.mp hg1).2 hgS + +private theorem flipS_disjoint_outbS {κ₀ : F.RelTransitionSystem} + (o₀ : κ₀.Orientation) (vv : W.Vertex) : + Disjoint (flipS S o₀ vv) (outbS S o₀ vv) := by + rw [Finset.disjoint_left] + intro g hg1 hg2 + have h1 := (mem_relInSetAt.mp (mem_flipS.mp hg1).1).2.2 + obtain ⟨-, -, h2, -⟩ := mem_outbS.mp hg2 + rw [h1] at h2 + cases h2 + +private theorem match_injOn_flipS {κ₀ : F.RelTransitionSystem} + (o₀ : κ₀.Orientation) (vv : W.Vertex) : + ∀ x ∈ flipS S o₀ vv, ∀ y ∈ flipS S o₀ vv, + κ₀.match_ x = κ₀.match_ y → x = y := by + intro x hx y hy hxy + have hxint := relInSetAt_subset_internal (mem_flipS.mp hx).1 + have hyint := relInSetAt_subset_internal (mem_flipS.mp hy).1 + calc x = κ₀.match_ (κ₀.match_ x) := (κ₀.match_invol x hxint).symm + _ = κ₀.match_ (κ₀.match_ y) := by rw [hxy] + _ = y := κ₀.match_invol y hyint + +private theorem diffAtS_split {κ₀ : F.RelTransitionSystem} + (o₀ : κ₀.Orientation) + (hSint : ∀ f ∈ S, f ∈ F.internalFlags) (vv : W.Vertex) : + diffAtS S vv = (flipS S o₀ vv).disjUnion (outbS S o₀ vv) + (flipS_disjoint_outbS o₀ vv) := by + apply Finset.ext + intro g + rw [Finset.mem_disjUnion, mem_diffAtS, mem_flipS, mem_outbS, + mem_relInSetAt] + constructor + · rintro ⟨hgS, hgat⟩ + have hgfl : g ∈ F.flags := + mem_flags_of_internalFlags F (hSint g hgS) + cases hb : o₀.isOut g + · exact Or.inl ⟨⟨hgfl, hgat, rfl⟩, hgS⟩ + · exact Or.inr ⟨hgfl, hgat, rfl, hgS⟩ + · rintro (⟨⟨_, hgat, _⟩, hgS⟩ | ⟨_, hgat, _, hgS⟩) + · exact ⟨hgS, hgat⟩ + · exact ⟨hgS, hgat⟩ + +private theorem S_eq_biUnion_diffAtS (hSint : ∀ f ∈ S, f ∈ F.internalFlags) : + S = Finset.univ.biUnion (fun vv => diffAtS S vv) := by + apply Finset.ext + intro g + rw [Finset.mem_biUnion] + constructor + · intro hg + obtain ⟨vv, hvv⟩ := F.attach_internal_of_mem (hSint g hg) + exact ⟨vv, Finset.mem_univ vv, mem_diffAtS.mpr ⟨hg, hvv⟩⟩ + · rintro ⟨vv, _, hvv⟩ + exact (mem_diffAtS.mp hvv).1 + +private theorem diffAtS_pairwiseDisjoint : + Set.PairwiseDisjoint (↑(Finset.univ : Finset W.Vertex)) + (fun vv => diffAtS S vv) := by + intro x _ y _ hxy + refine Finset.disjoint_left.mpr (fun g hgx hgy => hxy ?_) + have h1 := (mem_diffAtS.mp hgx).2 + have h2 := (mem_diffAtS.mp hgy).2 + rw [h1] at h2 + exact Sum.inl.inj h2 + +private theorem prod_inSign_seg (hSpair : ∀ f ∈ S, W.pairing f ∈ S) + (hScore : ∀ f ∈ S, f ∈ F.coreFlags) + (φ : F.CoreOddColouring ℓ) : + ∏ g ∈ S, inSign φ g = 1 := by + refine Finset.prod_involution (fun g _ => W.pairing g) ?_ ?_ ?_ ?_ + · intro g hg + rw [inSign_pairing φ (hScore g hg)] + exact inSign_mul_self φ g + · exact fun g _ _ => W.pairing_ne g + · exact fun g hg => hSpair g hg + · exact fun g _ => W.pairing_invol g + +/-! ### The pair blocks -/ + +private theorem pairFn_eq {κ₀ : F.RelTransitionSystem} + (φ : F.CoreOddColouring ℓ) + (f : {f : W.Flag // f ∈ F.internalFlags}) {m : W.Flag} + (hm : κ₀.match_ f.val = m) (hmi : m ∈ F.coreFlags) : + F.coreOddPairFn κ₀ φ f = + [φ.val ⟨f.val, F.internalFlags_subset_coreFlags f.prop⟩, + oddPartner ℓ (φ.val ⟨m, hmi⟩)] := by + subst hm + rfl + +/-! ### The parametric vertex data of the move -/ + +/-- The abstract data of the flipped-segment comparison at the +move's vertex, unifying the two orientation branches: `P` is the +kept in-flag whose partner changes (`P–R` re-pairs to `P–Q`), `Q` +the flipped in-flag, `R` the flipped out-flag re-paired to `T`, +`T` the kept out-flag. -/ +private structure SegData (κ κ' : F.RelTransitionSystem) + (o : κ.Orientation) (o' : κ'.Orientation) + (S : Finset W.Flag) (v : W.Vertex) (P Q R T : W.Flag) : + Prop where + hiso : ∀ f, o'.isOut f = if f ∈ S then !o.isOut f else o.isOut f + hSpair : ∀ f ∈ S, W.pairing f ∈ S + hSint : ∀ f ∈ S, f ∈ F.internalFlags + hSmatch : ∀ g ∈ S, g ≠ Q → g ≠ R → κ.match_ g ∈ S + hSnot : ∀ g ∈ F.internalFlags, g ∉ S → g ≠ P → g ≠ T → + κ.match_ g ∉ S + hoff : ∀ g, g ≠ P → g ≠ Q → g ≠ R → g ≠ T → + κ'.match_ g = κ.match_ g + hPint : P ∈ F.internalFlags + hQint : Q ∈ F.internalFlags + hRint : R ∈ F.internalFlags + hTint : T ∈ F.internalFlags + hPS : P ∉ S + hQS : Q ∈ S + hRS : R ∈ S + hTS : T ∉ S + hPout : o.isOut P = false + hQout : o.isOut Q = false + hRout : o.isOut R = true + hTout : o.isOut T = true + hPv : W.attach P = Sum.inl v + hQv : W.attach Q = Sum.inl v + hRv : W.attach R = Sum.inl v + hTv : W.attach T = Sum.inl v + hmPR : κ.match_ P = R + hmQT : κ.match_ Q = T + hm'PQ : κ'.match_ P = Q + hm'RT : κ'.match_ R = T + +namespace SegData + +variable {κ' : F.RelTransitionSystem} {o : κ.Orientation} + {o' : κ'.Orientation} {P Q R T : W.Flag} + +private theorem hmRP (hd : SegData κ κ' o o' S v P Q R T) : + κ.match_ R = P := by + rw [← hd.hmPR, κ.match_invol P hd.hPint] + +private theorem hmTQ (hd : SegData κ κ' o o' S v P Q R T) : + κ.match_ T = Q := by + rw [← hd.hmQT, κ.match_invol Q hd.hQint] + +private theorem hScore (hd : SegData κ κ' o o' S v P Q R T) + {f : W.Flag} (hf : f ∈ S) : f ∈ F.coreFlags := + F.internalFlags_subset_coreFlags (hd.hSint f hf) + +/-- A flag at another vertex avoids the square, so its repaired +match is untouched. -/ +private theorem hoff_at (hd : SegData κ κ' o o' S v P Q R T) + {vv : W.Vertex} (hvv : vv ≠ v) {g : W.Flag} + (hg : W.attach g = Sum.inl vv) : + κ'.match_ g = κ.match_ g := by + have hne : ∀ x : W.Flag, W.attach x = Sum.inl v → g ≠ x := by + intro x hx he + rw [he, hx] at hg + exact hvv (Sum.inl.inj hg).symm + exact hd.hoff g (hne P hd.hPv) (hne Q hd.hQv) (hne R hd.hRv) + (hne T hd.hTv) + +/-- The in-set of the flipped orientation: the kept in-flags plus +the segment flags that were outgoing. -/ +private theorem inb_flip (hd : SegData κ κ' o o' S v P Q R T) + (vv : W.Vertex) : + relInSetAt o' vv = (keepS S o vv).disjUnion (outbS S o vv) + (keepS_disjoint_outbS o vv) := by + apply Finset.ext + intro g + rw [Finset.mem_disjUnion, mem_relInSetAt, mem_keepS, mem_outbS, + mem_relInSetAt] + constructor + · rintro ⟨hgfl, hgat, hgout⟩ + rw [hd.hiso g] at hgout + by_cases hgS : g ∈ S + · rw [ite_eq_left hgS] at hgout + refine Or.inr ⟨hgfl, hgat, ?_, hgS⟩ + cases hb : o.isOut g + · rw [hb] at hgout + cases hgout + · rfl + · rw [ite_eq_right hgS] at hgout + exact Or.inl ⟨⟨hgfl, hgat, hgout⟩, hgS⟩ + · rintro (⟨⟨hgfl, hgat, hgout⟩, hgS⟩ | ⟨hgfl, hgat, hgout, hgS⟩) + · refine ⟨hgfl, hgat, ?_⟩ + rw [hd.hiso g, ite_eq_right hgS] + exact hgout + · refine ⟨hgfl, hgat, ?_⟩ + rw [hd.hiso g, ite_eq_left hgS, hgout] + rfl + +/-- Away from the move's vertex, the outgoing segment flags are the +matches of the flipped in-flags. -/ +private theorem outbS_ne (hd : SegData κ κ' o o' S v P Q R T) + {vv : W.Vertex} (hvv : vv ≠ v) : + outbS S o vv = (flipS S o vv).image κ.match_ := by + apply Finset.ext + intro g + rw [mem_outbS, Finset.mem_image] + constructor + · rintro ⟨hgfl, hgat, hgout, hgS⟩ + have hgint : g ∈ F.internalFlags := + mem_internalFlags_of hgfl ⟨vv, hgat⟩ + have hne : ∀ x : W.Flag, W.attach x = Sum.inl v → g ≠ x := by + intro x hx he + rw [he, hx] at hgat + exact hvv (Sum.inl.inj hgat).symm + have hmS : κ.match_ g ∈ S := + hd.hSmatch g hgS (hne Q hd.hQv) (hne R hd.hRv) + have hmint := κ.match_mem g hgint + refine ⟨κ.match_ g, mem_flipS.mpr ⟨mem_relInSetAt.mpr + ⟨mem_flags_of_internalFlags F hmint, + κ.match_vertex g hgint vv hgat, ?_⟩, hmS⟩, + κ.match_invol g hgint⟩ + rw [o.match_flip g hgint, hgout] + rfl + · rintro ⟨x, hx, rfl⟩ + obtain ⟨hxin, hxS⟩ := mem_flipS.mp hx + obtain ⟨hxfl, hxat, hxout⟩ := mem_relInSetAt.mp hxin + have hxint : x ∈ F.internalFlags := + mem_internalFlags_of hxfl ⟨vv, hxat⟩ + have hne : ∀ y : W.Flag, W.attach y = Sum.inl v → x ≠ y := by + intro y hy he + rw [he, hy] at hxat + exact hvv (Sum.inl.inj hxat).symm + have hmint := κ.match_mem x hxint + refine ⟨mem_flags_of_internalFlags F hmint, + κ.match_vertex x hxint vv hxat, ?_, + hd.hSmatch x hxS (hne Q hd.hQv) (hne R hd.hRv)⟩ + rw [o.match_flip x hxint, hxout] + rfl + +private theorem Q_mem_flipS (hd : SegData κ κ' o o' S v P Q R T) : + Q ∈ flipS S o v := + mem_flipS.mpr ⟨mem_relInSetAt.mpr + ⟨mem_flags_of_internalFlags F hd.hQint, hd.hQv, hd.hQout⟩, + hd.hQS⟩ + +private theorem P_mem_keepS (hd : SegData κ κ' o o' S v P Q R T) : + P ∈ keepS S o v := + mem_keepS.mpr ⟨mem_relInSetAt.mpr + ⟨mem_flags_of_internalFlags F hd.hPint, hd.hPv, hd.hPout⟩, + hd.hPS⟩ + +/-- At the move's vertex, the outgoing segment flags are `R` +together with the matches of the flipped in-flags other than `Q`. -/ +private theorem outbS_v (hd : SegData κ κ' o o' S v P Q R T) : + outbS S o v = + insert R (((flipS S o v).erase Q).image κ.match_) := by + apply Finset.ext + intro g + rw [mem_outbS, Finset.mem_insert, Finset.mem_image] + constructor + · rintro ⟨hgfl, hgat, hgout, hgS⟩ + by_cases hgR : g = R + · exact Or.inl hgR + · have hgint : g ∈ F.internalFlags := + mem_internalFlags_of hgfl ⟨v, hgat⟩ + have hgQ : g ≠ Q := by + intro he + rw [he, hd.hQout] at hgout + cases hgout + have hmS : κ.match_ g ∈ S := hd.hSmatch g hgS hgQ hgR + have hmint := κ.match_mem g hgint + have hmQ : κ.match_ g ≠ Q := by + intro he + have h2 := congrArg κ.match_ he + rw [κ.match_invol g hgint, hd.hmQT] at h2 + rw [h2] at hgS + exact hd.hTS hgS + refine Or.inr ⟨κ.match_ g, Finset.mem_erase.mpr + ⟨hmQ, mem_flipS.mpr ⟨mem_relInSetAt.mpr + ⟨mem_flags_of_internalFlags F hmint, + κ.match_vertex g hgint v hgat, ?_⟩, hmS⟩⟩, + κ.match_invol g hgint⟩ + rw [o.match_flip g hgint, hgout] + rfl + · rintro (rfl | ⟨x, hx, rfl⟩) + · exact ⟨mem_flags_of_internalFlags F hd.hRint, hd.hRv, + hd.hRout, hd.hRS⟩ + · obtain ⟨hxQ, hxfli⟩ := Finset.mem_erase.mp hx + obtain ⟨hxin, hxS⟩ := mem_flipS.mp hxfli + obtain ⟨hxfl, hxat, hxout⟩ := mem_relInSetAt.mp hxin + have hxint : x ∈ F.internalFlags := + mem_internalFlags_of hxfl ⟨v, hxat⟩ + have hxR : x ≠ R := by + intro he + rw [he, hd.hRout] at hxout + cases hxout + have hmint := κ.match_mem x hxint + refine ⟨mem_flags_of_internalFlags F hmint, + κ.match_vertex x hxint v hxat, ?_, + hd.hSmatch x hxS hxQ hxR⟩ + rw [o.match_flip x hxint, hxout] + rfl + +private theorem R_notMem_image (hd : SegData κ κ' o o' S v P Q R T) : + R ∉ ((flipS S o v).erase Q).image κ.match_ := by + intro hmem + obtain ⟨x, hx, hxR⟩ := Finset.mem_image.mp hmem + have hxint : x ∈ F.internalFlags := + relInSetAt_subset_internal (mem_flipS.mp (Finset.mem_erase.mp hx).2).1 + have h2 := congrArg κ.match_ hxR + rw [κ.match_invol x hxint, hd.hmRP] at h2 + have hxS := (mem_flipS.mp (Finset.mem_erase.mp hx).2).2 + rw [h2] at hxS + exact hd.hPS hxS + +/-- Away from the move's vertex: the flipped vertex sign. -/ +private theorem signAt_flip_ne (hd : SegData κ κ' o o' S v P Q R T) + {vv : W.Vertex} (hvv : vv ≠ v) {φ φ' : F.CoreOddColouring ℓ} + (hφ' : ∀ g, φ'.val g = + if g.val ∈ S then oddPartner ℓ (φ.val g) else φ.val g) : + F.coreOddSignAt o' φ' vv = + (-1 : ℤ) ^ (flipS S o vv).card * + (∏ g ∈ diffAtS S vv, inSign φ g) * + F.coreOddSignAt o φ vv := by + have hne : ∀ g : W.Flag, W.attach g = Sum.inl vv → + ∀ x : W.Flag, W.attach x = Sum.inl v → g ≠ x := by + intro g hg x hx he + rw [he, hx] at hg + exact hvv (Sum.inl.inj hg).symm + rw [signAt_eq_prod o' φ' vv, signAt_eq_prod o φ vv, + hd.inb_flip vv, Finset.prod_disjUnion, hd.outbS_ne hvv, + Finset.prod_image (match_injOn_flipS o vv)] + have hkeep : ∏ g ∈ keepS S o vv, inSign φ' (κ'.match_ g) = + ∏ g ∈ keepS S o vv, inSign φ (κ.match_ g) := by + refine Finset.prod_congr rfl (fun g hg => ?_) + obtain ⟨hgin, hgS⟩ := mem_keepS.mp hg + obtain ⟨hgfl, hgat, _⟩ := mem_relInSetAt.mp hgin + have hgint : g ∈ F.internalFlags := + mem_internalFlags_of hgfl ⟨vv, hgat⟩ + rw [hd.hoff_at hvv hgat, + inSign_flip_of_notMem hφ' + (hd.hSnot g hgint hgS (hne g hgat P hd.hPv) + (hne g hgat T hd.hTv))] + have himg : ∏ g ∈ flipS S o vv, + inSign φ' (κ'.match_ (κ.match_ g)) = + ∏ g ∈ flipS S o vv, -inSign φ g := by + refine Finset.prod_congr rfl (fun g hg => ?_) + obtain ⟨hgin, hgS⟩ := mem_flipS.mp hg + obtain ⟨hgfl, hgat, _⟩ := mem_relInSetAt.mp hgin + have hgint : g ∈ F.internalFlags := + mem_internalFlags_of hgfl ⟨vv, hgat⟩ + have hmat : W.attach (κ.match_ g) = Sum.inl vv := + κ.match_vertex g hgint vv hgat + rw [hd.hoff_at hvv hmat, κ.match_invol g hgint, + inSign_flip_of_mem hφ' hgS + (F.internalFlags_subset_coreFlags hgint)] + rw [hkeep, himg, Finset.prod_neg, + diffAtS_split o hd.hSint vv, Finset.prod_disjUnion, + hd.outbS_ne hvv, Finset.prod_image (match_injOn_flipS o vv), + prod_relInSetAt_split (S := S) o vv (fun g => inSign φ (κ.match_ g))] + have hsq2 : (∏ g ∈ flipS S o vv, inSign φ (κ.match_ g)) * + (∏ g ∈ flipS S o vv, inSign φ (κ.match_ g)) = 1 := by + rw [← Finset.prod_mul_distrib] + exact Finset.prod_eq_one (fun g _ => inSign_mul_self φ _) + have key : ∀ (A M K : ℤ) (cN : ℕ), M * M = 1 → + K * ((-1) ^ cN * A) = (-1) ^ cN * (A * M) * (M * K) := by + intro A M K cN hM + calc K * ((-1) ^ cN * A) + = (M * M) * (K * ((-1) ^ cN * A)) := by rw [hM, one_mul] + _ = (-1) ^ cN * (A * M) * (M * K) := by ring + exact key _ _ _ _ hsq2 + +/-- At the move's vertex: the flipped vertex sign. -/ +private theorem signAt_flip_v (hd : SegData κ κ' o o' S v P Q R T) + {φ φ' : F.CoreOddColouring ℓ} + (hφ' : ∀ g, φ'.val g = + if g.val ∈ S then oddPartner ℓ (φ.val g) else φ.val g) : + F.coreOddSignAt o' φ' v = + (-1 : ℤ) ^ (flipS S o v).card * + (∏ g ∈ diffAtS S v, inSign φ g) * + F.coreOddSignAt o φ v := by + have hinjE : ∀ x ∈ (flipS S o v).erase Q, + ∀ y ∈ (flipS S o v).erase Q, + κ.match_ x = κ.match_ y → x = y := + fun x hx y hy => match_injOn_flipS o v x + (Finset.mem_of_mem_erase hx) y (Finset.mem_of_mem_erase hy) + rw [signAt_eq_prod o' φ' v, hd.inb_flip v, Finset.prod_disjUnion, + hd.outbS_v, Finset.prod_insert hd.R_notMem_image, + Finset.prod_image hinjE, + ← Finset.mul_prod_erase _ _ hd.P_mem_keepS] + have hPterm : inSign φ' (κ'.match_ P) = -inSign φ Q := by + rw [hd.hm'PQ, inSign_flip_of_mem hφ' hd.hQS + (F.internalFlags_subset_coreFlags hd.hQint)] + have hkeep : ∏ g ∈ (keepS S o v).erase P, + inSign φ' (κ'.match_ g) = + ∏ g ∈ (keepS S o v).erase P, inSign φ (κ.match_ g) := by + refine Finset.prod_congr rfl (fun g hg => ?_) + obtain ⟨hgP, hgk⟩ := Finset.mem_erase.mp hg + obtain ⟨hgin, hgS⟩ := mem_keepS.mp hgk + obtain ⟨hgfl, hgat, hgout⟩ := mem_relInSetAt.mp hgin + have hgint : g ∈ F.internalFlags := + mem_internalFlags_of hgfl ⟨v, hgat⟩ + have hgQ : g ≠ Q := fun he => hgS (he ▸ hd.hQS) + have hgR : g ≠ R := fun he => hgS (he ▸ hd.hRS) + have hgT : g ≠ T := by + intro he + rw [he, hd.hTout] at hgout + cases hgout + rw [hd.hoff g hgP hgQ hgR hgT, + inSign_flip_of_notMem hφ' (hd.hSnot g hgint hgS hgP hgT)] + have hRterm : inSign φ' (κ'.match_ R) = inSign φ T := by + rw [hd.hm'RT, inSign_flip_of_notMem hφ' hd.hTS] + have himg : ∏ g ∈ (flipS S o v).erase Q, + inSign φ' (κ'.match_ (κ.match_ g)) = + ∏ g ∈ (flipS S o v).erase Q, -inSign φ g := by + refine Finset.prod_congr rfl (fun g hg => ?_) + obtain ⟨hgQ, hgfli⟩ := Finset.mem_erase.mp hg + obtain ⟨hgin, hgS⟩ := mem_flipS.mp hgfli + obtain ⟨hgfl, hgat, hgout⟩ := mem_relInSetAt.mp hgin + have hgint : g ∈ F.internalFlags := + mem_internalFlags_of hgfl ⟨v, hgat⟩ + have hgR : g ≠ R := by + intro he + rw [he, hd.hRout] at hgout + cases hgout + have hmP : κ.match_ g ≠ P := by + intro he + have h2 := congrArg κ.match_ he + rw [κ.match_invol g hgint, hd.hmPR] at h2 + exact hgR h2 + have hmQ : κ.match_ g ≠ Q := by + intro he + have h2 := congrArg κ.match_ he + rw [κ.match_invol g hgint, hd.hmQT] at h2 + exact hd.hTS (h2 ▸ hgS) + have hmR : κ.match_ g ≠ R := by + intro he + have h2 := congrArg κ.match_ he + rw [κ.match_invol g hgint, hd.hmRP] at h2 + exact hd.hPS (h2 ▸ hgS) + have hmT : κ.match_ g ≠ T := by + intro he + have h2 := congrArg κ.match_ he + rw [κ.match_invol g hgint, hd.hmTQ] at h2 + exact hgQ h2 + rw [hd.hoff _ hmP hmQ hmR hmT, κ.match_invol g hgint, + inSign_flip_of_mem hφ' hgS + (F.internalFlags_subset_coreFlags hgint)] + rw [hPterm, hkeep, hRterm, himg, Finset.prod_neg, + signAt_eq_prod o φ v, diffAtS_split o hd.hSint v, + Finset.prod_disjUnion, hd.outbS_v, + Finset.prod_insert hd.R_notMem_image, + Finset.prod_image hinjE, + ← Finset.mul_prod_erase _ (fun g => inSign φ g) + hd.Q_mem_flipS, + prod_relInSetAt_split (S := S) o v (fun g => inSign φ (κ.match_ g)), + ← Finset.mul_prod_erase _ (fun g => inSign φ (κ.match_ g)) + hd.Q_mem_flipS, + ← Finset.mul_prod_erase _ (fun g => inSign φ (κ.match_ g)) + hd.P_mem_keepS, + hd.hmPR, hd.hmQT, + ← Finset.card_erase_add_one hd.Q_mem_flipS, pow_succ] + have hr2 : inSign φ R * inSign φ R = 1 := inSign_mul_self φ R + have hM2 : (∏ g ∈ (flipS S o v).erase Q, + inSign φ (κ.match_ g)) * + (∏ g ∈ (flipS S o v).erase Q, inSign φ (κ.match_ g)) = 1 := by + rw [← Finset.prod_mul_distrib] + exact Finset.prod_eq_one (fun g _ => inSign_mul_self φ _) + have key : ∀ (q r t A M K : ℤ) (cN : ℕ), r * r = 1 → M * M = 1 → + (-q * K) * (t * ((-1) ^ cN * A)) = + (-1) ^ cN * -1 * ((q * A) * (r * M)) * ((t * M) * (r * K)) := by + intro q r t A M K cN hr hM + calc (-q * K) * (t * ((-1) ^ cN * A)) + = (r * r) * ((M * M) * + ((-q * K) * (t * ((-1) ^ cN * A)))) := by + rw [hr, hM, one_mul, one_mul] + _ = (-1) ^ cN * -1 * ((q * A) * (r * M)) * + ((t * M) * (r * K)) := by ring + exact key _ _ _ _ _ _ _ hr2 hM2 + +/-- Away from the move's vertex: the flipped vertex list. -/ +private theorem evalList_flip_ne (hd : SegData κ κ' o o' S v P Q R T) + (hM : MixedFunctional k ℓ) (μ : Multiset (Fin k)) + {vv : W.Vertex} (hvv : vv ≠ v) {φ φ' : F.CoreOddColouring ℓ} + (hφ' : ∀ g, φ'.val g = + if g.val ∈ S then oddPartner ℓ (φ.val g) else φ.val g) : + hM.evalOdd μ (F.coreOddListAt o' φ' vv) = + (-1 : ℂ) ^ (flipS S o vv).card * + hM.evalOdd μ (F.coreOddListAt o φ vv) := by + have hne : ∀ g : W.Flag, W.attach g = Sum.inl vv → + ∀ x : W.Flag, W.attach x = Sum.inl v → g ≠ x := by + intro g hg x hx he + rw [he, hx] at hg + exact hvv (Sum.inl.inj hg).symm + have Hk : ∀ g ∈ (keepS S o vv).toList, g ∈ F.internalFlags := + fun g hg => relInSetAt_subset_internal + (mem_keepS.mp (Finset.mem_toList.mp hg)).1 + have Hf : ∀ g ∈ (flipS S o vv).toList, g ∈ F.internalFlags := + fun g hg => relInSetAt_subset_internal + (mem_flipS.mp (Finset.mem_toList.mp hg)).1 + have H2 : ∀ g ∈ (keepS S o vv).toList ++ + (flipS S o vv).toList.map κ.match_, + g ∈ F.internalFlags := by + intro g hg + rcases List.mem_append.mp hg with hg | hg + · exact Hk g hg + · obtain ⟨x, hx, rfl⟩ := List.mem_map.mp hg + exact κ.match_mem x (Hf x hx) + have H3 : ∀ g ∈ (keepS S o vv).toList ++ (flipS S o vv).toList, + g ∈ F.internalFlags := by + intro g hg + rcases List.mem_append.mp hg with hg | hg + · exact Hk g hg + · exact Hf g hg + -- ═══════ BOTH IN-FLAG ENUMERATIONS, SPLIT BY THE FLIP ═══════ + -- The unflipped in-flags are common to the two orientations; the + -- flipped ones appear under the transported one through the + -- matching. + have hbase : (F.relInFlagsAt o vv).Perm + ((keepS S o vv).toList ++ (flipS S o vv).toList) := by + rw [← Multiset.coe_eq_coe, relInFlagsAt_coe o vv, + ← Multiset.coe_add, Finset.coe_toList, Finset.coe_toList] + exact relInSetAt_val_split (S := S) o vv + have hbase' : (F.relInFlagsAt o' vv).Perm + ((keepS S o vv).toList ++ + (flipS S o vv).toList.map κ.match_) := by + rw [← Multiset.coe_eq_coe, relInFlagsAt_coe o' vv, + ← Multiset.coe_add, Finset.coe_toList, ← Multiset.map_coe, + Finset.coe_toList] + rw [hd.inb_flip vv, Finset.disjUnion_val, hd.outbS_ne hvv, + Finset.image_val_of_injOn (fun x hx y hy => + match_injOn_flipS o vv x (Finset.mem_coe.mp hx) y + (Finset.mem_coe.mp hy))] + unfold EdgeSubset.coreOddListAt + simp only [List.attachWith] + calc hM.evalOdd μ ((List.pmap Subtype.mk (F.relInFlagsAt o' vv) + (fun _ hf => F.mem_internal_of_mem_relInFlagsAt hf)).flatMap + (F.coreOddPairFn κ' φ')) + = hM.evalOdd μ ((List.pmap Subtype.mk + ((keepS S o vv).toList ++ + (flipS S o vv).toList.map κ.match_) H2).flatMap + (F.coreOddPairFn κ' φ')) := by + have hp := hM.evalOdd_flatMap_perm μ + (F.coreOddPairFn κ' φ') (fun _ => rfl) + (perm_pmap Subtype.mk hbase' + (fun _ hf => F.mem_internal_of_mem_relInFlagsAt hf) H2) + [] + simpa using hp + _ = hM.evalOdd μ + ((List.pmap Subtype.mk (keepS S o vv).toList Hk).flatMap + (F.coreOddPairFn κ φ) ++ + (List.pmap Subtype.mk (flipS S o vv).toList Hf).flatMap + (fun fs => [pairB (κ₀ := κ) φ fs, pairA φ fs])) := by + rw [List.pmap_append, List.flatMap_append] + refine congrArg (hM.evalOdd μ) (congrArg₂ + (fun x y : List (Fin (2 * ℓ)) => x ++ y) ?_ ?_) + · refine pmap_flatMap_congr _ _ _ _ _ _ _ ?_ + intro g hg h₁ h₂ + obtain ⟨hgin, hgS⟩ := + mem_keepS.mp (Finset.mem_toList.mp hg) + obtain ⟨hgfl, hgat, _⟩ := mem_relInSetAt.mp hgin + have hgint : g ∈ F.internalFlags := + mem_internalFlags_of hgfl ⟨vv, hgat⟩ + have hmS : κ.match_ g ∉ S := + hd.hSnot g hgint hgS (hne g hgat P hd.hPv) + (hne g hgat T hd.hTv) + rw [pairFn_eq (κ₀ := κ') φ' ⟨g, h₁⟩ + (hd.hoff_at hvv hgat) + (F.internalFlags_subset_coreFlags + (κ.match_mem g hgint)), + pairFn_eq (κ₀ := κ) φ ⟨g, h₂⟩ rfl + (F.internalFlags_subset_coreFlags + (κ.match_mem g hgint)), + flipVal_of_notMem hφ' _ hgS, + flipVal_of_notMem hφ' _ hmS] + · rw [List.pmap_map] + refine pmap_flatMap_congr _ _ _ _ _ _ _ ?_ + intro x hx h₁ h₂ + obtain ⟨hxin, hxS⟩ := + mem_flipS.mp (Finset.mem_toList.mp hx) + obtain ⟨hxfl, hxat, _⟩ := mem_relInSetAt.mp hxin + have hxint : x ∈ F.internalFlags := + mem_internalFlags_of hxfl ⟨vv, hxat⟩ + have hmat : W.attach (κ.match_ x) = Sum.inl vv := + κ.match_vertex x hxint vv hxat + have hmS : κ.match_ x ∈ S := + hd.hSmatch x hxS (hne x hxat Q hd.hQv) + (hne x hxat R hd.hRv) + have hm'eq : κ'.match_ (κ.match_ x) = x := by + rw [hd.hoff_at hvv hmat, κ.match_invol x hxint] + rw [pairFn_eq (κ₀ := κ') φ' ⟨κ.match_ x, h₁⟩ hm'eq + (F.internalFlags_subset_coreFlags hxint), + flipVal_of_mem hφ' _ hmS, + flipVal_of_mem hφ' _ hxS, + oddPartner_invol] + rfl + _ = (-1 : ℂ) ^ (flipS S o vv).card * hM.evalOdd μ + ((List.pmap Subtype.mk (keepS S o vv).toList Hk).flatMap + (F.coreOddPairFn κ φ) ++ + (List.pmap Subtype.mk (flipS S o vv).toList Hf).flatMap + (fun fs => [pairA φ fs, pairB (κ₀ := κ) φ fs])) := by + have hrev := evalOdd_flatMap_rev hM μ (pairA φ) + (pairB (κ₀ := κ) φ) + (List.pmap Subtype.mk (flipS S o vv).toList Hf) + ((List.pmap Subtype.mk (keepS S o vv).toList Hk).flatMap + (F.coreOddPairFn κ φ)) + rw [hrev, List.length_pmap, Finset.length_toList] + _ = (-1 : ℂ) ^ (flipS S o vv).card * hM.evalOdd μ + ((List.pmap Subtype.mk + ((keepS S o vv).toList ++ (flipS S o vv).toList) + H3).flatMap (F.coreOddPairFn κ φ)) := by + rw [List.pmap_append, List.flatMap_append] + rw [coreOddPairFn_eq' (κ₀ := κ) φ] + _ = (-1 : ℂ) ^ (flipS S o vv).card * hM.evalOdd μ + ((List.pmap Subtype.mk (F.relInFlagsAt o vv) + (fun _ hf => + F.mem_internal_of_mem_relInFlagsAt hf)).flatMap + (F.coreOddPairFn κ φ)) := by + have hp := hM.evalOdd_flatMap_perm μ (F.coreOddPairFn κ φ) + (fun _ => rfl) + (perm_pmap Subtype.mk hbase.symm H3 + (fun _ hf => F.mem_internal_of_mem_relInFlagsAt hf)) + [] + simp only [List.nil_append] at hp + rw [hp] + +private theorem evalList_flip_v_expansion (hd : SegData κ κ' o o' S v P Q R T) + (hM : MixedFunctional k ℓ) (μ : Multiset (Fin k)) + {φ φ' : F.CoreOddColouring ℓ} + (hφ' : ∀ g, φ'.val g = + if g.val ∈ S then oddPartner ℓ (φ.val g) else φ.val g) + (HkE : ∀ g ∈ ((keepS S o v).erase P).toList, + g ∈ F.internalFlags) + (HfE : ∀ g ∈ ((flipS S o v).erase Q).toList, + g ∈ F.internalFlags) : + hM.evalOdd μ ((List.pmap Subtype.mk (F.relInFlagsAt o' v) + (fun _ hf => F.mem_internal_of_mem_relInFlagsAt hf)).flatMap + (F.coreOddPairFn κ' φ')) = + hM.evalOdd μ + ([φ.val ⟨P, F.internalFlags_subset_coreFlags hd.hPint⟩, + φ.val ⟨Q, F.internalFlags_subset_coreFlags hd.hQint⟩] ++ + (((List.pmap Subtype.mk ((keepS S o v).erase P).toList + HkE).flatMap (F.coreOddPairFn κ φ)) ++ + ([oddPartner ℓ (φ.val ⟨R, + F.internalFlags_subset_coreFlags hd.hRint⟩), + oddPartner ℓ (φ.val ⟨T, + F.internalFlags_subset_coreFlags hd.hTint⟩)] ++ + (List.pmap Subtype.mk + ((flipS S o v).erase Q).toList HfE).flatMap + (fun fs => [pairB (κ₀ := κ) φ fs, + pairA φ fs])))) := by + have hPint := hd.hPint + have hQint := hd.hQint + have hRint := hd.hRint + have hTint := hd.hTint + have Hnew : ∀ g ∈ P :: (((keepS S o v).erase P).toList ++ + R :: (((flipS S o v).erase Q).toList.map κ.match_)), + g ∈ F.internalFlags := by + intro g hg + rcases List.mem_cons.mp hg with rfl | hg + · exact hPint + rcases List.mem_append.mp hg with hg | hg + · exact HkE g hg + rcases List.mem_cons.mp hg with rfl | hg + · exact hRint + · obtain ⟨x, hx, rfl⟩ := List.mem_map.mp hg + exact κ.match_mem x (HfE x hx) + -- ═══════ SPLITTING THE IN-FLAGS INTO KEPT AND FLIPPED ═══════ + have hkeepval : (keepS S o v).val = + P ::ₘ ((keepS S o v).erase P).val := by + rw [Finset.erase_val] + exact (Multiset.cons_erase + (Finset.mem_def.mp hd.P_mem_keepS)).symm + have hflipval : (flipS S o v).val = + Q ::ₘ ((flipS S o v).erase Q).val := by + rw [Finset.erase_val] + exact (Multiset.cons_erase + (Finset.mem_def.mp hd.Q_mem_flipS)).symm + -- ═══════ THE TWO ENUMERATIONS ARE THE SAME MULTISET ═══════ + have hbase : (F.relInFlagsAt o v).Perm + (P :: (((keepS S o v).erase P).toList ++ + Q :: ((flipS S o v).erase Q).toList)) := by + rw [← Multiset.coe_eq_coe, relInFlagsAt_coe o v, + ← Multiset.cons_coe, ← Multiset.coe_add, + ← Multiset.cons_coe, Finset.coe_toList, Finset.coe_toList, + relInSetAt_val_split (S := S) o v, hkeepval, hflipval, + Multiset.cons_add] + have hinjE : ∀ x ∈ ((flipS S o v).erase Q : Finset W.Flag), + ∀ y ∈ ((flipS S o v).erase Q : Finset W.Flag), + κ.match_ x = κ.match_ y → x = y := + fun x hx y hy => match_injOn_flipS o v x + (Finset.mem_of_mem_erase hx) y (Finset.mem_of_mem_erase hy) + have hbase' : (F.relInFlagsAt o' v).Perm + (P :: (((keepS S o v).erase P).toList ++ + R :: (((flipS S o v).erase Q).toList.map κ.match_))) := by + rw [← Multiset.coe_eq_coe, relInFlagsAt_coe o' v, + ← Multiset.cons_coe, ← Multiset.coe_add, + ← Multiset.cons_coe, ← Multiset.map_coe, + Finset.coe_toList, Finset.coe_toList, + hd.inb_flip v, Finset.disjUnion_val, hkeepval, + hd.outbS_v, Finset.insert_val_of_notMem hd.R_notMem_image, + Finset.image_val_of_injOn (fun x hx y hy => + hinjE x (Finset.mem_coe.mp hx) y (Finset.mem_coe.mp hy)), + Multiset.cons_add] + calc hM.evalOdd μ ((List.pmap Subtype.mk (F.relInFlagsAt o' v) + (fun _ hf => F.mem_internal_of_mem_relInFlagsAt hf)).flatMap + (F.coreOddPairFn κ' φ')) + = hM.evalOdd μ ((List.pmap Subtype.mk + (P :: (((keepS S o v).erase P).toList ++ + R :: (((flipS S o v).erase Q).toList.map κ.match_))) + Hnew).flatMap (F.coreOddPairFn κ' φ')) := by + have hp := hM.evalOdd_flatMap_perm μ + (F.coreOddPairFn κ' φ') (fun _ => rfl) + (perm_pmap Subtype.mk hbase' + (fun _ hf => F.mem_internal_of_mem_relInFlagsAt hf) + Hnew) [] + simpa using hp + _ = hM.evalOdd μ + ([φ.val ⟨P, F.internalFlags_subset_coreFlags hPint⟩, + φ.val ⟨Q, F.internalFlags_subset_coreFlags hQint⟩] ++ + (((List.pmap Subtype.mk ((keepS S o v).erase P).toList + HkE).flatMap (F.coreOddPairFn κ φ)) ++ + ([oddPartner ℓ (φ.val ⟨R, + F.internalFlags_subset_coreFlags hRint⟩), + oddPartner ℓ (φ.val ⟨T, + F.internalFlags_subset_coreFlags hTint⟩)] ++ + (List.pmap Subtype.mk + ((flipS S o v).erase Q).toList HfE).flatMap + (fun fs => [pairB (κ₀ := κ) φ fs, + pairA φ fs])))) := by + simp only [List.pmap, List.pmap_append, List.flatMap_cons, + List.flatMap_append] + refine congrArg (hM.evalOdd μ) (congrArg₂ + (fun x y : List (Fin (2 * ℓ)) => x ++ y) ?_ + (congrArg₂ (fun x y : List (Fin (2 * ℓ)) => x ++ y) ?_ + (congrArg₂ (fun x y : List (Fin (2 * ℓ)) => x ++ y) + ?_ ?_))) + · rw [pairFn_eq (κ₀ := κ') φ' _ hd.hm'PQ + (F.internalFlags_subset_coreFlags hQint), + flipVal_of_notMem hφ' _ hd.hPS, + flipVal_of_mem hφ' _ hd.hQS, oddPartner_invol] + · refine pmap_flatMap_congr _ _ _ _ _ _ _ ?_ + intro g hg h₁ h₂ + obtain ⟨hgP, hgk⟩ := Finset.mem_erase.mp + (Finset.mem_toList.mp hg) + obtain ⟨hgin, hgS⟩ := mem_keepS.mp hgk + obtain ⟨hgfl, hgat, hgout⟩ := mem_relInSetAt.mp hgin + have hgint : g ∈ F.internalFlags := + mem_internalFlags_of hgfl ⟨v, hgat⟩ + have hgQ : g ≠ Q := fun he => hgS (he ▸ hd.hQS) + have hgR : g ≠ R := fun he => hgS (he ▸ hd.hRS) + have hgT : g ≠ T := by + intro he + rw [he, hd.hTout] at hgout + cases hgout + have hmS : κ.match_ g ∉ S := + hd.hSnot g hgint hgS hgP hgT + rw [pairFn_eq (κ₀ := κ') φ' ⟨g, h₁⟩ + (hd.hoff g hgP hgQ hgR hgT) + (F.internalFlags_subset_coreFlags + (κ.match_mem g hgint)), + pairFn_eq (κ₀ := κ) φ ⟨g, h₂⟩ rfl + (F.internalFlags_subset_coreFlags + (κ.match_mem g hgint)), + flipVal_of_notMem hφ' _ hgS, + flipVal_of_notMem hφ' _ hmS] + · rw [pairFn_eq (κ₀ := κ') φ' _ hd.hm'RT + (F.internalFlags_subset_coreFlags hTint), + flipVal_of_mem hφ' _ hd.hRS, + flipVal_of_notMem hφ' _ hd.hTS] + · rw [List.pmap_map] + refine pmap_flatMap_congr _ _ _ _ _ _ _ ?_ + intro x hx h₁ h₂ + obtain ⟨hxQ, hxfli⟩ := Finset.mem_erase.mp + (Finset.mem_toList.mp hx) + obtain ⟨hxin, hxS⟩ := mem_flipS.mp hxfli + obtain ⟨hxfl, hxat, hxout⟩ := mem_relInSetAt.mp hxin + have hxint : x ∈ F.internalFlags := + mem_internalFlags_of hxfl ⟨v, hxat⟩ + have hxR : x ≠ R := by + intro he + rw [he, hd.hRout] at hxout + cases hxout + have hmS : κ.match_ x ∈ S := hd.hSmatch x hxS hxQ hxR + have hmP : κ.match_ x ≠ P := by + intro he + have h2 := congrArg κ.match_ he + rw [κ.match_invol x hxint, hd.hmPR] at h2 + exact hxR h2 + have hmQ : κ.match_ x ≠ Q := by + intro he + have h2 := congrArg κ.match_ he + rw [κ.match_invol x hxint, hd.hmQT] at h2 + exact hd.hTS (h2 ▸ hxS) + have hmR : κ.match_ x ≠ R := by + intro he + have h2 := congrArg κ.match_ he + rw [κ.match_invol x hxint, hd.hmRP] at h2 + exact hd.hPS (h2 ▸ hxS) + have hmT : κ.match_ x ≠ T := by + intro he + have h2 := congrArg κ.match_ he + rw [κ.match_invol x hxint, hd.hmTQ] at h2 + exact hxQ h2 + have hm'eq : κ'.match_ (κ.match_ x) = x := by + rw [hd.hoff _ hmP hmQ hmR hmT, + κ.match_invol x hxint] + rw [pairFn_eq (κ₀ := κ') φ' ⟨κ.match_ x, h₁⟩ hm'eq + (F.internalFlags_subset_coreFlags hxint), + flipVal_of_mem hφ' _ hmS, + flipVal_of_mem hφ' _ hxS, + oddPartner_invol] + rfl + +/-- At the move's vertex: the flipped vertex list. -/ +private theorem evalList_flip_v (hd : SegData κ κ' o o' S v P Q R T) + (hM : MixedFunctional k ℓ) (μ : Multiset (Fin k)) + {φ φ' : F.CoreOddColouring ℓ} + (hφ' : ∀ g, φ'.val g = + if g.val ∈ S then oddPartner ℓ (φ.val g) else φ.val g) : + hM.evalOdd μ (F.coreOddListAt o' φ' v) = + (-1 : ℂ) ^ (flipS S o v).card * + hM.evalOdd μ (F.coreOddListAt o φ v) := by + have hPint := hd.hPint + have hQint := hd.hQint + have hRint := hd.hRint + have hTint := hd.hTint + have HkE : ∀ g ∈ ((keepS S o v).erase P).toList, + g ∈ F.internalFlags := + fun g hg => relInSetAt_subset_internal + (mem_keepS.mp (Finset.mem_of_mem_erase + (Finset.mem_toList.mp hg))).1 + have HfE : ∀ g ∈ ((flipS S o v).erase Q).toList, + g ∈ F.internalFlags := + fun g hg => relInSetAt_subset_internal + (mem_flipS.mp (Finset.mem_of_mem_erase + (Finset.mem_toList.mp hg))).1 + have Hold : ∀ g ∈ P :: (((keepS S o v).erase P).toList ++ + Q :: ((flipS S o v).erase Q).toList), g ∈ F.internalFlags := by + intro g hg + rcases List.mem_cons.mp hg with rfl | hg + · exact hPint + rcases List.mem_append.mp hg with hg | hg + · exact HkE g hg + rcases List.mem_cons.mp hg with rfl | hg + · exact hQint + · exact HfE g hg + have hkeepval : (keepS S o v).val = + P ::ₘ ((keepS S o v).erase P).val := by + rw [Finset.erase_val] + exact (Multiset.cons_erase + (Finset.mem_def.mp hd.P_mem_keepS)).symm + have hflipval : (flipS S o v).val = + Q ::ₘ ((flipS S o v).erase Q).val := by + rw [Finset.erase_val] + exact (Multiset.cons_erase + (Finset.mem_def.mp hd.Q_mem_flipS)).symm + -- ═══════ THE TWO ENUMERATIONS ARE THE SAME MULTISET ═══════ + have hbase : (F.relInFlagsAt o v).Perm + (P :: (((keepS S o v).erase P).toList ++ + Q :: ((flipS S o v).erase Q).toList)) := by + rw [← Multiset.coe_eq_coe, relInFlagsAt_coe o v, + ← Multiset.cons_coe, ← Multiset.coe_add, + ← Multiset.cons_coe, Finset.coe_toList, Finset.coe_toList, + relInSetAt_val_split (S := S) o v, hkeepval, hflipval, + Multiset.cons_add] + unfold EdgeSubset.coreOddListAt + simp only [List.attachWith] + -- ═══════ THE SIGN COMPUTATION ═══════ + calc hM.evalOdd μ ((List.pmap Subtype.mk (F.relInFlagsAt o' v) + (fun _ hf => F.mem_internal_of_mem_relInFlagsAt hf)).flatMap + (F.coreOddPairFn κ' φ')) = + hM.evalOdd μ + ([φ.val ⟨P, F.internalFlags_subset_coreFlags hPint⟩, + φ.val ⟨Q, F.internalFlags_subset_coreFlags hQint⟩] ++ + (((List.pmap Subtype.mk ((keepS S o v).erase P).toList + HkE).flatMap (F.coreOddPairFn κ φ)) ++ + ([oddPartner ℓ (φ.val ⟨R, + F.internalFlags_subset_coreFlags hRint⟩), + oddPartner ℓ (φ.val ⟨T, + F.internalFlags_subset_coreFlags hTint⟩)] ++ + (List.pmap Subtype.mk + ((flipS S o v).erase Q).toList HfE).flatMap + (fun fs => [pairB (κ₀ := κ) φ fs, + pairA φ fs])))) := evalList_flip_v_expansion hd hM μ hφ' HkE HfE + _ = (-1 : ℂ) ^ ((flipS S o v).erase Q).card * + hM.evalOdd μ + ([φ.val ⟨P, F.internalFlags_subset_coreFlags hPint⟩, + φ.val ⟨Q, F.internalFlags_subset_coreFlags hQint⟩] ++ + (((List.pmap Subtype.mk ((keepS S o v).erase P).toList + HkE).flatMap (F.coreOddPairFn κ φ)) ++ + ([oddPartner ℓ (φ.val ⟨R, + F.internalFlags_subset_coreFlags hRint⟩), + oddPartner ℓ (φ.val ⟨T, + F.internalFlags_subset_coreFlags hTint⟩)] ++ + (List.pmap Subtype.mk + ((flipS S o v).erase Q).toList HfE).flatMap + (fun fs => [pairA φ fs, + pairB (κ₀ := κ) φ fs])))) := by + have hrev := evalOdd_flatMap_rev hM μ (pairA φ) + (pairB (κ₀ := κ) φ) + (List.pmap Subtype.mk ((flipS S o v).erase Q).toList HfE) + ([φ.val ⟨P, F.internalFlags_subset_coreFlags hPint⟩, + φ.val ⟨Q, F.internalFlags_subset_coreFlags hQint⟩] ++ + (((List.pmap Subtype.mk ((keepS S o v).erase P).toList + HkE).flatMap (F.coreOddPairFn κ φ)) ++ + [oddPartner ℓ (φ.val ⟨R, + F.internalFlags_subset_coreFlags hRint⟩), + oddPartner ℓ (φ.val ⟨T, + F.internalFlags_subset_coreFlags hTint⟩)])) + simp only [List.append_assoc, List.cons_append, + List.nil_append, List.length_pmap, + Finset.length_toList] at hrev ⊢ + rw [hrev] + _ = (-1 : ℂ) ^ ((flipS S o v).erase Q).card * -hM.evalOdd μ + ([φ.val ⟨P, F.internalFlags_subset_coreFlags hPint⟩, + oddPartner ℓ (φ.val ⟨R, + F.internalFlags_subset_coreFlags hRint⟩)] ++ + (((List.pmap Subtype.mk ((keepS S o v).erase P).toList + HkE).flatMap (F.coreOddPairFn κ φ)) ++ + ([φ.val ⟨Q, F.internalFlags_subset_coreFlags hQint⟩, + oddPartner ℓ (φ.val ⟨T, + F.internalFlags_subset_coreFlags hTint⟩)] ++ + (List.pmap Subtype.mk + ((flipS S o v).erase Q).toList HfE).flatMap + (fun fs => [pairA φ fs, + pairB (κ₀ := κ) φ fs])))) := by + have htr := MixedFunctional.evalOdd_transpose hM μ + ((List.pmap Subtype.mk ((keepS S o v).erase P).toList + HkE).flatMap (F.coreOddPairFn κ φ)) + [φ.val ⟨P, F.internalFlags_subset_coreFlags hPint⟩] + (oddPartner ℓ (φ.val ⟨T, + F.internalFlags_subset_coreFlags hTint⟩) :: + (List.pmap Subtype.mk + ((flipS S o v).erase Q).toList HfE).flatMap + (fun fs => [pairA φ fs, pairB (κ₀ := κ) φ fs])) + (oddPartner ℓ (φ.val ⟨R, + F.internalFlags_subset_coreFlags hRint⟩)) + (φ.val ⟨Q, F.internalFlags_subset_coreFlags hQint⟩) + simp only [List.cons_append, List.nil_append] at htr ⊢ + rw [htr] + _ = (-1 : ℂ) ^ (flipS S o v).card * hM.evalOdd μ + ((List.pmap Subtype.mk + (P :: (((keepS S o v).erase P).toList ++ + Q :: ((flipS S o v).erase Q).toList)) + Hold).flatMap (F.coreOddPairFn κ φ)) := by + rw [← Finset.card_erase_add_one hd.Q_mem_flipS, pow_succ] + simp only [List.pmap, List.pmap_append, List.flatMap_cons, + List.flatMap_append] + rw [pairFn_eq (κ₀ := κ) φ + ⟨P, hPint⟩ hd.hmPR + (F.internalFlags_subset_coreFlags hRint), + pairFn_eq (κ₀ := κ) φ ⟨Q, hQint⟩ hd.hmQT + (F.internalFlags_subset_coreFlags hTint), + coreOddPairFn_eq' (κ₀ := κ) φ] + simp only [List.cons_append, List.nil_append] + ring + _ = (-1 : ℂ) ^ (flipS S o v).card * hM.evalOdd μ + ((List.pmap Subtype.mk (F.relInFlagsAt o v) + (fun _ hf => + F.mem_internal_of_mem_relInFlagsAt hf)).flatMap + (F.coreOddPairFn κ φ)) := by + have hp := hM.evalOdd_flatMap_perm μ (F.coreOddPairFn κ φ) + (fun _ => rfl) + (perm_pmap Subtype.mk hbase.symm Hold + (fun _ hf => F.mem_internal_of_mem_relInFlagsAt hf)) + [] + simp only [List.nil_append] at hp + rw [hp] + +/-- Boundary flags are never on the segment. -/ +private theorem hSb (hd : SegData κ κ' o o' S v P Q R T) (i : α) : + W.boundaryFlag i ∉ S := by + intro hmem + obtain ⟨w, hw⟩ := F.attach_internal_of_mem (hd.hSint _ hmem) + rw [W.attach_boundaryFlag] at hw + cases hw + +/-- The combined vertex factor of the flipped comparison. -/ +private theorem vertexFactor (hd : SegData κ κ' o o' S v P Q R T) + (hM : MixedFunctional k ℓ) (μ : Multiset (Fin k)) + {φ φ' : F.CoreOddColouring ℓ} + (hφ' : ∀ g, φ'.val g = + if g.val ∈ S then oddPartner ℓ (φ.val g) else φ.val g) + (vv : W.Vertex) : + (F.coreOddSignAt o' φ' vv : ℂ) * + hM.evalOdd μ (F.coreOddListAt o' φ' vv) = + (∏ g ∈ diffAtS S vv, ((inSign φ g : ℤ) : ℂ)) * + ((F.coreOddSignAt o φ vv : ℂ) * + hM.evalOdd μ (F.coreOddListAt o φ vv)) := by + have hsign : F.coreOddSignAt o' φ' vv = + (-1 : ℤ) ^ (flipS S o vv).card * + (∏ g ∈ diffAtS S vv, inSign φ g) * + F.coreOddSignAt o φ vv := by + by_cases hvv : vv = v + · subst hvv + exact hd.signAt_flip_v hφ' + · exact hd.signAt_flip_ne hvv hφ' + have hlist : hM.evalOdd μ (F.coreOddListAt o' φ' vv) = + (-1 : ℂ) ^ (flipS S o vv).card * + hM.evalOdd μ (F.coreOddListAt o φ vv) := by + by_cases hvv : vv = v + · subst hvv + exact hd.evalList_flip_v hM μ hφ' + · exact hd.evalList_flip_ne hM μ hvv hφ' + rw [hsign, hlist] + have hsq : (-1 : ℂ) ^ (flipS S o vv).card * + (-1 : ℂ) ^ (flipS S o vv).card = 1 := by + rw [← mul_pow] + norm_num + push_cast + calc ((-1 : ℂ) ^ (flipS S o vv).card * + (∏ g ∈ diffAtS S vv, ((inSign φ g : ℤ) : ℂ)) * + (F.coreOddSignAt o φ vv : ℂ)) * + ((-1 : ℂ) ^ (flipS S o vv).card * + hM.evalOdd μ (F.coreOddListAt o φ vv)) = + ((-1 : ℂ) ^ (flipS S o vv).card * + (-1 : ℂ) ^ (flipS S o vv).card) * + ((∏ g ∈ diffAtS S vv, ((inSign φ g : ℤ) : ℂ)) * + ((F.coreOddSignAt o φ vv : ℂ) * + hM.evalOdd μ (F.coreOddListAt o φ vv))) := by + ring + _ = (∏ g ∈ diffAtS S vv, ((inSign φ g : ℤ) : ℂ)) * + ((F.coreOddSignAt o φ vv : ℂ) * + hM.evalOdd μ (F.coreOddListAt o φ vv)) := by + rw [hsq, one_mul] + +/-- The vertex-product identity of the flipped comparison. -/ +private theorem vertexProd (hd : SegData κ κ' o o' S v P Q R T) + (hM : MixedFunctional k ℓ) {φ φ' : F.CoreOddColouring ℓ} + (hφ' : ∀ g, φ'.val g = + if g.val ∈ S then oddPartner ℓ (φ.val g) else φ.val g) + (μf : W.Vertex → Multiset (Fin k)) : + ∏ vv : W.Vertex, + ((F.coreOddSignAt o' φ' vv : ℂ) * + hM.evalOdd (μf vv) (F.coreOddListAt o' φ' vv)) = + ∏ vv : W.Vertex, + ((F.coreOddSignAt o φ vv : ℂ) * + hM.evalOdd (μf vv) (F.coreOddListAt o φ vv)) := by + have hglobal : ∏ vv : W.Vertex, + ∏ g ∈ diffAtS S vv, ((inSign φ g : ℤ) : ℂ) = 1 := by + have h1 : ∏ vv : W.Vertex, + ∏ g ∈ diffAtS S vv, inSign φ g = 1 := by + rw [← Finset.prod_biUnion diffAtS_pairwiseDisjoint, + ← S_eq_biUnion_diffAtS hd.hSint] + exact prod_inSign_seg hd.hSpair (fun f hf => hd.hScore hf) φ + have h2 : ((∏ vv : W.Vertex, + ∏ g ∈ diffAtS S vv, inSign φ g : ℤ) : ℂ) = 1 := by + rw [h1] + norm_num + push_cast at h2 + exact h2 + rw [Finset.prod_congr rfl + (fun vv _ => hd.vertexFactor hM (μf vv) hφ' vv), + Finset.prod_mul_distrib, hglobal, one_mul] + +open scoped Classical in +/-- The colouring-sum identity of the flipped comparison. -/ +private theorem phiSum (hd : SegData κ κ' o o' S v P Q R T) + (hM : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (μf : W.Vertex → Multiset (Fin k)) : + ∑ φ : F.CoreOddColouring ℓ, + (if F.coreOddBoundaryMatch st φ then + ∏ vv : W.Vertex, ((F.coreOddSignAt o' φ vv : ℂ) * + hM.evalOdd (μf vv) (F.coreOddListAt o' φ vv)) + else 0) = + ∑ φ : F.CoreOddColouring ℓ, + (if F.coreOddBoundaryMatch st φ then + ∏ vv : W.Vertex, ((F.coreOddSignAt o φ vv : ℂ) * + hM.evalOdd (μf vv) (F.coreOddListAt o φ vv)) + else 0) := by + refine ((Equiv.sum_comp (Function.Involutive.toPerm _ + (segFlipColouring_involutive hd.hSpair (ℓ := ℓ))) + _).symm).trans + (Finset.sum_congr rfl (fun φ _ => ?_)) + change (if F.coreOddBoundaryMatch st + (segFlipColouring hd.hSpair φ) then + ∏ vv : W.Vertex, + ((F.coreOddSignAt o' (segFlipColouring hd.hSpair φ) + vv : ℂ) * + hM.evalOdd (μf vv) + (F.coreOddListAt o' (segFlipColouring hd.hSpair φ) vv)) + else 0) = + (if F.coreOddBoundaryMatch st φ then + ∏ vv : W.Vertex, ((F.coreOddSignAt o φ vv : ℂ) * + hM.evalOdd (μf vv) (F.coreOddListAt o φ vv)) + else 0) + exact if_congr + (coreOddBoundaryMatch_segFlipColouring st hd.hSpair hd.hSb φ) + (hd.vertexProd hM (fun g => rfl) μf) rfl + +end SegData + +open scoped Classical in +/-- The parametric core of the flipped-segment ledger. -/ +private theorem throughSummand_seg_core [LinearOrder α] + (hM : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ' : F.RelTransitionSystem} {o : κ.Orientation} + {o' : κ'.Orientation} {P Q R T : W.Flag} + (hd : SegData κ κ' o o' S v P Q R T) (n : ℕ) : + F.throughSummand hM st hbnd o' n = + F.throughSummand hM st hbnd o n := by + unfold EdgeSubset.throughSummand + apply congrArg (fun z : ℂ => ((-1 : ℂ) ^ n) * F.throughProduct st * z) + refine Finset.sum_congr rfl (fun ψ _ => ?_) + exact if_congr Iff.rfl (hd.phiSum hM st (F.evenColoursAt ψ)) rfl + +/-- **The flipped-segment ledger**: the constrained summand of the +repaired system over the flipped-segment orientation and equals +the old summand at every fixed circuit exponent. -/ +theorem throughSummand_segFlip [LinearOrder α] + (hM : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (hsq : RepairSquare κ a b c d v) (o : κ.Orientation) + (hsame : o.isOut c = o.isOut a) + (hseg : RepairSegment κ a b c d S) (n : ℕ) : + F.throughSummand hM st hbnd + (RelTransitionSystem.Orientation.segFlip hsq o hsame hseg) + n = + F.throughSummand hM st hbnd o n := by + have hbflip : o.isOut b = !o.isOut a := by + rw [← hsq.hab] + exact o.match_flip a hsq.ha + have hdflip : o.isOut d = !o.isOut c := by + rw [← hsq.hcd] + exact o.match_flip c hsq.hc + cases hxa : o.isOut a with + | false => + refine throughSummand_seg_core hM st hbnd (S := S) (v := v) + (P := a) (Q := c) (R := b) (T := d) ?_ n + exact + { hiso := fun f => rfl + hSpair := hseg.pairing_mem + hSint := hseg.int_of_mem + hSmatch := fun g hg hgQ hgR => hseg.match_mem g hg hgR hgQ + hSnot := fun g hgint hgS hgP hgT => + hseg.match_notMem hsq hgint hgS hgP hgT + hoff := fun g h1 h2 h3 h4 => + RelTransitionSystem.repair_match_of_ne hsq h1 h3 h2 h4 + hPint := hsq.ha + hQint := hsq.hc + hRint := hsq.hb + hTint := hsq.hd + hPS := hseg.haS + hQS := hseg.hcS + hRS := hseg.hbS + hTS := hseg.hdS + hPout := hxa + hQout := hsame.trans hxa + hRout := by rw [hbflip, hxa]; rfl + hTout := by rw [hdflip, hsame, hxa]; rfl + hPv := hsq.hav + hQv := hsq.hcv + hRv := hsq.hbv + hTv := hsq.hdv + hmPR := hsq.hab + hmQT := hsq.hcd + hm'PQ := RelTransitionSystem.repair_match_a hsq + hm'RT := RelTransitionSystem.repair_match_b hsq } + | true => + refine throughSummand_seg_core hM st hbnd (S := S) (v := v) + (P := d) (Q := b) (R := c) (T := a) ?_ n + exact + { hiso := fun f => rfl + hSpair := hseg.pairing_mem + hSint := hseg.int_of_mem + hSmatch := fun g hg hgQ hgR => hseg.match_mem g hg hgQ hgR + hSnot := fun g hgint hgS hgP hgT => + hseg.match_notMem hsq hgint hgS hgT hgP + hoff := fun g h1 h2 h3 h4 => + RelTransitionSystem.repair_match_of_ne hsq h4 h2 h3 h1 + hPint := hsq.hd + hQint := hsq.hb + hRint := hsq.hc + hTint := hsq.ha + hPS := hseg.hdS + hQS := hseg.hbS + hRS := hseg.hcS + hTS := hseg.haS + hPout := by rw [hdflip, hsame, hxa]; rfl + hQout := by rw [hbflip, hxa]; rfl + hRout := hsame.trans hxa + hTout := hxa + hPv := hsq.hdv + hQv := hsq.hbv + hRv := hsq.hcv + hTv := hsq.hav + hmPR := hsq.hmd + hmQT := hsq.hmb + hm'PQ := RelTransitionSystem.repair_match_d hsq + hm'RT := RelTransitionSystem.repair_match_c hsq } + +end SegLedger + +/-! ## The same-component configuration and its segment -/ + +section WalkReach + +variable {F : EdgeSubset W} + +/-- The walk from `c` reaches `a` with internal pairings: the +same-component configuration of the non-separated move (both the +same-circuit and the same-chain reversal sub-cases). -/ +def WalkReach (κ : F.RelTransitionSystem) (c a : W.Flag) : Prop := + ∃ m : ℕ, 1 ≤ m ∧ + (∀ j, j < m → + W.pairing (iterWalk κ c j) ∈ F.internalFlags) ∧ + iterWalk κ c m = a + +variable {κ : F.RelTransitionSystem} + +/-- Iterates along an internally-continuing walk are internal. -/ +theorem iterWalk_int_of_cont {f : W.Flag} + (hf : f ∈ F.internalFlags) {m : ℕ} + (hcont : ∀ j, j < m → + W.pairing (iterWalk κ f j) ∈ F.internalFlags) : + ∀ j, j ≤ m → iterWalk κ f j ∈ F.internalFlags := by + intro j + cases j with + | zero => intro _; exact hf + | succ j => + intro hj + rw [iterWalk_succ] + exact κ.match_mem _ (hcont j (by omega)) + +/-- The orientation is constant along the walk positions of an +internally-continuing walk. -/ +theorem isOut_iterWalk_of_cont (o : κ.Orientation) {f : W.Flag} + (hf : f ∈ F.internalFlags) {m : ℕ} + (hcont : ∀ j, j < m → + W.pairing (iterWalk κ f j) ∈ F.internalFlags) : + ∀ j, j ≤ m → o.isOut (iterWalk κ f j) = o.isOut f := by + intro j + induction j with + | zero => intro _; rfl + | succ j ih => + intro hj + rw [iterWalk_succ, o.match_flip _ (hcont j (by omega)), + o.pairing_flip _ (iterWalk_int_of_cont hf hcont j (by omega)) + (hcont j (by omega)), + Bool.not_not, ih (by omega)] + +/-- **The reversal segment of a same-component non-separated +square**: the flags of the walk from `c` up to (excluding) `a`, on +both sides of each visited edge. -/ +theorem exists_repairSegment {a b c d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) (o : κ.Orientation) + (hsame : o.isOut c = o.isOut a) (hreach : WalkReach κ c a) : + ∃ S : Finset W.Flag, RepairSegment κ a b c d S := by + have : DecidablePred (fun m : ℕ => 1 ≤ m ∧ + (∀ j, j < m → + W.pairing (iterWalk κ c j) ∈ F.internalFlags) ∧ + iterWalk κ c m = a) := fun m => Classical.dec _ + obtain ⟨m₀, ⟨hm1, hcont, hlast⟩, hmin⟩ : + ∃ m : ℕ, (1 ≤ m ∧ + (∀ j, j < m → + W.pairing (iterWalk κ c j) ∈ F.internalFlags) ∧ + iterWalk κ c m = a) ∧ + ∀ j, j < m → ¬ (1 ≤ j ∧ + (∀ i, i < j → + W.pairing (iterWalk κ c i) ∈ F.internalFlags) ∧ + iterWalk κ c j = a) := + ⟨Nat.find hreach, Nat.find_spec hreach, + fun j hj => Nat.find_min hreach hj⟩ + refine ⟨(Finset.range m₀).image (fun j => iterWalk κ c j) ∪ + (Finset.range m₀).image + (fun j => W.pairing (iterWalk κ c j)), ?_⟩ + have hmemS : ∀ f : W.Flag, + f ∈ (Finset.range m₀).image (fun j => iterWalk κ c j) ∪ + (Finset.range m₀).image + (fun j => W.pairing (iterWalk κ c j)) ↔ + ∃ j, j < m₀ ∧ (f = iterWalk κ c j ∨ + f = W.pairing (iterWalk κ c j)) := by + intro f + rw [Finset.mem_union, Finset.mem_image, Finset.mem_image] + constructor + · rintro (⟨j, hj, rfl⟩ | ⟨j, hj, rfl⟩) + · exact ⟨j, Finset.mem_range.mp hj, Or.inl rfl⟩ + · exact ⟨j, Finset.mem_range.mp hj, Or.inr rfl⟩ + · rintro ⟨j, hj, rfl | rfl⟩ + · exact Or.inl ⟨j, Finset.mem_range.mpr hj, rfl⟩ + · exact Or.inr ⟨j, Finset.mem_range.mpr hj, rfl⟩ + -- the walk positions never hit `a` + have haW : ∀ j, j < m₀ → iterWalk κ c j ≠ a := by + intro j hj heq + rcases Nat.eq_zero_or_pos j with rfl | hj1 + · rw [iterWalk_zero] at heq + exact hsq.hac heq.symm + · exact hmin j hj ⟨hj1, fun i hi => hcont i (by omega), heq⟩ + -- the pairing positions never hit `a` (orientation obstruction) + have haP : ∀ j, j < m₀ → W.pairing (iterWalk κ c j) ≠ a := by + intro j hj heq + have h1 : o.isOut (W.pairing (iterWalk κ c j)) = !o.isOut c := by + rw [o.pairing_flip _ + (iterWalk_int_of_cont hsq.hc hcont j (by omega)) + (hcont j hj), + isOut_iterWalk_of_cont o hsq.hc hcont j (by omega)] + rw [heq, hsame] at h1 + simp at h1 + -- the walk positions never hit `d` (orientation obstruction) + have hdW : ∀ j, j < m₀ → iterWalk κ c j ≠ d := by + intro j hj heq + have h1 : o.isOut d = !o.isOut c := by + rw [← hsq.hcd]; exact o.match_flip c hsq.hc + rw [← heq, isOut_iterWalk_of_cont o hsq.hc hcont j (by omega)] + at h1 + simp at h1 + -- the pairing positions never hit `d` (minimality obstruction) + have hdP : ∀ j, j < m₀ → W.pairing (iterWalk κ c j) ≠ d := by + intro j hj heq + have h1 : iterWalk κ c (j + 1) = c := by + rw [iterWalk_succ, heq, hsq.hmd] + have h2 : iterWalk κ c m₀ = iterWalk κ c (m₀ - (j + 1)) := by + conv_lhs => + rw [show m₀ = (j + 1) + (m₀ - (j + 1)) from by omega] + rw [iterWalk_add, h1] + rw [hlast] at h2 + rcases Nat.eq_zero_or_pos (m₀ - (j + 1)) with hz | hpos + · rw [hz, iterWalk_zero] at h2 + exact hsq.hac h2 + · exact hmin (m₀ - (j + 1)) (by omega) + ⟨hpos, fun i hi => hcont i (by omega), h2.symm⟩ + -- `b` sits at the last pairing position + have hbP : W.pairing (iterWalk κ c (m₀ - 1)) = b := by + have h1 : κ.match_ a = + κ.match_ (iterWalk κ c m₀) := by rw [hlast] + have h2 : iterWalk κ c m₀ = + κ.match_ (W.pairing (iterWalk κ c (m₀ - 1))) := by + conv_lhs => rw [show m₀ = (m₀ - 1) + 1 from by omega] + rw [iterWalk_succ] + rw [h2, κ.match_invol _ (hcont (m₀ - 1) (by omega)), + hsq.hab] at h1 + exact h1.symm + refine ⟨?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · -- ═══════ b ∈ S ═══════ + rw [hmemS] + exact ⟨m₀ - 1, by omega, Or.inr hbP.symm⟩ + · -- ═══════ c ∈ S ═══════ + rw [hmemS] + exact ⟨0, by omega, Or.inl (iterWalk_zero κ c).symm⟩ + · -- ═══════ a ∉ S ═══════ + rw [hmemS] + rintro ⟨j, hj, heq | heq⟩ + · exact haW j hj heq.symm + · exact haP j hj heq.symm + · -- ═══════ d ∉ S ═══════ + rw [hmemS] + rintro ⟨j, hj, heq | heq⟩ + · exact hdW j hj heq.symm + · exact hdP j hj heq.symm + · -- ═══════ INTERNALITY ═══════ + intro f hf + rw [hmemS] at hf + obtain ⟨j, hj, rfl | rfl⟩ := hf + · exact iterWalk_int_of_cont hsq.hc hcont j (by omega) + · exact hcont j hj + · -- ═══════ PAIRING CLOSURE ═══════ + intro f hf + rw [hmemS] at hf ⊢ + obtain ⟨j, hj, rfl | rfl⟩ := hf + · exact ⟨j, hj, Or.inr rfl⟩ + · exact ⟨j, hj, Or.inl (W.pairing_invol _)⟩ + · -- ═══════ MATCHING CLOSURE AWAY FROM THE CUTS ═══════ + intro f hf hfb hfc + rw [hmemS] at hf ⊢ + obtain ⟨j, hj, rfl | rfl⟩ := hf + · cases j with + | zero => + rw [iterWalk_zero] at hfc ⊢ + exact absurd rfl hfc + | succ j => + refine ⟨j, by omega, Or.inr ?_⟩ + rw [iterWalk_succ, + κ.match_invol _ (hcont j (by omega))] + · rcases Nat.lt_or_ge (j + 1) m₀ with hjm | hjm + · refine ⟨j + 1, hjm, Or.inl ?_⟩ + rw [iterWalk_succ] + · exfalso + have hje : j = m₀ - 1 := by omega + rw [hje, hbP] at hfb + exact hfb rfl + +end WalkReach + +/-! ## Localization of the same-component square -/ + +section WalkReachLocalized + +/-- The chain membership is closed under the pairing. -/ +theorem onBoundaryChain_pairing {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {β f : W.Flag} + (h : OnBoundaryChain κ β f) : + OnBoundaryChain κ β (W.pairing f) := by + obtain ⟨k, t, htk, hcont, hterm, hf⟩ := h + refine ⟨k, t, htk, hcont, hterm, ?_⟩ + rcases hf with rfl | rfl + · exact Or.inr rfl + · exact Or.inl (W.pairing_invol _) + +/-- The chain membership is closed along internally-continuing +walks. -/ +theorem onBoundaryChain_iterWalk {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {β f : W.Flag} + (hβ : β ∈ F.boundaryFlags) (h : OnBoundaryChain κ β f) + {m : ℕ} + (hcont : ∀ j, j < m → + W.pairing (iterWalk κ f j) ∈ F.internalFlags) : + ∀ j, j ≤ m → OnBoundaryChain κ β (iterWalk κ f j) := by + intro j + induction j with + | zero => intro _; exact h + | succ j ih => + intro hj + rw [iterWalk_succ] + exact onBoundaryChain_match hβ (hcont j (by omega)) + (onBoundaryChain_pairing (ih (by omega))) + +/-- A same-component square is localized: `c`'s component either +is a circuit carrying all four flags, or is the chain of a +boundary flag carrying them. -/ +theorem squareLocalized_of_walkReach + {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {a b c d : W.Flag} + {v : W.Vertex} (hsq : RepairSquare κ a b c d v) + (hreach : WalkReach κ c a) : + SquareLocalized κ a b c d := by + obtain ⟨m, hm1, hcont, hlast⟩ := hreach + rcases periodic_or_onBoundaryChain κ hsq.hc with + hpc | ⟨β, hβ, hchain⟩ + · exact Or.inl ⟨hlast ▸ periodicFlag_iterWalk κ hpc m, hpc⟩ + · refine Or.inr ⟨β, hβ, ?_⟩ + have hca : OnBoundaryChain κ β a := + hlast ▸ onBoundaryChain_iterWalk hβ hchain hcont m le_rfl + intro f hf + rcases hf with rfl | rfl | rfl | rfl + · exact Or.inr hca + · exact Or.inr (hsq.hab ▸ onBoundaryChain_match hβ hsq.ha hca) + · exact Or.inr hchain + · exact Or.inr + (hsq.hcd ▸ onBoundaryChain_match hβ hsq.hc hchain) + +/-- On a component with an orientation, membership of `a` on `c`'s +periodic orbit forces the forward reach under the non-separated +condition: the pairing-side (reverse) membership contradicts the +orientation. -/ +theorem walkReach_of_orbitFlag {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {a c : W.Flag} {o : κ.Orientation} + (hpc : κ.PeriodicFlag c) (hsame : o.isOut c = o.isOut a) + (hac : a ≠ c) (horb : OrbitFlag κ c a) : + WalkReach κ c a := by + have hcont : ∀ j, j < 0 + 1 → + W.pairing (iterWalk κ c j) ∈ F.internalFlags := + fun j _ => all_pairings_internal_of_periodic κ hpc j + obtain ⟨m, hm | hm⟩ := horb + · rcases Nat.eq_zero_or_pos m with rfl | hpos + · rw [iterWalk_zero] at hm + exact absurd hm hac + · exact ⟨m, hpos, + fun j _ => all_pairings_internal_of_periodic κ hpc j, + hm.symm⟩ + · exfalso + have h1 : o.isOut (W.pairing (iterWalk κ c m)) = + !o.isOut c := by + rw [o.pairing_flip _ + (iterWalk_int_of_cont hpc.mem_internal + (fun j (_ : j < m) => + all_pairings_internal_of_periodic κ hpc j) m le_rfl) + (all_pairings_internal_of_periodic κ hpc m), + isOut_iterWalk_of_cont o hpc.mem_internal + (fun j (_ : j < m) => + all_pairings_internal_of_periodic κ hpc j) m le_rfl] + rw [← hm, hsame] at h1 + simp at h1 + +/-- Orbit membership on a periodic component is periodic. -/ +theorem periodicFlag_of_orbitFlag {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {c f : W.Flag} + (hpc : κ.PeriodicFlag c) (horb : OrbitFlag κ c f) : + κ.PeriodicFlag f := by + obtain ⟨m, rfl | rfl⟩ := horb + · exact periodicFlag_iterWalk κ hpc m + · exact periodicFlag_pairing (periodicFlag_iterWalk κ hpc m) + +end WalkReachLocalized + +/-! ## The swapped square -/ + +section SwapSquare + +variable {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {a b c d : W.Flag} {v : W.Vertex} + +/-- The square with the two re-paired edges exchanged. -/ +theorem RepairSquare.swap (h : RepairSquare κ a b c d v) : + RepairSquare κ c d a b v where + ha := h.hc + hc := h.ha + hab := h.hcd + hcd := h.hab + hac := Ne.symm h.hac + had := Ne.symm h.hbc + hbc := Ne.symm h.had + hbd := Ne.symm h.hbd + hav := h.hcv + hcv := h.hav + +/-- The swapped square repairs to the same system. -/ +theorem repair_swap_matchEq (h : RepairSquare κ a b c d v) : + (κ.repair c d a b v h.swap).MatchEq + (κ.repair a b c d v h) := by + intro f hf + by_cases h1 : f = a + · subst h1 + rw [RelTransitionSystem.repair_match_c h.swap, + RelTransitionSystem.repair_match_a h] + by_cases h3 : f = c + · subst h3 + rw [RelTransitionSystem.repair_match_a h.swap, + RelTransitionSystem.repair_match_c h] + by_cases h2 : f = b + · subst h2 + rw [RelTransitionSystem.repair_match_d h.swap, + RelTransitionSystem.repair_match_b h] + by_cases h4 : f = d + · subst h4 + rw [RelTransitionSystem.repair_match_b h.swap, + RelTransitionSystem.repair_match_d h] + · rw [RelTransitionSystem.repair_match_of_ne h.swap h3 h4 h1 h2, + RelTransitionSystem.repair_match_of_ne h h1 h2 h3 h4] + +end SwapSquare + +end EdgeSubset + +/-! ## The inputs and the dispatch -/ + +/-- **Input (segment count parity)**: a same-component +square preserves the circuit-count parity — the segment reversal +maps the two traversal orbits of the affected component onto two +orbits of the same sizes (Δ = 0 on circuits; chains carry no +periodic flags). Proved in `OrbitParities.lean`. -/ +def NonSeparatedSegmentParity : Prop := + ∀ {α : Type} {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a b c d : W.Flag} {v : W.Vertex} + (hsq : EdgeSubset.RepairSquare κ a b c d v), + EdgeSubset.WalkReach κ c a → + Even (κ.openCircuitCount + + (κ.repair a b c d v hsq).openCircuitCount) + +/-- **Input (merge count parity)**: a square whose +`c`-edge lies on a circuit not carrying `a` flips the count parity +— the splice merges the circuit into `a`'s component (Δ = −1). +Proved in `OrbitParities.lean`. -/ +def NonSeparatedMergeParity : Prop := + ∀ {α : Type} {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a b c d : W.Flag} {v : W.Vertex} + (hsq : EdgeSubset.RepairSquare κ a b c d v), + κ.PeriodicFlag c → ¬ EdgeSubset.OrbitFlag κ c a → + Odd (κ.openCircuitCount + + (κ.repair a b c d v hsq).openCircuitCount) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/OpenCircuits.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/OpenCircuits.lean new file mode 100644 index 0000000000..cf1d7faab8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/OpenCircuits.lean @@ -0,0 +1,514 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathMatch + +/-! +# Open circuit count for boundary-relative transition systems + +For an edge subset `F` that may have boundary flags, the internal +circuit count (`internalCircuitCount`) is defined only when +`F.allInternal` holds. This file generalises the count to open +edge subsets by restricting to the *periodic* flags — internal flags +whose forward walk eventually returns to them. + +## Main definitions + +* `PeriodicFlag` — a flag on a closed circuit: internal, with the + walk staying internal and returning to it. +* `periodicFlags` — the finset of periodic flags. +* `walkPermPeriodic` — the walk restricted to periodic flags as a + permutation. +* `openCircuitCount` — `(cycleType.card + fixedPoints) / 2` on + periodic flags. + +## Main results + +* `openCircuitCount_of_allInternal` — when all flags are internal + the open and internal circuit counts agree. +* `internal_periodic_or_terminates` — every internal flag is either + periodic or its chain reaches the boundary. +* `not_periodic_of_boundary_chain` — boundary-terminating flags are + not periodic. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} {W : Fragment α} + +namespace EdgeSubset + +variable {F : EdgeSubset W} + +/-! ### 1. PeriodicFlag -/ + +/-- A flag on a closed circuit: it is internal, every intermediate +pairing stays internal, and the walk returns to it. -/ +def RelTransitionSystem.PeriodicFlag + (κ : F.RelTransitionSystem) (f : W.Flag) : Prop := + f ∈ F.internalFlags ∧ + ∃ n : ℕ, 1 ≤ n ∧ + (∀ j, j < n → + W.pairing (iterWalk κ f j) ∈ F.internalFlags) ∧ + iterWalk κ f n = f + +/-- A periodic flag is internal. -/ +theorem RelTransitionSystem.PeriodicFlag.mem_internal + {κ : F.RelTransitionSystem} {f : W.Flag} + (hf : κ.PeriodicFlag f) : f ∈ F.internalFlags := + hf.1 + +/-! #### Periodicity helpers -/ + +/-- Shift a period: `iterWalk κ f (n + k) = iterWalk κ f k` when +`iterWalk κ f n = f`. -/ +theorem iterWalk_add_period (κ : F.RelTransitionSystem) + (f : W.Flag) (n k : ℕ) + (hperiod : iterWalk κ f n = f) : + iterWalk κ f (n + k) = iterWalk κ f k := by + induction k with + | zero => simp [hperiod] + | succ k ih => + rw [show n + (k + 1) = (n + k) + 1 from by omega, + iterWalk_succ, ih, ← iterWalk_succ] + +/-- All pairings along a periodic walk are internal. -/ +theorem all_pairings_internal_of_periodic + (κ : F.RelTransitionSystem) {f : W.Flag} + (hper : κ.PeriodicFlag f) (j : ℕ) : + W.pairing (iterWalk κ f j) ∈ F.internalFlags := by + obtain ⟨_, n, hn1, hcont, hperiod⟩ := hper + have hmod : ∀ k, + iterWalk κ f (n * (j / n) + k) = iterWalk κ f k := by + intro k + induction j / n with + | zero => simp + | succ m ih => + rw [show n * (m + 1) + k = n + (n * m + k) from by ring] + rw [iterWalk_add_period κ f n (n * m + k) hperiod] + exact ih + rw [show j = n * (j / n) + j % n from + (Nat.div_add_mod j n).symm] + rw [hmod (j % n)] + exact hcont (j % n) (Nat.mod_lt j (by omega)) + +/-- All iterates along a periodic walk are internal. -/ +theorem iterWalk_mem_internal_of_periodic + (κ : F.RelTransitionSystem) {f : W.Flag} + (hper : κ.PeriodicFlag f) (j : ℕ) (hj : 1 ≤ j) : + iterWalk κ f j ∈ F.internalFlags := by + cases j with + | zero => omega + | succ j => + rw [iterWalk_succ] + exact κ.match_mem _ + (all_pairings_internal_of_periodic κ hper j) + +/-- The walk-successor of a periodic flag is periodic (same period). -/ +theorem RelTransitionSystem.periodicFlag_step + {κ : F.RelTransitionSystem} {f : W.Flag} + (hf : κ.PeriodicFlag f) : + κ.PeriodicFlag (iterWalk κ f 1) := by + have hmem := hf.1 + obtain ⟨_, n, hn1, hcont, hperiod⟩ := hf + have hf' : κ.PeriodicFlag f := ⟨hmem, n, hn1, hcont, hperiod⟩ + refine ⟨iterWalk_mem_internal_of_periodic κ hf' 1 (by omega), + n, hn1, fun j hj => ?_, ?_⟩ + · -- iterWalk κ f 1 is definitionally κ.match_ (W.pairing f) + change W.pairing (iterWalk κ (κ.match_ (W.pairing f)) j) ∈ + F.internalFlags + rw [iterWalk_shift] + exact all_pairings_internal_of_periodic κ hf' (j + 1) + · change iterWalk κ (κ.match_ (W.pairing f)) n = + κ.match_ (W.pairing f) + rw [iterWalk_shift, iterWalk_succ, hperiod] + +/-! ### 2. periodicFlags -/ + +open scoped Classical in +/-- The finset of periodic flags. -/ +noncomputable def RelTransitionSystem.periodicFlags + (κ : F.RelTransitionSystem) : Finset W.Flag := + F.internalFlags.filter (fun f => + ∃ n : ℕ, 1 ≤ n ∧ + (∀ j, j < n → + W.pairing (iterWalk κ f j) ∈ F.internalFlags) ∧ + iterWalk κ f n = f) + +/-- Membership in periodicFlags iff PeriodicFlag. -/ +theorem RelTransitionSystem.mem_periodicFlags + (κ : F.RelTransitionSystem) {f : W.Flag} : + f ∈ κ.periodicFlags ↔ κ.PeriodicFlag f := by + simp only [RelTransitionSystem.periodicFlags, + Finset.mem_filter, RelTransitionSystem.PeriodicFlag] + +/-- A periodic flag is internal. -/ +theorem RelTransitionSystem.periodicFlags_sub + (κ : F.RelTransitionSystem) {f : W.Flag} + (hf : f ∈ κ.periodicFlags) : f ∈ F.internalFlags := + ((κ.mem_periodicFlags).mp hf).1 + +/-! ### Walk closure on periodic flags -/ + +/-- The walk maps periodic flags to periodic flags. -/ +theorem RelTransitionSystem.internalWalk_periodic + (κ : F.RelTransitionSystem) {f : W.Flag} + (hf : f ∈ κ.periodicFlags) : + κ.internalWalk f ∈ κ.periodicFlags := by + rw [κ.mem_periodicFlags] at hf ⊢ + change κ.PeriodicFlag (κ.match_ (W.pairing f)) + rw [show κ.match_ (W.pairing f) = iterWalk κ f 1 from rfl] + exact κ.periodicFlag_step hf + +/-- The walk is injective on periodic flags. -/ +theorem RelTransitionSystem.internalWalk_injOn_periodic + (κ : F.RelTransitionSystem) {f g : W.Flag} + (hf : f ∈ κ.periodicFlags) (hg : g ∈ κ.periodicFlags) + (h : κ.internalWalk f = κ.internalWalk g) : f = g := by + have hpf : W.pairing f ∈ F.internalFlags := + all_pairings_internal_of_periodic κ + (κ.mem_periodicFlags.mp hf) 0 + have hpg : W.pairing g ∈ F.internalFlags := + all_pairings_internal_of_periodic κ + (κ.mem_periodicFlags.mp hg) 0 + exact κ.internalWalk_injOn hpf hpg h + +/-! ### 3. walkPermPeriodic -/ + +/-- The walk permutation restricted to periodic flags. -/ +noncomputable def RelTransitionSystem.walkPermPeriodic + (κ : F.RelTransitionSystem) : + Equiv.Perm {f : W.Flag // f ∈ κ.periodicFlags} := + Equiv.ofBijective + (fun f => ⟨κ.internalWalk f.val, + κ.internalWalk_periodic f.prop⟩) + (Finite.injective_iff_bijective.mp + (fun f g h => Subtype.ext + (κ.internalWalk_injOn_periodic f.prop g.prop + (congrArg Subtype.val h)))) + +/-! ### 4. openCircuitCount -/ + +/-- The open circuit count: half the orbit count of the walk on +periodic flags. -/ +noncomputable def RelTransitionSystem.openCircuitCount + (κ : F.RelTransitionSystem) : ℕ := + (κ.walkPermPeriodic.cycleType.card + + Fintype.card + (Function.fixedPoints κ.walkPermPeriodic)) / 2 + +/-! ### Backward period extraction -/ + +/-- If the walk repeats at positions `i` and `i + d` (with all +intermediate pairings internal), then it has period `d` from +position 0. -/ +theorem iterWalk_period_of_repeat + (κ : F.RelTransitionSystem) (f : W.Flag) + (i d : ℕ) + (hcont : ∀ j, j < i + d → + W.pairing (iterWalk κ f j) ∈ F.internalFlags) + (heq : iterWalk κ f i = iterWalk κ f (i + d)) : + iterWalk κ f d = f := by + induction i with + | zero => simp at heq; exact heq.symm + | succ i ih => + apply ih (fun j hj => hcont j (by omega)) + rw [iterWalk_succ, + show i + 1 + d = (i + d) + 1 from by omega, + iterWalk_succ] at heq + have hm1 := hcont i (by omega) + have hm2 := hcont (i + d) (by omega) + calc iterWalk κ f i + = W.pairing (W.pairing (iterWalk κ f i)) := + (W.pairing_invol _).symm + _ = W.pairing (W.pairing (iterWalk κ f (i + d))) := + by rw [κ.match_injOn hm1 hm2 heq] + _ = iterWalk κ f (i + d) := W.pairing_invol _ + +/-! ### Pigeonhole period extraction -/ + +/-- Helper for the pigeonhole argument: given a non-injective +map from `Fin (n+1)` to a type, extract a collision. -/ +private theorem exists_collision_of_not_injective + {α : Type*} {n : ℕ} {g : Fin (n + 1) → α} + (h : ¬ Function.Injective g) : + ∃ (i j : Fin (n + 1)), i ≠ j ∧ g i = g j := by + by_contra hall + apply h + intro a b hab + by_contra hne + exact hall ⟨a, b, hne, hab⟩ + +/-! ### 5. Compatibility with internalCircuitCount -/ + +/-- Under `allInternal`, every internal flag is periodic (via +pigeonhole on the walk iterates). -/ +theorem periodic_of_allInternal + (κ : F.RelTransitionSystem) (hall : F.allInternal) + {f : W.Flag} (hf : f ∈ F.internalFlags) : + κ.PeriodicFlag f := by + refine ⟨hf, ?_⟩ + -- Under allInternal, all iterates are internal. + have hmem : ∀ j, iterWalk κ f j ∈ F.internalFlags := by + intro j + induction j with + | zero => exact hf + | succ j ih => + rw [iterWalk_succ] + exact κ.match_mem _ + (κ.pairing_internal_of_allInternal hall ih) + have hcont_all : ∀ j, + W.pairing (iterWalk κ f j) ∈ F.internalFlags := + fun j => κ.pairing_internal_of_allInternal hall (hmem j) + -- Pigeonhole: N+1 iterates in a set of size N. + set N := F.internalFlags.card + have hinj_false : ¬ Function.Injective + (fun (i : Fin (N + 1)) => + (⟨iterWalk κ f i.val, hmem i.val⟩ : + {g : W.Flag // g ∈ F.internalFlags})) := by + intro hinj + have hcard := Fintype.card_le_of_injective _ hinj + rw [Fintype.card_fin, Fintype.card_coe] at hcard + omega + obtain ⟨⟨i, hi⟩, ⟨j, hj⟩, hne, heq_sub⟩ := + exists_collision_of_not_injective hinj_false + have heq : iterWalk κ f i = iterWalk κ f j := + congrArg Subtype.val heq_sub + have hne_val : i ≠ j := fun h => hne (Fin.ext h) + rcases Nat.lt_or_gt_of_ne hne_val with hij | hij + · exact ⟨j - i, by omega, + fun k _ => hcont_all k, + iterWalk_period_of_repeat κ f i (j - i) + (fun k _ => hcont_all k) + (by rw [Nat.add_sub_cancel' hij.le]; exact heq)⟩ + · exact ⟨i - j, by omega, + fun k _ => hcont_all k, + iterWalk_period_of_repeat κ f j (i - j) + (fun k _ => hcont_all k) + (by rw [Nat.add_sub_cancel' hij.le]; exact heq.symm)⟩ + +/-- The equivalence between periodic-flag and internal-flag subtypes +under `allInternal`. -/ +noncomputable def periodicEquivInternal + (κ : F.RelTransitionSystem) (hall : F.allInternal) : + {f : W.Flag // f ∈ κ.periodicFlags} ≃ + {f : W.Flag // f ∈ F.internalFlags} where + toFun g := ⟨g.val, κ.periodicFlags_sub g.prop⟩ + invFun g := ⟨g.val, (κ.mem_periodicFlags).mpr + (periodic_of_allInternal κ hall g.prop)⟩ + left_inv _ := Subtype.ext rfl + right_inv _ := Subtype.ext rfl + +/-- The two walk permutations agree under the canonical equivalence. -/ +theorem walkPermPeriodic_eq_of_allInternal + (κ : F.RelTransitionSystem) (hall : F.allInternal) : + κ.walkPermPeriodic = + (periodicEquivInternal κ hall).symm.permCongr + (κ.walkPermInternal hall) := by + ext ⟨f, hf⟩ + -- Goal after ext: ↑(walkPermPeriodic ⟨f, hf⟩) = ↑(permCongr ... ⟨f, hf⟩) + -- Both sides have .val = κ.internalWalk f + simp only [RelTransitionSystem.walkPermPeriodic, + RelTransitionSystem.walkPermInternal, + Equiv.ofBijective_apply, Equiv.permCongr_apply, + Equiv.symm_symm, periodicEquivInternal] + rfl + +/-- **Compatibility**: for a closed edge subset, `openCircuitCount` +equals `internalCircuitCount`. -/ +theorem openCircuitCount_of_allInternal + {F : EdgeSubset W} (κ : F.RelTransitionSystem) + (hall : F.allInternal) : + κ.openCircuitCount = κ.internalCircuitCount hall := by + unfold RelTransitionSystem.openCircuitCount + RelTransitionSystem.internalCircuitCount + rw [walkPermPeriodic_eq_of_allInternal κ hall, + cycleType_permCongr, card_fixedPoints_permCongr] + +/-! ### 6. Boundary paths are not periodic -/ + +/-- The chain from a flag with all-internal pairings always returns +`none` (never reaches the boundary). -/ +theorem traceChain_none_of_all_internal_pairings + (κ : F.RelTransitionSystem) {f : W.Flag} + (h : ∀ j, W.pairing (iterWalk κ f j) ∈ F.internalFlags) + (fuel : ℕ) : traceChain κ fuel f = none := by + induction fuel generalizing f with + | zero => rfl + | succ n ih => + have h0 := h 0 + simp only [iterWalk_zero] at h0 + rw [traceChain_internal κ n f h0] + exact ih (fun j => by + show W.pairing (iterWalk κ (κ.match_ (W.pairing f)) j) ∈ + F.internalFlags + rw [iterWalk_shift]; exact h (j + 1)) + +/-- A flag whose chain reaches the boundary is not periodic. -/ +theorem not_periodic_of_boundary_chain + (κ : F.RelTransitionSystem) (f : W.Flag) + (hterm : ∃ fuel b, traceChain κ fuel f = some b) : + ¬ κ.PeriodicFlag f := by + intro hper + obtain ⟨fuel, b, hfuel⟩ := hterm + have := traceChain_none_of_all_internal_pairings κ + (all_pairings_internal_of_periodic κ hper) fuel + rw [this] at hfuel; cases hfuel + +/-! #### Dichotomy: periodic or boundary-terminating -/ + +/-- Every internal flag is either periodic or its chain reaches the +boundary. -/ +theorem internal_periodic_or_terminates + (κ : F.RelTransitionSystem) (f : W.Flag) + (hf : f ∈ F.internalFlags) : + κ.PeriodicFlag f ∨ + (∃ fuel b, traceChain κ fuel f = some b) := by + set N := F.internalFlags.card + -- Does the walk ever exit to a non-internal pairing? + by_cases hexall : ∀ j, + W.pairing (iterWalk κ f j) ∈ F.internalFlags + · -- Walk stays internal forever. Pigeonhole gives periodicity. + left + have hmem : ∀ j, iterWalk κ f j ∈ F.internalFlags := by + intro j; cases j with + | zero => exact hf + | succ j => + rw [iterWalk_succ] + exact κ.match_mem _ (hexall j) + have hinj_false : ¬ Function.Injective + (fun (i : Fin (N + 1)) => + (⟨iterWalk κ f i.val, hmem i.val⟩ : + {g : W.Flag // g ∈ F.internalFlags})) := by + intro hinj + have hcard := Fintype.card_le_of_injective _ hinj + rw [Fintype.card_fin, Fintype.card_coe] at hcard + omega + obtain ⟨⟨i, hi⟩, ⟨j, hj⟩, hne, heq_sub⟩ := + exists_collision_of_not_injective hinj_false + have heq : iterWalk κ f i = iterWalk κ f j := + congrArg Subtype.val heq_sub + have hne_val : i ≠ j := fun h => hne (Fin.ext h) + rcases Nat.lt_or_gt_of_ne hne_val with hij | hij + · exact ⟨hf, j - i, by omega, + fun k _ => hexall k, + iterWalk_period_of_repeat κ f i (j - i) + (fun k _ => hexall k) + (by rw [Nat.add_sub_cancel' hij.le]; exact heq)⟩ + · exact ⟨hf, i - j, by omega, + fun k _ => hexall k, + iterWalk_period_of_repeat κ f j (i - j) + (fun k _ => hexall k) + (by rw [Nat.add_sub_cancel' hij.le]; + exact heq.symm)⟩ + · -- Walk exits at some step. Find the first exit. + right + simp only [not_forall] at hexall + have : DecidablePred (fun k => + W.pairing (iterWalk κ f k) ∉ F.internalFlags) := + fun k => Classical.dec _ + have hk₀_spec := Nat.find_spec hexall + have hk₀_min : ∀ j, j < Nat.find hexall → + W.pairing (iterWalk κ f j) ∈ F.internalFlags := + fun j hj => by + by_contra h; exact Nat.find_min hexall hj h + -- iterWalk κ f (Nat.find hexall) is internal + have hk₀_mem : + iterWalk κ f (Nat.find hexall) ∈ F.internalFlags := by + rcases Nat.eq_zero_or_pos (Nat.find hexall) with h | h + · rw [h]; exact hf + · exact iterWalk_mem_internal κ (Nat.find hexall) + h le_rfl hk₀_min + have hk₀_flags : + W.pairing (iterWalk κ f (Nat.find hexall)) ∈ F.flags := + F.pairing_mem _ (mem_flags_of_internalFlags F hk₀_mem) + have hk₀_bdry : + W.pairing (iterWalk κ f (Nat.find hexall)) ∈ + F.boundaryFlags := + (F.mem_internalFlags_or_boundaryFlags hk₀_flags + ).resolve_left hk₀_spec + exact ⟨Nat.find hexall + 1, + W.pairing (iterWalk κ f (Nat.find hexall)), + traceChain_forward κ f hk₀_min hk₀_bdry⟩ + +/-! ### The edge-pairing reversal on periodic flags + +Reversing every periodic flag along its own edge conjugates the walk +permutation into its inverse, which is what makes the open circuits +come in pairs. +-/ + +/-- The periodic flags are closed under the edge pairing: a closed +circuit's edges lie wholly on it. -/ +theorem pairing_mem_periodicFlags (κ : F.RelTransitionSystem) + {f : W.Flag} (hf : f ∈ κ.periodicFlags) : + W.pairing f ∈ κ.periodicFlags := by + have hper := κ.mem_periodicFlags.mp hf + obtain ⟨hint, n, hn1, hcont, hperiod⟩ := hper + have hper' : κ.PeriodicFlag f := + ⟨hint, n, hn1, hcont, hperiod⟩ + have hcont_all : ∀ j, + W.pairing (iterWalk κ f j) ∈ F.internalFlags := + all_pairings_internal_of_periodic κ hper' + have hrev : ∀ j, j ≤ n → + iterWalk κ (W.pairing f) j = + W.pairing (iterWalk κ f (n - j)) := by + intro j hj + have h := iterWalk_reverse κ (fun i _ => hcont_all i) j hj + rwa [hperiod] at h + refine κ.mem_periodicFlags.mpr ⟨hcont_all 0, n, hn1, ?_, ?_⟩ + · intro j hj + rw [hrev j (le_of_lt hj), W.pairing_invol] + exact iterWalk_mem_internal_of_periodic κ hper' (n - j) + (by omega) + · rw [hrev n le_rfl, Nat.sub_self, iterWalk_zero] + +/-- The edge-pairing reversal on periodic flags. -/ +noncomputable def revPerm (κ : F.RelTransitionSystem) : + Equiv.Perm {f : W.Flag // f ∈ κ.periodicFlags} := + Function.Involutive.toPerm + (fun x => ⟨W.pairing x.val, pairing_mem_periodicFlags κ x.prop⟩) + (fun x => Subtype.ext (W.pairing_invol x.val)) + +/-- **The reversal conjugates the walk to its inverse**: traversing +a circuit backwards. -/ +theorem walkPerm_revPerm_walkPerm (κ : F.RelTransitionSystem) : + κ.walkPermPeriodic * revPerm κ * κ.walkPermPeriodic = revPerm κ := by + ext x + have hp0 : W.pairing x.val ∈ F.internalFlags := + all_pairings_internal_of_periodic κ + (κ.mem_periodicFlags.mp x.prop) 0 + change κ.internalWalk (W.pairing (κ.internalWalk x.val)) = + W.pairing x.val + calc κ.internalWalk (W.pairing (κ.internalWalk x.val)) + = κ.match_ (W.pairing (W.pairing + (κ.match_ (W.pairing x.val)))) := rfl + _ = κ.match_ (κ.match_ (W.pairing x.val)) := by + rw [W.pairing_invol] + _ = W.pairing x.val := κ.match_invol _ hp0 + +/-- The reversal is an involution. -/ +theorem revPerm_mul_self (κ : F.RelTransitionSystem) : + revPerm κ * revPerm κ = 1 := by + ext x + change W.pairing (W.pairing x.val) = x.val + exact W.pairing_invol x.val + +/-- Equivalently, it is its own inverse. -/ +theorem revPerm_inv (κ : F.RelTransitionSystem) : + (revPerm κ)⁻¹ = revPerm κ := by + rw [← mul_one (revPerm κ)⁻¹, ← revPerm_mul_self κ, ← mul_assoc, + inv_mul_cancel, one_mul] + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrbitParities.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrbitParities.lean new file mode 100644 index 0000000000..3958600b20 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrbitParities.lean @@ -0,0 +1,402 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.NonSeparatedStep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SeparatedParity + +/-! +# The non-separated count parities + +The two orbit-counting inputs of +`RS.Novel.Skein.NonSeparatedStep`, proved: + +* `nonSeparatedSegmentParity` — a same-component square preserves + the circuit-count parity (`NonSeparatedSegmentParity`); +* `nonSeparatedMergeParity` — a square whose `c`-edge lies on a + circuit not carrying `a` flips the count parity + (`NonSeparatedMergeParity`). + +## Method + +Both are computed on the closed-up full walk `Π` of +`RS.Novel.Skein.SeparatedParity`: a localized square turns the repaired +full walk into `(a d)(b c) · Π` (`fullPerm_repair`), and +`permOrbitCount Π = permOrbitCount walkPermPeriodic + |B|` converts +full-walk orbit ledgers into circuit-count ledgers. + +*Merge case* (`c` periodic, `a` off its orbit): exactly +`separatedCountParity` — the two swaps act +coherently (`permOrbitCount_swap_swap_mul`, `Δ = ±2` on `Π`-orbits, +`Δ = ±1` on circuits, parity flips). The separated-orientation +exclusion `a ≁ c` is replaced by the orbit-disjointness hypothesis +via `sameCycle_periodic_val`. + +*Segment case* (`WalkReach κ c a`): the walk gives `c ∼ a`, the +mirror symmetry gives `b ∼ σa ∼ σc ∼ d`, and the mirror collision +at `c` gives `b ≁ c`. The first swap therefore **merges** the two +traversal orbits of the component and the second swap **splits** +the merged cycle again (`a ∼ d` after the merge): the net change of +the `Π`-orbit count is zero (`permOrbitCount_swap_swap_mul_cancel` +below), so the circuit count is unchanged and the parity is even. + +The localization needed for `fullPerm_repair` comes from +`squareLocalized_of_walkReach` (segment case) and from +`periodic_or_onBoundaryChain` (merge case); their `[LinearOrder α]` +assumption is discharged by well-ordering the label type. +-/ + +@[expose] public section + +namespace RS + + + +/-! ## The incoherent double swap: merge then split -/ + +section AbstractCancel + +open Equiv Equiv.Perm + +variable {Y : Type} + +/-- Along the swap-multiplied permutation, every point of a +`g`-trajectory of `x` is in the orbit of `x` or of `y`. -/ +private theorem sameCycle_swap_mul_pow_left [DecidableEq Y] + (g : Perm Y) (x y : Y) : + ∀ k : ℕ, (Equiv.swap x y * g).SameCycle x ((g ^ k) x) ∨ + (Equiv.swap x y * g).SameCycle y ((g ^ k) x) := by + intro k + induction k with + | zero => exact Or.inl (Equiv.Perm.SameCycle.refl _ _) + | succ k ih => + have hstep : (g ^ (k + 1)) x = g ((g ^ k) x) := by + rw [pow_succ', Equiv.Perm.mul_apply] + by_cases h1 : g ((g ^ k) x) = x + · refine Or.inl ?_ + rw [hstep, h1] + by_cases h2 : g ((g ^ k) x) = y + · refine Or.inr ?_ + rw [hstep, h2] + · have happ : (Equiv.swap x y * g) ((g ^ k) x) = + g ((g ^ k) x) := by + rw [Equiv.Perm.mul_apply, + Equiv.swap_apply_of_ne_of_ne h1 h2] + have hsc : (Equiv.swap x y * g).SameCycle ((g ^ k) x) + ((g ^ (k + 1)) x) := by + rw [hstep, ← happ] + exact Equiv.Perm.sameCycle_apply_right.mpr + (Equiv.Perm.SameCycle.refl _ _) + rcases ih with h | h + · exact Or.inl (h.trans hsc) + · exact Or.inr (h.trans hsc) + +/-- `SameCycle` out of a swapped point transfers to the +swap-multiplied permutation, up to landing in either swap orbit. -/ +private theorem sameCycle_swap_mul_of_left [Finite Y] [DecidableEq Y] + {g : Perm Y} {x y u : Y} + (h : g.SameCycle x u) : + (Equiv.swap x y * g).SameCycle x u ∨ + (Equiv.swap x y * g).SameCycle y u := by + let : Fintype Y := Fintype.ofFinite Y + obtain ⟨i, _, _, hiu⟩ := Equiv.Perm.SameCycle.exists_pow_eq _ h + rw [← hiu] + exact sameCycle_swap_mul_pow_left g x y i + +/-- **The incoherent double swap**: if the first transposition +merges two distinct orbits (`c ∼ a`, `b ∼ d`, `b ≁ c`) then the +second transposition splits the merged cycle again (`a ∼ d` holds +after the merge), and the total orbit count is unchanged. -/ +private theorem permOrbitCount_swap_swap_mul_cancel [Fintype Y] [DecidableEq Y] + {g : Perm Y} + {a b c d : Y} (hbc : b ≠ c) (had : a ≠ d) + (hca : g.SameCycle c a) (hbd : g.SameCycle b d) + (hnbc : ¬ g.SameCycle b c) : + permOrbitCount (Equiv.swap a d * (Equiv.swap b c * g)) = + permOrbitCount g := by + have hmerge := permOrbitCount_swap_mul_not_sameCycle hbc hnbc + have hbc' : (Equiv.swap b c * g).SameCycle b c := + sameCycle_swap_mul_of_not hbc hnbc + have hca' : (Equiv.swap b c * g).SameCycle c a ∨ + (Equiv.swap b c * g).SameCycle b a := by + rw [Equiv.swap_comm b c] + exact sameCycle_swap_mul_of_left hca + have hbd' : (Equiv.swap b c * g).SameCycle b d ∨ + (Equiv.swap b c * g).SameCycle c d := + sameCycle_swap_mul_of_left hbd + have hac' : (Equiv.swap b c * g).SameCycle a c := by + rcases hca' with h | h + · exact h.symm + · exact h.symm.trans hbc' + have hcd' : (Equiv.swap b c * g).SameCycle c d := by + rcases hbd' with h | h + · exact hbc'.symm.trans h + · exact h + have had' : (Equiv.swap b c * g).SameCycle a d := + hac'.trans hcd' + have hsplit := permOrbitCount_swap_mul_sameCycle had had' + omega + +end AbstractCancel + +/-! ## The same-component parity (segment reversal, Δ = 0) -/ + +open EdgeSubset in +/-- **The segment count parity** (the input +`NonSeparatedSegmentParity`): a +same-component square preserves the circuit-count parity. The +first swap merges the two traversal orbits of the component, the +second splits them again: `Δ permOrbitCount = 0`. -/ +theorem nonSeparatedSegmentParity : NonSeparatedSegmentParity := by + intro α W F κ a b c d v hsq hreach + classical + let : LinearOrder α := IsWellOrder.linearOrder WellOrderingRel + -- localization and pathMatch invariance of the move + have hloc : SquareLocalized κ a b c d := + squareLocalized_of_walkReach hsq hreach + have hpm := pathMatch_repair_of_localized hsq hloc + obtain ⟨m, hm1, hcont, hlast⟩ := hreach + -- distinctness of the swap pairs in the flag subtype + have hbcX : (⟨b, mem_flags_of_internalFlags F hsq.hb⟩ : + {f : W.Flag // f ∈ F.flags}) ≠ + ⟨c, mem_flags_of_internalFlags F hsq.hc⟩ := fun h => + hsq.hbc (congrArg Subtype.val h) + have hadX : (⟨a, mem_flags_of_internalFlags F hsq.ha⟩ : + {f : W.Flag // f ∈ F.flags}) ≠ + ⟨d, mem_flags_of_internalFlags F hsq.hd⟩ := fun h => + hsq.had (congrArg Subtype.val h) + -- the walk relation `c ∼ a` + have hca : (fullPerm κ).SameCycle + ⟨c, mem_flags_of_internalFlags F hsq.hc⟩ + ⟨a, mem_flags_of_internalFlags F hsq.ha⟩ := by + refine sameCycle_of_pow_eq (n := m) (Subtype.ext ?_) + rw [fullPerm_pow_val + (x := ⟨c, mem_flags_of_internalFlags F hsq.hc⟩) hcont m + le_rfl] + exact hlast + -- the single-step relations `σb ∼ a` and `σc ∼ d` + have hstep_b : fullPerm κ (pairingPermSP F + ⟨b, mem_flags_of_internalFlags F hsq.hb⟩) = + ⟨a, mem_flags_of_internalFlags F hsq.ha⟩ := by + apply Subtype.ext + rw [fullPerm_apply_pairing, + fullMatchFun_val_internal κ + (show (⟨b, mem_flags_of_internalFlags F hsq.hb⟩ : + {f : W.Flag // f ∈ F.flags}).val ∈ F.internalFlags from + hsq.hb)] + exact hsq.hmb + have hstep_c : fullPerm κ (pairingPermSP F + ⟨c, mem_flags_of_internalFlags F hsq.hc⟩) = + ⟨d, mem_flags_of_internalFlags F hsq.hd⟩ := by + apply Subtype.ext + rw [fullPerm_apply_pairing, + fullMatchFun_val_internal κ + (show (⟨c, mem_flags_of_internalFlags F hsq.hc⟩ : + {f : W.Flag // f ∈ F.flags}).val ∈ F.internalFlags from + hsq.hc)] + exact hsq.hcd + have hrel_b : (fullPerm κ).SameCycle + (pairingPermSP F ⟨b, mem_flags_of_internalFlags F hsq.hb⟩) + ⟨a, mem_flags_of_internalFlags F hsq.ha⟩ := by + rw [← hstep_b] + exact Equiv.Perm.sameCycle_apply_right.mpr + (Equiv.Perm.SameCycle.refl _ _) + have hrel_c : (fullPerm κ).SameCycle + (pairingPermSP F ⟨c, mem_flags_of_internalFlags F hsq.hc⟩) + ⟨d, mem_flags_of_internalFlags F hsq.hd⟩ := by + rw [← hstep_c] + exact Equiv.Perm.sameCycle_apply_right.mpr + (Equiv.Perm.SameCycle.refl _ _) + -- the mirror of the walk relation: `σc ∼ σa` + have hmir : (fullPerm κ).SameCycle + (pairingPermSP F ⟨c, mem_flags_of_internalFlags F hsq.hc⟩) + (pairingPermSP F ⟨a, mem_flags_of_internalFlags F hsq.ha⟩) := + sameCycle_pairingPermSP hca + -- `b ∼ σa` (mirror of `σb ∼ a`) + have hbσa := sameCycle_pairingPermSP hrel_b + rw [pairingPermSP_invol] at hbσa + -- hence `b ∼ d` through the mirror orbit + have hbd : (fullPerm κ).SameCycle + ⟨b, mem_flags_of_internalFlags F hsq.hb⟩ + ⟨d, mem_flags_of_internalFlags F hsq.hd⟩ := + (hbσa.trans hmir.symm).trans hrel_c + -- mirror collision at `c`: `c ≁ σc` + have hNc : ¬ (fullPerm κ).SameCycle + ⟨c, mem_flags_of_internalFlags F hsq.hc⟩ + (pairingPermSP F ⟨c, mem_flags_of_internalFlags F hsq.hc⟩) + := by + rcases hloc with ⟨_hpa, hpc⟩ | ⟨β, hβ, hall⟩ + · exact not_sameCycle_pairingPermSP_of_periodic hpc + · rcases hall c (Or.inr (Or.inr (Or.inl rfl))) with hpc | hchain + · exact not_sameCycle_pairingPermSP_of_periodic hpc + · obtain ⟨k, hkle, hcontk, htermk⟩ := + chain_terminates_with_data κ hβ + obtain ⟨k', t, htk', hcont', hterm', hft⟩ := hchain + have hkk : k' = k := + chain_exit_unique hcont' hterm' hcontk htermk + subst hkk + exact not_sameCycle_pairingPermSP_of_chain hβ hkle hcontk + htermk (mem_flags_of_internalFlags F hsq.hc) htk' hft + -- the two swap points are on distinct orbits: `b ≁ c` + have hnbc : ¬ (fullPerm κ).SameCycle + ⟨b, mem_flags_of_internalFlags F hsq.hb⟩ + ⟨c, mem_flags_of_internalFlags F hsq.hc⟩ := by + intro h + exact hNc ((h.symm.trans hbσa).trans hmir.symm) + -- the incoherent double swap: net zero + have hcnt := permOrbitCount_swap_swap_mul_cancel hbcX hadX hca + hbd hnbc + rw [← fullPerm_repair hsq hpm] at hcnt + -- the orbit bookkeeping on both sides + have h1 := permOrbitCount_fullPerm_eq κ + have h2 := permOrbitCount_fullPerm_eq (κ.repair a b c d v hsq) + have hc1 : κ.openCircuitCount = + permOrbitCount κ.walkPermPeriodic / 2 := rfl + have hc2 : (κ.repair a b c d v hsq).openCircuitCount = + permOrbitCount (κ.repair a b c d v hsq).walkPermPeriodic / 2 + := rfl + rw [Nat.even_iff, hc1, hc2] + omega + +/-! ## The distinct-component parity (splice merge, Δ = ±1) -/ + +open EdgeSubset in +/-- **The merge count parity** (the input +`NonSeparatedMergeParity`): a +square whose `c`-edge lies on a circuit not carrying `a` flips the +count parity. The argument of `separatedCountParity`, with the +separated-orientation exclusion `a ≁ c` replaced by the +orbit-disjointness hypothesis. -/ +theorem nonSeparatedMergeParity : NonSeparatedMergeParity := by + intro α W F κ a b c d v hsq hpc hdisj + classical + let : LinearOrder α := IsWellOrder.linearOrder WellOrderingRel + -- localization: `c`'s circuit is periodic, `a` is periodic or on + -- a boundary chain carrying its whole edge + have hloc : SquareLocalized κ a b c d := by + by_cases hpa : κ.PeriodicFlag a + · exact Or.inl ⟨hpa, hpc⟩ + · rcases periodic_or_onBoundaryChain κ hsq.ha with + h | ⟨β, hβ, hchain⟩ + · exact absurd h hpa + · refine Or.inr ⟨β, hβ, ?_⟩ + intro f hf + rcases hf with rfl | rfl | rfl | rfl + · exact Or.inr hchain + · exact Or.inr (hsq.hab ▸ + onBoundaryChain_match hβ hsq.ha hchain) + · exact Or.inl hpc + · exact Or.inl (hsq.hcd ▸ periodicFlag_match hpc) + have hpm := pathMatch_repair_of_localized hsq hloc + -- ═══════ STAGE 1: THE SQUARE'S CORNERS AND THEIR STEPS ═══════ + -- distinctness of the square corners in the flag subtype + have hbcX : (⟨b, mem_flags_of_internalFlags F hsq.hb⟩ : + {f : W.Flag // f ∈ F.flags}) ≠ + ⟨c, mem_flags_of_internalFlags F hsq.hc⟩ := fun h => + hsq.hbc (congrArg Subtype.val h) + have hadX : (⟨a, mem_flags_of_internalFlags F hsq.ha⟩ : + {f : W.Flag // f ∈ F.flags}) ≠ + ⟨d, mem_flags_of_internalFlags F hsq.hd⟩ := fun h => + hsq.had (congrArg Subtype.val h) + -- the single-step relations `σb ∼ a` and `σc ∼ d` + have hstep_b : fullPerm κ (pairingPermSP F + ⟨b, mem_flags_of_internalFlags F hsq.hb⟩) = + ⟨a, mem_flags_of_internalFlags F hsq.ha⟩ := by + apply Subtype.ext + rw [fullPerm_apply_pairing, + fullMatchFun_val_internal κ + (show (⟨b, mem_flags_of_internalFlags F hsq.hb⟩ : + {f : W.Flag // f ∈ F.flags}).val ∈ F.internalFlags from + hsq.hb)] + exact hsq.hmb + have hstep_c : fullPerm κ (pairingPermSP F + ⟨c, mem_flags_of_internalFlags F hsq.hc⟩) = + ⟨d, mem_flags_of_internalFlags F hsq.hd⟩ := by + apply Subtype.ext + rw [fullPerm_apply_pairing, + fullMatchFun_val_internal κ + (show (⟨c, mem_flags_of_internalFlags F hsq.hc⟩ : + {f : W.Flag // f ∈ F.flags}).val ∈ F.internalFlags from + hsq.hc)] + exact hsq.hcd + have hrel_b : (fullPerm κ).SameCycle + (pairingPermSP F ⟨b, mem_flags_of_internalFlags F hsq.hb⟩) + ⟨a, mem_flags_of_internalFlags F hsq.ha⟩ := by + rw [← hstep_b] + exact Equiv.Perm.sameCycle_apply_right.mpr + (Equiv.Perm.SameCycle.refl _ _) + have hrel_c : (fullPerm κ).SameCycle + (pairingPermSP F ⟨c, mem_flags_of_internalFlags F hsq.hc⟩) + ⟨d, mem_flags_of_internalFlags F hsq.hd⟩ := by + rw [← hstep_c] + exact Equiv.Perm.sameCycle_apply_right.mpr + (Equiv.Perm.SameCycle.refl _ _) + -- ═══════ STAGE 2: THE MIRROR EQUIVALENCE `b ∼ c ↔ a ∼ d` ═══════ + have hiff : (fullPerm κ).SameCycle + ⟨b, mem_flags_of_internalFlags F hsq.hb⟩ + ⟨c, mem_flags_of_internalFlags F hsq.hc⟩ ↔ + (fullPerm κ).SameCycle + ⟨a, mem_flags_of_internalFlags F hsq.ha⟩ + ⟨d, mem_flags_of_internalFlags F hsq.hd⟩ := by + constructor + · intro h + exact (hrel_b.symm.trans (sameCycle_pairingPermSP h)).trans + hrel_c + · intro h + have h2 := sameCycle_pairingPermSP + ((hrel_b.trans h).trans hrel_c.symm) + rw [pairingPermSP_invol, pairingPermSP_invol] at h2 + exact h2 + -- ═══════ STAGE 3: THE THREE EXCLUSIONS ═══════ + -- exclusion `¬ b ∼ σb` (mirror collision at `b`) + have hN1 : ¬ (fullPerm κ).SameCycle + ⟨b, mem_flags_of_internalFlags F hsq.hb⟩ + (pairingPermSP F ⟨b, mem_flags_of_internalFlags F hsq.hb⟩) + := by + rcases hloc with ⟨hpa, _hpc⟩ | ⟨β, hβ, hall⟩ + · exact not_sameCycle_pairingPermSP_of_periodic + (show κ.PeriodicFlag b from + hsq.hab ▸ periodicFlag_match hpa) + · rcases hall b (Or.inr (Or.inl rfl)) with hpb | hchain + · exact not_sameCycle_pairingPermSP_of_periodic hpb + · obtain ⟨k, hkle, hcontk, htermk⟩ := + chain_terminates_with_data κ hβ + obtain ⟨k', t, htk', hcont', hterm', hft⟩ := hchain + have hkk : k' = k := + chain_exit_unique hcont' hterm' hcontk htermk + subst hkk + exact not_sameCycle_pairingPermSP_of_chain hβ hkle hcontk + htermk (mem_flags_of_internalFlags F hsq.hb) htk' hft + -- exclusion `¬ a ∼ b` + have hab : ¬ (fullPerm κ).SameCycle + ⟨a, mem_flags_of_internalFlags F hsq.ha⟩ + ⟨b, mem_flags_of_internalFlags F hsq.hb⟩ := by + intro h + exact hN1 (h.symm.trans hrel_b.symm) + -- exclusion `¬ a ∼ c` (the orbit disjointness) + have hac : ¬ (fullPerm κ).SameCycle + ⟨a, mem_flags_of_internalFlags F hsq.ha⟩ + ⟨c, mem_flags_of_internalFlags F hsq.hc⟩ := by + intro h + obtain ⟨i, hi⟩ := sameCycle_periodic_val hpc h.symm + exact hdisj ⟨i, Or.inl hi.symm⟩ + -- ═══════ ASSEMBLY: THE DOUBLE SWAP AND THE ORBIT LEDGER ═══════ + have hswap := permOrbitCount_swap_swap_mul (g := fullPerm κ) + hbcX hadX hiff hab hac + rw [← fullPerm_repair hsq hpm] at hswap + -- the orbit bookkeeping on both sides + have h1 := permOrbitCount_fullPerm_eq κ + have h2 := permOrbitCount_fullPerm_eq (κ.repair a b c d v hsq) + have hc1 : κ.openCircuitCount = + permOrbitCount κ.walkPermPeriodic / 2 := rfl + have hc2 : (κ.repair a b c d v hsq).openCircuitCount = + permOrbitCount (κ.repair a b c d v hsq).walkPermPeriodic / 2 + := rfl + rw [Nat.odd_iff, hc1, hc2] + rcases hswap with h | h <;> omega + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientExistence.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientExistence.lean new file mode 100644 index 0000000000..2c94eb05dc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientExistence.lean @@ -0,0 +1,499 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonTransport + +/-! +# Orientation existence + +Every boundary-relative transition system admits an orientation: the +boundary-completed walk is an involution pair, and two-colouring its +orbits by the orbit representative gives the directions. Canonical +data therefore exist exactly when a transition system does. +-/ + +@[expose] public section + +namespace RS + + +/-! ## Orientation existence + +Every boundary-relative transition system admits an orientation: +complete the matching across the boundary by the path matching +(fixed-point-free by the chain-reversal parity), and two-colour the +alternating-walk orbits exactly as `buildOrientation` does — the +conjugation identity is pure group algebra of two involutions. -/ + +section OrientExist + +open EdgeSubset + +variable {α : Type} {W : Fragment α} {F : EdgeSubset W} + +/-- **The path matching has no fixed points**: a chain cannot end +where it starts — folding the reversal identity into the middle +hits a pairing or matching fixed point. -/ +theorem EdgeSubset.RelTransitionSystem.pathMatch_ne + (κ : F.RelTransitionSystem) {b : W.Flag} + (hb : b ∈ F.boundaryFlags) : κ.pathMatch b hb ≠ b := by + intro hEq + obtain ⟨k, -, hcont, hpm⟩ := pathMatch_chain_length κ hb + have hrev : ∀ j, j ≤ k → iterWalk κ b j = + W.pairing (iterWalk κ b (k - j)) := by + intro j hj + have h0 := iterWalk_reverse κ hcont j hj + rw [← hpm, hEq] at h0 + exact h0 + rcases Nat.even_or_odd k with ⟨m, hm⟩ | ⟨m, hm⟩ + · have h1 := hrev m (by omega) + rw [show k - m = m from by omega] at h1 + exact W.pairing_ne (iterWalk κ b m) h1.symm + · have h1 := hrev (m + 1) (by omega) + rw [show k - (m + 1) = m from by omega] at h1 + have h2 : iterWalk κ b (m + 1) = + κ.match_ (W.pairing (iterWalk κ b m)) := rfl + have hint : W.pairing (iterWalk κ b m) ∈ F.internalFlags := + hcont m (by omega) + exact κ.match_ne _ hint (h1 ▸ h2).symm + +/-- Internal and boundary flags are disjoint. -/ +theorem internal_not_boundary {f : W.Flag} + (hf : f ∈ F.internalFlags) : f ∉ F.boundaryFlags := by + classical + intro hb + obtain ⟨-, v, hv⟩ := mem_internalFlags_iff.mp hf + obtain ⟨-, i, hi⟩ := Finset.mem_filter.mp hb + rw [hv] at hi + cases hi + +/-- The matching completed across the boundary by the path +matching. -/ +noncomputable def relComplete (κ : F.RelTransitionSystem) + (f : W.Flag) : W.Flag := + if _hf : f ∈ F.internalFlags then κ.match_ f + else if hb : f ∈ F.boundaryFlags then κ.pathMatch f hb + else f + +/-- The completed matching is the system's own on internal +flags. -/ +theorem relComplete_internal (κ : F.RelTransitionSystem) + {f : W.Flag} (hf : f ∈ F.internalFlags) : + relComplete κ f = κ.match_ f := by + unfold relComplete + rw [dite_eq_left hf] + +/-- And the path matching on boundary flags. -/ +theorem relComplete_boundary (κ : F.RelTransitionSystem) + {f : W.Flag} (hb : f ∈ F.boundaryFlags) : + relComplete κ f = κ.pathMatch f hb := by + unfold relComplete + rw [dite_eq_right (fun hf => internal_not_boundary hf hb), dite_eq_left hb] + +/-- Off the subset it is the identity. -/ +theorem relComplete_off (κ : F.RelTransitionSystem) + {f : W.Flag} (hf : f ∉ F.flags) : relComplete κ f = f := by + unfold relComplete + rw [dite_eq_right (fun h1 => hf (mem_flags_of_internalFlags F h1)), + dite_eq_right (fun h1 => hf (mem_flags_of_boundaryFlags F h1))] + +/-- The completed matching is a global involution. -/ +theorem relComplete_invol (κ : F.RelTransitionSystem) : + Function.Involutive (relComplete κ) := by + intro f + by_cases hf : f ∈ F.internalFlags + · rw [relComplete_internal κ hf, + relComplete_internal κ (κ.match_mem f hf)] + exact κ.match_invol f hf + · by_cases hb : f ∈ F.boundaryFlags + · rw [relComplete_boundary κ hb, + relComplete_boundary κ (κ.pathMatch_mem hb)] + exact κ.pathMatch_invol hb + · have hoff : f ∉ F.flags := by + intro hfl + rcases mem_internalFlags_or_boundaryFlags F hfl with + h1 | h1 + · exact hf h1 + · exact hb h1 + rw [relComplete_off κ hoff, relComplete_off κ hoff] + +/-- The completed matching preserves the participating flags. -/ +theorem relComplete_mem (κ : F.RelTransitionSystem) + {f : W.Flag} (hf : f ∈ F.flags) : + relComplete κ f ∈ F.flags := by + rcases mem_internalFlags_or_boundaryFlags F hf with h1 | h1 + · rw [relComplete_internal κ h1] + exact mem_flags_of_internalFlags F (κ.match_mem f h1) + · rw [relComplete_boundary κ h1] + exact mem_flags_of_boundaryFlags F (κ.pathMatch_mem h1) + +/-- The completed matching has no fixed points on participating +flags. -/ +theorem relComplete_ne (κ : F.RelTransitionSystem) + {f : W.Flag} (hf : f ∈ F.flags) : relComplete κ f ≠ f := by + rcases mem_internalFlags_or_boundaryFlags F hf with h1 | h1 + · rw [relComplete_internal κ h1] + exact κ.match_ne f h1 + · rw [relComplete_boundary κ h1] + exact κ.pathMatch_ne h1 + +/-- The completed matching as a permutation of the participating +flags. -/ +noncomputable def relMatchPerm (κ : F.RelTransitionSystem) : + Equiv.Perm {f : W.Flag // f ∈ F.flags} where + toFun x := ⟨relComplete κ x.val, relComplete_mem κ x.prop⟩ + invFun x := ⟨relComplete κ x.val, relComplete_mem κ x.prop⟩ + left_inv x := Subtype.ext (relComplete_invol κ x.val) + right_inv x := Subtype.ext (relComplete_invol κ x.val) + +/-- The completed matching as a permutation, on underlying +flags. -/ +@[simp] theorem relMatchPerm_val (κ : F.RelTransitionSystem) + (x : {f : W.Flag // f ∈ F.flags}) : + (relMatchPerm κ x).val = relComplete κ x.val := rfl + +/-- It is an involution. -/ +theorem relMatchPerm_mul_self (κ : F.RelTransitionSystem) : + relMatchPerm κ * relMatchPerm κ = 1 := by + apply Equiv.Perm.ext + intro x + exact Subtype.ext (relComplete_invol κ x.val) + +/-- The completed walk permutation. -/ +noncomputable def relWalkPerm (κ : F.RelTransitionSystem) : + Equiv.Perm {f : W.Flag // f ∈ F.flags} := + relMatchPerm κ * F.pairingPerm + +/-- The walk permutation: cross the edge, then match. -/ +@[simp] theorem relWalkPerm_val (κ : F.RelTransitionSystem) + (x : {f : W.Flag // f ∈ F.flags}) : + (relWalkPerm κ x).val = + relComplete κ (W.pairing x.val) := by + change (relMatchPerm κ (F.pairingPerm x)).val = _ + rw [relMatchPerm_val, EdgeSubset.pairingPerm_val] + +/-- Its inverse walks the other way: match, then cross. -/ +theorem relWalkPerm_inv (κ : F.RelTransitionSystem) : + (relWalkPerm κ)⁻¹ = F.pairingPerm * relMatchPerm κ := by + rw [relWalkPerm, mul_inv_rev, EdgeSubset.pairingPerm_inv, + show (relMatchPerm κ)⁻¹ = relMatchPerm κ from + mul_left_cancel (a := relMatchPerm κ) + (by rw [mul_inv_cancel, relMatchPerm_mul_self])] + +/-- The pairing conjugates the completed walk to its inverse. -/ +theorem relConj (κ : F.RelTransitionSystem) : + F.pairingPerm * relWalkPerm κ * F.pairingPerm = + (relWalkPerm κ)⁻¹ := by + rw [relWalkPerm_inv, relWalkPerm] + calc F.pairingPerm * (relMatchPerm κ * F.pairingPerm) * + F.pairingPerm + = F.pairingPerm * relMatchPerm κ * + (F.pairingPerm * F.pairingPerm) := by + rw [mul_assoc, mul_assoc, mul_assoc] + _ = F.pairingPerm * relMatchPerm κ := by + rw [EdgeSubset.pairingPerm_mul_self, mul_one] + +/-- **The mirror symmetry**: conjugating a power of the walk by the +edge pairing inverts it — traversing a chain backwards. -/ +theorem relConj_zpow (κ : F.RelTransitionSystem) (n : ℤ) : + F.pairingPerm * relWalkPerm κ ^ n * F.pairingPerm = + relWalkPerm κ ^ (-n) := by + have hσ_inv := EdgeSubset.pairingPerm_inv (F := F) + calc F.pairingPerm * relWalkPerm κ ^ n * F.pairingPerm + = F.pairingPerm * relWalkPerm κ ^ n * + F.pairingPerm⁻¹ := by + congr 1 + exact hσ_inv.symm + _ = (MulAut.conj F.pairingPerm) (relWalkPerm κ ^ n) := rfl + _ = ((MulAut.conj F.pairingPerm) (relWalkPerm κ)) ^ n := + map_zpow (MulAut.conj F.pairingPerm).toMonoidHom + (relWalkPerm κ) n + _ = (relWalkPerm κ)⁻¹ ^ n := by + congr 1 + change F.pairingPerm * relWalkPerm κ * F.pairingPerm⁻¹ = + (relWalkPerm κ)⁻¹ + rw [hσ_inv] + exact relConj κ + _ = relWalkPerm κ ^ (-n) := inv_zpow' (relWalkPerm κ) n + +/-- A flag and its pairing partner are never in the same completed +walk orbit. -/ +theorem relPairing_not_sameCycle (κ : F.RelTransitionSystem) + {f : W.Flag} (hf : f ∈ F.flags) : + ¬ (relWalkPerm κ).SameCycle ⟨f, hf⟩ + ⟨W.pairing f, F.pairing_mem f hf⟩ := by + intro hsame + obtain ⟨m, _hm_pos, _, hm_eq⟩ := hsame.exists_pow_eq'' + have hconj_applied : ∀ n : ℤ, + F.pairingPerm ((relWalkPerm κ ^ n) + (F.pairingPerm ⟨f, hf⟩)) = + (relWalkPerm κ ^ (-n)) ⟨f, hf⟩ := fun n => by + have h := congr_fun (congr_arg DFunLike.coe + (relConj_zpow κ n)) ⟨f, hf⟩ + simpa only [Equiv.Perm.mul_apply] using h + have hm' : (relWalkPerm κ ^ (m : ℤ)) ⟨f, hf⟩ = + F.pairingPerm ⟨f, hf⟩ := by + rw [zpow_natCast] + exact Subtype.ext (by + have := congrArg Subtype.val hm_eq + simpa only [EdgeSubset.pairingPerm_val] using this) + have hshift : ∀ n : ℤ, + F.pairingPerm ((relWalkPerm κ ^ (n + ↑m)) ⟨f, hf⟩) = + (relWalkPerm κ ^ (-n)) ⟨f, hf⟩ := by + intro n + rw [zpow_add, Equiv.Perm.mul_apply, hm'] + exact hconj_applied n + rcases Nat.even_or_odd m with ⟨j, hj⟩ | ⟨j, hj⟩ + · have key := hshift (-(j : ℤ)) + have harith : -(j : ℤ) + ↑m = (j : ℤ) := by omega + rw [harith, neg_neg] at key + have hval := congrArg Subtype.val key + simp only [EdgeSubset.pairingPerm_val] at hval + exact W.pairing_ne _ hval + · have key := hshift (-(j : ℤ)) + have harith : -(j : ℤ) + ↑m = (j : ℤ) + 1 := by omega + rw [harith, neg_neg] at key + have hstep : (relWalkPerm κ ^ ((j : ℤ) + 1)) ⟨f, hf⟩ = + relWalkPerm κ ((relWalkPerm κ ^ (j : ℤ)) ⟨f, hf⟩) := by + conv_lhs => rw [show (j : ℤ) + 1 = 1 + (j : ℤ) from by + ring] + rw [zpow_add, zpow_one, Equiv.Perm.mul_apply] + rw [hstep] at key + set g := (relWalkPerm κ ^ (j : ℤ)) ⟨f, hf⟩ + have hval : W.pairing (relComplete κ (W.pairing g.val)) = + g.val := by + have := congrArg Subtype.val key + simpa only [EdgeSubset.pairingPerm_val, relWalkPerm_val] + using this + have hval2 : relComplete κ (W.pairing g.val) = + W.pairing g.val := by + have := congrArg W.pairing hval + rwa [W.pairing_invol] at this + exact relComplete_ne κ (F.pairing_mem g.val g.prop) hval2 + +/-- An internal flag's match and its edge partner lie on the same +walk orbit. -/ +theorem relMatch_sameCycle_pairing (κ : F.RelTransitionSystem) + {f : W.Flag} (hf : f ∈ F.internalFlags) : + (relWalkPerm κ).SameCycle + ⟨κ.match_ f, mem_flags_of_internalFlags F + (κ.match_mem f hf)⟩ + ⟨W.pairing f, F.pairing_mem f + (mem_flags_of_internalFlags F hf)⟩ := + Equiv.Perm.SameCycle.symm ⟨1, Subtype.ext (by + rw [zpow_one, relWalkPerm_val, W.pairing_invol, + relComplete_internal κ hf])⟩ + +/-- So do the edge partner of a flag's match and the flag itself. -/ +theorem relPairing_match_sameCycle (κ : F.RelTransitionSystem) + {f : W.Flag} (hf : f ∈ F.internalFlags) : + (relWalkPerm κ).SameCycle + ⟨W.pairing (κ.match_ f), F.pairing_mem _ + (mem_flags_of_internalFlags F (κ.match_mem f hf))⟩ + ⟨f, mem_flags_of_internalFlags F hf⟩ := + ⟨1, Subtype.ext (by + rw [zpow_one, relWalkPerm_val, W.pairing_invol, + relComplete_internal κ (κ.match_mem f hf), + κ.match_invol f hf])⟩ + +/-- `a ≠ b` flips the decidable strict comparison. -/ +private theorem decide_lt_flip' {γ : Type} [LinearOrder γ] + [DecidableRel ((· < ·) : γ → γ → Prop)] + {a b : γ} (h : a ≠ b) : decide (a < b) = !decide (b < a) := by + rcases lt_or_gt_of_ne h with hab | hab + · simp [hab, show ¬ b < a from not_lt.mpr hab.le] + · simp [hab, show ¬ a < b from not_lt.mpr hab.le] + +open Classical in +/-- **Orientation existence**: every boundary-relative transition +system admits an orientation — two-colour the completed-walk +orbits by the orbit-representative comparison. -/ +noncomputable def relBuildOrientation (κ : F.RelTransitionSystem) : + κ.Orientation := by + letI flagOrd := W.flagOrder + letI := Classical.dec + letI subtypeOrd : LinearOrder {f : W.Flag // f ∈ F.flags} := + LinearOrder.lift' Subtype.val Subtype.val_injective + let orbitOf (x : {f : W.Flag // f ∈ F.flags}) : + Finset {f : W.Flag // f ∈ F.flags} := + Finset.univ.filter (fun y => (relWalkPerm κ).SameCycle x y) + have orbit_nonempty (x : {f : W.Flag // f ∈ F.flags}) : + (orbitOf x).Nonempty := + ⟨x, Finset.mem_filter.mpr ⟨Finset.mem_univ _, + Equiv.Perm.SameCycle.rfl⟩⟩ + let orbitMin (x : {f : W.Flag // f ∈ F.flags}) : + {f : W.Flag // f ∈ F.flags} := + (orbitOf x).min' (orbit_nonempty x) + have orbitMin_eq (x y : {f : W.Flag // f ∈ F.flags}) + (h : (relWalkPerm κ).SameCycle x y) : + orbitMin x = orbitMin y := by + simp only [orbitMin] + congr 1 + ext z + simp only [orbitOf, Finset.mem_filter, Finset.mem_univ, + true_and] + exact ⟨fun hz => h.symm.trans hz, fun hz => h.trans hz⟩ + have orbitMin_pairing_ne (x : {f : W.Flag // f ∈ F.flags}) : + orbitMin (F.pairingPerm x) ≠ orbitMin x := by + intro heq + have hmin_in_x : orbitMin x ∈ orbitOf x := + Finset.min'_mem _ _ + have hmin_in_σx : orbitMin (F.pairingPerm x) ∈ + orbitOf (F.pairingPerm x) := Finset.min'_mem _ _ + rw [heq] at hmin_in_σx + simp only [orbitOf, Finset.mem_filter, Finset.mem_univ, + true_and] at hmin_in_x hmin_in_σx + refine relPairing_not_sameCycle κ x.prop ?_ + have hx : (⟨W.pairing x.val, F.pairing_mem x.val x.prop⟩ : + {f : W.Flag // f ∈ F.flags}) = F.pairingPerm x := + Subtype.ext (by simp) + rw [show (⟨x.val, x.prop⟩ : {f : W.Flag // f ∈ F.flags}) = x + from rfl, hx] + exact hmin_in_x.trans hmin_in_σx.symm + have orbitMin_match (x : {f : W.Flag // f ∈ F.flags}) + (hint : x.val ∈ F.internalFlags) : + orbitMin ⟨κ.match_ x.val, mem_flags_of_internalFlags F + (κ.match_mem x.val hint)⟩ = + orbitMin (F.pairingPerm x) := by + apply orbitMin_eq + have h := relMatch_sameCycle_pairing κ hint + convert h using 1 + exact Subtype.ext (by simp) + have orbitMin_pairing_match (x : {f : W.Flag // f ∈ F.flags}) + (hint : x.val ∈ F.internalFlags) : + orbitMin (F.pairingPerm ⟨κ.match_ x.val, + mem_flags_of_internalFlags F (κ.match_mem x.val hint)⟩) = + orbitMin x := by + apply orbitMin_eq + exact relPairing_match_sameCycle κ hint + let isOut (g : W.Flag) : Bool := + if hg : g ∈ F.flags then + decide (orbitMin (F.pairingPerm ⟨g, hg⟩) < orbitMin ⟨g, hg⟩) + else false + exact ⟨isOut, + (by + intro g hg + have hgf : g ∈ F.flags := mem_flags_of_internalFlags F hg + simp only [isOut, dite_eq_left hgf, + dite_eq_left (mem_flags_of_internalFlags F (κ.match_mem g hg))] + rw [orbitMin_pairing_match ⟨g, hgf⟩ hg, + orbitMin_match ⟨g, hgf⟩ hg] + exact decide_lt_flip' (Ne.symm (orbitMin_pairing_ne ⟨g, hgf⟩))), + (by + intro g hg _hpg + have hgf : g ∈ F.flags := mem_flags_of_internalFlags F hg + simp only [isOut, dite_eq_left hgf, + dite_eq_left (F.pairing_mem g hgf)] + have hσσ : F.pairingPerm ⟨W.pairing g, F.pairing_mem g hgf⟩ = + ⟨g, hgf⟩ := Subtype.ext (by simp [W.pairing_invol g]) + have hσ_eq : (⟨W.pairing g, F.pairing_mem g hgf⟩ : + {f : W.Flag // f ∈ F.flags}) = F.pairingPerm ⟨g, hgf⟩ := + Subtype.ext (by simp) + rw [hσσ, hσ_eq] + exact decide_lt_flip' (Ne.symm (orbitMin_pairing_ne ⟨g, hgf⟩)))⟩ + +end OrientExist + +/-- **Unconditional canonicity**: every system on every subset has +a path-canonical orientation. -/ +theorem nonempty_canonical_any {β : Type} [LinearOrder β] + {V : Fragment β} {F : EdgeSubset V} + (κ : F.RelTransitionSystem) : + Nonempty {o : κ.Orientation // EdgeSubset.PathCanonical o} := by + obtain ⟨o₂, hc₂⟩ := EdgeSubset.exists_pathCanonical κ + (relBuildOrientation κ) + exact ⟨⟨o₂, hc₂⟩⟩ + +/-! ## The bottom splitting + +With orientation existence, canonical data reduce to bare system +existence, and the pinned term of a disjoint-union subset +factorizes side by side at the restricted systems, the value +product being threaded through the support certificates. -/ + +/-- Canonical data are exactly system existence. -/ +theorem nonempty_canonData_iff_system {β : Type} [LinearOrder β] + {V : Fragment β} (F : EdgeSubset V) : + Nonempty F.CanonData ↔ Nonempty F.RelTransitionSystem := by + constructor + · rintro ⟨⟨κ, -⟩⟩ + exact ⟨κ⟩ + · rintro ⟨κ⟩ + obtain ⟨⟨o, hc⟩⟩ := nonempty_canonical_any κ + exact ⟨⟨κ, o, hc⟩⟩ + +/-! ## The product family + +The tower base as the product of the side-pinned families: the +side restrictions return the side families up to `MatchEq`, so the +bottom of the tower is side-pinned by construction — the +side-pinning covariance dissolves. -/ + +section ProductFamily + +open EdgeSubset + +variable {α β : Type} + +/-- The left support transfer of a join subset. -/ +theorem join_support_left [LinearOrder α] {W₁ : Fragment α} {W₂ : Fragment β} + [instS : LinearOrder (α ⊕ β)] + {s : Finset ((W₁.disjUnion W₂).Flag)} + (hc : ∀ f ∈ s, (W₁.disjUnion W₂).pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) : + ∃ (hcL : ∀ f ∈ leftPart s, W₁.pairing f ∈ leftPart s), + (EdgeSubset.mk (leftPart s) hcL).Eulerian ∧ + Nonempty (EdgeSubset.mk (leftPart s) hcL).CanonData := by + refine ⟨((pairing_closed_iff_parts s).mp hc).1, ?_, ?_⟩ + · exact ((eulerian_iff_parts s hc _ + ((pairing_closed_iff_parts s).mp hc).2).mp hE).1 + · exact (nonempty_canonData_iff_system _).mpr + (((nonempty_canonData_iff_system _).mp hne).map + (fun κ => leftRel κ)) + +/-- The right support transfer of a join subset. -/ +theorem join_support_right [LinearOrder β] {W₁ : Fragment α} {W₂ : Fragment β} + [instS : LinearOrder (α ⊕ β)] + {s : Finset ((W₁.disjUnion W₂).Flag)} + (hc : ∀ f ∈ s, (W₁.disjUnion W₂).pairing f ∈ s) + (hE : (EdgeSubset.mk s hc).Eulerian) + (hne : Nonempty (EdgeSubset.mk s hc).CanonData) : + ∃ (hcR : ∀ f ∈ rightPart s, W₂.pairing f ∈ rightPart s), + (EdgeSubset.mk (rightPart s) hcR).Eulerian ∧ + Nonempty (EdgeSubset.mk (rightPart s) hcR).CanonData := by + refine ⟨((pairing_closed_iff_parts s).mp hc).2, ?_, ?_⟩ + · exact ((eulerian_iff_parts s hc + ((pairing_closed_iff_parts s).mp hc).1 _).mp hE).2 + · exact (nonempty_canonData_iff_system _).mpr + (((nonempty_canonData_iff_system _).mp hne).map + (fun κ => rightRel κ)) + +end ProductFamily + +open EdgeSubset Fragment in +/-- **Canonical data ascend the open glue.** A lift's system glues, +and every system is orientable, so the glued subset carries canonical +data as soon as the lift does. -/ +theorem nonempty_canonData_glueOpen {α : Type} [LinearOrder α] + {W : Fragment α} {i j : α} (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairOpen i j hij hopen).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetOpen hopen s', + W.pairing f ∈ liftSubsetOpen hopen s') + (hne : Nonempty (EdgeSubset.mk (liftSubsetOpen hopen s') + hc : EdgeSubset W).CanonData) : + Nonempty (EdgeSubset.mk s' hc' : EdgeSubset + (W.gluePairOpen i j hij hopen)).CanonData := by + obtain ⟨⟨κ, -⟩⟩ := hne + obtain ⟨⟨o, ho⟩⟩ := nonempty_canonical_any + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + exact ⟨⟨_, o, ho⟩⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientationFlip.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientationFlip.lean new file mode 100644 index 0000000000..330d4a94e6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientationFlip.lean @@ -0,0 +1,888 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexOddSign + +/-! +# Orientation invariance of the constrained summand: circuit flips + +For a *fixed* boundary-relative transition system `κ`, the corrected +constrained summand `throughSummand` is invariant under changing the +orientation, **provided every internal flag on which the two +orientations disagree has an internal pairing partner** — that is, +the difference set is supported on fully internal edges (equivalently, +on closed circuits; flips of path components are excluded). + +## The proof + +The difference set `orientDiff o o'` of two orientations is closed +under the matching (from both `match_flip`s) and — under the +pairing-internality hypothesis — under the edge pairing (from both +`pairing_flip`s). The colouring reindexing `flipColouring` applies +the odd-partner involution `∂` edge-wise on the difference set; it is +an involution of the core odd colourings fixing all boundary flags, +so the odd boundary constraint is preserved. At each vertex the +in-flags under `o'` are the unflipped in-flags under `o` together +with the matches of the flipped ones; each flipped visit contributes +a reversed pair block (one adjacent-swap sign) and trades the sign +factor `∂`-partner-sign of the outgoing colour for that of the +incoming one. The two `(−1)`s per visit cancel, and the leftover +ratio `sign(in) · sign(out)` telescopes over the whole vertex product +to `∏_{f ∈ diff} sign(φ f)`, which is `1` because the difference set +is a disjoint union of full edges and the colouring is +pairing-constant. + +## Why the hypothesis is necessary + +Unrestricted orientation invariance is **false**. Counterexample +(`ℓ = 2`): one vertex `v` with two pendant edges `{f₁, b₁}`, +`{f₂, b₂}` to boundary labels `i₁, i₂`, the matching `f₁ ↔ f₂`, and +odd state colours `st i₁ = 0`, `st i₂ = 1`. The boundary constraint +pins the unique contributing colouring, and the two orientations of +the path give summands proportional to `−h(μ, {0, 3})` and +`−h(μ, {1, 2})` respectively — different for generic `h`. The +per-visit sign ratio `sign(x)·sign(y)` telescopes to `1` only around +closed circuits; on a path it leaves the pinned end-colour signs, and +the `∂`-reindexing moreover violates the pinned boundary values. +Consequently any orientation-independence interface must restrict to +circuit-supported differences (or fix path orientations by +convention). +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} {W : Fragment α} + +namespace EdgeSubset + +section Diff + +variable {F : EdgeSubset W} {κ : F.RelTransitionSystem} + +/-! ## Bool helpers -/ + +private theorem bool_not_inj {a b : Bool} (h : (!a) = (!b)) : a = b := by + cases a <;> cases b <;> simp_all + +/-! ## The difference set of two orientations -/ + +/-- The internal flags on which two orientations of the same relative +transition system disagree. -/ +noncomputable def orientDiff (o o' : κ.Orientation) : Finset W.Flag := + F.internalFlags.filter (fun f => o.isOut f ≠ o'.isOut f) + +/-- Membership in the difference set: an internal flag the two +orientations direct oppositely. -/ +theorem mem_orientDiff {o o' : κ.Orientation} {f : W.Flag} : + f ∈ orientDiff o o' ↔ + f ∈ F.internalFlags ∧ o.isOut f ≠ o'.isOut f := + Finset.mem_filter + +/-- The difference set consists of internal flags. -/ +theorem orientDiff_subset_internal (o o' : κ.Orientation) + {f : W.Flag} (hf : f ∈ orientDiff o o') : f ∈ F.internalFlags := + (mem_orientDiff.mp hf).1 + +/-- Off the difference set, internal flags are oriented identically. -/ +theorem isOut_eq_of_notMem_orientDiff {o o' : κ.Orientation} + {f : W.Flag} (hf : f ∈ F.internalFlags) + (hnot : f ∉ orientDiff o o') : o.isOut f = o'.isOut f := by + by_contra hne + exact hnot (mem_orientDiff.mpr ⟨hf, hne⟩) + +/-- The difference set is closed under the matching. -/ +theorem match_mem_orientDiff {o o' : κ.Orientation} {f : W.Flag} + (hf : f ∈ orientDiff o o') : κ.match_ f ∈ orientDiff o o' := by + obtain ⟨hint, hne⟩ := mem_orientDiff.mp hf + refine mem_orientDiff.mpr ⟨κ.match_mem f hint, ?_⟩ + rw [o.match_flip f hint, o'.match_flip f hint] + exact fun hcon => hne (bool_not_inj hcon) + +/-- The complement of the difference set is closed under the matching +on internal flags. -/ +theorem match_notMem_orientDiff {o o' : κ.Orientation} {f : W.Flag} + (hf : f ∈ F.internalFlags) (hnot : f ∉ orientDiff o o') : + κ.match_ f ∉ orientDiff o o' := by + intro hmem + have h2 := match_mem_orientDiff hmem + rw [κ.match_invol f hf] at h2 + exact hnot h2 + +/-- Under the pairing-internality hypothesis, the difference set is +closed under the edge pairing. -/ +theorem pairing_mem_orientDiff {o o' : κ.Orientation} + (hpair : ∀ f ∈ F.internalFlags, + o.isOut f ≠ o'.isOut f → W.pairing f ∈ F.internalFlags) + {f : W.Flag} (hf : f ∈ orientDiff o o') : + W.pairing f ∈ orientDiff o o' := by + obtain ⟨hint, hne⟩ := mem_orientDiff.mp hf + have hp := hpair f hint hne + refine mem_orientDiff.mpr ⟨hp, ?_⟩ + rw [o.pairing_flip f hint hp, o'.pairing_flip f hint hp] + exact fun hcon => hne (bool_not_inj hcon) + +/-- The complement of the difference set is closed under the pairing. -/ +theorem pairing_notMem_orientDiff {o o' : κ.Orientation} + (hpair : ∀ f ∈ F.internalFlags, + o.isOut f ≠ o'.isOut f → W.pairing f ∈ F.internalFlags) + {f : W.Flag} (hnot : f ∉ orientDiff o o') : + W.pairing f ∉ orientDiff o o' := by + intro hmem + have h2 := pairing_mem_orientDiff hpair hmem + rw [W.pairing_invol] at h2 + exact hnot h2 + +/-- Boundary flags are never in the difference set. -/ +theorem boundaryFlag_notMem_orientDiff (o o' : κ.Orientation) + (i : α) : W.boundaryFlag i ∉ orientDiff o o' := by + intro hmem + obtain ⟨v, hv⟩ := + F.attach_internal_of_mem (orientDiff_subset_internal o o' hmem) + rw [W.attach_boundaryFlag] at hv + cases hv + +/-! ## The colouring reindexing -/ + +/-- The `∂`-flip of a core odd colouring on the edges of the +difference set: the crux bijection for orientation invariance. -/ +noncomputable def flipColouring (o o' : κ.Orientation) + (hpair : ∀ f ∈ F.internalFlags, + o.isOut f ≠ o'.isOut f → W.pairing f ∈ F.internalFlags) + {ℓ : ℕ} (φ : F.CoreOddColouring ℓ) : F.CoreOddColouring ℓ := + ⟨fun g => if g.val ∈ orientDiff o o' then oddPartner ℓ (φ.val g) + else φ.val g, + fun g => by + have hbeta : (if W.pairing g.val ∈ orientDiff o o' then + oddPartner ℓ (φ.val + ⟨W.pairing g.val, F.pairing_mem_coreFlags g.prop⟩) + else φ.val + ⟨W.pairing g.val, F.pairing_mem_coreFlags g.prop⟩) = + (if g.val ∈ orientDiff o o' then oddPartner ℓ (φ.val g) + else φ.val g) := by + by_cases hg : g.val ∈ orientDiff o o' + · rw [ite_eq_left (pairing_mem_orientDiff hpair hg), ite_eq_left hg, + φ.prop g] + · rw [ite_eq_right (pairing_notMem_orientDiff hpair hg), ite_eq_right hg, + φ.prop g] + exact hbeta⟩ + +/-- On the difference set the colouring is `∂`-flipped. -/ +theorem flipColouring_val_of_mem (o o' : κ.Orientation) + (hpair : ∀ f ∈ F.internalFlags, + o.isOut f ≠ o'.isOut f → W.pairing f ∈ F.internalFlags) + {ℓ : ℕ} (φ : F.CoreOddColouring ℓ) + (g : {g : W.Flag // g ∈ F.coreFlags}) + (hg : g.val ∈ orientDiff o o') : + (flipColouring o o' hpair φ).val g = oddPartner ℓ (φ.val g) := + ite_eq_left hg + +/-- Off it the colouring is unchanged. -/ +theorem flipColouring_val_of_notMem (o o' : κ.Orientation) + (hpair : ∀ f ∈ F.internalFlags, + o.isOut f ≠ o'.isOut f → W.pairing f ∈ F.internalFlags) + {ℓ : ℕ} (φ : F.CoreOddColouring ℓ) + (g : {g : W.Flag // g ∈ F.coreFlags}) + (hg : g.val ∉ orientDiff o o') : + (flipColouring o o' hpair φ).val g = φ.val g := + ite_eq_right hg + +/-- The flip negates the incoming sign on the difference set: the +flip colouring is the colour flip on `orientDiff o o'`. -/ +theorem inSign_flipColouring_of_mem (o o' : κ.Orientation) + (hpair : ∀ f ∈ F.internalFlags, + o.isOut f ≠ o'.isOut f → W.pairing f ∈ F.internalFlags) + {ℓ : ℕ} (φ : F.CoreOddColouring ℓ) {g : W.Flag} + (hg : g ∈ orientDiff o o') : + inSign (flipColouring o o' hpair φ) g = -inSign φ g := + inSign_flip_of_mem (S := orientDiff o o') (fun _ => rfl) hg + (F.internalFlags_subset_coreFlags + (orientDiff_subset_internal o o' hg)) + +/-- The flip leaves the incoming sign off the difference set +alone. -/ +theorem inSign_flipColouring_of_notMem (o o' : κ.Orientation) + (hpair : ∀ f ∈ F.internalFlags, + o.isOut f ≠ o'.isOut f → W.pairing f ∈ F.internalFlags) + {ℓ : ℕ} (φ : F.CoreOddColouring ℓ) {g : W.Flag} + (hg : g ∉ orientDiff o o') : + inSign (flipColouring o o' hpair φ) g = inSign φ g := + inSign_flip_of_notMem (S := orientDiff o o') (fun _ => rfl) hg + +/-- The flip is an involution, so it is a bijection of the +colouring sum. -/ +theorem flipColouring_involutive (o o' : κ.Orientation) + (hpair : ∀ f ∈ F.internalFlags, + o.isOut f ≠ o'.isOut f → W.pairing f ∈ F.internalFlags) + {ℓ : ℕ} : + Function.Involutive + (flipColouring o o' hpair (F := F) (ℓ := ℓ)) := by + intro φ + apply Subtype.ext + funext g + change (if g.val ∈ orientDiff o o' then + oddPartner ℓ ((flipColouring o o' hpair φ).val g) + else (flipColouring o o' hpair φ).val g) = φ.val g + by_cases hg : g.val ∈ orientDiff o o' + · rw [ite_eq_left hg, flipColouring_val_of_mem o o' hpair φ g hg, + oddPartner_invol] + · rw [ite_eq_right hg, flipColouring_val_of_notMem o o' hpair φ g hg] + +/-- The reindexing preserves the odd boundary constraint. -/ +theorem coreOddBoundaryMatch_flipColouring {k ℓ : ℕ} + (st : GenBoundaryState k ℓ α) (o o' : κ.Orientation) + (hpair : ∀ f ∈ F.internalFlags, + o.isOut f ≠ o'.isOut f → W.pairing f ∈ F.internalFlags) + (φ : F.CoreOddColouring ℓ) : + F.coreOddBoundaryMatch st (flipColouring o o' hpair φ) ↔ + F.coreOddBoundaryMatch st φ := by + have hval : ∀ (i : α) (hcore : W.boundaryFlag i ∈ F.coreFlags), + (flipColouring o o' hpair φ).val ⟨W.boundaryFlag i, hcore⟩ = + φ.val ⟨W.boundaryFlag i, hcore⟩ := + fun i hcore => flipColouring_val_of_notMem o o' hpair φ _ + (boundaryFlag_notMem_orientDiff o o' i) + unfold coreOddBoundaryMatch + constructor + · intro H i c hst hcore + rw [← hval i hcore] + exact H i c hst hcore + · intro H i c hst hcore + rw [hval i hcore] + exact H i c hst hcore + +/-! ## Vertex-local in-sets -/ + +/-- The in-flags kept fixed by the orientation change. -/ +private noncomputable def keepIn (o o' : κ.Orientation) + (v : W.Vertex) : Finset W.Flag := + (relInSetAt o v).filter (fun g => g ∉ orientDiff o o') + +/-- The in-flags flipped by the orientation change. -/ +private noncomputable def flipIn (o o' : κ.Orientation) + (v : W.Vertex) : Finset W.Flag := + (relInSetAt o v).filter (fun g => g ∈ orientDiff o o') + +private theorem mem_keepIn {o o' : κ.Orientation} {v : W.Vertex} + {g : W.Flag} : + g ∈ keepIn o o' v ↔ g ∈ relInSetAt o v ∧ g ∉ orientDiff o o' := + Finset.mem_filter + +private theorem mem_flipIn {o o' : κ.Orientation} {v : W.Vertex} + {g : W.Flag} : + g ∈ flipIn o o' v ↔ g ∈ relInSetAt o v ∧ g ∈ orientDiff o o' := + Finset.mem_filter + +private theorem inSet_val_eq (o o' : κ.Orientation) (v : W.Vertex) : + (relInSetAt o v).val = + (keepIn o o' v).val + (flipIn o o' v).val := by + unfold keepIn flipIn + rw [Finset.filter_val, Finset.filter_val, add_comm] + exact (Multiset.filter_add_not + (fun g => g ∈ orientDiff o o') (relInSetAt o v).val).symm + +private theorem match_injOn_flipIn (o o' : κ.Orientation) + (v : W.Vertex) : + ∀ x ∈ flipIn o o' v, ∀ y ∈ flipIn o o' v, + κ.match_ x = κ.match_ y → x = y := by + intro x hx y hy hxy + have hxint := relInSetAt_subset_internal (mem_flipIn.mp hx).1 + have hyint := relInSetAt_subset_internal (mem_flipIn.mp hy).1 + calc x = κ.match_ (κ.match_ x) := (κ.match_invol x hxint).symm + _ = κ.match_ (κ.match_ y) := by rw [hxy] + _ = y := κ.match_invol y hyint + +private theorem keepIn_disjoint_image (o o' : κ.Orientation) + (v : W.Vertex) : + Disjoint (keepIn o o' v) ((flipIn o o' v).image κ.match_) := by + rw [Finset.disjoint_left] + intro g hgk hgi + obtain ⟨f, hf, rfl⟩ := Finset.mem_image.mp hgi + exact (mem_keepIn.mp hgk).2 + (match_mem_orientDiff (mem_flipIn.mp hf).2) + +/-- **The in-set identity**: the in-flags under `o'` are the kept +in-flags under `o` together with the matches of the flipped ones. -/ +private theorem inSet_flip_eq (o o' : κ.Orientation) (v : W.Vertex) : + relInSetAt o' v = (keepIn o o' v).disjUnion + ((flipIn o o' v).image κ.match_) + (keepIn_disjoint_image o o' v) := by + apply Finset.ext + intro g + rw [Finset.mem_disjUnion, mem_relInSetAt] + constructor + · rintro ⟨hgfl, hgat, hgout'⟩ + have hgint : g ∈ F.internalFlags := + mem_internalFlags_of hgfl ⟨v, hgat⟩ + by_cases hgD : g ∈ orientDiff o o' + · right + refine Finset.mem_image.mpr + ⟨κ.match_ g, ?_, κ.match_invol g hgint⟩ + have hmD := match_mem_orientDiff hgD + have hmint := κ.match_mem g hgint + have hone : o.isOut g = true := by + have hne := (mem_orientDiff.mp hgD).2 + cases hb : o.isOut g + · exact absurd (hb.trans hgout'.symm) hne + · rfl + refine mem_flipIn.mpr ⟨mem_relInSetAt.mpr + ⟨mem_flags_of_internalFlags F hmint, + κ.match_vertex g hgint v hgat, ?_⟩, hmD⟩ + rw [o.match_flip g hgint, hone] + rfl + · left + refine mem_keepIn.mpr ⟨mem_relInSetAt.mpr ⟨hgfl, hgat, ?_⟩, hgD⟩ + rw [isOut_eq_of_notMem_orientDiff hgint hgD] + exact hgout' + · rintro (hg | hg) + · obtain ⟨hgin, hgD⟩ := mem_keepIn.mp hg + obtain ⟨h1, h2, h3⟩ := mem_relInSetAt.mp hgin + have hgint : g ∈ F.internalFlags := mem_internalFlags_of h1 ⟨v, h2⟩ + refine ⟨h1, h2, ?_⟩ + rw [← isOut_eq_of_notMem_orientDiff hgint hgD] + exact h3 + · obtain ⟨f, hf, rfl⟩ := Finset.mem_image.mp hg + obtain ⟨hfin, hfD⟩ := mem_flipIn.mp hf + obtain ⟨h1, h2, h3⟩ := mem_relInSetAt.mp hfin + have hfint : f ∈ F.internalFlags := mem_internalFlags_of h1 ⟨v, h2⟩ + have hmint := κ.match_mem f hfint + refine ⟨mem_flags_of_internalFlags F hmint, + κ.match_vertex f hfint v h2, ?_⟩ + have hmD := match_mem_orientDiff hfD + have hne := (mem_orientDiff.mp hmD).2 + have ho : o.isOut (κ.match_ f) = true := by + rw [o.match_flip f hfint, h3] + rfl + cases hb : o'.isOut (κ.match_ f) + · rfl + · exact absurd (ho.trans hb.symm) hne + +/-! ## Signs as finset products -/ + +private theorem oddPartnerSign_mul_self (ℓ : ℕ) (c : Fin (2 * ℓ)) : + oddPartnerSign ℓ c * oddPartnerSign ℓ c = 1 := by + unfold oddPartnerSign + by_cases h : c.val < ℓ <;> simp [h] + +private theorem coreOddSignFn_eq {ℓ : ℕ} (φ : F.CoreOddColouring ℓ) + (f : {f : W.Flag // f ∈ F.internalFlags}) : + F.coreOddSignFn κ φ f = inSign φ (κ.match_ f.val) := by + unfold EdgeSubset.coreOddSignFn inSign + rw [dite_eq_left + (F.internalFlags_subset_coreFlags (κ.match_mem _ f.prop))] + +private theorem coreOddSignAt_eq_prod {ℓ : ℕ} (o : κ.Orientation) + (φ : F.CoreOddColouring ℓ) (v : W.Vertex) : + F.coreOddSignAt o φ v = + ∏ g ∈ relInSetAt o v, inSign φ (κ.match_ g) := by + unfold EdgeSubset.coreOddSignAt + rw [attachWith_map_eq (F.coreOddSignFn κ φ) + (fun g => inSign φ (κ.match_ g)) + (fun g hg => coreOddSignFn_eq φ ⟨g, hg⟩) (F.relInFlagsAt o v) _] + exact list_map_prod_eq_finset_prod (relInSetAt o v) _ + (relInFlagsAt_coe o v) _ + +private theorem prod_inSet_split {M : Type*} [CommMonoid M] + (o o' : κ.Orientation) (v : W.Vertex) (f : W.Flag → M) : + ∏ g ∈ relInSetAt o v, f g = + (∏ g ∈ flipIn o o' v, f g) * ∏ g ∈ keepIn o o' v, f g := by + unfold flipIn keepIn + exact (Finset.prod_filter_mul_prod_filter_not (relInSetAt o v) _ f).symm + +/-- **The per-vertex sign identity**: flipping the orientation and +the colouring multiplies the vertex sign by one `−1` per flipped +visit and by the incoming-over-outgoing sign ratio. -/ +private theorem coreOddSignAt_flip {ℓ : ℕ} (o o' : κ.Orientation) + (hpair : ∀ f ∈ F.internalFlags, + o.isOut f ≠ o'.isOut f → W.pairing f ∈ F.internalFlags) + (φ : F.CoreOddColouring ℓ) (v : W.Vertex) : + F.coreOddSignAt o' (flipColouring o o' hpair φ) v = + (-1 : ℤ) ^ (flipIn o o' v).card * + (∏ f ∈ flipIn o o' v, + inSign φ f * inSign φ (κ.match_ f)) * + F.coreOddSignAt o φ v := by + rw [coreOddSignAt_eq_prod o' _ v, coreOddSignAt_eq_prod o φ v] + rw [inSet_flip_eq o o' v, Finset.prod_disjUnion] + have hkeep : ∏ g ∈ keepIn o o' v, + inSign (flipColouring o o' hpair φ) (κ.match_ g) = + ∏ g ∈ keepIn o o' v, inSign φ (κ.match_ g) := by + refine Finset.prod_congr rfl (fun g hg => ?_) + have hgint := relInSetAt_subset_internal (mem_keepIn.mp hg).1 + exact inSign_flipColouring_of_notMem o o' hpair φ + (match_notMem_orientDiff hgint (mem_keepIn.mp hg).2) + have himg : ∏ g ∈ (flipIn o o' v).image κ.match_, + inSign (flipColouring o o' hpair φ) (κ.match_ g) = + ∏ f ∈ flipIn o o' v, -inSign φ f := by + rw [Finset.prod_image (match_injOn_flipIn o o' v)] + refine Finset.prod_congr rfl (fun f hf => ?_) + have hfint := relInSetAt_subset_internal (mem_flipIn.mp hf).1 + rw [κ.match_invol f hfint] + exact inSign_flipColouring_of_mem o o' hpair φ (mem_flipIn.mp hf).2 + rw [hkeep, himg, + prod_inSet_split o o' v (fun g => inSign φ (κ.match_ g)), + Finset.prod_neg] + have hsq : ∏ f ∈ flipIn o o' v, inSign φ f = + (∏ f ∈ flipIn o o' v, + inSign φ f * inSign φ (κ.match_ f)) * + ∏ f ∈ flipIn o o' v, inSign φ (κ.match_ f) := by + rw [← Finset.prod_mul_distrib] + refine Finset.prod_congr rfl (fun f _ => ?_) + rw [mul_assoc, inSign_mul_self, mul_one] + rw [hsq] + ring + +/-! ## The global sign telescopes -/ + +open scoped Classical in +/-- The difference flags attached to a vertex. -/ +private noncomputable def diffAt (o o' : κ.Orientation) + (v : W.Vertex) : Finset W.Flag := + (orientDiff o o').filter (fun g => W.attach g = Sum.inl v) + +private theorem flipIn_disjoint_image (o o' : κ.Orientation) + (v : W.Vertex) : + Disjoint (flipIn o o' v) ((flipIn o o' v).image κ.match_) := by + rw [Finset.disjoint_left] + intro g hgf hgi + obtain ⟨f, hf, rfl⟩ := Finset.mem_image.mp hgi + have hfint := relInSetAt_subset_internal (mem_flipIn.mp hf).1 + have hffalse := (mem_relInSetAt.mp (mem_flipIn.mp hf).1).2.2 + have hmtrue : o.isOut (κ.match_ f) = true := by + rw [o.match_flip f hfint, hffalse] + rfl + have hmfalse := (mem_relInSetAt.mp (mem_flipIn.mp hgf).1).2.2 + rw [hmtrue] at hmfalse + cases hmfalse + +/-- The difference flags at a vertex split into flipped in-flags and +their matches. -/ +private theorem diffAt_eq (o o' : κ.Orientation) (v : W.Vertex) : + diffAt o o' v = (flipIn o o' v).disjUnion + ((flipIn o o' v).image κ.match_) + (flipIn_disjoint_image o o' v) := by + classical + apply Finset.ext + intro g + rw [Finset.mem_disjUnion] + unfold diffAt + rw [Finset.mem_filter] + constructor + · rintro ⟨hgD, hgat⟩ + have hgint := orientDiff_subset_internal o o' hgD + cases hb : o.isOut g + · left + exact mem_flipIn.mpr ⟨mem_relInSetAt.mpr + ⟨mem_flags_of_internalFlags F hgint, hgat, hb⟩, hgD⟩ + · right + refine Finset.mem_image.mpr + ⟨κ.match_ g, ?_, κ.match_invol g hgint⟩ + have hmD := match_mem_orientDiff hgD + have hmint := κ.match_mem g hgint + refine mem_flipIn.mpr ⟨mem_relInSetAt.mpr + ⟨mem_flags_of_internalFlags F hmint, + κ.match_vertex g hgint v hgat, ?_⟩, hmD⟩ + rw [o.match_flip g hgint, hb] + rfl + · rintro (hg | hg) + · exact ⟨(mem_flipIn.mp hg).2, + (mem_relInSetAt.mp (mem_flipIn.mp hg).1).2.1⟩ + · obtain ⟨f, hf, rfl⟩ := Finset.mem_image.mp hg + have hfint := relInSetAt_subset_internal (mem_flipIn.mp hf).1 + exact ⟨match_mem_orientDiff (mem_flipIn.mp hf).2, + κ.match_vertex f hfint v + (mem_relInSetAt.mp (mem_flipIn.mp hf).1).2.1⟩ + +private theorem orientDiff_eq_biUnion (o o' : κ.Orientation) : + orientDiff o o' = + Finset.univ.biUnion (fun v => diffAt o o' v) := by + classical + apply Finset.ext + intro g + rw [Finset.mem_biUnion] + constructor + · intro hg + obtain ⟨v, hv⟩ := + F.attach_internal_of_mem (orientDiff_subset_internal o o' hg) + exact ⟨v, Finset.mem_univ v, Finset.mem_filter.mpr ⟨hg, hv⟩⟩ + · rintro ⟨v, _, hv⟩ + exact (Finset.mem_filter.mp hv).1 + +private theorem diffAt_pairwiseDisjoint (o o' : κ.Orientation) : + Set.PairwiseDisjoint (↑(Finset.univ : Finset W.Vertex)) + (fun v => diffAt o o' v) := by + classical + intro v _ w _ hvw + refine Finset.disjoint_left.mpr (fun g hgv hgw => hvw ?_) + have h1 := (Finset.mem_filter.mp hgv).2 + have h2 := (Finset.mem_filter.mp hgw).2 + rw [h1] at h2 + exact Sum.inl.inj h2 + +/-- **The telescoping identity**: the product over all vertices of +the flipped-visit sign ratios is the product of `sign(φ)` over the +whole difference set, which is `1` edge by edge. -/ +private theorem flipSign_prod_eq_one {ℓ : ℕ} (o o' : κ.Orientation) + (hpair : ∀ f ∈ F.internalFlags, + o.isOut f ≠ o'.isOut f → W.pairing f ∈ F.internalFlags) + (φ : F.CoreOddColouring ℓ) : + ∏ v : W.Vertex, ∏ f ∈ flipIn o o' v, + (inSign φ f * inSign φ (κ.match_ f)) = 1 := by + have hv : ∀ v : W.Vertex, + ∏ f ∈ flipIn o o' v, + (inSign φ f * inSign φ (κ.match_ f)) = + ∏ g ∈ diffAt o o' v, inSign φ g := by + intro v + rw [diffAt_eq o o' v, Finset.prod_disjUnion, + Finset.prod_image (match_injOn_flipIn o o' v), + Finset.prod_mul_distrib] + rw [Finset.prod_congr rfl (fun v _ => hv v), + ← Finset.prod_biUnion (diffAt_pairwiseDisjoint o o'), + ← orientDiff_eq_biUnion o o'] + refine Finset.prod_involution (fun g _ => W.pairing g) ?_ ?_ ?_ ?_ + · intro g hg + have hcore : g ∈ F.coreFlags := + F.internalFlags_subset_coreFlags + (orientDiff_subset_internal o o' hg) + rw [inSign_pairing φ hcore] + exact inSign_mul_self φ g + · exact fun g _ _ => W.pairing_ne g + · exact fun g hg => pairing_mem_orientDiff hpair hg + · exact fun g _ => W.pairing_invol g + +/-! ## The pair-list reindexing -/ + +private theorem coreOddPairFn_eq {ℓ : ℕ} (φ : F.CoreOddColouring ℓ) : + F.coreOddPairFn κ φ = + fun f => [pairA φ f, pairB (κ₀ := κ) φ f] := rfl + +/-- **The per-vertex list identity**: flipping the orientation and +the colouring changes the alternating evaluation by one `−1` per +flipped visit. -/ +private theorem evalOdd_coreOddListAt_flip {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (μ : Multiset (Fin k)) + (o o' : κ.Orientation) + (hpair : ∀ f ∈ F.internalFlags, + o.isOut f ≠ o'.isOut f → W.pairing f ∈ F.internalFlags) + (φ : F.CoreOddColouring ℓ) (v : W.Vertex) : + h.evalOdd μ + (F.coreOddListAt o' (flipColouring o o' hpair φ) v) = + (-1 : ℂ) ^ (flipIn o o' v).card * + h.evalOdd μ (F.coreOddListAt o φ v) := by + have Hk : ∀ g ∈ (keepIn o o' v).toList, g ∈ F.internalFlags := + fun g hg => relInSetAt_subset_internal + (mem_keepIn.mp (Finset.mem_toList.mp hg)).1 + have Hf : ∀ g ∈ (flipIn o o' v).toList, g ∈ F.internalFlags := + fun g hg => relInSetAt_subset_internal + (mem_flipIn.mp (Finset.mem_toList.mp hg)).1 + have H2 : ∀ g ∈ (keepIn o o' v).toList ++ + (flipIn o o' v).toList.map κ.match_, g ∈ F.internalFlags := by + intro g hg + rcases List.mem_append.mp hg with hg | hg + · exact Hk g hg + · obtain ⟨f, hf, rfl⟩ := List.mem_map.mp hg + exact κ.match_mem f (Hf f hf) + have H3 : ∀ g ∈ (keepIn o o' v).toList ++ (flipIn o o' v).toList, + g ∈ F.internalFlags := by + intro g hg + rcases List.mem_append.mp hg with hg | hg + · exact Hk g hg + · exact Hf g hg + -- ═══════ BOTH IN-FLAG ENUMERATIONS, SPLIT BY THE FLIP ═══════ + -- The unflipped in-flags are common to the two orientations; the + -- flipped ones appear under `o'` through the matching. + have hbase : (F.relInFlagsAt o v).Perm + ((keepIn o o' v).toList ++ (flipIn o o' v).toList) := by + rw [← Multiset.coe_eq_coe, relInFlagsAt_coe o v, + ← Multiset.coe_add, Finset.coe_toList, Finset.coe_toList] + exact inSet_val_eq o o' v + have hbase' : (F.relInFlagsAt o' v).Perm + ((keepIn o o' v).toList ++ + (flipIn o o' v).toList.map κ.match_) := by + rw [← Multiset.coe_eq_coe, relInFlagsAt_coe o' v, + ← Multiset.coe_add, Finset.coe_toList, ← Multiset.map_coe, + Finset.coe_toList] + rw [inSet_flip_eq o o' v, Finset.disjUnion_val, + Finset.image_val_of_injOn (fun x hx y hy => + match_injOn_flipIn o o' v x (Finset.mem_coe.mp hx) y + (Finset.mem_coe.mp hy))] + unfold EdgeSubset.coreOddListAt + simp only [List.attachWith] + calc h.evalOdd μ ((List.pmap Subtype.mk (F.relInFlagsAt o' v) + (fun _ hf => F.mem_internal_of_mem_relInFlagsAt hf)).flatMap + (F.coreOddPairFn κ (flipColouring o o' hpair φ))) + = h.evalOdd μ ((List.pmap Subtype.mk + ((keepIn o o' v).toList ++ + (flipIn o o' v).toList.map κ.match_) H2).flatMap + (F.coreOddPairFn κ (flipColouring o o' hpair φ))) := by + have hp := h.evalOdd_flatMap_perm μ + (F.coreOddPairFn κ (flipColouring o o' hpair φ)) + (fun _ => rfl) + (perm_pmap Subtype.mk hbase' + (fun _ hf => F.mem_internal_of_mem_relInFlagsAt hf) H2) + [] + simpa using hp + _ = h.evalOdd μ + ((List.pmap Subtype.mk (keepIn o o' v).toList Hk).flatMap + (F.coreOddPairFn κ φ) ++ + (List.pmap Subtype.mk (flipIn o o' v).toList Hf).flatMap + (fun fs => [pairB (κ₀ := κ) φ fs, pairA φ fs])) := by + rw [List.pmap_append, List.flatMap_append] + refine congrArg (h.evalOdd μ) (congrArg₂ + (fun x y : List (Fin (2 * ℓ)) => x ++ y) ?_ ?_) + · refine pmap_flatMap_congr _ _ _ _ _ _ _ ?_ + intro g hg h₁ h₂ + have hgD : g ∉ orientDiff o o' := + (mem_keepIn.mp (Finset.mem_toList.mp hg)).2 + have hmD : κ.match_ g ∉ orientDiff o o' := + match_notMem_orientDiff h₁ hgD + change [(flipColouring o o' hpair φ).val + ⟨g, F.internalFlags_subset_coreFlags h₁⟩, + oddPartner ℓ ((flipColouring o o' hpair φ).val + ⟨κ.match_ g, F.internalFlags_subset_coreFlags + (κ.match_mem _ h₁)⟩)] = + [φ.val ⟨g, F.internalFlags_subset_coreFlags h₂⟩, + oddPartner ℓ (φ.val ⟨κ.match_ g, + F.internalFlags_subset_coreFlags + (κ.match_mem _ h₂)⟩)] + rw [flipColouring_val_of_notMem o o' hpair φ _ hgD, + flipColouring_val_of_notMem o o' hpair φ _ hmD] + · rw [List.pmap_map] + refine pmap_flatMap_congr _ _ _ _ _ _ _ ?_ + intro f hf h₁ h₂ + have hfD : f ∈ orientDiff o o' := + (mem_flipIn.mp (Finset.mem_toList.mp hf)).2 + have hmD : κ.match_ f ∈ orientDiff o o' := + match_mem_orientDiff hfD + have hsub : (⟨κ.match_ (κ.match_ f), + F.internalFlags_subset_coreFlags + (κ.match_mem _ h₁)⟩ : + {g : W.Flag // g ∈ F.coreFlags}) = + ⟨f, F.internalFlags_subset_coreFlags h₂⟩ := + Subtype.ext (κ.match_invol f h₂) + change [(flipColouring o o' hpair φ).val + ⟨κ.match_ f, F.internalFlags_subset_coreFlags h₁⟩, + oddPartner ℓ ((flipColouring o o' hpair φ).val + ⟨κ.match_ (κ.match_ f), + F.internalFlags_subset_coreFlags + (κ.match_mem _ h₁)⟩)] = + [pairB (κ₀ := κ) φ ⟨f, h₂⟩, pairA φ ⟨f, h₂⟩] + rw [hsub, + flipColouring_val_of_mem o o' hpair φ _ hmD, + flipColouring_val_of_mem o o' hpair φ _ hfD, + oddPartner_invol] + rfl + _ = (-1 : ℂ) ^ (flipIn o o' v).card * h.evalOdd μ + ((List.pmap Subtype.mk (keepIn o o' v).toList Hk).flatMap + (F.coreOddPairFn κ φ) ++ + (List.pmap Subtype.mk (flipIn o o' v).toList Hf).flatMap + (fun fs => [pairA φ fs, pairB (κ₀ := κ) φ fs])) := by + have hrev := evalOdd_flatMap_rev h μ (pairA φ) + (pairB (κ₀ := κ) φ) + (List.pmap Subtype.mk (flipIn o o' v).toList Hf) + ((List.pmap Subtype.mk (keepIn o o' v).toList Hk).flatMap + (F.coreOddPairFn κ φ)) + rw [hrev, List.length_pmap, Finset.length_toList] + _ = (-1 : ℂ) ^ (flipIn o o' v).card * h.evalOdd μ + ((List.pmap Subtype.mk + ((keepIn o o' v).toList ++ (flipIn o o' v).toList) + H3).flatMap (F.coreOddPairFn κ φ)) := by + rw [List.pmap_append, List.flatMap_append] + rw [coreOddPairFn_eq (κ := κ) φ] + _ = (-1 : ℂ) ^ (flipIn o o' v).card * h.evalOdd μ + ((List.pmap Subtype.mk (F.relInFlagsAt o v) + (fun _ hf => + F.mem_internal_of_mem_relInFlagsAt hf)).flatMap + (F.coreOddPairFn κ φ)) := by + have hp := h.evalOdd_flatMap_perm μ (F.coreOddPairFn κ φ) + (fun _ => rfl) + (perm_pmap Subtype.mk hbase.symm H3 + (fun _ hf => F.mem_internal_of_mem_relInFlagsAt hf)) + [] + simp only [List.nil_append] at hp + rw [hp] + +/-! ## Assembly -/ + +/-- **The vertex-product identity**: the full product over vertices +of sign times alternating evaluation is invariant under flipping the +orientation together with the colouring. -/ +private theorem vertexProd_flip {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (o o' : κ.Orientation) + (hpair : ∀ f ∈ F.internalFlags, + o.isOut f ≠ o'.isOut f → W.pairing f ∈ F.internalFlags) + (φ : F.CoreOddColouring ℓ) (μf : W.Vertex → Multiset (Fin k)) : + ∏ v : W.Vertex, + ((F.coreOddSignAt o' (flipColouring o o' hpair φ) v : ℂ) * + h.evalOdd (μf v) + (F.coreOddListAt o' (flipColouring o o' hpair φ) v)) = + ∏ v : W.Vertex, + ((F.coreOddSignAt o φ v : ℂ) * + h.evalOdd (μf v) (F.coreOddListAt o φ v)) := by + have hglobal : ∏ v : W.Vertex, ∏ f ∈ flipIn o o' v, + ((inSign φ f : ℂ) * (inSign φ (κ.match_ f) : ℂ)) = 1 := by + have h1 := flipSign_prod_eq_one o o' hpair φ + have h2 : ((∏ v : W.Vertex, ∏ f ∈ flipIn o o' v, + (inSign φ f * inSign φ (κ.match_ f)) : ℤ) : ℂ) = 1 := by + rw [h1] + norm_num + push_cast at h2 + exact h2 + have hv : ∀ v : W.Vertex, + ((F.coreOddSignAt o' (flipColouring o o' hpair φ) v : ℂ) * + h.evalOdd (μf v) + (F.coreOddListAt o' (flipColouring o o' hpair φ) v)) = + (∏ f ∈ flipIn o o' v, + ((inSign φ f : ℂ) * (inSign φ (κ.match_ f) : ℂ))) * + ((F.coreOddSignAt o φ v : ℂ) * + h.evalOdd (μf v) (F.coreOddListAt o φ v)) := by + intro v + rw [coreOddSignAt_flip o o' hpair φ v, + evalOdd_coreOddListAt_flip h (μf v) o o' hpair φ v] + have hsq : (-1 : ℂ) ^ (flipIn o o' v).card * + (-1 : ℂ) ^ (flipIn o o' v).card = 1 := by + rw [← mul_pow] + norm_num + push_cast + calc ((-1 : ℂ) ^ (flipIn o o' v).card * + (∏ f ∈ flipIn o o' v, + ((inSign φ f : ℂ) * (inSign φ (κ.match_ f) : ℂ))) * + (F.coreOddSignAt o φ v : ℂ)) * + ((-1 : ℂ) ^ (flipIn o o' v).card * + h.evalOdd (μf v) (F.coreOddListAt o φ v)) = + ((-1 : ℂ) ^ (flipIn o o' v).card * + (-1 : ℂ) ^ (flipIn o o' v).card) * + ((∏ f ∈ flipIn o o' v, + ((inSign φ f : ℂ) * (inSign φ (κ.match_ f) : ℂ))) * + ((F.coreOddSignAt o φ v : ℂ) * + h.evalOdd (μf v) (F.coreOddListAt o φ v))) := by + ring + _ = (∏ f ∈ flipIn o o' v, + ((inSign φ f : ℂ) * (inSign φ (κ.match_ f) : ℂ))) * + ((F.coreOddSignAt o φ v : ℂ) * + h.evalOdd (μf v) (F.coreOddListAt o φ v)) := by + rw [hsq, one_mul] + rw [Finset.prod_congr rfl (fun v _ => hv v), + Finset.prod_mul_distrib, hglobal, one_mul] + +open scoped Classical in +/-- **The colouring-sum identity**: the constrained inner sum over +core odd colourings is invariant under the orientation flip. -/ +private theorem phiSum_flip {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) (o o' : κ.Orientation) + (hpair : ∀ f ∈ F.internalFlags, + o.isOut f ≠ o'.isOut f → W.pairing f ∈ F.internalFlags) + (μf : W.Vertex → Multiset (Fin k)) : + ∑ φ : F.CoreOddColouring ℓ, + (if F.coreOddBoundaryMatch st φ then + ∏ v : W.Vertex, ((F.coreOddSignAt o' φ v : ℂ) * + h.evalOdd (μf v) (F.coreOddListAt o' φ v)) + else 0) = + ∑ φ : F.CoreOddColouring ℓ, + (if F.coreOddBoundaryMatch st φ then + ∏ v : W.Vertex, ((F.coreOddSignAt o φ v : ℂ) * + h.evalOdd (μf v) (F.coreOddListAt o φ v)) + else 0) := by + refine ((Equiv.sum_comp (Function.Involutive.toPerm _ + (flipColouring_involutive o o' hpair (ℓ := ℓ))) _).symm).trans + (Finset.sum_congr rfl (fun φ _ => ?_)) + change (if F.coreOddBoundaryMatch st (flipColouring o o' hpair φ) + then ∏ v : W.Vertex, + ((F.coreOddSignAt o' (flipColouring o o' hpair φ) v : ℂ) * + h.evalOdd (μf v) + (F.coreOddListAt o' (flipColouring o o' hpair φ) v)) + else 0) = + (if F.coreOddBoundaryMatch st φ then + ∏ v : W.Vertex, ((F.coreOddSignAt o φ v : ℂ) * + h.evalOdd (μf v) (F.coreOddListAt o φ v)) + else 0) + exact if_congr + (coreOddBoundaryMatch_flipColouring st o o' hpair φ) + (vertexProd_flip h o o' hpair φ μf) rfl + +end Diff + +/-! ## The orientation-invariance theorems -/ + +open Classical in +/-- **Invariance under circuit flips**: for a fixed relative +transition system, +the corrected constrained summand is invariant under changing the +orientation, provided every internal flag on which the orientations +disagree lies on a fully internal edge. (Unrestricted invariance is +false: flipping a boundary-to-boundary path changes the summand — +see the module docstring.) -/ +theorem throughSummand_orientation_invariant [LinearOrder α] + (F : EdgeSubset W) {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ : F.RelTransitionSystem} (o o' : κ.Orientation) + (hpair : ∀ f ∈ F.internalFlags, + o.isOut f ≠ o'.isOut f → W.pairing f ∈ F.internalFlags) + (c : ℕ) : + F.throughSummand h st hbnd o c = + F.throughSummand h st hbnd o' c := by + unfold EdgeSubset.throughSummand + apply congrArg (fun z : ℂ => ((-1 : ℂ) ^ c) * F.throughProduct st * z) + refine Finset.sum_congr rfl (fun ψ _ => ?_) + exact if_congr Iff.rfl + (phiSum_flip h st o o' hpair (F.evenColoursAt ψ)).symm rfl + +end EdgeSubset + +end RS + +-- The counterexample lives outside the `open scoped Classical` +-- region: its concrete finite objects are decided computationally. +namespace RS + +/-! +## Necessity of the hypothesis: a path-flip counterexample + +One vertex with two pendant edges to boundary labels `0 < 1`, the +matching joining the two internal flags, and odd state colours `0` +and `1` (with `ℓ = 2`). The odd boundary constraint pins the unique +contributing colouring; the two orientations of the resulting +boundary-to-boundary path give summands `−1` and `0` for the +functional supported on the colour set `{0, 3}`. +-/ + +section Counterexample + +open EdgeSubset + +-- Deliberately reducible: instance search must see the concrete +-- carrier types (`Fin 4`, `Unit`) of this example object. +/-- One vertex, two pendant edges: flags `0, 1` at the vertex, flags +`2, 3` at boundary labels `0, 1`; edges `{0, 2}` and `{1, 3}`. -/ +@[reducible] private def exFragment : Fragment (Fin 2) where + Flag := Fin 4 + Vertex := Unit + attach := ![Sum.inl (), Sum.inl (), Sum.inr 0, Sum.inr 1] + pairing := ![2, 3, 0, 1] + pairing_invol := by decide + pairing_ne := by decide + boundaryFlag := ![2, 3] + attach_boundaryFlag := by decide + eq_boundaryFlag := by decide + circles := 0 + +/-- The full edge subset. -/ +private noncomputable def exSubset : EdgeSubset exFragment := + ⟨Finset.univ, fun f _ => Finset.mem_univ (exFragment.pairing f)⟩ + +private instance : IsEmpty {f : exFragment.Flag // f ∉ exSubset.flags} := + ⟨fun f => f.prop (Finset.mem_univ f.val)⟩ + +private instance : Subsingleton (exSubset.EvenColouring 0) := + ⟨fun _ _ => Subtype.ext (funext fun f => isEmptyElim f)⟩ + +end Counterexample + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairCloseComm.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairCloseComm.lean new file mode 100644 index 0000000000..b90d5b5104 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairCloseComm.lean @@ -0,0 +1,218 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc + +/-! +# Commutativity of pair closure + +The closed fragment `pairClose F G`, formed by composing +an `(0+t)`- with a `(t+0)`-fragment, is invariant (up to +`Fragment.Equiv`) under swapping `F` and `G`. +-/ + +@[expose] public section + +namespace RS + +namespace Fragment + +/-- Swap the two boundary summands in the comparison of opposite pair closures. -/ +def pairCloseSwapFun (t : ℕ) : + Fin (0 + t) ⊕ Fin (t + 0) → + Fin (0 + t) ⊕ Fin (t + 0) := + Sum.elim + (fun x => Sum.inr (finCongr (by omega) x)) + (fun y => Sum.inl (finCongr (by omega) y)) + +/-- Self-inverse sum-swap equivalence used in the +`pairClose` commutativity proof. -/ +def pairCloseSwap (t : ℕ) : + Fin (0 + t) ⊕ Fin (t + 0) ≃ + Fin (0 + t) ⊕ Fin (t + 0) where + toFun := pairCloseSwapFun t + invFun := pairCloseSwapFun t + left_inv x := by + rcases x with a | b <;> simp [pairCloseSwapFun, finCongr] + right_inv x := by + rcases x with a | b <;> simp [pairCloseSwapFun, finCongr] + +/-- The disjoint-union ambients of `pairClose F G` +and `pairClose G F` are related by `pairCloseSwap`. -/ +noncomputable def pairCloseAmbient + {t : ℕ} (F G : Fragment (Fin t)) : + (disjUnion + (F.relabel (finCongr (by omega : t = 0 + t))) + (G.relabel (finCongr (by omega : t = t + 0))) + ).Equiv + (relabel + (disjUnion + (G.relabel + (finCongr (by omega : t = 0 + t))) + (F.relabel + (finCongr (by omega : t = t + 0)))) + (pairCloseSwap t)) where + flagEquiv := + _root_.Equiv.sumComm F.Flag G.Flag + vertexEquiv := + _root_.Equiv.sumComm F.Vertex G.Vertex + attach_comm f := by + rcases f with g | g + · change (((F.attach g).map id + (finCongr (by omega : t = t + 0))).map + Sum.inr Sum.inr).map + id (pairCloseSwap t) = + (((F.attach g).map id + (finCongr (by omega : t = 0 + t))).map + Sum.inl Sum.inl).map + (_root_.Equiv.sumComm F.Vertex + G.Vertex) id + rcases F.attach g with v | ℓ <;> rfl + · change (((G.attach g).map id + (finCongr (by omega : t = 0 + t))).map + Sum.inl Sum.inl).map + id (pairCloseSwap t) = + (((G.attach g).map id + (finCongr (by omega : t = t + 0))).map + Sum.inr Sum.inr).map + (_root_.Equiv.sumComm F.Vertex + G.Vertex) id + rcases G.attach g with v | ℓ <;> rfl + pairing_comm f := by + rcases f with g | g <;> rfl + circles_eq := by + change F.circles + G.circles = + G.circles + F.circles + omega + +/-- `mapPairs` through `(pairCloseSwap t).symm` on +the interface pairs yields the swap of each pair. -/ +theorem mapPairs_pairCloseSwap_symm (t : ℕ) : + mapPairs (pairCloseSwap t).symm + (interfacePairs 0 t 0) = + (interfacePairs 0 t 0).map Prod.swap := by + simp only [interfacePairs, mapPairs, + List.map_map, List.map_reverse] + refine congrArg List.reverse + (List.map_congr_left fun k _ => ?_) + -- Each pair: (Sum.inl ⟨0+k, _⟩, Sum.inr ⟨k, _⟩) + -- .symm acts as pairCloseSwapFun since self-inverse + change (pairCloseSwapFun t (Sum.inl ⟨0 + k.val, _⟩), + pairCloseSwapFun t (Sum.inr ⟨k.val, _⟩)) = + (Sum.inr ⟨k.val, _⟩, + Sum.inl ⟨0 + k.val, _⟩) + simp only [pairCloseSwapFun, Sum.elim_inl, + Sum.elim_inr] + exact Prod.ext + (congrArg Sum.inr (Fin.ext (by simp))) + (congrArg Sum.inl (Fin.ext (by simp))) + +/-- Composing `pairClose F G` and `pairClose G F` +yields equivalent closed fragments. -/ +noncomputable def pairCloseComm {t : ℕ} + (F G : Fragment (Fin t)) : + (pairClose F G).Equiv (pairClose G F) := by + -- Abbreviations + set fc₁ := finCongr (show t = 0 + t by omega) + set fc₂ := finCongr (show t = t + 0 by omega) + set A_FG := disjUnion (F.relabel fc₁) + (G.relabel fc₂) + set A_GF := disjUnion (G.relabel fc₁) + (F.relabel fc₂) + set e := pairCloseSwap t + set ips := interfacePairs 0 t 0 + set wf := interfacePairs_wf 0 t 0 + set survE := + (interfaceSurvEquiv 0 t 0).trans + finSumFinEquiv + -- Normal forms via composeNormal + have nFG := composeNormal (F.relabel fc₁) + (G.relabel fc₂) + have nGF := composeNormal (G.relabel fc₁) + (F.relabel fc₂) + -- The ambient fragments are related + have amb := pairCloseAmbient F G + -- glueList respects the ambient equiv + have gc := glueListCongr amb ips wf + -- Pull relabel through glueList + set mips := mapPairs e.symm ips + have wf_m : PairsWF mips := + mapPairs_wf e.symm ips wf + have hcancel : mapPairs e mips = ips := + mapPairs_symm_cancel e ips + -- glueListEqEquiv bridges pair lists + have eq1 := + (glueListEqEquiv (A_GF.relabel e) + hcancel (mapPairs_wf e mips wf_m) wf + (hcancel ▸ List.Perm.refl _)).symm + -- glueListRelabel pulls e through + have rl := glueListRelabel A_GF e mips wf_m + -- mips = ips.map Prod.swap + have hswap : mips = ips.map Prod.swap := by + exact mapPairs_pairCloseSwap_symm t + have wf_sw := swapPairs_wf ips wf + -- Bridge mips to ips.map Prod.swap + have eq2 := glueListEqEquiv A_GF hswap + wf_m wf_sw (hswap ▸ List.Perm.refl _) + -- glueListSwap + have sw := glueListSwap A_GF ips wf + -- The surviving label type is empty + have hempty : + IsEmpty (FoldSurviving + (Fin (0 + t) ⊕ Fin (t + 0)) ips) := by + have h0 : IsEmpty (Fin 0 ⊕ Fin 0) := + isEmpty_sum.mpr ⟨Fin.isEmpty, Fin.isEmpty⟩ + exact ⟨fun x => h0.false + ((interfaceSurvEquiv 0 t 0) x)⟩ + -- Build the chain at glueList level: + -- GL(A_FG) ≡ GL(A_GF.relabel e) [gc] + -- ≡ GL(A_GF.relabel e, mapPairs e mips).relabel + -- fSPE₁ [eq1] + -- ≡ (GL(A_GF, mips).relabel fSME).relabel + -- fSPE₁ [rl] + -- ≡ GL(A_GF, mips).relabel (fSME.trans fSPE₁) + -- [relabelTrans] + -- ≡ (GL(A_GF, ips.map swap).relabel + -- fSPE₂.symm).relabel (fSME.trans fSPE₁) + -- [relabelFlip eq2.symm] + -- ≡ GL(A_GF, ips.map swap).relabel _ + -- [relabelTrans] + -- ≡ (GL(A_GF, ips).relabel + -- (swapFoldEquiv ips).symm).relabel _ + -- [sw] + -- ≡ GL(A_GF, ips).relabel e_mid + -- [relabelTrans] + have chain := + gc.trans (eq1.trans + ((Equiv.relabelCongr rl _).trans + ((Equiv.relabelTrans _ _ _).trans + ((Equiv.relabelCongr + (Equiv.relabelFlip eq2.symm) _).trans + ((Equiv.relabelTrans _ _ _).trans + ((Equiv.relabelCongr sw _).trans + (Equiv.relabelTrans _ _ _))))))) + -- chain : GL(A_FG, ips) ≡ GL(A_GF, ips).relabel + -- e_mid + -- Lift to the survE level + have lifted := + (Equiv.relabelCongr chain survE).trans + (Equiv.relabelTrans _ _ _) + -- lifted : GL(A_FG).relabel survE ≡ + -- GL(A_GF).relabel (e_mid.trans survE) + -- Since source is empty, e_mid.trans survE = survE + have bridge : + ((glueList A_FG ips wf).relabel survE).Equiv + ((glueList A_GF ips wf).relabel survE) := + lifted.trans + (Equiv.relabelEq _ (_root_.Equiv.ext + fun x => False.elim (hempty.false x))) + exact nFG.trans (bridge.trans nGF.symm) + +end Fragment + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairedAssembly.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairedAssembly.lean new file mode 100644 index 0000000000..eb361bdaf2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairedAssembly.lean @@ -0,0 +1,2229 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatusNonsep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FourLabelParity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignForm + +/-! +# The paired assembly: `PairedLedgerUnsigned` + +The final assembly of Proposition 3's paired step. Along any +π-returning repair block, the canonical route accumulates a state +relabel and a sign; this file pins both. + +**The state**: the accumulated relabel set is the +status difference `statusDiff` of the endpoint systems — per step +the relabel pairs are exactly the labels whose high-status changed +(`antiLow_labels_eq_statusChange` for separated steps, +`nonsep_labels_eq_statusChange` for non-separated ones), and the +status difference telescopes (`statusDiff_trans`) to `∅` at the +π-returning endpoint (`statusDiff_of_samePairing`). + +**The sign**: the accumulated sign is carried as +`(−1)^tp · flipSignProd g T` — one `−1` per two-path step, and the +port-sign product of the full flip list `T` at the evolving +colours. At the endpoint the flip list has all label counts even +(its parity fold is the empty status difference), so +`flipSignProd_of_even` evaluates the product to `(−1)^{T.length}`; +the per-step parity identity `tp_k + |T_k| ≡ Δcc_k (mod 2)` — the +four-label parity lemmas fed by the exact per-step flip counts — +telescopes the exponent against the chord-crossing counts, which +return with the pairing. Hence the total sign is `+1`. + +Main results: `chainStatusLedger` (the enriched chain induction), +`stepStatusLedger` (the per-step composed ledger), +`pairedLedgerUnsigned`, and `pairedLedger`. +-/ + +@[expose] public section + +namespace RS + + + +/-! ## Flip-sign list algebra -/ + +section SignAlgebra + +variable {α : Type} {ℓ : ℕ} + +/-- The flip-sign product is involutive: each factor is `±1`. -/ +theorem flipSignProd_mul_self (f : α → Fin (2 * ℓ)) + (L : List (α × α)) : + flipSignProd f L * flipSignProd f L = 1 := by + induction L generalizing f with + | nil => + rw [flipSignProd_nil, one_mul] + | cons p L ih => + rw [flipSignProd_cons] + have h1 := oddPartnerSign_mul_self ℓ (f p.1) + have h2 := oddPartnerSign_mul_self ℓ (f p.2) + have h3 := ih (flipColours f p) + calc (oddPartnerSign ℓ (f p.1) * oddPartnerSign ℓ (f p.2) * + flipSignProd (flipColours f p) L) * + (oddPartnerSign ℓ (f p.1) * oddPartnerSign ℓ (f p.2) * + flipSignProd (flipColours f p) L) + = (oddPartnerSign ℓ (f p.1) * oddPartnerSign ℓ (f p.1)) * + ((oddPartnerSign ℓ (f p.2) * oddPartnerSign ℓ (f p.2)) * + (flipSignProd (flipColours f p) L * + flipSignProd (flipColours f p) L)) := by ring + _ = 1 := by rw [h1, h2, h3, one_mul, one_mul] + +/-- The accumulated colour relabel of a flip sequence. -/ +noncomputable def flipColoursFold (f : α → Fin (2 * ℓ)) + (L : List (α × α)) : α → Fin (2 * ℓ) := + L.foldl flipColours f + +/-- The empty flip sequence leaves the colours alone. -/ +theorem flipColoursFold_nil (f : α → Fin (2 * ℓ)) : + flipColoursFold f [] = f := rfl + +/-- One more flip moves its two labels' colours, then continues. -/ +theorem flipColoursFold_cons (f : α → Fin (2 * ℓ)) (p : α × α) + (L : List (α × α)) : + flipColoursFold f (p :: L) = + flipColoursFold (flipColours f p) L := rfl + +/-- The flip-sign product splits along an append, the second block +evaluated at the accumulated colours of the first. -/ +theorem flipSignProd_append (f : α → Fin (2 * ℓ)) + (L₁ L₂ : List (α × α)) : + flipSignProd f (L₁ ++ L₂) = + flipSignProd f L₁ * + flipSignProd (flipColoursFold f L₁) L₂ := by + induction L₁ generalizing f with + | nil => + rw [List.nil_append, flipSignProd_nil, one_mul, + flipColoursFold_nil] + | cons p L ih => + rw [List.cons_append, flipSignProd_cons, flipSignProd_cons, + ih (flipColours f p), flipColoursFold_cons] + ring + +open scoped Classical in +private theorem flipLabels_count_cons (p : α × α) + (L : List (α × α)) (i : α) : + (flipLabels (p :: L)).count i = + (flipLabels L).count i + (if i = p.1 then 1 else 0) + + (if i = p.2 then 1 else 0) := by + have hbase : (flipLabels (p :: L)).count i = + ((flipLabels L).count i + if p.2 = i then 1 else 0) + + if p.1 = i then 1 else 0 := by + simp only [flipLabels_cons, List.count_cons, beq_iff_eq] + rw [hbase] + by_cases h1 : i = p.1 <;> by_cases h2 : i = p.2 + · rw [ite_eq_left h1.symm, ite_eq_left h2.symm, ite_eq_left h1, ite_eq_left h2] + · rw [ite_eq_right (fun h => h2 h.symm), ite_eq_left h1.symm, ite_eq_left h1, + ite_eq_right h2] + · rw [ite_eq_left h2.symm, ite_eq_right (fun h => h1 h.symm), ite_eq_right h1, + ite_eq_left h2] + · rw [ite_eq_right (fun h => h2 h.symm), ite_eq_right (fun h => h1 h.symm), + ite_eq_right h1, ite_eq_right h2] + +/-- The odd-count set of a cons toggles exactly at the head's +labels. -/ +private theorem mem_oddCountLabels_cons {p : α × α} + (hp : p.1 ≠ p.2) {L : List (α × α)} {i : α} : + i ∈ oddCountLabels (p :: L) ↔ + (((i = p.1 ∨ i = p.2) ∧ i ∉ oddCountLabels L) ∨ + (i ∈ oddCountLabels L ∧ ¬(i = p.1 ∨ i = p.2))) := by + simp only [mem_oddCountLabels, flipLabels_count_cons p L i] + by_cases h1 : i = p.1 <;> by_cases h2 : i = p.2 + · exact absurd (h1.symm.trans h2) hp + · rw [ite_eq_left h1, ite_eq_right h2] + have hm : i = p.1 ∨ i = p.2 := Or.inl h1 + constructor + · intro h + exact Or.inl ⟨hm, by omega⟩ + · rintro (⟨-, hodd⟩ | ⟨-, hnot⟩) + · omega + · exact absurd hm hnot + · rw [ite_eq_right h1, ite_eq_left h2] + have hm : i = p.1 ∨ i = p.2 := Or.inr h2 + constructor + · intro h + exact Or.inl ⟨hm, by omega⟩ + · rintro (⟨-, hodd⟩ | ⟨-, hnot⟩) + · omega + · exact absurd hm hnot + · rw [ite_eq_right h1, ite_eq_right h2] + have hm : ¬(i = p.1 ∨ i = p.2) := by + rintro (h | h) + · exact h1 h + · exact h2 h + constructor + · intro h + exact Or.inr ⟨by omega, hm⟩ + · rintro (⟨hor, -⟩ | ⟨hodd, -⟩) + · exact absurd hor hm + · omega + +/-- For pairs with distinct components the symmetric-difference +fold is the odd-count set. -/ +theorem pairFold_eq_oddCountLabels {L : List (α × α)} + (hd : ∀ p ∈ L, p.1 ≠ p.2) : + pairFold L = oddCountLabels L := by + induction L with + | nil => + rw [pairFold_nil] + refine (Finset.eq_empty_of_forall_notMem fun i hi => ?_).symm + rw [mem_oddCountLabels] at hi + simp [flipLabels_nil] at hi + | cons p L ih => + have hp := hd p List.mem_cons_self + have hd' : ∀ q ∈ L, q.1 ≠ q.2 := fun q hq => + hd q (List.mem_cons_of_mem p hq) + rw [pairFold_cons, ih hd'] + apply Finset.ext + intro i + rw [mem_symmU, mem_oddCountLabels_cons hp] + simp only [mem_pairSet] + +open scoped Classical in +/-- The accumulated colour relabel is the odd-partner relabel at +the odd-count labels. -/ +theorem flipColoursFold_apply {L : List (α × α)} + (hd : ∀ p ∈ L, p.1 ≠ p.2) (f : α → Fin (2 * ℓ)) (i : α) : + flipColoursFold f L i = + if i ∈ oddCountLabels L then oddPartner ℓ (f i) else f i := by + induction L generalizing f with + | nil => + rw [flipColoursFold_nil, ite_eq_right (fun h => by + rw [mem_oddCountLabels] at h + simp [flipLabels_nil] at h)] + | cons p L ih => + have hp := hd p List.mem_cons_self + have hd' : ∀ q ∈ L, q.1 ≠ q.2 := fun q hq => + hd q (List.mem_cons_of_mem p hq) + rw [flipColoursFold_cons, ih hd' (flipColours f p)] + by_cases hm : i = p.1 ∨ i = p.2 + · have hfc : flipColours f p i = oddPartner ℓ (f i) := by + unfold flipColours + rw [ite_eq_left hm] + by_cases ho : i ∈ oddCountLabels L + · have hnot : i ∉ oddCountLabels (p :: L) := by + rw [mem_oddCountLabels_cons hp] + rintro (⟨-, h⟩ | ⟨-, h⟩) + · exact h ho + · exact h hm + rw [ite_eq_left ho, hfc, oddPartner_invol, ite_eq_right hnot] + · have hyes : i ∈ oddCountLabels (p :: L) := + (mem_oddCountLabels_cons hp).mpr (Or.inl ⟨hm, ho⟩) + rw [ite_eq_right ho, hfc, ite_eq_left hyes] + · have hfc : flipColours f p i = f i := by + unfold flipColours + rw [ite_eq_right hm] + by_cases ho : i ∈ oddCountLabels L + · have hyes : i ∈ oddCountLabels (p :: L) := + (mem_oddCountLabels_cons hp).mpr (Or.inr ⟨ho, hm⟩) + rw [ite_eq_left ho, hfc, ite_eq_left hyes] + · have hnot : i ∉ oddCountLabels (p :: L) := by + rw [mem_oddCountLabels_cons hp] + rintro (⟨h, -⟩ | ⟨h, -⟩) + · exact hm h + · exact ho h + rw [ite_eq_right ho, hfc, ite_eq_right hnot] + +end SignAlgebra + +/-! ## Indicator and crossing-symmetry helpers -/ + +section Indicators + +variable {β : Type} + +open scoped Classical in +/-- The cardinality of a subset of an explicit finset as an +indicator sum. -/ +private theorem card_eq_sum_indicator {s t : Finset β} + (h : s ⊆ t) : + s.card = ∑ z ∈ t, if z ∈ s then 1 else 0 := by + have he : t.filter (fun z => z ∈ s) = s := by + apply Finset.ext + intro z + rw [Finset.mem_filter] + exact ⟨fun hz => hz.2, fun hz => ⟨h hz, hz⟩⟩ + calc s.card = (t.filter (fun z => z ∈ s)).card := by rw [he] + _ = ∑ z ∈ t, if z ∈ s then 1 else 0 := by + rw [Finset.card_filter] + +end Indicators + +section OrderIndicators + +variable {α : Type} + +/-- Two membership indicators of one new chord combine into the +low-end indicator gated by the label comparison. -/ +private theorem two_indicator_if [LinearOrder α] + {x y : α} (hxy : x ≠ y) + (P Q : Prop) [Decidable P] [Decidable Q] : + ((if x < y ∧ P then 1 else 0) + + (if y < x ∧ Q then 1 else 0) : ℕ) = + if (if x < y then P else Q) then 1 else 0 := by + rcases lt_or_gt_of_ne hxy with h | h + · have e2 : (if y < x ∧ Q then 1 else 0 : ℕ) = 0 := + ite_eq_right (fun hc => lt_asymm h hc.1) + have hcond : (if x < y then P else Q) ↔ P := by + rw [ite_eq_left h] + rw [e2, add_zero, if_congr (and_iff_right h) rfl rfl, + if_congr hcond rfl rfl] + · have e1 : (if x < y ∧ P then 1 else 0 : ℕ) = 0 := + ite_eq_right (fun hc => lt_asymm h hc.1) + have hcond : (if x < y then P else Q) ↔ Q := by + rw [ite_eq_right (lt_asymm h)] + rw [e1, zero_add, if_congr (and_iff_right h) rfl rfl, + if_congr hcond rfl rfl] + +/-- Exactly one of the two strict comparisons of distinct elements +holds. -/ +private theorem indicator_pair_one [LinearOrder α] + {x y : α} (hxy : x ≠ y) : + ((if x < y then 1 else 0) + (if y < x then 1 else 0) : ℕ) = + 1 := by + rcases lt_or_gt_of_ne hxy with h | h + · rw [ite_eq_left h, ite_eq_right (lt_asymm h)] + · rw [ite_eq_right (lt_asymm h), ite_eq_left h] + +/-- The symmetrized chord crossing is symmetric in its two +arguments. -/ +private theorem chordPairCrossSym_comm [LinearOrder α] + (p q : α × α) : + chordPairCrossSym p q ↔ chordPairCrossSym q p := + Or.comm + +/-- The symmetrized chord crossing ignores the internal order of +each recorded pair. -/ +private theorem chordPairCrossSym_swap_pair [LinearOrder α] + (a₁ a₂ b₁ b₂ : α) : + chordPairCrossSym (a₂, a₁) (b₂, b₁) ↔ + chordPairCrossSym (a₁, a₂) (b₁, b₂) := by + change (ChordPairCross (min a₂ a₁) (max a₂ a₁) (min b₂ b₁) + (max b₂ b₁) ∨ + ChordPairCross (min b₂ b₁) (max b₂ b₁) (min a₂ a₁) + (max a₂ a₁)) ↔ + (ChordPairCross (min a₁ a₂) (max a₁ a₂) (min b₁ b₂) + (max b₁ b₂) ∨ + ChordPairCross (min b₁ b₂) (max b₁ b₂) (min a₁ a₂) + (max a₁ a₂)) + rw [min_comm a₂ a₁, max_comm a₂ a₁, min_comm b₂ b₁, + max_comm b₂ b₁] + +end OrderIndicators + +/-! ## Status-difference membership and transport -/ + +namespace EdgeSubset + +variable {α : Type} + +/-- A matching equality induces the same boundary pairing. -/ +private theorem samePairing_of_matchEq {W : Fragment α} {F : EdgeSubset W} + {κ₁ κ₂ : F.RelTransitionSystem} (heq : κ₁.MatchEq κ₂) : + SamePairing κ₁ κ₂ := + fun _ hδ => (pathMatch_matchEq heq hδ).symm + +private theorem statusMembership_iff (p q : Prop) : + ((p ∧ ¬ q) ∨ (q ∧ ¬ p)) ↔ q ≠ p := by + rw [prop_ne_iff] + tauto + +/-- Membership in the status difference is the status change. -/ +private theorem mem_statusDiff + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ κ' : F.RelTransitionSystem} + {i : α} : + i ∈ statusDiff κ κ' ↔ + ((i ∈ highSet κ') ≠ (i ∈ highSet κ)) := by + exact mem_symmU.trans (statusMembership_iff _ _) + +/-- Status differences transport across matching equality on the +right. -/ +private theorem statusDiff_matchEq_right + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ₁ κ₂ κ₂' : F.RelTransitionSystem} (heq : κ₂.MatchEq κ₂') : + statusDiff κ₁ κ₂ = statusDiff κ₁ κ₂' := by + unfold statusDiff + rw [highSet_of_samePairing (samePairing_of_matchEq heq)] + +/-- **A re-partnered end participates**: if the path match of a +boundary flag differs between two systems, its entry edge is +internal — a boundary-paired end has the same (pairing-determined) +path match in every system. -/ +theorem repartner_internal {W : Fragment α} {F : EdgeSubset W} + {κ κ' : F.RelTransitionSystem} + {ε : W.Flag} (hε : ε ∈ F.boundaryFlags) + (hch : κ'.pathMatch ε hε ≠ κ.pathMatch ε hε) : + W.pairing ε ∈ F.internalFlags := by + rcases F.mem_internalFlags_or_boundaryFlags + (F.pairing_mem ε (mem_flags_of_boundaryFlags F hε)) with + h | h + · exact h + · exact absurd ((κ'.pathMatch_eq_pairing hε h).trans + (κ.pathMatch_eq_pairing hε h).symm) hch + +end EdgeSubset + +/-! ## Colour functions matching a state -/ + +section StateColours + +variable {k ℓ : ℕ} {α : Type} + +/-- One flip: the flipped colour function matches the flipped +state. -/ +private theorem flipColours_matches {st : GenBoundaryState k ℓ α} + {g : α → Fin (2 * ℓ)} + (hg : ∀ i c, st i = Sum.inr c → g i = c) (l₁ l₂ : α) : + ∀ i c, stateOddFlip st l₁ l₂ i = Sum.inr c → + flipColours g (l₁, l₂) i = c := by + intro i c hic + by_cases hm : i = l₁ ∨ i = l₂ + · have hst : stateOddFlip st l₁ l₂ i = + Sum.map id (oddPartner ℓ) (st i) := by + rcases hm with rfl | rfl + · exact stateOddFlip_left + · exact stateOddFlip_right + rw [hst] at hic + have hfc : flipColours g (l₁, l₂) i = oddPartner ℓ (g i) := by + unfold flipColours + rw [ite_eq_left hm] + rcases hval : st i with a | c₀ + · rw [hval] at hic + simp only [Sum.map_inl] at hic + simp at hic + · rw [hval] at hic + simp only [Sum.map_inr] at hic + rw [hfc, hg i c₀ hval] + exact Sum.inr.inj hic + · have hst : stateOddFlip st l₁ l₂ i = st i := + stateOddFlip_of_ne (fun h => hm (Or.inl h)) + (fun h => hm (Or.inr h)) + have hfc : flipColours g (l₁, l₂) i = g i := by + unfold flipColours + rw [ite_eq_right hm] + rw [hst] at hic + rw [hfc] + exact hg i c hic + +/-- The accumulated colour relabel matches the accumulated state +relabel. -/ +private theorem flipColoursFold_matches + {st : GenBoundaryState k ℓ α} {g : α → Fin (2 * ℓ)} + (hg : ∀ i c, st i = Sum.inr c → g i = c) + {T : List (α × α)} (hd : ∀ p ∈ T, p.1 ≠ p.2) : + ∀ i c, stateOddFlipSet st (pairFold T) i = Sum.inr c → + flipColoursFold g T i = c := by + intro i c hic + rw [flipColoursFold_apply hd g i, ← pairFold_eq_oddCountLabels hd] + by_cases hm : i ∈ pairFold T + · rw [stateOddFlipSet_of_mem hm] at hic + rw [ite_eq_left hm] + rcases hval : st i with a | c₀ + · rw [hval] at hic + simp only [Sum.map_inl] at hic + simp at hic + · rw [hval] at hic + simp only [Sum.map_inr] at hic + rw [hg i c₀ hval] + exact Sum.inr.inj hic + · rw [stateOddFlipSet_of_notMem hm] at hic + rw [ite_eq_right hm] + exact hg i c hic + +end StateColours + +/-! ## The signed full re-canonicalization -/ + +namespace EdgeSubset + +variable {α : Type} + +section RecanonSigned + +/-- **Sign-explicit full re-canonicalization**: as +`exists_recanonicalize_sets`, but with the accumulated sign pinned +as the flip-sign product `flipSignProd g L` of the flip list at +any colour function `g` matching the state. -/ +theorem exists_recanonicalize_signed + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {k : ℕ} {ℓ : ℕ} + (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (o : κ.Orientation) (g : α → Fin (2 * ℓ)) + (hg : ∀ i c, st i = Sum.inr c → g i = c) : + ∃ (o₁ : κ.Orientation) (L : List (α × α)), + PathCanonical o₁ ∧ + L.length = (antiLowSet o).card ∧ + L.Pairwise PairDisjoint ∧ + (∀ p ∈ L, AntiLowPair o p) ∧ + ∀ n, F.throughSummand hM st hbnd o n = + ((flipSignProd g L : ℤ) : ℂ) * + F.throughSummand hM (stateOddFlipSet st (pairFold L)) + (genBoundarySubsetMatches_stateOddFlipSet hbnd + (pairFold L)) o₁ n := by + suffices H : ∀ (N : ℕ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (g : α → Fin (2 * ℓ)) + (hg : ∀ i c, st i = Sum.inr c → g i = c) + (o : κ.Orientation), (antiLowSet o).card = N → + ∃ (o₁ : κ.Orientation) (L : List (α × α)), + PathCanonical o₁ ∧ L.length = N ∧ + L.Pairwise PairDisjoint ∧ + (∀ p ∈ L, AntiLowPair o p) ∧ + ∀ n, F.throughSummand hM st hbnd o n = + ((flipSignProd g L : ℤ) : ℂ) * + F.throughSummand hM (stateOddFlipSet st (pairFold L)) + (genBoundarySubsetMatches_stateOddFlipSet hbnd + (pairFold L)) o₁ n by + obtain ⟨o₁, L, h1, h2, h3, h4, h5⟩ := H _ st hbnd g hg o rfl + exact ⟨o₁, L, h1, h2.trans rfl, h3, h4, h5⟩ + -- ═══════ INDUCTION ON THE ANTI-CANONICAL COUNT ═══════ + -- Zero anti-canonical chains means the frame is already + -- canonical; each step flips one chain and drops the count. + intro N + induction N with + | zero => + intro st hbnd g hg o hcard + refine ⟨o, [], ?_, rfl, List.Pairwise.nil, ?_, ?_⟩ + · rw [pathCanonical_iff_antiLowSet_empty] + exact Finset.card_eq_zero.mp hcard + · intro p hp + cases hp + · intro n + rw [flipSignProd_nil, Int.cast_one, one_mul, pairFold_nil] + exact (F.throughSummand_state_congr hM stateOddFlipSet_empty + (genBoundarySubsetMatches_stateOddFlipSet hbnd ∅) hbnd + o n).symm + | succ N ih => + intro st hbnd g hg o hcard + have hne : (antiLowSet o).Nonempty := by + rw [← Finset.card_pos, hcard] + omega + obtain ⟨β, hβmem⟩ := hne + obtain ⟨hβ, hint, hlow, hdir⟩ := mem_antiLowSet.mp hβmem + obtain ⟨c₁, hcol₁⟩ : + ∃ c, st (F.boundaryLabel hβ) = Sum.inr c := by + apply (hbnd _).mp + have he : W.boundaryFlag (F.boundaryLabel hβ) = β := + (W.eq_boundaryFlag _ β (attach_boundaryLabel hβ)).symm + rw [he] + exact mem_flags_of_boundaryFlags F hβ + obtain ⟨c₂, hcol₂⟩ : + ∃ c, st (F.boundaryLabel (κ.pathMatch_mem hβ)) = + Sum.inr c := by + apply (hbnd _).mp + have he : W.boundaryFlag + (F.boundaryLabel (κ.pathMatch_mem hβ)) = + κ.pathMatch β hβ := + (W.eq_boundaryFlag _ _ + (attach_boundaryLabel (κ.pathMatch_mem hβ))).symm + rw [he] + exact mem_flags_of_boundaryFlags F (κ.pathMatch_mem hβ) + obtain ⟨o₁, hd₁, hd₂, hpres, hled⟩ := + exists_chainRecanonicalize hM st hbnd o hβ hint hcol₁ hcol₂ + have hset : antiLowSet o₁ = (antiLowSet o).erase β := + antiLowSet_flip hβ hβmem hd₁ hpres + have hcard₁ : (antiLowSet o₁).card = N := by + rw [hset, Finset.card_erase_of_mem hβmem, hcard] + omega + have hsub : antiLowSet o₁ ⊆ antiLowSet o := by + intro x hx + rw [hset] at hx + exact Finset.mem_of_mem_erase hx + obtain ⟨o₂, L', hcanon, hlen', hpw', hprov', hled₂⟩ := + ih (stateOddFlip st (F.boundaryLabel hβ) + (F.boundaryLabel (κ.pathMatch_mem hβ))) + (genBoundarySubsetMatches_stateOddFlip hbnd + (F.boundaryLabel hβ) + (F.boundaryLabel (κ.pathMatch_mem hβ))) + (flipColours g (F.boundaryLabel hβ, + F.boundaryLabel (κ.pathMatch_mem hβ))) + (flipColours_matches hg _ _) o₁ hcard₁ + have hstEq : stateOddFlipSet + (stateOddFlip st (F.boundaryLabel hβ) + (F.boundaryLabel (κ.pathMatch_mem hβ))) (pairFold L') = + stateOddFlipSet st + (pairFold ((F.boundaryLabel hβ, + F.boundaryLabel (κ.pathMatch_mem hβ)) :: L')) := by + rw [stateOddFlip_eq_flipSet, stateOddFlipSet_symmU, + pairFold_cons] + rfl + have hpd : ∀ q ∈ L', PairDisjoint + (F.boundaryLabel hβ, + F.boundaryLabel (κ.pathMatch_mem hβ)) q := by + intro q hq + obtain ⟨γ, hγ, hγm, hq1, hq2⟩ := hprov' q hq + rw [hset] at hγm + obtain ⟨hγβ, hγmo⟩ := Finset.mem_erase.mp hγm + have hd := antiLowPair_disjoint hβ hγ hβmem hγmo + (Ne.symm hγβ) + refine ⟨?_, ?_, ?_, ?_⟩ + · rw [hq1] + exact hd.fst_ne_fst + · rw [hq2] + exact hd.fst_ne_snd + · rw [hq1] + exact hd.snd_ne_fst + · rw [hq2] + exact hd.snd_ne_snd + have hprovNew : ∀ p ∈ ((F.boundaryLabel hβ, + F.boundaryLabel (κ.pathMatch_mem hβ)) :: L'), + AntiLowPair o p := by + intro p hp + rcases List.mem_cons.mp hp with rfl | hp' + · exact ⟨β, hβ, hβmem, rfl, rfl⟩ + · exact AntiLowPair.mono hsub (hprov' p hp') + refine ⟨o₂, + (F.boundaryLabel hβ, + F.boundaryLabel (κ.pathMatch_mem hβ)) :: L', + hcanon, ?_, ?_, hprovNew, ?_⟩ + · rw [List.length_cons, hlen'] + · exact List.pairwise_cons.mpr ⟨hpd, hpw'⟩ + · intro n + have hb1 := genBoundarySubsetMatches_stateOddFlipSet + (genBoundarySubsetMatches_stateOddFlip hbnd + (F.boundaryLabel hβ) + (F.boundaryLabel (κ.pathMatch_mem hβ))) (pairFold L') + have hb2 := genBoundarySubsetMatches_stateOddFlipSet hbnd + (pairFold ((F.boundaryLabel hβ, + F.boundaryLabel (κ.pathMatch_mem hβ)) :: L')) + have hsign : ((flipSignProd g + ((F.boundaryLabel hβ, + F.boundaryLabel (κ.pathMatch_mem hβ)) :: L') : ℤ) : + ℂ) = + ((oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂ : ℤ) : ℂ) * + ((flipSignProd (flipColours g (F.boundaryLabel hβ, + F.boundaryLabel (κ.pathMatch_mem hβ))) L' : ℤ) : + ℂ) := by + rw [flipSignProd_cons, + show g (F.boundaryLabel hβ, + F.boundaryLabel (κ.pathMatch_mem hβ)).1 = c₁ from + hg _ c₁ hcol₁, + show g (F.boundaryLabel hβ, + F.boundaryLabel (κ.pathMatch_mem hβ)).2 = c₂ from + hg _ c₂ hcol₂] + push_cast + ring + rw [hled n, hled₂ n, + F.throughSummand_state_congr hM hstEq hb1 hb2 o₂ n, + hsign, mul_assoc] + +end RecanonSigned + +/-! ## The anchored transported frame: per-end evaluation -/ + +section NonsepCount + +/-- Membership of a re-paired end in the transported anti set, for +an arbitrary source orientation: the low-in-new comparison and the +source chain direction. -/ +private theorem mem_antiLowSet_transport_end + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) (o : κ.Orientation) + (hflip : o.isOut c = !o.isOut a) {x y : W.Flag} + (hx : x ∈ F.boundaryFlags) (hy : y ∈ F.boundaryFlags) + (hintx : W.pairing x ∈ F.internalFlags) + (hnew : (κ.repair a b c d v hsq).pathMatch x hx = y) : + x ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq o + hflip) ↔ + (F.boundaryLabel hx < F.boundaryLabel hy ∧ + chainDir o x = true) := by + rw [mem_antiLowSet_transport hsq o hflip] + constructor + · rintro ⟨hx', hint', hlt, hdir⟩ + refine ⟨?_, hdir⟩ + rwa [boundaryLabel_congr + ((κ.repair a b c d v hsq).pathMatch_mem hx) hy hnew] at hlt + · rintro ⟨hlt, hdir⟩ + refine ⟨hx, hintx, ?_, hdir⟩ + rwa [boundaryLabel_congr + ((κ.repair a b c d v hsq).pathMatch_mem hx) hy hnew] + +/-- The chain direction of the anchored flip at an untoggled end is +the canonical high-status. -/ +private theorem dir_portFlip_untoggled_iff + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {S : Finset W.Flag} {p₁ : W.Flag} + {p₂ : W.Flag} {iβ : α} {iγ : α} + {o : κ.Orientation} + (hc : PathCanonical o) (hpf : PortedFlipSet κ S p₁ p₂ iβ iγ) + {x : W.Flag} (hx : x ∈ F.boundaryFlags) + (hintx : W.pairing x ∈ F.internalFlags) + (hT : W.pairing x ∉ S) : + chainDir (o.portFlip hpf) x = true ↔ + F.boundaryLabel (κ.pathMatch_mem hx) < F.boundaryLabel hx := by + rw [chainDir_portFlip_of_notMem o hpf hT] + exact chainDir_true_iff_high hc hx hintx + +/-- The chain direction of the anchored flip at a toggled end is +the negated canonical high-status. -/ +private theorem dir_portFlip_toggled_iff + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {S : Finset W.Flag} {p₁ : W.Flag} + {p₂ : W.Flag} {iβ : α} {iγ : α} + {o : κ.Orientation} + (hc : PathCanonical o) (hpf : PortedFlipSet κ S p₁ p₂ iβ iγ) + {x : W.Flag} (hx : x ∈ F.boundaryFlags) + (hintx : W.pairing x ∈ F.internalFlags) + (hT : W.pairing x ∈ S) : + chainDir (o.portFlip hpf) x = true ↔ + ¬ F.boundaryLabel (κ.pathMatch_mem hx) < + F.boundaryLabel hx := by + rw [chainDir_portFlip_of_mem o hpf hT] + constructor + · intro hd hlt + rw [(chainDir_true_iff_high hc hx hintx).mpr hlt] at hd + simp at hd + · intro hn + cases hb : chainDir o x + · rfl + · exact absurd ((chainDir_true_iff_high hc hx hintx).mp hb) hn + +/-- The anchor-chain toggle is chord-wise: an end's entry edge is +on the flipped chain iff its path match's entry edge is. -/ +private theorem toggle_partner + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {S : Finset W.Flag} {p₁ : W.Flag} + {p₂ : W.Flag} {iβ : α} {iγ : α} + (hpf : PortedFlipSet κ S p₁ p₂ iβ iγ) + {β₂ : W.Flag} (hβ₂ : β₂ ∈ F.boundaryFlags) + (hintβ : W.pairing β₂ ∈ F.internalFlags) + (honS : ∀ f ∈ S, OnBoundaryChain κ β₂ f) + (hSon : ∀ f ∈ F.internalFlags, OnBoundaryChain κ β₂ f → f ∈ S) + {x : W.Flag} (hx : x ∈ F.boundaryFlags) + (hintx : W.pairing x ∈ F.internalFlags) : + W.pairing (κ.pathMatch x hx) ∈ S ↔ W.pairing x ∈ S := by + rw [pairing_mem_flipSet_iff hpf hβ₂ hintβ honS hSon + (κ.pathMatch_mem hx) (pathMatch_pairing_internal hx hintx), + pairing_mem_flipSet_iff hpf hβ₂ hintβ honS hSon hx hintx] + constructor + · rintro (h | h) + · right + calc x = κ.pathMatch (κ.pathMatch x hx) + (κ.pathMatch_mem hx) := (κ.pathMatch_invol hx).symm + _ = κ.pathMatch β₂ hβ₂ := + κ.pathMatch_congr h (κ.pathMatch_mem hx) hβ₂ + · left + calc x = κ.pathMatch (κ.pathMatch x hx) + (κ.pathMatch_mem hx) := (κ.pathMatch_invol hx).symm + _ = κ.pathMatch (κ.pathMatch β₂ hβ₂) + (κ.pathMatch_mem hβ₂) := + κ.pathMatch_congr h (κ.pathMatch_mem hx) + (κ.pathMatch_mem hβ₂) + _ = β₂ := κ.pathMatch_invol hβ₂ + · rintro (rfl | h) + · exact Or.inr rfl + · left + calc κ.pathMatch x hx + = κ.pathMatch (κ.pathMatch β₂ hβ₂) + (κ.pathMatch_mem hβ₂) := + κ.pathMatch_congr h hx (κ.pathMatch_mem hβ₂) + _ = β₂ := κ.pathMatch_invol hβ₂ + +/-- **The mixed-toggle anti count**: when the cross-pairing joins +an untoggled end `ε₁` to a toggled end `ε₂` (an end of the anchor +chord), the anti set of the anchored transported frame lies on the +four re-paired ends and its cardinality is the toggled four-label +indicator sum of `fourLabel_parity_nonsep`. -/ +private theorem nonsep_anti_card_mixed + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} {S : Finset W.Flag} {p₁ : W.Flag} + {p₂ : W.Flag} {iβ : α} {iγ : α} + (hsq : RepairSquare κ a b c d v) {o : κ.Orientation} + (hc : PathCanonical o) + (hpf : PortedFlipSet κ S p₁ p₂ iβ iγ) + (hflip : (o.portFlip hpf).isOut c = !(o.portFlip hpf).isOut a) + {β₂ : W.Flag} (hβ₂ : β₂ ∈ F.boundaryFlags) + (hintβ : W.pairing β₂ ∈ F.internalFlags) + (honS : ∀ f ∈ S, OnBoundaryChain κ β₂ f) + (hSon : ∀ f ∈ F.internalFlags, OnBoundaryChain κ β₂ f → f ∈ S) + {ε₁ ε₂ : W.Flag} (hε₁ : ε₁ ∈ F.boundaryFlags) + (hε₂ : ε₂ ∈ F.boundaryFlags) + (hne : ε₁ ≠ ε₂) (hPne : κ.pathMatch ε₁ hε₁ ≠ ε₂) + (hcross : (κ.repair a b c d v hsq).pathMatch ε₁ hε₁ = ε₂) + (hfar : (κ.repair a b c d v hsq).pathMatch + (κ.pathMatch ε₁ hε₁) (κ.pathMatch_mem hε₁) = + κ.pathMatch ε₂ hε₂) + (hout : ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + δ ≠ ε₁ → δ ≠ ε₂ → δ ≠ κ.pathMatch ε₁ hε₁ → + δ ≠ κ.pathMatch ε₂ hε₂ → + (κ.repair a b c d v hsq).pathMatch δ hδ = + κ.pathMatch δ hδ) + (hT₁ : W.pairing ε₁ ∉ S) (hT₂ : W.pairing ε₂ ∈ S) : + (antiLowSet (RelTransitionSystem.Orientation.transportRepair + hsq (o.portFlip hpf) hflip)).card = + (if (if F.boundaryLabel hε₁ < F.boundaryLabel hε₂ then + F.boundaryLabel (κ.pathMatch_mem hε₁) < + F.boundaryLabel hε₁ + else ¬ F.boundaryLabel (κ.pathMatch_mem hε₂) < + F.boundaryLabel hε₂) then 1 else 0) + + (if (if F.boundaryLabel (κ.pathMatch_mem hε₁) < + F.boundaryLabel (κ.pathMatch_mem hε₂) then + F.boundaryLabel hε₁ < + F.boundaryLabel (κ.pathMatch_mem hε₁) + else ¬ F.boundaryLabel hε₂ < + F.boundaryLabel (κ.pathMatch_mem hε₂)) then 1 + else 0) := by + have hcross₂ : (κ.repair a b c d v hsq).pathMatch ε₂ hε₂ = ε₁ := + ((κ.repair a b c d v hsq).pathMatch_congr hcross.symm hε₂ + ((κ.repair a b c d v hsq).pathMatch_mem hε₁)).trans + ((κ.repair a b c d v hsq).pathMatch_invol hε₁) + have hfar₂ : (κ.repair a b c d v hsq).pathMatch + (κ.pathMatch ε₂ hε₂) (κ.pathMatch_mem hε₂) = + κ.pathMatch ε₁ hε₁ := + ((κ.repair a b c d v hsq).pathMatch_congr hfar.symm + (κ.pathMatch_mem hε₂) + ((κ.repair a b c d v hsq).pathMatch_mem + (κ.pathMatch_mem hε₁))).trans + ((κ.repair a b c d v hsq).pathMatch_invol + (κ.pathMatch_mem hε₁)) + have hPne' : ε₁ ≠ κ.pathMatch ε₂ hε₂ := fun h => + hPne ((κ.pathMatch_congr h hε₁ (κ.pathMatch_mem hε₂)).trans + (κ.pathMatch_invol hε₂)) + have hPP : κ.pathMatch ε₁ hε₁ ≠ κ.pathMatch ε₂ hε₂ := by + intro h + apply hne + calc ε₁ = κ.pathMatch (κ.pathMatch ε₁ hε₁) + (κ.pathMatch_mem hε₁) := (κ.pathMatch_invol hε₁).symm + _ = κ.pathMatch (κ.pathMatch ε₂ hε₂) + (κ.pathMatch_mem hε₂) := + κ.pathMatch_congr h (κ.pathMatch_mem hε₁) + (κ.pathMatch_mem hε₂) + _ = ε₂ := κ.pathMatch_invol hε₂ + have hint₁ : W.pairing ε₁ ∈ F.internalFlags := + repartner_internal (κ := κ) (κ' := κ.repair a b c d v hsq) + hε₁ (by + rw [hcross] + exact fun h => hPne h.symm) + have hint₂' : W.pairing ε₂ ∈ F.internalFlags := + repartner_internal (κ := κ) (κ' := κ.repair a b c d v hsq) + hε₂ (by + rw [hcross₂] + exact hPne') + have hintP₁ : W.pairing (κ.pathMatch ε₁ hε₁) ∈ + F.internalFlags := + repartner_internal (κ := κ) (κ' := κ.repair a b c d v hsq) + (κ.pathMatch_mem hε₁) (by + rw [hfar, κ.pathMatch_invol hε₁] + exact fun h => hPne' h.symm) + have hintP₂ : W.pairing (κ.pathMatch ε₂ hε₂) ∈ + F.internalFlags := + repartner_internal (κ := κ) (κ' := κ.repair a b c d v hsq) + (κ.pathMatch_mem hε₂) (by + rw [hfar₂, κ.pathMatch_invol hε₂] + exact hPne) + have hT₃ : W.pairing (κ.pathMatch ε₁ hε₁) ∉ S := fun hmem => + hT₁ ((toggle_partner hpf hβ₂ hintβ honS hSon hε₁ hint₁).mp + hmem) + have hT₄ : W.pairing (κ.pathMatch ε₂ hε₂) ∈ S := + (toggle_partner hpf hβ₂ hintβ honS hSon hε₂ hint₂').mpr hT₂ + have hLxy : F.boundaryLabel hε₁ ≠ F.boundaryLabel hε₂ := + fun h => hne (boundaryLabel_inj hε₁ hε₂ h) + have hLxbyb : F.boundaryLabel (κ.pathMatch_mem hε₁) ≠ + F.boundaryLabel (κ.pathMatch_mem hε₂) := + fun h => hPP (boundaryLabel_inj (κ.pathMatch_mem hε₁) + (κ.pathMatch_mem hε₂) h) + have hππ₁ : F.boundaryLabel + (κ.pathMatch_mem (κ.pathMatch_mem hε₁)) = + F.boundaryLabel hε₁ := + boundaryLabel_congr _ hε₁ (κ.pathMatch_invol hε₁) + have hππ₂ : F.boundaryLabel + (κ.pathMatch_mem (κ.pathMatch_mem hε₂)) = + F.boundaryLabel hε₂ := + boundaryLabel_congr _ hε₂ (κ.pathMatch_invol hε₂) + have hm₁ : ε₁ ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip) ↔ + (F.boundaryLabel hε₁ < F.boundaryLabel hε₂ ∧ + F.boundaryLabel (κ.pathMatch_mem hε₁) < + F.boundaryLabel hε₁) := by + rw [mem_antiLowSet_transport_end hsq (o.portFlip hpf) hflip + hε₁ hε₂ hint₁ hcross] + exact and_congr_right fun _ => + dir_portFlip_untoggled_iff hc hpf hε₁ hint₁ hT₁ + have hm₂ : ε₂ ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip) ↔ + (F.boundaryLabel hε₂ < F.boundaryLabel hε₁ ∧ + ¬ F.boundaryLabel (κ.pathMatch_mem hε₂) < + F.boundaryLabel hε₂) := by + rw [mem_antiLowSet_transport_end hsq (o.portFlip hpf) hflip + hε₂ hε₁ hint₂' hcross₂] + exact and_congr_right fun _ => + dir_portFlip_toggled_iff hc hpf hε₂ hint₂' hT₂ + have hm₃ : κ.pathMatch ε₁ hε₁ ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip) ↔ + (F.boundaryLabel (κ.pathMatch_mem hε₁) < + F.boundaryLabel (κ.pathMatch_mem hε₂) ∧ + F.boundaryLabel hε₁ < + F.boundaryLabel (κ.pathMatch_mem hε₁)) := by + rw [mem_antiLowSet_transport_end hsq (o.portFlip hpf) hflip + (κ.pathMatch_mem hε₁) (κ.pathMatch_mem hε₂) hintP₁ hfar] + refine and_congr_right fun _ => ?_ + have h1 := dir_portFlip_untoggled_iff hc hpf + (κ.pathMatch_mem hε₁) hintP₁ hT₃ + rw [hππ₁] at h1 + exact h1 + have hm₄ : κ.pathMatch ε₂ hε₂ ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip) ↔ + (F.boundaryLabel (κ.pathMatch_mem hε₂) < + F.boundaryLabel (κ.pathMatch_mem hε₁) ∧ + ¬ F.boundaryLabel hε₂ < + F.boundaryLabel (κ.pathMatch_mem hε₂)) := by + rw [mem_antiLowSet_transport_end hsq (o.portFlip hpf) hflip + (κ.pathMatch_mem hε₂) (κ.pathMatch_mem hε₁) hintP₂ hfar₂] + refine and_congr_right fun _ => ?_ + have h1 := dir_portFlip_toggled_iff hc hpf + (κ.pathMatch_mem hε₂) hintP₂ hT₄ + rw [hππ₂] at h1 + exact h1 + have hsub : antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip) ⊆ + ({ε₁, ε₂, κ.pathMatch ε₁ hε₁, κ.pathMatch ε₂ hε₂} : + Finset W.Flag) := by + intro δ hδmem + by_contra hnot + have h1 : δ ≠ ε₁ := fun h => hnot (by + rw [h] + exact Finset.mem_insert_self _ _) + have h2 : δ ≠ ε₂ := fun h => hnot (by + rw [h] + exact Finset.mem_insert_of_mem (Finset.mem_insert_self _ _)) + have h3 : δ ≠ κ.pathMatch ε₁ hε₁ := fun h => hnot (by + rw [h] + exact Finset.mem_insert_of_mem (Finset.mem_insert_of_mem + (Finset.mem_insert_self _ _))) + have h4 : δ ≠ κ.pathMatch ε₂ hε₂ := fun h => hnot (by + rw [h] + exact Finset.mem_insert_of_mem (Finset.mem_insert_of_mem + (Finset.mem_insert_of_mem (Finset.mem_singleton_self _)))) + have h5 := (mem_antiLowSet_transport_untouched hsq + (o.portFlip hpf) hflip hε₁ hε₂ hout h1 h2 h3 h4).mp hδmem + obtain ⟨hδb, hintδ, hlowδ, hdirδ⟩ := mem_antiLowSet.mp h5 + by_cases hTδ : W.pairing δ ∈ S + · rcases (pairing_mem_flipSet_iff hpf hβ₂ hintβ honS hSon + hδb hintδ).mp hTδ with hδ1 | hδ1 <;> + rcases (pairing_mem_flipSet_iff hpf hβ₂ hintβ honS hSon + hε₂ hint₂').mp hT₂ with hδ2 | hδ2 + · exact h2 (hδ1.trans hδ2.symm) + · apply h4 + rw [hδ1] + exact ((κ.pathMatch_congr hδ2 hε₂ + (κ.pathMatch_mem hβ₂)).trans + (κ.pathMatch_invol hβ₂)).symm + · apply h4 + rw [hδ1] + exact (κ.pathMatch_congr hδ2 hε₂ hβ₂).symm + · exact h2 (hδ1.trans hδ2.symm) + · rw [chainDir_portFlip_of_notMem o hpf hTδ] at hdirδ + exact absurd ((chainDir_true_iff_high hc hδb hintδ).mp + hdirδ) (lt_asymm hlowδ) + have d13 : ε₁ ≠ κ.pathMatch ε₁ hε₁ := fun h => + κ.pathMatch_ne_self hε₁ h.symm + have d24 : ε₂ ≠ κ.pathMatch ε₂ hε₂ := fun h => + κ.pathMatch_ne_self hε₂ h.symm + have d23 : ε₂ ≠ κ.pathMatch ε₁ hε₁ := fun h => hPne h.symm + -- ═══════ COUNTING THE CANDIDATES ═══════ + have hcards := card_eq_sum_indicator hsub + rw [Finset.sum_insert (by simp [hne, d13, hPne']), + Finset.sum_insert (by simp [d23, d24]), + Finset.sum_insert (by simp [hPP]), + Finset.sum_singleton] at hcards + simp only [hm₁, hm₂, hm₃, hm₄] at hcards + rw [hcards, + ← two_indicator_if hLxy + (F.boundaryLabel (κ.pathMatch_mem hε₁) < + F.boundaryLabel hε₁) + (¬ F.boundaryLabel (κ.pathMatch_mem hε₂) < + F.boundaryLabel hε₂), + ← two_indicator_if hLxbyb + (F.boundaryLabel hε₁ < + F.boundaryLabel (κ.pathMatch_mem hε₁)) + (¬ F.boundaryLabel hε₂ < + F.boundaryLabel (κ.pathMatch_mem hε₂))] + omega + +private theorem repair_pathMatch_reverse + {W : Fragment α} {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {x y : W.Flag} (hx : x ∈ F.boundaryFlags) (hy : y ∈ F.boundaryFlags) + (h : κ.pathMatch x hx = y) : κ.pathMatch y hy = x := + (κ.pathMatch_congr h.symm hy (κ.pathMatch_mem hx)).trans (κ.pathMatch_invol hx) + +private theorem nonsep_anti_subset_six_candidates + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} {S : Finset W.Flag} {p₁ : W.Flag} + {p₂ : W.Flag} {iβ : α} {iγ : α} + (hsq : RepairSquare κ a b c d v) {o : κ.Orientation} + (hc : PathCanonical o) + (hpf : PortedFlipSet κ S p₁ p₂ iβ iγ) + (hflip : (o.portFlip hpf).isOut c = !(o.portFlip hpf).isOut a) + {β₂ : W.Flag} (hβ₂ : β₂ ∈ F.boundaryFlags) + (hintβ : W.pairing β₂ ∈ F.internalFlags) + (honS : ∀ f ∈ S, OnBoundaryChain κ β₂ f) + (hSon : ∀ f ∈ F.internalFlags, OnBoundaryChain κ β₂ f → f ∈ S) + {ε₁ ε₂ : W.Flag} (hε₁ : ε₁ ∈ F.boundaryFlags) + (hε₂ : ε₂ ∈ F.boundaryFlags) + (hout : ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + δ ≠ ε₁ → δ ≠ ε₂ → δ ≠ κ.pathMatch ε₁ hε₁ → + δ ≠ κ.pathMatch ε₂ hε₂ → + (κ.repair a b c d v hsq).pathMatch δ hδ = + κ.pathMatch δ hδ) + : antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip) ⊆ + ({ε₁, ε₂, κ.pathMatch ε₁ hε₁, κ.pathMatch ε₂ hε₂, β₂, + κ.pathMatch β₂ hβ₂} : Finset W.Flag) := by + intro δ hδmem + by_contra hnot + simp only [Finset.mem_insert, Finset.mem_singleton, not_or] + at hnot + obtain ⟨h1, h2, h3, h4, h5, h6⟩ := hnot + have h7 := (mem_antiLowSet_transport_untouched hsq + (o.portFlip hpf) hflip hε₁ hε₂ hout h1 h2 h3 h4).mp hδmem + obtain ⟨hδb, hintδ, hlowδ, hdirδ⟩ := mem_antiLowSet.mp h7 + by_cases hTδ : W.pairing δ ∈ S + · rcases (pairing_mem_flipSet_iff hpf hβ₂ hintβ honS hSon + hδb hintδ).mp hTδ with hδ1 | hδ1 + · exact h5 hδ1 + · exact h6 hδ1 + · rw [chainDir_portFlip_of_notMem o hpf hTδ] at hdirδ + exact absurd ((chainDir_true_iff_high hc hδb hintδ).mp + hdirδ) (lt_asymm hlowδ) + +/-- **The untoggled anti count**: when neither re-paired chord is +the anchor chord, the anchor chord is untouched by the repair and +contributes exactly its low end to the anti set of the anchored +transported frame; the four re-paired ends contribute the plain +separated indicators. -/ +private theorem nonsep_anti_card_untoggled + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} {S : Finset W.Flag} {p₁ : W.Flag} + {p₂ : W.Flag} {iβ : α} {iγ : α} + (hsq : RepairSquare κ a b c d v) {o : κ.Orientation} + (hc : PathCanonical o) + (hpf : PortedFlipSet κ S p₁ p₂ iβ iγ) + (hflip : (o.portFlip hpf).isOut c = !(o.portFlip hpf).isOut a) + {β₂ : W.Flag} (hβ₂ : β₂ ∈ F.boundaryFlags) + (hintβ : W.pairing β₂ ∈ F.internalFlags) + (honS : ∀ f ∈ S, OnBoundaryChain κ β₂ f) + (hSon : ∀ f ∈ F.internalFlags, OnBoundaryChain κ β₂ f → f ∈ S) + {ε₁ ε₂ : W.Flag} (hε₁ : ε₁ ∈ F.boundaryFlags) + (hε₂ : ε₂ ∈ F.boundaryFlags) + (hne : ε₁ ≠ ε₂) (hPne : κ.pathMatch ε₁ hε₁ ≠ ε₂) + (hcross : (κ.repair a b c d v hsq).pathMatch ε₁ hε₁ = ε₂) + (hfar : (κ.repair a b c d v hsq).pathMatch + (κ.pathMatch ε₁ hε₁) (κ.pathMatch_mem hε₁) = + κ.pathMatch ε₂ hε₂) + (hout : ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + δ ≠ ε₁ → δ ≠ ε₂ → δ ≠ κ.pathMatch ε₁ hε₁ → + δ ≠ κ.pathMatch ε₂ hε₂ → + (κ.repair a b c d v hsq).pathMatch δ hδ = + κ.pathMatch δ hδ) + (hT₁ : W.pairing ε₁ ∉ S) (hT₂ : W.pairing ε₂ ∉ S) : + (antiLowSet (RelTransitionSystem.Orientation.transportRepair + hsq (o.portFlip hpf) hflip)).card = + (if (if F.boundaryLabel hε₁ < F.boundaryLabel hε₂ then + F.boundaryLabel (κ.pathMatch_mem hε₁) < + F.boundaryLabel hε₁ + else F.boundaryLabel (κ.pathMatch_mem hε₂) < + F.boundaryLabel hε₂) then 1 else 0) + + (if (if F.boundaryLabel (κ.pathMatch_mem hε₁) < + F.boundaryLabel (κ.pathMatch_mem hε₂) then + F.boundaryLabel hε₁ < + F.boundaryLabel (κ.pathMatch_mem hε₁) + else F.boundaryLabel hε₂ < + F.boundaryLabel (κ.pathMatch_mem hε₂)) then 1 + else 0) + 1 := by + have hcross₂ := repair_pathMatch_reverse hε₁ hε₂ hcross + have hfar₂ := repair_pathMatch_reverse (κ.pathMatch_mem hε₁) + (κ.pathMatch_mem hε₂) hfar + have hPne' : ε₁ ≠ κ.pathMatch ε₂ hε₂ := fun h => + hPne ((κ.pathMatch_congr h hε₁ (κ.pathMatch_mem hε₂)).trans + (κ.pathMatch_invol hε₂)) + have hPP : κ.pathMatch ε₁ hε₁ ≠ κ.pathMatch ε₂ hε₂ := by + intro h + apply hne + calc ε₁ = κ.pathMatch (κ.pathMatch ε₁ hε₁) + (κ.pathMatch_mem hε₁) := (κ.pathMatch_invol hε₁).symm + _ = κ.pathMatch (κ.pathMatch ε₂ hε₂) + (κ.pathMatch_mem hε₂) := + κ.pathMatch_congr h (κ.pathMatch_mem hε₁) + (κ.pathMatch_mem hε₂) + _ = ε₂ := κ.pathMatch_invol hε₂ + have hint₁ : W.pairing ε₁ ∈ F.internalFlags := + repartner_internal (κ := κ) (κ' := κ.repair a b c d v hsq) + hε₁ (by + rw [hcross] + exact fun h => hPne h.symm) + have hint₂' : W.pairing ε₂ ∈ F.internalFlags := + repartner_internal (κ := κ) (κ' := κ.repair a b c d v hsq) + hε₂ (by + rw [hcross₂] + exact hPne') + have hintP₁ : W.pairing (κ.pathMatch ε₁ hε₁) ∈ + F.internalFlags := + repartner_internal (κ := κ) (κ' := κ.repair a b c d v hsq) + (κ.pathMatch_mem hε₁) (by + rw [hfar, κ.pathMatch_invol hε₁] + exact fun h => hPne' h.symm) + have hintP₂ : W.pairing (κ.pathMatch ε₂ hε₂) ∈ + F.internalFlags := + repartner_internal (κ := κ) (κ' := κ.repair a b c d v hsq) + (κ.pathMatch_mem hε₂) (by + rw [hfar₂, κ.pathMatch_invol hε₂] + exact hPne) + have hintPβ : W.pairing (κ.pathMatch β₂ hβ₂) ∈ + F.internalFlags := pathMatch_pairing_internal hβ₂ hintβ + have hT₃ : W.pairing (κ.pathMatch ε₁ hε₁) ∉ S := fun hmem => + hT₁ ((toggle_partner hpf hβ₂ hintβ honS hSon hε₁ hint₁).mp + hmem) + have hT₄ : W.pairing (κ.pathMatch ε₂ hε₂) ∉ S := fun hmem => + hT₂ ((toggle_partner hpf hβ₂ hintβ honS hSon hε₂ hint₂').mp + hmem) + have hTβ : W.pairing β₂ ∈ S := + (pairing_mem_flipSet_iff hpf hβ₂ hintβ honS hSon hβ₂ + hintβ).mpr (Or.inl rfl) + have hTγ : W.pairing (κ.pathMatch β₂ hβ₂) ∈ S := + (toggle_partner hpf hβ₂ hintβ honS hSon hβ₂ hintβ).mpr hTβ + have hLxy : F.boundaryLabel hε₁ ≠ F.boundaryLabel hε₂ := + fun h => hne (boundaryLabel_inj hε₁ hε₂ h) + have hLxbyb : F.boundaryLabel (κ.pathMatch_mem hε₁) ≠ + F.boundaryLabel (κ.pathMatch_mem hε₂) := + fun h => hPP (boundaryLabel_inj (κ.pathMatch_mem hε₁) + (κ.pathMatch_mem hε₂) h) + have hLβγ : F.boundaryLabel hβ₂ ≠ + F.boundaryLabel (κ.pathMatch_mem hβ₂) := fun h => + κ.pathMatch_ne_self hβ₂ + (boundaryLabel_inj hβ₂ (κ.pathMatch_mem hβ₂) h).symm + have hππ₁ : F.boundaryLabel + (κ.pathMatch_mem (κ.pathMatch_mem hε₁)) = + F.boundaryLabel hε₁ := + boundaryLabel_congr _ hε₁ (κ.pathMatch_invol hε₁) + have hππ₂ : F.boundaryLabel + (κ.pathMatch_mem (κ.pathMatch_mem hε₂)) = + F.boundaryLabel hε₂ := + boundaryLabel_congr _ hε₂ (κ.pathMatch_invol hε₂) + have hππβ : F.boundaryLabel + (κ.pathMatch_mem (κ.pathMatch_mem hβ₂)) = + F.boundaryLabel hβ₂ := + boundaryLabel_congr _ hβ₂ (κ.pathMatch_invol hβ₂) + -- distinctness + have d13 : ε₁ ≠ κ.pathMatch ε₁ hε₁ := fun h => + κ.pathMatch_ne_self hε₁ h.symm + have d24 : ε₂ ≠ κ.pathMatch ε₂ hε₂ := fun h => + κ.pathMatch_ne_self hε₂ h.symm + have d23 : ε₂ ≠ κ.pathMatch ε₁ hε₁ := fun h => hPne h.symm + have b1 : β₂ ≠ ε₁ := fun h => hT₁ (h ▸ hTβ) + have b2 : β₂ ≠ ε₂ := fun h => hT₂ (h ▸ hTβ) + have b3 : β₂ ≠ κ.pathMatch ε₁ hε₁ := fun h => hT₃ (h ▸ hTβ) + have b4 : β₂ ≠ κ.pathMatch ε₂ hε₂ := fun h => hT₄ (h ▸ hTβ) + have c1 : κ.pathMatch β₂ hβ₂ ≠ ε₁ := fun h => hT₁ (h ▸ hTγ) + have c2 : κ.pathMatch β₂ hβ₂ ≠ ε₂ := fun h => hT₂ (h ▸ hTγ) + have c3 : κ.pathMatch β₂ hβ₂ ≠ κ.pathMatch ε₁ hε₁ := fun h => + hT₃ (h ▸ hTγ) + have c4 : κ.pathMatch β₂ hβ₂ ≠ κ.pathMatch ε₂ hε₂ := fun h => + hT₄ (h ▸ hTγ) + have d56 : β₂ ≠ κ.pathMatch β₂ hβ₂ := fun h => + κ.pathMatch_ne_self hβ₂ h.symm + -- membership formulas + have hm₁ : ε₁ ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip) ↔ + (F.boundaryLabel hε₁ < F.boundaryLabel hε₂ ∧ + F.boundaryLabel (κ.pathMatch_mem hε₁) < + F.boundaryLabel hε₁) := by + rw [mem_antiLowSet_transport_end hsq (o.portFlip hpf) hflip + hε₁ hε₂ hint₁ hcross] + exact and_congr_right fun _ => + dir_portFlip_untoggled_iff hc hpf hε₁ hint₁ hT₁ + have hm₂ : ε₂ ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip) ↔ + (F.boundaryLabel hε₂ < F.boundaryLabel hε₁ ∧ + F.boundaryLabel (κ.pathMatch_mem hε₂) < + F.boundaryLabel hε₂) := by + rw [mem_antiLowSet_transport_end hsq (o.portFlip hpf) hflip + hε₂ hε₁ hint₂' hcross₂] + exact and_congr_right fun _ => + dir_portFlip_untoggled_iff hc hpf hε₂ hint₂' hT₂ + have hm₃ : κ.pathMatch ε₁ hε₁ ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip) ↔ + (F.boundaryLabel (κ.pathMatch_mem hε₁) < + F.boundaryLabel (κ.pathMatch_mem hε₂) ∧ + F.boundaryLabel hε₁ < + F.boundaryLabel (κ.pathMatch_mem hε₁)) := by + rw [mem_antiLowSet_transport_end hsq (o.portFlip hpf) hflip + (κ.pathMatch_mem hε₁) (κ.pathMatch_mem hε₂) hintP₁ hfar] + refine and_congr_right fun _ => ?_ + have h1 := dir_portFlip_untoggled_iff hc hpf + (κ.pathMatch_mem hε₁) hintP₁ hT₃ + rw [hππ₁] at h1 + exact h1 + have hm₄ : κ.pathMatch ε₂ hε₂ ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip) ↔ + (F.boundaryLabel (κ.pathMatch_mem hε₂) < + F.boundaryLabel (κ.pathMatch_mem hε₁) ∧ + F.boundaryLabel hε₂ < + F.boundaryLabel (κ.pathMatch_mem hε₂)) := by + rw [mem_antiLowSet_transport_end hsq (o.portFlip hpf) hflip + (κ.pathMatch_mem hε₂) (κ.pathMatch_mem hε₁) hintP₂ hfar₂] + refine and_congr_right fun _ => ?_ + have h1 := dir_portFlip_untoggled_iff hc hpf + (κ.pathMatch_mem hε₂) hintP₂ hT₄ + rw [hππ₂] at h1 + exact h1 + have hm₅ : β₂ ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip) ↔ + F.boundaryLabel hβ₂ < + F.boundaryLabel (κ.pathMatch_mem hβ₂) := by + rw [mem_antiLowSet_transport_untouched hsq (o.portFlip hpf) + hflip hε₁ hε₂ hout b1 b2 b3 b4, + mem_antiLowSet] + constructor + · rintro ⟨hb, -, hlow, -⟩ + exact hlow + · intro h + exact ⟨hβ₂, hintβ, h, + (dir_portFlip_toggled_iff hc hpf hβ₂ hintβ hTβ).mpr + (lt_asymm h)⟩ + have hm₆ : κ.pathMatch β₂ hβ₂ ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip) ↔ + F.boundaryLabel (κ.pathMatch_mem hβ₂) < + F.boundaryLabel hβ₂ := by + rw [mem_antiLowSet_transport_untouched hsq (o.portFlip hpf) + hflip hε₁ hε₂ hout c1 c2 c3 c4, + mem_antiLowSet] + constructor + · rintro ⟨hb, -, hlow, -⟩ + rwa [hππβ] at hlow + · intro h + refine ⟨κ.pathMatch_mem hβ₂, hintPβ, ?_, ?_⟩ + · rwa [hππβ] + · have h1 := dir_portFlip_toggled_iff hc hpf + (κ.pathMatch_mem hβ₂) hintPβ hTγ + rw [hππβ] at h1 + exact h1.mpr (lt_asymm h) + -- ═══════ THE ANTI SET LIES ON SIX CANDIDATES ═══════ + -- Everything off the four re-paired ends and the anchor chord's + -- two ends is untouched by both the flip and the repair. + -- the anti set lies on the six candidates + have hsub := nonsep_anti_subset_six_candidates hsq hc hpf hflip + hβ₂ hintβ honS hSon hε₁ hε₂ hout + -- ═══════ COUNTING THE CANDIDATES ═══════ + have hcards := card_eq_sum_indicator hsub + rw [Finset.sum_insert (by + simp [hne, d13, hPne', Ne.symm b1, Ne.symm c1]), + Finset.sum_insert (by + simp [d23, d24, Ne.symm b2, Ne.symm c2]), + Finset.sum_insert (by simp [hPP, Ne.symm b3, Ne.symm c3]), + Finset.sum_insert (by simp [Ne.symm b4, Ne.symm c4]), + Finset.sum_insert (by simp [d56]), + Finset.sum_singleton] at hcards + simp only [hm₁, hm₂, hm₃, hm₄, hm₅, hm₆] at hcards + have e56 := indicator_pair_one hLβγ + rw [hcards, + ← two_indicator_if hLxy + (F.boundaryLabel (κ.pathMatch_mem hε₁) < + F.boundaryLabel hε₁) + (F.boundaryLabel (κ.pathMatch_mem hε₂) < + F.boundaryLabel hε₂), + ← two_indicator_if hLxbyb + (F.boundaryLabel hε₁ < + F.boundaryLabel (κ.pathMatch_mem hε₁)) + (F.boundaryLabel hε₂ < + F.boundaryLabel (κ.pathMatch_mem hε₂))] + omega + +open scoped Classical in +/-- **The non-separated per-step flip-count parity**: the anti +count of the anchored transported frame matches, mod 2, the +chord-crossing change of the repair. The toggle configuration of +the four re-paired ends is resolved by cases: both re-paired new +chords cannot lie on the anchor chord; a mixed configuration feeds +`fourLabel_parity_nonsep`; the untoggled configuration leaves the +anchor chord untouched, contributing the extra flip that feeds +`fourLabel_parity_sep`. -/ +private theorem nonsep_count_parity + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} {S : Finset W.Flag} {p₁ : W.Flag} + {p₂ : W.Flag} {iβ : α} {iγ : α} + (hsq : RepairSquare κ a b c d v) {o : κ.Orientation} + (hc : PathCanonical o) + (hpf : PortedFlipSet κ S p₁ p₂ iβ iγ) + (hflip : (o.portFlip hpf).isOut c = !(o.portFlip hpf).isOut a) + {β₂ : W.Flag} (hβ₂ : β₂ ∈ F.boundaryFlags) + (hintβ : W.pairing β₂ ∈ F.internalFlags) + (honS : ∀ f ∈ S, OnBoundaryChain κ β₂ f) + (hSon : ∀ f ∈ F.internalFlags, OnBoundaryChain κ β₂ f → f ∈ S) + {ε₁ ε₂ : W.Flag} (hε₁ : ε₁ ∈ F.boundaryFlags) + (hε₂ : ε₂ ∈ F.boundaryFlags) + (hne : ε₁ ≠ ε₂) (hPne : κ.pathMatch ε₁ hε₁ ≠ ε₂) + (hcross : (κ.repair a b c d v hsq).pathMatch ε₁ hε₁ = ε₂) + (hfar : (κ.repair a b c d v hsq).pathMatch + (κ.pathMatch ε₁ hε₁) (κ.pathMatch_mem hε₁) = + κ.pathMatch ε₂ hε₂) + (hout : ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + δ ≠ ε₁ → δ ≠ ε₂ → δ ≠ κ.pathMatch ε₁ hε₁ → + δ ≠ κ.pathMatch ε₂ hε₂ → + (κ.repair a b c d v hsq).pathMatch δ hδ = + κ.pathMatch δ hδ) : + ((antiLowSet (RelTransitionSystem.Orientation.transportRepair + hsq (o.portFlip hpf) hflip)).card + + (chordCrossingCount κ + + chordCrossingCount (κ.repair a b c d v hsq))) % 2 = 0 := by + have hcross₂ : (κ.repair a b c d v hsq).pathMatch ε₂ hε₂ = ε₁ := + ((κ.repair a b c d v hsq).pathMatch_congr hcross.symm hε₂ + ((κ.repair a b c d v hsq).pathMatch_mem hε₁)).trans + ((κ.repair a b c d v hsq).pathMatch_invol hε₁) + have hfar₂ : (κ.repair a b c d v hsq).pathMatch + (κ.pathMatch ε₂ hε₂) (κ.pathMatch_mem hε₂) = + κ.pathMatch ε₁ hε₁ := + ((κ.repair a b c d v hsq).pathMatch_congr hfar.symm + (κ.pathMatch_mem hε₂) + ((κ.repair a b c d v hsq).pathMatch_mem + (κ.pathMatch_mem hε₁))).trans + ((κ.repair a b c d v hsq).pathMatch_invol + (κ.pathMatch_mem hε₁)) + have hPne' : ε₁ ≠ κ.pathMatch ε₂ hε₂ := fun h => + hPne ((κ.pathMatch_congr h hε₁ (κ.pathMatch_mem hε₂)).trans + (κ.pathMatch_invol hε₂)) + have hPP : κ.pathMatch ε₁ hε₁ ≠ κ.pathMatch ε₂ hε₂ := by + intro h + apply hne + calc ε₁ = κ.pathMatch (κ.pathMatch ε₁ hε₁) + (κ.pathMatch_mem hε₁) := (κ.pathMatch_invol hε₁).symm + _ = κ.pathMatch (κ.pathMatch ε₂ hε₂) + (κ.pathMatch_mem hε₂) := + κ.pathMatch_congr h (κ.pathMatch_mem hε₁) + (κ.pathMatch_mem hε₂) + _ = ε₂ := κ.pathMatch_invol hε₂ + have hint₁ : W.pairing ε₁ ∈ F.internalFlags := + repartner_internal (κ := κ) (κ' := κ.repair a b c d v hsq) + hε₁ (by + rw [hcross] + exact fun h => hPne h.symm) + have hint₂' : W.pairing ε₂ ∈ F.internalFlags := + repartner_internal (κ := κ) (κ' := κ.repair a b c d v hsq) + hε₂ (by + rw [hcross₂] + exact hPne') + have hLxy : F.boundaryLabel hε₁ ≠ F.boundaryLabel hε₂ := + fun h => hne (boundaryLabel_inj hε₁ hε₂ h) + have hLxbyb : F.boundaryLabel (κ.pathMatch_mem hε₁) ≠ + F.boundaryLabel (κ.pathMatch_mem hε₂) := + fun h => hPP (boundaryLabel_inj (κ.pathMatch_mem hε₁) + (κ.pathMatch_mem hε₂) h) + have hLx_xb : F.boundaryLabel hε₁ ≠ + F.boundaryLabel (κ.pathMatch_mem hε₁) := fun h => + κ.pathMatch_ne_self hε₁ + (boundaryLabel_inj hε₁ (κ.pathMatch_mem hε₁) h).symm + have hLy_yb : F.boundaryLabel hε₂ ≠ + F.boundaryLabel (κ.pathMatch_mem hε₂) := fun h => + κ.pathMatch_ne_self hε₂ + (boundaryLabel_inj hε₂ (κ.pathMatch_mem hε₂) h).symm + have hLx_yb : F.boundaryLabel hε₁ ≠ + F.boundaryLabel (κ.pathMatch_mem hε₂) := fun h => + hPne' (boundaryLabel_inj hε₁ (κ.pathMatch_mem hε₂) h) + have hLxb_y : F.boundaryLabel (κ.pathMatch_mem hε₁) ≠ + F.boundaryLabel hε₂ := fun h => + hPne (boundaryLabel_inj (κ.pathMatch_mem hε₁) hε₂ h) + -- ═══════ THE FOUR ENDS AND THEIR LABELS ═══════ + -- Above: the re-paired ends are four distinct flags carrying four + -- distinct labels. Below: the crossing parity and the directions. + have hccp := chordCrossingCount_repair_parity hε₁ hε₂ hne hPne + hcross hfar hout + have hdirs := swap_dirs_opposite hsq (o.portFlip hpf) hflip hε₁ + hcross hint₁ + have i1 := chainDir_true_iff_high hc hε₁ hint₁ + have i2 := chainDir_true_iff_high hc hε₂ hint₂' + -- ═══════ WHICH ENDS THE CHAIN FLIP TOGGLES ═══════ + -- The anchor chain meets at most one of the two chords, so the + -- both-toggled case is impossible and the rest split by which. + by_cases hT₁ : W.pairing ε₁ ∈ S <;> + by_cases hT₂ : W.pairing ε₂ ∈ S + · -- both toggled: impossible + exfalso + rcases (pairing_mem_flipSet_iff hpf hβ₂ hintβ honS hSon hε₁ + hint₁).mp hT₁ with h1 | h1 <;> + rcases (pairing_mem_flipSet_iff hpf hβ₂ hintβ honS hSon hε₂ + hint₂').mp hT₂ with h2 | h2 + · exact hne (h1.trans h2.symm) + · apply hPne + rw [h2] + exact κ.pathMatch_congr h1 hε₁ hβ₂ + · apply hPne + rw [h2] + calc κ.pathMatch ε₁ hε₁ + = κ.pathMatch (κ.pathMatch β₂ hβ₂) + (κ.pathMatch_mem hβ₂) := + κ.pathMatch_congr h1 hε₁ (κ.pathMatch_mem hβ₂) + _ = β₂ := κ.pathMatch_invol hβ₂ + · exact hne (h1.trans h2.symm) + · -- toggled cross untoggled: the swapped mixed case + have h1 := hdirs + rw [chainDir_portFlip_of_mem o hpf hT₁, + chainDir_portFlip_of_notMem o hpf hT₂] at h1 + have hdd : chainDir o ε₂ = chainDir o ε₁ := by + rw [h1, Bool.not_not] + have hsame' : (F.boundaryLabel (κ.pathMatch_mem hε₂) < + F.boundaryLabel hε₂) = + (F.boundaryLabel (κ.pathMatch_mem hε₁) < + F.boundaryLabel hε₁) := by + apply propext + constructor + · intro h + exact i1.mp (hdd.symm.trans (i2.mpr h)) + · intro h + exact i2.mp (hdd.trans (i1.mpr h)) + have hcard := nonsep_anti_card_mixed hsq hc hpf hflip hβ₂ + hintβ honS hSon hε₂ hε₁ (Ne.symm hne) + (fun h => hPne' h.symm) hcross₂ hfar₂ + (fun δ hδ k1 k2 k3 k4 => hout δ hδ k2 k1 k4 k3) hT₂ hT₁ + have hfour := fourLabel_parity_nonsep hLy_yb hLx_xb + (Ne.symm hLxy) (Ne.symm hLxb_y) (Ne.symm hLx_yb) + (Ne.symm hLxbyb) hsame' + have ec1 : (if chordPairCrossSym + (F.boundaryLabel hε₂, F.boundaryLabel (κ.pathMatch_mem hε₂)) + (F.boundaryLabel hε₁, F.boundaryLabel (κ.pathMatch_mem hε₁)) + then 1 else 0 : ℕ) = + if chordPairCrossSym + (F.boundaryLabel hε₁, + F.boundaryLabel (κ.pathMatch_mem hε₁)) + (F.boundaryLabel hε₂, + F.boundaryLabel (κ.pathMatch_mem hε₂)) + then 1 else 0 := + if_congr (chordPairCrossSym_comm _ _) rfl rfl + have ec2 : (if chordPairCrossSym + (F.boundaryLabel hε₂, F.boundaryLabel hε₁) + (F.boundaryLabel (κ.pathMatch_mem hε₂), + F.boundaryLabel (κ.pathMatch_mem hε₁)) + then 1 else 0 : ℕ) = + if chordPairCrossSym + (F.boundaryLabel hε₁, F.boundaryLabel hε₂) + (F.boundaryLabel (κ.pathMatch_mem hε₁), + F.boundaryLabel (κ.pathMatch_mem hε₂)) + then 1 else 0 := + if_congr (chordPairCrossSym_swap_pair + (F.boundaryLabel hε₁) (F.boundaryLabel hε₂) + (F.boundaryLabel (κ.pathMatch_mem hε₁)) + (F.boundaryLabel (κ.pathMatch_mem hε₂))) rfl rfl + omega + · -- untoggled cross toggled: the direct mixed case + have h1 := hdirs + rw [chainDir_portFlip_of_notMem o hpf hT₁, + chainDir_portFlip_of_mem o hpf hT₂] at h1 + have hdd : chainDir o ε₂ = chainDir o ε₁ := by + have h2 := congrArg (fun z => !z) h1 + simpa using h2 + have hsame : (F.boundaryLabel (κ.pathMatch_mem hε₁) < + F.boundaryLabel hε₁) = + (F.boundaryLabel (κ.pathMatch_mem hε₂) < + F.boundaryLabel hε₂) := by + apply propext + constructor + · intro h + exact i2.mp (hdd.trans (i1.mpr h)) + · intro h + exact i1.mp (hdd.symm.trans (i2.mpr h)) + have hcard := nonsep_anti_card_mixed hsq hc hpf hflip hβ₂ + hintβ honS hSon hε₁ hε₂ hne hPne hcross hfar hout hT₁ hT₂ + have hfour := fourLabel_parity_nonsep hLx_xb hLy_yb hLxy + hLx_yb hLxb_y hLxbyb hsame + omega + · -- both untoggled: the anchored extra flip + have h1 := hdirs + rw [chainDir_portFlip_of_notMem o hpf hT₁, + chainDir_portFlip_of_notMem o hpf hT₂] at h1 + have hsep : (F.boundaryLabel (κ.pathMatch_mem hε₁) < + F.boundaryLabel hε₁) ≠ + (F.boundaryLabel (κ.pathMatch_mem hε₂) < + F.boundaryLabel hε₂) := by + cases hb : chainDir o ε₁ + · rw [hb, Bool.not_false] at h1 + refine prop_ne_of_right ?_ (i2.mp h1) + intro hlt + rw [i1.mpr hlt] at hb + cases hb + · rw [hb, Bool.not_true] at h1 + refine prop_ne_of_left (i1.mp hb) ?_ + intro hlt + rw [i2.mpr hlt] at h1 + cases h1 + have hcard := nonsep_anti_card_untoggled hsq hc hpf hflip hβ₂ + hintβ honS hSon hε₁ hε₂ hne hPne hcross hfar hout hT₁ hT₂ + have hfour := fourLabel_parity_sep hLx_xb hLy_yb hLxy hLx_yb + hLxb_y hLxbyb hsep + omega + +end NonsepCount + +/-! ## The per-step composed status ledger -/ + +section StepLemma + +private theorem stepStatusLedger_nonseparated + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} {k : ℕ} {ℓ : ℕ} + (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ₁ κ₂ : F.RelTransitionSystem} + {o₁ : κ₁.Orientation} (hc₁ : PathCanonical o₁) + (g : α → Fin (2 * ℓ)) + (hg : ∀ i c, st i = Sum.inr c → g i = c) + {a b c d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ₁ a b c d v) + (heq : (κ₁.repair a b c d v hsq).MatchEq κ₂) + (hloc : ¬ SquareLocalized κ₁ a b c d) + {ε₁ ε₂ : W.Flag} (hε₁ : ε₁ ∈ F.boundaryFlags) (hε₂ : ε₂ ∈ F.boundaryFlags) + (hne : ε₁ ≠ ε₂) (hPne : κ₁.pathMatch ε₁ hε₁ ≠ ε₂) + (hcross : (κ₁.repair a b c d v hsq).pathMatch ε₁ hε₁ = ε₂) + (hfar : (κ₁.repair a b c d v hsq).pathMatch (κ₁.pathMatch ε₁ hε₁) + (κ₁.pathMatch_mem hε₁) = κ₁.pathMatch ε₂ hε₂) + (hout : ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + δ ≠ ε₁ → δ ≠ ε₂ → δ ≠ κ₁.pathMatch ε₁ hε₁ → δ ≠ κ₁.pathMatch ε₂ hε₂ → + (κ₁.repair a b c d v hsq).pathMatch δ hδ = κ₁.pathMatch δ hδ) + (hsame : o₁.isOut c = o₁.isOut a) : + ∃ (o₂ : κ₂.Orientation) (T : List (α × α)) (tp : ℕ), + PathCanonical o₂ ∧ + (∀ p ∈ T, p.1 ≠ p.2) ∧ + pairFold T = statusDiff κ₁ κ₂ ∧ + (tp + T.length + chordCrossingCount κ₁ + + chordCrossingCount κ₂) % 2 = 0 ∧ + F.throughSummand hM (stateOddFlipSet st (pairFold T)) + (genBoundarySubsetMatches_stateOddFlipSet hbnd + (pairFold T)) o₂ κ₂.openCircuitCount = + (((-1) ^ tp * flipSignProd g T : ℤ) : ℂ) * + F.throughSummand hM st hbnd o₁ κ₁.openCircuitCount := by + have hccp := chordCrossingCount_repair_parity hε₁ hε₂ hne + hPne hcross hfar hout + have hcc₂ : chordCrossingCount κ₂ = + chordCrossingCount (κ₁.repair a b c d v hsq) := + chordCrossingCount_matchEq heq + -- The chain of `c` is flipped first, which moves the state at + -- its two ends, and the flipped square is then separated. + obtain ⟨β₁, β₂, hβ₁, hβ₂, hca, hcc, h21, h2γ⟩ := + twoChains_of_not_localized hsq hloc + obtain ⟨kc, hkle, hcont, hterm⟩ := + chain_terminates_with_data κ₁ hβ₂ + have hk : 1 ≤ kc := by + by_contra hlt + obtain rfl : kc = 0 := by omega + obtain ⟨k', t, htk, hcont', hterm', hft⟩ := hcc + have hkk : k' = 0 := + chain_exit_unique hcont' hterm' hcont hterm + subst hkk + obtain rfl : t = 0 := by omega + simp only [iterWalk_zero] at hterm + rcases hft with hE | hE + · rw [iterWalk_zero] at hE + exact Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags (hE ▸ hsq.hc) + hβ₂ + · rw [iterWalk_zero] at hE + exact Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags (hE ▸ hsq.hc) + hterm + obtain ⟨iβ, hiβ⟩ := F.attach_boundary_of_mem hβ₂ + obtain ⟨iγ, hiγ⟩ := F.attach_boundary_of_mem hterm + obtain ⟨S, hpf, honS, hSon⟩ := + exists_chainPortedFlipSet κ₁ hβ₂ hcont hterm hk hiβ hiγ + have hcS : c ∈ S := hSon c hsq.hc hcc + have h1γ2 : β₁ ≠ κ₁.pathMatch β₂ hβ₂ := by + intro he + apply h2γ + have h3 := κ₁.pathMatch_congr he hβ₁ + (κ₁.pathMatch_mem hβ₂) + exact (h3.trans (κ₁.pathMatch_invol hβ₂)).symm + have haS : a ∉ S := fun hmem => + onBoundaryChain_disjoint hβ₂ hβ₁ (Ne.symm h21) h1γ2 + (honS a hmem) hca + have hbF₁ : W.boundaryFlag iβ ∈ F.flags := by + rw [← W.eq_boundaryFlag iβ β₂ hiβ] + exact mem_flags_of_boundaryFlags F hβ₂ + have hbF₂ : W.boundaryFlag iγ ∈ F.flags := by + rw [← W.eq_boundaryFlag iγ _ hiγ] + exact mem_flags_of_boundaryFlags F hterm + obtain ⟨c₁, hcol₁⟩ := (hbnd iβ).mp hbF₁ + obtain ⟨c₂, hcol₂⟩ := (hbnd iγ).mp hbF₂ + have hbndS := genBoundarySubsetMatches_stateOddFlip hbnd + iβ iγ + have hcol₁' : stateOddFlip st iβ iγ iβ = + Sum.inr (oddPartner ℓ c₁) := stateOddFlip_left_odd hcol₁ + have hcol₂' : stateOddFlip st iβ iγ iγ = + Sum.inr (oddPartner ℓ c₂) := stateOddFlip_right_odd hcol₂ + have hflip' := portFlip_separated o₁ hpf hsame hcS haS + have htrans := twoPathNonSep_transform hM + (stateOddFlip st iβ iγ) hbndS hsq o₁ hsame hloc hpf hcS + haS hcol₁' hcol₂' + have hret := F.throughSummand_state_congr hM + (stateOddFlip_stateOddFlip (st := st) (i₁ := iβ) + (i₂ := iγ)) + (genBoundarySubsetMatches_stateOddFlip hbndS iβ iγ) hbnd + (κ := κ₁) o₁ κ₁.openCircuitCount + rw [hret] at htrans + have hint₂ : W.pairing β₂ ∈ F.internalFlags := by + have h0 := hcont 0 hk + rwa [iterWalk_zero] at h0 + have hpm₂ : κ₁.pathMatch β₂ hβ₂ = + W.pairing (iterWalk κ₁ β₂ kc) := + κ₁.pathMatch_eq hβ₂ (traceChain_fuel_mono κ₁ (by omega) + (traceChain_forward κ₁ β₂ hcont hterm)) + have hlabβ : F.boundaryLabel hβ₂ = iβ := + boundaryLabel_eq_of_attach hβ₂ hiβ + have hlabγ : F.boundaryLabel (κ₁.pathMatch_mem hβ₂) = + iγ := by + apply boundaryLabel_eq_of_attach + rw [hpm₂] + exact hiγ + obtain ⟨o'', L, hcanon, hlen, hpw, hprov, hled⟩ := + exists_recanonicalize_signed hM (stateOddFlip st iβ iγ) + hbndS + (RelTransitionSystem.Orientation.transportRepair hsq + (o₁.portFlip hpf) hflip') + (flipColours g (iβ, iγ)) (flipColours_matches hg iβ iγ) + have hstEq : stateOddFlipSet (stateOddFlip st iβ iγ) + (pairFold L) = + stateOddFlipSet st (pairFold ((iβ, iγ) :: L)) := by + rw [stateOddFlip_eq_flipSet, stateOddFlipSet_symmU, + pairFold_cons] + rfl + have hb1 := genBoundarySubsetMatches_stateOddFlipSet hbndS + (pairFold L) + have hb2 := genBoundarySubsetMatches_stateOddFlipSet hbnd + (pairFold ((iβ, iγ) :: L)) + have hsq2 : ((flipSignProd (flipColours g (iβ, iγ)) L : + ℤ) : ℂ) * + ((flipSignProd (flipColours g (iβ, iγ)) L : ℤ) : ℂ) = + 1 := by + rw [← Int.cast_mul, flipSignProd_mul_self, Int.cast_one] + have hval' : F.throughSummand hM + (stateOddFlipSet st (pairFold ((iβ, iγ) :: L))) hb2 o'' + ((κ₁.repair a b c d v hsq).openCircuitCount) = + (((-1) ^ 1 * flipSignProd g ((iβ, iγ) :: L) : ℤ) : ℂ) * + F.throughSummand hM st hbnd o₁ + κ₁.openCircuitCount := by + have h1 := hled + ((κ₁.repair a b c d v hsq).openCircuitCount) + have h3 : ((flipSignProd (flipColours g (iβ, iγ)) L : + ℤ) : ℂ) * + F.throughSummand hM + (stateOddFlipSet (stateOddFlip st iβ iγ) + (pairFold L)) hb1 o'' + ((κ₁.repair a b c d v hsq).openCircuitCount) = + twoPathNonSepFactor ℓ (oddPartner ℓ c₁) + (oddPartner ℓ c₂) * + F.throughSummand hM st hbnd o₁ + κ₁.openCircuitCount := + h1.symm.trans htrans + have hcongr := F.throughSummand_state_congr hM hstEq hb1 + hb2 o'' ((κ₁.repair a b c d v hsq).openCircuitCount) + have hfac : twoPathNonSepFactor ℓ (oddPartner ℓ c₁) + (oddPartner ℓ c₂) = + -((oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂ : ℤ) : + ℂ) := by + rw [twoPathNonSepFactor_eq, oddPartnerSign_oddPartner, + oddPartnerSign_oddPartner] + push_cast + ring + have hsign : (((-1) ^ 1 * + flipSignProd g ((iβ, iγ) :: L) : ℤ) : ℂ) = + -((oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂ : ℤ) : + ℂ) * + ((flipSignProd (flipColours g (iβ, iγ)) L : ℤ) : + ℂ) := by + rw [flipSignProd_cons, + show g (iβ, iγ).1 = c₁ from hg _ c₁ hcol₁, + show g (iβ, iγ).2 = c₂ from hg _ c₂ hcol₂] + push_cast + ring + calc F.throughSummand hM + (stateOddFlipSet st (pairFold ((iβ, iγ) :: L))) + hb2 o'' + ((κ₁.repair a b c d v hsq).openCircuitCount) + = F.throughSummand hM + (stateOddFlipSet (stateOddFlip st iβ iγ) + (pairFold L)) hb1 o'' + ((κ₁.repair a b c d v hsq).openCircuitCount) := + hcongr.symm + _ = (((flipSignProd (flipColours g (iβ, iγ)) L : ℤ) : + ℂ) * + ((flipSignProd (flipColours g (iβ, iγ)) L : ℤ) : + ℂ)) * + F.throughSummand hM + (stateOddFlipSet (stateOddFlip st iβ iγ) + (pairFold L)) hb1 o'' + ((κ₁.repair a b c d v hsq).openCircuitCount) := by + rw [hsq2, one_mul] + _ = ((flipSignProd (flipColours g (iβ, iγ)) L : ℤ) : + ℂ) * + (((flipSignProd (flipColours g (iβ, iγ)) L : ℤ) : + ℂ) * + F.throughSummand hM + (stateOddFlipSet (stateOddFlip st iβ iγ) + (pairFold L)) hb1 o'' + ((κ₁.repair a b c d v hsq).openCircuitCount)) := + by ring + _ = ((flipSignProd (flipColours g (iβ, iγ)) L : ℤ) : + ℂ) * + (twoPathNonSepFactor ℓ (oddPartner ℓ c₁) + (oddPartner ℓ c₂) * + F.throughSummand hM st hbnd o₁ + κ₁.openCircuitCount) := by rw [h3] + _ = (((-1) ^ 1 * flipSignProd g ((iβ, iγ) :: L) : ℤ) : + ℂ) * + F.throughSummand hM st hbnd o₁ + κ₁.openCircuitCount := by + rw [hfac, hsign] + ring + obtain ⟨o₂, hc₂, htrans₂⟩ := matchEq_canonical_transfer hM + (stateOddFlipSet st (pairFold ((iβ, iγ) :: L))) hb2 heq + hcanon + refine ⟨o₂, (iβ, iγ) :: L, 1, hc₂, ?_, ?_, ?_, ?_⟩ + · intro p hp + rcases List.mem_cons.mp hp with rfl | hp' + · exact hpf.hlab + · exact ne_of_lt (AntiLowPair.lt (hprov p hp')) + · rw [← statusDiff_matchEq_right heq] + apply Finset.ext + intro i + rw [mem_statusDiff] + exact nonsep_labels_eq_statusChange hsq hc₁ hpf hflip' + hβ₂ hint₂ honS hSon hlabβ hlabγ hprov hpw hlen + · have hcnt := nonsep_count_parity hsq hc₁ hpf hflip' hβ₂ + hint₂ honS hSon hε₁ hε₂ hne hPne hcross hfar hout + rw [List.length_cons, hlen] + omega + · exact htrans₂.trans hval' + +private theorem stepStatusLedger_separated + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} {k : ℕ} {ℓ : ℕ} + (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ₁ κ₂ : F.RelTransitionSystem} + {o₁ : κ₁.Orientation} (hc₁ : PathCanonical o₁) + (g : α → Fin (2 * ℓ)) + (hg : ∀ i c, st i = Sum.inr c → g i = c) + {a b c d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ₁ a b c d v) + (heq : (κ₁.repair a b c d v hsq).MatchEq κ₂) + (hloc : ¬ SquareLocalized κ₁ a b c d) + {ε₁ ε₂ : W.Flag} (hε₁ : ε₁ ∈ F.boundaryFlags) (hε₂ : ε₂ ∈ F.boundaryFlags) + (hne : ε₁ ≠ ε₂) (hPne : κ₁.pathMatch ε₁ hε₁ ≠ ε₂) + (hcross : (κ₁.repair a b c d v hsq).pathMatch ε₁ hε₁ = ε₂) + (hfar : (κ₁.repair a b c d v hsq).pathMatch (κ₁.pathMatch ε₁ hε₁) + (κ₁.pathMatch_mem hε₁) = κ₁.pathMatch ε₂ hε₂) + (hout : ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + δ ≠ ε₁ → δ ≠ ε₂ → δ ≠ κ₁.pathMatch ε₁ hε₁ → δ ≠ κ₁.pathMatch ε₂ hε₂ → + (κ₁.repair a b c d v hsq).pathMatch δ hδ = κ₁.pathMatch δ hδ) + (hsame : ¬ o₁.isOut c = o₁.isOut a) : + ∃ (o₂ : κ₂.Orientation) (T : List (α × α)) (tp : ℕ), + PathCanonical o₂ ∧ + (∀ p ∈ T, p.1 ≠ p.2) ∧ + pairFold T = statusDiff κ₁ κ₂ ∧ + (tp + T.length + chordCrossingCount κ₁ + + chordCrossingCount κ₂) % 2 = 0 ∧ + F.throughSummand hM (stateOddFlipSet st (pairFold T)) + (genBoundarySubsetMatches_stateOddFlipSet hbnd + (pairFold T)) o₂ κ₂.openCircuitCount = + (((-1) ^ tp * flipSignProd g T : ℤ) : ℂ) * + F.throughSummand hM st hbnd o₁ κ₁.openCircuitCount := by + have hcross₂ : (κ₁.repair a b c d v hsq).pathMatch ε₂ hε₂ = + ε₁ := + ((κ₁.repair a b c d v hsq).pathMatch_congr hcross.symm hε₂ + ((κ₁.repair a b c d v hsq).pathMatch_mem hε₁)).trans + ((κ₁.repair a b c d v hsq).pathMatch_invol hε₁) + have hfar₂ : (κ₁.repair a b c d v hsq).pathMatch + (κ₁.pathMatch ε₂ hε₂) (κ₁.pathMatch_mem hε₂) = + κ₁.pathMatch ε₁ hε₁ := + ((κ₁.repair a b c d v hsq).pathMatch_congr hfar.symm + (κ₁.pathMatch_mem hε₂) + ((κ₁.repair a b c d v hsq).pathMatch_mem + (κ₁.pathMatch_mem hε₁))).trans + ((κ₁.repair a b c d v hsq).pathMatch_invol + (κ₁.pathMatch_mem hε₁)) + have hPne' : ε₁ ≠ κ₁.pathMatch ε₂ hε₂ := fun h => + hPne ((κ₁.pathMatch_congr h hε₁ + (κ₁.pathMatch_mem hε₂)).trans (κ₁.pathMatch_invol hε₂)) + have hPP : κ₁.pathMatch ε₁ hε₁ ≠ κ₁.pathMatch ε₂ hε₂ := by + intro h + apply hne + calc ε₁ = κ₁.pathMatch (κ₁.pathMatch ε₁ hε₁) + (κ₁.pathMatch_mem hε₁) := + (κ₁.pathMatch_invol hε₁).symm + _ = κ₁.pathMatch (κ₁.pathMatch ε₂ hε₂) + (κ₁.pathMatch_mem hε₂) := + κ₁.pathMatch_congr h (κ₁.pathMatch_mem hε₁) + (κ₁.pathMatch_mem hε₂) + _ = ε₂ := κ₁.pathMatch_invol hε₂ + have hint₁ : W.pairing ε₁ ∈ F.internalFlags := + repartner_internal (κ := κ₁) + (κ' := κ₁.repair a b c d v hsq) hε₁ (by + rw [hcross] + exact fun h => hPne h.symm) + have hint₂' : W.pairing ε₂ ∈ F.internalFlags := + repartner_internal (κ := κ₁) + (κ' := κ₁.repair a b c d v hsq) hε₂ (by + rw [hcross₂] + exact hPne') + have hintP₁ : W.pairing (κ₁.pathMatch ε₁ hε₁) ∈ + F.internalFlags := + repartner_internal (κ := κ₁) + (κ' := κ₁.repair a b c d v hsq) + (κ₁.pathMatch_mem hε₁) (by + rw [hfar, κ₁.pathMatch_invol hε₁] + exact fun h => hPne' h.symm) + have hintP₂ : W.pairing (κ₁.pathMatch ε₂ hε₂) ∈ + F.internalFlags := + repartner_internal (κ := κ₁) + (κ' := κ₁.repair a b c d v hsq) + (κ₁.pathMatch_mem hε₂) (by + rw [hfar₂, κ₁.pathMatch_invol hε₂] + exact hPne) + have hLxy : F.boundaryLabel hε₁ ≠ F.boundaryLabel hε₂ := + fun h => hne (boundaryLabel_inj hε₁ hε₂ h) + have hLxbyb : F.boundaryLabel (κ₁.pathMatch_mem hε₁) ≠ + F.boundaryLabel (κ₁.pathMatch_mem hε₂) := + fun h => hPP (boundaryLabel_inj (κ₁.pathMatch_mem hε₁) + (κ₁.pathMatch_mem hε₂) h) + have hLx_xb : F.boundaryLabel hε₁ ≠ + F.boundaryLabel (κ₁.pathMatch_mem hε₁) := fun h => + κ₁.pathMatch_ne_self hε₁ + (boundaryLabel_inj hε₁ (κ₁.pathMatch_mem hε₁) h).symm + have hLy_yb : F.boundaryLabel hε₂ ≠ + F.boundaryLabel (κ₁.pathMatch_mem hε₂) := fun h => + κ₁.pathMatch_ne_self hε₂ + (boundaryLabel_inj hε₂ (κ₁.pathMatch_mem hε₂) h).symm + have hLx_yb : F.boundaryLabel hε₁ ≠ + F.boundaryLabel (κ₁.pathMatch_mem hε₂) := fun h => + hPne' (boundaryLabel_inj hε₁ (κ₁.pathMatch_mem hε₂) h) + have hLxb_y : F.boundaryLabel (κ₁.pathMatch_mem hε₁) ≠ + F.boundaryLabel hε₂ := fun h => + hPne (boundaryLabel_inj (κ₁.pathMatch_mem hε₁) hε₂ h) + have hccp := chordCrossingCount_repair_parity hε₁ hε₂ hne + hPne hcross hfar hout + have hcc₂ : chordCrossingCount κ₂ = + chordCrossingCount (κ₁.repair a b c d v hsq) := + chordCrossingCount_matchEq heq + -- The orientation transports verbatim; re-canonicalizing it + -- supplies the flip list and the transform gives the sign. + have hflip : o₁.isOut c = !o₁.isOut a := by + cases h1 : o₁.isOut c <;> cases h2 : o₁.isOut a <;> + simp_all + obtain ⟨o'', L, hcanon, hlen, hpw, hprov, hled⟩ := + exists_recanonicalize_signed hM st hbnd + (RelTransitionSystem.Orientation.transportRepair hsq o₁ + hflip) g hg + have hb2 := genBoundarySubsetMatches_stateOddFlipSet hbnd + (pairFold L) + have h2 := twoPath_transform hM st hbnd hsq o₁ hflip hloc + rw [twoPathTransformFactor_eq_neg_one] at h2 + have hsq2 : ((flipSignProd g L : ℤ) : ℂ) * + ((flipSignProd g L : ℤ) : ℂ) = 1 := by + rw [← Int.cast_mul, flipSignProd_mul_self, Int.cast_one] + have hval' : F.throughSummand hM + (stateOddFlipSet st (pairFold L)) hb2 o'' + ((κ₁.repair a b c d v hsq).openCircuitCount) = + (((-1) ^ 1 * flipSignProd g L : ℤ) : ℂ) * + F.throughSummand hM st hbnd o₁ + κ₁.openCircuitCount := by + have h1 := hled + ((κ₁.repair a b c d v hsq).openCircuitCount) + have h3 : ((flipSignProd g L : ℤ) : ℂ) * + F.throughSummand hM (stateOddFlipSet st (pairFold L)) + hb2 o'' + ((κ₁.repair a b c d v hsq).openCircuitCount) = + -1 * F.throughSummand hM st hbnd o₁ + κ₁.openCircuitCount := + h1.symm.trans h2 + calc F.throughSummand hM (stateOddFlipSet st (pairFold L)) + hb2 o'' + ((κ₁.repair a b c d v hsq).openCircuitCount) + = (((flipSignProd g L : ℤ) : ℂ) * + ((flipSignProd g L : ℤ) : ℂ)) * + F.throughSummand hM + (stateOddFlipSet st (pairFold L)) hb2 o'' + ((κ₁.repair a b c d v hsq).openCircuitCount) := by + rw [hsq2, one_mul] + _ = ((flipSignProd g L : ℤ) : ℂ) * + (((flipSignProd g L : ℤ) : ℂ) * + F.throughSummand hM + (stateOddFlipSet st (pairFold L)) hb2 o'' + ((κ₁.repair a b c d v hsq).openCircuitCount)) := + by ring + _ = ((flipSignProd g L : ℤ) : ℂ) * + (-1 * F.throughSummand hM st hbnd o₁ + κ₁.openCircuitCount) := by rw [h3] + _ = (((-1) ^ 1 * flipSignProd g L : ℤ) : ℂ) * + F.throughSummand hM st hbnd o₁ + κ₁.openCircuitCount := by + push_cast + ring + obtain ⟨o₂, hc₂, htrans₂⟩ := matchEq_canonical_transfer hM + (stateOddFlipSet st (pairFold L)) hb2 heq hcanon + refine ⟨o₂, L, 1, hc₂, ?_, ?_, ?_, ?_⟩ + · exact fun p hp => ne_of_lt (AntiLowPair.lt (hprov p hp)) + · rw [← statusDiff_matchEq_right heq] + apply Finset.ext + intro i + rw [mem_statusDiff, mem_pairFold_antiLow hprov hpw hlen] + exact antiLow_labels_eq_statusChange hsq hflip hc₁ hε₁ + hε₂ hcross hfar hout hint₁ hint₂' hintP₁ hintP₂ + · have hcardL := hlen.trans (antiLowSet_transport_card hsq + hflip hc₁ hε₁ hε₂ hne hPne hcross hfar hout hint₁ + hint₂' hintP₁ hintP₂) + have hdirs := swap_dirs_opposite hsq o₁ hflip hε₁ hcross + hint₁ + have i1 := chainDir_true_iff_high hc₁ hε₁ hint₁ + have i2 := chainDir_true_iff_high hc₁ hε₂ hint₂' + have hsep : (F.boundaryLabel (κ₁.pathMatch_mem hε₁) < + F.boundaryLabel hε₁) ≠ + (F.boundaryLabel (κ₁.pathMatch_mem hε₂) < + F.boundaryLabel hε₂) := by + cases hb : chainDir o₁ ε₁ + · rw [hb, Bool.not_false] at hdirs + refine prop_ne_of_right ?_ (i2.mp hdirs) + intro hlt + rw [i1.mpr hlt] at hb + cases hb + · rw [hb, Bool.not_true] at hdirs + refine prop_ne_of_left (i1.mp hb) ?_ + intro hlt + rw [i2.mpr hlt] at hdirs + cases hdirs + have hfour := fourLabel_parity_sep hLx_xb hLy_yb hLxy + hLx_yb hLxb_y hLxbyb hsep + omega + · exact htrans₂.trans hval' + +/-- **The per-step composed ledger**: across one repair step from a +canonical frame, the state relabel is `stateOddFlipSet` at the fold +of an explicit flip list `T` with `pairFold T = statusDiff κ₁ κ₂`, +the sign is `(−1)^tp · flipSignProd g T` at any colour function `g` +matching the state, and the flip count satisfies the crossing +parity `tp + |T| ≡ cc κ₁ + cc κ₂ (mod 2)`. -/ +theorem stepStatusLedger + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} {k : ℕ} {ℓ : ℕ} + (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ₁ κ₂ : F.RelTransitionSystem} (hstep : IsRepairStep κ₁ κ₂) + {o₁ : κ₁.Orientation} (hc₁ : PathCanonical o₁) + (g : α → Fin (2 * ℓ)) + (hg : ∀ i c, st i = Sum.inr c → g i = c) : + ∃ (o₂ : κ₂.Orientation) (T : List (α × α)) (tp : ℕ), + PathCanonical o₂ ∧ + (∀ p ∈ T, p.1 ≠ p.2) ∧ + pairFold T = statusDiff κ₁ κ₂ ∧ + (tp + T.length + chordCrossingCount κ₁ + + chordCrossingCount κ₂) % 2 = 0 ∧ + F.throughSummand hM (stateOddFlipSet st (pairFold T)) + (genBoundarySubsetMatches_stateOddFlipSet hbnd + (pairFold T)) o₂ κ₂.openCircuitCount = + (((-1) ^ tp * flipSignProd g T : ℤ) : ℂ) * + F.throughSummand hM st hbnd o₁ κ₁.openCircuitCount := by + obtain ⟨a, b, c, d, v, hsq, heq⟩ := hstep + by_cases hloc : SquareLocalized κ₁ a b c d + · -- ═══════ LOCALIZED SQUARE ═══════ + -- No relabel, no sign, and no status change: the step is + -- pairing-preserving, so the single-step ledger applies and the + -- flip list is empty. + have hmps : MatchPreservingStep κ₁ κ₂ := + ⟨a, b, c, d, v, hsq, RelTransitionSystem.MatchEq.symm heq, + pathMatch_repair_of_localized hsq hloc⟩ + obtain ⟨o₂, hc₂, hval⟩ := stepLedger_single hM st hbnd κ₁ κ₂ + hmps o₁ hc₁ + have hsp : SamePairing κ₁ κ₂ := samePairing_of_step hmps + have hps : pathSign κ₁ = pathSign κ₂ := + pathSign_of_samePairing hsp + have hnz : pathSign κ₂ ≠ 0 := by + unfold pathSign + exact pow_ne_zero _ (by norm_num) + refine ⟨o₂, [], 0, hc₂, ?_, ?_, ?_, ?_⟩ + · intro p hp + cases hp + · rw [pairFold_nil] + exact (statusDiff_of_samePairing hsp).symm + · have hcc := chordCrossingCount_of_samePairing hsp + simp only [List.length_nil] + omega + · have h1 : (((-1 : ℤ)) ^ 0 * flipSignProd g [] : ℤ) = 1 := by + rw [flipSignProd_nil] + norm_num + rw [pairFold_nil, h1, Int.cast_one, one_mul, + F.throughSummand_state_congr hM stateOddFlipSet_empty + (genBoundarySubsetMatches_stateOddFlipSet hbnd ∅) hbnd + o₂ κ₂.openCircuitCount] + rw [hps] at hval + exact mul_left_cancel₀ hnz hval + · -- ═══════ TWO-CHAIN SQUARE ═══════ + -- The repair transposes the boundary pairing at the two chain + -- ends `ε₁, ε₂`; the flip list is those two labels, and the + -- orientation splits into the separated and non-separated cases. + obtain ⟨ε₁, ε₂, hε₁, hε₂, hne, hPne, hcross, hfar, hout⟩ := + pathMatch_repair_swap hsq hloc + by_cases hsame : o₁.isOut c = o₁.isOut a + · exact stepStatusLedger_nonseparated hM st hbnd hc₁ g hg hsq heq hloc + hε₁ hε₂ hne hPne hcross hfar hout hsame + · exact stepStatusLedger_separated hM st hbnd hc₁ g hg hsq heq hloc + hε₁ hε₂ hne hPne hcross hfar hout hsame + +/-- **The chain status ledger**: fold the per-step ledger along a +repair chain — the relabel set is the status difference of the +endpoint stages, the sign is the explicit +`(−1)^tp · flipSignProd g T`, and the flip count carries the +crossing parity telescope. -/ +theorem chainStatusLedger + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} {k : ℕ} {ℓ : ℕ} + (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) {n : ℕ} + (chain : Fin (n + 1) → F.RelTransitionSystem) + (hstep : ∀ r : Fin n, + IsRepairStep (chain r.castSucc) (chain r.succ)) + {o₀ : (chain 0).Orientation} (hc₀ : PathCanonical o₀) + (g : α → Fin (2 * ℓ)) + (hg : ∀ i c, st i = Sum.inr c → g i = c) : + ∀ r : Fin (n + 1), + ∃ (oᵣ : (chain r).Orientation) (T : List (α × α)) (tp : ℕ), + PathCanonical oᵣ ∧ + (∀ p ∈ T, p.1 ≠ p.2) ∧ + pairFold T = statusDiff (chain 0) (chain r) ∧ + (tp + T.length + chordCrossingCount (chain 0) + + chordCrossingCount (chain r)) % 2 = 0 ∧ + F.throughSummand hM (stateOddFlipSet st (pairFold T)) + (genBoundarySubsetMatches_stateOddFlipSet hbnd + (pairFold T)) oᵣ (chain r).openCircuitCount = + (((-1) ^ tp * flipSignProd g T : ℤ) : ℂ) * + F.throughSummand hM st hbnd o₀ + (chain 0).openCircuitCount := by + intro r + induction r using Fin.induction with + | zero => + refine ⟨o₀, [], 0, hc₀, ?_, ?_, ?_, ?_⟩ + · intro p hp + cases hp + · rw [pairFold_nil] + exact (statusDiff_self _).symm + · simp only [List.length_nil] + omega + · have h1 : (((-1 : ℤ)) ^ 0 * flipSignProd g [] : ℤ) = 1 := by + rw [flipSignProd_nil] + norm_num + rw [pairFold_nil, h1, Int.cast_one, one_mul] + exact F.throughSummand_state_congr hM stateOddFlipSet_empty + (genBoundarySubsetMatches_stateOddFlipSet hbnd ∅) hbnd o₀ + (chain 0).openCircuitCount + | succ r ih => + obtain ⟨oᵣ, T, tp, hcᵣ, hdT, hSD, hpar, hval⟩ := ih + have hgr := flipColoursFold_matches hg hdT + obtain ⟨o', T', tp', hc', hdT', hSD', hpar', hval'⟩ := + stepStatusLedger hM (stateOddFlipSet st (pairFold T)) + (genBoundarySubsetMatches_stateOddFlipSet hbnd + (pairFold T)) (hstep r) hcᵣ (flipColoursFold g T) hgr + refine ⟨o', T ++ T', tp + tp', hc', ?_, ?_, ?_, ?_⟩ + · intro p hp + rcases List.mem_append.mp hp with h | h + · exact hdT p h + · exact hdT' p h + · rw [pairFold_append, hSD, hSD'] + exact statusDiff_trans _ _ _ + · rw [List.length_append] + omega + · have hstEq : stateOddFlipSet st (pairFold (T ++ T')) = + stateOddFlipSet (stateOddFlipSet st (pairFold T)) + (pairFold T') := by + rw [stateOddFlipSet_symmU, pairFold_append] + have hb1 := genBoundarySubsetMatches_stateOddFlipSet + (genBoundarySubsetMatches_stateOddFlipSet hbnd + (pairFold T)) (pairFold T') + have hb2 := genBoundarySubsetMatches_stateOddFlipSet hbnd + (pairFold (T ++ T')) + have hsign : (((-1) ^ (tp + tp') * + flipSignProd g (T ++ T') : ℤ) : ℂ) = + (((-1) ^ tp' * flipSignProd (flipColoursFold g T) T' : + ℤ) : ℂ) * + (((-1) ^ tp * flipSignProd g T : ℤ) : ℂ) := by + rw [flipSignProd_append, pow_add] + push_cast + ring + calc F.throughSummand hM + (stateOddFlipSet st (pairFold (T ++ T'))) hb2 o' + (chain r.succ).openCircuitCount + = F.throughSummand hM + (stateOddFlipSet (stateOddFlipSet st (pairFold T)) + (pairFold T')) hb1 o' + (chain r.succ).openCircuitCount := + F.throughSummand_state_congr hM hstEq hb2 hb1 o' _ + _ = (((-1) ^ tp' * + flipSignProd (flipColoursFold g T) T' : ℤ) : ℂ) * + F.throughSummand hM + (stateOddFlipSet st (pairFold T)) + (genBoundarySubsetMatches_stateOddFlipSet hbnd + (pairFold T)) oᵣ + (chain r.castSucc).openCircuitCount := hval' + _ = (((-1) ^ tp' * + flipSignProd (flipColoursFold g T) T' : ℤ) : ℂ) * + ((((-1) ^ tp * flipSignProd g T : ℤ) : ℂ) * + F.throughSummand hM st hbnd o₀ + (chain 0).openCircuitCount) := by rw [hval] + _ = (((-1) ^ (tp + tp') * + flipSignProd g (T ++ T') : ℤ) : ℂ) * + F.throughSummand hM st hbnd o₀ + (chain 0).openCircuitCount := by + rw [hsign] + ring + +end StepLemma + +end EdgeSubset + +/-! ## The paired assembly -/ + +open EdgeSubset in +/-- **The paired step, unsigned form**: across any π-returning +repair block, a canonical frame carries to a canonical frame with +the *same* summand at the *same* state — the accumulated relabel is +the (empty) status difference of the endpoints, and the accumulated +sign telescopes to `+1` through the crossing-parity ledger. -/ +theorem pairedLedgerUnsigned : PairedLedgerUnsigned := by + intro α _ W F k ℓ hM st hbnd κ₁ κ₂ hps o₁ hc₁ + obtain ⟨⟨n, chain, h0, hlast, hstep⟩, hsp⟩ := hps + have hsp0n : SamePairing (chain 0) (chain (Fin.last n)) := + ((samePairing_of_matchEq h0).trans hsp).trans + (samePairing_of_matchEq hlast).symm + have hcc0n : chordCrossingCount (chain 0) = + chordCrossingCount (chain (Fin.last n)) := + chordCrossingCount_of_samePairing hsp0n + obtain ⟨o₀, hc₀, hval₀⟩ := matchEq_canonical_transfer hM st hbnd + (RelTransitionSystem.MatchEq.symm h0) hc₁ + by_cases hcol : Nonempty (Fin (2 * ℓ)) + · -- the colour function matching the state + have hex : ∀ i : α, ∃ cc : Fin (2 * ℓ), + ∀ c0, st i = Sum.inr c0 → cc = c0 := by + intro i + rcases hsi : st i with a | c0 + · obtain ⟨c₀⟩ := hcol + refine ⟨c₀, fun c0 h => ?_⟩ + simp at h + · refine ⟨c0, fun c0' h => ?_⟩ + exact Sum.inr.inj h + choose g hgspec using hex + have hg : ∀ i c0, st i = Sum.inr c0 → g i = c0 := + fun i c0 h => hgspec i c0 h + obtain ⟨oₙ, T, tp, hcₙ, hdT, hSD, hpar, hval⟩ := + chainStatusLedger hM st hbnd chain hstep hc₀ g hg + (Fin.last n) + have hSDnil : pairFold T = ∅ := by + rw [hSD] + exact statusDiff_of_samePairing hsp0n + have hodd : oddCountLabels T = ∅ := by + rw [← pairFold_eq_oddCountLabels hdT] + exact hSDnil + have hprodT : flipSignProd g T = (-1) ^ T.length := by + refine flipSignProd_of_even g T hdT fun a => ?_ + by_contra hne0 + have h2 : a ∈ oddCountLabels T := + mem_oddCountLabels.mpr (by omega) + rw [hodd] at h2 + exact Finset.notMem_empty a h2 + have hsign1 : (((-1) ^ tp * flipSignProd g T : ℤ) : ℂ) = + 1 := by + obtain ⟨m, hm⟩ : ∃ m, tp + T.length = 2 * m := + ⟨(tp + T.length) / 2, by omega⟩ + rw [hprodT, ← pow_add, hm, pow_mul] + norm_num + rw [hSDnil] at hval + have hstid := F.throughSummand_state_congr hM + stateOddFlipSet_empty + (genBoundarySubsetMatches_stateOddFlipSet hbnd ∅) hbnd oₙ + (chain (Fin.last n)).openCircuitCount + obtain ⟨o₂, hc₂, hval₂⟩ := matchEq_canonical_transfer hM st + hbnd hlast hcₙ + refine ⟨o₂, hc₂, ?_⟩ + rw [hval₂, ← hstid, hval, hsign1, one_mul, hval₀] + · -- degenerate: no odd colours, hence no boundary flags and + -- every step is match-preserving + have hbf : F.boundaryFlags = ∅ := by + refine Finset.eq_empty_of_forall_notMem fun β hβ => ?_ + obtain ⟨i, hi⟩ := F.attach_boundary_of_mem hβ + have hflag : W.boundaryFlag i ∈ F.flags := by + rw [← W.eq_boundaryFlag i β hi] + exact mem_flags_of_boundaryFlags F hβ + obtain ⟨cc, -⟩ := (hbnd i).mp hflag + exact hcol ⟨cc⟩ + have hmp : ∀ r : Fin n, + MatchPreservingStep (chain r.castSucc) (chain r.succ) := by + intro r + obtain ⟨a, b, c, d, v, hsq, heq⟩ := hstep r + by_cases hl : SquareLocalized (chain r.castSucc) a b c d + · exact ⟨a, b, c, d, v, hsq, + RelTransitionSystem.MatchEq.symm heq, + pathMatch_repair_of_localized hsq hl⟩ + · exfalso + obtain ⟨β₁, β₂, hβ₁, hβ₂, -, -, -, -⟩ := + twoChains_of_not_localized hsq hl + rw [hbf] at hβ₁ + exact Finset.notMem_empty β₁ hβ₁ + have hcarry : ∀ r : Fin (n + 1), + ∃ oᵣ : (chain r).Orientation, PathCanonical oᵣ ∧ + pathSign (chain r) * + F.throughSummand hM st hbnd oᵣ + (chain r).openCircuitCount = + pathSign (chain 0) * + F.throughSummand hM st hbnd o₀ + (chain 0).openCircuitCount := by + intro r + induction r using Fin.induction with + | zero => exact ⟨o₀, hc₀, rfl⟩ + | succ r ih => + obtain ⟨oᵣ, hcᵣ, hvᵣ⟩ := ih + obtain ⟨o', hc', hv'⟩ := stepLedger_single hM st hbnd _ _ + (hmp r) oᵣ hcᵣ + exact ⟨o', hc', hv'.trans hvᵣ⟩ + obtain ⟨oₙ, hcₙ, hvₙ⟩ := hcarry (Fin.last n) + have hps0 : pathSign (chain 0) = + pathSign (chain (Fin.last n)) := + pathSign_of_samePairing hsp0n + have hnz : pathSign (chain (Fin.last n)) ≠ 0 := by + unfold pathSign + exact pow_ne_zero _ (by norm_num) + rw [hps0] at hvₙ + have hveq : F.throughSummand hM st hbnd oₙ + (chain (Fin.last n)).openCircuitCount = + F.throughSummand hM st hbnd o₀ + (chain 0).openCircuitCount := + mul_left_cancel₀ hnz hvₙ + obtain ⟨o₂, hc₂, hval₂⟩ := matchEq_canonical_transfer hM st + hbnd hlast hcₙ + exact ⟨o₂, hc₂, by rw [hval₂, hveq, hval₀]⟩ + +/-- **The paired step**: the last input of Proposition 3's +per-π well-definedness — across any π-returning repair block the +`pathSign`-weighted canonical summand is preserved. -/ +theorem pairedLedger : EdgeSubset.PairedLedger := + EdgeSubset.pairedLedger_iff_unsigned.mpr pairedLedgerUnsigned + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingConnectivity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingConnectivity.lean new file mode 100644 index 0000000000..b8b0180970 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingConnectivity.lean @@ -0,0 +1,258 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger + +/-! +# Pairing-preserving connectivity + +The pairing-resolved value is well-defined once systems inducing +the same boundary pairing are connected by pairing-preserving +repair steps. This file fixes the +step relation and the connectivity statement, proves that +localized repairs qualify, and derives the same-pairing invariance +of the signed summand from connectivity and the per-step ledger. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} + +namespace EdgeSubset + +/-- Two systems induce the same boundary pairing. -/ +def SamePairing {W : Fragment α} {F : EdgeSubset W} + (κ κ' : F.RelTransitionSystem) : Prop := + ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + κ.pathMatch δ hδ = κ'.pathMatch δ hδ + +/-- Inducing the same boundary pairing is reflexive. -/ +theorem SamePairing.refl {W : Fragment α} {F : EdgeSubset W} + (κ : F.RelTransitionSystem) : + SamePairing κ κ := fun _ _ => rfl + +/-- It is symmetric. -/ +theorem SamePairing.symm {W : Fragment α} {F : EdgeSubset W} + {κ κ' : F.RelTransitionSystem} + (h : SamePairing κ κ') : SamePairing κ' κ := + fun δ hδ => (h δ hδ).symm + +/-- And transitive — an equivalence on transition systems. -/ +theorem SamePairing.trans {W : Fragment α} {F : EdgeSubset W} + {κ₁ κ₂ κ₃ : F.RelTransitionSystem} + (h : SamePairing κ₁ κ₂) (h' : SamePairing κ₂ κ₃) : + SamePairing κ₁ κ₃ := + fun δ hδ => (h δ hδ).trans (h' δ hδ) + +/-- A repair step that preserves the boundary pairing. -/ +def MatchPreservingStep {W : Fragment α} {F : EdgeSubset W} + (κ₁ κ₂ : F.RelTransitionSystem) : Prop := + ∃ (a b c d : W.Flag) (v : W.Vertex) + (hsq : RepairSquare κ₁ a b c d v), + κ₂.MatchEq (κ₁.repair a b c d v hsq) ∧ + ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + (κ₁.repair a b c d v hsq).pathMatch δ hδ = + κ₁.pathMatch δ hδ + +/-- A pairing-preserving step indeed preserves the pairing. -/ +theorem samePairing_of_step {W : Fragment α} {F : EdgeSubset W} + {κ₁ κ₂ : F.RelTransitionSystem} + (h : MatchPreservingStep κ₁ κ₂) : SamePairing κ₁ κ₂ := by + obtain ⟨a, b, c, d, v, hsq, heq, hpres⟩ := h + intro δ hδ + rw [← hpres δ hδ] + exact pathMatch_matchEq heq hδ + +/-- A composite move: a repair block whose net effect preserves +the boundary pairing (individual repairs may cross two chains and +change it; the double-crossing example shows single-step +connectivity fails, and non-adjacent restorations force general +blocks rather than pairs). -/ +def PairedStep {W : Fragment α} {F : EdgeSubset W} + (κ₁ κ₂ : F.RelTransitionSystem) : Prop := + (∃ (n : ℕ) (chain : Fin (n + 1) → F.RelTransitionSystem), + (chain 0).MatchEq κ₁ ∧ (chain (Fin.last n)).MatchEq κ₂ ∧ + ∀ r : Fin n, IsRepairStep (chain r.castSucc) (chain r.succ)) ∧ + SamePairing κ₁ κ₂ + +/-- A pairing-preserving move: a single preserved step or a +π-restoring pair. -/ +def MatchPreservingMove {W : Fragment α} {F : EdgeSubset W} + (κ₁ κ₂ : F.RelTransitionSystem) : Prop := + MatchPreservingStep κ₁ κ₂ ∨ PairedStep κ₁ κ₂ + +/-- **The connectivity statement** (the keystone, move form): +systems with the same boundary pairing are connected by +pairing-preserving moves, up to match-equality at the endpoints. +(Single steps do not suffice: the double-crossing configuration +disconnects the fibre.) -/ +def PairingConnectivity : Prop := + ∀ {α : Type} [LinearOrder α] {W : Fragment α} + {F : EdgeSubset W} (κ κ' : F.RelTransitionSystem), + SamePairing κ κ' → + ∃ (n : ℕ) (chain : Fin (n + 1) → F.RelTransitionSystem), + (chain 0).MatchEq κ ∧ (chain (Fin.last n)).MatchEq κ' ∧ + ∀ r : Fin n, + MatchPreservingMove (chain r.castSucc) (chain r.succ) + +/-- **Connectivity is a theorem in the block form**: any repair +chain between same-pairing systems is a single pairing-preserving +move, so the general connectivity of `TransitionMove` suffices. -/ +theorem pairingConnectivity : PairingConnectivity := by + intro α _ W F κ κ' hsp + refine ⟨1, ![κ, κ'], RelTransitionSystem.MatchEq.refl κ, + RelTransitionSystem.MatchEq.refl κ', ?_⟩ + intro r + have hr : r = 0 := Subsingleton.elim r 0 + subst hr + right + refine ⟨?_, hsp⟩ + obtain ⟨n, chain, h0, hlast, hstep⟩ := repair_connectivity κ κ' + exact ⟨n, chain, h0, hlast, hstep⟩ + +/-- **The per-step ledger interface**: every pairing-preserving +step preserves the signed canonical summand (dischargeable from +the localized/non-separated ledgers plus the orbit +parities; two-path moves change the pairing and are excluded by +the step relation). -/ +def MatchPreservingLedger : Prop := + ∀ {α : Type} [LinearOrder α] {W : Fragment α} + {F : EdgeSubset W} {k ℓ : ℕ} (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (κ₁ κ₂ : F.RelTransitionSystem), + MatchPreservingMove κ₁ κ₂ → + ∀ (o₁ : κ₁.Orientation), PathCanonical o₁ → + ∃ (o₂ : κ₂.Orientation), PathCanonical o₂ ∧ + pathSign κ₂ * + F.throughSummand hM st hbnd o₂ κ₂.openCircuitCount = + pathSign κ₁ * + F.throughSummand hM st hbnd o₁ κ₁.openCircuitCount + +/-- The `MatchEq` layer for the signed canonical summand. -/ +theorem signed_summand_matchEq + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {k ℓ : ℕ} + (hM : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ₁ κ₂ : F.RelTransitionSystem} + (heq : κ₁.MatchEq κ₂) (o₁ : κ₁.Orientation) : + ∃ o₂ : κ₂.Orientation, + pathSign κ₂ * + F.throughSummand hM st hbnd o₂ κ₂.openCircuitCount = + pathSign κ₁ * + F.throughSummand hM st hbnd o₁ κ₁.openCircuitCount := by + refine ⟨RelTransitionSystem.Orientation.ofMatchEq heq o₁, ?_⟩ + rw [← pathSign_matchEq heq, ← openCircuitCount_matchEq heq] + exact congrArg (fun x => pathSign κ₂ * x) + (throughSummand_ofMatchEq hM st hbnd heq o₁ + κ₂.openCircuitCount) + +/-- The forward-carried chain induction: along a chain of +pairing-preserving steps, a canonical orientation and the signed +value propagate from the base. -/ +theorem chain_carry [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + (HLedger : MatchPreservingLedger) + {k ℓ : ℕ} (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ : F.RelTransitionSystem} + (o : κ.Orientation) (hc : PathCanonical o) + {n : ℕ} (chain : Fin (n + 1) → F.RelTransitionSystem) + (h0 : (chain 0).MatchEq κ) + (hstep : ∀ r : Fin n, + MatchPreservingMove (chain r.castSucc) (chain r.succ)) : + ∀ r : Fin (n + 1), + ∃ (oᵣ : (chain r).Orientation), PathCanonical oᵣ ∧ + pathSign (chain r) * + F.throughSummand hM st hbnd oᵣ + (chain r).openCircuitCount = + pathSign κ * + F.throughSummand hM st hbnd o κ.openCircuitCount := by + intro r + induction r using Fin.induction with + | zero => + refine ⟨RelTransitionSystem.Orientation.ofMatchEq + (RelTransitionSystem.MatchEq.symm h0) o, ?_, ?_⟩ + · intro i j hb hint hpm hij + exact hc i j hb hint (by + rw [← pathMatch_matchEq + (RelTransitionSystem.MatchEq.symm h0) + (δ := W.boundaryFlag i) hb] + exact hpm) hij + · rw [← pathSign_matchEq (RelTransitionSystem.MatchEq.symm h0), + ← openCircuitCount_matchEq + (RelTransitionSystem.MatchEq.symm h0)] + exact congrArg (fun x => pathSign (chain 0) * x) + (throughSummand_ofMatchEq hM st hbnd + (RelTransitionSystem.MatchEq.symm h0) o + (chain 0).openCircuitCount) + | succ r ih => + obtain ⟨oprev, hcprev, hprev⟩ := ih + obtain ⟨o₂, hc₂, hstepval⟩ := HLedger hM st hbnd _ _ + (hstep r) oprev hcprev + exact ⟨o₂, hc₂, hstepval.trans hprev⟩ + +/-- The endpoint transfer: a canonical orientation and the signed +value cross a `MatchEq` to the target system. -/ +theorem endpoint_transfer [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {k ℓ : ℕ} + (hM : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ₁ κ' : F.RelTransitionSystem} (hlast : κ₁.MatchEq κ') + (olast : κ₁.Orientation) (hclast : PathCanonical olast) : + ∃ oκ' : κ'.Orientation, PathCanonical oκ' ∧ + pathSign κ' * + F.throughSummand hM st hbnd oκ' κ'.openCircuitCount = + pathSign κ₁ * + F.throughSummand hM st hbnd olast + κ₁.openCircuitCount := by + refine ⟨RelTransitionSystem.Orientation.ofMatchEq hlast olast, + ?_, ?_⟩ + · intro i j hb hint hpm hij + exact hclast i j hb hint (by + rw [← pathMatch_matchEq hlast (δ := W.boundaryFlag i) hb] + exact hpm) hij + · rw [← pathSign_matchEq hlast, ← openCircuitCount_matchEq hlast] + exact congrArg (fun x => pathSign κ' * x) + (throughSummand_ofMatchEq hM st hbnd hlast olast + κ'.openCircuitCount) + +/-- **Same-pairing invariance from connectivity and the step +ledger**: with these two inputs the signed canonical summand +depends only on the boundary pairing — the well-definedness of the +pairing-resolved value. -/ +theorem samePairing_invariance_of + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + (HConn : PairingConnectivity) + (HLedger : MatchPreservingLedger) + {k ℓ : ℕ} (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (κ κ' : F.RelTransitionSystem) (hsp : SamePairing κ κ') + (o : κ.Orientation) (hc : PathCanonical o) + (o' : κ'.Orientation) (hc' : PathCanonical o') : + pathSign κ * F.throughSummand hM st hbnd o κ.openCircuitCount = + pathSign κ' * + F.throughSummand hM st hbnd o' κ'.openCircuitCount := by + obtain ⟨n, chain, h0, hlast, hstep⟩ := HConn κ κ' hsp + obtain ⟨olast, hclast, hval⟩ := + chain_carry HLedger hM st hbnd o hc chain h0 hstep (Fin.last n) + obtain ⟨oκ', hcκ', hvalκ'⟩ := + endpoint_transfer hM st hbnd hlast olast hclast + exact hval.symm.trans (hvalκ'.symm.trans + (congrArg (fun x => pathSign κ' * x) + (throughSummand_pathCanonical hM st hbnd hcκ' hc' _))) + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSignature.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSignature.lean new file mode 100644 index 0000000000..2e373685c3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSignature.lean @@ -0,0 +1,62 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingConnectivity + +/-! +# The chord data is a function of the pairing + +Systems with the same boundary pairing have the same chord-crossing +count, hence the same path sign: `pathSign` telescopes freely along +pairing-preserving blocks, and around any pairing-returning loop of +repairs the crossing count returns — the parity backbone of the +holonomy bookkeeping. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} + +namespace EdgeSubset + +/-- The crossing relation only sees the pairing. -/ +theorem chordCross_of_samePairing + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ κ' : F.RelTransitionSystem} + (h : SamePairing κ κ') + (b b' : {x : W.Flag // x ∈ F.boundaryFlags}) : + ChordCross κ b b' ↔ ChordCross κ' b b' := by + unfold ChordCross + rw [h b.val b.prop, h b'.val b'.prop] + +open scoped Classical in +/-- **The crossing count is a pairing invariant.** -/ +theorem chordCrossingCount_of_samePairing + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ κ' : F.RelTransitionSystem} (h : SamePairing κ κ') : + chordCrossingCount κ = chordCrossingCount κ' := by + unfold chordCrossingCount + exact congrArg Finset.card (Finset.filter_congr + (fun bb _ => chordCross_of_samePairing h bb.1 bb.2)) + +/-- **The path sign is a pairing invariant**: around any +pairing-returning block the chord signs cancel. -/ +theorem pathSign_of_samePairing + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ κ' : F.RelTransitionSystem} + (h : SamePairing κ κ') : pathSign κ = pathSign κ' := + congrArg (fun n => ((-1 : ℂ)) ^ n) + (chordCrossingCount_of_samePairing h) + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSwap.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSwap.lean new file mode 100644 index 0000000000..7213cba815 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSwap.lean @@ -0,0 +1,291 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepLedger + +/-! +# The pairing transposition of a non-localized repair + +A non-localized repair square touches two genuinely distinct +boundary chords. The repaired matching pairs one end of the first +chord with one end of the second, pairs the two remaining ends with +each other, and agrees with the old matching everywhere else: the +boundary pairing changes by conjugation with a transposition of two +ends of distinct chords. This is the algebraic heart of the +holonomy programme — repair words act on boundary pairings through +transposition conjugations. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} + +namespace EdgeSubset + +/-- Once two ends of distinct chords re-pair and every end off the +two chords keeps its match, the two far ends must re-pair with each +other: elimination over the fixed-point-free involution. -/ +private theorem far_ends_pair + {W : Fragment α} {F : EdgeSubset W} {κ : F.RelTransitionSystem} + (κ' : F.RelTransitionSystem) + {e₁ e₂ : W.Flag} (he₁ : e₁ ∈ F.boundaryFlags) + (he₂ : e₂ ∈ F.boundaryFlags) + (hP₁2 : κ.pathMatch e₁ he₁ ≠ e₂) + (hcross : κ'.pathMatch e₁ he₁ = e₂) + (hout : ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + δ ≠ e₁ → δ ≠ e₂ → δ ≠ κ.pathMatch e₁ he₁ → + δ ≠ κ.pathMatch e₂ he₂ → + κ'.pathMatch δ hδ = κ.pathMatch δ hδ) : + κ'.pathMatch (κ.pathMatch e₁ he₁) (κ.pathMatch_mem he₁) = + κ.pathMatch e₂ he₂ := by + have hP₁mem : κ.pathMatch e₁ he₁ ∈ F.boundaryFlags := + κ.pathMatch_mem he₁ + have hcross' : κ'.pathMatch e₂ he₂ = e₁ := + (κ'.pathMatch_congr hcross.symm he₂ + (κ'.pathMatch_mem he₁)).trans (κ'.pathMatch_invol he₁) + by_contra hne + have hδmem : κ'.pathMatch (κ.pathMatch e₁ he₁) hP₁mem ∈ + F.boundaryFlags := κ'.pathMatch_mem hP₁mem + have hδinv : κ'.pathMatch (κ'.pathMatch (κ.pathMatch e₁ he₁) + hP₁mem) hδmem = κ.pathMatch e₁ he₁ := + κ'.pathMatch_invol hP₁mem + have hδe₁ : κ'.pathMatch (κ.pathMatch e₁ he₁) hP₁mem ≠ e₁ := by + intro he + have h1 : κ'.pathMatch e₁ he₁ = κ.pathMatch e₁ he₁ := + (κ'.pathMatch_congr he.symm he₁ hδmem).trans hδinv + exact hP₁2 (h1.symm.trans hcross) + have hδe₂ : κ'.pathMatch (κ.pathMatch e₁ he₁) hP₁mem ≠ e₂ := by + intro he + have h1 : κ'.pathMatch e₂ he₂ = κ.pathMatch e₁ he₁ := + (κ'.pathMatch_congr he.symm he₂ hδmem).trans hδinv + exact κ.pathMatch_ne_self he₁ (hcross'.symm.trans h1).symm + have hpres := hout _ hδmem hδe₁ hδe₂ + (κ'.pathMatch_ne_self hP₁mem) hne + have h2 : κ.pathMatch (κ'.pathMatch (κ.pathMatch e₁ he₁) + hP₁mem) hδmem = κ.pathMatch e₁ he₁ := + hpres.symm.trans hδinv + have h3 : κ'.pathMatch (κ.pathMatch e₁ he₁) hP₁mem = e₁ := + ((κ.pathMatch_invol hδmem).symm.trans + (κ.pathMatch_congr h2 (κ.pathMatch_mem hδmem) + hP₁mem)).trans (κ.pathMatch_invol he₁) + exact hδe₁ h3 + +/-- **The pairing transposition**: a non-localized repair square +re-pairs one end of each of its two distinct boundary chords with +one end of the other, re-pairs the two far ends with each other, +and preserves every other path match — the boundary pairing changes +by conjugation with a transposition. -/ +theorem pathMatch_repair_swap + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) + (hnl : ¬ SquareLocalized κ a b c d) : + ∃ (e₁ e₂ : W.Flag) (he₁ : e₁ ∈ F.boundaryFlags) + (he₂ : e₂ ∈ F.boundaryFlags), + e₁ ≠ e₂ ∧ κ.pathMatch e₁ he₁ ≠ e₂ ∧ + (κ.repair a b c d v hsq).pathMatch e₁ he₁ = e₂ ∧ + (κ.repair a b c d v hsq).pathMatch (κ.pathMatch e₁ he₁) + (κ.pathMatch_mem he₁) = κ.pathMatch e₂ he₂ ∧ + ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + δ ≠ e₁ → δ ≠ e₂ → δ ≠ κ.pathMatch e₁ he₁ → + δ ≠ κ.pathMatch e₂ he₂ → + (κ.repair a b c d v hsq).pathMatch δ hδ = + κ.pathMatch δ hδ := by + obtain ⟨β₁, β₂, hβ₁, hβ₂, hca, hcc, h21, h2γ⟩ := + twoChains_of_not_localized hsq hnl + have h12 : β₁ ≠ β₂ := Ne.symm h21 + have hγ₁mem : κ.pathMatch β₁ hβ₁ ∈ F.boundaryFlags := + κ.pathMatch_mem hβ₁ + have hγ₂mem : κ.pathMatch β₂ hβ₂ ∈ F.boundaryFlags := + κ.pathMatch_mem hβ₂ + have h1γ2 : β₁ ≠ κ.pathMatch β₂ hβ₂ := by + intro he + apply h2γ + have h3 := κ.pathMatch_congr he hβ₁ hγ₂mem + exact (h3.trans (κ.pathMatch_invol hβ₂)).symm + have hγ2γ1 : κ.pathMatch β₂ hβ₂ ≠ κ.pathMatch β₁ hβ₁ := by + intro he + apply h21 + have h3 := κ.pathMatch_congr he hγ₂mem hγ₁mem + exact ((κ.pathMatch_invol hβ₂).symm.trans h3).trans + (κ.pathMatch_invol hβ₁) + have hγ1β2 : κ.pathMatch β₁ hβ₁ ≠ β₂ := fun he => h2γ he.symm + have hinv₁ : κ.pathMatch (κ.pathMatch β₁ hβ₁) hγ₁mem = β₁ := + κ.pathMatch_invol hβ₁ + have hinv₂ : κ.pathMatch (κ.pathMatch β₂ hβ₂) hγ₂mem = β₂ := + κ.pathMatch_invol hβ₂ + have hcb : OnBoundaryChain κ β₁ b := + hsq.hab ▸ onBoundaryChain_match hβ₁ hsq.ha hca + have hcd : OnBoundaryChain κ β₂ d := + hsq.hcd ▸ onBoundaryChain_match hβ₂ hsq.hc hcc + -- canonical chain data and normalized square positions + obtain ⟨k₁, hk₁le, hcont₁, hterm₁⟩ := + chain_terminates_with_data κ hβ₁ + obtain ⟨k₂, hk₂le, hcont₂, hterm₂⟩ := + chain_terminates_with_data κ hβ₂ + have hγ₁w : κ.pathMatch β₁ hβ₁ = + W.pairing (iterWalk κ β₁ k₁) := + pathMatch_eq_of_chain κ hβ₁ hcont₁ hterm₁ + have hγ₂w : κ.pathMatch β₂ hβ₂ = + W.pairing (iterWalk κ β₂ k₂) := + pathMatch_eq_of_chain κ hβ₂ hcont₂ hterm₂ + have hpa : ∃ t ≤ k₁, a = iterWalk κ β₁ t ∨ + a = W.pairing (iterWalk κ β₁ t) := by + obtain ⟨k', t, htk', hcont', hterm', hft⟩ := hca + have hk : k' = k₁ := + chain_exit_unique hcont' hterm' hcont₁ hterm₁ + exact ⟨t, hk ▸ htk', hft⟩ + have hpb : ∃ t ≤ k₁, b = iterWalk κ β₁ t ∨ + b = W.pairing (iterWalk κ β₁ t) := by + obtain ⟨k', t, htk', hcont', hterm', hft⟩ := hcb + have hk : k' = k₁ := + chain_exit_unique hcont' hterm' hcont₁ hterm₁ + exact ⟨t, hk ▸ htk', hft⟩ + have hpc : ∃ t ≤ k₂, c = iterWalk κ β₂ t ∨ + c = W.pairing (iterWalk κ β₂ t) := by + obtain ⟨k', t, htk', hcont', hterm', hft⟩ := hcc + have hk : k' = k₂ := + chain_exit_unique hcont' hterm' hcont₂ hterm₂ + exact ⟨t, hk ▸ htk', hft⟩ + have hpd : ∃ t ≤ k₂, d = iterWalk κ β₂ t ∨ + d = W.pairing (iterWalk κ β₂ t) := by + obtain ⟨k', t, htk', hcont', hterm', hft⟩ := hcd + have hk : k' = k₂ := + chain_exit_unique hcont' hterm' hcont₂ hterm₂ + exact ⟨t, hk ▸ htk', hft⟩ + -- untouched chains avoid the square by rigidity + have hout : ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + δ ≠ β₁ → δ ≠ κ.pathMatch β₁ hβ₁ → δ ≠ β₂ → + δ ≠ κ.pathMatch β₂ hβ₂ → + (κ.repair a b c d v hsq).pathMatch δ hδ = + κ.pathMatch δ hδ := by + intro δ hδ h1 h2 h3 h4 + rw [hγ₁w] at h2 + rw [hγ₂w] at h4 + obtain ⟨kδ, hkδ, hcontδ, htermδ⟩ := + chain_terminates_with_data κ hδ + refine pathMatch_repair_of_avoid hsq hδ hkδ hcontδ htermδ ?_ + intro s hs + obtain ⟨ta, hta, hfa⟩ := hpa + obtain ⟨tb, htb, hfb⟩ := hpb + obtain ⟨tc, htc, hfc⟩ := hpc + obtain ⟨td, htd, hfd⟩ := hpd + exact ⟨chain_arg_ne_of_onChain hβ₁ hδ hcont₁ hterm₁ hcontδ + h1 h2 hta hfa hs, + chain_arg_ne_of_onChain hβ₁ hδ hcont₁ hterm₁ hcontδ + h1 h2 htb hfb hs, + chain_arg_ne_of_onChain hβ₂ hδ hcont₂ hterm₂ hcontδ + h3 h4 htc hfc hs, + chain_arg_ne_of_onChain hβ₂ hδ hcont₂ hterm₂ hcontδ + h3 h4 htd hfd hs⟩ + -- the square hits: each chain family carries the square to the + -- repaired chain of one of its ends + have hA := hit_membership hsq hβ₁ hβ₂ h12 h1γ2 hsq.ha hsq.hab + hca hcc hcd (fun g => Iff.rfl) + have hswap4 : ∀ g : W.Flag, + (g = a ∨ g = b ∨ g = c ∨ g = d) ↔ + (g = c ∨ g = d ∨ g = a ∨ g = b) := fun g => + ⟨fun h => h.elim (fun h => Or.inr (Or.inr (Or.inl h))) + (fun h => h.elim (fun h => Or.inr (Or.inr (Or.inr h))) + (fun h => h.elim Or.inl fun h => Or.inr (Or.inl h))), + fun h => h.elim (fun h => Or.inr (Or.inr (Or.inl h))) + (fun h => h.elim (fun h => Or.inr (Or.inr (Or.inr h))) + (fun h => h.elim Or.inl fun h => Or.inr (Or.inl h)))⟩ + have hC := hit_membership hsq hβ₂ hβ₁ h21 h2γ hsq.hc hsq.hcd + hcc hca hcb hswap4 + have honc : ∀ {e : W.Flag}, e ∈ F.boundaryFlags → + OnBoundaryChain (κ.repair a b c d v hsq) e a → + OnBoundaryChain (κ.repair a b c d v hsq) e c := by + intro e he h + have h2 := onBoundaryChain_match + (κ := κ.repair a b c d v hsq) he hsq.ha h + rwa [RelTransitionSystem.repair_match_a hsq] at h2 + rcases hA with h₁ | h₁ <;> rcases hC with h₂ | h₂ + · -- ═══════ NEAR ENDS β₁ ↔ β₂ ═══════ + have hcross : (κ.repair a b c d v hsq).pathMatch β₁ hβ₁ = + β₂ := by + by_contra hne + exact onBoundaryChain_disjoint hβ₁ hβ₂ h21 + (fun h => hne h.symm) (honc hβ₁ h₁) h₂ + have hout' : ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + δ ≠ β₁ → δ ≠ β₂ → δ ≠ κ.pathMatch β₁ hβ₁ → + δ ≠ κ.pathMatch β₂ hβ₂ → + (κ.repair a b c d v hsq).pathMatch δ hδ = + κ.pathMatch δ hδ := + fun δ hδ q1 q2 q3 q4 => hout δ hδ q1 q3 q2 q4 + exact ⟨β₁, β₂, hβ₁, hβ₂, h12, hγ1β2, hcross, + far_ends_pair (κ.repair a b c d v hsq) hβ₁ hβ₂ hγ1β2 + hcross hout', hout'⟩ + · -- ═══════ NEAR ENDS β₁ ↔ pathMatch β₂ ═══════ + have hcross : (κ.repair a b c d v hsq).pathMatch β₁ hβ₁ = + κ.pathMatch β₂ hβ₂ := by + by_contra hne + exact onBoundaryChain_disjoint hβ₁ hγ₂mem + (fun he => h1γ2 he.symm) (fun h => hne h.symm) + (honc hβ₁ h₁) h₂ + have hout' : ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + δ ≠ β₁ → δ ≠ κ.pathMatch β₂ hβ₂ → + δ ≠ κ.pathMatch β₁ hβ₁ → + δ ≠ κ.pathMatch (κ.pathMatch β₂ hβ₂) hγ₂mem → + (κ.repair a b c d v hsq).pathMatch δ hδ = + κ.pathMatch δ hδ := + fun δ hδ q1 q2 q3 q4 => hout δ hδ q1 q3 + (fun he => q4 (he.trans hinv₂.symm)) q2 + exact ⟨β₁, κ.pathMatch β₂ hβ₂, hβ₁, hγ₂mem, h1γ2, + fun he => hγ2γ1 he.symm, hcross, + far_ends_pair (κ.repair a b c d v hsq) hβ₁ hγ₂mem + (fun he => hγ2γ1 he.symm) hcross hout', hout'⟩ + · -- ═══════ NEAR ENDS pathMatch β₁ ↔ β₂ ═══════ + have hcross : (κ.repair a b c d v hsq).pathMatch + (κ.pathMatch β₁ hβ₁) hγ₁mem = β₂ := by + by_contra hne + exact onBoundaryChain_disjoint hγ₁mem hβ₂ h2γ + (fun h => hne h.symm) (honc hγ₁mem h₁) h₂ + have hout' : ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + δ ≠ κ.pathMatch β₁ hβ₁ → δ ≠ β₂ → + δ ≠ κ.pathMatch (κ.pathMatch β₁ hβ₁) hγ₁mem → + δ ≠ κ.pathMatch β₂ hβ₂ → + (κ.repair a b c d v hsq).pathMatch δ hδ = + κ.pathMatch δ hδ := + fun δ hδ q1 q2 q3 q4 => hout δ hδ + (fun he => q3 (he.trans hinv₁.symm)) q1 q2 q4 + exact ⟨κ.pathMatch β₁ hβ₁, β₂, hγ₁mem, hβ₂, hγ1β2, + fun he => h12 (hinv₁.symm.trans he), hcross, + far_ends_pair (κ.repair a b c d v hsq) hγ₁mem hβ₂ + (fun he => h12 (hinv₁.symm.trans he)) hcross hout', + hout'⟩ + · -- ═══════ NEAR ENDS pathMatch β₁ ↔ pathMatch β₂ ═══════ + have hcross : (κ.repair a b c d v hsq).pathMatch + (κ.pathMatch β₁ hβ₁) hγ₁mem = κ.pathMatch β₂ hβ₂ := by + by_contra hne + exact onBoundaryChain_disjoint hγ₁mem hγ₂mem hγ2γ1 + (fun h => hne h.symm) (honc hγ₁mem h₁) h₂ + have hout' : ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + δ ≠ κ.pathMatch β₁ hβ₁ → δ ≠ κ.pathMatch β₂ hβ₂ → + δ ≠ κ.pathMatch (κ.pathMatch β₁ hβ₁) hγ₁mem → + δ ≠ κ.pathMatch (κ.pathMatch β₂ hβ₂) hγ₂mem → + (κ.repair a b c d v hsq).pathMatch δ hδ = + κ.pathMatch δ hδ := + fun δ hδ q1 q2 q3 q4 => hout δ hδ + (fun he => q3 (he.trans hinv₁.symm)) q1 + (fun he => q4 (he.trans hinv₂.symm)) q2 + exact ⟨κ.pathMatch β₁ hβ₁, κ.pathMatch β₂ hβ₂, hγ₁mem, + hγ₂mem, fun he => hγ2γ1 he.symm, + fun he => h1γ2 (hinv₁.symm.trans he), hcross, + far_ends_pair (κ.repair a b c d v hsq) hγ₁mem hγ₂mem + (fun he => h1γ2 (hinv₁.symm.trans he)) hcross hout', + hout'⟩ + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingValue.lean new file mode 100644 index 0000000000..4ba4ef0376 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingValue.lean @@ -0,0 +1,113 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSignature + +/-! +# The pairing-resolved signed value + +The signed canonical summand of a single transition system, chosen +among its path-canonical orientations. Within one system the +choice is immaterial (`throughSummand_pathCanonical`); across +systems with the same boundary pairing it is invariant given the +pairing-preserving ledger — the well-definedness of the value as a +function of the pairing, riding on the proved block connectivity. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} + +namespace EdgeSubset + +open Classical in +/-- The signed canonical summand of one system: the path sign times +the through summand at the open circuit count, at a chosen +path-canonical orientation. -/ +noncomputable def signedValueAt [LinearOrder α] {W : Fragment α} + {k ℓ : ℕ} + (F : EdgeSubset W) (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (κ : F.RelTransitionSystem) : ℂ := + if h : Nonempty {o : κ.Orientation // PathCanonical o} then + pathSign κ * + F.throughSummand hM st hbnd (Classical.choice h).val + κ.openCircuitCount + else 0 + +/-- The signed value evaluates at any concrete path-canonical +orientation. -/ +theorem signedValueAt_eq [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {k ℓ : ℕ} (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ : F.RelTransitionSystem} (o : κ.Orientation) + (hc : PathCanonical o) : + F.signedValueAt hM st hbnd κ = + pathSign κ * + F.throughSummand hM st hbnd o κ.openCircuitCount := by + have hne : Nonempty {o : κ.Orientation // PathCanonical o} := + ⟨⟨o, hc⟩⟩ + rw [signedValueAt, dite_eq_left hne] + exact congrArg (fun x => pathSign κ * x) + (throughSummand_pathCanonical hM st hbnd + (Classical.choice hne).prop hc _) + +/-- Canonical-orientation existence transfers along the same +pairing, given the ledger: fold the ledger down the block chain and +cross the final `MatchEq`. -/ +theorem canonical_transfer_of_samePairing + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + (HLedger : MatchPreservingLedger) {k ℓ : ℕ} + (hM : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ κ' : F.RelTransitionSystem} (hsp : SamePairing κ κ') + (o : κ.Orientation) (hc : PathCanonical o) : + ∃ o' : κ'.Orientation, PathCanonical o' := by + obtain ⟨n, chain, h0, hlast, hstep⟩ := pairingConnectivity κ κ' + hsp + obtain ⟨olast, hclast, -⟩ := + chain_carry HLedger hM st hbnd o hc chain h0 hstep (Fin.last n) + obtain ⟨oκ', hcκ', -⟩ := + endpoint_transfer hM st hbnd hlast olast hclast + exact ⟨oκ', hcκ'⟩ + +/-- **Same-pairing invariance of the signed value** (conditional on +the pairing-preserving ledger): the signed canonical summand is a +function of the boundary pairing alone. -/ +theorem signedValueAt_samePairing + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + (HLedger : MatchPreservingLedger) {k ℓ : ℕ} + (hM : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ κ' : F.RelTransitionSystem} (hsp : SamePairing κ κ') : + F.signedValueAt hM st hbnd κ = + F.signedValueAt hM st hbnd κ' := by + by_cases h : Nonempty {o : κ.Orientation // PathCanonical o} + · obtain ⟨⟨o, hc⟩⟩ := h + obtain ⟨o', hc'⟩ := canonical_transfer_of_samePairing HLedger + hM st hbnd hsp o hc + rw [signedValueAt_eq hM st hbnd o hc, + signedValueAt_eq hM st hbnd o' hc'] + exact samePairing_invariance_of pairingConnectivity HLedger + hM st hbnd κ κ' hsp o hc o' hc' + · have h' : ¬ Nonempty {o : κ'.Orientation // PathCanonical o} := by + intro ⟨⟨o', hc'⟩⟩ + obtain ⟨o, hc⟩ := canonical_transfer_of_samePairing HLedger + hM st hbnd (SamePairing.symm hsp) o' hc' + exact h ⟨⟨o, hc⟩⟩ + rw [signedValueAt, dite_eq_right h, signedValueAt, dite_eq_right h'] + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialClose.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialClose.lean new file mode 100644 index 0000000000..ba1f2a2c12 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialClose.lean @@ -0,0 +1,215 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeNormal + +/-! +# Partial closure: gluing a fragment into a test fragment + +The accompanying paper's `G_z` (Lemma 3.3(b)): given a +`(u, v)`-fragment `z` +and a test fragment `G` on the interleaved boundary +`(s + u) + (t + v)`, glue each open end of `z` to the matching +`z`-block end of `G`. The survivors are exactly the `x`-block +ends of `G`, so the result is an `(s + t)`-fragment. The +absorption theorem `pairClose (tensorFragment x z) G ≃ +pairClose x (partialClose z G)` lives in `TensorIdeal.lean`; this +file provides the construction: the gluing pair list, its +well-formedness, the survivor identification, and congruence. +-/ + +@[expose] public section + +namespace RS + +/-- The `z`-gluing pairs: `z`'s high block against the last block +of `G`, then `z`'s low block against the second block of `G` +(top pair first within each block). -/ +noncomputable def zClosePairs (s t u v : ℕ) : + List ((Fin (u + v) ⊕ Fin ((s + u) + (t + v))) × + (Fin (u + v) ⊕ Fin ((s + u) + (t + v)))) := + (List.finRange v).reverse.map (fun l => + (Sum.inl ⟨u + l.val, by have := l.isLt; omega⟩, + Sum.inr ⟨(s + u) + (t + l.val), by have := l.isLt; omega⟩)) ++ + (List.finRange u).reverse.map (fun j => + (Sum.inl ⟨j.val, by have := j.isLt; omega⟩, + Sum.inr ⟨s + j.val, by have := j.isLt; omega⟩)) + +/-- Membership in the flattened `z`-gluing pairs: every `z`-label, +and the two `z`-blocks of `G`-labels. -/ +theorem mem_zClosePairs_flat (s t u v : ℕ) + (x : Fin (u + v) ⊕ Fin ((s + u) + (t + v))) : + x ∈ (zClosePairs s t u v).flatMap (fun p => [p.1, p.2]) ↔ + (∃ a : Fin (u + v), x = Sum.inl a) ∨ + (∃ b : Fin ((s + u) + (t + v)), x = Sum.inr b ∧ + ((s ≤ b.val ∧ b.val < s + u) ∨ (s + u) + t ≤ b.val)) := by + unfold zClosePairs + rw [List.flatMap_append, List.flatMap_map, List.flatMap_map, + List.mem_append] + simp only [List.mem_flatMap, List.mem_reverse, List.mem_finRange, + List.mem_cons, List.not_mem_nil, or_false, true_and] + constructor + · rintro (⟨l, hl | hl⟩ | ⟨j, hj | hj⟩) + · exact Or.inl ⟨_, hl⟩ + · exact Or.inr ⟨_, hl, Or.inr (by simp)⟩ + · exact Or.inl ⟨_, hj⟩ + · exact Or.inr ⟨_, hj, Or.inl (by simp)⟩ + · rintro (⟨a, rfl⟩ | ⟨b, rfl, hb | hb⟩) + · by_cases ha : a.val < u + · refine Or.inr ⟨⟨a.val, ha⟩, Or.inl ?_⟩ + exact congrArg Sum.inl (Fin.ext rfl) + · refine Or.inl ⟨⟨a.val - u, by have := a.isLt; omega⟩, + Or.inl ?_⟩ + exact congrArg Sum.inl (Fin.ext (by simp; omega)) + · refine Or.inr ⟨⟨b.val - s, by omega⟩, Or.inr ?_⟩ + exact congrArg Sum.inr (Fin.ext (by simp; omega)) + · refine Or.inl ⟨⟨b.val - ((s + u) + t), + by have := b.isLt; omega⟩, Or.inr ?_⟩ + exact congrArg Sum.inr (Fin.ext (by simp; omega)) + +/-- The `z`-gluing pairs are well-formed. -/ +theorem zClosePairs_wf (s t u v : ℕ) : + Fragment.PairsWF (zClosePairs s t u v) := by + unfold Fragment.PairsWF zClosePairs + rw [List.flatMap_append, List.nodup_append] + refine ⟨?_, ?_, ?_⟩ + · rw [List.flatMap_map, List.nodup_flatMap] + refine ⟨fun l _ => by simp, ?_⟩ + rw [List.pairwise_reverse] + refine (List.nodup_finRange v).pairwise_of_forall_ne ?_ + intro k _ m _ hkm x hxm hxk + simp only [List.mem_cons, List.not_mem_nil, or_false] + at hxm hxk + rcases hxm with rfl | rfl <;> rcases hxk with h | h + · rw [Sum.inl.injEq, Fin.mk.injEq] at h + exact hkm (Fin.ext (by omega)).symm + · exact Sum.inl_ne_inr h + · exact Sum.inr_ne_inl h + · rw [Sum.inr.injEq, Fin.mk.injEq] at h + exact hkm (Fin.ext (by omega)).symm + · rw [List.flatMap_map, List.nodup_flatMap] + refine ⟨fun j _ => by simp, ?_⟩ + rw [List.pairwise_reverse] + refine (List.nodup_finRange u).pairwise_of_forall_ne ?_ + intro k _ m _ hkm x hxm hxk + simp only [List.mem_cons, List.not_mem_nil, or_false] + at hxm hxk + rcases hxm with rfl | rfl <;> rcases hxk with h | h + · rw [Sum.inl.injEq, Fin.mk.injEq] at h + exact hkm (Fin.ext (by omega)).symm + · exact Sum.inl_ne_inr h + · exact Sum.inr_ne_inl h + · rw [Sum.inr.injEq, Fin.mk.injEq] at h + exact hkm (Fin.ext (by omega)).symm + · intro x hxv y hy + rw [List.flatMap_map] at hxv hy + simp only [List.mem_flatMap, List.mem_reverse, + List.mem_finRange, List.mem_cons, List.not_mem_nil, + or_false, true_and] at hxv hy + obtain ⟨l, hl⟩ := hxv + obtain ⟨j, hj⟩ := hy + have hlv := l.isLt + have hju := j.isLt + rcases hl with rfl | rfl <;> rcases hj with rfl | rfl + · intro h + rw [Sum.inl.injEq, Fin.mk.injEq] at h + omega + · exact Sum.inl_ne_inr + · exact Sum.inr_ne_inl + · intro h + rw [Sum.inr.injEq, Fin.mk.injEq] at h + omega + +/-- The survivor predicate of the `z`-gluing: no `z`-label +survives, and a `G`-label survives iff it lies in one of the two +`x`-blocks. -/ +def pcSurvPred (s t u v : ℕ) : + Fin (u + v) ⊕ Fin ((s + u) + (t + v)) → Prop := + Sum.elim (fun _ => False) + (fun b => b.val < s ∨ ((s + u) ≤ b.val ∧ b.val < (s + u) + t)) + +/-- Avoiding the `z`-gluing pairs is the survivor predicate. -/ +theorem pcSurv_iff (s t u v : ℕ) + (x : Fin (u + v) ⊕ Fin ((s + u) + (t + v))) : + x ∉ (zClosePairs s t u v).flatMap (fun p => [p.1, p.2]) ↔ + pcSurvPred s t u v x := by + rw [mem_zClosePairs_flat] + rcases x with a | b + · simp [pcSurvPred] + · simp only [pcSurvPred, Sum.elim_inr, reduceCtorEq, + exists_false, false_or, Sum.inr.injEq, exists_eq_left'] + have := b.isLt + omega + +/-- The surviving `G`-labels of the `z`-gluing, identified with +the `(s + t)`-boundary: first `x`-block by value, second by +offset. -/ +def pcSurvValEquiv (s t u v : ℕ) : + {x : Fin (u + v) ⊕ Fin ((s + u) + (t + v)) // + pcSurvPred s t u v x} ≃ Fin (s + t) where + toFun x := + match x with + | ⟨Sum.inl _, h⟩ => absurd h not_false + | ⟨Sum.inr b, h⟩ => + if hb : b.val < s then ⟨b.val, by omega⟩ + else ⟨s + (b.val - (s + u)), by + rcases h with h | h + · omega + · omega⟩ + invFun k := + if hk : k.val < s then + ⟨Sum.inr ⟨k.val, by omega⟩, Or.inl hk⟩ + else + ⟨Sum.inr ⟨(s + u) + (k.val - s), by have := k.isLt; omega⟩, + Or.inr ⟨by change (s + u) ≤ (s + u) + (k.val - s); omega, + by change (s + u) + (k.val - s) < (s + u) + t + have := k.isLt; omega⟩⟩ + left_inv x := by + obtain ⟨x, h⟩ := x + rcases x with a | b + · exact absurd h not_false + · by_cases hb : b.val < s + · simp only [dite_eq_left hb] + · have hb2 : (s + u) ≤ b.val ∧ b.val < (s + u) + t := by + rcases h with h | h + · omega + · exact h + simp only [dite_eq_right hb, + dite_eq_right (show ¬ s + (b.val - (s + u)) < s by omega)] + exact Subtype.ext (congrArg Sum.inr (Fin.ext (by + change (s + u) + (s + (b.val - (s + u)) - s) = b.val + omega))) + right_inv k := by + by_cases hk : k.val < s + · simp only [dite_eq_left hk] + · simp only [dite_eq_right hk, + dite_eq_right (show ¬ (s + u) + (k.val - s) < s by omega)] + exact Fin.ext (by + change s + ((s + u) + (k.val - s) - (s + u)) = k.val + omega) + +/-- The survivor identification of the `z`-gluing. -/ +noncomputable def pcSurvEquiv (s t u v : ℕ) : + Fragment.FoldSurviving (Fin (u + v) ⊕ Fin ((s + u) + (t + v))) + (zClosePairs s t u v) ≃ Fin (s + t) := + (_root_.Equiv.subtypeEquivRight (fun x => + (forall_ne_iff_not_mem_flat _ x).trans + (pcSurv_iff s t u v x))).trans + (pcSurvValEquiv s t u v) + +/-- **Partial closure**: glue every open end of `z` into the +matching `z`-block end of the test fragment `G`; the surviving +`x`-block ends form the `(s + t)`-boundary. -/ +noncomputable def partialClose {s t u v : ℕ} + (z : Fragment (Fin (u + v))) + (G : Fragment (Fin ((s + u) + (t + v)))) : + Fragment (Fin (s + t)) := + (Fragment.glueList (z.disjUnion G) (zClosePairs s t u v) + (zClosePairs_wf s t u v)).relabel (pcSurvEquiv s t u v) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseCompose.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseCompose.lean new file mode 100644 index 0000000000..8f779fb6a8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseCompose.lean @@ -0,0 +1,406 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseTensor + +/-! +# Partial closure as a composition + +The partial closure is a composition in disguise: reshuffle the +test fragment's boundary so that the `z`-blocks form the incoming +interface and the `x`-blocks the outgoing free side +(`pcReshuffle`), and gluing `z` into `G` is composing `z` +(as a `(0, u+v)`-fragment) with the reshuffled `G`. This lets +the entire compose-calculus (identity laws, free-side relabels, +permutation absorption) act on partial closures. +-/ + +@[expose] public section + +namespace RS + +/-- The reshuffle of the test boundary: `z`-blocks first (the +interface), `x`-blocks last (the free side). -/ +noncomputable def pcReshuffle (s t u v : ℕ) : + Fin ((s + u) + (t + v)) ≃ Fin ((u + v) + (s + t)) := + (interleaveEquiv s t u v).symm.trans + ((_root_.Equiv.sumComm (Fin (s + t)) (Fin (u + v))).trans + finSumFinEquiv) + +/-- The reshuffle on the low `z`-block. -/ +theorem pcReshuffle_zlow (s t u v : ℕ) (j : Fin u) : + pcReshuffle s t u v + (Fin.castAdd (t + v) (Fin.natAdd s j)) = + Fin.castAdd (s + t) (Fin.castAdd v j) := by + unfold pcReshuffle + rw [_root_.Equiv.trans_apply, interleaveEquiv_symm_low_right] + rfl + +/-- The reshuffle on the high `z`-block. -/ +theorem pcReshuffle_zhigh (s t u v : ℕ) (l : Fin v) : + pcReshuffle s t u v + (Fin.natAdd (s + u) (Fin.natAdd t l)) = + Fin.castAdd (s + t) (Fin.natAdd u l) := by + unfold pcReshuffle + rw [_root_.Equiv.trans_apply, interleaveEquiv_symm_high_right] + rfl + +/-- The reshuffle on the low `x`-block. -/ +theorem pcReshuffle_xlow (s t u v : ℕ) (i : Fin s) : + pcReshuffle s t u v + (Fin.castAdd (t + v) (Fin.castAdd u i)) = + Fin.natAdd (u + v) (Fin.castAdd t i) := by + unfold pcReshuffle + rw [_root_.Equiv.trans_apply, interleaveEquiv_symm_low_left] + rfl + +/-- The reshuffle on the high `x`-block. -/ +theorem pcReshuffle_xhigh (s t u v : ℕ) (k : Fin t) : + pcReshuffle s t u v + (Fin.natAdd (s + u) (Fin.castAdd v k)) = + Fin.natAdd (u + v) (Fin.natAdd s k) := by + unfold pcReshuffle + rw [_root_.Equiv.trans_apply, interleaveEquiv_symm_high_left] + rfl + +/-- The inverse reshuffle on the low interface. -/ +theorem pcReshuffle_symm_low (s t u v : ℕ) (j : Fin u) : + (pcReshuffle s t u v).symm + (Fin.castAdd (s + t) (Fin.castAdd v j)) = + Fin.castAdd (t + v) (Fin.natAdd s j) := + (_root_.Equiv.symm_apply_eq _).mpr + (pcReshuffle_zlow s t u v j).symm + +/-- The inverse reshuffle on the high interface. -/ +theorem pcReshuffle_symm_high (s t u v : ℕ) (l : Fin v) : + (pcReshuffle s t u v).symm + (Fin.castAdd (s + t) (Fin.natAdd u l)) = + Fin.natAdd (s + u) (Fin.natAdd t l) := + (_root_.Equiv.symm_apply_eq _).mpr + (pcReshuffle_zhigh s t u v l).symm + +/-! ### The peeled ground pairs are the z-gluing pairs -/ + +/-- The full-interface split of the composition pairs at +`(0, u + v, s + t)`. -/ +theorem interfacePairs_zsplit (s t u v : ℕ) : + interfacePairs 0 (u + v) (s + t) = + (List.finRange v).reverse.map (fun l => + ((Sum.inl ⟨u + l.val, by have := l.isLt; omega⟩ : + Fin (0 + (u + v)) ⊕ Fin ((u + v) + (s + t))), + Sum.inr ⟨u + l.val, by have := l.isLt; omega⟩)) ++ + (List.finRange u).reverse.map (fun j => + (Sum.inl ⟨j.val, by have := j.isLt; omega⟩, + Sum.inr ⟨j.val, by have := j.isLt; omega⟩)) := by + unfold interfacePairs + rw [List.map_reverse, List.map_reverse, List.map_reverse, + ← List.reverse_append] + refine congrArg List.reverse ?_ + rw [← List.ofFn_eq_map, List.ofFn_add, List.ofFn_eq_map, + List.ofFn_eq_map] + refine congrArg₂ (· ++ ·) + (List.map_congr_left fun j _ => ?_) + (List.map_congr_left fun l _ => ?_) + · refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) + (congrArg Sum.inr (Fin.ext ?_)) + · change 0 + j.val = j.val + omega + · rfl + · refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) + (congrArg Sum.inr (Fin.ext ?_)) + · change 0 + (u + l.val) = u + l.val + omega + · rfl + +private theorem pc_compose_ground_v_aux (s t u v : ℕ) : + ∀ (l : List (Fin v)), + Fragment.mapPairs + (_root_.Equiv.sumCongr + (finCongr (by omega : u + v = 0 + (u + v))) + (pcReshuffle s t u v)).symm + (l.map (fun l' => + ((Sum.inl ⟨u + l'.val, by have := l'.isLt; omega⟩ : + Fin (0 + (u + v)) ⊕ Fin ((u + v) + (s + t))), + Sum.inr ⟨u + l'.val, by have := l'.isLt; omega⟩))) = + l.map (fun l' => + ((Sum.inl ⟨u + l'.val, by have := l'.isLt; omega⟩ : + Fin (u + v) ⊕ Fin ((s + u) + (t + v))), + Sum.inr ⟨(s + u) + (t + l'.val), + by have := l'.isLt; omega⟩)) + | [] => rfl + | l' :: l => by + simp only [List.map_cons, Fragment.mapPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext rfl ?_) + (pc_compose_ground_v_aux s t u v l) + change Sum.inr ((pcReshuffle s t u v).symm + ⟨u + l'.val, by have := l'.isLt; omega⟩) = _ + refine congrArg Sum.inr ?_ + rw [show (⟨u + l'.val, by have := l'.isLt; omega⟩ : + Fin ((u + v) + (s + t))) = + Fin.castAdd (s + t) (Fin.natAdd u l') from Fin.ext rfl, + pcReshuffle_symm_high] + exact Fin.ext rfl + +private theorem pc_compose_ground_u_aux (s t u v : ℕ) : + ∀ (l : List (Fin u)), + Fragment.mapPairs + (_root_.Equiv.sumCongr + (finCongr (by omega : u + v = 0 + (u + v))) + (pcReshuffle s t u v)).symm + (l.map (fun j => + ((Sum.inl ⟨j.val, by have := j.isLt; omega⟩ : + Fin (0 + (u + v)) ⊕ Fin ((u + v) + (s + t))), + Sum.inr ⟨j.val, by have := j.isLt; omega⟩))) = + l.map (fun j => + ((Sum.inl ⟨j.val, by have := j.isLt; omega⟩ : + Fin (u + v) ⊕ Fin ((s + u) + (t + v))), + Sum.inr ⟨s + j.val, by have := j.isLt; omega⟩)) + | [] => rfl + | j :: l => by + simp only [List.map_cons, Fragment.mapPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext rfl ?_) + (pc_compose_ground_u_aux s t u v l) + change Sum.inr ((pcReshuffle s t u v).symm + ⟨j.val, by have := j.isLt; omega⟩) = _ + refine congrArg Sum.inr ?_ + rw [show (⟨j.val, by have := j.isLt; omega⟩ : + Fin ((u + v) + (s + t))) = + Fin.castAdd (s + t) (Fin.castAdd v j) from Fin.ext rfl, + pcReshuffle_symm_low] + exact Fin.ext rfl + +/-- The peeled composition pairs of the reshuffled test fragment +are the `z`-gluing pairs. -/ +theorem pc_compose_ground (s t u v : ℕ) : + Fragment.mapPairs + (_root_.Equiv.sumCongr + (finCongr (by omega : u + v = 0 + (u + v))) + (pcReshuffle s t u v)).symm + (interfacePairs 0 (u + v) (s + t)) = + zClosePairs s t u v := by + rw [interfacePairs_zsplit s t u v, mapPairs_append] + unfold zClosePairs + rw [pc_compose_ground_v_aux s t u v, + pc_compose_ground_u_aux s t u v] + +/-! ### The label meet -/ + +/-- The peeled composition pairs. -/ +noncomputable def pcComposeQs (s t u v : ℕ) := + Fragment.mapPairs + (_root_.Equiv.sumCongr + (finCongr (by omega : u + v = 0 + (u + v))) + (pcReshuffle s t u v)).symm + (interfacePairs 0 (u + v) (s + t)) + +/-- The composed label of the compose-side normalization is the +partial-closure survivor identification. -/ +theorem pc_compose_meet (s t u v : ℕ) : + (Fragment.foldSurvivingPermEquiv + (List.Perm.of_eq (pc_compose_ground s t u v))).symm.trans + ((Fragment.foldSurvivingMapEquiv + (_root_.Equiv.sumCongr + (finCongr (by omega : u + v = 0 + (u + v))) + (pcReshuffle s t u v)) + (pcComposeQs s t u v)).trans + ((Fragment.foldSurvivingPermEquiv + (List.Perm.of_eq (mapPairs_symm_cancel + (_root_.Equiv.sumCongr + (finCongr (by omega : u + v = 0 + (u + v))) + (pcReshuffle s t u v)) + (interfacePairs 0 (u + v) (s + t))).symm)).symm.trans + (((interfaceSurvEquiv 0 (u + v) (s + t)).trans + finSumFinEquiv).trans + (finCongr (by omega : 0 + (s + t) = s + t))))) = + pcSurvEquiv s t u v := by + apply _root_.Equiv.ext + intro x + obtain ⟨xv, hx⟩ := x + have hpred : pcSurvPred s t u v xv := + (pcSurv_iff s t u v xv).mp + ((forall_ne_iff_not_mem_flat _ xv).mp hx) + rcases xv with a | b + · exact hpred.elim + · rcases hpred with hb | hb + · have hbv : pcReshuffle s t u v b = + Fin.natAdd (u + v) (Fin.castAdd t ⟨b.val, hb⟩) := by + conv_lhs => rw [show b = Fin.castAdd (t + v) + (Fin.castAdd u ⟨b.val, hb⟩) from Fin.ext rfl] + exact pcReshuffle_xlow s t u v ⟨b.val, hb⟩ + have hsurvL : ∀ p ∈ interfacePairs 0 (u + v) (s + t), + (Sum.inr (pcReshuffle s t u v b) : + Fin (0 + (u + v)) ⊕ Fin ((u + v) + (s + t))) ≠ p.1 ∧ + (Sum.inr (pcReshuffle s t u v b) : + Fin (0 + (u + v)) ⊕ Fin ((u + v) + (s + t))) ≠ p.2 := + (forall_ne_iff_not_mem_flat _ _).mpr + ((interfaceSurv_iff 0 (u + v) (s + t) _).mpr + (by change ¬ (pcReshuffle s t u v b).val < u + v + rw [hbv] + change ¬ (u + v) + b.val < u + v + omega)) + change finCongr (by omega : 0 + (s + t) = s + t) + (finSumFinEquiv (interfaceSurvEquiv 0 (u + v) (s + t) + ⟨Sum.inr (pcReshuffle s t u v b), hsurvL⟩)) = + pcSurvEquiv s t u v ⟨Sum.inr b, hx⟩ + rw [interfaceSurvEquiv_inr 0 (u + v) (s + t) + ⟨Sum.inr (pcReshuffle s t u v b), hsurvL⟩ _ rfl + (by rw [hbv]; change u + v ≤ (u + v) + b.val; omega), + finSumFinEquiv_apply_right, + pcSurvEquiv_val_low s t u v b hx hb] + refine Fin.ext ?_ + change 0 + ((pcReshuffle s t u v b).val - (u + v)) = b.val + rw [hbv] + change 0 + ((u + v) + b.val - (u + v)) = b.val + omega + · have hk : b.val - (s + u) < t := by omega + have hb2 : b = Fin.natAdd (s + u) + (Fin.castAdd v ⟨b.val - (s + u), hk⟩) := + Fin.ext (by + change b.val = (s + u) + (b.val - (s + u)) + omega) + have hbv : pcReshuffle s t u v b = + Fin.natAdd (u + v) + (Fin.natAdd s ⟨b.val - (s + u), hk⟩) := by + conv_lhs => rw [hb2] + exact pcReshuffle_xhigh s t u v ⟨b.val - (s + u), hk⟩ + have hsurvL : ∀ p ∈ interfacePairs 0 (u + v) (s + t), + (Sum.inr (pcReshuffle s t u v b) : + Fin (0 + (u + v)) ⊕ Fin ((u + v) + (s + t))) ≠ p.1 ∧ + (Sum.inr (pcReshuffle s t u v b) : + Fin (0 + (u + v)) ⊕ Fin ((u + v) + (s + t))) ≠ p.2 := + (forall_ne_iff_not_mem_flat _ _).mpr + ((interfaceSurv_iff 0 (u + v) (s + t) _).mpr + (by change ¬ (pcReshuffle s t u v b).val < u + v + rw [hbv] + change ¬ (u + v) + (s + (b.val - (s + u))) < u + v + omega)) + change finCongr (by omega : 0 + (s + t) = s + t) + (finSumFinEquiv (interfaceSurvEquiv 0 (u + v) (s + t) + ⟨Sum.inr (pcReshuffle s t u v b), hsurvL⟩)) = + pcSurvEquiv s t u v ⟨Sum.inr b, hx⟩ + rw [interfaceSurvEquiv_inr 0 (u + v) (s + t) + ⟨Sum.inr (pcReshuffle s t u v b), hsurvL⟩ _ rfl + (by rw [hbv] + change u + v ≤ (u + v) + (s + (b.val - (s + u))) + omega), + finSumFinEquiv_apply_right, + pcSurvEquiv_val_high s t u v b hx + (by omega) (by omega) (by omega)] + refine Fin.ext ?_ + change 0 + ((pcReshuffle s t u v b).val - (u + v)) = + s + (b.val - (s + u)) + rw [hbv] + change 0 + ((u + v) + (s + (b.val - (s + u))) - (u + v)) = + s + (b.val - (s + u)) + omega + +/-- **Partial closure as a composition**: gluing `z` into `G` is +composing `z` with the reshuffled `G`. -/ +noncomputable def partialCloseEqCompose {s t u v : ℕ} + (z : Fragment (Fin (u + v))) + (G : Fragment (Fin ((s + u) + (t + v)))) : + (partialClose z G).Equiv + (((z.relabel + (finCongr (by omega : u + v = 0 + (u + v)))).compose + (G.relabel (pcReshuffle s t u v))).relabel + (finCongr (by omega : 0 + (s + t) = s + t))) := by + let eZ := _root_.Equiv.sumCongr + (finCongr (by omega : u + v = 0 + (u + v))) + (pcReshuffle s t u v) + let qs := pcComposeQs s t u v + have wfqs : Fragment.PairsWF qs := + Fragment.mapPairs_wf eZ.symm _ + (interfacePairs_wf 0 (u + v) (s + t)) + let Amb := z.disjUnion G + -- C5: bridge the peeled pairs to the z-gluing pairs. + have C5 : (Fragment.glueList Amb qs wfqs).Equiv + ((Fragment.glueList Amb (zClosePairs s t u v) + (zClosePairs_wf s t u v)).relabel + (Fragment.foldSurvivingPermEquiv + (List.Perm.of_eq (pc_compose_ground s t u v))).symm) := + Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv Amb (pc_compose_ground s t u v) + wfqs (zClosePairs_wf s t u v) + (List.Perm.of_eq (pc_compose_ground s t u v))) + -- C3: the relabelling stage. + have C3 := (Fragment.glueListRelabel Amb eZ qs wfqs).trans + ((Fragment.Equiv.relabelCongr C5 + (Fragment.foldSurvivingMapEquiv eZ qs)).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- C2: bridge the composition pairs. + have C2 := (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (Amb.relabel eZ) + (mapPairs_symm_cancel eZ + (interfacePairs 0 (u + v) (s + t))).symm + (interfacePairs_wf 0 (u + v) (s + t)) + (Fragment.mapPairs_wf eZ _ wfqs) + (List.Perm.of_eq (mapPairs_symm_cancel eZ + (interfacePairs 0 (u + v) (s + t))).symm))).trans + ((Fragment.Equiv.relabelCongr C3 + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel eZ + (interfacePairs 0 (u + v) (s + t))).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- C1: transport across the peel. + have C1 : (Fragment.glueList + ((z.relabel + (finCongr (by omega : u + v = 0 + (u + v)))).disjUnion + (G.relabel (pcReshuffle s t u v))) + (interfacePairs 0 (u + v) (s + t)) + (interfacePairs_wf 0 (u + v) (s + t))).Equiv + (Fragment.glueList (Amb.relabel eZ) + (interfacePairs 0 (u + v) (s + t)) + (interfacePairs_wf 0 (u + v) (s + t))) := + Fragment.glueListCongr + ((Fragment.relabelDisjUnionLeft z + (G.relabel (pcReshuffle s t u v)) + (finCongr (by omega : u + v = 0 + (u + v)))).trans + ((Fragment.Equiv.relabelCongr + (Fragment.relabelDisjUnionRight z G + (pcReshuffle s t u v)) + (_root_.Equiv.sumCongr + (finCongr (by omega : u + v = 0 + (u + v))) + (_root_.Equiv.refl _))).trans + ((Fragment.Equiv.relabelTrans _ _ _).trans + (Fragment.Equiv.relabelEq _ + (_root_.Equiv.ext (fun x => by cases x <;> rfl)))))) + (interfacePairs 0 (u + v) (s + t)) + (interfacePairs_wf 0 (u + v) (s + t)) + -- The compose side, fully normalized onto the z-gluing fold. + have RHSchain : (((z.relabel + (finCongr (by omega : u + v = 0 + (u + v)))).compose + (G.relabel (pcReshuffle s t u v))).relabel + (finCongr (by omega : 0 + (s + t) = s + t))).Equiv + ((Fragment.glueList Amb (zClosePairs s t u v) + (zClosePairs_wf s t u v)).relabel + ((((Fragment.foldSurvivingPermEquiv + (List.Perm.of_eq + (pc_compose_ground s t u v))).symm.trans + (Fragment.foldSurvivingMapEquiv eZ qs)).trans + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel eZ + (interfacePairs 0 (u + v) (s + t))).symm ▸ + List.Perm.refl _)).symm).trans + (((interfaceSurvEquiv 0 (u + v) (s + t)).trans + finSumFinEquiv).trans + (finCongr (by omega : 0 + (s + t) = s + t))))) := + (Fragment.Equiv.relabelCongr + ((composeNormal + (z.relabel (finCongr (by omega : u + v = 0 + (u + v)))) + (G.relabel (pcReshuffle s t u v))).trans + ((Fragment.Equiv.relabelCongr (C1.trans C2) + ((interfaceSurvEquiv 0 (u + v) (s + t)).trans + finSumFinEquiv)).trans + (Fragment.Equiv.relabelTrans _ _ _))) + (finCongr (by omega : 0 + (s + t) = s + t))).trans + (Fragment.Equiv.relabelTrans _ _ _) + exact (Fragment.Equiv.relabelEq _ + (pc_compose_meet s t u v).symm).trans RHSchain.symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseTensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseTensor.lean new file mode 100644 index 0000000000..f5ace40ef5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseTensor.lean @@ -0,0 +1,545 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorIdeal + +/-! +# Partial closure of a tensor + +`partialClose z (X' ⊗ z')` glues `z`'s ends onto the `z`-block of +the tensor — which is exactly `z'`'s boundary. The result is +`X'` sitting untouched next to the full closure of `z` against +`z'`: + +`partialClose z (X' ⊗ z') ≃ X' ⊔ pairClose z z'`. + +This is the engine of the trace multiplicativity (Lemma 3.5(b)): +with `X' := strandBundle a`, `z' := strandBundle b` and +`strandBundleTensor`, the trace of a tensor splits. + +This file: the three-summand shuffle, the ground computation +(the `z`-gluing pairs localize to the `z, z'` summands), and the +inner-pair identification. +-/ + +@[expose] public section + +namespace RS + +/-- The three-summand shuffle: pull the middle summand out +front. -/ +def sumShuffleEquiv (α β γ : Type) : + (β ⊕ (α ⊕ γ)) ≃ (α ⊕ (β ⊕ γ)) where + toFun x := + match x with + | Sum.inl b => Sum.inr (Sum.inl b) + | Sum.inr (Sum.inl a) => Sum.inl a + | Sum.inr (Sum.inr c) => Sum.inr (Sum.inr c) + invFun x := + match x with + | Sum.inl a => Sum.inr (Sum.inl a) + | Sum.inr (Sum.inl b) => Sum.inl b + | Sum.inr (Sum.inr c) => Sum.inr (Sum.inr c) + left_inv x := by rcases x with b | (a | c) <;> rfl + right_inv x := by rcases x with a | (b | c) <;> rfl + +/-- The disjoint union shuffles: the middle factor pulls out +front, up to the shuffle relabelling. -/ +noncomputable def disjUnionShuffle {α β γ : Type} + (W₁ : Fragment α) (W₂ : Fragment β) (W₃ : Fragment γ) : + (W₁.disjUnion (W₂.disjUnion W₃)).Equiv + ((W₂.disjUnion (W₁.disjUnion W₃)).relabel + (sumShuffleEquiv α β γ)) where + flagEquiv := sumShuffleEquiv W₂.Flag W₁.Flag W₃.Flag + vertexEquiv := sumShuffleEquiv W₂.Vertex W₁.Vertex W₃.Vertex + attach_comm := fun f => by + rcases f with f | (f | f) + · change ((((W₁.attach f).map Sum.inl Sum.inl).map + Sum.inr Sum.inr).map id (sumShuffleEquiv α β γ)) = + (((W₁.attach f).map Sum.inl Sum.inl).map + (sumShuffleEquiv W₂.Vertex W₁.Vertex W₃.Vertex) id) + rcases W₁.attach f with v | ℓ <;> rfl + · change (((W₂.attach f).map Sum.inl Sum.inl).map id + (sumShuffleEquiv α β γ)) = + ((((W₂.attach f).map Sum.inl Sum.inl).map + Sum.inr Sum.inr).map + (sumShuffleEquiv W₂.Vertex W₁.Vertex W₃.Vertex) id) + rcases W₂.attach f with v | ℓ <;> rfl + · change ((((W₃.attach f).map Sum.inr Sum.inr).map + Sum.inr Sum.inr).map id (sumShuffleEquiv α β γ)) = + ((((W₃.attach f).map Sum.inr Sum.inr).map + Sum.inr Sum.inr).map + (sumShuffleEquiv W₂.Vertex W₁.Vertex W₃.Vertex) id) + rcases W₃.attach f with v | ℓ <;> rfl + pairing_comm := fun f => by + rcases f with f | (f | f) <;> rfl + circles_eq := by + change W₁.circles + (W₂.circles + W₃.circles) = + W₂.circles + (W₁.circles + W₃.circles) + omega + +/-! ### The localized inner pairs -/ + +/-- The closure pairs of `z` against `z'`, over the pair of +`(u + v)`-boundaries: high block, then low block. -/ +def innerClosePairs (u v : ℕ) : + List ((Fin (u + v) ⊕ Fin (u + v)) × + (Fin (u + v) ⊕ Fin (u + v))) := + (List.finRange v).reverse.map (fun l => + (Sum.inl ⟨u + l.val, by have := l.isLt; omega⟩, + Sum.inr ⟨u + l.val, by have := l.isLt; omega⟩)) ++ + (List.finRange u).reverse.map (fun j => + (Sum.inl ⟨j.val, by have := j.isLt; omega⟩, + Sum.inr ⟨j.val, by have := j.isLt; omega⟩)) + +/-! ### The ground computation: peeling the interleave -/ + +private theorem pc_tensor_ground_v_aux (s t u v : ℕ) : + ∀ (l : List (Fin v)), + Fragment.mapPairs + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (u + v))) + (interleaveEquiv s t u v)).symm + (l.map (fun l' => + ((Sum.inl ⟨u + l'.val, by have := l'.isLt; omega⟩ : + Fin (u + v) ⊕ Fin ((s + u) + (t + v))), + Sum.inr ⟨(s + u) + (t + l'.val), + by have := l'.isLt; omega⟩))) = + l.map (fun l' => + (Sum.inl ⟨u + l'.val, by have := l'.isLt; omega⟩, + Sum.inr (Sum.inr ⟨u + l'.val, + by have := l'.isLt; omega⟩))) + | [] => rfl + | l' :: l => by + simp only [List.map_cons, Fragment.mapPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext rfl ?_) + (pc_tensor_ground_v_aux s t u v l) + change Sum.inr ((interleaveEquiv s t u v).symm + ⟨(s + u) + (t + l'.val), by have := l'.isLt; omega⟩) = _ + refine congrArg Sum.inr ?_ + rw [show (⟨(s + u) + (t + l'.val), + by have := l'.isLt; omega⟩ : + Fin ((s + u) + (t + v))) = + Fin.natAdd (s + u) (Fin.natAdd t l') from Fin.ext rfl, + interleaveEquiv_symm_high_right] + exact congrArg Sum.inr (Fin.ext rfl) + +private theorem pc_tensor_ground_u_aux (s t u v : ℕ) : + ∀ (l : List (Fin u)), + Fragment.mapPairs + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (u + v))) + (interleaveEquiv s t u v)).symm + (l.map (fun j => + ((Sum.inl ⟨j.val, by have := j.isLt; omega⟩ : + Fin (u + v) ⊕ Fin ((s + u) + (t + v))), + Sum.inr ⟨s + j.val, by have := j.isLt; omega⟩))) = + l.map (fun j => + (Sum.inl ⟨j.val, by have := j.isLt; omega⟩, + Sum.inr (Sum.inr ⟨j.val, by have := j.isLt; omega⟩))) + | [] => rfl + | j :: l => by + simp only [List.map_cons, Fragment.mapPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext rfl ?_) + (pc_tensor_ground_u_aux s t u v l) + change Sum.inr ((interleaveEquiv s t u v).symm + ⟨s + j.val, by have := j.isLt; omega⟩) = _ + refine congrArg Sum.inr ?_ + rw [show (⟨s + j.val, by have := j.isLt; omega⟩ : + Fin ((s + u) + (t + v))) = + Fin.castAdd (t + v) (Fin.natAdd s j) from Fin.ext rfl, + interleaveEquiv_symm_low_right] + exact congrArg Sum.inr (Fin.ext rfl) + +/-- Peeling the interleave from the `z`-gluing pairs localizes +them to the `z, z'` summands. -/ +theorem pc_tensor_ground (s t u v : ℕ) : + Fragment.mapPairs + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (u + v))) + (interleaveEquiv s t u v)).symm + (zClosePairs s t u v) = + Fragment.mapPairs + (sumShuffleEquiv (Fin (u + v)) (Fin (s + t)) + (Fin (u + v))) + (Fragment.inrPairs (α := Fin (s + t)) + (innerClosePairs u v)) := by + unfold zClosePairs + rw [mapPairs_append] + rw [pc_tensor_ground_v_aux s t u v, pc_tensor_ground_u_aux] + unfold Fragment.mapPairs Fragment.inrPairs innerClosePairs + simp only [List.map_append, List.map_map] + rfl + +/-! ### The inner closure, normalized -/ + +/-- The closure label of the inner pair: the two closure casts. -/ +noncomputable def innerCloseLabel (u v : ℕ) : + (Fin (u + v) ⊕ Fin (u + v)) ≃ + (Fin (0 + (u + v)) ⊕ Fin ((u + v) + 0)) := + _root_.Equiv.sumCongr + (finCongr (by omega : u + v = 0 + (u + v))) + (finCongr (by omega : u + v = (u + v) + 0)) + +/-- The transported closure pairs of the inner closure are the +inner pairs. -/ +theorem inner_ground (u v : ℕ) : + Fragment.mapPairs (innerCloseLabel u v).symm + (interfacePairs 0 (u + v) 0) = + innerClosePairs u v := by + rw [interfacePairs_closure_split u v] + unfold Fragment.mapPairs innerClosePairs ipHigh ipLow + simp only [List.map_append, List.map_map] + rfl + +/-- The inner pairs are well-formed. -/ +theorem innerClosePairs_wf (u v : ℕ) : + Fragment.PairsWF (innerClosePairs u v) := + (inner_ground u v) ▸ + Fragment.mapPairs_wf (innerCloseLabel u v).symm _ + (interfacePairs_wf 0 (u + v) 0) + +/-- The transported inner closure pairs. -/ +noncomputable def innerQs (u v : ℕ) := + Fragment.mapPairs (innerCloseLabel u v).symm + (interfacePairs 0 (u + v) 0) + +/-- The composed label identification of the inner closure. -/ +noncomputable def innerLabel (u v : ℕ) : + Fragment.FoldSurviving (Fin (u + v) ⊕ Fin (u + v)) + (innerClosePairs u v) ≃ Fin (0 + 0) := + (Fragment.foldSurvivingPermEquiv + ((inner_ground u v) ▸ List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv (innerCloseLabel u v) + (innerQs u v)).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel (innerCloseLabel u v) + (interfacePairs 0 (u + v) 0)).symm ▸ + List.Perm.refl _)).symm.trans + ((interfaceSurvEquiv 0 (u + v) 0).trans finSumFinEquiv))) + +/-- **The inner closure, normalized**: the closure of `z` against +`z'` is iterated gluing of the inner pairs over `z ⊔ z'`. -/ +noncomputable def innerNormal {u v : ℕ} + (z z' : Fragment (Fin (u + v))) : + (pairClose z z').Equiv + ((Fragment.glueList (z.disjUnion z') + (innerClosePairs u v) + (innerClosePairs_wf u v)).relabel + (innerLabel u v)) := by + let σC := innerCloseLabel u v + let qs0 := innerQs u v + have wfqs0 : Fragment.PairsWF qs0 := + Fragment.mapPairs_wf σC.symm _ (interfacePairs_wf 0 (u + v) 0) + let Amb := z.disjUnion z' + -- C5: bridge the transported pairs to the inner pairs. + have C5 : (Fragment.glueList Amb qs0 wfqs0).Equiv + ((Fragment.glueList Amb (innerClosePairs u v) + (innerClosePairs_wf u v)).relabel + (Fragment.foldSurvivingPermEquiv + ((inner_ground u v) ▸ List.Perm.refl _)).symm) := + Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv Amb (inner_ground u v) + wfqs0 (innerClosePairs_wf u v) + ((inner_ground u v) ▸ List.Perm.refl _)) + -- C3: the fold-survivor relabelling stage. + have C3 := (Fragment.glueListRelabel Amb σC qs0 wfqs0).trans + ((Fragment.Equiv.relabelCongr C5 + (Fragment.foldSurvivingMapEquiv σC qs0)).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- C2: bridge the closure pairs. + have C2 := (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (Amb.relabel σC) + (mapPairs_symm_cancel σC + (interfacePairs 0 (u + v) 0)).symm + (interfacePairs_wf 0 (u + v) 0) + (Fragment.mapPairs_wf σC _ wfqs0) + ((mapPairs_symm_cancel σC + (interfacePairs 0 (u + v) 0)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr C3 + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel σC + (interfacePairs 0 (u + v) 0)).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- E1: peel the closure casts. + have E1 : ((z.relabel + (finCongr (by omega : u + v = 0 + (u + v)))).disjUnion + (z'.relabel + (finCongr (by omega : u + v = (u + v) + 0)))).Equiv + (Amb.relabel σC) := + (Fragment.relabelDisjUnionLeft z _ + (finCongr (by omega : u + v = 0 + (u + v)))).trans + ((Fragment.Equiv.relabelCongr + (Fragment.relabelDisjUnionRight z z' + (finCongr (by omega : u + v = (u + v) + 0))) + (_root_.Equiv.sumCongr + (finCongr (by omega : u + v = 0 + (u + v))) + (_root_.Equiv.refl _))).trans + ((Fragment.Equiv.relabelTrans _ _ _).trans + (Fragment.Equiv.relabelEq _ + (_root_.Equiv.ext (fun x => by cases x <;> rfl))))) + -- C1: transport the closure gluing across E1. + have C1 := (Fragment.glueListCongr E1 + (interfacePairs 0 (u + v) 0) + (interfacePairs_wf 0 (u + v) 0)).trans C2 + -- Assemble. + exact (composeNormal + (z.relabel (finCongr (by omega : u + v = 0 + (u + v)))) + (z'.relabel + (finCongr (by omega : u + v = (u + v) + 0)))).trans + ((Fragment.Equiv.relabelCongr C1 + ((interfaceSurvEquiv 0 (u + v) 0).trans + finSumFinEquiv)).trans + (Fragment.Equiv.relabelTrans _ _ _)) + +/-! ### The main chain -/ + +/-- The clean label of the partial closure of a tensor. -/ +noncomputable def pcTensorClose (s t : ℕ) : + (Fin (s + t) ⊕ Fin (0 + 0)) ≃ Fin (s + t) := + (_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (s + t))) + (finCongr (by omega : 0 + 0 = 0))).trans + (_root_.Equiv.sumEmpty (Fin (s + t)) (Fin 0)) + +/-- The interleave peel of the `z`-gluing ambient. -/ +noncomputable def pcTensorPeel (s t u v : ℕ) : + (Fin (u + v) ⊕ (Fin (s + t) ⊕ Fin (u + v))) ≃ + (Fin (u + v) ⊕ Fin ((s + u) + (t + v))) := + _root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (u + v))) + (interleaveEquiv s t u v) + +/-- The peeled `z`-gluing pairs. -/ +noncomputable def pcTensorQs (s t u v : ℕ) := + Fragment.mapPairs (pcTensorPeel s t u v).symm + (zClosePairs s t u v) + +/-- The pairs pulled back through the tensor peel are well formed. -/ +theorem pcTensorPairs_wf (s t u v : ℕ) : + Fragment.PairsWF (pcTensorQs s t u v) := + Fragment.mapPairs_wf (pcTensorPeel s t u v).symm _ (zClosePairs_wf s t u v) + +/-- The composed label identification of the partial closure of a +tensor. -/ +noncomputable def pcTensorLabel (s t u v : ℕ) : + (Fin (s + t) ⊕ Fin (0 + 0)) ≃ Fin (s + t) := + (_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (s + t))) + (innerLabel u v).symm).trans + ((Fragment.inrFoldEquiv (α := Fin (s + t)) + (innerClosePairs u v)).symm.trans + ((Fragment.foldSurvivingMapEquiv + (sumShuffleEquiv (Fin (u + v)) (Fin (s + t)) + (Fin (u + v))) + (Fragment.inrPairs (α := Fin (s + t)) + (innerClosePairs u v))).trans + ((Fragment.foldSurvivingPermEquiv + ((pc_tensor_ground s t u v) ▸ + List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv (pcTensorPeel s t u v) + (pcTensorQs s t u v)).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel (pcTensorPeel s t u v) + (zClosePairs s t u v)).symm ▸ + List.Perm.refl _)).symm.trans + (pcSurvEquiv s t u v)))))) + +/-- **The partial closure of a tensor, normalized**: `X'` next to +the inner closure, up to the composed label. -/ +noncomputable def pcTensorNormal {s t u v : ℕ} + (z : Fragment (Fin (u + v))) (X' : Fragment (Fin (s + t))) + (z' : Fragment (Fin (u + v))) : + (partialClose z (tensorFragment X' z')).Equiv + ((X'.disjUnion (pairClose z z')).relabel + (pcTensorLabel s t u v)) := by + let eP := pcTensorPeel s t u v + let qsP := pcTensorQs s t u v + have wfqsP : Fragment.PairsWF qsP := by + exact pcTensorPairs_wf s t u v + let shufE := sumShuffleEquiv (Fin (u + v)) (Fin (s + t)) + (Fin (u + v)) + let ps₂ := Fragment.inrPairs (α := Fin (s + t)) + (innerClosePairs u v) + have wfps₂ : Fragment.PairsWF ps₂ := + Fragment.inrPairs_wf _ (innerClosePairs_wf u v) + let Zin := Fragment.glueList (z.disjUnion z') + (innerClosePairs u v) (innerClosePairs_wf u v) + let AmbP := z.disjUnion (X'.disjUnion z') + let AmbQ := X'.disjUnion (z.disjUnion z') + -- M5: the inner closure identified, inside the union. + have M5 : ((X'.disjUnion Zin).relabel + (Fragment.inrFoldEquiv (α := Fin (s + t)) + (innerClosePairs u v)).symm).Equiv + (((X'.disjUnion (pairClose z z')).relabel + (_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (s + t))) + (innerLabel u v).symm)).relabel + (Fragment.inrFoldEquiv (α := Fin (s + t)) + (innerClosePairs u v)).symm) := + Fragment.Equiv.relabelCongr + ((Fragment.Equiv.disjUnionCongr (Fragment.Equiv.refl X') + (Fragment.Equiv.relabelFlip (innerNormal z z'))).trans + (Fragment.relabelDisjUnionRight X' (pairClose z z') + (innerLabel u v).symm)) + (Fragment.inrFoldEquiv (α := Fin (s + t)) + (innerClosePairs u v)).symm + -- M4: localize the inner pairs to the z, z' summands. + have M4 : (Fragment.glueList AmbQ ps₂ wfps₂).Equiv + (((X'.disjUnion (pairClose z z')).relabel + (_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (s + t))) + (innerLabel u v).symm)).relabel + (Fragment.inrFoldEquiv (α := Fin (s + t)) + (innerClosePairs u v)).symm) := + (Fragment.glueListDisjUnionRight X' (z.disjUnion z') + (innerClosePairs u v) (innerClosePairs_wf u v)).trans M5 + -- M3: the shuffle relabelling stage. + have M3 := (Fragment.glueListRelabel AmbQ shufE ps₂ + wfps₂).trans + ((Fragment.Equiv.relabelCongr M4 + (Fragment.foldSurvivingMapEquiv shufE ps₂)).trans + ((Fragment.Equiv.relabelTrans _ _ _).trans + (Fragment.Equiv.relabelTrans _ _ _))) + -- M2b: bridge the peeled pairs to the shuffled pairs. + have M2b := (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (AmbQ.relabel shufE) + (pc_tensor_ground s t u v) + wfqsP (Fragment.mapPairs_wf shufE _ wfps₂) + ((pc_tensor_ground s t u v) ▸ List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr M3 + (Fragment.foldSurvivingPermEquiv + ((pc_tensor_ground s t u v) ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- MA: the shuffle of the ambient. + have MA := (Fragment.glueListCongr + (disjUnionShuffle z X' z') qsP wfqsP).trans M2b + -- M2: the peel relabelling stage. + have M2 := (Fragment.glueListRelabel AmbP eP qsP wfqsP).trans + ((Fragment.Equiv.relabelCongr MA + (Fragment.foldSurvivingMapEquiv eP qsP)).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- M1: bridge the z-gluing pairs. + have M1 := (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (AmbP.relabel eP) + (mapPairs_symm_cancel eP (zClosePairs s t u v)).symm + (zClosePairs_wf s t u v) + (Fragment.mapPairs_wf eP _ wfqsP) + ((mapPairs_symm_cancel eP + (zClosePairs s t u v)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr M2 + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel eP + (zClosePairs s t u v)).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- M0: peel the interleave off the gluing ambient. + have M0 := (Fragment.glueListCongr + (Fragment.relabelDisjUnionRight z (X'.disjUnion z') + (interleaveEquiv s t u v)) + (zClosePairs s t u v) (zClosePairs_wf s t u v)).trans M1 + -- Assemble. + exact (Fragment.Equiv.relabelCongr M0 + (pcSurvEquiv s t u v)).trans + (Fragment.Equiv.relabelTrans _ _ _) + +/-! ### The label meet -/ + +/-- The forward survivor identification on low labels. -/ +theorem pcSurvEquiv_val_low (s t u v : ℕ) + (b : Fin ((s + u) + (t + v))) + (hsurv : ∀ p ∈ zClosePairs s t u v, + (Sum.inr b : Fin (u + v) ⊕ Fin ((s + u) + (t + v))) ≠ p.1 ∧ + (Sum.inr b : Fin (u + v) ⊕ Fin ((s + u) + (t + v))) ≠ p.2) + (hb : b.val < s) : + pcSurvEquiv s t u v ⟨Sum.inr b, hsurv⟩ = + ⟨b.val, by omega⟩ := by + change (if h : b.val < s then _ else _ : Fin (s + t)) = _ + rw [dite_eq_left hb] + +/-- The forward survivor identification on high labels. -/ +theorem pcSurvEquiv_val_high (s t u v : ℕ) + (b : Fin ((s + u) + (t + v))) + (hsurv : ∀ p ∈ zClosePairs s t u v, + (Sum.inr b : Fin (u + v) ⊕ Fin ((s + u) + (t + v))) ≠ p.1 ∧ + (Sum.inr b : Fin (u + v) ⊕ Fin ((s + u) + (t + v))) ≠ p.2) + (hb : ¬ b.val < s) (h1 : (s + u) ≤ b.val) + (h2 : b.val < (s + u) + t) : + pcSurvEquiv s t u v ⟨Sum.inr b, hsurv⟩ = + ⟨s + (b.val - (s + u)), by omega⟩ := by + change (if h : b.val < s then _ else _ : Fin (s + t)) = _ + rw [dite_eq_right hb] + +/-- The composed label is the clean label: the live value chase +on the surviving `x`-labels. -/ +theorem pcTensorLabel_eq (s t u v : ℕ) : + pcTensorLabel s t u v = pcTensorClose s t := by + apply _root_.Equiv.ext + intro x + rcases x with x' | f0 + · by_cases hx : x'.val < s + · have h1 : interleaveEquiv s t u v (Sum.inl x') = + Fin.castAdd (t + v) (Fin.castAdd u ⟨x'.val, hx⟩) := + interleaveEquiv_inl_low s t u v ⟨x'.val, hx⟩ + have hval : (interleaveEquiv s t u v (Sum.inl x')).val = + x'.val := by rw [h1]; rfl + have hsurv : ∀ p ∈ zClosePairs s t u v, + (Sum.inr (interleaveEquiv s t u v (Sum.inl x')) : + Fin (u + v) ⊕ Fin ((s + u) + (t + v))) ≠ p.1 ∧ + (Sum.inr (interleaveEquiv s t u v (Sum.inl x')) : + Fin (u + v) ⊕ Fin ((s + u) + (t + v))) ≠ p.2 := + (forall_ne_iff_not_mem_flat _ _).mpr + ((pcSurv_iff s t u v _).mpr + (Or.inl (by rw [hval]; exact hx))) + change pcSurvEquiv s t u v + ⟨Sum.inr (interleaveEquiv s t u v (Sum.inl x')), + hsurv⟩ = _ + rw [pcSurvEquiv_val_low s t u v _ _ (by rw [hval]; exact hx)] + exact Fin.ext hval + · have hk : x'.val - s < t := by have := x'.isLt; omega + have hx2 : x' = Fin.natAdd s ⟨x'.val - s, hk⟩ := + Fin.ext (by change x'.val = s + (x'.val - s); omega) + have h1 : interleaveEquiv s t u v (Sum.inl x') = + Fin.natAdd (s + u) (Fin.castAdd v ⟨x'.val - s, hk⟩) := by + conv_lhs => rw [hx2] + exact interleaveEquiv_inl_high s t u v ⟨x'.val - s, hk⟩ + have hval : (interleaveEquiv s t u v (Sum.inl x')).val = + (s + u) + (x'.val - s) := by rw [h1]; rfl + have hsurv : ∀ p ∈ zClosePairs s t u v, + (Sum.inr (interleaveEquiv s t u v (Sum.inl x')) : + Fin (u + v) ⊕ Fin ((s + u) + (t + v))) ≠ p.1 ∧ + (Sum.inr (interleaveEquiv s t u v (Sum.inl x')) : + Fin (u + v) ⊕ Fin ((s + u) + (t + v))) ≠ p.2 := + (forall_ne_iff_not_mem_flat _ _).mpr + ((pcSurv_iff s t u v _).mpr + (Or.inr ⟨by rw [hval]; omega, + by rw [hval]; have := x'.isLt; omega⟩)) + change pcSurvEquiv s t u v + ⟨Sum.inr (interleaveEquiv s t u v (Sum.inl x')), + hsurv⟩ = _ + rw [pcSurvEquiv_val_high s t u v _ _ + (by rw [hval]; omega) (by rw [hval]; omega) + (by rw [hval]; have := x'.isLt; omega)] + refine Fin.ext ?_ + change s + ((interleaveEquiv s t u v (Sum.inl x')).val - + (s + u)) = x'.val + rw [hval] + omega + · exact absurd f0.isLt (by omega) + +/-- **The partial closure of a tensor**: `X'` unscathed next to +the full closure of `z` against `z'`. -/ +noncomputable def partialCloseTensor {s t u v : ℕ} + (z : Fragment (Fin (u + v))) (X' : Fragment (Fin (s + t))) + (z' : Fragment (Fin (u + v))) : + (partialClose z (tensorFragment X' z')).Equiv + ((X'.disjUnion (pairClose z z')).relabel + (pcTensorClose s t)) := + (pcTensorNormal z X' z').trans + (Fragment.Equiv.relabelEq _ (pcTensorLabel_eq s t u v)) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PathCanon.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathCanon.lean new file mode 100644 index 0000000000..d397454244 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathCanon.lean @@ -0,0 +1,181 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientationFlip +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCircuitDelta + +/-! +# Path-canonical orientations and the corrected independence + +The orientation counterexample shows the constrained summand +genuinely depends on the orientation of boundary-to-boundary +chains; only circuit-supported differences are invisible. The +correction: orient every chain canonically, from its lower-labelled +boundary end to its higher-labelled one. Two path-canonical +orientations of the same system then differ only on circuits, so +the circuit-restricted invariance makes the canonical +summand well-defined; the corrected value chooses among canonical +data, and the corrected independence interface quantifies over it. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} + +namespace EdgeSubset + +/-- **Path-canonical orientation**: every participating +boundary-to-boundary chain is directed from its lower-labelled end +to its higher-labelled one — the entry edge at the lower end is +incoming. -/ +def PathCanonical [LinearOrder α] {W : Fragment α} + {F : EdgeSubset W} {κ : F.RelTransitionSystem} + (o : κ.Orientation) : Prop := + ∀ (i j : α) (hb : W.boundaryFlag i ∈ F.boundaryFlags), + W.pairing (W.boundaryFlag i) ∈ F.internalFlags → + κ.pathMatch (W.boundaryFlag i) hb = W.boundaryFlag j → + i < j → + o.isOut (W.pairing (W.boundaryFlag i)) = false + +/-- On an all-internal subset every orientation is path-canonical: +there are no participating boundary flags. -/ +theorem pathCanonical_of_allInternal [LinearOrder α] {W : Fragment α} + {F : EdgeSubset W} + (hall : F.allInternal) {κ : F.RelTransitionSystem} + (o : κ.Orientation) : PathCanonical o := by + intro i j hb _ _ _ + exact absurd hb (by + rw [hall] + exact Finset.notMem_empty _) + +/-- The chord-interleaving condition between two boundary chains: +both chords are recorded at their lower-labelled ends and +interleave. -/ +def ChordCross [LinearOrder α] {W : Fragment α} + {F : EdgeSubset W} (κ : F.RelTransitionSystem) + (b b' : {x : W.Flag // x ∈ F.boundaryFlags}) : Prop := + ∃ i j i' j' : α, + W.attach b.val = Sum.inr i ∧ + W.attach (κ.pathMatch b.val b.prop) = Sum.inr j ∧ + W.attach b'.val = Sum.inr i' ∧ + W.attach (κ.pathMatch b'.val b'.prop) = Sum.inr j' ∧ + i < j ∧ i' < j' ∧ i < i' ∧ i' < j ∧ j < j' + +open Classical in +/-- The number of interleaving chain-chord pairs of a transition +system. -/ +noncomputable def chordCrossingCount [LinearOrder α] {W : Fragment α} + {F : EdgeSubset W} + (κ : F.RelTransitionSystem) : ℕ := + ((F.boundaryFlags.attach ×ˢ F.boundaryFlags.attach).filter + (fun bb => ChordCross κ bb.1 bb.2)).card + +/-- **The path-sector sign**: the crossing sign of the boundary +chain pairing — the Pfaffian chord-diagram sign forced by the +two-path repair obstruction. -/ +noncomputable def pathSign [LinearOrder α] {W : Fragment α} + {F : EdgeSubset W} + (κ : F.RelTransitionSystem) : ℂ := + (-1 : ℂ) ^ chordCrossingCount κ + +/-- On an all-internal subset the path sign is trivial. -/ +theorem pathSign_of_allInternal [LinearOrder α] {W : Fragment α} + {F : EdgeSubset W} + (hall : F.allInternal) (κ : F.RelTransitionSystem) : + pathSign κ = 1 := by + classical + unfold pathSign chordCrossingCount + rw [show ((F.boundaryFlags.attach ×ˢ F.boundaryFlags.attach).filter + (fun bb => ChordCross κ bb.1 bb.2)) = ∅ from + Finset.eq_empty_of_forall_notMem (fun bb _ => by + obtain ⟨⟨v, hv⟩, _⟩ := bb + rw [hall] at hv + exact absurd hv (Finset.notMem_empty _))] + rw [Finset.card_empty, pow_zero] + +/-- Canonical transition data: a relative system with a +path-canonical orientation. -/ +def CanonData [LinearOrder α] {W : Fragment α} + (F : EdgeSubset W) : Type := + (κ : F.RelTransitionSystem) × {o : κ.Orientation // PathCanonical o} + +open Classical in +/-- **The canonical constrained value**: the through summand at the +open circuit count, chosen among path-canonical data. -/ +noncomputable def throughValueC [LinearOrder α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) : ℂ := + if hne : Nonempty F.CanonData then + pathSign (Classical.choice hne).1 * + F.throughSummand h st hbnd (Classical.choice hne).2.val + ((Classical.choice hne).1.openCircuitCount) + else 0 + +end EdgeSubset + +open Classical in +/-- **The canonical state-constrained partition value** of an open +fragment. -/ +noncomputable def throughMixedPartitionC [LinearOrder α] + {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (W : Fragment α) + (st : GenBoundaryState k ℓ α) : ℂ := + ((k : ℂ) - 2 * ℓ) ^ W.circles * + ∑ s : Finset W.Flag, + if hc : ∀ f ∈ s, W.pairing f ∈ s then + if hbnd : genBoundarySubsetMatches W s st then + if (EdgeSubset.mk s hc).Eulerian then + (EdgeSubset.mk s hc).throughValueC h st hbnd + else 0 + else 0 + else 0 + +namespace EdgeSubset + +/-- Two path-canonical orientations of one system differ only on +circuit components, so their summands agree — the difference set +avoids every chain (both orientations direct each chain the same +way) and is therefore pairing-closed on internal flags. -/ +theorem throughSummand_canonical_unique [LinearOrder α] {W : Fragment α} + {F : EdgeSubset W} + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ : F.RelTransitionSystem} {o o' : κ.Orientation} + (_hc : PathCanonical o) (_hc' : PathCanonical o') + (hchain : ∀ f ∈ F.internalFlags, + o.isOut f ≠ o'.isOut f → W.pairing f ∈ F.internalFlags) + (c : ℕ) : + F.throughSummand h st hbnd o c = + F.throughSummand h st hbnd o' c := + F.throughSummand_orientation_invariant h st hbnd o o' hchain c + +end EdgeSubset + +/-- **The corrected independence interface**: the constrained +summand at the open circuit count is independent of the choice of +relative transition system and *path-canonical* orientation. -/ +def ThroughIndependenceC : Prop := + ∀ {α : Type} [LinearOrder α] {W : Fragment α} (F : EdgeSubset W) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ κ' : F.RelTransitionSystem} + (o : κ.Orientation) (o' : κ'.Orientation), + EdgeSubset.PathCanonical o → EdgeSubset.PathCanonical o' → + EdgeSubset.pathSign κ * + F.throughSummand h st hbnd o κ.openCircuitCount = + EdgeSubset.pathSign κ' * + F.throughSummand h st hbnd o' κ'.openCircuitCount + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PathLedger.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathLedger.lean new file mode 100644 index 0000000000..635419181f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathLedger.lean @@ -0,0 +1,1056 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RepairInvariance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChainAgreement + +/-! +# The path ledger for the repair move + +The corrected per-move target for Proposition 3: the +path-sign-weighted constrained summand +`pathSign κ * throughSummand … o κ.openCircuitCount` under one +elementary repair move. The `RepairInvariance` ledger +handles the summand factor; this file supplies the `pathSign` +factor and the case analysis that controls it. + +## Main results + +* `third_chord_reparity` — **the third-chord parity lemma** (chord + combinatorics, self-contained): re-pairing four fixed points of a + linear order into chords in any two ways changes the number of + crossings with any third chord by an even amount. +* `chain_meet` — **chain rigidity**: two boundary-terminated chains + sharing a walk flag have the same starting boundary flag (walks + are forward- and backward-deterministic). +* `pathMatch_repair_of_avoid` — a chain whose pairing arguments + avoid the four flags of the square walks identically in the + repaired system. +* `periodicFlag_pairing` / `periodicFlag_match` — the periodic + flags are closed under the edge pairing and the matching. +* `pathMatch_repair_of_periodic` — **case 1**: a square on periodic + (circuit) components leaves every path matching unchanged. +* `pathMatch_repair_of_chainLocal` — **cases 2–3**: a square whose + four flags are each periodic or on the chain of one boundary flag + `β` leaves every path matching unchanged — untouched chains avoid + the square by rigidity, and the two ends of `β`'s chain must + re-pair with each other because `pathMatch` remains a + fixed-point-free involution (`pathMatch_ne_self`). +* `pathSign_congr` / `pathSign_matchEq` — the crossing sign only + depends on the path matching, so it is unchanged in cases 1–3 and + invariant under `MatchEq`. +* `RelTransitionSystem.Orientation.flipOrbit` and + `throughSummand_flipOrbit` — reversing one whole circuit, and the + summand's invariance under doing so. +* `SeparatedCountParity` and `NonSeparatedStep` — the two per-case + hypotheses the move analysis is stated over, discharged in + `SeparatedParity.lean` and `NonSeparatedStep.lean` respectively. +-/ + +@[expose] public section + +namespace RS + + + +/-! ## (i) Chord combinatorics: the third-chord parity lemma -/ + +section ChordParity + +variable {γ : Type*} + +/-- Two chords of a linear order, each recorded low-to-high, +interleave (in either relative position). -/ +def ChordPairCross [LinearOrder γ] + (x y u w : γ) : Prop := + (x < u ∧ u < y ∧ y < w) ∨ (u < x ∧ x < w ∧ w < y) + +/-- A point lies strictly inside a chord. -/ +def InsideChord [LinearOrder γ] + (x y p : γ) : Prop := x < p ∧ p < y + +/-- Crossing a chord is interleaving: exactly one endpoint inside. -/ +theorem chordPairCross_iff_xor [LinearOrder γ] + {x y u w : γ} + (huw : u < w) (hux : u ≠ x) (hwy : w ≠ y) : + ChordPairCross x y u w ↔ + Xor (InsideChord x y u) (InsideChord x y w) := by + constructor + · rintro (⟨h1, h2, h3⟩ | ⟨h1, h2, h3⟩) + · exact Or.inl ⟨⟨h1, h2⟩, fun hw => absurd h3 (not_lt.mpr (le_of_lt hw.2))⟩ + · exact Or.inr ⟨⟨h2, h3⟩, fun hu => absurd h1 (not_lt.mpr (le_of_lt hu.1))⟩ + · rintro (⟨⟨hu1, hu2⟩, hnw⟩ | ⟨⟨hw1, hw2⟩, hnu⟩) + · have hxw : x < w := lt_trans hu1 huw + have hyw : y ≤ w := by + by_contra hcon + exact hnw ⟨hxw, not_le.mp hcon⟩ + exact Or.inl ⟨hu1, hu2, lt_of_le_of_ne hyw (Ne.symm hwy)⟩ + · have huy : u < y := lt_trans huw hw2 + have hux' : u ≤ x := by + by_contra hcon + exact hnu ⟨not_le.mp hcon, huy⟩ + exact Or.inr ⟨lt_of_le_of_ne hux' hux, hw1, hw2⟩ + +open Classical in +/-- The crossing indicator of one chord has the parity of the +number of its endpoints inside the third chord. -/ +theorem chordPairCross_parity [LinearOrder γ] + {x y u w : γ} + (huw : u < w) (hux : u ≠ x) (hwy : w ≠ y) : + (if ChordPairCross x y u w then 1 else 0) % 2 = + ((if InsideChord x y u then 1 else 0) + + (if InsideChord x y w then 1 else 0)) % 2 := by + by_cases hu : InsideChord x y u <;> by_cases hw : InsideChord x y w + · have hnX : ¬ ChordPairCross x y u w := by + rw [chordPairCross_iff_xor huw hux hwy] + rintro (⟨-, h⟩ | ⟨-, h⟩) + · exact h hw + · exact h hu + rw [ite_eq_right hnX, ite_eq_left hu, ite_eq_left hw] + · have hX : ChordPairCross x y u w := by + rw [chordPairCross_iff_xor huw hux hwy] + exact Or.inl ⟨hu, hw⟩ + rw [ite_eq_left hX, ite_eq_left hu, ite_eq_right hw] + · have hX : ChordPairCross x y u w := by + rw [chordPairCross_iff_xor huw hux hwy] + exact Or.inr ⟨hw, hu⟩ + rw [ite_eq_left hX, ite_eq_right hu, ite_eq_left hw] + · have hnX : ¬ ChordPairCross x y u w := by + rw [chordPairCross_iff_xor huw hux hwy] + rintro (⟨h, -⟩ | ⟨h, -⟩) + · exact hu h + · exact hw h + rw [ite_eq_right hnX, ite_eq_right hu, ite_eq_right hw] + +open Classical in +private theorem inside_sum_eq [LinearOrder γ] + (x y u₁ w₁ u₂ w₂ : γ) : + (({u₁, w₁, u₂, w₂} : Multiset γ).map + (fun p => if InsideChord x y p then 1 else 0)).sum = + (if InsideChord x y u₁ then 1 else 0) + + ((if InsideChord x y w₁ then 1 else 0) + + ((if InsideChord x y u₂ then 1 else 0) + + (if InsideChord x y w₂ then 1 else 0))) := by + simp only [Multiset.insert_eq_cons, Multiset.map_cons, + Multiset.map_singleton, Multiset.sum_cons, Multiset.sum_singleton] + +open Classical in +/-- **The third-chord parity lemma**: re-pairing the same four +points of a linear order into two chords in any two ways (the same +multiset of endpoints, each chord recorded low-to-high, no endpoint +shared with the third chord) preserves the parity of the number of +crossings with the third chord. -/ +theorem third_chord_reparity [LinearOrder γ] + {x y u₁ w₁ u₂ w₂ p₁ q₁ p₂ q₂ : γ} + (h₁ : u₁ < w₁) (h₂ : u₂ < w₂) + (h₁' : p₁ < q₁) (h₂' : p₂ < q₂) + (hmul : ({u₁, w₁, u₂, w₂} : Multiset γ) = {p₁, q₁, p₂, q₂}) + (hne : ∀ p ∈ ({u₁, w₁, u₂, w₂} : Multiset γ), p ≠ x ∧ p ≠ y) : + ((if ChordPairCross x y u₁ w₁ then 1 else 0) + + (if ChordPairCross x y u₂ w₂ then 1 else 0)) % 2 = + ((if ChordPairCross x y p₁ q₁ then 1 else 0) + + (if ChordPairCross x y p₂ q₂ then 1 else 0)) % 2 := by + have hne' : ∀ p ∈ ({p₁, q₁, p₂, q₂} : Multiset γ), p ≠ x ∧ p ≠ y := by + rw [← hmul]; exact hne + have e₁ := chordPairCross_parity (x := x) (y := y) h₁ + (hne u₁ (by simp)).1 (hne w₁ (by simp)).2 + have e₂ := chordPairCross_parity (x := x) (y := y) h₂ + (hne u₂ (by simp)).1 (hne w₂ (by simp)).2 + have e₁' := chordPairCross_parity (x := x) (y := y) h₁' + (hne' p₁ (by simp)).1 (hne' q₁ (by simp)).2 + have e₂' := chordPairCross_parity (x := x) (y := y) h₂' + (hne' p₂ (by simp)).1 (hne' q₂ (by simp)).2 + have hsum : (({u₁, w₁, u₂, w₂} : Multiset γ).map + (fun p => if InsideChord x y p then 1 else 0)).sum = + (({p₁, q₁, p₂, q₂} : Multiset γ).map + (fun p => if InsideChord x y p then 1 else 0)).sum := by + rw [hmul] + rw [inside_sum_eq, inside_sum_eq] at hsum + omega + +end ChordParity + +/-! ## (ii) Walk rigidity -/ + +namespace EdgeSubset + +variable {α : Type} {W : Fragment α} + +section WalkRigidity + +variable {F : EdgeSubset W} {κ : F.RelTransitionSystem} + +/-- The exit step of a boundary-terminated chain is unique. -/ +theorem chain_exit_unique {β : W.Flag} {k k' : ℕ} + (hcont : ∀ j, j < k → + W.pairing (iterWalk κ β j) ∈ F.internalFlags) + (hterm : W.pairing (iterWalk κ β k) ∈ F.boundaryFlags) + (hcont' : ∀ j, j < k' → + W.pairing (iterWalk κ β j) ∈ F.internalFlags) + (hterm' : W.pairing (iterWalk κ β k') ∈ F.boundaryFlags) : + k = k' := by + rcases Nat.lt_trichotomy k k' with h | h | h + · exact absurd hterm + (Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags (hcont' k h) ·) + · exact h + · exact absurd hterm' + (Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags (hcont k' h) ·) + +/-- **Chain rigidity**: the walk is forward- and +backward-deterministic, so two boundary-terminated chains sharing a +walk flag start at the same boundary flag, at the same step. -/ +theorem chain_meet {β β' : W.Flag} (hβ : β ∈ F.boundaryFlags) + (hβ' : β' ∈ F.boundaryFlags) {k k' : ℕ} + (hcont : ∀ j, j < k → + W.pairing (iterWalk κ β j) ∈ F.internalFlags) + (hcont' : ∀ j, j < k' → + W.pairing (iterWalk κ β' j) ∈ F.internalFlags) : + ∀ t s, t ≤ k' → s ≤ k → iterWalk κ β' t = iterWalk κ β s → + β' = β ∧ t = s := by + intro t + induction t with + | zero => + intro s _ hs heq + cases s with + | zero => + rw [iterWalk_zero, iterWalk_zero] at heq + exact ⟨heq, rfl⟩ + | succ s => + exfalso + have hint : iterWalk κ β (s + 1) ∈ F.internalFlags := + iterWalk_mem_internal κ k (by omega) hs hcont + rw [← heq, iterWalk_zero] at hint + exact Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags hint hβ' + | succ t ih => + intro s ht hs heq + cases s with + | zero => + exfalso + have hint : iterWalk κ β' (t + 1) ∈ F.internalFlags := + iterWalk_mem_internal κ k' (by omega) ht hcont' + rw [heq, iterWalk_zero] at hint + exact Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags hint hβ + | succ s => + have hm : κ.match_ (W.pairing (iterWalk κ β' t)) = + κ.match_ (W.pairing (iterWalk κ β s)) := by + rw [← iterWalk_succ, ← iterWalk_succ] + exact heq + have hargs : W.pairing (iterWalk κ β' t) = + W.pairing (iterWalk κ β s) := + κ.match_injOn (hcont' t (by omega)) (hcont s (by omega)) hm + have hEq : iterWalk κ β' t = iterWalk κ β s := by + have h2 := congrArg W.pairing hargs + rwa [W.pairing_invol, W.pairing_invol] at h2 + obtain ⟨h1, h2⟩ := ih s (by omega) (by omega) hEq + exact ⟨h1, by omega⟩ + +end WalkRigidity + +/-! ## Walk transfer under square avoidance -/ + +section RepairAvoid + +variable {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {a b c d : W.Flag} {v : W.Vertex} + +/-- A walk whose pairing arguments avoid the four flags of the +square is untouched by the repair. -/ +theorem repair_iterWalk_of_avoid (hsq : RepairSquare κ a b c d v) + {δ : W.Flag} {k : ℕ} + (havoid : ∀ t, t < k → + W.pairing (iterWalk κ δ t) ≠ a ∧ + W.pairing (iterWalk κ δ t) ≠ b ∧ + W.pairing (iterWalk κ δ t) ≠ c ∧ + W.pairing (iterWalk κ δ t) ≠ d) : + ∀ t, t ≤ k → + iterWalk (κ.repair a b c d v hsq) δ t = iterWalk κ δ t := by + intro t + induction t with + | zero => intro _; rfl + | succ t ih => + intro ht + obtain ⟨h1, h2, h3, h4⟩ := havoid t (by omega) + rw [iterWalk_succ, ih (by omega), iterWalk_succ, + RelTransitionSystem.repair_match_of_ne hsq h1 h2 h3 h4] + +/-- The path matching is untouched at a boundary flag whose chain +avoids the square. -/ +theorem pathMatch_repair_of_avoid (hsq : RepairSquare κ a b c d v) + {δ : W.Flag} (hδ : δ ∈ F.boundaryFlags) {k : ℕ} + (hk : k ≤ F.flags.card) + (hcont : ∀ j, j < k → + W.pairing (iterWalk κ δ j) ∈ F.internalFlags) + (hterm : W.pairing (iterWalk κ δ k) ∈ F.boundaryFlags) + (havoid : ∀ t, t < k → + W.pairing (iterWalk κ δ t) ≠ a ∧ + W.pairing (iterWalk κ δ t) ≠ b ∧ + W.pairing (iterWalk κ δ t) ≠ c ∧ + W.pairing (iterWalk κ δ t) ≠ d) : + (κ.repair a b c d v hsq).pathMatch δ hδ = κ.pathMatch δ hδ := by + have hwalk := repair_iterWalk_of_avoid hsq havoid + have hcont' : ∀ j, j < k → + W.pairing (iterWalk (κ.repair a b c d v hsq) δ j) ∈ + F.internalFlags := by + intro j hj + rw [hwalk j (by omega)] + exact hcont j hj + have hterm' : W.pairing (iterWalk (κ.repair a b c d v hsq) δ k) ∈ + F.boundaryFlags := by + rw [hwalk k le_rfl] + exact hterm + have h1 : (κ.repair a b c d v hsq).pathMatch δ hδ = + W.pairing (iterWalk (κ.repair a b c d v hsq) δ k) := + (κ.repair a b c d v hsq).pathMatch_eq hδ + (traceChain_fuel_mono _ (by omega) + (traceChain_forward _ δ hcont' hterm')) + have h2 : κ.pathMatch δ hδ = W.pairing (iterWalk κ δ k) := + κ.pathMatch_eq hδ + (traceChain_fuel_mono κ (by omega) + (traceChain_forward κ δ hcont hterm)) + rw [h1, h2, hwalk k le_rfl] + +end RepairAvoid + +/-! ## Closure of the periodic flags -/ + +section PeriodicClosure + +variable {F : EdgeSubset W} {κ : F.RelTransitionSystem} + +/-- The edge pairing of a periodic flag is periodic (the reversed +traversal of its circuit). -/ +theorem periodicFlag_pairing {f : W.Flag} (hf : κ.PeriodicFlag f) : + κ.PeriodicFlag (W.pairing f) := by + obtain ⟨hint, n, hn1, hcont, hper⟩ := hf + have hf' : κ.PeriodicFlag f := ⟨hint, n, hn1, hcont, hper⟩ + have hrev : ∀ j, j ≤ n → + iterWalk κ (W.pairing f) j = W.pairing (iterWalk κ f (n - j)) := by + intro j hj + have h := iterWalk_reverse κ hcont j hj + rwa [hper] at h + refine ⟨by simpa using hcont 0 (by omega), n, hn1, ?_, ?_⟩ + · intro j hj + rw [hrev j (by omega), W.pairing_invol] + exact iterWalk_mem_internal_of_periodic κ hf' (n - j) (by omega) + · rw [hrev n le_rfl, Nat.sub_self, iterWalk_zero] + +/-- The matching image of a periodic flag is periodic. -/ +theorem periodicFlag_match {f : W.Flag} (hf : κ.PeriodicFlag f) : + κ.PeriodicFlag (κ.match_ f) := by + have hp : κ.PeriodicFlag (W.pairing f) := periodicFlag_pairing hf + have h1 : iterWalk κ (W.pairing f) 1 = κ.match_ f := by + rw [iterWalk_succ, iterWalk_zero, W.pairing_invol] + rw [← h1] + exact periodicFlag_iterWalk κ hp 1 + +/-- No boundary chain hits a periodic flag in its pairing-argument +position: chains are non-periodic. -/ +theorem chain_arg_ne_of_periodic {δ f : W.Flag} + (hδ : δ ∈ F.boundaryFlags) {kδ : ℕ} + (hcontδ : ∀ j, j < kδ → + W.pairing (iterWalk κ δ j) ∈ F.internalFlags) + (htermδ : W.pairing (iterWalk κ δ kδ) ∈ F.boundaryFlags) + (hper : κ.PeriodicFlag f) {s : ℕ} (hs : s < kδ) : + W.pairing (iterWalk κ δ s) ≠ f := by + intro heq + have h2 : iterWalk κ δ s = W.pairing f := by + have h3 := congrArg W.pairing heq + rwa [W.pairing_invol] at h3 + have hpp : κ.PeriodicFlag (W.pairing f) := periodicFlag_pairing hper + cases s with + | zero => + rw [iterWalk_zero] at h2 + refine Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags ?_ hδ + rw [h2] + exact hpp.mem_internal + | succ s => + have hnp := not_periodic_of_chain_segment κ hcontδ htermδ + (by omega : s + 1 ≤ kδ) + rw [h2] at hnp + exact hnp hpp + +end PeriodicClosure + +/-! ## Avoidance of a foreign chain -/ + +section ChainAvoid + +variable {F : EdgeSubset W} {κ : F.RelTransitionSystem} + +/-- A chain distinct from `β` and from `β`'s far end never hits a +flag of `β`'s chain in its pairing-argument position. -/ +theorem chain_arg_ne_of_onChain {β δ f : W.Flag} + (hβ : β ∈ F.boundaryFlags) (hδ : δ ∈ F.boundaryFlags) {k : ℕ} + (hcont : ∀ j, j < k → + W.pairing (iterWalk κ β j) ∈ F.internalFlags) + (hterm : W.pairing (iterWalk κ β k) ∈ F.boundaryFlags) + {kδ : ℕ} + (hcontδ : ∀ j, j < kδ → + W.pairing (iterWalk κ δ j) ∈ F.internalFlags) + (hδβ : δ ≠ β) (hδγ : δ ≠ W.pairing (iterWalk κ β k)) + {t : ℕ} (ht : t ≤ k) + (hf : f = iterWalk κ β t ∨ f = W.pairing (iterWalk κ β t)) + {s : ℕ} (hs : s < kδ) : + W.pairing (iterWalk κ δ s) ≠ f := by + intro heq + have hcontγ : ∀ j, j < k → + W.pairing (iterWalk κ (W.pairing (iterWalk κ β k)) j) ∈ + F.internalFlags := + fun j hj => reverse_chain_continues κ hβ hcont j hj + rcases hf with rfl | rfl + · -- `f` is a walk-side flag of `β`'s chain: land on the reverse + -- chain from the far end and apply rigidity. + have h3 : iterWalk κ δ s = W.pairing (iterWalk κ β t) := by + have h4 := congrArg W.pairing heq + rwa [W.pairing_invol] at h4 + have h5 : iterWalk κ (W.pairing (iterWalk κ β k)) (k - t) = + W.pairing (iterWalk κ β t) := by + rw [iterWalk_reverse κ hcont (k - t) (by omega), + show k - (k - t) = t from by omega] + have h6 : iterWalk κ δ s = + iterWalk κ (W.pairing (iterWalk κ β k)) (k - t) := + h3.trans h5.symm + exact hδγ (chain_meet hterm hδ hcontγ hcontδ s (k - t) + (by omega) (by omega) h6).1 + · -- `f` is a pairing-side flag of `β`'s chain: rigidity directly. + have h3 : iterWalk κ δ s = iterWalk κ β t := by + have h4 := congrArg W.pairing heq + rwa [W.pairing_invol, W.pairing_invol] at h4 + exact hδβ (chain_meet hβ hδ hcont hcontδ s t + (by omega) (by omega) h3).1 + +end ChainAvoid + +/-! ## Membership on a boundary chain -/ + +section OnChain + +variable {F : EdgeSubset W} + +/-- Membership on the boundary chain of `β`: the flag appears on +the walk from `β` (on either side of an edge) before the chain +exits. -/ +def OnBoundaryChain (κ : F.RelTransitionSystem) (β f : W.Flag) : + Prop := + ∃ k t : ℕ, t ≤ k ∧ + (∀ j, j < k → W.pairing (iterWalk κ β j) ∈ F.internalFlags) ∧ + W.pairing (iterWalk κ β k) ∈ F.boundaryFlags ∧ + (f = iterWalk κ β t ∨ f = W.pairing (iterWalk κ β t)) + +variable {κ : F.RelTransitionSystem} + +/-- The chain membership is closed under the matching (on internal +flags). -/ +theorem onBoundaryChain_match {β f : W.Flag} + (hβ : β ∈ F.boundaryFlags) (hf : f ∈ F.internalFlags) + (h : OnBoundaryChain κ β f) : + OnBoundaryChain κ β (κ.match_ f) := by + obtain ⟨k, t, htk, hcont, hterm, hft⟩ := h + rcases hft with rfl | rfl + · -- walk-side: `match (iterWalk β t) = pairing (iterWalk β (t-1))` + cases t with + | zero => + exfalso + rw [iterWalk_zero] at hf + exact Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags hf hβ + | succ t => + refine ⟨k, t, by omega, hcont, hterm, Or.inr ?_⟩ + have h1 : iterWalk κ β (t + 1) = + κ.match_ (W.pairing (iterWalk κ β t)) := iterWalk_succ κ β t + rw [h1, κ.match_invol _ (hcont t (by omega))] + · -- pairing-side: `match (pairing (iterWalk β t)) = iterWalk β (t+1)` + have htne : t ≠ k := by + intro hEq + subst hEq + exact Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags hf hterm + refine ⟨k, t + 1, by omega, hcont, hterm, Or.inl ?_⟩ + exact (iterWalk_succ κ β t).symm + +end OnChain + +/-! ## Case 1: squares on circuits -/ + +section PeriodicSquare + +variable {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {a b c d : W.Flag} {v : W.Vertex} + +/-- **Case 1**: a square on periodic (circuit) components leaves +every path matching unchanged. -/ +theorem pathMatch_repair_of_periodic (hsq : RepairSquare κ a b c d v) + (hpa : κ.PeriodicFlag a) (hpc : κ.PeriodicFlag c) : + ∀ δ (hδ : δ ∈ F.boundaryFlags), + (κ.repair a b c d v hsq).pathMatch δ hδ = κ.pathMatch δ hδ := by + have hpb : κ.PeriodicFlag b := hsq.hab ▸ periodicFlag_match hpa + have hpd : κ.PeriodicFlag d := hsq.hcd ▸ periodicFlag_match hpc + intro δ hδ + obtain ⟨kδ, hkδ, hcontδ, htermδ⟩ := chain_terminates_with_data κ hδ + refine pathMatch_repair_of_avoid hsq hδ hkδ hcontδ htermδ ?_ + intro s hs + exact ⟨chain_arg_ne_of_periodic hδ hcontδ htermδ hpa hs, + chain_arg_ne_of_periodic hδ hcontδ htermδ hpb hs, + chain_arg_ne_of_periodic hδ hcontδ htermδ hpc hs, + chain_arg_ne_of_periodic hδ hcontδ htermδ hpd hs⟩ + +end PeriodicSquare + +/-! ## Cases 2–3: squares localized to one chain -/ + +section ChainLocalSquare + +variable {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {a b c d : W.Flag} {v : W.Vertex} + +/-- **Cases 2–3**: a square whose four flags are each periodic or on +the chain of one boundary flag `β` leaves every path matching +unchanged. Untouched chains avoid the square by rigidity +(`chain_meet`); the two ends of `β`'s chain must then re-pair with +each other, because the repaired path matching is a fixed-point-free +involution and every other boundary end is already taken. -/ +theorem pathMatch_repair_of_chainLocal (hsq : RepairSquare κ a b c d v) + {β : W.Flag} (hβ : β ∈ F.boundaryFlags) + (hloc : ∀ f, f = a ∨ f = b ∨ f = c ∨ f = d → + κ.PeriodicFlag f ∨ OnBoundaryChain κ β f) : + ∀ δ (hδ : δ ∈ F.boundaryFlags), + (κ.repair a b c d v hsq).pathMatch δ hδ = κ.pathMatch δ hδ := by + obtain ⟨k, hkle, hcont, hterm⟩ := chain_terminates_with_data κ hβ + have hγpm : κ.pathMatch β hβ = W.pairing (iterWalk κ β k) := + κ.pathMatch_eq hβ (traceChain_fuel_mono κ (by omega) + (traceChain_forward κ β hcont hterm)) + -- normalize the chain positions to the canonical exit step + have hloc' : ∀ f, f = a ∨ f = b ∨ f = c ∨ f = d → + κ.PeriodicFlag f ∨ + ∃ t ≤ k, f = iterWalk κ β t ∨ + f = W.pairing (iterWalk κ β t) := by + intro f hf + rcases hloc f hf with hper | ⟨k', t, htk', hcont', hterm', hft⟩ + · exact Or.inl hper + · have hkk : k' = k := chain_exit_unique hcont' hterm' hcont hterm + subst hkk + exact Or.inr ⟨t, htk', hft⟩ + -- untouched chains: avoidance by rigidity + have hA : ∀ δ (hδ : δ ∈ F.boundaryFlags), δ ≠ β → + δ ≠ W.pairing (iterWalk κ β k) → + (κ.repair a b c d v hsq).pathMatch δ hδ = + κ.pathMatch δ hδ := by + intro δ hδ hδβ hδγ + obtain ⟨kδ, hkδ, hcontδ, htermδ⟩ := + chain_terminates_with_data κ hδ + refine pathMatch_repair_of_avoid hsq hδ hkδ hcontδ htermδ ?_ + intro s hs + have hne : ∀ f, f = a ∨ f = b ∨ f = c ∨ f = d → + W.pairing (iterWalk κ δ s) ≠ f := by + intro f hf + rcases hloc' f hf with hper | ⟨t, htk, hft⟩ + · exact chain_arg_ne_of_periodic hδ hcontδ htermδ hper hs + · exact chain_arg_ne_of_onChain hβ hδ hcont hterm hcontδ + hδβ hδγ htk hft hs + exact ⟨hne a (Or.inl rfl), hne b (Or.inr (Or.inl rfl)), + hne c (Or.inr (Or.inr (Or.inl rfl))), + hne d (Or.inr (Or.inr (Or.inr rfl)))⟩ + -- the affected chain: its two ends re-pair with each other + have hB : (κ.repair a b c d v hsq).pathMatch β hβ = + W.pairing (iterWalk κ β k) := by + by_contra hne + have hδmem : (κ.repair a b c d v hsq).pathMatch β hβ ∈ + F.boundaryFlags := (κ.repair a b c d v hsq).pathMatch_mem hβ + have hδβ : (κ.repair a b c d v hsq).pathMatch β hβ ≠ β := + (κ.repair a b c d v hsq).pathMatch_ne_self hβ + have h1 := hA _ hδmem hδβ hne + have h2 : (κ.repair a b c d v hsq).pathMatch + ((κ.repair a b c d v hsq).pathMatch β hβ) hδmem = β := + (κ.repair a b c d v hsq).pathMatch_invol hβ + have h3 : κ.pathMatch ((κ.repair a b c d v hsq).pathMatch β hβ) + hδmem = β := h1.symm.trans h2 + have h4 : κ.pathMatch β hβ = + (κ.repair a b c d v hsq).pathMatch β hβ := + calc κ.pathMatch β hβ + = κ.pathMatch (κ.pathMatch + ((κ.repair a b c d v hsq).pathMatch β hβ) hδmem) + (κ.pathMatch_mem hδmem) := + κ.pathMatch_congr h3.symm hβ _ + _ = (κ.repair a b c d v hsq).pathMatch β hβ := + κ.pathMatch_invol hδmem + exact hne (h4.symm.trans hγpm) + -- the reverse end + have hγmem : W.pairing (iterWalk κ β k) ∈ F.boundaryFlags := hterm + have hγpm' : κ.pathMatch (W.pairing (iterWalk κ β k)) hγmem = β := + calc κ.pathMatch (W.pairing (iterWalk κ β k)) hγmem + = κ.pathMatch (κ.pathMatch β hβ) (κ.pathMatch_mem hβ) := + κ.pathMatch_congr hγpm.symm hγmem _ + _ = β := κ.pathMatch_invol hβ + have hC : (κ.repair a b c d v hsq).pathMatch + (W.pairing (iterWalk κ β k)) hγmem = β := by + have h5 := (κ.repair a b c d v hsq).pathMatch_congr hB.symm hγmem + ((κ.repair a b c d v hsq).pathMatch_mem hβ) + exact h5.trans ((κ.repair a b c d v hsq).pathMatch_invol hβ) + intro δ hδ + by_cases h1 : δ = β + · subst h1 + exact hB.trans hγpm.symm + · by_cases h2 : δ = W.pairing (iterWalk κ β k) + · subst h2 + exact hC.trans hγpm'.symm + · exact hA δ hδ h1 h2 + +end ChainLocalSquare + +/-! ## The localized case predicate -/ + +section Localized + +variable {F : EdgeSubset W} + +/-- The square is **localized** (cases 1–3 of the path ledger): the +two re-paired edges lie on periodic components, or each of the four +flags is periodic or on the chain of a single boundary flag. The +complement is the genuine two-path case (case 4). -/ +def SquareLocalized (κ : F.RelTransitionSystem) + (a b c d : W.Flag) : Prop := + (κ.PeriodicFlag a ∧ κ.PeriodicFlag c) ∨ + ∃ β, β ∈ F.boundaryFlags ∧ + ∀ f, f = a ∨ f = b ∨ f = c ∨ f = d → + κ.PeriodicFlag f ∨ OnBoundaryChain κ β f + +variable {κ : F.RelTransitionSystem} {a b c d : W.Flag} + {v : W.Vertex} + +/-- **(ii) pathMatch invariance in cases 1–3**: a localized square +leaves every path matching unchanged. -/ +theorem pathMatch_repair_of_localized (hsq : RepairSquare κ a b c d v) + (hloc : SquareLocalized κ a b c d) : + ∀ δ (hδ : δ ∈ F.boundaryFlags), + (κ.repair a b c d v hsq).pathMatch δ hδ = κ.pathMatch δ hδ := by + rcases hloc with ⟨hpa, hpc⟩ | ⟨β, hβ, hlocal⟩ + · exact pathMatch_repair_of_periodic hsq hpa hpc + · exact pathMatch_repair_of_chainLocal hsq hβ hlocal + +end Localized + +/-! ## The crossing sign under pathMatch-preserving moves -/ + +section ChordCongr + +/-- The chord-interleaving relation only depends on the path +matching. -/ +theorem chordCross_congr [LinearOrder α] {F : EdgeSubset W} + {κ κ' : F.RelTransitionSystem} + (hpm : ∀ δ (hδ : δ ∈ F.boundaryFlags), + κ'.pathMatch δ hδ = κ.pathMatch δ hδ) + (b b' : {x : W.Flag // x ∈ F.boundaryFlags}) : + ChordCross κ' b b' ↔ ChordCross κ b b' := by + unfold ChordCross + rw [hpm b.val b.prop, hpm b'.val b'.prop] + +/-- The chord-crossing count only depends on the path matching. -/ +theorem chordCrossingCount_congr [LinearOrder α] {F : EdgeSubset W} + {κ κ' : F.RelTransitionSystem} + (hpm : ∀ δ (hδ : δ ∈ F.boundaryFlags), + κ'.pathMatch δ hδ = κ.pathMatch δ hδ) : + chordCrossingCount κ' = chordCrossingCount κ := by + classical + unfold chordCrossingCount + exact congrArg Finset.card + (Finset.filter_congr + (fun bb _ => chordCross_congr hpm bb.1 bb.2)) + +/-- The path sign only depends on the path matching. -/ +theorem pathSign_congr [LinearOrder α] {F : EdgeSubset W} + {κ κ' : F.RelTransitionSystem} + (hpm : ∀ δ (hδ : δ ∈ F.boundaryFlags), + κ'.pathMatch δ hδ = κ.pathMatch δ hδ) : + pathSign κ' = pathSign κ := by + unfold pathSign + rw [chordCrossingCount_congr hpm] + +end ChordCongr + +/-! ## The MatchEq layer for the path sign -/ + +section MatchEqPath + +variable {F : EdgeSubset W} + +/-- Matching-equal systems have equal path matchings. -/ +theorem pathMatch_matchEq {κ₁ κ₂ : F.RelTransitionSystem} + (heq : κ₁.MatchEq κ₂) {δ : W.Flag} + (hδ : δ ∈ F.boundaryFlags) : + κ₂.pathMatch δ hδ = κ₁.pathMatch δ hδ := by + obtain ⟨k, hk, hcont, hterm⟩ := chain_terminates_with_data κ₁ hδ + have hwalk : ∀ t, t ≤ k → iterWalk κ₂ δ t = iterWalk κ₁ δ t := by + intro t + induction t with + | zero => intro _; rfl + | succ t ih => + intro ht + rw [iterWalk_succ, iterWalk_succ, ih (by omega), + ← heq _ (hcont t (by omega))] + have hcont' : ∀ j, j < k → + W.pairing (iterWalk κ₂ δ j) ∈ F.internalFlags := by + intro j hj + rw [hwalk j (by omega)] + exact hcont j hj + have hterm' : W.pairing (iterWalk κ₂ δ k) ∈ F.boundaryFlags := by + rw [hwalk k le_rfl] + exact hterm + have h1 : κ₂.pathMatch δ hδ = W.pairing (iterWalk κ₂ δ k) := + κ₂.pathMatch_eq hδ + (traceChain_fuel_mono κ₂ (by omega) + (traceChain_forward κ₂ δ hcont' hterm')) + have h2 : κ₁.pathMatch δ hδ = W.pairing (iterWalk κ₁ δ k) := + κ₁.pathMatch_eq hδ + (traceChain_fuel_mono κ₁ (by omega) + (traceChain_forward κ₁ δ hcont hterm)) + rw [h1, h2, hwalk k le_rfl] + +/-- Matching-equal systems have equal chord-crossing counts. -/ +theorem chordCrossingCount_matchEq [LinearOrder α] + {κ₁ κ₂ : F.RelTransitionSystem} (heq : κ₁.MatchEq κ₂) : + chordCrossingCount κ₂ = chordCrossingCount κ₁ := + chordCrossingCount_congr (fun _ hδ => pathMatch_matchEq heq hδ) + +/-- Matching-equal systems have equal path signs. -/ +theorem pathSign_matchEq [LinearOrder α] + {κ₁ κ₂ : F.RelTransitionSystem} (heq : κ₁.MatchEq κ₂) : + pathSign κ₂ = pathSign κ₁ := + pathSign_congr (fun _ hδ => pathMatch_matchEq heq hδ) + +end MatchEqPath + +/-! ## Classification: periodic, one chain, or two chains -/ + +section Classification + +/-- Every internal flag is periodic or lies on the chain of some +boundary flag. -/ +theorem periodic_or_onBoundaryChain {F : EdgeSubset W} + (κ : F.RelTransitionSystem) + {f : W.Flag} (hf : f ∈ F.internalFlags) : + κ.PeriodicFlag f ∨ + ∃ β ∈ F.boundaryFlags, OnBoundaryChain κ β f := by + rcases internal_periodic_or_terminates κ f hf with hper | hterm + · exact Or.inl hper + · right + obtain ⟨fuel, b0, hchain⟩ := hterm + obtain ⟨kf, hcontf, hexitf, hb0⟩ := + traceChain_some_exit κ fuel f b0 hchain + have hβ : W.pairing (iterWalk κ f kf) ∈ F.boundaryFlags := by + rw [hexitf]; exact hb0 + have hcontb : ∀ t, t ≤ kf → + W.pairing (iterWalk κ (W.pairing (iterWalk κ f kf)) t) ∈ + F.internalFlags := by + intro t ht + rw [iterWalk_reverse κ hcontf t ht, W.pairing_invol] + rcases Nat.lt_or_ge t kf with h | h + · exact iterWalk_mem_internal κ kf (by omega) (by omega) + hcontf + · rw [show kf - t = 0 from by omega, iterWalk_zero] + exact hf + obtain ⟨k', hk'le, hcont', hterm'⟩ := + chain_terminates_with_data κ hβ + have hk'gt : kf < k' := by + by_contra hle + exact Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags + (hcontb k' (by omega)) hterm' + have hfeq : + W.pairing (iterWalk κ (W.pairing (iterWalk κ f kf)) kf) = + f := reverse_chain_terminates κ hcontf + exact ⟨W.pairing (iterWalk κ f kf), hβ, + k', kf, by omega, hcont', hterm', Or.inr hfeq.symm⟩ + +/-- Chain membership from the far end of a chain is chain membership +from the near end. -/ +theorem onBoundaryChain_of_reverse + {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {β f : W.Flag} + (hβ : β ∈ F.boundaryFlags) {k : ℕ} + (hcont : ∀ j, j < k → + W.pairing (iterWalk κ β j) ∈ F.internalFlags) + (hterm : W.pairing (iterWalk κ β k) ∈ F.boundaryFlags) + (h : OnBoundaryChain κ (W.pairing (iterWalk κ β k)) f) : + OnBoundaryChain κ β f := by + obtain ⟨kγ, t, htk, hcontγ, htermγ, hft⟩ := h + have hcontγ' : ∀ j, j < k → + W.pairing (iterWalk κ (W.pairing (iterWalk κ β k)) j) ∈ + F.internalFlags := + fun j hj => reverse_chain_continues κ hβ hcont j hj + have htermγ' : + W.pairing (iterWalk κ (W.pairing (iterWalk κ β k)) k) ∈ + F.boundaryFlags := by + rw [reverse_chain_terminates κ hcont] + exact hβ + have hkk : kγ = k := chain_exit_unique hcontγ htermγ hcontγ' htermγ' + subst hkk + have hrev := iterWalk_reverse κ hcont t htk + refine ⟨kγ, kγ - t, by omega, hcont, hterm, ?_⟩ + rcases hft with rfl | rfl + · exact Or.inr hrev + · refine Or.inl ?_ + rw [hrev, W.pairing_invol] + +/-- **The two-path classification**: a non-localized square has its +two re-paired edges on two genuinely distinct boundary chains. -/ +theorem twoChains_of_not_localized + {F : EdgeSubset W} {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} + {c : W.Flag} {d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) + (hnl : ¬ SquareLocalized κ a b c d) : + ∃ (β₁ β₂ : W.Flag) (hβ₁ : β₁ ∈ F.boundaryFlags) + (_hβ₂ : β₂ ∈ F.boundaryFlags), + OnBoundaryChain κ β₁ a ∧ OnBoundaryChain κ β₂ c ∧ + β₂ ≠ β₁ ∧ β₂ ≠ κ.pathMatch β₁ hβ₁ := by + rcases periodic_or_onBoundaryChain κ hsq.ha with + hpa | ⟨β₁, hβ₁, hca⟩ + · rcases periodic_or_onBoundaryChain κ hsq.hc with + hpc | ⟨β₂, hβ₂, hcc⟩ + · exact absurd (Or.inl ⟨hpa, hpc⟩) hnl + · exfalso + refine hnl (Or.inr ⟨β₂, hβ₂, ?_⟩) + intro f hf + rcases hf with rfl | rfl | rfl | rfl + · exact Or.inl hpa + · exact Or.inl (hsq.hab ▸ periodicFlag_match hpa) + · exact Or.inr hcc + · exact Or.inr + (hsq.hcd ▸ onBoundaryChain_match hβ₂ hsq.hc hcc) + · rcases periodic_or_onBoundaryChain κ hsq.hc with + hpc | ⟨β₂, hβ₂, hcc⟩ + · exfalso + refine hnl (Or.inr ⟨β₁, hβ₁, ?_⟩) + intro f hf + rcases hf with rfl | rfl | rfl | rfl + · exact Or.inr hca + · exact Or.inr + (hsq.hab ▸ onBoundaryChain_match hβ₁ hsq.ha hca) + · exact Or.inl hpc + · exact Or.inl (hsq.hcd ▸ periodicFlag_match hpc) + · by_cases h12 : β₂ = β₁ + · subst h12 + exfalso + refine hnl (Or.inr ⟨β₂, hβ₂, ?_⟩) + intro f hf + rcases hf with rfl | rfl | rfl | rfl + · exact Or.inr hca + · exact Or.inr + (hsq.hab ▸ onBoundaryChain_match hβ₂ hsq.ha hca) + · exact Or.inr hcc + · exact Or.inr + (hsq.hcd ▸ onBoundaryChain_match hβ₂ hsq.hc hcc) + · by_cases h1γ : β₂ = κ.pathMatch β₁ hβ₁ + · exfalso + obtain ⟨k, hkle, hcont, hterm⟩ := + chain_terminates_with_data κ hβ₁ + have hγ : κ.pathMatch β₁ hβ₁ = + W.pairing (iterWalk κ β₁ k) := + κ.pathMatch_eq hβ₁ (traceChain_fuel_mono κ (by omega) + (traceChain_forward κ β₁ hcont hterm)) + have hcc' : OnBoundaryChain κ β₁ c := by + refine onBoundaryChain_of_reverse hβ₁ hcont hterm ?_ + rw [← hγ, ← h1γ] + exact hcc + refine hnl (Or.inr ⟨β₁, hβ₁, ?_⟩) + intro f hf + rcases hf with rfl | rfl | rfl | rfl + · exact Or.inr hca + · exact Or.inr + (hsq.hab ▸ onBoundaryChain_match hβ₁ hsq.ha hca) + · exact Or.inr hcc' + · exact Or.inr + (hsq.hcd ▸ onBoundaryChain_match hβ₁ hsq.hc hcc') + · exact ⟨β₁, β₂, hβ₁, hβ₂, hca, hcc, h12, h1γ⟩ + +end Classification + +/-! ## Circuit flips: orbit-supported orientation gauges -/ + +section OrbitFlip + +variable {F : EdgeSubset W} {κ : F.RelTransitionSystem} + +/-- The flags of the walk orbit through `g`, on both sides of each +visited edge. -/ +def OrbitFlag (κ : F.RelTransitionSystem) (g f : W.Flag) : Prop := + ∃ m, f = iterWalk κ g m ∨ f = W.pairing (iterWalk κ g m) + +/-- A flag lies on its own orbit. -/ +theorem orbitFlag_self (κ : F.RelTransitionSystem) (g : W.Flag) : + OrbitFlag κ g g := ⟨0, Or.inl rfl⟩ + +/-- Orbits are closed under the edge pairing. -/ +theorem orbitFlag_pairing {g f : W.Flag} (hf : OrbitFlag κ g f) : + OrbitFlag κ g (W.pairing f) := by + obtain ⟨m, rfl | rfl⟩ := hf + · exact ⟨m, Or.inr rfl⟩ + · exact ⟨m, Or.inl (W.pairing_invol _)⟩ + +/-- And under it backwards. -/ +theorem orbitFlag_of_pairing {g f : W.Flag} + (h : OrbitFlag κ g (W.pairing f)) : OrbitFlag κ g f := by + have h2 := orbitFlag_pairing h + rwa [W.pairing_invol] at h2 + +/-- Every flag on a periodic flag's orbit is internal: a closed +circuit never reaches the boundary. -/ +theorem orbitFlag_internal {g f : W.Flag} (hg : κ.PeriodicFlag g) + (hf : OrbitFlag κ g f) : f ∈ F.internalFlags := by + obtain ⟨m, rfl | rfl⟩ := hf + · rcases Nat.eq_zero_or_pos m with rfl | hm + · rw [iterWalk_zero] + exact hg.mem_internal + · exact iterWalk_mem_internal_of_periodic κ hg m hm + · exact all_pairings_internal_of_periodic κ hg m + +/-- So is each such flag's edge partner. -/ +theorem orbitFlag_pairing_internal {g f : W.Flag} + (hg : κ.PeriodicFlag g) (hf : OrbitFlag κ g f) : + W.pairing f ∈ F.internalFlags := + orbitFlag_internal hg (orbitFlag_pairing hf) + +/-- A periodic orbit is closed under the matching. -/ +theorem orbitFlag_match {g f : W.Flag} (hg : κ.PeriodicFlag g) + (hf : OrbitFlag κ g f) : OrbitFlag κ g (κ.match_ f) := by + obtain ⟨hgint, n, hn1, hcont, hper⟩ := hg + have hg' : κ.PeriodicFlag g := ⟨hgint, n, hn1, hcont, hper⟩ + obtain ⟨m, rfl | rfl⟩ := hf + · have hshift : iterWalk κ g (n + m) = iterWalk κ g m := + iterWalk_add_period κ g n m hper + obtain ⟨m₀, hm₀⟩ : ∃ m₀, n + m = m₀ + 1 := ⟨n + m - 1, by omega⟩ + have hmm : κ.match_ (iterWalk κ g m) = + W.pairing (iterWalk κ g m₀) := by + rw [← hshift, hm₀, iterWalk_succ] + exact κ.match_invol _ + (all_pairings_internal_of_periodic κ hg' m₀) + rw [hmm] + exact ⟨m₀, Or.inr rfl⟩ + · have hmm : κ.match_ (W.pairing (iterWalk κ g m)) = + iterWalk κ g (m + 1) := (iterWalk_succ κ g m).symm + rw [hmm] + exact ⟨m + 1, Or.inl rfl⟩ + +/-- And under it backwards. -/ +theorem orbitFlag_of_match {g f : W.Flag} (hg : κ.PeriodicFlag g) + (hf : f ∈ F.internalFlags) (h : OrbitFlag κ g (κ.match_ f)) : + OrbitFlag κ g f := by + have h2 := orbitFlag_match hg h + rwa [κ.match_invol f hf] at h2 + +open Classical in +/-- Flip an orientation on the walk orbit of a periodic flag: a +circuit-supported orientation gauge. -/ +noncomputable def RelTransitionSystem.Orientation.flipOrbit + (o : κ.Orientation) {g : W.Flag} (hg : κ.PeriodicFlag g) : + κ.Orientation where + isOut f := if OrbitFlag κ g f then !o.isOut f else o.isOut f + match_flip := by + intro f hf + show (if OrbitFlag κ g (κ.match_ f) then !o.isOut (κ.match_ f) + else o.isOut (κ.match_ f)) = + !(if OrbitFlag κ g f then !o.isOut f else o.isOut f) + by_cases hfo : OrbitFlag κ g f + · rw [ite_eq_left (orbitFlag_match hg hfo), ite_eq_left hfo, + o.match_flip f hf] + · rw [ite_eq_right (fun hcon => hfo (orbitFlag_of_match hg hf hcon)), + ite_eq_right hfo] + exact o.match_flip f hf + pairing_flip := by + intro f hf hp + show (if OrbitFlag κ g (W.pairing f) then !o.isOut (W.pairing f) + else o.isOut (W.pairing f)) = + !(if OrbitFlag κ g f then !o.isOut f else o.isOut f) + by_cases hfo : OrbitFlag κ g f + · rw [ite_eq_left (orbitFlag_pairing hfo), ite_eq_left hfo, + o.pairing_flip f hf hp] + · rw [ite_eq_right (fun hcon => hfo (orbitFlag_of_pairing hcon)), + ite_eq_right hfo] + exact o.pairing_flip f hf hp + +/-- Flipping an orbit reverses the orientation on it. -/ +theorem flipOrbit_isOut_of_mem (o : κ.Orientation) {g : W.Flag} + (hg : κ.PeriodicFlag g) {f : W.Flag} (hf : OrbitFlag κ g f) : + (o.flipOrbit hg).isOut f = !o.isOut f := by + classical + change (if OrbitFlag κ g f then !o.isOut f else o.isOut f) = + !o.isOut f + exact ite_eq_left hf + +/-- And leaves it alone elsewhere. -/ +theorem flipOrbit_isOut_of_notMem (o : κ.Orientation) {g : W.Flag} + (hg : κ.PeriodicFlag g) {f : W.Flag} (hf : ¬ OrbitFlag κ g f) : + (o.flipOrbit hg).isOut f = o.isOut f := by + classical + change (if OrbitFlag κ g f then !o.isOut f else o.isOut f) = + o.isOut f + exact ite_eq_right hf + +/-- An orbit flip is a circuit-supported gauge, so the constrained +summand is invariant under it: the difference is supported on +closed circuits. -/ +theorem throughSummand_flipOrbit [LinearOrder α] {k ℓ : ℕ} + (hM : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (o : κ.Orientation) {g : W.Flag} (hg : κ.PeriodicFlag g) + (c : ℕ) : + F.throughSummand hM st hbnd (o.flipOrbit hg) c = + F.throughSummand hM st hbnd o c := by + refine throughSummand_orientation_invariant F hM st hbnd _ o + (fun f hf hne => ?_) c + by_cases hfo : OrbitFlag κ g f + · exact orbitFlag_pairing_internal hg hfo + · exact absurd (flipOrbit_isOut_of_notMem o hg hfo) hne + +end OrbitFlip + +end EdgeSubset + +/-! ## The per-move interface and its inputs -/ + +/-- **The count-parity hypothesis (cases 1–3)**: a separated +square on a localized configuration flips the circuit-count parity +(the splice merges two circuits, Δ = −1, or splits one component, +Δ = +1). Discharged in `SeparatedParity.lean`. -/ +def SeparatedCountParity : Prop := + ∀ {α : Type} {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a b c d : W.Flag} {v : W.Vertex} + (hsq : EdgeSubset.RepairSquare κ a b c d v) (o : κ.Orientation), + o.isOut c = !o.isOut a → + EdgeSubset.SquareLocalized κ a b c d → + Odd (κ.openCircuitCount + + (κ.repair a b c d v hsq).openCircuitCount) + +/-- **The flipped-segment hypothesis (non-separated moves)**: a +non-separated square (`isOut c = isOut a`) admits an +orientation on the repaired system realizing the same +pathSign-weighted summand. The structure: the repaired walk +reverses a segment (Δ = 0), the transported orientation flips on +the reversed segment, and the vertex transposition (−1) cancels +against the segment-reversal telescope (+1 total). Discharged in +`NonSeparatedStep.lean`. -/ +def NonSeparatedStep : Prop := + ∀ {α : Type} [LinearOrder α] {W : Fragment α} (F : EdgeSubset W) + {k ℓ : ℕ} (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ : F.RelTransitionSystem} {a b c d : W.Flag} {v : W.Vertex} + (hsq : EdgeSubset.RepairSquare κ a b c d v) (o : κ.Orientation), + o.isOut c = o.isOut a → + ∃ o' : (κ.repair a b c d v hsq).Orientation, + EdgeSubset.pathSign (κ.repair a b c d v hsq) * + F.throughSummand hM st hbnd o' + ((κ.repair a b c d v hsq).openCircuitCount) = + EdgeSubset.pathSign κ * + F.throughSummand hM st hbnd o κ.openCircuitCount + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PathMatch.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathMatch.lean new file mode 100644 index 0000000000..3b598a2ad2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathMatch.lean @@ -0,0 +1,535 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelTransition + +/-! +# Path matching on boundary flags + +For a boundary-relative transition system `κ : RelTransitionSystem F`, +the alternating paths traced by `traceChain` pair the boundary flags +of the edge subset. This file constructs the path matching as a +proven involution on boundary flags. + +## Main results + +* `RelTransitionSystem.pathMatch` — sends each boundary flag to the + boundary flag at the other end of its alternating chain. +* `pathMatch_mem` — the result is a boundary flag. +* `pathMatch_invol` — `pathMatch` is an involution. + +## Proof architecture + +Chain termination uses a pigeonhole/backward-injectivity argument on +the pairings visited at each step. The involution is proved via an +identity on the reverse iterate sequence: +`iterWalk κ b' j = σ(iterWalk κ b (k - j))` (where `b'` is the +chain result and `σ` is the edge pairing), established by induction +on `j` using `match_invol`. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} {W : Fragment α} + +namespace EdgeSubset + +variable {F : EdgeSubset W} + +/-! ### Flag classification helpers -/ + +private theorem not_boundary_of_internal + {f : W.Flag} (hf : f ∈ F.internalFlags) : + f ∉ F.boundaryFlags := + Finset.disjoint_left.mp F.internalFlags_disjoint_boundaryFlags hf + +/-! ### traceChain rewriting lemmas -/ + +/-- One step of the chain when the flag's edge partner is internal: +match and recurse on one less fuel. -/ +theorem traceChain_internal (κ : F.RelTransitionSystem) + (n : ℕ) (f : W.Flag) (h : W.pairing f ∈ F.internalFlags) : + traceChain κ (n + 1) f = + traceChain κ n (κ.match_ (W.pairing f)) := by + conv_lhs => unfold traceChain + simp only [ite_eq_right (not_boundary_of_internal h), dite_eq_left h] + +/-- The chain stops at the first boundary partner and returns it. -/ +theorem traceChain_boundary (κ : F.RelTransitionSystem) + (n : ℕ) (f : W.Flag) (h : W.pairing f ∈ F.boundaryFlags) : + traceChain κ (n + 1) f = some (W.pairing f) := by + conv_lhs => unfold traceChain; simp only [ite_eq_left h] + +/-- The chain fails on a partner outside the subset. -/ +theorem traceChain_neither (κ : F.RelTransitionSystem) + (n : ℕ) (f : W.Flag) + (hb : W.pairing f ∉ F.boundaryFlags) + (hi : W.pairing f ∉ F.internalFlags) : + traceChain κ (n + 1) f = none := by + conv_lhs => unfold traceChain + simp only [ite_eq_right hb, dite_eq_right hi] + +/-! ### Fuel monotonicity -/ + +/-- Extra fuel does not change a successful result. -/ +theorem traceChain_fuel_mono (κ : F.RelTransitionSystem) + {f g : W.Flag} {n m : ℕ} (hnm : n ≤ m) + (h : traceChain κ n f = some g) : + traceChain κ m f = some g := by + induction n generalizing f m with + | zero => simp [traceChain] at h + | succ n ih => + obtain ⟨d, rfl⟩ := Nat.exists_eq_add_of_le hnm + rw [show n + 1 + d = (n + d) + 1 from by omega] + by_cases hb : W.pairing f ∈ F.boundaryFlags + · rw [traceChain_boundary κ n f hb] at h + rw [traceChain_boundary κ (n + d) f hb]; exact h + · by_cases hi : W.pairing f ∈ F.internalFlags + · rw [traceChain_internal κ n f hi] at h + rw [traceChain_internal κ (n + d) f hi] + exact ih (Nat.le_add_right n d) h + · rw [traceChain_neither κ n f hb hi] at h; cases h + +/-! ### Result is boundary -/ + +/-- A chain that succeeds ends at a boundary flag. -/ +theorem traceChain_result_boundary (κ : F.RelTransitionSystem) + {f g : W.Flag} {n : ℕ} + (h : traceChain κ n f = some g) : g ∈ F.boundaryFlags := by + induction n generalizing f with + | zero => simp [traceChain] at h + | succ n ih => + by_cases hb : W.pairing f ∈ F.boundaryFlags + · rw [traceChain_boundary κ n f hb] at h + exact (Option.some.inj h) ▸ hb + · by_cases hi : W.pairing f ∈ F.internalFlags + · rw [traceChain_internal κ n f hi] at h; exact ih h + · rw [traceChain_neither κ n f hb hi] at h; cases h + +/-! ### Iterated walk -/ + +/-- The fuel-free chain step iterated: cross the edge, then match. +This is `traceChain`'s recursion without the termination test, so +the two can be compared step by step. -/ +noncomputable def iterWalk (κ : F.RelTransitionSystem) + (f : W.Flag) : ℕ → W.Flag + | 0 => f + | n + 1 => κ.match_ (W.pairing (iterWalk κ f n)) + +/-- No steps leave the flag where it is. -/ +@[simp] theorem iterWalk_zero (κ : F.RelTransitionSystem) + (f : W.Flag) : iterWalk κ f 0 = f := rfl + +/-- One more step: cross the edge from the current flag, then +match. -/ +theorem iterWalk_succ (κ : F.RelTransitionSystem) + (f : W.Flag) (n : ℕ) : + iterWalk κ f (n + 1) = + κ.match_ (W.pairing (iterWalk κ f n)) := rfl + +/-- Splitting an iterated walk. -/ +theorem iterWalk_add (κ : F.RelTransitionSystem) (f : W.Flag) + (a b : ℕ) : + iterWalk κ f (a + b) = iterWalk κ (iterWalk κ f a) b := by + induction b with + | zero => rfl + | succ b ih => + rw [show a + (b + 1) = (a + b) + 1 from rfl, iterWalk_succ, + ih, ← iterWalk_succ] + +/-- Starting one step along is the same as taking one more step. -/ +theorem iterWalk_shift (κ : F.RelTransitionSystem) + (f : W.Flag) (k : ℕ) : + iterWalk κ (κ.match_ (W.pairing f)) k = + iterWalk κ f (k + 1) := by + induction k with + | zero => simp [iterWalk] + | succ k ih => simp only [iterWalk, ih] + +/-- While the chain continues, every flag it reaches after the first +step is internal. -/ +theorem iterWalk_mem_internal (κ : F.RelTransitionSystem) + {b : W.Flag} (k : ℕ) {j : ℕ} (hj : 1 ≤ j) + (hjk : j ≤ k) + (hcont : ∀ i, i < k → + W.pairing (iterWalk κ b i) ∈ F.internalFlags) : + iterWalk κ b j ∈ F.internalFlags := by + cases j with + | zero => omega + | succ j' => + rw [iterWalk_succ] + exact κ.match_mem _ (hcont j' (by omega)) + +/-! ### match_ injectivity on internal flags -/ + +/-- The matching is injective on internal flags, being an +involution there. -/ +theorem RelTransitionSystem.match_injOn + (κ : F.RelTransitionSystem) {x y : W.Flag} + (hx : x ∈ F.internalFlags) (hy : y ∈ F.internalFlags) + (h : κ.match_ x = κ.match_ y) : x = y := + calc x = κ.match_ (κ.match_ x) := (κ.match_invol x hx).symm + _ = κ.match_ (κ.match_ y) := by rw [h] + _ = y := κ.match_invol y hy + +/-! ### Chain unfolding -/ + +/-- Splitting the fuel: `k` steps of a continuing chain can be run +first, leaving the rest of the chain from the flag reached. -/ +theorem traceChain_unfold (κ : F.RelTransitionSystem) + (f : W.Flag) (k m : ℕ) + (hcont : ∀ j, j < k → + W.pairing (iterWalk κ f j) ∈ F.internalFlags) : + traceChain κ (k + m + 1) f = + traceChain κ (m + 1) (iterWalk κ f k) := by + induction k generalizing f with + | zero => simp [iterWalk] + | succ k ih => + have h0 := hcont 0 (by omega) + simp only [iterWalk_zero] at h0 + rw [show k + 1 + m + 1 = (k + m + 1) + 1 from by omega] + rw [traceChain_internal κ (k + m + 1) f h0] + rw [ih _ (fun j hj => by + rw [iterWalk_shift]; exact hcont (j + 1) (by omega))] + congr 1; exact iterWalk_shift κ f k + +/-! ### Backward injectivity -/ + +/-- **A continuing chain never revisits a flag.** A repeat would +force the matching to send two distinct internal flags to the same +place, or the chain to re-enter its own boundary start. -/ +theorem iterWalk_no_repeat (κ : F.RelTransitionSystem) + {b : W.Flag} (hb : b ∈ F.boundaryFlags) (k : ℕ) + (hcont : ∀ j, j < k → + W.pairing (iterWalk κ b j) ∈ F.internalFlags) + (i d : ℕ) (hd : 1 ≤ d) (hidk : i + d ≤ k) + (heq : iterWalk κ b i = iterWalk κ b (i + d)) : + False := by + induction i with + | zero => + simp only [Nat.zero_add] at heq hidk + have hmem : iterWalk κ b d ∈ F.internalFlags := + iterWalk_mem_internal κ k hd hidk + (fun j hj => hcont j (by omega)) + rw [← heq] at hmem + exact not_boundary_of_internal hmem hb + | succ i ih => + apply ih (by omega) + rw [iterWalk_succ, + show i + 1 + d = (i + d) + 1 from by omega, + iterWalk_succ] at heq + have hm1 := hcont i (by omega) + have hm2 := hcont (i + d) (by omega) + calc iterWalk κ b i + = W.pairing (W.pairing (iterWalk κ b i)) := + (W.pairing_invol _).symm + _ = W.pairing (W.pairing (iterWalk κ b (i + d))) := + by rw [κ.match_injOn hm1 hm2 heq] + _ = iterWalk κ b (i + d) := W.pairing_invol _ + +/-- The edge partners visited by a continuing chain are pairwise +distinct — the pigeonhole input for termination. -/ +theorem pairing_iterWalk_injective + (κ : F.RelTransitionSystem) + {b : W.Flag} (hb : b ∈ F.boundaryFlags) (k : ℕ) + (hcont : ∀ j, j < k → + W.pairing (iterWalk κ b j) ∈ F.internalFlags) + {i j : ℕ} (hi : i < k) (hj : j < k) + (heq : W.pairing (iterWalk κ b i) = + W.pairing (iterWalk κ b j)) : i = j := by + by_cases hij : i ≤ j + · by_contra hne + have heq_iter : iterWalk κ b i = iterWalk κ b j := + calc iterWalk κ b i + = W.pairing (W.pairing (iterWalk κ b i)) := + (W.pairing_invol _).symm + _ = W.pairing (W.pairing (iterWalk κ b j)) := + by rw [heq] + _ = iterWalk κ b j := W.pairing_invol _ + exact absurd (iterWalk_no_repeat κ hb k hcont + i (j - i) (by omega) (by omega) + (by rwa [Nat.add_sub_cancel' hij])) not_false + · by_contra _hne + have heq_iter : iterWalk κ b j = iterWalk κ b i := + calc iterWalk κ b j + = W.pairing (W.pairing (iterWalk κ b j)) := + (W.pairing_invol _).symm + _ = W.pairing (W.pairing (iterWalk κ b i)) := + by rw [← heq] + _ = iterWalk κ b i := W.pairing_invol _ + exact absurd (iterWalk_no_repeat κ hb k hcont + j (i - j) (by omega) (by omega) + (by rwa [Nat.add_sub_cancel' (by omega : j ≤ i)])) + not_false + +/-! ### Chain termination with data -/ + +private theorem pairing_iterWalk_mem_flags + (κ : F.RelTransitionSystem) {b : W.Flag} + (hb : b ∈ F.boundaryFlags) (j : ℕ) + (hcont : ∀ i, i < j → + W.pairing (iterWalk κ b i) ∈ F.internalFlags) : + W.pairing (iterWalk κ b j) ∈ F.flags := by + cases j with + | zero => + exact F.pairing_mem b (mem_flags_of_boundaryFlags F hb) + | succ j => + exact F.pairing_mem _ + (mem_flags_of_internalFlags F + (iterWalk_mem_internal κ (j + 1) (by omega) (by omega) + (fun i hi => hcont i (by omega)))) + +/-- **The chain terminates**, within `F.flags.card` steps, at a +boundary partner: the visited partners are distinct and there are +only that many flags. -/ +theorem chain_terminates_with_data + (κ : F.RelTransitionSystem) + {b : W.Flag} (hb : b ∈ F.boundaryFlags) : + ∃ k, k ≤ F.flags.card ∧ + (∀ j, j < k → + W.pairing (iterWalk κ b j) ∈ F.internalFlags) ∧ + W.pairing (iterWalk κ b k) ∈ F.boundaryFlags := by + have hex : ∃ k, k ≤ F.flags.card ∧ + W.pairing (iterWalk κ b k) ∉ F.internalFlags := by + by_contra hall + simp only [not_exists, not_and, not_not] at hall + have hinj : Function.Injective + (fun (i : Fin (F.flags.card + 1)) => + (⟨W.pairing (iterWalk κ b i.val), + hall i.val (by omega)⟩ : + {f : W.Flag // f ∈ F.internalFlags})) := by + intro ⟨i, hi⟩ ⟨j, hj⟩ h + simp only [Subtype.mk.injEq] at h + exact Fin.ext (pairing_iterWalk_injective κ hb + (F.flags.card + 1) + (fun j hj => hall j (by omega)) + (by omega) (by omega) h) + have hcard := Fintype.card_le_of_injective _ hinj + rw [Fintype.card_fin, Fintype.card_coe] at hcard + have hsub : F.internalFlags.card ≤ F.flags.card := + Finset.card_le_card + (fun f hf => mem_flags_of_internalFlags F hf) + omega + have hex' : ∃ k, W.pairing (iterWalk κ b k) ∉ + F.internalFlags := ⟨_, hex.choose_spec.2⟩ + have : DecidablePred (fun k => + W.pairing (iterWalk κ b k) ∉ F.internalFlags) := + fun k => Classical.dec _ + set k₀ := Nat.find hex' + have hk₀_spec := Nat.find_spec hex' + have hk₀_min : ∀ j, j < k₀ → + W.pairing (iterWalk κ b j) ∈ F.internalFlags := + fun j hj => not_not.mp (Nat.find_min hex' hj) + obtain ⟨k, hk_le, hk_not⟩ := hex + have hk₀_le : k₀ ≤ F.flags.card := + (Nat.find_min' hex' hk_not).trans hk_le + have hmem := pairing_iterWalk_mem_flags κ hb k₀ hk₀_min + exact ⟨k₀, hk₀_le, hk₀_min, + (F.mem_internalFlags_or_boundaryFlags hmem).resolve_left + hk₀_spec⟩ + +/-! ### traceChain terminates -/ + +/-- With `F.flags.card + 1` fuel every chain from a boundary flag +succeeds. -/ +theorem traceChain_terminates (κ : F.RelTransitionSystem) + {b : W.Flag} (hb : b ∈ F.boundaryFlags) : + ∃ g, traceChain κ (F.flags.card + 1) b = some g := by + obtain ⟨k, hk_le, hcont, hterm⟩ := + chain_terminates_with_data κ hb + have hfwd : traceChain κ (k + 1) b = + some (W.pairing (iterWalk κ b k)) := by + rw [show k + 1 = k + 0 + 1 from by omega, + traceChain_unfold κ b k 0 hcont] + exact traceChain_boundary κ 0 _ hterm + exact ⟨_, traceChain_fuel_mono κ (by omega) hfwd⟩ + +/-! ### pathMatch definition -/ + +/-- **The path matching**: the boundary flag at the other end of a +boundary flag's alternating chain. -/ +noncomputable def RelTransitionSystem.pathMatch + (κ : F.RelTransitionSystem) (b : W.Flag) + (hb : b ∈ F.boundaryFlags) : W.Flag := + (traceChain κ (F.flags.card + 1) b).get + (by rw [Option.isSome_iff_exists] + exact traceChain_terminates κ hb) + +/-- Reading `pathMatch` off any successful trace at the standard +fuel. -/ +theorem RelTransitionSystem.pathMatch_eq + (κ : F.RelTransitionSystem) {b g : W.Flag} + (hb : b ∈ F.boundaryFlags) + (h : traceChain κ (F.flags.card + 1) b = some g) : + κ.pathMatch b hb = g := by + unfold RelTransitionSystem.pathMatch; simp [h] + +/-- The path matching lands in the boundary flags. -/ +theorem RelTransitionSystem.pathMatch_mem + (κ : F.RelTransitionSystem) {b : W.Flag} + (hb : b ∈ F.boundaryFlags) : + κ.pathMatch b hb ∈ F.boundaryFlags := by + unfold RelTransitionSystem.pathMatch + exact traceChain_result_boundary κ (Option.get_mem _) + +/-! ### Forward/reverse chain helpers -/ + +/-- A chain that continues for `k` steps and then meets a boundary +partner traces to that partner. -/ +theorem traceChain_forward (κ : F.RelTransitionSystem) + (b : W.Flag) {k : ℕ} + (hcont : ∀ j, j < k → + W.pairing (iterWalk κ b j) ∈ F.internalFlags) + (hterm : W.pairing (iterWalk κ b k) ∈ + F.boundaryFlags) : + traceChain κ (k + 1) b = + some (W.pairing (iterWalk κ b k)) := by + rw [show k + 1 = k + 0 + 1 from by omega, + traceChain_unfold κ b k 0 hcont] + exact traceChain_boundary κ 0 _ hterm + +/-- **The reverse-iterate identity**: walking back from the chain's +far end retraces the forward walk under the edge pairing. This is +what makes the path matching an involution. -/ +theorem iterWalk_reverse (κ : F.RelTransitionSystem) + {b : W.Flag} {k : ℕ} + (hcont : ∀ j, j < k → + W.pairing (iterWalk κ b j) ∈ F.internalFlags) + (j : ℕ) (hjk : j ≤ k) : + iterWalk κ (W.pairing (iterWalk κ b k)) j = + W.pairing (iterWalk κ b (k - j)) := by + induction j with + | zero => simp [iterWalk] + | succ j ih => + rw [iterWalk_succ, ih (by omega), + show k - j = (k - (j + 1)) + 1 from by omega, + iterWalk_succ, W.pairing_invol] + exact κ.match_invol _ + (hcont (k - (j + 1)) (by omega)) + +/-- The reversed chain continues wherever the forward one did. -/ +theorem reverse_chain_continues + (κ : F.RelTransitionSystem) + {b : W.Flag} (_hb : b ∈ F.boundaryFlags) {k : ℕ} + (hcont : ∀ j, j < k → + W.pairing (iterWalk κ b j) ∈ F.internalFlags) + (j : ℕ) (hjk : j < k) : + W.pairing + (iterWalk κ (W.pairing (iterWalk κ b k)) j) ∈ + F.internalFlags := by + rw [iterWalk_reverse κ hcont j (by omega), + W.pairing_invol] + exact iterWalk_mem_internal κ k (by omega) (by omega) + (fun i hi => hcont i (by omega)) + +/-- The reversed chain arrives back at the original start. -/ +theorem reverse_chain_terminates + (κ : F.RelTransitionSystem) + {b : W.Flag} {k : ℕ} + (hcont : ∀ j, j < k → + W.pairing (iterWalk κ b j) ∈ F.internalFlags) : + W.pairing + (iterWalk κ (W.pairing (iterWalk κ b k)) k) = + b := by + rw [iterWalk_reverse κ hcont k (le_refl k)] + simp [W.pairing_invol] + +/-! ### Involution -/ + +/-- The trace from the far end returns the original boundary +flag. -/ +theorem traceChain_reverse (κ : F.RelTransitionSystem) + {b : W.Flag} (hb : b ∈ F.boundaryFlags) {k : ℕ} + (hcont : ∀ j, j < k → + W.pairing (iterWalk κ b j) ∈ F.internalFlags) + (hterm : W.pairing (iterWalk κ b k) ∈ + F.boundaryFlags) : + traceChain κ (k + 1) + (W.pairing (iterWalk κ b k)) = some b := by + cases k with + | zero => + simp only [iterWalk_zero] at hterm ⊢ + have hpb : W.pairing (W.pairing b) ∈ + F.boundaryFlags := by + rw [W.pairing_invol]; exact hb + have h := traceChain_boundary κ 0 (W.pairing b) hpb + rwa [W.pairing_invol] at h + | succ k => + rw [show k + 1 + 1 = (k + 1) + 0 + 1 from by omega, + traceChain_unfold κ _ (k + 1) 0 + (reverse_chain_continues κ hb hcont)] + have hrt := reverse_chain_terminates κ hcont + have hpb : W.pairing + (iterWalk κ (W.pairing (iterWalk κ b (k + 1))) + (k + 1)) ∈ F.boundaryFlags := by + rw [hrt]; exact hb + have h := traceChain_boundary κ 0 _ hpb + rwa [hrt] at h + +/-- **The path matching is an involution**: it pairs the boundary +flags of the subset. -/ +theorem RelTransitionSystem.pathMatch_invol + (κ : F.RelTransitionSystem) {b : W.Flag} + (hb : b ∈ F.boundaryFlags) : + κ.pathMatch (κ.pathMatch b hb) + (κ.pathMatch_mem hb) = b := by + obtain ⟨k, hk_le, hcont, hterm⟩ := + chain_terminates_with_data κ hb + have hfwd := traceChain_forward κ b hcont hterm + have hpm : κ.pathMatch b hb = + W.pairing (iterWalk κ b k) := + κ.pathMatch_eq hb + (traceChain_fuel_mono κ (by omega) hfwd) + have hrev := traceChain_reverse κ hb hcont hterm + have hchain : + traceChain κ (F.flags.card + 1) + (κ.pathMatch b hb) = some b := by + rw [hpm] + exact traceChain_fuel_mono κ (by omega) hrev + exact κ.pathMatch_eq (κ.pathMatch_mem hb) hchain + +/-! ### Self-matching analysis -/ + +/-- A boundary flag whose edge partner is also boundary is matched +to that partner: the chain has no internal steps. -/ +theorem RelTransitionSystem.pathMatch_eq_pairing + (κ : F.RelTransitionSystem) {b : W.Flag} + (hb : b ∈ F.boundaryFlags) + (hp : W.pairing b ∈ F.boundaryFlags) : + κ.pathMatch b hb = W.pairing b := + κ.pathMatch_eq hb + (traceChain_fuel_mono κ (by omega) + (traceChain_boundary κ 0 b hp)) + +/-! ### Interaction lemmas -/ + +/-- The path matching, together with the length of the chain that +produced it and the continuation data along the way — the form +downstream chain arguments consume. -/ +theorem pathMatch_chain_length + (κ : F.RelTransitionSystem) + {b : W.Flag} (hb : b ∈ F.boundaryFlags) : + ∃ k, k ≤ F.flags.card ∧ + (∀ j, j < k → + W.pairing (iterWalk κ b j) ∈ + F.internalFlags) ∧ + κ.pathMatch b hb = + W.pairing (iterWalk κ b k) := by + obtain ⟨k, hk_le, hcont, hterm⟩ := + chain_terminates_with_data κ hb + exact ⟨k, hk_le, hcont, κ.pathMatch_eq hb + (traceChain_fuel_mono κ (by omega) + (traceChain_forward κ b hcont hterm))⟩ + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PermCompose.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PermCompose.lean new file mode 100644 index 0000000000..bde4c847f9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PermCompose.lean @@ -0,0 +1,147 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PermFragment +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceShift +public import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLaw + +/-! +# Composition of permutation fragments + +The multiplication law of the symmetric-group generators +(accompanying paper §3.1): composing permutation fragments composes the +permutations, `Pσ ∘ Pτ ≃ P(τσ)`. The proof is pure calculus: +a permutation fragment is the strand bundle with outgoing labels +permuted (`permFragmentRelabelOutPerm`), the outgoing +permutation crosses the interface by `interfaceShift`, the bare +bundle is absorbed by the identity law, and the residual incoming +permutation is traded for a strand re-indexing of the bundle +(`strandBundleRelabelBoth`), which is invisible up to +equivalence. +-/ + +@[expose] public section + +namespace RS + +/-- A permutation fragment is the strand bundle with its outgoing +labels permuted by `outPermEquiv`. -/ +noncomputable def permFragmentRelabelOutPerm {t : ℕ} + (σ : Equiv.Perm (Fin t)) : + (permFragment σ).Equiv + ((strandBundle t).relabel (outPermEquiv t σ)) where + flagEquiv := _root_.Equiv.refl _ + vertexEquiv := _root_.Equiv.refl _ + attach_comm := fun f => by + obtain ⟨k, b⟩ := f + cases b + · change Sum.inr (outPermEquiv t σ + ⟨k.val, by have := k.isLt; omega⟩) = + Sum.inr (⟨k.val, by have := k.isLt; omega⟩ : Fin (t + t)) + refine congrArg Sum.inr ?_ + rw [show (⟨k.val, by have := k.isLt; omega⟩ : Fin (t + t)) = + Fin.castAdd t k from Fin.ext rfl, outPermEquiv_low] + · change Sum.inr (outPermEquiv t σ + ⟨t + k.val, by have := k.isLt; omega⟩) = + Sum.inr (⟨t + (σ k).val, + by have := (σ k).isLt; omega⟩ : Fin (t + t)) + refine congrArg Sum.inr ?_ + rw [show (⟨t + k.val, by have := k.isLt; omega⟩ : + Fin (t + t)) = Fin.natAdd t k from Fin.ext rfl, + outPermEquiv_high] + exact Fin.ext rfl + pairing_comm := fun _ => rfl + circles_eq := rfl + +/-- Re-indexing the strands of the bundle — permuting both ends +of each strand by the same permutation — is invisible up to +equivalence. -/ +noncomputable def strandBundleRelabelBoth {t : ℕ} + (δ : Equiv.Perm (Fin t)) : + ((strandBundle t).relabel + ((inPermEquiv δ t).trans (outPermEquiv t δ))).Equiv + (strandBundle t) where + flagEquiv := _root_.Equiv.prodCongr δ (_root_.Equiv.refl Bool) + vertexEquiv := _root_.Equiv.refl _ + attach_comm := fun f => by + obtain ⟨k, b⟩ := f + cases b + · change Sum.inr (⟨(δ k).val, + by have := (δ k).isLt; omega⟩ : Fin (t + t)) = + Sum.inr ((inPermEquiv δ t).trans (outPermEquiv t δ) + ⟨k.val, by have := k.isLt; omega⟩) + refine congrArg Sum.inr ?_ + rw [show (⟨k.val, by have := k.isLt; omega⟩ : Fin (t + t)) = + Fin.castAdd t k from Fin.ext rfl, + _root_.Equiv.trans_apply, inPermEquiv_low, outPermEquiv_low] + exact Fin.ext rfl + · change Sum.inr (⟨t + (δ k).val, + by have := (δ k).isLt; omega⟩ : Fin (t + t)) = + Sum.inr ((inPermEquiv δ t).trans (outPermEquiv t δ) + ⟨t + k.val, by have := k.isLt; omega⟩) + refine congrArg Sum.inr ?_ + rw [show (⟨t + k.val, by have := k.isLt; omega⟩ : + Fin (t + t)) = Fin.natAdd t k from Fin.ext rfl, + _root_.Equiv.trans_apply, inPermEquiv_high, outPermEquiv_high] + exact Fin.ext rfl + pairing_comm := fun _ => rfl + circles_eq := rfl + +/-- Label algebra: shifting the outgoing permutation `τ` across +the interface against `σ` re-associates into a strand re-indexing +by `σ⁻¹` followed by the outgoing composite permutation. -/ +theorem outPerm_shift_both {t : ℕ} (σ τ : Equiv.Perm (Fin t)) : + (outPermEquiv t τ).trans (inPermEquiv σ.symm t) = + ((inPermEquiv σ.symm t).trans (outPermEquiv t σ.symm)).trans + (outPermEquiv t (τ * σ)) := by + apply _root_.Equiv.ext + intro ℓ + by_cases h : ℓ.val < t + · rw [show ℓ = (Fin.castAdd t ⟨ℓ.val, h⟩ : Fin (t + t)) from + Fin.ext rfl] + simp only [_root_.Equiv.trans_apply, outPermEquiv_low, + inPermEquiv_low] + · rw [show ℓ = (Fin.natAdd t ⟨ℓ.val - t, + by have := ℓ.isLt; omega⟩ : Fin (t + t)) from + Fin.ext (by change ℓ.val = t + (ℓ.val - t); omega)] + simp only [_root_.Equiv.trans_apply, outPermEquiv_high, + inPermEquiv_high] + refine congrArg (Fin.natAdd t) ?_ + simp [Equiv.Perm.mul_apply] + +/-- **Permutation fragments compose** (accompanying paper §3.1): the +composition of the permutation fragments of `σ` and `τ` is the +permutation fragment of the composite `τ * σ` (first through +`σ`, then through `τ`). -/ +noncomputable def permFragmentCompose {t : ℕ} + (σ τ : Equiv.Perm (Fin t)) : + ((permFragment σ).compose (permFragment τ)).Equiv + (permFragment (τ * σ)) := + (Fragment.composeCongr (permFragmentRelabelOutPerm σ) + (Fragment.Equiv.refl (permFragment τ))).trans + ((interfaceShift σ (strandBundle t) (permFragment τ)).trans + ((composeStrandBundleLeft t t + ((permFragment τ).relabel (inPermEquiv σ.symm t))).trans + ((Fragment.Equiv.relabelCongr + (permFragmentRelabelOutPerm τ) + (inPermEquiv σ.symm t)).trans + ((Fragment.Equiv.relabelTrans (strandBundle t) + (outPermEquiv t τ) (inPermEquiv σ.symm t)).trans + ((Fragment.Equiv.relabelEq (strandBundle t) + (outPerm_shift_both σ τ)).trans + ((Fragment.Equiv.relabelTrans (strandBundle t) + ((inPermEquiv σ.symm t).trans + (outPermEquiv t σ.symm)) + (outPermEquiv t (τ * σ))).symm.trans + ((Fragment.Equiv.relabelCongr + (strandBundleRelabelBoth σ.symm) + (outPermEquiv t (τ * σ))).trans + (permFragmentRelabelOutPerm + (τ * σ)).symm))))))) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PermFragment.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PermFragment.lean new file mode 100644 index 0000000000..6f07e7ffe9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PermFragment.lean @@ -0,0 +1,162 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StrandBundle + +/-! +# Permutation fragments + +The symmetric-group generators of the skein category: for a +permutation `σ` of `Fin t`, the fragment `permFragment σ` consists +of `t` disjoint strands, strand `k` joining incoming boundary label +`k` to outgoing boundary label `t + σ k`. The identity permutation +gives the strand bundle. +-/ + +@[expose] public section + +namespace RS + +/-- The permutation fragment of `σ`: strand `k` joins incoming +label `k` to outgoing label `t + σ k`. -/ +def permFragment {t : ℕ} (σ : Equiv.Perm (Fin t)) : + Fragment (Fin (t + t)) where + Flag := Fin t × Bool + Vertex := Empty + attach := fun f => + Sum.inr (if f.2 then + ⟨t + (σ f.1).val, by have := (σ f.1).isLt; omega⟩ + else ⟨f.1.val, by have := f.1.isLt; omega⟩) + pairing := fun f => (f.1, !f.2) + pairing_invol := fun f => by simp + pairing_ne := fun f h => by + have hsnd := congrArg Prod.snd h + simp at hsnd + boundaryFlag := fun ℓ => + if h : ℓ.val < t then (⟨ℓ.val, h⟩, false) + else (σ.symm ⟨ℓ.val - t, by have := ℓ.isLt; omega⟩, true) + attach_boundaryFlag := fun ℓ => by + by_cases h : ℓ.val < t + · rw [dite_eq_left h] + exact congrArg Sum.inr (Fin.ext rfl) + · rw [dite_eq_right h] + refine congrArg Sum.inr (Fin.ext ?_) + change t + (σ (σ.symm ⟨ℓ.val - t, by have := ℓ.isLt; omega⟩)).val = + ℓ.val + rw [Equiv.apply_symm_apply] + change t + (ℓ.val - t) = ℓ.val + have := ℓ.isLt + omega + eq_boundaryFlag := fun ℓ f h => by + obtain ⟨a, b⟩ := f + have hℓ := (Sum.inr.inj h).symm + cases b + · simp only [Bool.false_eq_true, ite_false] at hℓ + subst hℓ + rw [dite_eq_left a.isLt] + · simp only [ite_true] at hℓ + subst hℓ + rw [dite_eq_right (show ¬ t + (σ a).val < t by omega)] + refine Prod.ext_iff.mpr ⟨?_, rfl⟩ + change a = σ.symm ⟨t + (σ a).val - t, + by have := (σ a).isLt; omega⟩ + rw [show (⟨t + (σ a).val - t, + by have := (σ a).isLt; omega⟩ : Fin t) = σ a from + Fin.ext (by change t + (σ a).val - t = (σ a).val; omega)] + exact (σ.symm_apply_apply a).symm + circles := 0 + +/-- The identity permutation gives the strand bundle. -/ +theorem permFragment_one (t : ℕ) : + permFragment (1 : Equiv.Perm (Fin t)) = strandBundle t := rfl + +/-- The label re-indexing that fixes incoming labels and permutes +outgoing labels by `σ`. -/ +def permHighEquiv {t : ℕ} (σ : Equiv.Perm (Fin t)) : + Fin (t + t) ≃ Fin (t + t) where + toFun ℓ := + if h : ℓ.val < t then ℓ + else ⟨t + (σ ⟨ℓ.val - t, by have := ℓ.isLt; omega⟩).val, + by have := (σ ⟨ℓ.val - t, by have := ℓ.isLt; omega⟩).isLt; omega⟩ + invFun ℓ := + if h : ℓ.val < t then ℓ + else ⟨t + (σ.symm ⟨ℓ.val - t, by have := ℓ.isLt; omega⟩).val, + by have := (σ.symm ⟨ℓ.val - t, + by have := ℓ.isLt; omega⟩).isLt; omega⟩ + left_inv ℓ := by + dsimp only + by_cases h : ℓ.val < t + · simp only [dite_eq_left h] + · rw [dite_eq_right h, dite_eq_right (by + change ¬ t + (σ ⟨ℓ.val - t, _⟩).val < t + omega)] + refine Fin.ext ?_ + change t + (σ.symm ⟨t + (σ ⟨ℓ.val - t, _⟩).val - t, _⟩).val = ℓ.val + rw [show (⟨t + (σ ⟨ℓ.val - t, by have := ℓ.isLt; omega⟩).val - t, + by have := (σ ⟨ℓ.val - t, by have := ℓ.isLt; omega⟩).isLt + omega⟩ : Fin t) = + σ ⟨ℓ.val - t, by have := ℓ.isLt; omega⟩ from Fin.ext (by + change t + _ - t = _ + omega)] + rw [Equiv.symm_apply_apply] + change t + (ℓ.val - t) = ℓ.val + omega + right_inv ℓ := by + dsimp only + by_cases h : ℓ.val < t + · simp only [dite_eq_left h] + · rw [dite_eq_right h, dite_eq_right (by + change ¬ t + (σ.symm ⟨ℓ.val - t, _⟩).val < t + omega)] + refine Fin.ext ?_ + change t + (σ ⟨t + (σ.symm ⟨ℓ.val - t, _⟩).val - t, _⟩).val = ℓ.val + rw [show (⟨t + (σ.symm ⟨ℓ.val - t, + by have := ℓ.isLt; omega⟩).val - t, + by have := (σ.symm ⟨ℓ.val - t, + by have := ℓ.isLt; omega⟩).isLt; omega⟩ : Fin t) = + σ.symm ⟨ℓ.val - t, by have := ℓ.isLt; omega⟩ from Fin.ext (by + change t + _ - t = _ + omega)] + rw [Equiv.apply_symm_apply] + change t + (ℓ.val - t) = ℓ.val + omega + +/-- A permutation fragment is the strand bundle with its outgoing +labels re-indexed. -/ +noncomputable def permFragmentRelabelBundle {t : ℕ} + (σ : Equiv.Perm (Fin t)) : + (permFragment σ).Equiv + ((strandBundle t).relabel (permHighEquiv σ)) where + flagEquiv := _root_.Equiv.refl _ + vertexEquiv := _root_.Equiv.refl _ + attach_comm := fun f => by + obtain ⟨k, b⟩ := f + cases b + · change Sum.inr (permHighEquiv σ ⟨k.val, by have := k.isLt; omega⟩) = + Sum.inr ⟨k.val, by have := k.isLt; omega⟩ + refine congrArg Sum.inr ?_ + unfold permHighEquiv + change (if h : (⟨k.val, by have := k.isLt; omega⟩ : + Fin (t + t)).val < t then _ else _) = _ + rw [dite_eq_left (show k.val < t from k.isLt)] + · change Sum.inr (permHighEquiv σ ⟨t + k.val, + by have := k.isLt; omega⟩) = + Sum.inr ⟨t + (σ k).val, by have := (σ k).isLt; omega⟩ + refine congrArg Sum.inr ?_ + unfold permHighEquiv + change (if h : (⟨t + k.val, by have := k.isLt; omega⟩ : + Fin (t + t)).val < t then _ else _) = _ + rw [dite_eq_right (show ¬ t + k.val < t by omega)] + refine Fin.ext ?_ + change t + (σ ⟨t + k.val - t, _⟩).val = t + (σ k).val + rw [show (⟨t + k.val - t, by have := k.isLt; omega⟩ : Fin t) = k + from Fin.ext (by change t + k.val - t = k.val; omega)] + pairing_comm := fun _ => rfl + circles_eq := rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PropThreeOpen.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PropThreeOpen.lean new file mode 100644 index 0000000000..d92b864f51 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PropThreeOpen.lean @@ -0,0 +1,55 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairedAssembly +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelChords + +/-! +# Proposition 3 for open fragments + +The paired step is a theorem (`pairedLedger`), so the whole chain +follows with no hypothesis: the pairing-preserving move ledger, the +within-pairing independence of the signed canonical value, and the +well-definedness of the value over chord diagrams. With +independence across pairings refuted (`not_throughIndependenceC`), +this is the open-sector Proposition 3 in its exact form: the +constrained value is a function of the boundary pairing, and of +nothing else. +-/ + +@[expose] public section + +namespace RS + + + +/-- The paired step in value form, unconditionally. -/ +theorem pairedValueLedger : PairedValueLedger := + EdgeSubset.pairedLedger_iff_value.mp pairedLedger + +namespace EdgeSubset + +variable {α : Type} + +/-- Signed values agree across equal chord diagrams, +unconditionally. -/ +theorem signedValueAt_of_labelChords_eq_pairing + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {k ℓ : ℕ} + (hM : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ κ' : F.RelTransitionSystem} + (h : labelChords κ = labelChords κ') : + F.signedValueAt hM st hbnd κ = + F.signedValueAt hM st hbnd κ' := + signedValueAt_of_labelChords_eq pairedValueLedger + hM st hbnd h + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RSTensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RSTensor.lean new file mode 100644 index 0000000000..b623330ed4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RSTensor.lean @@ -0,0 +1,1845 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeSum +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CutMatching +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperGram +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GluePathMatch +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseDischarge + +/-! +# The fragment tensor + +RS21 attaches to a fragment, an Eulerian subset, an Eulerian +orientation and a compatible local pairing the tensor + + t′_h(F,H,ω,κ) := Σ_χ t′_{h,χ}(F,H,ω,κ), + + t′_{h,χ} := (−1)^{ĉ(κ)} Σ_{ψ ∼ χ₀, φ ∼ χ₁} + ∏_{v ∈ V′(F)} h_v( … ) ⊗_{i ∈ [t]} c_{χ,ω,i}. + +A basis coordinate of the tensor determines `χ`: an entering leg +carries `f_{χ₁(i)}`, so its coordinate is `χ₁(i)` itself, and a +leaving leg carries `g_{χ₁(i)}`, whose expansion is the partner +colour with the partner sign. So the sum over `χ` collapses, and +the coordinate at `x` is the colourings' sum read at `untwist x`, +weighted by the leaving legs' signs. + +The tensor is zero at a coordinate whose parity pattern is not the +subset's, which is the condition that `χ` be consistent with `S`. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + + + +variable {α : Type} + +open scoped Classical in +/-- **RS21's tensor `t′_h`, in coordinates.** -/ +noncomputable def tPrime [LinearOrder α] [Fintype α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (κ : F.RelTransitionSystem) + (o : κ.Orientation) (x : GenBoundaryState k ℓ α) : ℂ := + if hbnd : genBoundarySubsetMatches W F.flags (untwist F κ o x) then + ((-1 : ℂ) ^ κ.openCircuitCount) * dualWeight F κ o x * + ∑ ψ : F.EvenColouring k, + if genEvenBoundaryMatch F (untwist F κ o x) hbnd ψ then + ∑ φ : F.EdgeOddColouring ℓ, + if edgeOddBoundaryMatch F (untwist F κ o x) φ then + ∏ v : W.Vertex, + ((F.coreOddSignAt o φ.core v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) + (F.coreOddListAt o φ.core v)) + else 0 + else 0 + else 0 + +open scoped Classical in +/-- **RS21's tensor at given arc directions.** The chain +orientation fixes the vertex signs; the arc directions fix which +legs carry `f` and which carry `g`. -/ +noncomputable def tPrimeD [Fintype α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (κ : F.RelTransitionSystem) + (o : κ.Orientation) (tl : UsedLab F → Bool) + (x : GenBoundaryState k ℓ α) : ℂ := + if hbnd : genBoundarySubsetMatches W F.flags (untwistD F tl x) then + ((-1 : ℂ) ^ κ.openCircuitCount) * dualWeightD F tl x * + ∑ ψ : F.EvenColouring k, + if genEvenBoundaryMatch F (untwistD F tl x) hbnd ψ then + ∑ φ : F.EdgeOddColouring ℓ, + if edgeOddBoundaryMatch F (untwistD F tl x) φ then + ∏ v : W.Vertex, + ((F.coreOddSignAt o φ.core v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) + (F.coreOddListAt o φ.core v)) + else 0 + else 0 + else 0 + +/-! ### The dual weight is a product of leg weights + +The dual basis's weight is a product over the labels of a factor +that depends only on that leg's colour and its arc's direction, so +it is the leg weight the Gram computation uses. At a label the +subset does not use, the colour is even and the factor is one. +-/ + +/-- The arc direction as a function of the label, with the unused +labels reading `false`. -/ +noncomputable def legDir {W : Fragment α} + (F : EdgeSubset W) (tl : UsedLab F → Bool) + (i : α) : Bool := + if h : W.boundaryFlag i ∈ F.boundaryFlags then tl ⟨i, h⟩ else false + +open Classical in +/-- **The dual weight is the product of the legs' weights.** -/ +theorem dualWeightD_eq_prod_legWeight [Fintype α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (tl : UsedLab F → Bool) (x : GenBoundaryState k ℓ α) + (hx : genBoundarySubsetMatches W F.flags x) : + dualWeightD F tl x + = ∏ i : α, legWeight (legDir F tl i) (x i) := by + unfold dualWeightD legDir + refine Finset.prod_congr rfl (fun i _ => ?_) + by_cases hb : W.boundaryFlag i ∈ F.boundaryFlags + · rw [dite_eq_left hb, dite_eq_left hb] + by_cases ht : tl ⟨i, hb⟩ = true + · rw [ite_eq_left ht] + rcases hxi : x i with a | c + · change (1 : ℂ) = legWeight (tl ⟨i, hb⟩) (Sum.inl a) + rfl + · change dualSign ℓ c = legWeight (tl ⟨i, hb⟩) (Sum.inr c) + change dualSign ℓ c = if tl ⟨i, hb⟩ then dualSign ℓ c else 1 + rw [ite_eq_left ht] + · rw [ite_eq_right ht] + rcases hxi : x i with a | c + · rfl + · change (1 : ℂ) = if tl ⟨i, hb⟩ then dualSign ℓ c else 1 + rw [ite_eq_right ht] + · rw [dite_eq_right hb, dite_eq_right hb] + have hev : ¬ ∃ c, x i = Sum.inr c := by + intro hc + exact hb (boundaryFlag_mem_boundaryFlags ((hx i).mpr hc)) + obtain ⟨a, ha⟩ := exists_left_of_not_right hev + rw [ha] + rfl + +/-! ### The normalised tensor + +RS21 normalises by a fourth root of unity per two used legs and by +the matching's sign: + + t_h(F,H,ω,κ) := (−1)^{|S|/4} · sgn(M(ω,κ)) · t′_h(F,H,ω,κ). + +Since `|S|` is only even, `(−1)^{|S|/4}` is a fourth root: `i^{|S|/2}`. +The sign is taken against the reference matching with arcs +`(i₁,i₂),…`, which is `stdMatching` on the used labels. +-/ + +/-- The labels the subset uses — RS21's `S(H)`. -/ +abbrev UsedLabel {W : Fragment α} + (F : EdgeSubset W) : Type := + {i : α // W.boundaryFlag i ∈ F.boundaryFlags} + +/-- The used labels are even in number: they are matched in pairs. -/ +theorem card_usedLabel_eq [LinearOrder α] [Fintype α] {W : Fragment α} + (F : EdgeSubset W) + (κ : F.RelTransitionSystem) (o : κ.Orientation) : + Fintype.card (UsedLabel F) + = 2 * (Fintype.card (UsedLabel F) / 2) := by + obtain ⟨r, hr⟩ := (cutMatching F κ o).even_card + have hc : Fintype.card + {i : α // W.boundaryFlag i ∈ F.boundaryFlags} + = Fintype.card (UsedLabel F) := + Fintype.card_congr (Equiv.refl _) + rw [hc] at hr + omega + +/-- **RS21's normalised tensor `t_h`, in coordinates.** -/ +noncomputable def tFull [LinearOrder α] [Fintype α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (κ : F.RelTransitionSystem) + (o : κ.Orientation) (x : GenBoundaryState k ℓ α) : ℂ := + Complex.I ^ (Fintype.card (UsedLabel F) / 2) * + ((DirMatching.sgnRel + (DirMatching.stdMatching (card_usedLabel_eq F κ o)) + (cutMatching F κ o) : ℤ) : ℂ) + * F.tPrime h κ o x + +/-- The used labels are even in number, for any directed matching on +them. -/ +theorem card_usedLab_eq [LinearOrder α] [Fintype α] {W : Fragment α} + (F : EdgeSubset W) + (M : DirMatching (UsedLab F)) : + Fintype.card (UsedLab F) + = 2 * (Fintype.card (UsedLab F) / 2) := by + obtain ⟨r, hr⟩ := M.even_card + omega + +/-- **RS21's normalised tensor at given arc directions.** The +directions enter twice: through the matching's sign and through the +dual basis. -/ +noncomputable def tFullD [LinearOrder α] [Fintype α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (κ : F.RelTransitionSystem) + (o : κ.Orientation) (M : DirMatching (UsedLab F)) + (x : GenBoundaryState k ℓ α) : ℂ := + Complex.I ^ (Fintype.card (UsedLab F) / 2) * + ((DirMatching.sgnRel + (DirMatching.stdMatching (card_usedLab_eq F M)) M : ℤ) : ℂ) + * F.tPrimeD h κ o M.tail x + +/-- **The normalised tensor is the directed one at the chain +orientation's own directions.** -/ +theorem tFull_eq_tFullD [LinearOrder α] [Fintype α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (κ : F.RelTransitionSystem) + (o : κ.Orientation) (x : GenBoundaryState k ℓ α) : + F.tFull h κ o x = F.tFullD h κ o (cutMatching F κ o) x := rfl + +open Classical in +/-- **A disagreeing state carries no colouring.** RS21 colours a +through-edge once, so a state whose two legs there disagree admits +no `φ ∼ χ₁`, and the tensor vanishes at it. -/ +theorem tPrimeD_eq_zero_of_not_throughAgree [Fintype α] {W : Fragment α} + (F : EdgeSubset W) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (κ : F.RelTransitionSystem) (o : κ.Orientation) + (tl : UsedLab F → Bool) (x : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags (untwistD F tl x)) + (hag : ¬ ThroughAgree F (untwistD F tl x) hbnd) : + F.tPrimeD h κ o tl x = 0 := by + unfold tPrimeD + rw [dite_eq_left hbnd] + refine mul_eq_zero_of_right _ (Finset.sum_eq_zero (fun ψ _ => ?_)) + by_cases hev : genEvenBoundaryMatch F (untwistD F tl x) hbnd ψ + · rw [ite_eq_left hev] + exact Finset.sum_eq_zero (fun φ _ => ite_eq_right (fun hφ => + hag (throughAgree_of_edgeOddBoundaryMatch hbnd hφ))) + · rw [ite_eq_right hev] + +open Classical in +/-- **A disagreeing state carries no colouring**, at the chain +orientation's own directions. -/ +theorem tPrime_eq_zero_of_not_throughAgree + [LinearOrder α] [Fintype α] {W : Fragment α} + (F : EdgeSubset W) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (κ : F.RelTransitionSystem) (o : κ.Orientation) + (x : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags (untwist F κ o x)) + (hag : ¬ ThroughAgree F (untwist F κ o x) hbnd) : + F.tPrime h κ o x = 0 := by + unfold tPrime + rw [dite_eq_left hbnd] + refine mul_eq_zero_of_right _ (Finset.sum_eq_zero (fun ψ _ => ?_)) + by_cases hev : genEvenBoundaryMatch F (untwist F κ o x) hbnd ψ + · rw [ite_eq_left hev] + exact Finset.sum_eq_zero (fun φ _ => ite_eq_right (fun hφ => + hag (throughAgree_of_edgeOddBoundaryMatch hbnd hφ))) + · rw [ite_eq_right hev] + +open Classical in +/-- **RS21's `t_h` vanishes at a disagreeing state.** -/ +theorem tFull_eq_zero_of_not_throughAgree + [LinearOrder α] [Fintype α] {W : Fragment α} + (F : EdgeSubset W) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (κ : F.RelTransitionSystem) (o : κ.Orientation) + (x : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags (untwist F κ o x)) + (hag : ¬ ThroughAgree F (untwist F κ o x) hbnd) : + F.tFull h κ o x = 0 := by + unfold tFull + rw [tPrime_eq_zero_of_not_throughAgree F h κ o x hbnd hag, mul_zero] + +open Classical in +/-- **The normalised tensor vanishes at a disagreeing state.** -/ +theorem tFullD_eq_zero_of_not_throughAgree + [LinearOrder α] [Fintype α] {W : Fragment α} + (F : EdgeSubset W) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (κ : F.RelTransitionSystem) (o : κ.Orientation) + (M : DirMatching (UsedLab F)) (x : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags (untwistD F M.tail x)) + (hag : ¬ ThroughAgree F (untwistD F M.tail x) hbnd) : + F.tFullD h κ o M x = 0 := by + unfold tFullD + rw [tPrimeD_eq_zero_of_not_throughAgree F h κ o M.tail x hbnd hag, + mul_zero] + +/-! ### The tensor's support + +The tensor vanishes unless the state's odd legs are exactly the +labels the subset uses. On that support the number of odd legs is +the number of used labels, and the legs whose arc leaves are half of +them. These are the hypotheses RS21's leg count needs. +-/ + +open Classical in +/-- **The tensor vanishes off its support.** -/ +theorem genBoundarySubsetMatches_of_tPrimeD_ne_zero [Fintype α] {W : Fragment α} + (F : EdgeSubset W) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) (κ : F.RelTransitionSystem) + (o : κ.Orientation) (tl : UsedLab F → Bool) + (x : GenBoundaryState k ℓ α) (hne : F.tPrimeD h κ o tl x ≠ 0) : + genBoundarySubsetMatches W F.flags x := by + by_contra hc + refine hne ?_ + unfold tPrimeD + refine dite_eq_right (fun hb => hc ?_) + exact (genBoundarySubsetMatches_untwistD F tl x).mp hb + +open Classical in +/-- The same, for the normalised tensor. -/ +theorem genBoundarySubsetMatches_of_tFullD_ne_zero + [LinearOrder α] [Fintype α] {W : Fragment α} + (F : EdgeSubset W) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) (κ : F.RelTransitionSystem) + (o : κ.Orientation) (M : DirMatching (UsedLab F)) + (x : GenBoundaryState k ℓ α) (hne : F.tFullD h κ o M x ≠ 0) : + genBoundarySubsetMatches W F.flags x := by + refine genBoundarySubsetMatches_of_tPrimeD_ne_zero F h κ o M.tail x + (fun hz => hne ?_) + unfold tFullD + rw [hz, mul_zero] + +open Classical in +/-- **On the support the odd legs are the used labels.** -/ +theorem oddCount_eq_card_usedLab {t : ℕ} {W : Fragment (Fin t)} + (F : EdgeSubset W) {k ℓ : ℕ} (x : GenBoundaryState k ℓ (Fin t)) + (hx : genBoundarySubsetMatches W F.flags x) : + oddCount x = Fintype.card (UsedLab F) := by + have hiff : ∀ i : Fin t, + (∃ c, x i = Sum.inr c) ↔ W.boundaryFlag i ∈ F.boundaryFlags := by + intro i + constructor + · intro hc + exact boundaryFlag_mem_boundaryFlags ((hx i).mpr hc) + · intro hb + exact (hx i).mp (mem_flags_of_boundaryFlags F hb) + rw [oddCount, Fintype.card_subtype] + exact congrArg Finset.card + (Finset.filter_congr (fun i _ => hiff i)) + +/-- The leg direction agrees with the matching's on the used +labels. -/ +theorem legDir_eq {W : Fragment α} + (F : EdgeSubset W) (tl : UsedLab F → Bool) + (i : α) (h : W.boundaryFlag i ∈ F.boundaryFlags) : + legDir F tl i = tl ⟨i, h⟩ := dite_eq_left h + +open Classical in +/-- **The fragment's change of basis is the abstract one** at its +own leg directions. -/ +theorem untwistD_eq_untwistState {t : ℕ} {W : Fragment (Fin t)} + (F : EdgeSubset W) {k ℓ : ℕ} (tl : UsedLab F → Bool) + (x : GenBoundaryState k ℓ (Fin t)) : + untwistD F tl x = untwistState (legDir F tl) x := by + funext i + by_cases hb : W.boundaryFlag i ∈ F.boundaryFlags + · rw [untwistD_apply_mem F tl x hb] + change (if tl ⟨i, hb⟩ then Sum.map id (oddPartner ℓ) (x i) + else x i) + = if legDir F tl i then dualLeg (x i) else x i + rw [legDir_eq F tl i hb] + by_cases ht : tl ⟨i, hb⟩ = true + · rw [ite_eq_left ht, ite_eq_left ht] + rcases x i with a | c <;> rfl + · rw [ite_eq_right ht, ite_eq_right ht] + · rw [untwistD_apply_not_mem F tl x hb] + change x i = if legDir F tl i then dualLeg (x i) else x i + rw [show legDir F tl i = false from dite_eq_right hb, ite_eq_right (by simp)] + +open Classical in +/-- **Half the used legs**, in the form the leg count needs: the +legs whose arc leaves are half the odd ones. -/ +theorem oddCount_eq_two_mul_legDir {t : ℕ} {W : Fragment (Fin t)} + (F : EdgeSubset W) {k ℓ : ℕ} (x : GenBoundaryState k ℓ (Fin t)) + (hx : genBoundarySubsetMatches W F.flags x) + (M : DirMatching (UsedLab F)) : + oddCount x = 2 * (Finset.univ.filter (fun i => + (∃ c, x i = Sum.inr c) + ∧ legDir F M.tail i = true)).card := by + have hiff : ∀ i : Fin t, + (∃ c, x i = Sum.inr c) ↔ W.boundaryFlag i ∈ F.boundaryFlags := by + intro i + constructor + · intro hc + exact boundaryFlag_mem_boundaryFlags ((hx i).mpr hc) + · intro hb + exact (hx i).mp (mem_flags_of_boundaryFlags F hb) + have he : {i : Fin t // + (∃ c, x i = Sum.inr c) ∧ legDir F M.tail i = true} ≃ M.Tail := + { toFun := fun y => + ⟨⟨y.val, (hiff y.val).mp y.prop.1⟩, by + rw [← legDir_eq F M.tail y.val ((hiff y.val).mp y.prop.1)] + exact y.prop.2⟩ + invFun := fun a => + ⟨a.val.val, (hiff a.val.val).mpr a.val.prop, by + rw [legDir_eq F M.tail a.val.val a.val.prop] + exact a.prop⟩ + left_inv := fun _ => rfl + right_inv := fun _ => rfl } + have h1 : (Finset.univ.filter (fun i => + (∃ c, x i = Sum.inr c) ∧ legDir F M.tail i = true)).card + = Fintype.card M.Tail := by + rw [← Fintype.card_congr he, Fintype.card_subtype] + rw [h1, oddCount_eq_card_usedLab F x hx, M.two_mul_card_tail] + +/-- **The tensor vanishes off its support**, read on the state +itself rather than on its untwist. -/ +theorem tFullD_eq_zero_of_not_matches + [LinearOrder α] [Fintype α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (κ : F.RelTransitionSystem) + (o : κ.Orientation) (M : DirMatching (UsedLab F)) + (x : GenBoundaryState k ℓ α) + (hx : ¬ genBoundarySubsetMatches W F.flags x) : + F.tFullD h κ o M x = 0 := by + by_contra hne + exact hx (genBoundarySubsetMatches_of_tFullD_ne_zero F h κ o M x hne) + +/-- **The normalised tensor vanishes off its support.** -/ +theorem tFull_eq_zero_of_not_matches + [LinearOrder α] [Fintype α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (κ : F.RelTransitionSystem) + (o : κ.Orientation) (x : GenBoundaryState k ℓ α) + (hx : ¬ genBoundarySubsetMatches W F.flags x) : + F.tFull h κ o x = 0 := by + rw [tFull_eq_tFullD] + exact tFullD_eq_zero_of_not_matches F h κ o _ x hx + +/-! ### The tensor over the core sum + +RS21's colouring sum runs over every edge of the subset. By the +bridge it equals the sum over the core edges, which is the vertex +sum the mixed partition function is built from. So the tensor is +the vertex sum, weighted by the circuit sign and the dual basis. +-/ + +open Classical in +/-- **The tensor is the vertex sum, weighted.** -/ +theorem tPrime_eq_vertexSum [LinearOrder α] [Fintype α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (κ : F.RelTransitionSystem) + (o : κ.Orientation) (x : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags (untwist F κ o x)) + (hag : ThroughAgree F (untwist F κ o x) hbnd) : + F.tPrime h κ o x + = ((-1 : ℂ) ^ κ.openCircuitCount) * dualWeight F κ o x + * F.vertexSum h (untwist F κ o x) hbnd o := by + unfold tPrime vertexSum + rw [dite_eq_left hbnd] + refine congrArg + (fun z : ℂ => ((-1 : ℂ) ^ κ.openCircuitCount) + * dualWeight F κ o x * z) ?_ + refine Finset.sum_congr rfl (fun ψ _ => ?_) + by_cases hψ : genEvenBoundaryMatch F (untwist F κ o x) hbnd ψ + · rw [ite_eq_left hψ, ite_eq_left hψ] + exact sum_edgeOddColouring hbnd hag + (fun φ' => ∏ v : W.Vertex, + ((F.coreOddSignAt o φ' v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) + (F.coreOddListAt o φ' v))) + · rw [ite_eq_right hψ, ite_eq_right hψ] + +open Classical in +/-- **The tensor at given arc directions is the vertex sum, +weighted.** -/ +theorem tPrimeD_eq_vertexSum [Fintype α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (κ : F.RelTransitionSystem) + (o : κ.Orientation) (tl : UsedLab F → Bool) + (x : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags (untwistD F tl x)) + (hag : ThroughAgree F (untwistD F tl x) hbnd) : + F.tPrimeD h κ o tl x + = ((-1 : ℂ) ^ κ.openCircuitCount) * dualWeightD F tl x + * F.vertexSum h (untwistD F tl x) hbnd o := by + unfold tPrimeD vertexSum + rw [dite_eq_left hbnd] + refine congrArg + (fun z : ℂ => ((-1 : ℂ) ^ κ.openCircuitCount) + * dualWeightD F tl x * z) ?_ + refine Finset.sum_congr rfl (fun ψ _ => ?_) + by_cases hψ : genEvenBoundaryMatch F (untwistD F tl x) hbnd ψ + · rw [ite_eq_left hψ, ite_eq_left hψ] + exact sum_edgeOddColouring hbnd hag + (fun φ' => ∏ v : W.Vertex, + ((F.coreOddSignAt o φ' v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) + (F.coreOddListAt o φ' v))) + · rw [ite_eq_right hψ, ite_eq_right hψ] + +open Classical in +/-- **The tensor in the Gram computation's terms**: a fourth root +and the matching's sign, the circuit sign, the legs' weights, and +the vertex sum at the untwisted state. Every factor but the last +is what RS21's sign bookkeeping handles; the last is what the +colouring sums multiply. -/ +theorem tFullD_eq {t : ℕ} {W : Fragment (Fin t)} (F : EdgeSubset W) + {k ℓ : ℕ} (h : MixedFunctional k ℓ) (κ : F.RelTransitionSystem) + (o : κ.Orientation) (M : DirMatching (UsedLab F)) + (x : GenBoundaryState k ℓ (Fin t)) + (hx : genBoundarySubsetMatches W F.flags x) + (hag : ThroughAgree F (untwistD F M.tail x) + ((genBoundarySubsetMatches_untwistD F M.tail x).mpr hx)) : + F.tFullD h κ o M x + = (Complex.I ^ (Fintype.card (UsedLab F) / 2) + * ((DirMatching.sgnRel + (DirMatching.stdMatching (card_usedLab_eq F M)) M + : ℤ) : ℂ) + * ((-1 : ℂ) ^ κ.openCircuitCount)) + * ((∏ i : Fin t, legWeight (legDir F M.tail i) (x i)) + * F.vertexSum h (untwistD F M.tail x) + ((genBoundarySubsetMatches_untwistD F M.tail x).mpr hx) + o) := by + unfold tFullD + rw [tPrimeD_eq_vertexSum F h κ o M.tail x + ((genBoundarySubsetMatches_untwistD F M.tail x).mpr hx) hag, + dualWeightD_eq_prod_legWeight F M.tail x hx] + ring + +/-! ### The two fragments' vertex sums, paired + +RS21's right-hand side is the composed graph's summand, whose +colouring sum runs over `V′(G) = V′(F₁) ⊔ V′(F₂)`. The object the +Gram pairing produces is the two fragments' vertex sums multiplied +at a shared interface state; naming it separates the sign +bookkeeping from the colouring correspondence. +-/ + +open Classical in +/-- **The two fragments' vertex sums at a shared agreeing state.** +RS21 colours a through-edge once, so a state whose two legs there +disagree carries no colouring at all and both tensors vanish at it. +The pairing therefore sees only the agreeing states, and it is this +value, not the bare product of vertex sums, that it computes. -/ +noncomputable def pairAgreeValue {t : ℕ} {W₁ W₂ : Fragment (Fin t)} + (F₁ : EdgeSubset W₁) (F₂ : EdgeSubset W₂) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) {κ₁ : F₁.RelTransitionSystem} + (o₁ : κ₁.Orientation) {κ₂ : F₂.RelTransitionSystem} + (o₂ : κ₂.Orientation) (st : GenBoundaryState k ℓ (Fin t)) : ℂ := + if h₁ : genBoundarySubsetMatches W₁ F₁.flags st then + if h₂ : genBoundarySubsetMatches W₂ F₂.flags st then + if ThroughAgree F₁ st h₁ ∧ ThroughAgree F₂ st h₂ then + F₁.vertexSum h st h₁ o₁ * F₂.vertexSum h st h₂ o₂ + else 0 + else 0 + else 0 + +open Classical in +/-- **The agreeing value on its support** is the two colouring +sums. -/ +theorem pairAgreeValue_pos {t : ℕ} {W₁ W₂ : Fragment (Fin t)} + (F₁ : EdgeSubset W₁) (F₂ : EdgeSubset W₂) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) {κ₁ : F₁.RelTransitionSystem} + (o₁ : κ₁.Orientation) {κ₂ : F₂.RelTransitionSystem} + (o₂ : κ₂.Orientation) (st : GenBoundaryState k ℓ (Fin t)) + (h₁ : genBoundarySubsetMatches W₁ F₁.flags st) + (h₂ : genBoundarySubsetMatches W₂ F₂.flags st) + (hag₁ : ThroughAgree F₁ st h₁) (hag₂ : ThroughAgree F₂ st h₂) : + pairAgreeValue F₁ F₂ h o₁ o₂ st + = F₁.vertexSum h st h₁ o₁ * F₂.vertexSum h st h₂ o₂ := by + unfold pairAgreeValue + rw [dite_eq_left h₁, dite_eq_left h₂, ite_eq_left ⟨hag₁, hag₂⟩] + +open Classical in +/-- **The agreeing value vanishes off the first tensor's +support.** -/ +theorem pairAgreeValue_eq_zero {t : ℕ} {W₁ W₂ : Fragment (Fin t)} + (F₁ : EdgeSubset W₁) (F₂ : EdgeSubset W₂) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) {κ₁ : F₁.RelTransitionSystem} + (o₁ : κ₁.Orientation) {κ₂ : F₂.RelTransitionSystem} + (o₂ : κ₂.Orientation) (st : GenBoundaryState k ℓ (Fin t)) + (h₁ : ¬ genBoundarySubsetMatches W₁ F₁.flags st) : + pairAgreeValue F₁ F₂ h o₁ o₂ st = 0 := by + unfold pairAgreeValue + rw [dite_eq_right h₁] + +open Classical in +/-- **The agreeing value vanishes where the first side +disagrees.** -/ +theorem pairAgreeValue_eq_zero_of_not_agree₁ {t : ℕ} + {W₁ W₂ : Fragment (Fin t)} (F₁ : EdgeSubset W₁) + (F₂ : EdgeSubset W₂) {k ℓ : ℕ} (h : MixedFunctional k ℓ) + {κ₁ : F₁.RelTransitionSystem} (o₁ : κ₁.Orientation) + {κ₂ : F₂.RelTransitionSystem} (o₂ : κ₂.Orientation) + (st : GenBoundaryState k ℓ (Fin t)) + (h₁ : genBoundarySubsetMatches W₁ F₁.flags st) + (hag : ¬ ThroughAgree F₁ st h₁) : + pairAgreeValue F₁ F₂ h o₁ o₂ st = 0 := by + unfold pairAgreeValue + rw [dite_eq_left h₁] + by_cases h₂ : genBoundarySubsetMatches W₂ F₂.flags st + · rw [dite_eq_left h₂, ite_eq_right (fun hx => hag hx.1)] + · rw [dite_eq_right h₂] + +open Classical in +/-- **The agreeing value vanishes where the second side +disagrees.** -/ +theorem pairAgreeValue_eq_zero_of_not_agree₂ {t : ℕ} + {W₁ W₂ : Fragment (Fin t)} (F₁ : EdgeSubset W₁) + (F₂ : EdgeSubset W₂) {k ℓ : ℕ} (h : MixedFunctional k ℓ) + {κ₁ : F₁.RelTransitionSystem} (o₁ : κ₁.Orientation) + {κ₂ : F₂.RelTransitionSystem} (o₂ : κ₂.Orientation) + (st : GenBoundaryState k ℓ (Fin t)) + (h₂ : genBoundarySubsetMatches W₂ F₂.flags st) + (hag : ¬ ThroughAgree F₂ st h₂) : + pairAgreeValue F₁ F₂ h o₁ o₂ st = 0 := by + unfold pairAgreeValue + by_cases h₁ : genBoundarySubsetMatches W₁ F₁.flags st + · rw [dite_eq_left h₁, dite_eq_left h₂, ite_eq_right (fun hx => hag hx.2)] + · rw [dite_eq_right h₁] + +open Classical in +/-- **The paired value is the two colouring sums**, in RS21's own +form. The agreement is not a condition imposed on top: it is the +support of the colouring sum itself. -/ +theorem pairAgreeValue_eq_edgeSum {t : ℕ} {W₁ W₂ : Fragment (Fin t)} + (F₁ : EdgeSubset W₁) (F₂ : EdgeSubset W₂) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) {κ₁ : F₁.RelTransitionSystem} + (o₁ : κ₁.Orientation) {κ₂ : F₂.RelTransitionSystem} + (o₂ : κ₂.Orientation) (st : GenBoundaryState k ℓ (Fin t)) + (h₁ : genBoundarySubsetMatches W₁ F₁.flags st) + (h₂ : genBoundarySubsetMatches W₂ F₂.flags st) : + pairAgreeValue F₁ F₂ h o₁ o₂ st + = F₁.edgeSum h st h₁ o₁ * F₂.edgeSum h st h₂ o₂ := by + by_cases hag₁ : ThroughAgree F₁ st h₁ + · by_cases hag₂ : ThroughAgree F₂ st h₂ + · rw [pairAgreeValue_pos F₁ F₂ h o₁ o₂ st h₁ h₂ hag₁ hag₂, + edgeSum_eq_vertexSum F₁ h st h₁ o₁ hag₁, + edgeSum_eq_vertexSum F₂ h st h₂ o₂ hag₂] + · rw [pairAgreeValue_eq_zero_of_not_agree₂ F₁ F₂ h o₁ o₂ st h₂ + hag₂, edgeSum_eq_zero_of_not_throughAgree F₂ h st h₂ o₂ + hag₂, mul_zero] + · rw [pairAgreeValue_eq_zero_of_not_agree₁ F₁ F₂ h o₁ o₂ st h₁ + hag₁, edgeSum_eq_zero_of_not_throughAgree F₁ h st h₁ o₁ hag₁, + zero_mul] + +open Classical in +/-- **The Gram summand, per coordinate.** At a coordinate the first +tensor supports, the product of the two tensors against the form is +the sign bookkeeping, the twists and leg weights the cancellation +consumes, and the two vertex sums at the shared state. -/ +theorem superForm_mul_tFullD_mul_tFullD {t : ℕ} + {W₁ W₂ : Fragment (Fin t)} (F₁ : EdgeSubset W₁) + (F₂ : EdgeSubset W₂) {k ℓ : ℕ} (h : MixedFunctional k ℓ) + {κ₁ : F₁.RelTransitionSystem} (o₁ : κ₁.Orientation) + (M₁ : DirMatching (UsedLab F₁)) + {κ₂ : F₂.RelTransitionSystem} (o₂ : κ₂.Orientation) + (M₂ : DirMatching (UsedLab F₂)) + (x : GenBoundaryState k ℓ (Fin t)) + (hx : genBoundarySubsetMatches W₁ F₁.flags x) + (hag₁ : ThroughAgree F₁ (untwistD F₁ M₁.tail x) + ((genBoundarySubsetMatches_untwistD F₁ M₁.tail x).mpr hx)) + (hx₂ : genBoundarySubsetMatches W₂ F₂.flags (dualState x)) + (hag₂ : ThroughAgree F₂ (untwistD F₂ M₂.tail (dualState x)) + ((genBoundarySubsetMatches_untwistD F₂ M₂.tail + (dualState x)).mpr hx₂)) : + (∏ i : Fin t, legSelf (x i)) * F₁.tFullD h κ₁ o₁ M₁ x + * F₂.tFullD h κ₂ o₂ M₂ (dualState x) + = (((DirMatching.sgnRel + (DirMatching.stdMatching (card_usedLab_eq F₁ M₁)) M₁ + : ℤ) : ℂ) * ((-1 : ℂ) ^ κ₁.openCircuitCount) + * (((DirMatching.sgnRel + (DirMatching.stdMatching (card_usedLab_eq F₂ M₂)) M₂ + : ℤ) : ℂ) * ((-1 : ℂ) ^ κ₂.openCircuitCount))) + * ((Complex.I ^ (Fintype.card (UsedLab F₁) / 2) + * Complex.I ^ (Fintype.card (UsedLab F₂) / 2)) + * ((∏ i : Fin t, legWeight (legDir F₁ M₁.tail i) (x i)) + * (∏ i : Fin t, + legWeight (legDir F₂ M₂.tail i) (dualLeg (x i)))) + * (∏ i : Fin t, legSelf (x i))) + * (F₁.vertexSum h (untwistD F₁ M₁.tail x) + ((genBoundarySubsetMatches_untwistD F₁ M₁.tail x).mpr hx) + o₁ + * F₂.vertexSum h (untwistD F₂ M₂.tail (dualState x)) + ((genBoundarySubsetMatches_untwistD F₂ M₂.tail + (dualState x)).mpr hx₂) o₂) := by + rw [tFullD_eq F₁ h κ₁ o₁ M₁ x hx hag₁, + tFullD_eq F₂ h κ₂ o₂ M₂ (dualState x) hx₂ hag₂] + have hd : ∀ i : Fin t, dualState x i = dualLeg (x i) := fun _ => rfl + rw [Finset.prod_congr rfl (fun i _ => congrArg + (legWeight (legDir F₂ M₂.tail i)) (hd i))] + ring + +open Classical in +/-- **RS21's (13), up to its sign bookkeeping.** The Gram pairing +of the two fragments' tensors is the two colouring sums, multiplied +at a shared interface state and summed, times the two matchings' +signs and circuit signs. What remains to identify it with the +composed graph's summand is (14) and the colouring correspondence. -/ +theorem sum_sum_superForm_tFullD {t : ℕ} {W₁ W₂ : Fragment (Fin t)} + (F₁ : EdgeSubset W₁) (F₂ : EdgeSubset W₂) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) {κ₁ : F₁.RelTransitionSystem} + (o₁ : κ₁.Orientation) (M₁ : DirMatching (UsedLab F₁)) + {κ₂ : F₂.RelTransitionSystem} (o₂ : κ₂.Orientation) + (M₂ : DirMatching (UsedLab F₂)) (m : ℕ) + (hcard₁ : Fintype.card (UsedLab F₁) = 2 * m) + (hcard₂ : Fintype.card (UsedLab F₂) = 2 * m) + (hused : ∀ i : Fin t, W₁.boundaryFlag i ∈ F₁.boundaryFlags + ↔ W₂.boundaryFlag i ∈ F₂.boundaryFlags) + (halt : ∀ i : Fin t, W₁.boundaryFlag i ∈ F₁.boundaryFlags → + legDir F₂ M₂.tail i = !(legDir F₁ M₁.tail i)) + : + (∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * F₁.tFullD h κ₁ o₁ M₁ x + * F₂.tFullD h κ₂ o₂ M₂ y) + = (((DirMatching.sgnRel + (DirMatching.stdMatching (card_usedLab_eq F₁ M₁)) M₁ + : ℤ) : ℂ) * ((-1 : ℂ) ^ κ₁.openCircuitCount) + * (((DirMatching.sgnRel + (DirMatching.stdMatching (card_usedLab_eq F₂ M₂)) M₂ + : ℤ) : ℂ) * ((-1 : ℂ) ^ κ₂.openCircuitCount))) + * ∑ st : GenBoundaryState k ℓ (Fin t), + pairAgreeValue F₁ F₂ h o₁ o₂ st := by + classical + rw [sum_sum_superForm (fun x => F₁.tFullD h κ₁ o₁ M₁ x) + (fun y => F₂.tFullD h κ₂ o₂ M₂ y)] + -- ═══════ THE DUAL STATE MATCHES THE SECOND SUBSET ═══════ + have hmatch₂ : ∀ x : GenBoundaryState k ℓ (Fin t), + genBoundarySubsetMatches W₁ F₁.flags x → + genBoundarySubsetMatches W₂ F₂.flags (dualState x) := by + intro x hx i + constructor + · intro hf + have h1 : W₁.boundaryFlag i ∈ F₁.boundaryFlags := + (hused i).mpr (boundaryFlag_mem_boundaryFlags hf) + obtain ⟨c, hc⟩ := (hx i).mp (mem_flags_of_boundaryFlags F₁ h1) + exact ⟨oddPartner ℓ c, by + change dualLeg (x i) = Sum.inr (oddPartner ℓ c) + rw [hc]; rfl⟩ + · rintro ⟨c, hc⟩ + have hodd : ∃ d, x i = Sum.inr d := + (dualState_isInr x i).mp ⟨c, hc⟩ + exact mem_flags_of_boundaryFlags F₂ + ((hused i).mp + (boundaryFlag_mem_boundaryFlags ((hx i).mpr hodd))) + have hterm : ∀ x : GenBoundaryState k ℓ (Fin t), + (∏ i : Fin t, legSelf (x i)) * F₁.tFullD h κ₁ o₁ M₁ x + * F₂.tFullD h κ₂ o₂ M₂ (dualState x) + = (((DirMatching.sgnRel + (DirMatching.stdMatching (card_usedLab_eq F₁ M₁)) M₁ + : ℤ) : ℂ) * ((-1 : ℂ) ^ κ₁.openCircuitCount) + * (((DirMatching.sgnRel + (DirMatching.stdMatching (card_usedLab_eq F₂ M₂)) M₂ + : ℤ) : ℂ) * ((-1 : ℂ) ^ κ₂.openCircuitCount))) + * (((stateTwist x * stateTwist (dualState x)) + * (((∏ i : Fin t, + legWeight (legDir F₁ M₁.tail i) (x i)) + * (∏ i : Fin t, + legWeight (legDir F₂ M₂.tail i) (dualLeg (x i)))) + * superForm t x (dualState x))) + * pairAgreeValue F₁ F₂ h o₁ o₂ + (untwistState (legDir F₁ M₁.tail) x)) := by + intro x + by_cases hx : genBoundarySubsetMatches W₁ F₁.flags x + · have hx₂ := hmatch₂ x hx + have hst₁ : untwistD F₁ M₁.tail x + = untwistState (legDir F₁ M₁.tail) x := + untwistD_eq_untwistState F₁ M₁.tail x + have hst₂ : untwistD F₂ M₂.tail (dualState x) + = untwistState (legDir F₁ M₁.tail) x := by + rw [untwistD_eq_untwistState F₂ M₂.tail (dualState x)] + refine untwistState_dualState' _ _ x (fun i hi => ?_) + obtain ⟨c, hc⟩ := hi + exact halt i + (boundaryFlag_mem_boundaryFlags ((hx i).mpr ⟨c, hc⟩)) + have hm₁ : genBoundarySubsetMatches W₁ F₁.flags + (untwistState (legDir F₁ M₁.tail) x) := by + rw [← hst₁] + exact (genBoundarySubsetMatches_untwistD F₁ M₁.tail x).mpr hx + have hm₂ : genBoundarySubsetMatches W₂ F₂.flags + (untwistState (legDir F₁ M₁.tail) x) := by + rw [← hst₂] + exact (genBoundarySubsetMatches_untwistD F₂ M₂.tail + (dualState x)).mpr hx₂ + by_cases hag₁ : ThroughAgree F₁ + (untwistState (legDir F₁ M₁.tail) x) hm₁ + · by_cases hag₂ : ThroughAgree F₂ + (untwistState (legDir F₁ M₁.tail) x) hm₂ + · have htw : Complex.I ^ (Fintype.card (UsedLab F₁) / 2) + * Complex.I ^ (Fintype.card (UsedLab F₂) / 2) + = stateTwist x * stateTwist (dualState x) := by + have h1 : oddCount x = 2 * m := by + rw [oddCount_eq_card_usedLab F₁ x hx, hcard₁] + have h2 : oddCount (dualState x) = 2 * m := by + rw [oddCount_dualState x, h1] + unfold stateTwist + rw [h1, h2, hcard₁, hcard₂] + have hpv : pairAgreeValue F₁ F₂ h o₁ o₂ + (untwistState (legDir F₁ M₁.tail) x) + = F₁.vertexSum h (untwistD F₁ M₁.tail x) + ((genBoundarySubsetMatches_untwistD F₁ M₁.tail + x).mpr hx) o₁ + * F₂.vertexSum h (untwistD F₂ M₂.tail (dualState x)) + ((genBoundarySubsetMatches_untwistD F₂ M₂.tail + (dualState x)).mpr hx₂) o₂ := by + rw [pairAgreeValue_pos F₁ F₂ h o₁ o₂ _ hm₁ hm₂ hag₁ hag₂] + congr 1 + · congr 1 + exact hst₁.symm + · congr 1 + exact hst₂.symm + rw [superForm_mul_tFullD_mul_tFullD F₁ F₂ h o₁ M₁ o₂ M₂ x hx + ((throughAgree_congr hst₁ _ hm₁).mpr hag₁) hx₂ + ((throughAgree_congr hst₂ _ hm₂).mpr hag₂), hpv, htw, + superForm_dualState x] + ring + · rw [tFullD_eq_zero_of_not_throughAgree F₂ h κ₂ o₂ M₂ + (dualState x) + ((genBoundarySubsetMatches_untwistD F₂ M₂.tail + (dualState x)).mpr hx₂) + (fun hy => hag₂ ((throughAgree_congr hst₂ _ hm₂).mp hy)), + pairAgreeValue_eq_zero_of_not_agree₂ F₁ F₂ h o₁ o₂ _ hm₂ + hag₂] + ring + · rw [tFullD_eq_zero_of_not_throughAgree F₁ h κ₁ o₁ M₁ x + ((genBoundarySubsetMatches_untwistD F₁ M₁.tail x).mpr hx) + (fun hy => hag₁ ((throughAgree_congr hst₁ _ hm₁).mp hy)), + pairAgreeValue_eq_zero_of_not_agree₁ F₁ F₂ h o₁ o₂ _ hm₁ + hag₁] + ring + · have hz₁ : F₁.tFullD h κ₁ o₁ M₁ x = 0 := by + by_contra hne + exact hx (genBoundarySubsetMatches_of_tFullD_ne_zero F₁ h κ₁ + o₁ M₁ x hne) + have hzp : pairAgreeValue F₁ F₂ h o₁ o₂ + (untwistState (legDir F₁ M₁.tail) x) = 0 := by + unfold pairAgreeValue + refine dite_eq_right (fun hc => hx ?_) + rw [← untwistD_eq_untwistState F₁ M₁.tail x] at hc + exact (genBoundarySubsetMatches_untwistD F₁ M₁.tail x).mp hc + rw [hz₁, hzp] + ring + -- ═══════ THE SUM OVER STATES, WITH THE TWISTS ═══════ + -- Every term is the pair value at the state; what is left is the + -- bracket sum, whose three side conditions follow. + rw [Finset.sum_congr rfl (fun x _ => hterm x), ← Finset.mul_sum] + congr 1 + refine sum_legBracket_with_twists' (legDir F₁ M₁.tail) + (legDir F₂ M₂.tail) _ m ?_ ?_ ?_ + · intro x hne + have hx : genBoundarySubsetMatches W₁ F₁.flags x := by + by_contra hc + refine hne ?_ + unfold pairAgreeValue + refine dite_eq_right (fun hd => hc ?_) + rw [← untwistD_eq_untwistState F₁ M₁.tail x] at hd + exact (genBoundarySubsetMatches_untwistD F₁ M₁.tail x).mp hd + have := oddCount_eq_two_mul_legDir F₁ x hx M₁ + rw [oddCount_eq_card_usedLab F₁ x hx, hcard₁] at this + omega + · intro x hne + have hx : genBoundarySubsetMatches W₁ F₁.flags x := by + by_contra hc + refine hne ?_ + unfold pairAgreeValue + refine dite_eq_right (fun hd => hc ?_) + rw [← untwistD_eq_untwistState F₁ M₁.tail x] at hd + exact (genBoundarySubsetMatches_untwistD F₁ M₁.tail x).mp hd + rw [oddCount_eq_card_usedLab F₁ x hx, hcard₁] + · intro x hne i hi + have hx : genBoundarySubsetMatches W₁ F₁.flags x := by + by_contra hc + refine hne ?_ + unfold pairAgreeValue + refine dite_eq_right (fun hd => hc ?_) + rw [← untwistD_eq_untwistState F₁ M₁.tail x] at hd + exact (genBoundarySubsetMatches_untwistD F₁ M₁.tail x).mp hd + exact halt i (boundaryFlag_mem_boundaryFlags ((hx i).mpr hi)) + +/-! ### The vertex sum under a chain flip + +The colouring sum's own chain-flip ledger, read on the vertex sum. +-/ + +open Classical in +/-- **The vertex sum under a chain flip.** -/ +theorem vertexSum_portFlip {W : Fragment α} + {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {S : Finset W.Flag} {p₁ p₂ : W.Flag} + {i₁ i₂ : α} (hp : PortedFlipSet κ S p₁ p₂ i₁ i₂) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {c₁ c₂ : Fin (2 * ℓ)} (hc₁ : st i₁ = Sum.inr c₁) + (hc₂ : st i₂ = Sum.inr c₂) (o : κ.Orientation) : + F.vertexSum h st hbnd (o.portFlip hp) + = ((oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂ : ℤ) : ℂ) * + F.vertexSum h (stateOddFlip st i₁ i₂) + (genBoundarySubsetMatches_stateOddFlip hbnd i₁ i₂) o := + psiSum_portFlip hp h st hbnd hc₁ hc₂ o + +/-! ### The vertex sum ignores the through legs + +The core colouring constraint reaches only the core flags, and a +through edge's legs are not among them. Flipping the state's odd +colour to its partner at two such legs therefore leaves the vertex +sum alone: the even constraint does not see an odd leg at all, and +the odd constraint does not see a through one. +-/ + +open Classical in +/-- **Flipping the state at two through legs leaves the vertex sum +unchanged.** -/ +theorem vertexSum_stateOddFlip_through {W : Fragment α} + {F : EdgeSubset W} {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ : F.RelTransitionSystem} (o : κ.Orientation) (i₁ i₂ : α) + (h₁ : W.boundaryFlag i₁ ∈ F.throughFlags) + (h₂ : W.boundaryFlag i₂ ∈ F.throughFlags) : + F.vertexSum h (stateOddFlip st i₁ i₂) + (genBoundarySubsetMatches_stateOddFlip hbnd i₁ i₂) o + = F.vertexSum h st hbnd o := by + have hne : ∀ i : α, W.boundaryFlag i ∈ F.coreFlags → + i ≠ i₁ ∧ i ≠ i₂ := by + intro i hcore + have hnt := (Finset.mem_sdiff.mp hcore).2 + exact ⟨fun hx => hnt (by rw [hx]; exact h₁), + fun hx => hnt (by rw [hx]; exact h₂)⟩ + unfold vertexSum + refine Finset.sum_congr rfl (fun ψ _ => ?_) + have heven : genEvenBoundaryMatch F (stateOddFlip st i₁ i₂) + (genBoundarySubsetMatches_stateOddFlip hbnd i₁ i₂) ψ + ↔ genEvenBoundaryMatch F st hbnd ψ := by + constructor + · intro hm i c hst + exact hm i c ((stateOddFlip_isInl (st := st) i c).mpr hst) + · intro hm i c hst + exact hm i c ((stateOddFlip_isInl (st := st) i c).mp hst) + by_cases hψ : genEvenBoundaryMatch F st hbnd ψ + · rw [ite_eq_left (heven.mpr hψ), ite_eq_left hψ] + refine Finset.sum_congr rfl (fun φ _ => ?_) + have hcore : F.coreOddBoundaryMatch (stateOddFlip st i₁ i₂) φ + ↔ F.coreOddBoundaryMatch st φ := by + constructor + · intro hm i c hst hc + obtain ⟨hn₁, hn₂⟩ := hne i hc + exact hm i c (by rw [stateOddFlip_of_ne hn₁ hn₂]; exact hst) hc + · intro hm i c hst hc + obtain ⟨hn₁, hn₂⟩ := hne i hc + refine hm i c ?_ hc + rw [← stateOddFlip_of_ne (st := st) hn₁ hn₂] + exact hst + by_cases hφ : F.coreOddBoundaryMatch st φ + · rw [ite_eq_left (hcore.mpr hφ), ite_eq_left hφ] + · rw [ite_eq_right (fun hx => hφ (hcore.mp hx)), ite_eq_right hφ] + · rw [ite_eq_right (fun hx => hψ (heven.mp hx)), ite_eq_right hψ] + +/-! ### The tensor under a chain flip + +RS21: inverting a directed trail negates `t′_h`. The two ledgers +meet — the dual basis contributes `dualSign` at each chain end, the +colouring sum contributes the flipped state's own sign there — and +each pair is `1` where the trail leaves and `-1` where it enters. +Exactly one end of a chain is its tail, so the product is `-1`. +-/ + +/-- The dual sign against the state's own sign. -/ +theorem dualSign_mul_self {ℓ : ℕ} (c : Fin (2 * ℓ)) : + dualSign ℓ c * ((oddPartnerSign ℓ c : ℤ) : ℂ) = 1 := + oddPartnerSign_cast_sq ℓ c + +/-- The dual sign against the partner colour's sign. -/ +theorem dualSign_mul_partner {ℓ : ℕ} (c : Fin (2 * ℓ)) : + dualSign ℓ c * ((oddPartnerSign ℓ (oddPartner ℓ c) : ℤ) : ℂ) + = -1 := by + have hsq := oddPartnerSign_cast_sq ℓ c + unfold dualSign + rw [oddPartnerSign_oddPartner] + push_cast at hsq ⊢ + linear_combination -hsq + +/-- **The tensor changes sign under a chain flip** — RS21's +`t′_h(F,H,ω,κ) = -t′_h(F,H,ω′,κ′)`. The dual basis contributes the +chain ends' own signs and the colouring sum contributes the flipped +state's; each pair is `1` at the end the trail leaves and `-1` at the +end it enters, and a trail leaves exactly one of its two ends. -/ +theorem tPrime_portFlip [LinearOrder α] [Fintype α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) {κ : F.RelTransitionSystem} + (o : κ.Orientation) {S : Finset W.Flag} {p₁ p₂ : W.Flag} + {i₁ i₂ : α} (hp : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (hb₁ : W.boundaryFlag i₁ ∈ F.boundaryFlags) + (hchord : chordInv F κ i₁ = i₂) + (x : GenBoundaryState k ℓ α) {c₁ c₂ : Fin (2 * ℓ)} + (hc₁ : x i₁ = Sum.inr c₁) (hc₂ : x i₂ = Sum.inr c₂) + (hbnd : genBoundarySubsetMatches W F.flags (untwist F κ o x)) + (hbnd' : genBoundarySubsetMatches W F.flags + (untwist F κ (o.portFlip hp) x)) + (hag : ThroughAgree F (untwist F κ o x) hbnd) + (hag' : ThroughAgree F (untwist F κ (o.portFlip hp) x) hbnd') : + F.tPrime h κ (o.portFlip hp) x = - F.tPrime h κ o x := by + have hb₂ : W.boundaryFlag i₂ ∈ F.boundaryFlags := by + rw [← hchord]; exact chordInv_mem F κ hb₁ + -- the two ends' directions are opposite + have hedge : (cutMatching F κ o).edge ⟨i₁, hb₁⟩ + = ⟨i₂, hb₂⟩ := Subtype.ext hchord + have ht12 : (cutMatching F κ o).tail ⟨i₂, hb₂⟩ + = !(cutMatching F κ o).tail ⟨i₁, hb₁⟩ := by + rw [← hedge] + exact (cutMatching F κ o).tail_flip ⟨i₁, hb₁⟩ + -- the flipped state's colours at the two ends + have ha₁ : stateOddFlip (untwist F κ o x) i₁ i₂ i₁ + = Sum.inr (if (cutMatching F κ o).tail ⟨i₁, hb₁⟩ then c₁ + else oddPartner ℓ c₁) := by + rw [stateOddFlip_left, untwist_apply_odd F κ o x hb₁ hc₁] + by_cases ht : (cutMatching F κ o).tail ⟨i₁, hb₁⟩ = true + · rw [ite_eq_left ht, ite_eq_left ht] + change Sum.inr (oddPartner ℓ (oddPartner ℓ c₁)) = Sum.inr c₁ + rw [oddPartner_invol] + · rw [ite_eq_right ht, ite_eq_right ht] + rfl + have ha₂ : stateOddFlip (untwist F κ o x) i₁ i₂ i₂ + = Sum.inr (if (cutMatching F κ o).tail ⟨i₂, hb₂⟩ then c₂ + else oddPartner ℓ c₂) := by + rw [stateOddFlip_right, untwist_apply_odd F κ o x hb₂ hc₂] + by_cases ht : (cutMatching F κ o).tail ⟨i₂, hb₂⟩ = true + · rw [ite_eq_left ht, ite_eq_left ht] + change Sum.inr (oddPartner ℓ (oddPartner ℓ c₂)) = Sum.inr c₂ + rw [oddPartner_invol] + · rw [ite_eq_right ht, ite_eq_right ht] + rfl + -- the colouring sum's ledger + have hVS : F.vertexSum h (untwist F κ (o.portFlip hp) x) hbnd' + (o.portFlip hp) + = ((oddPartnerSign ℓ (if (cutMatching F κ o).tail ⟨i₁, hb₁⟩ + then c₁ else oddPartner ℓ c₁) * + oddPartnerSign ℓ (if (cutMatching F κ o).tail ⟨i₂, hb₂⟩ + then c₂ else oddPartner ℓ c₂) : ℤ) : ℂ) * + F.vertexSum h (untwist F κ o x) hbnd o := by + have hst := untwist_portFlip o hp hb₁ hchord x + have hkey := vertexSum_portFlip hp h + (stateOddFlip (untwist F κ o x) i₁ i₂) + (by rw [← hst]; exact hbnd') ha₁ ha₂ o + rw [show F.vertexSum h (untwist F κ (o.portFlip hp) x) hbnd' + (o.portFlip hp) + = F.vertexSum h (stateOddFlip (untwist F κ o x) i₁ i₂) + (by rw [← hst]; exact hbnd') (o.portFlip hp) from by + congr 1] + rw [hkey] + congr 2 + rw [stateOddFlip_stateOddFlip] + -- the dual basis's weight + have hdw : dualWeight F κ (o.portFlip hp) x + = dualSign ℓ c₁ * dualSign ℓ c₂ * dualWeight F κ o x := by + have h1 := dualWeight_portFlip_mul o hp hb₁ hchord x hc₁ hc₂ + have h2 := dualWeight_mul_self F κ o x + calc dualWeight F κ (o.portFlip hp) x + = dualWeight F κ (o.portFlip hp) x * + (dualWeight F κ o x * dualWeight F κ o x) := by + rw [h2, mul_one] + _ = (dualWeight F κ (o.portFlip hp) x * dualWeight F κ o x) * + dualWeight F κ o x := by ring + _ = dualSign ℓ c₁ * dualSign ℓ c₂ * dualWeight F κ o x := by + rw [h1] + rw [tPrime_eq_vertexSum F h κ (o.portFlip hp) x hbnd' hag', + tPrime_eq_vertexSum F h κ o x hbnd hag, hVS, hdw, + show κ.openCircuitCount = κ.openCircuitCount from rfl] + have hsign : dualSign ℓ c₁ * dualSign ℓ c₂ * + ((oddPartnerSign ℓ (if (cutMatching F κ o).tail ⟨i₁, hb₁⟩ + then c₁ else oddPartner ℓ c₁) * + oddPartnerSign ℓ (if (cutMatching F κ o).tail ⟨i₂, hb₂⟩ + then c₂ else oddPartner ℓ c₂) : ℤ) : ℂ) = -1 := by + rw [ht12] + cases hcase : (cutMatching F κ o).tail ⟨i₁, hb₁⟩ + · rw [ite_eq_right (by simp), Bool.not_false, ite_eq_left rfl] + have hB := dualSign_mul_partner (ℓ := ℓ) c₁ + have hA := dualSign_mul_self (ℓ := ℓ) c₂ + push_cast + linear_combination + (dualSign ℓ c₂ * ((oddPartnerSign ℓ c₂ : ℤ) : ℂ)) * hB - hA + · rw [ite_eq_left rfl, Bool.not_true, ite_eq_right (by simp)] + have hA := dualSign_mul_self (ℓ := ℓ) c₁ + have hB := dualSign_mul_partner (ℓ := ℓ) c₂ + push_cast + linear_combination + (dualSign ℓ c₂ * + ((oddPartnerSign ℓ (oddPartner ℓ c₂) : ℤ) : ℂ)) * hA + hB + linear_combination (((-1 : ℂ) ^ κ.openCircuitCount) * + dualWeight F κ o x * + F.vertexSum h (untwist F κ o x) hbnd o) * hsign + +/-! ### Inverting an edge joining two labelled ends + +RS21's (12) inverts a directed trail. When the trail is a single +edge with both ends labelled there is no transition to invert, so +the whole effect falls on the dual basis: the two legs exchange `f` +and `g`. The colouring moves too — the edge's colour becomes its +partner — but that colour occurs at no vertex, so the vertex sum is +unchanged and the two weights differ by exactly one sign. This is +RS21's count of one arc and no pairings. +-/ + +open Classical in +/-- **Inverting an edge joining two labelled ends negates the +tensor.** -/ +theorem tPrimeD_reverseArc [LinearOrder α] [Fintype α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (κ : F.RelTransitionSystem) + (o : κ.Orientation) (M : DirMatching (UsedLab F)) + (a : UsedLab F) (x : GenBoundaryState k ℓ α) + (hthr₁ : W.boundaryFlag a.val ∈ F.throughFlags) + (hthr₂ : W.boundaryFlag (M.edge a).val ∈ F.throughFlags) + (hta : M.tail a = true) {c : Fin (2 * ℓ)} + (hca : x a.val = Sum.inr c) + (hca' : x (M.edge a).val = Sum.inr (oddPartner ℓ c)) + (hbnd : genBoundarySubsetMatches W F.flags (untwistD F M.tail x)) + (hbnd' : genBoundarySubsetMatches W F.flags + (untwistD F (M.reverseArc a).tail x)) + (hag : ThroughAgree F (untwistD F M.tail x) hbnd) + (hag' : ThroughAgree F (untwistD F (M.reverseArc a).tail x) + hbnd') : + F.tPrimeD h κ o (M.reverseArc a).tail x + = - F.tPrimeD h κ o M.tail x := by + -- the two weights differ by a sign + have hmul := dualWeightD_reverseArc_mul F M a x hta hca hca' + have hsq := dualWeightD_mul_self F M.tail x + have hw : dualWeightD F (M.reverseArc a).tail x + = - dualWeightD F M.tail x := by + calc dualWeightD F (M.reverseArc a).tail x + = dualWeightD F (M.reverseArc a).tail x + * (dualWeightD F M.tail x * dualWeightD F M.tail x) := by + rw [hsq, mul_one] + _ = (dualWeightD F (M.reverseArc a).tail x + * dualWeightD F M.tail x) * dualWeightD F M.tail x := by + ring + _ = - dualWeightD F M.tail x := by rw [hmul]; ring + -- the vertex sums agree + have hst := untwistD_reverseArc F M a x + have hV : F.vertexSum h (untwistD F (M.reverseArc a).tail x) hbnd' o + = F.vertexSum h (untwistD F M.tail x) hbnd o := by + rw [show F.vertexSum h (untwistD F (M.reverseArc a).tail x) hbnd' o + = F.vertexSum h + (stateOddFlip (untwistD F M.tail x) a.val (M.edge a).val) + (by rw [← hst]; exact hbnd') o from by congr 1] + exact vertexSum_stateOddFlip_through h (untwistD F M.tail x) hbnd + o a.val (M.edge a).val hthr₁ hthr₂ + rw [tPrimeD_eq_vertexSum F h κ o _ x hbnd' hag', + tPrimeD_eq_vertexSum F h κ o _ x hbnd hag, hV, hw] + ring + +open Classical in +/-- **RS21's (12) at the normalised tensor**: inverting an edge +joining two labelled ends leaves `t_h` alone, because the matching's +sign and the tensor both change sign. -/ +theorem tFullD_reverseArc [LinearOrder α] [Fintype α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (κ : F.RelTransitionSystem) + (o : κ.Orientation) (M : DirMatching (UsedLab F)) + (a : UsedLab F) (x : GenBoundaryState k ℓ α) + (hthr₁ : W.boundaryFlag a.val ∈ F.throughFlags) + (hthr₂ : W.boundaryFlag (M.edge a).val ∈ F.throughFlags) + (hta : M.tail a = true) {c : Fin (2 * ℓ)} + (hca : x a.val = Sum.inr c) + (hca' : x (M.edge a).val = Sum.inr (oddPartner ℓ c)) + (hbnd : genBoundarySubsetMatches W F.flags (untwistD F M.tail x)) + (hbnd' : genBoundarySubsetMatches W F.flags + (untwistD F (M.reverseArc a).tail x)) + (hag : ThroughAgree F (untwistD F M.tail x) hbnd) + (hag' : ThroughAgree F (untwistD F (M.reverseArc a).tail x) + hbnd') : + F.tFullD h κ o (M.reverseArc a) x = F.tFullD h κ o M x := by + have hsgn := DirMatching.sgnRel_reverseArc + (DirMatching.stdMatching (card_usedLab_eq F M)) M a + have htp := tPrimeD_reverseArc F h κ o M a x hthr₁ hthr₂ hta hca + hca' hbnd hbnd' hag hag' + unfold tFullD + rw [show (card_usedLab_eq F (M.reverseArc a)) + = (card_usedLab_eq F M) from rfl, hsgn, htp] + push_cast + ring + +/-- **RS21's (12) at the normalised tensor, for a chain**: +inverting a directed trail through the interior leaves `t_h` alone, +because the matching's sign and the tensor both change sign. The +orientation moves with the trail, which is what distinguishes this +from the case of an edge joining two labelled ends. -/ +theorem tFull_portFlip [LinearOrder α] [Fintype α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) {κ : F.RelTransitionSystem} + (o : κ.Orientation) {S : Finset W.Flag} {p₁ p₂ : W.Flag} + {i₁ i₂ : α} (hp : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (hb₁ : W.boundaryFlag i₁ ∈ F.boundaryFlags) + (hchord : chordInv F κ i₁ = i₂) + (x : GenBoundaryState k ℓ α) {c₁ c₂ : Fin (2 * ℓ)} + (hc₁ : x i₁ = Sum.inr c₁) (hc₂ : x i₂ = Sum.inr c₂) + (hbnd : genBoundarySubsetMatches W F.flags (untwist F κ o x)) + (hbnd' : genBoundarySubsetMatches W F.flags + (untwist F κ (o.portFlip hp) x)) + (hag : ThroughAgree F (untwist F κ o x) hbnd) + (hag' : ThroughAgree F (untwist F κ (o.portFlip hp) x) hbnd') : + F.tFull h κ (o.portFlip hp) x = F.tFull h κ o x := by + have hcut := cutMatching_portFlip o hp hb₁ hchord + have hsgn : (DirMatching.sgnRel + (DirMatching.stdMatching (card_usedLabel_eq F κ (o.portFlip hp))) + (cutMatching F κ (o.portFlip hp))) + = - DirMatching.sgnRel + (DirMatching.stdMatching (card_usedLabel_eq F κ o)) + (cutMatching F κ o) := by + rw [show (card_usedLabel_eq F κ (o.portFlip hp)) + = (card_usedLabel_eq F κ o) from rfl, hcut] + exact DirMatching.sgnRel_reverseArc _ _ _ + have htp := tPrime_portFlip F h o hp hb₁ hchord x hc₁ hc₂ hbnd + hbnd' hag hag' + unfold tFull + rw [hsgn, htp] + push_cast + ring + +open Classical in +/-- **RS21's (12) for a chain, at every state.** Off the tensor's +support both sides vanish, so the invariance needs no hypothesis on +the state. -/ +theorem tFull_portFlip_all [LinearOrder α] [Fintype α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) {κ : F.RelTransitionSystem} + (o : κ.Orientation) {S : Finset W.Flag} {p₁ p₂ : W.Flag} + {i₁ i₂ : α} (hp : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (hb₁ : W.boundaryFlag i₁ ∈ F.boundaryFlags) + (hchord : chordInv F κ i₁ = i₂) + (hnt₁ : ¬ IsThroughLabel F i₁) (hnt₂ : ¬ IsThroughLabel F i₂) + (x : GenBoundaryState k ℓ α) : + F.tFull h κ (o.portFlip hp) x = F.tFull h κ o x := by + by_cases hx : genBoundarySubsetMatches W F.flags x + · have hbnd := (genBoundarySubsetMatches_untwistD F + (cutMatching F κ o).tail x).mpr hx + have hbnd' := (genBoundarySubsetMatches_untwistD F + (cutMatching F κ (o.portFlip hp)).tail x).mpr hx + obtain ⟨c₁, hc₁⟩ := (hx i₁).mp (mem_flags_of_boundaryFlags F hb₁) + have hb₂ : W.boundaryFlag i₂ ∈ F.boundaryFlags := by + rw [← hchord] + exact chordInv_mem F κ hb₁ + obtain ⟨c₂, hc₂⟩ := (hx i₂).mp (mem_flags_of_boundaryFlags F hb₂) + have hthr : ∀ (f : W.Flag) (hb : f ∈ F.boundaryFlags), + W.pairing f ∈ F.boundaryFlags → + untwist F κ o x (F.boundaryLabel hb) + = untwist F κ (o.portFlip hp) x (F.boundaryLabel hb) := by + intro f hb hbp + have hbf : W.boundaryFlag (F.boundaryLabel hb) = f := + boundaryFlag_boundaryLabel hb + have hbi : W.boundaryFlag (F.boundaryLabel hb) + ∈ F.boundaryFlags := by + rw [hbf]; exact hb + have hit : IsThroughLabel F (F.boundaryLabel hb) := by + unfold IsThroughLabel + rw [hbf]; exact hbp + have hne : ¬ (F.boundaryLabel hb = i₁ + ∨ F.boundaryLabel hb = i₂) := by + rintro (hx' | hx') + · exact hnt₁ (hx' ▸ hit) + · exact hnt₂ (hx' ▸ hit) + simp only [untwist] + rw [dite_eq_left hbi, dite_eq_left hbi, + tail_portFlip_of_not_mem o hp hb₁ hchord hbi hne] + by_cases hag : ThroughAgree F (untwist F κ o x) hbnd + · exact tFull_portFlip F h o hp hb₁ hchord x hc₁ hc₂ hbnd hbnd' + hag (throughAgree_of_eq_on_through hbnd hbnd' hthr hag) + · rw [tFull_eq_zero_of_not_throughAgree F h κ (o.portFlip hp) x + hbnd' (fun hy => hag (throughAgree_of_eq_on_through hbnd' + hbnd (fun f hb hbp => (hthr f hb hbp).symm) hy)), + tFull_eq_zero_of_not_throughAgree F h κ o x hbnd hag] + · rw [tFull_eq_zero_of_not_matches F h κ _ x hx, + tFull_eq_zero_of_not_matches F h κ o x hx] + +/-! ### The tensor does not see those edges' directions + +Since inverting such an edge leaves `t_h` alone, and any two +direction assignments on them differ by a set of such inversions, +the normalised tensor is the same for all of them. This is RS21's +"we may assume that `ω₁, κ₁, ω₂, κ₂` are chosen so that the union is +Eulerian", for the half of the choice the chain orientation does not +already provide. +-/ + +open Classical in +/-- **The normalised tensor is independent of the directions given +to the edges joining two labelled ends.** -/ +theorem tFullD_congr_through [LinearOrder α] [Fintype α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (κ : F.RelTransitionSystem) + (o : κ.Orientation) (x : GenBoundaryState k ℓ α) + (hx : genBoundarySubsetMatches W F.flags x) : + ∀ (n : ℕ) (M M' : DirMatching (UsedLab F)), + M'.edge = M.edge → + (∀ N : DirMatching (UsedLab F), N.edge = M.edge → + ThroughAgree F (untwistD F N.tail x) + ((genBoundarySubsetMatches_untwistD F N.tail x).mpr hx)) → + (∀ a : UsedLab F, M'.tail a ≠ M.tail a → + W.boundaryFlag a.val ∈ F.throughFlags) → + (∀ a : UsedLab F, W.boundaryFlag a.val ∈ F.throughFlags → + W.boundaryFlag (M.edge a).val ∈ F.throughFlags) → + (∀ a : UsedLab F, W.boundaryFlag a.val ∈ F.throughFlags → + ∃ c : Fin (2 * ℓ), x a.val = Sum.inr c ∧ + x (M.edge a).val = Sum.inr (oddPartner ℓ c)) → + (DirMatching.flipSet M M').card = 2 * n → + F.tFullD h κ o M' x = F.tFullD h κ o M x := by + intro n + induction n with + | zero => + intro M M' he _ _ _ _ hcard + have hempty : DirMatching.flipSet M M' = ∅ := + Finset.card_eq_zero.mp (by omega) + have htail : M'.tail = M.tail := by + funext b + by_contra hb + have hmem : b ∈ DirMatching.flipSet M M' := + DirMatching.mem_flipSet.mpr hb + rw [hempty] at hmem + exact Finset.notMem_empty b hmem + rw [DirMatching.ext he htail] + | succ n ih => + intro M M' he hag hthr hclo hpart hcard + have hpos : (DirMatching.flipSet M M').Nonempty := by + rw [← Finset.card_pos] + omega + obtain ⟨a₀, ha₀⟩ := hpos + -- take the end of the arc that the direction leaves + obtain ⟨a, ha, hta⟩ : + ∃ a, a ∈ DirMatching.flipSet M M' ∧ M.tail a = true := by + by_cases h0 : M.tail a₀ = true + · exact ⟨a₀, ha₀, h0⟩ + · refine ⟨M.edge a₀, DirMatching.edge_mem_flipSet he ha₀, ?_⟩ + rw [M.tail_flip a₀] + cases hb : M.tail a₀ + · rfl + · exact absurd hb h0 + have hthr₁ : W.boundaryFlag a.val ∈ F.throughFlags := + hthr a (DirMatching.mem_flipSet.mp ha) + have hthr₂ : W.boundaryFlag (M.edge a).val ∈ F.throughFlags := + hclo a hthr₁ + obtain ⟨c, hc, hc'⟩ := hpart a hthr₁ + have hbnd := (genBoundarySubsetMatches_untwistD F M.tail x).mpr hx + have hbnd' := (genBoundarySubsetMatches_untwistD F + (M.reverseArc a).tail x).mpr hx + have hstep := tFullD_reverseArc F h κ o M a x hthr₁ hthr₂ hta hc + hc' hbnd hbnd' (hag M rfl) + (hag (M.reverseArc a) rfl) + have hea : M.edge a ∈ DirMatching.flipSet M M' := + DirMatching.edge_mem_flipSet he ha + have hsub : ({a, M.edge a} : Finset (UsedLab F)) + ⊆ DirMatching.flipSet M M' := by + intro y hy + rcases Finset.mem_insert.mp hy with rfl | hy + · exact ha + · rw [Finset.mem_singleton.mp hy]; exact hea + have hcard' : (DirMatching.flipSet (M.reverseArc a) M').card + = 2 * n := by + rw [DirMatching.flipSet_reverseArc he ha] + have hh := Finset.card_sdiff_add_card_eq_card hsub + rw [Finset.card_pair (M.edge_ne a).symm] at hh + omega + have hthr' : ∀ b : UsedLab F, + M'.tail b ≠ (M.reverseArc a).tail b → + W.boundaryFlag b.val ∈ F.throughFlags := by + intro b hb + by_cases hbm : b = a ∨ b = M.edge a + · rcases hbm with rfl | rfl + · exact hthr₁ + · exact hthr₂ + · refine hthr b ?_ + rwa [DirMatching.reverseArc_tail, ite_eq_right hbm] at hb + rw [ih (M.reverseArc a) M' he + (fun N hN => hag N hN) hthr' hclo + hpart hcard', hstep] + +/-! ### A through edge's two labels carry partner colours + +The colouring the tensor sums over gives a through edge one colour, +so in the twisted basis its two labels carry partner colours — which +is what RS21's (12) reads at such an edge. It is not an extra +hypothesis: it follows from the agreement the colouring forces. +-/ + +open Classical in +/-- **At a through label the chord is the edge's other end.** -/ +theorem boundaryFlag_chordInv_through [LinearOrder α] {W : Fragment α} + (F : EdgeSubset W) + (κ : F.RelTransitionSystem) {i : α} + (hb : W.boundaryFlag i ∈ F.boundaryFlags) + (hthr : IsThroughLabel F i) : + W.boundaryFlag (chordInv F κ i) + = W.pairing (W.boundaryFlag i) := by + rw [boundaryFlag_chordInv F κ hb] + exact pathMatch_exit_unique κ hb 0 + (fun t ht => absurd ht (by omega)) hthr + +open Classical in +/-- **A through edge's two labels carry partner colours.** -/ +theorem partner_of_throughAgree [LinearOrder α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (κ : F.RelTransitionSystem) (M : DirMatching (UsedLab F)) + (hM : ∀ a : UsedLab F, (M.edge a).val = chordInv F κ a.val) + (x : GenBoundaryState k ℓ α) + (hx : genBoundarySubsetMatches W F.flags x) + (hag : ThroughAgree F (untwistD F M.tail x) + ((genBoundarySubsetMatches_untwistD F M.tail x).mpr hx)) + (a : UsedLab F) (hthr : W.boundaryFlag a.val ∈ F.throughFlags) : + ∃ c : Fin (2 * ℓ), x a.val = Sum.inr c ∧ + x (M.edge a).val = Sum.inr (oddPartner ℓ c) := by + have hbnd := (genBoundarySubsetMatches_untwistD F M.tail x).mpr hx + have hit : IsThroughLabel F a.val := + isThroughLabel_of_mem_throughFlags hthr (W.attach_boundaryFlag _) + have hbp : W.pairing (W.boundaryFlag a.val) ∈ F.boundaryFlags := hit + have hpair := hag (W.boundaryFlag a.val) a.prop hbp + -- the two ends' labels + have hlab : F.boundaryLabel a.prop = a.val := + boundaryLabel_boundaryFlag F a.prop + have hbe : W.boundaryFlag (M.edge a).val + = W.pairing (W.boundaryFlag a.val) := by + rw [hM a] + exact boundaryFlag_chordInv_through F κ a.prop hit + have hlab' : F.boundaryLabel hbp = (M.edge a).val := by + refine W.boundaryFlag_injective ?_ + rw [boundaryFlag_boundaryLabel hbp, hbe] + -- the untwisted colours agree + have hs := usedColour_spec F (untwistD F M.tail x) hbnd a.prop + have hs' := usedColour_spec F (untwistD F M.tail x) hbnd hbp + rw [hlab] at hs + rw [hlab'] at hs' + rw [hpair] at hs' + -- the two directions are opposite + have htf : M.tail (M.edge a) = !M.tail a := M.tail_flip a + obtain ⟨c, hc⟩ := (hx a.val).mp + (mem_flags_of_boundaryFlags F a.prop) + refine ⟨c, hc, ?_⟩ + rw [untwistD_apply_mem F M.tail x a.prop, hc] at hs + rw [untwistD_apply_mem F M.tail x (M.edge a).prop, htf] at hs' + cases hb : M.tail a with + | false => + rw [hb] at hs hs' + simp only [Bool.false_eq_true, ite_false, Bool.not_false, + ite_true] at hs hs' + rw [← hs] at hs' + rcases hxe : x (M.edge a).val with b | d + · rw [hxe] at hs' + exact absurd hs' (by simp) + · rw [hxe] at hs' + have hd : oddPartner ℓ d = c := Sum.inr.inj hs' + rw [← hd, oddPartner_invol ℓ] + | true => + rw [hb] at hs hs' + simp only [ite_true, Bool.not_true, Bool.false_eq_true, + ite_false] at hs hs' + rw [hs', ← hs] + rfl + +open Classical in +/-- **Agreement is a condition on the state alone.** At a through +edge it says the two labels' colours are partners, and reading that +does not need the arc directions: reversing the edge replaces both +ends' colours by their partners at once. -/ +theorem throughAgree_of_partner [LinearOrder α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (κ : F.RelTransitionSystem) (M : DirMatching (UsedLab F)) + (hM : ∀ a : UsedLab F, (M.edge a).val = chordInv F κ a.val) + (x : GenBoundaryState k ℓ α) + (hx : genBoundarySubsetMatches W F.flags x) + (hpart : ∀ (i : α), W.boundaryFlag i ∈ F.boundaryFlags → + IsThroughLabel F i → ∀ c : Fin (2 * ℓ), x i = Sum.inr c → + x (chordInv F κ i) = Sum.inr (oddPartner ℓ c)) : + ThroughAgree F (untwistD F M.tail x) + ((genBoundarySubsetMatches_untwistD F M.tail x).mpr hx) := by + have hbnd := (genBoundarySubsetMatches_untwistD F M.tail x).mpr hx + intro f hb hbp + have hbf : W.boundaryFlag (F.boundaryLabel hb) = f := + boundaryFlag_boundaryLabel hb + have hbi : W.boundaryFlag (F.boundaryLabel hb) ∈ F.boundaryFlags := by + rw [hbf]; exact hb + have hit : IsThroughLabel F (F.boundaryLabel hb) := by + unfold IsThroughLabel + rw [hbf]; exact hbp + have hj : W.boundaryFlag (chordInv F κ (F.boundaryLabel hb)) + ∈ F.boundaryFlags := chordInv_mem F κ hbi + have hbe : W.boundaryFlag (chordInv F κ (F.boundaryLabel hb)) + = W.pairing (W.boundaryFlag (F.boundaryLabel hb)) := + boundaryFlag_chordInv_through F κ hbi hit + have hlab' : F.boundaryLabel hbp + = chordInv F κ (F.boundaryLabel hb) := by + refine W.boundaryFlag_injective ?_ + rw [boundaryFlag_boundaryLabel hbp, hbe, hbf] + obtain ⟨c, hc⟩ := (hx (F.boundaryLabel hb)).mp + (mem_flags_of_boundaryFlags F hbi) + have hcj : x (chordInv F κ (F.boundaryLabel hb)) + = Sum.inr (oddPartner ℓ c) := + hpart (F.boundaryLabel hb) hbi hit c hc + have hs := usedColour_spec F (untwistD F M.tail x) hbnd hb + have hs' := usedColour_spec F (untwistD F M.tail x) hbnd hbp + rw [hlab'] at hs' + have hedge' : M.edge ⟨F.boundaryLabel hb, hbi⟩ + = ⟨chordInv F κ (F.boundaryLabel hb), hj⟩ := + Subtype.ext (hM ⟨F.boundaryLabel hb, hbi⟩) + have htf' : M.tail ⟨chordInv F κ (F.boundaryLabel hb), hj⟩ + = !M.tail ⟨F.boundaryLabel hb, hbi⟩ := by + rw [← hedge'] + exact M.tail_flip _ + rw [untwistD_apply_mem F M.tail x hbi, hc] at hs + rw [untwistD_apply_mem F M.tail x hj, hcj, htf'] at hs' + cases hb0 : M.tail ⟨F.boundaryLabel hb, hbi⟩ with + | false => + simp only [hb0, Bool.false_eq_true, ite_false, Bool.not_false, + ite_true, Sum.map_inr, oddPartner_invol] at hs hs' + exact (Sum.inr.inj hs').symm.trans (Sum.inr.inj hs) + | true => + simp only [hb0, ite_true, Bool.not_true, Bool.false_eq_true, + ite_false, Sum.map_inr] at hs hs' + exact (Sum.inr.inj hs').symm.trans (Sum.inr.inj hs) + +open Classical in +/-- **The agreement does not read the arc directions.** -/ +theorem throughAgree_congr_matching [LinearOrder α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (κ : F.RelTransitionSystem) (M M' : DirMatching (UsedLab F)) + (hM : ∀ a : UsedLab F, (M.edge a).val = chordInv F κ a.val) + (hM' : ∀ a : UsedLab F, (M'.edge a).val = chordInv F κ a.val) + (x : GenBoundaryState k ℓ α) + (hx : genBoundarySubsetMatches W F.flags x) + (hag : ThroughAgree F (untwistD F M.tail x) + ((genBoundarySubsetMatches_untwistD F M.tail x).mpr hx)) : + ThroughAgree F (untwistD F M'.tail x) + ((genBoundarySubsetMatches_untwistD F M'.tail x).mpr hx) := by + refine throughAgree_of_partner F κ M' hM' x hx + (fun i hb hit c hcx => ?_) + obtain ⟨c', hc', hpc⟩ := partner_of_throughAgree F κ M hM x hx hag + ⟨i, hb⟩ (mem_throughFlags_of_isThroughLabel hb hit) + rw [hcx] at hc' + rw [hM ⟨i, hb⟩] at hpc + rw [hpc, Sum.inr.inj hc'] + +/-! ### RS21's step 1, the chain half + +The directions at the chain labels are the chain orientation's own, +and a chain flip reverses exactly one of their arcs at no cost to the +tensor. So the orientation can be chosen to give those labels any +directions the pairing allows — which is half of "we may assume that +`ω₁, κ₁, ω₂, κ₂` are chosen so that the union is Eulerian". +-/ + +open Classical in +/-- **The chain labels' directions can be chosen freely.** -/ +theorem exists_orient_chainAgree [LinearOrder α] [Fintype α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (κ : F.RelTransitionSystem) : + ∀ (n : ℕ) (o : κ.Orientation) (P : DirMatching (UsedLab F)), + P.edge = (cutMatching F κ o).edge → + ((DirMatching.flipSet (cutMatching F κ o) P).filter + (fun a => ¬ IsThroughLabel F a.val)).card = 2 * n → + ∃ o' : κ.Orientation, + (∀ a : UsedLab F, ¬ IsThroughLabel F a.val → + P.tail a = (cutMatching F κ o').tail a) + ∧ (∀ x : GenBoundaryState k ℓ α, + F.tFull h κ o' x = F.tFull h κ o x) := by + intro n + induction n with + | zero => + intro o P _ hcard + refine ⟨o, ?_, fun _ => rfl⟩ + intro a hnt + by_contra hne + have hmem : a ∈ (DirMatching.flipSet (cutMatching F κ o) P).filter + (fun b => ¬ IsThroughLabel F b.val) := + Finset.mem_filter.mpr ⟨DirMatching.mem_flipSet.mpr hne, hnt⟩ + rw [Finset.card_eq_zero.mp (by omega : ((DirMatching.flipSet + (cutMatching F κ o) P).filter + (fun b => ¬ IsThroughLabel F b.val)).card = 0)] at hmem + exact Finset.notMem_empty a hmem + | succ n ih => + intro o P he hcard + have hpos : ((DirMatching.flipSet (cutMatching F κ o) P).filter + (fun b => ¬ IsThroughLabel F b.val)).Nonempty := by + rw [← Finset.card_pos] + omega + obtain ⟨a, ha⟩ := hpos + obtain ⟨haf, hant⟩ := Finset.mem_filter.mp ha + obtain ⟨S, p₁, p₂, hp, hcut⟩ := exists_chainFlip κ o a.prop hant + have hnt' : ¬ IsThroughLabel F + ((cutMatching F κ o).edge a).val := by + intro hx + refine hant ?_ + have := isThroughLabel_chordInv F κ (chordInv_mem F κ a.prop) hx + rwa [chordInv_invol] at this + have haef : (cutMatching F κ o).edge a + ∈ DirMatching.flipSet (cutMatching F κ o) P := + DirMatching.edge_mem_flipSet he haf + have hsub : ({a, (cutMatching F κ o).edge a} : Finset (UsedLab F)) + ⊆ (DirMatching.flipSet (cutMatching F κ o) P).filter + (fun b => ¬ IsThroughLabel F b.val) := by + intro y hy + rcases Finset.mem_insert.mp hy with rfl | hy + · exact ha + · rw [Finset.mem_singleton.mp hy] + exact Finset.mem_filter.mpr ⟨haef, hnt'⟩ + have hcut' : cutMatching F κ (o.portFlip hp) + = (cutMatching F κ o).reverseArc a := hcut + have he' : P.edge = (cutMatching F κ (o.portFlip hp)).edge := by + rw [hcut'] + exact he + have hcard' : ((DirMatching.flipSet + (cutMatching F κ (o.portFlip hp)) P).filter + (fun b => ¬ IsThroughLabel F b.val)).card = 2 * n := by + have hfs : (DirMatching.flipSet + (cutMatching F κ (o.portFlip hp)) P).filter + (fun b => ¬ IsThroughLabel F b.val) + = ((DirMatching.flipSet (cutMatching F κ o) P).filter + (fun b => ¬ IsThroughLabel F b.val)) + \ {a, (cutMatching F κ o).edge a} := by + rw [hcut', DirMatching.flipSet_reverseArc he haf] + ext y + simp only [Finset.mem_filter, Finset.mem_sdiff] + tauto + have hh : (((DirMatching.flipSet (cutMatching F κ o) P).filter + (fun b => ¬ IsThroughLabel F b.val)) + \ {a, (cutMatching F κ o).edge a}).card + 2 + = ((DirMatching.flipSet (cutMatching F κ o) P).filter + (fun b => ¬ IsThroughLabel F b.val)).card := by + have h0 := Finset.card_sdiff_add_card_eq_card hsub + rwa [Finset.card_pair + ((cutMatching F κ o).edge_ne a).symm] at h0 + rw [hfs] + omega + obtain ⟨o', hagree, hval⟩ := ih (o.portFlip hp) P he' hcard' + refine ⟨o', hagree, fun x => (hval x).trans ?_⟩ + exact tFull_portFlip_all F h o hp a.prop rfl hant hnt' x + +open Classical in +/-- **RS21's step 1.** The arc directions can be given any values +the pairing allows, at no cost to the tensor: the chain labels' by +choosing the orientation, the through labels' outright. -/ +theorem exists_orient_tFullD [LinearOrder α] [Fintype α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (κ : F.RelTransitionSystem) + (o : κ.Orientation) (P : DirMatching (UsedLab F)) + (hP : ∀ a : UsedLab F, (P.edge a).val = chordInv F κ a.val) : + ∃ o' : κ.Orientation, + (∀ a : UsedLab F, ¬ IsThroughLabel F a.val → + P.tail a = (cutMatching F κ o').tail a) ∧ + ∀ x : GenBoundaryState k ℓ α, + F.tFullD h κ o' P x = F.tFull h κ o x := by + have hedge : ∀ õ : κ.Orientation, P.edge = (cutMatching F κ õ).edge := + fun _ => funext (fun a => Subtype.ext (hP a)) + have hnt' : ∀ (õ : κ.Orientation) (y : UsedLab F), + ¬ IsThroughLabel F y.val → + ¬ IsThroughLabel F ((cutMatching F κ õ).edge y).val := by + intro _ y hy hxx + refine hy ?_ + have hz := isThroughLabel_chordInv F κ (chordInv_mem F κ y.prop) hxx + rwa [chordInv_invol] at hz + have hthrough : ∀ (õ : κ.Orientation) (a : UsedLab F), + W.boundaryFlag a.val ∈ F.throughFlags → + W.boundaryFlag ((cutMatching F κ õ).edge a).val + ∈ F.throughFlags := by + intro _ a hthr + exact mem_throughFlags_of_isThroughLabel (chordInv_mem F κ a.prop) + (isThroughLabel_chordInv F κ a.prop + (isThroughLabel_of_mem_throughFlags hthr + (W.attach_boundaryFlag _))) + obtain ⟨n, hn⟩ : ∃ n, ((DirMatching.flipSet + (cutMatching F κ o) P).filter + (fun a => ¬ IsThroughLabel F a.val)).card = 2 * n := by + obtain ⟨r, hr⟩ := even_card_of_involution + ((DirMatching.flipSet (cutMatching F κ o) P).filter + (fun a => ¬ IsThroughLabel F a.val)) + (cutMatching F κ o).edge + (fun y hy => Finset.mem_filter.mpr + ⟨DirMatching.edge_mem_flipSet (hedge o) + (Finset.mem_filter.mp hy).1, + hnt' o y (Finset.mem_filter.mp hy).2⟩) + (fun y _ => (cutMatching F κ o).edge_invol y) + (fun y _ => (cutMatching F κ o).edge_ne y) + exact ⟨r, by omega⟩ + obtain ⟨o', hagree, hval⟩ := exists_orient_chainAgree F h κ n o P + (hedge o) hn + refine ⟨o', hagree, fun x => ?_⟩ + by_cases hx : genBoundarySubsetMatches W F.flags x + · by_cases hagP : ThroughAgree F (untwistD F P.tail x) + ((genBoundarySubsetMatches_untwistD F P.tail x).mpr hx) + · obtain ⟨m, hm⟩ := DirMatching.even_card_flipSet (hedge o') + have hagN : ∀ N : DirMatching (UsedLab F), + N.edge = (cutMatching F κ o').edge → + ThroughAgree F (untwistD F N.tail x) + ((genBoundarySubsetMatches_untwistD F N.tail x).mpr hx) := + fun N hN => throughAgree_congr_matching F κ P N hP + (fun a => by rw [hN]; rfl) x hx hagP + refine Eq.trans ?_ (hval x) + refine tFullD_congr_through F h κ o' x hx m + (cutMatching F κ o') P (hedge o') hagN + (fun a hne => mem_throughFlags_of_isThroughLabel a.prop + (by + by_contra hnt + exact hne (hagree a hnt))) + (hthrough o') + (fun a hthr => partner_of_throughAgree F κ + (cutMatching F κ o') (fun _ => rfl) x hx (hagN _ rfl) a + hthr) + (by omega) + · rw [tFullD_eq_zero_of_not_throughAgree F h κ o' P x + ((genBoundarySubsetMatches_untwistD F P.tail x).mpr hx) + hagP, + tFull_eq_zero_of_not_throughAgree F h κ o x + ((genBoundarySubsetMatches_untwistD F + (cutMatching F κ o).tail x).mpr hx) + (fun hy => hagP (throughAgree_congr_matching F κ + (cutMatching F κ o) P (fun _ => rfl) hP x hx hy))] + · rw [tFullD_eq_zero_of_not_matches F h κ o' P x hx, + tFull_eq_zero_of_not_matches F h κ o x hx] + +/-! ### The Eulerian position + +RS21's step 1 asks for directions making `M(ω₁,κ₁) ∪ M(ω₂,κ₂)` +Eulerian, and Lemma 11's repair supplies them. Since the tensor does +not read the directions beyond their pairing, they can be imposed on +both sides at once. +-/ + +/-- The two subsets' used labels, identified by the interface. -/ +def usedLabInterfaceEquiv {t : ℕ} {W₁ W₂ : Fragment (Fin t)} + (F₁ : EdgeSubset W₁) (F₂ : EdgeSubset W₂) + (hused : ∀ i : Fin t, W₁.boundaryFlag i ∈ F₁.boundaryFlags + ↔ W₂.boundaryFlag i ∈ F₂.boundaryFlags) : + UsedLab F₁ ≃ UsedLab F₂ := + Equiv.subtypeEquivRight hused + +open Classical in +/-- **The two subsets' arc directions can be put in Eulerian +position**, keeping the pairings. -/ +theorem exists_eulerianPosition {t : ℕ} {W₁ W₂ : Fragment (Fin t)} + (F₁ : EdgeSubset W₁) (F₂ : EdgeSubset W₂) + (κ₁ : F₁.RelTransitionSystem) (o₁ : κ₁.Orientation) + (κ₂ : F₂.RelTransitionSystem) (o₂ : κ₂.Orientation) + (hused : ∀ i : Fin t, W₁.boundaryFlag i ∈ F₁.boundaryFlags + ↔ W₂.boundaryFlag i ∈ F₂.boundaryFlags) : + ∃ (M₁ : DirMatching (UsedLab F₁)) (M₂ : DirMatching (UsedLab F₂)), + (∀ a : UsedLab F₁, (M₁.edge a).val = chordInv F₁ κ₁ a.val) ∧ + (∀ b : UsedLab F₂, (M₂.edge b).val = chordInv F₂ κ₂ b.val) ∧ + (∀ a : UsedLab F₁, + M₂.tail (usedLabInterfaceEquiv F₁ F₂ hused a) + = !M₁.tail a) := by + set e := usedLabInterfaceEquiv F₁ F₂ hused with he + obtain ⟨A, B, hAe, hBe, hAB⟩ := + DirMatching.exists_alternating_repair (cutMatching F₁ κ₁ o₁) + ((cutMatching F₂ κ₂ o₂).map e.symm) + refine ⟨A, B.map e, fun a => ?_, fun b => ?_, fun a => ?_⟩ + · exact congrArg Subtype.val (congrFun hAe a) + · change (e (B.edge (e.symm b))).val = _ + rw [congrFun hBe (e.symm b)] + change (e (e.symm ((cutMatching F₂ κ₂ o₂).edge + (e (e.symm b))))).val = _ + rw [e.apply_symm_apply, e.apply_symm_apply] + rfl + · change B.tail (e.symm (e a)) = _ + rw [e.symm_apply_apply] + exact hAB a + +open Classical in +/-- **RS21's (13), with the directions discharged.** Step 1 supplies +the Eulerian position and the tensor does not see it, so the pairing +of the two fragments' tensors is the two colouring sums against the +sign bookkeeping, with no hypothesis on the directions. -/ +theorem exists_sum_sum_superForm_tFull {t : ℕ} + {W₁ W₂ : Fragment (Fin t)} (F₁ : EdgeSubset W₁) + (F₂ : EdgeSubset W₂) {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (κ₁ : F₁.RelTransitionSystem) (o₁ : κ₁.Orientation) + (κ₂ : F₂.RelTransitionSystem) (o₂ : κ₂.Orientation) (m : ℕ) + (hcard₁ : Fintype.card (UsedLab F₁) = 2 * m) + (hcard₂ : Fintype.card (UsedLab F₂) = 2 * m) + (hused : ∀ i : Fin t, W₁.boundaryFlag i ∈ F₁.boundaryFlags + ↔ W₂.boundaryFlag i ∈ F₂.boundaryFlags) : + ∃ (o₁' : κ₁.Orientation) (o₂' : κ₂.Orientation) + (M₁ : DirMatching (UsedLab F₁)) + (M₂ : DirMatching (UsedLab F₂)), + (∀ a : UsedLab F₁, (M₁.edge a).val = chordInv F₁ κ₁ a.val) ∧ + (∀ b : UsedLab F₂, (M₂.edge b).val = chordInv F₂ κ₂ b.val) ∧ + (∀ a : UsedLab F₁, M₂.tail (usedLabInterfaceEquiv F₁ F₂ hused a) + = !M₁.tail a) ∧ + (∀ a : UsedLab F₁, ¬ IsThroughLabel F₁ a.val → + M₁.tail a = (cutMatching F₁ κ₁ o₁').tail a) ∧ + (∀ b : UsedLab F₂, ¬ IsThroughLabel F₂ b.val → + M₂.tail b = (cutMatching F₂ κ₂ o₂').tail b) ∧ + (∀ a : UsedLab F₁, ¬ IsThroughLabel F₁ a.val → + ¬ IsThroughLabel F₂ + (usedLabInterfaceEquiv F₁ F₂ hused a).val → + (cutMatching F₂ κ₂ o₂').tail + (usedLabInterfaceEquiv F₁ F₂ hused a) + = !(cutMatching F₁ κ₁ o₁').tail a) ∧ + (∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * F₁.tFull h κ₁ o₁ x + * F₂.tFull h κ₂ o₂ y) + = (((DirMatching.sgnRel + (DirMatching.stdMatching (card_usedLab_eq F₁ M₁)) M₁ + : ℤ) : ℂ) * ((-1 : ℂ) ^ κ₁.openCircuitCount) + * (((DirMatching.sgnRel + (DirMatching.stdMatching (card_usedLab_eq F₂ M₂)) M₂ + : ℤ) : ℂ) * ((-1 : ℂ) ^ κ₂.openCircuitCount))) + * ∑ st : GenBoundaryState k ℓ (Fin t), + pairAgreeValue F₁ F₂ h o₁' o₂' st := by + obtain ⟨M₁, M₂, hM₁, hM₂, halt⟩ := + exists_eulerianPosition F₁ F₂ κ₁ o₁ κ₂ o₂ hused + obtain ⟨o₁', hag₁, hval₁⟩ := exists_orient_tFullD F₁ h κ₁ o₁ M₁ hM₁ + obtain ⟨o₂', hag₂, hval₂⟩ := exists_orient_tFullD F₂ h κ₂ o₂ M₂ hM₂ + refine ⟨o₁', o₂', M₁, M₂, hM₁, hM₂, halt, hag₁, hag₂, + fun a h1 h2 => ?_, ?_⟩ + · rw [← hag₂ _ h2, ← hag₁ a h1] + exact halt a + rw [show (∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * F₁.tFull h κ₁ o₁ x * F₂.tFull h κ₂ o₂ y) + = ∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * F₁.tFullD h κ₁ o₁' M₁ x + * F₂.tFullD h κ₂ o₂' M₂ y from by + refine Finset.sum_congr rfl (fun x _ => Finset.sum_congr rfl + (fun y _ => ?_)) + rw [hval₁ x, hval₂ y]] + refine sum_sum_superForm_tFullD F₁ F₂ h o₁' M₁ o₂' M₂ m hcard₁ + hcard₂ hused (fun i hi => ?_) + have hi₂ : W₂.boundaryFlag i ∈ F₂.boundaryFlags := (hused i).mp hi + change (if hb : W₂.boundaryFlag i ∈ F₂.boundaryFlags then + M₂.tail ⟨i, hb⟩ else false) + = !(if hb : W₁.boundaryFlag i ∈ F₁.boundaryFlags then + M₁.tail ⟨i, hb⟩ else false) + rw [dite_eq_left hi₂, dite_eq_left hi] + exact halt ⟨i, hi⟩ + +/-! ### The fragment's tensor + +Summing the normalised tensors over the Eulerian subsets gives the +fragment's own tensor, at the transition data each subset's +canonical data provide. Any choice of data serves, by the +invariance under reversing a trail. +-/ + +open Classical in +/-- **The fragment's tensor**: `Σ_H t_h(F,H,ω_H,κ_H)`. -/ +noncomputable def _root_.RS.tensorSum [LinearOrder α] [Fintype α] + (V : Fragment α) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (x : GenBoundaryState k ℓ α) : ℂ := + ∑ s : Finset V.Flag, + if hc : ∀ f ∈ s, V.pairing f ∈ s then + if _hE : (EdgeSubset.mk s hc).Eulerian then + if hne : Nonempty (EdgeSubset.mk s hc).CanonData then + (EdgeSubset.mk s hc).tFull h (Classical.choice hne).1 + (Classical.choice hne).2.val x + else 0 + else 0 + else 0 + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelTransition.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelTransition.lean new file mode 100644 index 0000000000..e5e9c784b5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelTransition.lean @@ -0,0 +1,365 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition + +/-! +# Boundary-relative transition systems + +For an open fragment `W : Fragment α` and an Eulerian edge +subset that may contain boundary-attached flags, the standard +`TransitionSystem` is too strong: it requires every participating +flag to be internally attached (`attach_internal`). This file +defines a weaker notion. + +## Design + +A `RelTransitionSystem W F` for an edge subset `F : EdgeSubset W` +matches the *internal* participating flags pairwise at common +vertices, leaving boundary-attached flags unmatched (they are path +endpoints). + +The walk permutation `κ ∘ σ` is well-defined only on internal flags. +Internal circuits are the orbits of this internal walk permutation. + +Paths connect boundary flags in pairs: starting from a boundary flag +`b`, follow the edge pairing `σ` to the partner `σ b` (internal), +then apply matching `κ`, then `σ` again, alternating until reaching +another boundary flag. The resulting pairing is `pathMatch`. + +### Representation choice for the gluing theorem + +The path matching is an involution on boundary s-flags. For the +eventual gluing decomposition: + + `circuitCount(glued) = internalCircuitCount(F) + + internalCircuitCount(G) + cycleCount(pathMatch_G ∘ pathMatch_F)` + +the composition of two path matchings produces closed cycles that +become "cross-boundary" circuits. Representing `pathMatch` as an +involution on boundary flags makes this composition natural. + +For a closed fragment (no boundary flags), `RelTransitionSystem` +degenerates to `TransitionSystem` and `internalCircuitCount` equals +`circuitCount`. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} + +namespace EdgeSubset + +variable {W : Fragment α} + +/-! ## Internal vs boundary flag classification -/ + +open scoped Classical in +/-- The internal flags of an edge subset: participating flags attached +to a vertex. -/ +noncomputable def internalFlags (F : EdgeSubset W) : Finset W.Flag := + F.flags.filter (fun f => ∃ v : W.Vertex, W.attach f = Sum.inl v) + +open scoped Classical in +/-- A flag is internal exactly when it is in the subset and attached +to a vertex. -/ +theorem mem_internalFlags_iff {f : W.Flag} {F : EdgeSubset W} : + f ∈ F.internalFlags ↔ f ∈ F.flags ∧ + ∃ v : W.Vertex, W.attach f = Sum.inl v := + Finset.mem_filter + +open scoped Classical in +/-- The boundary flags of an edge subset: participating flags attached +to a boundary label. -/ +noncomputable def boundaryFlags (F : EdgeSubset W) : Finset W.Flag := + F.flags.filter (fun f => ∃ i : α, W.attach f = Sum.inr i) + +open scoped Classical in +/-- Every participating flag is either internal or boundary. -/ +theorem mem_internalFlags_or_boundaryFlags (F : EdgeSubset W) + {f : W.Flag} (hf : f ∈ F.flags) : + f ∈ F.internalFlags ∨ f ∈ F.boundaryFlags := by + rcases ha : W.attach f with v | i + · left; exact Finset.mem_filter.mpr ⟨hf, v, ha⟩ + · right; exact Finset.mem_filter.mpr ⟨hf, i, ha⟩ + +/-- Internal and boundary flags are disjoint. -/ +theorem internalFlags_disjoint_boundaryFlags (F : EdgeSubset W) : + Disjoint F.internalFlags F.boundaryFlags := by + classical + unfold internalFlags boundaryFlags + rw [Finset.disjoint_filter] + intro f _ ⟨v, hv⟩ ⟨i, hi⟩ + rw [hv] at hi; cases hi + +open scoped Classical in +/-- An internal flag is in the edge subset. -/ +theorem mem_flags_of_internalFlags (F : EdgeSubset W) {f : W.Flag} + (hf : f ∈ F.internalFlags) : f ∈ F.flags := + (Finset.mem_filter.mp hf).1 + +open scoped Classical in +/-- A boundary flag is in the edge subset. -/ +theorem mem_flags_of_boundaryFlags (F : EdgeSubset W) {f : W.Flag} + (hf : f ∈ F.boundaryFlags) : f ∈ F.flags := + (Finset.mem_filter.mp hf).1 + +open scoped Classical in +/-- An internal flag is attached to some vertex. -/ +theorem attach_internal_of_mem (F : EdgeSubset W) {f : W.Flag} + (hf : f ∈ F.internalFlags) : ∃ v : W.Vertex, W.attach f = Sum.inl v := + (Finset.mem_filter.mp hf).2 + +open scoped Classical in +/-- A boundary flag is attached to some label. -/ +theorem attach_boundary_of_mem (F : EdgeSubset W) {f : W.Flag} + (hf : f ∈ F.boundaryFlags) : ∃ i : α, W.attach f = Sum.inr i := + (Finset.mem_filter.mp hf).2 + +/-- A participating boundary flag lies in the boundary flags: it +attaches to a label, so it cannot be internal. -/ +theorem boundaryFlag_mem_boundaryFlags {F : EdgeSubset W} {a : α} + (hf : W.boundaryFlag a ∈ F.flags) : + W.boundaryFlag a ∈ F.boundaryFlags := by + rcases mem_internalFlags_or_boundaryFlags F hf with hint | hbd + · obtain ⟨v, hv⟩ := attach_internal_of_mem F hint + rw [W.attach_boundaryFlag a] at hv + cases hv + · exact hbd + +/-- All participating flags are internal (no boundary flags). -/ +def allInternal (F : EdgeSubset W) : Prop := F.boundaryFlags = ∅ + +/-- When all flags are internal, a participating flag is internal. -/ +theorem mem_internalFlags_of_allInternal {F : EdgeSubset W} + (hall : F.allInternal) {f : W.Flag} (hf : f ∈ F.flags) : + f ∈ F.internalFlags := by + rcases F.mem_internalFlags_or_boundaryFlags hf with h | h + · exact h + · exact absurd h (Finset.eq_empty_iff_forall_notMem.mp hall _) + +/-! ## Boundary-relative transition system -/ + +/-- A boundary-relative transition system on an edge subset: a +fixed-point-free involution of its *internal* flags matching flags at +a common vertex. Boundary flags are path endpoints and are not +matched. This mirrors `TransitionSystem` but restricts the domain +from all participating flags to internal flags only. -/ +structure RelTransitionSystem (F : EdgeSubset W) where + /-- The matching, defined on all flags but only meaningful on + internal participating flags. -/ + match_ : W.Flag → W.Flag + /-- The matching is an involution on the internal flags. -/ + match_invol : ∀ f ∈ F.internalFlags, match_ (match_ f) = f + /-- The matching has no fixed points on internal flags. -/ + match_ne : ∀ f ∈ F.internalFlags, match_ f ≠ f + /-- The matching maps internal flags to internal flags. -/ + match_mem : ∀ f ∈ F.internalFlags, match_ f ∈ F.internalFlags + /-- Matched flags share an internal vertex. -/ + match_vertex : ∀ f ∈ F.internalFlags, ∀ v : W.Vertex, + W.attach f = Sum.inl v → W.attach (match_ f) = Sum.inl v + +/-! ## Compatibility: conversions -/ + +open scoped Classical in +/-- A participating flag that is internally attached is an internal +flag. -/ +theorem mem_internalFlags_of {F : EdgeSubset W} {f : W.Flag} + (hf : f ∈ F.flags) (hv : ∃ v : W.Vertex, W.attach f = Sum.inl v) : + f ∈ F.internalFlags := by + exact Finset.mem_filter.mpr ⟨hf, hv⟩ + +open scoped Classical in +/-- Every `TransitionSystem` is a `RelTransitionSystem`. -/ +def TransitionSystem.toRelTransitionSystem {F : EdgeSubset W} + (κ : F.TransitionSystem) : F.RelTransitionSystem where + match_ := κ.match_ + match_invol := fun f hf => κ.match_invol f (mem_flags_of_internalFlags F hf) + match_ne := fun f hf => κ.match_ne f (mem_flags_of_internalFlags F hf) + match_mem := fun f hf => by + have hf' := mem_flags_of_internalFlags F hf + refine Finset.mem_filter.mpr ⟨κ.match_mem f hf', ?_⟩ + obtain ⟨v, hv⟩ := attach_internal_of_mem F hf + exact ⟨v, κ.match_vertex f hf' v hv⟩ + match_vertex := fun f hf => κ.match_vertex f (mem_flags_of_internalFlags F hf) + +/-! ## Walk and circuit count on internal flags -/ + +/-- The walk map on flags via a relative transition: follow pairing +then matching. -/ +noncomputable def RelTransitionSystem.internalWalk {F : EdgeSubset W} + (κ : F.RelTransitionSystem) (f : W.Flag) : W.Flag := + κ.match_ (W.pairing f) + +/-- If a flag's pairing is internal, its walk successor is internal. -/ +theorem RelTransitionSystem.internalWalk_mem {F : EdgeSubset W} + (κ : F.RelTransitionSystem) {f : W.Flag} + (hp : W.pairing f ∈ F.internalFlags) : + κ.internalWalk f ∈ F.internalFlags := + κ.match_mem _ hp + +/-- The walk map is injective on flags whose pairings are internal. -/ +theorem RelTransitionSystem.internalWalk_injOn {F : EdgeSubset W} + (κ : F.RelTransitionSystem) {f g : W.Flag} + (hpf : W.pairing f ∈ F.internalFlags) + (hpg : W.pairing g ∈ F.internalFlags) + (h : κ.internalWalk f = κ.internalWalk g) : f = g := by + have h' : κ.match_ (W.pairing f) = κ.match_ (W.pairing g) := h + have h1 := κ.match_invol _ hpf + have h2 := κ.match_invol _ hpg + have hm : W.pairing f = W.pairing g := + calc W.pairing f = κ.match_ (κ.match_ (W.pairing f)) := h1.symm + _ = κ.match_ (κ.match_ (W.pairing g)) := by rw [h'] + _ = W.pairing g := h2 + calc f = W.pairing (W.pairing f) := (W.pairing_invol f).symm + _ = W.pairing (W.pairing g) := by rw [hm] + _ = g := W.pairing_invol g + +/-- When all flags are internal, the pairing of an internal flag is +internal. -/ +theorem RelTransitionSystem.pairing_internal_of_allInternal + {F : EdgeSubset W} (_κ : F.RelTransitionSystem) + (hall : F.allInternal) {f : W.Flag} (hf : f ∈ F.internalFlags) : + W.pairing f ∈ F.internalFlags := + mem_internalFlags_of_allInternal hall (F.pairing_mem f + (mem_flags_of_internalFlags F hf)) + +/-- When all flags are internal, the walk preserves internal flags. -/ +theorem RelTransitionSystem.internalWalk_mem_of_allInternal + {F : EdgeSubset W} (κ : F.RelTransitionSystem) + (hall : F.allInternal) {f : W.Flag} (hf : f ∈ F.internalFlags) : + κ.internalWalk f ∈ F.internalFlags := + κ.internalWalk_mem (κ.pairing_internal_of_allInternal hall hf) + +/-- When all flags are internal, the walk is injective. -/ +theorem RelTransitionSystem.internalWalk_injOn_of_allInternal + {F : EdgeSubset W} (κ : F.RelTransitionSystem) + (hall : F.allInternal) {f g : W.Flag} + (hf : f ∈ F.internalFlags) (hg : g ∈ F.internalFlags) + (h : κ.internalWalk f = κ.internalWalk g) : f = g := + κ.internalWalk_injOn + (κ.pairing_internal_of_allInternal hall hf) + (κ.pairing_internal_of_allInternal hall hg) h + +/-- The walk permutation on internal flags, when all flags are +internal. -/ +noncomputable def RelTransitionSystem.walkPermInternal + {F : EdgeSubset W} (κ : F.RelTransitionSystem) + (hall : F.allInternal) : + Equiv.Perm {f : W.Flag // f ∈ F.internalFlags} := + Equiv.ofBijective + (fun f => ⟨κ.internalWalk f.val, + κ.internalWalk_mem_of_allInternal hall f.prop⟩) + (Finite.injective_iff_bijective.mp + (fun f g h => Subtype.ext + (κ.internalWalk_injOn_of_allInternal hall f.prop g.prop + (congrArg Subtype.val h)))) + +/-- The internal circuit count when all flags are internal. -/ +noncomputable def RelTransitionSystem.internalCircuitCount + {F : EdgeSubset W} (κ : F.RelTransitionSystem) + (hall : F.allInternal) : ℕ := + ((κ.walkPermInternal hall).cycleType.card + + Fintype.card (Function.fixedPoints (κ.walkPermInternal hall))) / 2 + +/-! ## Compatibility: circuit-count agreement for closed subsets -/ + +open scoped Classical in +/-- When a `TransitionSystem` exists (all flags internal), the internal +flags equal the full flag set. -/ +theorem internalFlags_eq_flags_of_transition {F : EdgeSubset W} + (κ : F.TransitionSystem) : F.internalFlags = F.flags := by + ext f; constructor + · exact fun hf => mem_flags_of_internalFlags F hf + · intro hf; exact Finset.mem_filter.mpr ⟨hf, κ.attach_internal f hf⟩ + +/-- A standard `TransitionSystem` implies all flags are internal. -/ +theorem allInternal_of_transition {F : EdgeSubset W} + (κ : F.TransitionSystem) : F.allInternal := by + unfold allInternal + rw [Finset.eq_empty_iff_forall_notMem] + intro f hf + obtain ⟨i, hi⟩ := attach_boundary_of_mem F hf + obtain ⟨v, hv⟩ := κ.attach_internal f (mem_flags_of_boundaryFlags F hf) + rw [hv] at hi; cases hi + +/-- The equivalence between full-flag and internal-flag subtypes when +all flags are internal. -/ +noncomputable def flagsEquivInternal {F : EdgeSubset W} + (κ : F.TransitionSystem) : + {f : W.Flag // f ∈ F.flags} ≃ + {f : W.Flag // f ∈ F.internalFlags} where + toFun f := ⟨f.val, by + rw [internalFlags_eq_flags_of_transition κ]; exact f.prop⟩ + invFun f := ⟨f.val, mem_flags_of_internalFlags F f.prop⟩ + left_inv f := Subtype.ext rfl + right_inv f := Subtype.ext rfl + +/-- The walk permutations agree under the canonical equivalence. -/ +theorem walkPerm_eq_of_transition {F : EdgeSubset W} + (κ : F.TransitionSystem) : + κ.toRelTransitionSystem.walkPermInternal (allInternal_of_transition κ) = + (flagsEquivInternal κ).permCongr κ.walkPerm := by + ext ⟨f, hf⟩ + show (κ.toRelTransitionSystem.walkPermInternal _ ⟨f, hf⟩).val = + ((flagsEquivInternal κ).permCongr κ.walkPerm ⟨f, hf⟩).val + simp only [RelTransitionSystem.walkPermInternal, Equiv.ofBijective_apply, + Equiv.permCongr_apply, flagsEquivInternal] + change κ.match_ (W.pairing f) = κ.walk f + rfl + +/-- **Compatibility**: for a closed-fragment transition system, +`internalCircuitCount` equals `circuitCount`. -/ +theorem relTransition_circuitCount_eq {F : EdgeSubset W} + (κ : F.TransitionSystem) : + κ.toRelTransitionSystem.internalCircuitCount + (allInternal_of_transition κ) = κ.circuitCount := by + unfold RelTransitionSystem.internalCircuitCount + TransitionSystem.circuitCount + rw [walkPerm_eq_of_transition κ, cycleType_permCongr, + card_fixedPoints_permCongr] + +/-! ## Orientation for relative transition systems -/ + +/-- An orientation compatible with a boundary-relative transition +system: an in/out designation of the internal flags, flipped by the +matching and by the edge pairing (when both ends are internal). -/ +structure RelTransitionSystem.Orientation {F : EdgeSubset W} + (κ : F.RelTransitionSystem) where + /-- Whether a flag is outgoing. -/ + isOut : W.Flag → Bool + /-- The matching flips orientation on internal flags. -/ + match_flip : ∀ f ∈ F.internalFlags, isOut (κ.match_ f) = !isOut f + /-- The pairing flips orientation on internal flags whose partner is + also internal. -/ + pairing_flip : ∀ f ∈ F.internalFlags, + W.pairing f ∈ F.internalFlags → + isOut (W.pairing f) = !isOut f + +/-! ## Path chain tracing -/ + +/-- Follow the chain from a flag: apply pairing, check if boundary; +if internal, apply matching and recurse. Returns `none` if the fuel +runs out. -/ +noncomputable def traceChain {F : EdgeSubset W} + (κ : F.RelTransitionSystem) : ℕ → W.Flag → Option W.Flag + | 0, _ => none + | n + 1, f => + let f' := W.pairing f + if f' ∈ F.boundaryFlags then some f' + else if _hf' : f' ∈ F.internalFlags then + traceChain κ n (κ.match_ f') + else none + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelValue.lean new file mode 100644 index 0000000000..2f476073a7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelValue.lean @@ -0,0 +1,90 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelTransition +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GenBoundaryStates + +/-! +# The boundary-relative constrained summand + +The Definition 5 summand re-founded on boundary-relative +transition systems: vertex-local odd lists and signs over a +relative orientation (in-flags at a vertex are automatically +internal), and the state-constrained summand with an abstract +circuit exponent — specialized to the open circuit count when +that lands. For subsets arising from a standard transition +system, the relative data agrees with the original. +-/ + +@[expose] public section + +namespace RS + +variable {α : Type} {W : Fragment α} + +/-! ## Vertex-local data over a relative orientation -/ + +/-- In-flags at a vertex for a boundary-relative orientation: the +participating flags attached to the vertex and marked incoming, in +the fixed enumeration order. -/ +noncomputable def EdgeSubset.relInFlagsAt (F : EdgeSubset W) + {κ : F.RelTransitionSystem} (o : κ.Orientation) + (v : W.Vertex) : List W.Flag := + letI := W.flagOrder + letI := Classical.dec + (F.flags.filter + (fun f => W.attach f = Sum.inl v ∧ o.isOut f = false)).sort + (· ≤ ·) + +/-- An in-flag at a vertex is an internal flag. -/ +theorem EdgeSubset.mem_internal_of_mem_relInFlagsAt + {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {o : κ.Orientation} {v : W.Vertex} {f : W.Flag} + (hf : f ∈ F.relInFlagsAt o v) : f ∈ F.internalFlags := by + let := W.flagOrder + let := Classical.dec + unfold EdgeSubset.relInFlagsAt at hf + have hmem := (Finset.mem_sort (α := W.Flag) (· ≤ ·)).mp hf + have h := Finset.mem_filter.mp hmem + exact mem_internalFlags_of h.1 ⟨v, h.2.1⟩ + +/-! ## Agreement with the standard data -/ + +/-- Transport of an orientation to the relative system. -/ +def EdgeSubset.TransitionSystem.Orientation.toRel + {F : EdgeSubset W} {κ : F.TransitionSystem} + (o : κ.Orientation) : κ.toRelTransitionSystem.Orientation where + isOut := o.isOut + match_flip := fun f hf => + o.match_flip f (mem_flags_of_internalFlags F hf) + pairing_flip := fun f hf _ => + o.pairing_flip f (mem_flags_of_internalFlags F hf) + +/-- Membership in the in-flag list, unfolded. -/ +theorem mem_relInFlagsAt_iff {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + {o : κ.Orientation} {vv : W.Vertex} {f : W.Flag} : + f ∈ F.relInFlagsAt o vv ↔ + f ∈ F.flags ∧ W.attach f = Sum.inl vv ∧ + o.isOut f = false := by + let := W.flagOrder + let := Classical.dec + unfold EdgeSubset.relInFlagsAt + rw [Finset.mem_sort, Finset.mem_filter] + +/-- The in-flag list is `Nodup`. -/ +theorem relInFlagsAt_nodup {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + (o : κ.Orientation) (vv : W.Vertex) : + (F.relInFlagsAt o vv).Nodup := by + let := W.flagOrder + let := Classical.dec + unfold EdgeSubset.relInFlagsAt + exact Finset.sort_nodup _ _ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelChords.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelChords.lean new file mode 100644 index 0000000000..ca49089180 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelChords.lean @@ -0,0 +1,43 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelInvariance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FibreValue + +/-! +# Chord diagrams transport along monotone relabels + +The label chord diagram of a relabeled system is the image of the +original diagram under the order isomorphism, entrywise: the flags +and the path matching are untouched, the labels shift through `e`, +and `e` preserves the sorting. +-/ + +@[expose] public section + +namespace RS + + + +open EdgeSubset + +variable {α β : Type} + +/-- The boundary label shifts through the relabel. -/ +theorem relabel_boundaryLabel + [LinearOrder α] [LinearOrder β] (e : α ≃o β) {W : Fragment α} + (F : EdgeSubset W) {b : W.Flag} + (hb : b ∈ (F.relabelUp e.toEquiv).boundaryFlags) + (hb' : b ∈ F.boundaryFlags) : + (F.relabelUp e.toEquiv).boundaryLabel hb = + e (F.boundaryLabel hb') := + boundaryLabel_eq_of_attach hb + ((relabel_attach_inr_iff e.toEquiv b (F.boundaryLabel hb')).mpr + (attach_boundaryLabel hb')) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelInvariance.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelInvariance.lean new file mode 100644 index 0000000000..e663f0de75 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelInvariance.lean @@ -0,0 +1,622 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonExistence + +/-! +# Monotone relabel invariance of the corrected constrained value + +Transporting a fragment along an order isomorphism of its label +types leaves the corrected state-constrained partition value +unchanged, up to composing the boundary state with the +isomorphism. `Fragment.relabel` keeps the flags, vertices, +pairing, and circles on the nose and only re-decorates the +boundary attachments, so every ingredient of the through value is +transported by identity-shaped conversions; the orientation guard +`i < j` of the through product is preserved because the relabeling +is monotone. + +Both sides of the value are defined by a `Classical.choice` of +relative transition data, so the transport is stated for a value +already pinned to a choice: the relabel carries one side's data to +the other's, and the conversions are identity-shaped. +-/ + +@[expose] public section + +namespace RS + + + +section General + +variable {α β : Type} {W : Fragment α} (ee : α ≃ β) + +/-! ## Attachment decoding under a relabel -/ + +/-- The relabel keeps the pairing. -/ +theorem relabel_pairing_eq : (W.relabel ee).pairing = W.pairing := rfl + +/-- Internal attachment is untouched by a relabel. -/ +theorem relabel_attach_inl_iff (f : W.Flag) (v : W.Vertex) : + (W.relabel ee).attach f = Sum.inl v ↔ W.attach f = Sum.inl v := by + change (W.attach f).map id ⇑ee = Sum.inl v ↔ W.attach f = Sum.inl v + rcases W.attach f with w | i <;> simp + +/-- Boundary attachment is shifted through the equivalence. -/ +theorem relabel_attach_inr_iff (f : W.Flag) (i : α) : + (W.relabel ee).attach f = Sum.inr (ee i) ↔ W.attach f = Sum.inr i := by + change (W.attach f).map id ⇑ee = Sum.inr (ee i) ↔ W.attach f = Sum.inr i + rcases W.attach f with w | j <;> simp + +/-- Being internally attached is invariant under a relabel. -/ +theorem relabel_attach_inl_exists (f : W.Flag) : + (∃ v : W.Vertex, (W.relabel ee).attach f = Sum.inl v) ↔ + (∃ v : W.Vertex, W.attach f = Sum.inl v) := + exists_congr fun v => relabel_attach_inl_iff ee f v + +/-- Being boundary-attached is invariant under a relabel. -/ +theorem relabel_attach_inr_exists (f : W.Flag) : + (∃ b : β, (W.relabel ee).attach f = Sum.inr b) ↔ + (∃ i : α, W.attach f = Sum.inr i) := by + constructor + · rintro ⟨b, hb⟩ + refine ⟨ee.symm b, (relabel_attach_inr_iff ee f (ee.symm b)).mp ?_⟩ + rwa [Equiv.apply_symm_apply] + · rintro ⟨i, hi⟩ + exact ⟨ee i, (relabel_attach_inr_iff ee f i).mpr hi⟩ + +private theorem filter_eq_of_iff {γ : Type} {p q : γ → Prop} + {ip : DecidablePred p} {iq : DecidablePred q} {s t : Finset γ} + (hst : s = t) (h : ∀ x, p x ↔ q x) : + @Finset.filter γ p ip s = @Finset.filter γ q iq t := by + subst hst + ext x + simp only [Finset.mem_filter] + exact and_congr Iff.rfl (h x) + +/-- The relabelled boundary flag at a pushed-forward label. -/ +theorem relabel_boundaryFlag_apply (a : α) : + (W.relabel ee).boundaryFlag (ee a) = W.boundaryFlag a := by + change W.boundaryFlag (ee.symm (ee a)) = W.boundaryFlag a + rw [Equiv.symm_apply_apply] + +/-! ## Edge subsets under a relabel -/ + +/-- Transport of an edge subset along a relabel: the flags and the +pairing are untouched. -/ +def EdgeSubset.relabelUp (F : EdgeSubset W) : EdgeSubset (W.relabel ee) where + flags := F.flags + pairing_mem := fun f hf => F.pairing_mem f hf + +/-- Transport of an edge subset back along a relabel. -/ +def EdgeSubset.relabelDown (F : EdgeSubset (W.relabel ee)) : EdgeSubset W where + flags := F.flags + pairing_mem := fun f hf => F.pairing_mem f hf + +/-- Degrees are untouched by a relabel. -/ +theorem relabelUp_deg (F : EdgeSubset W) (v : W.Vertex) : + (F.relabelUp ee).deg v = F.deg v := by + unfold EdgeSubset.deg + exact congrArg Finset.card + (filter_eq_of_iff rfl fun f => relabel_attach_inl_iff ee f v) + +/-- The Eulerian condition is invariant under a relabel. -/ +theorem relabelUp_eulerian (F : EdgeSubset W) : + (F.relabelUp ee).Eulerian ↔ F.Eulerian := by + unfold EdgeSubset.Eulerian + exact forall_congr' fun v => by rw [relabelUp_deg ee F v] + +/-- The internal flags are untouched by a relabel. -/ +theorem relabelUp_internalFlags (F : EdgeSubset W) : + (F.relabelUp ee).internalFlags = F.internalFlags := by + unfold EdgeSubset.internalFlags + exact filter_eq_of_iff rfl fun f => relabel_attach_inl_exists ee f + +/-- The through flags are untouched by a relabel. -/ +theorem relabelUp_throughFlags (F : EdgeSubset W) : + (F.relabelUp ee).throughFlags = F.throughFlags := by + unfold EdgeSubset.throughFlags + exact filter_eq_of_iff rfl fun f => + and_congr (relabel_attach_inr_exists ee f) + (relabel_attach_inr_exists ee (W.pairing f)) + +/-- The core flags are untouched by a relabel. -/ +theorem relabelUp_coreFlags (F : EdgeSubset W) : + (F.relabelUp ee).coreFlags = F.coreFlags := by + unfold EdgeSubset.coreFlags + rw [relabelUp_throughFlags] + rfl + +/-! ## The boundary-state matching under a relabel -/ + +/-- The subset boundary constraint reindexes through the +equivalence. -/ +theorem relabel_genBoundarySubsetMatches_iff {k ℓ : ℕ} + (s : Finset W.Flag) (st : GenBoundaryState k ℓ β) : + genBoundarySubsetMatches (W.relabel ee) s st ↔ + genBoundarySubsetMatches W s (fun a => st (ee a)) := by + constructor + · intro hm a + have h := hm (ee a) + rw [relabel_boundaryFlag_apply ee a] at h + exact h + · intro hm b + have h := hm (ee.symm b) + simp only [Equiv.apply_symm_apply] at h + exact h + +/-! ## Relative transition systems under a relabel -/ + +/-- Transport of a relative transition system along a relabel. -/ +def relabelTransUp (F : EdgeSubset W) (κ : F.RelTransitionSystem) : + (F.relabelUp ee).RelTransitionSystem where + match_ := κ.match_ + match_invol := fun f hf => + κ.match_invol f (by rwa [relabelUp_internalFlags ee F] at hf) + match_ne := fun f hf => + κ.match_ne f (by rwa [relabelUp_internalFlags ee F] at hf) + match_mem := fun f hf => by + rw [relabelUp_internalFlags ee F] + exact κ.match_mem f (by rwa [relabelUp_internalFlags ee F] at hf) + match_vertex := fun f hf v hv => + (relabel_attach_inl_iff ee _ v).mpr + (κ.match_vertex f (by rwa [relabelUp_internalFlags ee F] at hf) v + ((relabel_attach_inl_iff ee f v).mp hv)) + +/-- Transport of a relative transition system back along a +relabel. -/ +def relabelTransDown (F : EdgeSubset W) + (κ : (F.relabelUp ee).RelTransitionSystem) : F.RelTransitionSystem where + match_ := κ.match_ + match_invol := fun f hf => + κ.match_invol f (by rw [relabelUp_internalFlags ee F]; exact hf) + match_ne := fun f hf => + κ.match_ne f (by rw [relabelUp_internalFlags ee F]; exact hf) + match_mem := fun f hf => by + have h := κ.match_mem f (by rw [relabelUp_internalFlags ee F]; exact hf) + rwa [relabelUp_internalFlags ee F] at h + match_vertex := fun f hf v hv => + (relabel_attach_inl_iff ee _ v).mp + (κ.match_vertex f (by rw [relabelUp_internalFlags ee F]; exact hf) v + ((relabel_attach_inl_iff ee f v).mpr hv)) + +/-- Transport of an orientation along a relabel. -/ +def relabelOrientUp (F : EdgeSubset W) {κ : F.RelTransitionSystem} + (o : κ.Orientation) : (relabelTransUp ee F κ).Orientation where + isOut := o.isOut + match_flip := fun f hf => + o.match_flip f (by rwa [relabelUp_internalFlags ee F] at hf) + pairing_flip := fun f hf hp => + o.pairing_flip f (by rwa [relabelUp_internalFlags ee F] at hf) + (by rwa [relabelUp_internalFlags ee F] at hp) + +/-- Transport of an orientation back along a relabel. -/ +def relabelOrientDown (F : EdgeSubset W) + {κ : (F.relabelUp ee).RelTransitionSystem} (o : κ.Orientation) : + (relabelTransDown ee F κ).Orientation where + isOut := o.isOut + match_flip := fun f hf => + o.match_flip f (by rw [relabelUp_internalFlags ee F]; exact hf) + pairing_flip := fun f hf hp => + o.pairing_flip f (by rw [relabelUp_internalFlags ee F]; exact hf) + (by rw [relabelUp_internalFlags ee F]; exact hp) + +/-! ## The open circuit count under a relabel -/ + +/-- The iterated walk is untouched by a relabel. -/ +theorem relabel_iterWalk (F : EdgeSubset W) (κ : F.RelTransitionSystem) + (f : W.Flag) (n : ℕ) : + EdgeSubset.iterWalk (relabelTransUp ee F κ) f n = + EdgeSubset.iterWalk κ f n := by + induction n with + | zero => rfl + | succ n ih => + change (relabelTransUp ee F κ).match_ ((W.relabel ee).pairing + (EdgeSubset.iterWalk (relabelTransUp ee F κ) f n)) = + κ.match_ (W.pairing (EdgeSubset.iterWalk κ f n)) + rw [ih] + rfl + +/-- The periodic flags are untouched by a relabel. -/ +theorem relabel_periodicFlags (F : EdgeSubset W) + (κ : F.RelTransitionSystem) : + (relabelTransUp ee F κ).periodicFlags = κ.periodicFlags := by + unfold EdgeSubset.RelTransitionSystem.periodicFlags + refine filter_eq_of_iff (relabelUp_internalFlags ee F) fun f => ?_ + constructor + · rintro ⟨n, hn, hcont, hper⟩ + refine ⟨n, hn, fun j hj => ?_, ?_⟩ + · have h := hcont j hj + rw [relabel_iterWalk ee F κ f j, relabelUp_internalFlags ee F] at h + exact h + · have h := hper + rw [relabel_iterWalk ee F κ f n] at h + exact h + · rintro ⟨n, hn, hcont, hper⟩ + refine ⟨n, hn, fun j hj => ?_, ?_⟩ + · rw [relabel_iterWalk ee F κ f j, relabelUp_internalFlags ee F] + exact hcont j hj + · rw [relabel_iterWalk ee F κ f n] + exact hper + +/-- The periodic-flag subtypes agree under a relabel. -/ +noncomputable def relabelPeriodicEquiv (F : EdgeSubset W) + (κ : F.RelTransitionSystem) : + {f : W.Flag // f ∈ (relabelTransUp ee F κ).periodicFlags} ≃ + {f : W.Flag // f ∈ κ.periodicFlags} where + toFun g := ⟨g.val, by + rw [← relabel_periodicFlags ee F κ]; exact g.prop⟩ + invFun g := ⟨g.val, by + rw [relabel_periodicFlags ee F κ]; exact g.prop⟩ + left_inv _ := Subtype.ext rfl + right_inv _ := Subtype.ext rfl + +/-- The periodic walk permutations agree under the canonical +equivalence. -/ +theorem relabel_walkPermPeriodic (F : EdgeSubset W) + (κ : F.RelTransitionSystem) : + (relabelTransUp ee F κ).walkPermPeriodic = + (relabelPeriodicEquiv ee F κ).symm.permCongr κ.walkPermPeriodic := by + ext ⟨f, hf⟩ + simp only [EdgeSubset.RelTransitionSystem.walkPermPeriodic, + Equiv.ofBijective_apply, relabelPeriodicEquiv] + rfl + +/-- The open circuit count is untouched by a relabel. -/ +theorem relabel_openCircuitCount (F : EdgeSubset W) + (κ : F.RelTransitionSystem) : + (relabelTransUp ee F κ).openCircuitCount = κ.openCircuitCount := by + have h1 : (relabelTransUp ee F κ).walkPermPeriodic.cycleType = + κ.walkPermPeriodic.cycleType := by + rw [relabel_walkPermPeriodic ee F κ] + exact cycleType_permCongr _ _ + have h2 : Fintype.card + (Function.fixedPoints ⇑(relabelTransUp ee F κ).walkPermPeriodic) = + Fintype.card (Function.fixedPoints ⇑κ.walkPermPeriodic) := by + rw [relabel_walkPermPeriodic ee F κ] + exact card_fixedPoints_permCongr _ _ + unfold EdgeSubset.RelTransitionSystem.openCircuitCount + exact congrArg₂ (fun (A B : ℕ) => (A + B) / 2) + (congrArg Multiset.card h1) h2 + +/-! ## Colourings under a relabel -/ + +/-- The core odd colourings agree under a relabel, via the equality +of the core flag sets. -/ +noncomputable def coreOddRelabelEquiv (F : EdgeSubset W) (ℓ : ℕ) : + (F.relabelUp ee).CoreOddColouring ℓ ≃ F.CoreOddColouring ℓ where + toFun φ := + ⟨fun f => φ.val ⟨f.val, (relabelUp_coreFlags ee F).symm ▸ f.prop⟩, + fun f => (congrArg φ.val (Subtype.ext rfl)).trans + (φ.prop ⟨f.val, (relabelUp_coreFlags ee F).symm ▸ f.prop⟩)⟩ + invFun φ := + ⟨fun f => φ.val ⟨f.val, (relabelUp_coreFlags ee F) ▸ f.prop⟩, + fun f => (congrArg φ.val (Subtype.ext rfl)).trans + (φ.prop ⟨f.val, (relabelUp_coreFlags ee F) ▸ f.prop⟩)⟩ + left_inv φ := Subtype.ext (funext fun _ => + congrArg φ.val (Subtype.ext rfl)) + right_inv φ := Subtype.ext (funext fun _ => + congrArg φ.val (Subtype.ext rfl)) + +/-- The even-colour multiset at a vertex is untouched by a +relabel. -/ +theorem relabel_evenColoursAt (F : EdgeSubset W) {k : ℕ} + (ψ : (F.relabelUp ee).EvenColouring k) (v : W.Vertex) : + (F.relabelUp ee).evenColoursAt ψ v = F.evenColoursAt ψ v := by + unfold EdgeSubset.evenColoursAt + refine congrArg (Multiset.map _) (congrArg Finset.val ?_) + exact filter_eq_of_iff rfl fun f => relabel_attach_inl_iff ee f.val v + +/-! ## Vertex-local data under a relabel -/ + +/-- The in-flag list at a vertex is untouched by a relabel. -/ +theorem relabel_relInFlagsAt (F : EdgeSubset W) + {κ : F.RelTransitionSystem} (o : κ.Orientation) (v : W.Vertex) : + (F.relabelUp ee).relInFlagsAt (relabelOrientUp ee F o) v = + F.relInFlagsAt o v := by + unfold EdgeSubset.relInFlagsAt + let := (W.relabel ee).flagOrder + let := Classical.dec + exact congrArg + (fun s : Finset (W.relabel ee).Flag => Finset.sort s (· ≤ ·)) + (filter_eq_of_iff rfl fun f => + and_congr (relabel_attach_inl_iff ee f v) Iff.rfl) + +private theorem attachWith_flatMap_congr {δ γ : Type} {P : δ → Prop} + (g : {x : δ // P x} → List γ) {l₁ l₂ : List δ} (hl : l₁ = l₂) + (h₁ : ∀ x ∈ l₁, P x) (h₂ : ∀ x ∈ l₂, P x) : + (l₁.attachWith P h₁).flatMap g = (l₂.attachWith P h₂).flatMap g := by + subst hl; rfl + +private theorem attachWith_map_congr {δ γ : Type} {P : δ → Prop} + (g : {x : δ // P x} → γ) {l₁ l₂ : List δ} (hl : l₁ = l₂) + (h₁ : ∀ x ∈ l₁, P x) (h₂ : ∀ x ∈ l₂, P x) : + (l₁.attachWith P h₁).map g = (l₂.attachWith P h₂).map g := by + subst hl; rfl + +private theorem flatMap_core_relabel {ℓ : ℕ} (F : EdgeSubset W) + (κ : F.RelTransitionSystem) + (φ : (F.relabelUp ee).CoreOddColouring ℓ) (l : List W.Flag) : + ∀ (h1 : ∀ f ∈ l, f ∈ (F.relabelUp ee).internalFlags) + (h2 : ∀ f ∈ l, f ∈ F.internalFlags), + (l.attachWith + (fun x : (W.relabel ee).Flag => + x ∈ (F.relabelUp ee).internalFlags) h1).flatMap + ((F.relabelUp ee).coreOddPairFn (relabelTransUp ee F κ) φ) = + (l.attachWith (fun x : W.Flag => x ∈ F.internalFlags) h2).flatMap + (F.coreOddPairFn κ (coreOddRelabelEquiv ee F ℓ φ)) := by + induction l with + | nil => intro h1 h2; rfl + | cons a as ih => + intro h1 h2 + exact congrArg₂ (· ++ ·) rfl + (ih (fun f hf => h1 f (List.mem_cons_of_mem a hf)) + (fun f hf => h2 f (List.mem_cons_of_mem a hf))) + +private theorem map_sign_relabel {ℓ : ℕ} (F : EdgeSubset W) + (κ : F.RelTransitionSystem) + (φ : (F.relabelUp ee).CoreOddColouring ℓ) (l : List W.Flag) : + ∀ (h1 : ∀ f ∈ l, f ∈ (F.relabelUp ee).internalFlags) + (h2 : ∀ f ∈ l, f ∈ F.internalFlags), + (l.attachWith + (fun x : (W.relabel ee).Flag => + x ∈ (F.relabelUp ee).internalFlags) h1).map + ((F.relabelUp ee).coreOddSignFn (relabelTransUp ee F κ) φ) = + (l.attachWith (fun x : W.Flag => x ∈ F.internalFlags) h2).map + (F.coreOddSignFn κ (coreOddRelabelEquiv ee F ℓ φ)) := by + induction l with + | nil => intro h1 h2; rfl + | cons a as ih => + intro h1 h2 + exact congrArg₂ List.cons rfl + (ih (fun f hf => h1 f (List.mem_cons_of_mem a hf)) + (fun f hf => h2 f (List.mem_cons_of_mem a hf))) + +/-- The vertex odd list is transported by the colouring +equivalence. -/ +theorem relabel_coreOddListAt (F : EdgeSubset W) {ℓ : ℕ} + {κ : F.RelTransitionSystem} (o : κ.Orientation) + (φ : (F.relabelUp ee).CoreOddColouring ℓ) (v : W.Vertex) : + (F.relabelUp ee).coreOddListAt (relabelOrientUp ee F o) φ v = + F.coreOddListAt o (coreOddRelabelEquiv ee F ℓ φ) v := by + have h2 : ∀ f ∈ (F.relabelUp ee).relInFlagsAt (relabelOrientUp ee F o) v, + f ∈ F.internalFlags := by + intro f hf + have h := EdgeSubset.mem_internal_of_mem_relInFlagsAt hf + rwa [relabelUp_internalFlags ee F] at h + refine Eq.trans (flatMap_core_relabel ee F κ φ + ((F.relabelUp ee).relInFlagsAt (relabelOrientUp ee F o) v) + (fun _ hf => EdgeSubset.mem_internal_of_mem_relInFlagsAt hf) h2) ?_ + exact attachWith_flatMap_congr _ (relabel_relInFlagsAt ee F o v) h2 + (fun _ hf => EdgeSubset.mem_internal_of_mem_relInFlagsAt hf) + +/-- The vertex odd sign is transported by the colouring +equivalence. -/ +theorem relabel_coreOddSignAt (F : EdgeSubset W) {ℓ : ℕ} + {κ : F.RelTransitionSystem} (o : κ.Orientation) + (φ : (F.relabelUp ee).CoreOddColouring ℓ) (v : W.Vertex) : + (F.relabelUp ee).coreOddSignAt (relabelOrientUp ee F o) φ v = + F.coreOddSignAt o (coreOddRelabelEquiv ee F ℓ φ) v := by + have h2 : ∀ f ∈ (F.relabelUp ee).relInFlagsAt (relabelOrientUp ee F o) v, + f ∈ F.internalFlags := by + intro f hf + have h := EdgeSubset.mem_internal_of_mem_relInFlagsAt hf + rwa [relabelUp_internalFlags ee F] at h + refine Eq.trans (congrArg List.prod (map_sign_relabel ee F κ φ + ((F.relabelUp ee).relInFlagsAt (relabelOrientUp ee F o) v) + (fun _ hf => EdgeSubset.mem_internal_of_mem_relInFlagsAt hf) h2)) ?_ + exact congrArg List.prod + (attachWith_map_congr _ (relabel_relInFlagsAt ee F o v) h2 + (fun _ hf => EdgeSubset.mem_internal_of_mem_relInFlagsAt hf)) + +/-! ## The boundary colour matches under a relabel -/ + +/-- The even boundary match reindexes through the equivalence. -/ +theorem relabel_genEvenBoundaryMatch_iff (F : EdgeSubset W) {k ℓ : ℕ} + (st : GenBoundaryState k ℓ β) + (hbnd : genBoundarySubsetMatches (W.relabel ee) + (F.relabelUp ee).flags st) + (hbnd' : genBoundarySubsetMatches W F.flags (fun a => st (ee a))) + (ψ : (F.relabelUp ee).EvenColouring k) : + genEvenBoundaryMatch (F.relabelUp ee) st hbnd ψ ↔ + genEvenBoundaryMatch F (fun a => st (ee a)) hbnd' ψ := by + unfold genEvenBoundaryMatch + constructor + · intro hm a c hst + have h := hm (ee a) c hst + exact (congrArg ψ.val (Subtype.ext + (relabel_boundaryFlag_apply ee a).symm)).trans h + · intro hm b c hst + exact hm (ee.symm b) c + (by simp only [Equiv.apply_symm_apply]; exact hst) + +/-- The core odd boundary match reindexes through the equivalence +and the colouring equivalence. -/ +theorem relabel_coreOddBoundaryMatch_iff (F : EdgeSubset W) {k ℓ : ℕ} + (st : GenBoundaryState k ℓ β) + (φ : (F.relabelUp ee).CoreOddColouring ℓ) : + (F.relabelUp ee).coreOddBoundaryMatch st φ ↔ + F.coreOddBoundaryMatch (fun a => st (ee a)) + (coreOddRelabelEquiv ee F ℓ φ) := by + unfold EdgeSubset.coreOddBoundaryMatch + constructor + · intro hm a c hst hcore + have hcore' : (W.relabel ee).boundaryFlag (ee a) ∈ + (F.relabelUp ee).coreFlags := by + rw [relabel_boundaryFlag_apply ee a, relabelUp_coreFlags ee F] + exact hcore + have h := hm (ee a) c hst hcore' + exact (congrArg φ.val (Subtype.ext + (relabel_boundaryFlag_apply ee a).symm)).trans h + · intro hm b c hst hcore + have hcore' : W.boundaryFlag (ee.symm b) ∈ F.coreFlags := by + rw [← relabelUp_coreFlags ee F] + exact hcore + exact hm (ee.symm b) c + (by simp only [Equiv.apply_symm_apply]; exact hst) hcore' + +end General + +section Order + +variable {α β : Type} + +/-! ## The through product under a monotone relabel -/ + +/-- The through product transports along a monotone relabel: the +orientation guard is preserved by monotonicity. -/ +theorem relabel_throughProduct + [LinearOrder α] [LinearOrder β] (e : α ≃o β) {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (st : GenBoundaryState k ℓ β) : + (F.relabelUp e.toEquiv).throughProduct st = + F.throughProduct (fun a => st (e a)) := by + unfold EdgeSubset.throughProduct + refine Finset.prod_bij' + (fun a _ => (⟨a.val, relabelUp_throughFlags e.toEquiv F ▸ a.prop⟩ : + {x // x ∈ F.throughFlags})) + (fun b _ => ⟨b.val, (relabelUp_throughFlags e.toEquiv F).symm ▸ b.prop⟩) + (fun a _ => Finset.mem_attach _ _) (fun b _ => Finset.mem_attach _ _) + (fun a _ => Subtype.ext rfl) (fun b _ => Subtype.ext rfl) + (fun a _ => ?_) + beta_reduce + rw [relabel_pairing_eq e.toEquiv] + rcases ha : W.attach a.val with v | i₀ + · rw [(relabel_attach_inl_iff e.toEquiv a.val v).mpr ha] + · rcases hb : W.attach (W.pairing a.val) with w | j₀ + · rw [(relabel_attach_inr_iff e.toEquiv a.val i₀).mpr ha, + (relabel_attach_inl_iff e.toEquiv (W.pairing a.val) w).mpr hb] + · rw [(relabel_attach_inr_iff e.toEquiv a.val i₀).mpr ha, + (relabel_attach_inr_iff e.toEquiv (W.pairing a.val) j₀).mpr hb] + change (if e.toEquiv i₀ < e.toEquiv j₀ then + throughStateFactor (st (e.toEquiv i₀)) (st (e.toEquiv j₀)) + else 1) = + (if i₀ < j₀ then throughStateFactor (st (e i₀)) (st (e j₀)) + else 1) + exact if_congr e.lt_iff_lt rfl rfl + +/-! ## The through summand and value under a monotone relabel -/ + +open scoped Classical in +/-- The corrected constrained summand transports along a monotone +relabel, at converted transition data. -/ +theorem relabel_throughSummand + [LinearOrder α] [LinearOrder β] (e : α ≃o β) {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ β) + (hbnd : genBoundarySubsetMatches (W.relabel e.toEquiv) + (F.relabelUp e.toEquiv).flags st) + (hbnd' : genBoundarySubsetMatches W F.flags (fun a => st (e a))) + {κ : F.RelTransitionSystem} (o : κ.Orientation) (c : ℕ) : + (F.relabelUp e.toEquiv).throughSummand h st hbnd + (relabelOrientUp e.toEquiv F o) c = + F.throughSummand h (fun a => st (e a)) hbnd' o c := by + unfold EdgeSubset.throughSummand + rw [relabel_throughProduct e F st] + refine congrArg (fun z => (-1 : ℂ) ^ c * + F.throughProduct (fun a => st (e a)) * z) ?_ + refine Fintype.sum_equiv + (Equiv.refl ((F.relabelUp e.toEquiv).EvenColouring k) : + (F.relabelUp e.toEquiv).EvenColouring k ≃ F.EvenColouring k) + _ _ fun ψ => ?_ + simp only [Equiv.refl_apply] + refine if_congr + (relabel_genEvenBoundaryMatch_iff e.toEquiv F st hbnd hbnd' ψ) ?_ rfl + refine Fintype.sum_equiv (coreOddRelabelEquiv e.toEquiv F ℓ) _ _ + fun φ => ?_ + refine if_congr + (relabel_coreOddBoundaryMatch_iff e.toEquiv F st φ) ?_ rfl + refine Finset.prod_congr rfl fun v _ => ?_ + rw [relabel_coreOddSignAt e.toEquiv F o φ v, + relabel_coreOddListAt e.toEquiv F o φ v, + relabel_evenColoursAt e.toEquiv F ψ v] + +end Order + +/-! ## The canonical-value migration + +The corrected constrained value chooses among *path-canonical* +transition data and weights the chosen summand by the chord-crossing +sign. Every ingredient transports along a monotone relabel: the +path matching is untouched (the walk and the flag classification +are), canonicality transports because labels move monotonically, +and the crossing count is invariant because the four chord +endpoints of each pair shift through the order isomorphism, which +preserves every comparison. -/ + +section Canon + +variable {α β : Type} + +open EdgeSubset + +/-- The boundary flags are untouched by a relabel. -/ +theorem relabelUp_boundaryFlags + [LinearOrder α] [LinearOrder β] (e : α ≃o β) {W : Fragment α} + (F : EdgeSubset W) : + (F.relabelUp e.toEquiv).boundaryFlags = F.boundaryFlags := by + unfold EdgeSubset.boundaryFlags + exact filter_eq_of_iff rfl fun f => relabel_attach_inr_exists e.toEquiv f + +/-- The path matching is untouched by a relabel: the transported +walk agrees step by step, so the transported chain data terminate at +the same flag. -/ +theorem relabel_pathMatch + [LinearOrder α] [LinearOrder β] (e : α ≃o β) {W : Fragment α} + (F : EdgeSubset W) (κ : F.RelTransitionSystem) + {b : W.Flag} (hb : b ∈ (F.relabelUp e.toEquiv).boundaryFlags) + (hb' : b ∈ F.boundaryFlags) : + (relabelTransUp e.toEquiv F κ).pathMatch b hb = κ.pathMatch b hb' := by + obtain ⟨k, -, hcont, hpm⟩ := pathMatch_chain_length κ hb' + have hcont' : ∀ t, t < k → + (W.relabel e.toEquiv).pairing + (iterWalk (relabelTransUp e.toEquiv F κ) b t) ∈ + (F.relabelUp e.toEquiv).internalFlags := by + intro t ht + rw [relabel_iterWalk e.toEquiv F κ b t, + relabelUp_internalFlags e.toEquiv F] + exact hcont t ht + have hterm' : (W.relabel e.toEquiv).pairing + (iterWalk (relabelTransUp e.toEquiv F κ) b k) ∈ + (F.relabelUp e.toEquiv).boundaryFlags := by + rw [relabel_iterWalk e.toEquiv F κ b k, + relabelUp_boundaryFlags e F] + exact hpm ▸ κ.pathMatch_mem hb' + rw [pathMatch_eq_of_chain (relabelTransUp e.toEquiv F κ) hb hcont' hterm', + hpm] + exact congrArg (W.relabel e.toEquiv).pairing + (relabel_iterWalk e.toEquiv F κ b k) + +/-- **Canonicality transport**: the transported orientation of a +path-canonical orientation is path-canonical — labels transport +monotonically, and every other ingredient is untouched. -/ +theorem pathCanonical_relabelUp + [LinearOrder α] [LinearOrder β] (e : α ≃o β) {W : Fragment α} + (F : EdgeSubset W) + {κ : F.RelTransitionSystem} {o : κ.Orientation} + (hc : PathCanonical o) : + PathCanonical (relabelOrientUp e.toEquiv F o) := by + intro i j hb hint hpm hij + have hb₀ : W.boundaryFlag (e.toEquiv.symm i) ∈ F.boundaryFlags := by + rw [← relabelUp_boundaryFlags e F] + exact hb + have hint₀ : W.pairing (W.boundaryFlag (e.toEquiv.symm i)) ∈ + F.internalFlags := by + rw [← relabelUp_internalFlags e.toEquiv F] + exact hint + have hpm₀ : κ.pathMatch (W.boundaryFlag (e.toEquiv.symm i)) hb₀ = + W.boundaryFlag (e.toEquiv.symm j) := + (relabel_pathMatch e F κ hb hb₀).symm.trans hpm + have hij₀ : e.toEquiv.symm i < e.toEquiv.symm j := + e.symm.lt_iff_lt.mpr hij + exact hc (e.toEquiv.symm i) (e.toEquiv.symm j) hb₀ hint₀ hpm₀ hij₀ + +end Canon + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RepairInvariance.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RepairInvariance.lean new file mode 100644 index 0000000000..9bd14e447e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RepairInvariance.lean @@ -0,0 +1,924 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionMove +public import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientationFlip + +/-! +# Invariance of the constrained summand under the repair move + +What one elementary 2-opt re-pairing move +(`RelTransitionSystem.repair`) does to the corrected constrained +summand (`throughSummand`). + +## Main results + +* `MixedFunctional.evalOdd_transpose` — transposing two entries of + an odd list (at arbitrary positions) negates the alternating + evaluation, unconditionally. +* `EdgeSubset.openCircuitCount_matchEq` and + `EdgeSubset.throughSummand_ofMatchEq` — matching-equal systems + have equal open circuit counts and equal summands (over the + transported orientation). +* `EdgeSubset.throughSummand_transportRepair` — **the vertex-`v` + ledger**: in the separated case (`isOut c = !isOut a`, where the + orientation transports unchanged), one repair move negates the + constrained summand at every fixed circuit exponent. The two + changed pair-blocks at `v` swap their partner entries — one list + transposition — while the sign factors merely commute. +* `EdgeSubset.throughSummand_repair` — the move preserves the + summand at the open circuit counts whenever the count parity + flips (`Odd (count κ + count κ')`), by the ledger above. + +## Why the count-parity hypothesis is needed + +The count-parity hypothesis of `throughSummand_repair` cannot be +dropped. A move whose four flags lie on two distinct +boundary-terminated paths leaves `openCircuitCount` unchanged while +the ledger still negates the summand, so on such squares the +per-move invariance fails. It fails for the reason orientation +invariance is restricted to differences on fully internal edges +(`throughSummand_orientation_invariant` in `OrientationFlip.lean`): +a two-path square re-pairs which boundary ends chain together, and +the two pairings differ in sign. The +two-path squares are handled instead by the pathSign-corrected +ledger of `PathLedger.lean`, whose statements weigh the summand by +the boundary pairing's chord sign. +-/ + +@[expose] public section + +namespace RS + + + +/-! ## List helpers -/ + +section ListHelpers + +variable {γ δ : Type*} + +/-- Pointwise-equal block functions give equal `flatMap`s. -/ +private theorem flatMap_congr_mem {l : List γ} {g g' : γ → List δ} + (h : ∀ x ∈ l, g x = g' x) : l.flatMap g = l.flatMap g' := by + induction l with + | nil => rfl + | cons a t ih => + rw [List.flatMap_cons, List.flatMap_cons, + h a List.mem_cons_self, + ih (fun x hx => h x (List.mem_cons_of_mem a hx))] + +/-- `attachWith` over propositionally equal lists. -/ +private theorem attachWith_congr {l₁ l₂ : List γ} (h : l₁ = l₂) + {p : γ → Prop} (H₁ : ∀ x ∈ l₁, p x) : + l₁.attachWith p H₁ = l₂.attachWith p (h ▸ H₁) := by + subst h; rfl + +/-- `attachWith` preserves `Nodup`. -/ +private theorem nodup_attachWith {p : γ → Prop} : + ∀ {l : List γ}, l.Nodup → ∀ (H : ∀ x ∈ l, p x), + (l.attachWith p H).Nodup + | [], _, _ => List.nodup_nil + | a :: t, hnd, H => by + rw [List.attachWith_cons, List.nodup_cons] + rw [List.nodup_cons] at hnd + exact ⟨fun hmem => hnd.1 ((List.mem_attachWith _ _).mp hmem), + nodup_attachWith hnd.2 _⟩ + +/-- A list with a repeated element is not `Nodup`. -/ +private theorem not_nodup_two (l₁ l₂ l₃ : List γ) (x : γ) : + ¬ (l₁ ++ x :: (l₂ ++ x :: l₃)).Nodup := by + intro hnd + have h2 : (x :: (l₂ ++ x :: l₃)).Nodup := + (List.nodup_append.mp hnd).2.1 + rw [List.nodup_cons] at h2 + exact h2.1 (List.mem_append_right _ List.mem_cons_self) + +/-- Split a list at two distinct members, in one of the two +orders. -/ +private theorem exists_two_split {l : List γ} {u w : γ} + (hu : u ∈ l) (hw : w ∈ l) (huw : u ≠ w) : + (∃ P Q R, l = P ++ u :: (Q ++ w :: R)) ∨ + (∃ P Q R, l = P ++ w :: (Q ++ u :: R)) := by + obtain ⟨P, t, rfl⟩ := List.append_of_mem hu + rcases List.mem_append.mp hw with hwP | hwt + · obtain ⟨P₁, P₂, rfl⟩ := List.append_of_mem hwP + right + exact ⟨P₁, P₂, t, by simp⟩ + · have hwt' : w ∈ t := by + rcases List.mem_cons.mp hwt with h | h + · exact absurd h.symm huw + · exact h + obtain ⟨Q, R, rfl⟩ := List.append_of_mem hwt' + left + exact ⟨P, Q, R, rfl⟩ + +/-- Distinctness facts from `Nodup` of a two-point split. -/ +private theorem split_facts {P Q R : List γ} {u w : γ} + (hnd : (P ++ u :: (Q ++ w :: R)).Nodup) : + (∀ f ∈ P, f ≠ u ∧ f ≠ w) ∧ (∀ f ∈ Q, f ≠ u ∧ f ≠ w) ∧ + (∀ f ∈ R, f ≠ u ∧ f ≠ w) := by + rw [List.nodup_append] at hnd + obtain ⟨-, hnd2, hdisj⟩ := hnd + rw [List.nodup_cons] at hnd2 + obtain ⟨hu_nin, hnd3⟩ := hnd2 + rw [List.nodup_append] at hnd3 + obtain ⟨-, hnd4, hdisjQ⟩ := hnd3 + rw [List.nodup_cons] at hnd4 + refine ⟨fun f hf => ⟨?_, ?_⟩, fun f hf => ⟨?_, ?_⟩, + fun f hf => ⟨?_, ?_⟩⟩ + · exact hdisj f hf u List.mem_cons_self + · exact hdisj f hf w (List.mem_cons_of_mem _ + (List.mem_append_right _ List.mem_cons_self)) + · intro he + exact hu_nin (List.mem_append_left _ (he ▸ hf)) + · exact hdisjQ f hf w List.mem_cons_self + · intro he + exact hu_nin (List.mem_append_right _ + (List.mem_cons_of_mem _ (he ▸ hf))) + · intro he + exact hnd4.1 (he ▸ hf) + +end ListHelpers + +/-! ## The transposition lemma for the alternating evaluation -/ + +/-- **Transposing two entries** of an odd list, at arbitrary +positions, negates the alternating evaluation. Unconditional: when +the two entries are equal both sides vanish on the duplicate. -/ +theorem MixedFunctional.evalOdd_transpose {k ℓ : ℕ} + (hM : MixedFunctional k ℓ) (μ : Multiset (Fin k)) + (l₂ : List (Fin (2 * ℓ))) : + ∀ (l₁ l₃ : List (Fin (2 * ℓ))) (x y : Fin (2 * ℓ)), + hM.evalOdd μ (l₁ ++ y :: (l₂ ++ x :: l₃)) = + -hM.evalOdd μ (l₁ ++ x :: (l₂ ++ y :: l₃)) := by + induction l₂ with + | nil => + intro l₁ l₃ x y + simp only [List.nil_append] + by_cases hxy : x = y + · subst hxy + have h0 := not_nodup_two l₁ [] l₃ x + simp only [List.nil_append] at h0 + rw [hM.evalOdd_of_not_nodup μ h0, neg_zero] + · exact hM.evalOdd_swap_adjacent μ l₁ l₃ hxy + | cons z l₂' ih => + intro l₁ l₃ x y + simp only [List.cons_append] + by_cases hzy : z = y + · subst hzy + have h1 := not_nodup_two l₁ [] (l₂' ++ x :: l₃) z + simp only [List.nil_append] at h1 + rw [hM.evalOdd_of_not_nodup μ h1] + have h2 := not_nodup_two (l₁ ++ [x]) l₂' l₃ z + simp only [List.append_assoc, List.cons_append, + List.nil_append] at h2 + rw [hM.evalOdd_of_not_nodup μ h2, neg_zero] + · by_cases hzx : z = x + · subst hzx + have h1 := not_nodup_two (l₁ ++ [y]) l₂' l₃ z + simp only [List.append_assoc, List.cons_append, + List.nil_append] at h1 + rw [hM.evalOdd_of_not_nodup μ h1] + have h2 := not_nodup_two l₁ [] (l₂' ++ y :: l₃) z + simp only [List.nil_append] at h2 + rw [hM.evalOdd_of_not_nodup μ h2, neg_zero] + · have hswap1 : + hM.evalOdd μ (l₁ ++ y :: z :: (l₂' ++ x :: l₃)) = + -hM.evalOdd μ (l₁ ++ z :: y :: (l₂' ++ x :: l₃)) := + hM.evalOdd_swap_adjacent μ l₁ (l₂' ++ x :: l₃) hzy + have hih := ih (l₁ ++ [z]) l₃ x y + simp only [List.append_assoc, List.cons_append, + List.nil_append] at hih + have hswap2 : + hM.evalOdd μ (l₁ ++ z :: x :: (l₂' ++ y :: l₃)) = + -hM.evalOdd μ (l₁ ++ x :: z :: (l₂' ++ y :: l₃)) := + hM.evalOdd_swap_adjacent μ l₁ (l₂' ++ y :: l₃) + (fun he => hzx he.symm) + calc hM.evalOdd μ (l₁ ++ y :: z :: (l₂' ++ x :: l₃)) + = -hM.evalOdd μ (l₁ ++ z :: y :: (l₂' ++ x :: l₃)) := + hswap1 + _ = hM.evalOdd μ (l₁ ++ z :: x :: (l₂' ++ y :: l₃)) := by + rw [hih]; ring + _ = -hM.evalOdd μ (l₁ ++ x :: z :: (l₂' ++ y :: l₃)) := + hswap2 + +/-! ## The two-block swap ledger -/ + +section SwapLedger + +variable {γ : Type*} + +/-- **The pair-block swap**: exchanging the second entries of two +pair blocks in a `flatMap` of blocks negates the alternating +evaluation. -/ +private theorem evalOdd_flatMap_swap {k ℓ : ℕ} + (hM : MixedFunctional k ℓ) (μ : Multiset (Fin k)) + (g g' : γ → List (Fin (2 * ℓ))) (u w : γ) (huw : u ≠ w) + (cu cw x y : Fin (2 * ℓ)) + (hgu : g u = [cu, x]) (hgw : g w = [cw, y]) + (hgu' : g' u = [cu, y]) (hgw' : g' w = [cw, x]) + {l : List γ} (hnd : l.Nodup) (hu : u ∈ l) (hw : w ∈ l) + (hoff : ∀ f ∈ l, f ≠ u → f ≠ w → g' f = g f) : + hM.evalOdd μ (l.flatMap g') = -hM.evalOdd μ (l.flatMap g) := by + rcases exists_two_split hu hw huw with + ⟨P, Q, R, rfl⟩ | ⟨P, Q, R, rfl⟩ + · obtain ⟨fP, fQ, fR⟩ := split_facts hnd + have hP : P.flatMap g' = P.flatMap g := + flatMap_congr_mem (fun f hf => + hoff f (by simp [hf]) (fP f hf).1 (fP f hf).2) + have hQ : Q.flatMap g' = Q.flatMap g := + flatMap_congr_mem (fun f hf => + hoff f (by simp [hf]) (fQ f hf).1 (fQ f hf).2) + have hR : R.flatMap g' = R.flatMap g := + flatMap_congr_mem (fun f hf => + hoff f (by simp [hf]) (fR f hf).1 (fR f hf).2) + simp only [List.flatMap_append, List.flatMap_cons] + rw [hgu, hgw, hgu', hgw', hP, hQ, hR] + have key := hM.evalOdd_transpose μ (Q.flatMap g ++ [cw]) + (P.flatMap g ++ [cu]) (R.flatMap g) x y + simp only [List.append_assoc, List.cons_append, + List.nil_append] at key ⊢ + exact key + · obtain ⟨fP, fQ, fR⟩ := split_facts hnd + have hP : P.flatMap g' = P.flatMap g := + flatMap_congr_mem (fun f hf => + hoff f (by simp [hf]) (fP f hf).2 (fP f hf).1) + have hQ : Q.flatMap g' = Q.flatMap g := + flatMap_congr_mem (fun f hf => + hoff f (by simp [hf]) (fQ f hf).2 (fQ f hf).1) + have hR : R.flatMap g' = R.flatMap g := + flatMap_congr_mem (fun f hf => + hoff f (by simp [hf]) (fR f hf).2 (fR f hf).1) + simp only [List.flatMap_append, List.flatMap_cons] + rw [hgu, hgw, hgu', hgw', hP, hQ, hR] + have key := hM.evalOdd_transpose μ (Q.flatMap g ++ [cu]) + (P.flatMap g ++ [cw]) (R.flatMap g) y x + simp only [List.append_assoc, List.cons_append, + List.nil_append] at key ⊢ + exact key + +/-- Swapping two values of a sign function leaves the list product +unchanged. -/ +private theorem prod_map_swap (s s' : γ → ℤ) (u w : γ) + (huw : u ≠ w) (hsu : s' u = s w) (hsw : s' w = s u) + {l : List γ} (hnd : l.Nodup) (hu : u ∈ l) (hw : w ∈ l) + (hoff : ∀ f ∈ l, f ≠ u → f ≠ w → s' f = s f) : + (l.map s').prod = (l.map s).prod := by + rcases exists_two_split hu hw huw with + ⟨P, Q, R, rfl⟩ | ⟨P, Q, R, rfl⟩ + · obtain ⟨fP, fQ, fR⟩ := split_facts hnd + simp only [List.map_append, List.map_cons, List.prod_append, + List.prod_cons] + rw [hsu, hsw, + List.map_congr_left (fun f hf => + hoff f (by simp [hf]) (fP f hf).1 (fP f hf).2), + List.map_congr_left (fun f hf => + hoff f (by simp [hf]) (fQ f hf).1 (fQ f hf).2), + List.map_congr_left (fun f hf => + hoff f (by simp [hf]) (fR f hf).1 (fR f hf).2)] + ring + · obtain ⟨fP, fQ, fR⟩ := split_facts hnd + simp only [List.map_append, List.map_cons, List.prod_append, + List.prod_cons] + rw [hsu, hsw, + List.map_congr_left (fun f hf => + hoff f (by simp [hf]) (fP f hf).2 (fP f hf).1), + List.map_congr_left (fun f hf => + hoff f (by simp [hf]) (fQ f hf).2 (fQ f hf).1), + List.map_congr_left (fun f hf => + hoff f (by simp [hf]) (fR f hf).2 (fR f hf).1)] + ring + +end SwapLedger + +/-! ## Orientation-local congruence for the vertex data -/ + +namespace EdgeSubset + +variable {α : Type} {W : Fragment α} {F : EdgeSubset W} + +/-- The in-flag list depends on the orientation only through +`isOut`. -/ +theorem relInFlagsAt_congr {κ₁ κ₂ : F.RelTransitionSystem} + {o₁ : κ₁.Orientation} {o₂ : κ₂.Orientation} + (hiso : o₁.isOut = o₂.isOut) (vv : W.Vertex) : + F.relInFlagsAt o₁ vv = F.relInFlagsAt o₂ vv := by + let := W.flagOrder + let := Classical.dec + unfold EdgeSubset.relInFlagsAt + have hfil : F.flags.filter + (fun f => W.attach f = Sum.inl vv ∧ o₁.isOut f = false) = + F.flags.filter + (fun f => W.attach f = Sum.inl vv ∧ o₂.isOut f = false) := + Finset.filter_congr (fun f _ => by rw [hiso]) + exact congrArg (fun s : Finset W.Flag => s.sort (· ≤ ·)) hfil + +/-- The pair block at a flag, with the matched value evaluated. -/ +private theorem coreOddPairFn_eq_of_match {ℓ : ℕ} + {κ : F.RelTransitionSystem} (φ : F.CoreOddColouring ℓ) + (f : {f : W.Flag // f ∈ F.internalFlags}) {m : W.Flag} + (hm : κ.match_ f.val = m) (hmi : m ∈ F.coreFlags) : + F.coreOddPairFn κ φ f = + [φ.val ⟨f.val, F.internalFlags_subset_coreFlags f.prop⟩, + oddPartner ℓ (φ.val ⟨m, hmi⟩)] := by + subst hm + rfl + +/-- The sign factor at a flag, with the matched value evaluated. -/ +private theorem coreOddSignFn_eq_of_match {ℓ : ℕ} + {κ : F.RelTransitionSystem} (φ : F.CoreOddColouring ℓ) + (f : {f : W.Flag // f ∈ F.internalFlags}) {m : W.Flag} + (hm : κ.match_ f.val = m) (hmi : m ∈ F.coreFlags) : + F.coreOddSignFn κ φ f = oddPartnerSign ℓ (φ.val ⟨m, hmi⟩) := by + subst hm + rfl + +/-- The vertex odd list depends only on `isOut` and the matching +at internal flags. -/ +theorem coreOddListAt_congr {ℓ : ℕ} + {κ₁ κ₂ : F.RelTransitionSystem} + {o₁ : κ₁.Orientation} {o₂ : κ₂.Orientation} + (hiso : o₁.isOut = o₂.isOut) + (hmatch : ∀ f ∈ F.internalFlags, κ₁.match_ f = κ₂.match_ f) + (φ : F.CoreOddColouring ℓ) (vv : W.Vertex) : + F.coreOddListAt o₁ φ vv = F.coreOddListAt o₂ φ vv := by + unfold EdgeSubset.coreOddListAt + rw [attachWith_congr (relInFlagsAt_congr hiso vv)] + exact flatMap_congr_mem (fun f _ => by + rw [coreOddPairFn_eq_of_match φ f (hmatch f.val f.prop) + (F.internalFlags_subset_coreFlags (κ₂.match_mem _ f.prop)), + coreOddPairFn_eq_of_match φ f rfl + (F.internalFlags_subset_coreFlags (κ₂.match_mem _ f.prop))]) + +/-- The vertex sign depends only on `isOut` and the matching at +internal flags. -/ +theorem coreOddSignAt_congr {ℓ : ℕ} + {κ₁ κ₂ : F.RelTransitionSystem} + {o₁ : κ₁.Orientation} {o₂ : κ₂.Orientation} + (hiso : o₁.isOut = o₂.isOut) + (hmatch : ∀ f ∈ F.internalFlags, κ₁.match_ f = κ₂.match_ f) + (φ : F.CoreOddColouring ℓ) (vv : W.Vertex) : + F.coreOddSignAt o₁ φ vv = F.coreOddSignAt o₂ φ vv := by + unfold EdgeSubset.coreOddSignAt + rw [attachWith_congr (relInFlagsAt_congr hiso vv)] + refine congrArg List.prod + (List.map_congr_left (fun f _ => ?_)) + rw [coreOddSignFn_eq_of_match φ f (hmatch f.val f.prop) + (F.internalFlags_subset_coreFlags (κ₂.match_mem _ f.prop)), + coreOddSignFn_eq_of_match φ f rfl + (F.internalFlags_subset_coreFlags (κ₂.match_mem _ f.prop))] + +/-- The through summand depends only on `isOut`, the matching at +internal flags, and the circuit exponent. -/ +theorem throughSummand_congr [LinearOrder α] {k ℓ : ℕ} + (hM : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ₁ κ₂ : F.RelTransitionSystem} + {o₁ : κ₁.Orientation} {o₂ : κ₂.Orientation} + (hiso : o₁.isOut = o₂.isOut) + (hmatch : ∀ f ∈ F.internalFlags, κ₁.match_ f = κ₂.match_ f) + (n : ℕ) : + F.throughSummand hM st hbnd o₁ n = + F.throughSummand hM st hbnd o₂ n := by + classical + unfold EdgeSubset.throughSummand + refine congrArg _ (Finset.sum_congr rfl (fun ψ _ => ?_)) + refine if_congr Iff.rfl (Finset.sum_congr rfl (fun φ _ => ?_)) rfl + refine if_congr Iff.rfl (Finset.prod_congr rfl (fun vv _ => ?_)) + rfl + rw [coreOddSignAt_congr hiso hmatch φ vv, + coreOddListAt_congr hiso hmatch φ vv] + +/-! ## The MatchEq layer -/ + +/-- Along a `κ₁`-periodic walk, matching-equal systems walk +identically. -/ +theorem iterWalk_matchEq {κ₁ κ₂ : F.RelTransitionSystem} + (heq : κ₁.MatchEq κ₂) {f : W.Flag} + (hper : κ₁.PeriodicFlag f) (j : ℕ) : + iterWalk κ₂ f j = iterWalk κ₁ f j := by + induction j with + | zero => rfl + | succ j ih => + rw [iterWalk_succ, iterWalk_succ, ih] + exact (heq _ (all_pairings_internal_of_periodic κ₁ hper j)).symm + +/-- Periodicity transfers across matching equality. -/ +theorem RelTransitionSystem.PeriodicFlag.matchEq + {κ₁ κ₂ : F.RelTransitionSystem} (heq : κ₁.MatchEq κ₂) + {f : W.Flag} (hper : κ₁.PeriodicFlag f) : + κ₂.PeriodicFlag f := by + obtain ⟨hint, n, hn1, hcont, hperiod⟩ := hper + have hper' : κ₁.PeriodicFlag f := ⟨hint, n, hn1, hcont, hperiod⟩ + refine ⟨hint, n, hn1, fun j hj => ?_, ?_⟩ + · rw [iterWalk_matchEq heq hper' j] + exact hcont j hj + · rw [iterWalk_matchEq heq hper' n] + exact hperiod + +/-- Matching-equal systems have the same periodic flags. -/ +theorem periodicFlags_matchEq {κ₁ κ₂ : F.RelTransitionSystem} + (heq : κ₁.MatchEq κ₂) : + κ₁.periodicFlags = κ₂.periodicFlags := by + ext f + rw [κ₁.mem_periodicFlags, κ₂.mem_periodicFlags] + exact ⟨fun h => h.matchEq heq, fun h => h.matchEq heq.symm⟩ + +/-- The carrier equivalence of `periodicFlags_matchEq`. -/ +noncomputable def periodicEquivMatchEq + {κ₁ κ₂ : F.RelTransitionSystem} (heq : κ₁.MatchEq κ₂) : + {f : W.Flag // f ∈ κ₁.periodicFlags} ≃ + {f : W.Flag // f ∈ κ₂.periodicFlags} := + Equiv.subtypeEquivRight (fun f => by + rw [periodicFlags_matchEq heq]) + +/-- The periodic walk permutations agree across matching +equality. -/ +theorem walkPermPeriodic_matchEq {κ₁ κ₂ : F.RelTransitionSystem} + (heq : κ₁.MatchEq κ₂) : + κ₂.walkPermPeriodic = + (periodicEquivMatchEq heq).permCongr κ₁.walkPermPeriodic := by + apply Equiv.ext + rintro ⟨f, hf⟩ + apply Subtype.ext + have hper₂ : κ₂.PeriodicFlag f := κ₂.mem_periodicFlags.mp hf + have hpint : W.pairing f ∈ F.internalFlags := by + have h0 := all_pairings_internal_of_periodic κ₂ hper₂ 0 + simpa using h0 + change κ₂.match_ (W.pairing f) = _ + exact (heq _ hpint).symm.trans rfl + +/-- **Matching-equal systems have equal open circuit counts.** -/ +theorem openCircuitCount_matchEq {κ₁ κ₂ : F.RelTransitionSystem} + (heq : κ₁.MatchEq κ₂) : + κ₂.openCircuitCount = κ₁.openCircuitCount := by + unfold RelTransitionSystem.openCircuitCount + rw [walkPermPeriodic_matchEq heq, cycleType_permCongr, + card_fixedPoints_permCongr] + +/-- **Matching-equal systems have equal summands** over the +transported orientation, at every circuit exponent. -/ +theorem throughSummand_ofMatchEq [LinearOrder α] {k ℓ : ℕ} + (hM : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ₁ κ₂ : F.RelTransitionSystem} (heq : κ₁.MatchEq κ₂) + (o : κ₁.Orientation) (n : ℕ) : + F.throughSummand hM st hbnd + (RelTransitionSystem.Orientation.ofMatchEq heq o) n = + F.throughSummand hM st hbnd o n := + throughSummand_congr + (o₁ := RelTransitionSystem.Orientation.ofMatchEq heq o) + (o₂ := o) hM st hbnd rfl (fun f hf => (heq f hf).symm) n + +/-! ## The repair ledger at the vertex -/ + +section RepairLedger + +variable {k ℓ : ℕ} {κ : F.RelTransitionSystem} + {a b c d : W.Flag} {v : W.Vertex} + +/-- The transported orientation keeps `isOut`. -/ +private theorem isOut_transportRepair (hsq : RepairSquare κ a b c d v) + (o : κ.Orientation) (hflip : o.isOut c = !o.isOut a) : + (RelTransitionSystem.Orientation.transportRepair hsq o + hflip).isOut = o.isOut := rfl + +/-- `b` is oriented opposite to `a`. -/ +private theorem isOut_b_eq (hsq : RepairSquare κ a b c d v) + (o : κ.Orientation) : o.isOut b = !o.isOut a := by + rw [← hsq.hab] + exact o.match_flip a hsq.ha + +/-- In the separated case, `d` is oriented like `a`. -/ +private theorem isOut_d_eq (hsq : RepairSquare κ a b c d v) + (o : κ.Orientation) (hflip : o.isOut c = !o.isOut a) : + o.isOut d = o.isOut a := by + have hd : o.isOut d = !o.isOut c := by + rw [← hsq.hcd] + exact o.match_flip c hsq.hc + rw [hd, hflip, Bool.not_not] + +/-- Away from the move's vertex, the odd list is untouched. -/ +private theorem coreOddListAt_transportRepair_ne + (hsq : RepairSquare κ a b c d v) (o : κ.Orientation) + (hflip : o.isOut c = !o.isOut a) (φ : F.CoreOddColouring ℓ) + {vv : W.Vertex} (hvv : vv ≠ v) : + F.coreOddListAt + (RelTransitionSystem.Orientation.transportRepair hsq o + hflip) φ vv = + F.coreOddListAt o φ vv := by + unfold EdgeSubset.coreOddListAt + rw [attachWith_congr (relInFlagsAt_congr + (isOut_transportRepair hsq o hflip) vv)] + refine flatMap_congr_mem (fun f hf => ?_) + have hfmem : f.val ∈ F.relInFlagsAt o vv := + (List.mem_attachWith _ _).mp hf + have hatt : W.attach f.val = Sum.inl vv := + (mem_relInFlagsAt_iff.mp hfmem).2.1 + have hne : ∀ g, W.attach g = Sum.inl v → f.val ≠ g := by + intro g hg he + rw [he, hg] at hatt + exact hvv (Sum.inl.inj hatt).symm + rw [coreOddPairFn_eq_of_match φ f + (RelTransitionSystem.repair_match_of_ne hsq + (hne a hsq.hav) (hne b hsq.hbv) (hne c hsq.hcv) + (hne d hsq.hdv)) + (F.internalFlags_subset_coreFlags (κ.match_mem _ f.prop)), + coreOddPairFn_eq_of_match φ f rfl + (F.internalFlags_subset_coreFlags (κ.match_mem _ f.prop))] + +/-- Away from the move's vertex, the sign is untouched. -/ +private theorem coreOddSignAt_transportRepair_ne + (hsq : RepairSquare κ a b c d v) (o : κ.Orientation) + (hflip : o.isOut c = !o.isOut a) (φ : F.CoreOddColouring ℓ) + {vv : W.Vertex} (hvv : vv ≠ v) : + F.coreOddSignAt + (RelTransitionSystem.Orientation.transportRepair hsq o + hflip) φ vv = + F.coreOddSignAt o φ vv := by + unfold EdgeSubset.coreOddSignAt + rw [attachWith_congr (relInFlagsAt_congr + (isOut_transportRepair hsq o hflip) vv)] + refine congrArg List.prod + (List.map_congr_left (fun f hf => ?_)) + have hfmem : f.val ∈ F.relInFlagsAt o vv := + (List.mem_attachWith _ _).mp hf + have hatt : W.attach f.val = Sum.inl vv := + (mem_relInFlagsAt_iff.mp hfmem).2.1 + have hne : ∀ g, W.attach g = Sum.inl v → f.val ≠ g := by + intro g hg he + rw [he, hg] at hatt + exact hvv (Sum.inl.inj hatt).symm + rw [coreOddSignFn_eq_of_match φ f + (RelTransitionSystem.repair_match_of_ne hsq + (hne a hsq.hav) (hne b hsq.hbv) (hne c hsq.hcv) + (hne d hsq.hdv)) + (F.internalFlags_subset_coreFlags (κ.match_mem _ f.prop)), + coreOddSignFn_eq_of_match φ f rfl + (F.internalFlags_subset_coreFlags (κ.match_mem _ f.prop))] + +/-- At the move's vertex, the sign factors merely commute. -/ +private theorem coreOddSignAt_transportRepair_v + (hsq : RepairSquare κ a b c d v) (o : κ.Orientation) + (hflip : o.isOut c = !o.isOut a) (φ : F.CoreOddColouring ℓ) : + F.coreOddSignAt + (RelTransitionSystem.Orientation.transportRepair hsq o + hflip) φ v = + F.coreOddSignAt o φ v := by + unfold EdgeSubset.coreOddSignAt + rw [attachWith_congr (relInFlagsAt_congr + (isOut_transportRepair hsq o hflip) v)] + have hndL : (F.relInFlagsAt o v).Nodup := relInFlagsAt_nodup o v + -- ═══════ THE DIRECTION AT `a` ═══════ + -- It decides which of the square's flags the vertex enumerates, + -- and the repaired enumeration differs from it by one + -- transposition either way. + cases hxa : o.isOut a with + | false => + have hain : a ∈ F.relInFlagsAt o v := + mem_relInFlagsAt_iff.mpr + ⟨mem_flags_of_internalFlags F hsq.ha, hsq.hav, hxa⟩ + have hdin : d ∈ F.relInFlagsAt o v := + mem_relInFlagsAt_iff.mpr + ⟨mem_flags_of_internalFlags F hsq.hd, hsq.hdv, by + rw [isOut_d_eq hsq o hflip, hxa]⟩ + have hbout : o.isOut b = true := by + rw [isOut_b_eq hsq o, hxa, Bool.not_false] + have hcout : o.isOut c = true := by + rw [hflip, hxa, Bool.not_false] + refine prod_map_swap _ _ (⟨a, hsq.ha⟩ : + {f : W.Flag // f ∈ F.internalFlags}) ⟨d, hsq.hd⟩ + (fun he => hsq.had (congrArg Subtype.val he)) ?_ ?_ + (nodup_attachWith hndL _) + ((List.mem_attachWith _ _).mpr hain) + ((List.mem_attachWith _ _).mpr hdin) + (fun f hf hfu hfw => ?_) + · rw [coreOddSignFn_eq_of_match φ _ + (RelTransitionSystem.repair_match_a hsq) + (F.internalFlags_subset_coreFlags hsq.hc), + coreOddSignFn_eq_of_match φ _ hsq.hmd + (F.internalFlags_subset_coreFlags hsq.hc)] + · rw [coreOddSignFn_eq_of_match φ _ + (RelTransitionSystem.repair_match_d hsq) + (F.internalFlags_subset_coreFlags hsq.hb), + coreOddSignFn_eq_of_match φ _ hsq.hab + (F.internalFlags_subset_coreFlags hsq.hb)] + · have hfmem : f.val ∈ F.relInFlagsAt o v := + (List.mem_attachWith _ _).mp hf + have hisoutf : o.isOut f.val = false := + (mem_relInFlagsAt_iff.mp hfmem).2.2 + have hnev : ∀ g, o.isOut g = true → f.val ≠ g := by + intro g hg he + rw [he, hg] at hisoutf + cases hisoutf + rw [coreOddSignFn_eq_of_match φ f + (RelTransitionSystem.repair_match_of_ne hsq + (fun he => hfu (Subtype.ext he)) (hnev b hbout) + (hnev c hcout) (fun he => hfw (Subtype.ext he))) + (F.internalFlags_subset_coreFlags + (κ.match_mem _ f.prop)), + coreOddSignFn_eq_of_match φ f rfl + (F.internalFlags_subset_coreFlags + (κ.match_mem _ f.prop))] + | true => + have hbin : b ∈ F.relInFlagsAt o v := + mem_relInFlagsAt_iff.mpr + ⟨mem_flags_of_internalFlags F hsq.hb, hsq.hbv, by + rw [isOut_b_eq hsq o, hxa, Bool.not_true]⟩ + have hcin : c ∈ F.relInFlagsAt o v := + mem_relInFlagsAt_iff.mpr + ⟨mem_flags_of_internalFlags F hsq.hc, hsq.hcv, by + rw [hflip, hxa, Bool.not_true]⟩ + have hdout : o.isOut d = true := by + rw [isOut_d_eq hsq o hflip, hxa] + refine prod_map_swap _ _ (⟨b, hsq.hb⟩ : + {f : W.Flag // f ∈ F.internalFlags}) ⟨c, hsq.hc⟩ + (fun he => hsq.hbc (congrArg Subtype.val he)) ?_ ?_ + (nodup_attachWith hndL _) + ((List.mem_attachWith _ _).mpr hbin) + ((List.mem_attachWith _ _).mpr hcin) + (fun f hf hfu hfw => ?_) + · rw [coreOddSignFn_eq_of_match φ _ + (RelTransitionSystem.repair_match_b hsq) + (F.internalFlags_subset_coreFlags hsq.hd), + coreOddSignFn_eq_of_match φ _ hsq.hcd + (F.internalFlags_subset_coreFlags hsq.hd)] + · rw [coreOddSignFn_eq_of_match φ _ + (RelTransitionSystem.repair_match_c hsq) + (F.internalFlags_subset_coreFlags hsq.ha), + coreOddSignFn_eq_of_match φ _ hsq.hmb + (F.internalFlags_subset_coreFlags hsq.ha)] + · have hfmem : f.val ∈ F.relInFlagsAt o v := + (List.mem_attachWith _ _).mp hf + have hisoutf : o.isOut f.val = false := + (mem_relInFlagsAt_iff.mp hfmem).2.2 + have hnev : ∀ g, o.isOut g = true → f.val ≠ g := by + intro g hg he + rw [he, hg] at hisoutf + cases hisoutf + rw [coreOddSignFn_eq_of_match φ f + (RelTransitionSystem.repair_match_of_ne hsq + (hnev a hxa) (fun he => hfu (Subtype.ext he)) + (fun he => hfw (Subtype.ext he)) (hnev d hdout)) + (F.internalFlags_subset_coreFlags + (κ.match_mem _ f.prop)), + coreOddSignFn_eq_of_match φ f rfl + (F.internalFlags_subset_coreFlags + (κ.match_mem _ f.prop))] + +/-- **The vertex ledger**: at the move's vertex, the transported +odd list is the old list with one transposition — the two changed +pair blocks swap their partner entries. -/ +private theorem evalOdd_coreOddListAt_transportRepair_v + (hsq : RepairSquare κ a b c d v) (o : κ.Orientation) + (hflip : o.isOut c = !o.isOut a) (hM : MixedFunctional k ℓ) + (μ : Multiset (Fin k)) (φ : F.CoreOddColouring ℓ) : + hM.evalOdd μ (F.coreOddListAt + (RelTransitionSystem.Orientation.transportRepair hsq o + hflip) φ v) = + -hM.evalOdd μ (F.coreOddListAt o φ v) := by + unfold EdgeSubset.coreOddListAt + rw [attachWith_congr (relInFlagsAt_congr + (isOut_transportRepair hsq o hflip) v)] + have hndL : (F.relInFlagsAt o v).Nodup := relInFlagsAt_nodup o v + -- ═══════ THE DIRECTION AT `a` ═══════ + -- It decides which of the square's flags the vertex enumerates, + -- and the repaired enumeration differs from it by one + -- transposition either way. + cases hxa : o.isOut a with + | false => + have hain : a ∈ F.relInFlagsAt o v := + mem_relInFlagsAt_iff.mpr + ⟨mem_flags_of_internalFlags F hsq.ha, hsq.hav, hxa⟩ + have hdin : d ∈ F.relInFlagsAt o v := + mem_relInFlagsAt_iff.mpr + ⟨mem_flags_of_internalFlags F hsq.hd, hsq.hdv, by + rw [isOut_d_eq hsq o hflip, hxa]⟩ + have hbout : o.isOut b = true := by + rw [isOut_b_eq hsq o, hxa, Bool.not_false] + have hcout : o.isOut c = true := by + rw [hflip, hxa, Bool.not_false] + refine evalOdd_flatMap_swap hM μ _ _ (⟨a, hsq.ha⟩ : + {f : W.Flag // f ∈ F.internalFlags}) ⟨d, hsq.hd⟩ + (fun he => hsq.had (congrArg Subtype.val he)) + (φ.val ⟨a, F.internalFlags_subset_coreFlags hsq.ha⟩) + (φ.val ⟨d, F.internalFlags_subset_coreFlags hsq.hd⟩) + (oddPartner ℓ (φ.val ⟨b, + F.internalFlags_subset_coreFlags hsq.hb⟩)) + (oddPartner ℓ (φ.val ⟨c, + F.internalFlags_subset_coreFlags hsq.hc⟩)) + (coreOddPairFn_eq_of_match φ _ hsq.hab + (F.internalFlags_subset_coreFlags hsq.hb)) + (coreOddPairFn_eq_of_match φ _ hsq.hmd + (F.internalFlags_subset_coreFlags hsq.hc)) + (coreOddPairFn_eq_of_match φ _ + (RelTransitionSystem.repair_match_a hsq) + (F.internalFlags_subset_coreFlags hsq.hc)) + (coreOddPairFn_eq_of_match φ _ + (RelTransitionSystem.repair_match_d hsq) + (F.internalFlags_subset_coreFlags hsq.hb)) + (nodup_attachWith hndL _) + ((List.mem_attachWith _ _).mpr hain) + ((List.mem_attachWith _ _).mpr hdin) + (fun f hf hfu hfw => ?_) + have hfmem : f.val ∈ F.relInFlagsAt o v := + (List.mem_attachWith _ _).mp hf + have hisoutf : o.isOut f.val = false := + (mem_relInFlagsAt_iff.mp hfmem).2.2 + have hnev : ∀ g, o.isOut g = true → f.val ≠ g := by + intro g hg he + rw [he, hg] at hisoutf + cases hisoutf + rw [coreOddPairFn_eq_of_match φ f + (RelTransitionSystem.repair_match_of_ne hsq + (fun he => hfu (Subtype.ext he)) (hnev b hbout) + (hnev c hcout) (fun he => hfw (Subtype.ext he))) + (F.internalFlags_subset_coreFlags (κ.match_mem _ f.prop)), + coreOddPairFn_eq_of_match φ f rfl + (F.internalFlags_subset_coreFlags (κ.match_mem _ f.prop))] + | true => + have hbin : b ∈ F.relInFlagsAt o v := + mem_relInFlagsAt_iff.mpr + ⟨mem_flags_of_internalFlags F hsq.hb, hsq.hbv, by + rw [isOut_b_eq hsq o, hxa, Bool.not_true]⟩ + have hcin : c ∈ F.relInFlagsAt o v := + mem_relInFlagsAt_iff.mpr + ⟨mem_flags_of_internalFlags F hsq.hc, hsq.hcv, by + rw [hflip, hxa, Bool.not_true]⟩ + have hdout : o.isOut d = true := by + rw [isOut_d_eq hsq o hflip, hxa] + refine evalOdd_flatMap_swap hM μ _ _ (⟨b, hsq.hb⟩ : + {f : W.Flag // f ∈ F.internalFlags}) ⟨c, hsq.hc⟩ + (fun he => hsq.hbc (congrArg Subtype.val he)) + (φ.val ⟨b, F.internalFlags_subset_coreFlags hsq.hb⟩) + (φ.val ⟨c, F.internalFlags_subset_coreFlags hsq.hc⟩) + (oddPartner ℓ (φ.val ⟨a, + F.internalFlags_subset_coreFlags hsq.ha⟩)) + (oddPartner ℓ (φ.val ⟨d, + F.internalFlags_subset_coreFlags hsq.hd⟩)) + (coreOddPairFn_eq_of_match φ _ hsq.hmb + (F.internalFlags_subset_coreFlags hsq.ha)) + (coreOddPairFn_eq_of_match φ _ hsq.hcd + (F.internalFlags_subset_coreFlags hsq.hd)) + (coreOddPairFn_eq_of_match φ _ + (RelTransitionSystem.repair_match_b hsq) + (F.internalFlags_subset_coreFlags hsq.hd)) + (coreOddPairFn_eq_of_match φ _ + (RelTransitionSystem.repair_match_c hsq) + (F.internalFlags_subset_coreFlags hsq.ha)) + (nodup_attachWith hndL _) + ((List.mem_attachWith _ _).mpr hbin) + ((List.mem_attachWith _ _).mpr hcin) + (fun f hf hfu hfw => ?_) + have hfmem : f.val ∈ F.relInFlagsAt o v := + (List.mem_attachWith _ _).mp hf + have hisoutf : o.isOut f.val = false := + (mem_relInFlagsAt_iff.mp hfmem).2.2 + have hnev : ∀ g, o.isOut g = true → f.val ≠ g := by + intro g hg he + rw [he, hg] at hisoutf + cases hisoutf + rw [coreOddPairFn_eq_of_match φ f + (RelTransitionSystem.repair_match_of_ne hsq + (hnev a hxa) (fun he => hfu (Subtype.ext he)) + (fun he => hfw (Subtype.ext he)) (hnev d hdout)) + (F.internalFlags_subset_coreFlags (κ.match_mem _ f.prop)), + coreOddPairFn_eq_of_match φ f rfl + (F.internalFlags_subset_coreFlags (κ.match_mem _ f.prop))] + +end RepairLedger + +/-! ## The summand under one separated move -/ + +section SummandRepair + +/-- **The separated-case ledger**: one repair move negates the +constrained summand at every fixed circuit exponent, over the +transported orientation. -/ +theorem throughSummand_transportRepair + [LinearOrder α] {k : ℕ} {ℓ : ℕ} {κ : F.RelTransitionSystem} {a : W.Flag} + {b : W.Flag} {c : W.Flag} {d : W.Flag} {v : W.Vertex} + (hM : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (hsq : RepairSquare κ a b c d v) (o : κ.Orientation) + (hflip : o.isOut c = !o.isOut a) (n : ℕ) : + F.throughSummand hM st hbnd + (RelTransitionSystem.Orientation.transportRepair hsq o + hflip) n = + -F.throughSummand hM st hbnd o n := by + classical + have hprod : ∀ (ψ : F.EvenColouring k) + (φ : F.CoreOddColouring ℓ), + (∏ vv : W.Vertex, + ((F.coreOddSignAt + (RelTransitionSystem.Orientation.transportRepair hsq o + hflip) φ vv : ℂ) * + hM.evalOdd (F.evenColoursAt ψ vv) + (F.coreOddListAt + (RelTransitionSystem.Orientation.transportRepair hsq + o hflip) φ vv))) = + -(∏ vv : W.Vertex, + ((F.coreOddSignAt o φ vv : ℂ) * + hM.evalOdd (F.evenColoursAt ψ vv) + (F.coreOddListAt o φ vv))) := by + intro ψ φ + rw [← Finset.mul_prod_erase Finset.univ _ (Finset.mem_univ v), + ← Finset.mul_prod_erase Finset.univ _ (Finset.mem_univ v)] + have herase : ∀ vv ∈ Finset.univ.erase v, + ((F.coreOddSignAt + (RelTransitionSystem.Orientation.transportRepair hsq o + hflip) φ vv : ℂ) * + hM.evalOdd (F.evenColoursAt ψ vv) + (F.coreOddListAt + (RelTransitionSystem.Orientation.transportRepair hsq + o hflip) φ vv)) = + ((F.coreOddSignAt o φ vv : ℂ) * + hM.evalOdd (F.evenColoursAt ψ vv) + (F.coreOddListAt o φ vv)) := by + intro vv hvv + rw [coreOddSignAt_transportRepair_ne hsq o hflip φ + (Finset.mem_erase.mp hvv).1, + coreOddListAt_transportRepair_ne hsq o hflip φ + (Finset.mem_erase.mp hvv).1] + rw [Finset.prod_congr rfl herase, + coreOddSignAt_transportRepair_v hsq o hflip φ, + evalOdd_coreOddListAt_transportRepair_v hsq o hflip hM + (F.evenColoursAt ψ v) φ] + ring + unfold EdgeSubset.throughSummand + rw [← mul_neg] + refine congrArg _ ?_ + rw [← Finset.sum_neg_distrib] + refine Finset.sum_congr rfl (fun ψ _ => ?_) + split_ifs with hP + · rw [← Finset.sum_neg_distrib] + refine Finset.sum_congr rfl (fun φ _ => ?_) + split_ifs with hQ + · exact hprod ψ φ + · rw [neg_zero] + · rw [neg_zero] + +/-- The summand at exponent `n` factors through exponent `0`. -/ +theorem throughSummand_exp + [LinearOrder α] {k : ℕ} {ℓ : ℕ} {κ : F.RelTransitionSystem} + (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (o : κ.Orientation) (n : ℕ) : + F.throughSummand hM st hbnd o n = + (-1 : ℂ) ^ n * F.throughSummand hM st hbnd o 0 := by + unfold EdgeSubset.throughSummand + rw [pow_zero] + ring + +private theorem neg_one_pow_eq_neg {m n : ℕ} (hodd : Odd (n + m)) : + ((-1 : ℂ)) ^ m = -((-1 : ℂ)) ^ n := by + have hmul : ((-1 : ℂ)) ^ n * ((-1 : ℂ)) ^ m = -1 := by + rw [← pow_add] + exact Odd.neg_one_pow hodd + have hsq2 : ((-1 : ℂ)) ^ n * ((-1 : ℂ)) ^ n = 1 := by + rw [← pow_add, ← two_mul, pow_mul, neg_one_sq, one_pow] + calc ((-1 : ℂ)) ^ m + = ((-1 : ℂ) ^ n * (-1 : ℂ) ^ n) * (-1 : ℂ) ^ m := by + rw [hsq2, one_mul] + _ = (-1 : ℂ) ^ n * ((-1 : ℂ) ^ n * (-1 : ℂ) ^ m) := by ring + _ = (-1 : ℂ) ^ n * -1 := by rw [hmul] + _ = -((-1 : ℂ)) ^ n := by ring + +/-- **The separated repair step** (target shape): when the +circuit-count parity flips across the move, the summand at the +open circuit counts is preserved, over the transported +orientation. -/ +theorem throughSummand_repair + [LinearOrder α] {k : ℕ} {ℓ : ℕ} {κ : F.RelTransitionSystem} {a : W.Flag} + {b : W.Flag} {c : W.Flag} {d : W.Flag} {v : W.Vertex} + (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (hsq : RepairSquare κ a b c d v) (o : κ.Orientation) + (hflip : o.isOut c = !o.isOut a) + (hodd : Odd (κ.openCircuitCount + + (κ.repair a b c d v hsq).openCircuitCount)) : + F.throughSummand hM st hbnd + (RelTransitionSystem.Orientation.transportRepair hsq o + hflip) + ((κ.repair a b c d v hsq).openCircuitCount) = + F.throughSummand hM st hbnd o κ.openCircuitCount := by + rw [throughSummand_exp hM st hbnd _ + ((κ.repair a b c d v hsq).openCircuitCount), + throughSummand_exp hM st hbnd o κ.openCircuitCount, + throughSummand_transportRepair hM st hbnd hsq o hflip 0, + neg_one_pow_eq_neg hodd] + ring + +end SummandRepair + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidInstance.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidInstance.lean new file mode 100644 index 0000000000..6d65a2b156 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidInstance.lean @@ -0,0 +1,64 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ExactPairingInstance + +/-! +# Rigidity of the skein category + +Every object is self-dual: the exact self-pairing at arity `n` is +assembled by induction from the single-strand pairing, using the +unit pairing at arity zero and the tensor product of exact +pairings for the step (the arity arithmetic `n + 1` is +definitional, and the flip `1 + n = n + 1` is transported along +`eqToIso`). +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory MonoidalCategory + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The exact self-pairing at every arity. -/ +@[instance_reducible] +noncomputable def strandPairingAll : + (n : ℕ) → + ExactPairing (SkeinObj.mk (f := f) n) (SkeinObj.mk n) + | 0 => exactPairingUnit + | n + 1 => + letI : ExactPairing (SkeinObj.mk (f := f) n) + (SkeinObj.mk n) := strandPairingAll n + letI : ExactPairing + (SkeinObj.mk (f := f) n ⊗ SkeinObj.mk 1) + (SkeinObj.mk 1 ⊗ SkeinObj.mk n) := + ExactPairing.tensor + exactPairingCongrRight + (X := SkeinObj.mk (f := f) (n + 1)) + (Y := SkeinObj.mk (f := f) (n + 1)) + (Y' := SkeinObj.mk (f := f) (1 + n)) + (eqToIso (congrArg SkeinObj.mk (Nat.add_comm n 1))) + +/-- Every skein object is its own right dual. -/ +noncomputable instance skeinHasRightDual (X : SkeinObj f) : + HasRightDual X where + rightDual := X + exact := strandPairingAll f X.arity + +/-- And its own left dual — the category is rigid. -/ +noncomputable instance skeinHasLeftDual (X : SkeinObj f) : + HasLeftDual X where + leftDual := X + exact := strandPairingAll f X.arity + +/-- **The skein category is rigid.** -/ +noncomputable instance skeinRigid : RigidCategory (SkeinObj f) where + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidityClasses.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidityClasses.lean new file mode 100644 index 0000000000..7c6e055be7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidityClasses.lean @@ -0,0 +1,94 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeRelabel + +/-! +# The rigidity classes of the skein category + +The evaluation and coevaluation classes — the single strand read +as a `(2,0)`- or `(0,2)`-fragment — together with the braiding +class on two strands, and the supersymmetry of the evaluation: +precomposing the evaluation with the braiding (or postcomposing +the coevaluation) is absorbed, because the strand is symmetric +under any boundary relabelling. These are the data that the +Deligne fibre functor sends to the standard form and copairing. +-/ + +@[expose] public section + +namespace RS + +/-- The strand is invariant under every boundary relabelling: any +permutation of `Fin 2` commutes with the end swap. -/ +noncomputable def strandRelabelEquiv (e : Fin 2 ≃ Fin 2) : + (Fragment.strand.relabel e).Equiv Fragment.strand where + flagEquiv := e + vertexEquiv := _root_.Equiv.refl Empty + attach_comm := fun g => by + change Sum.inr (e g) = + ((Sum.inr (e g) : Empty ⊕ Fin 2).map + (_root_.Equiv.refl Empty) id) + rfl + pairing_comm := fun g => by + change e ⟨1 - g.val, by omega⟩ = ⟨1 - (e g).val, by omega⟩ + set x := (⟨1 - g.val, by omega⟩ : Fin 2) with hx + have hxv : x.val = 1 - g.val := congrArg Fin.val hx + have hne : x ≠ g := by + intro he + have hv : x.val = g.val := congrArg Fin.val he + have := g.isLt + omega + have hnev : (e x).val ≠ (e g).val := + fun hv => hne (e.injective (Fin.ext hv)) + have h1 : (e x).val < 2 := (e x).isLt + have h2 : (e g).val < 2 := (e g).isLt + refine Fin.ext ?_ + change (e x).val = 1 - (e g).val + omega + circles_eq := rfl + +/-- The evaluation fragment: the strand as a `(2,0)`-morphism. -/ +noncomputable def evFrag : Fragment (Fin (2 + 0)) := + Fragment.strand.relabel (finCongr (by omega : 2 = 2 + 0)) + +/-- The coevaluation fragment: the strand as a `(0,2)`-morphism. -/ +noncomputable def coevFrag : Fragment (Fin (0 + 2)) := + Fragment.strand.relabel (finCongr (by omega : 2 = 0 + 2)) + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The evaluation class. -/ +noncomputable def evClass : HomSpace f.val (2 + 0) := + HomSpace.ofFragment f.val evFrag + +/-- The coevaluation class. -/ +noncomputable def coevClass : HomSpace f.val (0 + 2) := + HomSpace.ofFragment f.val coevFrag + +/-- The braiding class on two strands. -/ +noncomputable def braidClass : HomSpace f.val (2 + 2) := + HomSpace.ofFragment f.val + (permFragment (_root_.Equiv.swap (0 : Fin 2) 1)) + +/-- **Supersymmetry of the evaluation**: the braiding is absorbed +by the evaluation class. -/ +theorem braid_comp_evClass : + HomSpace.comp f 2 2 0 (braidClass f) (evClass f) = + evClass f := by + rw [braidClass, evClass, HomSpace.comp_ofFragment] + refine HomSpace.ofFragment_congr f ?_ + refine (permFragmentComposeLeft + (_root_.Equiv.swap (0 : Fin 2) 1) evFrag).trans ?_ + refine (Fragment.Equiv.relabelTrans Fragment.strand _ _).trans + ?_ + exact (strandRelabelEquiv _).trans + (strandRelabelEquiv _).symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ScalarClass.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ScalarClass.lean new file mode 100644 index 0000000000..d250d5e068 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ScalarClass.lean @@ -0,0 +1,67 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Multiplicativity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal + +/-! +# The scalar class + +Every closed fragment's class in the arity-zero Hom space is its +parameter value times the class of the empty fragment: this is +how the parameter `f` enters the skein category numerically. +The proof is the rank-one argument of Lemma 3.2 read backwards: +both rows of the arity-zero pairing are multiples of the empty +row, with ratio `f(W)`. +-/ + +@[expose] public section + +namespace RS + +/-- The arity-zero pairing is the union value. -/ +theorem connectionPairing_zero_union {R : ℕ} + (f : EdgeRankParameter R) (W G : ClosedFragment) : + connectionPairing f.val 0 W G = + f.val (ClosedFragment.union W G) := + f.iso_invariant _ _ + ((Fragment.composeCongr (relabelZeroEquiv W _) + (relabelZeroEquiv G _)).trans (composeZeroEquiv W G)) + +/-- **The scalar class**: the class of a closed fragment in the +arity-zero Hom space is its value times the empty class. -/ +theorem ofFragment_eq_smul_empty {R : ℕ} + (f : EdgeRankParameter R) (W : ClosedFragment) : + HomSpace.ofFragment f.val W = + f.val W • HomSpace.ofFragment f.val emptyClosedFragment := by + have h : (Finsupp.single W (1 : ℂ)) - + f.val W • Finsupp.single emptyClosedFragment 1 ∈ + LinearMap.ker (connectionMap f.val 0) := by + rw [LinearMap.mem_ker, map_sub, map_smul] + funext G + change connectionMap f.val 0 (Finsupp.single W 1) G - + f.val W • connectionMap f.val 0 + (Finsupp.single emptyClosedFragment 1) G = 0 + rw [connectionMap_single, connectionMap_single, one_mul, + one_mul, smul_eq_mul, connectionPairing_zero_union f W G, + connectionPairing_zero_union f emptyClosedFragment G, + EdgeRankParameter.val_union, + EdgeRankParameter.val_union, f.val_empty, one_mul] + ring + have h2 : (LinearMap.ker (connectionMap f.val 0)).mkQ + (Finsupp.single W (1 : ℂ)) = + (LinearMap.ker (connectionMap f.val 0)).mkQ + (f.val W • Finsupp.single emptyClosedFragment 1) := by + rw [Submodule.mkQ_apply, Submodule.mkQ_apply, + Submodule.Quotient.eq] + exact h + exact h2.trans (map_smul + (LinearMap.ker (connectionMap f.val 0)).mkQ (f.val W) + (Finsupp.single emptyClosedFragment 1)) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ScalarFunctional.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ScalarFunctional.lean new file mode 100644 index 0000000000..f8abb2e2c8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ScalarFunctional.lean @@ -0,0 +1,50 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceNondegenerate + +/-! +# The scalar functional + +The descended trace at arity zero evaluates a closed fragment's +class to its parameter value: closing against the empty strand +bundle is the identity, so the arity-zero trace is evaluation +of `f` itself. This is the numerical endpoint of the extraction: +every identity of Hom-classes at arity zero becomes an identity +of parameter values through this functional. +-/ + +@[expose] public section + +namespace RS + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- Closing a closed fragment against the empty bundle is the +fragment. -/ +noncomputable def pairCloseStrandBundleZero + (W : Fragment (Fin (0 + 0))) : + (pairClose W (strandBundle 0)).Equiv W := by + refine (Fragment.composeCongr (Fragment.Equiv.refl _) + ((Fragment.Equiv.relabelEq (strandBundle 0) + (_root_.Equiv.ext (fun i => i.elim0))).trans + (Fragment.Equiv.relabelRefl (strandBundle 0)))).trans ?_ + refine (composeStrandBundleRight 0 0 _).trans ?_ + exact (Fragment.Equiv.relabelEq W + (_root_.Equiv.ext (fun i => i.elim0))).trans + (Fragment.Equiv.relabelRefl W) + +/-- **The scalar functional**: the arity-zero descended trace of +a closed fragment's class is its parameter value. -/ +theorem traceMap_zero_ofFragment (W : Fragment (Fin (0 + 0))) : + HomSpace.traceMap f.val 0 + (HomSpace.ofFragment f.val W) = f.val W := by + rw [HomSpace.traceMap_ofFragment] + exact f.iso_invariant _ _ (pairCloseStrandBundleZero W) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SeparatedParity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SeparatedParity.lean new file mode 100644 index 0000000000..591c153214 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SeparatedParity.lean @@ -0,0 +1,1809 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger + +/-! +# The separated count parity + +Discharges `SeparatedCountParity`: a separated repair square on a +localized configuration flips the circuit-count parity +(`Δ openCircuitCount = ±1`). + +## Architecture + +Instead of tracking the periodic-flag subtype (which changes across +the move in the chain-local cases), we close up the whole system +into a single permutation on **all** participating flags, the +*full walk* `Π = M ∘ σ`, where `σ` is the edge pairing and `M` is +the matching on internal flags extended by the path matching on +boundary flags. Its orbits are the circuit orbits (two per +circuit) plus one orbit per boundary flag (each boundary chain +contributes its two traversal directions, each containing exactly +one boundary flag). Hence + + `orbits Π = orbits (walkPermPeriodic) + boundaryFlags.card`. + +Because a localized square leaves the path matching untouched +(`pathMatch_repair_of_localized`), the repaired full walk is the +old one multiplied by the double transposition `(a d)(b c)`. An +abstract transposition lemma (multiplying by a swap changes the +orbit count by exactly one, splitting iff the swapped points share +an orbit) plus the mirror symmetry `σ Π σ = Π⁻¹` and the separated +orientation force the two swaps to act coherently: the orbit count +moves by exactly `±2`, i.e. the circuit count by `±1`. + +## Main results + +* `permOrbitCount_swap_mul_sameCycle` / `..._not_sameCycle` — the + abstract transposition ledger for total orbit counts. +* `permOrbitCount_swap_swap_mul` — the coherent double swap. +* `EdgeSubset.fullPerm` — the closed-up walk permutation. +* `EdgeSubset.permOrbitCount_fullPerm_eq` — the orbit bookkeeping + `orbits Π = orbits wpp + |B|`. +* `EdgeSubset.fullPerm_repair` — the move is the double swap. +* `separatedCountParity` — the discharged `SeparatedCountParity`. +-/ + +@[expose] public section + +namespace RS + + + +/-! ## (i) Abstract orbit counting -/ + +section AbstractOrbit + +open Equiv Equiv.Perm + +variable {Y : Type} + +/-- The total orbit count of a permutation: nontrivial cycles plus +fixed points. -/ +noncomputable def permOrbitCount [Fintype Y] [DecidableEq Y] + (g : Perm Y) : ℕ := + g.cycleType.card + Fintype.card (Function.fixedPoints g) + +/-- Fixed points and support partition the domain. -/ +theorem card_fixedPoints_add_card_support [Fintype Y] [DecidableEq Y] + (g : Perm Y) : + Fintype.card (Function.fixedPoints g) + g.support.card = + Fintype.card Y := by + have h1 : Fintype.card (Function.fixedPoints g) = + (Finset.univ.filter (fun x => g x = x)).card := + Fintype.card_subtype _ + have h2 : g.support = Finset.univ.filter (fun x => ¬ g x = x) := by + ext x + simp [Equiv.Perm.mem_support] + rw [h1, h2, ← Finset.card_univ] + exact Finset.card_filter_add_card_filter_not (fun x => g x = x) + +/-- Reduce a permutation power at a recurrent point. -/ +theorem perm_pow_mod {g : Perm Y} {x : Y} {p : ℕ} (_hp : 1 ≤ p) + (hper : (g ^ p) x = x) (i : ℕ) : + (g ^ i) x = (g ^ (i % p)) x := by + have key : ∀ q r, (g ^ (p * q + r)) x = (g ^ r) x := by + intro q + induction q with + | zero => intro r; simp + | succ q ih => + intro r + have hsplit : p * (q + 1) + r = (p * q + r) + p := by ring + rw [hsplit, pow_add, Equiv.Perm.mul_apply] + have hx : (g ^ p) x = x := hper + rw [hx] + exact ih r + conv_lhs => + rw [show i = p * (i / p) + i % p from (Nat.div_add_mod i p).symm] + exact key (i / p) (i % p) + +/-- A `SameCycle` witness from a power. -/ +theorem sameCycle_of_pow_eq {g : Perm Y} {x y : Y} {n : ℕ} + (h : (g ^ n) x = y) : g.SameCycle x y := + ⟨(n : ℤ), by rw [zpow_natCast]; exact h⟩ + +/-- Trajectories avoiding both swapped points are untouched by the +swap. -/ +private theorem swap_mul_pow_eq [DecidableEq Y] + {g : Perm Y} {x y u : Y} + (hx : ∀ k : ℕ, (g ^ k) u ≠ x) (hy : ∀ k : ℕ, (g ^ k) u ≠ y) : + ∀ k : ℕ, ((Equiv.swap x y * g) ^ k) u = (g ^ k) u := by + intro k + induction k with + | zero => rfl + | succ k ih => + have h1 : ((Equiv.swap x y * g) ^ (k + 1)) u = + (Equiv.swap x y * g) (((Equiv.swap x y * g) ^ k) u) := by + rw [pow_succ', Equiv.Perm.mul_apply] + have h2 : (g ^ (k + 1)) u = g ((g ^ k) u) := by + rw [pow_succ', Equiv.Perm.mul_apply] + rw [h1, ih, Equiv.Perm.mul_apply, ← h2, + Equiv.swap_apply_of_ne_of_ne (hx (k + 1)) (hy (k + 1))] + +/-- **Untouched orbits**: `SameCycle` from a point in neither +swapped orbit transfers across the swap-multiplication. -/ +theorem sameCycle_swap_mul_iff [Finite Y] [DecidableEq Y] + {g : Perm Y} {x y u : Y} + (hux : ¬ g.SameCycle u x) (huy : ¬ g.SameCycle u y) (v : Y) : + (Equiv.swap x y * g).SameCycle u v ↔ g.SameCycle u v := by + let : Fintype Y := Fintype.ofFinite Y + have hx : ∀ k : ℕ, (g ^ k) u ≠ x := by + intro k hk + exact hux (sameCycle_of_pow_eq hk) + have hy : ∀ k : ℕ, (g ^ k) u ≠ y := by + intro k hk + exact huy (sameCycle_of_pow_eq hk) + constructor + · intro h + obtain ⟨i, _, _, hiv⟩ := Equiv.Perm.SameCycle.exists_pow_eq _ h + rw [swap_mul_pow_eq hx hy] at hiv + exact sameCycle_of_pow_eq hiv + · intro h + obtain ⟨i, _, _, hiv⟩ := Equiv.Perm.SameCycle.exists_pow_eq _ h + rw [← swap_mul_pow_eq hx hy] at hiv + exact sameCycle_of_pow_eq hiv + +/-- Along the swap-multiplied permutation, every point of a +`g`-trajectory of `x` is in the orbit of `x` or of `y`. -/ +private theorem sameCycle_swap_mul_pow_target [DecidableEq Y] + (g : Perm Y) + (x y : Y) : + ∀ k : ℕ, (Equiv.swap x y * g).SameCycle x ((g ^ k) x) ∨ + (Equiv.swap x y * g).SameCycle y ((g ^ k) x) := by + intro k + induction k with + | zero => exact Or.inl (Equiv.Perm.SameCycle.refl _ _) + | succ k ih => + have hstep : (g ^ (k + 1)) x = g ((g ^ k) x) := by + rw [pow_succ', Equiv.Perm.mul_apply] + by_cases h1 : g ((g ^ k) x) = x + · refine Or.inl ?_ + rw [hstep, h1] + by_cases h2 : g ((g ^ k) x) = y + · refine Or.inr ?_ + rw [hstep, h2] + · have happ : (Equiv.swap x y * g) ((g ^ k) x) = + g ((g ^ k) x) := by + rw [Equiv.Perm.mul_apply, + Equiv.swap_apply_of_ne_of_ne h1 h2] + have hsc : (Equiv.swap x y * g).SameCycle ((g ^ k) x) + ((g ^ (k + 1)) x) := by + rw [hstep, ← happ] + exact Equiv.Perm.sameCycle_apply_right.mpr + (Equiv.Perm.SameCycle.refl _ _) + rcases ih with h | h + · exact Or.inl (h.trans hsc) + · exact Or.inr (h.trans hsc) + +/-- Cover: every support point of a cycle lands in the swap-orbit +of `x` or of `y`. -/ +private theorem swap_mul_cycle_cover [Fintype Y] [DecidableEq Y] + {c : Perm Y} (hc : c.IsCycle) + {x y z : Y} (hx : x ∈ c.support) (hz : z ∈ c.support) : + (Equiv.swap x y * c).SameCycle x z ∨ + (Equiv.swap x y * c).SameCycle y z := by + have hsc : c.SameCycle x z := + hc.sameCycle (Equiv.Perm.mem_support.mp hx) + (Equiv.Perm.mem_support.mp hz) + obtain ⟨i, _, _, hiz⟩ := Equiv.Perm.SameCycle.exists_pow_eq _ hsc + rw [← hiz] + exact sameCycle_swap_mul_pow_target c x y i + +/-- Fixed points of the swapped cycle inside the old support are +the swapped points. -/ +private theorem swap_mul_cycle_fixed [Fintype Y] [DecidableEq Y] + {c : Perm Y} (hc : c.IsCycle) + {x y z : Y} (hx : x ∈ c.support) (hz : z ∈ c.support) + (hfix : (Equiv.swap x y * c) z = z) : z = x ∨ z = y := by + rcases swap_mul_cycle_cover (y := y) hc hx hz with h | h + · exact Or.inl (h.eq_of_right hfix).symm + · exact Or.inr (h.eq_of_right hfix).symm + +/-- The swapped cycle has support inside the old support. -/ +private theorem swap_mul_support_subset [Fintype Y] [DecidableEq Y] + {c : Perm Y} {x y : Y} + (hx : x ∈ c.support) (hy : y ∈ c.support) : + (Equiv.swap x y * c).support ⊆ c.support := by + intro z hz + by_contra hzc + have hcz : c z = z := Equiv.Perm.notMem_support.mp hzc + have hzx : z ≠ x := fun h => hzc (h ▸ hx) + have hzy : z ≠ y := fun h => hzc (h ▸ hy) + have : (Equiv.swap x y * c) z = z := by + rw [Equiv.Perm.mul_apply, hcz, + Equiv.swap_apply_of_ne_of_ne hzx hzy] + exact Equiv.Perm.mem_support.mp hz this + +/-- **No crossover**: swapping two points of one cycle separates +them. -/ +private theorem not_sameCycle_swap_mul [Finite Y] [DecidableEq Y] + {g : Perm Y} {x y : Y} + (hxy : x ≠ y) (hsc : g.SameCycle x y) : + ¬ (Equiv.swap x y * g).SameCycle x y := by + let : Fintype Y := Fintype.ofFinite Y + have hex : ∃ i, 0 < i ∧ (g ^ i) x = y := by + obtain ⟨i, hi0, _, hiy⟩ := Equiv.Perm.SameCycle.exists_pow_eq _ hsc + exact ⟨i, hi0, hiy⟩ + obtain ⟨m, hm0, hmy, hmin⟩ : ∃ m, 0 < m ∧ (g ^ m) x = y ∧ + ∀ j, 0 < j → j < m → (g ^ j) x ≠ y := by + refine ⟨Nat.find hex, (Nat.find_spec hex).1, + (Nat.find_spec hex).2, ?_⟩ + intro j hj0 hjm hjy + exact Nat.find_min hex hjm ⟨hj0, hjy⟩ + have hne_x : ∀ j, 0 < j → j < m → (g ^ j) x ≠ x := by + intro j hj0 hjm hjx + have hmod := perm_pow_mod (p := j) hj0 hjx m + rw [hmy] at hmod + have hlt : m % j < j := Nat.mod_lt m hj0 + rcases Nat.eq_zero_or_pos (m % j) with h0 | hpos + · rw [h0] at hmod + exact hxy (by simpa using hmod.symm) + · exact hmin (m % j) hpos (by omega) hmod.symm + have htraj : ∀ i, i < m → + ((Equiv.swap x y * g) ^ i) x = (g ^ i) x := by + intro i + induction i with + | zero => intro _; rfl + | succ i ih => + intro hi + have h1 : ((Equiv.swap x y * g) ^ (i + 1)) x = + (Equiv.swap x y * g) (((Equiv.swap x y * g) ^ i) x) := by + rw [pow_succ', Equiv.Perm.mul_apply] + have h2 : (g ^ (i + 1)) x = g ((g ^ i) x) := by + rw [pow_succ', Equiv.Perm.mul_apply] + rw [h1, ih (by omega), Equiv.Perm.mul_apply, ← h2, + Equiv.swap_apply_of_ne_of_ne + (hne_x (i + 1) (by omega) (by omega)) + (hmin (i + 1) (by omega) (by omega))] + have hwrap : ((Equiv.swap x y * g) ^ m) x = x := by + obtain ⟨m0, rfl⟩ : ∃ m0, m = m0 + 1 := ⟨m - 1, by omega⟩ + have h1 : ((Equiv.swap x y * g) ^ (m0 + 1)) x = + (Equiv.swap x y * g) (((Equiv.swap x y * g) ^ m0) x) := by + rw [pow_succ', Equiv.Perm.mul_apply] + have h2 : (g ^ (m0 + 1)) x = g ((g ^ m0) x) := by + rw [pow_succ', Equiv.Perm.mul_apply] + rw [h1, htraj m0 (by omega), Equiv.Perm.mul_apply, ← h2, hmy, + Equiv.swap_apply_right] + intro hcon + obtain ⟨i, hi0, _, hiy⟩ := Equiv.Perm.SameCycle.exists_pow_eq _ hcon + rw [perm_pow_mod (p := m) (by omega) hwrap i] at hiy + have hlt : i % m < m := Nat.mod_lt i (by omega) + rcases Nat.eq_zero_or_pos (i % m) with h0 | hpos + · rw [h0] at hiy + exact hxy (by simpa using hiy) + · rw [htraj (i % m) hlt] at hiy + exact hmin (i % m) hpos hlt hiy + +/-- **Merging**: swapping two points of different orbits joins +them. -/ +theorem sameCycle_swap_mul_of_not [Finite Y] [DecidableEq Y] + {g : Perm Y} {x y : Y} + (_hxy : x ≠ y) (hsc : ¬ g.SameCycle x y) : + (Equiv.swap x y * g).SameCycle x y := by + let : Fintype Y := Fintype.ofFinite Y + have hex : ∃ i, 0 < i ∧ (g ^ i) x = x := by + refine ⟨orderOf g, ?_, ?_⟩ + · exact orderOf_pos g + · rw [pow_orderOf_eq_one]; rfl + obtain ⟨m, hm0, hmx, hmin⟩ : ∃ m, 0 < m ∧ (g ^ m) x = x ∧ + ∀ j, 0 < j → j < m → (g ^ j) x ≠ x := by + refine ⟨Nat.find hex, (Nat.find_spec hex).1, + (Nat.find_spec hex).2, ?_⟩ + intro j hj0 hjm hjx + exact Nat.find_min hex hjm ⟨hj0, hjx⟩ + have hne_y : ∀ j : ℕ, (g ^ j) x ≠ y := by + intro j hj + exact hsc (sameCycle_of_pow_eq hj) + have htraj : ∀ i, i < m → + ((Equiv.swap x y * g) ^ i) x = (g ^ i) x := by + intro i + induction i with + | zero => intro _; rfl + | succ i ih => + intro hi + have h1 : ((Equiv.swap x y * g) ^ (i + 1)) x = + (Equiv.swap x y * g) (((Equiv.swap x y * g) ^ i) x) := by + rw [pow_succ', Equiv.Perm.mul_apply] + have h2 : (g ^ (i + 1)) x = g ((g ^ i) x) := by + rw [pow_succ', Equiv.Perm.mul_apply] + rw [h1, ih (by omega), Equiv.Perm.mul_apply, ← h2, + Equiv.swap_apply_of_ne_of_ne + (hmin (i + 1) (by omega) (by omega)) (hne_y (i + 1))] + have hwrap : ((Equiv.swap x y * g) ^ m) x = y := by + obtain ⟨m0, rfl⟩ : ∃ m0, m = m0 + 1 := ⟨m - 1, by omega⟩ + have h1 : ((Equiv.swap x y * g) ^ (m0 + 1)) x = + (Equiv.swap x y * g) (((Equiv.swap x y * g) ^ m0) x) := by + rw [pow_succ', Equiv.Perm.mul_apply] + have h2 : (g ^ (m0 + 1)) x = g ((g ^ m0) x) := by + rw [pow_succ', Equiv.Perm.mul_apply] + rw [h1, htraj m0 (by omega), Equiv.Perm.mul_apply, ← h2, hmx, + Equiv.swap_apply_left] + exact sameCycle_of_pow_eq hwrap + +/-! ### Orbit counting via representatives -/ + +/-- **Orbit counting by representatives**: a set meeting every +orbit exactly once has the orbit count as its cardinality. -/ +theorem permOrbitCount_eq_card_of_reps [Fintype Y] [DecidableEq Y] + (g : Perm Y) (S : Finset Y) + (hcover : ∀ z : Y, ∃ w ∈ S, g.SameCycle w z) + (hsep : ∀ w ∈ S, ∀ w' ∈ S, g.SameCycle w w' → w = w') : + permOrbitCount g = S.card := by + have hmoved : (S.filter (fun w => ¬ g w = w)).card = + g.cycleFactorsFinset.card := by + refine Finset.card_bij + (fun w _ => g.cycleOf w) ?_ ?_ ?_ + · intro w hw + rw [Equiv.Perm.cycleOf_mem_cycleFactorsFinset_iff, + Equiv.Perm.mem_support] + exact (Finset.mem_filter.mp hw).2 + · intro w hw w' hw' hEq + obtain ⟨hwS, hwm⟩ := Finset.mem_filter.mp hw + obtain ⟨hwS', hwm'⟩ := Finset.mem_filter.mp hw' + refine hsep w hwS w' hwS' ?_ + exact (Equiv.Perm.sameCycle_iff_cycleOf_eq_of_mem_support + (Equiv.Perm.mem_support.mpr hwm) + (Equiv.Perm.mem_support.mpr hwm')).mpr hEq + · intro f' hf' + have hcyc : f'.IsCycle := + (Equiv.Perm.mem_cycleFactorsFinset_iff.mp hf').1 + obtain ⟨z, hz⟩ := hcyc.nonempty_support + have hzg : z ∈ g.support := by + rw [Equiv.Perm.mem_support] + have h1 := (Equiv.Perm.mem_cycleFactorsFinset_iff.mp + hf').2 z hz + rw [← h1] + exact Equiv.Perm.mem_support.mp hz + obtain ⟨w, hwS, hwz⟩ := hcover z + have hwm : ¬ g w = w := + Equiv.Perm.mem_support.mp ((hwz.mem_support_iff).mpr hzg) + refine ⟨w, Finset.mem_filter.mpr ⟨hwS, hwm⟩, ?_⟩ + rw [hwz.cycleOf_eq] + exact (Equiv.Perm.cycle_is_cycleOf hz hf').symm + have hfixed : (S.filter (fun w => g w = w)).card = + Fintype.card (Function.fixedPoints g) := by + rw [Fintype.card_subtype] + congr 1 + ext z + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + constructor + · rintro ⟨-, h⟩ + exact h + · intro h + obtain ⟨w, hwS, hwz⟩ := hcover z + have hwz' : w = z := hwz.eq_of_right h + exact ⟨hwz' ▸ hwS, h⟩ + have hct : g.cycleType.card = g.cycleFactorsFinset.card := by + rw [Equiv.Perm.cycleType_def, Multiset.card_map] + rfl + have hpart := Finset.card_filter_add_card_filter_not + (s := S) (fun w => g w = w) + unfold permOrbitCount + rw [hct, ← hmoved, ← hfixed] + omega + +/-! ### The cycle split -/ + +/-- **The cycle split count**: swapping two support points of a +cycle yields exactly two orbits on its support. -/ +private theorem swap_mul_cycle_count [Fintype Y] [DecidableEq Y] + {c : Perm Y} (hc : c.IsCycle) + {x y : Y} (hxy : x ≠ y) (hx : x ∈ c.support) + (hy : y ∈ c.support) : + (Equiv.swap x y * c).cycleType.card + c.support.card = + 2 + (Equiv.swap x y * c).support.card := by + have hsub := swap_mul_support_subset (c := c) hx hy + have hfac : ∀ f' ∈ (Equiv.swap x y * c).cycleFactorsFinset, + f' = (Equiv.swap x y * c).cycleOf x ∨ + f' = (Equiv.swap x y * c).cycleOf y := by + intro f' hf' + have hcyc : f'.IsCycle := + (Equiv.Perm.mem_cycleFactorsFinset_iff.mp hf').1 + obtain ⟨z, hz⟩ := hcyc.nonempty_support + have hzs : z ∈ (Equiv.swap x y * c).support := by + rw [Equiv.Perm.mem_support] + have h1 := (Equiv.Perm.mem_cycleFactorsFinset_iff.mp + hf').2 z hz + rw [← h1] + exact Equiv.Perm.mem_support.mp hz + have hzc : z ∈ c.support := hsub hzs + have hfz : f' = (Equiv.swap x y * c).cycleOf z := + Equiv.Perm.cycle_is_cycleOf hz hf' + rcases swap_mul_cycle_cover (y := y) hc hx hzc with h | h + · left + rw [hfz, h.cycleOf_eq] + · right + rw [hfz, h.cycleOf_eq] + have hct : (Equiv.swap x y * c).cycleType.card = + (Equiv.swap x y * c).cycleFactorsFinset.card := by + rw [Equiv.Perm.cycleType_def, Multiset.card_map] + rfl + -- ═══════ FOUR CASES ON WHICH ENDS THE PRODUCT FIXES ═══════ + -- Multiplying by a transposition either splits one cycle in two + -- or merges two into one; which, is read off the two fixed-point + -- tests. + by_cases hτx : (Equiv.swap x y * c) x = x <;> + by_cases hτy : (Equiv.swap x y * c) y = y + · -- both fixed: the swapped cycle is trivial, the cycle is the + -- transposition + have hsupp : (Equiv.swap x y * c).support = ∅ := by + rw [Finset.eq_empty_iff_forall_notMem] + intro z hz + have hzc : z ∈ c.support := hsub hz + have hzm : (Equiv.swap x y * c) z ≠ z := + Equiv.Perm.mem_support.mp hz + rcases swap_mul_cycle_cover (y := y) hc hx hzc with h | h + · exact hzm ((h.eq_of_left hτx) ▸ hτx) + · exact hzm ((h.eq_of_left hτy) ▸ hτy) + have h1 : Equiv.swap x y * c = 1 := + Equiv.Perm.support_eq_empty_iff.mp hsupp + have hct0 : (Equiv.swap x y * c).cycleType.card = 0 := by + rw [h1, Equiv.Perm.cycleType_one] + rfl + have hsc : c.support = {x, y} := by + apply Finset.Subset.antisymm + · intro z hzc + have hzfix : (Equiv.swap x y * c) z = z := by + rw [h1] + rfl + rcases swap_mul_cycle_fixed (y := y) hc hx hzc hzfix with + h | h + · simp [h] + · simp [h] + · intro z hz + rcases Finset.mem_insert.mp hz with rfl | hz + · exact hx + · rw [Finset.mem_singleton.mp hz] + exact hy + have hc2 : ({x, y} : Finset Y).card = 2 := + Finset.card_pair_eq_two_iff.mpr hxy + rw [hct0, hsc, hsupp] + simp [hc2] + · -- x fixed, y moved: one orbit, support loses x + have hxnot : x ∉ (Equiv.swap x y * c).support := + Equiv.Perm.notMem_support.mpr hτx + have hsupp : (Equiv.swap x y * c).support = + c.support.erase x := by + apply Finset.Subset.antisymm + · intro z hz + exact Finset.mem_erase.mpr + ⟨fun h => hxnot (h ▸ hz), hsub hz⟩ + · intro z hz + obtain ⟨hzx, hzc⟩ := Finset.mem_erase.mp hz + rw [Equiv.Perm.mem_support] + intro hzfix + rcases swap_mul_cycle_fixed (y := y) hc hx hzc hzfix with + h | h + · exact hzx h + · rw [h] at hzfix + exact hτy hzfix + have hfacs : (Equiv.swap x y * c).cycleFactorsFinset = + {(Equiv.swap x y * c).cycleOf y} := by + apply Finset.Subset.antisymm + · intro f' hf' + rcases hfac f' hf' with h | h + · exfalso + rw [h, + Equiv.Perm.cycleOf_mem_cycleFactorsFinset_iff] at hf' + exact hxnot hf' + · exact Finset.mem_singleton.mpr h + · intro f' hf' + rw [Finset.mem_singleton.mp hf', + Equiv.Perm.cycleOf_mem_cycleFactorsFinset_iff, + Equiv.Perm.mem_support] + exact hτy + have hpos : 1 ≤ c.support.card := + Finset.card_pos.mpr ⟨x, hx⟩ + rw [hct, hfacs, hsupp, Finset.card_singleton, + Finset.card_erase_of_mem hx] + omega + · -- x moved, y fixed: one orbit, support loses y + have hynot : y ∉ (Equiv.swap x y * c).support := + Equiv.Perm.notMem_support.mpr hτy + have hsupp : (Equiv.swap x y * c).support = + c.support.erase y := by + apply Finset.Subset.antisymm + · intro z hz + exact Finset.mem_erase.mpr + ⟨fun h => hynot (h ▸ hz), hsub hz⟩ + · intro z hz + obtain ⟨hzy, hzc⟩ := Finset.mem_erase.mp hz + rw [Equiv.Perm.mem_support] + intro hzfix + rcases swap_mul_cycle_fixed (y := y) hc hx hzc hzfix with + h | h + · rw [h] at hzfix + exact hτx hzfix + · exact hzy h + have hfacs : (Equiv.swap x y * c).cycleFactorsFinset = + {(Equiv.swap x y * c).cycleOf x} := by + apply Finset.Subset.antisymm + · intro f' hf' + rcases hfac f' hf' with h | h + · exact Finset.mem_singleton.mpr h + · exfalso + rw [h, + Equiv.Perm.cycleOf_mem_cycleFactorsFinset_iff] at hf' + exact hynot hf' + · intro f' hf' + rw [Finset.mem_singleton.mp hf', + Equiv.Perm.cycleOf_mem_cycleFactorsFinset_iff, + Equiv.Perm.mem_support] + exact hτx + have hpos : 1 ≤ c.support.card := + Finset.card_pos.mpr ⟨y, hy⟩ + rw [hct, hfacs, hsupp, Finset.card_singleton, + Finset.card_erase_of_mem hy] + omega + · -- both moved: two orbits, support unchanged + have hsupp : (Equiv.swap x y * c).support = c.support := by + apply Finset.Subset.antisymm hsub + intro z hzc + rw [Equiv.Perm.mem_support] + intro hzfix + rcases swap_mul_cycle_fixed (y := y) hc hx hzc hzfix with + h | h + · rw [h] at hzfix + exact hτx hzfix + · rw [h] at hzfix + exact hτy hzfix + have hxs : x ∈ (Equiv.swap x y * c).support := + Equiv.Perm.mem_support.mpr hτx + have hys : y ∈ (Equiv.swap x y * c).support := + Equiv.Perm.mem_support.mpr hτy + have hne : (Equiv.swap x y * c).cycleOf x ≠ + (Equiv.swap x y * c).cycleOf y := by + intro hEq + have hscxy : (Equiv.swap x y * c).SameCycle x y := + (Equiv.Perm.sameCycle_iff_cycleOf_eq_of_mem_support hxs + hys).mpr hEq + exact not_sameCycle_swap_mul hxy + (hc.sameCycle (Equiv.Perm.mem_support.mp hx) + (Equiv.Perm.mem_support.mp hy)) hscxy + have hfacs : (Equiv.swap x y * c).cycleFactorsFinset = + {(Equiv.swap x y * c).cycleOf x, + (Equiv.swap x y * c).cycleOf y} := by + apply Finset.Subset.antisymm + · intro f' hf' + rcases hfac f' hf' with h | h + · exact Finset.mem_insert.mpr (Or.inl h) + · exact Finset.mem_insert.mpr + (Or.inr (Finset.mem_singleton.mpr h)) + · intro f' hf' + rcases Finset.mem_insert.mp hf' with rfl | hf' + · rw [Equiv.Perm.cycleOf_mem_cycleFactorsFinset_iff] + exact hxs + · rw [Finset.mem_singleton.mp hf', + Equiv.Perm.cycleOf_mem_cycleFactorsFinset_iff] + exact hys + have hc2 : ({(Equiv.swap x y * c).cycleOf x, + (Equiv.swap x y * c).cycleOf y} : + Finset (Perm Y)).card = 2 := + Finset.card_pair_eq_two_iff.mpr hne + rw [hct, hfacs, hsupp, hc2] + +/-! ### The transposition orbit ledger -/ + +/-- **Splitting**: multiplying by a transposition of two points on +one orbit raises the orbit count by one. -/ +theorem permOrbitCount_swap_mul_sameCycle [Fintype Y] [DecidableEq Y] + {g : Perm Y} {x y : Y} + (hxy : x ≠ y) (hsc : g.SameCycle x y) : + permOrbitCount (Equiv.swap x y * g) = permOrbitCount g + 1 := by + have hgx : g x ≠ x := by + intro h + exact hxy (hsc.eq_of_left h) + set c := g.cycleOf x with hc_def + set d := c⁻¹ * g with hd_def + have hcyc : c.IsCycle := Equiv.Perm.isCycle_cycleOf g hgx + have hcd : g = c * d := by + rw [hd_def, mul_inv_cancel_left] + have hc_app : ∀ z, g.SameCycle x z → c z = g z := by + intro z hz + exact hz.cycleOf_apply + have hc_fix : ∀ z, ¬ g.SameCycle x z → c z = z := by + intro z hz + exact Equiv.Perm.cycleOf_apply_of_not_sameCycle hz + have hd_fix : ∀ z, g.SameCycle x z → d z = z := by + intro z hz + have h1 : c z = g z := hc_app z hz + rw [hd_def, Equiv.Perm.mul_apply, ← h1, Equiv.Perm.inv_def, + Equiv.symm_apply_apply] + have hd_app : ∀ z, ¬ g.SameCycle x z → d z = g z := by + intro z hz + have h1 : c⁻¹ (g z) = g z := by + have h2 : c (g z) = g z := by + refine hc_fix (g z) ?_ + intro hcon + exact hz ((Equiv.Perm.sameCycle_apply_right).mp hcon) + calc c⁻¹ (g z) = c⁻¹ (c (g z)) := by rw [h2] + _ = g z := by + rw [Equiv.Perm.inv_def] + exact Equiv.symm_apply_apply c (g z) + rw [hd_def, Equiv.Perm.mul_apply, h1] + have hdisj : Equiv.Perm.Disjoint c d := by + intro z + by_cases hz : g.SameCycle x z + · exact Or.inr (hd_fix z hz) + · exact Or.inl (hc_fix z hz) + have hxc : x ∈ c.support := by + rw [Equiv.Perm.mem_support_cycleOf_iff] + exact ⟨Equiv.Perm.SameCycle.refl g x, + Equiv.Perm.mem_support.mpr hgx⟩ + have hyc : y ∈ c.support := by + rw [Equiv.Perm.mem_support_cycleOf_iff] + exact ⟨hsc, Equiv.Perm.mem_support.mpr hgx⟩ + have hdisj2 : Equiv.Perm.Disjoint (Equiv.swap x y * c) d := by + intro z + by_cases hz : g.SameCycle x z + · exact Or.inr (hd_fix z hz) + · refine Or.inl ?_ + have hzx : z ≠ x := by + intro h + exact hz (h ▸ Equiv.Perm.SameCycle.refl g x) + have hzy : z ≠ y := by + intro h + exact hz (h ▸ hsc) + rw [Equiv.Perm.mul_apply, hc_fix z hz, + Equiv.swap_apply_of_ne_of_ne hzx hzy] + have hmul : Equiv.swap x y * g = + (Equiv.swap x y * c) * d := by + rw [mul_assoc, ← hcd] + -- counting + have hcount := swap_mul_cycle_count hcyc hxy hxc hyc + have hE1 := card_fixedPoints_add_card_support (Equiv.swap x y * g) + have hE2 := card_fixedPoints_add_card_support g + have hct1 : (Equiv.swap x y * g).cycleType = + (Equiv.swap x y * c).cycleType + d.cycleType := by + rw [hmul] + exact hdisj2.cycleType_mul + have hct2 : g.cycleType = c.cycleType + d.cycleType := by + rw [hcd] + exact hdisj.cycleType_mul + have hs1 : (Equiv.swap x y * g).support.card = + (Equiv.swap x y * c).support.card + d.support.card := by + rw [hmul, hdisj2.support_mul] + exact Finset.card_union_of_disjoint hdisj2.disjoint_support + have hs2 : g.support.card = c.support.card + d.support.card := by + rw [hcd, hdisj.support_mul] + exact Finset.card_union_of_disjoint hdisj.disjoint_support + have hcc : c.cycleType.card = 1 := by + rw [hcyc.cycleType] + rfl + have hcards1 := congrArg Multiset.card hct1 + have hcards2 := congrArg Multiset.card hct2 + rw [Multiset.card_add] at hcards1 hcards2 + unfold permOrbitCount at * + omega + +/-- **Merging**: multiplying by a transposition of two points on +different orbits lowers the orbit count by one. -/ +theorem permOrbitCount_swap_mul_not_sameCycle [Fintype Y] [DecidableEq Y] + {g : Perm Y} + {x y : Y} (hxy : x ≠ y) (hsc : ¬ g.SameCycle x y) : + permOrbitCount g = permOrbitCount (Equiv.swap x y * g) + 1 := by + have h2 : (Equiv.swap x y * g).SameCycle x y := + sameCycle_swap_mul_of_not hxy hsc + have h3 := permOrbitCount_swap_mul_sameCycle hxy h2 + rw [← mul_assoc, Equiv.swap_mul_self, one_mul] at h3 + exact h3 + +/-- **The coherent double swap**: with the mirror equivalence +`b ∼ c ↔ a ∼ d` and the two exclusions `a ≁ b`, `a ≁ c`, the double +transposition moves the orbit count by exactly two. -/ +theorem permOrbitCount_swap_swap_mul [Fintype Y] [DecidableEq Y] + {g : Perm Y} {a b c d : Y} + (hbc : b ≠ c) (had : a ≠ d) + (hiff : g.SameCycle b c ↔ g.SameCycle a d) + (hab : ¬ g.SameCycle a b) (hac : ¬ g.SameCycle a c) : + permOrbitCount (Equiv.swap a d * (Equiv.swap b c * g)) = + permOrbitCount g + 2 ∨ + permOrbitCount g = + permOrbitCount (Equiv.swap a d * (Equiv.swap b c * g)) + 2 + := by + have htrans := sameCycle_swap_mul_iff (g := g) (x := b) (y := c) + hab hac d + by_cases hbcs : g.SameCycle b c + · left + have h1 := permOrbitCount_swap_mul_sameCycle hbc hbcs + have h2 := permOrbitCount_swap_mul_sameCycle had + (htrans.mpr (hiff.mp hbcs)) + omega + · right + have h1 := permOrbitCount_swap_mul_not_sameCycle hbc hbcs + have h2 := permOrbitCount_swap_mul_not_sameCycle had + (fun h => (fun hcon => hbcs (hiff.mpr hcon)) (htrans.mp h)) + omega + +/-- Transporting a permutation along an equivalence preserves the +orbit count. -/ +theorem permOrbitCount_permCongr {γ δ : Type} [Fintype γ] + [DecidableEq γ] [Fintype δ] [DecidableEq δ] + (e : γ ≃ δ) (g : Perm γ) : + permOrbitCount (e.permCongr g) = permOrbitCount g := by + unfold permOrbitCount + rw [cycleType_permCongr, card_fixedPoints_permCongr] + +/-- The orbit count of a `sumCongr` is the sum of the orbit +counts. -/ +theorem permOrbitCount_sumCongr {γ δ : Type} [Fintype γ] + [DecidableEq γ] [Fintype δ] [DecidableEq δ] + (σ : Perm γ) (τ : Perm δ) : + permOrbitCount (Equiv.sumCongr σ τ) = + permOrbitCount σ + permOrbitCount τ := by + unfold permOrbitCount + rw [cycleType_sumCongr, Multiset.card_add, + card_fixedPoints_sumCongr] + omega + +end AbstractOrbit + +/-! ## (ii) The closed-up full walk permutation -/ + +namespace EdgeSubset + +variable {α : Type} {W : Fragment α} {F : EdgeSubset W} + +/-- The edge pairing as a permutation of the participating flags. -/ +noncomputable def pairingPermSP (F : EdgeSubset W) : + Equiv.Perm {f : W.Flag // f ∈ F.flags} where + toFun x := ⟨W.pairing x.val, F.pairing_mem x.val x.prop⟩ + invFun x := ⟨W.pairing x.val, F.pairing_mem x.val x.prop⟩ + left_inv x := Subtype.ext (W.pairing_invol x.val) + right_inv x := Subtype.ext (W.pairing_invol x.val) + +/-- The edge pairing as a permutation of participating flags, on +underlying flags. -/ +@[simp] theorem pairingPermSP_val (x : {f : W.Flag // f ∈ F.flags}) : + (pairingPermSP F x).val = W.pairing x.val := rfl + +/-- It is an involution. -/ +theorem pairingPermSP_invol (x : {f : W.Flag // f ∈ F.flags}) : + pairingPermSP F (pairingPermSP F x) = x := + Subtype.ext (W.pairing_invol x.val) + +/-- Equivalently, its square is the identity. -/ +theorem pairingPermSP_mul_self : + pairingPermSP F * pairingPermSP F = 1 := by + apply Equiv.ext + intro x + exact pairingPermSP_invol x + +/-- The matching extended by the path matching, as a function on +participating flags. -/ +noncomputable def fullMatchFun (κ : F.RelTransitionSystem) + (x : {f : W.Flag // f ∈ F.flags}) : + {f : W.Flag // f ∈ F.flags} := + if h : x.val ∈ F.internalFlags then + ⟨κ.match_ x.val, + mem_flags_of_internalFlags F (κ.match_mem x.val h)⟩ + else + ⟨κ.pathMatch x.val + ((F.mem_internalFlags_or_boundaryFlags x.prop).resolve_left + h), + mem_flags_of_boundaryFlags F (κ.pathMatch_mem _)⟩ + +/-- The full matching is the system's own on internal flags. -/ +theorem fullMatchFun_val_internal (κ : F.RelTransitionSystem) + {x : {f : W.Flag // f ∈ F.flags}} + (h : x.val ∈ F.internalFlags) : + (fullMatchFun κ x).val = κ.match_ x.val := by + unfold fullMatchFun + rw [dite_eq_left h] + +/-- And the path matching on boundary flags: this is what closes +the chains into orbits. -/ +theorem fullMatchFun_val_boundary (κ : F.RelTransitionSystem) + {x : {f : W.Flag // f ∈ F.flags}} + (h : x.val ∈ F.boundaryFlags) : + (fullMatchFun κ x).val = κ.pathMatch x.val h := by + have hni : x.val ∉ F.internalFlags := + Finset.disjoint_right.mp F.internalFlags_disjoint_boundaryFlags + h + unfold fullMatchFun + rw [dite_eq_right hni] + +/-- The full matching is an involution, both halves being ones. -/ +theorem fullMatchFun_invol (κ : F.RelTransitionSystem) + (x : {f : W.Flag // f ∈ F.flags}) : + fullMatchFun κ (fullMatchFun κ x) = x := by + by_cases h : x.val ∈ F.internalFlags + · have h1 : (fullMatchFun κ x).val = κ.match_ x.val := + fullMatchFun_val_internal κ h + have h2 : (fullMatchFun κ x).val ∈ F.internalFlags := by + rw [h1] + exact κ.match_mem x.val h + apply Subtype.ext + rw [fullMatchFun_val_internal κ h2, h1] + exact κ.match_invol x.val h + · have hb : x.val ∈ F.boundaryFlags := + (F.mem_internalFlags_or_boundaryFlags x.prop).resolve_left h + have h1 : (fullMatchFun κ x).val = κ.pathMatch x.val hb := + fullMatchFun_val_boundary κ hb + have h2 : (fullMatchFun κ x).val ∈ F.boundaryFlags := by + rw [h1] + exact κ.pathMatch_mem hb + apply Subtype.ext + rw [fullMatchFun_val_boundary κ h2] + have h3 := κ.pathMatch_congr h1 h2 (κ.pathMatch_mem hb) + rw [h3] + exact κ.pathMatch_invol hb + +/-- The extended matching as an (involutive) permutation. -/ +noncomputable def fullMatchPerm (κ : F.RelTransitionSystem) : + Equiv.Perm {f : W.Flag // f ∈ F.flags} where + toFun := fullMatchFun κ + invFun := fullMatchFun κ + left_inv := fullMatchFun_invol κ + right_inv := fullMatchFun_invol κ + +/-- The full matching as a permutation acts by that function. -/ +@[simp] theorem fullMatchPerm_apply (κ : F.RelTransitionSystem) + (x : {f : W.Flag // f ∈ F.flags}) : + fullMatchPerm κ x = fullMatchFun κ x := rfl + +/-- Its square is the identity. -/ +theorem fullMatchPerm_mul_self (κ : F.RelTransitionSystem) : + fullMatchPerm κ * fullMatchPerm κ = 1 := by + apply Equiv.ext + intro x + exact fullMatchFun_invol κ x + +/-- **The full walk permutation**: pairing followed by extended +matching, a permutation of all participating flags. -/ +noncomputable def fullPerm (κ : F.RelTransitionSystem) : + Equiv.Perm {f : W.Flag // f ∈ F.flags} := + fullMatchPerm κ * pairingPermSP F + +/-- **The full walk**: cross the edge, then match — including at +the boundary, where matching follows the chain to its far end. -/ +theorem fullPerm_apply (κ : F.RelTransitionSystem) + (x : {f : W.Flag // f ∈ F.flags}) : + fullPerm κ x = fullMatchFun κ (pairingPermSP F x) := rfl + +/-- Its value when the edge partner is internal. -/ +theorem fullPerm_val_internal {κ : F.RelTransitionSystem} + {x : {f : W.Flag // f ∈ F.flags}} + (h : W.pairing x.val ∈ F.internalFlags) : + (fullPerm κ x).val = κ.match_ (W.pairing x.val) := + fullMatchFun_val_internal κ (x := pairingPermSP F x) h + +/-- Its value when the edge partner is a boundary flag. -/ +theorem fullPerm_val_boundary {κ : F.RelTransitionSystem} + {x : {f : W.Flag // f ∈ F.flags}} + (h : W.pairing x.val ∈ F.boundaryFlags) : + (fullPerm κ x).val = κ.pathMatch (W.pairing x.val) h := + fullMatchFun_val_boundary κ (x := pairingPermSP F x) h + +/-- Applying the full walk to a paired flag lands on the extended +matching. -/ +theorem fullPerm_apply_pairing (κ : F.RelTransitionSystem) + (x : {f : W.Flag // f ∈ F.flags}) : + fullPerm κ (pairingPermSP F x) = fullMatchFun κ x := by + rw [fullPerm_apply, pairingPermSP_invol] + +/-- The inverse of the full walk. -/ +theorem fullPerm_inv (κ : F.RelTransitionSystem) : + (fullPerm κ)⁻¹ = pairingPermSP F * fullMatchPerm κ := by + rw [inv_eq_iff_mul_eq_one] + unfold fullPerm + rw [mul_assoc, ← mul_assoc (pairingPermSP F), pairingPermSP_mul_self, + one_mul, fullMatchPerm_mul_self] + +/-- **Mirror symmetry**: the pairing conjugates the full walk to +its inverse, so `SameCycle` transfers to paired flags. -/ +theorem sameCycle_pairingPermSP {κ : F.RelTransitionSystem} + {x y : {f : W.Flag // f ∈ F.flags}} + (h : (fullPerm κ).SameCycle x y) : + (fullPerm κ).SameCycle (pairingPermSP F x) (pairingPermSP F y) := by + have hconj : pairingPermSP F * fullPerm κ * (pairingPermSP F)⁻¹ = + (fullPerm κ)⁻¹ := by + have hp : (pairingPermSP F)⁻¹ = pairingPermSP F := by + rw [inv_eq_iff_mul_eq_one] + exact pairingPermSP_mul_self + rw [hp, fullPerm_inv] + unfold fullPerm + rw [← mul_assoc, mul_assoc (pairingPermSP F * fullMatchPerm κ), + pairingPermSP_mul_self, mul_one] + have h2 := h.conj (g := pairingPermSP F) + rw [hconj] at h2 + exact (Equiv.Perm.sameCycle_inv).mp h2 + +/-! ### Trajectories of the full walk -/ + +/-- While the pairings along a walk stay internal, powers of the +full walk follow the iterated walk. -/ +theorem fullPerm_pow_val {κ : F.RelTransitionSystem} + {x : {f : W.Flag // f ∈ F.flags}} {m : ℕ} + (hcont : ∀ t, t < m → + W.pairing (iterWalk κ x.val t) ∈ F.internalFlags) : + ∀ j, j ≤ m → ((fullPerm κ ^ j) x).val = iterWalk κ x.val j := by + intro j + induction j with + | zero => intro _; rfl + | succ j ih => + intro hj + have h1 : (fullPerm κ ^ (j + 1)) x = + fullPerm κ ((fullPerm κ ^ j) x) := by + rw [pow_succ', Equiv.Perm.mul_apply] + have h2 : W.pairing (((fullPerm κ ^ j) x).val) ∈ + F.internalFlags := by + rw [ih (by omega)] + exact hcont j (by omega) + rw [h1, fullPerm_val_internal h2, ih (by omega)] + exact (iterWalk_succ κ x.val j).symm + +/-- Powers of the full walk at a periodic flag follow the iterated +walk forever. -/ +theorem fullPerm_pow_val_periodic {κ : F.RelTransitionSystem} + {x : {f : W.Flag // f ∈ F.flags}} + (hper : κ.PeriodicFlag x.val) (j : ℕ) : + ((fullPerm κ ^ j) x).val = iterWalk κ x.val j := + fullPerm_pow_val (m := j) + (fun t _ => all_pairings_internal_of_periodic κ hper t) j + le_rfl + +/-- `SameCycle` from a periodic flag produces a walk witness. -/ +theorem sameCycle_periodic_val {κ : F.RelTransitionSystem} + {x y : {f : W.Flag // f ∈ F.flags}} + (hper : κ.PeriodicFlag x.val) + (h : (fullPerm κ).SameCycle x y) : + ∃ i : ℕ, iterWalk κ x.val i = y.val := by + obtain ⟨i, _, _, hiy⟩ := Equiv.Perm.SameCycle.exists_pow_eq _ h + refine ⟨i, ?_⟩ + rw [← fullPerm_pow_val_periodic hper i, hiy] + +/-- **Mirror collision, periodic case**: a periodic flag is never +on the same full-walk orbit as its pairing. -/ +theorem not_sameCycle_pairingPermSP_of_periodic {κ : F.RelTransitionSystem} + {x : {f : W.Flag // f ∈ F.flags}} + (hper : κ.PeriodicFlag x.val) : + ¬ (fullPerm κ).SameCycle x (pairingPermSP F x) := by + intro h + obtain ⟨i, hi⟩ := sameCycle_periodic_val hper h + refine pairing_iterWalk_ne κ + (fun t _ => all_pairings_internal_of_periodic κ hper t) + (Nat.zero_le i) (le_refl i) ?_ + rw [iterWalk_zero] + exact hi.symm + +/-! ### Chain orbits of the full walk -/ + +section ChainOrbit + +variable {κ : F.RelTransitionSystem} {β : W.Flag} + (hβ : β ∈ F.boundaryFlags) {k : ℕ} (hkle : k ≤ F.flags.card) + (hcont : ∀ j, j < k → + W.pairing (iterWalk κ β j) ∈ F.internalFlags) + (hterm : W.pairing (iterWalk κ β k) ∈ F.boundaryFlags) + +include hβ hkle hcont hterm + +/-- **The chain wraps**: the full walk from a boundary flag closes +up after `k + 1` steps (through the path-matching jump). -/ +theorem fullPerm_chain_wrap : + (fullPerm κ ^ (k + 1)) ⟨β, mem_flags_of_boundaryFlags F hβ⟩ = + ⟨β, mem_flags_of_boundaryFlags F hβ⟩ := by + have hpow : (fullPerm κ ^ (k + 1)) + (⟨β, mem_flags_of_boundaryFlags F hβ⟩ : + {f : W.Flag // f ∈ F.flags}) = + fullPerm κ ((fullPerm κ ^ k) + ⟨β, mem_flags_of_boundaryFlags F hβ⟩) := by + rw [pow_succ', Equiv.Perm.mul_apply] + have hval : ((fullPerm κ ^ k) + (⟨β, mem_flags_of_boundaryFlags F hβ⟩ : + {f : W.Flag // f ∈ F.flags})).val = iterWalk κ β k := + fullPerm_pow_val hcont k le_rfl + apply Subtype.ext + rw [hpow] + have h2 : W.pairing (((fullPerm κ ^ k) + (⟨β, mem_flags_of_boundaryFlags F hβ⟩ : + {f : W.Flag // f ∈ F.flags})).val) ∈ F.boundaryFlags := by + rw [hval] + exact hterm + rw [fullPerm_val_boundary h2] + have hγ : κ.pathMatch β hβ = W.pairing (iterWalk κ β k) := + κ.pathMatch_eq hβ (traceChain_fuel_mono κ (by omega) + (traceChain_forward κ β hcont hterm)) + have hγpm' : κ.pathMatch (W.pairing (iterWalk κ β k)) hterm = + β := + calc κ.pathMatch (W.pairing (iterWalk κ β k)) hterm + = κ.pathMatch (κ.pathMatch β hβ) (κ.pathMatch_mem hβ) := + κ.pathMatch_congr hγ.symm hterm _ + _ = β := κ.pathMatch_invol hβ + calc κ.pathMatch (W.pairing (((fullPerm κ ^ k) + (⟨β, mem_flags_of_boundaryFlags F hβ⟩ : + {f : W.Flag // f ∈ F.flags})).val)) h2 + = κ.pathMatch (W.pairing (iterWalk κ β k)) hterm := + κ.pathMatch_congr (congrArg W.pairing hval) h2 hterm + _ = β := hγpm' + +/-- Values on the full-walk orbit of a boundary flag are chain +values. -/ +theorem fullPerm_chain_sameCycle_val {z : {f : W.Flag // f ∈ F.flags}} + (h : (fullPerm κ).SameCycle + ⟨β, mem_flags_of_boundaryFlags F hβ⟩ z) : + ∃ j, j ≤ k ∧ z.val = iterWalk κ β j := by + obtain ⟨i, _, _, hiz⟩ := Equiv.Perm.SameCycle.exists_pow_eq _ h + rw [perm_pow_mod (p := k + 1) (by omega) + (fullPerm_chain_wrap hβ hkle hcont hterm) i] at hiz + have hlt : i % (k + 1) < k + 1 := Nat.mod_lt i (by omega) + refine ⟨i % (k + 1), by omega, ?_⟩ + rw [← hiz, fullPerm_pow_val hcont _ (by omega)] + +/-- A boundary flag on the full-walk orbit of a boundary flag is +the base point. -/ +theorem fullPerm_chain_boundary_eq {z : {f : W.Flag // f ∈ F.flags}} + (h : (fullPerm κ).SameCycle + ⟨β, mem_flags_of_boundaryFlags F hβ⟩ z) + (hzb : z.val ∈ F.boundaryFlags) : + z = ⟨β, mem_flags_of_boundaryFlags F hβ⟩ := by + obtain ⟨j, hjk, hjv⟩ := + fullPerm_chain_sameCycle_val hβ hkle hcont hterm h + rcases Nat.eq_zero_or_pos j with rfl | hj1 + · rw [iterWalk_zero] at hjv + exact Subtype.ext hjv + · exfalso + have hint : iterWalk κ β j ∈ F.internalFlags := + iterWalk_mem_internal κ k hj1 hjk hcont + rw [← hjv] at hint + exact Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags hint hzb + +/-- **Mirror collision, chain case**: a chain flag is never on the +same full-walk orbit as its pairing. -/ +theorem not_sameCycle_pairingPermSP_of_chain {f : W.Flag} + (hfi : f ∈ F.flags) {t : ℕ} (htk : t ≤ k) + (hft : f = iterWalk κ β t ∨ f = W.pairing (iterWalk κ β t)) : + ¬ (fullPerm κ).SameCycle ⟨f, hfi⟩ + (pairingPermSP F ⟨f, hfi⟩) := by + intro h + rcases hft with hf1 | hf1 + · -- walk-side flag: the pairing would be a chain value + have hx : (⟨f, hfi⟩ : {g : W.Flag // g ∈ F.flags}) = + (fullPerm κ ^ t) ⟨β, mem_flags_of_boundaryFlags F hβ⟩ := + Subtype.ext (by rw [fullPerm_pow_val hcont t htk]; exact hf1) + have hbx : (fullPerm κ).SameCycle + ⟨β, mem_flags_of_boundaryFlags F hβ⟩ ⟨f, hfi⟩ := by + rw [hx] + exact sameCycle_of_pow_eq rfl + obtain ⟨j, hjk, hjv⟩ := fullPerm_chain_sameCycle_val hβ hkle + hcont hterm (hbx.trans h) + have hjv' : W.pairing (iterWalk κ β t) = iterWalk κ β j := by + rw [← hf1] + exact hjv + exact pairing_iterWalk_ne κ hcont htk hjk hjv' + · -- pairing-side flag: the flag itself would be a chain value + have hσx : pairingPermSP F (⟨f, hfi⟩ : + {g : W.Flag // g ∈ F.flags}) = + (fullPerm κ ^ t) ⟨β, mem_flags_of_boundaryFlags F hβ⟩ := by + refine Subtype.ext ?_ + rw [fullPerm_pow_val hcont t htk, pairingPermSP_val] + change W.pairing f = iterWalk κ β t + rw [hf1, W.pairing_invol] + have hbσ : (fullPerm κ).SameCycle + ⟨β, mem_flags_of_boundaryFlags F hβ⟩ + (pairingPermSP F ⟨f, hfi⟩) := by + rw [hσx] + exact sameCycle_of_pow_eq rfl + obtain ⟨j, hjk, hjv⟩ := fullPerm_chain_sameCycle_val hβ hkle + hcont hterm (hbσ.trans h.symm) + have hjv' : W.pairing (iterWalk κ β t) = iterWalk κ β j := by + rw [← hf1] + exact hjv + exact pairing_iterWalk_ne κ hcont htk hjk hjv' + +omit hβ hkle hterm in +/-- **Orientation constancy** along the walk side of a chain. -/ +theorem isOut_iterWalk_chain (o : κ.Orientation) {i j : ℕ} + (hi1 : 1 ≤ i) (hij : i ≤ j) (hjk : j ≤ k) : + o.isOut (iterWalk κ β j) = o.isOut (iterWalk κ β i) := by + induction j with + | zero => omega + | succ j ih => + rcases Nat.eq_or_lt_of_le hij with heq | hlt + · rw [heq] + · have hj1 : 1 ≤ j := by omega + have hstep : o.isOut (iterWalk κ β (j + 1)) = + o.isOut (iterWalk κ β j) := by + rw [iterWalk_succ, o.match_flip _ (hcont j (by omega)), + o.pairing_flip _ + (iterWalk_mem_internal κ k hj1 (by omega) hcont) + (hcont j (by omega)), + Bool.not_not] + rw [hstep] + exact ih (by omega) (by omega) + +omit hβ hkle hterm in +/-- The pairing-side orientation along a chain. -/ +theorem isOut_pairing_iterWalk_chain (o : κ.Orientation) {j : ℕ} + (hjk : j < k) : + o.isOut (W.pairing (iterWalk κ β j)) = + !o.isOut (iterWalk κ β (j + 1)) := by + have h := o.match_flip _ (hcont j hjk) + rw [← iterWalk_succ] at h + rw [h, Bool.not_not] + +end ChainOrbit + +/-! ### The periodic/chain decomposition of the orbit count -/ + +section Decompose + +variable (κ : F.RelTransitionSystem) + +/-- Exit data from a terminating chain (a `LinearOrder`-free copy +of `traceChain_some_exit`). -/ +private theorem traceChain_exit_data (κ : F.RelTransitionSystem) : + ∀ (fuel : ℕ) (f b : W.Flag), traceChain κ fuel f = some b → + ∃ k, (∀ j, j < k → + W.pairing (iterWalk κ f j) ∈ F.internalFlags) ∧ + W.pairing (iterWalk κ f k) = b ∧ b ∈ F.boundaryFlags := by + intro fuel + induction fuel with + | zero => intro f b h; simp [traceChain] at h + | succ n ih => + intro f b h + by_cases hb : W.pairing f ∈ F.boundaryFlags + · rw [traceChain_boundary κ n f hb] at h + refine ⟨0, fun j hj => absurd hj (by omega), ?_, ?_⟩ + · simpa using Option.some.inj h + · rw [← Option.some.inj h]; exact hb + · by_cases hi : W.pairing f ∈ F.internalFlags + · rw [traceChain_internal κ n f hi] at h + obtain ⟨k, hcont, hexit, hbb⟩ := + ih (κ.match_ (W.pairing f)) b h + refine ⟨k + 1, ?_, ?_, hbb⟩ + · intro j hj + cases j with + | zero => simpa using hi + | succ j' => + have hstep := hcont j' (by omega) + rwa [iterWalk_shift] at hstep + · rwa [iterWalk_shift] at hexit + · rw [traceChain_neither κ n f hb hi] at h; cases h + +/-- The full walk preserves periodicity. -/ +theorem fullPerm_periodic_iff (x : {f : W.Flag // f ∈ F.flags}) : + (fullPerm κ x).val ∈ κ.periodicFlags ↔ + x.val ∈ κ.periodicFlags := by + constructor + · intro h + have hper : κ.PeriodicFlag ((fullPerm κ x).val) := + (κ.mem_periodicFlags).mp h + have hzint : (fullPerm κ x).val ∈ F.internalFlags := + hper.mem_internal + have hx : ((fullPerm κ)⁻¹ (fullPerm κ x)) = x := by + rw [Equiv.Perm.inv_def] + exact Equiv.symm_apply_apply _ _ + have h1 : ((fullPerm κ)⁻¹ (fullPerm κ x)).val = + W.pairing (κ.match_ ((fullPerm κ x).val)) := by + rw [fullPerm_inv] + change (pairingPermSP F + (fullMatchPerm κ (fullPerm κ x))).val = _ + rw [pairingPermSP_val, fullMatchPerm_apply, + fullMatchFun_val_internal κ hzint] + rw [hx] at h1 + rw [κ.mem_periodicFlags, h1] + exact periodicFlag_pairing (periodicFlag_match hper) + · intro h + have hper : κ.PeriodicFlag x.val := (κ.mem_periodicFlags).mp h + have hσ : W.pairing x.val ∈ F.internalFlags := by + have h0 := all_pairings_internal_of_periodic κ hper 0 + rwa [iterWalk_zero] at h0 + rw [κ.mem_periodicFlags, fullPerm_val_internal hσ, + show κ.match_ (W.pairing x.val) = iterWalk κ x.val 1 from + rfl] + exact periodicFlag_iterWalk κ hper 1 + +/-- The full walk restricted to periodic flags. -/ +noncomputable def fullPermPeriodic : + Equiv.Perm {x : {f : W.Flag // f ∈ F.flags} // + x.val ∈ κ.periodicFlags} := + (fullPerm κ).subtypePerm (fun x => fullPerm_periodic_iff κ x) + +/-- The full walk restricted to non-periodic flags. -/ +noncomputable def fullPermChain : + Equiv.Perm {x : {f : W.Flag // f ∈ F.flags} // + ¬ x.val ∈ κ.periodicFlags} := + (fullPerm κ).subtypePerm + (fun x => not_congr (fullPerm_periodic_iff κ x)) + +/-- The decomposition of the full walk over the periodicity +partition. -/ +theorem fullPerm_eq_sumCongr : + fullPerm κ = (Equiv.sumCompl + (fun x : {f : W.Flag // f ∈ F.flags} => + x.val ∈ κ.periodicFlags)).permCongr + (Equiv.sumCongr (fullPermPeriodic κ) (fullPermChain κ)) := by + apply Equiv.ext + intro z + rw [Equiv.permCongr_apply] + by_cases h : z.val ∈ κ.periodicFlags + · rw [Equiv.sumCompl_symm_apply_of_pos + (p := fun x : {f : W.Flag // f ∈ F.flags} => + x.val ∈ κ.periodicFlags) h] + rfl + · rw [Equiv.sumCompl_symm_apply_of_neg + (p := fun x : {f : W.Flag // f ∈ F.flags} => + x.val ∈ κ.periodicFlags) h] + rfl + +/-- The orbit count splits over the partition. -/ +theorem permOrbitCount_fullPerm_split : + permOrbitCount (fullPerm κ) = + permOrbitCount (fullPermPeriodic κ) + + permOrbitCount (fullPermChain κ) := by + rw [fullPerm_eq_sumCongr κ, permOrbitCount_permCongr, + permOrbitCount_sumCongr] + +/-- The double-subtype carrier of the periodic part. -/ +noncomputable def periodicSubEquiv : + {x : {f : W.Flag // f ∈ F.flags} // + x.val ∈ κ.periodicFlags} ≃ + {f : W.Flag // f ∈ κ.periodicFlags} where + toFun x := ⟨x.val.val, x.prop⟩ + invFun f := ⟨⟨f.val, mem_flags_of_internalFlags F + (κ.periodicFlags_sub f.prop)⟩, f.prop⟩ + left_inv _x := Subtype.ext (Subtype.ext rfl) + right_inv _f := rfl + +/-- The periodic part of the full walk is the periodic walk +permutation. -/ +theorem walkPermPeriodic_eq_permCongr : + κ.walkPermPeriodic = + (periodicSubEquiv κ).permCongr (fullPermPeriodic κ) := by + apply Equiv.ext + intro f + apply Subtype.ext + rw [Equiv.permCongr_apply] + have hσ : W.pairing f.val ∈ F.internalFlags := by + have h0 := all_pairings_internal_of_periodic κ + ((κ.mem_periodicFlags).mp f.prop) 0 + rwa [iterWalk_zero] at h0 + change κ.internalWalk f.val = + ((fullPerm κ) ⟨f.val, mem_flags_of_internalFlags F + (κ.periodicFlags_sub f.prop)⟩).val + rw [fullPerm_val_internal hσ] + rfl + +/-- The periodic part has the periodic orbit count. -/ +theorem permOrbitCount_fullPermPeriodic : + permOrbitCount (fullPermPeriodic κ) = + permOrbitCount κ.walkPermPeriodic := by + rw [walkPermPeriodic_eq_permCongr κ, permOrbitCount_permCongr] + +/-- Values of powers of the chain part. -/ +theorem fullPermChain_pow_val (z : {x : {f : W.Flag // f ∈ F.flags} // + ¬ x.val ∈ κ.periodicFlags}) (n : ℕ) : + (((fullPermChain κ) ^ n) z).val = ((fullPerm κ) ^ n) z.val := by + induction n with + | zero => rfl + | succ n ih => + have h1 : ((fullPermChain κ) ^ (n + 1)) z = + (fullPermChain κ) (((fullPermChain κ) ^ n) z) := by + rw [pow_succ', Equiv.Perm.mul_apply] + have h2 : ((fullPerm κ) ^ (n + 1)) z.val = + (fullPerm κ) (((fullPerm κ) ^ n) z.val) := by + rw [pow_succ', Equiv.Perm.mul_apply] + rw [h1, h2, ← ih] + rfl + +/-- `SameCycle` in the chain part descends to the full walk. -/ +theorem sameCycle_fullPermChain_val {z w : {x : {f : W.Flag // f ∈ F.flags} // + ¬ x.val ∈ κ.periodicFlags}} + (h : (fullPermChain κ).SameCycle z w) : + (fullPerm κ).SameCycle z.val w.val := by + obtain ⟨i, _, _, hi⟩ := Equiv.Perm.SameCycle.exists_pow_eq _ h + refine sameCycle_of_pow_eq (n := i) ?_ + rw [← fullPermChain_pow_val, hi] + +/-- **The chain part counts the boundary flags**: each non-periodic +orbit contains exactly one boundary flag. -/ +theorem permOrbitCount_fullPermChain : + permOrbitCount (fullPermChain κ) = F.boundaryFlags.card := by + classical + have hres := permOrbitCount_eq_card_of_reps (fullPermChain κ) + (Finset.univ.filter (fun z => z.val.val ∈ F.boundaryFlags)) + ?_ ?_ + · rw [hres] + refine Finset.card_bij' (fun z _ => z.val.val) + (fun b hb => ⟨⟨b, mem_flags_of_boundaryFlags F hb⟩, + fun hper => Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags + (κ.periodicFlags_sub hper) hb⟩) ?_ ?_ ?_ ?_ + · intro z hz + exact (Finset.mem_filter.mp hz).2 + · intro b hb + refine Finset.mem_filter.mpr ⟨Finset.mem_univ _, hb⟩ + · intro z _ + exact Subtype.ext (Subtype.ext rfl) + · intro b _ + rfl + · -- cover + intro z + by_cases hzb : z.val.val ∈ F.boundaryFlags + · exact ⟨z, Finset.mem_filter.mpr ⟨Finset.mem_univ _, hzb⟩, + Equiv.Perm.SameCycle.refl _ _⟩ + · have hzi : z.val.val ∈ F.internalFlags := + (F.mem_internalFlags_or_boundaryFlags + z.val.prop).resolve_right hzb + have hznp : ¬ κ.PeriodicFlag z.val.val := fun hper => + z.prop ((κ.mem_periodicFlags).mpr hper) + rcases internal_periodic_or_terminates κ z.val.val hzi with + hper | ⟨fuel, b0, htr⟩ + · exact absurd hper hznp + obtain ⟨kf, hcontf, hexitf, hb0⟩ := + traceChain_exit_data κ fuel z.val.val b0 htr + refine ⟨((fullPermChain κ) ^ (kf + 1)) z, ?_, ?_⟩ + · refine Finset.mem_filter.mpr ⟨Finset.mem_univ _, ?_⟩ + rw [fullPermChain_pow_val] + have h1 : ((fullPerm κ) ^ (kf + 1)) z.val = + fullPerm κ (((fullPerm κ) ^ kf) z.val) := by + rw [pow_succ', Equiv.Perm.mul_apply] + have hval : (((fullPerm κ) ^ kf) z.val).val = + iterWalk κ z.val.val kf := + fullPerm_pow_val (fun t ht => hcontf t ht) kf le_rfl + have hb : W.pairing ((((fullPerm κ) ^ kf) z.val).val) ∈ + F.boundaryFlags := by + rw [hval, hexitf] + exact hb0 + rw [h1, fullPerm_val_boundary hb] + exact κ.pathMatch_mem hb + · exact (sameCycle_of_pow_eq (n := kf + 1) rfl).symm + · -- separation + intro w hw w' hw' hsc + have hwb : w.val.val ∈ F.boundaryFlags := + (Finset.mem_filter.mp hw).2 + have hwb' : w'.val.val ∈ F.boundaryFlags := + (Finset.mem_filter.mp hw').2 + have hscv : (fullPerm κ).SameCycle w.val w'.val := + sameCycle_fullPermChain_val κ hsc + obtain ⟨k, hkle, hcont, hterm⟩ := + chain_terminates_with_data κ hwb + have hb : (fullPerm κ).SameCycle + ⟨w.val.val, mem_flags_of_boundaryFlags F hwb⟩ w'.val := + hscv + have := fullPerm_chain_boundary_eq hwb hkle hcont hterm hb + hwb' + apply Subtype.ext + apply Subtype.ext + exact congrArg Subtype.val this.symm + +/-- **The orbit bookkeeping**: the full walk's orbit count is the +periodic orbit count plus the number of boundary flags. -/ +theorem permOrbitCount_fullPerm_eq : + permOrbitCount (fullPerm κ) = + permOrbitCount κ.walkPermPeriodic + F.boundaryFlags.card := by + rw [permOrbitCount_fullPerm_split κ, + permOrbitCount_fullPermPeriodic κ, + permOrbitCount_fullPermChain κ] + +end Decompose + +/-! ### The move as a double swap -/ + +section RepairFull + +variable {κ : F.RelTransitionSystem} {a b c d : W.Flag} + {v : W.Vertex} + +/-- **The move is a double swap**: on a square whose repair leaves +the path matching unchanged, the repaired full walk is the old full +walk multiplied by the double transposition `(a d)(b c)`. -/ +theorem fullPerm_repair (hsq : RepairSquare κ a b c d v) + (hpm : ∀ δ (hδ : δ ∈ F.boundaryFlags), + (κ.repair a b c d v hsq).pathMatch δ hδ = + κ.pathMatch δ hδ) : + fullPerm (κ.repair a b c d v hsq) = + Equiv.swap ⟨a, mem_flags_of_internalFlags F hsq.ha⟩ + ⟨d, mem_flags_of_internalFlags F hsq.hd⟩ * + (Equiv.swap ⟨b, mem_flags_of_internalFlags F hsq.hb⟩ + ⟨c, mem_flags_of_internalFlags F hsq.hc⟩ * + fullPerm κ) := by + set aX : {f : W.Flag // f ∈ F.flags} := + ⟨a, mem_flags_of_internalFlags F hsq.ha⟩ with haX + set bX : {f : W.Flag // f ∈ F.flags} := + ⟨b, mem_flags_of_internalFlags F hsq.hb⟩ with hbX + set cX : {f : W.Flag // f ∈ F.flags} := + ⟨c, mem_flags_of_internalFlags F hsq.hc⟩ with hcX + set dX : {f : W.Flag // f ∈ F.flags} := + ⟨d, mem_flags_of_internalFlags F hsq.hd⟩ with hdX + have hval_a : aX.val = a := rfl + have hval_b : bX.val = b := rfl + have hval_c : cX.val = c := rfl + have hval_d : dX.val = d := rfl + have hne_ca : cX ≠ aX := fun h => + hsq.hac (by rw [← hval_a, ← hval_c, h]) + -- ═══════ THE SQUARE'S FOUR FLAGS ARE PAIRWISE DISTINCT ═══════ + -- Below: the repaired walk permutation is the old one times two + -- transpositions, and its cycle count follows. + have hne_cd : cX ≠ dX := fun h => + hsq.hdc (by rw [← hval_c, ← hval_d, h]) + have hne_ab : aX ≠ bX := fun h => + hsq.hba (by rw [← hval_a, ← hval_b, h]) + have hne_ac : aX ≠ cX := fun h => + hsq.hac (by rw [← hval_a, ← hval_c, h]) + have hne_db : dX ≠ bX := fun h => + hsq.hbd (by rw [← hval_b, ← hval_d, h]) + have hne_dc : dX ≠ cX := fun h => + hsq.hdc (by rw [← hval_c, ← hval_d, h]) + have hne_ba : bX ≠ aX := fun h => + hsq.hba (by rw [← hval_a, ← hval_b, h]) + have hne_bd : bX ≠ dX := fun h => + hsq.hbd (by rw [← hval_b, ← hval_d, h]) + apply Equiv.ext + intro z + apply Subtype.ext + rw [Equiv.Perm.mul_apply, Equiv.Perm.mul_apply] + by_cases hσi : W.pairing z.val ∈ F.internalFlags + · by_cases h1 : W.pairing z.val = a + · have hPi : fullPerm κ z = bX := Subtype.ext + (by rw [fullPerm_val_internal hσi, h1, hval_b] + exact hsq.hab) + rw [hPi, Equiv.swap_apply_left, + Equiv.swap_apply_of_ne_of_ne hne_ca hne_cd, + fullPerm_val_internal (κ := κ.repair a b c d v hsq) hσi, + h1, RelTransitionSystem.repair_match_a hsq] + · by_cases h2 : W.pairing z.val = b + · have hPi : fullPerm κ z = aX := Subtype.ext + (by rw [fullPerm_val_internal hσi, h2, hval_a] + exact hsq.hmb) + rw [hPi, Equiv.swap_apply_of_ne_of_ne hne_ab hne_ac, + Equiv.swap_apply_left, + fullPerm_val_internal (κ := κ.repair a b c d v hsq) hσi, + h2, RelTransitionSystem.repair_match_b hsq] + · by_cases h3 : W.pairing z.val = c + · have hPi : fullPerm κ z = dX := Subtype.ext + (by rw [fullPerm_val_internal hσi, h3, hval_d] + exact hsq.hcd) + rw [hPi, Equiv.swap_apply_of_ne_of_ne hne_db hne_dc, + Equiv.swap_apply_right, + fullPerm_val_internal (κ := κ.repair a b c d v hsq) + hσi, + h3, RelTransitionSystem.repair_match_c hsq] + · by_cases h4 : W.pairing z.val = d + · have hPi : fullPerm κ z = cX := Subtype.ext + (by rw [fullPerm_val_internal hσi, h4, hval_c] + exact hsq.hmd) + rw [hPi, Equiv.swap_apply_right, + Equiv.swap_apply_of_ne_of_ne hne_ba hne_bd, + fullPerm_val_internal (κ := κ.repair a b c d v hsq) + hσi, + h4, RelTransitionSystem.repair_match_d hsq] + · obtain ⟨n1, n2, n3, n4⟩ := + hsq.match_ne_four hσi h1 h2 h3 h4 + have hPiv : (fullPerm κ z).val = + κ.match_ (W.pairing z.val) := + fullPerm_val_internal hσi + have hzb : fullPerm κ z ≠ bX := fun h => + n2 (by rw [← hPiv, ← hval_b, h]) + have hzc : fullPerm κ z ≠ cX := fun h => + n3 (by rw [← hPiv, ← hval_c, h]) + have hza : fullPerm κ z ≠ aX := fun h => + n1 (by rw [← hPiv, ← hval_a, h]) + have hzd : fullPerm κ z ≠ dX := fun h => + n4 (by rw [← hPiv, ← hval_d, h]) + rw [Equiv.swap_apply_of_ne_of_ne hzb hzc, + Equiv.swap_apply_of_ne_of_ne hza hzd, + fullPerm_val_internal (κ := κ.repair a b c d v hsq) + hσi, + RelTransitionSystem.repair_match_of_ne hsq h1 h2 h3 + h4, hPiv] + · have hσb : W.pairing z.val ∈ F.boundaryFlags := + (F.mem_internalFlags_or_boundaryFlags + (F.pairing_mem z.val z.prop)).resolve_left hσi + have hPiv : (fullPerm κ z).val = + κ.pathMatch (W.pairing z.val) hσb := + fullPerm_val_boundary hσb + have hbd : (fullPerm κ z).val ∈ F.boundaryFlags := by + rw [hPiv] + exact κ.pathMatch_mem hσb + have hnotin : ∀ {g : W.Flag}, g ∈ F.internalFlags → + ∀ (hgf : g ∈ F.flags), fullPerm κ z ≠ ⟨g, hgf⟩ := by + intro g hg hgf h + have hvv : (fullPerm κ z).val = g := by rw [h] + rw [hvv] at hbd + exact Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags hg hbd + rw [Equiv.swap_apply_of_ne_of_ne (hnotin hsq.hb _) + (hnotin hsq.hc _), + Equiv.swap_apply_of_ne_of_ne (hnotin hsq.ha _) + (hnotin hsq.hd _), + fullPerm_val_boundary (κ := κ.repair a b c d v hsq) hσb, + hPiv] + exact hpm _ hσb + +end RepairFull + +/-! ### Orientation exclusions -/ + +section OrientationExclusion + +variable {κ : F.RelTransitionSystem} + +/-- Orientation constancy along a periodic walk. -/ +theorem isOut_iterWalk_periodic (o : κ.Orientation) {f : W.Flag} + (hper : κ.PeriodicFlag f) (i : ℕ) : + o.isOut (iterWalk κ f i) = o.isOut f := by + induction i with + | zero => rfl + | succ i ih => + have hint : iterWalk κ f i ∈ F.internalFlags := by + rcases Nat.eq_zero_or_pos i with rfl | hi + · rw [iterWalk_zero] + exact hper.mem_internal + · exact iterWalk_mem_internal_of_periodic κ hper i hi + rw [iterWalk_succ, + o.match_flip _ (all_pairings_internal_of_periodic κ hper i), + o.pairing_flip _ hint + (all_pairings_internal_of_periodic κ hper i), + Bool.not_not, ih] + +/-- **The separated exclusion, periodic seed**: a flag oppositely +oriented to a periodic flag is not on its full-walk orbit. -/ +theorem not_sameCycle_of_periodic_flip (o : κ.Orientation) + {x y : {h : W.Flag // h ∈ F.flags}} + (hper : κ.PeriodicFlag x.val) + (hflip : o.isOut y.val = !o.isOut x.val) : + ¬ (fullPerm κ).SameCycle x y := by + intro h + obtain ⟨i, hi⟩ := sameCycle_periodic_val hper h + have hconst := isOut_iterWalk_periodic o hper i + rw [hi, hflip] at hconst + simp at hconst + +/-- **The separated exclusion, chain seeds**: two chain flags in +separated orientation are not on a common full-walk orbit. -/ +theorem not_sameCycle_of_chain_positions {β : W.Flag} + (hβ : β ∈ F.boundaryFlags) {k : ℕ} (hkle : k ≤ F.flags.card) + (hcont : ∀ j, j < k → + W.pairing (iterWalk κ β j) ∈ F.internalFlags) + (hterm : W.pairing (iterWalk κ β k) ∈ F.boundaryFlags) + (o : κ.Orientation) + {x y : {h : W.Flag // h ∈ F.flags}} + (hxi : x.val ∈ F.internalFlags) (hyi : y.val ∈ F.internalFlags) + {s t : ℕ} (hsk : s ≤ k) (htk : t ≤ k) + (hxs : x.val = iterWalk κ β s ∨ + x.val = W.pairing (iterWalk κ β s)) + (hyt : y.val = iterWalk κ β t ∨ + y.val = W.pairing (iterWalk κ β t)) + (hflip : o.isOut y.val = !o.isOut x.val) : + ¬ (fullPerm κ).SameCycle x y := by + rcases hxs with hxs | hxs <;> rcases hyt with hyt | hyt + · -- walk/walk: same orientation, contradiction with `hflip` + intro _h + have hs1 : 1 ≤ s := by + rcases Nat.eq_zero_or_pos s with rfl | h + · rw [iterWalk_zero] at hxs + exact absurd hβ (Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags (hxs ▸ hxi)) + · exact h + have ht1 : 1 ≤ t := by + rcases Nat.eq_zero_or_pos t with rfl | h + · rw [iterWalk_zero] at hyt + exact absurd hβ (Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags (hyt ▸ hyi)) + · exact h + have heq : o.isOut y.val = o.isOut x.val := by + rw [hxs, hyt] + rcases le_total s t with hst | hts + · exact isOut_iterWalk_chain hcont o hs1 hst + htk + · exact (isOut_iterWalk_chain hcont o ht1 hts + hsk).symm + rw [heq] at hflip + simp at hflip + · -- walk/pairing: mirror collision + intro h + have hx' : x = (fullPerm κ ^ s) + ⟨β, mem_flags_of_boundaryFlags F hβ⟩ := + Subtype.ext (by rw [fullPerm_pow_val hcont s hsk]; exact hxs) + have hbx : (fullPerm κ).SameCycle + ⟨β, mem_flags_of_boundaryFlags F hβ⟩ x := by + rw [hx'] + exact sameCycle_of_pow_eq rfl + obtain ⟨j, hjk, hjv⟩ := fullPerm_chain_sameCycle_val hβ hkle + hcont hterm (hbx.trans h) + refine pairing_iterWalk_ne κ hcont htk hjk ?_ + rw [← hyt] + exact hjv + · -- pairing/walk: mirror collision + intro h + have hy' : y = (fullPerm κ ^ t) + ⟨β, mem_flags_of_boundaryFlags F hβ⟩ := + Subtype.ext (by rw [fullPerm_pow_val hcont t htk]; exact hyt) + have hby : (fullPerm κ).SameCycle + ⟨β, mem_flags_of_boundaryFlags F hβ⟩ y := by + rw [hy'] + exact sameCycle_of_pow_eq rfl + obtain ⟨j, hjk, hjv⟩ := fullPerm_chain_sameCycle_val hβ hkle + hcont hterm (hby.trans h.symm) + refine pairing_iterWalk_ne κ hcont hsk hjk ?_ + rw [← hxs] + exact hjv + · -- pairing/pairing: same orientation, contradiction + intro _h + have hsk' : s < k := by + rcases Nat.eq_or_lt_of_le hsk with rfl | h + · exfalso + have hb : x.val ∈ F.boundaryFlags := by + rw [hxs] + exact hterm + exact Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags hxi hb + · exact h + have htk' : t < k := by + rcases Nat.eq_or_lt_of_le htk with rfl | h + · exfalso + have hb : y.val ∈ F.boundaryFlags := by + rw [hyt] + exact hterm + exact Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags hyi hb + · exact h + have hwx : o.isOut x.val = !o.isOut (iterWalk κ β (s + 1)) := by + rw [hxs] + exact isOut_pairing_iterWalk_chain hcont o hsk' + have hwy : o.isOut y.val = !o.isOut (iterWalk κ β (t + 1)) := by + rw [hyt] + exact isOut_pairing_iterWalk_chain hcont o htk' + have hw : o.isOut (iterWalk κ β (t + 1)) = + o.isOut (iterWalk κ β (s + 1)) := by + rcases le_total (s + 1) (t + 1) with hst | hts + · exact isOut_iterWalk_chain hcont o + (by omega) hst (by omega) + · exact (isOut_iterWalk_chain hcont o + (by omega) hts (by omega)).symm + rw [hwx, hwy, hw] at hflip + simp at hflip + +end OrientationExclusion + +end EdgeSubset + +/-! ## (iii) The discharged parity input -/ + +open EdgeSubset in +/-- **The separated count parity** (the input +`SeparatedCountParity`): a +separated square on a localized configuration flips the +circuit-count parity. -/ +theorem separatedCountParity : SeparatedCountParity := by + intro α W F κ a b c d v hsq o hflip hloc + classical + -- the pathMatch invariance of the localized move + have hpm := pathMatch_repair_of_localized hsq hloc + -- ═══════ STAGE 1: THE SQUARE'S CORNERS AND THEIR STEPS ═══════ + -- distinctness of the square corners in the flag subtype + have hbcX : (⟨b, mem_flags_of_internalFlags F hsq.hb⟩ : + {f : W.Flag // f ∈ F.flags}) ≠ + ⟨c, mem_flags_of_internalFlags F hsq.hc⟩ := fun h => + hsq.hbc (congrArg Subtype.val h) + have hadX : (⟨a, mem_flags_of_internalFlags F hsq.ha⟩ : + {f : W.Flag // f ∈ F.flags}) ≠ + ⟨d, mem_flags_of_internalFlags F hsq.hd⟩ := fun h => + hsq.had (congrArg Subtype.val h) + -- the single-step relations `σb ∼ a` and `σc ∼ d` + have hstep_b : fullPerm κ (pairingPermSP F + ⟨b, mem_flags_of_internalFlags F hsq.hb⟩) = + ⟨a, mem_flags_of_internalFlags F hsq.ha⟩ := by + apply Subtype.ext + rw [fullPerm_apply_pairing, + fullMatchFun_val_internal κ + (show (⟨b, mem_flags_of_internalFlags F hsq.hb⟩ : + {f : W.Flag // f ∈ F.flags}).val ∈ F.internalFlags from + hsq.hb)] + exact hsq.hmb + have hstep_c : fullPerm κ (pairingPermSP F + ⟨c, mem_flags_of_internalFlags F hsq.hc⟩) = + ⟨d, mem_flags_of_internalFlags F hsq.hd⟩ := by + apply Subtype.ext + rw [fullPerm_apply_pairing, + fullMatchFun_val_internal κ + (show (⟨c, mem_flags_of_internalFlags F hsq.hc⟩ : + {f : W.Flag // f ∈ F.flags}).val ∈ F.internalFlags from + hsq.hc)] + exact hsq.hcd + have hrel_b : (fullPerm κ).SameCycle + (pairingPermSP F ⟨b, mem_flags_of_internalFlags F hsq.hb⟩) + ⟨a, mem_flags_of_internalFlags F hsq.ha⟩ := by + rw [← hstep_b] + exact Equiv.Perm.sameCycle_apply_right.mpr + (Equiv.Perm.SameCycle.refl _ _) + have hrel_c : (fullPerm κ).SameCycle + (pairingPermSP F ⟨c, mem_flags_of_internalFlags F hsq.hc⟩) + ⟨d, mem_flags_of_internalFlags F hsq.hd⟩ := by + rw [← hstep_c] + exact Equiv.Perm.sameCycle_apply_right.mpr + (Equiv.Perm.SameCycle.refl _ _) + -- ═══════ STAGE 2: THE MIRROR EQUIVALENCE `b ∼ c ↔ a ∼ d` ═══════ + have hiff : (fullPerm κ).SameCycle + ⟨b, mem_flags_of_internalFlags F hsq.hb⟩ + ⟨c, mem_flags_of_internalFlags F hsq.hc⟩ ↔ + (fullPerm κ).SameCycle + ⟨a, mem_flags_of_internalFlags F hsq.ha⟩ + ⟨d, mem_flags_of_internalFlags F hsq.hd⟩ := by + constructor + · intro h + exact (hrel_b.symm.trans (sameCycle_pairingPermSP h)).trans + hrel_c + · intro h + have h2 := sameCycle_pairingPermSP + ((hrel_b.trans h).trans hrel_c.symm) + rw [pairingPermSP_invol, pairingPermSP_invol] at h2 + exact h2 + -- ═══════ STAGE 3: THE THREE EXCLUSIONS ═══════ + -- exclusion `¬ b ∼ σb` (mirror collision at `b`) + have hN1 : ¬ (fullPerm κ).SameCycle + ⟨b, mem_flags_of_internalFlags F hsq.hb⟩ + (pairingPermSP F ⟨b, mem_flags_of_internalFlags F hsq.hb⟩) + := by + rcases hloc with ⟨hpa, _hpc⟩ | ⟨β, hβ, hall⟩ + · exact not_sameCycle_pairingPermSP_of_periodic + (show κ.PeriodicFlag b from + hsq.hab ▸ periodicFlag_match hpa) + · rcases hall b (Or.inr (Or.inl rfl)) with hpb | hchain + · exact not_sameCycle_pairingPermSP_of_periodic hpb + · obtain ⟨k, hkle, hcont, hterm⟩ := + chain_terminates_with_data κ hβ + obtain ⟨k', t, htk', hcont', hterm', hft⟩ := hchain + have hkk : k' = k := + chain_exit_unique hcont' hterm' hcont hterm + subst hkk + exact not_sameCycle_pairingPermSP_of_chain hβ hkle hcont + hterm (mem_flags_of_internalFlags F hsq.hb) htk' hft + -- exclusion `¬ a ∼ b` + have hab : ¬ (fullPerm κ).SameCycle + ⟨a, mem_flags_of_internalFlags F hsq.ha⟩ + ⟨b, mem_flags_of_internalFlags F hsq.hb⟩ := by + intro h + exact hN1 (h.symm.trans hrel_b.symm) + -- exclusion `¬ a ∼ c` (the separated orientation) + have hac : ¬ (fullPerm κ).SameCycle + ⟨a, mem_flags_of_internalFlags F hsq.ha⟩ + ⟨c, mem_flags_of_internalFlags F hsq.hc⟩ := by + rcases hloc with ⟨hpa, _hpc⟩ | ⟨β, hβ, hall⟩ + · exact not_sameCycle_of_periodic_flip o hpa hflip + · rcases hall a (Or.inl rfl) with hpa | hchaina + · exact not_sameCycle_of_periodic_flip o hpa hflip + · rcases hall c (Or.inr (Or.inr (Or.inl rfl))) with + hpc | hchainc + · have hflip' : o.isOut a = !o.isOut c := by + rw [hflip, Bool.not_not] + exact fun h => + not_sameCycle_of_periodic_flip o hpc hflip' h.symm + · obtain ⟨k, hkle, hcont, hterm⟩ := + chain_terminates_with_data κ hβ + obtain ⟨ka, s, hsk, hconta, hterma, hfs⟩ := hchaina + have hka : k = ka := + (chain_exit_unique hconta hterma hcont hterm).symm + subst hka + obtain ⟨kc, t, htk, hcontc, htermc, hftc⟩ := hchainc + have hkc : k = kc := + (chain_exit_unique hcontc htermc hcont hterm).symm + subst hkc + exact not_sameCycle_of_chain_positions hβ hkle hcont + hterm o hsq.ha hsq.hc hsk htk hfs hftc hflip + -- ═══════ ASSEMBLY: THE DOUBLE SWAP AND THE ORBIT LEDGER ═══════ + have hswap := permOrbitCount_swap_swap_mul (g := fullPerm κ) + hbcX hadX hiff hab hac + rw [← fullPerm_repair hsq hpm] at hswap + -- the orbit bookkeeping on both sides + have h1 := permOrbitCount_fullPerm_eq κ + have h2 := permOrbitCount_fullPerm_eq (κ.repair a b c d v hsq) + have hc1 : κ.openCircuitCount = + permOrbitCount κ.walkPermPeriodic / 2 := rfl + have hc2 : (κ.repair a b c d v hsq).openCircuitCount = + permOrbitCount (κ.repair a b c d v hsq).walkPermPeriodic / 2 + := rfl + rw [Nat.odd_iff, hc1, hc2] + rcases hswap with h | h <;> omega + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SimpleUnit.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SimpleUnit.lean new file mode 100644 index 0000000000..6ca7e19109 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SimpleUnit.lean @@ -0,0 +1,80 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Multiplicativity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal + +/-! +# The simple unit + +Lemma 3.4 of the accompanying paper: the arity-zero Hom space of an +edge-rank-bounded parameter is spanned by the class of the empty +fragment, which is nonzero — `End(𝟙) = ℂ·[∅]`. The rank bound at +arity zero caps the dimension at one, and the empty class is +nonzero because its closure row at the empty fragment is +`f(∅) = 1`. +-/ + +@[expose] public section + +noncomputable section + +namespace RS + +/-- The class of the empty fragment in the arity-zero Hom +space. -/ +noncomputable def emptyClass (f : ClosedFragment → ℂ) : + HomSpace f 0 := + HomSpace.ofFragment f emptyClosedFragment + +/-- The arity-zero connection pairing is the parameter of the +union. -/ +theorem connectionPairing_zero {R : ℕ} (f : EdgeRankParameter R) + (F G : ClosedFragment) : + connectionPairing f.val 0 F G = + f.val (ClosedFragment.union F G) := + f.iso_invariant _ _ + ((Fragment.composeCongr (relabelZeroEquiv F _) + (relabelZeroEquiv G _)).trans (composeZeroEquiv F G)) + +/-- The empty class is nonzero. -/ +theorem emptyClass_ne_zero {R : ℕ} (f : EdgeRankParameter R) : + emptyClass f.val ≠ 0 := by + intro h + have hker : Finsupp.single emptyClosedFragment (1 : ℂ) ∈ + LinearMap.ker (connectionMap f.val 0) := + (Submodule.Quotient.mk_eq_zero _).mp h + rw [LinearMap.mem_ker] at hker + have hval := congrFun hker emptyClosedFragment + rw [connectionMap_single, one_mul, connectionPairing_zero, + f.iso_invariant _ _ (unionEmptyLeftEquiv emptyClosedFragment), + f.val_empty] at hval + exact one_ne_zero hval + +/-- **The simple unit** (accompanying paper, Lemma 3.4): the +arity-zero Hom space is spanned by the class of the empty +fragment. -/ +theorem homSpace_zero_spanned {R : ℕ} (f : EdgeRankParameter R) + (u : HomSpace f.val 0) : + ∃ c : ℂ, u = c • emptyClass f.val := by + have hrank : Module.rank ℂ (HomSpace f.val 0) ≤ 1 := by + have := HomSpace.rank_le f 0 + rwa [pow_zero] at this + obtain ⟨v₀, hv₀⟩ := rank_le_one_iff.mp hrank + obtain ⟨c₀, hc₀⟩ := hv₀ (emptyClass f.val) + obtain ⟨cu, hcu⟩ := hv₀ u + have hc₀ne : c₀ ≠ 0 := by + intro h + rw [h, zero_smul] at hc₀ + exact emptyClass_ne_zero f hc₀.symm + refine ⟨cu * c₀⁻¹, ?_⟩ + rw [← hcu, ← hc₀, smul_smul] + congr 1 + field_simp + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinCatInstance.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinCatInstance.lean new file mode 100644 index 0000000000..a8c745cce9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinCatInstance.lean @@ -0,0 +1,44 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceNondegenerate + +/-! +# The skein category, packaged + +The accompanying paper's connection category `𝒞_f` as a +`CategoryTheory.Category` instance: objects are arities, morphisms +are Hom-space classes, identities are strand bundle classes, +composition is the descended bilinear composition. All axioms were proven in +`SkeinCategory.lean`; this file only packages them. +-/ + +@[expose] public section + +namespace RS + +/-- An object of the skein category of a parameter: an arity. -/ +structure SkeinObj {R : ℕ} (f : EdgeRankParameter R) where + /-- The arity: the number of open ends. -/ + arity : ℕ + +/-- **The skein category**: the accompanying paper's connection +category `𝒞_f` (§3.2). -/ +noncomputable instance skeinCategory {R : ℕ} + (f : EdgeRankParameter R) : + CategoryTheory.Category (SkeinObj f) where + Hom X Y := HomSpace f.val (X.arity + Y.arity) + id X := HomSpace.ofFragment f.val (strandBundle X.arity) + comp {X Y Z} p q := + HomSpace.comp f X.arity Y.arity Z.arity p q + id_comp {X Y} p := HomSpace.comp_id_left f X.arity Y.arity p + comp_id {X Y} p := HomSpace.comp_id_right f X.arity Y.arity p + assoc {W X Y Z} p q r := + HomSpace.comp_assoc f W.arity X.arity Y.arity Z.arity p q r + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinCategory.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinCategory.lean new file mode 100644 index 0000000000..475f864c8a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinCategory.lean @@ -0,0 +1,241 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomCompose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic +public import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLawRight + +/-! +# The skein category: the axioms on Hom spaces + +The skein category — the accompanying paper's connection category +`𝒞_f` (§3.2): identities are strand bundle classes and +composition is the descended bilinear composition. Every axiom +reduces to a kernel membership of a difference of free-module +elements, proven by linear induction +with the per-single case supplied by a fragment equivalence +(identity laws, associativity) through isomorphism invariance. +-/ + +@[expose] public section + +namespace RS + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The single difference of equivalent fragments lies in the +pairing kernel. -/ +theorem mem_ker_single_sub_of_equiv {t : ℕ} + {F G : Fragment (Fin t)} (h : F.Equiv G) : + Finsupp.single F (1 : ℂ) - Finsupp.single G 1 ∈ + LinearMap.ker (connectionMap f.val t) := by + rw [LinearMap.mem_ker, map_sub] + funext K + change connectionMap f.val t (Finsupp.single F 1) K - + connectionMap f.val t (Finsupp.single G 1) K = 0 + rw [connectionMap_single, connectionMap_single, one_mul, + one_mul, + show connectionPairing f.val t F K = + connectionPairing f.val t G K from + f.iso_invariant _ _ + (pairCloseCongr h (Fragment.Equiv.refl K))] + ring + +/-- Equivalent fragments have equal classes. -/ +theorem HomSpace.ofFragment_congr {t : ℕ} + {F G : Fragment (Fin t)} (h : F.Equiv G) : + HomSpace.ofFragment f.val F = + HomSpace.ofFragment f.val G := + (Submodule.Quotient.eq _).mpr + (mem_ker_single_sub_of_equiv f h) + +/-- The single difference of a weighted pair of equivalent +fragments lies in the kernel. -/ +theorem mem_ker_single_sub_of_equiv_smul {t : ℕ} + {F G : Fragment (Fin t)} (h : F.Equiv G) (c : ℂ) : + Finsupp.single F c - Finsupp.single G c ∈ + LinearMap.ker (connectionMap f.val t) := by + have h1 : Finsupp.single F c - Finsupp.single G c = + c • (Finsupp.single F (1 : ℂ) - Finsupp.single G 1) := by + rw [smul_sub, Finsupp.smul_single, Finsupp.smul_single, + smul_eq_mul, mul_one] + rw [h1] + exact Submodule.smul_mem _ c + (mem_ker_single_sub_of_equiv f h) + +/-- The left unit difference lies in the kernel. -/ +theorem mem_ker_id_left (s u : ℕ) + (y : Fragment (Fin (s + u)) →₀ ℂ) : + composeFinsupp s s u + (Finsupp.single (strandBundle s) 1) y - y ∈ + LinearMap.ker (connectionMap f.val (s + u)) := by + induction y using Finsupp.induction_linear with + | zero => + rw [map_zero, sub_zero] + exact Submodule.zero_mem _ + | add y z hy hz => + have h1 : composeFinsupp s s u + (Finsupp.single (strandBundle s) 1) (y + z) - (y + z) = + (composeFinsupp s s u + (Finsupp.single (strandBundle s) 1) y - y) + + (composeFinsupp s s u + (Finsupp.single (strandBundle s) 1) z - z) := by + rw [map_add] + abel + rw [h1] + exact Submodule.add_mem _ hy hz + | single F c => + rw [composeFinsupp_single, one_mul] + exact mem_ker_single_sub_of_equiv_smul f + (composeStrandBundleLeft s u F) c + +/-- The right unit difference lies in the kernel. -/ +theorem mem_ker_id_right (s u : ℕ) + (y : Fragment (Fin (s + u)) →₀ ℂ) : + composeFinsupp s u u y + (Finsupp.single (strandBundle u) 1) - y ∈ + LinearMap.ker (connectionMap f.val (s + u)) := by + induction y using Finsupp.induction_linear with + | zero => + rw [map_zero, LinearMap.zero_apply, sub_zero] + exact Submodule.zero_mem _ + | add y z hy hz => + have h1 : composeFinsupp s u u (y + z) + (Finsupp.single (strandBundle u) 1) - (y + z) = + (composeFinsupp s u u y + (Finsupp.single (strandBundle u) 1) - y) + + (composeFinsupp s u u z + (Finsupp.single (strandBundle u) 1) - z) := by + rw [map_add, LinearMap.add_apply] + abel + rw [h1] + exact Submodule.add_mem _ hy hz + | single F c => + rw [composeFinsupp_single, mul_one] + exact mem_ker_single_sub_of_equiv_smul f + (composeStrandBundleRight s u F) c + +/-- The associativity difference lies in the kernel. -/ +theorem mem_ker_assoc (s t u v : ℕ) + (x : Fragment (Fin (s + t)) →₀ ℂ) + (y : Fragment (Fin (t + u)) →₀ ℂ) + (z : Fragment (Fin (u + v)) →₀ ℂ) : + composeFinsupp s u v (composeFinsupp s t u x y) z - + composeFinsupp s t v x (composeFinsupp t u v y z) ∈ + LinearMap.ker (connectionMap f.val (s + v)) := by + induction x using Finsupp.induction_linear with + | zero => + rw [map_zero, LinearMap.zero_apply, map_zero, + LinearMap.zero_apply, map_zero, LinearMap.zero_apply, + sub_zero] + exact Submodule.zero_mem _ + | add x₁ x₂ h₁ h₂ => + have he : composeFinsupp s u v + (composeFinsupp s t u (x₁ + x₂) y) z - + composeFinsupp s t v (x₁ + x₂) + (composeFinsupp t u v y z) = + (composeFinsupp s u v (composeFinsupp s t u x₁ y) z - + composeFinsupp s t v x₁ (composeFinsupp t u v y z)) + + (composeFinsupp s u v (composeFinsupp s t u x₂ y) z - + composeFinsupp s t v x₂ + (composeFinsupp t u v y z)) := by + rw [map_add, LinearMap.add_apply, map_add, + LinearMap.add_apply, map_add, LinearMap.add_apply] + abel + rw [he] + exact Submodule.add_mem _ h₁ h₂ + | single F c => + induction y using Finsupp.induction_linear with + | zero => + simp only [map_zero, LinearMap.zero_apply, sub_zero] + exact Submodule.zero_mem _ + | add y₁ y₂ h₁ h₂ => + have he : composeFinsupp s u v + (composeFinsupp s t u (Finsupp.single F c) + (y₁ + y₂)) z - + composeFinsupp s t v (Finsupp.single F c) + (composeFinsupp t u v (y₁ + y₂) z) = + (composeFinsupp s u v + (composeFinsupp s t u (Finsupp.single F c) y₁) z - + composeFinsupp s t v (Finsupp.single F c) + (composeFinsupp t u v y₁ z)) + + (composeFinsupp s u v + (composeFinsupp s t u (Finsupp.single F c) y₂) z - + composeFinsupp s t v (Finsupp.single F c) + (composeFinsupp t u v y₂ z)) := by + rw [map_add, map_add, LinearMap.add_apply, map_add, + LinearMap.add_apply, map_add] + abel + rw [he] + exact Submodule.add_mem _ h₁ h₂ + | single G c' => + induction z using Finsupp.induction_linear with + | zero => + rw [map_zero, map_zero, map_zero, sub_zero] + exact Submodule.zero_mem _ + | add z₁ z₂ h₁ h₂ => + have he : composeFinsupp s u v + (composeFinsupp s t u (Finsupp.single F c) + (Finsupp.single G c')) (z₁ + z₂) - + composeFinsupp s t v (Finsupp.single F c) + (composeFinsupp t u v (Finsupp.single G c') + (z₁ + z₂)) = + (composeFinsupp s u v + (composeFinsupp s t u (Finsupp.single F c) + (Finsupp.single G c')) z₁ - + composeFinsupp s t v (Finsupp.single F c) + (composeFinsupp t u v (Finsupp.single G c') + z₁)) + + (composeFinsupp s u v + (composeFinsupp s t u (Finsupp.single F c) + (Finsupp.single G c')) z₂ - + composeFinsupp s t v (Finsupp.single F c) + (composeFinsupp t u v (Finsupp.single G c') + z₂)) := by + rw [map_add, map_add, map_add] + abel + rw [he] + exact Submodule.add_mem _ h₁ h₂ + | single H c'' => + rw [composeFinsupp_single, composeFinsupp_single, + composeFinsupp_single, composeFinsupp_single] + rw [show c * c' * c'' = c * (c' * c'') by ring] + exact mem_ker_single_sub_of_equiv_smul f + (composeAssoc F G H) (c * (c' * c'')) + +/-! ### The axioms on quotient classes -/ + +/-- Left unit law on classes. -/ +theorem HomSpace.comp_id_left (s u : ℕ) + (q : HomSpace f.val (s + u)) : + HomSpace.comp f s s u + (HomSpace.ofFragment f.val (strandBundle s)) q = q := by + obtain ⟨y, rfl⟩ := Submodule.Quotient.mk_surjective _ q + exact (Submodule.Quotient.eq _).mpr (mem_ker_id_left f s u y) + +/-- Right unit law on classes. -/ +theorem HomSpace.comp_id_right (s u : ℕ) + (q : HomSpace f.val (s + u)) : + HomSpace.comp f s u u q + (HomSpace.ofFragment f.val (strandBundle u)) = q := by + obtain ⟨y, rfl⟩ := Submodule.Quotient.mk_surjective _ q + exact (Submodule.Quotient.eq _).mpr (mem_ker_id_right f s u y) + +/-- Associativity on classes. -/ +theorem HomSpace.comp_assoc (s t u v : ℕ) + (p : HomSpace f.val (s + t)) (q : HomSpace f.val (t + u)) + (r : HomSpace f.val (u + v)) : + HomSpace.comp f s u v (HomSpace.comp f s t u p q) r = + HomSpace.comp f s t v p (HomSpace.comp f t u v q r) := by + obtain ⟨x, rfl⟩ := Submodule.Quotient.mk_surjective _ p + obtain ⟨y, rfl⟩ := Submodule.Quotient.mk_surjective _ q + obtain ⟨z, rfl⟩ := Submodule.Quotient.mk_surjective _ r + exact (Submodule.Quotient.eq _).mpr + (mem_ker_assoc f s t u v x y z) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdeal.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdeal.lean new file mode 100644 index 0000000000..417e0d5b05 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdeal.lean @@ -0,0 +1,140 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomSpaces + +/-! +# The composition ideal + +Bilinear composition on the free modules of fragments, and the +first half of the ideal lemma (accompanying paper, Lemma 3.3(a)): +composing a +kernel element with any fragment on the right stays in the +kernel, because every closure row of the composite is a closure +row of the original — the rotation of closures moves the +composed factor into the test fragment. +-/ + +@[expose] public section + +noncomputable section + +namespace RS + +/-- Bilinear composition on the free modules of fragments. -/ +noncomputable def composeFinsupp (m n p : ℕ) : + (Fragment (Fin (m + n)) →₀ ℂ) →ₗ[ℂ] + (Fragment (Fin (n + p)) →₀ ℂ) →ₗ[ℂ] + (Fragment (Fin (m + p)) →₀ ℂ) := + Finsupp.lift _ ℂ _ (fun F => + Finsupp.lift _ ℂ _ (fun G => + Finsupp.single (F.compose G) (1 : ℂ))) + +/-- Composition of weighted single fragments. -/ +theorem composeFinsupp_single (m n p : ℕ) + (F : Fragment (Fin (m + n))) (c : ℂ) + (G : Fragment (Fin (n + p))) (d : ℂ) : + composeFinsupp m n p (Finsupp.single F c) + (Finsupp.single G d) = + Finsupp.single (F.compose G) (c * d) := by + unfold composeFinsupp + rw [Finsupp.lift_apply, Finsupp.sum_single_index (by simp), + LinearMap.smul_apply, Finsupp.lift_apply, + Finsupp.sum_single_index (by simp), Finsupp.smul_single, + Finsupp.smul_single, smul_eq_mul, smul_eq_mul, mul_one] + +/-- The connection row of a weighted single fragment. -/ +theorem connectionMap_single (f : ClosedFragment → ℂ) (t : ℕ) + (X : Fragment (Fin t)) (c : ℂ) (G : Fragment (Fin t)) : + connectionMap f t (Finsupp.single X c) G = + c * connectionPairing f t X G := by + unfold connectionMap + rw [Finsupp.lift_apply, Finsupp.sum_single_index (by simp)] + rfl + +/-- **Rotation of connection rows** (accompanying paper, +Lemma 3.3(a), right): for an isomorphism-invariant parameter, the +closure row of a right-composite is a closure row of the +original. -/ +theorem connectionPairing_compose_right + (f : ClosedFragment → ℂ) + (hf : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) + {m n p : ℕ} (F : Fragment (Fin (m + n))) + (H : Fragment (Fin (n + p))) (K : Fragment (Fin (m + p))) : + connectionPairing f (m + p) (F.compose H) K = + connectionPairing f (m + n) F + (K.compose (H.relabel (transposeEquiv n p))) := + hf _ _ (pairCloseComposeRotate F H K) + +/-- The closure row of a right-composite, linearized: each row of +`x ∘ H` is a row of `x` at a rotated test fragment. -/ +theorem connectionMap_compose_single + (f : ClosedFragment → ℂ) + (hf : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) + {m n p : ℕ} (x : Fragment (Fin (m + n)) →₀ ℂ) + (H : Fragment (Fin (n + p))) (K : Fragment (Fin (m + p))) : + connectionMap f (m + p) + (composeFinsupp m n p x (Finsupp.single H 1)) K = + connectionMap f (m + n) x + (K.compose (H.relabel (transposeEquiv n p))) := by + induction x using Finsupp.induction_linear with + | zero => + rw [map_zero, LinearMap.zero_apply, map_zero] + rfl + | add y z hy hz => + rw [map_add, LinearMap.add_apply, map_add] + change connectionMap f (m + p) _ K + connectionMap f (m + p) _ K + = _ + rw [hy, hz, map_add] + rfl + | single F c => + rw [composeFinsupp_single, mul_one, connectionMap_single, + connectionMap_single, + connectionPairing_compose_right f hf] + +/-- **The right ideal property** (accompanying paper, Lemma 3.3(a), +right): a kernel element composed with any single fragment on the +right stays in the kernel. -/ +theorem composeFinsupp_single_ker (f : ClosedFragment → ℂ) + (hf : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) + {m n p : ℕ} {x : Fragment (Fin (m + n)) →₀ ℂ} + (hx : x ∈ LinearMap.ker (connectionMap f (m + n))) + (H : Fragment (Fin (n + p))) : + composeFinsupp m n p x (Finsupp.single H 1) ∈ + LinearMap.ker (connectionMap f (m + p)) := by + rw [LinearMap.mem_ker] at hx ⊢ + funext K + rw [connectionMap_compose_single f hf x H K, hx] + rfl + +/-- **The right ideal property, bilinear form**: a kernel element +composed with anything on the right stays in the kernel. -/ +theorem composeFinsupp_ker_left (f : ClosedFragment → ℂ) + (hf : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) + {m n p : ℕ} {x : Fragment (Fin (m + n)) →₀ ℂ} + (hx : x ∈ LinearMap.ker (connectionMap f (m + n))) + (y : Fragment (Fin (n + p)) →₀ ℂ) : + composeFinsupp m n p x y ∈ + LinearMap.ker (connectionMap f (m + p)) := by + induction y using Finsupp.induction_linear with + | zero => + rw [map_zero] + exact Submodule.zero_mem _ + | add y z hy hz => + rw [map_add] + exact Submodule.add_mem _ hy hz + | single H c => + have h1 : composeFinsupp m n p x (Finsupp.single H c) = + c • composeFinsupp m n p x (Finsupp.single H 1) := by + rw [← map_smul, Finsupp.smul_single, smul_eq_mul, mul_one] + rw [h1] + exact Submodule.smul_mem _ c + (composeFinsupp_single_ker f hf hx H) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdealLeft.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdealLeft.lean new file mode 100644 index 0000000000..86312c4a17 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdealLeft.lean @@ -0,0 +1,113 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotateLeft +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal + +/-! +# The composition ideal, left half + +The mirror of `SkeinIdeal.lean`: composing a kernel element with +any fragment on the *left* stays in the kernel, because every +closure row of `w ∘ x` is a closure row of `x` — the mirror +rotation moves the left factor into the test fragment. Together +with `composeFinsupp_ker_left` this makes the pairing kernel a +two-sided ideal (accompanying paper, Lemma 3.3(a)), so composition +descends to the Hom spaces. +-/ + +@[expose] public section + +namespace RS + +/-- **Rotation of connection rows, left** (accompanying paper, +Lemma 3.3(a), left): for an isomorphism-invariant parameter, the +closure row of a left-composite is a closure row of the +original. -/ +theorem connectionPairing_compose_left + (f : ClosedFragment → ℂ) + (hf : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) + {s t u : ℕ} (W : Fragment (Fin (s + t))) + (F : Fragment (Fin (t + u))) (K : Fragment (Fin (s + u))) : + connectionPairing f (s + u) (W.compose F) K = + connectionPairing f (t + u) F + ((W.relabel (transposeEquiv s t)).compose K) := + hf _ _ (pairCloseComposeRotateLeft W F K) + +/-- The closure row of a left-composite, linearized: each row of +`W ∘ y` is a row of `y` at a rotated test fragment. -/ +theorem connectionMap_compose_left_single + (f : ClosedFragment → ℂ) + (hf : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) + {s t u : ℕ} (W : Fragment (Fin (s + t))) + (y : Fragment (Fin (t + u)) →₀ ℂ) + (K : Fragment (Fin (s + u))) : + connectionMap f (s + u) + (composeFinsupp s t u (Finsupp.single W 1) y) K = + connectionMap f (t + u) y + ((W.relabel (transposeEquiv s t)).compose K) := by + induction y using Finsupp.induction_linear with + | zero => + rw [map_zero, map_zero] + rfl + | add y z hy hz => + rw [map_add, map_add] + change connectionMap f (s + u) _ K + + connectionMap f (s + u) _ K = _ + rw [hy, hz, map_add] + rfl + | single F c => + rw [composeFinsupp_single, one_mul, connectionMap_single, + connectionMap_single, + connectionPairing_compose_left f hf] + +/-- A kernel element composed with a single fragment on the left +stays in the kernel. -/ +theorem composeFinsupp_single_ker_left + (f : ClosedFragment → ℂ) + (hf : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) + {s t u : ℕ} (W : Fragment (Fin (s + t))) + {y : Fragment (Fin (t + u)) →₀ ℂ} + (hy : y ∈ LinearMap.ker (connectionMap f (t + u))) : + composeFinsupp s t u (Finsupp.single W 1) y ∈ + LinearMap.ker (connectionMap f (s + u)) := by + rw [LinearMap.mem_ker] at hy ⊢ + funext K + rw [connectionMap_compose_left_single f hf W y K, hy] + rfl + +/-- **The left ideal property** (accompanying paper, Lemma 3.3(a), +left): anything composed with a kernel element on the left stays +in the kernel. -/ +theorem composeFinsupp_ker_right + (f : ClosedFragment → ℂ) + (hf : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) + {s t u : ℕ} (x : Fragment (Fin (s + t)) →₀ ℂ) + {y : Fragment (Fin (t + u)) →₀ ℂ} + (hy : y ∈ LinearMap.ker (connectionMap f (t + u))) : + composeFinsupp s t u x y ∈ + LinearMap.ker (connectionMap f (s + u)) := by + induction x using Finsupp.induction_linear with + | zero => + rw [map_zero, LinearMap.zero_apply] + exact Submodule.zero_mem _ + | add x₁ x₂ h₁ h₂ => + rw [map_add, LinearMap.add_apply] + exact Submodule.add_mem _ h₁ h₂ + | single W c => + have h1 : composeFinsupp s t u (Finsupp.single W c) y = + c • composeFinsupp s t u (Finsupp.single W 1) y := by + rw [show (Finsupp.single W c : Fragment (Fin (s + t)) →₀ ℂ) + = c • Finsupp.single W 1 by + rw [Finsupp.smul_single, smul_eq_mul, mul_one], + map_smul, LinearMap.smul_apply] + rw [h1] + exact Submodule.smul_mem _ c + (composeFinsupp_single_ker_left f hf W hy) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinLinear.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinLinear.lean new file mode 100644 index 0000000000..cb991823e9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinLinear.lean @@ -0,0 +1,70 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance + +/-! +# The skein category is ℂ-linear + +Hom spaces are ℂ-modules and the descended composition is +bilinear, so the skein category is preadditive and ℂ-linear — +two of the instance hypotheses of the Deligne package carrier. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +/-- Skein hom-spaces are abelian groups. -/ +noncomputable instance skeinHomAddCommGroup {R : ℕ} + (f : EdgeRankParameter R) (X Y : SkeinObj f) : + AddCommGroup (X ⟶ Y) := + inferInstanceAs (AddCommGroup + (HomSpace f.val (X.arity + Y.arity))) + +/-- And ℂ-modules. -/ +noncomputable instance skeinHomModule {R : ℕ} + (f : EdgeRankParameter R) (X Y : SkeinObj f) : + Module ℂ (X ⟶ Y) := + inferInstanceAs (Module ℂ + (HomSpace f.val (X.arity + Y.arity))) + +/-- Composition is additive in each argument, so the category is +preadditive. -/ +noncomputable instance skeinPreadditive {R : ℕ} + (f : EdgeRankParameter R) : Preadditive (SkeinObj f) where + homGroup := skeinHomAddCommGroup f + add_comp X Y Z p p' q := + congrArg (fun g : HomSpace f.val (Y.arity + Z.arity) →ₗ[ℂ] + HomSpace f.val (X.arity + Z.arity) => g q) + (map_add (HomSpace.comp f X.arity Y.arity Z.arity) + (p : HomSpace f.val (X.arity + Y.arity)) + (p' : HomSpace f.val (X.arity + Y.arity))) + comp_add X Y Z p q q' := + map_add (HomSpace.comp f X.arity Y.arity Z.arity + (p : HomSpace f.val (X.arity + Y.arity))) + (q : HomSpace f.val (Y.arity + Z.arity)) + (q' : HomSpace f.val (Y.arity + Z.arity)) + +/-- And bilinear, so it is ℂ-linear. -/ +noncomputable instance skeinLinear {R : ℕ} + (f : EdgeRankParameter R) : Linear ℂ (SkeinObj f) where + homModule := skeinHomModule f + smul_comp X Y Z c p q := + congrArg (fun g : HomSpace f.val (Y.arity + Z.arity) →ₗ[ℂ] + HomSpace f.val (X.arity + Z.arity) => g q) + (map_smul (HomSpace.comp f X.arity Y.arity Z.arity) c + (p : HomSpace f.val (X.arity + Y.arity))) + comp_smul X Y Z p c q := + map_smul (HomSpace.comp f X.arity Y.arity Z.arity + (p : HomSpace f.val (X.arity + Y.arity))) c + (q : HomSpace f.val (Y.arity + Z.arity)) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SnakeClasses.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SnakeClasses.lean new file mode 100644 index 0000000000..0776811395 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SnakeClasses.lean @@ -0,0 +1,184 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidityClasses +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTensor + +/-! +# The snake identities on Hom classes + +The two snake composites of the skein category are the identity +class. Both composites are concrete fragments built from strands +by tensor and composition, and the entire gluing stack reduces +definitionally on concrete data, so the fragment equivalences are +established by `decide` over the two surviving flags, with the +inverse flag map given canonically by the boundary-flag function. +-/ + +@[expose] public section + +namespace RS + +/-- The left snake fragment `(coev ⊗ id) ∘ (id ⊗ ev)`. -/ +noncomputable def snakeFragL : Fragment (Fin (1 + 1)) := + (tensorFragment coevFrag (strandBundle 1)).compose + (tensorFragment (strandBundle 1) evFrag) + +/-- The right snake fragment `(id ⊗ coev) ∘ (ev ⊗ id)`. -/ +noncomputable def snakeFragR : Fragment (Fin (1 + 1)) := + (tensorFragment (strandBundle 1) coevFrag).compose + (tensorFragment evFrag (strandBundle 1)) + +private instance : IsEmpty (strandBundle 1).Vertex := + inferInstanceAs (IsEmpty Empty) + +private instance : Fintype (strandBundle 1).Flag := + inferInstanceAs (Fintype (Fin 1 × Bool)) + +private instance : DecidableEq (strandBundle 1).Flag := + inferInstanceAs (DecidableEq (Fin 1 × Bool)) + +private instance : IsEmpty snakeFragL.Vertex := + inferInstanceAs (IsEmpty ((Empty ⊕ Empty) ⊕ (Empty ⊕ Empty))) + +private instance : IsEmpty snakeFragR.Vertex := + inferInstanceAs (IsEmpty ((Empty ⊕ Empty) ⊕ (Empty ⊕ Empty))) + +private instance : DecidableEq snakeFragL.Vertex := + fun a _ => isEmptyElim a + +private instance : DecidableEq snakeFragR.Vertex := + fun a _ => isEmptyElim a + +private noncomputable instance : DecidableEq snakeFragL.Flag := + snakeFragL.flagDecEq + +private noncomputable instance : DecidableEq snakeFragR.Flag := + snakeFragR.flagDecEq + +private noncomputable instance : Fintype snakeFragL.Flag := + snakeFragL.flagFintype + +private noncomputable instance : Fintype snakeFragR.Flag := + snakeFragR.flagFintype + +/-- The left snake fragment is the identity strand. -/ +noncomputable def snakeFragLEquiv : + (strandBundle 1).Equiv snakeFragL where + flagEquiv := _root_.Equiv.ofBijective + (fun g : Fin 1 × Bool => + snakeFragL.boundaryFlag (if g.2 then 1 else 0)) + (by + exact (Fintype.bijective_iff_injective_and_card _).mpr + ⟨by + intro a b h + obtain ⟨i, ba⟩ := a + obtain ⟨j, bb⟩ := b + have hi : i = ⟨0, Nat.zero_lt_one⟩ := Fin.ext (by + have := i.isLt + omega) + have hj : j = ⟨0, Nat.zero_lt_one⟩ := Fin.ext (by + have := j.isLt + omega) + subst hi + subst hj + cases ba <;> cases bb + · rfl + · exact absurd h (by decide) + · exact absurd h (by decide) + · rfl, + by decide⟩) + vertexEquiv := @_root_.Equiv.equivOfIsEmpty _ _ (by infer_instance) (by infer_instance) + attach_comm := fun g => by + obtain ⟨i, b⟩ := g + have hi : i = ⟨0, Nat.zero_lt_one⟩ := Fin.ext (by + have := i.isLt + omega) + subst hi + cases b <;> decide + pairing_comm := fun g => by + obtain ⟨i, b⟩ := g + have hi : i = ⟨0, Nat.zero_lt_one⟩ := Fin.ext (by + have := i.isLt + omega) + subst hi + cases b <;> decide + circles_eq := by decide + +/-- The right snake fragment is the identity strand. -/ +noncomputable def snakeFragREquiv : + (strandBundle 1).Equiv snakeFragR where + flagEquiv := _root_.Equiv.ofBijective + (fun g : Fin 1 × Bool => + snakeFragR.boundaryFlag (if g.2 then 1 else 0)) + (by + exact (Fintype.bijective_iff_injective_and_card _).mpr + ⟨by + intro a b h + obtain ⟨i, ba⟩ := a + obtain ⟨j, bb⟩ := b + have hi : i = ⟨0, Nat.zero_lt_one⟩ := Fin.ext (by + have := i.isLt + omega) + have hj : j = ⟨0, Nat.zero_lt_one⟩ := Fin.ext (by + have := j.isLt + omega) + subst hi + subst hj + cases ba <;> cases bb + · rfl + · exact absurd h (by decide) + · exact absurd h (by decide) + · rfl, + by decide⟩) + vertexEquiv := @_root_.Equiv.equivOfIsEmpty _ _ (by infer_instance) (by infer_instance) + attach_comm := fun g => by + obtain ⟨i, b⟩ := g + have hi : i = ⟨0, Nat.zero_lt_one⟩ := Fin.ext (by + have := i.isLt + omega) + subst hi + cases b <;> decide + pairing_comm := fun g => by + obtain ⟨i, b⟩ := g + have hi : i = ⟨0, Nat.zero_lt_one⟩ := Fin.ext (by + have := i.isLt + omega) + subst hi + cases b <;> decide + circles_eq := by decide + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The identity class on one strand. -/ +noncomputable def idClass : HomSpace f.val (1 + 1) := + HomSpace.ofFragment f.val (strandBundle 1) + +/-- **The left snake identity** on Hom classes. -/ +theorem snake_left : + HomSpace.comp f 1 3 1 + (HomSpace.tensor f 0 2 1 1 (coevClass f) (idClass f)) + (HomSpace.tensor f 1 1 2 0 (idClass f) (evClass f)) = + idClass f := by + rw [coevClass, evClass, idClass, + HomSpace.tensor_ofFragment, HomSpace.tensor_ofFragment, + HomSpace.comp_ofFragment] + exact (HomSpace.ofFragment_congr f (snakeFragLEquiv).symm) + +/-- **The right snake identity** on Hom classes. -/ +theorem snake_right : + HomSpace.comp f 1 3 1 + (HomSpace.tensor f 1 1 0 2 (idClass f) (coevClass f)) + (HomSpace.tensor f 2 0 1 1 (evClass f) (idClass f)) = + idClass f := by + rw [coevClass, evClass, idClass, + HomSpace.tensor_ofFragment, HomSpace.tensor_ofFragment, + HomSpace.comp_ofFragment] + exact (HomSpace.ofFragment_congr f (snakeFragREquiv).symm) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarCompClass.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarCompClass.lean new file mode 100644 index 0000000000..e6d9448007 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarCompClass.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarTrace +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarFunctional +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarClass + +/-! +# The star composite in the category + +The accompanying paper's (★) in categorical form: composing the star-union +class `Hom(0, 2m)` with the strand-bundle class `Hom(2m, 0)` is +the parameter value times the empty class — the identity that the +fibre functor transports into the standard model. +-/ + +@[expose] public section + +namespace RS + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The star-union class as a `(0, 2m)`-morphism. -/ +noncomputable def starClass (W : ClosedFragment) : + HomSpace f.val (0 + (edgeCount W + edgeCount W)) := + HomSpace.ofFragment f.val + ((starUnion W).relabel (finCongr + (by omega : edgeCount W + edgeCount W = + 0 + (edgeCount W + edgeCount W)))) + +/-- The strand-bundle class as a `(2m, 0)`-morphism. -/ +noncomputable def bundleCapClass (m : ℕ) : + HomSpace f.val ((m + m) + 0) := + HomSpace.ofFragment f.val + ((strandBundle m).relabel (finCongr + (by omega : m + m = (m + m) + 0))) + +/-- **The categorical (★)**: the star composite is the parameter +value times the empty class. -/ +theorem star_comp_class (W : ClosedFragment) : + HomSpace.comp f 0 (edgeCount W + edgeCount W) 0 + (starClass f W) (bundleCapClass f (edgeCount W)) = + f.val W • + HomSpace.ofFragment f.val emptyClosedFragment := by + rw [starClass, bundleCapClass, HomSpace.comp_ofFragment] + rw [show ((starUnion W).relabel (finCongr + (by omega : edgeCount W + edgeCount W = + 0 + (edgeCount W + edgeCount W)))).compose + ((strandBundle (edgeCount W)).relabel (finCongr + (by omega : edgeCount W + edgeCount W = + (edgeCount W + edgeCount W) + 0))) = + pairClose (starUnion W) (strandBundle (edgeCount W)) + from rfl] + rw [HomSpace.ofFragment_congr f (starUnionPairClose W)] + exact ofFragment_eq_smul_empty f W + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarDecomposition.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarDecomposition.lean new file mode 100644 index 0000000000..275f2f5c9a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarDecomposition.lean @@ -0,0 +1,451 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarExplode +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc + +/-! +# The star decomposition + +Regluing the explosion along the matching restores the fragment +(`explode_reglue`): an induction over a list of orbit +representatives, each step being `explodeAtGluePair`, threaded +through `glueList_cons`. Taking the representatives to be the +canonical ones gives `starDecomposition`, the accompanying paper's +"stars and closed graphs" (§3.2): every closed fragment is its star +union glued along the edge matching. +-/ + +@[expose] public section + +namespace RS + +section Decomposition + +variable (W : ClosedFragment) + +/-- The matching pairs of a representative list, as labels of the +explosion at `C`. -/ +def repPairs (C : Finset W.Flag) (hC : CutClosed W C) : + (l : List W.Flag) → (∀ x ∈ l, x ∈ C) → + List ({f : W.Flag // f ∈ C} × {f : W.Flag // f ∈ C}) + | [], _ => [] + | x :: l, h => + (⟨x, h x List.mem_cons_self⟩, + ⟨W.pairing x, hC x (h x List.mem_cons_self)⟩) :: + repPairs C hC l + (fun y hy => h y (List.mem_cons.mpr (Or.inr hy))) + +/-- Coverage: the orbits of the list exhaust the cut set. -/ +def Covers (C : Finset W.Flag) (l : List W.Flag) : Prop := + ∀ g ∈ C, ∃ x ∈ l, g = x ∨ g = W.pairing x + +/-- The tail of a representative list covers the shrunken cut +set, provided the head's orbit is disjoint from the tail's +pairs (from well-formedness). -/ +theorem covers_tail {C : Finset W.Flag} {x : W.Flag} + {l : List W.Flag} (hcov : Covers W C (x :: l)) + (hdisj : ∀ y ∈ l, y ≠ x ∧ y ≠ W.pairing x ∧ + W.pairing y ≠ x ∧ W.pairing y ≠ W.pairing x) : + Covers W (cutErase W C x) l := by + intro g hg + rw [mem_cutErase] at hg + obtain ⟨hgC, hgx, hgpx⟩ := hg + obtain ⟨y, hy, hcase⟩ := hcov g hgC + rcases List.mem_cons.mp hy with rfl | hyl + · rcases hcase with rfl | rfl + · exact absurd rfl hgx + · exact absurd rfl hgpx + · exact ⟨y, hyl, hcase⟩ + +/-- Membership in the flattened matching pairs: the orbits of the +list. -/ +theorem mem_repPairs_flat (C : Finset W.Flag) + (hC : CutClosed W C) : + ∀ (l : List W.Flag) (h : ∀ x ∈ l, x ∈ C) + (z : {f : W.Flag // f ∈ C}), + z ∈ (repPairs W C hC l h).flatMap + (fun p => [p.1, p.2]) ↔ + ∃ y ∈ l, z.val = y ∨ z.val = W.pairing y + | [], _, z => by + simp [repPairs] + | x :: l, h, z => by + simp only [repPairs, List.flatMap_cons, List.mem_append, + List.mem_cons, List.not_mem_nil, or_false] + rw [mem_repPairs_flat C hC l _ z] + constructor + · rintro ((rfl | rfl) | ⟨y, hy, hcase⟩) + · exact ⟨x, Or.inl rfl, Or.inl rfl⟩ + · exact ⟨x, Or.inl rfl, Or.inr rfl⟩ + · exact ⟨y, Or.inr hy, hcase⟩ + · rintro ⟨y, rfl | hyl, hcase⟩ + · rcases hcase with hv | hv + · exact Or.inl (Or.inl (Subtype.ext hv)) + · exact Or.inl (Or.inr (Subtype.ext hv)) + · exact Or.inr ⟨y, hyl, hcase⟩ + +/-- No label survives a covering matching. -/ +theorem repPairs_surv_isEmpty (C : Finset W.Flag) + (hC : CutClosed W C) (l : List W.Flag) + (h : ∀ x ∈ l, x ∈ C) (hcov : Covers W C l) : + IsEmpty (Fragment.FoldSurviving {f : W.Flag // f ∈ C} + (repPairs W C hC l h)) := by + refine ⟨fun s => ?_⟩ + obtain ⟨⟨g, hgC⟩, hprop⟩ := s + have hmem := (forall_ne_iff_not_mem_flat _ _).mp hprop + refine hmem ?_ + rw [mem_repPairs_flat] + exact hcov g hgC + +/-- The coerced matching tail is the matching of the shrunken cut +set, through the step label equivalence. -/ +theorem coerce_repPairs (C : Finset W.Flag) + (hC : CutClosed W C) (x : W.Flag) (hx : x ∈ C) : + ∀ (l : List W.Flag) (h : ∀ y ∈ l, y ∈ C) + (h' : ∀ y ∈ l, y ∈ cutErase W C x) + (hsep : Fragment.PairsSep (stepLabelI W C x hx) + (stepLabelJ W C hC x hx) (repPairs W C hC l h)), + Fragment.coercePairsList (stepLabelI W C x hx) + (stepLabelJ W C hC x hx) (repPairs W C hC l h) hsep = + Fragment.mapPairs (stepLabelEquiv W C hC x hx) + (repPairs W (cutErase W C x) + (cutErase_closed W C hC x) l h') + | [], _, _, _ => rfl + | y :: l, h, h', hsep => by + simp only [repPairs, Fragment.coercePairsList, + Fragment.mapPairs, List.map_cons] + refine congrArg₂ List.cons (Prod.ext ?_ ?_) + (coerce_repPairs C hC x hx l _ _ _) + · exact Subtype.ext (Subtype.ext rfl) + · exact Subtype.ext (Subtype.ext rfl) + +/-- The pair of a list member is in the matching. -/ +theorem repPairs_mem (C : Finset W.Flag) (hC : CutClosed W C) : + ∀ (l : List W.Flag) (h : ∀ x ∈ l, x ∈ C) {y : W.Flag} + (hy : y ∈ l), + (⟨y, h y hy⟩, + (⟨W.pairing y, hC y (h y hy)⟩ : + {f : W.Flag // f ∈ C})) ∈ repPairs W C hC l h + | [], _, _, hy => absurd hy (List.not_mem_nil) + | a :: l, h, y, hy => by + rcases List.mem_cons.mp hy with rfl | hyl + · exact List.mem_cons_self + · exact List.mem_cons.mpr + (Or.inr (repPairs_mem C hC l _ hyl)) + +/-- The head-orbit disjointness facts, from well-formedness. -/ +theorem repPairs_head_disj {C : Finset W.Flag} + {hC : CutClosed W C} {x : W.Flag} {l : List W.Flag} + {h : ∀ y ∈ x :: l, y ∈ C} + (wf : Fragment.PairsWF (repPairs W C hC (x :: l) h)) : + ∀ y ∈ l, y ≠ x ∧ y ≠ W.pairing x ∧ + W.pairing y ≠ x ∧ W.pairing y ≠ W.pairing x := by + intro y hy + have hmem := repPairs_mem W C hC l + (fun z hz => h z (List.mem_cons.mpr (Or.inr hz))) hy + have hy1 := wf.sep _ hmem + obtain ⟨h1, h2, h3, h4⟩ := hy1 + exact ⟨fun he => h1 (Subtype.ext he), + fun he => h2 (Subtype.ext he), + fun he => h3 (Subtype.ext he), + fun he => h4 (Subtype.ext he)⟩ + +/-- Well-formedness transports along mapped pairs. -/ +theorem mapPairs_wf_of {α β : Type} (e : α ≃ β) + {ps : List (α × α)} + (h : Fragment.PairsWF (Fragment.mapPairs e ps)) : + Fragment.PairsWF ps := by + have h2 := Fragment.mapPairs_wf e.symm _ h + have h3 : Fragment.mapPairs e.symm (Fragment.mapPairs e ps) = + ps := by + rw [show Fragment.mapPairs e ps = + Fragment.mapPairs e.symm.symm ps by + rw [_root_.Equiv.symm_symm]] + exact mapPairs_symm_cancel e.symm ps + rwa [h3] at h2 + +/-- The explosion at a memberless cut set is the fragment, +generalized over the cut set. -/ +noncomputable def explodeAtNotMem (C : Finset W.Flag) + (hC : CutClosed W C) (hne : ∀ f, f ∉ C) + (e0 : Fin 0 ≃ {f : W.Flag // f ∈ C}) : + (W.relabel e0).Equiv (explodeAt W C hC) := + haveI : IsEmpty {f : W.Flag // f ∈ C} := + ⟨fun s => hne s.val s.prop⟩ + { flagEquiv := (_root_.Equiv.sumEmpty W.Flag + {f : W.Flag // f ∈ C}).symm + vertexEquiv := _root_.Equiv.refl W.Vertex + attach_comm := fun f => by + change (explodeAt W C hC).attach (Sum.inl f) = + ((W.attach f).map id _).map (_root_.Equiv.refl _) id + rw [ClosedFragment.attach_eq_vertexOf W f] + rfl + pairing_comm := fun f => by + change (Sum.inl (W.pairing f) : + W.Flag ⊕ {f : W.Flag // f ∈ C}) = + (explodeAt W C hC).pairing (Sum.inl f) + have hp : ∀ g : W.Flag, (explodeAt W C hC).pairing + (Sum.inl g) = Sum.inl (W.pairing g) := fun g => by + change (if h : g ∈ C then + (Sum.inr ⟨g, h⟩ : W.Flag ⊕ {f : W.Flag // f ∈ C}) + else Sum.inl (W.pairing g)) = Sum.inl (W.pairing g) + exact dite_eq_right (hne g) + rw [hp f] + circles_eq := rfl } + +/-- **The regluing induction**: gluing the covering matching in +the explosion restores the fragment. -/ +theorem explode_reglue : + ∀ (l : List W.Flag) (C : Finset W.Flag) + (hC : CutClosed W C) (h : ∀ x ∈ l, x ∈ C) + (_hcov : Covers W C l) + (wf : Fragment.PairsWF (repPairs W C hC l h)) + (e : Fin 0 ≃ Fragment.FoldSurviving + {f : W.Flag // f ∈ C} (repPairs W C hC l h)), + Nonempty ((Fragment.glueList (explodeAt W C hC) + (repPairs W C hC l h) wf).Equiv (W.relabel e)) + | [], C, hC, h, hcov, wf, e => by + have hne : ∀ f, f ∉ C := fun f hf => by + obtain ⟨x, hx, _⟩ := hcov f hf + exact absurd hx (List.not_mem_nil) + have : IsEmpty {f : W.Flag // f ∈ C} := + ⟨fun s => hne s.val s.prop⟩ + refine ⟨?_⟩ + change ((explodeAt W C hC).relabel + Fragment.foldSurvivingNilEquiv.symm).Equiv (W.relabel e) + refine (Fragment.Equiv.relabelCongr + (explodeAtNotMem W C hC hne + (_root_.Equiv.equivOfIsEmpty (Fin 0) _)).symm + Fragment.foldSurvivingNilEquiv.symm).trans ?_ + refine (Fragment.Equiv.relabelTrans W _ _).trans ?_ + exact Fragment.Equiv.relabelEq W + (_root_.Equiv.ext (fun i => i.elim0)) + | x :: l, C, hC, h, hcov, wf, e => by + have hx : x ∈ C := h x List.mem_cons_self + have hdisj := repPairs_head_disj W wf + have htail : ∀ y ∈ l, y ∈ C := + fun y hy => h y (List.mem_cons.mpr (Or.inr hy)) + have h' : ∀ y ∈ l, y ∈ cutErase W C x := fun y hy => + (mem_cutErase W C x).mpr + ⟨htail y hy, (hdisj y hy).1, (hdisj y hy).2.1⟩ + have hcov' : Covers W (cutErase W C x) l := + covers_tail W hcov hdisj + -- the coerced tail is the shrunken matching + have hco := coerce_repPairs W C hC x hx l htail h' wf.sep + have wfco : Fragment.PairsWF + (Fragment.coercePairsList (stepLabelI W C x hx) + (stepLabelJ W C hC x hx) + (repPairs W C hC l htail) wf.sep) := + Fragment.coercePairsList_wf _ _ _ wf.tail wf.sep + have wf' : Fragment.PairsWF + (repPairs W (cutErase W C x) + (cutErase_closed W C hC x) l h') := + mapPairs_wf_of (stepLabelEquiv W C hC x hx) + (hco ▸ wfco) + have : IsEmpty (Fragment.FoldSurviving + {f : W.Flag // f ∈ cutErase W C x} + (repPairs W (cutErase W C x) + (cutErase_closed W C hC x) l h')) := + repPairs_surv_isEmpty W (cutErase W C x) + (cutErase_closed W C hC x) l h' hcov' + obtain ⟨IH⟩ := explode_reglue l (cutErase W C x) + (cutErase_closed W C hC x) h' hcov' wf' + (_root_.Equiv.equivOfIsEmpty (Fin 0) _) + refine ⟨?_⟩ + change (Fragment.glueList (explodeAt W C hC) + ((⟨x, hx⟩, ⟨W.pairing x, hC x hx⟩) :: + repPairs W C hC l htail) + wf).Equiv (W.relabel e) + rw [Fragment.glueList_cons (explodeAt W C hC) + (⟨x, hx⟩, ⟨W.pairing x, hC x hx⟩) + (repPairs W C hC l htail) wf] + -- transport the inner fold across the one-step equivalence + have C1 := Fragment.glueListCongr + (explodeAtGluePair W C hC x hx) _ wfco + -- bridge the coerced pairs to the mapped shrunken matching + have C2 := Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv + ((explodeAt W (cutErase W C x) + (cutErase_closed W C hC x)).relabel + (stepLabelEquiv W C hC x hx)) + hco wfco + (Fragment.mapPairs_wf (stepLabelEquiv W C hC x hx) _ + wf') + (List.Perm.of_eq hco)) + -- pull the step relabel out + have C3 := Fragment.glueListRelabel + (explodeAt W (cutErase W C x) + (cutErase_closed W C hC x)) + (stepLabelEquiv W C hC x hx) + (repPairs W (cutErase W C x) + (cutErase_closed W C hC x) l h') wf' + -- assemble: the inner chain, fully spelled + have K : (Fragment.glueList + ((explodeAt W C hC).gluePair (stepLabelI W C x hx) + (stepLabelJ W C hC x hx) + (stepLabel_ne W C hC x hx)) + (Fragment.coercePairsList (stepLabelI W C x hx) + (stepLabelJ W C hC x hx) + (repPairs W C hC l htail) wf.sep) wfco).Equiv + (W.relabel + (((_root_.Equiv.equivOfIsEmpty (Fin 0) + (Fragment.FoldSurviving + {f : W.Flag // f ∈ cutErase W C x} + (repPairs W (cutErase W C x) + (cutErase_closed W C hC x) l h'))).trans + (Fragment.foldSurvivingMapEquiv + (stepLabelEquiv W C hC x hx) + (repPairs W (cutErase W C x) + (cutErase_closed W C hC x) l h'))).trans + (Fragment.foldSurvivingPermEquiv + (List.Perm.of_eq hco)).symm)) := + C1.trans (C2.trans + ((Fragment.Equiv.relabelCongr + (C3.trans + ((Fragment.Equiv.relabelCongr IH + (Fragment.foldSurvivingMapEquiv + (stepLabelEquiv W C hC x hx) + (repPairs W (cutErase W C x) + (cutErase_closed W C hC x) l h'))).trans + (Fragment.Equiv.relabelTrans W _ _))) + (Fragment.foldSurvivingPermEquiv + (List.Perm.of_eq hco)).symm).trans + (Fragment.Equiv.relabelTrans W _ _))) + exact (Fragment.Equiv.relabelCongr K + (Fragment.foldFlatten _ _ _ _)).trans + ((Fragment.Equiv.relabelTrans W _ _).trans + (Fragment.Equiv.relabelEq W + (_root_.Equiv.ext (fun i => i.elim0)))) + +/-- Well-formedness of the matching from list distinctness and +orbit disjointness. -/ +theorem repPairs_wf_of (C : Finset W.Flag) (hC : CutClosed W C) : + ∀ (l : List W.Flag) (h : ∀ x ∈ l, x ∈ C) + (_ : l.Nodup) + (_ : ∀ x ∈ l, ∀ y ∈ l, x ≠ y → x ≠ W.pairing y), + Fragment.PairsWF (repPairs W C hC l h) + | [], _, _, _ => List.nodup_nil + | x :: l, h, hnodup, hdisj => by + have htail : ∀ y ∈ l, y ∈ C := + fun y hy => h y (List.mem_cons.mpr (Or.inr hy)) + change ((⟨x, _⟩, ⟨W.pairing x, _⟩) :: + repPairs W C hC l htail).flatMap + (fun p => [p.1, p.2]) |>.Nodup + rw [List.flatMap_cons] + refine List.Nodup.append ?_ ?_ ?_ + · refine List.nodup_cons.mpr ⟨?_, List.nodup_singleton _⟩ + simp only [List.mem_singleton] + exact fun he => W.pairing_ne x + (congrArg Subtype.val he).symm + · exact repPairs_wf_of C hC l htail + (List.nodup_cons.mp hnodup).2 + (fun a ha b hb hab => hdisj a + (List.mem_cons.mpr (Or.inr ha)) b + (List.mem_cons.mpr (Or.inr hb)) hab) + · intro z hz hz2 + have hz3 := (mem_repPairs_flat W C hC l htail z).mp hz2 + obtain ⟨y, hy, hcase⟩ := hz3 + have hxy : x ≠ y := fun he => + (List.nodup_cons.mp hnodup).1 (he ▸ hy) + simp only [List.mem_cons, List.not_mem_nil, + or_false] at hz + rcases hz with rfl | rfl + · rcases hcase with hv | hv + · exact hxy hv + · exact hdisj x List.mem_cons_self y + (List.mem_cons.mpr (Or.inr hy)) hxy hv + · rcases hcase with hv | hv + · exact hdisj y (List.mem_cons.mpr (Or.inr hy)) x + List.mem_cons_self (fun he => hxy he.symm) hv.symm + · exact hxy (by + have h5 : W.pairing x = W.pairing y := hv + have := congrArg W.pairing h5 + rwa [W.pairing_invol, W.pairing_invol] at this) + +/-- The canonical orbit representatives: flags enumerated below +their partners. -/ +noncomputable def canonicalReps : List W.Flag := + (Finset.univ.filter (fun f => + (Fintype.equivFin W.Flag f : ℕ) < + Fintype.equivFin W.Flag (W.pairing f))).toList + +/-- A flag represents its edge exactly when it is the lower of the +two under the enumeration. -/ +theorem mem_canonicalReps {f : W.Flag} : + f ∈ canonicalReps W ↔ + (Fintype.equivFin W.Flag f : ℕ) < + Fintype.equivFin W.Flag (W.pairing f) := by + unfold canonicalReps + rw [Finset.mem_toList, Finset.mem_filter] + simp + +/-- The canonical representatives cover everything. -/ +theorem canonicalReps_covers : + Covers W Finset.univ (canonicalReps W) := by + intro g _ + have hne : (Fintype.equivFin W.Flag g : ℕ) ≠ + Fintype.equivFin W.Flag (W.pairing g) := fun he => + W.pairing_ne g (((Fintype.equivFin W.Flag).injective + (Fin.ext he)).symm) + rcases lt_or_gt_of_ne hne with hlt | hgt + · exact ⟨g, (mem_canonicalReps W).mpr hlt, Or.inl rfl⟩ + · refine ⟨W.pairing g, (mem_canonicalReps W).mpr ?_, + Or.inr (W.pairing_invol g).symm⟩ + rw [W.pairing_invol] + exact hgt + +/-- The canonical representatives are orbit-disjoint. -/ +theorem canonicalReps_disj : + ∀ x ∈ canonicalReps W, ∀ y ∈ canonicalReps W, + x ≠ y → x ≠ W.pairing y := by + intro x hx y hy _ he + have h1 := (mem_canonicalReps W).mp hx + have h2 := (mem_canonicalReps W).mp hy + rw [he] at h1 + rw [W.pairing_invol] at h1 + omega + +/-- The full cut is pairing-closed. -/ +theorem fullCut_closed : CutClosed W Finset.univ := + fun _ _ => Finset.mem_univ _ + +/-- The canonical matching is well-formed. -/ +theorem canonicalReps_wf : + Fragment.PairsWF (repPairs W Finset.univ (fullCut_closed W) + (canonicalReps W) (fun _ _ => Finset.mem_univ _)) := + repPairs_wf_of W Finset.univ (fullCut_closed W) + (canonicalReps W) _ (Finset.nodup_toList _) + (canonicalReps_disj W) + +/-- Regluing the whole matching leaves no surviving label: the +decomposition closes the fragment. -/ +instance canonical_surv_isEmpty : + IsEmpty (Fragment.FoldSurviving + {f : W.Flag // f ∈ (Finset.univ : Finset W.Flag)} + (repPairs W Finset.univ (fullCut_closed W) + (canonicalReps W) (fun _ _ => Finset.mem_univ _))) := + repPairs_surv_isEmpty W Finset.univ (fullCut_closed W) + (canonicalReps W) _ (canonicalReps_covers W) + +/-- **The star decomposition** (accompanying paper §3.2, "stars and closed +graphs"): every closed fragment is its star union, reglued along +the canonical edge matching. -/ +theorem starDecomposition (W : ClosedFragment) : + Nonempty ((Fragment.glueList + (explodeAt W Finset.univ (fullCut_closed W)) + (repPairs W Finset.univ (fullCut_closed W) + (canonicalReps W) (fun _ _ => Finset.mem_univ _)) + (canonicalReps_wf W)).Equiv + (W.relabel (_root_.Equiv.equivOfIsEmpty (Fin 0) _))) := + explode_reglue W (canonicalReps W) Finset.univ + (fullCut_closed W) (fun _ _ => Finset.mem_univ _) + (canonicalReps_covers W) (canonicalReps_wf W) _ + +end Decomposition + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarEnum.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarEnum.lean new file mode 100644 index 0000000000..0af322fabd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarEnum.lean @@ -0,0 +1,318 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarDecomposition + +/-! +# The star union with a `Fin`-boundary + +The explosion at the full cut, enumerated representatives-first: +each edge orbit contributes its canonical representative among the +first `m` boundary labels and its partner among the last `m`. +Under this enumeration the canonical matching becomes the straight +matching `i ↔ m + i`, so the star decomposition says that gluing +the straight matching in the star union restores the fragment — +the shape the trace calculus closes against the strand bundle. +-/ + +@[expose] public section + +namespace RS + +section StarEnum + +variable (W : ClosedFragment) + +/-- The number of edges: one canonical representative per orbit. -/ +noncomputable abbrev edgeCount : ℕ := (canonicalReps W).length + +/-- The representatives are pairwise distinct: one per edge orbit. -/ +theorem canonicalReps_nodup : (canonicalReps W).Nodup := + Finset.nodup_toList _ + +/-- The partner of a representative is not a representative. -/ +theorem pairing_notMem_canonicalReps {f : W.Flag} + (h : f ∈ canonicalReps W) : + W.pairing f ∉ canonicalReps W := by + intro h2 + have h1 := (mem_canonicalReps W).mp h + have h3 := (mem_canonicalReps W).mp h2 + rw [W.pairing_invol] at h3 + omega + +/-- Every flag is a representative or the partner of one. -/ +theorem mem_or_pairing_mem (f : W.Flag) : + f ∈ canonicalReps W ∨ W.pairing f ∈ canonicalReps W := by + have hne : (Fintype.equivFin W.Flag f : ℕ) ≠ + Fintype.equivFin W.Flag (W.pairing f) := fun he => + W.pairing_ne f (((Fintype.equivFin W.Flag).injective + (Fin.ext he)).symm) + rcases lt_or_gt_of_ne hne with hlt | hgt + · exact Or.inl ((mem_canonicalReps W).mpr hlt) + · refine Or.inr ((mem_canonicalReps W).mpr ?_) + rw [W.pairing_invol] + exact hgt + +/-- The splitting map: a flag to its orbit representative, tagged +by which side of the orbit it sits on. -/ +noncomputable def repSplitFun (f : W.Flag) : + {x // x ∈ canonicalReps W} ⊕ {x // x ∈ canonicalReps W} := + if h : f ∈ canonicalReps W then Sum.inl ⟨f, h⟩ + else Sum.inr ⟨W.pairing f, (mem_or_pairing_mem W f).resolve_left h⟩ + +/-- The inverse splitting map. -/ +def repSplitInv : + ({x // x ∈ canonicalReps W} ⊕ {x // x ∈ canonicalReps W}) → + W.Flag + | Sum.inl x => x.val + | Sum.inr x => W.pairing x.val + +/-- The orbit split: a flag is a representative or a partner. -/ +noncomputable def repSplitEquiv : + W.Flag ≃ + {x // x ∈ canonicalReps W} ⊕ {x // x ∈ canonicalReps W} where + toFun := repSplitFun W + invFun := repSplitInv W + left_inv f := by + by_cases h : f ∈ canonicalReps W + · have h1 : repSplitFun W f = Sum.inl ⟨f, h⟩ := dite_eq_left h + rw [h1] + rfl + · have h1 : repSplitFun W f = + Sum.inr ⟨W.pairing f, + (mem_or_pairing_mem W f).resolve_left h⟩ := dite_eq_right h + rw [h1] + exact W.pairing_invol f + right_inv s := by + rcases s with x | x + · change repSplitFun W x.val = Sum.inl x + exact dite_eq_left x.prop + · change repSplitFun W (W.pairing x.val) = Sum.inr x + exact (dite_eq_right (pairing_notMem_canonicalReps W x.prop)).trans + (congrArg Sum.inr (Subtype.ext (W.pairing_invol x.val))) + +/-- The list-position equivalence of the representatives. -/ +noncomputable def repIndexEquiv : + {x // x ∈ canonicalReps W} ≃ Fin (edgeCount W) := + (List.Nodup.getEquiv (canonicalReps W) (canonicalReps_nodup W)).symm + +/-- **The star enumeration**: representatives on the low labels, +partners on the high labels, in list order. -/ +noncomputable def starEnum : + {f : W.Flag // f ∈ (Finset.univ : Finset W.Flag)} ≃ + Fin (edgeCount W + edgeCount W) := + ((Equiv.subtypeUnivEquiv (fun f => Finset.mem_univ f)).trans + (repSplitEquiv W)).trans + ((Equiv.sumCongr (repIndexEquiv W) (repIndexEquiv W)).trans + finSumFinEquiv) + +/-- **The star union**: the explosion at the full cut with the +representatives-first boundary enumeration. -/ +noncomputable def starUnion : + Fragment (Fin (edgeCount W + edgeCount W)) := + (explodeAt W Finset.univ (fullCut_closed W)).relabel (starEnum W) + +/-- The straight matching pairs `i ↔ m + i`. -/ +def matchPairs (m : ℕ) : List (Fin (m + m) × Fin (m + m)) := + (List.finRange m).map (fun j => (Fin.castAdd m j, Fin.natAdd m j)) + +/-- The straight matching has one pair per edge. -/ +theorem matchPairs_length (m : ℕ) : (matchPairs m).length = m := by + simp [matchPairs] + +/-- Its `j`th pair is `(j, m + j)`. -/ +theorem matchPairs_getElem (m j : ℕ) + (hj : j < (matchPairs m).length) (hj' : j < m) : + (matchPairs m)[j]'hj = + (Fin.castAdd m ⟨j, hj'⟩, Fin.natAdd m ⟨j, hj'⟩) := by + simp [matchPairs] + +/-- Transporting a pair list along an equivalence keeps its +length. -/ +theorem mapPairs_length {α β : Type} (e : α ≃ β) + (ps : List (α × α)) : + (Fragment.mapPairs e ps).length = ps.length := by + simp [Fragment.mapPairs] + +/-- And moves each pair componentwise. -/ +theorem mapPairs_getElem {α β : Type} (e : α ≃ β) + (ps : List (α × α)) (j : ℕ) + (hj : j < (Fragment.mapPairs e ps).length) + (hj' : j < ps.length) : + (Fragment.mapPairs e ps)[j]'hj = + (e (ps[j]'hj').1, e (ps[j]'hj').2) := by + simp [Fragment.mapPairs, Prod.map] + +/-! ### The enumeration sends the canonical matching to the +straight matching -/ + +/-- **The `j`th representative gets the low label `j`.** -/ +theorem starEnum_rep (j : ℕ) (hj : j < (canonicalReps W).length) : + starEnum W ⟨(canonicalReps W)[j]'hj, Finset.mem_univ _⟩ = + Fin.castAdd (edgeCount W) ⟨j, hj⟩ := by + have hmem : (canonicalReps W)[j]'hj ∈ canonicalReps W := + List.getElem_mem hj + change finSumFinEquiv + ((Equiv.sumCongr (repIndexEquiv W) (repIndexEquiv W)) + (repSplitEquiv W ((canonicalReps W)[j]'hj))) = _ + have h1 : repSplitEquiv W ((canonicalReps W)[j]'hj) = + Sum.inl ⟨(canonicalReps W)[j]'hj, hmem⟩ := dite_eq_left hmem + rw [h1, Equiv.sumCongr_apply, Sum.map_inl] + have h2 : repIndexEquiv W ⟨(canonicalReps W)[j]'hj, hmem⟩ = + ⟨j, hj⟩ := by + rw [show (⟨(canonicalReps W)[j]'hj, hmem⟩ : + {x // x ∈ canonicalReps W}) = + List.Nodup.getEquiv (canonicalReps W) + (canonicalReps_nodup W) ⟨j, hj⟩ from Subtype.ext rfl] + exact Equiv.symm_apply_apply _ _ + rw [h2] + exact finSumFinEquiv_apply_left ⟨j, hj⟩ + +/-- **Its partner gets the high label `m + j`** — so the canonical +matching becomes the straight one. -/ +theorem starEnum_partner (j : ℕ) + (hj : j < (canonicalReps W).length) : + starEnum W ⟨W.pairing ((canonicalReps W)[j]'hj), + Finset.mem_univ _⟩ = + Fin.natAdd (edgeCount W) ⟨j, hj⟩ := by + have hmem : (canonicalReps W)[j]'hj ∈ canonicalReps W := + List.getElem_mem hj + have hnot : W.pairing ((canonicalReps W)[j]'hj) ∉ + canonicalReps W := + pairing_notMem_canonicalReps W hmem + change finSumFinEquiv + ((Equiv.sumCongr (repIndexEquiv W) (repIndexEquiv W)) + (repSplitEquiv W (W.pairing ((canonicalReps W)[j]'hj)))) = _ + have h1 : repSplitEquiv W (W.pairing ((canonicalReps W)[j]'hj)) = + Sum.inr ⟨W.pairing (W.pairing ((canonicalReps W)[j]'hj)), + (mem_or_pairing_mem W _).resolve_left hnot⟩ := + dite_eq_right hnot + rw [h1, Equiv.sumCongr_apply, Sum.map_inr] + have h2 : repIndexEquiv W + ⟨W.pairing (W.pairing ((canonicalReps W)[j]'hj)), + (mem_or_pairing_mem W _).resolve_left hnot⟩ = ⟨j, hj⟩ := by + rw [show (⟨W.pairing (W.pairing ((canonicalReps W)[j]'hj)), + (mem_or_pairing_mem W _).resolve_left hnot⟩ : + {x // x ∈ canonicalReps W}) = + List.Nodup.getEquiv (canonicalReps W) + (canonicalReps_nodup W) ⟨j, hj⟩ from + Subtype.ext (by + change W.pairing (W.pairing ((canonicalReps W)[j]'hj)) = _ + rw [W.pairing_invol] + rfl)] + exact Equiv.symm_apply_apply _ _ + rw [h2] + exact finSumFinEquiv_apply_right ⟨j, hj⟩ + +/-- The representative pair list has one pair per listed flag. -/ +theorem repPairs_length (C : Finset W.Flag) (hC : CutClosed W C) : + ∀ (l : List W.Flag) (h : ∀ x ∈ l, x ∈ C), + (repPairs W C hC l h).length = l.length + | [], _ => rfl + | _ :: l, _ => congrArg Nat.succ (repPairs_length C hC l _) + +/-- And its `j`th pair is that flag with its partner. -/ +theorem repPairs_getElem (C : Finset W.Flag) (hC : CutClosed W C) : + ∀ (l : List W.Flag) (h : ∀ x ∈ l, x ∈ C) (j : ℕ) + (hj : j < (repPairs W C hC l h).length) + (hj' : j < l.length), + (repPairs W C hC l h)[j]'hj = + (⟨l[j]'hj', h _ (List.getElem_mem hj')⟩, + ⟨W.pairing (l[j]'hj'), + hC _ (h _ (List.getElem_mem hj'))⟩) + | [], _, j, hj, _ => absurd hj (by simp [repPairs]) + | x :: l, h, 0, _, _ => rfl + | x :: l, h, j + 1, hj, hj' => by + change (repPairs W C hC l _)[j]'_ = _ + exact repPairs_getElem C hC l _ j _ (by simpa using hj') + +/-- The enumerated canonical matching is the straight matching. -/ +theorem mapPairs_repPairs : + Fragment.mapPairs (starEnum W) + (repPairs W Finset.univ (fullCut_closed W) (canonicalReps W) + (fun _ _ => Finset.mem_univ _)) = + matchPairs (edgeCount W) := by + have hlen : (Fragment.mapPairs (starEnum W) + (repPairs W Finset.univ (fullCut_closed W) (canonicalReps W) + (fun _ _ => Finset.mem_univ _))).length = + (matchPairs (edgeCount W)).length := by + rw [mapPairs_length, + repPairs_length W Finset.univ (fullCut_closed W), + matchPairs_length] + apply List.ext_getElem hlen + intro j hj hj' + have hjr : j < (canonicalReps W).length := by + rw [mapPairs_length, + repPairs_length W Finset.univ (fullCut_closed W)] at hj + exact hj + have hjp : j < (repPairs W Finset.univ (fullCut_closed W) + (canonicalReps W) (fun _ _ => Finset.mem_univ _)).length := by + rw [repPairs_length W Finset.univ (fullCut_closed W)] + exact hjr + rw [mapPairs_getElem (starEnum W) _ j hj hjp, + repPairs_getElem W Finset.univ (fullCut_closed W) + (canonicalReps W) _ j hjp hjr, + matchPairs_getElem (edgeCount W) j hj' hjr] + exact Prod.ext (starEnum_rep W j hjr) (starEnum_partner W j hjr) + +/-! ### The transported star decomposition -/ + +/-- The straight matching is a well-formed gluing list on the star +union: it is the transported canonical list. -/ +theorem matchPairs_wf_star : + Fragment.PairsWF (matchPairs (edgeCount W)) := + mapPairs_repPairs W ▸ + Fragment.mapPairs_wf (starEnum W) _ (canonicalReps_wf W) + +/-- Gluing the straight matching in the star union leaves no +surviving label: the fold consumes the whole boundary, which is +what makes the decomposition restore the fragment. -/ +theorem starUnion_surv_isEmpty : + IsEmpty (Fragment.FoldSurviving + (Fin (edgeCount W + edgeCount W)) (matchPairs (edgeCount W))) := by + have e := Fragment.foldSurvivingMapEquiv (starEnum W) + (repPairs W Finset.univ (fullCut_closed W) (canonicalReps W) + (fun _ _ => Finset.mem_univ _)) + rw [mapPairs_repPairs W] at e + have := canonical_surv_isEmpty W + exact Function.isEmpty e.symm + +/-- **The star union self-glue**: gluing the straight matching in +the star union restores the fragment. -/ +theorem starUnion_reglue : + Nonempty ((Fragment.glueList (starUnion W) + (matchPairs (edgeCount W)) (matchPairs_wf_star W)).Equiv + (W.relabel + (haveI := starUnion_surv_isEmpty W + Equiv.equivOfIsEmpty (Fin 0) _))) := by + have := starUnion_surv_isEmpty W + obtain ⟨D⟩ := starDecomposition W + have G := Fragment.glueListRelabel + (explodeAt W Finset.univ (fullCut_closed W)) (starEnum W) + (repPairs W Finset.univ (fullCut_closed W) (canonicalReps W) + (fun _ _ => Finset.mem_univ _)) + (canonicalReps_wf W) + have E := Fragment.glueListEqEquiv (starUnion W) + (mapPairs_repPairs W) + (Fragment.mapPairs_wf (starEnum W) _ (canonicalReps_wf W)) + (matchPairs_wf_star W) + (List.Perm.of_eq (mapPairs_repPairs W)) + refine ⟨?_⟩ + refine (E.symm.trans ?_) + refine (Fragment.Equiv.relabelCongr G _).trans ?_ + refine (Fragment.Equiv.relabelCongr + (Fragment.Equiv.relabelCongr D _) _).trans ?_ + refine (Fragment.Equiv.relabelCongr + (Fragment.Equiv.relabelTrans W _ _) _).trans ?_ + refine (Fragment.Equiv.relabelTrans W _ _).trans ?_ + exact Fragment.Equiv.relabelEq W + (_root_.Equiv.ext (fun i => i.elim0)) + +end StarEnum + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarExplode.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarExplode.lean new file mode 100644 index 0000000000..c3b48fb662 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarExplode.lean @@ -0,0 +1,407 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueFold +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank + +/-! +# Exploding a closed fragment into stars + +The accompanying paper's "stars and closed graphs" (§3.2): a closed +fragment +is its own star union, reglued along the edge matching. The +explosion is parameterized by a pairing-closed set `C` of cut +flags: each cut flag's edge is severed, the freed half-edge +becoming a pendant boundary edge of its vertex's star. At +`C = ∅` the explosion is the fragment itself; at `C = univ` it is +the disjoint union of vertex stars. Regluing shrinks `C` one +edge at a time (`explodeAtGluePair`, next file), giving the star +decomposition by induction. +-/ + +@[expose] public section + +namespace RS + +/-- The vertex of a flag in a closed fragment. -/ +def ClosedFragment.vertexOf (W : ClosedFragment) (f : W.Flag) : + W.Vertex := + (W.attach f).elim id Fin.elim0 + +/-- Every flag of a closed fragment attaches to its vertex. -/ +theorem ClosedFragment.attach_eq_vertexOf (W : ClosedFragment) + (f : W.Flag) : + W.attach f = Sum.inl (ClosedFragment.vertexOf W f) := by + unfold ClosedFragment.vertexOf + rcases h : W.attach f with v | ℓ + · rfl + · exact Fin.elim0 ℓ + +/-- A pairing-closed cut set: with each flag, its partner. -/ +def CutClosed (W : ClosedFragment) (C : Finset W.Flag) : Prop := + ∀ f ∈ C, W.pairing f ∈ C + +/-- Membership of the partner, from cut closure. -/ +theorem CutClosed.pairing_mem {W : ClosedFragment} + {C : Finset W.Flag} (hC : CutClosed W C) {f : W.Flag} : + W.pairing f ∈ C ↔ f ∈ C := + ⟨fun h => W.pairing_invol f ▸ hC _ h, fun h => hC f h⟩ + +/-- **The explosion at a cut set**: sever each cut flag's edge, +the freed half-edge becoming a pendant boundary edge labelled by +the cut flag itself. -/ +def explodeAt (W : ClosedFragment) (C : Finset W.Flag) + (hC : CutClosed W C) : Fragment {f : W.Flag // f ∈ C} where + Flag := W.Flag ⊕ {f : W.Flag // f ∈ C} + Vertex := W.Vertex + attach := fun g => + match g with + | Sum.inl f => Sum.inl (ClosedFragment.vertexOf W f) + | Sum.inr s => Sum.inr s + pairing := fun g => + match g with + | Sum.inl f => + if h : f ∈ C then Sum.inr ⟨f, h⟩ + else Sum.inl (W.pairing f) + | Sum.inr s => Sum.inl s.val + pairing_invol := fun g => by + rcases g with f | s + · by_cases h : f ∈ C + · simp only [dite_eq_left h] + · simp only [dite_eq_right h, + dite_eq_right (fun hp => h (hC.pairing_mem.mp hp)), + W.pairing_invol] + · simp only [dite_eq_left s.prop] + pairing_ne := fun g h => by + rcases g with f | s + · have h' : (if h' : f ∈ C then + (Sum.inr ⟨f, h'⟩ : W.Flag ⊕ {f : W.Flag // f ∈ C}) + else Sum.inl (W.pairing f)) = Sum.inl f := h + by_cases hf : f ∈ C + · rw [dite_eq_left hf] at h' + exact Sum.inr_ne_inl h' + · rw [dite_eq_right hf] at h' + exact W.pairing_ne f (Sum.inl.inj h') + · exact Sum.inl_ne_inr h + boundaryFlag := fun s => Sum.inr s + attach_boundaryFlag := fun s => rfl + eq_boundaryFlag := fun s g h => by + rcases g with f | s' + · exact absurd h (by simp) + · exact congrArg Sum.inr (Sum.inr.inj h) + circles := W.circles + +/-! ### One regluing step -/ + +section GlueStep + +variable (W : ClosedFragment) (C : Finset W.Flag) + (hC : CutClosed W C) (f₀ : W.Flag) (h₀ : f₀ ∈ C) + +/-- The shrunken cut set: the edge of `f₀` restored. -/ +def cutErase : Finset W.Flag := + (C.erase f₀).erase (W.pairing f₀) + +/-- Erasing one edge from the cut set removes exactly its two +flags. -/ +theorem mem_cutErase {g : W.Flag} : + g ∈ cutErase W C f₀ ↔ + g ∈ C ∧ g ≠ f₀ ∧ g ≠ W.pairing f₀ := by + unfold cutErase + simp only [Finset.mem_erase] + tauto + +include hC in +/-- The erased set is still pairing-closed, so the explosion +recurses. -/ +theorem cutErase_closed : CutClosed W (cutErase W C f₀) := by + intro g hg + rw [mem_cutErase] at hg ⊢ + refine ⟨hC g hg.1, ?_, ?_⟩ + · intro h + exact hg.2.2 (by rw [← W.pairing_invol g, h]) + · intro h + exact hg.2.1 (by rw [← W.pairing_invol g, h, W.pairing_invol]) + +/-- The glued labels of the step, as labels of the explosion. -/ +def stepLabelI : {f : W.Flag // f ∈ C} := ⟨f₀, h₀⟩ + +/-- The partner label of the step. -/ +def stepLabelJ : {f : W.Flag // f ∈ C} := + ⟨W.pairing f₀, hC f₀ h₀⟩ + +/-- The two labels the severed edge creates are distinct. -/ +theorem stepLabel_ne : stepLabelI W C f₀ h₀ ≠ + stepLabelJ W C hC f₀ h₀ := fun h => + W.pairing_ne f₀ (congrArg Subtype.val h).symm + +/-- The surviving labels of the step are the shrunken cut set. -/ +def stepLabelEquiv : + {f : W.Flag // f ∈ cutErase W C f₀} ≃ + Fragment.SurvivingLabel {f : W.Flag // f ∈ C} + (stepLabelI W C f₀ h₀) (stepLabelJ W C hC f₀ h₀) where + toFun s := + ⟨⟨s.val, ((mem_cutErase W C f₀).mp s.prop).1⟩, + fun h => ((mem_cutErase W C f₀).mp s.prop).2.1 + (congrArg Subtype.val h), + fun h => ((mem_cutErase W C f₀).mp s.prop).2.2 + (congrArg Subtype.val h)⟩ + invFun t := + ⟨t.val.val, (mem_cutErase W C f₀).mpr + ⟨t.val.prop, + fun h => t.prop.1 (Subtype.ext h), + fun h => t.prop.2 (Subtype.ext h)⟩⟩ + left_inv _s := Subtype.ext rfl + right_inv _t := Subtype.ext (Subtype.ext rfl) + +/-- The surviving flags of the step are the flags of the smaller +explosion. -/ +def stepFlagEquiv : + Fragment.SurvivingFlag (explodeAt W C hC) + (stepLabelI W C f₀ h₀) (stepLabelJ W C hC f₀ h₀) ≃ + (W.Flag ⊕ {f : W.Flag // f ∈ cutErase W C f₀}) where + toFun g := + match g with + | ⟨Sum.inl f, _⟩ => Sum.inl f + | ⟨Sum.inr s, hs⟩ => + Sum.inr ⟨s.val, (mem_cutErase W C f₀).mpr + ⟨s.prop, + fun h => hs.1 (congrArg Sum.inr (Subtype.ext h)), + fun h => hs.2 (congrArg Sum.inr (Subtype.ext h))⟩⟩ + invFun g := + match g with + | Sum.inl f => + ⟨Sum.inl f, Sum.inl_ne_inr, Sum.inl_ne_inr⟩ + | Sum.inr s' => + ⟨Sum.inr ⟨s'.val, + ((mem_cutErase W C f₀).mp s'.prop).1⟩, + fun h => ((mem_cutErase W C f₀).mp s'.prop).2.1 + (congrArg Subtype.val (Sum.inr.inj h)), + fun h => ((mem_cutErase W C f₀).mp s'.prop).2.2 + (congrArg Subtype.val (Sum.inr.inj h))⟩ + left_inv g := by + obtain ⟨gv, hg⟩ := g + rcases gv with f | s + · rfl + · exact Subtype.ext (congrArg Sum.inr (Subtype.ext rfl)) + right_inv g := by + rcases g with f | s' + · rfl + · exact congrArg Sum.inr (Subtype.ext rfl) + +private theorem explodeAt_rewire_pairing + (hopen : (explodeAt W C hC).pairing + ((explodeAt W C hC).boundaryFlag (stepLabelI W C f₀ h₀)) ≠ + (explodeAt W C hC).boundaryFlag (stepLabelJ W C hC f₀ h₀)) + (g : Fragment.SurvivingFlag (explodeAt W C hC) + (stepLabelI W C f₀ h₀) (stepLabelJ W C hC f₀ h₀)) : + stepFlagEquiv W C hC f₀ h₀ (Fragment.rewire hopen g) = + (explodeAt W (cutErase W C f₀) (cutErase_closed W C hC f₀)).pairing + (stepFlagEquiv W C hC f₀ h₀ g) := by + obtain ⟨gv, hg⟩ := g + rcases gv with f | s + · -- ═══════ An old flag: case-split on the rewire ═══════ + change (stepFlagEquiv W C hC f₀ h₀) + (Fragment.rewire hopen ⟨Sum.inl f, hg⟩) = + ((explodeAt W (cutErase W C f₀) (cutErase_closed W C hC f₀)).relabel + (stepLabelEquiv W C hC f₀ h₀)).pairing + ((stepFlagEquiv W C hC f₀ h₀) ⟨Sum.inl f, hg⟩) + unfold Fragment.rewire + split + · -- first branch: partner = boundary i → f = f₀ + rename_i h + have h' : (if hf : f ∈ C then + (Sum.inr ⟨f, hf⟩ : W.Flag ⊕ {f : W.Flag // f ∈ C}) + else Sum.inl (W.pairing f)) = + Sum.inr ⟨f₀, h₀⟩ := h + by_cases hf : f ∈ C + · rw [dite_eq_left hf] at h' + have feq : f = f₀ := + congrArg Subtype.val (Sum.inr.inj h') + -- LHS: rewire first branch gives ⟨Sum.inl (W.pairing f₀), _⟩; + -- stepFlagEquiv maps this to Sum.inl (W.pairing f₀). + -- RHS: stepFlagEquiv sends ⟨Sum.inl f, _⟩ to Sum.inl f; + -- the smaller explosion's pairing at Sum.inl f, with + -- f ∉ cutErase (since f = f₀), gives Sum.inl (W.pairing f). + -- Both sides = Sum.inl (W.pairing f₀) via feq. + have hne : f ∉ cutErase W C f₀ := by + rw [mem_cutErase, feq]; tauto + -- Expose the dite on the RHS + have hrhs : (if h'' : f ∈ cutErase W C f₀ then + (Sum.inr ⟨f, h''⟩ : + W.Flag ⊕ {g : W.Flag // g ∈ cutErase W C f₀}) + else Sum.inl (W.pairing f)) = + Sum.inl (W.pairing f) := dite_eq_right hne + simp only [feq] + -- LHS: stepFlagEquiv ⟨Sum.inl (W.pairing f₀), _⟩ = Sum.inl + -- (W.pairing f₀) + -- RHS: (relabel ...).pairing (Sum.inl f₀) = dite(f₀ ∈ + -- cutErase...) + -- f₀ ∉ cutErase so dite resolves to Sum.inl (W.pairing f₀) + have hne₀ : f₀ ∉ cutErase W C f₀ := + fun hm => ((mem_cutErase W C f₀).mp hm).2.1 rfl + change (Sum.inl (W.pairing f₀) : + W.Flag ⊕ {g : W.Flag // g ∈ cutErase W C f₀}) = + (if h'' : f₀ ∈ cutErase W C f₀ then + (Sum.inr ⟨f₀, h''⟩ : + W.Flag ⊕ {g : W.Flag // g ∈ cutErase W C f₀}) + else Sum.inl (W.pairing f₀)) + rw [dite_eq_right hne₀] + · rw [dite_eq_right hf] at h' + exact absurd h' Sum.inl_ne_inr + · split + · -- second branch: partner = boundary j → f = W.pairing f₀ + rename_i hni h + have h' : (if hf : f ∈ C then + (Sum.inr ⟨f, hf⟩ : W.Flag ⊕ {f : W.Flag // f ∈ C}) + else Sum.inl (W.pairing f)) = + Sum.inr ⟨W.pairing f₀, hC f₀ h₀⟩ := h + by_cases hf : f ∈ C + · rw [dite_eq_left hf] at h' + have feq : f = W.pairing f₀ := + congrArg Subtype.val (Sum.inr.inj h') + -- Rewire second branch gives ⟨Sum.inl f₀, _⟩; + -- stepFlagEquiv maps to Sum.inl f₀. + -- RHS: stepFlagEquiv sends ⟨Sum.inl f, _⟩ to Sum.inl f = + -- Sum.inl (W.pairing f₀); smaller explosion's pairing + -- at Sum.inl (W.pairing f₀), with W.pairing f₀ ∉ cutErase, + -- gives Sum.inl (W.pairing (W.pairing f₀)) = Sum.inl f₀ + -- by pairing_invol. + simp only [feq] + have hne₁ : W.pairing f₀ ∉ cutErase W C f₀ := + fun hm => ((mem_cutErase W C f₀).mp hm).2.2 rfl + change (Sum.inl f₀ : + W.Flag ⊕ {g : W.Flag // g ∈ cutErase W C f₀}) = + (if h'' : W.pairing f₀ ∈ cutErase W C f₀ then + (Sum.inr ⟨W.pairing f₀, h''⟩ : + W.Flag ⊕ {g : W.Flag // g ∈ cutErase W C f₀}) + else Sum.inl (W.pairing (W.pairing f₀))) + rw [dite_eq_right hne₁, W.pairing_invol] + · rw [dite_eq_right hf] at h' + exact absurd h' Sum.inl_ne_inr + · -- else branch: partner is neither boundary flag + rename_i hni hnj + -- hni/hnj: pairing ≠ boundary i/j. + -- Rewire gives ⟨(explodeAt ...).pairing (Sum.inl f), hni, hnj⟩. + -- Expose the pairing dite. + have hni' : (if hf' : f ∈ C then + (Sum.inr ⟨f, hf'⟩ : W.Flag ⊕ {f : W.Flag // f ∈ C}) + else Sum.inl (W.pairing f)) ≠ + Sum.inr ⟨f₀, h₀⟩ := hni + have hnj' : (if hf' : f ∈ C then + (Sum.inr ⟨f, hf'⟩ : W.Flag ⊕ {f : W.Flag // f ∈ C}) + else Sum.inl (W.pairing f)) ≠ + Sum.inr ⟨W.pairing f₀, hC f₀ h₀⟩ := hnj + by_cases hf : f ∈ C + · -- f ∈ C, f ≠ f₀, f ≠ W.pairing f₀ → f ∈ cutErase + rw [dite_eq_left hf] at hni' hnj' + have hfne₀ : f ≠ f₀ := fun h => + hni' (congrArg Sum.inr (Subtype.ext h)) + have hfne₁ : f ≠ W.pairing f₀ := fun h => + hnj' (congrArg Sum.inr (Subtype.ext h)) + have hmem : f ∈ cutErase W C f₀ := + (mem_cutErase W C f₀).mpr ⟨hf, hfne₀, hfne₁⟩ + -- Both sides reduce to Sum.inr ⟨f, _⟩ + -- Compute LHS pairing via defeq-ascription + have hp₁ : (explodeAt W C hC).pairing (Sum.inl f) = + (Sum.inr ⟨f, hf⟩ : + W.Flag ⊕ {f : W.Flag // f ∈ C}) := by + exact (show (if hf' : f ∈ C then + (Sum.inr ⟨f, hf'⟩ : W.Flag ⊕ {f : W.Flag // f ∈ C}) + else Sum.inl (W.pairing f)) = _ from dite_eq_left hf) + -- Compute RHS pairing via defeq-ascription + have hp₂ : (explodeAt W (cutErase W C f₀) + (cutErase_closed W C hC f₀)).pairing (Sum.inl f) = + (Sum.inr ⟨f, hmem⟩ : + W.Flag ⊕ {g : W.Flag // g ∈ cutErase W C f₀}) := by + exact (show (if hf' : f ∈ cutErase W C f₀ then + (Sum.inr ⟨f, hf'⟩ : + W.Flag ⊕ {g : W.Flag // g ∈ cutErase W C f₀}) + else Sum.inl (W.pairing f)) = _ from + dite_eq_left hmem) + simp only [hp₁] + exact hp₂.symm + · -- f ∉ C → pairing = Sum.inl (W.pairing f) + rw [dite_eq_right hf] at hni' hnj' + have hne : f ∉ cutErase W C f₀ := fun hm => + hf ((mem_cutErase W C f₀).mp hm).1 + -- Compute both pairing values via defeq-ascription trick + have hp₁ : (explodeAt W C hC).pairing (Sum.inl f) = + (Sum.inl (W.pairing f) : + W.Flag ⊕ {f : W.Flag // f ∈ C}) := by + exact (show (if hf' : f ∈ C then + (Sum.inr ⟨f, hf'⟩ : W.Flag ⊕ {f : W.Flag // f ∈ C}) + else Sum.inl (W.pairing f)) = + Sum.inl (W.pairing f) from dite_eq_right hf) + have hp₂ : (explodeAt W (cutErase W C f₀) + (cutErase_closed W C hC f₀)).pairing (Sum.inl f) = + (Sum.inl (W.pairing f) : + W.Flag ⊕ {g : W.Flag // g ∈ cutErase W C f₀}) := by + exact (show (if hf' : f ∈ cutErase W C f₀ then + (Sum.inr ⟨f, hf'⟩ : + W.Flag ⊕ {g : W.Flag // g ∈ cutErase W C f₀}) + else Sum.inl (W.pairing f)) = + Sum.inl (W.pairing f) from dite_eq_right hne) + simp only [hp₁] + exact hp₂.symm + · -- ═══════ A new star flag ═══════ + change (stepFlagEquiv W C hC f₀ h₀) + (Fragment.rewire hopen ⟨Sum.inr s, hg⟩) = + ((explodeAt W (cutErase W C f₀) (cutErase_closed W C hC f₀)).relabel + (stepLabelEquiv W C hC f₀ h₀)).pairing + ((stepFlagEquiv W C hC f₀ h₀) ⟨Sum.inr s, hg⟩) + unfold Fragment.rewire + split + · rename_i h; exact absurd h Sum.inl_ne_inr + · split + · rename_i _ h; exact absurd h Sum.inl_ne_inr + · -- else branch: result is ⟨Sum.inl s.val, ...⟩ + rfl + +/-- **One regluing step**: gluing the two cut ends of the edge of +`f₀` in the explosion at `C` is the explosion at the shrunken cut +set. -/ +noncomputable def explodeAtGluePair (W : ClosedFragment) + (C : Finset W.Flag) (hC : CutClosed W C) (f₀ : W.Flag) + (h₀ : f₀ ∈ C) : + ((explodeAt W C hC).gluePair (stepLabelI W C f₀ h₀) + (stepLabelJ W C hC f₀ h₀) + (stepLabel_ne W C hC f₀ h₀)).Equiv + ((explodeAt W (cutErase W C f₀) + (cutErase_closed W C hC f₀)).relabel + (stepLabelEquiv W C hC f₀ h₀)) := by + -- The glue is open: pairing (boundaryFlag i) = Sum.inl f₀ ≠ Sum.inr ... = + -- boundaryFlag j + have hopen : (explodeAt W C hC).pairing + ((explodeAt W C hC).boundaryFlag (stepLabelI W C f₀ h₀)) ≠ + (explodeAt W C hC).boundaryFlag (stepLabelJ W C hC f₀ h₀) := + Sum.inl_ne_inr + -- Bridge gluePair = gluePairOpen via dif_neg + have heq : (explodeAt W C hC).gluePair (stepLabelI W C f₀ h₀) + (stepLabelJ W C hC f₀ h₀) (stepLabel_ne W C hC f₀ h₀) = + (explodeAt W C hC).gluePairOpen (stepLabelI W C f₀ h₀) + (stepLabelJ W C hC f₀ h₀) (stepLabel_ne W C hC f₀ h₀) hopen := + dite_eq_right hopen + rw [heq] + exact { + flagEquiv := stepFlagEquiv W C hC f₀ h₀ + vertexEquiv := _root_.Equiv.refl W.Vertex + circles_eq := rfl + -- ═══════ ATTACHMENT ═══════ + attach_comm := fun f => by + obtain ⟨fv, hf⟩ := f + rcases fv with g | s + · rfl + · rfl + -- ═══════ PAIRING ═══════ + pairing_comm := by exact explodeAt_rewire_pairing W C hC f₀ h₀ hopen + } + +end GlueStep + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarPrep.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarPrep.lean new file mode 100644 index 0000000000..7a158c7c8a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarPrep.lean @@ -0,0 +1,227 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarEnum +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic + +/-! +# Preparations for the bundle closure + +Three ingredients for identifying the strand-bundle closure with +the straight-matching self-glue: the straight matching is +well-formed and leaves no survivors (generically, for any `m`); +the strand bundle is invariant under transposing its two boundary +blocks; and the interface pairs of a full closure split into the +high-block pairs followed by the low-block pairs. +-/ + +@[expose] public section + +namespace RS + +/-! ### The straight matching, generically -/ + +/-- The straight matching's flags, listed. -/ +theorem matchPairs_flat (m : ℕ) : + (matchPairs m).flatMap (fun p => [p.1, p.2]) = + (List.finRange m).flatMap + (fun j => [Fin.castAdd m j, Fin.natAdd m j]) := by + unfold matchPairs + rw [List.flatMap_map] + +/-- It uses every label: the matching is perfect. -/ +theorem mem_matchPairs_flat (m : ℕ) (z : Fin (m + m)) : + z ∈ (matchPairs m).flatMap (fun p => [p.1, p.2]) := by + rw [matchPairs_flat] + refine List.mem_flatMap.mpr ?_ + by_cases h : z.val < m + · exact ⟨⟨z.val, h⟩, List.mem_finRange _, + List.mem_cons.mpr (Or.inl (Fin.ext rfl))⟩ + · refine ⟨⟨z.val - m, by have := z.isLt; omega⟩, + List.mem_finRange _, List.mem_cons.mpr (Or.inr + (List.mem_cons.mpr (Or.inl (Fin.ext ?_))))⟩ + change z.val = m + (z.val - m) + have := z.isLt + omega + +/-- It is a well-formed gluing list. -/ +theorem matchPairs_wf (m : ℕ) : + Fragment.PairsWF (matchPairs m) := by + change ((matchPairs m).flatMap (fun p => [p.1, p.2])).Nodup + rw [matchPairs_flat] + refine List.nodup_flatMap.mpr ⟨?_, ?_⟩ + · intro j _ + refine List.nodup_cons.mpr ⟨?_, List.nodup_singleton _⟩ + simp only [List.mem_singleton] + intro he + have hv := congrArg Fin.val he + have h1 : (Fin.castAdd m j).val = j.val := rfl + have h2 : (Fin.natAdd m j).val = m + j.val := rfl + rw [h1, h2] at hv + have := j.isLt + omega + · refine List.Nodup.pairwise_of_forall_ne + (List.nodup_finRange m) ?_ + intro a _ b _ hab + have hne : a.val ≠ b.val := fun h => hab (Fin.ext h) + intro z hza hzb + simp only [List.mem_cons, List.not_mem_nil, or_false] at hza hzb + rcases hza with rfl | rfl + · rcases hzb with h | h + · have hv := congrArg Fin.val h + have h1 : (Fin.castAdd m a).val = a.val := rfl + have h2 : (Fin.castAdd m b).val = b.val := rfl + rw [h1, h2] at hv + exact hne hv + · have hv := congrArg Fin.val h + have h1 : (Fin.castAdd m a).val = a.val := rfl + have h2 : (Fin.natAdd m b).val = m + b.val := rfl + rw [h1, h2] at hv + have := a.isLt + omega + · rcases hzb with h | h + · have hv := congrArg Fin.val h + have h1 : (Fin.natAdd m a).val = m + a.val := rfl + have h2 : (Fin.castAdd m b).val = b.val := rfl + rw [h1, h2] at hv + have := b.isLt + omega + · have hv := congrArg Fin.val h + have h1 : (Fin.natAdd m a).val = m + a.val := rfl + have h2 : (Fin.natAdd m b).val = m + b.val := rfl + rw [h1, h2] at hv + omega + +/-- And leaves no survivor, so gluing it closes the fragment. -/ +theorem matchPairs_surv_isEmpty (m : ℕ) : + IsEmpty (Fragment.FoldSurviving (Fin (m + m)) + (matchPairs m)) := by + refine ⟨fun s => ?_⟩ + obtain ⟨z, hprop⟩ := s + exact (forall_ne_iff_not_mem_flat _ _).mp hprop + (mem_matchPairs_flat m z) + +/-! ### Block-swap invariance of the strand bundle -/ + +/-- Transposing the two boundary blocks of the strand bundle +returns the strand bundle: each strand just swaps its two ends. -/ +noncomputable def strandBundleTranspose (m : ℕ) : + ((strandBundle m).relabel (transposeEquiv m m)).Equiv + (strandBundle m) where + flagEquiv := ⟨fun f => (f.1, !f.2), fun f => (f.1, !f.2), + fun f => by obtain ⟨i, b⟩ := f; cases b <;> rfl, + fun f => by obtain ⟨i, b⟩ := f; cases b <;> rfl⟩ + vertexEquiv := _root_.Equiv.refl Empty + attach_comm := fun f => by + obtain ⟨i, b⟩ := f + change (strandBundle m).attach (i, !b) = + (((strandBundle m).attach (i, b)).map id + (transposeEquiv m m)).map (_root_.Equiv.refl Empty) id + cases b + · change (Sum.inr ⟨m + i.val, by omega⟩ : + Empty ⊕ Fin (m + m)) = + Sum.inr (transposeEquiv m m ⟨i.val, by omega⟩) + refine congrArg Sum.inr ?_ + rw [transposeEquiv_low m m i.val i.isLt] + · change (Sum.inr ⟨i.val, by omega⟩ : + Empty ⊕ Fin (m + m)) = + Sum.inr (transposeEquiv m m ⟨m + i.val, by omega⟩) + refine congrArg Sum.inr ?_ + rw [transposeEquiv_high m m i.val i.isLt] + pairing_comm := fun _ => rfl + circles_eq := rfl + +/-! ### The interface split of a full closure -/ + +/-- The high-block interface pairs of a full `(m + m)`-closure. -/ +def highCross (m : ℕ) : + List ((Fin (0 + (m + m)) ⊕ Fin ((m + m) + 0)) × + (Fin (0 + (m + m)) ⊕ Fin ((m + m) + 0))) := + (List.finRange m).reverse.map (fun k => + (Sum.inl ⟨m + k.val, by have := k.isLt; omega⟩, + Sum.inr ⟨m + k.val, by have := k.isLt; omega⟩)) + +/-- The low-block interface pairs of a full `(m + m)`-closure. -/ +def lowCross (m : ℕ) : + List ((Fin (0 + (m + m)) ⊕ Fin ((m + m) + 0)) × + (Fin (0 + (m + m)) ⊕ Fin ((m + m) + 0))) := + (List.finRange m).reverse.map (fun k => + (Sum.inl ⟨k.val, by have := k.isLt; omega⟩, + Sum.inr ⟨k.val, by have := k.isLt; omega⟩)) + +/-- A full closure's interface pairs split into the high block +followed by the low block. -/ +theorem interfacePairs_split (m : ℕ) : + interfacePairs 0 (m + m) 0 = highCross m ++ lowCross m := by + apply List.ext_getElem + · simp [interfacePairs, highCross, lowCross] + intro i hi hi' + have hi2 : i < m + m := by + have h0 : (interfacePairs 0 (m + m) 0).length = m + m := by + simp [interfacePairs] + omega + have hL : (interfacePairs 0 (m + m) 0)[i]'hi = + (Sum.inl ⟨0 + (m + m - 1 - i), by omega⟩, + Sum.inr ⟨m + m - 1 - i, by omega⟩) := by + simp only [interfacePairs, List.getElem_map, + List.getElem_reverse, List.length_finRange, + List.getElem_finRange] + refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) + (congrArg Sum.inr (Fin.ext ?_)) <;> simp + rw [hL] + rcases Nat.lt_or_ge i m with him | him + · have hml : i < (highCross m).length := by + simp only [highCross, List.length_map, List.length_reverse, + List.length_finRange] + omega + rw [List.getElem_append_left hml] + have hR : (highCross m)[i]'hml = + (Sum.inl ⟨m + (m - 1 - i), by omega⟩, + Sum.inr ⟨m + (m - 1 - i), by omega⟩) := by + simp only [highCross, List.getElem_map, + List.getElem_reverse, List.length_finRange, + List.getElem_finRange] + refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) + (congrArg Sum.inr (Fin.ext ?_)) <;> simp + rw [hR] + refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) + (congrArg Sum.inr (Fin.ext ?_)) + · change 0 + (m + m - 1 - i) = m + (m - 1 - i) + omega + · change m + m - 1 - i = m + (m - 1 - i) + omega + · have hml : (highCross m).length ≤ i := by + simp only [highCross, List.length_map, List.length_reverse, + List.length_finRange] + omega + rw [List.getElem_append_right hml] + have hcl : (highCross m).length = m := by + simp only [highCross, List.length_map, List.length_reverse, + List.length_finRange] + have hlow : i - (highCross m).length < + (lowCross m).length := by + simp only [highCross, lowCross, List.length_map, + List.length_reverse, List.length_finRange] + omega + have hR : (lowCross m)[i - (highCross m).length]'hlow = + (Sum.inl ⟨m - 1 - (i - m), by omega⟩, + Sum.inr ⟨m - 1 - (i - m), by omega⟩) := by + simp only [lowCross, List.getElem_map, + List.getElem_reverse, List.length_finRange, + List.getElem_finRange, hcl] + refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) + (congrArg Sum.inr (Fin.ext ?_)) <;> simp + rw [hR] + refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) + (congrArg Sum.inr (Fin.ext ?_)) + · change 0 + (m + m - 1 - i) = m - 1 - (i - m) + omega + · change m + m - 1 - i = m - 1 - (i - m) + omega + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarTrace.lean new file mode 100644 index 0000000000..3d1c2168c9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarTrace.lean @@ -0,0 +1,42 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleClose + +/-! +# The star trace identity + +The accompanying paper's (★): the trace of the star union is the parameter +value of the closed fragment. Closing the star union against the +strand bundle self-glues its straight matching +(`pairCloseStrandBundle`), and regluing the straight matching in +the star union restores the fragment (`starUnion_reglue`). On Hom +classes: the descended trace of the star-union class is the value. +-/ + +@[expose] public section + +namespace RS + +/-- The star union reassembles under the bundle closure. -/ +noncomputable def starUnionPairClose (W : ClosedFragment) : + (pairClose (starUnion W) (strandBundle (edgeCount W))).Equiv + W := by + have E := (starUnion_reglue W).some + refine (pairCloseStrandBundle (edgeCount W) + (starUnion W)).trans ?_ + refine (Fragment.Equiv.relabelCongr + ((Fragment.glueListProofIrrel (starUnion W) + (matchPairs (edgeCount W)) _ (matchPairs_wf_star W)).trans + E) _).trans ?_ + refine (Fragment.Equiv.relabelTrans W _ _).trans ?_ + exact (Fragment.Equiv.relabelEq W + (_root_.Equiv.ext (fun i => i.elim0))).trans + (Fragment.Equiv.relabelRefl W) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StateFlipSet.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StateFlipSet.lean new file mode 100644 index 0000000000..9e2b8eec47 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StateFlipSet.lean @@ -0,0 +1,133 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathNonSep + +/-! +# Set-indexed state relabels + +The odd-partner relabel over a finite set of labels: the ambient +algebra of the accumulated state relabels of the canonical route. +Composition is symmetric difference, so pairing-returning +accumulations cancel by parity. +-/ + +@[expose] public section + +namespace RS + + + +variable {k ℓ : ℕ} {α : Type} + +open Classical in +/-- The odd-partner relabel at every label of a finite set. -/ +noncomputable def stateOddFlipSet (st : GenBoundaryState k ℓ α) + (E : Finset α) : GenBoundaryState k ℓ α := + fun i => if i ∈ E then Sum.map id (oddPartner ℓ) (st i) else st i + +variable {st : GenBoundaryState k ℓ α} + +/-- On the relabel set the state entry is `∂`-flipped. -/ +theorem stateOddFlipSet_of_mem {E : Finset α} {i : α} + (h : i ∈ E) : + stateOddFlipSet st E i = Sum.map id (oddPartner ℓ) (st i) := + ite_eq_left h + +/-- Off it the state is unchanged. -/ +theorem stateOddFlipSet_of_notMem {E : Finset α} {i : α} + (h : i ∉ E) : stateOddFlipSet st E i = st i := + ite_eq_right h + +/-- The empty relabel is the identity. -/ +theorem stateOddFlipSet_empty : + stateOddFlipSet st (∅ : Finset α) = st := by + funext i + exact ite_eq_right (Finset.notMem_empty i) + +open scoped Classical in +/-- The pair relabel is the two-element set relabel. -/ +theorem stateOddFlip_eq_flipSet {i₁ i₂ : α} : + stateOddFlip st i₁ i₂ = stateOddFlipSet st {i₁, i₂} := by + funext i + change (if i = i₁ ∨ i = i₂ then Sum.map id (oddPartner ℓ) (st i) + else st i) = _ + unfold stateOddFlipSet + by_cases h : i = i₁ ∨ i = i₂ + · rw [ite_eq_left h, ite_eq_left (by + rcases h with rfl | rfl + · exact Finset.mem_insert_self _ _ + · exact Finset.mem_insert_of_mem (Finset.mem_singleton_self _))] + · rw [ite_eq_right h, ite_eq_right (by + intro hmem + rcases Finset.mem_insert.mp hmem with rfl | hmem' + · exact h (Or.inl rfl) + · exact h (Or.inr (Finset.mem_singleton.mp hmem')))] + +open scoped Classical in +/-- **Composition is symmetric difference**: two set relabels +compose to the relabel at the symmetric difference — labels hit +twice cancel by the odd-partner involution. -/ +theorem stateOddFlipSet_flipSet (E₁ E₂ : Finset α) : + stateOddFlipSet (stateOddFlipSet st E₁) E₂ = + stateOddFlipSet st ((E₁ \ E₂) ∪ (E₂ \ E₁)) := by + funext i + unfold stateOddFlipSet + by_cases h1 : i ∈ E₁ <;> by_cases h2 : i ∈ E₂ + · rw [ite_eq_left h2, ite_eq_left h1, ite_eq_right (by + intro hmem + rcases Finset.mem_union.mp hmem with h | h + · exact (Finset.mem_sdiff.mp h).2 h2 + · exact (Finset.mem_sdiff.mp h).2 h1)] + rcases hst : st i with a | c + · rfl + · change Sum.inr (oddPartner ℓ (oddPartner ℓ c)) = Sum.inr c + rw [oddPartner_invol] + · rw [ite_eq_right h2, ite_eq_left h1, ite_eq_left + (Finset.mem_union_left _ (Finset.mem_sdiff.mpr ⟨h1, h2⟩))] + · rw [ite_eq_left h2, ite_eq_right h1, ite_eq_left + (Finset.mem_union_right _ (Finset.mem_sdiff.mpr ⟨h2, h1⟩))] + · rw [ite_eq_right h2, ite_eq_right h1, ite_eq_right (by + intro hmem + rcases Finset.mem_union.mp hmem with h | h + · exact h1 (Finset.mem_sdiff.mp h).1 + · exact h2 (Finset.mem_sdiff.mp h).1)] + +/-- The relabel does not change which labels carry odd colours. -/ +theorem stateOddFlipSet_isInr {st : GenBoundaryState k ℓ α} + {E : Finset α} (i : α) : + (∃ c, stateOddFlipSet st E i = Sum.inr c) ↔ + ∃ c, st i = Sum.inr c := by + constructor + · rintro ⟨c, hc⟩ + by_cases h : i ∈ E + · rw [stateOddFlipSet_of_mem h] at hc + rcases hst : st i with a | b + · rw [hst] at hc + simp only [Sum.map_inl] at hc + cases hc + · exact ⟨b, rfl⟩ + · rw [stateOddFlipSet_of_notMem h] at hc + exact ⟨c, hc⟩ + · rintro ⟨c, hc⟩ + by_cases h : i ∈ E + · refine ⟨oddPartner ℓ c, ?_⟩ + rw [stateOddFlipSet_of_mem h, hc] + rfl + · refine ⟨c, ?_⟩ + rw [stateOddFlipSet_of_notMem h] + exact hc + +/-- The boundary-membership constraint survives any set relabel. -/ +theorem genBoundarySubsetMatches_stateOddFlipSet {W : Fragment α} + {s : Finset W.Flag} {st : GenBoundaryState k ℓ α} + (hbnd : genBoundarySubsetMatches W s st) (E : Finset α) : + genBoundarySubsetMatches W s (stateOddFlipSet st E) := + fun i => (hbnd i).trans (stateOddFlipSet_isInr i).symm + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StatusSet.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StatusSet.lean new file mode 100644 index 0000000000..92edcea977 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StatusSet.lean @@ -0,0 +1,137 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepFrame +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LabelChords + +/-! +# The high-status set of a pairing + +The labels whose boundary end is the high end of its chord: the +potential function of the canonical route's state relabels. On +the canonical route the chain direction at every participating end +equals its high-status, so the accumulated relabel set is the +high-status difference of the endpoint pairings — empty exactly +when the pairing returns. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} + +namespace EdgeSubset + +open Classical in +/-- The labels whose participating boundary end is the high end of +its chord. -/ +noncomputable def highSet [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + (κ : F.RelTransitionSystem) : + Finset α := + (F.boundaryFlags.attach.filter (fun b => + W.pairing b.val ∈ F.internalFlags ∧ + F.boundaryLabel (κ.pathMatch_mem b.prop) < + F.boundaryLabel b.prop)).image + (fun b => F.boundaryLabel b.prop) + +/-- Membership in the high-status set: a label that is the high end +of its chord. -/ +theorem mem_highSet [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {i : α} : + i ∈ highSet κ ↔ + ∃ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + W.pairing δ ∈ F.internalFlags ∧ + F.boundaryLabel (κ.pathMatch_mem hδ) < + F.boundaryLabel hδ ∧ + F.boundaryLabel hδ = i := by + unfold highSet + rw [Finset.mem_image] + constructor + · rintro ⟨⟨δ, hδ⟩, hmem, rfl⟩ + obtain ⟨-, hint, hlt⟩ := Finset.mem_filter.mp hmem + exact ⟨δ, hδ, hint, hlt, rfl⟩ + · rintro ⟨δ, hδ, hint, hlt, rfl⟩ + exact ⟨⟨δ, hδ⟩, Finset.mem_filter.mpr + ⟨Finset.mem_attach _ _, hint, hlt⟩, rfl⟩ + +/-- The high-status set only sees the pairing. -/ +theorem highSet_of_samePairing + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ κ' : F.RelTransitionSystem} + (h : SamePairing κ κ') : highSet κ = highSet κ' := by + unfold highSet + refine congrArg _ (Finset.filter_congr ?_) + rintro ⟨δ, hδ⟩ - + rw [boundaryLabel_congr (κ.pathMatch_mem hδ) + (κ'.pathMatch_mem hδ) (h δ hδ)] + +/-- Membership at a given end's label reduces to the label +comparison at that end. -/ +theorem mem_highSet_iff_lt [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + {δ : W.Flag} (hδ : δ ∈ F.boundaryFlags) + (hint : W.pairing δ ∈ F.internalFlags) : + F.boundaryLabel hδ ∈ highSet κ ↔ + F.boundaryLabel (κ.pathMatch_mem hδ) < + F.boundaryLabel hδ := by + rw [mem_highSet] + constructor + · rintro ⟨γ, hγ, hint', hlt, heq⟩ + have hδγ : δ = γ := boundaryLabel_inj hδ hγ heq.symm + subst hδγ + exact hlt + · intro h + exact ⟨δ, hδ, hint, h, rfl⟩ + +/-- **Untouched ends keep their status** across a repair. -/ +theorem mem_highSet_repair_untouched + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) + {e₁ e₂ : W.Flag} (he₁ : e₁ ∈ F.boundaryFlags) + (he₂ : e₂ ∈ F.boundaryFlags) + (hout : ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + δ ≠ e₁ → δ ≠ e₂ → δ ≠ κ.pathMatch e₁ he₁ → + δ ≠ κ.pathMatch e₂ he₂ → + (κ.repair a b c d v hsq).pathMatch δ hδ = + κ.pathMatch δ hδ) + {δ : W.Flag} (hδ : δ ∈ F.boundaryFlags) + (hint : W.pairing δ ∈ F.internalFlags) + (h1 : δ ≠ e₁) (h2 : δ ≠ e₂) (h3 : δ ≠ κ.pathMatch e₁ he₁) + (h4 : δ ≠ κ.pathMatch e₂ he₂) : + (F.boundaryLabel hδ ∈ highSet (κ.repair a b c d v hsq) ↔ + F.boundaryLabel hδ ∈ highSet κ) := by + rw [mem_highSet_iff_lt hδ hint, mem_highSet_iff_lt hδ hint, + boundaryLabel_congr + ((κ.repair a b c d v hsq).pathMatch_mem hδ) + (κ.pathMatch_mem hδ) (hout δ hδ h1 h2 h3 h4)] + +/-- **The re-paired end's status** is the comparison against its +new partner. -/ +theorem mem_highSet_repair_end + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) + {x y : W.Flag} (hx : x ∈ F.boundaryFlags) + (hy : y ∈ F.boundaryFlags) + (hint : W.pairing x ∈ F.internalFlags) + (hnew : (κ.repair a b c d v hsq).pathMatch x hx = y) : + (F.boundaryLabel hx ∈ highSet (κ.repair a b c d v hsq) ↔ + F.boundaryLabel hy < F.boundaryLabel hx) := by + rw [mem_highSet_iff_lt hx hint, + boundaryLabel_congr + ((κ.repair a b c d v hsq).pathMatch_mem hx) hy hnew] + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StepFrame.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepFrame.lean new file mode 100644 index 0000000000..26edb452ba --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepFrame.lean @@ -0,0 +1,563 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonicalFrame +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSwap + +/-! +# The frame across a separated two-path step + +The separated transport keeps `isOut` verbatim, so the chain +direction observable is preserved pointwise; canonicality after +the step is therefore measured by the *new* chords' low ends +against the *old* directions — pure label combinatorics. The new +pairing's rigidity forces the re-paired ends to carry opposite +directions, a constraint on the old frame derived from the new +system. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} + +namespace EdgeSubset + +/-- The separated transport preserves the chain direction at every +flag. -/ +theorem chainDir_transportRepair + {W : Fragment α} {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {a : W.Flag} {b : W.Flag} {c : W.Flag} {d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) + (o : κ.Orientation) (hflip : o.isOut c = !o.isOut a) + (δ : W.Flag) : + chainDir (RelTransitionSystem.Orientation.transportRepair hsq + o hflip) δ = chainDir o δ := rfl + +/-- **The re-paired ends carry opposite directions**: the new +chord's rigidity, read back through the preserved directions, is a +constraint on the old frame. -/ +theorem swap_dirs_opposite + {W : Fragment α} {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {a : W.Flag} {b : W.Flag} {c : W.Flag} {d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) + (o : κ.Orientation) (hflip : o.isOut c = !o.isOut a) + {e₁ e₂ : W.Flag} (he₁ : e₁ ∈ F.boundaryFlags) + (hcross : (κ.repair a b c d v hsq).pathMatch e₁ he₁ = e₂) + (hint : W.pairing e₁ ∈ F.internalFlags) : + chainDir o e₂ = !chainDir o e₁ := by + have h := chainDir_pathMatch + (RelTransitionSystem.Orientation.transportRepair hsq o hflip) + he₁ hint + rw [hcross] at h + rw [chainDir_transportRepair, chainDir_transportRepair] at h + exact h + +/-- Membership in the transported frame's anti-canonical set: +directions are the old ones, labels are the new chords'. -/ +theorem mem_antiLowSet_transport + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) + (o : κ.Orientation) (hflip : o.isOut c = !o.isOut a) + {x : W.Flag} : + x ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq o + hflip) ↔ + ∃ hx : x ∈ F.boundaryFlags, + W.pairing x ∈ F.internalFlags ∧ + F.boundaryLabel hx < + F.boundaryLabel + ((κ.repair a b c d v hsq).pathMatch_mem hx) ∧ + chainDir o x = true := by + rw [mem_antiLowSet] + exact exists_congr fun hx => and_congr_right fun _ => + and_congr_right fun _ => by + rw [chainDir_transportRepair] + +/-- **Untouched chains keep their anti-canonicality** across the +transported step: off the four re-paired ends both the label +comparison and the direction are unchanged. -/ +theorem mem_antiLowSet_transport_untouched + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) + (o : κ.Orientation) (hflip : o.isOut c = !o.isOut a) + {e₁ e₂ : W.Flag} (he₁ : e₁ ∈ F.boundaryFlags) + (he₂ : e₂ ∈ F.boundaryFlags) + (hout : ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + δ ≠ e₁ → δ ≠ e₂ → δ ≠ κ.pathMatch e₁ he₁ → + δ ≠ κ.pathMatch e₂ he₂ → + (κ.repair a b c d v hsq).pathMatch δ hδ = + κ.pathMatch δ hδ) + {x : W.Flag} (hx1 : x ≠ e₁) (hx2 : x ≠ e₂) + (hx3 : x ≠ κ.pathMatch e₁ he₁) (hx4 : x ≠ κ.pathMatch e₂ he₂) : + (x ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq o + hflip) ↔ x ∈ antiLowSet o) := by + rw [mem_antiLowSet_transport hsq o hflip, mem_antiLowSet] + constructor + · rintro ⟨hx, hint, hlt, hdir⟩ + refine ⟨hx, hint, ?_, hdir⟩ + rwa [boundaryLabel_congr + ((κ.repair a b c d v hsq).pathMatch_mem hx) + (κ.pathMatch_mem hx) (hout x hx hx1 hx2 hx3 hx4)] at hlt + · rintro ⟨hx, hint, hlt, hdir⟩ + refine ⟨hx, hint, ?_, hdir⟩ + rwa [boundaryLabel_congr + ((κ.repair a b c d v hsq).pathMatch_mem hx) + (κ.pathMatch_mem hx) (hout x hx hx1 hx2 hx3 hx4)] + +/-- **The canonical direction formula**: on a participating chain a +canonical frame points `true` exactly at the high-labelled end. -/ +theorem chainDir_true_iff_high + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + {o : κ.Orientation} + (hc : PathCanonical o) {x : W.Flag} + (hx : x ∈ F.boundaryFlags) + (hint : W.pairing x ∈ F.internalFlags) : + chainDir o x = true ↔ + F.boundaryLabel (κ.pathMatch_mem hx) < F.boundaryLabel hx := by + have hne : F.boundaryLabel hx ≠ + F.boundaryLabel (κ.pathMatch_mem hx) := fun h => + κ.pathMatch_ne_self hx + (boundaryLabel_inj (κ.pathMatch_mem hx) hx h.symm) + rcases lt_or_gt_of_ne hne with hlt | hgt + · -- x is the low end: direction false + have h0 := (pathCanonical_iff_chainDir o).mp hc x hx hint hlt + constructor + · intro h1 + exact absurd (h0.symm.trans h1) (by decide) + · intro h1 + exact absurd h1 (not_lt_of_gt hlt) + · -- x is the high end: the far end is low, rigidity flips + have hπmem := κ.pathMatch_mem hx + have hπint := pathMatch_pairing_internal (κ := κ) hx hint + have hππ : κ.pathMatch (κ.pathMatch x hx) hπmem = x := + κ.pathMatch_invol hx + have hlow : F.boundaryLabel hπmem < + F.boundaryLabel (κ.pathMatch_mem hπmem) := by + rw [boundaryLabel_congr (κ.pathMatch_mem hπmem) hx hππ] + exact hgt + have h0 := (pathCanonical_iff_chainDir o).mp hc _ hπmem hπint + hlow + have h1 := chainDir_pathMatch o hx hint + rw [h0] at h1 + constructor + · intro _ + exact hgt + · intro _ + have h2 : chainDir o x = true := by + have h3 := congrArg (fun z => !z) h1 + simpa using h3.symm + exact h2 + +/-- **The four-end evaluation**: from a canonical frame, an end of +a re-paired chord is anti-canonical after the transported step +exactly when it is low in its new chord but was high in its old +one. (Instantiate at the four swap ends with the new partners +from `pathMatch_repair_swap`.) -/ +theorem mem_antiLowSet_transport_of_canonical + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) {o : κ.Orientation} + (hflip : o.isOut c = !o.isOut a) (hc : PathCanonical o) + {x y : W.Flag} (hx : x ∈ F.boundaryFlags) + (hy : y ∈ F.boundaryFlags) + (hint : W.pairing x ∈ F.internalFlags) + (hnew : (κ.repair a b c d v hsq).pathMatch x hx = y) : + (x ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq o + hflip) ↔ + (F.boundaryLabel hx < F.boundaryLabel hy ∧ + F.boundaryLabel (κ.pathMatch_mem hx) < + F.boundaryLabel hx)) := by + rw [mem_antiLowSet_transport hsq o hflip] + have hlab : F.boundaryLabel + ((κ.repair a b c d v hsq).pathMatch_mem hx) = + F.boundaryLabel hy := + boundaryLabel_congr _ hy hnew + constructor + · rintro ⟨hx', hint', hlt, hdir⟩ + exact ⟨hlab ▸ hlt, + (chainDir_true_iff_high hc hx hint).mp hdir⟩ + · rintro ⟨hlt, hhigh⟩ + exact ⟨hx, hint, hlab.symm ▸ hlt, + (chainDir_true_iff_high hc hx hint).mpr hhigh⟩ + +/-- **The transported anti-canonical set lives on the four +re-paired ends**: from a canonical source frame, every other chain +stays canonical. -/ +theorem antiLowSet_transport_subset + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) {o : κ.Orientation} + (hflip : o.isOut c = !o.isOut a) (hc : PathCanonical o) + {e₁ e₂ : W.Flag} (he₁ : e₁ ∈ F.boundaryFlags) + (he₂ : e₂ ∈ F.boundaryFlags) + (hout : ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + δ ≠ e₁ → δ ≠ e₂ → δ ≠ κ.pathMatch e₁ he₁ → + δ ≠ κ.pathMatch e₂ he₂ → + (κ.repair a b c d v hsq).pathMatch δ hδ = + κ.pathMatch δ hδ) : + antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq o + hflip) ⊆ + {e₁, e₂, κ.pathMatch e₁ he₁, κ.pathMatch e₂ he₂} := by + intro x hx + by_contra hmem + have h1 : x ≠ e₁ := fun h => hmem (by + rw [h] + exact Finset.mem_insert_self _ _) + have h2 : x ≠ e₂ := fun h => hmem (by + rw [h] + exact Finset.mem_insert_of_mem (Finset.mem_insert_self _ _)) + have h3 : x ≠ κ.pathMatch e₁ he₁ := fun h => hmem (by + rw [h] + exact Finset.mem_insert_of_mem (Finset.mem_insert_of_mem + (Finset.mem_insert_self _ _))) + have h4 : x ≠ κ.pathMatch e₂ he₂ := fun h => hmem (by + rw [h] + exact Finset.mem_insert_of_mem (Finset.mem_insert_of_mem + (Finset.mem_insert_of_mem (Finset.mem_singleton_self _)))) + have hx' := (mem_antiLowSet_transport_untouched hsq o hflip + he₁ he₂ hout h1 h2 h3 h4).mp hx + rw [pathCanonical_iff_antiLowSet_empty] at hc + rw [hc] at hx' + exact Finset.notMem_empty x hx' + +/-- The low end of the `(e₁, e₂)` chord, as a flag. -/ +noncomputable def newLow [LinearOrder α] {W : Fragment α} + (F : EdgeSubset W) {e₁ : W.Flag} + (he₁ : e₁ ∈ F.boundaryFlags) (e₂ : W.Flag) + (he₂ : e₂ ∈ F.boundaryFlags) : W.Flag := + if F.boundaryLabel he₁ < F.boundaryLabel he₂ then e₁ else e₂ + +/-- **The transported anti set, exactly**: the two new chords' +low ends, each present exactly when it was high in its old +chord. -/ +theorem antiLowSet_transport_eq + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) {o : κ.Orientation} + (hflip : o.isOut c = !o.isOut a) (hc : PathCanonical o) + {e₁ e₂ : W.Flag} (he₁ : e₁ ∈ F.boundaryFlags) + (he₂ : e₂ ∈ F.boundaryFlags) + (hne : e₁ ≠ e₂) (hPne : κ.pathMatch e₁ he₁ ≠ e₂) + (hcross : (κ.repair a b c d v hsq).pathMatch e₁ he₁ = e₂) + (hfar : (κ.repair a b c d v hsq).pathMatch + (κ.pathMatch e₁ he₁) (κ.pathMatch_mem he₁) = + κ.pathMatch e₂ he₂) + (hout : ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + δ ≠ e₁ → δ ≠ e₂ → δ ≠ κ.pathMatch e₁ he₁ → + δ ≠ κ.pathMatch e₂ he₂ → + (κ.repair a b c d v hsq).pathMatch δ hδ = + κ.pathMatch δ hδ) + (hint₁ : W.pairing e₁ ∈ F.internalFlags) + (hint₂ : W.pairing e₂ ∈ F.internalFlags) + (hintP₁ : W.pairing (κ.pathMatch e₁ he₁) ∈ F.internalFlags) + (hintP₂ : W.pairing (κ.pathMatch e₂ he₂) ∈ F.internalFlags) : + antiLowSet (RelTransitionSystem.Orientation.transportRepair + hsq o hflip) = + (if (if F.boundaryLabel he₁ < F.boundaryLabel he₂ then + F.boundaryLabel (κ.pathMatch_mem he₁) < + F.boundaryLabel he₁ + else + F.boundaryLabel (κ.pathMatch_mem he₂) < + F.boundaryLabel he₂) then + {newLow F he₁ e₂ he₂} else ∅) ∪ + (if (if F.boundaryLabel (κ.pathMatch_mem he₁) < + F.boundaryLabel (κ.pathMatch_mem he₂) then + F.boundaryLabel he₁ < + F.boundaryLabel (κ.pathMatch_mem he₁) + else + F.boundaryLabel he₂ < + F.boundaryLabel (κ.pathMatch_mem he₂)) then + {newLow F (κ.pathMatch_mem he₁) (κ.pathMatch e₂ he₂) + (κ.pathMatch_mem he₂)} else ∅) := by + have hcross₂ : (κ.repair a b c d v hsq).pathMatch e₂ he₂ = e₁ := + ((κ.repair a b c d v hsq).pathMatch_congr hcross.symm he₂ + ((κ.repair a b c d v hsq).pathMatch_mem he₁)).trans + ((κ.repair a b c d v hsq).pathMatch_invol he₁) + have hfar₂ : (κ.repair a b c d v hsq).pathMatch + (κ.pathMatch e₂ he₂) (κ.pathMatch_mem he₂) = + κ.pathMatch e₁ he₁ := + ((κ.repair a b c d v hsq).pathMatch_congr hfar.symm + (κ.pathMatch_mem he₂) + ((κ.repair a b c d v hsq).pathMatch_mem + (κ.pathMatch_mem he₁))).trans + ((κ.repair a b c d v hsq).pathMatch_invol + (κ.pathMatch_mem he₁)) + have hP₁P₂ : κ.pathMatch e₁ he₁ ≠ κ.pathMatch e₂ he₂ := by + intro h + apply hne + calc e₁ = κ.pathMatch (κ.pathMatch e₁ he₁) + (κ.pathMatch_mem he₁) := (κ.pathMatch_invol he₁).symm + _ = κ.pathMatch (κ.pathMatch e₂ he₂) + (κ.pathMatch_mem he₂) := + κ.pathMatch_congr h (κ.pathMatch_mem he₁) + (κ.pathMatch_mem he₂) + _ = e₂ := κ.pathMatch_invol he₂ + have hL12 : F.boundaryLabel he₁ ≠ F.boundaryLabel he₂ := + fun h => hne (boundaryLabel_inj he₁ he₂ h) + have hLP : F.boundaryLabel (κ.pathMatch_mem he₁) ≠ + F.boundaryLabel (κ.pathMatch_mem he₂) := + fun h => hP₁P₂ (boundaryLabel_inj (κ.pathMatch_mem he₁) + (κ.pathMatch_mem he₂) h) + -- ═══════ THE FOUR RE-PAIRED ENDS ═══════ + -- Above: they are four distinct flags with four distinct labels. + -- Below: which of them the transported frame calls anti-canonical. + have hm₁ := mem_antiLowSet_transport_of_canonical hsq hflip hc + he₁ he₂ hint₁ hcross + have hm₂ := mem_antiLowSet_transport_of_canonical hsq hflip hc + he₂ he₁ hint₂ hcross₂ + have hm₃ := mem_antiLowSet_transport_of_canonical hsq hflip hc + (κ.pathMatch_mem he₁) (κ.pathMatch_mem he₂) hintP₁ hfar + have hm₄ := mem_antiLowSet_transport_of_canonical hsq hflip hc + (κ.pathMatch_mem he₂) (κ.pathMatch_mem he₁) hintP₂ hfar₂ + have hππ₁ : F.boundaryLabel + (κ.pathMatch_mem (κ.pathMatch_mem he₁)) = + F.boundaryLabel he₁ := + boundaryLabel_congr _ he₁ (κ.pathMatch_invol he₁) + have hππ₂ : F.boundaryLabel + (κ.pathMatch_mem (κ.pathMatch_mem he₂)) = + F.boundaryLabel he₂ := + boundaryLabel_congr _ he₂ (κ.pathMatch_invol he₂) + rw [hππ₁] at hm₃ + rw [hππ₂] at hm₄ + apply Finset.ext + -- ═══════ THE TWO SETS AGREE ELEMENTWISE ═══════ + intro x + rw [Finset.mem_union] + constructor + · intro hx + have hx4 := antiLowSet_transport_subset hsq hflip hc he₁ he₂ + hout hx + rcases Finset.mem_insert.mp hx4 with rfl | hx4b + · obtain ⟨hlt, hhigh⟩ := hm₁.mp hx + left + rw [ite_eq_left (by rw [ite_eq_left hlt]; exact hhigh)] + rw [Finset.mem_singleton, newLow, ite_eq_left hlt] + · rcases Finset.mem_insert.mp hx4b with rfl | hx4c + · obtain ⟨hlt, hhigh⟩ := hm₂.mp hx + left + have hnlt : ¬ F.boundaryLabel he₁ < F.boundaryLabel he₂ := + fun h => lt_asymm h hlt + rw [ite_eq_left (by rw [ite_eq_right hnlt]; exact hhigh)] + rw [Finset.mem_singleton, newLow, ite_eq_right hnlt] + · rcases Finset.mem_insert.mp hx4c with rfl | hx4d + · obtain ⟨hlt, hhigh⟩ := hm₃.mp hx + right + rw [ite_eq_left (by rw [ite_eq_left hlt]; exact hhigh)] + rw [Finset.mem_singleton, newLow, ite_eq_left hlt] + · rw [Finset.mem_singleton] at hx4d + subst hx4d + obtain ⟨hlt, hhigh⟩ := hm₄.mp hx + right + have hnlt : ¬ F.boundaryLabel (κ.pathMatch_mem he₁) < + F.boundaryLabel (κ.pathMatch_mem he₂) := + fun h => lt_asymm h hlt + rw [ite_eq_left (by rw [ite_eq_right hnlt]; exact hhigh)] + rw [Finset.mem_singleton, newLow, ite_eq_right hnlt] + · intro hx + rcases hx with hx | hx + · by_cases hcond : (if F.boundaryLabel he₁ < + F.boundaryLabel he₂ then + F.boundaryLabel (κ.pathMatch_mem he₁) < + F.boundaryLabel he₁ + else + F.boundaryLabel (κ.pathMatch_mem he₂) < + F.boundaryLabel he₂) + · rw [ite_eq_left hcond, Finset.mem_singleton] at hx + subst hx + unfold newLow + by_cases hlt : F.boundaryLabel he₁ < F.boundaryLabel he₂ + · rw [ite_eq_left hlt] + rw [ite_eq_left hlt] at hcond + exact hm₁.mpr ⟨hlt, hcond⟩ + · rw [ite_eq_right hlt] + rw [ite_eq_right hlt] at hcond + have hlt2 : F.boundaryLabel he₂ < + F.boundaryLabel he₁ := + lt_of_le_of_ne (not_lt.mp hlt) + (fun h => hL12 h.symm) + exact hm₂.mpr ⟨hlt2, hcond⟩ + · rw [ite_eq_right hcond] at hx + exact absurd hx (Finset.notMem_empty _) + · by_cases hcond : (if F.boundaryLabel + (κ.pathMatch_mem he₁) < + F.boundaryLabel (κ.pathMatch_mem he₂) then + F.boundaryLabel he₁ < + F.boundaryLabel (κ.pathMatch_mem he₁) + else + F.boundaryLabel he₂ < + F.boundaryLabel (κ.pathMatch_mem he₂)) + · rw [ite_eq_left hcond, Finset.mem_singleton] at hx + subst hx + unfold newLow + by_cases hlt : F.boundaryLabel (κ.pathMatch_mem he₁) < + F.boundaryLabel (κ.pathMatch_mem he₂) + · rw [ite_eq_left hlt] + rw [ite_eq_left hlt] at hcond + exact hm₃.mpr ⟨hlt, hcond⟩ + · rw [ite_eq_right hlt] + rw [ite_eq_right hlt] at hcond + have hlt2 : F.boundaryLabel (κ.pathMatch_mem he₂) < + F.boundaryLabel (κ.pathMatch_mem he₁) := + lt_of_le_of_ne (not_lt.mp hlt) + (fun h => hLP h.symm) + exact hm₄.mpr ⟨hlt2, hcond⟩ + · rw [ite_eq_right hcond] at hx + exact absurd hx (Finset.notMem_empty _) + +/-- **The flip count of a separated canonical step**: the four-label +indicator sum — the exact left side of the parity identity. -/ +theorem antiLowSet_transport_card + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) {o : κ.Orientation} + (hflip : o.isOut c = !o.isOut a) (hc : PathCanonical o) + {e₁ e₂ : W.Flag} (he₁ : e₁ ∈ F.boundaryFlags) + (he₂ : e₂ ∈ F.boundaryFlags) + (hne : e₁ ≠ e₂) (hPne : κ.pathMatch e₁ he₁ ≠ e₂) + (hcross : (κ.repair a b c d v hsq).pathMatch e₁ he₁ = e₂) + (hfar : (κ.repair a b c d v hsq).pathMatch + (κ.pathMatch e₁ he₁) (κ.pathMatch_mem he₁) = + κ.pathMatch e₂ he₂) + (hout : ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + δ ≠ e₁ → δ ≠ e₂ → δ ≠ κ.pathMatch e₁ he₁ → + δ ≠ κ.pathMatch e₂ he₂ → + (κ.repair a b c d v hsq).pathMatch δ hδ = + κ.pathMatch δ hδ) + (hint₁ : W.pairing e₁ ∈ F.internalFlags) + (hint₂ : W.pairing e₂ ∈ F.internalFlags) + (hintP₁ : W.pairing (κ.pathMatch e₁ he₁) ∈ F.internalFlags) + (hintP₂ : W.pairing (κ.pathMatch e₂ he₂) ∈ F.internalFlags) : + (antiLowSet (RelTransitionSystem.Orientation.transportRepair + hsq o hflip)).card = + (if (if F.boundaryLabel he₁ < F.boundaryLabel he₂ then + F.boundaryLabel (κ.pathMatch_mem he₁) < + F.boundaryLabel he₁ + else + F.boundaryLabel (κ.pathMatch_mem he₂) < + F.boundaryLabel he₂) then 1 else 0) + + (if (if F.boundaryLabel (κ.pathMatch_mem he₁) < + F.boundaryLabel (κ.pathMatch_mem he₂) then + F.boundaryLabel he₁ < + F.boundaryLabel (κ.pathMatch_mem he₁) + else + F.boundaryLabel he₂ < + F.boundaryLabel (κ.pathMatch_mem he₂)) + then 1 else 0) := by + rw [antiLowSet_transport_eq hsq hflip hc he₁ he₂ hne hPne + hcross hfar hout hint₁ hint₂ hintP₁ hintP₂] + have hdisj : ∀ z₁ z₂ : W.Flag, + (z₁ = e₁ ∨ z₁ = e₂) → + (z₂ = κ.pathMatch e₁ he₁ ∨ z₂ = κ.pathMatch e₂ he₂) → + z₁ ≠ z₂ := by + rintro z₁ z₂ (rfl | rfl) (rfl | rfl) + · exact fun h => κ.pathMatch_ne_self he₁ h.symm + · intro h + apply hPne + exact ((κ.pathMatch_congr h he₁ + (κ.pathMatch_mem he₂)).trans (κ.pathMatch_invol he₂)) + · exact fun h => hPne h.symm + · exact fun h => κ.pathMatch_ne_self he₂ h.symm + have hz : newLow F he₁ e₂ he₂ ≠ + newLow F (κ.pathMatch_mem he₁) (κ.pathMatch e₂ he₂) + (κ.pathMatch_mem he₂) := by + apply hdisj + · unfold newLow + split_ifs + · exact Or.inl rfl + · exact Or.inr rfl + · unfold newLow + split_ifs + · exact Or.inl rfl + · exact Or.inr rfl + split_ifs <;> + first + | (rw [Finset.card_union_of_disjoint (by + rw [Finset.disjoint_singleton] + exact hz)] + rfl) + | (rw [Finset.union_empty] + rfl) + | (rw [Finset.empty_union] + rfl) + +/-- Canonicality and the summand cross a `MatchEq` unchanged (the +unsigned endpoint transfer). -/ +theorem matchEq_canonical_transfer + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} {k : ℕ} {ℓ : ℕ} + (hM : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ₁ κ₂ : F.RelTransitionSystem} (heq : κ₁.MatchEq κ₂) + {o : κ₁.Orientation} (hc : PathCanonical o) : + ∃ o' : κ₂.Orientation, PathCanonical o' ∧ + F.throughSummand hM st hbnd o' κ₂.openCircuitCount = + F.throughSummand hM st hbnd o κ₁.openCircuitCount := by + refine ⟨RelTransitionSystem.Orientation.ofMatchEq heq o, ?_, ?_⟩ + · intro i j hb hint hpm hij + exact hc i j hb hint (by + rw [← pathMatch_matchEq heq (δ := W.boundaryFlag i) hb] + exact hpm) hij + · rw [openCircuitCount_matchEq heq] + exact throughSummand_ofMatchEq hM st hbnd heq o + κ₁.openCircuitCount + +end EdgeSubset + +/-- The paired step without the chord signs: within a block the +pairing returns, so the two path signs agree and cancel. -/ +def PairedLedgerUnsigned : Prop := + ∀ {α : Type} [LinearOrder α] {W : Fragment α} + {F : EdgeSubset W} {k ℓ : ℕ} (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (κ₁ κ₂ : F.RelTransitionSystem), + EdgeSubset.PairedStep κ₁ κ₂ → + ∀ (o₁ : κ₁.Orientation), EdgeSubset.PathCanonical o₁ → + ∃ (o₂ : κ₂.Orientation), EdgeSubset.PathCanonical o₂ ∧ + F.throughSummand hM st hbnd o₂ κ₂.openCircuitCount = + F.throughSummand hM st hbnd o₁ κ₁.openCircuitCount + +namespace EdgeSubset + +/-- The signed and unsigned paired steps coincide. -/ +theorem pairedLedger_iff_unsigned : + EdgeSubset.PairedLedger ↔ PairedLedgerUnsigned := by + constructor + · intro H α _ W F k ℓ hM st hbnd κ₁ κ₂ hps o₁ hc₁ + obtain ⟨o₂, hc₂, hval⟩ := H hM st hbnd κ₁ κ₂ hps o₁ hc₁ + have hpsign : pathSign κ₁ = pathSign κ₂ := + pathSign_of_samePairing hps.2 + have hnz : pathSign κ₂ ≠ 0 := by + unfold pathSign + exact pow_ne_zero _ (by norm_num) + refine ⟨o₂, hc₂, ?_⟩ + rw [hpsign] at hval + exact mul_left_cancel₀ hnz hval + · intro H α _ W F k ℓ hM st hbnd κ₁ κ₂ hps o₁ hc₁ + obtain ⟨o₂, hc₂, hval⟩ := H hM st hbnd κ₁ κ₂ hps o₁ hc₁ + refine ⟨o₂, hc₂, ?_⟩ + rw [hval, pathSign_of_samePairing hps.2] + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StepLedger.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepLedger.lean new file mode 100644 index 0000000000..5de9e8cd2c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepLedger.lean @@ -0,0 +1,731 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingConnectivity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.OrbitParities +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathStep + +/-! +# The pairing-preserving step ledger + +Discharges the single-repair disjunct of `MatchPreservingLedger`: +every pairing-preserving repair step (`MatchPreservingStep`) carries +a path-canonical orientation to a path-canonical orientation on the +repaired side with the same pathSign-weighted canonical summand. + +## Main results + +* `EdgeSubset.squareLocalized_of_pathMatch_eq` — **two-path + exclusion**: a repair square that preserves every path matching is + localized. A non-localized square has its two re-paired edges on + genuinely distinct boundary chains (`twoChains_of_not_localized`); + after the repair, the `a`-flag and the `c`-flag land on the + repaired chains of the two old chains' ends (`hit_membership`, + from the unique square crossing of each chain), and `a`, `c` are + matched by the repaired system, so the two repaired chains share a + flag — contradicting chain disjointness when the pairing is + preserved. +* `EdgeSubset.walkReach_or_walkReach_of_chain` — on one boundary + chain, two coherently oriented internal flags see one another + along the walk (orientation rigidity kills the mixed walk-side / + pairing-side cases; positions order the same-side cases). +* Canonicality transfer: `EdgeSubset.pathCanonical_of_entry_eq` plus + the per-case entry computations — `transportRepair` keeps `isOut` + verbatim; `flipOrbit` is supported on a periodic orbit and entry + flags are non-periodic (`entry_not_periodic`); the reversal + segment of `segFlip` is pairing-closed and internal, so it carries + no entry flag (`entry_notMem_repairSegment`). +* `EdgeSubset.stepLedger_single` — **the single-step ledger**: the + `MatchPreservingStep` disjunct of the per-move interface, fully + discharged from the parity theorems (`separatedCountParity`, + `nonSeparatedSegmentParity`, `nonSeparatedMergeParity`). +* `EdgeSubset.PairedLedger` — the named input: the `PairedStep` + disjunct (two consecutive repairs with net pairing + preservation); a theorem downstream (`pairedLedger`, + `PairedAssembly.lean`). +* `EdgeSubset.matchPreservingLedger_of` — the dispatch: + `MatchPreservingLedger` from `PairedLedger` and the single-step + theorem. + +## Why a pair is one move + +`PairedLedger` carries the content. Each half of a `PairedStep` +may be a two-path repair that changes the boundary pairing, where +the per-repair vertex ledger negates the summand and re-pairs the +boundary colour blocks; across the pair the values net-agree via a +re-pairing (colour-swap) identity for the vertex functional on the +re-routed strand. `TwoPathStep` supplies the count invariance the halves need +(`openCircuitCount_repair_of_not_localized`). A single two-path +repair does not carry the ledger on its own, which is why a pair +is treated as one composite move. +-/ + +@[expose] public section + +namespace RS + + + +namespace EdgeSubset + +variable {α : Type} + +/-! ## Entry flags: non-periodicity and segment avoidance -/ + +section EntryFlags + +/-- The entry edge of a participating boundary flag is not periodic: +it is the step-`0` pairing argument of a boundary-terminated chain. -/ +theorem entry_not_periodic + {W : Fragment α} {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {i : α} + (hb : W.boundaryFlag i ∈ F.boundaryFlags) + (hint : W.pairing (W.boundaryFlag i) ∈ F.internalFlags) : + ¬ κ.PeriodicFlag (W.pairing (W.boundaryFlag i)) := by + intro hper + obtain ⟨k, hkle, hcont, hterm⟩ := chain_terminates_with_data κ hb + have hk : 0 < k := by + rcases Nat.eq_zero_or_pos k with rfl | h + · rw [iterWalk_zero] at hterm + exact absurd hterm + (Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags hint) + · exact h + have h := chain_arg_ne_of_periodic hb hcont hterm hper (s := 0) hk + rw [iterWalk_zero] at h + exact h rfl + +/-- A reversal segment carries no entry flag: the segment is +pairing-closed and internal, while the pairing of an entry flag is a +boundary flag. -/ +theorem entry_notMem_repairSegment + {W : Fragment α} {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {a b c d : W.Flag} + {S : Finset W.Flag} (hseg : RepairSegment κ a b c d S) (i : α) : + W.pairing (W.boundaryFlag i) ∉ S := by + intro hmem + have h2 := hseg.pairing_mem _ hmem + rw [W.pairing_invol] at h2 + exact hseg.notMem_boundaryFlag i h2 + +/-- **Canonicality transfer**: an orientation of a system with the +same path matching, agreeing with a path-canonical orientation on +every entry flag, is path-canonical. -/ +theorem pathCanonical_of_entry_eq + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + {κ' : F.RelTransitionSystem} + {o : κ.Orientation} {o' : κ'.Orientation} + (hpm : ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + κ'.pathMatch δ hδ = κ.pathMatch δ hδ) + (hentry : ∀ i : α, W.boundaryFlag i ∈ F.boundaryFlags → + W.pairing (W.boundaryFlag i) ∈ F.internalFlags → + o'.isOut (W.pairing (W.boundaryFlag i)) = + o.isOut (W.pairing (W.boundaryFlag i))) + (hc : PathCanonical o) : PathCanonical o' := by + intro i j hb hint hpm' hij + rw [hentry i hb hint] + exact hc i j hb hint ((hpm _ hb).symm.trans hpm') hij + +end EntryFlags + +/-! ## Two-path exclusion -/ + +section TwoPathExclusion + +/-- Chain membership from the exit end of a terminating forward +walk. -/ +theorem onBoundaryChain_of_exit + {W : Fragment α} {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {f : W.Flag} + (hf : f ∈ F.internalFlags) {m : ℕ} + (hcont : ∀ j, j < m → + W.pairing (iterWalk κ f j) ∈ F.internalFlags) + (hterm : W.pairing (iterWalk κ f m) ∈ F.boundaryFlags) : + OnBoundaryChain κ (W.pairing (iterWalk κ f m)) f := by + have hcontb : ∀ t, t ≤ m → + W.pairing (iterWalk κ (W.pairing (iterWalk κ f m)) t) ∈ + F.internalFlags := by + intro t ht + rw [iterWalk_reverse κ hcont t ht, W.pairing_invol] + rcases Nat.lt_or_ge t m with h | h + · exact iterWalk_mem_internal κ m (by omega) (by omega) hcont + · rw [show m - t = 0 from by omega, iterWalk_zero] + exact hf + obtain ⟨k', hk'le, hcont', hterm'⟩ := + chain_terminates_with_data κ hterm + have hk'gt : m < k' := by + by_contra hle + exact Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags + (hcontb k' (by omega)) hterm' + have hfeq : + W.pairing (iterWalk κ (W.pairing (iterWalk κ f m)) m) = f := + reverse_chain_terminates κ hcont + exact ⟨k', m, by omega, hcont', hterm', Or.inr hfeq.symm⟩ + +/-- **The tail exit**: after the walk flag following the square hit, +the repaired walk follows the old chain tail and exits at the old +chain's far end, so that walk flag lies on the repaired chain of the +far end. -/ +private theorem tail_exits_repair + {W : Fragment α} {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {a : W.Flag} {b : W.Flag} {c : W.Flag} {d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) + {β : W.Flag} {k s : ℕ} + (hcont : ∀ j, j < k → + W.pairing (iterWalk κ β j) ∈ F.internalFlags) + (hterm : W.pairing (iterWalk κ β k) ∈ F.boundaryFlags) + (hs : s < k) + (hav : ∀ j, s < j → j < k → + W.pairing (iterWalk κ β j) ≠ a ∧ + W.pairing (iterWalk κ β j) ≠ b ∧ + W.pairing (iterWalk κ β j) ≠ c ∧ + W.pairing (iterWalk κ β j) ≠ d) : + OnBoundaryChain (κ.repair a b c d v hsq) + (W.pairing (iterWalk κ β k)) (iterWalk κ β (s + 1)) := by + have hYint : iterWalk κ β (s + 1) ∈ F.internalFlags := + iterWalk_mem_internal κ k (by omega) (by omega) hcont + have hYW : ∀ t, iterWalk κ (iterWalk κ β (s + 1)) t = + iterWalk κ β (s + 1 + t) := + fun t => (iterWalk_add κ β (s + 1) t).symm + have havY : ∀ t, t < k - s - 1 → + W.pairing (iterWalk κ (iterWalk κ β (s + 1)) t) ≠ a ∧ + W.pairing (iterWalk κ (iterWalk κ β (s + 1)) t) ≠ b ∧ + W.pairing (iterWalk κ (iterWalk κ β (s + 1)) t) ≠ c ∧ + W.pairing (iterWalk κ (iterWalk κ β (s + 1)) t) ≠ d := by + intro t ht + rw [hYW] + exact hav (s + 1 + t) (by omega) (by omega) + have hagree := repair_iterWalk_of_avoid hsq (k := k - s - 1) havY + have hcont' : ∀ t, t < k - s - 1 → + W.pairing (iterWalk (κ.repair a b c d v hsq) + (iterWalk κ β (s + 1)) t) ∈ F.internalFlags := by + intro t ht + rw [hagree t (by omega), hYW] + exact hcont (s + 1 + t) (by omega) + have hexit : W.pairing (iterWalk (κ.repair a b c d v hsq) + (iterWalk κ β (s + 1)) (k - s - 1)) = + W.pairing (iterWalk κ β k) := by + rw [hagree (k - s - 1) le_rfl, hYW, + show s + 1 + (k - s - 1) = k from by omega] + have hterm' : W.pairing (iterWalk (κ.repair a b c d v hsq) + (iterWalk κ β (s + 1)) (k - s - 1)) ∈ F.boundaryFlags := by + rw [hexit] + exact hterm + have h := onBoundaryChain_of_exit + (κ := κ.repair a b c d v hsq) hYint hcont' hterm' + rwa [hexit] at h + +/-- **The hit membership**: on a two-chain square, the `X`-flag of +the matched pair carried by `β`'s chain lies, after the repair, on +the repaired chain of `β` or of `β`'s far end. -/ +theorem hit_membership [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) + {β βo X Y Z₁ Z₂ : W.Flag} + (hβ : β ∈ F.boundaryFlags) (hβo : βo ∈ F.boundaryFlags) + (hne1 : β ≠ βo) (hne2 : β ≠ κ.pathMatch βo hβo) + (hXi : X ∈ F.internalFlags) (hXY : κ.match_ X = Y) + (honX : OnBoundaryChain κ β X) + (honZ₁ : OnBoundaryChain κ βo Z₁) + (honZ₂ : OnBoundaryChain κ βo Z₂) + (hperm : ∀ g : W.Flag, + (g = a ∨ g = b ∨ g = c ∨ g = d) ↔ + (g = X ∨ g = Y ∨ g = Z₁ ∨ g = Z₂)) : + OnBoundaryChain (κ.repair a b c d v hsq) β X ∨ + OnBoundaryChain (κ.repair a b c d v hsq) + (κ.pathMatch β hβ) X := by + obtain ⟨k, hkle, hcont, hterm⟩ := chain_terminates_with_data κ hβ + obtain ⟨s, hs, hhit⟩ := square_hit hβ hXi hXY hcont hterm honX + have havoid : ∀ j, j < k → j ≠ s → + W.pairing (iterWalk κ β j) ≠ a ∧ + W.pairing (iterWalk κ β j) ≠ b ∧ + W.pairing (iterWalk κ β j) ≠ c ∧ + W.pairing (iterWalk κ β j) ≠ d := by + intro j hj hjs + have hXne : W.pairing (iterWalk κ β j) ≠ X ∧ + W.pairing (iterWalk κ β j) ≠ Y := by + rcases hhit with ⟨hargX, hwalkY⟩ | ⟨hargY, hwalkX⟩ + · constructor + · intro he + exact hjs (pairing_iterWalk_injective κ hβ k hcont hj hs + (he.trans hargX.symm)) + · intro he + exact pairing_iterWalk_ne κ hcont (le_of_lt hj) + (by omega : s + 1 ≤ k) (he.trans hwalkY.symm) + · constructor + · intro he + exact pairing_iterWalk_ne κ hcont (le_of_lt hj) + (by omega : s + 1 ≤ k) (he.trans hwalkX.symm) + · intro he + exact hjs (pairing_iterWalk_injective κ hβ k hcont hj hs + (he.trans hargY.symm)) + have hZne : W.pairing (iterWalk κ β j) ≠ Z₁ ∧ + W.pairing (iterWalk κ β j) ≠ Z₂ := by + constructor + · intro he + exact onBoundaryChain_disjoint hβo hβ hne1 hne2 honZ₁ + ⟨k, j, le_of_lt hj, hcont, hterm, Or.inr he.symm⟩ + · intro he + exact onBoundaryChain_disjoint hβo hβ hne1 hne2 honZ₂ + ⟨k, j, le_of_lt hj, hcont, hterm, Or.inr he.symm⟩ + have hall : ¬ (W.pairing (iterWalk κ β j) = a ∨ + W.pairing (iterWalk κ β j) = b ∨ + W.pairing (iterWalk κ β j) = c ∨ + W.pairing (iterWalk κ β j) = d) := by + intro hor + rcases (hperm (W.pairing (iterWalk κ β j))).mp hor with + h | h | h | h + · exact hXne.1 h + · exact hXne.2 h + · exact hZne.1 h + · exact hZne.2 h + exact ⟨fun he => hall (Or.inl he), + fun he => hall (Or.inr (Or.inl he)), + fun he => hall (Or.inr (Or.inr (Or.inl he))), + fun he => hall (Or.inr (Or.inr (Or.inr he)))⟩ + rcases hhit with ⟨hargX, _⟩ | ⟨_, hwalkX⟩ + · left + have h := onBoundaryChain_repair_of_hit hsq hβ hcont hs + (fun j hj => havoid j (by omega) (by omega)) + rwa [hargX] at h + · right + have h := tail_exits_repair hsq hcont hterm hs + (fun j hj1 hj2 => havoid j hj2 (by omega)) + rw [hwalkX] at h + rw [pathMatch_eq_of_chain κ hβ hcont hterm] + exact h + +/-- **Two-path exclusion**: a repair square that preserves every +path matching is localized. On a non-localized square the repaired +`a`-flag and its repaired match `c` land on the repaired chains of +two genuinely distinct pairs of ends, which share no flag. -/ +theorem squareLocalized_of_pathMatch_eq + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) + (hpres : ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + (κ.repair a b c d v hsq).pathMatch δ hδ = + κ.pathMatch δ hδ) : + SquareLocalized κ a b c d := by + by_contra hnl + obtain ⟨β₁, β₂, hβ₁, hβ₂, hca, hcc, h21, h2γ⟩ := + twoChains_of_not_localized hsq hnl + have h12 : β₁ ≠ β₂ := Ne.symm h21 + have hγ₁mem : κ.pathMatch β₁ hβ₁ ∈ F.boundaryFlags := + κ.pathMatch_mem hβ₁ + have hγ₂mem : κ.pathMatch β₂ hβ₂ ∈ F.boundaryFlags := + κ.pathMatch_mem hβ₂ + have h1γ2 : β₁ ≠ κ.pathMatch β₂ hβ₂ := by + intro he + apply h2γ + have h3 := κ.pathMatch_congr he hβ₁ hγ₂mem + exact (h3.trans (κ.pathMatch_invol hβ₂)).symm + have hγ2γ1 : κ.pathMatch β₂ hβ₂ ≠ κ.pathMatch β₁ hβ₁ := by + intro he + apply h21 + have h3 := κ.pathMatch_congr he hγ₂mem hγ₁mem + exact ((κ.pathMatch_invol hβ₂).symm.trans h3).trans + (κ.pathMatch_invol hβ₁) + have hγ2β1 : κ.pathMatch β₂ hβ₂ ≠ β₁ := fun he => h1γ2 he.symm + have hcb : OnBoundaryChain κ β₁ b := + hsq.hab ▸ onBoundaryChain_match hβ₁ hsq.ha hca + have hcd : OnBoundaryChain κ β₂ d := + hsq.hcd ▸ onBoundaryChain_match hβ₂ hsq.hc hcc + have hA := hit_membership hsq hβ₁ hβ₂ h12 h1γ2 hsq.ha hsq.hab + hca hcc hcd (fun g => Iff.rfl) + have hC := hit_membership hsq hβ₂ hβ₁ h21 h2γ hsq.hc hsq.hcd + hcc hca hcb (fun g => by tauto) + have honc : ∀ {e : W.Flag}, e ∈ F.boundaryFlags → + OnBoundaryChain (κ.repair a b c d v hsq) e a → + OnBoundaryChain (κ.repair a b c d v hsq) e c := by + intro e he h + have h2 := onBoundaryChain_match + (κ := κ.repair a b c d v hsq) he hsq.ha h + rwa [RelTransitionSystem.repair_match_a hsq] at h2 + have hpm1 : (κ.repair a b c d v hsq).pathMatch β₁ hβ₁ = + κ.pathMatch β₁ hβ₁ := hpres β₁ hβ₁ + have hpmγ1 : (κ.repair a b c d v hsq).pathMatch + (κ.pathMatch β₁ hβ₁) hγ₁mem = β₁ := + (hpres _ hγ₁mem).trans (κ.pathMatch_invol hβ₁) + rcases hA with h₁ | h₁ <;> rcases hC with h₂ | h₂ + · exact onBoundaryChain_disjoint hβ₁ hβ₂ h21 + (by rw [hpm1]; exact h2γ) (honc hβ₁ h₁) h₂ + · exact onBoundaryChain_disjoint hβ₁ hγ₂mem hγ2β1 + (by rw [hpm1]; exact hγ2γ1) (honc hβ₁ h₁) h₂ + · exact onBoundaryChain_disjoint hγ₁mem hβ₂ h2γ + (by rw [hpmγ1]; exact h21) (honc hγ₁mem h₁) h₂ + · exact onBoundaryChain_disjoint hγ₁mem hγ₂mem hγ2γ1 + (by rw [hpmγ1]; exact hγ2β1) (honc hγ₁mem h₁) h₂ + +end TwoPathExclusion + +/-! ## Same-chain reach for coherent orientations -/ + +section SameChainReach + +/-- **Same-chain reach**: two distinct coherently oriented internal +flags on one boundary chain see one another along the walk. +Orientation rigidity (walk-side flags carry the negated seed, +pairing-side flags the seed) excludes the mixed cases; on a common +side the walk runs from the earlier to the later position. -/ +theorem walkReach_or_walkReach_of_chain + {W : Fragment α} {F : EdgeSubset W} {κ : F.RelTransitionSystem} + {β f g : W.Flag} + (hβ : β ∈ F.boundaryFlags) (o : κ.Orientation) + (hsame : o.isOut f = o.isOut g) (hfg : f ≠ g) + (hf : f ∈ F.internalFlags) (hg : g ∈ F.internalFlags) + (honf : OnBoundaryChain κ β f) + (hong : OnBoundaryChain κ β g) : + WalkReach κ f g ∨ WalkReach κ g f := by + obtain ⟨k, hkle, hcont, hterm⟩ := chain_terminates_with_data κ hβ + obtain ⟨kf, t, htk, hcontf, htermf, hft⟩ := honf + obtain ⟨kg, s, hsk, hcontg, htermg, hgs⟩ := hong + have hkf : kf = k := chain_exit_unique hcontf htermf hcont hterm + have hkg : kg = k := chain_exit_unique hcontg htermg hcont hterm + rw [hkf] at htk + rw [hkg] at hsk + have hwalkpos : ∀ {x : W.Flag} {u : ℕ}, x ∈ F.internalFlags → + x = iterWalk κ β u → 1 ≤ u := by + intro x u hx hxe + rcases Nat.eq_zero_or_pos u with rfl | h + · rw [iterWalk_zero] at hxe + rw [hxe] at hx + exact absurd hβ (Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags hx) + · exact h + have hpairpos : ∀ {x : W.Flag} {u : ℕ}, u ≤ k → + x ∈ F.internalFlags → + x = W.pairing (iterWalk κ β u) → u < k := by + intro x u huk hx hxe + rcases Nat.lt_or_ge u k with h | h + · exact h + · obtain rfl : u = k := by omega + rw [hxe] at hx + exact absurd hterm (Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags hx) + have hreach_walk : ∀ {t s : ℕ}, t < s → s ≤ k → + WalkReach κ (iterWalk κ β t) (iterWalk κ β s) := by + intro t s hts hsk' + refine ⟨s - t, by omega, ?_, ?_⟩ + · intro j hj + rw [← iterWalk_add κ β t j] + exact hcont (t + j) (by omega) + · rw [← iterWalk_add κ β t (s - t), + show t + (s - t) = s from by omega] + have hreach_pair : ∀ {t s : ℕ}, s < t → t ≤ k → + WalkReach κ (W.pairing (iterWalk κ β t)) + (W.pairing (iterWalk κ β s)) := by + intro t s hst htk' + have hcont' : ∀ j, j < t → + W.pairing (iterWalk κ β j) ∈ F.internalFlags := + fun j hj => hcont j (by omega) + have hrev : ∀ j, j ≤ t → + iterWalk κ (W.pairing (iterWalk κ β t)) j = + W.pairing (iterWalk κ β (t - j)) := + fun j hj => iterWalk_reverse κ hcont' j hj + refine ⟨t - s, by omega, ?_, ?_⟩ + · intro j hj + rw [hrev j (by omega), W.pairing_invol] + exact iterWalk_mem_internal κ k (by omega) (by omega) hcont + · rw [hrev (t - s) (by omega), + show t - (t - s) = s from by omega] + rcases hft with hfw | hfp <;> rcases hgs with hgw | hgp + · -- both walk-side + rcases Nat.lt_trichotomy t s with h | h | h + · left + rw [hfw, hgw] + exact hreach_walk h hsk + · exact absurd (by rw [hfw, hgw, h]) hfg + · right + rw [hfw, hgw] + exact hreach_walk h htk + · -- f walk-side, g pairing-side: orientation obstruction + exfalso + have ht1 : 1 ≤ t := hwalkpos hf hfw + have hsk2 : s < k := hpairpos hsk hg hgp + have h1 : o.isOut f = !o.isOut (W.pairing β) := by + rw [hfw] + exact isOut_iterWalk_eq_not_seed o hcont t ht1 htk + have h2 : o.isOut g = o.isOut (W.pairing β) := by + rw [hgp] + exact isOut_pairing_iterWalk_eq_seed o hcont s hsk2 + rw [h1, h2] at hsame + exact Bool.not_ne_self _ hsame + · -- f pairing-side, g walk-side: orientation obstruction + exfalso + have hs1 : 1 ≤ s := hwalkpos hg hgw + have htk2 : t < k := hpairpos htk hf hfp + have h1 : o.isOut f = o.isOut (W.pairing β) := by + rw [hfp] + exact isOut_pairing_iterWalk_eq_seed o hcont t htk2 + have h2 : o.isOut g = !o.isOut (W.pairing β) := by + rw [hgw] + exact isOut_iterWalk_eq_not_seed o hcont s hs1 hsk + rw [h1, h2] at hsame + exact Bool.not_ne_self _ hsame.symm + · -- both pairing-side + rcases Nat.lt_trichotomy t s with h | h | h + · right + rw [hfp, hgp] + exact hreach_pair h hsk + · exact absurd (by rw [hfp, hgp, h]) hfg + · left + rw [hfp, hgp] + exact hreach_pair h htk + +end SameChainReach + +/-! ## The single-step ledger -/ + +section StepLedger + +private theorem neg_one_pow_congr_of_even {m n : ℕ} + (h : Even (n + m)) : ((-1 : ℂ)) ^ m = ((-1 : ℂ)) ^ n := by + have h1 : ((-1 : ℂ)) ^ n * ((-1 : ℂ)) ^ m = 1 := by + rw [← pow_add] + exact h.neg_one_pow + have h2 : ((-1 : ℂ)) ^ n * ((-1 : ℂ)) ^ n = 1 := by + rw [← pow_add, ← two_mul, pow_mul, neg_one_sq, one_pow] + calc ((-1 : ℂ)) ^ m + = (((-1 : ℂ)) ^ n * ((-1 : ℂ)) ^ n) * ((-1 : ℂ)) ^ m := by + rw [h2, one_mul] + _ = ((-1 : ℂ)) ^ n * (((-1 : ℂ)) ^ n * ((-1 : ℂ)) ^ m) := by + ring + _ = ((-1 : ℂ)) ^ n := by rw [h1, mul_one] + +/-- Transport of the canonical signed conclusion across the +`MatchEq` slack of the step relation. -/ +private theorem step_conclusion + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} {k : ℕ} {ℓ : ℕ} + (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ₁ κ₂ κ' : F.RelTransitionSystem} + (heq : κ₂.MatchEq κ') (o₁ : κ₁.Orientation) + (o' : κ'.Orientation) (hc' : PathCanonical o') + (hval : pathSign κ' * + F.throughSummand hM st hbnd o' κ'.openCircuitCount = + pathSign κ₁ * + F.throughSummand hM st hbnd o₁ κ₁.openCircuitCount) : + ∃ o₂ : κ₂.Orientation, PathCanonical o₂ ∧ + pathSign κ₂ * + F.throughSummand hM st hbnd o₂ κ₂.openCircuitCount = + pathSign κ₁ * + F.throughSummand hM st hbnd o₁ κ₁.openCircuitCount := by + refine ⟨RelTransitionSystem.Orientation.ofMatchEq + (RelTransitionSystem.MatchEq.symm heq) o', ?_, ?_⟩ + · exact pathCanonical_of_entry_eq + (fun δ hδ => pathMatch_matchEq + (RelTransitionSystem.MatchEq.symm heq) hδ) + (fun _ _ _ => rfl) hc' + · rw [openCircuitCount_matchEq + (RelTransitionSystem.MatchEq.symm heq), + throughSummand_ofMatchEq hM st hbnd + (RelTransitionSystem.MatchEq.symm heq) o', + pathSign_matchEq (RelTransitionSystem.MatchEq.symm heq)] + exact hval + +/-- **The single-step ledger** (the `MatchPreservingStep` disjunct +of `MatchPreservingLedger`, fully discharged): a pairing-preserving +repair step carries a path-canonical orientation to a +path-canonical orientation with the same pathSign-weighted +canonical summand. The square is localized by the two-path +exclusion; the separated case transports the orientation verbatim, +the non-separated case dispatches into the segment-reversal, +swapped-segment, orbit-flip, and swapped-orbit-flip ledgers, whose +count parities are `separatedCountParity`, +`nonSeparatedSegmentParity`, and `nonSeparatedMergeParity`; in +every case the produced orientation agrees with the input on all +entry flags, so canonicality transfers. -/ +theorem stepLedger_single + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} {k : ℕ} {ℓ : ℕ} + (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (κ₁ κ₂ : F.RelTransitionSystem) + (hstep : MatchPreservingStep κ₁ κ₂) + (o₁ : κ₁.Orientation) (hc₁ : PathCanonical o₁) : + ∃ o₂ : κ₂.Orientation, PathCanonical o₂ ∧ + pathSign κ₂ * + F.throughSummand hM st hbnd o₂ κ₂.openCircuitCount = + pathSign κ₁ * + F.throughSummand hM st hbnd o₁ κ₁.openCircuitCount := by + obtain ⟨a, b, c, d, v, hsq, heq, hpres⟩ := hstep + have hloc : SquareLocalized κ₁ a b c d := + squareLocalized_of_pathMatch_eq hsq hpres + -- ═══════ SEPARATED OR NOT ═══════ + -- A separated square transports the orientation verbatim; a + -- non-separated one dispatches on where the walk reaches. + by_cases hflip : o₁.isOut c = !o₁.isOut a + · -- separated localized: transport the orientation verbatim + refine step_conclusion hM st hbnd heq o₁ + (RelTransitionSystem.Orientation.transportRepair hsq o₁ hflip) + (pathCanonical_of_entry_eq hpres (fun _ _ _ => rfl) hc₁) ?_ + rw [pathSign_congr hpres, + throughSummand_repair hM st hbnd hsq o₁ hflip + (separatedCountParity hsq o₁ hflip hloc)] + · have hsame : o₁.isOut c = o₁.isOut a := by + cases h1 : o₁.isOut a <;> cases h2 : o₁.isOut c <;> simp_all + have hpres2 : ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + (κ₁.repair c d a b v hsq.swap).pathMatch δ hδ = + κ₁.pathMatch δ hδ := + fun δ hδ => + (pathMatch_matchEq (repair_swap_matchEq hsq) hδ).symm.trans + (hpres δ hδ) + have heq2 : κ₂.MatchEq (κ₁.repair c d a b v hsq.swap) := + heq.trans + (RelTransitionSystem.MatchEq.symm (repair_swap_matchEq hsq)) + by_cases hr1 : WalkReach κ₁ c a + · -- same-component segment reversal + obtain ⟨S, hseg⟩ := exists_repairSegment hsq o₁ hsame hr1 + refine step_conclusion hM st hbnd heq o₁ + (RelTransitionSystem.Orientation.segFlip hsq o₁ hsame hseg) + (pathCanonical_of_entry_eq hpres + (fun i hb hint => + segFlip_isOut_of_notMem hsq o₁ hsame hseg + (entry_notMem_repairSegment hseg i)) hc₁) ?_ + rw [pathSign_congr hpres, + throughSummand_exp hM st hbnd + (RelTransitionSystem.Orientation.segFlip hsq o₁ hsame + hseg) + ((κ₁.repair a b c d v hsq).openCircuitCount), + throughSummand_exp hM st hbnd o₁ κ₁.openCircuitCount, + throughSummand_segFlip hM st hbnd hsq o₁ hsame hseg 0, + neg_one_pow_congr_of_even + (nonSeparatedSegmentParity hsq hr1)] + · by_cases hr2 : WalkReach κ₁ a c + · -- same component, swapped roles + obtain ⟨S, hseg⟩ := + exists_repairSegment hsq.swap o₁ hsame.symm hr2 + refine step_conclusion hM st hbnd heq2 o₁ + (RelTransitionSystem.Orientation.segFlip hsq.swap o₁ + hsame.symm hseg) + (pathCanonical_of_entry_eq hpres2 + (fun i hb hint => + segFlip_isOut_of_notMem hsq.swap o₁ hsame.symm hseg + (entry_notMem_repairSegment hseg i)) hc₁) ?_ + rw [pathSign_congr hpres2, + throughSummand_exp hM st hbnd + (RelTransitionSystem.Orientation.segFlip hsq.swap o₁ + hsame.symm hseg) + ((κ₁.repair c d a b v hsq.swap).openCircuitCount), + throughSummand_exp hM st hbnd o₁ κ₁.openCircuitCount, + throughSummand_segFlip hM st hbnd hsq.swap o₁ hsame.symm + hseg 0, + neg_one_pow_congr_of_even + (nonSeparatedSegmentParity hsq.swap hr2)] + · by_cases hpc : κ₁.PeriodicFlag c + · -- `c` periodic on a distinct component: orbit flip + have hdisj : ¬ OrbitFlag κ₁ c a := fun horb => + hr1 (walkReach_of_orbitFlag hpc hsame hsq.hac horb) + have hflip2 : (o₁.flipOrbit hpc).isOut c = + !(o₁.flipOrbit hpc).isOut a := by + rw [flipOrbit_isOut_of_mem o₁ hpc (orbitFlag_self κ₁ c), + flipOrbit_isOut_of_notMem o₁ hpc hdisj, hsame] + refine step_conclusion hM st hbnd heq o₁ + (RelTransitionSystem.Orientation.transportRepair hsq + (o₁.flipOrbit hpc) hflip2) + (pathCanonical_of_entry_eq hpres + (fun i hb hint => + flipOrbit_isOut_of_notMem o₁ hpc + (fun horb => entry_not_periodic hb hint + (periodicFlag_of_orbitFlag hpc horb))) hc₁) ?_ + rw [pathSign_congr hpres, + throughSummand_repair hM st hbnd hsq (o₁.flipOrbit hpc) + hflip2 (nonSeparatedMergeParity hsq hpc hdisj), + throughSummand_flipOrbit hM st hbnd o₁ hpc + κ₁.openCircuitCount] + · by_cases hpa : κ₁.PeriodicFlag a + · -- `a` periodic on a distinct component: swapped flip + have hdisj2 : ¬ OrbitFlag κ₁ a c := fun horb => + hr2 (walkReach_of_orbitFlag hpa hsame.symm + (Ne.symm hsq.hac) horb) + have hflip2 : (o₁.flipOrbit hpa).isOut a = + !(o₁.flipOrbit hpa).isOut c := by + rw [flipOrbit_isOut_of_mem o₁ hpa + (orbitFlag_self κ₁ a), + flipOrbit_isOut_of_notMem o₁ hpa hdisj2, hsame] + refine step_conclusion hM st hbnd heq2 o₁ + (RelTransitionSystem.Orientation.transportRepair + hsq.swap (o₁.flipOrbit hpa) hflip2) + (pathCanonical_of_entry_eq hpres2 + (fun i hb hint => + flipOrbit_isOut_of_notMem o₁ hpa + (fun horb => entry_not_periodic hb hint + (periodicFlag_of_orbitFlag hpa horb))) hc₁) ?_ + rw [pathSign_congr hpres2, + throughSummand_repair hM st hbnd hsq.swap + (o₁.flipOrbit hpa) hflip2 + (nonSeparatedMergeParity hsq.swap hpa hdisj2), + throughSummand_flipOrbit hM st hbnd o₁ hpa + κ₁.openCircuitCount] + · -- both non-periodic: the localized square forces a + -- same-chain configuration, hence a reach + exfalso + rcases hloc with ⟨hpa', -⟩ | ⟨β, hβ, hall⟩ + · exact hpa hpa' + · rcases walkReach_or_walkReach_of_chain hβ o₁ hsame + (Ne.symm hsq.hac) hsq.hc hsq.ha + ((hall c (Or.inr (Or.inr (Or.inl rfl)))).resolve_left + hpc) + ((hall a (Or.inl rfl)).resolve_left hpa) + with h | h + · exact hr1 h + · exact hr2 h + +end StepLedger + +/-! ## The paired step and the dispatch -/ + +/-- **The paired two-path move** (a theorem downstream, +`pairedLedger`): a +`PairedStep` — two consecutive repairs `κ₁ → κmid → κ₂` whose net +effect preserves the boundary pairing — carries a path-canonical +orientation to a path-canonical orientation with the same +pathSign-weighted canonical summand. + +The pair is the unit, not the half. In the double-crossing +configuration each half is a two-path repair that *changes* the +pairing, so `stepLedger_single` does not apply to it: the per-half +vertex ledger negates the summand while re-pairing the boundary +colour blocks across the two chains. Across the pair the second +repair undoes the re-routing of the first, the composite walk +change is supported on the two crossing squares, and the two vertex +negations cancel against the net chord-parity change. Proved in +`PairedAssembly.lean`. -/ +def PairedLedger : Prop := + ∀ {α : Type} [LinearOrder α] {W : Fragment α} + {F : EdgeSubset W} {k ℓ : ℕ} (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (κ₁ κ₂ : F.RelTransitionSystem), + PairedStep κ₁ κ₂ → + ∀ (o₁ : κ₁.Orientation), PathCanonical o₁ → + ∃ (o₂ : κ₂.Orientation), PathCanonical o₂ ∧ + pathSign κ₂ * + F.throughSummand hM st hbnd o₂ κ₂.openCircuitCount = + pathSign κ₁ * + F.throughSummand hM st hbnd o₁ κ₁.openCircuitCount + +/-- **The per-move ledger from the paired step**: the +`MatchPreservingStep` disjunct is discharged by +`stepLedger_single`; the `PairedStep` disjunct is the named input. -/ +theorem matchPreservingLedger_of (HPaired : PairedLedger) : + MatchPreservingLedger := by + intro α _ W F k ℓ hM st hbnd κ₁ κ₂ hmove o₁ hc₁ + rcases hmove with hstep | hpair + · exact stepLedger_single hM st hbnd κ₁ κ₂ hstep o₁ hc₁ + · exact HPaired hM st hbnd κ₁ κ₂ hpair o₁ hc₁ + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatus.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatus.lean new file mode 100644 index 0000000000..0001193be0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatus.lean @@ -0,0 +1,455 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerSets + +/-! +# Per-step status identification of the relabel sets + +Two composable identifications for the paired assembly. First, +the pairs of a full pairwise-disjoint `AntiLowPair` list enumerate +the anti-canonical set: membership in the `pairFold` of such a +list is exactly being an end label of some anti-canonical chain +(`mem_pairFold_antiLow`) — the completeness direction pins every +anti flag's label as a first component by comparing cardinalities +(`Finset.eq_of_subset_of_card_le`). Second, for the transported +frame of a separated step from a canonical source, the anti set's +end labels are exactly the labels whose high-status changed across +the repair (`antiLow_labels_eq_statusChange`): an anti end is +low-in-new but high-in-old, and its new partner is high-in-new but +low-in-old (the re-paired ends carry opposite old statuses, +`swap_dirs_opposite`); conversely a status-changed label must sit +on a re-paired end (`mem_highSet_repair_untouched`). +-/ + +@[expose] public section + +namespace RS + + + +/-! ## Propositional inequality helpers -/ + +namespace EdgeSubset + +variable {α : Type} + +/-! ## The enumeration lemma -/ + +section Enumeration + +/-- The anti-canonical set consists of boundary flags. -/ +theorem antiLowSet_subset_boundary + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + (o : κ.Orientation) : + antiLowSet o ⊆ F.boundaryFlags := by + intro β h + obtain ⟨hβ, -⟩ := mem_antiLowSet.mp h + exact hβ + +/-- **Pairs of a full disjoint anti-low list enumerate the anti +set**: for a list of anti-low pairs, pairwise disjoint and as long +as the anti set, membership in the fold is exactly being an end +label of some anti-canonical chain. The completeness direction is +a counting argument: the first components form a `Nodup` list of +labels of anti flags, and label injectivity forces them to exhaust +the anti set. -/ +theorem mem_pairFold_antiLow [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + {o : κ.Orientation} + {L : List (α × α)} + (hall : ∀ p ∈ L, AntiLowPair o p) + (hdisj : L.Pairwise PairDisjoint) + (hlen : L.length = (antiLowSet o).card) {a : α} : + a ∈ pairFold L ↔ + ∃ (β : W.Flag) (hβ : β ∈ F.boundaryFlags), + β ∈ antiLowSet o ∧ + (a = F.boundaryLabel hβ ∨ + a = F.boundaryLabel (κ.pathMatch_mem hβ)) := by + classical + -- the label image of the anti set + have hinj : Set.InjOn + (fun β : {x // x ∈ antiLowSet o} => + F.boundaryLabel (antiLowSet_subset_boundary o β.prop)) + (antiLowSet o).attach := by + intro β _ γ _ hlab + exact Subtype.ext (boundaryLabel_inj _ _ hlab) + have hTcard : + ((antiLowSet o).attach.image (fun β => + F.boundaryLabel + (antiLowSet_subset_boundary o β.prop))).card = + (antiLowSet o).card := + (Finset.card_image_of_injOn hinj).trans Finset.card_attach + have hmemT : ∀ (γ : W.Flag) (hm : γ ∈ antiLowSet o), + F.boundaryLabel (antiLowSet_subset_boundary o hm) ∈ + (antiLowSet o).attach.image (fun β => + F.boundaryLabel + (antiLowSet_subset_boundary o β.prop)) := by + intro γ hm + exact Finset.mem_image.mpr + ⟨⟨γ, hm⟩, Finset.mem_attach _ _, rfl⟩ + -- the first components exhaust the label image + have hnd : (L.map Prod.fst).Nodup := + hdisj.map Prod.fst (fun p q hpq => hpq.1) + have hFscard : (L.map Prod.fst).toFinset.card = L.length := by + rw [List.toFinset_card_of_nodup hnd, List.length_map] + have hFsub : (L.map Prod.fst).toFinset ⊆ + (antiLowSet o).attach.image (fun β => + F.boundaryLabel + (antiLowSet_subset_boundary o β.prop)) := by + intro x hx + rw [List.mem_toFinset] at hx + obtain ⟨p, hp, hpx⟩ := List.mem_map.mp hx + obtain ⟨β, hβ, hm, h1, -⟩ := hall p hp + rw [← hpx, h1] + exact hmemT β hm + have hFeq : (L.map Prod.fst).toFinset = + (antiLowSet o).attach.image (fun β => + F.boundaryLabel + (antiLowSet_subset_boundary o β.prop)) := + Finset.eq_of_subset_of_card_le hFsub + (le_of_eq (by rw [hTcard, hFscard, ← hlen])) + rw [mem_pairFold_of_pairwise hdisj] + -- ═══════ AN ANTI END IS A STATUS CHANGE ═══════ + -- Forward: the four re-paired ends, one case each. Backward: a + -- changed label must sit on one of them. + constructor + · rintro ⟨p, hp, hpa⟩ + obtain ⟨β, hβ, hm, h1, h2⟩ := hall p hp + rcases hpa with rfl | rfl + · exact ⟨β, hβ, hm, Or.inl h1⟩ + · exact ⟨β, hβ, hm, Or.inr h2⟩ + · rintro ⟨β, hβ, hm, hpa⟩ + have hlT : F.boundaryLabel hβ ∈ (L.map Prod.fst).toFinset := by + rw [hFeq] + exact hmemT β hm + rw [List.mem_toFinset] at hlT + obtain ⟨p, hp, hp1⟩ := List.mem_map.mp hlT + obtain ⟨β', hβ', -, h1, h2⟩ := hall p hp + have hββ' : β' = β := + boundaryLabel_inj hβ' hβ (h1.symm.trans hp1) + have hpm2 : p.2 = F.boundaryLabel (κ.pathMatch_mem hβ) := + h2.trans (boundaryLabel_congr (κ.pathMatch_mem hβ') + (κ.pathMatch_mem hβ) (κ.pathMatch_congr hββ' hβ' hβ)) + refine ⟨p, hp, ?_⟩ + rcases hpa with rfl | rfl + · exact Or.inl hp1.symm + · exact Or.inr hpm2.symm + +end Enumeration + +/-! ## The separated-step status identification -/ + +section StepStatus + +/-- **An anti end and its new partner both change status**: from a +canonical source, a flag `x` that is anti-canonical for the +transported frame is high-in-old and low-in-new, while its new +partner `y` is low-in-old (the re-paired ends carry opposite old +directions) and high-in-new. -/ +private theorem status_flip_anti_end + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) {o : κ.Orientation} + (hflip : o.isOut c = !o.isOut a) (hc : PathCanonical o) + {x y : W.Flag} (hx : x ∈ F.boundaryFlags) + (hy : y ∈ F.boundaryFlags) + (hintx : W.pairing x ∈ F.internalFlags) + (hinty : W.pairing y ∈ F.internalFlags) + (hxy : (κ.repair a b c d v hsq).pathMatch x hx = y) + (hanti : x ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq o + hflip)) : + ((F.boundaryLabel hx ∈ highSet (κ.repair a b c d v hsq)) ≠ + (F.boundaryLabel hx ∈ highSet κ)) ∧ + ((F.boundaryLabel hy ∈ highSet (κ.repair a b c d v hsq)) ≠ + (F.boundaryLabel hy ∈ highSet κ)) := by + obtain ⟨hlt, hhigh⟩ := + (mem_antiLowSet_transport_of_canonical hsq hflip hc hx hy + hintx hxy).mp hanti + have hyx : (κ.repair a b c d v hsq).pathMatch y hy = x := + ((κ.repair a b c d v hsq).pathMatch_congr hxy.symm hy + ((κ.repair a b c d v hsq).pathMatch_mem hx)).trans + ((κ.repair a b c d v hsq).pathMatch_invol hx) + have hdx : chainDir o x = true := + (chainDir_true_iff_high hc hx hintx).mpr hhigh + have hdy : chainDir o y = false := by + have h := swap_dirs_opposite hsq o hflip hx hxy hintx + rw [hdx, Bool.not_true] at h + exact h + have hylow : ¬ F.boundaryLabel (κ.pathMatch_mem hy) < + F.boundaryLabel hy := by + intro hlt' + have h := (chainDir_true_iff_high hc hy hinty).mpr hlt' + rw [hdy] at h + exact Bool.false_ne_true h + constructor + · refine prop_ne_of_right ?_ ?_ + · rw [mem_highSet_repair_end hsq hx hy hintx hxy] + exact lt_asymm hlt + · rw [mem_highSet_iff_lt hx hintx] + exact hhigh + · refine prop_ne_of_left ?_ ?_ + · rw [mem_highSet_repair_end hsq hy hx hinty hyx] + exact hlt + · rw [mem_highSet_iff_lt hy hinty] + exact hylow + +/-- The forward case handler: any end label of an anti-canonical +re-paired chord is a status-changed label. -/ +private theorem statusChange_end_fwd + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) {o : κ.Orientation} + (hflip : o.isOut c = !o.isOut a) (hc : PathCanonical o) + {x y : W.Flag} (hx : x ∈ F.boundaryFlags) + (hy : y ∈ F.boundaryFlags) + (hintx : W.pairing x ∈ F.internalFlags) + (hinty : W.pairing y ∈ F.internalFlags) + (hxy : (κ.repair a b c d v hsq).pathMatch x hx = y) + (hanti : x ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq o + hflip)) + {i : α} + (hi : i = F.boundaryLabel hx ∨ + i = F.boundaryLabel + ((κ.repair a b c d v hsq).pathMatch_mem hx)) : + (i ∈ highSet (κ.repair a b c d v hsq)) ≠ (i ∈ highSet κ) := by + obtain ⟨hchx, hchy⟩ := status_flip_anti_end hsq hflip hc hx hy + hintx hinty hxy hanti + rcases hi with rfl | rfl + · exact hchx + · rwa [boundaryLabel_congr + ((κ.repair a b c d v hsq).pathMatch_mem hx) hy hxy] + +/-- The backward case handler: if the status of a re-paired end's +label changed, then either that end is anti-canonical for the +transported frame (it was high, now low) and the label is its own, +or its new partner is (the end was low, now high) and the label is +the partner's partner-label. -/ +private theorem statusChange_end_bwd + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) {o : κ.Orientation} + (hflip : o.isOut c = !o.isOut a) (hc : PathCanonical o) + {x y : W.Flag} (hx : x ∈ F.boundaryFlags) + (hy : y ∈ F.boundaryFlags) + (hintx : W.pairing x ∈ F.internalFlags) + (hinty : W.pairing y ∈ F.internalFlags) + (hxy : (κ.repair a b c d v hsq).pathMatch x hx = y) + (hch : + (F.boundaryLabel hx ∈ highSet (κ.repair a b c d v hsq)) ≠ + (F.boundaryLabel hx ∈ highSet κ)) : + ∃ (β : W.Flag) (hβ : β ∈ F.boundaryFlags), + β ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq o + hflip) ∧ + (F.boundaryLabel hx = F.boundaryLabel hβ ∨ + F.boundaryLabel hx = F.boundaryLabel + ((κ.repair a b c d v hsq).pathMatch_mem hβ)) := by + have hyx : (κ.repair a b c d v hsq).pathMatch y hy = x := + ((κ.repair a b c d v hsq).pathMatch_congr hxy.symm hy + ((κ.repair a b c d v hsq).pathMatch_mem hx)).trans + ((κ.repair a b c d v hsq).pathMatch_invol hx) + have hxney : x ≠ y := fun h => + (κ.repair a b c d v hsq).pathMatch_ne_self hx + (hxy.trans h.symm) + have hlabne : F.boundaryLabel hx ≠ F.boundaryLabel hy := + fun h => hxney (boundaryLabel_inj hx hy h) + rw [mem_highSet_repair_end hsq hx hy hintx hxy, + mem_highSet_iff_lt hx hintx] at hch + rcases prop_ne_cases hch with ⟨hnew, hold⟩ | ⟨hnew, hold⟩ + · -- `x` is high-in-new and was low-in-old: its partner `y` was + -- high-in-old and is low-in-new, so `y` is the anti end. + have hdx : chainDir o x = false := by + cases hd : chainDir o x + · rfl + · exact absurd ((chainDir_true_iff_high hc hx hintx).mp hd) + hold + have hdy := swap_dirs_opposite hsq o hflip hx hxy hintx + rw [hdx, Bool.not_false] at hdy + have hyhigh : F.boundaryLabel (κ.pathMatch_mem hy) < + F.boundaryLabel hy := + (chainDir_true_iff_high hc hy hinty).mp hdy + have hymem : y ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq o + hflip) := + (mem_antiLowSet_transport_of_canonical hsq hflip hc hy hx + hinty hyx).mpr ⟨hnew, hyhigh⟩ + exact ⟨y, hy, hymem, Or.inr + (boundaryLabel_congr + ((κ.repair a b c d v hsq).pathMatch_mem hy) hx + hyx).symm⟩ + · -- `x` was high-in-old and is low-in-new: `x` is the anti end. + have hlt : F.boundaryLabel hx < F.boundaryLabel hy := + lt_of_le_of_ne (not_lt.mp hnew) hlabne + have hxmem : x ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq o + hflip) := + (mem_antiLowSet_transport_of_canonical hsq hflip hc hx hy + hintx hxy).mpr ⟨hlt, hold⟩ + exact ⟨x, hx, hxmem, Or.inl rfl⟩ + +/-- **The separated-step status identification**: for the +transported frame of a separated step from a canonical source, the +end labels of the anti-canonical chords — each anti low end with +its partner in the *repaired* system, the shape produced by +`mem_pairFold_antiLow` at the transported frame — are exactly the +labels whose high-status differs between the repaired and the +source systems. -/ +theorem antiLow_labels_eq_statusChange + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) {o : κ.Orientation} + (hflip : o.isOut c = !o.isOut a) (hc : PathCanonical o) + {e₁ e₂ : W.Flag} (he₁ : e₁ ∈ F.boundaryFlags) + (he₂ : e₂ ∈ F.boundaryFlags) + (hcross : (κ.repair a b c d v hsq).pathMatch e₁ he₁ = e₂) + (hfar : (κ.repair a b c d v hsq).pathMatch + (κ.pathMatch e₁ he₁) (κ.pathMatch_mem he₁) = + κ.pathMatch e₂ he₂) + (hout : ∀ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + δ ≠ e₁ → δ ≠ e₂ → δ ≠ κ.pathMatch e₁ he₁ → + δ ≠ κ.pathMatch e₂ he₂ → + (κ.repair a b c d v hsq).pathMatch δ hδ = + κ.pathMatch δ hδ) + (hint₁ : W.pairing e₁ ∈ F.internalFlags) + (hint₂ : W.pairing e₂ ∈ F.internalFlags) + (hintP₁ : W.pairing (κ.pathMatch e₁ he₁) ∈ F.internalFlags) + (hintP₂ : W.pairing (κ.pathMatch e₂ he₂) ∈ F.internalFlags) + {i : α} : + (∃ (β : W.Flag) (hβ : β ∈ F.boundaryFlags), + β ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq o + hflip) ∧ + (i = F.boundaryLabel hβ ∨ + i = F.boundaryLabel + ((κ.repair a b c d v hsq).pathMatch_mem hβ))) ↔ + ((i ∈ highSet (κ.repair a b c d v hsq)) ≠ + (i ∈ highSet κ)) := by + have hcross₂ : (κ.repair a b c d v hsq).pathMatch e₂ he₂ = e₁ := + ((κ.repair a b c d v hsq).pathMatch_congr hcross.symm he₂ + ((κ.repair a b c d v hsq).pathMatch_mem he₁)).trans + ((κ.repair a b c d v hsq).pathMatch_invol he₁) + have hfar₂ : (κ.repair a b c d v hsq).pathMatch + (κ.pathMatch e₂ he₂) (κ.pathMatch_mem he₂) = + κ.pathMatch e₁ he₁ := + ((κ.repair a b c d v hsq).pathMatch_congr hfar.symm + (κ.pathMatch_mem he₂) + ((κ.repair a b c d v hsq).pathMatch_mem + (κ.pathMatch_mem he₁))).trans + ((κ.repair a b c d v hsq).pathMatch_invol + (κ.pathMatch_mem he₁)) + -- ═══════ AN ANTI END IS A STATUS CHANGE ═══════ + -- Forward: the four re-paired ends, one case each. Backward: a + -- changed label must sit on one of them. + constructor + · rintro ⟨β, hβ, hmem, hlab⟩ + have hfour := antiLowSet_transport_subset hsq hflip hc he₁ + he₂ hout hmem + rcases Finset.mem_insert.mp hfour with h | hfour₁ + · -- `β = e₁`, new partner `e₂` + have hintβ : W.pairing β ∈ F.internalFlags := by + rw [h] + exact hint₁ + have hxy : (κ.repair a b c d v hsq).pathMatch β hβ = e₂ := + ((κ.repair a b c d v hsq).pathMatch_congr h hβ he₁).trans + hcross + exact statusChange_end_fwd hsq hflip hc hβ he₂ hintβ hint₂ + hxy hmem hlab + rcases Finset.mem_insert.mp hfour₁ with h | hfour₂ + · -- `β = e₂`, new partner `e₁` + have hintβ : W.pairing β ∈ F.internalFlags := by + rw [h] + exact hint₂ + have hxy : (κ.repair a b c d v hsq).pathMatch β hβ = e₁ := + ((κ.repair a b c d v hsq).pathMatch_congr h hβ he₂).trans + hcross₂ + exact statusChange_end_fwd hsq hflip hc hβ he₁ hintβ hint₁ + hxy hmem hlab + rcases Finset.mem_insert.mp hfour₂ with h | hfour₃ + · -- `β = κ.pathMatch e₁`, new partner `κ.pathMatch e₂` + have hintβ : W.pairing β ∈ F.internalFlags := by + rw [h] + exact hintP₁ + have hxy : (κ.repair a b c d v hsq).pathMatch β hβ = + κ.pathMatch e₂ he₂ := + ((κ.repair a b c d v hsq).pathMatch_congr h hβ + (κ.pathMatch_mem he₁)).trans hfar + exact statusChange_end_fwd hsq hflip hc hβ + (κ.pathMatch_mem he₂) hintβ hintP₂ hxy hmem hlab + · -- `β = κ.pathMatch e₂`, new partner `κ.pathMatch e₁` + have h := Finset.mem_singleton.mp hfour₃ + have hintβ : W.pairing β ∈ F.internalFlags := by + rw [h] + exact hintP₂ + have hxy : (κ.repair a b c d v hsq).pathMatch β hβ = + κ.pathMatch e₁ he₁ := + ((κ.repair a b c d v hsq).pathMatch_congr h hβ + (κ.pathMatch_mem he₂)).trans hfar₂ + exact statusChange_end_fwd hsq hflip hc hβ + (κ.pathMatch_mem he₁) hintβ hintP₁ hxy hmem hlab + · intro hchanged + -- a status-changed label is the label of a participating flag + have hpart : ∃ (δ : W.Flag) (hδ : δ ∈ F.boundaryFlags), + W.pairing δ ∈ F.internalFlags ∧ + F.boundaryLabel hδ = i := by + rcases prop_ne_cases hchanged with ⟨hnew, -⟩ | ⟨-, hold⟩ + · obtain ⟨δ, hδ, hint, -, hlab⟩ := mem_highSet.mp hnew + exact ⟨δ, hδ, hint, hlab⟩ + · obtain ⟨δ, hδ, hint, -, hlab⟩ := mem_highSet.mp hold + exact ⟨δ, hδ, hint, hlab⟩ + obtain ⟨δ, hδ, hintδ, hlabδ⟩ := hpart + subst hlabδ + by_cases h1 : δ = e₁ + · rw [boundaryLabel_congr hδ he₁ h1] at hchanged ⊢ + exact statusChange_end_bwd hsq hflip hc he₁ he₂ hint₁ hint₂ + hcross hchanged + by_cases h2 : δ = e₂ + · rw [boundaryLabel_congr hδ he₂ h2] at hchanged ⊢ + exact statusChange_end_bwd hsq hflip hc he₂ he₁ hint₂ hint₁ + hcross₂ hchanged + by_cases h3 : δ = κ.pathMatch e₁ he₁ + · rw [boundaryLabel_congr hδ (κ.pathMatch_mem he₁) h3] + at hchanged ⊢ + exact statusChange_end_bwd hsq hflip hc + (κ.pathMatch_mem he₁) (κ.pathMatch_mem he₂) hintP₁ hintP₂ + hfar hchanged + by_cases h4 : δ = κ.pathMatch e₂ he₂ + · rw [boundaryLabel_congr hδ (κ.pathMatch_mem he₂) h4] + at hchanged ⊢ + exact statusChange_end_bwd hsq hflip hc + (κ.pathMatch_mem he₂) (κ.pathMatch_mem he₁) hintP₂ hintP₁ + hfar₂ hchanged + · -- untouched flags keep their status: contradiction + exact absurd (propext (mem_highSet_repair_untouched hsq he₁ + he₂ hout hδ hintδ h1 h2 h3 h4)) hchanged + +end StepStatus + +end EdgeSubset + +/-- Propositional inequality as an exclusive disjunction, in the +`symmU` component order. -/ +theorem prop_ne_iff {P Q : Prop} : + (P ≠ Q) ↔ ((P ∧ ¬Q) ∨ (Q ∧ ¬P)) := by + constructor + · intro h + rcases prop_ne_cases h with ⟨hP, hQ⟩ | ⟨hP, hQ⟩ + · exact Or.inl ⟨hP, hQ⟩ + · exact Or.inr ⟨hQ, hP⟩ + · rintro (⟨hP, hQ⟩ | ⟨hQ, hP⟩) + · exact prop_ne_of_left hP hQ + · exact prop_ne_of_right hP hQ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatusNonsep.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatusNonsep.lean new file mode 100644 index 0000000000..c627a5fa28 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatusNonsep.lean @@ -0,0 +1,418 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatus + +/-! +# The non-separated per-step status identification + +The non-separated counterpart of `antiLow_labels_eq_statusChange`: +for the transported frame of a non-separated step — reached from a +canonical source `o` by first flipping the anchor chain (the +`c`-chain, realized as a `PortedFlipSet`) and then transporting +across the repair — the fold of the anchor pair with a full +disjoint anti-low list is exactly the status-change set +(`nonsep_labels_eq_statusChange`). + +The identification dissolves into a per-chord XOR computation. For +a participating end `x` the chain flip toggles the direction +exactly when `x` is an end of the anchor chord +(`pairing_mem_flipSet_iff`, via chain disjointness), so with +`T := x on the anchor chord`, `old := high-in-κ`, +`new := high-in-κ'`: + +* `x` or its new partner is anti-canonical for the transported + frame iff `new ⊕ (old ⊕ T)` — the new-chord rigidity pairs the + two ends' directions (`anti_ends_iff_toggle_xor_status`); +* the anchor membership contributes `T` once more, and + `T ⊕ (new ⊕ old ⊕ T) = new ⊕ old` is the status change — + the `(2,3)`-chord phenomenon (an anchor end whose status did not + change must be anti: the extra toggle needs undoing) is the case + `T = true`, `new = old` of the same algebra. + +No swap-end data is consumed: the identity holds for the anchored +transported frame of *any* repair from a canonical source. +-/ + +@[expose] public section + +namespace RS + + + +/-! ## Propositional XOR helpers -/ + +/-- XOR of propositions rotates. -/ +private theorem prop_xor_rotate {P Q R : Prop} : + (P ≠ (Q ≠ R)) ↔ (R ≠ (P ≠ Q)) := by + simp only [prop_ne_iff] + tauto + +/-- XOR of propositions cancels a repeated argument. -/ +private theorem prop_xor_cancel {P Q : Prop} : + (P ≠ (P ≠ Q)) ↔ Q := by + simp only [prop_ne_iff] + tauto + +namespace EdgeSubset + +variable {α : Type} + +/-! ## The toggle set of the anchored chain flip -/ + +section ToggleSet + +/-- **The chain flip toggles exactly the anchor chord's ends**: a +ported flip set realized by the boundary chain of `β₂` contains the +entry edge of a participating boundary flag `x` iff `x` is an end +of `β₂`'s chord. The two anchor ends' entry edges lie on the chain +by construction; any other participating end's entry edge is on a +genuinely distinct chain (`onBoundaryChain_disjoint`). -/ +theorem pairing_mem_flipSet_iff + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + {S : Finset W.Flag} {p₁ p₂ : W.Flag} {i₁ i₂ : α} + (_ : PortedFlipSet κ S p₁ p₂ i₁ i₂) + {β₂ : W.Flag} (hβ₂ : β₂ ∈ F.boundaryFlags) + (hint₂ : W.pairing β₂ ∈ F.internalFlags) + (honS : ∀ f ∈ S, OnBoundaryChain κ β₂ f) + (hSon : ∀ f ∈ F.internalFlags, + OnBoundaryChain κ β₂ f → f ∈ S) + {x : W.Flag} (hx : x ∈ F.boundaryFlags) + (hxint : W.pairing x ∈ F.internalFlags) : + W.pairing x ∈ S ↔ (x = β₂ ∨ x = κ.pathMatch β₂ hβ₂) := by + obtain ⟨kc, -, hcont, hterm⟩ := + chain_terminates_with_data κ hβ₂ + have hpm : κ.pathMatch β₂ hβ₂ = + W.pairing (iterWalk κ β₂ kc) := + pathMatch_eq_of_chain κ hβ₂ hcont hterm + constructor + · intro hmem + by_contra hcon + rw [not_or] at hcon + obtain ⟨h1, h2⟩ := hcon + obtain ⟨kx, -, hcontx, htermx⟩ := + chain_terminates_with_data κ hx + exact onBoundaryChain_disjoint hβ₂ hx h1 h2 (honS _ hmem) + ⟨kx, 0, Nat.zero_le kx, hcontx, htermx, + Or.inr (by rw [iterWalk_zero])⟩ + · rintro (rfl | rfl) + · exact hSon _ hint₂ + ⟨kc, 0, Nat.zero_le kc, hcont, hterm, + Or.inr (by rw [iterWalk_zero])⟩ + · apply hSon _ hxint + refine ⟨kc, kc, le_rfl, hcont, hterm, Or.inl ?_⟩ + rw [hpm, W.pairing_invol] + +end ToggleSet + +/-! ## The per-end evaluation of the anchored transported frame -/ + +section StepStatusNonsep + +/-- **The per-chord XOR evaluation**: for a participating boundary +end `x`, some end of `x`'s *new* chord is anti-canonical for the +anchored transported frame iff the direction toggle at `x` (entry +edge in the flip set) differs from the status change of `x`'s +label. From the canonical source the old direction at `x` is its +old high-status; the flip XORs the toggle in; the new-chord +rigidity pairs the two ends' directions, so exactly the low end of +an "old-dir-still-up" chord is anti — the XOR of new-status with +toggled old-status. -/ +private theorem anti_ends_iff_toggle_xor_status + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} + {S : Finset W.Flag} {p₁ p₂ : W.Flag} {i₁ i₂ : α} + (hsq : RepairSquare κ a b c d v) {o : κ.Orientation} + (hc : PathCanonical o) + (hpf : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (hflip : (o.portFlip hpf).isOut c = !(o.portFlip hpf).isOut a) + {x : W.Flag} (hx : x ∈ F.boundaryFlags) + (hxint : W.pairing x ∈ F.internalFlags) : + (x ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip) ∨ + (κ.repair a b c d v hsq).pathMatch x hx ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip)) ↔ + ((W.pairing x ∈ S) ≠ + ((F.boundaryLabel hx ∈ highSet (κ.repair a b c d v hsq)) ≠ + (F.boundaryLabel hx ∈ highSet κ))) := by + -- ═══════ SETUP: THE PARTNER AND THE TWO LABELS ═══════ + have hy : (κ.repair a b c d v hsq).pathMatch x hx ∈ + F.boundaryFlags := (κ.repair a b c d v hsq).pathMatch_mem hx + have hyint : W.pairing + ((κ.repair a b c d v hsq).pathMatch x hx) ∈ + F.internalFlags := + pathMatch_pairing_internal (κ := κ.repair a b c d v hsq) hx + hxint + have hinv : (κ.repair a b c d v hsq).pathMatch + ((κ.repair a b c d v hsq).pathMatch x hx) hy = x := + (κ.repair a b c d v hsq).pathMatch_invol hx + have hlabne : F.boundaryLabel hx ≠ + F.boundaryLabel + ((κ.repair a b c d v hsq).pathMatch_mem hx) := + fun h => (κ.repair a b c d v hsq).pathMatch_ne_self hx + (boundaryLabel_inj + ((κ.repair a b c d v hsq).pathMatch_mem hx) hx h.symm) + -- ═══════ STAGE 1: THE TWO ANTI MEMBERSHIPS ═══════ + -- the two anti memberships, at the preserved directions + have hAX : x ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip) ↔ + (F.boundaryLabel hx < + F.boundaryLabel + ((κ.repair a b c d v hsq).pathMatch_mem hx) ∧ + chainDir (o.portFlip hpf) x = true) := by + rw [mem_antiLowSet_transport hsq (o.portFlip hpf) hflip] + constructor + · rintro ⟨hx', hint', hlt, hdir⟩ + exact ⟨hlt, hdir⟩ + · rintro ⟨hlt, hdir⟩ + exact ⟨hx, hxint, hlt, hdir⟩ + have hAY : (κ.repair a b c d v hsq).pathMatch x hx ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip) ↔ + (F.boundaryLabel + ((κ.repair a b c d v hsq).pathMatch_mem hx) < + F.boundaryLabel hx ∧ + chainDir (o.portFlip hpf) + ((κ.repair a b c d v hsq).pathMatch x hx) = true) := by + rw [mem_antiLowSet_transport hsq (o.portFlip hpf) hflip] + constructor + · rintro ⟨hy', hint', hlt, hdir⟩ + refine ⟨?_, hdir⟩ + have hlt' : F.boundaryLabel hy < + F.boundaryLabel + ((κ.repair a b c d v hsq).pathMatch_mem hy) := hlt + rwa [boundaryLabel_congr + ((κ.repair a b c d v hsq).pathMatch_mem hy) hx hinv] + at hlt' + · rintro ⟨hlt, hdir⟩ + refine ⟨hy, hyint, ?_, hdir⟩ + rwa [boundaryLabel_congr + ((κ.repair a b c d v hsq).pathMatch_mem hy) hx hinv] + -- new-chord rigidity at the preserved directions + have hrig : chainDir (o.portFlip hpf) + ((κ.repair a b c d v hsq).pathMatch x hx) = + !chainDir (o.portFlip hpf) x := by + have h := chainDir_pathMatch + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip) hx hxint + rw [chainDir_transportRepair, chainDir_transportRepair] at h + exact h + -- the canonical direction formula at the source + have hcanx : chainDir o x = true ↔ + F.boundaryLabel (κ.pathMatch_mem hx) < F.boundaryLabel hx := + chainDir_true_iff_high hc hx hxint + -- ═══════ STAGE 2: THE ANTI DISJUNCTION AS `new-high ⊕ flipped-dir` ═══════ + have h1 : (x ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip) ∨ + (κ.repair a b c d v hsq).pathMatch x hx ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip)) ↔ + ((F.boundaryLabel + ((κ.repair a b c d v hsq).pathMatch_mem hx) < + F.boundaryLabel hx) ≠ + (chainDir (o.portFlip hpf) x = true)) := by + rw [hAX, hAY, hrig] + cases hdd : chainDir (o.portFlip hpf) x + · rw [Bool.not_false] + constructor + · rintro (⟨-, hcon⟩ | ⟨hplt, -⟩) + · exact absurd hcon Bool.false_ne_true + · exact prop_ne_of_left hplt Bool.false_ne_true + · intro h + rcases prop_ne_cases h with ⟨hplt, -⟩ | ⟨-, hcon⟩ + · exact Or.inr ⟨hplt, rfl⟩ + · exact absurd hcon Bool.false_ne_true + · rw [Bool.not_true] + constructor + · rintro (⟨hnlt, -⟩ | ⟨-, hcon⟩) + · exact prop_ne_of_right + (fun hplt => lt_asymm hnlt hplt) rfl + · exact absurd hcon Bool.false_ne_true + · intro h + rcases prop_ne_cases h with ⟨-, hcon⟩ | ⟨hnplt, -⟩ + · exact absurd rfl hcon + · exact Or.inl + ⟨(lt_or_gt_of_ne hlabne).resolve_right hnplt, rfl⟩ + -- ═══════ STAGE 3: THE FLIPPED DIRECTION AS `old-high ⊕ toggle` ═══════ + have h2 : (chainDir (o.portFlip hpf) x = true) ↔ + ((F.boundaryLabel (κ.pathMatch_mem hx) < + F.boundaryLabel hx) ≠ (W.pairing x ∈ S)) := by + by_cases hTx : W.pairing x ∈ S + · rw [chainDir_portFlip_of_mem o hpf hTx] + cases hdc : chainDir o x + · rw [Bool.not_false] + have hnolt : ¬ (F.boundaryLabel (κ.pathMatch_mem hx) < + F.boundaryLabel hx) := fun h => + Bool.false_ne_true (((hcanx.mpr h).symm.trans hdc).symm) + exact iff_of_true rfl (prop_ne_of_right hnolt hTx) + · rw [Bool.not_true] + have holt := hcanx.mp hdc + refine iff_of_false Bool.false_ne_true ?_ + intro h + rcases prop_ne_cases h with ⟨-, hnT⟩ | ⟨hnolt, -⟩ + · exact hnT hTx + · exact hnolt holt + · rw [chainDir_portFlip_of_notMem o hpf hTx] + constructor + · intro hd + exact prop_ne_of_left (hcanx.mp hd) hTx + · intro h + rcases prop_ne_cases h with ⟨holt, -⟩ | ⟨-, hT⟩ + · exact hcanx.mpr holt + · exact absurd hT hTx + -- ═══════ ASSEMBLY: ROTATE THE THREE-WAY XOR ═══════ + rw [h1, h2, + mem_highSet_iff_lt (κ := κ.repair a b c d v hsq) hx hxint, + mem_highSet_iff_lt (κ := κ) hx hxint] + exact prop_xor_rotate + +/-- **The non-separated per-step status identification**: for the +anchored transported frame of a non-separated step from a canonical +source — flip the anchor chain of `β₂` (the `c`-chain, realized as +the ported flip set `S` with the chord's two end labels `iβ`, `iγ`), +then transport across the repair — the fold of the anchor pair +`(iβ, iγ)` with a full pairwise-disjoint anti-low list of the +transported frame is exactly the set of labels whose high-status +differs between the repaired and the source systems. The anchor +pair is `β₂`'s chord in the *source* system; the list pairs are +anti-low chords of the *repaired* system at the transported +frame. -/ +theorem nonsep_labels_eq_statusChange + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} + {S : Finset W.Flag} {p₁ p₂ : W.Flag} {iβ iγ : α} + (hsq : RepairSquare κ a b c d v) {o : κ.Orientation} + (hc : PathCanonical o) + (hpf : PortedFlipSet κ S p₁ p₂ iβ iγ) + (hflip : (o.portFlip hpf).isOut c = !(o.portFlip hpf).isOut a) + {β₂ : W.Flag} (hβ₂ : β₂ ∈ F.boundaryFlags) + (hint₂ : W.pairing β₂ ∈ F.internalFlags) + (honS : ∀ f ∈ S, OnBoundaryChain κ β₂ f) + (hSon : ∀ f ∈ F.internalFlags, + OnBoundaryChain κ β₂ f → f ∈ S) + (hlabβ : F.boundaryLabel hβ₂ = iβ) + (hlabγ : F.boundaryLabel (κ.pathMatch_mem hβ₂) = iγ) + {L : List (α × α)} + (hall : ∀ p ∈ L, AntiLowPair + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip) p) + (hdisj : L.Pairwise PairDisjoint) + (hlen : L.length = (antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip)).card) + {i : α} : + (i ∈ pairFold ((iβ, iγ) :: L)) ↔ + ((i ∈ highSet (κ.repair a b c d v hsq)) ≠ + (i ∈ highSet κ)) := by + have hps : i ∈ pairSet (iβ, iγ) ↔ (i = iβ ∨ i = iγ) := + mem_pairSet + rw [pairFold_cons, mem_symmU, hps, + mem_pairFold_antiLow hall hdisj hlen] + -- ═══════ IS THE LABEL A PARTICIPATING END? ═══════ + -- If it is, the anchor toggle and the chord rigidity combine by + -- a three-term XOR; if not, both sides are false. + by_cases hpart : ∃ (x : W.Flag) (hx : x ∈ F.boundaryFlags), + W.pairing x ∈ F.internalFlags ∧ F.boundaryLabel hx = i + · -- the label of a participating end: the XOR algebra + obtain ⟨x, hx, hxint, hlabx⟩ := hpart + subst hlabx + have hE1 : (F.boundaryLabel hx = iβ ∨ + F.boundaryLabel hx = iγ) ↔ W.pairing x ∈ S := by + rw [pairing_mem_flipSet_iff hpf hβ₂ hint₂ honS hSon hx + hxint] + constructor + · rintro (h | h) + · exact Or.inl (boundaryLabel_inj hx hβ₂ + (h.trans hlabβ.symm)) + · exact Or.inr (boundaryLabel_inj hx + (κ.pathMatch_mem hβ₂) (h.trans hlabγ.symm)) + · rintro (h | h) + · exact Or.inl ((boundaryLabel_congr hx hβ₂ h).trans + hlabβ) + · exact Or.inr ((boundaryLabel_congr hx + (κ.pathMatch_mem hβ₂) h).trans hlabγ) + have hF : (∃ (β : W.Flag) (hβ : β ∈ F.boundaryFlags), + β ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip) ∧ + (F.boundaryLabel hx = F.boundaryLabel hβ ∨ + F.boundaryLabel hx = F.boundaryLabel + ((κ.repair a b c d v hsq).pathMatch_mem hβ))) ↔ + (x ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip) ∨ + (κ.repair a b c d v hsq).pathMatch x hx ∈ antiLowSet + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip hpf) hflip)) := by + constructor + · rintro ⟨β, hβ, hmem, hlab | hlab⟩ + · refine Or.inl ?_ + rw [boundaryLabel_inj hx hβ hlab] + exact hmem + · refine Or.inr ?_ + have hxβ : x = + (κ.repair a b c d v hsq).pathMatch β hβ := + boundaryLabel_inj hx + ((κ.repair a b c d v hsq).pathMatch_mem hβ) hlab + have hpmx : (κ.repair a b c d v hsq).pathMatch x hx = + β := + ((κ.repair a b c d v hsq).pathMatch_congr hxβ hx + ((κ.repair a b c d v hsq).pathMatch_mem hβ)).trans + ((κ.repair a b c d v hsq).pathMatch_invol hβ) + rw [hpmx] + exact hmem + · rintro (hmem | hmem) + · exact ⟨x, hx, hmem, Or.inl rfl⟩ + · exact ⟨(κ.repair a b c d v hsq).pathMatch x hx, + (κ.repair a b c d v hsq).pathMatch_mem hx, hmem, + Or.inr (boundaryLabel_congr hx + ((κ.repair a b c d v hsq).pathMatch_mem + ((κ.repair a b c d v hsq).pathMatch_mem hx)) + ((κ.repair a b c d v hsq).pathMatch_invol + hx).symm)⟩ + have hFC := hF.trans + (anti_ends_iff_toggle_xor_status hsq hc hpf hflip hx hxint) + rw [hFC, hE1, ← prop_ne_iff] + exact prop_xor_cancel + · -- a non-participating label: both sides are false + constructor + · rintro (⟨hor, -⟩ | ⟨⟨β, hβ, hmem, hlab⟩, -⟩) + · exfalso + rcases hor with rfl | rfl + · exact hpart ⟨β₂, hβ₂, hint₂, hlabβ⟩ + · exact hpart ⟨κ.pathMatch β₂ hβ₂, κ.pathMatch_mem hβ₂, + pathMatch_pairing_internal (κ := κ) hβ₂ hint₂, + hlabγ⟩ + · exfalso + obtain ⟨hβ', hintβ, -, -⟩ := mem_antiLowSet.mp hmem + rcases hlab with rfl | rfl + · exact hpart ⟨β, hβ, hintβ, rfl⟩ + · exact hpart ⟨(κ.repair a b c d v hsq).pathMatch β hβ, + (κ.repair a b c d v hsq).pathMatch_mem hβ, + pathMatch_pairing_internal + (κ := κ.repair a b c d v hsq) hβ hintβ, rfl⟩ + · intro hch + exfalso + rcases prop_ne_cases hch with ⟨hnew, -⟩ | ⟨-, hold⟩ + · obtain ⟨δ, hδ, hint, -, hlabδ⟩ := mem_highSet.mp hnew + exact hpart ⟨δ, hδ, hint, hlabδ⟩ + · obtain ⟨δ, hδ, hint, -, hlabδ⟩ := mem_highSet.mp hold + exact hpart ⟨δ, hδ, hint, hlabδ⟩ + +end StepStatusNonsep + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StrandBundle.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StrandBundle.lean new file mode 100644 index 0000000000..52e07ddbb0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StrandBundle.lean @@ -0,0 +1,76 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FragmentEquiv + +/-! +# Strand bundles + +The identity fragments of the skein category: `strandBundle t` is +the disjoint union of `t` parallel strands, with strand `k` joining +boundary label `k` to boundary label `t + k`. Flags are pairs +`(k, b)` with `b = false` at the incoming end (label `k`) and +`b = true` at the outgoing end (label `t + k`). +-/ + +@[expose] public section + +namespace RS + +/-- The bundle of `t` parallel strands: strand `k` joins label `k` +to label `t + k`. -/ +def strandBundle (t : ℕ) : Fragment (Fin (t + t)) where + Flag := Fin t × Bool + Vertex := Empty + attach := fun f => + Sum.inr (if f.2 then ⟨t + f.1.val, by omega⟩ else ⟨f.1.val, by omega⟩) + pairing := fun f => (f.1, !f.2) + pairing_invol := fun f => by simp + pairing_ne := fun f h => by + have hsnd := congrArg Prod.snd h + simp at hsnd + boundaryFlag := fun ℓ => + if h : ℓ.val < t then (⟨ℓ.val, h⟩, false) + else (⟨ℓ.val - t, by omega⟩, true) + attach_boundaryFlag := fun ℓ => by + by_cases h : ℓ.val < t + · rw [dite_eq_left h] + exact congrArg Sum.inr (Fin.ext rfl) + · rw [dite_eq_right h] + refine congrArg Sum.inr (Fin.ext ?_) + change t + (ℓ.val - t) = ℓ.val + omega + eq_boundaryFlag := fun ℓ f h => by + obtain ⟨a, b⟩ := f + have hℓ := (Sum.inr.inj h).symm + cases b + · simp only [Bool.false_eq_true, ite_false] at hℓ + subst hℓ + rw [dite_eq_left a.isLt] + · simp only [ite_true] at hℓ + subst hℓ + rw [dite_eq_right (show ¬ t + a.val < t by omega)] + refine Prod.ext_iff.mpr ⟨Fin.ext ?_, rfl⟩ + change a.val = t + a.val - t + omega + circles := 0 + +/-- The boundary flag of an incoming label. -/ +theorem strandBundle_boundaryFlag_low (t : ℕ) (ℓ : Fin (t + t)) + (h : ℓ.val < t) : + (strandBundle t).boundaryFlag ℓ = (⟨ℓ.val, h⟩, false) := by + simp only [strandBundle, dite_eq_left h] + +/-- The boundary flag of an outgoing label. -/ +theorem strandBundle_boundaryFlag_high (t : ℕ) (ℓ : Fin (t + t)) + (h : ¬ ℓ.val < t) : + (strandBundle t).boundaryFlag ℓ = + (⟨ℓ.val - t, by omega⟩, true) := by + simp only [strandBundle, dite_eq_right h] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SumLexOrder.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SumLexOrder.lean new file mode 100644 index 0000000000..5650bbb06e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SumLexOrder.lean @@ -0,0 +1,73 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplit + +/-! +# The lexicographic order on disjoint-union labels + +Plain `α ⊕ β` carries no linear order in mathlib (only the `⊕ₗ` +synonym does); the corrected constrained value of a `disjUnion` +needs one for its through-product orientation. This file +transports the lexicographic order to the plain sum (left before +right) and pins the disjoint-union factorization interface — the +multiplicativity of the corrected value, first target of the +factorization chain. +-/ + +@[expose] public section + +namespace RS + +-- Deliberately semireducible: supplied explicitly via `letI` in +-- the gluing chain, never by instance search. +/-- The lexicographic linear order on a plain sum type: left +before right. -/ +@[instance_reducible] +def sumLexLinearOrder (α β : Type) [LinearOrder α] + [LinearOrder β] : LinearOrder (α ⊕ β) := + LinearOrder.lift' (toLex : α ⊕ β → α ⊕ₗ β) (fun _ _ h => h) + +section Lemmas + +variable {α β : Type} + +/-- Within the left block the order is the left order. -/ +theorem sumLex_inl_lt_inl_iff [LinearOrder α] [LinearOrder β] + {a a' : α} : + (sumLexLinearOrder α β).lt (Sum.inl a) (Sum.inl a') ↔ + a < a' := by + change toLex (Sum.inl a) < toLex (Sum.inl a') ↔ _ + exact Sum.Lex.inl_lt_inl_iff + +/-- Within the right block, the right order. -/ +theorem sumLex_inr_lt_inr_iff [LinearOrder α] [LinearOrder β] + {b b' : β} : + (sumLexLinearOrder α β).lt (Sum.inr b) (Sum.inr b') ↔ + b < b' := by + change toLex (Sum.inr b) < toLex (Sum.inr b') ↔ _ + exact Sum.Lex.inr_lt_inr_iff + +/-- Every left label precedes every right one. -/ +theorem sumLex_inl_lt_inr [LinearOrder α] [LinearOrder β] + (a : α) (b : β) : + (sumLexLinearOrder α β).lt (Sum.inl a) (Sum.inr b) := by + change toLex (Sum.inl a) < toLex (Sum.inr b) + exact Sum.Lex.inl_lt_inr a b + +/-- And no right label precedes a left one. -/ +theorem sumLex_not_inr_lt_inl [LinearOrder α] [LinearOrder β] + (a : α) (b : β) : + ¬ (sumLexLinearOrder α β).lt (Sum.inr b) (Sum.inl a) := by + change ¬ toLex (Sum.inr b) < toLex (Sum.inl a) + exact fun h => absurd (lt_trans (Sum.Lex.inl_lt_inr a b) h) + (lt_irrefl _) + +end Lemmas + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperGram.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperGram.lean new file mode 100644 index 0000000000..7dfd4496ff --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperGram.lean @@ -0,0 +1,587 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GramRank +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperSpace + +/-! +# The super form on boundary states, and the rank it bounds + +A boundary state at arity `t` is a coordinate of the `t`-fold tensor +power of `V_k ⊕ V_{2ℓ}`, so a vector in that power is a function on +boundary states. The ambient bilinear form is the `t`-fold product +of the super form on one leg: the identity on the even colours and +the symplectic form on the odd ones, zero across the two. That one +leg's form is the through-edge state factor the mixed partition +function already uses. + +Writing the connection pairing as this form evaluated at vectors +attached to the two fragments bounds the edge-rank by `(k + 2ℓ)^t`, +because that is how many boundary states there are. +-/ + +@[expose] public section + +namespace RS + + + +/-- **The super form on boundary states at arity `t`**: the product +over the legs of the one-leg form of RS21 (11) — the identity on the +even colours and the symplectic form on the odd ones, zero across +the two. -/ +noncomputable def superForm {k ℓ : ℕ} (t : ℕ) + (x y : GenBoundaryState k ℓ (Fin t)) : ℂ := + ∏ i : Fin t, superLeg (x i) (y i) + +/-- **A super-Gram factorization bounds the edge-rank by +`k + 2ℓ`.** -/ +theorem edgeRankBounded_of_superGram {k ℓ : ℕ} + {f : ClosedFragment → ℂ} + (T : ∀ t : ℕ, Fragment (Fin t) → GenBoundaryState k ℓ (Fin t) → ℂ) + (hgram : ∀ (t : ℕ) (F G : Fragment (Fin t)), + connectionPairing f t F G + = ∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * T t F x * T t G y) : + EdgeRankBounded f (k + 2 * ℓ) := + edgeRankBounded_of_gram (fun t => GenBoundaryState k ℓ (Fin t)) + (fun t => by + rw [card_genBoundaryState k ℓ (Fin t), Fintype.card_fin]) + (fun t => superForm t) T hgram + +/-! ### The fragment tensor's normalisation + +The super form pairs an odd leg's two colours antisymmetrically, so +across the legs a matched pair of fragments picks up `(-1)` once for +each of the half of the used legs where the first fragment's arc +enters. The fragment tensor carries a fourth root of unity per two +used legs, and the two fragments' roots multiply to exactly that +sign. Since a leg is used exactly when its colour is odd, the +factor depends on the boundary state alone. +-/ + +/-- The number of legs a boundary state colours oddly. -/ +noncomputable def oddCount {k ℓ t : ℕ} + (x : GenBoundaryState k ℓ (Fin t)) : ℕ := + (Finset.univ.filter (fun i => ∃ c, x i = Sum.inr c)).card + +/-- **The fragment tensor's normalising root**: a fourth root of +unity, one quarter turn for every two odd legs. -/ +noncomputable def stateTwist {k ℓ t : ℕ} + (x : GenBoundaryState k ℓ (Fin t)) : ℂ := + Complex.I ^ (oddCount x / 2) + +/-- **The two fragments' roots multiply to the form's sign.** On a +matched pair of states the product is `(-1)` to half the number of +odd legs — exactly the sign the antisymmetric legs contribute. -/ +theorem stateTwist_mul_stateTwist {k ℓ t : ℕ} + {x y : GenBoundaryState k ℓ (Fin t)} + (hxy : oddCount x = oddCount y) : + stateTwist x * stateTwist y = (-1 : ℂ) ^ (oddCount x / 2) := by + unfold stateTwist + rw [← hxy, ← pow_add, ← two_mul, pow_mul, Complex.I_sq] + +/-- **The roots cancel the legs' sign** — RS21's "these +contributions cancel with `(-1)^{|S(H₁)|/4} (-1)^{|S(H₂)|/4}`". At +half the used legs the first fragment's arc enters and the form is +`⟨f_c, g_c⟩ = -1`; at the other half it leaves and the form is +`⟨g_c, f_c⟩ = 1`. So the legs contribute `(-1)` to half the number +of used legs, and the two fragments' fourth roots multiply to the +same thing. -/ +theorem stateTwist_mul_stateTwist_mul_half {k ℓ t : ℕ} + {x y : GenBoundaryState k ℓ (Fin t)} + (hxy : oddCount x = oddCount y) {m : ℕ} (hm : oddCount x = 2 * m) : + (stateTwist x * stateTwist y) * (-1 : ℂ) ^ m = 1 := by + rw [stateTwist_mul_stateTwist hxy, hm, + show 2 * m / 2 = m from by omega, ← pow_add, ← two_mul, pow_mul] + norm_num + +/-! ### The form vanishes across a parity mismatch + +The one-leg form is zero between an even colour and an odd one, so +two states differing in parity at any leg pair to zero. This is +what makes two fragments' tensors orthogonal when their subsets use +different label sets. +-/ + +/-- **An even leg against an odd one kills the form.** -/ +theorem superForm_eq_zero_of_left_right {k ℓ t : ℕ} + (x y : GenBoundaryState k ℓ (Fin t)) (i : Fin t) {a : Fin k} + {c : Fin (2 * ℓ)} (hx : x i = Sum.inl a) (hy : y i = Sum.inr c) : + superForm t x y = 0 := by + refine Finset.prod_eq_zero (Finset.mem_univ i) ?_ + rw [hx, hy] + rfl + +/-- **And an odd leg against an even one.** -/ +theorem superForm_eq_zero_of_right_left {k ℓ t : ℕ} + (x y : GenBoundaryState k ℓ (Fin t)) (i : Fin t) + {c : Fin (2 * ℓ)} {a : Fin k} (hx : x i = Sum.inr c) + (hy : y i = Sum.inl a) : superForm t x y = 0 := by + refine Finset.prod_eq_zero (Finset.mem_univ i) ?_ + rw [hx, hy] + rfl + +/-- A colour that is not odd is even. -/ +theorem exists_left_of_not_right {k ℓ : ℕ} + {v : Fin k ⊕ Fin (2 * ℓ)} (h : ¬ ∃ c, v = Sum.inr c) : + ∃ a, v = Sum.inl a := by + rcases v with a | c + · exact ⟨a, rfl⟩ + · exact absurd ⟨c, rfl⟩ h + +/-! ### The form is diagonal in the partner pairing + +RS21 pairs two fragments' tensors coordinate by coordinate and +observes that the pairing vanishes unless the two coordinates agree +— the even colours outright, and the odd ones because the two +orientations are opposite at a used leg, so the same colour appears +against its dual basis vector. + +Written in one basis the second coordinate is not equal to the +first but *dual* to it: the same colour on an even leg, the partner +colour on an odd one. So the form has exactly one nonzero +coordinate for each state, and the double sum over coordinates +collapses to a single one. +-/ + +/-- **The dual of one leg's colour**: itself on an even colour, the +partner on an odd one. -/ +noncomputable def dualLeg {k ℓ : ℕ} : + (Fin k ⊕ Fin (2 * ℓ)) → (Fin k ⊕ Fin (2 * ℓ)) + | Sum.inl a => Sum.inl a + | Sum.inr c => Sum.inr (oddPartner ℓ c) + +/-- **The dual state**: the dual colour at every leg. -/ +noncomputable def dualState {k ℓ : ℕ} {α : Type} + (x : GenBoundaryState k ℓ α) : GenBoundaryState k ℓ α := + fun i => dualLeg (x i) + +/-- **One leg's form vanishes off the dual colour.** -/ +theorem superLeg_eq_zero_of_ne_dualLeg {k ℓ : ℕ} + (u v : Fin k ⊕ Fin (2 * ℓ)) (h : v ≠ dualLeg u) : + superLeg u v = 0 := by + rcases u with a | c + · rcases v with b | d + · exact ite_eq_right (fun hb => h (by rw [hb]; rfl)) + · rfl + · rcases v with b | d + · rfl + · change symplecticJ ℓ c d = 0 + have hd : d ≠ oddPartner ℓ c := fun hx => h (by rw [hx]; rfl) + have hc := c.isLt + have hd' := d.isLt + have hpart := eq_oddPartner_iff c d + unfold symplecticJ + by_cases hlt : c.val < ℓ + · rw [ite_eq_left hlt] at hpart + rw [ite_eq_right (fun hx => hd (hpart.mpr hx)), + ite_eq_right (by omega)] + · rw [ite_eq_right hlt] at hpart + rw [ite_eq_right (by omega), + ite_eq_right (fun hx => hd (hpart.mpr (by omega)))] + +/-- **The form vanishes off the dual state.** -/ +theorem superForm_eq_zero_of_ne_dualState {k ℓ t : ℕ} + (x y : GenBoundaryState k ℓ (Fin t)) (h : y ≠ dualState x) : + superForm t x y = 0 := by + obtain ⟨i, hi⟩ : ∃ i, y i ≠ dualLeg (x i) := by + by_contra hx + push Not at hx + exact h (funext hx) + exact Finset.prod_eq_zero (Finset.mem_univ i) + (superLeg_eq_zero_of_ne_dualLeg (x i) (y i) hi) + +/-- **One leg's form against its own dual**: `1` on an even colour, +and on an odd one the negated dual sign — RS21's `⟨f_c, g_c⟩`. -/ +noncomputable def legSelf {k ℓ : ℕ} : + (Fin k ⊕ Fin (2 * ℓ)) → ℂ + | Sum.inl _ => 1 + | Sum.inr c => -dualSign ℓ c + +/-- The one-leg form at the dual colour. -/ +theorem superLeg_dualLeg {k ℓ : ℕ} (u : Fin k ⊕ Fin (2 * ℓ)) : + superLeg u (dualLeg u) = legSelf u := by + rcases u with a | c + · exact ite_eq_left rfl + · change symplecticJ ℓ c (oddPartner ℓ c) = -dualSign ℓ c + have hfg := superLeg_f_g ℓ c + have hsq := dualSign_sq ℓ c + linear_combination dualSign ℓ c * hfg + - symplecticJ ℓ c (oddPartner ℓ c) * hsq + +/-- **The form at the dual state** is the product of the legs' own +values. -/ +theorem superForm_dualState {k ℓ t : ℕ} + (x : GenBoundaryState k ℓ (Fin t)) : + superForm t x (dualState x) = ∏ i : Fin t, legSelf (x i) := + Finset.prod_congr rfl (fun i _ => superLeg_dualLeg (x i)) + +/-- **The Gram double sum collapses.** Only the dual coordinate +contributes, so a pairing written against the form is a single sum +over boundary states. -/ +theorem sum_sum_superForm {k ℓ t : ℕ} + (T₁ T₂ : GenBoundaryState k ℓ (Fin t) → ℂ) : + (∑ x : GenBoundaryState k ℓ (Fin t), + ∑ y : GenBoundaryState k ℓ (Fin t), + superForm t x y * T₁ x * T₂ y) + = ∑ x : GenBoundaryState k ℓ (Fin t), + (∏ i : Fin t, legSelf (x i)) * T₁ x * T₂ (dualState x) := by + refine Finset.sum_congr rfl (fun x _ => ?_) + rw [Finset.sum_eq_single (dualState x)] + · rw [superForm_dualState] + · intro y _ hy + rw [superForm_eq_zero_of_ne_dualState x y hy, zero_mul, + zero_mul] + · intro hx + exact absurd (Finset.mem_univ _) hx + +/-! ### The leg bracket + +At a used leg the two fragments each contribute a dual-basis weight +and the form contributes its entry. Their product is RS21's leg +value: `-1` where the first fragment's arc leaves the leg and `1` +where it enters — provided the two arcs point oppositely, which is +what the Eulerian condition on the union of the two matchings says. +-/ + +/-- **The leg bracket on an odd leg** — RS21's `⟨f_c, g_c⟩ = -1` and +`⟨g_c, f_c⟩ = 1`, read in the coordinates the tensor uses. -/ +theorem legBracket_odd {k ℓ : ℕ} (u : Fin (2 * ℓ)) (t₁ : Bool) : + ((if t₁ then dualSign ℓ u else 1) + * (if !t₁ then dualSign ℓ (oddPartner ℓ u) else 1)) + * (superLeg (k := k) (ℓ := ℓ) (Sum.inr u) + (Sum.inr (oddPartner ℓ u))) + = if t₁ then -1 else 1 := by + have hJ : (superLeg (k := k) (ℓ := ℓ) (Sum.inr u) + (Sum.inr (oddPartner ℓ u))) = -dualSign ℓ u := by + have hfg := superLeg_f_g ℓ u + have hsq := dualSign_sq ℓ u + change symplecticJ ℓ u (oddPartner ℓ u) = -dualSign ℓ u + linear_combination dualSign ℓ u * hfg + - symplecticJ ℓ u (oddPartner ℓ u) * hsq + have hsq := dualSign_sq ℓ u + have hpart := dualSign_oddPartner ℓ u + cases t₁ + · rw [ite_eq_right (by simp), Bool.not_false, ite_eq_left rfl, hJ, hpart, + ite_eq_right (by simp)] + linear_combination hsq + · rw [ite_eq_left rfl, Bool.not_true, ite_eq_right (by simp), hJ, + ite_eq_left rfl] + linear_combination -hsq + +/-- **The leg bracket on an even leg** is trivial. -/ +theorem legBracket_even {k ℓ : ℕ} (a : Fin k) : + (superLeg (k := k) (ℓ := ℓ) (Sum.inl a) (Sum.inl a)) = 1 := + ite_eq_left rfl + +/-! ### The legs, multiplied out + +Each fragment's dual-basis weight is a product over the legs, so the +whole leg contribution is a product of brackets. With the two +matchings' arcs opposite at every leg, each bracket is `-1` exactly +where the first fragment's arc leaves, so the product is `(-1)` to +the number of such legs — half the used ones, which is RS21's +count. +-/ + +/-- One leg's dual-basis weight, as it occurs in `dualWeight`. -/ +noncomputable def legWeight {k ℓ : ℕ} (b : Bool) + (v : Fin k ⊕ Fin (2 * ℓ)) : ℂ := + match v with + | Sum.inl _ => 1 + | Sum.inr u => if b then dualSign ℓ u else 1 + +/-- **The leg weights only see the used legs.** At an even colour +the weight is one whichever way the arc points, so two direction +assignments agreeing on the odd legs give the same product. This is +what lets the two fragments' directions be compared only where both +subsets are used. -/ +theorem prod_legWeight_congr {k ℓ t : ℕ} (b b' : Fin t → Bool) + (x : GenBoundaryState k ℓ (Fin t)) + (h : ∀ i, (∃ c, x i = Sum.inr c) → b i = b' i) : + (∏ i : Fin t, legWeight (b i) (x i)) + = ∏ i : Fin t, legWeight (b' i) (x i) := by + refine Finset.prod_congr rfl (fun i _ => ?_) + rcases hx : x i with a | c + · rfl + · rw [h i ⟨c, hx⟩] + +/-- **The bracket at one leg.** -/ +theorem legWeight_mul {k ℓ : ℕ} (b : Bool) + (v : Fin k ⊕ Fin (2 * ℓ)) : + legWeight b v * legWeight (!b) (dualLeg v) * superLeg v (dualLeg v) + = if (∃ c, v = Sum.inr c) ∧ b = true then -1 else 1 := by + rcases v with a | u + · rw [ite_eq_right (by + rintro ⟨⟨c, hcc⟩, -⟩ + exact Sum.inl_ne_inr hcc)] + change (1 : ℂ) * 1 * superLeg (Sum.inl a) (Sum.inl a) = 1 + rw [legBracket_even a] + ring + · have hb := legBracket_odd (k := k) u b + by_cases hbt : b = true + · rw [ite_eq_left ⟨⟨u, rfl⟩, hbt⟩, hbt] + rw [hbt] at hb + simpa [legWeight, dualLeg] using hb + · have hbf : b = false := by + cases b + · rfl + · exact absurd rfl hbt + rw [ite_eq_right (fun hc => hbt hc.2), hbf] + rw [hbf] at hb + simpa [legWeight, dualLeg] using hb + +/-! ### Undoing the dual basis is a bijection of states + +Summing a tensor's coordinates and summing the partition function's +states are the same sum: the dual basis relabels the colour at the +legs whose arc leaves, and that relabelling is an involution. +-/ + +/-- The dual colour is an involution. -/ +theorem dualLeg_involutive {k ℓ : ℕ} : + Function.Involutive (dualLeg (k := k) (ℓ := ℓ)) := by + rintro (a | c) + · rfl + · change Sum.inr (oddPartner ℓ (oddPartner ℓ c)) = Sum.inr c + rw [oddPartner_invol] + +/-- **Undoing the dual basis at the legs whose arc leaves.** -/ +noncomputable def untwistState {k ℓ t : ℕ} (b : Fin t → Bool) + (x : GenBoundaryState k ℓ (Fin t)) : + GenBoundaryState k ℓ (Fin t) := + fun i => if b i then dualLeg (x i) else x i + +/-- Untwisting a state at a fixed sign pattern is an involution. -/ +theorem untwistState_involutive {k ℓ t : ℕ} (b : Fin t → Bool) : + Function.Involutive (untwistState (k := k) (ℓ := ℓ) b) := by + intro x + funext i + change (if b i then dualLeg (untwistState b x i) + else untwistState b x i) = x i + by_cases hb : b i = true + · rw [ite_eq_left hb] + change dualLeg (if b i then dualLeg (x i) else x i) = x i + rw [ite_eq_left hb, dualLeg_involutive (x i)] + · rw [ite_eq_right hb] + change (if b i then dualLeg (x i) else x i) = x i + rw [ite_eq_right hb] + +/-- **The two sums agree.** -/ +theorem sum_untwistState {k ℓ t : ℕ} (b : Fin t → Bool) + (V : GenBoundaryState k ℓ (Fin t) → ℂ) : + (∑ x : GenBoundaryState k ℓ (Fin t), V (untwistState b x)) + = ∑ st : GenBoundaryState k ℓ (Fin t), V st := + Fintype.sum_equiv + ((untwistState_involutive (k := k) (ℓ := ℓ) b).toPerm) _ _ + (fun _ => rfl) + +/-- The dual state colours the same legs oddly, pointwise. -/ +theorem dualState_isInr {k ℓ t : ℕ} + (x : GenBoundaryState k ℓ (Fin t)) (i : Fin t) : + (∃ c, dualState x i = Sum.inr c) ↔ (∃ c, x i = Sum.inr c) := by + change (∃ c, dualLeg (x i) = Sum.inr c) ↔ (∃ c, x i = Sum.inr c) + rcases x i with a | c + · constructor + · rintro ⟨d, hd⟩ + exact (Sum.inl_ne_inr hd).elim + · rintro ⟨d, hd⟩ + exact (Sum.inl_ne_inr hd).elim + · exact ⟨fun _ => ⟨c, rfl⟩, fun _ => ⟨oddPartner ℓ c, rfl⟩⟩ + +/-- **RS21's `χ = χ′`, needing the directions opposite only where +both subsets are used.** At an even leg the dual colour is the +colour, so the two sides agree there whatever the directions say. -/ +theorem untwistState_dualState' {k ℓ t : ℕ} (b₁ b₂ : Fin t → Bool) + (x : GenBoundaryState k ℓ (Fin t)) + (hb : ∀ i, (∃ c, x i = Sum.inr c) → b₂ i = !(b₁ i)) : + untwistState b₂ (dualState x) = untwistState b₁ x := by + funext i + change (if b₂ i then dualLeg (dualLeg (x i)) else dualLeg (x i)) + = if b₁ i then dualLeg (x i) else x i + rcases hx : x i with a | c + · have he : dualLeg (Sum.inl a : Fin k ⊕ Fin (2 * ℓ)) + = Sum.inl a := rfl + rw [he, he] + by_cases h₂ : b₂ i = true + · rw [ite_eq_left h₂] + by_cases h₁ : b₁ i = true + · rw [ite_eq_left h₁] + · rw [ite_eq_right h₁] + · rw [ite_eq_right h₂] + by_cases h₁ : b₁ i = true + · rw [ite_eq_left h₁] + · rw [ite_eq_right h₁] + · rw [hb i ⟨c, hx⟩] + by_cases h₁ : b₁ i = true + · rw [h₁, Bool.not_true, ite_eq_right (by simp), ite_eq_left rfl] + · have hf : b₁ i = false := by + cases hbb : b₁ i + · rfl + · exact absurd hbb h₁ + rw [hf, Bool.not_false, ite_eq_left rfl, ite_eq_right (by simp)] + exact dualLeg_involutive _ + +/-! ### Contracting one leg + +Summing a fragment tensor's coordinate at a used leg against the +form is the same as summing the partition function's own colour +there. The two differ by the partner relabelling the dual basis +performs, which is a bijection of the odd colours, and by RS21's leg +value. +-/ + +/-- **The legs' product**: `(-1)` to the number of legs at which the +first fragment's arc leaves. -/ +theorem prod_legBracket {k ℓ t : ℕ} + (x : GenBoundaryState k ℓ (Fin t)) (b : Fin t → Bool) : + ((∏ i : Fin t, legWeight (b i) (x i)) + * (∏ i : Fin t, legWeight (!(b i)) (dualLeg (x i)))) + * superForm t x (dualState x) + = (-1 : ℂ) ^ (Finset.univ.filter + (fun i => (∃ c, x i = Sum.inr c) ∧ b i = true)).card := by + classical + rw [superForm, ← Finset.prod_mul_distrib, ← Finset.prod_mul_distrib] + rw [Finset.prod_congr rfl (fun i _ => by + change legWeight (b i) (x i) * legWeight (!(b i)) (dualLeg (x i)) + * superLeg (x i) (dualState x i) = _ + exact legWeight_mul (b i) (x i))] + rw [Finset.prod_ite, Finset.prod_const, Finset.prod_const_one, + mul_one] + +/-- The dual state colours the same legs oddly. -/ +theorem oddCount_dualState {k ℓ t : ℕ} + (x : GenBoundaryState k ℓ (Fin t)) : + oddCount (dualState x) = oddCount x := by + classical + unfold oddCount + refine congrArg Finset.card (Finset.filter_congr (fun i _ => ?_)) + constructor + · rintro ⟨c, hc⟩ + rcases hx : x i with a | u + · exact absurd (hx ▸ hc : dualLeg (Sum.inl a) = Sum.inr c) + (fun h => Sum.inl_ne_inr h) + · exact ⟨u, rfl⟩ + · rintro ⟨u, hu⟩ + exact ⟨oddPartner ℓ u, by + change dualLeg (x i) = Sum.inr (oddPartner ℓ u) + rw [hu] + rfl⟩ + +/-- **RS21's cancellation, assembled**: the two fragments' fourth +roots and the legs' product cancel, provided the first fragment's +arc leaves at half the used legs — which is what the Eulerian +condition on the union gives. -/ +theorem legs_cancel_twists {k ℓ t : ℕ} + (x : GenBoundaryState k ℓ (Fin t)) (b : Fin t → Bool) + (hcount : oddCount x = 2 * (Finset.univ.filter + (fun i => (∃ c, x i = Sum.inr c) ∧ b i = true)).card) : + (stateTwist x * stateTwist (dualState x)) + * (((∏ i : Fin t, legWeight (b i) (x i)) + * (∏ i : Fin t, legWeight (!(b i)) (dualLeg (x i)))) + * superForm t x (dualState x)) + = 1 := by + rw [prod_legBracket x b] + exact stateTwist_mul_stateTwist_mul_half (oddCount_dualState x).symm + hcount + +/-! ### The legs contracted, all at once + +Putting the two together: the bracket product is `(-1)` to the +number of legs the first fragment's arc leaves, and undoing the dual +basis is a bijection of states. So the Gram sum in the tensor's +coordinates is the partition function's sum over states, times +RS21's leg sign — provided the tensors are supported where the used +legs are the same, which is what (16) already says. +-/ + +/-- **RS21's step 5, complete.** With the two fragments' fourth +roots included, the Gram sum in the tensor's coordinates is the +partition function's own sum over states, with no residual sign: +the legs' `(-1)` per entering arc is exactly cancelled by the +roots. -/ +theorem sum_legBracket_with_twists {k ℓ t : ℕ} (b : Fin t → Bool) + (V : GenBoundaryState k ℓ (Fin t) → ℂ) (m : ℕ) + (hodd : ∀ x : GenBoundaryState k ℓ (Fin t), + V (untwistState b x) ≠ 0 → + (Finset.univ.filter (fun i => + (∃ c, x i = Sum.inr c) ∧ b i = true)).card = m) + (hcnt : ∀ x : GenBoundaryState k ℓ (Fin t), + V (untwistState b x) ≠ 0 → oddCount x = 2 * m) : + (∑ x : GenBoundaryState k ℓ (Fin t), + ((stateTwist x * stateTwist (dualState x)) + * (((∏ i : Fin t, legWeight (b i) (x i)) + * (∏ i : Fin t, legWeight (!(b i)) (dualLeg (x i)))) + * superForm t x (dualState x))) + * V (untwistState b x)) + = ∑ st : GenBoundaryState k ℓ (Fin t), V st := by + classical + have hterm : ∀ x : GenBoundaryState k ℓ (Fin t), + ((stateTwist x * stateTwist (dualState x)) + * (((∏ i : Fin t, legWeight (b i) (x i)) + * (∏ i : Fin t, legWeight (!(b i)) (dualLeg (x i)))) + * superForm t x (dualState x))) + * V (untwistState b x) + = V (untwistState b x) := by + intro x + by_cases hV : V (untwistState b x) = 0 + · rw [hV, mul_zero] + · rw [legs_cancel_twists x b (by rw [hcnt x hV, hodd x hV]), + one_mul] + rw [Finset.sum_congr rfl (fun x _ => hterm x), sum_untwistState b V] + +/-- **RS21's step 5, with the second fragment's own directions.** +The two fragments each carry their own arc directions; they need +only be opposite at the legs both subsets use, since an even leg's +weight is one either way. -/ +theorem sum_legBracket_with_twists' {k ℓ t : ℕ} + (b₁ b₂ : Fin t → Bool) + (V : GenBoundaryState k ℓ (Fin t) → ℂ) (m : ℕ) + (hodd : ∀ x : GenBoundaryState k ℓ (Fin t), + V (untwistState b₁ x) ≠ 0 → + (Finset.univ.filter (fun i => + (∃ c, x i = Sum.inr c) ∧ b₁ i = true)).card = m) + (hcnt : ∀ x : GenBoundaryState k ℓ (Fin t), + V (untwistState b₁ x) ≠ 0 → oddCount x = 2 * m) + (hb : ∀ x : GenBoundaryState k ℓ (Fin t), + V (untwistState b₁ x) ≠ 0 → + ∀ i, (∃ c, x i = Sum.inr c) → b₂ i = !(b₁ i)) : + (∑ x : GenBoundaryState k ℓ (Fin t), + ((stateTwist x * stateTwist (dualState x)) + * (((∏ i : Fin t, legWeight (b₁ i) (x i)) + * (∏ i : Fin t, legWeight (b₂ i) (dualLeg (x i)))) + * superForm t x (dualState x))) + * V (untwistState b₁ x)) + = ∑ st : GenBoundaryState k ℓ (Fin t), V st := by + classical + have hodd' : ∀ (x : GenBoundaryState k ℓ (Fin t)) (i : Fin t), + (∃ c, dualState x i = Sum.inr c) ↔ (∃ c, x i = Sum.inr c) := by + intro x i + change (∃ c, dualLeg (x i) = Sum.inr c) ↔ (∃ c, x i = Sum.inr c) + rcases x i with a | c + · constructor + · rintro ⟨d, hd⟩ + exact (Sum.inl_ne_inr hd).elim + · rintro ⟨d, hd⟩ + exact (Sum.inl_ne_inr hd).elim + · exact ⟨fun _ => ⟨c, rfl⟩, fun _ => ⟨oddPartner ℓ c, rfl⟩⟩ + refine (Finset.sum_congr rfl (fun x _ => ?_)).trans + (sum_legBracket_with_twists b₁ V m hodd hcnt) + by_cases hV : V (untwistState b₁ x) = 0 + · rw [hV, mul_zero, mul_zero] + · refine congrArg (fun z : ℂ => z * V (untwistState b₁ x)) ?_ + refine congrArg (fun z : ℂ => + (stateTwist x * stateTwist (dualState x)) + * (((∏ i : Fin t, legWeight (b₁ i) (x i)) * z) + * superForm t x (dualState x))) ?_ + exact prod_legWeight_congr b₂ (fun i => !(b₁ i)) (dualState x) + (fun i hi => hb x hV i ((hodd' x i).mp hi)) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperSpace.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperSpace.lean new file mode 100644 index 0000000000..1cae1c03b8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperSpace.lean @@ -0,0 +1,135 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue + +/-! +# The super-symmetric form on one leg + +The ambient space of the Gram construction is `V_k ⊕ V_{2ℓ}`, +carrying the symmetric form `xᵀy` on the even summand, the +skew-symmetric form `xᵀJy` on the odd summand with + + J = [[0, I], [-I, 0]], + +and zero across the two. This file is that form and nothing else, +written from the definition rather than assembled out of the +partition function's own weights, so that its relation to those +weights is a theorem. + +The relation is recorded at the end: on the even block the form is +the partition function's state factor, and on the odd block it is +that factor negated. The negation is the one already visible in +the tower's colour kernel, which pairs the odd colours through +`-oddThroughFactor`. +-/ + +@[expose] public section + +namespace RS + + + +/-- **The symplectic matrix** `J = [[0, I], [-I, 0]]` in +coordinates: `J c d` is `1` when `d = c + ℓ`, `-1` when +`c = d + ℓ`, and `0` otherwise. -/ +noncomputable def symplecticJ (ℓ : ℕ) (c d : Fin (2 * ℓ)) : ℂ := + if d.val = c.val + ℓ then 1 + else if c.val = d.val + ℓ then -1 + else 0 + +/-- **The super form on one leg**: the identity on the even +colours, `J` on the odd ones, zero across. -/ +noncomputable def superLeg {k ℓ : ℕ} : + (Fin k ⊕ Fin (2 * ℓ)) → (Fin k ⊕ Fin (2 * ℓ)) → ℂ + | Sum.inl a, Sum.inl b => if a = b then 1 else 0 + | Sum.inr c, Sum.inr d => symplecticJ ℓ c d + | _, _ => 0 + +/-! ### The relation to the partition function's state factor + +The through-edge state factor of the mixed partition function is +the super form on the even block and its negative on the odd one. +Both are recorded as theorems; nothing below assumes them. +-/ + +/-- Membership in the odd partner relation, in coordinates. -/ +theorem eq_oddPartner_iff {ℓ : ℕ} (c d : Fin (2 * ℓ)) : + d = oddPartner ℓ c + ↔ (if c.val < ℓ then d.val = c.val + ℓ else d.val = c.val - ℓ) := by + unfold oddPartner + by_cases h : c.val < ℓ + · rw [dite_eq_left h, ite_eq_left h, Fin.ext_iff] + · rw [dite_eq_right h, ite_eq_right h, Fin.ext_iff] + +/-! ### The dual basis at outgoing ends + +RS21 writes the boundary vector at an odd leg as `f_c` where the +arc is incoming and `g_c` where it is outgoing, and computes +`⟨f_c, g_c⟩ = -1` and `⟨g_c, f_c⟩ = 1`. In one basis, `g_c` is the +symplectic dual of `f_c`: the partner colour carrying the partner +sign. The two displayed values are recovered below, which is what +fixes the convention. +-/ + +/-- The symplectic dual of a colour: the partner colour with the +partner sign. This is RS21's `g_c` written in the basis of the +`f`'s. -/ +noncomputable def dualSign (ℓ : ℕ) (c : Fin (2 * ℓ)) : ℂ := + ((oddPartnerSign ℓ c : ℤ) : ℂ) + +/-- **The dual sign squares to one**: it is `±1`. -/ +theorem dualSign_sq (ℓ : ℕ) (c : Fin (2 * ℓ)) : + dualSign ℓ c * dualSign ℓ c = 1 := by + unfold dualSign oddPartnerSign + by_cases h : c.val < ℓ + · rw [ite_eq_left h]; norm_num + · rw [ite_eq_right h]; norm_num + +/-- The partner colour in coordinates. -/ +theorem oddPartner_val (ℓ : ℕ) (c : Fin (2 * ℓ)) : + (oddPartner ℓ c).val + = if c.val < ℓ then c.val + ℓ else c.val - ℓ := by + unfold oddPartner + split_ifs <;> rfl + +/-- **`⟨f_c, g_c⟩ = -1`.** -/ +theorem superLeg_f_g (ℓ : ℕ) (c : Fin (2 * ℓ)) : + dualSign ℓ c * symplecticJ ℓ c (oddPartner ℓ c) = -1 := by + have hc := c.isLt + have hv := oddPartner_val ℓ c + unfold dualSign symplecticJ oddPartnerSign + by_cases h : c.val < ℓ + · rw [ite_eq_left h] at hv + rw [ite_eq_left hv, ite_eq_left h] + norm_num + · rw [ite_eq_right h] at hv + rw [ite_eq_right (show ¬ ((oddPartner ℓ c).val = c.val + ℓ) by omega), + ite_eq_left (show c.val = (oddPartner ℓ c).val + ℓ by omega), + ite_eq_right h] + norm_num + +/-! ### The through-edge factor is the dual basis at one end + +A through-edge's two legs carry `f_{φ(a)}` and `g_{φ(a)}` — the +same colour, dual bases. In one basis that says the two legs' +colours are partners and the leg holding `g` contributes its +partner sign. The mixed partition function's through-edge factor +says exactly that, so it is the dual basis's contribution at those +legs rather than an extra weight. +-/ + +/-- **The dual sign flips at the partner colour.** -/ +theorem dualSign_oddPartner (ℓ : ℕ) (c : Fin (2 * ℓ)) : + dualSign ℓ (oddPartner ℓ c) = -dualSign ℓ c := by + unfold dualSign + rw [oddPartnerSign_oddPartner] + push_cast + ring + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorAssoc.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorAssoc.lean new file mode 100644 index 0000000000..cb7e04e0cd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorAssoc.lean @@ -0,0 +1,148 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc + +/-! +# Associativity of the fragment tensor + +The two associations of a triple tensor carry the same +interleaved boundary up to the arithmetic cast: block order is +`s₁ s₂ s₃ | t₁ t₂ t₃` either way. The label identity +(`assocLabel_eq`) is a six-block value chase through the +interleave value lemmas; the associator equivalence follows by +pure relabel algebra. +-/ + +@[expose] public section + +namespace RS + +variable (s₁ t₁ s₂ t₂ s₃ t₃ : ℕ) + +/-- The associativity cast of interleaved boundaries. -/ +noncomputable def tensorAssocCast : + Fin ((s₁ + (s₂ + s₃)) + (t₁ + (t₂ + t₃))) ≃ + Fin (((s₁ + s₂) + s₃) + ((t₁ + t₂) + t₃)) := + finCongr (by omega) + +/-- The left-association label composite. -/ +noncomputable def assocLabelL : + (Fin (s₁ + t₁) ⊕ (Fin (s₂ + t₂) ⊕ Fin (s₃ + t₃))) ≃ + Fin (((s₁ + s₂) + s₃) + ((t₁ + t₂) + t₃)) := + (_root_.Equiv.sumAssoc _ _ _).symm.trans + ((_root_.Equiv.sumCongr (interleaveEquiv s₁ t₁ s₂ t₂) + (_root_.Equiv.refl (Fin (s₃ + t₃)))).trans + (interleaveEquiv (s₁ + s₂) (t₁ + t₂) s₃ t₃)) + +/-- The right-association label composite, cast. -/ +noncomputable def assocLabelR : + (Fin (s₁ + t₁) ⊕ (Fin (s₂ + t₂) ⊕ Fin (s₃ + t₃))) ≃ + Fin (((s₁ + s₂) + s₃) + ((t₁ + t₂) + t₃)) := + (_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin (s₁ + t₁))) + (interleaveEquiv s₂ t₂ s₃ t₃)).trans + ((interleaveEquiv s₁ t₁ (s₂ + s₃) (t₂ + t₃)).trans + (tensorAssocCast s₁ t₁ s₂ t₂ s₃ t₃)) + +/-- The two association composites agree. -/ +theorem assocLabel_eq : + assocLabelL s₁ t₁ s₂ t₂ s₃ t₃ = + assocLabelR s₁ t₁ s₂ t₂ s₃ t₃ := by + apply _root_.Equiv.ext + intro x + unfold assocLabelL assocLabelR tensorAssocCast + simp only [_root_.Equiv.trans_apply, + _root_.Equiv.sumCongr_apply] + rcases x with a | (b | c) + · simp only [_root_.Equiv.sumAssoc_symm_apply_inl, + Sum.map_inl, _root_.Equiv.refl_apply] + by_cases h : a.val < s₁ + · rw [show a = Fin.castAdd t₁ ⟨a.val, h⟩ from Fin.ext rfl, + interleaveEquiv_inl_low, interleaveEquiv_inl_low, + interleaveEquiv_inl_low] + exact Fin.ext rfl + · have hk : a.val - s₁ < t₁ := by have := a.isLt; omega + rw [show a = Fin.natAdd s₁ ⟨a.val - s₁, hk⟩ from + Fin.ext (by change a.val = s₁ + (a.val - s₁); omega), + interleaveEquiv_inl_high, interleaveEquiv_inl_high, + interleaveEquiv_inl_high] + exact Fin.ext (by + change ((s₁ + s₂) + s₃) + (a.val - s₁) = + (s₁ + (s₂ + s₃)) + (a.val - s₁) + omega) + · simp only [_root_.Equiv.sumAssoc_symm_apply_inr_inl, + Sum.map_inl, Sum.map_inr] + by_cases h : b.val < s₂ + · rw [show b = Fin.castAdd t₂ ⟨b.val, h⟩ from Fin.ext rfl, + interleaveEquiv_inr_low, interleaveEquiv_inl_low, + interleaveEquiv_inl_low, interleaveEquiv_inr_low] + exact Fin.ext rfl + · have hk : b.val - s₂ < t₂ := by have := b.isLt; omega + rw [show b = Fin.natAdd s₂ ⟨b.val - s₂, hk⟩ from + Fin.ext (by change b.val = s₂ + (b.val - s₂); omega), + interleaveEquiv_inr_high, interleaveEquiv_inl_high, + interleaveEquiv_inl_high, interleaveEquiv_inr_high] + exact Fin.ext (by + change ((s₁ + s₂) + s₃) + (t₁ + (b.val - s₂)) = + (s₁ + (s₂ + s₃)) + (t₁ + (b.val - s₂)) + omega) + · simp only [_root_.Equiv.sumAssoc_symm_apply_inr_inr, + Sum.map_inr, _root_.Equiv.refl_apply] + by_cases h : c.val < s₃ + · rw [show c = Fin.castAdd t₃ ⟨c.val, h⟩ from Fin.ext rfl, + interleaveEquiv_inr_low, interleaveEquiv_inr_low, + interleaveEquiv_inr_low] + exact Fin.ext (by + change (s₁ + s₂) + c.val = s₁ + (s₂ + c.val) + omega) + · have hk : c.val - s₃ < t₃ := by have := c.isLt; omega + rw [show c = Fin.natAdd s₃ ⟨c.val - s₃, hk⟩ from + Fin.ext (by change c.val = s₃ + (c.val - s₃); omega), + interleaveEquiv_inr_high, interleaveEquiv_inr_high, + interleaveEquiv_inr_high] + exact Fin.ext (by + change ((s₁ + s₂) + s₃) + ((t₁ + t₂) + (c.val - s₃)) = + (s₁ + (s₂ + s₃)) + (t₁ + (t₂ + (c.val - s₃))) + omega) + +/-- **Associativity of the fragment tensor**: the two +associations agree up to the arithmetic cast. -/ +noncomputable def tensorFragmentAssoc + (X : Fragment (Fin (s₁ + t₁))) (Y : Fragment (Fin (s₂ + t₂))) + (Z : Fragment (Fin (s₃ + t₃))) : + (tensorFragment (tensorFragment X Y) Z).Equiv + ((tensorFragment X (tensorFragment Y Z)).relabel + (tensorAssocCast s₁ t₁ s₂ t₂ s₃ t₃)) := + ((Fragment.Equiv.relabelCongr + (Fragment.relabelDisjUnionLeft (X.disjUnion Y) Z + (interleaveEquiv s₁ t₁ s₂ t₂)) + (interleaveEquiv (s₁ + s₂) (t₁ + t₂) s₃ t₃)).trans + ((Fragment.Equiv.relabelTrans + ((X.disjUnion Y).disjUnion Z) _ _).trans + ((Fragment.Equiv.relabelCongr + (Fragment.disjUnionAssoc X Y Z) + ((_root_.Equiv.sumCongr (interleaveEquiv s₁ t₁ s₂ t₂) + (_root_.Equiv.refl (Fin (s₃ + t₃)))).trans + (interleaveEquiv (s₁ + s₂) (t₁ + t₂) s₃ t₃))).trans + (Fragment.Equiv.relabelTrans + (X.disjUnion (Y.disjUnion Z)) _ _)))).trans + ((Fragment.Equiv.relabelEq _ + (assocLabel_eq s₁ t₁ s₂ t₂ s₃ t₃)).trans + (((Fragment.Equiv.relabelCongr + ((Fragment.Equiv.relabelCongr + (Fragment.relabelDisjUnionRight X (Y.disjUnion Z) + (interleaveEquiv s₂ t₂ s₃ t₃)) + (interleaveEquiv s₁ t₁ (s₂ + s₃) (t₂ + t₃))).trans + (Fragment.Equiv.relabelTrans + (X.disjUnion (Y.disjUnion Z)) _ _)) + (tensorAssocCast s₁ t₁ s₂ t₂ s₃ t₃)).trans + (Fragment.Equiv.relabelTrans + (X.disjUnion (Y.disjUnion Z)) _ _)).symm)) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorComm.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorComm.lean new file mode 100644 index 0000000000..652ee66ff1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorComm.lean @@ -0,0 +1,143 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorIdeal +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic + +/-! +# Tensor commutativity and the right-slot ideal + +The tensor of fragments commutes up to the block-swap relabel, +so the closure rows of `x ⊗ z` are closure rows of `z` — the +right-slot half of the monoidal ideal follows from the left-slot +machinery through the swap. +-/ + +@[expose] public section + +namespace RS + +/-- The block swap of interleaved boundaries. -/ +noncomputable def tensorSwapEquiv (s t u v : ℕ) : + Fin ((u + s) + (v + t)) ≃ Fin ((s + u) + (t + v)) := + (interleaveEquiv u v s t).symm.trans + ((_root_.Equiv.sumComm (Fin (u + v)) (Fin (s + t))).trans + (interleaveEquiv s t u v)) + +/-- **Tensor commutativity**: the tensor is the swapped tensor, +relabelled by the block swap. -/ +noncomputable def tensorFragmentComm {s t u v : ℕ} + (X : Fragment (Fin (s + t))) (z : Fragment (Fin (u + v))) : + (tensorFragment X z).Equiv + ((tensorFragment z X).relabel (tensorSwapEquiv s t u v)) := + (Fragment.Equiv.relabelCongr + (Fragment.disjUnionComm X z) (interleaveEquiv s t u v)).trans + ((Fragment.Equiv.relabelTrans (z.disjUnion X) + (_root_.Equiv.sumComm (Fin (u + v)) (Fin (s + t))) + (interleaveEquiv s t u v)).trans + ((Fragment.Equiv.relabelEq (z.disjUnion X) + (show (_root_.Equiv.sumComm (Fin (u + v)) + (Fin (s + t))).trans (interleaveEquiv s t u v) = + (interleaveEquiv u v s t).trans + (tensorSwapEquiv s t u v) from + _root_.Equiv.ext fun x => by + simp [tensorSwapEquiv])).trans + (Fragment.Equiv.relabelTrans (z.disjUnion X) + (interleaveEquiv u v s t) + (tensorSwapEquiv s t u v)).symm)) + +/-- The closure rows of a tensor are closure rows of the second +factor. -/ +theorem connectionPairing_tensor_right (f : ClosedFragment → ℂ) + (hf : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) + {s t u v : ℕ} (X : Fragment (Fin (s + t))) + (z : Fragment (Fin (u + v))) + (G : Fragment (Fin ((s + u) + (t + v)))) : + connectionPairing f ((s + u) + (t + v)) + (tensorFragment X z) G = + connectionPairing f (u + v) z + (partialClose X + (G.relabel (tensorSwapEquiv s t u v).symm)) := by + rw [show connectionPairing f ((s + u) + (t + v)) + (tensorFragment X z) G = + connectionPairing f ((s + u) + (t + v)) + ((tensorFragment z X).relabel + (tensorSwapEquiv s t u v)) G from + hf _ _ (pairCloseCongr (tensorFragmentComm X z) + (Fragment.Equiv.refl G))] + rw [show connectionPairing f ((s + u) + (t + v)) + ((tensorFragment z X).relabel + (tensorSwapEquiv s t u v)) G = + connectionPairing f ((u + s) + (v + t)) + (tensorFragment z X) + (G.relabel (tensorSwapEquiv s t u v).symm) from + hf _ _ (pairCloseRelabel (tensorSwapEquiv s t u v) + (tensorFragment z X) G)] + exact connectionPairing_tensor f hf z X + (G.relabel (tensorSwapEquiv s t u v).symm) + +/-- The connection row of a single-fragment tensor, linearized in +the second slot. -/ +theorem connectionMap_tensor_right_single + (f : ClosedFragment → ℂ) + (hf : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) + {s t u v : ℕ} (X : Fragment (Fin (s + t))) + (y : Fragment (Fin (u + v)) →₀ ℂ) + (K : Fragment (Fin ((s + u) + (t + v)))) : + connectionMap f ((s + u) + (t + v)) + (tensorFinsupp s t u v (Finsupp.single X 1) y) K = + connectionMap f (u + v) y + (partialClose X + (K.relabel (tensorSwapEquiv s t u v).symm)) := by + induction y using Finsupp.induction_linear with + | zero => + rw [map_zero, map_zero] + rfl + | add y z hy hz => + rw [map_add, map_add] + change connectionMap f ((s + u) + (t + v)) _ K + + connectionMap f ((s + u) + (t + v)) _ K = _ + rw [hy, hz, map_add] + rfl + | single z c => + rw [tensorFinsupp_single, one_mul, connectionMap_single, + connectionMap_single, + connectionPairing_tensor_right f hf] + +/-- **The right-slot monoidal ideal**: anything tensored with a +kernel element stays in the kernel. -/ +theorem tensorFinsupp_ker_right (f : ClosedFragment → ℂ) + (hf : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) + {s t u v : ℕ} (x : Fragment (Fin (s + t)) →₀ ℂ) + {y : Fragment (Fin (u + v)) →₀ ℂ} + (hy : y ∈ LinearMap.ker (connectionMap f (u + v))) : + tensorFinsupp s t u v x y ∈ + LinearMap.ker (connectionMap f ((s + u) + (t + v))) := by + induction x using Finsupp.induction_linear with + | zero => + rw [map_zero, LinearMap.zero_apply] + exact Submodule.zero_mem _ + | add x₁ x₂ h₁ h₂ => + rw [map_add, LinearMap.add_apply] + exact Submodule.add_mem _ h₁ h₂ + | single X c => + have h1 : tensorFinsupp s t u v (Finsupp.single X c) y = + c • tensorFinsupp s t u v (Finsupp.single X 1) y := by + rw [show (Finsupp.single X c : + Fragment (Fin (s + t)) →₀ ℂ) = + c • Finsupp.single X 1 by + rw [Finsupp.smul_single, smul_eq_mul, mul_one], + map_smul, LinearMap.smul_apply] + rw [h1] + refine Submodule.smul_mem _ c ?_ + rw [LinearMap.mem_ker] at hy ⊢ + funext K + rw [connectionMap_tensor_right_single f hf X y K, hy] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorCompClass.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorCompClass.lean new file mode 100644 index 0000000000..98e8c4ca7e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorCompClass.lean @@ -0,0 +1,210 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorInterchange +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTensor +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCategory + +/-! +# The interchange law on Hom classes + +Tensoring two composites is composing the two tensors, descended +to the Hom spaces: the fragment-level interchange at the singles, +extended by the four-fold bilinear induction. +-/ + +@[expose] public section + +namespace RS + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The interchange difference lies in the kernel. -/ +theorem mem_ker_interchange {s₁ t₁ u₁ s₂ t₂ u₂ : ℕ} + (x₁ : Fragment (Fin (s₁ + t₁)) →₀ ℂ) + (y₁ : Fragment (Fin (t₁ + u₁)) →₀ ℂ) + (x₂ : Fragment (Fin (s₂ + t₂)) →₀ ℂ) + (y₂ : Fragment (Fin (t₂ + u₂)) →₀ ℂ) : + tensorFinsupp s₁ u₁ s₂ u₂ + (composeFinsupp s₁ t₁ u₁ x₁ y₁) + (composeFinsupp s₂ t₂ u₂ x₂ y₂) - + composeFinsupp (s₁ + s₂) (t₁ + t₂) (u₁ + u₂) + (tensorFinsupp s₁ t₁ s₂ t₂ x₁ x₂) + (tensorFinsupp t₁ u₁ t₂ u₂ y₁ y₂) ∈ + LinearMap.ker (connectionMap f.val + ((s₁ + s₂) + (u₁ + u₂))) := by + -- ═══════ FOUR BILINEAR INDUCTIONS ═══════ + -- The difference is bilinear in each of the four arguments, so + -- the zero and add branches are formal and the content is at + -- four single fragments, where it is `tensorComposeInterchange`. + induction x₁ using Finsupp.induction_linear with + | zero => + simp only [map_zero, LinearMap.zero_apply, sub_zero] + exact Submodule.zero_mem _ + | add a b ha hb => + have he : tensorFinsupp s₁ u₁ s₂ u₂ + (composeFinsupp s₁ t₁ u₁ (a + b) y₁) + (composeFinsupp s₂ t₂ u₂ x₂ y₂) - + composeFinsupp (s₁ + s₂) (t₁ + t₂) (u₁ + u₂) + (tensorFinsupp s₁ t₁ s₂ t₂ (a + b) x₂) + (tensorFinsupp t₁ u₁ t₂ u₂ y₁ y₂) = + (tensorFinsupp s₁ u₁ s₂ u₂ + (composeFinsupp s₁ t₁ u₁ a y₁) + (composeFinsupp s₂ t₂ u₂ x₂ y₂) - + composeFinsupp (s₁ + s₂) (t₁ + t₂) (u₁ + u₂) + (tensorFinsupp s₁ t₁ s₂ t₂ a x₂) + (tensorFinsupp t₁ u₁ t₂ u₂ y₁ y₂)) + + (tensorFinsupp s₁ u₁ s₂ u₂ + (composeFinsupp s₁ t₁ u₁ b y₁) + (composeFinsupp s₂ t₂ u₂ x₂ y₂) - + composeFinsupp (s₁ + s₂) (t₁ + t₂) (u₁ + u₂) + (tensorFinsupp s₁ t₁ s₂ t₂ b x₂) + (tensorFinsupp t₁ u₁ t₂ u₂ y₁ y₂)) := by + simp only [map_add, LinearMap.add_apply] + abel + rw [he] + exact Submodule.add_mem _ ha hb + | single F₁ c₁ => + induction y₁ using Finsupp.induction_linear with + | zero => + simp only [map_zero, LinearMap.zero_apply, sub_zero] + exact Submodule.zero_mem _ + | add a b ha hb => + have he : tensorFinsupp s₁ u₁ s₂ u₂ + (composeFinsupp s₁ t₁ u₁ (Finsupp.single F₁ c₁) + (a + b)) + (composeFinsupp s₂ t₂ u₂ x₂ y₂) - + composeFinsupp (s₁ + s₂) (t₁ + t₂) (u₁ + u₂) + (tensorFinsupp s₁ t₁ s₂ t₂ + (Finsupp.single F₁ c₁) x₂) + (tensorFinsupp t₁ u₁ t₂ u₂ (a + b) y₂) = + (tensorFinsupp s₁ u₁ s₂ u₂ + (composeFinsupp s₁ t₁ u₁ (Finsupp.single F₁ c₁) a) + (composeFinsupp s₂ t₂ u₂ x₂ y₂) - + composeFinsupp (s₁ + s₂) (t₁ + t₂) (u₁ + u₂) + (tensorFinsupp s₁ t₁ s₂ t₂ + (Finsupp.single F₁ c₁) x₂) + (tensorFinsupp t₁ u₁ t₂ u₂ a y₂)) + + (tensorFinsupp s₁ u₁ s₂ u₂ + (composeFinsupp s₁ t₁ u₁ (Finsupp.single F₁ c₁) b) + (composeFinsupp s₂ t₂ u₂ x₂ y₂) - + composeFinsupp (s₁ + s₂) (t₁ + t₂) (u₁ + u₂) + (tensorFinsupp s₁ t₁ s₂ t₂ + (Finsupp.single F₁ c₁) x₂) + (tensorFinsupp t₁ u₁ t₂ u₂ b y₂)) := by + simp only [map_add, LinearMap.add_apply] + abel + rw [he] + exact Submodule.add_mem _ ha hb + | single G₁ c₁' => + induction x₂ using Finsupp.induction_linear with + | zero => + simp only [map_zero, LinearMap.zero_apply, sub_zero] + exact Submodule.zero_mem _ + | add a b ha hb => + have he : tensorFinsupp s₁ u₁ s₂ u₂ + (composeFinsupp s₁ t₁ u₁ (Finsupp.single F₁ c₁) + (Finsupp.single G₁ c₁')) + (composeFinsupp s₂ t₂ u₂ (a + b) y₂) - + composeFinsupp (s₁ + s₂) (t₁ + t₂) (u₁ + u₂) + (tensorFinsupp s₁ t₁ s₂ t₂ + (Finsupp.single F₁ c₁) (a + b)) + (tensorFinsupp t₁ u₁ t₂ u₂ + (Finsupp.single G₁ c₁') y₂) = + (tensorFinsupp s₁ u₁ s₂ u₂ + (composeFinsupp s₁ t₁ u₁ (Finsupp.single F₁ c₁) + (Finsupp.single G₁ c₁')) + (composeFinsupp s₂ t₂ u₂ a y₂) - + composeFinsupp (s₁ + s₂) (t₁ + t₂) (u₁ + u₂) + (tensorFinsupp s₁ t₁ s₂ t₂ + (Finsupp.single F₁ c₁) a) + (tensorFinsupp t₁ u₁ t₂ u₂ + (Finsupp.single G₁ c₁') y₂)) + + (tensorFinsupp s₁ u₁ s₂ u₂ + (composeFinsupp s₁ t₁ u₁ (Finsupp.single F₁ c₁) + (Finsupp.single G₁ c₁')) + (composeFinsupp s₂ t₂ u₂ b y₂) - + composeFinsupp (s₁ + s₂) (t₁ + t₂) (u₁ + u₂) + (tensorFinsupp s₁ t₁ s₂ t₂ + (Finsupp.single F₁ c₁) b) + (tensorFinsupp t₁ u₁ t₂ u₂ + (Finsupp.single G₁ c₁') y₂)) := by + simp only [map_add, LinearMap.add_apply] + abel + rw [he] + exact Submodule.add_mem _ ha hb + | single F₂ c₂ => + induction y₂ using Finsupp.induction_linear with + | zero => + simp only [map_zero, sub_zero] + exact Submodule.zero_mem _ + | add a b ha hb => + have he : tensorFinsupp s₁ u₁ s₂ u₂ + (composeFinsupp s₁ t₁ u₁ (Finsupp.single F₁ c₁) + (Finsupp.single G₁ c₁')) + (composeFinsupp s₂ t₂ u₂ (Finsupp.single F₂ c₂) + (a + b)) - + composeFinsupp (s₁ + s₂) (t₁ + t₂) (u₁ + u₂) + (tensorFinsupp s₁ t₁ s₂ t₂ + (Finsupp.single F₁ c₁) (Finsupp.single F₂ c₂)) + (tensorFinsupp t₁ u₁ t₂ u₂ + (Finsupp.single G₁ c₁') (a + b)) = + (tensorFinsupp s₁ u₁ s₂ u₂ + (composeFinsupp s₁ t₁ u₁ (Finsupp.single F₁ c₁) + (Finsupp.single G₁ c₁')) + (composeFinsupp s₂ t₂ u₂ + (Finsupp.single F₂ c₂) a) - + composeFinsupp (s₁ + s₂) (t₁ + t₂) (u₁ + u₂) + (tensorFinsupp s₁ t₁ s₂ t₂ + (Finsupp.single F₁ c₁) + (Finsupp.single F₂ c₂)) + (tensorFinsupp t₁ u₁ t₂ u₂ + (Finsupp.single G₁ c₁') a)) + + (tensorFinsupp s₁ u₁ s₂ u₂ + (composeFinsupp s₁ t₁ u₁ (Finsupp.single F₁ c₁) + (Finsupp.single G₁ c₁')) + (composeFinsupp s₂ t₂ u₂ + (Finsupp.single F₂ c₂) b) - + composeFinsupp (s₁ + s₂) (t₁ + t₂) (u₁ + u₂) + (tensorFinsupp s₁ t₁ s₂ t₂ + (Finsupp.single F₁ c₁) + (Finsupp.single F₂ c₂)) + (tensorFinsupp t₁ u₁ t₂ u₂ + (Finsupp.single G₁ c₁') b)) := by + simp only [map_add] + abel + rw [he] + exact Submodule.add_mem _ ha hb + | single G₂ c₂' => + rw [composeFinsupp_single, composeFinsupp_single, + tensorFinsupp_single, tensorFinsupp_single, + tensorFinsupp_single, composeFinsupp_single, + show (c₁ * c₂) * (c₁' * c₂') = + (c₁ * c₁') * (c₂ * c₂') from by ring] + exact mem_ker_single_sub_of_equiv_smul f + (Fragment.tensorComposeInterchange F₁ G₁ F₂ G₂) + ((c₁ * c₁') * (c₂ * c₂')) + +/-- **The interchange law on Hom classes.** -/ +theorem HomSpace.tensor_comp {s₁ t₁ u₁ s₂ t₂ u₂ : ℕ} + (p₁ : HomSpace f.val (s₁ + t₁)) (q₁ : HomSpace f.val (t₁ + u₁)) + (p₂ : HomSpace f.val (s₂ + t₂)) (q₂ : HomSpace f.val (t₂ + u₂)) : + HomSpace.tensor f s₁ u₁ s₂ u₂ + (HomSpace.comp f s₁ t₁ u₁ p₁ q₁) + (HomSpace.comp f s₂ t₂ u₂ p₂ q₂) = + HomSpace.comp f (s₁ + s₂) (t₁ + t₂) (u₁ + u₂) + (HomSpace.tensor f s₁ t₁ s₂ t₂ p₁ p₂) + (HomSpace.tensor f t₁ u₁ t₂ u₂ q₁ q₂) := by + obtain ⟨x₁, rfl⟩ := Submodule.Quotient.mk_surjective _ p₁ + obtain ⟨y₁, rfl⟩ := Submodule.Quotient.mk_surjective _ q₁ + obtain ⟨x₂, rfl⟩ := Submodule.Quotient.mk_surjective _ p₂ + obtain ⟨y₂, rfl⟩ := Submodule.Quotient.mk_surjective _ q₂ + exact (Submodule.Quotient.eq _).mpr + (mem_ker_interchange f x₁ y₁ x₂ y₂) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorFragment.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorFragment.lean new file mode 100644 index 0000000000..2c4203eb16 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorFragment.lean @@ -0,0 +1,121 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv + +/-! +# The tensor product of fragments + +The monoidal product of the skein category on representatives: +the tensor of an `(s, t)`-fragment and a `(u, v)`-fragment is +their disjoint union with interleaved boundary — the two low +blocks side by side, then the two high blocks +(`interleaveEquiv`). The four value lemmas locate each block of +the interleaving, and `tensorFragmentCongr` shows the tensor +respects fragment equivalence in both slots. +-/ + +@[expose] public section + +namespace RS + +/-- The interleaving of two `(low, high)` boundaries: low block +of the first, low block of the second, high block of the first, +high block of the second. -/ +def interleaveEquiv (s t u v : ℕ) : + (Fin (s + t) ⊕ Fin (u + v)) ≃ Fin ((s + u) + (t + v)) := + ((_root_.Equiv.sumCongr finSumFinEquiv.symm + finSumFinEquiv.symm).trans + ((_root_.Equiv.sumSumSumComm (Fin s) (Fin t) + (Fin u) (Fin v)).trans + (_root_.Equiv.sumCongr finSumFinEquiv + finSumFinEquiv))).trans + finSumFinEquiv + +/-- The low block of the first factor sits first. -/ +theorem interleaveEquiv_inl_low (s t u v : ℕ) (i : Fin s) : + interleaveEquiv s t u v (Sum.inl (Fin.castAdd t i)) = + Fin.castAdd (t + v) (Fin.castAdd u i) := by + unfold interleaveEquiv + simp [_root_.Equiv.sumSumSumComm, + finSumFinEquiv_symm_apply_castAdd] + +/-- The low block of the second factor sits second. -/ +theorem interleaveEquiv_inr_low (s t u v : ℕ) (j : Fin u) : + interleaveEquiv s t u v (Sum.inr (Fin.castAdd v j)) = + Fin.castAdd (t + v) (Fin.natAdd s j) := by + unfold interleaveEquiv + simp [_root_.Equiv.sumSumSumComm, + finSumFinEquiv_symm_apply_castAdd] + +/-- The high block of the first factor sits third. -/ +theorem interleaveEquiv_inl_high (s t u v : ℕ) (k : Fin t) : + interleaveEquiv s t u v (Sum.inl (Fin.natAdd s k)) = + Fin.natAdd (s + u) (Fin.castAdd v k) := by + unfold interleaveEquiv + simp [_root_.Equiv.sumSumSumComm, + finSumFinEquiv_symm_apply_natAdd] + +/-- The high block of the second factor sits last. -/ +theorem interleaveEquiv_inr_high (s t u v : ℕ) (l : Fin v) : + interleaveEquiv s t u v (Sum.inr (Fin.natAdd u l)) = + Fin.natAdd (s + u) (Fin.natAdd t l) := by + unfold interleaveEquiv + simp [_root_.Equiv.sumSumSumComm, + finSumFinEquiv_symm_apply_natAdd] + +/-- The inverse interleaving on the first block. -/ +theorem interleaveEquiv_symm_low_left (s t u v : ℕ) (i : Fin s) : + (interleaveEquiv s t u v).symm + (Fin.castAdd (t + v) (Fin.castAdd u i)) = + Sum.inl (Fin.castAdd t i) := + (_root_.Equiv.symm_apply_eq _).mpr + (interleaveEquiv_inl_low s t u v i).symm + +/-- The inverse interleaving on the second block. -/ +theorem interleaveEquiv_symm_low_right (s t u v : ℕ) (j : Fin u) : + (interleaveEquiv s t u v).symm + (Fin.castAdd (t + v) (Fin.natAdd s j)) = + Sum.inr (Fin.castAdd v j) := + (_root_.Equiv.symm_apply_eq _).mpr + (interleaveEquiv_inr_low s t u v j).symm + +/-- The inverse interleaving on the third block. -/ +theorem interleaveEquiv_symm_high_left (s t u v : ℕ) (k : Fin t) : + (interleaveEquiv s t u v).symm + (Fin.natAdd (s + u) (Fin.castAdd v k)) = + Sum.inl (Fin.natAdd s k) := + (_root_.Equiv.symm_apply_eq _).mpr + (interleaveEquiv_inl_high s t u v k).symm + +/-- The inverse interleaving on the last block. -/ +theorem interleaveEquiv_symm_high_right (s t u v : ℕ) (l : Fin v) : + (interleaveEquiv s t u v).symm + (Fin.natAdd (s + u) (Fin.natAdd t l)) = + Sum.inr (Fin.natAdd u l) := + (_root_.Equiv.symm_apply_eq _).mpr + (interleaveEquiv_inr_high s t u v l).symm + +/-- The tensor product of fragments: disjoint union with +interleaved boundary. -/ +noncomputable def tensorFragment {s t u v : ℕ} + (x : Fragment (Fin (s + t))) (z : Fragment (Fin (u + v))) : + Fragment (Fin ((s + u) + (t + v))) := + (x.disjUnion z).relabel (interleaveEquiv s t u v) + +/-- The tensor respects fragment equivalence in both slots. -/ +noncomputable def tensorFragmentCongr {s t u v : ℕ} + {x₁ x₂ : Fragment (Fin (s + t))} + {z₁ z₂ : Fragment (Fin (u + v))} + (hx : x₁.Equiv x₂) (hz : z₁.Equiv z₂) : + (tensorFragment x₁ z₁).Equiv (tensorFragment x₂ z₂) := + Fragment.Equiv.relabelCongr + (Fragment.Equiv.disjUnionCongr hx hz) + (interleaveEquiv s t u v) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorIdeal.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorIdeal.lean new file mode 100644 index 0000000000..4552cc5142 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorIdeal.lean @@ -0,0 +1,1135 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialClose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal + +/-! +# The absorption of a tensor factor into the test fragment + +The accompanying paper's Lemma 3.3(b), the geometric core: closing +a tensor +`x ⊗ z` against a test fragment `G` is closing `x` against the +partial closure `G_z = partialClose z G`. Both sides normalize +to iterated gluing over the common ambient `(x ⊔ z) ⊔ G`: the +closure pairs split into the `z`-blocks and the `x`-blocks, the +`z`-blocks glue first (`glueListAppend`), localize to `z ⊔ G` +(`disjUnionAssoc` + `glueListDisjUnionRight`), and what +remains is the closure of `x` against the survivors — the +defining gluing of `partialClose`. +-/ + +@[expose] public section + +namespace RS + +/-! ### The four closure blocks over the common ambient -/ + +/-- The `v`-block: `z`'s high labels against the last block of +`G`. -/ +def zvBlock (s t u v : ℕ) : + List (((Fin (s + t) ⊕ Fin (u + v)) ⊕ Fin ((s + u) + (t + v))) × + ((Fin (s + t) ⊕ Fin (u + v)) ⊕ Fin ((s + u) + (t + v)))) := + (List.finRange v).reverse.map (fun l => + (Sum.inl (Sum.inr ⟨u + l.val, by have := l.isLt; omega⟩), + Sum.inr ⟨(s + u) + (t + l.val), by have := l.isLt; omega⟩)) + +/-- The `t`-block: `x`'s high labels against the third block of +`G`. -/ +def xtBlock (s t u v : ℕ) : + List (((Fin (s + t) ⊕ Fin (u + v)) ⊕ Fin ((s + u) + (t + v))) × + ((Fin (s + t) ⊕ Fin (u + v)) ⊕ Fin ((s + u) + (t + v)))) := + (List.finRange t).reverse.map (fun k => + (Sum.inl (Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩), + Sum.inr ⟨(s + u) + k.val, by have := k.isLt; omega⟩)) + +/-- The `u`-block: `z`'s low labels against the second block of +`G`. -/ +def zuBlock (s t u v : ℕ) : + List (((Fin (s + t) ⊕ Fin (u + v)) ⊕ Fin ((s + u) + (t + v))) × + ((Fin (s + t) ⊕ Fin (u + v)) ⊕ Fin ((s + u) + (t + v)))) := + (List.finRange u).reverse.map (fun j => + (Sum.inl (Sum.inr ⟨j.val, by have := j.isLt; omega⟩), + Sum.inr ⟨s + j.val, by have := j.isLt; omega⟩)) + +/-- The `s`-block: `x`'s low labels against the first block of +`G`. -/ +def xsBlock (s t u v : ℕ) : + List (((Fin (s + t) ⊕ Fin (u + v)) ⊕ Fin ((s + u) + (t + v))) × + ((Fin (s + t) ⊕ Fin (u + v)) ⊕ Fin ((s + u) + (t + v)))) := + (List.finRange s).reverse.map (fun i => + (Sum.inl (Sum.inl ⟨i.val, by have := i.isLt; omega⟩), + Sum.inr ⟨i.val, by have := i.isLt; omega⟩)) + +/-! ### The four-way split of the closure interface -/ + +/-- The high closure half splits at `t`. -/ +theorem ipHigh_split (s t u v : ℕ) : + ipHigh (s + u) (t + v) = + (List.finRange v).reverse.map (fun l => + ((Sum.inl ⟨(s + u) + (t + l.val), + by have := l.isLt; omega⟩ : + Fin (0 + ((s + u) + (t + v))) ⊕ + Fin ((s + u) + (t + v) + 0)), + Sum.inr ⟨(s + u) + (t + l.val), + by have := l.isLt; omega⟩)) ++ + (List.finRange t).reverse.map (fun k => + (Sum.inl ⟨(s + u) + k.val, by have := k.isLt; omega⟩, + Sum.inr ⟨(s + u) + k.val, by have := k.isLt; omega⟩)) := by + unfold ipHigh + rw [List.map_reverse, List.map_reverse, List.map_reverse, + ← List.reverse_append] + refine congrArg List.reverse ?_ + rw [← List.ofFn_eq_map, List.ofFn_add, List.ofFn_eq_map, + List.ofFn_eq_map] + refine congrArg₂ (· ++ ·) + (List.map_congr_left fun k _ => ?_) + (List.map_congr_left fun l _ => ?_) + · refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) + (congrArg Sum.inr (Fin.ext ?_)) <;> rfl + · refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) + (congrArg Sum.inr (Fin.ext ?_)) <;> + · change (s + u) + (t + l.val) = (s + u) + (t + l.val) + rfl + +/-- The low closure half splits at `s`. -/ +theorem ipLow_split (s t u v : ℕ) : + ipLow (s + u) (t + v) = + (List.finRange u).reverse.map (fun j => + ((Sum.inl ⟨s + j.val, by have := j.isLt; omega⟩ : + Fin (0 + ((s + u) + (t + v))) ⊕ + Fin ((s + u) + (t + v) + 0)), + Sum.inr ⟨s + j.val, by have := j.isLt; omega⟩)) ++ + (List.finRange s).reverse.map (fun i => + (Sum.inl ⟨i.val, by have := i.isLt; omega⟩, + Sum.inr ⟨i.val, by have := i.isLt; omega⟩)) := by + unfold ipLow + rw [List.map_reverse, List.map_reverse, List.map_reverse, + ← List.reverse_append] + refine congrArg List.reverse ?_ + rw [← List.ofFn_eq_map, List.ofFn_add, List.ofFn_eq_map, + List.ofFn_eq_map] + refine congrArg₂ (· ++ ·) + (List.map_congr_left fun i _ => ?_) + (List.map_congr_left fun j _ => ?_) + · refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) + (congrArg Sum.inr (Fin.ext ?_)) <;> rfl + · refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) + (congrArg Sum.inr (Fin.ext ?_)) <;> rfl + +/-! ### The transported closure label -/ + +/-- The label equivalence of the left side: interleave the +tensor factors, then the closure casts. -/ +noncomputable def tensorCloseLabel (s t u v : ℕ) : + ((Fin (s + t) ⊕ Fin (u + v)) ⊕ Fin ((s + u) + (t + v))) ≃ + (Fin (0 + ((s + u) + (t + v))) ⊕ + Fin ((s + u) + (t + v) + 0)) := + _root_.Equiv.sumCongr + ((interleaveEquiv s t u v).trans + (finCongr (by omega : + (s + u) + (t + v) = 0 + ((s + u) + (t + v))))) + (finCongr (by omega : + (s + u) + (t + v) = (s + u) + (t + v) + 0)) + +/-! ### The ground computation: transported pairs blockwise -/ + +private theorem tensor_ground_zv_aux (s t u v : ℕ) : + ∀ (l : List (Fin v)), + Fragment.mapPairs (tensorCloseLabel s t u v).symm + (l.map (fun l' => + ((Sum.inl ⟨(s + u) + (t + l'.val), + by have := l'.isLt; omega⟩ : + Fin (0 + ((s + u) + (t + v))) ⊕ + Fin ((s + u) + (t + v) + 0)), + Sum.inr ⟨(s + u) + (t + l'.val), + by have := l'.isLt; omega⟩))) = + l.map (fun l' => + (Sum.inl (Sum.inr ⟨u + l'.val, by have := l'.isLt; omega⟩), + Sum.inr ⟨(s + u) + (t + l'.val), + by have := l'.isLt; omega⟩)) + | [] => rfl + | l' :: l => by + simp only [List.map_cons, Fragment.mapPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext ?_ ?_) + (tensor_ground_zv_aux s t u v l) + · change Sum.inl ((interleaveEquiv s t u v).symm + ⟨(s + u) + (t + l'.val), by have := l'.isLt; omega⟩) = _ + refine congrArg Sum.inl ?_ + rw [show (⟨(s + u) + (t + l'.val), + by have := l'.isLt; omega⟩ : + Fin ((s + u) + (t + v))) = + Fin.natAdd (s + u) (Fin.natAdd t l') from Fin.ext rfl, + interleaveEquiv_symm_high_right] + exact congrArg Sum.inr (Fin.ext rfl) + · change Sum.inr (⟨(s + u) + (t + l'.val), + by have := l'.isLt; omega⟩ : + Fin ((s + u) + (t + v))) = _ + rfl + +private theorem tensor_ground_xt_aux (s t u v : ℕ) : + ∀ (l : List (Fin t)), + Fragment.mapPairs (tensorCloseLabel s t u v).symm + (l.map (fun k => + ((Sum.inl ⟨(s + u) + k.val, + by have := k.isLt; omega⟩ : + Fin (0 + ((s + u) + (t + v))) ⊕ + Fin ((s + u) + (t + v) + 0)), + Sum.inr ⟨(s + u) + k.val, + by have := k.isLt; omega⟩))) = + l.map (fun k => + (Sum.inl (Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩), + Sum.inr ⟨(s + u) + k.val, by have := k.isLt; omega⟩)) + | [] => rfl + | k :: l => by + simp only [List.map_cons, Fragment.mapPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext ?_ ?_) + (tensor_ground_xt_aux s t u v l) + · change Sum.inl ((interleaveEquiv s t u v).symm + ⟨(s + u) + k.val, by have := k.isLt; omega⟩) = _ + refine congrArg Sum.inl ?_ + rw [show (⟨(s + u) + k.val, by have := k.isLt; omega⟩ : + Fin ((s + u) + (t + v))) = + Fin.natAdd (s + u) (Fin.castAdd v k) from Fin.ext rfl, + interleaveEquiv_symm_high_left] + exact congrArg Sum.inl (Fin.ext rfl) + · change Sum.inr (⟨(s + u) + k.val, by have := k.isLt; omega⟩ : + Fin ((s + u) + (t + v))) = _ + rfl + +private theorem tensor_ground_zu_aux (s t u v : ℕ) : + ∀ (l : List (Fin u)), + Fragment.mapPairs (tensorCloseLabel s t u v).symm + (l.map (fun j => + ((Sum.inl ⟨s + j.val, by have := j.isLt; omega⟩ : + Fin (0 + ((s + u) + (t + v))) ⊕ + Fin ((s + u) + (t + v) + 0)), + Sum.inr ⟨s + j.val, by have := j.isLt; omega⟩))) = + l.map (fun j => + (Sum.inl (Sum.inr ⟨j.val, by have := j.isLt; omega⟩), + Sum.inr ⟨s + j.val, by have := j.isLt; omega⟩)) + | [] => rfl + | j :: l => by + simp only [List.map_cons, Fragment.mapPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext ?_ ?_) + (tensor_ground_zu_aux s t u v l) + · change Sum.inl ((interleaveEquiv s t u v).symm + ⟨s + j.val, by have := j.isLt; omega⟩) = _ + refine congrArg Sum.inl ?_ + rw [show (⟨s + j.val, by have := j.isLt; omega⟩ : + Fin ((s + u) + (t + v))) = + Fin.castAdd (t + v) (Fin.natAdd s j) from Fin.ext rfl, + interleaveEquiv_symm_low_right] + exact congrArg Sum.inr (Fin.ext rfl) + · change Sum.inr (⟨s + j.val, by have := j.isLt; omega⟩ : + Fin ((s + u) + (t + v))) = _ + rfl + +private theorem tensor_ground_xs_aux (s t u v : ℕ) : + ∀ (l : List (Fin s)), + Fragment.mapPairs (tensorCloseLabel s t u v).symm + (l.map (fun i => + ((Sum.inl ⟨i.val, by have := i.isLt; omega⟩ : + Fin (0 + ((s + u) + (t + v))) ⊕ + Fin ((s + u) + (t + v) + 0)), + Sum.inr ⟨i.val, by have := i.isLt; omega⟩))) = + l.map (fun i => + (Sum.inl (Sum.inl ⟨i.val, by have := i.isLt; omega⟩), + Sum.inr ⟨i.val, by have := i.isLt; omega⟩)) + | [] => rfl + | i :: l => by + simp only [List.map_cons, Fragment.mapPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext ?_ ?_) + (tensor_ground_xs_aux s t u v l) + · change Sum.inl ((interleaveEquiv s t u v).symm + ⟨i.val, by have := i.isLt; omega⟩) = _ + refine congrArg Sum.inl ?_ + rw [show (⟨i.val, by have := i.isLt; omega⟩ : + Fin ((s + u) + (t + v))) = + Fin.castAdd (t + v) (Fin.castAdd u i) from Fin.ext rfl, + interleaveEquiv_symm_low_left] + exact congrArg Sum.inl (Fin.ext rfl) + · change Sum.inr (⟨i.val, by have := i.isLt; omega⟩ : + Fin ((s + u) + (t + v))) = _ + rfl + +/-- The transported closure pairs of the tensor side: the four +blocks, in ground order. -/ +theorem tensor_ground_pairs (s t u v : ℕ) : + Fragment.mapPairs (tensorCloseLabel s t u v).symm + (interfacePairs 0 ((s + u) + (t + v)) 0) = + (zvBlock s t u v ++ xtBlock s t u v) ++ + (zuBlock s t u v ++ xsBlock s t u v) := by + rw [interfacePairs_closure_split (s + u) (t + v), + mapPairs_append, ipHigh_split, ipLow_split, + mapPairs_append, mapPairs_append] + unfold zvBlock xtBlock zuBlock xsBlock + rw [tensor_ground_zv_aux, tensor_ground_xt_aux, + tensor_ground_zu_aux, tensor_ground_xs_aux] + +/-- Exchanging the middle blocks of a double append. -/ +theorem perm_append_exchange {α : Type} (A B C D : List α) : + ((A ++ B) ++ (C ++ D)).Perm ((A ++ C) ++ (B ++ D)) := by + have h1 : (A ++ B) ++ (C ++ D) = A ++ (B ++ (C ++ D)) := by + simp [List.append_assoc] + have h2 : (A ++ C) ++ (B ++ D) = A ++ (C ++ (B ++ D)) := by + simp [List.append_assoc] + rw [h1, h2] + refine List.Perm.append_left A ?_ + have h3 : B ++ (C ++ D) = (B ++ C) ++ D := + (List.append_assoc B C D).symm + have h4 : C ++ (B ++ D) = (C ++ B) ++ D := + (List.append_assoc C B D).symm + rw [h3, h4] + exact List.perm_append_comm.append_right D + +/-- The tensor-side closure pairs, reordered: `z`-blocks first. -/ +theorem tensor_pairs_perm (s t u v : ℕ) : + (Fragment.mapPairs (tensorCloseLabel s t u v).symm + (interfacePairs 0 ((s + u) + (t + v)) 0)).Perm + ((zvBlock s t u v ++ zuBlock s t u v) ++ + (xtBlock s t u v ++ xsBlock s t u v)) := by + rw [tensor_ground_pairs] + exact perm_append_exchange _ _ _ _ + +/-- The reordered tensor-side pairs are well-formed. -/ +theorem tensorPairsL_wf (s t u v : ℕ) : + Fragment.PairsWF + ((zvBlock s t u v ++ zuBlock s t u v) ++ + (xtBlock s t u v ++ xsBlock s t u v)) := + (Fragment.mapPairs_wf (tensorCloseLabel s t u v).symm _ + (interfacePairs_wf 0 ((s + u) + (t + v)) 0)).perm + (tensor_pairs_perm s t u v) + +/-! ### The associated ambient: pairs localize -/ + +/-- The cross pairs: `x`'s labels against the surviving `x`-block +labels of `G`, inside the associated ambient. -/ +def xCrossPairs (s t u v : ℕ) : + List ((Fin (s + t) ⊕ (Fin (u + v) ⊕ Fin ((s + u) + (t + v)))) × + (Fin (s + t) ⊕ (Fin (u + v) ⊕ Fin ((s + u) + (t + v))))) := + (List.finRange t).reverse.map (fun k => + (Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩, + Sum.inr (Sum.inr ⟨(s + u) + k.val, + by have := k.isLt; omega⟩))) ++ + (List.finRange s).reverse.map (fun i => + (Sum.inl ⟨i.val, by have := i.isLt; omega⟩, + Sum.inr (Sum.inr ⟨i.val, by have := i.isLt; omega⟩))) + +/-- Under the sum association, the reordered tensor pairs are the +embedded `z`-gluing pairs followed by the cross pairs. -/ +theorem tensor_pairs_assoc (s t u v : ℕ) : + Fragment.mapPairs + (_root_.Equiv.sumAssoc (Fin (s + t)) (Fin (u + v)) + (Fin ((s + u) + (t + v)))) + ((zvBlock s t u v ++ zuBlock s t u v) ++ + (xtBlock s t u v ++ xsBlock s t u v)) = + Fragment.inrPairs (zClosePairs s t u v) ++ + xCrossPairs s t u v := by + unfold Fragment.mapPairs zvBlock zuBlock xtBlock xsBlock + zClosePairs Fragment.inrPairs xCrossPairs + simp only [List.map_append, List.map_map] + rfl + +/-- The associated pair list is well-formed. -/ +theorem tensorPairsA_wf (s t u v : ℕ) : + Fragment.PairsWF + (Fragment.inrPairs (zClosePairs s t u v) ++ + xCrossPairs s t u v) := + (tensor_pairs_assoc s t u v) ▸ + Fragment.mapPairs_wf + (_root_.Equiv.sumAssoc (Fin (s + t)) (Fin (u + v)) + (Fin ((s + u) + (t + v)))) _ (tensorPairsL_wf s t u v) + +/-! ### The lifted cross pairs -/ + +/-- A high `x`-block label of `G` survives the `z`-gluing. -/ +theorem xtSurv (s t u v : ℕ) (k : Fin t) : + ∀ p ∈ zClosePairs s t u v, + (Sum.inr ⟨(s + u) + k.val, by have := k.isLt; omega⟩ : + Fin (u + v) ⊕ Fin ((s + u) + (t + v))) ≠ p.1 ∧ + (Sum.inr ⟨(s + u) + k.val, by have := k.isLt; omega⟩ : + Fin (u + v) ⊕ Fin ((s + u) + (t + v))) ≠ p.2 := + (forall_ne_iff_not_mem_flat _ _).mpr + ((pcSurv_iff s t u v _).mpr + (Or.inr ⟨by change (s + u) ≤ (s + u) + k.val; omega, + by change (s + u) + k.val < (s + u) + t + have := k.isLt; omega⟩)) + +/-- A low `x`-block label of `G` survives the `z`-gluing. -/ +theorem xsSurv (s t u v : ℕ) (i : Fin s) : + ∀ p ∈ zClosePairs s t u v, + (Sum.inr ⟨i.val, by have := i.isLt; omega⟩ : + Fin (u + v) ⊕ Fin ((s + u) + (t + v))) ≠ p.1 ∧ + (Sum.inr ⟨i.val, by have := i.isLt; omega⟩ : + Fin (u + v) ⊕ Fin ((s + u) + (t + v))) ≠ p.2 := + (forall_ne_iff_not_mem_flat _ _).mpr + ((pcSurv_iff s t u v _).mpr + (Or.inl (show i.val < s from i.isLt))) + +/-- The canonical cross pairs after the `z`-gluing: `x`'s labels +against the surviving `x`-block labels of `G`. -/ +noncomputable def xLiftedPairs (s t u v : ℕ) : + List ((Fin (s + t) ⊕ + Fragment.FoldSurviving + (Fin (u + v) ⊕ Fin ((s + u) + (t + v))) + (zClosePairs s t u v)) × + (Fin (s + t) ⊕ + Fragment.FoldSurviving + (Fin (u + v) ⊕ Fin ((s + u) + (t + v))) + (zClosePairs s t u v))) := + (List.finRange t).reverse.map (fun k => + (Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩, + Sum.inr ⟨Sum.inr ⟨(s + u) + k.val, by have := k.isLt; omega⟩, + xtSurv s t u v k⟩)) ++ + (List.finRange s).reverse.map (fun i => + (Sum.inl ⟨i.val, by have := i.isLt; omega⟩, + Sum.inr ⟨Sum.inr ⟨i.val, by have := i.isLt; omega⟩, + xsSurv s t u v i⟩)) + +private theorem lift_pull_xt_aux (s t u v : ℕ) : + ∀ (l : List (Fin t)) + (h : Fragment.PairsSepAll + (Fragment.inrPairs (zClosePairs s t u v)) + (l.map (fun k => + ((Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩ : + Fin (s + t) ⊕ + (Fin (u + v) ⊕ Fin ((s + u) + (t + v)))), + Sum.inr (Sum.inr ⟨(s + u) + k.val, + by have := k.isLt; omega⟩))))), + Fragment.mapPairs + (Fragment.inrFoldEquiv (α := Fin (s + t)) + (zClosePairs s t u v)) + (Fragment.liftPairs _ _ h) = + l.map (fun k => + (Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩, + Sum.inr ⟨Sum.inr ⟨(s + u) + k.val, + by have := k.isLt; omega⟩, xtSurv s t u v k⟩)) + | [], _ => rfl + | k :: l, h => by + simp only [List.map_cons, Fragment.liftPairs, + Fragment.mapPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext rfl ?_) + (lift_pull_xt_aux s t u v l _) + exact congrArg Sum.inr (Subtype.ext rfl) + +private theorem lift_pull_xs_aux (s t u v : ℕ) : + ∀ (l : List (Fin s)) + (h : Fragment.PairsSepAll + (Fragment.inrPairs (zClosePairs s t u v)) + (l.map (fun i => + ((Sum.inl ⟨i.val, by have := i.isLt; omega⟩ : + Fin (s + t) ⊕ + (Fin (u + v) ⊕ Fin ((s + u) + (t + v)))), + Sum.inr (Sum.inr ⟨i.val, by have := i.isLt; omega⟩))))), + Fragment.mapPairs + (Fragment.inrFoldEquiv (α := Fin (s + t)) + (zClosePairs s t u v)) + (Fragment.liftPairs _ _ h) = + l.map (fun i => + (Sum.inl ⟨i.val, by have := i.isLt; omega⟩, + Sum.inr ⟨Sum.inr ⟨i.val, by have := i.isLt; omega⟩, + xsSurv s t u v i⟩)) + | [], _ => rfl + | i :: l, h => by + simp only [List.map_cons, Fragment.liftPairs, + Fragment.mapPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext rfl ?_) + (lift_pull_xs_aux s t u v l _) + exact congrArg Sum.inr (Subtype.ext rfl) + +/-- Pulling the lifted cross pairs through the right-embedding +survivor equivalence gives the canonical cross pairs. -/ +theorem lift_pull (s t u v : ℕ) + (h : Fragment.PairsSepAll + (Fragment.inrPairs (zClosePairs s t u v)) + (xCrossPairs s t u v)) : + Fragment.mapPairs + (Fragment.inrFoldEquiv (α := Fin (s + t)) + (zClosePairs s t u v)) + (Fragment.liftPairs _ _ h) = + xLiftedPairs s t u v := by + unfold xCrossPairs at h ⊢ + rw [liftPairs_append, mapPairs_append] + unfold xLiftedPairs + rw [lift_pull_xt_aux s t u v _ h.append_left', + lift_pull_xs_aux s t u v _ h.append_right'] + +/-! ### The right side's transported closure label -/ + +/-- The label equivalence of the right side: the partial-closure +survivor identification, then the closure casts. -/ +noncomputable def pcCloseLabel (s t u v : ℕ) : + (Fin (s + t) ⊕ + Fragment.FoldSurviving + (Fin (u + v) ⊕ Fin ((s + u) + (t + v))) + (zClosePairs s t u v)) ≃ + (Fin (0 + (s + t)) ⊕ Fin ((s + t) + 0)) := + _root_.Equiv.sumCongr + (finCongr (by omega : s + t = 0 + (s + t))) + ((pcSurvEquiv s t u v).trans + (finCongr (by omega : s + t = (s + t) + 0))) + +/-- The inverse survivor identification on high labels. -/ +theorem pcSurvEquiv_symm_high_val (s t u v : ℕ) (k : Fin t) + (h : s + k.val < s + t) : + ((pcSurvEquiv s t u v).symm ⟨s + k.val, h⟩).val = + Sum.inr (⟨(s + u) + k.val, by have := k.isLt; omega⟩ : + Fin ((s + u) + (t + v))) := by + change ((if hk : s + k.val < s then _ else _ : + {x // pcSurvPred s t u v x})).val = _ + rw [dite_eq_right (show ¬ s + k.val < s by omega)] + exact congrArg Sum.inr (Fin.ext (by + change (s + u) + (s + k.val - s) = (s + u) + k.val + omega)) + +/-- The inverse survivor identification on low labels. -/ +theorem pcSurvEquiv_symm_low_val (s t u v : ℕ) (i : Fin s) + (h : i.val < s + t) : + ((pcSurvEquiv s t u v).symm ⟨i.val, h⟩).val = + Sum.inr (⟨i.val, by have := i.isLt; omega⟩ : + Fin ((s + u) + (t + v))) := by + change ((if hk : i.val < s then _ else _ : + {x // pcSurvPred s t u v x})).val = _ + rw [dite_eq_left (show i.val < s from i.isLt)] + +/-! ### The right side's ground computation -/ + +private theorem rhs_ground_xt_aux (s t u v : ℕ) : + ∀ (l : List (Fin t)), + Fragment.mapPairs (pcCloseLabel s t u v).symm + (l.map (fun k => + ((Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩ : + Fin (0 + (s + t)) ⊕ Fin ((s + t) + 0)), + Sum.inr ⟨s + k.val, by have := k.isLt; omega⟩))) = + l.map (fun k => + (Sum.inl ⟨s + k.val, by have := k.isLt; omega⟩, + Sum.inr ⟨Sum.inr ⟨(s + u) + k.val, + by have := k.isLt; omega⟩, xtSurv s t u v k⟩)) + | [] => rfl + | k :: l => by + simp only [List.map_cons, Fragment.mapPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext rfl ?_) + (rhs_ground_xt_aux s t u v l) + change Sum.inr ((pcSurvEquiv s t u v).symm + ⟨s + k.val, by have := k.isLt; omega⟩) = _ + refine congrArg Sum.inr (Subtype.ext ?_) + rw [pcSurvEquiv_symm_high_val] + +private theorem rhs_ground_xs_aux (s t u v : ℕ) : + ∀ (l : List (Fin s)), + Fragment.mapPairs (pcCloseLabel s t u v).symm + (l.map (fun i => + ((Sum.inl ⟨i.val, by have := i.isLt; omega⟩ : + Fin (0 + (s + t)) ⊕ Fin ((s + t) + 0)), + Sum.inr ⟨i.val, by have := i.isLt; omega⟩))) = + l.map (fun i => + (Sum.inl ⟨i.val, by have := i.isLt; omega⟩, + Sum.inr ⟨Sum.inr ⟨i.val, by have := i.isLt; omega⟩, + xsSurv s t u v i⟩)) + | [] => rfl + | i :: l => by + simp only [List.map_cons, Fragment.mapPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext rfl ?_) + (rhs_ground_xs_aux s t u v l) + change Sum.inr ((pcSurvEquiv s t u v).symm + ⟨i.val, by have := i.isLt; omega⟩) = _ + refine congrArg Sum.inr (Subtype.ext ?_) + rw [pcSurvEquiv_symm_low_val] + +/-- The right side's closure pairs are the canonical cross +pairs. -/ +theorem rhs_ground_pairs (s t u v : ℕ) : + Fragment.mapPairs (pcCloseLabel s t u v).symm + (interfacePairs 0 (s + t) 0) = + xLiftedPairs s t u v := by + rw [interfacePairs_closure_split s t, mapPairs_append] + unfold xLiftedPairs ipHigh ipLow + rw [rhs_ground_xt_aux, rhs_ground_xs_aux] + +/-- The right side's transported closure pairs. -/ +noncomputable def absQsR (s t u v : ℕ) := + Fragment.mapPairs (pcCloseLabel s t u v).symm + (interfacePairs 0 (s + t) 0) + +/-- The canonical cross pairs are well-formed. -/ +theorem xLiftedPairs_wf (s t u v : ℕ) : + Fragment.PairsWF (xLiftedPairs s t u v) := + (rhs_ground_pairs s t u v) ▸ + Fragment.mapPairs_wf (pcCloseLabel s t u v).symm _ + (interfacePairs_wf 0 (s + t) 0) + +/-! ### The right side, normalized -/ + +/-- The composed label identification of the right side. -/ +noncomputable def absLabelR (s t u v : ℕ) : + Fragment.FoldSurviving + (Fin (s + t) ⊕ + Fragment.FoldSurviving + (Fin (u + v) ⊕ Fin ((s + u) + (t + v))) + (zClosePairs s t u v)) + (xLiftedPairs s t u v) ≃ Fin (0 + 0) := + (Fragment.foldSurvivingPermEquiv + ((rhs_ground_pairs s t u v) ▸ List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv (pcCloseLabel s t u v) + (absQsR s t u v)).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel (pcCloseLabel s t u v) + (interfacePairs 0 (s + t) 0)).symm ▸ + List.Perm.refl _)).symm.trans + ((interfaceSurvEquiv 0 (s + t) 0).trans finSumFinEquiv))) + +/-- **The right side, normalized**: the closure of `x` against +the partial closure is iterated gluing of the canonical cross +pairs over `x ⊔ (glued z ⊔ G)`. -/ +noncomputable def absNormalRight {s t u v : ℕ} + (X : Fragment (Fin (s + t))) (z : Fragment (Fin (u + v))) + (G : Fragment (Fin ((s + u) + (t + v)))) : + (pairClose X (partialClose z G)).Equiv + ((Fragment.glueList + (X.disjUnion + (Fragment.glueList (z.disjUnion G) + (zClosePairs s t u v) (zClosePairs_wf s t u v))) + (xLiftedPairs s t u v) + (xLiftedPairs_wf s t u v)).relabel + (absLabelR s t u v)) := by + let σB := pcCloseLabel s t u v + let qs0 := absQsR s t u v + have wfqs0 : Fragment.PairsWF qs0 := + Fragment.mapPairs_wf σB.symm _ (interfacePairs_wf 0 (s + t) 0) + let Zg := Fragment.glueList (z.disjUnion G) + (zClosePairs s t u v) (zClosePairs_wf s t u v) + let AmbR := X.disjUnion Zg + -- C5: bridge the transported pairs to the canonical list. + have C5 : (Fragment.glueList AmbR qs0 wfqs0).Equiv + ((Fragment.glueList AmbR (xLiftedPairs s t u v) + (xLiftedPairs_wf s t u v)).relabel + (Fragment.foldSurvivingPermEquiv + ((rhs_ground_pairs s t u v) ▸ + List.Perm.refl _)).symm) := + Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv AmbR (rhs_ground_pairs s t u v) + wfqs0 (xLiftedPairs_wf s t u v) + ((rhs_ground_pairs s t u v) ▸ List.Perm.refl _)) + -- C3: the fold-survivor relabelling stage. + have C3 := (Fragment.glueListRelabel AmbR σB qs0 wfqs0).trans + ((Fragment.Equiv.relabelCongr C5 + (Fragment.foldSurvivingMapEquiv σB qs0)).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- C2: bridge the closure pairs. + have C2 := (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (AmbR.relabel σB) + (mapPairs_symm_cancel σB + (interfacePairs 0 (s + t) 0)).symm + (interfacePairs_wf 0 (s + t) 0) + (Fragment.mapPairs_wf σB _ wfqs0) + ((mapPairs_symm_cancel σB + (interfacePairs 0 (s + t) 0)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr C3 + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel σB + (interfacePairs 0 (s + t) 0)).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- E1R: peel the closure casts. + have E1R : ((X.relabel + (finCongr (by omega : s + t = 0 + (s + t)))).disjUnion + ((partialClose z G).relabel + (finCongr (by omega : s + t = (s + t) + 0)))).Equiv + (AmbR.relabel σB) := + (Fragment.Equiv.disjUnionCongr + (Fragment.Equiv.refl _) + (Fragment.Equiv.relabelTrans Zg (pcSurvEquiv s t u v) + (finCongr (by omega : s + t = (s + t) + 0)))).trans + ((Fragment.relabelDisjUnionLeft X _ + (finCongr (by omega : s + t = 0 + (s + t)))).trans + ((Fragment.Equiv.relabelCongr + (Fragment.relabelDisjUnionRight X Zg + ((pcSurvEquiv s t u v).trans + (finCongr (by omega : s + t = (s + t) + 0)))) + (_root_.Equiv.sumCongr + (finCongr (by omega : s + t = 0 + (s + t))) + (_root_.Equiv.refl _))).trans + ((Fragment.Equiv.relabelTrans _ _ _).trans + (Fragment.Equiv.relabelEq _ + (_root_.Equiv.ext (fun x => by cases x <;> rfl)))))) + -- C1: transport the closure gluing across E1R. + have C1 := (Fragment.glueListCongr E1R + (interfacePairs 0 (s + t) 0) + (interfacePairs_wf 0 (s + t) 0)).trans C2 + -- Assemble. + exact (composeNormal + (X.relabel (finCongr (by omega : s + t = 0 + (s + t)))) + ((partialClose z G).relabel + (finCongr (by omega : s + t = (s + t) + 0)))).trans + ((Fragment.Equiv.relabelCongr C1 + ((interfaceSurvEquiv 0 (s + t) 0).trans + finSumFinEquiv)).trans + (Fragment.Equiv.relabelTrans _ _ _)) + +/-! ### The left side's derived pair lists -/ + +/-- The left side's transported closure pairs. -/ +noncomputable def absQsL (s t u v : ℕ) := + Fragment.mapPairs (tensorCloseLabel s t u v).symm + (interfacePairs 0 ((s + u) + (t + v)) 0) + +/-- The reordered pairs, pulled back through the association. -/ +noncomputable def absPs1 (s t u v : ℕ) := + Fragment.mapPairs + (_root_.Equiv.sumAssoc (Fin (s + t)) (Fin (u + v)) + (Fin ((s + u) + (t + v)))).symm.symm + ((zvBlock s t u v ++ zuBlock s t u v) ++ + (xtBlock s t u v ++ xsBlock s t u v)) + +/-- The pulled-back pairs are the localized pairs. -/ +theorem abs_assoc' (s t u v : ℕ) : + absPs1 s t u v = + Fragment.inrPairs (zClosePairs s t u v) ++ + xCrossPairs s t u v := by + unfold absPs1 + rw [_root_.Equiv.symm_symm] + exact tensor_pairs_assoc s t u v + +/-- The lifted cross pairs of the two-stage fold. -/ +noncomputable def absQsLift (s t u v : ℕ) := + Fragment.liftPairs + (Fragment.inrPairs (zClosePairs s t u v)) + (xCrossPairs s t u v) + ((tensorPairsA_wf s t u v).append_sep) + +/-- The lifted cross pairs, pulled back through the embedding +survivor equivalence. -/ +noncomputable def absPs0 (s t u v : ℕ) := + Fragment.mapPairs + (Fragment.inrFoldEquiv (α := Fin (s + t)) + (zClosePairs s t u v)).symm.symm + (absQsLift s t u v) + +/-- The pulled-back lifted pairs are the canonical cross pairs. -/ +theorem abs_lift_pull (s t u v : ℕ) : + absPs0 s t u v = xLiftedPairs s t u v := by + unfold absPs0 absQsLift + rw [_root_.Equiv.symm_symm] + exact lift_pull s t u v _ + +/-! ### The left side, normalized -/ + +/-- The composed label identification of the left side. -/ +noncomputable def absLabelL (s t u v : ℕ) : + Fragment.FoldSurviving + (Fin (s + t) ⊕ + Fragment.FoldSurviving + (Fin (u + v) ⊕ Fin ((s + u) + (t + v))) + (zClosePairs s t u v)) + (xLiftedPairs s t u v) ≃ Fin (0 + 0) := + (Fragment.foldSurvivingPermEquiv + ((abs_lift_pull s t u v) ▸ List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv + (Fragment.inrFoldEquiv (α := Fin (s + t)) + (zClosePairs s t u v)).symm (absPs0 s t u v)).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel + (Fragment.inrFoldEquiv (α := Fin (s + t)) + (zClosePairs s t u v)).symm + (absQsLift s t u v)).symm ▸ + List.Perm.refl _)).symm.trans + ((Fragment.appendFlatten + (Fragment.inrPairs (zClosePairs s t u v)) + (xCrossPairs s t u v) + ((tensorPairsA_wf s t u v).append_sep)).trans + ((Fragment.foldSurvivingPermEquiv + ((abs_assoc' s t u v) ▸ List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingMapEquiv + (_root_.Equiv.sumAssoc (Fin (s + t)) (Fin (u + v)) + (Fin ((s + u) + (t + v)))).symm (absPs1 s t u v)).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel + (_root_.Equiv.sumAssoc (Fin (s + t)) (Fin (u + v)) + (Fin ((s + u) + (t + v)))).symm + ((zvBlock s t u v ++ zuBlock s t u v) ++ + (xtBlock s t u v ++ xsBlock s t u v))).symm ▸ + List.Perm.refl _)).symm.trans + ((Fragment.foldSurvivingPermEquiv + (tensor_pairs_perm s t u v)).symm.trans + ((Fragment.foldSurvivingMapEquiv (tensorCloseLabel s t u v) + (absQsL s t u v)).trans + ((Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel (tensorCloseLabel s t u v) + (interfacePairs 0 ((s + u) + (t + v)) 0)).symm ▸ + List.Perm.refl _)).symm.trans + ((interfaceSurvEquiv 0 ((s + u) + (t + v)) 0).trans + finSumFinEquiv)))))))))) + +/-- The pulled-back absorption pairs form a well-formed gluing list. -/ +theorem absorptionPairs_wf (s t u v : ℕ) : + Fragment.PairsWF (absPs0 s t u v) := by + apply Fragment.mapPairs_wf + exact Fragment.liftPairs_wf _ _ (tensorPairsA_wf s t u v).append_right + (tensorPairsA_wf s t u v).append_sep + +/-- **The left side, normalized**: the closure of the tensor +against `G` is iterated gluing of the canonical cross pairs over +`x ⊔ (glued z ⊔ G)`. -/ +noncomputable def absNormalLeft {s t u v : ℕ} + (X : Fragment (Fin (s + t))) (z : Fragment (Fin (u + v))) + (G : Fragment (Fin ((s + u) + (t + v)))) : + (pairClose (tensorFragment X z) G).Equiv + ((Fragment.glueList + (X.disjUnion + (Fragment.glueList (z.disjUnion G) + (zClosePairs s t u v) (zClosePairs_wf s t u v))) + (xLiftedPairs s t u v) + (xLiftedPairs_wf s t u v)).relabel + (absLabelL s t u v)) := by + -- ═══════ SETUP ═══════ + -- The three ambients (`AmbL`, `AmbA`, `AmbR`), the folds over them, + -- and the well-formedness certificates of the four pair lists. + let σA := tensorCloseLabel s t u v + let aE := (_root_.Equiv.sumAssoc (Fin (s + t)) (Fin (u + v)) + (Fin ((s + u) + (t + v)))).symm + let iM := Fragment.inrFoldEquiv (α := Fin (s + t)) + (zClosePairs s t u v) + let pairsP := (zvBlock s t u v ++ zuBlock s t u v) ++ + (xtBlock s t u v ++ xsBlock s t u v) + have wfqsL : Fragment.PairsWF (absQsL s t u v) := + Fragment.mapPairs_wf σA.symm _ + (interfacePairs_wf 0 ((s + u) + (t + v)) 0) + have wfP : Fragment.PairsWF pairsP := tensorPairsL_wf s t u v + have wfPs1 : Fragment.PairsWF (absPs1 s t u v) := + Fragment.mapPairs_wf aE.symm _ wfP + have wfA : Fragment.PairsWF + (Fragment.inrPairs (zClosePairs s t u v) ++ + xCrossPairs s t u v) := tensorPairsA_wf s t u v + have wfLift : Fragment.PairsWF (absQsLift s t u v) := + Fragment.liftPairs_wf _ _ wfA.append_right wfA.append_sep + have wfPs0 : Fragment.PairsWF (absPs0 s t u v) := by + exact absorptionPairs_wf s t u v + let Zg := Fragment.glueList (z.disjUnion G) + (zClosePairs s t u v) (zClosePairs_wf s t u v) + let AmbL := (X.disjUnion z).disjUnion G + let AmbA := X.disjUnion (z.disjUnion G) + let AmbR := X.disjUnion Zg + let Xf := Fragment.glueList AmbA + (Fragment.inrPairs (zClosePairs s t u v)) wfA.append_left + -- ═══════ STAGE 1: THE z-BLOCK, AS AN EMBEDDED FOLD ═══════ + -- K9: bridge the pulled-back lifted pairs to the canonical + -- list. + have K9 : (Fragment.glueList AmbR (absPs0 s t u v) + wfPs0).Equiv + ((Fragment.glueList AmbR (xLiftedPairs s t u v) + (xLiftedPairs_wf s t u v)).relabel + (Fragment.foldSurvivingPermEquiv + ((abs_lift_pull s t u v) ▸ + List.Perm.refl _)).symm) := + Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv AmbR (abs_lift_pull s t u v) + wfPs0 (xLiftedPairs_wf s t u v) + ((abs_lift_pull s t u v) ▸ List.Perm.refl _)) + -- K8: the embedding-survivor relabelling stage. + have K8 := (Fragment.glueListRelabel AmbR iM.symm + (absPs0 s t u v) wfPs0).trans + ((Fragment.Equiv.relabelCongr K9 + (Fragment.foldSurvivingMapEquiv iM.symm + (absPs0 s t u v))).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- K7: bridge the lifted pairs. + have K7 := (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (AmbR.relabel iM.symm) + (mapPairs_symm_cancel iM.symm (absQsLift s t u v)).symm + wfLift (Fragment.mapPairs_wf iM.symm _ wfPs0) + ((mapPairs_symm_cancel iM.symm + (absQsLift s t u v)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr K8 + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel iM.symm + (absQsLift s t u v)).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- E4: the glued z-block is the embedded fold. + have E4 : Xf.Equiv (AmbR.relabel iM.symm) := + Fragment.glueListDisjUnionRight X (z.disjUnion G) + (zClosePairs s t u v) (zClosePairs_wf s t u v) + -- K6: transport across E4. + have K6 := (Fragment.glueListCongr E4 (absQsLift s t u v) + wfLift).trans K7 + -- ═══════ STAGE 2: APPENDING AND REASSOCIATING THE AMBIENT ═══════ + -- K5: the append stage. + have K5 := (Fragment.glueListAppend AmbA + (Fragment.inrPairs (zClosePairs s t u v)) + (xCrossPairs s t u v) wfA).trans + ((Fragment.Equiv.relabelCongr K6 + (Fragment.appendFlatten _ _ wfA.append_sep)).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- K4: bridge the localized pairs. + have K4 := (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv AmbA (abs_assoc' s t u v) + wfPs1 wfA + ((abs_assoc' s t u v) ▸ List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr K5 + (Fragment.foldSurvivingPermEquiv + ((abs_assoc' s t u v) ▸ List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- K3: the association relabelling stage. + have K3 := (Fragment.glueListRelabel AmbA aE + (absPs1 s t u v) wfPs1).trans + ((Fragment.Equiv.relabelCongr K4 + (Fragment.foldSurvivingMapEquiv aE (absPs1 s t u v))).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- K2: bridge the reordered pairs. + have K2 := (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (AmbA.relabel aE) + (mapPairs_symm_cancel aE pairsP).symm + wfP (Fragment.mapPairs_wf aE _ wfPs1) + ((mapPairs_symm_cancel aE pairsP).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr K3 + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel aE pairsP).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- KA: the association of the ambient. + have KA := (Fragment.glueListCongr + (Fragment.disjUnionAssoc X z G) pairsP wfP).trans K2 + -- ═══════ STAGE 3: REORDERING AND THE BOUNDARY RELABEL ═══════ + -- K1: the reordering stage. + have K1 := (Fragment.glueListPerm AmbL + (tensor_pairs_perm s t u v) wfqsL).trans + ((Fragment.Equiv.relabelCongr KA + (Fragment.foldSurvivingPermEquiv + (tensor_pairs_perm s t u v)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- K0: the boundary relabelling stage. + have K0 := (Fragment.glueListRelabel AmbL σA + (absQsL s t u v) wfqsL).trans + ((Fragment.Equiv.relabelCongr K1 + (Fragment.foldSurvivingMapEquiv σA (absQsL s t u v))).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- KB: bridge the closure pairs. + have KB := (Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (AmbL.relabel σA) + (mapPairs_symm_cancel σA + (interfacePairs 0 ((s + u) + (t + v)) 0)).symm + (interfacePairs_wf 0 ((s + u) + (t + v)) 0) + (Fragment.mapPairs_wf σA _ wfqsL) + ((mapPairs_symm_cancel σA + (interfacePairs 0 ((s + u) + (t + v)) 0)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr K0 + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel σA + (interfacePairs 0 ((s + u) + (t + v)) 0)).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _)) + -- ═══════ STAGE 4: THE CLOSURE'S OWN INTERFACE ═══════ + -- E1L: peel the closure casts. + have E1L : (((tensorFragment X z).relabel + (finCongr (by omega : + (s + u) + (t + v) = 0 + ((s + u) + (t + v))))).disjUnion + (G.relabel (finCongr (by omega : + (s + u) + (t + v) = (s + u) + (t + v) + 0)))).Equiv + (AmbL.relabel σA) := + (Fragment.Equiv.disjUnionCongr + (Fragment.Equiv.relabelTrans (X.disjUnion z) + (interleaveEquiv s t u v) + (finCongr (by omega : + (s + u) + (t + v) = 0 + ((s + u) + (t + v))))) + (Fragment.Equiv.refl _)).trans + ((Fragment.relabelDisjUnionLeft (X.disjUnion z) _ + ((interleaveEquiv s t u v).trans + (finCongr (by omega : + (s + u) + (t + v) = 0 + ((s + u) + (t + v)))))).trans + ((Fragment.Equiv.relabelCongr + (Fragment.relabelDisjUnionRight (X.disjUnion z) G + (finCongr (by omega : + (s + u) + (t + v) = (s + u) + (t + v) + 0))) + (_root_.Equiv.sumCongr + ((interleaveEquiv s t u v).trans + (finCongr (by omega : + (s + u) + (t + v) = 0 + ((s + u) + (t + v))))) + (_root_.Equiv.refl _))).trans + ((Fragment.Equiv.relabelTrans _ _ _).trans + (Fragment.Equiv.relabelEq _ + (_root_.Equiv.ext (fun x => by cases x <;> rfl)))))) + -- KC: transport the closure gluing across E1L. + have KC := (Fragment.glueListCongr E1L + (interfacePairs 0 ((s + u) + (t + v)) 0) + (interfacePairs_wf 0 ((s + u) + (t + v)) 0)).trans KB + -- ═══════ ASSEMBLY ═══════ + exact (composeNormal + ((tensorFragment X z).relabel + (finCongr (by omega : + (s + u) + (t + v) = 0 + ((s + u) + (t + v))))) + (G.relabel (finCongr (by omega : + (s + u) + (t + v) = (s + u) + (t + v) + 0)))).trans + ((Fragment.Equiv.relabelCongr KC + ((interfaceSurvEquiv 0 ((s + u) + (t + v)) 0).trans + finSumFinEquiv)).trans + (Fragment.Equiv.relabelTrans _ _ _)) + +/-! ### The meet: no label survives a full closure -/ + +/-- The canonical cross pairs glue every label: no survivor. -/ +theorem absSurv_empty (s t u v : ℕ) + (x : Fragment.FoldSurviving + (Fin (s + t) ⊕ + Fragment.FoldSurviving + (Fin (u + v) ⊕ Fin ((s + u) + (t + v))) + (zClosePairs s t u v)) + (xLiftedPairs s t u v)) : False := by + obtain ⟨xv, hx⟩ := x + rcases xv with a | b + · by_cases ha : a.val < s + · exact (hx _ (List.mem_append.mpr (Or.inr + (List.mem_map.mpr ⟨⟨a.val, ha⟩, + List.mem_reverse.mpr (List.mem_finRange _), + rfl⟩)))).1 (congrArg Sum.inl (Fin.ext rfl)) + · have hk : a.val - s < t := by have := a.isLt; omega + exact (hx _ (List.mem_append.mpr (Or.inl + (List.mem_map.mpr ⟨⟨a.val - s, hk⟩, + List.mem_reverse.mpr (List.mem_finRange _), + rfl⟩)))).1 (congrArg Sum.inl (Fin.ext (by + change a.val = s + (a.val - s) + omega))) + · obtain ⟨bv, hb⟩ := b + have hpred : pcSurvPred s t u v bv := + (pcSurv_iff s t u v bv).mp + ((forall_ne_iff_not_mem_flat _ bv).mp hb) + rcases bv with a' | c + · exact hpred + · rcases hpred with hc | hc + · exact (hx _ (List.mem_append.mpr (Or.inr + (List.mem_map.mpr ⟨⟨c.val, hc⟩, + List.mem_reverse.mpr (List.mem_finRange _), + rfl⟩)))).2 (congrArg Sum.inr (Subtype.ext + (congrArg Sum.inr (Fin.ext rfl)))) + · have hk : c.val - (s + u) < t := by omega + exact (hx _ (List.mem_append.mpr (Or.inl + (List.mem_map.mpr ⟨⟨c.val - (s + u), hk⟩, + List.mem_reverse.mpr (List.mem_finRange _), + rfl⟩)))).2 (congrArg Sum.inr (Subtype.ext + (congrArg Sum.inr (Fin.ext (by + change c.val = (s + u) + (c.val - (s + u)) + omega))))) + +/-- **The absorption** (accompanying paper, Lemma 3.3(b), geometric +core): closing a tensor against a test fragment is closing the +first factor against the partial closure of the second. -/ +noncomputable def pairCloseTensorAbsorb {s t u v : ℕ} + (X : Fragment (Fin (s + t))) (z : Fragment (Fin (u + v))) + (G : Fragment (Fin ((s + u) + (t + v)))) : + (pairClose (tensorFragment X z) G).Equiv + (pairClose X (partialClose z G)) := + (absNormalLeft X z G).trans + ((Fragment.Equiv.relabelEq _ + (_root_.Equiv.ext (fun x => + absurd (absSurv_empty s t u v x) not_false))).trans + (absNormalRight X z G).symm) + +/-! ### The monoidal ideal (accompanying paper, Lemma 3.3(b)) -/ + +/-- The connection row of a tensor is a connection row of the +first factor at the partially closed test fragment. -/ +theorem connectionPairing_tensor (f : ClosedFragment → ℂ) + (hf : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) + {s t u v : ℕ} (X : Fragment (Fin (s + t))) + (z : Fragment (Fin (u + v))) + (G : Fragment (Fin ((s + u) + (t + v)))) : + connectionPairing f ((s + u) + (t + v)) + (tensorFragment X z) G = + connectionPairing f (s + t) X (partialClose z G) := + hf _ _ (pairCloseTensorAbsorb X z G) + +/-- Bilinear tensor on the free modules of fragments. -/ +noncomputable def tensorFinsupp (s t u v : ℕ) : + (Fragment (Fin (s + t)) →₀ ℂ) →ₗ[ℂ] + (Fragment (Fin (u + v)) →₀ ℂ) →ₗ[ℂ] + (Fragment (Fin ((s + u) + (t + v))) →₀ ℂ) := + Finsupp.lift _ ℂ _ (fun F => + Finsupp.lift _ ℂ _ (fun z => + Finsupp.single (tensorFragment F z) (1 : ℂ))) + +/-- Tensor of weighted single fragments. -/ +theorem tensorFinsupp_single (s t u v : ℕ) + (F : Fragment (Fin (s + t))) (c : ℂ) + (z : Fragment (Fin (u + v))) (d : ℂ) : + tensorFinsupp s t u v (Finsupp.single F c) + (Finsupp.single z d) = + Finsupp.single (tensorFragment F z) (c * d) := by + unfold tensorFinsupp + rw [Finsupp.lift_apply, Finsupp.sum_single_index (by simp), + LinearMap.smul_apply, Finsupp.lift_apply, + Finsupp.sum_single_index (by simp), Finsupp.smul_single, + Finsupp.smul_single, smul_eq_mul, smul_eq_mul, mul_one] + +/-- The connection row of a single-fragment tensor, linearized in +the first slot. -/ +theorem connectionMap_tensor_single (f : ClosedFragment → ℂ) + (hf : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) + {s t u v : ℕ} (x : Fragment (Fin (s + t)) →₀ ℂ) + (z : Fragment (Fin (u + v))) + (K : Fragment (Fin ((s + u) + (t + v)))) : + connectionMap f ((s + u) + (t + v)) + (tensorFinsupp s t u v x (Finsupp.single z 1)) K = + connectionMap f (s + t) x (partialClose z K) := by + induction x using Finsupp.induction_linear with + | zero => + rw [map_zero, LinearMap.zero_apply, map_zero] + rfl + | add y w hy hw => + rw [map_add, LinearMap.add_apply, map_add] + change connectionMap f ((s + u) + (t + v)) _ K + + connectionMap f ((s + u) + (t + v)) _ K = _ + rw [hy, hw, map_add] + rfl + | single F c => + rw [tensorFinsupp_single, mul_one, connectionMap_single, + connectionMap_single, connectionPairing_tensor f hf] + +/-- A kernel element tensored with a single fragment stays in the +kernel. -/ +theorem tensorFinsupp_single_ker (f : ClosedFragment → ℂ) + (hf : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) + {s t u v : ℕ} {x : Fragment (Fin (s + t)) →₀ ℂ} + (hx : x ∈ LinearMap.ker (connectionMap f (s + t))) + (z : Fragment (Fin (u + v))) : + tensorFinsupp s t u v x (Finsupp.single z 1) ∈ + LinearMap.ker (connectionMap f ((s + u) + (t + v))) := by + rw [LinearMap.mem_ker] at hx ⊢ + funext K + rw [connectionMap_tensor_single f hf x z K, hx] + rfl + +/-- **The monoidal ideal** (accompanying paper, Lemma 3.3(b)): a +kernel element tensored with anything stays in the kernel. -/ +theorem tensorFinsupp_ker_left (f : ClosedFragment → ℂ) + (hf : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) + {s t u v : ℕ} {x : Fragment (Fin (s + t)) →₀ ℂ} + (hx : x ∈ LinearMap.ker (connectionMap f (s + t))) + (y : Fragment (Fin (u + v)) →₀ ℂ) : + tensorFinsupp s t u v x y ∈ + LinearMap.ker (connectionMap f ((s + u) + (t + v))) := by + induction y using Finsupp.induction_linear with + | zero => + rw [map_zero] + exact Submodule.zero_mem _ + | add y w hy hw => + rw [map_add] + exact Submodule.add_mem _ hy hw + | single z c => + have h1 : tensorFinsupp s t u v x (Finsupp.single z c) = + c • tensorFinsupp s t u v x (Finsupp.single z 1) := by + rw [← map_smul, Finsupp.smul_single, smul_eq_mul, mul_one] + rw [h1] + exact Submodule.smul_mem _ c + (tensorFinsupp_single_ker f hf hx z) + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean new file mode 100644 index 0000000000..1f854699ee --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean @@ -0,0 +1,797 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate + +/-! +# Interchange law of the skein category + +The interchange law holds at the fragment level: tensoring two +composites is equivalent to composing the two tensors. This file +constructs the `Fragment.Equiv` witnessing + + `(F₁ . G₁) ⊗ (F₂ . G₂) ≃ (F₁ ⊗ F₂) . (G₁ ⊗ G₂)` + +by normalizing both sides to iterated gluing over the common +ambient `(F₁ ⊔ G₁) ⊔ (F₂ ⊔ G₂)` and meeting the label chains. +-/ + +@[expose] public section + +namespace RS + +namespace Fragment + +variable {α β γ δ : Type} + +/-- Four-summand exchange: `(W₁ ⊔ W₂) ⊔ (W₃ ⊔ W₄)` reshuffles +to `(W₁ ⊔ W₃) ⊔ (W₂ ⊔ W₄)` up to the `sumSumSumComm` +relabelling. -/ +noncomputable def disjUnionExchange + (W₁ : Fragment α) (W₂ : Fragment β) + (W₃ : Fragment γ) (W₄ : Fragment δ) : + ((W₁.disjUnion W₂).disjUnion (W₃.disjUnion W₄)).Equiv + (((W₁.disjUnion W₃).disjUnion (W₂.disjUnion W₄)).relabel + (_root_.Equiv.sumSumSumComm α γ β δ)) where + flagEquiv := _root_.Equiv.sumSumSumComm + W₁.Flag W₂.Flag W₃.Flag W₄.Flag + vertexEquiv := _root_.Equiv.sumSumSumComm + W₁.Vertex W₂.Vertex W₃.Vertex W₄.Vertex + attach_comm := fun f => by + rcases f with (f | f) | (f | f) + · change (((W₁.attach f).map Sum.inl Sum.inl).map + Sum.inl Sum.inl).map id + (_root_.Equiv.sumSumSumComm α γ β δ) = + (((W₁.attach f).map Sum.inl Sum.inl).map + Sum.inl Sum.inl).map + (_root_.Equiv.sumSumSumComm W₁.Vertex W₂.Vertex + W₃.Vertex W₄.Vertex) id + rcases W₁.attach f with v | ℓ <;> rfl + · change (((W₂.attach f).map Sum.inl Sum.inl).map + Sum.inr Sum.inr).map id + (_root_.Equiv.sumSumSumComm α γ β δ) = + (((W₂.attach f).map Sum.inr Sum.inr).map + Sum.inl Sum.inl).map + (_root_.Equiv.sumSumSumComm W₁.Vertex W₂.Vertex + W₃.Vertex W₄.Vertex) id + rcases W₂.attach f with v | ℓ <;> rfl + · change (((W₃.attach f).map Sum.inr Sum.inr).map + Sum.inl Sum.inl).map id + (_root_.Equiv.sumSumSumComm α γ β δ) = + (((W₃.attach f).map Sum.inl Sum.inl).map + Sum.inr Sum.inr).map + (_root_.Equiv.sumSumSumComm W₁.Vertex W₂.Vertex + W₃.Vertex W₄.Vertex) id + rcases W₃.attach f with v | ℓ <;> rfl + · change (((W₄.attach f).map Sum.inr Sum.inr).map + Sum.inr Sum.inr).map id + (_root_.Equiv.sumSumSumComm α γ β δ) = + (((W₄.attach f).map Sum.inr Sum.inr).map + Sum.inr Sum.inr).map + (_root_.Equiv.sumSumSumComm W₁.Vertex W₂.Vertex + W₃.Vertex W₄.Vertex) id + rcases W₄.attach f with v | ℓ <;> rfl + pairing_comm := fun f => by + rcases f with (f | f) | (f | f) <;> rfl + circles_eq := by + change W₁.circles + W₂.circles + + (W₃.circles + W₄.circles) = + W₁.circles + W₃.circles + + (W₂.circles + W₄.circles) + omega + +end Fragment + +/-! ### Interface pair splitting and ground computation -/ + +/-- The interface pairs of a sum split into the high block (second +factor) followed by the low block (first factor). -/ +private theorem interchange_pairs_split + (s₁ t₁ u₁ s₂ t₂ u₂ : ℕ) : + interfacePairs (s₁+s₂) (t₁+t₂) (u₁+u₂) = + (List.finRange t₂).reverse.map (fun k' => + ((Sum.inl ⟨(s₁+s₂) + (t₁ + k'.val), + by have := k'.isLt; omega⟩ : + Fin ((s₁+s₂) + (t₁+t₂)) ⊕ + Fin ((t₁+t₂) + (u₁+u₂))), + Sum.inr ⟨t₁ + k'.val, + by have := k'.isLt; omega⟩)) ++ + (List.finRange t₁).reverse.map (fun k => + ((Sum.inl ⟨(s₁+s₂) + k.val, + by have := k.isLt; omega⟩ : + Fin ((s₁+s₂) + (t₁+t₂)) ⊕ + Fin ((t₁+t₂) + (u₁+u₂))), + Sum.inr ⟨k.val, + by have := k.isLt; omega⟩)) := by + unfold interfacePairs + rw [List.map_reverse, List.map_reverse, List.map_reverse, + ← List.reverse_append] + refine congrArg List.reverse ?_ + rw [← List.ofFn_eq_map, List.ofFn_add, List.ofFn_eq_map, + List.ofFn_eq_map] + exact congrArg₂ (· ++ ·) + (List.map_congr_left fun i _ => + Prod.ext (congrArg Sum.inl (Fin.ext rfl)) + (congrArg Sum.inr (Fin.ext rfl))) + (List.map_congr_left fun j _ => + Prod.ext (congrArg Sum.inl (Fin.ext rfl)) + (congrArg Sum.inr (Fin.ext rfl))) + +/-- Transport of the low (first-factor) half through the +interchange shuffle: each pair maps to the corresponding +`inlPairs` pair. -/ +private theorem interchange_ground_low_aux + (s₁ t₁ u₁ s₂ t₂ u₂ : ℕ) : + ∀ (l : List (Fin t₁)), + Fragment.mapPairs + ((_root_.Equiv.sumCongr + (interleaveEquiv s₁ t₁ s₂ t₂) + (interleaveEquiv t₁ u₁ t₂ u₂)).symm.trans + (_root_.Equiv.sumSumSumComm + (Fin (s₁+t₁)) (Fin (s₂+t₂)) + (Fin (t₁+u₁)) (Fin (t₂+u₂)))) + (l.map (fun k => + ((Sum.inl ⟨(s₁+s₂) + k.val, + by have := k.isLt; omega⟩ : + Fin ((s₁+s₂) + (t₁+t₂)) ⊕ + Fin ((t₁+t₂) + (u₁+u₂))), + Sum.inr ⟨k.val, + by have := k.isLt; omega⟩))) = + Fragment.inlPairs + (β := Fin (s₂+t₂) ⊕ Fin (t₂+u₂)) + (l.map (fun k => + ((Sum.inl ⟨s₁ + k.val, + by have := k.isLt; omega⟩ : + Fin (s₁+t₁) ⊕ Fin (t₁+u₁)), + Sum.inr ⟨k.val, + by have := k.isLt; omega⟩))) + | [] => rfl + | k :: l => by + simp only [List.map_cons, Fragment.mapPairs, + Fragment.inlPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext ?_ ?_) + (interchange_ground_low_aux s₁ t₁ u₁ s₂ t₂ u₂ l) + · change (_root_.Equiv.sumSumSumComm + (Fin (s₁+t₁)) (Fin (s₂+t₂)) + (Fin (t₁+u₁)) (Fin (t₂+u₂))) + (Sum.inl ((interleaveEquiv s₁ t₁ s₂ t₂).symm + ⟨(s₁+s₂) + k.val, + by have := k.isLt; omega⟩)) = + Sum.inl (Sum.inl ⟨s₁ + k.val, + by have := k.isLt; omega⟩) + rw [show (⟨(s₁+s₂) + k.val, _⟩ : + Fin ((s₁+s₂) + (t₁+t₂))) = + Fin.natAdd (s₁+s₂) (Fin.castAdd t₂ k) + from Fin.ext rfl, + interleaveEquiv_symm_high_left] + simp [_root_.Equiv.sumSumSumComm, Fin.ext_iff] + · change (_root_.Equiv.sumSumSumComm + (Fin (s₁+t₁)) (Fin (s₂+t₂)) + (Fin (t₁+u₁)) (Fin (t₂+u₂))) + (Sum.inr ((interleaveEquiv t₁ u₁ t₂ u₂).symm + ⟨k.val, by have := k.isLt; omega⟩)) = + Sum.inl (Sum.inr ⟨k.val, + by have := k.isLt; omega⟩) + rw [show (⟨k.val, _⟩ : + Fin ((t₁+t₂) + (u₁+u₂))) = + Fin.castAdd (u₁+u₂) (Fin.castAdd t₂ k) + from Fin.ext rfl, + interleaveEquiv_symm_low_left] + simp [_root_.Equiv.sumSumSumComm, Fin.ext_iff] + +/-- Transport of the high (second-factor) half through the +interchange shuffle: each pair maps to the corresponding +`inrPairs` pair. -/ +private theorem interchange_ground_high_aux + (s₁ t₁ u₁ s₂ t₂ u₂ : ℕ) : + ∀ (l : List (Fin t₂)), + Fragment.mapPairs + ((_root_.Equiv.sumCongr + (interleaveEquiv s₁ t₁ s₂ t₂) + (interleaveEquiv t₁ u₁ t₂ u₂)).symm.trans + (_root_.Equiv.sumSumSumComm + (Fin (s₁+t₁)) (Fin (s₂+t₂)) + (Fin (t₁+u₁)) (Fin (t₂+u₂)))) + (l.map (fun k' => + ((Sum.inl ⟨(s₁+s₂) + (t₁ + k'.val), + by have := k'.isLt; omega⟩ : + Fin ((s₁+s₂) + (t₁+t₂)) ⊕ + Fin ((t₁+t₂) + (u₁+u₂))), + Sum.inr ⟨t₁ + k'.val, + by have := k'.isLt; omega⟩))) = + Fragment.inrPairs + (α := Fin (s₁+t₁) ⊕ Fin (t₁+u₁)) + (l.map (fun k' => + ((Sum.inl ⟨s₂ + k'.val, + by have := k'.isLt; omega⟩ : + Fin (s₂+t₂) ⊕ Fin (t₂+u₂)), + Sum.inr ⟨k'.val, + by have := k'.isLt; omega⟩))) + | [] => rfl + | k' :: l => by + simp only [List.map_cons, Fragment.mapPairs, + Fragment.inrPairs, Prod.map] + refine congrArg₂ List.cons (Prod.ext ?_ ?_) + (interchange_ground_high_aux s₁ t₁ u₁ s₂ t₂ u₂ l) + · change (_root_.Equiv.sumSumSumComm + (Fin (s₁+t₁)) (Fin (s₂+t₂)) + (Fin (t₁+u₁)) (Fin (t₂+u₂))) + (Sum.inl ((interleaveEquiv s₁ t₁ s₂ t₂).symm + ⟨(s₁+s₂) + (t₁ + k'.val), + by have := k'.isLt; omega⟩)) = + Sum.inr (Sum.inl ⟨s₂ + k'.val, + by have := k'.isLt; omega⟩) + rw [show (⟨(s₁+s₂) + (t₁ + k'.val), _⟩ : + Fin ((s₁+s₂) + (t₁+t₂))) = + Fin.natAdd (s₁+s₂) (Fin.natAdd t₁ k') + from Fin.ext rfl, + interleaveEquiv_symm_high_right] + simp [_root_.Equiv.sumSumSumComm, Fin.ext_iff] + · change (_root_.Equiv.sumSumSumComm + (Fin (s₁+t₁)) (Fin (s₂+t₂)) + (Fin (t₁+u₁)) (Fin (t₂+u₂))) + (Sum.inr ((interleaveEquiv t₁ u₁ t₂ u₂).symm + ⟨t₁ + k'.val, + by have := k'.isLt; omega⟩)) = + Sum.inr (Sum.inr ⟨k'.val, + by have := k'.isLt; omega⟩) + rw [show (⟨t₁ + k'.val, _⟩ : + Fin ((t₁+t₂) + (u₁+u₂))) = + Fin.castAdd (u₁+u₂) (Fin.natAdd t₁ k') + from Fin.ext rfl, + interleaveEquiv_symm_low_right] + simp [_root_.Equiv.sumSumSumComm, Fin.ext_iff] + +/-- **Ground computation**: transporting the composition interface +pairs through the interchange shuffle yields the right-block +interface pairs followed by the left-block interface pairs. -/ +theorem interchange_ground (s₁ t₁ u₁ s₂ t₂ u₂ : ℕ) : + Fragment.mapPairs + ((_root_.Equiv.sumCongr + (interleaveEquiv s₁ t₁ s₂ t₂) + (interleaveEquiv t₁ u₁ t₂ u₂)).symm.trans + (_root_.Equiv.sumSumSumComm + (Fin (s₁+t₁)) (Fin (s₂+t₂)) + (Fin (t₁+u₁)) (Fin (t₂+u₂)))) + (interfacePairs (s₁+s₂) (t₁+t₂) (u₁+u₂)) = + Fragment.inrPairs + (α := Fin (s₁+t₁) ⊕ Fin (t₁+u₁)) + (interfacePairs s₂ t₂ u₂) ++ + Fragment.inlPairs + (β := Fin (s₂+t₂) ⊕ Fin (t₂+u₂)) + (interfacePairs s₁ t₁ u₁) := by + rw [interchange_pairs_split s₁ t₁ u₁ s₂ t₂ u₂, + mapPairs_append] + unfold interfacePairs + exact congrArg₂ (· ++ ·) + (interchange_ground_high_aux s₁ t₁ u₁ s₂ t₂ u₂ _) + (interchange_ground_low_aux s₁ t₁ u₁ s₂ t₂ u₂ _) + +/-- The combined interface pairs of the interchange are +well-formed: the `inlPairs` block is all `Sum.inl` and the +`inrPairs` block is all `Sum.inr`, so they are disjoint. -/ +theorem interchangePairs_wf (s₁ t₁ u₁ s₂ t₂ u₂ : ℕ) : + Fragment.PairsWF + (Fragment.inlPairs + (β := Fin (s₂+t₂) ⊕ Fin (t₂+u₂)) + (interfacePairs s₁ t₁ u₁) ++ + Fragment.inrPairs + (α := Fin (s₁+t₁) ⊕ Fin (t₁+u₁)) + (interfacePairs s₂ t₂ u₂)) := by + unfold Fragment.PairsWF + rw [List.flatMap_append] + refine List.Nodup.append + (Fragment.inlPairs_wf _ (interfacePairs_wf s₁ t₁ u₁)) + (Fragment.inrPairs_wf _ (interfacePairs_wf s₂ t₂ u₂)) + ?_ + intro x hx hy + obtain ⟨p, hp, hxp⟩ := List.mem_flatMap.mp hx + obtain ⟨q, hq, hyq⟩ := List.mem_flatMap.mp hy + obtain ⟨p', _, rfl⟩ := List.mem_map.mp hp + obtain ⟨q', _, rfl⟩ := List.mem_map.mp hq + dsimp [Prod.map] at hxp hyq + simp only [List.mem_cons, List.not_mem_nil, + or_false] at hxp hyq + rcases hxp with rfl | rfl <;> + (rcases hyq with h | h <;> exact absurd h Sum.inl_ne_inr) + +namespace Fragment + +/-! ### LHS normalization -/ + +/-- **LHS chain**: `(F₁ . G₁) ⊗ (F₂ . G₂)` normalizes to +`(GL₁ ⊔ GL₂).relabel L_lhs` where `GL_i` is the glueing of +the `i`-th factor. -/ +noncomputable def interchangeNormalLeft + {s₁ t₁ u₁ s₂ t₂ u₂ : ℕ} + (F₁ : Fragment (Fin (s₁ + t₁))) (G₁ : Fragment (Fin (t₁ + u₁))) + (F₂ : Fragment (Fin (s₂ + t₂))) (G₂ : Fragment (Fin (t₂ + u₂))) : + (tensorFragment (F₁.compose G₁) (F₂.compose G₂)).Equiv + (((Fragment.glueList (F₁.disjUnion G₁) + (interfacePairs s₁ t₁ u₁) (interfacePairs_wf s₁ t₁ u₁)).disjUnion + (Fragment.glueList (F₂.disjUnion G₂) + (interfacePairs s₂ t₂ u₂) (interfacePairs_wf s₂ t₂ u₂))).relabel + ((_root_.Equiv.sumCongr + ((interfaceSurvEquiv s₁ t₁ u₁).trans finSumFinEquiv) + ((interfaceSurvEquiv s₂ t₂ u₂).trans finSumFinEquiv)).trans + (interleaveEquiv s₁ u₁ s₂ u₂))) := by + let GL₁ := glueList (F₁.disjUnion G₁) + (interfacePairs s₁ t₁ u₁) (interfacePairs_wf s₁ t₁ u₁) + let GL₂ := glueList (F₂.disjUnion G₂) + (interfacePairs s₂ t₂ u₂) (interfacePairs_wf s₂ t₂ u₂) + let surv₁ := (interfaceSurvEquiv s₁ t₁ u₁).trans finSumFinEquiv + let surv₂ := (interfaceSurvEquiv s₂ t₂ u₂).trans finSumFinEquiv + -- C0: composeNormal in each factor + refine (tensorFragmentCongr + (composeNormal F₁ G₁) (composeNormal F₂ G₂)).trans ?_ + -- Peel relabels, compose, flatten + exact (Equiv.relabelCongr + ((relabelDisjUnionLeft GL₁ (GL₂.relabel surv₂) surv₁).trans + ((Equiv.relabelCongr + (relabelDisjUnionRight GL₁ GL₂ surv₂) + (_root_.Equiv.sumCongr surv₁ + (_root_.Equiv.refl _))).trans + ((Equiv.relabelTrans (GL₁.disjUnion GL₂) + (_root_.Equiv.sumCongr (_root_.Equiv.refl _) surv₂) + (_root_.Equiv.sumCongr surv₁ + (_root_.Equiv.refl _))).trans + (Equiv.relabelEq (GL₁.disjUnion GL₂) + (_root_.Equiv.ext fun x => by + cases x <;> rfl))))) + (interleaveEquiv s₁ u₁ s₂ u₂)).trans + (Equiv.relabelTrans (GL₁.disjUnion GL₂) + (_root_.Equiv.sumCongr surv₁ surv₂) + (interleaveEquiv s₁ u₁ s₂ u₂)) + +/-! ### Helper: liftPairs of inlPairs/inrPairs -/ + +/-- Lifting `inrPairs qs` through `inlPairs ps` equals mapping +through the inverse of `inlFoldEquiv`. -/ +private theorem liftPairs_inlPairs_inrPairs + {α β : Type} + (ps : List (α × α)) : + ∀ (qs : List (β × β)) + (h : PairsSepAll (inlPairs (β := β) ps) + (inrPairs (α := α) qs)), + liftPairs (inlPairs ps) (inrPairs qs) h = + Fragment.mapPairs (inlFoldEquiv (β := β) ps).symm + (inrPairs (α := FoldSurviving α ps) qs) + | [], _ => rfl + | q :: qs, h => by + simp only [inrPairs, List.map_cons, liftPairs, + Fragment.mapPairs, Prod.map] + exact congrArg₂ List.cons + (Prod.ext (Subtype.ext rfl) (Subtype.ext rfl)) + (liftPairs_inlPairs_inrPairs ps qs _) + +/-! ### RHS normalization -/ + +section InterchangeSurvivor + +variable + {s₁ t₁ u₁ s₂ t₂ u₂ : ℕ} + (g : (FoldSurviving (Fin (s₁ + t₁) ⊕ Fin (t₁ + u₁)) + (interfacePairs s₁ t₁ u₁) ⊕ + FoldSurviving (Fin (s₂ + t₂) ⊕ Fin (t₂ + u₂)) + (interfacePairs s₂ t₂ u₂)) ≃ + FoldSurviving (Fin ((s₁ + s₂) + (t₁ + t₂)) ⊕ Fin ((t₁ + t₂) + (u₁ + u₂))) + (interfacePairs (s₁ + s₂) (t₁ + t₂) (u₁ + u₂))) + (hg : ∀ x, (g x).val = + ((_root_.Equiv.sumSumSumComm (Fin (s₁ + t₁)) (Fin (t₁ + u₁)) + (Fin (s₂ + t₂)) (Fin (t₂ + u₂))).trans + (_root_.Equiv.sumCongr (interleaveEquiv s₁ t₁ s₂ t₂) + (interleaveEquiv t₁ u₁ t₂ u₂))) (Sum.map Subtype.val Subtype.val x)) + +include hg + +private theorem interchange_survivor_relabel_inl + (fs₁ : FoldSurviving (Fin (s₁ + t₁) ⊕ Fin (t₁ + u₁)) + (interfacePairs s₁ t₁ u₁)) : + (g.trans ((interfaceSurvEquiv (s₁ + s₂) (t₁ + t₂) (u₁ + u₂)).trans + finSumFinEquiv)) (Sum.inl fs₁) = + ((_root_.Equiv.sumCongr + ((interfaceSurvEquiv s₁ t₁ u₁).trans finSumFinEquiv) + ((interfaceSurvEquiv s₂ t₂ u₂).trans finSumFinEquiv)).trans + (interleaveEquiv s₁ u₁ s₂ u₂)) (Sum.inl fs₁) := by + let ieF := interleaveEquiv s₁ t₁ s₂ t₂ + let ieG := interleaveEquiv t₁ u₁ t₂ u₂ + let E := (_root_.Equiv.sumSumSumComm + (Fin (s₁+t₁)) (Fin (t₁+u₁)) (Fin (s₂+t₂)) (Fin (t₂+u₂))).trans + (_root_.Equiv.sumCongr ieF ieG) + cases hxv : fs₁.val with + | inl a => + have ha : a.val < s₁ := by + by_contra hge + exact (forall_ne_iff_not_mem_flat _ _).mp fs₁.prop + ((mem_interfacePairs_flat s₁ t₁ u₁ _).mpr + (Or.inl ⟨a, hxv, by omega⟩)) + have hie_val : (ieF (Sum.inl a)).val = a.val := by + change (interleaveEquiv s₁ t₁ s₂ t₂ + (Sum.inl a)).val = a.val + conv_lhs => rw [show a = Fin.castAdd t₁ + ⟨a.val, ha⟩ from Fin.ext rfl, + interleaveEquiv_inl_low] + rfl + rw [_root_.Equiv.trans_apply] + conv_rhs => + rw [_root_.Equiv.trans_apply, + _root_.Equiv.sumCongr_apply, Sum.map_inl, + _root_.Equiv.trans_apply, + interfaceSurvEquiv_inl s₁ t₁ u₁ fs₁ a hxv ha, + finSumFinEquiv_apply_left, + interleaveEquiv_inl_low s₁ u₁ s₂ u₂ + ⟨a.val, ha⟩] + rw [_root_.Equiv.trans_apply] + refine (congrArg finSumFinEquiv + (interfaceSurvEquiv_inl (s₁+s₂) (t₁+t₂) (u₁+u₂) + _ (ieF (Sum.inl a)) + (by + rw [hg] + change E (Sum.inl fs₁.val) = _ + rw [hxv] + rfl) + (by rw [hie_val]; omega))).trans ?_ + rw [finSumFinEquiv_apply_left] + exact congrArg (Fin.castAdd (u₁+u₂)) + (Fin.ext hie_val) + | inr b => + have hb : t₁ ≤ b.val := by + by_contra hlt + exact (forall_ne_iff_not_mem_flat _ _).mp fs₁.prop + ((mem_interfacePairs_flat s₁ t₁ u₁ _).mpr + (Or.inr ⟨b, hxv, by omega⟩)) + have hie_val : (ieG (Sum.inl b)).val = + (t₁ + t₂) + (b.val - t₁) := by + change (interleaveEquiv t₁ u₁ t₂ u₂ + (Sum.inl b)).val = _ + conv_lhs => rw [show b = Fin.natAdd t₁ + ⟨b.val - t₁, by + have := b.isLt + omega⟩ from Fin.ext (by + change b.val = t₁ + (b.val - t₁) + omega), + interleaveEquiv_inl_high] + rfl + rw [_root_.Equiv.trans_apply] + conv_rhs => + rw [_root_.Equiv.trans_apply, + _root_.Equiv.sumCongr_apply, Sum.map_inl, + _root_.Equiv.trans_apply, + interfaceSurvEquiv_inr s₁ t₁ u₁ fs₁ b hxv hb, + finSumFinEquiv_apply_right, + interleaveEquiv_inl_high s₁ u₁ s₂ u₂ + ⟨b.val - t₁, by have := b.isLt; omega⟩] + rw [_root_.Equiv.trans_apply] + refine (congrArg finSumFinEquiv + (interfaceSurvEquiv_inr (s₁+s₂) (t₁+t₂) (u₁+u₂) + _ (ieG (Sum.inl b)) + (by + rw [hg] + change E (Sum.inl fs₁.val) = _ + rw [hxv] + rfl) + (by rw [hie_val]; omega))).trans ?_ + rw [finSumFinEquiv_apply_right] + exact congrArg (Fin.natAdd (s₁+s₂)) + (Fin.ext (by + change (ieG (Sum.inl b)).val - (t₁ + t₂) = + b.val - t₁ + rw [hie_val] + omega)) + +private theorem interchange_survivor_relabel_inr + (fs₂ : FoldSurviving (Fin (s₂ + t₂) ⊕ Fin (t₂ + u₂)) + (interfacePairs s₂ t₂ u₂)) : + (g.trans ((interfaceSurvEquiv (s₁ + s₂) (t₁ + t₂) (u₁ + u₂)).trans + finSumFinEquiv)) (Sum.inr fs₂) = + ((_root_.Equiv.sumCongr + ((interfaceSurvEquiv s₁ t₁ u₁).trans finSumFinEquiv) + ((interfaceSurvEquiv s₂ t₂ u₂).trans finSumFinEquiv)).trans + (interleaveEquiv s₁ u₁ s₂ u₂)) (Sum.inr fs₂) := by + let ieF := interleaveEquiv s₁ t₁ s₂ t₂ + let ieG := interleaveEquiv t₁ u₁ t₂ u₂ + let E := (_root_.Equiv.sumSumSumComm + (Fin (s₁+t₁)) (Fin (t₁+u₁)) (Fin (s₂+t₂)) (Fin (t₂+u₂))).trans + (_root_.Equiv.sumCongr ieF ieG) + cases hxv : fs₂.val with + | inl c => + have hc : c.val < s₂ := by + by_contra hge + exact (forall_ne_iff_not_mem_flat _ _).mp fs₂.prop + ((mem_interfacePairs_flat s₂ t₂ u₂ _).mpr + (Or.inl ⟨c, hxv, by omega⟩)) + have hie_val : (ieF (Sum.inr c)).val = + s₁ + c.val := by + change (interleaveEquiv s₁ t₁ s₂ t₂ + (Sum.inr c)).val = _ + conv_lhs => rw [show c = Fin.castAdd t₂ + ⟨c.val, hc⟩ from Fin.ext rfl, + interleaveEquiv_inr_low] + rfl + rw [_root_.Equiv.trans_apply] + conv_rhs => + rw [_root_.Equiv.trans_apply, + _root_.Equiv.sumCongr_apply, Sum.map_inr, + _root_.Equiv.trans_apply, + interfaceSurvEquiv_inl s₂ t₂ u₂ fs₂ c hxv hc, + finSumFinEquiv_apply_left, + interleaveEquiv_inr_low s₁ u₁ s₂ u₂ + ⟨c.val, hc⟩] + rw [_root_.Equiv.trans_apply] + refine (congrArg finSumFinEquiv + (interfaceSurvEquiv_inl (s₁+s₂) (t₁+t₂) (u₁+u₂) + _ (ieF (Sum.inr c)) + (by + rw [hg] + change E (Sum.inr fs₂.val) = _ + rw [hxv] + rfl) + (by rw [hie_val]; omega))).trans ?_ + rw [finSumFinEquiv_apply_left] + exact congrArg (Fin.castAdd (u₁+u₂)) + (Fin.ext hie_val) + | inr d => + have hd : t₂ ≤ d.val := by + by_contra hlt + exact (forall_ne_iff_not_mem_flat _ _).mp fs₂.prop + ((mem_interfacePairs_flat s₂ t₂ u₂ _).mpr + (Or.inr ⟨d, hxv, by omega⟩)) + have hie_val : (ieG (Sum.inr d)).val = + (t₁ + t₂) + (u₁ + (d.val - t₂)) := by + change (interleaveEquiv t₁ u₁ t₂ u₂ + (Sum.inr d)).val = _ + conv_lhs => rw [show d = Fin.natAdd t₂ + ⟨d.val - t₂, by + have := d.isLt + omega⟩ from Fin.ext (by + change d.val = t₂ + (d.val - t₂) + omega), + interleaveEquiv_inr_high] + rfl + rw [_root_.Equiv.trans_apply] + conv_rhs => + rw [_root_.Equiv.trans_apply, + _root_.Equiv.sumCongr_apply, Sum.map_inr, + _root_.Equiv.trans_apply, + interfaceSurvEquiv_inr s₂ t₂ u₂ fs₂ d hxv hd, + finSumFinEquiv_apply_right, + interleaveEquiv_inr_high s₁ u₁ s₂ u₂ + ⟨d.val - t₂, by have := d.isLt; omega⟩] + rw [_root_.Equiv.trans_apply] + refine (congrArg finSumFinEquiv + (interfaceSurvEquiv_inr (s₁+s₂) (t₁+t₂) (u₁+u₂) + _ (ieG (Sum.inr d)) + (by + rw [hg] + change E (Sum.inr fs₂.val) = _ + rw [hxv] + rfl) + (by rw [hie_val]; omega))).trans ?_ + rw [finSumFinEquiv_apply_right] + exact congrArg (Fin.natAdd (s₁+s₂)) + (Fin.ext (by + change (ieG (Sum.inr d)).val - (t₁ + t₂) = + u₁ + (d.val - t₂) + rw [hie_val] + omega)) + +private theorem interchange_survivor_relabel_eq : + g.trans ((interfaceSurvEquiv (s₁ + s₂) (t₁ + t₂) (u₁ + u₂)).trans + finSumFinEquiv) = + (_root_.Equiv.sumCongr + ((interfaceSurvEquiv s₁ t₁ u₁).trans finSumFinEquiv) + ((interfaceSurvEquiv s₂ t₂ u₂).trans finSumFinEquiv)).trans + (interleaveEquiv s₁ u₁ s₂ u₂) := by + apply _root_.Equiv.ext + intro x + cases x with + | inl fs₁ => exact interchange_survivor_relabel_inl g hg fs₁ + | inr fs₂ => exact interchange_survivor_relabel_inr g hg fs₂ + +end InterchangeSurvivor + +/-- **RHS chain**: `(F₁ ⊗ F₂) . (G₁ ⊗ G₂)` normalizes to +`(GL₁ ⊔ GL₂).relabel L_rhs`. + +The chain goes through composeNormal, ambient peel (exchange + +relabel_disjUnion), relabel peel (glueListRelabel + +mapPairs_symm_cancel), ground computation +(interchange_ground), pair permutation (glueListPerm), +append split (glueListAppend), and two-sided localization +(glueListDisjUnionLeft + glueListDisjUnionRight). -/ +noncomputable def interchangeNormalRight + {s₁ t₁ u₁ s₂ t₂ u₂ : ℕ} + (F₁ : Fragment (Fin (s₁ + t₁))) (G₁ : Fragment (Fin (t₁ + u₁))) + (F₂ : Fragment (Fin (s₂ + t₂))) (G₂ : Fragment (Fin (t₂ + u₂))) : + ((tensorFragment F₁ F₂).compose (tensorFragment G₁ G₂)).Equiv + (((glueList (F₁.disjUnion G₁) + (interfacePairs s₁ t₁ u₁) (interfacePairs_wf s₁ t₁ u₁)).disjUnion + (glueList (F₂.disjUnion G₂) + (interfacePairs s₂ t₂ u₂) (interfacePairs_wf s₂ t₂ u₂))).relabel + ((_root_.Equiv.sumCongr + ((interfaceSurvEquiv s₁ t₁ u₁).trans finSumFinEquiv) + ((interfaceSurvEquiv s₂ t₂ u₂).trans finSumFinEquiv)).trans + (interleaveEquiv s₁ u₁ s₂ u₂))) := by + -- ═══════ SETUP: the two component folds and the interfaces ═══════ + let GL₁ := glueList (F₁.disjUnion G₁) + (interfacePairs s₁ t₁ u₁) (interfacePairs_wf s₁ t₁ u₁) + let GL₂ := glueList (F₂.disjUnion G₂) + (interfacePairs s₂ t₂ u₂) (interfacePairs_wf s₂ t₂ u₂) + let A := (F₁.disjUnion G₁).disjUnion (F₂.disjUnion G₂) + let ieF := interleaveEquiv s₁ t₁ s₂ t₂ + let ieG := interleaveEquiv t₁ u₁ t₂ u₂ + let E := (_root_.Equiv.sumSumSumComm + (Fin (s₁+t₁)) (Fin (t₁+u₁)) + (Fin (s₂+t₂)) (Fin (t₂+u₂))).trans + (_root_.Equiv.sumCongr ieF ieG) + let ips_c := interfacePairs (s₁+s₂) (t₁+t₂) (u₁+u₂) + let wf_c := interfacePairs_wf (s₁+s₂) (t₁+t₂) (u₁+u₂) + let surv_c := (interfaceSurvEquiv (s₁+s₂) (t₁+t₂) (u₁+u₂)).trans + finSumFinEquiv + let surv₁ := (interfaceSurvEquiv s₁ t₁ u₁).trans finSumFinEquiv + let surv₂ := (interfaceSurvEquiv s₂ t₂ u₂).trans finSumFinEquiv + let ips₁ := interfacePairs s₁ t₁ u₁ + let ips₂ := interfacePairs s₂ t₂ u₂ + let wf₁ := interfacePairs_wf s₁ t₁ u₁ + let wf₂ := interfacePairs_wf s₂ t₂ u₂ + -- ═══════ STAGE 1: THE AMBIENT EXCHANGE ═══════ + -- AMB: peel relabels from the tensor disjoint union via exchange + have AMB : ((tensorFragment F₁ F₂).disjUnion + (tensorFragment G₁ G₂)).Equiv (A.relabel E) := + (relabelDisjUnionLeft (F₁.disjUnion F₂) + (tensorFragment G₁ G₂) ieF).trans + ((Equiv.relabelCongr + (relabelDisjUnionRight (F₁.disjUnion F₂) + (G₁.disjUnion G₂) ieG) + (_root_.Equiv.sumCongr ieF + (_root_.Equiv.refl _))).trans + ((Equiv.relabelTrans _ _ _).trans + ((Equiv.relabelEq _ + (_root_.Equiv.ext fun x => by + cases x <;> rfl)).trans + ((Equiv.relabelCongr + (disjUnionExchange F₁ F₂ G₁ G₂) + (_root_.Equiv.sumCongr ieF ieG)).trans + (Equiv.relabelTrans _ _ _))))) + -- Peeled pair list and well-formedness + let qs := Fragment.mapPairs E.symm ips_c + have wfqs : PairsWF qs := + Fragment.mapPairs_wf E.symm _ wf_c + -- rl / lr: reversed and canonical order of the decomposed pairs + let rl := inrPairs (α := Fin (s₁+t₁) ⊕ Fin (t₁+u₁)) ips₂ ++ + inlPairs (β := Fin (s₂+t₂) ⊕ Fin (t₂+u₂)) ips₁ + let lr := inlPairs (β := Fin (s₂+t₂) ⊕ Fin (t₂+u₂)) ips₁ ++ + inrPairs (α := Fin (s₁+t₁) ⊕ Fin (t₁+u₁)) ips₂ + have wf_lr : PairsWF lr := interchangePairs_wf s₁ t₁ u₁ s₂ t₂ u₂ + have wf_rl : PairsWF rl := wf_lr.perm List.perm_append_comm + -- ═══════ STAGE 2: PEELING THE COMPOSITE INTERFACE ═══════ + -- The single interface of the composite is pulled back along the + -- exchange to the two components' interfaces, one relabel at a time. + -- C5: bridge peeled pairs qs to decomposed pairs rl + have C5 := Equiv.relabelFlip' + (glueListEqEquiv A + (interchange_ground s₁ t₁ u₁ s₂ t₂ u₂) wfqs wf_rl + (List.Perm.of_eq (interchange_ground s₁ t₁ u₁ s₂ t₂ u₂))) + -- C3: peel relabel E through glueList + have C3 := (glueListRelabel A E qs wfqs).trans + ((Equiv.relabelCongr C5 + (foldSurvivingMapEquiv E qs)).trans + (Equiv.relabelTrans _ _ _)) + -- C2: bridge the composite pairs ips_c through mapPairs_symm_cancel + have C2 := (Equiv.relabelFlip' + (glueListEqEquiv (A.relabel E) + (mapPairs_symm_cancel E ips_c).symm + wf_c (Fragment.mapPairs_wf E _ wfqs) + (List.Perm.of_eq + (mapPairs_symm_cancel E ips_c).symm))).trans + ((Equiv.relabelCongr C3 + (foldSurvivingPermEquiv + ((mapPairs_symm_cancel E ips_c).symm ▸ + List.Perm.refl _)).symm).trans + (Equiv.relabelTrans _ _ _)) + -- C1: composeNormal + AMB transport + peel + have C1 := (glueListCongr AMB ips_c wf_c).trans C2 + -- ═══════ STAGE 3: REORDERING AND SPLITTING THE INTERFACE ═══════ + -- PM: permute rl → lr + have PM := glueListPerm A + (List.perm_append_comm + (l₁ := inrPairs (α := Fin (s₁+t₁) ⊕ Fin (t₁+u₁)) ips₂) + (l₂ := inlPairs (β := Fin (s₂+t₂) ⊕ Fin (t₂+u₂)) ips₁)) + wf_rl + -- APP: append split lr = inlPairs ips₁ ++ inrPairs ips₂ + have APP := glueListAppend A + (inlPairs (β := Fin (s₂+t₂) ⊕ Fin (t₂+u₂)) ips₁) + (inrPairs (α := Fin (s₁+t₁) ⊕ Fin (t₁+u₁)) ips₂) + wf_lr + -- ═══════ STAGE 4: LOCALIZING THE FIRST COMPONENT ═══════ + -- L1: first localization — glue inlPairs ips₁ in A localizes + -- to GL₁ ⊔ (F₂⊔G₂) + have L1 := glueListDisjUnionLeft + (F₁.disjUnion G₁) (F₂.disjUnion G₂) ips₁ wf₁ + -- L1G: transport second stage across L1 + have L1G := glueListCongr L1 + (liftPairs + (inlPairs (β := Fin (s₂+t₂) ⊕ Fin (t₂+u₂)) ips₁) + (inrPairs (α := Fin (s₁+t₁) ⊕ Fin (t₁+u₁)) ips₂) + wf_lr.append_sep) + (liftPairs_wf + (inlPairs (β := Fin (s₂+t₂) ⊕ Fin (t₂+u₂)) ips₁) + (inrPairs (α := Fin (s₁+t₁) ⊕ Fin (t₁+u₁)) ips₂) + wf_lr.append_right wf_lr.append_sep) + -- ═══════ STAGE 5: LOCALIZING THE SECOND COMPONENT ═══════ + -- L2B: bridge liftPairs → mapPairs via helper lemma + let e_l := (inlFoldEquiv + (β := Fin (s₂+t₂) ⊕ Fin (t₂+u₂)) ips₁).symm + have L2B := Equiv.relabelFlip' + (glueListEqEquiv + ((GL₁.disjUnion (F₂.disjUnion G₂)).relabel e_l) + (by exact liftPairs_inlPairs_inrPairs ips₁ ips₂ wf_lr.append_sep) + (liftPairs_wf _ _ wf_lr.append_right wf_lr.append_sep) + (Fragment.mapPairs_wf e_l _ + (inrPairs_wf ips₂ wf₂)) + (List.Perm.of_eq + (by + exact liftPairs_inlPairs_inrPairs ips₁ ips₂ + wf_lr.append_sep))) + -- L2R: peel e_l through second-stage glueList + have L2R := glueListRelabel + (GL₁.disjUnion (F₂.disjUnion G₂)) e_l + (inrPairs (α := FoldSurviving _ ips₁) ips₂) + (inrPairs_wf ips₂ wf₂) + -- L2D: second localization — glue inrPairs ips₂ in + -- GL₁ ⊔ (F₂⊔G₂) localizes to GL₁ ⊔ GL₂ + have L2D := glueListDisjUnionRight GL₁ + (F₂.disjUnion G₂) ips₂ wf₂ + -- L2: compose the second-stage localization chain + -- glueList (Y₁.relabel e_l) (liftPairs ...) ≃ (GL₁ ⊔ GL₂).relabel L_L2 + have L2 := L2B.trans + ((Equiv.relabelCongr + (L2R.trans + ((Equiv.relabelCongr L2D + (foldSurvivingMapEquiv e_l + (inrPairs + (α := FoldSurviving _ ips₁) ips₂))).trans + (Equiv.relabelTrans _ _ _))) + _).trans + (Equiv.relabelTrans _ _ _)) + -- ═══════ ASSEMBLY ═══════ + -- C_total: compose the full inner chain + -- glueList (TF⊔TG) ips_c wf_c ≃ (GL₁ ⊔ GL₂).relabel L_inner + have C_total := C1.trans + ((Equiv.relabelCongr (PM.trans + ((Equiv.relabelCongr (APP.trans + ((Equiv.relabelCongr (L1G.trans L2) _).trans + (Equiv.relabelTrans _ _ _))) _).trans + (Equiv.relabelTrans _ _ _))) _).trans + (Equiv.relabelTrans _ _ _)) + -- Assemble: composeNormal → C_total → label meet + exact (composeNormal (tensorFragment F₁ F₂) + (tensorFragment G₁ G₂)).trans + ((Equiv.relabelCongr C_total surv_c).trans + ((Equiv.relabelTrans _ _ _).trans + (Equiv.relabelEq _ (by + exact interchange_survivor_relabel_eq _ + (fun x => by cases x <;> rfl))))) + +/-! ### Final assembly -/ + +/-- **Interchange law**: tensoring two composites is equivalent to +composing the two tensors. -/ +noncomputable def tensorComposeInterchange + {s₁ t₁ u₁ s₂ t₂ u₂ : ℕ} + (F₁ : Fragment (Fin (s₁ + t₁))) (G₁ : Fragment (Fin (t₁ + u₁))) + (F₂ : Fragment (Fin (s₂ + t₂))) (G₂ : Fragment (Fin (t₂ + u₂))) : + (tensorFragment (F₁.compose G₁) (F₂.compose G₂)).Equiv + ((tensorFragment F₁ F₂).compose (tensorFragment G₁ G₂)) := + (interchangeNormalLeft F₁ G₁ F₂ G₂).trans + (interchangeNormalRight F₁ G₁ F₂ G₂).symm + +end Fragment + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorUnit.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorUnit.lean new file mode 100644 index 0000000000..b902192e47 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorUnit.lean @@ -0,0 +1,119 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment + +/-! +# Units of the fragment tensor + +Tensoring with the empty closed fragment is a relabel by the +arithmetic cast, on either side. These power the unitors of the +monoidal skein category. +-/ + +@[expose] public section + +namespace RS + +/-- The interleave against an empty left factor is the cast. -/ +theorem interleave_unit_left (s t : ℕ) (ℓ : Fin (s + t)) : + interleaveEquiv 0 0 s t (Sum.inr ℓ) = + finCongr (by omega : s + t = (0 + s) + (0 + t)) ℓ := by + by_cases hl : ℓ.val < s + · rw [show ℓ = Fin.castAdd t ⟨ℓ.val, hl⟩ from Fin.ext rfl, + interleaveEquiv_inr_low] + exact Fin.ext (by change 0 + ℓ.val = ℓ.val; omega) + · have hk : ℓ.val - s < t := by have := ℓ.isLt; omega + rw [show ℓ = Fin.natAdd s ⟨ℓ.val - s, hk⟩ from + Fin.ext (by change ℓ.val = s + (ℓ.val - s); omega), + interleaveEquiv_inr_high] + exact Fin.ext (by + change (0 + s) + (0 + (ℓ.val - s)) = s + (ℓ.val - s) + omega) + +/-- The interleave against an empty right factor is the cast. -/ +theorem interleave_unit_right (s t : ℕ) (ℓ : Fin (s + t)) : + interleaveEquiv s t 0 0 (Sum.inl ℓ) = + finCongr (by omega : s + t = (s + 0) + (t + 0)) ℓ := by + by_cases hl : ℓ.val < s + · rw [show ℓ = Fin.castAdd t ⟨ℓ.val, hl⟩ from Fin.ext rfl, + interleaveEquiv_inl_low] + exact Fin.ext rfl + · have hk : ℓ.val - s < t := by have := ℓ.isLt; omega + rw [show ℓ = Fin.natAdd s ⟨ℓ.val - s, hk⟩ from + Fin.ext (by change ℓ.val = s + (ℓ.val - s); omega), + interleaveEquiv_inl_high] + exact Fin.ext (by + change (s + 0) + (ℓ.val - s) = s + (ℓ.val - s) + omega) + +/-- **The left unit**: the empty fragment tensors away. -/ +noncomputable def tensorFragmentUnitLeft {s t : ℕ} + (X : Fragment (Fin (s + t))) : + (tensorFragment emptyClosedFragment X).Equiv + (X.relabel (finCongr + (by omega : s + t = (0 + s) + (0 + t)))) where + flagEquiv := + show (Empty ⊕ X.Flag) ≃ X.Flag from + _root_.Equiv.emptySum Empty X.Flag + vertexEquiv := + show (Empty ⊕ X.Vertex) ≃ X.Vertex from + _root_.Equiv.emptySum Empty X.Vertex + attach_comm := fun f => by + rcases f with f | f + · exact f.elim + · change (X.attach f).map id + (finCongr (by omega : s + t = (0 + s) + (0 + t))) = + Sum.map (show (Empty ⊕ X.Vertex) ≃ X.Vertex from + _root_.Equiv.emptySum Empty X.Vertex) id + (Sum.map id (interleaveEquiv 0 0 s t) + (Sum.map Sum.inr Sum.inr (X.attach f))) + rcases ha : X.attach f with v | ℓ + · rfl + · exact congrArg Sum.inr (interleave_unit_left s t ℓ).symm + pairing_comm := fun f => by + rcases f with f | f + · exact f.elim + · rfl + circles_eq := by + change 0 + X.circles = X.circles + omega + +/-- **The right unit**: the empty fragment tensors away. -/ +noncomputable def tensorFragmentUnitRight {s t : ℕ} + (X : Fragment (Fin (s + t))) : + (tensorFragment X emptyClosedFragment).Equiv + (X.relabel (finCongr + (by omega : s + t = (s + 0) + (t + 0)))) where + flagEquiv := + show (X.Flag ⊕ Empty) ≃ X.Flag from + _root_.Equiv.sumEmpty X.Flag Empty + vertexEquiv := + show (X.Vertex ⊕ Empty) ≃ X.Vertex from + _root_.Equiv.sumEmpty X.Vertex Empty + attach_comm := fun f => by + rcases f with f | f + · change (X.attach f).map id + (finCongr (by omega : s + t = (s + 0) + (t + 0))) = + Sum.map (show (X.Vertex ⊕ Empty) ≃ X.Vertex from + _root_.Equiv.sumEmpty X.Vertex Empty) id + (Sum.map id (interleaveEquiv s t 0 0) + (Sum.map Sum.inl Sum.inl (X.attach f))) + rcases ha : X.attach f with v | ℓ + · rfl + · exact congrArg Sum.inr (interleave_unit_right s t ℓ).symm + · exact f.elim + pairing_comm := fun f => by + rcases f with f | f + · rfl + · exact f.elim + circles_eq := by + change X.circles + 0 = X.circles + omega + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughEdgeCut.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughEdgeCut.lean new file mode 100644 index 0000000000..f64ad763bf --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughEdgeCut.lean @@ -0,0 +1,171 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GluePathMatch +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCrossDelta +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseDischarge +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PropThreeOpen + +/-! +# Transport across a through-edge cut + +A cut whose edge is a *through-edge* of the fragment -- both its +flags on the boundary -- carries no vertex data, so the colour and +vertex factors transport across the glue unchanged. The two +transports here are what the colouring recursion needs at such a +cut. +-/ + +@[expose] public section + +namespace RS + + + +namespace EdgeSubset + +open Fragment + +/-! ## The shared participating context -/ + +variable {α : Type} {W : Fragment α} {i j : α} + (hij : i ≠ j) + (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) + (s' : Finset (SurvivingFlag W i j)) + (hc' : ∀ f ∈ s', (W.gluePairOpen i j hij hopen).pairing f ∈ s') + (hc : ∀ f ∈ liftSubsetOpen hopen s', + W.pairing f ∈ liftSubsetOpen hopen s') + (hpi : partnerSurvI hopen ∈ s') + +/-- The glued edge subset. -/ +local notation "Fg" => + (EdgeSubset.mk s' hc' : EdgeSubset (W.gluePairOpen i j hij hopen)) + +/-- The lifted edge subset. -/ +local notation "Fl" => + (EdgeSubset.mk (liftSubsetOpen hopen s') hc : EdgeSubset W) + +/-! ## The even-colouring layer (participating, any configuration) -/ + +/-- Finset-supported multisets map equally along a bijection of +their supports. -/ +theorem multiset_map_eq_of_bijT {γ δ X : Type _} + (s : Finset γ) (t : Finset δ) + (e : δ → γ) (hinj : Function.Injective e) + (hmem : ∀ y, y ∈ t ↔ e y ∈ s) + (hsurj : ∀ x ∈ s, ∃ y, e y = x) + (g : γ → X) (g' : δ → X) + (hg : ∀ y ∈ t, g (e y) = g' y) : + s.val.map g = t.val.map g' := by + have hset : s = t.map ⟨e, hinj⟩ := by + ext x + rw [Finset.mem_map] + constructor + · intro hx + obtain ⟨y, rfl⟩ := hsurj x hx + exact ⟨y, (hmem y).mpr hx, rfl⟩ + · rintro ⟨y, hy, rfl⟩ + exact (hmem y).mp hy + rw [hset, + show (t.map ⟨e, hinj⟩).val = t.val.map e from rfl, + Multiset.map_map] + refine Multiset.map_congr rfl ?_ + intro y hy + exact hg y (Finset.mem_val.mp hy) + +/-- The even colour multiset agrees (participating case). -/ +theorem evenColoursAt_transport_T + [LinearOrder α] + {k : ℕ} + (ψW : (Fl).EvenColouring k) (ψ' : (Fg).EvenColouring k) + (hψ : ∀ (g : SurvivingFlag W i j) + (h1 : g.val ∉ liftSubsetOpen hopen s') (h2 : g ∉ s'), + ψW.val ⟨g.val, h1⟩ = ψ'.val ⟨g, h2⟩) + (v : W.Vertex) : + (Fl).evenColoursAt ψW v = (Fg).evenColoursAt ψ' v := by + have hemb : ∀ x : {f' : (W.gluePairOpen i j hij hopen).Flag // + f' ∉ (Fg).flags}, + x.val.val ∉ (Fl).flags := by + intro x hmem + exact x.prop ((surviving_val_mem_liftOpen_iff hopen s' + x.val).mp hmem) + have hinj : Function.Injective + (fun x : {f' : (W.gluePairOpen i j hij hopen).Flag // + f' ∉ (Fg).flags} => + (⟨x.val.val, hemb x⟩ : {f : W.Flag // f ∉ (Fl).flags})) + := by + intro x y hxy + have hxy' : (⟨x.val.val, hemb x⟩ : + {f : W.Flag // f ∉ (Fl).flags}) = ⟨y.val.val, hemb y⟩ := + hxy + have hval : x.val.val = y.val.val := congrArg + (fun z : {f : W.Flag // f ∉ (Fl).flags} => z.val) hxy' + exact Subtype.ext (Subtype.ext hval) + unfold EdgeSubset.evenColoursAt + refine multiset_map_eq_of_bijT _ _ + (fun x => ⟨x.val.val, hemb x⟩) hinj ?_ ?_ ψW.val ψ'.val ?_ + · intro y + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + exact glueAttach_inl_iff y.val v + · intro x hx + simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hx + have hsurv := vertex_flag_surviving (i := i) (j := j) + x.val v hx + have hnot : (⟨x.val, hsurv.1, hsurv.2⟩ : + SurvivingFlag W i j) ∉ s' := by + intro hmem + exact x.prop ((surviving_val_mem_liftOpen_iff hopen s' + ⟨x.val, hsurv.1, hsurv.2⟩).mpr hmem) + exact ⟨⟨⟨x.val, hsurv.1, hsurv.2⟩, hnot⟩, Subtype.ext rfl⟩ + · intro y _ + exact hψ y.val (hemb y) y.prop + +section VertexTransport + +variable + (κ' : (EdgeSubset.mk s' hc' : + EdgeSubset (W.gluePairOpen i j hij hopen)).RelTransitionSystem) + (o' : κ'.Orientation) + +local notation "κW" => + RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ' + +local notation "oW" => + unglueOrientationOpen hij hopen s' hc' hc κ' o' + +/-- **The vertex factor transport (participating case).** -/ +theorem vertexFactor_transport_T + [LinearOrder α] + {k ℓ : ℕ} + (h : MixedFunctional k ℓ) + (ψW : (Fl).EvenColouring k) (ψ' : (Fg).EvenColouring k) + (hψ : ∀ (g : SurvivingFlag W i j) + (h1 : g.val ∉ liftSubsetOpen hopen s') (h2 : g ∉ s'), + ψW.val ⟨g.val, h1⟩ = ψ'.val ⟨g, h2⟩) + (φW : (Fl).CoreOddColouring ℓ) (φ' : (Fg).CoreOddColouring ℓ) + (hφ : ∀ (g : SurvivingFlag W i j) + (h1 : g.val ∈ (Fl).coreFlags) (h2 : g ∈ (Fg).coreFlags), + φW.val ⟨g.val, h1⟩ = φ'.val ⟨g, h2⟩) + (v : W.Vertex) : + ((Fl).coreOddSignAt (oW) φW v : ℂ) * + h.evalOdd ((Fl).evenColoursAt ψW v) + ((Fl).coreOddListAt (oW) φW v) = + ((Fg).coreOddSignAt o' φ' v : ℂ) * + h.evalOdd ((Fg).evenColoursAt ψ' v) + ((Fg).coreOddListAt o' φ' v) := by + rw [coreOddSignAt_transport_open hij hopen s' hc' hc κ' o' + φW φ' hφ v, + evenColoursAt_transport_T hij hopen s' hc' hc ψW ψ' hψ v, + evalOdd_coreOddListAt_transport_open hij hopen s' hc' hc + κ' o' h φW φ' hφ ((Fg).evenColoursAt ψ' v) v] + +end VertexTransport + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughIndCFalse.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughIndCFalse.lean new file mode 100644 index 0000000000..c9ca98a077 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughIndCFalse.lean @@ -0,0 +1,100 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopVerify + +/-! +# The corrected independence interface is refutable across pairings + +`ThroughIndependenceC` quantifies over *all* pairs of transition +systems, including pairs with different boundary pairings. On the +worked one-vertex instance the two matchings `cKappa` (chords +`(0,1), (2,3)`) and its repair (chords `(0,3), (1,2)`) both carry +path-canonical orientations (`cO`, `lvO₂flip`), both with trivial +chord sign, yet the constrained summands differ: `−1` versus `0`. +The canonical value genuinely depends on the boundary pairing — +Proposition 3 for open fragments can only assert independence +*within* a pairing (`signedValueAt_samePairing`), and the +interfaces consuming `ThroughIndependenceC` must be re-based on +the pairing-resolved value. +-/ + +@[expose] public section + +namespace RS + + + +namespace TransposeVerify + +/-- `cO` is path-canonical: both chains run low-to-high with +incoming entry edges (`isOut 0 = isOut 3 = false`). -/ +theorem cO_pathCanonical : EdgeSubset.PathCanonical cO := by + intro i j hb hint hpm hij + fin_cases i + · rfl + · have h5 : (5 : Fin 8) ∈ cSubset.boundaryFlags := + cMem_boundary 1 rfl + have h := (cPM_5 h5).symm.trans hpm + fin_cases j + · exact absurd hij (by decide) + · exact absurd h (by decide) + · exact absurd h (by decide) + · exact absurd h (by decide) + · rfl + · have h7 : (7 : Fin 8) ∈ cSubset.boundaryFlags := + cMem_boundary 3 rfl + have h := (cPM_7 h7).symm.trans hpm + fin_cases j + · exact absurd h (by decide) + · exact absurd h (by decide) + · exact absurd hij (by decide) + · exact absurd h (by decide) + +/-- `lvO₂flip` is path-canonical on the repaired system: the +repaired chords are `(0,3)` and `(1,2)`, and both low-end entry +edges are incoming (`isOut 0 = isOut 1 = false`). -/ +theorem lvO₂flip_pathCanonical : + EdgeSubset.PathCanonical lvO₂flip := by + intro i j hb hint hpm hij + fin_cases i + · rfl + · rfl + · have h6 : (6 : Fin 8) ∈ cSubset.boundaryFlags := + cMem_boundary 2 rfl + have h := (cPM'_6 h6).symm.trans hpm + fin_cases j + · exact absurd h (by decide) + · exact absurd hij (by decide) + · exact absurd h (by decide) + · exact absurd h (by decide) + · have h7 : (7 : Fin 8) ∈ cSubset.boundaryFlags := + cMem_boundary 3 rfl + have h := (cPM'_7 h7).symm.trans hpm + fin_cases j + · exact absurd hij (by decide) + · exact absurd h (by decide) + · exact absurd h (by decide) + · exact absurd h (by decide) + +/-- **The cross-pairing refutation**: the corrected independence +interface fails between path-canonical data with different +boundary pairings — the signed canonical values are `−1` and `0`. -/ +theorem not_throughIndependenceC : ¬ ThroughIndependenceC := by + intro H + have h := H cSubset cFunctional cState cBnd + (κ := cKappa) (κ' := lvKappa₂R) cO lvO₂flip + cO_pathCanonical lvO₂flip_pathCanonical + rw [cCount_zero, cCount_zero, cPathSign_kappa, cSummand_O, + show EdgeSubset.pathSign lvKappa₂R = 1 from cPathSign_repair, + lvSummand₂flip] at h + norm_num at h + +end TransposeVerify + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughValue.lean new file mode 100644 index 0000000000..ab8f9cecfe --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughValue.lean @@ -0,0 +1,230 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.OpenCircuits + +/-! +# Through-edges and the corrected constrained value + +A participating edge of an open fragment both of whose flags are +boundary flags (a *through-edge*) carries no vertex data; its two +ends must take independent state colours, paired by the symplectic +copairing — full pairing-constancy of the odd colouring would +force the two ends equal, exactly where the symplectic weight +vanishes. This file splits the participating flags into core and +through parts, restricts the odd colouring to the core, and +defines the corrected constrained summand: the core colouring sum +times an explicit symplectic factor per through-edge, oriented by +the label order. + +Even colourings stay fully pairing-constant: the even gluing +weight is diagonal, which pairing-constancy implements already. +-/ + +@[expose] public section + +namespace RS + +variable {α : Type} {W : Fragment α} + +namespace EdgeSubset + +/-! ## Core and through flags -/ + +open scoped Classical in +/-- The through-flags: participating flags on boundary–boundary +edges. -/ +noncomputable def throughFlags (F : EdgeSubset W) : Finset W.Flag := + F.flags.filter (fun f => (∃ i : α, W.attach f = Sum.inr i) ∧ + (∃ j : α, W.attach (W.pairing f) = Sum.inr j)) + +/-- The core flags: participating flags on edges with at least one +internal end. -/ +noncomputable def coreFlags (F : EdgeSubset W) : Finset W.Flag := + F.flags \ F.throughFlags + +/-- Core flags participate. -/ +theorem coreFlags_subset (F : EdgeSubset W) : + F.coreFlags ⊆ F.flags := + Finset.sdiff_subset + +open scoped Classical in +/-- A participating flag is core when it or its edge partner meets +a vertex — through-edges, meeting none, are excluded. -/ +theorem mem_coreFlags_iff (F : EdgeSubset W) {f : W.Flag} : + f ∈ F.coreFlags ↔ f ∈ F.flags ∧ + ((∃ v : W.Vertex, W.attach f = Sum.inl v) ∨ + (∃ v : W.Vertex, W.attach (W.pairing f) = Sum.inl v)) := by + unfold coreFlags throughFlags + rw [Finset.mem_sdiff, Finset.mem_filter] + constructor + · rintro ⟨hf, hnot⟩ + refine ⟨hf, ?_⟩ + by_contra hc + push Not at hc + obtain ⟨h1, h2⟩ := hc + refine hnot ⟨hf, ?_, ?_⟩ + · rcases hx : W.attach f with v | i + · exact absurd hx (h1 v) + · exact ⟨i, rfl⟩ + · rcases hx : W.attach (W.pairing f) with v | i + · exact absurd hx (h2 v) + · exact ⟨i, rfl⟩ + · rintro ⟨hf, hor⟩ + refine ⟨hf, fun hthr => ?_⟩ + obtain ⟨_, ⟨i, hi⟩, ⟨j, hj⟩⟩ := hthr + rcases hor with ⟨v, hv⟩ | ⟨v, hv⟩ + · rw [hv] at hi; cases hi + · rw [hv] at hj; cases hj + +/-- The pairing preserves the core flags. -/ +theorem pairing_mem_coreFlags (F : EdgeSubset W) {f : W.Flag} + (hf : f ∈ F.coreFlags) : W.pairing f ∈ F.coreFlags := by + rw [mem_coreFlags_iff] at hf ⊢ + refine ⟨F.pairing_mem _ hf.1, ?_⟩ + rcases hf.2 with h | h + · right; rwa [W.pairing_invol] + · left; exact h + +/-- Internal flags are core flags. -/ +theorem internalFlags_subset_coreFlags (F : EdgeSubset W) : + F.internalFlags ⊆ F.coreFlags := by + classical + intro f hf + rw [mem_coreFlags_iff] + have h := Finset.mem_filter.mp hf + exact ⟨h.1, Or.inl h.2⟩ + +/-! ## The core odd colouring -/ + +/-- Odd colourings of the core: pairing-constant colours on the +participating flags of edges with an internal end. -/ +def CoreOddColouring (F : EdgeSubset W) (ℓ : ℕ) : Type := + {φ : {f : W.Flag // f ∈ F.coreFlags} → Fin (2 * ℓ) // + ∀ f : {f : W.Flag // f ∈ F.coreFlags}, + φ ⟨W.pairing f.val, F.pairing_mem_coreFlags f.prop⟩ = φ f} + +open scoped Classical in +/-- Core odd colourings are finite in number, so the summand's sum +over them is a finite sum. -/ +noncomputable instance CoreOddColouring.instFintype + (F : EdgeSubset W) (ℓ : ℕ) : Fintype (F.CoreOddColouring ℓ) := by + unfold CoreOddColouring + infer_instance + +/-! ## Vertex-local data over the core colouring -/ + +open Classical in +/-- The odd pair contributed by an incoming internal flag, from the +core colouring. -/ +noncomputable def coreOddPairFn (F : EdgeSubset W) {ℓ : ℕ} + (κ : F.RelTransitionSystem) (φ : F.CoreOddColouring ℓ) + (f : {f : W.Flag // f ∈ F.internalFlags}) : + List (Fin (2 * ℓ)) := + [φ.val ⟨f.val, F.internalFlags_subset_coreFlags f.prop⟩, + oddPartner ℓ (φ.val ⟨κ.match_ f.val, + F.internalFlags_subset_coreFlags (κ.match_mem _ f.prop)⟩)] + +open Classical in +/-- The odd-pairing sign contributed by an incoming internal flag, +from the core colouring. -/ +noncomputable def coreOddSignFn (F : EdgeSubset W) {ℓ : ℕ} + (κ : F.RelTransitionSystem) (φ : F.CoreOddColouring ℓ) + (f : {f : W.Flag // f ∈ F.internalFlags}) : ℤ := + oddPartnerSign ℓ (φ.val ⟨κ.match_ f.val, + F.internalFlags_subset_coreFlags (κ.match_mem _ f.prop)⟩) + +open Classical in +/-- The odd-colour list at a vertex, from the core colouring. -/ +noncomputable def coreOddListAt (F : EdgeSubset W) {ℓ : ℕ} + {κ : F.RelTransitionSystem} (o : κ.Orientation) + (φ : F.CoreOddColouring ℓ) (v : W.Vertex) : + List (Fin (2 * ℓ)) := + ((F.relInFlagsAt o v).attachWith (· ∈ F.internalFlags) + (fun _ hf => F.mem_internal_of_mem_relInFlagsAt hf)).flatMap + (F.coreOddPairFn κ φ) + +open Classical in +/-- The odd-pairing sign at a vertex, from the core colouring. -/ +noncomputable def coreOddSignAt (F : EdgeSubset W) {ℓ : ℕ} + {κ : F.RelTransitionSystem} (o : κ.Orientation) + (φ : F.CoreOddColouring ℓ) (v : W.Vertex) : ℤ := + (((F.relInFlagsAt o v).attachWith (· ∈ F.internalFlags) + (fun _ hf => F.mem_internal_of_mem_relInFlagsAt hf)).map + (F.coreOddSignFn κ φ)).prod + +end EdgeSubset + +/-! ## The through-edge symplectic factor -/ + +/-- The symplectic copairing weight of an odd through-edge: nonzero +exactly on partner colours, with the partner sign of the +lower-label end. (The sign convention is validated by the strand +identity in the gluing decomposition.) -/ +noncomputable def oddThroughFactor (ℓ : ℕ) + (c c' : Fin (2 * ℓ)) : ℂ := + if c' = oddPartner ℓ c then (oddPartnerSign ℓ c : ℂ) else 0 + +/-- The state weight of a through-edge, by the parity of its two +end states: diagonal on even colours, symplectic on odd colours, +zero on mixed parities. -/ +noncomputable def throughStateFactor {k ℓ : ℕ} + (c c' : Fin k ⊕ Fin (2 * ℓ)) : ℂ := + match c, c' with + | Sum.inl a, Sum.inl a' => if a' = a then 1 else 0 + | Sum.inr b, Sum.inr b' => oddThroughFactor ℓ b b' + | _, _ => 0 + +namespace EdgeSubset + +open scoped Classical in +/-- The through-edge state weight of an edge subset: each +through-edge contributes its state factor exactly once, from its +lower-label flag. -/ +noncomputable def throughProduct [LinearOrder α] {k ℓ : ℕ} + (F : EdgeSubset W) (st : GenBoundaryState k ℓ α) : ℂ := + ∏ f ∈ F.throughFlags.attach, + match W.attach f.val, W.attach (W.pairing f.val) with + | Sum.inr i, Sum.inr j => + if i < j then throughStateFactor (st i) (st j) else 1 + | _, _ => 1 + +/-- The core odd boundary constraint: the state's odd colours are +imposed on the core boundary flags (through-edges are constrained +by the through factor instead). -/ +def coreOddBoundaryMatch {k ℓ : ℕ} (F : EdgeSubset W) + (st : GenBoundaryState k ℓ α) + (φ : F.CoreOddColouring ℓ) : Prop := + ∀ (i : α) (c : Fin (2 * ℓ)) (_ : st i = Sum.inr c) + (hcore : W.boundaryFlag i ∈ F.coreFlags), + φ.val ⟨W.boundaryFlag i, hcore⟩ = c + +open Classical in +/-- **The corrected constrained summand**: circuit sign, through +factor, and the core colouring sum. -/ +noncomputable def throughSummand [LinearOrder α] + (F : EdgeSubset W) {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ : F.RelTransitionSystem} (o : κ.Orientation) (c : ℕ) : ℂ := + ((-1 : ℂ) ^ c) * F.throughProduct st * + ∑ ψ : F.EvenColouring k, + if genEvenBoundaryMatch F st hbnd ψ then + ∑ φ : F.CoreOddColouring ℓ, + if F.coreOddBoundaryMatch st φ then + ∏ v : W.Vertex, + ((F.coreOddSignAt o φ v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) + (F.coreOddListAt o φ v)) + else 0 + else 0 + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/Trace.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/Trace.lean new file mode 100644 index 0000000000..891afb26d8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/Trace.lean @@ -0,0 +1,66 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StrandBundle +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomSpaces + +/-! +# The categorical trace on Hom spaces + +The trace of a `(t + t)`-fragment is its full strand closure: the +closure pairing against the strand bundle, which threads each +output label back to the matching input. The trace functional is +therefore the connection pairing evaluated at the bundle; it kills +the pairing kernel by construction and so descends to the Hom +spaces of the skein category. +-/ + +@[expose] public section + +namespace RS + +/-- The trace of a `(t + t)`-fragment under a parameter: the value +of its strand closure. -/ +noncomputable def fragTrace (f : ClosedFragment → ℂ) {t : ℕ} + (F : Fragment (Fin (t + t))) : ℂ := + f (pairClose F (strandBundle t)) + +/-- The trace as a linear functional on the free module: the +connection pairing evaluated at the strand bundle. -/ +noncomputable def traceFunctional (f : ClosedFragment → ℂ) (t : ℕ) : + (Fragment (Fin (t + t)) →₀ ℂ) →ₗ[ℂ] ℂ := + (LinearMap.proj (strandBundle t)).comp (connectionMap f (t + t)) + +/-- The trace functional on a single fragment is its trace. -/ +theorem traceFunctional_single (f : ClosedFragment → ℂ) {t : ℕ} + (F : Fragment (Fin (t + t))) : + traceFunctional f t (Finsupp.single F 1) = fragTrace f F := by + simp [traceFunctional, fragTrace, connectionMap, connectionPairing] + +/-- The pairing kernel is contained in the trace kernel. -/ +theorem ker_le_ker_traceFunctional (f : ClosedFragment → ℂ) (t : ℕ) : + LinearMap.ker (connectionMap f (t + t)) ≤ + LinearMap.ker (traceFunctional f t) := fun x hx => by + rw [LinearMap.mem_ker] at hx ⊢ + rw [traceFunctional, LinearMap.comp_apply, hx] + rfl + +/-- The trace descends to the Hom space. -/ +noncomputable def HomSpace.traceMap (f : ClosedFragment → ℂ) (t : ℕ) : + HomSpace f (t + t) →ₗ[ℂ] ℂ := + Submodule.liftQ _ (traceFunctional f t) + (ker_le_ker_traceFunctional f t) + +/-- The descended trace on a fragment class is the fragment +trace. -/ +theorem HomSpace.traceMap_ofFragment (f : ClosedFragment → ℂ) + {t : ℕ} (F : Fragment (Fin (t + t))) : + HomSpace.traceMap f t (HomSpace.ofFragment f F) = fragTrace f F := by + exact traceFunctional_single f F + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceCyclic.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceCyclic.lean new file mode 100644 index 0000000000..76350122af --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceCyclic.lean @@ -0,0 +1,191 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceShift +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairCloseComm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLaw +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Trace + +/-! +# Cyclicity of the trace + +The trace of a composition is independent of the order +(`fragTrace_comm`, accompanying paper, Lemma 3.5(a)): closing +`F ∘ G` by the strand bundle and closing `G ∘ F` by the strand +bundle produce isomorphic closed fragments. Both reduce, by the rotation +(`pairCloseComposeRotate`) and the identity law +(`composeStrandBundleLeft`), to the closure of `F` against a +transposed copy of `G`; the two reductions are matched by the +commutativity of the closure and the closure-relabel exchange +(`pairCloseRelabel`), itself derived from `interfaceShift` at +`s = 0`, where the outgoing block is the entire boundary. +-/ + +@[expose] public section + +namespace RS + +/-- The inverse of the transpose is the reverse transpose. -/ +theorem transposeEquiv_symm (n p : ℕ) : + (transposeEquiv n p).symm = transposeEquiv p n := by + apply _root_.Equiv.ext + intro x + by_cases hx : x.val < p + · rw [show x = (⟨x.val, x.isLt⟩ : Fin (p + n)) from Fin.ext rfl, + transposeEquiv_symm_low n p x.val hx, + transposeEquiv_low p n x.val hx] + all_goals omega + · have hj : x.val - p < n := by have := x.isLt; omega + rw [show x = (⟨p + (x.val - p), by have := x.isLt; omega⟩ : + Fin (p + n)) from Fin.ext + (by change x.val = p + (x.val - p); omega), + transposeEquiv_symm_high n p (x.val - p) hj, + transposeEquiv_high p n (x.val - p) hj] + all_goals omega + +/-- The closure respects fragment equivalence in both slots. -/ +noncomputable def pairCloseCongr {t : ℕ} + {F₁ F₂ G₁ G₂ : Fragment (Fin t)} + (hF : F₁.Equiv F₂) (hG : G₁.Equiv G₂) : + (pairClose F₁ G₁).Equiv (pairClose F₂ G₂) := + Fragment.composeCongr + (Fragment.Equiv.relabelCongr hF _) + (Fragment.Equiv.relabelCongr hG _) + +/-- Label algebra: post-composing a boundary permutation with the +low cast is pre-composing the cast with the outgoing permutation +at `s = 0`. -/ +theorem cast_trans_outPerm {t : ℕ} (e : Equiv.Perm (Fin t)) : + e.trans (finCongr (by omega : t = 0 + t)) = + (finCongr (by omega : t = 0 + t)).trans (outPermEquiv 0 e) := by + apply _root_.Equiv.ext + intro j + simp only [_root_.Equiv.trans_apply] + rw [show (finCongr (by omega : t = 0 + t) j : Fin (0 + t)) = + Fin.natAdd 0 j from Fin.ext (by change j.val = 0 + j.val; omega), + outPermEquiv_high 0 e j] + exact Fin.ext (by change (e j).val = 0 + (e j).val; omega) + +/-- Label algebra: post-composing the inverse boundary permutation +with the high cast is pre-composing the cast with the incoming +permutation at `u = 0`. -/ +theorem cast_trans_inPerm {t : ℕ} (e : Equiv.Perm (Fin t)) : + e.symm.trans (finCongr (by omega : t = t + 0)) = + (finCongr (by omega : t = t + 0)).trans + (inPermEquiv e.symm 0) := by + apply _root_.Equiv.ext + intro j + simp only [_root_.Equiv.trans_apply] + rw [show (finCongr (by omega : t = t + 0) j : Fin (t + 0)) = + Fin.castAdd 0 j from Fin.ext rfl, + inPermEquiv_low e.symm 0 j] + exact Fin.ext rfl + +/-- The closure-relabel exchange for boundary permutations: +relabelling the first factor of a closure by a permutation is +relabelling the second by the inverse. Instance of +`interfaceShift` at `s = 0`, where the outgoing block is the +whole boundary. -/ +noncomputable def pairCloseRelabelPerm {t : ℕ} + (e : Equiv.Perm (Fin t)) (X Y : Fragment (Fin t)) : + (pairClose (X.relabel e) Y).Equiv + (pairClose X (Y.relabel e.symm)) := + (Fragment.composeCongr + ((Fragment.Equiv.relabelTrans X e + (finCongr (by omega : t = 0 + t))).trans + ((Fragment.Equiv.relabelEq X (cast_trans_outPerm e)).trans + (Fragment.Equiv.relabelTrans X + (finCongr (by omega : t = 0 + t)) + (outPermEquiv 0 e)).symm)) + (Fragment.Equiv.refl + (Y.relabel (finCongr (by omega : t = t + 0))))).trans + ((interfaceShift e + (X.relabel (finCongr (by omega : t = 0 + t))) + (Y.relabel (finCongr (by omega : t = t + 0)))).trans + (Fragment.composeCongr + (Fragment.Equiv.refl + (X.relabel (finCongr (by omega : t = 0 + t)))) + ((Fragment.Equiv.relabelTrans Y + (finCongr (by omega : t = t + 0)) + (inPermEquiv e.symm 0)).trans + ((Fragment.Equiv.relabelEq Y + (cast_trans_inPerm e).symm).trans + (Fragment.Equiv.relabelTrans Y e.symm + (finCongr (by omega : t = t + 0))).symm)))) + +/-- The closure-relabel exchange across a pure cast. -/ +noncomputable def pairCloseCast {a b : ℕ} (h : a = b) + (X : Fragment (Fin a)) (Y : Fragment (Fin b)) : + (pairClose (X.relabel (finCongr h)) Y).Equiv + (pairClose X (Y.relabel (finCongr h.symm))) := by + subst h + exact pairCloseCongr + (Fragment.Equiv.relabelRefl X) + (Fragment.Equiv.relabelRefl Y).symm + +/-- **The closure-relabel exchange**: relabelling the first factor +of a closure is relabelling the second factor by the inverse +label equivalence. -/ +noncomputable def pairCloseRelabel {a b : ℕ} (e : Fin a ≃ Fin b) + (X : Fragment (Fin a)) (Y : Fragment (Fin b)) : + (pairClose (X.relabel e) Y).Equiv + (pairClose X (Y.relabel e.symm)) := by + have h : a = b := by simpa using Fintype.card_congr e + have hsplit : e = (finCongr h).trans + ((finCongr h).symm.trans e) := + _root_.Equiv.ext fun _ => rfl + have hsymm : (((finCongr h).symm.trans e).symm.trans + (finCongr h.symm)) = e.symm := + _root_.Equiv.ext fun _ => rfl + exact (pairCloseCongr + ((Fragment.Equiv.relabelEq X hsplit).trans + (Fragment.Equiv.relabelTrans X (finCongr h) + ((finCongr h).symm.trans e)).symm) + (Fragment.Equiv.refl Y)).trans + ((pairCloseRelabelPerm ((finCongr h).symm.trans e) + (X.relabel (finCongr h)) Y).trans + ((pairCloseCast h X + (Y.relabel ((finCongr h).symm.trans e).symm)).trans + (pairCloseCongr (Fragment.Equiv.refl X) + ((Fragment.Equiv.relabelTrans Y + ((finCongr h).symm.trans e).symm + (finCongr h.symm)).trans + (Fragment.Equiv.relabelEq Y hsymm))))) + +/-- **Cyclicity of the trace** (accompanying paper, Lemma 3.5(a)): +for an +isomorphism-invariant parameter, the trace of a composition does +not depend on the order of the factors. -/ +theorem fragTrace_comm (f : ClosedFragment → ℂ) + (hf : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) + {t u : ℕ} (F : Fragment (Fin (t + u))) + (G : Fragment (Fin (u + t))) : + fragTrace f (F.compose G) = fragTrace f (G.compose F) := by + have E1 : (pairClose (F.compose G) (strandBundle t)).Equiv + (pairClose F (G.relabel (transposeEquiv u t))) := + (pairCloseComposeRotate F G (strandBundle t)).trans + (pairCloseCongr (Fragment.Equiv.refl F) + (composeStrandBundleLeft t u + (G.relabel (transposeEquiv u t)))) + have E2 : (pairClose (G.compose F) (strandBundle u)).Equiv + (pairClose F (G.relabel (transposeEquiv u t))) := + (pairCloseComposeRotate G F (strandBundle u)).trans + ((pairCloseCongr (Fragment.Equiv.refl G) + (composeStrandBundleLeft u t + (F.relabel (transposeEquiv t u)))).trans + ((Fragment.pairCloseComm G + (F.relabel (transposeEquiv t u))).trans + ((pairCloseRelabel (transposeEquiv t u) F G).trans + (pairCloseCongr (Fragment.Equiv.refl F) + (Fragment.Equiv.relabelEq G + (transposeEquiv_symm t u)))))) + unfold fragTrace + rw [hf _ _ E1, hf _ _ E2] + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceNondegenerate.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceNondegenerate.lean new file mode 100644 index 0000000000..76ba8f7d3d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceNondegenerate.lean @@ -0,0 +1,100 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal + +/-! +# Zero negligibles: nondegeneracy of the trace pairing + +The accompanying paper's Lemma 3.6: the trace closure of `x` +against a test fragment differs from the defining connection +pairing only by the fixed +transpose relabeling of the open ends — a bijection on fragments — +so the two test families coincide, and an element all of whose +traces vanish lies in the pairing kernel. +-/ + +@[expose] public section + +namespace RS + +/-- The trace of a composition is the connection pairing against +the transposed test fragment: the trace closure is the defining +pairing up to a relabeling. -/ +theorem fragTrace_compose_eq_pairing (f : ClosedFragment → ℂ) + (hf : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) + {t u : ℕ} (F : Fragment (Fin (t + u))) + (G : Fragment (Fin (u + t))) : + fragTrace f (F.compose G) = + connectionPairing f (t + u) F + (G.relabel (transposeEquiv u t)) := + hf _ _ ((pairCloseComposeRotate F G (strandBundle t)).trans + (pairCloseCongr (Fragment.Equiv.refl F) + (composeStrandBundleLeft t u + (G.relabel (transposeEquiv u t))))) + +/-- Every connection row is a family of traces: the row of `x` at +the test fragment `H` is the trace of `x` composed with the +un-transposed `H`. -/ +theorem connectionMap_eq_trace_row (f : ClosedFragment → ℂ) + (hf : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) + {t u : ℕ} (x : Fragment (Fin (t + u)) →₀ ℂ) + (H : Fragment (Fin (t + u))) : + connectionMap f (t + u) x H = + traceFunctional f t (composeFinsupp t u t x + (Finsupp.single + (H.relabel (transposeEquiv u t).symm) 1)) := by + induction x using Finsupp.induction_linear with + | zero => + rw [map_zero, map_zero, LinearMap.zero_apply, map_zero] + rfl + | add y z hy hz => + rw [map_add] + change connectionMap f (t + u) y H + + connectionMap f (t + u) z H = _ + rw [hy, hz, map_add, LinearMap.add_apply, map_add] + | single F c => + rw [composeFinsupp_single, mul_one, connectionMap_single] + have h1 : (Finsupp.single + (F.compose (H.relabel (transposeEquiv u t).symm)) c) = + c • Finsupp.single + (F.compose (H.relabel (transposeEquiv u t).symm)) + (1 : ℂ) := by + rw [Finsupp.smul_single, smul_eq_mul, mul_one] + rw [h1, map_smul, traceFunctional_single, smul_eq_mul, + fragTrace_compose_eq_pairing f hf] + have h2 : connectionPairing f (t + u) F + ((H.relabel (transposeEquiv u t).symm).relabel + (transposeEquiv u t)) = + connectionPairing f (t + u) F H := + hf _ _ (pairCloseCongr (Fragment.Equiv.refl F) + ((Fragment.Equiv.relabelTrans H + (transposeEquiv u t).symm (transposeEquiv u t)).trans + ((Fragment.Equiv.relabelEq H + (_root_.Equiv.symm_trans_self + (transposeEquiv u t))).trans + (Fragment.Equiv.relabelRefl H)))) + rw [h2] + +/-- **Zero negligibles** (accompanying paper, Lemma 3.6): an element +all of whose composition traces vanish lies in the pairing +kernel. -/ +theorem mem_ker_of_traces_vanish (f : ClosedFragment → ℂ) + (hf : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) + {t u : ℕ} (x : Fragment (Fin (t + u)) →₀ ℂ) + (hx : ∀ G : Fragment (Fin (u + t)), + traceFunctional f t + (composeFinsupp t u t x (Finsupp.single G 1)) = 0) : + x ∈ LinearMap.ker (connectionMap f (t + u)) := by + rw [LinearMap.mem_ker] + funext H + rw [connectionMap_eq_trace_row f hf x H, hx] + rfl + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean new file mode 100644 index 0000000000..7bbdb36264 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean @@ -0,0 +1,499 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition + +/-! +# Existence of transition systems with orientations + +Every Eulerian edge subset whose participating flags all attach to +internal vertices admits a transition system equipped with an +orientation. The construction proceeds in two parts: + +1. **The matching κ** (Part 1): at each vertex the participating flags + have even cardinality (from the Eulerian condition); a fixed-point-free + involution matching flags at common vertices is built by the finite + combinatorial lemma `exists_involution_of_even`, applied per-vertex + and glued into a global function. + +2. **The orientation** (Part 2): the edge pairing σ conjugates the + walk permutation to its inverse; this forces the walk-orbit of f and + of σ f to be disjoint for every participating f. An orientation is + obtained by choosing, for each orbit-pair, one side as "out" using + orbit representatives under the flag order. +-/ + +@[expose] public section + +namespace RS + +/-! ### The involution lemma -/ + +open Classical in +/-- A finset of even cardinality admits a fixed-point-free involution +mapping the set to itself. Proved by strong induction on the finset: +for cardinality 0 the properties are vacuous; for cardinality ≥ 2 pick +two distinct elements, match them, and recurse on the remainder. -/ +theorem exists_involution_of_even {β : Type} + (s : Finset β) (hs : Even s.card) : + ∃ m : β → β, (∀ x ∈ s, m x ∈ s) ∧ + (∀ x ∈ s, m (m x) = x) ∧ (∀ x ∈ s, m x ≠ x) := by + classical + revert hs + exact s.strongInductionOn fun s ih hs => by + by_cases hempty : s.card = 0 + · exact ⟨id, fun x hx => by simp [Finset.card_eq_zero.mp hempty] at hx, + fun x hx => by simp [Finset.card_eq_zero.mp hempty] at hx, + fun x hx => by simp [Finset.card_eq_zero.mp hempty] at hx⟩ + · have hge2 : 1 < s.card := by rcases hs with ⟨k, hk⟩; omega + rw [Finset.one_lt_card] at hge2 + obtain ⟨a, ha, b, hb, hab⟩ := hge2 + have hb_in_erase : b ∈ s.erase a := + Finset.mem_erase.mpr ⟨hab.symm, hb⟩ + set s' := (s.erase a).erase b with hs'_def + have ha' : a ∉ s' := by simp [hs'_def] + have hb' : b ∉ s' := by simp [hs'_def] + have hs'_sub : s' ⊂ s := + ssubset_trans (Finset.erase_ssubset hb_in_erase) (Finset.erase_ssubset + ha) + have hs'_card : s'.card = s.card - 2 := by + have h1 : (s.erase a).card = s.card - 1 := Finset.card_erase_of_mem ha + have h2 : s'.card = (s.erase a).card - 1 := by + change ((s.erase a).erase b).card = (s.erase a).card - 1 + exact Finset.card_erase_of_mem hb_in_erase + omega + have hs'_even : Even s'.card := by + rw [hs'_card] + rcases hs with ⟨k, hk⟩ + exact ⟨k - 1, by omega⟩ + obtain ⟨m', hm'_mem, hm'_invol, hm'_ne⟩ := ih s' hs'_sub hs'_even + let m (x : β) : β := if x = a then b else if x = b then a else m' x + have hm_a : m a = b := by simp [m] + have hm_b : m b = a := by simp [m, hab.symm] + have hm_other (x : β) (h1 : x ≠ a) (h2 : x ≠ b) : m x = m' x := by + simp [m, h1, h2] + refine ⟨m, ?_, ?_, ?_⟩ + · -- m maps s to s + intro x hx + by_cases h1 : x = a + · rw [h1, hm_a]; exact hb + · by_cases h2 : x = b + · rw [h2, hm_b]; exact ha + · rw [hm_other x h1 h2] + have hxs' : x ∈ s' := by + simp only [hs'_def, Finset.mem_erase, ne_eq]; exact ⟨h2, h1, hx⟩ + have := hm'_mem x hxs' + simp only [hs'_def, Finset.mem_erase, ne_eq] at this; exact this.2.2 + · -- m is an involution on s + intro x hx + by_cases h1 : x = a + · rw [h1, hm_a, hm_b] + · by_cases h2 : x = b + · rw [h2, hm_b, hm_a] + · rw [hm_other x h1 h2] + have hxs' : x ∈ s' := by + simp only [hs'_def, Finset.mem_erase, ne_eq]; exact ⟨h2, h1, hx⟩ + have hm'x_ne_a : m' x ≠ a := fun heq => ha' (heq ▸ hm'_mem x hxs') + have hm'x_ne_b : m' x ≠ b := fun heq => hb' (heq ▸ hm'_mem x hxs') + rw [hm_other (m' x) hm'x_ne_a hm'x_ne_b] + exact hm'_invol x hxs' + · -- m has no fixed points on s + intro x hx hfp + by_cases h1 : x = a + · rw [h1, hm_a] at hfp; exact hab hfp.symm + · by_cases h2 : x = b + · rw [h2, hm_b] at hfp; exact hab hfp + · rw [hm_other x h1 h2] at hfp + have hxs' : x ∈ s' := by + simp only [hs'_def, Finset.mem_erase, ne_eq]; exact ⟨h2, h1, hx⟩ + exact hm'_ne x hxs' hfp + +/-! ### Part 1: constructing the transition system -/ + +open Classical in +/-- Given an Eulerian edge subset whose flags all attach to internal +vertices, construct a transition system by building per-vertex +matchings and gluing them. -/ +noncomputable def EdgeSubset.buildTransitionSystem {α : Type} + {W : Fragment α} (F : EdgeSubset W) + (hE : F.Eulerian) (hint : ∀ f ∈ F.flags, ∃ v : W.Vertex, W.attach f = + Sum.inl v) : + F.TransitionSystem := by + letI := Classical.decEq W.Flag + letI := Classical.decEq W.Vertex + letI := Classical.decEq (W.Vertex ⊕ α) + let flagsAt (v : W.Vertex) : Finset W.Flag := + F.flags.filter (fun f => W.attach f = Sum.inl v) + have heven : ∀ v, Even (flagsAt v).card := hE + have hinvol : ∀ v, ∃ m : W.Flag → W.Flag, + (∀ x ∈ flagsAt v, m x ∈ flagsAt v) ∧ + (∀ x ∈ flagsAt v, m (m x) = x) ∧ + (∀ x ∈ flagsAt v, m x ≠ x) := + fun v => exists_involution_of_even (flagsAt v) (heven v) + let mv (v : W.Vertex) := (hinvol v).choose + have hmv_spec (v : W.Vertex) := (hinvol v).choose_spec + let vertexOf (f : W.Flag) (hf : f ∈ F.flags) : W.Vertex := (hint f hf).choose + have hvertexOf (f : W.Flag) (hf : f ∈ F.flags) : + W.attach f = Sum.inl (vertexOf f hf) := (hint f hf).choose_spec + let globalMatch (f : W.Flag) : W.Flag := + if hf : f ∈ F.flags then mv (vertexOf f hf) f else f + have hf_in_flagsAt (f : W.Flag) (hf : f ∈ F.flags) : + f ∈ flagsAt (vertexOf f hf) := + Finset.mem_filter.mpr ⟨hf, hvertexOf f hf⟩ + have hgm_unfold (f : W.Flag) (hf : f ∈ F.flags) : + globalMatch f = mv (vertexOf f hf) f := dite_eq_left hf + have hmatch_mem : ∀ f ∈ F.flags, globalMatch f ∈ F.flags := by + intro f hf + rw [hgm_unfold f hf] + exact (Finset.mem_filter.mp ((hmv_spec (vertexOf f hf)).1 f (hf_in_flagsAt f + hf))).1 + have hmatch_invol : ∀ f ∈ F.flags, globalMatch (globalMatch f) = f := by + intro f hf + have hgf : globalMatch f ∈ F.flags := hmatch_mem f hf + rw [hgm_unfold (globalMatch f) hgf] + -- Goal: mv (vertexOf (globalMatch f) hgf) (globalMatch f) = f + have hmvf_in : mv (vertexOf f hf) f ∈ flagsAt (vertexOf f hf) := + (hmv_spec (vertexOf f hf)).1 f (hf_in_flagsAt f hf) + have hmvf_attach : W.attach (mv (vertexOf f hf) f) = + Sum.inl (vertexOf f hf) := + (Finset.mem_filter.mp hmvf_in).2 + have hvv' : vertexOf (globalMatch f) hgf = vertexOf f hf := by + apply Sum.inl.inj + rw [← hvertexOf (globalMatch f) hgf, hgm_unfold f hf] + exact hmvf_attach + conv_lhs => rw [hvv'] + -- Goal: mv (vertexOf f hf) (globalMatch f) = f + rw [hgm_unfold f hf] + -- Goal: mv (vertexOf f hf) (mv (vertexOf f hf) f) = f + exact (hmv_spec (vertexOf f hf)).2.1 f (hf_in_flagsAt f hf) + have hmatch_ne : ∀ f ∈ F.flags, globalMatch f ≠ f := by + intro f hf + rw [hgm_unfold f hf] + exact (hmv_spec (vertexOf f hf)).2.2 f (hf_in_flagsAt f hf) + have hmatch_vertex : ∀ f ∈ F.flags, ∀ v : W.Vertex, + W.attach f = Sum.inl v → W.attach (globalMatch f) = Sum.inl v := by + intro f hf v hv + rw [hgm_unfold f hf] + have hmvf_in : mv (vertexOf f hf) f ∈ flagsAt (vertexOf f hf) := + (hmv_spec (vertexOf f hf)).1 f (hf_in_flagsAt f hf) + have hv_eq : vertexOf f hf = v := + Sum.inl.inj ((hvertexOf f hf).symm.trans hv) + rw [← hv_eq]; exact (Finset.mem_filter.mp hmvf_in).2 + exact { + match_ := globalMatch + match_invol := hmatch_invol + match_ne := hmatch_ne + match_mem := hmatch_mem + match_vertex := hmatch_vertex + attach_internal := hint + } + +/-! ### Part 2: the walk–pairing conjugation and orientation -/ + +namespace EdgeSubset.TransitionSystem + +variable {α : Type} {W : Fragment α} {F : EdgeSubset W} + +/-- The walk applied to σ f gives κ f, since walk(σ f) = κ(σ(σ f)) = κ f. -/ +theorem walk_pairing_eq (κ : F.TransitionSystem) + {f : W.Flag} (_hf : f ∈ F.flags) : + κ.walk (W.pairing f) = κ.match_ f := by + unfold walk; rw [W.pairing_invol] + +/-- Fundamental computation: walk(σ(walk(σ f))) = f for participating f. -/ +theorem walk_pairing_walk_pairing (κ : F.TransitionSystem) + {f : W.Flag} (hf : f ∈ F.flags) : + κ.walk (W.pairing (κ.walk (W.pairing f))) = f := by + unfold walk; rw [W.pairing_invol, W.pairing_invol] + exact κ.match_invol f hf + +end EdgeSubset.TransitionSystem + +/-- The edge pairing as a permutation of participating flags. -/ +noncomputable def EdgeSubset.pairingPerm {α : Type} {W : Fragment α} + (F : EdgeSubset W) : + Equiv.Perm {f : W.Flag // f ∈ F.flags} := + Equiv.ofBijective + (fun f => ⟨W.pairing f.val, F.pairing_mem f.val f.prop⟩) + (Finite.injective_iff_bijective.mp (fun ⟨f, hf⟩ ⟨g, hg⟩ h => by + have hval : W.pairing f = W.pairing g := congrArg Subtype.val h + have : f = g := + (W.pairing_invol f).symm.trans ((congrArg W.pairing hval).trans + (W.pairing_invol g)) + exact Subtype.ext this)) + +section PairingPerm + +variable {α : Type} {W : Fragment α} {F : EdgeSubset W} + +/-- The edge pairing as a permutation of participating flags. -/ +@[simp] +theorem EdgeSubset.pairingPerm_val (x : {f : W.Flag // f ∈ F.flags}) : + (F.pairingPerm x).val = W.pairing x.val := by + simp [EdgeSubset.pairingPerm, Equiv.ofBijective] + +/-- σ² = 1 on participating flags. -/ +theorem EdgeSubset.pairingPerm_mul_self : + F.pairingPerm * F.pairingPerm = (1 : Equiv.Perm {f : W.Flag // f ∈ F.flags}) + := by + ext ⟨f, hf⟩ + simp [Equiv.Perm.mul_apply, Equiv.Perm.one_apply, W.pairing_invol f] + +/-- It is its own inverse. -/ +theorem EdgeSubset.pairingPerm_inv : + F.pairingPerm⁻¹ = (F.pairingPerm : Equiv.Perm {f : W.Flag // f ∈ F.flags}) + := + mul_left_cancel (by rw [mul_inv_cancel, EdgeSubset.pairingPerm_mul_self]) + +end PairingPerm + +namespace EdgeSubset.TransitionSystem + +variable {α : Type} {W : Fragment α} {F : EdgeSubset W} + +/-- The walk permutation acts by the walk step. -/ +@[simp] +theorem walkPerm_val (κ : F.TransitionSystem) + (x : {f : W.Flag // f ∈ F.flags}) : + (κ.walkPerm x).val = κ.walk x.val := by + simp [walkPerm, Equiv.ofBijective] + +/-- σ ∘ walk ∘ σ = walk⁻¹: the edge pairing conjugates the walk +permutation to its inverse. -/ +theorem conj_eq_inv (κ : F.TransitionSystem) : + F.pairingPerm * κ.walkPerm * F.pairingPerm = κ.walkPerm⁻¹ := by + have h : κ.walkPerm * (F.pairingPerm * κ.walkPerm * F.pairingPerm) = 1 := by + apply Equiv.Perm.ext; intro ⟨f, hf⟩ + simp only [Equiv.Perm.mul_apply, Equiv.Perm.one_apply] + exact Subtype.ext (by + simp only [walkPerm_val, EdgeSubset.pairingPerm_val] + exact κ.walk_pairing_walk_pairing hf) + exact mul_left_cancel (by rw [h, mul_inv_cancel]) + +/-- σ ∘ walk^n ∘ σ = walk^{−n} for all n : ℤ. -/ +theorem conj_zpow (κ : F.TransitionSystem) (n : ℤ) : + F.pairingPerm * κ.walkPerm ^ n * F.pairingPerm = κ.walkPerm ^ (-n) := by + have hσ_inv := EdgeSubset.pairingPerm_inv (F := F) + calc F.pairingPerm * κ.walkPerm ^ n * F.pairingPerm + = F.pairingPerm * κ.walkPerm ^ n * F.pairingPerm⁻¹ := by + congr 1; exact hσ_inv.symm + _ = (MulAut.conj F.pairingPerm) (κ.walkPerm ^ n) := rfl + _ = ((MulAut.conj F.pairingPerm) κ.walkPerm) ^ n := + map_zpow (MulAut.conj F.pairingPerm).toMonoidHom κ.walkPerm n + _ = κ.walkPerm⁻¹ ^ n := by + congr 1 + change F.pairingPerm * κ.walkPerm * F.pairingPerm⁻¹ = κ.walkPerm⁻¹ + rw [hσ_inv]; exact κ.conj_eq_inv + _ = κ.walkPerm ^ (-n) := inv_zpow' κ.walkPerm n + +/-- If f and σ f were in the same walk-orbit, the conjugation identity +forces a contradiction. -/ +theorem pairing_not_sameCycle (κ : F.TransitionSystem) + {f : W.Flag} (hf : f ∈ F.flags) : + ¬ κ.walkPerm.SameCycle ⟨f, hf⟩ + ⟨W.pairing f, F.pairing_mem f hf⟩ := by + intro hsame + obtain ⟨m, hm_pos, _, hm_eq⟩ := hsame.exists_pow_eq'' + have hconj_applied : ∀ n : ℤ, + F.pairingPerm ((κ.walkPerm ^ n) (F.pairingPerm ⟨f, hf⟩)) = + (κ.walkPerm ^ (-n)) ⟨f, hf⟩ := fun n => by + have h := congr_fun (congr_arg DFunLike.coe (κ.conj_zpow n)) ⟨f, hf⟩ + simpa only [Equiv.Perm.mul_apply] using h + have hm' : (κ.walkPerm ^ (m : ℤ)) ⟨f, hf⟩ = F.pairingPerm ⟨f, hf⟩ := by + rw [zpow_natCast] + exact Subtype.ext (by + have := congrArg Subtype.val hm_eq + simpa only [EdgeSubset.pairingPerm_val] using this) + have hshift : ∀ n : ℤ, + F.pairingPerm ((κ.walkPerm ^ (n + ↑m)) ⟨f, hf⟩) = + (κ.walkPerm ^ (-n)) ⟨f, hf⟩ := by + intro n + rw [zpow_add, Equiv.Perm.mul_apply, hm'] + exact hconj_applied n + rcases Nat.even_or_odd m with ⟨j, hj⟩ | ⟨j, hj⟩ + · -- Even case: m = 2*j; σ(walk^j f) = walk^j f + have key := hshift (-(j : ℤ)) + have harith : -(j : ℤ) + ↑m = (j : ℤ) := by omega + rw [harith, neg_neg] at key + -- key : pairingPerm (walkPerm^j ⟨f,hf⟩) = walkPerm^j ⟨f,hf⟩ + have hval := congrArg Subtype.val key + simp only [EdgeSubset.pairingPerm_val] at hval + -- hval : W.pairing (walkPerm^j ⟨f,hf⟩).val = (walkPerm^j ⟨f,hf⟩).val + exact W.pairing_ne _ hval + · -- Odd case: m = 2*j+1; σ(walk^{j+1} f) = walk^j f → κ fixes + have key := hshift (-(j : ℤ)) + have harith : -(j : ℤ) + ↑m = (j : ℤ) + 1 := by omega + rw [harith, neg_neg] at key + -- key : pairingPerm (walkPerm^{j+1} ⟨f,hf⟩) = walkPerm^j ⟨f,hf⟩ + have hstep : (κ.walkPerm ^ ((j : ℤ) + 1)) ⟨f, hf⟩ = + κ.walkPerm ((κ.walkPerm ^ (j : ℤ)) ⟨f, hf⟩) := by + conv_lhs => rw [show (j : ℤ) + 1 = 1 + (j : ℤ) from by ring] + rw [zpow_add, zpow_one, Equiv.Perm.mul_apply] + rw [hstep] at key + set g := (κ.walkPerm ^ (j : ℤ)) ⟨f, hf⟩ + -- key : pairingPerm (walkPerm g) = g → σ(walk g.val) = g.val + have hval : W.pairing (κ.walk g.val) = g.val := by + have := congrArg Subtype.val key + simpa only [EdgeSubset.pairingPerm_val, walkPerm_val] using this + -- So walk g.val = σ g.val (applying σ to both sides) + have hval2 : κ.walk g.val = W.pairing g.val := by + have := congrArg W.pairing hval; rw [W.pairing_invol] at this; exact this + -- walk g.val = match_(σ g.val), contradicting match_ne + exact κ.match_ne _ (F.pairing_mem g.val g.prop) hval2 + +/-- κ f is in the walk-orbit of σ f: walk(σ f) = κ f gives a direct +witness. -/ +theorem match_sameCycle_pairing (κ : F.TransitionSystem) + {f : W.Flag} (hf : f ∈ F.flags) : + κ.walkPerm.SameCycle + ⟨κ.match_ f, κ.match_mem f hf⟩ + ⟨W.pairing f, F.pairing_mem f hf⟩ := by + have h : κ.walkPerm.SameCycle + ⟨W.pairing f, F.pairing_mem f hf⟩ + ⟨κ.match_ f, κ.match_mem f hf⟩ := + ⟨1, Subtype.ext (by + simp only [zpow_one, walkPerm_val] + exact κ.walk_pairing_eq hf)⟩ + exact h.symm + +/-- σ(κ f) is in the walk-orbit of f: walk(σ(κ f)) = κ(σ(σ(κ f))) = +κ(κ f) = f gives a direct witness. -/ +theorem pairing_match_sameCycle (κ : F.TransitionSystem) + {f : W.Flag} (hf : f ∈ F.flags) : + κ.walkPerm.SameCycle + ⟨W.pairing (κ.match_ f), F.pairing_mem _ (κ.match_mem f hf)⟩ + ⟨f, hf⟩ := + ⟨1, Subtype.ext (by + simp only [zpow_one, walkPerm_val] + -- Goal: walk (σ(κ f)) = f + -- walk g = κ(σ g), so walk(σ(κ f)) = κ(σ(σ(κ f))) = κ(κ f) = f + show κ.walk (W.pairing (κ.match_ f)) = f + unfold TransitionSystem.walk + rw [W.pairing_invol] + exact κ.match_invol f hf)⟩ + +end EdgeSubset.TransitionSystem + +/-! ### Orientation construction -/ + +section Orientation + +variable {α : Type} {W : Fragment α} {F : EdgeSubset W} + +/-- In a linear order, a ≠ b implies decide(a < b) = !decide(b < a). -/ +theorem transition_decide_lt_flip {γ : Type} [LinearOrder γ] + [DecidableRel ((· < ·) : γ → γ → Prop)] + {a b : γ} (h : a ≠ b) : decide (a < b) = !decide (b < a) := by + rcases lt_or_gt_of_ne h with hab | hab + · simp [hab, show ¬(b < a) from not_lt.mpr hab.le] + · simp [hab, show ¬(a < b) from not_lt.mpr hab.le] + +open Classical in +/-- Construct an orientation for a transition system. Walk-orbits +come in σ-paired pairs; the orientation assigns "out" to one side +of each pair based on orbit representatives under the flag order. -/ +noncomputable def EdgeSubset.TransitionSystem.buildOrientation + (κ : F.TransitionSystem) : κ.Orientation := by + letI flagOrd := W.flagOrder + letI := Classical.dec + letI subtypeOrd : LinearOrder {f : W.Flag // f ∈ F.flags} := + LinearOrder.lift' Subtype.val Subtype.val_injective + -- Walk-orbit of a participating flag + let orbitOf (x : {f : W.Flag // f ∈ F.flags}) : Finset {f : W.Flag // f ∈ + F.flags} := + Finset.univ.filter (fun y => κ.walkPerm.SameCycle x y) + have orbit_nonempty (x : {f : W.Flag // f ∈ F.flags}) : + (orbitOf x).Nonempty := + ⟨x, Finset.mem_filter.mpr ⟨Finset.mem_univ _, Equiv.Perm.SameCycle.rfl⟩⟩ + -- Orbit representative: minimum element + let orbitMin (x : {f : W.Flag // f ∈ F.flags}) : {f : W.Flag // f ∈ F.flags} + := + (orbitOf x).min' (orbit_nonempty x) + -- orbitMin constant on walk-orbits + have orbitMin_eq (x y : {f : W.Flag // f ∈ F.flags}) + (h : κ.walkPerm.SameCycle x y) : orbitMin x = orbitMin y := by + simp only [orbitMin] + congr 1 + ext z + simp only [orbitOf, Finset.mem_filter, Finset.mem_univ, true_and] + exact ⟨fun hz => h.symm.trans hz, fun hz => h.trans hz⟩ + -- orbitMin(σ f) ≠ orbitMin(f) + have orbitMin_pairing_ne (x : {f : W.Flag // f ∈ F.flags}) : + orbitMin (F.pairingPerm x) ≠ orbitMin x := by + intro heq + have hmin_in_x : orbitMin x ∈ orbitOf x := Finset.min'_mem _ _ + have hmin_in_σx : orbitMin (F.pairingPerm x) ∈ orbitOf (F.pairingPerm x) := + Finset.min'_mem _ _ + rw [heq] at hmin_in_σx + simp only [orbitOf, Finset.mem_filter, Finset.mem_univ, true_and] + at hmin_in_x hmin_in_σx + -- hmin_in_x : SameCycle x (orbitMin x) + -- hmin_in_σx : SameCycle (pairingPerm x) (orbitMin x) + exact κ.pairing_not_sameCycle x.prop (hmin_in_x.trans hmin_in_σx.symm) + -- κ f is in orbit(σ f), hence orbitMin(κ f) = orbitMin(σ f) + have orbitMin_match (x : {f : W.Flag // f ∈ F.flags}) : + orbitMin ⟨κ.match_ x.val, κ.match_mem x.val x.prop⟩ = + orbitMin (F.pairingPerm x) := by + apply orbitMin_eq + -- Need: SameCycle ⟨κ x.val, _⟩ (pairingPerm x) + have h := κ.match_sameCycle_pairing x.prop + -- h : SameCycle ⟨κ x.val, _⟩ ⟨σ x.val, F.pairing_mem x.val x.prop⟩ + -- pairingPerm x has val = σ x.val + convert h using 1 + exact Subtype.ext (by simp) + -- σ(κ f) is in orbit(f), hence orbitMin(σ(κ f)) = orbitMin(f) + have orbitMin_pairing_match (x : {f : W.Flag // f ∈ F.flags}) : + orbitMin (F.pairingPerm ⟨κ.match_ x.val, κ.match_mem x.val x.prop⟩) = + orbitMin x := by + apply orbitMin_eq + -- Need: SameCycle (pairingPerm ⟨κ x.val, _⟩) x + have h := κ.pairing_match_sameCycle x.prop + -- h : SameCycle ⟨σ(κ x.val), _⟩ ⟨x.val, x.prop⟩ + convert h using 1 + exact Subtype.ext (by simp) + -- Define isOut + let isOut (g : W.Flag) : Bool := + if hg : g ∈ F.flags then + decide (orbitMin (F.pairingPerm ⟨g, hg⟩) < orbitMin ⟨g, hg⟩) + else false + -- match_flip + have hmatch_flip : ∀ g ∈ F.flags, isOut (κ.match_ g) = !isOut g := by + intro g hg + simp only [isOut, dite_eq_left hg, dite_eq_left (κ.match_mem g hg)] + rw [orbitMin_pairing_match ⟨g, hg⟩, orbitMin_match ⟨g, hg⟩] + exact transition_decide_lt_flip (Ne.symm (orbitMin_pairing_ne ⟨g, hg⟩)) + -- pairing_flip + have hpairing_flip : ∀ g ∈ F.flags, isOut (W.pairing g) = !isOut g := by + intro g hg + simp only [isOut, dite_eq_left hg, dite_eq_left (F.pairing_mem g hg)] + -- pairingPerm ⟨σ g, _⟩ = ⟨g, hg⟩ (since σ² = id) + have hσσ : F.pairingPerm ⟨W.pairing g, F.pairing_mem g hg⟩ = ⟨g, hg⟩ := + Subtype.ext (by simp [W.pairing_invol g]) + -- ⟨σ g, _⟩ = pairingPerm ⟨g, hg⟩ + have hσ_eq : (⟨W.pairing g, F.pairing_mem g hg⟩ : + {f : W.Flag // f ∈ F.flags}) = F.pairingPerm ⟨g, hg⟩ := + Subtype.ext (by simp) + rw [hσσ, hσ_eq] + exact transition_decide_lt_flip (Ne.symm (orbitMin_pairing_ne ⟨g, hg⟩)) + exact ⟨isOut, hmatch_flip, hpairing_flip⟩ + +/-! ### The main theorem -/ + +open Classical in +/-- An Eulerian edge subset with internally-attached flags admits a +transition system equipped with an orientation. -/ +theorem EdgeSubset.exists_transition_orientation {α : Type} + {W : Fragment α} (F : EdgeSubset W) (hE : F.Eulerian) + (hint : ∀ f ∈ F.flags, ∃ v : W.Vertex, W.attach f = Sum.inl v) : + Nonempty ((κ : F.TransitionSystem) × κ.Orientation) := + let κ := F.buildTransitionSystem hE hint + ⟨⟨κ, κ.buildOrientation⟩⟩ + +end Orientation + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionMove.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionMove.lean new file mode 100644 index 0000000000..de7263ac94 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionMove.lean @@ -0,0 +1,644 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelTransition + +/-! +# The elementary re-pairing move on relative transition systems + +For a fixed edge subset `F : EdgeSubset W`, this file introduces the +elementary *2-opt move* on boundary-relative transition systems and +proves that the moves connect any two systems. + +## Main definitions + +* `EdgeSubset.repairFun` — the raw re-pairing of a matching function + at four flags: `a ↦ c`, `c ↦ a`, `b ↦ d`, `d ↦ b`. +* `EdgeSubset.RepairSquare` — the admissibility data for a move: + four pairwise distinct internal flags at a common vertex with + `a ↔ b` and `c ↔ d` matched. +* `EdgeSubset.RelTransitionSystem.repair` — the elementary move, + producing a transition system over the *same* `F` (so the edge + subset, its `internalFlags`, and its `boundaryFlags` are untouched + by construction). +* `EdgeSubset.RelTransitionSystem.MatchEq` — matching equality on + internal flags; two systems whose matchings agree on + `F.internalFlags` are indistinguishable to every field of + `RelTransitionSystem`, so connectivity is stated up to `MatchEq`. +* `EdgeSubset.IsRepairStep` — one elementary move (up to `MatchEq`). +* `EdgeSubset.disagreeSet` — the internal flags where two systems' + matchings differ. + +## Main results + +* `EdgeSubset.repair_connectivity` — **connectivity**: any two + relative transition systems on `F` are joined by a finite chain of + elementary moves, with `MatchEq` at the endpoints. The proof is by + induction on `(disagreeSet κ κ').card`: a disagreement at `a` + yields an admissible square (`repairSquare_of_disagree`) whose + repair strictly shrinks the disagreement set + (`disagreeSet_repair_subset`). +* `EdgeSubset.IsRepairStep.symm` — the move is reversible, so chains + can be traversed backwards. +* `EdgeSubset.RelTransitionSystem.Orientation.ofMatchEq` and + `…Orientation.transportRepair` — orientation transport across + `MatchEq` and (conditionally) across a move. + +## Orientation transport along a matching equality + +`Orientation.transportRepair` transports an orientation across a +repair when it already separates `a` from `c` +(`o.isOut c = !o.isOut a`): the directions carry over unchanged. +When instead `o.isOut c = o.isOut a` the transported orientation +must flip `isOut` along the walk-orbit segment through `c`, which +needs the orbit machinery; that construction is +`Orientation.segFlip` in `NonSeparatedStep.lean`, with +`Orientation.flipOrbit` of `PathLedger.lean` for a periodic +segment. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} + +namespace EdgeSubset + +variable {W : Fragment α} {F : EdgeSubset W} + +/-! ## The raw re-pairing function -/ + +/-- Re-pair a matching function at four flags: `a ↦ c`, `c ↦ a`, +`b ↦ d`, `d ↦ b`, leaving every other flag to `m`. -/ +def repairFun (m : W.Flag → W.Flag) (a b c d : W.Flag) : + W.Flag → W.Flag := fun f => + if f = a then c else if f = c then a else + if f = b then d else if f = d then b else m f + +section RepairFun + +variable {m m' : W.Flag → W.Flag} {a b c d f : W.Flag} + +/-- The re-pairing sends `a` to `c`. -/ +theorem repairFun_a : repairFun m a b c d a = c := by + simp [repairFun] + +/-- And `c` back to `a`. -/ +theorem repairFun_c (h : c ≠ a) : repairFun m a b c d c = a := by + simp [repairFun, h] + +/-- It sends `b` to `d`. -/ +theorem repairFun_b (h1 : b ≠ a) (h2 : b ≠ c) : + repairFun m a b c d b = d := by + simp [repairFun, h1, h2] + +/-- And `d` back to `b`. -/ +theorem repairFun_d (h1 : d ≠ a) (h2 : d ≠ c) (h3 : d ≠ b) : + repairFun m a b c d d = b := by + simp [repairFun, h1, h2, h3] + +/-- Away from the four flags the matching is untouched: the move is +local. -/ +theorem repairFun_of_ne (h1 : f ≠ a) (h2 : f ≠ b) (h3 : f ≠ c) + (h4 : f ≠ d) : repairFun m a b c d f = m f := by + simp [repairFun, h1, h2, h3, h4] + +/-- The re-paired function depends on the underlying matching only +through its value at the argument. -/ +theorem repairFun_congr (hm : m f = m' f) : + repairFun m a b c d f = repairFun m' a b c d f := by + unfold repairFun + split_ifs <;> first | rfl | exact hm + +end RepairFun + +/-! ## Admissibility data for a move -/ + +/-- The data of an admissible 2-opt re-pairing move on +`κ : F.RelTransitionSystem`: four pairwise distinct internal flags +`a, b, c, d` attached to a common vertex `v`, with `a ↔ b` and +`c ↔ d` matched by `κ`. (The distinctness facts `a ≠ b` and `c ≠ d` +are derivable from `match_ne` and are not recorded.) -/ +structure RepairSquare (κ : F.RelTransitionSystem) + (a b c d : W.Flag) (v : W.Vertex) : Prop where + ha : a ∈ F.internalFlags + hc : c ∈ F.internalFlags + hab : κ.match_ a = b + hcd : κ.match_ c = d + hac : a ≠ c + had : a ≠ d + hbc : b ≠ c + hbd : b ≠ d + hav : W.attach a = Sum.inl v + hcv : W.attach c = Sum.inl v + +namespace RepairSquare + +variable {κ : F.RelTransitionSystem} {a b c d : W.Flag} {v : W.Vertex} + +/-- `b` is internal. -/ +theorem hb (h : RepairSquare κ a b c d v) : b ∈ F.internalFlags := by + rw [← h.hab]; exact κ.match_mem a h.ha + +/-- `d` is internal. -/ +theorem hd (h : RepairSquare κ a b c d v) : d ∈ F.internalFlags := by + rw [← h.hcd]; exact κ.match_mem c h.hc + +/-- `b ≠ a`. -/ +theorem hba (h : RepairSquare κ a b c d v) : b ≠ a := by + rw [← h.hab]; exact κ.match_ne a h.ha + +/-- `d ≠ c`. -/ +theorem hdc (h : RepairSquare κ a b c d v) : d ≠ c := by + rw [← h.hcd]; exact κ.match_ne c h.hc + +/-- `κ` matches `b` back to `a`. -/ +theorem hmb (h : RepairSquare κ a b c d v) : κ.match_ b = a := by + rw [← h.hab]; exact κ.match_invol a h.ha + +/-- `κ` matches `d` back to `c`. -/ +theorem hmd (h : RepairSquare κ a b c d v) : κ.match_ d = c := by + rw [← h.hcd]; exact κ.match_invol c h.hc + +/-- `b` sits at the common vertex. -/ +theorem hbv (h : RepairSquare κ a b c d v) : + W.attach b = Sum.inl v := by + rw [← h.hab]; exact κ.match_vertex a h.ha v h.hav + +/-- `d` sits at the common vertex. -/ +theorem hdv (h : RepairSquare κ a b c d v) : + W.attach d = Sum.inl v := by + rw [← h.hcd]; exact κ.match_vertex c h.hc v h.hcv + +/-- The `κ`-partner of a flag off the square stays off the square. -/ +theorem match_ne_four (h : RepairSquare κ a b c d v) {f : W.Flag} + (hf : f ∈ F.internalFlags) (h1 : f ≠ a) (h2 : f ≠ b) + (h3 : f ≠ c) (h4 : f ≠ d) : + κ.match_ f ≠ a ∧ κ.match_ f ≠ b ∧ κ.match_ f ≠ c ∧ + κ.match_ f ≠ d := by + refine ⟨?_, ?_, ?_, ?_⟩ + · intro he + apply h2 + calc f = κ.match_ (κ.match_ f) := (κ.match_invol f hf).symm + _ = κ.match_ a := by rw [he] + _ = b := h.hab + · intro he + apply h1 + calc f = κ.match_ (κ.match_ f) := (κ.match_invol f hf).symm + _ = κ.match_ b := by rw [he] + _ = a := h.hmb + · intro he + apply h4 + calc f = κ.match_ (κ.match_ f) := (κ.match_invol f hf).symm + _ = κ.match_ c := by rw [he] + _ = d := h.hcd + · intro he + apply h3 + calc f = κ.match_ (κ.match_ f) := (κ.match_invol f hf).symm + _ = κ.match_ d := by rw [he] + _ = c := h.hmd + +end RepairSquare + +/-! ## The elementary move -/ + +namespace RelTransitionSystem + +/-- **The elementary move (2-opt re-pairing)**: given an admissible +square (`a ↔ b`, `c ↔ d` matched, all four distinct, all at vertex +`v`), the transition system matching `a ↔ c` and `b ↔ d` instead, +keeping every other matched pair. The result is a system over the +*same* edge subset `F`. -/ +def repair (κ : F.RelTransitionSystem) (a b c d : W.Flag) + (v : W.Vertex) (h : RepairSquare κ a b c d v) : + F.RelTransitionSystem where + match_ := repairFun κ.match_ a b c d + match_invol := by + intro f hf + by_cases h1 : f = a + · subst h1 + rw [repairFun_a, repairFun_c (Ne.symm h.hac)] + by_cases h3 : f = c + · subst h3 + rw [repairFun_c (Ne.symm h.hac), repairFun_a] + by_cases h2 : f = b + · subst h2 + rw [repairFun_b h.hba h.hbc, + repairFun_d (Ne.symm h.had) h.hdc (Ne.symm h.hbd)] + by_cases h4 : f = d + · subst h4 + rw [repairFun_d (Ne.symm h.had) h.hdc (Ne.symm h.hbd), + repairFun_b h.hba h.hbc] + · obtain ⟨n1, n2, n3, n4⟩ := h.match_ne_four hf h1 h2 h3 h4 + rw [repairFun_of_ne h1 h2 h3 h4, repairFun_of_ne n1 n2 n3 n4] + exact κ.match_invol f hf + match_ne := by + intro f hf + by_cases h1 : f = a + · subst h1; rw [repairFun_a]; exact Ne.symm h.hac + by_cases h3 : f = c + · subst h3; rw [repairFun_c (Ne.symm h.hac)]; exact h.hac + by_cases h2 : f = b + · subst h2; rw [repairFun_b h.hba h.hbc]; exact Ne.symm h.hbd + by_cases h4 : f = d + · subst h4 + rw [repairFun_d (Ne.symm h.had) h.hdc (Ne.symm h.hbd)] + exact h.hbd + · rw [repairFun_of_ne h1 h2 h3 h4]; exact κ.match_ne f hf + match_mem := by + intro f hf + by_cases h1 : f = a + · subst h1; rw [repairFun_a]; exact h.hc + by_cases h3 : f = c + · subst h3; rw [repairFun_c (Ne.symm h.hac)]; exact h.ha + by_cases h2 : f = b + · subst h2; rw [repairFun_b h.hba h.hbc]; exact h.hd + by_cases h4 : f = d + · subst h4 + rw [repairFun_d (Ne.symm h.had) h.hdc (Ne.symm h.hbd)] + exact h.hb + · rw [repairFun_of_ne h1 h2 h3 h4]; exact κ.match_mem f hf + match_vertex := by + intro f hf w hw + by_cases h1 : f = a + · subst h1 + rw [h.hav] at hw + rw [repairFun_a, ← Sum.inl.inj hw] + exact h.hcv + by_cases h3 : f = c + · subst h3 + rw [h.hcv] at hw + rw [repairFun_c (Ne.symm h.hac), ← Sum.inl.inj hw] + exact h.hav + by_cases h2 : f = b + · subst h2 + rw [h.hbv] at hw + rw [repairFun_b h.hba h.hbc, ← Sum.inl.inj hw] + exact h.hdv + by_cases h4 : f = d + · subst h4 + rw [h.hdv] at hw + rw [repairFun_d (Ne.symm h.had) h.hdc (Ne.symm h.hbd), + ← Sum.inl.inj hw] + exact h.hbv + · rw [repairFun_of_ne h1 h2 h3 h4] + exact κ.match_vertex f hf w hw + +section RepairEval + +variable {κ : F.RelTransitionSystem} {a b c d f : W.Flag} {v : W.Vertex} + +/-- The repaired system's matching at `a`. -/ +@[simp] theorem repair_match_a (h : RepairSquare κ a b c d v) : + (κ.repair a b c d v h).match_ a = c := repairFun_a + +/-- At `c`. -/ +@[simp] theorem repair_match_c (h : RepairSquare κ a b c d v) : + (κ.repair a b c d v h).match_ c = a := repairFun_c (Ne.symm h.hac) + +/-- At `b`. -/ +@[simp] theorem repair_match_b (h : RepairSquare κ a b c d v) : + (κ.repair a b c d v h).match_ b = d := repairFun_b h.hba h.hbc + +/-- At `d`. -/ +@[simp] theorem repair_match_d (h : RepairSquare κ a b c d v) : + (κ.repair a b c d v h).match_ d = b := + repairFun_d (Ne.symm h.had) h.hdc (Ne.symm h.hbd) + +/-- And everywhere else, unchanged. -/ +theorem repair_match_of_ne (h : RepairSquare κ a b c d v) + (h1 : f ≠ a) (h2 : f ≠ b) (h3 : f ≠ c) (h4 : f ≠ d) : + (κ.repair a b c d v h).match_ f = κ.match_ f := + repairFun_of_ne h1 h2 h3 h4 + +end RepairEval + +/-! ## Matching equality -/ + +/-- Two relative transition systems agree when their matchings agree +on the internal flags. All fields of `RelTransitionSystem` constrain +only internal flags, so `MatchEq`-related systems are +interchangeable; the matching's values off `F.internalFlags` are +junk. -/ +def MatchEq (κ₁ κ₂ : F.RelTransitionSystem) : Prop := + ∀ f ∈ F.internalFlags, κ₁.match_ f = κ₂.match_ f + +namespace MatchEq + +variable {κ₁ κ₂ κ₃ : F.RelTransitionSystem} + +/-- Matching equality is reflexive. -/ +theorem refl (κ : F.RelTransitionSystem) : κ.MatchEq κ := + fun _ _ => rfl + +/-- It is symmetric. -/ +theorem symm (h : κ₁.MatchEq κ₂) : κ₂.MatchEq κ₁ := + fun f hf => (h f hf).symm + +/-- It is transitive — an equivalence, so chains compose up to +it. -/ +theorem trans (h : κ₁.MatchEq κ₂) (h' : κ₂.MatchEq κ₃) : + κ₁.MatchEq κ₃ := + fun f hf => (h f hf).trans (h' f hf) + +end MatchEq + +end RelTransitionSystem + +/-! ## Transport of squares and moves -/ + +/-- A repair square transports across matching equality. -/ +theorem RepairSquare.of_matchEq {κ κ' : F.RelTransitionSystem} + {a b c d : W.Flag} {v : W.Vertex} + (heq : κ.MatchEq κ') (h : RepairSquare κ a b c d v) : + RepairSquare κ' a b c d v := + ⟨h.ha, h.hc, (heq a h.ha).symm.trans h.hab, + (heq c h.hc).symm.trans h.hcd, h.hac, h.had, h.hbc, h.hbd, + h.hav, h.hcv⟩ + +namespace RelTransitionSystem + +/-- Repairing `MatchEq`-equal systems along the same square yields +`MatchEq`-equal systems. -/ +theorem repair_congr {κ κ' : F.RelTransitionSystem} + {a b c d : W.Flag} {v : W.Vertex} (heq : κ.MatchEq κ') + (h : RepairSquare κ a b c d v) (h' : RepairSquare κ' a b c d v) : + (κ.repair a b c d v h).MatchEq (κ'.repair a b c d v h') := + fun f hf => repairFun_congr (heq f hf) + +/-- **The move is an involution**: repairing back along the inverse +square recovers the original matching on internal flags. -/ +theorem repair_repair {κ : F.RelTransitionSystem} + {a b c d : W.Flag} {v : W.Vertex} (h : RepairSquare κ a b c d v) + (h₂ : RepairSquare (κ.repair a b c d v h) a c b d v) : + ((κ.repair a b c d v h).repair a c b d v h₂).MatchEq κ := by + intro f hf + by_cases h1 : f = a + · subst h1 + rw [repair_match_a h₂, h.hab] + by_cases h2 : f = b + · subst h2 + rw [repair_match_c h₂, h.hmb] + by_cases h3 : f = c + · subst h3 + rw [repair_match_b h₂, h.hcd] + by_cases h4 : f = d + · subst h4 + rw [repair_match_d h₂, h.hmd] + · rw [repair_match_of_ne h₂ h1 h3 h2 h4, + repair_match_of_ne h h1 h2 h3 h4] + +end RelTransitionSystem + +/-- The inverse square: after the move, `(a, c, b, d)` is again +admissible (the move `a ↔ c`, `b ↔ d` back to `a ↔ b`, `c ↔ d`). -/ +theorem RepairSquare.symm {κ : F.RelTransitionSystem} + {a b c d : W.Flag} {v : W.Vertex} (h : RepairSquare κ a b c d v) : + RepairSquare (κ.repair a b c d v h) a c b d v := + ⟨h.ha, h.hb, RelTransitionSystem.repair_match_a h, + RelTransitionSystem.repair_match_b h, + Ne.symm h.hba, h.had, Ne.symm h.hbc, Ne.symm h.hdc, + h.hav, h.hbv⟩ + +/-! ## The elementary step relation -/ + +/-- One elementary move joins `κ₁` to `κ₂`: some admissible square of +`κ₁` repairs it to a system matching-equal to `κ₂`. -/ +def IsRepairStep (κ₁ κ₂ : F.RelTransitionSystem) : Prop := + ∃ (a b c d : W.Flag) (v : W.Vertex) + (h : RepairSquare κ₁ a b c d v), + (κ₁.repair a b c d v h).MatchEq κ₂ + +/-- The step relation respects matching equality on both sides. -/ +theorem IsRepairStep.congr {κ₁ κ₁' κ₂ κ₂' : F.RelTransitionSystem} + (h1 : κ₁.MatchEq κ₁') (h2 : κ₂.MatchEq κ₂') + (hstep : IsRepairStep κ₁ κ₂) : IsRepairStep κ₁' κ₂' := by + obtain ⟨a, b, c, d, v, h, heq⟩ := hstep + exact ⟨a, b, c, d, v, h.of_matchEq h1, + ((RelTransitionSystem.repair_congr h1.symm (h.of_matchEq h1) h).trans + heq).trans h2⟩ + +/-- **The step relation is symmetric**: every move can be undone by a +move, so chains of moves can be reversed. -/ +theorem IsRepairStep.symm {κ₁ κ₂ : F.RelTransitionSystem} + (hstep : IsRepairStep κ₁ κ₂) : IsRepairStep κ₂ κ₁ := by + obtain ⟨a, b, c, d, v, h, heq⟩ := hstep + refine ⟨a, c, b, d, v, (RepairSquare.symm h).of_matchEq heq, ?_⟩ + exact (RelTransitionSystem.repair_congr heq.symm _ + (RepairSquare.symm h)).trans + (RelTransitionSystem.repair_repair h _) + +/-! ## The disagreement set -/ + +/-- The internal flags at which two transition systems' matchings +disagree. -/ +noncomputable def disagreeSet (κ κ' : F.RelTransitionSystem) : + Finset W.Flag := + F.internalFlags.filter (fun f => κ.match_ f ≠ κ'.match_ f) + +/-- Membership in the disagreement set: an internal flag the two +matchings send to different places. -/ +theorem mem_disagreeSet {κ κ' : F.RelTransitionSystem} {f : W.Flag} : + f ∈ disagreeSet κ κ' ↔ + f ∈ F.internalFlags ∧ κ.match_ f ≠ κ'.match_ f := + Finset.mem_filter + +/-- The disagreement set is empty exactly for matching-equal +systems. -/ +theorem disagreeSet_eq_empty_iff {κ κ' : F.RelTransitionSystem} : + disagreeSet κ κ' = ∅ ↔ κ.MatchEq κ' := by + rw [Finset.eq_empty_iff_forall_notMem] + constructor + · intro h f hf + by_contra hne + exact h f (mem_disagreeSet.mpr ⟨hf, hne⟩) + · intro h f hf + obtain ⟨hfi, hfd⟩ := mem_disagreeSet.mp hf + exact hfd (h f hfi) + +/-- A disagreement at `a` yields an admissible square: with +`b := κ.match_ a`, `c := κ'.match_ a`, `d := κ.match_ c`, the four +flags are pairwise distinct internal flags at `a`'s vertex. -/ +theorem repairSquare_of_disagree {κ κ' : F.RelTransitionSystem} + {a : W.Flag} (ha : a ∈ F.internalFlags) + (hdis : κ.match_ a ≠ κ'.match_ a) {v : W.Vertex} + (hav : W.attach a = Sum.inl v) : + RepairSquare κ a (κ.match_ a) (κ'.match_ a) + (κ.match_ (κ'.match_ a)) v := by + have hcmem : κ'.match_ a ∈ F.internalFlags := κ'.match_mem a ha + refine ⟨ha, hcmem, rfl, rfl, ?_, ?_, hdis, ?_, hav, ?_⟩ + · exact Ne.symm (κ'.match_ne a ha) + · -- a ≠ κ.match_ (κ'.match_ a) + intro he + apply hdis + calc κ.match_ a = κ.match_ (κ.match_ (κ'.match_ a)) := by + rw [← he] + _ = κ'.match_ a := κ.match_invol _ hcmem + · -- κ.match_ a ≠ κ.match_ (κ'.match_ a) + intro he + apply Ne.symm (κ'.match_ne a ha) + calc a = κ.match_ (κ.match_ a) := (κ.match_invol a ha).symm + _ = κ.match_ (κ.match_ (κ'.match_ a)) := by rw [he] + _ = κ'.match_ a := κ.match_invol _ hcmem + · exact κ'.match_vertex a ha v hav + +/-- **Disagreement decrease**: repairing the square of a disagreement +at `a` (with `c = κ'.match_ a`) removes both `a` and `c` from the +disagreement set and adds nothing; in particular the new disagreement +set avoids `a`. -/ +theorem disagreeSet_repair_subset {κ κ' : F.RelTransitionSystem} + {a b c d : W.Flag} {v : W.Vertex} (h : RepairSquare κ a b c d v) + (hc' : κ'.match_ a = c) : + disagreeSet (κ.repair a b c d v h) κ' ⊆ + (disagreeSet κ κ').erase a := by + have hca' : κ'.match_ c = a := by + rw [← hc']; exact κ'.match_invol a h.ha + intro f hf + obtain ⟨hfi, hfd⟩ := mem_disagreeSet.mp hf + rw [Finset.mem_erase, mem_disagreeSet] + by_cases h1 : f = a + · subst h1 + exact absurd ((RelTransitionSystem.repair_match_a h).trans + hc'.symm) hfd + by_cases h3 : f = c + · subst h3 + exact absurd ((RelTransitionSystem.repair_match_c h).trans + hca'.symm) hfd + refine ⟨h1, hfi, ?_⟩ + by_cases h2 : f = b + · subst h2 + rw [h.hmb] + intro he + have hb' : κ'.match_ a = f := by + rw [he]; exact κ'.match_invol f h.hb + exact h.hbc (hb'.symm.trans hc') + by_cases h4 : f = d + · subst h4 + rw [h.hmd] + intro he + have hd' : κ'.match_ c = f := by + rw [he]; exact κ'.match_invol f h.hd + exact h.had (hca'.symm.trans hd') + · rw [RelTransitionSystem.repair_match_of_ne h h1 h2 h3 h4] at hfd + exact hfd + +/-! ## Connectivity -/ + +/-- Connectivity, with an explicit bound on the disagreement count: +strong induction on `(disagreeSet κ κ').card`. -/ +theorem repair_connectivity_of_card_le (N : ℕ) : + ∀ κ κ' : F.RelTransitionSystem, (disagreeSet κ κ').card ≤ N → + ∃ (n : ℕ) (chain : Fin (n + 1) → F.RelTransitionSystem), + (chain 0).MatchEq κ ∧ (chain (Fin.last n)).MatchEq κ' ∧ + ∀ r : Fin n, IsRepairStep (chain r.castSucc) (chain r.succ) := by + induction N with + | zero => + intro κ κ' hcard + have heq : κ.MatchEq κ' := + disagreeSet_eq_empty_iff.mp + (Finset.card_eq_zero.mp (Nat.le_zero.mp hcard)) + exact ⟨0, fun _ => κ, RelTransitionSystem.MatchEq.refl κ, heq, + fun r => r.elim0⟩ + | succ N ih => + intro κ κ' hcard + by_cases hne : (disagreeSet κ κ').Nonempty + · obtain ⟨a, haS⟩ := hne + obtain ⟨hai, hdis⟩ := mem_disagreeSet.mp haS + obtain ⟨v, hav⟩ := F.attach_internal_of_mem hai + have hsq := repairSquare_of_disagree hai hdis hav + have hsub := disagreeSet_repair_subset hsq rfl + have hcard' : (disagreeSet (κ.repair a (κ.match_ a) + (κ'.match_ a) (κ.match_ (κ'.match_ a)) v hsq) κ').card ≤ + N := + Nat.lt_succ_iff.mp + (lt_of_lt_of_le + (lt_of_le_of_lt (Finset.card_le_card hsub) + (Finset.card_erase_lt_of_mem haS)) hcard) + obtain ⟨n, chain, h0, hlast, hstep⟩ := ih _ κ' hcard' + refine ⟨n + 1, Fin.cons κ chain, ?_, ?_, ?_⟩ + · rw [Fin.cons_zero] + exact RelTransitionSystem.MatchEq.refl κ + · rw [← Fin.succ_last, Fin.cons_succ] + exact hlast + · intro r + refine Fin.cases ?_ (fun i => ?_) r + · rw [Fin.castSucc_zero, Fin.cons_zero, Fin.cons_succ] + exact ⟨a, κ.match_ a, κ'.match_ a, + κ.match_ (κ'.match_ a), v, hsq, h0.symm⟩ + · rw [← Fin.succ_castSucc, Fin.cons_succ, Fin.cons_succ] + exact hstep i + · rw [Finset.not_nonempty_iff_eq_empty] at hne + exact ⟨0, fun _ => κ, RelTransitionSystem.MatchEq.refl κ, + disagreeSet_eq_empty_iff.mp hne, fun r => r.elim0⟩ + +/-- **Connectivity of the elementary move**: any two boundary-relative +transition systems on the same edge subset are joined by a finite +chain of elementary re-pairing moves, matching-equal to the given +systems at the endpoints. -/ +theorem repair_connectivity (κ κ' : F.RelTransitionSystem) : + ∃ (n : ℕ) (chain : Fin (n + 1) → F.RelTransitionSystem), + (chain 0).MatchEq κ ∧ (chain (Fin.last n)).MatchEq κ' ∧ + ∀ r : Fin n, IsRepairStep (chain r.castSucc) (chain r.succ) := + repair_connectivity_of_card_le (disagreeSet κ κ').card κ κ' le_rfl + +/-! ## Orientation transport -/ + +namespace RelTransitionSystem + +/-- Orientations transport across matching equality: an orientation +constrains `isOut` only through the matching's values on internal +flags. -/ +def Orientation.ofMatchEq {κ κ' : F.RelTransitionSystem} + (heq : κ.MatchEq κ') (o : κ.Orientation) : κ'.Orientation where + isOut := o.isOut + match_flip := fun f hf => by + rw [← heq f hf]; exact o.match_flip f hf + pairing_flip := o.pairing_flip + +/-- **Orientation transport along a move (separated case)**: when the +orientation already separates `a` and `c` (`isOut c = !isOut a`), it +transports *unchanged* along the repair. When instead +`isOut c = isOut a` the transported orientation must flip `isOut` +along a walk segment; that is `Orientation.segFlip`. -/ +def Orientation.transportRepair {κ : F.RelTransitionSystem} + {a b c d : W.Flag} {v : W.Vertex} (h : RepairSquare κ a b c d v) + (o : κ.Orientation) (hflip : o.isOut c = !o.isOut a) : + (κ.repair a b c d v h).Orientation where + isOut := o.isOut + match_flip := by + have hb' : o.isOut b = !o.isOut a := by + rw [← h.hab]; exact o.match_flip a h.ha + have hd' : o.isOut d = !o.isOut c := by + rw [← h.hcd]; exact o.match_flip c h.hc + intro f hf + change o.isOut (repairFun κ.match_ a b c d f) = !o.isOut f + by_cases h1 : f = a + · subst h1 + rw [repairFun_a]; exact hflip + by_cases h3 : f = c + · subst h3 + rw [repairFun_c (Ne.symm h.hac), hflip, Bool.not_not] + by_cases h2 : f = b + · subst h2 + rw [repairFun_b h.hba h.hbc, hd', hflip, hb', Bool.not_not] + by_cases h4 : f = d + · subst h4 + rw [repairFun_d (Ne.symm h.had) h.hdc (Ne.symm h.hbd), + hb', hd', hflip, Bool.not_not] + · rw [repairFun_of_ne h1 h2 h3 h4] + exact o.match_flip f hf + pairing_flip := o.pairing_flip + +end RelTransitionSystem + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransposeLedger.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransposeLedger.lean new file mode 100644 index 0000000000..d25f12e973 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransposeLedger.lean @@ -0,0 +1,814 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathStep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingConnectivity + +/-! +# The transpose ledger: the explicit two-path transform factor + +The two-path separated move transforms the +constrained summand by an **explicit** factor `T`. This file pins +`T` down, for the separated orientation class over the transported +orientation: + + `T = twoPathTransformFactor = −1`, + +**independent of the boundary state, of the `∂`-data at the four +re-paired ends, and of the transition system** beyond the two-chain +separated configuration. The decomposition behind the constant: + +* the vertex bookkeeping contributes the alternating-evaluation + transposition sign of the two re-paired pair-blocks at the + square's vertex (`MixedFunctional.evalOdd_transpose`, the + engine inside `throughSummand_transportRepair`): `−1`; +* the `oddPartnerSign` factors at the two changed blocks merely + commute (`+1`); +* the colour re-routing between the two chains is, at the sum + level, the **identity** reindexing of the `φ`-sum: the + transported orientation keeps `isOut`, each repaired chain still + carries its boundary colour data along the same strand segments, + and only the *partner* entries of the two vertex blocks swap. + So the state-dependent piece is `+1` for every boundary state — + the colour sets the functional is evaluated on change, but the + colourings themselves are not re-indexed. + +## Main results + +* `EdgeSubset.twoPathTransformFactor` — the explicit factor, + `(-1 : ℂ)` (`twoPathTransformFactor_eq_neg_one`). +* `EdgeSubset.twoPath_transform` — **the two-path transform**: on a + two-chain (non-localized) separated square, + `throughSummand (transportRepair o) (count κ') = + T * throughSummand o (count κ)` + (count invariance `openCircuitCount_repair_of_not_localized` plus + the vertex ledger `throughSummand_transportRepair`); + `twoPath_transform_exp` is the fixed-exponent form, showing `T` + is exponent-independent. +* `TransposeVerify` — a worked instance carrying the vocabulary + concretely, and the value `cSummand_O = −1` that + `ThroughIndCFalse.lean` compares against. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + +/-- **The two-path transform factor**: the explicit `T` of the +separated two-path move over the transported orientation. It is +the transposition sign of the alternating evaluation at the +square's vertex; the `oddPartnerSign` commutation and the colour +re-routing contribute `+1` each, so `T` is constant — independent +of the boundary state, the `∂`-data at the four re-paired ends, +and the transition system. -/ +noncomputable def twoPathTransformFactor : ℂ := -1 + +/-- The factor unfolded. -/ +theorem twoPathTransformFactor_eq_neg_one : + twoPathTransformFactor = -1 := rfl + +section Transform + + + +variable {α : Type} + +/-- The fixed-exponent transform: at every circuit exponent the +transported summand is `T` times the old summand — `T` is +exponent-independent (restating the vertex ledger with +the explicit factor). -/ +theorem twoPath_transform_exp + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} {k : ℕ} {ℓ : ℕ} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} + (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (hsq : RepairSquare κ a b c d v) (o : κ.Orientation) + (hflip : o.isOut c = !o.isOut a) (n : ℕ) : + F.throughSummand hM st hbnd + (RelTransitionSystem.Orientation.transportRepair hsq o + hflip) n = + twoPathTransformFactor * + F.throughSummand hM st hbnd o n := by + rw [throughSummand_transportRepair hM st hbnd hsq o hflip n] + unfold twoPathTransformFactor + ring + +/-- **The two-path transform**: a repair at a two-chain square +(`twoChains_of_not_localized` configuration), separated class, over +the transported orientation, transforms the constrained summand at +the open circuit counts by the explicit factor +`T = twoPathTransformFactor = −1` — the circuit count is unchanged +and the vertex transposition supplies the sign; the state-dependent +`∂`-piece of the colour re-routing is trivial at the sum level. -/ +theorem twoPath_transform + [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} {k : ℕ} {ℓ : ℕ} + {κ : F.RelTransitionSystem} {a : W.Flag} {b : W.Flag} {c : W.Flag} + {d : W.Flag} {v : W.Vertex} + (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (hsq : RepairSquare κ a b c d v) (o : κ.Orientation) + (hflip : o.isOut c = !o.isOut a) + (hnl : ¬ SquareLocalized κ a b c d) : + F.throughSummand hM st hbnd + (RelTransitionSystem.Orientation.transportRepair hsq o + hflip) + ((κ.repair a b c d v hsq).openCircuitCount) = + twoPathTransformFactor * + F.throughSummand hM st hbnd o κ.openCircuitCount := by + rw [openCircuitCount_repair_of_not_localized hsq hnl] + exact twoPath_transform_exp hM st hbnd hsq o hflip + κ.openCircuitCount + +end Transform + +end EdgeSubset + +/-! +## The worked instance + +One vertex carrying two boundary-to-boundary paths with disjoint +boundary chords: labels `0 < 1 < 2 < 3`, chain `(0,1)` through the +matched pair `0 ↔ 1`, chain `(2,3)` through `2 ↔ 3` (flags `0–3` +internal, flags `4–7` at the boundary labels), edge assignment +`pairing = ![4,5,7,6,0,1,3,2]`. The square `0 ↔ 1`, `2 ↔ 3` is +non-localized, the orientation `![F,T,T,F]` is separated +(`isOut 2 = !isOut 0`), both circuit counts are `0`, and both +chord-crossing counts are `0`, so both path signs are trivial +(`cChord_kappa`, `cPathSign_kappa`). + +Against the functional supported on the colour set `{0,5,2,7}` the +constrained summand is `−1` (`cSummand_O`). `LoopVerify.lean` +computes the same summand for a repaired system at a flipped +orientation, and `ThroughIndCFalse.lean` reads the two values off +to refute independence across boundary pairings. +-/ + +namespace TransposeVerify + +open EdgeSubset + +/-- One vertex, four pendant edges: flags `0–3` at the vertex, +flags `4–7` at boundary labels `0–3`; edges `{0,4}`, `{1,5}`, +`{3,6}`, `{2,7}`. -/ +@[reducible] def cFragment : Fragment (Fin 4) where + Flag := Fin 8 + Vertex := Unit + attach := ![Sum.inl (), Sum.inl (), Sum.inl (), Sum.inl (), + Sum.inr 0, Sum.inr 1, Sum.inr 2, Sum.inr 3] + pairing := ![4, 5, 7, 6, 0, 1, 3, 2] + pairing_invol := by decide + pairing_ne := by decide + boundaryFlag := ![4, 5, 6, 7] + attach_boundaryFlag := by decide + eq_boundaryFlag := by decide + circles := 0 + +/-- The unique vertex. -/ +def cV : cFragment.Vertex := () + +/-- The full edge subset. -/ +def cSubset : EdgeSubset cFragment := + ⟨Finset.univ, fun f _ => Finset.mem_univ (cFragment.pairing f)⟩ + +/-- The verification instance's matching: `0 ↔ 1`, `2 ↔ 3` at the +single vertex, boundary flags fixed. -/ +def cMatch : Fin 8 → Fin 8 := ![1, 0, 3, 2, 4, 5, 6, 7] + +/-- The instance's internal flags are exactly `0–3`. -/ +theorem cInternal_cases {f : Fin 8} + (hf : f ∈ cSubset.internalFlags) : + f = 0 ∨ f = 1 ∨ f = 2 ∨ f = 3 := by + obtain ⟨v, hv⟩ := cSubset.attach_internal_of_mem hf + cases v + fin_cases f + · exact Or.inl rfl + · exact Or.inr (Or.inl rfl) + · exact Or.inr (Or.inr (Or.inl rfl)) + · exact Or.inr (Or.inr (Or.inr rfl)) + · exact absurd hv (by decide) + · exact absurd hv (by decide) + · exact absurd hv (by decide) + · exact absurd hv (by decide) + +/-- Each of `0–3` is an internal flag. -/ +theorem cMem_internal {f : Fin 8} + (hf : f = 0 ∨ f = 1 ∨ f = 2 ∨ f = 3) : + f ∈ cSubset.internalFlags := by + rcases hf with rfl | rfl | rfl | rfl <;> + exact mem_internalFlags_of (Finset.mem_univ _) ⟨(), rfl⟩ + +/-- A boundary-attached flag is a boundary flag. -/ +theorem cMem_boundary {f : Fin 8} (i : Fin 4) + (h : cFragment.attach f = Sum.inr i) : + f ∈ cSubset.boundaryFlags := by + rcases cSubset.mem_internalFlags_or_boundaryFlags + (Finset.mem_univ f) with hint | hb + · obtain ⟨v, hv⟩ := cSubset.attach_internal_of_mem hint + rw [h] at hv + cases hv + · exact hb + +/-- The instance's boundary flags are exactly `4–7`. -/ +theorem cBoundary_cases {f : Fin 8} + (hf : f ∈ cSubset.boundaryFlags) : + f = 4 ∨ f = 5 ∨ f = 6 ∨ f = 7 := by + obtain ⟨lab, hlab⟩ := cSubset.attach_boundary_of_mem hf + have hbf := cFragment.eq_boundaryFlag lab f hlab + subst hbf + fin_cases lab + · exact Or.inl (by decide) + · exact Or.inr (Or.inl (by decide)) + · exact Or.inr (Or.inr (Or.inl (by decide))) + · exact Or.inr (Or.inr (Or.inr (by decide))) + +/-- The matching `0 ↔ 1`, `2 ↔ 3`: two boundary chains with +disjoint chords `(0,1)` and `(2,3)`. -/ +def cKappa : cSubset.RelTransitionSystem where + match_ := cMatch + match_invol := fun f hf => by + rcases cInternal_cases hf with rfl | rfl | rfl | rfl <;> rfl + match_ne := fun f hf => by + rcases cInternal_cases hf with rfl | rfl | rfl | rfl <;> decide + match_mem := fun f hf => by + rcases cInternal_cases hf with rfl | rfl | rfl | rfl + · exact cMem_internal (Or.inr (Or.inl rfl)) + · exact cMem_internal (Or.inl rfl) + · exact cMem_internal (Or.inr (Or.inr (Or.inr rfl))) + · exact cMem_internal (Or.inr (Or.inr (Or.inl rfl))) + match_vertex := fun f hf v hv => by + cases v + rcases cInternal_cases hf with rfl | rfl | rfl | rfl <;> rfl + +/-- The square `0 ↔ 1`, `2 ↔ 3` at the vertex. -/ +theorem cSquare : RepairSquare cKappa 0 1 2 3 cV := + ⟨cMem_internal (Or.inl rfl), + cMem_internal (Or.inr (Or.inr (Or.inl rfl))), + rfl, rfl, by decide, by decide, by decide, by decide, rfl, rfl⟩ + +/-- The separated, path-canonical orientation: both chains enter +the vertex through their low-label ends. -/ +def cO : cKappa.Orientation where + isOut := ![false, true, true, false, false, false, false, false] + match_flip := fun f hf => by + rcases cInternal_cases hf with rfl | rfl | rfl | rfl <;> rfl + pairing_flip := fun f hf hp => by + rcases cInternal_cases hf with rfl | rfl | rfl | rfl <;> + · rcases cInternal_cases hp with h | h | h | h <;> + exact absurd h (by decide) + +/-- The boundary state: odd colours `0, 1, 2, 3` at labels +`0, 1, 2, 3`. -/ +def cState : GenBoundaryState 0 4 (Fin 4) := + ![Sum.inr 0, Sum.inr 1, Sum.inr 2, Sum.inr 3] + +/-- The state matches the fragment's boundary: each of the four +legs carries the colour the state names. -/ +theorem cBnd : + genBoundarySubsetMatches cFragment cSubset.flags cState := by + intro i + constructor + · intro _ + fin_cases i + · exact ⟨0, rfl⟩ + · exact ⟨1, rfl⟩ + · exact ⟨2, rfl⟩ + · exact ⟨3, rfl⟩ + · intro _ + exact Finset.mem_univ _ + +/-- The functional supported on the colour set `{0, 5, 2, 7}` (the +odd-list set of the original summand). -/ +noncomputable def cFunctional : MixedFunctional 0 4 := + fun _ s => if s = ({0, 5, 2, 7} : Finset (Fin (2 * 4))) then 1 + else 0 + +/-- The functional's values, unfolded: `1` at the original +summand's odd-list set and `0` elsewhere. -/ +theorem cFunctional_apply (μ : Multiset (Fin 0)) + (s : Finset (Fin (2 * 4))) : + cFunctional μ s = + if s = ({0, 5, 2, 7} : Finset (Fin (2 * 4))) then 1 else 0 := + rfl + +/-! ### The pinned core colouring -/ + +/-- Every flag is a core flag. -/ +theorem cCoreFlags : cSubset.coreFlags = Finset.univ := by + apply Finset.ext + intro g + simp only [Finset.mem_univ, iff_true] + rw [EdgeSubset.mem_coreFlags_iff] + refine ⟨Finset.mem_univ g, ?_⟩ + fin_cases g + · exact Or.inl ⟨cV, rfl⟩ + · exact Or.inl ⟨cV, rfl⟩ + · exact Or.inl ⟨cV, rfl⟩ + · exact Or.inl ⟨cV, rfl⟩ + · exact Or.inr ⟨cV, rfl⟩ + · exact Or.inr ⟨cV, rfl⟩ + · exact Or.inr ⟨cV, rfl⟩ + · exact Or.inr ⟨cV, rfl⟩ + +/-- No flag is a through flag: both boundary chains pass through +the vertex. -/ +theorem cThroughFlags : cSubset.throughFlags = ∅ := by + rw [Finset.eq_empty_iff_forall_notMem] + intro f hf + have hcore : f ∈ cSubset.coreFlags := by + rw [cCoreFlags] + exact Finset.mem_univ f + unfold EdgeSubset.coreFlags at hcore + exact (Finset.mem_sdiff.mp hcore).2 hf + +/-- With no through flags the through product is `1`, so it drops +out of both summands being compared. -/ +theorem cThroughProduct : + cSubset.throughProduct cState = 1 := by + unfold EdgeSubset.throughProduct + rw [cThroughFlags] + simp + +/-- The edge colours: edge `{0,4}` gets `0`, `{1,5}` gets `1`, +`{3,6}` gets `2`, `{2,7}` gets `3`. -/ +def cColour : Fin 8 → Fin (2 * 4) := ![0, 1, 3, 2, 0, 1, 2, 3] + +/-- The pinned core odd colouring. -/ +noncomputable def cPhi : cSubset.CoreOddColouring 4 := + ⟨fun g => cColour g.val, fun g => by + have hval : ∀ x : Fin 8, + cColour (cFragment.pairing x) = cColour x := by decide + exact hval g.val⟩ + +/-- Every flag participates, so there are no non-participating +flags to colour. -/ +instance : + IsEmpty {f : cFragment.Flag // f ∉ cSubset.flags} := + ⟨fun f => f.prop (Finset.mem_univ f.val)⟩ + +/-- The unique (empty) even colouring. -/ +noncomputable def cPsi : cSubset.EvenColouring 0 := + ⟨fun f => isEmptyElim f, fun f => isEmptyElim f⟩ + +/-- The even colouring is unique: there is nothing to choose. -/ +instance : Subsingleton (cSubset.EvenColouring 0) := + ⟨fun _ _ => Subtype.ext (funext fun f => isEmptyElim f)⟩ + +/-- The empty even colouring matches the state's even part: with +`k = 0` there is nothing to check. -/ +theorem cEvenMatch : + genEvenBoundaryMatch cSubset cState cBnd cPsi := + fun _ c _ => Fin.elim0 c + +/-- The pinned colouring is boundary-matched. -/ +theorem cOddMatch : + cSubset.coreOddBoundaryMatch cState cPhi := by + intro i c hst hcore + fin_cases i + · obtain rfl : (0 : Fin (2 * 4)) = c := Sum.inr.inj hst + rfl + · obtain rfl : (1 : Fin (2 * 4)) = c := Sum.inr.inj hst + rfl + · obtain rfl : (2 : Fin (2 * 4)) = c := Sum.inr.inj hst + rfl + · obtain rfl : (3 : Fin (2 * 4)) = c := Sum.inr.inj hst + rfl + +/-- **The colouring is forced**: every boundary-matched core odd +colouring is the pinned one, so each summand is a single term. -/ +theorem cPhi_unique (φ : cSubset.CoreOddColouring 4) + (hB : cSubset.coreOddBoundaryMatch cState φ) : φ = cPhi := by + have hcore : ∀ g : Fin 8, g ∈ cSubset.coreFlags := fun g => by + rw [cCoreFlags] + exact Finset.mem_univ g + have h4 : φ.val ⟨(4 : Fin 8), hcore 4⟩ = 0 := hB 0 0 rfl (hcore 4) + have h5 : φ.val ⟨(5 : Fin 8), hcore 5⟩ = 1 := hB 1 1 rfl (hcore 5) + have h6 : φ.val ⟨(6 : Fin 8), hcore 6⟩ = 2 := hB 2 2 rfl (hcore 6) + have h7 : φ.val ⟨(7 : Fin 8), hcore 7⟩ = 3 := hB 3 3 rfl (hcore 7) + have h0 : φ.val ⟨(0 : Fin 8), hcore 0⟩ = 0 := by + have hp := φ.prop ⟨(0 : Fin 8), hcore 0⟩ + exact hp.symm.trans h4 + have h1 : φ.val ⟨(1 : Fin 8), hcore 1⟩ = 1 := by + have hp := φ.prop ⟨(1 : Fin 8), hcore 1⟩ + exact hp.symm.trans h5 + have h2 : φ.val ⟨(2 : Fin 8), hcore 2⟩ = 3 := by + have hp := φ.prop ⟨(2 : Fin 8), hcore 2⟩ + exact hp.symm.trans h7 + have h3 : φ.val ⟨(3 : Fin 8), hcore 3⟩ = 2 := by + have hp := φ.prop ⟨(3 : Fin 8), hcore 3⟩ + exact hp.symm.trans h6 + apply Subtype.ext + funext g + have hval : ∀ (x : Fin 8) (hx : x ∈ cSubset.coreFlags), + φ.val ⟨x, hx⟩ = cColour x := by + intro x hx + fin_cases x + · exact h0 + · exact h1 + · exact h2 + · exact h3 + · exact h4 + · exact h5 + · exact h6 + · exact h7 + exact hval g.val g.prop + +/-! ### Two-element in-lists -/ + +/-- A duplicate-free list whose members are exactly two distinct +elements is one of the two orderings of that pair. -/ +theorem list_pair_cases {γ : Type} {x y : γ} {l : List γ} + (hxy : x ≠ y) (hnd : l.Nodup) + (hmem : ∀ g, g ∈ l ↔ (g = x ∨ g = y)) : + l = [x, y] ∨ l = [y, x] := by + rcases l with _ | ⟨u, l₂⟩ + · have := (hmem x).mpr (Or.inl rfl) + simp at this + rcases l₂ with _ | ⟨w, l₃⟩ + · have hx := (hmem x).mpr (Or.inl rfl) + have hy := (hmem y).mpr (Or.inr rfl) + simp only [List.mem_singleton] at hx hy + exact absurd (hx.trans hy.symm) hxy + rcases l₃ with _ | ⟨r, l₄⟩ + · have hu := (hmem u).mp (by simp) + have hw := (hmem w).mp (by simp) + have hne : u ≠ w := by + simp only [List.nodup_cons, List.mem_singleton] at hnd + exact fun he => hnd.1 (by simp [he]) + rcases hu with rfl | rfl + · rcases hw with rfl | rfl + · exact absurd rfl hne + · exact Or.inl rfl + · rcases hw with rfl | rfl + · exact Or.inr rfl + · exact absurd rfl hne + · exfalso + have hu := (hmem u).mp (by simp) + have hw := (hmem w).mp (by simp) + have hr := (hmem r).mp (by simp) + simp only [List.nodup_cons, List.mem_cons, not_or] at hnd + obtain ⟨⟨huw, hur, -⟩, ⟨hwr, -⟩, -⟩ := hnd + rcases hu with rfl | rfl <;> rcases hw with rfl | rfl <;> + rcases hr with rfl | rfl <;> simp_all + +/-- The in-flag list at the vertex, up to order, read off an +orientation's `isOut` table: the two flags oriented inwards. -/ +theorem cRelIn_pair {κ : cSubset.RelTransitionSystem} + (o : κ.Orientation) {i0 i1 i2 i3 : Bool} + (h0 : o.isOut 0 = i0) (h1 : o.isOut 1 = i1) + (h2 : o.isOut 2 = i2) (h3 : o.isOut 3 = i3) + (g₁ g₂ : Fin 8) (hne : g₁ ≠ g₂) + (hpat : ∀ g : Fin 8, + ((g = 0 ∧ i0 = false) ∨ (g = 1 ∧ i1 = false) ∨ + (g = 2 ∧ i2 = false) ∨ (g = 3 ∧ i3 = false)) ↔ + (g = g₁ ∨ g = g₂)) : + cSubset.relInFlagsAt o cV = [g₁, g₂] ∨ + cSubset.relInFlagsAt o cV = [g₂, g₁] := by + refine list_pair_cases hne (relInFlagsAt_nodup o cV) (fun g => ?_) + rw [mem_relInFlagsAt_iff, ← hpat g] + constructor + · rintro ⟨-, hat, hout⟩ + fin_cases g + · exact Or.inl ⟨rfl, h0.symm.trans hout⟩ + · exact Or.inr (Or.inl ⟨rfl, h1.symm.trans hout⟩) + · exact Or.inr (Or.inr (Or.inl ⟨rfl, h2.symm.trans hout⟩)) + · exact Or.inr (Or.inr (Or.inr ⟨rfl, h3.symm.trans hout⟩)) + · exact absurd hat (by decide) + · exact absurd hat (by decide) + · exact absurd hat (by decide) + · exact absurd hat (by decide) + · rintro (⟨rfl, hb⟩ | ⟨rfl, hb⟩ | ⟨rfl, hb⟩ | ⟨rfl, hb⟩) + · exact ⟨Finset.mem_univ _, rfl, h0.trans hb⟩ + · exact ⟨Finset.mem_univ _, rfl, h1.trans hb⟩ + · exact ⟨Finset.mem_univ _, rfl, h2.trans hb⟩ + · exact ⟨Finset.mem_univ _, rfl, h3.trans hb⟩ + +/-! ### The summand over a two-element in-list -/ + +/-- The vertex sign over a two-element in-list: the product of the +two entry partners' `oddPartnerSign`s. -/ +theorem cCoreOddSignAt (κ : cSubset.RelTransitionSystem) + (o : κ.Orientation) (g₁ g₂ : Fin 8) + (hglist : cSubset.relInFlagsAt o cV = [g₁, g₂]) : + cSubset.coreOddSignAt o cPhi cV = + oddPartnerSign 4 (cColour (κ.match_ g₁)) * + oddPartnerSign 4 (cColour (κ.match_ g₂)) := by + unfold EdgeSubset.coreOddSignAt + rw [List.attachWith_congr hglist] + simp only [List.attachWith_cons, List.attachWith_nil, + List.map_cons, List.map_nil, List.prod_cons, List.prod_nil, + mul_one] + rfl + +/-- The vertex odd list over a two-element in-list: each in-flag's +colour followed by its match's partner colour. -/ +theorem cCoreOddListAt (κ : cSubset.RelTransitionSystem) + (o : κ.Orientation) (g₁ g₂ : Fin 8) + (hglist : cSubset.relInFlagsAt o cV = [g₁, g₂]) : + cSubset.coreOddListAt o cPhi cV = + [cColour g₁, oddPartner 4 (cColour (κ.match_ g₁)), + cColour g₂, oddPartner 4 (cColour (κ.match_ g₂))] := by + unfold EdgeSubset.coreOddListAt + rw [List.attachWith_congr hglist] + simp only [List.attachWith_cons, List.attachWith_nil, + List.flatMap_cons, List.flatMap_nil, List.append_nil] + rfl + +open Classical in +/-- **The summand over a two-element in-list**: with the colouring +forced and the through product trivial, the whole summand is the +single vertex factor. -/ +theorem cThroughSummand (κ : cSubset.RelTransitionSystem) + (o : κ.Orientation) (g₁ g₂ : Fin 8) + (hglist : cSubset.relInFlagsAt o cV = [g₁, g₂]) : + cSubset.throughSummand cFunctional cState cBnd o 0 = + ((oddPartnerSign 4 (cColour (κ.match_ g₁)) * + oddPartnerSign 4 (cColour (κ.match_ g₂)) : ℤ) : ℂ) * + MixedFunctional.evalOdd cFunctional + (cSubset.evenColoursAt cPsi cV) + [cColour g₁, oddPartner 4 (cColour (κ.match_ g₁)), + cColour g₂, oddPartner 4 (cColour (κ.match_ g₂))] := by + unfold EdgeSubset.throughSummand + rw [cThroughProduct, pow_zero, one_mul, one_mul] + rw [Fintype.sum_subsingleton _ cPsi] + rw [ite_eq_left cEvenMatch] + have hzero : ∀ φ : cSubset.CoreOddColouring 4, φ ≠ cPhi → + (if cSubset.coreOddBoundaryMatch cState φ then + ∏ v : cFragment.Vertex, + ((cSubset.coreOddSignAt o φ v : ℂ) * + MixedFunctional.evalOdd cFunctional + (cSubset.evenColoursAt cPsi v) + (cSubset.coreOddListAt o φ v)) + else 0) = 0 := by + intro φ hφ + rcases Classical.em (cSubset.coreOddBoundaryMatch cState φ) with + hb | hb + · exact absurd (cPhi_unique φ hb) hφ + · rw [ite_eq_right hb] + rw [Fintype.sum_eq_single cPhi hzero] + rw [ite_eq_left cOddMatch] + rw [Fintype.prod_subsingleton _ cV] + rw [cCoreOddSignAt κ o g₁ g₂ hglist, cCoreOddListAt κ o g₁ g₂ + hglist] + +/-! ### Open circuit counts -/ + +/-- No system on this instance has periodic flags: every flag lies +on a boundary-to-boundary chain. -/ +theorem cPeriodic_empty (κ : cSubset.RelTransitionSystem) : + κ.periodicFlags = ∅ := by + rw [Finset.eq_empty_iff_forall_notMem] + intro f hf + obtain ⟨hint, n, hn1, hcont, -⟩ := κ.mem_periodicFlags.mp hf + have h0 := hcont 0 (by omega) + rw [iterWalk_zero] at h0 + rcases cInternal_cases hint with rfl | rfl | rfl | rfl <;> + · rcases cInternal_cases h0 with h | h | h | h <;> + exact absurd h (by decide) + +/-- Pointwise form of `cPeriodic_empty`. -/ +theorem cNot_periodic (κ : cSubset.RelTransitionSystem) + (f : Fin 8) : ¬ κ.PeriodicFlag f := fun hper => + Finset.notMem_empty f + (cPeriodic_empty κ ▸ κ.mem_periodicFlags.mpr hper) + +open Classical in +/-- Every system on this instance has open circuit count `0`, so +the original and repaired summands are compared at the same loop +weight. -/ +theorem cCount_zero (κ : cSubset.RelTransitionSystem) : + κ.openCircuitCount = 0 := by + have hemp : IsEmpty {f : cFragment.Flag // f ∈ κ.periodicFlags} := + ⟨fun x => cNot_periodic κ x.val (κ.mem_periodicFlags.mp x.prop)⟩ + have h1 : κ.walkPermPeriodic = 1 := Equiv.ext (fun x => hemp.elim x) + unfold RelTransitionSystem.openCircuitCount + rw [h1, Equiv.Perm.cycleType_one, Multiset.card_zero] + have h2 : ∀ (inst : Fintype (Function.fixedPoints + (1 : Equiv.Perm {f : cFragment.Flag // f ∈ κ.periodicFlags}))), + @Fintype.card _ inst = 0 := fun inst => + (@Fintype.card_eq_zero_iff _ inst).mpr + ⟨fun x => hemp.elim x.val⟩ + rw [h2 _] + +/-! ### Path matchings and chord-crossing counts -/ + +/-- Path-match evaluation along a one-internal-step chain: enter at +`β`, cross to `x`, match, leave at `g`. -/ +theorem cPathMatch_eval (κ : cSubset.RelTransitionSystem) + {β x g : Fin 8} (hβ : β ∈ cSubset.boundaryFlags) + (h1 : cFragment.pairing β = x) + (hx : x ∈ cSubset.internalFlags) + (h2 : cFragment.pairing (κ.match_ x) = g) + (hg : g ∈ cSubset.boundaryFlags) : + κ.pathMatch β hβ = g := by + have hcont : ∀ t, t < 1 → + cFragment.pairing (iterWalk κ β t) ∈ cSubset.internalFlags := by + intro t ht + obtain rfl : t = 0 := by omega + rw [iterWalk_zero, h1] + exact hx + have hw1 : iterWalk κ β 1 = κ.match_ x := by + rw [iterWalk_succ, iterWalk_zero, h1] + have hterm : cFragment.pairing (iterWalk κ β 1) ∈ + cSubset.boundaryFlags := by + rw [hw1, h2] + exact hg + have hpm := pathMatch_eq_of_chain κ hβ hcont hterm + rw [hpm, hw1, h2] + +/-- The original system's chain from `4` ends at `5`. -/ +theorem cPM_4 (h : (4 : Fin 8) ∈ cSubset.boundaryFlags) : + cKappa.pathMatch 4 h = 5 := + cPathMatch_eval cKappa (x := 0) h rfl (cMem_internal (Or.inl rfl)) + rfl (cMem_boundary 1 rfl) + +/-- The original system's chain from `5` ends at `4`. -/ +theorem cPM_5 (h : (5 : Fin 8) ∈ cSubset.boundaryFlags) : + cKappa.pathMatch 5 h = 4 := + cPathMatch_eval cKappa (x := 1) h rfl + (cMem_internal (Or.inr (Or.inl rfl))) rfl (cMem_boundary 0 rfl) + +/-- The original system's chain from `6` ends at `7`. -/ +theorem cPM_6 (h : (6 : Fin 8) ∈ cSubset.boundaryFlags) : + cKappa.pathMatch 6 h = 7 := + cPathMatch_eval cKappa (x := 3) h rfl + (cMem_internal (Or.inr (Or.inr (Or.inr rfl)))) rfl + (cMem_boundary 3 rfl) + +/-- The original system's chain from `7` ends at `6`. -/ +theorem cPM_7 (h : (7 : Fin 8) ∈ cSubset.boundaryFlags) : + cKappa.pathMatch 7 h = 6 := + cPathMatch_eval cKappa (x := 2) h rfl + (cMem_internal (Or.inr (Or.inr (Or.inl rfl)))) rfl + (cMem_boundary 2 rfl) + +/-- The repaired system re-pairs the boundary: its chain from `4` +ends at `7`, not `5`. -/ +theorem cPM'_4 (h : (4 : Fin 8) ∈ cSubset.boundaryFlags) : + (cKappa.repair 0 1 2 3 cV cSquare).pathMatch 4 h = 7 := + cPathMatch_eval _ (x := 0) h rfl (cMem_internal (Or.inl rfl)) + (by rw [RelTransitionSystem.repair_match_a cSquare]; rfl) + (cMem_boundary 3 rfl) + +/-- The repaired system's chain from `5` ends at `6`. -/ +theorem cPM'_5 (h : (5 : Fin 8) ∈ cSubset.boundaryFlags) : + (cKappa.repair 0 1 2 3 cV cSquare).pathMatch 5 h = 6 := + cPathMatch_eval _ (x := 1) h rfl + (cMem_internal (Or.inr (Or.inl rfl))) + (by rw [RelTransitionSystem.repair_match_b cSquare]; rfl) + (cMem_boundary 2 rfl) + +/-- The repaired system's chain from `6` ends at `5`. -/ +theorem cPM'_6 (h : (6 : Fin 8) ∈ cSubset.boundaryFlags) : + (cKappa.repair 0 1 2 3 cV cSquare).pathMatch 6 h = 5 := + cPathMatch_eval _ (x := 3) h rfl + (cMem_internal (Or.inr (Or.inr (Or.inr rfl)))) + (by rw [RelTransitionSystem.repair_match_d cSquare]; rfl) + (cMem_boundary 1 rfl) + +/-- The repaired system's chain from `7` ends at `4`. -/ +theorem cPM'_7 (h : (7 : Fin 8) ∈ cSubset.boundaryFlags) : + (cKappa.repair 0 1 2 3 cV cSquare).pathMatch 7 h = 4 := + cPathMatch_eval _ (x := 2) h rfl + (cMem_internal (Or.inr (Or.inr (Or.inl rfl)))) + (by rw [RelTransitionSystem.repair_match_c cSquare]; rfl) + (cMem_boundary 0 rfl) + +/-- Reading a chord's two labels off a chain: the labels recorded +by `attach` at the chain's ends are the chord's. -/ +theorem cChord_label {κ : cSubset.RelTransitionSystem} + {x g : Fin 8} {hx : x ∈ cSubset.boundaryFlags} {i j : Fin 4} + (hpm : κ.pathMatch x hx = g) + (h1 : cFragment.attach x = Sum.inr i) + (h2 : cFragment.attach (κ.pathMatch x hx) = Sum.inr j) + {i0 j0 : Fin 4} + (hxa : cFragment.attach x = Sum.inr i0) + (hga : cFragment.attach g = Sum.inr j0) : + i = i0 ∧ j = j0 := by + rw [h1] at hxa + rw [hpm, hga] at h2 + exact ⟨Sum.inr.inj hxa, (Sum.inr.inj h2).symm⟩ + +open Classical in +/-- A system whose chords all join adjacent labels has no +interleaving pair, hence crossing count `0`. -/ +theorem cChord_empty (κ : cSubset.RelTransitionSystem) + (hpair : ∀ (x : Fin 8) (hx : x ∈ cSubset.boundaryFlags) + (i j : Fin 4), cFragment.attach x = Sum.inr i → + cFragment.attach (κ.pathMatch x hx) = Sum.inr j → + (i = 0 ∧ j = 1) ∨ (i = 1 ∧ j = 0) ∨ (i = 2 ∧ j = 3) ∨ + (i = 3 ∧ j = 2) ∨ (i = 0 ∧ j = 3) ∨ (i = 3 ∧ j = 0) ∨ + (i = 1 ∧ j = 2) ∨ (i = 2 ∧ j = 1)) : + chordCrossingCount κ = 0 := by + unfold chordCrossingCount + rw [Finset.card_eq_zero, Finset.filter_eq_empty_iff] + rintro ⟨⟨x, hx⟩, ⟨x', hx'⟩⟩ - + rintro ⟨i, j, i', j', ha1, ha2, ha3, ha4, h5, h6, h7, h8, h9⟩ + have hp := hpair x hx i j ha1 ha2 + have hp' := hpair x' hx' i' j' ha3 ha4 + rcases hp with ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | + ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | + ⟨rfl, rfl⟩ <;> + rcases hp' with ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | + ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | + ⟨rfl, rfl⟩ <;> + revert h5 h6 h7 h8 h9 <;> decide + +open Classical in +/-- The original system's chords `(0,1)` and `(2,3)` are disjoint: +crossing count `0`. -/ +theorem cChord_kappa : chordCrossingCount cKappa = 0 := by + refine cChord_empty cKappa ?_ + intro x hx i j h1 h2 + rcases cBoundary_cases hx with rfl | rfl | rfl | rfl + · obtain ⟨rfl, rfl⟩ := cChord_label (cPM_4 hx) h1 h2 rfl rfl + tauto + · obtain ⟨rfl, rfl⟩ := cChord_label (cPM_5 hx) h1 h2 rfl rfl + tauto + · obtain ⟨rfl, rfl⟩ := cChord_label (cPM_6 hx) h1 h2 rfl rfl + tauto + · obtain ⟨rfl, rfl⟩ := cChord_label (cPM_7 hx) h1 h2 rfl rfl + tauto + +open Classical in +/-- The repaired system's chords `(0,3)` and `(1,2)` nest: +crossing count `0` as well. -/ +theorem cChord_repair : + chordCrossingCount (cKappa.repair 0 1 2 3 cV cSquare) = 0 := by + refine cChord_empty _ ?_ + intro x hx i j h1 h2 + rcases cBoundary_cases hx with rfl | rfl | rfl | rfl + · obtain ⟨rfl, rfl⟩ := cChord_label (cPM'_4 hx) h1 h2 rfl rfl + tauto + · obtain ⟨rfl, rfl⟩ := cChord_label (cPM'_5 hx) h1 h2 rfl rfl + tauto + · obtain ⟨rfl, rfl⟩ := cChord_label (cPM'_6 hx) h1 h2 rfl rfl + tauto + · obtain ⟨rfl, rfl⟩ := cChord_label (cPM'_7 hx) h1 h2 rfl rfl + tauto + +/-- The original path sign is `1`. -/ +theorem cPathSign_kappa : pathSign cKappa = 1 := by + unfold EdgeSubset.pathSign + rw [cChord_kappa, pow_zero] + +/-- The repaired path sign is `1` too — so the factor the two +summands differ by is *not* the chord sign. -/ +theorem cPathSign_repair : + pathSign (cKappa.repair 0 1 2 3 cV cSquare) = 1 := by + unfold EdgeSubset.pathSign + rw [cChord_repair, pow_zero] + +/-! ### The two summand values -/ + +open Classical in +/-- **The original summand is `−1`.** -/ +theorem cSummand_O : + cSubset.throughSummand cFunctional cState cBnd cO 0 = -1 := by + rcases cRelIn_pair (κ := cKappa) cO rfl rfl rfl rfl 0 3 (by decide) + (by decide) with h | h + · rw [cThroughSummand cKappa cO 0 3 h, + show cKappa.match_ 0 = 1 from rfl, + show cKappa.match_ 3 = 2 from rfl, + show (oddPartnerSign 4 (cColour 1) * + oddPartnerSign 4 (cColour 2) : ℤ) = 1 from by decide, + show [cColour 0, oddPartner 4 (cColour 1), cColour 3, + oddPartner 4 (cColour 2)] = + ([0, 5, 2, 7] : List (Fin (2 * 4))) from by decide, + MixedFunctional.evalOdd, + ite_eq_left (by decide : ([0, 5, 2, 7] : List (Fin (2 * 4))).Nodup), + show sortSign ([0, 5, 2, 7] : List (Fin (2 * 4))) = -1 from + by decide, + show ([0, 5, 2, 7] : List (Fin (2 * 4))).toFinset = + ({0, 5, 2, 7} : Finset (Fin (2 * 4))) from by decide, + cFunctional_apply, ite_eq_left rfl] + norm_num + · rw [cThroughSummand cKappa cO 3 0 h, + show cKappa.match_ 0 = 1 from rfl, + show cKappa.match_ 3 = 2 from rfl, + show (oddPartnerSign 4 (cColour 2) * + oddPartnerSign 4 (cColour 1) : ℤ) = 1 from by decide, + show [cColour 3, oddPartner 4 (cColour 2), cColour 0, + oddPartner 4 (cColour 1)] = + ([2, 7, 0, 5] : List (Fin (2 * 4))) from by decide, + MixedFunctional.evalOdd, + ite_eq_left (by decide : ([2, 7, 0, 5] : List (Fin (2 * 4))).Nodup), + show sortSign ([2, 7, 0, 5] : List (Fin (2 * 4))) = -1 from + by decide, + show ([2, 7, 0, 5] : List (Fin (2 * 4))).toFinset = + ({0, 5, 2, 7} : Finset (Fin (2 * 4))) from by decide, + cFunctional_apply, ite_eq_left rfl] + norm_num + +end TransposeVerify + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathNonSep.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathNonSep.lean new file mode 100644 index 0000000000..ce91f9e34a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathNonSep.lean @@ -0,0 +1,1610 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransposeLedger +public import LeanPool.RegtsSevenster.RS.Novel.Skein.NonSeparatedStep + +/-! +# The two-path non-separated transform + +The value transformation of the constrained summand under a +non-localized repair square whose orientation is non-separated +(`o.isOut c = o.isOut a`). The transported orientation flips the +whole boundary chain of `c`, which is legal because the chain's two +ends carry unconstrained boundary partners, and then transports +across the now-separated square. + +The chain flip is not a scalar at a fixed state: the `∂`-reindex of +the colour sum meets the boundary at the chain's two end labels, so +the flipped summand is a signed summand at a *modified* state, the +two end labels' odd colours replaced by their `∂`-partners. +Composing with the separated ledger gives the transform, whose +factor is minus the product of the two end colours' odd-partner +signs. +-/ + +@[expose] public section + +namespace RS + + + +/-! ## The two-label `∂`-relabel of a boundary state -/ + +open scoped Classical in +/-- Apply the odd-partner involution to the (odd) state entries at +two labels, leaving all other labels untouched. -/ +noncomputable def stateOddFlip {k ℓ : ℕ} {α : Type} + (st : GenBoundaryState k ℓ α) (i₁ i₂ : α) : + GenBoundaryState k ℓ α := + fun i => if i = i₁ ∨ i = i₂ then Sum.map id (oddPartner ℓ) (st i) + else st i + +section StateFlip + +variable {k ℓ : ℕ} {α : Type} {st : GenBoundaryState k ℓ α} + {i₁ i₂ : α} + +open scoped Classical in +/-- Away from the two labels the state is unchanged. -/ +theorem stateOddFlip_of_ne {i : α} (h1 : i ≠ i₁) (h2 : i ≠ i₂) : + stateOddFlip st i₁ i₂ i = st i := + ite_eq_right (fun h => h.elim h1 h2) + +open scoped Classical in +/-- At the first label the state entry is `∂`-flipped. -/ +theorem stateOddFlip_left : + stateOddFlip st i₁ i₂ i₁ = Sum.map id (oddPartner ℓ) (st i₁) := + ite_eq_left (Or.inl rfl) + +open scoped Classical in +/-- At the second label likewise. -/ +theorem stateOddFlip_right : + stateOddFlip st i₁ i₂ i₂ = Sum.map id (oddPartner ℓ) (st i₂) := + ite_eq_left (Or.inr rfl) + +/-- At the first label, on an odd entry: the colour is replaced by +its odd partner. -/ +theorem stateOddFlip_left_odd {c : Fin (2 * ℓ)} + (hc : st i₁ = Sum.inr c) : + stateOddFlip st i₁ i₂ i₁ = Sum.inr (oddPartner ℓ c) := by + rw [stateOddFlip_left, hc] + rfl + +/-- At the second label likewise. -/ +theorem stateOddFlip_right_odd {c : Fin (2 * ℓ)} + (hc : st i₂ = Sum.inr c) : + stateOddFlip st i₁ i₂ i₂ = Sum.inr (oddPartner ℓ c) := by + rw [stateOddFlip_right, hc] + rfl + +open scoped Classical in +/-- The relabel preserves odd-ness of every entry. -/ +theorem stateOddFlip_isInr (i : α) : + (∃ c, stateOddFlip st i₁ i₂ i = Sum.inr c) ↔ + ∃ c, st i = Sum.inr c := by + unfold stateOddFlip + by_cases h : i = i₁ ∨ i = i₂ + · rw [ite_eq_left h] + cases hst : st i with + | inl a => + constructor + · rintro ⟨c, hc⟩ + cases hc + · rintro ⟨c, hc⟩ + cases hc + | inr b => exact ⟨fun _ => ⟨b, rfl⟩, + fun _ => ⟨oddPartner ℓ b, rfl⟩⟩ + · rw [ite_eq_right h] + +open scoped Classical in +/-- The relabel fixes every even entry. -/ +theorem stateOddFlip_isInl (i : α) (a : Fin k) : + stateOddFlip st i₁ i₂ i = Sum.inl a ↔ st i = Sum.inl a := by + unfold stateOddFlip + by_cases h : i = i₁ ∨ i = i₂ + · rw [ite_eq_left h] + cases hst : st i with + | inl a' => exact Iff.rfl + | inr b => + constructor + · intro hc + cases hc + · intro hc + cases hc + · rw [ite_eq_right h] + +/-- The boundary-membership constraint transfers across the +relabel. -/ +theorem genBoundarySubsetMatches_stateOddFlip {W : Fragment α} + {s : Finset W.Flag} (hbnd : genBoundarySubsetMatches W s st) + (i₁ i₂ : α) : + genBoundarySubsetMatches W s (stateOddFlip st i₁ i₂) := + fun i => (hbnd i).trans (stateOddFlip_isInr i).symm + +open scoped Classical in +/-- **The relabel is an involution.** -/ +theorem stateOddFlip_stateOddFlip : + stateOddFlip (stateOddFlip st i₁ i₂) i₁ i₂ = st := by + funext i + change (if i = i₁ ∨ i = i₂ then + Sum.map id (oddPartner ℓ) (stateOddFlip st i₁ i₂ i) + else stateOddFlip st i₁ i₂ i) = st i + by_cases h : i = i₁ ∨ i = i₂ + · rw [ite_eq_left h, show stateOddFlip st i₁ i₂ i = + Sum.map id (oddPartner ℓ) (st i) from ite_eq_left h] + cases st i with + | inl a => rfl + | inr b => + change Sum.inr (oddPartner ℓ (oddPartner ℓ b)) = Sum.inr b + rw [oddPartner_invol] + · rw [ite_eq_right h] + exact stateOddFlip_of_ne (fun he => h (Or.inl he)) + (fun he => h (Or.inr he)) + +/-- The summand only reads the state and the proof of the boundary +constraint is irrelevant: propositionally equal states give equal +summands over any proofs. -/ +theorem EdgeSubset.throughSummand_state_congr {W : Fragment α} + [LinearOrder α] (F : EdgeSubset W) + (hM : MixedFunctional k ℓ) {st₁ st₂ : GenBoundaryState k ℓ α} + (hst : st₁ = st₂) + (hbnd₁ : genBoundarySubsetMatches W F.flags st₁) + (hbnd₂ : genBoundarySubsetMatches W F.flags st₂) + {κ : F.RelTransitionSystem} (o : κ.Orientation) (n : ℕ) : + F.throughSummand hM st₁ hbnd₁ o n = + F.throughSummand hM st₂ hbnd₂ o n := by + subst hst + rfl + +end StateFlip + +namespace EdgeSubset + +/-! ## The ported flip set and the chain-flipped orientation -/ + +section PortedFlip + +variable {α : Type} {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {S : Finset W.Flag} + {p₁ p₂ : W.Flag} {i₁ i₂ : α} + +/-- **The ported flip set**: a set of internal flags closed under +the matching and closed under the edge pairing except at two +*ports* `p₁`, `p₂`, whose edge partners are the boundary flags of +the labels `i₁`, `i₂`. The internal-flag support of a full +boundary chain is the motivating instance +(`exists_chainPortedFlipSet`). -/ +structure PortedFlipSet (κ : F.RelTransitionSystem) + (S : Finset W.Flag) (p₁ p₂ : W.Flag) (i₁ i₂ : α) : Prop where + int_of_mem : ∀ f ∈ S, f ∈ F.internalFlags + match_mem : ∀ f ∈ S, κ.match_ f ∈ S + pairing_mem : ∀ f ∈ S, f ≠ p₁ → f ≠ p₂ → W.pairing f ∈ S + hp₁S : p₁ ∈ S + hp₂S : p₂ ∈ S + hp₁₂ : p₁ ≠ p₂ + hσ₁ : W.pairing p₁ = W.boundaryFlag i₁ + hσ₂ : W.pairing p₂ = W.boundaryFlag i₂ + +namespace PortedFlipSet + +/-- The two port labels are distinct. -/ +theorem hlab (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) : i₁ ≠ i₂ := by + intro he + apply h.hp₁₂ + have h1 : W.pairing (W.pairing p₁) = W.pairing (W.pairing p₂) := by + rw [h.hσ₁, h.hσ₂, he] + rwa [W.pairing_invol, W.pairing_invol] at h1 + +/-- The complement of the flip set is closed under the matching. -/ +theorem match_notMem (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + {f : W.Flag} (hf : f ∈ F.internalFlags) + (hfS : f ∉ S) : κ.match_ f ∉ S := by + intro hmem + have h2 := h.match_mem _ hmem + rw [κ.match_invol f hf] at h2 + exact hfS h2 + +/-- The edge partner of the first port is the first boundary +flag. -/ +theorem bF₁_pairing (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) : + W.pairing (W.boundaryFlag i₁) = p₁ := by + rw [← h.hσ₁, W.pairing_invol] + +/-- The edge partner of the second port is the second boundary +flag. -/ +theorem bF₂_pairing (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) : + W.pairing (W.boundaryFlag i₂) = p₂ := by + rw [← h.hσ₂, W.pairing_invol] + +/-- Boundary-attached flags are not in the flip set. -/ +theorem attach_inr_notMem (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + {f : W.Flag} {i : α} + (hat : W.attach f = Sum.inr i) : f ∉ S := by + intro hmem + obtain ⟨v, hv⟩ := F.attach_internal_of_mem (h.int_of_mem _ hmem) + rw [hv] at hat + cases hat + +/-- Boundary flags are not in the flip set. -/ +theorem boundaryFlag_notMem (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (i : α) : W.boundaryFlag i ∉ S := + h.attach_inr_notMem (W.attach_boundaryFlag i) + +/-- The complement of the flip set is closed under the pairing away +from the two boundary ends. -/ +theorem pairing_notMem (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + {f : W.Flag} (hfS : f ∉ S) + (h1 : f ≠ W.boundaryFlag i₁) (h2 : f ≠ W.boundaryFlag i₂) : + W.pairing f ∉ S := by + intro hmem + by_cases hq₁ : W.pairing f = p₁ + · refine h1 ?_ + have h3 := congrArg W.pairing hq₁ + rwa [W.pairing_invol, h.hσ₁] at h3 + by_cases hq₂ : W.pairing f = p₂ + · refine h2 ?_ + have h3 := congrArg W.pairing hq₂ + rwa [W.pairing_invol, h.hσ₂] at h3 + · have h3 := h.pairing_mem _ hmem hq₁ hq₂ + rw [W.pairing_invol] at h3 + exact hfS h3 + +/-- Internal flags are never the boundary flags of the ports. -/ +theorem int_ne_boundaryFlag {f : W.Flag} + (hf : f ∈ F.internalFlags) (i : α) : + f ≠ W.boundaryFlag i := by + intro he + obtain ⟨v, hv⟩ := F.attach_internal_of_mem hf + rw [he, W.attach_boundaryFlag] at hv + cases hv + +/-- The ports are core flags. -/ +theorem p₁_core (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) : + p₁ ∈ F.coreFlags := + F.internalFlags_subset_coreFlags (h.int_of_mem _ h.hp₁S) + +/-- The second port is a core flag. -/ +theorem p₂_core (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) : + p₂ ∈ F.coreFlags := + F.internalFlags_subset_coreFlags (h.int_of_mem _ h.hp₂S) + +/-- The port boundary flags are core flags. -/ +theorem bF₁_core (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) : + W.boundaryFlag i₁ ∈ F.coreFlags := by + have h1 := F.pairing_mem_coreFlags h.p₁_core + rwa [h.hσ₁] at h1 + +/-- The second port's boundary end is a core flag — the colour +reindexing needs a value there. -/ +theorem bF₂_core (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) : + W.boundaryFlag i₂ ∈ F.coreFlags := by + have h1 := F.pairing_mem_coreFlags h.p₂_core + rwa [h.hσ₂] at h1 + +end PortedFlipSet + +/-- **The chain-flipped orientation** of the *same* system: negate +`isOut` exactly on the flip set. The flip is legal at the two +ports because their edge partners are boundary flags, whose +orientation is unconstrained. -/ +noncomputable def RelTransitionSystem.Orientation.portFlip + (o : κ.Orientation) (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) : + κ.Orientation where + isOut f := if f ∈ S then !o.isOut f else o.isOut f + match_flip := by + intro f hf + show (if κ.match_ f ∈ S then !o.isOut (κ.match_ f) + else o.isOut (κ.match_ f)) = + !(if f ∈ S then !o.isOut f else o.isOut f) + by_cases hfS : f ∈ S + · rw [ite_eq_left (h.match_mem f hfS), ite_eq_left hfS, + o.match_flip f hf] + · rw [ite_eq_right (h.match_notMem hf hfS), ite_eq_right hfS] + exact o.match_flip f hf + pairing_flip := by + intro f hf hp + show (if W.pairing f ∈ S then !o.isOut (W.pairing f) + else o.isOut (W.pairing f)) = + !(if f ∈ S then !o.isOut f else o.isOut f) + by_cases hfS : f ∈ S + · have hfp₁ : f ≠ p₁ := by + intro he + subst he + rw [h.hσ₁] at hp + obtain ⟨v, hv⟩ := F.attach_internal_of_mem hp + rw [W.attach_boundaryFlag] at hv + cases hv + have hfp₂ : f ≠ p₂ := by + intro he + subst he + rw [h.hσ₂] at hp + obtain ⟨v, hv⟩ := F.attach_internal_of_mem hp + rw [W.attach_boundaryFlag] at hv + cases hv + rw [ite_eq_left (h.pairing_mem f hfS hfp₁ hfp₂), ite_eq_left hfS, + o.pairing_flip f hf hp] + · rw [ite_eq_right (h.pairing_notMem hfS + (PortedFlipSet.int_ne_boundaryFlag hf i₁) + (PortedFlipSet.int_ne_boundaryFlag hf i₂)), ite_eq_right hfS] + exact o.pairing_flip f hf hp + +section PortFlipEval + +variable (o : κ.Orientation) (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + +/-- On the flip set the orientation reverses. -/ +theorem portFlip_isOut_of_mem {f : W.Flag} (hf : f ∈ S) : + (o.portFlip h).isOut f = !o.isOut f := ite_eq_left hf + +/-- Off the flip set the orientation is unchanged. -/ +theorem portFlip_isOut_of_notMem {f : W.Flag} (hf : f ∉ S) : + (o.portFlip h).isOut f = o.isOut f := ite_eq_right hf + +end PortFlipEval + +end PortedFlip + +/-! ## The chain-flip value ledger -/ + +section PortFlipLedger + +variable {α : Type} {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {S : Finset W.Flag} + {p₁ p₂ : W.Flag} {i₁ i₂ : α} {k ℓ : ℕ} + +/-! ### The pairing-closed colour-flip core -/ + +/-- The flip set together with the two boundary ends: the +pairing-closed support of the colour reindexing. -/ +noncomputable def portFlipCore {W : Fragment α} (S : Finset W.Flag) + (i₁ i₂ : α) : Finset W.Flag := + insert (W.boundaryFlag i₁) (insert (W.boundaryFlag i₂) S) + +/-- Membership in the colour-flip core: the flip set plus the two +chain-end boundary flags. -/ +theorem mem_portFlipCore {f : W.Flag} : + f ∈ portFlipCore S i₁ i₂ ↔ + f = W.boundaryFlag i₁ ∨ f = W.boundaryFlag i₂ ∨ f ∈ S := by + unfold portFlipCore + rw [Finset.mem_insert, Finset.mem_insert] + +/-- The flip set sits inside its colour-flip core. -/ +theorem mem_portFlipCore_of_mem {f : W.Flag} (hf : f ∈ S) : + f ∈ portFlipCore S i₁ i₂ := + mem_portFlipCore.mpr (Or.inr (Or.inr hf)) + +namespace PortedFlipSet + +/-- The colour-flip core is fully pairing-closed. -/ +theorem flipCore_pairing (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) : + ∀ f ∈ portFlipCore S i₁ i₂, + W.pairing f ∈ portFlipCore S i₁ i₂ := by + intro f hf + rcases mem_portFlipCore.mp hf with rfl | rfl | hfS + · exact mem_portFlipCore_of_mem (h.bF₁_pairing ▸ h.hp₁S) + · exact mem_portFlipCore_of_mem (h.bF₂_pairing ▸ h.hp₂S) + · by_cases h1 : f = p₁ + · subst h1 + rw [h.hσ₁] + exact mem_portFlipCore.mpr (Or.inl rfl) + by_cases h2 : f = p₂ + · subst h2 + rw [h.hσ₂] + exact mem_portFlipCore.mpr (Or.inr (Or.inl rfl)) + · exact mem_portFlipCore_of_mem (h.pairing_mem f hfS h1 h2) + +/-- On internal flags the colour-flip core is the flip set. -/ +theorem mem_flipCore_int (_ : PortedFlipSet κ S p₁ p₂ i₁ i₂) + {g : W.Flag} (hg : g ∈ F.internalFlags) : + g ∈ portFlipCore S i₁ i₂ ↔ g ∈ S := by + rw [mem_portFlipCore] + constructor + · rintro (rfl | rfl | hgS) + · exact absurd rfl (PortedFlipSet.int_ne_boundaryFlag hg i₁) + · exact absurd rfl (PortedFlipSet.int_ne_boundaryFlag hg i₂) + · exact hgS + · exact fun hgS => Or.inr (Or.inr hgS) + +/-- On boundary flags the colour-flip core is the two end +labels. -/ +theorem mem_flipCore_boundaryFlag (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) (i : α) : + W.boundaryFlag i ∈ portFlipCore S i₁ i₂ ↔ i = i₁ ∨ i = i₂ := by + rw [mem_portFlipCore] + constructor + · rintro (he | he | hmem) + · exact Or.inl (W.boundaryFlag_injective he) + · exact Or.inr (W.boundaryFlag_injective he) + · exact absurd hmem (h.boundaryFlag_notMem i) + · rintro (rfl | rfl) + · exact Or.inl rfl + · exact Or.inr (Or.inl rfl) + +end PortedFlipSet + +/-! ### The colour reindexing -/ + +/-- The `∂`-flip of a core odd colouring on the flip set together +with the two chain-end edges. -/ +noncomputable def portColourFlip (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (φ : F.CoreOddColouring ℓ) : F.CoreOddColouring ℓ := + segFlipColouring h.flipCore_pairing φ + +/-- The reindexed colouring, unfolded: `∂`-flipped on the core, +unchanged off it. -/ +theorem portColourFlip_val (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (φ : F.CoreOddColouring ℓ) + (g : {g : W.Flag // g ∈ F.coreFlags}) : + (portColourFlip h φ).val g = + if g.val ∈ portFlipCore S i₁ i₂ then oddPartner ℓ (φ.val g) + else φ.val g := + segFlipColouring_val h.flipCore_pairing φ g + +/-- On the flip set the colour is `∂`-flipped. -/ +theorem portColourFlip_val_of_mem (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (φ : F.CoreOddColouring ℓ) + (g : {g : W.Flag // g ∈ F.coreFlags}) (hg : g.val ∈ S) : + (portColourFlip h φ).val g = oddPartner ℓ (φ.val g) := by + rw [portColourFlip_val h φ g, ite_eq_left (mem_portFlipCore_of_mem hg)] + +/-- On an internal flag off the flip set the colour is +unchanged. -/ +theorem portColourFlip_val_int_of_notMem (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (φ : F.CoreOddColouring ℓ) + (g : {g : W.Flag // g ∈ F.coreFlags}) + (hgint : g.val ∈ F.internalFlags) (hg : g.val ∉ S) : + (portColourFlip h φ).val g = φ.val g := by + rw [portColourFlip_val h φ g, + ite_eq_right (fun hc => hg ((h.mem_flipCore_int hgint).mp hc))] + +/-- At the first chain end the colour is `∂`-flipped: this is where +the reindexing meets the boundary, and why the transform relabels +the state. -/ +theorem portColourFlip_val_bF₁ (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (φ : F.CoreOddColouring ℓ) + (hcore : W.boundaryFlag i₁ ∈ F.coreFlags) : + (portColourFlip h φ).val ⟨W.boundaryFlag i₁, hcore⟩ = + oddPartner ℓ (φ.val ⟨W.boundaryFlag i₁, hcore⟩) := by + rw [portColourFlip_val h φ _, + ite_eq_left ((h.mem_flipCore_boundaryFlag i₁).mpr (Or.inl rfl))] + +/-- At the second chain end likewise. -/ +theorem portColourFlip_val_bF₂ (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (φ : F.CoreOddColouring ℓ) + (hcore : W.boundaryFlag i₂ ∈ F.coreFlags) : + (portColourFlip h φ).val ⟨W.boundaryFlag i₂, hcore⟩ = + oddPartner ℓ (φ.val ⟨W.boundaryFlag i₂, hcore⟩) := by + rw [portColourFlip_val h φ _, + ite_eq_left ((h.mem_flipCore_boundaryFlag i₂).mpr (Or.inr rfl))] + +/-- At every other boundary flag the colour is unchanged: only the +two chain-end labels move. -/ +theorem portColourFlip_val_bF_of_ne (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (φ : F.CoreOddColouring ℓ) {i : α} (hi₁ : i ≠ i₁) + (hi₂ : i ≠ i₂) (hcore : W.boundaryFlag i ∈ F.coreFlags) : + (portColourFlip h φ).val ⟨W.boundaryFlag i, hcore⟩ = + φ.val ⟨W.boundaryFlag i, hcore⟩ := by + rw [portColourFlip_val h φ _, ite_eq_right (fun hc => by + rcases (h.mem_flipCore_boundaryFlag i).mp hc with he | he + · exact hi₁ he + · exact hi₂ he)] + +/-- The colour reindexing is an involution, so it is a bijection of +the colouring sum. -/ +theorem portColourFlip_involutive (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) : + Function.Involutive (portColourFlip (ℓ := ℓ) h) := + fun φ => segFlipColouring_involutive h.flipCore_pairing φ + +/-- **The boundary-constraint exchange**: the flipped colouring +matches the original state exactly when the original colouring +matches the `∂`-relabelled state. -/ +theorem coreOddBoundaryMatch_portColourFlip (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (st : GenBoundaryState k ℓ α) (φ : F.CoreOddColouring ℓ) : + F.coreOddBoundaryMatch st (portColourFlip h φ) ↔ + F.coreOddBoundaryMatch (stateOddFlip st i₁ i₂) φ := by + unfold coreOddBoundaryMatch + constructor + · intro H i cc hst hcore + by_cases hi₁ : i = i₁ + · subst hi₁ + cases hsti : st i with + | inl a => + rw [stateOddFlip_left, hsti] at hst + cases hst + | inr c' => + have hcc : cc = oddPartner ℓ c' := by + rw [stateOddFlip_left_odd hsti] at hst + exact (Sum.inr.inj hst).symm + have hΦ := H i c' hsti hcore + rw [portColourFlip_val_bF₁ h φ hcore] at hΦ + rw [hcc, ← hΦ, oddPartner_invol] + by_cases hi₂ : i = i₂ + · subst hi₂ + cases hsti : st i with + | inl a => + rw [stateOddFlip_right, hsti] at hst + cases hst + | inr c' => + have hcc : cc = oddPartner ℓ c' := by + rw [stateOddFlip_right_odd hsti] at hst + exact (Sum.inr.inj hst).symm + have hΦ := H i c' hsti hcore + rw [portColourFlip_val_bF₂ h φ hcore] at hΦ + rw [hcc, ← hΦ, oddPartner_invol] + · have hst' : st i = Sum.inr cc := + (stateOddFlip_of_ne hi₁ hi₂).symm.trans hst + have hΦ := H i cc hst' hcore + rwa [portColourFlip_val_bF_of_ne h φ hi₁ hi₂ hcore] at hΦ + · intro H i cc hst hcore + by_cases hi₁ : i = i₁ + · subst hi₁ + have hstpar : stateOddFlip st i i₂ i = Sum.inr (oddPartner ℓ cc) := + stateOddFlip_left_odd hst + have hφ := H i (oddPartner ℓ cc) hstpar hcore + rw [portColourFlip_val_bF₁ h φ hcore, hφ, oddPartner_invol] + by_cases hi₂ : i = i₂ + · subst hi₂ + have hstpar : stateOddFlip st i₁ i i = Sum.inr (oddPartner ℓ cc) := + stateOddFlip_right_odd hst + have hφ := H i (oddPartner ℓ cc) hstpar hcore + rw [portColourFlip_val_bF₂ h φ hcore, hφ, oddPartner_invol] + · have hst' : stateOddFlip st i₁ i₂ i = Sum.inr cc := by + rw [stateOddFlip_of_ne hi₁ hi₂] + exact hst + rw [portColourFlip_val_bF_of_ne h φ hi₁ hi₂ hcore] + exact H i cc hst' hcore + +/-! ### The pairing sign as a total function -/ + +private theorem inSign_portFlip_of_mem + (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) (φ : F.CoreOddColouring ℓ) + {g : W.Flag} (hg : g ∈ S) : + inSign (portColourFlip h φ) g = -inSign φ g := by + have hcore : g ∈ F.coreFlags := + F.internalFlags_subset_coreFlags (h.int_of_mem g hg) + unfold inSign + rw [dite_eq_left hcore, dite_eq_left hcore, + portColourFlip_val_of_mem h φ ⟨g, hcore⟩ hg, + oddPartnerSign_oddPartner] + +private theorem inSign_portFlip_of_int_notMem + (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) (φ : F.CoreOddColouring ℓ) + {g : W.Flag} (hgint : g ∈ F.internalFlags) (hg : g ∉ S) : + inSign (portColourFlip h φ) g = inSign φ g := by + have hcore : g ∈ F.coreFlags := + F.internalFlags_subset_coreFlags hgint + unfold inSign + rw [dite_eq_left hcore, dite_eq_left hcore, + portColourFlip_val_int_of_notMem h φ ⟨g, hcore⟩ hgint hg] + +/-! ### Vertex-local in-sets -/ + +private noncomputable def keepP (S : Finset W.Flag) + (o₀ : κ.Orientation) (vv : W.Vertex) : Finset W.Flag := + (relInSetAt o₀ vv).filter (fun g => g ∉ S) + +private noncomputable def flipP (S : Finset W.Flag) + (o₀ : κ.Orientation) (vv : W.Vertex) : Finset W.Flag := + (relInSetAt o₀ vv).filter (fun g => g ∈ S) + +private theorem mem_keepP {o₀ : κ.Orientation} {vv : W.Vertex} + {g : W.Flag} : + g ∈ keepP S o₀ vv ↔ g ∈ relInSetAt o₀ vv ∧ g ∉ S := + Finset.mem_filter + +private theorem mem_flipP {o₀ : κ.Orientation} {vv : W.Vertex} + {g : W.Flag} : + g ∈ flipP S o₀ vv ↔ g ∈ relInSetAt o₀ vv ∧ g ∈ S := + Finset.mem_filter + +private theorem match_injOn_flipP (o₀ : κ.Orientation) + (vv : W.Vertex) : + ∀ x ∈ flipP S o₀ vv, ∀ y ∈ flipP S o₀ vv, + κ.match_ x = κ.match_ y → x = y := by + intro x hx y hy hxy + have hxint := relInSetAt_subset_internal (mem_flipP.mp hx).1 + have hyint := relInSetAt_subset_internal (mem_flipP.mp hy).1 + calc x = κ.match_ (κ.match_ x) := (κ.match_invol x hxint).symm + _ = κ.match_ (κ.match_ y) := by rw [hxy] + _ = y := κ.match_invol y hyint + +/-- The port flip on `S` splits a vertex's in-set into the kept and +the flipped part. -/ +private theorem relInSetAt_val_split_port (o₀ : κ.Orientation) + (vv : W.Vertex) : + (relInSetAt o₀ vv).val = + (keepP S o₀ vv).val + (flipP S o₀ vv).val := by + unfold keepP flipP + rw [Finset.filter_val, Finset.filter_val, add_comm] + exact (Multiset.filter_add_not (fun g => g ∈ S) + (relInSetAt o₀ vv).val).symm + +/-- A product over a vertex's in-set splits along that +partition. -/ +private theorem prod_relInSetAt_split_port {M : Type*} [CommMonoid M] + (o₀ : κ.Orientation) (vv : W.Vertex) (f : W.Flag → M) : + ∏ g ∈ relInSetAt o₀ vv, f g = + (∏ g ∈ flipP S o₀ vv, f g) * ∏ g ∈ keepP S o₀ vv, f g := by + unfold flipP keepP + exact (Finset.prod_filter_mul_prod_filter_not + (relInSetAt o₀ vv) _ f).symm + +private theorem keepP_disjoint_image + (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) (o₀ : κ.Orientation) + (vv : W.Vertex) : + Disjoint (keepP S o₀ vv) ((flipP S o₀ vv).image κ.match_) := by + rw [Finset.disjoint_left] + intro g hgk hgi + obtain ⟨f, hf, rfl⟩ := Finset.mem_image.mp hgi + exact (mem_keepP.mp hgk).2 + (h.match_mem f (mem_flipP.mp hf).2) + +/-- **The in-set identity**: the in-flags of the flipped +orientation are the kept in-flags together with the matches of the +flipped ones. -/ +private theorem inb_portFlip (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (o : κ.Orientation) (vv : W.Vertex) : + relInSetAt (o.portFlip h) vv = (keepP S o vv).disjUnion + ((flipP S o vv).image κ.match_) + (keepP_disjoint_image h o vv) := by + apply Finset.ext + intro g + rw [Finset.mem_disjUnion, mem_relInSetAt] + constructor + · rintro ⟨hgfl, hgat, hgout⟩ + have hgint : g ∈ F.internalFlags := + mem_internalFlags_of hgfl ⟨vv, hgat⟩ + by_cases hgS : g ∈ S + · right + refine Finset.mem_image.mpr + ⟨κ.match_ g, ?_, κ.match_invol g hgint⟩ + have hone : o.isOut g = true := by + rw [portFlip_isOut_of_mem o h hgS] at hgout + cases hb : o.isOut g + · rw [hb] at hgout + cases hgout + · rfl + have hmint := κ.match_mem g hgint + refine mem_flipP.mpr ⟨mem_relInSetAt.mpr + ⟨mem_flags_of_internalFlags F hmint, + κ.match_vertex g hgint vv hgat, ?_⟩, h.match_mem g hgS⟩ + rw [o.match_flip g hgint, hone] + rfl + · left + refine mem_keepP.mpr ⟨mem_relInSetAt.mpr ⟨hgfl, hgat, ?_⟩, hgS⟩ + rw [← portFlip_isOut_of_notMem o h hgS] + exact hgout + · rintro (hg | hg) + · obtain ⟨hgin, hgS⟩ := mem_keepP.mp hg + obtain ⟨h1, h2, h3⟩ := mem_relInSetAt.mp hgin + refine ⟨h1, h2, ?_⟩ + rw [portFlip_isOut_of_notMem o h hgS] + exact h3 + · obtain ⟨f, hf, rfl⟩ := Finset.mem_image.mp hg + obtain ⟨hfin, hfS⟩ := mem_flipP.mp hf + obtain ⟨h1, h2, h3⟩ := mem_relInSetAt.mp hfin + have hfint : f ∈ F.internalFlags := + mem_internalFlags_of h1 ⟨vv, h2⟩ + have hmint := κ.match_mem f hfint + refine ⟨mem_flags_of_internalFlags F hmint, + κ.match_vertex f hfint vv h2, ?_⟩ + rw [portFlip_isOut_of_mem o h (h.match_mem f hfS), + o.match_flip f hfint, h3] + rfl + +/-! ### The flip set split by vertex -/ + +open scoped Classical in +private noncomputable def diffAtP (S : Finset W.Flag) + (vv : W.Vertex) : Finset W.Flag := + S.filter (fun g => W.attach g = Sum.inl vv) + +open scoped Classical in +private theorem mem_diffAtP {vv : W.Vertex} {g : W.Flag} : + g ∈ diffAtP S vv ↔ g ∈ S ∧ W.attach g = Sum.inl vv := + Finset.mem_filter + +private theorem flipP_disjoint_image (o₀ : κ.Orientation) + (vv : W.Vertex) : + Disjoint (flipP S o₀ vv) ((flipP S o₀ vv).image κ.match_) := by + rw [Finset.disjoint_left] + intro g hgf hgi + obtain ⟨f, hf, rfl⟩ := Finset.mem_image.mp hgi + have hfint := relInSetAt_subset_internal (mem_flipP.mp hf).1 + have hffalse := (mem_relInSetAt.mp (mem_flipP.mp hf).1).2.2 + have hmtrue : o₀.isOut (κ.match_ f) = true := by + rw [o₀.match_flip f hfint, hffalse] + rfl + have hmfalse := (mem_relInSetAt.mp (mem_flipP.mp hgf).1).2.2 + rw [hmtrue] at hmfalse + cases hmfalse + +private theorem diffAtP_eq (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (o₀ : κ.Orientation) (vv : W.Vertex) : + diffAtP S vv = (flipP S o₀ vv).disjUnion + ((flipP S o₀ vv).image κ.match_) + (flipP_disjoint_image o₀ vv) := by + apply Finset.ext + intro g + rw [Finset.mem_disjUnion, mem_diffAtP] + constructor + · rintro ⟨hgS, hgat⟩ + have hgint : g ∈ F.internalFlags := h.int_of_mem g hgS + have hgfl : g ∈ F.flags := mem_flags_of_internalFlags F hgint + cases hb : o₀.isOut g + · left + exact mem_flipP.mpr ⟨mem_relInSetAt.mpr ⟨hgfl, hgat, hb⟩, hgS⟩ + · right + refine Finset.mem_image.mpr + ⟨κ.match_ g, ?_, κ.match_invol g hgint⟩ + have hmint := κ.match_mem g hgint + refine mem_flipP.mpr ⟨mem_relInSetAt.mpr + ⟨mem_flags_of_internalFlags F hmint, + κ.match_vertex g hgint vv hgat, ?_⟩, h.match_mem g hgS⟩ + rw [o₀.match_flip g hgint, hb] + rfl + · rintro (hg | hg) + · exact ⟨(mem_flipP.mp hg).2, + (mem_relInSetAt.mp (mem_flipP.mp hg).1).2.1⟩ + · obtain ⟨f, hf, rfl⟩ := Finset.mem_image.mp hg + have hfint := relInSetAt_subset_internal (mem_flipP.mp hf).1 + exact ⟨h.match_mem f (mem_flipP.mp hf).2, + κ.match_vertex f hfint vv + (mem_relInSetAt.mp (mem_flipP.mp hf).1).2.1⟩ + +private theorem S_eq_biUnion_diffAtP (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) : + S = Finset.univ.biUnion (fun vv => diffAtP S vv) := by + apply Finset.ext + intro g + rw [Finset.mem_biUnion] + constructor + · intro hg + obtain ⟨vv, hvv⟩ := + F.attach_internal_of_mem (h.int_of_mem g hg) + exact ⟨vv, Finset.mem_univ vv, mem_diffAtP.mpr ⟨hg, hvv⟩⟩ + · rintro ⟨vv, _, hvv⟩ + exact (mem_diffAtP.mp hvv).1 + +private theorem diffAtP_pairwiseDisjoint : + Set.PairwiseDisjoint (↑(Finset.univ : Finset W.Vertex)) + (fun vv => diffAtP S vv) := by + intro x _ y _ hxy + refine Finset.disjoint_left.mpr (fun g hgx hgy => hxy ?_) + have h1 := (mem_diffAtP.mp hgx).2 + have h2 := (mem_diffAtP.mp hgy).2 + rw [h1] at h2 + exact Sum.inl.inj h2 + +/-! ### The port telescoping -/ + +/-- The flip-set sign product telescopes to the two port signs. -/ +private theorem prod_inSign_ports (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (φ : F.CoreOddColouring ℓ) : + ∏ g ∈ S, inSign φ g = inSign φ p₁ * inSign φ p₂ := by + have hp₂mem : p₂ ∈ S.erase p₁ := + Finset.mem_erase.mpr ⟨Ne.symm h.hp₁₂, h.hp₂S⟩ + rw [← Finset.mul_prod_erase S _ h.hp₁S, + ← Finset.mul_prod_erase (S.erase p₁) _ hp₂mem, ← mul_assoc] + have hone : ∏ g ∈ (S.erase p₁).erase p₂, inSign φ g = 1 := by + refine Finset.prod_involution (fun g _ => W.pairing g) ?_ ?_ ?_ ?_ + · intro g hg + have hgS : g ∈ S := Finset.mem_of_mem_erase + (Finset.mem_of_mem_erase hg) + rw [inSign_pairing φ + (F.internalFlags_subset_coreFlags (h.int_of_mem g hgS))] + exact inSign_mul_self φ g + · exact fun g _ _ => W.pairing_ne g + · intro g hg + have hg₂ : g ≠ p₂ := (Finset.mem_erase.mp hg).1 + have hg₁ : g ≠ p₁ := + (Finset.mem_erase.mp (Finset.mem_of_mem_erase hg)).1 + have hgS : g ∈ S := Finset.mem_of_mem_erase + (Finset.mem_of_mem_erase hg) + have hpS : W.pairing g ∈ S := h.pairing_mem g hgS hg₁ hg₂ + refine Finset.mem_erase.mpr ⟨?_, Finset.mem_erase.mpr + ⟨?_, hpS⟩⟩ + · intro he + have h3 := congrArg W.pairing he + rw [W.pairing_invol, h.hσ₂] at h3 + exact h.boundaryFlag_notMem i₂ (h3 ▸ hgS) + · intro he + have h3 := congrArg W.pairing he + rw [W.pairing_invol, h.hσ₁] at h3 + exact h.boundaryFlag_notMem i₁ (h3 ▸ hgS) + · exact fun g _ => W.pairing_invol g + rw [hone, mul_one] + +/-- The global flipped-visit sign product is the two port signs. -/ +private theorem flip_prod_ports (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (o : κ.Orientation) (φ : F.CoreOddColouring ℓ) : + ∏ vv : W.Vertex, ∏ f ∈ flipP S o vv, + (inSign φ f * inSign φ (κ.match_ f)) = + inSign φ p₁ * inSign φ p₂ := by + have hv : ∀ vv : W.Vertex, + ∏ f ∈ flipP S o vv, + (inSign φ f * inSign φ (κ.match_ f)) = + ∏ g ∈ diffAtP S vv, inSign φ g := by + intro vv + rw [diffAtP_eq h o vv, Finset.prod_disjUnion, + Finset.prod_image (match_injOn_flipP o vv), + Finset.prod_mul_distrib] + rw [Finset.prod_congr rfl (fun vv _ => hv vv), + ← Finset.prod_biUnion diffAtP_pairwiseDisjoint, + ← S_eq_biUnion_diffAtP h] + exact prod_inSign_ports h φ + +/-! ### The per-vertex sign identity -/ + +private theorem signAt_portFlip (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (o : κ.Orientation) (φ : F.CoreOddColouring ℓ) + (vv : W.Vertex) : + F.coreOddSignAt (o.portFlip h) (portColourFlip h φ) vv = + (-1 : ℤ) ^ (flipP S o vv).card * + (∏ f ∈ flipP S o vv, + inSign φ f * inSign φ (κ.match_ f)) * + F.coreOddSignAt o φ vv := by + rw [signAt_eq_prod (o.portFlip h) _ vv, signAt_eq_prod o φ vv, + inb_portFlip h o vv, Finset.prod_disjUnion] + have hkeep : ∏ g ∈ keepP S o vv, + inSign (portColourFlip h φ) (κ.match_ g) = + ∏ g ∈ keepP S o vv, inSign φ (κ.match_ g) := by + refine Finset.prod_congr rfl (fun g hg => ?_) + have hgint := relInSetAt_subset_internal (mem_keepP.mp hg).1 + exact inSign_portFlip_of_int_notMem h φ + (κ.match_mem g hgint) + (h.match_notMem hgint (mem_keepP.mp hg).2) + have himg : ∏ g ∈ (flipP S o vv).image κ.match_, + inSign (portColourFlip h φ) (κ.match_ g) = + ∏ f ∈ flipP S o vv, -inSign φ f := by + rw [Finset.prod_image (match_injOn_flipP o vv)] + refine Finset.prod_congr rfl (fun f hf => ?_) + have hfint := relInSetAt_subset_internal (mem_flipP.mp hf).1 + rw [κ.match_invol f hfint] + exact inSign_portFlip_of_mem h φ (mem_flipP.mp hf).2 + rw [hkeep, himg, + prod_relInSetAt_split_port (S := S) o vv (fun g => inSign φ (κ.match_ g)), + Finset.prod_neg] + have hsq : ∏ f ∈ flipP S o vv, inSign φ f = + (∏ f ∈ flipP S o vv, + inSign φ f * inSign φ (κ.match_ f)) * + ∏ f ∈ flipP S o vv, inSign φ (κ.match_ f) := by + rw [← Finset.prod_mul_distrib] + refine Finset.prod_congr rfl (fun f _ => ?_) + rw [mul_assoc, inSign_mul_self, mul_one] + rw [hsq] + ring + +/-! ### The per-vertex list identity -/ + +private theorem evalList_portFlip + (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) (hM : MixedFunctional k ℓ) + (μ : Multiset (Fin k)) (o : κ.Orientation) + (φ : F.CoreOddColouring ℓ) (vv : W.Vertex) : + hM.evalOdd μ + (F.coreOddListAt (o.portFlip h) (portColourFlip h φ) vv) = + (-1 : ℂ) ^ (flipP S o vv).card * + hM.evalOdd μ (F.coreOddListAt o φ vv) := by + have Hk : ∀ g ∈ (keepP S o vv).toList, g ∈ F.internalFlags := + fun g hg => relInSetAt_subset_internal + (mem_keepP.mp (Finset.mem_toList.mp hg)).1 + have Hf : ∀ g ∈ (flipP S o vv).toList, g ∈ F.internalFlags := + fun g hg => relInSetAt_subset_internal + (mem_flipP.mp (Finset.mem_toList.mp hg)).1 + have H2 : ∀ g ∈ (keepP S o vv).toList ++ + (flipP S o vv).toList.map κ.match_, g ∈ F.internalFlags := by + intro g hg + rcases List.mem_append.mp hg with hg | hg + · exact Hk g hg + · obtain ⟨f, hf, rfl⟩ := List.mem_map.mp hg + exact κ.match_mem f (Hf f hf) + have H3 : ∀ g ∈ (keepP S o vv).toList ++ (flipP S o vv).toList, + g ∈ F.internalFlags := by + intro g hg + rcases List.mem_append.mp hg with hg | hg + · exact Hk g hg + · exact Hf g hg + -- ═══════ BOTH IN-FLAG ENUMERATIONS, SPLIT BY THE PORT FLIP ═══════ + -- The unported in-flags are common to the two orientations; the + -- ported ones appear under the flipped one through the matching. + have hbase : (F.relInFlagsAt o vv).Perm + ((keepP S o vv).toList ++ (flipP S o vv).toList) := by + rw [← Multiset.coe_eq_coe, relInFlagsAt_coe o vv, + ← Multiset.coe_add, Finset.coe_toList, Finset.coe_toList] + exact relInSetAt_val_split_port o vv + have hbase' : (F.relInFlagsAt (o.portFlip h) vv).Perm + ((keepP S o vv).toList ++ + (flipP S o vv).toList.map κ.match_) := by + rw [← Multiset.coe_eq_coe, relInFlagsAt_coe (o.portFlip h) vv, + ← Multiset.coe_add, Finset.coe_toList, ← Multiset.map_coe, + Finset.coe_toList] + rw [inb_portFlip h o vv, Finset.disjUnion_val, + Finset.image_val_of_injOn (fun x hx y hy => + match_injOn_flipP o vv x (Finset.mem_coe.mp hx) y + (Finset.mem_coe.mp hy))] + unfold EdgeSubset.coreOddListAt + simp only [List.attachWith] + calc hM.evalOdd μ ((List.pmap Subtype.mk + (F.relInFlagsAt (o.portFlip h) vv) + (fun _ hf => F.mem_internal_of_mem_relInFlagsAt hf)).flatMap + (F.coreOddPairFn κ (portColourFlip h φ))) + = hM.evalOdd μ ((List.pmap Subtype.mk + ((keepP S o vv).toList ++ + (flipP S o vv).toList.map κ.match_) H2).flatMap + (F.coreOddPairFn κ (portColourFlip h φ))) := by + have hp := hM.evalOdd_flatMap_perm μ + (F.coreOddPairFn κ (portColourFlip h φ)) + (fun _ => rfl) + (perm_pmap Subtype.mk hbase' + (fun _ hf => F.mem_internal_of_mem_relInFlagsAt hf) H2) + [] + simpa using hp + _ = hM.evalOdd μ + ((List.pmap Subtype.mk (keepP S o vv).toList Hk).flatMap + (F.coreOddPairFn κ φ) ++ + (List.pmap Subtype.mk (flipP S o vv).toList Hf).flatMap + (fun fs => [pairB (κ₀ := κ) φ fs, pairA φ fs])) := by + rw [List.pmap_append, List.flatMap_append] + refine congrArg (hM.evalOdd μ) (congrArg₂ + (fun x y : List (Fin (2 * ℓ)) => x ++ y) ?_ ?_) + · refine pmap_flatMap_congr _ _ _ _ _ _ _ ?_ + intro g hg h₁ h₂ + have hgS : g ∉ S := + (mem_keepP.mp (Finset.mem_toList.mp hg)).2 + have hmS : κ.match_ g ∉ S := h.match_notMem h₁ hgS + change [(portColourFlip h φ).val + ⟨g, F.internalFlags_subset_coreFlags h₁⟩, + oddPartner ℓ ((portColourFlip h φ).val + ⟨κ.match_ g, F.internalFlags_subset_coreFlags + (κ.match_mem _ h₁)⟩)] = + [φ.val ⟨g, F.internalFlags_subset_coreFlags h₂⟩, + oddPartner ℓ (φ.val ⟨κ.match_ g, + F.internalFlags_subset_coreFlags + (κ.match_mem _ h₂)⟩)] + rw [portColourFlip_val_int_of_notMem h φ _ h₁ hgS, + portColourFlip_val_int_of_notMem h φ _ + (κ.match_mem _ h₁) hmS] + · rw [List.pmap_map] + refine pmap_flatMap_congr _ _ _ _ _ _ _ ?_ + intro f hf h₁ h₂ + have hfS : f ∈ S := + (mem_flipP.mp (Finset.mem_toList.mp hf)).2 + have hmS : κ.match_ f ∈ S := h.match_mem f hfS + have hsub : (⟨κ.match_ (κ.match_ f), + F.internalFlags_subset_coreFlags + (κ.match_mem _ h₁)⟩ : + {g : W.Flag // g ∈ F.coreFlags}) = + ⟨f, F.internalFlags_subset_coreFlags h₂⟩ := + Subtype.ext (κ.match_invol f h₂) + change [(portColourFlip h φ).val + ⟨κ.match_ f, F.internalFlags_subset_coreFlags h₁⟩, + oddPartner ℓ ((portColourFlip h φ).val + ⟨κ.match_ (κ.match_ f), + F.internalFlags_subset_coreFlags + (κ.match_mem _ h₁)⟩)] = + [pairB (κ₀ := κ) φ ⟨f, h₂⟩, pairA φ ⟨f, h₂⟩] + rw [hsub, + portColourFlip_val_of_mem h φ _ hmS, + portColourFlip_val_of_mem h φ _ hfS, + oddPartner_invol] + rfl + _ = (-1 : ℂ) ^ (flipP S o vv).card * hM.evalOdd μ + ((List.pmap Subtype.mk (keepP S o vv).toList Hk).flatMap + (F.coreOddPairFn κ φ) ++ + (List.pmap Subtype.mk (flipP S o vv).toList Hf).flatMap + (fun fs => [pairA φ fs, pairB (κ₀ := κ) φ fs])) := by + have hrev := evalOdd_flatMap_rev hM μ (pairA φ) + (pairB (κ₀ := κ) φ) + (List.pmap Subtype.mk (flipP S o vv).toList Hf) + ((List.pmap Subtype.mk (keepP S o vv).toList Hk).flatMap + (F.coreOddPairFn κ φ)) + rw [hrev, List.length_pmap, Finset.length_toList] + _ = (-1 : ℂ) ^ (flipP S o vv).card * hM.evalOdd μ + ((List.pmap Subtype.mk + ((keepP S o vv).toList ++ (flipP S o vv).toList) + H3).flatMap (F.coreOddPairFn κ φ)) := by + rw [List.pmap_append, List.flatMap_append] + rw [coreOddPairFn_eq' (κ₀ := κ) φ] + _ = (-1 : ℂ) ^ (flipP S o vv).card * hM.evalOdd μ + ((List.pmap Subtype.mk (F.relInFlagsAt o vv) + (fun _ hf => + F.mem_internal_of_mem_relInFlagsAt hf)).flatMap + (F.coreOddPairFn κ φ)) := by + have hp := hM.evalOdd_flatMap_perm μ (F.coreOddPairFn κ φ) + (fun _ => rfl) + (perm_pmap Subtype.mk hbase.symm H3 + (fun _ hf => F.mem_internal_of_mem_relInFlagsAt hf)) + [] + simp only [List.nil_append] at hp + rw [hp] + +/-! ### The vertex product and the colouring sum -/ + +private theorem vertexProd_portFlip + (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) (hM : MixedFunctional k ℓ) + (o : κ.Orientation) (φ : F.CoreOddColouring ℓ) + (μf : W.Vertex → Multiset (Fin k)) : + ∏ vv : W.Vertex, + ((F.coreOddSignAt (o.portFlip h) (portColourFlip h φ) + vv : ℂ) * + hM.evalOdd (μf vv) + (F.coreOddListAt (o.portFlip h) (portColourFlip h φ) + vv)) = + ((inSign φ p₁ * inSign φ p₂ : ℤ) : ℂ) * + ∏ vv : W.Vertex, + ((F.coreOddSignAt o φ vv : ℂ) * + hM.evalOdd (μf vv) (F.coreOddListAt o φ vv)) := by + have hglobal : ∏ vv : W.Vertex, ∏ f ∈ flipP S o vv, + ((inSign φ f : ℂ) * (inSign φ (κ.match_ f) : ℂ)) = + ((inSign φ p₁ * inSign φ p₂ : ℤ) : ℂ) := by + have h1 := flip_prod_ports h o φ + have h2 : ((∏ vv : W.Vertex, ∏ f ∈ flipP S o vv, + (inSign φ f * inSign φ (κ.match_ f)) : ℤ) : ℂ) = + ((inSign φ p₁ * inSign φ p₂ : ℤ) : ℂ) := by + rw [h1] + push_cast at h2 ⊢ + exact h2 + have hv : ∀ vv : W.Vertex, + ((F.coreOddSignAt (o.portFlip h) (portColourFlip h φ) + vv : ℂ) * + hM.evalOdd (μf vv) + (F.coreOddListAt (o.portFlip h) (portColourFlip h φ) + vv)) = + (∏ f ∈ flipP S o vv, + ((inSign φ f : ℂ) * (inSign φ (κ.match_ f) : ℂ))) * + ((F.coreOddSignAt o φ vv : ℂ) * + hM.evalOdd (μf vv) (F.coreOddListAt o φ vv)) := by + intro vv + rw [signAt_portFlip h o φ vv, + evalList_portFlip h hM (μf vv) o φ vv] + have hsq : (-1 : ℂ) ^ (flipP S o vv).card * + (-1 : ℂ) ^ (flipP S o vv).card = 1 := by + rw [← mul_pow] + norm_num + push_cast + calc ((-1 : ℂ) ^ (flipP S o vv).card * + (∏ f ∈ flipP S o vv, + ((inSign φ f : ℂ) * (inSign φ (κ.match_ f) : ℂ))) * + (F.coreOddSignAt o φ vv : ℂ)) * + ((-1 : ℂ) ^ (flipP S o vv).card * + hM.evalOdd (μf vv) (F.coreOddListAt o φ vv)) = + ((-1 : ℂ) ^ (flipP S o vv).card * + (-1 : ℂ) ^ (flipP S o vv).card) * + ((∏ f ∈ flipP S o vv, + ((inSign φ f : ℂ) * (inSign φ (κ.match_ f) : ℂ))) * + ((F.coreOddSignAt o φ vv : ℂ) * + hM.evalOdd (μf vv) (F.coreOddListAt o φ vv))) := by + ring + _ = (∏ f ∈ flipP S o vv, + ((inSign φ f : ℂ) * (inSign φ (κ.match_ f) : ℂ))) * + ((F.coreOddSignAt o φ vv : ℂ) * + hM.evalOdd (μf vv) (F.coreOddListAt o φ vv)) := by + rw [hsq, one_mul] + rw [Finset.prod_congr rfl (fun vv _ => hv vv), + Finset.prod_mul_distrib, hglobal] + +/-! ### Pinning the port signs by the boundary constraint -/ + +private theorem inSign_pin₁ (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + {st : GenBoundaryState k ℓ α} {φ : F.CoreOddColouring ℓ} + (hO : F.coreOddBoundaryMatch (stateOddFlip st i₁ i₂) φ) + {c₁ : Fin (2 * ℓ)} (hc₁ : st i₁ = Sum.inr c₁) : + inSign φ p₁ = oddPartnerSign ℓ (oddPartner ℓ c₁) := by + have hstpar : stateOddFlip st i₁ i₂ i₁ = Sum.inr (oddPartner ℓ c₁) := + stateOddFlip_left_odd hc₁ + have hval : φ.val ⟨W.boundaryFlag i₁, h.bF₁_core⟩ = + oddPartner ℓ c₁ := + hO i₁ (oddPartner ℓ c₁) hstpar h.bF₁_core + have h1 : φ.val ⟨p₁, h.p₁_core⟩ = + φ.val ⟨W.pairing (W.boundaryFlag i₁), + F.pairing_mem_coreFlags h.bF₁_core⟩ := + congrArg φ.val (Subtype.ext h.bF₁_pairing.symm) + have h2 : φ.val ⟨W.pairing (W.boundaryFlag i₁), + F.pairing_mem_coreFlags h.bF₁_core⟩ = + φ.val ⟨W.boundaryFlag i₁, h.bF₁_core⟩ := + φ.prop ⟨W.boundaryFlag i₁, h.bF₁_core⟩ + have h3 : inSign φ p₁ = + oddPartnerSign ℓ (φ.val ⟨p₁, h.p₁_core⟩) := dite_eq_left h.p₁_core + rw [h3, h1, h2, hval] + +private theorem inSign_pin₂ (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + {st : GenBoundaryState k ℓ α} {φ : F.CoreOddColouring ℓ} + (hO : F.coreOddBoundaryMatch (stateOddFlip st i₁ i₂) φ) + {c₂ : Fin (2 * ℓ)} (hc₂ : st i₂ = Sum.inr c₂) : + inSign φ p₂ = oddPartnerSign ℓ (oddPartner ℓ c₂) := by + have hstpar : stateOddFlip st i₁ i₂ i₂ = Sum.inr (oddPartner ℓ c₂) := + stateOddFlip_right_odd hc₂ + have hval : φ.val ⟨W.boundaryFlag i₂, h.bF₂_core⟩ = + oddPartner ℓ c₂ := + hO i₂ (oddPartner ℓ c₂) hstpar h.bF₂_core + have h1 : φ.val ⟨p₂, h.p₂_core⟩ = + φ.val ⟨W.pairing (W.boundaryFlag i₂), + F.pairing_mem_coreFlags h.bF₂_core⟩ := + congrArg φ.val (Subtype.ext h.bF₂_pairing.symm) + have h2 : φ.val ⟨W.pairing (W.boundaryFlag i₂), + F.pairing_mem_coreFlags h.bF₂_core⟩ = + φ.val ⟨W.boundaryFlag i₂, h.bF₂_core⟩ := + φ.prop ⟨W.boundaryFlag i₂, h.bF₂_core⟩ + have h3 : inSign φ p₂ = + oddPartnerSign ℓ (φ.val ⟨p₂, h.p₂_core⟩) := dite_eq_left h.p₂_core + rw [h3, h1, h2, hval] + +/-! ### The colouring-sum and even-sum identities -/ + +open scoped Classical in +private theorem phiSum_portFlip (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (hM : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + {c₁ c₂ : Fin (2 * ℓ)} (hc₁ : st i₁ = Sum.inr c₁) + (hc₂ : st i₂ = Sum.inr c₂) (o : κ.Orientation) + (μf : W.Vertex → Multiset (Fin k)) : + ∑ φ : F.CoreOddColouring ℓ, + (if F.coreOddBoundaryMatch st φ then + ∏ vv : W.Vertex, + ((F.coreOddSignAt (o.portFlip h) φ vv : ℂ) * + hM.evalOdd (μf vv) + (F.coreOddListAt (o.portFlip h) φ vv)) + else 0) = + ((oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂ : ℤ) : ℂ) * + ∑ φ : F.CoreOddColouring ℓ, + (if F.coreOddBoundaryMatch (stateOddFlip st i₁ i₂) φ then + ∏ vv : W.Vertex, + ((F.coreOddSignAt o φ vv : ℂ) * + hM.evalOdd (μf vv) (F.coreOddListAt o φ vv)) + else 0) := by + rw [Finset.mul_sum] + refine ((Equiv.sum_comp (Function.Involutive.toPerm _ + (portColourFlip_involutive h)) _).symm).trans + (Finset.sum_congr rfl (fun φ _ => ?_)) + change (if F.coreOddBoundaryMatch st (portColourFlip h φ) then + ∏ vv : W.Vertex, + ((F.coreOddSignAt (o.portFlip h) (portColourFlip h φ) + vv : ℂ) * + hM.evalOdd (μf vv) + (F.coreOddListAt (o.portFlip h) (portColourFlip h φ) + vv)) + else 0) = + ((oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂ : ℤ) : ℂ) * + (if F.coreOddBoundaryMatch (stateOddFlip st i₁ i₂) φ then + ∏ vv : W.Vertex, + ((F.coreOddSignAt o φ vv : ℂ) * + hM.evalOdd (μf vv) (F.coreOddListAt o φ vv)) + else 0) + rcases Classical.em + (F.coreOddBoundaryMatch (stateOddFlip st i₁ i₂) φ) with + hO | hO + · rw [ite_eq_left ((coreOddBoundaryMatch_portColourFlip h st φ).mpr + hO), + ite_eq_left hO, vertexProd_portFlip h hM o φ μf, + inSign_pin₁ h hO hc₁, inSign_pin₂ h hO hc₂, + oddPartnerSign_oddPartner, oddPartnerSign_oddPartner] + push_cast + ring + · rw [ite_eq_right (fun hc => + hO ((coreOddBoundaryMatch_portColourFlip h st φ).mp hc)), + ite_eq_right hO, mul_zero] + +private theorem evenMatch_stateOddFlip {st : GenBoundaryState k ℓ α} + (hbnd : genBoundarySubsetMatches W F.flags st) + (ψ : F.EvenColouring k) : + genEvenBoundaryMatch F (stateOddFlip st i₁ i₂) + (genBoundarySubsetMatches_stateOddFlip hbnd i₁ i₂) ψ ↔ + genEvenBoundaryMatch F st hbnd ψ := by + unfold genEvenBoundaryMatch + constructor + · intro H i c hst + exact H i c ((stateOddFlip_isInl i c).mpr hst) + · intro H i c hst + exact H i c ((stateOddFlip_isInl i c).mp hst) + +/-! ### The through product is untouched -/ + +private noncomputable def tBody [LinearOrder α] + (st : GenBoundaryState k ℓ α) (f : W.Flag) : ℂ := + match W.attach f, W.attach (W.pairing f) with + | Sum.inr i, Sum.inr j => + if i < j then throughStateFactor (st i) (st j) else 1 + | _, _ => 1 + +private theorem throughProduct_eq_body [LinearOrder α] + (st : GenBoundaryState k ℓ α) : + F.throughProduct st = ∏ f ∈ F.throughFlags, tBody st f := by + unfold EdgeSubset.throughProduct + exact Finset.prod_attach _ (tBody st) + +open scoped Classical in +private theorem tBody_stateOddFlip [LinearOrder α] + (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (st : GenBoundaryState k ℓ α) {f : W.Flag} + (hf : f ∈ F.throughFlags) : + tBody (stateOddFlip st i₁ i₂) f = tBody st f := by + obtain ⟨hfl, ⟨i, hi⟩, ⟨j, hj⟩⟩ := Finset.mem_filter.mp hf + have hi' : i ≠ i₁ ∧ i ≠ i₂ := by + have hfb : f = W.boundaryFlag i := W.eq_boundaryFlag i f hi + constructor + · intro he + have hp : W.pairing f = p₁ := by + rw [hfb, he] + exact h.bF₁_pairing + have hint : W.pairing f ∈ F.internalFlags := by + rw [hp] + exact h.int_of_mem p₁ h.hp₁S + obtain ⟨v, hv⟩ := F.attach_internal_of_mem hint + rw [hv] at hj + cases hj + · intro he + have hp : W.pairing f = p₂ := by + rw [hfb, he] + exact h.bF₂_pairing + have hint : W.pairing f ∈ F.internalFlags := by + rw [hp] + exact h.int_of_mem p₂ h.hp₂S + obtain ⟨v, hv⟩ := F.attach_internal_of_mem hint + rw [hv] at hj + cases hj + have hj' : j ≠ i₁ ∧ j ≠ i₂ := by + have hfb : W.pairing f = W.boundaryFlag j := + W.eq_boundaryFlag j _ hj + constructor + · intro he + have hp : f = p₁ := by + have h1 := congrArg W.pairing hfb + rw [W.pairing_invol, he, h.bF₁_pairing] at h1 + exact h1 + have hint : f ∈ F.internalFlags := by + rw [hp] + exact h.int_of_mem p₁ h.hp₁S + obtain ⟨v, hv⟩ := F.attach_internal_of_mem hint + rw [hv] at hi + cases hi + · intro he + have hp : f = p₂ := by + have h1 := congrArg W.pairing hfb + rw [W.pairing_invol, he, h.bF₂_pairing] at h1 + exact h1 + have hint : f ∈ F.internalFlags := by + rw [hp] + exact h.int_of_mem p₂ h.hp₂S + obtain ⟨v, hv⟩ := F.attach_internal_of_mem hint + rw [hv] at hi + cases hi + unfold tBody + rw [hi, hj] + change (if i < j then + throughStateFactor (stateOddFlip st i₁ i₂ i) + (stateOddFlip st i₁ i₂ j) else 1) = + (if i < j then throughStateFactor (st i) (st j) else 1) + rw [stateOddFlip_of_ne hi'.1 hi'.2, + stateOddFlip_of_ne hj'.1 hj'.2] + +private theorem throughProduct_stateOddFlip [LinearOrder α] + (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (st : GenBoundaryState k ℓ α) : + F.throughProduct (stateOddFlip st i₁ i₂) = + F.throughProduct st := by + rw [throughProduct_eq_body (stateOddFlip st i₁ i₂), + throughProduct_eq_body st] + exact Finset.prod_congr rfl + (fun f hf => tBody_stateOddFlip h st hf) + +/-! ### The chain-flip ledger -/ + +open scoped Classical in +/-- **The chain-flip ledger at the colouring sum**: flipping the +orientation of a ported chain multiplies the sum over colourings by +the two chain-end colour signs and flips the state there. This is +the vertex-sum form of the ledger; the through-edge product is +untouched, so the constrained summand's form follows. -/ +theorem psiSum_portFlip + (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {c₁ c₂ : Fin (2 * ℓ)} (hc₁ : st i₁ = Sum.inr c₁) + (hc₂ : st i₂ = Sum.inr c₂) (o : κ.Orientation) : + ∑ ψ : F.EvenColouring k, + (if genEvenBoundaryMatch F st hbnd ψ then + ∑ φ : F.CoreOddColouring ℓ, + (if F.coreOddBoundaryMatch st φ then + ∏ vv : W.Vertex, + ((F.coreOddSignAt (o.portFlip h) φ vv : ℂ) * + hM.evalOdd (F.evenColoursAt ψ vv) + (F.coreOddListAt (o.portFlip h) φ vv)) + else 0) + else 0) = + ((oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂ : ℤ) : ℂ) * + ∑ ψ : F.EvenColouring k, + (if genEvenBoundaryMatch F (stateOddFlip st i₁ i₂) + (genBoundarySubsetMatches_stateOddFlip hbnd i₁ i₂) + ψ then + ∑ φ : F.CoreOddColouring ℓ, + (if F.coreOddBoundaryMatch (stateOddFlip st i₁ i₂) + φ then + ∏ vv : W.Vertex, + ((F.coreOddSignAt o φ vv : ℂ) * + hM.evalOdd (F.evenColoursAt ψ vv) + (F.coreOddListAt o φ vv)) + else 0) + else 0) := by + rw [Finset.mul_sum] + refine Finset.sum_congr rfl (fun ψ _ => ?_) + rcases Classical.em (genEvenBoundaryMatch F st hbnd ψ) with + hE | hE + · rw [ite_eq_left hE, ite_eq_left ((evenMatch_stateOddFlip hbnd ψ).mpr hE)] + exact phiSum_portFlip h hM st hc₁ hc₂ o (F.evenColoursAt ψ) + · rw [ite_eq_right hE, + ite_eq_right (fun hc => hE ((evenMatch_stateOddFlip hbnd ψ).mp hc)), + mul_zero] + +/-- **The chain-flip ledger**: flipping the orientation of a ported +flip set (a full boundary chain) multiplies the constrained summand +by the two chain-end colour signs *and `∂`-relabels the state at +the two end labels* — the local system acts on states. Valid at +every circuit exponent. -/ +theorem throughSummand_portFlip [LinearOrder α] + (hM : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + (o : κ.Orientation) (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + {c₁ c₂ : Fin (2 * ℓ)} (hc₁ : st i₁ = Sum.inr c₁) + (hc₂ : st i₂ = Sum.inr c₂) (n : ℕ) : + F.throughSummand hM st hbnd (o.portFlip h) n = + ((oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂ : ℤ) : ℂ) * + F.throughSummand hM (stateOddFlip st i₁ i₂) + (genBoundarySubsetMatches_stateOddFlip hbnd i₁ i₂) o n := by + unfold EdgeSubset.throughSummand + rw [psiSum_portFlip h hM st hbnd hc₁ hc₂ o, + throughProduct_stateOddFlip h st] + ring + +end PortFlipLedger + +/-! ## The boundary chain as a ported flip set -/ + +section ChainConstruction + +variable {α : Type} + +/-- **The chain flip set**: the internal flags of a full +boundary-terminated chain form a ported flip set whose ports are +the two chain-end entry flags and whose labels are the chain's two +boundary labels. -/ +theorem exists_chainPortedFlipSet {W : Fragment α} {F : EdgeSubset W} + (κ : F.RelTransitionSystem) + {β : W.Flag} (hβ : β ∈ F.boundaryFlags) {kc : ℕ} + (hcont : ∀ j, j < kc → + W.pairing (iterWalk κ β j) ∈ F.internalFlags) + (hterm : W.pairing (iterWalk κ β kc) ∈ F.boundaryFlags) + (hk : 1 ≤ kc) {iβ iγ : α} (hiβ : W.attach β = Sum.inr iβ) + (hiγ : W.attach (W.pairing (iterWalk κ β kc)) = Sum.inr iγ) : + ∃ S : Finset W.Flag, + PortedFlipSet κ S (W.pairing β) (iterWalk κ β kc) iβ iγ ∧ + (∀ f ∈ S, OnBoundaryChain κ β f) ∧ + (∀ f ∈ F.internalFlags, OnBoundaryChain κ β f → f ∈ S) := by + -- ═══════ THE PORTED FLIP SET IS THE CHAIN'S WALK IMAGE ═══════ + -- The set is the first `kc` steps of the walk from the chain's + -- entry; the obligations are that it is internal, matching-closed + -- and pairing-closed except at the two ends. + refine ⟨(Finset.range kc).image + (fun j => W.pairing (iterWalk κ β j)) ∪ + (Finset.range kc).image (fun j => iterWalk κ β (j + 1)), + ?_, ?_, ?_⟩ + case _ => + have hmemS : ∀ f : W.Flag, + f ∈ (Finset.range kc).image + (fun j => W.pairing (iterWalk κ β j)) ∪ + (Finset.range kc).image + (fun j => iterWalk κ β (j + 1)) ↔ + ∃ j, j < kc ∧ (f = W.pairing (iterWalk κ β j) ∨ + f = iterWalk κ β (j + 1)) := by + intro f + rw [Finset.mem_union, Finset.mem_image, Finset.mem_image] + constructor + · rintro (⟨j, hj, rfl⟩ | ⟨j, hj, rfl⟩) + · exact ⟨j, Finset.mem_range.mp hj, Or.inl rfl⟩ + · exact ⟨j, Finset.mem_range.mp hj, Or.inr rfl⟩ + · rintro ⟨j, hj, rfl | rfl⟩ + · exact Or.inl ⟨j, Finset.mem_range.mpr hj, rfl⟩ + · exact Or.inr ⟨j, Finset.mem_range.mpr hj, rfl⟩ + refine + { int_of_mem := ?_ + match_mem := ?_ + pairing_mem := ?_ + hp₁S := ?_ + hp₂S := ?_ + hp₁₂ := ?_ + hσ₁ := ?_ + hσ₂ := ?_ } + · intro f hf + rw [hmemS] at hf + obtain ⟨j, hj, rfl | rfl⟩ := hf + · exact hcont j hj + · exact iterWalk_mem_internal κ kc (by omega) (by omega) + hcont + · intro f hf + rw [hmemS] at hf ⊢ + obtain ⟨j, hj, rfl | rfl⟩ := hf + · exact ⟨j, hj, Or.inr (iterWalk_succ κ β j).symm⟩ + · refine ⟨j, hj, Or.inl ?_⟩ + rw [iterWalk_succ, κ.match_invol _ (hcont j hj)] + · intro f hf hne₁ hne₂ + rw [hmemS] at hf ⊢ + obtain ⟨j, hj, rfl | rfl⟩ := hf + · rcases Nat.eq_zero_or_pos j with rfl | hj1 + · exact absurd (by rw [iterWalk_zero]) hne₁ + · refine ⟨j - 1, by omega, Or.inr ?_⟩ + rw [W.pairing_invol, show j - 1 + 1 = j from by omega] + · rcases Nat.lt_or_ge (j + 1) kc with hjk | hjk + · refine ⟨j + 1, hjk, Or.inl ?_⟩ + rfl + · exfalso + have hje : j + 1 = kc := by omega + rw [hje] at hne₂ + exact hne₂ rfl + · rw [hmemS] + exact ⟨0, by omega, Or.inl (by rw [iterWalk_zero])⟩ + · rw [hmemS] + refine ⟨kc - 1, by omega, Or.inr ?_⟩ + rw [show kc - 1 + 1 = kc from by omega] + · have h1 := pairing_iterWalk_ne κ hcont (Nat.zero_le kc) + (le_refl kc) + rwa [iterWalk_zero] at h1 + · rw [W.pairing_invol] + exact W.eq_boundaryFlag iβ β hiβ + · exact W.eq_boundaryFlag iγ _ hiγ + case _ => + intro f hf + rw [Finset.mem_union, Finset.mem_image, Finset.mem_image] at hf + rcases hf with ⟨j, hj, rfl⟩ | ⟨j, hj, rfl⟩ + · exact ⟨kc, j, le_of_lt (Finset.mem_range.mp hj), hcont, + hterm, Or.inr rfl⟩ + · exact ⟨kc, j + 1, by + have := Finset.mem_range.mp hj + omega, hcont, hterm, Or.inl rfl⟩ + case _ => + intro f hfint hon + obtain ⟨k', t, htk, hcont', hterm', hft⟩ := hon + have hkk : kc = k' := + (chain_exit_unique hcont' hterm' hcont hterm).symm + subst hkk + rw [Finset.mem_union, Finset.mem_image, Finset.mem_image] + rcases hft with rfl | rfl + · rcases Nat.eq_zero_or_pos t with rfl | ht1 + · exfalso + rw [iterWalk_zero] at hfint + exact Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags hfint hβ + · refine Or.inr ⟨t - 1, Finset.mem_range.mpr (by omega), ?_⟩ + rw [show t - 1 + 1 = t from by omega] + · rcases Nat.lt_or_ge t kc with htk' | htk' + · exact Or.inl ⟨t, Finset.mem_range.mpr htk', rfl⟩ + · exfalso + have hte : t = kc := by omega + rw [hte] at hfint + exact Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags hfint hterm + +end ChainConstruction + +/-! ## The two-path non-separated transform -/ + +section NonSepTransform + +variable {α : Type} {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} {S : Finset W.Flag} + {p₁ p₂ : W.Flag} {i₁ i₂ : α} {k ℓ : ℕ} + +/-- **The two-path non-separated transform factor**: minus the +product of the `∂`-signs of the two chain-end colours of the +original state. Unlike the separated factor `−1`, it depends on +the boundary state (only through those two signs), and the +transform additionally `∂`-relabels the state at the two chain-end +labels. -/ +noncomputable def twoPathNonSepFactor (ℓ : ℕ) + (c₁ c₂ : Fin (2 * ℓ)) : ℂ := + -(((oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂ : ℤ) : ℂ)) + +/-- The factor unfolded: minus the product of the two chain-end +colours' odd-partner signs. -/ +theorem twoPathNonSepFactor_eq (ℓ : ℕ) (c₁ c₂ : Fin (2 * ℓ)) : + twoPathNonSepFactor ℓ c₁ c₂ = + -(((oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂ : ℤ) : ℂ)) := + rfl + +private theorem signProd_cast_mul_self (ℓ : ℕ) + (c₁ c₂ : Fin (2 * ℓ)) : + ((oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂ : ℤ) : ℂ) * + ((oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂ : ℤ) : ℂ) = 1 := by + have hz : (oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂) * + (oddPartnerSign ℓ c₁ * oddPartnerSign ℓ c₂) = (1 : ℤ) := by + unfold oddPartnerSign + split_ifs <;> norm_num + rw [← Int.cast_mul, hz, Int.cast_one] + +/-- The factor is an involution: the two signs are each `±1`. -/ +theorem twoPathNonSepFactor_mul_self (ℓ : ℕ) + (c₁ c₂ : Fin (2 * ℓ)) : + twoPathNonSepFactor ℓ c₁ c₂ * twoPathNonSepFactor ℓ c₁ c₂ = + 1 := by + unfold twoPathNonSepFactor + rw [neg_mul_neg] + exact signProd_cast_mul_self ℓ c₁ c₂ + +/-- The chain flip separates a non-separated square when `c` is on +the flipped chain and `a` is off it. -/ +theorem portFlip_separated (o : κ.Orientation) + (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) {a c : W.Flag} + (hsame : o.isOut c = o.isOut a) (hcS : c ∈ S) (haS : a ∉ S) : + (o.portFlip h).isOut c = !(o.portFlip h).isOut a := by + rw [portFlip_isOut_of_mem o h hcS, + portFlip_isOut_of_notMem o h haS, hsame] + +/-- **The two-path non-separated transform, fixed exponent**: with +the transported chain-flip orientation, the repaired summand at any +circuit exponent is `twoPathNonSepFactor` times the original +summand at the `∂`-relabelled state. -/ +theorem twoPathNonSep_transform_exp [LinearOrder α] + (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {a b c d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) (o : κ.Orientation) + (hsame : o.isOut c = o.isOut a) + (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (hcS : c ∈ S) (haS : a ∉ S) + {c₁ c₂ : Fin (2 * ℓ)} (hc₁ : st i₁ = Sum.inr c₁) + (hc₂ : st i₂ = Sum.inr c₂) (n : ℕ) : + F.throughSummand hM st hbnd + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip h) (portFlip_separated o h hsame hcS haS)) + n = + twoPathNonSepFactor ℓ c₁ c₂ * + F.throughSummand hM (stateOddFlip st i₁ i₂) + (genBoundarySubsetMatches_stateOddFlip hbnd i₁ i₂) o + n := by + rw [twoPath_transform_exp hM st hbnd hsq (o.portFlip h) + (portFlip_separated o h hsame hcS haS) n, + throughSummand_portFlip hM st hbnd o h hc₁ hc₂ n, + twoPathTransformFactor_eq_neg_one] + unfold twoPathNonSepFactor + ring + +/-- **The two-path non-separated transform** (parametric form): +for a non-localized square with non-separated orientation, flipping +the ported chain of `c` and transporting across the repair +transforms the constrained summand at the open circuit counts by +the explicit factor `twoPathNonSepFactor ℓ c₁ c₂ = −(sign c₁ · +sign c₂)` — **evaluated at the `∂`-relabelled state**. The state +relabel is intrinsic: the chain flip meets the boundary at the +chain's two end labels, so no state-preserving scalar form of the +move exists. -/ +theorem twoPathNonSep_transform [LinearOrder α] + (hM : MixedFunctional k ℓ) + (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {a b c d : W.Flag} {v : W.Vertex} + (hsq : RepairSquare κ a b c d v) (o : κ.Orientation) + (hsame : o.isOut c = o.isOut a) + (hnl : ¬ SquareLocalized κ a b c d) + (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) + (hcS : c ∈ S) (haS : a ∉ S) + {c₁ c₂ : Fin (2 * ℓ)} (hc₁ : st i₁ = Sum.inr c₁) + (hc₂ : st i₂ = Sum.inr c₂) : + F.throughSummand hM st hbnd + (RelTransitionSystem.Orientation.transportRepair hsq + (o.portFlip h) (portFlip_separated o h hsame hcS haS)) + ((κ.repair a b c d v hsq).openCircuitCount) = + twoPathNonSepFactor ℓ c₁ c₂ * + F.throughSummand hM (stateOddFlip st i₁ i₂) + (genBoundarySubsetMatches_stateOddFlip hbnd i₁ i₂) o + κ.openCircuitCount := by + rw [openCircuitCount_repair_of_not_localized hsq hnl] + exact twoPathNonSep_transform_exp hM st hbnd hsq o hsame h hcS + haS hc₁ hc₂ κ.openCircuitCount + +end NonSepTransform + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathStep.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathStep.lean new file mode 100644 index 0000000000..467450978b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathStep.lean @@ -0,0 +1,455 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonExistence + +/-! +# The two-path separated move + +A repair square is *non-localized* when its two re-paired edges lie +on genuinely distinct boundary chains. This file establishes the +chain geometry of such a square and the count invariance it gives: + +* `EdgeSubset.not_periodic_of_onBoundaryChain` — flags on a + boundary chain are not periodic; +* `EdgeSubset.onBoundaryChain_disjoint` — genuinely distinct + boundary chains share no flag (chain rigidity); +* `EdgeSubset.square_hit` — a chain carrying one matched edge of + the square crosses it exactly once, by a pairing argument; +* `EdgeSubset.openCircuitCount_repair_of_not_localized` — **count + invariance**: a non-localized square leaves the open circuit + count unchanged, the repaired components being still boundary + chains, so `periodicFlags` and the periodic walk permutation are + untouched. + +The transform factor the move contributes to the summand is pinned +in `TransposeLedger.lean`, on top of this count invariance. +-/ + +@[expose] public section + +namespace RS + + + +namespace EdgeSubset + +variable {α : Type} {W : Fragment α} {F : EdgeSubset W} + {κ : F.RelTransitionSystem} + +/-! ## Chain membership excludes periodicity -/ + +/-- A flag on a boundary chain is not periodic. -/ +theorem not_periodic_of_onBoundaryChain {β f : W.Flag} + (hβ : β ∈ F.boundaryFlags) (h : OnBoundaryChain κ β f) : + ¬ κ.PeriodicFlag f := by + intro hper + obtain ⟨k, t, htk, hcont, hterm, hft⟩ := h + rcases hft with rfl | rfl + · exact not_periodic_of_chain_segment κ hcont hterm htk hper + · rcases Nat.lt_or_ge t k with hlt | hge + · exact chain_arg_ne_of_periodic hβ hcont hterm hper hlt rfl + · obtain rfl : t = k := by omega + exact Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags hper.mem_internal + hterm + +/-! ## Distinct chains share no flag -/ + +/-- **Chain disjointness**: two genuinely distinct boundary chains +(the second end not among the first chain's two ends) share no +flag, on either side of an edge. -/ +theorem onBoundaryChain_disjoint {β β' f : W.Flag} + (hβ : β ∈ F.boundaryFlags) (hβ' : β' ∈ F.boundaryFlags) + (hne : β' ≠ β) (hne' : β' ≠ κ.pathMatch β hβ) + (h : OnBoundaryChain κ β f) (h' : OnBoundaryChain κ β' f) : + False := by + obtain ⟨k, t, htk, hcont, hterm, hft⟩ := h + obtain ⟨k', t', htk', hcont', hterm', hft'⟩ := h' + have hγ : κ.pathMatch β hβ = W.pairing (iterWalk κ β k) := + pathMatch_eq_of_chain κ hβ hcont hterm + have hcontγ : ∀ j, j < k → + W.pairing (iterWalk κ (W.pairing (iterWalk κ β k)) j) ∈ + F.internalFlags := + fun j hj => reverse_chain_continues κ hβ hcont j hj + -- reduce `f` on the `β'` side to a walk flag + have hf'W : iterWalk κ β' t' = f ∨ + iterWalk κ β' t' = W.pairing f := by + rcases hft' with hE | hE + · exact Or.inl hE.symm + · refine Or.inr ?_ + have := congrArg W.pairing hE + rwa [W.pairing_invol, eq_comm] at this + rcases hft with hW | hP + · -- `f` is a walk flag of `β`'s chain + rcases hf'W with hE | hE + · exact hne (chain_meet hβ hβ' hcont hcont' t' t htk' htk + (hE.trans hW)).1 + · -- `iterWalk β' t' = pairing (iterWalk β t)`: reverse chain + have h5 : iterWalk κ (W.pairing (iterWalk κ β k)) (k - t) = + W.pairing (iterWalk κ β t) := by + rw [iterWalk_reverse κ hcont (k - t) (by omega), + show k - (k - t) = t from by omega] + have h6 : iterWalk κ β' t' = + iterWalk κ (W.pairing (iterWalk κ β k)) (k - t) := by + rw [hE, hW, h5] + have h7 := (chain_meet hterm hβ' hcontγ hcont' t' (k - t) + htk' (by omega) h6).1 + exact hne' (h7.trans hγ.symm) + · -- `f` is a pairing-side flag of `β`'s chain + rcases hf'W with hE | hE + · have h5 : iterWalk κ (W.pairing (iterWalk κ β k)) (k - t) = + W.pairing (iterWalk κ β t) := by + rw [iterWalk_reverse κ hcont (k - t) (by omega), + show k - (k - t) = t from by omega] + have h6 : iterWalk κ β' t' = + iterWalk κ (W.pairing (iterWalk κ β k)) (k - t) := by + rw [hE, hP, h5] + have h7 := (chain_meet hterm hβ' hcontγ hcont' t' (k - t) + htk' (by omega) h6).1 + exact hne' (h7.trans hγ.symm) + · have h6 : iterWalk κ β' t' = iterWalk κ β t := by + rw [hE, hP, W.pairing_invol] + exact hne (chain_meet hβ hβ' hcont hcont' t' t htk' htk h6).1 + +/-! ## The square hit on a chain -/ + +/-- A chain carrying one matched edge `X ↔ Y` of the square meets it +as a pairing argument: at some step `s < k` the argument is `X` or +`Y`, and the next walk flag is the other. -/ +theorem square_hit {X Y β : W.Flag} (hβ : β ∈ F.boundaryFlags) + (hXi : X ∈ F.internalFlags) (hXY : κ.match_ X = Y) {k : ℕ} + (hcont : ∀ j, j < k → + W.pairing (iterWalk κ β j) ∈ F.internalFlags) + (hterm : W.pairing (iterWalk κ β k) ∈ F.boundaryFlags) + (hon : OnBoundaryChain κ β X) : + ∃ s, s < k ∧ + ((W.pairing (iterWalk κ β s) = X ∧ + iterWalk κ β (s + 1) = Y) ∨ + (W.pairing (iterWalk κ β s) = Y ∧ + iterWalk κ β (s + 1) = X)) := by + obtain ⟨k', t, htk, hcont', hterm', hft⟩ := hon + have hkk : k' = k := chain_exit_unique hcont' hterm' hcont hterm + rcases hft with hW | hP + · cases t with + | zero => + rw [iterWalk_zero] at hW + subst hW + exact absurd hβ (Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags hXi) + | succ t => + refine ⟨t, by omega, Or.inr ⟨?_, hW.symm⟩⟩ + have h1 : κ.match_ (W.pairing (iterWalk κ β t)) = X := by + rw [← iterWalk_succ] + exact hW.symm + have h2 : W.pairing (iterWalk κ β t) = κ.match_ X := by + rw [← h1, κ.match_invol _ (hcont t (by omega))] + rw [h2, hXY] + · have htk2 : t < k := by + rcases Nat.lt_or_ge t k with hlt | hge + · exact hlt + · obtain rfl : t = k := by omega + rw [← hP] at hterm + exact absurd hterm (Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags hXi) + refine ⟨t, htk2, Or.inl ⟨hP.symm, ?_⟩⟩ + rw [iterWalk_succ, ← hP, hXY] + +/-! ## Repaired chains through the square -/ + +section RepairChains + +variable {a b c d : W.Flag} {v : W.Vertex} + +/-- The repaired chain from `β` reaches the first square argument: +if the arguments before step `s` avoid the square, the argument at +step `s` lies on the repaired chain of `β`. -/ +theorem onBoundaryChain_repair_of_hit (hsq : RepairSquare κ a b c d v) + {β : W.Flag} (hβ : β ∈ F.boundaryFlags) {k s : ℕ} + (hcont : ∀ j, j < k → + W.pairing (iterWalk κ β j) ∈ F.internalFlags) + (hs : s < k) + (havoid : ∀ j, j < s → + W.pairing (iterWalk κ β j) ≠ a ∧ + W.pairing (iterWalk κ β j) ≠ b ∧ + W.pairing (iterWalk κ β j) ≠ c ∧ + W.pairing (iterWalk κ β j) ≠ d) : + OnBoundaryChain (κ.repair a b c d v hsq) β + (W.pairing (iterWalk κ β s)) := by + have hagree := repair_iterWalk_of_avoid hsq (k := s) havoid + obtain ⟨k', hk'le, hcont', hterm'⟩ := + chain_terminates_with_data (κ.repair a b c d v hsq) hβ + have hsk' : s < k' := by + by_contra hle + have hk's : k' ≤ s := by omega + have h1 : W.pairing (iterWalk (κ.repair a b c d v hsq) β k') = + W.pairing (iterWalk κ β k') := by + rw [hagree k' hk's] + rw [h1] at hterm' + exact Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags + (hcont k' (by omega)) hterm' + exact ⟨k', s, by omega, hcont', hterm', + Or.inr (by rw [hagree s le_rfl])⟩ + +/-- The walk-side square flag on a chain is not periodic in the +repaired system: the repaired walk from it follows the old chain +tail to the boundary. -/ +theorem not_periodic_repair_of_tail (hsq : RepairSquare κ a b c d v) + {β : W.Flag} {k s : ℕ} + (hcont : ∀ j, j < k → + W.pairing (iterWalk κ β j) ∈ F.internalFlags) + (hterm : W.pairing (iterWalk κ β k) ∈ F.boundaryFlags) + (hs : s < k) + (hav : ∀ j, s < j → j < k → + W.pairing (iterWalk κ β j) ≠ a ∧ + W.pairing (iterWalk κ β j) ≠ b ∧ + W.pairing (iterWalk κ β j) ≠ c ∧ + W.pairing (iterWalk κ β j) ≠ d) : + ¬ (κ.repair a b c d v hsq).PeriodicFlag + (iterWalk κ β (s + 1)) := by + have hYW : ∀ t, iterWalk κ (iterWalk κ β (s + 1)) t = + iterWalk κ β (s + 1 + t) := + fun t => (iterWalk_add κ β (s + 1) t).symm + have havY : ∀ t, t < k - s - 1 → + W.pairing (iterWalk κ (iterWalk κ β (s + 1)) t) ≠ a ∧ + W.pairing (iterWalk κ (iterWalk κ β (s + 1)) t) ≠ b ∧ + W.pairing (iterWalk κ (iterWalk κ β (s + 1)) t) ≠ c ∧ + W.pairing (iterWalk κ (iterWalk κ β (s + 1)) t) ≠ d := by + intro t ht + rw [hYW] + exact hav (s + 1 + t) (by omega) (by omega) + have hagree := repair_iterWalk_of_avoid hsq (k := k - s - 1) havY + apply not_periodic_of_boundary_chain (κ.repair a b c d v hsq) _ + refine ⟨(k - s - 1) + 1, + W.pairing (iterWalk (κ.repair a b c d v hsq) + (iterWalk κ β (s + 1)) (k - s - 1)), ?_⟩ + apply traceChain_forward (κ.repair a b c d v hsq) + (iterWalk κ β (s + 1)) (k := k - s - 1) + · intro t ht + rw [hagree t (by omega), hYW] + exact hcont (s + 1 + t) (by omega) + · rw [hagree (k - s - 1) le_rfl, hYW, + show s + 1 + (k - s - 1) = k from by omega] + exact hterm + +/-- One chain side of a two-chain square: its two square flags are +non-periodic in the repaired system. Stated for a matched pair +`X ↔ Y` on the chain of `β`, with the other two square flags on the +genuinely distinct chain of `βo`; `hperm` identifies the four square +flags with `{X, Y, Z₁, Z₂}`. -/ +theorem chain_side_not_periodic_repair [LinearOrder α] + (hsq : RepairSquare κ a b c d v) + {β βo X Y Z₁ Z₂ : W.Flag} + (hβ : β ∈ F.boundaryFlags) (hβo : βo ∈ F.boundaryFlags) + (hne1 : β ≠ βo) (hne2 : β ≠ κ.pathMatch βo hβo) + (hXi : X ∈ F.internalFlags) (hXY : κ.match_ X = Y) + (honX : OnBoundaryChain κ β X) + (honZ₁ : OnBoundaryChain κ βo Z₁) + (honZ₂ : OnBoundaryChain κ βo Z₂) + (hperm : ∀ g : W.Flag, + (g = a ∨ g = b ∨ g = c ∨ g = d) ↔ + (g = X ∨ g = Y ∨ g = Z₁ ∨ g = Z₂)) : + ¬ (κ.repair a b c d v hsq).PeriodicFlag X ∧ + ¬ (κ.repair a b c d v hsq).PeriodicFlag Y := by + obtain ⟨k, hkle, hcont, hterm⟩ := chain_terminates_with_data κ hβ + obtain ⟨s, hs, hhit⟩ := square_hit hβ hXi hXY hcont hterm honX + -- arguments away from step `s` avoid all four square flags + have havoid : ∀ j, j < k → j ≠ s → + W.pairing (iterWalk κ β j) ≠ a ∧ + W.pairing (iterWalk κ β j) ≠ b ∧ + W.pairing (iterWalk κ β j) ≠ c ∧ + W.pairing (iterWalk κ β j) ≠ d := by + intro j hj hjs + have hXne : W.pairing (iterWalk κ β j) ≠ X ∧ + W.pairing (iterWalk κ β j) ≠ Y := by + rcases hhit with ⟨hargX, hwalkY⟩ | ⟨hargY, hwalkX⟩ + · constructor + · intro he + exact hjs (pairing_iterWalk_injective κ hβ k hcont hj hs + (he.trans hargX.symm)) + · intro he + exact pairing_iterWalk_ne κ hcont (le_of_lt hj) + (by omega : s + 1 ≤ k) (he.trans hwalkY.symm) + · constructor + · intro he + exact pairing_iterWalk_ne κ hcont (le_of_lt hj) + (by omega : s + 1 ≤ k) (he.trans hwalkX.symm) + · intro he + exact hjs (pairing_iterWalk_injective κ hβ k hcont hj hs + (he.trans hargY.symm)) + have hZne : W.pairing (iterWalk κ β j) ≠ Z₁ ∧ + W.pairing (iterWalk κ β j) ≠ Z₂ := by + constructor + · intro he + exact onBoundaryChain_disjoint hβo hβ hne1 hne2 honZ₁ + ⟨k, j, le_of_lt hj, hcont, hterm, Or.inr he.symm⟩ + · intro he + exact onBoundaryChain_disjoint hβo hβ hne1 hne2 honZ₂ + ⟨k, j, le_of_lt hj, hcont, hterm, Or.inr he.symm⟩ + have hall : ¬ (W.pairing (iterWalk κ β j) = a ∨ + W.pairing (iterWalk κ β j) = b ∨ + W.pairing (iterWalk κ β j) = c ∨ + W.pairing (iterWalk κ β j) = d) := by + intro hor + rcases (hperm (W.pairing (iterWalk κ β j))).mp hor with + h | h | h | h + · exact hXne.1 h + · exact hXne.2 h + · exact hZne.1 h + · exact hZne.2 h + exact ⟨fun he => hall (Or.inl he), + fun he => hall (Or.inr (Or.inl he)), + fun he => hall (Or.inr (Or.inr (Or.inl he))), + fun he => hall (Or.inr (Or.inr (Or.inr he)))⟩ + have hOn : OnBoundaryChain (κ.repair a b c d v hsq) β + (W.pairing (iterWalk κ β s)) := + onBoundaryChain_repair_of_hit hsq hβ hcont hs + (fun j hj => havoid j (by omega) (by omega)) + have hTail : ¬ (κ.repair a b c d v hsq).PeriodicFlag + (iterWalk κ β (s + 1)) := + not_periodic_repair_of_tail hsq hcont hterm hs + (fun j hj1 hj2 => havoid j hj2 (by omega)) + have hArg : ¬ (κ.repair a b c d v hsq).PeriodicFlag + (W.pairing (iterWalk κ β s)) := + not_periodic_of_onBoundaryChain hβ hOn + rcases hhit with ⟨hargX, hwalkY⟩ | ⟨hargY, hwalkX⟩ + · exact ⟨hargX ▸ hArg, hwalkY ▸ hTail⟩ + · exact ⟨hwalkX ▸ hTail, hargY ▸ hArg⟩ + +/-- Periodicity transfer across a repair whose four flags are +non-periodic on both sides. -/ +theorem periodicFlag_repair_iff (hsq : RepairSquare κ a b c d v) + (hna : ¬ κ.PeriodicFlag a) (hnb : ¬ κ.PeriodicFlag b) + (hnc : ¬ κ.PeriodicFlag c) (hnd : ¬ κ.PeriodicFlag d) + (hna' : ¬ (κ.repair a b c d v hsq).PeriodicFlag a) + (hnb' : ¬ (κ.repair a b c d v hsq).PeriodicFlag b) + (hnc' : ¬ (κ.repair a b c d v hsq).PeriodicFlag c) + (hnd' : ¬ (κ.repair a b c d v hsq).PeriodicFlag d) + (f : W.Flag) : + (κ.repair a b c d v hsq).PeriodicFlag f ↔ κ.PeriodicFlag f := by + constructor + · intro hper + have hagree : ∀ j, + iterWalk (κ.repair a b c d v hsq) f j = iterWalk κ f j := by + intro j + induction j with + | zero => rfl + | succ j ih => + have harg : (κ.repair a b c d v hsq).PeriodicFlag + (W.pairing (iterWalk (κ.repair a b c d v hsq) f j)) := + periodicFlag_pairing + (periodicFlag_iterWalk (κ.repair a b c d v hsq) hper j) + rw [ih] at harg + rw [iterWalk_succ, iterWalk_succ, ih] + exact RelTransitionSystem.repair_match_of_ne hsq + (fun he => hna' (he ▸ harg)) (fun he => hnb' (he ▸ harg)) + (fun he => hnc' (he ▸ harg)) (fun he => hnd' (he ▸ harg)) + obtain ⟨hint, n, hn1, hcont, hret⟩ := hper + refine ⟨hint, n, hn1, fun j hj => ?_, ?_⟩ + · rw [← hagree j] + exact hcont j hj + · rw [← hagree n] + exact hret + · intro hper + have hagree : ∀ j, + iterWalk (κ.repair a b c d v hsq) f j = iterWalk κ f j := by + intro j + induction j with + | zero => rfl + | succ j ih => + have harg : κ.PeriodicFlag (W.pairing (iterWalk κ f j)) := + periodicFlag_pairing (periodicFlag_iterWalk κ hper j) + rw [iterWalk_succ, iterWalk_succ, ih] + exact RelTransitionSystem.repair_match_of_ne hsq + (fun he => hna (he ▸ harg)) (fun he => hnb (he ▸ harg)) + (fun he => hnc (he ▸ harg)) (fun he => hnd (he ▸ harg)) + obtain ⟨hint, n, hn1, hcont, hret⟩ := hper + refine ⟨hint, n, hn1, fun j hj => ?_, ?_⟩ + · rw [hagree j] + exact hcont j hj + · rw [hagree n] + exact hret + +/-- **Count invariance for two-chain squares**: a non-localized +square leaves the open circuit count unchanged — both repaired +components are still boundary-terminated chains, so the periodic +flags and the periodic walk permutation are untouched. -/ +theorem openCircuitCount_repair_of_not_localized [LinearOrder α] + (hsq : RepairSquare κ a b c d v) + (hnl : ¬ SquareLocalized κ a b c d) : + (κ.repair a b c d v hsq).openCircuitCount = + κ.openCircuitCount := by + obtain ⟨β₁, β₂, hβ₁, hβ₂, hca, hcc, h21, h2γ⟩ := + twoChains_of_not_localized hsq hnl + have h12 : β₁ ≠ β₂ := Ne.symm h21 + have h1γ2 : β₁ ≠ κ.pathMatch β₂ hβ₂ := by + intro he + apply h2γ + have h3 := κ.pathMatch_congr he hβ₁ (κ.pathMatch_mem hβ₂) + exact (h3.trans (κ.pathMatch_invol hβ₂)).symm + have hcb : OnBoundaryChain κ β₁ b := + hsq.hab ▸ onBoundaryChain_match hβ₁ hsq.ha hca + have hcd : OnBoundaryChain κ β₂ d := + hsq.hcd ▸ onBoundaryChain_match hβ₂ hsq.hc hcc + -- non-periodicity in `κ` + have hna : ¬ κ.PeriodicFlag a := + not_periodic_of_onBoundaryChain hβ₁ hca + have hnb : ¬ κ.PeriodicFlag b := + not_periodic_of_onBoundaryChain hβ₁ hcb + have hnc : ¬ κ.PeriodicFlag c := + not_periodic_of_onBoundaryChain hβ₂ hcc + have hnd : ¬ κ.PeriodicFlag d := + not_periodic_of_onBoundaryChain hβ₂ hcd + -- non-periodicity in the repaired system + obtain ⟨hna', hnb'⟩ := chain_side_not_periodic_repair hsq + hβ₁ hβ₂ h12 h1γ2 hsq.ha hsq.hab hca hcc hcd + (fun g => Iff.rfl) + obtain ⟨hnc', hnd'⟩ := chain_side_not_periodic_repair hsq + hβ₂ hβ₁ h21 h2γ hsq.hc hsq.hcd hcc hca hcb + (fun g => by tauto) + -- the periodic flags agree + have hset : (κ.repair a b c d v hsq).periodicFlags = + κ.periodicFlags := by + apply Finset.ext + intro f + rw [(κ.repair a b c d v hsq).mem_periodicFlags, + κ.mem_periodicFlags] + exact periodicFlag_repair_iff hsq hna hnb hnc hnd + hna' hnb' hnc' hnd' f + -- transport the walk permutation + have hperm : (κ.repair a b c d v hsq).walkPermPeriodic = + (Equiv.subtypeEquivRight (fun f => by rw [hset]) : + {f : W.Flag // f ∈ κ.periodicFlags} ≃ + {f : W.Flag // + f ∈ (κ.repair a b c d v hsq).periodicFlags}).permCongr + κ.walkPermPeriodic := by + apply Equiv.ext + rintro ⟨f, hf⟩ + apply Subtype.ext + have hfp : κ.PeriodicFlag f := by + rw [hset] at hf + exact κ.mem_periodicFlags.mp hf + have hσ : κ.PeriodicFlag (W.pairing f) := periodicFlag_pairing hfp + rw [Equiv.permCongr_apply] + simp only [Equiv.subtypeEquivRight_symm_apply, + Equiv.subtypeEquivRight_apply] + change (κ.repair a b c d v hsq).match_ (W.pairing f) = + κ.match_ (W.pairing f) + exact RelTransitionSystem.repair_match_of_ne hsq + (fun he => hna (he ▸ hσ)) (fun he => hnb (he ▸ hσ)) + (fun he => hnc (he ▸ hσ)) (fun he => hnd (he ▸ hσ)) + unfold RelTransitionSystem.openCircuitCount + rw [hperm, cycleType_permCongr, card_fixedPoints_permCongr] + +end RepairChains + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexOddSign.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexOddSign.lean new file mode 100644 index 0000000000..134f83d09f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexOddSign.lean @@ -0,0 +1,206 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Common.ListAttach +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplit + +/-! +# Vertex-local in-sets and the incoming-flag sign + +The vocabulary the orientation-change analysis is written in: at a +vertex, the participating flags attached to it and marked incoming +form a finite set, of which `EdgeSubset.relInFlagsAt` is the sorted +enumeration; each such flag carries an odd-pairing sign, and the +odd-colour pair it contributes is read off by two maps. + +Flipping the colours on a set `S` negates the sign at the flags of +`S` and leaves the others alone, which is what makes the flip +analysis a product of independent local factors. +-/ + +@[expose] public section + +namespace RS + + + +variable {α : Type} {W : Fragment α} {F : EdgeSubset W} + {k ℓ : ℕ} {S : Finset W.Flag} + +/-! ## The in-set at a vertex -/ + +open scoped Classical in +/-- The in-set at a vertex over a relative orientation: the +participating flags attached to the vertex and marked incoming. -/ +noncomputable def relInSetAt {κ₀ : F.RelTransitionSystem} + (o₀ : κ₀.Orientation) (vv : W.Vertex) : Finset W.Flag := + F.flags.filter + (fun f => W.attach f = Sum.inl vv ∧ o₀.isOut f = false) + +/-- Membership in the in-set at a vertex, unfolded. -/ +theorem mem_relInSetAt {κ₀ : F.RelTransitionSystem} + {o₀ : κ₀.Orientation} {vv : W.Vertex} {g : W.Flag} : + g ∈ relInSetAt o₀ vv ↔ + g ∈ F.flags ∧ W.attach g = Sum.inl vv ∧ + o₀.isOut g = false := by + classical + exact Finset.mem_filter + +/-- An in-flag at a vertex is an internal flag. -/ +theorem relInSetAt_subset_internal {κ₀ : F.RelTransitionSystem} + {o₀ : κ₀.Orientation} {vv : W.Vertex} {g : W.Flag} + (hg : g ∈ relInSetAt o₀ vv) : g ∈ F.internalFlags := by + obtain ⟨h1, h2, _⟩ := mem_relInSetAt.mp hg + exact EdgeSubset.mem_internalFlags_of h1 ⟨vv, h2⟩ + +/-- `EdgeSubset.relInFlagsAt` enumerates the in-set at a vertex. -/ +theorem relInFlagsAt_coe {κ₀ : F.RelTransitionSystem} + (o₀ : κ₀.Orientation) (vv : W.Vertex) : + (F.relInFlagsAt o₀ vv : Multiset W.Flag) = + (relInSetAt o₀ vv).val := by + let := W.flagOrder + let := Classical.dec + unfold EdgeSubset.relInFlagsAt + rw [Finset.sort_eq] + exact congrArg Finset.val (Finset.ext (fun g => by + rw [Finset.mem_filter, mem_relInSetAt])) + +/-! ## The odd-colour pair at an internal flag -/ + +/-- The flag's own odd colour. -/ +noncomputable def pairA (φ : F.CoreOddColouring ℓ) + (f : {f : W.Flag // f ∈ F.internalFlags}) : Fin (2 * ℓ) := + φ.val ⟨f.val, F.internalFlags_subset_coreFlags f.prop⟩ + +/-- The odd colour opposite the flag's transition partner. -/ +noncomputable def pairB {κ₀ : F.RelTransitionSystem} + (φ : F.CoreOddColouring ℓ) + (f : {f : W.Flag // f ∈ F.internalFlags}) : Fin (2 * ℓ) := + oddPartner ℓ (φ.val ⟨κ₀.match_ f.val, + F.internalFlags_subset_coreFlags (κ₀.match_mem _ f.prop)⟩) + +/-- Reversing every odd pair of a list multiplies the odd +evaluation by `(−1)` per pair. -/ +theorem evalOdd_flatMap_rev (hM : MixedFunctional k ℓ) + (μ : Multiset (Fin k)) {β : Type*} + (pa pb : β → Fin (2 * ℓ)) : + ∀ (l : List β) (pre : List (Fin (2 * ℓ))), + hM.evalOdd μ (pre ++ l.flatMap (fun f => [pb f, pa f])) = + (-1 : ℂ) ^ l.length * + hM.evalOdd μ (pre ++ l.flatMap (fun f => [pa f, pb f])) + | [], pre => by simp + | f :: t, pre => by + simp only [List.flatMap_cons, List.cons_append, List.nil_append, + List.length_cons] + by_cases hab : pa f = pb f + · have hz1 : ¬ (pre ++ pb f :: pa f :: + t.flatMap (fun f => [pb f, pa f])).Nodup := by + intro hnd + have hsub := hnd.sublist (List.sublist_append_right pre _) + simp only [List.nodup_cons, List.mem_cons] at hsub + exact hsub.1 (Or.inl hab.symm) + have hz2 : ¬ (pre ++ pa f :: pb f :: + t.flatMap (fun f => [pa f, pb f])).Nodup := by + intro hnd + have hsub := hnd.sublist (List.sublist_append_right pre _) + simp only [List.nodup_cons, List.mem_cons] at hsub + exact hsub.1 (Or.inl hab) + rw [hM.evalOdd_of_not_nodup μ hz1, + hM.evalOdd_of_not_nodup μ hz2] + ring + · rw [hM.evalOdd_swap_adjacent μ pre + (t.flatMap (fun f => [pb f, pa f])) hab] + have hstep := evalOdd_flatMap_rev hM μ pa pb t + (pre ++ [pa f, pb f]) + simp only [List.append_assoc, List.cons_append, + List.nil_append] at hstep + rw [hstep, pow_succ] + ring + +/-! ## The incoming-flag sign -/ + +/-- The odd-pairing sign an incoming flag carries, extended by one +off the core. -/ +noncomputable def inSign (φ : F.CoreOddColouring ℓ) + (g : W.Flag) : ℤ := + if hg : g ∈ F.coreFlags then oddPartnerSign ℓ (φ.val ⟨g, hg⟩) + else 1 + +/-- Flipping the colours on `S` negates the sign at a flag of `S`. -/ +theorem inSign_flip_of_mem {φ φ' : F.CoreOddColouring ℓ} + (hφ' : ∀ g, φ'.val g = + if g.val ∈ S then oddPartner ℓ (φ.val g) else φ.val g) + {g : W.Flag} (hg : g ∈ S) (hcore : g ∈ F.coreFlags) : + inSign φ' g = -inSign φ g := by + unfold inSign + rw [dite_eq_left hcore, dite_eq_left hcore, hφ' ⟨g, hcore⟩, ite_eq_left hg, + oddPartnerSign_oddPartner] + +/-- Flipping the colours on `S` leaves the sign off `S` alone. -/ +theorem inSign_flip_of_notMem {φ φ' : F.CoreOddColouring ℓ} + (hφ' : ∀ g, φ'.val g = + if g.val ∈ S then oddPartner ℓ (φ.val g) else φ.val g) + {g : W.Flag} (hg : g ∉ S) : inSign φ' g = inSign φ g := by + unfold inSign + by_cases hcore : g ∈ F.coreFlags + · rw [dite_eq_left hcore, dite_eq_left hcore, hφ' ⟨g, hcore⟩, ite_eq_right hg] + · rw [dite_eq_right hcore, dite_eq_right hcore] + +/-- The sign is a square root of one. -/ +theorem inSign_mul_self (φ : F.CoreOddColouring ℓ) + (g : W.Flag) : inSign φ g * inSign φ g = 1 := by + unfold inSign + by_cases hg : g ∈ F.coreFlags + · rw [dite_eq_left hg] + unfold oddPartnerSign + by_cases h : (φ.val ⟨g, hg⟩).val < ℓ <;> simp [h] + · rw [dite_eq_right hg] + norm_num + +/-- Paired flags carry the same sign. -/ +theorem inSign_pairing (φ : F.CoreOddColouring ℓ) + {g : W.Flag} (hg : g ∈ F.coreFlags) : + inSign φ (W.pairing g) = inSign φ g := by + unfold inSign + rw [dite_eq_left (F.pairing_mem_coreFlags hg), dite_eq_left hg] + exact congrArg (oddPartnerSign ℓ) (φ.prop ⟨g, hg⟩) + +/-! ## The core odd data in this vocabulary -/ + +/-- The odd pair an internal flag contributes, in terms of the two +pair maps. -/ +theorem coreOddPairFn_eq' {κ₀ : F.RelTransitionSystem} + (φ : F.CoreOddColouring ℓ) : + F.coreOddPairFn κ₀ φ = + fun f => [pairA φ f, pairB (κ₀ := κ₀) φ f] := rfl + +/-- The sign an internal flag contributes is the incoming sign at +its transition partner. -/ +theorem signFn_eq {κ₀ : F.RelTransitionSystem} + (φ : F.CoreOddColouring ℓ) + (f : {f : W.Flag // f ∈ F.internalFlags}) : + F.coreOddSignFn κ₀ φ f = inSign φ (κ₀.match_ f.val) := by + unfold EdgeSubset.coreOddSignFn inSign + rw [dite_eq_left + (F.internalFlags_subset_coreFlags (κ₀.match_mem _ f.prop))] + +/-- The odd-pairing sign at a vertex is the product of the incoming +signs over the in-set. -/ +theorem signAt_eq_prod {κ₀ : F.RelTransitionSystem} + (o₀ : κ₀.Orientation) (φ : F.CoreOddColouring ℓ) + (vv : W.Vertex) : + F.coreOddSignAt o₀ φ vv = + ∏ g ∈ relInSetAt o₀ vv, inSign φ (κ₀.match_ g) := by + unfold EdgeSubset.coreOddSignAt + rw [attachWith_map_eq (F.coreOddSignFn κ₀ φ) + (fun g => inSign φ (κ₀.match_ g)) + (fun g hg => signFn_eq φ ⟨g, hg⟩) (F.relInFlagsAt o₀ vv) _] + exact list_map_prod_eq_finset_prod (relInSetAt o₀ vv) _ + (relInFlagsAt_coe o₀ vv) _ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexSum.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexSum.lean new file mode 100644 index 0000000000..591cbea980 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexSum.lean @@ -0,0 +1,71 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue + +/-! +# The vertex sum + +RS21's tensor is built from a sum over colourings extending the +boundary data of a product of the functional's vertex values: + + Σ_{ψ ∼ χ₀, φ ∼ χ₁} ∏_{v ∈ V′(F)} h_v( … ). + +That sum is named here, and the mixed partition function's own +summand is shown to be it, times the circuit sign and the +through-edge product. Naming it separates the part of the summand +that is RS21's from the part the flag model adds — the through-edge +product, which the graph model instead carries inside the boundary +vectors. +-/ + +@[expose] public section + +namespace RS + +namespace EdgeSubset + + + +variable {α : Type} + +open scoped Classical in +/-- **The vertex sum**: over colourings extending the boundary +state, the product of the functional's vertex values. -/ +noncomputable def vertexSum {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ : F.RelTransitionSystem} (o : κ.Orientation) : ℂ := + ∑ ψ : F.EvenColouring k, + if genEvenBoundaryMatch F st hbnd ψ then + ∑ φ : F.CoreOddColouring ℓ, + if F.coreOddBoundaryMatch st φ then + ∏ v : W.Vertex, + ((F.coreOddSignAt o φ v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) + (F.coreOddListAt o φ v)) + else 0 + else 0 + +/-- **The summand is the vertex sum, weighted.** The circuit sign +and the through-edge product are the flag model's own factors; what +is left is RS21's sum over colourings. -/ +theorem throughSummand_eq_vertexSum [LinearOrder α] {W : Fragment α} + (F : EdgeSubset W) {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) + (hbnd : genBoundarySubsetMatches W F.flags st) + {κ : F.RelTransitionSystem} (o : κ.Orientation) (c : ℕ) : + F.throughSummand h st hbnd o c + = ((-1 : ℂ) ^ c) * F.throughProduct st + * F.vertexSum h st hbnd o := + rfl + +end EdgeSubset + +end RS diff --git a/LeanPool/RegtsSevenster/RS/QuantSector.lean b/LeanPool/RegtsSevenster/RS/QuantSector.lean new file mode 100644 index 0000000000..542f9a515d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/QuantSector.lean @@ -0,0 +1,79 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.TheoremForward +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SuperKill + +/-! +# Assembly of the quantitative theorem + +The quantitative Regts–Sevenster statement, assembled against the +sector bound. The sector bound (`SquareSectorBound`) is the model +half of the dichotomy: when the super permutation action kills the +square block idempotent, both sector dimensions of the standard +model lie below the side. It is discharged as +`squareSectorBound_of_detPos` in +`RS/Classical/Interfaces/SectorDischarge.lean` (sector intertwining +together with the square Schur nonvanishing); this file holds the +tower half of the dichotomy and the assembly. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +/-- **The sector bound**: super-level death of the square block +idempotent forces both dimensions of the standard model below the +side. Discharged as `squareSectorBound_of_detPos` in +`RS/Classical/Interfaces/SectorDischarge.lean`. -/ +def SquareSectorBound : Prop := + ∀ {R : ℕ} (f : EdgeRankParameter R) + (P : DelignePackage (SkeinObj f)) (k l s : ℕ), 1 ≤ s → + ∀ (e : SuperVect.Hom (stdSuperPair k l) (P.ω.obj (SkeinObj.mk 1))) + (e' : SuperVect.Hom (P.ω.obj (SkeinObj.mk 1)) (stdSuperPair k l)), + SuperVect.Hom.comp e' e = SuperVect.Hom.id (stdSuperPair k l) → + SuperVect.Hom.comp e e' = + SuperVect.Hom.id (P.ω.obj (SkeinObj.mk 1)) → + (∀ s' : ℕ, s ≤ s' → + superPermAction f P (squareDiagram s').card + (charIdempotent (nDim (jtSimple (squareDiagram s'))) + (jtChar (squareDiagram s'))) = 0) → + k < s ∧ 2 * l < s + +/-- **THE QUANTITATIVE REGTS–SEVENSTER THEOREM, CONDITIONAL ON +DELIGNE AND THE SECTOR BOUND**: every graph parameter with +edge-connection rank at most `R ^ t` is the mixed partition +function of a functional with both dimensions at most `⌊2eR⌋`. -/ +theorem regts_sevenster_quant_of_sector + (HSB : SquareSectorBound) + (hDeligne : DeligneTheoremStatement.{1, 1}) : + RegtsSevensterStatementQuant := by + intro R f + obtain ⟨P⟩ := skein_delignePackage f hDeligne + obtain ⟨k, ℓ, e, e', he'e, hee', hform, hcopair⟩ := + skein_std_model f P + have hs : 2 * Real.exp 1 * (R : ℝ) < + ((⌊2 * Real.exp 1 * (R : ℝ)⌋₊ + 1 : ℕ) : ℝ) := by + push_cast + exact Nat.lt_floor_add_one _ + have hdead : ∀ s' : ℕ, ⌊2 * Real.exp 1 * (R : ℝ)⌋₊ + 1 ≤ s' → + superPermAction f P (squareDiagram s').card + (charIdempotent (nDim (jtSimple (squareDiagram s'))) + (jtChar (squareDiagram s'))) = 0 := fun s' hs' => + superPermAction_square_dead f P + (lt_of_lt_of_le hs (by exact_mod_cast hs')) + obtain ⟨hk, hl⟩ := HSB f P k ℓ + (⌊2 * Real.exp 1 * (R : ℝ)⌋₊ + 1) (Nat.le_add_left 1 _) + e e' he'e hee' hdead + refine ⟨k, ℓ, hRS f P e', by omega, by omega, fun W => ?_⟩ + exact parameter_eq_mixedPartition f P e e' W + hee' he'e hform hcopair + +end RS diff --git a/LeanPool/RegtsSevenster/RS/StatementConverse.lean b/LeanPool/RegtsSevenster/RS/StatementConverse.lean new file mode 100644 index 0000000000..531c781bf4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/StatementConverse.lean @@ -0,0 +1,141 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.EulerianIndependence + +/-! +# The converse statement, assembled + +The converse of the Regts–Sevenster theorem: every mixed partition +function has exponentially bounded edge-connection rank, with base +the total dimension `k + 2ℓ`. This file defines the statement and +assembles it from the Eulerian independence of the Definition 5 +value (a theorem, `eulerianIndependence`) and the connection-rank +bound, which the super-Gram identity supplies downstream +(`RS/TheoremConverse.lean`). The normalization on the empty graph is +proved here: the Definition 5 value of any flagless +fragment is `(k − 2ℓ) ^ circles`. +-/ + +@[expose] public section + +namespace RS + +/-! ## The value on flagless fragments -/ + +section EmptyValue + +variable {α : Type} (W : Fragment α) + +/-- The empty edge subset of a flagless fragment. -/ +private def flaglessEmptySubset : EdgeSubset W := + ⟨∅, fun f hf => absurd hf (Finset.notMem_empty f)⟩ + +/-- The vacuous transition system on the empty subset of a +flagless fragment. -/ +private def flaglessTransition [IsEmpty W.Flag] : + (flaglessEmptySubset W).TransitionSystem where + match_ := fun f => isEmptyElim f + match_invol := fun f => isEmptyElim f + match_ne := fun f => isEmptyElim f + match_mem := fun f => isEmptyElim f + match_vertex := fun f => isEmptyElim f + attach_internal := fun f => isEmptyElim f + +/-- The vacuous orientation. -/ +private def flaglessOrientation [IsEmpty W.Flag] : + (flaglessTransition W).Orientation where + isOut := fun f => isEmptyElim f + match_flip := fun f => isEmptyElim f + pairing_flip := fun f => isEmptyElim f + +open Classical in +/-- **The Definition 5 value of a flagless fragment** is the circle +factor alone. -/ +theorem mixedPartition_of_flagless [IsEmpty W.Flag] [IsEmpty W.Vertex] + {k ℓ : ℕ} + (h : MixedFunctional k ℓ) : + mixedPartition h W = ((k : ℂ) - 2 * ℓ) ^ W.circles := by + unfold mixedPartition + rw [Fintype.sum_eq_single ∅ + (fun s hs => absurd (Finset.eq_empty_of_isEmpty s) hs)] + rw [dite_eq_left (fun f hf => absurd hf (Finset.notMem_empty f))] + rw [ite_eq_left (show (EdgeSubset.mk (∅ : Finset W.Flag) + (fun f hf => absurd hf (Finset.notMem_empty f))).Eulerian + from fun v => isEmptyElim v)] + have hval : (EdgeSubset.mk (∅ : Finset W.Flag) + (fun f hf => absurd hf (Finset.notMem_empty f))).mixedValue h = + 1 := by + have hne : Nonempty + ((κ : (flaglessEmptySubset W).TransitionSystem) × + κ.Orientation) := + ⟨⟨flaglessTransition W, flaglessOrientation W⟩⟩ + rw [show (EdgeSubset.mk (∅ : Finset W.Flag) + (fun f hf => absurd hf (Finset.notMem_empty f))) = + flaglessEmptySubset W from rfl] + rw [EdgeSubset.mixedValue, dite_eq_left hne] + unfold EdgeSubset.mixedSummand + have hcirc : ∀ κ : (flaglessEmptySubset W).TransitionSystem, + κ.circuitCount = 0 := by + intro κ + unfold EdgeSubset.TransitionSystem.circuitCount + have : IsEmpty {f : W.Flag // + f ∈ (flaglessEmptySubset W).flags} := + ⟨fun f => isEmptyElim f.val⟩ + rw [Subsingleton.elim κ.walkPerm 1, Equiv.Perm.cycleType_one] + simp + rw [hcirc, pow_zero, one_mul] + have : IsEmpty {f : W.Flag // + f ∉ (flaglessEmptySubset W).flags} := + ⟨fun f => isEmptyElim f.val⟩ + have : IsEmpty {f : W.Flag // + f ∈ (flaglessEmptySubset W).flags} := + ⟨fun f => isEmptyElim f.val⟩ + have : Subsingleton + ((flaglessEmptySubset W).EvenColouring k) := + ⟨fun a b => Subtype.ext (funext fun f => isEmptyElim f)⟩ + have : Subsingleton + ((flaglessEmptySubset W).OddColouring ℓ) := + ⟨fun a b => Subtype.ext (funext fun f => isEmptyElim f)⟩ + rw [Fintype.sum_subsingleton _ + ⟨fun f => isEmptyElim f, fun f => isEmptyElim f⟩] + rw [Fintype.sum_subsingleton _ + ⟨fun f => isEmptyElim f, fun f => isEmptyElim f⟩] + rw [Finset.univ_eq_empty, Finset.prod_empty] + rw [hval] + ring + +end EmptyValue + +/-- **The empty-graph normalization**: the Definition 5 value of +the empty closed fragment is `1`. -/ +theorem mixedPartition_empty {k ℓ : ℕ} (h : MixedFunctional k ℓ) : + mixedPartition h emptyClosedFragment = 1 := by + have : IsEmpty emptyClosedFragment.Flag := + inferInstanceAs (IsEmpty Empty) + have : IsEmpty emptyClosedFragment.Vertex := + inferInstanceAs (IsEmpty Empty) + rw [mixedPartition_of_flagless emptyClosedFragment h] + rw [show emptyClosedFragment.circles = 0 from rfl] + ring + +/-! ## The converse statement -/ + +/-- **Assembly of the converse** from the Eulerian-independence +input and the connection-rank bound. -/ +theorem converseStatement_of_rank_bounded (hInd : EulerianIndependence) + (Hrank : ∀ (k ℓ : ℕ) (hf : MixedFunctional k ℓ), + EdgeRankBounded (fun W => mixedPartition hf W) (k + 2 * ℓ)) : + RegtsSevensterConverseStatement := by + intro k ℓ hf + exact ⟨⟨fun W => mixedPartition hf W, mixedPartition_empty hf, + fun W₁ W₂ e => mixedPartition_transport hInd e hf, + (Hrank k ℓ hf).mono (le_max_right 1 (k + 2 * ℓ))⟩, + fun W => rfl⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Summit.lean b/LeanPool/RegtsSevenster/RS/Summit.lean new file mode 100644 index 0000000000..35830802bd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Summit.lean @@ -0,0 +1,104 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.TheoremConverse +public import LeanPool.RegtsSevenster.RS.TheoremTotal +public import LeanPool.RegtsSevenster.RS.TheoremPadding +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DeligneAssembly + +/-! +# The theorems, unconditionally + +The theorems of record, carrying no hypothesis: Deligne's theorem, +in fibre-functor form, is `RS.deligne_theorem` +(`RS/Classical/Deligne/DeligneAssembly.lean`), +so the forms in `RS/TheoremForward.lean`, `RS/TheoremQuant.lean`, +`RS/TheoremTotal.lean`, `RS/TheoremDimension.lean`, +`RS/TheoremPadding.lean` and `RS/TheoremConverse.lean` that take it as +an argument are applied to +it here. Those forms remain available alongside: they exhibit the +dependency structure, which is what a reader checking the argument +against the literature wants. + +The envelope's semisimplicity and abelianness come from the +factorial trace obstruction. `Assembly/BlueprintFactorial` checks +that the forward summits use this theorem and exclude the appendix +nilpotent-trace and trace-zeta mechanisms. + +The axiom checks are pinned in +`RS/Assembly/BlueprintDeligne.lean`. +-/ + +@[expose] public section + +namespace RS + +/-- **The Regts–Sevenster theorem**: every graph parameter with +exponentially bounded edge-connection rank is a mixed partition +function. -/ +theorem regts_sevenster : RegtsSevensterStatement := + regts_sevenster_deligne_only deligne_theorem + +/-- **The Regts–Sevenster theorem, quantitative form**. -/ +theorem regts_sevenster_quant : RegtsSevensterStatementQuant := + regts_sevenster_quant_deligne_only deligne_theorem + +/-- The Regts–Sevenster theorem with at most `R` colours in total: +the representing functional satisfies `k + 2 * ℓ ≤ R`. -/ +theorem regts_sevenster_total : RegtsSevensterStatementTotal := + regts_sevenster_total_deligne_only deligne_theorem + +/-- Every parameter with exponentially bounded connection rank has +a model attaining its minimum total colour dimension. -/ +theorem regts_sevenster_minimum {R : ℕ} (f : EdgeRankParameter R) : + IsMixedPartitionFunctionTotalBounded f.val + (minimumColourDimension f.val) := + regts_sevenster_minimum_deligne_only deligne_theorem f + +/-- The even connection-rank growth rate is the minimum total +number of colours of a representing mixed model. -/ +theorem regts_sevenster_rank_growth {R : ℕ} (f : EdgeRankParameter R) : + Filter.Tendsto + (fun n => (connectionRank f.val (2 * n) : ℝ) ^ + ((2 * n : ℕ) : ℝ)⁻¹) + Filter.atTop (nhds (minimumColourDimension f.val : ℝ)) := + regts_sevenster_rank_growth_deligne_only deligne_theorem f + +/-- Prescribed parity dimensions are characterized by the total +rank bound and the free-circle value. -/ +theorem regts_sevenster_prescribed + (f : ClosedFragment → ℂ) + (hempty : f emptyClosedFragment = 1) + (hiso : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) + (k ℓ : ℕ) : + (∃ h : MixedFunctional k ℓ, h.Represents f) ↔ + PrescribedColourBounds f k ℓ := + regts_sevenster_prescribed_deligne_only deligne_theorem f hempty hiso k ℓ + +/-- **The characterisation**: for a normalised isomorphism-invariant +parameter, bounded edge-connection rank and being a mixed partition +function are equivalent. -/ +theorem regts_sevenster_characterisation (f : ClosedFragment → ℂ) + (hempty : f emptyClosedFragment = 1) + (hiso : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) : + (∃ R : ℕ, EdgeRankBounded f R) ↔ IsMixedPartitionFunction f := + regts_sevenster_iff deligne_theorem f hempty hiso + +/-- **The quantitative round trip**. -/ +theorem regts_sevenster_quant_characterisation + (f : ClosedFragment → ℂ) + (hempty : f emptyClosedFragment = 1) + (hiso : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) : + (∀ R, EdgeRankBounded f R → + IsMixedPartitionFunctionBounded f + ⌊2 * Real.exp 1 * (R : ℝ)⌋₊) ∧ + (∀ B, IsMixedPartitionFunctionBounded f B → + EdgeRankBounded f (max 1 (2 * B))) := + regts_sevenster_quant_roundtrip deligne_theorem f hempty hiso + +end RS diff --git a/LeanPool/RegtsSevenster/RS/TheoremConverse.lean b/LeanPool/RegtsSevenster/RS/TheoremConverse.lean new file mode 100644 index 0000000000..53ac460cdc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/TheoremConverse.lean @@ -0,0 +1,95 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseIdentity + +/-! +# The Regts–Sevenster theorem, both directions + +The super-Gram identity is a theorem +(`EdgeSubset.superGramIdentity`), so the converse holds with no +hypothesis at all: every mixed partition function is an +edge-rank-bounded parameter. With it the characterization and the +quantitative round trip rest on Deligne alone. +-/ + +@[expose] public section + +namespace RS + + + +/-- The converse rank bound with the exact total dimension as its +base, including the zero-dimensional model. -/ +theorem mixedPartition_edgeRankBounded {k ℓ : ℕ} + (h : MixedFunctional k ℓ) : + EdgeRankBounded (fun W => mixedPartition h W) (k + 2 * ℓ) := + edgeRankBounded_of_superGram (fragmentTensor h) + (EdgeSubset.superGramIdentity h) + +/-- **THE CONVERSE** (Regts–Sevenster, arXiv:1807.04494, Theorem 6): +every mixed partition function is an edge-rank-bounded parameter, +with base `max 1 (k + 2ℓ)`. -/ +theorem regts_sevenster_converse : RegtsSevensterConverseStatement := + EdgeSubset.regtsSevensterConverse + +/-- **The rank bound from a bounded mixed partition function.** -/ +theorem edgeRankBounded_of_mixedBounded + {f : ClosedFragment → ℂ} {B : ℕ} + (hf : IsMixedPartitionFunctionBounded f B) : + EdgeRankBounded f (max 1 (2 * B)) := by + obtain ⟨k, ℓ, h, hk, hℓ, hval⟩ := hf + obtain ⟨g, hg⟩ := regts_sevenster_converse k ℓ h + have hfg : f = g.val := by + funext W + rw [hval W, hg W] + rw [hfg] + exact g.rank_bounded.mono (by omega) + +/-- **THE CHARACTERIZATION**, conditional on Deligne alone: a +fragment parameter has bounded edge rank exactly when it is a mixed +partition function. -/ +theorem regts_sevenster_iff + (hDeligne : DeligneTheoremStatement.{1, 1}) + (f : ClosedFragment → ℂ) + (hempty : f emptyClosedFragment = 1) + (hiso : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) : + (∃ R : ℕ, EdgeRankBounded f R) ↔ IsMixedPartitionFunction f := by + constructor + · rintro ⟨R, hR⟩ + exact regts_sevenster_deligne_only hDeligne R + ⟨f, hempty, hiso, hR⟩ + · rintro ⟨k, ℓ, h, hval⟩ + obtain ⟨g, hg⟩ := regts_sevenster_converse k ℓ h + refine ⟨max 1 (k + 2 * ℓ), ?_⟩ + have hf : f = fun W => mixedPartition h W := funext hval + have hgv : g.val = fun W => mixedPartition h W := funext hg + rw [hf, ← hgv] + exact g.rank_bounded + +/-- **THE QUANTITATIVE ROUND TRIP**, conditional on Deligne alone: +edge rank `R` gives dimension `⌊2eR⌋`, and dimension `B` gives edge +rank base `max 1 (2B)`. -/ +theorem regts_sevenster_quant_roundtrip + (hDeligne : DeligneTheoremStatement.{1, 1}) + (f : ClosedFragment → ℂ) + (hempty : f emptyClosedFragment = 1) + (hiso : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) : + (∀ R, EdgeRankBounded f R → + IsMixedPartitionFunctionBounded f + ⌊2 * Real.exp 1 * (R : ℝ)⌋₊) ∧ + (∀ B, IsMixedPartitionFunctionBounded f B → + EdgeRankBounded f (max 1 (2 * B))) := by + constructor + · intro R hR + exact regts_sevenster_quant_deligne_only hDeligne R + ⟨f, hempty, hiso, hR⟩ + · intro B hf + exact edgeRankBounded_of_mixedBounded hf + +end RS diff --git a/LeanPool/RegtsSevenster/RS/TheoremDimension.lean b/LeanPool/RegtsSevenster/RS/TheoremDimension.lean new file mode 100644 index 0000000000..d9d8cae134 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/TheoremDimension.lean @@ -0,0 +1,119 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.TheoremTotal +public import LeanPool.RegtsSevenster.RS.TheoremConverse + +/-! +# Minimum colour dimension and connection-rank growth + +The total dimension of the reconstructed standard model is minimal +among all mixed models of the parameter. Its value is the limit of +the even roots of the actual connection ranks. The assembly is +conditional on Deligne's theorem, discharged in `RS/Summit.lean`. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +/-- A representing model bounds the minimum total colour dimension. -/ +theorem minimumColourDimension_le_of_represents + {f : ClosedFragment → ℂ} {k ℓ : ℕ} (h : MixedFunctional k ℓ) + (hrep : h.Represents f) : minimumColourDimension f ≤ k + 2 * ℓ := + Nat.sInf_le (show IsMixedPartitionFunctionTotalBounded f (k + 2 * ℓ) + from ⟨⟨k, ℓ, h, le_rfl, hrep⟩⟩) + +/-- Every parameter admitting a mixed model admits one at the least +total colour bound. -/ +theorem minimumColourDimension_attained {f : ClosedFragment → ℂ} + (hf : IsMixedPartitionFunction f) : + IsMixedPartitionFunctionTotalBounded f (minimumColourDimension f) := by + apply Nat.sInf_mem (s := {d | IsMixedPartitionFunctionTotalBounded f d}) + obtain ⟨k, ℓ, h, hrep⟩ := hf + exact ⟨k + 2 * ℓ, ⟨⟨k, ℓ, h, le_rfl, hrep⟩⟩⟩ + +/-- A model at the least colour bound has exactly that total +dimension, rather than merely a dimension bounded by it. -/ +theorem TotalBoundedMixedModel.dimension_eq_minimum + {f : ClosedFragment → ℂ} + (M : TotalBoundedMixedModel f (minimumColourDimension f)) : + M.k + 2 * M.ℓ = minimumColourDimension f := + le_antisymm M.dimension_le + (minimumColourDimension_le_of_represents M.functional M.partition_eq) + +/-- A represented parameter satisfies the rank bound with the +representing model's exact total dimension. -/ +theorem MixedFunctional.Represents.edgeRankBounded + {f : ClosedFragment → ℂ} {k ℓ : ℕ} {h : MixedFunctional k ℓ} + (hrep : h.Represents f) : EdgeRankBounded f (k + 2 * ℓ) := by + rw [show f = fun W => mixedPartition h W from funext hrep] + exact mixedPartition_edgeRankBounded h + +/-- The standard model's dimension is the intrinsic minimum as +soon as its graph evaluations agree with the parameter. -/ +theorem stdModel_dimension_eq_minimum {R k ℓ : ℕ} + (f : EdgeRankParameter R) (P : DelignePackage (SkeinObj f)) + (e : stdSuperPair k ℓ ≅ strandImage f P) + (h : MixedFunctional k ℓ) (hrep : h.Represents f.val) : + k + 2 * ℓ = minimumColourDimension f.val := by + obtain ⟨M⟩ := minimumColourDimension_attained + (show IsMixedPartitionFunction f.val from ⟨k, ℓ, h, hrep⟩) + have hsmall : k + 2 * ℓ ≤ M.k + 2 * M.ℓ := + stdModel_total_dimension_le_of_rank_bound f P e + (show M.functional.Represents f.val from M.partition_eq).edgeRankBounded + exact le_antisymm (hsmall.trans M.dimension_le) + (minimumColourDimension_le_of_represents h hrep) + +/-- The even roots of the connection ranks tend to the total +dimension of the reconstructed standard model. -/ +theorem stdModel_connectionRank_growth {R k ℓ : ℕ} + (f : EdgeRankParameter R) (P : DelignePackage (SkeinObj f)) + (e : stdSuperPair k ℓ ≅ strandImage f P) + (h : MixedFunctional k ℓ) (hrep : h.Represents f.val) : + Filter.Tendsto + (fun n => (connectionRank f.val (2 * n) : ℝ) ^ + ((2 * n : ℕ) : ℝ)⁻¹) + Filter.atTop (nhds ((k + 2 * ℓ : ℕ) : ℝ)) := + tendsto_even_root_of_polynomial_bounds _ (k + 2 * ℓ) + (2 * (k + 2 * ℓ) ^ 2) (stdModel_pow_le_connectionRank f P e) + (fun n => connectionRank_le_pow hrep.edgeRankBounded (2 * n)) + +/-- Exponentially bounded connection rank admits a model attaining +the minimum total colour dimension, conditional on Deligne alone. -/ +theorem regts_sevenster_minimum_deligne_only + (hDeligne : DeligneTheoremStatement.{1, 1}) {R : ℕ} + (f : EdgeRankParameter R) : + IsMixedPartitionFunctionTotalBounded f.val + (minimumColourDimension f.val) := + minimumColourDimension_attained + (regts_sevenster_deligne_only hDeligne R f) + +/-- The even connection-rank growth rate exists and equals the +minimum total colour dimension, conditional on Deligne alone. -/ +theorem regts_sevenster_rank_growth_deligne_only + (hDeligne : DeligneTheoremStatement.{1, 1}) {R : ℕ} + (f : EdgeRankParameter R) : + Filter.Tendsto + (fun n => (connectionRank f.val (2 * n) : ℝ) ^ + ((2 * n : ℕ) : ℝ)⁻¹) + Filter.atTop (nhds (minimumColourDimension f.val : ℝ)) := by + obtain ⟨P⟩ := skein_delignePackage f hDeligne + obtain ⟨k, ℓ, e, e', he'e, hee', hform, hcopair⟩ := + skein_std_model f P + let eModel : stdSuperPair k ℓ ≅ strandImage f P := + ⟨e, e', he'e, hee'⟩ + have hrep : (hRS f P e').Represents f.val := fun W => + parameter_eq_mixedPartition f P e e' W hee' he'e hform hcopair + have hdim := stdModel_dimension_eq_minimum f P eModel _ hrep + simpa only [hdim] using + stdModel_connectionRank_growth f P eModel _ hrep + +end RS diff --git a/LeanPool/RegtsSevenster/RS/TheoremForward.lean b/LeanPool/RegtsSevenster/RS/TheoremForward.lean new file mode 100644 index 0000000000..e3e496f8ef --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/TheoremForward.lean @@ -0,0 +1,42 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexHeart +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDelignePackage + +/-! +# The Regts–Sevenster theorem, forward direction + +The forward direction conditional on Deligne's theorem. The +factorial trace obstruction supplies semisimplicity and abelianness +of the envelope from the connection-rank bound, without a Schur +package. The resulting fibre functor provides the mixed model. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +/-- **THE REGTS–SEVENSTER THEOREM, CONDITIONAL ON DELIGNE +ALONE**: the factorial trace obstruction verifies the envelope +hypotheses, and Deligne's fibre functor reconstructs a mixed +partition function. -/ +theorem regts_sevenster_deligne_only + (hDeligne : DeligneTheoremStatement.{1, 1}) : + RegtsSevensterStatement := by + intro R f + obtain ⟨P⟩ := skein_delignePackage f hDeligne + obtain ⟨k, ℓ, e, e', he'e, hee', hform, hcopair⟩ := + skein_std_model f P + refine ⟨k, ℓ, hRS f P e', fun W => ?_⟩ + exact parameter_eq_mixedPartition f P e e' W + hee' he'e hform hcopair + +end RS diff --git a/LeanPool/RegtsSevenster/RS/TheoremPadding.lean b/LeanPool/RegtsSevenster/RS/TheoremPadding.lean new file mode 100644 index 0000000000..f27dc4f0ef --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/TheoremPadding.lean @@ -0,0 +1,94 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.TheoremDimension +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourPadding + +/-! +# Prescribed parity dimensions + +The free-circle value fixes the difference of the parity dimensions. +The total-dimension theorem therefore bounds both dimensions by any +prescribed compatible pair. Extension by zero then gives a model on +exactly that pair of colour spaces. +-/ + +@[expose] public section + +namespace RS + +/-- A disjoint union of free circles evaluates to the corresponding +power of the superdimension. -/ +theorem mixedPartition_circlesClosed {k ℓ : ℕ} + (h : MixedFunctional k ℓ) (c : ℕ) : + mixedPartition h (circlesClosed c) = ((k : ℂ) - 2 * ℓ) ^ c := by + let : IsEmpty (circlesClosed c).Flag := inferInstanceAs (IsEmpty Empty) + let : IsEmpty (circlesClosed c).Vertex := inferInstanceAs (IsEmpty Empty) + exact mixedPartition_of_flagless (circlesClosed c) h + +/-- Every representing model has superdimension equal to the +parameter's free-circle value. -/ +theorem MixedFunctional.Represents.circle_eq + {f : ClosedFragment → ℂ} {k ℓ : ℕ} {h : MixedFunctional k ℓ} + (hrep : h.Represents f) : f (circlesClosed 1) = (k : ℂ) - 2 * ℓ := by + rw [hrep, mixedPartition_circlesClosed, pow_one] + +/-- The minimum total dimension and free-circle value determine +the even dimension of every minimal model. -/ +theorem TotalBoundedMixedModel.even_dimension_eq + {f : ClosedFragment → ℂ} + (M : TotalBoundedMixedModel f (minimumColourDimension f)) : + (M.k : ℂ) = ((minimumColourDimension f : ℂ) + f (circlesClosed 1)) / 2 := by + have hcircle := (show M.functional.Represents f from M.partition_eq).circle_eq + have hdim : (minimumColourDimension f : ℂ) = (M.k : ℂ) + 2 * M.ℓ := by + exact_mod_cast M.dimension_eq_minimum.symm + rw [hcircle, hdim] + ring + +/-- The minimum total dimension and free-circle value determine +half the odd dimension of every minimal model. -/ +theorem TotalBoundedMixedModel.half_odd_dimension_eq + {f : ClosedFragment → ℂ} + (M : TotalBoundedMixedModel f (minimumColourDimension f)) : + (M.ℓ : ℂ) = ((minimumColourDimension f : ℂ) - f (circlesClosed 1)) / 4 := by + have hcircle := (show M.functional.Represents f from M.partition_eq).circle_eq + have hdim : (minimumColourDimension f : ℂ) = (M.k : ℂ) + 2 * M.ℓ := by + exact_mod_cast M.dimension_eq_minimum.symm + rw [hcircle, hdim] + ring + +/-- A normalized invariant parameter has a model with prescribed +parity dimensions exactly when its ranks and free-circle value +satisfy the corresponding bounds, conditional on Deligne alone. -/ +theorem regts_sevenster_prescribed_deligne_only + (hDeligne : DeligneTheoremStatement.{1, 1}) + (f : ClosedFragment → ℂ) + (hempty : f emptyClosedFragment = 1) + (hiso : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) + (K L : ℕ) : + (∃ h : MixedFunctional K L, h.Represents f) ↔ + PrescribedColourBounds f K L := by + constructor + · rintro ⟨h, hrep⟩ + exact ⟨hrep.circle_eq, hrep.edgeRankBounded⟩ + · intro hbounds + let g : EdgeRankParameter (K + 2 * L) := + ⟨f, hempty, hiso, hbounds.rank_bounded⟩ + obtain ⟨M⟩ := regts_sevenster_total_deligne_only hDeligne _ g + have hrep : M.functional.Represents f := M.partition_eq + have hcircle : (M.k : ℂ) - 2 * M.ℓ = (K : ℂ) - 2 * L := + hrep.circle_eq.symm.trans hbounds.circle_eq + have hdim := M.dimension_le + have hcircleInt : (M.k : ℤ) - 2 * M.ℓ = (K : ℤ) - 2 * L := by + exact_mod_cast hcircle + have hk : M.k ≤ K := by omega + have hℓ : M.ℓ ≤ L := by omega + exact ⟨M.functional.padColours hk hℓ, + M.functional.padColours_represents hk hℓ hcircle.symm hrep⟩ + +end RS diff --git a/LeanPool/RegtsSevenster/RS/TheoremQuant.lean b/LeanPool/RegtsSevenster/RS/TheoremQuant.lean new file mode 100644 index 0000000000..5ce8aa6978 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/TheoremQuant.lean @@ -0,0 +1,44 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SectorDischarge +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.LGVStrict + +/-! +# The quantitative theorem, one determinant from Deligne-only + +The sector bound is a theorem given the negated square Schur +nonvanishing, so the quantitative Regts–Sevenster statement rests +on Deligne's theorem and one binomial determinant. +-/ + +@[expose] public section + +namespace RS + +/-- **THE QUANTITATIVE REGTS–SEVENSTER THEOREM, CONDITIONAL ON +DELIGNE AND THE BINOMIAL DETERMINANT.** -/ +theorem regts_sevenster_quant_of_detPos + (H : SquareBinomialDetPos) + (hDeligne : DeligneTheoremStatement.{1, 1}) : + RegtsSevensterStatementQuant := + regts_sevenster_quant_of_sector + (squareSectorBound_of_detPos H) hDeligne + +/-- **THE QUANTITATIVE REGTS–SEVENSTER THEOREM, CONDITIONAL ON +DELIGNE ALONE**: the binomial determinant is a theorem +(Lindström–Gessel–Viennot), so every graph parameter with +edge-connection rank at most `R ^ t` is the mixed partition +function of a functional with both dimensions at most `⌊2eR⌋`, +assuming only Deligne's theorem on tensor categories. -/ +theorem regts_sevenster_quant_deligne_only + (hDeligne : DeligneTheoremStatement.{1, 1}) : + RegtsSevensterStatementQuant := + regts_sevenster_quant_of_detPos squareBinomialDetPos hDeligne + +end RS diff --git a/LeanPool/RegtsSevenster/RS/TheoremTotal.lean b/LeanPool/RegtsSevenster/RS/TheoremTotal.lean new file mode 100644 index 0000000000..9b13510601 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/TheoremTotal.lean @@ -0,0 +1,47 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS.TheoremForward +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.TotalDimension + +/-! +# The total-dimension Regts–Sevenster theorem + +The reconstructed standard model has at most `R` colours in total. +The extraction and graph-evaluation proof are those of the forward +theorem; the dimension bound comes from the polynomial commutant +estimate for the full signed colour action. +-/ + +@[expose] public section + +namespace RS + +open CategoryTheory + +/-- The Regts–Sevenster theorem with `k + 2 * ℓ ≤ R`, conditional +on Deligne's theorem alone. -/ +theorem regts_sevenster_total_deligne_only + (hDeligne : DeligneTheoremStatement.{1, 1}) : + RegtsSevensterStatementTotal := by + intro R f + obtain ⟨P⟩ := skein_delignePackage f hDeligne + obtain ⟨k, ℓ, e, e', he'e, hee', hform, hcopair⟩ := + skein_std_model f P + refine ⟨{ + k := k + ℓ := ℓ + functional := hRS f P e' + dimension_le := ?_ + partition_eq := fun W => parameter_eq_mixedPartition + f P e e' W hee' he'e hform hcopair + }⟩ + exact stdModel_total_dimension_le f P + { hom := e, inv := e', hom_inv_id := he'e, inv_hom_id := hee' } + +end RS diff --git a/LeanPool/RegtsSevenster/Solution.lean b/LeanPool/RegtsSevenster/Solution.lean new file mode 100644 index 0000000000..e0352aa0c4 --- /dev/null +++ b/LeanPool/RegtsSevenster/Solution.lean @@ -0,0 +1,76 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +module + +public import LeanPool.RegtsSevenster.RS + +/-! +# The certification solution + +The theorems of `Challenge.lean`, each proved by the theorem of +record of the same name. Comparator confirms at the kernel-export +level that the statements match the challenge's, that the proofs +use no axiom outside `[propext, Classical.choice, Quot.sound]`, and +that the kernel accepts them; see `comparator-config.json` and the +CI workflow. +-/ + +@[expose] public section + +namespace Certified + +open RS + +/-- **The converse**: every mixed partition function is an +edge-rank-bounded parameter, with base `max 1 (k + 2ℓ)`. -/ +theorem regts_sevenster_converse : RegtsSevensterConverseStatement := + RS.regts_sevenster_converse + +/-- **The rank bound from a bounded mixed partition function.** -/ +theorem edgeRankBounded_of_mixedBounded + {f : ClosedFragment → ℂ} {B : ℕ} + (hf : IsMixedPartitionFunctionBounded f B) : + EdgeRankBounded f (max 1 (2 * B)) := + RS.edgeRankBounded_of_mixedBounded hf + +/-- **The forward direction**, with no hypothesis. -/ +theorem regts_sevenster : RegtsSevensterStatement := + RS.regts_sevenster + +/-- **The quantitative forward direction**, with no hypothesis: +both dimensions at most `⌊2eR⌋`. -/ +theorem regts_sevenster_quant : RegtsSevensterStatementQuant := + RS.regts_sevenster_quant + +/-- The total-dimension forward direction: the representing model +has `k + 2 * ℓ ≤ R`. -/ +theorem regts_sevenster_total : RegtsSevensterStatementTotal := + RS.regts_sevenster_total + +/-- **The characterisation**: a fragment parameter has bounded edge +rank exactly when it is a mixed partition function. -/ +theorem regts_sevenster_characterisation + (f : ClosedFragment → ℂ) + (hempty : f emptyClosedFragment = 1) + (hiso : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) : + (∃ R : ℕ, EdgeRankBounded f R) ↔ IsMixedPartitionFunction f := + RS.regts_sevenster_characterisation f hempty hiso + +/-- **The quantitative round trip**: edge rank `R` gives dimension +`⌊2eR⌋`, and dimension `B` gives edge rank base `max 1 (2B)`. -/ +theorem regts_sevenster_quant_characterisation + (f : ClosedFragment → ℂ) + (hempty : f emptyClosedFragment = 1) + (hiso : ∀ W₁ W₂ : ClosedFragment, W₁.Equiv W₂ → f W₁ = f W₂) : + (∀ R, EdgeRankBounded f R → + IsMixedPartitionFunctionBounded f + ⌊2 * Real.exp 1 * (R : ℝ)⌋₊) ∧ + (∀ B, IsMixedPartitionFunctionBounded f B → + EdgeRankBounded f (max 1 (2 * B))) := + RS.regts_sevenster_quant_characterisation f hempty hiso + +end Certified diff --git a/LeanPool/projects.yml b/LeanPool/projects.yml index 5d174fc0b3..648f4d35fe 100644 --- a/LeanPool/projects.yml +++ b/LeanPool/projects.yml @@ -10563,3 +10563,49 @@ projects: - 20E05 - 68Q45 - 03B35 + - slug: regts-sevenster + title: A proof of the Regts–Sevenster conjecture, formalized + summary: A Lean 4 proof of the Regts–Sevenster conjecture. A complex-valued graph + parameter, normalized at the empty graph and invariant under isomorphism, has + exponentially bounded edge-connection rank if and only if it is a mixed partition + function. For a natural rank base R, a representing model can be chosen with k + even and 2ℓ odd colours satisfying k + 2ℓ ≤ R. The development also proves the + even connection-rank growth limit, minimum total colour dimension, minimal parity + formulas and prescribed-dimension criterion. Schrijver's factorial argument supplies + nilpotent-trace vanishing; semisimplicity and Deligne's fibre-functor theorem + give the model; a polynomial commutant estimate gives the sharp colour budget. + Deligne's theorem and the required symmetric-group character theory are proved + within the development. The appendix's trace-zeta results give rationality and + degree bounds, with an independent proof of nilpotent-trace vanishing. The theorems + of record use only propext, Classical.choice and Quot.sound, checked by pinned + audits. + branch: algebraic graph theory + entry_module: LeanPool.RegtsSevenster + authors: + - William Whistler + source: + url: https://github.com/willwhistler/regts-sevenster + github_repo: willwhistler/regts-sevenster + commit: bb0a60543d48afac3f36938104b5c85c7c0396c7 + license: Apache-2.0 + status: verified + provenance: AI + main_declarations: + - RS.regts_sevenster_characterisation + main_results: + - declaration: RS.regts_sevenster_characterisation + informal: Normalized isomorphism-invariant complex graph parameters with exponentially + bounded edge-connection ranks are precisely mixed partition functions. + - declaration: RS.regts_sevenster_total + informal: A natural rank bound R admits a representing mixed model with total + color dimension at most R. + - declaration: RS.deligne_theorem + informal: The development proves its stated Deligne fiber-functor theorem for + the symmetric tensor categories used in the representation. + tags: + - graph-parameters + - tensor-categories + - partition-functions + msc: + - 05C50 + - 18M20